From c299f186ff9693fc88859daef037e3d94cc7c0ff Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Tue, 20 Jun 2000 22:26:41 +0000 Subject: [PATCH 0001/2047] *** empty log message *** --- GUILE-VERSION | 2 +- NEWS | 13 +++++++++++++ README | 6 +++++- THANKS | 37 ------------------------------------- 4 files changed, 19 insertions(+), 39 deletions(-) diff --git a/GUILE-VERSION b/GUILE-VERSION index 6be0dac1b..97644762a 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -1,5 +1,5 @@ GUILE_MAJOR_VERSION=1 -GUILE_MINOR_VERSION=4 +GUILE_MINOR_VERSION=4.1 GUILE_VERSION=${GUILE_MAJOR_VERSION}.${GUILE_MINOR_VERSION} # For automake. diff --git a/NEWS b/NEWS index 105f7390d..e46483f55 100644 --- a/NEWS +++ b/NEWS @@ -3,6 +3,19 @@ Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc. See the end for copying conditions. Please send Guile bug reports to bug-guile@gnu.org. + +Changes since Guile 1.4: + +* Changes to the distribution + +* Changes to the stand-alone interpreter + +* Changes to Scheme functions and syntax + +* Changes to the gh_ interface + +* Changes to the scm_ interface + Changes since Guile 1.3.4: diff --git a/README b/README index 9b60ceafa..b58be0e2c 100644 --- a/README +++ b/README @@ -1,4 +1,8 @@ -This is version 1.4 of Guile, Project GNU's extension language +This is not a Guile release; it is a source tree retrieved via +anonymous CVS or as a nightly snapshot at some random time after the +Guile 1.4 release. + +This is version 1.4.1 of Guile, Project GNU's extension language library. Guile is an interpreter for Scheme, packaged as a library that you can link into your applications to give them their own scripting language. Guile will eventually support other languages as diff --git a/THANKS b/THANKS index bc1b731f9..05b5810f7 100644 --- a/THANKS +++ b/THANKS @@ -7,42 +7,5 @@ The Guile maintainer committee consists of Contributors since the last release: - Greg Badros - Jim Blandy - Mikael Djurfeldt - Dirk Herrmann - Gary Houston - Michael Livshin - Thomas Tanner - Marius Vollmer - For fixes or providing information which led to a fix: - Lauri Alanko - Craig Brozefsky - Diego Dainese - Mark Galassi - Ian Grant - Greg Harvey - Karl M. Hegbloom - Jon Hellan - Richard Kim - Brad Knotwell - Tim Mooney - Eric Moore - Thien-Thi Nguyen -Kalle Olavi Niemitalo - Han-Wen Nienhuys - Jan Nieuwenhuizen - Keisuke Nishida - Roland Orre - Bertrand Petit - Jorgen Schaefer - Bill Schottstaedt - Daniel Skarda - Dale P. Smith - Ivan Toshkov - Tal Tversky - Bernard Urban - Lynn Winebarger - Ryan Yeske From 032926310669468a29f9a7f7e41322dc5558feca Mon Sep 17 00:00:00 2001 From: Jim Blandy Date: Tue, 20 Jun 2000 22:58:10 +0000 Subject: [PATCH 0002/2047] Remove instructions for updating the Majordomo info for the mailing list. We don't use majordomo any more, and the new list has no info to be updated. --- RELEASE | 2 -- 1 file changed, 2 deletions(-) diff --git a/RELEASE b/RELEASE index dfd225518..5a104c8b5 100644 --- a/RELEASE +++ b/RELEASE @@ -173,5 +173,3 @@ Punting checklist: version numbers of the form "N.M.L", where L is odd. * Start a new section of the NEWS file. * Start a new THANKS file. -* Send mail to majordomo-owner@cygnus.com updating the message you - get when you ask majordomo for "info guile". From ce7ac2fe785bce4d69170906c0266156659b4850 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 21 Jun 2000 01:16:26 +0000 Subject: [PATCH 0003/2047] New modules null.scm, r5rs.scm, safe-r5rs.scm, safe.scm --- ice-9/Makefile.am | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index 5488d1b01..0c57fd7cb 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -22,16 +22,14 @@ AUTOMAKE_OPTIONS = foreign # These should be installed and distributed. -ice9_sources = \ - and-let*.scm arrays.scm boot-9.scm \ - calling.scm common-list.scm debug.scm \ - debugger.scm documentation.scm emacs.scm expect.scm format.scm \ - getopt-long.scm hcons.scm lineio.scm \ - ls.scm mapping.scm networking.scm \ - optargs.scm poe.scm popen.scm posix.scm \ - psyntax.pp psyntax.ss q.scm \ - r4rs.scm regex.scm runq.scm session.scm slib.scm \ - streams.scm string-fun.scm syncase.scm tags.scm threads.scm +ice9_sources = \ + and-let*.scm arrays.scm boot-9.scm calling.scm common-list.scm \ + debug.scm debugger.scm documentation.scm emacs.scm expect.scm \ + format.scm getopt-long.scm hcons.scm lineio.scm ls.scm \ + mapping.scm networking.scm null.scm optargs.scm poe.scm popen.scm \ + posix.scm psyntax.pp psyntax.ss q.scm r4rs.scm r5rs.scm \ + regex.scm runq.scm safe-r5rs.scm safe.scm session.scm slib.scm \ + streams.scm string-fun.scm syncase.scm tags.scm threads.scm subpkgdatadir = $(pkgdatadir)/$(VERSION)/ice-9 subpkgdata_DATA = $(ice9_sources) From 90847923a4ba78f9b156095a4ec5c54f539aad58 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 21 Jun 2000 01:16:45 +0000 Subject: [PATCH 0004/2047] * boot-9.scm (purify-module!, module-export!): New procedures. (export): Rewritten using `module-export!'. (process-define-module): New define-module options: pure, export. See NEWS. --- ice-9/boot-9.scm | 35 +++++++++++++++++++++++++---------- 1 file changed, 25 insertions(+), 10 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index ec7c3ead8..e2b6cbe4f 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1741,6 +1741,13 @@ (not (eq? module the-root-module))) (set-module-uses! module (append (module-uses module) (list the-scm-module))))) +(define (purify-module! module) + "Removes bindings in MODULE which are inherited from the (guile) module." + (let ((use-list (module-uses module))) + (if (and (pair? use-list) + (eq? (car (last-pair use-list)) the-scm-module)) + (set-module-uses! module (reverse (cdr (reverse use-list))))))) + ;; NOTE: This binding is used in libguile/modules.c. ;; (define (make-modules-in module name) @@ -1816,6 +1823,14 @@ ((no-backtrace) (set-system-module! module #t) (loop (cdr kws) reversed-interfaces)) + ((pure) + (purify-module! module) + (loop (cdr kws) reversed-interfaces)) + ((export) + (if (not (and (pair? (cdr kws)) (pair? (cddr kws)))) + (error "unrecognized defmodule argument" kws)) + (module-export! module (cadr kws)) + (loop (cddr kws) reversed-interfaces)) (else (error "unrecognized defmodule argument" kws)))))) module)) @@ -2738,21 +2753,21 @@ (defmacro ,@ args)))))) +(define (module-export! m names) + (let ((public-i (module-public-interface m))) + (for-each (lambda (name) + ;; Make sure there is a local variable: + (module-define! m name (module-ref m name #f)) + ;; Make sure that local is exported: + (module-add! public-i name (module-variable m name))) + names))) + (defmacro export names - `(let* ((m (current-module)) - (public-i (module-public-interface m))) - (for-each (lambda (name) - ;; Make sure there is a local variable: - (module-define! m name (module-ref m name #f)) - ;; Make sure that local is exported: - (module-add! public-i name (module-variable m name))) - ',names))) + `(module-export! (current-module) ',names)) (define export-syntax export) - - (define load load-module) From affb914f39ece0ed19fe8ffd80fb9f6dd76c843f Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 21 Jun 2000 01:17:28 +0000 Subject: [PATCH 0005/2047] * null.scm, r5rs.scm, safe-r5rs.scm, safe.scm: New modules. --- ice-9/null.scm | 38 ++++++++++++ ice-9/r5rs.scm | 51 ++++++++++++++++ ice-9/safe-r5rs.scm | 143 ++++++++++++++++++++++++++++++++++++++++++++ ice-9/safe.scm | 31 ++++++++++ 4 files changed, 263 insertions(+) create mode 100644 ice-9/null.scm create mode 100644 ice-9/r5rs.scm create mode 100644 ice-9/safe-r5rs.scm create mode 100644 ice-9/safe.scm diff --git a/ice-9/null.scm b/ice-9/null.scm new file mode 100644 index 000000000..594267bd2 --- /dev/null +++ b/ice-9/null.scm @@ -0,0 +1,38 @@ +;;;; Copyright (C) 2000 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; + +;;;; The null environment - only syntactic bindings + +(define-module (ice-9 null) + :use-module (ice-9 syncase)) + +(export define quote lambda if set! + + cond case and or + + let let* letrec + + begin do + + delay + + quasiquote unquote unquote-splicing + + define-syntax + let-syntax letrec-syntax + ) diff --git a/ice-9/r5rs.scm b/ice-9/r5rs.scm new file mode 100644 index 000000000..a3d0d2f66 --- /dev/null +++ b/ice-9/r5rs.scm @@ -0,0 +1,51 @@ +;;;; Copyright (C) 2000 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; + +;;;; R5RS bindings + +(define-module (ice-9 r5rs)) + +(module-use! %module-public-interface (resolve-interface '(ice-9 safe-r5rs))) + +(export scheme-report-environment + interaction-environment + + call-with-input-file call-with-output-file + with-input-from-file with-output-to-file + open-input-file open-output-file + close-input-port close-output-port + + load + ;;transcript-on + ;;transcript-off + ) + +(define scheme-report-interface %module-public-interface) + +(define (scheme-report-environment n) + (if (not (= n 5)) + (scm-error 'misc-error 'scheme-report-environment + "~A is not a valid version" + (list n) + '())) + scheme-report-interface) + +(define interaction-interface (resolve-interface '(guile-user))) + +(define (interaction-environment) + interaction-interface) diff --git a/ice-9/safe-r5rs.scm b/ice-9/safe-r5rs.scm new file mode 100644 index 000000000..f5bf800d5 --- /dev/null +++ b/ice-9/safe-r5rs.scm @@ -0,0 +1,143 @@ +;;;; Copyright (C) 2000 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; + +;;;; Safe subset of R5RS bindings + +(define-module (ice-9 safe-r5rs)) + +(module-use! %module-public-interface (resolve-interface '(ice-9 null))) + +(export eqv? eq? equal? + number? complex? real? rational? integer? + exact? inexact? + = < > <= >= + zero? positive? negative? odd? even? + max min + + * - / + abs + quotient remainder modulo + gcd lcm + numerator denominator + floor ceiling truncate round + rationalize + exp log sin cos tan asin acos atan + sqrt + expt + make-rectangualr make-polar real-part imag-part magnitude angle + exact->inexact inexact->exact + + number->string string->number + + boolean? + not + + pair? + cons car cdr + set-car! set-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 + null? + list? + length + append + reverse + list-tail list-ref + memq memv member + assq assv assoc + + symbol? + symbol->string string->symbol + + char? + char=? char? char<=? char>=? + char-ci=? char-ci? char-ci<=? char-ci>=? + char-alphabetic? char-numeric? char-whitespace? + char-upper-case? char-lower-case? + char->integer integer->char + char-upcase + char-downcase + + string? + make-string + string + string-length + string-ref string-set! + string=? string-ci=? + string? string<=? string>=? + string-ci? string-ci<=? string-ci>=? + substring + string-length + string-append + string->list list->string + string-copy string-fill! + + vector? + make-vector + vector + vector-length + vector-ref vector-set! + vector->list list->vector + vector-fill! + + procedure? + apply + map + for-each + force + + call-with-current-continuation + + values + call-with-values + dynamic-wind + + eval + null-environment + + input-port? output-port? + current-input-port current-output-port + + read + read-char + peek-char + eof-object? + char-ready? + + write + display + newline + write-char + + ;;transcript-on + ;;transcript-off + ) + +(define eval eval-in-module) + +(define null-interface (make-module 31)) +(set-module-kind! null-interface 'interface) + +(define (null-environment n) + (if (not (= n 5)) + (scm-error 'misc-error 'null-environment + "~A is not a valid version" + (list n) + '())) + null-interface) diff --git a/ice-9/safe.scm b/ice-9/safe.scm new file mode 100644 index 000000000..fe6da1a31 --- /dev/null +++ b/ice-9/safe.scm @@ -0,0 +1,31 @@ +;;;; Copyright (C) 2000 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; + +;;;; Safe subset of R5RS bindings + +(define-module (ice-9 safe)) + +(define safe-r5rs-interface (resolve-interface '(ice-9 safe-r5rs))) + +(define-public (safe-environment n) + (if (not (= n 5)) + (scm-error 'misc-error 'safe-environment + "~A is not a valid version" + (list n) + '())) + safe-r5rs-interface) From c0997079b4f65b10fc96da4467ce0b4fcb534080 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 21 Jun 2000 01:17:51 +0000 Subject: [PATCH 0006/2047] *** empty log message *** --- NEWS | 38 ++++++++++++++++++++++++++++++++++++++ ice-9/ChangeLog | 9 +++++++++ 2 files changed, 47 insertions(+) diff --git a/NEWS b/NEWS index e46483f55..73e92a914 100644 --- a/NEWS +++ b/NEWS @@ -10,8 +10,46 @@ Changes since Guile 1.4: * Changes to the stand-alone interpreter +** It's now possible to create modules with controlled environments + +Example: + +(define m (make-module 1021 (list (resolve-interface '(ice-9 safe-r5rs))))) +;;; m will now be a module containing only a safe subset of R5RS +(eval-in-module '(+ 1 2) m) --> 3 +(eval-in-module 'load m) --> ERROR: Unbound variable: load + * Changes to Scheme functions and syntax +** New define-module option: pure + +Tells the module system not to include any bindings from the root +module. + +Example: + +(define-module (totally-empty-module) + :pure) + +** New define-module option: export NAME1 ... + +Export names NAME1 ... + +This option is required if you want to be able to export bindings from +a module which doesn't import one of `define-public' or `export'. + +Example: + +(define-module (foo) + :pure + :use-module (ice-9 r5rs) + :export (bar)) + +;;; Note that we're pure R5RS below this point! + +(define (bar) + ...) + * Changes to the gh_ interface * Changes to the scm_ interface diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 6b1ac4274..ea66f130d 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,12 @@ +2000-06-21 Mikael Djurfeldt + + * boot-9.scm (purify-module!, module-export!): New procedures. + (export): Rewritten using `module-export!'. + (process-define-module): New define-module options: pure, export. + See NEWS. + + * null.scm, r5rs.scm, safe-r5rs.scm, safe.scm: New modules. + 2000-06-20 Mikael Djurfeldt * session.scm (make-fold-modules): Detect circular references in From 03cd374d375ba0d0d5ae074f048582f35a169707 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 21 Jun 2000 01:24:56 +0000 Subject: [PATCH 0007/2047] Fix --- NEWS | 3 ++- ice-9/safe.scm | 3 +++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index 73e92a914..062bb1430 100644 --- a/NEWS +++ b/NEWS @@ -14,7 +14,8 @@ Changes since Guile 1.4: Example: -(define m (make-module 1021 (list (resolve-interface '(ice-9 safe-r5rs))))) +(use-modules (ice-9 safe)) +(define m (make-safe-module)) ;;; m will now be a module containing only a safe subset of R5RS (eval-in-module '(+ 1 2) m) --> 3 (eval-in-module 'load m) --> ERROR: Unbound variable: load diff --git a/ice-9/safe.scm b/ice-9/safe.scm index fe6da1a31..bd4fc377f 100644 --- a/ice-9/safe.scm +++ b/ice-9/safe.scm @@ -29,3 +29,6 @@ (list n) '())) safe-r5rs-interface) + +(define-public (make-safe-module) + (make-module 1021 (list safe-r5rs-interface))) From 549e6ec69d0ba7d3cfadc9575c62f3e94f7c63b8 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 21 Jun 2000 02:42:03 +0000 Subject: [PATCH 0008/2047] * eval.c, eval.h (scm_top_level_lookup_closure_var): Added. #include "libguile/fluids.h". --- libguile/eval.c | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index 54e28268f..e9c8f0b1d 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -99,6 +99,7 @@ char *alloca (); #include "libguile/ports.h" #include "libguile/root.h" #include "libguile/vectors.h" +#include "libguile/fluids.h" #include "libguile/validate.h" #include "libguile/eval.h" @@ -3825,8 +3826,9 @@ SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0, SCM scm_eval_3 (SCM obj, int copyp, SCM env) { - if (SCM_NIMP (SCM_CDR (scm_system_transformer))) - obj = scm_apply (SCM_CDR (scm_system_transformer), obj, scm_listofnull); + SCM transformer = scm_fluid_ref (SCM_CDR (scm_system_transformer)); + if (SCM_NIMP (transformer)) + obj = scm_apply (transformer, obj, scm_listofnull); else if (copyp) obj = scm_copy_tree (obj); return SCM_XEVAL (obj, env); @@ -3843,6 +3845,9 @@ SCM_DEFINE (scm_eval2, "eval2", 2, 0, 0, } #undef FUNC_NAME +SCM scm_system_transformer; +SCM scm_top_level_lookup_closure_var; + SCM_DEFINE (scm_eval, "eval", 1, 0, 0, (SCM obj), "Evaluate @var{exp}, a list representing a Scheme expression, in the\n" @@ -3851,8 +3856,7 @@ SCM_DEFINE (scm_eval, "eval", 1, 0, 0, { return scm_eval_3 (obj, 1, - scm_top_level_env - (SCM_CDR (scm_top_level_lookup_closure_var))); + scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE)); } #undef FUNC_NAME @@ -3865,8 +3869,7 @@ scm_eval_x (SCM obj) { return scm_eval_3 (obj, 0, - scm_top_level_env - (SCM_CDR (scm_top_level_lookup_closure_var))); + scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE)); } @@ -3895,7 +3898,8 @@ scm_init_eval () scm_set_smob_print (scm_tc16_promise, prinprom); scm_f_apply = scm_make_subr ("apply", scm_tc7_lsubr_2, scm_apply); - scm_system_transformer = scm_sysintern ("scm:eval-transformer", SCM_UNDEFINED); + scm_system_transformer = scm_sysintern ("scm:eval-transformer", + scm_make_fluid ()); scm_sym_dot = SCM_CAR (scm_sysintern (".", SCM_UNDEFINED)); scm_sym_arrow = SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED)); scm_sym_else = SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED)); @@ -3913,7 +3917,7 @@ scm_init_eval () /* end of acros */ scm_top_level_lookup_closure_var = - scm_sysintern("*top-level-lookup-closure*", SCM_BOOL_F); + scm_sysintern ("*top-level-lookup-closure*", scm_make_fluid ()); scm_can_use_top_level_lookup_closure_var = 1; #ifdef DEBUG_EXTENSIONS From a0ea2bf0433a3519394429f891ac04e62d79819f Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 21 Jun 2000 02:42:14 +0000 Subject: [PATCH 0009/2047] * eval.c, eval.h (scm_top_level_lookup_closure_var): Added. #include "libguile/fluids.h". * eval.h (SCM_TOP_LEVEL_LOOKUP_CLOSURE): New macro which replaces SCM_CDR (scm_top_level_lookup_closure_var) everywhere. --- libguile/eval.h | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/eval.h b/libguile/eval.h index 7f3abc6de..4fa1e6d7a 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -118,6 +118,12 @@ extern SCM scm_eval_options_interface (SCM setting); #define SCM_EXTEND_ENV scm_acons + +#define SCM_TOP_LEVEL_LOOKUP_CLOSURE scm_fluid_ref (SCM_CDR (scm_top_level_lookup_closure_var)) + +extern SCM scm_system_transformer; +extern SCM scm_top_level_lookup_closure_var; + extern const char scm_s_expression[]; extern const char scm_s_test[]; From 7f763132bc314c2f530decba81c5e6c69a0477cd Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 21 Jun 2000 02:42:31 +0000 Subject: [PATCH 0010/2047] * modules.c (scm_selected_module): the_module is now a fluid. --- libguile/modules.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/modules.c b/libguile/modules.c index f43a893b9..6e5d3413a 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -52,6 +52,7 @@ #include "libguile/hashtab.h" #include "libguile/struct.h" #include "libguile/variable.h" +#include "libguile/fluids.h" #include "libguile/modules.h" @@ -69,7 +70,7 @@ static SCM the_module; SCM scm_selected_module () { - return SCM_CDR (the_module); + return scm_fluid_ref (SCM_CDR (the_module)); } static SCM set_current_module; From de8722785101f5e646a9b98e2f3d59981e76c835 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 21 Jun 2000 02:42:41 +0000 Subject: [PATCH 0011/2047] * root.h (scm_top_level_lookup_closure_var): Removed. (It's no sense in having the *variable* be a "fluid".) --- libguile/root.h | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/libguile/root.h b/libguile/root.h index 51f0528a6..5ed36ec83 100644 --- a/libguile/root.h +++ b/libguile/root.h @@ -116,8 +116,8 @@ typedef struct scm_root_state SCM fluids; - SCM system_transformer; - SCM top_level_lookup_closure_var; + SCM system_transformer; /* No longer used (but kept for binary compatibility) */ + SCM top_level_lookup_closure_var; /* No longer used (but kept for binary compatibility) */ SCM handle; /* The root object for this root state */ SCM parent; /* The parent root object */ @@ -143,9 +143,6 @@ typedef struct scm_root_state #define scm_def_outp (scm_root->def_outp) #define scm_def_errp (scm_root->def_errp) #define scm_cur_loadp (scm_root->cur_loadp) -#define scm_top_level_lookup_closure_var \ - (scm_root->top_level_lookup_closure_var) -#define scm_system_transformer (scm_root->system_transformer) #ifdef USE_THREADS #define scm_root ((scm_root_state *) SCM_THREAD_LOCAL_DATA) From 51eb747ebfcac593fced29d073c6b49f57e896aa Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 21 Jun 2000 02:45:26 +0000 Subject: [PATCH 0012/2047] * root.c (mark_root): Removed marking of s->top_level_lookup_closure_var and s->system_transformer. --- libguile/root.c | 2 -- 1 file changed, 2 deletions(-) diff --git a/libguile/root.c b/libguile/root.c index e350a9cb9..5504f3544 100644 --- a/libguile/root.c +++ b/libguile/root.c @@ -93,8 +93,6 @@ mark_root (SCM root) scm_gc_mark (s->def_errp); /* No need to gc mark def_loadp */ scm_gc_mark (s->fluids); - scm_gc_mark (s->top_level_lookup_closure_var); - scm_gc_mark (s->system_transformer); return SCM_ROOT_STATE (root) -> parent; } From 7e73eaee6ef8b4471b90917e8a98ffcb739644b2 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 21 Jun 2000 02:46:01 +0000 Subject: [PATCH 0013/2047] (SCM_TOP_LEVEL_LOOKUP_CLOSURE): New macro which replaces SCM_CDR (scm_top_level_lookup_closure_var) everywhere. --- libguile/debug.c | 4 ++-- libguile/evalext.c | 4 ++-- libguile/fluids.c | 2 +- libguile/gdbint.c | 6 +++--- libguile/symbols.c | 6 +++--- 5 files changed, 11 insertions(+), 11 deletions(-) diff --git a/libguile/debug.c b/libguile/debug.c index 74129a17f..81b3576e4 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -263,7 +263,7 @@ SCM_DEFINE (scm_make_gloc, "make-gloc", 1, 1, 0, #endif SCM_VALIDATE_VARIABLE (1,var); if (SCM_UNBNDP (env)) - env = scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var)); + env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE); else SCM_VALIDATE_NULLORCONS (2,env); return scm_make_memoized (SCM_VARVCELL (var) + 1, env); @@ -328,7 +328,7 @@ SCM_DEFINE (scm_memcons, "memcons", 2, 1, 0, cdr = SCM_MEMOIZED_EXP (cdr); } if (SCM_UNBNDP (env)) - env = scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var)); + env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE); else SCM_VALIDATE_NULLORCONS (3,env); return scm_make_memoized (scm_cons (car, cdr), env); diff --git a/libguile/evalext.c b/libguile/evalext.c index f4b9eac89..843897c57 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -48,7 +48,7 @@ #include "libguile/eval.h" #include "libguile/macros.h" #include "libguile/modules.h" -#include "libguile/root.h" +#include "libguile/fluids.h" #include "libguile/validate.h" #include "libguile/evalext.h" @@ -79,7 +79,7 @@ SCM_DEFINE (scm_definedp, "defined?", 1, 1, 0, if (SCM_UNBNDP (env)) vcell = scm_sym2vcell(sym, - SCM_CDR (scm_top_level_lookup_closure_var), + SCM_TOP_LEVEL_LOOKUP_CLOSURE, SCM_BOOL_F); else { diff --git a/libguile/fluids.c b/libguile/fluids.c index 88897ab73..e7841d884 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -160,7 +160,7 @@ SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0, if (SCM_LENGTH (scm_root->fluids) <= n) grow_fluids (scm_root, n+1); - return SCM_VELTS(scm_root->fluids)[n]; + return SCM_VELTS (scm_root->fluids)[n]; } #undef FUNC_NAME diff --git a/libguile/gdbint.c b/libguile/gdbint.c index 59ad14093..bc0c73ac5 100644 --- a/libguile/gdbint.c +++ b/libguile/gdbint.c @@ -61,7 +61,7 @@ #include "libguile/chars.h" #include "libguile/modules.h" #include "libguile/ports.h" -#include "libguile/root.h" +#include "libguile/fluids.h" #include "libguile/strings.h" #include "libguile/init.h" @@ -256,7 +256,7 @@ gdb_eval (SCM exp) } SCM_BEGIN_FOREIGN_BLOCK; { - SCM env = scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var)); + SCM env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE); gdb_result = scm_permanent_object (scm_ceval (exp, env)); } SCM_END_FOREIGN_BLOCK; @@ -302,7 +302,7 @@ gdb_binding (SCM name, SCM value) SCM_BEGIN_FOREIGN_BLOCK; { SCM vcell = scm_sym2vcell (name, - SCM_CDR (scm_top_level_lookup_closure_var), + SCM_TOP_LEVEL_LOOKUP_CLOSURE, SCM_BOOL_T); SCM_SETCDR (vcell, value); } diff --git a/libguile/symbols.c b/libguile/symbols.c index dffa8cb25..1c56a6e10 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -50,7 +50,7 @@ #include "libguile/eval.h" #include "libguile/variable.h" #include "libguile/alist.h" -#include "libguile/root.h" +#include "libguile/fluids.h" #include "libguile/strings.h" #include "libguile/vectors.h" #include "libguile/weaks.h" @@ -398,7 +398,7 @@ scm_sysintern0 (const char *name) { SCM lookup_proc; if (scm_can_use_top_level_lookup_closure_var && - SCM_NIMP (lookup_proc = SCM_CDR (scm_top_level_lookup_closure_var))) + SCM_NIMP (lookup_proc = SCM_TOP_LEVEL_LOOKUP_CLOSURE)) { SCM sym = SCM_CAR (scm_intern0 (name)); SCM vcell = scm_sym2vcell (sym, lookup_proc, SCM_BOOL_T); @@ -420,7 +420,7 @@ scm_symbol_value0 (const char *name) lookup closures are written in scheme which needs real symbols. */ SCM symbol = scm_intern_obarray_soft (name, strlen (name), scm_symhash, 0); SCM vcell = scm_sym2vcell (SCM_CAR (symbol), - SCM_CDR (scm_top_level_lookup_closure_var), + SCM_TOP_LEVEL_LOOKUP_CLOSURE, SCM_BOOL_F); if (SCM_FALSEP (vcell)) return SCM_UNDEFINED; From bd0fb3cfbfbaab37feb37fd3d864f53d1bce2c9f Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 21 Jun 2000 02:46:44 +0000 Subject: [PATCH 0014/2047] * boot-9.scm: Turned `the-module', `*top-level-lookup-closure*', and `scm:eval-transformer' into fluids. --- ice-9/boot-9.scm | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index e2b6cbe4f..590bc7788 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1481,11 +1481,11 @@ ;; ;; NOTE: This binding is used in libguile/modules.c. ;; -(define the-module #f) +(define the-module (make-fluid)) ;; scm:eval-transformer ;; -(define scm:eval-transformer #f) +;;(define scm:eval-transformer (make-fluid)) ; initialized in eval.c. ;; set-current-module module ;; @@ -1494,19 +1494,20 @@ ;; NOTE: This binding is used in libguile/modules.c. ;; (define (set-current-module m) - (set! the-module m) + (fluid-set! the-module m) (if m (begin - (set! *top-level-lookup-closure* (module-eval-closure the-module)) - (set! scm:eval-transformer (module-transformer the-module))) - (set! *top-level-lookup-closure* #f))) + (fluid-set! *top-level-lookup-closure* + (module-eval-closure (fluid-ref the-module))) + (fluid-set! scm:eval-transformer (module-transformer (fluid-ref the-module)))) + (fluid-set! *top-level-lookup-closure* #f))) ;; current-module ;; ;; return the current module as viewed by the normalizer. ;; -(define (current-module) the-module) +(define (current-module) (fluid-ref the-module)) ;;; {Module-based Loading} ;;; @@ -2688,7 +2689,7 @@ (set-module-transformer! (current-module) ,(car (last-pair spec)))) `((set-module-transformer! (current-module) ,spec))) - (set! scm:eval-transformer (module-transformer (current-module))))) + (fluid-set! scm:eval-transformer (module-transformer (current-module))))) (define define-private define) From 2b6e0d2b77205408b06a1099e573a88080fb0bd5 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 21 Jun 2000 02:47:01 +0000 Subject: [PATCH 0015/2047] *** empty log message *** --- ice-9/ChangeLog | 6 +++++- libguile/ChangeLog | 17 +++++++++++++++++ 2 files changed, 22 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index ea66f130d..c79b4ad95 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,10 +1,14 @@ 2000-06-21 Mikael Djurfeldt + * boot-9.scm: Turned `the-module', `*top-level-lookup-closure*', + and `scm:eval-transformer' into fluids. + * boot-9.scm (purify-module!, module-export!): New procedures. (export): Rewritten using `module-export!'. (process-define-module): New define-module options: pure, export. See NEWS. - + (scm-style-repl): Added optional module argument. + * null.scm, r5rs.scm, safe-r5rs.scm, safe.scm: New modules. 2000-06-20 Mikael Djurfeldt diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d60914290..1a1104b41 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,20 @@ +2000-06-21 Mikael Djurfeldt + + * eval.c, eval.h (scm_top_level_lookup_closure_var): Added. + #include "libguile/fluids.h". + + * eval.h (SCM_TOP_LEVEL_LOOKUP_CLOSURE): New macro which replaces + SCM_CDR (scm_top_level_lookup_closure_var) everywhere. + + * root.h (scm_top_level_lookup_closure_var, + scm_system_transformer): Removed. (It's no sense in having the + *variable* be a "fluid".) + + * root.c (mark_root): Removed marking of + s->top_level_lookup_closure_var and s->system_transformer. + + * modules.c (scm_selected_module): the_module is now a fluid. + 2000-06-20 Mikael Djurfeldt * gc.h, tags.h: Be kind to compilers which must see hash signs in From 3c6d9d717f0fcf617456cb22a212ea82aeea3a1a Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 21 Jun 2000 08:43:12 +0000 Subject: [PATCH 0016/2047] * Renamed SCM__X tokens to better readable ones that also follow the SCM_SNARF_ prefix convention. --- libguile/ChangeLog | 6 ++++++ libguile/guile-snarf.awk.in | 22 +++++++++++----------- libguile/guile-snarf.in | 2 +- libguile/snarf.h | 14 +++++++++----- 4 files changed, 27 insertions(+), 17 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 1a1104b41..d575c7c7e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2000-06-21 Dirk Herrmann + + * guile-snarf.awk.in, guile-snarf.in, snarf.h: Rename SCM__I to + SCM_SNARF_INIT_START, SCM__D to SCM_SNARF_DOC_START, SCM__S to + SCM_SNARF_DOCSTRING_START and SCM__E to SCM_SNARF_DOCSTRING_END. + 2000-06-21 Mikael Djurfeldt * eval.c, eval.h (scm_top_level_lookup_closure_var): Added. diff --git a/libguile/guile-snarf.awk.in b/libguile/guile-snarf.awk.in index 582b5a61d..9fa44aac3 100644 --- a/libguile/guile-snarf.awk.in +++ b/libguile/guile-snarf.awk.in @@ -9,16 +9,16 @@ BEGIN { FS="|"; printf "" > dot_doc_file; } -/^[ \t]*SCM__I/ { copy = $0; - gsub(/[ \t]*SCM__I/, "", copy); - gsub(/SCM__D.*$/, "", copy); +/^[ \t]*SCM_SNARF_INIT_START/ { copy = $0; + gsub(/[ \t]*SCM_SNARF_INIT_START/, "", copy); + gsub(/SCM_SNARF_DOC_START.*$/, "", copy); print copy; } -/SCM__D/,/SCM__S/ { copy = $0; - if (match(copy,/SCM__DR/)) { registering = 1; } +/SCM_SNARF_DOC_START/,/SCM_SNARF_DOCSTRING_START/ { copy = $0; + if (match(copy,/SCM_SNARF_DOC_STARTR/)) { registering = 1; } else {registering = 0; } - gsub(/.*SCM__D./,"", copy); - gsub(/SCM__S.*/,"",copy); + gsub(/.*SCM_SNARF_DOC_START./,"", copy); + gsub(/SCM_SNARF_DOCSTRING_START.*/,"",copy); gsub(/[ \t]+/," ", copy); sub(/^[ \t]*/,"(", copy); gsub(/\"/,"",copy); @@ -51,10 +51,10 @@ BEGIN { FS="|"; { print location ":*** `" copy "' is improperly registered as having " numactuals " arguments" > std_err; } print " \n" copy (registering?")":"") > dot_doc_file ; } -/SCM__S/,/SCM__E.*$/ { copy = $0; - gsub(/.*SCM__S/,"",copy); +/SCM_SNARF_DOCSTRING_START/,/SCM_SNARF_DOCSTRING_END.*$/ { copy = $0; + gsub(/.*SCM_SNARF_DOCSTRING_START/,"",copy); sub(/^[ \t]*"?/,"", copy); - sub(/\"?[ \t]*SCM__E.*$/,"", copy); + sub(/\"?[ \t]*SCM_SNARF_DOCSTRING_END.*$/,"", copy); gsub(/\\n\\n"?/,"\n",copy); gsub(/\\n"?[ \t]*$/,"",copy); gsub(/\\\"[ \t]*$/,"\"",copy); @@ -62,7 +62,7 @@ BEGIN { FS="|"; if (copy != "") { print copy > dot_doc_file } } -/SCM__E[ \t]/ { print "[" location "]" >> dot_doc_file; } +/SCM_SNARF_DOCSTRING_END[ \t]/ { print "[" location "]" >> dot_doc_file; } /\*&\*&\*&\*SCM_ARG_BETTER_BE_IN_POSITION/ { copy = $0; sub(/.*\*&\*&\*&\*SCM_ARG_BETTER_BE_IN_POSITION\([ \t]*/,"",copy); diff --git a/libguile/guile-snarf.in b/libguile/guile-snarf.in index d1347037f..a606b440b 100644 --- a/libguile/guile-snarf.in +++ b/libguile/guile-snarf.in @@ -10,7 +10,7 @@ test -n "${CPP+set}" || CPP="@CPP@" ## We must use a temporary file here, instead of a pipe, because we ## need to know if CPP exits with a non-zero status. ${CPP} -DSCM_MAGIC_SNARFER "$@" > ${temp} || exit $? -< ${temp} grep "^ *SCM__I" | sed -e "s/^ *SCM__I//" -e 's/SCM__D.*$//g' +< ${temp} grep "^ *SCM_SNARF_INIT_START" | sed -e "s/^ *SCM_SNARF_INIT_START//" -e 's/SCM_SNARF_DOC_START.*$//g' ## Apparently, AIX's preprocessor is unhappy if you try to #include an ## empty file. diff --git a/libguile/snarf.h b/libguile/snarf.h index ee6d91597..95371244f 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -67,7 +67,8 @@ * SCM_SNARF_INIT (NAME = foo ()) * * The SCM_SNARF_INIT text goes into the corresponding .x file - * up through the first occurrence of SCM__D on that line, if any. + * up through the first occurrence of SCM_SNARF_DOC_START on that + * line, if any. */ #ifndef SCM_MAGIC_SNARFER @@ -76,7 +77,7 @@ # define SCM_SNARF_DOCS(X) #else # define SCM_SNARF_HERE(X) -# define SCM_SNARF_INIT(X) SCM__I X +# define SCM_SNARF_INIT(X) SCM_SNARF_INIT_START X # define SCM_SNARF_DOCS(X) X #endif @@ -90,7 +91,8 @@ scm_make_gsubr (s_ ## FNAME, REQ, OPT, VAR, \ (SCM_FUNC_CAST_ARBITRARY_ARGS) FNAME); \ )\ SCM_SNARF_DOCS(\ -SCM__DP PRIMNAME #ARGLIST | REQ | OPT | VAR | __FILE__:__LINE__ | SCM__S DOCSTRING SCM__E \ +SCM_SNARF_DOC_STARTP PRIMNAME #ARGLIST | REQ | OPT | VAR | __FILE__:__LINE__ | \ + SCM_SNARF_DOCSTRING_START DOCSTRING SCM_SNARF_DOCSTRING_END \ ) #define SCM_DEFINE1(FNAME, PRIMNAME, TYPE, ARGLIST, DOCSTRING) \ @@ -100,7 +102,8 @@ SCM FNAME ARGLIST\ )\ SCM_SNARF_INIT(scm_make_subr (s_ ## FNAME, TYPE, FNAME); ) \ SCM_SNARF_DOCS(\ -SCM__D1 PRIMNAME #ARGLIST | 2 | 0 | 0 | __FILE__:__LINE__ | SCM__S DOCSTRING SCM__E \ +SCM_SNARF_DOC_START1 PRIMNAME #ARGLIST | 2 | 0 | 0 | __FILE__:__LINE__ | \ + SCM_SNARF_DOCSTRING_START DOCSTRING SCM_SNARF_DOCSTRING_END \ ) #define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \ @@ -113,7 +116,8 @@ SCM_SNARF_HERE(static const char RANAME[]=STR) \ SCM_SNARF_INIT(scm_make_gsubr (RANAME, REQ, OPT, VAR, \ (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN);) \ SCM_SNARF_DOCS(\ -SCM__DR STR | REQ | OPT | VAR | __FILE__:__LINE__ | SCM__S CFN SCM__E \ +SCM_SNARF_DOC_STARTR STR | REQ | OPT | VAR | __FILE__:__LINE__ | \ + SCM_SNARF_DOCSTRING_START CFN SCM_SNARF_DOCSTRING_END \ ) #define SCM_GPROC(RANAME, STR, REQ, OPT, VAR, CFN, GF) \ From 141443d7ec74ea0dbf9df4fed4daa6acc1db1584 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 21 Jun 2000 15:00:44 +0000 Subject: [PATCH 0017/2047] * Added some tests that are currently known to fail due to bugs in the evaluator's handling of macros. --- test-suite/ChangeLog | 4 ++ test-suite/tests/eval.test | 137 +++++++++++++++++++++++++++++++++++++ 2 files changed, 141 insertions(+) create mode 100644 test-suite/tests/eval.test diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index d604ff555..624cd2160 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2000-06-21 Dirk Herrmann + + * tests/eval.test: Added. + 2000-06-16 Dirk Herrmann * tests/list.test: Use cons* instead of list*. diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test new file mode 100644 index 000000000..cdc69ef62 --- /dev/null +++ b/test-suite/tests/eval.test @@ -0,0 +1,137 @@ +;;;; eval.test --- tests guile's evaluator -*- scheme -*- +;;;; Copyright (C) 2000 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. + +(use-modules (ice-9 documentation)) + + +;;; +;;; miscellaneous +;;; + + +(define (documented? object) + (object-documentation object)) + + +;;; +;;; eval +;;; + +(with-test-prefix "evaluator" + + (with-test-prefix "parameter error" + + ;; This is currently a bug in guile: + ;; Macros are accepted as function parameters. + ;; Functions that 'apply' macros are rewritten!!! + + (expect-fail "macro as argument" + (let ((f (lambda (p a b) (p a b)))) + (catch 'wrong-type-arg + (lambda () + (f and #t #t) + #f) + (lambda (key . args) + #t)))) + + (expect-fail "application of macro" + (let ((f (lambda (p a b) (p a b)))) + (catch 'wrong-type-arg + (lambda () + (let ((foo (procedure-source f))) + (f and #t #t) + (equal? (procedure-source f) foo))) + (lambda (key . args) + #t)))) + + )) + +;;; +;;; map +;;; + +(with-test-prefix "map" + + ;; Is documentation available? + + (expect-fail "documented?" + (documented? 'map)) + + (with-test-prefix "argument error" + + (with-test-prefix "non list argument" + #t) + + (with-test-prefix "different length lists" + + (pass-if "first list empty" + (catch 'out-of-range + (lambda () + (map + '() '(1)) + #f) + (lambda (key . args) + #t))) + + (pass-if "second list empty" + (catch 'out-of-range + (lambda () + (map + '(1) '()) + #f) + (lambda (key . args) + #t))) + + (pass-if "first list shorter" + (catch 'out-of-range + (lambda () + (map + '(1) '(2 3)) + #f) + (lambda (key . args) + #t))) + + (pass-if "second list shorter" + (catch 'out-of-range + (lambda () + (map + '(1 2) '(3)) + #f) + (lambda (key . args) + #t))) + ))) From c7b6388d1e20c31e0e773afd66209b9f92fceafd Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 21 Jun 2000 15:11:30 +0000 Subject: [PATCH 0018/2047] * Added reminder about removing system_transformer and top_level_lookup_closure_var from root.h with the next version of libguile that is not binary compatible with 1.4. --- RELEASE | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/RELEASE b/RELEASE index 5a104c8b5..13d47924e 100644 --- a/RELEASE +++ b/RELEASE @@ -7,6 +7,11 @@ absinthe, etc. However, the first release containing the module system should be called Godot: "This is the one you've been waiting for." +Before releasing the next version of libguile which is not binary compatible +with the one released with 1.4: +- remove struct members system_transformer and top_level_lookup_closure_var + from struct scm_root_state in root.h. + In release 1.5: - remove deprecated macros: SCM_INPORTP, SCM_OUTPORTP, SCM_CRDY, SCM_ICHRP, SCM_ICHR, SCM_MAKICHR, SCM_SETJMPBUF, SCM_NSTRINGP, SCM_NRWSTRINGP, From 7f40b48a9f199527a2d45a560873606ce779970a Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Wed, 21 Jun 2000 15:14:00 +0000 Subject: [PATCH 0019/2047] * guile-doc-snarf.in: use cut instead of sed, that's much much faster. also, don't call basename more than needed. and, to gain a couple of microseconds more, don't call cat needlessly. (thanks to Brad Knotwell). --- THANKS | 1 + libguile/ChangeLog | 7 +++++++ libguile/guile-doc-snarf.in | 3 +-- 3 files changed, 9 insertions(+), 2 deletions(-) diff --git a/THANKS b/THANKS index 05b5810f7..f2dce3777 100644 --- a/THANKS +++ b/THANKS @@ -9,3 +9,4 @@ Contributors since the last release: For fixes or providing information which led to a fix: + Brad Knotwell diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d575c7c7e..16631ddd9 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2000-06-21 Michael Livshin + + * guile-doc-snarf.in: use cut instead of sed, that's much much + faster. also, don't call basename more than needed. and, to gain + a couple of microseconds more, don't call cat needlessly. (thanks + to Brad Knotwell). + 2000-06-21 Dirk Herrmann * guile-snarf.awk.in, guile-snarf.in, snarf.h: Rename SCM__I to diff --git a/libguile/guile-doc-snarf.in b/libguile/guile-doc-snarf.in index 89dcc04ee..cce78ed89 100755 --- a/libguile/guile-doc-snarf.in +++ b/libguile/guile-doc-snarf.in @@ -28,5 +28,4 @@ ${AWK} -f guile-func-name-check "$fullfilename" ## We must use a temporary file here, instead of a pipe, because we ## need to know if CPP exits with a non-zero status. ${CPP} -DSCM_MAGIC_SNARFER "$@" > ${temp} || exit $? -cat ${temp} | sed 's/^\(.\{128\}.\{128\}.\{128\}.\{128\}.\{128\}.\{128\}.\{128\}.\{128\}\).*/\1/g' | \ -${AWK} -f `dirname $0`/guile-snarf.awk `basename ${dot_doc}` +cut -c1-1023 ${temp} | ${AWK} -f `dirname $0`/guile-snarf.awk ${dot_doc} From e5d2c2fa4fb0586308f4d716c9ae9d3ce47ae237 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 21 Jun 2000 18:19:20 +0000 Subject: [PATCH 0020/2047] * Made a couple of functions (not all yet) tail recursive. Thanks to William Webber for the hint. --- THANKS | 1 + ice-9/ChangeLog | 10 ++ ice-9/common-list.scm | 62 ++++---- test-suite/ChangeLog | 4 + test-suite/tests/common-list.test | 242 ++++++++++++++++++++++++++++++ 5 files changed, 290 insertions(+), 29 deletions(-) create mode 100644 test-suite/tests/common-list.test diff --git a/THANKS b/THANKS index f2dce3777..30b01958a 100644 --- a/THANKS +++ b/THANKS @@ -10,3 +10,4 @@ Contributors since the last release: For fixes or providing information which led to a fix: Brad Knotwell + William Webber diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index c79b4ad95..8c121cd2a 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,13 @@ +2000-06-16 Dirk Herrmann + + * common-list.scm (intersection, set-difference, remove-if, + remove-if-not): Made tail-recursive. Thanks to William Webber + for the hint. + + (delete-if!, delete-if-not!): Renamed parameter from `list' to + `l' in order to avoid confusion. Note: These functions are not + tail recursive yet. + 2000-06-21 Mikael Djurfeldt * boot-9.scm: Turned `the-module', `*top-level-lookup-closure*', diff --git a/ice-9/common-list.scm b/ice-9/common-list.scm index fea6b8764..02d1858e2 100644 --- a/ice-9/common-list.scm +++ b/ice-9/common-list.scm @@ -54,16 +54,18 @@ in the result list." (define-public (intersection l1 l2) "Returns a new list that is the intersection of L1 and L2. Only elements that occur in both lists will occur in the result list." - (cond ((null? l1) l1) - ((null? l2) l2) - ((memv (car l1) l2) (cons (car l1) (intersection (cdr l1) l2))) - (else (intersection (cdr l1) l2)))) + (if (null? l2) l2 + (let loop ((l1 l1) (result '())) + (cond ((null? l1) (reverse! result)) + ((memv (car l1) l2) (loop (cdr l1) (cons (car l1) result))) + (else (loop (cdr l1) result)))))) (define-public (set-difference l1 l2) "Return elements from list L1 that are not in list L2." - (cond ((null? l1) l1) - ((memv (car l1) l2) (set-difference (cdr l1) l2)) - (else (cons (car l1) (set-difference (cdr l1) l2))))) + (let loop ((l1 l1) (result '())) + (cond ((null? l1) (reverse! result)) + ((memv (car l1) l2) (loop (cdr l1) result)) + (else (loop (cdr l1) (cons (car l1) result)))))) (define-public (reduce-init p init l) "Same as `reduce' except it implicitly inserts INIT at the start of L." @@ -137,37 +139,39 @@ if PRED does not apply to any element in L." ((pred (car l)) l) (else (member-if pred (cdr l))))) -(define-public (remove-if p l) - "Removes all elements from L where (P element) is true. +(define-public (remove-if pred? l) + "Removes all elements from L where (PRED? element) is true. Returns everything that's left." - (cond ((null? l) '()) - ((p (car l)) (remove-if p (cdr l))) - (else (cons (car l) (remove-if p (cdr l)))))) + (let loop ((l l) (result '())) + (cond ((null? l) (reverse! result)) + ((pred? (car l)) (loop (cdr l) result)) + (else (loop (cdr l) (cons (car l) result)))))) -(define-public (remove-if-not p l) - "Removes all elements from L where (P element) is #f. +(define-public (remove-if-not pred? l) + "Removes all elements from L where (PRED? element) is #f. Returns everything that's left." - (cond ((null? l) '()) - ((not (p (car l))) (remove-if-not p (cdr l))) - (else (cons (car l) (remove-if-not p (cdr l)))))) + (let loop ((l l) (result '())) + (cond ((null? l) (reverse! result)) + ((not (pred? (car l))) (loop (cdr l) result)) + (else (loop (cdr l) (cons (car l) result)))))) -(define-public (delete-if! pred list) +(define-public (delete-if! pred l) "Destructive version of `remove-if'." - (let delete-if ((list list)) - (cond ((null? list) '()) - ((pred (car list)) (delete-if (cdr list))) + (let delete-if ((l l)) + (cond ((null? l) '()) + ((pred (car l)) (delete-if (cdr l))) (else - (set-cdr! list (delete-if (cdr list))) - list)))) + (set-cdr! l (delete-if (cdr l))) + l)))) -(define-public (delete-if-not! pred list) +(define-public (delete-if-not! pred l) "Destructive version of `remove-if-not'." - (let delete-if-not ((list list)) - (cond ((null? list) '()) - ((not (pred (car list))) (delete-if-not (cdr list))) + (let delete-if-not ((l l)) + (cond ((null? l) '()) + ((not (pred (car l))) (delete-if-not (cdr l))) (else - (set-cdr! list (delete-if-not (cdr list))) - list)))) + (set-cdr! l (delete-if-not (cdr l))) + l)))) (define-public (butlast lst n) "Return all but the last N elements of LST." diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 624cd2160..a6b768eab 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2000-06-21 Dirk Herrmann + + * tests/common-list.test: Added. + 2000-06-21 Dirk Herrmann * tests/eval.test: Added. diff --git a/test-suite/tests/common-list.test b/test-suite/tests/common-list.test new file mode 100644 index 000000000..349ba9e4f --- /dev/null +++ b/test-suite/tests/common-list.test @@ -0,0 +1,242 @@ +;;;; common-list.test --- tests guile's common list functions -*- scheme -*- +;;;; Copyright (C) 2000 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. + +(use-modules (ice-9 documentation) + (ice-9 common-list)) + + +;;; +;;; miscellaneous +;;; + + +(define (documented? object) + (object-documentation object)) + + +;;; +;;; intersection +;;; + +(with-test-prefix "intersection" + + (pass-if "documented?" + (documented? intersection)) + + (pass-if "both arguments empty" + (eq? (intersection '() '()) '())) + + (pass-if "first argument empty" + (eq? (intersection '() '(1)) '())) + + (pass-if "second argument empty" + (eq? (intersection '(1) '()) '())) + + (pass-if "disjoint arguments" + (eq? (intersection '(1) '(2)) '())) + + (pass-if "equal arguments" + (equal? (intersection '(1) '(1)) '(1))) + + (pass-if "reverse argument order" + (equal? (intersection '(1 2 3) '(3 2 1)) '(1 2 3))) + + (pass-if "multiple matches in first list" + (equal? (intersection '(1 1 2 2 3) '(3 2 1)) '(1 1 2 2 3))) + + (pass-if "multiple matches in second list" + (equal? (intersection '(1 2 3) '(3 3 2 2 1)) '(1 2 3))) + + (pass-if "mixed arguments" + (equal? (intersection '(1 2 3 5 7 8 10) '(1 3 4 7 8 9)) '(1 3 7 8))) + + ) + + +;;; +;;; set-difference +;;; + +(with-test-prefix "set-difference" + + (pass-if "documented?" + (documented? set-difference)) + + (pass-if "both arguments empty" + (eq? (set-difference '() '()) '())) + + (pass-if "first argument empty" + (eq? (set-difference '() '(1)) '())) + + (pass-if "second argument empty" + (equal? (set-difference '(1) '()) '(1))) + + (pass-if "disjoint arguments" + (equal? (set-difference '(1) '(2)) '(1))) + + (pass-if "equal arguments" + (eq? (set-difference '(1) '(1)) '())) + + (pass-if "reverse argument order" + (eq? (set-difference '(1 2 3) '(3 2 1)) '())) + + (pass-if "multiple matches in first list" + (eq? (set-difference '(1 1 2 2 3) '(3 2 1)) '())) + + (pass-if "multiple matches in second list" + (eq? (set-difference '(1 2 3) '(3 3 2 2 1)) '())) + + (pass-if "mixed arguments" + (equal? (set-difference '(1 2 3 5 7 8 10) '(1 3 4 7 8 9)) '(2 5 10))) + + ) + + +;;; +;;; remove-if +;;; + +(with-test-prefix "remove-if" + + (pass-if "documented?" + (documented? remove-if)) + + (pass-if "empty list, remove all" + (eq? (remove-if (lambda (x) #t) '()) '())) + + (pass-if "empty list, remove none" + (eq? (remove-if (lambda (x) #f) '()) '())) + + (pass-if "non-empty list, remove all" + (eq? (remove-if (lambda (x) #t) '(1 2 3 4)) '())) + + (pass-if "non-empty list, remove none" + (equal? (remove-if (lambda (x) #f) '(1 2 3 4)) '(1 2 3 4))) + + (pass-if "non-empty list, remove some" + (equal? (remove-if odd? '(1 2 3 4)) '(2 4))) + + ) + + +;;; +;;; remove-if-not +;;; + + +(with-test-prefix "remove-if-not" + + (pass-if "documented?" + (documented? remove-if-not)) + + (pass-if "empty list, remove all" + (eq? (remove-if-not (lambda (x) #f) '()) '())) + + (pass-if "empty list, remove none" + (eq? (remove-if-not (lambda (x) #t) '()) '())) + + (pass-if "non-empty list, remove all" + (eq? (remove-if-not (lambda (x) #f) '(1 2 3 4)) '())) + + (pass-if "non-empty list, remove none" + (equal? (remove-if-not (lambda (x) #t) '(1 2 3 4)) '(1 2 3 4))) + + (pass-if "non-empty list, remove some" + (equal? (remove-if-not odd? '(1 2 3 4)) '(1 3))) + + ) + + +;;; +;;; delete-if! +;;; + + +(with-test-prefix "delete-if!" + + (pass-if "documented?" + (documented? delete-if!)) + + (pass-if "empty list, remove all" + (eq? (delete-if! (lambda (x) #t) '()) '())) + + (pass-if "empty list, remove none" + (eq? (delete-if! (lambda (x) #f) '()) '())) + + (pass-if "non-empty list, remove all" + (eq? (delete-if! (lambda (x) #t) '(1 2 3 4)) '())) + + (pass-if "non-empty list, remove none" + (equal? (delete-if! (lambda (x) #f) '(1 2 3 4)) '(1 2 3 4))) + + (pass-if "non-empty list, remove some" + (equal? (delete-if! odd? '(1 2 3 4)) '(2 4))) + + ) + + +;;; +;;; delete-if-not! +;;; + + +(with-test-prefix "delete-if-not!" + + (pass-if "documented?" + (documented? delete-if-not!)) + + (pass-if "empty list, remove all" + (eq? (delete-if-not! (lambda (x) #f) '()) '())) + + (pass-if "empty list, remove none" + (eq? (delete-if-not! (lambda (x) #t) '()) '())) + + (pass-if "non-empty list, remove all" + (eq? (delete-if-not! (lambda (x) #f) '(1 2 3 4)) '())) + + (pass-if "non-empty list, remove none" + (equal? (delete-if-not! (lambda (x) #t) '(1 2 3 4)) '(1 2 3 4))) + + (pass-if "non-empty list, remove some" + (equal? (delete-if-not! odd? '(1 2 3 4)) '(1 3))) + + ) From ac373580683625b12337c52e116143adfa5be54a Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 27 Jun 2000 13:52:49 +0000 Subject: [PATCH 0021/2047] * gc-thunk is deprecated. Use after-gc-hook instead. --- ice-9/ChangeLog | 4 ++++ ice-9/popen.scm | 8 +------- 2 files changed, 5 insertions(+), 7 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 8c121cd2a..a1234ace3 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2000-06-27 Dirk Herrmann + + * popen.scm: gc-thunk is deprecated. Use after-gc-hook instead. + 2000-06-16 Dirk Herrmann * common-list.scm (intersection, set-difference, remove-if, diff --git a/ice-9/popen.scm b/ice-9/popen.scm index 5689e5ffc..6919f0eca 100644 --- a/ice-9/popen.scm +++ b/ice-9/popen.scm @@ -95,13 +95,7 @@ information on how to interpret this value." (close-process-quietly (cons p pid)))) (loop (pipe-guardian))))))) -(set! gc-thunk - (let ((old-thunk gc-thunk)) - (lambda () - (if old-thunk (old-thunk)) - (reap-pipes)))) - -;; (add-hook! after-gc-hook reap-pipes) +(add-hook! after-gc-hook reap-pipes) (define-public (open-input-pipe command) (open-pipe command OPEN_READ)) (define-public (open-output-pipe command) (open-pipe command OPEN_WRITE)) From 73ea78af4d2f7bec513a4569400265e89e8ca153 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 27 Jun 2000 16:00:01 +0000 Subject: [PATCH 0022/2047] * Switch to standard way of smob initialization. --- libguile/ChangeLog | 5 +++++ libguile/async.c | 6 ++++-- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 16631ddd9..6b19a9079 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-06-27 Dirk Herrmann + + * async.c (scm_init_async): Switch to standard way of smob + initialization. + 2000-06-21 Michael Livshin * guile-doc-snarf.in: use cut instead of sed, that's much much diff --git a/libguile/async.c b/libguile/async.c index 6b264fb17..39330a35f 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -502,8 +502,10 @@ void scm_init_async () { SCM a_thunk; - tc16_async = scm_make_smob_type_mfpe ("async", 0, - mark_async, NULL, NULL, NULL); + + tc16_async = scm_make_smob_type ("async", 0); + scm_set_smob_mark (tc16_async, mark_async); + scm_gc_vcell = scm_sysintern ("gc-thunk", SCM_BOOL_F); a_thunk = scm_make_gsubr ("%gc-thunk", 0, 0, 0, scm_sys_gc_async_thunk); scm_gc_async = scm_system_async (a_thunk); From 12acbbef543e5d6de5f6c344550cb865ecddd239 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 28 Jun 2000 07:49:25 +0000 Subject: [PATCH 0023/2047] * Removed commented code from gc.c. * Removed unused identifier scm_type_obj_list. --- libguile/ChangeLog | 7 +++++++ libguile/gc.c | 22 ---------------------- libguile/root.h | 19 +++++++++---------- 3 files changed, 16 insertions(+), 32 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6b19a9079..649fe9c4f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2000-06-28 Dirk Herrmann + + * gc.c (scm_igc): Removed commented code that once was intended + to unprotect struct types with no instances. + + * root.h (scm_type_obj_list): Removed. + 2000-06-27 Dirk Herrmann * async.c (scm_init_async): Switch to standard way of smob diff --git a/libguile/gc.c b/libguile/gc.c index d2e13d88e..c8aec31a9 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -796,28 +796,6 @@ scm_igc (const char *what) ++scm_gc_heap_lock; - /* unprotect any struct types with no instances */ -#if 0 - { - SCM type_list; - SCM * pos; - - pos = &scm_type_obj_list; - type_list = scm_type_obj_list; - while (type_list != SCM_EOL) - if (SCM_VELTS (SCM_CAR (type_list))[scm_struct_i_refcnt]) - { - pos = SCM_CDRLOC (type_list); - type_list = SCM_CDR (type_list); - } - else - { - *pos = SCM_CDR (type_list); - type_list = SCM_CDR (type_list); - } - } -#endif - /* flush dead entries from the continuation stack */ { int x; diff --git a/libguile/root.h b/libguile/root.h index 5ed36ec83..58466b29a 100644 --- a/libguile/root.h +++ b/libguile/root.h @@ -65,18 +65,17 @@ #define scm_weak_symhash scm_sys_protects[6] #define scm_symhash_vars scm_sys_protects[7] #define scm_keyword_obarray scm_sys_protects[8] -#define scm_type_obj_list scm_sys_protects[9] -#define scm_first_type scm_sys_protects[10] -#define scm_stand_in_procs scm_sys_protects[11] -#define scm_object_whash scm_sys_protects[12] -#define scm_permobjs scm_sys_protects[13] -#define scm_asyncs scm_sys_protects[14] -#define scm_protects scm_sys_protects[15] +#define scm_first_type scm_sys_protects[9] +#define scm_stand_in_procs scm_sys_protects[10] +#define scm_object_whash scm_sys_protects[11] +#define scm_permobjs scm_sys_protects[12] +#define scm_asyncs scm_sys_protects[13] +#define scm_protects scm_sys_protects[14] #ifdef DEBUG_EXTENSIONS -#define scm_source_whash scm_sys_protects[16] -#define SCM_NUM_PROTECTS 17 -#else +#define scm_source_whash scm_sys_protects[15] #define SCM_NUM_PROTECTS 16 +#else +#define SCM_NUM_PROTECTS 15 #endif extern SCM scm_sys_protects[]; From 939794ce7f602438ed45d70e74133b59358084a3 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 28 Jun 2000 10:26:52 +0000 Subject: [PATCH 0024/2047] * Cleaned up initialization of asyncs. * Moved handling of scm_gc_async to gc.c. * Extracted handling of scheme level after-gc-hook from gc core. --- libguile/ChangeLog | 36 +++++++++++++++++++++++ libguile/async.c | 38 +----------------------- libguile/async.h | 3 +- libguile/gc.c | 72 ++++++++++++++++++++++++++++++++++++++++++---- libguile/init.c | 2 +- 5 files changed, 106 insertions(+), 45 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 649fe9c4f..e5940c1b3 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,39 @@ +2000-06-28 Dirk Herrmann + + * async.c (scm_gc_async, scm_gc_vcell, scm_sys_gc_async_thunk): + Moved to gc.c. + + (scm_init_async): Moved initialization for scm_gc_async and + scm_gc_vcell to gc.c. Moved initialization of scm_asyncs here + from gc.c. + + * async.h (scm_gc_async): Not globally visible any more. + + * gc.c (scm_gc_stats): Made callable even from within regions + where gc is blocked. + + (scm_gc_end): Eliminate the hardcoding of the marking of the + scm_gc_async from the gc core. + + (scm_init_storage): Don't initialize the scm_asyncs list here. + This is now done in asyncs.c. + + (scm_gc_vcell): Moved here from async.c. + + (gc_async): Renamed from scm_gc_async, moved here from async.c + and made static. + + (gc_async_thunk): Renamed from scm_sys_gc_async_thunk and moved + here from async.c. + + (mark_gc_async): New hook function for scm_after_gc_c_hook. + + (scm_init_gc): Added initialization of scm_gc_vcell and + gc_async. Further, add mark_gc_async to scm_after_gc_c_hook. + + * init.c (scm_boot_guile_1): scm_init_gc requires asyncs to be + initialized. + 2000-06-28 Dirk Herrmann * gc.c (scm_igc): Removed commented code that once was intended diff --git a/libguile/async.c b/libguile/async.c index 39330a35f..b04796cd7 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -51,7 +51,6 @@ #include "libguile/throw.h" #include "libguile/root.h" #include "libguile/smob.h" -#include "libguile/gc.h" #include "libguile/validate.h" #include "libguile/async.h" @@ -442,36 +441,6 @@ SCM_DEFINE (scm_set_switch_rate, "set-switch-rate", 1, 0, 0, #undef FUNC_NAME #endif - - -/* points to the GC system-async, so that scm_gc_end can find it. */ -SCM scm_gc_async; - -/* the vcell for gc-thunk. */ -static SCM scm_gc_vcell; - -/* the thunk installed in the GC system-async, which is marked at the - end of garbage collection. */ -static SCM -scm_sys_gc_async_thunk (void) -{ - scm_c_run_hook (scm_after_gc_hook, SCM_EOL); - -#if (SCM_DEBUG_DEPRECATED == 0) - - /* The following code will be removed in Guile 1.5. */ - if (SCM_NFALSEP (scm_gc_vcell)) - { - SCM proc = SCM_CDR (scm_gc_vcell); - - if (SCM_NFALSEP (proc) && !SCM_UNBNDP (proc)) - scm_apply (proc, SCM_EOL, SCM_EOL); - } - -#endif /* SCM_DEBUG_DEPRECATED == 0 */ - - return SCM_UNSPECIFIED; -} @@ -501,15 +470,10 @@ SCM_DEFINE (scm_mask_signals, "mask-signals", 0, 0, 0, void scm_init_async () { - SCM a_thunk; - + scm_asyncs = SCM_EOL; tc16_async = scm_make_smob_type ("async", 0); scm_set_smob_mark (tc16_async, mark_async); - scm_gc_vcell = scm_sysintern ("gc-thunk", SCM_BOOL_F); - a_thunk = scm_make_gsubr ("%gc-thunk", 0, 0, 0, scm_sys_gc_async_thunk); - scm_gc_async = scm_system_async (a_thunk); - #include "libguile/async.x" } diff --git a/libguile/async.h b/libguile/async.h index 39d5868d7..b4fa403cb 100644 --- a/libguile/async.h +++ b/libguile/async.h @@ -49,11 +49,10 @@ #include "libguile/__scm.h" - extern unsigned int scm_mask_ints; -extern SCM scm_gc_async; + extern int scm_asyncs_pending (void); diff --git a/libguile/gc.c b/libguile/gc.c index c8aec31a9..0fe25d58b 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -572,7 +572,9 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, SCM answer; SCM_DEFER_INTS; - scm_block_gc = 1; + + ++scm_block_gc; + retry: heap_segs = SCM_EOL; n = scm_n_heap_segs; @@ -582,7 +584,8 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, heap_segs); if (scm_n_heap_segs != n) goto retry; - scm_block_gc = 0; + + --scm_block_gc; /* Below, we cons to produce the resulting list. We want a snapshot of * the heap situation before consing. @@ -619,12 +622,12 @@ scm_gc_start (const char *what) scm_gc_ports_collected = 0; } + void scm_gc_end () { scm_gc_rt = SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt; scm_gc_time_taken += scm_gc_rt; - scm_system_async_mark (scm_gc_async); } @@ -746,7 +749,6 @@ scm_alloc_cluster (scm_freelist_t *master) } #endif -SCM scm_after_gc_hook; scm_c_hook_t scm_before_gc_c_hook; scm_c_hook_t scm_before_mark_c_hook; @@ -880,6 +882,7 @@ scm_igc (const char *what) } + /* {Mark/Sweep} */ @@ -2309,7 +2312,6 @@ scm_init_storage (scm_sizet init_heap_size_1, int gc_trigger_1, scm_stand_in_procs = SCM_EOL; scm_permobjs = SCM_EOL; scm_protects = scm_make_vector (SCM_MAKINUM (31), SCM_EOL); - scm_asyncs = SCM_EOL; scm_sysintern ("most-positive-fixnum", SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)); scm_sysintern ("most-negative-fixnum", SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM)); #ifdef SCM_BIGDIG @@ -2317,12 +2319,72 @@ scm_init_storage (scm_sizet init_heap_size_1, int gc_trigger_1, #endif return 0; } + +SCM scm_after_gc_hook; + +#if (SCM_DEBUG_DEPRECATED == 0) +static SCM scm_gc_vcell; /* the vcell for gc-thunk. */ +#endif /* SCM_DEBUG_DEPRECATED == 0 */ +static SCM gc_async; + + +/* The function gc_async_thunk causes the execution of the after-gc-hook. It + * is run after the gc, as soon as the asynchronous events are handled by the + * evaluator. + */ +static SCM +gc_async_thunk (void) +{ + scm_c_run_hook (scm_after_gc_hook, SCM_EOL); + +#if (SCM_DEBUG_DEPRECATED == 0) + + /* The following code will be removed in Guile 1.5. */ + if (SCM_NFALSEP (scm_gc_vcell)) + { + SCM proc = SCM_CDR (scm_gc_vcell); + + if (SCM_NFALSEP (proc) && !SCM_UNBNDP (proc)) + scm_apply (proc, SCM_EOL, SCM_EOL); + } + +#endif /* SCM_DEBUG_DEPRECATED == 0 */ + + return SCM_UNSPECIFIED; +} + + +/* The function mark_gc_async is run by the scm_after_gc_c_hook at the end of + * the garbage collection. The only purpose of this function is to mark the + * gc_async (which will eventually lead to the execution of the + * gc_async_thunk). + */ +static void * +mark_gc_async (void * hook_data, void *func_data, void *data) +{ + scm_system_async_mark (gc_async); + return NULL; +} + + void scm_init_gc () { + SCM after_gc_thunk; + scm_after_gc_hook = scm_create_hook ("after-gc-hook", 0); + +#if (SCM_DEBUG_DEPRECATED == 0) + scm_gc_vcell = scm_sysintern ("gc-thunk", SCM_BOOL_F); +#endif /* SCM_DEBUG_DEPRECATED == 0 */ + /* Dirk:FIXME:: We don't really want a binding here. */ + after_gc_thunk = scm_make_gsubr ("%gc-thunk", 0, 0, 0, gc_async_thunk); + gc_async = scm_system_async (after_gc_thunk); + + scm_c_hook_add (&scm_after_gc_c_hook, mark_gc_async, NULL, 0); + #include "libguile/gc.x" } diff --git a/libguile/init.c b/libguile/init.c index b7bb1644d..ea61c5b19 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -514,7 +514,7 @@ scm_boot_guile_1 (SCM_STACKITEM *base, struct main_func_closure *closure) scm_init_hashtab (); scm_init_objprop (); scm_init_hooks (); /* Requires objprop until hook names are removed */ - scm_init_gc (); /* Requires hooks */ + scm_init_gc (); /* Requires hooks, async */ #ifdef GUILE_ISELECT scm_init_iselect (); #endif From 150c200bdd8f1ce965b0588266df3955eff2f4d4 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Wed, 28 Jun 2000 13:17:11 +0000 Subject: [PATCH 0025/2047] * gc.c (scm_gc_for_newcell): don't try to do GC if it's blocked, allocate instead. --- libguile/ChangeLog | 5 +++++ libguile/gc.c | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index e5940c1b3..dd390003d 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-06-28 Michael Livshin + + * gc.c (scm_gc_for_newcell): don't try to do GC if it's blocked, + allocate instead. + 2000-06-28 Dirk Herrmann * async.c (scm_gc_async, scm_gc_vcell, scm_sys_gc_async_thunk): diff --git a/libguile/gc.c b/libguile/gc.c index 0fe25d58b..c9ccca65c 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -705,7 +705,7 @@ scm_gc_for_newcell (scm_freelist_t *master, SCM *freelist) { if (SCM_NULLP (master->clusters)) { - if (master->grow_heap_p) + if (master->grow_heap_p || scm_block_gc) { master->grow_heap_p = 0; alloc_some_heap (master); From 0a7a74453eab4e18fa59c6c9abb32836ec483359 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 29 Jun 2000 08:27:40 +0000 Subject: [PATCH 0026/2047] * Removed unused identifier MIN_GC_YIELD. --- libguile/ChangeLog | 4 ++++ libguile/gc.c | 7 +------ 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index dd390003d..582d97431 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2000-06-28 Dirk Herrmann + + * gc.c (MIN_GC_YIELD): Removed. + 2000-06-28 Michael Livshin * gc.c (scm_gc_for_newcell): don't try to do GC if it's blocked, diff --git a/libguile/gc.c b/libguile/gc.c index c9ccca65c..aca9fd907 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -47,6 +47,7 @@ #include #include "libguile/_scm.h" +#include "libguile/eval.h" #include "libguile/stime.h" #include "libguile/stackchk.h" #include "libguile/struct.h" @@ -239,14 +240,8 @@ int scm_gc_heap_lock = 0; * Don't pause for collection if this is set -- just * expand the heap. */ - int scm_block_gc = 1; -/* If fewer than MIN_GC_YIELD cells are recovered during a garbage - * collection (GC) more space is allocated for the heap. - */ -#define MIN_GC_YIELD(freelist) (freelist->heap_size / 4) - /* During collection, this accumulates objects holding * weak references. */ From fc3d77788a6a8ac632a1e9655a5c24d12eb0d34a Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 29 Jun 2000 09:13:17 +0000 Subject: [PATCH 0027/2047] * Removed scm_first_type. --- libguile/ChangeLog | 6 +++++- libguile/root.h | 17 ++++++++--------- 2 files changed, 13 insertions(+), 10 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 582d97431..d89ed742d 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,4 +1,8 @@ -2000-06-28 Dirk Herrmann +2000-06-29 Dirk Herrmann + + * root.h (scm_first_type): Removed. + +2000-06-29 Dirk Herrmann * gc.c (MIN_GC_YIELD): Removed. diff --git a/libguile/root.h b/libguile/root.h index 58466b29a..c769e6c98 100644 --- a/libguile/root.h +++ b/libguile/root.h @@ -65,17 +65,16 @@ #define scm_weak_symhash scm_sys_protects[6] #define scm_symhash_vars scm_sys_protects[7] #define scm_keyword_obarray scm_sys_protects[8] -#define scm_first_type scm_sys_protects[9] -#define scm_stand_in_procs scm_sys_protects[10] -#define scm_object_whash scm_sys_protects[11] -#define scm_permobjs scm_sys_protects[12] -#define scm_asyncs scm_sys_protects[13] -#define scm_protects scm_sys_protects[14] +#define scm_stand_in_procs scm_sys_protects[9] +#define scm_object_whash scm_sys_protects[10] +#define scm_permobjs scm_sys_protects[11] +#define scm_asyncs scm_sys_protects[12] +#define scm_protects scm_sys_protects[13] #ifdef DEBUG_EXTENSIONS -#define scm_source_whash scm_sys_protects[15] -#define SCM_NUM_PROTECTS 16 -#else +#define scm_source_whash scm_sys_protects[14] #define SCM_NUM_PROTECTS 15 +#else +#define SCM_NUM_PROTECTS 14 #endif extern SCM scm_sys_protects[]; From acf4331fa5e8aefed476cef48b3d486cc09926bd Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 29 Jun 2000 13:31:33 +0000 Subject: [PATCH 0028/2047] * Use appropriate error signalling functions. --- libguile/ChangeLog | 6 ++++++ libguile/gc.c | 32 +++++++++++++++++++++----------- 2 files changed, 27 insertions(+), 11 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d89ed742d..d23895fc9 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2000-06-29 Dirk Herrmann + + * gc.c (scm_gc_mark, scm_gc_sweep, scm_must_malloc, + scm_must_realloc, scm_must_free, alloc_some_heap): Use the + appropriate error signalling function. + 2000-06-29 Dirk Herrmann * root.h (scm_first_type): Removed. diff --git a/libguile/gc.c b/libguile/gc.c index aca9fd907..f400fdf39 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -887,6 +887,7 @@ scm_igc (const char *what) */ void scm_gc_mark (SCM p) +#define FUNC_NAME "scm_gc_mark" { register long i; register SCM ptr; @@ -899,7 +900,7 @@ gc_mark_loop: gc_mark_nimp: if (SCM_NCELLP (ptr)) - scm_wta (ptr, "rogue pointer in heap", NULL); + SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL); switch (SCM_TYP7 (ptr)) { @@ -1178,9 +1179,11 @@ gc_mark_nimp: } break; default: - def:scm_wta (ptr, "unknown type in ", "gc_mark"); + def: + SCM_MISC_ERROR ("unknown type", SCM_EOL); } } +#undef FUNC_NAME /* Mark a Region Conservatively @@ -1321,6 +1324,7 @@ gc_sweep_freelist_finish (scm_freelist_t *freelist) void scm_gc_sweep () +#define FUNC_NAME "scm_gc_sweep" { register SCM_CELLPTR ptr; register SCM nfreelist; @@ -1546,7 +1550,8 @@ scm_gc_sweep () } break; default: - sweeperr:scm_wta (scmptr, "unknown type in ", "gc_sweep"); + sweeperr: + SCM_MISC_ERROR ("unknown type", SCM_EOL); } #if 0 if (SCM_CAR (scmptr) == (SCM) scm_tc_free_cell) @@ -1623,6 +1628,7 @@ scm_gc_sweep () scm_mallocated -= m; scm_gc_malloc_collected = m; } +#undef FUNC_NAME @@ -1687,8 +1693,7 @@ scm_must_malloc (scm_sizet size, const char *what) return ptr; } - scm_wta (SCM_MAKINUM (size), (char *) SCM_NALLOC, what); - return 0; /* never reached */ + scm_memory_error (what); } @@ -1736,12 +1741,13 @@ scm_must_realloc (void *where, return ptr; } - scm_wta (SCM_MAKINUM (size), (char *) SCM_NALLOC, what); - return 0; /* never reached */ + scm_memory_error (what); } + void scm_must_free (void *obj) +#define FUNC_NAME "scm_must_free" { #ifdef GUILE_DEBUG_MALLOC scm_malloc_unregister (obj); @@ -1749,8 +1755,10 @@ scm_must_free (void *obj) if (obj) free (obj); else - scm_wta (SCM_INUM0, "already free", ""); + SCM_MISC_ERROR ("freeing NULL pointer", SCM_EOL); } +#undef FUNC_NAME + /* Announce that there has been some malloc done that will be freed * during gc. A typical use is for a smob that uses some malloced @@ -1933,6 +1941,7 @@ round_to_cluster_size (scm_freelist_t *freelist, scm_sizet len) static void alloc_some_heap (scm_freelist_t *freelist) +#define FUNC_NAME "alloc_some_heap" { scm_heap_seg_data_t * tmptable; SCM_CELLPTR ptr; @@ -1942,7 +1951,7 @@ alloc_some_heap (scm_freelist_t *freelist) * aren't supposed to add heap segments. */ if (scm_gc_heap_lock) - scm_wta (SCM_UNDEFINED, "need larger initial", "heap"); + SCM_MISC_ERROR ("can not grow heap while locked", SCM_EOL); /* Expand the heap tables to have room for the new segment. * Do not yet increment scm_n_heap_segs -- that is done by init_heap_seg @@ -1953,7 +1962,7 @@ alloc_some_heap (scm_freelist_t *freelist) SCM_SYSCALL (tmptable = ((scm_heap_seg_data_t *) realloc ((char *)scm_heap_table, len))); if (!tmptable) - scm_wta (SCM_UNDEFINED, "could not grow", "hplims"); + SCM_MISC_ERROR ("could not grow heap segment table", SCM_EOL); else scm_heap_table = tmptable; @@ -2016,8 +2025,9 @@ alloc_some_heap (scm_freelist_t *freelist) } } - scm_wta (SCM_UNDEFINED, "could not grow", "heap"); + SCM_MISC_ERROR ("could not grow heap", SCM_EOL); } +#undef FUNC_NAME SCM_DEFINE (scm_unhash_name, "unhash-name", 1, 0, 0, From 9b166f1273d16da2590720d3a57c2d17f97f2218 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 29 Jun 2000 15:06:31 +0000 Subject: [PATCH 0029/2047] * Removed some unused identifiers and commented code. --- libguile/ChangeLog | 10 ++++++++++ libguile/__scm.h | 43 +------------------------------------------ libguile/async.c | 12 ------------ 3 files changed, 11 insertions(+), 54 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d23895fc9..169b48508 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,13 @@ +2000-06-29 Dirk Herrmann + + * __scm.h: Removed some commented code and fixed some comments. + + (SCM_HUP_SIGNAL, SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, + SCM_SEGV_SIGNAL, SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, + SCM_SIG_ORD, SCM_ORD_SIG, SCM_NUM_SIGS): Removed. + + * async.c: Removed some commented code. + 2000-06-29 Dirk Herrmann * gc.c (scm_gc_mark, scm_gc_sweep, scm_must_malloc, diff --git a/libguile/__scm.h b/libguile/__scm.h index 556e408e5..a3c3093f3 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -550,54 +550,15 @@ extern SCM scm_apply_generic (SCM gf, SCM args); #define SCM_ARG5 5 #define SCM_ARG6 6 #define SCM_ARG7 7 - /* #define SCM_ARGERR(X) ((X) < SCM_WNA \ - ? (char *)(X) \ - : "wrong type argument") - */ -/* Following must match entry indexes in scm_errmsgs[]. - * Also, SCM_WNA must follow the last SCM_ARGn in sequence. +/* SCM_WNA must follow the last SCM_ARGn in sequence. */ #define SCM_WNA 8 - /* #define SCM_OVSCM_FLOW 9 */ #define SCM_OUTOFRANGE 10 #define SCM_NALLOC 11 - /* #define SCM_STACK_OVFLOW 12 */ - /* #define SCM_EXIT 13 */ #endif /* SCM_MAGIC_SNARFER */ -/* (...still matching scm_errmsgs) These - * are signals. Signals may become errors - * but are distinguished because they first - * try to invoke a handler that can resume - * the interrupted routine. - */ -#define SCM_HUP_SIGNAL 14 -#define SCM_INT_SIGNAL 15 -#define SCM_FPE_SIGNAL 16 -#define SCM_BUS_SIGNAL 17 -#define SCM_SEGV_SIGNAL 18 -#define SCM_ALRM_SIGNAL 19 -#define SCM_GC_SIGNAL 20 -#define SCM_TICK_SIGNAL 21 - -#define SCM_SIG_ORD(X) ((X) - SCM_HUP_SIGNAL) -#define SCM_ORD_SIG(X) ((X) + SCM_HUP_SIGNAL) -#define SCM_NUM_SIGS (SCM_SIG_ORD (SCM_TICK_SIGNAL) + 1) - -#if 0 -struct errdesc -{ - char *msg; - char *s_response; - short parent_err; -}; - - -extern struct errdesc scm_errmsgs[]; -#endif - /* SCM_EXIT_SUCCESS is the default code to return from SCM if no errors @@ -621,8 +582,6 @@ extern struct errdesc scm_errmsgs[]; #endif /* def vms */ #endif /* ndef SCM_EXIT_FAILURE */ - - #endif /* __SCMH */ diff --git a/libguile/async.c b/libguile/async.c index b04796cd7..7c16cdddb 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -142,14 +142,6 @@ scm_asyncs_pending () return 0; } -#if 0 -static SCM -scm_sys_tick_async_thunk (void) -{ - scm_deliver_signal (SCM_TICK_SIGNAL); - return SCM_BOOL_F; -} -#endif void scm_async_click () @@ -228,10 +220,6 @@ scm_async_click () } } - /* - if (owe_tick) - scm_async_mark (system_signal_asyncs[SCM_SIG_ORD(SCM_TICK_SIGNAL)]); */ - SCM_DEFER_INTS; if (scm_tick_rate && scm_switch_rate) { From 2500356c67755723d802538e8938b30019f64163 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 29 Jun 2000 15:54:58 +0000 Subject: [PATCH 0030/2047] * Cleaned up memory error signalling. --- libguile/ChangeLog | 13 +++++++++++++ libguile/__scm.h | 1 - libguile/error.c | 2 -- libguile/numbers.c | 4 ++-- libguile/ports.c | 6 ++++-- libguile/random.c | 7 ++----- libguile/smob.c | 8 +++++--- libguile/srcprop.c | 3 ++- libguile/vectors.c | 2 +- 9 files changed, 29 insertions(+), 17 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 169b48508..320c1a56b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,16 @@ +2000-06-29 Dirk Herrmann + + * __scm.h (SCM_NALLOC): Removed. + + * error.c (scm_wta): Removed sick dispatch code for memory + errors. (More sick dispatches still to be removed.) + + * numbers.c (scm_mkbig, scm_adjbig), ports.c (scm_make_port_type), + random.c (scm_i_copy_rstate, scm_c_make_rstate), smob.c + (scm_make_smob_type), srcprop.c (scm_make_srcprops), vectors.c + (scm_vector_set_length_x): Now using scm_memory_error to signal + memory errors. + 2000-06-29 Dirk Herrmann * __scm.h: Removed some commented code and fixed some comments. diff --git a/libguile/__scm.h b/libguile/__scm.h index a3c3093f3..13eaa82c9 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -555,7 +555,6 @@ extern SCM scm_apply_generic (SCM gf, SCM args); */ #define SCM_WNA 8 #define SCM_OUTOFRANGE 10 -#define SCM_NALLOC 11 #endif /* SCM_MAGIC_SNARFER */ diff --git a/libguile/error.c b/libguile/error.c index 5eab67afb..88e6fc030 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -318,8 +318,6 @@ scm_wta (SCM arg, const char *pos, const char *s_subr) scm_wrong_num_args (arg); case SCM_OUTOFRANGE: scm_out_of_range (s_subr, arg); - case SCM_NALLOC: - scm_memory_error (s_subr); default: /* this shouldn't happen. */ scm_misc_error (s_subr, "Unknown error", SCM_EOL); diff --git a/libguile/numbers.c b/libguile/numbers.c index 132fa9440..6d3e808ce 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1319,7 +1319,7 @@ scm_mkbig (scm_sizet nlen, int sign) /* Cast to long int to avoid signed/unsigned comparison warnings. */ if ((( ((long int) nlen) << SCM_BIGSIZEFIELD) >> SCM_BIGSIZEFIELD) != (long int) nlen) - scm_wta (SCM_MAKINUM (nlen), (char *) SCM_NALLOC, s_bignum); + scm_memory_error (s_bignum); SCM_NEWCELL (v); SCM_DEFER_INTS; @@ -1356,7 +1356,7 @@ scm_adjbig (SCM b, scm_sizet nlen) { scm_sizet nsiz = nlen; if (((nsiz << SCM_BIGSIZEFIELD) >> SCM_BIGSIZEFIELD) != nlen) - scm_wta (scm_ulong2num (nsiz), (char *) SCM_NALLOC, s_adjbig); + scm_memory_error (s_adjbig); SCM_DEFER_INTS; { diff --git a/libguile/ports.c b/libguile/ports.c index 3badd8349..0c2536945 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -151,8 +151,10 @@ scm_make_port_type (char *name, } SCM_ALLOW_INTS; if (!tmp) - ptoberr:scm_wta (SCM_MAKINUM ((long) scm_numptob), - (char *) SCM_NALLOC, "scm_make_port_type"); + { + ptoberr: + scm_memory_error ("scm_make_port_type"); + } /* Make a class object if Goops is present */ if (scm_port_class) scm_make_port_classes (scm_numptob - 1, SCM_PTOBNAME (scm_numptob - 1)); diff --git a/libguile/random.c b/libguile/random.c index cfe1d0050..28c94d33c 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -171,8 +171,7 @@ scm_i_copy_rstate (scm_i_rstate *state) { scm_rstate *new_state = malloc (scm_the_rng.rstate_size); if (new_state == 0) - scm_wta (SCM_MAKINUM (scm_the_rng.rstate_size), - (char *) SCM_NALLOC, "rstate"); + scm_memory_error ("rstate"); return memcpy (new_state, state, scm_the_rng.rstate_size); } @@ -186,9 +185,7 @@ scm_c_make_rstate (char *seed, int n) { scm_rstate *state = malloc (scm_the_rng.rstate_size); if (state == 0) - scm_wta (SCM_MAKINUM (scm_the_rng.rstate_size), - (char *) SCM_NALLOC, - "rstate"); + scm_memory_error ("rstate"); state->reserved0 = 0; scm_the_rng.init_rstate (state, seed, n); return state; diff --git a/libguile/smob.c b/libguile/smob.c index 3b5f74069..406c5370b 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -144,9 +144,11 @@ scm_make_smob_type (char *name, scm_sizet size) scm_numsmob++; } SCM_ALLOW_INTS; - if (!tmp) - smoberr:scm_wta (SCM_MAKINUM ((long) scm_numsmob), - (char *) SCM_NALLOC, "scm_make_smob_type"); + if (!tmp) + { + smoberr: + scm_memory_error ("scm_make_smob_type"); + } /* Make a class object if Goops is present. */ if (scm_smob_class) scm_smob_class[scm_numsmob - 1] diff --git a/libguile/srcprop.c b/libguile/srcprop.c index f3aebe800..7f2271df7 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -132,7 +132,8 @@ scm_make_srcprops (int line, int col, SCM filename, SCM copy, SCM plist) scm_sizet n = sizeof (scm_srcprops_chunk) + sizeof (scm_srcprops) * (SRCPROPS_CHUNKSIZE - 1); SCM_SYSCALL (mem = (scm_srcprops_chunk *) malloc (n)); - SCM_ASSERT (mem, SCM_UNDEFINED, SCM_NALLOC, "srcprops"); + if (mem == NULL) + scm_memory_error ("srcprops"); scm_mallocated += n; mem->next = srcprops_chunklist; srcprops_chunklist = mem; diff --git a/libguile/vectors.c b/libguile/vectors.c index 2d045b332..2ffe1302d 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -103,7 +103,7 @@ scm_vector_set_length_x (SCM vect, SCM len) l = 1L; siz = l * sz; if (siz != l * sz) - scm_wta (SCM_MAKINUM (l * sz), (char *) SCM_NALLOC, s_vector_set_length_x); + scm_memory_error (s_vector_set_length_x); SCM_REDEFER_INTS; SCM_SETCHARS (vect, ((char *) From 83d58c82570e93dc15dc381e58bedbea6c9badfb Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Thu, 29 Jun 2000 23:46:59 +0000 Subject: [PATCH 0031/2047] * gc.c (scm_gc_for_newcell): Behave gracefully also if scm_igc doesn't yield any new cells. In theory this could happen if all cells allocated with NEWCELL are either in use or conservatively marked and all cluster spine cells are conservatively marked. (Thanks to Dirk.) --- libguile/gc.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/gc.c b/libguile/gc.c index f400fdf39..eca4c2f4e 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -698,7 +698,7 @@ scm_gc_for_newcell (scm_freelist_t *master, SCM *freelist) ++scm_ints_disabled; do { - if (SCM_NULLP (master->clusters)) + while (SCM_NULLP (master->clusters)) { if (master->grow_heap_p || scm_block_gc) { From 627df12801ed865ecc01eae52762b2e2338022a7 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Thu, 29 Jun 2000 23:47:14 +0000 Subject: [PATCH 0032/2047] *** empty log message *** --- libguile/ChangeLog | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 320c1a56b..9e881d41c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2000-06-30 Mikael Djurfeldt + + * gc.c (scm_gc_for_newcell): Behave gracefully also if scm_igc + doesn't yield any new cells. In theory this could happen if all + cells allocated with NEWCELL are either in use or conservatively + marked and all cluster spine cells are conservatively marked. + (Thanks to Dirk.) + 2000-06-29 Dirk Herrmann * __scm.h (SCM_NALLOC): Removed. From fdf25853e190c086e75fce727c657e27e224eb42 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 30 Jun 2000 09:48:25 +0000 Subject: [PATCH 0033/2047] * Fix range checks of SCM_VALIDATE* macros. --- libguile/ChangeLog | 11 +++++++++++ libguile/validate.h | 10 +++++----- 2 files changed, 16 insertions(+), 5 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 9e881d41c..31cd6ea3f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2000-06-30 Dirk Herrmann + + * validate.h (SCM_VALIDATE_INUM_MIN_COPY, + SCM_VALIDATE_INUM_MIN_DEF_COPY, SCM_VALIDATE_INUM_RANGE_COPY): + Perform all range checks based on the input value. The former way + of using the value that is assigned to the target variable fails + if the assignment to the target variable itself can change the + value because of type conversion. + + (SCM_ASSERT_RANGE): Use scm_out_of_range to signal range errors. + 2000-06-30 Mikael Djurfeldt * gc.c (scm_gc_for_newcell): Behave gracefully also if scm_igc diff --git a/libguile/validate.h b/libguile/validate.h index 8ce49ca68..9889757d8 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -1,4 +1,4 @@ -/* $Id: validate.h,v 1.12 2000-06-05 11:39:46 dirk Exp $ */ +/* $Id: validate.h,v 1.13 2000-06-30 09:48:25 dirk Exp $ */ /* Copyright (C) 1999, 2000 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify @@ -83,7 +83,7 @@ do { scm_out_of_range_pos (FUNC_NAME, arg, SCM_MAKINUM (pos)); } while (0) #define SCM_ASSERT_RANGE(pos, arg, f) \ - do { SCM_ASSERT (f, arg, SCM_OUTOFRANGE, FUNC_NAME); } while (0) + do { if (!(f)) scm_out_of_range (FUNC_NAME, arg); } while (0) #define SCM_MUST_MALLOC_TYPE(type) \ ((type *) scm_must_malloc (sizeof (type), FUNC_NAME)) @@ -212,8 +212,8 @@ #define SCM_VALIDATE_INUM_MIN_COPY(pos, k, min, cvar) \ do { \ SCM_ASSERT (SCM_INUMP (k), k, pos, FUNC_NAME); \ + SCM_ASSERT_RANGE (pos, k, (SCM_INUM (k) >= min)); \ cvar = SCM_INUM (k); \ - SCM_ASSERT_RANGE (pos, k, (cvar >= min)); \ } while (0) #define SCM_VALIDATE_INUM_MIN_DEF_COPY(pos, k, min, default, cvar) \ @@ -221,8 +221,8 @@ if (SCM_UNBNDP (k)) \ k = SCM_MAKINUM (default); \ SCM_ASSERT (SCM_INUMP (k), k, pos, FUNC_NAME); \ + SCM_ASSERT_RANGE (pos, k, (SCM_INUM (k) >= min)); \ cvar = SCM_INUM (k); \ - SCM_ASSERT_RANGE (pos, k, (cvar >= min)); \ } while (0) #define SCM_VALIDATE_INUM_DEF(pos, k, default) \ @@ -257,8 +257,8 @@ #define SCM_VALIDATE_INUM_RANGE_COPY(pos, k, low, high, cvar) \ do { \ SCM_ASSERT (SCM_INUMP (k), k, pos, FUNC_NAME); \ + SCM_ASSERT_RANGE (pos, k, low <= SCM_INUM (k) && SCM_INUM (k) < high); \ cvar = SCM_INUM (k); \ - SCM_ASSERT_RANGE (pos, k, cvar >= low && cvar < high); \ } while (0) #define SCM_VALIDATE_NULL(pos, scm) SCM_MAKE_VALIDATE (pos, scm, NULLP) From 685c0d7116658bcefa6404224832480e1e6cba92 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 30 Jun 2000 10:46:35 +0000 Subject: [PATCH 0034/2047] * Eliminated use of SCM_ASSERT to check for range errors. * Fix some error reporting code in list.c * Added some test cases. --- doc/ChangeLog | 4 + doc/data-rep.texi | 7 +- libguile/ChangeLog | 33 +++++++ libguile/__scm.h | 1 - libguile/error.c | 2 - libguile/hashtab.c | 18 ++-- libguile/hooks.c | 3 +- libguile/list.c | 88 ++++++++++------- libguile/strings.c | 20 ++-- libguile/unif.c | 26 ++--- libguile/vectors.c | 26 ++--- test-suite/ChangeLog | 5 + test-suite/tests/list.test | 195 +++++++++++++++++++++++++++++++++++++ 13 files changed, 339 insertions(+), 89 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 9b7bd4617..bdde435c4 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,7 @@ +2000-06-30 Dirk Herrmann + + * data-rep.tex: Removed documentation for SCM_OUTOFRANGE. + 2000-06-20 Mikael Djurfeldt * data-rep.texi: Center discussion around the standard interface diff --git a/doc/data-rep.texi b/doc/data-rep.texi index d515d3afe..407a79656 100644 --- a/doc/data-rep.texi +++ b/doc/data-rep.texi @@ -46,7 +46,7 @@ by the Free Software Foundation. @sp 10 @comment The title is printed in a large font. @title Data Representation in Guile -@subtitle $Id: data-rep.texi,v 1.11 2000-06-20 03:22:56 mdj Exp $ +@subtitle $Id: data-rep.texi,v 1.12 2000-06-30 10:46:33 dirk Exp $ @subtitle For use with Guile @value{VERSION} @author Jim Blandy @author Free Software Foundation @@ -1077,11 +1077,6 @@ naming the function. Usually, Guile catches these errors before ever invoking the subr, so we don't run into these problems. @end deftypefn -@deftypefn Macro int SCM_OUTOFRANGE -Signal an error complaining that @var{obj} is ``out of range'' for -@var{subr}. -@end deftypefn - @node Defining New Types (Smobs), , How Guile does it, Top @section Defining New Types (Smobs) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 31cd6ea3f..daeabdc4b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,36 @@ +2000-06-30 Dirk Herrmann + + * __scm.h (SCM_OUTOFRANGE): Removed. + + * error.c (scm_wta): Removed sick dispatch code for range + errors. (More sick dispatches still to be removed.) + + * hashtab.c (scm_hash_fn_get_handle, scm_hash_fn_create_handle_x, + scm_hash_fn_remove_x): Eliminate redundant test for if unsigned + value is non-negative. Use scm_out_of_range to signal range + errors. + + * hooks.c (make_hook), unif.c (scm_aind): Use scm_out_of_range to + signal range errors. + + * list.c (scm_list_ref, scm_list_set_x, scm_list_cdr_set_x): Fix + error reporting (now uses original input parameter to report wrong + type argument errors). Use SCM_OUT_OF_RANGE to report range + errors and SCM_WRONG_TYPE_ARG to report type errors. + + * strings.c (scm_substring): Make range checks for negative + values explicit (former behaviour relied on an implicit + conversion from signed to unsigned). Don't use SCM_ASSERT for + range checks. + + * unif.c (scm_aind, scm_transpose_array, scm_bit_set_star_x, + scm_bit_count_star): Use scm_out_of_range to signal range + errors. + + * unif.c (scm_transpose_array, scm_bit_position), vectors.c + (scm_vector_ref, scm_vector_set_x, scm_vector_move_left_x, + scm_vector_move_right_x): Use SCM_ASSERT_RANGE to check ranges. + 2000-06-30 Dirk Herrmann * validate.h (SCM_VALIDATE_INUM_MIN_COPY, diff --git a/libguile/__scm.h b/libguile/__scm.h index 13eaa82c9..f1aa50afb 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -554,7 +554,6 @@ extern SCM scm_apply_generic (SCM gf, SCM args); /* SCM_WNA must follow the last SCM_ARGn in sequence. */ #define SCM_WNA 8 -#define SCM_OUTOFRANGE 10 #endif /* SCM_MAGIC_SNARFER */ diff --git a/libguile/error.c b/libguile/error.c index 88e6fc030..067b3cdb1 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -316,8 +316,6 @@ scm_wta (SCM arg, const char *pos, const char *s_subr) scm_wrong_type_arg (s_subr, 7, arg); case SCM_WNA: scm_wrong_num_args (arg); - case SCM_OUTOFRANGE: - scm_out_of_range (s_subr, arg); default: /* this shouldn't happen. */ scm_misc_error (s_subr, "Unknown error", SCM_EOL); diff --git a/libguile/hashtab.c b/libguile/hashtab.c index f8e20e8de..6b169c6e3 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -66,10 +66,8 @@ scm_hash_fn_get_handle (SCM table,SCM obj,unsigned int (*hash_fn)(),SCM (*assoc_ if (SCM_LENGTH (table) == 0) return SCM_EOL; k = hash_fn (obj, SCM_LENGTH (table), closure); - SCM_ASSERT ((0 <= k) && (k < SCM_LENGTH (table)), - scm_ulong2num (k), - SCM_OUTOFRANGE, - "hash_fn_get_handle"); + if (k >= SCM_LENGTH (table)) + scm_out_of_range ("hash_fn_get_handle", scm_ulong2num (k)); h = assoc_fn (obj, SCM_VELTS (table)[k], closure); return h; } @@ -87,10 +85,8 @@ scm_hash_fn_create_handle_x (SCM table,SCM obj,SCM init,unsigned int (*hash_fn)( if (SCM_LENGTH (table) == 0) return SCM_EOL; k = hash_fn (obj, SCM_LENGTH (table), closure); - SCM_ASSERT ((0 <= k) && (k < SCM_LENGTH (table)), - scm_ulong2num (k), - SCM_OUTOFRANGE, - "hash_fn_create_handle_x"); + if (k >= SCM_LENGTH (table)) + scm_out_of_range ("hash_fn_create_handle_x", scm_ulong2num (k)); SCM_REDEFER_INTS; it = assoc_fn (obj, SCM_VELTS (table)[k], closure); if (SCM_NIMP (it)) @@ -154,10 +150,8 @@ scm_hash_fn_remove_x (SCM table,SCM obj,unsigned int (*hash_fn)(),SCM (*assoc_fn if (SCM_LENGTH (table) == 0) return SCM_EOL; k = hash_fn (obj, SCM_LENGTH (table), closure); - SCM_ASSERT ((0 <= k) && (k < SCM_LENGTH (table)), - scm_ulong2num (k), - SCM_OUTOFRANGE, - "hash_fn_remove_x"); + if (k >= SCM_LENGTH (table)) + scm_out_of_range ("hash_fn_remove_x", scm_ulong2num (k)); h = assoc_fn (obj, SCM_VELTS (table)[k], closure); SCM_VELTS(table)[k] = delete_fn (h, SCM_VELTS(table)[k]); return h; diff --git a/libguile/hooks.c b/libguile/hooks.c index 862b55a96..712debd87 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -164,7 +164,8 @@ make_hook (SCM n_args, const char *subr) { SCM_ASSERT (SCM_INUMP (n_args), n_args, SCM_ARGn, subr); n = SCM_INUM (n_args); - SCM_ASSERT (n >= 0 && n <= 16, n_args, SCM_OUTOFRANGE, subr); + if (n < 0 || n > 16) + scm_out_of_range (subr, n_args); } SCM_RETURN_NEWSMOB (scm_tc16_hook + (n << 16), SCM_EOL); } diff --git a/libguile/list.c b/libguile/list.c index 25aac038f..cabdba417 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -346,44 +346,55 @@ SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0, } #undef FUNC_NAME - + /* indexing lists by element number */ SCM_DEFINE (scm_list_ref, "list-ref", 2, 0, 0, - (SCM lst, SCM k), - "Return the Kth element from list LST.") + (SCM list, SCM k), + "Return the Kth element from LIST.") #define FUNC_NAME s_scm_list_ref { - register long i; + SCM lst = list; + unsigned long int i; SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i); - while (i-- > 0) { - SCM_ASRTGO(SCM_CONSP(lst), erout); - lst = SCM_CDR(lst); - } - erout: - SCM_ASSERT(SCM_CONSP(lst), - SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, FUNC_NAME); - return SCM_CAR(lst); + while (SCM_CONSP (lst)) { + if (i == 0) + return SCM_CAR (lst); + else { + --i; + lst = SCM_CDR (lst); + } + }; + if (SCM_NULLP (lst)) + SCM_OUT_OF_RANGE (2, k); + else + SCM_WRONG_TYPE_ARG (1, list); } #undef FUNC_NAME + SCM_DEFINE (scm_list_set_x, "list-set!", 3, 0, 0, - (SCM lst, SCM k, SCM val), - "Set the @var{k}th element of @var{lst} to @var{val}.") + (SCM list, SCM k, SCM val), + "Set the @var{k}th element of @var{list} to @var{val}.") #define FUNC_NAME s_scm_list_set_x { - register long i; + SCM lst = list; + unsigned long int i; SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i); - while (i-- > 0) { - SCM_ASRTGO(SCM_CONSP(lst), erout); - lst = SCM_CDR(lst); - } - erout: - SCM_ASSERT(SCM_CONSP(lst), - SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, FUNC_NAME); - SCM_SETCAR (lst, val); - return val; + while (SCM_CONSP (lst)) { + if (i == 0) { + SCM_SETCAR (lst, val); + return val; + } else { + --i; + lst = SCM_CDR (lst); + } + }; + if (SCM_NULLP (lst)) + SCM_OUT_OF_RANGE (2, k); + else + SCM_WRONG_TYPE_ARG (1, list); } #undef FUNC_NAME @@ -411,21 +422,26 @@ SCM_DEFINE (scm_list_tail, "list-tail", 2, 0, 0, SCM_DEFINE (scm_list_cdr_set_x, "list-cdr-set!", 3, 0, 0, - (SCM lst, SCM k, SCM val), - "Set the @var{k}th cdr of @var{lst} to @var{val}.") + (SCM list, SCM k, SCM val), + "Set the @var{k}th cdr of @var{list} to @var{val}.") #define FUNC_NAME s_scm_list_cdr_set_x { - register long i; + SCM lst = list; + unsigned long int i; SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i); - while (i-- > 0) { - SCM_ASRTGO(SCM_CONSP(lst), erout); - lst = SCM_CDR(lst); - } -erout: - SCM_ASSERT(SCM_CONSP(lst), - SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, FUNC_NAME); - SCM_SETCDR (lst, val); - return val; + while (SCM_CONSP (lst)) { + if (i == 0) { + SCM_SETCDR (lst, val); + return val; + } else { + --i; + lst = SCM_CDR (lst); + } + }; + if (SCM_NULLP (lst)) + SCM_OUT_OF_RANGE (2, k); + else + SCM_WRONG_TYPE_ARG (1, list); } #undef FUNC_NAME diff --git a/libguile/strings.c b/libguile/strings.c index a20607df9..44ae6215c 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -278,7 +278,6 @@ SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0, #undef FUNC_NAME - SCM_DEFINE (scm_substring, "substring", 2, 1, 0, (SCM str, SCM start, SCM end), "Returns a newly allocated string formed from the characters\n" @@ -288,18 +287,23 @@ SCM_DEFINE (scm_substring, "substring", 2, 1, 0, "0 <= START <= END <= (string-length STR).") #define FUNC_NAME s_scm_substring { - long l; + long int from; + long int to; + SCM_VALIDATE_ROSTRING (1,str); - SCM_VALIDATE_INUM (2,start); + SCM_VALIDATE_INUM (2, start); SCM_VALIDATE_INUM_DEF (3,end,SCM_ROLENGTH(str)); - SCM_ASSERT_RANGE (2,start,SCM_INUM (start) <= SCM_ROLENGTH (str)); - SCM_ASSERT_RANGE (2,end,SCM_INUM (end) <= SCM_ROLENGTH (str)); - l = SCM_INUM (end)-SCM_INUM (start); - SCM_ASSERT (l >= 0, SCM_MAKINUM (l), SCM_OUTOFRANGE, FUNC_NAME); - return scm_makfromstr (&SCM_ROCHARS (str)[SCM_INUM (start)], (scm_sizet)l, 0); + + from = SCM_INUM (start); + SCM_ASSERT_RANGE (2, start, 0 <= from && from <= SCM_ROLENGTH (str)); + to = SCM_INUM (end); + SCM_ASSERT_RANGE (3, end, from <= to && to <= SCM_ROLENGTH (str)); + + return scm_makfromstr (&SCM_ROCHARS (str)[from], (scm_sizet) (to - from), 0); } #undef FUNC_NAME + SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, (SCM args), "Returns a newly allocated string whose characters form the\n" diff --git a/libguile/unif.c b/libguile/unif.c index 19f7acea1..cc029157d 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -480,7 +480,8 @@ scm_aind (SCM ra, SCM args, const char *what) args = SCM_CDR (args); SCM_ASSERT (SCM_INUMP (ind), ind, s_bad_ind, what); j = SCM_INUM (ind); - SCM_ASSERT (j >= (s->lbnd) && j <= (s->ubnd), ind, SCM_OUTOFRANGE, what); + if (j < s->lbnd || j > s->ubnd) + scm_out_of_range (what, ind); pos += (j - s->lbnd) * (s->inc); k--; s++; @@ -831,8 +832,8 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); SCM_ASSERT (SCM_INUMP (SCM_CAR (args)), SCM_CAR (args), SCM_ARG2, FUNC_NAME); - SCM_ASSERT (SCM_EQ_P (SCM_INUM0, SCM_CAR (args)), SCM_CAR (args), SCM_OUTOFRANGE, - FUNC_NAME); + SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), + SCM_EQ_P (SCM_INUM0, SCM_CAR (args))); return ra; case scm_tc7_smob: SCM_ASRTGO (SCM_ARRAYP (ra), badarg); @@ -846,8 +847,8 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, SCM_ASSERT (SCM_INUMP (ve[k]), ve[k], (SCM_ARG2 + k), FUNC_NAME); i = SCM_INUM (ve[k]); - SCM_ASSERT (i >= 0 && i < SCM_ARRAY_NDIM (ra), ve[k], - SCM_OUTOFRANGE, FUNC_NAME); + if (i < 0 || i >= SCM_ARRAY_NDIM (ra)) + scm_out_of_range (FUNC_NAME, ve[k]); if (ndim < i) ndim = i; } @@ -1770,8 +1771,7 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, register unsigned long w; SCM_VALIDATE_NIM (2,v); SCM_VALIDATE_INUM_COPY (3,k,pos); - SCM_ASSERT ((pos <= SCM_LENGTH (v)) && (pos >= 0), - k, SCM_OUTOFRANGE, FUNC_NAME); + SCM_ASSERT_RANGE (3, k, (pos <= SCM_LENGTH (v)) && (pos >= 0)); if (pos == SCM_LENGTH (v)) return SCM_BOOL_F; switch SCM_TYP7 (v) @@ -1856,14 +1856,16 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, for (i = SCM_LENGTH (kv); i;) { k = SCM_UNPACK (SCM_VELTS (kv)[--i]); - SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); + if (k >= vlen) + scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k)); SCM_BITVEC_CLR(v,k); } else if (SCM_EQ_P (obj, SCM_BOOL_T)) for (i = SCM_LENGTH (kv); i;) { k = SCM_UNPACK (SCM_VELTS (kv)[--i]); - SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); + if (k >= vlen) + scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k)); SCM_BITVEC_SET(v,k); } else @@ -1920,7 +1922,8 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, for (i = SCM_LENGTH (kv); i;) { k = SCM_UNPACK (SCM_VELTS (kv)[--i]); - SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); + if (k >= vlen) + scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k)); if (!SCM_BITVEC_REF(v,k)) count++; } @@ -1928,7 +1931,8 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, for (i = SCM_LENGTH (kv); i;) { k = SCM_UNPACK (SCM_VELTS (kv)[--i]); - SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); + if (k >= vlen) + scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k)); if (SCM_BITVEC_REF (v,k)) count++; } diff --git a/libguile/vectors.c b/libguile/vectors.c index 2ffe1302d..1c59b96c1 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -200,15 +200,16 @@ SCM_GPROC (s_vector_ref, "vector-ref", 2, 0, 0, scm_vector_ref, g_vector_ref); SCM scm_vector_ref (SCM v, SCM k) +#define FUNC_NAME s_vector_ref { SCM_GASSERT2 (SCM_VECTORP (v), g_vector_ref, v, k, SCM_ARG1, s_vector_ref); SCM_GASSERT2 (SCM_INUMP (k), g_vector_ref, v, k, SCM_ARG2, s_vector_ref); - SCM_ASSERT (SCM_INUM (k) < SCM_LENGTH (v) && SCM_INUM (k) >= 0, - k, SCM_OUTOFRANGE, s_vector_ref); + SCM_ASSERT_RANGE (2, k, SCM_INUM (k) < SCM_LENGTH (v) && SCM_INUM (k) >= 0); return SCM_VELTS (v)[(long) SCM_INUM (k)]; } +#undef FUNC_NAME SCM_GPROC (s_vector_set_x, "vector-set!", 3, 0, 0, scm_vector_set_x, g_vector_set_x); @@ -233,6 +234,7 @@ The value returned by @samp{vector-set!} is unspecified. SCM scm_vector_set_x (SCM v, SCM k, SCM obj) +#define FUNC_NAME s_vector_set_x { SCM_GASSERTn (SCM_VECTORP (v), g_vector_set_x, SCM_LIST3 (v, k, obj), @@ -240,11 +242,11 @@ scm_vector_set_x (SCM v, SCM k, SCM obj) SCM_GASSERTn (SCM_INUMP (k), g_vector_set_x, SCM_LIST3 (v, k, obj), SCM_ARG2, s_vector_set_x); - SCM_ASSERT ((SCM_INUM (k) < SCM_LENGTH (v)) && (SCM_INUM (k) >= 0), - k, SCM_OUTOFRANGE, s_vector_set_x); + SCM_ASSERT_RANGE (2, k, SCM_INUM (k) < SCM_LENGTH (v) && SCM_INUM (k) >= 0); SCM_VELTS(v)[(long) SCM_INUM(k)] = obj; return SCM_UNSPECIFIED; } +#undef FUNC_NAME SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0, @@ -342,10 +344,10 @@ SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0, SCM_VALIDATE_INUM_COPY (3,end1,e); SCM_VALIDATE_VECTOR (4,vec2); SCM_VALIDATE_INUM_COPY (5,start2,j); - SCM_ASSERT (i <= SCM_LENGTH (vec1) && i >= 0, start1, SCM_OUTOFRANGE, FUNC_NAME); - SCM_ASSERT (j <= SCM_LENGTH (vec2) && j >= 0, start2, SCM_OUTOFRANGE, FUNC_NAME); - SCM_ASSERT (e <= SCM_LENGTH (vec1) && e >= 0, end1, SCM_OUTOFRANGE, FUNC_NAME); - SCM_ASSERT (e-i+j <= SCM_LENGTH (vec2), start2, SCM_OUTOFRANGE, FUNC_NAME); + SCM_ASSERT_RANGE (2, start1, i <= SCM_LENGTH (vec1) && i >= 0); + SCM_ASSERT_RANGE (5, start2, j <= SCM_LENGTH (vec2) && j >= 0); + SCM_ASSERT_RANGE (3, end1, e <= SCM_LENGTH (vec1) && e >= 0); + SCM_ASSERT_RANGE (5, start2, e-i+j <= SCM_LENGTH (vec2)); while (i= 0, start1, SCM_OUTOFRANGE, FUNC_NAME); - SCM_ASSERT (j <= SCM_LENGTH (vec2) && j >= 0, start2, SCM_OUTOFRANGE, FUNC_NAME); - SCM_ASSERT (e <= SCM_LENGTH (vec1) && e >= 0, end1, SCM_OUTOFRANGE, FUNC_NAME); + SCM_ASSERT_RANGE (2, start1, i <= SCM_LENGTH (vec1) && i >= 0); + SCM_ASSERT_RANGE (5, start2, j <= SCM_LENGTH (vec2) && j >= 0); + SCM_ASSERT_RANGE (3, end1, e <= SCM_LENGTH (vec1) && e >= 0); j = e - i + j; - SCM_ASSERT (j <= SCM_LENGTH (vec2), start2, SCM_OUTOFRANGE, FUNC_NAME); + SCM_ASSERT_RANGE (5, start2, j <= SCM_LENGTH (vec2)); while (i < e) SCM_VELTS (vec2)[--j] = SCM_VELTS (vec1)[--e]; return SCM_UNSPECIFIED; diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index a6b768eab..9bcf4fe21 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2000-06-30 Dirk Herrmann + + * tests/list.test: Added tests for list-ref, list-set! and + list-cdr-set! + 2000-06-21 Dirk Herrmann * tests/common-list.test: Added. diff --git a/test-suite/tests/list.test b/test-suite/tests/list.test index c3546a638..99e9b3fec 100644 --- a/test-suite/tests/list.test +++ b/test-suite/tests/list.test @@ -451,9 +451,138 @@ ;;; list-ref +(with-test-prefix "list-ref" + + ;; Is documentation available? + + (pass-if "documented?" (object-documentation list-ref)) + + (with-test-prefix "argument error" + + (with-test-prefix "non list argument" + #t) + + (with-test-prefix "improper list argument" + #t) + + (with-test-prefix "non integer index" + #t) + + (with-test-prefix "index out of range" + + (with-test-prefix "empty list" + + (pass-if "index 0" + (catch 'out-of-range + (lambda () + (list-ref '() 0) + #f) + (lambda (key . args) + #t))) + + (pass-if "index > 0" + (catch 'out-of-range + (lambda () + (list-ref '() 1) + #f) + (lambda (key . args) + #t))) + + (pass-if "index < 0" + (catch 'out-of-range + (lambda () + (list-ref '() -1) + #f) + (lambda (key . args) + #t)))) + + (with-test-prefix "non-empty list" + + (pass-if "index > length" + (catch 'out-of-range + (lambda () + (list-ref '(1) 1) + #f) + (lambda (key . args) + #t))) + + (pass-if "index < 0" + (catch 'out-of-range + (lambda () + (list-ref '(1) -1) + #f) + (lambda (key . args) + #t))))))) + ;;; list-set! +(with-test-prefix "list-set!" + + ;; Is documentation available? + + (pass-if "documented?" (object-documentation list-set!)) + + (with-test-prefix "argument error" + + (with-test-prefix "non list argument" + #t) + + (with-test-prefix "improper list argument" + #t) + + (with-test-prefix "read-only list argument" + #t) + + (with-test-prefix "non integer index" + #t) + + (with-test-prefix "index out of range" + + (with-test-prefix "empty list" + + (pass-if "index 0" + (catch 'out-of-range + (lambda () + (list-set! (list) 0 #t) + #f) + (lambda (key . args) + #t))) + + (pass-if "index > 0" + (catch 'out-of-range + (lambda () + (list-set! (list) 1 #t) + #f) + (lambda (key . args) + #t))) + + (pass-if "index < 0" + (catch 'out-of-range + (lambda () + (list-set! (list) -1 #t) + #f) + (lambda (key . args) + #t)))) + + (with-test-prefix "non-empty list" + + (pass-if "index > length" + (catch 'out-of-range + (lambda () + (list-set! (list 1) 1 #t) + #f) + (lambda (key . args) + #t))) + + (pass-if "index < 0" + (catch 'out-of-range + (lambda () + (list-set! (list 1) -1 #t) + #f) + (lambda (key . args) + #t))))))) + ;;; list-cdr-ref @@ -463,6 +592,72 @@ ;;; list-cdr-set! +(with-test-prefix "list-cdr-set!" + + ;; Is documentation available? + + (pass-if "documented?" (object-documentation list-cdr-set!)) + + (with-test-prefix "argument error" + + (with-test-prefix "non list argument" + #t) + + (with-test-prefix "improper list argument" + #t) + + (with-test-prefix "read-only list argument" + #t) + + (with-test-prefix "non integer index" + #t) + + (with-test-prefix "index out of range" + + (with-test-prefix "empty list" + + (pass-if "index 0" + (catch 'out-of-range + (lambda () + (list-cdr-set! (list) 0 #t) + #f) + (lambda (key . args) + #t))) + + (pass-if "index > 0" + (catch 'out-of-range + (lambda () + (list-cdr-set! (list) 1 #t) + #f) + (lambda (key . args) + #t))) + + (pass-if "index < 0" + (catch 'out-of-range + (lambda () + (list-cdr-set! (list) -1 #t) + #f) + (lambda (key . args) + #t)))) + + (with-test-prefix "non-empty list" + + (pass-if "index > length" + (catch 'out-of-range + (lambda () + (list-cdr-set! (list 1) 1 #t) + #f) + (lambda (key . args) + #t))) + + (pass-if "index < 0" + (catch 'out-of-range + (lambda () + (list-cdr-set! (list 1) -1 #t) + #f) + (lambda (key . args) + #t))))))) + ;;; list-head From c73879189d82d0a12ebdb077dfaa86e0849fa39f Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 30 Jun 2000 13:48:28 +0000 Subject: [PATCH 0035/2047] * Improved memory error handling. * Made the behaviour of scm_gc_for_newcell more obvious. --- libguile/ChangeLog | 9 +++++++++ libguile/gc.c | 18 +++++++++++++++--- 2 files changed, 24 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index daeabdc4b..7dda5afbd 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2000-06-30 Dirk Herrmann + + * gc.c (alloc_some_heap): Use scm_memory_error to indicate a + failed attempt to get additional memory from the system. + + (scm_gc_for_newcell): Changed the control structure to make the + behaviour explicit for the case that gc is not able to free any + cells. + 2000-06-30 Dirk Herrmann * __scm.h (SCM_OUTOFRANGE): Removed. diff --git a/libguile/gc.c b/libguile/gc.c index eca4c2f4e..075b28194 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -698,7 +698,7 @@ scm_gc_for_newcell (scm_freelist_t *master, SCM *freelist) ++scm_ints_disabled; do { - while (SCM_NULLP (master->clusters)) + if (SCM_NULLP (master->clusters)) { if (master->grow_heap_p || scm_block_gc) { @@ -715,6 +715,12 @@ scm_gc_for_newcell (scm_freelist_t *master, SCM *freelist) #endif scm_igc ("cells"); adjust_min_yield (master); + if (SCM_NULLP (master->clusters)) + { + /* gc could not free any cells */ + master->grow_heap_p = 0; + alloc_some_heap (master); + } } } cell = SCM_CAR (master->clusters); @@ -1962,7 +1968,10 @@ alloc_some_heap (scm_freelist_t *freelist) SCM_SYSCALL (tmptable = ((scm_heap_seg_data_t *) realloc ((char *)scm_heap_table, len))); if (!tmptable) - SCM_MISC_ERROR ("could not grow heap segment table", SCM_EOL); + /* Dirk:FIXME:: scm_memory_error needs an additional message parameter. + * Here: "could not grow heap segment table". + */ + scm_memory_error (FUNC_NAME); else scm_heap_table = tmptable; @@ -2025,7 +2034,10 @@ alloc_some_heap (scm_freelist_t *freelist) } } - SCM_MISC_ERROR ("could not grow heap", SCM_EOL); + /* Dirk:FIXME:: scm_memory_error needs an additional message parameter. + * Here: "could not grow heap". + */ + scm_memory_error (FUNC_NAME); } #undef FUNC_NAME From c76b1eafa3d30bae68e03b99c30c41c7e3727148 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 30 Jun 2000 16:08:48 +0000 Subject: [PATCH 0036/2047] * numbers.c (scm_gr_p, scm_leq_p, scm_geq_p): Turned into primitive generics. (Thanks to Nicolas Neuss.) --- libguile/numbers.c | 49 +++++++++++++++++++++++++++++++++------------- 1 file changed, 35 insertions(+), 14 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 6d3e808ce..e1e1396db 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -3053,34 +3053,55 @@ scm_less_p (SCM x, SCM y) } -SCM_DEFINE1 (scm_gr_p, ">", scm_tc7_rpsubr, - (SCM x, SCM y), - "Return #t if the list of parameters is monotonically\n" - "increasing.") +SCM_GPROC1 (s_scm_gr_p, ">", scm_tc7_rpsubr, scm_gr_p, g_gr_p); +/* "Return #t if the list of parameters is monotonically\n" + * "increasing." + */ #define FUNC_NAME s_scm_gr_p +SCM +scm_gr_p (SCM x, SCM y) { - return scm_less_p (y, x); + if (!SCM_NUMBERP (x)) + SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG1, FUNC_NAME); + else if (!SCM_NUMBERP (y)) + SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG2, FUNC_NAME); + else + return scm_less_p (y, x); } #undef FUNC_NAME -SCM_DEFINE1 (scm_leq_p, "<=", scm_tc7_rpsubr, - (SCM x, SCM y), - "Return #t if the list of parameters is monotonically\n" - "non-decreasing.") +SCM_GPROC1 (s_scm_leq_p, "<=", scm_tc7_rpsubr, scm_leq_p, g_leq_p); +/* "Return #t if the list of parameters is monotonically\n" + * "non-decreasing." + */ #define FUNC_NAME s_scm_leq_p +SCM +scm_leq_p (SCM x, SCM y) { - return SCM_BOOL_NOT (scm_less_p (y, x)); + if (!SCM_NUMBERP (x)) + SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG1, FUNC_NAME); + else if (!SCM_NUMBERP (y)) + SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG2, FUNC_NAME); + else + return SCM_BOOL_NOT (scm_less_p (y, x)); } #undef FUNC_NAME -SCM_DEFINE1 (scm_geq_p, ">=", scm_tc7_rpsubr, - (SCM x, SCM y), - "Return #t if the list of parameters is monotonically\n" - "non-increasing.") +SCM_GPROC1 (s_scm_geq_p, ">=", scm_tc7_rpsubr, scm_geq_p, g_geq_p); +/* "Return #t if the list of parameters is monotonically\n" + * "non-increasing." + */ #define FUNC_NAME s_scm_geq_p +SCM +scm_geq_p (SCM x, SCM y) { + if (!SCM_NUMBERP (x)) + SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG1, FUNC_NAME); + else if (!SCM_NUMBERP (y)) + SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG2, FUNC_NAME); + else return SCM_BOOL_NOT (scm_less_p (x, y)); } #undef FUNC_NAME From a75a7aff74ac813d217bbd3f99648230e8d40f52 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 30 Jun 2000 16:09:13 +0000 Subject: [PATCH 0037/2047] *** empty log message *** --- libguile/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 7dda5afbd..081800f92 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-06-30 Mikael Djurfeldt + + * numbers.c (scm_gr_p, scm_leq_p, scm_geq_p): Turned into + primitive generics. (Thanks to Nicolas Neuss.) + 2000-06-30 Dirk Herrmann * gc.c (alloc_some_heap): Use scm_memory_error to indicate a From b06a8b87c4c3043ec2e665a5e0455c5b3c15c3cf Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 30 Jun 2000 16:14:56 +0000 Subject: [PATCH 0038/2047] * debug.c: Added #include fluids.h. --- libguile/debug.c | 1 + 1 file changed, 1 insertion(+) diff --git a/libguile/debug.c b/libguile/debug.c index 81b3576e4..0473cacab 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -65,6 +65,7 @@ #include "libguile/modules.h" #include "libguile/ports.h" #include "libguile/root.h" +#include "libguile/fluids.h" #include "libguile/validate.h" #include "libguile/debug.h" From 38ec519cbfb6bc6ca7eb86a35f997f8a0cf4ef11 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 30 Jun 2000 16:16:08 +0000 Subject: [PATCH 0039/2047] *** empty log message *** --- libguile/ChangeLog | 2 ++ 1 file changed, 2 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 081800f92..9a5d5982d 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,7 @@ 2000-06-30 Mikael Djurfeldt + * debug.c: Added #include fluids.h. + * numbers.c (scm_gr_p, scm_leq_p, scm_geq_p): Turned into primitive generics. (Thanks to Nicolas Neuss.) From b63a956dc50aa3234ccda2c5c6bcda4d9e41acbc Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 30 Jun 2000 17:37:26 +0000 Subject: [PATCH 0040/2047] * Re-introduced some symbols as deprecated. --- NEWS | 8 ++++++++ RELEASE | 7 +++++++ libguile/ChangeLog | 11 +++++++++++ libguile/__scm.h | 22 ++++++++++++++++++++++ libguile/error.c | 10 ++++++++++ 5 files changed, 58 insertions(+) diff --git a/NEWS b/NEWS index 062bb1430..5c3a2189e 100644 --- a/NEWS +++ b/NEWS @@ -55,6 +55,14 @@ Example: * Changes to the scm_ interface +** Deprecated macros: SCM_OUTOFRANGE, SCM_NALLOC, SCM_HUP_SIGNAL, +SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, +SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD, +SCM_ORD_SIG, SCM_NUM_SIGS + +Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of SCM_OUTOFRANGE. +Use scm_memory_error instead of SCM_NALLOC. + Changes since Guile 1.3.4: diff --git a/RELEASE b/RELEASE index 13d47924e..9921ed806 100644 --- a/RELEASE +++ b/RELEASE @@ -33,6 +33,13 @@ In release 1.5: SCM_UNEGFIXABLE, SCM_FLOBUFLEN, SCM_INEXP, SCM_CPLXP, SCM_REAL, SCM_IMAG, SCM_REALPART, scm_makdbl, SCM_SINGP, SCM_NUM2DBL, SCM_NO_BIGDIG +In release 1.6: +- remove deprecated macros: SCM_OUTOFRANGE, SCM_NALLOC, SCM_HUP_SIGNAL, + SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, + SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD, + SCM_ORD_SIG, SCM_NUM_SIGS + + Modules sort.c and random.c should be factored out into separate modules (but still be distributed with guile-core) when we get a new module system. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 9a5d5982d..2d8b96768 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2000-06-30 Dirk Herrmann + + * __scm.h (SCM_OUTOFRANGE, SCM_NALLOC, SCM_HUP_SIGNAL, + SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, + SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD, + SCM_ORD_SIG, SCM_NUM_SIGS): Re-introduce these as deprecated + symbols. + + * error.c (scm_wta): Re-introduce dispatching for SCM_OUTOFRANGE + and SCM_NALLOC, but as a deprecated feature. + 2000-06-30 Mikael Djurfeldt * debug.c: Added #include fluids.h. diff --git a/libguile/__scm.h b/libguile/__scm.h index f1aa50afb..2146ca9ac 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -555,6 +555,28 @@ extern SCM scm_apply_generic (SCM gf, SCM args); */ #define SCM_WNA 8 +#if (SCM_DEBUG_DEPRECATED == 0) + +/* Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of: */ +#define SCM_OUTOFRANGE 10 + +/* Use scm_memory_error instead of: */ +#define SCM_NALLOC 11 + +#define SCM_HUP_SIGNAL 14 +#define SCM_INT_SIGNAL 15 +#define SCM_FPE_SIGNAL 16 +#define SCM_BUS_SIGNAL 17 +#define SCM_SEGV_SIGNAL 18 +#define SCM_ALRM_SIGNAL 19 +#define SCM_GC_SIGNAL 20 +#define SCM_TICK_SIGNAL 21 +#define SCM_SIG_ORD(X) ((X) - SCM_HUP_SIGNAL) +#define SCM_ORD_SIG(X) ((X) + SCM_HUP_SIGNAL) +#define SCM_NUM_SIGS (SCM_SIG_ORD (SCM_TICK_SIGNAL) + 1) + +#endif /* SCM_DEBUG_DEPRECATED == 0 */ + #endif /* SCM_MAGIC_SNARFER */ diff --git a/libguile/error.c b/libguile/error.c index 067b3cdb1..850bf5b7d 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -316,6 +316,16 @@ scm_wta (SCM arg, const char *pos, const char *s_subr) scm_wrong_type_arg (s_subr, 7, arg); case SCM_WNA: scm_wrong_num_args (arg); + +#if (SCM_DEBUG_DEPRECATED == 0) + + case SCM_OUTOFRANGE: + scm_out_of_range (s_subr, arg); + case SCM_NALLOC: + scm_memory_error (s_subr); + +#endif /* SCM_DEBUG_DEPRECATED == 0 */ + default: /* this shouldn't happen. */ scm_misc_error (s_subr, "Unknown error", SCM_EOL); From a63982381352191464247b55ddfadfe2f15956fe Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 30 Jun 2000 20:00:54 +0000 Subject: [PATCH 0041/2047] *** empty log message *** --- THANKS | 1 + 1 file changed, 1 insertion(+) diff --git a/THANKS b/THANKS index 30b01958a..700e4dfcf 100644 --- a/THANKS +++ b/THANKS @@ -10,4 +10,5 @@ Contributors since the last release: For fixes or providing information which led to a fix: Brad Knotwell + Nicolas Neuss William Webber From 80edbc334753cfe6ce52c3c47f1e4462362a0752 Mon Sep 17 00:00:00 2001 From: "Greg J. Badros" Date: Sat, 1 Jul 2000 00:13:17 +0000 Subject: [PATCH 0042/2047] *** empty log message *** --- ice-9/ChangeLog | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index a1234ace3..b5905cf2e 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -77,6 +77,20 @@ (find-documentation): Renamed from `documentation'. Return documentation string instead of printing it. Not exported. +Tue Jun 6 09:21:28 2000 Greg J. Badros + + * session.scm: Update references to `proc-doc' to be + `proc-documentation' + + * doc.scm: Cleaned up a great deal. Put variables at the top of + the file, eliminated `object-documentation' that was broken + (referencing Scwm), drop `help' as session.scm has a better + supported version of that procedure. Rename `proc-doc' to + `proc-documentation' -- `procedure-documentation' is a primitive + getter function, so I use the shorter name for this more useful + function. (Alternatively, we could rename the primitive + getter...) + 2000-06-05 Mikael Djurfeldt * boot-9.scm (error-catching-loop): Inform about debugger on error. From a473feada17baaa08d93106a8767d65f225174d5 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sat, 1 Jul 2000 17:01:22 +0000 Subject: [PATCH 0043/2047] * boot-9.scm (process-define-module): Bugfix: Only check the CDR for export args. --- ice-9/boot-9.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 590bc7788..d190a771c 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1828,7 +1828,7 @@ (purify-module! module) (loop (cdr kws) reversed-interfaces)) ((export) - (if (not (and (pair? (cdr kws)) (pair? (cddr kws)))) + (if (not (pair? (cdr kws))) (error "unrecognized defmodule argument" kws)) (module-export! module (cadr kws)) (loop (cddr kws) reversed-interfaces)) From 45036de1f77bad5d5628f3d80e9ad698ef04d74e Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sat, 1 Jul 2000 17:01:37 +0000 Subject: [PATCH 0044/2047] *** empty log message *** --- ice-9/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index b5905cf2e..02f1a1024 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2000-07-01 Mikael Djurfeldt + + * boot-9.scm (process-define-module): Bugfix: Only check the CDR + for export args. + 2000-06-27 Dirk Herrmann * popen.scm: gc-thunk is deprecated. Use after-gc-hook instead. From a6c12a04cf2e71b742ff994fa18603c442ebff0d Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 6 Jul 2000 08:48:14 +0000 Subject: [PATCH 0045/2047] * Don't include in gh.h. Thanks to Han-Wen Nienhuys. --- THANKS | 1 + libguile/ChangeLog | 5 +++++ libguile/gh.h | 2 -- 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/THANKS b/THANKS index 700e4dfcf..c4bcb6540 100644 --- a/THANKS +++ b/THANKS @@ -11,4 +11,5 @@ For fixes or providing information which led to a fix: Brad Knotwell Nicolas Neuss + Han-Wen Nienhuys William Webber diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 2d8b96768..5731e0f37 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-07-06 Dirk Herrmann + + * gh.g: Don't include . Thanks to Han-Wen Nienhuys for + the hint. + 2000-06-30 Dirk Herrmann * __scm.h (SCM_OUTOFRANGE, SCM_NALLOC, SCM_HUP_SIGNAL, diff --git a/libguile/gh.h b/libguile/gh.h index b9b03cfdc..447c43867 100644 --- a/libguile/gh.h +++ b/libguile/gh.h @@ -47,8 +47,6 @@ extern "C" { #endif -#include - #include /* gcc has extern inline functions that are basically as fast as macros */ From b6efc9510ea4b33e55d4ff73eca33192135b3c52 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 6 Jul 2000 09:10:22 +0000 Subject: [PATCH 0046/2047] * Keep track of the heap segment table size. * Let the caller of alloc_some_heap determine the behaviour in case of malloc failures. Use this feature in scm_gc_for_newcell. --- libguile/ChangeLog | 24 +++++++++++- libguile/gc.c | 98 +++++++++++++++++++++++++++++++--------------- 2 files changed, 89 insertions(+), 33 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 5731e0f37..ce4bce375 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,6 +1,28 @@ 2000-07-06 Dirk Herrmann - * gh.g: Don't include . Thanks to Han-Wen Nienhuys for + * gc.c (policy_on_error): Added in order to allow alloc_some_heap + to react to malloc failures in a context dependent way. + + (scm_check_freelist): No need to flush streams before abort(). + + (scm_gc_for_newcell): Try to allocate new memory in three phases: + grow heap if preferred, if still no memory available collect + garbage, if still no memory available grow heap. + + (heap_segment_table_size): Added to always reflect the actual + size of the heap segment table, because scm_n_heap_segs may differ + from the heap segment table size. + + (alloc_some_heap): In case of malloc failure, react according to + the new policy_on_error parameter (either return to caller or + abort immediately). Further, keep heap_segment_table_size up to + date. + + (scm_init_storage): Initialize heap_segment_table_size. + +2000-07-06 Dirk Herrmann + + * gh.h: Don't include . Thanks to Han-Wen Nienhuys for the hint. 2000-06-30 Dirk Herrmann diff --git a/libguile/gc.c b/libguile/gc.c index 075b28194..0c4491af2 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -282,7 +282,9 @@ typedef struct scm_heap_seg_data_t static scm_sizet init_heap_seg (SCM_CELLPTR, scm_sizet, scm_freelist_t *); -static void alloc_some_heap (scm_freelist_t *); + +typedef enum { return_on_error, abort_on_error } policy_on_error; +static void alloc_some_heap (scm_freelist_t *, policy_on_error); @@ -444,7 +446,6 @@ scm_check_freelist (SCM freelist) { fprintf (stderr, "Bad cell in freelist on newcell %lu: %d'th elt\n", scm_newcell_count, i); - fflush (stderr); abort (); } } @@ -687,6 +688,7 @@ adjust_min_yield (scm_freelist_t *freelist) } } + /* When we get POSIX threads support, the master will be global and * common while the freelist will be individual for each thread. */ @@ -702,11 +704,19 @@ scm_gc_for_newcell (scm_freelist_t *master, SCM *freelist) { if (master->grow_heap_p || scm_block_gc) { + /* In order to reduce gc frequency, try to allocate a new heap + * segment first, even if gc might find some free cells. If we + * can't obtain a new heap segment, we will try gc later. + */ master->grow_heap_p = 0; - alloc_some_heap (master); + alloc_some_heap (master, return_on_error); } - else + if (SCM_NULLP (master->clusters)) { + /* The heap was not grown, either because it wasn't scheduled to + * grow, or because there was not enough memory available. In + * both cases we have to try gc to get some free cells. + */ #ifdef DEBUGINFO fprintf (stderr, "allocated = %d, ", scm_cells_allocated @@ -717,9 +727,11 @@ scm_gc_for_newcell (scm_freelist_t *master, SCM *freelist) adjust_min_yield (master); if (SCM_NULLP (master->clusters)) { - /* gc could not free any cells */ - master->grow_heap_p = 0; - alloc_some_heap (master); + /* gc could not free any cells. Now, we _must_ allocate a + * new heap segment, because there is no other possibility + * to provide a new cell for the caller. + */ + alloc_some_heap (master, abort_on_error); } } } @@ -734,6 +746,7 @@ scm_gc_for_newcell (scm_freelist_t *master, SCM *freelist) return cell; } + #if 0 /* This is a support routine which can be used to reserve a cluster * for some special use, such as debugging. It won't be useful until @@ -757,6 +770,7 @@ scm_c_hook_t scm_before_sweep_c_hook; scm_c_hook_t scm_after_sweep_c_hook; scm_c_hook_t scm_after_gc_c_hook; + void scm_igc (const char *what) { @@ -1819,6 +1833,7 @@ scm_sizet scm_max_segment_size; SCM_CELLPTR scm_heap_org; scm_heap_seg_data_t * scm_heap_table = 0; +static unsigned int heap_segment_table_size = 0; int scm_n_heap_segs = 0; /* init_heap_seg @@ -1946,34 +1961,51 @@ round_to_cluster_size (scm_freelist_t *freelist, scm_sizet len) } static void -alloc_some_heap (scm_freelist_t *freelist) +alloc_some_heap (scm_freelist_t *freelist, policy_on_error error_policy) #define FUNC_NAME "alloc_some_heap" { - scm_heap_seg_data_t * tmptable; SCM_CELLPTR ptr; long len; - /* Critical code sections (such as the garbage collector) - * aren't supposed to add heap segments. - */ - if (scm_gc_heap_lock) - SCM_MISC_ERROR ("can not grow heap while locked", SCM_EOL); + if (scm_gc_heap_lock) + { + /* Critical code sections (such as the garbage collector) aren't + * supposed to add heap segments. + */ + fprintf (stderr, "alloc_some_heap: Can not extend locked heap.\n"); + abort (); + } - /* Expand the heap tables to have room for the new segment. - * Do not yet increment scm_n_heap_segs -- that is done by init_heap_seg - * only if the allocation of the segment itself succeeds. - */ - len = (1 + scm_n_heap_segs) * sizeof (scm_heap_seg_data_t); + if (scm_n_heap_segs == heap_segment_table_size) + { + /* We have to expand the heap segment table to have room for the new + * segment. Do not yet increment scm_n_heap_segs -- that is done by + * init_heap_seg only if the allocation of the segment itself succeeds. + */ + unsigned int new_table_size = scm_n_heap_segs + 1; + size_t size = new_table_size * sizeof (scm_heap_seg_data_t); + scm_heap_seg_data_t * new_heap_table; - SCM_SYSCALL (tmptable = ((scm_heap_seg_data_t *) - realloc ((char *)scm_heap_table, len))); - if (!tmptable) - /* Dirk:FIXME:: scm_memory_error needs an additional message parameter. - * Here: "could not grow heap segment table". - */ - scm_memory_error (FUNC_NAME); - else - scm_heap_table = tmptable; + SCM_SYSCALL (new_heap_table = ((scm_heap_seg_data_t *) + realloc ((char *)scm_heap_table, size))); + if (!new_heap_table) + { + if (error_policy == abort_on_error) + { + fprintf (stderr, "alloc_some_heap: Could not grow heap segment table.\n"); + abort (); + } + else + { + return; + } + } + else + { + scm_heap_table = new_heap_table; + heap_segment_table_size = new_table_size; + } + } /* Pick a size for the new heap segment. @@ -2034,10 +2066,11 @@ alloc_some_heap (scm_freelist_t *freelist) } } - /* Dirk:FIXME:: scm_memory_error needs an additional message parameter. - * Here: "could not grow heap". - */ - scm_memory_error (FUNC_NAME); + if (error_policy == abort_on_error) + { + fprintf (stderr, "alloc_some_heap: Could not grow heap.\n"); + abort (); + } } #undef FUNC_NAME @@ -2289,6 +2322,7 @@ scm_init_storage (scm_sizet init_heap_size_1, int gc_trigger_1, scm_mtrigger = SCM_INIT_MALLOC_LIMIT; scm_heap_table = ((scm_heap_seg_data_t *) scm_must_malloc (sizeof (scm_heap_seg_data_t) * 2, "hplims")); + heap_segment_table_size = 2; if (make_initial_segment (init_heap_size_1, &scm_master_freelist) || make_initial_segment (init_heap_size_2, &scm_master_freelist2)) From cbaadf0202f6a99fdd24ac2541a6af1fdcdd9430 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 7 Jul 2000 15:28:56 +0000 Subject: [PATCH 0047/2047] * Signal an error when adding entries to a hash table with no slots. --- libguile/ChangeLog | 5 +++++ libguile/hashtab.c | 8 ++++---- 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index ce4bce375..9de06a427 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-07-07 Dirk Herrmann + + * hashtab.c (scm_hash_fn_create_handle_x): Signal an error if the + given hash table has no slots. + 2000-07-06 Dirk Herrmann * gc.c (policy_on_error): Added in order to allow alloc_some_heap diff --git a/libguile/hashtab.c b/libguile/hashtab.c index 6b169c6e3..e65a4776b 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -73,17 +73,18 @@ scm_hash_fn_get_handle (SCM table,SCM obj,unsigned int (*hash_fn)(),SCM (*assoc_ } - SCM scm_hash_fn_create_handle_x (SCM table,SCM obj,SCM init,unsigned int (*hash_fn)(), SCM (*assoc_fn)(),void * closure) +#define FUNC_NAME "scm_hash_fn_create_handle_x" { unsigned int k; SCM it; SCM_ASSERT (SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_create_handle_x"); if (SCM_LENGTH (table) == 0) - return SCM_EOL; + SCM_MISC_ERROR ("void hashtable", SCM_EOL); + k = hash_fn (obj, SCM_LENGTH (table), closure); if (k >= SCM_LENGTH (table)) scm_out_of_range ("hash_fn_create_handle_x", scm_ulong2num (k)); @@ -104,8 +105,7 @@ scm_hash_fn_create_handle_x (SCM table,SCM obj,SCM init,unsigned int (*hash_fn)( return SCM_CAR (new_bucket); } } - - +#undef FUNC_NAME SCM From f706a58b671131718a85cf7ccd6f40edb52a0cc9 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 10 Jul 2000 13:54:03 +0000 Subject: [PATCH 0048/2047] * Make the compiler warn about code like SCM_CELL_WORD (x, n) = y. --- libguile/ChangeLog | 11 +++++++++++ libguile/gc.h | 26 +++++++++++--------------- 2 files changed, 22 insertions(+), 15 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 9de06a427..c26394e76 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2000-07-10 Dirk Herrmann + + * gc.h (SCM_CELL_WORD, SCM_CELL_OBJECT): Treat the referenced + object as const in order to make the compiler warn about code like + SCM_CELL_WORD (x, n) = y. Instead, SCM_SET_CELL_WORD (x, n, y) + should be used. + + (SCM_CELL_WORD_LOC, SCM_CARLOC, SCM_CDRLOC): Return the address + as an address to a non-const object, since these macros are used + to allow direct write access to objects. + 2000-07-07 Dirk Herrmann * hashtab.c (scm_hash_fn_create_handle_x): Signal an error if the diff --git a/libguile/gc.h b/libguile/gc.h index 431e3ad44..a90d47614 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -92,33 +92,29 @@ typedef scm_cell * SCM_CELLPTR; #define SCM_VALIDATE_CELL(cell, expr) expr #endif -#define SCM_CELL_WORD(x, n) \ - SCM_VALIDATE_CELL ((x), \ - ((scm_bits_t *) SCM2PTR (x)) [n]) +#define SCM_CELL_WORD(x, n) \ + SCM_VALIDATE_CELL ((x), ((const scm_bits_t *) SCM2PTR (x)) [n]) #define SCM_CELL_WORD_0(x) SCM_CELL_WORD (x, 0) #define SCM_CELL_WORD_1(x) SCM_CELL_WORD (x, 1) #define SCM_CELL_WORD_2(x) SCM_CELL_WORD (x, 2) #define SCM_CELL_WORD_3(x) SCM_CELL_WORD (x, 3) -#define SCM_CELL_OBJECT(x, n) \ - SCM_VALIDATE_CELL ((x), \ - SCM_PACK (((scm_bits_t *) SCM2PTR (x)) [n])) +#define SCM_CELL_OBJECT(x, n) \ + SCM_VALIDATE_CELL ((x), SCM_PACK (((const scm_bits_t *) SCM2PTR (x)) [n])) #define SCM_CELL_OBJECT_0(x) SCM_CELL_OBJECT (x, 0) #define SCM_CELL_OBJECT_1(x) SCM_CELL_OBJECT (x, 1) #define SCM_CELL_OBJECT_2(x) SCM_CELL_OBJECT (x, 2) #define SCM_CELL_OBJECT_3(x) SCM_CELL_OBJECT (x, 3) -#define SCM_SET_CELL_WORD(x, n, v) \ - SCM_VALIDATE_CELL ((x), \ - ((scm_bits_t *) SCM2PTR (x)) [n] = (scm_bits_t) (v)) +#define SCM_SET_CELL_WORD(x, n, v) \ + SCM_VALIDATE_CELL ((x), ((scm_bits_t *) SCM2PTR (x)) [n] = (scm_bits_t) (v)) #define SCM_SET_CELL_WORD_0(x, v) SCM_SET_CELL_WORD (x, 0, v) #define SCM_SET_CELL_WORD_1(x, v) SCM_SET_CELL_WORD (x, 1, v) #define SCM_SET_CELL_WORD_2(x, v) SCM_SET_CELL_WORD (x, 2, v) #define SCM_SET_CELL_WORD_3(x, v) SCM_SET_CELL_WORD (x, 3, v) -#define SCM_SET_CELL_OBJECT(x, n, v) \ - SCM_VALIDATE_CELL ((x), \ - ((scm_bits_t *) SCM2PTR (x)) [n] = SCM_UNPACK (v)) +#define SCM_SET_CELL_OBJECT(x, n, v) \ + SCM_VALIDATE_CELL ((x), ((scm_bits_t *) SCM2PTR (x)) [n] = SCM_UNPACK (v)) #define SCM_SET_CELL_OBJECT_0(x, v) SCM_SET_CELL_OBJECT (x, 0, v) #define SCM_SET_CELL_OBJECT_1(x, v) SCM_SET_CELL_OBJECT (x, 1, v) #define SCM_SET_CELL_OBJECT_2(x, v) SCM_SET_CELL_OBJECT (x, 2, v) @@ -136,9 +132,9 @@ typedef scm_cell * SCM_CELLPTR; #define SCM_SETOR_CDR(x, y)\ (SCM_SETCDR ((x), SCM_PACK (SCM_UNPACK (SCM_CDR (x)) | (y)))) -#define SCM_CELL_WORD_LOC(x, n) (&SCM_CELL_WORD (x, n)) -#define SCM_CARLOC(x) ((SCM *) (&(((scm_bits_t *) SCM2PTR (x)) [0]))) -#define SCM_CDRLOC(x) ((SCM *) (&(((scm_bits_t *) SCM2PTR (x)) [1]))) +#define SCM_CELL_WORD_LOC(x, n) ((scm_bits_t *) & SCM_CELL_WORD (x, n)) +#define SCM_CARLOC(x) ((SCM *) SCM_CELL_WORD_LOC ((x), 0)) +#define SCM_CDRLOC(x) ((SCM *) SCM_CELL_WORD_LOC ((x), 1)) /* SCM_PTR_LT and friends define how to compare two SCM_CELLPTRs (which may From 3f5d82cd9a59cc94cd056c95c61e3e9beda50bcc Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 10 Jul 2000 14:25:53 +0000 Subject: [PATCH 0049/2047] * Use a set of dedicated macros to access and modify free cells. --- libguile/ChangeLog | 16 ++++++++++++++++ libguile/gc.c | 41 ++++++++++++++++++++--------------------- libguile/gc.h | 20 ++++++++++++++------ 3 files changed, 50 insertions(+), 27 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index c26394e76..f72ec1cf0 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,19 @@ +2000-07-10 Dirk Herrmann + + * gc.h (SCM_SET_FREE_CELL_TYPE, SCM_SET_FREE_CELL_CDR, + SCM_FREE_CELL_P, SCM_FREE_CELL_CDR): Added since free cells + should not be accessed via SCM_C[AD]R. Further, using dedicated + macros to access free cells allows all other cell accessing macros + to treat acesses to free cells as errors, thus enabling better + error checks for cell accesses. SCM_FREE_CELL_P is supposed to + replace SCM_FREEP some time. + + * gc.h (SCM_NEWCELL, SCM_NEWCELL2), gc.c (map_free_list, + free_list_length, scm_check_freelist, scm_debug_newcell, + scm_debug_newcell2, freelist_length, scm_gc_for_newcell, + scm_gc_mark, scm_gc_sweep, init_heap_seg): Only use the dedicated + cell accessors when accessing free cells. + 2000-07-10 Dirk Herrmann * gc.h (SCM_CELL_WORD, SCM_CELL_OBJECT): Treat the referenced diff --git a/libguile/gc.c b/libguile/gc.c index 0c4491af2..1c053c27c 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -314,7 +314,7 @@ map_free_list (scm_freelist_t *master, SCM freelist) int last_seg = -1, count = 0; SCM f; - for (f = freelist; SCM_NIMP (f); f = SCM_CDR (f)) + for (f = freelist; !SCM_NULLP (f); f = SCM_FREE_CELL_CDR (f)) { int this_seg = which_seg (f); @@ -365,8 +365,8 @@ free_list_length (char *title, int i, SCM freelist) { SCM ls; int n = 0; - for (ls = freelist; SCM_NNULLP (ls); ls = SCM_CDR (ls)) - if (SCM_CELL_TYPE (ls) == scm_tc_free_cell) + for (ls = freelist; !SCM_NULLP (ls); ls = SCM_FREE_CELL_CDR (ls)) + if (SCM_FREE_CELL_P (ls)) ++n; else { @@ -441,8 +441,8 @@ scm_check_freelist (SCM freelist) SCM f; int i = 0; - for (f = freelist; SCM_NIMP (f); f = SCM_CDR (f), i++) - if (SCM_CAR (f) != (SCM) scm_tc_free_cell) + for (f = freelist; !SCM_NULLP (f); f = SCM_FREE_CELL_CDR (f), i++) + if (!SCM_FREE_CELL_P (f)) { fprintf (stderr, "Bad cell in freelist on newcell %lu: %d'th elt\n", scm_newcell_count, i); @@ -479,13 +479,13 @@ scm_debug_newcell (void) /* The rest of this is supposed to be identical to the SCM_NEWCELL macro. */ - if (SCM_IMP (scm_freelist)) + if (SCM_NULLP (scm_freelist)) new = scm_gc_for_newcell (&scm_master_freelist, &scm_freelist); else { new = scm_freelist; - scm_freelist = SCM_CDR (scm_freelist); - SCM_SETCAR (new, scm_tc16_allocated); + scm_freelist = SCM_FREE_CELL_CDR (scm_freelist); + SCM_SET_FREE_CELL_TYPE (new, scm_tc16_allocated); } return new; @@ -505,13 +505,13 @@ scm_debug_newcell2 (void) /* The rest of this is supposed to be identical to the SCM_NEWCELL macro. */ - if (SCM_IMP (scm_freelist2)) + if (SCM_NULLP (scm_freelist2)) new = scm_gc_for_newcell (&scm_master_freelist2, &scm_freelist2); else { new = scm_freelist2; - scm_freelist2 = SCM_CDR (scm_freelist2); - SCM_SETCAR (new, scm_tc16_allocated); + scm_freelist2 = SCM_FREE_CELL_CDR (scm_freelist2); + SCM_SET_FREE_CELL_TYPE (new, scm_tc16_allocated); } return new; @@ -534,7 +534,7 @@ static unsigned long freelist_length (SCM freelist) { int n; - for (n = 0; SCM_NNULLP (freelist); freelist = SCM_CDR (freelist)) + for (n = 0; !SCM_NULLP (freelist); freelist = SCM_FREE_CELL_CDR (freelist)) ++n; return n; } @@ -741,8 +741,8 @@ scm_gc_for_newcell (scm_freelist_t *master, SCM *freelist) } while (SCM_NULLP (cell)); --scm_ints_disabled; - *freelist = SCM_CDR (cell); - SCM_SET_CELL_TYPE (cell, scm_tc16_allocated); + *freelist = SCM_FREE_CELL_CDR (cell); + SCM_SET_FREE_CELL_TYPE (cell, scm_tc16_allocated); return cell; } @@ -919,7 +919,7 @@ gc_mark_loop: return; gc_mark_nimp: - if (SCM_NCELLP (ptr)) + if (!SCM_CELLP (ptr)) SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL); switch (SCM_TYP7 (ptr)) @@ -1264,7 +1264,6 @@ scm_mark_locations (SCM_STACKITEM x[], scm_sizet n) scm_gc_mark (* (SCM *) &x[m]); break; } - } } } @@ -1321,7 +1320,7 @@ gc_sweep_freelist_finish (scm_freelist_t *freelist) { int collected; *freelist->clustertail = freelist->cells; - if (SCM_NNULLP (freelist->cells)) + if (!SCM_NULLP (freelist->cells)) { SCM c = freelist->cells; SCM_SETCAR (c, SCM_CDR (c)); @@ -1574,7 +1573,7 @@ scm_gc_sweep () SCM_MISC_ERROR ("unknown type", SCM_EOL); } #if 0 - if (SCM_CAR (scmptr) == (SCM) scm_tc_free_cell) + if (SCM_FREE_CELL_P (scmptr)) exit (2); #endif if (!--left_to_collect) @@ -1594,7 +1593,7 @@ scm_gc_sweep () conservative collector might trace it as some other type of object. */ SCM_SET_CELL_TYPE (scmptr, scm_tc_free_cell); - SCM_SETCDR (scmptr, nfreelist); + SCM_SET_FREE_CELL_CDR (scmptr, nfreelist); nfreelist = scmptr; } @@ -1930,11 +1929,11 @@ init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, scm_freelist_t *freelist) SCM scmptr = PTR2SCM (ptr); SCM_SET_CELL_TYPE (scmptr, scm_tc_free_cell); - SCM_SETCDR (scmptr, PTR2SCM (ptr + span)); + SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (ptr + span)); ptr += span; } - SCM_SETCDR (PTR2SCM (ptr - span), SCM_EOL); + SCM_SET_FREE_CELL_CDR (PTR2SCM (ptr - span), SCM_EOL); } /* Patch up the last cluster pointer in the segment diff --git a/libguile/gc.h b/libguile/gc.h index a90d47614..49a8ecc97 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -146,13 +146,21 @@ typedef scm_cell * SCM_CELLPTR; #define SCM_PTR_GE(x, y) (!SCM_PTR_LT (x, y)) -/* Dirk:FIXME:: */ /* Freelists consist of linked cells where the type entry holds the value * scm_tc_free_cell and the second entry holds a pointer to the next cell of * the freelist. Due to this structure, freelist cells are not cons cells * and thus may not be accessed using SCM_CAR and SCM_CDR. */ +#define SCM_FREE_CELL_P(x) \ + (!SCM_IMP (x) && (* (const scm_bits_t *) SCM2PTR (x) == scm_tc_free_cell)) +#define SCM_FREE_CELL_CDR(x) \ + (((const scm_bits_t *) SCM2PTR (x)) [1]) +#define SCM_SET_FREE_CELL_TYPE(x, v) \ + (((scm_bits_t *) SCM2PTR (x)) [0] = (v)) +#define SCM_SET_FREE_CELL_CDR(x, v) \ + (((scm_bits_t *) SCM2PTR (x)) [1] = (v)) + /* the allocated thing: The car of new cells is set to scm_tc16_allocated to avoid the fragile state of newcells wrt the gc. If it stays as a freecell, any allocation afterwards could @@ -174,8 +182,8 @@ typedef scm_cell * SCM_CELLPTR; else \ { \ _into = scm_freelist; \ - scm_freelist = SCM_CDR (scm_freelist); \ - SCM_SET_CELL_TYPE (_into, scm_tc16_allocated); \ + scm_freelist = SCM_FREE_CELL_CDR (scm_freelist); \ + SCM_SET_FREE_CELL_TYPE (_into, scm_tc16_allocated); \ } \ } while(0) #define SCM_NEWCELL2(_into) \ @@ -186,14 +194,14 @@ typedef scm_cell * SCM_CELLPTR; else \ { \ _into = scm_freelist2; \ - scm_freelist2 = SCM_CDR (scm_freelist2); \ - SCM_SET_CELL_TYPE (_into, scm_tc16_allocated); \ + scm_freelist2 = SCM_FREE_CELL_CDR (scm_freelist2); \ + SCM_SET_FREE_CELL_TYPE (_into, scm_tc16_allocated); \ } \ } while(0) #endif -#define SCM_FREEP(x) (SCM_NIMP (x) && (SCM_CELL_TYPE (x) == scm_tc_free_cell)) +#define SCM_FREEP(x) (SCM_FREE_CELL_P (x)) #define SCM_NFREEP(x) (!SCM_FREEP (x)) /* 1. This shouldn't be used on immediates. From 24511502828ede8f8b6acd27e23ff33c9186c418 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 12 Jul 2000 07:38:06 +0000 Subject: [PATCH 0050/2047] * Fixed expt for the case of negative integer exponents. --- ice-9/ChangeLog | 5 +++++ ice-9/boot-9.scm | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 02f1a1024..6160c876e 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2000-07-12 Dirk Herrmann + + * boot-9.scm (expt): Make sure that integer-expt is only called + if the exponent is a non-negative integer. + 2000-07-01 Mikael Djurfeldt * boot-9.scm (process-define-module): Bugfix: Only check the CDR diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index d190a771c..c1e578494 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -793,7 +793,7 @@ (define expt (let ((integer-expt integer-expt)) (lambda (z1 z2) - (cond ((exact? z2) + (cond ((and (integer? z2) (>= z2 0)) (integer-expt z1 z2)) ((and (real? z2) (real? z1) (>= z1 0)) ($expt z1 z2)) From 04914986164f25bed24ec2279c062886fa98c283 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 13 Jul 2000 07:27:02 +0000 Subject: [PATCH 0051/2047] * Added a note about removing GUILE_OLD_ASYNC_CLICK. --- RELEASE | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/RELEASE b/RELEASE index 9921ed806..f9b7ff1b2 100644 --- a/RELEASE +++ b/RELEASE @@ -12,6 +12,10 @@ with the one released with 1.4: - remove struct members system_transformer and top_level_lookup_closure_var from struct scm_root_state in root.h. +After signal handling and threading have been fixed: +- remove the code corresponding to GUILE_OLD_ASYNC_CLICK and the corresponding + GUILE_OLD_ASYNC_CLICK macro. + In release 1.5: - remove deprecated macros: SCM_INPORTP, SCM_OUTPORTP, SCM_CRDY, SCM_ICHRP, SCM_ICHR, SCM_MAKICHR, SCM_SETJMPBUF, SCM_NSTRINGP, SCM_NRWSTRINGP, From c4da09e2ddc0f6cd2c63f4e68d75988fe7beceed Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 13 Jul 2000 07:40:04 +0000 Subject: [PATCH 0052/2047] * Minor cleanups in scm_mark_locations. --- libguile/ChangeLog | 5 +++ libguile/gc.c | 107 +++++++++++++++++++++++---------------------- 2 files changed, 59 insertions(+), 53 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f72ec1cf0..5fd8c0620 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-07-13 Dirk Herrmann + + * gc.c (scm_mark_locations): Minimized some variable scopes and + simplified the code a bit. + 2000-07-10 Dirk Herrmann * gc.h (SCM_SET_FREE_CELL_TYPE, SCM_SET_FREE_CELL_CDR, diff --git a/libguile/gc.c b/libguile/gc.c index 1c053c27c..bcbc831f2 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1212,60 +1212,61 @@ gc_mark_nimp: void scm_mark_locations (SCM_STACKITEM x[], scm_sizet n) { - register long m = n; - register int i, j; - register SCM_CELLPTR ptr; + unsigned long m; - while (0 <= --m) - if (SCM_CELLP (* (SCM *) &x[m])) - { - ptr = SCM2PTR (* (SCM *) &x[m]); - i = 0; - j = scm_n_heap_segs - 1; - if ( SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr) - && SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr)) - { - while (i <= j) - { - int seg_id; - seg_id = -1; - if ( (i == j) - || SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr)) - seg_id = i; - else if (SCM_PTR_LE (scm_heap_table[j].bounds[0], ptr)) - seg_id = j; - else - { - int k; - k = (i + j) / 2; - if (k == i) - break; - if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr)) - { - j = k; - ++i; - if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr)) - continue; - else - break; - } - else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr)) - { - i = k; - --j; - if (SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr)) - continue; - else - break; - } - } - if (scm_heap_table[seg_id].span == 1 - || SCM_DOUBLE_CELLP (* (SCM *) &x[m])) - scm_gc_mark (* (SCM *) &x[m]); - break; - } - } - } + for (m = 0; m < n; ++m) + { + SCM obj = * (SCM *) &x[m]; + if (SCM_CELLP (obj)) + { + SCM_CELLPTR ptr = SCM2PTR (obj); + int i = 0; + int j = scm_n_heap_segs - 1; + if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr) + && SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr)) + { + while (i <= j) + { + int seg_id; + seg_id = -1; + if ((i == j) + || SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr)) + seg_id = i; + else if (SCM_PTR_LE (scm_heap_table[j].bounds[0], ptr)) + seg_id = j; + else + { + int k; + k = (i + j) / 2; + if (k == i) + break; + if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr)) + { + j = k; + ++i; + if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr)) + continue; + else + break; + } + else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr)) + { + i = k; + --j; + if (SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr)) + continue; + else + break; + } + } + if (scm_heap_table[seg_id].span == 1 + || SCM_DOUBLE_CELLP (obj)) + scm_gc_mark (obj); + break; + } + } + } + } } From 2238100586a99880885ac31c146a2397f2d579ff Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 13 Jul 2000 14:47:32 +0000 Subject: [PATCH 0053/2047] * In expt, return exact results when possible. --- ice-9/ChangeLog | 6 ++++++ ice-9/boot-9.scm | 6 ++++-- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 6160c876e..5620222bc 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,9 @@ +2000-07-13 Dirk Herrmann + + * boot-9.scm (expt): In case of negative integer exponents return + an exact result if the input paramters were exact. Thanks to + Mikael for the suggestion. + 2000-07-12 Dirk Herrmann * boot-9.scm (expt): Make sure that integer-expt is only called diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index c1e578494..3735c7948 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -793,8 +793,10 @@ (define expt (let ((integer-expt integer-expt)) (lambda (z1 z2) - (cond ((and (integer? z2) (>= z2 0)) - (integer-expt z1 z2)) + (cond ((integer? z2) + (if (>= z2 0) + (integer-expt z1 z2) + (/ 1 (integer-expt z1 (- z2))))) ((and (real? z2) (real? z1) (>= z1 0)) ($expt z1 z2)) (else From 406c7d902207af0e25afc6d543e94067bc92bf2b Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 13 Jul 2000 15:00:58 +0000 Subject: [PATCH 0054/2047] * Extend checks performed with SCM_DEBUG_CELL_ACCESSES=1 and make them configurable at run-time. * Replace SCM_FREEP by SCM_FREE_CELL_P and scm_gc_heap_lock by scm_gc_running_p (not in all places yet). --- libguile/ChangeLog | 29 +++++++++++++++++ libguile/error.c | 2 +- libguile/gc.c | 80 +++++++++++++++++++++++++++++++++++++++++++++- libguile/gc.h | 15 ++++++--- libguile/gdbint.c | 4 +-- libguile/weaks.c | 6 ++-- 6 files changed, 124 insertions(+), 12 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 5fd8c0620..81993cae0 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,32 @@ +2000-07-13 Dirk Herrmann + + * gc.h (scm_take_stdin): Removed. + + * gc.h (SCM_VALIDATE_CELL): Delegate cell checks to function + scm_assert_cell_valid to allow extensions to the checking + functionality without need to recompile everything. + + * gc.[ch] (scm_assert_cell_valid, scm_set_debug_cell_accesses_x): + Added as conditionally compiled functions for the case that + SCM_DEBUG_CELL_ACCESSES is enabled. + + * gc.c (debug_cells_p): Added to indicate whether compile-time + included cell access debugging is run-time enabled. + + * gc.[ch] (scm_gc_running_p): Added to indicate that scm_igc is + being executed. Intended to be used instead of scm_gc_heap_lock + at most places. + + * error.c (scm_error), gdbint.c (SCM_GC_P): Use scm_gc_running_p + instead of scm_gc_heap_lock. + + * gc.c (scm_igc): Set scm_gc_running_p to true while running. + + * gc.c (scm_mark_locations): Don't mark free cells. + + * weaks.c (scm_scan_weak_vectors): Use SCM_FREE_CELL_P instead of + SCM_FREEP. + 2000-07-13 Dirk Herrmann * gc.c (scm_mark_locations): Minimized some variable scopes and diff --git a/libguile/error.c b/libguile/error.c index 850bf5b7d..fa409bcef 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -74,7 +74,7 @@ void scm_error (SCM key, const char *subr, const char *message, SCM args, SCM rest) { SCM arg_list; - if (scm_gc_heap_lock) + if (scm_gc_running_p) { /* The error occured during GC --- abort */ fprintf (stderr, "Error in %s during GC: %s\n", diff --git a/libguile/gc.c b/libguile/gc.c index bcbc831f2..4878e15a1 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -85,6 +85,78 @@ #endif + +unsigned int scm_gc_running_p = 0; + + + +#if (SCM_DEBUG_CELL_ACCESSES == 1) + +unsigned int scm_debug_cell_accesses_p = 0; + + +/* Assert that the given object is a valid reference to a valid cell. This + * test involves to determine whether the object is a cell pointer, whether + * this pointer actually points into a heap segment and whether the cell + * pointed to is not a free cell. + */ +void +scm_assert_cell_valid (SCM cell) +{ + if (scm_debug_cell_accesses_p) + { + scm_debug_cell_accesses_p = 0; /* disable to avoid recursion */ + + if (!scm_cellp (cell)) + { + fprintf (stderr, "scm_assert_cell_valid: Not a cell object: %lx\n", SCM_UNPACK (cell)); + abort (); + } + else if (!scm_gc_running_p) + { + /* Dirk::FIXME:: During garbage collection there occur references to + free cells. This is allright during conservative marking, but + should not happen otherwise (I think). The case of free cells + accessed during conservative marking is handled in function + scm_mark_locations. However, there still occur accesses to free + cells during gc. I don't understand why this happens. If it is + a bug and gets fixed, the following test should also work while + gc is running. + */ + if (SCM_FREE_CELL_P (cell)) + { + fprintf (stderr, "scm_assert_cell_valid: Accessing free cell: %lx\n", SCM_UNPACK (cell)); + abort (); + } + } + scm_debug_cell_accesses_p = 1; /* re-enable */ + } +} + + +SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0, + (SCM flag), + "If FLAG is #f, cell access checking is disabled.\n" + "If FLAG is #t, cell access checking is enabled.\n" + "This procedure only exists because the compile-time flag\n" + "SCM_DEBUG_CELL_ACCESSES was set to 1.\n") +#define FUNC_NAME s_scm_set_debug_cell_accesses_x +{ + if (SCM_FALSEP (flag)) { + scm_debug_cell_accesses_p = 0; + } else if (SCM_EQ_P (flag, SCM_BOOL_T)) { + scm_debug_cell_accesses_p = 1; + } else { + SCM_WRONG_TYPE_ARG (1, flag); + } + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +#endif /* SCM_DEBUG_CELL_ACCESSES == 1 */ + + + /* {heap tuning parameters} * * These are parameters for controlling memory allocation. The heap @@ -776,6 +848,7 @@ scm_igc (const char *what) { int j; + ++scm_gc_running_p; scm_c_hook_run (&scm_before_gc_c_hook, 0); #ifdef DEBUGINFO fprintf (stderr, @@ -795,6 +868,7 @@ scm_igc (const char *what) if (!scm_stack_base || scm_block_gc) { scm_gc_end (); + --scm_gc_running_p; return; } @@ -894,6 +968,7 @@ scm_igc (const char *what) SCM_THREAD_CRITICAL_SECTION_END; #endif scm_c_hook_run (&scm_after_gc_c_hook, 0); + --scm_gc_running_p; } @@ -1261,7 +1336,10 @@ scm_mark_locations (SCM_STACKITEM x[], scm_sizet n) } if (scm_heap_table[seg_id].span == 1 || SCM_DOUBLE_CELLP (obj)) - scm_gc_mark (obj); + { + if (!SCM_FREE_CELL_P (obj)) + scm_gc_mark (obj); + } break; } } diff --git a/libguile/gc.h b/libguile/gc.h index 49a8ecc97..c40016254 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -85,11 +85,10 @@ typedef scm_cell * SCM_CELLPTR; /* Low level cell data accessing macros: */ -#if SCM_DEBUG_CELL_ACCESSES == 1 -#define SCM_VALIDATE_CELL(cell, expr) \ - (!scm_cellp (cell) ? abort (), 0 : (expr)) +#if (SCM_DEBUG_CELL_ACCESSES == 1) +# define SCM_VALIDATE_CELL(cell, expr) (scm_assert_cell_valid (cell), (expr)) #else -#define SCM_VALIDATE_CELL(cell, expr) expr +# define SCM_VALIDATE_CELL(cell, expr) expr #endif #define SCM_CELL_WORD(x, n) \ @@ -213,9 +212,9 @@ typedef scm_cell * SCM_CELLPTR; extern struct scm_heap_seg_data_t *scm_heap_table; extern int scm_n_heap_segs; -extern int scm_take_stdin; extern int scm_block_gc; extern int scm_gc_heap_lock; +extern unsigned int scm_gc_running_p; extern int scm_default_init_heap_size_1; @@ -246,6 +245,12 @@ extern scm_c_hook_t scm_before_sweep_c_hook; extern scm_c_hook_t scm_after_sweep_c_hook; extern scm_c_hook_t scm_after_gc_c_hook; +#if (SCM_DEBUG_CELL_ACCESSES == 1) +extern void scm_assert_cell_valid (SCM); +extern unsigned int scm_debug_cell_accesses_p; +extern SCM scm_set_debug_cell_accesses_x (SCM flag); +#endif + #if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST) extern SCM scm_map_free_list (void); extern SCM scm_free_list_length (void); diff --git a/libguile/gdbint.c b/libguile/gdbint.c index bc0c73ac5..c2b87d920 100644 --- a/libguile/gdbint.c +++ b/libguile/gdbint.c @@ -83,9 +83,9 @@ /* Be carefull when this macro is true. - scm_gc_heap_lock is set during gc. + scm_gc_running_p is set during gc. */ -#define SCM_GC_P (scm_gc_heap_lock) +#define SCM_GC_P (scm_gc_running_p) /* Macros that encapsulate blocks of code which can be called by the * debugger. diff --git a/libguile/weaks.c b/libguile/weaks.c index dad6bd63b..71905ac05 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -264,7 +264,7 @@ scm_scan_weak_vectors (void *dummy1, void *dummy2, void *dummy3) ptr = SCM_VELTS (w); n = SCM_LENGTH (w); for (j = 0; j < n; ++j) - if (SCM_FREEP (ptr[j])) + if (SCM_FREE_CELL_P (ptr[j])) ptr[j] = SCM_BOOL_F; } else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */ @@ -296,8 +296,8 @@ scm_scan_weak_vectors (void *dummy1, void *dummy2, void *dummy3) key = SCM_CAAR (alist); value = SCM_CDAR (alist); - if ( (weak_keys && SCM_FREEP (key)) - || (weak_values && SCM_FREEP (value))) + if ( (weak_keys && SCM_FREE_CELL_P (key)) + || (weak_values && SCM_FREE_CELL_P (value))) { *fixup = SCM_CDR (alist); } From 32d0d4b1e3f76c7839cfede6de181b3811d8bd57 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 14 Jul 2000 07:36:35 +0000 Subject: [PATCH 0055/2047] * Added note about new global variable scm_gc_running_p. --- NEWS | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/NEWS b/NEWS index 5c3a2189e..c72155a74 100644 --- a/NEWS +++ b/NEWS @@ -55,6 +55,15 @@ Example: * Changes to the scm_ interface +** New global variable scm_gc_running_p introduced. + +Use this variable to find out if garbage collection is being executed. Up to +now applications have used scm_gc_heap_lock to test if garbage collection was +running, which also works because of the fact that up to know only the garbage +collector has set this variable. But, this is an implementation detail that +may change. Further, scm_gc_heap_lock is not set throughout gc, thus the use +of this variable is (and has been) not fully safe anyway. + ** Deprecated macros: SCM_OUTOFRANGE, SCM_NALLOC, SCM_HUP_SIGNAL, SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD, From 9d47a1e6f2714e91e91619a46f433fe2eaa5c9a4 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Sat, 15 Jul 2000 13:44:04 +0000 Subject: [PATCH 0056/2047] * gc.c (scm_done_free): new. expanded comments about scm_done_malloc. * gc.h: added prototype for scm_done_free --- NEWS | 7 +++++++ libguile/ChangeLog | 7 +++++++ libguile/gc.c | 46 +++++++++++++++++++++++++++++----------------- libguile/gc.h | 1 + 4 files changed, 44 insertions(+), 17 deletions(-) diff --git a/NEWS b/NEWS index c72155a74..c79e3eb4d 100644 --- a/NEWS +++ b/NEWS @@ -55,6 +55,13 @@ Example: * Changes to the scm_ interface +** New function: scm_done_free (long size) + +This function is the inverse of scm_done_malloc. Use it to report the +amount of smob memory you free. The previous method, which involved +calling scm_done_malloc with negative argument, was somewhat +unintuitive (and is still available, of course). + ** New global variable scm_gc_running_p introduced. Use this variable to find out if garbage collection is being executed. Up to diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 81993cae0..6e922106c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2000-07-15 Michael Livshin + + * gc.c (scm_done_free): new. + expanded comments about scm_done_malloc. + + * gc.h: added prototype for scm_done_free + 2000-07-13 Dirk Herrmann * gc.h (scm_take_stdin): Removed. diff --git a/libguile/gc.c b/libguile/gc.c index 4878e15a1..ecf4ace1b 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -107,7 +107,7 @@ scm_assert_cell_valid (SCM cell) { scm_debug_cell_accesses_p = 0; /* disable to avoid recursion */ - if (!scm_cellp (cell)) + if (!scm_cellp (cell)) { fprintf (stderr, "scm_assert_cell_valid: Not a cell object: %lx\n", SCM_UNPACK (cell)); abort (); @@ -1034,7 +1034,7 @@ gc_mark_nimp: * to a heap cell. If it is a struct, the cell word #0 of ptr is a * pointer to a struct vtable data region. The fact that these are * accessed in the same way restricts the possibilites to change the - * data layout of structs or heap cells. + * data layout of structs or heap cells. */ scm_bits_t word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_cons_gloc; scm_bits_t * vtable_data = (scm_bits_t *) word0; /* access as struct */ @@ -1369,7 +1369,7 @@ scm_cellp (SCM value) } } - if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr) + if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr) && SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr) && (scm_heap_table[i].span == 1 || SCM_DOUBLE_CELLP (value))) { return 1; @@ -1475,7 +1475,7 @@ scm_gc_sweep () vtable_data [scm_vtable_index_vcell] = 0; goto cmrkcontinue; } - else + else { if (vtable_data [scm_vtable_index_vcell] == 0 || vtable_data [scm_vtable_index_vcell] == 1) @@ -1733,12 +1733,12 @@ scm_gc_sweep () /* {Front end to malloc} * - * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc + * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc, + * scm_done_free * * These functions provide services comperable to malloc, realloc, and * free. They are for allocating malloced parts of scheme objects. - * The primary purpose of the front end is to impose calls to gc. - */ + * The primary purpose of the front end is to impose calls to gc. */ /* scm_must_malloc @@ -1864,7 +1864,13 @@ scm_must_free (void *obj) * reason). When a new object of this smob is created you call * scm_done_malloc with the size of the object. When your smob free * function is called, be sure to include this size in the return - * value. */ + * value. + * + * If you can't actually free the memory in the smob free function, + * for whatever reason (like reference counting), you still can (and + * should) report the amount of memory freed when you actually free it. + * Do it by calling scm_done_malloc with the _negated_ size. Clever, + * eh? Or even better, call scm_done_free. */ void scm_done_malloc (long size) @@ -1884,6 +1890,12 @@ scm_done_malloc (long size) } } +void +scm_done_free (long size) +{ + scm_mallocated -= size; +} + @@ -2045,7 +2057,7 @@ alloc_some_heap (scm_freelist_t *freelist, policy_on_error error_policy) SCM_CELLPTR ptr; long len; - if (scm_gc_heap_lock) + if (scm_gc_heap_lock) { /* Critical code sections (such as the garbage collector) aren't * supposed to add heap segments. @@ -2054,7 +2066,7 @@ alloc_some_heap (scm_freelist_t *freelist, policy_on_error error_policy) abort (); } - if (scm_n_heap_segs == heap_segment_table_size) + if (scm_n_heap_segs == heap_segment_table_size) { /* We have to expand the heap segment table to have room for the new * segment. Do not yet increment scm_n_heap_segs -- that is done by @@ -2254,15 +2266,15 @@ SCM scm_protect_object (SCM obj) { SCM handle; - + /* This critical section barrier will be replaced by a mutex. */ SCM_REDEFER_INTS; - + handle = scm_hashq_create_handle_x (scm_protects, obj, SCM_MAKINUM (0)); SCM_SETCDR (handle, SCM_MAKINUM (SCM_INUM (SCM_CDR (handle)) + 1)); - + SCM_REALLOW_INTS; - + return obj; } @@ -2275,12 +2287,12 @@ SCM scm_unprotect_object (SCM obj) { SCM handle; - + /* This critical section barrier will be replaced by a mutex. */ SCM_REDEFER_INTS; - + handle = scm_hashq_get_handle (scm_protects, obj); - + if (SCM_IMP (handle)) { fprintf (stderr, "scm_unprotect_object called on unprotected object\n"); diff --git a/libguile/gc.h b/libguile/gc.h index c40016254..9a647e843 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -284,6 +284,7 @@ extern void * scm_must_realloc (void *where, scm_sizet olen, scm_sizet len, const char *what); extern void scm_done_malloc (long size); +extern void scm_done_free (long size); extern void scm_must_free (void *obj); extern void scm_remember (SCM * ptr); extern SCM scm_return_first (SCM elt, ...); From 1bd07992b6d08380d84fdc3d48e8f77666641544 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 17 Jul 2000 19:59:57 +0000 Subject: [PATCH 0057/2047] * eval.c (unmemocopy): Don't rely on V being a list of at least one element. Thanks to Bill Schottstaedt! --- libguile/eval.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index e9c8f0b1d..40a8f8bf7 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1341,7 +1341,7 @@ unmemocopy (SCM x, SCM env) : f; /* build transformed binding list */ z = SCM_EOL; - do + while (SCM_NIMP (v)) { z = scm_acons (SCM_CAR (v), scm_cons (SCM_CAR (e), @@ -1353,7 +1353,6 @@ unmemocopy (SCM x, SCM env) e = SCM_CDR (e); s = SCM_CDR (s); } - while (SCM_NIMP (v)); z = scm_cons (z, SCM_UNSPECIFIED); SCM_SETCDR (ls, z); if (SCM_EQ_P (SCM_CAR (ls), scm_sym_do)) From 007e7c35883b9d5ac982a27c7ac80b468bd7f61e Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 17 Jul 2000 20:00:22 +0000 Subject: [PATCH 0058/2047] *** empty log message *** --- libguile/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6e922106c..298f5dea8 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-07-17 Marius Vollmer + + * eval.c (unmemocopy): Don't rely on V being a list of at least + one element. Thanks to Bill Schottstaedt! + 2000-07-15 Michael Livshin * gc.c (scm_done_free): new. From cc4feeca51e8b9f2883cfd0efb51092e6a014b4c Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 18 Jul 2000 07:02:57 +0000 Subject: [PATCH 0059/2047] * Deprecated function scm_call_catching_errors. * Updated root-smob initialization. --- NEWS | 4 ++++ RELEASE | 2 ++ libguile/ChangeLog | 7 +++++++ libguile/root.c | 14 +++++++++----- libguile/root.h | 10 +++++++++- 5 files changed, 31 insertions(+), 6 deletions(-) diff --git a/NEWS b/NEWS index c79e3eb4d..e902d5a4d 100644 --- a/NEWS +++ b/NEWS @@ -79,6 +79,10 @@ SCM_ORD_SIG, SCM_NUM_SIGS Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of SCM_OUTOFRANGE. Use scm_memory_error instead of SCM_NALLOC. +** Deprecated function: scm_call_catching_errors + +Use scm_catch or scm_lazy_catch from throw.[ch] instead. + Changes since Guile 1.3.4: diff --git a/RELEASE b/RELEASE index f9b7ff1b2..497e79b78 100644 --- a/RELEASE +++ b/RELEASE @@ -42,6 +42,8 @@ In release 1.6: SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD, SCM_ORD_SIG, SCM_NUM_SIGS +- remove function scm_call_catching_errors + (replaced by catch functions from throw.[ch]) Modules sort.c and random.c should be factored out into separate diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 298f5dea8..880fd9632 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2000-07-18 Dirk Herrmann + + * root.[ch] (scm_call_catching_errors): Deprecated. + + * root.c (scm_init_root): Initialize the root smob type using the + standard initialization functions. + 2000-07-17 Marius Vollmer * eval.c (unmemocopy): Don't rely on V being a list of at least diff --git a/libguile/root.c b/libguile/root.c index 5504f3544..e58db5304 100644 --- a/libguile/root.c +++ b/libguile/root.c @@ -399,12 +399,13 @@ scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler) +#if (SCM_DEBUG_DEPRECATED == 0) + /* Call thunk(closure) underneath a top-level error handler. * If an error occurs, pass the exitval through err_filter and return it. * If no error occurs, return the value of thunk. */ - #ifdef _UNICOS typedef int setjmp_type; #else @@ -412,7 +413,6 @@ typedef long setjmp_type; #endif - SCM scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(), void *closure) { @@ -436,12 +436,16 @@ scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(), void *closure) return answer; } +#endif /* SCM_DEBUG_DEPRECATED == 0 */ + + void scm_init_root () { - scm_tc16_root = scm_make_smob_type_mfpe ("root", sizeof (struct scm_root_state), - mark_root, NULL, print_root, NULL); - + scm_tc16_root = scm_make_smob_type ("root", sizeof (struct scm_root_state)); + scm_set_smob_mark (scm_tc16_root, mark_root); + scm_set_smob_print (scm_tc16_root, print_root); + #include "libguile/root.x" } diff --git a/libguile/root.h b/libguile/root.h index c769e6c98..2c6bdc255 100644 --- a/libguile/root.h +++ b/libguile/root.h @@ -161,9 +161,17 @@ extern SCM scm_internal_cwdr (scm_catch_body_t body, extern SCM scm_call_with_dynamic_root (SCM thunk, SCM handler); extern SCM scm_dynamic_root (void); extern SCM scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler); -extern SCM scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(), void * closure); extern void scm_init_root (void); + + +#if (SCM_DEBUG_DEPRECATED == 0) + +/* Use the catch functions from throw.[ch] instead of: */ +extern SCM scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(), void * closure); + +#endif /* SCM_DEBUG_DEPRECATED == 0 */ + #endif /* ROOTH */ /* From 62850ef3c14ef9dfa96951a3230cb6fb76084bb2 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 18 Jul 2000 16:09:09 +0000 Subject: [PATCH 0060/2047] * Don't use return value from SCM_SETCDR or SCM_WHASHSET. --- libguile/ChangeLog | 6 ++++++ libguile/read.c | 17 ++++++++++++----- libguile/srcprop.c | 32 +++++++++++++++----------------- 3 files changed, 33 insertions(+), 22 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 880fd9632..51aab8bd5 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2000-07-18 Dirk Herrmann + + read.c (scm_lreadrecparen), srcprop.c (scm_set_source_property_x): + SCM_SETCDR and SCM_WHASHSET macros don't deliver a return value. + Thanks to Han-Wen Nienhuys for the bug report. + 2000-07-18 Dirk Herrmann * root.[ch] (scm_call_catching_errors): Deprecated. diff --git a/libguile/read.c b/libguile/read.c index 5aa743e69..1fa86009c 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -666,6 +666,8 @@ scm_lreadrecparen (SCM *tok_buf, SCM port, char *name, SCM *copy) SCM_EOL); while (')' != (c = scm_flush_ws (port, name))) { + SCM new_tail; + scm_ungetc (c, port); if (SCM_EQ_P (scm_sym_dot, (tmp = scm_lreadr (tok_buf, port, copy)))) { @@ -679,12 +681,17 @@ scm_lreadrecparen (SCM *tok_buf, SCM port, char *name, SCM *copy) scm_wta (SCM_UNDEFINED, "missing close paren", ""); goto exit; } - tl = SCM_SETCDR (tl, scm_cons (tmp, SCM_EOL)); + + new_tail = scm_cons (tmp, SCM_EOL); + SCM_SETCDR (tl, new_tail); + tl = new_tail; + if (SCM_COPY_SOURCE_P) - tl2 = SCM_SETCDR (tl2, scm_cons (SCM_CONSP (tmp) - ? *copy - : tmp, - SCM_EOL)); + { + SCM new_tail2 = scm_cons (SCM_CONSP (tmp) ? *copy : tmp, SCM_EOL); + SCM_SETCDR (tl2, new_tail2); + tl2 = new_tail2; + } } exit: scm_whash_insert (scm_source_whash, diff --git a/libguile/srcprop.c b/libguile/srcprop.c index 7f2271df7..0ac089cfd 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -262,24 +262,22 @@ SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0, } if (SCM_EQ_P (scm_sym_breakpoint, key)) { - if (SCM_FALSEP (datum)) - CLEARSRCPROPBRK (SRCPROPSP (p) - ? p - : SCM_WHASHSET (scm_source_whash, h, - scm_make_srcprops (0, - 0, - SCM_UNDEFINED, - SCM_UNDEFINED, - p))); + if (SRCPROPSP (p)) + { + if (SCM_FALSEP (datum)) + CLEARSRCPROPBRK (p); + else + SETSRCPROPBRK (p); + } else - SETSRCPROPBRK (SRCPROPSP (p) - ? p - : SCM_WHASHSET (scm_source_whash, h, - scm_make_srcprops (0, - 0, - SCM_UNDEFINED, - SCM_UNDEFINED, - p))); + { + SCM sp = scm_make_srcprops (0, 0, SCM_UNDEFINED, SCM_UNDEFINED, p); + SCM_WHASHSET (scm_source_whash, h, sp); + if (SCM_FALSEP (datum)) + CLEARSRCPROPBRK (sp); + else + SETSRCPROPBRK (sp); + } } else if (SCM_EQ_P (scm_sym_line, key)) { From 78a3503e568462b3316dd5a36b247db5f10710c8 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 18 Jul 2000 16:59:35 +0000 Subject: [PATCH 0061/2047] * Fixed some type-related errors. --- libguile/ChangeLog | 9 +++++++++ libguile/gc.h | 4 ++-- libguile/hooks.c | 2 +- libguile/modules.c | 8 ++++---- 4 files changed, 16 insertions(+), 7 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 51aab8bd5..dd9906c61 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2000-07-18 Dirk Herrmann + + * gc.h (SCM_FREE_CELL_CDR, SCM_SET_FREE_CELL_CDR), hooks.c + (make_hook), modules.c (OBARRAY, USES, BINDER): Pack and unpack + SCM values appropriately. + + * modules.c (scm_standard_eval_closure): Don't pass an inum to + scm_makcclo, but rather a long value. + 2000-07-18 Dirk Herrmann read.c (scm_lreadrecparen), srcprop.c (scm_set_source_property_x): diff --git a/libguile/gc.h b/libguile/gc.h index 9a647e843..7f1207671 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -154,11 +154,11 @@ typedef scm_cell * SCM_CELLPTR; #define SCM_FREE_CELL_P(x) \ (!SCM_IMP (x) && (* (const scm_bits_t *) SCM2PTR (x) == scm_tc_free_cell)) #define SCM_FREE_CELL_CDR(x) \ - (((const scm_bits_t *) SCM2PTR (x)) [1]) + (SCM_PACK (((const scm_bits_t *) SCM2PTR (x)) [1])) #define SCM_SET_FREE_CELL_TYPE(x, v) \ (((scm_bits_t *) SCM2PTR (x)) [0] = (v)) #define SCM_SET_FREE_CELL_CDR(x, v) \ - (((scm_bits_t *) SCM2PTR (x)) [1] = (v)) + (((scm_bits_t *) SCM2PTR (x)) [1] = SCM_UNPACK (v)) /* the allocated thing: The car of new cells is set to scm_tc16_allocated to avoid the fragile state of newcells wrt the diff --git a/libguile/hooks.c b/libguile/hooks.c index 712debd87..14609cb5e 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -167,7 +167,7 @@ make_hook (SCM n_args, const char *subr) if (n < 0 || n > 16) scm_out_of_range (subr, n_args); } - SCM_RETURN_NEWSMOB (scm_tc16_hook + (n << 16), SCM_EOL); + SCM_RETURN_NEWSMOB (scm_tc16_hook + (n << 16), SCM_UNPACK (SCM_EOL)); } diff --git a/libguile/modules.c b/libguile/modules.c index 6e5d3413a..ad016582a 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -188,9 +188,9 @@ scm_system_module_env_p (SCM env) * The code will be replaced by the low-level environments in next release. */ -#define OBARRAY(module) (SCM_STRUCT_DATA (module) [0]) -#define USES(module) (SCM_STRUCT_DATA (module) [1]) -#define BINDER(module) (SCM_STRUCT_DATA (module) [2]) +#define OBARRAY(module) (SCM_PACK (SCM_STRUCT_DATA (module) [0])) +#define USES(module) (SCM_PACK (SCM_STRUCT_DATA (module) [1])) +#define BINDER(module) (SCM_PACK (SCM_STRUCT_DATA (module) [2])) static SCM module_make_local_var_x; @@ -246,7 +246,7 @@ SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0, "") #define FUNC_NAME s_scm_standard_eval_closure { - SCM cclo = scm_makcclo (f_eval_closure, SCM_MAKINUM (2)); + SCM cclo = scm_makcclo (f_eval_closure, 2); SCM_VELTS (cclo) [1] = module; return cclo; } From 60113271177f770dd36df8ce5f017aec4d343e0f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 19 Jul 2000 18:10:30 +0000 Subject: [PATCH 0062/2047] * configure.in (rl_pre_input_hook): Don't check for this with AC_CHECK_FUNCS, it doesn't work on HP/UX. Test for it with AC_TRY_LINK. --- guile-readline/configure.in | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/guile-readline/configure.in b/guile-readline/configure.in index a467d5a3d..b59b9e4c5 100644 --- a/guile-readline/configure.in +++ b/guile-readline/configure.in @@ -18,7 +18,27 @@ if test $ac_cv_lib_readline_main = no; then AC_MSG_WARN([libreadline was not found on your system.]) fi -AC_CHECK_FUNCS(siginterrupt rl_clear_signals rl_cleanup_after_signal rl_pre_input_hook) +AC_CHECK_FUNCS(siginterrupt rl_clear_signals rl_cleanup_after_signal) + +dnl Check for rl_pre_input_hook. This is more complicated because on +dnl some systems (HP/UX), the linker wont let us treat +dnl rl_pre_input_hook as a function when it really is a function +dnl pointer. + +AC_MSG_CHECKING([for rl_pre_input_hook]) +AC_CACHE_VAL(ac_cv_var_rl_pre_input_hook, +[AC_TRY_LINK([ +#include +#include +], [ +rl_pre_input_hook = 0; +], +ac_cv_var_rl_pre_input_hook=yes, +ac_cv_var_rl_pre_input_hook=no)]) +AC_MSG_RESULT($ac_cv_var_rl_pre_input_hook) +if test $ac_cv_var_rl_pre_input_hook = yes; then + AC_DEFINE(HAVE_RL_PRE_INPUT_HOOK) +fi AC_MSG_CHECKING(if readline clears SA_RESTART flag for SIGWINCH) From ff0fd4e4081ae85a5f643728ffcc3c6fc9fcdafd Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 19 Jul 2000 18:10:46 +0000 Subject: [PATCH 0063/2047] *** empty log message *** --- guile-readline/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 367952ac6..4474c64b4 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,9 @@ +2000-07-17 Marius Vollmer + + * configure.in (rl_pre_input_hook): Don't check for this with + AC_CHECK_FUNCS, it doesn't work on HP/UX. Test for it with + AC_TRY_LINK. + 2000-06-19 Mikael Djurfeldt * readline.c (sigwinch_enable_restart, scm_init_readline): From 5d2538526626d1948536b7b9df1298771474285f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 23 Jul 2000 11:50:05 +0000 Subject: [PATCH 0064/2047] * alist.c (scm_assq_remove_x, scm_assv_remove_x, scm_assoc_remove_x): Remove all cells whose key is eq, eqv, or equal (respectively) to the argument key, not all cells that are eq, eqv, or equal to the first cell with the argument key. Thanks to Neil Jerram! --- libguile/alist.c | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/libguile/alist.c b/libguile/alist.c index db8602e19..e4f0b0cc5 100644 --- a/libguile/alist.c +++ b/libguile/alist.c @@ -331,19 +331,19 @@ SCM_DEFINE (scm_assq_remove_x, "assq-remove!", 2, 0, 0, (SCM alist, SCM key), "@deffnx primitive assv-remove! alist key\n" "@deffnx primitive assoc-remove! alist key\n" - "Delete any entry in @var{alist} associated with @var{key}, and return\n" + "Delete all entries in @var{alist} associated with @var{key}, and return\n" "the resulting alist.") #define FUNC_NAME s_scm_assq_remove_x { SCM handle; handle = scm_sloppy_assq (key, alist); - if (SCM_CONSP (handle)) + while (SCM_CONSP (handle)) { - return scm_delq_x (handle, alist); + alist = scm_delq_x (handle, alist); + handle = scm_sloppy_assq (key, alist); } - else - return alist; + return alist; } #undef FUNC_NAME @@ -356,12 +356,12 @@ SCM_DEFINE (scm_assv_remove_x, "assv-remove!", 2, 0, 0, SCM handle; handle = scm_sloppy_assv (key, alist); - if (SCM_CONSP (handle)) + while (SCM_CONSP (handle)) { - return scm_delv_x (handle, alist); + alist = scm_delq_x (handle, alist); + handle = scm_sloppy_assv (key, alist); } - else - return alist; + return alist; } #undef FUNC_NAME @@ -374,12 +374,12 @@ SCM_DEFINE (scm_assoc_remove_x, "assoc-remove!", 2, 0, 0, SCM handle; handle = scm_sloppy_assoc (key, alist); - if (SCM_CONSP (handle)) + while (SCM_CONSP (handle)) { - return scm_delete_x (handle, alist); + alist = scm_delq_x (handle, alist); + handle = scm_sloppy_assoc (key, alist); } - else - return alist; + return alist; } #undef FUNC_NAME From e85da7d990fedf0c9b60dc2d20d3cd1753c026f3 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 23 Jul 2000 11:50:33 +0000 Subject: [PATCH 0065/2047] *** empty log message *** --- libguile/ChangeLog | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index dd9906c61..6023b1cc9 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2000-07-23 Marius Vollmer + + * alist.c (scm_assq_remove_x, scm_assv_remove_x, + scm_assoc_remove_x): Remove all cells whose key is eq, eqv, or + equal (respectively) to the argument key, not all cells that are + eq, eqv, or equal to the first cell with the argument key. Thanks + to Neil Jerram! + 2000-07-18 Dirk Herrmann * gc.h (SCM_FREE_CELL_CDR, SCM_SET_FREE_CELL_CDR), hooks.c From 23d919087ee749cc68a3f4cc80b40a30d646c516 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 23 Jul 2000 23:12:02 +0000 Subject: [PATCH 0066/2047] * common-list.scm (uniq): Made tail-recursive. Thanks to thi! --- ice-9/common-list.scm | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/ice-9/common-list.scm b/ice-9/common-list.scm index 02d1858e2..ebb13fe5b 100644 --- a/ice-9/common-list.scm +++ b/ice-9/common-list.scm @@ -225,10 +225,11 @@ non-#f return values of P." (define-public (uniq l) "Return a list containing elements of L, with duplicates removed." - (if (null? l) - '() - (let ((u (uniq (cdr l)))) - (if (memq (car l) u) - u - (cons (car l) u))))) - + (let loop ((acc '()) + (l l)) + (if (null? l) + (reverse! acc) + (loop (if (memq (car l) acc) + acc + (cons (car l) acc)) + (cdr l))))) From a15e6dcc8fb52a0ff4c8376b277c8f13c3015318 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 23 Jul 2000 23:12:39 +0000 Subject: [PATCH 0067/2047] * stime.c (scm_strftime): Recognize a return value of zero from strftime as buffer overflow and take care to detect a valid zero length result regardless. Thanks to David Barts! --- libguile/stime.c | 24 +++++++++++++++++++++--- 1 file changed, 21 insertions(+), 3 deletions(-) diff --git a/libguile/stime.c b/libguile/stime.c index d5dbeecf3..7f739e346 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -62,6 +62,10 @@ # include # endif +#ifdef HAVE_STRING_H +#include +#endif + # ifdef TIME_WITH_SYS_TIME # include # include @@ -560,7 +564,7 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, char *tbuf; int size = 50; - char *fmt; + char *fmt, *myfmt; int len; SCM result; @@ -571,6 +575,16 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, fmt = SCM_ROCHARS (format); len = SCM_ROLENGTH (format); + /* Ugly hack: strftime can return 0 if its buffer is too small, + but some valid time strings (e.g. "%p") can sometimes produce + a zero-byte output string! Workaround is to prepend a junk + character to the format string, so that valid returns are always + nonzero. */ + myfmt = SCM_MUST_MALLOC (len+2); + *myfmt = 'x'; + strncpy(myfmt+1, fmt, len); + myfmt[len+1] = 0; + tbuf = SCM_MUST_MALLOC (size); { #if !defined (HAVE_TM_ZONE) @@ -603,7 +617,10 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, tzset (); #endif - while ((len = strftime (tbuf, size, fmt, &t)) == size) + /* POSIX says strftime returns 0 on buffer overrun, but old + systems (i.e. libc 4 on GNU/Linux) might return `size' in that + case. */ + while ((len = strftime (tbuf, size, myfmt, &t)) == 0 || len == size) { scm_must_free (tbuf); size *= 2; @@ -619,8 +636,9 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, #endif } - result = scm_makfromstr (tbuf, len, 0); + result = scm_makfromstr (tbuf+1, len-1, 0); scm_must_free (tbuf); + scm_must_free(myfmt); return result; } #undef FUNC_NAME From b73bde31c72c213c363b880463ca5ab28bf97291 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 23 Jul 2000 23:13:01 +0000 Subject: [PATCH 0068/2047] *** empty log message *** --- ice-9/ChangeLog | 4 ++++ libguile/ChangeLog | 6 ++++++ 2 files changed, 10 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 5620222bc..c3f575e3a 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2000-07-24 Marius Vollmer + + * common-list.scm (uniq): Made tail-recursive. Thanks to thi! + 2000-07-13 Dirk Herrmann * boot-9.scm (expt): In case of negative integer exponents return diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6023b1cc9..716f8a1c9 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2000-07-24 Marius Vollmer + + * stime.c (scm_strftime): Recognize a return value of zero from + strftime as buffer overflow and take care to detect a valid zero + length result regardless. Thanks to David Barts! + 2000-07-23 Marius Vollmer * alist.c (scm_assq_remove_x, scm_assv_remove_x, From 623ada63ad5ebebe55e76a0c25a8f996a68a7f85 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 25 Jul 2000 19:06:22 +0000 Subject: [PATCH 0069/2047] * alist.c (scm_assq_remove_x, scm_assv_remove_x, scm_assoc_remove_x): Remove only the first cell with a matching key, not all. --- libguile/alist.c | 26 ++++++++++---------------- 1 file changed, 10 insertions(+), 16 deletions(-) diff --git a/libguile/alist.c b/libguile/alist.c index e4f0b0cc5..da9335f67 100644 --- a/libguile/alist.c +++ b/libguile/alist.c @@ -331,18 +331,16 @@ SCM_DEFINE (scm_assq_remove_x, "assq-remove!", 2, 0, 0, (SCM alist, SCM key), "@deffnx primitive assv-remove! alist key\n" "@deffnx primitive assoc-remove! alist key\n" - "Delete all entries in @var{alist} associated with @var{key}, and return\n" + "Delete the first entry in @var{alist} associated with @var{key}, and return\n" "the resulting alist.") #define FUNC_NAME s_scm_assq_remove_x { SCM handle; handle = scm_sloppy_assq (key, alist); - while (SCM_CONSP (handle)) - { - alist = scm_delq_x (handle, alist); - handle = scm_sloppy_assq (key, alist); - } + if (SCM_CONSP (handle)) + alist = scm_delq_x (handle, alist); + return alist; } #undef FUNC_NAME @@ -356,11 +354,9 @@ SCM_DEFINE (scm_assv_remove_x, "assv-remove!", 2, 0, 0, SCM handle; handle = scm_sloppy_assv (key, alist); - while (SCM_CONSP (handle)) - { - alist = scm_delq_x (handle, alist); - handle = scm_sloppy_assv (key, alist); - } + if (SCM_CONSP (handle)) + alist = scm_delq_x (handle, alist); + return alist; } #undef FUNC_NAME @@ -374,11 +370,9 @@ SCM_DEFINE (scm_assoc_remove_x, "assoc-remove!", 2, 0, 0, SCM handle; handle = scm_sloppy_assoc (key, alist); - while (SCM_CONSP (handle)) - { - alist = scm_delq_x (handle, alist); - handle = scm_sloppy_assoc (key, alist); - } + if (SCM_CONSP (handle)) + alist = scm_delq_x (handle, alist); + return alist; } #undef FUNC_NAME From 17dd060d12c0e51d00f25463fc49c0e9cdb21d3a Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 25 Jul 2000 19:06:47 +0000 Subject: [PATCH 0070/2047] *** empty log message *** --- libguile/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 716f8a1c9..64c905361 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2000-07-25 Marius Vollmer + + * alist.c (scm_assq_remove_x, scm_assv_remove_x, + scm_assoc_remove_x): Remove only the first cell with a matching + key, not all. + 2000-07-24 Marius Vollmer * stime.c (scm_strftime): Recognize a return value of zero from From 5682251bb12a130ea0ec742174d5a58c8314f93f Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Tue, 25 Jul 2000 20:28:35 +0000 Subject: [PATCH 0071/2047] *** empty log message *** --- devel/tasks.text | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/devel/tasks.text b/devel/tasks.text index c70807147..e29c88799 100644 --- a/devel/tasks.text +++ b/devel/tasks.text @@ -47,11 +47,10 @@ ryanw ** integration of Jost's environments -gjb +dirk ** generational garbage collection -gregh livshin ** POSIX thread support @@ -116,7 +115,7 @@ dirk *** Orbit CORBA interface -Talk to mdj +livshin Local Variables: From 8e2488ffae40c1f13dfbadb118ba106df9e4bc43 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 26 Jul 2000 05:08:23 +0000 Subject: [PATCH 0072/2047] *** empty log message *** --- devel/policy/plans.text | 278 ---------------------------------------- devel/tasks.text | 4 + 2 files changed, 4 insertions(+), 278 deletions(-) diff --git a/devel/policy/plans.text b/devel/policy/plans.text index 93c4791a0..e69de29bb 100644 --- a/devel/policy/plans.text +++ b/devel/policy/plans.text @@ -1,278 +0,0 @@ -This file describes the current status and future plans for Guile development. - -* Status - -To give you an idea how far we are from the things described above, -here is the status of some topics. Guile used to suck, but it doesn't -any more. - -** Documentation - -XXX - Losta stuff, and talk also about updating the web page. - -** Object oriented programming - -Guile's object system is GOOPS. XXX - Some notes about -characteristics and motivations. - -** Multithreading - -At the moment, Guile supports co-operative threading on several -platforms. We do *not* support true kernel threads at present, not -because we don't think that would be way cool, but because it's -really, really hard. We're taking continually taking steps towards -that goal, however. - -Current status is that necessary basic changes to the garbage -collector and the signal handling has been done. (Few are aware of -it, but the SCM_DEFER_INTS/SCM_ALLOW_INTS macros no longer have any -effect!) - -The major remaining work is to protect common resources using mutecis. - -*** Using Guile's COOP threads in a POSIX threaded application - -A recent change has made it possible to mix use of Guile's COOP -threads and POSIX threads in a single application. This is useful, -since some GNOME libraries links with pthreads by default. (Guile -still has to run in a single POSIX thread, and the two thread systems -needs to use independent sets of thread synchronization mechanisms, -however.) - -** Graphical toolkit - -You can access Gtk+ from Guile by using the (separate) guile-gtk -package. The basic machinery of guile-gtk is mostly done but -individual features of Gtk+ are missing. Adding these features is -mostly the job of taking a look whether they are safe to export in -unmodified form and when that is the case, writing a couple of easy -lines of descriptions for the feature. This is mostly busy work. - -XXX - guile-tcltk? - -* Near Future - -What is planned for the near future. - -** Breakpoints and single-stepping in the debugger - -Guile now has a debugger (try `(debug)'). We are planning to -implement breakpoints and single-stepping, and then announce the -debugger in README file and documentation. - -** A new module system - -Integration of Jost Boekemeiers environment implementation. Greg -Badros has promised to try to integrate them. - -On top of that, a new module system will be implemented, but: - 1) We're not settled yet, - 2) we're really trying to settle it, and - 3) we're discovering why the rest of the Scheme scene isn't - settled on this issue either. - -There will be a C API to the new module system. - -** Factorization of Guile into function libraries - -Although Guile is meant to support composing a system from modules -well, it does not make use of this principle itself. The core is -quite monolithic and includes a lot of things that could be separated -out. - -We will be moving such things as networking, posix and regular -expression support to separate modules instead of having them all in -the root namespace. - -** Faster startup - -We will make Guile start up quicker. Guile's current slow startup is -primarily due to 1. inefficient code in a time-critical place in the -current module system, and, 2. that too much code is loaded at -startup. - -** Translators - -XXX - ??? - -*** C-like syntax for Scheme -*** elisp -*** tcl -*** python - -* The Guile wishlist - -** Revision and stabilization of interfaces - -Along with the updating the documentation, we should clean up the -interfaces of Guile. - -It should be well defined which existing Scheme procedures and C -functions and macros are supported as part of the "Guile language" and -which are temporary procedures used in the implementation of Guile or -historical remnants. - -** Full R5RS compliance - -XXX - -** SRFIs - -XXX - -** Reorganization of the numeric code - -Numeric tower - -3. Introduce a subclass of called . - - Such objects contain 7 pointers to C functions handling the argument - combinations (), (INUM), (REAL), (INUM, INUM), (REAL, INUM), - (INUM, REAL) and (REAL, REAL). - - When an is applied, it first uses simple - if-statements to dispatch onto one of these "primitive methods". - If that fails, it behaves as an ordinary generic, i.e., it does - type dispatch. - -4. Turn all standard Guile arithmetic, and comparison operators into - s and break up numbers.c into independent - modules. - -After this, we can easily add new types to the numeric tower. The new -types will be handled a little bit slower than INUMs and REALs, but I -think it will be fast enough. - -Some fundamental changes have already been done that make floating -point calculations more efficient. - -** Low-level support for hygienic macros - -Instead of a well integrated support for hygieneic macros, Guile -provides three redundant ways of defining unhygienic macros: -`procedure->macro', `defmacro' (with `defmacro-public'), and, -`define-macro' (which lacks a "public" version). There is a -syntax-case macro module (hygienic), but that macro system is written -in Scheme and makes loading time extend even further beyond it's -current unacceptable level. - -Guile macros are not compatible with Guile's module system. If you -export a macro, you need to explicitly export all bindings which it -uses. This needs to be fixed. - -It might be benefitial to separate memoization and execution to better -support macro expansion and compile time optimizations. The result of -the macro expansion and memoization pass could be permanentaly stored -on disk to reduce the load time of large programs. This would also -make the integration of a real compiler easier. See next point. - -** Compiler - -Hobbit doesn't support all of the Guile language, produces inefficient -code, and is a very unstructured program which can't be developed -further. - -It iss very important that the compiler and interpreter agree as much -as possible on the language they're implementing. Users should be -able to write code, run it in the interpreter, and then just switch -over to the compiler and have everything work just as it did before. - -To make this possible, the compiler and interpreter should share as -much code as possible. For example, the module system should be -designed to support both. They should use the same parser and the -same macro expander. - -** CORBA - -The way many of the major applications in the GNOME/Gtk+ world are -moving is this: - - Core application code is written in C or some other similarly - low-level langauge. - - However, internally it consists of Bonobo components. - - Bonobo components should in theory be accessible from any language - (someone really ought to write ORBit-guile) and can be recomposed in - ways other how the application originally intended. - -Thus, Gimp and Gnumeric will eventually in effect provide pieces that -can be used from Guile (and other langauges) and recombined; however, -these components will be written to the Bonobo API, not the Guile API, -and will require a CORBA mapping for the target language to work. - -There are advantages and disadvantages to doing things this way as -compared to writing Guile modules; but in either case we must be -prepared to play in this brave new world of components by ensuring -Guile has the proper tools available, because I don't think we are -going to convince the GNOME people that Guile modules provide all they -want from a component model. - -** POSIX threads support - -XXX - -** Faster GC - -We hope so. If someone came up with a running GC that's faster than -what we've got now, that would be extremely interesting. But this -isn't a primary focus. - -** Test suite - -XXX - -** Internationalization/multilingualization - -XXX - -** Integration of Guile into GNU programs - -XXX - -*** Emacs - -XXX - -*** The Gimp - -XXX - -** Soft typing - -XXX - combine with compiler section? - -** Importing changes from SCM - -XXX - -** Guile module repository - -One is to provide a better public face for Guile, and encourage people -to contribute useful extensions. This can be achieved by providing a -repository and managed namespace along the lines of CPAN. - -** More frequent releases - -We will try to make Guile releases more frequently. - -------------------- XXX - add the following to HACKING? - -** The CVS repository - -*** The current CVS version of Guile should always compile - -The current CVS version of Guile should always compile and not contain -major bugs. - -*** Applying patches - -A Guile developer should always fully understand the code in a patch -which he applies, and is responsible for the quality of the applied -patch. - -*** Experimental code - -Experimental code should be kept in the local working copy or -committed onto a branch. The only exception is when some kind of -feedback is needed from other developers or users. diff --git a/devel/tasks.text b/devel/tasks.text index e29c88799..a95ecc88b 100644 --- a/devel/tasks.text +++ b/devel/tasks.text @@ -45,6 +45,10 @@ rlb ryanw +** generic translator support + +mdj + ** integration of Jost's environments dirk From f762051048ae4ca01e8620d1494b3ccfb67724e4 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 26 Jul 2000 08:35:35 +0000 Subject: [PATCH 0073/2047] * Fixed struct initialization. --- NEWS | 2 ++ libguile/ChangeLog | 9 +++++++++ libguile/struct.c | 12 +++++------- libguile/struct.h | 1 - 4 files changed, 16 insertions(+), 8 deletions(-) diff --git a/NEWS b/NEWS index e902d5a4d..693fb836f 100644 --- a/NEWS +++ b/NEWS @@ -79,6 +79,8 @@ SCM_ORD_SIG, SCM_NUM_SIGS Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of SCM_OUTOFRANGE. Use scm_memory_error instead of SCM_NALLOC. +** Removed function: scm_struct_init + ** Deprecated function: scm_call_catching_errors Use scm_catch or scm_lazy_catch from throw.[ch] instead. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 64c905361..ca986cfdd 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2000-07-26 Dirk Herrmann + + * struct.[ch] (scm_struct_init): Made static. Fixed not to rely + on the struct cell to be fully initialized. + + * struct.c (scm_make_struct, scm_make_vtable_vtable): Fix the + initialization order of the struct such that the type cell is + initialized last. + 2000-07-25 Marius Vollmer * alist.c (scm_assq_remove_x, scm_assv_remove_x, diff --git a/libguile/struct.c b/libguile/struct.c index 520056c46..ea952e3b9 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -148,14 +148,12 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, -void -scm_struct_init (SCM handle, int tail_elts, SCM inits) +static void +scm_struct_init (SCM handle, SCM layout, scm_bits_t * mem, int tail_elts, SCM inits) { - SCM layout = SCM_STRUCT_LAYOUT (handle); unsigned char * fields_desc = (unsigned char *) SCM_CHARS (layout) - 2; unsigned char prot = 0; int n_fields = SCM_LENGTH (layout) / 2; - scm_bits_t * mem = SCM_STRUCT_DATA (handle); int tailp = 0; while (n_fields) @@ -399,8 +397,8 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, scm_struct_n_extra_words, "make-struct"); SCM_SET_CELL_WORD_1 (handle, data); + scm_struct_init (handle, layout, data, tail_elts, init); SCM_SET_CELL_WORD_0 (handle, (scm_bits_t) SCM_STRUCT_DATA (vtable) + scm_tc3_cons_gloc); - scm_struct_init (handle, tail_elts, init); SCM_ALLOW_INTS; return handle; } @@ -489,9 +487,9 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, scm_struct_n_extra_words, "make-vtable-vtable"); SCM_SET_CELL_WORD_1 (handle, data); + data [scm_vtable_index_layout] = SCM_UNPACK (layout); + scm_struct_init (handle, layout, data, tail_elts, scm_cons (layout, init)); SCM_SET_CELL_WORD_0 (handle, (scm_bits_t) data + scm_tc3_cons_gloc); - SCM_SET_STRUCT_LAYOUT (handle, layout); - scm_struct_init (handle, tail_elts, scm_cons (layout, init)); SCM_ALLOW_INTS; return handle; } diff --git a/libguile/struct.h b/libguile/struct.h index c7abfc577..623c82bf9 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -104,7 +104,6 @@ extern scm_sizet scm_struct_free_0 (scm_bits_t * vtable, scm_bits_t * data); extern scm_sizet scm_struct_free_light (scm_bits_t * vtable, scm_bits_t * data); extern scm_sizet scm_struct_free_standard (scm_bits_t * vtable, scm_bits_t * data); extern scm_sizet scm_struct_free_entity (scm_bits_t * vtable, scm_bits_t * data); -extern void scm_struct_init (SCM handle, int tail_elts, SCM inits); extern SCM scm_make_struct_layout (SCM fields); extern SCM scm_struct_p (SCM x); extern SCM scm_struct_vtable_p (SCM x); From a75923bb037e14730d8abbfee5a383d35e6427ba Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 26 Jul 2000 09:20:09 +0000 Subject: [PATCH 0074/2047] * Fix vector initialization. --- libguile/ChangeLog | 5 +++++ libguile/vectors.c | 6 +++--- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index ca986cfdd..64f58afba 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-07-26 Dirk Herrmann + + * vectors.c (scm_make_vector): Fix the initialization order of + the vector such that the type cell is initialized last. + 2000-07-26 Dirk Herrmann * struct.[ch] (scm_struct_init): Made static. Fixed not to rely diff --git a/libguile/vectors.c b/libguile/vectors.c index 1c59b96c1..e2e94e156 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -268,10 +268,10 @@ SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0, SCM_NEWCELL(v); SCM_DEFER_INTS; SCM_SETCHARS(v, scm_must_malloc(i?(long)(i*sizeof(SCM)):1L, FUNC_NAME)); - SCM_SETLENGTH(v, i, scm_tc7_vector); velts = SCM_VELTS(v); - j = 0; - while(--i >= j) (velts)[i] = fill; + for (j = 0; j < i; ++j) + velts[j] = fill; + SCM_SETLENGTH(v, i, scm_tc7_vector); SCM_ALLOW_INTS; return v; } From 1110299262325ebbe842d272ba1aa5129dcb8752 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 26 Jul 2000 11:29:58 +0000 Subject: [PATCH 0075/2047] * Renamed local variable 'free' to avoid confusion with stdlib's 'free'. --- libguile/ChangeLog | 5 +++++ libguile/gc.c | 4 ++-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 64f58afba..5b5c095b3 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-07-26 Dirk Herrmann + + * gc.c (scm_gc_sweep): Renamed local variable from 'free' to + 'free_struct_data' to avoid confusion with stdlib's 'free'. + 2000-07-26 Dirk Herrmann * vectors.c (scm_make_vector): Fix the initialization order of diff --git a/libguile/gc.c b/libguile/gc.c index ecf4ace1b..978a80057 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1480,9 +1480,9 @@ scm_gc_sweep () if (vtable_data [scm_vtable_index_vcell] == 0 || vtable_data [scm_vtable_index_vcell] == 1) { - scm_struct_free_t free + scm_struct_free_t free_struct_data = (scm_struct_free_t) vtable_data[scm_struct_i_free]; - m += free (vtable_data, (scm_bits_t *) SCM_UNPACK (SCM_GCCDR (scmptr))); + m += free_struct_data (vtable_data, (scm_bits_t *) SCM_UNPACK (SCM_GCCDR (scmptr))); } } } From 6de50a5278ca200afd2b21c0eccf4393377c00b3 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 28 Jul 2000 13:19:01 +0000 Subject: [PATCH 0076/2047] Fix spelling mistake --- doc/ChangeLog | 5 +++++ doc/data-rep.texi | 4 ++-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index bdde435c4..e7ba2180e 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,8 @@ +2000-07-28 Neil Jerram + + * data-rep.texi (Garbage Collection): Fix "accomodate" spelling + mistake. + 2000-06-30 Dirk Herrmann * data-rep.tex: Removed documentation for SCM_OUTOFRANGE. diff --git a/doc/data-rep.texi b/doc/data-rep.texi index 407a79656..b9d9a8438 100644 --- a/doc/data-rep.texi +++ b/doc/data-rep.texi @@ -46,7 +46,7 @@ by the Free Software Foundation. @sp 10 @comment The title is printed in a large font. @title Data Representation in Guile -@subtitle $Id: data-rep.texi,v 1.12 2000-06-30 10:46:33 dirk Exp $ +@subtitle $Id: data-rep.texi,v 1.13 2000-07-28 13:19:01 ossau Exp $ @subtitle For use with Guile @value{VERSION} @author Jim Blandy @author Free Software Foundation @@ -493,7 +493,7 @@ problem. The alternative, an explicitly maintained list of local variable addresses, is effectively much less reliable, due to programmer error. -To accomodate this technique, data must be represented so that the +To accommodate this technique, data must be represented so that the collector can accurately determine whether a given stack word is a pointer or not. Guile does this as follows: @itemize @bullet From 60e61f0a20c7251d1adfed55efe8376f84b5f0c8 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 30 Jul 2000 13:40:46 +0000 Subject: [PATCH 0077/2047] * alist.c (scm_assq_remove_x, scm_assv_remove_x, scm_assoc_remove_x): Use scm_delq1_x instead of scm_delq_x, since using the latter is pointless. --- libguile/alist.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/libguile/alist.c b/libguile/alist.c index da9335f67..adede41a2 100644 --- a/libguile/alist.c +++ b/libguile/alist.c @@ -339,7 +339,7 @@ SCM_DEFINE (scm_assq_remove_x, "assq-remove!", 2, 0, 0, handle = scm_sloppy_assq (key, alist); if (SCM_CONSP (handle)) - alist = scm_delq_x (handle, alist); + alist = scm_delq1_x (handle, alist); return alist; } @@ -355,7 +355,7 @@ SCM_DEFINE (scm_assv_remove_x, "assv-remove!", 2, 0, 0, handle = scm_sloppy_assv (key, alist); if (SCM_CONSP (handle)) - alist = scm_delq_x (handle, alist); + alist = scm_delq1_x (handle, alist); return alist; } @@ -371,7 +371,7 @@ SCM_DEFINE (scm_assoc_remove_x, "assoc-remove!", 2, 0, 0, handle = scm_sloppy_assoc (key, alist); if (SCM_CONSP (handle)) - alist = scm_delq_x (handle, alist); + alist = scm_delq1_x (handle, alist); return alist; } From 3ccd186077aae3034ae156a8fecb47f3893fc862 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 30 Jul 2000 13:41:01 +0000 Subject: [PATCH 0078/2047] *** empty log message *** --- libguile/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 5b5c095b3..fef500b3c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2000-07-30 Marius Vollmer + + * alist.c (scm_assq_remove_x, scm_assv_remove_x, + scm_assoc_remove_x): Use scm_delq1_x instead of scm_delq_x, since + using the latter is pointless. + 2000-07-26 Dirk Herrmann * gc.c (scm_gc_sweep): Renamed local variable from 'free' to From 08f980a4faa3d1b1c64bd7fb15df041bfc9c5227 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Mon, 31 Jul 2000 21:02:54 +0000 Subject: [PATCH 0079/2047] 2000-07-31 Gary Houston * acconfig.h: added HAVE_H_ERRNO * configure.in: removed some dnl'd & obsolete cygwin stuff. added a test for h_errno. --- acconfig.h | 3 +++ configure.in | 39 ++++++++++++--------------------------- 2 files changed, 15 insertions(+), 27 deletions(-) diff --git a/acconfig.h b/acconfig.h index 5f20c10d8..b7b42bc3d 100644 --- a/acconfig.h +++ b/acconfig.h @@ -110,6 +110,9 @@ /* Define if dlsym automatically supplies a leading underscore. */ #undef DLSYM_ADDS_USCORE +/* Define if h_errno is declared in netdb.h. */ +#undef HAVE_H_ERRNO + /* Define if localtime caches the TZ setting. */ #undef LOCALTIME_CACHE diff --git a/configure.in b/configure.in index 395ca7d76..09e897dee 100644 --- a/configure.in +++ b/configure.in @@ -210,8 +210,6 @@ case "$guile_cv_func_usleep_return_type" in ;; esac -dnl - AC_CHECK_HEADER(sys/un.h, have_sys_un_h=1) if test -n "$have_sys_un_h" ; then AC_DEFINE(HAVE_UNIX_DOMAIN_SOCKETS) @@ -219,30 +217,6 @@ fi AC_CHECK_FUNCS(socketpair getgroups setpwent pause tzset) -dnl I don't know what this prefixing of cygwin32_ is for. -dnl scmconfig.h wasn't updated with the test results. -dnl so use AC_CHECK_FUNCS for now. - -dnl how about: -dnl save confdefs.h -dnl if test $ac_cv_cigwin = yes; then -dnl modify confdefs.h -dnl fi -dnl AC_CHECK_FUNCS... -dnl restore confdefs.h - -dnl cp confdefs.h confdefs.h.bak -dnl for func in gethostent sethostent endhostent getnetent setnetent endnetent getprotoent setprotoent endprotoent getservent setservent endservent getnetbyaddr getnetbyname inet_lnaof inet_makeaddr inet_netof hstrerror; do -dnl cp confdefs.h.bak confdefs.h -dnl cat >> confdefs.h << EOF -dnl #ifdef __CYGWIN32__ -dnl #define $func cygwin32_$func -dnl #endif -dnl EOF -dnl AC_CHECK_FUNC($func) -dnl done -dnl cp confdefs.h.bak confdefs.h - AC_CHECK_FUNCS(sethostent gethostent endhostent dnl setnetent getnetent endnetent dnl setprotoent getprotoent endprotoent dnl @@ -250,7 +224,18 @@ AC_CHECK_FUNCS(sethostent gethostent endhostent dnl getnetbyaddr getnetbyname dnl inet_lnaof inet_makeaddr inet_netof hstrerror) -dnl +dnl Some systems do not declare this. Some systems do declare it, as a +dnl macro. With cygwin it may be in a DLL. + +AC_MSG_CHECKING(whether netdb.h declares h_errno) +AC_CACHE_VAL(guile_cv_have_h_errno, +[AC_TRY_COMPILE([#include ], +[int a = h_errno;], +guile_cv_have_h_errno=yes, guile_cv_have_h_errno=no)]) +AC_MSG_RESULT($guile_cv_have_h_errno) +if test $guile_cv_have_h_errno = yes; then + AC_DEFINE(HAVE_H_ERRNO) +fi AC_MSG_CHECKING(whether localtime caches TZ) AC_CACHE_VAL(guile_cv_localtime_cache, From 42aae6335f633e918d02d164e17c55b9417ac9e9 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Mon, 31 Jul 2000 21:03:47 +0000 Subject: [PATCH 0080/2047] *** empty log message *** --- ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/ChangeLog b/ChangeLog index 0d8325b26..e8aa470c3 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2000-07-31 Gary Houston + + * acconfig.h: added HAVE_H_ERRNO + * configure.in: removed some dnl'd & obsolete cygwin stuff. + added a test for h_errno. + 2000-06-21 Mikael Djurfeldt * Guile 1.4 released. From a080badb0732037e7617bd010db12db78f6cc59e Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Mon, 31 Jul 2000 21:08:30 +0000 Subject: [PATCH 0081/2047] 2000-07-31 Gary Houston * net_db.c: declare h_errno only if HAVE_H_ERRNO is defined (thanks to Richard Kim for the bug report). --- libguile/net_db.c | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/libguile/net_db.c b/libguile/net_db.c index ed1c54317..82da282b4 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -70,9 +70,7 @@ #include #include -/* Some systems do not declare this. Some systems do declare it, as a - macro. */ -#ifndef h_errno +#if !defined (HAVE_H_ERRNO) extern int h_errno; #endif From 3bc0c6df34932fb31a611da3aba2b62a16a8dbe0 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Mon, 31 Jul 2000 21:09:02 +0000 Subject: [PATCH 0082/2047] *** empty log message *** --- libguile/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index fef500b3c..391c80cf0 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-07-31 Gary Houston + + * net_db.c: declare h_errno only if HAVE_H_ERRNO is defined + (thanks to Richard Kim for the bug report). + 2000-07-30 Marius Vollmer * alist.c (scm_assq_remove_x, scm_assv_remove_x, From cdaf0a20afcd06f8cc83b5a1c958780e94feba30 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Tue, 1 Aug 2000 18:43:54 +0000 Subject: [PATCH 0083/2047] *** empty log message *** --- libguile/ChangeLog | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 391c80cf0..f4f48650c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,6 +1,6 @@ 2000-07-31 Gary Houston - * net_db.c: declare h_errno only if HAVE_H_ERRNO is defined + * net_db.c: declare h_errno only if HAVE_H_ERRNO is not defined (thanks to Richard Kim for the bug report). 2000-07-30 Marius Vollmer From daba1a710da4275b5ac52f4d2ca0353eae9ae1ef Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 2 Aug 2000 06:00:09 +0000 Subject: [PATCH 0084/2047] * print.c (scm_simple_format): Bugfix: Coerce port before using it. --- libguile/print.c | 32 +++++++++++++++++++------------- 1 file changed, 19 insertions(+), 13 deletions(-) diff --git a/libguile/print.c b/libguile/print.c index ebe9c9751..7bebd6557 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -960,18 +960,24 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, char *start; char *p; - if (SCM_EQ_P (destination, SCM_BOOL_T)) { - destination = scm_cur_outp; - } else if (SCM_FALSEP (destination)) { - fReturnString = 1; - destination = scm_mkstrport (SCM_INUM0, - scm_make_string (SCM_INUM0, SCM_UNDEFINED), - SCM_OPN | SCM_WRTNG, - FUNC_NAME); - } else { - SCM_VALIDATE_OPORT_VALUE (1,destination); - } - SCM_VALIDATE_STRING(2,message); + if (SCM_EQ_P (destination, SCM_BOOL_T)) + { + destination = scm_cur_outp; + } + else if (SCM_FALSEP (destination)) + { + fReturnString = 1; + destination = scm_mkstrport (SCM_INUM0, + scm_make_string (SCM_INUM0, SCM_UNDEFINED), + SCM_OPN | SCM_WRTNG, + FUNC_NAME); + } + else + { + SCM_VALIDATE_OPORT_VALUE (1, destination); + destination = SCM_COERCE_OUTPORT (destination); + } + SCM_VALIDATE_STRING (2, message); SCM_VALIDATE_REST_ARGUMENT (args); start = SCM_ROCHARS (message); @@ -999,7 +1005,7 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, if (fReturnString) answer = scm_strport_to_string (destination); - return scm_return_first(answer,message); + return scm_return_first (answer, message); } #undef FUNC_NAME From b62cc1c27ff4a420d35436c805a205822db0fe50 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 2 Aug 2000 06:00:28 +0000 Subject: [PATCH 0085/2047] *** empty log message *** --- libguile/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f4f48650c..98b57f4ea 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-08-02 Mikael Djurfeldt + + * print.c (scm_simple_format): Bugfix: Coerce port before using + it. + 2000-07-31 Gary Houston * net_db.c: declare h_errno only if HAVE_H_ERRNO is not defined From e478dffa01f7399c58b349fa7034a33a12aad6d3 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 2 Aug 2000 06:11:08 +0000 Subject: [PATCH 0086/2047] *** empty log message *** --- NEWS | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/NEWS b/NEWS index 693fb836f..845f6e83d 100644 --- a/NEWS +++ b/NEWS @@ -2681,9 +2681,9 @@ inherits the print-state of OLD-PORT. ** New constants: vtable-index-layout, vtable-index-vtable, vtable-index-printer -** There is now a fourth (optional) argument to make-vtable-vtable and - make-struct when constructing new types (vtables). This argument - initializes field vtable-index-printer of the vtable. +** There is now a third optional argument to make-vtable-vtable + (and fourth to make-struct) when constructing new types (vtables). + This argument initializes field vtable-index-printer of the vtable. ** The detection of circular references has been extended to structs. That is, a structure that -- in the process of being printed -- prints From 04323af4ad67d258f126006f16528315c13374eb Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 2 Aug 2000 06:34:51 +0000 Subject: [PATCH 0087/2047] * struct.c (scm_make_struct_layout, scm_make_struct, scm_make_vtable_vtable): Updated documentation. --- libguile/struct.c | 117 +++++++++++++++++++++++----------------------- 1 file changed, 59 insertions(+), 58 deletions(-) diff --git a/libguile/struct.c b/libguile/struct.c index ea952e3b9..1fd9278e4 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -74,7 +74,7 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, "strung together. The first character of each pair describes a field\n" "type, the second a field protection. Allowed types are 'p' for\n" "GC-protected Scheme data, 'u' for unprotected binary data, and 's' for\n" - "fields that should point to the structure itself. Allowed protections\n" + "a field that points to the structure itself. Allowed protections\n" "are 'w' for mutable fields, 'r' for read-only fields, and 'o' for opaque \n" "fields. The last field protection specification may be capitalized to\n" "indicate that the field is a tail-array.") @@ -362,11 +362,21 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, "@var{tail-elts} must be a non-negative integer. If the layout\n" "specification indicated by @var{type} includes a tail-array,\n" "this is the number of elements allocated to that array.\n\n" - "The @var{inits} are optional arguments describing how successive fields\n" - "of the structure should be initialized. Only fields with protection 'r'\n" - "or 'w' can be initialized -- fields of protection 's' are automatically\n" - "initialized to point to the new structure itself; fields of protection 'o'\n" - "can not be initialized by Scheme programs.") + "The @var{init1}, @dots are optional arguments describing how\n" + "successive fields of the structure should be initialized. Only fields\n" + "with protection 'r' or 'w' can be initialized, except for fields of\n" + "type 's', which are automatically initialized to point to the new\n" + "structure itself; fields with protection 'o' can not be initialized by\n" + "Scheme programs.\n\n" + "If fewer optional arguments than initializable fields are supplied,\n" + "fields of type 'p' get default value #f while fields of type 'u' are\n" + "initialized to 0.\n\n" + "Structs are currently the basic representation for record-like data\n" + "structures in Guile. The plan is to eventually replace them with a\n" + "new representation which will at the same time be easier to use and\n" + "more powerful.\n\n" + "For more information, see the documentation for @code{make-vtable-vtable}.\n" + "") #define FUNC_NAME s_scm_make_struct { SCM layout; @@ -407,59 +417,50 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, - (SCM extra_fields, SCM tail_array_size, SCM init), + (SCM user_fields, SCM tail_array_size, SCM init), "Return a new, self-describing vtable structure.\n\n" - "@var{new-fields} is a layout specification describing fields\n" - "of the resulting structure beginning at the position bound to\n" - "@code{vtable-offset-user}.\n\n" + "@var{user-fields} is a string describing user defined fields of the\n" + "vtable beginning at index @code{vtable-offset-user}\n" + "(see @code{make-struct-layout}).\n\n" "@var{tail-size} specifies the size of the tail-array (if any) of\n" "this vtable.\n\n" - "@var{inits} initializes the fields of the vtable. Minimally, one\n" - "initializer must be provided: the layout specification for instances\n" - "of the type this vtable will describe. If a second initializer is\n" - "provided, it will be interpreted as a print call-back function.\n\n" + "@var{init1}, @dots are the optional initializers for the fields of\n" + "the vtable.\n\n" + "Vtables have one initializable system field---the struct printer.\n" + "This field comes before the user fields in the initializers passed\n" + "to @code{make-vtable-vtable} and @code{make-struct}, and thus works as\n" + "a third optional argument to @code{make-vtable-vtable} and a fourth to\n" + "@code{make-struct} when creating vtables:\n\n" + "If the value is a procedure, it will be called instead of the standard\n" + "printer whenever a struct described by this vtable is printed.\n" + "The procedure will be called with arguments STRUCT and PORT.\n\n" + "The structure of a struct is described by a vtable, so the vtable is\n" + "in essence the type of the struct. The vtable is itself a struct with\n" + "a vtable. This could go on forever if it weren't for the\n" + "vtable-vtables which are self-describing vtables, and thus terminates\n" + "the chain.\n\n" + "There are several potential ways of using structs, but the standard\n" + "one is to use three kinds of structs, together building up a type\n" + "sub-system: one vtable-vtable working as the root and one or several\n" + "\"types\", each with a set of \"instances\". (The vtable-vtable should be\n" + "compared to the class which is a class of itself.)\n\n" "@example\n" - ";;; loading ,a...\n" - "(define x\n" - " (make-vtable-vtable (make-struct-layout (quote pw))\n" - " 0\n" - " 'foo))\n\n" - "(struct? x)\n" - "@result{} #t\n" - "(struct-vtable? x)\n" - "@result{} #t\n" - "(eq? x (struct-vtable x))\n" - "@result{} #t\n" - "(struct-ref x vtable-offset-user)\n" - "@result{} foo\n" - "(struct-ref x 0)\n" - "@result{} pruosrpwpw\n\n\n" - "(define y\n" - " (make-struct x\n" - " 0\n" - " (make-struct-layout (quote pwpwpw))\n" - " 'bar))\n\n" - "(struct? y)\n" - "@result{} #t\n" - "(struct-vtable? y)\n" - "@result{} #t\n" - "(eq? x y)\n" - "@result{} ()\n" - "(eq? x (struct-vtable y))\n" - "@result{} #t\n" - "(struct-ref y 0)\n" - "@result{} pwpwpw\n" - "(struct-ref y vtable-offset-user)\n" - "@result{} bar\n\n\n" - "(define z (make-struct y 0 'a 'b 'c))\n\n" - "(struct? z)\n" - "@result{} #t\n" - "(struct-vtable? z)\n" - "@result{} ()\n" - "(eq? y (struct-vtable z))\n" - "@result{} #t\n" - "(map (lambda (n) (struct-ref z n)) '(0 1 2))\n" - "@result{} (a b c)\n" + "(define ball-root (make-vtable-vtable \"pr\" 0))\n\n" + "(define (make-ball-type ball-color)\n" + " (make-struct ball-root 0\n" + " (make-struct-layout \"pw\")\n" + " (lambda (ball port)\n" + " (format port \"#\"\n" + " (color ball)\n" + " (owner ball)))\n" + " ball-color))\n" + "(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))\n" + "(define (owner ball) (struct-ref ball 0))\n\n" + "(define red (make-ball-type 'red))\n" + "(define green (make-ball-type 'green))\n\n" + "(define (make-ball type owner) (make-struct type 0 owner))\n\n" + "(define ball (make-ball green 'Nisse))\n" + "ball @result{} #\n" "@end example\n" "") #define FUNC_NAME s_scm_make_vtable_vtable @@ -471,12 +472,12 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, scm_bits_t * data; SCM handle; - SCM_VALIDATE_ROSTRING (1,extra_fields); - SCM_VALIDATE_INUM (2,tail_array_size); + SCM_VALIDATE_ROSTRING (1, user_fields); + SCM_VALIDATE_INUM (2, tail_array_size); SCM_VALIDATE_REST_ARGUMENT (init); fields = scm_string_append (scm_listify (required_vtable_fields, - extra_fields, + user_fields, SCM_UNDEFINED)); layout = scm_make_struct_layout (fields); basic_size = SCM_LENGTH (layout) / 2; From 89e941f154d8d8c21c1b7ff7df88895f73455434 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 2 Aug 2000 06:35:18 +0000 Subject: [PATCH 0088/2047] *** empty log message *** --- libguile/ChangeLog | 3 +++ 1 file changed, 3 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 98b57f4ea..8a81851f3 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,8 @@ 2000-08-02 Mikael Djurfeldt + * struct.c (scm_make_struct_layout, scm_make_struct, + scm_make_vtable_vtable): Updated documentation. + * print.c (scm_simple_format): Bugfix: Coerce port before using it. From 29b4f9fb2ca974e34d4aef2f19baebc70bbd91fb Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 2 Aug 2000 06:48:28 +0000 Subject: [PATCH 0089/2047] *** empty log message *** --- libguile/struct.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/struct.c b/libguile/struct.c index 1fd9278e4..955c250b9 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -437,13 +437,13 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, "The structure of a struct is described by a vtable, so the vtable is\n" "in essence the type of the struct. The vtable is itself a struct with\n" "a vtable. This could go on forever if it weren't for the\n" - "vtable-vtables which are self-describing vtables, and thus terminates\n" + "vtable-vtables which are self-describing vtables, and thus terminate\n" "the chain.\n\n" "There are several potential ways of using structs, but the standard\n" "one is to use three kinds of structs, together building up a type\n" "sub-system: one vtable-vtable working as the root and one or several\n" "\"types\", each with a set of \"instances\". (The vtable-vtable should be\n" - "compared to the class which is a class of itself.)\n\n" + "compared to the class which is the class of itself.)\n\n" "@example\n" "(define ball-root (make-vtable-vtable \"pr\" 0))\n\n" "(define (make-ball-type ball-color)\n" From a26f1191e31d88fe6ccab62f4db5ef15c4d7e18c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 5 Aug 2000 14:33:31 +0000 Subject: [PATCH 0090/2047] * iselect.c: Include . Thanks to Bertrand Petit! --- libguile/iselect.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/libguile/iselect.c b/libguile/iselect.c index 46ef923e7..ea0be94f0 100644 --- a/libguile/iselect.c +++ b/libguile/iselect.c @@ -43,6 +43,10 @@ #include #include +#ifdef HAVE_UNISTD_H +#include +#endif + #include "libguile/_scm.h" #include "libguile/async.h" From 7ca387343448b07dc24435711a1199f9d514498c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 5 Aug 2000 14:34:00 +0000 Subject: [PATCH 0091/2047] *** empty log message *** --- libguile/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 8a81851f3..fdc4c3196 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2000-08-05 Marius Vollmer + + * iselect.c: Include . Thanks to Bertrand Petit! + 2000-08-02 Mikael Djurfeldt * struct.c (scm_make_struct_layout, scm_make_struct, From d156d3b7301f95d06253f28e26bc49a141b81375 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 6 Aug 2000 22:04:11 +0000 Subject: [PATCH 0092/2047] * read.c (scm_flush_ws): Include filename in error message when it is not `#f'. --- libguile/read.c | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/libguile/read.c b/libguile/read.c index 1fa86009c..23d0e9ada 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -138,7 +138,14 @@ scm_flush_ws (SCM port, const char *eoferr) case EOF: goteof: if (eoferr) - scm_wta (SCM_UNDEFINED, "end of file in ", eoferr); + { + if (SCM_FILENAME (port) != SCM_BOOL_F) + scm_misc_error (eoferr, + "end of file in ~A", + SCM_LIST1 (SCM_FILENAME (port))); + else + scm_misc_error (eoferr, "end of file", SCM_EOL); + } return c; case ';': lp: From b054684d816866a8392e0c9fcedec414eff0a0a1 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 6 Aug 2000 22:04:35 +0000 Subject: [PATCH 0093/2047] *** empty log message *** --- libguile/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index fdc4c3196..318b5f0b4 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-08-06 Marius Vollmer + + * read.c (scm_flush_ws): Include filename in error message when it + is not `#f'. + 2000-08-05 Marius Vollmer * iselect.c: Include . Thanks to Bertrand Petit! From 163fada3d319d6738fa1afb444f0c7e210da5c71 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Mon, 7 Aug 2000 20:20:24 +0000 Subject: [PATCH 0094/2047] *** empty log message *** --- devel/policy/goals.text | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/devel/policy/goals.text b/devel/policy/goals.text index 9ef9aa7f1..32ce46b68 100644 --- a/devel/policy/goals.text +++ b/devel/policy/goals.text @@ -23,7 +23,7 @@ can be found in the file "plans.text". ** Guile as an extension language library Guile's primary aim is to provide a good extension language which is -easy to add to an application written in C on a UNIX machine. This +easy to add to an application written in C for the GNU system. This means that it must export the features of a higher level language in a way that makes it easy not to break them from C code. @@ -80,3 +80,13 @@ layer of Scheme code. Guile has support for writing modules in C or other compiled languages. + +** Guile as a basis for other languages + +Scheme is a very powerful language, which makes it possible +to implement other languages by translating them into Scheme. + +By writing translators that convert various popular scripting +languages into Scheme, we can enable users to choose their favorite +languages for extending any program that provides extensibility using +Guile. From 7445e0e8eb12b02c61c6b3b918b625bdacbeaa8a Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 9 Aug 2000 18:29:10 +0000 Subject: [PATCH 0095/2047] * gc.c (scm_gc_mark, scm_gc_sweep): Remove vcell = 1 magic. (scm_structs_to_free): New variable. (scm_gc_sweep): Hook up structs to free on the scm_structs_to_free chain. --- libguile/gc.c | 113 ++++++++++++++++++++++++-------------------------- 1 file changed, 54 insertions(+), 59 deletions(-) diff --git a/libguile/gc.c b/libguile/gc.c index 978a80057..f682881fc 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -319,6 +319,10 @@ int scm_block_gc = 1; */ SCM scm_weak_vectors; +/* During collection, this accumulates structures which are to be freed. + */ +SCM scm_structs_to_free; + /* GC Statistics Keeping */ unsigned long scm_cells_allocated = 0; @@ -1038,55 +1042,48 @@ gc_mark_nimp: */ scm_bits_t word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_cons_gloc; scm_bits_t * vtable_data = (scm_bits_t *) word0; /* access as struct */ - switch (vtable_data [scm_vtable_index_vcell]) + if (vtable_data [scm_vtable_index_vcell] != 0) { - default: - { - /* ptr is a gloc */ - SCM gloc_car = SCM_PACK (word0); - scm_gc_mark (gloc_car); - ptr = SCM_GCCDR (ptr); - goto gc_mark_loop; - } - case 1: /* ! */ - case 0: /* ! */ - { - /* ptr is a struct */ - SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]); - int len = SCM_LENGTH (layout); - char * fields_desc = SCM_CHARS (layout); - /* We're using SCM_GCCDR here like STRUCT_DATA, except - that it removes the mark */ - scm_bits_t * struct_data = (scm_bits_t *) SCM_UNPACK (SCM_GCCDR (ptr)); + /* ptr is a gloc */ + SCM gloc_car = SCM_PACK (word0); + scm_gc_mark (gloc_car); + ptr = SCM_GCCDR (ptr); + goto gc_mark_loop; + } + else + { + /* ptr is a struct */ + SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]); + int len = SCM_LENGTH (layout); + char * fields_desc = SCM_CHARS (layout); + /* We're using SCM_GCCDR here like STRUCT_DATA, except + that it removes the mark */ + scm_bits_t * struct_data = (scm_bits_t *) SCM_UNPACK (SCM_GCCDR (ptr)); - if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) - { - scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_procedure])); - scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_setter])); - } - if (len) - { - int x; + if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) + { + scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_procedure])); + scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_setter])); + } + if (len) + { + int x; - for (x = 0; x < len - 2; x += 2, ++struct_data) - if (fields_desc[x] == 'p') - scm_gc_mark (SCM_PACK (*struct_data)); + for (x = 0; x < len - 2; x += 2, ++struct_data) if (fields_desc[x] == 'p') - { - if (SCM_LAYOUT_TAILP (fields_desc[x + 1])) - for (x = *struct_data; x; --x) - scm_gc_mark (SCM_PACK (*++struct_data)); - else - scm_gc_mark (SCM_PACK (*struct_data)); - } - } - if (vtable_data [scm_vtable_index_vcell] == 0) - { - vtable_data [scm_vtable_index_vcell] = 1; - ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]); - goto gc_mark_loop; - } - } + scm_gc_mark (SCM_PACK (*struct_data)); + if (fields_desc[x] == 'p') + { + if (SCM_LAYOUT_TAILP (fields_desc[x + 1])) + for (x = *struct_data; x; --x) + scm_gc_mark (SCM_PACK (*++struct_data)); + else + scm_gc_mark (SCM_PACK (*struct_data)); + } + } + /* mark vtable */ + ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]); + goto gc_mark_loop; } } break; @@ -1467,24 +1464,22 @@ scm_gc_sweep () * struct or a gloc. See the corresponding comment in * scm_gc_mark. */ - scm_bits_t word0 = SCM_CELL_WORD_0 (scmptr) - scm_tc3_cons_gloc; - scm_bits_t * vtable_data = (scm_bits_t *) word0; /* access as struct */ + scm_bits_t word0 = (SCM_CELL_WORD_0 (scmptr) + - scm_tc3_cons_gloc); + /* access as struct */ + scm_bits_t * vtable_data = (scm_bits_t *) word0; if (SCM_GCMARKP (scmptr)) + goto cmrkcontinue; + else if (vtable_data[scm_vtable_index_vcell] == 0) { - if (vtable_data [scm_vtable_index_vcell] == 1) - vtable_data [scm_vtable_index_vcell] = 0; + /* Structs need to be freed in a special order. + * This is handled by GC C hooks in struct.c. + */ + SCM_SET_STRUCT_GC_CHAIN (scmptr, scm_structs_to_free); + scm_structs_to_free = scmptr; goto cmrkcontinue; } - else - { - if (vtable_data [scm_vtable_index_vcell] == 0 - || vtable_data [scm_vtable_index_vcell] == 1) - { - scm_struct_free_t free_struct_data - = (scm_struct_free_t) vtable_data[scm_struct_i_free]; - m += free_struct_data (vtable_data, (scm_bits_t *) SCM_UNPACK (SCM_GCCDR (scmptr))); - } - } + /* fall through so that scmptr gets collected */ } break; case scm_tcs_cons_imcar: From 1d49cea8b8a7eb7188211ed626df5be500ad5cb9 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 9 Aug 2000 18:29:21 +0000 Subject: [PATCH 0096/2047] * init.c (scm_boot_guile_1): Call scm_struct_prehistory. --- libguile/init.c | 1 + 1 file changed, 1 insertion(+) diff --git a/libguile/init.c b/libguile/init.c index ea61c5b19..ee8a060e3 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -485,6 +485,7 @@ scm_boot_guile_1 (SCM_STACKITEM *base, struct main_func_closure *closure) scm_i_getenv_int ("GUILE_INIT_SEGMENT_SIZE_2", 0), scm_i_getenv_int ("GUILE_MIN_YIELD_2", 0), scm_i_getenv_int ("GUILE_MAX_SEGMENT_SIZE", 0)); + scm_struct_prehistory (); /* Must come after scm_init_storage */ scm_weaks_prehistory (); /* Must come after scm_init_storage */ scm_init_subr_table (); scm_init_root (); From 08c880a36746289330f3722522960ea21fe4ddc8 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 9 Aug 2000 18:29:31 +0000 Subject: [PATCH 0097/2047] * struct.c (scm_make_struct, scm_make_vtable_vtable): Structs handles are now double cells; Initialize SCM_STRUCT_GC_CHAIN to 0. (scm_struct_gc_init, scm_free_structs): New GC C hooks. (scm_struct_prehistory): Install them. --- libguile/struct.c | 65 +++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 63 insertions(+), 2 deletions(-) diff --git a/libguile/struct.c b/libguile/struct.c index 955c250b9..1c5df0bb3 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -355,6 +355,58 @@ scm_struct_free_entity (scm_bits_t * vtable, scm_bits_t * data) return n; } +static void * +scm_struct_gc_init (void *dummy1, void *dummy2, void *dummy3) +{ + scm_structs_to_free = SCM_EOL; + return 0; +} + +static void * +scm_free_structs (void *dummy1, void *dummy2, void *dummy3) +{ + SCM newchain = scm_structs_to_free; + do + { + /* Mark vtables in GC chain. GC mark set means delay freeing. */ + SCM chain = newchain; + while (SCM_NNULLP (chain)) + { + SCM vtable = SCM_STRUCT_VTABLE (chain); + if (SCM_STRUCT_GC_CHAIN (vtable) != 0 && vtable != chain) + SCM_SETGCMARK (vtable); + chain = SCM_STRUCT_GC_CHAIN (chain); + } + /* Free unmarked structs. */ + chain = newchain; + newchain = SCM_EOL; + while (SCM_NNULLP (chain)) + { + SCM obj = chain; + chain = SCM_STRUCT_GC_CHAIN (chain); + if (SCM_GCMARKP (obj)) + { + SCM_CLRGCMARK (obj); + SCM_SET_STRUCT_GC_CHAIN (obj, newchain); + newchain = obj; + } + else + { + scm_bits_t word0 = SCM_CELL_WORD_0 (obj) - scm_tc3_cons_gloc; + /* access as struct */ + scm_bits_t * vtable_data = (scm_bits_t *) word0; + scm_bits_t * data = (scm_bits_t *) SCM_UNPACK (SCM_CDR (obj)); + scm_struct_free_t free_struct_data + = ((scm_struct_free_t) vtable_data[scm_struct_i_free]); + SCM_SET_CELL_TYPE (obj, scm_tc_free_cell); + free_struct_data (vtable_data, data); + } + } + } + while (SCM_NNULLP (newchain)); + return 0; +} + SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, (SCM vtable, SCM tail_array_size, SCM init), "Create a new structure.\n\n" @@ -392,7 +444,7 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, layout = SCM_PACK (SCM_STRUCT_DATA (vtable) [scm_vtable_index_layout]); basic_size = SCM_LENGTH (layout) / 2; tail_elts = SCM_INUM (tail_array_size); - SCM_NEWCELL (handle); + SCM_NEWCELL2 (handle); SCM_DEFER_INTS; if (SCM_STRUCT_DATA (vtable)[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) { @@ -407,6 +459,7 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, scm_struct_n_extra_words, "make-struct"); SCM_SET_CELL_WORD_1 (handle, data); + SCM_SET_STRUCT_GC_CHAIN (handle, 0); scm_struct_init (handle, layout, data, tail_elts, init); SCM_SET_CELL_WORD_0 (handle, (scm_bits_t) SCM_STRUCT_DATA (vtable) + scm_tc3_cons_gloc); SCM_ALLOW_INTS; @@ -482,12 +535,13 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, layout = scm_make_struct_layout (fields); basic_size = SCM_LENGTH (layout) / 2; tail_elts = SCM_INUM (tail_array_size); - SCM_NEWCELL (handle); + SCM_NEWCELL2 (handle); SCM_DEFER_INTS; data = scm_alloc_struct (basic_size + tail_elts, scm_struct_n_extra_words, "make-vtable-vtable"); SCM_SET_CELL_WORD_1 (handle, data); + SCM_SET_STRUCT_GC_CHAIN (handle, 0); data [scm_vtable_index_layout] = SCM_UNPACK (layout); scm_struct_init (handle, layout, data, tail_elts, scm_cons (layout, init)); SCM_SET_CELL_WORD_0 (handle, (scm_bits_t) data + scm_tc3_cons_gloc); @@ -754,6 +808,13 @@ scm_print_struct (SCM exp, SCM port, scm_print_state *pstate) } } +void +scm_struct_prehistory () +{ + scm_c_hook_add (&scm_before_mark_c_hook, scm_struct_gc_init, 0, 0); + scm_c_hook_add (&scm_after_sweep_c_hook, scm_free_structs, 0, 0); +} + void scm_init_struct () { From 85c213397849c01a9a52c3cd20ac4e0dc4f9d3bd Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 9 Aug 2000 18:29:39 +0000 Subject: [PATCH 0098/2047] * struct.h (SCM_STRUCT_GC_CHAIN, SCM_SET_STRUCT_GC_CHAIN): New macros. (scm_structs_to_free, scm_struct_prehistory): Declare. --- libguile/struct.h | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/struct.h b/libguile/struct.h index 623c82bf9..b78f9a7f9 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -97,6 +97,10 @@ typedef scm_sizet (*scm_struct_free_t) (scm_bits_t * vtable, scm_bits_t * data); #define SCM_SET_STRUCT_TABLE_CLASS(X, CLASS) SCM_SETCDR (X, CLASS) extern SCM scm_struct_table; +#define SCM_STRUCT_GC_CHAIN(X) SCM_CELL_OBJECT_3 (X) +#define SCM_SET_STRUCT_GC_CHAIN(X, Y) SCM_SET_CELL_OBJECT_3 (X, Y) +extern SCM scm_structs_to_free; + extern scm_bits_t * scm_alloc_struct (int n_words, int n_extra, char * who); @@ -118,6 +122,7 @@ extern SCM scm_struct_create_handle (SCM obj); extern SCM scm_struct_vtable_name (SCM vtable); extern SCM scm_set_struct_vtable_name_x (SCM vtable, SCM name); extern void scm_print_struct (SCM exp, SCM port, scm_print_state *); +extern void scm_struct_prehistory (void); extern void scm_init_struct (void); #endif /* STRUCTH */ From 1a2f1b902351172438ea8eff4cdc3b78e30a231f Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 9 Aug 2000 18:29:48 +0000 Subject: [PATCH 0099/2047] *** empty log message *** --- libguile/ChangeLog | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 318b5f0b4..80af0711a 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,26 @@ +2000-08-09 Mikael Djurfeldt + + The following changes are intended to ensure that struct instances + are freed before their vtables. It's optimized for the most + common case, which is freeing of struct instances. + + * gc.c (scm_gc_mark, scm_gc_sweep): Remove vcell = 1 magic. + (scm_structs_to_free): New variable. + (scm_gc_sweep): Hook up structs to free on the scm_structs_to_free + chain. + + * struct.h (SCM_STRUCT_GC_CHAIN, SCM_SET_STRUCT_GC_CHAIN): New + macros. + (scm_structs_to_free, scm_struct_prehistory): Declare. + + * struct.c (scm_make_struct, scm_make_vtable_vtable): Structs + handles are now double cells; Initialize SCM_STRUCT_GC_CHAIN to + 0. + (scm_struct_gc_init, scm_free_structs): New GC C hooks. + (scm_struct_prehistory): Install them. + + * init.c (scm_boot_guile_1): Call scm_struct_prehistory. + 2000-08-06 Marius Vollmer * read.c (scm_flush_ws): Include filename in error message when it From be33b1a39c98a8f4e143f597eb5fc36a7773826d Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 11 Aug 2000 00:44:36 +0000 Subject: [PATCH 0100/2047] * receive.scm, srfi-8.scm: New files. --- ice-9/receive.scm | 29 +++++++++++++++++++++++++++++ ice-9/srfi-8.scm | 0 2 files changed, 29 insertions(+) create mode 100644 ice-9/receive.scm create mode 100644 ice-9/srfi-8.scm diff --git a/ice-9/receive.scm b/ice-9/receive.scm new file mode 100644 index 000000000..148db2821 --- /dev/null +++ b/ice-9/receive.scm @@ -0,0 +1,29 @@ +;;;; SRFI-8 + +;;; Copyright (C) 2000 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;; Boston, MA 02111-1307 USA + +(define-module (ice-9 receive) + :export (receive) + :no-backtrace + ) + +(define receive + (procedure->memoizing-macro + (lambda (exp env) + `(call-with-values (lambda () ,(caddr exp)) + (lambda ,(cadr exp) ,@(cdddr exp)))))) diff --git a/ice-9/srfi-8.scm b/ice-9/srfi-8.scm new file mode 100644 index 000000000..e69de29bb From 44484f52b3c63e4485b23cd7ecf6c1d0276ce276 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 11 Aug 2000 00:44:49 +0000 Subject: [PATCH 0101/2047] * boot-9.scm (scm-style-repl): Print multiple values on successive lines. * boot-9.scm (process-define-module): Bugfix: Make sure that exports are done *after* all used interfaces has been added. --- ice-9/boot-9.scm | 69 ++++++++++++++++++++++++++++-------------------- 1 file changed, 41 insertions(+), 28 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 3735c7948..a6615b4da 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -497,6 +497,11 @@ (make-record-type "values" '(values))) +;;; These two are needed internally in boot-9.scm. +;;; They shouldn't be visible outside this module. +(define values? (record-predicate *values-rtd*)) +(define get-values (record-accessor *values-rtd* 'values)) + (define values (let ((make-values (record-constructor *values-rtd*))) (lambda x @@ -506,13 +511,11 @@ (make-values x))))) (define call-with-values - (let ((access-values (record-accessor *values-rtd* 'values)) - (values-predicate? (record-predicate *values-rtd*))) - (lambda (producer consumer) - (let ((result (producer))) - (if (values-predicate? result) - (apply consumer (access-values result)) - (consumer result)))))) + (lambda (producer consumer) + (let ((result (producer))) + (if (values? result) + (apply consumer (get-values result)) + (consumer result))))) (provide 'values) @@ -1780,11 +1783,14 @@ (kws (cdr args))) (beautify-user-module! module) (let loop ((kws kws) - (reversed-interfaces '())) + (reversed-interfaces '()) + (exports '())) (if (null? kws) - (for-each (lambda (interface) - (module-use! module interface)) - reversed-interfaces) + (begin + (for-each (lambda (interface) + (module-use! module interface)) + reversed-interfaces) + (module-export! module exports)) (let ((keyword (cond ((keyword? (car kws)) (keyword->symbol (car kws))) ((and (symbol? (car kws)) @@ -1814,7 +1820,8 @@ (module-ref interface (car (last-pair used-name)) #f))) (loop (cddr kws) - (cons interface reversed-interfaces))))) + (cons interface reversed-interfaces) + exports)))) ((autoload) (if (not (and (pair? (cdr kws)) (pair? (cddr kws)))) (error "unrecognized defmodule argument" kws)) @@ -1822,18 +1829,20 @@ (cons (make-autoload-interface module (cadr kws) (caddr kws)) - reversed-interfaces))) + reversed-interfaces) + exports)) ((no-backtrace) (set-system-module! module #t) - (loop (cdr kws) reversed-interfaces)) + (loop (cdr kws) reversed-interfaces exports)) ((pure) (purify-module! module) - (loop (cdr kws) reversed-interfaces)) + (loop (cdr kws) reversed-interfaces exports)) ((export) (if (not (pair? (cdr kws))) (error "unrecognized defmodule argument" kws)) - (module-export! module (cadr kws)) - (loop (cddr kws) reversed-interfaces)) + (loop (cddr kws) + reversed-interfaces + (append (cadr kws) exports))) (else (error "unrecognized defmodule argument" kws)))))) module)) @@ -2546,17 +2555,21 @@ (repl-report-start-timing) (start-stack 'repl-stack (eval sourc)))) - (-print (lambda (result) - (if (not scm-repl-silent) - (begin - (if (or scm-repl-print-unspecified - (not (unspecified? result))) - (begin - (write result) - (newline))) - (if scm-repl-verbose - (repl-report)) - (force-output))))) + (-print (let ((maybe-print (lambda (result) + (if (or scm-repl-print-unspecified + (not (unspecified? result))) + (begin + (write result) + (newline)))))) + (lambda (result) + (if (not scm-repl-silent) + (begin + (if (values? result) + (for-each maybe-print (get-values result)) + (maybe-print result)) + (if scm-repl-verbose + (repl-report)) + (force-output)))))) (-quit (lambda (args) (if scm-repl-verbose From 528d8ce9915dea96d1ae40b94fbfbbe1b350e2ce Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 11 Aug 2000 00:45:09 +0000 Subject: [PATCH 0102/2047] * Makefile.am (ice9_sources): Added receive.scm, srfi-8.scm. --- ice-9/Makefile.am | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index 0c57fd7cb..0cff73751 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -22,13 +22,14 @@ AUTOMAKE_OPTIONS = foreign # These should be installed and distributed. -ice9_sources = \ - and-let*.scm arrays.scm boot-9.scm calling.scm common-list.scm \ - debug.scm debugger.scm documentation.scm emacs.scm expect.scm \ - format.scm getopt-long.scm hcons.scm lineio.scm ls.scm \ - mapping.scm networking.scm null.scm optargs.scm poe.scm popen.scm \ - posix.scm psyntax.pp psyntax.ss q.scm r4rs.scm r5rs.scm \ - regex.scm runq.scm safe-r5rs.scm safe.scm session.scm slib.scm \ +ice9_sources = \ + and-let*.scm arrays.scm boot-9.scm calling.scm common-list.scm \ + debug.scm debugger.scm documentation.scm emacs.scm expect.scm \ + format.scm getopt-long.scm hcons.scm lineio.scm ls.scm \ + mapping.scm networking.scm null.scm optargs.scm poe.scm popen.scm \ + posix.scm psyntax.pp psyntax.ss q.scm r4rs.scm r5rs.scm \ + receive.scm srfi-8.scm \ + regex.scm runq.scm safe-r5rs.scm safe.scm session.scm slib.scm \ streams.scm string-fun.scm syncase.scm tags.scm threads.scm subpkgdatadir = $(pkgdatadir)/$(VERSION)/ice-9 From cc6f0237bdb6aa8f4a245e0466fcfd7b0420e24d Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 11 Aug 2000 00:45:25 +0000 Subject: [PATCH 0103/2047] * print.c (scm_simple_format): Be case-insensitive for ~A and ~S directives. --- libguile/print.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/print.c b/libguile/print.c index 7bebd6557..225a81bcd 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -988,9 +988,9 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, continue; ++p; - if (*p == 'A') + if (*p == 'A' || *p == 'a') writingp = 0; - else if (*p == 'S') + else if (*p == 'S' || *p == 's') writingp = 1; else continue; From 1807c7b87559ae5d09946a790b6958e7299f5585 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 11 Aug 2000 00:45:33 +0000 Subject: [PATCH 0104/2047] *** empty log message *** --- ice-9/ChangeLog | 11 +++++++++++ libguile/ChangeLog | 5 +++++ 2 files changed, 16 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index c3f575e3a..5081aaf4e 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,14 @@ +2000-08-10 Mikael Djurfeldt + + * Makefile.am (ice9_sources): Added receive.scm, srfi-8.scm. + + * receive.scm, srfi-8.scm: New files. + + * boot-9.scm (scm-style-repl): Print multiple values on successive + lines. + (process-define-module): Bugfix: Make sure that exports are done + *after* all used interfaces has been added. + 2000-07-24 Marius Vollmer * common-list.scm (uniq): Made tail-recursive. Thanks to thi! diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 80af0711a..2baf2b167 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-08-10 Mikael Djurfeldt + + * print.c (scm_simple_format): Be case-insensitive for ~A and ~S + directives. + 2000-08-09 Mikael Djurfeldt The following changes are intended to ensure that struct instances From 82b3290db7b8720f53a8b0ffb473c6c9861ecdc6 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 11 Aug 2000 08:42:42 +0000 Subject: [PATCH 0105/2047] * debug.c (scm_local_eval): Use scm_i_eval and scm_i_eval_x. (scm_start_stack): Use scm_i_eval. --- libguile/debug.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/libguile/debug.c b/libguile/debug.c index 0473cacab..72e7c2d53 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -486,10 +486,10 @@ SCM_DEFINE (scm_local_eval, "local-eval", 1, 1, 0, { if (SCM_UNBNDP (env)) { - SCM_VALIDATE_MEMOIZED (1,exp); - return scm_eval_3 (SCM_MEMOIZED_EXP (exp), 0, SCM_MEMOIZED_ENV (exp)); + SCM_VALIDATE_MEMOIZED (1, exp); + return scm_i_eval_x (SCM_MEMOIZED_EXP (exp), SCM_MEMOIZED_ENV (exp)); } - return scm_eval_3 (exp, 1, env); + return scm_i_eval (exp, env); } #undef FUNC_NAME @@ -530,7 +530,7 @@ scm_start_stack (SCM id, SCM exp, SCM env) vframe.vect = &vframe_vect_body; vframe.vect[0].id = id; scm_last_debug_frame = &vframe; - answer = scm_eval_3 (exp, 1, env); + answer = scm_i_eval (exp, env); scm_last_debug_frame = vframe.prev; return answer; } From 68d8be66ce259ca1a397f9c9055b0df14ea5a48f Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 11 Aug 2000 08:42:50 +0000 Subject: [PATCH 0106/2047] * eval.c (scm_eval): Backward incompatible change: Now takes an environment specifier as second arg. `eval' hereby becomes R5RS compatible. (scm_i_eval_x, scm_i_eval): New functions (replace scm_eval_3). (scm_eval2, scm_eval_3): Deprecated. (scm_top_level_lookup_closure_var): Deprecated. --- libguile/eval.c | 100 ++++++++++++++++++++++++++++++++---------------- 1 file changed, 67 insertions(+), 33 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index 40a8f8bf7..cca70f44d 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3822,15 +3822,73 @@ SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0, #undef FUNC_NAME +SCM scm_system_transformer; + SCM -scm_eval_3 (SCM obj, int copyp, SCM env) +scm_i_eval_x (SCM exp, SCM env) { SCM transformer = scm_fluid_ref (SCM_CDR (scm_system_transformer)); if (SCM_NIMP (transformer)) - obj = scm_apply (transformer, obj, scm_listofnull); - else if (copyp) - obj = scm_copy_tree (obj); - return SCM_XEVAL (obj, env); + exp = scm_apply (transformer, exp, scm_listofnull); + return SCM_XEVAL (exp, env); +} + +SCM +scm_i_eval (SCM exp, SCM env) +{ + SCM transformer = scm_fluid_ref (SCM_CDR (scm_system_transformer)); + if (SCM_NIMP (transformer)) + exp = scm_apply (transformer, exp, scm_listofnull); + return SCM_XEVAL (scm_copy_tree (exp), env); +} + +SCM +scm_eval_x (SCM exp, SCM module) +{ + return scm_i_eval_x (exp, + scm_top_level_env (SCM_MODULE_EVAL_CLOSURE (module))); +} + +/* Eval does not take the second arg optionally. This is intentional + * in order to be R5RS compatible, and to prepare for the new module + * system, where we would like to make the choice of evaluation + * environment explicit. + */ + +SCM_DEFINE (scm_eval, "eval", 2, 0, 0, + (SCM exp, SCM environment), + "Evaluate @var{exp}, a list representing a Scheme expression, in the\n" + "environment given by @var{environment specifier}.") +#define FUNC_NAME s_scm_eval +{ + SCM_VALIDATE_MODULE (2, environment); + return scm_i_eval (scm_copy_tree (exp), + scm_top_level_env (SCM_MODULE_EVAL_CLOSURE (environment))); +} +#undef FUNC_NAME + +#if (SCM_DEBUG_DEPRECATED == 0) + +/* Use scm_selected_module () or scm_interaction_environment () + * instead. The former is the module selected during loading of code. + * The latter is the module in which the user of this thread currently + * types expressions. + */ + +SCM scm_top_level_lookup_closure_var; + +/* Avoid using this functionality altogether (except for implementing + * libguile, where you can use scm_i_eval or scm_i_eval_x). + * + * Applications should use either C level scm_eval_x or Scheme scm_eval. */ + +SCM +scm_eval_3 (SCM obj, int copyp, SCM env) +{ + if (copyp) + return scm_i_eval (obj, env); + else + return scm_i_eval_x (obj, env); } SCM_DEFINE (scm_eval2, "eval2", 2, 0, 0, @@ -3840,36 +3898,11 @@ SCM_DEFINE (scm_eval2, "eval2", 2, 0, 0, "equivalent to @code{(eval2 exp *top-level-lookup-closure*)}.") #define FUNC_NAME s_scm_eval2 { - return scm_eval_3 (obj, 1, scm_top_level_env (env_thunk)); + return scm_i_eval (obj, scm_top_level_env (env_thunk)); } #undef FUNC_NAME -SCM scm_system_transformer; -SCM scm_top_level_lookup_closure_var; - -SCM_DEFINE (scm_eval, "eval", 1, 0, 0, - (SCM obj), - "Evaluate @var{exp}, a list representing a Scheme expression, in the\n" - "top-level environment.") -#define FUNC_NAME s_scm_eval -{ - return scm_eval_3 (obj, - 1, - scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE)); -} -#undef FUNC_NAME - -/* -SCM_REGISTER_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x); -*/ - -SCM -scm_eval_x (SCM obj) -{ - return scm_eval_3 (obj, - 0, - scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE)); -} +#endif /* DEPRECATED */ /* At this point, scm_deval and scm_dapply are generated. @@ -3915,9 +3948,10 @@ scm_init_eval () /* acros */ /* end of acros */ +#if SCM_DEBUG_DEPRECATED == 0 scm_top_level_lookup_closure_var = scm_sysintern ("*top-level-lookup-closure*", scm_make_fluid ()); - scm_can_use_top_level_lookup_closure_var = 1; +#endif #ifdef DEBUG_EXTENSIONS scm_sym_enter_frame = SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED)); From 37607b5a7b0391596c120c9786ea75c4d894b815 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 11 Aug 2000 08:43:00 +0000 Subject: [PATCH 0107/2047] * eval.h: #include "struct.h". --- libguile/eval.h | 22 ++++++++++++++++++---- 1 file changed, 18 insertions(+), 4 deletions(-) diff --git a/libguile/eval.h b/libguile/eval.h index 4fa1e6d7a..7ae614993 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -46,6 +46,10 @@ #include "libguile/__scm.h" +/* Needed by SCM_TOP_LEVEL_LOOKUP_CLOSURE below. */ + +#include "struct.h" + /* {Options} @@ -118,11 +122,17 @@ extern SCM scm_eval_options_interface (SCM setting); #define SCM_EXTEND_ENV scm_acons +/*fixme* This should probably be removed throught the code. */ -#define SCM_TOP_LEVEL_LOOKUP_CLOSURE scm_fluid_ref (SCM_CDR (scm_top_level_lookup_closure_var)) +#define SCM_TOP_LEVEL_LOOKUP_CLOSURE \ + SCM_MODULE_EVAL_CLOSURE (scm_selected_module ()) + +#if SCM_DEBUG_DEPRECATED == 0 + +extern SCM scm_top_level_lookup_closure_var; +#endif extern SCM scm_system_transformer; -extern SCM scm_top_level_lookup_closure_var; extern const char scm_s_expression[]; @@ -227,10 +237,14 @@ extern SCM scm_force (SCM x); extern SCM scm_promise_p (SCM x); extern SCM scm_cons_source (SCM xorig, SCM x, SCM y); extern SCM scm_copy_tree (SCM obj); +#if SCM_DEBUG_DEPRECATED == 0 extern SCM scm_eval_3 (SCM obj, int copyp, SCM env); extern SCM scm_eval2 (SCM obj, SCM env_thunk); -extern SCM scm_eval (SCM obj); -extern SCM scm_eval_x (SCM obj); +#endif +extern SCM scm_i_eval_x (SCM obj, SCM env); +extern SCM scm_i_eval (SCM obj, SCM env); +extern SCM scm_eval (SCM obj, SCM environment); +extern SCM scm_eval_x (SCM obj, SCM environment); extern void scm_init_eval (void); #endif /* EVALH */ From 238d517c09f3cc4120568f6fb980fbd9fa88ab77 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 11 Aug 2000 08:43:08 +0000 Subject: [PATCH 0108/2047] * evalext.c (scm_definedp): Have to work before module system is booted. --- libguile/evalext.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/libguile/evalext.c b/libguile/evalext.c index 843897c57..f358bca99 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -79,7 +79,9 @@ SCM_DEFINE (scm_definedp, "defined?", 1, 1, 0, if (SCM_UNBNDP (env)) vcell = scm_sym2vcell(sym, - SCM_TOP_LEVEL_LOOKUP_CLOSURE, + scm_module_system_booted_p + ? SCM_TOP_LEVEL_LOOKUP_CLOSURE + : SCM_EOL, SCM_BOOL_F); else { From f33b174d0e9b310bf97d6608603b72eb587952ea Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 11 Aug 2000 08:43:49 +0000 Subject: [PATCH 0109/2047] * load.c (load): Use `scm_selected_module' to compute second arg to new scm_i_eval_x; Don't call it if module system hasn't booted. (scm_read_and_eval_x): Deprecated. #include "modules.h". --- libguile/load.c | 20 +++++++++++++++----- 1 file changed, 15 insertions(+), 5 deletions(-) diff --git a/libguile/load.c b/libguile/load.c index af640e31f..06eacbd8f 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -55,6 +55,7 @@ #include "libguile/dynwind.h" #include "libguile/root.h" #include "libguile/strings.h" +#include "libguile/modules.h" #include "libguile/validate.h" #include "libguile/load.h" @@ -94,7 +95,14 @@ load (void *data) SCM form = scm_read (port); if (SCM_EOF_OBJECT_P (form)) break; - scm_eval_x (form); + /* Ugh! We need to re-check the environment for every form. + * We should change this in the new module system. + */ + scm_i_eval_x (form, + scm_module_system_booted_p + ? (scm_top_level_env + (SCM_MODULE_EVAL_CLOSURE (scm_selected_module ()))) + : SCM_EOL); } return SCM_UNSPECIFIED; } @@ -451,9 +459,9 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0, } #undef FUNC_NAME -/* The following function seems trivial - and indeed it is. Its - * existence is motivated by its ability to evaluate expressions - * without copying them first (as is done in "eval"). +#if SCM_DEBUG_DEPRECATED == 0 + +/* Eval now copies source properties, so this function is no longer required. */ SCM_SYMBOL (scm_end_of_file_key, "end-of-file"); @@ -469,10 +477,12 @@ SCM_DEFINE (scm_read_and_eval_x, "read-and-eval!", 0, 1, 0, SCM form = scm_read (port); if (SCM_EOF_OBJECT_P (form)) scm_ithrow (scm_end_of_file_key, SCM_EOL, 1); - return scm_eval_x (form); + return scm_eval_x (form, scm_selected_module ()); } #undef FUNC_NAME +#endif + /* Information about the build environment. */ From e3365c07da4368e533584d7d3103a8042a5fea32 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 11 Aug 2000 08:44:02 +0000 Subject: [PATCH 0110/2047] * modules.c (scm_module_tag, scm_module_system_booted_p): New globals. (scm_post_boot_init_modules): Initialize scm_module_tag. (scm_interaction_environment): New primitive. --- libguile/modules.c | 45 ++++++++++++++++++++++++++++++--------------- 1 file changed, 30 insertions(+), 15 deletions(-) diff --git a/libguile/modules.c b/libguile/modules.c index ad016582a..a59aec6a9 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -56,6 +56,10 @@ #include "libguile/modules.h" +SCM scm_module_system_booted_p = 0; + +SCM scm_module_tag; + static SCM the_root_module; static SCM root_module_lookup_closure; @@ -75,6 +79,11 @@ scm_selected_module () static SCM set_current_module; +/* This is the module selected during loading of code. Currently, + * this is the same as (interaction-environment), but need not be in + * the future. + */ + SCM scm_select_module (SCM module) { @@ -83,6 +92,19 @@ scm_select_module (SCM module) return old; } +SCM_DEFINE (scm_interaction_environment, "interaction-environment", 0, 0, 0, + (), + "This procedure returns a specifier for the environment that" + "contains implementation-defined bindings, typically a superset of" + "those listed in the report. The intent is that this procedure" + "will return the environment in which the implementation would" + "evaluate expressions dynamically typed by the user.") +#define FUNC_NAME s_scm_interaction_environment +{ + return scm_selected_module (); +} +#undef FUNC_NAME + SCM_SYMBOL (scm_sym_app, "app"); SCM_SYMBOL (scm_sym_modules, "modules"); static SCM module_prefix; @@ -115,14 +137,10 @@ scm_ensure_user_module (SCM module) return SCM_UNSPECIFIED; } -static SCM module_eval_closure; - SCM scm_module_lookup_closure (SCM module) { - return scm_apply (SCM_CDR (module_eval_closure), - SCM_LIST1 (module), - SCM_EOL); + return SCM_MODULE_EVAL_CLOSURE (module); } static SCM resolve_module; @@ -141,8 +159,7 @@ scm_load_scheme_module (SCM name) return scm_apply (SCM_CDR (try_module_autoload), SCM_LIST1 (name), SCM_EOL); } -/* Environments - */ +/* Environments */ SCM scm_top_level_env (SCM thunk) @@ -188,21 +205,17 @@ scm_system_module_env_p (SCM env) * The code will be replaced by the low-level environments in next release. */ -#define OBARRAY(module) (SCM_PACK (SCM_STRUCT_DATA (module) [0])) -#define USES(module) (SCM_PACK (SCM_STRUCT_DATA (module) [1])) -#define BINDER(module) (SCM_PACK (SCM_STRUCT_DATA (module) [2])) - static SCM module_make_local_var_x; static SCM module_variable (SCM module, SCM sym) { /* 1. Check module obarray */ - SCM b = scm_hashq_ref (OBARRAY (module), sym, SCM_UNDEFINED); + SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED); if (SCM_VARIABLEP (b)) return b; { - SCM binder = BINDER (module); + SCM binder = SCM_MODULE_BINDER (module); if (SCM_NFALSEP (binder)) /* 2. Custom binder */ { @@ -215,7 +228,7 @@ module_variable (SCM module, SCM sym) } { /* 3. Search the use list */ - SCM uses = USES (module); + SCM uses = SCM_MODULE_USES (module); while (SCM_CONSP (uses)) { b = module_variable (SCM_CAR (uses), sym); @@ -267,6 +280,8 @@ scm_init_modules () void scm_post_boot_init_modules () { + scm_module_tag = (SCM_CELL_WORD_1 (SCM_CDR (scm_intern0 ("module-type"))) + + scm_tc3_cons_gloc); the_root_module = scm_intern0 ("the-root-module"); the_module = scm_intern0 ("the-module"); set_current_module = scm_intern0 ("set-current-module"); @@ -274,11 +289,11 @@ scm_post_boot_init_modules () scm_sym_modules)); make_modules_in = scm_intern0 ("make-modules-in"); beautify_user_module_x = scm_intern0 ("beautify-user-module!"); - module_eval_closure = scm_intern0 ("module-eval-closure"); root_module_lookup_closure = scm_permanent_object (scm_module_lookup_closure (SCM_CDR (the_root_module))); resolve_module = scm_intern0 ("resolve-module"); try_module_autoload = scm_intern0 ("try-module-autoload"); + scm_module_system_booted_p = 1; } /* From b486ccc869a9c12df574a93f1c40726333383bcb Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 11 Aug 2000 08:44:16 +0000 Subject: [PATCH 0111/2047] * modules.h (SCM_MODULEP, SCM_VALIDATE_MODULE, SCM_MODULE_OBARRAY, SCM_MODULE_USES, SCM_MODULE_BINDER, SCM_MODULE_EVAL_CLOSURE): New macros. (scm_module_index_obarray, scm_module_index_uses, scm_module_index_binder, scm_module_index_eval_closure): New constants; #include "validate.h". --- libguile/modules.h | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/libguile/modules.h b/libguile/modules.h index 9ed8d49d7..9e7f8eb11 100644 --- a/libguile/modules.h +++ b/libguile/modules.h @@ -46,10 +46,41 @@ #include "libguile/__scm.h" +#include "libguile/validate.h" + +#define SCM_MODULEP(OBJ) \ + (SCM_NIMP (OBJ) && SCM_CELL_TYPE (OBJ) == scm_module_tag) + +#define SCM_VALIDATE_MODULE(pos, scm) SCM_MAKE_VALIDATE (pos, scm, MODULEP) + +/* NOTE: Indexes of module fields are dependent upon the definition of + * module-type in boot-9.scm. + */ + +#define scm_module_index_obarray 0 +#define scm_module_index_uses 1 +#define scm_module_index_binder 2 +#define scm_module_index_eval_closure 3 + +#define SCM_MODULE_OBARRAY(module) \ + SCM_PACK (SCM_STRUCT_DATA (module) [scm_module_index_obarray]) +#define SCM_MODULE_USES(module) \ + SCM_PACK (SCM_STRUCT_DATA (module) [scm_module_index_uses]) +#define SCM_MODULE_BINDER(module) \ + SCM_PACK (SCM_STRUCT_DATA (module) [scm_module_index_binder]) +#define SCM_MODULE_EVAL_CLOSURE(module) \ + SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_eval_closure]) + + + +extern SCM scm_module_system_booted_p; +extern SCM scm_module_tag; + extern SCM scm_the_root_module (void); extern SCM scm_selected_module (void); +extern SCM scm_interaction_environment (void); extern SCM scm_select_module (SCM module); extern SCM scm_make_module (SCM name); extern SCM scm_ensure_user_module (SCM name); From b3138544efa48dfdf2bffc36415a4ac428afb13f Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 11 Aug 2000 08:44:32 +0000 Subject: [PATCH 0112/2047] * script.c (scm_shell): Pass scm_the_root_module () as second arg to new scm_eval_x. --- libguile/script.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/script.c b/libguile/script.c index 6e225f6e8..e24c89f51 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -644,7 +644,8 @@ scm_shell (int argc, char **argv) } } - exit (scm_exit_status (scm_eval_x (scm_compile_shell_switches (argc,argv)))); + exit (scm_exit_status (scm_eval_x (scm_compile_shell_switches (argc, argv), + scm_the_root_module ()))); } From 07bcf91d63f1f1d1bf3754eebafc5be85264387f Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 11 Aug 2000 08:44:43 +0000 Subject: [PATCH 0113/2047] * strports.c (scm_eval_string): Evaluate in scm_interaction_environment (). * strports.c: #include "modules.h". --- libguile/strports.c | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/libguile/strports.c b/libguile/strports.c index 07dcdd7ee..779c10046 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -58,6 +58,7 @@ #include "libguile/root.h" #include "libguile/strings.h" #include "libguile/vectors.h" +#include "libguile/modules.h" #include "libguile/strports.h" @@ -387,17 +388,19 @@ scm_eval_0str (const char *expr) SCM_DEFINE (scm_eval_string, "eval-string", 1, 0, 0, (SCM string), "Evaluate @var{string} as the text representation of a Scheme form\n" - "or forms, and return whatever value they produce.") + "or forms, and return whatever value they produce." + "Evaluation takes place in (interaction-environment).") #define FUNC_NAME s_scm_eval_string { SCM port = scm_mkstrport (SCM_INUM0, string, SCM_OPN | SCM_RDNG, "scm_eval_0str"); SCM form; SCM ans = SCM_UNSPECIFIED; + SCM module = scm_interaction_environment (); /* Read expressions from that port; ignore the values. */ while (!SCM_EOF_OBJECT_P (form = scm_read (port))) - ans = scm_eval_x (form); + ans = scm_eval_x (form, module); /* Don't close the port here; if we re-enter this function via a continuation, then the next time we enter it, we'll get an error. From eb8db440595fb6c71e8a8aec080b900906a641e4 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 11 Aug 2000 08:44:51 +0000 Subject: [PATCH 0114/2047] * symbols.c (scm_can_use_top_level_lookup_closure_var): Removed. #include "modules.h". --- libguile/symbols.c | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/libguile/symbols.c b/libguile/symbols.c index 1c56a6e10..49e63aadc 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -54,6 +54,7 @@ #include "libguile/strings.h" #include "libguile/vectors.h" #include "libguile/weaks.h" +#include "libguile/modules.h" #include "libguile/validate.h" #include "libguile/symbols.h" @@ -376,11 +377,6 @@ scm_sysintern0_no_module_lookup (const char *name) } } - -/* Is it safe to access SCM_TOP_LEVEL_LOOKUP_CLOSURE_VAR? - */ -int scm_can_use_top_level_lookup_closure_var; - /* Intern the symbol named NAME in scm_symhash, and give it the value VAL. NAME is null-terminated. Use the current top_level lookup closure to give NAME its value. @@ -397,8 +393,8 @@ SCM scm_sysintern0 (const char *name) { SCM lookup_proc; - if (scm_can_use_top_level_lookup_closure_var && - SCM_NIMP (lookup_proc = SCM_TOP_LEVEL_LOOKUP_CLOSURE)) + if (scm_module_system_booted_p + && SCM_NIMP (lookup_proc = SCM_TOP_LEVEL_LOOKUP_CLOSURE)) { SCM sym = SCM_CAR (scm_intern0 (name)); SCM vcell = scm_sym2vcell (sym, lookup_proc, SCM_BOOL_T); From 26795895e26765ea83cd1b6ccd310e26218ea772 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 11 Aug 2000 08:45:19 +0000 Subject: [PATCH 0115/2047] Deprecated scm_top_level_lookup_closure_var --- libguile/init.c | 2 ++ libguile/symbols.h | 2 -- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/init.c b/libguile/init.c index ee8a060e3..c561adf3b 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -171,7 +171,9 @@ start_stack (void *base) scm_exitval = SCM_BOOL_F; /* vestigial */ +#if SCM_DEBUG_DEPRECATED == 0 scm_top_level_lookup_closure_var = SCM_BOOL_F; +#endif scm_system_transformer = SCM_BOOL_F; scm_root->fluids = scm_make_initial_fluids (); diff --git a/libguile/symbols.h b/libguile/symbols.h index c35572f73..05e8c2c96 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -147,8 +147,6 @@ extern SCM scm_builtin_weak_bindings (void); extern SCM scm_gensym (SCM name, SCM obarray); extern void scm_init_symbols (void); -extern int scm_can_use_top_level_lookup_closure_var; - #endif /* SYMBOLSH */ /* From d7faeb2ee94d79cdf641f5e9508a382bd901e228 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 11 Aug 2000 08:45:35 +0000 Subject: [PATCH 0116/2047] * boot-9.scm (record-constructor, record-accessor, record-modifier, scm-style-repl): Add second arg to eval. (read-hash-extend #\.): Ditto. (This is actually a bugfix!) (eval-in-module): Redefined to be eval and deprecated. --- ice-9/boot-9.scm | 68 ++++++++++++++++++++++++++++-------------------- 1 file changed, 40 insertions(+), 28 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index a6615b4da..3889fa8b6 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -329,6 +329,21 @@ (define (struct-layout s) (struct-ref (struct-vtable s) vtable-index-layout)) + + +;;; Environments + +(define the-environment + (procedure->syntax + (lambda (x e) + e))) + +(define the-root-environment (the-environment)) + +(define (environment-module env) + (let ((closure (and (pair? env) (car (last-pair env))))) + (and closure (procedure-property closure 'module)))) + ;;; {Records} ;;; @@ -405,12 +420,13 @@ (define (record-constructor rtd . opt) (let ((field-names (if (pair? opt) (car opt) (record-type-fields rtd)))) - (eval `(lambda ,field-names - (make-struct ',rtd 0 ,@(map (lambda (f) - (if (memq f field-names) - f - #f)) - (record-type-fields rtd))))))) + (local-eval `(lambda ,field-names + (make-struct ',rtd 0 ,@(map (lambda (f) + (if (memq f field-names) + f + #f)) + (record-type-fields rtd)))) + the-root-environment))) (define (record-predicate rtd) (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj))))) @@ -419,17 +435,19 @@ (let* ((pos (list-index (record-type-fields rtd) field-name))) (if (not pos) (error 'no-such-field field-name)) - (eval `(lambda (obj) - (and (eq? ',rtd (record-type-descriptor obj)) - (struct-ref obj ,pos)))))) + (local-eval `(lambda (obj) + (and (eq? ',rtd (record-type-descriptor obj)) + (struct-ref obj ,pos))) + the-root-environment))) (define (record-modifier rtd field-name) (let* ((pos (list-index (record-type-fields rtd) field-name))) (if (not pos) (error 'no-such-field field-name)) - (eval `(lambda (obj val) - (and (eq? ',rtd (record-type-descriptor obj)) - (struct-set! obj ,pos val)))))) + (local-eval `(lambda (obj val) + (and (eq? ',rtd (record-type-descriptor obj)) + (struct-set! obj ,pos val))) + the-root-environment))) (define (record? obj) @@ -883,7 +901,7 @@ (read-hash-extend #\' (lambda (c port) (read port))) (read-hash-extend #\. (lambda (c port) - (eval (read port)))) + (eval (read port) (interaction-environment)))) ;;; {Command Line Options} @@ -1067,6 +1085,8 @@ ;; is a (CLOSURE module symbol) which, as a last resort, can provide ;; bindings that would otherwise not be found locally in the module. ;; +;; NOTE: If you change here, you also need to change libguile/modules.h. +;; (define module-type (make-record-type 'module '(obarray uses binder eval-closure transformer name kind @@ -1148,8 +1168,9 @@ ;; to maximally one module. (set-procedure-property! closure 'module module)))) -(define (eval-in-module exp module) - (eval2 exp (module-eval-closure module))) +;;; This procedure is depreated +;;; +(define eval-in-module eval) ;;; {Observer protocol} @@ -1502,6 +1523,7 @@ (fluid-set! the-module m) (if m (begin + ;; *top-level-lookup-closure* is now deprecated (fluid-set! *top-level-lookup-closure* (module-eval-closure (fluid-ref the-module))) (fluid-set! scm:eval-transformer (module-transformer (fluid-ref the-module)))) @@ -2553,7 +2575,8 @@ (-eval (lambda (sourc) (repl-report-start-timing) - (start-stack 'repl-stack (eval sourc)))) + (start-stack 'repl-stack + (eval sourc (interaction-environment))))) (-print (let ((maybe-print (lambda (result) (if (or scm-repl-print-unspecified @@ -2637,17 +2660,6 @@ `(with-fluids* (list ,@(map car bindings)) (list ,@(map cadr bindings)) (lambda () ,@body))) -;;; Environments - -(define the-environment - (procedure->syntax - (lambda (x e) - e))) - -(define (environment-module env) - (let ((closure (and (pair? env) (car (last-pair env))))) - (and closure (procedure-property closure 'module)))) - ;;; {Macros} @@ -2737,7 +2749,7 @@ ;; suggests we use eval here to accomodate Hobbit; it lets ;; the interpreter handle the define-private form, which ;; Hobbit can't digest. - (eval '(define-private ,@ args))))))) + (eval '(define-private ,@ args) (interaction-environment))))))) From a71aca7af92e6c2f5d83f32c2eec6fb5ede3aaa7 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 11 Aug 2000 08:45:45 +0000 Subject: [PATCH 0117/2047] * emacs.scm (emacs-eval-request): (emacs-symdoc): (This procedure needs updating!) --- ice-9/emacs.scm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/ice-9/emacs.scm b/ice-9/emacs.scm index d7669916c..535e59ab6 100644 --- a/ice-9/emacs.scm +++ b/ice-9/emacs.scm @@ -1,4 +1,4 @@ -;;;; Copyright (C) 1996, 1997, 1998, 1999 Free Software Foundation, Inc. +;;;; Copyright (C) 1996, 1997, 1998, 1999, 2000 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 @@ -170,7 +170,7 @@ (apply throw key args)))))) (define (emacs-eval-request form) - (result-to-emacs (eval form))) + (result-to-emacs (eval form (interaction-environment)))) ;;*fixme* Not necessary to use flags no-stack and no-source (define (get-frame-source frame) @@ -248,9 +248,9 @@ (define (emacs-symdoc symbol) (if (or (not (module-bound? (current-module) symbol)) - (not (procedure? (eval symbol)))) + (not (procedure? (eval symbol) (interaction-environment)))) 'nil - (procedure-documentation (eval symbol)))) + (procedure-documentation (eval symbol (interaction-environment))))) ;;; A fix to get the emacs interface to work together with the module system. ;;; From 12eed809ef30439311dec07143bd947a96fbd0f1 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 11 Aug 2000 08:45:53 +0000 Subject: [PATCH 0118/2047] * safe-r5rs.scm (eval): Removed definition. --- ice-9/safe-r5rs.scm | 2 -- 1 file changed, 2 deletions(-) diff --git a/ice-9/safe-r5rs.scm b/ice-9/safe-r5rs.scm index f5bf800d5..87d958687 100644 --- a/ice-9/safe-r5rs.scm +++ b/ice-9/safe-r5rs.scm @@ -129,8 +129,6 @@ ;;transcript-off ) -(define eval eval-in-module) - (define null-interface (make-module 31)) (set-module-kind! null-interface 'interface) From 21c2a33a19f9f518804191379b4fb3780105c1c1 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 11 Aug 2000 08:46:07 +0000 Subject: [PATCH 0119/2047] * slib.scm (slib:eval): Use eval instead of eval-in-module. (defmacro:eval): Eval in (interaction-environment). --- ice-9/slib.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ice-9/slib.scm b/ice-9/slib.scm index ba80f8535..2bb33df13 100644 --- a/ice-9/slib.scm +++ b/ice-9/slib.scm @@ -41,8 +41,8 @@ (define slib:exit quit) (define slib:error error) (define slib:warn warn) -(define slib:eval (lambda (x) (eval-in-module x slib-module))) -(define defmacro:eval eval) +(define slib:eval (lambda (x) (eval x slib-module))) +(define defmacro:eval (lambda (x) (eval x (interaction-environment)))) (define logical:logand logand) (define logical:logior logior) (define logical:logxor logxor) From 6232c3dd6911e3e64cb34e8d15673d7f336e2bee Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 11 Aug 2000 08:46:14 +0000 Subject: [PATCH 0120/2047] * syncase.scm (eval): Add second arg both in definition and use. --- ice-9/syncase.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/ice-9/syncase.scm b/ice-9/syncase.scm index bc124bafd..0ca94520e 100644 --- a/ice-9/syncase.scm +++ b/ice-9/syncase.scm @@ -1,4 +1,4 @@ -;;;; Copyright (C) 1997 Free Software Foundation, Inc. +;;;; Copyright (C) 1997, 2000 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 @@ -152,11 +152,12 @@ (define internal-eval (nested-ref the-scm-module '(app modules guile eval))) -(define-public (eval x) +(define-public (eval x environment) (internal-eval (if (and (pair? x) (string=? (car x) "noexpand")) (cadr x) - (sc-expand x)))) + (sc-expand x)) + environment)) ;;; Hack to make syncase macros work in the slib module (let ((m (nested-ref the-root-module '(app modules ice-9 slib)))) From 3a33a9b117031feabcfa273b451191a280e5e7d9 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 11 Aug 2000 08:46:32 +0000 Subject: [PATCH 0121/2047] *** empty log message *** --- RELEASE | 7 +++++++ ice-9/ChangeLog | 20 ++++++++++++++++++++ libguile/ChangeLog | 46 +++++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 72 insertions(+), 1 deletion(-) diff --git a/RELEASE b/RELEASE index 497e79b78..ebffd6d22 100644 --- a/RELEASE +++ b/RELEASE @@ -17,6 +17,13 @@ After signal handling and threading have been fixed: GUILE_OLD_ASYNC_CLICK macro. In release 1.5: +- remove deprecated variables: + scm_top_level_lookup_closure_var +- remove deprecated functions: + eval.c: scm_eval2, scm_eval_3 + load.c: scm_read_and_eval_x +- remove deprecated procedures: + boot-9.scm:eval-in-module - remove deprecated macros: SCM_INPORTP, SCM_OUTPORTP, SCM_CRDY, SCM_ICHRP, SCM_ICHR, SCM_MAKICHR, SCM_SETJMPBUF, SCM_NSTRINGP, SCM_NRWSTRINGP, SCM_NVECTORP diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 5081aaf4e..07e344beb 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,5 +1,25 @@ +2000-08-11 Mikael Djurfeldt + + * boot-9.scm (record-constructor, record-accessor, + record-modifier, scm-style-repl): Add second arg to eval. + (read-hash-extend #\.): Ditto. (This is actually a bugfix!) + (eval-in-module): Redefined to be eval and deprecated. + + * syncase.scm (eval): Add second arg both in definition and use. + + * slib.scm (slib:eval): Use eval instead of eval-in-module. + (defmacro:eval): Eval in (interaction-environment). + + * safe-r5rs.scm (eval): Removed definition. + + * emacs.scm (emacs-eval-request): + (emacs-symdoc): (This procedure needs updating!) + 2000-08-10 Mikael Djurfeldt + * boot-9.scm: Added note about dependency in modules.h to + definition of module-type. + * Makefile.am (ice9_sources): Added receive.scm, srfi-8.scm. * receive.scm, srfi-8.scm: New files. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 2baf2b167..9730873e1 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,4 +1,48 @@ -2000-08-10 Mikael Djurfeldt +2000-08-11 Mikael Djurfeldt + + * eval.c (scm_eval): Backward incompatible change: Now takes an + environment specifier as second arg. `eval' hereby becomes R5RS + compatible. + (scm_i_eval_x, scm_i_eval): New functions (replace + scm_eval_3). + (scm_eval2, scm_eval_3): Deprecated. + (scm_top_level_lookup_closure_var): Deprecated. + + * eval.h: #include "struct.h". + + * evalext.c (scm_definedp): Have to work before module system is + booted. + + * modules.h (SCM_MODULEP, SCM_VALIDATE_MODULE, + SCM_MODULE_OBARRAY, SCM_MODULE_USES, SCM_MODULE_BINDER, + SCM_MODULE_EVAL_CLOSURE): New macros. + (scm_module_index_obarray, scm_module_index_uses, + scm_module_index_binder, scm_module_index_eval_closure): New + constants; #include "validate.h". + + * modules.c (scm_module_tag, scm_module_system_booted_p): New + globals. + (scm_post_boot_init_modules): Initialize scm_module_tag. + (scm_interaction_environment): New primitive. + + * symbols.c (scm_can_use_top_level_lookup_closure_var): Removed. + #include "modules.h". + + * strports.c (scm_eval_string): Evaluate in + scm_interaction_environment (). + + * script.c (scm_shell): Pass scm_the_root_module () as second arg + to new scm_eval_x. + + * load.c (load): Use `scm_selected_module' to compute second arg + to new scm_i_eval_x; Don't call it if module system hasn't booted. + (scm_read_and_eval_x): Deprecated. + #include "modules.h". + + * debug.c (scm_local_eval): Use scm_i_eval and scm_i_eval_x. + (scm_start_stack): Use scm_i_eval. + + * strports.c: #include "modules.h". * print.c (scm_simple_format): Be case-insensitive for ~A and ~S directives. From 728ee71e19e00eaeb0f43f46fa56a46ee08f3551 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 11 Aug 2000 09:19:58 +0000 Subject: [PATCH 0122/2047] * r5rs.scm (interaction-environment): Removed definition. (Is now provided by libguile/modules.c.) --- ice-9/r5rs.scm | 5 ----- 1 file changed, 5 deletions(-) diff --git a/ice-9/r5rs.scm b/ice-9/r5rs.scm index a3d0d2f66..2236c59b3 100644 --- a/ice-9/r5rs.scm +++ b/ice-9/r5rs.scm @@ -44,8 +44,3 @@ (list n) '())) scheme-report-interface) - -(define interaction-interface (resolve-interface '(guile-user))) - -(define (interaction-environment) - interaction-interface) From c7c6b0cbc015f76770195853d869bc6cb2762a97 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 11 Aug 2000 09:20:06 +0000 Subject: [PATCH 0123/2047] * safe-r5rs.scm (null-environment): Bugfix: Should include syntactic bindings. --- ice-9/safe-r5rs.scm | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/ice-9/safe-r5rs.scm b/ice-9/safe-r5rs.scm index 87d958687..6de652cd1 100644 --- a/ice-9/safe-r5rs.scm +++ b/ice-9/safe-r5rs.scm @@ -20,7 +20,9 @@ (define-module (ice-9 safe-r5rs)) -(module-use! %module-public-interface (resolve-interface '(ice-9 null))) +(define null-interface (resolve-interface '(ice-9 null))) + +(module-use! %module-public-interface null-interface) (export eqv? eq? equal? number? complex? real? rational? integer? @@ -129,13 +131,14 @@ ;;transcript-off ) -(define null-interface (make-module 31)) -(set-module-kind! null-interface 'interface) - (define (null-environment n) (if (not (= n 5)) (scm-error 'misc-error 'null-environment "~A is not a valid version" (list n) '())) - null-interface) + ;; Note that we need to create a *fresh* interface + (let ((interface (make-module 31))) + (set-module-kind! interface 'interface) + (module-use! interface null-interface) + interface)) From f7de400af612876e843587124322d710631752f8 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 11 Aug 2000 09:20:14 +0000 Subject: [PATCH 0124/2047] *** empty log message *** --- ice-9/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 07e344beb..2510e0180 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,5 +1,11 @@ 2000-08-11 Mikael Djurfeldt + * r5rs.scm (interaction-environment): Removed definition. (Is now + provided by libguile/modules.c.) + + * safe-r5rs.scm (null-environment): Bugfix: Should include + syntactic bindings. + * boot-9.scm (record-constructor, record-accessor, record-modifier, scm-style-repl): Add second arg to eval. (read-hash-extend #\.): Ditto. (This is actually a bugfix!) From 41d7d2af429d0901f0aaff881ee432f5a241b3df Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 11 Aug 2000 09:30:07 +0000 Subject: [PATCH 0125/2047] *** empty log message *** --- NEWS | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/NEWS b/NEWS index 845f6e83d..ce43cec0b 100644 --- a/NEWS +++ b/NEWS @@ -22,6 +22,19 @@ Example: * Changes to Scheme functions and syntax +** Backward incompatible change: eval EXP ENVIRONMENT-SPECIFIER + +`eval' is now R5RS, that is it takes two arguments. +The second argument is an environment specifier, i.e. either + + (scheme-report-environment 5) + (null-environment 5) + (interaction-environment) + +or + + any module. + ** New define-module option: pure Tells the module system not to include any bindings from the root From 872e0c7291add805ac889b31ae7e5cbf0122bbaa Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 11 Aug 2000 15:12:37 +0000 Subject: [PATCH 0126/2047] * macros.c: Remove surplus newlines from end of docstrings. * list.c (scm_list_tail): Add @deffnx line to docstring for list-cdr-ref. * keywords.c: Docstring improvements in conjunction with new reference manual doc on keywords. * error.c (scm_error_scm): Fix texinfo syntax error in docstring. (@code(~S) should be @code{~S}.) * dynl.c: Remove surplus newlines from end of docstrings. --- libguile/ChangeLog | 15 +++++++++++++++ libguile/dynl.c | 11 ++++------- libguile/error.c | 2 +- libguile/keywords.c | 8 ++++---- libguile/list.c | 3 ++- libguile/macros.c | 24 ++++++++++++------------ 6 files changed, 38 insertions(+), 25 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 9730873e1..8115a2443 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,18 @@ +2000-08-11 Neil Jerram + + * macros.c: Remove surplus newlines from end of docstrings. + + * list.c (scm_list_tail): Add @deffnx line to docstring for + list-cdr-ref. + + * keywords.c: Docstring improvements in conjunction with new + reference manual doc on keywords. + + * error.c (scm_error_scm): Fix texinfo syntax error in + docstring. (@code(~S) should be @code{~S}.) + + * dynl.c: Remove surplus newlines from end of docstrings. + 2000-08-11 Mikael Djurfeldt * eval.c (scm_eval): Backward incompatible change: Now takes an diff --git a/libguile/dynl.c b/libguile/dynl.c index 5b7cfbf71..16c15f46d 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -380,7 +380,7 @@ SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0, "Unlink the indicated object file from the application. The\n" "argument @var{dynobj} must have been obtained by a call to\n" "@code{dynamic-link}. After @code{dynamic-unlink} has been\n" - "called on @var{dynobj}, its content is no longer accessible.\n") + "called on @var{dynobj}, its content is no longer accessible.") #define FUNC_NAME s_scm_dynamic_unlink { /*fixme* GC-problem */ @@ -411,8 +411,7 @@ SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0, "Regardless whether your C compiler prepends an underscore @samp{_} to\n" "the global names in a program, you should @strong{not} include this\n" "underscore in @var{function}. Guile knows whether the underscore is\n" - "needed or not and will add it when necessary.\n\n" - "") + "needed or not and will add it when necessary.") #define FUNC_NAME s_scm_dynamic_func { void (*func) (); @@ -451,8 +450,7 @@ SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0, "(dynamic-call (dynamic-func @var{function} @var{dynobj} #f))\n" "@end smallexample\n\n" "Interrupts are deferred while the C function is executing (with\n" - "@code{SCM_DEFER_INTS}/@code{SCM_ALLOW_INTS}).\n" - "") + "@code{SCM_DEFER_INTS}/@code{SCM_ALLOW_INTS}).") #define FUNC_NAME s_scm_dynamic_call { void (*fptr) (); @@ -486,8 +484,7 @@ SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0, "The parameter @var{args} must be a list of strings and is converted into\n" "an array of @code{char *}. The array is passed in @var{argv} and its\n" "size in @var{argc}. The return value is converted to a Scheme number\n" - "and returned from the call to @code{dynamic-args-call}.\n\n\n" - "") + "and returned from the call to @code{dynamic-args-call}.") #define FUNC_NAME s_scm_dynamic_args_call { int (*fptr) (int argc, char **argv); diff --git a/libguile/error.c b/libguile/error.c index fa409bcef..4790df734 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -106,7 +106,7 @@ SCM_DEFINE (scm_error_scm, "scm-error", 5, 0, 0, "is the error message string, possibly containing @code{~S} and @code{~A}\n" "escapes. When an error is reported, these are replaced by formating the\n" "corresponding members of @var{args}: @code{~A} (was @code{%s}) formats using @code{display}\n" - "and @code(~S) (was @code{%S}) formats using @code{write}. @var{data} is a\n" + "and @code{~S} (was @code{%S}) formats using @code{write}. @var{data} is a\n" "list or @code{#f} depending on @var{key}: if @var{key} is\n" "@code{system-error} then it should be a list\n" "containing the Unix @code{errno} value; If @var{key} is @code{signal} then\n" diff --git a/libguile/keywords.c b/libguile/keywords.c index 301319f94..f75042abb 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -68,7 +68,7 @@ int scm_tc16_keyword; SCM_DEFINE (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", 1, 0, 0, (SCM symbol), - "Return a keyword object from SYMBOL that starts with `-' (a dash).") + "Make a keyword object from a @var{symbol} that starts with a dash.") #define FUNC_NAME s_scm_make_keyword_from_dash_symbol { SCM vcell; @@ -106,7 +106,7 @@ scm_c_make_keyword (char *s) SCM_DEFINE (scm_keyword_p, "keyword?", 1, 0, 0, (SCM obj), - "Returns #t if the argument OBJ is a keyword, else #f.") + "Returns @code{#t} if the argument @var{obj} is a keyword, else @code{#f}.") #define FUNC_NAME s_scm_keyword_p { return SCM_BOOL(SCM_KEYWORDP (obj)); @@ -116,8 +116,8 @@ SCM_DEFINE (scm_keyword_p, "keyword?", 1, 0, 0, SCM_DEFINE (scm_keyword_dash_symbol, "keyword-dash-symbol", 1, 0, 0, (SCM keyword), - "Return KEYWORD as a dash symbol.\n" - "This is the inverse of `make-keyword-from-dash-symbol'.\n") + "Return the dash symbol for @var{keyword}.\n" + "This is the inverse of @code{make-keyword-from-dash-symbol}.") #define FUNC_NAME s_scm_keyword_dash_symbol { SCM_VALIDATE_KEYWORD (1,keyword); diff --git a/libguile/list.c b/libguile/list.c index cabdba417..d141dd2b1 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -403,9 +403,10 @@ SCM_REGISTER_PROC(s_list_cdr_ref, "list-cdr-ref", 2, 0, 0, scm_list_tail); SCM_DEFINE (scm_list_tail, "list-tail", 2, 0, 0, (SCM lst, SCM k), + "@deffnx primitive list-cdr-ref lst k\n" "Return the \"tail\" of @var{lst} beginning with its @var{k}th element.\n" "The first element of the list is considered to be element 0.\n\n" - "@code{list-cdr-ref} and @code{list-tail} are identical. It may help to\n" + "@code{list-tail} and @code{list-cdr-ref} are identical. It may help to\n" "think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list,\n" "or returning the results of cdring @var{k} times down @var{lst}.") #define FUNC_NAME s_scm_list_tail diff --git a/libguile/macros.c b/libguile/macros.c index 9cc280c22..16562fcb9 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -69,17 +69,17 @@ SCM_DEFINE (scm_makacro, "procedure->syntax", 1, 0, 0, SCM_DEFINE (scm_makmacro, "procedure->macro", 1, 0, 0, (SCM code), "Returns a @dfn{macro} which, when a symbol defined to this value\n" - "appears as the first symbol in an expression, evaluates the result\n" - "of applying @var{code} to the expression and the environment.\n" - "The value returned from @var{code} which has been passed to\n" - "@code{procedure->memoizing-macro} replaces the form passed to\n" - "@var{code}. For example:\n\n" - "@example\n" - "(define trace\n" - " (procedure->macro\n" - " (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x))))))\n\n" - "(trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})).\n" - "@end example\n") + "appears as the first symbol in an expression, evaluates the result\n" + "of applying @var{code} to the expression and the environment.\n" + "The value returned from @var{code} which has been passed to\n" + "@code{procedure->memoizing-macro} replaces the form passed to\n" + "@var{code}. For example:\n\n" + "@example\n" + "(define trace\n" + " (procedure->macro\n" + " (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x))))))\n\n" + "(trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})).\n" + "@end example") #define FUNC_NAME s_scm_makmacro { SCM_VALIDATE_PROC (1,code); @@ -101,7 +101,7 @@ SCM_DEFINE (scm_makmmacro, "procedure->memoizing-macro", 1, 0, 0, " (procedure->macro\n" " (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x))))))\n\n" "(trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})).\n" - "@end example\n") + "@end example") #define FUNC_NAME s_scm_makmmacro { SCM_VALIDATE_PROC (1,code); From b63434358d5327b3ff94171ea3c8c65f2154d4e0 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sat, 12 Aug 2000 06:24:16 +0000 Subject: [PATCH 0127/2047] *** empty log message *** --- devel/ChangeLog | 6 ++++++ devel/README | 2 ++ 2 files changed, 8 insertions(+) diff --git a/devel/ChangeLog b/devel/ChangeLog index ecdb34339..c07edfccb 100644 --- a/devel/ChangeLog +++ b/devel/ChangeLog @@ -1,3 +1,9 @@ +2000-08-12 Mikael Djurfeldt + + * translate: New directory. + + * translate/langtools.text: New file. + 2000-05-30 Mikael Djurfeldt * tasks.text: Use outline-mode. Added section for tasks in need diff --git a/devel/README b/devel/README index f6e8553e1..6ab6e18e7 100644 --- a/devel/README +++ b/devel/README @@ -4,6 +4,8 @@ policy Guile policy documents build information related to the build/installation process +translation information related to language traslation + Files: tasks.text Guile project task list From 5da1a3da3ef66e755feb97b982b6b998eec0303c Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sat, 12 Aug 2000 06:25:04 +0000 Subject: [PATCH 0128/2047] * translate/langtools.text: New file. --- devel/translation/langtools.text | 307 +++++++++++++++++++++++++++++++ 1 file changed, 307 insertions(+) create mode 100644 devel/translation/langtools.text diff --git a/devel/translation/langtools.text b/devel/translation/langtools.text new file mode 100644 index 000000000..d0d47e277 --- /dev/null +++ b/devel/translation/langtools.text @@ -0,0 +1,307 @@ +* Introduction + +This is a proposal for how Guile could interface with language +translators. It will be posted on the Guile list and revised for some +short time (days rather than weeks) before being implemented. + +The document can be found in the CVS repository as +guile-core/devel/translation/lantools.text. All Guile developers are +welcome to modify and extend it according to the ongoing discussion +using CVS. + +Ideas and comments are welcome. + +For clarity, the proposal is partially written as if describing an +already existing system. + +MDJ 000812 + +* Language names + +A translator for Guile is a certain kind of Guile module, implemented +in Scheme, C, or a mixture of both. + +To make things simple, the name of the language is closely related to +the name of the translator module. + +Languages have long and short names. The long form is simply the name +of the translator module: `(lang ctax)', `(lang emacs-lisp)', +`(my-modules foo-lang)' etc. + +Languages with the long name `(lang IDENTIFIER)' can be referred to +with the short name IDENTIFIER, for example `emacs-lisp'. + +* How to tell Guile to read code in a different language (than Scheme) + +There are four methods of specifying which translator to use when +reading a file: + +** Command option + +The options to the guile command are parsed linearly from left to +right. You can change the language at zero or more points using the +option + + -t, --language LANGUAGE + +Example: + + guile -t emacs-lisp -l foo -l bar -t scheme -l baz + +will use the emacs-lisp translator while reading "foo" and "bar", and +the default translator (scheme) for "baz". + +You can use this technique in a script together with the meta switch: + +#!/usr/local/bin/guile \ +-t emacs-lisp -s +!# + +** Commentary in file + +When opening a file for reading, Guile will read the first few lines, +looking for the string "-*- LANGNAME -*-", where LANGNAME can be +either the long or short form of the name. + +If found, the corresponding translator is loaded and used to read the +file. + +** File extension + +Guile maintains an alist mapping filename extensions to languages. +Each entry has the form: + + (REGEXP . LANGNAME) + +where REGEXP is a string and LANGNAME a symbol or a list of symbols. + +The alist can be accessed using `language-alist' which is exported +by the module `(core config)': + + (language-alist) --> current alist + (language-alist ALIST) sets the alist to ALIST + (language-alist ALIST :prepend) prepends ALIST onto the current list + (language-alist ALIST :append) appends ALIST after current list + +The `load' command will match filenames against this alist and choose +the translator to use accordingly. + +** Module header + +The module header of the current module system is the form + + (define-module NAME OPTION1 ...) + +You can specify a translator using the option + + :language LANGNAME + +where LANGNAME is the long or short form of language name as described +above. + +The translator is being fed characters from the module file, starting +immediately after the end-parenthesis of the module header form. + +NOTE: There can be only one module header per file. + +It is also possible to put the module header in a separate file and +use the option + + :file FILENAME + +to point out a file containing the actual code. + +Example: + +foo.gm: +---------------------------------------------------------------------- +(define-module (foo) + :language emacs-lisp + :file "foo.el" + :export (foo bar) + ) +---------------------------------------------------------------------- + +foo.el: +---------------------------------------------------------------------- +(defun foo () + ...) + +(defun bar () + ...) +---------------------------------------------------------------------- + +* Language modules + +A language module is an ordinary Guile module importing bindings from +other modules and exporting bindings through its public interface. + +It is required to export the following procedures: + + language-environment --> ENVIRONMENT + + Returns a fresh top-level ENVIRONMENT (a module) where expressions + in this language are evaluated by default. + + Modules using this language will by default have this environment + on their use list. + + The intention is for this procedure to provide the "run-time + environment" for the language. + + read-expression PORT --> EXPRESSION + + Read next expression in the foreign syntax from PORT and return an + object EXPRESSION representing it. + + It is entirely up to the language module to define what one + expression is. The representation of EXPRESSION is also chosen by + the language module. + + This procedure will be called during interactive use (the user + types expressions at a prompt) and when the system `read' + procedure is called when a module using this language is selected. + + translate EXPRESSION --> SCHEMECODE + + Translate an EXPRESSION into SCHEMECODE. + + EXPRESSION can be anything returned by `read-expression'. + + SCHEMECODE is Scheme source code represented using ordinary Scheme + data. It will be passed to `eval' in an environment containing + bindings in the environment returned by `language-environment'. + + This procedure will be called duing interactive use and when the + system `eval + + translate-all PORT --> THUNK + + Translate the entire stream of characters PORT until #. + Return a THUNK which can be called repeatedly like this: + + THUNK --> SCHEMECODE + + Each call will yield a new piece of scheme code. #f is returned + to signal the end of the stream of scheme expressions. + + This procedure will be called by the system `load' command and by + the module system when loading files. + + The intensions are: + + 1. To let the language module decide when and in how large chunks + to do the processing. It may choose to do all processing at + the time translate-all is called, all processing when THUNK is + called the first time, or small pieces of processing each time + THUNK is called, or any conceivable combination. + + 2. To let the language module decide in how large chunks to output + the resulting Scheme code in order not to overload memory. + + 3. To enable the language module to use temporary files, and + whole-module analysis and optimization techniques. + + untranslate SCHEMECODE --> EXPRESSION + + Attempt to do the inverse of `translate'. An approximation is + OK. It is also OK to return #f. This procedure will be called + from the debugger, when generating error messages, backtraces etc. + +* Error handling + +** Errors during translation + +Errors during translation are generated as usual by calling scm-error +(from Scheme) or scm_misc_error etc (from C). The effect of +throwing errors from within `translate-all' is the same as when they +are generated within a call to the THUNK returned from +`translate-all'. + +scm-error takes a fifth argument. This is a property list (alist) +which you can use to pass extra information to the error reporting +machinery. + +Currently, the following properties are supported: + + filename filename of file being translated + line line number of errring expression + column column number + +** Run-time errors (errors in SCHEMECODE) + +This section pertains to what happens when a run-time error occurs +during evaluation of the translated code. + +In order to get "foreign code" in error messages, make sure that +`untranslate' yields good output. Note the possibility of maintaining +a table (preferably using weak references) mapping SCHEMECODE to +EXPRESSION. + +Note the availability of source-properties for attaching filename, +line and column number, and other, information, such as EXPRESSION, to +SCHEMECODE. If filename, line, and, column properties are defined, +they will be automatically used by the error reporting machinery. + +* Proposed changes to Guile + +** Implement the above proposal. + +* Add new field `reader' and `translator' to all module objects + +Make sure they are initialized when a language is specified. + +* Use `untranslate' during error handling. + +* Implement the use of arg 5 to scm-error + +(specified in "Errors during translation") + +** Implement a generic lexical analyzer with interface similar to read/rp + +Mikael is working on this. (It might take a few days, since he is +busy with his studies right now.) + +** Remove scm:eval-transformer + +This is replaced by new fields in each module object (environment). + +`eval' will instead directly the `transformer' field in the module +passed as second arg. + +Internal evaluation will, similarly, use the transformer of the module +representing the top-level of the local environment. + +Note that this level of transformation is something independent of +language translation. *This* is a hook for adding Scheme macro +packages and belong to the core language. + +We also need to check the new `translator' field, potentially using +it. + +** Package local environments as smobs + +so that environment list structures can't leak out on the Scheme +level. (This has already been done in SCM.) + +** Introduce "read-states" (symmetrical to "print-states") + +These carries state information belonging to a read call chain, such +as which keyword syntax to support, whether to be case sensitive or +not, and, which lexical grammar to use. + +** Move configuration of keyword syntax and case sensitivity to the read-state + +Add new fields to the module objects for these values, so that the +read-state can be initialized from them. + + *fixme* When? Why? How? + +Probably as soon as the language has been determined during file loading. + +Need to figure out how to set these values. + + +Local Variables: +mode: outline +End: From f0a7af1a86c220b5ae540c3fbcefb37e8ea73a2a Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 12 Aug 2000 22:13:32 +0000 Subject: [PATCH 0129/2047] Docstring fix for scm_logand. --- libguile/ChangeLog | 4 ++++ libguile/numbers.c | 3 ++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 8115a2443..59bd74e99 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2000-08-12 Neil Jerram + + * numbers.c (s_scm_logand): Docstring fix - "@end lisp" inserted. + 2000-08-11 Neil Jerram * macros.c: Remove surplus newlines from end of docstrings. diff --git a/libguile/numbers.c b/libguile/numbers.c index e1e1396db..b64b8fdc7 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -714,7 +714,8 @@ SCM_DEFINE1 (scm_logand, "logand", scm_tc7_asubr, "Example:\n" "@lisp\n" "(number->string (logand #b1100 #b1010) 2)\n" - " @result{} \"1000\"") + " @result{} \"1000\"\n" + "@end lisp") #define FUNC_NAME s_scm_logand { long int nn1; From 1670bef99183d4dbbbfbdc69c5b3c9d9e84dffc9 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 12 Aug 2000 22:15:55 +0000 Subject: [PATCH 0130/2047] Docstring fix - quote quotation marks and backslashes. --- libguile/ChangeLog | 3 +++ libguile/strop.c | 14 +++++++------- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 59bd74e99..b8761c918 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,8 @@ 2000-08-12 Neil Jerram + * strop.c: Docstring fixes - quotation marks and backslashes + needed quoting. + * numbers.c (s_scm_logand): Docstring fix - "@end lisp" inserted. 2000-08-11 Neil Jerram diff --git a/libguile/strop.c b/libguile/strop.c index 0a3ea54ce..abb6ae25b 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -114,11 +114,11 @@ SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0, "it is used as the starting index; if @var{to} is given and not @var{#f},\n" "it is used as the ending index (exclusive).\n\n" "@example\n" - "(string-index "weiner" #\e)\n" + "(string-index \"weiner\" #\\e)\n" "@result{} 1\n\n" - "(string-index "weiner" #\e 2)\n" + "(string-index \"weiner\" #\\e 2)\n" "@result{} 4\n\n" - "(string-index "weiner" #\e 2 4)\n" + "(string-index \"weiner\" #\\e 2 4)\n" "@result{} #f\n" "@end example") #define FUNC_NAME s_scm_string_index @@ -145,11 +145,11 @@ SCM_DEFINE (scm_string_rindex, "string-rindex", 2, 2, 0, "of @var{char} in the range [@var{frm}, @var{to}-1], which defaults to\n" "the entire string.\n\n" "@example\n" - "(string-rindex "weiner" #\e)\n" + "(string-rindex \"weiner\" #\\e)\n" "@result{} 4\n\n" - "(string-rindex "weiner" #\e 2 4)\n" + "(string-rindex \"weiner\" #\\e 2 4)\n" "@result{} #f\n\n" - "(string-rindex "weiner" #\e 2 5)\n" + "(string-rindex \"weiner\" #\\e 2 5)\n" "@result{} 4\n" "@end example") #define FUNC_NAME s_scm_string_rindex @@ -274,7 +274,7 @@ SCM_DEFINE (scm_substring_fill_x, "substring-fill!", 4, 0, 0, "(qdocs:) Destructively fills @var{str}, from @var{start} to @var{end}, with @var{fill}.\n\n" "@example\n" "(define y \"abcdefg\")\n" - "(substring-fill! y 1 3 #\r)\n" + "(substring-fill! y 1 3 #\\r)\n" "y\n" "@result{} \"arrdefg\"\n" "@end example") From ee826bae22c7fd1bd62d49752552a6adb44b9c1c Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 12 Aug 2000 22:18:04 +0000 Subject: [PATCH 0131/2047] Docstring updated so that make-soft-port example is correct. --- libguile/ChangeLog | 3 +++ libguile/vports.c | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b8761c918..b15492ffe 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,8 @@ 2000-08-12 Neil Jerram + * vports.c (s_scm_make_soft_port): Docstring updated so that + example is correct. + * strop.c: Docstring fixes - quotation marks and backslashes needed quoting. diff --git a/libguile/vports.c b/libguile/vports.c index 264c1c032..d36888606 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -175,7 +175,7 @@ SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0, " (lambda () (char-upcase (read-char)))\n" " (lambda () (display \"@@\" stdout)))\n" " \"rw\"))\n\n" - "(write p p) @result{} #\n" + "(write p p) @result{} #\n" "@end example") #define FUNC_NAME s_scm_make_soft_port { From 2a2a730bfa8c911806f784b65969ec828462a08a Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 12 Aug 2000 23:15:48 +0000 Subject: [PATCH 0132/2047] * Docstring fixes. --- libguile/ChangeLog | 11 +++++++++++ libguile/numbers.c | 10 +++++----- libguile/ports.c | 2 +- libguile/root.c | 3 +-- libguile/strports.c | 2 +- 5 files changed, 19 insertions(+), 9 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b15492ffe..1d82aca9e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,16 @@ +2000-08-13 Neil Jerram + + * root.c (s_scm_call_with_dynamic_root): Docstring fix - rogue + newline. + 2000-08-12 Neil Jerram + * numbers.c (scm_ash): Docstring fix - missing newlines. + + * ports.c (scm_port_filename): Docstring fix - missing newline. + + * strports.c (scm_eval_string): Docstring fix - missing newline. + * vports.c (s_scm_make_soft_port): Docstring updated so that example is correct. diff --git a/libguile/numbers.c b/libguile/numbers.c index b64b8fdc7..b5dc2fbbb 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1114,8 +1114,8 @@ SCM_DEFINE (scm_ash, "ash", 2, 0, 0, (SCM n, SCM cnt), "The function ash performs an arithmetic shift left by CNT bits\n" "(or shift right, if CNT is negative). 'Arithmetic' means, that\n" - "the function does not guarantee to keep the bit structure of N,\n" - "but rather guarantees that the result will always be rounded\n" + "the function does not guarantee to keep the bit structure of N,\n" + "but rather guarantees that the result will always be rounded\n" "towards minus infinity. Therefore, the results of ash and a\n" "corresponding bitwise shift will differ if N is negative.\n\n" "Formally, the function returns an integer equivalent to\n" @@ -1123,9 +1123,9 @@ SCM_DEFINE (scm_ash, "ash", 2, 0, 0, "Example:\n" "@lisp\n" "(number->string (ash #b1 3) 2)\n" - " @result{} \"1000\"" - "(number->string (ash #b1010 -1) 2)" - " @result{} \"101\"" + " @result{} \"1000\"\n" + "(number->string (ash #b1010 -1) 2)\n" + " @result{} \"101\"\n" "@end lisp") #define FUNC_NAME s_scm_ash { diff --git a/libguile/ports.c b/libguile/ports.c index 0c2536945..51cbb6ec6 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1265,7 +1265,7 @@ SCM_DEFINE (scm_set_port_column_x, "set-port-column!", 2, 0, 0, SCM_DEFINE (scm_port_filename, "port-filename", 1, 0, 0, (SCM port), "Return the filename associated with @var{port}. This function returns\n" - "the strings \"standard input\", \"standard output\" and \"standard error\"" + "the strings \"standard input\", \"standard output\" and \"standard error\"\n" "when called on the current input, output and error ports respectively.") #define FUNC_NAME s_scm_port_filename { diff --git a/libguile/root.c b/libguile/root.c index e58db5304..0a8c7a92d 100644 --- a/libguile/root.c +++ b/libguile/root.c @@ -359,8 +359,7 @@ SCM_DEFINE (scm_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0, " (newline))\n" " (lambda (errcode) errcode))))\n" "@end example\n\n" - "The problem is, on what port will @samp{fnord\n" - "} be displayed? You\n" + "The problem is, on what port will @samp{fnord} be displayed? You\n" "might expect that because of the @code{with-output-to-port} that\n" "it will be displayed on the port bound to @code{some-port}. But it\n" "probably won't -- before evaluating the thunk, dynamic winds are\n" diff --git a/libguile/strports.c b/libguile/strports.c index 779c10046..026c5cdae 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -388,7 +388,7 @@ scm_eval_0str (const char *expr) SCM_DEFINE (scm_eval_string, "eval-string", 1, 0, 0, (SCM string), "Evaluate @var{string} as the text representation of a Scheme form\n" - "or forms, and return whatever value they produce." + "or forms, and return whatever value they produce.\n" "Evaluation takes place in (interaction-environment).") #define FUNC_NAME s_scm_eval_string { From f888a1b586b63a593e7da16fd7b8f0e82b72b2a3 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 13 Aug 2000 02:31:46 +0000 Subject: [PATCH 0133/2047] *** empty log message *** --- devel/translation/langtools.text | 374 ++++++++++++++++++++++++++----- 1 file changed, 323 insertions(+), 51 deletions(-) diff --git a/devel/translation/langtools.text b/devel/translation/langtools.text index d0d47e277..1c776e383 100644 --- a/devel/translation/langtools.text +++ b/devel/translation/langtools.text @@ -1,5 +1,7 @@ * Introduction +Version: $Id: langtools.text,v 1.2 2000-08-13 02:31:46 mdj Exp $ + This is a proposal for how Guile could interface with language translators. It will be posted on the Guile list and revised for some short time (days rather than weeks) before being implemented. @@ -86,8 +88,49 @@ by the module `(core config)': The `load' command will match filenames against this alist and choose the translator to use accordingly. +There will be a default alist for common translators. For translators +not listed, the alist has to be extended in .guile just as Emacs users +extend auto-mode-alist in .emacs. + ** Module header +You specify the language used by a module with the :language option in +the module header. (See below under "Module configuration language".) + +* Module system + +This section describes how the Guile module system is adapted to use +with other languages. + +** Module configuration language + +*** The `(config)' module + +Guile has a sophisticated module system. We don't require each +translator implementation to implement its own syntax for modules. +That would be too much work for the implementor, and users would have +to learn the module system anew for each syntax. + +Instead, the module `(config)' exports the module header form +`(define-module ...)'. + +The config module also exports a number of primitives by which you can +customize the Guile library, such as `language-alist' and `load-path'. + +*** Default module environment + +The bindings of the config module is available in the default +interaction environment when Guile starts up. This is because the +config module is on the module use list for the startup environment. + +However, config bindings are *not* available by default in new +modules. + +The default module environment provides bindings from the R5RS module +only. + +*** Module headers + The module header of the current module system is the form (define-module NAME OPTION1 ...) @@ -131,82 +174,303 @@ foo.el: ...) ---------------------------------------------------------------------- +** Repl commands + +Up till now, Guile has been dependent upon the available bindings in +the selected module in order to do basic operations such as moving to +a different module, enter the debugger or getting documentation. + +This is not acceptable since we want be able to control Guile +consistently regardless of in which module we are, and sinc we don't +want to equip a module with bindings which don't have anything to do +with the purpose of the module. + +Therefore, the repl provides a special command language on top of +whatever syntax the current module provides. (Scheme48 and RScheme +provides similar repl command languages.) + +*** Repl command syntax + +Normally, repl commands have the syntax + + ,COMMAND ARG1 ... + +Input starting with arbitrary amount of whitespace + a comma thus +works as an escape syntax. + +This syntax is probably compatible with all languages. (Note that we +don't need to activate the lexer of the language until we've checked +if the first non-whitespace char is a comma.) + +(Hypothetically, if this would become a problem, we can provide means +of disabling this behaviour of the repl and let that particular +language module take sole control of reading at the repl prompt.) + +Among the commands available are + +*** ,in MODULE + +Select module named MODULE, that is any new expressions typed by the +user after this command will be evaluated in the evaluation +environment provided by MODULE. + +*** ,in MODULE EXPR + +Evaluate expression EXPR in MODULE. EXPR has the syntax supplied by +the language used by MODULE. + +*** ,use MODULE + +Import all bindings exported by MODULE to the current module. + * Language modules +Since code written in any kind of language should be able to implement +most tasks, which may include reading, evaluating and writing, and +generally computing with, expressions and data originating from other +languages, we want the basic reading, evaluation and printing +operations to be independent of the language. + +That is, instead of supplying separate `read', `eval' and `write' +procedures for different languages, a language module is required to +use the system procedures in the translated code. + +This means that the behaviour of `read', `eval' and `write' are +context dependent. (See further "How Guile system procedures `read', +`eval', `write' use language modules" below.) + +** Language data types + +Each language module should try to use the fundamental Scheme data +types as far as this is possible. + +Some data types have important differences in semantics between +languages, though, and all required data types may not exist in +Guile. + +In such cases, the language module must supply its own, distinct, data +types. So, each language supported by Guile uses a certain set of +data types, with the basic Scheme data types as the intersection +between all sets. + +Specifically, syntax trees representing source code expressions should +normally be a distinct data type. + +** Foreign language escape syntax + +Note that such data can flow freely between modules. In order to +accomodate data with different native syntaxes, each language module +provides a foreign language escape syntax. In Scheme, this syntax +uses the sharp comma extension specified by SRFI-10. The read +constructor is simply the last symbol in the long language name (which +is usually the same as the short language name). + +** Example1 + +Characters have the syntax in Scheme and in ctax. Lists currently +have syntax in Scheme but lack ctax syntax. Enums have syntax in ctax +but lack Scheme syntax. + +The following table now shows the syntax used for reading and writing +these expressions in module A using the language scheme, and module B +using the language ctax (we assume that the foreign language escape +syntax in ctax is #LANGUAGE EXPR): + + A B + +chars #\X 'X' + +lists (1 2 3) #scheme (1 2 3) + +enums #,(ctax ENUM) ENUM + +** Example2 + + A user is typing expressions in a ctax module which imports the + bindings x and y from the module `(foo)': + + ctax> x = read (); + 1+2; + 1+2; + ctax> x + 1+2; + ctax> y = 1; + 1 + ctax> y; + 1 + ctax> ,in (guile-user) + guile> ,use (foo) + guile> x + #,(ctax 1+2;) + guile> y + 1 + guile> + +The example shows that ctax uses a distinct representation for ctax +expressions, but Scheme integers for integers. + +** Language module interface + A language module is an ordinary Guile module importing bindings from other modules and exporting bindings through its public interface. -It is required to export the following procedures: +It is required to export the following variable and procedures: - language-environment --> ENVIRONMENT +*** language-environment --> ENVIRONMENT - Returns a fresh top-level ENVIRONMENT (a module) where expressions - in this language are evaluated by default. +Returns a fresh top-level ENVIRONMENT (a module) where expressions +in this language are evaluated by default. - Modules using this language will by default have this environment - on their use list. +Modules using this language will by default have this environment +on their use list. - The intention is for this procedure to provide the "run-time - environment" for the language. +The intention is for this procedure to provide the "run-time +environment" for the language. - read-expression PORT --> EXPRESSION +*** native-read PORT --> OBJECT - Read next expression in the foreign syntax from PORT and return an - object EXPRESSION representing it. +Read next expression in the foreign syntax from PORT and return an +object OBJECT representing it. - It is entirely up to the language module to define what one - expression is. The representation of EXPRESSION is also chosen by - the language module. +It is entirely up to the language module to define what one +expression is, that is, how much to read. - This procedure will be called during interactive use (the user - types expressions at a prompt) and when the system `read' - procedure is called when a module using this language is selected. +In lisp-like languages, `native-read' corresponds to `read'. Note +that in such languages, OBJECT need not be source code, but could +be data. - translate EXPRESSION --> SCHEMECODE +The representation of OBJECT is also chosen by the language +module. It can consist of Scheme data types, data types distinct for +the language, or a mixture. - Translate an EXPRESSION into SCHEMECODE. +There is one requirement, however: Distinct data types must be +instances of a subclass of `language-specific-class'. - EXPRESSION can be anything returned by `read-expression'. +This procedure will be called during interactive use (the user +types expressions at a prompt) and when the system `read' +procedure is called at a time when a module using this language is +selected. - SCHEMECODE is Scheme source code represented using ordinary Scheme - data. It will be passed to `eval' in an environment containing - bindings in the environment returned by `language-environment'. +Some languages (for example Python) parse differently depending if +its an interactive or non-interactive session. Guile prvides the +predicate `interactive-port?' to test for this. - This procedure will be called duing interactive use and when the - system `eval +*** language-specific-class - translate-all PORT --> THUNK +This variable contains the superclass of all non-Scheme data-types +provided by the language. - Translate the entire stream of characters PORT until #. - Return a THUNK which can be called repeatedly like this: +*** native-write OBJECT PORT - THUNK --> SCHEMECODE +This procedure prints the OBJECT on PORT using the specific +language syntax. - Each call will yield a new piece of scheme code. #f is returned - to signal the end of the stream of scheme expressions. +*** write-foreign-syntax OBJECT LANGUAGE NATIVE-WRITE PORT - This procedure will be called by the system `load' command and by - the module system when loading files. +Write OBJECT in the foreign language escape syntax of this module. +The object is specific to language LANGUAGE and can be written using +NATIVE-WRITE. - The intensions are: +Here's an implementation for Scheme: - 1. To let the language module decide when and in how large chunks - to do the processing. It may choose to do all processing at - the time translate-all is called, all processing when THUNK is - called the first time, or small pieces of processing each time - THUNK is called, or any conceivable combination. +(define (write-foreign-syntax object language native-write port) + (format port "#(~A " language)) + (native-write object port) + (display #\) port) - 2. To let the language module decide in how large chunks to output - the resulting Scheme code in order not to overload memory. +*** translate EXPRESSION --> SCHEMECODE - 3. To enable the language module to use temporary files, and - whole-module analysis and optimization techniques. +Translate an EXPRESSION into SCHEMECODE. - untranslate SCHEMECODE --> EXPRESSION +EXPRESSION can be anything returned by `read'. - Attempt to do the inverse of `translate'. An approximation is - OK. It is also OK to return #f. This procedure will be called - from the debugger, when generating error messages, backtraces etc. +SCHEMECODE is Scheme source code represented using ordinary Scheme +data. It will be passed to `eval' in an environment containing +bindings in the environment returned by `language-environment'. + +This procedure will be called duing interactive use and when the +system `eval + +*** translate-all PORT [ALIST] --> THUNK + +Translate the entire stream of characters PORT until #. +Return a THUNK which can be called repeatedly like this: + + THUNK --> SCHEMECODE + +Each call will yield a new piece of scheme code. #f is returned +to signal the end of the stream of scheme expressions. (Note that +it isn't meaningful for THUNK to return immediates. In fact, it's +only meaningful to return expressions with side-effects.) + +The optional argument ALIST provides compilation options for the +translator: + + (debug . #t) means produce code suitable for debugging + +This procedure will be called by the system `load' command and by +the module system when loading files. + +The intensions are: + +1. To let the language module decide when and in how large chunks + to do the processing. It may choose to do all processing at + the time translate-all is called, all processing when THUNK is + called the first time, or small pieces of processing each time + THUNK is called, or any conceivable combination. + +2. To let the language module decide in how large chunks to output + the resulting Scheme code in order not to overload memory. + +3. To enable the language module to use temporary files, and + whole-module analysis and optimization techniques. + +*** untranslate SCHEMECODE --> EXPRESSION + +Attempt to do the inverse of `translate'. An approximation is OK. It +is also OK to return #f. This procedure will be called from the +debugger, when generating error messages, backtraces etc. + +The debugger uses the local evaluation environment to determine from +which module an expression come. This is how the debugger can know +which `untranslate' procedure to call for a given expression. + +(This is used currently to decide whether which backtrace frames to +display. System modules use the option :no-backtrace to prevent +displaying of Guile's internals to the user.) + +Note that `untranslate' can use source-properties set by `native-read' +to give hints about how to do the reverse translation. Such hints +could for example be the filename, and line and column numbers for the +source expression, or an actual copy of the source expression. + +** How Guile system procedures `read', `eval', `write' use language modules + +*** read + +The idea is that the `read' exported from the R5RS library will +continue work when called from other languages, and will keep its +semantics. + +A call to `read' simply means "read in an expression from PORT using +the syntax associated with that port". + +Each module carries information about its language. + +When an input port is created for a module to be read or during +interaction with a given module, this information is copied to the +port object. + +read uses this information to call `native-read' in the correct +language module. + +*** eval + +[To be written.] + +*** write + +[To be written.] * Error handling @@ -284,11 +548,19 @@ it. so that environment list structures can't leak out on the Scheme level. (This has already been done in SCM.) -** Introduce "read-states" (symmetrical to "print-states") +** Introduce new fields in input ports -These carries state information belonging to a read call chain, such -as which keyword syntax to support, whether to be case sensitive or -not, and, which lexical grammar to use. +These carries state information such as + +*** which keyword syntax to support + +*** whether to be case sensitive or not + +*** which lexical grammar to use + +*** whether the port is used in an interactive session or not + +There will be a new Guile primitive `interactive-port?' testing for this. ** Move configuration of keyword syntax and case sensitivity to the read-state From 5a0c9f69c8313d9a32e6785f573c2fbe25574d95 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 13 Aug 2000 03:44:52 +0000 Subject: [PATCH 0134/2047] *** empty log message *** --- devel/translation/langtools.text | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/devel/translation/langtools.text b/devel/translation/langtools.text index 1c776e383..858b32b67 100644 --- a/devel/translation/langtools.text +++ b/devel/translation/langtools.text @@ -1,6 +1,6 @@ * Introduction -Version: $Id: langtools.text,v 1.2 2000-08-13 02:31:46 mdj Exp $ +Version: $Id: langtools.text,v 1.3 2000-08-13 03:44:52 mdj Exp $ This is a proposal for how Guile could interface with language translators. It will be posted on the Guile list and revised for some @@ -398,10 +398,9 @@ Return a THUNK which can be called repeatedly like this: THUNK --> SCHEMECODE -Each call will yield a new piece of scheme code. #f is returned -to signal the end of the stream of scheme expressions. (Note that -it isn't meaningful for THUNK to return immediates. In fact, it's -only meaningful to return expressions with side-effects.) +Each call will yield a new piece of scheme code. The THUNK signals +end of translation by returning the unique value *end-of-translation* +which can be tested using the predicate `end-of-translation?'. The optional argument ALIST provides compilation options for the translator: From f587dec1baf2db9a55170dc0b5b7c2629e083ac3 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 13 Aug 2000 04:16:18 +0000 Subject: [PATCH 0135/2047] *** empty log message *** --- devel/translation/langtools.text | 20 +++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) diff --git a/devel/translation/langtools.text b/devel/translation/langtools.text index 858b32b67..ed0a1b108 100644 --- a/devel/translation/langtools.text +++ b/devel/translation/langtools.text @@ -1,6 +1,6 @@ * Introduction -Version: $Id: langtools.text,v 1.3 2000-08-13 03:44:52 mdj Exp $ +Version: $Id: langtools.text,v 1.4 2000-08-13 04:16:18 mdj Exp $ This is a proposal for how Guile could interface with language translators. It will be posted on the Guile list and revised for some @@ -189,6 +189,20 @@ Therefore, the repl provides a special command language on top of whatever syntax the current module provides. (Scheme48 and RScheme provides similar repl command languages.) +[Jost Boekemeier has suggested the following alternative solution: + Commands are bindings just like any other binding. It is enough if + some modules carry command bindings (it's in fact enough if *one* + module has them), because from such a module you can use the command + (in MODULE) to walk into a module not carrying command bindings, and + then use CTRL-D to exit. + + However, this has the disadvantage of mixing the "real" bindings with + command bindings (the module might want to use "in" for other + purposes), that CTRL-D could cause problems since for some channels + CTRL-D might close down the connection, and that using one type of + command ("in") to go "into" the module and another (CTRL-D) to "exit" + is more complex than simply "going to" a module.] + *** Repl command syntax Normally, repl commands have the syntax @@ -399,8 +413,8 @@ Return a THUNK which can be called repeatedly like this: THUNK --> SCHEMECODE Each call will yield a new piece of scheme code. The THUNK signals -end of translation by returning the unique value *end-of-translation* -which can be tested using the predicate `end-of-translation?'. +end of translation by returning the value *end-of-translation* (which +is tested using the predicate `end-of-translation?'). The optional argument ALIST provides compilation options for the translator: From 7f43f900eded44d28040625b8df3cec63ceb5660 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 13 Aug 2000 04:47:26 +0000 Subject: [PATCH 0136/2047] *** empty log message *** --- devel/translation/langtools.text | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/devel/translation/langtools.text b/devel/translation/langtools.text index ed0a1b108..ac07ce034 100644 --- a/devel/translation/langtools.text +++ b/devel/translation/langtools.text @@ -1,13 +1,13 @@ * Introduction -Version: $Id: langtools.text,v 1.4 2000-08-13 04:16:18 mdj Exp $ +Version: $Id: langtools.text,v 1.5 2000-08-13 04:47:26 mdj Exp $ This is a proposal for how Guile could interface with language translators. It will be posted on the Guile list and revised for some short time (days rather than weeks) before being implemented. The document can be found in the CVS repository as -guile-core/devel/translation/lantools.text. All Guile developers are +guile-core/devel/translation/langtools.text. All Guile developers are welcome to modify and extend it according to the ongoing discussion using CVS. @@ -279,11 +279,11 @@ uses the sharp comma extension specified by SRFI-10. The read constructor is simply the last symbol in the long language name (which is usually the same as the short language name). -** Example1 +** Example 1 Characters have the syntax in Scheme and in ctax. Lists currently -have syntax in Scheme but lack ctax syntax. Enums have syntax in ctax -but lack Scheme syntax. +have syntax in Scheme but lack ctax syntax. Ctax doesn't have a +datatype "enum", but we pretend it has for this example. The following table now shows the syntax used for reading and writing these expressions in module A using the language scheme, and module B @@ -298,7 +298,7 @@ lists (1 2 3) #scheme (1 2 3) enums #,(ctax ENUM) ENUM -** Example2 +** Example 2 A user is typing expressions in a ctax module which imports the bindings x and y from the module `(foo)': @@ -524,13 +524,13 @@ they will be automatically used by the error reporting machinery. ** Implement the above proposal. -* Add new field `reader' and `translator' to all module objects +** Add new field `reader' and `translator' to all module objects Make sure they are initialized when a language is specified. -* Use `untranslate' during error handling. +** Use `untranslate' during error handling. -* Implement the use of arg 5 to scm-error +** Implement the use of arg 5 to scm-error (specified in "Errors during translation") From eaa6f703ea230b854b3ab3755a9210b7ad2e640a Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 13 Aug 2000 19:21:04 +0000 Subject: [PATCH 0137/2047] * psyntax.ss (top-level-eval-hook, local-eval-hook): Pass `(interaction-environment)' as second arg to `eval'. This is completely equivalent with the state before the change to eval of 2000-08-11, but we should extend psyntax.ss to be module aware. (Thanks to Ian Bicking.) --- ice-9/psyntax.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ice-9/psyntax.ss b/ice-9/psyntax.ss index f45ac9191..fc4178ed3 100644 --- a/ice-9/psyntax.ss +++ b/ice-9/psyntax.ss @@ -298,11 +298,11 @@ (define top-level-eval-hook (lambda (x) - (eval `(,noexpand ,x)))) + (eval `(,noexpand ,x) (interaction-environment)))) (define local-eval-hook (lambda (x) - (eval `(,noexpand ,x)))) + (eval `(,noexpand ,x) (interaction-environment)))) (define error-hook (lambda (who why what) From 1fe16f927b00721d54440b632ce28d254e9fb471 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 13 Aug 2000 19:21:14 +0000 Subject: [PATCH 0138/2047] Updated --- ice-9/psyntax.pp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ice-9/psyntax.pp b/ice-9/psyntax.pp index 172342d6d..93f134d06 100644 --- a/ice-9/psyntax.pp +++ b/ice-9/psyntax.pp @@ -1,4 +1,4 @@ -(letrec ((lambda-var-list (lambda (vars203) (let lvl ((vars204 vars203) (ls (quote ())) (w205 (quote (())))) (cond ((pair? vars204) (lvl (cdr vars204) (cons (wrap (car vars204) w205) ls) w205)) ((id? vars204) (cons (wrap vars204 w205) ls)) ((null? vars204) ls) ((syntax-object? vars204) (lvl (syntax-object-expression vars204) ls (join-wraps w205 (syntax-object-wrap vars204)))) ((annotation? vars204) (lvl (annotation-expression vars204) ls w205)) (else (cons vars204 ls)))))) (gen-var (lambda (id206) (let ((id207 (if (syntax-object? id206) (syntax-object-expression id206) id206))) (if (annotation? id207) (gensym (annotation-expression id207) generated-symbols) (gensym id207 generated-symbols))))) (strip (lambda (x208 w209) (if (memq (quote top) (wrap-marks w209)) (if (or (annotation? x208) (and (pair? x208) (annotation? (car x208)))) (strip-annotation x208 (quote #f)) x208) (let f210 ((x211 x208)) (cond ((syntax-object? x211) (strip (syntax-object-expression x211) (syntax-object-wrap x211))) ((pair? x211) (let ((a (f210 (car x211))) (d (f210 (cdr x211)))) (if (and (eq? a (car x211)) (eq? d (cdr x211))) x211 (cons a d)))) ((vector? x211) (let ((old212 (vector->list x211))) (let ((new213 (map f210 old212))) (if (andmap eq? old212 new213) x211 (list->vector new213))))) (else x211)))))) (strip-annotation (lambda (x214 parent) (cond ((pair? x214) (let ((new215 (cons (quote #f) (quote #f)))) (begin (when parent (set-annotation-stripped! parent new215)) (set-car! new215 (strip-annotation (car x214) (quote #f))) (set-cdr! new215 (strip-annotation (cdr x214) (quote #f))) new215))) ((annotation? x214) (or (annotation-stripped x214) (strip-annotation (annotation-expression x214) x214))) ((vector? x214) (let ((new216 (make-vector (vector-length x214)))) (begin (when parent (set-annotation-stripped! parent new216)) (let loop ((i217 (- (vector-length x214) (quote 1)))) (unless (fx< i217 (quote 0)) (vector-set! new216 i217 (strip-annotation (vector-ref x214 i217) (quote #f))) (loop (fx- i217 (quote 1))))) new216))) (else x214)))) (ellipsis? (lambda (x218) (and (nonsymbol-id? x218) (free-id=? x218 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))))))) (chi-void (lambda () (list (quote void)))) (eval-local-transformer (lambda (expanded) (let ((p (local-eval-hook expanded))) (if (procedure? p) p (syntax-error p (quote "nonprocedure transfomer")))))) (chi-local-syntax (lambda (rec? e219 r w220 s k) ((lambda (tmp221) ((lambda (tmp222) (if tmp222 (apply (lambda (_223 id224 val e1 e2) (let ((ids225 id224)) (if (not (valid-bound-ids? ids225)) (syntax-error e219 (quote "duplicate bound keyword in")) (let ((labels (gen-labels ids225))) (let ((new-w (make-binding-wrap ids225 labels w220))) (k (cons e1 e2) (extend-env labels (let ((w228 (if rec? new-w w220)) (trans-r (macros-only-env r))) (map (lambda (x229) (cons (quote macro) (eval-local-transformer (chi x229 trans-r w228)))) val)) r) new-w s)))))) tmp222) ((lambda (_231) (syntax-error (source-wrap e219 w220 s))) tmp221))) (syntax-dispatch tmp221 (quote (any #(each (any any)) any . each-any))))) e219))) (chi-lambda-clause (lambda (e232 c r233 w234 k235) ((lambda (tmp236) ((lambda (tmp237) (if tmp237 (apply (lambda (id238 e1239 e2240) (let ((ids241 id238)) (if (not (valid-bound-ids? ids241)) (syntax-error e232 (quote "invalid parameter list in")) (let ((labels243 (gen-labels ids241)) (new-vars (map gen-var ids241))) (k235 new-vars (chi-body (cons e1239 e2240) e232 (extend-var-env labels243 new-vars r233) (make-binding-wrap ids241 labels243 w234))))))) tmp237) ((lambda (tmp245) (if tmp245 (apply (lambda (ids246 e1247 e2248) (let ((old-ids (lambda-var-list ids246))) (if (not (valid-bound-ids? old-ids)) (syntax-error e232 (quote "invalid parameter list in")) (let ((labels249 (gen-labels old-ids)) (new-vars250 (map gen-var old-ids))) (k235 (let f251 ((ls1 (cdr new-vars250)) (ls2 (car new-vars250))) (if (null? ls1) ls2 (f251 (cdr ls1) (cons (car ls1) ls2)))) (chi-body (cons e1247 e2248) e232 (extend-var-env labels249 new-vars250 r233) (make-binding-wrap old-ids labels249 w234))))))) tmp245) ((lambda (_253) (syntax-error e232)) tmp236))) (syntax-dispatch tmp236 (quote (any any . each-any)))))) (syntax-dispatch tmp236 (quote (each-any any . each-any))))) c))) (chi-body (lambda (body outer-form r254 w255) (let ((r256 (cons (quote ("placeholder" placeholder)) r254))) (let ((ribcage (make-ribcage (quote ()) (quote ()) (quote ())))) (let ((w257 (make-wrap (wrap-marks w255) (cons ribcage (wrap-subst w255))))) (let parse ((body258 (map (lambda (x262) (cons r256 (wrap x262 w257))) body)) (ids259 (quote ())) (labels260 (quote ())) (vars261 (quote ())) (vals (quote ())) (bindings (quote ()))) (if (null? body258) (syntax-error outer-form (quote "no expressions in body")) (let ((e263 (cdar body258)) (er (caar body258))) (call-with-values (lambda () (syntax-type e263 er (quote (())) (quote #f) ribcage)) (lambda (type264 value265 e266 w267 s268) (let ((t type264)) (if (memv t (quote (define-form))) (let ((id269 (wrap value265 w267)) (label (gen-label))) (let ((var270 (gen-var id269))) (begin (extend-ribcage! ribcage id269 label) (parse (cdr body258) (cons id269 ids259) (cons label labels260) (cons var270 vars261) (cons (cons er (wrap e266 w267)) vals) (cons (cons (quote lexical) var270) bindings))))) (if (memv t (quote (define-syntax-form))) (let ((id271 (wrap value265 w267)) (label272 (gen-label))) (begin (extend-ribcage! ribcage id271 label272) (parse (cdr body258) (cons id271 ids259) (cons label272 labels260) vars261 vals (cons (cons (quote macro) (cons er (wrap e266 w267))) bindings)))) (if (memv t (quote (begin-form))) ((lambda (tmp273) ((lambda (tmp274) (if tmp274 (apply (lambda (_275 e1276) (parse (let f277 ((forms e1276)) (if (null? forms) (cdr body258) (cons (cons er (wrap (car forms) w267)) (f277 (cdr forms))))) ids259 labels260 vars261 vals bindings)) tmp274) (syntax-error tmp273))) (syntax-dispatch tmp273 (quote (any . each-any))))) e266) (if (memv t (quote (local-syntax-form))) (chi-local-syntax value265 e266 er w267 s268 (lambda (forms279 er280 w281 s282) (parse (let f283 ((forms284 forms279)) (if (null? forms284) (cdr body258) (cons (cons er280 (wrap (car forms284) w281)) (f283 (cdr forms284))))) ids259 labels260 vars261 vals bindings))) (if (null? ids259) (build-sequence (quote #f) (map (lambda (x285) (chi (cdr x285) (car x285) (quote (())))) (cons (cons er (source-wrap e266 w267 s268)) (cdr body258)))) (begin (if (not (valid-bound-ids? ids259)) (syntax-error outer-form (quote "invalid or duplicate identifier in definition"))) (let loop286 ((bs bindings) (er-cache (quote #f)) (r-cache (quote #f))) (if (not (null? bs)) (let ((b (car bs))) (if (eq? (car b) (quote macro)) (let ((er287 (cadr b))) (let ((r-cache288 (if (eq? er287 er-cache) r-cache (macros-only-env er287)))) (begin (set-cdr! b (eval-local-transformer (chi (cddr b) r-cache288 (quote (()))))) (loop286 (cdr bs) er287 r-cache288)))) (loop286 (cdr bs) er-cache r-cache))))) (set-cdr! r256 (extend-env labels260 bindings (cdr r256))) (build-letrec (quote #f) vars261 (map (lambda (x289) (chi (cdr x289) (car x289) (quote (())))) vals) (build-sequence (quote #f) (map (lambda (x290) (chi (cdr x290) (car x290) (quote (())))) (cons (cons er (source-wrap e266 w267 s268)) (cdr body258)))))))))))))))))))))) (chi-macro (lambda (p291 e292 r293 w294 rib) (letrec ((rebuild-macro-output (lambda (x295 m) (cond ((pair? x295) (cons (rebuild-macro-output (car x295) m) (rebuild-macro-output (cdr x295) m))) ((syntax-object? x295) (let ((w296 (syntax-object-wrap x295))) (let ((ms (wrap-marks w296)) (s297 (wrap-subst w296))) (make-syntax-object (syntax-object-expression x295) (if (and (pair? ms) (eq? (car ms) (quote #f))) (make-wrap (cdr ms) (if rib (cons rib (cdr s297)) (cdr s297))) (make-wrap (cons m ms) (if rib (cons rib (cons (quote shift) s297)) (cons (quote shift) s297)))))))) ((vector? x295) (let ((n (vector-length x295))) (let ((v (make-vector n))) (let doloop ((i298 (quote 0))) (if (fx= i298 n) v (begin (vector-set! v i298 (rebuild-macro-output (vector-ref x295 i298) m)) (doloop (fx+ i298 (quote 1))))))))) ((symbol? x295) (syntax-error x295 (quote "encountered raw symbol in macro output"))) (else x295))))) (rebuild-macro-output (p291 (wrap e292 (anti-mark w294))) (string (quote #\m)))))) (chi-application (lambda (x299 e300 r301 w302 s303) ((lambda (tmp304) ((lambda (tmp305) (if tmp305 (apply (lambda (e0 e1306) (cons x299 (map (lambda (e307) (chi e307 r301 w302)) e1306))) tmp305) (syntax-error tmp304))) (syntax-dispatch tmp304 (quote (any . each-any))))) e300))) (chi-expr (lambda (type309 value310 e311 r312 w313 s314) (let ((t315 type309)) (if (memv t315 (quote (lexical))) value310 (if (memv t315 (quote (core))) (value310 e311 r312 w313 s314) (if (memv t315 (quote (lexical-call))) (chi-application value310 e311 r312 w313 s314) (if (memv t315 (quote (global-call))) (chi-application value310 e311 r312 w313 s314) (if (memv t315 (quote (constant))) (list (quote quote) (strip (source-wrap e311 w313 s314) (quote (())))) (if (memv t315 (quote (global))) value310 (if (memv t315 (quote (call))) (chi-application (chi (car e311) r312 w313) e311 r312 w313 s314) (if (memv t315 (quote (begin-form))) ((lambda (tmp316) ((lambda (tmp317) (if tmp317 (apply (lambda (_318 e1319 e2320) (chi-sequence (cons e1319 e2320) r312 w313 s314)) tmp317) (syntax-error tmp316))) (syntax-dispatch tmp316 (quote (any any . each-any))))) e311) (if (memv t315 (quote (local-syntax-form))) (chi-local-syntax value310 e311 r312 w313 s314 chi-sequence) (if (memv t315 (quote (eval-when-form))) ((lambda (tmp322) ((lambda (tmp323) (if tmp323 (apply (lambda (_324 x325 e1326 e2327) (let ((when-list (chi-when-list e311 x325 w313))) (if (memq (quote eval) when-list) (chi-sequence (cons e1326 e2327) r312 w313 s314) (chi-void)))) tmp323) (syntax-error tmp322))) (syntax-dispatch tmp322 (quote (any each-any any . each-any))))) e311) (if (memv t315 (quote (define-form define-syntax-form))) (syntax-error (wrap value310 w313) (quote "invalid context for definition of")) (if (memv t315 (quote (syntax))) (syntax-error (source-wrap e311 w313 s314) (quote "reference to pattern variable outside syntax form")) (if (memv t315 (quote (displaced-lexical))) (syntax-error (source-wrap e311 w313 s314) (quote "reference to identifier outside its scope")) (syntax-error (source-wrap e311 w313 s314)))))))))))))))))) (chi (lambda (e330 r331 w332) (call-with-values (lambda () (syntax-type e330 r331 w332 (quote #f) (quote #f))) (lambda (type333 value334 e335 w336 s337) (chi-expr type333 value334 e335 r331 w336 s337))))) (chi-top (lambda (e338 r339 w340 m341 esew) (call-with-values (lambda () (syntax-type e338 r339 w340 (quote #f) (quote #f))) (lambda (type348 value349 e350 w351 s352) (let ((t353 type348)) (if (memv t353 (quote (begin-form))) ((lambda (tmp354) ((lambda (tmp355) (if tmp355 (apply (lambda (_356) (chi-void)) tmp355) ((lambda (tmp357) (if tmp357 (apply (lambda (_358 e1359 e2360) (chi-top-sequence (cons e1359 e2360) r339 w351 s352 m341 esew)) tmp357) (syntax-error tmp354))) (syntax-dispatch tmp354 (quote (any any . each-any)))))) (syntax-dispatch tmp354 (quote (any))))) e350) (if (memv t353 (quote (local-syntax-form))) (chi-local-syntax value349 e350 r339 w351 s352 (lambda (body362 r363 w364 s365) (chi-top-sequence body362 r363 w364 s365 m341 esew))) (if (memv t353 (quote (eval-when-form))) ((lambda (tmp366) ((lambda (tmp367) (if tmp367 (apply (lambda (_368 x369 e1370 e2371) (let ((when-list372 (chi-when-list e350 x369 w351)) (body373 (cons e1370 e2371))) (cond ((eq? m341 (quote e)) (if (memq (quote eval) when-list372) (chi-top-sequence body373 r339 w351 s352 (quote e) (quote (eval))) (chi-void))) ((memq (quote load) when-list372) (if (or (memq (quote compile) when-list372) (and (eq? m341 (quote c&e)) (memq (quote eval) when-list372))) (chi-top-sequence body373 r339 w351 s352 (quote c&e) (quote (compile load))) (if (memq m341 (quote (c c&e))) (chi-top-sequence body373 r339 w351 s352 (quote c) (quote (load))) (chi-void)))) ((or (memq (quote compile) when-list372) (and (eq? m341 (quote c&e)) (memq (quote eval) when-list372))) (top-level-eval-hook (chi-top-sequence body373 r339 w351 s352 (quote e) (quote (eval)))) (chi-void)) (else (chi-void))))) tmp367) (syntax-error tmp366))) (syntax-dispatch tmp366 (quote (any each-any any . each-any))))) e350) (if (memv t353 (quote (define-syntax-form))) (let ((n376 (id-var-name value349 w351)) (r377 (macros-only-env r339))) (let ((t378 m341)) (if (memv t378 (quote (c))) (if (memq (quote compile) esew) (let ((e379 (chi-install-global n376 (chi e350 r377 w351)))) (begin (top-level-eval-hook e379) (if (memq (quote load) esew) e379 (chi-void)))) (if (memq (quote load) esew) (chi-install-global n376 (chi e350 r377 w351)) (chi-void))) (if (memv t378 (quote (c&e))) (let ((e380 (chi-install-global n376 (chi e350 r377 w351)))) (begin (top-level-eval-hook e380) e380)) (begin (if (memq (quote eval) esew) (top-level-eval-hook (chi-install-global n376 (chi e350 r377 w351)))) (chi-void)))))) (if (memv t353 (quote (define-form))) (let ((n381 (id-var-name value349 w351))) (let ((t382 (binding-type (lookup n381 r339)))) (if (memv t382 (quote (global))) (let ((x383 (list (quote define) n381 (chi e350 r339 w351)))) (begin (if (eq? m341 (quote c&e)) (top-level-eval-hook x383)) x383)) (if (memv t382 (quote (displaced-lexical))) (syntax-error (wrap value349 w351) (quote "identifier out of context")) (syntax-error (wrap value349 w351) (quote "cannot define keyword at top level")))))) (let ((x384 (chi-expr type348 value349 e350 r339 w351 s352))) (begin (if (eq? m341 (quote c&e)) (top-level-eval-hook x384)) x384)))))))))))) (syntax-type (lambda (e385 r386 w387 s388 rib389) (cond ((symbol? e385) (let ((n390 (id-var-name e385 w387))) (let ((b391 (lookup n390 r386))) (let ((type392 (binding-type b391))) (let ((t393 type392)) (if (memv t393 (quote (lexical))) (values type392 (binding-value b391) e385 w387 s388) (if (memv t393 (quote (global))) (values type392 n390 e385 w387 s388) (if (memv t393 (quote (macro))) (syntax-type (chi-macro (binding-value b391) e385 r386 w387 rib389) r386 (quote (())) s388 rib389) (values type392 (binding-value b391) e385 w387 s388))))))))) ((pair? e385) (let ((first (car e385))) (if (id? first) (let ((n394 (id-var-name first w387))) (let ((b395 (lookup n394 r386))) (let ((type396 (binding-type b395))) (let ((t397 type396)) (if (memv t397 (quote (lexical))) (values (quote lexical-call) (binding-value b395) e385 w387 s388) (if (memv t397 (quote (global))) (values (quote global-call) n394 e385 w387 s388) (if (memv t397 (quote (macro))) (syntax-type (chi-macro (binding-value b395) e385 r386 w387 rib389) r386 (quote (())) s388 rib389) (if (memv t397 (quote (core))) (values type396 (binding-value b395) e385 w387 s388) (if (memv t397 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value b395) e385 w387 s388) (if (memv t397 (quote (begin))) (values (quote begin-form) (quote #f) e385 w387 s388) (if (memv t397 (quote (eval-when))) (values (quote eval-when-form) (quote #f) e385 w387 s388) (if (memv t397 (quote (define))) ((lambda (tmp398) ((lambda (tmp399) (if (if tmp399 (apply (lambda (_400 name401 val402) (id? name401)) tmp399) (quote #f)) (apply (lambda (_403 name404 val405) (values (quote define-form) name404 val405 w387 s388)) tmp399) ((lambda (tmp406) (if (if tmp406 (apply (lambda (_407 name408 args409 e1410 e2411) (and (id? name408) (or (valid-bound-ids? (lambda-var-list args409)) (id? (lambda-var-list args409))))) tmp406) (quote #f)) (apply (lambda (_412 name413 args414 e1415 e2416) (values (quote define-form) (wrap name413 w387) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) (wrap (cons args414 (cons e1415 e2416)) w387)) (quote (())) s388)) tmp406) ((lambda (tmp418) (if (if tmp418 (apply (lambda (_419 name420) (id? name420)) tmp418) (quote #f)) (apply (lambda (_421 name422) (values (quote define-form) (wrap name422 w387) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote (())) s388)) tmp418) (syntax-error tmp398))) (syntax-dispatch tmp398 (quote (any any)))))) (syntax-dispatch tmp398 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp398 (quote (any any any))))) e385) (if (memv t397 (quote (define-syntax))) ((lambda (tmp423) ((lambda (tmp424) (if (if tmp424 (apply (lambda (_425 name426 val427) (id? name426)) tmp424) (quote #f)) (apply (lambda (_428 name429 val430) (values (quote define-syntax-form) name429 val430 w387 s388)) tmp424) (syntax-error tmp423))) (syntax-dispatch tmp423 (quote (any any any))))) e385) (values (quote call) (quote #f) e385 w387 s388)))))))))))))) (values (quote call) (quote #f) e385 w387 s388)))) ((syntax-object? e385) (syntax-type (syntax-object-expression e385) r386 (join-wraps w387 (syntax-object-wrap e385)) (quote #f) rib389)) ((annotation? e385) (syntax-type (annotation-expression e385) r386 w387 (annotation-source e385) rib389)) ((let ((x431 e385)) (or (boolean? x431) (number? x431) (string? x431) (char? x431) (null? x431) (keyword? x431))) (values (quote constant) (quote #f) e385 w387 s388)) (else (values (quote other) (quote #f) e385 w387 s388))))) (chi-when-list (lambda (e432 when-list433 w434) (let f435 ((when-list436 when-list433) (situations (quote ()))) (if (null? when-list436) situations (f435 (cdr when-list436) (cons (let ((x437 (car when-list436))) (cond ((free-id=? x437 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote compile)) ((free-id=? x437 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote load)) ((free-id=? x437 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote eval)) (else (syntax-error (wrap x437 w434) (quote "invalid eval-when situation"))))) situations)))))) (chi-install-global (lambda (name438 e439) (list (quote install-global-transformer) (list (quote quote) name438) e439))) (chi-top-sequence (lambda (body440 r441 w442 s443 m444 esew445) (build-sequence s443 (let dobody ((body446 body440) (r447 r441) (w448 w442) (m449 m444) (esew450 esew445)) (if (null? body446) (quote ()) (let ((first451 (chi-top (car body446) r447 w448 m449 esew450))) (cons first451 (dobody (cdr body446) r447 w448 m449 esew450)))))))) (chi-sequence (lambda (body452 r453 w454 s455) (build-sequence s455 (let dobody456 ((body457 body452) (r458 r453) (w459 w454)) (if (null? body457) (quote ()) (let ((first460 (chi (car body457) r458 w459))) (cons first460 (dobody456 (cdr body457) r458 w459)))))))) (source-wrap (lambda (x461 w462 s463) (wrap (if s463 (make-annotation x461 s463 (quote #f)) x461) w462))) (wrap (lambda (x464 w465) (cond ((and (null? (wrap-marks w465)) (null? (wrap-subst w465))) x464) ((syntax-object? x464) (make-syntax-object (syntax-object-expression x464) (join-wraps w465 (syntax-object-wrap x464)))) ((null? x464) x464) (else (make-syntax-object x464 w465))))) (bound-id-member? (lambda (x466 list) (and (not (null? list)) (or (bound-id=? x466 (car list)) (bound-id-member? x466 (cdr list)))))) (distinct-bound-ids? (lambda (ids467) (let distinct? ((ids468 ids467)) (or (null? ids468) (and (not (bound-id-member? (car ids468) (cdr ids468))) (distinct? (cdr ids468))))))) (valid-bound-ids? (lambda (ids469) (and (let all-ids? ((ids470 ids469)) (or (null? ids470) (and (id? (car ids470)) (all-ids? (cdr ids470))))) (distinct-bound-ids? ids469)))) (bound-id=? (lambda (i471 j) (if (and (syntax-object? i471) (syntax-object? j)) (and (eq? (let ((e472 (syntax-object-expression i471))) (if (annotation? e472) (annotation-expression e472) e472)) (let ((e473 (syntax-object-expression j))) (if (annotation? e473) (annotation-expression e473) e473))) (same-marks? (wrap-marks (syntax-object-wrap i471)) (wrap-marks (syntax-object-wrap j)))) (eq? (let ((e474 i471)) (if (annotation? e474) (annotation-expression e474) e474)) (let ((e475 j)) (if (annotation? e475) (annotation-expression e475) e475)))))) (free-id=? (lambda (i476 j477) (and (eq? (let ((x478 i476)) (let ((e479 (if (syntax-object? x478) (syntax-object-expression x478) x478))) (if (annotation? e479) (annotation-expression e479) e479))) (let ((x480 j477)) (let ((e481 (if (syntax-object? x480) (syntax-object-expression x480) x480))) (if (annotation? e481) (annotation-expression e481) e481)))) (eq? (id-var-name i476 (quote (()))) (id-var-name j477 (quote (()))))))) (id-var-name (lambda (id482 w483) (letrec ((search-vector-rib (lambda (sym subst marks489 symnames ribcage490) (let ((n491 (vector-length symnames))) (let f492 ((i493 (quote 0))) (cond ((fx= i493 n491) (search sym (cdr subst) marks489)) ((and (eq? (vector-ref symnames i493) sym) (same-marks? marks489 (vector-ref (ribcage-marks ribcage490) i493))) (values (vector-ref (ribcage-labels ribcage490) i493) marks489)) (else (f492 (fx+ i493 (quote 1))))))))) (search-list-rib (lambda (sym494 subst495 marks496 symnames497 ribcage498) (let f499 ((symnames500 symnames497) (i501 (quote 0))) (cond ((null? symnames500) (search sym494 (cdr subst495) marks496)) ((and (eq? (car symnames500) sym494) (same-marks? marks496 (list-ref (ribcage-marks ribcage498) i501))) (values (list-ref (ribcage-labels ribcage498) i501) marks496)) (else (f499 (cdr symnames500) (fx+ i501 (quote 1)))))))) (search (lambda (sym502 subst503 marks504) (if (null? subst503) (values (quote #f) marks504) (let ((fst (car subst503))) (if (eq? fst (quote shift)) (search sym502 (cdr subst503) (cdr marks504)) (let ((symnames505 (ribcage-symnames fst))) (if (vector? symnames505) (search-vector-rib sym502 subst503 marks504 symnames505 fst) (search-list-rib sym502 subst503 marks504 symnames505 fst))))))))) (cond ((symbol? id482) (or (call-with-values (lambda () (search id482 (wrap-subst w483) (wrap-marks w483))) (lambda (x506 . ignore) x506)) id482)) ((syntax-object? id482) (let ((id507 (let ((e508 (syntax-object-expression id482))) (if (annotation? e508) (annotation-expression e508) e508))) (w1 (syntax-object-wrap id482))) (let ((marks509 (join-marks (wrap-marks w483) (wrap-marks w1)))) (call-with-values (lambda () (search id507 (wrap-subst w483) marks509)) (lambda (new-id marks510) (or new-id (call-with-values (lambda () (search id507 (wrap-subst w1) marks510)) (lambda (x512 . ignore511) x512)) id507)))))) ((annotation? id482) (let ((id513 (let ((e514 id482)) (if (annotation? e514) (annotation-expression e514) e514)))) (or (call-with-values (lambda () (search id513 (wrap-subst w483) (wrap-marks w483))) (lambda (x516 . ignore515) x516)) id513))) (else (error-hook (quote id-var-name) (quote "invalid id") id482)))))) (same-marks? (lambda (x517 y) (or (eq? x517 y) (and (not (null? x517)) (not (null? y)) (eq? (car x517) (car y)) (same-marks? (cdr x517) (cdr y)))))) (join-marks (lambda (m1 m2) (smart-append m1 m2))) (join-wraps (lambda (w1518 w2) (let ((m1519 (wrap-marks w1518)) (s1 (wrap-subst w1518))) (if (null? m1519) (if (null? s1) w2 (make-wrap (wrap-marks w2) (smart-append s1 (wrap-subst w2)))) (make-wrap (smart-append m1519 (wrap-marks w2)) (smart-append s1 (wrap-subst w2))))))) (smart-append (lambda (m1520 m2521) (if (null? m2521) m1520 (append m1520 m2521)))) (make-binding-wrap (lambda (ids522 labels523 w524) (if (null? ids522) w524 (make-wrap (wrap-marks w524) (cons (let ((labelvec (list->vector labels523))) (let ((n525 (vector-length labelvec))) (let ((symnamevec (make-vector n525)) (marksvec (make-vector n525))) (begin (let f526 ((ids527 ids522) (i528 (quote 0))) (if (not (null? ids527)) (call-with-values (lambda () (id-sym-name&marks (car ids527) w524)) (lambda (symname marks529) (begin (vector-set! symnamevec i528 symname) (vector-set! marksvec i528 marks529) (f526 (cdr ids527) (fx+ i528 (quote 1)))))))) (make-ribcage symnamevec marksvec labelvec))))) (wrap-subst w524)))))) (extend-ribcage! (lambda (ribcage530 id531 label532) (begin (set-ribcage-symnames! ribcage530 (cons (let ((e533 (syntax-object-expression id531))) (if (annotation? e533) (annotation-expression e533) e533)) (ribcage-symnames ribcage530))) (set-ribcage-marks! ribcage530 (cons (wrap-marks (syntax-object-wrap id531)) (ribcage-marks ribcage530))) (set-ribcage-labels! ribcage530 (cons label532 (ribcage-labels ribcage530)))))) (anti-mark (lambda (w534) (make-wrap (cons (quote #f) (wrap-marks w534)) (cons (quote shift) (wrap-subst w534))))) (set-ribcage-labels! (lambda (x535 update) (vector-set! x535 (quote 3) update))) (set-ribcage-marks! (lambda (x536 update537) (vector-set! x536 (quote 2) update537))) (set-ribcage-symnames! (lambda (x538 update539) (vector-set! x538 (quote 1) update539))) (ribcage-labels (lambda (x540) (vector-ref x540 (quote 3)))) (ribcage-marks (lambda (x541) (vector-ref x541 (quote 2)))) (ribcage-symnames (lambda (x542) (vector-ref x542 (quote 1)))) (ribcage? (lambda (x543) (and (vector? x543) (= (vector-length x543) (quote 4)) (eq? (vector-ref x543 (quote 0)) (quote ribcage))))) (make-ribcage (lambda (symnames544 marks545 labels546) (vector (quote ribcage) symnames544 marks545 labels546))) (gen-labels (lambda (ls547) (if (null? ls547) (quote ()) (cons (gen-label) (gen-labels (cdr ls547)))))) (gen-label (lambda () (string (quote #\i)))) (wrap-subst cdr) (wrap-marks car) (make-wrap cons) (id-sym-name&marks (lambda (x548 w549) (if (syntax-object? x548) (values (let ((e550 (syntax-object-expression x548))) (if (annotation? e550) (annotation-expression e550) e550)) (join-marks (wrap-marks w549) (wrap-marks (syntax-object-wrap x548)))) (values (let ((e551 x548)) (if (annotation? e551) (annotation-expression e551) e551)) (wrap-marks w549))))) (id? (lambda (x552) (cond ((symbol? x552) (quote #t)) ((syntax-object? x552) (symbol? (let ((e553 (syntax-object-expression x552))) (if (annotation? e553) (annotation-expression e553) e553)))) ((annotation? x552) (symbol? (annotation-expression x552))) (else (quote #f))))) (nonsymbol-id? (lambda (x554) (and (syntax-object? x554) (symbol? (let ((e555 (syntax-object-expression x554))) (if (annotation? e555) (annotation-expression e555) e555)))))) (global-extend (lambda (type556 sym557 val558) (put-global-definition-hook sym557 (cons type556 val558)))) (lookup (lambda (x559 r560) (cond ((assq x559 r560) => cdr) ((symbol? x559) (or (get-global-definition-hook x559) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env (lambda (r561) (if (null? r561) (quote ()) (let ((a562 (car r561))) (if (eq? (cadr a562) (quote macro)) (cons a562 (macros-only-env (cdr r561))) (macros-only-env (cdr r561))))))) (extend-var-env (lambda (labels563 vars564 r565) (if (null? labels563) r565 (extend-var-env (cdr labels563) (cdr vars564) (cons (cons (car labels563) (cons (quote lexical) (car vars564))) r565))))) (extend-env (lambda (labels566 bindings567 r568) (if (null? labels566) r568 (extend-env (cdr labels566) (cdr bindings567) (cons (cons (car labels566) (car bindings567)) r568))))) (binding-value cdr) (binding-type car) (source-annotation (lambda (x569) (cond ((annotation? x569) (annotation-source x569)) ((syntax-object? x569) (source-annotation (syntax-object-expression x569))) (else (quote #f))))) (set-syntax-object-wrap! (lambda (x570 update571) (vector-set! x570 (quote 2) update571))) (set-syntax-object-expression! (lambda (x572 update573) (vector-set! x572 (quote 1) update573))) (syntax-object-wrap (lambda (x574) (vector-ref x574 (quote 2)))) (syntax-object-expression (lambda (x575) (vector-ref x575 (quote 1)))) (syntax-object? (lambda (x576) (and (vector? x576) (= (vector-length x576) (quote 3)) (eq? (vector-ref x576 (quote 0)) (quote syntax-object))))) (make-syntax-object (lambda (expression wrap577) (vector (quote syntax-object) expression wrap577))) (build-letrec (lambda (src578 vars579 val-exps body-exp) (if (null? vars579) body-exp (list (quote letrec) (map list vars579 val-exps) body-exp)))) (build-named-let (lambda (src580 vars581 val-exps582 body-exp583) (if (null? vars581) body-exp583 (list (quote let) (car vars581) (map list (cdr vars581) val-exps582) body-exp583)))) (build-let (lambda (src584 vars585 val-exps586 body-exp587) (if (null? vars585) body-exp587 (list (quote let) (map list vars585 val-exps586) body-exp587)))) (build-sequence (lambda (src588 exps) (if (null? (cdr exps)) (car exps) (cons (quote begin) exps)))) (get-global-definition-hook (lambda (symbol) (getprop symbol (quote *sc-expander*)))) (put-global-definition-hook (lambda (symbol589 binding) (putprop symbol589 (quote *sc-expander*) binding))) (error-hook (lambda (who590 why what) (error who590 (quote "~a ~s") why what))) (local-eval-hook (lambda (x591) (eval (list noexpand x591)))) (top-level-eval-hook (lambda (x592) (eval (list noexpand x592)))) (annotation? (lambda (x593) (quote #f))) (fx< <) (fx= =) (fx- -) (fx+ +) (noexpand (quote "noexpand"))) (begin (global-extend (quote local-syntax) (quote letrec-syntax) (quote #t)) (global-extend (quote local-syntax) (quote let-syntax) (quote #f)) (global-extend (quote core) (quote fluid-let-syntax) (lambda (e594 r595 w596 s597) ((lambda (tmp598) ((lambda (tmp599) (if (if tmp599 (apply (lambda (_600 var601 val602 e1603 e2604) (valid-bound-ids? var601)) tmp599) (quote #f)) (apply (lambda (_606 var607 val608 e1609 e2610) (let ((names (map (lambda (x611) (id-var-name x611 w596)) var607))) (begin (for-each (lambda (id613 n614) (let ((t615 (binding-type (lookup n614 r595)))) (if (memv t615 (quote (displaced-lexical))) (syntax-error (source-wrap id613 w596 s597) (quote "identifier out of context"))))) var607 names) (chi-body (cons e1609 e2610) (source-wrap e594 w596 s597) (extend-env names (let ((trans-r618 (macros-only-env r595))) (map (lambda (x619) (cons (quote macro) (eval-local-transformer (chi x619 trans-r618 w596)))) val608)) r595) w596)))) tmp599) ((lambda (_621) (syntax-error (source-wrap e594 w596 s597))) tmp598))) (syntax-dispatch tmp598 (quote (any #(each (any any)) any . each-any))))) e594))) (global-extend (quote core) (quote quote) (lambda (e622 r623 w624 s625) ((lambda (tmp626) ((lambda (tmp627) (if tmp627 (apply (lambda (_628 e629) (list (quote quote) (strip e629 w624))) tmp627) ((lambda (_630) (syntax-error (source-wrap e622 w624 s625))) tmp626))) (syntax-dispatch tmp626 (quote (any any))))) e622))) (global-extend (quote core) (quote syntax) (letrec ((regen (lambda (x631) (let ((t632 (car x631))) (if (memv t632 (quote (ref))) (cadr x631) (if (memv t632 (quote (primitive))) (cadr x631) (if (memv t632 (quote (quote))) (list (quote quote) (cadr x631)) (if (memv t632 (quote (lambda))) (list (quote lambda) (cadr x631) (regen (caddr x631))) (if (memv t632 (quote (map))) (let ((ls633 (map regen (cdr x631)))) (cons (if (fx= (length ls633) (quote 2)) (quote map) (quote map)) ls633)) (cons (car x631) (map regen (cdr x631))))))))))) (gen-vector (lambda (x634) (cond ((eq? (car x634) (quote list)) (cons (quote vector) (cdr x634))) ((eq? (car x634) (quote quote)) (list (quote quote) (list->vector (cadr x634)))) (else (list (quote list->vector) x634))))) (gen-append (lambda (x635 y636) (if (equal? y636 (quote (quote ()))) x635 (list (quote append) x635 y636)))) (gen-cons (lambda (x637 y638) (let ((t639 (car y638))) (if (memv t639 (quote (quote))) (if (eq? (car x637) (quote quote)) (list (quote quote) (cons (cadr x637) (cadr y638))) (if (eq? (cadr y638) (quote ())) (list (quote list) x637) (list (quote cons) x637 y638))) (if (memv t639 (quote (list))) (cons (quote list) (cons x637 (cdr y638))) (list (quote cons) x637 y638)))))) (gen-map (lambda (e640 map-env) (let ((formals (map cdr map-env)) (actuals (map (lambda (x641) (list (quote ref) (car x641))) map-env))) (cond ((eq? (car e640) (quote ref)) (car actuals)) ((andmap (lambda (x642) (and (eq? (car x642) (quote ref)) (memq (cadr x642) formals))) (cdr e640)) (cons (quote map) (cons (list (quote primitive) (car e640)) (map (let ((r643 (map cons formals actuals))) (lambda (x644) (cdr (assq (cadr x644) r643)))) (cdr e640))))) (else (cons (quote map) (cons (list (quote lambda) formals e640) actuals))))))) (gen-mappend (lambda (e645 map-env646) (list (quote apply) (quote (primitive append)) (gen-map e645 map-env646)))) (gen-ref (lambda (src647 var648 level649 maps) (if (fx= level649 (quote 0)) (values var648 maps) (if (null? maps) (syntax-error src647 (quote "missing ellipsis in syntax form")) (call-with-values (lambda () (gen-ref src647 var648 (fx- level649 (quote 1)) (cdr maps))) (lambda (outer-var outer-maps) (let ((b650 (assq outer-var (car maps)))) (if b650 (values (cdr b650) maps) (let ((inner-var (gen-var (quote tmp)))) (values inner-var (cons (cons (cons outer-var inner-var) (car maps)) outer-maps))))))))))) (gen-syntax (lambda (src651 e652 r653 maps654 ellipsis?655) (if (id? e652) (let ((label656 (id-var-name e652 (quote (()))))) (let ((b657 (lookup label656 r653))) (if (eq? (binding-type b657) (quote syntax)) (call-with-values (lambda () (let ((var.lev (binding-value b657))) (gen-ref src651 (car var.lev) (cdr var.lev) maps654))) (lambda (var658 maps659) (values (list (quote ref) var658) maps659))) (if (ellipsis?655 e652) (syntax-error src651 (quote "misplaced ellipsis in syntax form")) (values (list (quote quote) e652) maps654))))) ((lambda (tmp660) ((lambda (tmp661) (if (if tmp661 (apply (lambda (dots e662) (ellipsis?655 dots)) tmp661) (quote #f)) (apply (lambda (dots663 e664) (gen-syntax src651 e664 r653 maps654 (lambda (x665) (quote #f)))) tmp661) ((lambda (tmp666) (if (if tmp666 (apply (lambda (x667 dots668 y669) (ellipsis?655 dots668)) tmp666) (quote #f)) (apply (lambda (x670 dots671 y672) (let f673 ((y674 y672) (k675 (lambda (maps676) (call-with-values (lambda () (gen-syntax src651 x670 r653 (cons (quote ()) maps676) ellipsis?655)) (lambda (x677 maps678) (if (null? (car maps678)) (syntax-error src651 (quote "extra ellipsis in syntax form")) (values (gen-map x677 (car maps678)) (cdr maps678)))))))) ((lambda (tmp679) ((lambda (tmp680) (if (if tmp680 (apply (lambda (dots681 y682) (ellipsis?655 dots681)) tmp680) (quote #f)) (apply (lambda (dots683 y684) (f673 y684 (lambda (maps685) (call-with-values (lambda () (k675 (cons (quote ()) maps685))) (lambda (x686 maps687) (if (null? (car maps687)) (syntax-error src651 (quote "extra ellipsis in syntax form")) (values (gen-mappend x686 (car maps687)) (cdr maps687)))))))) tmp680) ((lambda (_688) (call-with-values (lambda () (gen-syntax src651 y674 r653 maps654 ellipsis?655)) (lambda (y689 maps690) (call-with-values (lambda () (k675 maps690)) (lambda (x691 maps692) (values (gen-append x691 y689) maps692)))))) tmp679))) (syntax-dispatch tmp679 (quote (any . any))))) y674))) tmp666) ((lambda (tmp693) (if tmp693 (apply (lambda (x694 y695) (call-with-values (lambda () (gen-syntax src651 x694 r653 maps654 ellipsis?655)) (lambda (x696 maps697) (call-with-values (lambda () (gen-syntax src651 y695 r653 maps697 ellipsis?655)) (lambda (y698 maps699) (values (gen-cons x696 y698) maps699)))))) tmp693) ((lambda (tmp700) (if tmp700 (apply (lambda (e1701 e2702) (call-with-values (lambda () (gen-syntax src651 (cons e1701 e2702) r653 maps654 ellipsis?655)) (lambda (e704 maps705) (values (gen-vector e704) maps705)))) tmp700) ((lambda (_706) (values (list (quote quote) e652) maps654)) tmp660))) (syntax-dispatch tmp660 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp660 (quote (any . any)))))) (syntax-dispatch tmp660 (quote (any any . any)))))) (syntax-dispatch tmp660 (quote (any any))))) e652))))) (lambda (e707 r708 w709 s710) (let ((e711 (source-wrap e707 w709 s710))) ((lambda (tmp712) ((lambda (tmp713) (if tmp713 (apply (lambda (_714 x715) (call-with-values (lambda () (gen-syntax e711 x715 r708 (quote ()) ellipsis?)) (lambda (e716 maps717) (regen e716)))) tmp713) ((lambda (_718) (syntax-error e711)) tmp712))) (syntax-dispatch tmp712 (quote (any any))))) e711))))) (global-extend (quote core) (quote lambda) (lambda (e719 r720 w721 s722) ((lambda (tmp723) ((lambda (tmp724) (if tmp724 (apply (lambda (_725 c726) (chi-lambda-clause (source-wrap e719 w721 s722) c726 r720 w721 (lambda (vars727 body728) (list (quote lambda) vars727 body728)))) tmp724) (syntax-error tmp723))) (syntax-dispatch tmp723 (quote (any . any))))) e719))) (global-extend (quote core) (quote let) (letrec ((chi-let (lambda (e729 r730 w731 s732 constructor733 ids734 vals735 exps736) (if (not (valid-bound-ids? ids734)) (syntax-error e729 (quote "duplicate bound variable in")) (let ((labels737 (gen-labels ids734)) (new-vars738 (map gen-var ids734))) (let ((nw (make-binding-wrap ids734 labels737 w731)) (nr (extend-var-env labels737 new-vars738 r730))) (constructor733 s732 new-vars738 (map (lambda (x739) (chi x739 r730 w731)) vals735) (chi-body exps736 (source-wrap e729 nw s732) nr nw)))))))) (lambda (e740 r741 w742 s743) ((lambda (tmp744) ((lambda (tmp745) (if tmp745 (apply (lambda (_746 id747 val748 e1749 e2750) (chi-let e740 r741 w742 s743 build-let id747 val748 (cons e1749 e2750))) tmp745) ((lambda (tmp754) (if (if tmp754 (apply (lambda (_755 f756 id757 val758 e1759 e2760) (id? f756)) tmp754) (quote #f)) (apply (lambda (_761 f762 id763 val764 e1765 e2766) (chi-let e740 r741 w742 s743 build-named-let (cons f762 id763) val764 (cons e1765 e2766))) tmp754) ((lambda (_770) (syntax-error (source-wrap e740 w742 s743))) tmp744))) (syntax-dispatch tmp744 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp744 (quote (any #(each (any any)) any . each-any))))) e740)))) (global-extend (quote core) (quote letrec) (lambda (e771 r772 w773 s774) ((lambda (tmp775) ((lambda (tmp776) (if tmp776 (apply (lambda (_777 id778 val779 e1780 e2781) (let ((ids782 id778)) (if (not (valid-bound-ids? ids782)) (syntax-error e771 (quote "duplicate bound variable in")) (let ((labels784 (gen-labels ids782)) (new-vars785 (map gen-var ids782))) (let ((w786 (make-binding-wrap ids782 labels784 w773)) (r787 (extend-var-env labels784 new-vars785 r772))) (build-letrec s774 new-vars785 (map (lambda (x788) (chi x788 r787 w786)) val779) (chi-body (cons e1780 e2781) (source-wrap e771 w786 s774) r787 w786))))))) tmp776) ((lambda (_791) (syntax-error (source-wrap e771 w773 s774))) tmp775))) (syntax-dispatch tmp775 (quote (any #(each (any any)) any . each-any))))) e771))) (global-extend (quote core) (quote set!) (lambda (e792 r793 w794 s795) ((lambda (tmp796) ((lambda (tmp797) (if (if tmp797 (apply (lambda (_798 id799 val800) (id? id799)) tmp797) (quote #f)) (apply (lambda (_801 id802 val803) (let ((val804 (chi val803 r793 w794)) (n805 (id-var-name id802 w794))) (let ((b806 (lookup n805 r793))) (let ((t807 (binding-type b806))) (if (memv t807 (quote (lexical))) (list (quote set!) (binding-value b806) val804) (if (memv t807 (quote (global))) (list (quote set!) n805 val804) (if (memv t807 (quote (displaced-lexical))) (syntax-error (wrap id802 w794) (quote "identifier out of context")) (syntax-error (source-wrap e792 w794 s795))))))))) tmp797) ((lambda (_808) (syntax-error (source-wrap e792 w794 s795))) tmp796))) (syntax-dispatch tmp796 (quote (any any any))))) e792))) (global-extend (quote begin) (quote begin) (quote ())) (global-extend (quote define) (quote define) (quote ())) (global-extend (quote define-syntax) (quote define-syntax) (quote ())) (global-extend (quote eval-when) (quote eval-when) (quote ())) (global-extend (quote core) (quote syntax-case) (letrec ((gen-syntax-case (lambda (x809 keys clauses r810) (if (null? clauses) (list (quote syntax-error) x809) ((lambda (tmp811) ((lambda (tmp812) (if tmp812 (apply (lambda (pat exp813) (if (and (id? pat) (andmap (lambda (x814) (not (free-id=? pat x814))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) keys))) (let ((labels815 (list (gen-label))) (var816 (gen-var pat))) (list (list (quote lambda) (list var816) (chi exp813 (extend-env labels815 (list (cons (quote syntax) (cons var816 (quote 0)))) r810) (make-binding-wrap (list pat) labels815 (quote (()))))) x809)) (gen-clause x809 keys (cdr clauses) r810 pat (quote #t) exp813))) tmp812) ((lambda (tmp817) (if tmp817 (apply (lambda (pat818 fender exp819) (gen-clause x809 keys (cdr clauses) r810 pat818 fender exp819)) tmp817) ((lambda (_820) (syntax-error (car clauses) (quote "invalid syntax-case clause"))) tmp811))) (syntax-dispatch tmp811 (quote (any any any)))))) (syntax-dispatch tmp811 (quote (any any))))) (car clauses))))) (gen-clause (lambda (x821 keys822 clauses823 r824 pat825 fender826 exp827) (call-with-values (lambda () (convert-pattern pat825 keys822)) (lambda (p828 pvars) (cond ((not (distinct-bound-ids? (map car pvars))) (syntax-error pat825 (quote "duplicate pattern variable in syntax-case pattern"))) ((not (andmap (lambda (x829) (not (ellipsis? (car x829)))) pvars)) (syntax-error pat825 (quote "misplaced ellipsis in syntax-case pattern"))) (else (let ((y830 (gen-var (quote tmp)))) (list (list (quote lambda) (list y830) (let ((y831 y830)) (list (quote if) ((lambda (tmp832) ((lambda (tmp833) (if tmp833 (apply (lambda () y831) tmp833) ((lambda (_834) (list (quote if) y831 (build-dispatch-call pvars fender826 y831 r824) (list (quote quote) (quote #f)))) tmp832))) (syntax-dispatch tmp832 (quote #(atom #t))))) fender826) (build-dispatch-call pvars exp827 y831 r824) (gen-syntax-case x821 keys822 clauses823 r824)))) (if (eq? p828 (quote any)) (list (quote list) x821) (list (quote syntax-dispatch) x821 (list (quote quote) p828))))))))))) (build-dispatch-call (lambda (pvars835 exp836 y837 r838) (let ((ids839 (map car pvars835)) (levels (map cdr pvars835))) (let ((labels840 (gen-labels ids839)) (new-vars841 (map gen-var ids839))) (list (quote apply) (list (quote lambda) new-vars841 (chi exp836 (extend-env labels840 (map (lambda (var842 level843) (cons (quote syntax) (cons var842 level843))) new-vars841 (map cdr pvars835)) r838) (make-binding-wrap ids839 labels840 (quote (()))))) y837))))) (convert-pattern (lambda (pattern keys844) (let cvt ((p845 pattern) (n846 (quote 0)) (ids847 (quote ()))) (if (id? p845) (if (bound-id-member? p845 keys844) (values (vector (quote free-id) p845) ids847) (values (quote any) (cons (cons p845 n846) ids847))) ((lambda (tmp848) ((lambda (tmp849) (if (if tmp849 (apply (lambda (x850 dots851) (ellipsis? dots851)) tmp849) (quote #f)) (apply (lambda (x852 dots853) (call-with-values (lambda () (cvt x852 (fx+ n846 (quote 1)) ids847)) (lambda (p854 ids855) (values (if (eq? p854 (quote any)) (quote each-any) (vector (quote each) p854)) ids855)))) tmp849) ((lambda (tmp856) (if tmp856 (apply (lambda (x857 y858) (call-with-values (lambda () (cvt y858 n846 ids847)) (lambda (y859 ids860) (call-with-values (lambda () (cvt x857 n846 ids860)) (lambda (x861 ids862) (values (cons x861 y859) ids862)))))) tmp856) ((lambda (tmp863) (if tmp863 (apply (lambda () (values (quote ()) ids847)) tmp863) ((lambda (tmp864) (if tmp864 (apply (lambda (x865) (call-with-values (lambda () (cvt x865 n846 ids847)) (lambda (p867 ids868) (values (vector (quote vector) p867) ids868)))) tmp864) ((lambda (x869) (values (vector (quote atom) (strip p845 (quote (())))) ids847)) tmp848))) (syntax-dispatch tmp848 (quote #(vector each-any)))))) (syntax-dispatch tmp848 (quote ()))))) (syntax-dispatch tmp848 (quote (any . any)))))) (syntax-dispatch tmp848 (quote (any any))))) p845)))))) (lambda (e870 r871 w872 s873) (let ((e874 (source-wrap e870 w872 s873))) ((lambda (tmp875) ((lambda (tmp876) (if tmp876 (apply (lambda (_877 val878 key m879) (if (andmap (lambda (x880) (and (id? x880) (not (ellipsis? x880)))) key) (let ((x882 (gen-var (quote tmp)))) (list (list (quote lambda) (list x882) (gen-syntax-case x882 key m879 r871)) (chi val878 r871 (quote (()))))) (syntax-error e874 (quote "invalid literals list in")))) tmp876) (syntax-error tmp875))) (syntax-dispatch tmp875 (quote (any any each-any . each-any))))) e874))))) (set! sc-expand (let ((m885 (quote e)) (esew886 (quote (eval)))) (lambda (x887) (if (and (pair? x887) (equal? (car x887) noexpand)) (cadr x887) (chi-top x887 (quote ()) (quote ((top))) m885 esew886))))) (set! sc-expand3 (let ((m888 (quote e)) (esew889 (quote (eval)))) (lambda (x890 . rest) (if (and (pair? x890) (equal? (car x890) noexpand)) (cadr x890) (chi-top x890 (quote ()) (quote ((top))) (if (null? rest) m888 (car rest)) (if (or (null? rest) (null? (cdr rest))) esew889 (cadr rest))))))) (set! identifier? (lambda (x891) (nonsymbol-id? x891))) (set! datum->syntax-object (lambda (id892 datum) (begin (let ((x893 id892)) (if (not (nonsymbol-id? x893)) (error-hook (quote datum->syntax-object) (quote "invalid argument") x893))) (make-syntax-object datum (syntax-object-wrap id892))))) (set! syntax-object->datum (lambda (x894) (strip x894 (quote (()))))) (set! generate-temporaries (lambda (ls895) (begin (let ((x896 ls895)) (if (not (list? x896)) (error-hook (quote generate-temporaries) (quote "invalid argument") x896))) (map (lambda (x897) (wrap (gensym) (quote ((top))))) ls895)))) (set! free-identifier=? (lambda (x898 y899) (begin (let ((x900 x898)) (if (not (nonsymbol-id? x900)) (error-hook (quote free-identifier=?) (quote "invalid argument") x900))) (let ((x901 y899)) (if (not (nonsymbol-id? x901)) (error-hook (quote free-identifier=?) (quote "invalid argument") x901))) (free-id=? x898 y899)))) (set! bound-identifier=? (lambda (x902 y903) (begin (let ((x904 x902)) (if (not (nonsymbol-id? x904)) (error-hook (quote bound-identifier=?) (quote "invalid argument") x904))) (let ((x905 y903)) (if (not (nonsymbol-id? x905)) (error-hook (quote bound-identifier=?) (quote "invalid argument") x905))) (bound-id=? x902 y903)))) (set! syntax-error (lambda (object . messages) (begin (for-each (lambda (x906) (let ((x907 x906)) (if (not (string? x907)) (error-hook (quote syntax-error) (quote "invalid argument") x907)))) messages) (let ((message (if (null? messages) (quote "invalid syntax") (apply string-append messages)))) (error-hook (quote #f) message (strip object (quote (())))))))) (set! install-global-transformer (lambda (sym908 v909) (begin (let ((x910 sym908)) (if (not (symbol? x910)) (error-hook (quote define-syntax) (quote "invalid argument") x910))) (let ((x911 v909)) (if (not (procedure? x911)) (error-hook (quote define-syntax) (quote "invalid argument") x911))) (global-extend (quote macro) sym908 v909)))) (letrec ((match (lambda (e912 p913 w914 r915) (cond ((not r915) (quote #f)) ((eq? p913 (quote any)) (cons (wrap e912 w914) r915)) ((syntax-object? e912) (match* (let ((e916 (syntax-object-expression e912))) (if (annotation? e916) (annotation-expression e916) e916)) p913 (join-wraps w914 (syntax-object-wrap e912)) r915)) (else (match* (let ((e917 e912)) (if (annotation? e917) (annotation-expression e917) e917)) p913 w914 r915))))) (match* (lambda (e918 p919 w920 r921) (cond ((null? p919) (and (null? e918) r921)) ((pair? p919) (and (pair? e918) (match (car e918) (car p919) w920 (match (cdr e918) (cdr p919) w920 r921)))) ((eq? p919 (quote each-any)) (let ((l (match-each-any e918 w920))) (and l (cons l r921)))) (else (let ((t922 (vector-ref p919 (quote 0)))) (if (memv t922 (quote (each))) (if (null? e918) (match-empty (vector-ref p919 (quote 1)) r921) (let ((l923 (match-each e918 (vector-ref p919 (quote 1)) w920))) (and l923 (let collect ((l924 l923)) (if (null? (car l924)) r921 (cons (map car l924) (collect (map cdr l924)))))))) (if (memv t922 (quote (free-id))) (and (id? e918) (free-id=? (wrap e918 w920) (vector-ref p919 (quote 1))) r921) (if (memv t922 (quote (atom))) (and (equal? (vector-ref p919 (quote 1)) (strip e918 w920)) r921) (if (memv t922 (quote (vector))) (and (vector? e918) (match (vector->list e918) (vector-ref p919 (quote 1)) w920 r921))))))))))) (match-empty (lambda (p925 r926) (cond ((null? p925) r926) ((eq? p925 (quote any)) (cons (quote ()) r926)) ((pair? p925) (match-empty (car p925) (match-empty (cdr p925) r926))) ((eq? p925 (quote each-any)) (cons (quote ()) r926)) (else (let ((t927 (vector-ref p925 (quote 0)))) (if (memv t927 (quote (each))) (match-empty (vector-ref p925 (quote 1)) r926) (if (memv t927 (quote (free-id atom))) r926 (if (memv t927 (quote (vector))) (match-empty (vector-ref p925 (quote 1)) r926))))))))) (match-each-any (lambda (e928 w929) (cond ((annotation? e928) (match-each-any (annotation-expression e928) w929)) ((pair? e928) (let ((l930 (match-each-any (cdr e928) w929))) (and l930 (cons (wrap (car e928) w929) l930)))) ((null? e928) (quote ())) ((syntax-object? e928) (match-each-any (syntax-object-expression e928) (join-wraps w929 (syntax-object-wrap e928)))) (else (quote #f))))) (match-each (lambda (e931 p932 w933) (cond ((annotation? e931) (match-each (annotation-expression e931) p932 w933)) ((pair? e931) (let ((first934 (match (car e931) p932 w933 (quote ())))) (and first934 (let ((rest935 (match-each (cdr e931) p932 w933))) (and rest935 (cons first934 rest935)))))) ((null? e931) (quote ())) ((syntax-object? e931) (match-each (syntax-object-expression e931) p932 (join-wraps w933 (syntax-object-wrap e931)))) (else (quote #f)))))) (set! syntax-dispatch (lambda (e936 p937) (cond ((eq? p937 (quote any)) (list e936)) ((syntax-object? e936) (match* (let ((e938 (syntax-object-expression e936))) (if (annotation? e938) (annotation-expression e938) e938)) p937 (syntax-object-wrap e936) (quote ()))) (else (match* (let ((e939 e936)) (if (annotation? e939) (annotation-expression e939) e939)) p937 (quote (())) (quote ()))))))))) +(letrec ((lambda-var-list (lambda (vars203) (let lvl ((vars204 vars203) (ls (quote ())) (w205 (quote (())))) (cond ((pair? vars204) (lvl (cdr vars204) (cons (wrap (car vars204) w205) ls) w205)) ((id? vars204) (cons (wrap vars204 w205) ls)) ((null? vars204) ls) ((syntax-object? vars204) (lvl (syntax-object-expression vars204) ls (join-wraps w205 (syntax-object-wrap vars204)))) ((annotation? vars204) (lvl (annotation-expression vars204) ls w205)) (else (cons vars204 ls)))))) (gen-var (lambda (id206) (let ((id207 (if (syntax-object? id206) (syntax-object-expression id206) id206))) (if (annotation? id207) (gensym (annotation-expression id207) generated-symbols) (gensym id207 generated-symbols))))) (strip (lambda (x208 w209) (if (memq (quote top) (wrap-marks w209)) (if (or (annotation? x208) (and (pair? x208) (annotation? (car x208)))) (strip-annotation x208 (quote #f)) x208) (let f210 ((x211 x208)) (cond ((syntax-object? x211) (strip (syntax-object-expression x211) (syntax-object-wrap x211))) ((pair? x211) (let ((a (f210 (car x211))) (d (f210 (cdr x211)))) (if (and (eq? a (car x211)) (eq? d (cdr x211))) x211 (cons a d)))) ((vector? x211) (let ((old212 (vector->list x211))) (let ((new213 (map f210 old212))) (if (andmap eq? old212 new213) x211 (list->vector new213))))) (else x211)))))) (strip-annotation (lambda (x214 parent) (cond ((pair? x214) (let ((new215 (cons (quote #f) (quote #f)))) (begin (when parent (set-annotation-stripped! parent new215)) (set-car! new215 (strip-annotation (car x214) (quote #f))) (set-cdr! new215 (strip-annotation (cdr x214) (quote #f))) new215))) ((annotation? x214) (or (annotation-stripped x214) (strip-annotation (annotation-expression x214) x214))) ((vector? x214) (let ((new216 (make-vector (vector-length x214)))) (begin (when parent (set-annotation-stripped! parent new216)) (let loop ((i217 (- (vector-length x214) (quote 1)))) (unless (fx< i217 (quote 0)) (vector-set! new216 i217 (strip-annotation (vector-ref x214 i217) (quote #f))) (loop (fx- i217 (quote 1))))) new216))) (else x214)))) (ellipsis? (lambda (x218) (and (nonsymbol-id? x218) (free-id=? x218 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))))))) (chi-void (lambda () (list (quote void)))) (eval-local-transformer (lambda (expanded) (let ((p (local-eval-hook expanded))) (if (procedure? p) p (syntax-error p (quote "nonprocedure transfomer")))))) (chi-local-syntax (lambda (rec? e219 r w220 s k) ((lambda (tmp221) ((lambda (tmp222) (if tmp222 (apply (lambda (_223 id224 val e1 e2) (let ((ids225 id224)) (if (not (valid-bound-ids? ids225)) (syntax-error e219 (quote "duplicate bound keyword in")) (let ((labels (gen-labels ids225))) (let ((new-w (make-binding-wrap ids225 labels w220))) (k (cons e1 e2) (extend-env labels (let ((w228 (if rec? new-w w220)) (trans-r (macros-only-env r))) (map (lambda (x229) (cons (quote macro) (eval-local-transformer (chi x229 trans-r w228)))) val)) r) new-w s)))))) tmp222) ((lambda (_231) (syntax-error (source-wrap e219 w220 s))) tmp221))) (syntax-dispatch tmp221 (quote (any #(each (any any)) any . each-any))))) e219))) (chi-lambda-clause (lambda (e232 c r233 w234 k235) ((lambda (tmp236) ((lambda (tmp237) (if tmp237 (apply (lambda (id238 e1239 e2240) (let ((ids241 id238)) (if (not (valid-bound-ids? ids241)) (syntax-error e232 (quote "invalid parameter list in")) (let ((labels243 (gen-labels ids241)) (new-vars (map gen-var ids241))) (k235 new-vars (chi-body (cons e1239 e2240) e232 (extend-var-env labels243 new-vars r233) (make-binding-wrap ids241 labels243 w234))))))) tmp237) ((lambda (tmp245) (if tmp245 (apply (lambda (ids246 e1247 e2248) (let ((old-ids (lambda-var-list ids246))) (if (not (valid-bound-ids? old-ids)) (syntax-error e232 (quote "invalid parameter list in")) (let ((labels249 (gen-labels old-ids)) (new-vars250 (map gen-var old-ids))) (k235 (let f251 ((ls1 (cdr new-vars250)) (ls2 (car new-vars250))) (if (null? ls1) ls2 (f251 (cdr ls1) (cons (car ls1) ls2)))) (chi-body (cons e1247 e2248) e232 (extend-var-env labels249 new-vars250 r233) (make-binding-wrap old-ids labels249 w234))))))) tmp245) ((lambda (_253) (syntax-error e232)) tmp236))) (syntax-dispatch tmp236 (quote (any any . each-any)))))) (syntax-dispatch tmp236 (quote (each-any any . each-any))))) c))) (chi-body (lambda (body outer-form r254 w255) (let ((r256 (cons (quote ("placeholder" placeholder)) r254))) (let ((ribcage (make-ribcage (quote ()) (quote ()) (quote ())))) (let ((w257 (make-wrap (wrap-marks w255) (cons ribcage (wrap-subst w255))))) (let parse ((body258 (map (lambda (x262) (cons r256 (wrap x262 w257))) body)) (ids259 (quote ())) (labels260 (quote ())) (vars261 (quote ())) (vals (quote ())) (bindings (quote ()))) (if (null? body258) (syntax-error outer-form (quote "no expressions in body")) (let ((e263 (cdar body258)) (er (caar body258))) (call-with-values (lambda () (syntax-type e263 er (quote (())) (quote #f) ribcage)) (lambda (type264 value265 e266 w267 s268) (let ((t type264)) (if (memv t (quote (define-form))) (let ((id269 (wrap value265 w267)) (label (gen-label))) (let ((var270 (gen-var id269))) (begin (extend-ribcage! ribcage id269 label) (parse (cdr body258) (cons id269 ids259) (cons label labels260) (cons var270 vars261) (cons (cons er (wrap e266 w267)) vals) (cons (cons (quote lexical) var270) bindings))))) (if (memv t (quote (define-syntax-form))) (let ((id271 (wrap value265 w267)) (label272 (gen-label))) (begin (extend-ribcage! ribcage id271 label272) (parse (cdr body258) (cons id271 ids259) (cons label272 labels260) vars261 vals (cons (cons (quote macro) (cons er (wrap e266 w267))) bindings)))) (if (memv t (quote (begin-form))) ((lambda (tmp273) ((lambda (tmp274) (if tmp274 (apply (lambda (_275 e1276) (parse (let f277 ((forms e1276)) (if (null? forms) (cdr body258) (cons (cons er (wrap (car forms) w267)) (f277 (cdr forms))))) ids259 labels260 vars261 vals bindings)) tmp274) (syntax-error tmp273))) (syntax-dispatch tmp273 (quote (any . each-any))))) e266) (if (memv t (quote (local-syntax-form))) (chi-local-syntax value265 e266 er w267 s268 (lambda (forms279 er280 w281 s282) (parse (let f283 ((forms284 forms279)) (if (null? forms284) (cdr body258) (cons (cons er280 (wrap (car forms284) w281)) (f283 (cdr forms284))))) ids259 labels260 vars261 vals bindings))) (if (null? ids259) (build-sequence (quote #f) (map (lambda (x285) (chi (cdr x285) (car x285) (quote (())))) (cons (cons er (source-wrap e266 w267 s268)) (cdr body258)))) (begin (if (not (valid-bound-ids? ids259)) (syntax-error outer-form (quote "invalid or duplicate identifier in definition"))) (let loop286 ((bs bindings) (er-cache (quote #f)) (r-cache (quote #f))) (if (not (null? bs)) (let ((b (car bs))) (if (eq? (car b) (quote macro)) (let ((er287 (cadr b))) (let ((r-cache288 (if (eq? er287 er-cache) r-cache (macros-only-env er287)))) (begin (set-cdr! b (eval-local-transformer (chi (cddr b) r-cache288 (quote (()))))) (loop286 (cdr bs) er287 r-cache288)))) (loop286 (cdr bs) er-cache r-cache))))) (set-cdr! r256 (extend-env labels260 bindings (cdr r256))) (build-letrec (quote #f) vars261 (map (lambda (x289) (chi (cdr x289) (car x289) (quote (())))) vals) (build-sequence (quote #f) (map (lambda (x290) (chi (cdr x290) (car x290) (quote (())))) (cons (cons er (source-wrap e266 w267 s268)) (cdr body258)))))))))))))))))))))) (chi-macro (lambda (p291 e292 r293 w294 rib) (letrec ((rebuild-macro-output (lambda (x295 m) (cond ((pair? x295) (cons (rebuild-macro-output (car x295) m) (rebuild-macro-output (cdr x295) m))) ((syntax-object? x295) (let ((w296 (syntax-object-wrap x295))) (let ((ms (wrap-marks w296)) (s297 (wrap-subst w296))) (make-syntax-object (syntax-object-expression x295) (if (and (pair? ms) (eq? (car ms) (quote #f))) (make-wrap (cdr ms) (if rib (cons rib (cdr s297)) (cdr s297))) (make-wrap (cons m ms) (if rib (cons rib (cons (quote shift) s297)) (cons (quote shift) s297)))))))) ((vector? x295) (let ((n (vector-length x295))) (let ((v (make-vector n))) (let doloop ((i298 (quote 0))) (if (fx= i298 n) v (begin (vector-set! v i298 (rebuild-macro-output (vector-ref x295 i298) m)) (doloop (fx+ i298 (quote 1))))))))) ((symbol? x295) (syntax-error x295 (quote "encountered raw symbol in macro output"))) (else x295))))) (rebuild-macro-output (p291 (wrap e292 (anti-mark w294))) (string (quote #\m)))))) (chi-application (lambda (x299 e300 r301 w302 s303) ((lambda (tmp304) ((lambda (tmp305) (if tmp305 (apply (lambda (e0 e1306) (cons x299 (map (lambda (e307) (chi e307 r301 w302)) e1306))) tmp305) (syntax-error tmp304))) (syntax-dispatch tmp304 (quote (any . each-any))))) e300))) (chi-expr (lambda (type309 value310 e311 r312 w313 s314) (let ((t315 type309)) (if (memv t315 (quote (lexical))) value310 (if (memv t315 (quote (core))) (value310 e311 r312 w313 s314) (if (memv t315 (quote (lexical-call))) (chi-application value310 e311 r312 w313 s314) (if (memv t315 (quote (global-call))) (chi-application value310 e311 r312 w313 s314) (if (memv t315 (quote (constant))) (list (quote quote) (strip (source-wrap e311 w313 s314) (quote (())))) (if (memv t315 (quote (global))) value310 (if (memv t315 (quote (call))) (chi-application (chi (car e311) r312 w313) e311 r312 w313 s314) (if (memv t315 (quote (begin-form))) ((lambda (tmp316) ((lambda (tmp317) (if tmp317 (apply (lambda (_318 e1319 e2320) (chi-sequence (cons e1319 e2320) r312 w313 s314)) tmp317) (syntax-error tmp316))) (syntax-dispatch tmp316 (quote (any any . each-any))))) e311) (if (memv t315 (quote (local-syntax-form))) (chi-local-syntax value310 e311 r312 w313 s314 chi-sequence) (if (memv t315 (quote (eval-when-form))) ((lambda (tmp322) ((lambda (tmp323) (if tmp323 (apply (lambda (_324 x325 e1326 e2327) (let ((when-list (chi-when-list e311 x325 w313))) (if (memq (quote eval) when-list) (chi-sequence (cons e1326 e2327) r312 w313 s314) (chi-void)))) tmp323) (syntax-error tmp322))) (syntax-dispatch tmp322 (quote (any each-any any . each-any))))) e311) (if (memv t315 (quote (define-form define-syntax-form))) (syntax-error (wrap value310 w313) (quote "invalid context for definition of")) (if (memv t315 (quote (syntax))) (syntax-error (source-wrap e311 w313 s314) (quote "reference to pattern variable outside syntax form")) (if (memv t315 (quote (displaced-lexical))) (syntax-error (source-wrap e311 w313 s314) (quote "reference to identifier outside its scope")) (syntax-error (source-wrap e311 w313 s314)))))))))))))))))) (chi (lambda (e330 r331 w332) (call-with-values (lambda () (syntax-type e330 r331 w332 (quote #f) (quote #f))) (lambda (type333 value334 e335 w336 s337) (chi-expr type333 value334 e335 r331 w336 s337))))) (chi-top (lambda (e338 r339 w340 m341 esew) (call-with-values (lambda () (syntax-type e338 r339 w340 (quote #f) (quote #f))) (lambda (type348 value349 e350 w351 s352) (let ((t353 type348)) (if (memv t353 (quote (begin-form))) ((lambda (tmp354) ((lambda (tmp355) (if tmp355 (apply (lambda (_356) (chi-void)) tmp355) ((lambda (tmp357) (if tmp357 (apply (lambda (_358 e1359 e2360) (chi-top-sequence (cons e1359 e2360) r339 w351 s352 m341 esew)) tmp357) (syntax-error tmp354))) (syntax-dispatch tmp354 (quote (any any . each-any)))))) (syntax-dispatch tmp354 (quote (any))))) e350) (if (memv t353 (quote (local-syntax-form))) (chi-local-syntax value349 e350 r339 w351 s352 (lambda (body362 r363 w364 s365) (chi-top-sequence body362 r363 w364 s365 m341 esew))) (if (memv t353 (quote (eval-when-form))) ((lambda (tmp366) ((lambda (tmp367) (if tmp367 (apply (lambda (_368 x369 e1370 e2371) (let ((when-list372 (chi-when-list e350 x369 w351)) (body373 (cons e1370 e2371))) (cond ((eq? m341 (quote e)) (if (memq (quote eval) when-list372) (chi-top-sequence body373 r339 w351 s352 (quote e) (quote (eval))) (chi-void))) ((memq (quote load) when-list372) (if (or (memq (quote compile) when-list372) (and (eq? m341 (quote c&e)) (memq (quote eval) when-list372))) (chi-top-sequence body373 r339 w351 s352 (quote c&e) (quote (compile load))) (if (memq m341 (quote (c c&e))) (chi-top-sequence body373 r339 w351 s352 (quote c) (quote (load))) (chi-void)))) ((or (memq (quote compile) when-list372) (and (eq? m341 (quote c&e)) (memq (quote eval) when-list372))) (top-level-eval-hook (chi-top-sequence body373 r339 w351 s352 (quote e) (quote (eval)))) (chi-void)) (else (chi-void))))) tmp367) (syntax-error tmp366))) (syntax-dispatch tmp366 (quote (any each-any any . each-any))))) e350) (if (memv t353 (quote (define-syntax-form))) (let ((n376 (id-var-name value349 w351)) (r377 (macros-only-env r339))) (let ((t378 m341)) (if (memv t378 (quote (c))) (if (memq (quote compile) esew) (let ((e379 (chi-install-global n376 (chi e350 r377 w351)))) (begin (top-level-eval-hook e379) (if (memq (quote load) esew) e379 (chi-void)))) (if (memq (quote load) esew) (chi-install-global n376 (chi e350 r377 w351)) (chi-void))) (if (memv t378 (quote (c&e))) (let ((e380 (chi-install-global n376 (chi e350 r377 w351)))) (begin (top-level-eval-hook e380) e380)) (begin (if (memq (quote eval) esew) (top-level-eval-hook (chi-install-global n376 (chi e350 r377 w351)))) (chi-void)))))) (if (memv t353 (quote (define-form))) (let ((n381 (id-var-name value349 w351))) (let ((t382 (binding-type (lookup n381 r339)))) (if (memv t382 (quote (global))) (let ((x383 (list (quote define) n381 (chi e350 r339 w351)))) (begin (if (eq? m341 (quote c&e)) (top-level-eval-hook x383)) x383)) (if (memv t382 (quote (displaced-lexical))) (syntax-error (wrap value349 w351) (quote "identifier out of context")) (syntax-error (wrap value349 w351) (quote "cannot define keyword at top level")))))) (let ((x384 (chi-expr type348 value349 e350 r339 w351 s352))) (begin (if (eq? m341 (quote c&e)) (top-level-eval-hook x384)) x384)))))))))))) (syntax-type (lambda (e385 r386 w387 s388 rib389) (cond ((symbol? e385) (let ((n390 (id-var-name e385 w387))) (let ((b391 (lookup n390 r386))) (let ((type392 (binding-type b391))) (let ((t393 type392)) (if (memv t393 (quote (lexical))) (values type392 (binding-value b391) e385 w387 s388) (if (memv t393 (quote (global))) (values type392 n390 e385 w387 s388) (if (memv t393 (quote (macro))) (syntax-type (chi-macro (binding-value b391) e385 r386 w387 rib389) r386 (quote (())) s388 rib389) (values type392 (binding-value b391) e385 w387 s388))))))))) ((pair? e385) (let ((first (car e385))) (if (id? first) (let ((n394 (id-var-name first w387))) (let ((b395 (lookup n394 r386))) (let ((type396 (binding-type b395))) (let ((t397 type396)) (if (memv t397 (quote (lexical))) (values (quote lexical-call) (binding-value b395) e385 w387 s388) (if (memv t397 (quote (global))) (values (quote global-call) n394 e385 w387 s388) (if (memv t397 (quote (macro))) (syntax-type (chi-macro (binding-value b395) e385 r386 w387 rib389) r386 (quote (())) s388 rib389) (if (memv t397 (quote (core))) (values type396 (binding-value b395) e385 w387 s388) (if (memv t397 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value b395) e385 w387 s388) (if (memv t397 (quote (begin))) (values (quote begin-form) (quote #f) e385 w387 s388) (if (memv t397 (quote (eval-when))) (values (quote eval-when-form) (quote #f) e385 w387 s388) (if (memv t397 (quote (define))) ((lambda (tmp398) ((lambda (tmp399) (if (if tmp399 (apply (lambda (_400 name401 val402) (id? name401)) tmp399) (quote #f)) (apply (lambda (_403 name404 val405) (values (quote define-form) name404 val405 w387 s388)) tmp399) ((lambda (tmp406) (if (if tmp406 (apply (lambda (_407 name408 args409 e1410 e2411) (and (id? name408) (or (valid-bound-ids? (lambda-var-list args409)) (id? (lambda-var-list args409))))) tmp406) (quote #f)) (apply (lambda (_412 name413 args414 e1415 e2416) (values (quote define-form) (wrap name413 w387) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) (wrap (cons args414 (cons e1415 e2416)) w387)) (quote (())) s388)) tmp406) ((lambda (tmp418) (if (if tmp418 (apply (lambda (_419 name420) (id? name420)) tmp418) (quote #f)) (apply (lambda (_421 name422) (values (quote define-form) (wrap name422 w387) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote (())) s388)) tmp418) (syntax-error tmp398))) (syntax-dispatch tmp398 (quote (any any)))))) (syntax-dispatch tmp398 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp398 (quote (any any any))))) e385) (if (memv t397 (quote (define-syntax))) ((lambda (tmp423) ((lambda (tmp424) (if (if tmp424 (apply (lambda (_425 name426 val427) (id? name426)) tmp424) (quote #f)) (apply (lambda (_428 name429 val430) (values (quote define-syntax-form) name429 val430 w387 s388)) tmp424) (syntax-error tmp423))) (syntax-dispatch tmp423 (quote (any any any))))) e385) (values (quote call) (quote #f) e385 w387 s388)))))))))))))) (values (quote call) (quote #f) e385 w387 s388)))) ((syntax-object? e385) (syntax-type (syntax-object-expression e385) r386 (join-wraps w387 (syntax-object-wrap e385)) (quote #f) rib389)) ((annotation? e385) (syntax-type (annotation-expression e385) r386 w387 (annotation-source e385) rib389)) ((let ((x431 e385)) (or (boolean? x431) (number? x431) (string? x431) (char? x431) (null? x431) (keyword? x431))) (values (quote constant) (quote #f) e385 w387 s388)) (else (values (quote other) (quote #f) e385 w387 s388))))) (chi-when-list (lambda (e432 when-list433 w434) (let f435 ((when-list436 when-list433) (situations (quote ()))) (if (null? when-list436) situations (f435 (cdr when-list436) (cons (let ((x437 (car when-list436))) (cond ((free-id=? x437 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote compile)) ((free-id=? x437 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote load)) ((free-id=? x437 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote eval)) (else (syntax-error (wrap x437 w434) (quote "invalid eval-when situation"))))) situations)))))) (chi-install-global (lambda (name438 e439) (list (quote install-global-transformer) (list (quote quote) name438) e439))) (chi-top-sequence (lambda (body440 r441 w442 s443 m444 esew445) (build-sequence s443 (let dobody ((body446 body440) (r447 r441) (w448 w442) (m449 m444) (esew450 esew445)) (if (null? body446) (quote ()) (let ((first451 (chi-top (car body446) r447 w448 m449 esew450))) (cons first451 (dobody (cdr body446) r447 w448 m449 esew450)))))))) (chi-sequence (lambda (body452 r453 w454 s455) (build-sequence s455 (let dobody456 ((body457 body452) (r458 r453) (w459 w454)) (if (null? body457) (quote ()) (let ((first460 (chi (car body457) r458 w459))) (cons first460 (dobody456 (cdr body457) r458 w459)))))))) (source-wrap (lambda (x461 w462 s463) (wrap (if s463 (make-annotation x461 s463 (quote #f)) x461) w462))) (wrap (lambda (x464 w465) (cond ((and (null? (wrap-marks w465)) (null? (wrap-subst w465))) x464) ((syntax-object? x464) (make-syntax-object (syntax-object-expression x464) (join-wraps w465 (syntax-object-wrap x464)))) ((null? x464) x464) (else (make-syntax-object x464 w465))))) (bound-id-member? (lambda (x466 list) (and (not (null? list)) (or (bound-id=? x466 (car list)) (bound-id-member? x466 (cdr list)))))) (distinct-bound-ids? (lambda (ids467) (let distinct? ((ids468 ids467)) (or (null? ids468) (and (not (bound-id-member? (car ids468) (cdr ids468))) (distinct? (cdr ids468))))))) (valid-bound-ids? (lambda (ids469) (and (let all-ids? ((ids470 ids469)) (or (null? ids470) (and (id? (car ids470)) (all-ids? (cdr ids470))))) (distinct-bound-ids? ids469)))) (bound-id=? (lambda (i471 j) (if (and (syntax-object? i471) (syntax-object? j)) (and (eq? (let ((e472 (syntax-object-expression i471))) (if (annotation? e472) (annotation-expression e472) e472)) (let ((e473 (syntax-object-expression j))) (if (annotation? e473) (annotation-expression e473) e473))) (same-marks? (wrap-marks (syntax-object-wrap i471)) (wrap-marks (syntax-object-wrap j)))) (eq? (let ((e474 i471)) (if (annotation? e474) (annotation-expression e474) e474)) (let ((e475 j)) (if (annotation? e475) (annotation-expression e475) e475)))))) (free-id=? (lambda (i476 j477) (and (eq? (let ((x478 i476)) (let ((e479 (if (syntax-object? x478) (syntax-object-expression x478) x478))) (if (annotation? e479) (annotation-expression e479) e479))) (let ((x480 j477)) (let ((e481 (if (syntax-object? x480) (syntax-object-expression x480) x480))) (if (annotation? e481) (annotation-expression e481) e481)))) (eq? (id-var-name i476 (quote (()))) (id-var-name j477 (quote (()))))))) (id-var-name (lambda (id482 w483) (letrec ((search-vector-rib (lambda (sym subst marks489 symnames ribcage490) (let ((n491 (vector-length symnames))) (let f492 ((i493 (quote 0))) (cond ((fx= i493 n491) (search sym (cdr subst) marks489)) ((and (eq? (vector-ref symnames i493) sym) (same-marks? marks489 (vector-ref (ribcage-marks ribcage490) i493))) (values (vector-ref (ribcage-labels ribcage490) i493) marks489)) (else (f492 (fx+ i493 (quote 1))))))))) (search-list-rib (lambda (sym494 subst495 marks496 symnames497 ribcage498) (let f499 ((symnames500 symnames497) (i501 (quote 0))) (cond ((null? symnames500) (search sym494 (cdr subst495) marks496)) ((and (eq? (car symnames500) sym494) (same-marks? marks496 (list-ref (ribcage-marks ribcage498) i501))) (values (list-ref (ribcage-labels ribcage498) i501) marks496)) (else (f499 (cdr symnames500) (fx+ i501 (quote 1)))))))) (search (lambda (sym502 subst503 marks504) (if (null? subst503) (values (quote #f) marks504) (let ((fst (car subst503))) (if (eq? fst (quote shift)) (search sym502 (cdr subst503) (cdr marks504)) (let ((symnames505 (ribcage-symnames fst))) (if (vector? symnames505) (search-vector-rib sym502 subst503 marks504 symnames505 fst) (search-list-rib sym502 subst503 marks504 symnames505 fst))))))))) (cond ((symbol? id482) (or (call-with-values (lambda () (search id482 (wrap-subst w483) (wrap-marks w483))) (lambda (x506 . ignore) x506)) id482)) ((syntax-object? id482) (let ((id507 (let ((e508 (syntax-object-expression id482))) (if (annotation? e508) (annotation-expression e508) e508))) (w1 (syntax-object-wrap id482))) (let ((marks509 (join-marks (wrap-marks w483) (wrap-marks w1)))) (call-with-values (lambda () (search id507 (wrap-subst w483) marks509)) (lambda (new-id marks510) (or new-id (call-with-values (lambda () (search id507 (wrap-subst w1) marks510)) (lambda (x512 . ignore511) x512)) id507)))))) ((annotation? id482) (let ((id513 (let ((e514 id482)) (if (annotation? e514) (annotation-expression e514) e514)))) (or (call-with-values (lambda () (search id513 (wrap-subst w483) (wrap-marks w483))) (lambda (x516 . ignore515) x516)) id513))) (else (error-hook (quote id-var-name) (quote "invalid id") id482)))))) (same-marks? (lambda (x517 y) (or (eq? x517 y) (and (not (null? x517)) (not (null? y)) (eq? (car x517) (car y)) (same-marks? (cdr x517) (cdr y)))))) (join-marks (lambda (m1 m2) (smart-append m1 m2))) (join-wraps (lambda (w1518 w2) (let ((m1519 (wrap-marks w1518)) (s1 (wrap-subst w1518))) (if (null? m1519) (if (null? s1) w2 (make-wrap (wrap-marks w2) (smart-append s1 (wrap-subst w2)))) (make-wrap (smart-append m1519 (wrap-marks w2)) (smart-append s1 (wrap-subst w2))))))) (smart-append (lambda (m1520 m2521) (if (null? m2521) m1520 (append m1520 m2521)))) (make-binding-wrap (lambda (ids522 labels523 w524) (if (null? ids522) w524 (make-wrap (wrap-marks w524) (cons (let ((labelvec (list->vector labels523))) (let ((n525 (vector-length labelvec))) (let ((symnamevec (make-vector n525)) (marksvec (make-vector n525))) (begin (let f526 ((ids527 ids522) (i528 (quote 0))) (if (not (null? ids527)) (call-with-values (lambda () (id-sym-name&marks (car ids527) w524)) (lambda (symname marks529) (begin (vector-set! symnamevec i528 symname) (vector-set! marksvec i528 marks529) (f526 (cdr ids527) (fx+ i528 (quote 1)))))))) (make-ribcage symnamevec marksvec labelvec))))) (wrap-subst w524)))))) (extend-ribcage! (lambda (ribcage530 id531 label532) (begin (set-ribcage-symnames! ribcage530 (cons (let ((e533 (syntax-object-expression id531))) (if (annotation? e533) (annotation-expression e533) e533)) (ribcage-symnames ribcage530))) (set-ribcage-marks! ribcage530 (cons (wrap-marks (syntax-object-wrap id531)) (ribcage-marks ribcage530))) (set-ribcage-labels! ribcage530 (cons label532 (ribcage-labels ribcage530)))))) (anti-mark (lambda (w534) (make-wrap (cons (quote #f) (wrap-marks w534)) (cons (quote shift) (wrap-subst w534))))) (set-ribcage-labels! (lambda (x535 update) (vector-set! x535 (quote 3) update))) (set-ribcage-marks! (lambda (x536 update537) (vector-set! x536 (quote 2) update537))) (set-ribcage-symnames! (lambda (x538 update539) (vector-set! x538 (quote 1) update539))) (ribcage-labels (lambda (x540) (vector-ref x540 (quote 3)))) (ribcage-marks (lambda (x541) (vector-ref x541 (quote 2)))) (ribcage-symnames (lambda (x542) (vector-ref x542 (quote 1)))) (ribcage? (lambda (x543) (and (vector? x543) (= (vector-length x543) (quote 4)) (eq? (vector-ref x543 (quote 0)) (quote ribcage))))) (make-ribcage (lambda (symnames544 marks545 labels546) (vector (quote ribcage) symnames544 marks545 labels546))) (gen-labels (lambda (ls547) (if (null? ls547) (quote ()) (cons (gen-label) (gen-labels (cdr ls547)))))) (gen-label (lambda () (string (quote #\i)))) (wrap-subst cdr) (wrap-marks car) (make-wrap cons) (id-sym-name&marks (lambda (x548 w549) (if (syntax-object? x548) (values (let ((e550 (syntax-object-expression x548))) (if (annotation? e550) (annotation-expression e550) e550)) (join-marks (wrap-marks w549) (wrap-marks (syntax-object-wrap x548)))) (values (let ((e551 x548)) (if (annotation? e551) (annotation-expression e551) e551)) (wrap-marks w549))))) (id? (lambda (x552) (cond ((symbol? x552) (quote #t)) ((syntax-object? x552) (symbol? (let ((e553 (syntax-object-expression x552))) (if (annotation? e553) (annotation-expression e553) e553)))) ((annotation? x552) (symbol? (annotation-expression x552))) (else (quote #f))))) (nonsymbol-id? (lambda (x554) (and (syntax-object? x554) (symbol? (let ((e555 (syntax-object-expression x554))) (if (annotation? e555) (annotation-expression e555) e555)))))) (global-extend (lambda (type556 sym557 val558) (put-global-definition-hook sym557 (cons type556 val558)))) (lookup (lambda (x559 r560) (cond ((assq x559 r560) => cdr) ((symbol? x559) (or (get-global-definition-hook x559) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env (lambda (r561) (if (null? r561) (quote ()) (let ((a562 (car r561))) (if (eq? (cadr a562) (quote macro)) (cons a562 (macros-only-env (cdr r561))) (macros-only-env (cdr r561))))))) (extend-var-env (lambda (labels563 vars564 r565) (if (null? labels563) r565 (extend-var-env (cdr labels563) (cdr vars564) (cons (cons (car labels563) (cons (quote lexical) (car vars564))) r565))))) (extend-env (lambda (labels566 bindings567 r568) (if (null? labels566) r568 (extend-env (cdr labels566) (cdr bindings567) (cons (cons (car labels566) (car bindings567)) r568))))) (binding-value cdr) (binding-type car) (source-annotation (lambda (x569) (cond ((annotation? x569) (annotation-source x569)) ((syntax-object? x569) (source-annotation (syntax-object-expression x569))) (else (quote #f))))) (set-syntax-object-wrap! (lambda (x570 update571) (vector-set! x570 (quote 2) update571))) (set-syntax-object-expression! (lambda (x572 update573) (vector-set! x572 (quote 1) update573))) (syntax-object-wrap (lambda (x574) (vector-ref x574 (quote 2)))) (syntax-object-expression (lambda (x575) (vector-ref x575 (quote 1)))) (syntax-object? (lambda (x576) (and (vector? x576) (= (vector-length x576) (quote 3)) (eq? (vector-ref x576 (quote 0)) (quote syntax-object))))) (make-syntax-object (lambda (expression wrap577) (vector (quote syntax-object) expression wrap577))) (build-letrec (lambda (src578 vars579 val-exps body-exp) (if (null? vars579) body-exp (list (quote letrec) (map list vars579 val-exps) body-exp)))) (build-named-let (lambda (src580 vars581 val-exps582 body-exp583) (if (null? vars581) body-exp583 (list (quote let) (car vars581) (map list (cdr vars581) val-exps582) body-exp583)))) (build-let (lambda (src584 vars585 val-exps586 body-exp587) (if (null? vars585) body-exp587 (list (quote let) (map list vars585 val-exps586) body-exp587)))) (build-sequence (lambda (src588 exps) (if (null? (cdr exps)) (car exps) (cons (quote begin) exps)))) (get-global-definition-hook (lambda (symbol) (getprop symbol (quote *sc-expander*)))) (put-global-definition-hook (lambda (symbol589 binding) (putprop symbol589 (quote *sc-expander*) binding))) (error-hook (lambda (who590 why what) (error who590 (quote "~a ~s") why what))) (local-eval-hook (lambda (x591) (eval (list noexpand x591) (interaction-environment)))) (top-level-eval-hook (lambda (x592) (eval (list noexpand x592) (interaction-environment)))) (annotation? (lambda (x593) (quote #f))) (fx< <) (fx= =) (fx- -) (fx+ +) (noexpand (quote "noexpand"))) (begin (global-extend (quote local-syntax) (quote letrec-syntax) (quote #t)) (global-extend (quote local-syntax) (quote let-syntax) (quote #f)) (global-extend (quote core) (quote fluid-let-syntax) (lambda (e594 r595 w596 s597) ((lambda (tmp598) ((lambda (tmp599) (if (if tmp599 (apply (lambda (_600 var601 val602 e1603 e2604) (valid-bound-ids? var601)) tmp599) (quote #f)) (apply (lambda (_606 var607 val608 e1609 e2610) (let ((names (map (lambda (x611) (id-var-name x611 w596)) var607))) (begin (for-each (lambda (id613 n614) (let ((t615 (binding-type (lookup n614 r595)))) (if (memv t615 (quote (displaced-lexical))) (syntax-error (source-wrap id613 w596 s597) (quote "identifier out of context"))))) var607 names) (chi-body (cons e1609 e2610) (source-wrap e594 w596 s597) (extend-env names (let ((trans-r618 (macros-only-env r595))) (map (lambda (x619) (cons (quote macro) (eval-local-transformer (chi x619 trans-r618 w596)))) val608)) r595) w596)))) tmp599) ((lambda (_621) (syntax-error (source-wrap e594 w596 s597))) tmp598))) (syntax-dispatch tmp598 (quote (any #(each (any any)) any . each-any))))) e594))) (global-extend (quote core) (quote quote) (lambda (e622 r623 w624 s625) ((lambda (tmp626) ((lambda (tmp627) (if tmp627 (apply (lambda (_628 e629) (list (quote quote) (strip e629 w624))) tmp627) ((lambda (_630) (syntax-error (source-wrap e622 w624 s625))) tmp626))) (syntax-dispatch tmp626 (quote (any any))))) e622))) (global-extend (quote core) (quote syntax) (letrec ((regen (lambda (x631) (let ((t632 (car x631))) (if (memv t632 (quote (ref))) (cadr x631) (if (memv t632 (quote (primitive))) (cadr x631) (if (memv t632 (quote (quote))) (list (quote quote) (cadr x631)) (if (memv t632 (quote (lambda))) (list (quote lambda) (cadr x631) (regen (caddr x631))) (if (memv t632 (quote (map))) (let ((ls633 (map regen (cdr x631)))) (cons (if (fx= (length ls633) (quote 2)) (quote map) (quote map)) ls633)) (cons (car x631) (map regen (cdr x631))))))))))) (gen-vector (lambda (x634) (cond ((eq? (car x634) (quote list)) (cons (quote vector) (cdr x634))) ((eq? (car x634) (quote quote)) (list (quote quote) (list->vector (cadr x634)))) (else (list (quote list->vector) x634))))) (gen-append (lambda (x635 y636) (if (equal? y636 (quote (quote ()))) x635 (list (quote append) x635 y636)))) (gen-cons (lambda (x637 y638) (let ((t639 (car y638))) (if (memv t639 (quote (quote))) (if (eq? (car x637) (quote quote)) (list (quote quote) (cons (cadr x637) (cadr y638))) (if (eq? (cadr y638) (quote ())) (list (quote list) x637) (list (quote cons) x637 y638))) (if (memv t639 (quote (list))) (cons (quote list) (cons x637 (cdr y638))) (list (quote cons) x637 y638)))))) (gen-map (lambda (e640 map-env) (let ((formals (map cdr map-env)) (actuals (map (lambda (x641) (list (quote ref) (car x641))) map-env))) (cond ((eq? (car e640) (quote ref)) (car actuals)) ((andmap (lambda (x642) (and (eq? (car x642) (quote ref)) (memq (cadr x642) formals))) (cdr e640)) (cons (quote map) (cons (list (quote primitive) (car e640)) (map (let ((r643 (map cons formals actuals))) (lambda (x644) (cdr (assq (cadr x644) r643)))) (cdr e640))))) (else (cons (quote map) (cons (list (quote lambda) formals e640) actuals))))))) (gen-mappend (lambda (e645 map-env646) (list (quote apply) (quote (primitive append)) (gen-map e645 map-env646)))) (gen-ref (lambda (src647 var648 level649 maps) (if (fx= level649 (quote 0)) (values var648 maps) (if (null? maps) (syntax-error src647 (quote "missing ellipsis in syntax form")) (call-with-values (lambda () (gen-ref src647 var648 (fx- level649 (quote 1)) (cdr maps))) (lambda (outer-var outer-maps) (let ((b650 (assq outer-var (car maps)))) (if b650 (values (cdr b650) maps) (let ((inner-var (gen-var (quote tmp)))) (values inner-var (cons (cons (cons outer-var inner-var) (car maps)) outer-maps))))))))))) (gen-syntax (lambda (src651 e652 r653 maps654 ellipsis?655) (if (id? e652) (let ((label656 (id-var-name e652 (quote (()))))) (let ((b657 (lookup label656 r653))) (if (eq? (binding-type b657) (quote syntax)) (call-with-values (lambda () (let ((var.lev (binding-value b657))) (gen-ref src651 (car var.lev) (cdr var.lev) maps654))) (lambda (var658 maps659) (values (list (quote ref) var658) maps659))) (if (ellipsis?655 e652) (syntax-error src651 (quote "misplaced ellipsis in syntax form")) (values (list (quote quote) e652) maps654))))) ((lambda (tmp660) ((lambda (tmp661) (if (if tmp661 (apply (lambda (dots e662) (ellipsis?655 dots)) tmp661) (quote #f)) (apply (lambda (dots663 e664) (gen-syntax src651 e664 r653 maps654 (lambda (x665) (quote #f)))) tmp661) ((lambda (tmp666) (if (if tmp666 (apply (lambda (x667 dots668 y669) (ellipsis?655 dots668)) tmp666) (quote #f)) (apply (lambda (x670 dots671 y672) (let f673 ((y674 y672) (k675 (lambda (maps676) (call-with-values (lambda () (gen-syntax src651 x670 r653 (cons (quote ()) maps676) ellipsis?655)) (lambda (x677 maps678) (if (null? (car maps678)) (syntax-error src651 (quote "extra ellipsis in syntax form")) (values (gen-map x677 (car maps678)) (cdr maps678)))))))) ((lambda (tmp679) ((lambda (tmp680) (if (if tmp680 (apply (lambda (dots681 y682) (ellipsis?655 dots681)) tmp680) (quote #f)) (apply (lambda (dots683 y684) (f673 y684 (lambda (maps685) (call-with-values (lambda () (k675 (cons (quote ()) maps685))) (lambda (x686 maps687) (if (null? (car maps687)) (syntax-error src651 (quote "extra ellipsis in syntax form")) (values (gen-mappend x686 (car maps687)) (cdr maps687)))))))) tmp680) ((lambda (_688) (call-with-values (lambda () (gen-syntax src651 y674 r653 maps654 ellipsis?655)) (lambda (y689 maps690) (call-with-values (lambda () (k675 maps690)) (lambda (x691 maps692) (values (gen-append x691 y689) maps692)))))) tmp679))) (syntax-dispatch tmp679 (quote (any . any))))) y674))) tmp666) ((lambda (tmp693) (if tmp693 (apply (lambda (x694 y695) (call-with-values (lambda () (gen-syntax src651 x694 r653 maps654 ellipsis?655)) (lambda (x696 maps697) (call-with-values (lambda () (gen-syntax src651 y695 r653 maps697 ellipsis?655)) (lambda (y698 maps699) (values (gen-cons x696 y698) maps699)))))) tmp693) ((lambda (tmp700) (if tmp700 (apply (lambda (e1701 e2702) (call-with-values (lambda () (gen-syntax src651 (cons e1701 e2702) r653 maps654 ellipsis?655)) (lambda (e704 maps705) (values (gen-vector e704) maps705)))) tmp700) ((lambda (_706) (values (list (quote quote) e652) maps654)) tmp660))) (syntax-dispatch tmp660 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp660 (quote (any . any)))))) (syntax-dispatch tmp660 (quote (any any . any)))))) (syntax-dispatch tmp660 (quote (any any))))) e652))))) (lambda (e707 r708 w709 s710) (let ((e711 (source-wrap e707 w709 s710))) ((lambda (tmp712) ((lambda (tmp713) (if tmp713 (apply (lambda (_714 x715) (call-with-values (lambda () (gen-syntax e711 x715 r708 (quote ()) ellipsis?)) (lambda (e716 maps717) (regen e716)))) tmp713) ((lambda (_718) (syntax-error e711)) tmp712))) (syntax-dispatch tmp712 (quote (any any))))) e711))))) (global-extend (quote core) (quote lambda) (lambda (e719 r720 w721 s722) ((lambda (tmp723) ((lambda (tmp724) (if tmp724 (apply (lambda (_725 c726) (chi-lambda-clause (source-wrap e719 w721 s722) c726 r720 w721 (lambda (vars727 body728) (list (quote lambda) vars727 body728)))) tmp724) (syntax-error tmp723))) (syntax-dispatch tmp723 (quote (any . any))))) e719))) (global-extend (quote core) (quote let) (letrec ((chi-let (lambda (e729 r730 w731 s732 constructor733 ids734 vals735 exps736) (if (not (valid-bound-ids? ids734)) (syntax-error e729 (quote "duplicate bound variable in")) (let ((labels737 (gen-labels ids734)) (new-vars738 (map gen-var ids734))) (let ((nw (make-binding-wrap ids734 labels737 w731)) (nr (extend-var-env labels737 new-vars738 r730))) (constructor733 s732 new-vars738 (map (lambda (x739) (chi x739 r730 w731)) vals735) (chi-body exps736 (source-wrap e729 nw s732) nr nw)))))))) (lambda (e740 r741 w742 s743) ((lambda (tmp744) ((lambda (tmp745) (if tmp745 (apply (lambda (_746 id747 val748 e1749 e2750) (chi-let e740 r741 w742 s743 build-let id747 val748 (cons e1749 e2750))) tmp745) ((lambda (tmp754) (if (if tmp754 (apply (lambda (_755 f756 id757 val758 e1759 e2760) (id? f756)) tmp754) (quote #f)) (apply (lambda (_761 f762 id763 val764 e1765 e2766) (chi-let e740 r741 w742 s743 build-named-let (cons f762 id763) val764 (cons e1765 e2766))) tmp754) ((lambda (_770) (syntax-error (source-wrap e740 w742 s743))) tmp744))) (syntax-dispatch tmp744 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp744 (quote (any #(each (any any)) any . each-any))))) e740)))) (global-extend (quote core) (quote letrec) (lambda (e771 r772 w773 s774) ((lambda (tmp775) ((lambda (tmp776) (if tmp776 (apply (lambda (_777 id778 val779 e1780 e2781) (let ((ids782 id778)) (if (not (valid-bound-ids? ids782)) (syntax-error e771 (quote "duplicate bound variable in")) (let ((labels784 (gen-labels ids782)) (new-vars785 (map gen-var ids782))) (let ((w786 (make-binding-wrap ids782 labels784 w773)) (r787 (extend-var-env labels784 new-vars785 r772))) (build-letrec s774 new-vars785 (map (lambda (x788) (chi x788 r787 w786)) val779) (chi-body (cons e1780 e2781) (source-wrap e771 w786 s774) r787 w786))))))) tmp776) ((lambda (_791) (syntax-error (source-wrap e771 w773 s774))) tmp775))) (syntax-dispatch tmp775 (quote (any #(each (any any)) any . each-any))))) e771))) (global-extend (quote core) (quote set!) (lambda (e792 r793 w794 s795) ((lambda (tmp796) ((lambda (tmp797) (if (if tmp797 (apply (lambda (_798 id799 val800) (id? id799)) tmp797) (quote #f)) (apply (lambda (_801 id802 val803) (let ((val804 (chi val803 r793 w794)) (n805 (id-var-name id802 w794))) (let ((b806 (lookup n805 r793))) (let ((t807 (binding-type b806))) (if (memv t807 (quote (lexical))) (list (quote set!) (binding-value b806) val804) (if (memv t807 (quote (global))) (list (quote set!) n805 val804) (if (memv t807 (quote (displaced-lexical))) (syntax-error (wrap id802 w794) (quote "identifier out of context")) (syntax-error (source-wrap e792 w794 s795))))))))) tmp797) ((lambda (_808) (syntax-error (source-wrap e792 w794 s795))) tmp796))) (syntax-dispatch tmp796 (quote (any any any))))) e792))) (global-extend (quote begin) (quote begin) (quote ())) (global-extend (quote define) (quote define) (quote ())) (global-extend (quote define-syntax) (quote define-syntax) (quote ())) (global-extend (quote eval-when) (quote eval-when) (quote ())) (global-extend (quote core) (quote syntax-case) (letrec ((gen-syntax-case (lambda (x809 keys clauses r810) (if (null? clauses) (list (quote syntax-error) x809) ((lambda (tmp811) ((lambda (tmp812) (if tmp812 (apply (lambda (pat exp813) (if (and (id? pat) (andmap (lambda (x814) (not (free-id=? pat x814))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) keys))) (let ((labels815 (list (gen-label))) (var816 (gen-var pat))) (list (list (quote lambda) (list var816) (chi exp813 (extend-env labels815 (list (cons (quote syntax) (cons var816 (quote 0)))) r810) (make-binding-wrap (list pat) labels815 (quote (()))))) x809)) (gen-clause x809 keys (cdr clauses) r810 pat (quote #t) exp813))) tmp812) ((lambda (tmp817) (if tmp817 (apply (lambda (pat818 fender exp819) (gen-clause x809 keys (cdr clauses) r810 pat818 fender exp819)) tmp817) ((lambda (_820) (syntax-error (car clauses) (quote "invalid syntax-case clause"))) tmp811))) (syntax-dispatch tmp811 (quote (any any any)))))) (syntax-dispatch tmp811 (quote (any any))))) (car clauses))))) (gen-clause (lambda (x821 keys822 clauses823 r824 pat825 fender826 exp827) (call-with-values (lambda () (convert-pattern pat825 keys822)) (lambda (p828 pvars) (cond ((not (distinct-bound-ids? (map car pvars))) (syntax-error pat825 (quote "duplicate pattern variable in syntax-case pattern"))) ((not (andmap (lambda (x829) (not (ellipsis? (car x829)))) pvars)) (syntax-error pat825 (quote "misplaced ellipsis in syntax-case pattern"))) (else (let ((y830 (gen-var (quote tmp)))) (list (list (quote lambda) (list y830) (let ((y831 y830)) (list (quote if) ((lambda (tmp832) ((lambda (tmp833) (if tmp833 (apply (lambda () y831) tmp833) ((lambda (_834) (list (quote if) y831 (build-dispatch-call pvars fender826 y831 r824) (list (quote quote) (quote #f)))) tmp832))) (syntax-dispatch tmp832 (quote #(atom #t))))) fender826) (build-dispatch-call pvars exp827 y831 r824) (gen-syntax-case x821 keys822 clauses823 r824)))) (if (eq? p828 (quote any)) (list (quote list) x821) (list (quote syntax-dispatch) x821 (list (quote quote) p828))))))))))) (build-dispatch-call (lambda (pvars835 exp836 y837 r838) (let ((ids839 (map car pvars835)) (levels (map cdr pvars835))) (let ((labels840 (gen-labels ids839)) (new-vars841 (map gen-var ids839))) (list (quote apply) (list (quote lambda) new-vars841 (chi exp836 (extend-env labels840 (map (lambda (var842 level843) (cons (quote syntax) (cons var842 level843))) new-vars841 (map cdr pvars835)) r838) (make-binding-wrap ids839 labels840 (quote (()))))) y837))))) (convert-pattern (lambda (pattern keys844) (let cvt ((p845 pattern) (n846 (quote 0)) (ids847 (quote ()))) (if (id? p845) (if (bound-id-member? p845 keys844) (values (vector (quote free-id) p845) ids847) (values (quote any) (cons (cons p845 n846) ids847))) ((lambda (tmp848) ((lambda (tmp849) (if (if tmp849 (apply (lambda (x850 dots851) (ellipsis? dots851)) tmp849) (quote #f)) (apply (lambda (x852 dots853) (call-with-values (lambda () (cvt x852 (fx+ n846 (quote 1)) ids847)) (lambda (p854 ids855) (values (if (eq? p854 (quote any)) (quote each-any) (vector (quote each) p854)) ids855)))) tmp849) ((lambda (tmp856) (if tmp856 (apply (lambda (x857 y858) (call-with-values (lambda () (cvt y858 n846 ids847)) (lambda (y859 ids860) (call-with-values (lambda () (cvt x857 n846 ids860)) (lambda (x861 ids862) (values (cons x861 y859) ids862)))))) tmp856) ((lambda (tmp863) (if tmp863 (apply (lambda () (values (quote ()) ids847)) tmp863) ((lambda (tmp864) (if tmp864 (apply (lambda (x865) (call-with-values (lambda () (cvt x865 n846 ids847)) (lambda (p867 ids868) (values (vector (quote vector) p867) ids868)))) tmp864) ((lambda (x869) (values (vector (quote atom) (strip p845 (quote (())))) ids847)) tmp848))) (syntax-dispatch tmp848 (quote #(vector each-any)))))) (syntax-dispatch tmp848 (quote ()))))) (syntax-dispatch tmp848 (quote (any . any)))))) (syntax-dispatch tmp848 (quote (any any))))) p845)))))) (lambda (e870 r871 w872 s873) (let ((e874 (source-wrap e870 w872 s873))) ((lambda (tmp875) ((lambda (tmp876) (if tmp876 (apply (lambda (_877 val878 key m879) (if (andmap (lambda (x880) (and (id? x880) (not (ellipsis? x880)))) key) (let ((x882 (gen-var (quote tmp)))) (list (list (quote lambda) (list x882) (gen-syntax-case x882 key m879 r871)) (chi val878 r871 (quote (()))))) (syntax-error e874 (quote "invalid literals list in")))) tmp876) (syntax-error tmp875))) (syntax-dispatch tmp875 (quote (any any each-any . each-any))))) e874))))) (set! sc-expand (let ((m885 (quote e)) (esew886 (quote (eval)))) (lambda (x887) (if (and (pair? x887) (equal? (car x887) noexpand)) (cadr x887) (chi-top x887 (quote ()) (quote ((top))) m885 esew886))))) (set! sc-expand3 (let ((m888 (quote e)) (esew889 (quote (eval)))) (lambda (x890 . rest) (if (and (pair? x890) (equal? (car x890) noexpand)) (cadr x890) (chi-top x890 (quote ()) (quote ((top))) (if (null? rest) m888 (car rest)) (if (or (null? rest) (null? (cdr rest))) esew889 (cadr rest))))))) (set! identifier? (lambda (x891) (nonsymbol-id? x891))) (set! datum->syntax-object (lambda (id892 datum) (begin (let ((x893 id892)) (if (not (nonsymbol-id? x893)) (error-hook (quote datum->syntax-object) (quote "invalid argument") x893))) (make-syntax-object datum (syntax-object-wrap id892))))) (set! syntax-object->datum (lambda (x894) (strip x894 (quote (()))))) (set! generate-temporaries (lambda (ls895) (begin (let ((x896 ls895)) (if (not (list? x896)) (error-hook (quote generate-temporaries) (quote "invalid argument") x896))) (map (lambda (x897) (wrap (gensym) (quote ((top))))) ls895)))) (set! free-identifier=? (lambda (x898 y899) (begin (let ((x900 x898)) (if (not (nonsymbol-id? x900)) (error-hook (quote free-identifier=?) (quote "invalid argument") x900))) (let ((x901 y899)) (if (not (nonsymbol-id? x901)) (error-hook (quote free-identifier=?) (quote "invalid argument") x901))) (free-id=? x898 y899)))) (set! bound-identifier=? (lambda (x902 y903) (begin (let ((x904 x902)) (if (not (nonsymbol-id? x904)) (error-hook (quote bound-identifier=?) (quote "invalid argument") x904))) (let ((x905 y903)) (if (not (nonsymbol-id? x905)) (error-hook (quote bound-identifier=?) (quote "invalid argument") x905))) (bound-id=? x902 y903)))) (set! syntax-error (lambda (object . messages) (begin (for-each (lambda (x906) (let ((x907 x906)) (if (not (string? x907)) (error-hook (quote syntax-error) (quote "invalid argument") x907)))) messages) (let ((message (if (null? messages) (quote "invalid syntax") (apply string-append messages)))) (error-hook (quote #f) message (strip object (quote (())))))))) (set! install-global-transformer (lambda (sym908 v909) (begin (let ((x910 sym908)) (if (not (symbol? x910)) (error-hook (quote define-syntax) (quote "invalid argument") x910))) (let ((x911 v909)) (if (not (procedure? x911)) (error-hook (quote define-syntax) (quote "invalid argument") x911))) (global-extend (quote macro) sym908 v909)))) (letrec ((match (lambda (e912 p913 w914 r915) (cond ((not r915) (quote #f)) ((eq? p913 (quote any)) (cons (wrap e912 w914) r915)) ((syntax-object? e912) (match* (let ((e916 (syntax-object-expression e912))) (if (annotation? e916) (annotation-expression e916) e916)) p913 (join-wraps w914 (syntax-object-wrap e912)) r915)) (else (match* (let ((e917 e912)) (if (annotation? e917) (annotation-expression e917) e917)) p913 w914 r915))))) (match* (lambda (e918 p919 w920 r921) (cond ((null? p919) (and (null? e918) r921)) ((pair? p919) (and (pair? e918) (match (car e918) (car p919) w920 (match (cdr e918) (cdr p919) w920 r921)))) ((eq? p919 (quote each-any)) (let ((l (match-each-any e918 w920))) (and l (cons l r921)))) (else (let ((t922 (vector-ref p919 (quote 0)))) (if (memv t922 (quote (each))) (if (null? e918) (match-empty (vector-ref p919 (quote 1)) r921) (let ((l923 (match-each e918 (vector-ref p919 (quote 1)) w920))) (and l923 (let collect ((l924 l923)) (if (null? (car l924)) r921 (cons (map car l924) (collect (map cdr l924)))))))) (if (memv t922 (quote (free-id))) (and (id? e918) (free-id=? (wrap e918 w920) (vector-ref p919 (quote 1))) r921) (if (memv t922 (quote (atom))) (and (equal? (vector-ref p919 (quote 1)) (strip e918 w920)) r921) (if (memv t922 (quote (vector))) (and (vector? e918) (match (vector->list e918) (vector-ref p919 (quote 1)) w920 r921))))))))))) (match-empty (lambda (p925 r926) (cond ((null? p925) r926) ((eq? p925 (quote any)) (cons (quote ()) r926)) ((pair? p925) (match-empty (car p925) (match-empty (cdr p925) r926))) ((eq? p925 (quote each-any)) (cons (quote ()) r926)) (else (let ((t927 (vector-ref p925 (quote 0)))) (if (memv t927 (quote (each))) (match-empty (vector-ref p925 (quote 1)) r926) (if (memv t927 (quote (free-id atom))) r926 (if (memv t927 (quote (vector))) (match-empty (vector-ref p925 (quote 1)) r926))))))))) (match-each-any (lambda (e928 w929) (cond ((annotation? e928) (match-each-any (annotation-expression e928) w929)) ((pair? e928) (let ((l930 (match-each-any (cdr e928) w929))) (and l930 (cons (wrap (car e928) w929) l930)))) ((null? e928) (quote ())) ((syntax-object? e928) (match-each-any (syntax-object-expression e928) (join-wraps w929 (syntax-object-wrap e928)))) (else (quote #f))))) (match-each (lambda (e931 p932 w933) (cond ((annotation? e931) (match-each (annotation-expression e931) p932 w933)) ((pair? e931) (let ((first934 (match (car e931) p932 w933 (quote ())))) (and first934 (let ((rest935 (match-each (cdr e931) p932 w933))) (and rest935 (cons first934 rest935)))))) ((null? e931) (quote ())) ((syntax-object? e931) (match-each (syntax-object-expression e931) p932 (join-wraps w933 (syntax-object-wrap e931)))) (else (quote #f)))))) (set! syntax-dispatch (lambda (e936 p937) (cond ((eq? p937 (quote any)) (list e936)) ((syntax-object? e936) (match* (let ((e938 (syntax-object-expression e936))) (if (annotation? e938) (annotation-expression e938) e938)) p937 (syntax-object-wrap e936) (quote ()))) (else (match* (let ((e939 e936)) (if (annotation? e939) (annotation-expression e939) e939)) p937 (quote (())) (quote ()))))))))) (install-global-transformer (quote with-syntax) (lambda (x940) ((lambda (tmp941) ((lambda (tmp942) (if tmp942 (apply (lambda (_943 e1944 e2945) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e1944 e2945))) tmp942) ((lambda (tmp947) (if tmp947 (apply (lambda (_948 out in e1949 e2950) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) in (quote ()) (list out (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e1949 e2950))))) tmp947) ((lambda (tmp952) (if tmp952 (apply (lambda (_953 out954 in955 e1956 e2957) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) in955) (quote ()) (list out954 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e1956 e2957))))) tmp952) (syntax-error tmp941))) (syntax-dispatch tmp941 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp941 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp941 (quote (any () any . each-any))))) x940))) (install-global-transformer (quote syntax-rules) (lambda (x961) ((lambda (tmp962) ((lambda (tmp963) (if tmp963 (apply (lambda (_964 k965 keyword pattern966 template) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons k965 (map (lambda (tmp969 tmp968) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) tmp968) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) tmp969))) template pattern966)))))) tmp963) (syntax-error tmp962))) (syntax-dispatch tmp962 (quote (any each-any . #(each ((any . any) any))))))) x961))) (install-global-transformer (quote let*) (lambda (x970) ((lambda (tmp971) ((lambda (tmp972) (if (if tmp972 (apply (lambda (let* x973 v974 e1975 e2976) (andmap identifier? x973)) tmp972) (quote #f)) (apply (lambda (let*978 x979 v980 e1981 e2982) (let f983 ((bindings984 (map list x979 v980))) (if (null? bindings984) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote ()) (cons e1981 e2982))) ((lambda (tmp988) ((lambda (tmp989) (if tmp989 (apply (lambda (body binding) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list binding) body)) tmp989) (syntax-error tmp988))) (syntax-dispatch tmp988 (quote (any any))))) (list (f983 (cdr bindings984)) (car bindings984)))))) tmp972) (syntax-error tmp971))) (syntax-dispatch tmp971 (quote (any #(each (any any)) any . each-any))))) x970))) From 544468de3dc8ba6f19b16cf0b9da6f4b91d483dd Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 13 Aug 2000 19:21:25 +0000 Subject: [PATCH 0139/2047] * emacs.scm (emacs-symdoc): Parenthesis fix. --- ice-9/emacs.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ice-9/emacs.scm b/ice-9/emacs.scm index 535e59ab6..850571d42 100644 --- a/ice-9/emacs.scm +++ b/ice-9/emacs.scm @@ -248,7 +248,7 @@ (define (emacs-symdoc symbol) (if (or (not (module-bound? (current-module) symbol)) - (not (procedure? (eval symbol) (interaction-environment)))) + (not (procedure? (eval symbol (interaction-environment))))) 'nil (procedure-documentation (eval symbol (interaction-environment))))) From c4778010b37e686eabf7b06deb20622fe32622cf Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 13 Aug 2000 19:21:34 +0000 Subject: [PATCH 0140/2047] *** empty log message *** --- THANKS | 1 + ice-9/ChangeLog | 10 ++++++++++ 2 files changed, 11 insertions(+) diff --git a/THANKS b/THANKS index c4bcb6540..f9c59246b 100644 --- a/THANKS +++ b/THANKS @@ -9,6 +9,7 @@ Contributors since the last release: For fixes or providing information which led to a fix: + Ian Bicking Brad Knotwell Nicolas Neuss Han-Wen Nienhuys diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 2510e0180..a457618f7 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,13 @@ +2000-08-13 Mikael Djurfeldt + + * psyntax.ss (top-level-eval-hook, local-eval-hook): Pass + `(interaction-environment)' as second arg to `eval'. This is + completely equivalent with the state before the change to eval of + 2000-08-11, but we should extend psyntax.ss to be module aware. + (Thanks to Ian Bicking.) + + * emacs.scm (emacs-symdoc): Parenthesis fix. + 2000-08-11 Mikael Djurfeldt * r5rs.scm (interaction-environment): Removed definition. (Is now From 4be092bcf9687fe912223be7612339028e8a0b98 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 13 Aug 2000 20:26:49 +0000 Subject: [PATCH 0141/2047] Commentary fix --- ice-9/syncase.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ice-9/syncase.scm b/ice-9/syncase.scm index 0ca94520e..6b23bb757 100644 --- a/ice-9/syncase.scm +++ b/ice-9/syncase.scm @@ -147,7 +147,8 @@ (read-options old-read)))) -;;; The following line is necessary only if we start making changes +;;; The following lines are necessary only if we start making changes +;; (use-syntax sc-expand) ;; (load-from-path "ice-9/psyntax.ss") (define internal-eval (nested-ref the-scm-module '(app modules guile eval))) From 402dd41f64404fd9e758677c2192a8c081438043 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 13 Aug 2000 20:27:39 +0000 Subject: [PATCH 0142/2047] Regenerated --- ice-9/psyntax.pp | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/ice-9/psyntax.pp b/ice-9/psyntax.pp index 93f134d06..a453e679b 100644 --- a/ice-9/psyntax.pp +++ b/ice-9/psyntax.pp @@ -1,11 +1,11 @@ -(letrec ((lambda-var-list (lambda (vars203) (let lvl ((vars204 vars203) (ls (quote ())) (w205 (quote (())))) (cond ((pair? vars204) (lvl (cdr vars204) (cons (wrap (car vars204) w205) ls) w205)) ((id? vars204) (cons (wrap vars204 w205) ls)) ((null? vars204) ls) ((syntax-object? vars204) (lvl (syntax-object-expression vars204) ls (join-wraps w205 (syntax-object-wrap vars204)))) ((annotation? vars204) (lvl (annotation-expression vars204) ls w205)) (else (cons vars204 ls)))))) (gen-var (lambda (id206) (let ((id207 (if (syntax-object? id206) (syntax-object-expression id206) id206))) (if (annotation? id207) (gensym (annotation-expression id207) generated-symbols) (gensym id207 generated-symbols))))) (strip (lambda (x208 w209) (if (memq (quote top) (wrap-marks w209)) (if (or (annotation? x208) (and (pair? x208) (annotation? (car x208)))) (strip-annotation x208 (quote #f)) x208) (let f210 ((x211 x208)) (cond ((syntax-object? x211) (strip (syntax-object-expression x211) (syntax-object-wrap x211))) ((pair? x211) (let ((a (f210 (car x211))) (d (f210 (cdr x211)))) (if (and (eq? a (car x211)) (eq? d (cdr x211))) x211 (cons a d)))) ((vector? x211) (let ((old212 (vector->list x211))) (let ((new213 (map f210 old212))) (if (andmap eq? old212 new213) x211 (list->vector new213))))) (else x211)))))) (strip-annotation (lambda (x214 parent) (cond ((pair? x214) (let ((new215 (cons (quote #f) (quote #f)))) (begin (when parent (set-annotation-stripped! parent new215)) (set-car! new215 (strip-annotation (car x214) (quote #f))) (set-cdr! new215 (strip-annotation (cdr x214) (quote #f))) new215))) ((annotation? x214) (or (annotation-stripped x214) (strip-annotation (annotation-expression x214) x214))) ((vector? x214) (let ((new216 (make-vector (vector-length x214)))) (begin (when parent (set-annotation-stripped! parent new216)) (let loop ((i217 (- (vector-length x214) (quote 1)))) (unless (fx< i217 (quote 0)) (vector-set! new216 i217 (strip-annotation (vector-ref x214 i217) (quote #f))) (loop (fx- i217 (quote 1))))) new216))) (else x214)))) (ellipsis? (lambda (x218) (and (nonsymbol-id? x218) (free-id=? x218 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))))))) (chi-void (lambda () (list (quote void)))) (eval-local-transformer (lambda (expanded) (let ((p (local-eval-hook expanded))) (if (procedure? p) p (syntax-error p (quote "nonprocedure transfomer")))))) (chi-local-syntax (lambda (rec? e219 r w220 s k) ((lambda (tmp221) ((lambda (tmp222) (if tmp222 (apply (lambda (_223 id224 val e1 e2) (let ((ids225 id224)) (if (not (valid-bound-ids? ids225)) (syntax-error e219 (quote "duplicate bound keyword in")) (let ((labels (gen-labels ids225))) (let ((new-w (make-binding-wrap ids225 labels w220))) (k (cons e1 e2) (extend-env labels (let ((w228 (if rec? new-w w220)) (trans-r (macros-only-env r))) (map (lambda (x229) (cons (quote macro) (eval-local-transformer (chi x229 trans-r w228)))) val)) r) new-w s)))))) tmp222) ((lambda (_231) (syntax-error (source-wrap e219 w220 s))) tmp221))) (syntax-dispatch tmp221 (quote (any #(each (any any)) any . each-any))))) e219))) (chi-lambda-clause (lambda (e232 c r233 w234 k235) ((lambda (tmp236) ((lambda (tmp237) (if tmp237 (apply (lambda (id238 e1239 e2240) (let ((ids241 id238)) (if (not (valid-bound-ids? ids241)) (syntax-error e232 (quote "invalid parameter list in")) (let ((labels243 (gen-labels ids241)) (new-vars (map gen-var ids241))) (k235 new-vars (chi-body (cons e1239 e2240) e232 (extend-var-env labels243 new-vars r233) (make-binding-wrap ids241 labels243 w234))))))) tmp237) ((lambda (tmp245) (if tmp245 (apply (lambda (ids246 e1247 e2248) (let ((old-ids (lambda-var-list ids246))) (if (not (valid-bound-ids? old-ids)) (syntax-error e232 (quote "invalid parameter list in")) (let ((labels249 (gen-labels old-ids)) (new-vars250 (map gen-var old-ids))) (k235 (let f251 ((ls1 (cdr new-vars250)) (ls2 (car new-vars250))) (if (null? ls1) ls2 (f251 (cdr ls1) (cons (car ls1) ls2)))) (chi-body (cons e1247 e2248) e232 (extend-var-env labels249 new-vars250 r233) (make-binding-wrap old-ids labels249 w234))))))) tmp245) ((lambda (_253) (syntax-error e232)) tmp236))) (syntax-dispatch tmp236 (quote (any any . each-any)))))) (syntax-dispatch tmp236 (quote (each-any any . each-any))))) c))) (chi-body (lambda (body outer-form r254 w255) (let ((r256 (cons (quote ("placeholder" placeholder)) r254))) (let ((ribcage (make-ribcage (quote ()) (quote ()) (quote ())))) (let ((w257 (make-wrap (wrap-marks w255) (cons ribcage (wrap-subst w255))))) (let parse ((body258 (map (lambda (x262) (cons r256 (wrap x262 w257))) body)) (ids259 (quote ())) (labels260 (quote ())) (vars261 (quote ())) (vals (quote ())) (bindings (quote ()))) (if (null? body258) (syntax-error outer-form (quote "no expressions in body")) (let ((e263 (cdar body258)) (er (caar body258))) (call-with-values (lambda () (syntax-type e263 er (quote (())) (quote #f) ribcage)) (lambda (type264 value265 e266 w267 s268) (let ((t type264)) (if (memv t (quote (define-form))) (let ((id269 (wrap value265 w267)) (label (gen-label))) (let ((var270 (gen-var id269))) (begin (extend-ribcage! ribcage id269 label) (parse (cdr body258) (cons id269 ids259) (cons label labels260) (cons var270 vars261) (cons (cons er (wrap e266 w267)) vals) (cons (cons (quote lexical) var270) bindings))))) (if (memv t (quote (define-syntax-form))) (let ((id271 (wrap value265 w267)) (label272 (gen-label))) (begin (extend-ribcage! ribcage id271 label272) (parse (cdr body258) (cons id271 ids259) (cons label272 labels260) vars261 vals (cons (cons (quote macro) (cons er (wrap e266 w267))) bindings)))) (if (memv t (quote (begin-form))) ((lambda (tmp273) ((lambda (tmp274) (if tmp274 (apply (lambda (_275 e1276) (parse (let f277 ((forms e1276)) (if (null? forms) (cdr body258) (cons (cons er (wrap (car forms) w267)) (f277 (cdr forms))))) ids259 labels260 vars261 vals bindings)) tmp274) (syntax-error tmp273))) (syntax-dispatch tmp273 (quote (any . each-any))))) e266) (if (memv t (quote (local-syntax-form))) (chi-local-syntax value265 e266 er w267 s268 (lambda (forms279 er280 w281 s282) (parse (let f283 ((forms284 forms279)) (if (null? forms284) (cdr body258) (cons (cons er280 (wrap (car forms284) w281)) (f283 (cdr forms284))))) ids259 labels260 vars261 vals bindings))) (if (null? ids259) (build-sequence (quote #f) (map (lambda (x285) (chi (cdr x285) (car x285) (quote (())))) (cons (cons er (source-wrap e266 w267 s268)) (cdr body258)))) (begin (if (not (valid-bound-ids? ids259)) (syntax-error outer-form (quote "invalid or duplicate identifier in definition"))) (let loop286 ((bs bindings) (er-cache (quote #f)) (r-cache (quote #f))) (if (not (null? bs)) (let ((b (car bs))) (if (eq? (car b) (quote macro)) (let ((er287 (cadr b))) (let ((r-cache288 (if (eq? er287 er-cache) r-cache (macros-only-env er287)))) (begin (set-cdr! b (eval-local-transformer (chi (cddr b) r-cache288 (quote (()))))) (loop286 (cdr bs) er287 r-cache288)))) (loop286 (cdr bs) er-cache r-cache))))) (set-cdr! r256 (extend-env labels260 bindings (cdr r256))) (build-letrec (quote #f) vars261 (map (lambda (x289) (chi (cdr x289) (car x289) (quote (())))) vals) (build-sequence (quote #f) (map (lambda (x290) (chi (cdr x290) (car x290) (quote (())))) (cons (cons er (source-wrap e266 w267 s268)) (cdr body258)))))))))))))))))))))) (chi-macro (lambda (p291 e292 r293 w294 rib) (letrec ((rebuild-macro-output (lambda (x295 m) (cond ((pair? x295) (cons (rebuild-macro-output (car x295) m) (rebuild-macro-output (cdr x295) m))) ((syntax-object? x295) (let ((w296 (syntax-object-wrap x295))) (let ((ms (wrap-marks w296)) (s297 (wrap-subst w296))) (make-syntax-object (syntax-object-expression x295) (if (and (pair? ms) (eq? (car ms) (quote #f))) (make-wrap (cdr ms) (if rib (cons rib (cdr s297)) (cdr s297))) (make-wrap (cons m ms) (if rib (cons rib (cons (quote shift) s297)) (cons (quote shift) s297)))))))) ((vector? x295) (let ((n (vector-length x295))) (let ((v (make-vector n))) (let doloop ((i298 (quote 0))) (if (fx= i298 n) v (begin (vector-set! v i298 (rebuild-macro-output (vector-ref x295 i298) m)) (doloop (fx+ i298 (quote 1))))))))) ((symbol? x295) (syntax-error x295 (quote "encountered raw symbol in macro output"))) (else x295))))) (rebuild-macro-output (p291 (wrap e292 (anti-mark w294))) (string (quote #\m)))))) (chi-application (lambda (x299 e300 r301 w302 s303) ((lambda (tmp304) ((lambda (tmp305) (if tmp305 (apply (lambda (e0 e1306) (cons x299 (map (lambda (e307) (chi e307 r301 w302)) e1306))) tmp305) (syntax-error tmp304))) (syntax-dispatch tmp304 (quote (any . each-any))))) e300))) (chi-expr (lambda (type309 value310 e311 r312 w313 s314) (let ((t315 type309)) (if (memv t315 (quote (lexical))) value310 (if (memv t315 (quote (core))) (value310 e311 r312 w313 s314) (if (memv t315 (quote (lexical-call))) (chi-application value310 e311 r312 w313 s314) (if (memv t315 (quote (global-call))) (chi-application value310 e311 r312 w313 s314) (if (memv t315 (quote (constant))) (list (quote quote) (strip (source-wrap e311 w313 s314) (quote (())))) (if (memv t315 (quote (global))) value310 (if (memv t315 (quote (call))) (chi-application (chi (car e311) r312 w313) e311 r312 w313 s314) (if (memv t315 (quote (begin-form))) ((lambda (tmp316) ((lambda (tmp317) (if tmp317 (apply (lambda (_318 e1319 e2320) (chi-sequence (cons e1319 e2320) r312 w313 s314)) tmp317) (syntax-error tmp316))) (syntax-dispatch tmp316 (quote (any any . each-any))))) e311) (if (memv t315 (quote (local-syntax-form))) (chi-local-syntax value310 e311 r312 w313 s314 chi-sequence) (if (memv t315 (quote (eval-when-form))) ((lambda (tmp322) ((lambda (tmp323) (if tmp323 (apply (lambda (_324 x325 e1326 e2327) (let ((when-list (chi-when-list e311 x325 w313))) (if (memq (quote eval) when-list) (chi-sequence (cons e1326 e2327) r312 w313 s314) (chi-void)))) tmp323) (syntax-error tmp322))) (syntax-dispatch tmp322 (quote (any each-any any . each-any))))) e311) (if (memv t315 (quote (define-form define-syntax-form))) (syntax-error (wrap value310 w313) (quote "invalid context for definition of")) (if (memv t315 (quote (syntax))) (syntax-error (source-wrap e311 w313 s314) (quote "reference to pattern variable outside syntax form")) (if (memv t315 (quote (displaced-lexical))) (syntax-error (source-wrap e311 w313 s314) (quote "reference to identifier outside its scope")) (syntax-error (source-wrap e311 w313 s314)))))))))))))))))) (chi (lambda (e330 r331 w332) (call-with-values (lambda () (syntax-type e330 r331 w332 (quote #f) (quote #f))) (lambda (type333 value334 e335 w336 s337) (chi-expr type333 value334 e335 r331 w336 s337))))) (chi-top (lambda (e338 r339 w340 m341 esew) (call-with-values (lambda () (syntax-type e338 r339 w340 (quote #f) (quote #f))) (lambda (type348 value349 e350 w351 s352) (let ((t353 type348)) (if (memv t353 (quote (begin-form))) ((lambda (tmp354) ((lambda (tmp355) (if tmp355 (apply (lambda (_356) (chi-void)) tmp355) ((lambda (tmp357) (if tmp357 (apply (lambda (_358 e1359 e2360) (chi-top-sequence (cons e1359 e2360) r339 w351 s352 m341 esew)) tmp357) (syntax-error tmp354))) (syntax-dispatch tmp354 (quote (any any . each-any)))))) (syntax-dispatch tmp354 (quote (any))))) e350) (if (memv t353 (quote (local-syntax-form))) (chi-local-syntax value349 e350 r339 w351 s352 (lambda (body362 r363 w364 s365) (chi-top-sequence body362 r363 w364 s365 m341 esew))) (if (memv t353 (quote (eval-when-form))) ((lambda (tmp366) ((lambda (tmp367) (if tmp367 (apply (lambda (_368 x369 e1370 e2371) (let ((when-list372 (chi-when-list e350 x369 w351)) (body373 (cons e1370 e2371))) (cond ((eq? m341 (quote e)) (if (memq (quote eval) when-list372) (chi-top-sequence body373 r339 w351 s352 (quote e) (quote (eval))) (chi-void))) ((memq (quote load) when-list372) (if (or (memq (quote compile) when-list372) (and (eq? m341 (quote c&e)) (memq (quote eval) when-list372))) (chi-top-sequence body373 r339 w351 s352 (quote c&e) (quote (compile load))) (if (memq m341 (quote (c c&e))) (chi-top-sequence body373 r339 w351 s352 (quote c) (quote (load))) (chi-void)))) ((or (memq (quote compile) when-list372) (and (eq? m341 (quote c&e)) (memq (quote eval) when-list372))) (top-level-eval-hook (chi-top-sequence body373 r339 w351 s352 (quote e) (quote (eval)))) (chi-void)) (else (chi-void))))) tmp367) (syntax-error tmp366))) (syntax-dispatch tmp366 (quote (any each-any any . each-any))))) e350) (if (memv t353 (quote (define-syntax-form))) (let ((n376 (id-var-name value349 w351)) (r377 (macros-only-env r339))) (let ((t378 m341)) (if (memv t378 (quote (c))) (if (memq (quote compile) esew) (let ((e379 (chi-install-global n376 (chi e350 r377 w351)))) (begin (top-level-eval-hook e379) (if (memq (quote load) esew) e379 (chi-void)))) (if (memq (quote load) esew) (chi-install-global n376 (chi e350 r377 w351)) (chi-void))) (if (memv t378 (quote (c&e))) (let ((e380 (chi-install-global n376 (chi e350 r377 w351)))) (begin (top-level-eval-hook e380) e380)) (begin (if (memq (quote eval) esew) (top-level-eval-hook (chi-install-global n376 (chi e350 r377 w351)))) (chi-void)))))) (if (memv t353 (quote (define-form))) (let ((n381 (id-var-name value349 w351))) (let ((t382 (binding-type (lookup n381 r339)))) (if (memv t382 (quote (global))) (let ((x383 (list (quote define) n381 (chi e350 r339 w351)))) (begin (if (eq? m341 (quote c&e)) (top-level-eval-hook x383)) x383)) (if (memv t382 (quote (displaced-lexical))) (syntax-error (wrap value349 w351) (quote "identifier out of context")) (syntax-error (wrap value349 w351) (quote "cannot define keyword at top level")))))) (let ((x384 (chi-expr type348 value349 e350 r339 w351 s352))) (begin (if (eq? m341 (quote c&e)) (top-level-eval-hook x384)) x384)))))))))))) (syntax-type (lambda (e385 r386 w387 s388 rib389) (cond ((symbol? e385) (let ((n390 (id-var-name e385 w387))) (let ((b391 (lookup n390 r386))) (let ((type392 (binding-type b391))) (let ((t393 type392)) (if (memv t393 (quote (lexical))) (values type392 (binding-value b391) e385 w387 s388) (if (memv t393 (quote (global))) (values type392 n390 e385 w387 s388) (if (memv t393 (quote (macro))) (syntax-type (chi-macro (binding-value b391) e385 r386 w387 rib389) r386 (quote (())) s388 rib389) (values type392 (binding-value b391) e385 w387 s388))))))))) ((pair? e385) (let ((first (car e385))) (if (id? first) (let ((n394 (id-var-name first w387))) (let ((b395 (lookup n394 r386))) (let ((type396 (binding-type b395))) (let ((t397 type396)) (if (memv t397 (quote (lexical))) (values (quote lexical-call) (binding-value b395) e385 w387 s388) (if (memv t397 (quote (global))) (values (quote global-call) n394 e385 w387 s388) (if (memv t397 (quote (macro))) (syntax-type (chi-macro (binding-value b395) e385 r386 w387 rib389) r386 (quote (())) s388 rib389) (if (memv t397 (quote (core))) (values type396 (binding-value b395) e385 w387 s388) (if (memv t397 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value b395) e385 w387 s388) (if (memv t397 (quote (begin))) (values (quote begin-form) (quote #f) e385 w387 s388) (if (memv t397 (quote (eval-when))) (values (quote eval-when-form) (quote #f) e385 w387 s388) (if (memv t397 (quote (define))) ((lambda (tmp398) ((lambda (tmp399) (if (if tmp399 (apply (lambda (_400 name401 val402) (id? name401)) tmp399) (quote #f)) (apply (lambda (_403 name404 val405) (values (quote define-form) name404 val405 w387 s388)) tmp399) ((lambda (tmp406) (if (if tmp406 (apply (lambda (_407 name408 args409 e1410 e2411) (and (id? name408) (or (valid-bound-ids? (lambda-var-list args409)) (id? (lambda-var-list args409))))) tmp406) (quote #f)) (apply (lambda (_412 name413 args414 e1415 e2416) (values (quote define-form) (wrap name413 w387) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) (wrap (cons args414 (cons e1415 e2416)) w387)) (quote (())) s388)) tmp406) ((lambda (tmp418) (if (if tmp418 (apply (lambda (_419 name420) (id? name420)) tmp418) (quote #f)) (apply (lambda (_421 name422) (values (quote define-form) (wrap name422 w387) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote (())) s388)) tmp418) (syntax-error tmp398))) (syntax-dispatch tmp398 (quote (any any)))))) (syntax-dispatch tmp398 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp398 (quote (any any any))))) e385) (if (memv t397 (quote (define-syntax))) ((lambda (tmp423) ((lambda (tmp424) (if (if tmp424 (apply (lambda (_425 name426 val427) (id? name426)) tmp424) (quote #f)) (apply (lambda (_428 name429 val430) (values (quote define-syntax-form) name429 val430 w387 s388)) tmp424) (syntax-error tmp423))) (syntax-dispatch tmp423 (quote (any any any))))) e385) (values (quote call) (quote #f) e385 w387 s388)))))))))))))) (values (quote call) (quote #f) e385 w387 s388)))) ((syntax-object? e385) (syntax-type (syntax-object-expression e385) r386 (join-wraps w387 (syntax-object-wrap e385)) (quote #f) rib389)) ((annotation? e385) (syntax-type (annotation-expression e385) r386 w387 (annotation-source e385) rib389)) ((let ((x431 e385)) (or (boolean? x431) (number? x431) (string? x431) (char? x431) (null? x431) (keyword? x431))) (values (quote constant) (quote #f) e385 w387 s388)) (else (values (quote other) (quote #f) e385 w387 s388))))) (chi-when-list (lambda (e432 when-list433 w434) (let f435 ((when-list436 when-list433) (situations (quote ()))) (if (null? when-list436) situations (f435 (cdr when-list436) (cons (let ((x437 (car when-list436))) (cond ((free-id=? x437 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote compile)) ((free-id=? x437 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote load)) ((free-id=? x437 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote eval)) (else (syntax-error (wrap x437 w434) (quote "invalid eval-when situation"))))) situations)))))) (chi-install-global (lambda (name438 e439) (list (quote install-global-transformer) (list (quote quote) name438) e439))) (chi-top-sequence (lambda (body440 r441 w442 s443 m444 esew445) (build-sequence s443 (let dobody ((body446 body440) (r447 r441) (w448 w442) (m449 m444) (esew450 esew445)) (if (null? body446) (quote ()) (let ((first451 (chi-top (car body446) r447 w448 m449 esew450))) (cons first451 (dobody (cdr body446) r447 w448 m449 esew450)))))))) (chi-sequence (lambda (body452 r453 w454 s455) (build-sequence s455 (let dobody456 ((body457 body452) (r458 r453) (w459 w454)) (if (null? body457) (quote ()) (let ((first460 (chi (car body457) r458 w459))) (cons first460 (dobody456 (cdr body457) r458 w459)))))))) (source-wrap (lambda (x461 w462 s463) (wrap (if s463 (make-annotation x461 s463 (quote #f)) x461) w462))) (wrap (lambda (x464 w465) (cond ((and (null? (wrap-marks w465)) (null? (wrap-subst w465))) x464) ((syntax-object? x464) (make-syntax-object (syntax-object-expression x464) (join-wraps w465 (syntax-object-wrap x464)))) ((null? x464) x464) (else (make-syntax-object x464 w465))))) (bound-id-member? (lambda (x466 list) (and (not (null? list)) (or (bound-id=? x466 (car list)) (bound-id-member? x466 (cdr list)))))) (distinct-bound-ids? (lambda (ids467) (let distinct? ((ids468 ids467)) (or (null? ids468) (and (not (bound-id-member? (car ids468) (cdr ids468))) (distinct? (cdr ids468))))))) (valid-bound-ids? (lambda (ids469) (and (let all-ids? ((ids470 ids469)) (or (null? ids470) (and (id? (car ids470)) (all-ids? (cdr ids470))))) (distinct-bound-ids? ids469)))) (bound-id=? (lambda (i471 j) (if (and (syntax-object? i471) (syntax-object? j)) (and (eq? (let ((e472 (syntax-object-expression i471))) (if (annotation? e472) (annotation-expression e472) e472)) (let ((e473 (syntax-object-expression j))) (if (annotation? e473) (annotation-expression e473) e473))) (same-marks? (wrap-marks (syntax-object-wrap i471)) (wrap-marks (syntax-object-wrap j)))) (eq? (let ((e474 i471)) (if (annotation? e474) (annotation-expression e474) e474)) (let ((e475 j)) (if (annotation? e475) (annotation-expression e475) e475)))))) (free-id=? (lambda (i476 j477) (and (eq? (let ((x478 i476)) (let ((e479 (if (syntax-object? x478) (syntax-object-expression x478) x478))) (if (annotation? e479) (annotation-expression e479) e479))) (let ((x480 j477)) (let ((e481 (if (syntax-object? x480) (syntax-object-expression x480) x480))) (if (annotation? e481) (annotation-expression e481) e481)))) (eq? (id-var-name i476 (quote (()))) (id-var-name j477 (quote (()))))))) (id-var-name (lambda (id482 w483) (letrec ((search-vector-rib (lambda (sym subst marks489 symnames ribcage490) (let ((n491 (vector-length symnames))) (let f492 ((i493 (quote 0))) (cond ((fx= i493 n491) (search sym (cdr subst) marks489)) ((and (eq? (vector-ref symnames i493) sym) (same-marks? marks489 (vector-ref (ribcage-marks ribcage490) i493))) (values (vector-ref (ribcage-labels ribcage490) i493) marks489)) (else (f492 (fx+ i493 (quote 1))))))))) (search-list-rib (lambda (sym494 subst495 marks496 symnames497 ribcage498) (let f499 ((symnames500 symnames497) (i501 (quote 0))) (cond ((null? symnames500) (search sym494 (cdr subst495) marks496)) ((and (eq? (car symnames500) sym494) (same-marks? marks496 (list-ref (ribcage-marks ribcage498) i501))) (values (list-ref (ribcage-labels ribcage498) i501) marks496)) (else (f499 (cdr symnames500) (fx+ i501 (quote 1)))))))) (search (lambda (sym502 subst503 marks504) (if (null? subst503) (values (quote #f) marks504) (let ((fst (car subst503))) (if (eq? fst (quote shift)) (search sym502 (cdr subst503) (cdr marks504)) (let ((symnames505 (ribcage-symnames fst))) (if (vector? symnames505) (search-vector-rib sym502 subst503 marks504 symnames505 fst) (search-list-rib sym502 subst503 marks504 symnames505 fst))))))))) (cond ((symbol? id482) (or (call-with-values (lambda () (search id482 (wrap-subst w483) (wrap-marks w483))) (lambda (x506 . ignore) x506)) id482)) ((syntax-object? id482) (let ((id507 (let ((e508 (syntax-object-expression id482))) (if (annotation? e508) (annotation-expression e508) e508))) (w1 (syntax-object-wrap id482))) (let ((marks509 (join-marks (wrap-marks w483) (wrap-marks w1)))) (call-with-values (lambda () (search id507 (wrap-subst w483) marks509)) (lambda (new-id marks510) (or new-id (call-with-values (lambda () (search id507 (wrap-subst w1) marks510)) (lambda (x512 . ignore511) x512)) id507)))))) ((annotation? id482) (let ((id513 (let ((e514 id482)) (if (annotation? e514) (annotation-expression e514) e514)))) (or (call-with-values (lambda () (search id513 (wrap-subst w483) (wrap-marks w483))) (lambda (x516 . ignore515) x516)) id513))) (else (error-hook (quote id-var-name) (quote "invalid id") id482)))))) (same-marks? (lambda (x517 y) (or (eq? x517 y) (and (not (null? x517)) (not (null? y)) (eq? (car x517) (car y)) (same-marks? (cdr x517) (cdr y)))))) (join-marks (lambda (m1 m2) (smart-append m1 m2))) (join-wraps (lambda (w1518 w2) (let ((m1519 (wrap-marks w1518)) (s1 (wrap-subst w1518))) (if (null? m1519) (if (null? s1) w2 (make-wrap (wrap-marks w2) (smart-append s1 (wrap-subst w2)))) (make-wrap (smart-append m1519 (wrap-marks w2)) (smart-append s1 (wrap-subst w2))))))) (smart-append (lambda (m1520 m2521) (if (null? m2521) m1520 (append m1520 m2521)))) (make-binding-wrap (lambda (ids522 labels523 w524) (if (null? ids522) w524 (make-wrap (wrap-marks w524) (cons (let ((labelvec (list->vector labels523))) (let ((n525 (vector-length labelvec))) (let ((symnamevec (make-vector n525)) (marksvec (make-vector n525))) (begin (let f526 ((ids527 ids522) (i528 (quote 0))) (if (not (null? ids527)) (call-with-values (lambda () (id-sym-name&marks (car ids527) w524)) (lambda (symname marks529) (begin (vector-set! symnamevec i528 symname) (vector-set! marksvec i528 marks529) (f526 (cdr ids527) (fx+ i528 (quote 1)))))))) (make-ribcage symnamevec marksvec labelvec))))) (wrap-subst w524)))))) (extend-ribcage! (lambda (ribcage530 id531 label532) (begin (set-ribcage-symnames! ribcage530 (cons (let ((e533 (syntax-object-expression id531))) (if (annotation? e533) (annotation-expression e533) e533)) (ribcage-symnames ribcage530))) (set-ribcage-marks! ribcage530 (cons (wrap-marks (syntax-object-wrap id531)) (ribcage-marks ribcage530))) (set-ribcage-labels! ribcage530 (cons label532 (ribcage-labels ribcage530)))))) (anti-mark (lambda (w534) (make-wrap (cons (quote #f) (wrap-marks w534)) (cons (quote shift) (wrap-subst w534))))) (set-ribcage-labels! (lambda (x535 update) (vector-set! x535 (quote 3) update))) (set-ribcage-marks! (lambda (x536 update537) (vector-set! x536 (quote 2) update537))) (set-ribcage-symnames! (lambda (x538 update539) (vector-set! x538 (quote 1) update539))) (ribcage-labels (lambda (x540) (vector-ref x540 (quote 3)))) (ribcage-marks (lambda (x541) (vector-ref x541 (quote 2)))) (ribcage-symnames (lambda (x542) (vector-ref x542 (quote 1)))) (ribcage? (lambda (x543) (and (vector? x543) (= (vector-length x543) (quote 4)) (eq? (vector-ref x543 (quote 0)) (quote ribcage))))) (make-ribcage (lambda (symnames544 marks545 labels546) (vector (quote ribcage) symnames544 marks545 labels546))) (gen-labels (lambda (ls547) (if (null? ls547) (quote ()) (cons (gen-label) (gen-labels (cdr ls547)))))) (gen-label (lambda () (string (quote #\i)))) (wrap-subst cdr) (wrap-marks car) (make-wrap cons) (id-sym-name&marks (lambda (x548 w549) (if (syntax-object? x548) (values (let ((e550 (syntax-object-expression x548))) (if (annotation? e550) (annotation-expression e550) e550)) (join-marks (wrap-marks w549) (wrap-marks (syntax-object-wrap x548)))) (values (let ((e551 x548)) (if (annotation? e551) (annotation-expression e551) e551)) (wrap-marks w549))))) (id? (lambda (x552) (cond ((symbol? x552) (quote #t)) ((syntax-object? x552) (symbol? (let ((e553 (syntax-object-expression x552))) (if (annotation? e553) (annotation-expression e553) e553)))) ((annotation? x552) (symbol? (annotation-expression x552))) (else (quote #f))))) (nonsymbol-id? (lambda (x554) (and (syntax-object? x554) (symbol? (let ((e555 (syntax-object-expression x554))) (if (annotation? e555) (annotation-expression e555) e555)))))) (global-extend (lambda (type556 sym557 val558) (put-global-definition-hook sym557 (cons type556 val558)))) (lookup (lambda (x559 r560) (cond ((assq x559 r560) => cdr) ((symbol? x559) (or (get-global-definition-hook x559) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env (lambda (r561) (if (null? r561) (quote ()) (let ((a562 (car r561))) (if (eq? (cadr a562) (quote macro)) (cons a562 (macros-only-env (cdr r561))) (macros-only-env (cdr r561))))))) (extend-var-env (lambda (labels563 vars564 r565) (if (null? labels563) r565 (extend-var-env (cdr labels563) (cdr vars564) (cons (cons (car labels563) (cons (quote lexical) (car vars564))) r565))))) (extend-env (lambda (labels566 bindings567 r568) (if (null? labels566) r568 (extend-env (cdr labels566) (cdr bindings567) (cons (cons (car labels566) (car bindings567)) r568))))) (binding-value cdr) (binding-type car) (source-annotation (lambda (x569) (cond ((annotation? x569) (annotation-source x569)) ((syntax-object? x569) (source-annotation (syntax-object-expression x569))) (else (quote #f))))) (set-syntax-object-wrap! (lambda (x570 update571) (vector-set! x570 (quote 2) update571))) (set-syntax-object-expression! (lambda (x572 update573) (vector-set! x572 (quote 1) update573))) (syntax-object-wrap (lambda (x574) (vector-ref x574 (quote 2)))) (syntax-object-expression (lambda (x575) (vector-ref x575 (quote 1)))) (syntax-object? (lambda (x576) (and (vector? x576) (= (vector-length x576) (quote 3)) (eq? (vector-ref x576 (quote 0)) (quote syntax-object))))) (make-syntax-object (lambda (expression wrap577) (vector (quote syntax-object) expression wrap577))) (build-letrec (lambda (src578 vars579 val-exps body-exp) (if (null? vars579) body-exp (list (quote letrec) (map list vars579 val-exps) body-exp)))) (build-named-let (lambda (src580 vars581 val-exps582 body-exp583) (if (null? vars581) body-exp583 (list (quote let) (car vars581) (map list (cdr vars581) val-exps582) body-exp583)))) (build-let (lambda (src584 vars585 val-exps586 body-exp587) (if (null? vars585) body-exp587 (list (quote let) (map list vars585 val-exps586) body-exp587)))) (build-sequence (lambda (src588 exps) (if (null? (cdr exps)) (car exps) (cons (quote begin) exps)))) (get-global-definition-hook (lambda (symbol) (getprop symbol (quote *sc-expander*)))) (put-global-definition-hook (lambda (symbol589 binding) (putprop symbol589 (quote *sc-expander*) binding))) (error-hook (lambda (who590 why what) (error who590 (quote "~a ~s") why what))) (local-eval-hook (lambda (x591) (eval (list noexpand x591) (interaction-environment)))) (top-level-eval-hook (lambda (x592) (eval (list noexpand x592) (interaction-environment)))) (annotation? (lambda (x593) (quote #f))) (fx< <) (fx= =) (fx- -) (fx+ +) (noexpand (quote "noexpand"))) (begin (global-extend (quote local-syntax) (quote letrec-syntax) (quote #t)) (global-extend (quote local-syntax) (quote let-syntax) (quote #f)) (global-extend (quote core) (quote fluid-let-syntax) (lambda (e594 r595 w596 s597) ((lambda (tmp598) ((lambda (tmp599) (if (if tmp599 (apply (lambda (_600 var601 val602 e1603 e2604) (valid-bound-ids? var601)) tmp599) (quote #f)) (apply (lambda (_606 var607 val608 e1609 e2610) (let ((names (map (lambda (x611) (id-var-name x611 w596)) var607))) (begin (for-each (lambda (id613 n614) (let ((t615 (binding-type (lookup n614 r595)))) (if (memv t615 (quote (displaced-lexical))) (syntax-error (source-wrap id613 w596 s597) (quote "identifier out of context"))))) var607 names) (chi-body (cons e1609 e2610) (source-wrap e594 w596 s597) (extend-env names (let ((trans-r618 (macros-only-env r595))) (map (lambda (x619) (cons (quote macro) (eval-local-transformer (chi x619 trans-r618 w596)))) val608)) r595) w596)))) tmp599) ((lambda (_621) (syntax-error (source-wrap e594 w596 s597))) tmp598))) (syntax-dispatch tmp598 (quote (any #(each (any any)) any . each-any))))) e594))) (global-extend (quote core) (quote quote) (lambda (e622 r623 w624 s625) ((lambda (tmp626) ((lambda (tmp627) (if tmp627 (apply (lambda (_628 e629) (list (quote quote) (strip e629 w624))) tmp627) ((lambda (_630) (syntax-error (source-wrap e622 w624 s625))) tmp626))) (syntax-dispatch tmp626 (quote (any any))))) e622))) (global-extend (quote core) (quote syntax) (letrec ((regen (lambda (x631) (let ((t632 (car x631))) (if (memv t632 (quote (ref))) (cadr x631) (if (memv t632 (quote (primitive))) (cadr x631) (if (memv t632 (quote (quote))) (list (quote quote) (cadr x631)) (if (memv t632 (quote (lambda))) (list (quote lambda) (cadr x631) (regen (caddr x631))) (if (memv t632 (quote (map))) (let ((ls633 (map regen (cdr x631)))) (cons (if (fx= (length ls633) (quote 2)) (quote map) (quote map)) ls633)) (cons (car x631) (map regen (cdr x631))))))))))) (gen-vector (lambda (x634) (cond ((eq? (car x634) (quote list)) (cons (quote vector) (cdr x634))) ((eq? (car x634) (quote quote)) (list (quote quote) (list->vector (cadr x634)))) (else (list (quote list->vector) x634))))) (gen-append (lambda (x635 y636) (if (equal? y636 (quote (quote ()))) x635 (list (quote append) x635 y636)))) (gen-cons (lambda (x637 y638) (let ((t639 (car y638))) (if (memv t639 (quote (quote))) (if (eq? (car x637) (quote quote)) (list (quote quote) (cons (cadr x637) (cadr y638))) (if (eq? (cadr y638) (quote ())) (list (quote list) x637) (list (quote cons) x637 y638))) (if (memv t639 (quote (list))) (cons (quote list) (cons x637 (cdr y638))) (list (quote cons) x637 y638)))))) (gen-map (lambda (e640 map-env) (let ((formals (map cdr map-env)) (actuals (map (lambda (x641) (list (quote ref) (car x641))) map-env))) (cond ((eq? (car e640) (quote ref)) (car actuals)) ((andmap (lambda (x642) (and (eq? (car x642) (quote ref)) (memq (cadr x642) formals))) (cdr e640)) (cons (quote map) (cons (list (quote primitive) (car e640)) (map (let ((r643 (map cons formals actuals))) (lambda (x644) (cdr (assq (cadr x644) r643)))) (cdr e640))))) (else (cons (quote map) (cons (list (quote lambda) formals e640) actuals))))))) (gen-mappend (lambda (e645 map-env646) (list (quote apply) (quote (primitive append)) (gen-map e645 map-env646)))) (gen-ref (lambda (src647 var648 level649 maps) (if (fx= level649 (quote 0)) (values var648 maps) (if (null? maps) (syntax-error src647 (quote "missing ellipsis in syntax form")) (call-with-values (lambda () (gen-ref src647 var648 (fx- level649 (quote 1)) (cdr maps))) (lambda (outer-var outer-maps) (let ((b650 (assq outer-var (car maps)))) (if b650 (values (cdr b650) maps) (let ((inner-var (gen-var (quote tmp)))) (values inner-var (cons (cons (cons outer-var inner-var) (car maps)) outer-maps))))))))))) (gen-syntax (lambda (src651 e652 r653 maps654 ellipsis?655) (if (id? e652) (let ((label656 (id-var-name e652 (quote (()))))) (let ((b657 (lookup label656 r653))) (if (eq? (binding-type b657) (quote syntax)) (call-with-values (lambda () (let ((var.lev (binding-value b657))) (gen-ref src651 (car var.lev) (cdr var.lev) maps654))) (lambda (var658 maps659) (values (list (quote ref) var658) maps659))) (if (ellipsis?655 e652) (syntax-error src651 (quote "misplaced ellipsis in syntax form")) (values (list (quote quote) e652) maps654))))) ((lambda (tmp660) ((lambda (tmp661) (if (if tmp661 (apply (lambda (dots e662) (ellipsis?655 dots)) tmp661) (quote #f)) (apply (lambda (dots663 e664) (gen-syntax src651 e664 r653 maps654 (lambda (x665) (quote #f)))) tmp661) ((lambda (tmp666) (if (if tmp666 (apply (lambda (x667 dots668 y669) (ellipsis?655 dots668)) tmp666) (quote #f)) (apply (lambda (x670 dots671 y672) (let f673 ((y674 y672) (k675 (lambda (maps676) (call-with-values (lambda () (gen-syntax src651 x670 r653 (cons (quote ()) maps676) ellipsis?655)) (lambda (x677 maps678) (if (null? (car maps678)) (syntax-error src651 (quote "extra ellipsis in syntax form")) (values (gen-map x677 (car maps678)) (cdr maps678)))))))) ((lambda (tmp679) ((lambda (tmp680) (if (if tmp680 (apply (lambda (dots681 y682) (ellipsis?655 dots681)) tmp680) (quote #f)) (apply (lambda (dots683 y684) (f673 y684 (lambda (maps685) (call-with-values (lambda () (k675 (cons (quote ()) maps685))) (lambda (x686 maps687) (if (null? (car maps687)) (syntax-error src651 (quote "extra ellipsis in syntax form")) (values (gen-mappend x686 (car maps687)) (cdr maps687)))))))) tmp680) ((lambda (_688) (call-with-values (lambda () (gen-syntax src651 y674 r653 maps654 ellipsis?655)) (lambda (y689 maps690) (call-with-values (lambda () (k675 maps690)) (lambda (x691 maps692) (values (gen-append x691 y689) maps692)))))) tmp679))) (syntax-dispatch tmp679 (quote (any . any))))) y674))) tmp666) ((lambda (tmp693) (if tmp693 (apply (lambda (x694 y695) (call-with-values (lambda () (gen-syntax src651 x694 r653 maps654 ellipsis?655)) (lambda (x696 maps697) (call-with-values (lambda () (gen-syntax src651 y695 r653 maps697 ellipsis?655)) (lambda (y698 maps699) (values (gen-cons x696 y698) maps699)))))) tmp693) ((lambda (tmp700) (if tmp700 (apply (lambda (e1701 e2702) (call-with-values (lambda () (gen-syntax src651 (cons e1701 e2702) r653 maps654 ellipsis?655)) (lambda (e704 maps705) (values (gen-vector e704) maps705)))) tmp700) ((lambda (_706) (values (list (quote quote) e652) maps654)) tmp660))) (syntax-dispatch tmp660 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp660 (quote (any . any)))))) (syntax-dispatch tmp660 (quote (any any . any)))))) (syntax-dispatch tmp660 (quote (any any))))) e652))))) (lambda (e707 r708 w709 s710) (let ((e711 (source-wrap e707 w709 s710))) ((lambda (tmp712) ((lambda (tmp713) (if tmp713 (apply (lambda (_714 x715) (call-with-values (lambda () (gen-syntax e711 x715 r708 (quote ()) ellipsis?)) (lambda (e716 maps717) (regen e716)))) tmp713) ((lambda (_718) (syntax-error e711)) tmp712))) (syntax-dispatch tmp712 (quote (any any))))) e711))))) (global-extend (quote core) (quote lambda) (lambda (e719 r720 w721 s722) ((lambda (tmp723) ((lambda (tmp724) (if tmp724 (apply (lambda (_725 c726) (chi-lambda-clause (source-wrap e719 w721 s722) c726 r720 w721 (lambda (vars727 body728) (list (quote lambda) vars727 body728)))) tmp724) (syntax-error tmp723))) (syntax-dispatch tmp723 (quote (any . any))))) e719))) (global-extend (quote core) (quote let) (letrec ((chi-let (lambda (e729 r730 w731 s732 constructor733 ids734 vals735 exps736) (if (not (valid-bound-ids? ids734)) (syntax-error e729 (quote "duplicate bound variable in")) (let ((labels737 (gen-labels ids734)) (new-vars738 (map gen-var ids734))) (let ((nw (make-binding-wrap ids734 labels737 w731)) (nr (extend-var-env labels737 new-vars738 r730))) (constructor733 s732 new-vars738 (map (lambda (x739) (chi x739 r730 w731)) vals735) (chi-body exps736 (source-wrap e729 nw s732) nr nw)))))))) (lambda (e740 r741 w742 s743) ((lambda (tmp744) ((lambda (tmp745) (if tmp745 (apply (lambda (_746 id747 val748 e1749 e2750) (chi-let e740 r741 w742 s743 build-let id747 val748 (cons e1749 e2750))) tmp745) ((lambda (tmp754) (if (if tmp754 (apply (lambda (_755 f756 id757 val758 e1759 e2760) (id? f756)) tmp754) (quote #f)) (apply (lambda (_761 f762 id763 val764 e1765 e2766) (chi-let e740 r741 w742 s743 build-named-let (cons f762 id763) val764 (cons e1765 e2766))) tmp754) ((lambda (_770) (syntax-error (source-wrap e740 w742 s743))) tmp744))) (syntax-dispatch tmp744 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp744 (quote (any #(each (any any)) any . each-any))))) e740)))) (global-extend (quote core) (quote letrec) (lambda (e771 r772 w773 s774) ((lambda (tmp775) ((lambda (tmp776) (if tmp776 (apply (lambda (_777 id778 val779 e1780 e2781) (let ((ids782 id778)) (if (not (valid-bound-ids? ids782)) (syntax-error e771 (quote "duplicate bound variable in")) (let ((labels784 (gen-labels ids782)) (new-vars785 (map gen-var ids782))) (let ((w786 (make-binding-wrap ids782 labels784 w773)) (r787 (extend-var-env labels784 new-vars785 r772))) (build-letrec s774 new-vars785 (map (lambda (x788) (chi x788 r787 w786)) val779) (chi-body (cons e1780 e2781) (source-wrap e771 w786 s774) r787 w786))))))) tmp776) ((lambda (_791) (syntax-error (source-wrap e771 w773 s774))) tmp775))) (syntax-dispatch tmp775 (quote (any #(each (any any)) any . each-any))))) e771))) (global-extend (quote core) (quote set!) (lambda (e792 r793 w794 s795) ((lambda (tmp796) ((lambda (tmp797) (if (if tmp797 (apply (lambda (_798 id799 val800) (id? id799)) tmp797) (quote #f)) (apply (lambda (_801 id802 val803) (let ((val804 (chi val803 r793 w794)) (n805 (id-var-name id802 w794))) (let ((b806 (lookup n805 r793))) (let ((t807 (binding-type b806))) (if (memv t807 (quote (lexical))) (list (quote set!) (binding-value b806) val804) (if (memv t807 (quote (global))) (list (quote set!) n805 val804) (if (memv t807 (quote (displaced-lexical))) (syntax-error (wrap id802 w794) (quote "identifier out of context")) (syntax-error (source-wrap e792 w794 s795))))))))) tmp797) ((lambda (_808) (syntax-error (source-wrap e792 w794 s795))) tmp796))) (syntax-dispatch tmp796 (quote (any any any))))) e792))) (global-extend (quote begin) (quote begin) (quote ())) (global-extend (quote define) (quote define) (quote ())) (global-extend (quote define-syntax) (quote define-syntax) (quote ())) (global-extend (quote eval-when) (quote eval-when) (quote ())) (global-extend (quote core) (quote syntax-case) (letrec ((gen-syntax-case (lambda (x809 keys clauses r810) (if (null? clauses) (list (quote syntax-error) x809) ((lambda (tmp811) ((lambda (tmp812) (if tmp812 (apply (lambda (pat exp813) (if (and (id? pat) (andmap (lambda (x814) (not (free-id=? pat x814))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) keys))) (let ((labels815 (list (gen-label))) (var816 (gen-var pat))) (list (list (quote lambda) (list var816) (chi exp813 (extend-env labels815 (list (cons (quote syntax) (cons var816 (quote 0)))) r810) (make-binding-wrap (list pat) labels815 (quote (()))))) x809)) (gen-clause x809 keys (cdr clauses) r810 pat (quote #t) exp813))) tmp812) ((lambda (tmp817) (if tmp817 (apply (lambda (pat818 fender exp819) (gen-clause x809 keys (cdr clauses) r810 pat818 fender exp819)) tmp817) ((lambda (_820) (syntax-error (car clauses) (quote "invalid syntax-case clause"))) tmp811))) (syntax-dispatch tmp811 (quote (any any any)))))) (syntax-dispatch tmp811 (quote (any any))))) (car clauses))))) (gen-clause (lambda (x821 keys822 clauses823 r824 pat825 fender826 exp827) (call-with-values (lambda () (convert-pattern pat825 keys822)) (lambda (p828 pvars) (cond ((not (distinct-bound-ids? (map car pvars))) (syntax-error pat825 (quote "duplicate pattern variable in syntax-case pattern"))) ((not (andmap (lambda (x829) (not (ellipsis? (car x829)))) pvars)) (syntax-error pat825 (quote "misplaced ellipsis in syntax-case pattern"))) (else (let ((y830 (gen-var (quote tmp)))) (list (list (quote lambda) (list y830) (let ((y831 y830)) (list (quote if) ((lambda (tmp832) ((lambda (tmp833) (if tmp833 (apply (lambda () y831) tmp833) ((lambda (_834) (list (quote if) y831 (build-dispatch-call pvars fender826 y831 r824) (list (quote quote) (quote #f)))) tmp832))) (syntax-dispatch tmp832 (quote #(atom #t))))) fender826) (build-dispatch-call pvars exp827 y831 r824) (gen-syntax-case x821 keys822 clauses823 r824)))) (if (eq? p828 (quote any)) (list (quote list) x821) (list (quote syntax-dispatch) x821 (list (quote quote) p828))))))))))) (build-dispatch-call (lambda (pvars835 exp836 y837 r838) (let ((ids839 (map car pvars835)) (levels (map cdr pvars835))) (let ((labels840 (gen-labels ids839)) (new-vars841 (map gen-var ids839))) (list (quote apply) (list (quote lambda) new-vars841 (chi exp836 (extend-env labels840 (map (lambda (var842 level843) (cons (quote syntax) (cons var842 level843))) new-vars841 (map cdr pvars835)) r838) (make-binding-wrap ids839 labels840 (quote (()))))) y837))))) (convert-pattern (lambda (pattern keys844) (let cvt ((p845 pattern) (n846 (quote 0)) (ids847 (quote ()))) (if (id? p845) (if (bound-id-member? p845 keys844) (values (vector (quote free-id) p845) ids847) (values (quote any) (cons (cons p845 n846) ids847))) ((lambda (tmp848) ((lambda (tmp849) (if (if tmp849 (apply (lambda (x850 dots851) (ellipsis? dots851)) tmp849) (quote #f)) (apply (lambda (x852 dots853) (call-with-values (lambda () (cvt x852 (fx+ n846 (quote 1)) ids847)) (lambda (p854 ids855) (values (if (eq? p854 (quote any)) (quote each-any) (vector (quote each) p854)) ids855)))) tmp849) ((lambda (tmp856) (if tmp856 (apply (lambda (x857 y858) (call-with-values (lambda () (cvt y858 n846 ids847)) (lambda (y859 ids860) (call-with-values (lambda () (cvt x857 n846 ids860)) (lambda (x861 ids862) (values (cons x861 y859) ids862)))))) tmp856) ((lambda (tmp863) (if tmp863 (apply (lambda () (values (quote ()) ids847)) tmp863) ((lambda (tmp864) (if tmp864 (apply (lambda (x865) (call-with-values (lambda () (cvt x865 n846 ids847)) (lambda (p867 ids868) (values (vector (quote vector) p867) ids868)))) tmp864) ((lambda (x869) (values (vector (quote atom) (strip p845 (quote (())))) ids847)) tmp848))) (syntax-dispatch tmp848 (quote #(vector each-any)))))) (syntax-dispatch tmp848 (quote ()))))) (syntax-dispatch tmp848 (quote (any . any)))))) (syntax-dispatch tmp848 (quote (any any))))) p845)))))) (lambda (e870 r871 w872 s873) (let ((e874 (source-wrap e870 w872 s873))) ((lambda (tmp875) ((lambda (tmp876) (if tmp876 (apply (lambda (_877 val878 key m879) (if (andmap (lambda (x880) (and (id? x880) (not (ellipsis? x880)))) key) (let ((x882 (gen-var (quote tmp)))) (list (list (quote lambda) (list x882) (gen-syntax-case x882 key m879 r871)) (chi val878 r871 (quote (()))))) (syntax-error e874 (quote "invalid literals list in")))) tmp876) (syntax-error tmp875))) (syntax-dispatch tmp875 (quote (any any each-any . each-any))))) e874))))) (set! sc-expand (let ((m885 (quote e)) (esew886 (quote (eval)))) (lambda (x887) (if (and (pair? x887) (equal? (car x887) noexpand)) (cadr x887) (chi-top x887 (quote ()) (quote ((top))) m885 esew886))))) (set! sc-expand3 (let ((m888 (quote e)) (esew889 (quote (eval)))) (lambda (x890 . rest) (if (and (pair? x890) (equal? (car x890) noexpand)) (cadr x890) (chi-top x890 (quote ()) (quote ((top))) (if (null? rest) m888 (car rest)) (if (or (null? rest) (null? (cdr rest))) esew889 (cadr rest))))))) (set! identifier? (lambda (x891) (nonsymbol-id? x891))) (set! datum->syntax-object (lambda (id892 datum) (begin (let ((x893 id892)) (if (not (nonsymbol-id? x893)) (error-hook (quote datum->syntax-object) (quote "invalid argument") x893))) (make-syntax-object datum (syntax-object-wrap id892))))) (set! syntax-object->datum (lambda (x894) (strip x894 (quote (()))))) (set! generate-temporaries (lambda (ls895) (begin (let ((x896 ls895)) (if (not (list? x896)) (error-hook (quote generate-temporaries) (quote "invalid argument") x896))) (map (lambda (x897) (wrap (gensym) (quote ((top))))) ls895)))) (set! free-identifier=? (lambda (x898 y899) (begin (let ((x900 x898)) (if (not (nonsymbol-id? x900)) (error-hook (quote free-identifier=?) (quote "invalid argument") x900))) (let ((x901 y899)) (if (not (nonsymbol-id? x901)) (error-hook (quote free-identifier=?) (quote "invalid argument") x901))) (free-id=? x898 y899)))) (set! bound-identifier=? (lambda (x902 y903) (begin (let ((x904 x902)) (if (not (nonsymbol-id? x904)) (error-hook (quote bound-identifier=?) (quote "invalid argument") x904))) (let ((x905 y903)) (if (not (nonsymbol-id? x905)) (error-hook (quote bound-identifier=?) (quote "invalid argument") x905))) (bound-id=? x902 y903)))) (set! syntax-error (lambda (object . messages) (begin (for-each (lambda (x906) (let ((x907 x906)) (if (not (string? x907)) (error-hook (quote syntax-error) (quote "invalid argument") x907)))) messages) (let ((message (if (null? messages) (quote "invalid syntax") (apply string-append messages)))) (error-hook (quote #f) message (strip object (quote (())))))))) (set! install-global-transformer (lambda (sym908 v909) (begin (let ((x910 sym908)) (if (not (symbol? x910)) (error-hook (quote define-syntax) (quote "invalid argument") x910))) (let ((x911 v909)) (if (not (procedure? x911)) (error-hook (quote define-syntax) (quote "invalid argument") x911))) (global-extend (quote macro) sym908 v909)))) (letrec ((match (lambda (e912 p913 w914 r915) (cond ((not r915) (quote #f)) ((eq? p913 (quote any)) (cons (wrap e912 w914) r915)) ((syntax-object? e912) (match* (let ((e916 (syntax-object-expression e912))) (if (annotation? e916) (annotation-expression e916) e916)) p913 (join-wraps w914 (syntax-object-wrap e912)) r915)) (else (match* (let ((e917 e912)) (if (annotation? e917) (annotation-expression e917) e917)) p913 w914 r915))))) (match* (lambda (e918 p919 w920 r921) (cond ((null? p919) (and (null? e918) r921)) ((pair? p919) (and (pair? e918) (match (car e918) (car p919) w920 (match (cdr e918) (cdr p919) w920 r921)))) ((eq? p919 (quote each-any)) (let ((l (match-each-any e918 w920))) (and l (cons l r921)))) (else (let ((t922 (vector-ref p919 (quote 0)))) (if (memv t922 (quote (each))) (if (null? e918) (match-empty (vector-ref p919 (quote 1)) r921) (let ((l923 (match-each e918 (vector-ref p919 (quote 1)) w920))) (and l923 (let collect ((l924 l923)) (if (null? (car l924)) r921 (cons (map car l924) (collect (map cdr l924)))))))) (if (memv t922 (quote (free-id))) (and (id? e918) (free-id=? (wrap e918 w920) (vector-ref p919 (quote 1))) r921) (if (memv t922 (quote (atom))) (and (equal? (vector-ref p919 (quote 1)) (strip e918 w920)) r921) (if (memv t922 (quote (vector))) (and (vector? e918) (match (vector->list e918) (vector-ref p919 (quote 1)) w920 r921))))))))))) (match-empty (lambda (p925 r926) (cond ((null? p925) r926) ((eq? p925 (quote any)) (cons (quote ()) r926)) ((pair? p925) (match-empty (car p925) (match-empty (cdr p925) r926))) ((eq? p925 (quote each-any)) (cons (quote ()) r926)) (else (let ((t927 (vector-ref p925 (quote 0)))) (if (memv t927 (quote (each))) (match-empty (vector-ref p925 (quote 1)) r926) (if (memv t927 (quote (free-id atom))) r926 (if (memv t927 (quote (vector))) (match-empty (vector-ref p925 (quote 1)) r926))))))))) (match-each-any (lambda (e928 w929) (cond ((annotation? e928) (match-each-any (annotation-expression e928) w929)) ((pair? e928) (let ((l930 (match-each-any (cdr e928) w929))) (and l930 (cons (wrap (car e928) w929) l930)))) ((null? e928) (quote ())) ((syntax-object? e928) (match-each-any (syntax-object-expression e928) (join-wraps w929 (syntax-object-wrap e928)))) (else (quote #f))))) (match-each (lambda (e931 p932 w933) (cond ((annotation? e931) (match-each (annotation-expression e931) p932 w933)) ((pair? e931) (let ((first934 (match (car e931) p932 w933 (quote ())))) (and first934 (let ((rest935 (match-each (cdr e931) p932 w933))) (and rest935 (cons first934 rest935)))))) ((null? e931) (quote ())) ((syntax-object? e931) (match-each (syntax-object-expression e931) p932 (join-wraps w933 (syntax-object-wrap e931)))) (else (quote #f)))))) (set! syntax-dispatch (lambda (e936 p937) (cond ((eq? p937 (quote any)) (list e936)) ((syntax-object? e936) (match* (let ((e938 (syntax-object-expression e936))) (if (annotation? e938) (annotation-expression e938) e938)) p937 (syntax-object-wrap e936) (quote ()))) (else (match* (let ((e939 e936)) (if (annotation? e939) (annotation-expression e939) e939)) p937 (quote (())) (quote ()))))))))) -(install-global-transformer (quote with-syntax) (lambda (x940) ((lambda (tmp941) ((lambda (tmp942) (if tmp942 (apply (lambda (_943 e1944 e2945) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e1944 e2945))) tmp942) ((lambda (tmp947) (if tmp947 (apply (lambda (_948 out in e1949 e2950) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) in (quote ()) (list out (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e1949 e2950))))) tmp947) ((lambda (tmp952) (if tmp952 (apply (lambda (_953 out954 in955 e1956 e2957) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) in955) (quote ()) (list out954 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e1956 e2957))))) tmp952) (syntax-error tmp941))) (syntax-dispatch tmp941 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp941 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp941 (quote (any () any . each-any))))) x940))) -(install-global-transformer (quote syntax-rules) (lambda (x961) ((lambda (tmp962) ((lambda (tmp963) (if tmp963 (apply (lambda (_964 k965 keyword pattern966 template) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons k965 (map (lambda (tmp969 tmp968) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) tmp968) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) tmp969))) template pattern966)))))) tmp963) (syntax-error tmp962))) (syntax-dispatch tmp962 (quote (any each-any . #(each ((any . any) any))))))) x961))) -(install-global-transformer (quote let*) (lambda (x970) ((lambda (tmp971) ((lambda (tmp972) (if (if tmp972 (apply (lambda (let* x973 v974 e1975 e2976) (andmap identifier? x973)) tmp972) (quote #f)) (apply (lambda (let*978 x979 v980 e1981 e2982) (let f983 ((bindings984 (map list x979 v980))) (if (null? bindings984) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote ()) (cons e1981 e2982))) ((lambda (tmp988) ((lambda (tmp989) (if tmp989 (apply (lambda (body binding) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list binding) body)) tmp989) (syntax-error tmp988))) (syntax-dispatch tmp988 (quote (any any))))) (list (f983 (cdr bindings984)) (car bindings984)))))) tmp972) (syntax-error tmp971))) (syntax-dispatch tmp971 (quote (any #(each (any any)) any . each-any))))) x970))) -(install-global-transformer (quote do) (lambda (orig-x) ((lambda (tmp990) ((lambda (tmp991) (if tmp991 (apply (lambda (_992 var init step e0 e1 c) ((lambda (tmp993) ((lambda (tmp994) (if tmp994 (apply (lambda (step995) ((lambda (tmp996) ((lambda (tmp997) (if tmp997 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list var init) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) e0) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append c (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) step995))))))) tmp997) ((lambda (tmp1002) (if tmp1002 (apply (lambda (e11003 e2) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list var init) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) e0 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (cons e11003 e2)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append c (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) step995))))))) tmp1002) (syntax-error tmp996))) (syntax-dispatch tmp996 (quote (any . each-any)))))) (syntax-dispatch tmp996 (quote ())))) e1)) tmp994) (syntax-error tmp993))) (syntax-dispatch tmp993 (quote each-any)))) (map (lambda (v s) ((lambda (tmp1010) ((lambda (tmp1011) (if tmp1011 (apply (lambda () v) tmp1011) ((lambda (tmp1012) (if tmp1012 (apply (lambda (e) e) tmp1012) ((lambda (_1013) (syntax-error orig-x)) tmp1010))) (syntax-dispatch tmp1010 (quote (any)))))) (syntax-dispatch tmp1010 (quote ())))) s)) var step))) tmp991) (syntax-error tmp990))) (syntax-dispatch tmp990 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x))) -(install-global-transformer (quote quasiquote) (letrec ((quasicons (lambda (x1016 y) ((lambda (tmp1017) ((lambda (tmp1018) (if tmp1018 (apply (lambda (x1019 y1020) ((lambda (tmp1021) ((lambda (tmp1022) (if tmp1022 (apply (lambda (dy) ((lambda (tmp1023) ((lambda (tmp1024) (if tmp1024 (apply (lambda (dx) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons dx dy))) tmp1024) ((lambda (_1025) (if (null? dy) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1019) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1019 y1020))) tmp1023))) (syntax-dispatch tmp1023 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) x1019)) tmp1022) ((lambda (tmp) (if tmp (apply (lambda (stuff) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons x1019 stuff))) tmp) ((lambda (else) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1019 y1020)) tmp1021))) (syntax-dispatch tmp1021 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . any)))))) (syntax-dispatch tmp1021 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) y1020)) tmp1018) (syntax-error tmp1017))) (syntax-dispatch tmp1017 (quote (any any))))) (list x1016 y)))) (quasiappend (lambda (x y1026) ((lambda (tmp1027) ((lambda (tmp1028) (if tmp1028 (apply (lambda (x1029 y1030) ((lambda (tmp1031) ((lambda (tmp1032) (if tmp1032 (apply (lambda () x1029) tmp1032) ((lambda (_) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1029 y1030)) tmp1031))) (syntax-dispatch tmp1031 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) ()))))) y1030)) tmp1028) (syntax-error tmp1027))) (syntax-dispatch tmp1027 (quote (any any))))) (list x y1026)))) (quasivector (lambda (x1033) ((lambda (tmp1034) ((lambda (x1035) ((lambda (tmp1036) ((lambda (tmp1037) (if tmp1037 (apply (lambda (x1038) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (list->vector x1038))) tmp1037) ((lambda (tmp1040) (if tmp1040 (apply (lambda (x1041) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1041)) tmp1040) ((lambda (_1043) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1035)) tmp1036))) (syntax-dispatch tmp1036 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . each-any)))))) (syntax-dispatch tmp1036 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) each-any))))) x1035)) tmp1034)) x1033))) (quasi (lambda (p lev) ((lambda (tmp1044) ((lambda (tmp1045) (if tmp1045 (apply (lambda (p1046) (if (= lev (quote 0)) p1046 (quasicons (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi (list p1046) (- lev (quote 1)))))) tmp1045) ((lambda (tmp1047) (if tmp1047 (apply (lambda (p1048 q) (if (= lev (quote 0)) (quasiappend p1048 (quasi q lev)) (quasicons (quasicons (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi (list p1048) (- lev (quote 1)))) (quasi q lev)))) tmp1047) ((lambda (tmp1049) (if tmp1049 (apply (lambda (p1050) (quasicons (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi (list p1050) (+ lev (quote 1))))) tmp1049) ((lambda (tmp1051) (if tmp1051 (apply (lambda (p1052 q1053) (quasicons (quasi p1052 lev) (quasi q1053 lev))) tmp1051) ((lambda (tmp1054) (if tmp1054 (apply (lambda (x1055) (quasivector (quasi x1055 lev))) tmp1054) ((lambda (p1057) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) p1057)) tmp1044))) (syntax-dispatch tmp1044 (quote #(vector each-any)))))) (syntax-dispatch tmp1044 (quote (any . any)))))) (syntax-dispatch tmp1044 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any)))))) (syntax-dispatch tmp1044 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any) . any)))))) (syntax-dispatch tmp1044 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) p)))) (lambda (x1058) ((lambda (tmp1059) ((lambda (tmp1060) (if tmp1060 (apply (lambda (_1061 e1062) (quasi e1062 (quote 0))) tmp1060) (syntax-error tmp1059))) (syntax-dispatch tmp1059 (quote (any any))))) x1058)))) -(install-global-transformer (quote include) (lambda (x1063) (letrec ((read-file (lambda (fn k) (let ((p1064 (open-input-file fn))) (let f ((x1065 (read p1064))) (if (eof-object? x1065) (begin (close-input-port p1064) (quote ())) (cons (datum->syntax-object k x1065) (f (read p1064))))))))) ((lambda (tmp1066) ((lambda (tmp1067) (if tmp1067 (apply (lambda (k1068 filename) (let ((fn1069 (syntax-object->datum filename))) ((lambda (tmp1070) ((lambda (tmp1071) (if tmp1071 (apply (lambda (exp) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))))) exp)) tmp1071) (syntax-error tmp1070))) (syntax-dispatch tmp1070 (quote each-any)))) (read-file fn1069 k1068)))) tmp1067) (syntax-error tmp1066))) (syntax-dispatch tmp1066 (quote (any any))))) x1063)))) -(install-global-transformer (quote unquote) (lambda (x1073) ((lambda (tmp1074) ((lambda (tmp1075) (if tmp1075 (apply (lambda (_1076 e1077) (error (quote unquote) (quote "expression ,~s not valid outside of quasiquote") (syntax-object->datum e1077))) tmp1075) (syntax-error tmp1074))) (syntax-dispatch tmp1074 (quote (any any))))) x1073))) -(install-global-transformer (quote unquote-splicing) (lambda (x1078) ((lambda (tmp1079) ((lambda (tmp1080) (if tmp1080 (apply (lambda (_1081 e1082) (error (quote unquote-splicing) (quote "expression ,@~s not valid outside of quasiquote") (syntax-object->datum e1082))) tmp1080) (syntax-error tmp1079))) (syntax-dispatch tmp1079 (quote (any any))))) x1078))) -(install-global-transformer (quote case) (lambda (x1083) ((lambda (tmp1084) ((lambda (tmp1085) (if tmp1085 (apply (lambda (_1086 e1087 m1 m2) ((lambda (tmp1088) ((lambda (body1089) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) e1087)) body1089)) tmp1088)) (let f1090 ((clause m1) (clauses m2)) (if (null? clauses) ((lambda (tmp1092) ((lambda (tmp1093) (if tmp1093 (apply (lambda (e11094 e21095) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11094 e21095))) tmp1093) ((lambda (tmp1097) (if tmp1097 (apply (lambda (k1098 e11099 e21100) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) k1098)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11099 e21100)))) tmp1097) ((lambda (_1103) (syntax-error x1083)) tmp1092))) (syntax-dispatch tmp1092 (quote (each-any any . each-any)))))) (syntax-dispatch tmp1092 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) any . each-any))))) clause) ((lambda (tmp1104) ((lambda (rest) ((lambda (tmp1105) ((lambda (tmp1106) (if tmp1106 (apply (lambda (k1107 e11108 e21109) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) k1107)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11108 e21109)) rest)) tmp1106) ((lambda (_1112) (syntax-error x1083)) tmp1105))) (syntax-dispatch tmp1105 (quote (each-any any . each-any))))) clause)) tmp1104)) (f1090 (car clauses) (cdr clauses))))))) tmp1085) (syntax-error tmp1084))) (syntax-dispatch tmp1084 (quote (any any any . each-any))))) x1083))) -(install-global-transformer (quote identifier-syntax) (lambda (x1113) ((lambda (tmp1114) ((lambda (tmp1115) (if tmp1115 (apply (lambda (_1116 e1117) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) e1117)) (list (cons _1116 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e1117 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))))))))) tmp1115) (syntax-error tmp1114))) (syntax-dispatch tmp1114 (quote (any any))))) x1113))) +(letrec ((lambda-var-list (lambda (vars) (let lvl ((vars402 vars) (ls (quote ())) (w (quote (())))) (cond ((pair? vars402) (lvl (cdr vars402) (cons (wrap (car vars402) w) ls) w)) ((id? vars402) (cons (wrap vars402 w) ls)) ((null? vars402) ls) ((syntax-object? vars402) (lvl (syntax-object-expression vars402) ls (join-wraps w (syntax-object-wrap vars402)))) ((annotation? vars402) (lvl (annotation-expression vars402) ls w)) (else (cons vars402 ls)))))) (gen-var (lambda (id) (let ((id403 (if (syntax-object? id) (syntax-object-expression id) id))) (if (annotation? id403) (gensym (annotation-expression id403) generated-symbols) (gensym id403 generated-symbols))))) (strip (lambda (x404 w405) (if (memq (quote top) (wrap-marks w405)) (if (or (annotation? x404) (and (pair? x404) (annotation? (car x404)))) (strip-annotation x404 (quote #f)) x404) (let f406 ((x407 x404)) (cond ((syntax-object? x407) (strip (syntax-object-expression x407) (syntax-object-wrap x407))) ((pair? x407) (let ((a (f406 (car x407))) (d (f406 (cdr x407)))) (if (and (eq? a (car x407)) (eq? d (cdr x407))) x407 (cons a d)))) ((vector? x407) (let ((old (vector->list x407))) (let ((new (map f406 old))) (if (andmap eq? old new) x407 (list->vector new))))) (else x407)))))) (strip-annotation (lambda (x408 parent) (cond ((pair? x408) (let ((new409 (cons (quote #f) (quote #f)))) (begin (when parent (set-annotation-stripped! parent new409)) (set-car! new409 (strip-annotation (car x408) (quote #f))) (set-cdr! new409 (strip-annotation (cdr x408) (quote #f))) new409))) ((annotation? x408) (or (annotation-stripped x408) (strip-annotation (annotation-expression x408) x408))) ((vector? x408) (let ((new410 (make-vector (vector-length x408)))) (begin (when parent (set-annotation-stripped! parent new410)) (let loop ((i411 (- (vector-length x408) (quote 1)))) (unless (fx< i411 (quote 0)) (vector-set! new410 i411 (strip-annotation (vector-ref x408 i411) (quote #f))) (loop (fx- i411 (quote 1))))) new410))) (else x408)))) (ellipsis? (lambda (x412) (and (nonsymbol-id? x412) (free-id=? x412 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))))))) (chi-void (lambda () (list (quote void)))) (eval-local-transformer (lambda (expanded) (let ((p (local-eval-hook expanded))) (if (procedure? p) p (syntax-error p (quote "nonprocedure transfomer")))))) (chi-local-syntax (lambda (rec? e r w413 s k) ((lambda (tmp414) ((lambda (tmp415) (if tmp415 (apply (lambda (_416 id417 val e1 e2) (let ((ids418 id417)) (if (not (valid-bound-ids? ids418)) (syntax-error e (quote "duplicate bound keyword in")) (let ((labels (gen-labels ids418))) (let ((new-w (make-binding-wrap ids418 labels w413))) (k (cons e1 e2) (extend-env labels (let ((w421 (if rec? new-w w413)) (trans-r (macros-only-env r))) (map (lambda (x422) (cons (quote macro) (eval-local-transformer (chi x422 trans-r w421)))) val)) r) new-w s)))))) tmp415) ((lambda (_424) (syntax-error (source-wrap e w413 s))) tmp414))) (syntax-dispatch tmp414 (quote (any #(each (any any)) any . each-any))))) e))) (chi-lambda-clause (lambda (e425 c r426 w427 k428) ((lambda (tmp429) ((lambda (tmp430) (if tmp430 (apply (lambda (id431 e1432 e2433) (let ((ids434 id431)) (if (not (valid-bound-ids? ids434)) (syntax-error e425 (quote "invalid parameter list in")) (let ((labels436 (gen-labels ids434)) (new-vars (map gen-var ids434))) (k428 new-vars (chi-body (cons e1432 e2433) e425 (extend-var-env labels436 new-vars r426) (make-binding-wrap ids434 labels436 w427))))))) tmp430) ((lambda (tmp438) (if tmp438 (apply (lambda (ids439 e1440 e2441) (let ((old-ids (lambda-var-list ids439))) (if (not (valid-bound-ids? old-ids)) (syntax-error e425 (quote "invalid parameter list in")) (let ((labels442 (gen-labels old-ids)) (new-vars443 (map gen-var old-ids))) (k428 (let f444 ((ls1 (cdr new-vars443)) (ls2 (car new-vars443))) (if (null? ls1) ls2 (f444 (cdr ls1) (cons (car ls1) ls2)))) (chi-body (cons e1440 e2441) e425 (extend-var-env labels442 new-vars443 r426) (make-binding-wrap old-ids labels442 w427))))))) tmp438) ((lambda (_446) (syntax-error e425)) tmp429))) (syntax-dispatch tmp429 (quote (any any . each-any)))))) (syntax-dispatch tmp429 (quote (each-any any . each-any))))) c))) (chi-body (lambda (body outer-form r447 w448) (let ((r449 (cons (quote ("placeholder" placeholder)) r447))) (let ((ribcage (make-ribcage (quote ()) (quote ()) (quote ())))) (let ((w450 (make-wrap (wrap-marks w448) (cons ribcage (wrap-subst w448))))) (let parse ((body451 (map (lambda (x455) (cons r449 (wrap x455 w450))) body)) (ids452 (quote ())) (labels453 (quote ())) (vars454 (quote ())) (vals (quote ())) (bindings (quote ()))) (if (null? body451) (syntax-error outer-form (quote "no expressions in body")) (let ((e456 (cdar body451)) (er (caar body451))) (call-with-values (lambda () (syntax-type e456 er (quote (())) (quote #f) ribcage)) (lambda (type value e457 w458 s459) (let ((t type)) (if (memv t (quote (define-form))) (let ((id460 (wrap value w458)) (label (gen-label))) (let ((var (gen-var id460))) (begin (extend-ribcage! ribcage id460 label) (parse (cdr body451) (cons id460 ids452) (cons label labels453) (cons var vars454) (cons (cons er (wrap e457 w458)) vals) (cons (cons (quote lexical) var) bindings))))) (if (memv t (quote (define-syntax-form))) (let ((id461 (wrap value w458)) (label462 (gen-label))) (begin (extend-ribcage! ribcage id461 label462) (parse (cdr body451) (cons id461 ids452) (cons label462 labels453) vars454 vals (cons (cons (quote macro) (cons er (wrap e457 w458))) bindings)))) (if (memv t (quote (begin-form))) ((lambda (tmp463) ((lambda (tmp464) (if tmp464 (apply (lambda (_465 e1466) (parse (let f467 ((forms e1466)) (if (null? forms) (cdr body451) (cons (cons er (wrap (car forms) w458)) (f467 (cdr forms))))) ids452 labels453 vars454 vals bindings)) tmp464) (syntax-error tmp463))) (syntax-dispatch tmp463 (quote (any . each-any))))) e457) (if (memv t (quote (local-syntax-form))) (chi-local-syntax value e457 er w458 s459 (lambda (forms469 er470 w471 s472) (parse (let f473 ((forms474 forms469)) (if (null? forms474) (cdr body451) (cons (cons er470 (wrap (car forms474) w471)) (f473 (cdr forms474))))) ids452 labels453 vars454 vals bindings))) (if (null? ids452) (build-sequence (quote #f) (map (lambda (x475) (chi (cdr x475) (car x475) (quote (())))) (cons (cons er (source-wrap e457 w458 s459)) (cdr body451)))) (begin (if (not (valid-bound-ids? ids452)) (syntax-error outer-form (quote "invalid or duplicate identifier in definition"))) (let loop476 ((bs bindings) (er-cache (quote #f)) (r-cache (quote #f))) (if (not (null? bs)) (let ((b (car bs))) (if (eq? (car b) (quote macro)) (let ((er477 (cadr b))) (let ((r-cache478 (if (eq? er477 er-cache) r-cache (macros-only-env er477)))) (begin (set-cdr! b (eval-local-transformer (chi (cddr b) r-cache478 (quote (()))))) (loop476 (cdr bs) er477 r-cache478)))) (loop476 (cdr bs) er-cache r-cache))))) (set-cdr! r449 (extend-env labels453 bindings (cdr r449))) (build-letrec (quote #f) vars454 (map (lambda (x479) (chi (cdr x479) (car x479) (quote (())))) vals) (build-sequence (quote #f) (map (lambda (x480) (chi (cdr x480) (car x480) (quote (())))) (cons (cons er (source-wrap e457 w458 s459)) (cdr body451)))))))))))))))))))))) (chi-macro (lambda (p481 e482 r483 w484 rib) (letrec ((rebuild-macro-output (lambda (x485 m) (cond ((pair? x485) (cons (rebuild-macro-output (car x485) m) (rebuild-macro-output (cdr x485) m))) ((syntax-object? x485) (let ((w486 (syntax-object-wrap x485))) (let ((ms (wrap-marks w486)) (s487 (wrap-subst w486))) (make-syntax-object (syntax-object-expression x485) (if (and (pair? ms) (eq? (car ms) (quote #f))) (make-wrap (cdr ms) (if rib (cons rib (cdr s487)) (cdr s487))) (make-wrap (cons m ms) (if rib (cons rib (cons (quote shift) s487)) (cons (quote shift) s487)))))))) ((vector? x485) (let ((n (vector-length x485))) (let ((v (make-vector n))) (let doloop ((i488 (quote 0))) (if (fx= i488 n) v (begin (vector-set! v i488 (rebuild-macro-output (vector-ref x485 i488) m)) (doloop (fx+ i488 (quote 1))))))))) ((symbol? x485) (syntax-error x485 (quote "encountered raw symbol in macro output"))) (else x485))))) (rebuild-macro-output (p481 (wrap e482 (anti-mark w484))) (string (quote #\m)))))) (chi-application (lambda (x489 e490 r491 w492 s493) ((lambda (tmp494) ((lambda (tmp495) (if tmp495 (apply (lambda (e0 e1496) (cons x489 (map (lambda (e497) (chi e497 r491 w492)) e1496))) tmp495) (syntax-error tmp494))) (syntax-dispatch tmp494 (quote (any . each-any))))) e490))) (chi-expr (lambda (type499 value500 e501 r502 w503 s504) (let ((t505 type499)) (if (memv t505 (quote (lexical))) value500 (if (memv t505 (quote (core))) (value500 e501 r502 w503 s504) (if (memv t505 (quote (lexical-call))) (chi-application value500 e501 r502 w503 s504) (if (memv t505 (quote (global-call))) (chi-application value500 e501 r502 w503 s504) (if (memv t505 (quote (constant))) (list (quote quote) (strip (source-wrap e501 w503 s504) (quote (())))) (if (memv t505 (quote (global))) value500 (if (memv t505 (quote (call))) (chi-application (chi (car e501) r502 w503) e501 r502 w503 s504) (if (memv t505 (quote (begin-form))) ((lambda (tmp506) ((lambda (tmp507) (if tmp507 (apply (lambda (_508 e1509 e2510) (chi-sequence (cons e1509 e2510) r502 w503 s504)) tmp507) (syntax-error tmp506))) (syntax-dispatch tmp506 (quote (any any . each-any))))) e501) (if (memv t505 (quote (local-syntax-form))) (chi-local-syntax value500 e501 r502 w503 s504 chi-sequence) (if (memv t505 (quote (eval-when-form))) ((lambda (tmp512) ((lambda (tmp513) (if tmp513 (apply (lambda (_514 x515 e1516 e2517) (let ((when-list (chi-when-list e501 x515 w503))) (if (memq (quote eval) when-list) (chi-sequence (cons e1516 e2517) r502 w503 s504) (chi-void)))) tmp513) (syntax-error tmp512))) (syntax-dispatch tmp512 (quote (any each-any any . each-any))))) e501) (if (memv t505 (quote (define-form define-syntax-form))) (syntax-error (wrap value500 w503) (quote "invalid context for definition of")) (if (memv t505 (quote (syntax))) (syntax-error (source-wrap e501 w503 s504) (quote "reference to pattern variable outside syntax form")) (if (memv t505 (quote (displaced-lexical))) (syntax-error (source-wrap e501 w503 s504) (quote "reference to identifier outside its scope")) (syntax-error (source-wrap e501 w503 s504)))))))))))))))))) (chi (lambda (e520 r521 w522) (call-with-values (lambda () (syntax-type e520 r521 w522 (quote #f) (quote #f))) (lambda (type523 value524 e525 w526 s527) (chi-expr type523 value524 e525 r521 w526 s527))))) (chi-top (lambda (e528 r529 w530 m531 esew) (call-with-values (lambda () (syntax-type e528 r529 w530 (quote #f) (quote #f))) (lambda (type543 value544 e545 w546 s547) (let ((t548 type543)) (if (memv t548 (quote (begin-form))) ((lambda (tmp549) ((lambda (tmp550) (if tmp550 (apply (lambda (_551) (chi-void)) tmp550) ((lambda (tmp552) (if tmp552 (apply (lambda (_553 e1554 e2555) (chi-top-sequence (cons e1554 e2555) r529 w546 s547 m531 esew)) tmp552) (syntax-error tmp549))) (syntax-dispatch tmp549 (quote (any any . each-any)))))) (syntax-dispatch tmp549 (quote (any))))) e545) (if (memv t548 (quote (local-syntax-form))) (chi-local-syntax value544 e545 r529 w546 s547 (lambda (body557 r558 w559 s560) (chi-top-sequence body557 r558 w559 s560 m531 esew))) (if (memv t548 (quote (eval-when-form))) ((lambda (tmp561) ((lambda (tmp562) (if tmp562 (apply (lambda (_563 x564 e1565 e2566) (let ((when-list567 (chi-when-list e545 x564 w546)) (body568 (cons e1565 e2566))) (cond ((eq? m531 (quote e)) (if (memq (quote eval) when-list567) (chi-top-sequence body568 r529 w546 s547 (quote e) (quote (eval))) (chi-void))) ((memq (quote load) when-list567) (if (or (memq (quote compile) when-list567) (and (eq? m531 (quote c&e)) (memq (quote eval) when-list567))) (chi-top-sequence body568 r529 w546 s547 (quote c&e) (quote (compile load))) (if (memq m531 (quote (c c&e))) (chi-top-sequence body568 r529 w546 s547 (quote c) (quote (load))) (chi-void)))) ((or (memq (quote compile) when-list567) (and (eq? m531 (quote c&e)) (memq (quote eval) when-list567))) (top-level-eval-hook (chi-top-sequence body568 r529 w546 s547 (quote e) (quote (eval)))) (chi-void)) (else (chi-void))))) tmp562) (syntax-error tmp561))) (syntax-dispatch tmp561 (quote (any each-any any . each-any))))) e545) (if (memv t548 (quote (define-syntax-form))) (let ((n571 (id-var-name value544 w546)) (r572 (macros-only-env r529))) (let ((t573 m531)) (if (memv t573 (quote (c))) (if (memq (quote compile) esew) (let ((e574 (chi-install-global n571 (chi e545 r572 w546)))) (begin (top-level-eval-hook e574) (if (memq (quote load) esew) e574 (chi-void)))) (if (memq (quote load) esew) (chi-install-global n571 (chi e545 r572 w546)) (chi-void))) (if (memv t573 (quote (c&e))) (let ((e575 (chi-install-global n571 (chi e545 r572 w546)))) (begin (top-level-eval-hook e575) e575)) (begin (if (memq (quote eval) esew) (top-level-eval-hook (chi-install-global n571 (chi e545 r572 w546)))) (chi-void)))))) (if (memv t548 (quote (define-form))) (let ((n576 (id-var-name value544 w546))) (let ((t577 (binding-type (lookup n576 r529)))) (if (memv t577 (quote (global))) (let ((x578 (list (quote define) n576 (chi e545 r529 w546)))) (begin (if (eq? m531 (quote c&e)) (top-level-eval-hook x578)) x578)) (if (memv t577 (quote (displaced-lexical))) (syntax-error (wrap value544 w546) (quote "identifier out of context")) (syntax-error (wrap value544 w546) (quote "cannot define keyword at top level")))))) (let ((x579 (chi-expr type543 value544 e545 r529 w546 s547))) (begin (if (eq? m531 (quote c&e)) (top-level-eval-hook x579)) x579)))))))))))) (syntax-type (lambda (e580 r581 w582 s583 rib584) (cond ((symbol? e580) (let ((n585 (id-var-name e580 w582))) (let ((b586 (lookup n585 r581))) (let ((type587 (binding-type b586))) (let ((t588 type587)) (if (memv t588 (quote (lexical))) (values type587 (binding-value b586) e580 w582 s583) (if (memv t588 (quote (global))) (values type587 n585 e580 w582 s583) (if (memv t588 (quote (macro))) (syntax-type (chi-macro (binding-value b586) e580 r581 w582 rib584) r581 (quote (())) s583 rib584) (values type587 (binding-value b586) e580 w582 s583))))))))) ((pair? e580) (let ((first (car e580))) (if (id? first) (let ((n589 (id-var-name first w582))) (let ((b590 (lookup n589 r581))) (let ((type591 (binding-type b590))) (let ((t592 type591)) (if (memv t592 (quote (lexical))) (values (quote lexical-call) (binding-value b590) e580 w582 s583) (if (memv t592 (quote (global))) (values (quote global-call) n589 e580 w582 s583) (if (memv t592 (quote (macro))) (syntax-type (chi-macro (binding-value b590) e580 r581 w582 rib584) r581 (quote (())) s583 rib584) (if (memv t592 (quote (core))) (values type591 (binding-value b590) e580 w582 s583) (if (memv t592 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value b590) e580 w582 s583) (if (memv t592 (quote (begin))) (values (quote begin-form) (quote #f) e580 w582 s583) (if (memv t592 (quote (eval-when))) (values (quote eval-when-form) (quote #f) e580 w582 s583) (if (memv t592 (quote (define))) ((lambda (tmp593) ((lambda (tmp594) (if (if tmp594 (apply (lambda (_595 name596 val597) (id? name596)) tmp594) (quote #f)) (apply (lambda (_598 name599 val600) (values (quote define-form) name599 val600 w582 s583)) tmp594) ((lambda (tmp601) (if (if tmp601 (apply (lambda (_602 name603 args604 e1605 e2606) (and (id? name603) (valid-bound-ids? (lambda-var-list args604)))) tmp601) (quote #f)) (apply (lambda (_607 name608 args609 e1610 e2611) (values (quote define-form) (wrap name608 w582) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) (wrap (cons args609 (cons e1610 e2611)) w582)) (quote (())) s583)) tmp601) ((lambda (tmp613) (if (if tmp613 (apply (lambda (_614 name615) (id? name615)) tmp613) (quote #f)) (apply (lambda (_616 name617) (values (quote define-form) (wrap name617 w582) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote (())) s583)) tmp613) (syntax-error tmp593))) (syntax-dispatch tmp593 (quote (any any)))))) (syntax-dispatch tmp593 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp593 (quote (any any any))))) e580) (if (memv t592 (quote (define-syntax))) ((lambda (tmp618) ((lambda (tmp619) (if (if tmp619 (apply (lambda (_620 name621 val622) (id? name621)) tmp619) (quote #f)) (apply (lambda (_623 name624 val625) (values (quote define-syntax-form) name624 val625 w582 s583)) tmp619) (syntax-error tmp618))) (syntax-dispatch tmp618 (quote (any any any))))) e580) (values (quote call) (quote #f) e580 w582 s583)))))))))))))) (values (quote call) (quote #f) e580 w582 s583)))) ((syntax-object? e580) (syntax-type (syntax-object-expression e580) r581 (join-wraps w582 (syntax-object-wrap e580)) (quote #f) rib584)) ((annotation? e580) (syntax-type (annotation-expression e580) r581 w582 (annotation-source e580) rib584)) ((let ((x626 e580)) (or (boolean? x626) (number? x626) (string? x626) (char? x626) (null? x626) (keyword? x626))) (values (quote constant) (quote #f) e580 w582 s583)) (else (values (quote other) (quote #f) e580 w582 s583))))) (chi-when-list (lambda (e627 when-list628 w629) (let f630 ((when-list631 when-list628) (situations (quote ()))) (if (null? when-list631) situations (f630 (cdr when-list631) (cons (let ((x632 (car when-list631))) (cond ((free-id=? x632 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote compile)) ((free-id=? x632 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote load)) ((free-id=? x632 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote eval)) (else (syntax-error (wrap x632 w629) (quote "invalid eval-when situation"))))) situations)))))) (chi-install-global (lambda (name633 e634) (list (quote install-global-transformer) (list (quote quote) name633) e634))) (chi-top-sequence (lambda (body635 r636 w637 s638 m639 esew640) (build-sequence s638 (let dobody ((body641 body635) (r642 r636) (w643 w637) (m644 m639) (esew645 esew640)) (if (null? body641) (quote ()) (let ((first646 (chi-top (car body641) r642 w643 m644 esew645))) (cons first646 (dobody (cdr body641) r642 w643 m644 esew645)))))))) (chi-sequence (lambda (body647 r648 w649 s650) (build-sequence s650 (let dobody651 ((body652 body647) (r653 r648) (w654 w649)) (if (null? body652) (quote ()) (let ((first655 (chi (car body652) r653 w654))) (cons first655 (dobody651 (cdr body652) r653 w654)))))))) (source-wrap (lambda (x656 w657 s658) (wrap (if s658 (make-annotation x656 s658 (quote #f)) x656) w657))) (wrap (lambda (x659 w660) (cond ((and (null? (wrap-marks w660)) (null? (wrap-subst w660))) x659) ((syntax-object? x659) (make-syntax-object (syntax-object-expression x659) (join-wraps w660 (syntax-object-wrap x659)))) ((null? x659) x659) (else (make-syntax-object x659 w660))))) (bound-id-member? (lambda (x661 list) (and (not (null? list)) (or (bound-id=? x661 (car list)) (bound-id-member? x661 (cdr list)))))) (distinct-bound-ids? (lambda (ids662) (let distinct? ((ids663 ids662)) (or (null? ids663) (and (not (bound-id-member? (car ids663) (cdr ids663))) (distinct? (cdr ids663))))))) (valid-bound-ids? (lambda (ids664) (and (let all-ids? ((ids665 ids664)) (or (null? ids665) (and (id? (car ids665)) (all-ids? (cdr ids665))))) (distinct-bound-ids? ids664)))) (bound-id=? (lambda (i666 j) (if (and (syntax-object? i666) (syntax-object? j)) (and (eq? (let ((e667 (syntax-object-expression i666))) (if (annotation? e667) (annotation-expression e667) e667)) (let ((e668 (syntax-object-expression j))) (if (annotation? e668) (annotation-expression e668) e668))) (same-marks? (wrap-marks (syntax-object-wrap i666)) (wrap-marks (syntax-object-wrap j)))) (eq? (let ((e669 i666)) (if (annotation? e669) (annotation-expression e669) e669)) (let ((e670 j)) (if (annotation? e670) (annotation-expression e670) e670)))))) (free-id=? (lambda (i671 j672) (and (eq? (let ((x673 i671)) (let ((e674 (if (syntax-object? x673) (syntax-object-expression x673) x673))) (if (annotation? e674) (annotation-expression e674) e674))) (let ((x675 j672)) (let ((e676 (if (syntax-object? x675) (syntax-object-expression x675) x675))) (if (annotation? e676) (annotation-expression e676) e676)))) (eq? (id-var-name i671 (quote (()))) (id-var-name j672 (quote (()))))))) (id-var-name (lambda (id677 w678) (letrec ((search-vector-rib (lambda (sym subst marks symnames ribcage688) (let ((n689 (vector-length symnames))) (let f690 ((i691 (quote 0))) (cond ((fx= i691 n689) (search sym (cdr subst) marks)) ((and (eq? (vector-ref symnames i691) sym) (same-marks? marks (vector-ref (ribcage-marks ribcage688) i691))) (values (vector-ref (ribcage-labels ribcage688) i691) marks)) (else (f690 (fx+ i691 (quote 1))))))))) (search-list-rib (lambda (sym692 subst693 marks694 symnames695 ribcage696) (let f697 ((symnames698 symnames695) (i699 (quote 0))) (cond ((null? symnames698) (search sym692 (cdr subst693) marks694)) ((and (eq? (car symnames698) sym692) (same-marks? marks694 (list-ref (ribcage-marks ribcage696) i699))) (values (list-ref (ribcage-labels ribcage696) i699) marks694)) (else (f697 (cdr symnames698) (fx+ i699 (quote 1)))))))) (search (lambda (sym700 subst701 marks702) (if (null? subst701) (values (quote #f) marks702) (let ((fst (car subst701))) (if (eq? fst (quote shift)) (search sym700 (cdr subst701) (cdr marks702)) (let ((symnames703 (ribcage-symnames fst))) (if (vector? symnames703) (search-vector-rib sym700 subst701 marks702 symnames703 fst) (search-list-rib sym700 subst701 marks702 symnames703 fst))))))))) (cond ((symbol? id677) (or (call-with-values (lambda () (search id677 (wrap-subst w678) (wrap-marks w678))) (lambda (x704 . ignore) x704)) id677)) ((syntax-object? id677) (let ((id705 (let ((e706 (syntax-object-expression id677))) (if (annotation? e706) (annotation-expression e706) e706))) (w1 (syntax-object-wrap id677))) (let ((marks707 (join-marks (wrap-marks w678) (wrap-marks w1)))) (call-with-values (lambda () (search id705 (wrap-subst w678) marks707)) (lambda (new-id marks708) (or new-id (call-with-values (lambda () (search id705 (wrap-subst w1) marks708)) (lambda (x710 . ignore709) x710)) id705)))))) ((annotation? id677) (let ((id711 (let ((e712 id677)) (if (annotation? e712) (annotation-expression e712) e712)))) (or (call-with-values (lambda () (search id711 (wrap-subst w678) (wrap-marks w678))) (lambda (x714 . ignore713) x714)) id711))) (else (error-hook (quote id-var-name) (quote "invalid id") id677)))))) (same-marks? (lambda (x715 y) (or (eq? x715 y) (and (not (null? x715)) (not (null? y)) (eq? (car x715) (car y)) (same-marks? (cdr x715) (cdr y)))))) (join-marks (lambda (m1 m2) (smart-append m1 m2))) (join-wraps (lambda (w1716 w2) (let ((m1717 (wrap-marks w1716)) (s1 (wrap-subst w1716))) (if (null? m1717) (if (null? s1) w2 (make-wrap (wrap-marks w2) (smart-append s1 (wrap-subst w2)))) (make-wrap (smart-append m1717 (wrap-marks w2)) (smart-append s1 (wrap-subst w2))))))) (smart-append (lambda (m1718 m2719) (if (null? m2719) m1718 (append m1718 m2719)))) (make-binding-wrap (lambda (ids720 labels721 w722) (if (null? ids720) w722 (make-wrap (wrap-marks w722) (cons (let ((labelvec (list->vector labels721))) (let ((n723 (vector-length labelvec))) (let ((symnamevec (make-vector n723)) (marksvec (make-vector n723))) (begin (let f724 ((ids725 ids720) (i726 (quote 0))) (if (not (null? ids725)) (call-with-values (lambda () (id-sym-name&marks (car ids725) w722)) (lambda (symname marks727) (begin (vector-set! symnamevec i726 symname) (vector-set! marksvec i726 marks727) (f724 (cdr ids725) (fx+ i726 (quote 1)))))))) (make-ribcage symnamevec marksvec labelvec))))) (wrap-subst w722)))))) (extend-ribcage! (lambda (ribcage728 id729 label730) (begin (set-ribcage-symnames! ribcage728 (cons (let ((e731 (syntax-object-expression id729))) (if (annotation? e731) (annotation-expression e731) e731)) (ribcage-symnames ribcage728))) (set-ribcage-marks! ribcage728 (cons (wrap-marks (syntax-object-wrap id729)) (ribcage-marks ribcage728))) (set-ribcage-labels! ribcage728 (cons label730 (ribcage-labels ribcage728)))))) (anti-mark (lambda (w732) (make-wrap (cons (quote #f) (wrap-marks w732)) (cons (quote shift) (wrap-subst w732))))) (set-ribcage-labels! (lambda (x733 update) (vector-set! x733 (quote 3) update))) (set-ribcage-marks! (lambda (x734 update735) (vector-set! x734 (quote 2) update735))) (set-ribcage-symnames! (lambda (x736 update737) (vector-set! x736 (quote 1) update737))) (ribcage-labels (lambda (x738) (vector-ref x738 (quote 3)))) (ribcage-marks (lambda (x739) (vector-ref x739 (quote 2)))) (ribcage-symnames (lambda (x740) (vector-ref x740 (quote 1)))) (ribcage? (lambda (x741) (and (vector? x741) (= (vector-length x741) (quote 4)) (eq? (vector-ref x741 (quote 0)) (quote ribcage))))) (make-ribcage (lambda (symnames742 marks743 labels744) (vector (quote ribcage) symnames742 marks743 labels744))) (gen-labels (lambda (ls745) (if (null? ls745) (quote ()) (cons (gen-label) (gen-labels (cdr ls745)))))) (gen-label (lambda () (string (quote #\i)))) (wrap-subst cdr) (wrap-marks car) (make-wrap cons) (id-sym-name&marks (lambda (x746 w747) (if (syntax-object? x746) (values (let ((e748 (syntax-object-expression x746))) (if (annotation? e748) (annotation-expression e748) e748)) (join-marks (wrap-marks w747) (wrap-marks (syntax-object-wrap x746)))) (values (let ((e749 x746)) (if (annotation? e749) (annotation-expression e749) e749)) (wrap-marks w747))))) (id? (lambda (x750) (cond ((symbol? x750) (quote #t)) ((syntax-object? x750) (symbol? (let ((e751 (syntax-object-expression x750))) (if (annotation? e751) (annotation-expression e751) e751)))) ((annotation? x750) (symbol? (annotation-expression x750))) (else (quote #f))))) (nonsymbol-id? (lambda (x752) (and (syntax-object? x752) (symbol? (let ((e753 (syntax-object-expression x752))) (if (annotation? e753) (annotation-expression e753) e753)))))) (global-extend (lambda (type754 sym755 val756) (put-global-definition-hook sym755 (cons type754 val756)))) (lookup (lambda (x757 r758) (cond ((assq x757 r758) => cdr) ((symbol? x757) (or (get-global-definition-hook x757) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env (lambda (r759) (if (null? r759) (quote ()) (let ((a760 (car r759))) (if (eq? (cadr a760) (quote macro)) (cons a760 (macros-only-env (cdr r759))) (macros-only-env (cdr r759))))))) (extend-var-env (lambda (labels761 vars762 r763) (if (null? labels761) r763 (extend-var-env (cdr labels761) (cdr vars762) (cons (cons (car labels761) (cons (quote lexical) (car vars762))) r763))))) (extend-env (lambda (labels764 bindings765 r766) (if (null? labels764) r766 (extend-env (cdr labels764) (cdr bindings765) (cons (cons (car labels764) (car bindings765)) r766))))) (binding-value cdr) (binding-type car) (source-annotation (lambda (x767) (cond ((annotation? x767) (annotation-source x767)) ((syntax-object? x767) (source-annotation (syntax-object-expression x767))) (else (quote #f))))) (set-syntax-object-wrap! (lambda (x768 update769) (vector-set! x768 (quote 2) update769))) (set-syntax-object-expression! (lambda (x770 update771) (vector-set! x770 (quote 1) update771))) (syntax-object-wrap (lambda (x772) (vector-ref x772 (quote 2)))) (syntax-object-expression (lambda (x773) (vector-ref x773 (quote 1)))) (syntax-object? (lambda (x774) (and (vector? x774) (= (vector-length x774) (quote 3)) (eq? (vector-ref x774 (quote 0)) (quote syntax-object))))) (make-syntax-object (lambda (expression wrap775) (vector (quote syntax-object) expression wrap775))) (build-letrec (lambda (src vars776 val-exps body-exp) (if (null? vars776) body-exp (list (quote letrec) (map list vars776 val-exps) body-exp)))) (build-named-let (lambda (src777 vars778 val-exps779 body-exp780) (if (null? vars778) body-exp780 (list (quote let) (car vars778) (map list (cdr vars778) val-exps779) body-exp780)))) (build-let (lambda (src781 vars782 val-exps783 body-exp784) (if (null? vars782) body-exp784 (list (quote let) (map list vars782 val-exps783) body-exp784)))) (build-sequence (lambda (src785 exps) (if (null? (cdr exps)) (car exps) (cons (quote begin) exps)))) (get-global-definition-hook (lambda (symbol) (getprop symbol (quote *sc-expander*)))) (put-global-definition-hook (lambda (symbol786 binding) (putprop symbol786 (quote *sc-expander*) binding))) (error-hook (lambda (who why what) (error who (quote "~a ~s") why what))) (local-eval-hook (lambda (x787) (eval (list noexpand x787) (interaction-environment)))) (top-level-eval-hook (lambda (x788) (eval (list noexpand x788) (interaction-environment)))) (annotation? (lambda (x789) (quote #f))) (fx< <) (fx= =) (fx- -) (fx+ +) (noexpand (quote "noexpand"))) (begin (global-extend (quote local-syntax) (quote letrec-syntax) (quote #t)) (global-extend (quote local-syntax) (quote let-syntax) (quote #f)) (global-extend (quote core) (quote fluid-let-syntax) (lambda (e790 r791 w792 s793) ((lambda (tmp794) ((lambda (tmp795) (if (if tmp795 (apply (lambda (_796 var797 val798 e1799 e2800) (valid-bound-ids? var797)) tmp795) (quote #f)) (apply (lambda (_802 var803 val804 e1805 e2806) (let ((names (map (lambda (x807) (id-var-name x807 w792)) var803))) (begin (for-each (lambda (id809 n810) (let ((t811 (binding-type (lookup n810 r791)))) (if (memv t811 (quote (displaced-lexical))) (syntax-error (source-wrap id809 w792 s793) (quote "identifier out of context"))))) var803 names) (chi-body (cons e1805 e2806) (source-wrap e790 w792 s793) (extend-env names (let ((trans-r814 (macros-only-env r791))) (map (lambda (x815) (cons (quote macro) (eval-local-transformer (chi x815 trans-r814 w792)))) val804)) r791) w792)))) tmp795) ((lambda (_817) (syntax-error (source-wrap e790 w792 s793))) tmp794))) (syntax-dispatch tmp794 (quote (any #(each (any any)) any . each-any))))) e790))) (global-extend (quote core) (quote quote) (lambda (e818 r819 w820 s821) ((lambda (tmp822) ((lambda (tmp823) (if tmp823 (apply (lambda (_824 e825) (list (quote quote) (strip e825 w820))) tmp823) ((lambda (_826) (syntax-error (source-wrap e818 w820 s821))) tmp822))) (syntax-dispatch tmp822 (quote (any any))))) e818))) (global-extend (quote core) (quote syntax) (letrec ((regen (lambda (x827) (let ((t828 (car x827))) (if (memv t828 (quote (ref))) (cadr x827) (if (memv t828 (quote (primitive))) (cadr x827) (if (memv t828 (quote (quote))) (list (quote quote) (cadr x827)) (if (memv t828 (quote (lambda))) (list (quote lambda) (cadr x827) (regen (caddr x827))) (if (memv t828 (quote (map))) (let ((ls829 (map regen (cdr x827)))) (cons (if (fx= (length ls829) (quote 2)) (quote map) (quote map)) ls829)) (cons (car x827) (map regen (cdr x827))))))))))) (gen-vector (lambda (x830) (cond ((eq? (car x830) (quote list)) (cons (quote vector) (cdr x830))) ((eq? (car x830) (quote quote)) (list (quote quote) (list->vector (cadr x830)))) (else (list (quote list->vector) x830))))) (gen-append (lambda (x831 y832) (if (equal? y832 (quote (quote ()))) x831 (list (quote append) x831 y832)))) (gen-cons (lambda (x833 y834) (let ((t835 (car y834))) (if (memv t835 (quote (quote))) (if (eq? (car x833) (quote quote)) (list (quote quote) (cons (cadr x833) (cadr y834))) (if (eq? (cadr y834) (quote ())) (list (quote list) x833) (list (quote cons) x833 y834))) (if (memv t835 (quote (list))) (cons (quote list) (cons x833 (cdr y834))) (list (quote cons) x833 y834)))))) (gen-map (lambda (e836 map-env) (let ((formals (map cdr map-env)) (actuals (map (lambda (x837) (list (quote ref) (car x837))) map-env))) (cond ((eq? (car e836) (quote ref)) (car actuals)) ((andmap (lambda (x838) (and (eq? (car x838) (quote ref)) (memq (cadr x838) formals))) (cdr e836)) (cons (quote map) (cons (list (quote primitive) (car e836)) (map (let ((r839 (map cons formals actuals))) (lambda (x840) (cdr (assq (cadr x840) r839)))) (cdr e836))))) (else (cons (quote map) (cons (list (quote lambda) formals e836) actuals))))))) (gen-mappend (lambda (e841 map-env842) (list (quote apply) (quote (primitive append)) (gen-map e841 map-env842)))) (gen-ref (lambda (src843 var844 level maps) (if (fx= level (quote 0)) (values var844 maps) (if (null? maps) (syntax-error src843 (quote "missing ellipsis in syntax form")) (call-with-values (lambda () (gen-ref src843 var844 (fx- level (quote 1)) (cdr maps))) (lambda (outer-var outer-maps) (let ((b845 (assq outer-var (car maps)))) (if b845 (values (cdr b845) maps) (let ((inner-var (gen-var (quote tmp)))) (values inner-var (cons (cons (cons outer-var inner-var) (car maps)) outer-maps))))))))))) (gen-syntax (lambda (src846 e847 r848 maps849 ellipsis?850) (if (id? e847) (let ((label851 (id-var-name e847 (quote (()))))) (let ((b852 (lookup label851 r848))) (if (eq? (binding-type b852) (quote syntax)) (call-with-values (lambda () (let ((var.lev (binding-value b852))) (gen-ref src846 (car var.lev) (cdr var.lev) maps849))) (lambda (var853 maps854) (values (list (quote ref) var853) maps854))) (if (ellipsis?850 e847) (syntax-error src846 (quote "misplaced ellipsis in syntax form")) (values (list (quote quote) e847) maps849))))) ((lambda (tmp855) ((lambda (tmp856) (if (if tmp856 (apply (lambda (dots e857) (ellipsis?850 dots)) tmp856) (quote #f)) (apply (lambda (dots858 e859) (gen-syntax src846 e859 r848 maps849 (lambda (x860) (quote #f)))) tmp856) ((lambda (tmp861) (if (if tmp861 (apply (lambda (x862 dots863 y864) (ellipsis?850 dots863)) tmp861) (quote #f)) (apply (lambda (x865 dots866 y867) (let f868 ((y869 y867) (k870 (lambda (maps871) (call-with-values (lambda () (gen-syntax src846 x865 r848 (cons (quote ()) maps871) ellipsis?850)) (lambda (x872 maps873) (if (null? (car maps873)) (syntax-error src846 (quote "extra ellipsis in syntax form")) (values (gen-map x872 (car maps873)) (cdr maps873)))))))) ((lambda (tmp874) ((lambda (tmp875) (if (if tmp875 (apply (lambda (dots876 y877) (ellipsis?850 dots876)) tmp875) (quote #f)) (apply (lambda (dots878 y879) (f868 y879 (lambda (maps880) (call-with-values (lambda () (k870 (cons (quote ()) maps880))) (lambda (x881 maps882) (if (null? (car maps882)) (syntax-error src846 (quote "extra ellipsis in syntax form")) (values (gen-mappend x881 (car maps882)) (cdr maps882)))))))) tmp875) ((lambda (_883) (call-with-values (lambda () (gen-syntax src846 y869 r848 maps849 ellipsis?850)) (lambda (y884 maps885) (call-with-values (lambda () (k870 maps885)) (lambda (x886 maps887) (values (gen-append x886 y884) maps887)))))) tmp874))) (syntax-dispatch tmp874 (quote (any . any))))) y869))) tmp861) ((lambda (tmp888) (if tmp888 (apply (lambda (x889 y890) (call-with-values (lambda () (gen-syntax src846 x889 r848 maps849 ellipsis?850)) (lambda (x891 maps892) (call-with-values (lambda () (gen-syntax src846 y890 r848 maps892 ellipsis?850)) (lambda (y893 maps894) (values (gen-cons x891 y893) maps894)))))) tmp888) ((lambda (tmp895) (if tmp895 (apply (lambda (e1896 e2897) (call-with-values (lambda () (gen-syntax src846 (cons e1896 e2897) r848 maps849 ellipsis?850)) (lambda (e899 maps900) (values (gen-vector e899) maps900)))) tmp895) ((lambda (_901) (values (list (quote quote) e847) maps849)) tmp855))) (syntax-dispatch tmp855 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp855 (quote (any . any)))))) (syntax-dispatch tmp855 (quote (any any . any)))))) (syntax-dispatch tmp855 (quote (any any))))) e847))))) (lambda (e902 r903 w904 s905) (let ((e906 (source-wrap e902 w904 s905))) ((lambda (tmp907) ((lambda (tmp908) (if tmp908 (apply (lambda (_909 x910) (call-with-values (lambda () (gen-syntax e906 x910 r903 (quote ()) ellipsis?)) (lambda (e911 maps912) (regen e911)))) tmp908) ((lambda (_913) (syntax-error e906)) tmp907))) (syntax-dispatch tmp907 (quote (any any))))) e906))))) (global-extend (quote core) (quote lambda) (lambda (e914 r915 w916 s917) ((lambda (tmp918) ((lambda (tmp919) (if tmp919 (apply (lambda (_920 c921) (chi-lambda-clause (source-wrap e914 w916 s917) c921 r915 w916 (lambda (vars922 body923) (list (quote lambda) vars922 body923)))) tmp919) (syntax-error tmp918))) (syntax-dispatch tmp918 (quote (any . any))))) e914))) (global-extend (quote core) (quote let) (letrec ((chi-let (lambda (e924 r925 w926 s927 constructor928 ids929 vals930 exps931) (if (not (valid-bound-ids? ids929)) (syntax-error e924 (quote "duplicate bound variable in")) (let ((labels932 (gen-labels ids929)) (new-vars933 (map gen-var ids929))) (let ((nw (make-binding-wrap ids929 labels932 w926)) (nr (extend-var-env labels932 new-vars933 r925))) (constructor928 s927 new-vars933 (map (lambda (x934) (chi x934 r925 w926)) vals930) (chi-body exps931 (source-wrap e924 nw s927) nr nw)))))))) (lambda (e935 r936 w937 s938) ((lambda (tmp939) ((lambda (tmp940) (if tmp940 (apply (lambda (_941 id942 val943 e1944 e2945) (chi-let e935 r936 w937 s938 build-let id942 val943 (cons e1944 e2945))) tmp940) ((lambda (tmp949) (if (if tmp949 (apply (lambda (_950 f951 id952 val953 e1954 e2955) (id? f951)) tmp949) (quote #f)) (apply (lambda (_956 f957 id958 val959 e1960 e2961) (chi-let e935 r936 w937 s938 build-named-let (cons f957 id958) val959 (cons e1960 e2961))) tmp949) ((lambda (_965) (syntax-error (source-wrap e935 w937 s938))) tmp939))) (syntax-dispatch tmp939 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp939 (quote (any #(each (any any)) any . each-any))))) e935)))) (global-extend (quote core) (quote letrec) (lambda (e966 r967 w968 s969) ((lambda (tmp970) ((lambda (tmp971) (if tmp971 (apply (lambda (_972 id973 val974 e1975 e2976) (let ((ids977 id973)) (if (not (valid-bound-ids? ids977)) (syntax-error e966 (quote "duplicate bound variable in")) (let ((labels979 (gen-labels ids977)) (new-vars980 (map gen-var ids977))) (let ((w981 (make-binding-wrap ids977 labels979 w968)) (r982 (extend-var-env labels979 new-vars980 r967))) (build-letrec s969 new-vars980 (map (lambda (x983) (chi x983 r982 w981)) val974) (chi-body (cons e1975 e2976) (source-wrap e966 w981 s969) r982 w981))))))) tmp971) ((lambda (_986) (syntax-error (source-wrap e966 w968 s969))) tmp970))) (syntax-dispatch tmp970 (quote (any #(each (any any)) any . each-any))))) e966))) (global-extend (quote core) (quote set!) (lambda (e987 r988 w989 s990) ((lambda (tmp991) ((lambda (tmp992) (if (if tmp992 (apply (lambda (_993 id994 val995) (id? id994)) tmp992) (quote #f)) (apply (lambda (_996 id997 val998) (let ((val999 (chi val998 r988 w989)) (n1000 (id-var-name id997 w989))) (let ((b1001 (lookup n1000 r988))) (let ((t1002 (binding-type b1001))) (if (memv t1002 (quote (lexical))) (list (quote set!) (binding-value b1001) val999) (if (memv t1002 (quote (global))) (list (quote set!) n1000 val999) (if (memv t1002 (quote (displaced-lexical))) (syntax-error (wrap id997 w989) (quote "identifier out of context")) (syntax-error (source-wrap e987 w989 s990))))))))) tmp992) ((lambda (_1003) (syntax-error (source-wrap e987 w989 s990))) tmp991))) (syntax-dispatch tmp991 (quote (any any any))))) e987))) (global-extend (quote begin) (quote begin) (quote ())) (global-extend (quote define) (quote define) (quote ())) (global-extend (quote define-syntax) (quote define-syntax) (quote ())) (global-extend (quote eval-when) (quote eval-when) (quote ())) (global-extend (quote core) (quote syntax-case) (letrec ((gen-syntax-case (lambda (x1004 keys clauses r1005) (if (null? clauses) (list (quote syntax-error) x1004) ((lambda (tmp1006) ((lambda (tmp1007) (if tmp1007 (apply (lambda (pat exp) (if (and (id? pat) (andmap (lambda (x1008) (not (free-id=? pat x1008))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) keys))) (let ((labels1009 (list (gen-label))) (var1010 (gen-var pat))) (list (list (quote lambda) (list var1010) (chi exp (extend-env labels1009 (list (cons (quote syntax) (cons var1010 (quote 0)))) r1005) (make-binding-wrap (list pat) labels1009 (quote (()))))) x1004)) (gen-clause x1004 keys (cdr clauses) r1005 pat (quote #t) exp))) tmp1007) ((lambda (tmp1011) (if tmp1011 (apply (lambda (pat1012 fender exp1013) (gen-clause x1004 keys (cdr clauses) r1005 pat1012 fender exp1013)) tmp1011) ((lambda (_1014) (syntax-error (car clauses) (quote "invalid syntax-case clause"))) tmp1006))) (syntax-dispatch tmp1006 (quote (any any any)))))) (syntax-dispatch tmp1006 (quote (any any))))) (car clauses))))) (gen-clause (lambda (x1015 keys1016 clauses1017 r1018 pat1019 fender1020 exp1021) (call-with-values (lambda () (convert-pattern pat1019 keys1016)) (lambda (p1022 pvars) (cond ((not (distinct-bound-ids? (map car pvars))) (syntax-error pat1019 (quote "duplicate pattern variable in syntax-case pattern"))) ((not (andmap (lambda (x1023) (not (ellipsis? (car x1023)))) pvars)) (syntax-error pat1019 (quote "misplaced ellipsis in syntax-case pattern"))) (else (let ((y1024 (gen-var (quote tmp)))) (list (list (quote lambda) (list y1024) (let ((y1025 y1024)) (list (quote if) ((lambda (tmp1026) ((lambda (tmp1027) (if tmp1027 (apply (lambda () y1025) tmp1027) ((lambda (_1028) (list (quote if) y1025 (build-dispatch-call pvars fender1020 y1025 r1018) (list (quote quote) (quote #f)))) tmp1026))) (syntax-dispatch tmp1026 (quote #(atom #t))))) fender1020) (build-dispatch-call pvars exp1021 y1025 r1018) (gen-syntax-case x1015 keys1016 clauses1017 r1018)))) (if (eq? p1022 (quote any)) (list (quote list) x1015) (list (quote syntax-dispatch) x1015 (list (quote quote) p1022))))))))))) (build-dispatch-call (lambda (pvars1029 exp1030 y1031 r1032) (let ((ids1033 (map car pvars1029)) (levels (map cdr pvars1029))) (let ((labels1034 (gen-labels ids1033)) (new-vars1035 (map gen-var ids1033))) (list (quote apply) (list (quote lambda) new-vars1035 (chi exp1030 (extend-env labels1034 (map (lambda (var1036 level1037) (cons (quote syntax) (cons var1036 level1037))) new-vars1035 (map cdr pvars1029)) r1032) (make-binding-wrap ids1033 labels1034 (quote (()))))) y1031))))) (convert-pattern (lambda (pattern keys1038) (let cvt ((p1039 pattern) (n1040 (quote 0)) (ids1041 (quote ()))) (if (id? p1039) (if (bound-id-member? p1039 keys1038) (values (vector (quote free-id) p1039) ids1041) (values (quote any) (cons (cons p1039 n1040) ids1041))) ((lambda (tmp1042) ((lambda (tmp1043) (if (if tmp1043 (apply (lambda (x1044 dots1045) (ellipsis? dots1045)) tmp1043) (quote #f)) (apply (lambda (x1046 dots1047) (call-with-values (lambda () (cvt x1046 (fx+ n1040 (quote 1)) ids1041)) (lambda (p1048 ids1049) (values (if (eq? p1048 (quote any)) (quote each-any) (vector (quote each) p1048)) ids1049)))) tmp1043) ((lambda (tmp1050) (if tmp1050 (apply (lambda (x1051 y1052) (call-with-values (lambda () (cvt y1052 n1040 ids1041)) (lambda (y1053 ids1054) (call-with-values (lambda () (cvt x1051 n1040 ids1054)) (lambda (x1055 ids1056) (values (cons x1055 y1053) ids1056)))))) tmp1050) ((lambda (tmp1057) (if tmp1057 (apply (lambda () (values (quote ()) ids1041)) tmp1057) ((lambda (tmp1058) (if tmp1058 (apply (lambda (x1059) (call-with-values (lambda () (cvt x1059 n1040 ids1041)) (lambda (p1061 ids1062) (values (vector (quote vector) p1061) ids1062)))) tmp1058) ((lambda (x1063) (values (vector (quote atom) (strip p1039 (quote (())))) ids1041)) tmp1042))) (syntax-dispatch tmp1042 (quote #(vector each-any)))))) (syntax-dispatch tmp1042 (quote ()))))) (syntax-dispatch tmp1042 (quote (any . any)))))) (syntax-dispatch tmp1042 (quote (any any))))) p1039)))))) (lambda (e1064 r1065 w1066 s1067) (let ((e1068 (source-wrap e1064 w1066 s1067))) ((lambda (tmp1069) ((lambda (tmp1070) (if tmp1070 (apply (lambda (_1071 val1072 key m1073) (if (andmap (lambda (x1074) (and (id? x1074) (not (ellipsis? x1074)))) key) (let ((x1076 (gen-var (quote tmp)))) (list (list (quote lambda) (list x1076) (gen-syntax-case x1076 key m1073 r1065)) (chi val1072 r1065 (quote (()))))) (syntax-error e1068 (quote "invalid literals list in")))) tmp1070) (syntax-error tmp1069))) (syntax-dispatch tmp1069 (quote (any any each-any . each-any))))) e1068))))) (set! sc-expand (let ((m1079 (quote e)) (esew1080 (quote (eval)))) (lambda (x1081) (if (and (pair? x1081) (equal? (car x1081) noexpand)) (cadr x1081) (chi-top x1081 (quote ()) (quote ((top))) m1079 esew1080))))) (set! sc-expand3 (let ((m1082 (quote e)) (esew1083 (quote (eval)))) (lambda (x1084 . rest) (if (and (pair? x1084) (equal? (car x1084) noexpand)) (cadr x1084) (chi-top x1084 (quote ()) (quote ((top))) (if (null? rest) m1082 (car rest)) (if (or (null? rest) (null? (cdr rest))) esew1083 (cadr rest))))))) (set! identifier? (lambda (x1085) (nonsymbol-id? x1085))) (set! datum->syntax-object (lambda (id1086 datum) (begin (let ((x1087 id1086)) (if (not (nonsymbol-id? x1087)) (error-hook (quote datum->syntax-object) (quote "invalid argument") x1087))) (make-syntax-object datum (syntax-object-wrap id1086))))) (set! syntax-object->datum (lambda (x1088) (strip x1088 (quote (()))))) (set! generate-temporaries (lambda (ls1089) (begin (let ((x1090 ls1089)) (if (not (list? x1090)) (error-hook (quote generate-temporaries) (quote "invalid argument") x1090))) (map (lambda (x1091) (wrap (gensym) (quote ((top))))) ls1089)))) (set! free-identifier=? (lambda (x1092 y1093) (begin (let ((x1094 x1092)) (if (not (nonsymbol-id? x1094)) (error-hook (quote free-identifier=?) (quote "invalid argument") x1094))) (let ((x1095 y1093)) (if (not (nonsymbol-id? x1095)) (error-hook (quote free-identifier=?) (quote "invalid argument") x1095))) (free-id=? x1092 y1093)))) (set! bound-identifier=? (lambda (x1096 y1097) (begin (let ((x1098 x1096)) (if (not (nonsymbol-id? x1098)) (error-hook (quote bound-identifier=?) (quote "invalid argument") x1098))) (let ((x1099 y1097)) (if (not (nonsymbol-id? x1099)) (error-hook (quote bound-identifier=?) (quote "invalid argument") x1099))) (bound-id=? x1096 y1097)))) (set! syntax-error (lambda (object . messages) (begin (for-each (lambda (x1100) (let ((x1101 x1100)) (if (not (string? x1101)) (error-hook (quote syntax-error) (quote "invalid argument") x1101)))) messages) (let ((message (if (null? messages) (quote "invalid syntax") (apply string-append messages)))) (error-hook (quote #f) message (strip object (quote (())))))))) (set! install-global-transformer (lambda (sym1102 v1103) (begin (let ((x1104 sym1102)) (if (not (symbol? x1104)) (error-hook (quote define-syntax) (quote "invalid argument") x1104))) (let ((x1105 v1103)) (if (not (procedure? x1105)) (error-hook (quote define-syntax) (quote "invalid argument") x1105))) (global-extend (quote macro) sym1102 v1103)))) (letrec ((match (lambda (e1106 p1107 w1108 r1109) (cond ((not r1109) (quote #f)) ((eq? p1107 (quote any)) (cons (wrap e1106 w1108) r1109)) ((syntax-object? e1106) (match* (let ((e1110 (syntax-object-expression e1106))) (if (annotation? e1110) (annotation-expression e1110) e1110)) p1107 (join-wraps w1108 (syntax-object-wrap e1106)) r1109)) (else (match* (let ((e1111 e1106)) (if (annotation? e1111) (annotation-expression e1111) e1111)) p1107 w1108 r1109))))) (match* (lambda (e1112 p1113 w1114 r1115) (cond ((null? p1113) (and (null? e1112) r1115)) ((pair? p1113) (and (pair? e1112) (match (car e1112) (car p1113) w1114 (match (cdr e1112) (cdr p1113) w1114 r1115)))) ((eq? p1113 (quote each-any)) (let ((l (match-each-any e1112 w1114))) (and l (cons l r1115)))) (else (let ((t1116 (vector-ref p1113 (quote 0)))) (if (memv t1116 (quote (each))) (if (null? e1112) (match-empty (vector-ref p1113 (quote 1)) r1115) (let ((l1117 (match-each e1112 (vector-ref p1113 (quote 1)) w1114))) (and l1117 (let collect ((l1118 l1117)) (if (null? (car l1118)) r1115 (cons (map car l1118) (collect (map cdr l1118)))))))) (if (memv t1116 (quote (free-id))) (and (id? e1112) (free-id=? (wrap e1112 w1114) (vector-ref p1113 (quote 1))) r1115) (if (memv t1116 (quote (atom))) (and (equal? (vector-ref p1113 (quote 1)) (strip e1112 w1114)) r1115) (if (memv t1116 (quote (vector))) (and (vector? e1112) (match (vector->list e1112) (vector-ref p1113 (quote 1)) w1114 r1115))))))))))) (match-empty (lambda (p1119 r1120) (cond ((null? p1119) r1120) ((eq? p1119 (quote any)) (cons (quote ()) r1120)) ((pair? p1119) (match-empty (car p1119) (match-empty (cdr p1119) r1120))) ((eq? p1119 (quote each-any)) (cons (quote ()) r1120)) (else (let ((t1121 (vector-ref p1119 (quote 0)))) (if (memv t1121 (quote (each))) (match-empty (vector-ref p1119 (quote 1)) r1120) (if (memv t1121 (quote (free-id atom))) r1120 (if (memv t1121 (quote (vector))) (match-empty (vector-ref p1119 (quote 1)) r1120))))))))) (match-each-any (lambda (e1122 w1123) (cond ((annotation? e1122) (match-each-any (annotation-expression e1122) w1123)) ((pair? e1122) (let ((l1124 (match-each-any (cdr e1122) w1123))) (and l1124 (cons (wrap (car e1122) w1123) l1124)))) ((null? e1122) (quote ())) ((syntax-object? e1122) (match-each-any (syntax-object-expression e1122) (join-wraps w1123 (syntax-object-wrap e1122)))) (else (quote #f))))) (match-each (lambda (e1125 p1126 w1127) (cond ((annotation? e1125) (match-each (annotation-expression e1125) p1126 w1127)) ((pair? e1125) (let ((first1128 (match (car e1125) p1126 w1127 (quote ())))) (and first1128 (let ((rest1129 (match-each (cdr e1125) p1126 w1127))) (and rest1129 (cons first1128 rest1129)))))) ((null? e1125) (quote ())) ((syntax-object? e1125) (match-each (syntax-object-expression e1125) p1126 (join-wraps w1127 (syntax-object-wrap e1125)))) (else (quote #f)))))) (set! syntax-dispatch (lambda (e1130 p1131) (cond ((eq? p1131 (quote any)) (list e1130)) ((syntax-object? e1130) (match* (let ((e1132 (syntax-object-expression e1130))) (if (annotation? e1132) (annotation-expression e1132) e1132)) p1131 (syntax-object-wrap e1130) (quote ()))) (else (match* (let ((e1133 e1130)) (if (annotation? e1133) (annotation-expression e1133) e1133)) p1131 (quote (())) (quote ()))))))))) +(install-global-transformer (quote with-syntax) (lambda (x1134) ((lambda (tmp1135) ((lambda (tmp1136) (if tmp1136 (apply (lambda (_1137 e11138 e21139) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11138 e21139))) tmp1136) ((lambda (tmp1141) (if tmp1141 (apply (lambda (_1142 out in e11143 e21144) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) in (quote ()) (list out (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11143 e21144))))) tmp1141) ((lambda (tmp1146) (if tmp1146 (apply (lambda (_1147 out1148 in1149 e11150 e21151) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) in1149) (quote ()) (list out1148 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11150 e21151))))) tmp1146) (syntax-error tmp1135))) (syntax-dispatch tmp1135 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp1135 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp1135 (quote (any () any . each-any))))) x1134))) +(install-global-transformer (quote syntax-rules) (lambda (x1173) ((lambda (tmp1174) ((lambda (tmp1175) (if tmp1175 (apply (lambda (_1176 k1177 keyword pattern1178 template) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons k1177 (map (lambda (tmp1180 tmp1179) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) tmp1179) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) tmp1180))) template pattern1178)))))) tmp1175) (syntax-error tmp1174))) (syntax-dispatch tmp1174 (quote (any each-any . #(each ((any . any) any))))))) x1173))) +(install-global-transformer (quote let*) (lambda (x) ((lambda (tmp1191) ((lambda (tmp1192) (if (if tmp1192 (apply (lambda (let* x1193 v e1 e2) (andmap identifier? x1193)) tmp1192) (quote #f)) (apply (lambda (let*1195 x1196 v1197 e11198 e21199) (let f ((bindings (map list x1196 v1197))) (if (null? bindings) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote ()) (cons e11198 e21199))) ((lambda (tmp1203) ((lambda (tmp1204) (if tmp1204 (apply (lambda (body binding) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list binding) body)) tmp1204) (syntax-error tmp1203))) (syntax-dispatch tmp1203 (quote (any any))))) (list (f (cdr bindings)) (car bindings)))))) tmp1192) (syntax-error tmp1191))) (syntax-dispatch tmp1191 (quote (any #(each (any any)) any . each-any))))) x))) +(install-global-transformer (quote do) (lambda (orig-x) ((lambda (tmp1224) ((lambda (tmp1225) (if tmp1225 (apply (lambda (_ var init step e0 e11226 c) ((lambda (tmp1227) ((lambda (tmp1228) (if tmp1228 (apply (lambda (step1229) ((lambda (tmp1230) ((lambda (tmp1231) (if tmp1231 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list var init) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) e0) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append c (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) step1229))))))) tmp1231) ((lambda (tmp1235) (if tmp1235 (apply (lambda (e11236 e21237) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list var init) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) e0 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (cons e11236 e21237)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append c (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) step1229))))))) tmp1235) (syntax-error tmp1230))) (syntax-dispatch tmp1230 (quote (any . each-any)))))) (syntax-dispatch tmp1230 (quote ())))) e11226)) tmp1228) (syntax-error tmp1227))) (syntax-dispatch tmp1227 (quote each-any)))) (map (lambda (v1244 s) ((lambda (tmp1245) ((lambda (tmp1246) (if tmp1246 (apply (lambda () v1244) tmp1246) ((lambda (tmp1247) (if tmp1247 (apply (lambda (e) e) tmp1247) ((lambda (_1248) (syntax-error orig-x)) tmp1245))) (syntax-dispatch tmp1245 (quote (any)))))) (syntax-dispatch tmp1245 (quote ())))) s)) var step))) tmp1225) (syntax-error tmp1224))) (syntax-dispatch tmp1224 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x))) +(install-global-transformer (quote quasiquote) (letrec ((quasicons (lambda (x1276 y) ((lambda (tmp) ((lambda (tmp1277) (if tmp1277 (apply (lambda (x1278 y1279) ((lambda (tmp1280) ((lambda (tmp1281) (if tmp1281 (apply (lambda (dy) ((lambda (tmp1282) ((lambda (tmp1283) (if tmp1283 (apply (lambda (dx) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons dx dy))) tmp1283) ((lambda (_1284) (if (null? dy) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1278) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1278 y1279))) tmp1282))) (syntax-dispatch tmp1282 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) x1278)) tmp1281) ((lambda (tmp1285) (if tmp1285 (apply (lambda (stuff) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons x1278 stuff))) tmp1285) ((lambda (else) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1278 y1279)) tmp1280))) (syntax-dispatch tmp1280 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . any)))))) (syntax-dispatch tmp1280 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) y1279)) tmp1277) (syntax-error tmp))) (syntax-dispatch tmp (quote (any any))))) (list x1276 y)))) (quasiappend (lambda (x1286 y1287) ((lambda (tmp1288) ((lambda (tmp1289) (if tmp1289 (apply (lambda (x1290 y1291) ((lambda (tmp1292) ((lambda (tmp1293) (if tmp1293 (apply (lambda () x1290) tmp1293) ((lambda (_1294) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1290 y1291)) tmp1292))) (syntax-dispatch tmp1292 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) ()))))) y1291)) tmp1289) (syntax-error tmp1288))) (syntax-dispatch tmp1288 (quote (any any))))) (list x1286 y1287)))) (quasivector (lambda (x1295) ((lambda (tmp1296) ((lambda (x1297) ((lambda (tmp1298) ((lambda (tmp1299) (if tmp1299 (apply (lambda (x1300) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (list->vector x1300))) tmp1299) ((lambda (tmp1302) (if tmp1302 (apply (lambda (x1303) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1303)) tmp1302) ((lambda (_1305) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1297)) tmp1298))) (syntax-dispatch tmp1298 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . each-any)))))) (syntax-dispatch tmp1298 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) each-any))))) x1297)) tmp1296)) x1295))) (quasi (lambda (p lev) ((lambda (tmp1306) ((lambda (tmp1307) (if tmp1307 (apply (lambda (p1308) (if (= lev (quote 0)) p1308 (quasicons (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi (list p1308) (- lev (quote 1)))))) tmp1307) ((lambda (tmp1309) (if tmp1309 (apply (lambda (p1310 q) (if (= lev (quote 0)) (quasiappend p1310 (quasi q lev)) (quasicons (quasicons (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi (list p1310) (- lev (quote 1)))) (quasi q lev)))) tmp1309) ((lambda (tmp1311) (if tmp1311 (apply (lambda (p1312) (quasicons (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi (list p1312) (+ lev (quote 1))))) tmp1311) ((lambda (tmp1313) (if tmp1313 (apply (lambda (p1314 q1315) (quasicons (quasi p1314 lev) (quasi q1315 lev))) tmp1313) ((lambda (tmp1316) (if tmp1316 (apply (lambda (x1317) (quasivector (quasi x1317 lev))) tmp1316) ((lambda (p1319) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) p1319)) tmp1306))) (syntax-dispatch tmp1306 (quote #(vector each-any)))))) (syntax-dispatch tmp1306 (quote (any . any)))))) (syntax-dispatch tmp1306 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any)))))) (syntax-dispatch tmp1306 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any) . any)))))) (syntax-dispatch tmp1306 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) p)))) (lambda (x1320) ((lambda (tmp1321) ((lambda (tmp1322) (if tmp1322 (apply (lambda (_1323 e1324) (quasi e1324 (quote 0))) tmp1322) (syntax-error tmp1321))) (syntax-dispatch tmp1321 (quote (any any))))) x1320)))) +(install-global-transformer (quote include) (lambda (x) (letrec ((read-file (lambda (fn k) (let ((p1384 (open-input-file fn))) (let f ((x1385 (read p1384))) (if (eof-object? x1385) (begin (close-input-port p1384) (quote ())) (cons (datum->syntax-object k x1385) (f (read p1384))))))))) ((lambda (tmp1386) ((lambda (tmp1387) (if tmp1387 (apply (lambda (k1388 filename) (let ((fn1389 (syntax-object->datum filename))) ((lambda (tmp1390) ((lambda (tmp1391) (if tmp1391 (apply (lambda (exp) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))))) exp)) tmp1391) (syntax-error tmp1390))) (syntax-dispatch tmp1390 (quote each-any)))) (read-file fn1389 k1388)))) tmp1387) (syntax-error tmp1386))) (syntax-dispatch tmp1386 (quote (any any))))) x)))) +(install-global-transformer (quote unquote) (lambda (x1408) ((lambda (tmp1409) ((lambda (tmp1410) (if tmp1410 (apply (lambda (_ e) (error (quote unquote) (quote "expression ,~s not valid outside of quasiquote") (syntax-object->datum e))) tmp1410) (syntax-error tmp1409))) (syntax-dispatch tmp1409 (quote (any any))))) x1408))) +(install-global-transformer (quote unquote-splicing) (lambda (x1416) ((lambda (tmp1417) ((lambda (tmp1418) (if tmp1418 (apply (lambda (_1419 e1420) (error (quote unquote-splicing) (quote "expression ,@~s not valid outside of quasiquote") (syntax-object->datum e1420))) tmp1418) (syntax-error tmp1417))) (syntax-dispatch tmp1417 (quote (any any))))) x1416))) +(install-global-transformer (quote case) (lambda (x1426) ((lambda (tmp1427) ((lambda (tmp1428) (if tmp1428 (apply (lambda (_1429 e1430 m1 m2) ((lambda (tmp1431) ((lambda (body) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) e1430)) body)) tmp1431)) (let f1432 ((clause m1) (clauses m2)) (if (null? clauses) ((lambda (tmp1434) ((lambda (tmp1435) (if tmp1435 (apply (lambda (e1 e2) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e1 e2))) tmp1435) ((lambda (tmp1437) (if tmp1437 (apply (lambda (k1438 e11439 e21440) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) k1438)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11439 e21440)))) tmp1437) ((lambda (_1443) (syntax-error x1426)) tmp1434))) (syntax-dispatch tmp1434 (quote (each-any any . each-any)))))) (syntax-dispatch tmp1434 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) any . each-any))))) clause) ((lambda (tmp1444) ((lambda (rest) ((lambda (tmp1445) ((lambda (tmp1446) (if tmp1446 (apply (lambda (k1447 e11448 e21449) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) k1447)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11448 e21449)) rest)) tmp1446) ((lambda (_1452) (syntax-error x1426)) tmp1445))) (syntax-dispatch tmp1445 (quote (each-any any . each-any))))) clause)) tmp1444)) (f1432 (car clauses) (cdr clauses))))))) tmp1428) (syntax-error tmp1427))) (syntax-dispatch tmp1427 (quote (any any any . each-any))))) x1426))) +(install-global-transformer (quote identifier-syntax) (lambda (x) ((lambda (tmp) ((lambda (tmp1482) (if tmp1482 (apply (lambda (_ e) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) e)) (list (cons _ (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))))))))) tmp1482) (syntax-error tmp))) (syntax-dispatch tmp (quote (any any))))) x))) From 8a4b993ec3f6c9e68f563f74df262f949800c906 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 13 Aug 2000 20:53:09 +0000 Subject: [PATCH 0143/2047] * alist.c (scm_assq, scm_assv, scm_assoc): Report argument type error for the alist rather than the sublist where the type mismatch is discovered. --- libguile/alist.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/libguile/alist.c b/libguile/alist.c index adede41a2..611587fed 100644 --- a/libguile/alist.c +++ b/libguile/alist.c @@ -150,7 +150,7 @@ SCM_DEFINE (scm_assq, "assq", 2, 0, 0, for (; SCM_CONSP (alist); alist = SCM_CDR (alist)) { SCM tmp = SCM_CAR (alist); - SCM_VALIDATE_CONS (SCM_ARG2, tmp); + SCM_VALIDATE_CONS (SCM_ARG2, alist); if (SCM_EQ_P (SCM_CAR (tmp), key)) return tmp; } @@ -168,7 +168,7 @@ SCM_DEFINE (scm_assv, "assv", 2, 0, 0, for(; SCM_CONSP (alist); alist = SCM_CDR (alist)) { SCM tmp = SCM_CAR (alist); - SCM_VALIDATE_CONS (SCM_ARG2, tmp); + SCM_VALIDATE_CONS (SCM_ARG2, alist); if (SCM_NFALSEP (scm_eqv_p (SCM_CAR (tmp), key))) return tmp; } @@ -186,7 +186,7 @@ SCM_DEFINE (scm_assoc, "assoc", 2, 0, 0, for(; SCM_CONSP (alist); alist = SCM_CDR (alist)) { SCM tmp = SCM_CAR (alist); - SCM_VALIDATE_CONS (SCM_ARG2, tmp); + SCM_VALIDATE_CONS (SCM_ARG2, alist); if (SCM_NFALSEP (scm_equal_p (SCM_CAR (tmp), key))) return tmp; } From a94da0e030da7657a4840e4aac4609060493beae Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 13 Aug 2000 20:53:27 +0000 Subject: [PATCH 0144/2047] *** empty log message *** --- libguile/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 1d82aca9e..7c298618c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2000-08-13 Mikael Djurfeldt + + * alist.c (scm_assq, scm_assv, scm_assoc): Report argument type + error for the alist rather than the sublist where the type + mismatch is discovered. + 2000-08-13 Neil Jerram * root.c (s_scm_call_with_dynamic_root): Docstring fix - rogue From 1aa621a3d1769f620e98e4efe5819bccac8f5952 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 13 Aug 2000 21:05:03 +0000 Subject: [PATCH 0145/2047] Fix --- libguile/alist.c | 33 +++++++++++++++++++++------------ 1 file changed, 21 insertions(+), 12 deletions(-) diff --git a/libguile/alist.c b/libguile/alist.c index 611587fed..7e1414ec9 100644 --- a/libguile/alist.c +++ b/libguile/alist.c @@ -147,14 +147,17 @@ SCM_DEFINE (scm_assq, "assq", 2, 0, 0, "return the entire alist entry found (i.e. both the key and the value).") #define FUNC_NAME s_scm_assq { - for (; SCM_CONSP (alist); alist = SCM_CDR (alist)) + SCM ls = alist; + for (; SCM_CONSP (ls); ls = SCM_CDR (ls)) { - SCM tmp = SCM_CAR (alist); - SCM_VALIDATE_CONS (SCM_ARG2, alist); + SCM tmp = SCM_CAR (ls); + SCM_ASSERT_TYPE (SCM_CONSP (tmp), alist, SCM_ARG2, FUNC_NAME, + "association list"); if (SCM_EQ_P (SCM_CAR (tmp), key)) return tmp; } - SCM_VALIDATE_NULL (2, alist); + SCM_ASSERT_TYPE (SCM_NULLP (ls), alist, SCM_ARG2, FUNC_NAME, + "association list"); return SCM_BOOL_F; } #undef FUNC_NAME @@ -165,14 +168,17 @@ SCM_DEFINE (scm_assv, "assv", 2, 0, 0, "Behaves like @code{assq} but uses @code{eqv?} for key comparison.") #define FUNC_NAME s_scm_assv { - for(; SCM_CONSP (alist); alist = SCM_CDR (alist)) + SCM ls = alist; + for(; SCM_CONSP (ls); ls = SCM_CDR (ls)) { - SCM tmp = SCM_CAR (alist); - SCM_VALIDATE_CONS (SCM_ARG2, alist); + SCM tmp = SCM_CAR (ls); + SCM_ASSERT_TYPE (SCM_CONSP (tmp), alist, SCM_ARG2, FUNC_NAME, + "association list"); if (SCM_NFALSEP (scm_eqv_p (SCM_CAR (tmp), key))) return tmp; } - SCM_VALIDATE_NULL (2, alist); + SCM_ASSERT_TYPE (SCM_NULLP (ls), alist, SCM_ARG2, FUNC_NAME, + "association list"); return SCM_BOOL_F; } #undef FUNC_NAME @@ -183,14 +189,17 @@ SCM_DEFINE (scm_assoc, "assoc", 2, 0, 0, "Behaves like @code{assq} but uses @code{equal?} for key comparison.") #define FUNC_NAME s_scm_assoc { - for(; SCM_CONSP (alist); alist = SCM_CDR (alist)) + SCM ls = alist; + for(; SCM_CONSP (ls); ls = SCM_CDR (ls)) { - SCM tmp = SCM_CAR (alist); - SCM_VALIDATE_CONS (SCM_ARG2, alist); + SCM tmp = SCM_CAR (ls); + SCM_ASSERT_TYPE (SCM_CONSP (tmp), alist, SCM_ARG2, FUNC_NAME, + "association list"); if (SCM_NFALSEP (scm_equal_p (SCM_CAR (tmp), key))) return tmp; } - SCM_VALIDATE_NULL (2, alist); + SCM_ASSERT_TYPE (SCM_NULLP (ls), alist, SCM_ARG2, FUNC_NAME, + "association list"); return SCM_BOOL_F; } #undef FUNC_NAME From a510a7d8d5d96de2af2766d837e76b832366c5db Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Mon, 14 Aug 2000 15:40:03 +0000 Subject: [PATCH 0146/2047] =?UTF-8?q?*=20format.scm=20(format:obj->str):?= =?UTF-8?q?=20Made=20tail-recursive.=20=20(Thanks=20to=20Matthias=20K?= =?UTF-8?q?=C2=81=C3=B6ppe.)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- ice-9/format.scm | 30 ++++++++++++++++++------------ 1 file changed, 18 insertions(+), 12 deletions(-) diff --git a/ice-9/format.scm b/ice-9/format.scm index e4c5c6f63..abd13ddab 100644 --- a/ice-9/format.scm +++ b/ice-9/format.scm @@ -822,13 +822,17 @@ (string-append "(" (let loop ((obj-list obj) (visited visited) - (offset 0)) + (offset 0) + (prefix "")) (cond ((null? (cdr obj-list)) - (obj->str (car obj-list) - #t - (cons (car obj-list) visited))) + (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)) @@ -838,16 +842,18 @@ (list-index visited (cdr obj-list)))) "#")) ((pair? (cdr obj-list)) - (string-append - (obj->str (car obj-list) - #t - (cons (car obj-list) visited)) - " " - (loop (cdr obj-list) - (cons (cdr obj-list) visited) - (+ 1 offset)))) + (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)) From d6f3775530da66e03a927d56022551f867adf933 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Mon, 14 Aug 2000 15:40:27 +0000 Subject: [PATCH 0147/2047] *** empty log message *** --- THANKS | 1 + ice-9/ChangeLog | 5 +++++ 2 files changed, 6 insertions(+) diff --git a/THANKS b/THANKS index f9c59246b..81d2e51ca 100644 --- a/THANKS +++ b/THANKS @@ -11,6 +11,7 @@ For fixes or providing information which led to a fix: Ian Bicking Brad Knotwell + Matthias Köppe Nicolas Neuss Han-Wen Nienhuys William Webber diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index a457618f7..3d99d0424 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2000-08-14 Mikael Djurfeldt + + * format.scm (format:obj->str): Made tail-recursive. (Thanks to + Matthias Köppe.) + 2000-08-13 Mikael Djurfeldt * psyntax.ss (top-level-eval-hook, local-eval-hook): Pass From c9b0d4b0903084a7b0ac3637a1d79cbd9e546be1 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Wed, 16 Aug 2000 00:23:18 +0000 Subject: [PATCH 0148/2047] * gc.c (scm_gc_stats): add more obscure stats, such as: mark time, sweep time, total marked cells, total swept cells, and number of times GC was invoked. (gc_start_stats): renamed from scm_gc_start, made static, taught to init the new stats. (gc_end_stats): renamed from scm_gc_end, made static, taught to calculate the new stats. (scm_igc): don't call gc_start_stats unless we are sure that we are indeed going to collect. also, added some timekeeping between the mark and sweep phases. (scm_gc_sweep): count number of cells we sweep as we go. * gc.h: removed prototypes for scm_gc_{start,end}. --- libguile/gc.c | 62 +++++++++++++++++++++++++++++++++++++++++---------- libguile/gc.h | 2 -- 2 files changed, 50 insertions(+), 14 deletions(-) diff --git a/libguile/gc.c b/libguile/gc.c index f682881fc..74c9b622d 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -332,8 +332,15 @@ unsigned long scm_gc_yield; static unsigned long scm_gc_yield_1 = 0; /* previous GC yield */ unsigned long scm_gc_malloc_collected; unsigned long scm_gc_ports_collected; -unsigned long scm_gc_rt; unsigned long scm_gc_time_taken = 0; +static unsigned long t_before_gc; +static unsigned long t_before_sweep; +unsigned long scm_gc_mark_time_taken = 0; +unsigned long scm_gc_sweep_time_taken = 0; +unsigned long scm_gc_times = 0; +unsigned long scm_gc_cells_swept = 0; +double scm_gc_cells_marked_acc = 0.; +double scm_gc_cells_swept_acc = 0.; SCM_SYMBOL (sym_cells_allocated, "cells-allocated"); SCM_SYMBOL (sym_heap_size, "cell-heap-size"); @@ -341,6 +348,11 @@ SCM_SYMBOL (sym_mallocated, "bytes-malloced"); SCM_SYMBOL (sym_mtrigger, "gc-malloc-threshold"); SCM_SYMBOL (sym_heap_segments, "cell-heap-segments"); SCM_SYMBOL (sym_gc_time_taken, "gc-time-taken"); +SCM_SYMBOL (sym_gc_mark_time_taken, "gc-mark-time-taken"); +SCM_SYMBOL (sym_gc_sweep_time_taken, "gc-sweep-time-taken"); +SCM_SYMBOL (sym_times, "gc-times"); +SCM_SYMBOL (sym_cells_marked, "cells-marked"); +SCM_SYMBOL (sym_cells_swept, "cells-swept"); typedef struct scm_heap_seg_data_t { @@ -641,6 +653,11 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, long int local_scm_heap_size; long int local_scm_cells_allocated; long int local_scm_gc_time_taken; + long int local_scm_gc_times; + long int local_scm_gc_mark_time_taken; + long int local_scm_gc_sweep_time_taken; + double local_scm_gc_cells_swept; + double local_scm_gc_cells_marked; SCM answer; SCM_DEFER_INTS; @@ -667,12 +684,22 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, local_scm_heap_size = SCM_HEAP_SIZE; local_scm_cells_allocated = compute_cells_allocated (); local_scm_gc_time_taken = scm_gc_time_taken; + local_scm_gc_mark_time_taken = scm_gc_mark_time_taken; + local_scm_gc_sweep_time_taken = scm_gc_sweep_time_taken; + local_scm_gc_times = scm_gc_times; + local_scm_gc_cells_swept = scm_gc_cells_swept_acc; + local_scm_gc_cells_marked = scm_gc_cells_marked_acc; answer = scm_listify (scm_cons (sym_gc_time_taken, scm_ulong2num (local_scm_gc_time_taken)), scm_cons (sym_cells_allocated, scm_ulong2num (local_scm_cells_allocated)), scm_cons (sym_heap_size, scm_ulong2num (local_scm_heap_size)), scm_cons (sym_mallocated, scm_ulong2num (local_scm_mallocated)), scm_cons (sym_mtrigger, scm_ulong2num (local_scm_mtrigger)), + scm_cons (sym_times, scm_ulong2num (local_scm_gc_times)), + scm_cons (sym_gc_mark_time_taken, scm_ulong2num (local_scm_gc_mark_time_taken)), + scm_cons (sym_gc_sweep_time_taken, scm_ulong2num (local_scm_gc_sweep_time_taken)), + scm_cons (sym_cells_marked, scm_dbl2big (local_scm_gc_cells_marked)), + scm_cons (sym_cells_swept, scm_dbl2big (local_scm_gc_cells_swept)), scm_cons (sym_heap_segments, heap_segs), SCM_UNDEFINED); SCM_ALLOW_INTS; @@ -681,10 +708,11 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, #undef FUNC_NAME -void -scm_gc_start (const char *what) +static void +gc_start_stats (const char *what) { - scm_gc_rt = SCM_INUM (scm_get_internal_run_time ()); + t_before_gc = scm_c_get_internal_run_time (); + scm_gc_cells_swept = 0; scm_gc_cells_collected = 0; scm_gc_yield_1 = scm_gc_yield; scm_gc_yield = (scm_cells_allocated @@ -695,11 +723,16 @@ scm_gc_start (const char *what) } -void -scm_gc_end () +static void +gc_end_stats () { - scm_gc_rt = SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt; - scm_gc_time_taken += scm_gc_rt; + unsigned long t = scm_c_get_internal_run_time (); + scm_gc_time_taken += (t - t_before_gc); + scm_gc_sweep_time_taken += (t - t_before_sweep); + ++scm_gc_times; + + scm_gc_cells_marked_acc += scm_gc_cells_swept - scm_gc_cells_collected; + scm_gc_cells_swept_acc += scm_gc_cells_swept; } @@ -867,15 +900,14 @@ scm_igc (const char *what) /* fprintf (stderr, "gc: %s\n", what); */ - scm_gc_start (what); - if (!scm_stack_base || scm_block_gc) { - scm_gc_end (); --scm_gc_running_p; return; } + gc_start_stats (what); + if (scm_mallocated < 0) /* The byte count of allocated objects has underflowed. This is probably because you forgot to report the sizes of objects you @@ -959,6 +991,9 @@ scm_igc (const char *what) scm_gc_mark (scm_root->handle); #endif + t_before_sweep = scm_c_get_internal_run_time (); + scm_gc_mark_time_taken += (t_before_sweep - t_before_gc); + scm_c_hook_run (&scm_before_sweep_c_hook, 0); scm_gc_sweep (); @@ -966,7 +1001,7 @@ scm_igc (const char *what) scm_c_hook_run (&scm_after_sweep_c_hook, 0); --scm_gc_heap_lock; - scm_gc_end (); + gc_end_stats (); #ifdef USE_THREADS SCM_THREAD_CRITICAL_SECTION_END; @@ -1452,6 +1487,9 @@ scm_gc_sweep () ptr = CELL_UP (scm_heap_table[i].bounds[0], span); seg_size = CELL_DN (scm_heap_table[i].bounds[1], span) - ptr; + + scm_gc_cells_swept += seg_size; + for (j = seg_size + span; j -= span; ptr += span) { SCM scmptr = PTR2SCM (ptr); diff --git a/libguile/gc.h b/libguile/gc.h index 7f1207671..5af83869d 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -266,8 +266,6 @@ extern SCM scm_gc_set_debug_check_freelist_x (SCM flag); extern SCM scm_object_address (SCM obj); extern SCM scm_unhash_name (SCM name); extern SCM scm_gc_stats (void); -extern void scm_gc_start (const char *what); -extern void scm_gc_end (void); extern SCM scm_gc (void); extern void scm_gc_for_alloc (struct scm_freelist_t *freelist); extern SCM scm_gc_for_newcell (struct scm_freelist_t *master, SCM *freelist); From 1c299a6be5b0472bdcafc9ad25690ca99c2f7348 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Wed, 16 Aug 2000 00:23:59 +0000 Subject: [PATCH 0149/2047] * stime.c (scm_c_get_internal_run_time): new function, same as scm_get_internal_run_time but returns a long. it's used by the GC for timekeeping, since with scm_get_internal_run_time there is a (extremely theoretical) possibility of consing. (scm_get_internal_run_time): redefined in terms of scm_c_get_internal_run_time. * stime.h: added prototype for scm_c_get_internal_run_time. --- libguile/stime.c | 43 ++++++++++++++++++++++++------------------- libguile/stime.h | 7 ++++--- 2 files changed, 28 insertions(+), 22 deletions(-) diff --git a/libguile/stime.c b/libguile/stime.c index 7f739e346..460e8f3a9 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -1,15 +1,15 @@ /* Copyright (C) 1995,1996,1997,1998, 1999, 2000 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 * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, @@ -106,7 +106,6 @@ extern char *strptime (); # define CLKTCK 60 #endif - #ifdef __STDC__ # define timet time_t #else @@ -115,7 +114,7 @@ extern char *strptime (); #ifdef HAVE_TIMES static -long mytime() +timet mytime() { struct tms time_buffer; times(&time_buffer); @@ -137,7 +136,7 @@ struct timeb scm_your_base = {0}; timet scm_your_base = 0; #endif -SCM_DEFINE (scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0, +SCM_DEFINE (scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0, (), "Returns the number of time units since the interpreter was started.") #define FUNC_NAME s_scm_get_internal_real_time @@ -162,7 +161,7 @@ SCM_DEFINE (scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0, #ifdef HAVE_TIMES -SCM_DEFINE (scm_times, "times", 0, 0, 0, +SCM_DEFINE (scm_times, "times", 0, 0, 0, (void), "Returns an object with information about real and processor time.\n" "The following procedures accept such an object as an argument and\n" @@ -203,17 +202,23 @@ SCM_DEFINE (scm_times, "times", 0, 0, 0, static long scm_my_base = 0; -SCM_DEFINE (scm_get_internal_run_time, "get-internal-run-time", 0, 0, 0, +long +scm_c_get_internal_run_time () +{ + return mytime () - scm_my_base; +} + +SCM_DEFINE (scm_get_internal_run_time, "get-internal-run-time", 0, 0, 0, (void), "Returns the number of time units of processor time used by the interpreter.\n" "Both \"system\" and \"user\" time are included but subprocesses are not.") #define FUNC_NAME s_scm_get_internal_run_time { - return scm_long2num(mytime()-scm_my_base); + return scm_long2num (scm_c_get_internal_run_time ()); } #undef FUNC_NAME -SCM_DEFINE (scm_current_time, "current-time", 0, 0, 0, +SCM_DEFINE (scm_current_time, "current-time", 0, 0, 0, (void), "Returns the number of seconds since 1970-01-01 00:00:00 UTC, excludingleap seconds.") #define FUNC_NAME s_scm_current_time @@ -228,7 +233,7 @@ SCM_DEFINE (scm_current_time, "current-time", 0, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_gettimeofday, "gettimeofday", 0, 0, 0, +SCM_DEFINE (scm_gettimeofday, "gettimeofday", 0, 0, 0, (void), "Returns a pair containing the number of seconds and microseconds since\n" "1970-01-01 00:00:00 UTC, excluding leap seconds. Note: whether true\n" @@ -249,11 +254,11 @@ SCM_DEFINE (scm_gettimeofday, "gettimeofday", 0, 0, 0, struct timeb time; ftime(&time); - return scm_cons (scm_long2num ((long) time.time), + return scm_cons (scm_long2num ((long) time.time), SCM_MAKINUM (time.millitm * 1000)); # else timet timv; - + SCM_DEFER_INTS; if ((timv = time (0)) == -1) SCM_SYSERROR; @@ -327,7 +332,7 @@ restorezone (SCM zone, char **oldenv, const char *subr) } } -SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0, +SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0, (SCM time, SCM zone), "Returns an object representing the broken down components of @var{time},\n" "an integer like the one returned by @code{current-time}. The time zone\n" @@ -393,7 +398,7 @@ SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0, zoff -= 24 * 60 * 60; else if (utc->tm_yday > lt.tm_yday) zoff += 24 * 60 * 60; - + result = filltime (<, zoff, zname); SCM_ALLOW_INTS; scm_must_free (zname); @@ -401,7 +406,7 @@ SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_gmtime, "gmtime", 1, 0, 0, +SCM_DEFINE (scm_gmtime, "gmtime", 1, 0, 0, (SCM time), "Returns an object representing the broken down components of @var{time},\n" "an integer like the one returned by @code{current-time}. The values\n" @@ -459,7 +464,7 @@ bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr) #endif } -SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0, +SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0, (SCM sbd_time, SCM zone), "@var{bd-time} is an object representing broken down time and @code{zone}\n" "is an optional time zone specifier (otherwise the TZ environment variable\n" @@ -535,7 +540,7 @@ SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0, #undef FUNC_NAME #ifdef HAVE_TZSET -SCM_DEFINE (scm_tzset, "tzset", 0, 0, 0, +SCM_DEFINE (scm_tzset, "tzset", 0, 0, 0, (void), "Initialize the timezone from the TZ environment variable\n" "or the system default. It's not usually necessary to call this procedure\n" @@ -606,7 +611,7 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, scm_string_append (scm_cons (velts[10], scm_cons (scm_makfrom0str ("0"), SCM_EOL))); - + have_zone = 1; SCM_DEFER_INTS; oldenv = setzone (zone, SCM_ARG2, FUNC_NAME); diff --git a/libguile/stime.h b/libguile/stime.h index 2bfd77525..eaea28847 100644 --- a/libguile/stime.h +++ b/libguile/stime.h @@ -3,17 +3,17 @@ #ifndef STIMEH #define STIMEH /* Copyright (C) 1995,1996,1997,1998, 2000 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 * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, @@ -47,6 +47,7 @@ #include "libguile/__scm.h" +long scm_c_get_internal_run_time (void); extern SCM scm_get_internal_real_time (void); extern SCM scm_get_internal_run_time (void); extern SCM scm_current_time (void); From 83238bc162036a6f0d66b204d1a293ccb9272617 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Wed, 16 Aug 2000 00:25:38 +0000 Subject: [PATCH 0150/2047] *** empty log message *** --- libguile/ChangeLog | 63 ++++++++++++++++++++++++++++++++-------------- 1 file changed, 44 insertions(+), 19 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 7c298618c..30b9922c0 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,28 @@ +2000-08-16 Michael Livshin + + * stime.c (scm_c_get_internal_run_time): new function, same as + scm_get_internal_run_time but returns a long. it's used by the GC + for timekeeping, since with scm_get_internal_run_time there is a + (extremely theoretical) possibility of consing. + (scm_get_internal_run_time): redefined in terms of + scm_c_get_internal_run_time. + + * stime.h: added prototype for scm_c_get_internal_run_time. + + * gc.c (scm_gc_stats): add more obscure stats, such as: mark time, + sweep time, total marked cells, total swept cells, and number of + times GC was invoked. + (gc_start_stats): renamed from scm_gc_start, made static, taught + to init the new stats. + (gc_end_stats): renamed from scm_gc_end, made static, taught to + calculate the new stats. + (scm_igc): don't call gc_start_stats unless we are sure that we + are indeed going to collect. also, added some timekeeping between + the mark and sweep phases. + (scm_gc_sweep): count number of cells we sweep as we go. + + * gc.h: removed prototypes for scm_gc_{start,end}. + 2000-08-13 Mikael Djurfeldt * alist.c (scm_assq, scm_assv, scm_assoc): Report argument type @@ -8,7 +33,7 @@ * root.c (s_scm_call_with_dynamic_root): Docstring fix - rogue newline. - + 2000-08-12 Neil Jerram * numbers.c (scm_ash): Docstring fix - missing newlines. @@ -31,7 +56,7 @@ * list.c (scm_list_tail): Add @deffnx line to docstring for list-cdr-ref. - + * keywords.c: Docstring improvements in conjunction with new reference manual doc on keywords. @@ -61,7 +86,7 @@ (scm_module_index_obarray, scm_module_index_uses, scm_module_index_binder, scm_module_index_eval_closure): New constants; #include "validate.h". - + * modules.c (scm_module_tag, scm_module_system_booted_p): New globals. (scm_post_boot_init_modules): Initialize scm_module_tag. @@ -178,7 +203,7 @@ equal (respectively) to the argument key, not all cells that are eq, eqv, or equal to the first cell with the argument key. Thanks to Neil Jerram! - + 2000-07-18 Dirk Herrmann * gc.h (SCM_FREE_CELL_CDR, SCM_SET_FREE_CELL_CDR), hooks.c @@ -478,8 +503,8 @@ 2000-06-21 Michael Livshin * guile-doc-snarf.in: use cut instead of sed, that's much much - faster. also, don't call basename more than needed. and, to gain - a couple of microseconds more, don't call cat needlessly. (thanks + faster. also, don't call basename more than needed. and, to gain + a couple of microseconds more, don't call cat needlessly. (thanks to Brad Knotwell). 2000-06-21 Dirk Herrmann @@ -776,7 +801,7 @@ Sun Jun 18 14:45:21 2000 Greg J. Badros that a chain of Scheme level procedures has been evaluated for every top-level symbol lookup during the first pass through the code. - + The following is a kludge which I suggested four years ago, and which I've repeatedly suggested since. Personally, I've never been bothered by Guile's slow loading speed, so I thought I would @@ -785,7 +810,7 @@ Sun Jun 18 14:45:21 2000 Greg J. Badros But since the new environments will be included first in Guile-1.5, I thought it would make people happy to get the kludge into 1.4. - + * modules.c: Added #include "libguile/vectors.h"; Added #include "libguile/hashtab.h"; Added #include "libguile/struct.h"; @@ -893,7 +918,7 @@ Sun Jun 18 14:45:21 2000 Greg J. Badros * filesys.h (SCM_OPDIRP), fluids.h (SCM_FLUIDP, SCM_FLUID_NUM), fports.h (SCM_OPFPORTP, SCM_OPINFPORTP, SCM_OPOUTFPORTP), hooks.h (SCM_HOOK_ARITY), keywords.h (SCM_KEYWORDP, SCM_KEYWORDSYM), - numbers.h (SCM_NUMP, SCM_BIGSIGN, SCM_BDIGITS, SCM_NUMDIGS): + numbers.h (SCM_NUMP, SCM_BIGSIGN, SCM_BDIGITS, SCM_NUMDIGS): Replace SCM_UNPACK_CAR appropriately. Don't access cells via SCM_{SET}?C[AD]R unless they are known to be cons cells. @@ -948,7 +973,7 @@ Sun Jun 18 14:45:21 2000 Greg J. Badros cookies anyway. in the long term, it would be nice not to depend on AWK for anything.) - * gc.h (SCM_[SET_]CELL_{WORD,OBJECT}, SCM_VALIDATE_CELL): reverted + * gc.h (SCM_[SET_]CELL_{WORD,OBJECT}, SCM_VALIDATE_CELL): reverted the previous change to this macros, after deciding to torture the snarfer instead. @@ -975,7 +1000,7 @@ Sun Jun 18 14:45:21 2000 Greg J. Badros * hashtab.c (scm_hash_fn_create_handle_x): add missing SCM_REALLOW_INTS before return. I really wonder about the possible interactions between hashtables, threads & GC. it - doesn't look healthy at all. + doesn't look healthy at all. 2000-05-20 Dirk Herrmann @@ -1057,7 +1082,7 @@ Sun Jun 18 14:45:21 2000 Greg J. Badros * stacks.c (scm_make_stack), stacks.h (scm_make_stack), throw.c (ss_handler, handler_message): Make first mandatory rest argument - of scm_make_stack into a standard mandatory argument. + of scm_make_stack into a standard mandatory argument. * unif.c (scm_transpose_array, scm_enclose_array, scm_array_in_bounds_p), unif.h (scm_transpose_array, @@ -1385,7 +1410,7 @@ Sun Jun 18 14:45:21 2000 Greg J. Badros comparisons of SCM values with integer constants. * number.c (scm_logtest): Removed some redundant SCM_{N}?IMP - tests. + tests. 2000-04-28 Dirk Herrmann @@ -1423,7 +1448,7 @@ Sun Jun 18 14:45:21 2000 Greg J. Badros Better modularization of GC extensions through new C level GC hooks: - + * weaks.c (scm_weaks_prehistory): New function: Add scm_weak_vector_gc_init to scm_before_mark_c_hook; Add scm_mark_weak_vector_spines to scm_before_sweep_c_hook. @@ -1487,7 +1512,7 @@ Sun Jun 18 14:45:21 2000 Greg J. Badros the new code is not less clear.) * gc.c (scm_must_malloc, scm_must_realloc, scm_must_free): Added - calls to malloc debugging functions. + calls to malloc debugging functions. * init.c (scm_boot_guile_1): Added calls to debug-malloc init functions. @@ -1558,8 +1583,8 @@ Sun Jun 18 14:45:21 2000 Greg J. Badros Tue Apr 18 08:22:41 2000 Greg J. Badros - * validate.h: Do not cast to (unsigned) in SCM_VALIDATE_INUM_RANGE - when testing high-end of the range. Mikael Djurfeldt noticed this + * validate.h: Do not cast to (unsigned) in SCM_VALIDATE_INUM_RANGE + when testing high-end of the range. Mikael Djurfeldt noticed this anomaly -- thanks Mikael! 2000-04-18 Dirk Herrmann @@ -1697,7 +1722,7 @@ Tue Apr 18 08:22:41 2000 Greg J. Badros symbols.c (scm_intern_obarray_soft, msymbolize, scm_symbol_fset_x, scm_symbol_pset_x): Use them. - * symbols.c (scm_symbol_hash): Unpack to access SCM raw data. + * symbols.c (scm_symbol_hash): Unpack to access SCM raw data. 2000-04-12 Dirk Herrmann @@ -1748,7 +1773,7 @@ Tue Apr 18 08:22:41 2000 Greg J. Badros * numbers.c (scm_quotient, scm_modulo): Reordered to handle the case of immediate numbers parameters first. Also, only use decoded numbers for numerical comparison. - + 2000-04-10 Mikael Djurfeldt * objects.h: Don't redeclare scm_call_generic_0 and From dfb49627fc72ebbde4ea6eb685e287cbba673ac8 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 16 Aug 2000 19:30:07 +0000 Subject: [PATCH 0151/2047] * optargs.scm: Replaced `#&' reader syntax with keywords. --- ice-9/optargs.scm | 99 +++++++++++++++++------------------------------ 1 file changed, 35 insertions(+), 64 deletions(-) diff --git a/ice-9/optargs.scm b/ice-9/optargs.scm index d9687b47e..9824104a3 100644 --- a/ice-9/optargs.scm +++ b/ice-9/optargs.scm @@ -48,9 +48,9 @@ ;;; Summary of the lambda* extended parameter list syntax (brackets ;;; are used to indicate grouping only): ;;; -;;; ext-param-list ::= [identifier]* [#&optional [ext-var-decl]+]? -;;; [#&key [ext-var-decl]+ [#&allow-other-keys]?]? -;;; [[#&rest identifier]|[. identifier]]? +;;; ext-param-list ::= [identifier]* [#:optional [ext-var-decl]+]? +;;; [#:key [ext-var-decl]+ [#:allow-other-keys]?]? +;;; [[#:rest identifier]|[. identifier]]? ;;; ;;; ext-var-decl ::= identifier | ( identifier expression ) ;;; @@ -195,44 +195,15 @@ accum (loop (car rest) (cdr rest) accum))))))) - -;; reader extensions for #&optional #&key #&allow-other-keys #&rest -;; These need to be quoted in normal code, but need not be in -;; an extended lambda-list provided by lambda*, define*, or -;; define*-public (see below). In other words, they act sort of like -;; symbols, except they aren't. They're being temporarily used until -;; #!optional and #!key and such are available. #&rest is provided for -;; the convenience of confused Common Lisp users, even though `.' will -;; do just as well. - -(define the-optional-value - ((record-constructor (make-record-type - 'optional '() (lambda (o p) - (display "#&optional")))))) - -(define the-key-value - ((record-constructor (make-record-type - 'key '() (lambda (o p) - (display "#&key")))))) - - -(define the-rest-value - ((record-constructor (make-record-type - 'rest '() (lambda (o p) - (display "#&rest" p)))))) - -(define the-allow-other-keys-value - ((record-constructor (make-record-type - 'allow-other-keys '() (lambda (o p) - (display "#&allow-other-keys" p)))))) - +;; This is a reader extension to support the (deprecated) use of +;; "#&optional" instead of "#:optional" (read-hash-extend #\& (lambda (c port) (case (read port) - ((optional) the-optional-value) - ((key) the-key-value) - ((rest) the-rest-value) - ((allow-other-keys) the-allow-other-keys-value) + ((optional) #:optional) + ((key) #:key) + ((rest) #:rest) + ((allow-other-keys) #:allow-other-keys-value) (else (error "Bad #& value."))))) @@ -242,7 +213,7 @@ ;; lambda* creates a procedure that takes optional arguments. These ;; are specified by putting them inside brackets at the end of the ;; paramater list, but before any dotted rest argument. For example, -;; (lambda* (a b #&optional c d . e) '()) +;; (lambda* (a b #:optional c d . e) '()) ;; creates a procedure with fixed arguments a and b, optional arguments c ;; and d, and rest argument e. If the optional arguments are omitted ;; in a call, the variables for them are unbound in the procedure. This @@ -250,7 +221,7 @@ ;; ;; lambda* can also take keyword arguments. For example, a procedure ;; defined like this: -;; (lambda* (#&key xyzzy larch) '()) +;; (lambda* (#:key xyzzy larch) '()) ;; can be called with any of the argument lists (#:xyzzy 11) ;; (#:larch 13) (#:larch 42 #:xyzzy 19) (). Whichever arguments ;; are given as keywords are bound to values. @@ -258,7 +229,7 @@ ;; Optional and keyword arguments can also be given default values ;; which they take on when they are not present in a call, by giving a ;; two-item list in place of an optional argument, for example in: -;; (lambda* (foo #&optional (bar 42) #&key (baz 73)) (list foo bar baz)) +;; (lambda* (foo #:optional (bar 42) #:key (baz 73)) (list foo bar baz)) ;; foo is a fixed argument, bar is an optional argument with default ;; value 42, and baz is a keyword argument with default value 73. ;; Default value expressions are not evaluated unless they are needed @@ -268,17 +239,17 @@ ;; ;; lambda*-defined procedures now throw an error by default if a ;; keyword other than one of those specified is found in the actual -;; passed arguments. However, specifying #&allow-other-keys +;; passed arguments. However, specifying #:allow-other-keys ;; immediately after the kyword argument declarations restores the ;; previous behavior of ignoring unknown keywords. lambda* also now ;; guarantees that if the same keyword is passed more than once, the ;; last one passed is the one that takes effect. For example, -;; ((lambda* (#&key (heads 0) (tails 0)) (display (list heads tails))) +;; ((lambda* (#:key (heads 0) (tails 0)) (display (list heads tails))) ;; #:heads 37 #:tails 42 #:heads 99) ;; would result in (99 47) being displayed. ;; -;; #&rest is also now provided as a synonym for the dotted syntax rest -;; argument. The argument lists (a . b) and (a #&rest b) are equivalent in +;; #:rest is also now provided as a synonym for the dotted syntax rest +;; argument. The argument lists (a . b) and (a #:rest b) are equivalent in ;; all respects to lambda*. This is provided for more similarity to DSSSL, ;; MIT-Scheme and Kawa among others, as well as for refugees from other ;; Lisp dialects. @@ -345,27 +316,27 @@ (else (cont lst '() #f)))) (define (parse-opt-and-fixed arglist keys aok? rest cont) (split-list-at - '#&optional arglist + #:optional arglist (lambda (before after split?) (if (and split? (null? after)) - (error "#&optional specified but no optional arguments declared.") + (error "#:optional specified but no optional arguments declared.") (cont before after keys aok? rest))))) (define (parse-keys arglist rest cont) (split-list-at - '#&allow-other-keys arglist + #:allow-other-keys arglist (lambda (aok-before aok-after aok-split?) (if (and aok-split? (not (null? aok-after))) - (error "#&allow-other-keys not at end of keyword argument declarations.") + (error "#:allow-other-keys not at end of keyword argument declarations.") (split-list-at - '#&key aok-before + #:key aok-before (lambda (key-before key-after key-split?) (cond ((and aok-split? (not key-split?)) - (error "#&allow-other-keys specified but no keyword arguments declared.")) + (error "#:allow-other-keys specified but no keyword arguments declared.")) (key-split? (cond - ((null? key-after) (error "#&key specified but no keyword arguments declared.")) - ((memq '#&optional key-after) (error "#&optional arguments declared after #&key arguments.")) + ((null? key-after) (error "#:key specified but no keyword arguments declared.")) + ((memq #:optional key-after) (error "#:optional arguments declared after #:key arguments.")) (else (parse-opt-and-fixed key-before key-after aok-split? rest cont)))) (else (parse-opt-and-fixed arglist '() #f rest cont))))))))) (define (parse-rest arglist cont) @@ -377,17 +348,17 @@ (lp (last-pair copy)) (ra (cdr lp))) (set-cdr! lp '()) - (if (memq '#&rest copy) - (error "Cannot specify both #&rest and dotted rest argument.") + (if (memq #:rest copy) + (error "Cannot specify both #:rest and dotted rest argument.") (parse-keys copy ra cont)))) (else (split-list-at - '#&rest arglist + #:rest arglist (lambda (before after split?) (if split? (case (length after) - ((0) (error "#&rest not followed by argument.")) + ((0) (error "#:rest not followed by argument.")) ((1) (parse-keys before (car after) cont)) - (else (error "#&rest argument must be declared last."))) + (else (error "#:rest argument must be declared last."))) (parse-keys before #f cont))))))) (parse-rest arglist cont)) @@ -401,16 +372,16 @@ ;; define* and define*-public support optional arguments with ;; a similar syntax to lambda*. They also support arbitrary-depth ;; currying, just like Guile's define. Some examples: -;; (define* (x y #&optional a (z 3) #&key w . u) (display (list y z u))) +;; (define* (x y #:optional a (z 3) #:key w . u) (display (list y z u))) ;; defines a procedure x with a fixed argument y, an optional agument ;; a, another optional argument z with default value 3, a keyword argument w, ;; and a rest argument u. -;; (define-public* ((foo #&optional bar) #&optional baz) '()) +;; (define-public* ((foo #:optional bar) #:optional baz) '()) ;; This illustrates currying. A procedure foo is defined, which, ;; when called with an optional argument bar, returns a procedure that ;; takes an optional argument baz. ;; -;; Of course, define*[-public] also supports #&rest and #&allow-other-keys +;; Of course, define*[-public] also supports #:rest and #:allow-other-keys ;; in the same way as lambda*. (defmacro-public define* (ARGLIST . BODY) @@ -442,10 +413,10 @@ ;; defmacro and defmacro-public extended for optional and keyword arguments ;; ;; These are just like defmacro and defmacro-public except that they -;; take lambda*-style extended paramter lists, where #&optional, -;; #&key, #&allow-other-keys and #&rest are allowed with the usual +;; take lambda*-style extended paramter lists, where #:optional, +;; #:key, #:allow-other-keys and #:rest are allowed with the usual ;; semantics. Here is an example of a macro with an optional argument: -;; (defmacro* transmorgify (a #&optional b) +;; (defmacro* transmorgify (a #:optional b) (defmacro-public defmacro* (NAME ARGLIST . BODY) (defmacro*-guts 'define NAME ARGLIST BODY)) From 76ef92f358fdecd6b2400c23405a36295386dacd Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 16 Aug 2000 19:30:28 +0000 Subject: [PATCH 0152/2047] *** empty log message *** --- NEWS | 9 +++++++++ ice-9/ChangeLog | 5 +++++ 2 files changed, 14 insertions(+) diff --git a/NEWS b/NEWS index ce43cec0b..6004914c7 100644 --- a/NEWS +++ b/NEWS @@ -22,6 +22,15 @@ Example: * Changes to Scheme functions and syntax +** Module (ice-9 optargs) now uses keywords instead of `#&'. + +Instead of #&optional, #&key, etc you should now use #:optional, +#:key, etc. Since #:optional is a keyword, you can write it as just +:optional when (read-set! keywords 'prefix) is active. + +The old reader syntax `#&' is still supported, but deprecated. It +will be removed in the next release. + ** Backward incompatible change: eval EXP ENVIRONMENT-SPECIFIER `eval' is now R5RS, that is it takes two arguments. diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 3d99d0424..2bbed0164 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2000-08-16 Marius Vollmer + + * optargs.scm: Replaced `#&' reader syntax with keywords. + 2000-08-14 Mikael Djurfeldt * format.scm (format:obj->str): Made tail-recursive. (Thanks to @@ -50,6 +54,7 @@ (process-define-module): Bugfix: Make sure that exports are done *after* all used interfaces has been added. +>>>>>>> 1.341 2000-07-24 Marius Vollmer * common-list.scm (uniq): Made tail-recursive. Thanks to thi! From a099f10e497a1dfaaa65c168c86f360f595ebcf2 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 16 Aug 2000 22:42:41 +0000 Subject: [PATCH 0153/2047] * optargs.scm (#\&): Emit warning about `#&' being deprecated. --- ice-9/optargs.scm | 3 +++ 1 file changed, 3 insertions(+) diff --git a/ice-9/optargs.scm b/ice-9/optargs.scm index 9824104a3..33304085e 100644 --- a/ice-9/optargs.scm +++ b/ice-9/optargs.scm @@ -199,6 +199,9 @@ ;; "#&optional" instead of "#:optional" (read-hash-extend #\& (lambda (c port) + (display + "WARNING: `#&' is deprecated, use `#:' instead\n" + (current-error-port)) (case (read port) ((optional) #:optional) ((key) #:key) From 6219924c22468dfb7b08c0a3b114fa328ab7c548 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 16 Aug 2000 22:43:03 +0000 Subject: [PATCH 0154/2047] *** empty log message *** --- ice-9/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 2bbed0164..19937e8cb 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2000-08-17 Marius Vollmer + + * optargs.scm (#\&): Emit warning about `#&' being deprecated. + 2000-08-16 Marius Vollmer * optargs.scm: Replaced `#&' reader syntax with keywords. From 53bb55082885bae1770cd4e4268724c7e7200d6e Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Thu, 17 Aug 2000 04:08:31 +0000 Subject: [PATCH 0155/2047] *** empty log message *** --- devel/README | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/devel/README b/devel/README index 6ab6e18e7..7bc502266 100644 --- a/devel/README +++ b/devel/README @@ -2,9 +2,13 @@ Directories: policy Guile policy documents -build information related to the build/installation process +build Build/installation process -translation information related to language traslation +translation Language traslation + +vm Virtual machines + +vm/ior Mikael's ideas on a new type of Scheme interpreter Files: From 2fb8bdabd27f6620f143dc5b9d1b429e4287fe6c Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Thu, 17 Aug 2000 04:10:42 +0000 Subject: [PATCH 0156/2047] Mikael's ideas on a new type of Scheme interpreter --- devel/vm/ior/ior-intro.text | 0 devel/vm/ior/ior.text | 665 ++++++++++++++++++++++++++++++++++++ 2 files changed, 665 insertions(+) create mode 100644 devel/vm/ior/ior-intro.text create mode 100644 devel/vm/ior/ior.text diff --git a/devel/vm/ior/ior-intro.text b/devel/vm/ior/ior-intro.text new file mode 100644 index 000000000..e69de29bb diff --git a/devel/vm/ior/ior.text b/devel/vm/ior/ior.text new file mode 100644 index 000000000..9730de55d --- /dev/null +++ b/devel/vm/ior/ior.text @@ -0,0 +1,665 @@ +*** +*** These notes about the design of a new type of Scheme interpreter +*** "Ior" are cut out from various emails from early spring 2000. +*** +*** MDJ 000817 +*** + +Generally, we should try to make a design which is clean and +minimalistic in as many respects as possible. For example, even if we +need more primitives than those in R5RS internally, I don't think +these should be made available to the user in the core, but rather be +made available *through* libraries (implementation in core, +publication via library). + +The suggested working name for this project is "Ior" (Swedish name for +the donkey in "Winnie the Pooh" :). If, against the odds, we really +would succeed in producing an Ior, and we find it suitable, we could +turn it into a Guile 2.0 (or whatever). (The architecture still +allows for support of the gh interface and uses conservative GC (Hans +Böhm's, in fact).) + + Beware now that I'm just sending over my original letter, which is + just a sketch of the more detailed, but cryptic, design notes I made + originally, which are, in turn, not as detailed as the design has + become now. :) + + Please also excuse the lack of structure. I shouldn't work on this at + all right now. Choose for yourselves if you want to read this + unstructured information or if you want to wait until I've structured + it after end of January. + +But then I actually have to blurt out the basic idea of my +architecture already now. (I had hoped to present you with a proper +and fairly detailed spec, but I won't be able to complete such a spec +quickly.) + + +The basic idea is this: + +* Don't waste time on non-computation! + +Why waste a lot of time on type-checks, unboxing and boxing of data? +Neither of these actions do any computations! + +I'd like both interpreter and compiled code to work directly with data +in raw, native form (integers represented as 32bit longs, inexact +numbers as doubles, short strings as bytes in a word, longer strings +as a normal pointer to malloced memory, bignums are just pointers to a +gmp (GNU MultiPrecision library) object, etc.) + +* Don't we need to dispatch on type to know what to do? + +But don't we need to dispatch on the type in order to know how to +compute with the data? E.g., `display' does entirely different +computations on a and a . ( is an integer +between -2^31 and 2^31-1.) + +The answer is *no*, not in 95% of all cases. The main reason is that +the interpreter does type analysis while converting closures to +bytecode, and knows already when _calling_ `display' what type it's +arguments has. This means that the bytecode compiler can choose a +suitable _version_ of `display' which handles that particular type. + + + +This type analysis is greatly simplified by the fact that just as the +type analysis _results_ in the type of the argument in the call to +`display', and, thus, we can select the correct _version_ of +`display', the closure byte-code itself will only be one _version_ of +the closure with the types of its arguments fixed at the start of the +analysis. + +As you already have understood by now, the basic architecture is that +all procedures are generic functions, and the "versions" I'm speaking +about is a kind of methods. Let's call them "branches" by now. + +For example: + +(define foo + (lambda (x) + ... + (display x) + ...) + +may result in the following two branches: + +1. [-foo] = + (branch ((x )) + ... + ([-display] x) + ...) + +2. [-foo] = + (branch ((x )) + ... + ([-display] x) + ...) + +and a new closure + +(define bar + (lambda (x y) + ... + (foo x) + ...)) + +results in + +[--bar] = + (branch ((x ) (y )) + ... + ([-foo] x) + ...) + +Note how all type dispatch is eliminated in these examples. + +As a further reinforcement to the type analysis, branches will not +only have typed parameters but also have return types. This means +that the type of a branch will look like + + x ... x --> + +In essence, the entire system will be very ML-like internally, and we +can benefit from the research done on ML-compilation. + +However, we now get three major problems to confront: + +1. In the Scheme language not all situations can be completely type + analyzed. + +2. In particular, for some operations, even if the types of the + parameters are well defined, we can't determine the return type + generically. For example, [--+] may have return + type _or_ . + +3. Even if we can do a complete analysis, some closures will generate + a combinatoric explosion of branches. + + +Problem 1: Incomplete analysis + +We introduce a new type . This data type has type and +contents + +struct ior_boxed_t { + ior_type *type; /* pointer to class struct */ + void *data; /* generic field, may also contain immediate objects + */ +} + +For example, a boxed fixnum 4711 has type and contents +{ , 4711 }. The boxed type essentially corresponds to Guile's +SCM type. It's just that the 1 or 3 or 7 or 16-bit type tag has been +replaced with a 32-bit type tag (the pointer to the class structure +describing the type of the object). + +This is more inefficient than the SCM type system, but it's no problem +since it won't be used in 95% of all cases. The big advantage +compared to SCM's type system is that it is so simple and uniform. + +I should note here that while SCM and Guile are centered around the +cell representation and all objects either _are_ cells or have a cell +handle, objects in ior will more look like mallocs. This is the +reason why I planned to start with Böhm's GC which has C pointers as +object handles. But it is of course still possible to use a heap, or, +preferably several heaps for different kinds of objects. (Böhm's GC +has multiple heaps for different sizes of objects.) If we write a +custom GC, we can increase speed further. + + +Problem 3 (yes, I skipped :) Combinatoric explosion + +We simply don't generate all possible branches. In the interpreter we +generate branches "just-too-late" (well, it's normally called "lazy +compilation" or "just-in-time", but if it was "in-time", the procedure +would already be compiled when it was needed, right? :) as when Guile +memoizes or when a Java machine turns byte-codes into machine code, or +as when GOOPS turns methods into cmethods for that matter. + +Have noticed that branches (although still without return type +information) already exist in GOOPS? They are currently called +"cmethods" and are generated on demand from the method code and put +into the GF cache during evaluation of GOOPS code. :-) (I have not +utilized this fully yet. I plan to soon use this method compilation +(into branches) to eliminate almost all type dispatch in calls to +accessors.) + +For the compiler, we use profiling information, just as the modern GCC +scheduler, or else relies on some type analysis (if a procedure says +(+ x y), x is not normally a but rather some subclass of +) and some common sense (it's usually more important to +generate branches than branches). + +The rest of the cases can be handled by -branches. We can, for +example, have a: + +[--bar] = + (branch ((x ) (y )) + ... + ([-foo] x) + ...) + +[-foo] will use an efficient type dispatch mechanism (for +example akin to the GOOPS one) to select the right branch of +`display'. + + +Problem 2: Ambiguous return type + +If the return type of a branch is ambiguous, we simply define the +return type as , and box data at the point in the branch where +it can be decided which type of data we will return. This is how +things can be handled in the general case. However, we might be able +to handle things in a more neat way, at least in some cases: + +During compilation to byte code, we'll probably use an intermediate +representation in continuation passing style. We might even use a +subtype of branches reprented as continuations (not a heavy +representation, as in Guile and SCM, but probably not much more than a +function pointer). This is, for example, one way of handling tail +recursion, especially mutual tail recursion. + +One case where we would like to try really hard not to box data is +when fixnums "overflow into" bignums. + +Let's say that the branch [--bar] contains a form + + (+ x y) + +where the type analyzer knows that x and y are fixnums. We then split +the branch right after the form and let it fork into two possible +continuation branches bar1 and bar2: + +[The following is only pseudo code. It can be made efficient on the C + level. We can also use the asm compiler directive in conditional + compilation for GCC on i386. We could even let autoconf/automake + substitute an architecture specific solution for multiple + architectures, but still support a C level default case.] + + (if (sum-over/underflow? x y) + (bar1 (fixnum->bignum x) (fixnum->bignum y) ...) + (bar2 x y ...)) + +bar1 begins with the evaluation of the form + + ([--+] x y) + +while bar 2 begins with + + ([--+] x y) + +Note that the return type of each of these forms is unambiguous. + + +Now some random points from the design: + +* The basic concept in Ior is the class. A type is a concrete class. + Classes which are subclasses of are concrete, otherwise they + are abstract. + +* A procedure is a collection of methods. Each method can have + arbitrary number of parameters of arbitrary class (not type). + +* The type of a method is the tuple of it's argument classes. + +* The type of a procedure is the set of it's method types. + +But the most important new concept is the branch. +Regard the procedure: + +(define (half x) + (quotient x 2)) + +The procedure half will have the single method + + (method ((x )) + (quotient x 2)) + +When `(half 128)' is called the Ior evaluator will create a new branch +during the actual evaluation. I'm now going to extend the branch +syntax by adding a second list of formals: the continuations of the +branch. + +* The type of a branch is namely the tuple of the tuple of it's + argument types (not classes!) and the tuple of it's continuation + argument types. The branch generated above will be: + + (branch ((x ) ((c )) + (c (quotient x 2))) + + If the method + + (method ((x ) (y )) + (quotient (+ x 1) y)) + + is called with arguments 1 and 2 it results in the branch + + (branch ((x ) (y )) ((c1 ) (c2 )) + (quotient (+ x 1 c3) 2)) + + where c3 is: + + (branch ((x ) (y )) ((c )) + (quotient (+ (fixnum->bignum x) 1) 2) + +The generated branches are stored in a cache in the procedure object. + + +But wait a minute! What about variables and data structures? + +In essence, what we do is that we fork up all data paths so that they +can be typed: We put the type tags on the _data paths_ instead of on +the data itself. You can look upon the "branches" as tubes of +information where the type tag is attached to the tube instead of on +what passes through it. + +Variables and data structures are part of the "tubes", so they need to +be typed. For example, the generic pair looks like: + +(define-class () + car-type + car + cdr-type + cdr) + +But note that since car and cdr are generic procedures, we can let +more efficient pairs exist in parallel, like + +(define-class () + (car (class )) + (cdr (class ))) + +Note that instances of this last type only takes two words of memory! +They are easy to use too. We can't use `cons' or `list' to create +them, since these procedures can't assume immutability, but we don't +need to specify the type in our program. Something like + + (const-cons 1 x) + +where x is in the data flow path tagged as , or + + (const-list 1 2 3) + + +Some further notes: + +* The concepts module and instance are the same thing. Using other + modules means 1. creating a new module class which inherits the + classes of the used modules and 2. instantiating it. + +* Module definitions and class definitions are equivalent but + different syntactic sugar adapted for each kind of use. + +* (define x 1) means: create an instance variable which is itself a + subclass of with initial value 1 (which is an instance of + ). + + +The interpreter is a mixture between a stack machine and a register +machine. The evaluator looks like this... :) + + /* the interpreter! */ + if (!setjmp (ior_context->exit_buf)) +#ifndef i386_GCC + while (1) +#endif + (*ior_continue) (IOR_MICRO_OP_ARGS); + +The branches are represented as an array of pointers to micro +operations. In essence, the evaluator doesn't exist in itself, but is +folded out over the entire implementation. This allows for an extreme +form of modularity! + +The i386_GCC is a machine specific optimization which avoids all +unnecessary popping and pushing of the CPU stack (which is different +from the Ior data stack). + +The execution environment consists of + +* a continue register similar to the program counter in the CPU +* a data stack (where micro operation arguments and results are stored) +* a linked chain of environment frames (but look at exception below!) +* a dynamic context + +I've written a small baby Ior which uses Guile's infrastructure. +Here's the context from that baby Ior: + +typedef struct ior_context_t { + ior_data_t *env; /* rest of environment frames */ + ior_cont_t save_continue; /* saves or represents continuation */ + ior_data_t *save_env; /* saves or represents environment */ + ior_data_t *fluids; /* array of fluids (use GC_malloc!) */ + int n_fluids; + int fluids_size; + /* dynwind chain is stored directly in the environment, not in context */ + jmp_buf exit_buf; + IOR_SCM guile_protected; /* temporary */ +} ior_context_t; + +There's an important exception regarding the lowest environment +frame. That frame isn't stored in a separate block on the heap, but +on Ior's data stack. Frames are copied out onto the heap when +necessary (for example when closures "escape"). + + +Now a concrete example: + +Look at: + +(define sum + (lambda (from to res) + (if (= from to) + res + (sum (+ 1 from) to (+ from res))))) + +This can be rewritten into CPS (which captures a lot of what happens +during flow analysis): + +(define sum + (lambda (from to res c1) + (let ((c2 (lambda (limit?) + (let ((c3 (lambda () + (c1 res))) + (c4 (lambda () + (let ((c5 (lambda (from+1) + (let ((c6 (lambda (from+res) + (sum from+1 to from+res c1)))) + (_+ from res c6))))) + (_+ 1 from c5))))) + (_if limit? c3 c4))))) + (_= from to c2)))) + +Finally, after branch expansion, some optimization, code generation, +and some optimization again, we end up with the byte code for the two +branches (here marked by labels `sum' and `sumbig'): + + c5 + (ref -3) + (shift -1) + (+ c4big) + ;; c4 + (shift -2) + (+ 1 sumbig) + ;; c6 + sum + (shift 3) + (ref2 -3) + ;; c2 + (if!= c5) + ;; c3 + (ref -1) + ;; c1 + (end) + + c5big + (ref -3) + (shift -1) + (+ ) + c4big + (shift -2) + (+ 1) + ;; c6 + sumbig + (shift 3) + (ref2 -3) + ;; c2 + (= ) + (if! c5big) + ;; c3 + (ref -1) + ;; c1 + (end) + +Let's take a closer look upon the (+ 1 sumbig) micro +operation. The generated assembler from the Ior C source + machine +specific optimizations for i386_GCC looks like this (with some rubbish +deleted): + +ior_int_int_sum_intbig: + movl 4(%ebx),%eax ; fetch arg 2 + addl (%ebx),%eax ; fetch arg 1 and do the work! + jo ior_big_sum_int_int ; dispatch to other branch on overflow + movl %eax,(%ebx) ; store result in first environment frame + addl $8,%esi ; increment program counter + jmp (%esi) ; execute next opcode + +ior_big_sum_int_int: + +To clearify: This is output from the C compiler. I added the comments +afterwards. + +The source currently looks like this: + +IOR_MICRO_BRANCH_2_2 ("+", int, big, sum, int, int, 1, 0) +{ + int res = IOR_ARG (int, 0) + IOR_ARG (int, 1); + IOR_JUMP_OVERFLOW (res, ior_big_sum_int_int); + IOR_NEXT2 (z); +} + +where the macros allow for different definitions depending on if we +want to play pure ANSI or optimize for a certain machine/compiler. + +The plan is actually to write all source in the Ior language and write +Ior code to translate the core code into bootstrapping C code. + +Please note that if i386_GCC isn't defined, we run plain portable ANSI C. + + +Just one further note: + +In Ior, there are three modes of evaluation + +1. evaluating and type analyzing (these go in parallel) +2. code generation +3. executing byte codes + +It is mode 3 which is really fast in Ior. + +You can look upon your program as a web of branch segments where one +branch segment can be generated from fragments of many closures. Mode +switches doesn't occur at the procedure borders, but at "growth +points". I don't have time to define them here, but they are based +upon the idea that the continuation together with the type signature +of the data flow path is unique. + +We normally run in mode 3. When we come to a source growth point +(essentially an apply instruction) for uncompiled code we "dive out" +of mode 3 into mode 1 which starts to eval/analyze code until we come +to a "sink". When we reach the "sink", we have enough information +about the data path to do code generation, so we backtrack to the +source growth point and grow the branch between source and sink. +Finally, we "dive into" mode 3! + +So, code generation doesn't respect procedure borders. We instead get +a very neat kind of inlining, which, e.g., means that it is OK to use +closures instead of macros in many cases. +---------------------------------------------------------------------- +Ior and module system +===================== + +How, exactly, should the module system of Ior look like? + +There is this general issue of whether to have a single-dispatch or +multi-dispatch system. Personally, I see that Scheme already use +multi-dispatch. Compare (+ 1.0 2) and (+ 1 2.0). + +As you've seen if you've read the notes about Ior design, efficiency +is not an issue here, since almost all dispatch will be eliminated +anyway. + +Also, note an interesting thing: GOOPS actually has a special, +implicit, argument to all of it's methods: the lexical environment. +It would be very ugly to add a second, special, argument to this. + +Of course, the theoreticians have already recognised this, and in many +systems, the implicit argument (the object) and the environment for +the method is the same thing. + +I think we should especially take impressions from Matthias Blume's +module/object system. + +The idea, now, for Ior (remember that everything about Ior is +negotiable between us) is that a module is a type, as well as an +instance of that type. The idea is that we basically keep the GOOPS +style of methods, with the implicit argument being the module object +(or some other lexical environment, in a chain with the module as +root). + +Let's say now that module C uses modules A and B. Modules A and B +both exports the procedure `foo'. But A:foo and B:foo as different +sets of methods. + +What does this mean? Well, it obviously means that the procedure +`foo' in module C is a subtype of A:foo and B:foo. Note how this is +similar in structure to slot inheritance: When class C is created with +superclasses A and B, the properties of a slot in C are created +through slot inheritance. One way of interpreting variable foo in +module A is as a slot with init value foo. Through the MOP, we can +specify that procedure slot inheritance in a module class implies +creation of new init values through inheritance. + +This may look like a kludge, and perhaps it is, and, sure, we are not +going to accept any kludges in Ior. But, it might actually not be a +kludge... + +I think it is commonly accepted by computer scientists that a module, +and/or at least a module interface is a type. Again, this type can be +seen as the set of types of the functions in the interface. The types +of our procedures are the set of branch types the provide. It is then +natural that a module using two other modules create new procedure +types by folding. + +This thing would become less cloudy (yes, this is a cloudy part of my +reasoning; I meant previously that the interpreter itself is now +clear) if module interfaces were required to be explicitly types. + +Actually, this would fit much better together with the rest of Ior's +design. On one hand, we might be free to introduce such a restriction +(compiler writers would applaud it), since R5RS hasn't specified any +module system. On the other hand, it might be strange to require +explicit typing when Scheme is fundamentally implicitly types... + +We also have to consider that a module has an "inward" face, which is +one type, and possibly many "outward" faces, which are different +types. (Compare the idea of "interfaces" in Scheme48.) + +It thus, seems that, while a module can truly be an Ior class, the +reverse should probably not hold in the general case... + +Unless + + instance <-> module proper + class of the instance <-> "inward interface" + superclasses <-> "outward interfaces + inward uses" + +...hmm, is this possible to reconcile with Rees' object system? + +Please think about these issues. We should try to end up with a +beautiful and consistent object/module system. + +---------------------------------------------------------------------- + +Here's a difficult problem in Ior's design: + +Let's say that we have a mutable data structure, like an ordinary +list. Since, in Ior, the type tag (which is really a pointer to a +class structure) is stored separately from the data, it is thinkable +that another thread modifies the location in the list between when our +thread reads the type tag and when it reads the data. + +The reading of type and data must be made atomic in some way. +Probably, some kind of locking of the heap is required. It's just +that it may cause a lot of overhead to look the heap at every *read* +from a mutable data structure. + +Look how much trouble those set!-operations cause! Not only does it +force us to store type tags for each car and cdr in the list, but it +also forces a lot of explicit dispatch to be done, and causes troubles +in a threaded system... + +---------------------------------------------------------------------- + +Jim Blandy writes: + +> We also should try to make less work for the GC, by avoiding consing +> up local environments until they're closed over. + +Did the texts which I sent to you talk about Ior's solution? + +It basically is: Use *two* environment "arguments" to the evaluator +(in Ior, they aren't arguments but registers): + +* One argument is a pointer to the "top" of an environment stack. + This is used in the "inner loop" for very efficient access to + in-between results. The "top" segment of the environment stack is + also regarded as the first environment frame in the lexical + environment. ("top" is bottom on a stack which grows downwards) + +* The other argument points to a structure holding the evaluation + context. In this context, there is a pointer to the chain of the + rest of the environment frames. Note that since frames are just + blocks of SCM values, you can very efficiently "release" a frame + into the heap by block copying it (remember that Ior uses Boehms GC; + this is how we allocate the block). From ee4413093e7c66c960f78c3d5aa03d32d08675e3 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Thu, 17 Aug 2000 20:37:55 +0000 Subject: [PATCH 0157/2047] * tags.h: (SCM_GCTYPE16, SCM_GCCDR, SCM_GC[8]MARKP, SCM_SETGC[8]MARK, SCM_CLRGC[8]MARK): moved from here into gc.h. some (most) of these are probably going to be deprecated. --- libguile/tags.h | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/libguile/tags.h b/libguile/tags.h index ed1f6a71a..13901548d 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -330,20 +330,6 @@ typedef long scm_bits_t; #define SCM_TYP16(x) (0xffff & SCM_CELL_TYPE (x)) #define SCM_TYP16S(x) (0xfeff & SCM_CELL_TYPE (x)) -#define SCM_GCTYP16(x) (0xff7f & SCM_CELL_TYPE (x)) - - - -/* Testing and Changing GC Marks in Various Standard Positions - */ -#define SCM_GCCDR(x) SCM_PACK(~1L & SCM_UNPACK (SCM_CDR (x))) -#define SCM_GCMARKP(x) (1 & SCM_UNPACK (SCM_CDR (x))) -#define SCM_GC8MARKP(x) (0x80 & SCM_CELL_TYPE (x)) -#define SCM_SETGCMARK(x) SCM_SETOR_CDR (x, 1) -#define SCM_CLRGCMARK(x) SCM_SETAND_CDR (x, ~1L) -#define SCM_SETGC8MARK(x) SCM_SETOR_CAR (x, 0x80) -#define SCM_CLRGC8MARK(x) SCM_SETAND_CAR (x, ~0x80L) - From e618c9a3c88f9aba8b176f4481b215ad87944f8d Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Thu, 17 Aug 2000 20:38:23 +0000 Subject: [PATCH 0158/2047] * gc.h (SCM_MARKEDP): simplified, there are no different mark bit locations anymore. (SCM_GC_CARD_*, SCM_C_BVEC_*): lots of new macros to deal with cards and bvecs (bit-vectors). --- libguile/gc.h | 136 +++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 130 insertions(+), 6 deletions(-) diff --git a/libguile/gc.h b/libguile/gc.h index 5af83869d..446e15e00 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -71,7 +71,7 @@ typedef scm_cell * SCM_CELLPTR; * within the word. The following macros deal with this by storing the * native Cray pointers like the ones that looks like scm expects. This * is done for any pointers that might appear in the car of a scm_cell, - * pointers to scm_vector elts, functions, &c are not munged. + * pointers to scm_vector elts, functions, &c are not munged. */ #ifdef _UNICOS # define SCM2PTR(x) ((SCM_CELLPTR) (SCM_UNPACK (x) >> 3)) @@ -81,6 +81,134 @@ typedef scm_cell * SCM_CELLPTR; # define PTR2SCM(x) (SCM_PACK ((scm_bits_t) (x))) #endif /* def _UNICOS */ +/* This mess was copied from the GNU getpagesize.h. */ + +#ifndef HAVE_GETPAGESIZE + +/* Assume that all systems that can run configure have sys/param.h. */ +# ifndef HAVE_SYS_PARAM_H +# define HAVE_SYS_PARAM_H 1 +# endif + +# ifdef _SC_PAGESIZE +# define getpagesize() sysconf(_SC_PAGESIZE) +# else /* no _SC_PAGESIZE */ +# ifdef HAVE_SYS_PARAM_H +# include +# ifdef EXEC_PAGESIZE +# define getpagesize() EXEC_PAGESIZE +# else /* no EXEC_PAGESIZE */ +# ifdef NBPG +# define getpagesize() NBPG * CLSIZE +# ifndef CLSIZE +# define CLSIZE 1 +# endif /* no CLSIZE */ +# else /* no NBPG */ +# ifdef NBPC +# define getpagesize() NBPC +# else /* no NBPC */ +# ifdef PAGESIZE +# define getpagesize() PAGESIZE +# endif /* PAGESIZE */ +# endif /* no NBPC */ +# endif /* no NBPG */ +# endif /* no EXEC_PAGESIZE */ +# else /* no HAVE_SYS_PARAM_H */ +# define getpagesize() 8192 /* punt totally */ +# endif /* no HAVE_SYS_PARAM_H */ +# endif /* no _SC_PAGESIZE */ + +#endif /* no HAVE_GETPAGESIZE */ + +#define SCM_GC_CARD_N_HEADER_CELLS 1 +#define SCM_GC_CARD_N_CELLS (8 * sizeof (scm_cell) * 4) + +#define SCM_GC_CARD_SIZE (SCM_GC_CARD_N_CELLS * sizeof (scm_cell)) +#define SCM_GC_CARD_N_DATA_CELLS (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS) + +#define SCM_GC_CARD_BVEC_SIZE_IN_LIMBS \ + ((SCM_GC_CARD_N_CELLS + SCM_C_BVEC_LIMB_BITS - 1) / SCM_C_BVEC_LIMB_BITS) + +#define SCM_GC_IN_CARD_HEADERP(x) \ + SCM_PTR_LT ((scm_cell *) (x), SCM_GC_CELL_CARD (x) + SCM_GC_CARD_N_HEADER_CELLS) + +#define SCM_GC_CARD_BVEC(card) ((scm_c_bvec_limb_t *) ((card)->word_0)) + +#define SCM_GC_GET_CARD_FLAGS(card) ((long) ((card)->word_1)) +#define SCM_GC_SET_CARD_FLAGS(card, flags) (SCM_GC_GET_CARD_FLAGS (card) = (flags)) +#define SCM_GC_CLR_CARD_FLAGS(card) (SCM_GC_GET_CARD_FLAGS (card) = 0L) + +#define SCM_GC_GET_CARD_FLAG(card, shift) (SCM_GC_GET_CARD_FLAGS (card) & (1L << (shift))) +#define SCM_GC_SET_CARD_FLAG(card, shift) (SCM_GC_GET_CARD_FLAGS (card) |= (1L << (shift))) +#define SCM_GC_CLR_CARD_FLAG(card, shift) (SCM_GC_GET_CARD_FLAGS (card) &= ~(1L << (shift))) + +#define SCM_GC_CARDF_DOUBLECELL 0 + +#define SCM_GC_CARD_DOUBLECELLP(card) SCM_GC_GET_CARD_FLAG (card, SCM_GC_CARDF_DOUBLECELL) +#define SCM_GC_SET_CARD_DOUBLECELL(card) SCM_GC_SET_CARD_FLAG (card, SCM_GC_CARDF_DOUBLECELL) + +/* card addressing. for efficiency, cards are *always* aligned to + SCM_GC_CARD_SIZE. */ + +#define SCM_GC_CARD_SIZE_MASK (SCM_GC_CARD_SIZE - 1) +#define SCM_GC_CARD_ADDR_MASK (~SCM_GC_CARD_SIZE_MASK) + +#define SCM_GC_CELL_CARD(x) ((SCM_CELLPTR) ((long) (x) & SCM_GC_CARD_ADDR_MASK)) +#define SCM_GC_CELL_SPAN(x) ((SCM_GC_CARD_DOUBLECELLP (SCM_GC_CELL_CARD (x))) ? 2 : 1) +#define SCM_GC_CELL_OFFSET(x) (((long) (x) & SCM_GC_CARD_SIZE_MASK) >> SCM_CELL_SIZE_SHIFT) +#define SCM_GC_CELL_BVEC(x) SCM_GC_CARD_BVEC (SCM_GC_CELL_CARD (x)) +#define SCM_GC_CELL_GET_BIT(x) SCM_C_BVEC_GET (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x)) +#define SCM_GC_CELL_SET_BIT(x) SCM_C_BVEC_SET (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x)) +#define SCM_GC_CELL_CLR_BIT(x) SCM_C_BVEC_CLR (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x)) + +#define SCM_GC_CARD_UP(x) SCM_GC_CELL_CARD ((char *) (x) + SCM_GC_CARD_SIZE - 1) +#define SCM_GC_CARD_DOWN SCM_GC_CELL_CARD + +/* low level bit banging aids */ + +typedef unsigned long scm_c_bvec_limb_t; + +#if (SIZEOF_LONG == 8) +# define SCM_C_BVEC_LIMB_BITS 64 +# define SCM_C_BVEC_OFFSET_SHIFT 6 +# define SCM_C_BVEC_POS_MASK 63 +# define SCM_CELL_SIZE_SHIFT 4 +#else +# define SCM_C_BVEC_LIMB_BITS 32 +# define SCM_C_BVEC_OFFSET_SHIFT 5 +# define SCM_C_BVEC_POS_MASK 31 +# define SCM_CELL_SIZE_SHIFT 3 +#endif + +#define SCM_C_BVEC_OFFSET(pos) (pos >> SCM_C_BVEC_OFFSET_SHIFT) + +#define SCM_C_BVEC_GET(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] & (1L << (pos & SCM_C_BVEC_POS_MASK))) +#define SCM_C_BVEC_SET(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] |= (1L << (pos & SCM_C_BVEC_POS_MASK))) +#define SCM_C_BVEC_CLR(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] &= ~(1L << (pos & SCM_C_BVEC_POS_MASK))) + +#define SCM_C_BVEC_BITS2BYTES(bits) \ + (sizeof (scm_c_bvec_limb_t) * ((((bits) & SCM_C_BVEC_POS_MASK) ? 1L : 0L) + SCM_C_BVEC_OFFSET (bits))) + +#define SCM_C_BVEC_SET_BYTES(bvec, bytes) (memset (bvec, 0xff, bytes)) +#define SCM_C_BVEC_SET_ALL_BITS(bvec, bits) SCM_C_BVEC_SET_BYTES (bvec, SCM_C_BVEC_BITS2BYTES (bits)) + +#define SCM_C_BVEC_CLR_BYTES(bvec, bytes) (memset (bvec, 0, bytes)) +#define SCM_C_BVEC_CLR_ALL_BITS(bvec, bits) SCM_C_BVEC_CLR_BYTES (bvec, SCM_C_BVEC_BITS2BYTES (bits)) + +/* testing and changing GC marks */ + +#define SCM_GCMARKP(x) SCM_GC_CELL_GET_BIT (x) +#define SCM_SETGCMARK(x) SCM_GC_CELL_SET_BIT (x) +#define SCM_CLRGCMARK(x) SCM_GC_CELL_CLR_BIT (x) + +/* compatibility stuff: */ + +#define SCM_GC8MARKP(x) SCM_GCMARKP (x) +#define SCM_SETGC8MARK(x) SCM_SETGCMARK (x) +#define SCM_CLRGC8MARK(x) SCM_CLRGCMARK (x) + +#define SCM_GCTYP16(x) SCM_TYP16 (x) +#define SCM_GCCDR(x) SCM_CDR (x) /* Low level cell data accessing macros: */ @@ -203,11 +331,7 @@ typedef scm_cell * SCM_CELLPTR; #define SCM_FREEP(x) (SCM_FREE_CELL_P (x)) #define SCM_NFREEP(x) (!SCM_FREEP (x)) -/* 1. This shouldn't be used on immediates. - 2. It thinks that subrs are always unmarked (harmless). */ -#define SCM_MARKEDP(x) ((SCM_CELL_TYPE (x) & 5) == 5 \ - ? SCM_GC8MARKP (x) \ - : SCM_GCMARKP (x)) +#define SCM_MARKEDP SCM_GCMARKP #define SCM_NMARKEDP(x) (!SCM_MARKEDP (x)) extern struct scm_heap_seg_data_t *scm_heap_table; From d6884e6373065d007252ef4556937396da0bd849 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Thu, 17 Aug 2000 20:38:44 +0000 Subject: [PATCH 0159/2047] * gc.c: (scm_default_init_heap_size_*): defined to take cards into account, but keeping more or less the same values as previously. added some simple helper macros. (CLUSTER_SIZE_IN_BYTES, ALIGNMENT_SLACK): defined to take cards into account. (BVEC_*, scm_mark_space_t, current_mark_space, mark_space_ptr, current_mark_space_offset, mark_space_head, get_bvec, clear_mark_space): new functions and supporting variables, types and macros that implement mark space management. (scm_igc): clear the mark space (all of it) before beginning the mark phase. (scm_gc_mark): changed the tests for rogue cells, much simplified throughout (no different mark bit locations to worry about now). (scm_mark_locations): don't consider card header cells. (scm_cellp): ditto. (scm_gc_sweep): simplified. (init_heap_seg): changed to take cards into account. --- libguile/gc.c | 479 +++++++++++++++++++++++++++----------------------- 1 file changed, 261 insertions(+), 218 deletions(-) diff --git a/libguile/gc.c b/libguile/gc.c index 74c9b622d..b091f0178 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -197,20 +197,25 @@ SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0, * large heaps, especially if code behaviour is varying its * maximum consumption between different freelists. */ -int scm_default_init_heap_size_1 = (45000L * sizeof (scm_cell)); -int scm_default_min_yield_1 = 40; -#define SCM_CLUSTER_SIZE_1 2000L -int scm_default_init_heap_size_2 = (2500L * 2 * sizeof (scm_cell)); +#define SCM_DATA_CELLS2CARDS(n) (((n) + SCM_GC_CARD_N_DATA_CELLS - 1) / SCM_GC_CARD_N_DATA_CELLS) +#define SCM_CARDS_PER_CLUSTER SCM_DATA_CELLS2CARDS (2000L) +#define SCM_CLUSTER_SIZE_1 (SCM_CARDS_PER_CLUSTER * SCM_GC_CARD_N_DATA_CELLS) +int scm_default_init_heap_size_1 = (((SCM_DATA_CELLS2CARDS (45000L) + SCM_CARDS_PER_CLUSTER - 1) + / SCM_CARDS_PER_CLUSTER) * SCM_GC_CARD_SIZE); +int scm_default_min_yield_1 = 40; + +#define SCM_CLUSTER_SIZE_2 (SCM_CARDS_PER_CLUSTER * (SCM_GC_CARD_N_DATA_CELLS / 2)) +int scm_default_init_heap_size_2 = (((SCM_DATA_CELLS2CARDS (2500L * 2) + SCM_CARDS_PER_CLUSTER - 1) + / SCM_CARDS_PER_CLUSTER) * SCM_GC_CARD_SIZE); /* The following value may seem large, but note that if we get to GC at * all, this means that we have a numerically intensive application */ int scm_default_min_yield_2 = 40; -#define SCM_CLUSTER_SIZE_2 1000L int scm_default_max_segment_size = 2097000L;/* a little less (adm) than 2 Mb */ -#define SCM_MIN_HEAP_SEG_SIZE (2048L * sizeof (scm_cell)) +#define SCM_MIN_HEAP_SEG_SIZE (8 * SCM_GC_CARD_SIZE) #ifdef _QC # define SCM_HEAP_SEG_SIZE 32768L #else @@ -225,8 +230,8 @@ int scm_default_max_segment_size = 2097000L;/* a little less (adm) than 2 Mb */ #define SCM_INIT_MALLOC_LIMIT 100000 #define SCM_MTRIGGER_HYSTERESIS (SCM_INIT_MALLOC_LIMIT/10) -/* CELL_UP and CELL_DN are used by scm_init_heap_seg to find scm_cell aligned inner - bounds for allocated storage */ +/* CELL_UP and CELL_DN are used by scm_init_heap_seg to find (scm_cell * span) + aligned inner bounds for allocated storage */ #ifdef PROT386 /*in 386 protected mode we must only adjust the offset */ @@ -241,12 +246,10 @@ int scm_default_max_segment_size = 2097000L;/* a little less (adm) than 2 Mb */ # define CELL_DN(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & (long)(p)) # endif /* UNICOS */ #endif /* PROT386 */ -#define CLUSTER_SIZE_IN_BYTES(freelist) ((freelist)->cluster_size * (freelist)->span * sizeof(scm_cell)) -#define ALIGNMENT_SLACK(freelist) (sizeof (scm_cell) * (freelist)->span - 1) -#define SCM_HEAP_SIZE \ - (scm_master_freelist.heap_size + scm_master_freelist2.heap_size) -#define SCM_MAX(A, B) ((A) > (B) ? (A) : (B)) +#define ALIGNMENT_SLACK(freelist) (SCM_GC_CARD_SIZE - 1) +#define CLUSTER_SIZE_IN_BYTES(freelist) \ + (((freelist)->cluster_size / (SCM_GC_CARD_N_DATA_CELLS / (freelist)->span)) * SCM_GC_CARD_SIZE) /* scm_freelists @@ -301,7 +304,6 @@ scm_freelist_t scm_master_freelist2 = { */ unsigned long scm_mtrigger; - /* scm_gc_heap_lock * If set, don't expand the heap. Set only during gc, during which no allocation * is supposed to take place anyway. @@ -375,6 +377,82 @@ typedef enum { return_on_error, abort_on_error } policy_on_error; static void alloc_some_heap (scm_freelist_t *, policy_on_error); +#define SCM_HEAP_SIZE \ + (scm_master_freelist.heap_size + scm_master_freelist2.heap_size) +#define SCM_MAX(A, B) ((A) > (B) ? (A) : (B)) + +#define BVEC_GROW_SIZE 256 +#define BVEC_GROW_SIZE_IN_LIMBS (SCM_GC_CARD_BVEC_SIZE_IN_LIMBS * BVEC_GROW_SIZE) +#define BVEC_GROW_SIZE_IN_BYTES (BVEC_GROW_SIZE_IN_LIMBS * sizeof (scm_c_bvec_limb_t)) + +/* mark space allocation */ + +typedef struct scm_mark_space_t +{ + scm_c_bvec_limb_t *bvec_space; + struct scm_mark_space_t *next; +} scm_mark_space_t; + +static scm_mark_space_t *current_mark_space; +static scm_mark_space_t **mark_space_ptr; +static int current_mark_space_offset; +static scm_mark_space_t *mark_space_head; + +static scm_c_bvec_limb_t * +get_bvec () +{ + scm_c_bvec_limb_t *res; + + if (!current_mark_space) + { + SCM_SYSCALL (current_mark_space = (scm_mark_space_t *) malloc (sizeof (scm_mark_space_t))); + if (!current_mark_space) + scm_wta (SCM_UNDEFINED, "could not grow", "heap"); + + current_mark_space->bvec_space = NULL; + current_mark_space->next = NULL; + + *mark_space_ptr = current_mark_space; + mark_space_ptr = &(current_mark_space->next); + + return get_bvec (); + } + + if (!(current_mark_space->bvec_space)) + { + SCM_SYSCALL (current_mark_space->bvec_space = + (scm_c_bvec_limb_t *) calloc (BVEC_GROW_SIZE_IN_BYTES, 1)); + if (!(current_mark_space->bvec_space)) + scm_wta (SCM_UNDEFINED, "could not grow", "heap"); + + current_mark_space_offset = 0; + + return get_bvec (); + } + + if (current_mark_space_offset == BVEC_GROW_SIZE_IN_LIMBS) + { + current_mark_space = NULL; + + return get_bvec (); + } + + res = current_mark_space->bvec_space + current_mark_space_offset; + current_mark_space_offset += SCM_GC_CARD_BVEC_SIZE_IN_LIMBS; + + return res; +} + +static void +clear_mark_space () +{ + scm_mark_space_t *ms; + + for (ms = mark_space_head; ms; ms = ms->next) + memset (ms->bvec_space, 0, BVEC_GROW_SIZE_IN_BYTES); +} + + /* Debugging functions. */ @@ -538,8 +616,6 @@ scm_check_freelist (SCM freelist) } } -static int scm_debug_check_freelist = 0; - SCM_DEFINE (scm_gc_set_debug_check_freelist_x, "gc-set-debug-check-freelist!", 1, 0, 0, (SCM flag), "If FLAG is #t, check the freelist for consistency on each cell allocation.\n" @@ -547,6 +623,8 @@ SCM_DEFINE (scm_gc_set_debug_check_freelist_x, "gc-set-debug-check-freelist!", 1 "compile-time flag was selected.\n") #define FUNC_NAME s_scm_gc_set_debug_check_freelist_x { + /* [cmm] I did a double-take when I read this code the first time. + well, FWIW. */ SCM_VALIDATE_BOOL_COPY (1, flag, scm_debug_check_freelist); return SCM_UNSPECIFIED; } @@ -612,6 +690,7 @@ scm_debug_newcell2 (void) static unsigned long master_cells_allocated (scm_freelist_t *master) { + /* the '- 1' below is to ignore the cluster spine cells. */ int objects = master->clusters_allocated * (master->cluster_size - 1); if (SCM_NULLP (master->clusters)) objects -= master->left_to_collect; @@ -849,6 +928,11 @@ scm_gc_for_newcell (scm_freelist_t *master, SCM *freelist) ++master->clusters_allocated; } while (SCM_NULLP (cell)); + +#ifdef GUILE_DEBUG_FREELIST + scm_check_freelist (cell); +#endif + --scm_ints_disabled; *freelist = SCM_FREE_CELL_CDR (cell); SCM_SET_FREE_CELL_TYPE (cell, scm_tc16_allocated); @@ -940,6 +1024,8 @@ scm_igc (const char *what) scm_c_hook_run (&scm_before_mark_c_hook, 0); + clear_mark_space (); + #ifndef USE_THREADS /* Protect from the C stack. This must be the first marking @@ -1036,37 +1122,37 @@ gc_mark_nimp: if (!SCM_CELLP (ptr)) SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL); +#if (defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)) + + if (SCM_GC_IN_CARD_HEADERP (SCM2PTR (ptr))) + scm_wta (ptr, "rogue pointer in heap", NULL); + +#endif + + if (SCM_GCMARKP (ptr)) + return; + + SCM_SETGCMARK (ptr); + switch (SCM_TYP7 (ptr)) { case scm_tcs_cons_nimcar: - if (SCM_GCMARKP (ptr)) - break; - SCM_SETGCMARK (ptr); - if (SCM_IMP (SCM_CDR (ptr))) /* SCM_IMP works even with a GC mark */ + if (SCM_IMP (SCM_CDR (ptr))) { ptr = SCM_CAR (ptr); goto gc_mark_nimp; } scm_gc_mark (SCM_CAR (ptr)); - ptr = SCM_GCCDR (ptr); + ptr = SCM_CDR (ptr); goto gc_mark_nimp; case scm_tcs_cons_imcar: - if (SCM_GCMARKP (ptr)) - break; - SCM_SETGCMARK (ptr); - ptr = SCM_GCCDR (ptr); + ptr = SCM_CDR (ptr); goto gc_mark_loop; case scm_tc7_pws: - if (SCM_GCMARKP (ptr)) - break; - SCM_SETGCMARK (ptr); scm_gc_mark (SCM_CELL_OBJECT_2 (ptr)); - ptr = SCM_GCCDR (ptr); + ptr = SCM_CDR (ptr); goto gc_mark_loop; case scm_tcs_cons_gloc: - if (SCM_GCMARKP (ptr)) - break; - SCM_SETGCMARK (ptr); { /* Dirk:FIXME:: The following code is super ugly: ptr may be a struct * or a gloc. If it is a gloc, the cell word #0 of ptr is a pointer @@ -1079,69 +1165,61 @@ gc_mark_nimp: scm_bits_t * vtable_data = (scm_bits_t *) word0; /* access as struct */ if (vtable_data [scm_vtable_index_vcell] != 0) { - /* ptr is a gloc */ - SCM gloc_car = SCM_PACK (word0); - scm_gc_mark (gloc_car); - ptr = SCM_GCCDR (ptr); - goto gc_mark_loop; - } - else - { - /* ptr is a struct */ - SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]); - int len = SCM_LENGTH (layout); - char * fields_desc = SCM_CHARS (layout); - /* We're using SCM_GCCDR here like STRUCT_DATA, except - that it removes the mark */ - scm_bits_t * struct_data = (scm_bits_t *) SCM_UNPACK (SCM_GCCDR (ptr)); - - if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) - { - scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_procedure])); - scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_setter])); - } - if (len) - { - int x; - - for (x = 0; x < len - 2; x += 2, ++struct_data) - if (fields_desc[x] == 'p') - scm_gc_mark (SCM_PACK (*struct_data)); - if (fields_desc[x] == 'p') - { - if (SCM_LAYOUT_TAILP (fields_desc[x + 1])) - for (x = *struct_data; x; --x) - scm_gc_mark (SCM_PACK (*++struct_data)); - else - scm_gc_mark (SCM_PACK (*struct_data)); - } - } - /* mark vtable */ - ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]); - goto gc_mark_loop; + /* ptr is a gloc */ + SCM gloc_car = SCM_PACK (word0); + scm_gc_mark (gloc_car); + ptr = SCM_CDR (ptr); + goto gc_mark_loop; + } + else + { + /* ptr is a struct */ + SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]); + int len = SCM_LENGTH (layout); + char * fields_desc = SCM_CHARS (layout); + scm_bits_t * struct_data = (scm_bits_t *) SCM_STRUCT_DATA (ptr); + + if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) + { + scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_procedure])); + scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_setter])); + } + if (len) + { + int x; + + for (x = 0; x < len - 2; x += 2, ++struct_data) + if (fields_desc[x] == 'p') + scm_gc_mark (SCM_PACK (*struct_data)); + if (fields_desc[x] == 'p') + { + if (SCM_LAYOUT_TAILP (fields_desc[x + 1])) + for (x = *struct_data; x; --x) + scm_gc_mark (SCM_PACK (*++struct_data)); + else + scm_gc_mark (SCM_PACK (*struct_data)); + } + } + /* mark vtable */ + ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]); + goto gc_mark_loop; } } break; case scm_tcs_closures: - if (SCM_GCMARKP (ptr)) - break; - SCM_SETGCMARK (ptr); if (SCM_IMP (SCM_CDR (ptr))) { ptr = SCM_CLOSCAR (ptr); goto gc_mark_nimp; } scm_gc_mark (SCM_CLOSCAR (ptr)); - ptr = SCM_GCCDR (ptr); + ptr = SCM_CDR (ptr); goto gc_mark_nimp; case scm_tc7_vector: case scm_tc7_lvector: #ifdef CCLO case scm_tc7_cclo: #endif - if (SCM_GC8MARKP (ptr)) - break; - SCM_SETGC8MARK (ptr); i = SCM_LENGTH (ptr); if (i == 0) break; @@ -1151,9 +1229,6 @@ gc_mark_nimp: ptr = SCM_VELTS (ptr)[0]; goto gc_mark_loop; case scm_tc7_contin: - if SCM_GC8MARKP - (ptr) break; - SCM_SETGC8MARK (ptr); if (SCM_VELTS (ptr)) scm_mark_locations (SCM_VELTS_AS_STACKITEMS (ptr), (scm_sizet) @@ -1176,22 +1251,15 @@ gc_mark_nimp: #endif #endif case scm_tc7_string: - SCM_SETGC8MARK (ptr); break; case scm_tc7_substring: - if (SCM_GC8MARKP(ptr)) - break; - SCM_SETGC8MARK (ptr); ptr = SCM_CDR (ptr); goto gc_mark_loop; case scm_tc7_wvect: - if (SCM_GC8MARKP(ptr)) - break; SCM_WVECT_GC_CHAIN (ptr) = scm_weak_vectors; scm_weak_vectors = ptr; - SCM_SETGC8MARK (ptr); if (SCM_IS_WHVEC_ANY (ptr)) { int x; @@ -1239,7 +1307,7 @@ gc_mark_nimp: if (!weak_keys) scm_gc_mark (SCM_CAR (kvpair)); if (!weak_values) - scm_gc_mark (SCM_GCCDR (kvpair)); + scm_gc_mark (SCM_CDR (kvpair)); alist = next_alist; } if (SCM_NIMP (alist)) @@ -1249,26 +1317,16 @@ gc_mark_nimp: break; case scm_tc7_msymbol: - if (SCM_GC8MARKP(ptr)) - break; - SCM_SETGC8MARK (ptr); scm_gc_mark (SCM_SYMBOL_FUNC (ptr)); ptr = SCM_SYMBOL_PROPS (ptr); goto gc_mark_loop; case scm_tc7_ssymbol: - if (SCM_GC8MARKP(ptr)) - break; - SCM_SETGC8MARK (ptr); - break; case scm_tcs_subrs: break; case scm_tc7_port: i = SCM_PTOBNUM (ptr); if (!(i < scm_numptob)) goto def; - if (SCM_GC8MARKP (ptr)) - break; - SCM_SETGC8MARK (ptr); if (SCM_PTAB_ENTRY(ptr)) scm_gc_mark (SCM_PTAB_ENTRY(ptr)->file_name); if (scm_ptobs[i].mark) @@ -1280,10 +1338,7 @@ gc_mark_nimp: return; break; case scm_tc7_smob: - if (SCM_GC8MARKP (ptr)) - break; - SCM_SETGC8MARK (ptr); - switch (SCM_GCTYP16 (ptr)) + switch (SCM_TYP16 (ptr)) { /* should be faster than going through scm_smobs */ case scm_tc_free_cell: /* printf("found free_cell %X ", ptr); fflush(stdout); */ @@ -1366,6 +1421,10 @@ scm_mark_locations (SCM_STACKITEM x[], scm_sizet n) break; } } + + if (SCM_GC_IN_CARD_HEADERP (ptr)) + break; + if (scm_heap_table[seg_id].span == 1 || SCM_DOUBLE_CELLP (obj)) { @@ -1403,14 +1462,14 @@ scm_cellp (SCM value) if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr) && SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr) - && (scm_heap_table[i].span == 1 || SCM_DOUBLE_CELLP (value))) { + && (scm_heap_table[i].span == 1 || SCM_DOUBLE_CELLP (value)) + && !SCM_GC_IN_CARD_HEADERP (ptr) + ) return 1; - } else { + else return 0; - } - } else { + } else return 0; - } } @@ -1452,6 +1511,14 @@ gc_sweep_freelist_finish (scm_freelist_t *freelist) freelist->grow_heap_p = (collected < freelist->min_yield); } +#define NEXT_DATA_CELL(ptr, span) \ + do { \ + scm_cell *nxt__ = CELL_UP ((char *) (ptr) + 1, (span)); \ + (ptr) = (SCM_GC_IN_CARD_HEADERP (nxt__) ? \ + CELL_UP (SCM_GC_CELL_CARD (nxt__) + SCM_GC_CARD_N_HEADER_CELLS, span) \ + : nxt__); \ + } while (0) + void scm_gc_sweep () #define FUNC_NAME "scm_gc_sweep" @@ -1488,14 +1555,35 @@ scm_gc_sweep () ptr = CELL_UP (scm_heap_table[i].bounds[0], span); seg_size = CELL_DN (scm_heap_table[i].bounds[1], span) - ptr; + /* use only data cells in seg_size */ + seg_size = (seg_size / SCM_GC_CARD_N_CELLS) * (SCM_GC_CARD_N_DATA_CELLS / span) * span; + scm_gc_cells_swept += seg_size; for (j = seg_size + span; j -= span; ptr += span) { - SCM scmptr = PTR2SCM (ptr); + SCM scmptr; - switch SCM_TYP7 (scmptr) + if (SCM_GC_IN_CARD_HEADERP (ptr)) { + SCM_CELLPTR nxt; + + /* cheat here */ + nxt = ptr; + NEXT_DATA_CELL (nxt, span); + j += span; + + ptr = nxt - span; + continue; + } + + scmptr = PTR2SCM (ptr); + + if (SCM_GCMARKP (scmptr)) + continue; + + switch SCM_TYP7 (scmptr) + { case scm_tcs_cons_gloc: { /* Dirk:FIXME:: Again, super ugly code: scmptr may be a @@ -1506,16 +1594,13 @@ scm_gc_sweep () - scm_tc3_cons_gloc); /* access as struct */ scm_bits_t * vtable_data = (scm_bits_t *) word0; - if (SCM_GCMARKP (scmptr)) - goto cmrkcontinue; - else if (vtable_data[scm_vtable_index_vcell] == 0) + if (vtable_data[scm_vtable_index_vcell] == 0) { /* Structs need to be freed in a special order. * This is handled by GC C hooks in struct.c. */ SCM_SET_STRUCT_GC_CHAIN (scmptr, scm_structs_to_free); scm_structs_to_free = scmptr; - goto cmrkcontinue; } /* fall through so that scmptr gets collected */ } @@ -1524,29 +1609,16 @@ scm_gc_sweep () case scm_tcs_cons_nimcar: case scm_tcs_closures: case scm_tc7_pws: - if (SCM_GCMARKP (scmptr)) - goto cmrkcontinue; break; case scm_tc7_wvect: - if (SCM_GC8MARKP (scmptr)) - { - goto c8mrkcontinue; - } - else - { - m += (2 + SCM_LENGTH (scmptr)) * sizeof (SCM); - scm_must_free ((char *)(SCM_VELTS (scmptr) - 2)); - break; - } - + m += (2 + SCM_LENGTH (scmptr)) * sizeof (SCM); + scm_must_free ((char *)(SCM_VELTS (scmptr) - 2)); + break; case scm_tc7_vector: case scm_tc7_lvector: #ifdef CCLO case scm_tc7_cclo: #endif - if (SCM_GC8MARKP (scmptr)) - goto c8mrkcontinue; - m += (SCM_LENGTH (scmptr) * sizeof (SCM)); freechars: scm_must_free (SCM_CHARS (scmptr)); @@ -1554,80 +1626,53 @@ scm_gc_sweep () break; #ifdef HAVE_ARRAYS case scm_tc7_bvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; m += sizeof (long) * ((SCM_HUGE_LENGTH (scmptr) + SCM_LONG_BIT - 1) / SCM_LONG_BIT); goto freechars; case scm_tc7_byvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; m += SCM_HUGE_LENGTH (scmptr) * sizeof (char); goto freechars; case scm_tc7_ivect: case scm_tc7_uvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; m += SCM_HUGE_LENGTH (scmptr) * sizeof (long); goto freechars; case scm_tc7_svect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; m += SCM_HUGE_LENGTH (scmptr) * sizeof (short); goto freechars; #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; m += SCM_HUGE_LENGTH (scmptr) * sizeof (long_long); goto freechars; #endif case scm_tc7_fvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; m += SCM_HUGE_LENGTH (scmptr) * sizeof (float); goto freechars; case scm_tc7_dvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; m += SCM_HUGE_LENGTH (scmptr) * sizeof (double); goto freechars; case scm_tc7_cvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; m += SCM_HUGE_LENGTH (scmptr) * 2 * sizeof (double); goto freechars; #endif case scm_tc7_substring: - if (SCM_GC8MARKP (scmptr)) - goto c8mrkcontinue; break; case scm_tc7_string: - if (SCM_GC8MARKP (scmptr)) - goto c8mrkcontinue; m += SCM_HUGE_LENGTH (scmptr) + 1; goto freechars; case scm_tc7_msymbol: - if (SCM_GC8MARKP (scmptr)) - goto c8mrkcontinue; m += (SCM_LENGTH (scmptr) + 1 + (SCM_CHARS (scmptr) - (char *) SCM_SLOTS (scmptr))); scm_must_free ((char *)SCM_SLOTS (scmptr)); break; case scm_tc7_contin: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; m += SCM_LENGTH (scmptr) * sizeof (SCM_STACKITEM) + sizeof (scm_contregs); if (SCM_VELTS (scmptr)) goto freechars; case scm_tc7_ssymbol: - if SCM_GC8MARKP(scmptr) - goto c8mrkcontinue; break; case scm_tcs_subrs: + /* the various "subrs" (primitives) are never freed */ continue; case scm_tc7_port: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; if SCM_OPENP (scmptr) { int k = SCM_PTOBNUM (scmptr); @@ -1647,29 +1692,20 @@ scm_gc_sweep () } break; case scm_tc7_smob: - switch SCM_GCTYP16 (scmptr) + switch SCM_TYP16 (scmptr) { case scm_tc_free_cell: case scm_tc16_real: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; break; #ifdef SCM_BIGDIG case scm_tc16_big: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; m += (SCM_NUMDIGS (scmptr) * SCM_BITSPERDIG / SCM_CHAR_BIT); goto freechars; #endif /* def SCM_BIGDIG */ case scm_tc16_complex: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; m += 2 * sizeof (double); goto freechars; default: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - { int k; k = SCM_SMOBNUM (scmptr); @@ -1684,10 +1720,7 @@ scm_gc_sweep () sweeperr: SCM_MISC_ERROR ("unknown type", SCM_EOL); } -#if 0 - if (SCM_FREE_CELL_P (scmptr)) - exit (2); -#endif + if (!--left_to_collect) { SCM_SETCAR (scmptr, nfreelist); @@ -1708,14 +1741,8 @@ scm_gc_sweep () SCM_SET_FREE_CELL_CDR (scmptr, nfreelist); nfreelist = scmptr; } - - continue; - c8mrkcontinue: - SCM_CLRGC8MARK (scmptr); - continue; - cmrkcontinue: - SCM_CLRGCMARK (scmptr); } + #ifdef GC_FREE_SEGMENTS if (n == seg_size) { @@ -1739,9 +1766,6 @@ scm_gc_sweep () } #ifdef GUILE_DEBUG_FREELIST - scm_check_freelist (freelist == &scm_master_freelist - ? scm_freelist - : scm_freelist2); scm_map_free_list (); #endif } @@ -1763,7 +1787,6 @@ scm_gc_sweep () - /* {Front end to malloc} * * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc, @@ -1931,7 +1954,6 @@ scm_done_free (long size) - /* {Heap Segments} * * Each heap segment is an array of objects of a particular size. @@ -1960,15 +1982,22 @@ static unsigned int heap_segment_table_size = 0; int scm_n_heap_segs = 0; /* init_heap_seg - * initializes a new heap segment and return the number of objects it contains. + * initializes a new heap segment and returns the number of objects it contains. * - * The segment origin, segment size in bytes, and the span of objects - * in cells are input parameters. The freelist is both input and output. + * The segment origin and segment size in bytes are input parameters. + * The freelist is both input and output. * - * This function presume that the scm_heap_table has already been expanded - * to accomodate a new segment record. + * This function presumes that the scm_heap_table has already been expanded + * to accomodate a new segment record and that the markbit space was reserved + * for all the cards in this segment. */ +#define INIT_CARD(card, span) \ + do { \ + SCM_GC_CARD_BVEC (card) = get_bvec (); \ + if ((span) == 2) \ + SCM_GC_SET_CARD_DOUBLECELL (card); \ + } while (0) static scm_sizet init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, scm_freelist_t *freelist) @@ -1982,11 +2011,13 @@ init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, scm_freelist_t *freelist) if (seg_org == NULL) return 0; - ptr = CELL_UP (seg_org, span); + /* Align the begin ptr up. + */ + ptr = SCM_GC_CARD_UP (seg_org); /* Compute the ceiling on valid object pointers w/in this segment. */ - seg_end = CELL_DN ((char *) seg_org + size, span); + seg_end = SCM_GC_CARD_DOWN ((char *)seg_org + size); /* Find the right place and insert the segment record. * @@ -2010,12 +2041,6 @@ init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, scm_freelist_t *freelist) scm_heap_table[new_seg_index].bounds[0] = ptr; scm_heap_table[new_seg_index].bounds[1] = seg_end; - - /* Compute the least valid object pointer w/in this segment - */ - ptr = CELL_UP (ptr, span); - - /*n_new_cells*/ n_new_cells = seg_end - ptr; @@ -2025,41 +2050,56 @@ init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, scm_freelist_t *freelist) { SCM clusters; SCM *clusterp = &clusters; - int n_cluster_cells = span * freelist->cluster_size; - while (n_new_cells > span) /* at least one spine + one freecell */ + NEXT_DATA_CELL (ptr, span); + while (ptr < seg_end) { - /* Determine end of cluster - */ - if (n_new_cells >= n_cluster_cells) - { - seg_end = ptr + n_cluster_cells; - n_new_cells -= n_cluster_cells; - } - else - /* [cmm] looks like the segment size doesn't divide cleanly by - cluster size. bad cmm! */ - abort(); + scm_cell *nxt = ptr; + scm_cell *prv = NULL; + scm_cell *last_card = NULL; + int n_data_cells = (SCM_GC_CARD_N_DATA_CELLS / span) * SCM_CARDS_PER_CLUSTER - 1; + NEXT_DATA_CELL(nxt, span); /* Allocate cluster spine */ *clusterp = PTR2SCM (ptr); - SCM_SETCAR (*clusterp, PTR2SCM (ptr + span)); + SCM_SETCAR (*clusterp, PTR2SCM (nxt)); clusterp = SCM_CDRLOC (*clusterp); - ptr += span; + ptr = nxt; - while (ptr < seg_end) + while (n_data_cells--) { + scm_cell *card = SCM_GC_CELL_CARD (ptr); SCM scmptr = PTR2SCM (ptr); + nxt = ptr; + NEXT_DATA_CELL (nxt, span); + prv = ptr; + + if (card != last_card) + { + INIT_CARD (card, span); + last_card = card; + } SCM_SET_CELL_TYPE (scmptr, scm_tc_free_cell); - SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (ptr + span)); - ptr += span; + SCM_SETCDR (scmptr, PTR2SCM (nxt)); + + ptr = nxt; } - SCM_SET_FREE_CELL_CDR (PTR2SCM (ptr - span), SCM_EOL); + SCM_SET_FREE_CELL_CDR (PTR2SCM (prv), SCM_EOL); } + /* sanity check */ + { + scm_cell *ref = seg_end; + NEXT_DATA_CELL (ref, span); + if (ref != ptr) + /* [cmm] looks like the segment size doesn't divide cleanly by + cluster size. bad cmm! */ + abort(); + } + /* Patch up the last cluster pointer in the segment * to join it to the input freelist. */ @@ -2130,7 +2170,6 @@ alloc_some_heap (scm_freelist_t *freelist, policy_on_error error_policy) } } - /* Pick a size for the new heap segment. * The rule for picking the size of a segment is explained in * gc.h @@ -2371,6 +2410,7 @@ static int make_initial_segment (scm_sizet init_heap_size, scm_freelist_t *freelist) { scm_sizet rounded_size = round_to_cluster_size (freelist, init_heap_size); + if (!init_heap_seg ((SCM_CELLPTR) malloc (rounded_size), rounded_size, freelist)) @@ -2447,6 +2487,8 @@ scm_init_storage (scm_sizet init_heap_size_1, int gc_trigger_1, scm_must_malloc (sizeof (scm_heap_seg_data_t) * 2, "hplims")); heap_segment_table_size = 2; + mark_space_ptr = &mark_space_head; + if (make_initial_segment (init_heap_size_1, &scm_master_freelist) || make_initial_segment (init_heap_size_2, &scm_master_freelist2)) return 1; @@ -2491,6 +2533,7 @@ scm_init_storage (scm_sizet init_heap_size_1, int gc_trigger_1, #ifdef SCM_BIGDIG scm_sysintern ("bignum-radix", SCM_MAKINUM (SCM_BIGRAD)); #endif + return 0; } From dc16aa360d3234fdc47e63421980c71e3124d484 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Thu, 17 Aug 2000 20:39:05 +0000 Subject: [PATCH 0160/2047] *** empty log message *** --- libguile/ChangeLog | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 30b9922c0..88fce90d1 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,34 @@ +2000-08-17 Michael Livshin + + this changes the Guile GC to use cards (aka "chunklets"). + + * tags.h: (SCM_GCTYPE16, SCM_GCCDR, SCM_GC[8]MARKP, + SCM_SETGC[8]MARK, SCM_CLRGC[8]MARK): moved from here into gc.h. + some (most) of these are probably going to be deprecated. + + * gc.h (SCM_MARKEDP): simplified, there are no different mark bit + locations anymore. + (SCM_GC_CARD_*, SCM_C_BVEC_*): lots of new macros to deal with + cards and bvecs (bit-vectors). + + * gc.c: (scm_default_init_heap_size_*): defined to take cards into + account, but keeping more or less the same values as previously. + added some simple helper macros. + (CLUSTER_SIZE_IN_BYTES, ALIGNMENT_SLACK): defined to take cards + into account. + (BVEC_*, scm_mark_space_t, current_mark_space, mark_space_ptr, + current_mark_space_offset, mark_space_head, get_bvec, + clear_mark_space): new functions and supporting variables, types + and macros that implement mark space management. + (scm_igc): clear the mark space (all of it) before beginning the + mark phase. + (scm_gc_mark): changed the tests for rogue cells, much simplified + throughout (no different mark bit locations to worry about now). + (scm_mark_locations): don't consider card header cells. + (scm_cellp): ditto. + (scm_gc_sweep): simplified. + (init_heap_seg): changed to take cards into account. + 2000-08-16 Michael Livshin * stime.c (scm_c_get_internal_run_time): new function, same as From bbe6d8db7380c8f9418f2af11adf899db63b0da3 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Thu, 17 Aug 2000 20:46:22 +0000 Subject: [PATCH 0161/2047] *** empty log message *** --- THANKS | 2 ++ libguile/ChangeLog | 3 +++ 2 files changed, 5 insertions(+) diff --git a/THANKS b/THANKS index 81d2e51ca..f7257e90b 100644 --- a/THANKS +++ b/THANKS @@ -7,6 +7,8 @@ The Guile maintainer committee consists of Contributors since the last release: + Greg Harvey + For fixes or providing information which led to a fix: Ian Bicking diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 88fce90d1..a81363079 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,6 +1,9 @@ 2000-08-17 Michael Livshin this changes the Guile GC to use cards (aka "chunklets"). + (most of the ideas and some of the code are by Greg Harvey, though + the code is probably unrecognizable now. the original chunklet + proposal, way back, is by Dale Jordan). * tags.h: (SCM_GCTYPE16, SCM_GCCDR, SCM_GC[8]MARKP, SCM_SETGC[8]MARK, SCM_CLRGC[8]MARK): moved from here into gc.h. From 7e6b52f867ff2eafca903ac6ea59cef43a50ccf3 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 18 Aug 2000 00:57:08 +0000 Subject: [PATCH 0162/2047] *** empty log message *** --- RELEASE | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/RELEASE b/RELEASE index ebffd6d22..74b5c91a8 100644 --- a/RELEASE +++ b/RELEASE @@ -7,6 +7,10 @@ absinthe, etc. However, the first release containing the module system should be called Godot: "This is the one you've been waiting for." +* Deprecate `make-shared-substring'! We should arrange for shared + substrings to be generated automatically by `substring' and let string + mutators copy-on-write to otehr storage. + Before releasing the next version of libguile which is not binary compatible with the one released with 1.4: - remove struct members system_transformer and top_level_lookup_closure_var @@ -17,13 +21,6 @@ After signal handling and threading have been fixed: GUILE_OLD_ASYNC_CLICK macro. In release 1.5: -- remove deprecated variables: - scm_top_level_lookup_closure_var -- remove deprecated functions: - eval.c: scm_eval2, scm_eval_3 - load.c: scm_read_and_eval_x -- remove deprecated procedures: - boot-9.scm:eval-in-module - remove deprecated macros: SCM_INPORTP, SCM_OUTPORTP, SCM_CRDY, SCM_ICHRP, SCM_ICHR, SCM_MAKICHR, SCM_SETJMPBUF, SCM_NSTRINGP, SCM_NRWSTRINGP, SCM_NVECTORP @@ -45,6 +42,13 @@ In release 1.5: SCM_REALPART, scm_makdbl, SCM_SINGP, SCM_NUM2DBL, SCM_NO_BIGDIG In release 1.6: +- remove deprecated variables: + scm_top_level_lookup_closure_var +- remove deprecated functions: + eval.c: scm_eval2, scm_eval_3 + load.c: scm_read_and_eval_x +- remove deprecated procedures: + boot-9.scm:eval-in-module - remove deprecated macros: SCM_OUTOFRANGE, SCM_NALLOC, SCM_HUP_SIGNAL, SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD, From cdbc74184f98a5008ebc1bd5eea746730ec9bbc7 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 18 Aug 2000 09:30:54 +0000 Subject: [PATCH 0163/2047] * Docstring fixes - adding texinfo markup and removing extraneous trailing newlines. --- libguile/ChangeLog | 12 +++++++++++ libguile/boolean.c | 4 ++-- libguile/chars.c | 52 +++++++++++++++++++++++++++------------------- libguile/eq.c | 30 +++++++++++++------------- 4 files changed, 60 insertions(+), 38 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index a81363079..c8215eca5 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,15 @@ +2000-08-18 Neil Jerram + + * eq.c (scm_eq_p, scm_eqv_p, scm_equal_p): Add texinfo markup to + docstrings. + + * chars.c (scm_char*): Docstring fixes - texinfo markup. + +2000-08-18 Neil Jerram + + * boolean.c (scm_not, scm_boolean_p): Docstring fixes - add + texinfo markup and remove trailing newlines. + 2000-08-17 Michael Livshin this changes the Guile GC to use cards (aka "chunklets"). diff --git a/libguile/boolean.c b/libguile/boolean.c index 00d6a165a..6807d16b1 100644 --- a/libguile/boolean.c +++ b/libguile/boolean.c @@ -54,7 +54,7 @@ SCM_DEFINE (scm_not, "not", 1, 0, 0, (SCM x), - "Return #t iff X is #f, else return #f.\n") + "Return @code{#t} iff @var{x} is @code{#f}, else return @code{#f}.") #define FUNC_NAME s_scm_not { return SCM_BOOL(SCM_FALSEP(x)); @@ -64,7 +64,7 @@ SCM_DEFINE (scm_not, "not", 1, 0, 0, SCM_DEFINE (scm_boolean_p, "boolean?", 1, 0, 0, (SCM obj), - "Return #t iff OBJ is either #t or #f.\n") + "Return @code{#t} iff @var{obj} is either @code{#t} or @code{#f}.") #define FUNC_NAME s_scm_boolean_p { return SCM_BOOL (SCM_BOOLP (obj)); diff --git a/libguile/chars.c b/libguile/chars.c index a21b4cb2c..f0c0637c1 100644 --- a/libguile/chars.c +++ b/libguile/chars.c @@ -54,7 +54,7 @@ SCM_DEFINE (scm_char_p, "char?", 1, 0, 0, (SCM x), - "Return #t iff X is a character, else #f.") + "Return @code{#t} iff @var{x} is a character, else @code{#f}.") #define FUNC_NAME s_scm_char_p { return SCM_BOOL(SCM_CHARP(x)); @@ -63,7 +63,7 @@ SCM_DEFINE (scm_char_p, "char?", 1, 0, 0, SCM_DEFINE1 (scm_char_eq_p, "char=?", scm_tc7_rpsubr, (SCM x, SCM y), - "Return #t iff X is the same character as Y, else #f.") + "Return @code{#t} iff @var{x} is the same character as @var{y}, else @code{#f}.") #define FUNC_NAME s_scm_char_eq_p { SCM_VALIDATE_CHAR (1,x); @@ -75,7 +75,8 @@ SCM_DEFINE1 (scm_char_eq_p, "char=?", scm_tc7_rpsubr, SCM_DEFINE1 (scm_char_less_p, "char?", scm_tc7_rpsubr, (SCM x, SCM y), - "Return #t iff X is greater than Y in the Ascii sequence, else #f.") + "Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII\n" + "sequence, else @code{#f}.") #define FUNC_NAME s_scm_char_gr_p { SCM_VALIDATE_CHAR (1,x); @@ -108,7 +111,8 @@ SCM_DEFINE1 (scm_char_gr_p, "char>?", scm_tc7_rpsubr, SCM_DEFINE1 (scm_char_geq_p, "char>=?", scm_tc7_rpsubr, (SCM x, SCM y), - "Return #t iff X is greater than or equal to Y in the Ascii sequence, else #f.") + "Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the\n" + "ASCII sequence, else @code{#f}.") #define FUNC_NAME s_scm_char_geq_p { SCM_VALIDATE_CHAR (1,x); @@ -119,7 +123,8 @@ SCM_DEFINE1 (scm_char_geq_p, "char>=?", scm_tc7_rpsubr, SCM_DEFINE1 (scm_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr, (SCM x, SCM y), - "Return #t iff X is the same character as Y ignoring case, else #f.") + "Return @code{#t} iff @var{x} is the same character as @var{y} ignoring\n" + "case, else @code{#f}.") #define FUNC_NAME s_scm_char_ci_eq_p { SCM_VALIDATE_CHAR (1,x); @@ -130,7 +135,8 @@ SCM_DEFINE1 (scm_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr, SCM_DEFINE1 (scm_char_ci_less_p, "char-ci?", scm_tc7_rpsubr, (SCM x, SCM y), - "Return #t iff X is greater than Y in the Ascii sequence ignoring case, else #f.") + "Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII\n" + "sequence ignoring case, else @code{#f}.") #define FUNC_NAME s_scm_char_ci_gr_p { SCM_VALIDATE_CHAR (1,x); @@ -163,7 +171,8 @@ SCM_DEFINE1 (scm_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr, SCM_DEFINE1 (scm_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr, (SCM x, SCM y), - "Return #t iff X is greater than or equal to Y in the Ascii sequence ignoring case, else #f.") + "Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the\n" + "ASCII sequence ignoring case, else @code{#f}.") #define FUNC_NAME s_scm_char_ci_geq_p { SCM_VALIDATE_CHAR (1,x); @@ -175,7 +184,7 @@ SCM_DEFINE1 (scm_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr, SCM_DEFINE (scm_char_alphabetic_p, "char-alphabetic?", 1, 0, 0, (SCM chr), - "Return #t iff CHR is alphabetic, else #f.\n" + "Return @code{#t} iff @var{chr} is alphabetic, else @code{#f}.\n" "Alphabetic means the same thing as the isalpha C library function.") #define FUNC_NAME s_scm_char_alphabetic_p { @@ -186,7 +195,7 @@ SCM_DEFINE (scm_char_alphabetic_p, "char-alphabetic?", 1, 0, 0, SCM_DEFINE (scm_char_numeric_p, "char-numeric?", 1, 0, 0, (SCM chr), - "Return #t iff CHR is numeric, else #f.\n" + "Return @code{#t} iff @var{chr} is numeric, else @code{#f}.\n" "Numeric means the same thing as the isdigit C library function.") #define FUNC_NAME s_scm_char_numeric_p { @@ -197,7 +206,7 @@ SCM_DEFINE (scm_char_numeric_p, "char-numeric?", 1, 0, 0, SCM_DEFINE (scm_char_whitespace_p, "char-whitespace?", 1, 0, 0, (SCM chr), - "Return #t iff CHR is whitespace, else #f.\n" + "Return @code{#t} iff @var{chr} is whitespace, else @code{#f}.\n" "Whitespace means the same thing as the isspace C library function.") #define FUNC_NAME s_scm_char_whitespace_p { @@ -210,7 +219,7 @@ SCM_DEFINE (scm_char_whitespace_p, "char-whitespace?", 1, 0, 0, SCM_DEFINE (scm_char_upper_case_p, "char-upper-case?", 1, 0, 0, (SCM chr), - "Return #t iff CHR is uppercase, else #f.\n" + "Return @code{#t} iff @var{chr} is uppercase, else @code{#f}.\n" "Uppercase means the same thing as the isupper C library function.") #define FUNC_NAME s_scm_char_upper_case_p { @@ -222,7 +231,7 @@ SCM_DEFINE (scm_char_upper_case_p, "char-upper-case?", 1, 0, 0, SCM_DEFINE (scm_char_lower_case_p, "char-lower-case?", 1, 0, 0, (SCM chr), - "Return #t iff CHR is lowercase, else #f.\n" + "Return @code{#t} iff @var{chr} is lowercase, else @code{#f}.\n" "Lowercase means the same thing as the islower C library function.") #define FUNC_NAME s_scm_char_lower_case_p { @@ -235,7 +244,7 @@ SCM_DEFINE (scm_char_lower_case_p, "char-lower-case?", 1, 0, 0, SCM_DEFINE (scm_char_is_both_p, "char-is-both?", 1, 0, 0, (SCM chr), - "Return #t iff CHR is either uppercase or lowercase, else #f.\n" + "Return @code{#t} iff @var{chr} is either uppercase or lowercase, else @code{#f}.\n" "Uppercase and lowercase are as defined by the isupper and islower\n" "C library functions.") #define FUNC_NAME s_scm_char_is_both_p @@ -250,7 +259,8 @@ SCM_DEFINE (scm_char_is_both_p, "char-is-both?", 1, 0, 0, SCM_DEFINE (scm_char_to_integer, "char->integer", 1, 0, 0, (SCM chr), - "Return the number corresponding to ordinal position of CHR in the Ascii sequence.") + "Return the number corresponding to ordinal position of @var{chr} in the\n" + "ASCII sequence.") #define FUNC_NAME s_scm_char_to_integer { SCM_VALIDATE_CHAR (1,chr); @@ -262,7 +272,7 @@ SCM_DEFINE (scm_char_to_integer, "char->integer", 1, 0, 0, SCM_DEFINE (scm_integer_to_char, "integer->char", 1, 0, 0, (SCM n), - "Return the character at position N in the Ascii sequence.") + "Return the character at position @var{n} in the ASCII sequence.") #define FUNC_NAME s_scm_integer_to_char { SCM_VALIDATE_INUM_RANGE (1, n, 0, 256); @@ -273,7 +283,7 @@ SCM_DEFINE (scm_integer_to_char, "integer->char", 1, 0, 0, SCM_DEFINE (scm_char_upcase, "char-upcase", 1, 0, 0, (SCM chr), - "Return the uppercase character version of CHR.") + "Return the uppercase character version of @var{chr}.") #define FUNC_NAME s_scm_char_upcase { SCM_VALIDATE_CHAR (1,chr); @@ -284,7 +294,7 @@ SCM_DEFINE (scm_char_upcase, "char-upcase", 1, 0, 0, SCM_DEFINE (scm_char_downcase, "char-downcase", 1, 0, 0, (SCM chr), - "Return the lowercase character version of CHR.") + "Return the lowercase character version of @var{chr}.") #define FUNC_NAME s_scm_char_downcase { SCM_VALIDATE_CHAR (1,chr); diff --git a/libguile/eq.c b/libguile/eq.c index 526a97d4c..596a1ed30 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -59,10 +59,10 @@ SCM_DEFINE1 (scm_eq_p, "eq?", scm_tc7_rpsubr, (SCM x, SCM y), - "Return #t iff X references the same object as Y.\n" - "`eq?' is similar to `eqv?' except that in some cases\n" - "it is capable of discerning distinctions finer than\n" - "those detectable by `eqv?'.\n") + "Return @code{#t} iff @var{x} references the same object as @var{y}.\n" + "@code{eq?} is similar to @code{eqv?} except that in some cases it is\n" + "capable of discerning distinctions finer than those detectable by\n" + "@code{eqv?}.") #define FUNC_NAME s_scm_eq_p { return SCM_BOOL (SCM_EQ_P (x, y)); @@ -72,11 +72,11 @@ SCM_DEFINE1 (scm_eq_p, "eq?", scm_tc7_rpsubr, SCM_DEFINE1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr, (SCM x, SCM y), - "The `eqv?' procedure defines a useful equivalence relation on objects.\n" - "Briefly, it returns #t if X and Y should normally be\n" - "regarded as the same object. This relation is left\n" - "slightly open to interpretation, but works for comparing\n" - "immediate integers, characters, and inexact numbers.\n") + "The @code{eqv?} procedure defines a useful equivalence relation on objects.\n" + "Briefly, it returns @code{#t} if @var{x} and @var{y} should normally be\n" + "regarded as the same object. This relation is left slightly open to\n" + "interpretation, but works for comparing immediate integers, characters,\n" + "and inexact numbers.") #define FUNC_NAME s_scm_eqv_p { if (SCM_EQ_P (x, y)) @@ -120,12 +120,12 @@ SCM_DEFINE1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr, SCM_DEFINE1 (scm_equal_p, "equal?", scm_tc7_rpsubr, (SCM x, SCM y), - "Return #t iff X and Y are recursively `eqv?' equivalent.\n" - "`equal?' recursively compares the contents of pairs, vectors, and\n" - "strings, applying `eqv?' on other objects such as numbers and\n" - "symbols. A rule of thumb is that objects are generally `equal?'\n" - "if they print the same. `Equal?' may fail to terminate if its\n" - "arguments are circular data structures.\n") + "Return @code{#t} iff @var{x} and @var{y} are recursively @code{eqv?} equivalent.\n" + "@code{equal?} recursively compares the contents of pairs,\n" + "vectors, and strings, applying @code{eqv?} on other objects such as\n" + "numbers and symbols. A rule of thumb is that objects are generally\n" + "@code{equal?} if they print the same. @code{equal?} may fail to\n" + "terminate if its arguments are circular data structures.") #define FUNC_NAME s_scm_equal_p { SCM_CHECK_STACK; From d46e47131c3f3dfa9742c62b854203030cdb0ed1 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 18 Aug 2000 16:52:15 +0000 Subject: [PATCH 0164/2047] * net_db.c (scm_gethost, scm_getnet, scm_getproto, scm_sethost, scm_setnet, setproto, setserv): Argument names changed to match doc string. * feature.c (scm_program_arguments): New docstring. * simpos.c (scm_getenv): Reflow docstring. --- libguile/ChangeLog | 8 +++++ libguile/feature.c | 8 +++-- libguile/net_db.c | 76 +++++++++++++++++++++++----------------------- libguile/simpos.c | 3 +- 4 files changed, 53 insertions(+), 42 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index c8215eca5..3ba967238 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,13 @@ 2000-08-18 Neil Jerram + * net_db.c (scm_gethost, scm_getnet, scm_getproto, scm_sethost, + scm_setnet, setproto, setserv): Argument names changed to match + doc string. + + * feature.c (scm_program_arguments): New docstring. + + * simpos.c (scm_getenv): Reflow docstring. + * eq.c (scm_eq_p, scm_eqv_p, scm_equal_p): Add texinfo markup to docstrings. diff --git a/libguile/feature.c b/libguile/feature.c index 0589521e5..3829153ce 100644 --- a/libguile/feature.c +++ b/libguile/feature.c @@ -72,8 +72,12 @@ scm_add_feature (const char *str) SCM_DEFINE (scm_program_arguments, "program-arguments", 0, 0, 0, - (), -"") + (), + "@deffnx procedure command-line\n" + "Return the list of command line arguments passed to Guile, as a list of\n" + "strings. The list includes the invoked program name, which is usually\n" + "@code{\"guile\"}, but excludes switches and parameters for command line\n" + "options like @code{-e} and @code{-l}.") #define FUNC_NAME s_scm_program_arguments { return scm_progargs; diff --git a/libguile/net_db.c b/libguile/net_db.c index 82da282b4..768f718bb 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -236,7 +236,7 @@ static void scm_resolv_error (const char *subr, SCM bad_value) */ SCM_DEFINE (scm_gethost, "gethost", 0, 1, 0, - (SCM name), + (SCM host), "@deffnx procedure gethostbyname hostname\n" "@deffnx procedure gethostbyaddr address\n" "Look up a host by name or address, returning a host object. The\n" @@ -257,7 +257,7 @@ SCM_DEFINE (scm_gethost, "gethost", 0, 1, 0, struct in_addr inad; char **argv; int i = 0; - if (SCM_UNBNDP (name)) + if (SCM_UNBNDP (host)) { #ifdef HAVE_GETHOSTENT entry = gethostent (); @@ -275,18 +275,18 @@ SCM_DEFINE (scm_gethost, "gethost", 0, 1, 0, return SCM_BOOL_F; } } - else if (SCM_ROSTRINGP (name)) + else if (SCM_ROSTRINGP (host)) { - SCM_COERCE_SUBSTR (name); - entry = gethostbyname (SCM_ROCHARS (name)); + SCM_COERCE_SUBSTR (host); + entry = gethostbyname (SCM_ROCHARS (host)); } else { - inad.s_addr = htonl (SCM_NUM2ULONG (1,name)); + inad.s_addr = htonl (SCM_NUM2ULONG (1,host)); entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET); } if (!entry) - scm_resolv_error (FUNC_NAME, name); + scm_resolv_error (FUNC_NAME, host); ve[0] = scm_makfromstr (entry->h_name, (scm_sizet) strlen (entry->h_name), 0); @@ -321,7 +321,7 @@ SCM_DEFINE (scm_gethost, "gethost", 0, 1, 0, #if defined(HAVE_GETNETENT) && defined(HAVE_GETNETBYNAME) && defined(HAVE_GETNETBYADDR) SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0, - (SCM name), + (SCM net), "@deffnx procedure getnetbyname net-name\n" "@deffnx procedure getnetbyaddr net-number\n" "Look up a network by name or net number in the network database. The\n" @@ -337,7 +337,7 @@ SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0, ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED); ve = SCM_VELTS (ans); - if (SCM_UNBNDP (name)) + if (SCM_UNBNDP (net)) { errno = 0; entry = getnetent (); @@ -349,20 +349,20 @@ SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0, return SCM_BOOL_F; } } - else if (SCM_ROSTRINGP (name)) + else if (SCM_ROSTRINGP (net)) { - SCM_COERCE_SUBSTR (name); - entry = getnetbyname (SCM_ROCHARS (name)); + SCM_COERCE_SUBSTR (net); + entry = getnetbyname (SCM_ROCHARS (net)); } else { unsigned long netnum; - netnum = SCM_NUM2ULONG (1, name); + netnum = SCM_NUM2ULONG (1, net); entry = getnetbyaddr (netnum, AF_INET); } if (!entry) SCM_SYSERROR_MSG ("no such network ~A", - scm_listify (name, SCM_UNDEFINED), errno); + scm_listify (net, SCM_UNDEFINED), errno); ve[0] = scm_makfromstr (entry->n_name, (scm_sizet) strlen (entry->n_name), 0); ve[1] = scm_makfromstrs (-1, entry->n_aliases); ve[2] = SCM_MAKINUM (entry->n_addrtype + 0L); @@ -374,7 +374,7 @@ SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0, #ifdef HAVE_GETPROTOENT SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0, - (SCM name), + (SCM protocol), "@deffnx procedure getprotobyname name\n" "@deffnx procedure getprotobynumber number\n" "Look up a network protocol by name or by number. @code{getprotobyname}\n" @@ -389,7 +389,7 @@ SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0, ans = scm_make_vector (SCM_MAKINUM (3), SCM_UNSPECIFIED); ve = SCM_VELTS (ans); - if (SCM_UNBNDP (name)) + if (SCM_UNBNDP (protocol)) { errno = 0; entry = getprotoent (); @@ -401,20 +401,20 @@ SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0, return SCM_BOOL_F; } } - else if (SCM_ROSTRINGP (name)) + else if (SCM_ROSTRINGP (protocol)) { - SCM_COERCE_SUBSTR (name); - entry = getprotobyname (SCM_ROCHARS (name)); + SCM_COERCE_SUBSTR (protocol); + entry = getprotobyname (SCM_ROCHARS (protocol)); } else { unsigned long protonum; - protonum = SCM_NUM2ULONG (1,name); + protonum = SCM_NUM2ULONG (1,protocol); entry = getprotobynumber (protonum); } if (!entry) SCM_SYSERROR_MSG ("no such protocol ~A", - scm_listify (name, SCM_UNDEFINED), errno); + scm_listify (protocol, SCM_UNDEFINED), errno); ve[0] = scm_makfromstr (entry->p_name, (scm_sizet) strlen (entry->p_name), 0); ve[1] = scm_makfromstrs (-1, entry->p_aliases); ve[2] = SCM_MAKINUM (entry->p_proto + 0L); @@ -440,7 +440,7 @@ scm_return_entry (struct servent *entry) #ifdef HAVE_GETSERVENT SCM_DEFINE (scm_getserv, "getserv", 0, 2, 0, - (SCM name, SCM proto), + (SCM name, SCM protocol), "@deffnx procedure getservbyname name protocol\n" "@deffnx procedure getservbyport port protocol\n" "Look up a network service by name or by service number, and return a\n" @@ -466,17 +466,17 @@ SCM_DEFINE (scm_getserv, "getserv", 0, 2, 0, } return scm_return_entry (entry); } - SCM_VALIDATE_ROSTRING (2,proto); - SCM_COERCE_SUBSTR (proto); + SCM_VALIDATE_ROSTRING (2,protocol); + SCM_COERCE_SUBSTR (protocol); if (SCM_ROSTRINGP (name)) { SCM_COERCE_SUBSTR (name); - entry = getservbyname (SCM_ROCHARS (name), SCM_ROCHARS (proto)); + entry = getservbyname (SCM_ROCHARS (name), SCM_ROCHARS (protocol)); } else { SCM_VALIDATE_INUM (1,name); - entry = getservbyport (htons (SCM_INUM (name)), SCM_ROCHARS (proto)); + entry = getservbyport (htons (SCM_INUM (name)), SCM_ROCHARS (protocol)); } if (!entry) SCM_SYSERROR_MSG("no such service ~A", @@ -488,15 +488,15 @@ SCM_DEFINE (scm_getserv, "getserv", 0, 2, 0, #if defined(HAVE_SETHOSTENT) && defined(HAVE_ENDHOSTENT) SCM_DEFINE (scm_sethost, "sethost", 0, 1, 0, - (SCM arg), + (SCM stayopen), "If @var{stayopen} is omitted, this is equivalent to @code{endhostent}.\n" "Otherwise it is equivalent to @code{sethostent stayopen}.") #define FUNC_NAME s_scm_sethost { - if (SCM_UNBNDP (arg)) + if (SCM_UNBNDP (stayopen)) endhostent (); else - sethostent (SCM_NFALSEP (arg)); + sethostent (SCM_NFALSEP (stayopen)); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -504,15 +504,15 @@ SCM_DEFINE (scm_sethost, "sethost", 0, 1, 0, #if defined(HAVE_SETNETENT) && defined(HAVE_ENDNETENT) SCM_DEFINE (scm_setnet, "setnet", 0, 1, 0, - (SCM arg), + (SCM stayopen), "If @var{stayopen} is omitted, this is equivalent to @code{endnetent}.\n" "Otherwise it is equivalent to @code{setnetent stayopen}.") #define FUNC_NAME s_scm_setnet { - if (SCM_UNBNDP (arg)) + if (SCM_UNBNDP (stayopen)) endnetent (); else - setnetent (SCM_NFALSEP (arg)); + setnetent (SCM_NFALSEP (stayopen)); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -520,15 +520,15 @@ SCM_DEFINE (scm_setnet, "setnet", 0, 1, 0, #if defined(HAVE_SETPROTOENT) && defined(HAVE_ENDPROTOENT) SCM_DEFINE (scm_setproto, "setproto", 0, 1, 0, - (SCM arg), + (SCM stayopen), "If @var{stayopen} is omitted, this is equivalent to @code{endprotoent}.\n" "Otherwise it is equivalent to @code{setprotoent stayopen}.") #define FUNC_NAME s_scm_setproto { - if (SCM_UNBNDP (arg)) + if (SCM_UNBNDP (stayopen)) endprotoent (); else - setprotoent (SCM_NFALSEP (arg)); + setprotoent (SCM_NFALSEP (stayopen)); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -536,15 +536,15 @@ SCM_DEFINE (scm_setproto, "setproto", 0, 1, 0, #if defined(HAVE_SETSERVENT) && defined(HAVE_ENDSERVENT) SCM_DEFINE (scm_setserv, "setserv", 0, 1, 0, - (SCM arg), + (SCM stayopen), "If @var{stayopen} is omitted, this is equivalent to @code{endservent}.\n" "Otherwise it is equivalent to @code{setservent stayopen}.") #define FUNC_NAME s_scm_setserv { - if (SCM_UNBNDP (arg)) + if (SCM_UNBNDP (stayopen)) endservent (); else - setservent (SCM_NFALSEP (arg)); + setservent (SCM_NFALSEP (stayopen)); return SCM_UNSPECIFIED; } #undef FUNC_NAME diff --git a/libguile/simpos.c b/libguile/simpos.c index 8b6b744b6..b15d6987e 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -101,8 +101,7 @@ SCM_DEFINE (scm_getenv, "getenv", 1, 0, 0, (SCM nam), "Looks up the string @var{name} in the current environment. The return\n" "value is @code{#f} unless a string of the form @code{NAME=VALUE} is\n" - "found, in which case the string @code{VALUE} is\n" - "returned.") + "found, in which case the string @code{VALUE} is returned.") #define FUNC_NAME s_scm_getenv { char *val; From 55892d875c8147ad820c11266b84563ea0383000 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 18 Aug 2000 17:12:37 +0000 Subject: [PATCH 0165/2047] * filesys.c (scm_fcntl): Docstring fix - missing newlines inserted. --- libguile/ChangeLog | 2 ++ libguile/filesys.c | 4 ++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 3ba967238..d5862fac7 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,7 @@ 2000-08-18 Neil Jerram + * filesys.c (scm_fcntl): Docstring fix - missing newlines inserted. + * net_db.c (scm_gethost, scm_getnet, scm_getproto, scm_sethost, scm_setnet, setproto, setserv): Argument names changed to match doc string. diff --git a/libguile/filesys.c b/libguile/filesys.c index 8073225cb..d2a86729d 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1134,8 +1134,8 @@ SCM_DEFINE (scm_fcntl, "fcntl", 2, 1, 0, "@item F_SETOWN\n" "Set the process that owns a socket to @var{value}, for @code{SIGIO} signals.\n" "@item FD_CLOEXEC\n" - "The value used to indicate the \"close on exec\" flag with @code{F_GETFL} or" - "@code{F_SETFL}." + "The value used to indicate the \"close on exec\" flag with @code{F_GETFL} or\n" + "@code{F_SETFL}.\n" "@end table") #define FUNC_NAME s_scm_fcntl { From 35e9b48d791e82b18d6ddb2ee244ddee841fc370 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Fri, 18 Aug 2000 22:33:37 +0000 Subject: [PATCH 0166/2047] * gc.h: removed some stuff that broke compilation for people and wasn't actually needed anyway. --- libguile/gc.h | 39 --------------------------------------- 1 file changed, 39 deletions(-) diff --git a/libguile/gc.h b/libguile/gc.h index 446e15e00..12b17805f 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -81,45 +81,6 @@ typedef scm_cell * SCM_CELLPTR; # define PTR2SCM(x) (SCM_PACK ((scm_bits_t) (x))) #endif /* def _UNICOS */ -/* This mess was copied from the GNU getpagesize.h. */ - -#ifndef HAVE_GETPAGESIZE - -/* Assume that all systems that can run configure have sys/param.h. */ -# ifndef HAVE_SYS_PARAM_H -# define HAVE_SYS_PARAM_H 1 -# endif - -# ifdef _SC_PAGESIZE -# define getpagesize() sysconf(_SC_PAGESIZE) -# else /* no _SC_PAGESIZE */ -# ifdef HAVE_SYS_PARAM_H -# include -# ifdef EXEC_PAGESIZE -# define getpagesize() EXEC_PAGESIZE -# else /* no EXEC_PAGESIZE */ -# ifdef NBPG -# define getpagesize() NBPG * CLSIZE -# ifndef CLSIZE -# define CLSIZE 1 -# endif /* no CLSIZE */ -# else /* no NBPG */ -# ifdef NBPC -# define getpagesize() NBPC -# else /* no NBPC */ -# ifdef PAGESIZE -# define getpagesize() PAGESIZE -# endif /* PAGESIZE */ -# endif /* no NBPC */ -# endif /* no NBPG */ -# endif /* no EXEC_PAGESIZE */ -# else /* no HAVE_SYS_PARAM_H */ -# define getpagesize() 8192 /* punt totally */ -# endif /* no HAVE_SYS_PARAM_H */ -# endif /* no _SC_PAGESIZE */ - -#endif /* no HAVE_GETPAGESIZE */ - #define SCM_GC_CARD_N_HEADER_CELLS 1 #define SCM_GC_CARD_N_CELLS (8 * sizeof (scm_cell) * 4) From 005b59783e1bbd97dd2acfb1aef592a6b2099ee1 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Fri, 18 Aug 2000 22:36:11 +0000 Subject: [PATCH 0167/2047] *** empty log message *** --- libguile/ChangeLog | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d5862fac7..850b72ad4 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-08-19 Michael Livshin + + * gc.h: removed some stuff that broke compilation for people and + wasn't actually needed anyway. + 2000-08-18 Neil Jerram * filesys.c (scm_fcntl): Docstring fix - missing newlines inserted. @@ -5,14 +10,14 @@ * net_db.c (scm_gethost, scm_getnet, scm_getproto, scm_sethost, scm_setnet, setproto, setserv): Argument names changed to match doc string. - + * feature.c (scm_program_arguments): New docstring. * simpos.c (scm_getenv): Reflow docstring. * eq.c (scm_eq_p, scm_eqv_p, scm_equal_p): Add texinfo markup to docstrings. - + * chars.c (scm_char*): Docstring fixes - texinfo markup. 2000-08-18 Neil Jerram @@ -23,7 +28,7 @@ 2000-08-17 Michael Livshin this changes the Guile GC to use cards (aka "chunklets"). - (most of the ideas and some of the code are by Greg Harvey, though + (most of the ideas and some of the code are by Greg Harvey, though the code is probably unrecognizable now. the original chunklet proposal, way back, is by Dale Jordan). From aec1eb30482afb97764e3abda8dd7d7749d4f597 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Fri, 18 Aug 2000 22:44:12 +0000 Subject: [PATCH 0168/2047] * acconfig.h: added BROKEN_GCSE. * configure.in: check for a gcc GCSE optimisation bug. --- acconfig.h | 3 +++ configure.in | 27 +++++++++++++++++++++++++++ 2 files changed, 30 insertions(+) diff --git a/acconfig.h b/acconfig.h index b7b42bc3d..cf5e0fff2 100644 --- a/acconfig.h +++ b/acconfig.h @@ -154,3 +154,6 @@ /* Define if the compiler supports long longs. */ #undef HAVE_LONG_LONGS + +/* Define if GCC has GCSE optimisation bug. */ +#undef BROKEN_GCSE diff --git a/configure.in b/configure.in index 09e897dee..3c4126e90 100644 --- a/configure.in +++ b/configure.in @@ -129,6 +129,33 @@ if test "$scm_cv_long_longs" = yes; then AC_DEFINE(HAVE_LONG_LONGS) fi +dnl check for an optimisation problem which is present in some versions +dnl of gcc, including 2.95.2. +AC_MSG_CHECKING(for broken GCSE optimisation) +AC_CACHE_VAL(guile_cv_broken_gcse, + AC_TRY_RUN([ + int main () + { + long winds = 0; + + while (winds != 0) + { + if (*(char *) 0) + break; + } + + if (winds == 0 || *(char *) 0) + exit (0); + + return 0; + }], + guile_cv_broken_gcse=no, guile_cv_broken_gcse=yes, + guile_cv_broken_gcse=yes)) +AC_MSG_RESULT($guile_cv_broken_gcse) +if test $guile_cv_broken_gcse = yes; then + AC_DEFINE(BROKEN_GCSE) +fi + AC_HEADER_STDC AC_HEADER_DIRENT AC_HEADER_TIME From e494e76d22b2ff2992ae7a19e8104b4a4f8411aa Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Fri, 18 Aug 2000 22:45:43 +0000 Subject: [PATCH 0169/2047] *** empty log message *** --- ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ChangeLog b/ChangeLog index e8aa470c3..b9ac0f2db 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2000-08-18 Gary Houston + + * acconfig.h: added BROKEN_GCSE. + * configure.in: check for a gcc GCSE optimisation bug. + 2000-07-31 Gary Houston * acconfig.h: added HAVE_H_ERRNO From b1ee756f1f6a1761affcfd15b7be266741b9c39d Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 19 Aug 2000 13:37:55 +0000 Subject: [PATCH 0170/2047] * optargs.scm (#\&): Changed #:allow-other-key-value to #:allow-other-keys. Thanks to Bill Schottstaedt! --- ice-9/optargs.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ice-9/optargs.scm b/ice-9/optargs.scm index 33304085e..8b74d9127 100644 --- a/ice-9/optargs.scm +++ b/ice-9/optargs.scm @@ -206,7 +206,7 @@ ((optional) #:optional) ((key) #:key) ((rest) #:rest) - ((allow-other-keys) #:allow-other-keys-value) + ((allow-other-keys) #:allow-other-keys) (else (error "Bad #& value."))))) From 5aba8e27ab93fdd03460598833751b1148d453e4 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 19 Aug 2000 13:38:23 +0000 Subject: [PATCH 0171/2047] *** empty log message *** --- ice-9/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 19937e8cb..857d37f67 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2000-08-19 Marius Vollmer + + * optargs.scm (#\&): Changed #:allow-other-keys-value to + #:allow-other-keys. Thanks to Bill Schottstaedt! + 2000-08-17 Marius Vollmer * optargs.scm (#\&): Emit warning about `#&' being deprecated. From 7bb8eac7808421dbe9b6446e2c5d5a09a16e5631 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Sat, 19 Aug 2000 19:20:21 +0000 Subject: [PATCH 0172/2047] * gc.c (scm_gc_sweep): added a `continue' statement that have fallen through the cracks in the merge. thanks to Shuji Narazaki! --- libguile/gc.c | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/libguile/gc.c b/libguile/gc.c index b091f0178..69a4977a7 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1178,7 +1178,7 @@ gc_mark_nimp: int len = SCM_LENGTH (layout); char * fields_desc = SCM_CHARS (layout); scm_bits_t * struct_data = (scm_bits_t *) SCM_STRUCT_DATA (ptr); - + if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) { scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_procedure])); @@ -1187,7 +1187,7 @@ gc_mark_nimp: if (len) { int x; - + for (x = 0; x < len - 2; x += 2, ++struct_data) if (fields_desc[x] == 'p') scm_gc_mark (SCM_PACK (*struct_data)); @@ -1421,10 +1421,10 @@ scm_mark_locations (SCM_STACKITEM x[], scm_sizet n) break; } } - + if (SCM_GC_IN_CARD_HEADERP (ptr)) break; - + if (scm_heap_table[seg_id].span == 1 || SCM_DOUBLE_CELLP (obj)) { @@ -1581,7 +1581,7 @@ scm_gc_sweep () if (SCM_GCMARKP (scmptr)) continue; - + switch SCM_TYP7 (scmptr) { case scm_tcs_cons_gloc: @@ -1601,6 +1601,7 @@ scm_gc_sweep () */ SCM_SET_STRUCT_GC_CHAIN (scmptr, scm_structs_to_free); scm_structs_to_free = scmptr; + continue; } /* fall through so that scmptr gets collected */ } @@ -1720,7 +1721,7 @@ scm_gc_sweep () sweeperr: SCM_MISC_ERROR ("unknown type", SCM_EOL); } - + if (!--left_to_collect) { SCM_SETCAR (scmptr, nfreelist); From d8d4d4936655c9798f93d110c7931a5058d7d95f Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Sat, 19 Aug 2000 19:21:59 +0000 Subject: [PATCH 0173/2047] *** empty log message *** --- THANKS | 1 + libguile/ChangeLog | 3 +++ 2 files changed, 4 insertions(+) diff --git a/THANKS b/THANKS index f7257e90b..8e5e70d22 100644 --- a/THANKS +++ b/THANKS @@ -14,6 +14,7 @@ For fixes or providing information which led to a fix: Ian Bicking Brad Knotwell Matthias Köppe + Shuji Narazaki Nicolas Neuss Han-Wen Nienhuys William Webber diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 850b72ad4..2f40513da 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,8 @@ 2000-08-19 Michael Livshin + * gc.c (scm_gc_sweep): added a `continue' statement that have + fallen through the cracks in the merge. thanks to Shuji Narazaki! + * gc.h: removed some stuff that broke compilation for people and wasn't actually needed anyway. From 6ad9007abf9a0cd26315471aecbe03fdf7fac9f7 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 21 Aug 2000 08:57:11 +0000 Subject: [PATCH 0174/2047] * lib.scm (pass-if, expect-fail): Generalized. * * tests/eval.test: Fixed documentation test. --- test-suite/ChangeLog | 7 +++++++ test-suite/lib.scm | 8 ++++---- test-suite/tests/eval.test | 2 +- 3 files changed, 12 insertions(+), 5 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 9bcf4fe21..c92509b84 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,10 @@ +2000-08-21 Dirk Herrmann + + * lib.scm (pass-if, expect-fail): Generalized to allow a sequence + of expressions. + + * tests/eval.test: Fix documentation test. + 2000-06-30 Dirk Herrmann * tests/list.test: Added tests for list-ref, list-set! and diff --git a/test-suite/lib.scm b/test-suite/lib.scm index c69b18ba6..fa730973b 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -244,12 +244,12 @@ (set! run-test local-run-test)) ;;; A short form for tests that are expected to pass, taken from Greg. -(defmacro pass-if (name body) - `(run-test ,name #t (lambda () (not (not (begin ,body)))))) +(defmacro pass-if (name body . rest) + `(run-test ,name #t (lambda () (not (not (begin ,body ,@rest)))))) ;;; A short form for tests that are expected to fail, taken from Greg. -(defmacro expect-fail (name body) - `(run-test ,name #f (lambda () ,body))) +(defmacro expect-fail (name body . rest) + `(run-test ,name #f (lambda () ,body ,@rest))) ;;;; TEST NAMES diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index cdc69ef62..ba6a4ef7e 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -94,7 +94,7 @@ ;; Is documentation available? (expect-fail "documented?" - (documented? 'map)) + (documented? map)) (with-test-prefix "argument error" From f91f77e64edab9e6a2ea8cffd005e2e4f3542f3c Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Mon, 21 Aug 2000 10:06:45 +0000 Subject: [PATCH 0175/2047] * gc.h (SCM_GC_CARD_N_CELLS): change to be a nice non-confusing constant. --- libguile/gc.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/gc.h b/libguile/gc.h index 12b17805f..48d2611e5 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -82,7 +82,7 @@ typedef scm_cell * SCM_CELLPTR; #endif /* def _UNICOS */ #define SCM_GC_CARD_N_HEADER_CELLS 1 -#define SCM_GC_CARD_N_CELLS (8 * sizeof (scm_cell) * 4) +#define SCM_GC_CARD_N_CELLS 256 #define SCM_GC_CARD_SIZE (SCM_GC_CARD_N_CELLS * sizeof (scm_cell)) #define SCM_GC_CARD_N_DATA_CELLS (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS) From ca55e62c8e823310015ff64aa0ab424945cf63af Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Mon, 21 Aug 2000 10:07:13 +0000 Subject: [PATCH 0176/2047] *** empty log message *** --- libguile/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 2f40513da..129849b67 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-08-21 Michael Livshin + + * gc.h (SCM_GC_CARD_N_CELLS): change to be a nice non-confusing + constant. + 2000-08-19 Michael Livshin * gc.c (scm_gc_sweep): added a `continue' statement that have From 641d17a83a08839102d6b5c6ca8e27979ffdc776 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 23 Aug 2000 18:22:07 +0000 Subject: [PATCH 0177/2047] * gc.c (scm_gc_mark): Don't use GUILE_DEBUG flag to compile in extra tests. (GUILE_DEBUG is only supposed to make extra debugging functions available.) --- libguile/gc.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/gc.c b/libguile/gc.c index 69a4977a7..980567a0e 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1122,7 +1122,7 @@ gc_mark_nimp: if (!SCM_CELLP (ptr)) SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL); -#if (defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)) +#if (defined (GUILE_DEBUG_FREELIST)) if (SCM_GC_IN_CARD_HEADERP (SCM2PTR (ptr))) scm_wta (ptr, "rogue pointer in heap", NULL); From 38525772e47764ea63cc52fcba436e316d7f0c07 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 23 Aug 2000 18:22:19 +0000 Subject: [PATCH 0178/2047] *** empty log message *** --- libguile/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 129849b67..827f540e1 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2000-08-23 Mikael Djurfeldt + + * gc.c (scm_gc_mark): Don't use GUILE_DEBUG flag to compile in + extra tests. (GUILE_DEBUG is only supposed to make extra + debugging functions available.) + 2000-08-21 Michael Livshin * gc.h (SCM_GC_CARD_N_CELLS): change to be a nice non-confusing From fde75b7c8e2775ab3109f92daca91c7d1d776174 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Thu, 24 Aug 2000 00:16:17 +0000 Subject: [PATCH 0179/2047] * psyntax.ss (set!): Added generalized set! support to core syntax form set!. --- ice-9/psyntax.ss | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ice-9/psyntax.ss b/ice-9/psyntax.ss index fc4178ed3..0fd70f342 100644 --- a/ice-9/psyntax.ss +++ b/ice-9/psyntax.ss @@ -1670,6 +1670,11 @@ (syntax-error (wrap (syntax id) w) "identifier out of context")) (else (syntax-error (source-wrap e w s))))))) + ((_ (getter arg ...) val) + (build-application s + (chi (syntax (setter getter)) r w) + (map (lambda (e) (chi e r w)) + (syntax (arg ... val))))) (_ (syntax-error (source-wrap e w s)))))) (global-extend 'begin 'begin '()) From 9f174131de3c9decd93cd0c6a04246fb081c0b3b Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Thu, 24 Aug 2000 00:16:36 +0000 Subject: [PATCH 0180/2047] *** empty log message *** --- ice-9/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 857d37f67..d43ac393a 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2000-08-24 Mikael Djurfeldt + + * psyntax.ss (set!): Added generalized set! support to core syntax + form set!. + 2000-08-19 Marius Vollmer * optargs.scm (#\&): Changed #:allow-other-keys-value to From 2822e61232ca31aa4f5e30e09d421dc916a22c7e Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Thu, 24 Aug 2000 00:16:56 +0000 Subject: [PATCH 0181/2047] Regenerated --- ice-9/psyntax.pp | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/ice-9/psyntax.pp b/ice-9/psyntax.pp index a453e679b..f30697a78 100644 --- a/ice-9/psyntax.pp +++ b/ice-9/psyntax.pp @@ -1,11 +1,11 @@ -(letrec ((lambda-var-list (lambda (vars) (let lvl ((vars402 vars) (ls (quote ())) (w (quote (())))) (cond ((pair? vars402) (lvl (cdr vars402) (cons (wrap (car vars402) w) ls) w)) ((id? vars402) (cons (wrap vars402 w) ls)) ((null? vars402) ls) ((syntax-object? vars402) (lvl (syntax-object-expression vars402) ls (join-wraps w (syntax-object-wrap vars402)))) ((annotation? vars402) (lvl (annotation-expression vars402) ls w)) (else (cons vars402 ls)))))) (gen-var (lambda (id) (let ((id403 (if (syntax-object? id) (syntax-object-expression id) id))) (if (annotation? id403) (gensym (annotation-expression id403) generated-symbols) (gensym id403 generated-symbols))))) (strip (lambda (x404 w405) (if (memq (quote top) (wrap-marks w405)) (if (or (annotation? x404) (and (pair? x404) (annotation? (car x404)))) (strip-annotation x404 (quote #f)) x404) (let f406 ((x407 x404)) (cond ((syntax-object? x407) (strip (syntax-object-expression x407) (syntax-object-wrap x407))) ((pair? x407) (let ((a (f406 (car x407))) (d (f406 (cdr x407)))) (if (and (eq? a (car x407)) (eq? d (cdr x407))) x407 (cons a d)))) ((vector? x407) (let ((old (vector->list x407))) (let ((new (map f406 old))) (if (andmap eq? old new) x407 (list->vector new))))) (else x407)))))) (strip-annotation (lambda (x408 parent) (cond ((pair? x408) (let ((new409 (cons (quote #f) (quote #f)))) (begin (when parent (set-annotation-stripped! parent new409)) (set-car! new409 (strip-annotation (car x408) (quote #f))) (set-cdr! new409 (strip-annotation (cdr x408) (quote #f))) new409))) ((annotation? x408) (or (annotation-stripped x408) (strip-annotation (annotation-expression x408) x408))) ((vector? x408) (let ((new410 (make-vector (vector-length x408)))) (begin (when parent (set-annotation-stripped! parent new410)) (let loop ((i411 (- (vector-length x408) (quote 1)))) (unless (fx< i411 (quote 0)) (vector-set! new410 i411 (strip-annotation (vector-ref x408 i411) (quote #f))) (loop (fx- i411 (quote 1))))) new410))) (else x408)))) (ellipsis? (lambda (x412) (and (nonsymbol-id? x412) (free-id=? x412 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))))))) (chi-void (lambda () (list (quote void)))) (eval-local-transformer (lambda (expanded) (let ((p (local-eval-hook expanded))) (if (procedure? p) p (syntax-error p (quote "nonprocedure transfomer")))))) (chi-local-syntax (lambda (rec? e r w413 s k) ((lambda (tmp414) ((lambda (tmp415) (if tmp415 (apply (lambda (_416 id417 val e1 e2) (let ((ids418 id417)) (if (not (valid-bound-ids? ids418)) (syntax-error e (quote "duplicate bound keyword in")) (let ((labels (gen-labels ids418))) (let ((new-w (make-binding-wrap ids418 labels w413))) (k (cons e1 e2) (extend-env labels (let ((w421 (if rec? new-w w413)) (trans-r (macros-only-env r))) (map (lambda (x422) (cons (quote macro) (eval-local-transformer (chi x422 trans-r w421)))) val)) r) new-w s)))))) tmp415) ((lambda (_424) (syntax-error (source-wrap e w413 s))) tmp414))) (syntax-dispatch tmp414 (quote (any #(each (any any)) any . each-any))))) e))) (chi-lambda-clause (lambda (e425 c r426 w427 k428) ((lambda (tmp429) ((lambda (tmp430) (if tmp430 (apply (lambda (id431 e1432 e2433) (let ((ids434 id431)) (if (not (valid-bound-ids? ids434)) (syntax-error e425 (quote "invalid parameter list in")) (let ((labels436 (gen-labels ids434)) (new-vars (map gen-var ids434))) (k428 new-vars (chi-body (cons e1432 e2433) e425 (extend-var-env labels436 new-vars r426) (make-binding-wrap ids434 labels436 w427))))))) tmp430) ((lambda (tmp438) (if tmp438 (apply (lambda (ids439 e1440 e2441) (let ((old-ids (lambda-var-list ids439))) (if (not (valid-bound-ids? old-ids)) (syntax-error e425 (quote "invalid parameter list in")) (let ((labels442 (gen-labels old-ids)) (new-vars443 (map gen-var old-ids))) (k428 (let f444 ((ls1 (cdr new-vars443)) (ls2 (car new-vars443))) (if (null? ls1) ls2 (f444 (cdr ls1) (cons (car ls1) ls2)))) (chi-body (cons e1440 e2441) e425 (extend-var-env labels442 new-vars443 r426) (make-binding-wrap old-ids labels442 w427))))))) tmp438) ((lambda (_446) (syntax-error e425)) tmp429))) (syntax-dispatch tmp429 (quote (any any . each-any)))))) (syntax-dispatch tmp429 (quote (each-any any . each-any))))) c))) (chi-body (lambda (body outer-form r447 w448) (let ((r449 (cons (quote ("placeholder" placeholder)) r447))) (let ((ribcage (make-ribcage (quote ()) (quote ()) (quote ())))) (let ((w450 (make-wrap (wrap-marks w448) (cons ribcage (wrap-subst w448))))) (let parse ((body451 (map (lambda (x455) (cons r449 (wrap x455 w450))) body)) (ids452 (quote ())) (labels453 (quote ())) (vars454 (quote ())) (vals (quote ())) (bindings (quote ()))) (if (null? body451) (syntax-error outer-form (quote "no expressions in body")) (let ((e456 (cdar body451)) (er (caar body451))) (call-with-values (lambda () (syntax-type e456 er (quote (())) (quote #f) ribcage)) (lambda (type value e457 w458 s459) (let ((t type)) (if (memv t (quote (define-form))) (let ((id460 (wrap value w458)) (label (gen-label))) (let ((var (gen-var id460))) (begin (extend-ribcage! ribcage id460 label) (parse (cdr body451) (cons id460 ids452) (cons label labels453) (cons var vars454) (cons (cons er (wrap e457 w458)) vals) (cons (cons (quote lexical) var) bindings))))) (if (memv t (quote (define-syntax-form))) (let ((id461 (wrap value w458)) (label462 (gen-label))) (begin (extend-ribcage! ribcage id461 label462) (parse (cdr body451) (cons id461 ids452) (cons label462 labels453) vars454 vals (cons (cons (quote macro) (cons er (wrap e457 w458))) bindings)))) (if (memv t (quote (begin-form))) ((lambda (tmp463) ((lambda (tmp464) (if tmp464 (apply (lambda (_465 e1466) (parse (let f467 ((forms e1466)) (if (null? forms) (cdr body451) (cons (cons er (wrap (car forms) w458)) (f467 (cdr forms))))) ids452 labels453 vars454 vals bindings)) tmp464) (syntax-error tmp463))) (syntax-dispatch tmp463 (quote (any . each-any))))) e457) (if (memv t (quote (local-syntax-form))) (chi-local-syntax value e457 er w458 s459 (lambda (forms469 er470 w471 s472) (parse (let f473 ((forms474 forms469)) (if (null? forms474) (cdr body451) (cons (cons er470 (wrap (car forms474) w471)) (f473 (cdr forms474))))) ids452 labels453 vars454 vals bindings))) (if (null? ids452) (build-sequence (quote #f) (map (lambda (x475) (chi (cdr x475) (car x475) (quote (())))) (cons (cons er (source-wrap e457 w458 s459)) (cdr body451)))) (begin (if (not (valid-bound-ids? ids452)) (syntax-error outer-form (quote "invalid or duplicate identifier in definition"))) (let loop476 ((bs bindings) (er-cache (quote #f)) (r-cache (quote #f))) (if (not (null? bs)) (let ((b (car bs))) (if (eq? (car b) (quote macro)) (let ((er477 (cadr b))) (let ((r-cache478 (if (eq? er477 er-cache) r-cache (macros-only-env er477)))) (begin (set-cdr! b (eval-local-transformer (chi (cddr b) r-cache478 (quote (()))))) (loop476 (cdr bs) er477 r-cache478)))) (loop476 (cdr bs) er-cache r-cache))))) (set-cdr! r449 (extend-env labels453 bindings (cdr r449))) (build-letrec (quote #f) vars454 (map (lambda (x479) (chi (cdr x479) (car x479) (quote (())))) vals) (build-sequence (quote #f) (map (lambda (x480) (chi (cdr x480) (car x480) (quote (())))) (cons (cons er (source-wrap e457 w458 s459)) (cdr body451)))))))))))))))))))))) (chi-macro (lambda (p481 e482 r483 w484 rib) (letrec ((rebuild-macro-output (lambda (x485 m) (cond ((pair? x485) (cons (rebuild-macro-output (car x485) m) (rebuild-macro-output (cdr x485) m))) ((syntax-object? x485) (let ((w486 (syntax-object-wrap x485))) (let ((ms (wrap-marks w486)) (s487 (wrap-subst w486))) (make-syntax-object (syntax-object-expression x485) (if (and (pair? ms) (eq? (car ms) (quote #f))) (make-wrap (cdr ms) (if rib (cons rib (cdr s487)) (cdr s487))) (make-wrap (cons m ms) (if rib (cons rib (cons (quote shift) s487)) (cons (quote shift) s487)))))))) ((vector? x485) (let ((n (vector-length x485))) (let ((v (make-vector n))) (let doloop ((i488 (quote 0))) (if (fx= i488 n) v (begin (vector-set! v i488 (rebuild-macro-output (vector-ref x485 i488) m)) (doloop (fx+ i488 (quote 1))))))))) ((symbol? x485) (syntax-error x485 (quote "encountered raw symbol in macro output"))) (else x485))))) (rebuild-macro-output (p481 (wrap e482 (anti-mark w484))) (string (quote #\m)))))) (chi-application (lambda (x489 e490 r491 w492 s493) ((lambda (tmp494) ((lambda (tmp495) (if tmp495 (apply (lambda (e0 e1496) (cons x489 (map (lambda (e497) (chi e497 r491 w492)) e1496))) tmp495) (syntax-error tmp494))) (syntax-dispatch tmp494 (quote (any . each-any))))) e490))) (chi-expr (lambda (type499 value500 e501 r502 w503 s504) (let ((t505 type499)) (if (memv t505 (quote (lexical))) value500 (if (memv t505 (quote (core))) (value500 e501 r502 w503 s504) (if (memv t505 (quote (lexical-call))) (chi-application value500 e501 r502 w503 s504) (if (memv t505 (quote (global-call))) (chi-application value500 e501 r502 w503 s504) (if (memv t505 (quote (constant))) (list (quote quote) (strip (source-wrap e501 w503 s504) (quote (())))) (if (memv t505 (quote (global))) value500 (if (memv t505 (quote (call))) (chi-application (chi (car e501) r502 w503) e501 r502 w503 s504) (if (memv t505 (quote (begin-form))) ((lambda (tmp506) ((lambda (tmp507) (if tmp507 (apply (lambda (_508 e1509 e2510) (chi-sequence (cons e1509 e2510) r502 w503 s504)) tmp507) (syntax-error tmp506))) (syntax-dispatch tmp506 (quote (any any . each-any))))) e501) (if (memv t505 (quote (local-syntax-form))) (chi-local-syntax value500 e501 r502 w503 s504 chi-sequence) (if (memv t505 (quote (eval-when-form))) ((lambda (tmp512) ((lambda (tmp513) (if tmp513 (apply (lambda (_514 x515 e1516 e2517) (let ((when-list (chi-when-list e501 x515 w503))) (if (memq (quote eval) when-list) (chi-sequence (cons e1516 e2517) r502 w503 s504) (chi-void)))) tmp513) (syntax-error tmp512))) (syntax-dispatch tmp512 (quote (any each-any any . each-any))))) e501) (if (memv t505 (quote (define-form define-syntax-form))) (syntax-error (wrap value500 w503) (quote "invalid context for definition of")) (if (memv t505 (quote (syntax))) (syntax-error (source-wrap e501 w503 s504) (quote "reference to pattern variable outside syntax form")) (if (memv t505 (quote (displaced-lexical))) (syntax-error (source-wrap e501 w503 s504) (quote "reference to identifier outside its scope")) (syntax-error (source-wrap e501 w503 s504)))))))))))))))))) (chi (lambda (e520 r521 w522) (call-with-values (lambda () (syntax-type e520 r521 w522 (quote #f) (quote #f))) (lambda (type523 value524 e525 w526 s527) (chi-expr type523 value524 e525 r521 w526 s527))))) (chi-top (lambda (e528 r529 w530 m531 esew) (call-with-values (lambda () (syntax-type e528 r529 w530 (quote #f) (quote #f))) (lambda (type543 value544 e545 w546 s547) (let ((t548 type543)) (if (memv t548 (quote (begin-form))) ((lambda (tmp549) ((lambda (tmp550) (if tmp550 (apply (lambda (_551) (chi-void)) tmp550) ((lambda (tmp552) (if tmp552 (apply (lambda (_553 e1554 e2555) (chi-top-sequence (cons e1554 e2555) r529 w546 s547 m531 esew)) tmp552) (syntax-error tmp549))) (syntax-dispatch tmp549 (quote (any any . each-any)))))) (syntax-dispatch tmp549 (quote (any))))) e545) (if (memv t548 (quote (local-syntax-form))) (chi-local-syntax value544 e545 r529 w546 s547 (lambda (body557 r558 w559 s560) (chi-top-sequence body557 r558 w559 s560 m531 esew))) (if (memv t548 (quote (eval-when-form))) ((lambda (tmp561) ((lambda (tmp562) (if tmp562 (apply (lambda (_563 x564 e1565 e2566) (let ((when-list567 (chi-when-list e545 x564 w546)) (body568 (cons e1565 e2566))) (cond ((eq? m531 (quote e)) (if (memq (quote eval) when-list567) (chi-top-sequence body568 r529 w546 s547 (quote e) (quote (eval))) (chi-void))) ((memq (quote load) when-list567) (if (or (memq (quote compile) when-list567) (and (eq? m531 (quote c&e)) (memq (quote eval) when-list567))) (chi-top-sequence body568 r529 w546 s547 (quote c&e) (quote (compile load))) (if (memq m531 (quote (c c&e))) (chi-top-sequence body568 r529 w546 s547 (quote c) (quote (load))) (chi-void)))) ((or (memq (quote compile) when-list567) (and (eq? m531 (quote c&e)) (memq (quote eval) when-list567))) (top-level-eval-hook (chi-top-sequence body568 r529 w546 s547 (quote e) (quote (eval)))) (chi-void)) (else (chi-void))))) tmp562) (syntax-error tmp561))) (syntax-dispatch tmp561 (quote (any each-any any . each-any))))) e545) (if (memv t548 (quote (define-syntax-form))) (let ((n571 (id-var-name value544 w546)) (r572 (macros-only-env r529))) (let ((t573 m531)) (if (memv t573 (quote (c))) (if (memq (quote compile) esew) (let ((e574 (chi-install-global n571 (chi e545 r572 w546)))) (begin (top-level-eval-hook e574) (if (memq (quote load) esew) e574 (chi-void)))) (if (memq (quote load) esew) (chi-install-global n571 (chi e545 r572 w546)) (chi-void))) (if (memv t573 (quote (c&e))) (let ((e575 (chi-install-global n571 (chi e545 r572 w546)))) (begin (top-level-eval-hook e575) e575)) (begin (if (memq (quote eval) esew) (top-level-eval-hook (chi-install-global n571 (chi e545 r572 w546)))) (chi-void)))))) (if (memv t548 (quote (define-form))) (let ((n576 (id-var-name value544 w546))) (let ((t577 (binding-type (lookup n576 r529)))) (if (memv t577 (quote (global))) (let ((x578 (list (quote define) n576 (chi e545 r529 w546)))) (begin (if (eq? m531 (quote c&e)) (top-level-eval-hook x578)) x578)) (if (memv t577 (quote (displaced-lexical))) (syntax-error (wrap value544 w546) (quote "identifier out of context")) (syntax-error (wrap value544 w546) (quote "cannot define keyword at top level")))))) (let ((x579 (chi-expr type543 value544 e545 r529 w546 s547))) (begin (if (eq? m531 (quote c&e)) (top-level-eval-hook x579)) x579)))))))))))) (syntax-type (lambda (e580 r581 w582 s583 rib584) (cond ((symbol? e580) (let ((n585 (id-var-name e580 w582))) (let ((b586 (lookup n585 r581))) (let ((type587 (binding-type b586))) (let ((t588 type587)) (if (memv t588 (quote (lexical))) (values type587 (binding-value b586) e580 w582 s583) (if (memv t588 (quote (global))) (values type587 n585 e580 w582 s583) (if (memv t588 (quote (macro))) (syntax-type (chi-macro (binding-value b586) e580 r581 w582 rib584) r581 (quote (())) s583 rib584) (values type587 (binding-value b586) e580 w582 s583))))))))) ((pair? e580) (let ((first (car e580))) (if (id? first) (let ((n589 (id-var-name first w582))) (let ((b590 (lookup n589 r581))) (let ((type591 (binding-type b590))) (let ((t592 type591)) (if (memv t592 (quote (lexical))) (values (quote lexical-call) (binding-value b590) e580 w582 s583) (if (memv t592 (quote (global))) (values (quote global-call) n589 e580 w582 s583) (if (memv t592 (quote (macro))) (syntax-type (chi-macro (binding-value b590) e580 r581 w582 rib584) r581 (quote (())) s583 rib584) (if (memv t592 (quote (core))) (values type591 (binding-value b590) e580 w582 s583) (if (memv t592 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value b590) e580 w582 s583) (if (memv t592 (quote (begin))) (values (quote begin-form) (quote #f) e580 w582 s583) (if (memv t592 (quote (eval-when))) (values (quote eval-when-form) (quote #f) e580 w582 s583) (if (memv t592 (quote (define))) ((lambda (tmp593) ((lambda (tmp594) (if (if tmp594 (apply (lambda (_595 name596 val597) (id? name596)) tmp594) (quote #f)) (apply (lambda (_598 name599 val600) (values (quote define-form) name599 val600 w582 s583)) tmp594) ((lambda (tmp601) (if (if tmp601 (apply (lambda (_602 name603 args604 e1605 e2606) (and (id? name603) (valid-bound-ids? (lambda-var-list args604)))) tmp601) (quote #f)) (apply (lambda (_607 name608 args609 e1610 e2611) (values (quote define-form) (wrap name608 w582) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) (wrap (cons args609 (cons e1610 e2611)) w582)) (quote (())) s583)) tmp601) ((lambda (tmp613) (if (if tmp613 (apply (lambda (_614 name615) (id? name615)) tmp613) (quote #f)) (apply (lambda (_616 name617) (values (quote define-form) (wrap name617 w582) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote (())) s583)) tmp613) (syntax-error tmp593))) (syntax-dispatch tmp593 (quote (any any)))))) (syntax-dispatch tmp593 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp593 (quote (any any any))))) e580) (if (memv t592 (quote (define-syntax))) ((lambda (tmp618) ((lambda (tmp619) (if (if tmp619 (apply (lambda (_620 name621 val622) (id? name621)) tmp619) (quote #f)) (apply (lambda (_623 name624 val625) (values (quote define-syntax-form) name624 val625 w582 s583)) tmp619) (syntax-error tmp618))) (syntax-dispatch tmp618 (quote (any any any))))) e580) (values (quote call) (quote #f) e580 w582 s583)))))))))))))) (values (quote call) (quote #f) e580 w582 s583)))) ((syntax-object? e580) (syntax-type (syntax-object-expression e580) r581 (join-wraps w582 (syntax-object-wrap e580)) (quote #f) rib584)) ((annotation? e580) (syntax-type (annotation-expression e580) r581 w582 (annotation-source e580) rib584)) ((let ((x626 e580)) (or (boolean? x626) (number? x626) (string? x626) (char? x626) (null? x626) (keyword? x626))) (values (quote constant) (quote #f) e580 w582 s583)) (else (values (quote other) (quote #f) e580 w582 s583))))) (chi-when-list (lambda (e627 when-list628 w629) (let f630 ((when-list631 when-list628) (situations (quote ()))) (if (null? when-list631) situations (f630 (cdr when-list631) (cons (let ((x632 (car when-list631))) (cond ((free-id=? x632 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote compile)) ((free-id=? x632 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote load)) ((free-id=? x632 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote eval)) (else (syntax-error (wrap x632 w629) (quote "invalid eval-when situation"))))) situations)))))) (chi-install-global (lambda (name633 e634) (list (quote install-global-transformer) (list (quote quote) name633) e634))) (chi-top-sequence (lambda (body635 r636 w637 s638 m639 esew640) (build-sequence s638 (let dobody ((body641 body635) (r642 r636) (w643 w637) (m644 m639) (esew645 esew640)) (if (null? body641) (quote ()) (let ((first646 (chi-top (car body641) r642 w643 m644 esew645))) (cons first646 (dobody (cdr body641) r642 w643 m644 esew645)))))))) (chi-sequence (lambda (body647 r648 w649 s650) (build-sequence s650 (let dobody651 ((body652 body647) (r653 r648) (w654 w649)) (if (null? body652) (quote ()) (let ((first655 (chi (car body652) r653 w654))) (cons first655 (dobody651 (cdr body652) r653 w654)))))))) (source-wrap (lambda (x656 w657 s658) (wrap (if s658 (make-annotation x656 s658 (quote #f)) x656) w657))) (wrap (lambda (x659 w660) (cond ((and (null? (wrap-marks w660)) (null? (wrap-subst w660))) x659) ((syntax-object? x659) (make-syntax-object (syntax-object-expression x659) (join-wraps w660 (syntax-object-wrap x659)))) ((null? x659) x659) (else (make-syntax-object x659 w660))))) (bound-id-member? (lambda (x661 list) (and (not (null? list)) (or (bound-id=? x661 (car list)) (bound-id-member? x661 (cdr list)))))) (distinct-bound-ids? (lambda (ids662) (let distinct? ((ids663 ids662)) (or (null? ids663) (and (not (bound-id-member? (car ids663) (cdr ids663))) (distinct? (cdr ids663))))))) (valid-bound-ids? (lambda (ids664) (and (let all-ids? ((ids665 ids664)) (or (null? ids665) (and (id? (car ids665)) (all-ids? (cdr ids665))))) (distinct-bound-ids? ids664)))) (bound-id=? (lambda (i666 j) (if (and (syntax-object? i666) (syntax-object? j)) (and (eq? (let ((e667 (syntax-object-expression i666))) (if (annotation? e667) (annotation-expression e667) e667)) (let ((e668 (syntax-object-expression j))) (if (annotation? e668) (annotation-expression e668) e668))) (same-marks? (wrap-marks (syntax-object-wrap i666)) (wrap-marks (syntax-object-wrap j)))) (eq? (let ((e669 i666)) (if (annotation? e669) (annotation-expression e669) e669)) (let ((e670 j)) (if (annotation? e670) (annotation-expression e670) e670)))))) (free-id=? (lambda (i671 j672) (and (eq? (let ((x673 i671)) (let ((e674 (if (syntax-object? x673) (syntax-object-expression x673) x673))) (if (annotation? e674) (annotation-expression e674) e674))) (let ((x675 j672)) (let ((e676 (if (syntax-object? x675) (syntax-object-expression x675) x675))) (if (annotation? e676) (annotation-expression e676) e676)))) (eq? (id-var-name i671 (quote (()))) (id-var-name j672 (quote (()))))))) (id-var-name (lambda (id677 w678) (letrec ((search-vector-rib (lambda (sym subst marks symnames ribcage688) (let ((n689 (vector-length symnames))) (let f690 ((i691 (quote 0))) (cond ((fx= i691 n689) (search sym (cdr subst) marks)) ((and (eq? (vector-ref symnames i691) sym) (same-marks? marks (vector-ref (ribcage-marks ribcage688) i691))) (values (vector-ref (ribcage-labels ribcage688) i691) marks)) (else (f690 (fx+ i691 (quote 1))))))))) (search-list-rib (lambda (sym692 subst693 marks694 symnames695 ribcage696) (let f697 ((symnames698 symnames695) (i699 (quote 0))) (cond ((null? symnames698) (search sym692 (cdr subst693) marks694)) ((and (eq? (car symnames698) sym692) (same-marks? marks694 (list-ref (ribcage-marks ribcage696) i699))) (values (list-ref (ribcage-labels ribcage696) i699) marks694)) (else (f697 (cdr symnames698) (fx+ i699 (quote 1)))))))) (search (lambda (sym700 subst701 marks702) (if (null? subst701) (values (quote #f) marks702) (let ((fst (car subst701))) (if (eq? fst (quote shift)) (search sym700 (cdr subst701) (cdr marks702)) (let ((symnames703 (ribcage-symnames fst))) (if (vector? symnames703) (search-vector-rib sym700 subst701 marks702 symnames703 fst) (search-list-rib sym700 subst701 marks702 symnames703 fst))))))))) (cond ((symbol? id677) (or (call-with-values (lambda () (search id677 (wrap-subst w678) (wrap-marks w678))) (lambda (x704 . ignore) x704)) id677)) ((syntax-object? id677) (let ((id705 (let ((e706 (syntax-object-expression id677))) (if (annotation? e706) (annotation-expression e706) e706))) (w1 (syntax-object-wrap id677))) (let ((marks707 (join-marks (wrap-marks w678) (wrap-marks w1)))) (call-with-values (lambda () (search id705 (wrap-subst w678) marks707)) (lambda (new-id marks708) (or new-id (call-with-values (lambda () (search id705 (wrap-subst w1) marks708)) (lambda (x710 . ignore709) x710)) id705)))))) ((annotation? id677) (let ((id711 (let ((e712 id677)) (if (annotation? e712) (annotation-expression e712) e712)))) (or (call-with-values (lambda () (search id711 (wrap-subst w678) (wrap-marks w678))) (lambda (x714 . ignore713) x714)) id711))) (else (error-hook (quote id-var-name) (quote "invalid id") id677)))))) (same-marks? (lambda (x715 y) (or (eq? x715 y) (and (not (null? x715)) (not (null? y)) (eq? (car x715) (car y)) (same-marks? (cdr x715) (cdr y)))))) (join-marks (lambda (m1 m2) (smart-append m1 m2))) (join-wraps (lambda (w1716 w2) (let ((m1717 (wrap-marks w1716)) (s1 (wrap-subst w1716))) (if (null? m1717) (if (null? s1) w2 (make-wrap (wrap-marks w2) (smart-append s1 (wrap-subst w2)))) (make-wrap (smart-append m1717 (wrap-marks w2)) (smart-append s1 (wrap-subst w2))))))) (smart-append (lambda (m1718 m2719) (if (null? m2719) m1718 (append m1718 m2719)))) (make-binding-wrap (lambda (ids720 labels721 w722) (if (null? ids720) w722 (make-wrap (wrap-marks w722) (cons (let ((labelvec (list->vector labels721))) (let ((n723 (vector-length labelvec))) (let ((symnamevec (make-vector n723)) (marksvec (make-vector n723))) (begin (let f724 ((ids725 ids720) (i726 (quote 0))) (if (not (null? ids725)) (call-with-values (lambda () (id-sym-name&marks (car ids725) w722)) (lambda (symname marks727) (begin (vector-set! symnamevec i726 symname) (vector-set! marksvec i726 marks727) (f724 (cdr ids725) (fx+ i726 (quote 1)))))))) (make-ribcage symnamevec marksvec labelvec))))) (wrap-subst w722)))))) (extend-ribcage! (lambda (ribcage728 id729 label730) (begin (set-ribcage-symnames! ribcage728 (cons (let ((e731 (syntax-object-expression id729))) (if (annotation? e731) (annotation-expression e731) e731)) (ribcage-symnames ribcage728))) (set-ribcage-marks! ribcage728 (cons (wrap-marks (syntax-object-wrap id729)) (ribcage-marks ribcage728))) (set-ribcage-labels! ribcage728 (cons label730 (ribcage-labels ribcage728)))))) (anti-mark (lambda (w732) (make-wrap (cons (quote #f) (wrap-marks w732)) (cons (quote shift) (wrap-subst w732))))) (set-ribcage-labels! (lambda (x733 update) (vector-set! x733 (quote 3) update))) (set-ribcage-marks! (lambda (x734 update735) (vector-set! x734 (quote 2) update735))) (set-ribcage-symnames! (lambda (x736 update737) (vector-set! x736 (quote 1) update737))) (ribcage-labels (lambda (x738) (vector-ref x738 (quote 3)))) (ribcage-marks (lambda (x739) (vector-ref x739 (quote 2)))) (ribcage-symnames (lambda (x740) (vector-ref x740 (quote 1)))) (ribcage? (lambda (x741) (and (vector? x741) (= (vector-length x741) (quote 4)) (eq? (vector-ref x741 (quote 0)) (quote ribcage))))) (make-ribcage (lambda (symnames742 marks743 labels744) (vector (quote ribcage) symnames742 marks743 labels744))) (gen-labels (lambda (ls745) (if (null? ls745) (quote ()) (cons (gen-label) (gen-labels (cdr ls745)))))) (gen-label (lambda () (string (quote #\i)))) (wrap-subst cdr) (wrap-marks car) (make-wrap cons) (id-sym-name&marks (lambda (x746 w747) (if (syntax-object? x746) (values (let ((e748 (syntax-object-expression x746))) (if (annotation? e748) (annotation-expression e748) e748)) (join-marks (wrap-marks w747) (wrap-marks (syntax-object-wrap x746)))) (values (let ((e749 x746)) (if (annotation? e749) (annotation-expression e749) e749)) (wrap-marks w747))))) (id? (lambda (x750) (cond ((symbol? x750) (quote #t)) ((syntax-object? x750) (symbol? (let ((e751 (syntax-object-expression x750))) (if (annotation? e751) (annotation-expression e751) e751)))) ((annotation? x750) (symbol? (annotation-expression x750))) (else (quote #f))))) (nonsymbol-id? (lambda (x752) (and (syntax-object? x752) (symbol? (let ((e753 (syntax-object-expression x752))) (if (annotation? e753) (annotation-expression e753) e753)))))) (global-extend (lambda (type754 sym755 val756) (put-global-definition-hook sym755 (cons type754 val756)))) (lookup (lambda (x757 r758) (cond ((assq x757 r758) => cdr) ((symbol? x757) (or (get-global-definition-hook x757) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env (lambda (r759) (if (null? r759) (quote ()) (let ((a760 (car r759))) (if (eq? (cadr a760) (quote macro)) (cons a760 (macros-only-env (cdr r759))) (macros-only-env (cdr r759))))))) (extend-var-env (lambda (labels761 vars762 r763) (if (null? labels761) r763 (extend-var-env (cdr labels761) (cdr vars762) (cons (cons (car labels761) (cons (quote lexical) (car vars762))) r763))))) (extend-env (lambda (labels764 bindings765 r766) (if (null? labels764) r766 (extend-env (cdr labels764) (cdr bindings765) (cons (cons (car labels764) (car bindings765)) r766))))) (binding-value cdr) (binding-type car) (source-annotation (lambda (x767) (cond ((annotation? x767) (annotation-source x767)) ((syntax-object? x767) (source-annotation (syntax-object-expression x767))) (else (quote #f))))) (set-syntax-object-wrap! (lambda (x768 update769) (vector-set! x768 (quote 2) update769))) (set-syntax-object-expression! (lambda (x770 update771) (vector-set! x770 (quote 1) update771))) (syntax-object-wrap (lambda (x772) (vector-ref x772 (quote 2)))) (syntax-object-expression (lambda (x773) (vector-ref x773 (quote 1)))) (syntax-object? (lambda (x774) (and (vector? x774) (= (vector-length x774) (quote 3)) (eq? (vector-ref x774 (quote 0)) (quote syntax-object))))) (make-syntax-object (lambda (expression wrap775) (vector (quote syntax-object) expression wrap775))) (build-letrec (lambda (src vars776 val-exps body-exp) (if (null? vars776) body-exp (list (quote letrec) (map list vars776 val-exps) body-exp)))) (build-named-let (lambda (src777 vars778 val-exps779 body-exp780) (if (null? vars778) body-exp780 (list (quote let) (car vars778) (map list (cdr vars778) val-exps779) body-exp780)))) (build-let (lambda (src781 vars782 val-exps783 body-exp784) (if (null? vars782) body-exp784 (list (quote let) (map list vars782 val-exps783) body-exp784)))) (build-sequence (lambda (src785 exps) (if (null? (cdr exps)) (car exps) (cons (quote begin) exps)))) (get-global-definition-hook (lambda (symbol) (getprop symbol (quote *sc-expander*)))) (put-global-definition-hook (lambda (symbol786 binding) (putprop symbol786 (quote *sc-expander*) binding))) (error-hook (lambda (who why what) (error who (quote "~a ~s") why what))) (local-eval-hook (lambda (x787) (eval (list noexpand x787) (interaction-environment)))) (top-level-eval-hook (lambda (x788) (eval (list noexpand x788) (interaction-environment)))) (annotation? (lambda (x789) (quote #f))) (fx< <) (fx= =) (fx- -) (fx+ +) (noexpand (quote "noexpand"))) (begin (global-extend (quote local-syntax) (quote letrec-syntax) (quote #t)) (global-extend (quote local-syntax) (quote let-syntax) (quote #f)) (global-extend (quote core) (quote fluid-let-syntax) (lambda (e790 r791 w792 s793) ((lambda (tmp794) ((lambda (tmp795) (if (if tmp795 (apply (lambda (_796 var797 val798 e1799 e2800) (valid-bound-ids? var797)) tmp795) (quote #f)) (apply (lambda (_802 var803 val804 e1805 e2806) (let ((names (map (lambda (x807) (id-var-name x807 w792)) var803))) (begin (for-each (lambda (id809 n810) (let ((t811 (binding-type (lookup n810 r791)))) (if (memv t811 (quote (displaced-lexical))) (syntax-error (source-wrap id809 w792 s793) (quote "identifier out of context"))))) var803 names) (chi-body (cons e1805 e2806) (source-wrap e790 w792 s793) (extend-env names (let ((trans-r814 (macros-only-env r791))) (map (lambda (x815) (cons (quote macro) (eval-local-transformer (chi x815 trans-r814 w792)))) val804)) r791) w792)))) tmp795) ((lambda (_817) (syntax-error (source-wrap e790 w792 s793))) tmp794))) (syntax-dispatch tmp794 (quote (any #(each (any any)) any . each-any))))) e790))) (global-extend (quote core) (quote quote) (lambda (e818 r819 w820 s821) ((lambda (tmp822) ((lambda (tmp823) (if tmp823 (apply (lambda (_824 e825) (list (quote quote) (strip e825 w820))) tmp823) ((lambda (_826) (syntax-error (source-wrap e818 w820 s821))) tmp822))) (syntax-dispatch tmp822 (quote (any any))))) e818))) (global-extend (quote core) (quote syntax) (letrec ((regen (lambda (x827) (let ((t828 (car x827))) (if (memv t828 (quote (ref))) (cadr x827) (if (memv t828 (quote (primitive))) (cadr x827) (if (memv t828 (quote (quote))) (list (quote quote) (cadr x827)) (if (memv t828 (quote (lambda))) (list (quote lambda) (cadr x827) (regen (caddr x827))) (if (memv t828 (quote (map))) (let ((ls829 (map regen (cdr x827)))) (cons (if (fx= (length ls829) (quote 2)) (quote map) (quote map)) ls829)) (cons (car x827) (map regen (cdr x827))))))))))) (gen-vector (lambda (x830) (cond ((eq? (car x830) (quote list)) (cons (quote vector) (cdr x830))) ((eq? (car x830) (quote quote)) (list (quote quote) (list->vector (cadr x830)))) (else (list (quote list->vector) x830))))) (gen-append (lambda (x831 y832) (if (equal? y832 (quote (quote ()))) x831 (list (quote append) x831 y832)))) (gen-cons (lambda (x833 y834) (let ((t835 (car y834))) (if (memv t835 (quote (quote))) (if (eq? (car x833) (quote quote)) (list (quote quote) (cons (cadr x833) (cadr y834))) (if (eq? (cadr y834) (quote ())) (list (quote list) x833) (list (quote cons) x833 y834))) (if (memv t835 (quote (list))) (cons (quote list) (cons x833 (cdr y834))) (list (quote cons) x833 y834)))))) (gen-map (lambda (e836 map-env) (let ((formals (map cdr map-env)) (actuals (map (lambda (x837) (list (quote ref) (car x837))) map-env))) (cond ((eq? (car e836) (quote ref)) (car actuals)) ((andmap (lambda (x838) (and (eq? (car x838) (quote ref)) (memq (cadr x838) formals))) (cdr e836)) (cons (quote map) (cons (list (quote primitive) (car e836)) (map (let ((r839 (map cons formals actuals))) (lambda (x840) (cdr (assq (cadr x840) r839)))) (cdr e836))))) (else (cons (quote map) (cons (list (quote lambda) formals e836) actuals))))))) (gen-mappend (lambda (e841 map-env842) (list (quote apply) (quote (primitive append)) (gen-map e841 map-env842)))) (gen-ref (lambda (src843 var844 level maps) (if (fx= level (quote 0)) (values var844 maps) (if (null? maps) (syntax-error src843 (quote "missing ellipsis in syntax form")) (call-with-values (lambda () (gen-ref src843 var844 (fx- level (quote 1)) (cdr maps))) (lambda (outer-var outer-maps) (let ((b845 (assq outer-var (car maps)))) (if b845 (values (cdr b845) maps) (let ((inner-var (gen-var (quote tmp)))) (values inner-var (cons (cons (cons outer-var inner-var) (car maps)) outer-maps))))))))))) (gen-syntax (lambda (src846 e847 r848 maps849 ellipsis?850) (if (id? e847) (let ((label851 (id-var-name e847 (quote (()))))) (let ((b852 (lookup label851 r848))) (if (eq? (binding-type b852) (quote syntax)) (call-with-values (lambda () (let ((var.lev (binding-value b852))) (gen-ref src846 (car var.lev) (cdr var.lev) maps849))) (lambda (var853 maps854) (values (list (quote ref) var853) maps854))) (if (ellipsis?850 e847) (syntax-error src846 (quote "misplaced ellipsis in syntax form")) (values (list (quote quote) e847) maps849))))) ((lambda (tmp855) ((lambda (tmp856) (if (if tmp856 (apply (lambda (dots e857) (ellipsis?850 dots)) tmp856) (quote #f)) (apply (lambda (dots858 e859) (gen-syntax src846 e859 r848 maps849 (lambda (x860) (quote #f)))) tmp856) ((lambda (tmp861) (if (if tmp861 (apply (lambda (x862 dots863 y864) (ellipsis?850 dots863)) tmp861) (quote #f)) (apply (lambda (x865 dots866 y867) (let f868 ((y869 y867) (k870 (lambda (maps871) (call-with-values (lambda () (gen-syntax src846 x865 r848 (cons (quote ()) maps871) ellipsis?850)) (lambda (x872 maps873) (if (null? (car maps873)) (syntax-error src846 (quote "extra ellipsis in syntax form")) (values (gen-map x872 (car maps873)) (cdr maps873)))))))) ((lambda (tmp874) ((lambda (tmp875) (if (if tmp875 (apply (lambda (dots876 y877) (ellipsis?850 dots876)) tmp875) (quote #f)) (apply (lambda (dots878 y879) (f868 y879 (lambda (maps880) (call-with-values (lambda () (k870 (cons (quote ()) maps880))) (lambda (x881 maps882) (if (null? (car maps882)) (syntax-error src846 (quote "extra ellipsis in syntax form")) (values (gen-mappend x881 (car maps882)) (cdr maps882)))))))) tmp875) ((lambda (_883) (call-with-values (lambda () (gen-syntax src846 y869 r848 maps849 ellipsis?850)) (lambda (y884 maps885) (call-with-values (lambda () (k870 maps885)) (lambda (x886 maps887) (values (gen-append x886 y884) maps887)))))) tmp874))) (syntax-dispatch tmp874 (quote (any . any))))) y869))) tmp861) ((lambda (tmp888) (if tmp888 (apply (lambda (x889 y890) (call-with-values (lambda () (gen-syntax src846 x889 r848 maps849 ellipsis?850)) (lambda (x891 maps892) (call-with-values (lambda () (gen-syntax src846 y890 r848 maps892 ellipsis?850)) (lambda (y893 maps894) (values (gen-cons x891 y893) maps894)))))) tmp888) ((lambda (tmp895) (if tmp895 (apply (lambda (e1896 e2897) (call-with-values (lambda () (gen-syntax src846 (cons e1896 e2897) r848 maps849 ellipsis?850)) (lambda (e899 maps900) (values (gen-vector e899) maps900)))) tmp895) ((lambda (_901) (values (list (quote quote) e847) maps849)) tmp855))) (syntax-dispatch tmp855 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp855 (quote (any . any)))))) (syntax-dispatch tmp855 (quote (any any . any)))))) (syntax-dispatch tmp855 (quote (any any))))) e847))))) (lambda (e902 r903 w904 s905) (let ((e906 (source-wrap e902 w904 s905))) ((lambda (tmp907) ((lambda (tmp908) (if tmp908 (apply (lambda (_909 x910) (call-with-values (lambda () (gen-syntax e906 x910 r903 (quote ()) ellipsis?)) (lambda (e911 maps912) (regen e911)))) tmp908) ((lambda (_913) (syntax-error e906)) tmp907))) (syntax-dispatch tmp907 (quote (any any))))) e906))))) (global-extend (quote core) (quote lambda) (lambda (e914 r915 w916 s917) ((lambda (tmp918) ((lambda (tmp919) (if tmp919 (apply (lambda (_920 c921) (chi-lambda-clause (source-wrap e914 w916 s917) c921 r915 w916 (lambda (vars922 body923) (list (quote lambda) vars922 body923)))) tmp919) (syntax-error tmp918))) (syntax-dispatch tmp918 (quote (any . any))))) e914))) (global-extend (quote core) (quote let) (letrec ((chi-let (lambda (e924 r925 w926 s927 constructor928 ids929 vals930 exps931) (if (not (valid-bound-ids? ids929)) (syntax-error e924 (quote "duplicate bound variable in")) (let ((labels932 (gen-labels ids929)) (new-vars933 (map gen-var ids929))) (let ((nw (make-binding-wrap ids929 labels932 w926)) (nr (extend-var-env labels932 new-vars933 r925))) (constructor928 s927 new-vars933 (map (lambda (x934) (chi x934 r925 w926)) vals930) (chi-body exps931 (source-wrap e924 nw s927) nr nw)))))))) (lambda (e935 r936 w937 s938) ((lambda (tmp939) ((lambda (tmp940) (if tmp940 (apply (lambda (_941 id942 val943 e1944 e2945) (chi-let e935 r936 w937 s938 build-let id942 val943 (cons e1944 e2945))) tmp940) ((lambda (tmp949) (if (if tmp949 (apply (lambda (_950 f951 id952 val953 e1954 e2955) (id? f951)) tmp949) (quote #f)) (apply (lambda (_956 f957 id958 val959 e1960 e2961) (chi-let e935 r936 w937 s938 build-named-let (cons f957 id958) val959 (cons e1960 e2961))) tmp949) ((lambda (_965) (syntax-error (source-wrap e935 w937 s938))) tmp939))) (syntax-dispatch tmp939 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp939 (quote (any #(each (any any)) any . each-any))))) e935)))) (global-extend (quote core) (quote letrec) (lambda (e966 r967 w968 s969) ((lambda (tmp970) ((lambda (tmp971) (if tmp971 (apply (lambda (_972 id973 val974 e1975 e2976) (let ((ids977 id973)) (if (not (valid-bound-ids? ids977)) (syntax-error e966 (quote "duplicate bound variable in")) (let ((labels979 (gen-labels ids977)) (new-vars980 (map gen-var ids977))) (let ((w981 (make-binding-wrap ids977 labels979 w968)) (r982 (extend-var-env labels979 new-vars980 r967))) (build-letrec s969 new-vars980 (map (lambda (x983) (chi x983 r982 w981)) val974) (chi-body (cons e1975 e2976) (source-wrap e966 w981 s969) r982 w981))))))) tmp971) ((lambda (_986) (syntax-error (source-wrap e966 w968 s969))) tmp970))) (syntax-dispatch tmp970 (quote (any #(each (any any)) any . each-any))))) e966))) (global-extend (quote core) (quote set!) (lambda (e987 r988 w989 s990) ((lambda (tmp991) ((lambda (tmp992) (if (if tmp992 (apply (lambda (_993 id994 val995) (id? id994)) tmp992) (quote #f)) (apply (lambda (_996 id997 val998) (let ((val999 (chi val998 r988 w989)) (n1000 (id-var-name id997 w989))) (let ((b1001 (lookup n1000 r988))) (let ((t1002 (binding-type b1001))) (if (memv t1002 (quote (lexical))) (list (quote set!) (binding-value b1001) val999) (if (memv t1002 (quote (global))) (list (quote set!) n1000 val999) (if (memv t1002 (quote (displaced-lexical))) (syntax-error (wrap id997 w989) (quote "identifier out of context")) (syntax-error (source-wrap e987 w989 s990))))))))) tmp992) ((lambda (_1003) (syntax-error (source-wrap e987 w989 s990))) tmp991))) (syntax-dispatch tmp991 (quote (any any any))))) e987))) (global-extend (quote begin) (quote begin) (quote ())) (global-extend (quote define) (quote define) (quote ())) (global-extend (quote define-syntax) (quote define-syntax) (quote ())) (global-extend (quote eval-when) (quote eval-when) (quote ())) (global-extend (quote core) (quote syntax-case) (letrec ((gen-syntax-case (lambda (x1004 keys clauses r1005) (if (null? clauses) (list (quote syntax-error) x1004) ((lambda (tmp1006) ((lambda (tmp1007) (if tmp1007 (apply (lambda (pat exp) (if (and (id? pat) (andmap (lambda (x1008) (not (free-id=? pat x1008))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) keys))) (let ((labels1009 (list (gen-label))) (var1010 (gen-var pat))) (list (list (quote lambda) (list var1010) (chi exp (extend-env labels1009 (list (cons (quote syntax) (cons var1010 (quote 0)))) r1005) (make-binding-wrap (list pat) labels1009 (quote (()))))) x1004)) (gen-clause x1004 keys (cdr clauses) r1005 pat (quote #t) exp))) tmp1007) ((lambda (tmp1011) (if tmp1011 (apply (lambda (pat1012 fender exp1013) (gen-clause x1004 keys (cdr clauses) r1005 pat1012 fender exp1013)) tmp1011) ((lambda (_1014) (syntax-error (car clauses) (quote "invalid syntax-case clause"))) tmp1006))) (syntax-dispatch tmp1006 (quote (any any any)))))) (syntax-dispatch tmp1006 (quote (any any))))) (car clauses))))) (gen-clause (lambda (x1015 keys1016 clauses1017 r1018 pat1019 fender1020 exp1021) (call-with-values (lambda () (convert-pattern pat1019 keys1016)) (lambda (p1022 pvars) (cond ((not (distinct-bound-ids? (map car pvars))) (syntax-error pat1019 (quote "duplicate pattern variable in syntax-case pattern"))) ((not (andmap (lambda (x1023) (not (ellipsis? (car x1023)))) pvars)) (syntax-error pat1019 (quote "misplaced ellipsis in syntax-case pattern"))) (else (let ((y1024 (gen-var (quote tmp)))) (list (list (quote lambda) (list y1024) (let ((y1025 y1024)) (list (quote if) ((lambda (tmp1026) ((lambda (tmp1027) (if tmp1027 (apply (lambda () y1025) tmp1027) ((lambda (_1028) (list (quote if) y1025 (build-dispatch-call pvars fender1020 y1025 r1018) (list (quote quote) (quote #f)))) tmp1026))) (syntax-dispatch tmp1026 (quote #(atom #t))))) fender1020) (build-dispatch-call pvars exp1021 y1025 r1018) (gen-syntax-case x1015 keys1016 clauses1017 r1018)))) (if (eq? p1022 (quote any)) (list (quote list) x1015) (list (quote syntax-dispatch) x1015 (list (quote quote) p1022))))))))))) (build-dispatch-call (lambda (pvars1029 exp1030 y1031 r1032) (let ((ids1033 (map car pvars1029)) (levels (map cdr pvars1029))) (let ((labels1034 (gen-labels ids1033)) (new-vars1035 (map gen-var ids1033))) (list (quote apply) (list (quote lambda) new-vars1035 (chi exp1030 (extend-env labels1034 (map (lambda (var1036 level1037) (cons (quote syntax) (cons var1036 level1037))) new-vars1035 (map cdr pvars1029)) r1032) (make-binding-wrap ids1033 labels1034 (quote (()))))) y1031))))) (convert-pattern (lambda (pattern keys1038) (let cvt ((p1039 pattern) (n1040 (quote 0)) (ids1041 (quote ()))) (if (id? p1039) (if (bound-id-member? p1039 keys1038) (values (vector (quote free-id) p1039) ids1041) (values (quote any) (cons (cons p1039 n1040) ids1041))) ((lambda (tmp1042) ((lambda (tmp1043) (if (if tmp1043 (apply (lambda (x1044 dots1045) (ellipsis? dots1045)) tmp1043) (quote #f)) (apply (lambda (x1046 dots1047) (call-with-values (lambda () (cvt x1046 (fx+ n1040 (quote 1)) ids1041)) (lambda (p1048 ids1049) (values (if (eq? p1048 (quote any)) (quote each-any) (vector (quote each) p1048)) ids1049)))) tmp1043) ((lambda (tmp1050) (if tmp1050 (apply (lambda (x1051 y1052) (call-with-values (lambda () (cvt y1052 n1040 ids1041)) (lambda (y1053 ids1054) (call-with-values (lambda () (cvt x1051 n1040 ids1054)) (lambda (x1055 ids1056) (values (cons x1055 y1053) ids1056)))))) tmp1050) ((lambda (tmp1057) (if tmp1057 (apply (lambda () (values (quote ()) ids1041)) tmp1057) ((lambda (tmp1058) (if tmp1058 (apply (lambda (x1059) (call-with-values (lambda () (cvt x1059 n1040 ids1041)) (lambda (p1061 ids1062) (values (vector (quote vector) p1061) ids1062)))) tmp1058) ((lambda (x1063) (values (vector (quote atom) (strip p1039 (quote (())))) ids1041)) tmp1042))) (syntax-dispatch tmp1042 (quote #(vector each-any)))))) (syntax-dispatch tmp1042 (quote ()))))) (syntax-dispatch tmp1042 (quote (any . any)))))) (syntax-dispatch tmp1042 (quote (any any))))) p1039)))))) (lambda (e1064 r1065 w1066 s1067) (let ((e1068 (source-wrap e1064 w1066 s1067))) ((lambda (tmp1069) ((lambda (tmp1070) (if tmp1070 (apply (lambda (_1071 val1072 key m1073) (if (andmap (lambda (x1074) (and (id? x1074) (not (ellipsis? x1074)))) key) (let ((x1076 (gen-var (quote tmp)))) (list (list (quote lambda) (list x1076) (gen-syntax-case x1076 key m1073 r1065)) (chi val1072 r1065 (quote (()))))) (syntax-error e1068 (quote "invalid literals list in")))) tmp1070) (syntax-error tmp1069))) (syntax-dispatch tmp1069 (quote (any any each-any . each-any))))) e1068))))) (set! sc-expand (let ((m1079 (quote e)) (esew1080 (quote (eval)))) (lambda (x1081) (if (and (pair? x1081) (equal? (car x1081) noexpand)) (cadr x1081) (chi-top x1081 (quote ()) (quote ((top))) m1079 esew1080))))) (set! sc-expand3 (let ((m1082 (quote e)) (esew1083 (quote (eval)))) (lambda (x1084 . rest) (if (and (pair? x1084) (equal? (car x1084) noexpand)) (cadr x1084) (chi-top x1084 (quote ()) (quote ((top))) (if (null? rest) m1082 (car rest)) (if (or (null? rest) (null? (cdr rest))) esew1083 (cadr rest))))))) (set! identifier? (lambda (x1085) (nonsymbol-id? x1085))) (set! datum->syntax-object (lambda (id1086 datum) (begin (let ((x1087 id1086)) (if (not (nonsymbol-id? x1087)) (error-hook (quote datum->syntax-object) (quote "invalid argument") x1087))) (make-syntax-object datum (syntax-object-wrap id1086))))) (set! syntax-object->datum (lambda (x1088) (strip x1088 (quote (()))))) (set! generate-temporaries (lambda (ls1089) (begin (let ((x1090 ls1089)) (if (not (list? x1090)) (error-hook (quote generate-temporaries) (quote "invalid argument") x1090))) (map (lambda (x1091) (wrap (gensym) (quote ((top))))) ls1089)))) (set! free-identifier=? (lambda (x1092 y1093) (begin (let ((x1094 x1092)) (if (not (nonsymbol-id? x1094)) (error-hook (quote free-identifier=?) (quote "invalid argument") x1094))) (let ((x1095 y1093)) (if (not (nonsymbol-id? x1095)) (error-hook (quote free-identifier=?) (quote "invalid argument") x1095))) (free-id=? x1092 y1093)))) (set! bound-identifier=? (lambda (x1096 y1097) (begin (let ((x1098 x1096)) (if (not (nonsymbol-id? x1098)) (error-hook (quote bound-identifier=?) (quote "invalid argument") x1098))) (let ((x1099 y1097)) (if (not (nonsymbol-id? x1099)) (error-hook (quote bound-identifier=?) (quote "invalid argument") x1099))) (bound-id=? x1096 y1097)))) (set! syntax-error (lambda (object . messages) (begin (for-each (lambda (x1100) (let ((x1101 x1100)) (if (not (string? x1101)) (error-hook (quote syntax-error) (quote "invalid argument") x1101)))) messages) (let ((message (if (null? messages) (quote "invalid syntax") (apply string-append messages)))) (error-hook (quote #f) message (strip object (quote (())))))))) (set! install-global-transformer (lambda (sym1102 v1103) (begin (let ((x1104 sym1102)) (if (not (symbol? x1104)) (error-hook (quote define-syntax) (quote "invalid argument") x1104))) (let ((x1105 v1103)) (if (not (procedure? x1105)) (error-hook (quote define-syntax) (quote "invalid argument") x1105))) (global-extend (quote macro) sym1102 v1103)))) (letrec ((match (lambda (e1106 p1107 w1108 r1109) (cond ((not r1109) (quote #f)) ((eq? p1107 (quote any)) (cons (wrap e1106 w1108) r1109)) ((syntax-object? e1106) (match* (let ((e1110 (syntax-object-expression e1106))) (if (annotation? e1110) (annotation-expression e1110) e1110)) p1107 (join-wraps w1108 (syntax-object-wrap e1106)) r1109)) (else (match* (let ((e1111 e1106)) (if (annotation? e1111) (annotation-expression e1111) e1111)) p1107 w1108 r1109))))) (match* (lambda (e1112 p1113 w1114 r1115) (cond ((null? p1113) (and (null? e1112) r1115)) ((pair? p1113) (and (pair? e1112) (match (car e1112) (car p1113) w1114 (match (cdr e1112) (cdr p1113) w1114 r1115)))) ((eq? p1113 (quote each-any)) (let ((l (match-each-any e1112 w1114))) (and l (cons l r1115)))) (else (let ((t1116 (vector-ref p1113 (quote 0)))) (if (memv t1116 (quote (each))) (if (null? e1112) (match-empty (vector-ref p1113 (quote 1)) r1115) (let ((l1117 (match-each e1112 (vector-ref p1113 (quote 1)) w1114))) (and l1117 (let collect ((l1118 l1117)) (if (null? (car l1118)) r1115 (cons (map car l1118) (collect (map cdr l1118)))))))) (if (memv t1116 (quote (free-id))) (and (id? e1112) (free-id=? (wrap e1112 w1114) (vector-ref p1113 (quote 1))) r1115) (if (memv t1116 (quote (atom))) (and (equal? (vector-ref p1113 (quote 1)) (strip e1112 w1114)) r1115) (if (memv t1116 (quote (vector))) (and (vector? e1112) (match (vector->list e1112) (vector-ref p1113 (quote 1)) w1114 r1115))))))))))) (match-empty (lambda (p1119 r1120) (cond ((null? p1119) r1120) ((eq? p1119 (quote any)) (cons (quote ()) r1120)) ((pair? p1119) (match-empty (car p1119) (match-empty (cdr p1119) r1120))) ((eq? p1119 (quote each-any)) (cons (quote ()) r1120)) (else (let ((t1121 (vector-ref p1119 (quote 0)))) (if (memv t1121 (quote (each))) (match-empty (vector-ref p1119 (quote 1)) r1120) (if (memv t1121 (quote (free-id atom))) r1120 (if (memv t1121 (quote (vector))) (match-empty (vector-ref p1119 (quote 1)) r1120))))))))) (match-each-any (lambda (e1122 w1123) (cond ((annotation? e1122) (match-each-any (annotation-expression e1122) w1123)) ((pair? e1122) (let ((l1124 (match-each-any (cdr e1122) w1123))) (and l1124 (cons (wrap (car e1122) w1123) l1124)))) ((null? e1122) (quote ())) ((syntax-object? e1122) (match-each-any (syntax-object-expression e1122) (join-wraps w1123 (syntax-object-wrap e1122)))) (else (quote #f))))) (match-each (lambda (e1125 p1126 w1127) (cond ((annotation? e1125) (match-each (annotation-expression e1125) p1126 w1127)) ((pair? e1125) (let ((first1128 (match (car e1125) p1126 w1127 (quote ())))) (and first1128 (let ((rest1129 (match-each (cdr e1125) p1126 w1127))) (and rest1129 (cons first1128 rest1129)))))) ((null? e1125) (quote ())) ((syntax-object? e1125) (match-each (syntax-object-expression e1125) p1126 (join-wraps w1127 (syntax-object-wrap e1125)))) (else (quote #f)))))) (set! syntax-dispatch (lambda (e1130 p1131) (cond ((eq? p1131 (quote any)) (list e1130)) ((syntax-object? e1130) (match* (let ((e1132 (syntax-object-expression e1130))) (if (annotation? e1132) (annotation-expression e1132) e1132)) p1131 (syntax-object-wrap e1130) (quote ()))) (else (match* (let ((e1133 e1130)) (if (annotation? e1133) (annotation-expression e1133) e1133)) p1131 (quote (())) (quote ()))))))))) -(install-global-transformer (quote with-syntax) (lambda (x1134) ((lambda (tmp1135) ((lambda (tmp1136) (if tmp1136 (apply (lambda (_1137 e11138 e21139) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11138 e21139))) tmp1136) ((lambda (tmp1141) (if tmp1141 (apply (lambda (_1142 out in e11143 e21144) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) in (quote ()) (list out (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11143 e21144))))) tmp1141) ((lambda (tmp1146) (if tmp1146 (apply (lambda (_1147 out1148 in1149 e11150 e21151) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) in1149) (quote ()) (list out1148 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11150 e21151))))) tmp1146) (syntax-error tmp1135))) (syntax-dispatch tmp1135 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp1135 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp1135 (quote (any () any . each-any))))) x1134))) -(install-global-transformer (quote syntax-rules) (lambda (x1173) ((lambda (tmp1174) ((lambda (tmp1175) (if tmp1175 (apply (lambda (_1176 k1177 keyword pattern1178 template) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons k1177 (map (lambda (tmp1180 tmp1179) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) tmp1179) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) tmp1180))) template pattern1178)))))) tmp1175) (syntax-error tmp1174))) (syntax-dispatch tmp1174 (quote (any each-any . #(each ((any . any) any))))))) x1173))) -(install-global-transformer (quote let*) (lambda (x) ((lambda (tmp1191) ((lambda (tmp1192) (if (if tmp1192 (apply (lambda (let* x1193 v e1 e2) (andmap identifier? x1193)) tmp1192) (quote #f)) (apply (lambda (let*1195 x1196 v1197 e11198 e21199) (let f ((bindings (map list x1196 v1197))) (if (null? bindings) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote ()) (cons e11198 e21199))) ((lambda (tmp1203) ((lambda (tmp1204) (if tmp1204 (apply (lambda (body binding) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list binding) body)) tmp1204) (syntax-error tmp1203))) (syntax-dispatch tmp1203 (quote (any any))))) (list (f (cdr bindings)) (car bindings)))))) tmp1192) (syntax-error tmp1191))) (syntax-dispatch tmp1191 (quote (any #(each (any any)) any . each-any))))) x))) -(install-global-transformer (quote do) (lambda (orig-x) ((lambda (tmp1224) ((lambda (tmp1225) (if tmp1225 (apply (lambda (_ var init step e0 e11226 c) ((lambda (tmp1227) ((lambda (tmp1228) (if tmp1228 (apply (lambda (step1229) ((lambda (tmp1230) ((lambda (tmp1231) (if tmp1231 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list var init) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) e0) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append c (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) step1229))))))) tmp1231) ((lambda (tmp1235) (if tmp1235 (apply (lambda (e11236 e21237) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list var init) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) e0 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (cons e11236 e21237)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append c (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) step1229))))))) tmp1235) (syntax-error tmp1230))) (syntax-dispatch tmp1230 (quote (any . each-any)))))) (syntax-dispatch tmp1230 (quote ())))) e11226)) tmp1228) (syntax-error tmp1227))) (syntax-dispatch tmp1227 (quote each-any)))) (map (lambda (v1244 s) ((lambda (tmp1245) ((lambda (tmp1246) (if tmp1246 (apply (lambda () v1244) tmp1246) ((lambda (tmp1247) (if tmp1247 (apply (lambda (e) e) tmp1247) ((lambda (_1248) (syntax-error orig-x)) tmp1245))) (syntax-dispatch tmp1245 (quote (any)))))) (syntax-dispatch tmp1245 (quote ())))) s)) var step))) tmp1225) (syntax-error tmp1224))) (syntax-dispatch tmp1224 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x))) -(install-global-transformer (quote quasiquote) (letrec ((quasicons (lambda (x1276 y) ((lambda (tmp) ((lambda (tmp1277) (if tmp1277 (apply (lambda (x1278 y1279) ((lambda (tmp1280) ((lambda (tmp1281) (if tmp1281 (apply (lambda (dy) ((lambda (tmp1282) ((lambda (tmp1283) (if tmp1283 (apply (lambda (dx) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons dx dy))) tmp1283) ((lambda (_1284) (if (null? dy) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1278) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1278 y1279))) tmp1282))) (syntax-dispatch tmp1282 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) x1278)) tmp1281) ((lambda (tmp1285) (if tmp1285 (apply (lambda (stuff) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons x1278 stuff))) tmp1285) ((lambda (else) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1278 y1279)) tmp1280))) (syntax-dispatch tmp1280 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . any)))))) (syntax-dispatch tmp1280 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) y1279)) tmp1277) (syntax-error tmp))) (syntax-dispatch tmp (quote (any any))))) (list x1276 y)))) (quasiappend (lambda (x1286 y1287) ((lambda (tmp1288) ((lambda (tmp1289) (if tmp1289 (apply (lambda (x1290 y1291) ((lambda (tmp1292) ((lambda (tmp1293) (if tmp1293 (apply (lambda () x1290) tmp1293) ((lambda (_1294) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1290 y1291)) tmp1292))) (syntax-dispatch tmp1292 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) ()))))) y1291)) tmp1289) (syntax-error tmp1288))) (syntax-dispatch tmp1288 (quote (any any))))) (list x1286 y1287)))) (quasivector (lambda (x1295) ((lambda (tmp1296) ((lambda (x1297) ((lambda (tmp1298) ((lambda (tmp1299) (if tmp1299 (apply (lambda (x1300) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (list->vector x1300))) tmp1299) ((lambda (tmp1302) (if tmp1302 (apply (lambda (x1303) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1303)) tmp1302) ((lambda (_1305) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1297)) tmp1298))) (syntax-dispatch tmp1298 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . each-any)))))) (syntax-dispatch tmp1298 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) each-any))))) x1297)) tmp1296)) x1295))) (quasi (lambda (p lev) ((lambda (tmp1306) ((lambda (tmp1307) (if tmp1307 (apply (lambda (p1308) (if (= lev (quote 0)) p1308 (quasicons (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi (list p1308) (- lev (quote 1)))))) tmp1307) ((lambda (tmp1309) (if tmp1309 (apply (lambda (p1310 q) (if (= lev (quote 0)) (quasiappend p1310 (quasi q lev)) (quasicons (quasicons (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi (list p1310) (- lev (quote 1)))) (quasi q lev)))) tmp1309) ((lambda (tmp1311) (if tmp1311 (apply (lambda (p1312) (quasicons (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi (list p1312) (+ lev (quote 1))))) tmp1311) ((lambda (tmp1313) (if tmp1313 (apply (lambda (p1314 q1315) (quasicons (quasi p1314 lev) (quasi q1315 lev))) tmp1313) ((lambda (tmp1316) (if tmp1316 (apply (lambda (x1317) (quasivector (quasi x1317 lev))) tmp1316) ((lambda (p1319) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) p1319)) tmp1306))) (syntax-dispatch tmp1306 (quote #(vector each-any)))))) (syntax-dispatch tmp1306 (quote (any . any)))))) (syntax-dispatch tmp1306 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any)))))) (syntax-dispatch tmp1306 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any) . any)))))) (syntax-dispatch tmp1306 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) p)))) (lambda (x1320) ((lambda (tmp1321) ((lambda (tmp1322) (if tmp1322 (apply (lambda (_1323 e1324) (quasi e1324 (quote 0))) tmp1322) (syntax-error tmp1321))) (syntax-dispatch tmp1321 (quote (any any))))) x1320)))) -(install-global-transformer (quote include) (lambda (x) (letrec ((read-file (lambda (fn k) (let ((p1384 (open-input-file fn))) (let f ((x1385 (read p1384))) (if (eof-object? x1385) (begin (close-input-port p1384) (quote ())) (cons (datum->syntax-object k x1385) (f (read p1384))))))))) ((lambda (tmp1386) ((lambda (tmp1387) (if tmp1387 (apply (lambda (k1388 filename) (let ((fn1389 (syntax-object->datum filename))) ((lambda (tmp1390) ((lambda (tmp1391) (if tmp1391 (apply (lambda (exp) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))))) exp)) tmp1391) (syntax-error tmp1390))) (syntax-dispatch tmp1390 (quote each-any)))) (read-file fn1389 k1388)))) tmp1387) (syntax-error tmp1386))) (syntax-dispatch tmp1386 (quote (any any))))) x)))) -(install-global-transformer (quote unquote) (lambda (x1408) ((lambda (tmp1409) ((lambda (tmp1410) (if tmp1410 (apply (lambda (_ e) (error (quote unquote) (quote "expression ,~s not valid outside of quasiquote") (syntax-object->datum e))) tmp1410) (syntax-error tmp1409))) (syntax-dispatch tmp1409 (quote (any any))))) x1408))) -(install-global-transformer (quote unquote-splicing) (lambda (x1416) ((lambda (tmp1417) ((lambda (tmp1418) (if tmp1418 (apply (lambda (_1419 e1420) (error (quote unquote-splicing) (quote "expression ,@~s not valid outside of quasiquote") (syntax-object->datum e1420))) tmp1418) (syntax-error tmp1417))) (syntax-dispatch tmp1417 (quote (any any))))) x1416))) -(install-global-transformer (quote case) (lambda (x1426) ((lambda (tmp1427) ((lambda (tmp1428) (if tmp1428 (apply (lambda (_1429 e1430 m1 m2) ((lambda (tmp1431) ((lambda (body) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) e1430)) body)) tmp1431)) (let f1432 ((clause m1) (clauses m2)) (if (null? clauses) ((lambda (tmp1434) ((lambda (tmp1435) (if tmp1435 (apply (lambda (e1 e2) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e1 e2))) tmp1435) ((lambda (tmp1437) (if tmp1437 (apply (lambda (k1438 e11439 e21440) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) k1438)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11439 e21440)))) tmp1437) ((lambda (_1443) (syntax-error x1426)) tmp1434))) (syntax-dispatch tmp1434 (quote (each-any any . each-any)))))) (syntax-dispatch tmp1434 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) any . each-any))))) clause) ((lambda (tmp1444) ((lambda (rest) ((lambda (tmp1445) ((lambda (tmp1446) (if tmp1446 (apply (lambda (k1447 e11448 e21449) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) k1447)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11448 e21449)) rest)) tmp1446) ((lambda (_1452) (syntax-error x1426)) tmp1445))) (syntax-dispatch tmp1445 (quote (each-any any . each-any))))) clause)) tmp1444)) (f1432 (car clauses) (cdr clauses))))))) tmp1428) (syntax-error tmp1427))) (syntax-dispatch tmp1427 (quote (any any any . each-any))))) x1426))) -(install-global-transformer (quote identifier-syntax) (lambda (x) ((lambda (tmp) ((lambda (tmp1482) (if tmp1482 (apply (lambda (_ e) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) e)) (list (cons _ (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))))))))) tmp1482) (syntax-error tmp))) (syntax-dispatch tmp (quote (any any))))) x))) +(letrec ((lambda-var-list (lambda (vars203) (let lvl ((vars204 vars203) (ls (quote ())) (w205 (quote (())))) (cond ((pair? vars204) (lvl (cdr vars204) (cons (wrap (car vars204) w205) ls) w205)) ((id? vars204) (cons (wrap vars204 w205) ls)) ((null? vars204) ls) ((syntax-object? vars204) (lvl (syntax-object-expression vars204) ls (join-wraps w205 (syntax-object-wrap vars204)))) ((annotation? vars204) (lvl (annotation-expression vars204) ls w205)) (else (cons vars204 ls)))))) (gen-var (lambda (id206) (let ((id207 (if (syntax-object? id206) (syntax-object-expression id206) id206))) (if (annotation? id207) (gensym (annotation-expression id207) generated-symbols) (gensym id207 generated-symbols))))) (strip (lambda (x208 w209) (if (memq (quote top) (wrap-marks w209)) (if (or (annotation? x208) (and (pair? x208) (annotation? (car x208)))) (strip-annotation x208 (quote #f)) x208) (let f210 ((x211 x208)) (cond ((syntax-object? x211) (strip (syntax-object-expression x211) (syntax-object-wrap x211))) ((pair? x211) (let ((a (f210 (car x211))) (d (f210 (cdr x211)))) (if (and (eq? a (car x211)) (eq? d (cdr x211))) x211 (cons a d)))) ((vector? x211) (let ((old212 (vector->list x211))) (let ((new213 (map f210 old212))) (if (andmap eq? old212 new213) x211 (list->vector new213))))) (else x211)))))) (strip-annotation (lambda (x214 parent) (cond ((pair? x214) (let ((new215 (cons (quote #f) (quote #f)))) (begin (when parent (set-annotation-stripped! parent new215)) (set-car! new215 (strip-annotation (car x214) (quote #f))) (set-cdr! new215 (strip-annotation (cdr x214) (quote #f))) new215))) ((annotation? x214) (or (annotation-stripped x214) (strip-annotation (annotation-expression x214) x214))) ((vector? x214) (let ((new216 (make-vector (vector-length x214)))) (begin (when parent (set-annotation-stripped! parent new216)) (let loop ((i217 (- (vector-length x214) (quote 1)))) (unless (fx< i217 (quote 0)) (vector-set! new216 i217 (strip-annotation (vector-ref x214 i217) (quote #f))) (loop (fx- i217 (quote 1))))) new216))) (else x214)))) (ellipsis? (lambda (x218) (and (nonsymbol-id? x218) (free-id=? x218 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))))))) (chi-void (lambda () (list (quote void)))) (eval-local-transformer (lambda (expanded) (let ((p (local-eval-hook expanded))) (if (procedure? p) p (syntax-error p (quote "nonprocedure transfomer")))))) (chi-local-syntax (lambda (rec? e219 r w220 s k) ((lambda (tmp221) ((lambda (tmp222) (if tmp222 (apply (lambda (_223 id224 val e1 e2) (let ((ids225 id224)) (if (not (valid-bound-ids? ids225)) (syntax-error e219 (quote "duplicate bound keyword in")) (let ((labels (gen-labels ids225))) (let ((new-w (make-binding-wrap ids225 labels w220))) (k (cons e1 e2) (extend-env labels (let ((w228 (if rec? new-w w220)) (trans-r (macros-only-env r))) (map (lambda (x229) (cons (quote macro) (eval-local-transformer (chi x229 trans-r w228)))) val)) r) new-w s)))))) tmp222) ((lambda (_231) (syntax-error (source-wrap e219 w220 s))) tmp221))) (syntax-dispatch tmp221 (quote (any #(each (any any)) any . each-any))))) e219))) (chi-lambda-clause (lambda (e232 c r233 w234 k235) ((lambda (tmp236) ((lambda (tmp237) (if tmp237 (apply (lambda (id238 e1239 e2240) (let ((ids241 id238)) (if (not (valid-bound-ids? ids241)) (syntax-error e232 (quote "invalid parameter list in")) (let ((labels243 (gen-labels ids241)) (new-vars (map gen-var ids241))) (k235 new-vars (chi-body (cons e1239 e2240) e232 (extend-var-env labels243 new-vars r233) (make-binding-wrap ids241 labels243 w234))))))) tmp237) ((lambda (tmp245) (if tmp245 (apply (lambda (ids246 e1247 e2248) (let ((old-ids (lambda-var-list ids246))) (if (not (valid-bound-ids? old-ids)) (syntax-error e232 (quote "invalid parameter list in")) (let ((labels249 (gen-labels old-ids)) (new-vars250 (map gen-var old-ids))) (k235 (let f251 ((ls1 (cdr new-vars250)) (ls2 (car new-vars250))) (if (null? ls1) ls2 (f251 (cdr ls1) (cons (car ls1) ls2)))) (chi-body (cons e1247 e2248) e232 (extend-var-env labels249 new-vars250 r233) (make-binding-wrap old-ids labels249 w234))))))) tmp245) ((lambda (_253) (syntax-error e232)) tmp236))) (syntax-dispatch tmp236 (quote (any any . each-any)))))) (syntax-dispatch tmp236 (quote (each-any any . each-any))))) c))) (chi-body (lambda (body outer-form r254 w255) (let ((r256 (cons (quote ("placeholder" placeholder)) r254))) (let ((ribcage (make-ribcage (quote ()) (quote ()) (quote ())))) (let ((w257 (make-wrap (wrap-marks w255) (cons ribcage (wrap-subst w255))))) (let parse ((body258 (map (lambda (x262) (cons r256 (wrap x262 w257))) body)) (ids259 (quote ())) (labels260 (quote ())) (vars261 (quote ())) (vals (quote ())) (bindings (quote ()))) (if (null? body258) (syntax-error outer-form (quote "no expressions in body")) (let ((e263 (cdar body258)) (er (caar body258))) (call-with-values (lambda () (syntax-type e263 er (quote (())) (quote #f) ribcage)) (lambda (type264 value265 e266 w267 s268) (let ((t type264)) (if (memv t (quote (define-form))) (let ((id269 (wrap value265 w267)) (label (gen-label))) (let ((var270 (gen-var id269))) (begin (extend-ribcage! ribcage id269 label) (parse (cdr body258) (cons id269 ids259) (cons label labels260) (cons var270 vars261) (cons (cons er (wrap e266 w267)) vals) (cons (cons (quote lexical) var270) bindings))))) (if (memv t (quote (define-syntax-form))) (let ((id271 (wrap value265 w267)) (label272 (gen-label))) (begin (extend-ribcage! ribcage id271 label272) (parse (cdr body258) (cons id271 ids259) (cons label272 labels260) vars261 vals (cons (cons (quote macro) (cons er (wrap e266 w267))) bindings)))) (if (memv t (quote (begin-form))) ((lambda (tmp273) ((lambda (tmp274) (if tmp274 (apply (lambda (_275 e1276) (parse (let f277 ((forms e1276)) (if (null? forms) (cdr body258) (cons (cons er (wrap (car forms) w267)) (f277 (cdr forms))))) ids259 labels260 vars261 vals bindings)) tmp274) (syntax-error tmp273))) (syntax-dispatch tmp273 (quote (any . each-any))))) e266) (if (memv t (quote (local-syntax-form))) (chi-local-syntax value265 e266 er w267 s268 (lambda (forms279 er280 w281 s282) (parse (let f283 ((forms284 forms279)) (if (null? forms284) (cdr body258) (cons (cons er280 (wrap (car forms284) w281)) (f283 (cdr forms284))))) ids259 labels260 vars261 vals bindings))) (if (null? ids259) (build-sequence (quote #f) (map (lambda (x285) (chi (cdr x285) (car x285) (quote (())))) (cons (cons er (source-wrap e266 w267 s268)) (cdr body258)))) (begin (if (not (valid-bound-ids? ids259)) (syntax-error outer-form (quote "invalid or duplicate identifier in definition"))) (let loop286 ((bs bindings) (er-cache (quote #f)) (r-cache (quote #f))) (if (not (null? bs)) (let ((b (car bs))) (if (eq? (car b) (quote macro)) (let ((er287 (cadr b))) (let ((r-cache288 (if (eq? er287 er-cache) r-cache (macros-only-env er287)))) (begin (set-cdr! b (eval-local-transformer (chi (cddr b) r-cache288 (quote (()))))) (loop286 (cdr bs) er287 r-cache288)))) (loop286 (cdr bs) er-cache r-cache))))) (set-cdr! r256 (extend-env labels260 bindings (cdr r256))) (build-letrec (quote #f) vars261 (map (lambda (x289) (chi (cdr x289) (car x289) (quote (())))) vals) (build-sequence (quote #f) (map (lambda (x290) (chi (cdr x290) (car x290) (quote (())))) (cons (cons er (source-wrap e266 w267 s268)) (cdr body258)))))))))))))))))))))) (chi-macro (lambda (p291 e292 r293 w294 rib) (letrec ((rebuild-macro-output (lambda (x295 m) (cond ((pair? x295) (cons (rebuild-macro-output (car x295) m) (rebuild-macro-output (cdr x295) m))) ((syntax-object? x295) (let ((w296 (syntax-object-wrap x295))) (let ((ms (wrap-marks w296)) (s297 (wrap-subst w296))) (make-syntax-object (syntax-object-expression x295) (if (and (pair? ms) (eq? (car ms) (quote #f))) (make-wrap (cdr ms) (if rib (cons rib (cdr s297)) (cdr s297))) (make-wrap (cons m ms) (if rib (cons rib (cons (quote shift) s297)) (cons (quote shift) s297)))))))) ((vector? x295) (let ((n (vector-length x295))) (let ((v (make-vector n))) (let doloop ((i298 (quote 0))) (if (fx= i298 n) v (begin (vector-set! v i298 (rebuild-macro-output (vector-ref x295 i298) m)) (doloop (fx+ i298 (quote 1))))))))) ((symbol? x295) (syntax-error x295 (quote "encountered raw symbol in macro output"))) (else x295))))) (rebuild-macro-output (p291 (wrap e292 (anti-mark w294))) (string (quote #\m)))))) (chi-application (lambda (x299 e300 r301 w302 s303) ((lambda (tmp304) ((lambda (tmp305) (if tmp305 (apply (lambda (e0 e1306) (cons x299 (map (lambda (e307) (chi e307 r301 w302)) e1306))) tmp305) (syntax-error tmp304))) (syntax-dispatch tmp304 (quote (any . each-any))))) e300))) (chi-expr (lambda (type309 value310 e311 r312 w313 s314) (let ((t315 type309)) (if (memv t315 (quote (lexical))) value310 (if (memv t315 (quote (core))) (value310 e311 r312 w313 s314) (if (memv t315 (quote (lexical-call))) (chi-application value310 e311 r312 w313 s314) (if (memv t315 (quote (global-call))) (chi-application value310 e311 r312 w313 s314) (if (memv t315 (quote (constant))) (list (quote quote) (strip (source-wrap e311 w313 s314) (quote (())))) (if (memv t315 (quote (global))) value310 (if (memv t315 (quote (call))) (chi-application (chi (car e311) r312 w313) e311 r312 w313 s314) (if (memv t315 (quote (begin-form))) ((lambda (tmp316) ((lambda (tmp317) (if tmp317 (apply (lambda (_318 e1319 e2320) (chi-sequence (cons e1319 e2320) r312 w313 s314)) tmp317) (syntax-error tmp316))) (syntax-dispatch tmp316 (quote (any any . each-any))))) e311) (if (memv t315 (quote (local-syntax-form))) (chi-local-syntax value310 e311 r312 w313 s314 chi-sequence) (if (memv t315 (quote (eval-when-form))) ((lambda (tmp322) ((lambda (tmp323) (if tmp323 (apply (lambda (_324 x325 e1326 e2327) (let ((when-list (chi-when-list e311 x325 w313))) (if (memq (quote eval) when-list) (chi-sequence (cons e1326 e2327) r312 w313 s314) (chi-void)))) tmp323) (syntax-error tmp322))) (syntax-dispatch tmp322 (quote (any each-any any . each-any))))) e311) (if (memv t315 (quote (define-form define-syntax-form))) (syntax-error (wrap value310 w313) (quote "invalid context for definition of")) (if (memv t315 (quote (syntax))) (syntax-error (source-wrap e311 w313 s314) (quote "reference to pattern variable outside syntax form")) (if (memv t315 (quote (displaced-lexical))) (syntax-error (source-wrap e311 w313 s314) (quote "reference to identifier outside its scope")) (syntax-error (source-wrap e311 w313 s314)))))))))))))))))) (chi (lambda (e330 r331 w332) (call-with-values (lambda () (syntax-type e330 r331 w332 (quote #f) (quote #f))) (lambda (type333 value334 e335 w336 s337) (chi-expr type333 value334 e335 r331 w336 s337))))) (chi-top (lambda (e338 r339 w340 m341 esew) (call-with-values (lambda () (syntax-type e338 r339 w340 (quote #f) (quote #f))) (lambda (type348 value349 e350 w351 s352) (let ((t353 type348)) (if (memv t353 (quote (begin-form))) ((lambda (tmp354) ((lambda (tmp355) (if tmp355 (apply (lambda (_356) (chi-void)) tmp355) ((lambda (tmp357) (if tmp357 (apply (lambda (_358 e1359 e2360) (chi-top-sequence (cons e1359 e2360) r339 w351 s352 m341 esew)) tmp357) (syntax-error tmp354))) (syntax-dispatch tmp354 (quote (any any . each-any)))))) (syntax-dispatch tmp354 (quote (any))))) e350) (if (memv t353 (quote (local-syntax-form))) (chi-local-syntax value349 e350 r339 w351 s352 (lambda (body362 r363 w364 s365) (chi-top-sequence body362 r363 w364 s365 m341 esew))) (if (memv t353 (quote (eval-when-form))) ((lambda (tmp366) ((lambda (tmp367) (if tmp367 (apply (lambda (_368 x369 e1370 e2371) (let ((when-list372 (chi-when-list e350 x369 w351)) (body373 (cons e1370 e2371))) (cond ((eq? m341 (quote e)) (if (memq (quote eval) when-list372) (chi-top-sequence body373 r339 w351 s352 (quote e) (quote (eval))) (chi-void))) ((memq (quote load) when-list372) (if (or (memq (quote compile) when-list372) (and (eq? m341 (quote c&e)) (memq (quote eval) when-list372))) (chi-top-sequence body373 r339 w351 s352 (quote c&e) (quote (compile load))) (if (memq m341 (quote (c c&e))) (chi-top-sequence body373 r339 w351 s352 (quote c) (quote (load))) (chi-void)))) ((or (memq (quote compile) when-list372) (and (eq? m341 (quote c&e)) (memq (quote eval) when-list372))) (top-level-eval-hook (chi-top-sequence body373 r339 w351 s352 (quote e) (quote (eval)))) (chi-void)) (else (chi-void))))) tmp367) (syntax-error tmp366))) (syntax-dispatch tmp366 (quote (any each-any any . each-any))))) e350) (if (memv t353 (quote (define-syntax-form))) (let ((n376 (id-var-name value349 w351)) (r377 (macros-only-env r339))) (let ((t378 m341)) (if (memv t378 (quote (c))) (if (memq (quote compile) esew) (let ((e379 (chi-install-global n376 (chi e350 r377 w351)))) (begin (top-level-eval-hook e379) (if (memq (quote load) esew) e379 (chi-void)))) (if (memq (quote load) esew) (chi-install-global n376 (chi e350 r377 w351)) (chi-void))) (if (memv t378 (quote (c&e))) (let ((e380 (chi-install-global n376 (chi e350 r377 w351)))) (begin (top-level-eval-hook e380) e380)) (begin (if (memq (quote eval) esew) (top-level-eval-hook (chi-install-global n376 (chi e350 r377 w351)))) (chi-void)))))) (if (memv t353 (quote (define-form))) (let ((n381 (id-var-name value349 w351))) (let ((t382 (binding-type (lookup n381 r339)))) (if (memv t382 (quote (global))) (let ((x383 (list (quote define) n381 (chi e350 r339 w351)))) (begin (if (eq? m341 (quote c&e)) (top-level-eval-hook x383)) x383)) (if (memv t382 (quote (displaced-lexical))) (syntax-error (wrap value349 w351) (quote "identifier out of context")) (syntax-error (wrap value349 w351) (quote "cannot define keyword at top level")))))) (let ((x384 (chi-expr type348 value349 e350 r339 w351 s352))) (begin (if (eq? m341 (quote c&e)) (top-level-eval-hook x384)) x384)))))))))))) (syntax-type (lambda (e385 r386 w387 s388 rib389) (cond ((symbol? e385) (let ((n390 (id-var-name e385 w387))) (let ((b391 (lookup n390 r386))) (let ((type392 (binding-type b391))) (let ((t393 type392)) (if (memv t393 (quote (lexical))) (values type392 (binding-value b391) e385 w387 s388) (if (memv t393 (quote (global))) (values type392 n390 e385 w387 s388) (if (memv t393 (quote (macro))) (syntax-type (chi-macro (binding-value b391) e385 r386 w387 rib389) r386 (quote (())) s388 rib389) (values type392 (binding-value b391) e385 w387 s388))))))))) ((pair? e385) (let ((first (car e385))) (if (id? first) (let ((n394 (id-var-name first w387))) (let ((b395 (lookup n394 r386))) (let ((type396 (binding-type b395))) (let ((t397 type396)) (if (memv t397 (quote (lexical))) (values (quote lexical-call) (binding-value b395) e385 w387 s388) (if (memv t397 (quote (global))) (values (quote global-call) n394 e385 w387 s388) (if (memv t397 (quote (macro))) (syntax-type (chi-macro (binding-value b395) e385 r386 w387 rib389) r386 (quote (())) s388 rib389) (if (memv t397 (quote (core))) (values type396 (binding-value b395) e385 w387 s388) (if (memv t397 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value b395) e385 w387 s388) (if (memv t397 (quote (begin))) (values (quote begin-form) (quote #f) e385 w387 s388) (if (memv t397 (quote (eval-when))) (values (quote eval-when-form) (quote #f) e385 w387 s388) (if (memv t397 (quote (define))) ((lambda (tmp398) ((lambda (tmp399) (if (if tmp399 (apply (lambda (_400 name401 val402) (id? name401)) tmp399) (quote #f)) (apply (lambda (_403 name404 val405) (values (quote define-form) name404 val405 w387 s388)) tmp399) ((lambda (tmp406) (if (if tmp406 (apply (lambda (_407 name408 args409 e1410 e2411) (and (id? name408) (valid-bound-ids? (lambda-var-list args409)))) tmp406) (quote #f)) (apply (lambda (_412 name413 args414 e1415 e2416) (values (quote define-form) (wrap name413 w387) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) (wrap (cons args414 (cons e1415 e2416)) w387)) (quote (())) s388)) tmp406) ((lambda (tmp418) (if (if tmp418 (apply (lambda (_419 name420) (id? name420)) tmp418) (quote #f)) (apply (lambda (_421 name422) (values (quote define-form) (wrap name422 w387) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote (())) s388)) tmp418) (syntax-error tmp398))) (syntax-dispatch tmp398 (quote (any any)))))) (syntax-dispatch tmp398 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp398 (quote (any any any))))) e385) (if (memv t397 (quote (define-syntax))) ((lambda (tmp423) ((lambda (tmp424) (if (if tmp424 (apply (lambda (_425 name426 val427) (id? name426)) tmp424) (quote #f)) (apply (lambda (_428 name429 val430) (values (quote define-syntax-form) name429 val430 w387 s388)) tmp424) (syntax-error tmp423))) (syntax-dispatch tmp423 (quote (any any any))))) e385) (values (quote call) (quote #f) e385 w387 s388)))))))))))))) (values (quote call) (quote #f) e385 w387 s388)))) ((syntax-object? e385) (syntax-type (syntax-object-expression e385) r386 (join-wraps w387 (syntax-object-wrap e385)) (quote #f) rib389)) ((annotation? e385) (syntax-type (annotation-expression e385) r386 w387 (annotation-source e385) rib389)) ((let ((x431 e385)) (or (boolean? x431) (number? x431) (string? x431) (char? x431) (null? x431) (keyword? x431))) (values (quote constant) (quote #f) e385 w387 s388)) (else (values (quote other) (quote #f) e385 w387 s388))))) (chi-when-list (lambda (e432 when-list433 w434) (let f435 ((when-list436 when-list433) (situations (quote ()))) (if (null? when-list436) situations (f435 (cdr when-list436) (cons (let ((x437 (car when-list436))) (cond ((free-id=? x437 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote compile)) ((free-id=? x437 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote load)) ((free-id=? x437 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote eval)) (else (syntax-error (wrap x437 w434) (quote "invalid eval-when situation"))))) situations)))))) (chi-install-global (lambda (name438 e439) (list (quote install-global-transformer) (list (quote quote) name438) e439))) (chi-top-sequence (lambda (body440 r441 w442 s443 m444 esew445) (build-sequence s443 (let dobody ((body446 body440) (r447 r441) (w448 w442) (m449 m444) (esew450 esew445)) (if (null? body446) (quote ()) (let ((first451 (chi-top (car body446) r447 w448 m449 esew450))) (cons first451 (dobody (cdr body446) r447 w448 m449 esew450)))))))) (chi-sequence (lambda (body452 r453 w454 s455) (build-sequence s455 (let dobody456 ((body457 body452) (r458 r453) (w459 w454)) (if (null? body457) (quote ()) (let ((first460 (chi (car body457) r458 w459))) (cons first460 (dobody456 (cdr body457) r458 w459)))))))) (source-wrap (lambda (x461 w462 s463) (wrap (if s463 (make-annotation x461 s463 (quote #f)) x461) w462))) (wrap (lambda (x464 w465) (cond ((and (null? (wrap-marks w465)) (null? (wrap-subst w465))) x464) ((syntax-object? x464) (make-syntax-object (syntax-object-expression x464) (join-wraps w465 (syntax-object-wrap x464)))) ((null? x464) x464) (else (make-syntax-object x464 w465))))) (bound-id-member? (lambda (x466 list) (and (not (null? list)) (or (bound-id=? x466 (car list)) (bound-id-member? x466 (cdr list)))))) (distinct-bound-ids? (lambda (ids467) (let distinct? ((ids468 ids467)) (or (null? ids468) (and (not (bound-id-member? (car ids468) (cdr ids468))) (distinct? (cdr ids468))))))) (valid-bound-ids? (lambda (ids469) (and (let all-ids? ((ids470 ids469)) (or (null? ids470) (and (id? (car ids470)) (all-ids? (cdr ids470))))) (distinct-bound-ids? ids469)))) (bound-id=? (lambda (i471 j) (if (and (syntax-object? i471) (syntax-object? j)) (and (eq? (let ((e472 (syntax-object-expression i471))) (if (annotation? e472) (annotation-expression e472) e472)) (let ((e473 (syntax-object-expression j))) (if (annotation? e473) (annotation-expression e473) e473))) (same-marks? (wrap-marks (syntax-object-wrap i471)) (wrap-marks (syntax-object-wrap j)))) (eq? (let ((e474 i471)) (if (annotation? e474) (annotation-expression e474) e474)) (let ((e475 j)) (if (annotation? e475) (annotation-expression e475) e475)))))) (free-id=? (lambda (i476 j477) (and (eq? (let ((x478 i476)) (let ((e479 (if (syntax-object? x478) (syntax-object-expression x478) x478))) (if (annotation? e479) (annotation-expression e479) e479))) (let ((x480 j477)) (let ((e481 (if (syntax-object? x480) (syntax-object-expression x480) x480))) (if (annotation? e481) (annotation-expression e481) e481)))) (eq? (id-var-name i476 (quote (()))) (id-var-name j477 (quote (()))))))) (id-var-name (lambda (id482 w483) (letrec ((search-vector-rib (lambda (sym subst marks489 symnames ribcage490) (let ((n491 (vector-length symnames))) (let f492 ((i493 (quote 0))) (cond ((fx= i493 n491) (search sym (cdr subst) marks489)) ((and (eq? (vector-ref symnames i493) sym) (same-marks? marks489 (vector-ref (ribcage-marks ribcage490) i493))) (values (vector-ref (ribcage-labels ribcage490) i493) marks489)) (else (f492 (fx+ i493 (quote 1))))))))) (search-list-rib (lambda (sym494 subst495 marks496 symnames497 ribcage498) (let f499 ((symnames500 symnames497) (i501 (quote 0))) (cond ((null? symnames500) (search sym494 (cdr subst495) marks496)) ((and (eq? (car symnames500) sym494) (same-marks? marks496 (list-ref (ribcage-marks ribcage498) i501))) (values (list-ref (ribcage-labels ribcage498) i501) marks496)) (else (f499 (cdr symnames500) (fx+ i501 (quote 1)))))))) (search (lambda (sym502 subst503 marks504) (if (null? subst503) (values (quote #f) marks504) (let ((fst (car subst503))) (if (eq? fst (quote shift)) (search sym502 (cdr subst503) (cdr marks504)) (let ((symnames505 (ribcage-symnames fst))) (if (vector? symnames505) (search-vector-rib sym502 subst503 marks504 symnames505 fst) (search-list-rib sym502 subst503 marks504 symnames505 fst))))))))) (cond ((symbol? id482) (or (call-with-values (lambda () (search id482 (wrap-subst w483) (wrap-marks w483))) (lambda (x506 . ignore) x506)) id482)) ((syntax-object? id482) (let ((id507 (let ((e508 (syntax-object-expression id482))) (if (annotation? e508) (annotation-expression e508) e508))) (w1 (syntax-object-wrap id482))) (let ((marks509 (join-marks (wrap-marks w483) (wrap-marks w1)))) (call-with-values (lambda () (search id507 (wrap-subst w483) marks509)) (lambda (new-id marks510) (or new-id (call-with-values (lambda () (search id507 (wrap-subst w1) marks510)) (lambda (x512 . ignore511) x512)) id507)))))) ((annotation? id482) (let ((id513 (let ((e514 id482)) (if (annotation? e514) (annotation-expression e514) e514)))) (or (call-with-values (lambda () (search id513 (wrap-subst w483) (wrap-marks w483))) (lambda (x516 . ignore515) x516)) id513))) (else (error-hook (quote id-var-name) (quote "invalid id") id482)))))) (same-marks? (lambda (x517 y) (or (eq? x517 y) (and (not (null? x517)) (not (null? y)) (eq? (car x517) (car y)) (same-marks? (cdr x517) (cdr y)))))) (join-marks (lambda (m1 m2) (smart-append m1 m2))) (join-wraps (lambda (w1518 w2) (let ((m1519 (wrap-marks w1518)) (s1 (wrap-subst w1518))) (if (null? m1519) (if (null? s1) w2 (make-wrap (wrap-marks w2) (smart-append s1 (wrap-subst w2)))) (make-wrap (smart-append m1519 (wrap-marks w2)) (smart-append s1 (wrap-subst w2))))))) (smart-append (lambda (m1520 m2521) (if (null? m2521) m1520 (append m1520 m2521)))) (make-binding-wrap (lambda (ids522 labels523 w524) (if (null? ids522) w524 (make-wrap (wrap-marks w524) (cons (let ((labelvec (list->vector labels523))) (let ((n525 (vector-length labelvec))) (let ((symnamevec (make-vector n525)) (marksvec (make-vector n525))) (begin (let f526 ((ids527 ids522) (i528 (quote 0))) (if (not (null? ids527)) (call-with-values (lambda () (id-sym-name&marks (car ids527) w524)) (lambda (symname marks529) (begin (vector-set! symnamevec i528 symname) (vector-set! marksvec i528 marks529) (f526 (cdr ids527) (fx+ i528 (quote 1)))))))) (make-ribcage symnamevec marksvec labelvec))))) (wrap-subst w524)))))) (extend-ribcage! (lambda (ribcage530 id531 label532) (begin (set-ribcage-symnames! ribcage530 (cons (let ((e533 (syntax-object-expression id531))) (if (annotation? e533) (annotation-expression e533) e533)) (ribcage-symnames ribcage530))) (set-ribcage-marks! ribcage530 (cons (wrap-marks (syntax-object-wrap id531)) (ribcage-marks ribcage530))) (set-ribcage-labels! ribcage530 (cons label532 (ribcage-labels ribcage530)))))) (anti-mark (lambda (w534) (make-wrap (cons (quote #f) (wrap-marks w534)) (cons (quote shift) (wrap-subst w534))))) (set-ribcage-labels! (lambda (x535 update) (vector-set! x535 (quote 3) update))) (set-ribcage-marks! (lambda (x536 update537) (vector-set! x536 (quote 2) update537))) (set-ribcage-symnames! (lambda (x538 update539) (vector-set! x538 (quote 1) update539))) (ribcage-labels (lambda (x540) (vector-ref x540 (quote 3)))) (ribcage-marks (lambda (x541) (vector-ref x541 (quote 2)))) (ribcage-symnames (lambda (x542) (vector-ref x542 (quote 1)))) (ribcage? (lambda (x543) (and (vector? x543) (= (vector-length x543) (quote 4)) (eq? (vector-ref x543 (quote 0)) (quote ribcage))))) (make-ribcage (lambda (symnames544 marks545 labels546) (vector (quote ribcage) symnames544 marks545 labels546))) (gen-labels (lambda (ls547) (if (null? ls547) (quote ()) (cons (gen-label) (gen-labels (cdr ls547)))))) (gen-label (lambda () (string (quote #\i)))) (wrap-subst cdr) (wrap-marks car) (make-wrap cons) (id-sym-name&marks (lambda (x548 w549) (if (syntax-object? x548) (values (let ((e550 (syntax-object-expression x548))) (if (annotation? e550) (annotation-expression e550) e550)) (join-marks (wrap-marks w549) (wrap-marks (syntax-object-wrap x548)))) (values (let ((e551 x548)) (if (annotation? e551) (annotation-expression e551) e551)) (wrap-marks w549))))) (id? (lambda (x552) (cond ((symbol? x552) (quote #t)) ((syntax-object? x552) (symbol? (let ((e553 (syntax-object-expression x552))) (if (annotation? e553) (annotation-expression e553) e553)))) ((annotation? x552) (symbol? (annotation-expression x552))) (else (quote #f))))) (nonsymbol-id? (lambda (x554) (and (syntax-object? x554) (symbol? (let ((e555 (syntax-object-expression x554))) (if (annotation? e555) (annotation-expression e555) e555)))))) (global-extend (lambda (type556 sym557 val558) (put-global-definition-hook sym557 (cons type556 val558)))) (lookup (lambda (x559 r560) (cond ((assq x559 r560) => cdr) ((symbol? x559) (or (get-global-definition-hook x559) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env (lambda (r561) (if (null? r561) (quote ()) (let ((a562 (car r561))) (if (eq? (cadr a562) (quote macro)) (cons a562 (macros-only-env (cdr r561))) (macros-only-env (cdr r561))))))) (extend-var-env (lambda (labels563 vars564 r565) (if (null? labels563) r565 (extend-var-env (cdr labels563) (cdr vars564) (cons (cons (car labels563) (cons (quote lexical) (car vars564))) r565))))) (extend-env (lambda (labels566 bindings567 r568) (if (null? labels566) r568 (extend-env (cdr labels566) (cdr bindings567) (cons (cons (car labels566) (car bindings567)) r568))))) (binding-value cdr) (binding-type car) (source-annotation (lambda (x569) (cond ((annotation? x569) (annotation-source x569)) ((syntax-object? x569) (source-annotation (syntax-object-expression x569))) (else (quote #f))))) (set-syntax-object-wrap! (lambda (x570 update571) (vector-set! x570 (quote 2) update571))) (set-syntax-object-expression! (lambda (x572 update573) (vector-set! x572 (quote 1) update573))) (syntax-object-wrap (lambda (x574) (vector-ref x574 (quote 2)))) (syntax-object-expression (lambda (x575) (vector-ref x575 (quote 1)))) (syntax-object? (lambda (x576) (and (vector? x576) (= (vector-length x576) (quote 3)) (eq? (vector-ref x576 (quote 0)) (quote syntax-object))))) (make-syntax-object (lambda (expression wrap577) (vector (quote syntax-object) expression wrap577))) (build-letrec (lambda (src578 vars579 val-exps body-exp) (if (null? vars579) body-exp (list (quote letrec) (map list vars579 val-exps) body-exp)))) (build-named-let (lambda (src580 vars581 val-exps582 body-exp583) (if (null? vars581) body-exp583 (list (quote let) (car vars581) (map list (cdr vars581) val-exps582) body-exp583)))) (build-let (lambda (src584 vars585 val-exps586 body-exp587) (if (null? vars585) body-exp587 (list (quote let) (map list vars585 val-exps586) body-exp587)))) (build-sequence (lambda (src588 exps) (if (null? (cdr exps)) (car exps) (cons (quote begin) exps)))) (get-global-definition-hook (lambda (symbol) (getprop symbol (quote *sc-expander*)))) (put-global-definition-hook (lambda (symbol589 binding) (putprop symbol589 (quote *sc-expander*) binding))) (error-hook (lambda (who590 why what) (error who590 (quote "~a ~s") why what))) (local-eval-hook (lambda (x591) (eval (list noexpand x591) (interaction-environment)))) (top-level-eval-hook (lambda (x592) (eval (list noexpand x592) (interaction-environment)))) (annotation? (lambda (x593) (quote #f))) (fx< <) (fx= =) (fx- -) (fx+ +) (noexpand (quote "noexpand"))) (begin (global-extend (quote local-syntax) (quote letrec-syntax) (quote #t)) (global-extend (quote local-syntax) (quote let-syntax) (quote #f)) (global-extend (quote core) (quote fluid-let-syntax) (lambda (e594 r595 w596 s597) ((lambda (tmp598) ((lambda (tmp599) (if (if tmp599 (apply (lambda (_600 var601 val602 e1603 e2604) (valid-bound-ids? var601)) tmp599) (quote #f)) (apply (lambda (_606 var607 val608 e1609 e2610) (let ((names (map (lambda (x611) (id-var-name x611 w596)) var607))) (begin (for-each (lambda (id613 n614) (let ((t615 (binding-type (lookup n614 r595)))) (if (memv t615 (quote (displaced-lexical))) (syntax-error (source-wrap id613 w596 s597) (quote "identifier out of context"))))) var607 names) (chi-body (cons e1609 e2610) (source-wrap e594 w596 s597) (extend-env names (let ((trans-r618 (macros-only-env r595))) (map (lambda (x619) (cons (quote macro) (eval-local-transformer (chi x619 trans-r618 w596)))) val608)) r595) w596)))) tmp599) ((lambda (_621) (syntax-error (source-wrap e594 w596 s597))) tmp598))) (syntax-dispatch tmp598 (quote (any #(each (any any)) any . each-any))))) e594))) (global-extend (quote core) (quote quote) (lambda (e622 r623 w624 s625) ((lambda (tmp626) ((lambda (tmp627) (if tmp627 (apply (lambda (_628 e629) (list (quote quote) (strip e629 w624))) tmp627) ((lambda (_630) (syntax-error (source-wrap e622 w624 s625))) tmp626))) (syntax-dispatch tmp626 (quote (any any))))) e622))) (global-extend (quote core) (quote syntax) (letrec ((regen (lambda (x631) (let ((t632 (car x631))) (if (memv t632 (quote (ref))) (cadr x631) (if (memv t632 (quote (primitive))) (cadr x631) (if (memv t632 (quote (quote))) (list (quote quote) (cadr x631)) (if (memv t632 (quote (lambda))) (list (quote lambda) (cadr x631) (regen (caddr x631))) (if (memv t632 (quote (map))) (let ((ls633 (map regen (cdr x631)))) (cons (if (fx= (length ls633) (quote 2)) (quote map) (quote map)) ls633)) (cons (car x631) (map regen (cdr x631))))))))))) (gen-vector (lambda (x634) (cond ((eq? (car x634) (quote list)) (cons (quote vector) (cdr x634))) ((eq? (car x634) (quote quote)) (list (quote quote) (list->vector (cadr x634)))) (else (list (quote list->vector) x634))))) (gen-append (lambda (x635 y636) (if (equal? y636 (quote (quote ()))) x635 (list (quote append) x635 y636)))) (gen-cons (lambda (x637 y638) (let ((t639 (car y638))) (if (memv t639 (quote (quote))) (if (eq? (car x637) (quote quote)) (list (quote quote) (cons (cadr x637) (cadr y638))) (if (eq? (cadr y638) (quote ())) (list (quote list) x637) (list (quote cons) x637 y638))) (if (memv t639 (quote (list))) (cons (quote list) (cons x637 (cdr y638))) (list (quote cons) x637 y638)))))) (gen-map (lambda (e640 map-env) (let ((formals (map cdr map-env)) (actuals (map (lambda (x641) (list (quote ref) (car x641))) map-env))) (cond ((eq? (car e640) (quote ref)) (car actuals)) ((andmap (lambda (x642) (and (eq? (car x642) (quote ref)) (memq (cadr x642) formals))) (cdr e640)) (cons (quote map) (cons (list (quote primitive) (car e640)) (map (let ((r643 (map cons formals actuals))) (lambda (x644) (cdr (assq (cadr x644) r643)))) (cdr e640))))) (else (cons (quote map) (cons (list (quote lambda) formals e640) actuals))))))) (gen-mappend (lambda (e645 map-env646) (list (quote apply) (quote (primitive append)) (gen-map e645 map-env646)))) (gen-ref (lambda (src647 var648 level649 maps) (if (fx= level649 (quote 0)) (values var648 maps) (if (null? maps) (syntax-error src647 (quote "missing ellipsis in syntax form")) (call-with-values (lambda () (gen-ref src647 var648 (fx- level649 (quote 1)) (cdr maps))) (lambda (outer-var outer-maps) (let ((b650 (assq outer-var (car maps)))) (if b650 (values (cdr b650) maps) (let ((inner-var (gen-var (quote tmp)))) (values inner-var (cons (cons (cons outer-var inner-var) (car maps)) outer-maps))))))))))) (gen-syntax (lambda (src651 e652 r653 maps654 ellipsis?655) (if (id? e652) (let ((label656 (id-var-name e652 (quote (()))))) (let ((b657 (lookup label656 r653))) (if (eq? (binding-type b657) (quote syntax)) (call-with-values (lambda () (let ((var.lev (binding-value b657))) (gen-ref src651 (car var.lev) (cdr var.lev) maps654))) (lambda (var658 maps659) (values (list (quote ref) var658) maps659))) (if (ellipsis?655 e652) (syntax-error src651 (quote "misplaced ellipsis in syntax form")) (values (list (quote quote) e652) maps654))))) ((lambda (tmp660) ((lambda (tmp661) (if (if tmp661 (apply (lambda (dots e662) (ellipsis?655 dots)) tmp661) (quote #f)) (apply (lambda (dots663 e664) (gen-syntax src651 e664 r653 maps654 (lambda (x665) (quote #f)))) tmp661) ((lambda (tmp666) (if (if tmp666 (apply (lambda (x667 dots668 y669) (ellipsis?655 dots668)) tmp666) (quote #f)) (apply (lambda (x670 dots671 y672) (let f673 ((y674 y672) (k675 (lambda (maps676) (call-with-values (lambda () (gen-syntax src651 x670 r653 (cons (quote ()) maps676) ellipsis?655)) (lambda (x677 maps678) (if (null? (car maps678)) (syntax-error src651 (quote "extra ellipsis in syntax form")) (values (gen-map x677 (car maps678)) (cdr maps678)))))))) ((lambda (tmp679) ((lambda (tmp680) (if (if tmp680 (apply (lambda (dots681 y682) (ellipsis?655 dots681)) tmp680) (quote #f)) (apply (lambda (dots683 y684) (f673 y684 (lambda (maps685) (call-with-values (lambda () (k675 (cons (quote ()) maps685))) (lambda (x686 maps687) (if (null? (car maps687)) (syntax-error src651 (quote "extra ellipsis in syntax form")) (values (gen-mappend x686 (car maps687)) (cdr maps687)))))))) tmp680) ((lambda (_688) (call-with-values (lambda () (gen-syntax src651 y674 r653 maps654 ellipsis?655)) (lambda (y689 maps690) (call-with-values (lambda () (k675 maps690)) (lambda (x691 maps692) (values (gen-append x691 y689) maps692)))))) tmp679))) (syntax-dispatch tmp679 (quote (any . any))))) y674))) tmp666) ((lambda (tmp693) (if tmp693 (apply (lambda (x694 y695) (call-with-values (lambda () (gen-syntax src651 x694 r653 maps654 ellipsis?655)) (lambda (x696 maps697) (call-with-values (lambda () (gen-syntax src651 y695 r653 maps697 ellipsis?655)) (lambda (y698 maps699) (values (gen-cons x696 y698) maps699)))))) tmp693) ((lambda (tmp700) (if tmp700 (apply (lambda (e1701 e2702) (call-with-values (lambda () (gen-syntax src651 (cons e1701 e2702) r653 maps654 ellipsis?655)) (lambda (e704 maps705) (values (gen-vector e704) maps705)))) tmp700) ((lambda (_706) (values (list (quote quote) e652) maps654)) tmp660))) (syntax-dispatch tmp660 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp660 (quote (any . any)))))) (syntax-dispatch tmp660 (quote (any any . any)))))) (syntax-dispatch tmp660 (quote (any any))))) e652))))) (lambda (e707 r708 w709 s710) (let ((e711 (source-wrap e707 w709 s710))) ((lambda (tmp712) ((lambda (tmp713) (if tmp713 (apply (lambda (_714 x715) (call-with-values (lambda () (gen-syntax e711 x715 r708 (quote ()) ellipsis?)) (lambda (e716 maps717) (regen e716)))) tmp713) ((lambda (_718) (syntax-error e711)) tmp712))) (syntax-dispatch tmp712 (quote (any any))))) e711))))) (global-extend (quote core) (quote lambda) (lambda (e719 r720 w721 s722) ((lambda (tmp723) ((lambda (tmp724) (if tmp724 (apply (lambda (_725 c726) (chi-lambda-clause (source-wrap e719 w721 s722) c726 r720 w721 (lambda (vars727 body728) (list (quote lambda) vars727 body728)))) tmp724) (syntax-error tmp723))) (syntax-dispatch tmp723 (quote (any . any))))) e719))) (global-extend (quote core) (quote let) (letrec ((chi-let (lambda (e729 r730 w731 s732 constructor733 ids734 vals735 exps736) (if (not (valid-bound-ids? ids734)) (syntax-error e729 (quote "duplicate bound variable in")) (let ((labels737 (gen-labels ids734)) (new-vars738 (map gen-var ids734))) (let ((nw (make-binding-wrap ids734 labels737 w731)) (nr (extend-var-env labels737 new-vars738 r730))) (constructor733 s732 new-vars738 (map (lambda (x739) (chi x739 r730 w731)) vals735) (chi-body exps736 (source-wrap e729 nw s732) nr nw)))))))) (lambda (e740 r741 w742 s743) ((lambda (tmp744) ((lambda (tmp745) (if tmp745 (apply (lambda (_746 id747 val748 e1749 e2750) (chi-let e740 r741 w742 s743 build-let id747 val748 (cons e1749 e2750))) tmp745) ((lambda (tmp754) (if (if tmp754 (apply (lambda (_755 f756 id757 val758 e1759 e2760) (id? f756)) tmp754) (quote #f)) (apply (lambda (_761 f762 id763 val764 e1765 e2766) (chi-let e740 r741 w742 s743 build-named-let (cons f762 id763) val764 (cons e1765 e2766))) tmp754) ((lambda (_770) (syntax-error (source-wrap e740 w742 s743))) tmp744))) (syntax-dispatch tmp744 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp744 (quote (any #(each (any any)) any . each-any))))) e740)))) (global-extend (quote core) (quote letrec) (lambda (e771 r772 w773 s774) ((lambda (tmp775) ((lambda (tmp776) (if tmp776 (apply (lambda (_777 id778 val779 e1780 e2781) (let ((ids782 id778)) (if (not (valid-bound-ids? ids782)) (syntax-error e771 (quote "duplicate bound variable in")) (let ((labels784 (gen-labels ids782)) (new-vars785 (map gen-var ids782))) (let ((w786 (make-binding-wrap ids782 labels784 w773)) (r787 (extend-var-env labels784 new-vars785 r772))) (build-letrec s774 new-vars785 (map (lambda (x788) (chi x788 r787 w786)) val779) (chi-body (cons e1780 e2781) (source-wrap e771 w786 s774) r787 w786))))))) tmp776) ((lambda (_791) (syntax-error (source-wrap e771 w773 s774))) tmp775))) (syntax-dispatch tmp775 (quote (any #(each (any any)) any . each-any))))) e771))) (global-extend (quote core) (quote set!) (lambda (e792 r793 w794 s795) ((lambda (tmp796) ((lambda (tmp797) (if (if tmp797 (apply (lambda (_798 id799 val800) (id? id799)) tmp797) (quote #f)) (apply (lambda (_801 id802 val803) (let ((val804 (chi val803 r793 w794)) (n805 (id-var-name id802 w794))) (let ((b806 (lookup n805 r793))) (let ((t807 (binding-type b806))) (if (memv t807 (quote (lexical))) (list (quote set!) (binding-value b806) val804) (if (memv t807 (quote (global))) (list (quote set!) n805 val804) (if (memv t807 (quote (displaced-lexical))) (syntax-error (wrap id802 w794) (quote "identifier out of context")) (syntax-error (source-wrap e792 w794 s795))))))))) tmp797) ((lambda (tmp808) (if tmp808 (apply (lambda (_809 getter arg val810) (cons (chi (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) getter) r793 w794) (map (lambda (e811) (chi e811 r793 w794)) (append arg (list val810))))) tmp808) ((lambda (_813) (syntax-error (source-wrap e792 w794 s795))) tmp796))) (syntax-dispatch tmp796 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp796 (quote (any any any))))) e792))) (global-extend (quote begin) (quote begin) (quote ())) (global-extend (quote define) (quote define) (quote ())) (global-extend (quote define-syntax) (quote define-syntax) (quote ())) (global-extend (quote eval-when) (quote eval-when) (quote ())) (global-extend (quote core) (quote syntax-case) (letrec ((gen-syntax-case (lambda (x814 keys clauses r815) (if (null? clauses) (list (quote syntax-error) x814) ((lambda (tmp816) ((lambda (tmp817) (if tmp817 (apply (lambda (pat exp818) (if (and (id? pat) (andmap (lambda (x819) (not (free-id=? pat x819))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) keys))) (let ((labels820 (list (gen-label))) (var821 (gen-var pat))) (list (list (quote lambda) (list var821) (chi exp818 (extend-env labels820 (list (cons (quote syntax) (cons var821 (quote 0)))) r815) (make-binding-wrap (list pat) labels820 (quote (()))))) x814)) (gen-clause x814 keys (cdr clauses) r815 pat (quote #t) exp818))) tmp817) ((lambda (tmp822) (if tmp822 (apply (lambda (pat823 fender exp824) (gen-clause x814 keys (cdr clauses) r815 pat823 fender exp824)) tmp822) ((lambda (_825) (syntax-error (car clauses) (quote "invalid syntax-case clause"))) tmp816))) (syntax-dispatch tmp816 (quote (any any any)))))) (syntax-dispatch tmp816 (quote (any any))))) (car clauses))))) (gen-clause (lambda (x826 keys827 clauses828 r829 pat830 fender831 exp832) (call-with-values (lambda () (convert-pattern pat830 keys827)) (lambda (p833 pvars) (cond ((not (distinct-bound-ids? (map car pvars))) (syntax-error pat830 (quote "duplicate pattern variable in syntax-case pattern"))) ((not (andmap (lambda (x834) (not (ellipsis? (car x834)))) pvars)) (syntax-error pat830 (quote "misplaced ellipsis in syntax-case pattern"))) (else (let ((y835 (gen-var (quote tmp)))) (list (list (quote lambda) (list y835) (let ((y836 y835)) (list (quote if) ((lambda (tmp837) ((lambda (tmp838) (if tmp838 (apply (lambda () y836) tmp838) ((lambda (_839) (list (quote if) y836 (build-dispatch-call pvars fender831 y836 r829) (list (quote quote) (quote #f)))) tmp837))) (syntax-dispatch tmp837 (quote #(atom #t))))) fender831) (build-dispatch-call pvars exp832 y836 r829) (gen-syntax-case x826 keys827 clauses828 r829)))) (if (eq? p833 (quote any)) (list (quote list) x826) (list (quote syntax-dispatch) x826 (list (quote quote) p833))))))))))) (build-dispatch-call (lambda (pvars840 exp841 y842 r843) (let ((ids844 (map car pvars840)) (levels (map cdr pvars840))) (let ((labels845 (gen-labels ids844)) (new-vars846 (map gen-var ids844))) (list (quote apply) (list (quote lambda) new-vars846 (chi exp841 (extend-env labels845 (map (lambda (var847 level848) (cons (quote syntax) (cons var847 level848))) new-vars846 (map cdr pvars840)) r843) (make-binding-wrap ids844 labels845 (quote (()))))) y842))))) (convert-pattern (lambda (pattern keys849) (let cvt ((p850 pattern) (n851 (quote 0)) (ids852 (quote ()))) (if (id? p850) (if (bound-id-member? p850 keys849) (values (vector (quote free-id) p850) ids852) (values (quote any) (cons (cons p850 n851) ids852))) ((lambda (tmp853) ((lambda (tmp854) (if (if tmp854 (apply (lambda (x855 dots856) (ellipsis? dots856)) tmp854) (quote #f)) (apply (lambda (x857 dots858) (call-with-values (lambda () (cvt x857 (fx+ n851 (quote 1)) ids852)) (lambda (p859 ids860) (values (if (eq? p859 (quote any)) (quote each-any) (vector (quote each) p859)) ids860)))) tmp854) ((lambda (tmp861) (if tmp861 (apply (lambda (x862 y863) (call-with-values (lambda () (cvt y863 n851 ids852)) (lambda (y864 ids865) (call-with-values (lambda () (cvt x862 n851 ids865)) (lambda (x866 ids867) (values (cons x866 y864) ids867)))))) tmp861) ((lambda (tmp868) (if tmp868 (apply (lambda () (values (quote ()) ids852)) tmp868) ((lambda (tmp869) (if tmp869 (apply (lambda (x870) (call-with-values (lambda () (cvt x870 n851 ids852)) (lambda (p872 ids873) (values (vector (quote vector) p872) ids873)))) tmp869) ((lambda (x874) (values (vector (quote atom) (strip p850 (quote (())))) ids852)) tmp853))) (syntax-dispatch tmp853 (quote #(vector each-any)))))) (syntax-dispatch tmp853 (quote ()))))) (syntax-dispatch tmp853 (quote (any . any)))))) (syntax-dispatch tmp853 (quote (any any))))) p850)))))) (lambda (e875 r876 w877 s878) (let ((e879 (source-wrap e875 w877 s878))) ((lambda (tmp880) ((lambda (tmp881) (if tmp881 (apply (lambda (_882 val883 key m884) (if (andmap (lambda (x885) (and (id? x885) (not (ellipsis? x885)))) key) (let ((x887 (gen-var (quote tmp)))) (list (list (quote lambda) (list x887) (gen-syntax-case x887 key m884 r876)) (chi val883 r876 (quote (()))))) (syntax-error e879 (quote "invalid literals list in")))) tmp881) (syntax-error tmp880))) (syntax-dispatch tmp880 (quote (any any each-any . each-any))))) e879))))) (set! sc-expand (let ((m890 (quote e)) (esew891 (quote (eval)))) (lambda (x892) (if (and (pair? x892) (equal? (car x892) noexpand)) (cadr x892) (chi-top x892 (quote ()) (quote ((top))) m890 esew891))))) (set! sc-expand3 (let ((m893 (quote e)) (esew894 (quote (eval)))) (lambda (x895 . rest) (if (and (pair? x895) (equal? (car x895) noexpand)) (cadr x895) (chi-top x895 (quote ()) (quote ((top))) (if (null? rest) m893 (car rest)) (if (or (null? rest) (null? (cdr rest))) esew894 (cadr rest))))))) (set! identifier? (lambda (x896) (nonsymbol-id? x896))) (set! datum->syntax-object (lambda (id897 datum) (begin (let ((x898 id897)) (if (not (nonsymbol-id? x898)) (error-hook (quote datum->syntax-object) (quote "invalid argument") x898))) (make-syntax-object datum (syntax-object-wrap id897))))) (set! syntax-object->datum (lambda (x899) (strip x899 (quote (()))))) (set! generate-temporaries (lambda (ls900) (begin (let ((x901 ls900)) (if (not (list? x901)) (error-hook (quote generate-temporaries) (quote "invalid argument") x901))) (map (lambda (x902) (wrap (gensym) (quote ((top))))) ls900)))) (set! free-identifier=? (lambda (x903 y904) (begin (let ((x905 x903)) (if (not (nonsymbol-id? x905)) (error-hook (quote free-identifier=?) (quote "invalid argument") x905))) (let ((x906 y904)) (if (not (nonsymbol-id? x906)) (error-hook (quote free-identifier=?) (quote "invalid argument") x906))) (free-id=? x903 y904)))) (set! bound-identifier=? (lambda (x907 y908) (begin (let ((x909 x907)) (if (not (nonsymbol-id? x909)) (error-hook (quote bound-identifier=?) (quote "invalid argument") x909))) (let ((x910 y908)) (if (not (nonsymbol-id? x910)) (error-hook (quote bound-identifier=?) (quote "invalid argument") x910))) (bound-id=? x907 y908)))) (set! syntax-error (lambda (object . messages) (begin (for-each (lambda (x911) (let ((x912 x911)) (if (not (string? x912)) (error-hook (quote syntax-error) (quote "invalid argument") x912)))) messages) (let ((message (if (null? messages) (quote "invalid syntax") (apply string-append messages)))) (error-hook (quote #f) message (strip object (quote (())))))))) (set! install-global-transformer (lambda (sym913 v914) (begin (let ((x915 sym913)) (if (not (symbol? x915)) (error-hook (quote define-syntax) (quote "invalid argument") x915))) (let ((x916 v914)) (if (not (procedure? x916)) (error-hook (quote define-syntax) (quote "invalid argument") x916))) (global-extend (quote macro) sym913 v914)))) (letrec ((match (lambda (e917 p918 w919 r920) (cond ((not r920) (quote #f)) ((eq? p918 (quote any)) (cons (wrap e917 w919) r920)) ((syntax-object? e917) (match* (let ((e921 (syntax-object-expression e917))) (if (annotation? e921) (annotation-expression e921) e921)) p918 (join-wraps w919 (syntax-object-wrap e917)) r920)) (else (match* (let ((e922 e917)) (if (annotation? e922) (annotation-expression e922) e922)) p918 w919 r920))))) (match* (lambda (e923 p924 w925 r926) (cond ((null? p924) (and (null? e923) r926)) ((pair? p924) (and (pair? e923) (match (car e923) (car p924) w925 (match (cdr e923) (cdr p924) w925 r926)))) ((eq? p924 (quote each-any)) (let ((l (match-each-any e923 w925))) (and l (cons l r926)))) (else (let ((t927 (vector-ref p924 (quote 0)))) (if (memv t927 (quote (each))) (if (null? e923) (match-empty (vector-ref p924 (quote 1)) r926) (let ((l928 (match-each e923 (vector-ref p924 (quote 1)) w925))) (and l928 (let collect ((l929 l928)) (if (null? (car l929)) r926 (cons (map car l929) (collect (map cdr l929)))))))) (if (memv t927 (quote (free-id))) (and (id? e923) (free-id=? (wrap e923 w925) (vector-ref p924 (quote 1))) r926) (if (memv t927 (quote (atom))) (and (equal? (vector-ref p924 (quote 1)) (strip e923 w925)) r926) (if (memv t927 (quote (vector))) (and (vector? e923) (match (vector->list e923) (vector-ref p924 (quote 1)) w925 r926))))))))))) (match-empty (lambda (p930 r931) (cond ((null? p930) r931) ((eq? p930 (quote any)) (cons (quote ()) r931)) ((pair? p930) (match-empty (car p930) (match-empty (cdr p930) r931))) ((eq? p930 (quote each-any)) (cons (quote ()) r931)) (else (let ((t932 (vector-ref p930 (quote 0)))) (if (memv t932 (quote (each))) (match-empty (vector-ref p930 (quote 1)) r931) (if (memv t932 (quote (free-id atom))) r931 (if (memv t932 (quote (vector))) (match-empty (vector-ref p930 (quote 1)) r931))))))))) (match-each-any (lambda (e933 w934) (cond ((annotation? e933) (match-each-any (annotation-expression e933) w934)) ((pair? e933) (let ((l935 (match-each-any (cdr e933) w934))) (and l935 (cons (wrap (car e933) w934) l935)))) ((null? e933) (quote ())) ((syntax-object? e933) (match-each-any (syntax-object-expression e933) (join-wraps w934 (syntax-object-wrap e933)))) (else (quote #f))))) (match-each (lambda (e936 p937 w938) (cond ((annotation? e936) (match-each (annotation-expression e936) p937 w938)) ((pair? e936) (let ((first939 (match (car e936) p937 w938 (quote ())))) (and first939 (let ((rest940 (match-each (cdr e936) p937 w938))) (and rest940 (cons first939 rest940)))))) ((null? e936) (quote ())) ((syntax-object? e936) (match-each (syntax-object-expression e936) p937 (join-wraps w938 (syntax-object-wrap e936)))) (else (quote #f)))))) (set! syntax-dispatch (lambda (e941 p942) (cond ((eq? p942 (quote any)) (list e941)) ((syntax-object? e941) (match* (let ((e943 (syntax-object-expression e941))) (if (annotation? e943) (annotation-expression e943) e943)) p942 (syntax-object-wrap e941) (quote ()))) (else (match* (let ((e944 e941)) (if (annotation? e944) (annotation-expression e944) e944)) p942 (quote (())) (quote ()))))))))) +(install-global-transformer (quote with-syntax) (lambda (x945) ((lambda (tmp946) ((lambda (tmp947) (if tmp947 (apply (lambda (_948 e1949 e2950) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e1949 e2950))) tmp947) ((lambda (tmp952) (if tmp952 (apply (lambda (_953 out in e1954 e2955) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) in (quote ()) (list out (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e1954 e2955))))) tmp952) ((lambda (tmp957) (if tmp957 (apply (lambda (_958 out959 in960 e1961 e2962) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) in960) (quote ()) (list out959 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e1961 e2962))))) tmp957) (syntax-error tmp946))) (syntax-dispatch tmp946 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp946 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp946 (quote (any () any . each-any))))) x945))) +(install-global-transformer (quote syntax-rules) (lambda (x966) ((lambda (tmp967) ((lambda (tmp968) (if tmp968 (apply (lambda (_969 k970 keyword pattern971 template) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons k970 (map (lambda (tmp973 tmp972) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) tmp972) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) tmp973))) template pattern971)))))) tmp968) (syntax-error tmp967))) (syntax-dispatch tmp967 (quote (any each-any . #(each ((any . any) any))))))) x966))) +(install-global-transformer (quote let*) (lambda (x) ((lambda (tmp974) ((lambda (tmp975) (if (if tmp975 (apply (lambda (let* x976 v e1 e2) (andmap identifier? x976)) tmp975) (quote #f)) (apply (lambda (let*978 x979 v980 e1981 e2982) (let f ((bindings (map list x979 v980))) (if (null? bindings) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote ()) (cons e1981 e2982))) ((lambda (tmp986) ((lambda (tmp987) (if tmp987 (apply (lambda (body binding) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list binding) body)) tmp987) (syntax-error tmp986))) (syntax-dispatch tmp986 (quote (any any))))) (list (f (cdr bindings)) (car bindings)))))) tmp975) (syntax-error tmp974))) (syntax-dispatch tmp974 (quote (any #(each (any any)) any . each-any))))) x))) +(install-global-transformer (quote do) (lambda (orig-x) ((lambda (tmp988) ((lambda (tmp989) (if tmp989 (apply (lambda (_ var init step e0 e1990 c) ((lambda (tmp991) ((lambda (tmp992) (if tmp992 (apply (lambda (step993) ((lambda (tmp994) ((lambda (tmp995) (if tmp995 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list var init) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) e0) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append c (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) step993))))))) tmp995) ((lambda (tmp1000) (if tmp1000 (apply (lambda (e11001 e21002) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list var init) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) e0 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (cons e11001 e21002)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append c (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) step993))))))) tmp1000) (syntax-error tmp994))) (syntax-dispatch tmp994 (quote (any . each-any)))))) (syntax-dispatch tmp994 (quote ())))) e1990)) tmp992) (syntax-error tmp991))) (syntax-dispatch tmp991 (quote each-any)))) (map (lambda (v1009 s) ((lambda (tmp1010) ((lambda (tmp1011) (if tmp1011 (apply (lambda () v1009) tmp1011) ((lambda (tmp1012) (if tmp1012 (apply (lambda (e) e) tmp1012) ((lambda (_1013) (syntax-error orig-x)) tmp1010))) (syntax-dispatch tmp1010 (quote (any)))))) (syntax-dispatch tmp1010 (quote ())))) s)) var step))) tmp989) (syntax-error tmp988))) (syntax-dispatch tmp988 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x))) +(install-global-transformer (quote quasiquote) (letrec ((quasicons (lambda (x1015 y) ((lambda (tmp1016) ((lambda (tmp1017) (if tmp1017 (apply (lambda (x1018 y1019) ((lambda (tmp1020) ((lambda (tmp1021) (if tmp1021 (apply (lambda (dy) ((lambda (tmp1022) ((lambda (tmp1023) (if tmp1023 (apply (lambda (dx) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons dx dy))) tmp1023) ((lambda (_1024) (if (null? dy) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1018) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1018 y1019))) tmp1022))) (syntax-dispatch tmp1022 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) x1018)) tmp1021) ((lambda (tmp1025) (if tmp1025 (apply (lambda (stuff) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons x1018 stuff))) tmp1025) ((lambda (else) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1018 y1019)) tmp1020))) (syntax-dispatch tmp1020 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . any)))))) (syntax-dispatch tmp1020 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) y1019)) tmp1017) (syntax-error tmp1016))) (syntax-dispatch tmp1016 (quote (any any))))) (list x1015 y)))) (quasiappend (lambda (x1026 y1027) ((lambda (tmp1028) ((lambda (tmp1029) (if tmp1029 (apply (lambda (x1030 y1031) ((lambda (tmp1032) ((lambda (tmp1033) (if tmp1033 (apply (lambda () x1030) tmp1033) ((lambda (_1034) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1030 y1031)) tmp1032))) (syntax-dispatch tmp1032 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) ()))))) y1031)) tmp1029) (syntax-error tmp1028))) (syntax-dispatch tmp1028 (quote (any any))))) (list x1026 y1027)))) (quasivector (lambda (x1035) ((lambda (tmp1036) ((lambda (x1037) ((lambda (tmp1038) ((lambda (tmp1039) (if tmp1039 (apply (lambda (x1040) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (list->vector x1040))) tmp1039) ((lambda (tmp1042) (if tmp1042 (apply (lambda (x1043) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1043)) tmp1042) ((lambda (_1045) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1037)) tmp1038))) (syntax-dispatch tmp1038 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . each-any)))))) (syntax-dispatch tmp1038 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) each-any))))) x1037)) tmp1036)) x1035))) (quasi (lambda (p lev) ((lambda (tmp1046) ((lambda (tmp1047) (if tmp1047 (apply (lambda (p1048) (if (= lev (quote 0)) p1048 (quasicons (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi (list p1048) (- lev (quote 1)))))) tmp1047) ((lambda (tmp1049) (if tmp1049 (apply (lambda (p1050 q) (if (= lev (quote 0)) (quasiappend p1050 (quasi q lev)) (quasicons (quasicons (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi (list p1050) (- lev (quote 1)))) (quasi q lev)))) tmp1049) ((lambda (tmp) (if tmp (apply (lambda (p1051) (quasicons (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi (list p1051) (+ lev (quote 1))))) tmp) ((lambda (tmp1052) (if tmp1052 (apply (lambda (p1053 q1054) (quasicons (quasi p1053 lev) (quasi q1054 lev))) tmp1052) ((lambda (tmp1055) (if tmp1055 (apply (lambda (x1056) (quasivector (quasi x1056 lev))) tmp1055) ((lambda (p1058) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) p1058)) tmp1046))) (syntax-dispatch tmp1046 (quote #(vector each-any)))))) (syntax-dispatch tmp1046 (quote (any . any)))))) (syntax-dispatch tmp1046 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any)))))) (syntax-dispatch tmp1046 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any) . any)))))) (syntax-dispatch tmp1046 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) p)))) (lambda (x1059) ((lambda (tmp1060) ((lambda (tmp1061) (if tmp1061 (apply (lambda (_1062 e1063) (quasi e1063 (quote 0))) tmp1061) (syntax-error tmp1060))) (syntax-dispatch tmp1060 (quote (any any))))) x1059)))) +(install-global-transformer (quote include) (lambda (x1064) (letrec ((read-file (lambda (fn k) (let ((p1065 (open-input-file fn))) (let f1066 ((x1067 (read p1065))) (if (eof-object? x1067) (begin (close-input-port p1065) (quote ())) (cons (datum->syntax-object k x1067) (f1066 (read p1065))))))))) ((lambda (tmp1068) ((lambda (tmp1069) (if tmp1069 (apply (lambda (k1070 filename) (let ((fn1071 (syntax-object->datum filename))) ((lambda (tmp1072) ((lambda (tmp1073) (if tmp1073 (apply (lambda (exp) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))))) exp)) tmp1073) (syntax-error tmp1072))) (syntax-dispatch tmp1072 (quote each-any)))) (read-file fn1071 k1070)))) tmp1069) (syntax-error tmp1068))) (syntax-dispatch tmp1068 (quote (any any))))) x1064)))) +(install-global-transformer (quote unquote) (lambda (x1075) ((lambda (tmp1076) ((lambda (tmp1077) (if tmp1077 (apply (lambda (_1078 e1079) (error (quote unquote) (quote "expression ,~s not valid outside of quasiquote") (syntax-object->datum e1079))) tmp1077) (syntax-error tmp1076))) (syntax-dispatch tmp1076 (quote (any any))))) x1075))) +(install-global-transformer (quote unquote-splicing) (lambda (x1080) ((lambda (tmp1081) ((lambda (tmp1082) (if tmp1082 (apply (lambda (_1083 e1084) (error (quote unquote-splicing) (quote "expression ,@~s not valid outside of quasiquote") (syntax-object->datum e1084))) tmp1082) (syntax-error tmp1081))) (syntax-dispatch tmp1081 (quote (any any))))) x1080))) +(install-global-transformer (quote case) (lambda (x1085) ((lambda (tmp1086) ((lambda (tmp1087) (if tmp1087 (apply (lambda (_1088 e1089 m1 m2) ((lambda (tmp1090) ((lambda (body1091) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) e1089)) body1091)) tmp1090)) (let f1092 ((clause m1) (clauses m2)) (if (null? clauses) ((lambda (tmp1094) ((lambda (tmp1095) (if tmp1095 (apply (lambda (e11096 e21097) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11096 e21097))) tmp1095) ((lambda (tmp1099) (if tmp1099 (apply (lambda (k1100 e11101 e21102) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) k1100)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11101 e21102)))) tmp1099) ((lambda (_1105) (syntax-error x1085)) tmp1094))) (syntax-dispatch tmp1094 (quote (each-any any . each-any)))))) (syntax-dispatch tmp1094 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) any . each-any))))) clause) ((lambda (tmp1106) ((lambda (rest) ((lambda (tmp1107) ((lambda (tmp1108) (if tmp1108 (apply (lambda (k1109 e11110 e21111) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) k1109)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11110 e21111)) rest)) tmp1108) ((lambda (_1114) (syntax-error x1085)) tmp1107))) (syntax-dispatch tmp1107 (quote (each-any any . each-any))))) clause)) tmp1106)) (f1092 (car clauses) (cdr clauses))))))) tmp1087) (syntax-error tmp1086))) (syntax-dispatch tmp1086 (quote (any any any . each-any))))) x1085))) +(install-global-transformer (quote identifier-syntax) (lambda (x1115) ((lambda (tmp1116) ((lambda (tmp1117) (if tmp1117 (apply (lambda (_1118 e1119) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) e1119)) (list (cons _1118 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e1119 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))))))))) tmp1117) (syntax-error tmp1116))) (syntax-dispatch tmp1116 (quote (any any))))) x1115))) From 86f9f9ae850fb5d4b2f213dd9c17a607cd56f1f3 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Thu, 24 Aug 2000 00:23:19 +0000 Subject: [PATCH 0182/2047] * fluids.c (scm_fluid_set_x): Return SCM_UNSPECIFIED. --- libguile/fluids.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/fluids.c b/libguile/fluids.c index e7841d884..16b022df1 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -176,8 +176,8 @@ SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0, if (SCM_LENGTH (scm_root->fluids) <= n) grow_fluids (scm_root, n+1); - SCM_VELTS(scm_root->fluids)[n] = value; - return value; + SCM_VELTS (scm_root->fluids)[n] = value; + return SCM_UNSPECIFIED; } #undef FUNC_NAME From 5b03c15cbf471fd5aa56f2b2851af7e3a2542e61 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Thu, 24 Aug 2000 00:27:08 +0000 Subject: [PATCH 0183/2047] * Makefile.am (BUILT_SOURCES): Experimentally added scmconfig.h also here. (This is supposed to make sure that scmconfig.h is built before all sources in order to prevent that everything has to be rebuilt again. Hope it works---I'm just guessing. :) --- libguile/Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 9051d46c9..2f33a1b2d 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -84,7 +84,7 @@ DOT_DOC_FILES = \ EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@ -BUILT_SOURCES = cpp_err_symbols.c cpp_sig_symbols.c libpath.h \ +BUILT_SOURCES = cpp_err_symbols.c cpp_sig_symbols.c libpath.h scmconfig.h \ $(DOT_X_FILES) $(EXTRA_DOT_X_FILES) $(DOT_DOC_FILES) EXTRA_libguile_la_SOURCES = _scm.h \ From 665fc4e600f6088ab102a1d31b01baba9dc18eae Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Thu, 24 Aug 2000 00:27:22 +0000 Subject: [PATCH 0184/2047] *** empty log message *** --- libguile/ChangeLog | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 827f540e1..6b513d405 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2000-08-24 Mikael Djurfeldt + + * Makefile.am (BUILT_SOURCES): Experimentally added scmconfig.h + also here. (This is supposed to make sure that scmconfig.h is + built before all sources in order to prevent that everything has + to be rebuilt again. Hope it works---I'm just guessing. :) + + * fluids.c (scm_fluid_set_x): Return SCM_UNSPECIFIED. + 2000-08-23 Mikael Djurfeldt * gc.c (scm_gc_mark): Don't use GUILE_DEBUG flag to compile in From 0717dfd87115916e2354b3762b7360bd011270fc Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 25 Aug 2000 02:26:22 +0000 Subject: [PATCH 0185/2047] * smob.h (scm_smob_descriptor): Added `apply\' and `gsubr_type\'. * smob.c (scm_make_smob_type): Initialize `apply\' and `gsubr_type\'. (scm_set_smob_apply): New function. (scm_smob_apply_0, scm_smob_apply_1, scm_smob_apply_2, scm_smob_apply_3): New functions. * eval.c (SCM_CEVAL, SCM_APPLY): Added dispatch for applicable smobs. * procs.c (s_scm_procedure_p): Check applicable smobs. --- libguile/eval.c | 34 ++++++++++ libguile/procs.c | 3 + libguile/smob.c | 163 +++++++++++++++++++++++++++++++++++++++++++++++ libguile/smob.h | 8 +++ 4 files changed, 208 insertions(+) diff --git a/libguile/eval.c b/libguile/eval.c index cca70f44d..74574fd55 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2642,6 +2642,10 @@ evapply: RETURN (SCM_BOOL_T); case scm_tc7_asubr: RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED)); + case scm_tc7_smob: + if (!SCM_SMOB_DESCRIPTOR (proc).apply) + goto badfun; + RETURN (scm_smob_apply_0 (proc)); #ifdef CCLO case scm_tc7_cclo: t.arg1 = proc; @@ -2790,6 +2794,10 @@ evapply: #else RETURN (SCM_SUBRF (proc) (scm_cons (t.arg1, SCM_EOL))); #endif + case scm_tc7_smob: + if (!SCM_SMOB_DESCRIPTOR (proc).apply) + goto badfun; + RETURN (scm_smob_apply_1 (proc, t.arg1)); #ifdef CCLO case scm_tc7_cclo: arg2 = t.arg1; @@ -2908,6 +2916,10 @@ evapply: case scm_tc7_rpsubr: case scm_tc7_asubr: RETURN (SCM_SUBRF (proc) (t.arg1, arg2)); + case scm_tc7_smob: + if (!SCM_SMOB_DESCRIPTOR (proc).apply) + goto badfun; + RETURN (scm_smob_apply_2 (proc, t.arg1, arg2)); #ifdef CCLO cclon: case scm_tc7_cclo: @@ -3052,6 +3064,11 @@ evapply: SCM_CDR (SCM_CDR (debug.info->a.args)))) case scm_tc7_lsubr: RETURN (SCM_SUBRF (proc) (debug.info->a.args)) + case scm_tc7_smob: + if (!SCM_SMOB_DESCRIPTOR (proc).apply) + goto badfun; + RETURN (scm_smob_apply_3 (proc, t.arg1, arg2, + SCM_CDDR (debug.info->a.args))); #ifdef CCLO case scm_tc7_cclo: goto cclon; @@ -3111,6 +3128,11 @@ evapply: RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, arg2, scm_eval_args (x, env, proc)))); + case scm_tc7_smob: + if (!SCM_SMOB_DESCRIPTOR (proc).apply) + goto badfun; + RETURN (scm_smob_apply_3 (proc, t.arg1, arg2, + scm_eval_args (x, env, proc))); #ifdef CCLO case scm_tc7_cclo: goto cclon; @@ -3471,6 +3493,18 @@ tail: proc = arg1; } RETURN (EVALCAR (proc, args)); + case scm_tc7_smob: + if (!SCM_SMOB_DESCRIPTOR (proc).apply) + goto badproc; + if (SCM_NULLP (args)) + RETURN (scm_smob_apply_0 (proc)) + else if (SCM_NULLP (SCM_CDR (args))) + RETURN (scm_smob_apply_1 (proc, SCM_CAR (args))) + else if (SCM_NULLP (SCM_CDDR (args))) + RETURN (scm_smob_apply_2 (proc, SCM_CAR (args), SCM_CADR (args))) + else + RETURN (scm_smob_apply_3 (proc, SCM_CAR (args), SCM_CADR (args), + SCM_CDDR (args))); case scm_tc7_contin: SCM_ASRTGO (SCM_NULLP (args), wrongnumargs); scm_call_continuation (proc, arg1); diff --git a/libguile/procs.c b/libguile/procs.c index 8e53508bd..456cd19f0 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -50,6 +50,7 @@ #include "libguile/objects.h" #include "libguile/strings.h" #include "libguile/vectors.h" +#include "libguile/smob.h" #include "libguile/validate.h" #include "libguile/procs.h" @@ -198,6 +199,8 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0, #endif case scm_tc7_pws: return SCM_BOOL_T; + case scm_tc7_smob: + return SCM_BOOL (SCM_SMOB_DESCRIPTOR (obj).apply); default: return SCM_BOOL_F; } diff --git a/libguile/smob.c b/libguile/smob.c index 406c5370b..da76f5694 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -122,6 +122,160 @@ scm_smob_print (SCM exp, SCM port, scm_print_state *pstate) return 1; } +/* {Apply} + */ + +SCM +scm_smob_apply_0 (SCM smob) +{ + int type = SCM_SMOB_DESCRIPTOR (smob).gsubr_type; + switch (type) + { + case SCM_GSUBR_MAKTYPE (0, 0, 0): + return SCM_SMOB_DESCRIPTOR (smob).apply (); + case SCM_GSUBR_MAKTYPE (0, 1, 0): + return SCM_SMOB_DESCRIPTOR (smob).apply (smob, SCM_UNDEFINED); + case SCM_GSUBR_MAKTYPE (0, 0, 1): + return SCM_SMOB_DESCRIPTOR (smob).apply (smob, SCM_EOL); + case SCM_GSUBR_MAKTYPE (0, 2, 0): + return SCM_SMOB_DESCRIPTOR (smob).apply (smob, + SCM_UNDEFINED, + SCM_UNDEFINED); + case SCM_GSUBR_MAKTYPE (0, 1, 1): + return SCM_SMOB_DESCRIPTOR (smob).apply (smob, + SCM_UNDEFINED, + SCM_EOL); + case SCM_GSUBR_MAKTYPE (0, 3, 0): + return SCM_SMOB_DESCRIPTOR (smob).apply (smob, + SCM_UNDEFINED, + SCM_UNDEFINED, + SCM_UNDEFINED); + case SCM_GSUBR_MAKTYPE (0, 2, 1): + return SCM_SMOB_DESCRIPTOR (smob).apply (smob, + SCM_UNDEFINED, + SCM_UNDEFINED, + SCM_EOL); + default: + if (SCM_GSUBR_REQ (type) > 0) + scm_wrong_num_args (smob); + scm_misc_error ("scm_smob_apply_0", + "Unsupported smob application: ~S", + SCM_LIST1 (smob)); + } +} + +SCM +scm_smob_apply_1 (SCM smob, SCM a1) +{ + int type = SCM_SMOB_DESCRIPTOR (smob).gsubr_type; + switch (type) + { + case SCM_GSUBR_MAKTYPE (0, 0, 0): + scm_wrong_num_args (smob); + case SCM_GSUBR_MAKTYPE (1, 0, 0): + case SCM_GSUBR_MAKTYPE (0, 1, 0): + return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1); + case SCM_GSUBR_MAKTYPE (0, 0, 1): + return SCM_SMOB_DESCRIPTOR (smob).apply (smob, SCM_LIST1 (a1)); + case SCM_GSUBR_MAKTYPE (1, 1, 0): + case SCM_GSUBR_MAKTYPE (0, 2, 0): + return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, SCM_UNDEFINED); + case SCM_GSUBR_MAKTYPE (1, 0, 1): + case SCM_GSUBR_MAKTYPE (0, 1, 1): + return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, SCM_EOL); + case SCM_GSUBR_MAKTYPE (1, 2, 0): + case SCM_GSUBR_MAKTYPE (0, 3, 0): + return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, + SCM_UNDEFINED, + SCM_UNDEFINED); + case SCM_GSUBR_MAKTYPE (1, 1, 1): + case SCM_GSUBR_MAKTYPE (0, 2, 1): + return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, + SCM_UNDEFINED, + SCM_EOL); + default: + if (SCM_GSUBR_REQ (type) > 1) + scm_wrong_num_args (smob); + scm_misc_error ("scm_smob_apply_1", + "Unsupported smob application: ~S", + SCM_LIST1 (smob)); + } +} + +SCM +scm_smob_apply_2 (SCM smob, SCM a1, SCM a2) +{ + int type = SCM_SMOB_DESCRIPTOR (smob).gsubr_type; + switch (type) + { + case SCM_GSUBR_MAKTYPE (0, 0, 0): + case SCM_GSUBR_MAKTYPE (1, 0, 0): + case SCM_GSUBR_MAKTYPE (0, 1, 0): + scm_wrong_num_args (smob); + case SCM_GSUBR_MAKTYPE (0, 0, 1): + return SCM_SMOB_DESCRIPTOR (smob).apply (smob, SCM_LIST2 (a1, a2)); + case SCM_GSUBR_MAKTYPE (2, 0, 0): + case SCM_GSUBR_MAKTYPE (1, 1, 0): + case SCM_GSUBR_MAKTYPE (0, 2, 0): + return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, a2); + case SCM_GSUBR_MAKTYPE (1, 0, 1): + case SCM_GSUBR_MAKTYPE (0, 1, 1): + return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, SCM_LIST1 (a2)); + case SCM_GSUBR_MAKTYPE (2, 1, 0): + case SCM_GSUBR_MAKTYPE (1, 2, 0): + case SCM_GSUBR_MAKTYPE (0, 3, 0): + return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, a2, SCM_UNDEFINED); + case SCM_GSUBR_MAKTYPE (2, 0, 1): + case SCM_GSUBR_MAKTYPE (1, 1, 1): + case SCM_GSUBR_MAKTYPE (0, 2, 1): + return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, a2, SCM_EOL); + default: + if (SCM_GSUBR_REQ (type) > 2) + scm_wrong_num_args (smob); + scm_misc_error ("scm_smob_apply_2", + "Unsupported smob application: ~S", + SCM_LIST1 (smob)); + } +} + +SCM +scm_smob_apply_3 (SCM smob, SCM a1, SCM a2, SCM rest) +{ + int type = SCM_SMOB_DESCRIPTOR (smob).gsubr_type; + switch (type) + { + case SCM_GSUBR_MAKTYPE (0, 0, 0): + case SCM_GSUBR_MAKTYPE (1, 0, 0): + case SCM_GSUBR_MAKTYPE (0, 1, 0): + case SCM_GSUBR_MAKTYPE (2, 0, 0): + case SCM_GSUBR_MAKTYPE (1, 1, 0): + case SCM_GSUBR_MAKTYPE (0, 2, 0): + scm_wrong_num_args (smob); + case SCM_GSUBR_MAKTYPE (0, 0, 1): + return SCM_SMOB_DESCRIPTOR (smob).apply (smob, scm_cons (a1, scm_cons (a2, rest))); + case SCM_GSUBR_MAKTYPE (1, 0, 1): + case SCM_GSUBR_MAKTYPE (0, 1, 1): + return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, scm_cons (a2, rest)); + case SCM_GSUBR_MAKTYPE (3, 0, 0): + case SCM_GSUBR_MAKTYPE (2, 1, 0): + case SCM_GSUBR_MAKTYPE (1, 2, 0): + case SCM_GSUBR_MAKTYPE (0, 3, 0): + if (!SCM_NULLP (SCM_CDR (rest))) + scm_wrong_num_args (smob); + return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, a2, SCM_CAR (rest)); + case SCM_GSUBR_MAKTYPE (2, 0, 1): + case SCM_GSUBR_MAKTYPE (1, 1, 1): + case SCM_GSUBR_MAKTYPE (0, 2, 1): + return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, a2, rest); + default: + if (SCM_GSUBR_REQ (type) > 3) + scm_wrong_num_args (smob); + scm_misc_error ("scm_smob_apply_3", + "Unsupported smob application: ~S", + SCM_LIST1 (smob)); + } +} + long scm_make_smob_type (char *name, scm_sizet size) { @@ -141,6 +295,8 @@ scm_make_smob_type (char *name, scm_sizet size) scm_smobs[scm_numsmob].free = (size == 0 ? scm_free0 : scm_smob_free); scm_smobs[scm_numsmob].print = scm_smob_print; scm_smobs[scm_numsmob].equalp = 0; + scm_smobs[scm_numsmob].apply = 0; + scm_smobs[scm_numsmob].gsubr_type = 0; scm_numsmob++; } SCM_ALLOW_INTS; @@ -192,6 +348,13 @@ scm_set_smob_equalp (long tc, SCM (*equalp) (SCM, SCM)) scm_smobs[SCM_TC2SMOBNUM (tc)].equalp = equalp; } +void +scm_set_smob_apply (long tc, SCM (*apply) (), int req, int opt, int rst) +{ + scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply; + scm_smobs[SCM_TC2SMOBNUM (tc)].gsubr_type = SCM_GSUBR_MAKTYPE (req, opt, rst); +} + void scm_set_smob_mfpe (long tc, SCM (*mark) (SCM), diff --git a/libguile/smob.h b/libguile/smob.h index 87839de3b..b6de488b6 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -57,6 +57,8 @@ typedef struct scm_smob_descriptor scm_sizet (*free) (SCM); int (*print) (SCM exp, SCM port, scm_print_state *pstate); SCM (*equalp) (SCM, SCM); + SCM (*apply) (); + int gsubr_type; } scm_smob_descriptor; @@ -112,6 +114,7 @@ do { \ #define SCM_SMOBNAME(smobnum) (scm_smobs[smobnum].name) #define SCM_SMOB_PREDICATE(tag, obj) (SCM_NIMP (obj) \ && SCM_TYP16 (obj) == (tag)) +#define SCM_SMOB_DESCRIPTOR(x) (scm_smobs[SCM_SMOBNUM (x)]) extern int scm_numsmob; extern scm_smob_descriptor *scm_smobs; @@ -124,6 +127,10 @@ extern scm_sizet scm_free0 (SCM ptr); extern scm_sizet scm_smob_free (SCM obj); extern int scm_smob_print (SCM exp, SCM port, scm_print_state *pstate); +extern SCM scm_smob_apply_0 (SCM smob); +extern SCM scm_smob_apply_1 (SCM smob, SCM a1); +extern SCM scm_smob_apply_2 (SCM smob, SCM a1, SCM a2); +extern SCM scm_smob_apply_3 (SCM smob, SCM a1, SCM a2, SCM rest); /* The following set of functions is the standard way to create new * SMOB types. @@ -141,6 +148,7 @@ extern void scm_set_smob_print (long tc, int (*print) (SCM, SCM, scm_print_state*)); extern void scm_set_smob_equalp (long tc, SCM (*equalp) (SCM, SCM)); +extern void scm_set_smob_apply (long tc, SCM (*apply) (), int req, int opt, int rst); /* Functions for registering multiple handler functions simultaneously. From 14fb1c83d6bf6e6daa11740cdea58a28432727be Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 25 Aug 2000 02:26:47 +0000 Subject: [PATCH 0186/2047] *** empty log message *** --- libguile/ChangeLog | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6b513d405..7ebc6184c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,13 @@ +2000-08-24 Keisuke Nishida + + * smob.h (scm_smob_descriptor): Added `apply' and `gsubr_type'. + * smob.c (scm_make_smob_type): Initialize `apply' and `gsubr_type'. + (scm_set_smob_apply): New function. + (scm_smob_apply_0, scm_smob_apply_1, scm_smob_apply_2, + scm_smob_apply_3): New functions. + * eval.c (SCM_CEVAL, SCM_APPLY): Added dispatch for applicable smobs. + * procs.c (s_scm_procedure_p): Check applicable smobs. + 2000-08-24 Mikael Djurfeldt * Makefile.am (BUILT_SOURCES): Experimentally added scmconfig.h From 5540e847f4137f2a0896b3a6b94f73fff90194df Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 25 Aug 2000 04:08:50 +0000 Subject: [PATCH 0187/2047] * procprop.c: #include "libguile/smob.h"; Check applicable smobs. --- libguile/procprop.c | 24 ++++++++++++++++-------- 1 file changed, 16 insertions(+), 8 deletions(-) diff --git a/libguile/procprop.c b/libguile/procprop.c index cd3d56720..b2e76bbb7 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -52,6 +52,7 @@ #include "libguile/procs.h" #include "libguile/gsubr.h" #include "libguile/objects.h" +#include "libguile/smob.h" #include "libguile/root.h" #include "libguile/vectors.h" @@ -97,20 +98,27 @@ scm_i_procedure_arity (SCM proc) a += 2; r = 1; break; -#ifdef CCLO - case scm_tc7_cclo: - if (SCM_EQ_P (SCM_CCLO_SUBR (proc), scm_f_gsubr_apply)) + case scm_tc7_smob: + { + int type; + if (!SCM_SMOB_DESCRIPTOR (proc).apply) + return SCM_BOOL_F; + type = SCM_SMOB_DESCRIPTOR (proc).gsubr_type; + goto gsubr_type; + case scm_tc7_cclo: + if (SCM_EQ_P (SCM_CCLO_SUBR (proc), scm_f_gsubr_apply)) { - int type = SCM_INUM (SCM_GSUBR_TYPE (proc)); + type = SCM_INUM (SCM_GSUBR_TYPE (proc)); + gsubr_type: a += SCM_GSUBR_REQ (type); o = SCM_GSUBR_OPT (type); r = SCM_GSUBR_REST (type); break; } - proc = SCM_CCLO_SUBR (proc); - a -= 1; - goto loop; -#endif + proc = SCM_CCLO_SUBR (proc); + a -= 1; + goto loop; + } case scm_tc7_pws: proc = SCM_PROCEDURE (proc); goto loop; From 28819f62b56c2f3dae3ce5017d679e171042f9a5 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 25 Aug 2000 04:09:08 +0000 Subject: [PATCH 0188/2047] *** empty log message *** --- libguile/ChangeLog | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 7ebc6184c..35235e616 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2000-08-25 Mikael Djurfeldt + + * procprop.c: #include "libguile/smob.h"; Check applicable smobs. + 2000-08-24 Keisuke Nishida * smob.h (scm_smob_descriptor): Added `apply' and `gsubr_type'. @@ -6,7 +10,7 @@ (scm_smob_apply_0, scm_smob_apply_1, scm_smob_apply_2, scm_smob_apply_3): New functions. * eval.c (SCM_CEVAL, SCM_APPLY): Added dispatch for applicable smobs. - * procs.c (s_scm_procedure_p): Check applicable smobs. + * procs.c (scm_procedure_p): Check applicable smobs. 2000-08-24 Mikael Djurfeldt From 167d89cff92a301875e21ee31e35d6f8f3c3036e Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 25 Aug 2000 04:09:45 +0000 Subject: [PATCH 0189/2047] *** empty log message *** --- libguile/ChangeLog | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 35235e616..e3c6a8586 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,6 +1,6 @@ 2000-08-25 Mikael Djurfeldt - * procprop.c: #include "libguile/smob.h"; Check applicable smobs. + * procprop.c: #include "libguile/smob.h"; handle applicable smobs. 2000-08-24 Keisuke Nishida From 5d3e2388f3ef7532e69a6e43506b5f61d121b262 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 25 Aug 2000 17:01:32 +0000 Subject: [PATCH 0190/2047] * Added Jost Boekemeier's implementation of environments to guile. * Added a test suite for (up to now only) leaf environments. --- libguile/ChangeLog | 11 + libguile/Makefile.am | 12 +- libguile/environments.c | 2305 ++++++++++++++++++++++++++++ libguile/environments.h | 208 +++ libguile/init.c | 3 + test-suite/ChangeLog | 4 + test-suite/tests/environments.test | 364 +++++ 7 files changed, 2903 insertions(+), 4 deletions(-) create mode 100644 libguile/environments.c create mode 100644 libguile/environments.h create mode 100644 test-suite/tests/environments.test diff --git a/libguile/ChangeLog b/libguile/ChangeLog index e3c6a8586..3eac52325 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2000-08-25 Dirk Herrmann + + * Makefile.am: Added all necessary environments.* files. + + * init.c: Include environments.h. + + (scm_boot_guile_1): Initialize the environments. + + * environments.[ch]: Added. Most of the credit for these files + goes to Jost Boekemeier. + 2000-08-25 Mikael Djurfeldt * procprop.c: #include "libguile/smob.h"; handle applicable smobs. diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 2f33a1b2d..6e1f6e0fe 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -40,7 +40,8 @@ guile_LDFLAGS = @DLPREOPEN@ libguile_la_SOURCES = \ alist.c arbiters.c async.c backtrace.c boolean.c chars.c \ - continuations.c debug.c dynl.c dynwind.c eq.c error.c eval.c \ + continuations.c debug.c dynl.c dynwind.c environments.c eq.c \ + error.c eval.c \ evalext.c feature.c fluids.c fports.c gc.c gdbint.c gh_data.c \ gh_eval.c gh_funcs.c gh_init.c gh_io.c gh_list.c gh_predicates.c \ gsubr.c guardians.c hash.c hashtab.c hooks.c init.c ioext.c \ @@ -54,7 +55,8 @@ libguile_la_SOURCES = \ DOT_X_FILES = \ alist.x arbiters.x \ async.x backtrace.x boolean.x chars.x continuations.x debug.x \ - dynl.x dynwind.x eq.x error.x eval.x evalext.x feature.x \ + dynl.x dynwind.x environments.x eq.x error.x eval.x evalext.x \ + feature.x \ fluids.x fports.x gc.x gsubr.x guardians.x hash.x hashtab.x \ hooks.x init.x ioext.x iselect.x keywords.x lang.x list.x load.x \ macros.x mallocs.x modules.x net_db.x numbers.x objects.x \ @@ -70,7 +72,8 @@ EXTRA_DOT_X_FILES = debug-malloc.x filesys.x net_db.x posix.x ramap.x \ DOT_DOC_FILES = \ alist.doc arbiters.doc async.doc backtrace.doc boolean.doc \ - chars.doc continuations.doc debug.doc dynl.doc dynwind.doc eq.doc \ + chars.doc continuations.doc debug.doc dynl.doc dynwind.doc \ + environments.doc eq.doc \ error.doc eval.doc evalext.doc feature.doc fluids.doc fports.doc \ gc.doc gsubr.doc guardians.doc hash.doc hashtab.doc hooks.doc init.doc \ ioext.doc iselect.doc keywords.doc lang.doc list.doc load.doc \ @@ -115,7 +118,8 @@ pkginclude_HEADERS = gh.h modincludedir = $(includedir)/libguile modinclude_HEADERS = \ __scm.h alist.h arbiters.h async.h backtrace.h boolean.h chars.h \ - continuations.h debug.h dynl.h dynwind.h eq.h error.h eval.h \ + continuations.h debug.h dynl.h dynwind.h environments.h eq.h \ + error.h eval.h \ evalext.h feature.h filesys.h fports.h gc.h gdb_interface.h \ gdbint.h gsubr.h guardians.h hash.h hashtab.h hooks.h init.h \ ioext.h keywords.h lang.h list.h load.h macros.h mallocs.h \ diff --git a/libguile/environments.c b/libguile/environments.c new file mode 100644 index 000000000..594adddfb --- /dev/null +++ b/libguile/environments.c @@ -0,0 +1,2305 @@ +/* Copyright (C) 1999, 2000 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 + * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + + + +#include "libguile/_scm.h" +#include "libguile/alist.h" +#include "libguile/eval.h" +#include "libguile/gh.h" +#include "libguile/hash.h" +#include "libguile/ports.h" +#include "libguile/smob.h" +#include "libguile/symbols.h" +#include "libguile/vectors.h" +#include "libguile/weaks.h" + +#include "libguile/environments.h" + + + +long scm_tc16_environment; +long scm_tc16_observer; + + + +/* error conditions */ + +/* + * Throw an error if symbol is not bound in environment func + */ +void +scm_error_environment_unbound (const char *func, SCM env, SCM symbol) +{ + /* Dirk:FIXME:: Should throw an environment:unbound type error */ + char error[] = "Symbol `~A' not bound in environment `~A'."; + SCM arguments = scm_cons2 (symbol, env, SCM_EOL); + scm_misc_error (func, error, arguments); +} + + +/* + * Throw an error if func tried to create (define) or remove + * (undefine) a new binding for symbol in env + */ +void +scm_error_environment_immutable_binding (const char *func, SCM env, SCM symbol) +{ + /* Dirk:FIXME:: Should throw an environment:immutable-binding type error */ + char error[] = "Immutable binding in environment ~A (symbol: `~A')."; + SCM arguments = scm_cons2 (env, symbol, SCM_EOL); + scm_misc_error (func, error, arguments); +} + + +/* + * Throw an error if func tried to change an immutable location. + */ +void +scm_error_environment_immutable_location (const char *func, SCM env, SCM symbol) +{ + /* Dirk:FIXME:: Should throw an environment:immutable-location type error */ + char error[] = "Immutable location in environment `~A' (symbol: `~A')."; + SCM arguments = scm_cons2 (env, symbol, SCM_EOL); + scm_misc_error (func, error, arguments); +} + + + +/* generic environments */ + + +/* Create an environment for the given type. Dereferencing type twice must + * deliver the initialized set of environment functions. Thus, type will + * also determine the signature of the underlying environment implementation. + * Dereferencing type once will typically deliver the data fields used by the + * underlying environment implementation. + */ +SCM +scm_make_environment (void *type) +{ + SCM env; + + SCM_NEWCELL (env); + SCM_SET_CELL_WORD_1 (env, type); + SCM_SET_CELL_TYPE (env, scm_tc16_environment); + + return env; +} + + +SCM_DEFINE (scm_environment_p, "environment?", 1, 0, 0, + (SCM obj), + "Return #t if OBJ is an environment, or #f otherwise.") +#define FUNC_NAME s_scm_environment_p +{ + return SCM_BOOL (SCM_ENVIRONMENT_P (obj)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_environment_bound_p, "environment-bound?", 2, 0, 0, + (SCM env, SCM sym), + "Return #t if SYM is bound in ENV, or #f otherwise.") +#define FUNC_NAME s_scm_environment_bound_p +{ + SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); + SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG2, FUNC_NAME); + + return SCM_BOOL (SCM_ENVIRONMENT_BOUND_P (env, sym)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_environment_ref, "environment-ref", 2, 0, 0, + (SCM env, SCM sym), + "Return the value of the location bound to SYM in ENV.\n" + "If SYM is unbound in ENV, signal an environment:unbound\n" + "error.") +#define FUNC_NAME s_scm_environment_ref +{ + SCM val; + + SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); + SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG2, FUNC_NAME); + + val = SCM_ENVIRONMENT_REF (env, sym); + + if (!SCM_UNBNDP (val)) + return val; + else + scm_error_environment_unbound (FUNC_NAME, env, sym); +} +#undef FUNC_NAME + + +/* This C function is identical to environment-ref, except that if symbol is + * unbound in env, it returns the value SCM_UNDEFINED, instead of signalling + * an error. + */ +SCM +scm_c_environment_ref (SCM env, SCM sym) +{ + SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, "scm_c_environment_ref"); + SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG2, "scm_c_environment_ref"); + return SCM_ENVIRONMENT_REF (env, sym); +} + + +static SCM +environment_default_folder (SCM proc, SCM symbol, SCM value, SCM tail) +{ + return gh_call3 (proc, symbol, value, tail); +} + + +SCM_DEFINE (scm_environment_fold, "environment-fold", 3, 0, 0, + (SCM env, SCM proc, SCM init), + "Iterate over all the bindings in ENV, accumulating some value.\n" + "For each binding in ENV, apply PROC to the symbol bound, its\n" + "value, and the result from the previous application of PROC.\n" + "Use INIT as PROC's third argument the first time PROC is\n" + "applied.\n" + "If ENV contains no bindings, this function simply returns INIT.\n" + "If ENV binds the symbol sym1 to the value val1, sym2 to val2,\n" + "and so on, then this procedure computes:\n" + " (proc sym1 val1\n" + " (proc sym2 val2\n" + " ...\n" + " (proc symn valn\n" + " init)))\n" + "Each binding in ENV will be processed exactly once.\n" + "environment-fold makes no guarantees about the order in which\n" + "the bindings are processed.\n" + "Here is a function which, given an environment, constructs an\n" + "association list representing that environment's bindings,\n" + "using environment-fold:\n" + " (define (environment->alist env)\n" + " (environment-fold env\n" + " (lambda (sym val tail)\n" + " (cons (cons sym val) tail))\n" + " '()))") +#define FUNC_NAME s_scm_environment_fold +{ + SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); + SCM_ASSERT (SCM_EQ_P (scm_procedure_p (proc), SCM_BOOL_T), + proc, SCM_ARG2, FUNC_NAME); + + return SCM_ENVIRONMENT_FOLD (env, environment_default_folder, proc, init); +} +#undef FUNC_NAME + + +/* This is the C-level analog of environment-fold. For each binding in ENV, + * make the call: + * (*proc) (data, symbol, value, previous) + * where previous is the value returned from the last call to *PROC, or INIT + * for the first call. If ENV contains no bindings, return INIT. + */ +SCM +scm_c_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init) +{ + SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, "scm_c_environment_fold"); + + return SCM_ENVIRONMENT_FOLD (env, proc, data, init); +} + + +SCM_DEFINE (scm_environment_define, "environment-define", 3, 0, 0, + (SCM env, SCM sym, SCM val), + "Bind SYM to a new location containing VAL in ENV. If SYM is\n" + "already bound to another location in ENV and the binding is\n" + "mutable, that binding is replaced. The new binding and\n" + "location are both mutable. The return value is unspecified.\n" + "If SYM is already bound in ENV, and the binding is immutable,\n" + "signal an environment:immutable-binding error.") +#define FUNC_NAME s_scm_environment_define +{ + SCM status; + + SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); + SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG2, FUNC_NAME); + + status = SCM_ENVIRONMENT_DEFINE (env, sym, val); + + if (SCM_EQ_P (status, SCM_ENVIRONMENT_SUCCESS)) + return SCM_UNSPECIFIED; + else if (SCM_EQ_P (status, SCM_ENVIRONMENT_BINDING_IMMUTABLE)) + scm_error_environment_immutable_binding (FUNC_NAME, env, sym); + else + abort(); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_environment_undefine, "environment-undefine", 2, 0, 0, + (SCM env, SCM sym), + "Remove any binding for SYM from ENV. If SYM is unbound in ENV,\n" + "do nothing. The return value is unspecified.\n" + "If SYM is already bound in ENV, and the binding is immutable,\n" + "signal an environment:immutable-binding error.") +#define FUNC_NAME s_scm_environment_undefine +{ + SCM status; + + SCM_ASSERT(SCM_ENVIRONMENT_P(env), env, SCM_ARG1, FUNC_NAME); + SCM_ASSERT(SCM_SYMBOLP(sym), sym, SCM_ARG2, FUNC_NAME); + + status = SCM_ENVIRONMENT_UNDEFINE (env, sym); + + if (SCM_EQ_P (status, SCM_ENVIRONMENT_SUCCESS)) + return SCM_UNSPECIFIED; + else if (SCM_EQ_P (status, SCM_ENVIRONMENT_BINDING_IMMUTABLE)) + scm_error_environment_immutable_binding (FUNC_NAME, env, sym); + else + abort(); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_environment_set_x, "environment-set!", 3, 0, 0, + (SCM env, SCM sym, SCM val), + "If ENV binds SYM to some location, change that location's\n" + "value to VAL. The return value is unspecified.\n" + "If SYM is not bound in ENV, signal an environment:unbound\n" + "error. If ENV binds SYM to an immutable location, signal an\n" + "environment:immutable-location error.") +#define FUNC_NAME s_scm_environment_set_x +{ + SCM status; + + SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); + SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG2, FUNC_NAME); + + status = SCM_ENVIRONMENT_SET (env, sym, val); + + if (SCM_EQ_P (status, SCM_ENVIRONMENT_SUCCESS)) + return SCM_UNSPECIFIED; + else if (SCM_UNBNDP (status)) + scm_error_environment_unbound (FUNC_NAME, env, sym); + else if (SCM_EQ_P (status, SCM_ENVIRONMENT_LOCATION_IMMUTABLE)) + scm_error_environment_immutable_binding (FUNC_NAME, env, sym); + else + abort(); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_environment_cell, "environment-cell", 3, 0, 0, + (SCM env, SCM sym, SCM for_write), + "Return the value cell which ENV binds to SYM, or #f if the\n" + "binding does not live in a value cell.\n" + "The argument FOR-WRITE indicates whether the caller intends\n" + "to modify the variable's value by mutating the value cell. If\n" + "the variable is immutable, then environment-cell signals an\n" + "environment:immutable-location error.\n" + "If SYM is unbound in ENV, signal an environment:unbound error.\n" + "If you use this function, you should consider using\n" + "environment-observe, to be notified when SYM gets re-bound to\n" + "a new value cell, or becomes undefined.") +#define FUNC_NAME s_scm_environment_cell +{ + SCM location; + + SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); + SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG2, FUNC_NAME); + SCM_ASSERT (SCM_BOOLP (for_write), for_write, SCM_ARG3, FUNC_NAME); + + location = SCM_ENVIRONMENT_CELL (env, sym, !SCM_FALSEP (for_write)); + if (!SCM_IMP (location)) + return location; + else if (SCM_UNBNDP (location)) + scm_error_environment_unbound (FUNC_NAME, env, sym); + else if (SCM_EQ_P (location, SCM_ENVIRONMENT_LOCATION_IMMUTABLE)) + scm_error_environment_immutable_location (FUNC_NAME, env, sym); + else /* no cell */ + return location; +} +#undef FUNC_NAME + + +/* This C function is identical to environment-cell, with the following + * exceptions: If symbol is unbound in env, it returns the value + * SCM_UNDEFINED, instead of signalling an error. If symbol is bound to an + * immutable location but the cell is requested for write, the value + * SCM_ENVIRONMENT_LOCATION_IMMUTABLE is returned. + */ +SCM +scm_c_environment_cell(SCM env, SCM sym, int for_write) +{ + SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, "scm_c_environment_cell"); + SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG2, "scm_c_environment_cell"); + + return SCM_ENVIRONMENT_CELL (env, sym, for_write); +} + + +static void +environment_default_observer (SCM env, SCM proc) +{ + gh_call1 (proc, env); +} + + +SCM_DEFINE (scm_environment_observe, "environment-observe", 2, 0, 0, + (SCM env, SCM proc), + "Whenever ENV's bindings change, apply PROC to ENV.\n" + "This function returns an object, token, which you can pass to\n" + "environment-unobserve to remove PROC from the set of\n" + "procedures observing ENV. The type and value of token is\n" + "unspecified.") +#define FUNC_NAME s_scm_environment_observe +{ + SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); + + return SCM_ENVIRONMENT_OBSERVE (env, environment_default_observer, proc, 0); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_environment_observe_weak, "environment-observe-weak", 2, 0, 0, + (SCM env, SCM proc), + "This function is the same as environment-observe, except that\n" + "the reference ENV retains to PROC is a weak reference. This\n" + "means that, if there are no other live, non-weak references\n" + "to PROC, it will be garbage-collected, and dropped from ENV's\n" + "list of observing procedures.") +#define FUNC_NAME s_scm_environment_observe_weak +{ + SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); + + return SCM_ENVIRONMENT_OBSERVE (env, environment_default_observer, proc, 1); +} +#undef FUNC_NAME + + +/* This is the C-level analog of the Scheme functions environment-observe and + * environment-observe-weak. Whenever env's bindings change, call the + * function proc, passing it env and data. If weak_p is non-zero, env will + * retain only a weak reference to data, and if data is garbage collected, the + * entire observation will be dropped. This function returns a token, with + * the same meaning as those returned by environment-observe and + * environment-observe-weak. + */ +SCM +scm_c_environment_observe (SCM env, scm_environment_observer proc, SCM data, int weak_p) +#define FUNC_NAME "scm_c_environment_observe" +{ + SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); + + return SCM_ENVIRONMENT_OBSERVE (env, proc, data, weak_p); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_environment_unobserve, "environment-unobserve", 1, 0, 0, + (SCM token), + "Cancel the observation request which returned the value\n" + "TOKEN. The return value is unspecified.\n" + "If a call (environment-observe env proc) returns token, then\n" + "the call (environment-unobserve token) will cause proc to no\n" + "longer be called when env's bindings change.") +#define FUNC_NAME s_scm_environment_unobserve +{ + SCM env; + + SCM_ASSERT (SCM_OBSERVER_P (token), token, SCM_ARG1, FUNC_NAME); + + env = SCM_OBSERVER_ENVIRONMENT (token); + SCM_ENVIRONMENT_UNOBSERVE (env, token); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +static SCM +mark_environment (SCM env) +{ + return (*(SCM_ENVIRONMENT_FUNCS (env)->mark)) (env); +} + + +static scm_sizet +free_environment (SCM env) +{ + return (*(SCM_ENVIRONMENT_FUNCS (env)->free)) (env); +} + + +static int +print_environment (SCM env, SCM port, scm_print_state *pstate) +{ + return (*(SCM_ENVIRONMENT_FUNCS (env)->print)) (env, port, pstate); +} + + + +/* observers */ + +static SCM +mark_observer (SCM observer) +{ + scm_gc_mark (SCM_OBSERVER_ENVIRONMENT (observer)); + scm_gc_mark (SCM_OBSERVER_DATA (observer)); + return SCM_BOOL_F; +} + + +static scm_sizet +free_observer (SCM observer_smob) +{ + return 0; +} + + +static int +print_observer (SCM type, SCM port, scm_print_state *pstate) +{ + SCM address = scm_ulong2num (SCM_UNPACK (type)); + SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16)); + + scm_puts ("#", port); + + return 1; +} + + + +/* obarrays + * + * Obarrays form the basic lookup tables used to implement most of guile's + * built-in environment types. An obarray is implemented as a hash table with + * symbols as keys. The content of the data depends on the environment type. + */ + + +/* + * Copy symbol to obarray. The symbol must not already exist in obarray. + */ +static SCM +obarray_enter (SCM obarray, SCM symbol, SCM data) +{ + scm_sizet hash = SCM_SYMBOL_HASH (symbol); + SCM entry = scm_cons (symbol, data); + SCM slot = scm_cons (entry, SCM_VELTS (obarray)[hash]); + SCM_VELTS (obarray)[hash] = slot; + + return entry; +} + + +/* + * Look up symbol in obarray + */ +static SCM +obarray_retrieve (SCM obarray, SCM sym) +{ + scm_sizet hash = SCM_SYMBOL_HASH (sym); + SCM lsym; + + for (lsym = SCM_VELTS (obarray)[hash]; !SCM_NULLP (lsym); lsym = SCM_CDR (lsym)) + { + SCM entry = SCM_CAR (lsym); + if (SCM_CAR (entry) == sym) + return entry; + } + + return SCM_UNDEFINED; +} + + +/* + * remove entry from obarray + */ +static SCM +obarray_remove (SCM obarray, SCM sym) +{ + scm_sizet hash = SCM_SYMBOL_HASH (sym); + SCM lsym; + SCM *lsymp; + + /* Dirk:FIXME:: gc problem due to use of &SCM_VELTS[hash] */ + for (lsym = *(lsymp = &SCM_VELTS (obarray)[hash]); + !SCM_NULLP (lsym); + lsym = *(lsymp = SCM_CDRLOC (lsym))) + { + SCM entry = SCM_CAR (lsym); + if (SCM_CAR (entry) == sym) + { + *lsymp = SCM_CDR (lsym); + return entry; + } + } + return SCM_BOOL_F; +} + + +static void +obarray_remove_all (SCM obarray) +{ + scm_sizet size = SCM_LENGTH (obarray); + scm_sizet i; + + for (i = 0; i < size; i++) + { + SCM_VELTS (obarray)[i] = SCM_EOL; + } +} + + + +/* core environments base + * + * This struct and the corresponding functions form a base class for guile's + * built-in environment types. + */ + + +struct core_environments_base { + struct scm_environment_funcs *funcs; + + SCM observers; + SCM weak_observers; +}; + + +#define CORE_ENVIRONMENTS_BASE(env) \ + ((struct core_environments_base *) SCM_CELL_WORD_1 (env)) +#define CORE_ENVIRONMENT_OBSERVERS(env) \ + (CORE_ENVIRONMENTS_BASE (env)->observers) +#define SCM_SET_CORE_ENVIRONMENT_OBSERVERS(env, v) \ + (CORE_ENVIRONMENT_OBSERVERS (env) = (v)) +#define CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR(env) \ + (CORE_ENVIRONMENTS_BASE (env)->weak_observers) +#define CORE_ENVIRONMENT_WEAK_OBSERVERS(env) \ + (SCM_VELTS (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env)) [0]) +#define SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS(env, v) \ + (SCM_VELTS (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env)) [0] = (v)) + + + +static SCM +core_environments_observe (SCM env, scm_environment_observer proc, SCM data, int weak_p) +{ + SCM observer; + + SCM_NEWCELL2 (observer); + SCM_SET_CELL_OBJECT_1 (observer, env); + SCM_SET_CELL_OBJECT_2 (observer, data); + SCM_SET_CELL_WORD_3 (observer, proc); + SCM_SET_CELL_TYPE (observer, scm_tc16_observer); + + if (!weak_p) + { + SCM observers = CORE_ENVIRONMENT_OBSERVERS (env); + SCM new_observers = scm_cons (observer, observers); + SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env, new_observers); + } + else + { + SCM observers = CORE_ENVIRONMENT_WEAK_OBSERVERS (env); + SCM new_observers = scm_acons (SCM_BOOL_F, observer, observers); + SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env, new_observers); + } + + return observer; +} + + +static void +core_environments_unobserve (SCM env, SCM observer) +{ + unsigned int handling_weaks; + for (handling_weaks = 0; handling_weaks <= 1; ++handling_weaks) + { + SCM l = handling_weaks + ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env) + : CORE_ENVIRONMENT_OBSERVERS (env); + + if (!SCM_NULLP (l)) + { + SCM rest = SCM_CDR (l); + SCM first = handling_weaks + ? SCM_CDAR (l) + : SCM_CAR (l); + + if (SCM_EQ_P (first, observer)) + { + /* Remove the first observer */ + handling_weaks + ? SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env, rest) + : SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env, rest); + return; + } + + do { + SCM rest = SCM_CDR (l); + + if (!SCM_NULLP (rest)) + { + SCM next = handling_weaks + ? SCM_CDAR (l) + : SCM_CAR (l); + + if (SCM_EQ_P (next, observer)) + { + SCM_SETCDR (l, SCM_CDR (rest)); + return; + } + } + + l = rest; + } while (!SCM_NULLP (l)); + } + } + + /* Dirk:FIXME:: What to do now, since the observer is not found? */ +} + + +static SCM +core_environments_mark (SCM env) +{ + scm_gc_mark (CORE_ENVIRONMENT_OBSERVERS (env)); + return CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env); +} + + +static void +core_environments_finalize (SCM env) +{ +} + + +static void +core_environments_preinit (struct core_environments_base *body) +{ + body->funcs = NULL; + body->observers = SCM_BOOL_F; + body->weak_observers = SCM_BOOL_F; +} + + +static void +core_environments_init (struct core_environments_base *body, + struct scm_environment_funcs *funcs) +{ + body->funcs = funcs; + body->observers = SCM_EOL; + body->weak_observers = scm_make_weak_value_hash_table (SCM_MAKINUM (1)); +} + + +/* Tell all observers to clear their caches. + * + * Environments have to be informed about changes in the following cases: + * - The observed env has a new binding. This must be always reported. + * - The observed env has dropped a binding. This must be always reported. + * - A binding in the observed environment has changed. This must only be + * reported, if there is a chance that the binding is being cached outside. + * However, this potential optimization is not performed currently. + * + * Errors that occur while the observers are called are accumulated and + * signalled as one single error message to the caller. + */ + +struct update_data +{ + SCM observer; + SCM environment; +}; + + +static SCM +update_catch_body (void *ptr) +{ + struct update_data *data = (struct update_data *) ptr; + SCM observer = data->observer; + + (*SCM_OBSERVER_PROC (observer)) + (data->environment, SCM_OBSERVER_DATA (observer)); + + return SCM_UNDEFINED; +} + + +static SCM +update_catch_handler (void *ptr, SCM tag, SCM args) +{ + struct update_data *data = (struct update_data *) ptr; + SCM observer = data->observer; + SCM message = scm_makfrom0str ("Observer `~A' signals `~A' error: ~S"); + + return scm_cons (message, scm_listify (observer, tag, args, SCM_UNDEFINED)); +} + + +static void +core_environments_broadcast (SCM env) +#define FUNC_NAME "core_environments_broadcast" +{ + unsigned int handling_weaks; + SCM errors = SCM_EOL; + + for (handling_weaks = 0; handling_weaks <= 1; ++handling_weaks) + { + SCM observers = handling_weaks + ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env) + : CORE_ENVIRONMENT_OBSERVERS (env); + + for (; !SCM_NULLP (observers); observers = SCM_CDR (observers)) + { + struct update_data data; + SCM observer = handling_weaks + ? SCM_CDAR (observers) + : SCM_CAR (observers); + SCM error; + + data.observer = observer; + data.environment = env; + + error = scm_internal_catch (SCM_BOOL_T, + update_catch_body, &data, + update_catch_handler, &data); + + if (!SCM_UNBNDP (error)) + errors = scm_cons (error, errors); + } + } + + if (!SCM_NULLP (errors)) + { + /* Dirk:FIXME:: As soon as scm_misc_error is fixed to handle the name + * parameter correctly it should not be necessary any more to also pass + * namestr in order to get the desired information from the error + * message. + */ + SCM ordered_errors = scm_reverse (errors); + scm_misc_error + (FUNC_NAME, + "Observers of `~A' have signalled the following errors: ~S", + scm_cons2 (env, ordered_errors, SCM_EOL)); + } +} +#undef FUNC_NAME + + + +/* leaf environments + * + * A leaf environment is simply a mutable set of definitions. A leaf + * environment supports no operations beyond the common set. + * + * Implementation: The obarray of the leaf environment holds (symbol . value) + * pairs. No further information is necessary, since all bindings and + * locations in a leaf environment are mutable. + */ + + +struct leaf_environment { + struct core_environments_base base; + + SCM obarray; +}; + + +#define LEAF_ENVIRONMENT(env) \ + ((struct leaf_environment *) SCM_CELL_WORD_1 (env)) + + + +static SCM +leaf_environment_ref (SCM env, SCM sym) +{ + SCM obarray = LEAF_ENVIRONMENT (env)->obarray; + SCM binding = obarray_retrieve (obarray, sym); + return SCM_UNBNDP (binding) ? binding : SCM_CDR (binding); +} + + +static SCM +leaf_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init) +{ + scm_sizet i; + SCM result = init; + SCM obarray = LEAF_ENVIRONMENT (env)->obarray; + + for (i = 0; i < SCM_LENGTH (obarray); i++) + { + SCM l; + for (l = SCM_VELTS (obarray)[i]; !SCM_NULLP (l); l = SCM_CDR (l)) + { + SCM binding = SCM_CAR (l); + SCM symbol = SCM_CAR (binding); + SCM value = SCM_CDR (binding); + result = (*proc) (data, symbol, value, result); + } + } + return result; +} + + +static SCM +leaf_environment_define (SCM env, SCM sym, SCM val) +#define FUNC_NAME "leaf_environment_define" +{ + SCM obarray = LEAF_ENVIRONMENT (env)->obarray; + SCM old_binding = obarray_retrieve (obarray, sym); + SCM new_binding; + + if (!SCM_UNBNDP (old_binding)) + obarray_remove (obarray, sym); + + new_binding = obarray_enter (obarray, sym, val); + core_environments_broadcast (env); + + return SCM_ENVIRONMENT_SUCCESS; +} +#undef FUNC_NAME + + +static SCM +leaf_environment_undefine (SCM env, SCM sym) +#define FUNC_NAME "leaf_environment_undefine" +{ + SCM obarray = LEAF_ENVIRONMENT (env)->obarray; + SCM binding = obarray_retrieve (obarray, sym); + + if (!SCM_UNBNDP (binding)) + { + obarray_remove (obarray, sym); + core_environments_broadcast (env); + } + + return SCM_ENVIRONMENT_SUCCESS; +} +#undef FUNC_NAME + + +static SCM +leaf_environment_set_x (SCM env, SCM sym, SCM val) +#define FUNC_NAME "leaf_environment_set_x" +{ + SCM obarray = LEAF_ENVIRONMENT (env)->obarray; + SCM binding = obarray_retrieve (obarray, sym); + + if (!SCM_UNBNDP (binding)) + { + SCM_SETCDR (binding, val); + return SCM_ENVIRONMENT_SUCCESS; + } + else + { + return SCM_UNDEFINED; + } +} +#undef FUNC_NAME + + +static SCM +leaf_environment_cell(SCM env, SCM sym, int for_write) +{ + SCM obarray = LEAF_ENVIRONMENT (env)->obarray; + SCM binding = obarray_retrieve (obarray, sym); + return binding; +} + + +static SCM +mark_leaf_environment (SCM env) +{ + scm_gc_mark (LEAF_ENVIRONMENT (env)->obarray); + return core_environments_mark (env); +} + + +static scm_sizet +free_leaf_environment (SCM env) +{ + core_environments_finalize (env); + + free (LEAF_ENVIRONMENT (env)); + return sizeof (struct leaf_environment); +} + + +static int +print_leaf_environment (SCM type, SCM port, scm_print_state *pstate) +{ + SCM address = scm_ulong2num (SCM_UNPACK (type)); + SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16)); + + scm_puts ("#", port); + + return 1; +} + + +static struct scm_environment_funcs leaf_environment_funcs = { + leaf_environment_ref, + leaf_environment_fold, + leaf_environment_define, + leaf_environment_undefine, + leaf_environment_set_x, + leaf_environment_cell, + core_environments_observe, + core_environments_unobserve, + mark_leaf_environment, + free_leaf_environment, + print_leaf_environment +}; + + +void *scm_type_leaf_environment = &leaf_environment_funcs; + + +SCM_DEFINE (scm_make_leaf_environment, "make-leaf-environment", 0, 0, 0, + (), + "Create a new leaf environment, containing no bindings.\n" + "All bindings and locations created in the new environment\n" + "will be mutable.") +#define FUNC_NAME s_scm_make_leaf_environment +{ + scm_sizet size = sizeof (struct leaf_environment); + struct leaf_environment *body = scm_must_malloc (size, FUNC_NAME); + SCM env; + + core_environments_preinit (&body->base); + body->obarray = SCM_BOOL_F; + + env = scm_make_environment (body); + + core_environments_init (&body->base, &leaf_environment_funcs); + body->obarray = scm_make_vector (SCM_MAKINUM (scm_symhash_dim), SCM_EOL); + + return env; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_leaf_environment_p, "leaf-environment?", 1, 0, 0, + (SCM object), + "Return #t if object is a leaf environment, or #f otherwise.") +#define FUNC_NAME s_scm_leaf_environment_p +{ + return SCM_BOOL (SCM_LEAF_ENVIRONMENT_P (object)); +} +#undef FUNC_NAME + + + +/* eval environments + * + * A module's source code refers to definitions imported from other modules, + * and definitions made within itself. An eval environment combines two + * environments -- a local environment and an imported environment -- to + * produce a new environment in which both sorts of references can be + * resolved. + * + * Implementation: The obarray of the eval environment is used to cache + * entries from the local and imported environments such that in most of the + * cases only a single lookup is necessary. Since for neither the local nor + * the imported environment it is known, what kind of environment they form, + * the most general case is assumed. Therefore, entries in the obarray take + * one of the following forms: + * + * 1) ( location mutability . source-env), where mutability indicates + * one of the following states: IMMUTABLE if the location is known to be + * immutable, MUTABLE if the location is known to be mutable, UNKNOWN if + * the location has only been requested for non modifying accesses. + * + * 2) (symbol . source-env) if the symbol has a binding in the source-env, but + * if the source-env can't provide a cell for the binding. Thus, for every + * access, the source-env has to be contacted directly. + */ + + +struct eval_environment { + struct core_environments_base base; + + SCM obarray; + + SCM imported; + SCM imported_observer; + SCM local; + SCM local_observer; +}; + + +#define EVAL_ENVIRONMENT(env) \ + ((struct eval_environment *) SCM_CELL_WORD_1 (env)) + +#define IMMUTABLE SCM_MAKINUM (0) +#define MUTABLE SCM_MAKINUM (1) +#define UNKNOWN SCM_MAKINUM (2) + +#define CACHED_LOCATION(x) SCM_CAR (x) +#define CACHED_MUTABILITY(x) SCM_CADR (x) +#define SET_CACHED_MUTABILITY(x, v) SCM_SETCAR (SCM_CDR (x), (v)) +#define CACHED_SOURCE_ENVIRONMENT(x) SCM_CDDR (x) + + + +/* eval_environment_lookup will report one of the following distinct results: + * a) ( . value) if a cell could be obtained. + * b) if the environment has to be contacted directly. + * c) IMMUTABLE if an immutable cell was requested for write. + * d) SCM_UNDEFINED if there is no binding for the symbol. + */ +static SCM +eval_environment_lookup (SCM env, SCM sym, int for_write) +{ + SCM obarray = EVAL_ENVIRONMENT (env)->obarray; + SCM binding = obarray_retrieve (obarray, sym); + + if (!SCM_UNBNDP (binding)) + { + /* The obarray holds an entry for the symbol. */ + + SCM entry = SCM_CDR (binding); + + if (SCM_CONSP (entry)) + { + /* The entry in the obarray is a cached location. */ + + SCM location = CACHED_LOCATION (entry); + SCM mutability; + + if (!for_write) + return location; + + mutability = CACHED_MUTABILITY (entry); + if (SCM_EQ_P (mutability, MUTABLE)) + return location; + + if (SCM_EQ_P (mutability, UNKNOWN)) + { + SCM source_env = CACHED_SOURCE_ENVIRONMENT (entry); + SCM location = SCM_ENVIRONMENT_CELL (source_env, sym, 1); + + if (SCM_CONSP (location)) + { + SET_CACHED_MUTABILITY (entry, MUTABLE); + return location; + } + else /* IMMUTABLE */ + { + SET_CACHED_MUTABILITY (entry, IMMUTABLE); + return IMMUTABLE; + } + } + + return IMMUTABLE; + } + else + { + /* The obarray entry is an environment */ + + return entry; + } + } + else + { + /* There is no entry for the symbol in the obarray. This can either + * mean that there has not been a request for the symbol yet, or that + * the symbol is really undefined. We are looking for the symbol in + * both the local and the imported environment. If we find a binding, a + * cached entry is created. + */ + + struct eval_environment *body = EVAL_ENVIRONMENT (env); + unsigned int handling_import; + + for (handling_import = 0; handling_import <= 1; ++handling_import) + { + SCM source_env = handling_import ? body->imported : body->local; + SCM location = SCM_ENVIRONMENT_CELL (source_env, sym, for_write); + + if (!SCM_UNBNDP (location)) + { + if (SCM_CONSP (location)) + { + SCM mutability = for_write ? MUTABLE : UNKNOWN; + SCM entry = scm_cons2 (location, mutability, source_env); + obarray_enter (obarray, sym, entry); + return location; + } + else if (SCM_EQ_P (location, SCM_ENVIRONMENT_LOCATION_NO_CELL)) + { + obarray_enter (obarray, sym, source_env); + return source_env; + } + else + { + return IMMUTABLE; + } + } + } + + return SCM_UNDEFINED; + } +} + + +static SCM +eval_environment_ref (SCM env, SCM sym) +#define FUNC_NAME "eval_environment_ref" +{ + SCM location = eval_environment_lookup (env, sym, 0); + + if (SCM_CONSP (location)) + return SCM_CDR (location); + else if (!SCM_UNBNDP (location)) + return SCM_ENVIRONMENT_REF (location, sym); + else + return SCM_UNDEFINED; +} +#undef FUNC_NAME + + +static SCM +eval_environment_folder (SCM extended_data, SCM symbol, SCM value, SCM tail) +{ + SCM local = SCM_CAR (extended_data); + + if (!SCM_ENVIRONMENT_BOUND_P (local, symbol)) + { + SCM proc_as_nr = SCM_CADR (extended_data); + unsigned long int proc_as_ul = scm_num2ulong (proc_as_nr, NULL, NULL); + scm_environment_folder proc = (scm_environment_folder) proc_as_ul; + SCM data = SCM_CDDR (extended_data); + + return (*proc) (data, symbol, value, tail); + } + else + { + return tail; + } +} + + +static SCM +eval_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init) +{ + SCM local = EVAL_ENVIRONMENT (env)->local; + SCM imported = EVAL_ENVIRONMENT (env)->imported; + SCM proc_as_nr = scm_ulong2num ((unsigned long int) proc); + SCM extended_data = scm_cons2 (local, proc_as_nr, data); + SCM tmp_result = scm_c_environment_fold (imported, eval_environment_folder, extended_data, init); + + return scm_c_environment_fold (local, proc, data, tmp_result); +} + + +static SCM +eval_environment_define (SCM env, SCM sym, SCM val) +#define FUNC_NAME "eval_environment_define" +{ + SCM local = EVAL_ENVIRONMENT (env)->local; + return SCM_ENVIRONMENT_DEFINE (local, sym, val); +} +#undef FUNC_NAME + + +static SCM +eval_environment_undefine (SCM env, SCM sym) +#define FUNC_NAME "eval_environment_undefine" +{ + SCM local = EVAL_ENVIRONMENT (env)->local; + return SCM_ENVIRONMENT_UNDEFINE (local, sym); +} +#undef FUNC_NAME + + +static SCM +eval_environment_set_x (SCM env, SCM sym, SCM val) +#define FUNC_NAME "eval_environment_set_x" +{ + SCM location = eval_environment_lookup (env, sym, 1); + + if (SCM_CONSP (location)) + { + SCM_SETCDR (location, val); + return SCM_ENVIRONMENT_SUCCESS; + } + else if (SCM_ENVIRONMENT_P (location)) + { + return SCM_ENVIRONMENT_SET (location, sym, val); + } + else if (SCM_EQ_P (location, IMMUTABLE)) + { + return SCM_ENVIRONMENT_LOCATION_IMMUTABLE; + } + else + { + return SCM_UNDEFINED; + } +} +#undef FUNC_NAME + + +static SCM +eval_environment_cell (SCM env, SCM sym, int for_write) +#define FUNC_NAME "eval_environment_cell" +{ + SCM location = eval_environment_lookup (env, sym, for_write); + + if (SCM_CONSP (location)) + return location; + else if (SCM_ENVIRONMENT_P (location)) + return SCM_ENVIRONMENT_LOCATION_NO_CELL; + else if (SCM_EQ_P (location, IMMUTABLE)) + return SCM_ENVIRONMENT_LOCATION_IMMUTABLE; + else + return SCM_UNDEFINED; +} +#undef FUNC_NAME + + +static SCM +mark_eval_environment (SCM env) +{ + struct eval_environment *body = EVAL_ENVIRONMENT (env); + + scm_gc_mark (body->obarray); + scm_gc_mark (body->imported); + scm_gc_mark (body->imported_observer); + scm_gc_mark (body->local); + scm_gc_mark (body->local_observer); + + return core_environments_mark (env); +} + + +static scm_sizet +free_eval_environment (SCM env) +{ + core_environments_finalize (env); + + free (EVAL_ENVIRONMENT (env)); + return sizeof (struct eval_environment); +} + + +static int +print_eval_environment (SCM type, SCM port, scm_print_state *pstate) +{ + SCM address = scm_ulong2num (SCM_UNPACK (type)); + SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16)); + + scm_puts ("#", port); + + return 1; +} + + +static struct scm_environment_funcs eval_environment_funcs = { + eval_environment_ref, + eval_environment_fold, + eval_environment_define, + eval_environment_undefine, + eval_environment_set_x, + eval_environment_cell, + core_environments_observe, + core_environments_unobserve, + mark_eval_environment, + free_eval_environment, + print_eval_environment +}; + + +void *scm_type_eval_environment = &eval_environment_funcs; + + +static void +eval_environment_observer (SCM caller, SCM eval_env) +{ + SCM obarray = EVAL_ENVIRONMENT (eval_env)->obarray; + + obarray_remove_all (obarray); + core_environments_broadcast (eval_env); +} + + +SCM_DEFINE (scm_make_eval_environment, "make-eval-environment", 2, 0, 0, + (SCM local, SCM imported), + "Return a new environment object eval whose bindings are the\n" + "union of the bindings in the environments local and imported,\n" + "with bindings from local taking precedence. Definitions made\n" + "in eval are placed in local.\n" + "Applying environment-define or environment-undefine to eval\n" + "has the same effect as applying the procedure to local.\n" + "Note that eval incorporates local and imported by reference:\n" + "If, after creating eval, the program changes the bindings of\n" + "local or imported, those changes will be visible in eval.\n" + "Since most Scheme evaluation takes place in eval environments,\n" + "they transparenty cache the bindings received from local and\n" + "imported. Thus, the first time the program looks up a symbol\n" + "in eval, eval may make calls to local or imported to find\n" + "their bindings, but subsequent references to that symbol will\n" + "be as fast as references to bindings in finite environments.\n" + "In typical use, local will be a finite environment, and\n" + "imported will be an import environment") +#define FUNC_NAME s_scm_make_eval_environment +{ + SCM env; + struct eval_environment *body; + + SCM_ASSERT (SCM_ENVIRONMENT_P (local), local, SCM_ARG1, FUNC_NAME); + SCM_ASSERT (SCM_ENVIRONMENT_P (imported), imported, SCM_ARG2, FUNC_NAME); + + body = scm_must_malloc (sizeof (struct eval_environment), FUNC_NAME); + + core_environments_preinit (&body->base); + body->obarray = SCM_BOOL_F; + body->imported = SCM_BOOL_F; + body->imported_observer = SCM_BOOL_F; + body->local = SCM_BOOL_F; + body->local_observer = SCM_BOOL_F; + + env = scm_make_environment (body); + + core_environments_init (&body->base, &eval_environment_funcs); + body->obarray = scm_make_vector (SCM_MAKINUM (scm_symhash_dim), SCM_EOL); + body->imported = imported; + body->imported_observer + = SCM_ENVIRONMENT_OBSERVE (imported, eval_environment_observer, env, 1); + body->local = local; + body->local_observer + = SCM_ENVIRONMENT_OBSERVE (local, eval_environment_observer, env, 1); + + return env; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_eval_environment_p, "eval-environment?", 1, 0, 0, + (SCM object), + "Return #t if object is an eval environment, or #f otherwise.") +#define FUNC_NAME s_scm_eval_environment_p +{ + return SCM_BOOL (SCM_EVAL_ENVIRONMENT_P (object)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_eval_environment_local, "eval-environment-local", 1, 0, 0, + (SCM env), + "Return the local environment of eval environment env.") +#define FUNC_NAME s_scm_eval_environment_local +{ + SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); + + return EVAL_ENVIRONMENT (env)->local; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_eval_environment_set_local_x, "eval-environment-set-local!", 2, 0, 0, + (SCM env, SCM local), + "Change env's local environment to LOCAL.") +#define FUNC_NAME s_scm_eval_environment_set_local_x +{ + struct eval_environment *body; + + SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); + SCM_ASSERT (SCM_ENVIRONMENT_P (local), local, SCM_ARG2, FUNC_NAME); + + body = EVAL_ENVIRONMENT (env); + + obarray_remove_all (body->obarray); + SCM_ENVIRONMENT_UNOBSERVE (body->local, body->local_observer); + + body->local = local; + body->local_observer + = SCM_ENVIRONMENT_OBSERVE (local, eval_environment_observer, env, 1); + + core_environments_broadcast (env); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_eval_environment_imported, "eval-environment-imported", 1, 0, 0, + (SCM env), + "Return the imported environment of eval environment env.") +#define FUNC_NAME s_scm_eval_environment_imported +{ + SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); + + return EVAL_ENVIRONMENT (env)->imported; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_eval_environment_set_imported_x, "eval-environment-set-imported!", 2, 0, 0, + (SCM env, SCM imported), + "Change env's imported environment to IMPORTED.") +#define FUNC_NAME s_scm_eval_environment_set_imported_x +{ + struct eval_environment *body; + + SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); + SCM_ASSERT (SCM_ENVIRONMENT_P (imported), imported, SCM_ARG2, FUNC_NAME); + + body = EVAL_ENVIRONMENT (env); + + obarray_remove_all (body->obarray); + SCM_ENVIRONMENT_UNOBSERVE (body->imported, body->imported_observer); + + body->imported = imported; + body->imported_observer + = SCM_ENVIRONMENT_OBSERVE (imported, eval_environment_observer, env, 1); + + core_environments_broadcast (env); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + + +/* import environments + * + * An import environment combines the bindings of a set of argument + * environments, and checks for naming clashes. + * + * Implementation: The import environment does no caching at all. For every + * access, the list of imported environments is scanned. + */ + + +struct import_environment { + struct core_environments_base base; + + SCM imports; + SCM import_observers; + + SCM conflict_proc; +}; + + +#define IMPORT_ENVIRONMENT(env) \ + ((struct import_environment *) SCM_CELL_WORD_1 (env)) + + + +/* Lookup will report one of the following distinct results: + * a) if only environment binds the symbol. + * b) (env-1 env-2 ...) for conflicting bindings in env-1, ... + * c) SCM_UNDEFINED if there is no binding for the symbol. + */ +static SCM +import_environment_lookup (SCM env, SCM sym) +{ + SCM imports = IMPORT_ENVIRONMENT (env)->imports; + SCM result = SCM_UNDEFINED; + SCM l; + + for (l = imports; !SCM_NULLP (l); l = SCM_CDR (l)) + { + SCM imported = SCM_CAR (l); + + if (SCM_ENVIRONMENT_BOUND_P (imported, sym)) + { + if (SCM_UNBNDP (result)) + result = imported; + else if (SCM_CONSP (result)) + result = scm_cons (imported, result); + else + result = scm_cons2 (imported, result, SCM_EOL); + } + } + + if (SCM_CONSP (result)) + return scm_reverse (result); + else + return result; +} + + +static SCM +import_environment_conflict (SCM env, SCM sym, SCM imports) +{ + SCM conflict_proc = IMPORT_ENVIRONMENT (env)->conflict_proc; + SCM args = scm_cons2 (env, sym, scm_cons (imports, SCM_EOL)); + + return scm_apply (conflict_proc, args, SCM_EOL); +} + + +static SCM +import_environment_ref (SCM env, SCM sym) +#define FUNC_NAME "import_environment_ref" +{ + SCM owner = import_environment_lookup (env, sym); + + if (SCM_UNBNDP (owner)) + { + return SCM_UNDEFINED; + } + else if (SCM_CONSP (owner)) + { + SCM resolve = import_environment_conflict (env, sym, owner); + + if (SCM_ENVIRONMENT_P (resolve)) + return SCM_ENVIRONMENT_REF (resolve, sym); + else + return SCM_UNSPECIFIED; + } + else + { + return SCM_ENVIRONMENT_REF (owner, sym); + } +} +#undef FUNC_NAME + + +static SCM +import_environment_folder (SCM extended_data, SCM symbol, SCM value, SCM tail) +#define FUNC_NAME "import_environment_fold" +{ + SCM import_env = SCM_CAR (extended_data); + SCM imported_env = SCM_CADR (extended_data); + SCM owner = import_environment_lookup (import_env, symbol); + SCM proc_as_nr = SCM_CADDR (extended_data); + unsigned long int proc_as_ul = scm_num2ulong (proc_as_nr, NULL, NULL); + scm_environment_folder proc = (scm_environment_folder) proc_as_ul; + SCM data = SCM_CDDDR (extended_data); + + if (SCM_CONSP (owner) && SCM_EQ_P (SCM_CAR (owner), imported_env)) + owner = import_environment_conflict (import_env, symbol, owner); + + if (SCM_ENVIRONMENT_P (owner)) + return (*proc) (data, symbol, value, tail); + else /* unresolved conflict */ + return (*proc) (data, symbol, SCM_UNSPECIFIED, tail); +} +#undef FUNC_NAME + + +static SCM +import_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init) +{ + SCM proc_as_nr = scm_ulong2num ((unsigned long int) proc); + SCM result = init; + SCM l; + + for (l = IMPORT_ENVIRONMENT (env)->imports; !SCM_NULLP (l); l = SCM_CDR (l)) + { + SCM imported_env = SCM_CAR (l); + SCM extended_data = scm_cons (env, scm_cons2 (imported_env, proc_as_nr, data)); + + result = scm_c_environment_fold (imported_env, import_environment_folder, extended_data, result); + } + + return result; +} + + +static SCM +import_environment_define (SCM env, SCM sym, SCM val) +#define FUNC_NAME "import_environment_define" +{ + return SCM_ENVIRONMENT_BINDING_IMMUTABLE; +} +#undef FUNC_NAME + + +static SCM +import_environment_undefine (SCM env, SCM sym) +#define FUNC_NAME "import_environment_undefine" +{ + return SCM_ENVIRONMENT_BINDING_IMMUTABLE; +} +#undef FUNC_NAME + + +static SCM +import_environment_set_x (SCM env, SCM sym, SCM val) +#define FUNC_NAME "import_environment_set_x" +{ + SCM owner = import_environment_lookup (env, sym); + + if (SCM_UNBNDP (owner)) + { + return SCM_UNDEFINED; + } + else if (SCM_CONSP (owner)) + { + SCM resolve = import_environment_conflict (env, sym, owner); + + if (SCM_ENVIRONMENT_P (resolve)) + return SCM_ENVIRONMENT_SET (resolve, sym, val); + else + return SCM_ENVIRONMENT_LOCATION_IMMUTABLE; + } + else + { + return SCM_ENVIRONMENT_SET (owner, sym, val); + } +} +#undef FUNC_NAME + + +static SCM +import_environment_cell (SCM env, SCM sym, int for_write) +#define FUNC_NAME "import_environment_cell" +{ + SCM owner = import_environment_lookup (env, sym); + + if (SCM_UNBNDP (owner)) + { + return SCM_UNDEFINED; + } + else if (SCM_CONSP (owner)) + { + SCM resolve = import_environment_conflict (env, sym, owner); + + if (SCM_ENVIRONMENT_P (resolve)) + return SCM_ENVIRONMENT_CELL (resolve, sym, for_write); + else + return SCM_ENVIRONMENT_LOCATION_NO_CELL; + } + else + { + return SCM_ENVIRONMENT_CELL (owner, sym, for_write); + } +} +#undef FUNC_NAME + + +static SCM +mark_import_environment (SCM env) +{ + scm_gc_mark (IMPORT_ENVIRONMENT (env)->imports); + scm_gc_mark (IMPORT_ENVIRONMENT (env)->import_observers); + scm_gc_mark (IMPORT_ENVIRONMENT (env)->conflict_proc); + return core_environments_mark (env); +} + + +static scm_sizet +free_import_environment (SCM env) +{ + core_environments_finalize (env); + + free (IMPORT_ENVIRONMENT (env)); + return sizeof (struct import_environment); +} + + +static int +print_import_environment (SCM type, SCM port, scm_print_state *pstate) +{ + SCM address = scm_ulong2num (SCM_UNPACK (type)); + SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16)); + + scm_puts ("#", port); + + return 1; +} + + +static struct scm_environment_funcs import_environment_funcs = { + import_environment_ref, + import_environment_fold, + import_environment_define, + import_environment_undefine, + import_environment_set_x, + import_environment_cell, + core_environments_observe, + core_environments_unobserve, + mark_import_environment, + free_import_environment, + print_import_environment +}; + + +void *scm_type_import_environment = &import_environment_funcs; + + +static void +import_environment_observer (SCM caller, SCM import_env) +{ + core_environments_broadcast (import_env); +} + + +SCM_DEFINE (scm_make_import_environment, "make-import-environment", 2, 0, 0, + (SCM imports, SCM conflict_proc), + "Return a new environment imp whose bindings are the union of\n" + "the bindings from the environments in imports; imports must\n" + "be a list of environments. That is, imp binds symbol to\n" + "location when some element of imports does.\n" + "If two different elements of imports have a binding for the\n" + "same symbol, the conflict-proc is called with the following\n" + "parameters: the import environment, the symbol and the list\n" + "of the imported environments that bind the symbol. If the\n" + "conflict-proc returns an environment env, the conflict is\n" + "considered as resolved and the binding from env is used. If\n" + "the conflict-proc returns some non-environment object, the\n" + "conflict is considered unresolved and the symbol is treated\n" + "as unspecified in the import environment.\n" + "The checking for conflicts may be performed lazily, i. e. at\m" + "the moment when a value or binding for a certain symbol is\n" + "requested instead of the moment when the environment is\n" + "created or the bindings of the imports change.\n" + "All bindings in imp are immutable. If you apply\n" + "environment-define or environment-undefine to imp, Guile\n" + "will signal an environment:immutable-binding error. However,\n" + "notice that the set of bindings in imp may still change, if\n" + "one of its imported environments changes.") +#define FUNC_NAME s_scm_make_import_environment +{ + scm_sizet size = sizeof (struct import_environment); + struct import_environment *body = scm_must_malloc (size, FUNC_NAME); + SCM env; + + core_environments_preinit (&body->base); + body->imports = SCM_BOOL_F; + body->import_observers = SCM_BOOL_F; + body->conflict_proc = SCM_BOOL_F; + + env = scm_make_environment (body); + + core_environments_init (&body->base, &import_environment_funcs); + body->imports = SCM_EOL; + body->import_observers = SCM_EOL; + body->conflict_proc = conflict_proc; + + scm_import_environment_set_imports_x (env, imports); + + return env; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_import_environment_p, "import-environment?", 1, 0, 0, + (SCM object), + "Return #t if object is an import environment, or #f otherwise.") +#define FUNC_NAME s_scm_import_environment_p +{ + return SCM_BOOL (SCM_IMPORT_ENVIRONMENT_P (object)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_import_environment_imports, "import-environment-imports", 1, 0, 0, + (SCM env), + "Return the list of environments imported by the import environment env.") +#define FUNC_NAME s_scm_import_environment_imports +{ + SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); + + return IMPORT_ENVIRONMENT (env)->imports; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_import_environment_set_imports_x, "import-environment-set-imports!", 2, 0, 0, + (SCM env, SCM imports), + "Change env's list of imported environments to imports, and check for conflicts.") +#define FUNC_NAME s_scm_import_environment_set_imports_x +{ + struct import_environment *body = IMPORT_ENVIRONMENT (env); + SCM import_observers = SCM_EOL; + SCM l; + + SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); + for (l = imports; SCM_CONSP (l); l = SCM_CDR (l)) + { + SCM obj = SCM_CAR (l); + SCM_ASSERT (SCM_ENVIRONMENT_P (obj), imports, SCM_ARG1, FUNC_NAME); + } + SCM_ASSERT (SCM_NULLP (l), imports, SCM_ARG1, FUNC_NAME); + + for (l = body->import_observers; !SCM_NULLP (l); l = SCM_CDR (l)) + { + SCM obs = SCM_CAR (l); + SCM_ENVIRONMENT_UNOBSERVE (env, obs); + } + + for (l = imports; !SCM_NULLP (l); l = SCM_CDR (l)) + { + SCM imp = SCM_CAR (l); + SCM obs = SCM_ENVIRONMENT_OBSERVE (imp, import_environment_observer, env, 1); + import_observers = scm_cons (obs, import_observers); + } + + body->imports = imports; + body->import_observers = import_observers; + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + + +/* export environments + * + * An export environment restricts an environment to a specified set of + * bindings. + * + * Implementation: The export environment does no caching at all. For every + * access, the signature is scanned. The signature that is stored internally + * is an alist of pairs (symbol . (mutability)). + */ + + +struct export_environment { + struct core_environments_base base; + + SCM private; + SCM private_observer; + + SCM signature; +}; + + +#define EXPORT_ENVIRONMENT(env) \ + ((struct export_environment *) SCM_CELL_WORD_1 (env)) + + +SCM_SYMBOL (symbol_immutable_location, "immutable-location"); +SCM_SYMBOL (symbol_mutable_location, "mutable-location"); + + + +static SCM +export_environment_ref (SCM env, SCM sym) +#define FUNC_NAME "export_environment_ref" +{ + struct export_environment *body = EXPORT_ENVIRONMENT (env); + SCM entry = scm_assq (sym, body->signature); + + if (SCM_FALSEP (entry)) + return SCM_UNDEFINED; + else + return SCM_ENVIRONMENT_REF (body->private, sym); +} +#undef FUNC_NAME + + +static SCM +export_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init) +{ + struct export_environment *body = EXPORT_ENVIRONMENT (env); + SCM result = init; + SCM l; + + for (l = body->signature; !SCM_NULLP (l); l = SCM_CDR (l)) + { + SCM symbol = SCM_CAR (l); + SCM value = SCM_ENVIRONMENT_REF (body->private, symbol); + if (!SCM_UNBNDP (value)) + result = (*proc) (data, symbol, value, result); + } + return result; +} + + +static SCM +export_environment_define (SCM env, SCM sym, SCM val) +#define FUNC_NAME "export_environment_define" +{ + return SCM_ENVIRONMENT_BINDING_IMMUTABLE; +} +#undef FUNC_NAME + + +static SCM +export_environment_undefine (SCM env, SCM sym) +#define FUNC_NAME "export_environment_undefine" +{ + return SCM_ENVIRONMENT_BINDING_IMMUTABLE; +} +#undef FUNC_NAME + + +static SCM +export_environment_set_x (SCM env, SCM sym, SCM val) +#define FUNC_NAME "export_environment_set_x" +{ + struct export_environment *body = EXPORT_ENVIRONMENT (env); + SCM entry = scm_assq (sym, body->signature); + + if (SCM_FALSEP (entry)) + { + return SCM_UNDEFINED; + } + else + { + if (SCM_EQ_P (SCM_CADR (entry), symbol_mutable_location)) + return SCM_ENVIRONMENT_SET (body->private, sym, val); + else + return SCM_ENVIRONMENT_LOCATION_IMMUTABLE; + } +} +#undef FUNC_NAME + + +static SCM +export_environment_cell (SCM env, SCM sym, int for_write) +#define FUNC_NAME "export_environment_cell" +{ + struct export_environment *body = EXPORT_ENVIRONMENT (env); + SCM entry = scm_assq (sym, body->signature); + + if (SCM_FALSEP (entry)) + { + return SCM_UNDEFINED; + } + else + { + if (!for_write || SCM_EQ_P (SCM_CADR (entry), symbol_mutable_location)) + return SCM_ENVIRONMENT_CELL (body->private, sym, for_write); + else + return SCM_ENVIRONMENT_LOCATION_IMMUTABLE; + } +} +#undef FUNC_NAME + + +static SCM +mark_export_environment (SCM env) +{ + struct export_environment *body = EXPORT_ENVIRONMENT (env); + + scm_gc_mark (body->private); + scm_gc_mark (body->private_observer); + scm_gc_mark (body->signature); + + return core_environments_mark (env); +} + + +static scm_sizet +free_export_environment (SCM env) +{ + core_environments_finalize (env); + + free (EXPORT_ENVIRONMENT (env)); + return sizeof (struct export_environment); +} + + +static int +print_export_environment (SCM type, SCM port, scm_print_state *pstate) +{ + SCM address = scm_ulong2num (SCM_UNPACK (type)); + SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16)); + + scm_puts ("#", port); + + return 1; +} + + +static struct scm_environment_funcs export_environment_funcs = { + export_environment_ref, + export_environment_fold, + export_environment_define, + export_environment_undefine, + export_environment_set_x, + export_environment_cell, + core_environments_observe, + core_environments_unobserve, + mark_export_environment, + free_export_environment, + print_export_environment +}; + + +void *scm_type_export_environment = &export_environment_funcs; + + +static void +export_environment_observer (SCM caller, SCM export_env) +{ + core_environments_broadcast (export_env); +} + + +SCM_DEFINE (scm_make_export_environment, "make-export-environment", 2, 0, 0, + (SCM private, SCM signature), + "Return a new environment exp containing only those bindings\n" + "in private whose symbols are present in signature. The\n" + "private argument must be an environment.\n\n" + "The environment exp binds symbol to location when env does,\n" + "and symbol is exported by signature.\n\n" + "Signature is a list specifying which of the bindings in\n" + "private should be visible in exp. Each element of signature\n" + "should be a list of the form:\n" + " (symbol attribute ...)\n" + "where each attribute is one of the following:\n" + "* the symbol mutable-location exp should treat the location\n" + " bound to symbol as mutable. That is, exp will pass calls\n" + " to env-set! or environment-cell directly through to\n" + " private.\n" + "* the symbol immutable-location exp should treat the\n" + " location bound to symbol as immutable. If the program\n" + " applies environment-set! to exp and symbol, or calls\n" + " environment-cell to obtain a writable value cell,\n" + " environment-set! will signal an\n" + " environment:immutable-location error. Note that, even if\n" + " an export environment treats a location as immutable, the\n" + " underlying environment may treat it as mutable, so its\n" + " value may change.\n" + "It is an error for an element of signature to specify both\n" + "mutable-location and immutable-location. If neither is\n" + "specified, immutable-location is assumed.\n\n" + "As a special case, if an element of signature is a lone\n" + "symbol sym, it is equivalent to an element of the form\n" + "(sym).\n\n" + "All bindings in exp are immutable. If you apply\n" + "environment-define or environment-undefine to exp, Guile\n" + "will signal an environment:immutable-binding error. However,\n" + "notice that the set of bindings in exp may still change, if\n" + "the bindings in private change.") +#define FUNC_NAME s_scm_make_export_environment +{ + scm_sizet size; + struct export_environment *body; + SCM env; + + SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG1, FUNC_NAME); + + size = sizeof (struct export_environment); + body = scm_must_malloc (size, FUNC_NAME); + + core_environments_preinit (&body->base); + body->private = SCM_BOOL_F; + body->private_observer = SCM_BOOL_F; + body->signature = SCM_BOOL_F; + + env = scm_make_environment (body); + + core_environments_init (&body->base, &export_environment_funcs); + body->private = private; + body->private_observer + = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer, env, 1); + body->signature = SCM_EOL; + + scm_export_environment_set_signature_x (env, signature); + + return env; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_export_environment_p, "export-environment?", 1, 0, 0, + (SCM object), + "Return #t if object is an export environment, or #f otherwise.") +#define FUNC_NAME s_scm_export_environment_p +{ + return SCM_BOOL (SCM_EXPORT_ENVIRONMENT_P (object)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_export_environment_private, "export-environment-private", 1, 0, 0, + (SCM env), + "Return the private environment of export environment env.") +#define FUNC_NAME s_scm_export_environment_private +{ + SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); + + return EXPORT_ENVIRONMENT (env)->private; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_export_environment_set_private_x, "export-environment-set-private!", 2, 0, 0, + (SCM env, SCM private), + "Change the private environment of export environment env.") +#define FUNC_NAME s_scm_export_environment_set_private_x +{ + struct export_environment *body; + + SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); + SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG2, FUNC_NAME); + + body = EXPORT_ENVIRONMENT (env); + SCM_ENVIRONMENT_UNOBSERVE (private, body->private_observer); + + body->private = private; + body->private_observer + = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer, env, 1); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_export_environment_signature, "export-environment-signature", 1, 0, 0, + (SCM env), + "Return the signature of export environment env.") +#define FUNC_NAME s_scm_export_environment_signature +{ + SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); + + return EXPORT_ENVIRONMENT (env)->signature; +} +#undef FUNC_NAME + + +static SCM +export_environment_parse_signature (SCM signature, const char* caller) +{ + SCM result = SCM_EOL; + SCM l; + + for (l = signature; SCM_CONSP (l); l = SCM_CDR (l)) + { + SCM entry = SCM_CAR (l); + + if (SCM_SYMBOLP (entry)) + { + SCM new_entry = scm_cons2 (entry, symbol_immutable_location, SCM_EOL); + result = scm_cons (new_entry, result); + } + else + { + SCM sym; + SCM new_entry; + int immutable = 0; + int mutable = 0; + SCM mutability; + SCM l2; + + SCM_ASSERT (SCM_CONSP (entry), entry, SCM_ARGn, caller); + SCM_ASSERT (SCM_SYMBOLP (SCM_CAR (entry)), entry, SCM_ARGn, caller); + + sym = SCM_CAR (entry); + + for (l2 = SCM_CDR (entry); SCM_CONSP (l2); l2 = SCM_CDR (l2)) + { + SCM attribute = SCM_CAR (l2); + if (SCM_EQ_P (attribute, symbol_immutable_location)) + immutable = 1; + else if (SCM_EQ_P (attribute, symbol_mutable_location)) + mutable = 1; + else + SCM_ASSERT (0, entry, SCM_ARGn, caller); + } + SCM_ASSERT (SCM_NULLP (l2), entry, SCM_ARGn, caller); + SCM_ASSERT (!mutable || !immutable, entry, SCM_ARGn, caller); + + if (!mutable && !immutable) + immutable = 1; + + mutability = mutable ? symbol_mutable_location : symbol_immutable_location; + new_entry = scm_cons2 (sym, mutability, SCM_EOL); + result = scm_cons (new_entry, result); + } + } + SCM_ASSERT (SCM_NULLP (l), signature, SCM_ARGn, caller); + + /* Dirk:FIXME:: Now we know that signature is syntactically correct. There + * are, however, no checks for symbols entered twice with contradicting + * mutabilities. It would be nice, to implement this test, to be able to + * call the sort functions conveniently from C. + */ + + return scm_reverse (result); +} + + +SCM_DEFINE (scm_export_environment_set_signature_x, "export-environment-set-signature!", 2, 0, 0, + (SCM env, SCM signature), + "Change the signature of export environment env.") +#define FUNC_NAME s_scm_export_environment_set_signature_x +{ + SCM parsed_sig; + + SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); + parsed_sig = export_environment_parse_signature (signature, FUNC_NAME); + + EXPORT_ENVIRONMENT (env)->signature = parsed_sig; + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + + +void +scm_environments_prehistory () +{ + /* create environment smob */ + scm_tc16_environment = scm_make_smob_type ("environment", 0); + scm_set_smob_mark (scm_tc16_environment, mark_environment); + scm_set_smob_free (scm_tc16_environment, free_environment); + scm_set_smob_print (scm_tc16_environment, print_environment); + + /* create observer smob */ + scm_tc16_observer = scm_make_smob_type ("observer", 0); + scm_set_smob_mark (scm_tc16_observer, mark_observer); + scm_set_smob_free (scm_tc16_observer, free_observer); + scm_set_smob_print (scm_tc16_observer, print_observer); +} + + +void +scm_init_environments () +{ +#include "environments.x" +} + + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/environments.h b/libguile/environments.h new file mode 100644 index 000000000..1c7683b27 --- /dev/null +++ b/libguile/environments.h @@ -0,0 +1,208 @@ +/* classes: h_files */ + +#ifndef ENVIRONMENTS_H +#define ENVIRONMENTS_H +/* Copyright (C) 1999, 2000 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 + * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + + +#include "libguile/__scm.h" + + + +/* The type for folding functions written in C. A function meant to be passed + * to scm_c_environment_fold should have the type scm_environment_folder. + */ +typedef SCM (*scm_environment_folder) (SCM data, SCM sym, SCM val, SCM tail); + + +/* The type for observer functions written in C. A function meant to be + * passed to scm_c_environment_observe should have the type + * scm_environment_observer. + */ +typedef void (*scm_environment_observer) (SCM env, SCM data); + + +struct scm_environment_funcs { + SCM (*ref) (SCM self, SCM symbol); + SCM (*fold) (SCM self, scm_environment_folder proc, SCM data, SCM init); + + SCM (*define) (SCM self, SCM symbol, SCM value); + SCM (*undefine) (SCM self, SCM symbol); + SCM (*set) (SCM self, SCM symbol, SCM value); + + SCM (*cell) (SCM self, SCM symbol, int for_write); + SCM (*observe) (SCM self, scm_environment_observer proc, SCM data, int weak_p); + void (*unobserve) (SCM self, SCM token); + + SCM (*mark) (SCM self); + scm_sizet (*free) (SCM self); + int (*print) (SCM self, SCM port, scm_print_state *pstate); +}; + + + +#define SCM_ENVIRONMENT_SUCCESS SCM_BOOL_T +#define SCM_ENVIRONMENT_BINDING_IMMUTABLE SCM_MAKINUM (0) +#define SCM_ENVIRONMENT_LOCATION_IMMUTABLE SCM_MAKINUM (1) +#define SCM_ENVIRONMENT_LOCATION_NO_CELL SCM_BOOL_F + +extern long scm_tc16_environment; + +#define SCM_ENVIRONMENT_P(x) \ + (!SCM_IMP (x) && SCM_CELL_TYPE (x) == scm_tc16_environment) +#define SCM_ENVIRONMENT_FUNCS(env) \ + (*((struct scm_environment_funcs **) SCM_CELL_WORD_1 (env))) +#define SCM_ENVIRONMENT_BOUND_P(env, symbol) \ + (!SCM_UNBNDP (SCM_ENVIRONMENT_REF (env, symbol))) +#define SCM_ENVIRONMENT_REF(env, symbol) \ + ((*(SCM_ENVIRONMENT_FUNCS (env)->ref)) (env, symbol)) +#define SCM_ENVIRONMENT_FOLD(env, proc, data, init) \ + ((*(SCM_ENVIRONMENT_FUNCS (env)->fold)) (env, proc, data, init)) +#define SCM_ENVIRONMENT_DEFINE(env, symbol, value) \ + ((*(SCM_ENVIRONMENT_FUNCS (env)->define)) (env, symbol, value)) +#define SCM_ENVIRONMENT_UNDEFINE(env, symbol) \ + ((*(SCM_ENVIRONMENT_FUNCS (env)->undefine)) (env, symbol)) +#define SCM_ENVIRONMENT_SET(env, symbol, value) \ + ((*(SCM_ENVIRONMENT_FUNCS (env)->set)) (env, symbol, value)) +#define SCM_ENVIRONMENT_CELL(env, symbol, for_write) \ + ((*(SCM_ENVIRONMENT_FUNCS (env)->cell)) (env, symbol, for_write)) +#define SCM_ENVIRONMENT_OBSERVE(env, proc, data, weak_p) \ + ((*(SCM_ENVIRONMENT_FUNCS (env)->observe)) (env, proc, data, weak_p)) +#define SCM_ENVIRONMENT_UNOBSERVE(env, token) \ + ((*(SCM_ENVIRONMENT_FUNCS (env)->unobserve)) (env, token)) + +extern long scm_tc16_observer; + +#define SCM_OBSERVER_P(x) \ + (!SCM_IMP (x) && (SCM_CELL_TYPE (x) == scm_tc16_observer)) +#define SCM_OBSERVER_ENVIRONMENT(x) \ + (SCM_CELL_OBJECT_1 (x)) +#define SCM_OBSERVER_DATA(x) \ + (SCM_CELL_OBJECT_2 (x)) +#define SCM_OBSERVER_PROC(x) \ + ((scm_environment_observer) SCM_CELL_WORD_3 (x)) + +extern void scm_error_environment_unbound (const char *, SCM, SCM) SCM_NORETURN; +extern void scm_error_environment_immutable_binding (const char *, SCM, SCM) SCM_NORETURN; +extern void scm_error_environment_immutable_location (const char *, SCM, SCM) SCM_NORETURN; + +extern SCM scm_make_environment (void *type); +extern SCM scm_environment_p (SCM env); +extern SCM scm_environment_bound_p (SCM env, SCM sym); +extern SCM scm_environment_ref (SCM env, SCM sym); +extern SCM scm_c_environment_ref (SCM env, SCM sym); +extern SCM scm_environment_fold (SCM env, SCM proc, SCM init); +extern SCM scm_c_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init); +extern SCM scm_environment_define (SCM env, SCM sym, SCM val); +extern SCM scm_environment_undefine (SCM env, SCM sym); +extern SCM scm_environment_set_x (SCM env, SCM sym, SCM val); +extern SCM scm_environment_cell (SCM env, SCM sym, SCM for_write); +extern SCM scm_c_environment_cell (SCM env, SCM sym, int for_write); +extern SCM scm_environment_observe (SCM env, SCM proc); +extern SCM scm_environment_observe_weak (SCM env, SCM proc); +extern SCM scm_c_environment_observe (SCM env, scm_environment_observer proc, SCM data, int weak_p); +extern SCM scm_environment_unobserve (SCM token); + +extern void scm_environments_prehistory (void); +extern void scm_init_environments (void); + + + +extern void *scm_type_leaf_environment; + +#define SCM_LEAF_ENVIRONMENT_P(env) \ + (SCM_ENVIRONMENT_P (env) \ + && SCM_ENVIRONMENT_FUNCS (env) == scm_type_leaf_environment) + +extern SCM scm_make_leaf_environment (void); +extern SCM scm_leaf_environment_p (SCM env); + + + +extern void *scm_type_eval_environment; + +#define SCM_EVAL_ENVIRONMENT_P(env) \ + (SCM_ENVIRONMENT_P (env) \ + && SCM_ENVIRONMENT_FUNCS (env) == scm_type_eval_environment) + +extern SCM scm_make_eval_environment (SCM local, SCM imported); +extern SCM scm_eval_environment_p (SCM env); +extern SCM scm_eval_environment_local (SCM env); +extern SCM scm_eval_environment_set_local_x (SCM env, SCM local); +extern SCM scm_eval_environment_imported (SCM env); +extern SCM scm_eval_environment_set_imported_x (SCM env, SCM imported); + + + +extern void *scm_type_import_environment; + +#define SCM_IMPORT_ENVIRONMENT_P(env) \ + (SCM_ENVIRONMENT_FUNCS (env) == scm_type_import_environment) + +extern SCM scm_make_import_environment (SCM imports, SCM conflict_proc); +extern SCM scm_import_environment_p (SCM env); +extern SCM scm_import_environment_imports (SCM env); +extern SCM scm_import_environment_set_imports_x (SCM env, SCM imports); + + + +extern void *scm_type_export_environment; + +#define SCM_EXPORT_ENVIRONMENT_P(env) \ + (SCM_ENVIRONMENT_FUNCS (env) == scm_type_export_environment) + +extern SCM scm_make_export_environment (SCM private, SCM signature); +extern SCM scm_export_environment_p (SCM env); +extern SCM scm_export_environment_private (SCM env); +extern SCM scm_export_environment_set_private_x (SCM env, SCM private); +extern SCM scm_export_environment_signature (SCM env); +extern SCM scm_export_environment_set_signature_x (SCM env, SCM signature); + + +#endif + + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/init.c b/libguile/init.c index c561adf3b..28b32842c 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -68,6 +68,7 @@ #endif #include "libguile/dynl.h" #include "libguile/dynwind.h" +#include "libguile/environments.h" #include "libguile/eq.h" #include "libguile/error.h" #include "libguile/eval.h" @@ -490,12 +491,14 @@ scm_boot_guile_1 (SCM_STACKITEM *base, struct main_func_closure *closure) scm_struct_prehistory (); /* Must come after scm_init_storage */ scm_weaks_prehistory (); /* Must come after scm_init_storage */ scm_init_subr_table (); + scm_environments_prehistory (); /* create the root environment */ scm_init_root (); #ifdef USE_THREADS scm_init_threads (base); #endif start_stack (base); scm_init_gsubr (); + scm_init_environments (); scm_init_feature (); scm_init_alist (); scm_init_arbiters (); diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index c92509b84..2bac129a0 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2000-08-25 Dirk Herrmann + + * tests/environments.test: Added. + 2000-08-21 Dirk Herrmann * lib.scm (pass-if, expect-fail): Generalized to allow a sequence diff --git a/test-suite/tests/environments.test b/test-suite/tests/environments.test new file mode 100644 index 000000000..42e72e218 --- /dev/null +++ b/test-suite/tests/environments.test @@ -0,0 +1,364 @@ +;;;; environments.test -*- scheme -*- +;;;; Copyright (C) 2000 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. + +(use-modules (ice-9 documentation)) + + +;;; +;;; miscellaneous +;;; + + +(define (documented? object) + (object-documentation object)) + +(define (make-adder) + (let* ((counter 0)) + (lambda increment + (if (not (null? increment)) + (set! counter (+ counter (car increment)))) + counter))) + +(define (folder sym val res) + (cons (cons sym val) res)) + + +;;; +;;; leaf-environments +;;; + +(with-test-prefix "leaf-environments" + + (with-test-prefix "leaf-environment?" + + (pass-if "documented?" + (documented? leaf-environment?)) + + (pass-if "non-environment-object" + (not (leaf-environment? #f)))) + + + (with-test-prefix "make-leaf-environment" + + (pass-if "documented?" + (documented? make-leaf-environment)) + + (pass-if "produces an environment" + (environment? (make-leaf-environment))) + + (pass-if "produces a leaf-environment" + (leaf-environment? (make-leaf-environment))) + + (pass-if "produces always a new environment" + (not (eq? (make-leaf-environment) (make-leaf-environment))))) + + + (with-test-prefix "bound, define, ref, set!, cell" + + (let* ((env (make-leaf-environment)) + (ctr (make-adder))) + + (pass-if "unbound by default" + (and (not (environment-bound? env 'a)) + (not (environment-bound? env 'b)) + (not (environment-bound? env 'c)))) + + (pass-if "bound after define" + (environment-define env 'a (ctr 1)) + (environment-bound? env 'a)) + + (pass-if "ref defined" + (and (begin + (environment-define env 'a (ctr 1)) + (eq? (environment-ref env 'a) (ctr))) + (begin + (environment-define env 'a (ctr 1)) + (eq? (environment-ref env 'a) (ctr))))) + + (pass-if "set! defined" + (and (begin + (environment-set! env 'a (ctr 1)) + (eq? (environment-ref env 'a) (ctr))) + (begin + (environment-set! env 'a (ctr 1)) + (eq? (environment-ref env 'a) (ctr))))) + + (pass-if "read-only cell" + (let* ((cell (environment-cell env 'a #f))) + (and (begin + (environment-set! env 'a (ctr 1)) + (eq? (cdr cell) (ctr)))))) + + (pass-if "read-only cell rebound after define" + (let* ((cell (environment-cell env 'a #f))) + (environment-define env 'a (ctr 1)) + (not (eq? (environment-cell env 'a #f) cell)))) + + (pass-if "writable cell" + (let* ((readable (environment-cell env 'a #f)) + (writable (environment-cell env 'a #t))) + (and (eq? readable writable) + (begin + (environment-set! env 'a (ctr 1)) + (eq? (cdr writable) (ctr))) + (begin + (set-cdr! writable (ctr 1)) + (eq? (environment-ref env 'a) (ctr))) + (begin + (set-cdr! (environment-cell env 'a #t) (ctr 1)) + (eq? (cdr writable) (ctr)))))) + + (pass-if "writable cell rebound after define" + (let* ((cell (environment-cell env 'a #t))) + (environment-define env 'a (ctr 1)) + (not (eq? (environment-cell env 'a #t) cell)))) + + (pass-if "referencing undefined" + (catch #t + (lambda () + (environment-ref env 'b) + #f) + (lambda args + #t))) + + (pass-if "set!ing undefined" + (catch #t + (lambda () + (environment-set! env 'b) + #f) + (lambda args + #t))) + + (pass-if "readable cell from undefined" + (catch #t + (lambda () + (environment-cell env 'b #f) + #f) + (lambda args + #t))) + + (pass-if "writable cell from undefined" + (catch #t + (lambda () + (environment-cell env 'b #t) + #f) + (lambda args + #t))))) + + + (with-test-prefix "undefine" + + (let* ((env (make-leaf-environment))) + + (pass-if "undefine defined" + (environment-define env 'a 1) + (and (environment-bound? env 'a) + (begin + (environment-undefine env 'a) + (not (environment-bound? env 'a))))) + + (pass-if "undefine undefined" + (and (not (environment-bound? env 'a)) + (begin + (environment-undefine env 'a) + (not (environment-bound? env 'a))))))) + + + (with-test-prefix "fold" + + (let* ((env (make-leaf-environment)) + (ctr (make-adder))) + + (pass-if "fold empty" + (eq? 'success (environment-fold env folder 'success))) + + (pass-if "after define" + (environment-define env 'a (ctr 1)) + (equal? `((a . ,(ctr))) (environment-fold env folder '()))) + + (pass-if "after undefine" + (environment-undefine env 'a) + (eq? 'success (environment-fold env folder 'success))) + + (pass-if "after two defines" + (let* ((i (ctr 1)) + (j (+ i 1))) + (environment-define env 'a i) + (environment-define env 'b j) + (let ((folded (environment-fold env folder '()))) + (or (equal? folded `((a . ,i) (b . ,j))) + (equal? folded `((b . ,j) (a . ,i))))))) + + (pass-if "after set!" + (let* ((i (environment-ref env 'a))) + (environment-set! env 'b i) + (let ((folded (environment-fold env folder '()))) + (or (equal? folded `((a . ,i) (b . ,i))) + (equal? folded `((b . ,i) (a . ,i))))))))) + + + (with-test-prefix "observe" + + (let* ((env (make-leaf-environment)) + (tag #f) + (func (lambda (env) (set! tag (not tag)))) + (observer #f)) + + (pass-if "observe unobserved" + (set! observer (environment-observe env func)) + #t) + + (pass-if "define undefined" + (set! tag #f) + (environment-define env 'a 1) + tag) + + (pass-if "define defined" + (set! tag #f) + (environment-define env 'a 1) + tag) + + (pass-if "set! defined" + (set! tag #t) + (environment-set! env 'a 1) + tag) + + (pass-if "undefine defined" + (set! tag #f) + (environment-undefine env 'a) + tag) + + (pass-if "undefine undefined" + (set! tag #t) + (environment-undefine env 'a) + tag) + + (pass-if "unobserve observed" + (set! tag #t) + (environment-unobserve observer) + (environment-define env 'a 1) + tag) + + (pass-if "unobserve unobserved" + (environment-unobserve observer) + #t))) + + + (with-test-prefix "observe-weak" + + (let* ((env (make-leaf-environment)) + (tag #f) + (func (lambda (env) (set! tag (not tag)))) + (observer #f)) + + (pass-if "weak-observe unobserved" + (set! observer (environment-observe-weak env func)) + #t) + + (pass-if "define undefined" + (set! tag #f) + (environment-define env 'a 1) + tag) + + (pass-if "define defined" + (set! tag #f) + (environment-define env 'a 1) + tag) + + (pass-if "set! defined" + (set! tag #t) + (environment-set! env 'a 1) + tag) + + (pass-if "undefine defined" + (set! tag #f) + (environment-undefine env 'a) + tag) + + (pass-if "undefine undefined" + (set! tag #t) + (environment-undefine env 'a) + tag) + + (pass-if "unobserve observed" + (set! tag #t) + (environment-unobserve observer) + (environment-define env 'a 1) + tag) + + (pass-if "unobserve unobserved" + (environment-unobserve observer) + #t) + + (pass-if "weak observer gets collected" + (gc) + (environment-observe-weak env func) + (set! tag #f) + (environment-define env 'a 1) + (and tag + (begin + (gc) + (environment-define env 'a 1) + tag))))) + + + (with-test-prefix "observer-errors" + + (let* ((env (make-leaf-environment)) + (tag-1 #f) + (tag-2 #f) + (func-1 (lambda (env) + (set! tag-1 (not tag-1)) + (error))) + (func-2 (lambda (env) + (set! tag-2 (not tag-2)) + (error)))) + + (pass-if "update continues after error" + (environment-observe env func-1) + (environment-observe env func-2) + (catch #t + (lambda () + (environment-define env 'a 1) + #f) + (lambda args + (and tag-1 tag-2))))))) \ No newline at end of file From 92ccc1f1f326a7eddc3cb0ba4fca15741e51acf2 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 25 Aug 2000 17:33:01 +0000 Subject: [PATCH 0191/2047] * Docstring fixes. --- libguile/ChangeLog | 7 +++++++ libguile/guardians.c | 2 +- libguile/ports.c | 4 ++-- 3 files changed, 10 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 3eac52325..a84181b07 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2000-08-25 Neil Jerram + + * ports.c (scm_set_port_column_x): Fix docstring so that it + mentions set-port-line! rather than set-port-column! twice. + + * guardians.c (scm_make_guardian): Remove spurious . from doc string. + 2000-08-25 Dirk Herrmann * Makefile.am: Added all necessary environments.* files. diff --git a/libguile/guardians.c b/libguile/guardians.c index 94c3072a0..ba092a86e 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -173,7 +173,7 @@ SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 0, 0, "one of the protected objects which are ready for garbage\n" "collection or @code{#f} if no such object is available.\n" "Objects which are returned in this way are removed from\n" - "the guardian.\n\n". + "the guardian.\n\n" "See R. Kent Dybvig, Carl Bruggeman, and David Eby (1993)\n" "\"Guardians in a Generation-Based Garbage Collector\".\n" diff --git a/libguile/ports.c b/libguile/ports.c index 51cbb6ec6..f70db136e 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1249,8 +1249,8 @@ SCM_DEFINE (scm_port_column, "port-column", 1, 0, 0, SCM_DEFINE (scm_set_port_column_x, "set-port-column!", 2, 0, 0, (SCM port, SCM column), - "@deffnx primitive set-port-column! [input-port] column\n" - "Set the current column or line number of @var{input-port}, using the\n" + "@deffnx primitive set-port-line! port line\n" + "Set the current column or line number of @var{port}, using the\n" "current input port if none is specified.") #define FUNC_NAME s_scm_set_port_column_x { From 9b5477f6f615248bb4ed7660a3ac0192b55c587b Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sat, 26 Aug 2000 20:55:21 +0000 Subject: [PATCH 0192/2047] * strings/sharedstr.text (sharedstr.text): New file. --- devel/strings/sharedstr.text | 143 +++++++++++++++++++++++++++++++++++ 1 file changed, 143 insertions(+) create mode 100644 devel/strings/sharedstr.text diff --git a/devel/strings/sharedstr.text b/devel/strings/sharedstr.text new file mode 100644 index 000000000..f568c3ebf --- /dev/null +++ b/devel/strings/sharedstr.text @@ -0,0 +1,143 @@ +Implementation of shared substrings with fresh-copy semantics +============================================================= + +Version: $Id: sharedstr.text,v 1.1 2000-08-26 20:55:21 mdj Exp $ + +Background +---------- + +In Guile, most string operations work on two other data types apart +from strings: shared substrings and read-only strings (which includes +symbols). One of Guile's sub-goals is to be a scripting language in +which string management is important. Read-only strings and shared +substrings were introduced in order to reduce overhead in string +manipulation. + +We now want to simplify the Guile API by removing these two data +types, but keeping performance by allowing ordinary strings to share +storage. + +The idea is to let operations like `symbol->string' and `substring' +return a pointer into the original string/symbol, thus avoiding the +need to copy the string. + +Two of the problems which then arise are: + +* If s2 is derived from s1, and therefore share storage with s1, a + modification to either s1 or s2 will affect the other. + +* Guile is supposed to interact closely with many UNIX libraries in + which the NUL character is used to terminate strings. Therefore + Guile strings contain a NUL character at the end, in addition to the + string length (the latter of which is used by Guile's string + operations). + +The solutions to these problems are to + +* Copy a string with shared storage when it's modified. + +* Copy a string with shared storage when it's being used as argument + to a C library call. (Copying implies inserting an ending NUL + character.) + +But this leads to memory management problems. When is it OK to free +a character array which was allocated for a symbol or a string? + +Abstract description of proposed solution +----------------------------------------- + +Definitions + + STRING = + + SYMBOL = + + CHARRECORD = + + PHASE = black | white + + SHAREDFLAG = private | shared + + CHARS is a character array + + CHARPTR points into it + +Memory management + +A string or symbol is initially allocated with its contents stored in +a character array in a character record. The string/symbol header +contains a pointer to this record. The initial value of the shared +flag in the character record is `private'. + +The GC mark phases alternate between black and white---every second +phase is black, the rest are white. This is used to distinguish +whether a character record has been encountered before: + +During a black mark phase, when the GC encounters a string or symbol, +it changes the PHASE and SHAREDFLAG marks of the corresponding +character record according to the following table: + + --> (white => unconditionally + --> set to ) + --> (SHAREDFLAG changed) + --> (no change) + +The behaviour of a white phase is quivalent with the color names +switched. + +The GC sweep phase frees any unmarked string or symbol header and +frees its character record either if it is marked with the "wrong" +color (not matching the color of the last mark phase) or if its +SHAREDFLAG is `private'. + +Copy-on-write + +An attempt at mutating string contents leads to copying if SHAREDFLAG +is `shared'. Copying means making a copy of the character record and +mutating the CHARRECORDPTR and CHARPTR fields of the object header to +point to the copy. + +Substring operation + +When making a substring, a new string header is allocated, with new +contents for the LENGTH and CHARPTR fields. + +Implementation details +---------------------- + +* We store the character record consecutively with the character + array and lump the PHASE and SHAREDFLAG fields together into one + byte containing an integer code for the four possible states of the + PHASE and SHAREDFLAG fields. Another way of viewing it is that + these fields are represented as bits 1 and 0 in the "header" of the + character array. We let CHARRECORDPTR point to the first character + position instead of on this header: + + CHARRECORDPTR + | + V + FCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + F = 0, 1, 2, 3 + +* We represent strings as the sub-types `simple-string' and + `substring'. + +* In a simple string, CHARRECORDPTR and CHARPTR are represented by a + single pointer, so a `simple-string' is an ordinary heap cell with + TYPETAG and LENGTH in the CAR and CHARPTR in the CDR. + +* substring:s are represented as double cells, with TYPETAG and LENGTH + in word 0, CHARRECORDPTR in word 1 and CHARPTR in word 2 + (alternatively, we could store an offset from CHARRECORDPTR). + +Problems with this implementation +--------------------------------- + +* How do we make copy-on-write thread-safe? Is there a different + implementation which is efficient and thread-safe? + +* If small substrings are frequently generated from large, temporary + strings and the small substrings are kept in a data structure, the + heap will still have to host the large original strings. Should we + simply accept this? From 480a873ce1c9dfba47d1f4866e3cd6657cf08dba Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sat, 26 Aug 2000 20:55:49 +0000 Subject: [PATCH 0193/2047] * environments.c (scm_init_environments): All internal includes in libguile must use the prefix "libguile/" in path names since inly the top-level source directory is on the include list. (That, in turn, is because we want to distinguish between system header files and hedares files internal to libguile.) --- libguile/environments.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/environments.c b/libguile/environments.c index 594adddfb..6cb98bb9e 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -2294,7 +2294,7 @@ scm_environments_prehistory () void scm_init_environments () { -#include "environments.x" +#include "libguile/environments.x" } From 29a34ff64ae76f630022fe0191472f619106bd9d Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sat, 26 Aug 2000 20:56:36 +0000 Subject: [PATCH 0194/2047] Added comment about possible optimization --- libguile/smob.c | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/libguile/smob.c b/libguile/smob.c index da76f5694..02396f950 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -125,6 +125,18 @@ scm_smob_print (SCM exp, SCM port, scm_print_state *pstate) /* {Apply} */ +/* + * A possible future optimization: + * + * Let's call each of the forms of call below a "trampoline". + * + * We could make a function out of each trampoline and store four + * pointers to trampolines in the descriptor, one corresponding to + * each arity of call (apply_0, apply_1 etc.) + * + * Which trampoline to store in which field is chosen in scm_set_smob_apply. + */ + SCM scm_smob_apply_0 (SCM smob) { From e53cc81710b4bb87a9187818473c87cbbbd7f176 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sat, 26 Aug 2000 20:56:48 +0000 Subject: [PATCH 0195/2047] * strings.c (scm_make_shared_substring, scm_read_only_string_p): Deprecated. (scm_string_length, scm_string_ref, scm_substring, scm_string_append): Don't accept symbols as arguments (R5RS). --- libguile/strings.c | 32 +++++++++++++++++++++++++------- 1 file changed, 25 insertions(+), 7 deletions(-) diff --git a/libguile/strings.c b/libguile/strings.c index 44ae6215c..c4a5c3a22 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -62,10 +62,16 @@ SCM_DEFINE (scm_string_p, "string?", 1, 0, 0, "Returns #t iff OBJ is a string, else returns #f.") #define FUNC_NAME s_scm_string_p { - return SCM_BOOL(SCM_STRINGP (obj)); + return SCM_BOOL (SCM_STRINGP (obj)); } #undef FUNC_NAME +#if SCM_DEBUG_DEPRECATED == 0 + +/* The concept of read-only strings will disappear in next release + * of Guile. + */ + SCM_DEFINE (scm_read_only_string_p, "read-only-string?", 1, 0, 0, (SCM x), "Return true if OBJ can be read as a string,\n\n" @@ -83,6 +89,8 @@ SCM_DEFINE (scm_read_only_string_p, "read-only-string?", 1, 0, 0, } #undef FUNC_NAME +#endif /* DEPRECATED */ + SCM_REGISTER_PROC (s_scm_list_to_string, "list->string", 1, 0, 0, scm_string); SCM_DEFINE (scm_string, "string", 0, 0, 1, @@ -243,8 +251,8 @@ SCM_DEFINE (scm_string_length, "string-length", 1, 0, 0, "Returns the number of characters in STRING") #define FUNC_NAME s_scm_string_length { - SCM_VALIDATE_ROSTRING (1,string); - return SCM_MAKINUM (SCM_ROLENGTH (string)); + SCM_VALIDATE_STRINGORSUBSTR (1, string); + return SCM_MAKINUM (SCM_LENGTH (string)); } #undef FUNC_NAME @@ -256,7 +264,7 @@ SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0, { int idx; - SCM_VALIDATE_ROSTRING (1, str); + SCM_VALIDATE_STRINGORSUBSTR (1, str); SCM_VALIDATE_INUM_COPY (2, k, idx); SCM_ASSERT_RANGE (2, k, idx >= 0 && idx < SCM_ROLENGTH (str)); return SCM_MAKE_CHAR (SCM_ROUCHARS (str)[idx]); @@ -290,9 +298,9 @@ SCM_DEFINE (scm_substring, "substring", 2, 1, 0, long int from; long int to; - SCM_VALIDATE_ROSTRING (1,str); + SCM_VALIDATE_STRINGORSUBSTR (1, str); SCM_VALIDATE_INUM (2, start); - SCM_VALIDATE_INUM_DEF (3,end,SCM_ROLENGTH(str)); + SCM_VALIDATE_INUM_DEF (3, end, SCM_ROLENGTH (str)); from = SCM_INUM (start); SCM_ASSERT_RANGE (2, start, 0 <= from && from <= SCM_ROLENGTH (str)); @@ -318,7 +326,7 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, SCM_VALIDATE_REST_ARGUMENT (args); for (l = args; !SCM_NULLP (l); l = SCM_CDR (l)) { s = SCM_CAR (l); - SCM_VALIDATE_ROSTRING (SCM_ARGn,s); + SCM_VALIDATE_STRINGORSUBSTR (SCM_ARGn,s); i += SCM_ROLENGTH (s); } res = scm_makstr (i, 0); @@ -331,6 +339,14 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, } #undef FUNC_NAME +#if SCM_DEBUG_DEPRECATED == 0 + +/* Explicit shared substrings will disappear from Guile. + * + * Instead, "normal" strings will be implemented using sharing + * internally, combined with a copy-on-write strategy. + */ + SCM_DEFINE (scm_make_shared_substring, "make-shared-substring", 1, 2, 0, (SCM str, SCM frm, SCM to), "Return a shared substring of @var{str}. The semantics are the same as\n" @@ -381,6 +397,8 @@ SCM_DEFINE (scm_make_shared_substring, "make-shared-substring", 1, 2, 0, } #undef FUNC_NAME +#endif /* DEPRECATED */ + void scm_init_strings () { From 69b5f65aaafd9fe2fdb62afde0852d13a9d33431 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sat, 26 Aug 2000 20:57:57 +0000 Subject: [PATCH 0196/2047] *** empty log message *** --- NEWS | 12 ++++++++++++ RELEASE | 6 +++--- devel/ChangeLog | 6 ++++++ devel/README | 2 ++ libguile/ChangeLog | 13 +++++++++++++ 5 files changed, 36 insertions(+), 3 deletions(-) diff --git a/NEWS b/NEWS index 6004914c7..459340791 100644 --- a/NEWS +++ b/NEWS @@ -73,6 +73,18 @@ Example: (define (bar) ...) +** Deprecated: scm_make_shared_substring + +Explicit shared substrings will disappear from Guile. + +Instead, "normal" strings will be implemented using sharing +internally, combined with a copy-on-write strategy. + +** Deprecated: scm_read_only_string_p + +The concept of read-only strings will disappear in next release of +Guile. + * Changes to the gh_ interface * Changes to the scm_ interface diff --git a/RELEASE b/RELEASE index 74b5c91a8..913818047 100644 --- a/RELEASE +++ b/RELEASE @@ -7,9 +7,7 @@ absinthe, etc. However, the first release containing the module system should be called Godot: "This is the one you've been waiting for." -* Deprecate `make-shared-substring'! We should arrange for shared - substrings to be generated automatically by `substring' and let string - mutators copy-on-write to otehr storage. +* Deprecate `read-only-string?'. Before releasing the next version of libguile which is not binary compatible with the one released with 1.4: @@ -55,6 +53,8 @@ In release 1.6: SCM_ORD_SIG, SCM_NUM_SIGS - remove function scm_call_catching_errors (replaced by catch functions from throw.[ch]) +- remove scm_make_shared_substring +- remove scm_read_only_string_p Modules sort.c and random.c should be factored out into separate diff --git a/devel/ChangeLog b/devel/ChangeLog index c07edfccb..96e17f8ee 100644 --- a/devel/ChangeLog +++ b/devel/ChangeLog @@ -1,3 +1,9 @@ +2000-08-26 Mikael Djurfeldt + + * strings: New directory. + + * strings/sharedstr.text (sharedstr.text): New file. + 2000-08-12 Mikael Djurfeldt * translate: New directory. diff --git a/devel/README b/devel/README index 7bc502266..2ee832339 100644 --- a/devel/README +++ b/devel/README @@ -4,6 +4,8 @@ policy Guile policy documents build Build/installation process +string Strings and characters + translation Language traslation vm Virtual machines diff --git a/libguile/ChangeLog b/libguile/ChangeLog index a84181b07..b1fa39375 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,16 @@ +2000-08-26 Mikael Djurfeldt + + * environments.c (scm_init_environments): All internal includes in + libguile must use the prefix "libguile/" in path names since inly + the top-level source directory is on the include list. (That, in + turn, is because we want to distinguish between system header + files and hedares files internal to libguile.) + + * strings.c (scm_make_shared_substring, scm_read_only_string_p): + Deprecated. + (scm_string_length, scm_string_ref, scm_substring, + scm_string_append): Don't accept symbols as arguments (R5RS). + 2000-08-25 Neil Jerram * ports.c (scm_set_port_column_x): Fix docstring so that it From 06f0414c85308b4f6bd1cd6f95166cbdb2eb4017 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 27 Aug 2000 03:20:19 +0000 Subject: [PATCH 0197/2047] * boot-9.scm (make-record-type): Use `string-append' instead of `symbol-append'. (symbol-append): Map `symbol->string' on args. (obarray-symbol-append, obarray-gensym): Simply removed. I don't think I'll announce this in NEWS even. One of the functions never even worked... /mdj. (find-and-link-dynamic-module, keyword->symbol): Use `symbol->string'. (try-module-autoload, process-define-module): Rewrote using R5RS semantics. --- ice-9/boot-9.scm | 41 +++++++++++++++++++---------------------- 1 file changed, 19 insertions(+), 22 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 3889fa8b6..2407bfa25 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -315,7 +315,7 @@ (make-keyword-from-dash-symbol (symbol-append '- symbol))) (define (keyword->symbol kw) - (let ((sym (keyword-dash-symbol kw))) + (let ((sym (symbol->string (keyword-dash-symbol kw)))) (string->symbol (substring sym 1 (string-length sym))))) (define (kw-arg-ref args kw) @@ -383,7 +383,7 @@ (let ((printer-fn (and (pair? opt) (car opt)))) (let ((struct (make-struct record-type-vtable 0 (make-struct-layout - (apply symbol-append + (apply string-append (map (lambda (f) "pw") fields))) (or printer-fn (lambda (s p) @@ -471,7 +471,7 @@ ;;; (define (symbol-append . args) - (string->symbol (apply string-append args))) + (string->symbol (apply string-append (map symbol->string args)))) (define (list->symbol . args) (string->symbol (apply list->string args))) @@ -479,14 +479,6 @@ (define (symbol . args) (string->symbol (apply string args))) -(define (obarray-symbol-append ob . args) - (string->obarray-symbol (apply string-append ob args))) - -(define (obarray-gensym obarray . opt) - (if (null? opt) - (gensym "%%gensym" obarray) - (gensym (car opt) obarray))) - ;;; {Lists} ;;; @@ -1813,12 +1805,12 @@ (module-use! module interface)) reversed-interfaces) (module-export! module exports)) - (let ((keyword (cond ((keyword? (car kws)) - (keyword->symbol (car kws))) - ((and (symbol? (car kws)) - (eq? (string-ref (car kws) 0) #\:)) - (string->symbol (substring (car kws) 1))) - (else #f)))) + (let ((keyword (if (keyword? (car kws)) + (keyword->symbol (car kws)) + (and (symbol? (car kws)) + (let ((s (symbol->string (car kws)))) + (and (eq? (string-ref s 0) #\:) + (string->symbol (substring s 1)))))))) (case keyword ((use-module use-syntax) (if (not (pair? (cdr kws))) @@ -1890,9 +1882,12 @@ (define (try-module-autoload module-name) (let* ((reverse-name (reverse module-name)) - (name (car reverse-name)) + (name (symbol->string (car reverse-name))) (dir-hint-module-name (reverse (cdr reverse-name))) - (dir-hint (apply symbol-append (map (lambda (elt) (symbol-append elt "/")) dir-hint-module-name)))) + (dir-hint (apply string-append + (map (lambda (elt) + (string-append (symbol->string elt) "/")) + dir-hint-module-name)))) (resolve-module dir-hint-module-name #f) (and (not (autoload-done-or-in-progress? dir-hint name)) (let ((didit #f)) @@ -2034,11 +2029,13 @@ (let loop ((dirs "") (syms module-name)) (if (null? (cdr syms)) - (cons dirs (string-append "lib" (car syms))) - (loop (string-append dirs (car syms) "/") (cdr syms))))) + (cons dirs (string-append "lib" (symbol->string (car syms)))) + (loop (string-append dirs (symbol->string (car syms)) "/") + (cdr syms))))) (init (make-init-name (apply string-append (map (lambda (s) - (string-append "_" s)) + (string-append "_" + (symbol->string s))) module-name))))) (let ((subdir (car subdir-and-libname)) (libname (cdr subdir-and-libname))) From 3ce4544cfa84d6fd9c025ad2afeab6af22c25680 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 27 Aug 2000 03:20:55 +0000 Subject: [PATCH 0198/2047] * objects.c (scm_init_objects), print.c (scm_init_print), struct.c (scm_init_struct): First arg to scm_make_vtable_vtable should be a string, not a symbol. (`make-vtable-vtable' needs to append this string to another string and then pass it through `make-struct-layout'.) --- libguile/objects.c | 6 ++---- libguile/print.c | 4 +--- 2 files changed, 3 insertions(+), 7 deletions(-) diff --git a/libguile/objects.c b/libguile/objects.c index 568e25a9e..b8c6ac0dd 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -468,13 +468,11 @@ void scm_init_objects () { SCM ms = scm_makfrom0str (SCM_METACLASS_STANDARD_LAYOUT); - SCM ml = scm_make_struct_layout (ms); - SCM mt = scm_make_vtable_vtable (ml, SCM_INUM0, + SCM mt = scm_make_vtable_vtable (ms, SCM_INUM0, SCM_LIST3 (SCM_BOOL_F, SCM_EOL, SCM_EOL)); SCM os = scm_makfrom0str (SCM_METACLASS_OPERATOR_LAYOUT); - SCM ol = scm_make_struct_layout (os); - SCM ot = scm_make_vtable_vtable (ol, SCM_INUM0, + SCM ot = scm_make_vtable_vtable (os, SCM_INUM0, SCM_LIST3 (SCM_BOOL_F, SCM_EOL, SCM_EOL)); SCM es = scm_makfrom0str (SCM_ENTITY_LAYOUT); diff --git a/libguile/print.c b/libguile/print.c index 225a81bcd..5b3e35e69 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1113,9 +1113,7 @@ scm_init_print () SCM vtable, layout, type; scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS); - vtable = scm_make_vtable_vtable (scm_make_struct_layout (scm_nullstr), - SCM_INUM0, - SCM_EOL); + vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL); layout = scm_make_struct_layout (scm_makfrom0str (SCM_PRINT_STATE_LAYOUT)); type = scm_make_struct (vtable, SCM_INUM0, SCM_LIST1 (layout)); scm_set_struct_vtable_name_x (type, SCM_CAR (scm_intern0 ("print-state"))); From b299f5cd5bb8c7324a50f3b1dfc21c3a0582f116 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 27 Aug 2000 03:21:03 +0000 Subject: [PATCH 0199/2047] * stacks.c (scm_init_stacks): Pass a string, not a layout object, to scm_make_vtable_vtable. (Thanks to Dale P. Smith.) --- libguile/stacks.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/libguile/stacks.c b/libguile/stacks.c index 880b59305..1bf8f7a4a 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -734,10 +734,9 @@ void scm_init_stacks () { SCM vtable; - SCM vtable_layout = scm_make_struct_layout (scm_nullstr); SCM stack_layout = scm_make_struct_layout (scm_makfrom0str (SCM_STACK_LAYOUT)); - vtable = scm_make_vtable_vtable (vtable_layout, SCM_INUM0, SCM_EOL); + vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL); scm_stack_type = scm_permanent_object (scm_make_struct (vtable, SCM_INUM0, scm_cons (stack_layout, From 7c31152f99373a6bda9028683330d0495d9dc033 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 27 Aug 2000 03:21:16 +0000 Subject: [PATCH 0200/2047] * struct.c (scm_make_struct_layout): Removed reference to "read-only string" in comment; Check that argument is a string. (scm_make_vtable_vtable): Check that argument is a string. --- libguile/struct.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/libguile/struct.c b/libguile/struct.c index 1c5df0bb3..85e9f4c6f 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -70,7 +70,7 @@ SCM scm_struct_table; SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, (SCM fields), "Return a new structure layout object.\n\n" - "@var{fields} must be a read-only string made up of pairs of characters\n" + "@var{fields} must be a string made up of pairs of characters\n" "strung together. The first character of each pair describes a field\n" "type, the second a field protection. Allowed types are 'p' for\n" "GC-protected Scheme data, 'u' for unprotected binary data, and 's' for\n" @@ -81,7 +81,7 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, #define FUNC_NAME s_scm_make_struct_layout { SCM new_sym; - SCM_VALIDATE_ROSTRING (1,fields); + SCM_VALIDATE_STRINGORSUBSTR (1, fields); { /* scope */ char * field_desc; int len; @@ -525,7 +525,7 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, scm_bits_t * data; SCM handle; - SCM_VALIDATE_ROSTRING (1, user_fields); + SCM_VALIDATE_STRINGORSUBSTR (1, user_fields); SCM_VALIDATE_INUM (2, tail_array_size); SCM_VALIDATE_REST_ARGUMENT (init); @@ -820,7 +820,7 @@ scm_init_struct () { scm_struct_table = scm_permanent_object (scm_make_weak_key_hash_table (SCM_MAKINUM (31))); - required_vtable_fields = SCM_CAR (scm_intern_obarray ("pruosrpw", sizeof ("pruosrpw") - 1, SCM_BOOL_F)); + required_vtable_fields = scm_makfrom0str ("pruosrpw"); scm_permanent_object (required_vtable_fields); scm_sysintern ("vtable-index-layout", SCM_MAKINUM (scm_vtable_index_layout)); scm_sysintern ("vtable-index-vtable", SCM_MAKINUM (scm_vtable_index_vtable)); From 0745d3872ff581cdaa7ed3187e619fa2e064ca96 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 27 Aug 2000 03:21:35 +0000 Subject: [PATCH 0201/2047] *** empty log message *** --- THANKS | 1 + ice-9/ChangeLog | 14 ++++++++++++++ libguile/ChangeLog | 13 +++++++++++++ 3 files changed, 28 insertions(+) diff --git a/THANKS b/THANKS index 8e5e70d22..0ae063d38 100644 --- a/THANKS +++ b/THANKS @@ -18,3 +18,4 @@ For fixes or providing information which led to a fix: Nicolas Neuss Han-Wen Nienhuys William Webber + Dale P. Smith diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index d43ac393a..cecde4da8 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,17 @@ +2000-08-26 Mikael Djurfeldt + + * boot-9.scm (make-record-type): Use `string-append' instead of + `symbol-append'. + (symbol-append): Map `symbol->string' on + args. + (obarray-symbol-append, obarray-gensym): Simply removed. I don't + think I'll announce this in NEWS even. One of the functions never + even worked... /mdj. + (find-and-link-dynamic-module, keyword->symbol): Use + `symbol->string'. + (try-module-autoload, process-define-module): Rewrote using R5RS + semantics. + 2000-08-24 Mikael Djurfeldt * psyntax.ss (set!): Added generalized set! support to core syntax diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b1fa39375..6ca3fb779 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,18 @@ 2000-08-26 Mikael Djurfeldt + * objects.c (scm_init_objects), print.c (scm_init_print), struct.c + (scm_init_struct): First arg to scm_make_vtable_vtable should be a + string, not a symbol. (`make-vtable-vtable' needs to append this + string to another string and then pass it through + `make-struct-layout'.) + + * stacks.c (scm_init_stacks): Pass a string, not a layout object, + to scm_make_vtable_vtable. (Thanks to Dale P. Smith.) + + * struct.c (scm_make_struct_layout): Removed reference to + "read-only string" in comment; Check that argument is a string. + (scm_make_vtable_vtable): Check that argument is a string. + * environments.c (scm_init_environments): All internal includes in libguile must use the prefix "libguile/" in path names since inly the top-level source directory is on the include list. (That, in From 51a4264b156c88c4d81c4277169aed84d195737a Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 27 Aug 2000 03:34:27 +0000 Subject: [PATCH 0202/2047] * gdbint.c (gdb_print): Removed superfluous macro definition. --- libguile/gdbint.c | 2 -- 1 file changed, 2 deletions(-) diff --git a/libguile/gdbint.c b/libguile/gdbint.c index c2b87d920..b873325ed 100644 --- a/libguile/gdbint.c +++ b/libguile/gdbint.c @@ -106,8 +106,6 @@ do { \ } while (0) -#define MSG_GUILE_NOT_INITIALIZED "*** Guile not initialized ***" - #define RESET_STRING { gdb_output_length = 0; } #define SEND_STRING(str) \ From adf9e9592de94e2755a98a2978bc139fdc1f2d54 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 27 Aug 2000 03:34:38 +0000 Subject: [PATCH 0203/2047] *** empty log message *** --- libguile/ChangeLog | 2 ++ 1 file changed, 2 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6ca3fb779..bf1ba0d14 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,7 @@ 2000-08-26 Mikael Djurfeldt + * gdbint.c (gdb_print): Removed superfluous macro definition. + * objects.c (scm_init_objects), print.c (scm_init_print), struct.c (scm_init_struct): First arg to scm_make_vtable_vtable should be a string, not a symbol. (`make-vtable-vtable' needs to append this From 3731149d83f8751cf5351cec58466d5e4d39dc64 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Sat, 2 Sep 2000 21:52:35 +0000 Subject: [PATCH 0204/2047] * gc.c (scm_mark_locations): mark freecells too, and don't worry about any possible false positives. (scm_debug_newcell): don't change cell type to `allocated'. (scm_debug_newcell2): ditto. (scm_gc_for_newcell): ditto. (scm_gc_mark): remove the tc16_allocated case. --- libguile/gc.c | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/libguile/gc.c b/libguile/gc.c index 980567a0e..20883d300 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -651,7 +651,6 @@ scm_debug_newcell (void) { new = scm_freelist; scm_freelist = SCM_FREE_CELL_CDR (scm_freelist); - SCM_SET_FREE_CELL_TYPE (new, scm_tc16_allocated); } return new; @@ -677,7 +676,6 @@ scm_debug_newcell2 (void) { new = scm_freelist2; scm_freelist2 = SCM_FREE_CELL_CDR (scm_freelist2); - SCM_SET_FREE_CELL_TYPE (new, scm_tc16_allocated); } return new; @@ -935,7 +933,6 @@ scm_gc_for_newcell (scm_freelist_t *master, SCM *freelist) --scm_ints_disabled; *freelist = SCM_FREE_CELL_CDR (cell); - SCM_SET_FREE_CELL_TYPE (cell, scm_tc16_allocated); return cell; } @@ -1342,7 +1339,6 @@ gc_mark_nimp: { /* should be faster than going through scm_smobs */ case scm_tc_free_cell: /* printf("found free_cell %X ", ptr); fflush(stdout); */ - case scm_tc16_allocated: case scm_tc16_big: case scm_tc16_real: case scm_tc16_complex: @@ -1427,10 +1423,8 @@ scm_mark_locations (SCM_STACKITEM x[], scm_sizet n) if (scm_heap_table[seg_id].span == 1 || SCM_DOUBLE_CELLP (obj)) - { - if (!SCM_FREE_CELL_P (obj)) - scm_gc_mark (obj); - } + scm_gc_mark (obj); + break; } } From 3c8018e61e719935cb552f3d9a80ddeb88cc1d0d Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Sat, 2 Sep 2000 21:53:02 +0000 Subject: [PATCH 0205/2047] * gc.h: removed now-obsolete comments about the `allocated' cell state. (SCM_NEWCELL): don't change cell type to `allocated'. (SCM_NEWCELL2): ditto. --- libguile/gc.h | 11 +---------- 1 file changed, 1 insertion(+), 10 deletions(-) diff --git a/libguile/gc.h b/libguile/gc.h index 48d2611e5..afa6f1f54 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -249,19 +249,12 @@ typedef unsigned long scm_c_bvec_limb_t; #define SCM_SET_FREE_CELL_CDR(x, v) \ (((scm_bits_t *) SCM2PTR (x)) [1] = SCM_UNPACK (v)) -/* the allocated thing: The car of new cells is set to - scm_tc16_allocated to avoid the fragile state of newcells wrt the - gc. If it stays as a freecell, any allocation afterwards could - cause the cell to go back on the freelist, which will bite you - sometime afterwards. */ - #ifdef GUILE_DEBUG_FREELIST #define SCM_NEWCELL(_into) do { _into = scm_debug_newcell (); } while (0) #define SCM_NEWCELL2(_into) do { _into = scm_debug_newcell2 (); } while (0) #else /* When we introduce POSIX threads support, every thread will have - a freelist of its own. Then it won't any longer be necessary to - initialize cells with scm_tc16_allocated. */ + a freelist of its own. */ #define SCM_NEWCELL(_into) \ do { \ if (SCM_IMP (scm_freelist)) \ @@ -271,7 +264,6 @@ typedef unsigned long scm_c_bvec_limb_t; { \ _into = scm_freelist; \ scm_freelist = SCM_FREE_CELL_CDR (scm_freelist); \ - SCM_SET_FREE_CELL_TYPE (_into, scm_tc16_allocated); \ } \ } while(0) #define SCM_NEWCELL2(_into) \ @@ -283,7 +275,6 @@ typedef unsigned long scm_c_bvec_limb_t; { \ _into = scm_freelist2; \ scm_freelist2 = SCM_FREE_CELL_CDR (scm_freelist2); \ - SCM_SET_FREE_CELL_TYPE (_into, scm_tc16_allocated); \ } \ } while(0) #endif From 228c97488af0759a48c42899cd232e2af398c72b Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Sat, 2 Sep 2000 21:53:20 +0000 Subject: [PATCH 0206/2047] * smob.c (scm_smob_prehistory): don't init the "allocated" smob type. --- libguile/smob.c | 2 -- 1 file changed, 2 deletions(-) diff --git a/libguile/smob.c b/libguile/smob.c index 02396f950..1be908356 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -439,8 +439,6 @@ scm_smob_prehistory () scm_make_smob_type_mfpe ("complex", 0, /* freed in gc */ NULL, NULL, scm_print_complex, scm_complex_equalp); - - scm_make_smob_type ("allocated", 0); } /* From 98185197b1a502de37eee361d11add575a27f60a Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Sat, 2 Sep 2000 21:53:38 +0000 Subject: [PATCH 0207/2047] * tags.h (scm_tc16_allocated): removed. --- libguile/tags.h | 5 ----- 1 file changed, 5 deletions(-) diff --git a/libguile/tags.h b/libguile/tags.h index 13901548d..dac0cd652 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -414,11 +414,6 @@ typedef long scm_bits_t; #define scm_tc16_real 0x027f #define scm_tc16_complex 0x037f -/* Smob type 4 allocated, but not initialized cells; - this is required to prevent the gc from hosing your cells if - you have to allocate while creating the cell*/ -#define scm_tc16_allocated 0x047f - /* {Immediate Values} */ From eacb9dc265965b768c9b074d79c3f19f87c07bd1 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Sat, 2 Sep 2000 21:54:13 +0000 Subject: [PATCH 0208/2047] *** empty log message *** --- libguile/ChangeLog | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index bf1ba0d14..9ff0f4afd 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,25 @@ +2000-09-03 Michael Livshin + + the following changes let Guile get rid of the `allocated' cell + state. + + * smob.c (scm_smob_prehistory): don't init the "allocated" smob + type. + + * tags.h (scm_tc16_allocated): removed. + + * gc.h: removed now-obsolete comments about the `allocated' cell + state. + (SCM_NEWCELL): don't change cell type to `allocated'. + (SCM_NEWCELL2): ditto. + + * gc.c (scm_mark_locations): mark freecells too, and don't worry + about any possible false positives. + (scm_debug_newcell): don't change cell type to `allocated'. + (scm_debug_newcell2): ditto. + (scm_gc_for_newcell): ditto. + (scm_gc_mark): remove the tc16_allocated case. + 2000-08-26 Mikael Djurfeldt * gdbint.c (gdb_print): Removed superfluous macro definition. From 31daeb2db8ca58b14794e42e9ee7e11b5f481d5c Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 2 Sep 2000 23:13:33 +0000 Subject: [PATCH 0209/2047] * Docstring update for scm_vector. --- libguile/vectors.c | 1 + 1 file changed, 1 insertion(+) diff --git a/libguile/vectors.c b/libguile/vectors.c index e2e94e156..f066f92b2 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -159,6 +159,7 @@ SCM_REGISTER_PROC (s_list_to_vector, "list->vector", 1, 0, 0, scm_vector); */ SCM_DEFINE (scm_vector, "vector", 0, 0, 1, (SCM l), + "@deffnx primitive list->vector l\n" "Returns a newly allocated vector whose elements contain the given\n" "arguments. Analogous to @samp{list}. (r5rs)\n\n" "@format\n" From ec57ce2ecadeff4a5d4b6b2afa0a70d31a00bae7 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 2 Sep 2000 23:15:04 +0000 Subject: [PATCH 0210/2047] * Docstring updates for scm_uniform_vector_ref and scm_array_set_x. --- libguile/unif.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/libguile/unif.c b/libguile/unif.c index cc029157d..44cb0c2c8 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1072,6 +1072,7 @@ SCM_REGISTER_PROC(s_array_ref, "array-ref", 1, 0, 1, scm_uniform_vector_ref); SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, (SCM v, SCM args), + "@deffnx primitive array-ref v . args\n" "Returns the element at the @code{(index1, index2)} element in @var{array}.") #define FUNC_NAME s_scm_uniform_vector_ref { @@ -1245,6 +1246,7 @@ SCM_REGISTER_PROC(s_uniform_array_set1_x, "uniform-array-set1!", 3, 0, 0, scm_ar PROC is used (and it's called from C too). */ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, (SCM v, SCM obj, SCM args), + "@deffnx primitive uniform-array-set1! v obj args\n" "Sets the element at the @code{(index1, index2)} element in @var{array} to\n" "@var{new-value}. The value returned by array-set! is unspecified.") #define FUNC_NAME s_scm_array_set_x From ae42688c46f8f024153934c5e8935029fc7f7d4e Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 2 Sep 2000 23:16:00 +0000 Subject: [PATCH 0211/2047] * Docstring updates for scm_symbol_to_string. --- libguile/symbols.c | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/libguile/symbols.c b/libguile/symbols.c index 49e63aadc..919f806db 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -436,16 +436,16 @@ SCM_DEFINE (scm_symbol_p, "symbol?", 1, 0, 0, SCM_DEFINE (scm_symbol_to_string, "symbol->string", 1, 0, 0, (SCM s), "Returns the name of @var{symbol} as a string. If the symbol was part of\n" - "an object returned as the value of a literal expression\n" - "(section @pxref{Literal expressions}) or by a call to the @samp{read} procedure,\n" - "and its name contains alphabetic characters, then the string returned\n" - "will contain characters in the implementation's preferred standard\n" - "case---some implementations will prefer upper case, others lower case.\n" - "If the symbol was returned by @samp{string->symbol}, the case of\n" - "characters in the string returned will be the same as the case in the\n" - "string that was passed to @samp{string->symbol}. It is an error\n" - "to apply mutation procedures like @code{string-set!} to strings returned\n" - "by this procedure. (r5rs)\n\n" + "an object returned as the value of a literal expression (section\n" + "@pxref{Literal expressions,,,r4rs, The Revised^4 Report on Scheme}) or\n" + "by a call to the @samp{read} procedure, and its name contains alphabetic\n" + "characters, then the string returned will contain characters in the\n" + "implementation's preferred standard case---some implementations will\n" + "prefer upper case, others lower case. If the symbol was returned by\n" + "@samp{string->symbol}, the case of characters in the string returned\n" + "will be the same as the case in the string that was passed to\n" + "@samp{string->symbol}. It is an error to apply mutation procedures like\n" + "@code{string-set!} to strings returned by this procedure. (r5rs)\n\n" "The following examples assume that the implementation's standard case is\n" "lower case:\n\n" "@format\n" @@ -453,8 +453,8 @@ SCM_DEFINE (scm_symbol_to_string, "symbol->string", 1, 0, 0, " ==> \"flying-fish\"\n" "(symbol->string 'Martin) ==> \"martin\"\n" "(symbol->string\n" - " (string->symbol "Malvina")) \n" - " ==> \"Malvina\"\n" + " (string->symbol \"Malvina\")) \n" + " ==> \"Malvina\"\n" "}\n" "@end format") #define FUNC_NAME s_scm_symbol_to_string From 6386e25c29a5402fba343ef417c0ceb1704b7223 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 2 Sep 2000 23:17:23 +0000 Subject: [PATCH 0212/2047] * Docstring updates for scm_make_struct and scm_make_vtable_vtable. --- libguile/struct.c | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/libguile/struct.c b/libguile/struct.c index 85e9f4c6f..5f36eb958 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -414,7 +414,7 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, "@var{tail-elts} must be a non-negative integer. If the layout\n" "specification indicated by @var{type} includes a tail-array,\n" "this is the number of elements allocated to that array.\n\n" - "The @var{init1}, @dots are optional arguments describing how\n" + "The @var{init1}, @dots{} are optional arguments describing how\n" "successive fields of the structure should be initialized. Only fields\n" "with protection 'r' or 'w' can be initialized, except for fields of\n" "type 's', which are automatically initialized to point to the new\n" @@ -427,8 +427,7 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, "structures in Guile. The plan is to eventually replace them with a\n" "new representation which will at the same time be easier to use and\n" "more powerful.\n\n" - "For more information, see the documentation for @code{make-vtable-vtable}.\n" - "") + "For more information, see the documentation for @code{make-vtable-vtable}.") #define FUNC_NAME s_scm_make_struct { SCM layout; @@ -477,7 +476,7 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, "(see @code{make-struct-layout}).\n\n" "@var{tail-size} specifies the size of the tail-array (if any) of\n" "this vtable.\n\n" - "@var{init1}, @dots are the optional initializers for the fields of\n" + "@var{init1}, @dots{} are the optional initializers for the fields of\n" "the vtable.\n\n" "Vtables have one initializable system field---the struct printer.\n" "This field comes before the user fields in the initializers passed\n" From 09831f943c156eb534608ce91225602b42a567e5 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 2 Sep 2000 23:20:40 +0000 Subject: [PATCH 0213/2047] * Docstring fixes. --- libguile/posix.c | 4 ++-- libguile/ramap.c | 2 ++ libguile/socket.c | 3 ++- libguile/stime.c | 5 +++-- 4 files changed, 9 insertions(+), 5 deletions(-) diff --git a/libguile/posix.c b/libguile/posix.c index fd98dc882..813cda850 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1198,8 +1198,8 @@ SCM_DEFINE (scm_mknod, "mknod", 4, 0, 0, "being created.\n\n" "E.g.,\n" "@example\n" - "(mknod \"/dev/fd0\" 'block-special #o660 (+ (* 2 256) 2))" - "@end example\n" + "(mknod \"/dev/fd0\" 'block-special #o660 (+ (* 2 256) 2))\n" + "@end example\n\n" "The return value is unspecified.") #define FUNC_NAME s_scm_mknod { diff --git a/libguile/ramap.c b/libguile/ramap.c index 704976acd..679439177 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -813,6 +813,7 @@ SCM_REGISTER_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0, scm_ SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0, (SCM src, SCM dst), + "@deffnx primitive array-copy-in-order! src dst\n" "Copies every element from vector or array @var{source} to the\n" "corresponding element of @var{destination}. @var{destination} must have\n" "the same rank as @var{source}, and be at least as large in each\n" @@ -1495,6 +1496,7 @@ SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_ar SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1, (SCM ra0, SCM proc, SCM lra), + "@deffnx primitive array-map-in-order! ra0 proc . lra\n" "@var{array1}, @dots{} must have the same number of dimensions as\n" "@var{array0} and have a range for each index which includes the range\n" "for the corresponding index in @var{array0}. @var{proc} is applied to\n" diff --git a/libguile/socket.c b/libguile/socket.c index 37c44a1b8..47166e1ca 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -696,7 +696,8 @@ SCM_DEFINE (scm_recv, "recv!", 2, 1, 0, "The optional @var{flags} argument is a value or\n" "bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n" "The value returned is the number of bytes read from the socket.\n\n" - "Note that the data is read directly from the socket file descriptor:any unread buffered port data is ignored.") + "Note that the data is read directly from the socket file descriptor:\n" + "any unread buffered port data is ignored.") #define FUNC_NAME s_scm_recv { int rv; diff --git a/libguile/stime.c b/libguile/stime.c index 460e8f3a9..f44e003c3 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -220,7 +220,8 @@ SCM_DEFINE (scm_get_internal_run_time, "get-internal-run-time", 0, 0, 0, SCM_DEFINE (scm_current_time, "current-time", 0, 0, 0, (void), - "Returns the number of seconds since 1970-01-01 00:00:00 UTC, excludingleap seconds.") + "Returns the number of seconds since 1970-01-01 00:00:00 UTC, excluding\n" + "leap seconds.") #define FUNC_NAME s_scm_current_time { timet timv; @@ -660,7 +661,7 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, "but the time zone components\n" "are not usefully set.\n" "The CDR reports the number of characters from @var{string} which\n" - "vwere used for the conversion.") + "were used for the conversion.") #define FUNC_NAME s_scm_strptime { struct tm t; From 11768c044a883f4105dd36bd87c047f276128cfb Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 2 Sep 2000 23:23:16 +0000 Subject: [PATCH 0214/2047] * Docstring updates. --- libguile/ChangeLog | 43 +++++++++++++++++++++++++++++++++++++++++++ libguile/eval.c | 4 +++- libguile/modules.c | 10 +++++----- libguile/strings.c | 1 + libguile/strop.c | 2 ++ 5 files changed, 54 insertions(+), 6 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 9ff0f4afd..1ff3b9e9d 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,46 @@ +2000-09-03 Neil Jerram + + * vectors.c (scm_vector): Docstring: add @deffnx line for + list->vector. + + * unif.c (scm_uniform_vector_ref): Docstring: add @deffnx line for + array-ref. + (scm_array_set_x): Docstring: add @deffnx line for + uniform-array-set!. + + * symbols.c (scm_symbol_to_string): Docstring: complete an + incomplete Texinfo reference to a node in r4rs.texi. + (scm_symbol_to_string): Escape double quotes correctly within + docstring. + + * struct.c (scm_make_struct, scm_make_vtable_vtable): Docstring + fixes: `@dots' changed to `@dots{}'. + + * strop.c (scm_substring_move_x): Docstring: add @deffnx lines for + substring-move-left! and substring-move-right!. + + * strings.c (scm_string): Docstring: add @deffnx line for + list->string. + + * stime.c (scm_strptime): Fix spelling mistake in docstring. + (scm_current_time): Docstring fix: insert missing newline. + + * socket.c (scm_recvfrom): Docstring format fix: missing newline + inserted. + + * ramap.c (scm_array_copy_x): Docstring: add @deffnx line for + array-copy-in-order!. + (scm_array_map_x): Docstring: add @deffnx line for + array-map-in-order!. + + * posix.c (scm_mknod): Docstring format fix: missing newlines + inserted. + + * modules.c (scm_interaction_environment): Docstring fix: add + newlines. + + * eval.c (scm_cons_source): Added newly written docstring. + 2000-09-03 Michael Livshin the following changes let Guile get rid of the `allocated' cell diff --git a/libguile/eval.c b/libguile/eval.c index 74574fd55..41c10c3e7 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3802,7 +3802,9 @@ SCM_DEFINE (scm_promise_p, "promise?", 1, 0, 0, SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0, (SCM xorig, SCM x, SCM y), - "") + "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n" + "Any source properties associated with @var{xorig} are also associated\n" + "with the new pair.") #define FUNC_NAME s_scm_cons_source { SCM p, z; diff --git a/libguile/modules.c b/libguile/modules.c index a59aec6a9..ae062ab74 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -94,11 +94,11 @@ scm_select_module (SCM module) SCM_DEFINE (scm_interaction_environment, "interaction-environment", 0, 0, 0, (), - "This procedure returns a specifier for the environment that" - "contains implementation-defined bindings, typically a superset of" - "those listed in the report. The intent is that this procedure" - "will return the environment in which the implementation would" - "evaluate expressions dynamically typed by the user.") + "This procedure returns a specifier for the environment that contains\n" + "implementation-defined bindings, typically a superset of those listed in\n" + "the report. The intent is that this procedure will return the\n" + "environment in which the implementation would evaluate expressions\n" + "dynamically typed by the user.") #define FUNC_NAME s_scm_interaction_environment { return scm_selected_module (); diff --git a/libguile/strings.c b/libguile/strings.c index c4a5c3a22..1c4df1da1 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -95,6 +95,7 @@ SCM_REGISTER_PROC (s_scm_list_to_string, "list->string", 1, 0, 0, scm_string); SCM_DEFINE (scm_string, "string", 0, 0, 1, (SCM chrs), + "@deffnx primitive list->string chrs\n" "Returns a newly allocated string composed of the arguments, CHRS.") #define FUNC_NAME s_scm_string { diff --git a/libguile/strop.c b/libguile/strop.c index abb6ae25b..b777c8a7d 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -227,6 +227,8 @@ y SCM_DEFINE (scm_substring_move_x, "substring-move!", 5, 0, 0, (SCM str1, SCM start1, SCM end1, SCM str2, SCM start2), + "@deffnx primitive substring-move-left! str1 start1 end1 str2 start2\n" + "@deffnx primitive substring-move-right! str1 start1 end1 str2 start2\n" "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}\n" "into @var{str2} beginning at position @var{end2}.\n" "@code{substring-move-right!} begins copying from the rightmost character\n" From db36bd509b40701befe46855aef0369720cee43e Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Sep 2000 20:18:58 +0000 Subject: [PATCH 0215/2047] Add note about "#&". --- RELEASE | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/RELEASE b/RELEASE index 913818047..c13ae47c6 100644 --- a/RELEASE +++ b/RELEASE @@ -53,10 +53,10 @@ In release 1.6: SCM_ORD_SIG, SCM_NUM_SIGS - remove function scm_call_catching_errors (replaced by catch functions from throw.[ch]) +- remove support for "#&" reader syntax in (ice-9 optargs). - remove scm_make_shared_substring - remove scm_read_only_string_p - Modules sort.c and random.c should be factored out into separate modules (but still be distributed with guile-core) when we get a new module system. From 2d55a919c3e44e7deed23d89b6e83960be6741a9 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Sep 2000 20:20:19 +0000 Subject: [PATCH 0216/2047] * boot-9.scm (make-object-property): New function. --- ice-9/boot-9.scm | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 2407bfa25..41d4eb9f6 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -153,6 +153,17 @@ (if pair (symbol-pset! sym (delq! pair (symbol-pref sym)))))) +;;; {General Properties} + +;; This is a more modern interface to properties. It will replace all +;; other property-like things eventually. + +(define (make-object-property) + (let ((prop (primitive-make-property #f))) + (make-procedure-with-setter + (lambda (obj) (primitive-property-ref prop obj)) + (lambda (obj val) (primitive-property-set! prop obj val))))) + ;;; {Line and Delimited I/O} From 8c142820ea82772e832eb62d65726616b57ddead Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Sep 2000 20:20:58 +0000 Subject: [PATCH 0217/2047] *** empty log message *** --- ice-9/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index cecde4da8..28124fc90 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2000-08-27 Marius Vollmer + + * boot-9.scm (make-object-property): New function. + 2000-08-26 Mikael Djurfeldt * boot-9.scm (make-record-type): Use `string-append' instead of From faf6a29b1feb5bcad75121e3ec6c2b0ef51909c1 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Sep 2000 20:22:41 +0000 Subject: [PATCH 0218/2047] * Makefile.am (.x.doc): Pretend to create .doc files from .x files and give explicit dependencies for .x files that depend on generated files. This allows parallel builds. Thanks to Matthias Koeppe! * Makefile.am: Added gc_os_dep.c, properties.c, properties.x, properties.h and properties.doc in the suitable places. --- libguile/Makefile.am | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 6e1f6e0fe..3987240f0 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -50,7 +50,8 @@ libguile_la_SOURCES = \ print.c procprop.c procs.c random.c read.c root.c scmsigs.c \ script.c simpos.c smob.c sort.c srcprop.c stackchk.c stacks.c \ stime.c strings.c strop.c strorder.c strports.c struct.c symbols.c \ - tag.c throw.c variable.c vectors.c version.c vports.c weaks.c + tag.c throw.c variable.c vectors.c version.c vports.c weaks.c \ + gc_os_dep.c properties.c DOT_X_FILES = \ alist.x arbiters.x \ @@ -65,7 +66,7 @@ DOT_X_FILES = \ script.x simpos.x smob.x socket.x sort.x srcprop.x stackchk.x \ stacks.x stime.x strings.x strop.x strorder.x strports.x struct.x \ symbols.x tag.x throw.x variable.x vectors.x \ - version.x vports.x weaks.x + version.x vports.x weaks.x properties.x EXTRA_DOT_X_FILES = debug-malloc.x filesys.x net_db.x posix.x ramap.x \ regex-posix.x socket.x threads.x unif.x @@ -83,7 +84,7 @@ DOT_DOC_FILES = \ script.doc simpos.doc smob.doc socket.doc sort.doc srcprop.doc \ stackchk.doc stacks.doc stime.doc strings.doc strop.doc strorder.doc \ strports.doc struct.doc symbols.doc tag.doc throw.doc variable.doc \ - vectors.doc version.doc vports.doc weaks.doc + vectors.doc version.doc vports.doc weaks.doc properties.doc EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@ @@ -130,7 +131,7 @@ modinclude_HEADERS = \ strings.h strop.h strorder.h strports.h struct.h symbols.h tag.h \ tags.h throw.h unif.h variable.h vectors.h version.h vports.h \ weaks.h snarf.h threads.h coop-defs.h fluids.h iselect.h \ - debug-malloc.h + debug-malloc.h properties.h ## This file is generated at configure time. That is why it is DATA ## and not a header -- headers are included in the distribution. @@ -183,10 +184,14 @@ SUFFIXES = .x .doc .c.x: PATH=.:${PATH} ./guile-doc-snarf $< $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \ || { rm $@; false; } -.c.doc: - PATH=.:${PATH} ./guile-doc-snarf $< $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > /dev/null \ +.x.doc: + PATH=.:${PATH} ./guile-doc-snarf $*.c $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $*.c > /dev/null \ || { rm $@; false; } +error.x: cpp_err_symbols.c +posix.x: cpp_sig_symbols.c +load.x: libpath.h + guile-procedures.txt: $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) cat *.doc > $@ From 7ad3a9782ec6d76510d0035e05f0b9f9a5f667c9 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Sep 2000 20:23:55 +0000 Subject: [PATCH 0219/2047] * init.c (scm_init_guile, scm_init_guile_1): New interface for initializing Guile that does return to the caller. (scm_boot_guile_1): Use scm_init_guile_1 to initialize Guile. Do not establish a catch-all, this is no longer needed. --- libguile/init.c | 258 +++++++++++++++++++++++++----------------------- 1 file changed, 134 insertions(+), 124 deletions(-) diff --git a/libguile/init.c b/libguile/init.c index 28b32842c..d288b21bd 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -186,7 +186,7 @@ start_stack (void *base) "continuation")); SCM_SET_CELL_TYPE (scm_rootcont, scm_tc7_contin); SCM_SEQ (scm_rootcont) = 0; - /* The root continuation if further initialized by restart_stack. */ + /* The root continuation is further initialized by restart_stack. */ /* Create the look-aside stack for variables that are shared between * captured continuations. @@ -397,7 +397,9 @@ struct main_func_closure }; -static void scm_boot_guile_1(SCM_STACKITEM *base, struct main_func_closure *closure); +static void scm_init_guile_1 (SCM_STACKITEM *base); +static void scm_boot_guile_1 (SCM_STACKITEM *base, + struct main_func_closure *closure); static SCM invoke_main_func(void *body_data); @@ -446,151 +448,145 @@ scm_boot_guile (int argc, char ** argv, void (*main_func) (), void *closure) scm_boot_guile_1 (&dummy, &c); } +extern void *scm_get_stack_base (); -/* Record here whether SCM_BOOT_GUILE_1 has already been called. This - variable is now here and not inside SCM_BOOT_GUILE_1 so that one - can tweak it. This is necessary for unexec to work. (Hey, "1-live" - is the name of a local radiostation...) */ - -int scm_boot_guile_1_live = 0; +void +scm_init_guile () +{ + scm_init_guile_1 ((SCM_STACKITEM *)scm_get_stack_base ()); +} int scm_initialized_p = 0; static void -scm_boot_guile_1 (SCM_STACKITEM *base, struct main_func_closure *closure) +scm_init_guile_1 (SCM_STACKITEM *base) { - /* static int live = 0; */ - setjmp_type setjmp_val; + if (scm_initialized_p) + return; - /* This function is not re-entrant. */ - if (scm_boot_guile_1_live) - abort (); - - scm_boot_guile_1_live = 1; + if (base == NULL) + { + fprintf (stderr, "cannot determine stack base!\n"); + abort (); + } scm_ints_disabled = 1; scm_block_gc = 1; - if (scm_initialized_p) - { - restart_stack (base); - } - else - { - scm_ports_prehistory (); - scm_smob_prehistory (); - scm_tables_prehistory (); + scm_ports_prehistory (); + scm_smob_prehistory (); + scm_tables_prehistory (); #ifdef GUILE_DEBUG_MALLOC - scm_debug_malloc_prehistory (); + scm_debug_malloc_prehistory (); #endif - scm_init_storage (scm_i_getenv_int ("GUILE_INIT_SEGMENT_SIZE_1", 0), - scm_i_getenv_int ("GUILE_MIN_YIELD_1", 0), - scm_i_getenv_int ("GUILE_INIT_SEGMENT_SIZE_2", 0), - scm_i_getenv_int ("GUILE_MIN_YIELD_2", 0), - scm_i_getenv_int ("GUILE_MAX_SEGMENT_SIZE", 0)); - scm_struct_prehistory (); /* Must come after scm_init_storage */ - scm_weaks_prehistory (); /* Must come after scm_init_storage */ - scm_init_subr_table (); - scm_environments_prehistory (); /* create the root environment */ - scm_init_root (); + scm_init_storage (scm_i_getenv_int ("GUILE_INIT_SEGMENT_SIZE_1", 0), + scm_i_getenv_int ("GUILE_MIN_YIELD_1", 0), + scm_i_getenv_int ("GUILE_INIT_SEGMENT_SIZE_2", 0), + scm_i_getenv_int ("GUILE_MIN_YIELD_2", 0), + scm_i_getenv_int ("GUILE_MAX_SEGMENT_SIZE", 0)); + scm_struct_prehistory (); /* Must come after scm_init_storage */ + scm_weaks_prehistory (); /* Must come after scm_init_storage */ + scm_init_subr_table (); + scm_environments_prehistory (); /* create the root environment */ + scm_init_root (); #ifdef USE_THREADS - scm_init_threads (base); + scm_init_threads (base); #endif - start_stack (base); - scm_init_gsubr (); - scm_init_environments (); - scm_init_feature (); - scm_init_alist (); - scm_init_arbiters (); - scm_init_async (); - scm_init_boolean (); - scm_init_chars (); - scm_init_continuations (); + start_stack (base); + scm_init_gsubr (); + scm_init_environments (); + scm_init_feature (); + scm_init_alist (); + scm_init_arbiters (); + scm_init_async (); + scm_init_boolean (); + scm_init_chars (); + scm_init_continuations (); #ifdef GUILE_DEBUG_MALLOC - scm_init_debug_malloc (); + scm_init_debug_malloc (); #endif - scm_init_dynwind (); - scm_init_eq (); - scm_init_error (); - scm_init_fluids (); - scm_init_backtrace (); /* Requires fluids */ - scm_init_fports (); - scm_init_gdbint (); - scm_init_hash (); - scm_init_hashtab (); - scm_init_objprop (); - scm_init_hooks (); /* Requires objprop until hook names are removed */ - scm_init_gc (); /* Requires hooks, async */ + scm_init_dynwind (); + scm_init_eq (); + scm_init_error (); + scm_init_fluids (); + scm_init_backtrace (); /* Requires fluids */ + scm_init_fports (); + scm_init_gdbint (); + scm_init_hash (); + scm_init_hashtab (); + scm_init_objprop (); + scm_init_properties (); + scm_init_hooks (); /* Requires objprop until hook names are removed */ + scm_init_gc (); /* Requires hooks, async */ #ifdef GUILE_ISELECT - scm_init_iselect (); + scm_init_iselect (); #endif - scm_init_ioext (); - scm_init_keywords (); - scm_init_list (); - scm_init_macros (); - scm_init_mallocs (); - scm_init_modules (); - scm_init_numbers (); - scm_init_options (); - scm_init_pairs (); - scm_init_ports (); + scm_init_ioext (); + scm_init_keywords (); + scm_init_list (); + scm_init_macros (); + scm_init_mallocs (); + scm_init_modules (); + scm_init_numbers (); + scm_init_options (); + scm_init_pairs (); + scm_init_ports (); #ifdef HAVE_POSIX - scm_init_filesys (); - scm_init_posix (); + scm_init_filesys (); + scm_init_posix (); #endif #ifdef HAVE_REGCOMP - scm_init_regex_posix (); + scm_init_regex_posix (); #endif - scm_init_procs (); - scm_init_procprop (); - scm_init_scmsigs (); + scm_init_procs (); + scm_init_procprop (); + scm_init_scmsigs (); #ifdef HAVE_NETWORKING - scm_init_net_db (); - scm_init_socket (); + scm_init_net_db (); + scm_init_socket (); #endif - scm_init_sort (); + scm_init_sort (); #ifdef DEBUG_EXTENSIONS - scm_init_srcprop (); + scm_init_srcprop (); #endif - scm_init_stackchk (); - scm_init_struct (); /* Requires struct */ - scm_init_stacks (); - scm_init_strports (); - scm_init_symbols (); - scm_init_tag (); - scm_init_load (); - scm_init_objects (); /* Requires struct */ - scm_init_print (); /* Requires struct */ - scm_init_read (); - scm_init_stime (); - scm_init_strings (); - scm_init_strorder (); - scm_init_strop (); - scm_init_throw (); - scm_init_variable (); - scm_init_vectors (); - scm_init_version (); - scm_init_weaks (); - scm_init_guardian (); - scm_init_vports (); - scm_init_eval (); - scm_init_evalext (); + scm_init_stackchk (); + scm_init_struct (); /* Requires struct */ + scm_init_stacks (); + scm_init_strports (); + scm_init_symbols (); + scm_init_tag (); + scm_init_load (); + scm_init_objects (); /* Requires struct */ + scm_init_print (); /* Requires struct */ + scm_init_read (); + scm_init_stime (); + scm_init_strings (); + scm_init_strorder (); + scm_init_strop (); + scm_init_throw (); + scm_init_variable (); + scm_init_vectors (); + scm_init_version (); + scm_init_weaks (); + scm_init_guardian (); + scm_init_vports (); + scm_init_eval (); + scm_init_evalext (); #ifdef DEBUG_EXTENSIONS - scm_init_debug (); /* Requires macro smobs */ + scm_init_debug (); /* Requires macro smobs */ #endif - scm_init_random (); + scm_init_random (); #ifdef HAVE_ARRAYS - scm_init_ramap (); - scm_init_unif (); + scm_init_ramap (); + scm_init_unif (); #endif - scm_init_simpos (); - scm_init_load_path (); - scm_init_standard_ports (); - scm_init_dynamic_linking (); - scm_init_lang (); - scm_init_script (); - scm_initialized_p = 1; - } + scm_init_simpos (); + scm_init_load_path (); + scm_init_standard_ports (); + scm_init_dynamic_linking (); + scm_init_lang (); + scm_init_script (); + scm_initialized_p = 1; scm_block_gc = 0; /* permit the gc to run */ /* ints still disabled */ @@ -599,13 +595,28 @@ scm_boot_guile_1 (SCM_STACKITEM *base, struct main_func_closure *closure) scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; #endif - setjmp_val = setjmp (SCM_JMPBUF (scm_rootcont)); - if (!setjmp_val) - { - scm_set_program_arguments (closure->argc, closure->argv, 0); - scm_internal_lazy_catch (SCM_BOOL_T, invoke_main_func, closure, - scm_handle_by_message, 0); - } +} + +/* Record here whether SCM_BOOT_GUILE_1 has already been called. This + variable is now here and not inside SCM_BOOT_GUILE_1 so that one + can tweak it. This is necessary for unexec to work. (Hey, "1-live" + is the name of a local radiostation...) */ + +int scm_boot_guile_1_live = 0; + +static void +scm_boot_guile_1 (SCM_STACKITEM *base, struct main_func_closure *closure) +{ + scm_init_guile_1 (base); + + /* This function is not re-entrant. */ + if (scm_boot_guile_1_live) + abort (); + + scm_boot_guile_1_live = 1; + + scm_set_program_arguments (closure->argc, closure->argv, 0); + invoke_main_func (closure); scm_restore_signals (); @@ -620,7 +631,6 @@ scm_boot_guile_1 (SCM_STACKITEM *base, struct main_func_closure *closure) exit (0); } - static SCM invoke_main_func (void *body_data) { From 8a443f663acbb05d02d1cf9b3504d81b07e6a738 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Sep 2000 20:24:18 +0000 Subject: [PATCH 0220/2047] * init.h (scm_init_guile): New prototype. --- libguile/init.h | 2 ++ 1 file changed, 2 insertions(+) diff --git a/libguile/init.h b/libguile/init.h index 1864aab2d..4367e1a1c 100644 --- a/libguile/init.h +++ b/libguile/init.h @@ -49,6 +49,8 @@ extern int scm_initialized_p; +extern void scm_init_guile (void); + extern void scm_boot_guile (int argc, char **argv, void (*main_func) (void *closure, int argc, From 718eb1762b33a428b97e1f1c472c50270aa512e8 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Sep 2000 20:25:19 +0000 Subject: [PATCH 0221/2047] New files. --- libguile/properties.c | 156 ++++++++++++++++++++++++++++++++++++++++++ libguile/properties.h | 62 +++++++++++++++++ 2 files changed, 218 insertions(+) create mode 100644 libguile/properties.c create mode 100644 libguile/properties.h diff --git a/libguile/properties.c b/libguile/properties.c new file mode 100644 index 000000000..cc5941d9f --- /dev/null +++ b/libguile/properties.c @@ -0,0 +1,156 @@ +/* Copyright (C) 1995,1996, 2000 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 + * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + + + +#include +#include "libguile/_scm.h" +#include "libguile/hashtab.h" +#include "libguile/alist.h" +#include "libguile/root.h" +#include "libguile/weaks.h" +#include "libguile/validate.h" +#include "libguile/eval.h" + +#include "libguile/properties.h" + + +/* {Properties} + */ + +SCM_DEFINE (scm_primitive_make_property, "primitive-make-property", 1, 0, 0, + (SCM not_found_proc), + "Create a @dfn{property token} that can be used with\n" + "@code{primitive-property-ref} and @code{primitive-property-set!}.\n" + "See @code{primitive-property-ref} for the significance of\n" + "@var{not_found_proc}.") +#define FUNC_NAME s_scm_primitive_make_property +{ + if (not_found_proc != SCM_BOOL_F) + SCM_VALIDATE_PROC (SCM_ARG1, not_found_proc); + return scm_cons (not_found_proc, SCM_EOL); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_primitive_property_ref, "primitive-property-ref", 2, 0, 0, + (SCM prop, SCM obj), + "Return the property @var{prop} of @var{obj}. When no value\n" + "has yet been associated with @var{prop} and @var{obj}, call\n" + "@var{not-found-proc} instead (see @code{primitive-make-property})\n" + "and use its return value. That value is also associated with\n" + "@var{obj} via @code{primitive-property-set!}. When\n" + "@var{not-found-proc} is @code{#f}, use @code{#f} as the\n" + "default value of @var{prop}.") +#define FUNC_NAME s_scm_primitive_property_ref +{ + SCM h, assoc; + + SCM_VALIDATE_CONS (SCM_ARG1, prop); + + h = scm_hashq_get_handle (scm_properties_whash, obj); + assoc = (SCM_NIMP (h) ? scm_assq (prop, SCM_CDR (h)) : SCM_BOOL_F); + if (SCM_NIMP (assoc)) + return SCM_CDR (assoc); + + if (SCM_FALSEP (SCM_CAR (prop))) + return SCM_BOOL_F; + else + { + SCM val = scm_apply (SCM_CAR (prop), + SCM_LIST2 (prop, obj), SCM_EOL); + if (SCM_IMP (h)) + h = scm_hashq_create_handle_x (scm_properties_whash, obj, SCM_EOL); + SCM_SETCDR (h, scm_acons (prop, val, SCM_CDR (h))); + return val; + } +} +#undef FUNC_NAME + +SCM_DEFINE (scm_primitive_property_set_x, "primitive-property-set!", 3, 0, 0, + (SCM prop, SCM obj, SCM val), + "Associate @var{code} with @var{prop} and @var{obj}.") +#define FUNC_NAME s_scm_primitive_property_set_x +{ + SCM h, assoc; + SCM_VALIDATE_CONS (SCM_ARG1, prop); + h = scm_hashq_create_handle_x (scm_properties_whash, obj, SCM_EOL); + assoc = scm_assq (prop, SCM_CDR (h)); + if (SCM_NIMP (assoc)) + SCM_SETCDR (assoc, val); + else + { + assoc = scm_acons (prop, val, SCM_CDR (h)); + SCM_SETCDR (h, assoc); + } + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_primitive_property_del_x, "primitive-property-del!", 2, 0, 0, + (SCM prop, SCM obj), + "Remove any value associated with @var{prop} and @var{obj}.") +#define FUNC_NAME s_scm_primitive_property_del_x +{ + SCM h; + SCM_VALIDATE_CONS (SCM_ARG1, prop); + h = scm_hashq_get_handle (scm_properties_whash, obj); + if (SCM_NIMP (h)) + SCM_SETCDR (h, scm_assq_remove_x (SCM_CDR (h), prop)); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +void +scm_init_properties () +{ + scm_properties_whash = scm_make_weak_key_hash_table (SCM_MAKINUM (511)); +#include "libguile/properties.x" +} + + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/properties.h b/libguile/properties.h new file mode 100644 index 000000000..e256046a7 --- /dev/null +++ b/libguile/properties.h @@ -0,0 +1,62 @@ +/* classes: h_files */ + +#ifndef PROPERTIES_H +#define PROPERTIES_H +/* Copyright (C) 1995,1996,1998, 2000 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 + * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + + +#include "libguile/__scm.h" + +SCM scm_primitive_make_property (SCM not_found_proc); +SCM scm_primitive_property_ref (SCM prop, SCM obj); +SCM scm_primitive_property_set_x (SCM prop, SCM obj, SCM val); +SCM scm_primitive_property_del_x (SCM prop, SCM obj); + +void scm_init_properties (void); + +#endif /* PROPEERTIES_H */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ From cadee6cf342ae76106dc37745459feaf38f52bd6 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Sep 2000 20:26:11 +0000 Subject: [PATCH 0222/2047] * root.h (scm_properties_whash): New `sys_protect', used in properties.c. --- libguile/root.h | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/libguile/root.h b/libguile/root.h index 2c6bdc255..ef870854f 100644 --- a/libguile/root.h +++ b/libguile/root.h @@ -70,11 +70,12 @@ #define scm_permobjs scm_sys_protects[11] #define scm_asyncs scm_sys_protects[12] #define scm_protects scm_sys_protects[13] +#define scm_properties_whash scm_sys_protects[14] #ifdef DEBUG_EXTENSIONS -#define scm_source_whash scm_sys_protects[14] -#define SCM_NUM_PROTECTS 15 +#define scm_source_whash scm_sys_protects[15] +#define SCM_NUM_PROTECTS 16 #else -#define SCM_NUM_PROTECTS 14 +#define SCM_NUM_PROTECTS 15 #endif extern SCM scm_sys_protects[]; From 9500b5b95085cb7813c24e8bd5339edcb449b778 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Sep 2000 20:27:17 +0000 Subject: [PATCH 0223/2047] New file. --- libguile/gc_os_dep.c | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 libguile/gc_os_dep.c diff --git a/libguile/gc_os_dep.c b/libguile/gc_os_dep.c new file mode 100644 index 000000000..df0ce6d63 --- /dev/null +++ b/libguile/gc_os_dep.c @@ -0,0 +1,10 @@ +/* This is a dummy file. It will be replaced with the real thing when + all copyright issues have been settled. */ + +#include + +void * +scm_get_stack_base () +{ + return NULL; +} From d6580119f859d6134dea4b1c9d7a11666ab3492b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Sep 2000 20:31:10 +0000 Subject: [PATCH 0224/2047] * throw.c (scm_ithrow): Perform catch-all handling here when no suitable handler has been found. That way, we don't have to rely on the user establishing a catch-all, which might be difficult for him if he is using scm_init_guile instead of scm_boot_guile. --- libguile/throw.c | 45 ++++++++++++++++++++++----------------------- 1 file changed, 22 insertions(+), 23 deletions(-) diff --git a/libguile/throw.c b/libguile/throw.c index 17e046c57..421d3dd73 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -620,33 +620,32 @@ scm_ithrow (SCM key, SCM args, int noreturn) } } - /* If we didn't find anything, abort. scm_boot_guile should - have established a catch-all, but obviously things are - thoroughly screwed up. */ - if (SCM_NULLP (winds)) - abort (); +#ifdef BROKEN_GCSE +#ifdef __GNUC__ + /* GCC 2.95.2 has a bug in its optimizer that makes it generate + incorrect code sometimes. This barrier stops it from being too + clever. */ + asm volatile ("" : "=g" (winds)); +#else +#error "GCSE bug found: reconfigure without optimization?" +#endif +#endif - /* If the wind list is malformed, bail. */ + /* If we didn't find anything, print a message and abort the process + right here. If you don't want this, establish a catch-all around + any code that might throw up. */ + if (SCM_NULLP (winds) || SCM_FALSEP (dynpair)) + { + scm_handle_by_message (NULL, key, args); + abort (); + } + + /* If the wind list is malformed, bail. */ if (SCM_IMP (winds) || SCM_NCONSP (winds)) abort (); - if (!SCM_FALSEP (dynpair)) - jmpbuf = SCM_CDR (dynpair); - else - { - if (!noreturn) - return SCM_UNSPECIFIED; - else - { - scm_exitval = scm_cons (key, args); - scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds)); -#ifdef DEBUG_EXTENSIONS - scm_last_debug_frame = SCM_DFRAME (scm_rootcont); -#endif - longjmp (SCM_JMPBUF (scm_rootcont), 1); - } - } - + jmpbuf = SCM_CDR (dynpair); + for (wind_goal = scm_dynwinds; !SCM_EQ_P (SCM_CDAR (wind_goal), jmpbuf); wind_goal = SCM_CDR (wind_goal)) From 468fbf58ab400a32d3c6decc28c92ca0f9ee3449 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Sep 2000 20:31:35 +0000 Subject: [PATCH 0225/2047] *** empty log message *** --- libguile/ChangeLog | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 1ff3b9e9d..b18efca23 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,30 @@ +2000-09-03 Marius Vollmer + + * Makefile.am (.x.doc): Pretend to create .doc files from .x files + and give explicit dependencies for .x files that depend on + generated files. This allows parallel builds. Thanks to Matthias + Koeppe! + +2000-08-27 Marius Vollmer + + * Makefile.am: Added gc_os_dep.c, properties.c, properties.x, + properties.h and properties.doc in the suitable places. + + * init.h (scm_init_guile): New prototype. + + * init.c (scm_init_guile, scm_init_guile_1): New interface for + initializing Guile that does return to the caller. + (scm_boot_guile_1): Use scm_init_guile_1 to initialize Guile. + Do not establish a catch-all, this is no longer needed. + + * root.h (scm_properties_whash): New `sys_protect', used in + properties.c. + + * throw.c (scm_ithrow): Perform catch-all handling here when no + suitable handler has been found. That way, we don't have to rely + on the user establishing a catch-all, which might be difficult for + him if he is using scm_init_guile instead of scm_boot_guile. + 2000-09-03 Neil Jerram * vectors.c (scm_vector): Docstring: add @deffnx line for From 17f367e095148b4731b097543d34dc9564415b52 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Sep 2000 20:47:21 +0000 Subject: [PATCH 0226/2047] *** empty log message *** --- NEWS | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/NEWS b/NEWS index 459340791..bb62b0d7d 100644 --- a/NEWS +++ b/NEWS @@ -22,6 +22,21 @@ Example: * Changes to Scheme functions and syntax +** New function `make-object-property' + +This function returns a new `procedure with setter' P that can be used +to attach a property to objects. When calling P as + + (set! (P obj) val) + +where `obj' is any kind of object, it attaches `val' to `obj' in such +a way that it can be retrieved by calling P as + + (P obj) + +This function will replace procedure properties, symbol properties and +source properties eventually. + ** Module (ice-9 optargs) now uses keywords instead of `#&'. Instead of #&optional, #&key, etc you should now use #:optional, @@ -89,6 +104,19 @@ Guile. * Changes to the scm_ interface +** New function: scm_init_guile () + +In contrast to scm_boot_guile, scm_init_guile will return normally +after initializing Guile. It is not available on all systems, tho. + +** New functions: scm_primitive_make_property + scm_primitive_property_ref + scm_primitive_property_set_x + scm_primitive_property_del_x + +These functions implement a new way to deal with object properties. +See libguile/properties.c for their documentation. + ** New function: scm_done_free (long size) This function is the inverse of scm_done_malloc. Use it to report the From ee1a1c206640248a0ee93f6c373871db6fb14b5b Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 3 Sep 2000 21:56:03 +0000 Subject: [PATCH 0227/2047] * validate.h (SCM_VALIDATE_NUMBER_DEF_COPY): New macro. --- libguile/validate.h | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/libguile/validate.h b/libguile/validate.h index 9889757d8..3ddcebe25 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -1,4 +1,4 @@ -/* $Id: validate.h,v 1.13 2000-06-30 09:48:25 dirk Exp $ */ +/* $Id: validate.h,v 1.14 2000-09-03 21:56:03 mdj Exp $ */ /* Copyright (C) 1999, 2000 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify @@ -183,6 +183,14 @@ } \ } while (0) +#define SCM_VALIDATE_NUMBER_DEF_COPY(pos, number, def, cvar) \ + do { \ + if (SCM_UNBNDP (number)) \ + cvar = def; \ + else \ + SCM_VALIDATE_NUMBER_COPY(pos, number, cvar); \ + } while (0) + #define SCM_VALIDATE_INUM(pos, k) SCM_MAKE_VALIDATE (pos, k, INUMP) #define SCM_VALIDATE_INUM_COPY(pos, k, cvar) \ From 9e9e264f9a53d6344cd64b02ce118ddaac626ca2 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 3 Sep 2000 22:01:44 +0000 Subject: [PATCH 0228/2047] *** empty log message *** --- libguile/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b18efca23..7741b7668 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2000-09-03 Mikael Djurfeldt + + * validate.h (SCM_VALIDATE_NUMBER_DEF_COPY): New macro. + 2000-09-03 Marius Vollmer * Makefile.am (.x.doc): Pretend to create .doc files from .x files From 4c199a262b328b26117762413c04f9df3934c412 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 5 Sep 2000 10:43:53 +0000 Subject: [PATCH 0229/2047] * Fixed two bugs with environment type predicates. --- THANKS | 1 + libguile/ChangeLog | 6 ++++++ libguile/environments.h | 6 ++++-- 3 files changed, 11 insertions(+), 2 deletions(-) diff --git a/THANKS b/THANKS index 0ae063d38..72ae423a5 100644 --- a/THANKS +++ b/THANKS @@ -8,6 +8,7 @@ The Guile maintainer committee consists of Contributors since the last release: Greg Harvey + Jost Boekemeier For fixes or providing information which led to a fix: diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 7741b7668..acf2bc4cf 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2000-08-25 Dirk Herrmann + + * environments.h (SCM_IMPORT_ENVIRONMENT_P, + SCM_EXPORT_ENVIRONMENT_P): Before fetching the environment + functions, make sure that we really got an environment. + 2000-09-03 Mikael Djurfeldt * validate.h (SCM_VALIDATE_NUMBER_DEF_COPY): New macro. diff --git a/libguile/environments.h b/libguile/environments.h index 1c7683b27..9ed5cabc0 100644 --- a/libguile/environments.h +++ b/libguile/environments.h @@ -176,7 +176,8 @@ extern SCM scm_eval_environment_set_imported_x (SCM env, SCM imported); extern void *scm_type_import_environment; #define SCM_IMPORT_ENVIRONMENT_P(env) \ - (SCM_ENVIRONMENT_FUNCS (env) == scm_type_import_environment) + (SCM_ENVIRONMENT_P (env) \ + && SCM_ENVIRONMENT_FUNCS (env) == scm_type_import_environment) extern SCM scm_make_import_environment (SCM imports, SCM conflict_proc); extern SCM scm_import_environment_p (SCM env); @@ -188,7 +189,8 @@ extern SCM scm_import_environment_set_imports_x (SCM env, SCM imports); extern void *scm_type_export_environment; #define SCM_EXPORT_ENVIRONMENT_P(env) \ - (SCM_ENVIRONMENT_FUNCS (env) == scm_type_export_environment) + (SCM_ENVIRONMENT_P (env) \ + && SCM_ENVIRONMENT_FUNCS (env) == scm_type_export_environment) extern SCM scm_make_export_environment (SCM private, SCM signature); extern SCM scm_export_environment_p (SCM env); From 034b924f39a2f6df016f29d5912b8c6014faffd0 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 5 Sep 2000 10:49:10 +0000 Subject: [PATCH 0230/2047] * Improved and enhanced the environment test suite. --- test-suite/ChangeLog | 7 + test-suite/tests/environments.test | 1142 +++++++++++++++++++++++----- 2 files changed, 944 insertions(+), 205 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 2bac129a0..665e1fde2 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,10 @@ +2000-09-05 Dirk Herrmann + + * tests/environments.test: Finished and cleaned up the tests for + the leaf environments. Added a complete set of testcases for the + leaf environment based eval environments. Started with the tests + for the import environments. + 2000-08-25 Dirk Herrmann * tests/environments.test: Added. diff --git a/test-suite/tests/environments.test b/test-suite/tests/environments.test index 42e72e218..8f1f56b42 100644 --- a/test-suite/tests/environments.test +++ b/test-suite/tests/environments.test @@ -51,16 +51,24 @@ (define (documented? object) (object-documentation object)) -(define (make-adder) - (let* ((counter 0)) - (lambda increment - (if (not (null? increment)) - (set! counter (+ counter (car increment)))) - counter))) - (define (folder sym val res) (cons (cons sym val) res)) +(define (make-observer-func) + (let* ((counter 0)) + (lambda args + (if (null? args) + counter + (set! counter (+ counter 1)))))) + +(define (make-erroneous-observer-func) + (let* ((func (make-observer-func))) + (lambda args + (if (null? args) + (func) + (begin + (func args) + (error)))))) ;;; ;;; leaf-environments @@ -94,266 +102,295 @@ (with-test-prefix "bound, define, ref, set!, cell" - (let* ((env (make-leaf-environment)) - (ctr (make-adder))) - - (pass-if "unbound by default" + (pass-if "symbols are unbound by default" + (let* ((env (make-leaf-environment))) (and (not (environment-bound? env 'a)) (not (environment-bound? env 'b)) - (not (environment-bound? env 'c)))) + (not (environment-bound? env 'c))))) - (pass-if "bound after define" - (environment-define env 'a (ctr 1)) - (environment-bound? env 'a)) + (pass-if "symbol is bound after define" + (let* ((env (make-leaf-environment))) + (environment-bound? env 'a) + (environment-define env 'a #t) + (environment-bound? env 'a))) - (pass-if "ref defined" - (and (begin - (environment-define env 'a (ctr 1)) - (eq? (environment-ref env 'a) (ctr))) - (begin - (environment-define env 'a (ctr 1)) - (eq? (environment-ref env 'a) (ctr))))) + (pass-if "ref a defined symbol" + (let* ((env (make-leaf-environment))) + (environment-bound? env 'a) + (environment-bound? env 'b) + (environment-define env 'a #t) + (environment-define env 'b #f) + (and (environment-ref env 'a) + (not (environment-ref env 'b))))) - (pass-if "set! defined" - (and (begin - (environment-set! env 'a (ctr 1)) - (eq? (environment-ref env 'a) (ctr))) - (begin - (environment-set! env 'a (ctr 1)) - (eq? (environment-ref env 'a) (ctr))))) + (pass-if "set! a defined symbol" + (let* ((env (make-leaf-environment))) + (environment-define env 'a #t) + (environment-define env 'b #f) + (environment-ref env 'a) + (environment-ref env 'b) + (environment-set! env 'a #f) + (environment-set! env 'b #t) + (and (not (environment-ref env 'a)) + (environment-ref env 'b)))) - (pass-if "read-only cell" + (pass-if "get a read-only cell" + (let* ((env (make-leaf-environment))) + (environment-define env 'a #t) (let* ((cell (environment-cell env 'a #f))) - (and (begin - (environment-set! env 'a (ctr 1)) - (eq? (cdr cell) (ctr)))))) + (and (cdr cell) + (begin + (environment-set! env 'a #f) + (not (cdr cell))))))) - (pass-if "read-only cell rebound after define" + (pass-if "a read-only cell gets rebound after define" + (let* ((env (make-leaf-environment))) + (environment-define env 'a #t) (let* ((cell (environment-cell env 'a #f))) - (environment-define env 'a (ctr 1)) - (not (eq? (environment-cell env 'a #f) cell)))) + (environment-define env 'a #f) + (not (eq? (environment-cell env 'a #f) cell))))) - (pass-if "writable cell" + (pass-if "get a writable cell" + (let* ((env (make-leaf-environment))) + (environment-define env 'a #t) (let* ((readable (environment-cell env 'a #f)) (writable (environment-cell env 'a #t))) (and (eq? readable writable) (begin - (environment-set! env 'a (ctr 1)) - (eq? (cdr writable) (ctr))) + (environment-set! env 'a #f) + (not (cdr writable))) (begin - (set-cdr! writable (ctr 1)) - (eq? (environment-ref env 'a) (ctr))) + (set-cdr! writable #t) + (environment-ref env 'a)) (begin - (set-cdr! (environment-cell env 'a #t) (ctr 1)) - (eq? (cdr writable) (ctr)))))) + (set-cdr! (environment-cell env 'a #t) #f) + (not (cdr writable))))))) - (pass-if "writable cell rebound after define" + (pass-if "a writable cell gets rebound after define" + (let* ((env (make-leaf-environment))) + (environment-define env 'a #t) (let* ((cell (environment-cell env 'a #t))) - (environment-define env 'a (ctr 1)) - (not (eq? (environment-cell env 'a #t) cell)))) + (environment-define env 'a #f) + (not (eq? (environment-cell env 'a #t) cell))))) - (pass-if "referencing undefined" - (catch #t - (lambda () - (environment-ref env 'b) - #f) - (lambda args - #t))) + (pass-if "reference an undefined symbol" + (catch #t + (lambda () + (environment-ref (make-leaf-environment) 'a) + #f) + (lambda args + #t))) - (pass-if "set!ing undefined" - (catch #t - (lambda () - (environment-set! env 'b) - #f) - (lambda args - #t))) + (pass-if "set! an undefined symbol" + (catch #t + (lambda () + (environment-set! (make-leaf-environment) 'a) + #f) + (lambda args + #t))) - (pass-if "readable cell from undefined" - (catch #t - (lambda () - (environment-cell env 'b #f) - #f) - (lambda args - #t))) + (pass-if "get a readable cell for an undefined symbol" + (catch #t + (lambda () + (environment-cell (make-leaf-environment) 'a #f) + #f) + (lambda args + #t))) - (pass-if "writable cell from undefined" - (catch #t - (lambda () - (environment-cell env 'b #t) - #f) - (lambda args - #t))))) + (pass-if "get a writable cell for an undefined symbol" + (catch #t + (lambda () + (environment-cell (make-leaf-environment) 'a #t) + #f) + (lambda args + #t)))) (with-test-prefix "undefine" - (let* ((env (make-leaf-environment))) - - (pass-if "undefine defined" + (pass-if "undefine a defined symbol" + (let* ((env (make-leaf-environment))) (environment-define env 'a 1) - (and (environment-bound? env 'a) - (begin - (environment-undefine env 'a) - (not (environment-bound? env 'a))))) + (environment-ref env 'a) + (environment-undefine env 'a) + (not (environment-bound? env 'a)))) - (pass-if "undefine undefined" - (and (not (environment-bound? env 'a)) - (begin - (environment-undefine env 'a) - (not (environment-bound? env 'a))))))) + (pass-if "undefine an already undefined symbol" + (environment-undefine (make-leaf-environment) 'a) + #t)) (with-test-prefix "fold" - (let* ((env (make-leaf-environment)) - (ctr (make-adder))) + (pass-if "empty environment" + (let* ((env (make-leaf-environment))) + (eq? 'success (environment-fold env folder 'success)))) - (pass-if "fold empty" - (eq? 'success (environment-fold env folder 'success))) + (pass-if "one symbol" + (let* ((env (make-leaf-environment))) + (environment-define env 'a #t) + (equal? '((a . #t)) (environment-fold env folder '())))) - (pass-if "after define" - (environment-define env 'a (ctr 1)) - (equal? `((a . ,(ctr))) (environment-fold env folder '()))) - - (pass-if "after undefine" - (environment-undefine env 'a) - (eq? 'success (environment-fold env folder 'success))) - - (pass-if "after two defines" - (let* ((i (ctr 1)) - (j (+ i 1))) - (environment-define env 'a i) - (environment-define env 'b j) - (let ((folded (environment-fold env folder '()))) - (or (equal? folded `((a . ,i) (b . ,j))) - (equal? folded `((b . ,j) (a . ,i))))))) - - (pass-if "after set!" - (let* ((i (environment-ref env 'a))) - (environment-set! env 'b i) - (let ((folded (environment-fold env folder '()))) - (or (equal? folded `((a . ,i) (b . ,i))) - (equal? folded `((b . ,i) (a . ,i))))))))) + (pass-if "two symbols" + (let* ((env (make-leaf-environment))) + (environment-define env 'a #t) + (environment-define env 'b #f) + (let ((folded (environment-fold env folder '()))) + (or (equal? folded '((a . #t) (b . #f))) + (equal? folded '((b . #f) (a . #t)))))))) (with-test-prefix "observe" - (let* ((env (make-leaf-environment)) - (tag #f) - (func (lambda (env) (set! tag (not tag)))) - (observer #f)) + (pass-if "observe an environment" + (let* ((env (make-leaf-environment))) + (environment-observe env (make-observer-func)) + #t)) - (pass-if "observe unobserved" - (set! observer (environment-observe env func)) - #t) + (pass-if "observe an environment twice" + (let* ((env (make-leaf-environment)) + (observer-1 (environment-observe env (make-observer-func))) + (observer-2 (environment-observe env (make-observer-func)))) + (not (eq? observer-1 observer-2)))) - (pass-if "define undefined" - (set! tag #f) + (pass-if "definition of an undefined symbol" + (let* ((env (make-leaf-environment)) + (func (make-observer-func))) + (environment-observe env func) (environment-define env 'a 1) - tag) + (eqv? (func) 1))) - (pass-if "define defined" - (set! tag #f) + (pass-if "definition of an already defined symbol" + (let* ((env (make-leaf-environment))) (environment-define env 'a 1) - tag) + (let* ((func (make-observer-func))) + (environment-observe env func) + (environment-define env 'a 1) + (eqv? (func) 1)))) - (pass-if "set! defined" - (set! tag #t) - (environment-set! env 'a 1) - tag) + (pass-if "set!ing of a defined symbol" + (let* ((env (make-leaf-environment))) + (environment-define env 'a 1) + (let* ((func (make-observer-func))) + (environment-observe env func) + (environment-set! env 'a 1) + (eqv? (func) 0)))) - (pass-if "undefine defined" - (set! tag #f) + (pass-if "undefining a defined symbol" + (let* ((env (make-leaf-environment))) + (environment-define env 'a 1) + (let* ((func (make-observer-func))) + (environment-observe env func) + (environment-undefine env 'a) + (eqv? (func) 1)))) + + (pass-if "undefining an already undefined symbol" + (let* ((env (make-leaf-environment)) + (func (make-observer-func))) + (environment-observe env func) (environment-undefine env 'a) - tag) + (eqv? (func) 0))) - (pass-if "undefine undefined" - (set! tag #t) - (environment-undefine env 'a) - tag) - - (pass-if "unobserve observed" - (set! tag #t) + (pass-if "unobserve an active observer" + (let* ((env (make-leaf-environment)) + (func (make-observer-func)) + (observer (environment-observe env func))) (environment-unobserve observer) (environment-define env 'a 1) - tag) + (eqv? (func) 0))) - (pass-if "unobserve unobserved" + (pass-if "unobserve an inactive observer" + (let* ((env (make-leaf-environment)) + (func (make-observer-func)) + (observer (environment-observe env func))) + (environment-unobserve observer) (environment-unobserve observer) #t))) (with-test-prefix "observe-weak" - (let* ((env (make-leaf-environment)) - (tag #f) - (func (lambda (env) (set! tag (not tag)))) - (observer #f)) + (pass-if "observe an environment" + (let* ((env (make-leaf-environment))) + (environment-observe-weak env (make-observer-func)) + #t)) - (pass-if "weak-observe unobserved" - (set! observer (environment-observe-weak env func)) - #t) + (pass-if "observe an environment twice" + (let* ((env (make-leaf-environment)) + (observer-1 (environment-observe-weak env (make-observer-func))) + (observer-2 (environment-observe-weak env (make-observer-func)))) + (not (eq? observer-1 observer-2)))) - (pass-if "define undefined" - (set! tag #f) - (environment-define env 'a 1) - tag) - - (pass-if "define defined" - (set! tag #f) - (environment-define env 'a 1) - tag) - - (pass-if "set! defined" - (set! tag #t) - (environment-set! env 'a 1) - tag) - - (pass-if "undefine defined" - (set! tag #f) - (environment-undefine env 'a) - tag) - - (pass-if "undefine undefined" - (set! tag #t) - (environment-undefine env 'a) - tag) - - (pass-if "unobserve observed" - (set! tag #t) - (environment-unobserve observer) - (environment-define env 'a 1) - tag) - - (pass-if "unobserve unobserved" - (environment-unobserve observer) - #t) - - (pass-if "weak observer gets collected" - (gc) + (pass-if "definition of an undefined symbol" + (let* ((env (make-leaf-environment)) + (func (make-observer-func))) (environment-observe-weak env func) - (set! tag #f) (environment-define env 'a 1) - (and tag - (begin - (gc) - (environment-define env 'a 1) - tag))))) + (eqv? (func) 1))) + + (pass-if "definition of an already defined symbol" + (let* ((env (make-leaf-environment))) + (environment-define env 'a 1) + (let* ((func (make-observer-func))) + (environment-observe-weak env func) + (environment-define env 'a 1) + (eqv? (func) 1)))) + + (pass-if "set!ing of a defined symbol" + (let* ((env (make-leaf-environment))) + (environment-define env 'a 1) + (let* ((func (make-observer-func))) + (environment-observe-weak env func) + (environment-set! env 'a 1) + (eqv? (func) 0)))) + + (pass-if "undefining a defined symbol" + (let* ((env (make-leaf-environment))) + (environment-define env 'a 1) + (let* ((func (make-observer-func))) + (environment-observe-weak env func) + (environment-undefine env 'a) + (eqv? (func) 1)))) + + (pass-if "undefining an already undefined symbol" + (let* ((env (make-leaf-environment)) + (func (make-observer-func))) + (environment-observe-weak env func) + (environment-undefine env 'a) + (eqv? (func) 0))) + + (pass-if "unobserve an active observer" + (let* ((env (make-leaf-environment)) + (func (make-observer-func)) + (observer (environment-observe-weak env func))) + (environment-unobserve observer) + (environment-define env 'a 1) + (eqv? (func) 0))) + + (pass-if "unobserve an inactive observer" + (let* ((env (make-leaf-environment)) + (func (make-observer-func)) + (observer (environment-observe-weak env func))) + (environment-unobserve observer) + (environment-unobserve observer) + #t)) + + (pass-if "weak observer gets collected" + (gc) + (let* ((env (make-leaf-environment)) + (func (make-observer-func))) + (environment-observe-weak env func) + (gc) + (environment-define env 'a 1) + (eqv? (func) 0)))) - (with-test-prefix "observer-errors" + (with-test-prefix "erroneous observers" - (let* ((env (make-leaf-environment)) - (tag-1 #f) - (tag-2 #f) - (func-1 (lambda (env) - (set! tag-1 (not tag-1)) - (error))) - (func-2 (lambda (env) - (set! tag-2 (not tag-2)) - (error)))) - - (pass-if "update continues after error" + (pass-if "update continues after error" + (let* ((env (make-leaf-environment)) + (func-1 (make-erroneous-observer-func)) + (func-2 (make-erroneous-observer-func))) (environment-observe env func-1) (environment-observe env func-2) (catch #t @@ -361,4 +398,699 @@ (environment-define env 'a 1) #f) (lambda args - (and tag-1 tag-2))))))) \ No newline at end of file + (and (eq? (func-1) 1) + (eq? (func-2) 1)))))))) + + +;;; +;;; leaf-environment based eval-environments +;;; + +(with-test-prefix "leaf-environment based eval-environments" + + (with-test-prefix "eval-environment?" + + (pass-if "documented?" + (documented? eval-environment?)) + + (pass-if "non-environment-object" + (not (eval-environment? #f))) + + (pass-if "leaf-environment-object" + (not (eval-environment? (make-leaf-environment))))) + + + (with-test-prefix "make-eval-environment" + + (pass-if "documented?" + (documented? make-eval-environment)) + + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment))) + + (pass-if "produces an environment" + (environment? (make-eval-environment local imported))) + + (pass-if "produces an eval-environment" + (eval-environment? (make-eval-environment local imported))) + + (pass-if "produces always a new environment" + (not (eq? (make-eval-environment local imported) + (make-eval-environment local imported)))))) + + + (with-test-prefix "eval-environment-local" + + (pass-if "documented?" + (documented? eval-environment-local)) + + (pass-if "returns local" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (eq? (eval-environment-local env) local)))) + + + (with-test-prefix "eval-environment-imported" + + (pass-if "documented?" + (documented? eval-environment-imported)) + + (pass-if "returns imported" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (eq? (eval-environment-imported env) imported)))) + + + (with-test-prefix "bound, define, ref, set!, cell" + + (pass-if "symbols are unbound by default" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (and (not (environment-bound? env 'a)) + (not (environment-bound? env 'b)) + (not (environment-bound? env 'c))))) + + (with-test-prefix "symbols bound in imported" + + (pass-if "binding is visible" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-bound? env 'a) + (environment-define imported 'a #t) + (environment-bound? env 'a))) + + (pass-if "ref works" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-bound? env 'a) + (environment-define imported 'a #t) + (environment-ref env 'a))) + + (pass-if "set! works" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-define imported 'a #f) + (environment-set! env 'a #t) + (environment-ref imported 'a))) + + (pass-if "cells are passed through" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-define imported 'a #t) + (let* ((imported-cell (environment-cell imported 'a #f)) + (env-cell (environment-cell env 'a #f))) + (eq? env-cell imported-cell))))) + + (with-test-prefix "symbols bound in local" + + (pass-if "binding is visible" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-bound? env 'a) + (environment-define local 'a #t) + (environment-bound? env 'a))) + + (pass-if "ref works" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-define local 'a #t) + (environment-ref env 'a))) + + (pass-if "set! works" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-define local 'a #f) + (environment-set! env 'a #t) + (environment-ref local 'a))) + + (pass-if "cells are passed through" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-define local 'a #t) + (let* ((local-cell (environment-cell local 'a #f)) + (env-cell (environment-cell env 'a #f))) + (eq? env-cell local-cell))))) + + (with-test-prefix "symbols bound in local and imported" + + (pass-if "binding is visible" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-bound? env 'a) + (environment-define imported 'a #t) + (environment-define local 'a #f) + (environment-bound? env 'a))) + + (pass-if "ref works" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-define imported 'a #f) + (environment-define local 'a #t) + (environment-ref env 'a))) + + (pass-if "set! changes local" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-define imported 'a #f) + (environment-define local 'a #f) + (environment-set! env 'a #t) + (environment-ref local 'a))) + + (pass-if "set! does not touch imported" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-define imported 'a #t) + (environment-define local 'a #t) + (environment-set! env 'a #f) + (environment-ref imported 'a))) + + (pass-if "cells from local are passed through" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-define local 'a #t) + (let* ((local-cell (environment-cell local 'a #f)) + (env-cell (environment-cell env 'a #f))) + (eq? env-cell local-cell))))) + + (with-test-prefix "defining symbols" + + (pass-if "symbols are bound in local after define" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-define env 'a #t) + (environment-bound? local 'a))) + + (pass-if "cells in local get rebound after define" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-define env 'a #f) + (let* ((old-cell (environment-cell local 'a #f))) + (environment-define env 'a #f) + (let* ((new-cell (environment-cell local 'a #f))) + (not (eq? new-cell old-cell)))))) + + (pass-if "cells in imported get shadowed after define" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-define imported 'a #f) + (environment-define env 'a #t) + (environment-ref local 'a)))) + + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + + (pass-if "reference an undefined symbol" + (catch #t + (lambda () + (environment-ref env 'b) + #f) + (lambda args + #t))) + + (pass-if "set! an undefined symbol" + (catch #t + (lambda () + (environment-set! env 'b) + #f) + (lambda args + #t))) + + (pass-if "get a readable cell for an undefined symbol" + (catch #t + (lambda () + (environment-cell env 'b #f) + #f) + (lambda args + #t))) + + (pass-if "get a writable cell for an undefined symbol" + (catch #t + (lambda () + (environment-cell env 'b #t) + #f) + (lambda args + #t))))) + + (with-test-prefix "eval-environment-set-local!" + + (pass-if "documented?" + (documented? eval-environment-set-local!)) + + (pass-if "new binding becomes visible" + (let* ((old-local (make-leaf-environment)) + (new-local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment old-local imported))) + (environment-bound? env 'a) + (environment-define new-local 'a #t) + (eval-environment-set-local! env new-local) + (environment-bound? env 'a))) + + (pass-if "existing binding is replaced" + (let* ((old-local (make-leaf-environment)) + (new-local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment old-local imported))) + (environment-define old-local 'a #f) + (environment-ref env 'a) + (environment-define new-local 'a #t) + (eval-environment-set-local! env new-local) + (environment-ref env 'a))) + + (pass-if "undefined binding is removed" + (let* ((old-local (make-leaf-environment)) + (new-local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment old-local imported))) + (environment-define old-local 'a #f) + (environment-ref env 'a) + (eval-environment-set-local! env new-local) + (not (environment-bound? env 'a)))) + + (pass-if "binding in imported remains shadowed" + (let* ((old-local (make-leaf-environment)) + (new-local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment old-local imported))) + (environment-define imported 'a #f) + (environment-define old-local 'a #f) + (environment-ref env 'a) + (environment-define new-local 'a #t) + (eval-environment-set-local! env new-local) + (environment-ref env 'a))) + + (pass-if "binding in imported gets shadowed" + (let* ((old-local (make-leaf-environment)) + (new-local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment old-local imported))) + (environment-define imported 'a #f) + (environment-ref env 'a) + (environment-define new-local 'a #t) + (eval-environment-set-local! env new-local) + (environment-ref env 'a))) + + (pass-if "binding in imported becomes visible" + (let* ((old-local (make-leaf-environment)) + (new-local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment old-local imported))) + (environment-define imported 'a #t) + (environment-define old-local 'a #f) + (environment-ref env 'a) + (eval-environment-set-local! env new-local) + (environment-ref env 'a)))) + + (with-test-prefix "eval-environment-set-imported!" + + (pass-if "documented?" + (documented? eval-environment-set-imported!)) + + (pass-if "new binding becomes visible" + (let* ((local (make-leaf-environment)) + (old-imported (make-leaf-environment)) + (new-imported (make-leaf-environment)) + (env (make-eval-environment local old-imported))) + (environment-bound? env 'a) + (environment-define new-imported 'a #t) + (eval-environment-set-imported! env new-imported) + (environment-bound? env 'a))) + + (pass-if "existing binding is replaced" + (let* ((local (make-leaf-environment)) + (old-imported (make-leaf-environment)) + (new-imported (make-leaf-environment)) + (env (make-eval-environment local old-imported))) + (environment-define old-imported 'a #f) + (environment-ref env 'a) + (environment-define new-imported 'a #t) + (eval-environment-set-imported! env new-imported) + (environment-ref env 'a))) + + (pass-if "undefined binding is removed" + (let* ((local (make-leaf-environment)) + (old-imported (make-leaf-environment)) + (new-imported (make-leaf-environment)) + (env (make-eval-environment local old-imported))) + (environment-define old-imported 'a #f) + (environment-ref env 'a) + (eval-environment-set-imported! env new-imported) + (not (environment-bound? env 'a)))) + + (pass-if "binding in imported remains shadowed" + (let* ((local (make-leaf-environment)) + (old-imported (make-leaf-environment)) + (new-imported (make-leaf-environment)) + (env (make-eval-environment local old-imported))) + (environment-define local 'a #t) + (environment-define old-imported 'a #f) + (environment-ref env 'a) + (environment-define new-imported 'a #t) + (eval-environment-set-imported! env new-imported) + (environment-ref env 'a))) + + (pass-if "binding in imported gets shadowed" + (let* ((local (make-leaf-environment)) + (old-imported (make-leaf-environment)) + (new-imported (make-leaf-environment)) + (env (make-eval-environment local old-imported))) + (environment-define local 'a #t) + (environment-ref env 'a) + (environment-define new-imported 'a #f) + (eval-environment-set-imported! env new-imported) + (environment-ref env 'a)))) + + (with-test-prefix "undefine" + + (pass-if "undefine an already undefined symbol" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-undefine env 'a) + #t)) + + (pass-if "undefine removes a binding from local" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-define local 'a #t) + (environment-undefine env 'a) + (not (environment-bound? local 'a)))) + + (pass-if "undefine does not influence imported" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-define imported 'a #t) + (environment-undefine env 'a) + (environment-bound? imported 'a))) + + (pass-if "undefine an imported symbol does not undefine it" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-define imported 'a #t) + (environment-undefine env 'a) + (environment-bound? env 'a))) + + (pass-if "undefine unshadows an imported symbol" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-define imported 'a #t) + (environment-define local 'a #f) + (environment-undefine env 'a) + (environment-ref env 'a)))) + + (with-test-prefix "fold" + + (pass-if "empty environment" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (eq? 'success (environment-fold env folder 'success)))) + + (pass-if "one symbol in local" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-define local 'a #t) + (equal? '((a . #t)) (environment-fold env folder '())))) + + (pass-if "one symbol in imported" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-define imported 'a #t) + (equal? '((a . #t)) (environment-fold env folder '())))) + + (pass-if "shadowed symbol" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-define local 'a #t) + (environment-define imported 'a #f) + (equal? '((a . #t)) (environment-fold env folder '())))) + + (pass-if "one symbol each" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-define local 'a #t) + (environment-define imported 'b #f) + (let ((folded (environment-fold env folder '()))) + (or (equal? folded '((a . #t) (b . #f))) + (equal? folded '((b . #f) (a . #t)))))))) + + + (with-test-prefix "observe" + + (pass-if "observe an environment" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-observe env (make-observer-func)) + #t)) + + (pass-if "observe an environment twice" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported)) + (observer-1 (environment-observe env (make-observer-func))) + (observer-2 (environment-observe env (make-observer-func)))) + (not (eq? observer-1 observer-2)))) + + (pass-if "definition of an undefined symbol" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported)) + (func (make-observer-func))) + (environment-observe env func) + (environment-define env 'a 1) + (eqv? (func) 1))) + + (pass-if "definition of an already defined symbol" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-define env 'a 1) + (let* ((func (make-observer-func))) + (environment-observe env func) + (environment-define env 'a 1) + (eqv? (func) 1)))) + + (pass-if "set!ing of a defined symbol" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-define env 'a 1) + (let* ((func (make-observer-func))) + (environment-observe env func) + (environment-set! env 'a 1) + (eqv? (func) 0)))) + + (pass-if "undefining a defined symbol" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-define env 'a 1) + (let* ((func (make-observer-func))) + (environment-observe env func) + (environment-undefine env 'a) + (eqv? (func) 1)))) + + (pass-if "undefining an already undefined symbol" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported)) + (func (make-observer-func))) + (environment-observe env func) + (environment-undefine env 'a) + (eqv? (func) 0))) + + (pass-if "unobserve an active observer" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported)) + (func (make-observer-func)) + (observer (environment-observe env func))) + (environment-unobserve observer) + (environment-define env 'a 1) + (eqv? (func) 0))) + + (pass-if "unobserve an inactive observer" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported)) + (func (make-observer-func)) + (observer (environment-observe env func))) + (environment-unobserve observer) + (environment-unobserve observer) + #t))) + + + (with-test-prefix "observe-weak" + + (pass-if "observe an environment" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-observe-weak env (make-observer-func)) + #t)) + + (pass-if "observe an environment twice" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported)) + (observer-1 (environment-observe-weak env (make-observer-func))) + (observer-2 (environment-observe-weak env (make-observer-func)))) + (not (eq? observer-1 observer-2)))) + + (pass-if "definition of an undefined symbol" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported)) + (func (make-observer-func))) + (environment-observe-weak env func) + (environment-define env 'a 1) + (eqv? (func) 1))) + + (pass-if "definition of an already defined symbol" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-define env 'a 1) + (let* ((func (make-observer-func))) + (environment-observe-weak env func) + (environment-define env 'a 1) + (eqv? (func) 1)))) + + (pass-if "set!ing of a defined symbol" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-define env 'a 1) + (let* ((func (make-observer-func))) + (environment-observe-weak env func) + (environment-set! env 'a 1) + (eqv? (func) 0)))) + + (pass-if "undefining a defined symbol" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (environment-define env 'a 1) + (let* ((func (make-observer-func))) + (environment-observe-weak env func) + (environment-undefine env 'a) + (eqv? (func) 1)))) + + (pass-if "undefining an already undefined symbol" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported)) + (func (make-observer-func))) + (environment-observe-weak env func) + (environment-undefine env 'a) + (eqv? (func) 0))) + + (pass-if "unobserve an active observer" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported)) + (func (make-observer-func)) + (observer (environment-observe-weak env func))) + (environment-unobserve observer) + (environment-define env 'a 1) + (eqv? (func) 0))) + + (pass-if "unobserve an inactive observer" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported)) + (func (make-observer-func)) + (observer (environment-observe-weak env func))) + (environment-unobserve observer) + (environment-unobserve observer) + #t)) + + (pass-if "weak observer gets collected" + (gc) + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported)) + (func (make-observer-func))) + (environment-observe-weak env func) + (gc) + (environment-define env 'a 1) + (eqv? (func) 0)))) + + + (with-test-prefix "erroneous observers" + + (pass-if "update continues after error" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported)) + (func-1 (make-erroneous-observer-func)) + (func-2 (make-erroneous-observer-func))) + (environment-observe env func-1) + (environment-observe env func-2) + (catch #t + (lambda () + (environment-define env 'a 1) + #f) + (lambda args + (and (eq? (func-1) 1) + (eq? (func-2) 1)))))))) + + +;;; +;;; leaf-environment based import-environments +;;; + +(with-test-prefix "leaf-environment based import-environments" + + (with-test-prefix "import-environment?" + + (pass-if "documented?" + (documented? import-environment?)) + + (pass-if "non-environment-object" + (not (import-environment? #f))) + + (pass-if "leaf-environment-object" + (not (import-environment? (make-leaf-environment)))) + + (pass-if "eval-environment-object" + (let* ((local (make-leaf-environment)) + (imported (make-leaf-environment)) + (env (make-eval-environment local imported))) + (not (import-environment? (make-leaf-environment)))))) + + + (with-test-prefix "make-import-environment" + + (pass-if "documented?" + (documented? make-import-environment)))) + From b4255788b5555acb9d25b071094d3bd6eb1ea484 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 5 Sep 2000 18:39:09 +0000 Subject: [PATCH 0231/2047] * init.c: Include "libguile/properties.h". --- libguile/init.c | 1 + 1 file changed, 1 insertion(+) diff --git a/libguile/init.c b/libguile/init.c index d288b21bd..01cb4eb94 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -108,6 +108,7 @@ #include "libguile/print.h" #include "libguile/procprop.h" #include "libguile/procs.h" +#include "libguile/properties.h" #include "libguile/ramap.h" #include "libguile/random.h" #include "libguile/read.h" From 0e1d5b0a2aad29cfb915deccde9ea8acbc6651c2 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 5 Sep 2000 18:39:54 +0000 Subject: [PATCH 0232/2047] * gh_data.c (gh_scm2char): Validate that argument is a character. --- libguile/gh_data.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/libguile/gh_data.c b/libguile/gh_data.c index b982f6ec0..d0b164de0 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -255,9 +255,12 @@ gh_scm2double (SCM obj) } char gh_scm2char (SCM obj) +#define FUNC_NAME "gh_scm2char" { + SCM_VALIDATE_CHAR (SCM_ARG1, obj); return SCM_CHAR (obj); } +#undef FUNC_NAME; /* Convert a vector, weak vector, string, substring or uniform vector into an array of chars. If result array in arg 2 is NULL, malloc a From f0cb87877e17ffafea908bf3817018a2db2fc2ef Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 5 Sep 2000 18:40:19 +0000 Subject: [PATCH 0233/2047] *** empty log message *** --- libguile/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index acf2bc4cf..c39cd5450 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2000-09-05 Marius Vollmer + + * init.c: Include "libguile/properties.h". + + * gh_data.c (gh_scm2char): Validate that argument is a character. + 2000-08-25 Dirk Herrmann * environments.h (SCM_IMPORT_ENVIRONMENT_P, From d70d2c1e761ad3a213c42eee8c0d118461f9b7ee Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 6 Sep 2000 14:45:59 +0000 Subject: [PATCH 0234/2047] 2000-09-05 Mikael Djurfeldt * symbols.c (scm_gensym): Check that argument is a symbol, not a string. (Thanks to rm@mamma.varadinet.de.) --- libguile/symbols.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/symbols.c b/libguile/symbols.c index 919f806db..83136ae3e 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -859,7 +859,7 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 2, 0, if (SCM_UNBNDP (name)) name = gensym_prefix; else - SCM_VALIDATE_ROSTRING (1,name); + SCM_VALIDATE_SYMBOL (1, name); new = name; if (SCM_UNBNDP (obarray)) From a2550d0e3a7b0d8e1a7b30fd1c9fc6c26c549a07 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 6 Sep 2000 14:46:13 +0000 Subject: [PATCH 0235/2047] *** empty log message *** --- libguile/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index c39cd5450..d3a330f52 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-09-05 Mikael Djurfeldt + + * symbols.c (scm_gensym): Check that argument is a symbol, not a + string. (Thanks to rm@mamma.varadinet.de.) + 2000-09-05 Marius Vollmer * init.c: Include "libguile/properties.h". From a2d47b23b22ba0d30d13542810b17d5966f2f946 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 7 Sep 2000 09:19:22 +0000 Subject: [PATCH 0236/2047] * Fix hash value handling. * Documentation improvements. * Cleanups and optimizations. --- libguile/ChangeLog | 13 ++++++++++ libguile/environments.c | 57 +++++++++++++++++++++++++++++------------ 2 files changed, 53 insertions(+), 17 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d3a330f52..267f27c22 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,16 @@ +2000-09-07 Dirk Herrmann + + * environments.c (obarray_enter, obarray_retrieve, + obarray_remove): Make sure the hash value is a valid obarray + index. + + (obarray_enter, obarray_remove): Documentation improved. + + (obarray_replace): Added. + + (leaf_environment_define, leaf_environment_undefine): Cleaned up + and optimized. + 2000-09-05 Mikael Djurfeldt * symbols.c (scm_gensym): Check that argument is a symbol, not a diff --git a/libguile/environments.c b/libguile/environments.c index 6cb98bb9e..dd5ef17fe 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -515,12 +515,13 @@ print_observer (SCM type, SCM port, scm_print_state *pstate) /* - * Copy symbol to obarray. The symbol must not already exist in obarray. + * Enter symbol into obarray. The symbol must not already exist in obarray. + * The freshly generated (symbol . data) cell is returned. */ static SCM obarray_enter (SCM obarray, SCM symbol, SCM data) { - scm_sizet hash = SCM_SYMBOL_HASH (symbol); + scm_sizet hash = SCM_SYMBOL_HASH (symbol) % SCM_LENGTH (obarray); SCM entry = scm_cons (symbol, data); SCM slot = scm_cons (entry, SCM_VELTS (obarray)[hash]); SCM_VELTS (obarray)[hash] = slot; @@ -529,13 +530,42 @@ obarray_enter (SCM obarray, SCM symbol, SCM data) } +/* + * Enter symbol into obarray. An existing entry for symbol is replaced. If + * an entry existed, the old (symbol . data) cell is returned, #f otherwise. + */ +static SCM +obarray_replace (SCM obarray, SCM symbol, SCM data) +{ + scm_sizet hash = SCM_SYMBOL_HASH (symbol) % SCM_LENGTH (obarray); + SCM new_entry = scm_cons (symbol, data); + SCM lsym; + SCM slot; + + for (lsym = SCM_VELTS (obarray)[hash]; !SCM_NULLP (lsym); lsym = SCM_CDR (lsym)) + { + SCM old_entry = SCM_CAR (lsym); + if (SCM_CAR (old_entry) == symbol) + { + SCM_SETCAR (lsym, new_entry); + return old_entry; + } + } + + slot = scm_cons (new_entry, SCM_VELTS (obarray)[hash]); + SCM_VELTS (obarray)[hash] = slot; + + return SCM_BOOL_F; +} + + /* * Look up symbol in obarray */ static SCM obarray_retrieve (SCM obarray, SCM sym) { - scm_sizet hash = SCM_SYMBOL_HASH (sym); + scm_sizet hash = SCM_SYMBOL_HASH (sym) % SCM_LENGTH (obarray); SCM lsym; for (lsym = SCM_VELTS (obarray)[hash]; !SCM_NULLP (lsym); lsym = SCM_CDR (lsym)) @@ -550,12 +580,13 @@ obarray_retrieve (SCM obarray, SCM sym) /* - * remove entry from obarray + * Remove entry from obarray. If the symbol was found and removed, the old + * (symbol . data) cell is returned, #f otherwise. */ static SCM obarray_remove (SCM obarray, SCM sym) { - scm_sizet hash = SCM_SYMBOL_HASH (sym); + scm_sizet hash = SCM_SYMBOL_HASH (sym) % SCM_LENGTH (obarray); SCM lsym; SCM *lsymp; @@ -885,13 +916,8 @@ leaf_environment_define (SCM env, SCM sym, SCM val) #define FUNC_NAME "leaf_environment_define" { SCM obarray = LEAF_ENVIRONMENT (env)->obarray; - SCM old_binding = obarray_retrieve (obarray, sym); - SCM new_binding; - if (!SCM_UNBNDP (old_binding)) - obarray_remove (obarray, sym); - - new_binding = obarray_enter (obarray, sym, val); + obarray_replace (obarray, sym, val); core_environments_broadcast (env); return SCM_ENVIRONMENT_SUCCESS; @@ -904,13 +930,10 @@ leaf_environment_undefine (SCM env, SCM sym) #define FUNC_NAME "leaf_environment_undefine" { SCM obarray = LEAF_ENVIRONMENT (env)->obarray; - SCM binding = obarray_retrieve (obarray, sym); + SCM removed = obarray_remove (obarray, sym); - if (!SCM_UNBNDP (binding)) - { - obarray_remove (obarray, sym); - core_environments_broadcast (env); - } + if (!SCM_FALSEP (removed)) + core_environments_broadcast (env); return SCM_ENVIRONMENT_SUCCESS; } From afa38f6e600336a055971c12a2e7cd0bdcb189fa Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 10 Sep 2000 13:41:18 +0000 Subject: [PATCH 0237/2047] * eval.c (SCM_APPLY): Fixed bugs in the applicable-smob calls. --- libguile/eval.c | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index 41c10c3e7..86b21f6e0 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3496,15 +3496,14 @@ tail: case scm_tc7_smob: if (!SCM_SMOB_DESCRIPTOR (proc).apply) goto badproc; - if (SCM_NULLP (args)) + if (SCM_UNBNDP (arg1)) RETURN (scm_smob_apply_0 (proc)) + else if (SCM_NULLP (args)) + RETURN (scm_smob_apply_1 (proc, arg1)) else if (SCM_NULLP (SCM_CDR (args))) - RETURN (scm_smob_apply_1 (proc, SCM_CAR (args))) - else if (SCM_NULLP (SCM_CDDR (args))) - RETURN (scm_smob_apply_2 (proc, SCM_CAR (args), SCM_CADR (args))) + RETURN (scm_smob_apply_2 (proc, arg1, SCM_CAR (args))) else - RETURN (scm_smob_apply_3 (proc, SCM_CAR (args), SCM_CADR (args), - SCM_CDDR (args))); + RETURN (scm_smob_apply_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args))); case scm_tc7_contin: SCM_ASRTGO (SCM_NULLP (args), wrongnumargs); scm_call_continuation (proc, arg1); From 3cbe8373d3093189b72b5ec9beff97d93725e64a Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 10 Sep 2000 13:41:31 +0000 Subject: [PATCH 0238/2047] *** empty log message *** --- libguile/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 267f27c22..c842de20f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2000-09-10 Keisuke Nishida + + * eval.c (SCM_APPLY): Fixed bugs in the applicable-smob calls. + 2000-09-07 Dirk Herrmann * environments.c (obarray_enter, obarray_retrieve, From c64d02c59aa44ff49e9b8bf4385b06dd3a23e675 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 10 Sep 2000 19:10:10 +0000 Subject: [PATCH 0239/2047] * symbols.c (scm_gensym): Bugfixed my previous bugfix. (Thanks to Dale P. Smith.) --- libguile/symbols.c | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/libguile/symbols.c b/libguile/symbols.c index 83136ae3e..f204a0a05 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -857,11 +857,13 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 2, 0, { SCM new; if (SCM_UNBNDP (name)) - name = gensym_prefix; + new = gensym_prefix; else - SCM_VALIDATE_SYMBOL (1, name); + { + SCM_VALIDATE_SYMBOL (1, name); + new = scm_symbol_to_string (name); + } - new = name; if (SCM_UNBNDP (obarray)) { obarray = SCM_BOOL_F; From 370646da5b9eb110eb05a694f8a6cfc3439496ad Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 10 Sep 2000 19:11:28 +0000 Subject: [PATCH 0240/2047] *** empty log message *** --- THANKS | 1 + libguile/ChangeLog | 7 ++++++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/THANKS b/THANKS index 72ae423a5..c209cf8f1 100644 --- a/THANKS +++ b/THANKS @@ -20,3 +20,4 @@ For fixes or providing information which led to a fix: Han-Wen Nienhuys William Webber Dale P. Smith + Ralf Mattes diff --git a/libguile/ChangeLog b/libguile/ChangeLog index c842de20f..54ecd6488 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-09-10 Mikael Djurfeldt + + * symbols.c (scm_gensym): Bugfixed my previous bugfix. (Thanks to + Dale P. Smith.) + 2000-09-10 Keisuke Nishida * eval.c (SCM_APPLY): Fixed bugs in the applicable-smob calls. @@ -18,7 +23,7 @@ 2000-09-05 Mikael Djurfeldt * symbols.c (scm_gensym): Check that argument is a symbol, not a - string. (Thanks to rm@mamma.varadinet.de.) + string. (Thanks to Ralf Mattes.) 2000-09-05 Marius Vollmer From 44ab8170971bfee1ad9a68e1024bb3c04e3a9c4b Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 10 Sep 2000 20:21:42 +0000 Subject: [PATCH 0241/2047] * Makefile.am (.x.doc): Bugfix: Added $(srcdir) to path in order to allow for builds in separate tree. --- libguile/Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 3987240f0..e2a5d82e9 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -185,7 +185,7 @@ SUFFIXES = .x .doc PATH=.:${PATH} ./guile-doc-snarf $< $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \ || { rm $@; false; } .x.doc: - PATH=.:${PATH} ./guile-doc-snarf $*.c $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $*.c > /dev/null \ + PATH=.:${PATH} ./guile-doc-snarf $(srcdir)/$*.c $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $(srcdir)/$*.c > /dev/null \ || { rm $@; false; } error.x: cpp_err_symbols.c From 4c7cb8ba9447b5d51c88032b2b90eae618e2460e Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 10 Sep 2000 20:22:09 +0000 Subject: [PATCH 0242/2047] *** empty log message *** --- libguile/ChangeLog | 3 +++ libguile/symbols.c | 5 +++-- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 54ecd6488..22fe5f93c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,8 @@ 2000-09-10 Mikael Djurfeldt + * Makefile.am (.x.doc): Bugfix: Added $(srcdir) to path in order + to allow for builds in separate tree. + * symbols.c (scm_gensym): Bugfixed my previous bugfix. (Thanks to Dale P. Smith.) diff --git a/libguile/symbols.c b/libguile/symbols.c index f204a0a05..6fe45589d 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -857,13 +857,14 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 2, 0, { SCM new; if (SCM_UNBNDP (name)) - new = gensym_prefix; + name = gensym_prefix; else { SCM_VALIDATE_SYMBOL (1, name); - new = scm_symbol_to_string (name); + name = scm_symbol_to_string (name); } + new = name; if (SCM_UNBNDP (obarray)) { obarray = SCM_BOOL_F; From fb43bf74e2a2131ec80bf9e71de2fddab7696ff7 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 10 Sep 2000 22:22:36 +0000 Subject: [PATCH 0243/2047] * modules.c: Use applicable smobs for eval closures instead of compiled closures. Include "libguile/smob.h". (f_eval_closure): Removed. (scm_eval_closure_tag): New variable. (scm_eval_closure_lookup): Renamed from eval_closure. This function now takes a smob instead of a compiled closure. (scm_standard_eval_closure): Create a smob instead of a compiled closure. (scm_init_modules): Initialize the eval closure type as a smob. * modules.h (SCM_EVAL_CLOSURE_P): New macro. (scm_eval_closure_tag, scm_eval_closure_lookup): Declare. * symbols.c: Include "libguile/smob.h". (scm_sym2vcell): Call scm_eval_closure_lookup directly if THUNK is an eval closure. --- libguile/modules.c | 22 +++++++++++----------- libguile/modules.h | 4 ++++ libguile/symbols.c | 6 +++--- 3 files changed, 18 insertions(+), 14 deletions(-) diff --git a/libguile/modules.c b/libguile/modules.c index ae062ab74..04ba8546d 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -47,6 +47,7 @@ #include "libguile/_scm.h" #include "libguile/eval.h" +#include "libguile/smob.h" #include "libguile/procprop.h" #include "libguile/vectors.h" #include "libguile/hashtab.h" @@ -240,12 +241,14 @@ module_variable (SCM module, SCM sym) } } -static SCM f_eval_closure; +SCM scm_eval_closure_tag; -static SCM -eval_closure (SCM cclo, SCM sym, SCM definep) +/* NOTE: This function may be called by a smob application + or from another C function directly. */ +SCM +scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep) { - SCM module = SCM_VELTS (cclo) [1]; + SCM module = SCM_PACK (SCM_SMOB_DATA (eclo)); if (SCM_NFALSEP (definep)) return scm_apply (SCM_CDR (module_make_local_var_x), SCM_LIST2 (module, sym), @@ -259,9 +262,7 @@ SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0, "") #define FUNC_NAME s_scm_standard_eval_closure { - SCM cclo = scm_makcclo (f_eval_closure, 2); - SCM_VELTS (cclo) [1] = module; - return cclo; + SCM_RETURN_NEWSMOB (scm_eval_closure_tag, SCM_UNPACK (module)); } #undef FUNC_NAME @@ -271,10 +272,9 @@ scm_init_modules () #include "libguile/modules.x" module_make_local_var_x = scm_sysintern ("module-make-local-var!", SCM_UNDEFINED); - f_eval_closure = scm_make_subr_opt ("eval-closure", - scm_tc7_subr_3, - eval_closure, - 0); + scm_eval_closure_tag = scm_make_smob_type ("eval-closure", 0); + scm_set_smob_mark (scm_eval_closure_tag, scm_markcdr); + scm_set_smob_apply (scm_eval_closure_tag, scm_eval_closure_lookup, 2, 0, 0); } void diff --git a/libguile/modules.h b/libguile/modules.h index 9e7f8eb11..cfe4de442 100644 --- a/libguile/modules.h +++ b/libguile/modules.h @@ -73,10 +73,13 @@ #define SCM_MODULE_EVAL_CLOSURE(module) \ SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_eval_closure]) +#define SCM_EVAL_CLOSURE_P(OBJ) SCM_SMOB_PREDICATE (scm_eval_closure_tag, OBJ) + extern SCM scm_module_system_booted_p; extern SCM scm_module_tag; +extern SCM scm_eval_closure_tag; extern SCM scm_the_root_module (void); extern SCM scm_selected_module (void); @@ -90,6 +93,7 @@ extern SCM scm_load_scheme_module (SCM name); extern SCM scm_env_top_level (SCM env); extern SCM scm_top_level_env (SCM thunk); extern SCM scm_system_module_env_p (SCM env); +extern SCM scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep); extern SCM scm_standard_eval_closure (SCM module); extern void scm_init_modules (void); extern void scm_post_boot_init_modules (void); diff --git a/libguile/symbols.c b/libguile/symbols.c index 6fe45589d..b9b1b8c85 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -48,6 +48,7 @@ #include "libguile/_scm.h" #include "libguile/chars.h" #include "libguile/eval.h" +#include "libguile/smob.h" #include "libguile/variable.h" #include "libguile/alist.h" #include "libguile/fluids.h" @@ -112,10 +113,9 @@ scm_sym2vcell (SCM sym, SCM thunk, SCM definep) { SCM var; - if (SCM_TYP7 (thunk) == scm_tc7_cclo - && SCM_TYP7 (SCM_CCLO_SUBR (thunk)) == scm_tc7_subr_3) + if (SCM_EVAL_CLOSURE_P (thunk)) /* Bypass evaluator in the standard case. */ - var = SCM_SUBRF (SCM_CCLO_SUBR (thunk)) (thunk, sym, definep); + var = scm_eval_closure_lookup (thunk, sym, definep); else var = scm_apply (thunk, sym, scm_cons (definep, scm_listofnull)); From 5bcdfa2ea803e8c6eebb727bd4733d9f561801bd Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 10 Sep 2000 22:22:48 +0000 Subject: [PATCH 0244/2047] *** empty log message *** --- libguile/ChangeLog | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 22fe5f93c..ed726b0d7 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,20 @@ +2000-09-10 Keisuke Nishida + + * modules.c: Use applicable smobs for eval closures instead of + compiled closures. Include "libguile/smob.h". + (f_eval_closure): Removed. + (scm_eval_closure_tag): New variable. + (scm_eval_closure_lookup): Renamed from eval_closure. + This function now takes a smob instead of a compiled closure. + (scm_standard_eval_closure): Create a smob instead of a compiled + closure. + (scm_init_modules): Initialize the eval closure type as a smob. + * modules.h (SCM_EVAL_CLOSURE_P): New macro. + (scm_eval_closure_tag, scm_eval_closure_lookup): Declare. + * symbols.c: Include "libguile/smob.h". + (scm_sym2vcell): Call scm_eval_closure_lookup directly if THUNK + is an eval closure. + 2000-09-10 Mikael Djurfeldt * Makefile.am (.x.doc): Bugfix: Added $(srcdir) to path in order From e1313058e1a2aed4e6318cece8094293c1aafeef Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Tue, 12 Sep 2000 05:44:00 +0000 Subject: [PATCH 0245/2047] * symbols.c (scm_gensym): Reimplemented. Now only takes one optional argument which should be a *string*. (scm_gentemp): Reimplemented and moved from boot-9.scm. --- libguile/symbols.c | 104 +++++++++++++++++++++++++++++++++------------ 1 file changed, 77 insertions(+), 27 deletions(-) diff --git a/libguile/symbols.c b/libguile/symbols.c index b9b1b8c85..b67c85025 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -844,45 +844,95 @@ SCM_DEFINE (scm_builtin_weak_bindings, "builtin-weak-bindings", 0, 0, 0, } #undef FUNC_NAME -static int gensym_counter; -static SCM gensym_prefix; +#define MAX_PREFIX_LENGTH 30 -/* :FIXME:OPTIMIZE */ -SCM_DEFINE (scm_gensym, "gensym", 0, 2, 0, - (SCM name, SCM obarray), - "Create a new, unique symbol in @var{obarray}, using the global symbol\n" - "table by default. If @var{name} is specified, it should be used as a\n" - "prefix for the new symbol's name. The default prefix is @code{%%gensym}.") +static int gensym_counter; + +SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, + (SCM prefix), + "Create a new symbol with name constructed from a prefix and a counter value.\n" + "The string PREFIX can be specified as an optional argument.\n" + "Default prefix is @code{g}. The counter is increased by 1 at each call.\n" + "There is no provision for resetting the counter.") #define FUNC_NAME s_scm_gensym { - SCM new; - if (SCM_UNBNDP (name)) - name = gensym_prefix; + char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; + char *name = buf; + int len; + if (SCM_UNBNDP (prefix)) + { + name[0] = 'g'; + len = 1; + } else { - SCM_VALIDATE_SYMBOL (1, name); - name = scm_symbol_to_string (name); + SCM_VALIDATE_STRINGORSUBSTR (1, prefix); + len = SCM_ROLENGTH (prefix); + if (len > MAX_PREFIX_LENGTH) + name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); + strncpy (name, SCM_ROCHARS (prefix), len); + } + { + int n_digits = scm_iint2str (gensym_counter++, 10, &name[len]); + SCM res = SCM_CAR (scm_intern (name, len + n_digits)); + if (name != buf) + scm_must_free (name); + return res; + } +} +#undef FUNC_NAME + +static int gentemp_counter; + +SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0, + (SCM prefix, SCM obarray), + "Create a new symbol with a name unique in an obarray.\n" + "The name is constructed from an optional string PREFIX and a counter\n" + "value. The default prefix is @var{t}. The OBARRAY is specified as a\n" + "second optional argument. Default is the system obarray where all\n" + "normal symbols are interned. The counter is increased by 1 at each\n" + "call. There is no provision for resetting the counter.") +#define FUNC_NAME s_scm_gentemp +{ + char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; + char *name = buf; + int len, n_digits; + if (SCM_UNBNDP (prefix)) + { + name[0] = 't'; + len = 1; + } + else + { + SCM_VALIDATE_STRINGORSUBSTR (1, prefix); + len = SCM_ROLENGTH (prefix); + if (len > MAX_PREFIX_LENGTH) + name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); + strncpy (name, SCM_ROCHARS (prefix), len); } - new = name; if (SCM_UNBNDP (obarray)) - { - obarray = SCM_BOOL_F; - goto skip_test; - } + obarray = scm_symhash; else SCM_ASSERT ((SCM_VECTORP (obarray) || SCM_WVECTP (obarray)), obarray, SCM_ARG2, FUNC_NAME); - while (!SCM_FALSEP (scm_string_to_obarray_symbol (obarray, new, SCM_BOOL_T))) - skip_test: - new = scm_string_append - (scm_cons2 (name, - scm_number_to_string (SCM_MAKINUM (gensym_counter++), - SCM_UNDEFINED), - SCM_EOL)); - return scm_string_to_obarray_symbol (obarray, new, SCM_BOOL_F); + do + n_digits = scm_iint2str (gentemp_counter++, 10, &name[len]); + while (!SCM_FALSEP (scm_intern_obarray_soft (name, + len + n_digits, + obarray, + 1))); + { + SCM vcell = scm_intern_obarray_soft (name, + len + n_digits, + obarray, + 0); + if (name != buf) + scm_must_free (name); + return SCM_CAR (vcell); + } } #undef FUNC_NAME @@ -890,7 +940,7 @@ void scm_init_symbols () { gensym_counter = 0; - gensym_prefix = scm_permanent_object (scm_makfrom0str ("%%gensym")); + gentemp_counter = 0; #include "libguile/symbols.x" } From 5382d876c87531a37b6dafb76202c6ce96681774 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Tue, 12 Sep 2000 05:44:12 +0000 Subject: [PATCH 0246/2047] * symbols.h (scm_gentemp): Declared. --- libguile/symbols.h | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/symbols.h b/libguile/symbols.h index 05e8c2c96..d2a9af0ee 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -144,7 +144,8 @@ extern SCM scm_symbol_pset_x (SCM s, SCM val); extern SCM scm_symbol_hash (SCM s); extern SCM scm_builtin_bindings (void); extern SCM scm_builtin_weak_bindings (void); -extern SCM scm_gensym (SCM name, SCM obarray); +extern SCM scm_gensym (SCM prefix); +extern SCM scm_gentemp (SCM prefix, SCM obarray); extern void scm_init_symbols (void); #endif /* SYMBOLSH */ From 302f229e5834e1bf82a04949c2cd064685f80bed Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Tue, 12 Sep 2000 05:44:34 +0000 Subject: [PATCH 0247/2047] *** empty log message *** --- NEWS | 8 ++++++++ libguile/ChangeLog | 8 ++++++++ 2 files changed, 16 insertions(+) diff --git a/NEWS b/NEWS index bb62b0d7d..4bbbbc91f 100644 --- a/NEWS +++ b/NEWS @@ -147,6 +147,14 @@ Use scm_memory_error instead of SCM_NALLOC. Use scm_catch or scm_lazy_catch from throw.[ch] instead. +** scm_gensym has changed prototype + +scm_gensym now only takes one argument. + +** New function: scm_gentemp (SCM prefix, SCM obarray) + +The builtin `gentemp' has now become a primitive. + Changes since Guile 1.3.4: diff --git a/libguile/ChangeLog b/libguile/ChangeLog index ed726b0d7..38a472df6 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2000-09-12 Mikael Djurfeldt + + * symbols.h (scm_gentemp): Declared. + + * symbols.c (scm_gensym): Reimplemented. Now only takes one + optional argument which should be a *string*. + (scm_gentemp): Reimplemented and moved from boot-9.scm. + 2000-09-10 Keisuke Nishida * modules.c: Use applicable smobs for eval closures instead of From 484cd656825fbe2b9a9083192353ed3b35b59060 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Tue, 12 Sep 2000 05:45:26 +0000 Subject: [PATCH 0248/2047] * boot-9.scm (gentemp): Moved to symbols.c. --- ice-9/boot-9.scm | 3 --- 1 file changed, 3 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 41d4eb9f6..c9da2b1de 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -2188,9 +2188,6 @@ e))) (#t e))) -(define (gentemp) - (gensym "scm:G")) - (provide 'defmacro) From b68c1eed743acb7673fa28c15f9323772d7e52c2 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Tue, 12 Sep 2000 05:45:37 +0000 Subject: [PATCH 0249/2047] * calling.scm (excursion-function-syntax, getter-and-setter-syntax, delegating-getter-and-setter-syntax): Call gensym with string argument. (Thanks to Dale P. Smith.) --- ice-9/calling.scm | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/ice-9/calling.scm b/ice-9/calling.scm index 2e3aa9c3f..5b06d7f19 100644 --- a/ice-9/calling.scm +++ b/ice-9/calling.scm @@ -1,6 +1,6 @@ ;;;; calling.scm --- Calling Conventions ;;;; -;;;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. +;;;; Copyright (C) 1995, 1996, 1997, 2000 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 @@ -129,9 +129,9 @@ (define (excursion-function-syntax vars) (let ((saved-value-names (map gensym vars)) - (tmp-var-name (gensym 'temp)) - (swap-fn-name (gensym 'swap)) - (thunk-name (gensym 'thunk))) + (tmp-var-name (gensym "temp")) + (swap-fn-name (gensym "swap")) + (thunk-name (gensym "thunk"))) `(lambda (,thunk-name) (letrec ((,tmp-var-name #f) (,swap-fn-name @@ -148,10 +148,10 @@ (define (getter-and-setter-syntax vars) - (let ((args-name (gensym 'args)) - (an-arg-name (gensym 'an-arg)) - (new-val-name (gensym 'new-value)) - (loop-name (gensym 'loop)) + (let ((args-name (gensym "args")) + (an-arg-name (gensym "an-arg")) + (new-val-name (gensym "new-value")) + (loop-name (gensym "loop")) (kws (map symbol->keyword vars))) (list `(lambda ,args-name (let ,loop-name ((,args-name ,args-name)) @@ -184,10 +184,10 @@ (,loop-name (cddr ,args-name))))))))) (define (delegating-getter-and-setter-syntax vars get-delegate set-delegate) - (let ((args-name (gensym 'args)) - (an-arg-name (gensym 'an-arg)) - (new-val-name (gensym 'new-value)) - (loop-name (gensym 'loop)) + (let ((args-name (gensym "args")) + (an-arg-name (gensym "an-arg")) + (new-val-name (gensym "new-value")) + (loop-name (gensym "loop")) (kws (map symbol->keyword vars))) (list `(lambda ,args-name (let ,loop-name ((,args-name ,args-name)) From a86869dc5941457ecc779c7e8ffd906fc17f8924 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Tue, 12 Sep 2000 05:45:48 +0000 Subject: [PATCH 0250/2047] * oldprint.scm (print-table-add!): Ditto. --- ice-9/oldprint.scm | 123 --------------------------------------------- 1 file changed, 123 deletions(-) diff --git a/ice-9/oldprint.scm b/ice-9/oldprint.scm index 442dddd46..e69de29bb 100644 --- a/ice-9/oldprint.scm +++ b/ice-9/oldprint.scm @@ -1,123 +0,0 @@ -;;;; Copyright (C) 1995, 1996, 1997 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 -;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA -;;;; - - -;;; {Print} -;;; -;;; This code was removed from boot-9.scm by MDJ 970301 -;;; . It is placed here for archival -;;; purposes. - -(define (print obj . args) - (let ((default-args (list (current-output-port) 0 0 default-print-style #f))) - (apply-to-args (append args (list-cdr-ref default-args (length args))) - (lambda (port depth length style table) - (cond - ((and table (print-table-ref table obj)) - ((print-style-tag-hook style 'eq-val) - obj port depth length style table)) - (else - (and table (print-table-add! table obj)) - (cond - ((print-style-max-depth? style depth) - ((print-style-excess-depth-hook style))) - ((print-style-max-length? style length) - ((print-style-excess-length-hook style))) - (else - ((print-style-hook style obj) - obj port depth length style table))))))))) - -(define (make-print-style) (make-vector 59 '())) - -(define (extend-print-style! style utag printer) - (hashq-set! style utag printer)) - -(define (print-style-hook style obj) - (let ((type-tag (tag obj))) - (or (hashq-ref style type-tag) - (hashq-ref style (logand type-tag 255)) - print-obj))) - -(define (print-style-tag-hook style type-tag) - (or (hashq-ref style type-tag) - print-obj)) - -(define (print-style-max-depth? style d) #f) -(define (print-style-max-length? style l) #f) -(define (print-style-excess-length-hook style) - (hashq-ref style 'excess-length-hook)) -(define (print-style-excess-depth-hook style) - (hashq-ref style 'excess-depth-hook)) - -(define (make-print-table) (make-vector 59 '())) -(define (print-table-ref table obj) (hashq-ref table obj)) -(define (print-table-add! table obj) (hashq-set! table obj (gensym 'ref))) - -(define (print-obj obj port depth length style table) (write obj port)) - -(define (print-pair pair port depth length style table) - (if (= 0 length) - (display #\( port)) - - (print (car pair) port (+ 1 depth) 0 style table) - - (cond - ((and (pair? (cdr pair)) - (or (not table) - (not (print-table-ref table (cdr pair))))) - - (display #\space port) - (print (cdr pair) port depth (+ 1 length) style table)) - - ((null? (cdr pair)) (display #\) port)) - - (else (display " . " port) - (print (cdr pair) port (+ 1 depth) 0 - style table) - (display #\) port)))) - -(define (print-vector obj port depth length style table) - (if (= 0 length) - (cond - ((weak-key-hash-table? obj) (display "#wh(" port)) - ((weak-value-hash-table? obj) (display "#whv(" port)) - ((doubly-weak-hash-table? obj) (display "#whd(" port)) - (else (display "#(" port)))) - - (if (< length (vector-length obj)) - (print (vector-ref obj length) port (+ 1 depth) 0 style table)) - - (cond - ((>= (+ 1 length) (vector-length obj)) (display #\) port)) - (else (display #\space port) - (print obj port depth - (+ 1 length) - style table)))) - -(define default-print-style (make-print-style)) - -(extend-print-style! default-print-style utag_vector print-vector) -(extend-print-style! default-print-style utag_wvect print-vector) -(extend-print-style! default-print-style utag_pair print-pair) -(extend-print-style! default-print-style 'eq-val - (lambda (obj port depth length style table) - (if (symbol? obj) - (display obj) - (begin - (display "##" port) - (display (print-table-ref table obj)))))) From 2a6ba08d36ddfc3012f4c02d8255de431dcdb1ac Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Tue, 12 Sep 2000 06:03:22 +0000 Subject: [PATCH 0251/2047] * psyntax.ss (build-lexical-var): Use gentemp instead of gensym; Convert first argument to a string. --- ice-9/psyntax.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ice-9/psyntax.ss b/ice-9/psyntax.ss index 0fd70f342..b49d148e1 100644 --- a/ice-9/psyntax.ss +++ b/ice-9/psyntax.ss @@ -399,7 +399,7 @@ (define-syntax build-lexical-var (syntax-rules () - ((_ src id) (gensym id generated-symbols)))) + ((_ src id) (gentemp (symbol->string id) generated-symbols)))) (define-syntax self-evaluating? (syntax-rules () From 0eee44664213f24992d84cc9bcbb7c6d65823632 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Tue, 12 Sep 2000 06:03:37 +0000 Subject: [PATCH 0252/2047] *** empty log message *** --- ice-9/ChangeLog | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 28124fc90..dc5b843ac 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,17 @@ +2000-09-12 Mikael Djurfeldt + + * psyntax.ss (build-lexical-var): Use gentemp instead of gensym; + Convert first argument to a string. + + * calling.scm (excursion-function-syntax, + getter-and-setter-syntax, + delegating-getter-and-setter-syntax): Call gensym with string + argument. (Thanks to Dale P. Smith.) + + * oldprint.scm (print-table-add!): Ditto. + + * boot-9.scm (gentemp): Moved to symbols.c. + 2000-08-27 Marius Vollmer * boot-9.scm (make-object-property): New function. From 477c9802af9f5dbfbb03d6858487748fd8e76f88 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Tue, 12 Sep 2000 06:04:06 +0000 Subject: [PATCH 0253/2047] Regenerated --- ice-9/psyntax.pp | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/ice-9/psyntax.pp b/ice-9/psyntax.pp index f30697a78..605403444 100644 --- a/ice-9/psyntax.pp +++ b/ice-9/psyntax.pp @@ -1,11 +1,11 @@ -(letrec ((lambda-var-list (lambda (vars203) (let lvl ((vars204 vars203) (ls (quote ())) (w205 (quote (())))) (cond ((pair? vars204) (lvl (cdr vars204) (cons (wrap (car vars204) w205) ls) w205)) ((id? vars204) (cons (wrap vars204 w205) ls)) ((null? vars204) ls) ((syntax-object? vars204) (lvl (syntax-object-expression vars204) ls (join-wraps w205 (syntax-object-wrap vars204)))) ((annotation? vars204) (lvl (annotation-expression vars204) ls w205)) (else (cons vars204 ls)))))) (gen-var (lambda (id206) (let ((id207 (if (syntax-object? id206) (syntax-object-expression id206) id206))) (if (annotation? id207) (gensym (annotation-expression id207) generated-symbols) (gensym id207 generated-symbols))))) (strip (lambda (x208 w209) (if (memq (quote top) (wrap-marks w209)) (if (or (annotation? x208) (and (pair? x208) (annotation? (car x208)))) (strip-annotation x208 (quote #f)) x208) (let f210 ((x211 x208)) (cond ((syntax-object? x211) (strip (syntax-object-expression x211) (syntax-object-wrap x211))) ((pair? x211) (let ((a (f210 (car x211))) (d (f210 (cdr x211)))) (if (and (eq? a (car x211)) (eq? d (cdr x211))) x211 (cons a d)))) ((vector? x211) (let ((old212 (vector->list x211))) (let ((new213 (map f210 old212))) (if (andmap eq? old212 new213) x211 (list->vector new213))))) (else x211)))))) (strip-annotation (lambda (x214 parent) (cond ((pair? x214) (let ((new215 (cons (quote #f) (quote #f)))) (begin (when parent (set-annotation-stripped! parent new215)) (set-car! new215 (strip-annotation (car x214) (quote #f))) (set-cdr! new215 (strip-annotation (cdr x214) (quote #f))) new215))) ((annotation? x214) (or (annotation-stripped x214) (strip-annotation (annotation-expression x214) x214))) ((vector? x214) (let ((new216 (make-vector (vector-length x214)))) (begin (when parent (set-annotation-stripped! parent new216)) (let loop ((i217 (- (vector-length x214) (quote 1)))) (unless (fx< i217 (quote 0)) (vector-set! new216 i217 (strip-annotation (vector-ref x214 i217) (quote #f))) (loop (fx- i217 (quote 1))))) new216))) (else x214)))) (ellipsis? (lambda (x218) (and (nonsymbol-id? x218) (free-id=? x218 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))))))) (chi-void (lambda () (list (quote void)))) (eval-local-transformer (lambda (expanded) (let ((p (local-eval-hook expanded))) (if (procedure? p) p (syntax-error p (quote "nonprocedure transfomer")))))) (chi-local-syntax (lambda (rec? e219 r w220 s k) ((lambda (tmp221) ((lambda (tmp222) (if tmp222 (apply (lambda (_223 id224 val e1 e2) (let ((ids225 id224)) (if (not (valid-bound-ids? ids225)) (syntax-error e219 (quote "duplicate bound keyword in")) (let ((labels (gen-labels ids225))) (let ((new-w (make-binding-wrap ids225 labels w220))) (k (cons e1 e2) (extend-env labels (let ((w228 (if rec? new-w w220)) (trans-r (macros-only-env r))) (map (lambda (x229) (cons (quote macro) (eval-local-transformer (chi x229 trans-r w228)))) val)) r) new-w s)))))) tmp222) ((lambda (_231) (syntax-error (source-wrap e219 w220 s))) tmp221))) (syntax-dispatch tmp221 (quote (any #(each (any any)) any . each-any))))) e219))) (chi-lambda-clause (lambda (e232 c r233 w234 k235) ((lambda (tmp236) ((lambda (tmp237) (if tmp237 (apply (lambda (id238 e1239 e2240) (let ((ids241 id238)) (if (not (valid-bound-ids? ids241)) (syntax-error e232 (quote "invalid parameter list in")) (let ((labels243 (gen-labels ids241)) (new-vars (map gen-var ids241))) (k235 new-vars (chi-body (cons e1239 e2240) e232 (extend-var-env labels243 new-vars r233) (make-binding-wrap ids241 labels243 w234))))))) tmp237) ((lambda (tmp245) (if tmp245 (apply (lambda (ids246 e1247 e2248) (let ((old-ids (lambda-var-list ids246))) (if (not (valid-bound-ids? old-ids)) (syntax-error e232 (quote "invalid parameter list in")) (let ((labels249 (gen-labels old-ids)) (new-vars250 (map gen-var old-ids))) (k235 (let f251 ((ls1 (cdr new-vars250)) (ls2 (car new-vars250))) (if (null? ls1) ls2 (f251 (cdr ls1) (cons (car ls1) ls2)))) (chi-body (cons e1247 e2248) e232 (extend-var-env labels249 new-vars250 r233) (make-binding-wrap old-ids labels249 w234))))))) tmp245) ((lambda (_253) (syntax-error e232)) tmp236))) (syntax-dispatch tmp236 (quote (any any . each-any)))))) (syntax-dispatch tmp236 (quote (each-any any . each-any))))) c))) (chi-body (lambda (body outer-form r254 w255) (let ((r256 (cons (quote ("placeholder" placeholder)) r254))) (let ((ribcage (make-ribcage (quote ()) (quote ()) (quote ())))) (let ((w257 (make-wrap (wrap-marks w255) (cons ribcage (wrap-subst w255))))) (let parse ((body258 (map (lambda (x262) (cons r256 (wrap x262 w257))) body)) (ids259 (quote ())) (labels260 (quote ())) (vars261 (quote ())) (vals (quote ())) (bindings (quote ()))) (if (null? body258) (syntax-error outer-form (quote "no expressions in body")) (let ((e263 (cdar body258)) (er (caar body258))) (call-with-values (lambda () (syntax-type e263 er (quote (())) (quote #f) ribcage)) (lambda (type264 value265 e266 w267 s268) (let ((t type264)) (if (memv t (quote (define-form))) (let ((id269 (wrap value265 w267)) (label (gen-label))) (let ((var270 (gen-var id269))) (begin (extend-ribcage! ribcage id269 label) (parse (cdr body258) (cons id269 ids259) (cons label labels260) (cons var270 vars261) (cons (cons er (wrap e266 w267)) vals) (cons (cons (quote lexical) var270) bindings))))) (if (memv t (quote (define-syntax-form))) (let ((id271 (wrap value265 w267)) (label272 (gen-label))) (begin (extend-ribcage! ribcage id271 label272) (parse (cdr body258) (cons id271 ids259) (cons label272 labels260) vars261 vals (cons (cons (quote macro) (cons er (wrap e266 w267))) bindings)))) (if (memv t (quote (begin-form))) ((lambda (tmp273) ((lambda (tmp274) (if tmp274 (apply (lambda (_275 e1276) (parse (let f277 ((forms e1276)) (if (null? forms) (cdr body258) (cons (cons er (wrap (car forms) w267)) (f277 (cdr forms))))) ids259 labels260 vars261 vals bindings)) tmp274) (syntax-error tmp273))) (syntax-dispatch tmp273 (quote (any . each-any))))) e266) (if (memv t (quote (local-syntax-form))) (chi-local-syntax value265 e266 er w267 s268 (lambda (forms279 er280 w281 s282) (parse (let f283 ((forms284 forms279)) (if (null? forms284) (cdr body258) (cons (cons er280 (wrap (car forms284) w281)) (f283 (cdr forms284))))) ids259 labels260 vars261 vals bindings))) (if (null? ids259) (build-sequence (quote #f) (map (lambda (x285) (chi (cdr x285) (car x285) (quote (())))) (cons (cons er (source-wrap e266 w267 s268)) (cdr body258)))) (begin (if (not (valid-bound-ids? ids259)) (syntax-error outer-form (quote "invalid or duplicate identifier in definition"))) (let loop286 ((bs bindings) (er-cache (quote #f)) (r-cache (quote #f))) (if (not (null? bs)) (let ((b (car bs))) (if (eq? (car b) (quote macro)) (let ((er287 (cadr b))) (let ((r-cache288 (if (eq? er287 er-cache) r-cache (macros-only-env er287)))) (begin (set-cdr! b (eval-local-transformer (chi (cddr b) r-cache288 (quote (()))))) (loop286 (cdr bs) er287 r-cache288)))) (loop286 (cdr bs) er-cache r-cache))))) (set-cdr! r256 (extend-env labels260 bindings (cdr r256))) (build-letrec (quote #f) vars261 (map (lambda (x289) (chi (cdr x289) (car x289) (quote (())))) vals) (build-sequence (quote #f) (map (lambda (x290) (chi (cdr x290) (car x290) (quote (())))) (cons (cons er (source-wrap e266 w267 s268)) (cdr body258)))))))))))))))))))))) (chi-macro (lambda (p291 e292 r293 w294 rib) (letrec ((rebuild-macro-output (lambda (x295 m) (cond ((pair? x295) (cons (rebuild-macro-output (car x295) m) (rebuild-macro-output (cdr x295) m))) ((syntax-object? x295) (let ((w296 (syntax-object-wrap x295))) (let ((ms (wrap-marks w296)) (s297 (wrap-subst w296))) (make-syntax-object (syntax-object-expression x295) (if (and (pair? ms) (eq? (car ms) (quote #f))) (make-wrap (cdr ms) (if rib (cons rib (cdr s297)) (cdr s297))) (make-wrap (cons m ms) (if rib (cons rib (cons (quote shift) s297)) (cons (quote shift) s297)))))))) ((vector? x295) (let ((n (vector-length x295))) (let ((v (make-vector n))) (let doloop ((i298 (quote 0))) (if (fx= i298 n) v (begin (vector-set! v i298 (rebuild-macro-output (vector-ref x295 i298) m)) (doloop (fx+ i298 (quote 1))))))))) ((symbol? x295) (syntax-error x295 (quote "encountered raw symbol in macro output"))) (else x295))))) (rebuild-macro-output (p291 (wrap e292 (anti-mark w294))) (string (quote #\m)))))) (chi-application (lambda (x299 e300 r301 w302 s303) ((lambda (tmp304) ((lambda (tmp305) (if tmp305 (apply (lambda (e0 e1306) (cons x299 (map (lambda (e307) (chi e307 r301 w302)) e1306))) tmp305) (syntax-error tmp304))) (syntax-dispatch tmp304 (quote (any . each-any))))) e300))) (chi-expr (lambda (type309 value310 e311 r312 w313 s314) (let ((t315 type309)) (if (memv t315 (quote (lexical))) value310 (if (memv t315 (quote (core))) (value310 e311 r312 w313 s314) (if (memv t315 (quote (lexical-call))) (chi-application value310 e311 r312 w313 s314) (if (memv t315 (quote (global-call))) (chi-application value310 e311 r312 w313 s314) (if (memv t315 (quote (constant))) (list (quote quote) (strip (source-wrap e311 w313 s314) (quote (())))) (if (memv t315 (quote (global))) value310 (if (memv t315 (quote (call))) (chi-application (chi (car e311) r312 w313) e311 r312 w313 s314) (if (memv t315 (quote (begin-form))) ((lambda (tmp316) ((lambda (tmp317) (if tmp317 (apply (lambda (_318 e1319 e2320) (chi-sequence (cons e1319 e2320) r312 w313 s314)) tmp317) (syntax-error tmp316))) (syntax-dispatch tmp316 (quote (any any . each-any))))) e311) (if (memv t315 (quote (local-syntax-form))) (chi-local-syntax value310 e311 r312 w313 s314 chi-sequence) (if (memv t315 (quote (eval-when-form))) ((lambda (tmp322) ((lambda (tmp323) (if tmp323 (apply (lambda (_324 x325 e1326 e2327) (let ((when-list (chi-when-list e311 x325 w313))) (if (memq (quote eval) when-list) (chi-sequence (cons e1326 e2327) r312 w313 s314) (chi-void)))) tmp323) (syntax-error tmp322))) (syntax-dispatch tmp322 (quote (any each-any any . each-any))))) e311) (if (memv t315 (quote (define-form define-syntax-form))) (syntax-error (wrap value310 w313) (quote "invalid context for definition of")) (if (memv t315 (quote (syntax))) (syntax-error (source-wrap e311 w313 s314) (quote "reference to pattern variable outside syntax form")) (if (memv t315 (quote (displaced-lexical))) (syntax-error (source-wrap e311 w313 s314) (quote "reference to identifier outside its scope")) (syntax-error (source-wrap e311 w313 s314)))))))))))))))))) (chi (lambda (e330 r331 w332) (call-with-values (lambda () (syntax-type e330 r331 w332 (quote #f) (quote #f))) (lambda (type333 value334 e335 w336 s337) (chi-expr type333 value334 e335 r331 w336 s337))))) (chi-top (lambda (e338 r339 w340 m341 esew) (call-with-values (lambda () (syntax-type e338 r339 w340 (quote #f) (quote #f))) (lambda (type348 value349 e350 w351 s352) (let ((t353 type348)) (if (memv t353 (quote (begin-form))) ((lambda (tmp354) ((lambda (tmp355) (if tmp355 (apply (lambda (_356) (chi-void)) tmp355) ((lambda (tmp357) (if tmp357 (apply (lambda (_358 e1359 e2360) (chi-top-sequence (cons e1359 e2360) r339 w351 s352 m341 esew)) tmp357) (syntax-error tmp354))) (syntax-dispatch tmp354 (quote (any any . each-any)))))) (syntax-dispatch tmp354 (quote (any))))) e350) (if (memv t353 (quote (local-syntax-form))) (chi-local-syntax value349 e350 r339 w351 s352 (lambda (body362 r363 w364 s365) (chi-top-sequence body362 r363 w364 s365 m341 esew))) (if (memv t353 (quote (eval-when-form))) ((lambda (tmp366) ((lambda (tmp367) (if tmp367 (apply (lambda (_368 x369 e1370 e2371) (let ((when-list372 (chi-when-list e350 x369 w351)) (body373 (cons e1370 e2371))) (cond ((eq? m341 (quote e)) (if (memq (quote eval) when-list372) (chi-top-sequence body373 r339 w351 s352 (quote e) (quote (eval))) (chi-void))) ((memq (quote load) when-list372) (if (or (memq (quote compile) when-list372) (and (eq? m341 (quote c&e)) (memq (quote eval) when-list372))) (chi-top-sequence body373 r339 w351 s352 (quote c&e) (quote (compile load))) (if (memq m341 (quote (c c&e))) (chi-top-sequence body373 r339 w351 s352 (quote c) (quote (load))) (chi-void)))) ((or (memq (quote compile) when-list372) (and (eq? m341 (quote c&e)) (memq (quote eval) when-list372))) (top-level-eval-hook (chi-top-sequence body373 r339 w351 s352 (quote e) (quote (eval)))) (chi-void)) (else (chi-void))))) tmp367) (syntax-error tmp366))) (syntax-dispatch tmp366 (quote (any each-any any . each-any))))) e350) (if (memv t353 (quote (define-syntax-form))) (let ((n376 (id-var-name value349 w351)) (r377 (macros-only-env r339))) (let ((t378 m341)) (if (memv t378 (quote (c))) (if (memq (quote compile) esew) (let ((e379 (chi-install-global n376 (chi e350 r377 w351)))) (begin (top-level-eval-hook e379) (if (memq (quote load) esew) e379 (chi-void)))) (if (memq (quote load) esew) (chi-install-global n376 (chi e350 r377 w351)) (chi-void))) (if (memv t378 (quote (c&e))) (let ((e380 (chi-install-global n376 (chi e350 r377 w351)))) (begin (top-level-eval-hook e380) e380)) (begin (if (memq (quote eval) esew) (top-level-eval-hook (chi-install-global n376 (chi e350 r377 w351)))) (chi-void)))))) (if (memv t353 (quote (define-form))) (let ((n381 (id-var-name value349 w351))) (let ((t382 (binding-type (lookup n381 r339)))) (if (memv t382 (quote (global))) (let ((x383 (list (quote define) n381 (chi e350 r339 w351)))) (begin (if (eq? m341 (quote c&e)) (top-level-eval-hook x383)) x383)) (if (memv t382 (quote (displaced-lexical))) (syntax-error (wrap value349 w351) (quote "identifier out of context")) (syntax-error (wrap value349 w351) (quote "cannot define keyword at top level")))))) (let ((x384 (chi-expr type348 value349 e350 r339 w351 s352))) (begin (if (eq? m341 (quote c&e)) (top-level-eval-hook x384)) x384)))))))))))) (syntax-type (lambda (e385 r386 w387 s388 rib389) (cond ((symbol? e385) (let ((n390 (id-var-name e385 w387))) (let ((b391 (lookup n390 r386))) (let ((type392 (binding-type b391))) (let ((t393 type392)) (if (memv t393 (quote (lexical))) (values type392 (binding-value b391) e385 w387 s388) (if (memv t393 (quote (global))) (values type392 n390 e385 w387 s388) (if (memv t393 (quote (macro))) (syntax-type (chi-macro (binding-value b391) e385 r386 w387 rib389) r386 (quote (())) s388 rib389) (values type392 (binding-value b391) e385 w387 s388))))))))) ((pair? e385) (let ((first (car e385))) (if (id? first) (let ((n394 (id-var-name first w387))) (let ((b395 (lookup n394 r386))) (let ((type396 (binding-type b395))) (let ((t397 type396)) (if (memv t397 (quote (lexical))) (values (quote lexical-call) (binding-value b395) e385 w387 s388) (if (memv t397 (quote (global))) (values (quote global-call) n394 e385 w387 s388) (if (memv t397 (quote (macro))) (syntax-type (chi-macro (binding-value b395) e385 r386 w387 rib389) r386 (quote (())) s388 rib389) (if (memv t397 (quote (core))) (values type396 (binding-value b395) e385 w387 s388) (if (memv t397 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value b395) e385 w387 s388) (if (memv t397 (quote (begin))) (values (quote begin-form) (quote #f) e385 w387 s388) (if (memv t397 (quote (eval-when))) (values (quote eval-when-form) (quote #f) e385 w387 s388) (if (memv t397 (quote (define))) ((lambda (tmp398) ((lambda (tmp399) (if (if tmp399 (apply (lambda (_400 name401 val402) (id? name401)) tmp399) (quote #f)) (apply (lambda (_403 name404 val405) (values (quote define-form) name404 val405 w387 s388)) tmp399) ((lambda (tmp406) (if (if tmp406 (apply (lambda (_407 name408 args409 e1410 e2411) (and (id? name408) (valid-bound-ids? (lambda-var-list args409)))) tmp406) (quote #f)) (apply (lambda (_412 name413 args414 e1415 e2416) (values (quote define-form) (wrap name413 w387) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) (wrap (cons args414 (cons e1415 e2416)) w387)) (quote (())) s388)) tmp406) ((lambda (tmp418) (if (if tmp418 (apply (lambda (_419 name420) (id? name420)) tmp418) (quote #f)) (apply (lambda (_421 name422) (values (quote define-form) (wrap name422 w387) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote (())) s388)) tmp418) (syntax-error tmp398))) (syntax-dispatch tmp398 (quote (any any)))))) (syntax-dispatch tmp398 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp398 (quote (any any any))))) e385) (if (memv t397 (quote (define-syntax))) ((lambda (tmp423) ((lambda (tmp424) (if (if tmp424 (apply (lambda (_425 name426 val427) (id? name426)) tmp424) (quote #f)) (apply (lambda (_428 name429 val430) (values (quote define-syntax-form) name429 val430 w387 s388)) tmp424) (syntax-error tmp423))) (syntax-dispatch tmp423 (quote (any any any))))) e385) (values (quote call) (quote #f) e385 w387 s388)))))))))))))) (values (quote call) (quote #f) e385 w387 s388)))) ((syntax-object? e385) (syntax-type (syntax-object-expression e385) r386 (join-wraps w387 (syntax-object-wrap e385)) (quote #f) rib389)) ((annotation? e385) (syntax-type (annotation-expression e385) r386 w387 (annotation-source e385) rib389)) ((let ((x431 e385)) (or (boolean? x431) (number? x431) (string? x431) (char? x431) (null? x431) (keyword? x431))) (values (quote constant) (quote #f) e385 w387 s388)) (else (values (quote other) (quote #f) e385 w387 s388))))) (chi-when-list (lambda (e432 when-list433 w434) (let f435 ((when-list436 when-list433) (situations (quote ()))) (if (null? when-list436) situations (f435 (cdr when-list436) (cons (let ((x437 (car when-list436))) (cond ((free-id=? x437 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote compile)) ((free-id=? x437 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote load)) ((free-id=? x437 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote eval)) (else (syntax-error (wrap x437 w434) (quote "invalid eval-when situation"))))) situations)))))) (chi-install-global (lambda (name438 e439) (list (quote install-global-transformer) (list (quote quote) name438) e439))) (chi-top-sequence (lambda (body440 r441 w442 s443 m444 esew445) (build-sequence s443 (let dobody ((body446 body440) (r447 r441) (w448 w442) (m449 m444) (esew450 esew445)) (if (null? body446) (quote ()) (let ((first451 (chi-top (car body446) r447 w448 m449 esew450))) (cons first451 (dobody (cdr body446) r447 w448 m449 esew450)))))))) (chi-sequence (lambda (body452 r453 w454 s455) (build-sequence s455 (let dobody456 ((body457 body452) (r458 r453) (w459 w454)) (if (null? body457) (quote ()) (let ((first460 (chi (car body457) r458 w459))) (cons first460 (dobody456 (cdr body457) r458 w459)))))))) (source-wrap (lambda (x461 w462 s463) (wrap (if s463 (make-annotation x461 s463 (quote #f)) x461) w462))) (wrap (lambda (x464 w465) (cond ((and (null? (wrap-marks w465)) (null? (wrap-subst w465))) x464) ((syntax-object? x464) (make-syntax-object (syntax-object-expression x464) (join-wraps w465 (syntax-object-wrap x464)))) ((null? x464) x464) (else (make-syntax-object x464 w465))))) (bound-id-member? (lambda (x466 list) (and (not (null? list)) (or (bound-id=? x466 (car list)) (bound-id-member? x466 (cdr list)))))) (distinct-bound-ids? (lambda (ids467) (let distinct? ((ids468 ids467)) (or (null? ids468) (and (not (bound-id-member? (car ids468) (cdr ids468))) (distinct? (cdr ids468))))))) (valid-bound-ids? (lambda (ids469) (and (let all-ids? ((ids470 ids469)) (or (null? ids470) (and (id? (car ids470)) (all-ids? (cdr ids470))))) (distinct-bound-ids? ids469)))) (bound-id=? (lambda (i471 j) (if (and (syntax-object? i471) (syntax-object? j)) (and (eq? (let ((e472 (syntax-object-expression i471))) (if (annotation? e472) (annotation-expression e472) e472)) (let ((e473 (syntax-object-expression j))) (if (annotation? e473) (annotation-expression e473) e473))) (same-marks? (wrap-marks (syntax-object-wrap i471)) (wrap-marks (syntax-object-wrap j)))) (eq? (let ((e474 i471)) (if (annotation? e474) (annotation-expression e474) e474)) (let ((e475 j)) (if (annotation? e475) (annotation-expression e475) e475)))))) (free-id=? (lambda (i476 j477) (and (eq? (let ((x478 i476)) (let ((e479 (if (syntax-object? x478) (syntax-object-expression x478) x478))) (if (annotation? e479) (annotation-expression e479) e479))) (let ((x480 j477)) (let ((e481 (if (syntax-object? x480) (syntax-object-expression x480) x480))) (if (annotation? e481) (annotation-expression e481) e481)))) (eq? (id-var-name i476 (quote (()))) (id-var-name j477 (quote (()))))))) (id-var-name (lambda (id482 w483) (letrec ((search-vector-rib (lambda (sym subst marks489 symnames ribcage490) (let ((n491 (vector-length symnames))) (let f492 ((i493 (quote 0))) (cond ((fx= i493 n491) (search sym (cdr subst) marks489)) ((and (eq? (vector-ref symnames i493) sym) (same-marks? marks489 (vector-ref (ribcage-marks ribcage490) i493))) (values (vector-ref (ribcage-labels ribcage490) i493) marks489)) (else (f492 (fx+ i493 (quote 1))))))))) (search-list-rib (lambda (sym494 subst495 marks496 symnames497 ribcage498) (let f499 ((symnames500 symnames497) (i501 (quote 0))) (cond ((null? symnames500) (search sym494 (cdr subst495) marks496)) ((and (eq? (car symnames500) sym494) (same-marks? marks496 (list-ref (ribcage-marks ribcage498) i501))) (values (list-ref (ribcage-labels ribcage498) i501) marks496)) (else (f499 (cdr symnames500) (fx+ i501 (quote 1)))))))) (search (lambda (sym502 subst503 marks504) (if (null? subst503) (values (quote #f) marks504) (let ((fst (car subst503))) (if (eq? fst (quote shift)) (search sym502 (cdr subst503) (cdr marks504)) (let ((symnames505 (ribcage-symnames fst))) (if (vector? symnames505) (search-vector-rib sym502 subst503 marks504 symnames505 fst) (search-list-rib sym502 subst503 marks504 symnames505 fst))))))))) (cond ((symbol? id482) (or (call-with-values (lambda () (search id482 (wrap-subst w483) (wrap-marks w483))) (lambda (x506 . ignore) x506)) id482)) ((syntax-object? id482) (let ((id507 (let ((e508 (syntax-object-expression id482))) (if (annotation? e508) (annotation-expression e508) e508))) (w1 (syntax-object-wrap id482))) (let ((marks509 (join-marks (wrap-marks w483) (wrap-marks w1)))) (call-with-values (lambda () (search id507 (wrap-subst w483) marks509)) (lambda (new-id marks510) (or new-id (call-with-values (lambda () (search id507 (wrap-subst w1) marks510)) (lambda (x512 . ignore511) x512)) id507)))))) ((annotation? id482) (let ((id513 (let ((e514 id482)) (if (annotation? e514) (annotation-expression e514) e514)))) (or (call-with-values (lambda () (search id513 (wrap-subst w483) (wrap-marks w483))) (lambda (x516 . ignore515) x516)) id513))) (else (error-hook (quote id-var-name) (quote "invalid id") id482)))))) (same-marks? (lambda (x517 y) (or (eq? x517 y) (and (not (null? x517)) (not (null? y)) (eq? (car x517) (car y)) (same-marks? (cdr x517) (cdr y)))))) (join-marks (lambda (m1 m2) (smart-append m1 m2))) (join-wraps (lambda (w1518 w2) (let ((m1519 (wrap-marks w1518)) (s1 (wrap-subst w1518))) (if (null? m1519) (if (null? s1) w2 (make-wrap (wrap-marks w2) (smart-append s1 (wrap-subst w2)))) (make-wrap (smart-append m1519 (wrap-marks w2)) (smart-append s1 (wrap-subst w2))))))) (smart-append (lambda (m1520 m2521) (if (null? m2521) m1520 (append m1520 m2521)))) (make-binding-wrap (lambda (ids522 labels523 w524) (if (null? ids522) w524 (make-wrap (wrap-marks w524) (cons (let ((labelvec (list->vector labels523))) (let ((n525 (vector-length labelvec))) (let ((symnamevec (make-vector n525)) (marksvec (make-vector n525))) (begin (let f526 ((ids527 ids522) (i528 (quote 0))) (if (not (null? ids527)) (call-with-values (lambda () (id-sym-name&marks (car ids527) w524)) (lambda (symname marks529) (begin (vector-set! symnamevec i528 symname) (vector-set! marksvec i528 marks529) (f526 (cdr ids527) (fx+ i528 (quote 1)))))))) (make-ribcage symnamevec marksvec labelvec))))) (wrap-subst w524)))))) (extend-ribcage! (lambda (ribcage530 id531 label532) (begin (set-ribcage-symnames! ribcage530 (cons (let ((e533 (syntax-object-expression id531))) (if (annotation? e533) (annotation-expression e533) e533)) (ribcage-symnames ribcage530))) (set-ribcage-marks! ribcage530 (cons (wrap-marks (syntax-object-wrap id531)) (ribcage-marks ribcage530))) (set-ribcage-labels! ribcage530 (cons label532 (ribcage-labels ribcage530)))))) (anti-mark (lambda (w534) (make-wrap (cons (quote #f) (wrap-marks w534)) (cons (quote shift) (wrap-subst w534))))) (set-ribcage-labels! (lambda (x535 update) (vector-set! x535 (quote 3) update))) (set-ribcage-marks! (lambda (x536 update537) (vector-set! x536 (quote 2) update537))) (set-ribcage-symnames! (lambda (x538 update539) (vector-set! x538 (quote 1) update539))) (ribcage-labels (lambda (x540) (vector-ref x540 (quote 3)))) (ribcage-marks (lambda (x541) (vector-ref x541 (quote 2)))) (ribcage-symnames (lambda (x542) (vector-ref x542 (quote 1)))) (ribcage? (lambda (x543) (and (vector? x543) (= (vector-length x543) (quote 4)) (eq? (vector-ref x543 (quote 0)) (quote ribcage))))) (make-ribcage (lambda (symnames544 marks545 labels546) (vector (quote ribcage) symnames544 marks545 labels546))) (gen-labels (lambda (ls547) (if (null? ls547) (quote ()) (cons (gen-label) (gen-labels (cdr ls547)))))) (gen-label (lambda () (string (quote #\i)))) (wrap-subst cdr) (wrap-marks car) (make-wrap cons) (id-sym-name&marks (lambda (x548 w549) (if (syntax-object? x548) (values (let ((e550 (syntax-object-expression x548))) (if (annotation? e550) (annotation-expression e550) e550)) (join-marks (wrap-marks w549) (wrap-marks (syntax-object-wrap x548)))) (values (let ((e551 x548)) (if (annotation? e551) (annotation-expression e551) e551)) (wrap-marks w549))))) (id? (lambda (x552) (cond ((symbol? x552) (quote #t)) ((syntax-object? x552) (symbol? (let ((e553 (syntax-object-expression x552))) (if (annotation? e553) (annotation-expression e553) e553)))) ((annotation? x552) (symbol? (annotation-expression x552))) (else (quote #f))))) (nonsymbol-id? (lambda (x554) (and (syntax-object? x554) (symbol? (let ((e555 (syntax-object-expression x554))) (if (annotation? e555) (annotation-expression e555) e555)))))) (global-extend (lambda (type556 sym557 val558) (put-global-definition-hook sym557 (cons type556 val558)))) (lookup (lambda (x559 r560) (cond ((assq x559 r560) => cdr) ((symbol? x559) (or (get-global-definition-hook x559) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env (lambda (r561) (if (null? r561) (quote ()) (let ((a562 (car r561))) (if (eq? (cadr a562) (quote macro)) (cons a562 (macros-only-env (cdr r561))) (macros-only-env (cdr r561))))))) (extend-var-env (lambda (labels563 vars564 r565) (if (null? labels563) r565 (extend-var-env (cdr labels563) (cdr vars564) (cons (cons (car labels563) (cons (quote lexical) (car vars564))) r565))))) (extend-env (lambda (labels566 bindings567 r568) (if (null? labels566) r568 (extend-env (cdr labels566) (cdr bindings567) (cons (cons (car labels566) (car bindings567)) r568))))) (binding-value cdr) (binding-type car) (source-annotation (lambda (x569) (cond ((annotation? x569) (annotation-source x569)) ((syntax-object? x569) (source-annotation (syntax-object-expression x569))) (else (quote #f))))) (set-syntax-object-wrap! (lambda (x570 update571) (vector-set! x570 (quote 2) update571))) (set-syntax-object-expression! (lambda (x572 update573) (vector-set! x572 (quote 1) update573))) (syntax-object-wrap (lambda (x574) (vector-ref x574 (quote 2)))) (syntax-object-expression (lambda (x575) (vector-ref x575 (quote 1)))) (syntax-object? (lambda (x576) (and (vector? x576) (= (vector-length x576) (quote 3)) (eq? (vector-ref x576 (quote 0)) (quote syntax-object))))) (make-syntax-object (lambda (expression wrap577) (vector (quote syntax-object) expression wrap577))) (build-letrec (lambda (src578 vars579 val-exps body-exp) (if (null? vars579) body-exp (list (quote letrec) (map list vars579 val-exps) body-exp)))) (build-named-let (lambda (src580 vars581 val-exps582 body-exp583) (if (null? vars581) body-exp583 (list (quote let) (car vars581) (map list (cdr vars581) val-exps582) body-exp583)))) (build-let (lambda (src584 vars585 val-exps586 body-exp587) (if (null? vars585) body-exp587 (list (quote let) (map list vars585 val-exps586) body-exp587)))) (build-sequence (lambda (src588 exps) (if (null? (cdr exps)) (car exps) (cons (quote begin) exps)))) (get-global-definition-hook (lambda (symbol) (getprop symbol (quote *sc-expander*)))) (put-global-definition-hook (lambda (symbol589 binding) (putprop symbol589 (quote *sc-expander*) binding))) (error-hook (lambda (who590 why what) (error who590 (quote "~a ~s") why what))) (local-eval-hook (lambda (x591) (eval (list noexpand x591) (interaction-environment)))) (top-level-eval-hook (lambda (x592) (eval (list noexpand x592) (interaction-environment)))) (annotation? (lambda (x593) (quote #f))) (fx< <) (fx= =) (fx- -) (fx+ +) (noexpand (quote "noexpand"))) (begin (global-extend (quote local-syntax) (quote letrec-syntax) (quote #t)) (global-extend (quote local-syntax) (quote let-syntax) (quote #f)) (global-extend (quote core) (quote fluid-let-syntax) (lambda (e594 r595 w596 s597) ((lambda (tmp598) ((lambda (tmp599) (if (if tmp599 (apply (lambda (_600 var601 val602 e1603 e2604) (valid-bound-ids? var601)) tmp599) (quote #f)) (apply (lambda (_606 var607 val608 e1609 e2610) (let ((names (map (lambda (x611) (id-var-name x611 w596)) var607))) (begin (for-each (lambda (id613 n614) (let ((t615 (binding-type (lookup n614 r595)))) (if (memv t615 (quote (displaced-lexical))) (syntax-error (source-wrap id613 w596 s597) (quote "identifier out of context"))))) var607 names) (chi-body (cons e1609 e2610) (source-wrap e594 w596 s597) (extend-env names (let ((trans-r618 (macros-only-env r595))) (map (lambda (x619) (cons (quote macro) (eval-local-transformer (chi x619 trans-r618 w596)))) val608)) r595) w596)))) tmp599) ((lambda (_621) (syntax-error (source-wrap e594 w596 s597))) tmp598))) (syntax-dispatch tmp598 (quote (any #(each (any any)) any . each-any))))) e594))) (global-extend (quote core) (quote quote) (lambda (e622 r623 w624 s625) ((lambda (tmp626) ((lambda (tmp627) (if tmp627 (apply (lambda (_628 e629) (list (quote quote) (strip e629 w624))) tmp627) ((lambda (_630) (syntax-error (source-wrap e622 w624 s625))) tmp626))) (syntax-dispatch tmp626 (quote (any any))))) e622))) (global-extend (quote core) (quote syntax) (letrec ((regen (lambda (x631) (let ((t632 (car x631))) (if (memv t632 (quote (ref))) (cadr x631) (if (memv t632 (quote (primitive))) (cadr x631) (if (memv t632 (quote (quote))) (list (quote quote) (cadr x631)) (if (memv t632 (quote (lambda))) (list (quote lambda) (cadr x631) (regen (caddr x631))) (if (memv t632 (quote (map))) (let ((ls633 (map regen (cdr x631)))) (cons (if (fx= (length ls633) (quote 2)) (quote map) (quote map)) ls633)) (cons (car x631) (map regen (cdr x631))))))))))) (gen-vector (lambda (x634) (cond ((eq? (car x634) (quote list)) (cons (quote vector) (cdr x634))) ((eq? (car x634) (quote quote)) (list (quote quote) (list->vector (cadr x634)))) (else (list (quote list->vector) x634))))) (gen-append (lambda (x635 y636) (if (equal? y636 (quote (quote ()))) x635 (list (quote append) x635 y636)))) (gen-cons (lambda (x637 y638) (let ((t639 (car y638))) (if (memv t639 (quote (quote))) (if (eq? (car x637) (quote quote)) (list (quote quote) (cons (cadr x637) (cadr y638))) (if (eq? (cadr y638) (quote ())) (list (quote list) x637) (list (quote cons) x637 y638))) (if (memv t639 (quote (list))) (cons (quote list) (cons x637 (cdr y638))) (list (quote cons) x637 y638)))))) (gen-map (lambda (e640 map-env) (let ((formals (map cdr map-env)) (actuals (map (lambda (x641) (list (quote ref) (car x641))) map-env))) (cond ((eq? (car e640) (quote ref)) (car actuals)) ((andmap (lambda (x642) (and (eq? (car x642) (quote ref)) (memq (cadr x642) formals))) (cdr e640)) (cons (quote map) (cons (list (quote primitive) (car e640)) (map (let ((r643 (map cons formals actuals))) (lambda (x644) (cdr (assq (cadr x644) r643)))) (cdr e640))))) (else (cons (quote map) (cons (list (quote lambda) formals e640) actuals))))))) (gen-mappend (lambda (e645 map-env646) (list (quote apply) (quote (primitive append)) (gen-map e645 map-env646)))) (gen-ref (lambda (src647 var648 level649 maps) (if (fx= level649 (quote 0)) (values var648 maps) (if (null? maps) (syntax-error src647 (quote "missing ellipsis in syntax form")) (call-with-values (lambda () (gen-ref src647 var648 (fx- level649 (quote 1)) (cdr maps))) (lambda (outer-var outer-maps) (let ((b650 (assq outer-var (car maps)))) (if b650 (values (cdr b650) maps) (let ((inner-var (gen-var (quote tmp)))) (values inner-var (cons (cons (cons outer-var inner-var) (car maps)) outer-maps))))))))))) (gen-syntax (lambda (src651 e652 r653 maps654 ellipsis?655) (if (id? e652) (let ((label656 (id-var-name e652 (quote (()))))) (let ((b657 (lookup label656 r653))) (if (eq? (binding-type b657) (quote syntax)) (call-with-values (lambda () (let ((var.lev (binding-value b657))) (gen-ref src651 (car var.lev) (cdr var.lev) maps654))) (lambda (var658 maps659) (values (list (quote ref) var658) maps659))) (if (ellipsis?655 e652) (syntax-error src651 (quote "misplaced ellipsis in syntax form")) (values (list (quote quote) e652) maps654))))) ((lambda (tmp660) ((lambda (tmp661) (if (if tmp661 (apply (lambda (dots e662) (ellipsis?655 dots)) tmp661) (quote #f)) (apply (lambda (dots663 e664) (gen-syntax src651 e664 r653 maps654 (lambda (x665) (quote #f)))) tmp661) ((lambda (tmp666) (if (if tmp666 (apply (lambda (x667 dots668 y669) (ellipsis?655 dots668)) tmp666) (quote #f)) (apply (lambda (x670 dots671 y672) (let f673 ((y674 y672) (k675 (lambda (maps676) (call-with-values (lambda () (gen-syntax src651 x670 r653 (cons (quote ()) maps676) ellipsis?655)) (lambda (x677 maps678) (if (null? (car maps678)) (syntax-error src651 (quote "extra ellipsis in syntax form")) (values (gen-map x677 (car maps678)) (cdr maps678)))))))) ((lambda (tmp679) ((lambda (tmp680) (if (if tmp680 (apply (lambda (dots681 y682) (ellipsis?655 dots681)) tmp680) (quote #f)) (apply (lambda (dots683 y684) (f673 y684 (lambda (maps685) (call-with-values (lambda () (k675 (cons (quote ()) maps685))) (lambda (x686 maps687) (if (null? (car maps687)) (syntax-error src651 (quote "extra ellipsis in syntax form")) (values (gen-mappend x686 (car maps687)) (cdr maps687)))))))) tmp680) ((lambda (_688) (call-with-values (lambda () (gen-syntax src651 y674 r653 maps654 ellipsis?655)) (lambda (y689 maps690) (call-with-values (lambda () (k675 maps690)) (lambda (x691 maps692) (values (gen-append x691 y689) maps692)))))) tmp679))) (syntax-dispatch tmp679 (quote (any . any))))) y674))) tmp666) ((lambda (tmp693) (if tmp693 (apply (lambda (x694 y695) (call-with-values (lambda () (gen-syntax src651 x694 r653 maps654 ellipsis?655)) (lambda (x696 maps697) (call-with-values (lambda () (gen-syntax src651 y695 r653 maps697 ellipsis?655)) (lambda (y698 maps699) (values (gen-cons x696 y698) maps699)))))) tmp693) ((lambda (tmp700) (if tmp700 (apply (lambda (e1701 e2702) (call-with-values (lambda () (gen-syntax src651 (cons e1701 e2702) r653 maps654 ellipsis?655)) (lambda (e704 maps705) (values (gen-vector e704) maps705)))) tmp700) ((lambda (_706) (values (list (quote quote) e652) maps654)) tmp660))) (syntax-dispatch tmp660 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp660 (quote (any . any)))))) (syntax-dispatch tmp660 (quote (any any . any)))))) (syntax-dispatch tmp660 (quote (any any))))) e652))))) (lambda (e707 r708 w709 s710) (let ((e711 (source-wrap e707 w709 s710))) ((lambda (tmp712) ((lambda (tmp713) (if tmp713 (apply (lambda (_714 x715) (call-with-values (lambda () (gen-syntax e711 x715 r708 (quote ()) ellipsis?)) (lambda (e716 maps717) (regen e716)))) tmp713) ((lambda (_718) (syntax-error e711)) tmp712))) (syntax-dispatch tmp712 (quote (any any))))) e711))))) (global-extend (quote core) (quote lambda) (lambda (e719 r720 w721 s722) ((lambda (tmp723) ((lambda (tmp724) (if tmp724 (apply (lambda (_725 c726) (chi-lambda-clause (source-wrap e719 w721 s722) c726 r720 w721 (lambda (vars727 body728) (list (quote lambda) vars727 body728)))) tmp724) (syntax-error tmp723))) (syntax-dispatch tmp723 (quote (any . any))))) e719))) (global-extend (quote core) (quote let) (letrec ((chi-let (lambda (e729 r730 w731 s732 constructor733 ids734 vals735 exps736) (if (not (valid-bound-ids? ids734)) (syntax-error e729 (quote "duplicate bound variable in")) (let ((labels737 (gen-labels ids734)) (new-vars738 (map gen-var ids734))) (let ((nw (make-binding-wrap ids734 labels737 w731)) (nr (extend-var-env labels737 new-vars738 r730))) (constructor733 s732 new-vars738 (map (lambda (x739) (chi x739 r730 w731)) vals735) (chi-body exps736 (source-wrap e729 nw s732) nr nw)))))))) (lambda (e740 r741 w742 s743) ((lambda (tmp744) ((lambda (tmp745) (if tmp745 (apply (lambda (_746 id747 val748 e1749 e2750) (chi-let e740 r741 w742 s743 build-let id747 val748 (cons e1749 e2750))) tmp745) ((lambda (tmp754) (if (if tmp754 (apply (lambda (_755 f756 id757 val758 e1759 e2760) (id? f756)) tmp754) (quote #f)) (apply (lambda (_761 f762 id763 val764 e1765 e2766) (chi-let e740 r741 w742 s743 build-named-let (cons f762 id763) val764 (cons e1765 e2766))) tmp754) ((lambda (_770) (syntax-error (source-wrap e740 w742 s743))) tmp744))) (syntax-dispatch tmp744 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp744 (quote (any #(each (any any)) any . each-any))))) e740)))) (global-extend (quote core) (quote letrec) (lambda (e771 r772 w773 s774) ((lambda (tmp775) ((lambda (tmp776) (if tmp776 (apply (lambda (_777 id778 val779 e1780 e2781) (let ((ids782 id778)) (if (not (valid-bound-ids? ids782)) (syntax-error e771 (quote "duplicate bound variable in")) (let ((labels784 (gen-labels ids782)) (new-vars785 (map gen-var ids782))) (let ((w786 (make-binding-wrap ids782 labels784 w773)) (r787 (extend-var-env labels784 new-vars785 r772))) (build-letrec s774 new-vars785 (map (lambda (x788) (chi x788 r787 w786)) val779) (chi-body (cons e1780 e2781) (source-wrap e771 w786 s774) r787 w786))))))) tmp776) ((lambda (_791) (syntax-error (source-wrap e771 w773 s774))) tmp775))) (syntax-dispatch tmp775 (quote (any #(each (any any)) any . each-any))))) e771))) (global-extend (quote core) (quote set!) (lambda (e792 r793 w794 s795) ((lambda (tmp796) ((lambda (tmp797) (if (if tmp797 (apply (lambda (_798 id799 val800) (id? id799)) tmp797) (quote #f)) (apply (lambda (_801 id802 val803) (let ((val804 (chi val803 r793 w794)) (n805 (id-var-name id802 w794))) (let ((b806 (lookup n805 r793))) (let ((t807 (binding-type b806))) (if (memv t807 (quote (lexical))) (list (quote set!) (binding-value b806) val804) (if (memv t807 (quote (global))) (list (quote set!) n805 val804) (if (memv t807 (quote (displaced-lexical))) (syntax-error (wrap id802 w794) (quote "identifier out of context")) (syntax-error (source-wrap e792 w794 s795))))))))) tmp797) ((lambda (tmp808) (if tmp808 (apply (lambda (_809 getter arg val810) (cons (chi (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) getter) r793 w794) (map (lambda (e811) (chi e811 r793 w794)) (append arg (list val810))))) tmp808) ((lambda (_813) (syntax-error (source-wrap e792 w794 s795))) tmp796))) (syntax-dispatch tmp796 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp796 (quote (any any any))))) e792))) (global-extend (quote begin) (quote begin) (quote ())) (global-extend (quote define) (quote define) (quote ())) (global-extend (quote define-syntax) (quote define-syntax) (quote ())) (global-extend (quote eval-when) (quote eval-when) (quote ())) (global-extend (quote core) (quote syntax-case) (letrec ((gen-syntax-case (lambda (x814 keys clauses r815) (if (null? clauses) (list (quote syntax-error) x814) ((lambda (tmp816) ((lambda (tmp817) (if tmp817 (apply (lambda (pat exp818) (if (and (id? pat) (andmap (lambda (x819) (not (free-id=? pat x819))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) keys))) (let ((labels820 (list (gen-label))) (var821 (gen-var pat))) (list (list (quote lambda) (list var821) (chi exp818 (extend-env labels820 (list (cons (quote syntax) (cons var821 (quote 0)))) r815) (make-binding-wrap (list pat) labels820 (quote (()))))) x814)) (gen-clause x814 keys (cdr clauses) r815 pat (quote #t) exp818))) tmp817) ((lambda (tmp822) (if tmp822 (apply (lambda (pat823 fender exp824) (gen-clause x814 keys (cdr clauses) r815 pat823 fender exp824)) tmp822) ((lambda (_825) (syntax-error (car clauses) (quote "invalid syntax-case clause"))) tmp816))) (syntax-dispatch tmp816 (quote (any any any)))))) (syntax-dispatch tmp816 (quote (any any))))) (car clauses))))) (gen-clause (lambda (x826 keys827 clauses828 r829 pat830 fender831 exp832) (call-with-values (lambda () (convert-pattern pat830 keys827)) (lambda (p833 pvars) (cond ((not (distinct-bound-ids? (map car pvars))) (syntax-error pat830 (quote "duplicate pattern variable in syntax-case pattern"))) ((not (andmap (lambda (x834) (not (ellipsis? (car x834)))) pvars)) (syntax-error pat830 (quote "misplaced ellipsis in syntax-case pattern"))) (else (let ((y835 (gen-var (quote tmp)))) (list (list (quote lambda) (list y835) (let ((y836 y835)) (list (quote if) ((lambda (tmp837) ((lambda (tmp838) (if tmp838 (apply (lambda () y836) tmp838) ((lambda (_839) (list (quote if) y836 (build-dispatch-call pvars fender831 y836 r829) (list (quote quote) (quote #f)))) tmp837))) (syntax-dispatch tmp837 (quote #(atom #t))))) fender831) (build-dispatch-call pvars exp832 y836 r829) (gen-syntax-case x826 keys827 clauses828 r829)))) (if (eq? p833 (quote any)) (list (quote list) x826) (list (quote syntax-dispatch) x826 (list (quote quote) p833))))))))))) (build-dispatch-call (lambda (pvars840 exp841 y842 r843) (let ((ids844 (map car pvars840)) (levels (map cdr pvars840))) (let ((labels845 (gen-labels ids844)) (new-vars846 (map gen-var ids844))) (list (quote apply) (list (quote lambda) new-vars846 (chi exp841 (extend-env labels845 (map (lambda (var847 level848) (cons (quote syntax) (cons var847 level848))) new-vars846 (map cdr pvars840)) r843) (make-binding-wrap ids844 labels845 (quote (()))))) y842))))) (convert-pattern (lambda (pattern keys849) (let cvt ((p850 pattern) (n851 (quote 0)) (ids852 (quote ()))) (if (id? p850) (if (bound-id-member? p850 keys849) (values (vector (quote free-id) p850) ids852) (values (quote any) (cons (cons p850 n851) ids852))) ((lambda (tmp853) ((lambda (tmp854) (if (if tmp854 (apply (lambda (x855 dots856) (ellipsis? dots856)) tmp854) (quote #f)) (apply (lambda (x857 dots858) (call-with-values (lambda () (cvt x857 (fx+ n851 (quote 1)) ids852)) (lambda (p859 ids860) (values (if (eq? p859 (quote any)) (quote each-any) (vector (quote each) p859)) ids860)))) tmp854) ((lambda (tmp861) (if tmp861 (apply (lambda (x862 y863) (call-with-values (lambda () (cvt y863 n851 ids852)) (lambda (y864 ids865) (call-with-values (lambda () (cvt x862 n851 ids865)) (lambda (x866 ids867) (values (cons x866 y864) ids867)))))) tmp861) ((lambda (tmp868) (if tmp868 (apply (lambda () (values (quote ()) ids852)) tmp868) ((lambda (tmp869) (if tmp869 (apply (lambda (x870) (call-with-values (lambda () (cvt x870 n851 ids852)) (lambda (p872 ids873) (values (vector (quote vector) p872) ids873)))) tmp869) ((lambda (x874) (values (vector (quote atom) (strip p850 (quote (())))) ids852)) tmp853))) (syntax-dispatch tmp853 (quote #(vector each-any)))))) (syntax-dispatch tmp853 (quote ()))))) (syntax-dispatch tmp853 (quote (any . any)))))) (syntax-dispatch tmp853 (quote (any any))))) p850)))))) (lambda (e875 r876 w877 s878) (let ((e879 (source-wrap e875 w877 s878))) ((lambda (tmp880) ((lambda (tmp881) (if tmp881 (apply (lambda (_882 val883 key m884) (if (andmap (lambda (x885) (and (id? x885) (not (ellipsis? x885)))) key) (let ((x887 (gen-var (quote tmp)))) (list (list (quote lambda) (list x887) (gen-syntax-case x887 key m884 r876)) (chi val883 r876 (quote (()))))) (syntax-error e879 (quote "invalid literals list in")))) tmp881) (syntax-error tmp880))) (syntax-dispatch tmp880 (quote (any any each-any . each-any))))) e879))))) (set! sc-expand (let ((m890 (quote e)) (esew891 (quote (eval)))) (lambda (x892) (if (and (pair? x892) (equal? (car x892) noexpand)) (cadr x892) (chi-top x892 (quote ()) (quote ((top))) m890 esew891))))) (set! sc-expand3 (let ((m893 (quote e)) (esew894 (quote (eval)))) (lambda (x895 . rest) (if (and (pair? x895) (equal? (car x895) noexpand)) (cadr x895) (chi-top x895 (quote ()) (quote ((top))) (if (null? rest) m893 (car rest)) (if (or (null? rest) (null? (cdr rest))) esew894 (cadr rest))))))) (set! identifier? (lambda (x896) (nonsymbol-id? x896))) (set! datum->syntax-object (lambda (id897 datum) (begin (let ((x898 id897)) (if (not (nonsymbol-id? x898)) (error-hook (quote datum->syntax-object) (quote "invalid argument") x898))) (make-syntax-object datum (syntax-object-wrap id897))))) (set! syntax-object->datum (lambda (x899) (strip x899 (quote (()))))) (set! generate-temporaries (lambda (ls900) (begin (let ((x901 ls900)) (if (not (list? x901)) (error-hook (quote generate-temporaries) (quote "invalid argument") x901))) (map (lambda (x902) (wrap (gensym) (quote ((top))))) ls900)))) (set! free-identifier=? (lambda (x903 y904) (begin (let ((x905 x903)) (if (not (nonsymbol-id? x905)) (error-hook (quote free-identifier=?) (quote "invalid argument") x905))) (let ((x906 y904)) (if (not (nonsymbol-id? x906)) (error-hook (quote free-identifier=?) (quote "invalid argument") x906))) (free-id=? x903 y904)))) (set! bound-identifier=? (lambda (x907 y908) (begin (let ((x909 x907)) (if (not (nonsymbol-id? x909)) (error-hook (quote bound-identifier=?) (quote "invalid argument") x909))) (let ((x910 y908)) (if (not (nonsymbol-id? x910)) (error-hook (quote bound-identifier=?) (quote "invalid argument") x910))) (bound-id=? x907 y908)))) (set! syntax-error (lambda (object . messages) (begin (for-each (lambda (x911) (let ((x912 x911)) (if (not (string? x912)) (error-hook (quote syntax-error) (quote "invalid argument") x912)))) messages) (let ((message (if (null? messages) (quote "invalid syntax") (apply string-append messages)))) (error-hook (quote #f) message (strip object (quote (())))))))) (set! install-global-transformer (lambda (sym913 v914) (begin (let ((x915 sym913)) (if (not (symbol? x915)) (error-hook (quote define-syntax) (quote "invalid argument") x915))) (let ((x916 v914)) (if (not (procedure? x916)) (error-hook (quote define-syntax) (quote "invalid argument") x916))) (global-extend (quote macro) sym913 v914)))) (letrec ((match (lambda (e917 p918 w919 r920) (cond ((not r920) (quote #f)) ((eq? p918 (quote any)) (cons (wrap e917 w919) r920)) ((syntax-object? e917) (match* (let ((e921 (syntax-object-expression e917))) (if (annotation? e921) (annotation-expression e921) e921)) p918 (join-wraps w919 (syntax-object-wrap e917)) r920)) (else (match* (let ((e922 e917)) (if (annotation? e922) (annotation-expression e922) e922)) p918 w919 r920))))) (match* (lambda (e923 p924 w925 r926) (cond ((null? p924) (and (null? e923) r926)) ((pair? p924) (and (pair? e923) (match (car e923) (car p924) w925 (match (cdr e923) (cdr p924) w925 r926)))) ((eq? p924 (quote each-any)) (let ((l (match-each-any e923 w925))) (and l (cons l r926)))) (else (let ((t927 (vector-ref p924 (quote 0)))) (if (memv t927 (quote (each))) (if (null? e923) (match-empty (vector-ref p924 (quote 1)) r926) (let ((l928 (match-each e923 (vector-ref p924 (quote 1)) w925))) (and l928 (let collect ((l929 l928)) (if (null? (car l929)) r926 (cons (map car l929) (collect (map cdr l929)))))))) (if (memv t927 (quote (free-id))) (and (id? e923) (free-id=? (wrap e923 w925) (vector-ref p924 (quote 1))) r926) (if (memv t927 (quote (atom))) (and (equal? (vector-ref p924 (quote 1)) (strip e923 w925)) r926) (if (memv t927 (quote (vector))) (and (vector? e923) (match (vector->list e923) (vector-ref p924 (quote 1)) w925 r926))))))))))) (match-empty (lambda (p930 r931) (cond ((null? p930) r931) ((eq? p930 (quote any)) (cons (quote ()) r931)) ((pair? p930) (match-empty (car p930) (match-empty (cdr p930) r931))) ((eq? p930 (quote each-any)) (cons (quote ()) r931)) (else (let ((t932 (vector-ref p930 (quote 0)))) (if (memv t932 (quote (each))) (match-empty (vector-ref p930 (quote 1)) r931) (if (memv t932 (quote (free-id atom))) r931 (if (memv t932 (quote (vector))) (match-empty (vector-ref p930 (quote 1)) r931))))))))) (match-each-any (lambda (e933 w934) (cond ((annotation? e933) (match-each-any (annotation-expression e933) w934)) ((pair? e933) (let ((l935 (match-each-any (cdr e933) w934))) (and l935 (cons (wrap (car e933) w934) l935)))) ((null? e933) (quote ())) ((syntax-object? e933) (match-each-any (syntax-object-expression e933) (join-wraps w934 (syntax-object-wrap e933)))) (else (quote #f))))) (match-each (lambda (e936 p937 w938) (cond ((annotation? e936) (match-each (annotation-expression e936) p937 w938)) ((pair? e936) (let ((first939 (match (car e936) p937 w938 (quote ())))) (and first939 (let ((rest940 (match-each (cdr e936) p937 w938))) (and rest940 (cons first939 rest940)))))) ((null? e936) (quote ())) ((syntax-object? e936) (match-each (syntax-object-expression e936) p937 (join-wraps w938 (syntax-object-wrap e936)))) (else (quote #f)))))) (set! syntax-dispatch (lambda (e941 p942) (cond ((eq? p942 (quote any)) (list e941)) ((syntax-object? e941) (match* (let ((e943 (syntax-object-expression e941))) (if (annotation? e943) (annotation-expression e943) e943)) p942 (syntax-object-wrap e941) (quote ()))) (else (match* (let ((e944 e941)) (if (annotation? e944) (annotation-expression e944) e944)) p942 (quote (())) (quote ()))))))))) -(install-global-transformer (quote with-syntax) (lambda (x945) ((lambda (tmp946) ((lambda (tmp947) (if tmp947 (apply (lambda (_948 e1949 e2950) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e1949 e2950))) tmp947) ((lambda (tmp952) (if tmp952 (apply (lambda (_953 out in e1954 e2955) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) in (quote ()) (list out (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e1954 e2955))))) tmp952) ((lambda (tmp957) (if tmp957 (apply (lambda (_958 out959 in960 e1961 e2962) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) in960) (quote ()) (list out959 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e1961 e2962))))) tmp957) (syntax-error tmp946))) (syntax-dispatch tmp946 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp946 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp946 (quote (any () any . each-any))))) x945))) -(install-global-transformer (quote syntax-rules) (lambda (x966) ((lambda (tmp967) ((lambda (tmp968) (if tmp968 (apply (lambda (_969 k970 keyword pattern971 template) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons k970 (map (lambda (tmp973 tmp972) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) tmp972) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) tmp973))) template pattern971)))))) tmp968) (syntax-error tmp967))) (syntax-dispatch tmp967 (quote (any each-any . #(each ((any . any) any))))))) x966))) -(install-global-transformer (quote let*) (lambda (x) ((lambda (tmp974) ((lambda (tmp975) (if (if tmp975 (apply (lambda (let* x976 v e1 e2) (andmap identifier? x976)) tmp975) (quote #f)) (apply (lambda (let*978 x979 v980 e1981 e2982) (let f ((bindings (map list x979 v980))) (if (null? bindings) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote ()) (cons e1981 e2982))) ((lambda (tmp986) ((lambda (tmp987) (if tmp987 (apply (lambda (body binding) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list binding) body)) tmp987) (syntax-error tmp986))) (syntax-dispatch tmp986 (quote (any any))))) (list (f (cdr bindings)) (car bindings)))))) tmp975) (syntax-error tmp974))) (syntax-dispatch tmp974 (quote (any #(each (any any)) any . each-any))))) x))) -(install-global-transformer (quote do) (lambda (orig-x) ((lambda (tmp988) ((lambda (tmp989) (if tmp989 (apply (lambda (_ var init step e0 e1990 c) ((lambda (tmp991) ((lambda (tmp992) (if tmp992 (apply (lambda (step993) ((lambda (tmp994) ((lambda (tmp995) (if tmp995 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list var init) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) e0) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append c (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) step993))))))) tmp995) ((lambda (tmp1000) (if tmp1000 (apply (lambda (e11001 e21002) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list var init) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) e0 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (cons e11001 e21002)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append c (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) step993))))))) tmp1000) (syntax-error tmp994))) (syntax-dispatch tmp994 (quote (any . each-any)))))) (syntax-dispatch tmp994 (quote ())))) e1990)) tmp992) (syntax-error tmp991))) (syntax-dispatch tmp991 (quote each-any)))) (map (lambda (v1009 s) ((lambda (tmp1010) ((lambda (tmp1011) (if tmp1011 (apply (lambda () v1009) tmp1011) ((lambda (tmp1012) (if tmp1012 (apply (lambda (e) e) tmp1012) ((lambda (_1013) (syntax-error orig-x)) tmp1010))) (syntax-dispatch tmp1010 (quote (any)))))) (syntax-dispatch tmp1010 (quote ())))) s)) var step))) tmp989) (syntax-error tmp988))) (syntax-dispatch tmp988 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x))) -(install-global-transformer (quote quasiquote) (letrec ((quasicons (lambda (x1015 y) ((lambda (tmp1016) ((lambda (tmp1017) (if tmp1017 (apply (lambda (x1018 y1019) ((lambda (tmp1020) ((lambda (tmp1021) (if tmp1021 (apply (lambda (dy) ((lambda (tmp1022) ((lambda (tmp1023) (if tmp1023 (apply (lambda (dx) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons dx dy))) tmp1023) ((lambda (_1024) (if (null? dy) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1018) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1018 y1019))) tmp1022))) (syntax-dispatch tmp1022 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) x1018)) tmp1021) ((lambda (tmp1025) (if tmp1025 (apply (lambda (stuff) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons x1018 stuff))) tmp1025) ((lambda (else) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1018 y1019)) tmp1020))) (syntax-dispatch tmp1020 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . any)))))) (syntax-dispatch tmp1020 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) y1019)) tmp1017) (syntax-error tmp1016))) (syntax-dispatch tmp1016 (quote (any any))))) (list x1015 y)))) (quasiappend (lambda (x1026 y1027) ((lambda (tmp1028) ((lambda (tmp1029) (if tmp1029 (apply (lambda (x1030 y1031) ((lambda (tmp1032) ((lambda (tmp1033) (if tmp1033 (apply (lambda () x1030) tmp1033) ((lambda (_1034) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1030 y1031)) tmp1032))) (syntax-dispatch tmp1032 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) ()))))) y1031)) tmp1029) (syntax-error tmp1028))) (syntax-dispatch tmp1028 (quote (any any))))) (list x1026 y1027)))) (quasivector (lambda (x1035) ((lambda (tmp1036) ((lambda (x1037) ((lambda (tmp1038) ((lambda (tmp1039) (if tmp1039 (apply (lambda (x1040) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (list->vector x1040))) tmp1039) ((lambda (tmp1042) (if tmp1042 (apply (lambda (x1043) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1043)) tmp1042) ((lambda (_1045) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1037)) tmp1038))) (syntax-dispatch tmp1038 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . each-any)))))) (syntax-dispatch tmp1038 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) each-any))))) x1037)) tmp1036)) x1035))) (quasi (lambda (p lev) ((lambda (tmp1046) ((lambda (tmp1047) (if tmp1047 (apply (lambda (p1048) (if (= lev (quote 0)) p1048 (quasicons (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi (list p1048) (- lev (quote 1)))))) tmp1047) ((lambda (tmp1049) (if tmp1049 (apply (lambda (p1050 q) (if (= lev (quote 0)) (quasiappend p1050 (quasi q lev)) (quasicons (quasicons (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi (list p1050) (- lev (quote 1)))) (quasi q lev)))) tmp1049) ((lambda (tmp) (if tmp (apply (lambda (p1051) (quasicons (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi (list p1051) (+ lev (quote 1))))) tmp) ((lambda (tmp1052) (if tmp1052 (apply (lambda (p1053 q1054) (quasicons (quasi p1053 lev) (quasi q1054 lev))) tmp1052) ((lambda (tmp1055) (if tmp1055 (apply (lambda (x1056) (quasivector (quasi x1056 lev))) tmp1055) ((lambda (p1058) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) p1058)) tmp1046))) (syntax-dispatch tmp1046 (quote #(vector each-any)))))) (syntax-dispatch tmp1046 (quote (any . any)))))) (syntax-dispatch tmp1046 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any)))))) (syntax-dispatch tmp1046 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any) . any)))))) (syntax-dispatch tmp1046 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) p)))) (lambda (x1059) ((lambda (tmp1060) ((lambda (tmp1061) (if tmp1061 (apply (lambda (_1062 e1063) (quasi e1063 (quote 0))) tmp1061) (syntax-error tmp1060))) (syntax-dispatch tmp1060 (quote (any any))))) x1059)))) -(install-global-transformer (quote include) (lambda (x1064) (letrec ((read-file (lambda (fn k) (let ((p1065 (open-input-file fn))) (let f1066 ((x1067 (read p1065))) (if (eof-object? x1067) (begin (close-input-port p1065) (quote ())) (cons (datum->syntax-object k x1067) (f1066 (read p1065))))))))) ((lambda (tmp1068) ((lambda (tmp1069) (if tmp1069 (apply (lambda (k1070 filename) (let ((fn1071 (syntax-object->datum filename))) ((lambda (tmp1072) ((lambda (tmp1073) (if tmp1073 (apply (lambda (exp) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))))) exp)) tmp1073) (syntax-error tmp1072))) (syntax-dispatch tmp1072 (quote each-any)))) (read-file fn1071 k1070)))) tmp1069) (syntax-error tmp1068))) (syntax-dispatch tmp1068 (quote (any any))))) x1064)))) -(install-global-transformer (quote unquote) (lambda (x1075) ((lambda (tmp1076) ((lambda (tmp1077) (if tmp1077 (apply (lambda (_1078 e1079) (error (quote unquote) (quote "expression ,~s not valid outside of quasiquote") (syntax-object->datum e1079))) tmp1077) (syntax-error tmp1076))) (syntax-dispatch tmp1076 (quote (any any))))) x1075))) -(install-global-transformer (quote unquote-splicing) (lambda (x1080) ((lambda (tmp1081) ((lambda (tmp1082) (if tmp1082 (apply (lambda (_1083 e1084) (error (quote unquote-splicing) (quote "expression ,@~s not valid outside of quasiquote") (syntax-object->datum e1084))) tmp1082) (syntax-error tmp1081))) (syntax-dispatch tmp1081 (quote (any any))))) x1080))) -(install-global-transformer (quote case) (lambda (x1085) ((lambda (tmp1086) ((lambda (tmp1087) (if tmp1087 (apply (lambda (_1088 e1089 m1 m2) ((lambda (tmp1090) ((lambda (body1091) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) e1089)) body1091)) tmp1090)) (let f1092 ((clause m1) (clauses m2)) (if (null? clauses) ((lambda (tmp1094) ((lambda (tmp1095) (if tmp1095 (apply (lambda (e11096 e21097) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11096 e21097))) tmp1095) ((lambda (tmp1099) (if tmp1099 (apply (lambda (k1100 e11101 e21102) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) k1100)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11101 e21102)))) tmp1099) ((lambda (_1105) (syntax-error x1085)) tmp1094))) (syntax-dispatch tmp1094 (quote (each-any any . each-any)))))) (syntax-dispatch tmp1094 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) any . each-any))))) clause) ((lambda (tmp1106) ((lambda (rest) ((lambda (tmp1107) ((lambda (tmp1108) (if tmp1108 (apply (lambda (k1109 e11110 e21111) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) k1109)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11110 e21111)) rest)) tmp1108) ((lambda (_1114) (syntax-error x1085)) tmp1107))) (syntax-dispatch tmp1107 (quote (each-any any . each-any))))) clause)) tmp1106)) (f1092 (car clauses) (cdr clauses))))))) tmp1087) (syntax-error tmp1086))) (syntax-dispatch tmp1086 (quote (any any any . each-any))))) x1085))) -(install-global-transformer (quote identifier-syntax) (lambda (x1115) ((lambda (tmp1116) ((lambda (tmp1117) (if tmp1117 (apply (lambda (_1118 e1119) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) e1119)) (list (cons _1118 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e1119 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))))))))) tmp1117) (syntax-error tmp1116))) (syntax-dispatch tmp1116 (quote (any any))))) x1115))) +(letrec ((lambda-var-list116 (lambda (vars323) (let lvl324 ((vars325 vars323) (ls326 (quote ())) (w327 (quote (())))) (cond ((pair? vars325) (lvl324 (cdr vars325) (cons (wrap95 (car vars325) w327) ls326) w327)) ((id?67 vars325) (cons (wrap95 vars325 w327) ls326)) ((null? vars325) ls326) ((syntax-object?53 vars325) (lvl324 (syntax-object-expression54 vars325) ls326 (join-wraps86 w327 (syntax-object-wrap55 vars325)))) ((annotation?42 vars325) (lvl324 (annotation-expression vars325) ls326 w327)) (else (cons vars325 ls326)))))) (gen-var115 (lambda (id328) (let ((id329 (if (syntax-object?53 id328) (syntax-object-expression54 id328) id328))) (if (annotation?42 id329) (gentemp (symbol->string (annotation-expression id329)) generated-symbols) (gentemp (symbol->string id329) generated-symbols))))) (strip114 (lambda (x330 w331) (if (memq (quote top) (wrap-marks70 w331)) (if (or (annotation?42 x330) (and (pair? x330) (annotation?42 (car x330)))) (strip-annotation113 x330 (quote #f)) x330) (let f332 ((x333 x330)) (cond ((syntax-object?53 x333) (strip114 (syntax-object-expression54 x333) (syntax-object-wrap55 x333))) ((pair? x333) (let ((a334 (f332 (car x333))) (d335 (f332 (cdr x333)))) (if (and (eq? a334 (car x333)) (eq? d335 (cdr x333))) x333 (cons a334 d335)))) ((vector? x333) (let ((old336 (vector->list x333))) (let ((new337 (map f332 old336))) (if (andmap eq? old336 new337) x333 (list->vector new337))))) (else x333)))))) (strip-annotation113 (lambda (x338 parent339) (cond ((pair? x338) (let ((new340 (cons (quote #f) (quote #f)))) (begin (when parent339 (set-annotation-stripped! parent339 new340)) (set-car! new340 (strip-annotation113 (car x338) (quote #f))) (set-cdr! new340 (strip-annotation113 (cdr x338) (quote #f))) new340))) ((annotation?42 x338) (or (annotation-stripped x338) (strip-annotation113 (annotation-expression x338) x338))) ((vector? x338) (let ((new341 (make-vector (vector-length x338)))) (begin (when parent339 (set-annotation-stripped! parent339 new341)) (let loop342 ((i343 (- (vector-length x338) (quote 1)))) (unless (fx<41 i343 (quote 0)) (vector-set! new341 i343 (strip-annotation113 (vector-ref x338 i343) (quote #f))) (loop342 (fx-39 i343 (quote 1))))) new341))) (else x338)))) (ellipsis?112 (lambda (x344) (and (nonsymbol-id?66 x344) (free-id=?90 x344 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))))))) (chi-void111 (lambda () (list (quote void)))) (eval-local-transformer110 (lambda (expanded345) (let ((p346 (local-eval-hook44 expanded345))) (if (procedure? p346) p346 (syntax-error p346 (quote "nonprocedure transfomer")))))) (chi-local-syntax109 (lambda (rec?347 e348 r349 w350 s351 k352) ((lambda (tmp353) ((lambda (tmp354) (if tmp354 (apply (lambda (_355 id356 val357 e1358 e2359) (let ((ids360 id356)) (if (not (valid-bound-ids?92 ids360)) (syntax-error e348 (quote "duplicate bound keyword in")) (let ((labels362 (gen-labels73 ids360))) (let ((new-w363 (make-binding-wrap84 ids360 labels362 w350))) (k352 (cons e1358 e2359) (extend-env61 labels362 (let ((w365 (if rec?347 new-w363 w350)) (trans-r366 (macros-only-env63 r349))) (map (lambda (x367) (cons (quote macro) (eval-local-transformer110 (chi103 x367 trans-r366 w365)))) val357)) r349) new-w363 s351)))))) tmp354) ((lambda (_369) (syntax-error (source-wrap96 e348 w350 s351))) tmp353))) (syntax-dispatch tmp353 (quote (any #(each (any any)) any . each-any))))) e348))) (chi-lambda-clause108 (lambda (e370 c371 r372 w373 k374) ((lambda (tmp375) ((lambda (tmp376) (if tmp376 (apply (lambda (id377 e1378 e2379) (let ((ids380 id377)) (if (not (valid-bound-ids?92 ids380)) (syntax-error e370 (quote "invalid parameter list in")) (let ((labels382 (gen-labels73 ids380)) (new-vars383 (map gen-var115 ids380))) (k374 new-vars383 (chi-body107 (cons e1378 e2379) e370 (extend-var-env62 labels382 new-vars383 r372) (make-binding-wrap84 ids380 labels382 w373))))))) tmp376) ((lambda (tmp385) (if tmp385 (apply (lambda (ids386 e1387 e2388) (let ((old-ids389 (lambda-var-list116 ids386))) (if (not (valid-bound-ids?92 old-ids389)) (syntax-error e370 (quote "invalid parameter list in")) (let ((labels390 (gen-labels73 old-ids389)) (new-vars391 (map gen-var115 old-ids389))) (k374 (let f392 ((ls1393 (cdr new-vars391)) (ls2394 (car new-vars391))) (if (null? ls1393) ls2394 (f392 (cdr ls1393) (cons (car ls1393) ls2394)))) (chi-body107 (cons e1387 e2388) e370 (extend-var-env62 labels390 new-vars391 r372) (make-binding-wrap84 old-ids389 labels390 w373))))))) tmp385) ((lambda (_396) (syntax-error e370)) tmp375))) (syntax-dispatch tmp375 (quote (any any . each-any)))))) (syntax-dispatch tmp375 (quote (each-any any . each-any))))) c371))) (chi-body107 (lambda (body397 outer-form398 r399 w400) (let ((r401 (cons (quote ("placeholder" placeholder)) r399))) (let ((ribcage402 (make-ribcage74 (quote ()) (quote ()) (quote ())))) (let ((w403 (make-wrap69 (wrap-marks70 w400) (cons ribcage402 (wrap-subst71 w400))))) (let parse404 ((body405 (map (lambda (x411) (cons r401 (wrap95 x411 w403))) body397)) (ids406 (quote ())) (labels407 (quote ())) (vars408 (quote ())) (vals409 (quote ())) (bindings410 (quote ()))) (if (null? body405) (syntax-error outer-form398 (quote "no expressions in body")) (let ((e412 (cdar body405)) (er413 (caar body405))) (call-with-values (lambda () (syntax-type101 e412 er413 (quote (())) (quote #f) ribcage402)) (lambda (type414 value415 e416 w417 s418) (let ((t419 type414)) (if (memv t419 (quote (define-form))) (let ((id420 (wrap95 value415 w417)) (label421 (gen-label72))) (let ((var422 (gen-var115 id420))) (begin (extend-ribcage!83 ribcage402 id420 label421) (parse404 (cdr body405) (cons id420 ids406) (cons label421 labels407) (cons var422 vars408) (cons (cons er413 (wrap95 e416 w417)) vals409) (cons (cons (quote lexical) var422) bindings410))))) (if (memv t419 (quote (define-syntax-form))) (let ((id423 (wrap95 value415 w417)) (label424 (gen-label72))) (begin (extend-ribcage!83 ribcage402 id423 label424) (parse404 (cdr body405) (cons id423 ids406) (cons label424 labels407) vars408 vals409 (cons (cons (quote macro) (cons er413 (wrap95 e416 w417))) bindings410)))) (if (memv t419 (quote (begin-form))) ((lambda (tmp425) ((lambda (tmp426) (if tmp426 (apply (lambda (_427 e1428) (parse404 (let f429 ((forms430 e1428)) (if (null? forms430) (cdr body405) (cons (cons er413 (wrap95 (car forms430) w417)) (f429 (cdr forms430))))) ids406 labels407 vars408 vals409 bindings410)) tmp426) (syntax-error tmp425))) (syntax-dispatch tmp425 (quote (any . each-any))))) e416) (if (memv t419 (quote (local-syntax-form))) (chi-local-syntax109 value415 e416 er413 w417 s418 (lambda (forms432 er433 w434 s435) (parse404 (let f436 ((forms437 forms432)) (if (null? forms437) (cdr body405) (cons (cons er433 (wrap95 (car forms437) w434)) (f436 (cdr forms437))))) ids406 labels407 vars408 vals409 bindings410))) (if (null? ids406) (build-sequence48 (quote #f) (map (lambda (x438) (chi103 (cdr x438) (car x438) (quote (())))) (cons (cons er413 (source-wrap96 e416 w417 s418)) (cdr body405)))) (begin (if (not (valid-bound-ids?92 ids406)) (syntax-error outer-form398 (quote "invalid or duplicate identifier in definition"))) (let loop439 ((bs440 bindings410) (er-cache441 (quote #f)) (r-cache442 (quote #f))) (if (not (null? bs440)) (let ((b443 (car bs440))) (if (eq? (car b443) (quote macro)) (let ((er444 (cadr b443))) (let ((r-cache445 (if (eq? er444 er-cache441) r-cache442 (macros-only-env63 er444)))) (begin (set-cdr! b443 (eval-local-transformer110 (chi103 (cddr b443) r-cache445 (quote (()))))) (loop439 (cdr bs440) er444 r-cache445)))) (loop439 (cdr bs440) er-cache441 r-cache442))))) (set-cdr! r401 (extend-env61 labels407 bindings410 (cdr r401))) (build-letrec51 (quote #f) vars408 (map (lambda (x446) (chi103 (cdr x446) (car x446) (quote (())))) vals409) (build-sequence48 (quote #f) (map (lambda (x447) (chi103 (cdr x447) (car x447) (quote (())))) (cons (cons er413 (source-wrap96 e416 w417 s418)) (cdr body405)))))))))))))))))))))) (chi-macro106 (lambda (p448 e449 r450 w451 rib452) (letrec ((rebuild-macro-output453 (lambda (x454 m455) (cond ((pair? x454) (cons (rebuild-macro-output453 (car x454) m455) (rebuild-macro-output453 (cdr x454) m455))) ((syntax-object?53 x454) (let ((w456 (syntax-object-wrap55 x454))) (let ((ms457 (wrap-marks70 w456)) (s458 (wrap-subst71 w456))) (make-syntax-object52 (syntax-object-expression54 x454) (if (and (pair? ms457) (eq? (car ms457) (quote #f))) (make-wrap69 (cdr ms457) (if rib452 (cons rib452 (cdr s458)) (cdr s458))) (make-wrap69 (cons m455 ms457) (if rib452 (cons rib452 (cons (quote shift) s458)) (cons (quote shift) s458)))))))) ((vector? x454) (let ((n459 (vector-length x454))) (let ((v460 (make-vector n459))) (let doloop461 ((i462 (quote 0))) (if (fx=40 i462 n459) v460 (begin (vector-set! v460 i462 (rebuild-macro-output453 (vector-ref x454 i462) m455)) (doloop461 (fx+38 i462 (quote 1))))))))) ((symbol? x454) (syntax-error x454 (quote "encountered raw symbol in macro output"))) (else x454))))) (rebuild-macro-output453 (p448 (wrap95 e449 (anti-mark82 w451))) (string (quote #\m)))))) (chi-application105 (lambda (x463 e464 r465 w466 s467) ((lambda (tmp468) ((lambda (tmp469) (if tmp469 (apply (lambda (e0470 e1471) (cons x463 (map (lambda (e472) (chi103 e472 r465 w466)) e1471))) tmp469) (syntax-error tmp468))) (syntax-dispatch tmp468 (quote (any . each-any))))) e464))) (chi-expr104 (lambda (type474 value475 e476 r477 w478 s479) (let ((t480 type474)) (if (memv t480 (quote (lexical))) value475 (if (memv t480 (quote (core))) (value475 e476 r477 w478 s479) (if (memv t480 (quote (lexical-call))) (chi-application105 value475 e476 r477 w478 s479) (if (memv t480 (quote (global-call))) (chi-application105 value475 e476 r477 w478 s479) (if (memv t480 (quote (constant))) (list (quote quote) (strip114 (source-wrap96 e476 w478 s479) (quote (())))) (if (memv t480 (quote (global))) value475 (if (memv t480 (quote (call))) (chi-application105 (chi103 (car e476) r477 w478) e476 r477 w478 s479) (if (memv t480 (quote (begin-form))) ((lambda (tmp481) ((lambda (tmp482) (if tmp482 (apply (lambda (_483 e1484 e2485) (chi-sequence97 (cons e1484 e2485) r477 w478 s479)) tmp482) (syntax-error tmp481))) (syntax-dispatch tmp481 (quote (any any . each-any))))) e476) (if (memv t480 (quote (local-syntax-form))) (chi-local-syntax109 value475 e476 r477 w478 s479 chi-sequence97) (if (memv t480 (quote (eval-when-form))) ((lambda (tmp487) ((lambda (tmp488) (if tmp488 (apply (lambda (_489 x490 e1491 e2492) (let ((when-list493 (chi-when-list100 e476 x490 w478))) (if (memq (quote eval) when-list493) (chi-sequence97 (cons e1491 e2492) r477 w478 s479) (chi-void111)))) tmp488) (syntax-error tmp487))) (syntax-dispatch tmp487 (quote (any each-any any . each-any))))) e476) (if (memv t480 (quote (define-form define-syntax-form))) (syntax-error (wrap95 value475 w478) (quote "invalid context for definition of")) (if (memv t480 (quote (syntax))) (syntax-error (source-wrap96 e476 w478 s479) (quote "reference to pattern variable outside syntax form")) (if (memv t480 (quote (displaced-lexical))) (syntax-error (source-wrap96 e476 w478 s479) (quote "reference to identifier outside its scope")) (syntax-error (source-wrap96 e476 w478 s479)))))))))))))))))) (chi103 (lambda (e496 r497 w498) (call-with-values (lambda () (syntax-type101 e496 r497 w498 (quote #f) (quote #f))) (lambda (type499 value500 e501 w502 s503) (chi-expr104 type499 value500 e501 r497 w502 s503))))) (chi-top102 (lambda (e504 r505 w506 m507 esew508) (call-with-values (lambda () (syntax-type101 e504 r505 w506 (quote #f) (quote #f))) (lambda (type515 value516 e517 w518 s519) (let ((t520 type515)) (if (memv t520 (quote (begin-form))) ((lambda (tmp521) ((lambda (tmp522) (if tmp522 (apply (lambda (_523) (chi-void111)) tmp522) ((lambda (tmp524) (if tmp524 (apply (lambda (_525 e1526 e2527) (chi-top-sequence98 (cons e1526 e2527) r505 w518 s519 m507 esew508)) tmp524) (syntax-error tmp521))) (syntax-dispatch tmp521 (quote (any any . each-any)))))) (syntax-dispatch tmp521 (quote (any))))) e517) (if (memv t520 (quote (local-syntax-form))) (chi-local-syntax109 value516 e517 r505 w518 s519 (lambda (body529 r530 w531 s532) (chi-top-sequence98 body529 r530 w531 s532 m507 esew508))) (if (memv t520 (quote (eval-when-form))) ((lambda (tmp533) ((lambda (tmp534) (if tmp534 (apply (lambda (_535 x536 e1537 e2538) (let ((when-list539 (chi-when-list100 e517 x536 w518)) (body540 (cons e1537 e2538))) (cond ((eq? m507 (quote e)) (if (memq (quote eval) when-list539) (chi-top-sequence98 body540 r505 w518 s519 (quote e) (quote (eval))) (chi-void111))) ((memq (quote load) when-list539) (if (or (memq (quote compile) when-list539) (and (eq? m507 (quote c&e)) (memq (quote eval) when-list539))) (chi-top-sequence98 body540 r505 w518 s519 (quote c&e) (quote (compile load))) (if (memq m507 (quote (c c&e))) (chi-top-sequence98 body540 r505 w518 s519 (quote c) (quote (load))) (chi-void111)))) ((or (memq (quote compile) when-list539) (and (eq? m507 (quote c&e)) (memq (quote eval) when-list539))) (top-level-eval-hook43 (chi-top-sequence98 body540 r505 w518 s519 (quote e) (quote (eval)))) (chi-void111)) (else (chi-void111))))) tmp534) (syntax-error tmp533))) (syntax-dispatch tmp533 (quote (any each-any any . each-any))))) e517) (if (memv t520 (quote (define-syntax-form))) (let ((n543 (id-var-name89 value516 w518)) (r544 (macros-only-env63 r505))) (let ((t545 m507)) (if (memv t545 (quote (c))) (if (memq (quote compile) esew508) (let ((e546 (chi-install-global99 n543 (chi103 e517 r544 w518)))) (begin (top-level-eval-hook43 e546) (if (memq (quote load) esew508) e546 (chi-void111)))) (if (memq (quote load) esew508) (chi-install-global99 n543 (chi103 e517 r544 w518)) (chi-void111))) (if (memv t545 (quote (c&e))) (let ((e547 (chi-install-global99 n543 (chi103 e517 r544 w518)))) (begin (top-level-eval-hook43 e547) e547)) (begin (if (memq (quote eval) esew508) (top-level-eval-hook43 (chi-install-global99 n543 (chi103 e517 r544 w518)))) (chi-void111)))))) (if (memv t520 (quote (define-form))) (let ((n548 (id-var-name89 value516 w518))) (let ((t549 (binding-type59 (lookup64 n548 r505)))) (if (memv t549 (quote (global))) (let ((x550 (list (quote define) n548 (chi103 e517 r505 w518)))) (begin (if (eq? m507 (quote c&e)) (top-level-eval-hook43 x550)) x550)) (if (memv t549 (quote (displaced-lexical))) (syntax-error (wrap95 value516 w518) (quote "identifier out of context")) (syntax-error (wrap95 value516 w518) (quote "cannot define keyword at top level")))))) (let ((x551 (chi-expr104 type515 value516 e517 r505 w518 s519))) (begin (if (eq? m507 (quote c&e)) (top-level-eval-hook43 x551)) x551)))))))))))) (syntax-type101 (lambda (e552 r553 w554 s555 rib556) (cond ((symbol? e552) (let ((n557 (id-var-name89 e552 w554))) (let ((b558 (lookup64 n557 r553))) (let ((type559 (binding-type59 b558))) (let ((t560 type559)) (if (memv t560 (quote (lexical))) (values type559 (binding-value60 b558) e552 w554 s555) (if (memv t560 (quote (global))) (values type559 n557 e552 w554 s555) (if (memv t560 (quote (macro))) (syntax-type101 (chi-macro106 (binding-value60 b558) e552 r553 w554 rib556) r553 (quote (())) s555 rib556) (values type559 (binding-value60 b558) e552 w554 s555))))))))) ((pair? e552) (let ((first561 (car e552))) (if (id?67 first561) (let ((n562 (id-var-name89 first561 w554))) (let ((b563 (lookup64 n562 r553))) (let ((type564 (binding-type59 b563))) (let ((t565 type564)) (if (memv t565 (quote (lexical))) (values (quote lexical-call) (binding-value60 b563) e552 w554 s555) (if (memv t565 (quote (global))) (values (quote global-call) n562 e552 w554 s555) (if (memv t565 (quote (macro))) (syntax-type101 (chi-macro106 (binding-value60 b563) e552 r553 w554 rib556) r553 (quote (())) s555 rib556) (if (memv t565 (quote (core))) (values type564 (binding-value60 b563) e552 w554 s555) (if (memv t565 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value60 b563) e552 w554 s555) (if (memv t565 (quote (begin))) (values (quote begin-form) (quote #f) e552 w554 s555) (if (memv t565 (quote (eval-when))) (values (quote eval-when-form) (quote #f) e552 w554 s555) (if (memv t565 (quote (define))) ((lambda (tmp566) ((lambda (tmp567) (if (if tmp567 (apply (lambda (_568 name569 val570) (id?67 name569)) tmp567) (quote #f)) (apply (lambda (_571 name572 val573) (values (quote define-form) name572 val573 w554 s555)) tmp567) ((lambda (tmp574) (if (if tmp574 (apply (lambda (_575 name576 args577 e1578 e2579) (and (id?67 name576) (valid-bound-ids?92 (lambda-var-list116 args577)))) tmp574) (quote #f)) (apply (lambda (_580 name581 args582 e1583 e2584) (values (quote define-form) (wrap95 name581 w554) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) (wrap95 (cons args582 (cons e1583 e2584)) w554)) (quote (())) s555)) tmp574) ((lambda (tmp586) (if (if tmp586 (apply (lambda (_587 name588) (id?67 name588)) tmp586) (quote #f)) (apply (lambda (_589 name590) (values (quote define-form) (wrap95 name590 w554) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote (())) s555)) tmp586) (syntax-error tmp566))) (syntax-dispatch tmp566 (quote (any any)))))) (syntax-dispatch tmp566 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp566 (quote (any any any))))) e552) (if (memv t565 (quote (define-syntax))) ((lambda (tmp591) ((lambda (tmp592) (if (if tmp592 (apply (lambda (_593 name594 val595) (id?67 name594)) tmp592) (quote #f)) (apply (lambda (_596 name597 val598) (values (quote define-syntax-form) name597 val598 w554 s555)) tmp592) (syntax-error tmp591))) (syntax-dispatch tmp591 (quote (any any any))))) e552) (values (quote call) (quote #f) e552 w554 s555)))))))))))))) (values (quote call) (quote #f) e552 w554 s555)))) ((syntax-object?53 e552) (syntax-type101 (syntax-object-expression54 e552) r553 (join-wraps86 w554 (syntax-object-wrap55 e552)) (quote #f) rib556)) ((annotation?42 e552) (syntax-type101 (annotation-expression e552) r553 w554 (annotation-source e552) rib556)) ((let ((x599 e552)) (or (boolean? x599) (number? x599) (string? x599) (char? x599) (null? x599) (keyword? x599))) (values (quote constant) (quote #f) e552 w554 s555)) (else (values (quote other) (quote #f) e552 w554 s555))))) (chi-when-list100 (lambda (e600 when-list601 w602) (let f603 ((when-list604 when-list601) (situations605 (quote ()))) (if (null? when-list604) situations605 (f603 (cdr when-list604) (cons (let ((x606 (car when-list604))) (cond ((free-id=?90 x606 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote compile)) ((free-id=?90 x606 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote load)) ((free-id=?90 x606 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote eval)) (else (syntax-error (wrap95 x606 w602) (quote "invalid eval-when situation"))))) situations605)))))) (chi-install-global99 (lambda (name607 e608) (list (quote install-global-transformer) (list (quote quote) name607) e608))) (chi-top-sequence98 (lambda (body609 r610 w611 s612 m613 esew614) (build-sequence48 s612 (let dobody615 ((body616 body609) (r617 r610) (w618 w611) (m619 m613) (esew620 esew614)) (if (null? body616) (quote ()) (let ((first621 (chi-top102 (car body616) r617 w618 m619 esew620))) (cons first621 (dobody615 (cdr body616) r617 w618 m619 esew620)))))))) (chi-sequence97 (lambda (body622 r623 w624 s625) (build-sequence48 s625 (let dobody626 ((body627 body622) (r628 r623) (w629 w624)) (if (null? body627) (quote ()) (let ((first630 (chi103 (car body627) r628 w629))) (cons first630 (dobody626 (cdr body627) r628 w629)))))))) (source-wrap96 (lambda (x631 w632 s633) (wrap95 (if s633 (make-annotation x631 s633 (quote #f)) x631) w632))) (wrap95 (lambda (x634 w635) (cond ((and (null? (wrap-marks70 w635)) (null? (wrap-subst71 w635))) x634) ((syntax-object?53 x634) (make-syntax-object52 (syntax-object-expression54 x634) (join-wraps86 w635 (syntax-object-wrap55 x634)))) ((null? x634) x634) (else (make-syntax-object52 x634 w635))))) (bound-id-member?94 (lambda (x636 list637) (and (not (null? list637)) (or (bound-id=?91 x636 (car list637)) (bound-id-member?94 x636 (cdr list637)))))) (distinct-bound-ids?93 (lambda (ids638) (let distinct?639 ((ids640 ids638)) (or (null? ids640) (and (not (bound-id-member?94 (car ids640) (cdr ids640))) (distinct?639 (cdr ids640))))))) (valid-bound-ids?92 (lambda (ids641) (and (let all-ids?642 ((ids643 ids641)) (or (null? ids643) (and (id?67 (car ids643)) (all-ids?642 (cdr ids643))))) (distinct-bound-ids?93 ids641)))) (bound-id=?91 (lambda (i644 j645) (if (and (syntax-object?53 i644) (syntax-object?53 j645)) (and (eq? (let ((e646 (syntax-object-expression54 i644))) (if (annotation?42 e646) (annotation-expression e646) e646)) (let ((e647 (syntax-object-expression54 j645))) (if (annotation?42 e647) (annotation-expression e647) e647))) (same-marks?88 (wrap-marks70 (syntax-object-wrap55 i644)) (wrap-marks70 (syntax-object-wrap55 j645)))) (eq? (let ((e648 i644)) (if (annotation?42 e648) (annotation-expression e648) e648)) (let ((e649 j645)) (if (annotation?42 e649) (annotation-expression e649) e649)))))) (free-id=?90 (lambda (i650 j651) (and (eq? (let ((x652 i650)) (let ((e653 (if (syntax-object?53 x652) (syntax-object-expression54 x652) x652))) (if (annotation?42 e653) (annotation-expression e653) e653))) (let ((x654 j651)) (let ((e655 (if (syntax-object?53 x654) (syntax-object-expression54 x654) x654))) (if (annotation?42 e655) (annotation-expression e655) e655)))) (eq? (id-var-name89 i650 (quote (()))) (id-var-name89 j651 (quote (()))))))) (id-var-name89 (lambda (id656 w657) (letrec ((search-vector-rib660 (lambda (sym666 subst667 marks668 symnames669 ribcage670) (let ((n671 (vector-length symnames669))) (let f672 ((i673 (quote 0))) (cond ((fx=40 i673 n671) (search658 sym666 (cdr subst667) marks668)) ((and (eq? (vector-ref symnames669 i673) sym666) (same-marks?88 marks668 (vector-ref (ribcage-marks77 ribcage670) i673))) (values (vector-ref (ribcage-labels78 ribcage670) i673) marks668)) (else (f672 (fx+38 i673 (quote 1))))))))) (search-list-rib659 (lambda (sym674 subst675 marks676 symnames677 ribcage678) (let f679 ((symnames680 symnames677) (i681 (quote 0))) (cond ((null? symnames680) (search658 sym674 (cdr subst675) marks676)) ((and (eq? (car symnames680) sym674) (same-marks?88 marks676 (list-ref (ribcage-marks77 ribcage678) i681))) (values (list-ref (ribcage-labels78 ribcage678) i681) marks676)) (else (f679 (cdr symnames680) (fx+38 i681 (quote 1)))))))) (search658 (lambda (sym682 subst683 marks684) (if (null? subst683) (values (quote #f) marks684) (let ((fst685 (car subst683))) (if (eq? fst685 (quote shift)) (search658 sym682 (cdr subst683) (cdr marks684)) (let ((symnames686 (ribcage-symnames76 fst685))) (if (vector? symnames686) (search-vector-rib660 sym682 subst683 marks684 symnames686 fst685) (search-list-rib659 sym682 subst683 marks684 symnames686 fst685))))))))) (cond ((symbol? id656) (or (call-with-values (lambda () (search658 id656 (wrap-subst71 w657) (wrap-marks70 w657))) (lambda (x688 . ignore687) x688)) id656)) ((syntax-object?53 id656) (let ((id689 (let ((e691 (syntax-object-expression54 id656))) (if (annotation?42 e691) (annotation-expression e691) e691))) (w1690 (syntax-object-wrap55 id656))) (let ((marks692 (join-marks87 (wrap-marks70 w657) (wrap-marks70 w1690)))) (call-with-values (lambda () (search658 id689 (wrap-subst71 w657) marks692)) (lambda (new-id693 marks694) (or new-id693 (call-with-values (lambda () (search658 id689 (wrap-subst71 w1690) marks694)) (lambda (x696 . ignore695) x696)) id689)))))) ((annotation?42 id656) (let ((id697 (let ((e698 id656)) (if (annotation?42 e698) (annotation-expression e698) e698)))) (or (call-with-values (lambda () (search658 id697 (wrap-subst71 w657) (wrap-marks70 w657))) (lambda (x700 . ignore699) x700)) id697))) (else (error-hook45 (quote id-var-name) (quote "invalid id") id656)))))) (same-marks?88 (lambda (x701 y702) (or (eq? x701 y702) (and (not (null? x701)) (not (null? y702)) (eq? (car x701) (car y702)) (same-marks?88 (cdr x701) (cdr y702)))))) (join-marks87 (lambda (m1703 m2704) (smart-append85 m1703 m2704))) (join-wraps86 (lambda (w1705 w2706) (let ((m1707 (wrap-marks70 w1705)) (s1708 (wrap-subst71 w1705))) (if (null? m1707) (if (null? s1708) w2706 (make-wrap69 (wrap-marks70 w2706) (smart-append85 s1708 (wrap-subst71 w2706)))) (make-wrap69 (smart-append85 m1707 (wrap-marks70 w2706)) (smart-append85 s1708 (wrap-subst71 w2706))))))) (smart-append85 (lambda (m1709 m2710) (if (null? m2710) m1709 (append m1709 m2710)))) (make-binding-wrap84 (lambda (ids711 labels712 w713) (if (null? ids711) w713 (make-wrap69 (wrap-marks70 w713) (cons (let ((labelvec714 (list->vector labels712))) (let ((n715 (vector-length labelvec714))) (let ((symnamevec716 (make-vector n715)) (marksvec717 (make-vector n715))) (begin (let f718 ((ids719 ids711) (i720 (quote 0))) (if (not (null? ids719)) (call-with-values (lambda () (id-sym-name&marks68 (car ids719) w713)) (lambda (symname721 marks722) (begin (vector-set! symnamevec716 i720 symname721) (vector-set! marksvec717 i720 marks722) (f718 (cdr ids719) (fx+38 i720 (quote 1)))))))) (make-ribcage74 symnamevec716 marksvec717 labelvec714))))) (wrap-subst71 w713)))))) (extend-ribcage!83 (lambda (ribcage723 id724 label725) (begin (set-ribcage-symnames!79 ribcage723 (cons (let ((e726 (syntax-object-expression54 id724))) (if (annotation?42 e726) (annotation-expression e726) e726)) (ribcage-symnames76 ribcage723))) (set-ribcage-marks!80 ribcage723 (cons (wrap-marks70 (syntax-object-wrap55 id724)) (ribcage-marks77 ribcage723))) (set-ribcage-labels!81 ribcage723 (cons label725 (ribcage-labels78 ribcage723)))))) (anti-mark82 (lambda (w727) (make-wrap69 (cons (quote #f) (wrap-marks70 w727)) (cons (quote shift) (wrap-subst71 w727))))) (set-ribcage-labels!81 (lambda (x728 update729) (vector-set! x728 (quote 3) update729))) (set-ribcage-marks!80 (lambda (x730 update731) (vector-set! x730 (quote 2) update731))) (set-ribcage-symnames!79 (lambda (x732 update733) (vector-set! x732 (quote 1) update733))) (ribcage-labels78 (lambda (x734) (vector-ref x734 (quote 3)))) (ribcage-marks77 (lambda (x735) (vector-ref x735 (quote 2)))) (ribcage-symnames76 (lambda (x736) (vector-ref x736 (quote 1)))) (ribcage?75 (lambda (x737) (and (vector? x737) (= (vector-length x737) (quote 4)) (eq? (vector-ref x737 (quote 0)) (quote ribcage))))) (make-ribcage74 (lambda (symnames738 marks739 labels740) (vector (quote ribcage) symnames738 marks739 labels740))) (gen-labels73 (lambda (ls741) (if (null? ls741) (quote ()) (cons (gen-label72) (gen-labels73 (cdr ls741)))))) (gen-label72 (lambda () (string (quote #\i)))) (wrap-subst71 cdr) (wrap-marks70 car) (make-wrap69 cons) (id-sym-name&marks68 (lambda (x742 w743) (if (syntax-object?53 x742) (values (let ((e744 (syntax-object-expression54 x742))) (if (annotation?42 e744) (annotation-expression e744) e744)) (join-marks87 (wrap-marks70 w743) (wrap-marks70 (syntax-object-wrap55 x742)))) (values (let ((e745 x742)) (if (annotation?42 e745) (annotation-expression e745) e745)) (wrap-marks70 w743))))) (id?67 (lambda (x746) (cond ((symbol? x746) (quote #t)) ((syntax-object?53 x746) (symbol? (let ((e747 (syntax-object-expression54 x746))) (if (annotation?42 e747) (annotation-expression e747) e747)))) ((annotation?42 x746) (symbol? (annotation-expression x746))) (else (quote #f))))) (nonsymbol-id?66 (lambda (x748) (and (syntax-object?53 x748) (symbol? (let ((e749 (syntax-object-expression54 x748))) (if (annotation?42 e749) (annotation-expression e749) e749)))))) (global-extend65 (lambda (type750 sym751 val752) (put-global-definition-hook46 sym751 (cons type750 val752)))) (lookup64 (lambda (x753 r754) (cond ((assq x753 r754) => cdr) ((symbol? x753) (or (get-global-definition-hook47 x753) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env63 (lambda (r755) (if (null? r755) (quote ()) (let ((a756 (car r755))) (if (eq? (cadr a756) (quote macro)) (cons a756 (macros-only-env63 (cdr r755))) (macros-only-env63 (cdr r755))))))) (extend-var-env62 (lambda (labels757 vars758 r759) (if (null? labels757) r759 (extend-var-env62 (cdr labels757) (cdr vars758) (cons (cons (car labels757) (cons (quote lexical) (car vars758))) r759))))) (extend-env61 (lambda (labels760 bindings761 r762) (if (null? labels760) r762 (extend-env61 (cdr labels760) (cdr bindings761) (cons (cons (car labels760) (car bindings761)) r762))))) (binding-value60 cdr) (binding-type59 car) (source-annotation58 (lambda (x763) (cond ((annotation?42 x763) (annotation-source x763)) ((syntax-object?53 x763) (source-annotation58 (syntax-object-expression54 x763))) (else (quote #f))))) (set-syntax-object-wrap!57 (lambda (x764 update765) (vector-set! x764 (quote 2) update765))) (set-syntax-object-expression!56 (lambda (x766 update767) (vector-set! x766 (quote 1) update767))) (syntax-object-wrap55 (lambda (x768) (vector-ref x768 (quote 2)))) (syntax-object-expression54 (lambda (x769) (vector-ref x769 (quote 1)))) (syntax-object?53 (lambda (x770) (and (vector? x770) (= (vector-length x770) (quote 3)) (eq? (vector-ref x770 (quote 0)) (quote syntax-object))))) (make-syntax-object52 (lambda (expression771 wrap772) (vector (quote syntax-object) expression771 wrap772))) (build-letrec51 (lambda (src773 vars774 val-exps775 body-exp776) (if (null? vars774) body-exp776 (list (quote letrec) (map list vars774 val-exps775) body-exp776)))) (build-named-let50 (lambda (src777 vars778 val-exps779 body-exp780) (if (null? vars778) body-exp780 (list (quote let) (car vars778) (map list (cdr vars778) val-exps779) body-exp780)))) (build-let49 (lambda (src781 vars782 val-exps783 body-exp784) (if (null? vars782) body-exp784 (list (quote let) (map list vars782 val-exps783) body-exp784)))) (build-sequence48 (lambda (src785 exps786) (if (null? (cdr exps786)) (car exps786) (cons (quote begin) exps786)))) (get-global-definition-hook47 (lambda (symbol787) (getprop symbol787 (quote *sc-expander*)))) (put-global-definition-hook46 (lambda (symbol788 binding789) (putprop symbol788 (quote *sc-expander*) binding789))) (error-hook45 (lambda (who790 why791 what792) (error who790 (quote "~a ~s") why791 what792))) (local-eval-hook44 (lambda (x793) (eval (list noexpand37 x793) (interaction-environment)))) (top-level-eval-hook43 (lambda (x794) (eval (list noexpand37 x794) (interaction-environment)))) (annotation?42 (lambda (x795) (quote #f))) (fx<41 <) (fx=40 =) (fx-39 -) (fx+38 +) (noexpand37 (quote "noexpand"))) (begin (global-extend65 (quote local-syntax) (quote letrec-syntax) (quote #t)) (global-extend65 (quote local-syntax) (quote let-syntax) (quote #f)) (global-extend65 (quote core) (quote fluid-let-syntax) (lambda (e796 r797 w798 s799) ((lambda (tmp800) ((lambda (tmp801) (if (if tmp801 (apply (lambda (_802 var803 val804 e1805 e2806) (valid-bound-ids?92 var803)) tmp801) (quote #f)) (apply (lambda (_808 var809 val810 e1811 e2812) (let ((names813 (map (lambda (x814) (id-var-name89 x814 w798)) var809))) (begin (for-each (lambda (id816 n817) (let ((t818 (binding-type59 (lookup64 n817 r797)))) (if (memv t818 (quote (displaced-lexical))) (syntax-error (source-wrap96 id816 w798 s799) (quote "identifier out of context"))))) var809 names813) (chi-body107 (cons e1811 e2812) (source-wrap96 e796 w798 s799) (extend-env61 names813 (let ((trans-r821 (macros-only-env63 r797))) (map (lambda (x822) (cons (quote macro) (eval-local-transformer110 (chi103 x822 trans-r821 w798)))) val810)) r797) w798)))) tmp801) ((lambda (_824) (syntax-error (source-wrap96 e796 w798 s799))) tmp800))) (syntax-dispatch tmp800 (quote (any #(each (any any)) any . each-any))))) e796))) (global-extend65 (quote core) (quote quote) (lambda (e825 r826 w827 s828) ((lambda (tmp829) ((lambda (tmp830) (if tmp830 (apply (lambda (_831 e832) (list (quote quote) (strip114 e832 w827))) tmp830) ((lambda (_833) (syntax-error (source-wrap96 e825 w827 s828))) tmp829))) (syntax-dispatch tmp829 (quote (any any))))) e825))) (global-extend65 (quote core) (quote syntax) (letrec ((regen841 (lambda (x842) (let ((t843 (car x842))) (if (memv t843 (quote (ref))) (cadr x842) (if (memv t843 (quote (primitive))) (cadr x842) (if (memv t843 (quote (quote))) (list (quote quote) (cadr x842)) (if (memv t843 (quote (lambda))) (list (quote lambda) (cadr x842) (regen841 (caddr x842))) (if (memv t843 (quote (map))) (let ((ls844 (map regen841 (cdr x842)))) (cons (if (fx=40 (length ls844) (quote 2)) (quote map) (quote map)) ls844)) (cons (car x842) (map regen841 (cdr x842))))))))))) (gen-vector840 (lambda (x845) (cond ((eq? (car x845) (quote list)) (cons (quote vector) (cdr x845))) ((eq? (car x845) (quote quote)) (list (quote quote) (list->vector (cadr x845)))) (else (list (quote list->vector) x845))))) (gen-append839 (lambda (x846 y847) (if (equal? y847 (quote (quote ()))) x846 (list (quote append) x846 y847)))) (gen-cons838 (lambda (x848 y849) (let ((t850 (car y849))) (if (memv t850 (quote (quote))) (if (eq? (car x848) (quote quote)) (list (quote quote) (cons (cadr x848) (cadr y849))) (if (eq? (cadr y849) (quote ())) (list (quote list) x848) (list (quote cons) x848 y849))) (if (memv t850 (quote (list))) (cons (quote list) (cons x848 (cdr y849))) (list (quote cons) x848 y849)))))) (gen-map837 (lambda (e851 map-env852) (let ((formals853 (map cdr map-env852)) (actuals854 (map (lambda (x855) (list (quote ref) (car x855))) map-env852))) (cond ((eq? (car e851) (quote ref)) (car actuals854)) ((andmap (lambda (x856) (and (eq? (car x856) (quote ref)) (memq (cadr x856) formals853))) (cdr e851)) (cons (quote map) (cons (list (quote primitive) (car e851)) (map (let ((r857 (map cons formals853 actuals854))) (lambda (x858) (cdr (assq (cadr x858) r857)))) (cdr e851))))) (else (cons (quote map) (cons (list (quote lambda) formals853 e851) actuals854))))))) (gen-mappend836 (lambda (e859 map-env860) (list (quote apply) (quote (primitive append)) (gen-map837 e859 map-env860)))) (gen-ref835 (lambda (src861 var862 level863 maps864) (if (fx=40 level863 (quote 0)) (values var862 maps864) (if (null? maps864) (syntax-error src861 (quote "missing ellipsis in syntax form")) (call-with-values (lambda () (gen-ref835 src861 var862 (fx-39 level863 (quote 1)) (cdr maps864))) (lambda (outer-var865 outer-maps866) (let ((b867 (assq outer-var865 (car maps864)))) (if b867 (values (cdr b867) maps864) (let ((inner-var868 (gen-var115 (quote tmp)))) (values inner-var868 (cons (cons (cons outer-var865 inner-var868) (car maps864)) outer-maps866))))))))))) (gen-syntax834 (lambda (src869 e870 r871 maps872 ellipsis?873) (if (id?67 e870) (let ((label874 (id-var-name89 e870 (quote (()))))) (let ((b875 (lookup64 label874 r871))) (if (eq? (binding-type59 b875) (quote syntax)) (call-with-values (lambda () (let ((var.lev876 (binding-value60 b875))) (gen-ref835 src869 (car var.lev876) (cdr var.lev876) maps872))) (lambda (var877 maps878) (values (list (quote ref) var877) maps878))) (if (ellipsis?873 e870) (syntax-error src869 (quote "misplaced ellipsis in syntax form")) (values (list (quote quote) e870) maps872))))) ((lambda (tmp879) ((lambda (tmp880) (if (if tmp880 (apply (lambda (dots881 e882) (ellipsis?873 dots881)) tmp880) (quote #f)) (apply (lambda (dots883 e884) (gen-syntax834 src869 e884 r871 maps872 (lambda (x885) (quote #f)))) tmp880) ((lambda (tmp886) (if (if tmp886 (apply (lambda (x887 dots888 y889) (ellipsis?873 dots888)) tmp886) (quote #f)) (apply (lambda (x890 dots891 y892) (let f893 ((y894 y892) (k895 (lambda (maps896) (call-with-values (lambda () (gen-syntax834 src869 x890 r871 (cons (quote ()) maps896) ellipsis?873)) (lambda (x897 maps898) (if (null? (car maps898)) (syntax-error src869 (quote "extra ellipsis in syntax form")) (values (gen-map837 x897 (car maps898)) (cdr maps898)))))))) ((lambda (tmp899) ((lambda (tmp900) (if (if tmp900 (apply (lambda (dots901 y902) (ellipsis?873 dots901)) tmp900) (quote #f)) (apply (lambda (dots903 y904) (f893 y904 (lambda (maps905) (call-with-values (lambda () (k895 (cons (quote ()) maps905))) (lambda (x906 maps907) (if (null? (car maps907)) (syntax-error src869 (quote "extra ellipsis in syntax form")) (values (gen-mappend836 x906 (car maps907)) (cdr maps907)))))))) tmp900) ((lambda (_908) (call-with-values (lambda () (gen-syntax834 src869 y894 r871 maps872 ellipsis?873)) (lambda (y909 maps910) (call-with-values (lambda () (k895 maps910)) (lambda (x911 maps912) (values (gen-append839 x911 y909) maps912)))))) tmp899))) (syntax-dispatch tmp899 (quote (any . any))))) y894))) tmp886) ((lambda (tmp913) (if tmp913 (apply (lambda (x914 y915) (call-with-values (lambda () (gen-syntax834 src869 x914 r871 maps872 ellipsis?873)) (lambda (x916 maps917) (call-with-values (lambda () (gen-syntax834 src869 y915 r871 maps917 ellipsis?873)) (lambda (y918 maps919) (values (gen-cons838 x916 y918) maps919)))))) tmp913) ((lambda (tmp920) (if tmp920 (apply (lambda (e1921 e2922) (call-with-values (lambda () (gen-syntax834 src869 (cons e1921 e2922) r871 maps872 ellipsis?873)) (lambda (e924 maps925) (values (gen-vector840 e924) maps925)))) tmp920) ((lambda (_926) (values (list (quote quote) e870) maps872)) tmp879))) (syntax-dispatch tmp879 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp879 (quote (any . any)))))) (syntax-dispatch tmp879 (quote (any any . any)))))) (syntax-dispatch tmp879 (quote (any any))))) e870))))) (lambda (e927 r928 w929 s930) (let ((e931 (source-wrap96 e927 w929 s930))) ((lambda (tmp932) ((lambda (tmp933) (if tmp933 (apply (lambda (_934 x935) (call-with-values (lambda () (gen-syntax834 e931 x935 r928 (quote ()) ellipsis?112)) (lambda (e936 maps937) (regen841 e936)))) tmp933) ((lambda (_938) (syntax-error e931)) tmp932))) (syntax-dispatch tmp932 (quote (any any))))) e931))))) (global-extend65 (quote core) (quote lambda) (lambda (e939 r940 w941 s942) ((lambda (tmp943) ((lambda (tmp944) (if tmp944 (apply (lambda (_945 c946) (chi-lambda-clause108 (source-wrap96 e939 w941 s942) c946 r940 w941 (lambda (vars947 body948) (list (quote lambda) vars947 body948)))) tmp944) (syntax-error tmp943))) (syntax-dispatch tmp943 (quote (any . any))))) e939))) (global-extend65 (quote core) (quote let) (letrec ((chi-let949 (lambda (e950 r951 w952 s953 constructor954 ids955 vals956 exps957) (if (not (valid-bound-ids?92 ids955)) (syntax-error e950 (quote "duplicate bound variable in")) (let ((labels958 (gen-labels73 ids955)) (new-vars959 (map gen-var115 ids955))) (let ((nw960 (make-binding-wrap84 ids955 labels958 w952)) (nr961 (extend-var-env62 labels958 new-vars959 r951))) (constructor954 s953 new-vars959 (map (lambda (x962) (chi103 x962 r951 w952)) vals956) (chi-body107 exps957 (source-wrap96 e950 nw960 s953) nr961 nw960)))))))) (lambda (e963 r964 w965 s966) ((lambda (tmp967) ((lambda (tmp968) (if tmp968 (apply (lambda (_969 id970 val971 e1972 e2973) (chi-let949 e963 r964 w965 s966 build-let49 id970 val971 (cons e1972 e2973))) tmp968) ((lambda (tmp977) (if (if tmp977 (apply (lambda (_978 f979 id980 val981 e1982 e2983) (id?67 f979)) tmp977) (quote #f)) (apply (lambda (_984 f985 id986 val987 e1988 e2989) (chi-let949 e963 r964 w965 s966 build-named-let50 (cons f985 id986) val987 (cons e1988 e2989))) tmp977) ((lambda (_993) (syntax-error (source-wrap96 e963 w965 s966))) tmp967))) (syntax-dispatch tmp967 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp967 (quote (any #(each (any any)) any . each-any))))) e963)))) (global-extend65 (quote core) (quote letrec) (lambda (e994 r995 w996 s997) ((lambda (tmp998) ((lambda (tmp999) (if tmp999 (apply (lambda (_1000 id1001 val1002 e11003 e21004) (let ((ids1005 id1001)) (if (not (valid-bound-ids?92 ids1005)) (syntax-error e994 (quote "duplicate bound variable in")) (let ((labels1007 (gen-labels73 ids1005)) (new-vars1008 (map gen-var115 ids1005))) (let ((w1009 (make-binding-wrap84 ids1005 labels1007 w996)) (r1010 (extend-var-env62 labels1007 new-vars1008 r995))) (build-letrec51 s997 new-vars1008 (map (lambda (x1011) (chi103 x1011 r1010 w1009)) val1002) (chi-body107 (cons e11003 e21004) (source-wrap96 e994 w1009 s997) r1010 w1009))))))) tmp999) ((lambda (_1014) (syntax-error (source-wrap96 e994 w996 s997))) tmp998))) (syntax-dispatch tmp998 (quote (any #(each (any any)) any . each-any))))) e994))) (global-extend65 (quote core) (quote set!) (lambda (e1015 r1016 w1017 s1018) ((lambda (tmp1019) ((lambda (tmp1020) (if (if tmp1020 (apply (lambda (_1021 id1022 val1023) (id?67 id1022)) tmp1020) (quote #f)) (apply (lambda (_1024 id1025 val1026) (let ((val1027 (chi103 val1026 r1016 w1017)) (n1028 (id-var-name89 id1025 w1017))) (let ((b1029 (lookup64 n1028 r1016))) (let ((t1030 (binding-type59 b1029))) (if (memv t1030 (quote (lexical))) (list (quote set!) (binding-value60 b1029) val1027) (if (memv t1030 (quote (global))) (list (quote set!) n1028 val1027) (if (memv t1030 (quote (displaced-lexical))) (syntax-error (wrap95 id1025 w1017) (quote "identifier out of context")) (syntax-error (source-wrap96 e1015 w1017 s1018))))))))) tmp1020) ((lambda (tmp1031) (if tmp1031 (apply (lambda (_1032 getter1033 arg1034 val1035) (cons (chi103 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) getter1033) r1016 w1017) (map (lambda (e1036) (chi103 e1036 r1016 w1017)) (append arg1034 (list val1035))))) tmp1031) ((lambda (_1038) (syntax-error (source-wrap96 e1015 w1017 s1018))) tmp1019))) (syntax-dispatch tmp1019 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp1019 (quote (any any any))))) e1015))) (global-extend65 (quote begin) (quote begin) (quote ())) (global-extend65 (quote define) (quote define) (quote ())) (global-extend65 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend65 (quote eval-when) (quote eval-when) (quote ())) (global-extend65 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1042 (lambda (x1043 keys1044 clauses1045 r1046) (if (null? clauses1045) (list (quote syntax-error) x1043) ((lambda (tmp1047) ((lambda (tmp1048) (if tmp1048 (apply (lambda (pat1049 exp1050) (if (and (id?67 pat1049) (andmap (lambda (x1051) (not (free-id=?90 pat1049 x1051))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) keys1044))) (let ((labels1052 (list (gen-label72))) (var1053 (gen-var115 pat1049))) (list (list (quote lambda) (list var1053) (chi103 exp1050 (extend-env61 labels1052 (list (cons (quote syntax) (cons var1053 (quote 0)))) r1046) (make-binding-wrap84 (list pat1049) labels1052 (quote (()))))) x1043)) (gen-clause1041 x1043 keys1044 (cdr clauses1045) r1046 pat1049 (quote #t) exp1050))) tmp1048) ((lambda (tmp1054) (if tmp1054 (apply (lambda (pat1055 fender1056 exp1057) (gen-clause1041 x1043 keys1044 (cdr clauses1045) r1046 pat1055 fender1056 exp1057)) tmp1054) ((lambda (_1058) (syntax-error (car clauses1045) (quote "invalid syntax-case clause"))) tmp1047))) (syntax-dispatch tmp1047 (quote (any any any)))))) (syntax-dispatch tmp1047 (quote (any any))))) (car clauses1045))))) (gen-clause1041 (lambda (x1059 keys1060 clauses1061 r1062 pat1063 fender1064 exp1065) (call-with-values (lambda () (convert-pattern1039 pat1063 keys1060)) (lambda (p1066 pvars1067) (cond ((not (distinct-bound-ids?93 (map car pvars1067))) (syntax-error pat1063 (quote "duplicate pattern variable in syntax-case pattern"))) ((not (andmap (lambda (x1068) (not (ellipsis?112 (car x1068)))) pvars1067)) (syntax-error pat1063 (quote "misplaced ellipsis in syntax-case pattern"))) (else (let ((y1069 (gen-var115 (quote tmp)))) (list (list (quote lambda) (list y1069) (let ((y1070 y1069)) (list (quote if) ((lambda (tmp1071) ((lambda (tmp1072) (if tmp1072 (apply (lambda () y1070) tmp1072) ((lambda (_1073) (list (quote if) y1070 (build-dispatch-call1040 pvars1067 fender1064 y1070 r1062) (list (quote quote) (quote #f)))) tmp1071))) (syntax-dispatch tmp1071 (quote #(atom #t))))) fender1064) (build-dispatch-call1040 pvars1067 exp1065 y1070 r1062) (gen-syntax-case1042 x1059 keys1060 clauses1061 r1062)))) (if (eq? p1066 (quote any)) (list (quote list) x1059) (list (quote syntax-dispatch) x1059 (list (quote quote) p1066))))))))))) (build-dispatch-call1040 (lambda (pvars1074 exp1075 y1076 r1077) (let ((ids1078 (map car pvars1074)) (levels1079 (map cdr pvars1074))) (let ((labels1080 (gen-labels73 ids1078)) (new-vars1081 (map gen-var115 ids1078))) (list (quote apply) (list (quote lambda) new-vars1081 (chi103 exp1075 (extend-env61 labels1080 (map (lambda (var1082 level1083) (cons (quote syntax) (cons var1082 level1083))) new-vars1081 (map cdr pvars1074)) r1077) (make-binding-wrap84 ids1078 labels1080 (quote (()))))) y1076))))) (convert-pattern1039 (lambda (pattern1084 keys1085) (let cvt1086 ((p1087 pattern1084) (n1088 (quote 0)) (ids1089 (quote ()))) (if (id?67 p1087) (if (bound-id-member?94 p1087 keys1085) (values (vector (quote free-id) p1087) ids1089) (values (quote any) (cons (cons p1087 n1088) ids1089))) ((lambda (tmp1090) ((lambda (tmp1091) (if (if tmp1091 (apply (lambda (x1092 dots1093) (ellipsis?112 dots1093)) tmp1091) (quote #f)) (apply (lambda (x1094 dots1095) (call-with-values (lambda () (cvt1086 x1094 (fx+38 n1088 (quote 1)) ids1089)) (lambda (p1096 ids1097) (values (if (eq? p1096 (quote any)) (quote each-any) (vector (quote each) p1096)) ids1097)))) tmp1091) ((lambda (tmp1098) (if tmp1098 (apply (lambda (x1099 y1100) (call-with-values (lambda () (cvt1086 y1100 n1088 ids1089)) (lambda (y1101 ids1102) (call-with-values (lambda () (cvt1086 x1099 n1088 ids1102)) (lambda (x1103 ids1104) (values (cons x1103 y1101) ids1104)))))) tmp1098) ((lambda (tmp1105) (if tmp1105 (apply (lambda () (values (quote ()) ids1089)) tmp1105) ((lambda (tmp1106) (if tmp1106 (apply (lambda (x1107) (call-with-values (lambda () (cvt1086 x1107 n1088 ids1089)) (lambda (p1109 ids1110) (values (vector (quote vector) p1109) ids1110)))) tmp1106) ((lambda (x1111) (values (vector (quote atom) (strip114 p1087 (quote (())))) ids1089)) tmp1090))) (syntax-dispatch tmp1090 (quote #(vector each-any)))))) (syntax-dispatch tmp1090 (quote ()))))) (syntax-dispatch tmp1090 (quote (any . any)))))) (syntax-dispatch tmp1090 (quote (any any))))) p1087)))))) (lambda (e1112 r1113 w1114 s1115) (let ((e1116 (source-wrap96 e1112 w1114 s1115))) ((lambda (tmp1117) ((lambda (tmp1118) (if tmp1118 (apply (lambda (_1119 val1120 key1121 m1122) (if (andmap (lambda (x1123) (and (id?67 x1123) (not (ellipsis?112 x1123)))) key1121) (let ((x1125 (gen-var115 (quote tmp)))) (list (list (quote lambda) (list x1125) (gen-syntax-case1042 x1125 key1121 m1122 r1113)) (chi103 val1120 r1113 (quote (()))))) (syntax-error e1116 (quote "invalid literals list in")))) tmp1118) (syntax-error tmp1117))) (syntax-dispatch tmp1117 (quote (any any each-any . each-any))))) e1116))))) (set! sc-expand (let ((m1128 (quote e)) (esew1129 (quote (eval)))) (lambda (x1130) (if (and (pair? x1130) (equal? (car x1130) noexpand37)) (cadr x1130) (chi-top102 x1130 (quote ()) (quote ((top))) m1128 esew1129))))) (set! sc-expand3 (let ((m1131 (quote e)) (esew1132 (quote (eval)))) (lambda (x1134 . rest1133) (if (and (pair? x1134) (equal? (car x1134) noexpand37)) (cadr x1134) (chi-top102 x1134 (quote ()) (quote ((top))) (if (null? rest1133) m1131 (car rest1133)) (if (or (null? rest1133) (null? (cdr rest1133))) esew1132 (cadr rest1133))))))) (set! identifier? (lambda (x1135) (nonsymbol-id?66 x1135))) (set! datum->syntax-object (lambda (id1136 datum1137) (begin (let ((x1138 id1136)) (if (not (nonsymbol-id?66 x1138)) (error-hook45 (quote datum->syntax-object) (quote "invalid argument") x1138))) (make-syntax-object52 datum1137 (syntax-object-wrap55 id1136))))) (set! syntax-object->datum (lambda (x1139) (strip114 x1139 (quote (()))))) (set! generate-temporaries (lambda (ls1140) (begin (let ((x1141 ls1140)) (if (not (list? x1141)) (error-hook45 (quote generate-temporaries) (quote "invalid argument") x1141))) (map (lambda (x1142) (wrap95 (gensym) (quote ((top))))) ls1140)))) (set! free-identifier=? (lambda (x1143 y1144) (begin (let ((x1145 x1143)) (if (not (nonsymbol-id?66 x1145)) (error-hook45 (quote free-identifier=?) (quote "invalid argument") x1145))) (let ((x1146 y1144)) (if (not (nonsymbol-id?66 x1146)) (error-hook45 (quote free-identifier=?) (quote "invalid argument") x1146))) (free-id=?90 x1143 y1144)))) (set! bound-identifier=? (lambda (x1147 y1148) (begin (let ((x1149 x1147)) (if (not (nonsymbol-id?66 x1149)) (error-hook45 (quote bound-identifier=?) (quote "invalid argument") x1149))) (let ((x1150 y1148)) (if (not (nonsymbol-id?66 x1150)) (error-hook45 (quote bound-identifier=?) (quote "invalid argument") x1150))) (bound-id=?91 x1147 y1148)))) (set! syntax-error (lambda (object1152 . messages1151) (begin (for-each (lambda (x1153) (let ((x1154 x1153)) (if (not (string? x1154)) (error-hook45 (quote syntax-error) (quote "invalid argument") x1154)))) messages1151) (let ((message1155 (if (null? messages1151) (quote "invalid syntax") (apply string-append messages1151)))) (error-hook45 (quote #f) message1155 (strip114 object1152 (quote (())))))))) (set! install-global-transformer (lambda (sym1156 v1157) (begin (let ((x1158 sym1156)) (if (not (symbol? x1158)) (error-hook45 (quote define-syntax) (quote "invalid argument") x1158))) (let ((x1159 v1157)) (if (not (procedure? x1159)) (error-hook45 (quote define-syntax) (quote "invalid argument") x1159))) (global-extend65 (quote macro) sym1156 v1157)))) (letrec ((match1164 (lambda (e1165 p1166 w1167 r1168) (cond ((not r1168) (quote #f)) ((eq? p1166 (quote any)) (cons (wrap95 e1165 w1167) r1168)) ((syntax-object?53 e1165) (match*1163 (let ((e1169 (syntax-object-expression54 e1165))) (if (annotation?42 e1169) (annotation-expression e1169) e1169)) p1166 (join-wraps86 w1167 (syntax-object-wrap55 e1165)) r1168)) (else (match*1163 (let ((e1170 e1165)) (if (annotation?42 e1170) (annotation-expression e1170) e1170)) p1166 w1167 r1168))))) (match*1163 (lambda (e1171 p1172 w1173 r1174) (cond ((null? p1172) (and (null? e1171) r1174)) ((pair? p1172) (and (pair? e1171) (match1164 (car e1171) (car p1172) w1173 (match1164 (cdr e1171) (cdr p1172) w1173 r1174)))) ((eq? p1172 (quote each-any)) (let ((l1175 (match-each-any1161 e1171 w1173))) (and l1175 (cons l1175 r1174)))) (else (let ((t1176 (vector-ref p1172 (quote 0)))) (if (memv t1176 (quote (each))) (if (null? e1171) (match-empty1162 (vector-ref p1172 (quote 1)) r1174) (let ((l1177 (match-each1160 e1171 (vector-ref p1172 (quote 1)) w1173))) (and l1177 (let collect1178 ((l1179 l1177)) (if (null? (car l1179)) r1174 (cons (map car l1179) (collect1178 (map cdr l1179)))))))) (if (memv t1176 (quote (free-id))) (and (id?67 e1171) (free-id=?90 (wrap95 e1171 w1173) (vector-ref p1172 (quote 1))) r1174) (if (memv t1176 (quote (atom))) (and (equal? (vector-ref p1172 (quote 1)) (strip114 e1171 w1173)) r1174) (if (memv t1176 (quote (vector))) (and (vector? e1171) (match1164 (vector->list e1171) (vector-ref p1172 (quote 1)) w1173 r1174))))))))))) (match-empty1162 (lambda (p1180 r1181) (cond ((null? p1180) r1181) ((eq? p1180 (quote any)) (cons (quote ()) r1181)) ((pair? p1180) (match-empty1162 (car p1180) (match-empty1162 (cdr p1180) r1181))) ((eq? p1180 (quote each-any)) (cons (quote ()) r1181)) (else (let ((t1182 (vector-ref p1180 (quote 0)))) (if (memv t1182 (quote (each))) (match-empty1162 (vector-ref p1180 (quote 1)) r1181) (if (memv t1182 (quote (free-id atom))) r1181 (if (memv t1182 (quote (vector))) (match-empty1162 (vector-ref p1180 (quote 1)) r1181))))))))) (match-each-any1161 (lambda (e1183 w1184) (cond ((annotation?42 e1183) (match-each-any1161 (annotation-expression e1183) w1184)) ((pair? e1183) (let ((l1185 (match-each-any1161 (cdr e1183) w1184))) (and l1185 (cons (wrap95 (car e1183) w1184) l1185)))) ((null? e1183) (quote ())) ((syntax-object?53 e1183) (match-each-any1161 (syntax-object-expression54 e1183) (join-wraps86 w1184 (syntax-object-wrap55 e1183)))) (else (quote #f))))) (match-each1160 (lambda (e1186 p1187 w1188) (cond ((annotation?42 e1186) (match-each1160 (annotation-expression e1186) p1187 w1188)) ((pair? e1186) (let ((first1189 (match1164 (car e1186) p1187 w1188 (quote ())))) (and first1189 (let ((rest1190 (match-each1160 (cdr e1186) p1187 w1188))) (and rest1190 (cons first1189 rest1190)))))) ((null? e1186) (quote ())) ((syntax-object?53 e1186) (match-each1160 (syntax-object-expression54 e1186) p1187 (join-wraps86 w1188 (syntax-object-wrap55 e1186)))) (else (quote #f)))))) (set! syntax-dispatch (lambda (e1191 p1192) (cond ((eq? p1192 (quote any)) (list e1191)) ((syntax-object?53 e1191) (match*1163 (let ((e1193 (syntax-object-expression54 e1191))) (if (annotation?42 e1193) (annotation-expression e1193) e1193)) p1192 (syntax-object-wrap55 e1191) (quote ()))) (else (match*1163 (let ((e1194 e1191)) (if (annotation?42 e1194) (annotation-expression e1194) e1194)) p1192 (quote (())) (quote ()))))))))) +(install-global-transformer (quote with-syntax) (lambda (x1195) ((lambda (tmp1196) ((lambda (tmp1197) (if tmp1197 (apply (lambda (_1198 e11199 e21200) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11199 e21200))) tmp1197) ((lambda (tmp1202) (if tmp1202 (apply (lambda (_1203 out1204 in1205 e11206 e21207) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) in1205 (quote ()) (list out1204 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11206 e21207))))) tmp1202) ((lambda (tmp1209) (if tmp1209 (apply (lambda (_1210 out1211 in1212 e11213 e21214) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) in1212) (quote ()) (list out1211 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11213 e21214))))) tmp1209) (syntax-error tmp1196))) (syntax-dispatch tmp1196 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp1196 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp1196 (quote (any () any . each-any))))) x1195))) +(install-global-transformer (quote syntax-rules) (lambda (x1218) ((lambda (tmp1219) ((lambda (tmp1220) (if tmp1220 (apply (lambda (_1221 k1222 keyword1223 pattern1224 template1225) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons k1222 (map (lambda (tmp1228 tmp1227) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) tmp1227) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) tmp1228))) template1225 pattern1224)))))) tmp1220) (syntax-error tmp1219))) (syntax-dispatch tmp1219 (quote (any each-any . #(each ((any . any) any))))))) x1218))) +(install-global-transformer (quote let*) (lambda (x1229) ((lambda (tmp1230) ((lambda (tmp1231) (if (if tmp1231 (apply (lambda (let*1232 x1233 v1234 e11235 e21236) (andmap identifier? x1233)) tmp1231) (quote #f)) (apply (lambda (let*1238 x1239 v1240 e11241 e21242) (let f1243 ((bindings1244 (map list x1239 v1240))) (if (null? bindings1244) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote ()) (cons e11241 e21242))) ((lambda (tmp1248) ((lambda (tmp1249) (if tmp1249 (apply (lambda (body1250 binding1251) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list binding1251) body1250)) tmp1249) (syntax-error tmp1248))) (syntax-dispatch tmp1248 (quote (any any))))) (list (f1243 (cdr bindings1244)) (car bindings1244)))))) tmp1231) (syntax-error tmp1230))) (syntax-dispatch tmp1230 (quote (any #(each (any any)) any . each-any))))) x1229))) +(install-global-transformer (quote do) (lambda (orig-x1252) ((lambda (tmp1253) ((lambda (tmp1254) (if tmp1254 (apply (lambda (_1255 var1256 init1257 step1258 e01259 e11260 c1261) ((lambda (tmp1262) ((lambda (tmp1263) (if tmp1263 (apply (lambda (step1264) ((lambda (tmp1265) ((lambda (tmp1266) (if tmp1266 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list var1256 init1257) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) e01259) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append c1261 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) step1264))))))) tmp1266) ((lambda (tmp1271) (if tmp1271 (apply (lambda (e11272 e21273) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list var1256 init1257) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) e01259 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (cons e11272 e21273)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append c1261 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) step1264))))))) tmp1271) (syntax-error tmp1265))) (syntax-dispatch tmp1265 (quote (any . each-any)))))) (syntax-dispatch tmp1265 (quote ())))) e11260)) tmp1263) (syntax-error tmp1262))) (syntax-dispatch tmp1262 (quote each-any)))) (map (lambda (v1280 s1281) ((lambda (tmp1282) ((lambda (tmp1283) (if tmp1283 (apply (lambda () v1280) tmp1283) ((lambda (tmp1284) (if tmp1284 (apply (lambda (e1285) e1285) tmp1284) ((lambda (_1286) (syntax-error orig-x1252)) tmp1282))) (syntax-dispatch tmp1282 (quote (any)))))) (syntax-dispatch tmp1282 (quote ())))) s1281)) var1256 step1258))) tmp1254) (syntax-error tmp1253))) (syntax-dispatch tmp1253 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1252))) +(install-global-transformer (quote quasiquote) (letrec ((quasicons1289 (lambda (x1293 y1294) ((lambda (tmp1295) ((lambda (tmp1296) (if tmp1296 (apply (lambda (x1297 y1298) ((lambda (tmp1299) ((lambda (tmp1300) (if tmp1300 (apply (lambda (dy1301) ((lambda (tmp1302) ((lambda (tmp1303) (if tmp1303 (apply (lambda (dx1304) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons dx1304 dy1301))) tmp1303) ((lambda (_1305) (if (null? dy1301) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1297) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1297 y1298))) tmp1302))) (syntax-dispatch tmp1302 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) x1297)) tmp1300) ((lambda (tmp1306) (if tmp1306 (apply (lambda (stuff1307) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons x1297 stuff1307))) tmp1306) ((lambda (else1308) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1297 y1298)) tmp1299))) (syntax-dispatch tmp1299 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . any)))))) (syntax-dispatch tmp1299 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) y1298)) tmp1296) (syntax-error tmp1295))) (syntax-dispatch tmp1295 (quote (any any))))) (list x1293 y1294)))) (quasiappend1290 (lambda (x1309 y1310) ((lambda (tmp1311) ((lambda (tmp1312) (if tmp1312 (apply (lambda (x1313 y1314) ((lambda (tmp1315) ((lambda (tmp1316) (if tmp1316 (apply (lambda () x1313) tmp1316) ((lambda (_1317) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1313 y1314)) tmp1315))) (syntax-dispatch tmp1315 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) ()))))) y1314)) tmp1312) (syntax-error tmp1311))) (syntax-dispatch tmp1311 (quote (any any))))) (list x1309 y1310)))) (quasivector1291 (lambda (x1318) ((lambda (tmp1319) ((lambda (x1320) ((lambda (tmp1321) ((lambda (tmp1322) (if tmp1322 (apply (lambda (x1323) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (list->vector x1323))) tmp1322) ((lambda (tmp1325) (if tmp1325 (apply (lambda (x1326) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1326)) tmp1325) ((lambda (_1328) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1320)) tmp1321))) (syntax-dispatch tmp1321 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . each-any)))))) (syntax-dispatch tmp1321 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) each-any))))) x1320)) tmp1319)) x1318))) (quasi1292 (lambda (p1329 lev1330) ((lambda (tmp1331) ((lambda (tmp1332) (if tmp1332 (apply (lambda (p1333) (if (= lev1330 (quote 0)) p1333 (quasicons1289 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi1292 (list p1333) (- lev1330 (quote 1)))))) tmp1332) ((lambda (tmp1334) (if tmp1334 (apply (lambda (p1335 q1336) (if (= lev1330 (quote 0)) (quasiappend1290 p1335 (quasi1292 q1336 lev1330)) (quasicons1289 (quasicons1289 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi1292 (list p1335) (- lev1330 (quote 1)))) (quasi1292 q1336 lev1330)))) tmp1334) ((lambda (tmp1337) (if tmp1337 (apply (lambda (p1338) (quasicons1289 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi1292 (list p1338) (+ lev1330 (quote 1))))) tmp1337) ((lambda (tmp1339) (if tmp1339 (apply (lambda (p1340 q1341) (quasicons1289 (quasi1292 p1340 lev1330) (quasi1292 q1341 lev1330))) tmp1339) ((lambda (tmp1342) (if tmp1342 (apply (lambda (x1343) (quasivector1291 (quasi1292 x1343 lev1330))) tmp1342) ((lambda (p1345) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) p1345)) tmp1331))) (syntax-dispatch tmp1331 (quote #(vector each-any)))))) (syntax-dispatch tmp1331 (quote (any . any)))))) (syntax-dispatch tmp1331 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any)))))) (syntax-dispatch tmp1331 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any) . any)))))) (syntax-dispatch tmp1331 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) p1329)))) (lambda (x1346) ((lambda (tmp1347) ((lambda (tmp1348) (if tmp1348 (apply (lambda (_1349 e1350) (quasi1292 e1350 (quote 0))) tmp1348) (syntax-error tmp1347))) (syntax-dispatch tmp1347 (quote (any any))))) x1346)))) +(install-global-transformer (quote include) (lambda (x1351) (letrec ((read-file1352 (lambda (fn1353 k1354) (let ((p1355 (open-input-file fn1353))) (let f1356 ((x1357 (read p1355))) (if (eof-object? x1357) (begin (close-input-port p1355) (quote ())) (cons (datum->syntax-object k1354 x1357) (f1356 (read p1355))))))))) ((lambda (tmp1358) ((lambda (tmp1359) (if tmp1359 (apply (lambda (k1360 filename1361) (let ((fn1362 (syntax-object->datum filename1361))) ((lambda (tmp1363) ((lambda (tmp1364) (if tmp1364 (apply (lambda (exp1365) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))))) exp1365)) tmp1364) (syntax-error tmp1363))) (syntax-dispatch tmp1363 (quote each-any)))) (read-file1352 fn1362 k1360)))) tmp1359) (syntax-error tmp1358))) (syntax-dispatch tmp1358 (quote (any any))))) x1351)))) +(install-global-transformer (quote unquote) (lambda (x1367) ((lambda (tmp1368) ((lambda (tmp1369) (if tmp1369 (apply (lambda (_1370 e1371) (error (quote unquote) (quote "expression ,~s not valid outside of quasiquote") (syntax-object->datum e1371))) tmp1369) (syntax-error tmp1368))) (syntax-dispatch tmp1368 (quote (any any))))) x1367))) +(install-global-transformer (quote unquote-splicing) (lambda (x1372) ((lambda (tmp1373) ((lambda (tmp1374) (if tmp1374 (apply (lambda (_1375 e1376) (error (quote unquote-splicing) (quote "expression ,@~s not valid outside of quasiquote") (syntax-object->datum e1376))) tmp1374) (syntax-error tmp1373))) (syntax-dispatch tmp1373 (quote (any any))))) x1372))) +(install-global-transformer (quote case) (lambda (x1377) ((lambda (tmp1378) ((lambda (tmp1379) (if tmp1379 (apply (lambda (_1380 e1381 m11382 m21383) ((lambda (tmp1384) ((lambda (body1385) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) e1381)) body1385)) tmp1384)) (let f1386 ((clause1387 m11382) (clauses1388 m21383)) (if (null? clauses1388) ((lambda (tmp1390) ((lambda (tmp1391) (if tmp1391 (apply (lambda (e11392 e21393) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11392 e21393))) tmp1391) ((lambda (tmp1395) (if tmp1395 (apply (lambda (k1396 e11397 e21398) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) k1396)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11397 e21398)))) tmp1395) ((lambda (_1401) (syntax-error x1377)) tmp1390))) (syntax-dispatch tmp1390 (quote (each-any any . each-any)))))) (syntax-dispatch tmp1390 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) any . each-any))))) clause1387) ((lambda (tmp1402) ((lambda (rest1403) ((lambda (tmp1404) ((lambda (tmp1405) (if tmp1405 (apply (lambda (k1406 e11407 e21408) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) k1406)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11407 e21408)) rest1403)) tmp1405) ((lambda (_1411) (syntax-error x1377)) tmp1404))) (syntax-dispatch tmp1404 (quote (each-any any . each-any))))) clause1387)) tmp1402)) (f1386 (car clauses1388) (cdr clauses1388))))))) tmp1379) (syntax-error tmp1378))) (syntax-dispatch tmp1378 (quote (any any any . each-any))))) x1377))) +(install-global-transformer (quote identifier-syntax) (lambda (x1412) ((lambda (tmp1413) ((lambda (tmp1414) (if tmp1414 (apply (lambda (_1415 e1416) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) e1416)) (list (cons _1415 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e1416 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))))))))) tmp1414) (syntax-error tmp1413))) (syntax-dispatch tmp1413 (quote (any any))))) x1412))) From a5b265e3f955e0f920146119e14c67e95a22ecd1 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 12 Sep 2000 10:34:09 +0000 Subject: [PATCH 0254/2047] * Eliminate use of low-level symbol property function. --- ice-9/ChangeLog | 4 ++++ ice-9/syncase.scm | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index dc5b843ac..4f4b9716b 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2000-09-12 Dirk Herrmann + + * syncase.scm (putprop): Use the high-level property interface. + 2000-09-12 Mikael Djurfeldt * psyntax.ss (build-lexical-var): Use gentemp instead of gensym; diff --git a/ice-9/syncase.scm b/ice-9/syncase.scm index 6b23bb757..4a5e61b97 100644 --- a/ice-9/syncase.scm +++ b/ice-9/syncase.scm @@ -97,7 +97,7 @@ (let* ((m (current-module)) (v (or (module-variable m symbol) (module-make-local-var! m symbol)))) - (if (assq 'primitive-syntax (symbol-pref symbol)) + (if (symbol-property symbol 'primitive-syntax) (if (eq? (current-module) the-syncase-module) (set-object-property! (module-variable the-root-module symbol) key From 28b06554ca3c019cc1f5996d2890d95b2f1a5a21 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 12 Sep 2000 12:30:36 +0000 Subject: [PATCH 0255/2047] * Unified ssymbols and msymbols to a single symbol type 'scm_tc7_symbol'. * Added scm_string_hash and deprecated scm_strhash. --- NEWS | 10 ++- RELEASE | 4 ++ libguile/ChangeLog | 72 +++++++++++++++++++++ libguile/eval.c | 2 +- libguile/gc.c | 15 ++--- libguile/hash.c | 5 +- libguile/objects.c | 2 +- libguile/print.c | 2 +- libguile/properties.h | 2 +- libguile/strings.c | 25 ++------ libguile/strings.h | 4 +- libguile/symbols.c | 146 +++++++++++++++++------------------------- libguile/symbols.h | 56 +++++++--------- libguile/tag.c | 2 +- libguile/tags.h | 14 ++-- 15 files changed, 193 insertions(+), 168 deletions(-) diff --git a/NEWS b/NEWS index 4bbbbc91f..f98a4b61c 100644 --- a/NEWS +++ b/NEWS @@ -136,7 +136,7 @@ of this variable is (and has been) not fully safe anyway. ** Deprecated macros: SCM_OUTOFRANGE, SCM_NALLOC, SCM_HUP_SIGNAL, SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD, -SCM_ORD_SIG, SCM_NUM_SIGS +SCM_ORD_SIG, SCM_NUM_SIGS, SCM_SYMBOL_SLOTS, SCM_SLOTS Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of SCM_OUTOFRANGE. Use scm_memory_error instead of SCM_NALLOC. @@ -147,6 +147,10 @@ Use scm_memory_error instead of SCM_NALLOC. Use scm_catch or scm_lazy_catch from throw.[ch] instead. +** Deprecated function: scm_strhash + +Use scm_string_hash instead. + ** scm_gensym has changed prototype scm_gensym now only takes one argument. @@ -155,6 +159,10 @@ scm_gensym now only takes one argument. The builtin `gentemp' has now become a primitive. +** Deprecated type tags: scm_tc7_ssymbol, scm_tc7_msymbol, scm_tcs_symbols + +There is now only a single symbol type scm_tc7_symbol. + Changes since Guile 1.3.4: diff --git a/RELEASE b/RELEASE index c13ae47c6..ff52517db 100644 --- a/RELEASE +++ b/RELEASE @@ -56,6 +56,10 @@ In release 1.6: - remove support for "#&" reader syntax in (ice-9 optargs). - remove scm_make_shared_substring - remove scm_read_only_string_p +- remove scm_strhash +- remove scm_tc7_ssymbol +- remove scm_tc7_msymbol +- remove scm_tcs_symbols Modules sort.c and random.c should be factored out into separate modules (but still be distributed with guile-core) when we get a new diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 38a472df6..fb44cce9e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,75 @@ +2000-09-12 Dirk Herrmann + + This patch unifies the formerly distinct ssymbol and msymbol types + to a common symbol type scm_tc7_symbol. The representation of the + new symbol type uses a double cell with the following layout: + , where the car of + prop-pair holds the symbol's function property and the cdr of + prop-pair holds the symbol's other properties. In the long run, + these properties will be removed. Then, the generic property + functions will be uses. + + * eval.c (SCM_CEVAL), objects.c (scm_class_of), print.c + (scm_iprin1), tag.c (scm_tag): Use scm_tc7_symbol instead of + scm_tc7_ssymbol, scm_tc7_msymbol or scm_tcs_symbols. + + * gc.c (scm_gc_mark): Mark the symbols property pair. + + (scm_gc_sweep): There are no symbol slots any more. + + * hash.c (scm_hasher): Instead of re-calculating the hash value + of a symbol, use the raw_hash value stored in the symbol itself. + + * properties.h: Fix typo. + + * strings.[ch] (scm_makstr, scm_makfromstr): The slot parameter + is not used any more. + + * symbols.[ch] (scm_strhash): Deprecated, replaced by a macro. + + (scm_intern_obarray_soft): Made softness parameter unsigned. + + (scm_string_hash): New function with the same functionality as + scm_strhash had before, except that the hash value is not adjusted + to a hash table size. Instead, the 'raw' hash value is returned. + + * symbols.c (duplicate_string): New static convenience function. + + (scm_sym2vcell, scm_sym2ovcell_soft, scm_intern_obarray_soft): + Renamed local variable from scm_hash to hash. + + (scm_intern_obarray_soft): Don't check for a negative softness + any more. When generating symbol cells, use the new layout and + store the raw hash value in the symbol's cell. + + (scm_symbol_to_string): Removed unnecessary cast. + + (scm_intern_symbol, scm_unintern_symbol): Use scm_string_hash to + determine the hash values. + + (msymbolize): Removed. + + (scm_symbol_fref, scm_symbol_pref, scm_symbol_fset_x, + scm_symbol_pset_x, scm_symbol_hash): No need to distinguish + between different symbol types any more. + + (scm_symbol_hash): Comment fixed. + + * symbols.h: Comment about the distinction between ssymbols and + msymbols removed. + + (SCM_SYMBOLP, SCM_ROSTRINGP): No need to distinguish between + different symbol types any more. + + (SCM_PROP_SLOTS, SCM_SET_PROP_SLOTS): Added. + + (SCM_SYMBOL_FUNC, SCM_SET_SYMBOL_FUNC, SCM_SYMBOL_PROPS, + SCM_SET_SYMBOL_PROPS, SCM_SYMBOL_HASH, SCM_SET_SYMBOL_HASH): Use + the new symbol cell layout. + + * tags.h (scm_tc7_ssymbol, scm_tc7_msymbol, scm_tcs_symbols): + Deprecated. + 2000-09-12 Mikael Djurfeldt * symbols.h (scm_gentemp): Declared. diff --git a/libguile/eval.c b/libguile/eval.c index 86b21f6e0..effa23b56 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1913,7 +1913,7 @@ dispatch: SCM_TICK; switch (SCM_TYP7 (x)) { - case scm_tcs_symbols: + case scm_tc7_symbol: /* Only happens when called at top level. */ x = scm_cons (x, SCM_UNDEFINED); diff --git a/libguile/gc.c b/libguile/gc.c index 20883d300..0463cba46 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1313,11 +1313,9 @@ gc_mark_nimp: } break; - case scm_tc7_msymbol: - scm_gc_mark (SCM_SYMBOL_FUNC (ptr)); - ptr = SCM_SYMBOL_PROPS (ptr); + case scm_tc7_symbol: + ptr = SCM_PROP_SLOTS (ptr); goto gc_mark_loop; - case scm_tc7_ssymbol: case scm_tcs_subrs: break; case scm_tc7_port: @@ -1653,17 +1651,14 @@ scm_gc_sweep () case scm_tc7_string: m += SCM_HUGE_LENGTH (scmptr) + 1; goto freechars; - case scm_tc7_msymbol: - m += (SCM_LENGTH (scmptr) + 1 - + (SCM_CHARS (scmptr) - (char *) SCM_SLOTS (scmptr))); - scm_must_free ((char *)SCM_SLOTS (scmptr)); + case scm_tc7_symbol: + m += SCM_LENGTH (scmptr) + 1; + scm_must_free (SCM_CHARS (scmptr)); break; case scm_tc7_contin: m += SCM_LENGTH (scmptr) * sizeof (SCM_STACKITEM) + sizeof (scm_contregs); if (SCM_VELTS (scmptr)) goto freechars; - case scm_tc7_ssymbol: - break; case scm_tcs_subrs: /* the various "subrs" (primitives) are never freed */ continue; diff --git a/libguile/hash.c b/libguile/hash.c index a70f4ceaa..be1f33133 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -116,10 +116,11 @@ scm_hasher(SCM obj, unsigned long n, scm_sizet d) case scm_tc16_complex: obj = scm_number_to_string(obj, SCM_MAKINUM(10)); } - case scm_tcs_symbols: case scm_tc7_string: case scm_tc7_substring: - return scm_strhash(SCM_ROUCHARS(obj), (scm_sizet) SCM_ROLENGTH(obj), n); + return scm_string_hash (SCM_ROUCHARS (obj), SCM_ROLENGTH (obj)) % n; + case scm_tc7_symbol: + return SCM_SYMBOL_HASH (obj) % n; case scm_tc7_wvect: case scm_tc7_vector: { diff --git a/libguile/objects.c b/libguile/objects.c index b8c6ac0dd..3c70ea090 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -120,7 +120,7 @@ scm_class_of (SCM x) return scm_class_pair; case scm_tcs_closures: return scm_class_procedure; - case scm_tcs_symbols: + case scm_tc7_symbol: return scm_class_symbol; case scm_tc7_vector: case scm_tc7_wvect: diff --git a/libguile/print.c b/libguile/print.c index 5b3e35e69..99d7be796 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -479,7 +479,7 @@ taloop: scm_lfwrite (SCM_ROCHARS (exp), (scm_sizet) SCM_ROLENGTH (exp), port); break; - case scm_tcs_symbols: + case scm_tc7_symbol: { int pos; int end; diff --git a/libguile/properties.h b/libguile/properties.h index e256046a7..1a3298626 100644 --- a/libguile/properties.h +++ b/libguile/properties.h @@ -53,7 +53,7 @@ SCM scm_primitive_property_del_x (SCM prop, SCM obj); void scm_init_properties (void); -#endif /* PROPEERTIES_H */ +#endif /* PROPERTIES_H */ /* Local Variables: diff --git a/libguile/strings.c b/libguile/strings.c index 1c4df1da1..35733e66d 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -125,27 +125,16 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1, #undef FUNC_NAME SCM -scm_makstr (long len, int slots) +scm_makstr (long len, int dummy) { SCM s; - scm_bits_t * mem; + char *mem = (char *) scm_must_malloc (len + 1, "scm_makstr"); + mem[len] = 0; SCM_NEWCELL (s); - --slots; - SCM_REDEFER_INTS; - mem = (scm_bits_t *) scm_must_malloc (sizeof (scm_bits_t) * (slots + 1) - + len + 1, "scm_makstr"); - if (slots >= 0) - { - int x; - mem[slots] = (scm_bits_t) mem; - for (x = 0; x < slots; ++x) - mem[x] = SCM_UNPACK (SCM_BOOL_F); - } - SCM_SETCHARS (s, (char *) (mem + slots + 1)); + SCM_SETCHARS (s, mem); SCM_SETLENGTH (s, len, scm_tc7_string); - SCM_REALLOW_INTS; - SCM_CHARS (s)[len] = 0; + return s; } @@ -194,9 +183,9 @@ scm_take0str (char *s) } SCM -scm_makfromstr (const char *src, scm_sizet len, int slots) +scm_makfromstr (const char *src, scm_sizet len, int dummy) { - SCM s = scm_makstr (len, slots); + SCM s = scm_makstr (len, 0); char *dst = SCM_CHARS (s); while (len--) diff --git a/libguile/strings.h b/libguile/strings.h index 1b8189850..b56ab91f5 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -62,11 +62,11 @@ extern SCM scm_string_p (SCM x); extern SCM scm_read_only_string_p (SCM x); extern SCM scm_string (SCM chrs); -extern SCM scm_makstr (long len, int slots); +extern SCM scm_makstr (long len, int); extern SCM scm_makfromstrs (int argc, char **argv); extern SCM scm_take_str (char *s, int len); extern SCM scm_take0str (char *s); -extern SCM scm_makfromstr (const char *src, scm_sizet len, int slots); +extern SCM scm_makfromstr (const char *src, scm_sizet len, int); extern SCM scm_makfrom0str (const char *src); extern SCM scm_makfrom0str_opt (const char *src); extern SCM scm_make_string (SCM k, SCM chr); diff --git a/libguile/symbols.c b/libguile/symbols.c index b67c85025..641ea8a17 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -66,27 +66,35 @@ - /* NUM_HASH_BUCKETS is the number of symbol scm_hash table buckets. */ #define NUM_HASH_BUCKETS 137 +static char * +duplicate_string (const char * src, unsigned long length) +{ + char * dst = scm_must_malloc (length + 1, "duplicate_string"); + memcpy (dst, src, length + 1); + return dst; +} + + /* {Symbols} */ unsigned long -scm_strhash (const unsigned char *str, scm_sizet len, unsigned long n) +scm_string_hash (const unsigned char *str, scm_sizet len) { if (len > 5) { scm_sizet i = 5; - unsigned long h = 264 % n; + unsigned long h = 264; while (i--) - h = ((h << 8) + ((unsigned) (scm_downcase (str[h % len])))) % n; + h = (h << 8) + ((unsigned) (scm_downcase (str[h % len]))); return h; } else @@ -94,11 +102,12 @@ scm_strhash (const unsigned char *str, scm_sizet len, unsigned long n) scm_sizet i = len; unsigned long h = 0; while (i) - h = ((h << 8) + ((unsigned) (scm_downcase (str[--i])))) % n; + h = (h << 8) + ((unsigned) (scm_downcase (str[--i]))); return h; } } + int scm_symhash_dim = NUM_HASH_BUCKETS; @@ -133,11 +142,11 @@ scm_sym2vcell (SCM sym, SCM thunk, SCM definep) SCM lsym; SCM * lsymp; SCM z; - scm_sizet scm_hash = scm_strhash (SCM_UCHARS (sym), (scm_sizet) SCM_LENGTH (sym), - (unsigned long) scm_symhash_dim); + scm_sizet hash + = scm_string_hash (SCM_UCHARS (sym), SCM_LENGTH (sym)) % scm_symhash_dim; SCM_DEFER_INTS; - for (lsym = SCM_VELTS (scm_symhash)[scm_hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) + for (lsym = SCM_VELTS (scm_symhash)[hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) { z = SCM_CAR (lsym); if (SCM_EQ_P (SCM_CAR (z), sym)) @@ -147,7 +156,7 @@ scm_sym2vcell (SCM sym, SCM thunk, SCM definep) } } - for (lsym = *(lsymp = &SCM_VELTS (scm_weak_symhash)[scm_hash]); + for (lsym = *(lsymp = &SCM_VELTS (scm_weak_symhash)[hash]); SCM_NIMP (lsym); lsym = *(lsymp = SCM_CDRLOC (lsym))) { @@ -158,8 +167,8 @@ scm_sym2vcell (SCM sym, SCM thunk, SCM definep) { /* Move handle from scm_weak_symhash to scm_symhash. */ *lsymp = SCM_CDR (lsym); - SCM_SETCDR (lsym, SCM_VELTS(scm_symhash)[scm_hash]); - SCM_VELTS(scm_symhash)[scm_hash] = lsym; + SCM_SETCDR (lsym, SCM_VELTS(scm_symhash)[hash]); + SCM_VELTS(scm_symhash)[hash] = lsym; } SCM_ALLOW_INTS; return z; @@ -178,13 +187,10 @@ SCM scm_sym2ovcell_soft (SCM sym, SCM obarray) { SCM lsym, z; - scm_sizet scm_hash; - - scm_hash = scm_strhash (SCM_UCHARS (sym), - (scm_sizet) SCM_LENGTH (sym), - SCM_LENGTH (obarray)); + scm_sizet hash + = scm_string_hash (SCM_UCHARS (sym), SCM_LENGTH (sym)) % SCM_LENGTH (obarray); SCM_REDEFER_INTS; - for (lsym = SCM_VELTS (obarray)[scm_hash]; + for (lsym = SCM_VELTS (obarray)[hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) { @@ -235,45 +241,35 @@ scm_sym2ovcell (SCM sym, SCM obarray) SCM -scm_intern_obarray_soft (const char *name,scm_sizet len,SCM obarray,int softness) +scm_intern_obarray_soft (const char *name,scm_sizet len,SCM obarray,unsigned int softness) { + scm_sizet raw_hash = scm_string_hash ((unsigned char *) name, len); + scm_sizet hash; SCM lsym; - SCM z; - register scm_sizet i; - register unsigned char *tmp; - scm_sizet scm_hash; SCM_REDEFER_INTS; if (SCM_FALSEP (obarray)) { - scm_hash = scm_strhash ((unsigned char *) name, len, 1019); + hash = raw_hash % 1019; goto uninterned_symbol; } - scm_hash = scm_strhash ((unsigned char *) name, len, SCM_LENGTH (obarray)); - - /* softness == -1 used to mean that it was known that the symbol - wasn't already in the obarray. I don't think there are any - callers that use that case any more, but just in case... - -- JimB, Oct 1996 */ - if (softness == -1) - abort (); + hash = raw_hash % SCM_LENGTH (obarray); retry_new_obarray: - for (lsym = SCM_VELTS (obarray)[scm_hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) + for (lsym = SCM_VELTS (obarray)[hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) { - z = SCM_CAR (lsym); - z = SCM_CAR (z); - tmp = SCM_UCHARS (z); + scm_sizet i; + SCM a = SCM_CAR (lsym); + SCM z = SCM_CAR (a); + unsigned char *tmp = SCM_UCHARS (z); if (SCM_LENGTH (z) != len) goto trynext; for (i = len; i--;) if (((unsigned char *) name)[i] != tmp[i]) goto trynext; { - SCM a; - a = SCM_CAR (lsym); SCM_REALLOW_INTS; return a; } @@ -293,10 +289,12 @@ scm_intern_obarray_soft (const char *name,scm_sizet len,SCM obarray,int softness return SCM_BOOL_F; } - lsym = scm_makfromstr (name, len, SCM_SYMBOL_SLOTS); + SCM_NEWCELL2 (lsym); + SCM_SETCHARS (lsym, duplicate_string (name, len)); + SCM_SET_SYMBOL_HASH (lsym, raw_hash); + SCM_SET_PROP_SLOTS (lsym, scm_cons (SCM_BOOL_F, SCM_BOOL_F)); + SCM_SETLENGTH (lsym, (long) len, scm_tc7_symbol); - SCM_SETLENGTH (lsym, (long) len, scm_tc7_msymbol); - SCM_SYMBOL_HASH (lsym) = scm_hash; SCM_SET_SYMBOL_PROPS (lsym, SCM_EOL); if (SCM_FALSEP (obarray)) { @@ -319,8 +317,8 @@ scm_intern_obarray_soft (const char *name,scm_sizet len,SCM obarray,int softness SCM_SETCAR (a, lsym); SCM_SETCDR (a, SCM_UNDEFINED); SCM_SETCAR (b, a); - SCM_SETCDR (b, SCM_VELTS(obarray)[scm_hash]); - SCM_VELTS(obarray)[scm_hash] = b; + SCM_SETCDR (b, SCM_VELTS(obarray)[hash]); + SCM_VELTS(obarray)[hash] = b; SCM_REALLOW_INTS; return SCM_CAR (b); } @@ -364,14 +362,17 @@ scm_sysintern0_no_module_lookup (const char *name) { SCM lsym; scm_sizet len = strlen (name); - scm_sizet scm_hash = scm_strhash ((unsigned char *) name, - len, - (unsigned long) scm_symhash_dim); - SCM_NEWCELL (lsym); - SCM_SETLENGTH (lsym, (long) len, scm_tc7_ssymbol); + scm_sizet raw_hash = scm_string_hash ((unsigned char *) name, len); + scm_sizet hash = raw_hash % scm_symhash_dim; + + SCM_NEWCELL2 (lsym); SCM_SETCHARS (lsym, name); + SCM_SET_SYMBOL_HASH (lsym, raw_hash); + SCM_SET_PROP_SLOTS (lsym, scm_cons (SCM_BOOL_F, SCM_BOOL_F)); + SCM_SETLENGTH (lsym, (long) len, scm_tc7_symbol); + lsym = scm_cons (lsym, SCM_UNDEFINED); - SCM_VELTS (scm_symhash)[scm_hash] = scm_cons (lsym, SCM_VELTS (scm_symhash)[scm_hash]); + SCM_VELTS (scm_symhash)[hash] = scm_cons (lsym, SCM_VELTS (scm_symhash)[hash]); SCM_ALLOW_INTS; return lsym; } @@ -459,8 +460,8 @@ SCM_DEFINE (scm_symbol_to_string, "symbol->string", 1, 0, 0, "@end format") #define FUNC_NAME s_scm_symbol_to_string { - SCM_VALIDATE_SYMBOL (1,s); - return scm_makfromstr(SCM_CHARS(s), (scm_sizet)SCM_LENGTH(s), 0); + SCM_VALIDATE_SYMBOL (1, s); + return scm_makfromstr (SCM_CHARS (s), SCM_LENGTH (s), 0); } #undef FUNC_NAME @@ -557,7 +558,7 @@ SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0, if (SCM_FALSEP (o)) o = scm_symhash; SCM_VALIDATE_VECTOR (1,o); - hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o)); + hval = scm_string_hash (SCM_UCHARS (s), SCM_LENGTH (s)) % SCM_LENGTH (o); /* If the symbol is already interned, simply return. */ SCM_REDEFER_INTS; { @@ -594,7 +595,7 @@ SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0, if (SCM_FALSEP (o)) o = scm_symhash; SCM_VALIDATE_VECTOR (1,o); - hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o)); + hval = scm_string_hash (SCM_UCHARS (s), SCM_LENGTH (s)) % SCM_LENGTH (o); SCM_DEFER_INTS; { SCM lsym_follow; @@ -700,22 +701,6 @@ SCM_DEFINE (scm_symbol_set_x, "symbol-set!", 3, 0, 0, } #undef FUNC_NAME -static void -msymbolize (SCM s) -{ - SCM string; - string = scm_makfromstr (SCM_CHARS (s), SCM_LENGTH (s), SCM_SYMBOL_SLOTS); - SCM_SETCHARS (s, SCM_CHARS (string)); - SCM_SETLENGTH (s, SCM_LENGTH (s), scm_tc7_msymbol); - SCM_SETCDR (string, SCM_EOL); - SCM_SETCAR (string, SCM_EOL); - SCM_SET_SYMBOL_PROPS (s, SCM_EOL); - /* If it's a tc7_ssymbol, it comes from scm_symhash */ - SCM_SYMBOL_HASH (s) = scm_strhash (SCM_UCHARS (s), - (scm_sizet) SCM_LENGTH (s), - SCM_LENGTH (scm_symhash)); -} - SCM_DEFINE (scm_symbol_fref, "symbol-fref", 1, 0, 0, (SCM s), @@ -723,10 +708,6 @@ SCM_DEFINE (scm_symbol_fref, "symbol-fref", 1, 0, 0, #define FUNC_NAME s_scm_symbol_fref { SCM_VALIDATE_SYMBOL (1,s); - SCM_DEFER_INTS; - if (SCM_TYP7(s) == scm_tc7_ssymbol) - msymbolize (s); - SCM_ALLOW_INTS; return SCM_SYMBOL_FUNC (s); } #undef FUNC_NAME @@ -738,10 +719,6 @@ SCM_DEFINE (scm_symbol_pref, "symbol-pref", 1, 0, 0, #define FUNC_NAME s_scm_symbol_pref { SCM_VALIDATE_SYMBOL (1,s); - SCM_DEFER_INTS; - if (SCM_TYP7(s) == scm_tc7_ssymbol) - msymbolize (s); - SCM_ALLOW_INTS; return SCM_SYMBOL_PROPS (s); } #undef FUNC_NAME @@ -753,10 +730,6 @@ SCM_DEFINE (scm_symbol_fset_x, "symbol-fset!", 2, 0, 0, #define FUNC_NAME s_scm_symbol_fset_x { SCM_VALIDATE_SYMBOL (1,s); - SCM_DEFER_INTS; - if (SCM_TYP7(s) == scm_tc7_ssymbol) - msymbolize (s); - SCM_ALLOW_INTS; SCM_SET_SYMBOL_FUNC (s, val); return SCM_UNSPECIFIED; } @@ -770,8 +743,6 @@ SCM_DEFINE (scm_symbol_pset_x, "symbol-pset!", 2, 0, 0, { SCM_VALIDATE_SYMBOL (1,s); SCM_DEFER_INTS; - if (SCM_TYP7(s) == scm_tc7_ssymbol) - msymbolize (s); SCM_SET_SYMBOL_PROPS (s, val); SCM_ALLOW_INTS; return SCM_UNSPECIFIED; @@ -780,15 +751,12 @@ SCM_DEFINE (scm_symbol_pset_x, "symbol-pset!", 2, 0, 0, SCM_DEFINE (scm_symbol_hash, "symbol-hash", 1, 0, 0, - (SCM s), - "Return the hash value derived from @var{symbol}'s name, i.e. the integer\n" - "index into @var{symbol}'s obarray at which it is stored.") + (SCM symbol), + "Return a hash value for @var{symbol}.") #define FUNC_NAME s_scm_symbol_hash { - SCM_VALIDATE_SYMBOL (1,s); - if (SCM_TYP7(s) == scm_tc7_ssymbol) - msymbolize (s); - return SCM_MAKINUM (SCM_UNPACK (s) ^ SCM_SYMBOL_HASH (s)); + SCM_VALIDATE_SYMBOL (1, symbol); + return SCM_MAKINUM (SCM_SYMBOL_HASH (symbol)); } #undef FUNC_NAME diff --git a/libguile/symbols.h b/libguile/symbols.h index d2a9af0ee..72a83cdf7 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -53,31 +53,10 @@ extern int scm_symhash_dim; /* SCM_LENGTH(SYM) is the length of SYM's name in characters, and - SCM_CHARS(SYM) is the address of the first character of SYM's name. + * SCM_CHARS(SYM) is the address of the first character of SYM's name. + */ - Beyond that, there are two kinds of symbols: ssymbols and msymbols, - distinguished by the 'S' bit in the type. - - Ssymbols are just uniquified strings. They have a length, chars, - and that's it. They use the scm_tc7_ssymbol tag (S bit clear). - - Msymbols are symbols with extra slots. These slots hold a property - list and a function value (for Emacs Lisp compatibility), and a hash - code. They use the scm_tc7_msymbol tag. - - We'd like SCM_CHARS to work on msymbols just as it does on - ssymbols, so we'll have it point to the symbol's name as usual, and - store a pointer to the slots just before the name in memory. Thus, - you have to do some casting and pointer arithmetic to find the - slots; see the SCM_SLOTS macro. - - In practice, the slots always live just before the pointer to them. - So why not ditch the pointer, and use negative indices to refer to - the slots? That's a good question; ask the author. I think it was - the cognac. */ - -#define SCM_SYMBOLP(x) (SCM_NIMP (x) \ - && (SCM_TYP7S (x) == scm_tc7_ssymbol)) +#define SCM_SYMBOLP(x) (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_symbol)) #define SCM_LENGTH_MAX (0xffffffL) #define SCM_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) @@ -87,16 +66,17 @@ extern int scm_symhash_dim; #define SCM_UCHARS(x) ((unsigned char *) (SCM_CELL_WORD_1 (x))) #define SCM_SETCHARS(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_bits_t) (v))) -#define SCM_SYMBOL_SLOTS 4 -#define SCM_SLOTS(x) ((scm_bits_t *) (* ((scm_bits_t *) SCM_CHARS (x) - 1))) -#define SCM_SYMBOL_FUNC(X) (SCM_PACK (SCM_SLOTS (X) [0])) -#define SCM_SET_SYMBOL_FUNC(X, v) (SCM_SLOTS (X) [0] = SCM_UNPACK (v)) -#define SCM_SYMBOL_PROPS(X) (SCM_PACK (SCM_SLOTS (X) [1])) -#define SCM_SET_SYMBOL_PROPS(X, v) (SCM_SLOTS (X) [1] = SCM_UNPACK (v)) -#define SCM_SYMBOL_HASH(X) (SCM_SLOTS (X) [2]) +#define SCM_PROP_SLOTS(X) (SCM_CELL_WORD_3 (X)) +#define SCM_SET_PROP_SLOTS(X, v) (SCM_SET_CELL_WORD_3 ((X), (v))) +#define SCM_SYMBOL_FUNC(X) (SCM_CAR (SCM_CELL_WORD_3 (X))) +#define SCM_SET_SYMBOL_FUNC(X, v) (SCM_SETCAR (SCM_CELL_WORD_3 (X), (v))) +#define SCM_SYMBOL_PROPS(X) (SCM_CDR (SCM_CELL_WORD_3 (X))) +#define SCM_SET_SYMBOL_PROPS(X, v) (SCM_SETCDR (SCM_CELL_WORD_3 (X), (v))) +#define SCM_SYMBOL_HASH(X) (SCM_CELL_WORD_2 (X)) +#define SCM_SET_SYMBOL_HASH(X, v) (SCM_SET_CELL_WORD_2 ((X), (v))) #define SCM_ROSTRINGP(x) (SCM_NIMP(x) && ((SCM_TYP7S(x)==scm_tc7_string) \ - || (SCM_TYP7S(x) == scm_tc7_ssymbol))) + || (SCM_TYP7(x) == scm_tc7_symbol))) #define SCM_ROCHARS(x) ((char *)((SCM_TYP7(x) == scm_tc7_substring) \ ? SCM_INUM (SCM_CADR (x)) + SCM_CHARS (SCM_CDDR (x)) \ : SCM_CHARS (x))) @@ -115,11 +95,11 @@ extern int scm_symhash_dim; -extern unsigned long scm_strhash (const unsigned char *str, scm_sizet len, unsigned long n); +extern unsigned long scm_string_hash (const unsigned char *str, scm_sizet len); extern SCM scm_sym2vcell (SCM sym, SCM thunk, SCM definep); extern SCM scm_sym2ovcell_soft (SCM sym, SCM obarray); extern SCM scm_sym2ovcell (SCM sym, SCM obarray); -extern SCM scm_intern_obarray_soft (const char *name, scm_sizet len, SCM obarray, int softness); +extern SCM scm_intern_obarray_soft (const char *name, scm_sizet len, SCM obarray, unsigned int softness); extern SCM scm_intern_obarray (const char *name, scm_sizet len, SCM obarray); extern SCM scm_intern (const char *name, scm_sizet len); extern SCM scm_intern0 (const char *name); @@ -148,6 +128,14 @@ extern SCM scm_gensym (SCM prefix); extern SCM scm_gentemp (SCM prefix, SCM obarray); extern void scm_init_symbols (void); + + +#if (SCM_DEBUG_DEPRECATED == 0) + +#define scm_strhash(str, len, n) (scm_string_hash ((str), (len)) % (n)) + +#endif /* SCM_DEBUG_DEPRECATED == 0 */ + #endif /* SYMBOLSH */ /* diff --git a/libguile/tag.c b/libguile/tag.c index b33dc7545..ed60a0d1c 100644 --- a/libguile/tag.c +++ b/libguile/tag.c @@ -118,7 +118,7 @@ SCM_DEFINE (scm_tag, "tag", 1, 0, 0, return SCM_CDR (scm_utag_pair) ; case scm_tcs_closures: return SCM_CDR (scm_utag_closure) ; - case scm_tcs_symbols: + case scm_tc7_symbol: return SCM_CDR (scm_utag_symbol) ; case scm_tc7_vector: return SCM_CDR (scm_utag_vector) ; diff --git a/libguile/tags.h b/libguile/tags.h index dac0cd652..2b8ec0d48 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -221,8 +221,7 @@ typedef long scm_bits_t; * handy property that all bits of the CAR above the * bottom eight can be used to store a length, thus * saving a word in the body itself. Thus, we use them - * for strings, symbols, and vectors (among other - * things). + * for strings and vectors (among other things). * * SCM_LENGTH returns the bits in "length" (see the diagram). * SCM_CHARS returns the data cast to "char *" @@ -333,9 +332,8 @@ typedef long scm_bits_t; -/* couple */ -#define scm_tc7_ssymbol 5 -#define scm_tc7_msymbol 7 +#define scm_tc7_symbol 5 +/* free 7 */ /* couple */ #define scm_tc7_vector 13 @@ -551,12 +549,14 @@ extern char *scm_isymnames[]; /* defined in print.c */ case scm_tc7_subr_3:case scm_tc7_subr_2:case scm_tc7_rpsubr:case scm_tc7_subr_1o:\ case scm_tc7_subr_2o:case scm_tc7_lsubr_2:case scm_tc7_lsubr -#define scm_tcs_symbols scm_tc7_ssymbol:case scm_tc7_msymbol - #if (SCM_DEBUG_DEPRECATED == 0) +#define scm_tc7_ssymbol scm_tc7_symbol +#define scm_tc7_msymbol scm_tc7_symbol +#define scm_tcs_symbols scm_tc7_symbol + #define scm_tc16_flo scm_tc16_real #define scm_tc_flo 0x017fL #define scm_tc_dblr scm_tc16_real From 415052599e7a4e0b6f9de23e7e2023da447f5e45 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 12 Sep 2000 12:42:51 +0000 Subject: [PATCH 0256/2047] * Tests that rely on garbage collection: Be aware of conservative scanning. --- test-suite/ChangeLog | 7 +++++++ test-suite/tests/environments.test | 8 ++++++-- 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 665e1fde2..b0fea8962 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,10 @@ +2000-09-12 Dirk Herrmann + + * tests/environments.test: For tests that rely on garbage + collection, conservative scanning can be a problem. Add a comment + for these tests and make them turn out unresolved if things don't + work as expected. + 2000-09-05 Dirk Herrmann * tests/environments.test: Finished and cleaned up the tests for diff --git a/test-suite/tests/environments.test b/test-suite/tests/environments.test index 8f1f56b42..908ec5ab7 100644 --- a/test-suite/tests/environments.test +++ b/test-suite/tests/environments.test @@ -382,7 +382,9 @@ (environment-observe-weak env func) (gc) (environment-define env 'a 1) - (eqv? (func) 0)))) + (if (not (eqv? (func) 0)) + (throw 'unresolved) ; note: conservative scanning + #t)))) (with-test-prefix "erroneous observers" @@ -1043,7 +1045,9 @@ (environment-observe-weak env func) (gc) (environment-define env 'a 1) - (eqv? (func) 0)))) + (if (not (eqv? (func) 0)) + (throw 'unresolved) ; note: conservative scanning + #t)))) (with-test-prefix "erroneous observers" From 8e93e199f821096a56deea090ab7fccfc07aed2e Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 12 Sep 2000 12:50:13 +0000 Subject: [PATCH 0257/2047] * Redundant SCM_IMP test removed. --- libguile/ChangeLog | 4 ++++ libguile/symbols.c | 5 ++--- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index fb44cce9e..6a8376482 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2000-09-12 Dirk Herrmann + + * symbols.c (scm_symbol_p): Eliminate redundant SCM_IMP test. + 2000-09-12 Dirk Herrmann This patch unifies the formerly distinct ssymbol and msymbol types diff --git a/libguile/symbols.c b/libguile/symbols.c index 641ea8a17..0052b8acc 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -425,12 +425,11 @@ scm_symbol_value0 (const char *name) } SCM_DEFINE (scm_symbol_p, "symbol?", 1, 0, 0, - (SCM obj), + (SCM obj), "Returns @t{#t} if @var{obj} is a symbol, otherwise returns @t{#f}. (r5rs)") #define FUNC_NAME s_scm_symbol_p { - if SCM_IMP(obj) return SCM_BOOL_F; - return SCM_BOOL(SCM_SYMBOLP(obj)); + return SCM_BOOL (SCM_SYMBOLP (obj)); } #undef FUNC_NAME From 1e1384f0bc2eacc52963911f3dbc4a0c3fd35d91 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Tue, 12 Sep 2000 17:00:57 +0000 Subject: [PATCH 0258/2047] * symbols.c (duplicate_string): Don't try to copy the byte after the string. This might not be `\0' and might even not be allocated memory. --- libguile/symbols.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/symbols.c b/libguile/symbols.c index 0052b8acc..903394eac 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -76,7 +76,8 @@ static char * duplicate_string (const char * src, unsigned long length) { char * dst = scm_must_malloc (length + 1, "duplicate_string"); - memcpy (dst, src, length + 1); + memcpy (dst, src, length); + dst[length] = 0; return dst; } From 0282123991f047572abf652f7ea3f33393a6bfa7 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Tue, 12 Sep 2000 17:01:10 +0000 Subject: [PATCH 0259/2047] *** empty log message *** --- libguile/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6a8376482..be8604fbd 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2000-09-12 Mikael Djurfeldt + + * symbols.c (duplicate_string): Don't try to copy the byte after + the string. This might not be `\0' and might even not be + allocated memory. + 2000-09-12 Dirk Herrmann * symbols.c (scm_symbol_p): Eliminate redundant SCM_IMP test. From b1824fc4594b07a4aed3d7fabc91c8e7b659fb50 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Tue, 12 Sep 2000 18:18:39 +0000 Subject: [PATCH 0260/2047] *** empty log message *** --- devel/policy/names.text | 127 ---------------------------------------- 1 file changed, 127 deletions(-) diff --git a/devel/policy/names.text b/devel/policy/names.text index 1c6bbc2f3..e69de29bb 100644 --- a/devel/policy/names.text +++ b/devel/policy/names.text @@ -1,127 +0,0 @@ -[This is currently a collection of information in an unedited state. - Someone will change this soon.] - -The C names for Scheme primitives *always* obey a fixed name -translation scheme: - -scm_XXX where XXX is translated from the Scheme name, except that - - - becomes _ - ! becomes _x - ? becomes _p - % becomes sys_ - -If there's a C variant of something provided at the Scheme level (like -the current scm_internal_dynamic_wind), it has the prefix scm_c_ -instead of scm_. - -A function named scm_c_FOO serves the same purpose as the function -named scm_FOO, except that its interface is tailored for use from C, -while scm_FOO is tailored for use from Scheme, and is probably -exported as a Scheme primitive. - -For example, scm_FOO might expect Scheme procedures as arguments, -while scm_c_FOO might take C function pointers and a passthrough -value. - - -If there's a C function with global scope which is only intended to be -used internally in libguile, it has the prefix scm_i_. - -String literals with global scope has the prefix scm_s_. (Greg -introduced the prefix s_scm_ but this has to change to scm_s_ since -s_scm_ trespasses the user's namespace.) - -Not correct: Those names have module-local scope and does not trespass -user name space. - -Keywords with global scope has the prefix scm_k_. - -Symbols with global scope has the prefix scm_sym_. - -Variable bindings with global scope has the prefix scm_var_. - -Names, in general, have an internal left-to-right order of increasing -specificity: scm_ is least specific. It is often followed by some -type, like `stack', and, finally, the operation. Example: -scm_stack_length. - -There are exceptions, though: - -* If a name is already established at the Scheme level, this defines - the C name through the translation scheme. - -* According to the rule, we should have `SCM_SMOB_DATA_SET', but we - instead have `SCM_SET_SMOB_DATA'. Generally, `set' should be placed - as far left as possible: - - `port-filename' scm_port_filename - `set-port-filename!' scm_set_port_filename_x - - SCM_SMOB_DATA - SCM_SET_SMOB_DATA - -* Guile has a lot of history with lots of different strange names. - Perhaps a major name overhaul can be done at the same time as we go - through Guile's interfaces to checks soundness and theoretical - properties such as type safety. We *should* be a bit careful with - name changes in order not to break existing application code. - -> Further, I'd love it if macros to create scheme values from C values would -> be named SCM_MAKE_... more consitently. Currently, we have SCM_MAKICHAR -> (OK, this one's been made deprecated), SCM_MAKINUM and others. - -I agree. - -> Also, some macros are used for symbols or keywords. The best solution -> would be to use a similar naming scheme for these also. -> -> It's good to talk about improving guile's API. A clean, consistent and -> beautiful api is, in my belief, important for guile's attractivity, and -> makes learning it easier. - -Yes! - -There are still some open points: - -scm_c_XXX : - Only used for C-level variants of a scm_XXX schene primitive, or - rather to be used for everything that is not a scheme primitive? - -scm_i_XXX : - Only for internal _functions_ or rather for everything that is - internal? For example, scm_sym_ is for symbols that may be used by - users, while scm_i_sym_ is used for guile internally? Otherwise we - can't distinguish between C variables holding symbols that are part of - the official API and internally used C variables holding symbols. - -what about boolean variables/constants? scm_bool_? This would fit nicely - with the current macro names SCM_BOOL_T and SCM_BOOL_F. - -what about number variables/constants? scm_num_? There is at least a - SCM_MAKINUM(0) somewhere... - -scm_s_, scm_k_, scm_sym_, scm_var_: - What about macro variants of these? At least, some symbols and - constants are represented as macros. - -Macros in general: - Should internally used macros be called SCM_I_xxx, thus following the - above scheme? - - How do scheme-level names translate if there are macros that do the - same thing? set-car! --> SCM_SETCAR, thus, the '!' is dropped and the - intermediate '-' is dropped. However, this is not done - consistently: sometimes intermediate '-' are _not_ dropped. - - Currently it seem that: - - - becomes sometimes _ and sometimes nothing - ! becomes nothing - ? becomes P for single-word xxx, _P otherwise - % becomes I don't know what. - - -I would prefer if both worlds (functions/variables and macros) were using -similar schemes as far as possible. (I even dislike the _P/P -distinction, but I know that I am strange :-) From 57b74422f6f3c38151f7a716317a25654c87f437 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Thu, 14 Sep 2000 22:43:48 +0000 Subject: [PATCH 0261/2047] *** empty log message *** --- libguile/ChangeLog | 5 +++++ libguile/print.c | 4 ++++ 2 files changed, 9 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index be8604fbd..d55594afe 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-09-14 Gary Houston + + * print.c (scm_iprin1): write the ascii delete character as #\del + instead of '#\', so it can be read back. like in SCM. + 2000-09-12 Mikael Djurfeldt * symbols.c (duplicate_string): Don't try to copy the byte after diff --git a/libguile/print.c b/libguile/print.c index 99d7be796..fe7662c04 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -317,6 +317,10 @@ taloop: scm_puts ("#\\", port); if ((i >= 0) && (i <= ' ') && scm_charnames[i]) scm_puts (scm_charnames[i], port); +#ifndef EBCDIC + else if (i == '\177') + scm_puts (scm_charnames[scm_n_charnames - 1], port); +#endif else if (i < 0 || i > '\177') scm_intprint (i, 8, port); else From bdbfbbfb86485a8336cd9b30cd62f6a63fc1e67f Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 17 Sep 2000 09:24:47 +0000 Subject: [PATCH 0262/2047] 2000-09-17 Gary Houston * configure.in, acconfig.h: remove the GCSE test: it doesn't seem to be reliable on all platforms. --- acconfig.h | 3 --- configure.in | 27 --------------------------- 2 files changed, 30 deletions(-) diff --git a/acconfig.h b/acconfig.h index cf5e0fff2..b7b42bc3d 100644 --- a/acconfig.h +++ b/acconfig.h @@ -154,6 +154,3 @@ /* Define if the compiler supports long longs. */ #undef HAVE_LONG_LONGS - -/* Define if GCC has GCSE optimisation bug. */ -#undef BROKEN_GCSE diff --git a/configure.in b/configure.in index 3c4126e90..09e897dee 100644 --- a/configure.in +++ b/configure.in @@ -129,33 +129,6 @@ if test "$scm_cv_long_longs" = yes; then AC_DEFINE(HAVE_LONG_LONGS) fi -dnl check for an optimisation problem which is present in some versions -dnl of gcc, including 2.95.2. -AC_MSG_CHECKING(for broken GCSE optimisation) -AC_CACHE_VAL(guile_cv_broken_gcse, - AC_TRY_RUN([ - int main () - { - long winds = 0; - - while (winds != 0) - { - if (*(char *) 0) - break; - } - - if (winds == 0 || *(char *) 0) - exit (0); - - return 0; - }], - guile_cv_broken_gcse=no, guile_cv_broken_gcse=yes, - guile_cv_broken_gcse=yes)) -AC_MSG_RESULT($guile_cv_broken_gcse) -if test $guile_cv_broken_gcse = yes; then - AC_DEFINE(BROKEN_GCSE) -fi - AC_HEADER_STDC AC_HEADER_DIRENT AC_HEADER_TIME From 45605b53fbef5772808a6692e6f5f8ae2c0f0cff Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 17 Sep 2000 09:25:12 +0000 Subject: [PATCH 0263/2047] *** empty log message *** --- ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ChangeLog b/ChangeLog index b9ac0f2db..542a76478 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2000-09-17 Gary Houston + + * configure.in, acconfig.h: remove the GCSE test: it doesn't seem + to be reliable on all platforms. + 2000-08-18 Gary Houston * acconfig.h: added BROKEN_GCSE. From 49dd8ff33025c765a4e79fe9078e6ccc889d860f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 17 Sep 2000 21:16:18 +0000 Subject: [PATCH 0264/2047] * configure.in: Check for curses, terminfo and termlib libraries in addition to ncurses and termcap. Check for `readline' in libreadline, not for `main'. Thanks to Albert Chin! --- guile-readline/configure.in | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/guile-readline/configure.in b/guile-readline/configure.in index b59b9e4c5..8daafb5ab 100644 --- a/guile-readline/configure.in +++ b/guile-readline/configure.in @@ -7,14 +7,13 @@ AC_PROG_CC AM_PROG_CC_STDC AM_PROG_LIBTOOL -dnl Should we check for curses, terminfo, and termlib, too? -for termlib in ncurses termcap ; do +for termlib in ncurses curses termcap terminfo termlib ; do AC_CHECK_LIB(${termlib}, tgoto, [LIBS="-l${termlib} $LIBS"; break]) done -AC_CHECK_LIB(readline, main) -if test $ac_cv_lib_readline_main = no; then +AC_CHECK_LIB(readline, readline) +if test $ac_cv_lib_readline_readline = no; then AC_MSG_WARN([libreadline was not found on your system.]) fi From e621f2b022ca9ab8f0190d67847b828f588dce37 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 17 Sep 2000 21:22:31 +0000 Subject: [PATCH 0265/2047] *** empty log message *** --- guile-readline/ChangeLog | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 4474c64b4..43e7a2c72 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,10 @@ +2000-09-17 Marius Vollmer + + * configure.in: Check for curses, terminfo and termlib libraries + in addition to ncurses and termcap. + Check for `readline' in libreadline, not for `main'. + Thanks to Albert Chin! + 2000-07-17 Marius Vollmer * configure.in (rl_pre_input_hook): Don't check for this with From 5a2a5407e8457b1355f54b0ee0c315b01dbc790b Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 19 Sep 2000 10:56:57 +0000 Subject: [PATCH 0266/2047] * Added a comment suggesting to rename scm_handle_by_message. * When compiling on gcc, always avoid the GCSE bug. * Removed some redundant tests. --- libguile/ChangeLog | 7 +++++++ libguile/throw.c | 18 ++++++++---------- 2 files changed, 15 insertions(+), 10 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d55594afe..d10db6e76 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2000-09-19 Dirk Herrmann + + * throw.c (scm_handle_by_message): Added a FIXME comment. + + (scm_ithrow): Removed some redundant tests. When compiling on + gcc, always add the GCSE bug workaround. + 2000-09-14 Gary Houston * print.c (scm_iprin1): write the ascii delete character as #\del diff --git a/libguile/throw.c b/libguile/throw.c index 421d3dd73..afa9ffaec 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -472,6 +472,10 @@ handler_message (void *handler_data, SCM tag, SCM args) message header to print; if zero, we use "guile" instead. That text is followed by a colon, then the message described by ARGS. */ +/* Dirk:FIXME:: The name of the function should make clear that the + * application gets terminated. + */ + SCM scm_handle_by_message (void *handler_data, SCM tag, SCM args) { @@ -605,11 +609,8 @@ scm_ithrow (SCM key, SCM args, int noreturn) /* Search the wind list for an appropriate catch. "Waiter, please bring us the wind list." */ - for (winds = scm_dynwinds; SCM_NIMP (winds); winds = SCM_CDR (winds)) + for (winds = scm_dynwinds; SCM_CONSP (winds); winds = SCM_CDR (winds)) { - if (! SCM_CONSP (winds)) - abort (); - dynpair = SCM_CAR (winds); if (SCM_CONSP (dynpair)) { @@ -620,28 +621,25 @@ scm_ithrow (SCM key, SCM args, int noreturn) } } -#ifdef BROKEN_GCSE #ifdef __GNUC__ + /* Dirk:FIXME:: This bugfix should be removed some time. */ /* GCC 2.95.2 has a bug in its optimizer that makes it generate incorrect code sometimes. This barrier stops it from being too clever. */ asm volatile ("" : "=g" (winds)); -#else -#error "GCSE bug found: reconfigure without optimization?" -#endif #endif /* If we didn't find anything, print a message and abort the process right here. If you don't want this, establish a catch-all around any code that might throw up. */ - if (SCM_NULLP (winds) || SCM_FALSEP (dynpair)) + if (SCM_NULLP (winds)) { scm_handle_by_message (NULL, key, args); abort (); } /* If the wind list is malformed, bail. */ - if (SCM_IMP (winds) || SCM_NCONSP (winds)) + if (!SCM_CONSP (winds)) abort (); jmpbuf = SCM_CDR (dynpair); From 0f8c9efa58f9206300f897b53593dc7b68a40bca Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 20 Sep 2000 09:27:06 +0000 Subject: [PATCH 0267/2047] * Make sure that symbol properties initially form an empty list. --- libguile/ChangeLog | 7 +++++++ libguile/symbols.c | 5 ++--- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d10db6e76..ee141ef1c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2000-09-20 Dirk Herrmann + + * symbols.c (scm_intern_obarray_soft, + scm_sysintern0_no_module_lookup): Make sure that symbol + properties initially form an empty list. Thanks to Keisuke + Nishida for pointing this out. + 2000-09-19 Dirk Herrmann * throw.c (scm_handle_by_message): Added a FIXME comment. diff --git a/libguile/symbols.c b/libguile/symbols.c index 903394eac..04cf0c456 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -293,10 +293,9 @@ scm_intern_obarray_soft (const char *name,scm_sizet len,SCM obarray,unsigned int SCM_NEWCELL2 (lsym); SCM_SETCHARS (lsym, duplicate_string (name, len)); SCM_SET_SYMBOL_HASH (lsym, raw_hash); - SCM_SET_PROP_SLOTS (lsym, scm_cons (SCM_BOOL_F, SCM_BOOL_F)); + SCM_SET_PROP_SLOTS (lsym, scm_cons (SCM_BOOL_F, SCM_EOL)); SCM_SETLENGTH (lsym, (long) len, scm_tc7_symbol); - SCM_SET_SYMBOL_PROPS (lsym, SCM_EOL); if (SCM_FALSEP (obarray)) { SCM answer; @@ -369,7 +368,7 @@ scm_sysintern0_no_module_lookup (const char *name) SCM_NEWCELL2 (lsym); SCM_SETCHARS (lsym, name); SCM_SET_SYMBOL_HASH (lsym, raw_hash); - SCM_SET_PROP_SLOTS (lsym, scm_cons (SCM_BOOL_F, SCM_BOOL_F)); + SCM_SET_PROP_SLOTS (lsym, scm_cons (SCM_BOOL_F, SCM_EOL)); SCM_SETLENGTH (lsym, (long) len, scm_tc7_symbol); lsym = scm_cons (lsym, SCM_UNDEFINED); From b2eae655be45f9bd386a5625c1fbe26885a793ba Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 20 Sep 2000 16:28:00 +0000 Subject: [PATCH 0268/2047] * libguile.h: #include "libguile/environments.h" and "libguile/properties.h". --- libguile.h | 2 ++ 1 file changed, 2 insertions(+) diff --git a/libguile.h b/libguile.h index 14d458ccb..e98224f5b 100644 --- a/libguile.h +++ b/libguile.h @@ -68,6 +68,7 @@ extern "C" { #endif #include "libguile/dynl.h" #include "libguile/dynwind.h" +#include "libguile/environments.h" #include "libguile/eq.h" #include "libguile/error.h" #include "libguile/eval.h" @@ -98,6 +99,7 @@ extern "C" { #include "libguile/ports.h" #include "libguile/posix.h" #include "libguile/procprop.h" +#include "libguile/properties.h" #include "libguile/procs.h" #include "libguile/ramap.h" #include "libguile/random.h" From e4dba4c7a8e69b448f3567d839baeea6679b2918 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 20 Sep 2000 16:28:12 +0000 Subject: [PATCH 0269/2047] *** empty log message *** --- ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ChangeLog b/ChangeLog index 542a76478..88189541a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2000-09-20 Keisuke Nishida + + * libguile.h: #include "libguile/environments.h" and + "libguile/properties.h". + 2000-09-17 Gary Houston * configure.in, acconfig.h: remove the GCSE test: it doesn't seem From 8f486fc76aa997b21a72fed18384055a9ea987fe Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 20 Sep 2000 16:31:04 +0000 Subject: [PATCH 0270/2047] Removed #include "libguile/environments.h", sorry.. --- libguile.h | 1 - 1 file changed, 1 deletion(-) diff --git a/libguile.h b/libguile.h index e98224f5b..14a80703c 100644 --- a/libguile.h +++ b/libguile.h @@ -68,7 +68,6 @@ extern "C" { #endif #include "libguile/dynl.h" #include "libguile/dynwind.h" -#include "libguile/environments.h" #include "libguile/eq.h" #include "libguile/error.h" #include "libguile/eval.h" From 467ab77eee483a1075dc8fef559bcb7d079a6372 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 20 Sep 2000 16:31:15 +0000 Subject: [PATCH 0271/2047] *** empty log message *** --- ChangeLog | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index 88189541a..e45f5f71e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,7 +1,6 @@ 2000-09-20 Keisuke Nishida - * libguile.h: #include "libguile/environments.h" and - "libguile/properties.h". + * libguile.h: #include "libguile/properties.h". 2000-09-17 Gary Houston From 82b3d7781fad082fb5e7b775996a5f78523bdaa8 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 20 Sep 2000 16:50:18 +0000 Subject: [PATCH 0272/2047] * boot-9.scm: Removed comment. (Thanks to Brad Knotwell.) --- ice-9/boot-9.scm | 1 - 1 file changed, 1 deletion(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index c9da2b1de..b6da0a85e 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -545,7 +545,6 @@ ;;; ;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...) ;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...) -;;; (map-in-order fn lst) is like (map fn lst) but definately in order of lst. ;;; ;; and-map f l From 216b559acd57718816a35a6232be2e47825948f3 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 20 Sep 2000 16:56:21 +0000 Subject: [PATCH 0273/2047] *** empty log message *** --- libguile/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index ee141ef1c..fbc90c0f6 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2000-09-20 Mikael Djurfeldt + + * boot-9.scm: Removed comment. (Thanks to Brad Knotwell.) + 2000-09-20 Dirk Herrmann * symbols.c (scm_intern_obarray_soft, From dd47565aebd8a04448122862883a95096eb92d64 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 20 Sep 2000 21:04:19 +0000 Subject: [PATCH 0274/2047] * numbers.c (scm_istr2flo): Throw an `out of range' error when exponent is too large instead of returning `#f'. The rationale is that in this case the string represents a valid number but we can't deal with it. --- libguile/numbers.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index b5dc2fbbb..590e46cca 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -2641,7 +2641,7 @@ scm_istr2flo (char *str, long len, long radix) case DIGITS: expon = expon * 10 + c - '0'; if (expon > SCM_MAXEXP) - return SCM_BOOL_F; /* exponent too large */ + scm_out_of_range ("string->number", SCM_MAKINUM (expon)); break; default: goto out4; From f7b0a8d1c62a9aa839a0d4458b4045528e57dda9 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 20 Sep 2000 21:06:06 +0000 Subject: [PATCH 0275/2047] *** empty log message *** --- ice-9/ChangeLog | 4 ++++ libguile/ChangeLog | 7 +++++-- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 4f4b9716b..64c04bc1b 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2000-09-20 Mikael Djurfeldt + + * boot-9.scm: Removed comment. (Thanks to Brad Knotwell.) + 2000-09-12 Dirk Herrmann * syncase.scm (putprop): Use the high-level property interface. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index fbc90c0f6..baeddb9d2 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,6 +1,9 @@ -2000-09-20 Mikael Djurfeldt +2000-09-20 Marius Vollmer - * boot-9.scm: Removed comment. (Thanks to Brad Knotwell.) + * numbers.c (scm_istr2flo): Throw an `out of range' error when + exponent is too large instead of returning `#f'. The rationale is + that in this case the string represents a valid number but we + can't deal with it. 2000-09-20 Dirk Herrmann From 1bee0e70ca1609dee342cec0c0bc304098faf983 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 22 Sep 2000 13:40:12 +0000 Subject: [PATCH 0276/2047] * Fix docstring texinfo warnings. --- libguile/ChangeLog | 8 ++++++++ libguile/root.c | 2 +- libguile/struct.c | 2 +- 3 files changed, 10 insertions(+), 2 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index baeddb9d2..0d66d903e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2000-09-22 Neil Jerram + + * struct.c (scm_make_struct): Fix texinfo warning in docstring by + using @pxref rather than @xref. + + * root.c (scm_call_with_dynamic_root): Fix texinfo warning in + docstring by using @code for (thunk) rather than @var. + 2000-09-20 Marius Vollmer * numbers.c (scm_istr2flo): Throw an `out of range' error when diff --git a/libguile/root.c b/libguile/root.c index 0a8c7a92d..58fcf75d3 100644 --- a/libguile/root.c +++ b/libguile/root.c @@ -335,7 +335,7 @@ cwdr (SCM proc, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start) SCM_DEFINE (scm_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0, (SCM thunk, SCM handler), - "Evaluate @var{(thunk)} in a new dynamic context, returning its value.\n\n" + "Evaluate @code{(thunk)} in a new dynamic context, returning its value.\n\n" "If an error occurs during evaluation, apply @var{handler} to the\n" "arguments to the throw, just as @code{throw} would. If this happens,\n" "@var{handler} is called outside the scope of the new root -- it is\n" diff --git a/libguile/struct.c b/libguile/struct.c index 5f36eb958..2a5fff75c 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -410,7 +410,7 @@ scm_free_structs (void *dummy1, void *dummy2, void *dummy3) SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, (SCM vtable, SCM tail_array_size, SCM init), "Create a new structure.\n\n" - "@var{type} must be a vtable structure (@xref{Vtables}).\n\n" + "@var{type} must be a vtable structure (@pxref{Vtables}).\n\n" "@var{tail-elts} must be a non-negative integer. If the layout\n" "specification indicated by @var{type} includes a tail-array,\n" "this is the number of elements allocated to that array.\n\n" From c1aef037101d36e33de853041e407593cf32a489 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 22 Sep 2000 16:44:42 +0000 Subject: [PATCH 0277/2047] * Added SCM_STRING_CHARS and SCM_SYMBOL_CHARS in order to, in the long run, get rid of SCM_CHARS, which is shared between a large number of types, and thus makes it difficult to change the implementation of a single type. --- NEWS | 3 ++- RELEASE | 2 +- libguile/ChangeLog | 10 ++++++++++ libguile/strings.h | 5 +++-- libguile/symbols.h | 1 + 5 files changed, 17 insertions(+), 4 deletions(-) diff --git a/NEWS b/NEWS index f98a4b61c..d624d4a37 100644 --- a/NEWS +++ b/NEWS @@ -136,10 +136,11 @@ of this variable is (and has been) not fully safe anyway. ** Deprecated macros: SCM_OUTOFRANGE, SCM_NALLOC, SCM_HUP_SIGNAL, SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD, -SCM_ORD_SIG, SCM_NUM_SIGS, SCM_SYMBOL_SLOTS, SCM_SLOTS +SCM_ORD_SIG, SCM_NUM_SIGS, SCM_SYMBOL_SLOTS, SCM_SLOTS, SCM_SLOPPY_STRINGP Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of SCM_OUTOFRANGE. Use scm_memory_error instead of SCM_NALLOC. +Use SCM_STRINGP instead of SCM_SLOPPY_STRINGP. ** Removed function: scm_struct_init diff --git a/RELEASE b/RELEASE index ff52517db..5cf2ae6c9 100644 --- a/RELEASE +++ b/RELEASE @@ -50,7 +50,7 @@ In release 1.6: - remove deprecated macros: SCM_OUTOFRANGE, SCM_NALLOC, SCM_HUP_SIGNAL, SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD, - SCM_ORD_SIG, SCM_NUM_SIGS + SCM_ORD_SIG, SCM_NUM_SIGS, SCM_SLOPPY_STRINGP - remove function scm_call_catching_errors (replaced by catch functions from throw.[ch]) - remove support for "#&" reader syntax in (ice-9 optargs). diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 0d66d903e..8c3e6a1bd 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,13 @@ +2000-09-22 Dirk Herrmann + + * strings.h (SCM_STRING_CHARS): Added, should be used instead of + SCM_CHARS whenever the argument is known to be a string. + + (SCM_SLOPPY_STRINGP): Deprecated. + + * symbols.h (SCM_SYMBOL_CHARS): Added, should be used instead of + SCM_CHARS whenever the argument is known to be a symbol. + 2000-09-22 Neil Jerram * struct.c (scm_make_struct): Fix texinfo warning in docstring by diff --git a/libguile/strings.h b/libguile/strings.h index b56ab91f5..0d518d7e8 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -51,8 +51,8 @@ -#define SCM_SLOPPY_STRINGP(x) (SCM_TYP7S (x) == scm_tc7_string) -#define SCM_STRINGP(x) (SCM_NIMP (x) && SCM_SLOPPY_STRINGP (x)) +#define SCM_STRINGP(x) (SCM_NIMP (x) && (SCM_TYP7S (x) == scm_tc7_string)) +#define SCM_STRING_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) /* Is X a writable string (i.e., not a substring)? */ #define SCM_RWSTRINGP(x) (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_string)) @@ -82,6 +82,7 @@ extern void scm_init_strings (void); #if (SCM_DEBUG_DEPRECATED == 0) +#define SCM_SLOPPY_STRINGP(x) (SCM_STRINGP(x)) #define SCM_NSTRINGP(x) (!SCM_STRINGP(x)) #define SCM_NRWSTRINGP(x) (! SCM_RWSTRINGP (x)) diff --git a/libguile/symbols.h b/libguile/symbols.h index 72a83cdf7..bb654d200 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -57,6 +57,7 @@ extern int scm_symhash_dim; */ #define SCM_SYMBOLP(x) (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_symbol)) +#define SCM_SYMBOL_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) #define SCM_LENGTH_MAX (0xffffffL) #define SCM_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) From 86c991c2a202c1d06caa5f01ec5d36a07a19bb96 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 22 Sep 2000 17:17:55 +0000 Subject: [PATCH 0278/2047] * Replaced SCM_CHARS with SCM_STRING_CHARS or SCM_SYMBOL_CHARS. --- libguile/ChangeLog | 16 ++++++++++++++++ libguile/backtrace.c | 8 ++++---- libguile/environments.c | 10 +++++----- libguile/gh_data.c | 4 ++-- libguile/keywords.c | 2 +- libguile/ports.c | 2 +- libguile/posix.c | 2 +- libguile/print.c | 2 +- libguile/regex-posix.c | 4 ++-- libguile/script.c | 2 +- libguile/simpos.c | 2 +- libguile/socket.c | 4 ++-- libguile/strings.c | 2 +- libguile/strop.c | 8 ++++---- libguile/symbols.c | 2 +- libguile/unif.c | 6 +++--- libguile/validate.h | 4 ++-- 17 files changed, 48 insertions(+), 32 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 8c3e6a1bd..28aaf6e22 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,19 @@ +2000-09-22 Dirk Herrmann + + * backtrace.c (display_frame_expr), environments.c + (print_observer, print_leaf_environment, print_eval_environment, + print_import_environment, print_export_environment), gh_data.c + (gh_set_substr, gh_symbol2newstr), keywords.c + (scm_make_keyword_from_dash_symbol), ports.c (scm_drain_input), + posix.c (scm_mknod), print.c (scm_iprin1), regexp-posix.c + (scm_regexp_error_msg), script.c (scm_compile_shell_switches), + simpos.c (scm_getenv), socket.c (scm_recv, scm_recvfrom), + strings.c (scm_makfromstr), strop.c (scm_substring_move_x, + scm_substring_fill_x, scm_string_capitalize_x), symbols.c + (scm_symbol_to_string), unif.c (scm_make_uve, scm_array_p), + validate.h (SCM_VALIDATE_STRING_COPY): Use SCM_STRING_CHARS or + SCM_SYMBOL_CHARS instead of SCM_CHARS. + 2000-09-22 Dirk Herrmann * strings.h (SCM_STRING_CHARS): Added, should be used instead of diff --git a/libguile/backtrace.c b/libguile/backtrace.c index ae26dc01d..7a8ee3a47 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -333,16 +333,16 @@ display_frame_expr (char *hdr,SCM exp,char *tlr,int indentation,SCM sport,SCM po string = scm_strport_to_string (sport); /* Remove control characters */ for (i = 0; i < n; ++i) - if (iscntrl (SCM_CHARS (string)[i])) - SCM_CHARS (string)[i] = ' '; + if (iscntrl (SCM_STRING_CHARS (string)[i])) + SCM_STRING_CHARS (string)[i] = ' '; /* Truncate */ if (indentation + n > SCM_BACKTRACE_WIDTH) { n = SCM_BACKTRACE_WIDTH - indentation; - SCM_CHARS (string)[n - 1] = '$'; + SCM_STRING_CHARS (string)[n - 1] = '$'; } - scm_lfwrite (SCM_CHARS (string), n, port); + scm_lfwrite (SCM_STRING_CHARS (string), n, port); } static void diff --git a/libguile/environments.c b/libguile/environments.c index dd5ef17fe..55fd610d3 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -498,7 +498,7 @@ print_observer (SCM type, SCM port, scm_print_state *pstate) SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16)); scm_puts ("#", port); return 1; @@ -994,7 +994,7 @@ print_leaf_environment (SCM type, SCM port, scm_print_state *pstate) SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16)); scm_puts ("#", port); return 1; @@ -1354,7 +1354,7 @@ print_eval_environment (SCM type, SCM port, scm_print_state *pstate) SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16)); scm_puts ("#", port); return 1; @@ -1765,7 +1765,7 @@ print_import_environment (SCM type, SCM port, scm_print_state *pstate) SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16)); scm_puts ("#", port); return 1; @@ -2062,7 +2062,7 @@ print_export_environment (SCM type, SCM port, scm_print_state *pstate) SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16)); scm_puts ("#", port); return 1; diff --git a/libguile/gh_data.c b/libguile/gh_data.c index d0b164de0..5987ae7f6 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -116,7 +116,7 @@ gh_set_substr (char *src, SCM dst, int start, int len) SCM_ASSERT (SCM_STRINGP (dst), dst, SCM_ARG3, "gh_set_substr"); - dst_ptr = SCM_CHARS (dst); + dst_ptr = SCM_STRING_CHARS (dst); dst_len = SCM_LENGTH (dst); SCM_ASSERT (len >= 0 && (unsigned) len <= dst_len, dst, SCM_ARG4, "gh_set_substr"); @@ -605,7 +605,7 @@ gh_symbol2newstr (SCM sym, int *lenp) ret_str = (char *) scm_must_malloc ((len + 1) * sizeof (char), "gh_symbol2newstr"); /* so we copy tmp_str to ret_str, which is what we will allocate */ - memcpy (ret_str, SCM_CHARS (sym), len); + memcpy (ret_str, SCM_SYMBOL_CHARS (sym), len); /* now make sure we null-terminate it */ ret_str[len] = '\0'; diff --git a/libguile/keywords.c b/libguile/keywords.c index f75042abb..1909148a0 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -74,7 +74,7 @@ SCM_DEFINE (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", SCM vcell; SCM_ASSERT (SCM_SYMBOLP (symbol) - && ('-' == SCM_CHARS(symbol)[0]), + && ('-' == SCM_SYMBOL_CHARS(symbol)[0]), symbol, SCM_ARG1, FUNC_NAME); SCM_DEFER_INTS; diff --git a/libguile/ports.c b/libguile/ports.c index f70db136e..d6689e55d 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -290,7 +290,7 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, count += pt->saved_read_end - pt->saved_read_pos; result = scm_makstr (count, 0); - dst = SCM_CHARS (result); + dst = SCM_STRING_CHARS (result); while (pt->read_pos < pt->read_end) *dst++ = *(pt->read_pos++); diff --git a/libguile/posix.c b/libguile/posix.c index 813cda850..107de5522 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1213,7 +1213,7 @@ SCM_DEFINE (scm_mknod, "mknod", 4, 0, 0, SCM_VALIDATE_INUM (4,dev); SCM_COERCE_SUBSTR (path); - p = SCM_CHARS (type); + p = SCM_SYMBOL_CHARS (type); if (strcmp (p, "regular") == 0) ctype = S_IFREG; else if (strcmp (p, "directory") == 0) diff --git a/libguile/print.c b/libguile/print.c index fe7662c04..bcbb1fe32 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -494,7 +494,7 @@ taloop: int mw_pos = 0; len = SCM_LENGTH (exp); - str = SCM_CHARS (exp); + str = SCM_SYMBOL_CHARS (exp); scm_remember (&exp); pos = 0; weird = 0; diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index 66be0fe1e..4c0b22d03 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -124,14 +124,14 @@ scm_regexp_error_msg (int regerrno, regex_t *rx) errmsg = scm_make_string (SCM_MAKINUM (80), SCM_UNDEFINED); SCM_DEFER_INTS; - l = regerror (regerrno, rx, SCM_CHARS (errmsg), 80); + l = regerror (regerrno, rx, SCM_STRING_CHARS (errmsg), 80); if (l > 80) { errmsg = scm_make_string (SCM_MAKINUM (l), SCM_UNDEFINED); regerror (regerrno, rx, SCM_CHARS (errmsg), l); } SCM_ALLOW_INTS; - return SCM_CHARS (errmsg); + return SCM_STRING_CHARS (errmsg); } SCM_DEFINE (scm_regexp_p, "regexp?", 1, 0, 0, diff --git a/libguile/script.c b/libguile/script.c index e24c89f51..2ab76161e 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -557,7 +557,7 @@ scm_compile_shell_switches (int argc, char **argv) "certain other uses are permitted as well. For details, see the file\n" "`COPYING', which is included in the Guile distribution.\n" "There is no warranty, to the extent permitted by law.\n", - SCM_CHARS (scm_version ())); + SCM_STRING_CHARS (scm_version ())); exit (0); } diff --git a/libguile/simpos.c b/libguile/simpos.c index b15d6987e..062853ae8 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -107,7 +107,7 @@ SCM_DEFINE (scm_getenv, "getenv", 1, 0, 0, char *val; SCM_VALIDATE_ROSTRING (1,nam); nam = scm_makfromstr (SCM_ROCHARS (nam), SCM_ROLENGTH (nam), 0); - val = getenv(SCM_CHARS(nam)); + val = getenv (SCM_STRING_CHARS (nam)); return (val) ? scm_makfromstr(val, (scm_sizet)strlen(val), 0) : SCM_BOOL_F; } #undef FUNC_NAME diff --git a/libguile/socket.c b/libguile/socket.c index 47166e1ca..7bbcd1e52 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -709,7 +709,7 @@ SCM_DEFINE (scm_recv, "recv!", 2, 1, 0, SCM_VALIDATE_INUM_DEF_COPY (3,flags,0,flg); fd = SCM_FPORT_FDES (sock); - SCM_SYSCALL (rv = recv (fd, SCM_CHARS (buf), SCM_LENGTH (buf), flg)); + SCM_SYSCALL (rv = recv (fd, SCM_STRING_CHARS (buf), SCM_LENGTH (buf), flg)); if (rv == -1) SCM_SYSERROR; @@ -807,7 +807,7 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0, fd = SCM_FPORT_FDES (sock); tmp_size = scm_addr_buffer_size; - SCM_SYSCALL (rv = recvfrom (fd, SCM_CHARS (buf) + offset, + SCM_SYSCALL (rv = recvfrom (fd, SCM_STRING_CHARS (buf) + offset, cend - offset, flg, (struct sockaddr *) scm_addr_buffer, &tmp_size)); diff --git a/libguile/strings.c b/libguile/strings.c index 35733e66d..872cdc33b 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -186,7 +186,7 @@ SCM scm_makfromstr (const char *src, scm_sizet len, int dummy) { SCM s = scm_makstr (len, 0); - char *dst = SCM_CHARS (s); + char *dst = SCM_STRING_CHARS (s); while (len--) *dst++ = *src++; diff --git a/libguile/strop.c b/libguile/strop.c index b777c8a7d..4c40c7d36 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -260,8 +260,8 @@ SCM_DEFINE (scm_substring_move_x, "substring-move!", 5, 0, 0, SCM_ASSERT_RANGE (3,end1,e <= SCM_LENGTH (str1) && e >= 0); SCM_ASSERT_RANGE (5,start2,len+s2 <= SCM_LENGTH (str2)); - SCM_SYSCALL(memmove((void *)(&(SCM_CHARS(str2)[s2])), - (void *)(&(SCM_CHARS(str1)[s1])), + SCM_SYSCALL(memmove((void *)(&(SCM_STRING_CHARS(str2)[s2])), + (void *)(&(SCM_STRING_CHARS(str1)[s1])), len)); return scm_return_first(SCM_UNSPECIFIED, str1, str2); @@ -290,7 +290,7 @@ SCM_DEFINE (scm_substring_fill_x, "substring-fill!", 4, 0, 0, SCM_VALIDATE_CHAR_COPY (4,fill,c); SCM_ASSERT_RANGE (2,start,i <= SCM_LENGTH (str) && i >= 0); SCM_ASSERT_RANGE (3,end,e <= SCM_LENGTH (str) && e >= 0); - while (istring", 1, 0, 0, #define FUNC_NAME s_scm_symbol_to_string { SCM_VALIDATE_SYMBOL (1, s); - return scm_makfromstr (SCM_CHARS (s), SCM_LENGTH (s), 0); + return scm_makfromstr (SCM_SYMBOL_CHARS (s), SCM_LENGTH (s), 0); } #undef FUNC_NAME diff --git a/libguile/unif.c b/libguile/unif.c index 44cb0c2c8..45b792015 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -183,7 +183,7 @@ scm_make_uve (long k, SCM prot) { char s; - s = SCM_CHARS (prot)[0]; + s = SCM_SYMBOL_CHARS (prot)[0]; if (s == 's') { i = sizeof (short) * k; @@ -306,12 +306,12 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, case scm_tc7_svect: protp = SCM_SYMBOLP (prot) && (1 == SCM_LENGTH (prot)) - && ('s' == SCM_CHARS (prot)[0]); + && ('s' == SCM_SYMBOL_CHARS (prot)[0]); #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: protp = SCM_SYMBOLP (prot) && (1 == SCM_LENGTH (prot)) - && ('s' == SCM_CHARS (prot)[0]); + && ('s' == SCM_SYMBOL_CHARS (prot)[0]); #endif case scm_tc7_fvect: protp = singp (prot); diff --git a/libguile/validate.h b/libguile/validate.h index 3ddcebe25..178c34781 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -1,4 +1,4 @@ -/* $Id: validate.h,v 1.14 2000-09-03 21:56:03 mdj Exp $ */ +/* $Id: validate.h,v 1.15 2000-09-22 17:17:55 dirk Exp $ */ /* Copyright (C) 1999, 2000 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify @@ -156,7 +156,7 @@ #define SCM_VALIDATE_STRING_COPY(pos, str, cvar) \ do { \ SCM_ASSERT (SCM_STRINGP (str), str, pos, FUNC_NAME); \ - cvar = SCM_CHARS(str); \ + cvar = SCM_STRING_CHARS(str); \ } while (0) #define SCM_VALIDATE_RWSTRING(pos, str) \ From f151f912939a555a27ab29cfd1127bb36fa4bbc2 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 22 Sep 2000 17:43:57 +0000 Subject: [PATCH 0279/2047] * Eliminated some more calls to SCM_CHARS. --- libguile/ChangeLog | 8 ++++++++ libguile/eval.c | 10 ---------- libguile/evalext.c | 9 --------- libguile/gc.c | 5 +++-- 4 files changed, 11 insertions(+), 21 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 28aaf6e22..65c3d9ff1 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2000-09-22 Dirk Herrmann + + * eval.c (scm_m_define), evalext.c (scm_m_undefine): Removed dead + code. + + * gc.c (scm_gc_sweep): Use SCM_STRING_CHARS or SCM_SYMBOL_CHARS + instead of SCM_CHARS. + 2000-09-22 Dirk Herrmann * backtrace.c (display_frame_expr), environments.c diff --git a/libguile/eval.c b/libguile/eval.c index effa23b56..eb10b3459 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -900,16 +900,6 @@ scm_m_define (SCM x, SCM env) } #endif arg1 = scm_sym2vcell (proc, scm_env_top_level (env), SCM_BOOL_T); -#if 0 -#ifndef SCM_RECKLESS - if (SCM_NIMP (SCM_CDR (arg1)) && (SCM_SNAME (SCM_CDR (arg1)) == proc) - && (SCM_CDR (arg1) != x)) - scm_warn ("redefining built-in ", SCM_CHARS (proc)); - else -#endif - if (5 <= scm_verbose && SCM_UNDEFINED != SCM_CDR (arg1)) - scm_warn ("redefining ", SCM_CHARS (proc)); -#endif SCM_SETCDR (arg1, x); #ifdef SICP return scm_cons2 (scm_sym_quote, SCM_CAR (arg1), SCM_EOL); diff --git a/libguile/evalext.c b/libguile/evalext.c index f358bca99..124320503 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -134,15 +134,6 @@ scm_m_undefine (SCM x, SCM env) arg1 = scm_sym2vcell (x, scm_env_top_level (env), SCM_BOOL_F); SCM_ASSYNT (SCM_NFALSEP (arg1) && !SCM_UNBNDP (SCM_CDR (arg1)), x, "variable already unbound ", s_undefine); -#if 0 -#ifndef SCM_RECKLESS - if (SCM_NIMP (SCM_CDR (arg1)) && ((SCM) SCM_SNAME (SCM_CDR (arg1)) == x)) - scm_warn ("undefining built-in ", SCM_CHARS (x)); - else -#endif - if (5 <= scm_verbose && SCM_UNDEFINED != SCM_CDR (arg1)) - scm_warn ("redefining ", SCM_CHARS (x)); -#endif SCM_SETCDR (arg1, SCM_UNDEFINED); #ifdef SICP return SCM_CAR (arg1); diff --git a/libguile/gc.c b/libguile/gc.c index 0463cba46..d9d8dc890 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1650,10 +1650,11 @@ scm_gc_sweep () break; case scm_tc7_string: m += SCM_HUGE_LENGTH (scmptr) + 1; - goto freechars; + scm_must_free (SCM_STRING_CHARS (scmptr)); + break; case scm_tc7_symbol: m += SCM_LENGTH (scmptr) + 1; - scm_must_free (SCM_CHARS (scmptr)); + scm_must_free (SCM_SYMBOL_CHARS (scmptr)); break; case scm_tc7_contin: m += SCM_LENGTH (scmptr) * sizeof (SCM_STACKITEM) + sizeof (scm_contregs); From 1660782ecfdb3a7eb3a17dea314e383749ddf538 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 22 Sep 2000 18:33:24 +0000 Subject: [PATCH 0280/2047] * Removed unused type tag scm_tc7_lvector. --- NEWS | 4 +++- libguile/ChangeLog | 5 +++++ libguile/gc.c | 2 -- libguile/tags.h | 2 +- 4 files changed, 9 insertions(+), 4 deletions(-) diff --git a/NEWS b/NEWS index d624d4a37..8be7fc6ea 100644 --- a/NEWS +++ b/NEWS @@ -160,9 +160,11 @@ scm_gensym now only takes one argument. The builtin `gentemp' has now become a primitive. -** Deprecated type tags: scm_tc7_ssymbol, scm_tc7_msymbol, scm_tcs_symbols +** Deprecated type tags: scm_tc7_ssymbol, scm_tc7_msymbol, scm_tcs_symbols, +scm_tc7_lvector There is now only a single symbol type scm_tc7_symbol. +The tag scm_tc7_lvector was not used anyway. Changes since Guile 1.3.4: diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 65c3d9ff1..dfd0e3c49 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-09-22 Dirk Herrmann + + * gc.c (scm_gc_mark, scm_gc_sweep), tags.h: Removed the + scm_tc7_lvector type tag. + 2000-09-22 Dirk Herrmann * eval.c (scm_m_define), evalext.c (scm_m_undefine): Removed dead diff --git a/libguile/gc.c b/libguile/gc.c index d9d8dc890..4f35398ec 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1213,7 +1213,6 @@ gc_mark_nimp: ptr = SCM_CDR (ptr); goto gc_mark_nimp; case scm_tc7_vector: - case scm_tc7_lvector: #ifdef CCLO case scm_tc7_cclo: #endif @@ -1608,7 +1607,6 @@ scm_gc_sweep () scm_must_free ((char *)(SCM_VELTS (scmptr) - 2)); break; case scm_tc7_vector: - case scm_tc7_lvector: #ifdef CCLO case scm_tc7_cclo: #endif diff --git a/libguile/tags.h b/libguile/tags.h index 2b8ec0d48..0493e3582 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -348,11 +348,11 @@ typedef long scm_bits_t; * of these 7 bit tags! */ #define scm_tc7_pws 31 -#define scm_tc7_lvector 39 #ifdef HAVE_ARRAYS #define scm_tc7_llvect 29 #define scm_tc7_uvect 37 +/* free 39 */ #define scm_tc7_fvect 45 #define scm_tc7_dvect 47 #define scm_tc7_cvect 53 From a002f1a2cbdc39b2a52e6d1e100791f106fd34bb Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 26 Sep 2000 18:37:26 +0000 Subject: [PATCH 0281/2047] * Replaced a lot of references to SCM_CHARS. --- libguile/ChangeLog | 36 ++++++++++++++++++++++++++++++++++++ libguile/continuations.c | 4 ++-- libguile/coop-threads.c | 8 ++++---- libguile/dynl.c | 15 +++++++++------ libguile/hash.c | 3 +++ libguile/keywords.c | 2 +- libguile/objects.c | 2 +- libguile/print.c | 7 ++++--- libguile/regex-posix.c | 2 +- libguile/stacks.c | 6 +++--- libguile/stime.c | 4 ++-- libguile/strings.h | 1 + libguile/strorder.c | 2 ++ libguile/struct.c | 8 ++++---- libguile/symbols.h | 23 ++++++++++++++--------- libguile/tags.h | 13 +++---------- 16 files changed, 90 insertions(+), 46 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index dfd0e3c49..5f7aa99ff 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,39 @@ +2000-09-26 Dirk Herrmann + + * continuations.c (scm_make_cont, scm_dynthrow), print.c + (scm_iprin1), stacks.c (scm_make_stack, scm_stack_id, + scm_last_stack_frame): For continuations, use SCM_CONTREGS + instead of SCM_CHARS. + + * coop-threads.c (scm_threads_mark_stacks): Eliminate references + to SCM_LENGTH and SCM_CHARS from comments. + + * dynl.c (scm_dynamic_link, scm_dynamic_func), symbols.h + (SCM_ROCHARS, SCM_ROUCHARS): Cleanly distinguish between string + and symbol arguments. + + * hash.c (scm_hasher), keywords.c (prin_keyword), objects.c + (scm_make_subclass_object), print.c (scm_iprin1), regex-posix.c + (scm_regexp_error_msg), stime.c (bdtime2c, scm_strftime), struct.c + (scm_struct_init, scm_struct_vtable_p, scm_struct_ref, + scm_struct_set_x): Use SCM_STRING_U?CHARS or SCM_SYMBOL_U?CHARS + instead of SCM_U?CHARS. + + * strings.h (SCM_STRING_UCHARS): Added as a replacement for + SCM_UCHARS for string arguments. + + * strorder.c: Include strings.h and symbols.h. + + * symbols.h: Replaced SCM_CHARS in comment. + + (SCM_SYMBOL_UCHARS): Added as a replacement for SCM_UCHARS for + symbol arguments. + + (SCM_SLOPPY_SUBSTRP): Deprecated. + + * tags.h: Fixed comments not to reference SCM_LENGTH or + SCM_CHARS. + 2000-09-22 Dirk Herrmann * gc.c (scm_gc_mark, scm_gc_sweep), tags.h: Removed the diff --git a/libguile/continuations.c b/libguile/continuations.c index 40a863cef..fd7d9771f 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -94,7 +94,7 @@ scm_make_cont (SCM *answer) #ifndef SCM_STACK_GROWS_UP src -= SCM_LENGTH (cont); #endif /* ndef SCM_STACK_GROWS_UP */ - dst = (SCM_STACKITEM *) (SCM_CHARS (cont) + sizeof (scm_contregs)); + dst = (SCM_STACKITEM *) ((char *) SCM_CONTREGS (cont) + sizeof (scm_contregs)); /* memcpy should be safe: src and dst will never overlap */ memcpy (dst, src, sizeof (SCM_STACKITEM) * SCM_LENGTH (cont)); @@ -166,7 +166,7 @@ scm_dynthrow (SCM cont, SCM val) grow_stack (cont, val); #endif /* def SCM_STACK_GROWS_UP */ SCM_FLUSH_REGISTER_WINDOWS; - src = (SCM_STACKITEM *) (SCM_CHARS (cont) + sizeof (scm_contregs)); + src = (SCM_STACKITEM *) ((char *) SCM_CONTREGS (cont) + sizeof (scm_contregs)); copy_stack_and_call (cont, val, src, dst); } diff --git a/libguile/coop-threads.c b/libguile/coop-threads.c index c2f5696ed..8214584e8 100644 --- a/libguile/coop-threads.c +++ b/libguile/coop-threads.c @@ -101,8 +101,8 @@ scm_threads_mark_stacks (void) /* Protect from the C stack. This must be the first marking * done because it provides information about what objects * are "in-use" by the C code. "in-use" objects are those - * for which the values from SCM_LENGTH and SCM_CHARS must remain - * usable. This requirement is stricter than a liveness + * for which the information about length and base address must + * remain usable. This requirement is stricter than a liveness * requirement -- in particular, it constrains the implementation * of scm_resizuve. */ @@ -122,8 +122,8 @@ scm_threads_mark_stacks (void) /* Protect from the C stack. This must be the first marking * done because it provides information about what objects * are "in-use" by the C code. "in-use" objects are those - * for which the values from SCM_LENGTH and SCM_CHARS must remain - * usable. This requirement is stricter than a liveness + * for which the information about length and base address must + * remain usable. This requirement is stricter than a liveness * requirement -- in particular, it constrains the implementation * of scm_resizuve. */ diff --git a/libguile/dynl.c b/libguile/dynl.c index 16c15f46d..acd95486f 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -353,9 +353,11 @@ SCM_DEFINE (scm_dynamic_link, "dynamic-link", 1, 0, 0, #define FUNC_NAME s_scm_dynamic_link { void *handle; + char *chars; - SCM_COERCE_ROSTRING (1, fname); - handle = sysdep_dynl_link (SCM_CHARS (fname), FUNC_NAME); + fname = scm_coerce_rostring (fname, FUNC_NAME, 1); + chars = SCM_STRINGP (fname) ? SCM_STRING_CHARS (fname) : SCM_SYMBOL_CHARS (fname); + handle = sysdep_dynl_link (chars, FUNC_NAME); SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj, SCM_UNPACK (fname), handle); } #undef FUNC_NAME @@ -416,16 +418,17 @@ SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0, { void (*func) (); - SCM_COERCE_ROSTRING (1, symb); + symb = scm_coerce_rostring (symb, FUNC_NAME, 1); /*fixme* GC-problem */ SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj); if (DYNL_HANDLE (dobj) == NULL) { SCM_MISC_ERROR ("Already unlinked: ~S", dobj); } else { + char *chars; + SCM_DEFER_INTS; - func = (void (*) ()) sysdep_dynl_func (SCM_CHARS (symb), - DYNL_HANDLE (dobj), - FUNC_NAME); + chars = SCM_STRINGP (symb) ? SCM_STRING_CHARS (symb) : SCM_SYMBOL_CHARS (symb); + func = (void (*) ()) sysdep_dynl_func (chars, DYNL_HANDLE (dobj), FUNC_NAME); SCM_ALLOW_INTS; return scm_ulong2num ((unsigned long) func); } diff --git a/libguile/hash.c b/libguile/hash.c index be1f33133..d81ebcfb4 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -48,6 +48,8 @@ #include "libguile/_scm.h" #include "libguile/chars.h" #include "libguile/ports.h" +#include "libguile/strings.h" +#include "libguile/symbols.h" #include "libguile/vectors.h" #include "libguile/validate.h" @@ -117,6 +119,7 @@ scm_hasher(SCM obj, unsigned long n, scm_sizet d) obj = scm_number_to_string(obj, SCM_MAKINUM(10)); } case scm_tc7_string: + return scm_string_hash (SCM_STRING_UCHARS (obj), SCM_LENGTH (obj)) % n; case scm_tc7_substring: return scm_string_hash (SCM_ROUCHARS (obj), SCM_ROLENGTH (obj)) % n; case scm_tc7_symbol: diff --git a/libguile/keywords.c b/libguile/keywords.c index 1909148a0..45a40baca 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -59,7 +59,7 @@ static int prin_keyword (SCM exp,SCM port,scm_print_state *pstate) { scm_puts ("#:", port); - scm_puts(1 + SCM_CHARS (SCM_CDR (exp)), port); + scm_puts(1 + SCM_SYMBOL_CHARS (SCM_CDR (exp)), port); return 1; } diff --git a/libguile/objects.c b/libguile/objects.c index 3c70ea090..bc976a7d4 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -457,7 +457,7 @@ SCM_DEFINE (scm_make_subclass_object, "make-subclass-object", 2, 0, 0, SCM_VALIDATE_STRING (2,layout); pl = SCM_PACK (SCM_STRUCT_DATA (class) [scm_vtable_index_layout]); /* Convert symbol->string */ - pl = scm_makfromstr (SCM_CHARS (pl), (scm_sizet) SCM_LENGTH (pl), 0); + pl = scm_makfromstr (SCM_SYMBOL_CHARS (pl), (scm_sizet) SCM_LENGTH (pl), 0); return scm_i_make_class_object (SCM_STRUCT_VTABLE (class), scm_string_append (SCM_LIST2 (pl, layout)), SCM_CLASS_FLAGS (class)); diff --git a/libguile/print.c b/libguile/print.c index bcbb1fe32..499f44760 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -47,6 +47,7 @@ #include #include "libguile/_scm.h" #include "libguile/chars.h" +#include "libguile/continuations.h" #include "libguile/smob.h" #include "libguile/eval.h" #include "libguile/macros.h" @@ -620,7 +621,7 @@ taloop: ? "#', port); break; #ifdef CCLO @@ -635,7 +636,7 @@ taloop: if (SCM_NFALSEP (name)) { scm_putc (' ', port); - scm_puts (SCM_CHARS (name), port); + scm_puts (SCM_SYMBOL_CHARS (name), port); } } else @@ -663,7 +664,7 @@ taloop: scm_puts ("#', port); break; case scm_tc7_port: diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index 4c0b22d03..bf941c568 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -128,7 +128,7 @@ scm_regexp_error_msg (int regerrno, regex_t *rx) if (l > 80) { errmsg = scm_make_string (SCM_MAKINUM (l), SCM_UNDEFINED); - regerror (regerrno, rx, SCM_CHARS (errmsg), l); + regerror (regerrno, rx, SCM_STRING_CHARS (errmsg), l); } SCM_ALLOW_INTS; return SCM_STRING_CHARS (errmsg); diff --git a/libguile/stacks.c b/libguile/stacks.c index 1bf8f7a4a..5aab91786 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -435,7 +435,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (obj); else if (scm_tc7_contin == SCM_TYP7 (obj)) { - offset = ((SCM_STACKITEM *) (SCM_CHARS (obj) + sizeof (scm_contregs)) + offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (obj) + sizeof (scm_contregs)) - SCM_BASE (obj)); #ifndef STACK_GROWS_UP offset += SCM_LENGTH (obj); @@ -519,7 +519,7 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0, dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (stack); else if (scm_tc7_contin == SCM_TYP7 (stack)) { - offset = ((SCM_STACKITEM *) (SCM_CHARS (stack) + sizeof (scm_contregs)) + offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (stack) + sizeof (scm_contregs)) - SCM_BASE (stack)); #ifndef STACK_GROWS_UP offset += SCM_LENGTH (stack); @@ -589,7 +589,7 @@ SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0, dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (obj); else if (scm_tc7_contin == SCM_TYP7 (obj)) { - offset = ((SCM_STACKITEM *) (SCM_CHARS (obj) + sizeof (scm_contregs)) + offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (obj) + sizeof (scm_contregs)) - SCM_BASE (obj)); #ifndef STACK_GROWS_UP offset += SCM_LENGTH (obj); diff --git a/libguile/stime.c b/libguile/stime.c index f44e003c3..b10e7278c 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -461,7 +461,7 @@ bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr) if (SCM_FALSEP (velts[10])) lt->tm_zone = NULL; else - lt->tm_zone = SCM_CHARS (velts[10]); + lt->tm_zone = SCM_STRING_CHARS (velts[10]); #endif } @@ -602,7 +602,7 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, SCM *velts = SCM_VELTS (stime); int have_zone = 0; - if (SCM_NFALSEP (velts[10]) && *SCM_CHARS (velts[10]) != 0) + if (SCM_NFALSEP (velts[10]) && *SCM_STRING_CHARS (velts[10]) != 0) { /* it's not required that the TZ setting be correct, just that it has the right name. so try something like TZ=EST0. diff --git a/libguile/strings.h b/libguile/strings.h index 0d518d7e8..c13ccfda3 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -52,6 +52,7 @@ #define SCM_STRINGP(x) (SCM_NIMP (x) && (SCM_TYP7S (x) == scm_tc7_string)) +#define SCM_STRING_UCHARS(x) ((unsigned char *) (SCM_CELL_WORD_1 (x))) #define SCM_STRING_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) /* Is X a writable string (i.e., not a substring)? */ diff --git a/libguile/strorder.c b/libguile/strorder.c index d2a4347ec..8d2453fea 100644 --- a/libguile/strorder.c +++ b/libguile/strorder.c @@ -46,6 +46,8 @@ #include #include "libguile/_scm.h" #include "libguile/chars.h" +#include "libguile/strings.h" +#include "libguile/symbols.h" #include "libguile/validate.h" #include "libguile/strorder.h" diff --git a/libguile/struct.c b/libguile/struct.c index 2a5fff75c..ab361617a 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -151,7 +151,7 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, static void scm_struct_init (SCM handle, SCM layout, scm_bits_t * mem, int tail_elts, SCM inits) { - unsigned char * fields_desc = (unsigned char *) SCM_CHARS (layout) - 2; + unsigned char * fields_desc = (unsigned char *) SCM_SYMBOL_CHARS (layout) - 2; unsigned char prot = 0; int n_fields = SCM_LENGTH (layout) / 2; int tailp = 0; @@ -259,7 +259,7 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0, if (SCM_LENGTH (layout) < SCM_LENGTH (required_vtable_fields)) return SCM_BOOL_F; - if (strncmp (SCM_CHARS (layout), SCM_CHARS (required_vtable_fields), + if (strncmp (SCM_SYMBOL_CHARS (layout), SCM_STRING_CHARS (required_vtable_fields), SCM_LENGTH (required_vtable_fields))) return SCM_BOOL_F; @@ -577,7 +577,7 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0, data = SCM_STRUCT_DATA (handle); p = SCM_INUM (pos); - fields_desc = (unsigned char *) SCM_CHARS (layout); + fields_desc = SCM_SYMBOL_UCHARS (layout); n_fields = data[scm_struct_i_n_words]; SCM_ASSERT_RANGE(1,pos, p < n_fields); @@ -654,7 +654,7 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0, data = SCM_STRUCT_DATA (handle); p = SCM_INUM (pos); - fields_desc = (unsigned char *)SCM_CHARS (layout); + fields_desc = SCM_SYMBOL_UCHARS (layout); n_fields = data[scm_struct_i_n_words]; SCM_ASSERT_RANGE (1,pos, p < n_fields); diff --git a/libguile/symbols.h b/libguile/symbols.h index bb654d200..352f11467 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -53,10 +53,11 @@ extern int scm_symhash_dim; /* SCM_LENGTH(SYM) is the length of SYM's name in characters, and - * SCM_CHARS(SYM) is the address of the first character of SYM's name. + * SCM_SYMBOL_CHARS(SYM) is the address of the first character of SYM's name. */ #define SCM_SYMBOLP(x) (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_symbol)) +#define SCM_SYMBOL_UCHARS(x) ((unsigned char *) (SCM_CELL_WORD_1 (x))) #define SCM_SYMBOL_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) #define SCM_LENGTH_MAX (0xffffffL) @@ -78,15 +79,18 @@ extern int scm_symhash_dim; #define SCM_ROSTRINGP(x) (SCM_NIMP(x) && ((SCM_TYP7S(x)==scm_tc7_string) \ || (SCM_TYP7(x) == scm_tc7_symbol))) -#define SCM_ROCHARS(x) ((char *)((SCM_TYP7(x) == scm_tc7_substring) \ - ? SCM_INUM (SCM_CADR (x)) + SCM_CHARS (SCM_CDDR (x)) \ - : SCM_CHARS (x))) -#define SCM_ROUCHARS(x) ((unsigned char *) ((SCM_TYP7(x) == scm_tc7_substring) \ - ? SCM_INUM (SCM_CADR (x)) + SCM_UCHARS (SCM_CDDR (x))\ - : SCM_UCHARS (x))) +#define SCM_ROCHARS(x) ((SCM_TYP7 (x) == scm_tc7_substring) \ + ? (SCM_INUM (SCM_CADR (x)) + SCM_STRING_CHARS (SCM_CDDR (x))) \ + : ((SCM_TYP7 (x) == scm_tc7_string) \ + ? SCM_STRING_CHARS (x) \ + : SCM_SYMBOL_CHARS (x))) +#define SCM_ROUCHARS(x) ((SCM_TYP7 (x) == scm_tc7_substring) \ + ? (SCM_INUM (SCM_CADR (x)) + SCM_STRING_UCHARS (SCM_CDDR (x))) \ + : ((SCM_TYP7 (x) == scm_tc7_string) \ + ? SCM_STRING_UCHARS (x) \ + : SCM_SYMBOL_UCHARS (x))) #define SCM_ROLENGTH(x) SCM_LENGTH (x) -#define SCM_SLOPPY_SUBSTRP(x) (SCM_TYP7(x) == scm_tc7_substring) -#define SCM_SUBSTRP(x) (SCM_NIMP(x) && SCM_SLOPPY_SUBSTRP(x)) +#define SCM_SUBSTRP(x) (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_substring)) #define SCM_SUBSTR_STR(x) (SCM_CDDR (x)) #define SCM_SUBSTR_OFFSET(x) (SCM_CADR (x)) @@ -133,6 +137,7 @@ extern void scm_init_symbols (void); #if (SCM_DEBUG_DEPRECATED == 0) +#define SCM_SLOPPY_SUBSTRP(x) (SCM_SUBSTRP (x)) #define scm_strhash(str, len, n) (scm_string_hash ((str), (len)) % (n)) #endif /* SCM_DEBUG_DEPRECATED == 0 */ diff --git a/libguile/tags.h b/libguile/tags.h index 0493e3582..05c21170d 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -210,7 +210,7 @@ typedef long scm_bits_t; * gloc ..........SCM vcell..........001 ...........SCM cdr.............G * struct ..........void * type........001 ...........void * data.........G * closure ..........SCM code...........011 ...........SCM env.............G - * tc7 .........long length....Gxxxx1S1 ..........void *data............ + * tc7 ......24.bits of data...Gxxxx1S1 ..........void *data............ * * * @@ -219,18 +219,11 @@ typedef long scm_bits_t; * 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 a length, thus + * 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). * - * SCM_LENGTH returns the bits in "length" (see the diagram). - * SCM_CHARS returns the data cast to "char *" - * SCM_CDR returns the data cast to "SCM" - * TYP7(X) returns bits 0...6 of SCM_CAR (X) - * - * For the interpretation of SCM_LENGTH and SCM_CHARS - * that applies to a particular type, see the header file - * for that type. + * TYP7(X) returns bits 0...6 of CELL_TYPE (X) * * Sometimes we choose the bottom seven bits carefully, * so that the 2-valued bit (called S bit) can be masked From 3db4adfced1e047e82875f8f914f259182061c1f Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 26 Sep 2000 19:20:39 +0000 Subject: [PATCH 0282/2047] * Removed some more references to SCM_CHARS. * Provided SCM_U?VECTOR_BASE as replacements for SCM_VELTS. --- libguile/ChangeLog | 8 ++++++++ libguile/eval.c | 14 +++++++------- libguile/unif.h | 2 ++ libguile/vectors.h | 1 + 4 files changed, 18 insertions(+), 7 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 5f7aa99ff..c3c13dfe9 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2000-09-26 Dirk Herrmann + + * eval.c (scm_m_letrec1, SCM_CEVAL, SCM_APPLY): Use + SCM_STRING_U?CHARS or SCM_SYMBOL_U?CHARS instead of SCM_U?CHARS. + + * unif.h (SCM_UVECTOR_BASE), vectors.h (SCM_VECTOR_BASE): Added + as replacements for SCM_CHARS and SCM_VELTS. + 2000-09-26 Dirk Herrmann * continuations.c (scm_make_cont, scm_dynthrow), print.c diff --git a/libguile/eval.c b/libguile/eval.c index eb10b3459..6a2b58953 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -916,7 +916,7 @@ static SCM scm_m_letrec1 (SCM op, SCM imm, SCM xorig, SCM env) { SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */ - char *what = SCM_CHARS (SCM_CAR (xorig)); + char *what = SCM_SYMBOL_CHARS (SCM_CAR (xorig)); SCM x = cdrx, proc, arg1; /* structure traversers */ SCM vars = SCM_EOL, inits = SCM_EOL, *initloc = &inits; @@ -2761,15 +2761,15 @@ evapply: #endif floerr: SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), t.arg1, - SCM_ARG1, SCM_CHARS (SCM_SNAME (proc))); + SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); } proc = SCM_SNAME (proc); { - char *chrs = SCM_CHARS (proc) + SCM_LENGTH (proc) - 1; + char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_LENGTH (proc) - 1; while ('c' != *--chrs) { SCM_ASSERT (SCM_CONSP (t.arg1), - t.arg1, SCM_ARG1, SCM_CHARS (proc)); + t.arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc)); t.arg1 = ('a' == *chrs) ? SCM_CAR (t.arg1) : SCM_CDR (t.arg1); } RETURN (t.arg1); @@ -3392,15 +3392,15 @@ tail: #endif floerr: SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, - SCM_ARG1, SCM_CHARS (SCM_SNAME (proc))); + SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); } proc = SCM_SNAME (proc); { - char *chrs = SCM_CHARS (proc) + SCM_LENGTH (proc) - 1; + char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_LENGTH (proc) - 1; while ('c' != *--chrs) { SCM_ASSERT (SCM_CONSP (arg1), - arg1, SCM_ARG1, SCM_CHARS (proc)); + arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc)); arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1); } RETURN (arg1) diff --git a/libguile/unif.h b/libguile/unif.h index d67654a73..fd80f8b56 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -85,6 +85,8 @@ extern long scm_tc16_array; #define SCM_ARRAY_BASE(a) (((scm_array *) SCM_CELL_WORD_1 (a))->base) #define SCM_ARRAY_DIMS(a) ((scm_array_dim *)(SCM_CHARS(a)+sizeof(scm_array))) +#define SCM_UVECTOR_BASE(x) ((void *) (SCM_CELL_WORD_1 (x))) + /* apparently it's possible to have more than SCM_LENGTH_MAX elements in an array: if the length is SCM_LENGTH_MAX then the SCM_VELTS block begins with the true length (a long int). I wonder if it diff --git a/libguile/vectors.h b/libguile/vectors.h index fef91cfa5..3e8708472 100644 --- a/libguile/vectors.h +++ b/libguile/vectors.h @@ -52,6 +52,7 @@ #define SCM_VECTORP(x) (SCM_NIMP (x) && (SCM_TYP7S (x) == scm_tc7_vector)) +#define SCM_VECTOR_BASE(x) ((scm_bits_t *) SCM_CELL_WORD_1 (x)) #define SCM_VELTS(x) ((SCM *) SCM_CELL_WORD_1 (x)) #define SCM_VELTS_AS_STACKITEMS(x) ((SCM_STACKITEM *) SCM_CELL_WORD_1 (x)) #define SCM_SETVELTS(x,v) (SCM_SET_CELL_WORD_1 ((x), (v))) From 9eb364fccba89d07f1063d373df1aff911288e83 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 26 Sep 2000 19:40:10 +0000 Subject: [PATCH 0283/2047] * More references to SCM_CHARS removed. --- libguile/ChangeLog | 11 +++++++++++ libguile/numbers.c | 6 +++--- libguile/vectors.c | 11 ++++++++--- 3 files changed, 22 insertions(+), 6 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index c3c13dfe9..4f61dbcce 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2000-09-26 Dirk Herrmann + + * numbers.c (scm_adjbig): Use SCM_BDIGITS instead of SCM_CHARS. + + (big2str, scm_bigprint): Use SCM_STRING_CHARS instead of + SCM_CHARS. + + * vectors.c (scm_vector_set_length_x): Distinguish between + strings, scheme vectors and uniform vectors, thus getting rid of + references to SCM_CHARS. (The code still needs improvement.) + 2000-09-26 Dirk Herrmann * eval.c (scm_m_letrec1, SCM_CEVAL, SCM_APPLY): Use diff --git a/libguile/numbers.c b/libguile/numbers.c index 590e46cca..c997a4852 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1363,7 +1363,7 @@ scm_adjbig (SCM b, scm_sizet nlen) { SCM_BIGDIG *digits = ((SCM_BIGDIG *) - scm_must_realloc ((char *) SCM_CHARS (b), + scm_must_realloc ((char *) SCM_BDIGITS (b), (long) (SCM_NUMDIGS (b) * sizeof (SCM_BIGDIG)), (long) (nsiz * sizeof (SCM_BIGDIG)), s_bignum)); @@ -2179,7 +2179,7 @@ big2str (SCM b, unsigned int radix) scm_sizet ch; /* jeh */ SCM_BIGDIG radpow = 1, radmod = 0; SCM ss = scm_makstr ((long) j, 0); - char *s = SCM_CHARS (ss), c; + char *s = SCM_STRING_CHARS (ss), c; while ((long) radpow * radix < SCM_BIGRAD) { radpow *= radix; @@ -2271,7 +2271,7 @@ scm_bigprint (SCM exp, SCM port, scm_print_state *pstate) { #ifdef SCM_BIGDIG exp = big2str (exp, (unsigned int) 10); - scm_lfwrite (SCM_CHARS (exp), (scm_sizet) SCM_LENGTH (exp), port); + scm_lfwrite (SCM_STRING_CHARS (exp), (scm_sizet) SCM_LENGTH (exp), port); #else scm_ipruk ("bignum", exp, port); #endif diff --git a/libguile/vectors.c b/libguile/vectors.c index f066f92b2..eeca93439 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -71,6 +71,7 @@ scm_vector_set_length_x (SCM vect, SCM len) long l; scm_sizet siz; scm_sizet sz; + char *base; l = SCM_INUM (len); SCM_ASRTGO (SCM_NIMP (vect), badarg1); @@ -81,7 +82,9 @@ scm_vector_set_length_x (SCM vect, SCM len) l = (l + SCM_LONG_BIT - 1) / SCM_LONG_BIT; } sz = scm_uniform_element_size (vect); - if (sz == 0) + if (sz != 0) + base = SCM_UVECTOR_BASE (vect); + else #endif switch (SCM_TYP7 (vect)) { @@ -90,12 +93,14 @@ scm_vector_set_length_x (SCM vect, SCM len) case scm_tc7_string: SCM_ASRTGO (!SCM_EQ_P (vect, scm_nullstr), badarg1); sz = sizeof (char); + base = SCM_STRING_CHARS (vect); l++; break; case scm_tc7_vector: case scm_tc7_wvect: SCM_ASRTGO (!SCM_EQ_P (vect, scm_nullvect), badarg1); sz = sizeof (SCM); + base = (char *) SCM_VECTOR_BASE (vect); break; } SCM_ASSERT (SCM_INUMP (len), len, SCM_ARG2, s_vector_set_length_x); @@ -107,7 +112,7 @@ scm_vector_set_length_x (SCM vect, SCM len) SCM_REDEFER_INTS; SCM_SETCHARS (vect, ((char *) - scm_must_realloc (SCM_CHARS (vect), + scm_must_realloc (base, (long) SCM_LENGTH (vect) * sz, (long) siz, s_vector_set_length_x))); @@ -118,7 +123,7 @@ scm_vector_set_length_x (SCM vect, SCM len) SCM_VELTS (vect)[--l] = SCM_UNSPECIFIED; } else if (SCM_STRINGP (vect)) - SCM_CHARS (vect)[l - 1] = 0; + SCM_STRING_CHARS (vect)[l - 1] = 0; SCM_SETLENGTH (vect, SCM_INUM (len), SCM_TYP7 (vect)); SCM_REALLOW_INTS; return vect; From 74cc85038e5685aa7f9e81e0a9004b0717fb22a5 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 26 Sep 2000 20:11:22 +0000 Subject: [PATCH 0284/2047] * Don't use string or vector macros when accessing compiled closures. --- libguile/ChangeLog | 16 ++++++++++++++++ libguile/gsubr.c | 4 ++-- libguile/gsubr.h | 6 ++++-- libguile/procs.c | 14 +++++++++----- libguile/procs.h | 12 +++++++++++- 5 files changed, 42 insertions(+), 10 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 4f61dbcce..59e083f2e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,19 @@ +2000-09-26 Dirk Herrmann + + * procs.h (SCM_CCLO_LENGTH, SCM_SET_CCLO_LENGTH, SCM_CCLO_BASE, + SCM_SET_CCLO_BASE, SCM_CCLO_REF, SCM_CCLO_SET, SCM_CCLO_SUBR, + SCM_SET_CCLO_SUBR): Added resp. changed such that none of the + macros SCM_CHARS, SCM_SETCHARS, SCM_VELTS and SCM_LENGTH have to + be used with compiled closures any more. + + * procs.c (scm_makcclo), gsubr.h (SCM_GSUBR_TYPE, SCM_GSUBR_PROC): + Replace uses of SCM_CHARS, SCM_SETCHARS and SCM_VELTS with regards + to compiled closures. + + * gsubr.h (SCM_SET_GSUBR_TYPE, SCM_SET_GSUBR_PROC): Added. + + * gsubr.c (scm_make_gsubr): Use them. + 2000-09-26 Dirk Herrmann * numbers.c (scm_adjbig): Use SCM_BDIGITS instead of SCM_CHARS. diff --git a/libguile/gsubr.c b/libguile/gsubr.c index 3b77dee1b..cccbabc29 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -83,8 +83,8 @@ scm_make_gsubr(const char *name,int req,int opt,int rst,SCM (*fcn)()) fputs("ERROR in scm_make_gsubr: too many args\n", stderr); exit (1); } - SCM_GSUBR_PROC (cclo) = scm_make_subr_opt (name, scm_tc7_subr_0, fcn, 0); - SCM_GSUBR_TYPE (cclo) = SCM_MAKINUM (SCM_GSUBR_MAKTYPE (req, opt, rst)); + SCM_SET_GSUBR_PROC (cclo, scm_make_subr_opt (name, scm_tc7_subr_0, fcn, 0)); + SCM_SET_GSUBR_TYPE (cclo, SCM_MAKINUM (SCM_GSUBR_MAKTYPE (req, opt, rst))); SCM_SETCDR (symcell, cclo); #ifdef DEBUG_EXTENSIONS if (SCM_REC_PROCNAMES_P) diff --git a/libguile/gsubr.h b/libguile/gsubr.h index be7b4d5af..90153c30a 100644 --- a/libguile/gsubr.h +++ b/libguile/gsubr.h @@ -54,8 +54,10 @@ #define SCM_GSUBR_REST(x) ((int)(x)>>8) #define SCM_GSUBR_MAX 10 -#define SCM_GSUBR_TYPE(cclo) (SCM_VELTS(cclo)[1]) -#define SCM_GSUBR_PROC(cclo) (SCM_VELTS(cclo)[2]) +#define SCM_GSUBR_TYPE(cclo) (SCM_CCLO_REF ((cclo), 1)) +#define SCM_SET_GSUBR_TYPE(cclo, type) (SCM_CCLO_SET ((cclo), 1, (type))) +#define SCM_GSUBR_PROC(cclo) (SCM_CCLO_REF ((cclo), 2)) +#define SCM_SET_GSUBR_PROC(cclo, proc) (SCM_CCLO_SET ((cclo), 2, (proc))) extern SCM scm_f_gsubr_apply; diff --git a/libguile/procs.c b/libguile/procs.c index 456cd19f0..f979cd097 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -153,14 +153,18 @@ scm_mark_subr_table () SCM scm_makcclo (SCM proc, long len) { + scm_bits_t *base = scm_must_malloc (len * sizeof (scm_bits_t), "compiled-closure"); + unsigned long i; SCM s; + + for (i = 0; i < len; ++i) + base [i] = SCM_UNPACK (SCM_UNSPECIFIED); + SCM_NEWCELL (s); SCM_DEFER_INTS; - SCM_SETCHARS (s, scm_must_malloc (len * sizeof (SCM), "compiled-closure")); - SCM_SETLENGTH (s, len, scm_tc7_cclo); - while (--len) - SCM_VELTS (s)[len] = SCM_UNSPECIFIED; - SCM_CCLO_SUBR (s) = proc; + SCM_SET_CCLO_BASE (s, base); + SCM_SET_CCLO_LENGTH (s, len); + SCM_SET_CCLO_SUBR (s, proc); SCM_ALLOW_INTS; return s; } diff --git a/libguile/procs.h b/libguile/procs.h index 942385d7d..0a3de0374 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -74,7 +74,17 @@ typedef struct #define SCM_SUBRF(x) ((SCM (*)()) SCM_CELL_WORD_1 (x)) #define SCM_SET_SUBRF(x, v) (SCM_SET_CELL_WORD_1 ((x), (v))) #define SCM_DSUBRF(x) ((double (*)()) SCM_CELL_WORD_1 (x)) -#define SCM_CCLO_SUBR(x) (SCM_VELTS(x)[0]) + +#define SCM_CCLO_LENGTH(x) (SCM_CELL_WORD_0 (x) >> 8) +#define SCM_SET_CCLO_LENGTH(x, v) (SCM_SET_CELL_WORD_0 ((x), ((v) << 8) + scm_tc7_cclo)) +#define SCM_CCLO_BASE(x) ((scm_bits_t *) SCM_CELL_WORD_1 (x)) +#define SCM_SET_CCLO_BASE(x, v) (SCM_SET_CELL_WORD_1 ((x), (v))) + +#define SCM_CCLO_REF(x, i) (SCM_PACK (SCM_CCLO_BASE (x) [i])) +#define SCM_CCLO_SET(x, i, v) (SCM_CCLO_BASE (x) [i] = SCM_UNPACK (v)) + +#define SCM_CCLO_SUBR(x) (SCM_CCLO_REF ((x), 0)) +#define SCM_SET_CCLO_SUBR(x, v) (SCM_CCLO_SET ((x), 0, (v))) #define SCM_SUBR_GENERIC(x) (SCM_SUBR_ENTRY (x).generic) #define SCM_SUBR_PROPS(x) (SCM_SUBR_ENTRY (x).properties) From 06ee04b27dc3acf49ed644d78f197bef8efc4b89 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 26 Sep 2000 20:34:26 +0000 Subject: [PATCH 0285/2047] * Further references to SCM_CHARS removed. --- libguile/ChangeLog | 12 ++++++++++ libguile/gc.c | 56 +++++++++++++++++++++++----------------------- 2 files changed, 40 insertions(+), 28 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 59e083f2e..adc316a1a 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,15 @@ +2000-09-26 Dirk Herrmann + + * gc.c (scm_igc): : Eliminate references to SCM_LENGTH and + SCM_CHARS from comment. + + (scm_gc_mark, scm_gc_sweep): Replace SCM_CHARS with + SCM_SYMBOL_CHARS or SCM_CCLO_BASE or SCM_UVECTOR_BASE or + SCM_BDIGITS, and replace SCM_VELTS with SCM_VECTOR_BASE or + SCM_CONTREGS, according to the corresponding types. + + (scm_gc_sweep): Simplify sweeping of uniform vectors. + 2000-09-26 Dirk Herrmann * procs.h (SCM_CCLO_LENGTH, SCM_SET_CCLO_LENGTH, SCM_CCLO_BASE, diff --git a/libguile/gc.c b/libguile/gc.c index 4f35398ec..18b424a33 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1028,8 +1028,8 @@ scm_igc (const char *what) /* Protect from the C stack. This must be the first marking * done because it provides information about what objects * are "in-use" by the C code. "in-use" objects are those - * for which the values from SCM_LENGTH and SCM_CHARS must remain - * usable. This requirement is stricter than a liveness + * for which the information about length and base address must + * remain usable. This requirement is stricter than a liveness * requirement -- in particular, it constrains the implementation * of scm_vector_set_length_x. */ @@ -1173,7 +1173,7 @@ gc_mark_nimp: /* ptr is a struct */ SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]); int len = SCM_LENGTH (layout); - char * fields_desc = SCM_CHARS (layout); + char * fields_desc = SCM_SYMBOL_CHARS (layout); scm_bits_t * struct_data = (scm_bits_t *) SCM_STRUCT_DATA (ptr); if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) @@ -1604,45 +1604,36 @@ scm_gc_sweep () break; case scm_tc7_wvect: m += (2 + SCM_LENGTH (scmptr)) * sizeof (SCM); - scm_must_free ((char *)(SCM_VELTS (scmptr) - 2)); + scm_must_free (SCM_VECTOR_BASE (scmptr) - 2); break; case scm_tc7_vector: + m += (SCM_LENGTH (scmptr) * sizeof (SCM)); + scm_must_free (SCM_VECTOR_BASE (scmptr)); + break; #ifdef CCLO case scm_tc7_cclo: -#endif m += (SCM_LENGTH (scmptr) * sizeof (SCM)); - freechars: - scm_must_free (SCM_CHARS (scmptr)); - /* SCM_SETCHARS(scmptr, 0);*/ + scm_must_free (SCM_CCLO_BASE (scmptr)); break; +#endif #ifdef HAVE_ARRAYS case scm_tc7_bvect: m += sizeof (long) * ((SCM_HUGE_LENGTH (scmptr) + SCM_LONG_BIT - 1) / SCM_LONG_BIT); - goto freechars; + scm_must_free (SCM_UVECTOR_BASE (scmptr)); + break; case scm_tc7_byvect: - m += SCM_HUGE_LENGTH (scmptr) * sizeof (char); - goto freechars; case scm_tc7_ivect: case scm_tc7_uvect: - m += SCM_HUGE_LENGTH (scmptr) * sizeof (long); - goto freechars; case scm_tc7_svect: - m += SCM_HUGE_LENGTH (scmptr) * sizeof (short); - goto freechars; #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: - m += SCM_HUGE_LENGTH (scmptr) * sizeof (long_long); - goto freechars; #endif case scm_tc7_fvect: - m += SCM_HUGE_LENGTH (scmptr) * sizeof (float); - goto freechars; case scm_tc7_dvect: - m += SCM_HUGE_LENGTH (scmptr) * sizeof (double); - goto freechars; case scm_tc7_cvect: - m += SCM_HUGE_LENGTH (scmptr) * 2 * sizeof (double); - goto freechars; + m += SCM_HUGE_LENGTH (scmptr) * scm_uniform_element_size (scmptr); + scm_must_free (SCM_UVECTOR_BASE (scmptr)); + break; #endif case scm_tc7_substring: break; @@ -1656,8 +1647,15 @@ scm_gc_sweep () break; case scm_tc7_contin: m += SCM_LENGTH (scmptr) * sizeof (SCM_STACKITEM) + sizeof (scm_contregs); - if (SCM_VELTS (scmptr)) - goto freechars; + if (SCM_CONTREGS (scmptr)) + { + scm_must_free (SCM_CONTREGS (scmptr)); + break; + } + else + { + continue; + } case scm_tcs_subrs: /* the various "subrs" (primitives) are never freed */ continue; @@ -1689,11 +1687,13 @@ scm_gc_sweep () #ifdef SCM_BIGDIG case scm_tc16_big: m += (SCM_NUMDIGS (scmptr) * SCM_BITSPERDIG / SCM_CHAR_BIT); - goto freechars; + scm_must_free (SCM_BDIGITS (scmptr)); + break; #endif /* def SCM_BIGDIG */ case scm_tc16_complex: - m += 2 * sizeof (double); - goto freechars; + m += sizeof (scm_complex_t); + scm_must_free (SCM_CHARS (scmptr)); + break; default: { int k; From 548b92528934487f4a268b3038a1586c3d54bf01 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 26 Sep 2000 20:39:03 +0000 Subject: [PATCH 0286/2047] =?UTF-8?q?*=20Remember=20that=20string=3D=3F=20?= =?UTF-8?q?and=20friends=20need=20fixing.?= --- test-suite/ChangeLog | 5 +++++ test-suite/tests/strings.test | 9 +++++++++ 2 files changed, 14 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index b0fea8962..18b9582b8 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2000-09-26 Dirk Herrmann + + * tests/strings.test: Added a test to help remember that string=? + and friends need fixing. + 2000-09-12 Dirk Herrmann * tests/environments.test: For tests that rely on garbage diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test index e439b95a1..9305128f8 100644 --- a/test-suite/tests/strings.test +++ b/test-suite/tests/strings.test @@ -20,6 +20,15 @@ (use-modules (test-suite lib)) + +(expect-fail "string=? does not accept symbols" + (catch 'wrong-type-arg + (lambda () + (string=? 'a 'b) + #f) + (lambda args + #t))) + (pass-if "string Date: Tue, 26 Sep 2000 21:53:49 +0000 Subject: [PATCH 0287/2047] * Eliminated all remaining calls to SCM_CHARS. --- libguile/ChangeLog | 30 ++++++++++++++++++++++++++++++ libguile/gc.c | 2 +- libguile/numbers.h | 5 +++-- libguile/ramap.c | 33 +++++++++++++++++++++++---------- libguile/read.c | 32 ++++++++++++++++---------------- libguile/symbols.h | 2 +- libguile/unif.c | 36 ++++++++++++++++++++++++------------ libguile/unif.h | 7 ++++--- libguile/validate.h | 5 +---- 9 files changed, 103 insertions(+), 49 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index adc316a1a..ee2971108 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,33 @@ +2000-09-26 Dirk Herrmann + + * gc.c (scm_gc_sweep): Replace SCM_CHARS by SCM_COMPLEX_MEM. + + * numbers.h (SCM_COMPLEX_MEM): Added as a replacement for + SCM_CHARS. + + (SCM_COMPLEX_REAL, SCM_COMPLEX_IMAG): Use it. + + * ramap.c (scm_array_fill_int, racp, raeql_1): Replace SCM_CHARS + with SCM_STRING_CHARS or SCM_UVECTOR_BASE. + + (racp): Fix: Make sure that src and dst types match. + + * read.c (scm_grow_tok_buf, scm_lreadr, scm_read_token): Replace + SCM_CHARS with SCM_STRING_CHARS. + + * symbols.h (SCM_CHARS): Deprecated. + + * unif.c (scm_enclose_array, scm_uniform_vector_ref, scm_cvref, + scm_array_set_x, scm_uniform_array_read_x, rapr1, freera, + scm_uniform_array_write): Replace SCM_CHARS with + SCM_STRING_CHARS, SCM_UVECTOR_BASE or SCM_ARRAY_MEM. + + * unif.h (SCM_ARRAY_MEM): Added as a replacement for SCM_CHARS. + + (SCM_ARRAY_V, SCM_ARRAY_BASE, SCM_ARRAY_DIMS): Use it. + + * validate.h (SCM_COERCE_ROSTRING): Removed. + 2000-09-26 Dirk Herrmann * gc.c (scm_igc): : Eliminate references to SCM_LENGTH and diff --git a/libguile/gc.c b/libguile/gc.c index 18b424a33..f101b4b98 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1692,7 +1692,7 @@ scm_gc_sweep () #endif /* def SCM_BIGDIG */ case scm_tc16_complex: m += sizeof (scm_complex_t); - scm_must_free (SCM_CHARS (scmptr)); + scm_must_free (SCM_COMPLEX_MEM (scmptr)); break; default: { diff --git a/libguile/numbers.h b/libguile/numbers.h index d486d7ee2..2dc879ca4 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -134,8 +134,9 @@ #define SCM_COMPLEXP(x) (SCM_NIMP (x) && SCM_TYP16 (x) == scm_tc16_complex) #define SCM_REAL_VALUE(x) (((scm_double_t *) SCM2PTR (x))->real) -#define SCM_COMPLEX_REAL(x) (((scm_complex_t *) SCM_CELL_WORD_1 (x))->real) -#define SCM_COMPLEX_IMAG(x) (((scm_complex_t *) SCM_CELL_WORD_1 (x))->imag) +#define SCM_COMPLEX_MEM(x) ((scm_complex_t *) SCM_CELL_WORD_1 (x)) +#define SCM_COMPLEX_REAL(x) (SCM_COMPLEX_MEM (x)->real) +#define SCM_COMPLEX_IMAG(x) (SCM_COMPLEX_MEM (x)->imag) /* Define SCM_BIGDIG to an integer type whose size is smaller than long if * you want bignums. SCM_BIGRAD is one greater than the biggest SCM_BIGDIG. diff --git a/libguile/ramap.c b/libguile/ramap.c index 679439177..6631d8fc9 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -53,6 +53,7 @@ #include #include "libguile/_scm.h" +#include "libguile/strings.h" #include "libguile/unif.h" #include "libguile/smob.h" #include "libguile/chars.h" @@ -489,7 +490,7 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore) case scm_tc7_string: SCM_ASRTGO (SCM_CHARP (fill), badarg2); for (i = base; n--; i += inc) - SCM_CHARS (ra)[i] = SCM_CHAR (fill); + SCM_STRING_CHARS (ra)[i] = SCM_CHAR (fill); break; case scm_tc7_byvect: if (SCM_CHARP (fill)) @@ -498,7 +499,7 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore) && -128 <= SCM_INUM (fill) && SCM_INUM (fill) < 128, badarg2); for (i = base; n--; i += inc) - SCM_CHARS (ra)[i] = SCM_INUM (fill); + ((char *) SCM_UVECTOR_BASE (ra))[i] = SCM_INUM (fill); break; case scm_tc7_bvect: { /* scope */ @@ -645,8 +646,7 @@ racp (SCM src, SCM dst) if (SCM_EQ_P (src, dst)) return 1 ; - switch SCM_TYP7 - (dst) + switch SCM_TYP7 (dst) { default: gencase: @@ -657,14 +657,19 @@ racp (SCM src, SCM dst) scm_array_set_x (dst, scm_cvref (src, i_s, SCM_UNDEFINED), SCM_MAKINUM (i_d)); break; case scm_tc7_string: - case scm_tc7_byvect: - if (scm_tc7_string != SCM_TYP7 (dst)) + if (SCM_TYP7 (src) != scm_tc7_string) goto gencase; for (; n-- > 0; i_s += inc_s, i_d += inc_d) - SCM_CHARS (dst)[i_d] = SCM_CHARS (src)[i_s]; + SCM_STRING_CHARS (dst)[i_d] = SCM_STRING_CHARS (src)[i_s]; + break; + case scm_tc7_byvect: + if (SCM_TYP7 (src) != scm_tc7_byvect) + goto gencase; + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + ((char *) SCM_UVECTOR_BASE (dst))[i_d] = ((char *) SCM_UVECTOR_BASE (src))[i_s]; break; case scm_tc7_bvect: - if (scm_tc7_bvect != SCM_TYP7 (dst)) + if (SCM_TYP7 (src) != scm_tc7_bvect) goto gencase; if (1 == inc_d && 1 == inc_s && i_s % SCM_LONG_BIT == i_d % SCM_LONG_BIT && n >= SCM_LONG_BIT) { @@ -1797,10 +1802,18 @@ raeql_1 (SCM ra0,SCM as_equal,SCM ra1) } return 1; case scm_tc7_string: + { + char *v0 = SCM_STRING_CHARS (ra0) + i0; + char *v1 = SCM_STRING_CHARS (ra1) + i1; + for (; n--; v0 += inc0, v1 += inc1) + if (*v0 != *v1) + return 0; + return 1; + } case scm_tc7_byvect: { - char *v0 = SCM_CHARS (ra0) + i0; - char *v1 = SCM_CHARS (ra1) + i1; + char *v0 = ((char *) SCM_UVECTOR_BASE (ra0)) + i0; + char *v1 = ((char *) SCM_UVECTOR_BASE (ra1)) + i1; for (; n--; v0 += inc0, v1 += inc1) if (*v0 != *v1) return 0; diff --git a/libguile/read.c b/libguile/read.c index 23d0e9ada..c599f451c 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -123,7 +123,7 @@ char * scm_grow_tok_buf (SCM *tok_buf) { scm_vector_set_length_x (*tok_buf, SCM_MAKINUM (2 * SCM_LENGTH (*tok_buf))); - return SCM_CHARS (*tok_buf); + return SCM_STRING_CHARS (*tok_buf); } @@ -365,7 +365,7 @@ tryagain_no_flush_ws: #ifdef HAVE_ARRAYS case '*': j = scm_read_token (c, tok_buf, port, 0); - p = scm_istr2bve (SCM_CHARS (*tok_buf) + 1, (long) (j - 1)); + p = scm_istr2bve (SCM_STRING_CHARS (*tok_buf) + 1, (long) (j - 1)); if (SCM_NFALSEP (p)) return p; else @@ -374,7 +374,7 @@ tryagain_no_flush_ws: case '{': j = scm_read_token (c, tok_buf, port, 1); - p = scm_intern (SCM_CHARS (*tok_buf), j); + p = scm_intern (SCM_STRING_CHARS (*tok_buf), j); return SCM_CAR (p); case '\\': @@ -384,20 +384,20 @@ tryagain_no_flush_ws: return SCM_MAKE_CHAR (c); if (c >= '0' && c < '8') { - p = scm_istr2int (SCM_CHARS (*tok_buf), (long) j, 8); + p = scm_istr2int (SCM_STRING_CHARS (*tok_buf), (long) j, 8); if (SCM_NFALSEP (p)) return SCM_MAKE_CHAR (SCM_INUM (p)); } for (c = 0; c < scm_n_charnames; c++) if (scm_charnames[c] - && (scm_casei_streq (scm_charnames[c], SCM_CHARS (*tok_buf)))) + && (scm_casei_streq (scm_charnames[c], SCM_STRING_CHARS (*tok_buf)))) return SCM_MAKE_CHAR (scm_charnums[c]); - scm_wta (SCM_UNDEFINED, "unknown # object: #\\", SCM_CHARS (*tok_buf)); + scm_wta (SCM_UNDEFINED, "unknown # object: #\\", SCM_STRING_CHARS (*tok_buf)); /* #:SYMBOL is a syntax for keywords supported in all contexts. */ case ':': j = scm_read_token ('-', tok_buf, port, 0); - p = scm_intern (SCM_CHARS (*tok_buf), j); + p = scm_intern (SCM_STRING_CHARS (*tok_buf), j); return scm_make_keyword_from_dash_symbol (SCM_CAR (p)); default: @@ -464,15 +464,15 @@ tryagain_no_flush_ws: c = '\v'; break; } - SCM_CHARS (*tok_buf)[j] = c; + SCM_STRING_CHARS (*tok_buf)[j] = c; ++j; } if (j == 0) return scm_nullstr; - SCM_CHARS (*tok_buf)[j] = 0; + SCM_STRING_CHARS (*tok_buf)[j] = 0; { SCM str; - str = scm_makfromstr (SCM_CHARS (*tok_buf), j, 0); + str = scm_makfromstr (SCM_STRING_CHARS (*tok_buf), j, 0); return str; } @@ -483,7 +483,7 @@ tryagain_no_flush_ws: case '+': num: j = scm_read_token (c, tok_buf, port, 0); - p = scm_istring2number (SCM_CHARS (*tok_buf), (long) j, 10L); + p = scm_istring2number (SCM_STRING_CHARS (*tok_buf), (long) j, 10L); if (SCM_NFALSEP (p)) return p; if (c == '#') @@ -491,10 +491,10 @@ tryagain_no_flush_ws: if ((j == 2) && (scm_getc (port) == '(')) { scm_ungetc ('(', port); - c = SCM_CHARS (*tok_buf)[1]; + c = SCM_STRING_CHARS (*tok_buf)[1]; goto callshrp; } - scm_wta (SCM_UNDEFINED, "unknown # object", SCM_CHARS (*tok_buf)); + scm_wta (SCM_UNDEFINED, "unknown # object", SCM_STRING_CHARS (*tok_buf)); } goto tok; @@ -502,7 +502,7 @@ tryagain_no_flush_ws: if (SCM_EQ_P (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_prefix)) { j = scm_read_token ('-', tok_buf, port, 0); - p = scm_intern (SCM_CHARS (*tok_buf), j); + p = scm_intern (SCM_STRING_CHARS (*tok_buf), j); return scm_make_keyword_from_dash_symbol (SCM_CAR (p)); } /* fallthrough */ @@ -511,7 +511,7 @@ tryagain_no_flush_ws: /* fallthrough */ tok: - p = scm_intern (SCM_CHARS (*tok_buf), j); + p = scm_intern (SCM_STRING_CHARS (*tok_buf), j); return SCM_CAR (p); } } @@ -528,7 +528,7 @@ scm_read_token (int ic, SCM *tok_buf, SCM port, int weird) register char *p; c = (SCM_CASE_INSENSITIVE_P ? scm_downcase(ic) : ic); - p = SCM_CHARS (*tok_buf); + p = SCM_STRING_CHARS (*tok_buf); if (weird) j = 0; diff --git a/libguile/symbols.h b/libguile/symbols.h index 352f11467..b9aab4b4a 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -64,7 +64,6 @@ extern int scm_symhash_dim; #define SCM_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_SETLENGTH(x, v, t) (SCM_SET_CELL_WORD_0 ((x), ((v) << 8) + (t))) -#define SCM_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) #define SCM_UCHARS(x) ((unsigned char *) (SCM_CELL_WORD_1 (x))) #define SCM_SETCHARS(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_bits_t) (v))) @@ -137,6 +136,7 @@ extern void scm_init_symbols (void); #if (SCM_DEBUG_DEPRECATED == 0) +#define SCM_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) #define SCM_SLOPPY_SUBSTRP(x) (SCM_SUBSTRP (x)) #define scm_strhash(str, len, n) (scm_string_hash ((str), (len)) % (n)) diff --git a/libguile/unif.c b/libguile/unif.c index 45b792015..32df60237 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -972,11 +972,11 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, SCM_ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd; SCM_ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd; SCM_ARRAY_DIMS (ra_inr)[k].inc = s[j].inc; - SCM_CHARS (axv)[j] = 1; + SCM_STRING_CHARS (axv)[j] = 1; } for (j = 0, k = 0; k < noutr; k++, j++) { - while (SCM_CHARS (axv)[j]) + while (SCM_STRING_CHARS (axv)[j]) j++; SCM_ARRAY_DIMS (res)[k].lbnd = s[j].lbnd; SCM_ARRAY_DIMS (res)[k].ubnd = s[j].ubnd; @@ -1140,7 +1140,7 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, case scm_tc7_string: return SCM_MAKE_CHAR (SCM_UCHARS (v)[pos]); case scm_tc7_byvect: - return SCM_MAKINUM (((char *)SCM_CHARS (v))[pos]); + return SCM_MAKINUM (((char *) SCM_UVECTOR_BASE (v))[pos]); case scm_tc7_uvect: return scm_ulong2num (((unsigned long *) SCM_VELTS (v))[pos]); case scm_tc7_ivect: @@ -1185,7 +1185,7 @@ scm_cvref (SCM v, scm_sizet pos, SCM last) case scm_tc7_string: return SCM_MAKE_CHAR (SCM_UCHARS (v)[pos]); case scm_tc7_byvect: - return SCM_MAKINUM (((char *)SCM_CHARS (v))[pos]); + return SCM_MAKINUM (((char *) SCM_UVECTOR_BASE (v))[pos]); case scm_tc7_uvect: return scm_ulong2num(((unsigned long *) SCM_VELTS (v))[pos]); case scm_tc7_ivect: @@ -1300,7 +1300,7 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, if (SCM_CHARP (obj)) obj = SCM_MAKINUM ((char) SCM_CHAR (obj)); SCM_ASRTGO (SCM_INUMP (obj), badobj); - ((char *)SCM_CHARS (v))[pos] = SCM_INUM (obj); + ((char *) SCM_UVECTOR_BASE (v))[pos] = SCM_INUM (obj); break; case scm_tc7_uvect: SCM_VELTS(v)[pos] = SCM_PACK (scm_num2ulong(obj, (char *)SCM_ARG2, FUNC_NAME)); @@ -1475,6 +1475,7 @@ SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0, long cstart = 0; long cend; long offset = 0; + char *base; SCM_ASRTGO (SCM_NIMP (v), badarg1); if (SCM_UNBNDP (port_or_fd)) @@ -1527,7 +1528,12 @@ loop: sz = 2 * sizeof (double); break; } - + + if (SCM_STRINGP (v)) + base = SCM_STRING_CHARS (v); + else + base = (char *) SCM_UVECTOR_BASE (v); + cend = vlen; if (!SCM_UNBNDP (start)) { @@ -1552,7 +1558,7 @@ loop: { scm_port *pt = SCM_PTAB_ENTRY (port_or_fd); int remaining = (cend - offset) * sz; - char *dest = SCM_CHARS (v) + (cstart + offset) * sz; + char *dest = base + (cstart + offset) * sz; if (pt->rw_active == SCM_PORT_WRITE) scm_flush (port_or_fd); @@ -1590,7 +1596,7 @@ loop: else /* file descriptor. */ { SCM_SYSCALL (ans = read (SCM_INUM (port_or_fd), - SCM_CHARS (v) + (cstart + offset) * sz, + base + (cstart + offset) * sz, (scm_sizet) (sz * (cend - offset)))); if (ans == -1) SCM_SYSERROR; @@ -1623,6 +1629,7 @@ SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0, long offset = 0; long cstart = 0; long cend; + char *base; port_or_fd = SCM_COERCE_OUTPORT (port_or_fd); @@ -1678,6 +1685,11 @@ loop: break; } + if (SCM_STRINGP (v)) + base = SCM_STRING_CHARS (v); + else + base = (char *) SCM_UVECTOR_BASE (v); + cend = vlen; if (!SCM_UNBNDP (start)) { @@ -1700,7 +1712,7 @@ loop: if (SCM_NIMP (port_or_fd)) { - char *source = SCM_CHARS (v) + (cstart + offset) * sz; + char *source = base + (cstart + offset) * sz; ans = cend - offset; scm_lfwrite (source, ans * sz, port_or_fd); @@ -1708,7 +1720,7 @@ loop: else /* file descriptor. */ { SCM_SYSCALL (ans = write (SCM_INUM (port_or_fd), - SCM_CHARS (v) + (cstart + offset) * sz, + base + (cstart + offset) * sz, (scm_sizet) (sz * (cend - offset)))); if (ans == -1) SCM_SYSERROR; @@ -2298,7 +2310,7 @@ tail: } else for (j += inc; n-- > 0; j += inc) - scm_putc (SCM_CHARS (ra)[j], port); + scm_putc (SCM_STRING_CHARS (ra)[j], port); break; case scm_tc7_byvect: if (n-- > 0) @@ -2554,7 +2566,7 @@ markra (SCM ptr) static scm_sizet freera (SCM ptr) { - scm_must_free (SCM_CHARS (ptr)); + scm_must_free (SCM_ARRAY_MEM (ptr)); return sizeof (scm_array) + SCM_ARRAY_NDIM (ptr) * sizeof (scm_array_dim); } diff --git a/libguile/unif.h b/libguile/unif.h index fd80f8b56..32f0317a4 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -81,9 +81,10 @@ extern long scm_tc16_array; #define SCM_ARRAY_CONTIGUOUS 0x10000 #define SCM_ARRAY_CONTP(x) (SCM_ARRAY_CONTIGUOUS & (SCM_CELL_WORD_0 (x))) -#define SCM_ARRAY_V(a) (((scm_array *) SCM_CELL_WORD_1 (a))->v) -#define SCM_ARRAY_BASE(a) (((scm_array *) SCM_CELL_WORD_1 (a))->base) -#define SCM_ARRAY_DIMS(a) ((scm_array_dim *)(SCM_CHARS(a)+sizeof(scm_array))) +#define SCM_ARRAY_MEM(a) ((scm_array *) SCM_CELL_WORD_1 (a)) +#define SCM_ARRAY_V(a) (SCM_ARRAY_MEM (a)->v) +#define SCM_ARRAY_BASE(a) (SCM_ARRAY_MEM (a)->base) +#define SCM_ARRAY_DIMS(a) ((scm_array_dim *)((char *) SCM_ARRAY_MEM (a) + sizeof (scm_array))) #define SCM_UVECTOR_BASE(x) ((void *) (SCM_CELL_WORD_1 (x))) diff --git a/libguile/validate.h b/libguile/validate.h index 178c34781..c07b04fb4 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -1,4 +1,4 @@ -/* $Id: validate.h,v 1.15 2000-09-22 17:17:55 dirk Exp $ */ +/* $Id: validate.h,v 1.16 2000-09-26 21:53:49 dirk Exp $ */ /* Copyright (C) 1999, 2000 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify @@ -54,9 +54,6 @@ #define SCM_SYSERROR_MSG(str, args, val) \ do { scm_syserror_msg (FUNC_NAME, (str), (args), (val)); } while (0) -#define SCM_COERCE_ROSTRING(pos, scm) \ - do { scm = scm_coerce_rostring (scm, FUNC_NAME, pos); } while (0) - #define SCM_WTA(pos, scm) \ do { scm_wta (scm, (char *) pos, FUNC_NAME); } while (0) From 322ac0c5ccbeee968e3bd5b44398a5921b2fa311 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 26 Sep 2000 22:15:13 +0000 Subject: [PATCH 0288/2047] * Eliminated all calls to SCM_UCHARS. --- libguile/strings.c | 8 ++++---- libguile/strop.c | 43 ++++++++++++++----------------------------- libguile/strports.c | 2 +- libguile/symbols.c | 10 +++++----- libguile/symbols.h | 2 +- libguile/unif.c | 10 +++++----- 6 files changed, 30 insertions(+), 45 deletions(-) diff --git a/libguile/strings.c b/libguile/strings.c index 872cdc33b..7174d5c84 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -109,7 +109,7 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1, } { - unsigned char *data = SCM_UCHARS (result); + unsigned char *data = SCM_STRING_UCHARS (result); while (SCM_NNULLP (chrs)) { @@ -226,7 +226,7 @@ SCM_DEFINE (scm_make_string, "make-string", 1, 1, 0, { SCM_VALIDATE_CHAR (2,chr); { - unsigned char *dst = SCM_UCHARS (res); + unsigned char *dst = SCM_STRING_UCHARS (res); char c = SCM_CHAR (chr); memset (dst, c, i); @@ -270,7 +270,7 @@ SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0, SCM_VALIDATE_RWSTRING (1,str); SCM_VALIDATE_INUM_RANGE (2,k,0,SCM_LENGTH(str)); SCM_VALIDATE_CHAR (3,chr); - SCM_UCHARS (str)[SCM_INUM (k)] = SCM_CHAR (chr); + SCM_STRING_UCHARS (str)[SCM_INUM (k)] = SCM_CHAR (chr); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -320,7 +320,7 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, i += SCM_ROLENGTH (s); } res = scm_makstr (i, 0); - data = SCM_UCHARS (res); + data = SCM_STRING_UCHARS (res); for (l = args;SCM_NIMP (l);l = SCM_CDR (l)) { s = SCM_CAR (l); for (i = 0;iread_buf = pt->write_buf = SCM_UCHARS (stream); + pt->read_buf = pt->write_buf = SCM_STRING_UCHARS (stream); pt->read_pos = pt->write_pos = pt->write_buf + index; pt->write_end = pt->write_buf + pt->write_buf_size; pt->read_end = pt->read_buf + pt->read_buf_size; diff --git a/libguile/symbols.c b/libguile/symbols.c index 956400d9b..0e477f9fb 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -144,7 +144,7 @@ scm_sym2vcell (SCM sym, SCM thunk, SCM definep) SCM * lsymp; SCM z; scm_sizet hash - = scm_string_hash (SCM_UCHARS (sym), SCM_LENGTH (sym)) % scm_symhash_dim; + = scm_string_hash (SCM_SYMBOL_UCHARS (sym), SCM_LENGTH (sym)) % scm_symhash_dim; SCM_DEFER_INTS; for (lsym = SCM_VELTS (scm_symhash)[hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) @@ -189,7 +189,7 @@ scm_sym2ovcell_soft (SCM sym, SCM obarray) { SCM lsym, z; scm_sizet hash - = scm_string_hash (SCM_UCHARS (sym), SCM_LENGTH (sym)) % SCM_LENGTH (obarray); + = scm_string_hash (SCM_SYMBOL_UCHARS (sym), SCM_LENGTH (sym)) % SCM_LENGTH (obarray); SCM_REDEFER_INTS; for (lsym = SCM_VELTS (obarray)[hash]; SCM_NIMP (lsym); @@ -264,7 +264,7 @@ scm_intern_obarray_soft (const char *name,scm_sizet len,SCM obarray,unsigned int scm_sizet i; SCM a = SCM_CAR (lsym); SCM z = SCM_CAR (a); - unsigned char *tmp = SCM_UCHARS (z); + unsigned char *tmp = SCM_SYMBOL_UCHARS (z); if (SCM_LENGTH (z) != len) goto trynext; for (i = len; i--;) @@ -557,7 +557,7 @@ SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0, if (SCM_FALSEP (o)) o = scm_symhash; SCM_VALIDATE_VECTOR (1,o); - hval = scm_string_hash (SCM_UCHARS (s), SCM_LENGTH (s)) % SCM_LENGTH (o); + hval = scm_string_hash (SCM_SYMBOL_UCHARS (s), SCM_LENGTH (s)) % SCM_LENGTH (o); /* If the symbol is already interned, simply return. */ SCM_REDEFER_INTS; { @@ -594,7 +594,7 @@ SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0, if (SCM_FALSEP (o)) o = scm_symhash; SCM_VALIDATE_VECTOR (1,o); - hval = scm_string_hash (SCM_UCHARS (s), SCM_LENGTH (s)) % SCM_LENGTH (o); + hval = scm_string_hash (SCM_SYMBOL_UCHARS (s), SCM_LENGTH (s)) % SCM_LENGTH (o); SCM_DEFER_INTS; { SCM lsym_follow; diff --git a/libguile/symbols.h b/libguile/symbols.h index b9aab4b4a..d974a506b 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -64,7 +64,6 @@ extern int scm_symhash_dim; #define SCM_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_SETLENGTH(x, v, t) (SCM_SET_CELL_WORD_0 ((x), ((v) << 8) + (t))) -#define SCM_UCHARS(x) ((unsigned char *) (SCM_CELL_WORD_1 (x))) #define SCM_SETCHARS(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_bits_t) (v))) #define SCM_PROP_SLOTS(X) (SCM_CELL_WORD_3 (X)) @@ -137,6 +136,7 @@ extern void scm_init_symbols (void); #if (SCM_DEBUG_DEPRECATED == 0) #define SCM_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) +#define SCM_UCHARS(x) ((unsigned char *) (SCM_CELL_WORD_1 (x))) #define SCM_SLOPPY_SUBSTRP(x) (SCM_SUBSTRP (x)) #define scm_strhash(str, len, n) (scm_string_hash ((str), (len)) % (n)) diff --git a/libguile/unif.c b/libguile/unif.c index 32df60237..738270aa6 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1138,7 +1138,7 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, else return SCM_BOOL_F; case scm_tc7_string: - return SCM_MAKE_CHAR (SCM_UCHARS (v)[pos]); + return SCM_MAKE_CHAR (SCM_STRING_UCHARS (v)[pos]); case scm_tc7_byvect: return SCM_MAKINUM (((char *) SCM_UVECTOR_BASE (v))[pos]); case scm_tc7_uvect: @@ -1183,7 +1183,7 @@ scm_cvref (SCM v, scm_sizet pos, SCM last) else return SCM_BOOL_F; case scm_tc7_string: - return SCM_MAKE_CHAR (SCM_UCHARS (v)[pos]); + return SCM_MAKE_CHAR (SCM_STRING_UCHARS (v)[pos]); case scm_tc7_byvect: return SCM_MAKINUM (((char *) SCM_UVECTOR_BASE (v))[pos]); case scm_tc7_uvect: @@ -1294,7 +1294,7 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, break; case scm_tc7_string: SCM_ASRTGO (SCM_CHARP (obj), badobj); - SCM_UCHARS (v)[pos] = SCM_CHAR (obj); + SCM_STRING_UCHARS (v)[pos] = SCM_CHAR (obj); break; case scm_tc7_byvect: if (SCM_CHARP (obj)) @@ -2301,12 +2301,12 @@ tail: break; case scm_tc7_string: if (n-- > 0) - scm_iprin1 (SCM_MAKE_CHAR (SCM_UCHARS (ra)[j]), port, pstate); + scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra)[j]), port, pstate); if (SCM_WRITINGP (pstate)) for (j += inc; n-- > 0; j += inc) { scm_putc (' ', port); - scm_iprin1 (SCM_MAKE_CHAR (SCM_UCHARS (ra)[j]), port, pstate); + scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra)[j]), port, pstate); } else for (j += inc; n-- > 0; j += inc) From bbe4e612aafeba3c30d58c1c8db07826a14c4312 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 26 Sep 2000 22:21:10 +0000 Subject: [PATCH 0289/2047] * Forgot to submit the Changelog for the last patch. --- libguile/ChangeLog | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index ee2971108..f9309d83b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,15 @@ +2000-09-26 Dirk Herrmann + + * strings.c (scm_string, scm_make_string, scm_string_set_x, + scm_string_append), strop.c (scm_string_upcase_x, + scm_string_downcase_x), strports.c (st_resize_port), symbols.c + (scm_sym2vcell, scm_sym2ovcell_soft, scm_intern_obarray_soft, + scm_intern_symbol, scm_unintern_symbol), unif.c (scm_cvref, + scm_uniform_vector_ref, scm_array_set_x, rapr1): Replace calls to + SCM_UCHARS with SCM_STRING_UCHARS or SCM_SYMBOL_UCHARS. + + * symbols.h (SCM_UCHARS): Deprecated. + 2000-09-26 Dirk Herrmann * gc.c (scm_gc_sweep): Replace SCM_CHARS by SCM_COMPLEX_MEM. From 6ec589e2a2eef05feee900c25ed4c11bcd74594d Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 29 Sep 2000 20:22:31 +0000 Subject: [PATCH 0290/2047] * Cosmetic docstring fixes. --- libguile/ChangeLog | 13 +++++++++++++ libguile/hashtab.c | 4 ++-- libguile/list.c | 27 ++++++++++++++------------- libguile/net_db.c | 2 +- 4 files changed, 30 insertions(+), 16 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f9309d83b..5f4658281 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,16 @@ +2000-09-29 Neil Jerram + + * net_db.c (scm_inet_ntoa): Docstring fix: missing newline + inserted. + + * hashtab.c (scm_hashx_create_handle_x, scm_hashx_ref): Insert + spaces between C parameters so that the snarfer doesn't coalesce + them all into a single very long-named parameter. + +2000-09-27 Neil Jerram + + * list.c (scm_append): Use @example texinfo markup in docstring. + 2000-09-26 Dirk Herrmann * strings.c (scm_string, scm_make_string, scm_string_set_x, diff --git a/libguile/hashtab.c b/libguile/hashtab.c index e65a4776b..ec3674b06 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -433,7 +433,7 @@ SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0, SCM_DEFINE (scm_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0, - (SCM hash,SCM assoc,SCM table,SCM obj,SCM init), + (SCM hash, SCM assoc, SCM table, SCM obj, SCM init), "This behaves the same way as the corresponding @code{-create-handle}\n" "function, but uses @var{hasher} as a\n" "hash function and @var{assoc} to compare keys. @code{hasher} must\n" @@ -452,7 +452,7 @@ SCM_DEFINE (scm_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0, SCM_DEFINE (scm_hashx_ref, "hashx-ref", 4, 1, 0, - (SCM hash,SCM assoc,SCM table,SCM obj,SCM dflt), + (SCM hash, SCM assoc, SCM table, SCM obj, SCM dflt), "This behaves the same way as the corresponding @code{ref}\n" "function, but uses @var{hasher} as a\n" "hash function and @var{assoc} to compare keys. @code{hasher} must\n" diff --git a/libguile/list.c b/libguile/list.c index d141dd2b1..933b04adb 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -192,19 +192,20 @@ SCM_DEFINE (scm_length, "length", 1, 0, 0, SCM_DEFINE (scm_append, "append", 0, 0, 1, (SCM args), "Returns a list consisting of the elements of the first LIST\n" - "followed by the elements of the other LISTs.\n" - "\n" - " (append '(x) '(y)) => (x y)\n" - " (append '(a) '(b c d)) => (a b c d)\n" - " (append '(a (b)) '((c))) => (a (b) (c))\n" - "\n" - "The resulting list is always newly allocated, except that it shares\n" - "structure with the last LIST argument. The last argument may\n" - "actually be any object; an improper list results if the last\n" - "argument is not a proper list.\n" - - " (append '(a b) '(c . d)) => (a b c . d)\n" - " (append '() 'a) => a\n") + "followed by the elements of the other LISTs.\n\n" + "@example\n" + " (append '(x) '(y)) => (x y)\n" + " (append '(a) '(b c d)) => (a b c d)\n" + " (append '(a (b)) '((c))) => (a (b) (c))\n" + "@end example\n\n" + "The resulting list is always newly allocated, except that it shares\n" + "structure with the last LIST argument. The last argument may\n" + "actually be any object; an improper list results if the last\n" + "argument is not a proper list.\n\n" + "@example\n" + " (append '(a b) '(c . d)) => (a b c . d)\n" + " (append '() 'a) => a\n" + "@end example") #define FUNC_NAME s_scm_append { SCM_VALIDATE_REST_ARGUMENT (args); diff --git a/libguile/net_db.c b/libguile/net_db.c index 768f718bb..502892411 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -108,7 +108,7 @@ SCM_DEFINE (scm_inet_ntoa, "inet-ntoa", 1, 0, 0, "Converts an integer Internet host address into a string with the\n" "traditional dotted decimal representation.\n\n" "@smalllisp\n" - "(inet-ntoa 2130706433) @result{} \"127.0.0.1\"" + "(inet-ntoa 2130706433) @result{} \"127.0.0.1\"\n" "@end smalllisp") #define FUNC_NAME s_scm_inet_ntoa { From 9d29e9906eb7f44184c57e9564ee6e1d33964018 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 29 Sep 2000 20:33:13 +0000 Subject: [PATCH 0291/2047] * Enhance snarfing of libguile docstrings and postprocess them with makeinfo. --- libguile/ChangeLog | 12 +++++++++++ libguile/Makefile.am | 9 ++++++-- libguile/guile-snarf.awk.in | 41 +++++++++++++++++++++++++++++-------- 3 files changed, 52 insertions(+), 10 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 5f4658281..c096c0f5f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,17 @@ 2000-09-29 Neil Jerram + * Makefile.am (guile-procedures.txt): Insert a new rule such that + the output from guile-snarf.awk is processed by makeinfo to + produce guile-procedures.txt. + + * guile-snarf.awk.in: Modify the way we snarf docstrings such that + the output is Texinfo-compliant and suitable for post-processing + with makeinfo. (Trim leading "./" from C file name if + present; reformat procedure prototype line in @deffn format; + improve representation of args to show optional and rest args; + explicitly quote quotation marks where they are used inside an AWK + regexp.) + * net_db.c (scm_inet_ntoa): Docstring fix: missing newline inserted. diff --git a/libguile/Makefile.am b/libguile/Makefile.am index e2a5d82e9..007b7d3cc 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -192,8 +192,13 @@ error.x: cpp_err_symbols.c posix.x: cpp_sig_symbols.c load.x: libpath.h -guile-procedures.txt: $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) - cat *.doc > $@ +guile.texi: $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) + echo "@paragraphindent 0" > $@ + cat *.doc >> $@ + +guile-procedures.txt: guile.texi + rm -f $@ + makeinfo --force -o $@ $< || test -f $@ pkgdata_DATA = guile-procedures.txt diff --git a/libguile/guile-snarf.awk.in b/libguile/guile-snarf.awk.in index 9fa44aac3..45ad42b88 100644 --- a/libguile/guile-snarf.awk.in +++ b/libguile/guile-snarf.awk.in @@ -32,6 +32,7 @@ BEGIN { FS="|"; sub(/^[ \t]*/,"",location); sub(/[ \t]*$/,"",location); sub(/: /,":",location); + sub(/^\.\//,"",location); # Now whittle copy down to just the $1 field # (but do not use $1, since it hasn't been # altered by the above regexps) @@ -40,29 +41,53 @@ BEGIN { FS="|"; # Now `copy' contains the nice scheme proc "prototype", e.g. # (set-car! pair value) # print copy > "/dev/stderr"; # for debugging + sub(/^\(/,"",copy); + sub(/\)[ \t]*$/,"",copy); proc_and_args = copy; curr_function_proto = copy; + proc_name = copy; + sub(/ .*$/,"",proc_name); sub(/[^ \n]* /,"",proc_and_args); - sub(/\)[ \t]*/,"",proc_and_args); split(proc_and_args,args," "); # now args is an array of the arguments # args[1] is the formal name of the first argument, etc. if (numargs != numactuals && !registering) - { print location ":*** `" copy "' is improperly registered as having " numactuals " arguments" > std_err; } - print " \n" copy (registering?")":"") > dot_doc_file ; } + { print location ":*** `" curr_function_proto "' is improperly registered as having " numactuals " arguments" > std_err; } + # Build a nicer function prototype than curr_function_proto + # that shows optional and rest arguments. + nicer_function_proto = proc_name; + if (!registering) { + optional_args_tail = ""; + for (i = 1; i <= $2; i++) { + nicer_function_proto = nicer_function_proto " " args[i]; + } + for (; i <= $2 + $3; i++) { + nicer_function_proto = nicer_function_proto " [" args[i]; + optional_args_tail = optional_args_tail "]"; + } + nicer_function_proto = nicer_function_proto optional_args_tail; + if ($4 != 0) { + nicer_function_proto = nicer_function_proto " . " args[i]; + } + } + # Now produce Texinfo format output. + print "\n " proc_name > dot_doc_file; + print "@c snarfed from " location > dot_doc_file; + print "@deffn primitive " nicer_function_proto > dot_doc_file; +} /SCM_SNARF_DOCSTRING_START/,/SCM_SNARF_DOCSTRING_END.*$/ { copy = $0; gsub(/.*SCM_SNARF_DOCSTRING_START/,"",copy); - sub(/^[ \t]*"?/,"", copy); + sub(/^[ \t]*\"?/,"", copy); sub(/\"?[ \t]*SCM_SNARF_DOCSTRING_END.*$/,"", copy); - gsub(/\\n\\n"?/,"\n",copy); - gsub(/\\n"?[ \t]*$/,"",copy); - gsub(/\\\"[ \t]*$/,"\"",copy); + gsub(/\\n\\n\"?/,"\n",copy); + gsub(/\\n\"?[ \t]*$/,"",copy); + gsub(/\\\"/,"\"",copy); gsub(/[ \t]*$/,"", copy); if (copy != "") { print copy > dot_doc_file } } -/SCM_SNARF_DOCSTRING_END[ \t]/ { print "[" location "]" >> dot_doc_file; } +/SCM_SNARF_DOCSTRING_END[ \t]/ { print "@end deffn" >> dot_doc_file; } /\*&\*&\*&\*SCM_ARG_BETTER_BE_IN_POSITION/ { copy = $0; sub(/.*\*&\*&\*&\*SCM_ARG_BETTER_BE_IN_POSITION\([ \t]*/,"",copy); From db611983cfd376452d40239fdbe7b31644e7bffe Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 29 Sep 2000 20:39:29 +0000 Subject: [PATCH 0292/2047] * Enhancements to online help presentation. --- ice-9/ChangeLog | 12 ++++++ ice-9/documentation.scm | 16 +++----- ice-9/session.scm | 84 ++++++++++++++++++++++++++++------------- 3 files changed, 75 insertions(+), 37 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 64c04bc1b..c727ec59b 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,15 @@ +2000-09-29 Neil Jerram + + * documentation.scm (find-documentation-in-file): Modified + according to changed format of guile-procedures.txt caused by my + snarfing/makeinfo changes in libguile. + + * session.scm (help-doc): Improvements to (help) output: (i) a + friendlier Emacs-style introduction line; (ii) where the help arg + matches multiple documented entries, print an initial list of the + entries for which documentation is found, before printing the + actual documentation entries themselves. + 2000-09-20 Mikael Djurfeldt * boot-9.scm: Removed comment. (Thanks to Brad Knotwell.) diff --git a/ice-9/documentation.scm b/ice-9/documentation.scm index 46d6b2720..3a7f1c24f 100644 --- a/ice-9/documentation.scm +++ b/ice-9/documentation.scm @@ -38,28 +38,24 @@ documentation-files)) (define entry-delimiter "\f") -(define entry-start 2) (define (find-documentation-in-file name file) (and (file-exists? file) (let ((port (open-input-file file)) (name (symbol->string name))) - (let* ((len (string-length name)) - (min-size (+ entry-start len)) - (end (+ entry-start len))) + (let ((len (string-length name))) (read-delimited entry-delimiter port) ;skip to first entry (let loop ((entry (read-delimited entry-delimiter port))) (cond ((eof-object? entry) #f) ;; match? ((and ;; large enough? - (>= (string-length entry) min-size) + (>= (string-length entry) len) ;; matching name? - (string=? (substring entry entry-start end) - name) + (string=? (substring entry 0 len) name) ;; terminated? - (memq (string-ref entry end) '(#\space #\)))) - ;; cut away starting and ending newline - (substring entry 1 (- (string-length entry) 1))) + (memq (string-ref entry len) '(#\newline))) + ;; cut away name tag and extra surrounding newlines + (substring entry (+ len 2) (- (string-length entry) 2))) (else (loop (read-delimited entry-delimiter port))))))))) ;; helper until the procedure documentation property is cleaned up diff --git a/ice-9/session.scm b/ice-9/session.scm index a03edcc7e..a49fc5fed 100644 --- a/ice-9/session.scm +++ b/ice-9/session.scm @@ -63,14 +63,21 @@ You don't seem to have regular expressions installed.\n")) (let ((entries (apropos-fold (lambda (module name object data) (cons (list module name - (object-documentation object)) + (object-documentation object) + (cond ((closure? object) + "a procedure") + ((procedure? object) + "a primitive procedure") + (else + "an object"))) data)) '() regexp apropos-fold-exported)) (module car) (name cadr) - (doc caddr)) + (doc caddr) + (type cadddr)) (if (null? entries) ;; no matches (begin @@ -80,32 +87,55 @@ You don't seem to have regular expressions installed.\n")) "named `~A'\n" "matching regexp \"~A\"\n") term)) - (let ((first? #t)) - (if (or-map doc entries) - ;; entries with documentation - (for-each (lambda (entry) - ;; *fixme*: Use `describe' when we have GOOPS? - (if (doc entry) - (begin - (if first? - (set! first? #f) - (newline)) - (simple-format #t "~S: ~S\n~A\n" - (module-name (module entry)) - (name entry) - (doc entry))))) - entries)) - (if (or-map (lambda (x) (not (doc x))) entries) - ;; entries without documentation + (let ((first? #t) + (undocumented-entries '()) + (documented-entries '()) + (documentations '())) + + (for-each (lambda (entry) + (let ((entry-summary (simple-format #f + "~S: ~S\n" + (module-name (module entry)) + (name entry)))) + (if (doc entry) + (begin + (set! documented-entries + (cons entry-summary documented-entries)) + ;; *fixme*: Use `describe' when we have GOOPS? + (set! documentations + (cons (simple-format #f + "`~S' is ~A in the ~S module.\n\n~A\n" + (name entry) + (type entry) + (module-name (module entry)) + (doc entry)) + documentations))) + (set! undocumented-entries + (cons entry-summary undocumented-entries))))) + entries) + + (if (and (not (null? documented-entries)) + (or (> (length documented-entries) 1) + (not (null? undocumented-entries)))) (begin - (if (not first?) - (display "\nNo documentation found for:\n")) - (for-each (lambda (entry) - (if (not (doc entry)) - (simple-format #t "~S: ~S\n" - (module-name (module entry)) - (name entry)))) - entries))))))) + (display "Documentation found for:\n") + (for-each (lambda (entry) (display entry)) documented-entries) + (set! first? #f))) + + (for-each (lambda (entry) + (if first? + (set! first? #f) + (newline)) + (display entry)) + documentations) + + (if (not (null? undocumented-entries)) + (begin + (if first? + (set! first? #f) + (newline)) + (display "No documentation found for:\n") + (for-each (lambda (entry) (display entry)) undocumented-entries))))))) (define (help-usage) (display "Usage: (help NAME) gives documentation about objects named NAME (a symbol) From e655d0342432c6c4a0127d9e6104eb7a92d774bb Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sat, 30 Sep 2000 15:51:49 +0000 Subject: [PATCH 0293/2047] * filesys.c (scm_stat2scm), posix.c (s_scm_mknod): don't use S_ISSOCK or S_IFSOCK if not defined. thanks to Bruce Korb. --- libguile/ChangeLog | 5 +++++ libguile/filesys.c | 2 ++ libguile/posix.c | 2 ++ 3 files changed, 9 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index c096c0f5f..c1a62e708 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-09-30 Gary Houston + + * filesys.c (scm_stat2scm), posix.c (s_scm_mknod): don't use + S_ISSOCK or S_IFSOCK if not defined. thanks to Bruce Korb. + 2000-09-29 Neil Jerram * Makefile.am (guile-procedures.txt): Insert a new rule such that diff --git a/libguile/filesys.c b/libguile/filesys.c index d2a86729d..4a2c67659 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -398,8 +398,10 @@ scm_stat2scm (struct stat *stat_temp) ve[13] = scm_sym_char_special; else if (S_ISFIFO (mode)) ve[13] = scm_sym_fifo; +#ifdef S_ISSOCK else if (S_ISSOCK (mode)) ve[13] = scm_sym_sock; +#endif else ve[13] = scm_sym_unknown; diff --git a/libguile/posix.c b/libguile/posix.c index 107de5522..2d9d98038 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1226,8 +1226,10 @@ SCM_DEFINE (scm_mknod, "mknod", 4, 0, 0, ctype = S_IFCHR; else if (strcmp (p, "fifo") == 0) ctype = S_IFIFO; +#ifdef S_IFSOCK else if (strcmp (p, "socket") == 0) ctype = S_IFSOCK; +#endif else SCM_OUT_OF_RANGE (2,type); From deaecea77d61dae047d02ee76eb7b70e071439d1 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sat, 30 Sep 2000 15:53:36 +0000 Subject: [PATCH 0294/2047] * posix.scm (setgrent): pass #t, not #f. thanks to Jacques A. Vidrine. --- ice-9/ChangeLog | 5 +++++ ice-9/posix.scm | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index c727ec59b..bbbc9af7c 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2000-09-30 Gary Houston + + * posix.scm (setgrent): pass #t, not #f. thanks to + Jacques A. Vidrine. + 2000-09-29 Neil Jerram * documentation.scm (find-documentation-in-file): Modified diff --git a/ice-9/posix.scm b/ice-9/posix.scm index 9698a0b8a..9d76a79d0 100644 --- a/ice-9/posix.scm +++ b/ice-9/posix.scm @@ -63,7 +63,7 @@ (define (getpwuid uid) (getpw uid)) (define (getgrent) (getgr)) -(define (setgrent) (setgr #f)) +(define (setgrent) (setgr #t)) (define (endgrent) (setgr)) (define (getgrnam name) (getgr name)) From 7e56f76644be095ae83a5435e1773013477f6238 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sat, 30 Sep 2000 15:54:32 +0000 Subject: [PATCH 0295/2047] *** empty log message *** --- THANKS | 2 ++ 1 file changed, 2 insertions(+) diff --git a/THANKS b/THANKS index c209cf8f1..d49924da2 100644 --- a/THANKS +++ b/THANKS @@ -15,9 +15,11 @@ For fixes or providing information which led to a fix: Ian Bicking Brad Knotwell Matthias Köppe + Bruce Korb Shuji Narazaki Nicolas Neuss Han-Wen Nienhuys William Webber Dale P. Smith Ralf Mattes + Jacques A. Vidrine. From ed0e0e3097b03098febdad11d91a24c026c9cded Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 1 Oct 2000 10:29:56 +0000 Subject: [PATCH 0296/2047] * net_db.c: declare inet_aton only if MISSING_INET_ATON_DECL is defined. thanks to Han-Wen Nienhuys. --- libguile/ChangeLog | 5 +++++ libguile/net_db.c | 2 ++ 2 files changed, 7 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index c1a62e708..72c99f16a 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-10-01 Gary Houston + + * net_db.c: declare inet_aton only if MISSING_INET_ATON_DECL is + defined. thanks to Han-Wen Nienhuys. + 2000-09-30 Gary Houston * filesys.c (scm_stat2scm), posix.c (s_scm_mknod): don't use diff --git a/libguile/net_db.c b/libguile/net_db.c index 502892411..b8b5b2f44 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -80,7 +80,9 @@ extern int h_errno; int close (); #endif /* STDC_HEADERS */ +#ifdef MISSING_INET_ATON_DECL extern int inet_aton (); +#endif SCM_DEFINE (scm_inet_aton, "inet-aton", 1, 0, 0, (SCM address), From 99c01f4ad81bc328fe7b94ced69ed8b2daf26705 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 1 Oct 2000 10:31:10 +0000 Subject: [PATCH 0297/2047] * configure.in: check whether inet_aton is declared. * acconfig.h: added MISSING_INET_ATON_DECL. --- ChangeLog | 5 +++++ acconfig.h | 3 +++ configure.in | 1 + 3 files changed, 9 insertions(+) diff --git a/ChangeLog b/ChangeLog index e45f5f71e..bed3dd1cc 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2000-10-01 Gary Houston + + * configure.in: check whether inet_aton is declared. + * acconfig.h: added MISSING_INET_ATON_DECL. + 2000-09-20 Keisuke Nishida * libguile.h: #include "libguile/properties.h". diff --git a/acconfig.h b/acconfig.h index b7b42bc3d..eb23b076c 100644 --- a/acconfig.h +++ b/acconfig.h @@ -146,6 +146,9 @@ /* Define if the operating system supplies usleep without declaring it. */ #undef MISSING_USLEEP_DECL +/* Define if the operating system supplies inet_aton without declaring it. */ +#undef MISSING_INET_ATON_DECL + /* Define if the system headers declare usleep to return void. */ #undef USLEEP_RETURNS_VOID diff --git a/configure.in b/configure.in index 09e897dee..f0deb6ab9 100644 --- a/configure.in +++ b/configure.in @@ -196,6 +196,7 @@ GUILE_FUNC_DECLARED(strptime, time.h) GUILE_FUNC_DECLARED(bzero, string.h) GUILE_FUNC_DECLARED(sleep, unistd.h) GUILE_FUNC_DECLARED(usleep, unistd.h) +GUILE_FUNC_DECLARED(inet_aton, arpa/inet.h) ### On some systems usleep has no return value. If it does have one, ### we'd like to return it; otherwise, we'll fake it. From 5574f075e47683ef23e7d6d3474bdb68c22976d7 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 1 Oct 2000 11:03:17 +0000 Subject: [PATCH 0298/2047] Reverse the previous changes, I don't think they are needed after all. --- ChangeLog | 5 ----- acconfig.h | 3 --- configure.in | 1 - 3 files changed, 9 deletions(-) diff --git a/ChangeLog b/ChangeLog index bed3dd1cc..e45f5f71e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,8 +1,3 @@ -2000-10-01 Gary Houston - - * configure.in: check whether inet_aton is declared. - * acconfig.h: added MISSING_INET_ATON_DECL. - 2000-09-20 Keisuke Nishida * libguile.h: #include "libguile/properties.h". diff --git a/acconfig.h b/acconfig.h index eb23b076c..b7b42bc3d 100644 --- a/acconfig.h +++ b/acconfig.h @@ -146,9 +146,6 @@ /* Define if the operating system supplies usleep without declaring it. */ #undef MISSING_USLEEP_DECL -/* Define if the operating system supplies inet_aton without declaring it. */ -#undef MISSING_INET_ATON_DECL - /* Define if the system headers declare usleep to return void. */ #undef USLEEP_RETURNS_VOID diff --git a/configure.in b/configure.in index f0deb6ab9..09e897dee 100644 --- a/configure.in +++ b/configure.in @@ -196,7 +196,6 @@ GUILE_FUNC_DECLARED(strptime, time.h) GUILE_FUNC_DECLARED(bzero, string.h) GUILE_FUNC_DECLARED(sleep, unistd.h) GUILE_FUNC_DECLARED(usleep, unistd.h) -GUILE_FUNC_DECLARED(inet_aton, arpa/inet.h) ### On some systems usleep has no return value. If it does have one, ### we'd like to return it; otherwise, we'll fake it. From 0d26a8bca9baf0037b3578642531953e2def8438 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 1 Oct 2000 11:05:52 +0000 Subject: [PATCH 0299/2047] * net_db.c: declare inet_aton only if HAVE_INET_ATON is not defined. thanks to Han-Wen Nienhuys. (replacing the previously committed change) --- libguile/ChangeLog | 2 +- libguile/net_db.c | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 72c99f16a..d53bac29e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,6 +1,6 @@ 2000-10-01 Gary Houston - * net_db.c: declare inet_aton only if MISSING_INET_ATON_DECL is + * net_db.c: declare inet_aton only if HAVE_INET_ATON is not defined. thanks to Han-Wen Nienhuys. 2000-09-30 Gary Houston diff --git a/libguile/net_db.c b/libguile/net_db.c index b8b5b2f44..1df26f4f1 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -80,7 +80,7 @@ extern int h_errno; int close (); #endif /* STDC_HEADERS */ -#ifdef MISSING_INET_ATON_DECL +#ifndef HAVE_INET_ATON extern int inet_aton (); #endif From 77cd7f80f0ed3dc36c291bd37a8dc91b8cd4b95c Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Mon, 2 Oct 2000 19:39:25 +0000 Subject: [PATCH 0300/2047] * guile-func-name-check.in: now should not confuse SCO nawk anymore. thanks to Bruce Korb for the fix! --- libguile/ChangeLog | 5 +++++ libguile/guile-func-name-check.in | 5 +++-- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d53bac29e..e7d944ef0 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-10-02 Michael Livshin + + * guile-func-name-check.in: now should not confuse SCO nawk + anymore. thanks to Bruce Korb for the fix! + 2000-10-01 Gary Houston * net_db.c: declare inet_aton only if HAVE_INET_ATON is not diff --git a/libguile/guile-func-name-check.in b/libguile/guile-func-name-check.in index fcd29b17c..6516e468c 100644 --- a/libguile/guile-func-name-check.in +++ b/libguile/guile-func-name-check.in @@ -4,6 +4,7 @@ BEGIN { filename = ARGV[1]; + in_a_func = 0; } /^SCM_DEFINE/ { @@ -14,7 +15,7 @@ BEGIN { in_a_func = 1; } -in_a_func && /^\{/ { +/^\{/ && in_a_func { if (!match(last_line,/^#define[ \t]+FUNC_NAME[ \t]+/)) { printf filename ":" NR ":***" > "/dev/stderr"; print "Missing or erroneous `#define FUNC_NAME s_" func_name "'" > "/dev/stderr"; @@ -39,7 +40,7 @@ in_a_func && /^\{/ { next_line_better_be_undef = 0; } -in_a_func && /^\}/ { +/^\}/ && in_a_func { next_line_better_be_undef = 1; } From 817e55b939ea04694c3dbcc187ff2cd5c7119d3d Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 2 Oct 2000 21:32:57 +0000 Subject: [PATCH 0301/2047] * coop-defs.h (coop_key_create): Don't use the C++ keyword `destructor' in prototype. Thanks to Martin Baulig! --- libguile/coop-defs.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/coop-defs.h b/libguile/coop-defs.h index 4939580a7..c3bab1423 100644 --- a/libguile/coop-defs.h +++ b/libguile/coop-defs.h @@ -197,7 +197,7 @@ typedef int coop_k; typedef coop_k scm_key_t; -extern int coop_key_create (coop_k *keyp, void (*destructor) (void *value)); +extern int coop_key_create (coop_k *keyp, void (*destruktor) (void *value)); extern int coop_setspecific (coop_k key, const void *value); extern void *coop_getspecific (coop_k key); extern int coop_key_delete (coop_k); From 4fd03f43392a7d1efd7c47f8a8410e5d1e56609a Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 2 Oct 2000 21:33:38 +0000 Subject: [PATCH 0302/2047] *** empty log message *** --- libguile/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index e7d944ef0..8386ac49c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-10-02 Marius Vollmer + + * coop-defs.h (coop_key_create): Don't use the C++ keyword + `destructor' in prototype. Thanks to Martin Baulig! + 2000-10-02 Michael Livshin * guile-func-name-check.in: now should not confuse SCO nawk From 2d349e67acf8a750c527b73cdfc1d8ec1251769f Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 6 Oct 2000 13:35:58 +0000 Subject: [PATCH 0303/2047] * Added type-specific replacement macros for SCM_LENGTH. --- libguile/ChangeLog | 7 +++++++ libguile/continuations.h | 1 + libguile/strings.h | 1 + libguile/symbols.h | 3 ++- libguile/unif.h | 3 +++ libguile/vectors.h | 2 ++ 6 files changed, 16 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 8386ac49c..a5f910f80 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2000-10-06 Dirk Herrmann + + * continuations.h (SCM_CONTINUATION_LENGTH), strings.h + (SCM_STRING_LENGTH), symbols.h (SCM_SYMBOL_LENGTH), unif.h + (SCM_UVECTOR_LENGTH, SCM_BITVECTOR_LENGTH), vectors.h + (SCM_VECTOR_LENGTH): Added as replacements for SCM_LENGTH. + 2000-10-02 Marius Vollmer * coop-defs.h (coop_key_create): Don't use the C++ keyword diff --git a/libguile/continuations.h b/libguile/continuations.h index 133eb9804..11aa75c5a 100644 --- a/libguile/continuations.h +++ b/libguile/continuations.h @@ -63,6 +63,7 @@ typedef struct #define SCM_CONTREGS(x) ((scm_contregs *) SCM_CELL_WORD_1 (x)) #define SCM_SET_CONTREGS(x, r) (SCM_SET_CELL_WORD_1 ((x), (scm_bits_t) (r))) +#define SCM_CONTINUATION_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_JMPBUF(x) ((SCM_CONTREGS (x))->jmpbuf) #define SCM_DYNENV(x) ((SCM_CONTREGS (x))->dynenv) diff --git a/libguile/strings.h b/libguile/strings.h index c13ccfda3..6cc64aa5b 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -54,6 +54,7 @@ #define SCM_STRINGP(x) (SCM_NIMP (x) && (SCM_TYP7S (x) == scm_tc7_string)) #define SCM_STRING_UCHARS(x) ((unsigned char *) (SCM_CELL_WORD_1 (x))) #define SCM_STRING_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) +#define SCM_STRING_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) /* Is X a writable string (i.e., not a substring)? */ #define SCM_RWSTRINGP(x) (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_string)) diff --git a/libguile/symbols.h b/libguile/symbols.h index d974a506b..64b319c25 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -52,13 +52,14 @@ extern int scm_symhash_dim; -/* SCM_LENGTH(SYM) is the length of SYM's name in characters, and +/* SCM_SYMBOL_LENGTH(SYM) is the length of SYM's name in characters, and * SCM_SYMBOL_CHARS(SYM) is the address of the first character of SYM's name. */ #define SCM_SYMBOLP(x) (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_symbol)) #define SCM_SYMBOL_UCHARS(x) ((unsigned char *) (SCM_CELL_WORD_1 (x))) #define SCM_SYMBOL_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) +#define SCM_SYMBOL_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_LENGTH_MAX (0xffffffL) #define SCM_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) diff --git a/libguile/unif.h b/libguile/unif.h index 32f0317a4..4a9f5ede1 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -87,6 +87,9 @@ extern long scm_tc16_array; #define SCM_ARRAY_DIMS(a) ((scm_array_dim *)((char *) SCM_ARRAY_MEM (a) + sizeof (scm_array))) #define SCM_UVECTOR_BASE(x) ((void *) (SCM_CELL_WORD_1 (x))) +#define SCM_UVECTOR_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) + +#define SCM_BITVECTOR_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) /* apparently it's possible to have more than SCM_LENGTH_MAX elements in an array: if the length is SCM_LENGTH_MAX then the SCM_VELTS diff --git a/libguile/vectors.h b/libguile/vectors.h index 3e8708472..f995da3e8 100644 --- a/libguile/vectors.h +++ b/libguile/vectors.h @@ -53,6 +53,8 @@ #define SCM_VECTORP(x) (SCM_NIMP (x) && (SCM_TYP7S (x) == scm_tc7_vector)) #define SCM_VECTOR_BASE(x) ((scm_bits_t *) SCM_CELL_WORD_1 (x)) +#define SCM_VECTOR_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) + #define SCM_VELTS(x) ((SCM *) SCM_CELL_WORD_1 (x)) #define SCM_VELTS_AS_STACKITEMS(x) ((SCM_STACKITEM *) SCM_CELL_WORD_1 (x)) #define SCM_SETVELTS(x,v) (SCM_SET_CELL_WORD_1 ((x), (v))) From 94115ae3859ffede03ed93e31d1407019209b175 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 6 Oct 2000 16:51:08 +0000 Subject: [PATCH 0304/2047] * Don't call scm_vector_set_length_x for non-vector arguments. --- libguile/ChangeLog | 9 +++++++++ libguile/numbers.c | 5 ++--- libguile/read.c | 17 ++++++++++++----- libguile/strports.c | 15 ++++++++++----- 4 files changed, 33 insertions(+), 13 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index a5f910f80..9eb8ca241 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2000-10-06 Dirk Herrmann + + * numbers.c (big2str), read.c (scm_grow_tok_buf), strports.c + (st_resize_port): Don't call scm_vector_set_length_x to resize + strings. + + * read.c (scm_lreadr, scm_read_token): Use SCM_STRING_LENGTH for + string arguments (instead of SCM_LENGTH). + 2000-10-06 Dirk Herrmann * continuations.h (SCM_CONTINUATION_LENGTH), strings.h diff --git a/libguile/numbers.c b/libguile/numbers.c index c997a4852..209292740 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -52,7 +52,6 @@ #include "libguile/root.h" #include "libguile/smob.h" #include "libguile/strings.h" -#include "libguile/vectors.h" #include "libguile/validate.h" #include "libguile/numbers.h" @@ -2205,8 +2204,8 @@ big2str (SCM b, unsigned int radix) { /* jeh */ for (i = j; j < SCM_LENGTH (ss); j++) s[ch + j - i] = s[j]; /* jeh */ - scm_vector_set_length_x (ss, /* jeh */ - SCM_MAKINUM (ch + SCM_LENGTH (ss) - i)); + ss = scm_substring (ss, SCM_INUM0, + SCM_MAKINUM (ch + SCM_STRING_LENGTH (ss) - i)); } return scm_return_first (ss, t); diff --git a/libguile/read.c b/libguile/read.c index c599f451c..a2caccb1a 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -122,8 +122,15 @@ SCM_DEFINE (scm_read, "read", 0, 1, 0, char * scm_grow_tok_buf (SCM *tok_buf) { - scm_vector_set_length_x (*tok_buf, SCM_MAKINUM (2 * SCM_LENGTH (*tok_buf))); - return SCM_STRING_CHARS (*tok_buf); + unsigned long int oldlen = SCM_STRING_LENGTH (*tok_buf); + SCM newstr = scm_makstr (2 * oldlen, 0); + unsigned long int i; + + for (i = 0; i != oldlen; ++i) + SCM_STRING_CHARS (newstr) [i] = SCM_STRING_CHARS (*tok_buf) [i]; + + *tok_buf = newstr; + return SCM_STRING_CHARS (newstr); } @@ -434,7 +441,7 @@ tryagain_no_flush_ws: { SCM_ASSERT (EOF != c, SCM_UNDEFINED, "end of file in ", "string"); - while (j + 2 >= SCM_LENGTH (*tok_buf)) + while (j + 2 >= SCM_STRING_LENGTH (*tok_buf)) scm_grow_tok_buf (tok_buf); if (c == '\\') @@ -535,7 +542,7 @@ scm_read_token (int ic, SCM *tok_buf, SCM port, int weird) else { j = 0; - while (j + 2 >= SCM_LENGTH (*tok_buf)) + while (j + 2 >= SCM_STRING_LENGTH (*tok_buf)) p = scm_grow_tok_buf (tok_buf); p[j] = c; ++j; @@ -543,7 +550,7 @@ scm_read_token (int ic, SCM *tok_buf, SCM port, int weird) while (1) { - while (j + 2 >= SCM_LENGTH (*tok_buf)) + while (j + 2 >= SCM_STRING_LENGTH (*tok_buf)) p = scm_grow_tok_buf (tok_buf); c = scm_getc (port); switch (c) diff --git a/libguile/strports.c b/libguile/strports.c index fb736cc83..274008684 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -57,7 +57,6 @@ #include "libguile/read.h" #include "libguile/root.h" #include "libguile/strings.h" -#include "libguile/vectors.h" #include "libguile/modules.h" #include "libguile/strports.h" @@ -96,17 +95,23 @@ stfill_buffer (SCM port) static void st_resize_port (scm_port *pt, off_t new_size) { - SCM stream = SCM_PACK (pt->stream); + SCM old_stream = SCM_PACK (pt->stream); + SCM new_stream = scm_makstr (new_size, 0); + unsigned long int old_size = SCM_STRING_LENGTH (old_stream); + unsigned long int min_size = min (old_size, new_size); + unsigned long int i; off_t index = pt->write_pos - pt->write_buf; pt->write_buf_size = new_size; - scm_vector_set_length_x (stream, SCM_MAKINUM (new_size)); + for (i = 0; i != min_size; ++i) + SCM_STRING_CHARS (new_stream) [i] = SCM_STRING_CHARS (old_stream) [i]; - /* reset buffer in case reallocation moved the string. */ + /* reset buffer. */ { - pt->read_buf = pt->write_buf = SCM_STRING_UCHARS (stream); + pt->stream = new_stream; + pt->read_buf = pt->write_buf = SCM_STRING_UCHARS (new_stream); pt->read_pos = pt->write_pos = pt->write_buf + index; pt->write_end = pt->write_buf + pt->write_buf_size; pt->read_end = pt->read_buf + pt->read_buf_size; From aa3188a7d96a35546b9c14647da926a013570f4e Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 9 Oct 2000 09:54:28 +0000 Subject: [PATCH 0305/2047] * Eliminate previously introduced redundant string copying. --- libguile/ChangeLog | 6 ++++++ libguile/numbers.c | 20 ++++++++++---------- 2 files changed, 16 insertions(+), 10 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 9eb8ca241..3a724bda7 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2000-10-09 Dirk Herrmann + + * numbers.c (big2str): Avoid redundant copying. + + (scm_bigprint): Use SCM_STRING_LENGTH instead of SCM_LENGTH. + 2000-10-06 Dirk Herrmann * numbers.c (big2str), read.c (scm_grow_tok_buf), strports.c diff --git a/libguile/numbers.c b/libguile/numbers.c index 209292740..7e6a79281 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -2175,7 +2175,6 @@ big2str (SCM b, unsigned int radix) : (SCM_BITSPERDIG * i) + 2; scm_sizet k = 0; scm_sizet radct = 0; - scm_sizet ch; /* jeh */ SCM_BIGDIG radpow = 1, radmod = 0; SCM ss = scm_makstr ((long) j, 0); char *s = SCM_STRING_CHARS (ss), c; @@ -2184,7 +2183,6 @@ big2str (SCM b, unsigned int radix) radpow *= radix; radct++; } - s[0] = SCM_BIGSIGN (b) ? '-' : '+'; while ((i || radmod) && j) { if (k == 0) @@ -2199,13 +2197,15 @@ big2str (SCM b, unsigned int radix) k--; s[--j] = c < 10 ? c + '0' : c + 'a' - 10; } - ch = s[0] == '-' ? 1 : 0; /* jeh */ - if (ch < j) - { /* jeh */ - for (i = j; j < SCM_LENGTH (ss); j++) - s[ch + j - i] = s[j]; /* jeh */ - ss = scm_substring (ss, SCM_INUM0, - SCM_MAKINUM (ch + SCM_STRING_LENGTH (ss) - i)); + + if (SCM_BIGSIGN (b)) + s[--j] = '-'; + + if (j > 0) + { + /* The pre-reserved string length was too large. */ + unsigned long int length = SCM_STRING_LENGTH (ss); + ss = scm_substring (ss, SCM_MAKINUM (j), SCM_MAKINUM (length)); } return scm_return_first (ss, t); @@ -2270,7 +2270,7 @@ scm_bigprint (SCM exp, SCM port, scm_print_state *pstate) { #ifdef SCM_BIGDIG exp = big2str (exp, (unsigned int) 10); - scm_lfwrite (SCM_STRING_CHARS (exp), (scm_sizet) SCM_LENGTH (exp), port); + scm_lfwrite (SCM_STRING_CHARS (exp), (scm_sizet) SCM_STRING_LENGTH (exp), port); #else scm_ipruk ("bignum", exp, port); #endif From b17004b8068310facd08d4dd15aff09dbaee8b63 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 9 Oct 2000 12:39:14 +0000 Subject: [PATCH 0306/2047] * Eliminate last call to scm_vector_set_length_x within libguile. --- libguile/ChangeLog | 8 ++++++++ libguile/print.c | 25 +++++++++++++++++-------- 2 files changed, 25 insertions(+), 8 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 3a724bda7..52a1cf7c8 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2000-10-09 Dirk Herrmann + + * print.c (make_print_state, scm_iprin1): Replace SCM_LENGTH with + the appropriate SCM__LENGTH macro. + + (grow_ref_stack): Don't call scm_vector_set_length_x to resize + the print stack. + 2000-10-09 Dirk Herrmann * numbers.c (big2str): Avoid redundant copying. diff --git a/libguile/print.c b/libguile/print.c index 499f44760..9bd447815 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -215,7 +215,7 @@ make_print_state (void) pstate->ref_vect = scm_make_vector (SCM_MAKINUM (PSTATE_SIZE), SCM_UNDEFINED); pstate->ref_stack = SCM_VELTS (pstate->ref_vect); - pstate->ceiling = SCM_LENGTH (pstate->ref_vect); + pstate->ceiling = SCM_VECTOR_LENGTH (pstate->ref_vect); return print_state; } @@ -259,9 +259,18 @@ scm_free_print_state (SCM print_state) static void grow_ref_stack (scm_print_state *pstate) { - int new_size = 2 * pstate->ceiling; - scm_vector_set_length_x (pstate->ref_vect, SCM_MAKINUM (new_size)); - pstate->ref_stack = SCM_VELTS (pstate->ref_vect); + unsigned long int old_size = SCM_VECTOR_LENGTH (pstate->ref_vect); + SCM *old_elts = SCM_VELTS (pstate->ref_vect); + unsigned long int new_size = 2 * pstate->ceiling; + SCM new_vect = scm_make_vector (new_size, SCM_UNDEFINED); + SCM *new_elts = SCM_VELTS (new_vect); + unsigned long int i; + + for (i = 0; i != old_size; ++i) + new_elts [i] = old_elts [i]; + + pstate->ref_vect = new_vect; + pstate->ref_stack = new_elts; pstate->ceiling = new_size; } @@ -494,7 +503,7 @@ taloop: int maybe_weird; int mw_pos = 0; - len = SCM_LENGTH (exp); + len = SCM_SYMBOL_LENGTH (exp); str = SCM_SYMBOL_CHARS (exp); scm_remember (&exp); pos = 0; @@ -577,9 +586,9 @@ taloop: common_vector_printer: { register long i; - int last = SCM_LENGTH (exp) - 1; + int last = SCM_VECTOR_LENGTH (exp) - 1; int cutp = 0; - if (pstate->fancyp && SCM_LENGTH (exp) > pstate->length) + if (pstate->fancyp && SCM_VECTOR_LENGTH (exp) > pstate->length) { last = pstate->length - 1; cutp = 1; @@ -662,7 +671,7 @@ taloop: break; case scm_tc7_contin: scm_puts ("#', port); From bfa974f0a4a506888ada92ce362b3eeddde4689b Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 9 Oct 2000 14:37:36 +0000 Subject: [PATCH 0307/2047] * Replace a bunch of calls to SCM_LENGTH. --- libguile/ChangeLog | 21 +++++++++++++++++++++ libguile/continuations.c | 10 +++++----- libguile/environments.c | 12 ++++++------ libguile/fluids.c | 8 ++++---- libguile/hash.c | 4 ++-- libguile/hashtab.c | 20 ++++++++++---------- libguile/ioext.c | 2 +- libguile/objects.c | 4 ++-- libguile/ports.c | 2 +- libguile/socket.c | 4 ++-- libguile/stacks.c | 6 +++--- libguile/strings.c | 4 ++-- libguile/strop.c | 20 ++++++++++---------- libguile/struct.c | 22 +++++++++++----------- libguile/weaks.c | 6 +++--- 15 files changed, 83 insertions(+), 62 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 52a1cf7c8..8c1232e0b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,24 @@ +2000-10-09 Dirk Herrmann + + * continuations.c (scm_make_cont, copy_stack_and_call, + scm_dynthrow), environments.c (obarray_enter, obarray_replace, + obarray_retrieve, obarray_remove, obarray_remove_all, + leaf_environment_fold), fluids.c (grow_fluids, scm_copy_fluids, + scm_fluid_ref, scm_fluid_set_x), hash.c (scm_hasher), hashtab.c + (scm_hash_fn_get_handle, scm_hash_fn_create_handle_x, + scm_hash_fn_remove_x, scm_internal_hash_fold), ioext.c + (scm_read_delimited_x), objects.c (scm_mcache_lookup_cmethod, + scm_make_subclass_object), ports.c (scm_unread_string), socket.c + (scm_recv, scm_recvfrom), stacks.c (scm_make_stack, scm_stack_id, + scm_last_stack_frame), strings.c (scm_string_length, + scm_string_set_x), strop.c (scm_substring_move_x, + scm_substring_fill_x, scm_string_fill_x, scm_string_upcase_x, + scm_string_downcase_x, scm_string_capitalize_x), struct.c + (scm_struct_init, scm_struct_vtable_p, scm_make_struct, + scm_make_vtable_vtable, scm_struct_ref, scm_struct_set_x), weaks.c + (scm_mark_weak_vector_spines, scm_scan_weak_vectors): Replace + SCM_LENGTH with the appropriate SCM__LENGTH macro. + 2000-10-09 Dirk Herrmann * print.c (make_print_state, scm_iprin1): Replace SCM_LENGTH with diff --git a/libguile/continuations.c b/libguile/continuations.c index fd7d9771f..419a2f01b 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -92,12 +92,12 @@ scm_make_cont (SCM *answer) SCM_SETLENGTH (cont, j, scm_tc7_contin); SCM_EXIT_A_SECTION; #ifndef SCM_STACK_GROWS_UP - src -= SCM_LENGTH (cont); + src -= SCM_CONTINUATION_LENGTH (cont); #endif /* ndef SCM_STACK_GROWS_UP */ dst = (SCM_STACKITEM *) ((char *) SCM_CONTREGS (cont) + sizeof (scm_contregs)); /* memcpy should be safe: src and dst will never overlap */ - memcpy (dst, src, sizeof (SCM_STACKITEM) * SCM_LENGTH (cont)); + memcpy (dst, src, sizeof (SCM_STACKITEM) * SCM_CONTINUATION_LENGTH (cont)); #ifdef DEBUG_EXTENSIONS SCM_DFRAME (cont) = scm_last_debug_frame; @@ -135,7 +135,7 @@ copy_stack_and_call (SCM cont, SCM val, SCM_STACKITEM * src, SCM_STACKITEM * dst) { /* memcpy should be safe: src and dst will never overlap */ - memcpy (dst, src, sizeof (SCM_STACKITEM) * SCM_LENGTH (cont)); + memcpy (dst, src, sizeof (SCM_STACKITEM) * SCM_CONTINUATION_LENGTH (cont)); #ifdef DEBUG_EXTENSIONS scm_last_debug_frame = SCM_DFRAME (cont); @@ -158,10 +158,10 @@ scm_dynthrow (SCM cont, SCM val) SCM_STACKITEM stack_top_element; #ifdef SCM_STACK_GROWS_UP - if (SCM_PTR_GE (dst + SCM_LENGTH (cont), & stack_top_element)) + if (SCM_PTR_GE (dst + SCM_CONTINUATION_LENGTH (cont), & stack_top_element)) grow_stack (cont, val); #else - dst -= SCM_LENGTH (cont); + dst -= SCM_CONTINUATION_LENGTH (cont); if (SCM_PTR_LE (dst, & stack_top_element)) grow_stack (cont, val); #endif /* def SCM_STACK_GROWS_UP */ diff --git a/libguile/environments.c b/libguile/environments.c index 55fd610d3..cb366f0fb 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -521,7 +521,7 @@ print_observer (SCM type, SCM port, scm_print_state *pstate) static SCM obarray_enter (SCM obarray, SCM symbol, SCM data) { - scm_sizet hash = SCM_SYMBOL_HASH (symbol) % SCM_LENGTH (obarray); + scm_sizet hash = SCM_SYMBOL_HASH (symbol) % SCM_VECTOR_LENGTH (obarray); SCM entry = scm_cons (symbol, data); SCM slot = scm_cons (entry, SCM_VELTS (obarray)[hash]); SCM_VELTS (obarray)[hash] = slot; @@ -537,7 +537,7 @@ obarray_enter (SCM obarray, SCM symbol, SCM data) static SCM obarray_replace (SCM obarray, SCM symbol, SCM data) { - scm_sizet hash = SCM_SYMBOL_HASH (symbol) % SCM_LENGTH (obarray); + scm_sizet hash = SCM_SYMBOL_HASH (symbol) % SCM_VECTOR_LENGTH (obarray); SCM new_entry = scm_cons (symbol, data); SCM lsym; SCM slot; @@ -565,7 +565,7 @@ obarray_replace (SCM obarray, SCM symbol, SCM data) static SCM obarray_retrieve (SCM obarray, SCM sym) { - scm_sizet hash = SCM_SYMBOL_HASH (sym) % SCM_LENGTH (obarray); + scm_sizet hash = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (obarray); SCM lsym; for (lsym = SCM_VELTS (obarray)[hash]; !SCM_NULLP (lsym); lsym = SCM_CDR (lsym)) @@ -586,7 +586,7 @@ obarray_retrieve (SCM obarray, SCM sym) static SCM obarray_remove (SCM obarray, SCM sym) { - scm_sizet hash = SCM_SYMBOL_HASH (sym) % SCM_LENGTH (obarray); + scm_sizet hash = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (obarray); SCM lsym; SCM *lsymp; @@ -609,7 +609,7 @@ obarray_remove (SCM obarray, SCM sym) static void obarray_remove_all (SCM obarray) { - scm_sizet size = SCM_LENGTH (obarray); + scm_sizet size = SCM_VECTOR_LENGTH (obarray); scm_sizet i; for (i = 0; i < size; i++) @@ -896,7 +896,7 @@ leaf_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init) SCM result = init; SCM obarray = LEAF_ENVIRONMENT (env)->obarray; - for (i = 0; i < SCM_LENGTH (obarray); i++) + for (i = 0; i < SCM_VECTOR_LENGTH (obarray); i++) { SCM l; for (l = SCM_VELTS (obarray)[i]; !SCM_NULLP (l); l = SCM_CDR (l)) diff --git a/libguile/fluids.c b/libguile/fluids.c index 16b022df1..425956d41 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -72,7 +72,7 @@ grow_fluids (scm_root_state *root_state, int new_length) int old_length, i; old_fluids = root_state->fluids; - old_length = SCM_LENGTH (old_fluids); + old_length = SCM_VECTOR_LENGTH (old_fluids); new_fluids = scm_make_vector (SCM_MAKINUM (new_length), SCM_BOOL_F); i = 0; while (i < old_length) @@ -92,7 +92,7 @@ grow_fluids (scm_root_state *root_state, int new_length) void scm_copy_fluids (scm_root_state *root_state) { - grow_fluids (root_state, SCM_LENGTH(root_state->fluids)); + grow_fluids (root_state, SCM_VECTOR_LENGTH (root_state->fluids)); } static int @@ -158,7 +158,7 @@ SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0, n = SCM_FLUID_NUM (fluid); - if (SCM_LENGTH (scm_root->fluids) <= n) + if (SCM_VECTOR_LENGTH (scm_root->fluids) <= n) grow_fluids (scm_root, n+1); return SCM_VELTS (scm_root->fluids)[n]; } @@ -174,7 +174,7 @@ SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0, SCM_VALIDATE_FLUID (1, fluid); n = SCM_FLUID_NUM (fluid); - if (SCM_LENGTH (scm_root->fluids) <= n) + if (SCM_VECTOR_LENGTH (scm_root->fluids) <= n) grow_fluids (scm_root, n+1); SCM_VELTS (scm_root->fluids)[n] = value; return SCM_UNSPECIFIED; diff --git a/libguile/hash.c b/libguile/hash.c index d81ebcfb4..1bb4c2409 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -119,7 +119,7 @@ scm_hasher(SCM obj, unsigned long n, scm_sizet d) obj = scm_number_to_string(obj, SCM_MAKINUM(10)); } case scm_tc7_string: - return scm_string_hash (SCM_STRING_UCHARS (obj), SCM_LENGTH (obj)) % n; + return scm_string_hash (SCM_STRING_UCHARS (obj), SCM_STRING_LENGTH (obj)) % n; case scm_tc7_substring: return scm_string_hash (SCM_ROUCHARS (obj), SCM_ROLENGTH (obj)) % n; case scm_tc7_symbol: @@ -127,7 +127,7 @@ scm_hasher(SCM obj, unsigned long n, scm_sizet d) case scm_tc7_wvect: case scm_tc7_vector: { - scm_sizet len = SCM_LENGTH(obj); + scm_sizet len = SCM_VECTOR_LENGTH(obj); SCM *data = SCM_VELTS(obj); if (len>5) { diff --git a/libguile/hashtab.c b/libguile/hashtab.c index ec3674b06..0d3588910 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -63,10 +63,10 @@ scm_hash_fn_get_handle (SCM table,SCM obj,unsigned int (*hash_fn)(),SCM (*assoc_ SCM h; SCM_ASSERT (SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_get_handle"); - if (SCM_LENGTH (table) == 0) + if (SCM_VECTOR_LENGTH (table) == 0) return SCM_EOL; - k = hash_fn (obj, SCM_LENGTH (table), closure); - if (k >= SCM_LENGTH (table)) + k = hash_fn (obj, SCM_VECTOR_LENGTH (table), closure); + if (k >= SCM_VECTOR_LENGTH (table)) scm_out_of_range ("hash_fn_get_handle", scm_ulong2num (k)); h = assoc_fn (obj, SCM_VELTS (table)[k], closure); return h; @@ -82,11 +82,11 @@ scm_hash_fn_create_handle_x (SCM table,SCM obj,SCM init,unsigned int (*hash_fn)( SCM it; SCM_ASSERT (SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_create_handle_x"); - if (SCM_LENGTH (table) == 0) + if (SCM_VECTOR_LENGTH (table) == 0) SCM_MISC_ERROR ("void hashtable", SCM_EOL); - k = hash_fn (obj, SCM_LENGTH (table), closure); - if (k >= SCM_LENGTH (table)) + k = hash_fn (obj, SCM_VECTOR_LENGTH (table), closure); + if (k >= SCM_VECTOR_LENGTH (table)) scm_out_of_range ("hash_fn_create_handle_x", scm_ulong2num (k)); SCM_REDEFER_INTS; it = assoc_fn (obj, SCM_VELTS (table)[k], closure); @@ -147,10 +147,10 @@ scm_hash_fn_remove_x (SCM table,SCM obj,unsigned int (*hash_fn)(),SCM (*assoc_fn SCM h; SCM_ASSERT (SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_remove_x"); - if (SCM_LENGTH (table) == 0) + if (SCM_VECTOR_LENGTH (table) == 0) return SCM_EOL; - k = hash_fn (obj, SCM_LENGTH (table), closure); - if (k >= SCM_LENGTH (table)) + k = hash_fn (obj, SCM_VECTOR_LENGTH (table), closure); + if (k >= SCM_VECTOR_LENGTH (table)) scm_out_of_range ("hash_fn_remove_x", scm_ulong2num (k)); h = assoc_fn (obj, SCM_VELTS (table)[k], closure); SCM_VELTS(table)[k] = delete_fn (h, SCM_VELTS(table)[k]); @@ -533,7 +533,7 @@ SCM_DEFINE (scm_hash_fold, "hash-fold", 3, 0, 0, SCM scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table) { - int i, n = SCM_LENGTH (table); + int i, n = SCM_VECTOR_LENGTH (table); SCM result = init; for (i = 0; i < n; ++i) { diff --git a/libguile/ioext.c b/libguile/ioext.c index ade23ced8..c6d49d7f1 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -96,7 +96,7 @@ SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0, SCM_VALIDATE_ROSTRING_COPY (1,delims,cdelims); num_delims = SCM_ROLENGTH (delims); SCM_VALIDATE_STRING_COPY (2,buf,cbuf); - cend = SCM_LENGTH (buf); + cend = SCM_STRING_LENGTH (buf); if (SCM_UNBNDP (port)) port = scm_cur_inp; else diff --git a/libguile/objects.c b/libguile/objects.c index bc976a7d4..dab44d1f0 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -262,7 +262,7 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args) /* Prepare for linear search */ mask = -1; i = 0; - end = SCM_LENGTH (methods); + end = SCM_VECTOR_LENGTH (methods); } else { @@ -457,7 +457,7 @@ SCM_DEFINE (scm_make_subclass_object, "make-subclass-object", 2, 0, 0, SCM_VALIDATE_STRING (2,layout); pl = SCM_PACK (SCM_STRUCT_DATA (class) [scm_vtable_index_layout]); /* Convert symbol->string */ - pl = scm_makfromstr (SCM_SYMBOL_CHARS (pl), (scm_sizet) SCM_LENGTH (pl), 0); + pl = scm_makfromstr (SCM_SYMBOL_CHARS (pl), SCM_SYMBOL_LENGTH (pl), 0); return scm_i_make_class_object (SCM_STRUCT_VTABLE (class), scm_string_append (SCM_LIST2 (pl, layout)), SCM_CLASS_FLAGS (class)); diff --git a/libguile/ports.c b/libguile/ports.c index d6689e55d..84df7e5d6 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1084,7 +1084,7 @@ SCM_DEFINE (scm_unread_string, "unread-string", 2, 0, 0, else SCM_VALIDATE_OPINPORT (2,port); - scm_ungets (SCM_ROCHARS (str), SCM_LENGTH (str), port); + scm_ungets (SCM_ROCHARS (str), SCM_STRING_LENGTH (str), port); return str; } diff --git a/libguile/socket.c b/libguile/socket.c index 7bbcd1e52..0a7f2937f 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -709,7 +709,7 @@ SCM_DEFINE (scm_recv, "recv!", 2, 1, 0, SCM_VALIDATE_INUM_DEF_COPY (3,flags,0,flg); fd = SCM_FPORT_FDES (sock); - SCM_SYSCALL (rv = recv (fd, SCM_STRING_CHARS (buf), SCM_LENGTH (buf), flg)); + SCM_SYSCALL (rv = recv (fd, SCM_STRING_CHARS (buf), SCM_STRING_LENGTH (buf), flg)); if (rv == -1) SCM_SYSERROR; @@ -777,7 +777,7 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0, SCM_VALIDATE_OPFPORT (1,sock); SCM_VALIDATE_STRING (2,buf); - cend = SCM_LENGTH (buf); + cend = SCM_STRING_LENGTH (buf); if (SCM_UNBNDP (flags)) flg = 0; diff --git a/libguile/stacks.c b/libguile/stacks.c index 5aab91786..3b0535202 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -438,7 +438,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (obj) + sizeof (scm_contregs)) - SCM_BASE (obj)); #ifndef STACK_GROWS_UP - offset += SCM_LENGTH (obj); + offset += SCM_CONTINUATION_LENGTH (obj); #endif dframe = RELOC_FRAME (SCM_DFRAME (obj), offset); } @@ -522,7 +522,7 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0, offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (stack) + sizeof (scm_contregs)) - SCM_BASE (stack)); #ifndef STACK_GROWS_UP - offset += SCM_LENGTH (stack); + offset += SCM_CONTINUATION_LENGTH (stack); #endif dframe = RELOC_FRAME (SCM_DFRAME (stack), offset); } @@ -592,7 +592,7 @@ SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0, offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (obj) + sizeof (scm_contregs)) - SCM_BASE (obj)); #ifndef STACK_GROWS_UP - offset += SCM_LENGTH (obj); + offset += SCM_CONTINUATION_LENGTH (obj); #endif dframe = RELOC_FRAME (SCM_DFRAME (obj), offset); } diff --git a/libguile/strings.c b/libguile/strings.c index 7174d5c84..fc706393f 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -242,7 +242,7 @@ SCM_DEFINE (scm_string_length, "string-length", 1, 0, 0, #define FUNC_NAME s_scm_string_length { SCM_VALIDATE_STRINGORSUBSTR (1, string); - return SCM_MAKINUM (SCM_LENGTH (string)); + return SCM_MAKINUM (SCM_STRING_LENGTH (string)); } #undef FUNC_NAME @@ -268,7 +268,7 @@ SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0, #define FUNC_NAME s_scm_string_set_x { SCM_VALIDATE_RWSTRING (1,str); - SCM_VALIDATE_INUM_RANGE (2,k,0,SCM_LENGTH(str)); + SCM_VALIDATE_INUM_RANGE (2,k,0,SCM_STRING_LENGTH(str)); SCM_VALIDATE_CHAR (3,chr); SCM_STRING_UCHARS (str)[SCM_INUM (k)] = SCM_CHAR (chr); return SCM_UNSPECIFIED; diff --git a/libguile/strop.c b/libguile/strop.c index 49302167c..6b8e85bde 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -255,10 +255,10 @@ SCM_DEFINE (scm_substring_move_x, "substring-move!", 5, 0, 0, SCM_VALIDATE_INUM_COPY (5,start2,s2); len = e - s1; SCM_ASSERT_RANGE (3,end1,len >= 0); - SCM_ASSERT_RANGE (2,start1,s1 <= SCM_LENGTH (str1) && s1 >= 0); - SCM_ASSERT_RANGE (5,start2,s2 <= SCM_LENGTH (str2) && s2 >= 0); - SCM_ASSERT_RANGE (3,end1,e <= SCM_LENGTH (str1) && e >= 0); - SCM_ASSERT_RANGE (5,start2,len+s2 <= SCM_LENGTH (str2)); + SCM_ASSERT_RANGE (2,start1,s1 <= SCM_STRING_LENGTH (str1) && s1 >= 0); + SCM_ASSERT_RANGE (5,start2,s2 <= SCM_STRING_LENGTH (str2) && s2 >= 0); + SCM_ASSERT_RANGE (3,end1,e <= SCM_STRING_LENGTH (str1) && e >= 0); + SCM_ASSERT_RANGE (5,start2,len+s2 <= SCM_STRING_LENGTH (str2)); SCM_SYSCALL(memmove((void *)(&(SCM_STRING_CHARS(str2)[s2])), (void *)(&(SCM_STRING_CHARS(str1)[s1])), @@ -288,8 +288,8 @@ SCM_DEFINE (scm_substring_fill_x, "substring-fill!", 4, 0, 0, SCM_VALIDATE_INUM_COPY (2,start,i); SCM_VALIDATE_INUM_COPY (3,end,e); SCM_VALIDATE_CHAR_COPY (4,fill,c); - SCM_ASSERT_RANGE (2,start,i <= SCM_LENGTH (str) && i >= 0); - SCM_ASSERT_RANGE (3,end,e <= SCM_LENGTH (str) && e >= 0); + SCM_ASSERT_RANGE (2,start,i <= SCM_STRING_LENGTH (str) && i >= 0); + SCM_ASSERT_RANGE (3,end,e <= SCM_STRING_LENGTH (str) && e >= 0); while (i= 0;k--) dst[k] = c; + for (k = SCM_STRING_LENGTH (str)-1;k >= 0;k--) dst[k] = c; return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -379,7 +379,7 @@ SCM_DEFINE (scm_string_upcase_x, "string-upcase!", 1, 0, 0, SCM_VALIDATE_STRING (1, v); - for (k = 0; k < SCM_LENGTH (v); ++k) + for (k = 0; k < SCM_STRING_LENGTH (v); ++k) SCM_STRING_UCHARS (v) [k] = scm_upcase (SCM_STRING_UCHARS (v) [k]); return v; @@ -413,7 +413,7 @@ SCM_DEFINE (scm_string_downcase_x, "string-downcase!", 1, 0, 0, SCM_VALIDATE_STRING (1, v); - for (k = 0; k < SCM_LENGTH (v); ++k) + for (k = 0; k < SCM_STRING_LENGTH (v); ++k) SCM_STRING_UCHARS (v) [k] = scm_downcase (SCM_STRING_UCHARS (v) [k]); return v; @@ -438,7 +438,7 @@ SCM_DEFINE (scm_string_capitalize_x, "string-capitalize!", 1, 0, 0, char *sz; int i, len, in_word=0; SCM_VALIDATE_STRING (1,str); - len = SCM_LENGTH(str); + len = SCM_STRING_LENGTH(str); sz = SCM_STRING_CHARS (str); for(i=0; i Date: Mon, 9 Oct 2000 16:27:24 +0000 Subject: [PATCH 0308/2047] * Made some functions not accept symbols as input parameters any more. * Replaced some calls to SCM_LENGTH. --- libguile/ChangeLog | 17 +++++++++++++++++ libguile/filesys.c | 34 ++++++++++++++++++---------------- libguile/gh_data.c | 36 +++++++++++++++++------------------- libguile/posix.c | 8 ++++---- libguile/regex-posix.c | 4 ++-- libguile/stime.c | 7 +++---- libguile/symbols.c | 24 ++++++++++++------------ libguile/validate.h | 4 ++-- 8 files changed, 75 insertions(+), 59 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 8c1232e0b..567403fa3 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,20 @@ +2000-10-09 Dirk Herrmann + + * filesys.c (fill_select_type, retrieve_select_type, scm_select), + gh_data.c (gh_set_substr, gh_scm2chars, gh_scm2shorts, + gh_scm2longs, gh_scm2floats, gh_scm2doubles, gh_symbol2newstr), + stime.c (bdtime2c), symbols.c (scm_sym2vcell, scm_sym2ovcell_soft, + scm_intern_obarray_soft, scm_symbol_to_string, scm_intern_symbol, + scm_unintern_symbol, copy_and_prune_obarray, scm_builtin_bindings, + scm_builtin_weak_bindings), validate.h (SCM_VALIDATE_VECTOR_LEN): + Replace SCM_LENGTH with the appropriate SCM__LENGTH macro. + + * filesys.c (scm_dirname, scm_basename), gh_data.c (gh_scm2newstr, + gh_get_substr), posix.c (scm_putenv), regex-posix.c + (scm_regexp_exec), stime.c (setzone), symbols.c + (scm_string_to_symbol): Don't accept symbols as input parameters + any more. + 2000-10-09 Dirk Herrmann * continuations.c (scm_make_cont, copy_stack_and_call, diff --git a/libguile/filesys.c b/libguile/filesys.c index 4a2c67659..4f282d438 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -879,7 +879,7 @@ fill_select_type (SELECT_TYPE *set, SCM *ports_ready, SCM list_or_vec, int pos) if (SCM_VECTORP (list_or_vec)) { - int i = SCM_LENGTH (list_or_vec); + int i = SCM_VECTOR_LENGTH (list_or_vec); SCM *ve = SCM_VELTS (list_or_vec); while (--i >= 0) @@ -940,7 +940,7 @@ retrieve_select_type (SELECT_TYPE *set, SCM ports_ready, SCM list_or_vec) if (SCM_VECTORP (list_or_vec)) { - int i = SCM_LENGTH (list_or_vec); + int i = SCM_VECTOR_LENGTH (list_or_vec); SCM *ve = SCM_VELTS (list_or_vec); while (--i >= 0) @@ -1009,7 +1009,7 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0, if (SCM_VECTORP (reads)) { - read_count = SCM_LENGTH (reads); + read_count = SCM_VECTOR_LENGTH (reads); } else { @@ -1018,7 +1018,7 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0, } if (SCM_VECTORP (writes)) { - write_count = SCM_LENGTH (writes); + write_count = SCM_VECTOR_LENGTH (writes); } else { @@ -1027,7 +1027,7 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0, } if (SCM_VECTORP (excepts)) { - except_count = SCM_LENGTH (excepts); + except_count = SCM_VECTOR_LENGTH (excepts); } else { @@ -1330,10 +1330,14 @@ SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0, #define FUNC_NAME s_scm_dirname { char *s; - int i, len; - SCM_VALIDATE_ROSTRING (1,filename); + long int i; + unsigned long int len; + + SCM_VALIDATE_STRING (1,filename); + s = SCM_ROCHARS (filename); - len = SCM_LENGTH (filename); + len = SCM_STRING_LENGTH (filename); + i = len - 1; while (i >= 0 && s[i] == '/') --i; while (i >= 0 && s[i] != '/') --i; @@ -1357,21 +1361,19 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0, { char *f, *s = 0; int i, j, len, end; - SCM_VALIDATE_ROSTRING (1,filename); - SCM_ASSERT (SCM_UNBNDP (suffix) - || (SCM_ROSTRINGP (suffix)), - suffix, - SCM_ARG2, - FUNC_NAME); + + SCM_VALIDATE_STRING (1,filename); f = SCM_ROCHARS (filename); + len = SCM_STRING_LENGTH (filename); + if (SCM_UNBNDP (suffix)) j = -1; else { + SCM_VALIDATE_STRING (2, suffix); s = SCM_ROCHARS (suffix); - j = SCM_LENGTH (suffix) - 1; + j = SCM_STRING_LENGTH (suffix) - 1; } - len = SCM_LENGTH (filename); i = len - 1; while (i >= 0 && f[i] == '/') --i; end = i; diff --git a/libguile/gh_data.c b/libguile/gh_data.c index 5987ae7f6..9972f96e6 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -117,7 +117,7 @@ gh_set_substr (char *src, SCM dst, int start, int len) "gh_set_substr"); dst_ptr = SCM_STRING_CHARS (dst); - dst_len = SCM_LENGTH (dst); + dst_len = SCM_STRING_LENGTH (dst); SCM_ASSERT (len >= 0 && (unsigned) len <= dst_len, dst, SCM_ARG4, "gh_set_substr"); @@ -277,7 +277,7 @@ gh_scm2chars (SCM obj, char *m) { case scm_tc7_vector: case scm_tc7_wvect: - n = SCM_LENGTH (obj); + n = SCM_VECTOR_LENGTH (obj); for (i = 0; i < n; ++i) { val = SCM_VELTS (obj)[i]; @@ -325,7 +325,7 @@ gh_scm2shorts (SCM obj, short *m) { case scm_tc7_vector: case scm_tc7_wvect: - n = SCM_LENGTH (obj); + n = SCM_VECTOR_LENGTH (obj); for (i = 0; i < n; ++i) { val = SCM_VELTS (obj)[i]; @@ -345,7 +345,7 @@ gh_scm2shorts (SCM obj, short *m) break; #ifdef HAVE_ARRAYS case scm_tc7_svect: - n = SCM_LENGTH (obj); + n = SCM_UVECTOR_LENGTH (obj); if (m == 0) m = (short *) malloc (n * sizeof (short)); memcpy (m, SCM_VELTS (obj), n * sizeof (short)); @@ -370,7 +370,7 @@ gh_scm2longs (SCM obj, long *m) { case scm_tc7_vector: case scm_tc7_wvect: - n = SCM_LENGTH (obj); + n = SCM_VECTOR_LENGTH (obj); for (i = 0; i < n; ++i) { val = SCM_VELTS (obj)[i]; @@ -388,7 +388,7 @@ gh_scm2longs (SCM obj, long *m) #ifdef HAVE_ARRAYS case scm_tc7_ivect: case scm_tc7_uvect: - n = SCM_LENGTH (obj); + n = SCM_UVECTOR_LENGTH (obj); if (m == 0) m = (long *) malloc (n * sizeof (long)); memcpy (m, SCM_VELTS (obj), n * sizeof (long)); @@ -413,7 +413,7 @@ gh_scm2floats (SCM obj, float *m) { case scm_tc7_vector: case scm_tc7_wvect: - n = SCM_LENGTH (obj); + n = SCM_VECTOR_LENGTH (obj); for (i = 0; i < n; ++i) { val = SCM_VELTS (obj)[i]; @@ -436,14 +436,14 @@ gh_scm2floats (SCM obj, float *m) break; #ifdef HAVE_ARRAYS case scm_tc7_fvect: - n = SCM_LENGTH (obj); + n = SCM_UVECTOR_LENGTH (obj); if (m == 0) m = (float *) malloc (n * sizeof (float)); memcpy (m, (float *) SCM_VELTS (obj), n * sizeof (float)); break; case scm_tc7_dvect: - n = SCM_LENGTH (obj); + n = SCM_UVECTOR_LENGTH (obj); if (m == 0) m = (float*) malloc (n * sizeof (float)); for (i = 0; i < n; ++i) @@ -469,7 +469,7 @@ gh_scm2doubles (SCM obj, double *m) { case scm_tc7_vector: case scm_tc7_wvect: - n = SCM_LENGTH (obj); + n = SCM_VECTOR_LENGTH (obj); for (i = 0; i < n; ++i) { val = SCM_VELTS (obj)[i]; @@ -492,7 +492,7 @@ gh_scm2doubles (SCM obj, double *m) break; #ifdef HAVE_ARRAYS case scm_tc7_fvect: - n = SCM_LENGTH (obj); + n = SCM_UVECTOR_LENGTH (obj); if (m == 0) m = (double *) malloc (n * sizeof (double)); for (i = 0; i < n; ++i) @@ -500,7 +500,7 @@ gh_scm2doubles (SCM obj, double *m) break; case scm_tc7_dvect: - n = SCM_LENGTH (obj); + n = SCM_UVECTOR_LENGTH (obj); if (m == 0) m = (double*) malloc (n * sizeof (double)); memcpy (m, SCM_VELTS (obj), n * sizeof (double)); @@ -532,13 +532,12 @@ gh_scm2newstr (SCM str, int *lenp) char *ret_str; int len; - SCM_ASSERT (SCM_ROSTRINGP (str), str, SCM_ARG3, - "gh_scm2newstr"); + SCM_ASSERT (SCM_STRINGP (str), str, SCM_ARG3, "gh_scm2newstr"); /* protect str from GC while we copy off its data */ scm_protect_object (str); - len = SCM_LENGTH (str); + len = SCM_STRING_LENGTH (str); ret_str = (char *) scm_must_malloc ((len + 1) * sizeof (char), "gh_scm2newstr"); @@ -569,11 +568,10 @@ void gh_get_substr (SCM src, char *dst, int start, int len) { int src_len, effective_length; - SCM_ASSERT (SCM_ROSTRINGP (src), src, SCM_ARG3, - "gh_get_substr"); + SCM_ASSERT (SCM_STRINGP (src), src, SCM_ARG3, "gh_get_substr"); scm_protect_object (src); - src_len = SCM_LENGTH (src); + src_len = SCM_STRING_LENGTH (src); effective_length = (len < src_len) ? len : src_len; memcpy (dst + start, SCM_ROCHARS (src), effective_length * sizeof (char)); /* FIXME: must signal an error if len > src_len */ @@ -600,7 +598,7 @@ gh_symbol2newstr (SCM sym, int *lenp) /* protect str from GC while we copy off its data */ scm_protect_object (sym); - len = SCM_LENGTH (sym); + len = SCM_SYMBOL_LENGTH (sym); ret_str = (char *) scm_must_malloc ((len + 1) * sizeof (char), "gh_symbol2newstr"); diff --git a/libguile/posix.c b/libguile/posix.c index 2d9d98038..309fa7ab6 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1134,13 +1134,13 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0, int rv; char *ptr; - SCM_VALIDATE_ROSTRING (1,str); + SCM_VALIDATE_STRING (1, str); /* must make a new copy to be left in the environment, safe from gc. */ - ptr = malloc (SCM_LENGTH (str) + 1); + ptr = malloc (SCM_STRING_LENGTH (str) + 1); if (ptr == NULL) SCM_MEMORY_ERROR; - strncpy (ptr, SCM_ROCHARS (str), SCM_LENGTH (str)); - ptr[SCM_LENGTH(str)] = 0; + strncpy (ptr, SCM_ROCHARS (str), SCM_STRING_LENGTH (str)); + ptr[SCM_STRING_LENGTH (str)] = 0; rv = putenv (ptr); if (rv < 0) SCM_SYSERROR; diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index bf941c568..d706bd6ba 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -232,9 +232,9 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, SCM mvec = SCM_BOOL_F; SCM_VALIDATE_RGXP (1,rx); - SCM_VALIDATE_ROSTRING (2,str); + SCM_VALIDATE_STRING (2,str); SCM_VALIDATE_INUM_DEF_COPY (3,start,0,offset); - SCM_ASSERT_RANGE (3,start,offset >= 0 && (unsigned) offset <= SCM_LENGTH (str)); + SCM_ASSERT_RANGE (3,start, offset >= 0 && offset <= SCM_STRING_LENGTH (str)); if (SCM_UNBNDP (flags)) flags = SCM_INUM0; SCM_VALIDATE_INUM (4,flags); diff --git a/libguile/stime.c b/libguile/stime.c index b10e7278c..6e99a008c 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -306,10 +306,9 @@ setzone (SCM zone, int pos, const char *subr) static char *tmpenv[2]; char *buf; - SCM_ASSERT (SCM_ROSTRINGP (zone), zone, pos, subr); + SCM_ASSERT (SCM_STRINGP (zone), zone, pos, subr); SCM_COERCE_SUBSTR (zone); - buf = scm_must_malloc (SCM_LENGTH (zone) + sizeof (tzvar) + 1, - subr); + buf = scm_must_malloc (SCM_STRING_LENGTH (zone) + sizeof (tzvar) + 1, subr); sprintf (buf, "%s=%s", tzvar, SCM_ROCHARS (zone)); oldenv = environ; tmpenv[0] = buf; @@ -437,7 +436,7 @@ bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr) int i; SCM_ASSERT (SCM_VECTORP (sbd_time) - && SCM_LENGTH (sbd_time) == 11, + && SCM_VECTOR_LENGTH (sbd_time) == 11, sbd_time, pos, subr); velts = SCM_VELTS (sbd_time); for (i = 0; i < 10; i++) diff --git a/libguile/symbols.c b/libguile/symbols.c index 0e477f9fb..e40f4278a 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -144,7 +144,7 @@ scm_sym2vcell (SCM sym, SCM thunk, SCM definep) SCM * lsymp; SCM z; scm_sizet hash - = scm_string_hash (SCM_SYMBOL_UCHARS (sym), SCM_LENGTH (sym)) % scm_symhash_dim; + = scm_string_hash (SCM_SYMBOL_UCHARS (sym), SCM_SYMBOL_LENGTH (sym)) % scm_symhash_dim; SCM_DEFER_INTS; for (lsym = SCM_VELTS (scm_symhash)[hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) @@ -189,7 +189,7 @@ scm_sym2ovcell_soft (SCM sym, SCM obarray) { SCM lsym, z; scm_sizet hash - = scm_string_hash (SCM_SYMBOL_UCHARS (sym), SCM_LENGTH (sym)) % SCM_LENGTH (obarray); + = scm_string_hash (SCM_SYMBOL_UCHARS (sym), SCM_SYMBOL_LENGTH (sym)) % SCM_VECTOR_LENGTH (obarray); SCM_REDEFER_INTS; for (lsym = SCM_VELTS (obarray)[hash]; SCM_NIMP (lsym); @@ -256,7 +256,7 @@ scm_intern_obarray_soft (const char *name,scm_sizet len,SCM obarray,unsigned int goto uninterned_symbol; } - hash = raw_hash % SCM_LENGTH (obarray); + hash = raw_hash % SCM_VECTOR_LENGTH (obarray); retry_new_obarray: for (lsym = SCM_VELTS (obarray)[hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) @@ -265,7 +265,7 @@ scm_intern_obarray_soft (const char *name,scm_sizet len,SCM obarray,unsigned int SCM a = SCM_CAR (lsym); SCM z = SCM_CAR (a); unsigned char *tmp = SCM_SYMBOL_UCHARS (z); - if (SCM_LENGTH (z) != len) + if (SCM_SYMBOL_LENGTH (z) != len) goto trynext; for (i = len; i--;) if (((unsigned char *) name)[i] != tmp[i]) @@ -460,7 +460,7 @@ SCM_DEFINE (scm_symbol_to_string, "symbol->string", 1, 0, 0, #define FUNC_NAME s_scm_symbol_to_string { SCM_VALIDATE_SYMBOL (1, s); - return scm_makfromstr (SCM_SYMBOL_CHARS (s), SCM_LENGTH (s), 0); + return scm_makfromstr (SCM_SYMBOL_CHARS (s), SCM_SYMBOL_LENGTH (s), 0); } #undef FUNC_NAME @@ -497,8 +497,8 @@ SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0, SCM vcell; SCM answer; - SCM_VALIDATE_ROSTRING (1,s); - vcell = scm_intern(SCM_ROCHARS(s), (scm_sizet)SCM_LENGTH(s)); + SCM_VALIDATE_STRING (1,s); + vcell = scm_intern (SCM_ROCHARS (s), SCM_STRING_LENGTH (s)); answer = SCM_CAR (vcell); return answer; } @@ -557,7 +557,7 @@ SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0, if (SCM_FALSEP (o)) o = scm_symhash; SCM_VALIDATE_VECTOR (1,o); - hval = scm_string_hash (SCM_SYMBOL_UCHARS (s), SCM_LENGTH (s)) % SCM_LENGTH (o); + hval = scm_string_hash (SCM_SYMBOL_UCHARS (s), SCM_SYMBOL_LENGTH (s)) % SCM_VECTOR_LENGTH (o); /* If the symbol is already interned, simply return. */ SCM_REDEFER_INTS; { @@ -594,7 +594,7 @@ SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0, if (SCM_FALSEP (o)) o = scm_symhash; SCM_VALIDATE_VECTOR (1,o); - hval = scm_string_hash (SCM_SYMBOL_UCHARS (s), SCM_LENGTH (s)) % SCM_LENGTH (o); + hval = scm_string_hash (SCM_SYMBOL_UCHARS (s), SCM_SYMBOL_LENGTH (s)) % SCM_VECTOR_LENGTH (o); SCM_DEFER_INTS; { SCM lsym_follow; @@ -764,7 +764,7 @@ static void copy_and_prune_obarray (SCM from, SCM to) { int i; - int length = SCM_LENGTH (from); + int length = SCM_VECTOR_LENGTH (from); for (i = 0; i < length; ++i) { SCM head = SCM_VELTS (from)[i]; /* GC protection */ @@ -791,7 +791,7 @@ SCM_DEFINE (scm_builtin_bindings, "builtin-bindings", 0, 0, 0, "unbound symbols.") #define FUNC_NAME s_scm_builtin_bindings { - int length = SCM_LENGTH (scm_symhash); + int length = SCM_VECTOR_LENGTH (scm_symhash); SCM obarray = scm_make_vector (SCM_MAKINUM (length), SCM_EOL); copy_and_prune_obarray (scm_symhash, obarray); return obarray; @@ -804,7 +804,7 @@ SCM_DEFINE (scm_builtin_weak_bindings, "builtin-weak-bindings", 0, 0, 0, "") #define FUNC_NAME s_scm_builtin_weak_bindings { - int length = SCM_LENGTH (scm_weak_symhash); + int length = SCM_VECTOR_LENGTH (scm_weak_symhash); SCM obarray = scm_make_doubly_weak_hash_table (SCM_MAKINUM (length)); copy_and_prune_obarray (scm_weak_symhash, obarray); return obarray; diff --git a/libguile/validate.h b/libguile/validate.h index c07b04fb4..76277a43d 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -1,4 +1,4 @@ -/* $Id: validate.h,v 1.16 2000-09-26 21:53:49 dirk Exp $ */ +/* $Id: validate.h,v 1.17 2000-10-09 16:27:24 dirk Exp $ */ /* Copyright (C) 1999, 2000 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify @@ -413,7 +413,7 @@ #define SCM_VALIDATE_VECTOR_LEN(pos, v, len) \ do { \ - SCM_ASSERT (SCM_VECTORP (v) && len == SCM_LENGTH (v), v, pos, FUNC_NAME); \ + SCM_ASSERT (SCM_VECTORP (v) && len == SCM_VECTOR_LENGTH (v), v, pos, FUNC_NAME); \ } while (0) #endif From 4adc302894d806d90a684cf099de1f28379ca8f6 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 10 Oct 2000 07:32:45 +0000 Subject: [PATCH 0309/2047] * Fixed apropos: regexp-exec does not accept symbol arguments any more. --- ice-9/ChangeLog | 6 ++++++ ice-9/session.scm | 4 ++-- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index bbbc9af7c..b19c0f61f 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,9 @@ +2000-10-10 Dirk Herrmann + + * session.scm (apropos, apropos-fold): regexp-exec does not + accept symbol arguments any more. Thanks to Dale P. Smith for the + patch. + 2000-09-30 Gary Houston * posix.scm (setgrent): pass #t, not #f. thanks to diff --git a/ice-9/session.scm b/ice-9/session.scm index a49fc5fed..3cde2e5fa 100644 --- a/ice-9/session.scm +++ b/ice-9/session.scm @@ -212,7 +212,7 @@ where OPTIONSET is one of debug, read, eval, print (lambda (oblist) (for-each (lambda (x) - (cond ((regexp-exec match (car x)) + (cond ((regexp-exec match (symbol->string (car x))) (display name) (display ": ") (display (car x)) @@ -266,7 +266,7 @@ Fourth arg FOLDER is one of (lambda (module data) (let* ((obarray-filter (lambda (name val data) - (if (and (regexp-exec match name) + (if (and (regexp-exec match (symbol->string name)) (not (hashq-get-handle recorded name))) (begin (hashq-set! recorded name #t) From b5c2579a3444793316db68951ebf9e0b53ceabd6 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 10 Oct 2000 09:22:31 +0000 Subject: [PATCH 0310/2047] * Removed further calls to SCM_LENGTH. --- libguile/ChangeLog | 22 +++++++++++++ libguile/eval.c | 16 +++++----- libguile/gc.c | 41 ++++++++++++++---------- libguile/gh_data.c | 7 ++++- libguile/sort.c | 77 ++++++++++++++++------------------------------ libguile/unif.h | 2 ++ libguile/vectors.c | 28 ++++++++--------- 7 files changed, 103 insertions(+), 90 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 567403fa3..76d09a6c2 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,25 @@ +2000-10-10 Dirk Herrmann + + * unif.h (SCM_BITVECTOR_P, SCM_BITVECTOR_BASE): Added. + + * eval.c (iqq, SCM_CEVAL, SCM_APPLY, check_map_args, scm_map, + scm_for_each, scm_copy_tree), gc.c (scm_igc, scm_gc_mark, + scm_gc_sweep), gh_data.c (gh_scm2chars), sort.c + (scm_restricted_vector_sort_x, scm_sorted_p, scm_sort_x, + scm_sort, scm_stable_sort_x, scm_stable_sort), vectors.c + (scm_vector_length, scm_vector_ref, scm_vector_set_x, + scm_vector_to_list, scm_vector_fill_x, scm_vector_equal_p, + scm_vector_move_left_x, scm_vector_move_right_x, ): Replace + SCM_LENGTH with the appropriate SCM__LENGTH macro. + + * gc.c (scm_gc_sweep): Use SCM_BITVECTOR_BASE for bitvectors. + + * sort.c (scm_restricted_vector_sort_x, scm_sorted_p): Eliminated + dummy type dispatch. + + (scm_sort_x, scm_sort, scm_stable_sort_x, scm_stable_sort): + Eliminated redundant NIM test. + 2000-10-09 Dirk Herrmann * filesys.c (fill_select_type, retrieve_select_type, scm_select), diff --git a/libguile/eval.c b/libguile/eval.c index 6a2b58953..af200d3bb 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -811,7 +811,7 @@ iqq (SCM form,SCM env,int depth) return form; if (SCM_VECTORP (form)) { - long i = SCM_LENGTH (form); + long i = SCM_VECTOR_LENGTH (form); SCM *data = SCM_VELTS (form); tmp = SCM_EOL; for (; --i >= 0;) @@ -2276,7 +2276,7 @@ dispatch: /* Prepare for linear search */ mask = -1; i = 0; - end = SCM_LENGTH (proc); + end = SCM_VECTOR_LENGTH (proc); } else { @@ -2765,7 +2765,7 @@ evapply: } proc = SCM_SNAME (proc); { - char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_LENGTH (proc) - 1; + char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_SYMBOL_LENGTH (proc) - 1; while ('c' != *--chrs) { SCM_ASSERT (SCM_CONSP (t.arg1), @@ -3396,7 +3396,7 @@ tail: } proc = SCM_SNAME (proc); { - char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_LENGTH (proc) - 1; + char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_SYMBOL_LENGTH (proc) - 1; while ('c' != *--chrs) { SCM_ASSERT (SCM_CONSP (arg1), @@ -3604,7 +3604,7 @@ check_map_args (SCM argv, SCM *ve = SCM_VELTS (argv); int i; - for (i = SCM_LENGTH (argv) - 1; i >= 1; i--) + for (i = SCM_VECTOR_LENGTH (argv) - 1; i >= 1; i--) { int elt_len = scm_ilength (ve[i]); @@ -3665,7 +3665,7 @@ scm_map (SCM proc, SCM arg1, SCM args) while (1) { arg1 = SCM_EOL; - for (i = SCM_LENGTH (args) - 1; i >= 0; i--) + for (i = SCM_VECTOR_LENGTH (args) - 1; i >= 0; i--) { if (SCM_IMP (ve[i])) return res; @@ -3708,7 +3708,7 @@ scm_for_each (SCM proc, SCM arg1, SCM args) while (1) { arg1 = SCM_EOL; - for (i = SCM_LENGTH (args) - 1; i >= 0; i--) + for (i = SCM_VECTOR_LENGTH (args) - 1; i >= 0; i--) { if SCM_IMP (ve[i]) return SCM_UNSPECIFIED; @@ -3823,7 +3823,7 @@ SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0, return obj; if (SCM_VECTORP (obj)) { - scm_sizet i = SCM_LENGTH (obj); + scm_sizet i = SCM_VECTOR_LENGTH (obj); ans = scm_make_vector (SCM_MAKINUM (i), SCM_UNSPECIFIED); while (i--) SCM_VELTS (ans)[i] = scm_copy_tree (SCM_VELTS (obj)[i]); diff --git a/libguile/gc.c b/libguile/gc.c index f101b4b98..8ce64db8c 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1010,7 +1010,7 @@ scm_igc (const char *what) int bound; SCM * elts; elts = SCM_VELTS (scm_continuation_stack); - bound = SCM_LENGTH (scm_continuation_stack); + bound = SCM_VECTOR_LENGTH (scm_continuation_stack); x = SCM_INUM (scm_continuation_stack_ptr); while (x < bound) { @@ -1172,7 +1172,7 @@ gc_mark_nimp: { /* ptr is a struct */ SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]); - int len = SCM_LENGTH (layout); + int len = SCM_SYMBOL_LENGTH (layout); char * fields_desc = SCM_SYMBOL_CHARS (layout); scm_bits_t * struct_data = (scm_bits_t *) SCM_STRUCT_DATA (ptr); @@ -1213,10 +1213,7 @@ gc_mark_nimp: ptr = SCM_CDR (ptr); goto gc_mark_nimp; case scm_tc7_vector: -#ifdef CCLO - case scm_tc7_cclo: -#endif - i = SCM_LENGTH (ptr); + i = SCM_VECTOR_LENGTH (ptr); if (i == 0) break; while (--i > 0) @@ -1224,11 +1221,22 @@ gc_mark_nimp: scm_gc_mark (SCM_VELTS (ptr)[i]); ptr = SCM_VELTS (ptr)[0]; goto gc_mark_loop; +#ifdef CCLO + case scm_tc7_cclo: + i = SCM_CCLO_LENGTH (ptr); + if (i == 0) + break; + while (--i > 0) + if (SCM_NIMP (SCM_VELTS (ptr)[i])) + scm_gc_mark (SCM_VELTS (ptr)[i]); + ptr = SCM_VELTS (ptr)[0]; + goto gc_mark_loop; +#endif case scm_tc7_contin: if (SCM_VELTS (ptr)) scm_mark_locations (SCM_VELTS_AS_STACKITEMS (ptr), (scm_sizet) - (SCM_LENGTH (ptr) + + (SCM_CONTINUATION_LENGTH (ptr) + (sizeof (SCM_STACKITEM) + -1 + sizeof (scm_contregs)) / sizeof (SCM_STACKITEM))); @@ -1263,7 +1271,7 @@ gc_mark_nimp: int weak_keys; int weak_values; - len = SCM_LENGTH (ptr); + len = SCM_VECTOR_LENGTH (ptr); weak_keys = SCM_IS_WHVEC (ptr) || SCM_IS_WHVEC_B (ptr); weak_values = SCM_IS_WHVEC_V (ptr) || SCM_IS_WHVEC_B (ptr); @@ -1603,23 +1611,23 @@ scm_gc_sweep () case scm_tc7_pws: break; case scm_tc7_wvect: - m += (2 + SCM_LENGTH (scmptr)) * sizeof (SCM); + m += (2 + SCM_VECTOR_LENGTH (scmptr)) * sizeof (SCM); scm_must_free (SCM_VECTOR_BASE (scmptr) - 2); break; case scm_tc7_vector: - m += (SCM_LENGTH (scmptr) * sizeof (SCM)); + m += (SCM_VECTOR_LENGTH (scmptr) * sizeof (SCM)); scm_must_free (SCM_VECTOR_BASE (scmptr)); break; #ifdef CCLO case scm_tc7_cclo: - m += (SCM_LENGTH (scmptr) * sizeof (SCM)); + m += (SCM_CCLO_LENGTH (scmptr) * sizeof (SCM)); scm_must_free (SCM_CCLO_BASE (scmptr)); break; #endif #ifdef HAVE_ARRAYS case scm_tc7_bvect: - m += sizeof (long) * ((SCM_HUGE_LENGTH (scmptr) + SCM_LONG_BIT - 1) / SCM_LONG_BIT); - scm_must_free (SCM_UVECTOR_BASE (scmptr)); + m += sizeof (long) * ((SCM_BITVECTOR_LENGTH (scmptr) + SCM_LONG_BIT - 1) / SCM_LONG_BIT); + scm_must_free (SCM_BITVECTOR_BASE (scmptr)); break; case scm_tc7_byvect: case scm_tc7_ivect: @@ -1638,15 +1646,16 @@ scm_gc_sweep () case scm_tc7_substring: break; case scm_tc7_string: - m += SCM_HUGE_LENGTH (scmptr) + 1; + m += SCM_STRING_LENGTH (scmptr) + 1; scm_must_free (SCM_STRING_CHARS (scmptr)); break; case scm_tc7_symbol: - m += SCM_LENGTH (scmptr) + 1; + m += SCM_SYMBOL_LENGTH (scmptr) + 1; scm_must_free (SCM_SYMBOL_CHARS (scmptr)); break; case scm_tc7_contin: - m += SCM_LENGTH (scmptr) * sizeof (SCM_STACKITEM) + sizeof (scm_contregs); + m += SCM_CONTINUATION_LENGTH (scmptr) * sizeof (SCM_STACKITEM) + + sizeof (scm_contregs); if (SCM_CONTREGS (scmptr)) { scm_must_free (SCM_CONTREGS (scmptr)); diff --git a/libguile/gh_data.c b/libguile/gh_data.c index 9972f96e6..0e359dc54 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -297,10 +297,15 @@ gh_scm2chars (SCM obj, char *m) break; #ifdef HAVE_ARRAYS case scm_tc7_byvect: + n = SCM_UVECTOR_LENGTH (obj); + if (m == 0) + m = (char *) malloc (n * sizeof (char)); + memcpy (m, SCM_VELTS (obj), n * sizeof (char)); + break; #endif case scm_tc7_string: case scm_tc7_substring: - n = SCM_LENGTH (obj); + n = SCM_STRING_LENGTH (obj); if (m == 0) m = (char *) malloc (n * sizeof (char)); memcpy (m, SCM_VELTS (obj), n * sizeof (char)); diff --git a/libguile/sort.c b/libguile/sort.c index b5034b46d..154a9e2d3 100644 --- a/libguile/sort.c +++ b/libguile/sort.c @@ -424,23 +424,11 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0, size_t vlen, spos, len, size = sizeof (SCM); SCM *vp; - SCM_VALIDATE_NIM (1,vec); + SCM_VALIDATE_VECTOR (1,vec); SCM_VALIDATE_NIM (2,less); - switch (SCM_TYP7 (vec)) - { - case scm_tc7_vector: /* the only type we manage is vector */ - break; -#if 0 /* HAVE_ARRAYS */ - case scm_tc7_ivect: /* long */ - case scm_tc7_uvect: /* unsigned */ - case scm_tc7_fvect: /* float */ - case scm_tc7_dvect: /* double */ -#endif - default: - SCM_WTA (1,vec); - } + vp = SCM_VELTS (vec); /* vector pointer */ - vlen = SCM_LENGTH (vec); + vlen = SCM_VECTOR_LENGTH (vec); SCM_VALIDATE_INUM_COPY (3,startpos,spos); SCM_ASSERT_RANGE (3,startpos,(spos >= 0) && (spos <= vlen)); @@ -470,7 +458,6 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0, if (SCM_NULLP (items)) return SCM_BOOL_T; - SCM_VALIDATE_NIM (1,items); SCM_VALIDATE_NIM (2,less); if (SCM_CONSP (items)) @@ -498,36 +485,24 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0, } else { - switch (SCM_TYP7 (items)) + SCM_VALIDATE_VECTOR (1, items); + + vp = SCM_VELTS (items); /* vector pointer */ + len = SCM_VECTOR_LENGTH (items); + j = len - 1; + while (j > 0) { - case scm_tc7_vector: - { - vp = SCM_VELTS (items); /* vector pointer */ - len = SCM_LENGTH (items); - j = len - 1; - while (j > 0) - { - if ((*cmp) (less, &vp[1], vp)) - return SCM_BOOL_F; - else - { - vp++; - j--; - } - } - return SCM_BOOL_T; - } - break; -#if 0 /* HAVE_ARRAYS */ - case scm_tc7_ivect: /* long */ - case scm_tc7_uvect: /* unsigned */ - case scm_tc7_fvect: /* float */ - case scm_tc7_dvect: /* double */ -#endif - default: - SCM_WTA (1,items); + if ((*cmp) (less, &vp[1], vp)) + return SCM_BOOL_F; + else + { + vp++; + j--; + } } + return SCM_BOOL_T; } + return SCM_BOOL_F; } #undef FUNC_NAME @@ -724,7 +699,7 @@ SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0, long len; /* list/vector length */ if (SCM_NULLP(items)) return SCM_EOL; - SCM_VALIDATE_NIM (1,items); + SCM_VALIDATE_NIM (2,less); if (SCM_CONSP (items)) @@ -734,7 +709,7 @@ SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0, } else if (SCM_VECTORP (items)) { - len = SCM_LENGTH (items); + len = SCM_VECTOR_LENGTH (items); scm_restricted_vector_sort_x (items, less, SCM_MAKINUM (0L), @@ -757,7 +732,7 @@ SCM_DEFINE (scm_sort, "sort", 2, 0, 0, long len; /* list/vector length */ if (SCM_NULLP(items)) return SCM_EOL; - SCM_VALIDATE_NIM (1,items); + SCM_VALIDATE_NIM (2,less); if (SCM_CONSP (items)) { @@ -769,7 +744,7 @@ SCM_DEFINE (scm_sort, "sort", 2, 0, 0, /* support ordinary vectors even if arrays not available? */ else if (SCM_VECTORP (items)) { - len = SCM_LENGTH (items); + len = SCM_VECTOR_LENGTH (items); sortvec = scm_make_uve (len, scm_array_prototype (items)); scm_array_copy_x (items, sortvec); scm_restricted_vector_sort_x (sortvec, @@ -848,7 +823,7 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0, if (SCM_NULLP (items)) return SCM_EOL; - SCM_VALIDATE_NIM (1,items); + SCM_VALIDATE_NIM (2,less); if (SCM_CONSP (items)) { @@ -858,7 +833,7 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0, else if (SCM_VECTORP (items)) { SCM *temp, *vp; - len = SCM_LENGTH (items); + len = SCM_VECTOR_LENGTH (items); temp = malloc (len * sizeof(SCM)); vp = SCM_VELTS (items); scm_merge_vector_step (vp, @@ -885,7 +860,7 @@ SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0, long len; /* list/vector length */ if (SCM_NULLP (items)) return SCM_EOL; - SCM_VALIDATE_NIM (1,items); + SCM_VALIDATE_NIM (2,less); if (SCM_CONSP (items)) { @@ -899,7 +874,7 @@ SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0, { SCM retvec; SCM *temp, *vp; - len = SCM_LENGTH (items); + len = SCM_VECTOR_LENGTH (items); retvec = scm_make_uve (len, scm_array_prototype (items)); scm_array_copy_x (items, retvec); temp = malloc (len * sizeof (SCM)); diff --git a/libguile/unif.h b/libguile/unif.h index 4a9f5ede1..5fce7b467 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -89,6 +89,8 @@ extern long scm_tc16_array; #define SCM_UVECTOR_BASE(x) ((void *) (SCM_CELL_WORD_1 (x))) #define SCM_UVECTOR_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) +#define SCM_BITVECTOR_P(x) (!SCM_IMP (x) && (SCM_TYP7 (x) == scm_tc7_bvect)) +#define SCM_BITVECTOR_BASE(x) ((void *) (SCM_CELL_WORD_1 (x))) #define SCM_BITVECTOR_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) /* apparently it's possible to have more than SCM_LENGTH_MAX elements diff --git a/libguile/vectors.c b/libguile/vectors.c index eeca93439..728f48daa 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -147,7 +147,7 @@ scm_vector_length (SCM v) { SCM_GASSERT1 (SCM_VECTORP(v), g_vector_length, v, SCM_ARG1, s_vector_length); - return SCM_MAKINUM (SCM_LENGTH (v)); + return SCM_MAKINUM (SCM_VECTOR_LENGTH (v)); } SCM_REGISTER_PROC (s_list_to_vector, "list->vector", 1, 0, 0, scm_vector); @@ -212,7 +212,7 @@ scm_vector_ref (SCM v, SCM k) g_vector_ref, v, k, SCM_ARG1, s_vector_ref); SCM_GASSERT2 (SCM_INUMP (k), g_vector_ref, v, k, SCM_ARG2, s_vector_ref); - SCM_ASSERT_RANGE (2, k, SCM_INUM (k) < SCM_LENGTH (v) && SCM_INUM (k) >= 0); + SCM_ASSERT_RANGE (2, k, SCM_INUM (k) < SCM_VECTOR_LENGTH (v) && SCM_INUM (k) >= 0); return SCM_VELTS (v)[(long) SCM_INUM (k)]; } #undef FUNC_NAME @@ -248,7 +248,7 @@ scm_vector_set_x (SCM v, SCM k, SCM obj) SCM_GASSERTn (SCM_INUMP (k), g_vector_set_x, SCM_LIST3 (v, k, obj), SCM_ARG2, s_vector_set_x); - SCM_ASSERT_RANGE (2, k, SCM_INUM (k) < SCM_LENGTH (v) && SCM_INUM (k) >= 0); + SCM_ASSERT_RANGE (2, k, SCM_INUM (k) < SCM_VECTOR_LENGTH (v) && SCM_INUM (k) >= 0); SCM_VELTS(v)[(long) SCM_INUM(k)] = obj; return SCM_UNSPECIFIED; } @@ -302,7 +302,7 @@ SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0, SCM *data; SCM_VALIDATE_VECTOR (1,v); data = SCM_VELTS(v); - for(i = SCM_LENGTH(v)-1;i >= 0;i--) res = scm_cons(data[i], res); + for(i = SCM_VECTOR_LENGTH(v)-1;i >= 0;i--) res = scm_cons(data[i], res); return res; } #undef FUNC_NAME @@ -318,7 +318,7 @@ SCM_DEFINE (scm_vector_fill_x, "vector-fill!", 2, 0, 0, register SCM *data; SCM_VALIDATE_VECTOR (1,v); data = SCM_VELTS(v); - for(i = SCM_LENGTH(v) - 1; i >= 0; i--) + for(i = SCM_VECTOR_LENGTH(v) - 1; i >= 0; i--) data[i] = fill_x; return SCM_UNSPECIFIED; } @@ -329,7 +329,7 @@ SCM scm_vector_equal_p(SCM x, SCM y) { long i; - for(i = SCM_LENGTH(x)-1;i >= 0;i--) + for(i = SCM_VECTOR_LENGTH(x)-1;i >= 0;i--) if (SCM_FALSEP(scm_equal_p(SCM_VELTS(x)[i], SCM_VELTS(y)[i]))) return SCM_BOOL_F; return SCM_BOOL_T; @@ -350,10 +350,10 @@ SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0, SCM_VALIDATE_INUM_COPY (3,end1,e); SCM_VALIDATE_VECTOR (4,vec2); SCM_VALIDATE_INUM_COPY (5,start2,j); - SCM_ASSERT_RANGE (2, start1, i <= SCM_LENGTH (vec1) && i >= 0); - SCM_ASSERT_RANGE (5, start2, j <= SCM_LENGTH (vec2) && j >= 0); - SCM_ASSERT_RANGE (3, end1, e <= SCM_LENGTH (vec1) && e >= 0); - SCM_ASSERT_RANGE (5, start2, e-i+j <= SCM_LENGTH (vec2)); + SCM_ASSERT_RANGE (2, start1, i <= SCM_VECTOR_LENGTH (vec1) && i >= 0); + SCM_ASSERT_RANGE (5, start2, j <= SCM_VECTOR_LENGTH (vec2) && j >= 0); + SCM_ASSERT_RANGE (3, end1, e <= SCM_VECTOR_LENGTH (vec1) && e >= 0); + SCM_ASSERT_RANGE (5, start2, e-i+j <= SCM_VECTOR_LENGTH (vec2)); while (i= 0); - SCM_ASSERT_RANGE (5, start2, j <= SCM_LENGTH (vec2) && j >= 0); - SCM_ASSERT_RANGE (3, end1, e <= SCM_LENGTH (vec1) && e >= 0); + SCM_ASSERT_RANGE (2, start1, i <= SCM_VECTOR_LENGTH (vec1) && i >= 0); + SCM_ASSERT_RANGE (5, start2, j <= SCM_VECTOR_LENGTH (vec2) && j >= 0); + SCM_ASSERT_RANGE (3, end1, e <= SCM_VECTOR_LENGTH (vec1) && e >= 0); j = e - i + j; - SCM_ASSERT_RANGE (5, start2, j <= SCM_LENGTH (vec2)); + SCM_ASSERT_RANGE (5, start2, j <= SCM_VECTOR_LENGTH (vec2)); while (i < e) SCM_VELTS (vec2)[--j] = SCM_VELTS (vec1)[--e]; return SCM_UNSPECIFIED; From 74014c46fff6006236ac86f251162f3c670dae07 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 11 Oct 2000 12:24:43 +0000 Subject: [PATCH 0311/2047] * Replaced some calls to SCM_LENGTH. * Use scm_uniform_vector_length to determine lengths generically. * Eliminate some dummy type dispatch code. * Fix an array access but in scm_ra2contig. --- libguile/ChangeLog | 21 +++ libguile/unif.c | 387 +++++++++++++++++++++++---------------------- 2 files changed, 216 insertions(+), 192 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 76d09a6c2..cecb1a22e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,24 @@ +2000-10-11 Dirk Herrmann + + * unif.c (scm_make_uve, scm_uniform_vector_length, scm_array_p, + scm_transpose_array, scm_array_contents, scm_ra2contig, + scm_uniform_array_read_x, scm_uniform_array_write, scm_bit_count, + scm_bit_position, scm_bit_set_star_x, scm_bit_count_star, + scm_bit_invert_x, scm_array_to_list, scm_raprin1): Replace + SCM_LENGTH with the appropriate SCM__LENGTH macro. + + (scm_array_dimensions, scm_make_shared_array, scm_enclose_array, + scm_array_in_bounds_p, scm_uniform_vector_ref, scm_array_set_x, + scm_array_contents, scm_uniform_array_read_x, + scm_uniform_array_write, scm_list_to_uniform_array, rapr1): Use + scm_uniform_vector_length to determine the length of a vector + object generically. + + (scm_bit_count, scm_bit_set_star_x, scm_bit_count_star, + scm_bit_invert_x): Eliminated dummy type dispatch. + + (scm_ra2contig): Fixed array vector access. + 2000-10-10 Dirk Herrmann * unif.h (SCM_BITVECTOR_P, SCM_BITVECTOR_BASE): Added. diff --git a/libguile/unif.c b/libguile/unif.c index 738270aa6..444bec62c 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -179,7 +179,7 @@ scm_make_uve (long k, SCM prot) else type = scm_tc7_ivect; } - else if (SCM_SYMBOLP (prot) && (1 == SCM_LENGTH (prot))) + else if (SCM_SYMBOLP (prot) && (1 == SCM_SYMBOL_LENGTH (prot))) { char s; @@ -236,26 +236,28 @@ SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0, #define FUNC_NAME s_scm_uniform_vector_length { SCM_ASRTGO (SCM_NIMP (v), badarg1); - switch SCM_TYP7 - (v) + switch SCM_TYP7 (v) { default: badarg1:SCM_WTA(1,v); - case scm_tc7_bvect: + case scm_tc7_vector: + case scm_tc7_wvect: + return SCM_MAKINUM (SCM_VECTOR_LENGTH (v)); case scm_tc7_string: + return SCM_MAKINUM (SCM_STRING_LENGTH (v)); + case scm_tc7_bvect: + return SCM_MAKINUM (SCM_BITVECTOR_LENGTH (v)); case scm_tc7_byvect: case scm_tc7_uvect: case scm_tc7_ivect: case scm_tc7_fvect: case scm_tc7_dvect: case scm_tc7_cvect: - case scm_tc7_vector: - case scm_tc7_wvect: case scm_tc7_svect: #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: #endif - return SCM_MAKINUM (SCM_LENGTH (v)); + return SCM_MAKINUM (SCM_UVECTOR_LENGTH (v)); } } #undef FUNC_NAME @@ -305,12 +307,12 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, case scm_tc7_svect: protp = SCM_SYMBOLP (prot) - && (1 == SCM_LENGTH (prot)) + && (1 == SCM_SYMBOL_LENGTH (prot)) && ('s' == SCM_SYMBOL_CHARS (prot)[0]); #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: protp = SCM_SYMBOLP (prot) - && (1 == SCM_LENGTH (prot)) + && (1 == SCM_SYMBOL_LENGTH (prot)) && ('s' == SCM_SYMBOL_CHARS (prot)[0]); #endif case scm_tc7_fvect: @@ -399,7 +401,7 @@ SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0, #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: #endif - return scm_cons (SCM_MAKINUM (SCM_LENGTH (ra)), SCM_EOL); + return scm_cons (scm_uniform_vector_length (ra), SCM_EOL); case scm_tc7_smob: if (!SCM_ARRAYP (ra)) return SCM_BOOL_F; @@ -706,7 +708,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, { SCM_ARRAY_V (ra) = oldra; old_min = 0; - old_max = (long) SCM_LENGTH (oldra) - 1; + old_max = SCM_INUM (scm_uniform_vector_length (oldra)) - 1; } inds = SCM_EOL; s = SCM_ARRAY_DIMS (ra); @@ -773,9 +775,10 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, "mapping out of range", FUNC_NAME); if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra)) { - if (1 == s->inc && 0 == s->lbnd - && SCM_LENGTH (SCM_ARRAY_V (ra)) == 1 + s->ubnd) - return SCM_ARRAY_V (ra); + SCM v = SCM_ARRAY_V (ra); + unsigned long int length = SCM_INUM (scm_uniform_vector_length (v)); + if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd) + return v; if (s->ubnd < s->lbnd) return scm_make_uve (0L, scm_array_prototype (ra)); } @@ -838,7 +841,7 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, case scm_tc7_smob: SCM_ASRTGO (SCM_ARRAYP (ra), badarg); vargs = scm_vector (args); - SCM_ASSERT (SCM_LENGTH (vargs) == SCM_ARRAY_NDIM (ra), + SCM_ASSERT (SCM_VECTOR_LENGTH (vargs) == SCM_ARRAY_NDIM (ra), scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); ve = SCM_VELTS (vargs); ndim = 0; @@ -925,8 +928,7 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, SCM_ASSERT (0 <= ninr, scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); ra_inr = scm_make_ra (ninr); SCM_ASRTGO (SCM_NIMP (ra), badarg1); - switch SCM_TYP7 - (ra) + switch SCM_TYP7 (ra) { default: badarg1:SCM_WTA (1,ra); @@ -945,7 +947,7 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, case scm_tc7_llvect: #endif s->lbnd = 0; - s->ubnd = SCM_LENGTH (ra) - 1; + s->ubnd = SCM_INUM (scm_uniform_vector_length (ra)) - 1; s->inc = 1; SCM_ARRAY_V (ra_inr) = ra; SCM_ARRAY_BASE (ra_inr) = 0; @@ -1011,8 +1013,7 @@ SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1, pos = SCM_INUM (ind); } tail: - switch SCM_TYP7 - (v) + switch SCM_TYP7 (v) { default: badarg1:SCM_WTA (1,v); @@ -1060,8 +1061,11 @@ tail: #endif case scm_tc7_vector: case scm_tc7_wvect: - SCM_ASRTGO (SCM_NULLP (args) && SCM_INUMP (ind), wna); - return SCM_BOOL(pos >= 0 && pos < SCM_LENGTH (v)); + { + unsigned long int length = SCM_INUM (scm_uniform_vector_length (v)); + SCM_ASRTGO (SCM_NULLP (args) && SCM_INUMP (ind), wna); + return SCM_BOOL(pos >= 0 && pos < length); + } } } #undef FUNC_NAME @@ -1090,8 +1094,8 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, } else { + unsigned long int length; if (SCM_NIMP (args)) - { SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, FUNC_NAME); pos = SCM_INUM (SCM_CAR (args)); @@ -1102,10 +1106,10 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, SCM_VALIDATE_INUM (2,args); pos = SCM_INUM (args); } - SCM_ASRTGO (pos >= 0 && pos < SCM_LENGTH (v), outrng); + length = SCM_INUM (scm_uniform_vector_length (v)); + SCM_ASRTGO (pos >= 0 && pos < length, outrng); } - switch SCM_TYP7 - (v) + switch SCM_TYP7 (v) { default: if (SCM_NULLP (args)) @@ -1260,6 +1264,7 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, } else { + unsigned long int length; if (SCM_NIMP (args)) { SCM_ASSERT (SCM_CONSP(args) && SCM_INUMP (SCM_CAR (args)), args, @@ -1271,7 +1276,8 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, { SCM_VALIDATE_INUM_COPY (3,args,pos); } - SCM_ASRTGO (pos >= 0 && pos < SCM_LENGTH (v), outrng); + length = SCM_INUM (scm_uniform_vector_length (v)); + SCM_ASRTGO (pos >= 0 && pos < length, outrng); } switch (SCM_TYP7 (v)) { @@ -1397,14 +1403,20 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, return SCM_BOOL_F; if (scm_tc7_bvect == SCM_TYP7 (SCM_ARRAY_V (ra))) { - if (len != SCM_LENGTH (SCM_ARRAY_V (ra)) || + if (len != SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra)) || SCM_ARRAY_BASE (ra) % SCM_LONG_BIT || len % SCM_LONG_BIT) return SCM_BOOL_F; } } - if ((len == SCM_LENGTH (SCM_ARRAY_V (ra))) && 0 == SCM_ARRAY_BASE (ra) && SCM_ARRAY_DIMS (ra)->inc) - return SCM_ARRAY_V (ra); + + { + SCM v = SCM_ARRAY_V (ra); + unsigned long int length = SCM_INUM (scm_uniform_vector_length (v)); + if ((len == length) && 0 == SCM_ARRAY_BASE (ra) && SCM_ARRAY_DIMS (ra)->inc) + return v; + } + sra = scm_make_ra (1); SCM_ARRAY_DIMS (sra)->lbnd = 0; SCM_ARRAY_DIMS (sra)->ubnd = len - 1; @@ -1429,9 +1441,9 @@ scm_ra2contig (SCM ra, int copy) k = SCM_ARRAY_NDIM (ra); if (SCM_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_ARRAY_DIMS (ra)[k - 1].inc))) { - if (scm_tc7_bvect != SCM_TYP7 (ra)) + if (scm_tc7_bvect != SCM_TYP7 (SCM_ARRAY_V (ra))) return ra; - if ((len == SCM_LENGTH (SCM_ARRAY_V (ra)) && + if ((len == SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra)) && 0 == SCM_ARRAY_BASE (ra) % SCM_LONG_BIT && 0 == len % SCM_LONG_BIT)) return ra; @@ -1484,7 +1496,7 @@ SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0, SCM_ASSERT (SCM_INUMP (port_or_fd) || (SCM_OPINPORTP (port_or_fd)), port_or_fd, SCM_ARG2, FUNC_NAME); - vlen = SCM_LENGTH (v); + vlen = SCM_INUM (scm_uniform_vector_length (v)); loop: switch SCM_TYP7 (v) @@ -1500,40 +1512,48 @@ loop: v = SCM_ARRAY_V (cra); goto loop; case scm_tc7_string: - case scm_tc7_byvect: + base = SCM_STRING_CHARS (v); sz = sizeof (char); break; case scm_tc7_bvect: + base = (char *) SCM_BITVECTOR_BASE (v); vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT; cstart /= SCM_LONG_BIT; + sz = sizeof (long); + break; + case scm_tc7_byvect: + base = (char *) SCM_UVECTOR_BASE (v); + sz = sizeof (char); + break; case scm_tc7_uvect: case scm_tc7_ivect: + base = (char *) SCM_UVECTOR_BASE (v); sz = sizeof (long); break; case scm_tc7_svect: + base = (char *) SCM_UVECTOR_BASE (v); sz = sizeof (short); break; #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: + base = (char *) SCM_UVECTOR_BASE (v); sz = sizeof (long_long); break; #endif case scm_tc7_fvect: + base = (char *) SCM_UVECTOR_BASE (v); sz = sizeof (float); break; case scm_tc7_dvect: + base = (char *) SCM_UVECTOR_BASE (v); sz = sizeof (double); break; case scm_tc7_cvect: + base = (char *) SCM_UVECTOR_BASE (v); sz = 2 * sizeof (double); break; } - if (SCM_STRINGP (v)) - base = SCM_STRING_CHARS (v); - else - base = (char *) SCM_UVECTOR_BASE (v); - cend = vlen; if (!SCM_UNBNDP (start)) { @@ -1640,7 +1660,7 @@ SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0, SCM_ASSERT (SCM_INUMP (port_or_fd) || (SCM_OPOUTPORTP (port_or_fd)), port_or_fd, SCM_ARG2, FUNC_NAME); - vlen = SCM_LENGTH (v); + vlen = SCM_INUM (scm_uniform_vector_length (v)); loop: switch SCM_TYP7 (v) @@ -1656,40 +1676,48 @@ loop: v = SCM_ARRAY_V (v); goto loop; case scm_tc7_string: - case scm_tc7_byvect: + base = SCM_STRING_CHARS (v); sz = sizeof (char); break; case scm_tc7_bvect: + base = (char *) SCM_BITVECTOR_BASE (v); vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT; cstart /= SCM_LONG_BIT; + sz = sizeof (long); + break; + case scm_tc7_byvect: + base = (char *) SCM_UVECTOR_BASE (v); + sz = sizeof (char); + break; case scm_tc7_uvect: case scm_tc7_ivect: + base = (char *) SCM_UVECTOR_BASE (v); sz = sizeof (long); break; case scm_tc7_svect: + base = (char *) SCM_UVECTOR_BASE (v); sz = sizeof (short); break; #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: + base = (char *) SCM_UVECTOR_BASE (v); sz = sizeof (long_long); break; #endif case scm_tc7_fvect: + base = (char *) SCM_UVECTOR_BASE (v); sz = sizeof (float); break; case scm_tc7_dvect: + base = (char *) SCM_UVECTOR_BASE (v); sz = sizeof (double); break; case scm_tc7_cvect: + base = (char *) SCM_UVECTOR_BASE (v); sz = 2 * sizeof (double); break; } - if (SCM_STRINGP (v)) - base = SCM_STRING_CHARS (v); - else - base = (char *) SCM_UVECTOR_BASE (v); - cend = vlen; if (!SCM_UNBNDP (start)) { @@ -1742,18 +1770,17 @@ SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0, #define FUNC_NAME s_scm_bit_count { SCM_VALIDATE_BOOL (1, b); - SCM_ASSERT (!SCM_IMP (bitvector) && SCM_TYP7 (bitvector) == scm_tc7_bvect, - bitvector, 2, FUNC_NAME); - if (SCM_LENGTH (bitvector) == 0) { + SCM_ASSERT (SCM_BITVECTOR_P (bitvector), bitvector, 2, FUNC_NAME); + if (SCM_BITVECTOR_LENGTH (bitvector) == 0) { return SCM_INUM0; } else { unsigned long int count = 0; - unsigned long int i = (SCM_LENGTH (bitvector) - 1) / SCM_LONG_BIT; + unsigned long int i = (SCM_BITVECTOR_LENGTH (bitvector) - 1) / SCM_LONG_BIT; unsigned long int w = SCM_UNPACK (SCM_VELTS (bitvector)[i]); if (SCM_FALSEP (b)) { w = ~w; }; - w <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (bitvector) - 1) % SCM_LONG_BIT); + w <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (bitvector) - 1) % SCM_LONG_BIT); while (1) { while (w) { count += cnt_tab[w & 0x0f]; @@ -1783,60 +1810,56 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, { long i, lenw, xbits, pos; register unsigned long w; - SCM_VALIDATE_NIM (2,v); + + SCM_VALIDATE_BOOL (1, item); + SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG2, FUNC_NAME); SCM_VALIDATE_INUM_COPY (3,k,pos); - SCM_ASSERT_RANGE (3, k, (pos <= SCM_LENGTH (v)) && (pos >= 0)); - if (pos == SCM_LENGTH (v)) + SCM_ASSERT_RANGE (3, k, (pos <= SCM_BITVECTOR_LENGTH (v)) && (pos >= 0)); + + if (pos == SCM_BITVECTOR_LENGTH (v)) return SCM_BOOL_F; - switch SCM_TYP7 (v) + + lenw = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; /* watch for part words */ + i = pos / SCM_LONG_BIT; + w = SCM_UNPACK (SCM_VELTS (v)[i]); + if (SCM_FALSEP (item)) + w = ~w; + xbits = (pos % SCM_LONG_BIT); + pos -= xbits; + w = ((w >> xbits) << xbits); + xbits = SCM_LONG_BIT - 1 - (SCM_BITVECTOR_LENGTH (v) - 1) % SCM_LONG_BIT; + while (!0) { - default: - SCM_WTA (2,v); - case scm_tc7_bvect: - if (0 == SCM_LENGTH (v)) - return SCM_MAKINUM (-1L); - lenw = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; /* watch for part words */ - i = pos / SCM_LONG_BIT; + if (w && (i == lenw)) + w = ((w << xbits) >> xbits); + if (w) + while (w) + switch (w & 0x0f) + { + default: + return SCM_MAKINUM (pos); + case 2: + case 6: + case 10: + case 14: + return SCM_MAKINUM (pos + 1); + case 4: + case 12: + return SCM_MAKINUM (pos + 2); + case 8: + return SCM_MAKINUM (pos + 3); + case 0: + pos += 4; + w >>= 4; + } + if (++i > lenw) + break; + pos += SCM_LONG_BIT; w = SCM_UNPACK (SCM_VELTS (v)[i]); if (SCM_FALSEP (item)) w = ~w; - xbits = (pos % SCM_LONG_BIT); - pos -= xbits; - w = ((w >> xbits) << xbits); - xbits = SCM_LONG_BIT - 1 - (SCM_LENGTH (v) - 1) % SCM_LONG_BIT; - while (!0) - { - if (w && (i == lenw)) - w = ((w << xbits) >> xbits); - if (w) - while (w) - switch (w & 0x0f) - { - default: - return SCM_MAKINUM (pos); - case 2: - case 6: - case 10: - case 14: - return SCM_MAKINUM (pos + 1); - case 4: - case 12: - return SCM_MAKINUM (pos + 2); - case 8: - return SCM_MAKINUM (pos + 3); - case 0: - pos += 4; - w >>= 4; - } - if (++i > lenw) - break; - pos += SCM_LONG_BIT; - w = SCM_UNPACK (SCM_VELTS (v)[i]); - if (SCM_FALSEP (item)) - w = ~w; - } - return SCM_BOOL_F; } + return SCM_BOOL_F; } #undef FUNC_NAME @@ -1853,46 +1876,40 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, #define FUNC_NAME s_scm_bit_set_star_x { register long i, k, vlen; - SCM_ASRTGO (SCM_NIMP (v), badarg1); + SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME); SCM_ASRTGO (SCM_NIMP (kv), badarg2); switch SCM_TYP7 (kv) { default: badarg2:SCM_WTA (2,kv); case scm_tc7_uvect: - switch SCM_TYP7 (v) - { - default: - badarg1: SCM_WTA (1,v); - case scm_tc7_bvect: - vlen = SCM_LENGTH (v); - if (SCM_FALSEP (obj)) - for (i = SCM_LENGTH (kv); i;) - { - k = SCM_UNPACK (SCM_VELTS (kv)[--i]); - if (k >= vlen) - scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k)); - SCM_BITVEC_CLR(v,k); - } - else if (SCM_EQ_P (obj, SCM_BOOL_T)) - for (i = SCM_LENGTH (kv); i;) - { - k = SCM_UNPACK (SCM_VELTS (kv)[--i]); - if (k >= vlen) - scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k)); - SCM_BITVEC_SET(v,k); - } - else - badarg3:SCM_WTA (3,obj); - } + vlen = SCM_BITVECTOR_LENGTH (v); + if (SCM_FALSEP (obj)) + for (i = SCM_UVECTOR_LENGTH (kv); i;) + { + k = SCM_UNPACK (SCM_VELTS (kv)[--i]); + if (k >= vlen) + scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k)); + SCM_BITVEC_CLR(v,k); + } + else if (SCM_EQ_P (obj, SCM_BOOL_T)) + for (i = SCM_UVECTOR_LENGTH (kv); i;) + { + k = SCM_UNPACK (SCM_VELTS (kv)[--i]); + if (k >= vlen) + scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k)); + SCM_BITVEC_SET(v,k); + } + else + badarg3:SCM_WTA (3,obj); break; case scm_tc7_bvect: - SCM_ASRTGO (SCM_TYP7 (v) == scm_tc7_bvect && SCM_LENGTH (v) == SCM_LENGTH (kv), badarg1); + SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME); if (SCM_FALSEP (obj)) - for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) + for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) SCM_UNPACK (SCM_VELTS (v)[k]) &= ~ SCM_UNPACK(SCM_VELTS (kv)[k]); else if (SCM_EQ_P (obj, SCM_BOOL_T)) - for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) + for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) SCM_UNPACK (SCM_VELTS (v)[k]) |= SCM_UNPACK (SCM_VELTS (kv)[k]); else goto badarg3; @@ -1916,7 +1933,7 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, register unsigned long k; int fObj = 0; - SCM_ASRTGO (SCM_NIMP (v), badarg1); + SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME); SCM_ASRTGO (SCM_NIMP (kv), badarg2); switch SCM_TYP7 (kv) { @@ -1924,45 +1941,37 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, badarg2: SCM_WTA (2,kv); case scm_tc7_uvect: - switch SCM_TYP7 - (v) - { - default: - badarg1: - SCM_WTA (1,v); - case scm_tc7_bvect: - vlen = SCM_LENGTH (v); - if (SCM_FALSEP (obj)) - for (i = SCM_LENGTH (kv); i;) - { - k = SCM_UNPACK (SCM_VELTS (kv)[--i]); - if (k >= vlen) - scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k)); - if (!SCM_BITVEC_REF(v,k)) - count++; - } - else if (SCM_EQ_P (obj, SCM_BOOL_T)) - for (i = SCM_LENGTH (kv); i;) - { - k = SCM_UNPACK (SCM_VELTS (kv)[--i]); - if (k >= vlen) - scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k)); - if (SCM_BITVEC_REF (v,k)) - count++; - } - else - badarg3:SCM_WTA (3,obj); - } + vlen = SCM_BITVECTOR_LENGTH (v); + if (SCM_FALSEP (obj)) + for (i = SCM_UVECTOR_LENGTH (kv); i;) + { + k = SCM_UNPACK (SCM_VELTS (kv)[--i]); + if (k >= vlen) + scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k)); + if (!SCM_BITVEC_REF(v,k)) + count++; + } + else if (SCM_EQ_P (obj, SCM_BOOL_T)) + for (i = SCM_UVECTOR_LENGTH (kv); i;) + { + k = SCM_UNPACK (SCM_VELTS (kv)[--i]); + if (k >= vlen) + scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k)); + if (SCM_BITVEC_REF (v,k)) + count++; + } + else + badarg3:SCM_WTA (3,obj); break; case scm_tc7_bvect: - SCM_ASRTGO (SCM_TYP7 (v) == scm_tc7_bvect && SCM_LENGTH (v) == SCM_LENGTH (kv), badarg1); - if (0 == SCM_LENGTH (v)) + SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME); + if (0 == SCM_BITVECTOR_LENGTH (v)) return SCM_INUM0; SCM_ASRTGO (SCM_BOOLP (obj), badarg3); fObj = SCM_EQ_P (obj, SCM_BOOL_T); - i = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; + i = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; k = SCM_UNPACK (SCM_VELTS (kv)[i]) & (fObj ? SCM_UNPACK (SCM_VELTS (v)[i]) : ~ SCM_UNPACK (SCM_VELTS (v)[i])); - k <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (v) - 1) % SCM_LONG_BIT); + k <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (v) - 1) % SCM_LONG_BIT); while (1) { for (; k; k >>= 4) @@ -1984,19 +1993,14 @@ SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0, "Modifies @var{bv} by replacing each element with its negation.") #define FUNC_NAME s_scm_bit_invert_x { - register long k; - SCM_ASRTGO (SCM_NIMP (v), badarg1); - k = SCM_LENGTH (v); - switch SCM_TYP7 - (v) - { - case scm_tc7_bvect: - for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) - SCM_UNPACK (SCM_VELTS (v)[k]) = ~SCM_UNPACK(SCM_VELTS (v)[k]); - break; - default: - badarg1:SCM_WTA (1,v); - } + long int k; + + SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME); + + k = SCM_BITVECTOR_LENGTH (v); + for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) + SCM_UNPACK (SCM_VELTS (v)[k]) = ~SCM_UNPACK (SCM_VELTS (v)[k]); + return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -2070,8 +2074,7 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, SCM res = SCM_EOL; register long k; SCM_ASRTGO (SCM_NIMP (v), badarg1); - switch SCM_TYP7 - (v) + switch SCM_TYP7 (v) { default: badarg1:SCM_WTA (1,v); @@ -2087,29 +2090,29 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, { long *data = (long *) SCM_VELTS (v); register unsigned long mask; - for (k = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; k > 0; k--) + for (k = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; k > 0; k--) for (mask = 1UL << (SCM_LONG_BIT - 1); mask; mask >>= 1) res = scm_cons (SCM_BOOL(((long *) data)[k] & mask), res); - for (mask = 1L << ((SCM_LENGTH (v) % SCM_LONG_BIT) - 1); mask; mask >>= 1) + for (mask = 1L << ((SCM_BITVECTOR_LENGTH (v) % SCM_LONG_BIT) - 1); mask; mask >>= 1) res = scm_cons (SCM_BOOL(((long *) data)[k] & mask), res); return res; } case scm_tc7_uvect: { long *data = (long *)SCM_VELTS(v); - for (k = SCM_LENGTH(v) - 1; k >= 0; k--) + for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--) res = scm_cons(scm_ulong2num(data[k]), res); return res; } case scm_tc7_ivect: { long *data = (long *)SCM_VELTS(v); - for (k = SCM_LENGTH(v) - 1; k >= 0; k--) + for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--) res = scm_cons(scm_long2num(data[k]), res); return res; } case scm_tc7_svect: { short *data; data = (short *)SCM_VELTS(v); - for (k = SCM_LENGTH(v) - 1; k >= 0; k--) + for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--) res = scm_cons(SCM_MAKINUM (data[k]), res); return res; } @@ -2117,7 +2120,7 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, case scm_tc7_llvect: { long_long *data; data = (long_long *)SCM_VELTS(v); - for (k = SCM_LENGTH(v) - 1; k >= 0; k--) + for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--) res = scm_cons(scm_long_long2num(data[k]), res); return res; } @@ -2127,21 +2130,21 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, case scm_tc7_fvect: { float *data = (float *) SCM_VELTS (v); - for (k = SCM_LENGTH (v) - 1; k >= 0; k--) + for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--) res = scm_cons (scm_make_real (data[k]), res); return res; } case scm_tc7_dvect: { double *data = (double *) SCM_VELTS (v); - for (k = SCM_LENGTH (v) - 1; k >= 0; k--) + for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--) res = scm_cons (scm_make_real (data[k]), res); return res; } case scm_tc7_cvect: { double (*data)[2] = (double (*)[2]) SCM_VELTS (v); - for (k = SCM_LENGTH (v) - 1; k >= 0; k--) + for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--) res = scm_cons (scm_make_complex (data[k][0], data[k][1]), res); return res; } @@ -2187,7 +2190,8 @@ SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, } if (!SCM_ARRAYP (ra)) { - for (k = 0; k < SCM_LENGTH (ra); k++, lst = SCM_CDR (lst)) + unsigned long int length = SCM_INUM (scm_uniform_vector_length (ra)); + for (k = 0; k < length; k++, lst = SCM_CDR (lst)) scm_array_set_x (ra, SCM_CAR (lst), SCM_MAKINUM (k)); return ra; } @@ -2241,7 +2245,7 @@ static void rapr1 (SCM ra,scm_sizet j,scm_sizet k,SCM port,scm_print_state *pstate) { long inc = 1; - long n = SCM_LENGTH (ra); + long n = SCM_INUM (scm_uniform_vector_length (ra)); int enclosed = 0; tail: switch SCM_TYP7 (ra) @@ -2445,7 +2449,7 @@ tail: { /* a uve, not an scm_array */ register long i, j, w; scm_putc ('*', port); - for (i = 0; i < (SCM_LENGTH (exp)) / SCM_LONG_BIT; i++) + for (i = 0; i < (SCM_BITVECTOR_LENGTH (exp)) / SCM_LONG_BIT; i++) { scm_bits_t w = SCM_UNPACK (SCM_VELTS (exp)[i]); for (j = SCM_LONG_BIT; j; j--) @@ -2454,10 +2458,10 @@ tail: w >>= 1; } } - j = SCM_LENGTH (exp) % SCM_LONG_BIT; + j = SCM_BITVECTOR_LENGTH (exp) % SCM_LONG_BIT; if (j) { - w = SCM_UNPACK (SCM_VELTS (exp)[SCM_LENGTH (exp) / SCM_LONG_BIT]); + w = SCM_UNPACK (SCM_VELTS (exp)[SCM_BITVECTOR_LENGTH (exp) / SCM_LONG_BIT]); for (; j; j--) { scm_putc (w & 1 ? '1' : '0', port); @@ -2515,8 +2519,7 @@ SCM_DEFINE (scm_array_prototype, "array-prototype", 1, 0, 0, int enclosed = 0; SCM_ASRTGO (SCM_NIMP (ra), badarg); loop: - switch SCM_TYP7 - (ra) + switch SCM_TYP7 (ra) { default: badarg:SCM_WTA (1,ra); From b226e5f658a02a8d82b2410e11411ac49b0b0caf Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 11 Oct 2000 12:50:53 +0000 Subject: [PATCH 0312/2047] * Replace some SCM_LENGTH macros. --- libguile/ChangeLog | 9 ++++++ libguile/ramap.c | 78 ++++++++++++++++++++++++++-------------------- 2 files changed, 54 insertions(+), 33 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index cecb1a22e..731c6da58 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2000-10-11 Dirk Herrmann + + * ramap.c (scm_array_fill_int, scm_array_index_map_x): Replace + SCM_LENGTH with the appropriate SCM__LENGTH macro. + + (scm_ra_matchp, scm_ramapc, ramap, rafe, scm_array_index_map_x, + raeql_1, raeql): Use scm_uniform_vector_length to determine the + length of a vector object generically. + 2000-10-11 Dirk Herrmann * unif.c (scm_make_uve, scm_uniform_vector_length, scm_array_p, diff --git a/libguile/ramap.c b/libguile/ramap.c index 6631d8fc9..6aa7efbfd 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -221,7 +221,7 @@ scm_ra_matchp (SCM ra0, SCM ras) case scm_tc7_cvect: s0->lbnd = 0; s0->inc = 1; - s0->ubnd = (long) SCM_LENGTH (ra0) - 1; + s0->ubnd = SCM_INUM (scm_uniform_vector_length (ra0)) - 1; break; case scm_tc7_smob: if (!SCM_ARRAYP (ra0)) @@ -255,25 +255,32 @@ scm_ra_matchp (SCM ra0, SCM ras) case scm_tc7_fvect: case scm_tc7_dvect: case scm_tc7_cvect: - if (1 != ndim) - return 0; - switch (exact) - { - case 4: - if (0 != bas0) - exact = 3; - case 3: - if (1 != s0->inc) - exact = 2; - case 2: - if ((0 == s0->lbnd) && (s0->ubnd == SCM_LENGTH (ra1) - 1)) - break; - exact = 1; - case 1: - if (s0->lbnd < 0 || s0->ubnd >= SCM_LENGTH (ra1)) - return 0; - } - break; + { + unsigned long int length; + + if (1 != ndim) + return 0; + + length = SCM_INUM (scm_uniform_vector_length (ra1)); + + switch (exact) + { + case 4: + if (0 != bas0) + exact = 3; + case 3: + if (1 != s0->inc) + exact = 2; + case 2: + if ((0 == s0->lbnd) && (s0->ubnd == length - 1)) + break; + exact = 1; + case 1: + if (s0->lbnd < 0 || s0->ubnd >= length) + return 0; + } + break; + } case scm_tc7_smob: if (!SCM_ARRAYP (ra1) || ndim != SCM_ARRAY_NDIM (ra1)) return 0; @@ -333,10 +340,11 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) if (SCM_IMP (vra0)) goto gencase; if (!SCM_ARRAYP (vra0)) { + unsigned long int length = SCM_INUM (scm_uniform_vector_length (vra0)); vra1 = scm_make_ra (1); SCM_ARRAY_BASE (vra1) = 0; SCM_ARRAY_DIMS (vra1)->lbnd = 0; - SCM_ARRAY_DIMS (vra1)->ubnd = SCM_LENGTH (vra0) - 1; + SCM_ARRAY_DIMS (vra1)->ubnd = length - 1; SCM_ARRAY_DIMS (vra1)->inc = 1; SCM_ARRAY_V (vra1) = vra0; vra0 = vra1; @@ -390,9 +398,10 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) } else { + unsigned long int length = SCM_INUM (scm_uniform_vector_length (ra0)); kmax = 0; SCM_ARRAY_DIMS (vra0)->lbnd = 0; - SCM_ARRAY_DIMS (vra0)->ubnd = SCM_LENGTH (ra0) - 1; + SCM_ARRAY_DIMS (vra0)->ubnd = length - 1; SCM_ARRAY_DIMS (vra0)->inc = 1; SCM_ARRAY_BASE (vra0) = 0; SCM_ARRAY_V (vra0) = ra0; @@ -504,7 +513,7 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore) case scm_tc7_bvect: { /* scope */ long *ve = (long *) SCM_VELTS (ra); - if (1 == inc && (n >= SCM_LONG_BIT || n == SCM_LENGTH (ra))) + if (1 == inc && (n >= SCM_LONG_BIT || n == SCM_BITVECTOR_LENGTH (ra))) { i = base / SCM_LONG_BIT; if (SCM_FALSEP (fill)) @@ -1247,7 +1256,7 @@ ramap (SCM ra0,SCM proc,SCM ras) for (; i <= n; i++, i1 += inc1) { args = SCM_EOL; - for (k = SCM_LENGTH (ras); k--;) + for (k = SCM_INUM (scm_uniform_vector_length (ras)); k--;) args = scm_cons (scm_uniform_vector_ref (ve[k], SCM_MAKINUM (i)), args); args = scm_cons (scm_cvref (ra1, i1, SCM_UNDEFINED), args); scm_array_set_x (ra0, scm_apply (proc, args, SCM_EOL), SCM_MAKINUM (i * inc + base)); @@ -1641,7 +1650,7 @@ rafe (SCM ra0,SCM proc,SCM ras) for (; i <= n; i++, i0 += inc0, i1 += inc1) { args = SCM_EOL; - for (k = SCM_LENGTH (ras); k--;) + for (k = SCM_INUM (scm_uniform_vector_length (ras)); k--;) args = scm_cons (scm_uniform_vector_ref (ve[k], SCM_MAKINUM (i)), args); args = scm_cons2 (scm_cvref (ra0, i0, SCM_UNDEFINED), scm_cvref (ra1, i1, SCM_UNDEFINED), args); scm_apply (proc, args, SCM_EOL); @@ -1696,7 +1705,7 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0, case scm_tc7_wvect: { SCM *ve = SCM_VELTS (ra); - for (i = 0; i < SCM_LENGTH (ra); i++) + for (i = 0; i < SCM_VECTOR_LENGTH (ra); i++) ve[i] = scm_apply (proc, SCM_MAKINUM (i), scm_listofnull); return SCM_UNSPECIFIED; } @@ -1712,10 +1721,13 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0, case scm_tc7_fvect: case scm_tc7_dvect: case scm_tc7_cvect: - for (i = 0; i < SCM_LENGTH (ra); i++) - scm_array_set_x (ra, scm_apply (proc, SCM_MAKINUM (i), scm_listofnull), - SCM_MAKINUM (i)); - return SCM_UNSPECIFIED; + { + unsigned long int length = SCM_INUM (scm_uniform_vector_length (ra)); + for (i = 0; i < length; i++) + scm_array_set_x (ra, scm_apply (proc, SCM_MAKINUM (i), scm_listofnull), + SCM_MAKINUM (i)); + return SCM_UNSPECIFIED; + } case scm_tc7_smob: SCM_ASRTGO (SCM_ARRAYP (ra), badarg); { @@ -1770,7 +1782,7 @@ raeql_1 (SCM ra0,SCM as_equal,SCM ra1) SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; scm_sizet i0 = 0, i1 = 0; long inc0 = 1, inc1 = 1; - scm_sizet n = SCM_LENGTH (ra0); + scm_sizet n = SCM_INUM (scm_uniform_vector_length (ra0)); ra1 = SCM_CAR (ra1); if (SCM_ARRAYP(ra0)) { @@ -1909,7 +1921,7 @@ raeql (SCM ra0,SCM as_equal,SCM ra1) { s0->inc = 1; s0->lbnd = 0; - s0->ubnd = SCM_LENGTH (v0) - 1; + s0->ubnd = SCM_INUM (scm_uniform_vector_length (v0)) - 1; unroll = 0; } if (SCM_ARRAYP (ra1)) @@ -1929,7 +1941,7 @@ raeql (SCM ra0,SCM as_equal,SCM ra1) return 0; s1->inc = 1; s1->lbnd = 0; - s1->ubnd = SCM_LENGTH (v1) - 1; + s1->ubnd = SCM_INUM (scm_uniform_vector_length (v1)) - 1; unroll = 0; } if (SCM_TYP7 (v0) != SCM_TYP7 (v1)) From b7ead2aee2a34a071d34fe2a822b3bd6eddedd3c Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 11 Oct 2000 14:12:26 +0000 Subject: [PATCH 0313/2047] * Replace calls to SCM_LENGTH. --- libguile/ChangeLog | 9 +++++++++ libguile/random.c | 10 +++++----- 2 files changed, 14 insertions(+), 5 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 731c6da58..e0ee5922f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2000-10-11 Dirk Herrmann + + * random.c (scm_seed_to_random_state): Replace SCM_LENGTH with + the appropriate SCM__LENGTH macro. + + (vector_scale, vector_sum_squares, scm_random_solid_sphere_x, + scm_random_normal_vector_x): Use scm_uniform_vector_length to + determine the length of a vector object generically. + 2000-10-11 Dirk Herrmann * ramap.c (scm_array_fill_int, scm_array_index_map_x): Replace diff --git a/libguile/random.c b/libguile/random.c index 28c94d33c..6467bb8e3 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -405,7 +405,7 @@ SCM_DEFINE (scm_seed_to_random_state, "seed->random-state", 1, 0, 0, seed = scm_number_to_string (seed, SCM_UNDEFINED); SCM_VALIDATE_STRING (1,seed); return make_rstate (scm_c_make_rstate (SCM_ROCHARS (seed), - SCM_LENGTH (seed))); + SCM_STRING_LENGTH (seed))); } #undef FUNC_NAME @@ -442,7 +442,7 @@ SCM_DEFINE (scm_random_normal, "random:normal", 0, 1, 0, static void vector_scale (SCM v, double c) { - int n = SCM_LENGTH (v); + int n = SCM_INUM (scm_uniform_vector_length (v)); if (SCM_VECTORP (v)) while (--n >= 0) SCM_REAL_VALUE (SCM_VELTS (v)[n]) *= c; @@ -455,7 +455,7 @@ static double vector_sum_squares (SCM v) { double x, sum = 0.0; - int n = SCM_LENGTH (v); + int n = SCM_INUM (scm_uniform_vector_length (v)); if (SCM_VECTORP (v)) while (--n >= 0) { @@ -494,7 +494,7 @@ SCM_DEFINE (scm_random_solid_sphere_x, "random:solid-sphere!", 1, 1, 0, scm_random_normal_vector_x (v, state); vector_scale (v, pow (scm_c_uniform01 (SCM_RSTATE (state)), - 1.0 / SCM_LENGTH (v)) + 1.0 / SCM_INUM (scm_uniform_vector_length (v))) / sqrt (vector_sum_squares (v))); return SCM_UNSPECIFIED; } @@ -535,7 +535,7 @@ SCM_DEFINE (scm_random_normal_vector_x, "random:normal-vector!", 1, 1, 0, if (SCM_UNBNDP (state)) state = SCM_CDR (scm_var_random_state); SCM_VALIDATE_RSTATE (2,state); - n = SCM_LENGTH (v); + n = SCM_INUM (scm_uniform_vector_length (v)); if (SCM_VECTORP (v)) while (--n >= 0) SCM_VELTS (v)[n] = scm_make_real (scm_c_normal01 (SCM_RSTATE (state))); From 9208204554382a5a7866071cea4e2775c8bfaaae Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 11 Oct 2000 19:20:14 +0000 Subject: [PATCH 0314/2047] * gc.h (scm_get_stack_base): Added prototype. --- libguile/gc.h | 1 + 1 file changed, 1 insertion(+) diff --git a/libguile/gc.h b/libguile/gc.h index afa6f1f54..97a47c49a 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -369,6 +369,7 @@ extern SCM scm_unprotect_object (SCM obj); extern int scm_init_storage (scm_sizet init_heap_size, int trig, scm_sizet init_heap2_size, int trig2, scm_sizet max_segment_size); +extern void *scm_get_stack_base (void); extern void scm_init_gc (void); #endif /* GCH */ From ec009b22a936839fcb9bce45955513a9a91227b8 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 11 Oct 2000 19:22:06 +0000 Subject: [PATCH 0315/2047] * gc.h (scm_get_stack_base): Added prototype. * init.c (scm_get_stack_base): Removed prototype. --- libguile/init.c | 2 -- 1 file changed, 2 deletions(-) diff --git a/libguile/init.c b/libguile/init.c index 01cb4eb94..60ea523a6 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -449,8 +449,6 @@ scm_boot_guile (int argc, char ** argv, void (*main_func) (), void *closure) scm_boot_guile_1 (&dummy, &c); } -extern void *scm_get_stack_base (); - void scm_init_guile () { From 155415a56d1f48ed20b0873a4cd11ba9ae744ef2 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 11 Oct 2000 19:23:52 +0000 Subject: [PATCH 0316/2047] * gc_os_dep.c: Added real implementation based on code from Boehms collector. This is not well tested yet. --- libguile/gc_os_dep.c | 1840 +++++++++++++++++++++++++++++++++++++++++- 1 file changed, 1834 insertions(+), 6 deletions(-) diff --git a/libguile/gc_os_dep.c b/libguile/gc_os_dep.c index df0ce6d63..f0e37bc9a 100644 --- a/libguile/gc_os_dep.c +++ b/libguile/gc_os_dep.c @@ -1,10 +1,1838 @@ -/* This is a dummy file. It will be replaced with the real thing when - all copyright issues have been settled. */ +/* + * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers + * Copyright (c) 1991-1995 by Xerox Corporation. All rights reserved. + * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. + * Copyright (c) 1999 by Hewlett-Packard Company. All rights reserved. + * Copyright (c) 2000 Free Software Foundation + * + * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED + * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. + * + * Permission is hereby granted to use or copy this program + * for any purpose, provided the above notices are retained on all copies. + * Permission to modify the code and to distribute modified code is granted, + * provided the above notices are retained, and a notice that the code was + * modified is included with the above copyright notice. + * + */ -#include +/* + * Copied from gc5.2, files "os_dep.c", "gc_priv.h"and "gcconfig.h", + * and modified for Guile by Marius Vollmer. + */ -void * -scm_get_stack_base () +#include +#include "libguile/gc.h" + +#define ABORT(msg) abort () + +typedef char * ptr_t; /* A generic pointer to which we can add */ + /* byte displacements. */ + /* Preferably identical to caddr_t, if it */ + /* exists. */ + +/* Define word and signed_word to be unsigned and signed types of the */ +/* size as char * or void *. There seems to be no way to do this */ +/* even semi-portably. The following is probably no better/worse */ +/* than almost anything else. */ +/* The ANSI standard suggests that size_t and ptr_diff_t might be */ +/* better choices. But those appear to have incorrect definitions */ +/* on may systems. Notably "typedef int size_t" seems to be both */ +/* frequent and WRONG. */ +typedef unsigned long GC_word; +typedef long GC_signed_word; + +typedef GC_word word; +typedef GC_signed_word signed_word; + +/* Machine dependent parameters. Some tuning parameters can be found */ +/* near the top of gc_private.h. */ + +/* Machine specific parts contributed by various people. See README file. */ + +/* First a unified test for Linux: */ +# if defined(linux) || defined(__linux__) +# define LINUX +# endif + +/* Determine the machine type: */ +# if defined(sun) && defined(mc68000) +# define M68K +# define SUNOS4 +# define mach_type_known +# endif +# if defined(hp9000s300) +# define M68K +# define HP +# define mach_type_known +# endif +# if defined(__OpenBSD__) && defined(m68k) +# define M68K +# define OPENBSD +# define mach_type_known +# endif +# if defined(__OpenBSD__) && defined(__sparc__) +# define SPARC +# define OPENBSD +# define mach_type_known +# endif +# if defined(__NetBSD__) && defined(m68k) +# define M68K +# define NETBSD +# define mach_type_known +# endif +# if defined(__NetBSD__) && defined(arm32) +# define ARM32 +# define NETBSD +# define mach_type_known +# endif +# if defined(vax) +# define VAX +# ifdef ultrix +# define ULTRIX +# else +# define BSD +# endif +# define mach_type_known +# endif +# if defined(mips) || defined(__mips) +# define MIPS +# if !defined(LINUX) +# if defined(ultrix) || defined(__ultrix) || defined(__NetBSD__) +# define ULTRIX +# else +# if defined(_SYSTYPE_SVR4) || defined(SYSTYPE_SVR4) \ + || defined(__SYSTYPE_SVR4__) +# define IRIX5 /* or IRIX 6.X */ +# else +# define RISCOS /* or IRIX 4.X */ +# endif +# endif +# endif /* !LINUX */ +# define mach_type_known +# endif +# if defined(sequent) && defined(i386) +# define I386 +# define SEQUENT +# define mach_type_known +# endif +# if defined(sun) && defined(i386) +# define I386 +# define SUNOS5 +# define mach_type_known +# endif +# if (defined(__OS2__) || defined(__EMX__)) && defined(__32BIT__) +# define I386 +# define OS2 +# define mach_type_known +# endif +# if defined(ibm032) +# define RT +# define mach_type_known +# endif +# if defined(sun) && (defined(sparc) || defined(__sparc)) +# define SPARC + /* Test for SunOS 5.x */ +# include +# ifdef ECHRNG +# define SUNOS5 +# else +# define SUNOS4 +# endif +# define mach_type_known +# endif +# if defined(sparc) && defined(unix) && !defined(sun) && !defined(linux) \ + && !defined(__OpenBSD__) +# define SPARC +# define DRSNX +# define mach_type_known +# endif +# if defined(_IBMR2) +# define RS6000 +# define mach_type_known +# endif +# if defined(_M_XENIX) && defined(_M_SYSV) && defined(_M_I386) + /* The above test may need refinement */ +# define I386 +# if defined(_SCO_ELF) +# define SCO_ELF +# else +# define SCO +# endif +# define mach_type_known +# endif +# if defined(_AUX_SOURCE) +# define M68K +# define SYSV +# define mach_type_known +# endif +# if defined(_PA_RISC1_0) || defined(_PA_RISC1_1) || defined(_PA_RISC2_0) \ + || defined(hppa) || defined(__hppa__) +# define HP_PA +# ifndef LINUX +# define HPUX +# endif +# define mach_type_known +# endif +# if defined(LINUX) && (defined(i386) || defined(__i386__)) +# define I386 +# define mach_type_known +# endif +# if defined(LINUX) && (defined(__ia64__) || defined(__ia64)) +# define IA64 +# define mach_type_known +# endif +# if defined(LINUX) && defined(powerpc) +# define POWERPC +# define mach_type_known +# endif +# if defined(LINUX) && defined(__mc68000__) +# define M68K +# define mach_type_known +# endif +# if defined(LINUX) && (defined(sparc) || defined(__sparc__)) +# define SPARC +# define mach_type_known +# endif +# if defined(LINUX) && defined(arm) +# define ARM32 +# define mach_type_known +# endif +# if defined(__alpha) || defined(__alpha__) +# define ALPHA +# if !defined(LINUX) +# define OSF1 /* a.k.a Digital Unix */ +# endif +# define mach_type_known +# endif +# if defined(_AMIGA) && !defined(AMIGA) +# define AMIGA +# endif +# ifdef AMIGA +# define M68K +# define mach_type_known +# endif +# if defined(THINK_C) || defined(__MWERKS__) && !defined(__powerc) +# define M68K +# define MACOS +# define mach_type_known +# endif +# if defined(__MWERKS__) && defined(__powerc) +# define POWERPC +# define MACOS +# define mach_type_known +# endif +# if defined(macosx) +# define MACOSX +# define POWERPC +# define mach_type_known +# endif +# if defined(NeXT) && defined(mc68000) +# define M68K +# define NEXT +# define mach_type_known +# endif +# if defined(NeXT) && defined(i386) +# define I386 +# define NEXT +# define mach_type_known +# endif +# if defined(__OpenBSD__) && defined(i386) +# define I386 +# define OPENBSD +# define mach_type_known +# endif +# if defined(__FreeBSD__) && defined(i386) +# define I386 +# define FREEBSD +# define mach_type_known +# endif +# if defined(__NetBSD__) && defined(i386) +# define I386 +# define NETBSD +# define mach_type_known +# endif +# if defined(bsdi) && defined(i386) +# define I386 +# define BSDI +# define mach_type_known +# endif +# if !defined(mach_type_known) && defined(__386BSD__) +# define I386 +# define THREE86BSD +# define mach_type_known +# endif +# if defined(_CX_UX) && defined(_M88K) +# define M88K +# define CX_UX +# define mach_type_known +# endif +# if defined(DGUX) +# define M88K + /* DGUX defined */ +# define mach_type_known +# endif +# if (defined(_MSDOS) || defined(_MSC_VER)) && (_M_IX86 >= 300) \ + || defined(_WIN32) && !defined(__CYGWIN32__) && !defined(__CYGWIN__) +# define I386 +# define MSWIN32 /* or Win32s */ +# define mach_type_known +# endif +# if defined(__DJGPP__) +# define I386 +# ifndef DJGPP +# define DJGPP /* MSDOS running the DJGPP port of GCC */ +# endif +# define mach_type_known +# endif +# if defined(__CYGWIN32__) || defined(__CYGWIN__) +# define I386 +# define CYGWIN32 +# define mach_type_known +# endif +# if defined(__MINGW32__) +# define I386 +# define MSWIN32 +# define mach_type_known +# endif +# if defined(__BORLANDC__) +# define I386 +# define MSWIN32 +# define mach_type_known +# endif +# if defined(_UTS) && !defined(mach_type_known) +# define S370 +# define UTS4 +# define mach_type_known +# endif +# if defined(__pj__) +# define PJ +# define mach_type_known +# endif +/* Ivan Demakov */ +# if defined(__WATCOMC__) && defined(__386__) +# define I386 +# if !defined(OS2) && !defined(MSWIN32) && !defined(DOS4GW) +# if defined(__OS2__) +# define OS2 +# else +# if defined(__WINDOWS_386__) || defined(__NT__) +# define MSWIN32 +# else +# define DOS4GW +# endif +# endif +# endif +# define mach_type_known +# endif + +/* Feel free to add more clauses here */ + +/* Or manually define the machine type here. A machine type is */ +/* characterized by the architecture. Some */ +/* machine types are further subdivided by OS. */ +/* the macros ULTRIX, RISCOS, and BSD to distinguish. */ +/* Note that SGI IRIX is treated identically to RISCOS. */ +/* SYSV on an M68K actually means A/UX. */ +/* The distinction in these cases is usually the stack starting address */ +# ifndef mach_type_known + --> unknown machine type +# endif + /* Mapping is: M68K ==> Motorola 680X0 */ + /* (SUNOS4,HP,NEXT, and SYSV (A/UX), */ + /* MACOS and AMIGA variants) */ + /* I386 ==> Intel 386 */ + /* (SEQUENT, OS2, SCO, LINUX, NETBSD, */ + /* FREEBSD, THREE86BSD, MSWIN32, */ + /* BSDI,SUNOS5, NEXT, other variants) */ + /* NS32K ==> Encore Multimax */ + /* MIPS ==> R2000 or R3000 */ + /* (RISCOS, ULTRIX variants) */ + /* VAX ==> DEC VAX */ + /* (BSD, ULTRIX variants) */ + /* RS6000 ==> IBM RS/6000 AIX3.X */ + /* RT ==> IBM PC/RT */ + /* HP_PA ==> HP9000/700 & /800 */ + /* HP/UX */ + /* SPARC ==> SPARC under SunOS */ + /* (SUNOS4, SUNOS5, */ + /* DRSNX variants) */ + /* ALPHA ==> DEC Alpha */ + /* (OSF1 and LINUX variants) */ + /* M88K ==> Motorola 88XX0 */ + /* (CX_UX and DGUX) */ + /* S370 ==> 370-like machine */ + /* running Amdahl UTS4 */ + /* ARM32 ==> Intel StrongARM */ + /* IA64 ==> Intel IA64 */ + /* (e.g. Itanium) */ + + +/* + * For each architecture and OS, the following need to be defined: + * + * CPP_WORD_SZ is a simple integer constant representing the word size. + * in bits. We assume byte addressibility, where a byte has 8 bits. + * We also assume CPP_WORD_SZ is either 32 or 64. + * (We care about the length of pointers, not hardware + * bus widths. Thus a 64 bit processor with a C compiler that uses + * 32 bit pointers should use CPP_WORD_SZ of 32, not 64. Default is 32.) + * + * MACH_TYPE is a string representation of the machine type. + * OS_TYPE is analogous for the OS. + * + * ALIGNMENT is the largest N, such that + * all pointer are guaranteed to be aligned on N byte boundaries. + * defining it to be 1 will always work, but perform poorly. + * + * DATASTART is the beginning of the data segment. + * On UNIX systems, the collector will scan the area between DATASTART + * and DATAEND for root pointers. + * + * DATAEND, if not &end. + * + * ALIGN_DOUBLE of GC_malloc should return blocks aligned to twice + * the pointer size. + * + * STACKBOTTOM is the cool end of the stack, which is usually the + * highest address in the stack. + * Under PCR or OS/2, we have other ways of finding thread stacks. + * For each machine, the following should: + * 1) define STACK_GROWS_UP if the stack grows toward higher addresses, and + * 2) define exactly one of + * STACKBOTTOM (should be defined to be an expression) + * HEURISTIC1 + * HEURISTIC2 + * If either of the last two macros are defined, then STACKBOTTOM is computed + * during collector startup using one of the following two heuristics: + * HEURISTIC1: Take an address inside GC_init's frame, and round it up to + * the next multiple of STACK_GRAN. + * HEURISTIC2: Take an address inside GC_init's frame, increment it repeatedly + * in small steps (decrement if STACK_GROWS_UP), and read the value + * at each location. Remember the value when the first + * Segmentation violation or Bus error is signalled. Round that + * to the nearest plausible page boundary, and use that instead + * of STACKBOTTOM. + * + * Gustavo Rodriguez-Rivera points out that on most (all?) Unix machines, + * the value of environ is a pointer that can serve as STACKBOTTOM. + * I expect that HEURISTIC2 can be replaced by this approach, which + * interferes far less with debugging. + * + * If no expression for STACKBOTTOM can be found, and neither of the above + * heuristics are usable, the collector can still be used with all of the above + * undefined, provided one of the following is done: + * 1) GC_mark_roots can be changed to somehow mark from the correct stack(s) + * without reference to STACKBOTTOM. This is appropriate for use in + * conjunction with thread packages, since there will be multiple stacks. + * (Allocating thread stacks in the heap, and treating them as ordinary + * heap data objects is also possible as a last resort. However, this is + * likely to introduce significant amounts of excess storage retention + * unless the dead parts of the thread stacks are periodically cleared.) + * 2) Client code may set GC_stackbottom before calling any GC_ routines. + * If the author of the client code controls the main program, this is + * easily accomplished by introducing a new main program, setting + * GC_stackbottom to the address of a local variable, and then calling + * the original main program. The new main program would read something + * like: + * + * # include "gc_private.h" + * + * main(argc, argv, envp) + * int argc; + * char **argv, **envp; + * { + * int dummy; + * + * GC_stackbottom = (ptr_t)(&dummy); + * return(real_main(argc, argv, envp)); + * } + * + * + * Each architecture may also define the style of virtual dirty bit + * implementation to be used: + * MPROTECT_VDB: Write protect the heap and catch faults. + * PROC_VDB: Use the SVR4 /proc primitives to read dirty bits. + * + * An architecture may define DYNAMIC_LOADING if dynamic_load.c + * defined GC_register_dynamic_libraries() for the architecture. + * + * An architecture may define PREFETCH(x) to preload the cache with *x. + * This defaults to a no-op. + * + * PREFETCH_FOR_WRITE(x) is used if *x is about to be written. + * + * An architecture may also define CLEAR_DOUBLE(x) to be a fast way to + * clear the two words at GC_malloc-aligned address x. By default, + * word stores of 0 are used instead. + */ + + +# define STACK_GRAN 0x1000000 +# ifdef M68K +# define MACH_TYPE "M68K" +# define ALIGNMENT 2 +# ifdef OPENBSD +# define OS_TYPE "OPENBSD" +# define HEURISTIC2 + extern char etext; +# define DATASTART ((ptr_t)(&etext)) +# endif +# ifdef NETBSD +# define OS_TYPE "NETBSD" +# define HEURISTIC2 + extern char etext; +# define DATASTART ((ptr_t)(&etext)) +# endif +# ifdef LINUX +# define OS_TYPE "LINUX" +# define STACKBOTTOM ((ptr_t)0xf0000000) +# define MPROTECT_VDB +# ifdef __ELF__ +# define DYNAMIC_LOADING + extern char **__environ; +# define DATASTART ((ptr_t)(&__environ)) + /* hideous kludge: __environ is the first */ + /* word in crt0.o, and delimits the start */ + /* of the data segment, no matter which */ + /* ld options were passed through. */ + /* We could use _etext instead, but that */ + /* would include .rodata, which may */ + /* contain large read-only data tables */ + /* that we'd rather not scan. */ + extern int _end; +# define DATAEND (&_end) +# else + extern int etext; +# define DATASTART ((ptr_t)((((word) (&etext)) + 0xfff) & ~0xfff)) +# endif +# endif +# ifdef SUNOS4 +# define OS_TYPE "SUNOS4" + extern char etext; +# define DATASTART ((ptr_t)((((word) (&etext)) + 0x1ffff) & ~0x1ffff)) +# define HEURISTIC1 /* differs */ +# define DYNAMIC_LOADING +# endif +# ifdef HP +# define OS_TYPE "HP" + extern char etext; +# define DATASTART ((ptr_t)((((word) (&etext)) + 0xfff) & ~0xfff)) +# define STACKBOTTOM ((ptr_t) 0xffeffffc) + /* empirically determined. seems to work. */ +# include +# define GETPAGESIZE() sysconf(_SC_PAGE_SIZE) +# endif +# ifdef SYSV +# define OS_TYPE "SYSV" + extern etext; +# define DATASTART ((ptr_t)((((word) (&etext)) + 0x3fffff) \ + & ~0x3fffff) \ + +((word)&etext & 0x1fff)) + /* This only works for shared-text binaries with magic number 0413. + The other sorts of SysV binaries put the data at the end of the text, + in which case the default of &etext would work. Unfortunately, + handling both would require having the magic-number available. + -- Parag + */ +# define STACKBOTTOM ((ptr_t)0xFFFFFFFE) + /* The stack starts at the top of memory, but */ + /* 0x0 cannot be used as setjump_test complains */ + /* that the stack direction is incorrect. Two */ + /* bytes down from 0x0 should be safe enough. */ + /* --Parag */ +# include +# define GETPAGESIZE() PAGESIZE /* Is this still right? */ +# endif +# ifdef AMIGA +# define OS_TYPE "AMIGA" + /* STACKBOTTOM and DATASTART handled specially */ + /* in os_dep.c */ +# define DATAEND /* not needed */ +# define GETPAGESIZE() 4096 +# endif +# ifdef MACOS +# ifndef __LOWMEM__ +# include +# endif +# define OS_TYPE "MACOS" + /* see os_dep.c for details of global data segments. */ +# define STACKBOTTOM ((ptr_t) LMGetCurStackBase()) +# define DATAEND /* not needed */ +# define GETPAGESIZE() 4096 +# endif +# ifdef NEXT +# define OS_TYPE "NEXT" +# define DATASTART ((ptr_t) get_etext()) +# define STACKBOTTOM ((ptr_t) 0x4000000) +# define DATAEND /* not needed */ +# endif +# endif + +# ifdef POWERPC +# define MACH_TYPE "POWERPC" +# ifdef MACOS +# define ALIGNMENT 2 /* Still necessary? Could it be 4? */ +# ifndef __LOWMEM__ +# include +# endif +# define OS_TYPE "MACOS" + /* see os_dep.c for details of global data segments. */ +# define STACKBOTTOM ((ptr_t) LMGetCurStackBase()) +# define DATAEND /* not needed */ +# endif +# ifdef LINUX +# define ALIGNMENT 4 /* Guess. Can someone verify? */ + /* This was 2, but that didn't sound right. */ +# define OS_TYPE "LINUX" +# define HEURISTIC1 +# define DYNAMIC_LOADING +# undef STACK_GRAN +# define STACK_GRAN 0x10000000 + /* Stack usually starts at 0x80000000 */ +# define LINUX_DATA_START + extern int _end; +# define DATAEND (&_end) +# endif +# ifdef MACOSX +# define ALIGNMENT 4 +# define OS_TYPE "MACOSX" +# define DATASTART ((ptr_t) get_etext()) +# define STACKBOTTOM ((ptr_t) 0xc0000000) +# define DATAEND /* not needed */ +# endif +# endif + +# ifdef VAX +# define MACH_TYPE "VAX" +# define ALIGNMENT 4 /* Pointers are longword aligned by 4.2 C compiler */ + extern char etext; +# define DATASTART ((ptr_t)(&etext)) +# ifdef BSD +# define OS_TYPE "BSD" +# define HEURISTIC1 + /* HEURISTIC2 may be OK, but it's hard to test. */ +# endif +# ifdef ULTRIX +# define OS_TYPE "ULTRIX" +# define STACKBOTTOM ((ptr_t) 0x7fffc800) +# endif +# endif + +# ifdef RT +# define MACH_TYPE "RT" +# define ALIGNMENT 4 +# define DATASTART ((ptr_t) 0x10000000) +# define STACKBOTTOM ((ptr_t) 0x1fffd800) +# endif + +# ifdef SPARC +# define MACH_TYPE "SPARC" +# define ALIGNMENT 4 /* Required by hardware */ +# define ALIGN_DOUBLE + extern int etext; +# ifdef SUNOS5 +# define OS_TYPE "SUNOS5" + extern int _etext; + extern int _end; + extern char * GC_SysVGetDataStart(); +# define DATASTART (ptr_t)GC_SysVGetDataStart(0x10000, &_etext) +# define DATAEND (&_end) +# ifndef USE_MMAP +# define USE_MMAP +# endif +# ifdef USE_MMAP +# define HEAP_START (ptr_t)0x40000000 +# else +# define HEAP_START DATAEND +# endif +# define PROC_VDB +/* HEURISTIC1 reportedly no longer works under 2.7. Thus we */ +/* switched to HEURISTIC2, eventhough it creates some debugging */ +/* issues. */ +# define HEURISTIC2 +# include +# define GETPAGESIZE() sysconf(_SC_PAGESIZE) + /* getpagesize() appeared to be missing from at least one */ + /* Solaris 5.4 installation. Weird. */ +# define DYNAMIC_LOADING +# endif +# ifdef SUNOS4 +# define OS_TYPE "SUNOS4" + /* [If you have a weak stomach, don't read this.] */ + /* We would like to use: */ +/* # define DATASTART ((ptr_t)((((word) (&etext)) + 0x1fff) & ~0x1fff)) */ + /* This fails occasionally, due to an ancient, but very */ + /* persistent ld bug. &etext is set 32 bytes too high. */ + /* We instead read the text segment size from the a.out */ + /* header, which happens to be mapped into our address space */ + /* at the start of the text segment. The detective work here */ + /* was done by Robert Ehrlich, Manuel Serrano, and Bernard */ + /* Serpette of INRIA. */ + /* This assumes ZMAGIC, i.e. demand-loadable executables. */ +# define TEXTSTART 0x2000 +# define DATASTART ((ptr_t)(*(int *)(TEXTSTART+0x4)+TEXTSTART)) +# define MPROTECT_VDB +# define HEURISTIC1 +# define DYNAMIC_LOADING +# endif +# ifdef DRSNX +# define CPP_WORDSZ 32 +# define OS_TYPE "DRSNX" + extern char * GC_SysVGetDataStart(); + extern int etext; +# define DATASTART (ptr_t)GC_SysVGetDataStart(0x10000, &etext) +# define MPROTECT_VDB +# define STACKBOTTOM ((ptr_t) 0xdfff0000) +# define DYNAMIC_LOADING +# endif +# ifdef LINUX +# define OS_TYPE "LINUX" +# ifdef __ELF__ +# define LINUX_DATA_START +# define DYNAMIC_LOADING +# else + Linux Sparc non elf ? +# endif + extern int _end; +# define DATAEND (&_end) +# define SVR4 +# define STACKBOTTOM ((ptr_t) 0xf0000000) +# endif +# ifdef OPENBSD +# define OS_TYPE "OPENBSD" +# define STACKBOTTOM ((ptr_t) 0xf8000000) +# define DATASTART ((ptr_t)(&etext)) +# endif +# endif + +# ifdef I386 +# define MACH_TYPE "I386" +# define ALIGNMENT 4 /* Appears to hold for all "32 bit" compilers */ + /* except Borland. The -a4 option fixes */ + /* Borland. */ + /* Ivan Demakov: For Watcom the option is -zp4. */ +# ifndef SMALL_CONFIG +# define ALIGN_DOUBLE /* Not strictly necessary, but may give speed */ + /* improvement on Pentiums. */ +# endif +# ifdef SEQUENT +# define OS_TYPE "SEQUENT" + extern int etext; +# define DATASTART ((ptr_t)((((word) (&etext)) + 0xfff) & ~0xfff)) +# define STACKBOTTOM ((ptr_t) 0x3ffff000) +# endif +# ifdef SUNOS5 +# define OS_TYPE "SUNOS5" + extern int etext, _start; + extern char * GC_SysVGetDataStart(); +# define DATASTART GC_SysVGetDataStart(0x1000, &etext) +# define STACKBOTTOM ((ptr_t)(&_start)) +/** At least in Solaris 2.5, PROC_VDB gives wrong values for dirty bits. */ +/*# define PROC_VDB*/ +# define DYNAMIC_LOADING +# ifndef USE_MMAP +# define USE_MMAP +# endif +# ifdef USE_MMAP +# define HEAP_START (ptr_t)0x40000000 +# else +# define HEAP_START DATAEND +# endif +# endif +# ifdef SCO +# define OS_TYPE "SCO" + extern int etext; +# define DATASTART ((ptr_t)((((word) (&etext)) + 0x3fffff) \ + & ~0x3fffff) \ + +((word)&etext & 0xfff)) +# define STACKBOTTOM ((ptr_t) 0x7ffffffc) +# endif +# ifdef SCO_ELF +# define OS_TYPE "SCO_ELF" + extern int etext; +# define DATASTART ((ptr_t)(&etext)) +# define STACKBOTTOM ((ptr_t) 0x08048000) +# define DYNAMIC_LOADING +# define ELF_CLASS ELFCLASS32 +# endif +# ifdef LINUX +# define OS_TYPE "LINUX" +# define LINUX_STACKBOTTOM +# if 0 +# define HEURISTIC1 +# undef STACK_GRAN +# define STACK_GRAN 0x10000000 + /* STACKBOTTOM is usually 0xc0000000, but this changes with */ + /* different kernel configurations. In particular, systems */ + /* with 2GB physical memory will usually move the user */ + /* address space limit, and hence initial SP to 0x80000000. */ +# endif +# if !defined(LINUX_THREADS) || !defined(REDIRECT_MALLOC) +# define MPROTECT_VDB +# else + /* We seem to get random errors in incremental mode, */ + /* possibly because Linux threads is itself a malloc client */ + /* and can't deal with the signals. */ +# endif +# ifdef __ELF__ +# define DYNAMIC_LOADING +# ifdef UNDEFINED /* includes ro data */ + extern int _etext; +# define DATASTART ((ptr_t)((((word) (&_etext)) + 0xfff) & ~0xfff)) +# endif +# include +# if defined(__GLIBC__) && __GLIBC__ >= 2 +# define LINUX_DATA_START +# else + extern char **__environ; +# define DATASTART ((ptr_t)(&__environ)) + /* hideous kludge: __environ is the first */ + /* word in crt0.o, and delimits the start */ + /* of the data segment, no matter which */ + /* ld options were passed through. */ + /* We could use _etext instead, but that */ + /* would include .rodata, which may */ + /* contain large read-only data tables */ + /* that we'd rather not scan. */ +# endif + extern int _end; +# define DATAEND (&_end) +# else + extern int etext; +# define DATASTART ((ptr_t)((((word) (&etext)) + 0xfff) & ~0xfff)) +# endif +# ifdef USE_I686_PREFETCH +# define PREFETCH(x) \ + __asm__ __volatile__ (" prefetchnta %0": : "m"(*(char *)(x))) + /* Empirically prefetcht0 is much more effective at reducing */ + /* cache miss stalls for the targetted load instructions. But it */ + /* seems to interfere enough with other cache traffic that the net */ + /* result is worse than prefetchnta. */ +# if 0 + /* Using prefetches for write seems to have a slight negative */ + /* impact on performance, at least for a PIII/500. */ +# define PREFETCH_FOR_WRITE(x) \ + __asm__ __volatile__ (" prefetcht0 %0": : "m"(*(char *)(x))) +# endif +# endif +# ifdef USE_3DNOW_PREFETCH +# define PREFETCH(x) \ + __asm__ __volatile__ (" prefetch %0": : "m"(*(char *)(x))) +# define PREFETCH_FOR_WRITE(x) + __asm__ __volatile__ (" prefetchw %0": : "m"(*(char *)(x))) +# endif +# endif +# ifdef CYGWIN32 +# define OS_TYPE "CYGWIN32" + extern int _data_start__; + extern int _data_end__; + extern int _bss_start__; + extern int _bss_end__; + /* For binutils 2.9.1, we have */ + /* DATASTART = _data_start__ */ + /* DATAEND = _bss_end__ */ + /* whereas for some earlier versions it was */ + /* DATASTART = _bss_start__ */ + /* DATAEND = _data_end__ */ + /* To get it right for both, we take the */ + /* minumum/maximum of the two. */ +# define MAX(x,y) ((x) > (y) ? (x) : (y)) +# define MIN(x,y) ((x) < (y) ? (x) : (y)) +# define DATASTART ((ptr_t) MIN(&_data_start__, &_bss_start__)) +# define DATAEND ((ptr_t) MAX(&_data_end__, &_bss_end__)) +# undef STACK_GRAN +# define STACK_GRAN 0x10000 +# define HEURISTIC1 +# endif +# ifdef OS2 +# define OS_TYPE "OS2" + /* STACKBOTTOM and DATASTART are handled specially in */ + /* os_dep.c. OS2 actually has the right */ + /* system call! */ +# define DATAEND /* not needed */ +# endif +# ifdef MSWIN32 +# define OS_TYPE "MSWIN32" + /* STACKBOTTOM and DATASTART are handled specially in */ + /* os_dep.c. */ +# ifndef __WATCOMC__ +# define MPROTECT_VDB +# endif +# define DATAEND /* not needed */ +# endif +# ifdef DJGPP +# define OS_TYPE "DJGPP" +# include "stubinfo.h" + extern int etext; + extern int _stklen; + extern int __djgpp_stack_limit; +# define DATASTART ((ptr_t)((((word) (&etext)) + 0x1ff) & ~0x1ff)) +/* # define STACKBOTTOM ((ptr_t)((word) _stubinfo + _stubinfo->size \ + + _stklen)) */ +# define STACKBOTTOM ((ptr_t)((word) __djgpp_stack_limit + _stklen)) + /* This may not be right. */ +# endif +# ifdef OPENBSD +# define OS_TYPE "OPENBSD" +# endif +# ifdef FREEBSD +# define OS_TYPE "FREEBSD" +# define MPROTECT_VDB +# endif +# ifdef NETBSD +# define OS_TYPE "NETBSD" +# endif +# ifdef THREE86BSD +# define OS_TYPE "THREE86BSD" +# endif +# ifdef BSDI +# define OS_TYPE "BSDI" +# endif +# if defined(OPENBSD) || defined(FREEBSD) || defined(NETBSD) \ + || defined(THREE86BSD) || defined(BSDI) +# define HEURISTIC2 + extern char etext; +# define DATASTART ((ptr_t)(&etext)) +# endif +# ifdef NEXT +# define OS_TYPE "NEXT" +# define DATASTART ((ptr_t) get_etext()) +# define STACKBOTTOM ((ptr_t)0xc0000000) +# define DATAEND /* not needed */ +# endif +# ifdef DOS4GW +# define OS_TYPE "DOS4GW" + extern long __nullarea; + extern char _end; + extern char *_STACKTOP; + /* Depending on calling conventions Watcom C either precedes + or does not precedes with undescore names of C-variables. + Make sure startup code variables always have the same names. */ + #pragma aux __nullarea "*"; + #pragma aux _end "*"; +# define STACKBOTTOM ((ptr_t) _STACKTOP) + /* confused? me too. */ +# define DATASTART ((ptr_t) &__nullarea) +# define DATAEND ((ptr_t) &_end) +# endif +# endif + +# ifdef NS32K +# define MACH_TYPE "NS32K" +# define ALIGNMENT 4 + extern char **environ; +# define DATASTART ((ptr_t)(&environ)) + /* hideous kludge: environ is the first */ + /* word in crt0.o, and delimits the start */ + /* of the data segment, no matter which */ + /* ld options were passed through. */ +# define STACKBOTTOM ((ptr_t) 0xfffff000) /* for Encore */ +# endif + +# ifdef MIPS +# define MACH_TYPE "MIPS" +/* # define STACKBOTTOM ((ptr_t)0x7fff8000) sometimes also works. */ +# ifdef LINUX + /* This was developed for a linuxce style platform. Probably */ + /* needs to be tweaked for workstation class machines. */ +# define OS_TYPE "LINUX" + extern int __data_start; +# define DATASTART ((ptr_t)(&__data_start)) +# define ALIGNMENT 4 +# define USE_GENERIC_PUSH_REGS 1 +# define STACKBOTTOM 0x80000000 + /* In many cases, this should probably use LINUX_STACKBOTTOM */ + /* instead. But some kernel versions seem to give the wrong */ + /* value from /proc. */ +# endif /* Linux */ +# ifdef ULTRIX +# define HEURISTIC2 +# define DATASTART (ptr_t)0x10000000 + /* Could probably be slightly higher since */ + /* startup code allocates lots of stuff. */ +# define OS_TYPE "ULTRIX" +# define ALIGNMENT 4 +# endif +# ifdef RISCOS +# define HEURISTIC2 +# define DATASTART (ptr_t)0x10000000 +# define OS_TYPE "RISCOS" +# define ALIGNMENT 4 /* Required by hardware */ +# endif +# ifdef IRIX5 +# define HEURISTIC2 + extern int _fdata; +# define DATASTART ((ptr_t)(&_fdata)) +# ifdef USE_MMAP +# define HEAP_START (ptr_t)0x30000000 +# else +# define HEAP_START DATASTART +# endif + /* Lowest plausible heap address. */ + /* In the MMAP case, we map there. */ + /* In either case it is used to identify */ + /* heap sections so they're not */ + /* considered as roots. */ +# define OS_TYPE "IRIX5" +# define MPROTECT_VDB +# ifdef _MIPS_SZPTR +# define CPP_WORDSZ _MIPS_SZPTR +# define ALIGNMENT (_MIPS_SZPTR/8) +# if CPP_WORDSZ != 64 +# define ALIGN_DOUBLE +# endif +# else +# define ALIGNMENT 4 +# define ALIGN_DOUBLE +# endif +# define DYNAMIC_LOADING +# endif +# endif + +# ifdef RS6000 +# define MACH_TYPE "RS6000" +# define ALIGNMENT 4 +# define DATASTART ((ptr_t)0x20000000) + extern int errno; +# define STACKBOTTOM ((ptr_t)((ulong)&errno)) +# define DYNAMIC_LOADING + /* For really old versions of AIX, this may have to be removed. */ +# endif + +# ifdef HP_PA + /* OS is assumed to be HP/UX */ +# define MACH_TYPE "HP_PA" +# define OS_TYPE "HPUX" +# ifdef __LP64__ +# define CPP_WORDSZ 64 +# define ALIGNMENT 8 +# else +# define CPP_WORDSZ 32 +# define ALIGNMENT 4 +# define ALIGN_DOUBLE +# endif + extern int __data_start; +# define DATASTART ((ptr_t)(&__data_start)) +# if 0 + /* The following appears to work for 7xx systems running HP/UX */ + /* 9.xx Furthermore, it might result in much faster */ + /* collections than HEURISTIC2, which may involve scanning */ + /* segments that directly precede the stack. It is not the */ + /* default, since it may not work on older machine/OS */ + /* combinations. (Thanks to Raymond X.T. Nijssen for uncovering */ + /* this.) */ +# define STACKBOTTOM ((ptr_t) 0x7b033000) /* from /etc/conf/h/param.h */ +# else + /* Gustavo Rodriguez-Rivera suggested changing HEURISTIC2 */ + /* to this. We'll probably do this on other platforms, too. */ + /* For now I'll use it where I can test it. */ + extern char ** environ; +# define STACKBOTTOM ((ptr_t)environ) +# endif +# define STACK_GROWS_UP +# define DYNAMIC_LOADING +# ifndef HPUX_THREADS +# define MPROTECT_VDB +# endif +# include +# define GETPAGESIZE() sysconf(_SC_PAGE_SIZE) +# endif + +# ifdef ALPHA +# define MACH_TYPE "ALPHA" +# define ALIGNMENT 8 +# define USE_GENERIC_PUSH_REGS + /* Gcc and probably the DEC/Compaq compiler spill pointers to preserved */ + /* fp registers in some cases when the target is a 21264. The assembly */ + /* code doesn't handle that yet, and version dependencies make that a */ + /* bit tricky. Do the easy thing for now. */ +# ifdef OSF1 +# define OS_TYPE "OSF1" +# define DATASTART ((ptr_t) 0x140000000) + extern _end; +# define DATAEND ((ptr_t) &_end) +# define HEURISTIC2 + /* Normally HEURISTIC2 is too conervative, since */ + /* the text segment immediately follows the stack. */ + /* Hence we give an upper pound. */ + extern int __start; +# define HEURISTIC2_LIMIT ((ptr_t)((word)(&__start) & ~(getpagesize()-1))) +# define CPP_WORDSZ 64 +# define MPROTECT_VDB +# define DYNAMIC_LOADING +# endif +# ifdef LINUX +# define OS_TYPE "LINUX" +# define CPP_WORDSZ 64 +# define STACKBOTTOM ((ptr_t) 0x120000000) +# ifdef __ELF__ +# define LINUX_DATA_START +# define DYNAMIC_LOADING + /* This doesn't work if the collector is in a dynamic library. */ +# else +# define DATASTART ((ptr_t) 0x140000000) +# endif + extern int _end; +# define DATAEND (&_end) +# define MPROTECT_VDB + /* Has only been superficially tested. May not */ + /* work on all versions. */ +# endif +# endif + +# ifdef IA64 +# define MACH_TYPE "IA64" +# define ALIGN_DOUBLE + /* Requires 16 byte alignment for malloc */ +# define ALIGNMENT 8 +# define USE_GENERIC_PUSH_REGS + /* We need to get preserved registers in addition to register windows. */ + /* That's easiest to do with setjmp. */ +# ifdef HPUX + --> needs work +# endif +# ifdef LINUX +# define OS_TYPE "LINUX" +# define CPP_WORDSZ 64 + /* This should really be done through /proc, but that */ + /* requires we run on an IA64 kernel. */ +# define STACKBOTTOM ((ptr_t) 0xa000000000000000l) + /* We also need the base address of the register stack */ + /* backing store. There is probably a better way to */ + /* get that, too ... */ +# define BACKING_STORE_BASE ((ptr_t) 0x9fffffff80000000l) +# if 1 +# define SEARCH_FOR_DATA_START +# define DATASTART GC_data_start +# else + extern int data_start; +# define DATASTART ((ptr_t)(&data_start)) +# endif +# define DYNAMIC_LOADING +# define MPROTECT_VDB + /* Requires Linux 2.3.47 or later. */ + extern int _end; +# define DATAEND (&_end) +# define PREFETCH(x) \ + __asm__ (" lfetch [%0]": : "r"((void *)(x))) +# define PREFETCH_FOR_WRITE(x) \ + __asm__ (" lfetch.excl [%0]": : "r"((void *)(x))) +# define CLEAR_DOUBLE(x) \ + __asm__ (" stf.spill [%0]=f0": : "r"((void *)(x))) +# endif +# endif + +# ifdef M88K +# define MACH_TYPE "M88K" +# define ALIGNMENT 4 +# define ALIGN_DOUBLE + extern int etext; +# ifdef CX_UX +# define OS_TYPE "CX_UX" +# define DATASTART ((((word)&etext + 0x3fffff) & ~0x3fffff) + 0x10000) +# endif +# ifdef DGUX +# define OS_TYPE "DGUX" + extern char * GC_SysVGetDataStart(); +# define DATASTART (ptr_t)GC_SysVGetDataStart(0x10000, &etext) +# endif +# define STACKBOTTOM ((char*)0xf0000000) /* determined empirically */ +# endif + +# ifdef S370 +# define MACH_TYPE "S370" +# define OS_TYPE "UTS4" +# define ALIGNMENT 4 /* Required by hardware */ + extern int etext; + extern int _etext; + extern int _end; + extern char * GC_SysVGetDataStart(); +# define DATASTART (ptr_t)GC_SysVGetDataStart(0x10000, &_etext) +# define DATAEND (&_end) +# define HEURISTIC2 +# endif + +# if defined(PJ) +# define ALIGNMENT 4 + extern int _etext; +# define DATASTART ((ptr_t)(&_etext)) +# define HEURISTIC1 +# endif + +# ifdef ARM32 +# define CPP_WORDSZ 32 +# define MACH_TYPE "ARM32" +# define ALIGNMENT 4 +# ifdef NETBSD +# define OS_TYPE "NETBSD" +# define HEURISTIC2 + extern char etext; +# define DATASTART ((ptr_t)(&etext)) +# define USE_GENERIC_PUSH_REGS +# endif +# ifdef LINUX +# define OS_TYPE "LINUX" +# define HEURISTIC1 +# undef STACK_GRAN +# define STACK_GRAN 0x10000000 +# define USE_GENERIC_PUSH_REGS +# ifdef __ELF__ +# define DYNAMIC_LOADING +# include +# if defined(__GLIBC__) && __GLIBC__ >= 2 +# define LINUX_DATA_START +# else + extern char **__environ; +# define DATASTART ((ptr_t)(&__environ)) + /* hideous kludge: __environ is the first */ + /* word in crt0.o, and delimits the start */ + /* of the data segment, no matter which */ + /* ld options were passed through. */ + /* We could use _etext instead, but that */ + /* would include .rodata, which may */ + /* contain large read-only data tables */ + /* that we'd rather not scan. */ +# endif + extern int _end; +# define DATAEND (&_end) +# else + extern int etext; +# define DATASTART ((ptr_t)((((word) (&etext)) + 0xfff) & ~0xfff)) +# endif +# endif +#endif + +#ifdef LINUX_DATA_START + /* Some Linux distributions arrange to define __data_start. Some */ + /* define data_start as a weak symbol. The latter is technically */ + /* broken, since the user program may define data_start, in which */ + /* case we lose. Nonetheless, we try both, prefering __data_start. */ + /* We assume gcc. */ +# pragma weak __data_start + extern int __data_start; +# pragma weak data_start + extern int data_start; +# define DATASTART ((ptr_t)(&__data_start != 0? &__data_start : &data_start)) +#endif + +# ifndef STACK_GROWS_UP +# define STACK_GROWS_DOWN +# endif + +# ifndef CPP_WORDSZ +# define CPP_WORDSZ 32 +# endif + +# ifndef OS_TYPE +# define OS_TYPE "" +# endif + +# ifndef DATAEND + extern int end; +# define DATAEND (&end) +# endif + +# if defined(SVR4) && !defined(GETPAGESIZE) +# include +# define GETPAGESIZE() sysconf(_SC_PAGESIZE) +# endif + +# ifndef GETPAGESIZE +# if defined(SUNOS5) || defined(IRIX5) +# include +# endif +# define GETPAGESIZE() getpagesize() +# endif + +# if defined(SUNOS5) || defined(DRSNX) || defined(UTS4) + /* OS has SVR4 generic features. Probably others also qualify. */ +# define SVR4 +# endif + +# if defined(SUNOS5) || defined(DRSNX) + /* OS has SUNOS5 style semi-undocumented interface to dynamic */ + /* loader. */ +# define SUNOS5DL + /* OS has SUNOS5 style signal handlers. */ +# define SUNOS5SIGS +# endif + +# if defined(HPUX) +# define SUNOS5SIGS +# endif + +# if CPP_WORDSZ != 32 && CPP_WORDSZ != 64 + -> bad word size +# endif + +# ifdef PCR +# undef DYNAMIC_LOADING +# undef STACKBOTTOM +# undef HEURISTIC1 +# undef HEURISTIC2 +# undef PROC_VDB +# undef MPROTECT_VDB +# define PCR_VDB +# endif + +# ifdef SRC_M3 +/* Postponed for now. */ +# undef PROC_VDB +# undef MPROTECT_VDB +# endif + +# ifdef SMALL_CONFIG +/* Presumably not worth the space it takes. */ +# undef PROC_VDB +# undef MPROTECT_VDB +# endif + +# ifdef USE_MUNMAP +# undef MPROTECT_VDB /* Can't deal with address space holes. */ +# endif + +# if !defined(PCR_VDB) && !defined(PROC_VDB) && !defined(MPROTECT_VDB) +# define DEFAULT_VDB +# endif + +# ifndef PREFETCH +# define PREFETCH(x) +# define NO_PREFETCH +# endif + +# ifndef PREFETCH_FOR_WRITE +# define PREFETCH_FOR_WRITE(x) +# define NO_PREFETCH_FOR_WRITE +# endif + +# ifndef CACHE_LINE_SIZE +# define CACHE_LINE_SIZE 32 /* Wild guess */ +# endif + +# ifndef CLEAR_DOUBLE +# define CLEAR_DOUBLE(x) \ + ((word*)x)[0] = 0; \ + ((word*)x)[1] = 0; +# endif /* CLEAR_DOUBLE */ + +# if defined(_SOLARIS_PTHREADS) && !defined(SOLARIS_THREADS) +# define SOLARIS_THREADS +# endif +# if defined(IRIX_THREADS) && !defined(IRIX5) +--> inconsistent configuration +# endif +# if defined(IRIX_JDK_THREADS) && !defined(IRIX5) +--> inconsistent configuration +# endif +# if defined(LINUX_THREADS) && !defined(LINUX) +--> inconsistent configuration +# endif +# if defined(SOLARIS_THREADS) && !defined(SUNOS5) +--> inconsistent configuration +# endif +# if defined(HPUX_THREADS) && !defined(HPUX) +--> inconsistent configuration +# endif +# if defined(PCR) || defined(SRC_M3) || \ + defined(SOLARIS_THREADS) || defined(WIN32_THREADS) || \ + defined(IRIX_THREADS) || defined(LINUX_THREADS) || \ + defined(IRIX_JDK_THREADS) || defined(HPUX_THREADS) +# define THREADS +# endif + +# if defined(HP_PA) || defined(M88K) || defined(POWERPC) \ + || (defined(I386) && defined(OS2)) || defined(UTS4) || defined(LINT) + /* Use setjmp based hack to mark from callee-save registers. */ +# define USE_GENERIC_PUSH_REGS +# endif +# if defined(SPARC) && !defined(LINUX) +# define SAVE_CALL_CHAIN +# define ASM_CLEAR_CODE /* Stack clearing is crucial, and we */ + /* include assembly code to do it well. */ +# endif + +# if defined(LINUX) && !defined(POWERPC) +# include +# if (LINUX_VERSION_CODE <= 0x10400) + /* Ugly hack to get struct sigcontext_struct definition. Required */ + /* for some early 1.3.X releases. Will hopefully go away soon. */ + /* in some later Linux releases, asm/sigcontext.h may have to */ + /* be included instead. */ +# define __KERNEL__ +# include +# undef __KERNEL__ +# else + /* Kernels prior to 2.1.1 defined struct sigcontext_struct instead of */ + /* struct sigcontext. libc6 (glibc2) uses "struct sigcontext" in */ + /* prototypes, so we have to include the top-level sigcontext.h to */ + /* make sure the former gets defined to be the latter if appropriate. */ +# include +# if 2 <= __GLIBC__ +# if 2 == __GLIBC__ && 0 == __GLIBC_MINOR__ + /* glibc 2.1 no longer has sigcontext.h. But signal.h */ + /* has the right declaration for glibc 2.1. */ +# include +# endif /* 0 == __GLIBC_MINOR__ */ +# else /* not 2 <= __GLIBC__ */ + /* libc5 doesn't have : go directly with the kernel */ + /* one. Check LINUX_VERSION_CODE to see which we should reference. */ +# include +# endif /* 2 <= __GLIBC__ */ +# endif +# endif +# if !defined(OS2) && !defined(PCR) && !defined(AMIGA) && !defined(MACOS) +# include +# if !defined(MSWIN32) && !defined(SUNOS4) +# include +# endif +# endif + +# include +# include + +/* Blatantly OS dependent routines, except for those that are related */ +/* to dynamic loading. */ + +# if !defined(THREADS) && !defined(STACKBOTTOM) && defined(HEURISTIC2) +# define NEED_FIND_LIMIT +# endif + +# if defined(IRIX_THREADS) || defined(HPUX_THREADS) +# define NEED_FIND_LIMIT +# endif + +# if (defined(SUNOS4) && defined(DYNAMIC_LOADING)) && !defined(PCR) +# define NEED_FIND_LIMIT +# endif + +# if (defined(SVR4) || defined(AUX) || defined(DGUX)) && !defined(PCR) +# define NEED_FIND_LIMIT +# endif + +# if defined(LINUX) && \ + (defined(POWERPC) || defined(SPARC) || defined(ALPHA) || defined(IA64) \ + || defined(MIPS)) +# define NEED_FIND_LIMIT +# endif + +#ifdef NEED_FIND_LIMIT +# include +#endif + +#ifdef FREEBSD +# include +#endif + +#ifdef AMIGA +# include +# include +# include +# include +#endif + +#ifdef MSWIN32 +# define WIN32_LEAN_AND_MEAN +# define NOSERVICE +# include +#endif + +#ifdef MACOS +# include +#endif + +#ifdef IRIX5 +# include +# include /* for locking */ +#endif +#ifdef USE_MMAP +# include +# include +# include +# include +#endif + +#ifdef SUNOS5SIGS +# include +# undef setjmp +# undef longjmp +# define setjmp(env) sigsetjmp(env, 1) +# define longjmp(env, val) siglongjmp(env, val) +# define jmp_buf sigjmp_buf +#endif + +#ifdef DJGPP + /* Apparently necessary for djgpp 2.01. May casuse problems with */ + /* other versions. */ + typedef long unsigned int caddr_t; +#endif + +#ifdef PCR +# include "il/PCR_IL.h" +# include "th/PCR_ThCtl.h" +# include "mm/PCR_MM.h" +#endif + +#if !defined(NO_EXECUTE_PERMISSION) +# define OPT_PROT_EXEC PROT_EXEC +#else +# define OPT_PROT_EXEC 0 +#endif + +# ifdef OS2 + +# include + +# if !defined(__IBMC__) && !defined(__WATCOMC__) /* e.g. EMX */ + +# else /* IBM's compiler */ + +/* A kludge to get around what appears to be a header file bug */ +# ifndef WORD +# define WORD unsigned short +# endif +# ifndef DWORD +# define DWORD unsigned long +# endif + +# define EXE386 1 +# include +# include + +# endif /* __IBMC__ */ + +# define INCL_DOSEXCEPTIONS +# define INCL_DOSPROCESS +# define INCL_DOSERRORS +# define INCL_DOSMODULEMGR +# define INCL_DOSMEMMGR +# include + +# endif /*!OS/2 */ + +/* + * Find the base of the stack. + * Used only in single-threaded environment. + * With threads, GC_mark_roots needs to know how to do this. + * Called with allocator lock held. + */ +# ifdef MSWIN32 +# define is_writable(prot) ((prot) == PAGE_READWRITE \ + || (prot) == PAGE_WRITECOPY \ + || (prot) == PAGE_EXECUTE_READWRITE \ + || (prot) == PAGE_EXECUTE_WRITECOPY) +/* Return the number of bytes that are writable starting at p. */ +/* The pointer p is assumed to be page aligned. */ +/* If base is not 0, *base becomes the beginning of the */ +/* allocation region containing p. */ +static word GC_get_writable_length(ptr_t p, ptr_t *base) { - return NULL; + MEMORY_BASIC_INFORMATION buf; + word result; + word protect; + + result = VirtualQuery(p, &buf, sizeof(buf)); + if (result != sizeof(buf)) ABORT("Weird VirtualQuery result"); + if (base != 0) *base = (ptr_t)(buf.AllocationBase); + protect = (buf.Protect & ~(PAGE_GUARD | PAGE_NOCACHE)); + if (!is_writable(protect)) { + return(0); + } + if (buf.State != MEM_COMMIT) return(0); + return(buf.RegionSize); } + +void *scm_get_stack_base() +{ + int dummy; + ptr_t sp = (ptr_t)(&dummy); + ptr_t trunc_sp = (ptr_t)((word)sp & ~(GC_page_size - 1)); + word size = GC_get_writable_length(trunc_sp, 0); + + return(trunc_sp + size); +} + + +# else + +# ifdef OS2 + +void *scm_get_stack_base() +{ + PTIB ptib; + PPIB ppib; + + if (DosGetInfoBlocks(&ptib, &ppib) != NO_ERROR) { + GC_err_printf0("DosGetInfoBlocks failed\n"); + ABORT("DosGetInfoBlocks failed\n"); + } + return((ptr_t)(ptib -> tib_pstacklimit)); +} + +# else + +# ifdef AMIGA + +void *scm_get_stack_base() +{ + struct Process *proc = (struct Process*)SysBase->ThisTask; + + /* Reference: Amiga Guru Book Pages: 42,567,574 */ + if (proc->pr_Task.tc_Node.ln_Type==NT_PROCESS + && proc->pr_CLI != NULL) { + /* first ULONG is StackSize */ + /*longPtr = proc->pr_ReturnAddr; + size = longPtr[0];*/ + + return (char *)proc->pr_ReturnAddr + sizeof(ULONG); + } else { + return (char *)proc->pr_Task.tc_SPUpper; + } +} + +#if 0 /* old version */ +void *scm_get_stack_base() +{ + extern struct WBStartup *_WBenchMsg; + extern long __base; + extern long __stack; + struct Task *task; + struct Process *proc; + struct CommandLineInterface *cli; + long size; + + if ((task = FindTask(0)) == 0) { + GC_err_puts("Cannot find own task structure\n"); + ABORT("task missing"); + } + proc = (struct Process *)task; + cli = BADDR(proc->pr_CLI); + + if (_WBenchMsg != 0 || cli == 0) { + size = (char *)task->tc_SPUpper - (char *)task->tc_SPLower; + } else { + size = cli->cli_DefaultStack * 4; + } + return (ptr_t)(__base + GC_max(size, __stack)); +} +#endif /* 0 */ + +# else /* !AMIGA, !OS2, ... */ + +# ifdef NEED_FIND_LIMIT + /* Some tools to implement HEURISTIC2 */ +# define MIN_PAGE_SIZE 256 /* Smallest conceivable page size, bytes */ + /* static */ jmp_buf GC_jmp_buf; + + /*ARGSUSED*/ + static void GC_fault_handler(sig) + int sig; + { + longjmp(GC_jmp_buf, 1); + } + +# ifdef __STDC__ + typedef void (*handler)(int); +# else + typedef void (*handler)(); +# endif + +# if defined(SUNOS5SIGS) || defined(IRIX5) || defined(OSF1) + static struct sigaction old_segv_act; +# if defined(_sigargs) || defined(HPUX) /* !Irix6.x */ + static struct sigaction old_bus_act; +# endif +# else + static handler old_segv_handler, old_bus_handler; +# endif + + static void GC_setup_temporary_fault_handler() + { +# if defined(SUNOS5SIGS) || defined(IRIX5) || defined(OSF1) + struct sigaction act; + + act.sa_handler = GC_fault_handler; + act.sa_flags = SA_RESTART | SA_NODEFER; + /* The presence of SA_NODEFER represents yet another gross */ + /* hack. Under Solaris 2.3, siglongjmp doesn't appear to */ + /* interact correctly with -lthread. We hide the confusion */ + /* by making sure that signal handling doesn't affect the */ + /* signal mask. */ + + (void) sigemptyset(&act.sa_mask); +# ifdef IRIX_THREADS + /* Older versions have a bug related to retrieving and */ + /* and setting a handler at the same time. */ + (void) sigaction(SIGSEGV, 0, &old_segv_act); + (void) sigaction(SIGSEGV, &act, 0); +# else + (void) sigaction(SIGSEGV, &act, &old_segv_act); +# if defined(IRIX5) && defined(_sigargs) /* Irix 5.x, not 6.x */ \ + || defined(HPUX) + /* Under Irix 5.x or HP/UX, we may get SIGBUS. */ + /* Pthreads doesn't exist under Irix 5.x, so we */ + /* don't have to worry in the threads case. */ + (void) sigaction(SIGBUS, &act, &old_bus_act); +# endif +# endif /* IRIX_THREADS */ +# else + old_segv_handler = signal(SIGSEGV, GC_fault_handler); +# ifdef SIGBUS + old_bus_handler = signal(SIGBUS, GC_fault_handler); +# endif +# endif + } + + static void GC_reset_fault_handler() + { +# if defined(SUNOS5SIGS) || defined(IRIX5) || defined(OSF1) + (void) sigaction(SIGSEGV, &old_segv_act, 0); +# if defined(IRIX5) && defined(_sigargs) /* Irix 5.x, not 6.x */ \ + || defined(HPUX) + (void) sigaction(SIGBUS, &old_bus_act, 0); +# endif +# else + (void) signal(SIGSEGV, old_segv_handler); +# ifdef SIGBUS + (void) signal(SIGBUS, old_bus_handler); +# endif +# endif + } + + /* Return the first nonaddressible location > p (up) or */ + /* the smallest location q s.t. [q,p] is addressible (!up). */ + static ptr_t GC_find_limit(p, up) + ptr_t p; + GC_bool up; + { + static VOLATILE ptr_t result; + /* Needs to be static, since otherwise it may not be */ + /* preserved across the longjmp. Can safely be */ + /* static since it's only called once, with the */ + /* allocation lock held. */ + + + GC_setup_temporary_fault_handler(); + if (setjmp(GC_jmp_buf) == 0) { + result = (ptr_t)(((word)(p)) + & ~(MIN_PAGE_SIZE-1)); + for (;;) { + if (up) { + result += MIN_PAGE_SIZE; + } else { + result -= MIN_PAGE_SIZE; + } + GC_noop1((word)(*result)); + } + } + GC_reset_fault_handler(); + if (!up) { + result += MIN_PAGE_SIZE; + } + return(result); + } +# endif + +#ifdef LINUX_STACKBOTTOM + +#include +#include +#include + +# define STAT_SKIP 27 /* Number of fields preceding startstack */ + /* field in /proc/self/stat */ + + static ptr_t GC_linux_stack_base(void) + { + /* We read the stack base value from /proc/self/stat. We do this */ + /* using direct I/O system calls in order to avoid calling malloc */ + /* in case REDIRECT_MALLOC is defined. */ +# define STAT_BUF_SIZE 4096 +# ifdef USE_LD_WRAP +# define STAT_READ __real_read +# else +# define STAT_READ read +# endif + char stat_buf[STAT_BUF_SIZE]; + int f; + char c; + word result = 0; + size_t i, buf_offset = 0; + + f = open("/proc/self/stat", O_RDONLY); + if (f < 0 || STAT_READ(f, stat_buf, STAT_BUF_SIZE) < 2 * STAT_SKIP) { + ABORT("Couldn't read /proc/self/stat"); + } + c = stat_buf[buf_offset++]; + /* Skip the required number of fields. This number is hopefully */ + /* constant across all Linux implementations. */ + for (i = 0; i < STAT_SKIP; ++i) { + while (isspace(c)) c = stat_buf[buf_offset++]; + while (!isspace(c)) c = stat_buf[buf_offset++]; + } + while (isspace(c)) c = stat_buf[buf_offset++]; + while (isdigit(c)) { + result *= 10; + result += c - '0'; + c = stat_buf[buf_offset++]; + } + close(f); + if (result < 0x10000000) ABORT("Absurd stack bottom value"); + return (ptr_t)result; + } + +#endif /* LINUX_STACKBOTTOM */ + +void *scm_get_stack_base() +{ + word dummy; + void *result = &dummy; /* initialize to silence compiler */ + +# define STACKBOTTOM_ALIGNMENT_M1 ((word)STACK_GRAN - 1) + +# ifdef STACKBOTTOM + return(STACKBOTTOM); +# else +# ifdef HEURISTIC1 +# ifdef STACK_GROWS_DOWN + result = (ptr_t)((((word)(&dummy)) + + STACKBOTTOM_ALIGNMENT_M1) + & ~STACKBOTTOM_ALIGNMENT_M1); +# else + result = (ptr_t)(((word)(&dummy)) + & ~STACKBOTTOM_ALIGNMENT_M1); +# endif +# endif /* HEURISTIC1 */ +# ifdef LINUX_STACKBOTTOM + result = GC_linux_stack_base(); +# endif +# ifdef HEURISTIC2 +# ifdef STACK_GROWS_DOWN + result = GC_find_limit((ptr_t)(&dummy), TRUE); +# ifdef HEURISTIC2_LIMIT + if (result > HEURISTIC2_LIMIT + && (ptr_t)(&dummy) < HEURISTIC2_LIMIT) { + result = HEURISTIC2_LIMIT; + } +# endif +# else + result = GC_find_limit((ptr_t)(&dummy), FALSE); +# ifdef HEURISTIC2_LIMIT + if (result < HEURISTIC2_LIMIT + && (ptr_t)(&dummy) > HEURISTIC2_LIMIT) { + result = HEURISTIC2_LIMIT; + } +# endif +# endif + +# endif /* HEURISTIC2 */ +# ifdef STACK_GROWS_DOWN + if (result == 0) result = (ptr_t)(signed_word)(-sizeof(ptr_t)); +# endif + return(result); +# endif /* STACKBOTTOM */ +} + +# endif /* ! AMIGA */ +# endif /* ! OS2 */ +# endif /* ! MSWIN32 */ From 66ca939218bad0a64ac7013f8f690e1c74101ee3 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 11 Oct 2000 19:28:52 +0000 Subject: [PATCH 0317/2047] *** empty log message *** --- libguile/ChangeLog | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index e0ee5922f..1c9e4f1c8 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2000-10-11 Marius Vollmer + + * gc_os_dep.c: Added real implementation based on code from Boehms + collector. This is not well tested yet. + + * gc.h (scm_get_stack_base): Added prototype. + * init.c (scm_get_stack_base): Removed prototype. + 2000-10-11 Dirk Herrmann * random.c (scm_seed_to_random_state): Replace SCM_LENGTH with From a8a11001f95166da63c89f1937e72861b6f79a16 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 12 Oct 2000 07:59:02 +0000 Subject: [PATCH 0318/2047] * Fixed include file problem reported by Bruce Korb. --- libguile/ChangeLog | 5 +++++ libguile/alloca.c | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 1c9e4f1c8..d967a5457 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-10-11 Dirk Herrmann + + * alloca.c: Fixed include file path. Thanks to Bruce Korb for + the bug report. + 2000-10-11 Marius Vollmer * gc_os_dep.c: Added real implementation based on code from Boehms diff --git a/libguile/alloca.c b/libguile/alloca.c index b93fbe51e..8173cb6bc 100644 --- a/libguile/alloca.c +++ b/libguile/alloca.c @@ -25,7 +25,7 @@ gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #ifdef HAVE_CONFIG_H -#include +#include "libguile/scmconfig.h" #endif #ifdef HAVE_STRING_H From daa6ba187b62c0523d250cb55c6c8d21a9e05ef6 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 13 Oct 2000 07:55:25 +0000 Subject: [PATCH 0319/2047] * Deprecated scm_sloppy_mem(q|v|ber) --- NEWS | 4 ++++ RELEASE | 1 + libguile/ChangeLog | 7 +++++++ libguile/list.c | 37 ++++++++++++++++++++++++------------- libguile/list.h | 6 +++--- test-suite/ChangeLog | 4 ++++ test-suite/tests/list.test | 9 --------- 7 files changed, 43 insertions(+), 25 deletions(-) diff --git a/NEWS b/NEWS index 8be7fc6ea..893e5df6e 100644 --- a/NEWS +++ b/NEWS @@ -100,6 +100,10 @@ internally, combined with a copy-on-write strategy. The concept of read-only strings will disappear in next release of Guile. +** Deprecated: scm_sloppy_memq, scm_sloppy_memv, scm_sloppy_member + +Instead, use scm_memq, scm_memv, scm_member. + * Changes to the gh_ interface * Changes to the scm_ interface diff --git a/RELEASE b/RELEASE index 5cf2ae6c9..0cc101543 100644 --- a/RELEASE +++ b/RELEASE @@ -60,6 +60,7 @@ In release 1.6: - remove scm_tc7_ssymbol - remove scm_tc7_msymbol - remove scm_tcs_symbols +- remove scm_sloppy_memq, scm_sloppy_memv, scm_sloppy_member Modules sort.c and random.c should be factored out into separate modules (but still be distributed with guile-core) when we get a new diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d967a5457..fc6ec2915 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2000-10-13 Dirk Herrmann + + * list.[ch] (scm_sloppy_memq, scm_sloppy_memv, scm_sloppy_member): + Deprecated. + + (scm_memq, scm_memv, scm_member): Inline the sloppy code. + 2000-10-11 Dirk Herrmann * alloca.c: Fixed include file path. Thanks to Bruce Korb for diff --git a/libguile/list.c b/libguile/list.c index 933b04adb..d4305ee1f 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -504,6 +504,8 @@ SCM_DEFINE (scm_list_copy, "list-copy", 1, 0, 0, /* membership tests (memq, memv, etc.) */ +#if SCM_DEBUG_DEPRECATED == 0 + SCM_DEFINE (scm_sloppy_memq, "sloppy-memq", 2, 0, 0, (SCM x, SCM lst), "This procedure behaves like @code{memq}, but does no type or error checking.\n" @@ -554,7 +556,7 @@ SCM_DEFINE (scm_sloppy_member, "sloppy-member", 2, 0, 0, } #undef FUNC_NAME - +#endif /* DEPRECATED */ SCM_DEFINE (scm_memq, "memq", 2, 0, 0, (SCM x, SCM lst), @@ -565,10 +567,13 @@ SCM_DEFINE (scm_memq, "memq", 2, 0, 0, "returned.") #define FUNC_NAME s_scm_memq { - SCM answer; - SCM_VALIDATE_LIST (2,lst); - answer = scm_sloppy_memq (x, lst); - return (SCM_NULLP (answer)) ? SCM_BOOL_F : answer; + SCM_VALIDATE_LIST (2, lst); + for (; !SCM_NULLP (lst); lst = SCM_CDR (lst)) + { + if (SCM_EQ_P (SCM_CAR (lst), x)) + return lst; + } + return SCM_BOOL_F; } #undef FUNC_NAME @@ -583,10 +588,13 @@ SCM_DEFINE (scm_memv, "memv", 2, 0, 0, "returned.") #define FUNC_NAME s_scm_memv { - SCM answer; - SCM_VALIDATE_LIST (2,lst); - answer = scm_sloppy_memv (x, lst); - return (SCM_NULLP (answer)) ? SCM_BOOL_F : answer; + SCM_VALIDATE_LIST (2, lst); + for (; !SCM_NULLP (lst); lst = SCM_CDR (lst)) + { + if (! SCM_FALSEP (scm_eqv_p (SCM_CAR (lst), x))) + return lst; + } + return SCM_BOOL_F; } #undef FUNC_NAME @@ -600,10 +608,13 @@ SCM_DEFINE (scm_member, "member", 2, 0, 0, "returned.") #define FUNC_NAME s_scm_member { - SCM answer; - SCM_VALIDATE_LIST (2,lst); - answer = scm_sloppy_member (x, lst); - return (SCM_NULLP (answer)) ? SCM_BOOL_F : answer; + SCM_VALIDATE_LIST (2, lst); + for (; !SCM_NULLP (lst); lst = SCM_CDR (lst)) + { + if (! SCM_FALSEP (scm_equal_p (SCM_CAR (lst), x))) + return lst; + } + return SCM_BOOL_F; } #undef FUNC_NAME diff --git a/libguile/list.h b/libguile/list.h index e484e434a..f24d54331 100644 --- a/libguile/list.h +++ b/libguile/list.h @@ -83,9 +83,6 @@ extern SCM scm_list_set_x (SCM lst, SCM k, SCM val); extern SCM scm_list_cdr_set_x (SCM lst, SCM k, SCM val); extern SCM scm_last_pair (SCM sx); extern SCM scm_list_tail (SCM lst, SCM k); -extern SCM scm_sloppy_memq (SCM x, SCM lst); -extern SCM scm_sloppy_memv (SCM x, SCM lst); -extern SCM scm_sloppy_member (SCM x, SCM lst); extern SCM scm_memq (SCM x, SCM lst); extern SCM scm_memv (SCM x, SCM lst); extern SCM scm_member (SCM x, SCM lst); @@ -106,6 +103,9 @@ extern void scm_init_list (void); #if (SCM_DEBUG_DEPRECATED == 0) #define scm_list_star scm_cons_star +extern SCM scm_sloppy_memq (SCM x, SCM lst); +extern SCM scm_sloppy_memv (SCM x, SCM lst); +extern SCM scm_sloppy_member (SCM x, SCM lst); #endif /* SCM_DEBUG_DEPRECATED == 0 */ diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 18b9582b8..6e58b99e5 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2000-10-13 Dirk Herrmann + + * tests/list.test: Removed references to sloppy-mem(q|v|ber) + 2000-09-26 Dirk Herrmann * tests/strings.test: Added a test to help remember that string=? diff --git a/test-suite/tests/list.test b/test-suite/tests/list.test index 99e9b3fec..734c50629 100644 --- a/test-suite/tests/list.test +++ b/test-suite/tests/list.test @@ -665,15 +665,6 @@ ;;; list-copy -;;; sloppy-memq - - -;;; sloppy-memv - - -;;; sloppy-member - - ;;; memq From b4ad0dda0666988b655842443376d90645a50533 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sun, 15 Oct 2000 22:33:06 +0000 Subject: [PATCH 0320/2047] * Fix typos in optargs.scm. --- ice-9/ChangeLog | 4 ++++ ice-9/optargs.scm | 4 ++-- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index b19c0f61f..8a67766ab 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2000-10-15 Neil Jerram + + * optargs.scm: Fix typos in commentary for bound? and lambda*. + 2000-10-10 Dirk Herrmann * session.scm (apropos, apropos-fold): regexp-exec does not diff --git a/ice-9/optargs.scm b/ice-9/optargs.scm index 8b74d9127..5de0fa43a 100644 --- a/ice-9/optargs.scm +++ b/ice-9/optargs.scm @@ -65,7 +65,7 @@ ;; Checks if a variable is bound in the current environment. ;; ;; defined? doesn't quite cut it as it stands, since it only -;; cheks bindings in the top-level environment, not those in +;; checks bindings in the top-level environment, not those in ;; local scope only. ;; @@ -243,7 +243,7 @@ ;; lambda*-defined procedures now throw an error by default if a ;; keyword other than one of those specified is found in the actual ;; passed arguments. However, specifying #:allow-other-keys -;; immediately after the kyword argument declarations restores the +;; immediately after the keyword argument declarations restores the ;; previous behavior of ignoring unknown keywords. lambda* also now ;; guarantees that if the same keyword is passed more than once, the ;; last one passed is the one that takes effect. For example, From a3487916d04ea16af7d1d7f12aa9dfefa074d671 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 18 Oct 2000 18:27:55 +0000 Subject: [PATCH 0321/2047] * gc_os_dep.c (GC_noop1, GC_bool, TRUE, FALSE, VOLATILE): Definitions copied from Boehm collector. --- libguile/gc_os_dep.c | 28 +++++++++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/libguile/gc_os_dep.c b/libguile/gc_os_dep.c index f0e37bc9a..4ce37ec2e 100644 --- a/libguile/gc_os_dep.c +++ b/libguile/gc_os_dep.c @@ -17,7 +17,7 @@ */ /* - * Copied from gc5.2, files "os_dep.c", "gc_priv.h"and "gcconfig.h", + * Copied from gc5.2, files "os_dep.c", "gc_priv.h", "mark.c" and "gcconfig.h", * and modified for Guile by Marius Vollmer. */ @@ -45,6 +45,32 @@ typedef long GC_signed_word; typedef GC_word word; typedef GC_signed_word signed_word; +typedef int GC_bool; +# define TRUE 1 +# define FALSE 0 + +#if defined(__STDC__) +# include +# if !(defined( sony_news ) ) +# include +# endif +# define VOLATILE volatile +#else +# ifdef MSWIN32 +# include +# endif +# define VOLATILE +#endif + +/* Single argument version, robust against whole program analysis. */ +static void GC_noop1(x) +word x; +{ + static VOLATILE word sink; + + sink = x; +} + /* Machine dependent parameters. Some tuning parameters can be found */ /* near the top of gc_private.h. */ From 0100535b2cd2f80e02f0042366938c45d187b5a1 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 18 Oct 2000 18:28:19 +0000 Subject: [PATCH 0322/2047] *** empty log message *** --- libguile/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index fc6ec2915..bdba91875 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-10-18 Marius Vollmer + + * gc_os_dep.c (GC_noop1, GC_bool, TRUE, FALSE, VOLATILE): + Definitions copied from Boehm collector. + 2000-10-13 Dirk Herrmann * list.[ch] (scm_sloppy_memq, scm_sloppy_memv, scm_sloppy_member): From 5264d62116ecc291b2a5ad35c7059f46939a60f0 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 18 Oct 2000 21:05:57 +0000 Subject: [PATCH 0323/2047] * print.c (grow_ref_stack): Pass a INUM to scm_make_vector as the size, not a naked int. Thanks to Brat Knotwell! --- libguile/print.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/print.c b/libguile/print.c index 9bd447815..37874187f 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -262,7 +262,7 @@ grow_ref_stack (scm_print_state *pstate) unsigned long int old_size = SCM_VECTOR_LENGTH (pstate->ref_vect); SCM *old_elts = SCM_VELTS (pstate->ref_vect); unsigned long int new_size = 2 * pstate->ceiling; - SCM new_vect = scm_make_vector (new_size, SCM_UNDEFINED); + SCM new_vect = scm_make_vector (SCM_MAKINUM (new_size), SCM_UNDEFINED); SCM *new_elts = SCM_VELTS (new_vect); unsigned long int i; From c6ba6ce6e3538fd31b54bacff0fbcec9a7b0bcdd Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 18 Oct 2000 21:06:21 +0000 Subject: [PATCH 0324/2047] *** empty log message *** --- libguile/ChangeLog | 3 +++ 1 file changed, 3 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index bdba91875..baedc6ea1 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,8 @@ 2000-10-18 Marius Vollmer + * print.c (grow_ref_stack): Pass a INUM to scm_make_vector as the + size, not a naked int. Thanks to Brat Knotwell! + * gc_os_dep.c (GC_noop1, GC_bool, TRUE, FALSE, VOLATILE): Definitions copied from Boehm collector. From 612a55e5e3cb1c41660757eb879c46a2664785ce Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 20 Oct 2000 00:31:29 +0000 Subject: [PATCH 0325/2047] * init.c (scm_init_guile_1, invoke_main_func): Call scm_load_startup_files in scm_init_guile_1, not in invoke_main_func. --- libguile/init.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/libguile/init.c b/libguile/init.c index 60ea523a6..955cd8d9a 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -594,6 +594,7 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; #endif + scm_load_startup_files (); } /* Record here whether SCM_BOOT_GUILE_1 has already been called. This @@ -635,8 +636,6 @@ invoke_main_func (void *body_data) { struct main_func_closure *closure = (struct main_func_closure *) body_data; - scm_load_startup_files (); - (*closure->main_func) (closure->closure, closure->argc, closure->argv); /* never reached */ From f8fa3e387c75918cbdf24a8432367713387139cb Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 20 Oct 2000 00:32:00 +0000 Subject: [PATCH 0326/2047] *** empty log message *** --- libguile/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index baedc6ea1..1f7fdc2dc 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2000-10-20 Marius Vollmer + + * init.c (scm_init_guile_1, invoke_main_func): Call + scm_load_startup_files in scm_init_guile_1, not in + invoke_main_func. + 2000-10-18 Marius Vollmer * print.c (grow_ref_stack): Pass a INUM to scm_make_vector as the From 31535422f5aa27febb86fbbf1030c2e2aa35e9f1 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Oct 2000 20:37:00 +0000 Subject: [PATCH 0327/2047] Corrected "Brat" to "Brad". Sorry. --- libguile/ChangeLog | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 1f7fdc2dc..89fd9cd16 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -7,7 +7,7 @@ 2000-10-18 Marius Vollmer * print.c (grow_ref_stack): Pass a INUM to scm_make_vector as the - size, not a naked int. Thanks to Brat Knotwell! + size, not a naked int. Thanks to Brad Knotwell! * gc_os_dep.c (GC_noop1, GC_bool, TRUE, FALSE, VOLATILE): Definitions copied from Boehm collector. From d1ca2c64230419163f7ad80436e83bd74fdb7b95 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 25 Oct 2000 11:01:03 +0000 Subject: [PATCH 0328/2047] * Some more work to get rid of SCM_LENGTH * Eliminated some cell type bit fiddling * Various minor changes --- NEWS | 5 ++++- RELEASE | 8 ++------ libguile/ChangeLog | 50 +++++++++++++++++++++++++++++++++++++++++++++ libguile/alist.c | 12 +++++++++++ libguile/async.c | 2 +- libguile/dynl.c | 2 +- libguile/eval.c | 2 +- libguile/filesys.c | 18 ++++++++-------- libguile/fports.c | 4 ++-- libguile/gc.c | 2 +- libguile/gc.h | 13 +++++++++--- libguile/hash.c | 2 +- libguile/posix.c | 2 +- libguile/print.c | 4 ++-- libguile/read.c | 2 +- libguile/root.c | 2 -- libguile/root.h | 3 --- libguile/simpos.c | 4 ++-- libguile/strings.c | 20 +++++++++--------- libguile/strop.c | 4 ++-- libguile/struct.c | 6 +++--- libguile/symbols.c | 8 ++++---- libguile/symbols.h | 2 +- libguile/tags.h | 1 + libguile/validate.h | 16 ++++++++------- 25 files changed, 129 insertions(+), 65 deletions(-) diff --git a/NEWS b/NEWS index 893e5df6e..9ecf98e1c 100644 --- a/NEWS +++ b/NEWS @@ -140,11 +140,14 @@ of this variable is (and has been) not fully safe anyway. ** Deprecated macros: SCM_OUTOFRANGE, SCM_NALLOC, SCM_HUP_SIGNAL, SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD, -SCM_ORD_SIG, SCM_NUM_SIGS, SCM_SYMBOL_SLOTS, SCM_SLOTS, SCM_SLOPPY_STRINGP +SCM_ORD_SIG, SCM_NUM_SIGS, SCM_SYMBOL_SLOTS, SCM_SLOTS, SCM_SLOPPY_STRINGP, +SCM_VALIDATE_STRINGORSUBSTR, SCM_FREEP, SCM_NFREEP Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of SCM_OUTOFRANGE. Use scm_memory_error instead of SCM_NALLOC. Use SCM_STRINGP instead of SCM_SLOPPY_STRINGP. +Use SCM_VALIDATE_STRING instead of SCM_VALIDATE_STRINGORSUBSTR. +Use SCM_FREE_CELL_P instead of SCM_FREEP/SCM_NFREEP ** Removed function: scm_struct_init diff --git a/RELEASE b/RELEASE index 0cc101543..fdcadf848 100644 --- a/RELEASE +++ b/RELEASE @@ -9,11 +9,6 @@ for." * Deprecate `read-only-string?'. -Before releasing the next version of libguile which is not binary compatible -with the one released with 1.4: -- remove struct members system_transformer and top_level_lookup_closure_var - from struct scm_root_state in root.h. - After signal handling and threading have been fixed: - remove the code corresponding to GUILE_OLD_ASYNC_CLICK and the corresponding GUILE_OLD_ASYNC_CLICK macro. @@ -50,7 +45,8 @@ In release 1.6: - remove deprecated macros: SCM_OUTOFRANGE, SCM_NALLOC, SCM_HUP_SIGNAL, SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD, - SCM_ORD_SIG, SCM_NUM_SIGS, SCM_SLOPPY_STRINGP + SCM_ORD_SIG, SCM_NUM_SIGS, SCM_SLOPPY_STRINGP, SCM_VALIDATE_STRINGORSUBSTR, + SCM_FREEP, SCM_NFREEP - remove function scm_call_catching_errors (replaced by catch functions from throw.[ch]) - remove support for "#&" reader syntax in (ice-9 optargs). diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 89fd9cd16..c4251bc3d 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,53 @@ +2000-10-25 Dirk Herrmann + + * alist.c (scm_assq_ref): Add a suggestion about how to deal with + this function when the API gets reviewed. + + * async.c (SET_ASYNC_GOT_IT): Use SCM_TYP16 instead of doing bit + operations directly. + + * dynl.c (scm_coerce_rostring), filesys.c (scm_link, + scm_copy_file), fports (scm_open_file), hash.c (scm_hasher), + posix.c (scm_getpwuid), print.c (scm_iprin1), simpos.c + (scm_system), strings.c (scm_string_ref, scm_substring, + scm_string_append), strop.c (scm_string_copy), struct.c + (scm_make_struct_layout), symbols.c (scm_gensym, scm_gentemp), + symbols.h (SCM_COERCE_SUBSTR): Use SCM_STRING_LENGTH instead of + SCM_ROLENGTH if the object is known to be a string or substring. + + * eval.c (scm_lookupcar): Use SCM_ITAG7 instead of doing bit + operations directly. + + * filesys.c (scm_dirname, scm_basename): Don't create shared + substrings as these are going to disappear from guile. + + * gc.c (scm_gc_sweep): Use SCM_UVECTOR_LENGTH instead of + SCM_HUGE_LENGTH. (The SCM_HUGE_LENGTH mechanism does not work + correctly anyway.) + + * gc.h (SCM_FREEP, SCM_NFREEP): Deprecated. + + * read.c (scm_flush_ws): Don't compare SCM values directly. + + * root.c (scm_make_root), root.h (scm_root_state): Removed + system_transformer and top_level_lookup_closure_var from struct. + (Since eval is now R5RS, binary compatibility is not granted + anyway.) + + * simpos.c (scm_system): Fix condition. + + * strings.c (scm_string_length, scm_string_ref, scm_substring, + scm_string_append), strop.c (scm_string_copy), struct.c + (scm_make_struct_layout, scm_make_vtable_vtable), symbols.c + (scm_gensym, scm_gentemp): Replace SCM_VALIDATE_STRINGORSUBSTR + with SCM_VALIDATE_STRING, since they do the same thing. + + * strings.h (scm_make_shared_substring): Deprecated. + + * tags.h (SCM_ITAG7): Added. + + * validated.h (SCM_VALIDATE_STRINGORSUBSTR): Deprecated. + 2000-10-20 Marius Vollmer * init.c (scm_init_guile_1, invoke_main_func): Call diff --git a/libguile/alist.c b/libguile/alist.c index 7e1414ec9..31a9aabda 100644 --- a/libguile/alist.c +++ b/libguile/alist.c @@ -207,6 +207,18 @@ SCM_DEFINE (scm_assoc, "assoc", 2, 0, 0, +/* Dirk:API2.0:: We should not return #f if the key was not found. In the + * current solution we can not distinguish between finding a (key . #f) pair + * and not finding the key at all. + * + * Possible alternative solutions: + * 1) Remove assq-ref from the API: assq is sufficient. + * 2) Signal an error (what error type?) if the key is not found. + * 3) provide an additional 'default' parameter. + * 3.1) The default parameter is mandatory. + * 3.2) The default parameter is optional, but if no default is given and + * the key is not found, signal an error (what error type?). + */ SCM_DEFINE (scm_assq_ref, "assq-ref", 2, 0, 0, (SCM alist, SCM key), "@deffnx primitive assv-ref alist key\n" diff --git a/libguile/async.c b/libguile/async.c index 7c16cdddb..62008a39b 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -121,7 +121,7 @@ static long tc16_async; #define VALIDATE_ASYNC(pos,a) SCM_MAKE_VALIDATE(pos, a, ASYNCP) #define ASYNC_GOT_IT(X) (SCM_CELL_WORD_0 (X) >> 16) -#define SET_ASYNC_GOT_IT(X, V) (SCM_SET_CELL_WORD_0 (X, (SCM_CELL_WORD_0 (X) & ((1 << 16) - 1)) | ((V) << 16))) +#define SET_ASYNC_GOT_IT(X, V) (SCM_SET_CELL_WORD_0 ((X), SCM_TYP16 (X) | ((V) << 16))) #define ASYNC_THUNK(X) SCM_CELL_OBJECT_1 (X) diff --git a/libguile/dynl.c b/libguile/dynl.c index acd95486f..595517045 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -127,7 +127,7 @@ scm_coerce_rostring (SCM rostr,const char *subr,int argn) { SCM_ASSERT (SCM_ROSTRINGP (rostr), rostr, argn, subr); if (SCM_SUBSTRP (rostr)) - rostr = scm_makfromstr (SCM_ROCHARS (rostr), SCM_ROLENGTH (rostr), 0); + rostr = scm_makfromstr (SCM_ROCHARS (rostr), SCM_STRING_LENGTH (rostr), 0); return rostr; } diff --git a/libguile/eval.c b/libguile/eval.c index af200d3bb..5b89e197c 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -370,7 +370,7 @@ scm_lookupcar (SCM vloc, SCM genv, int check) if (SCM_ITAG3 (var) == scm_tc3_cons_gloc) return SCM_GLOC_VAL_LOC (var); #ifdef MEMOIZE_LOCALS - if ((SCM_UNPACK (var) & 127) == (127 & SCM_UNPACK (SCM_ILOC00))) + if (SCM_ITAG7 (var) == SCM_ITAG7 (SCM_ILOC00)) return scm_ilookup (var, genv); #endif /* We can't cope with anything else than glocs and ilocs. When diff --git a/libguile/filesys.c b/libguile/filesys.c index 4f282d438..c7de1c615 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -547,11 +547,11 @@ SCM_DEFINE (scm_link, "link", 2, 0, 0, SCM_VALIDATE_ROSTRING (1,oldpath); if (SCM_SUBSTRP (oldpath)) oldpath = scm_makfromstr (SCM_ROCHARS (oldpath), - SCM_ROLENGTH (oldpath), 0); + SCM_STRING_LENGTH (oldpath), 0); SCM_VALIDATE_ROSTRING (2,newpath); if (SCM_SUBSTRP (newpath)) newpath = scm_makfromstr (SCM_ROCHARS (newpath), - SCM_ROLENGTH (newpath), 0); + SCM_STRING_LENGTH (newpath), 0); SCM_SYSCALL (val = link (SCM_ROCHARS (oldpath), SCM_ROCHARS (newpath))); if (val != 0) SCM_SYSERROR; @@ -1289,10 +1289,10 @@ SCM_DEFINE (scm_copy_file, "copy-file", 2, 0, 0, SCM_VALIDATE_ROSTRING (1,oldfile); if (SCM_SUBSTRP (oldfile)) - oldfile = scm_makfromstr (SCM_ROCHARS (oldfile), SCM_ROLENGTH (oldfile), 0); + oldfile = scm_makfromstr (SCM_ROCHARS (oldfile), SCM_STRING_LENGTH (oldfile), 0); SCM_VALIDATE_ROSTRING (2,newfile); if (SCM_SUBSTRP (newfile)) - newfile = scm_makfromstr (SCM_ROCHARS (newfile), SCM_ROLENGTH (newfile), 0); + newfile = scm_makfromstr (SCM_ROCHARS (newfile), SCM_STRING_LENGTH (newfile), 0); if (stat (SCM_ROCHARS (oldfile), &oldstat) == -1) SCM_SYSERROR; oldfd = open (SCM_ROCHARS (oldfile), O_RDONLY); @@ -1345,12 +1345,12 @@ SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0, if (i < 0) { if (len > 0 && s[0] == '/') - return scm_make_shared_substring (filename, SCM_INUM0, SCM_MAKINUM (1)); + return scm_substring (filename, SCM_INUM0, SCM_MAKINUM (1)); else return scm_dot_string; } else - return scm_make_shared_substring (filename, SCM_INUM0, SCM_MAKINUM (i + 1)); + return scm_substring (filename, SCM_INUM0, SCM_MAKINUM (i + 1)); } #undef FUNC_NAME @@ -1384,14 +1384,12 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0, if (i == end) { if (len > 0 && f[0] == '/') - return scm_make_shared_substring (filename, SCM_INUM0, SCM_MAKINUM (1)); + return scm_substring (filename, SCM_INUM0, SCM_MAKINUM (1)); else return scm_dot_string; } else - return scm_make_shared_substring (filename, - SCM_MAKINUM (i + 1), - SCM_MAKINUM (end + 1)); + return scm_substring (filename, SCM_MAKINUM (i + 1), SCM_MAKINUM (end + 1)); } #undef FUNC_NAME diff --git a/libguile/fports.c b/libguile/fports.c index 1b981e8f1..bd955e314 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -279,9 +279,9 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0, SCM_VALIDATE_ROSTRING (1,filename); SCM_VALIDATE_ROSTRING (2,modes); if (SCM_SUBSTRP (filename)) - filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0); + filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_STRING_LENGTH (filename), 0); if (SCM_SUBSTRP (modes)) - modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_ROLENGTH (modes), 0); + modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_STRING_LENGTH (modes), 0); file = SCM_ROCHARS (filename); mode = SCM_ROCHARS (modes); diff --git a/libguile/gc.c b/libguile/gc.c index 8ce64db8c..a136d1b59 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1639,7 +1639,7 @@ scm_gc_sweep () case scm_tc7_fvect: case scm_tc7_dvect: case scm_tc7_cvect: - m += SCM_HUGE_LENGTH (scmptr) * scm_uniform_element_size (scmptr); + m += SCM_UVECTOR_LENGTH (scmptr) * scm_uniform_element_size (scmptr); scm_must_free (SCM_UVECTOR_BASE (scmptr)); break; #endif diff --git a/libguile/gc.h b/libguile/gc.h index 97a47c49a..2db7fe755 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -280,9 +280,6 @@ typedef unsigned long scm_c_bvec_limb_t; #endif -#define SCM_FREEP(x) (SCM_FREE_CELL_P (x)) -#define SCM_NFREEP(x) (!SCM_FREEP (x)) - #define SCM_MARKEDP SCM_GCMARKP #define SCM_NMARKEDP(x) (!SCM_MARKEDP (x)) @@ -371,6 +368,16 @@ extern int scm_init_storage (scm_sizet init_heap_size, int trig, scm_sizet max_segment_size); extern void *scm_get_stack_base (void); extern void scm_init_gc (void); + + + +#if (SCM_DEBUG_DEPRECATED == 0) + +#define SCM_FREEP(x) (SCM_FREE_CELL_P (x)) +#define SCM_NFREEP(x) (!SCM_FREE_CELL_P (x)) + +#endif /* SCM_DEBUG_DEPRECATED == 0 */ + #endif /* GCH */ /* diff --git a/libguile/hash.c b/libguile/hash.c index 1bb4c2409..baf95532c 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -121,7 +121,7 @@ scm_hasher(SCM obj, unsigned long n, scm_sizet d) case scm_tc7_string: return scm_string_hash (SCM_STRING_UCHARS (obj), SCM_STRING_LENGTH (obj)) % n; case scm_tc7_substring: - return scm_string_hash (SCM_ROUCHARS (obj), SCM_ROLENGTH (obj)) % n; + return scm_string_hash (SCM_ROUCHARS (obj), SCM_STRING_LENGTH (obj)) % n; case scm_tc7_symbol: return SCM_SYMBOL_HASH (obj) % n; case scm_tc7_wvect: diff --git a/libguile/posix.c b/libguile/posix.c index 309fa7ab6..1782928a6 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -266,7 +266,7 @@ SCM_DEFINE (scm_getpwuid, "getpw", 0, 1, 0, { SCM_VALIDATE_ROSTRING (1,user); if (SCM_SUBSTRP (user)) - user = scm_makfromstr (SCM_ROCHARS (user), SCM_ROLENGTH (user), 0); + user = scm_makfromstr (SCM_ROCHARS (user), SCM_STRING_LENGTH (user), 0); entry = getpwnam (SCM_ROCHARS (user)); } if (!entry) diff --git a/libguile/print.c b/libguile/print.c index 37874187f..16ac4e4f4 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -477,7 +477,7 @@ taloop: scm_sizet i; scm_putc ('"', port); - for (i = 0; i < SCM_ROLENGTH (exp); ++i) + for (i = 0; i < SCM_STRING_LENGTH (exp); ++i) switch (SCM_ROCHARS (exp)[i]) { case '"': @@ -490,7 +490,7 @@ taloop: break; } else - scm_lfwrite (SCM_ROCHARS (exp), (scm_sizet) SCM_ROLENGTH (exp), + scm_lfwrite (SCM_ROCHARS (exp), (scm_sizet) SCM_STRING_LENGTH (exp), port); break; case scm_tc7_symbol: diff --git a/libguile/read.c b/libguile/read.c index a2caccb1a..367decb11 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -146,7 +146,7 @@ scm_flush_ws (SCM port, const char *eoferr) goteof: if (eoferr) { - if (SCM_FILENAME (port) != SCM_BOOL_F) + if (!SCM_FALSEP (SCM_FILENAME (port))) scm_misc_error (eoferr, "end of file in ~A", SCM_LIST1 (SCM_FILENAME (port))); diff --git a/libguile/root.c b/libguile/root.c index 58fcf75d3..821d6f1a6 100644 --- a/libguile/root.c +++ b/libguile/root.c @@ -142,8 +142,6 @@ scm_make_root (SCM parent) = root_state->def_errp = root_state->cur_loadp = root_state->fluids - = root_state->system_transformer - = root_state->top_level_lookup_closure_var = root_state->handle = root_state->parent = SCM_BOOL_F; diff --git a/libguile/root.h b/libguile/root.h index ef870854f..b06285b62 100644 --- a/libguile/root.h +++ b/libguile/root.h @@ -115,9 +115,6 @@ typedef struct scm_root_state SCM fluids; - SCM system_transformer; /* No longer used (but kept for binary compatibility) */ - SCM top_level_lookup_closure_var; /* No longer used (but kept for binary compatibility) */ - SCM handle; /* The root object for this root state */ SCM parent; /* The parent root object */ } scm_root_state; diff --git a/libguile/simpos.c b/libguile/simpos.c index 062853ae8..f8f1ab940 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -85,8 +85,8 @@ SCM_DEFINE (scm_system, "system", 0, 1, 0, SCM_VALIDATE_ROSTRING (1,cmd); SCM_DEFER_INTS; errno = 0; - if (SCM_ROSTRINGP (cmd)) - cmd = scm_makfromstr (SCM_ROCHARS (cmd), SCM_ROLENGTH (cmd), 0); + if (SCM_SUBSTRP (cmd)) + cmd = scm_makfromstr (SCM_ROCHARS (cmd), SCM_STRING_LENGTH (cmd), 0); rv = system(SCM_ROCHARS(cmd)); if (rv == -1 || (rv == 127 && errno != 0)) SCM_SYSERROR; diff --git a/libguile/strings.c b/libguile/strings.c index fc706393f..4b8d115e8 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -241,7 +241,7 @@ SCM_DEFINE (scm_string_length, "string-length", 1, 0, 0, "Returns the number of characters in STRING") #define FUNC_NAME s_scm_string_length { - SCM_VALIDATE_STRINGORSUBSTR (1, string); + SCM_VALIDATE_STRING (1, string); return SCM_MAKINUM (SCM_STRING_LENGTH (string)); } #undef FUNC_NAME @@ -254,9 +254,9 @@ SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0, { int idx; - SCM_VALIDATE_STRINGORSUBSTR (1, str); + SCM_VALIDATE_STRING (1, str); SCM_VALIDATE_INUM_COPY (2, k, idx); - SCM_ASSERT_RANGE (2, k, idx >= 0 && idx < SCM_ROLENGTH (str)); + SCM_ASSERT_RANGE (2, k, idx >= 0 && idx < SCM_STRING_LENGTH (str)); return SCM_MAKE_CHAR (SCM_ROUCHARS (str)[idx]); } #undef FUNC_NAME @@ -288,14 +288,14 @@ SCM_DEFINE (scm_substring, "substring", 2, 1, 0, long int from; long int to; - SCM_VALIDATE_STRINGORSUBSTR (1, str); + SCM_VALIDATE_STRING (1, str); SCM_VALIDATE_INUM (2, start); - SCM_VALIDATE_INUM_DEF (3, end, SCM_ROLENGTH (str)); + SCM_VALIDATE_INUM_DEF (3, end, SCM_STRING_LENGTH (str)); from = SCM_INUM (start); - SCM_ASSERT_RANGE (2, start, 0 <= from && from <= SCM_ROLENGTH (str)); + SCM_ASSERT_RANGE (2, start, 0 <= from && from <= SCM_STRING_LENGTH (str)); to = SCM_INUM (end); - SCM_ASSERT_RANGE (3, end, from <= to && to <= SCM_ROLENGTH (str)); + SCM_ASSERT_RANGE (3, end, from <= to && to <= SCM_STRING_LENGTH (str)); return scm_makfromstr (&SCM_ROCHARS (str)[from], (scm_sizet) (to - from), 0); } @@ -316,14 +316,14 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, SCM_VALIDATE_REST_ARGUMENT (args); for (l = args; !SCM_NULLP (l); l = SCM_CDR (l)) { s = SCM_CAR (l); - SCM_VALIDATE_STRINGORSUBSTR (SCM_ARGn,s); - i += SCM_ROLENGTH (s); + SCM_VALIDATE_STRING (SCM_ARGn,s); + i += SCM_STRING_LENGTH (s); } res = scm_makstr (i, 0); data = SCM_STRING_UCHARS (res); for (l = args;SCM_NIMP (l);l = SCM_CDR (l)) { s = SCM_CAR (l); - for (i = 0;i MAX_PREFIX_LENGTH) name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); strncpy (name, SCM_ROCHARS (prefix), len); @@ -871,8 +871,8 @@ SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0, } else { - SCM_VALIDATE_STRINGORSUBSTR (1, prefix); - len = SCM_ROLENGTH (prefix); + SCM_VALIDATE_STRING (1, prefix); + len = SCM_STRING_LENGTH (prefix); if (len > MAX_PREFIX_LENGTH) name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); strncpy (name, SCM_ROCHARS (prefix), len); diff --git a/libguile/symbols.h b/libguile/symbols.h index 64b319c25..3331bd63c 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -95,7 +95,7 @@ extern int scm_symhash_dim; #define SCM_COERCE_SUBSTR(x) { if (SCM_SUBSTRP (x)) \ x = scm_makfromstr (SCM_ROCHARS (x), \ - SCM_ROLENGTH (x), 0); } + SCM_STRING_LENGTH (x), 0); } diff --git a/libguile/tags.h b/libguile/tags.h index 05c21170d..7082603aa 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -316,6 +316,7 @@ typedef long scm_bits_t; */ +#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)) diff --git a/libguile/validate.h b/libguile/validate.h index 76277a43d..4115c8200 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -1,4 +1,4 @@ -/* $Id: validate.h,v 1.17 2000-10-09 16:27:24 dirk Exp $ */ +/* $Id: validate.h,v 1.18 2000-10-25 11:01:03 dirk Exp $ */ /* Copyright (C) 1999, 2000 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify @@ -144,12 +144,6 @@ #define SCM_VALIDATE_STRING(pos, str) SCM_MAKE_VALIDATE (pos, str, STRINGP) -#define SCM_VALIDATE_STRINGORSUBSTR(pos, str) \ - do { \ - SCM_ASSERT (SCM_STRINGP (str) || SCM_SUBSTRP (str), \ - str, pos, FUNC_NAME); \ - } while (0) - #define SCM_VALIDATE_STRING_COPY(pos, str, cvar) \ do { \ SCM_ASSERT (SCM_STRINGP (str), str, pos, FUNC_NAME); \ @@ -416,6 +410,14 @@ SCM_ASSERT (SCM_VECTORP (v) && len == SCM_VECTOR_LENGTH (v), v, pos, FUNC_NAME); \ } while (0) + + +#if (SCM_DEBUG_DEPRECATED == 0) + +#define SCM_VALIDATE_STRINGORSUBSTR SCM_VALIDATE_STRING + +#endif /* SCM_DEBUG_DEPRECATED == 0 */ + #endif /* From c7ec8671f84cadaebdbbf43731071c77147d9270 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 25 Oct 2000 11:13:15 +0000 Subject: [PATCH 0329/2047] * Forgot to check this in with the last bunch of files. --- libguile/strings.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/strings.h b/libguile/strings.h index 6cc64aa5b..e6a9cf8b6 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -77,7 +77,6 @@ extern SCM scm_string_ref (SCM str, SCM k); extern SCM scm_string_set_x (SCM str, SCM k, SCM chr); extern SCM scm_substring (SCM str, SCM start, SCM end); extern SCM scm_string_append (SCM args); -extern SCM scm_make_shared_substring (SCM str, SCM frm, SCM to); extern void scm_init_strings (void); @@ -87,6 +86,7 @@ extern void scm_init_strings (void); #define SCM_SLOPPY_STRINGP(x) (SCM_STRINGP(x)) #define SCM_NSTRINGP(x) (!SCM_STRINGP(x)) #define SCM_NRWSTRINGP(x) (! SCM_RWSTRINGP (x)) +extern SCM scm_make_shared_substring (SCM str, SCM frm, SCM to); #endif /* SCM_DEBUG_DEPRECATED == 0 */ From 1b9be268c822e810432a215d8ea2ef57fe24d939 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 25 Oct 2000 12:58:51 +0000 Subject: [PATCH 0330/2047] * Deprecated scm_vector_set_length_x. * Zero length vectors do not allocate dummy memory any more. --- NEWS | 4 ++++ RELEASE | 1 + libguile/ChangeLog | 11 +++++++++++ libguile/gc.c | 36 ++++++++++++------------------------ libguile/vectors.c | 44 ++++++++++++++++++++++++++++++-------------- libguile/vectors.h | 2 +- 6 files changed, 59 insertions(+), 39 deletions(-) diff --git a/NEWS b/NEWS index 9ecf98e1c..cb6e69f6e 100644 --- a/NEWS +++ b/NEWS @@ -159,6 +159,10 @@ Use scm_catch or scm_lazy_catch from throw.[ch] instead. Use scm_string_hash instead. +** Deprecated function: scm_vector_set_length_x + +Instead, create a fresh vector of the desired size and copy the contents. + ** scm_gensym has changed prototype scm_gensym now only takes one argument. diff --git a/RELEASE b/RELEASE index fdcadf848..93ecc9962 100644 --- a/RELEASE +++ b/RELEASE @@ -47,6 +47,7 @@ In release 1.6: SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD, SCM_ORD_SIG, SCM_NUM_SIGS, SCM_SLOPPY_STRINGP, SCM_VALIDATE_STRINGORSUBSTR, SCM_FREEP, SCM_NFREEP +- remove scm_vector_set_length_x - remove function scm_call_catching_errors (replaced by catch functions from throw.[ch]) - remove support for "#&" reader syntax in (ice-9 optargs). diff --git a/libguile/ChangeLog b/libguile/ChangeLog index c4251bc3d..6a1ce3a17 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2000-10-25 Dirk Herrmann + + * gc.c (scm_igc): Remove references to scm_vector_set_length_x. + + (scm_gc_sweep): SCM_CONTREGS is never NULL. + + * gc.c (scm_gc_sweep), vectors.c (scm_make_vector): Don't + allocate/free memory for zero length vectors. + + * vectors.[ch] (scm_vector_set_length_x): Deprecated. + 2000-10-25 Dirk Herrmann * alist.c (scm_assq_ref): Add a suggestion about how to deal with diff --git a/libguile/gc.c b/libguile/gc.c index a136d1b59..fa6474296 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1025,14 +1025,7 @@ scm_igc (const char *what) #ifndef USE_THREADS - /* Protect from the C stack. This must be the first marking - * done because it provides information about what objects - * are "in-use" by the C code. "in-use" objects are those - * for which the information about length and base address must - * remain usable. This requirement is stricter than a liveness - * requirement -- in particular, it constrains the implementation - * of scm_vector_set_length_x. - */ + /* Mark objects on the C stack. */ SCM_FLUSH_REGISTER_WINDOWS; /* This assumes that all registers are saved into the jmp_buf */ setjmp (scm_save_regs_gc_mark); @@ -1057,10 +1050,6 @@ scm_igc (const char *what) #endif /* USE_THREADS */ - /* FIXME: insert a phase to un-protect string-data preserved - * in scm_vector_set_length_x. - */ - j = SCM_NUM_PROTECTS; while (j--) scm_gc_mark (scm_sys_protects[j]); @@ -1615,9 +1604,15 @@ scm_gc_sweep () scm_must_free (SCM_VECTOR_BASE (scmptr) - 2); break; case scm_tc7_vector: - m += (SCM_VECTOR_LENGTH (scmptr) * sizeof (SCM)); - scm_must_free (SCM_VECTOR_BASE (scmptr)); - break; + { + unsigned long int length = SCM_VECTOR_LENGTH (scmptr); + if (length > 0) + { + m += length * sizeof (scm_bits_t); + scm_must_free (SCM_VECTOR_BASE (scmptr)); + } + break; + } #ifdef CCLO case scm_tc7_cclo: m += (SCM_CCLO_LENGTH (scmptr) * sizeof (SCM)); @@ -1656,15 +1651,8 @@ scm_gc_sweep () case scm_tc7_contin: m += SCM_CONTINUATION_LENGTH (scmptr) * sizeof (SCM_STACKITEM) + sizeof (scm_contregs); - if (SCM_CONTREGS (scmptr)) - { - scm_must_free (SCM_CONTREGS (scmptr)); - break; - } - else - { - continue; - } + scm_must_free (SCM_CONTREGS (scmptr)); + break; case scm_tcs_subrs: /* the various "subrs" (primitives) are never freed */ continue; diff --git a/libguile/vectors.c b/libguile/vectors.c index 728f48daa..1281ddcd5 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -55,6 +55,12 @@ #include "libguile/unif.h" +#if (SCM_DEBUG_DEPRECATED == 0) + +/* The function scm_vector_set_length_x will disappear in the next release of + * guile. + */ + /* * This complicates things too much if allowed on any array. * C code can safely call it on arrays known to be used in a single @@ -129,6 +135,8 @@ scm_vector_set_length_x (SCM vect, SCM len) return vect; } +#endif /* (SCM_DEBUG_DEPRECATED == 0) */ + SCM_DEFINE (scm_vector_p, "vector?", 1, 0, 0, (SCM obj), "Returns @t{#t} if @var{obj} is a vector, otherwise returns @t{#f}. (r5rs)") @@ -263,22 +271,32 @@ SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0, #define FUNC_NAME s_scm_make_vector { SCM v; - register long i; - register long j; - register SCM *velts; + unsigned long int i; + scm_bits_t *velts; - SCM_VALIDATE_INUM_MIN (1,k,0); - if (SCM_UNBNDP(fill)) + SCM_VALIDATE_INUM_MIN (1, k, 0); + if (SCM_UNBNDP (fill)) fill = SCM_UNSPECIFIED; - i = SCM_INUM(k); - SCM_NEWCELL(v); + + i = SCM_INUM (k); + SCM_NEWCELL (v); + + velts = (i != 0) + ? scm_must_malloc (i * sizeof (scm_bits_t), FUNC_NAME) + : NULL; + SCM_DEFER_INTS; - SCM_SETCHARS(v, scm_must_malloc(i?(long)(i*sizeof(SCM)):1L, FUNC_NAME)); - velts = SCM_VELTS(v); - for (j = 0; j < i; ++j) - velts[j] = fill; - SCM_SETLENGTH(v, i, scm_tc7_vector); + { + unsigned long int j; + + for (j = 0; j != i; ++j) + velts[j] = SCM_UNPACK (fill); + + SCM_SETCHARS (v, velts); + SCM_SETLENGTH (v, i, scm_tc7_vector); + } SCM_ALLOW_INTS; + return v; } #undef FUNC_NAME @@ -390,8 +408,6 @@ void scm_init_vectors () { #include "libguile/vectors.x" - /* - scm_make_subr (s_resizuve, scm_tc7_subr_2, scm_vector_set_length_x); */ } diff --git a/libguile/vectors.h b/libguile/vectors.h index f995da3e8..55404554d 100644 --- a/libguile/vectors.h +++ b/libguile/vectors.h @@ -71,7 +71,6 @@ -extern SCM scm_vector_set_length_x (SCM vect, SCM len); extern SCM scm_vector_p (SCM x); extern SCM scm_vector_length (SCM v); extern SCM scm_vector (SCM l); @@ -92,6 +91,7 @@ extern void scm_init_vectors (void); #if (SCM_DEBUG_DEPRECATED == 0) #define SCM_NVECTORP(x) (!SCM_VECTORP (x)) +extern SCM scm_vector_set_length_x (SCM vect, SCM len); #endif /* SCM_DEBUG_DEPRECATED == 0 */ From fdd70ea97c142dc8db1e3f147ac6f5bd6ae157c6 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 25 Oct 2000 14:44:42 +0000 Subject: [PATCH 0331/2047] * GUILE-VERSION (LIBGUILE_MAJOR_VERSION): Incremented major version number to 10 due to the merge of GOOPS. --- GUILE-VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GUILE-VERSION b/GUILE-VERSION index 97644762a..0d61f1b50 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -7,7 +7,7 @@ VERSION=${GUILE_VERSION} PACKAGE=guile # libguile.so versioning info -LIBGUILE_MAJOR_VERSION=9 +LIBGUILE_MAJOR_VERSION=10 LIBGUILE_MINOR_VERSION=0 LIBGUILE_REVISION_VERSION=0 LIBGUILE_VERSION=${LIBGUILE_MAJOR_VERSION}.${LIBGUILE_MINOR_VERSION}.${LIBGUILE_REVISION_VERSION} From 5a35577551dd68803a9581b05d63807ba4787422 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 25 Oct 2000 14:49:00 +0000 Subject: [PATCH 0332/2047] * Makefile.am (libguile_la_SOURCES): Added goops.c (DOT_X_FILES): Added goops.x (DOT_DOC_FILES): Added goops.doc (modinclude_HEADERS): Added goops.h --- libguile/Makefile.am | 82 ++++++++++++++++++++++---------------------- 1 file changed, 41 insertions(+), 41 deletions(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 007b7d3cc..0d63b5c8b 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -38,19 +38,18 @@ guile_SOURCES = guile.c guile_LDADD = libguile.la ${THREAD_LIBS_LOCAL} guile_LDFLAGS = @DLPREOPEN@ -libguile_la_SOURCES = \ - alist.c arbiters.c async.c backtrace.c boolean.c chars.c \ - continuations.c debug.c dynl.c dynwind.c environments.c eq.c \ - error.c eval.c \ - evalext.c feature.c fluids.c fports.c gc.c gdbint.c gh_data.c \ - gh_eval.c gh_funcs.c gh_init.c gh_io.c gh_list.c gh_predicates.c \ - gsubr.c guardians.c hash.c hashtab.c hooks.c init.c ioext.c \ - iselect.c keywords.c lang.c list.c load.c macros.c mallocs.c \ - modules.c numbers.c objects.c objprop.c options.c pairs.c ports.c \ - print.c procprop.c procs.c random.c read.c root.c scmsigs.c \ - script.c simpos.c smob.c sort.c srcprop.c stackchk.c stacks.c \ - stime.c strings.c strop.c strorder.c strports.c struct.c symbols.c \ - tag.c throw.c variable.c vectors.c version.c vports.c weaks.c \ +libguile_la_SOURCES = \ + alist.c arbiters.c async.c backtrace.c boolean.c chars.c \ + continuations.c debug.c dynl.c dynwind.c environments.c eq.c error.c \ + eval.c evalext.c feature.c fluids.c fports.c gc.c gdbint.c gh_data.c \ + gh_eval.c gh_funcs.c gh_init.c gh_io.c gh_list.c gh_predicates.c \ + goops.c gsubr.c guardians.c hash.c hashtab.c hooks.c init.c ioext.c \ + iselect.c keywords.c lang.c list.c load.c macros.c mallocs.c \ + modules.c numbers.c objects.c objprop.c options.c pairs.c ports.c \ + print.c procprop.c procs.c random.c read.c root.c scmsigs.c \ + script.c simpos.c smob.c sort.c srcprop.c stackchk.c stacks.c \ + stime.c strings.c strop.c strorder.c strports.c struct.c symbols.c \ + tag.c throw.c variable.c vectors.c version.c vports.c weaks.c \ gc_os_dep.c properties.c DOT_X_FILES = \ @@ -58,7 +57,7 @@ DOT_X_FILES = \ async.x backtrace.x boolean.x chars.x continuations.x debug.x \ dynl.x dynwind.x environments.x eq.x error.x eval.x evalext.x \ feature.x \ - fluids.x fports.x gc.x gsubr.x guardians.x hash.x hashtab.x \ + fluids.x fports.x gc.x goops.x gsubr.x guardians.x hash.x hashtab.x \ hooks.x init.x ioext.x iselect.x keywords.x lang.x list.x load.x \ macros.x mallocs.x modules.x net_db.x numbers.x objects.x \ objprop.x options.x pairs.x ports.x posix.x print.x procprop.x \ @@ -71,19 +70,20 @@ DOT_X_FILES = \ EXTRA_DOT_X_FILES = debug-malloc.x filesys.x net_db.x posix.x ramap.x \ regex-posix.x socket.x threads.x unif.x -DOT_DOC_FILES = \ - alist.doc arbiters.doc async.doc backtrace.doc boolean.doc \ - chars.doc continuations.doc debug.doc dynl.doc dynwind.doc \ - environments.doc eq.doc \ - error.doc eval.doc evalext.doc feature.doc fluids.doc fports.doc \ - gc.doc gsubr.doc guardians.doc hash.doc hashtab.doc hooks.doc init.doc \ - ioext.doc iselect.doc keywords.doc lang.doc list.doc load.doc \ - macros.doc mallocs.doc modules.doc net_db.doc numbers.doc objects.doc \ - objprop.doc options.doc pairs.doc ports.doc posix.doc print.doc \ - procprop.doc procs.doc random.doc read.doc root.doc scmsigs.doc \ - script.doc simpos.doc smob.doc socket.doc sort.doc srcprop.doc \ - stackchk.doc stacks.doc stime.doc strings.doc strop.doc strorder.doc \ - strports.doc struct.doc symbols.doc tag.doc throw.doc variable.doc \ +DOT_DOC_FILES = \ + alist.doc arbiters.doc async.doc backtrace.doc boolean.doc \ + chars.doc continuations.doc debug.doc dynl.doc dynwind.doc \ + environments.doc eq.doc \ + error.doc eval.doc evalext.doc feature.doc fluids.doc fports.doc \ + gc.doc goops.doc gsubr.doc guardians.doc hash.doc hashtab.doc \ + hooks.doc init.doc \ + ioext.doc iselect.doc keywords.doc lang.doc list.doc load.doc \ + macros.doc mallocs.doc modules.doc net_db.doc numbers.doc objects.doc \ + objprop.doc options.doc pairs.doc ports.doc posix.doc print.doc \ + procprop.doc procs.doc random.doc read.doc root.doc scmsigs.doc \ + script.doc simpos.doc smob.doc socket.doc sort.doc srcprop.doc \ + stackchk.doc stacks.doc stime.doc strings.doc strop.doc strorder.doc \ + strports.doc struct.doc symbols.doc tag.doc throw.doc variable.doc \ vectors.doc version.doc vports.doc weaks.doc properties.doc EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@ @@ -117,20 +117,20 @@ pkginclude_HEADERS = gh.h # These are headers visible as . modincludedir = $(includedir)/libguile -modinclude_HEADERS = \ - __scm.h alist.h arbiters.h async.h backtrace.h boolean.h chars.h \ - continuations.h debug.h dynl.h dynwind.h environments.h eq.h \ - error.h eval.h \ - evalext.h feature.h filesys.h fports.h gc.h gdb_interface.h \ - gdbint.h gsubr.h guardians.h hash.h hashtab.h hooks.h init.h \ - ioext.h keywords.h lang.h list.h load.h macros.h mallocs.h \ - modules.h net_db.h numbers.h objects.h objprop.h options.h pairs.h \ - ports.h posix.h regex-posix.h print.h procprop.h procs.h random.h \ - ramap.h read.h root.h scmsigs.h validate.h script.h simpos.h \ - smob.h socket.h sort.h srcprop.h stackchk.h stacks.h stime.h \ - strings.h strop.h strorder.h strports.h struct.h symbols.h tag.h \ - tags.h throw.h unif.h variable.h vectors.h version.h vports.h \ - weaks.h snarf.h threads.h coop-defs.h fluids.h iselect.h \ +modinclude_HEADERS = \ + __scm.h alist.h arbiters.h async.h backtrace.h boolean.h chars.h \ + continuations.h debug.h dynl.h dynwind.h environments.h eq.h \ + error.h eval.h \ + evalext.h feature.h filesys.h fports.h gc.h gdb_interface.h \ + gdbint.h goops.h gsubr.h guardians.h hash.h hashtab.h hooks.h init.h \ + ioext.h keywords.h lang.h list.h load.h macros.h mallocs.h \ + modules.h net_db.h numbers.h objects.h objprop.h options.h pairs.h \ + ports.h posix.h regex-posix.h print.h procprop.h procs.h random.h \ + ramap.h read.h root.h scmsigs.h validate.h script.h simpos.h \ + smob.h socket.h sort.h srcprop.h stackchk.h stacks.h stime.h \ + strings.h strop.h strorder.h strports.h struct.h symbols.h tag.h \ + tags.h throw.h unif.h variable.h vectors.h version.h vports.h \ + weaks.h snarf.h threads.h coop-defs.h fluids.h iselect.h \ debug-malloc.h properties.h ## This file is generated at configure time. That is why it is DATA From 80662edab3b939f75e231fbf91414d569d8c5386 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 25 Oct 2000 14:49:31 +0000 Subject: [PATCH 0333/2047] * goops.c, objects.c, objects.h, eval.c (scm_make_extended_class, scm_make_port_classes, scm_change_object_class, scm_memoize_method): Changed to ordinary functions (was plugin slots). * goops.c (wrap_init, scm_wrap_object): Unconditionally use SCM_STRUCT_GC_CHAIN. (scm_goops_version): Removed. (scm_oldfmt): and all uses of it: Removed. (scm_shared_array_root, scm_shared_array_offset, scm_shared_array_increments): Removed. (scm_init_goops): No need to support two arg mutex init. Removed #include "versiondat.h", #include "goops.h". --- libguile/goops.c | 2753 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 2753 insertions(+) create mode 100644 libguile/goops.c diff --git a/libguile/goops.c b/libguile/goops.c new file mode 100644 index 000000000..83876e0d7 --- /dev/null +++ b/libguile/goops.c @@ -0,0 +1,2753 @@ +/* Copyright (C) 1998, 1999, 2000 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 + * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + + +/* This software is a derivative work of other copyrighted softwares; the + * copyright notices of these softwares are placed in the file COPYRIGHTS + * + * This file is based upon stklos.c from the STk distribution by + * Erick Gallesio . + */ + +#include + +#include "libguile/_scm.h" +#include "libguile/alist.h" +#include "libguile/debug.h" +#include "libguile/dynl.h" +#include "libguile/dynwind.h" +#include "libguile/eval.h" +#include "libguile/hashtab.h" +#include "libguile/keywords.h" +#include "libguile/macros.h" +#include "libguile/modules.h" +#include "libguile/objects.h" +#include "libguile/ports.h" +#include "libguile/procprop.h" +#include "libguile/random.h" +#include "libguile/smob.h" +#include "libguile/strings.h" +#include "libguile/strports.h" +#include "libguile/vectors.h" +#include "libguile/weaks.h" + +#include "libguile/goops.h" + +#define CLASSP(x) (SCM_STRUCTP (x) \ + && SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_METACLASS) +#define GENERICP(x) (SCM_INSTANCEP (x) \ + && SCM_SUBCLASSP (SCM_CLASS_OF (x), scm_class_generic)) +#define METHODP(x) (SCM_INSTANCEP (x) \ + && SCM_SUBCLASSP(SCM_CLASS_OF(x), scm_class_method)) +#define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers) + + +#define DEFVAR(v,val) \ +{ scm_eval2 (SCM_LIST3 (scm_sym_define_public, (v), (val)), \ + scm_goops_lookup_closure); } +/* Temporary hack until we get the new module system */ +/*fixme* Should optimize by keeping track of the variable object itself */ +#define GETVAR(v) (SCM_CDDR (scm_apply (scm_goops_lookup_closure, \ + SCM_LIST2 ((v), SCM_BOOL_F), \ + SCM_EOL))) +static SCM +Intern (const char *s) +{ + return SCM_CAR (scm_intern (s, strlen (s))); +} + +/* Fixme: Should use already interned symbols */ +#define CALL_GF1(name,a) (scm_apply (GETVAR (Intern(name)), \ + SCM_LIST1 (a), SCM_EOL)) +#define CALL_GF2(name,a,b) (scm_apply (GETVAR (Intern(name)), \ + SCM_LIST2 (a, b), SCM_EOL)) +#define CALL_GF3(name,a,b,c) (scm_apply (GETVAR (Intern(name)), \ + SCM_LIST3 (a, b, c), SCM_EOL)) +#define CALL_GF4(name,a,b,c,d) (scm_apply (GETVAR (Intern(name)), \ + SCM_LIST4 (a, b, c, d), SCM_EOL)) + +/* Class redefinition protocol: + + A class is represented by a heap header h1 which points to a + malloc:ed memory block m1. + + When a new version of a class is created, a new header h2 and + memory block m2 are allocated. The headers h1 and h2 then switch + pointers so that h1 refers to m2 and h2 to m1. In this way, names + bound to h1 will point to the new class at the same time as h2 will + be a handle which the GC will us to free m1. + + The `redefined' slot of m1 will be set to point to h1. An old + instance will have it's class pointer (the CAR of the heap header) + pointing to m1. The non-immediate `redefined'-slot in m1 indicates + the class modification and the new class pointer can be found via + h1. +*/ + +#define SCM_CLASS_REDEF(c) SCM_SLOT (c, scm_si_redefined) +/* The following definition is located in libguile/objects.h: +#define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined]) +*/ + +#define TEST_CHANGE_CLASS(obj, class) \ + { \ + class = SCM_CLASS_OF (obj); \ + if (SCM_OBJ_CLASS_REDEF (obj) != SCM_BOOL_F) \ + CALL_GF3 ("change-object-class", \ + obj, class, SCM_OBJ_CLASS_REDEF (obj)); \ + } + +#define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1]) +#define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2]) + +#define SCM_GOOPS_UNBOUND SCM_UNBOUND +#define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND) + +static int goops_loaded_p = 0; +static scm_rstate *goops_rstate; + +static SCM scm_goops_lookup_closure; + +/* Some classes are defined in libguile/objects.c. */ +SCM scm_class_top, scm_class_object, scm_class_class; +SCM scm_class_entity, scm_class_entity_with_setter; +SCM scm_class_generic, scm_class_generic_with_setter, scm_class_method; +SCM scm_class_simple_method, scm_class_accessor; +SCM scm_class_procedure_class; +SCM scm_class_operator_class, scm_class_operator_with_setter_class; +SCM scm_class_entity_class; +SCM scm_class_number, scm_class_list; +SCM scm_class_keyword; +SCM scm_class_port, scm_class_input_output_port; +SCM scm_class_input_port, scm_class_output_port; +SCM scm_class_foreign_class, scm_class_foreign_object; +SCM scm_class_foreign_slot; +SCM scm_class_self, scm_class_protected; +SCM scm_class_opaque, scm_class_read_only; +SCM scm_class_protected_opaque, scm_class_protected_read_only; +SCM scm_class_scm; +SCM scm_class_int, scm_class_float, scm_class_double; + +SCM_SYMBOL (scm_sym_define_public, "define-public"); + +static SCM scm_make_unbound (void); +static SCM scm_unbound_p (SCM obj); + +/****************************************************************************** + * + * Compute-cpl + * + * This version doesn't handle multiple-inheritance. It serves only for + * booting classes and will be overaloaded in Scheme + * + ******************************************************************************/ + +#if 0 +static SCM +compute_cpl (SCM supers, SCM res) +{ + return (SCM_NULLP (supers) + ? scm_reverse (res) + : compute_cpl (SCM_SLOT (SCM_CAR (supers), scm_si_direct_supers), + scm_cons (SCM_CAR (supers), res))); +} +#endif + +static SCM +map (SCM (*proc) (SCM), SCM ls) +{ + if (SCM_IMP (ls)) + return ls; + { + SCM res = scm_cons (proc (SCM_CAR (ls)), SCM_EOL); + SCM h = res; + ls = SCM_CDR (ls); + while (SCM_NIMP (ls)) + { + SCM_SETCDR (h, scm_cons (proc (SCM_CAR (ls)), SCM_EOL)); + h = SCM_CDR (h); + ls = SCM_CDR (ls); + } + return res; + } +} + +static SCM +filter_cpl (SCM ls) +{ + SCM res = SCM_EOL; + while (SCM_NIMP (ls)) + { + SCM el = SCM_CAR (ls); + if (SCM_IMP (scm_sloppy_memq (el, res))) + res = scm_cons (el, res); + ls = SCM_CDR (ls); + } + return res; +} + +static SCM +compute_cpl (SCM class) +{ + if (goops_loaded_p) + return CALL_GF1 ("compute-cpl", class); + else + { + SCM supers = SCM_SLOT (class, scm_si_direct_supers); + SCM ls = scm_append (scm_acons (class, supers, + map (compute_cpl, supers))); + return scm_reverse_x (filter_cpl (ls), SCM_EOL); + } +} + +/****************************************************************************** + * + * compute-slots + * + ******************************************************************************/ + +static SCM +remove_duplicate_slots (SCM l, SCM res, SCM slots_already_seen) +{ + SCM tmp; + + if (SCM_NULLP (l)) + return res; + + tmp = SCM_CAAR (l); + if (!(SCM_NIMP (tmp) && SCM_SYMBOLP (tmp))) + scm_misc_error ("%compute-slots", + "bad slot name ~S", + SCM_LIST1 (tmp)); + + if (SCM_NULLP (scm_sloppy_memq (tmp, slots_already_seen))) { + res = scm_cons (SCM_CAR (l), res); + slots_already_seen = scm_cons (tmp, slots_already_seen); + } + + return remove_duplicate_slots (SCM_CDR (l), res, slots_already_seen); +} + +static SCM +build_slots_list (SCM dslots, SCM cpl) +{ + register SCM res = dslots; + + for (cpl = SCM_CDR(cpl); SCM_NNULLP(cpl); cpl = SCM_CDR(cpl)) + res = scm_append (SCM_LIST2 (SCM_SLOT (SCM_CAR (cpl), scm_si_direct_slots), + res)); + + /* res contains a list of slots. Remove slots which appears more than once */ + return remove_duplicate_slots (scm_reverse (res), SCM_EOL, SCM_EOL); +} + +static SCM +maplist (SCM ls) +{ + SCM orig = ls; + while (SCM_NIMP (ls)) + { + if (!(SCM_NIMP (SCM_CAR (ls)) && SCM_CONSP (SCM_CAR (ls)))) + SCM_SETCAR (ls, scm_cons (SCM_CAR (ls), SCM_EOL)); + ls = SCM_CDR (ls); + } + return orig; +} + +SCM_PROC (s_sys_compute_slots, "%compute-slots", 1, 0, 0, scm_sys_compute_slots); + +SCM +scm_sys_compute_slots (SCM class) +{ + SCM_ASSERT (SCM_NIMP (class) && CLASSP (class), + class, SCM_ARG1, s_sys_compute_slots); + return build_slots_list (SCM_SLOT (class, scm_si_direct_slots), + SCM_SLOT (class, scm_si_cpl)); +} + +/****************************************************************************** + * + * compute-getters-n-setters + * + * This version doesn't handle slot options. It serves only for booting + * classes and will be overaloaded in Scheme. + * + ******************************************************************************/ + +SCM_KEYWORD (k_init_value, "init-value"); +SCM_KEYWORD (k_init_thunk, "init-thunk"); + +static SCM +compute_getters_n_setters (SCM slots) +{ + SCM res = SCM_EOL; + SCM *cdrloc = &res; + long i = 0; + + for ( ; SCM_NNULLP(slots); slots = SCM_CDR(slots)) + { + SCM init = SCM_BOOL_F; + SCM options = SCM_CDAR (slots); + if (SCM_NNULLP (options)) + { + init = scm_get_keyword (k_init_value, options, 0); + if (init) + init = scm_closure (SCM_LIST2 (SCM_EOL, init), SCM_EOL); + else + init = scm_get_keyword (k_init_thunk, options, SCM_BOOL_F); + } + *cdrloc = scm_cons (scm_cons (SCM_CAAR (slots), + scm_cons (init, + SCM_MAKINUM (i++))), + SCM_EOL); + cdrloc = SCM_CDRLOC (*cdrloc); + } + return res; +} + +/****************************************************************************** + * + * initialize-object + * + ******************************************************************************/ + +/*fixme* Manufacture keywords in advance */ +SCM +scm_i_get_keyword (SCM key, SCM l, int len, SCM default_value, const char *subr) +{ + int i; + for (i = 0; i < len; i += 2) + { + if (!(SCM_NIMP (SCM_CAR (l)) && SCM_KEYWORDP (SCM_CAR (l)))) + scm_misc_error (subr, + "bad keyword: ~S", + SCM_LIST1 (SCM_CAR (l))); + if (SCM_CAR (l) == key) + return SCM_CADR (l); + l = SCM_CDDR (l); + } + return default_value; +} + +SCM_PROC (s_get_keyword, "get-keyword", 3, 0, 0, scm_get_keyword); + +SCM +scm_get_keyword (SCM key, SCM l, SCM default_value) +{ + int len; + SCM_ASSERT (SCM_NIMP (key) && SCM_KEYWORDP (key), + key, + "Bad keyword: ~S", + s_get_keyword); + len = scm_ilength (l); + SCM_ASSERT (len >= 0 && (len & 1) == 0, l, + "Bad keyword-value list: ~S", + s_get_keyword); + return scm_i_get_keyword (key, l, len, default_value, s_get_keyword); +} + +SCM_PROC (s_sys_initialize_object, "%initialize-object", 2, 0, 0, scm_sys_initialize_object); + +SCM_KEYWORD (k_init_keyword, "init-keyword"); + +static SCM get_slot_value (SCM class, SCM obj, SCM slotdef); +static SCM set_slot_value (SCM class, SCM obj, SCM slotdef, SCM value); + +SCM +scm_sys_initialize_object (SCM obj, SCM initargs) +{ + SCM tmp, get_n_set, slots; + SCM class = SCM_CLASS_OF (obj); + int n_initargs; + + SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj), + obj, SCM_ARG1, s_sys_initialize_object); + n_initargs = scm_ilength (initargs); + SCM_ASSERT ((n_initargs & 1) == 0, + initargs, SCM_ARG2, s_sys_initialize_object); + + get_n_set = SCM_SLOT (class, scm_si_getters_n_setters); + slots = SCM_SLOT (class, scm_si_slots); + + /* See for each slot how it must be initialized */ + for (; + SCM_NNULLP (slots); + get_n_set = SCM_CDR (get_n_set), slots = SCM_CDR (slots)) + { + SCM slot_name = SCM_CAR (slots); + SCM slot_value = 0; + + if (SCM_NIMP (SCM_CDR (slot_name))) + { + /* This slot admits (perhaps) to be initialized at creation time */ + int n = scm_ilength (SCM_CDR (slot_name)); + if (n & 1) /* odd or -1 */ + scm_misc_error (s_sys_initialize_object, + "class contains bogus slot definition: ~S", + SCM_LIST1 (slot_name)); + tmp = scm_i_get_keyword (k_init_keyword, + SCM_CDR (slot_name), + n, + 0, + s_sys_initialize_object); + slot_name = SCM_CAR (slot_name); + if (tmp) + { + /* an initarg was provided for this slot */ + if (!(SCM_NIMP (tmp) && SCM_KEYWORDP (tmp))) + scm_misc_error (s_sys_initialize_object, + "initarg must be a keyword. It was ~S", + SCM_LIST1 (tmp)); + slot_value = scm_i_get_keyword (tmp, + initargs, + n_initargs, + 0, + s_sys_initialize_object); + } + } + + if (slot_value) + /* set slot to provided value */ + set_slot_value (class, obj, SCM_CAR (get_n_set), slot_value); + else + { + /* set slot to its :init-form if it exists */ + tmp = SCM_CADAR (get_n_set); + if (tmp != SCM_BOOL_F) + { + slot_value = get_slot_value (class, obj, SCM_CAR (get_n_set)); + if (SCM_GOOPS_UNBOUNDP (slot_value)) + { + SCM env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, SCM_ENV (tmp)); + set_slot_value (class, + obj, + SCM_CAR (get_n_set), + scm_eval_body (SCM_CDR (SCM_CODE (tmp)), + env)); + } + } + } + } + + return obj; +} + + +SCM_KEYWORD (k_class, "class"); + +SCM_PROC (s_sys_prep_layout_x, "%prep-layout!", 1, 0, 0, scm_sys_prep_layout_x); + +SCM +scm_sys_prep_layout_x (SCM class) +{ + int i, n, len; + char *s, p, a; + SCM nfields, slots, type; + + SCM_ASSERT (SCM_NIMP (class) && SCM_INSTANCEP (class), + class, + SCM_ARG1, + s_sys_prep_layout_x); + slots = SCM_SLOT (class, scm_si_slots); + nfields = SCM_SLOT (class, scm_si_nfields); + if (!SCM_INUMP (nfields) || SCM_INUM (nfields) < 0) + scm_misc_error (s_sys_prep_layout_x, + "bad value in nfields slot: ~S", + SCM_LIST1 (nfields)); + n = 2 * SCM_INUM (nfields); + if (n < sizeof (SCM_CLASS_CLASS_LAYOUT) - 1 + && SCM_SUBCLASSP (class, scm_class_class)) + scm_misc_error (s_sys_prep_layout_x, + "class object doesn't have enough fields: ~S", + SCM_LIST1 (nfields)); + + s = n > 0 ? scm_must_malloc (n, s_sys_prep_layout_x) : 0; + for (i = 0; i < n; i += 2) + { + if (!(SCM_NIMP (slots) && SCM_CONSP (slots))) + scm_misc_error (s_sys_prep_layout_x, + "to few slot definitions", + SCM_EOL); + len = scm_ilength (SCM_CDAR (slots)); + type = scm_i_get_keyword (k_class, SCM_CDAR (slots), len, SCM_BOOL_F, + s_sys_prep_layout_x); + if (SCM_NIMP (type) && SCM_SUBCLASSP (type, scm_class_foreign_slot)) + { + if (SCM_SUBCLASSP (type, scm_class_self)) + p = 's'; + else if (SCM_SUBCLASSP (type, scm_class_protected)) + p = 'p'; + else + p = 'u'; + + if (SCM_SUBCLASSP (type, scm_class_opaque)) + a = 'o'; + else if (SCM_SUBCLASSP (type, scm_class_read_only)) + a = 'r'; + else + a = 'w'; + } + else + { + p = 'p'; + a = 'w'; + } + s[i] = p; + s[i + 1] = a; + slots = SCM_CDR (slots); + } + SCM_SLOT (class, scm_si_layout) = SCM_CAR (scm_intern (s, n)); + if (s) + scm_must_free (s); + return SCM_UNSPECIFIED; +} + +static void prep_hashsets (SCM); + +SCM_PROC (s_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0, scm_sys_inherit_magic_x); + +SCM +scm_sys_inherit_magic_x (SCM class, SCM dsupers) +{ + SCM ls = dsupers; + long flags = 0; + SCM_ASSERT (SCM_NIMP (class) && SCM_INSTANCEP (class), + class, + SCM_ARG1, + s_sys_inherit_magic_x); + while (SCM_NNULLP (ls)) + { + SCM_ASSERT (SCM_NIMP (ls) + && SCM_CONSP (ls) + && SCM_NIMP (SCM_CAR (ls)) + && SCM_INSTANCEP (SCM_CAR (ls)), + dsupers, + SCM_ARG2, + s_sys_inherit_magic_x); + flags |= SCM_CLASS_FLAGS (SCM_CAR (ls)); + ls = SCM_CDR (ls); + } + flags &= SCM_CLASSF_INHERIT; + if (flags & SCM_CLASSF_ENTITY) + SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity); + else + { + int n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); +#if 0 + /* + * We could avoid calling scm_must_malloc in the allocation code + * (in which case the following two lines are needed). Instead + * we make 0-slot instances non-light, so that the light case + * can be handled without special cases. + */ + if (n == 0) + SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0); +#endif + if (n > 0 && !(flags & SCM_CLASSF_METACLASS)) + { + /* NOTE: The following depends on scm_struct_i_size. */ + flags |= SCM_STRUCTF_LIGHT + n * sizeof (SCM); /* use light representation */ + SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light); + } + } + SCM_SET_CLASS_FLAGS (class, flags); + + prep_hashsets (class); + + return SCM_UNSPECIFIED; +} + +void +prep_hashsets (SCM class) +{ + int i; + + for (i = 0; i < 7; ++i) + SCM_SLOT (class, scm_si_hashsets + i) + = SCM_PACK (scm_c_uniform32 (goops_rstate)); +} + +/******************************************************************************/ + +SCM +scm_basic_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots) +{ + SCM z, cpl, slots, nfields, g_n_s; + + /* Allocate one instance */ + z = scm_make_struct (class, SCM_INUM0, SCM_EOL); + + /* Initialize its slots */ +#if 0 + cpl = compute_cpl (dsupers, SCM_LIST1(z)); +#endif + SCM_SLOT (z, scm_si_direct_supers) = dsupers; + cpl = compute_cpl (z); + slots = build_slots_list (maplist (dslots), cpl); + nfields = SCM_MAKINUM (scm_ilength (slots)); + g_n_s = compute_getters_n_setters (slots); + + SCM_SLOT(z, scm_si_name) = name; + SCM_SLOT(z, scm_si_direct_slots) = dslots; + SCM_SLOT(z, scm_si_direct_subclasses) = SCM_EOL; + SCM_SLOT(z, scm_si_direct_methods) = SCM_EOL; + SCM_SLOT(z, scm_si_cpl) = cpl; + SCM_SLOT(z, scm_si_slots) = slots; + SCM_SLOT(z, scm_si_nfields) = nfields; + SCM_SLOT(z, scm_si_getters_n_setters) = g_n_s; + SCM_SLOT(z, scm_si_redefined) = SCM_BOOL_F; + SCM_SLOT(z, scm_si_environment) + = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE); + + /* Add this class in the direct-subclasses slot of dsupers */ + { + SCM tmp; + for (tmp = dsupers; SCM_NNULLP(tmp); tmp = SCM_CDR(tmp)) + SCM_SLOT(SCM_CAR(tmp), scm_si_direct_subclasses) + = scm_cons(z, SCM_SLOT(SCM_CAR(tmp), scm_si_direct_subclasses)); + } + + /* Support for the underlying structs: */ + SCM_SET_CLASS_FLAGS (z, (class == scm_class_entity_class + ? (SCM_CLASSF_GOOPS_OR_VALID + | SCM_CLASSF_OPERATOR + | SCM_CLASSF_ENTITY) + : class == scm_class_operator_class + ? SCM_CLASSF_GOOPS_OR_VALID | SCM_CLASSF_OPERATOR + : SCM_CLASSF_GOOPS_OR_VALID)); + return z; +} + +SCM +scm_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots) +{ + SCM z = scm_basic_basic_make_class (class, name, dsupers, dslots); + scm_sys_inherit_magic_x (z, dsupers); + scm_sys_prep_layout_x (z); + return z; +} + +/******************************************************************************/ + +static SCM +build_class_class_slots () +{ + return maplist ( + scm_cons (SCM_LIST3 (Intern ("layout"), + k_class, + scm_class_protected_read_only), + scm_cons (SCM_LIST3 (Intern ("vcell"), + k_class, + scm_class_opaque), + scm_cons (SCM_LIST3 (Intern ("vtable"), + k_class, + scm_class_self), + scm_cons (Intern ("print"), + scm_cons (SCM_LIST3 (Intern ("procedure"), + k_class, + scm_class_protected_opaque), + scm_cons (SCM_LIST3 (Intern ("setter"), + k_class, + scm_class_protected_opaque), + scm_cons (Intern ("redefined"), + scm_cons (SCM_LIST3 (Intern ("h0"), + k_class, + scm_class_int), + scm_cons (SCM_LIST3 (Intern ("h1"), + k_class, + scm_class_int), + scm_cons (SCM_LIST3 (Intern ("h2"), + k_class, + scm_class_int), + scm_cons (SCM_LIST3 (Intern ("h3"), + k_class, + scm_class_int), + scm_cons (SCM_LIST3 (Intern ("h4"), + k_class, + scm_class_int), + scm_cons (SCM_LIST3 (Intern ("h5"), + k_class, + scm_class_int), + scm_cons (SCM_LIST3 (Intern ("h6"), + k_class, + scm_class_int), + scm_cons (SCM_LIST3 (Intern ("h7"), + k_class, + scm_class_int), + scm_cons (Intern ("name"), + scm_cons (Intern ("direct-supers"), + scm_cons (Intern ("direct-slots"), + scm_cons (Intern ("direct-subclasses"), + scm_cons (Intern ("direct-methods"), + scm_cons (Intern ("cpl"), + scm_cons (Intern ("default-slot-definition-class"), + scm_cons (Intern ("slots"), + scm_cons (Intern ("getters-n-setters"), /* name-access */ + scm_cons (Intern ("keyword-access"), + scm_cons (Intern ("nfields"), + scm_cons (Intern ("environment"), + SCM_EOL)))))))))))))))))))))))))))); +} + +static void +create_basic_classes (void) +{ + /* SCM slots_of_class = build_class_class_slots (); */ + + /**** ****/ + SCM cs = scm_makfrom0str (SCM_CLASS_CLASS_LAYOUT + + 2 * scm_vtable_offset_user); + SCM name = Intern (""); + scm_class_class = scm_permanent_object (scm_make_vtable_vtable (cs, + SCM_INUM0, + SCM_EOL)); + SCM_SET_CLASS_FLAGS (scm_class_class, (SCM_CLASSF_GOOPS_OR_VALID + | SCM_CLASSF_METACLASS)); + + SCM_SLOT(scm_class_class, scm_si_name) = name; + SCM_SLOT(scm_class_class, scm_si_direct_supers) = SCM_EOL; /* will be changed */ + /* SCM_SLOT(scm_class_class, scm_si_direct_slots) = slots_of_class; */ + SCM_SLOT(scm_class_class, scm_si_direct_subclasses)= SCM_EOL; + SCM_SLOT(scm_class_class, scm_si_direct_methods) = SCM_EOL; + SCM_SLOT(scm_class_class, scm_si_cpl) = SCM_EOL; /* will be changed */ + /* SCM_SLOT(scm_class_class, scm_si_slots) = slots_of_class; */ + SCM_SLOT(scm_class_class, scm_si_nfields) = SCM_MAKINUM (SCM_N_CLASS_SLOTS); + /* SCM_SLOT(scm_class_class, scm_si_getters_n_setters) + = compute_getters_n_setters (slots_of_class); */ + SCM_SLOT(scm_class_class, scm_si_redefined) = SCM_BOOL_F; + SCM_SLOT(scm_class_class, scm_si_environment) + = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE); + + prep_hashsets (scm_class_class); + + DEFVAR(name, scm_class_class); + + /**** ****/ + name = Intern (""); + scm_class_top = scm_permanent_object (scm_basic_make_class (scm_class_class, + name, + SCM_EOL, + SCM_EOL)); + + DEFVAR(name, scm_class_top); + + /**** ****/ + name = Intern(""); + scm_class_object = scm_permanent_object (scm_basic_make_class (scm_class_class, + name, + SCM_LIST1 (scm_class_top), + SCM_EOL)); + + DEFVAR (name, scm_class_object); + + /* and were partially initialized. Correct them here */ + SCM_SLOT (scm_class_object, scm_si_direct_subclasses) = SCM_LIST1 (scm_class_class); + + SCM_SLOT (scm_class_class, scm_si_direct_supers) = SCM_LIST1 (scm_class_object); + SCM_SLOT (scm_class_class, scm_si_cpl) = SCM_LIST3 (scm_class_class, scm_class_object, scm_class_top); +} + +/******************************************************************************/ + +SCM_PROC (s_instance_p, "instance?", 1, 0, 0, scm_instance_p); + +SCM +scm_instance_p (SCM obj) +{ + return SCM_NIMP (obj) && SCM_INSTANCEP (obj) ? SCM_BOOL_T : SCM_BOOL_F; +} + +SCM_PROC (s_class_of, "class-of", 1, 0, 0, scm_class_of); +/* scm_class_of is defined in libguile */ + +/****************************************************************************** + * + * Meta object accessors + * + ******************************************************************************/ +SCM_PROC (s_class_name, "class-name", 1, 0, 0, scm_class_name); + +SCM +scm_class_name (SCM obj) +{ + SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), obj, SCM_ARG1, s_class_name); + return scm_slot_ref (obj, Intern ("name")); +} + +SCM_PROC (s_class_direct_supers, "class-direct-supers", 1, 0, 0, scm_class_direct_supers); + +SCM +scm_class_direct_supers (SCM obj) +{ + SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), obj, SCM_ARG1, s_class_direct_supers); + return scm_slot_ref (obj, Intern("direct-supers")); +} + +SCM_PROC (s_class_direct_slots, "class-direct-slots", 1, 0, 0, scm_class_direct_slots); + +SCM +scm_class_direct_slots (SCM obj) +{ + SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), + obj, SCM_ARG1, s_class_direct_slots); + return scm_slot_ref (obj, Intern ("direct-slots")); +} + +SCM_PROC (s_class_direct_subclasses, "class-direct-subclasses", 1, 0, 0, scm_class_direct_subclasses); + +SCM +scm_class_direct_subclasses (SCM obj) +{ + SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), + obj, SCM_ARG1, s_class_direct_subclasses); + return scm_slot_ref(obj, Intern ("direct-subclasses")); +} + +SCM_PROC (s_class_direct_methods, "class-direct-methods", 1, 0, 0, scm_class_direct_methods); + +SCM +scm_class_direct_methods (SCM obj) +{ + SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), + obj, SCM_ARG1, s_class_direct_methods); + return scm_slot_ref (obj, Intern("direct-methods")); +} + +SCM_PROC (s_class_direct_precedence_list, "class-precedence-list", 1, 0, 0, scm_class_precedence_list); + +SCM +scm_class_precedence_list (SCM obj) +{ + SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), + obj, SCM_ARG1, s_class_direct_precedence_list); + return scm_slot_ref (obj, Intern ("cpl")); +} + +SCM_PROC (s_class_slots, "class-slots", 1, 0, 0, scm_class_slots); + +SCM +scm_class_slots (SCM obj) +{ + SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), + obj, SCM_ARG1, s_class_slots); + return scm_slot_ref (obj, Intern ("slots")); +} + +SCM_PROC (s_class_environment, "class-environment", 1, 0, 0, scm_class_environment); + +SCM +scm_class_environment (SCM obj) +{ + SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), + obj, SCM_ARG1, s_class_environment); + return scm_slot_ref(obj, Intern ("environment")); +} + + +SCM_PROC (s_generic_function_name, "generic-function-name", 1, 0, 0, scm_generic_function_name); + +SCM +scm_generic_function_name (SCM obj) +{ + SCM_ASSERT (SCM_NIMP (obj) && GENERICP (obj), + obj, SCM_ARG1, s_generic_function_name); + return scm_procedure_property (obj, scm_sym_name); +} + +SCM_PROC (s_generic_function_methods, "generic-function-methods", 1, 0, 0, scm_generic_function_methods); + +SCM +scm_generic_function_methods (SCM obj) +{ + SCM_ASSERT (SCM_NIMP (obj) && GENERICP (obj), + obj, SCM_ARG1, s_generic_function_methods); + return scm_slot_ref (obj, Intern ("methods")); +} + + +SCM_PROC (s_method_generic_function, "method-generic-function", 1, 0, 0, scm_method_generic_function); + +SCM +scm_method_generic_function (SCM obj) +{ + SCM_ASSERT (SCM_NIMP (obj) && METHODP (obj), + obj, SCM_ARG1, s_method_generic_function); + return scm_slot_ref (obj, Intern ("generic-function")); +} + +SCM_PROC (s_method_specializers, "method-specializers", 1, 0, 0, scm_method_specializers); + +SCM +scm_method_specializers (SCM obj) +{ + SCM_ASSERT (SCM_NIMP (obj) && METHODP (obj), + obj, SCM_ARG1, s_method_specializers); + return scm_slot_ref (obj, Intern ("specializers")); +} + +SCM_PROC (s_method_procedure, "method-procedure", 1, 0, 0, scm_method_procedure); + +SCM +scm_method_procedure (SCM obj) +{ + SCM_ASSERT (SCM_NIMP (obj) && METHODP (obj), + obj, SCM_ARG1, s_method_procedure); + return scm_slot_ref (obj, Intern ("procedure")); +} + +SCM_PROC (s_accessor_method_slot_definition, "accessor-method-slot-definition", 1, 0, 0, scm_accessor_method_slot_definition); + +SCM +scm_accessor_method_slot_definition (SCM obj) +{ + SCM_ASSERT (SCM_NIMP (obj) && SCM_ACCESSORP (obj), + obj, SCM_ARG1, s_method_procedure); + return scm_slot_ref (obj, Intern ("slot-definition")); +} + + +/****************************************************************************** + * + * S l o t a c c e s s + * + ******************************************************************************/ + +SCM_PROC (s_make_unbound, "make-unbound", 0, 0, 0, scm_make_unbound); + +static SCM +scm_make_unbound () +{ + return SCM_GOOPS_UNBOUND; +} + +SCM_PROC (s_unbound_p, "unbound?", 1, 0, 0, scm_unbound_p); + +static SCM +scm_unbound_p (SCM obj) +{ + return SCM_GOOPS_UNBOUNDP (obj) ? SCM_BOOL_T : SCM_BOOL_F; +} + +SCM_PROC (s_assert_bound, "assert-bound", 2, 0, 0, scm_assert_bound); + +static SCM +scm_assert_bound (SCM value, SCM obj) +{ + if (SCM_GOOPS_UNBOUNDP (value)) + return CALL_GF1 ("slot-unbound", obj); + return value; +} + +SCM_PROC (s_at_assert_bound_ref, "@assert-bound-ref", 2, 0, 0, scm_at_assert_bound_ref); + +static SCM +scm_at_assert_bound_ref (SCM obj, SCM index) +{ + SCM value = SCM_SLOT (obj, SCM_INUM (index)); + if (SCM_GOOPS_UNBOUNDP (value)) + return CALL_GF1 ("slot-unbound", obj); + return value; +} + +SCM_PROC (s_sys_fast_slot_ref, "%fast-slot-ref", 2, 0, 0, scm_sys_fast_slot_ref); + +SCM +scm_sys_fast_slot_ref (SCM obj, SCM index) +{ + register long i; + + SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj), + obj, SCM_ARG1, s_sys_fast_slot_ref); + SCM_ASSERT (SCM_INUMP (index), index, SCM_ARG2, s_sys_fast_slot_ref); + i = SCM_INUM (index); + SCM_ASSERT (i >= 0 && i < SCM_NUMBER_OF_SLOTS (obj), + index, SCM_OUTOFRANGE, s_sys_fast_slot_ref); + return scm_at_assert_bound_ref (obj, index); +} + +SCM_PROC (s_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0, scm_sys_fast_slot_set_x); + +SCM +scm_sys_fast_slot_set_x (SCM obj, SCM index, SCM value) +{ + register long i; + + SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj), + obj, SCM_ARG1, s_sys_fast_slot_set_x); + SCM_ASSERT (SCM_INUMP (index), index, SCM_ARG2, s_sys_fast_slot_set_x); + i = SCM_INUM (index); + SCM_ASSERT (i >= 0 && i < SCM_NUMBER_OF_SLOTS (obj), + index, SCM_OUTOFRANGE, s_sys_fast_slot_set_x); + + SCM_SLOT (obj, i) = value; + return SCM_UNSPECIFIED; +} + +/** Utilities **/ + +/* In the future, this function will return the effective slot + * definition associated with SLOT_NAME. Now it just returns some of + * the information which will be stored in the effective slot + * definition. + */ + +static SCM +slot_definition_using_name (SCM class, SCM slot_name) +{ + register SCM slots = SCM_SLOT (class, scm_si_getters_n_setters); + for (; SCM_NIMP (slots); slots = SCM_CDR (slots)) + if (SCM_CAAR (slots) == slot_name) + return SCM_CAR (slots); + return SCM_BOOL_F; +} + +static SCM +get_slot_value (SCM class, SCM obj, SCM slotdef) +{ + SCM access = SCM_CDDR (slotdef); + /* Two cases here: + * - access is an integer (the offset of this slot in the slots vector) + * - otherwise (car access) is the getter function to apply + */ + if (SCM_INUMP (access)) + return SCM_SLOT (obj, SCM_INUM (access)); + else + { + /* We must evaluate (apply (car access) (list obj)) + * where (car access) is known to be a closure of arity 1 */ + register SCM code, env; + + code = SCM_CAR (access); + if (!SCM_CLOSUREP (code)) + return SCM_SUBRF (code) (obj); + env = SCM_EXTEND_ENV (SCM_CAR (SCM_CODE (code)), + SCM_LIST1 (obj), + SCM_ENV (code)); + /* Evaluate the closure body */ + return scm_eval_body (SCM_CDR (SCM_CODE (code)), env); + } +} + +static SCM +get_slot_value_using_name (SCM class, SCM obj, SCM slot_name) +{ + SCM slotdef = slot_definition_using_name (class, slot_name); + if (SCM_NFALSEP (slotdef)) + return get_slot_value (class, obj, slotdef); + else + return CALL_GF3 ("slot-missing", class, obj, slot_name); +} + +static SCM +set_slot_value (SCM class, SCM obj, SCM slotdef, SCM value) +{ + SCM access = SCM_CDDR (slotdef); + /* Two cases here: + * - access is an integer (the offset of this slot in the slots vector) + * - otherwise (cadr access) is the setter function to apply + */ + if (SCM_INUMP (access)) + SCM_SLOT (obj, SCM_INUM (access)) = value; + else + { + /* We must evaluate (apply (cadr l) (list obj value)) + * where (cadr l) is known to be a closure of arity 2 */ + register SCM code, env; + + code = SCM_CADR (access); + if (!SCM_CLOSUREP (code)) + SCM_SUBRF (code) (obj, value); + else + { + env = SCM_EXTEND_ENV (SCM_CAR (SCM_CODE (code)), + SCM_LIST2 (obj, value), + SCM_ENV (code)); + /* Evaluate the closure body */ + scm_eval_body (SCM_CDR (SCM_CODE (code)), env); + } + } + return SCM_UNSPECIFIED; +} + +static SCM +set_slot_value_using_name (SCM class, SCM obj, SCM slot_name, SCM value) +{ + SCM slotdef = slot_definition_using_name (class, slot_name); + if (SCM_NFALSEP (slotdef)) + return set_slot_value (class, obj, slotdef, value); + else + return CALL_GF4 ("slot-missing", class, obj, slot_name, value); +} + +static SCM +test_slot_existence (SCM class, SCM obj, SCM slot_name) +{ + register SCM l; + + for (l = SCM_ACCESSORS_OF (obj); SCM_NNULLP (l); l = SCM_CDR (l)) + if (SCM_CAAR (l) == slot_name) + return SCM_BOOL_T; + + return SCM_BOOL_F; +} + +/* The current libguile logand doesn't handle bignums. + * This (primitive) version handles them up to 32 bits. + */ + +SCM_PROC1 (s_sys_logand, "%logand", scm_tc7_asubr, scm_sys_logand); + +static unsigned long +scm_sloppy_num2ulong (SCM num, char *pos, const char *s_caller) +{ + unsigned long res; + + if (SCM_INUMP (num)) + { + if (SCM_INUM (num) < 0) + goto out_of_range; + res = SCM_INUM (num); + return res; + } + SCM_ASRTGO (SCM_NIMP (num), wrong_type_arg); + if (SCM_BIGP (num)) + { + scm_sizet l; + + res = 0; + for (l = SCM_NUMDIGS (num); l--;) + res = SCM_BIGUP (res) + SCM_BDIGITS (num)[l]; + return res; + } + wrong_type_arg: + scm_wrong_type_arg (s_caller, (int) pos, num); + out_of_range: + scm_out_of_range (s_caller, num); +} + +static SCM +scm_sys_logand (SCM n1, SCM n2) +{ + if (SCM_UNBNDP (n2)) + { + if (SCM_UNBNDP (n1)) + return SCM_MAKINUM (-1); + return n1; + } + { + unsigned long u1 = scm_sloppy_num2ulong (n1, (char *) 1, s_sys_logand); + unsigned long u2 = scm_sloppy_num2ulong (n2, (char *) 2, s_sys_logand); + return scm_ulong2num (u1 & u2); + } +} + + /* ======================================== */ + +SCM_PROC (s_slot_ref_using_class, "slot-ref-using-class", 3, 0, 0, scm_slot_ref_using_class); + +SCM +scm_slot_ref_using_class (SCM class, SCM obj, SCM slot_name) +{ + SCM res; + + SCM_ASSERT (SCM_NIMP (class) && CLASSP (class), + class, SCM_ARG1, s_slot_ref_using_class); + SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj), + obj, SCM_ARG1, s_slot_ref_using_class); + SCM_ASSERT (SCM_NIMP (slot_name) && SCM_SYMBOLP (slot_name), + obj, SCM_ARG3, s_slot_ref_using_class); + + res = get_slot_value_using_name (class, obj, slot_name); + if (SCM_GOOPS_UNBOUNDP (res)) + return CALL_GF3 ("slot-unbound", class, obj, slot_name); + return res; +} + +SCM_PROC (s_slot_set_using_class_x, "slot-set-using-class!", 4, 0, 0, scm_slot_set_using_class_x); + +SCM +scm_slot_set_using_class_x (SCM class, SCM obj, SCM slot_name, SCM value) +{ + SCM_ASSERT (SCM_NIMP (class) && CLASSP (class), + class, SCM_ARG1, s_slot_set_using_class_x); + SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj), + obj, SCM_ARG2, s_slot_set_using_class_x); + SCM_ASSERT (SCM_NIMP (slot_name) && SCM_SYMBOLP (slot_name), + obj, SCM_ARG3, s_slot_set_using_class_x); + return set_slot_value_using_name (class, obj, slot_name, value); +} + +SCM_PROC (s_slot_bound_using_class_p, "slot-bound-using-class?", 3, 0, 0, scm_slot_bound_using_class_p); + +SCM +scm_slot_bound_using_class_p (SCM class, SCM obj, SCM slot_name) +{ + SCM_ASSERT (SCM_NIMP (class) && CLASSP (class), + class, SCM_ARG1, s_slot_bound_using_class_p); + SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj), + obj, SCM_ARG2, s_slot_bound_using_class_p); + SCM_ASSERT (SCM_NIMP (slot_name) && SCM_SYMBOLP (slot_name), + obj, SCM_ARG3, s_slot_bound_using_class_p); + + return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj, slot_name)) + ? SCM_BOOL_F + : SCM_BOOL_T); +} + +SCM_PROC (s_slot_exists_using_class_p, "slot-exists-using-class?", 3, 0, 0, scm_slot_exists_using_class_p); + +SCM +scm_slot_exists_using_class_p (SCM class, SCM obj, SCM slot_name) +{ + SCM_ASSERT (SCM_NIMP (class) && CLASSP (class), + class, SCM_ARG1, s_slot_exists_using_class_p); + SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj), + obj, SCM_ARG2, s_slot_exists_using_class_p); + SCM_ASSERT (SCM_NIMP (slot_name) && SCM_SYMBOLP (slot_name), + obj, SCM_ARG3, s_slot_exists_using_class_p); + return test_slot_existence (class, obj, slot_name); +} + + + /* ======================================== */ + +SCM_PROC (s_slot_ref, "slot-ref", 2, 0, 0, scm_slot_ref); + +SCM +scm_slot_ref (SCM obj, SCM slot_name) +{ + SCM res, class; + + SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj), + obj, SCM_ARG1, s_slot_ref); + TEST_CHANGE_CLASS (obj, class); + + res = get_slot_value_using_name (class, obj, slot_name); + if (SCM_GOOPS_UNBOUNDP (res)) + return CALL_GF3 ("slot-unbound", class, obj, slot_name); + return res; +} + +SCM_PROC (s_slot_set_x, "slot-set!", 3, 0, 0, scm_slot_set_x); + +const char *scm_s_slot_set_x = s_slot_set_x; + +SCM +scm_slot_set_x (SCM obj, SCM slot_name, SCM value) +{ + SCM class; + + SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj), + obj, SCM_ARG1, s_slot_set_x); + TEST_CHANGE_CLASS(obj, class); + + return set_slot_value_using_name (class, obj, slot_name, value); +} + +SCM_PROC (s_slot_bound_p, "slot-bound?", 2, 0, 0, scm_slot_bound_p); + +SCM +scm_slot_bound_p (SCM obj, SCM slot_name) +{ + SCM class; + + SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj), + obj, SCM_ARG1, s_slot_bound_p); + TEST_CHANGE_CLASS(obj, class); + + return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, + obj, + slot_name)) + ? SCM_BOOL_F + : SCM_BOOL_T); +} + +SCM_PROC (s_slot_exists_p, "slot-exists?", 2, 0, 0, scm_slots_exists_p); + +SCM +scm_slots_exists_p (SCM obj, SCM slot_name) +{ + SCM class; + + SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj), + obj, SCM_ARG1, s_slot_exists_p); + SCM_ASSERT (SCM_NIMP (slot_name) && SCM_SYMBOLP (slot_name), + slot_name, SCM_ARG2, s_slot_exists_p); + TEST_CHANGE_CLASS (obj, class); + + return test_slot_existence (class, obj, slot_name); +} + + +/****************************************************************************** + * + * %allocate-instance (the low level instance allocation primitive) + * + ******************************************************************************/ + +static void clear_method_cache (SCM); + +static SCM +wrap_init (SCM class, SCM *m, int n) +{ + SCM z; + int i; + + /* Set all slots to unbound */ + for (i = 0; i < n; i++) + m[i] = SCM_GOOPS_UNBOUND; + + SCM_NEWCELL2 (z); + SCM_SETCDR (z, (SCM) m); + SCM_SET_STRUCT_GC_CHAIN (z, 0); + SCM_SETCAR (z, (scm_bits_t) SCM_STRUCT_DATA (class) | scm_tc3_cons_gloc); + + return z; +} + +SCM_PROC (s_sys_allocate_instance, "%allocate-instance", 2, 0, 0, scm_sys_allocate_instance); + +SCM +scm_sys_allocate_instance (SCM class, SCM initargs) +{ + SCM *m; + int n; + + SCM_ASSERT (SCM_NIMP (class) && CLASSP (class), + class, SCM_ARG1, s_sys_allocate_instance); + + /* Most instances */ + if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT) + { + n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); + m = (SCM *) scm_must_malloc (n * sizeof (SCM), "instance"); + return wrap_init (class, m, n); + } + + /* Foreign objects */ + if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN) + return scm_make_foreign_object (class, initargs); + + n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); + + /* Entities */ + if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY) + { + m = (SCM *) scm_alloc_struct (n, + scm_struct_entity_n_extra_words, + "entity"); + m[scm_struct_i_setter] = SCM_BOOL_F; + m[scm_struct_i_procedure] = SCM_BOOL_F; + /* Generic functions */ + if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC) + { + SCM gf = wrap_init (class, m, n); + clear_method_cache (gf); + return gf; + } + else + return wrap_init (class, m, n); + } + + /* Class objects */ + if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS) + { + int i; + + /* allocate class object */ + SCM z = scm_make_struct (class, SCM_INUM0, SCM_EOL); + + SCM_SLOT (z, scm_si_print) = SCM_GOOPS_UNBOUND; + for (i = scm_si_goops_fields; i < n; i++) + SCM_SLOT (z, i) = SCM_GOOPS_UNBOUND; + + if (SCM_SUBCLASSP (class, scm_class_entity_class)) + SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY); + else if (SCM_SUBCLASSP (class, scm_class_operator_class)) + SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_OPERATOR); + + return z; + } + + /* Non-light instances */ + { + m = (SCM *) scm_alloc_struct (n, + scm_struct_n_extra_words, + "heavy instance"); + return wrap_init (class, m, n); + } +} + +SCM_PROC (s_sys_set_object_setter_x, "%set-object-setter!", 2, 0, 0, scm_sys_set_object_setter_x); + +SCM +scm_sys_set_object_setter_x (SCM obj, SCM setter) +{ + SCM_ASSERT (SCM_NIMP (obj) && SCM_STRUCTP (obj) + && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR) + || SCM_I_ENTITYP (obj)), + obj, + SCM_ARG1, + s_sys_set_object_setter_x); + if (SCM_I_ENTITYP (obj)) + SCM_ENTITY_SETTER (obj) = setter; + else + SCM_OPERATOR_CLASS (obj)->setter = setter; + return SCM_UNSPECIFIED; +} + +/****************************************************************************** + * + * %modify-instance (used by change-class to modify in place) + * + ******************************************************************************/ + +SCM_PROC (s_sys_modify_instance, "%modify-instance", 2, 0, 0, scm_sys_modify_instance); + +SCM +scm_sys_modify_instance (SCM old, SCM new) +{ + SCM_ASSERT (SCM_NIMP (old) && SCM_INSTANCEP (old), + old, SCM_ARG1, s_sys_modify_instance); + SCM_ASSERT (SCM_NIMP (new) && SCM_INSTANCEP (new), + new, SCM_ARG2, s_sys_modify_instance); + + /* Exchange the data contained in old and new. We exchange rather than + * scratch the old value with new to be correct with GC. + * See "Class redefinition protocol above". + */ + SCM_REDEFER_INTS; + { + SCM car = SCM_CAR (old); + SCM cdr = SCM_CDR (old); + SCM_SETCAR (old, SCM_CAR (new)); + SCM_SETCDR (old, SCM_CDR (new)); + SCM_SETCAR (new, car); + SCM_SETCDR (new, cdr); + } + SCM_REALLOW_INTS; + return SCM_UNSPECIFIED; +} + +SCM_PROC (s_sys_modify_class, "%modify-class", 2, 0, 0, scm_sys_modify_class); + +SCM +scm_sys_modify_class (SCM old, SCM new) +{ + SCM_ASSERT (SCM_NIMP (old) && CLASSP (old), + old, SCM_ARG1, s_sys_modify_class); + SCM_ASSERT (SCM_NIMP (new) && CLASSP (new), + new, SCM_ARG2, s_sys_modify_class); + + SCM_REDEFER_INTS; + { + SCM car = SCM_CAR (old); + SCM cdr = SCM_CDR (old); + SCM_SETCAR (old, SCM_CAR (new)); + SCM_SETCDR (old, SCM_CDR (new)); + SCM_STRUCT_DATA (old)[scm_vtable_index_vtable] = old; + SCM_SETCAR (new, car); + SCM_SETCDR (new, cdr); + SCM_STRUCT_DATA (new)[scm_vtable_index_vtable] = new; + } + SCM_REALLOW_INTS; + return SCM_UNSPECIFIED; +} + +SCM_PROC (s_sys_invalidate_class, "%invalidate-class", 1, 0, 0, scm_sys_invalidate_class); + +SCM +scm_sys_invalidate_class (SCM class) +{ + SCM_ASSERT (SCM_NIMP (class) && CLASSP (class), + class, SCM_ARG1, s_sys_invalidate_class); + + SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID); + return SCM_UNSPECIFIED; +} + +/* When instances change class, they finally get a new body, but + * before that, they go through purgatory in hell. Odd as it may + * seem, this data structure saves us from eternal suffering in + * infinite recursions. + */ + +static SCM **hell; +static int n_hell = 1; /* one place for the evil one himself */ +static int hell_size = 4; +#ifdef USE_THREADS +static scm_mutex_t hell_mutex; +#endif + +static int +burnin (SCM o) +{ + int i; + for (i = 1; i < n_hell; ++i) + if (SCM_INST (o) == hell[i]) + return i; + return 0; +} + +static void +go_to_hell (void *o) +{ + SCM obj = (SCM) o; +#ifdef USE_THREADS + scm_mutex_lock (&hell_mutex); +#endif + if (n_hell == hell_size) + { + int new_size = 2 * hell_size; + hell = scm_must_realloc (hell, hell_size, new_size, "hell"); + hell_size = new_size; + } + hell[n_hell++] = SCM_INST (obj); +#ifdef USE_THREADS + scm_mutex_unlock (&hell_mutex); +#endif +} + +static void +go_to_heaven (void *o) +{ +#ifdef USE_THREADS + scm_mutex_lock (&hell_mutex); +#endif + hell[burnin ((SCM) o)] = hell[--n_hell]; +#ifdef USE_THREADS + scm_mutex_unlock (&hell_mutex); +#endif +} + +static SCM +purgatory (void *args) +{ + return scm_apply (GETVAR (Intern ("change-class")), (SCM) args, SCM_EOL); +} + +void +scm_change_object_class (SCM obj, SCM old_class, SCM new_class) +{ + if (!burnin (obj)) + scm_internal_dynamic_wind (go_to_hell, purgatory, go_to_heaven, + (void *) SCM_LIST2 (obj, new_class), + (void *) obj); +} + +/****************************************************************************** + * + * GGGG FFFFF + * G F + * G GG FFF + * G G F + * GGG E N E R I C F U N C T I O N S + * + * This implementation provides + * - generic functions (with class specializers) + * - multi-methods + * - next-method + * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf + * + ******************************************************************************/ + +SCM_KEYWORD (k_name, "name"); + +SCM_SYMBOL (sym_no_method, "no-method"); + +static SCM list_of_no_method; + +SCM_SYMBOL (scm_sym_args, "args"); + +SCM +scm_make_method_cache (SCM gf) +{ + return SCM_LIST5 (SCM_IM_DISPATCH, scm_sym_args, SCM_MAKINUM (1), + scm_make_vector (SCM_MAKINUM (SCM_INITIAL_MCACHE_SIZE), + list_of_no_method), + gf); +} + +static void +clear_method_cache (SCM gf) +{ + SCM_ENTITY_PROCEDURE (gf) = scm_make_method_cache (gf); + SCM_SLOT (gf, scm_si_used_by) = SCM_BOOL_F; +} + +SCM_PROC (s_sys_invalidate_method_cache_x, "%invalidate-method-cache!", 1, 0, 0, scm_sys_invalidate_method_cache_x); + +SCM +scm_sys_invalidate_method_cache_x (SCM gf) +{ + SCM used_by; + SCM_ASSERT (SCM_NIMP (gf) && SCM_STRUCTP (gf) && SCM_PUREGENERICP (gf), + gf, SCM_ARG1, s_sys_invalidate_method_cache_x); + used_by = SCM_SLOT (gf, scm_si_used_by); + if (SCM_NFALSEP (used_by)) + { + SCM methods = SCM_SLOT (gf, scm_si_methods); + for (; SCM_NIMP (used_by) && SCM_CONSP (used_by); + used_by = SCM_CDR (used_by)) + scm_sys_invalidate_method_cache_x (SCM_CAR (used_by)); + clear_method_cache (gf); + for (; SCM_NIMP (methods) && SCM_CONSP (methods); + methods = SCM_CDR (methods)) + SCM_SLOT (SCM_CAR (methods), scm_si_code_table) = SCM_EOL; + } + { + int n = SCM_INUM (SCM_SLOT (gf, scm_si_n_specialized)); + /* The sign of n is a flag indicating rest args. */ + SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf), + SCM_MAKINUM (n >= 0 ? n : -n)); + } + return SCM_UNSPECIFIED; +} + +SCM_PROC (s_generic_capability_p, "generic-capability?", 1, 0, 0, scm_generic_capability_p); + +SCM +scm_generic_capability_p (SCM proc) +{ + SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (proc)), + proc, SCM_ARG1, s_generic_capability_p); + return (scm_subr_p (proc) && SCM_SUBR_GENERIC (proc) + ? SCM_BOOL_T + : SCM_BOOL_F); +} + +SCM_PROC (s_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1, scm_enable_primitive_generic_x); + +SCM +scm_enable_primitive_generic_x (SCM subrs) +{ + while (SCM_NIMP (subrs)) + { + SCM subr = SCM_CAR (subrs); + SCM_ASSERT (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr), + subr, SCM_ARGn, s_enable_primitive_generic_x); + *SCM_SUBR_GENERIC (subr) + = scm_make (SCM_LIST3 (scm_class_generic, + k_name, + SCM_SNAME (subr))); + subrs = SCM_CDR (subrs); + } + return SCM_UNSPECIFIED; +} + +SCM_PROC (s_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0, scm_primitive_generic_generic); + +SCM +scm_primitive_generic_generic (SCM subr) +{ + if (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr)) + { + SCM gf = *SCM_SUBR_GENERIC (subr); + if (gf) + return gf; + } + return scm_wta (subr, (char *) SCM_ARG1, s_primitive_generic_generic); +} + +/****************************************************************************** + * + * Protocol for calling a generic fumction + * This protocol is roughly equivalent to (parameter are a little bit different + * for efficiency reasons): + * + * + apply-generic (gf args) + * + compute-applicable-methods (gf args ...) + * + sort-applicable-methods (methods args) + * + apply-methods (gf methods args) + * + * apply-methods calls make-next-method to build the "continuation" of a a + * method. Applying a next-method will call apply-next-method which in + * turn will call apply again to call effectively the following method. + * + ******************************************************************************/ + +static int +applicablep (SCM actual, SCM formal) +{ + register SCM ptr; + + /* We test that (memq formal (slot-ref actual 'cpl)) + * However, we don't call memq here since we already know that + * the list is well formed + */ + for (ptr=SCM_SLOT(actual, scm_si_cpl); SCM_NNULLP(ptr); ptr = SCM_CDR(ptr)) { + if (SCM_NIMP (ptr) && SCM_CONSP (ptr)) { + if (SCM_CAR (ptr) == formal) + return 1; + } + else + scm_misc_error (0, + "Internal error in applicable: bad list ~S", + SCM_LIST1 (actual)); + } + return 0; +} + +static int +more_specificp (SCM m1, SCM m2, SCM *targs) +{ + register SCM s1, s2; + register int i; + /* + * Note: + * m1 and m2 can have != length (i.e. one can be one element longer than the + * other when we have a dotted parameter list). For instance, with the call + * (M 1) + * with + * (define-method M (a . l) ....) + * (define-method M (a) ....) + * + * we consider that the second method is more specific. + * + * BTW, targs is an array of types. We don't need it's size since + * we already know that m1 and m2 are applicable (no risk to go past + * the end of this array). + * + */ + for (i=0,s1=SPEC_OF(m1),s2=SPEC_OF(m2); ; i++,s1=SCM_CDR(s1),s2=SCM_CDR(s2)) { + if (SCM_NULLP(s1)) return 1; + if (SCM_NULLP(s2)) return 0; + if (SCM_CAR(s1) != SCM_CAR(s2)) { + register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2); + + for (l = SCM_SLOT(targs[i], scm_si_cpl); ; l = SCM_CDR(l)) { + if (cs1 == SCM_CAR(l)) + return 1; + if (cs2 == SCM_CAR(l)) + return 0; + } + return 0;/* should not occur! */ + } + } + return 0; /* should not occur! */ +} + +#define BUFFSIZE 32 /* big enough for most uses */ + +static SCM +scm_i_vector2list (SCM l, int len) +{ + int j; + SCM z = scm_make_vector (SCM_MAKINUM (len), SCM_UNDEFINED); + + for (j = 0; j < len; j++, l = SCM_CDR (l)) { + SCM_VELTS (z)[j] = SCM_CAR (l); + } + return z; +} + +static SCM +sort_applicable_methods (SCM method_list, int size, SCM *targs) +{ + int i, j, incr; + SCM *v, vector = SCM_EOL; + SCM buffer[BUFFSIZE]; + SCM save = method_list; + + /* For reasonably sized method_lists we can try to avoid all the + * consing and reorder the list in place... + * This idea is due to David McClain + */ + if (size <= BUFFSIZE) + { + for (i = 0; i < size; i++) + { + buffer[i] = SCM_CAR (method_list); + method_list = SCM_CDR (method_list); + } + v = buffer; + } + else + { + /* Too many elements in method_list to keep everything locally */ + vector = scm_i_vector2list (save, size); + v = SCM_VELTS (vector); + } + + /* Use a simple shell sort since it is generally faster than qsort on + * small vectors (which is probably mostly the case when we have to + * sort a list of applicable methods). + */ + for (incr = size / 2; incr; incr /= 2) + { + for (i = incr; i < size; i++) + { + for (j = i - incr; j >= 0; j -= incr) + { + if (more_specificp (v[j], v[j+incr], targs)) + break; + else + { + SCM tmp = v[j + incr]; + v[j + incr] = v[j]; + v[j] = tmp; + } + } + } + } + + if (size <= BUFFSIZE) + { + /* We did it in locally, so restore the original list (reordered) in-place */ + for (i = 0, method_list = save; i < size; i++, v++) + { + SCM_SETCAR (method_list, *v); + method_list = SCM_CDR (method_list); + } + return save; + } + /* If we are here, that's that we did it the hard way... */ + return scm_vector_to_list (vector); +} + +SCM +scm_compute_applicable_methods (SCM gf, SCM args, int len, int find_method_p) +{ + register int i; + int count = 0; + SCM l, fl, applicable = SCM_EOL; + SCM save = args; + SCM buffer[BUFFSIZE], *types, *p; + SCM tmp; + + /* Build the list of arguments types */ + if (len >= BUFFSIZE) { + tmp = scm_make_vector (SCM_MAKINUM (len), SCM_UNDEFINED); + /* NOTE: Using pointers to malloced memory won't work if we + 1. have preemtive threading, and, + 2. have a GC which moves objects. */ + types = p = SCM_VELTS(tmp); + } + else + types = p = buffer; + + for ( ; SCM_NNULLP (args); args = SCM_CDR (args)) + *p++ = scm_class_of (SCM_CAR (args)); + + /* Build a list of all applicable methods */ + for (l = SCM_SLOT (gf, scm_si_methods); SCM_NNULLP (l); l = SCM_CDR (l)) + { + fl = SPEC_OF (SCM_CAR (l)); + /* Only accept accessors which match exactly in first arg. */ + if (SCM_ACCESSORP (SCM_CAR (l)) + && (SCM_IMP (fl) || types[0] != SCM_CAR (fl))) + continue; + for (i = 0; ; i++, fl = SCM_CDR (fl)) + { + if ((SCM_NIMP (fl) && SCM_INSTANCEP (fl)) + /* We have a dotted argument list */ + || (i >= len && SCM_NULLP (fl))) + { /* both list exhausted */ + applicable = scm_cons (SCM_CAR (l), applicable); + count += 1; + break; + } + if (i >= len + || SCM_NULLP (fl) + || !applicablep (types[i], SCM_CAR (fl))) + break; + } + } + + if (count == 0) + { + if (find_method_p) + return SCM_BOOL_F; + CALL_GF2 ("no-applicable-method", gf, save); + /* if we are here, it's because no-applicable-method hasn't signaled an error */ + return SCM_BOOL_F; + } + return (count == 1 + ? applicable + : sort_applicable_methods (applicable, count, types)); +} + +#if 0 +SCM_PROC (s_sys_compute_applicable_methods, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods); +#endif + +static const char s_sys_compute_applicable_methods[] = "%compute-applicable-methods"; + +SCM +scm_sys_compute_applicable_methods (SCM gf, SCM args) +{ + int n; + SCM_ASSERT (SCM_NIMP (gf) && GENERICP (gf), + gf, SCM_ARG1, s_sys_compute_applicable_methods); + n = scm_ilength (args); + SCM_ASSERT (n >= 0, args, SCM_ARG2, s_sys_compute_applicable_methods); + return scm_compute_applicable_methods (gf, args, n, 1); +} + +SCM_VCELL_INIT (var_compute_applicable_methods, "compute-applicable-methods", scm_make_gsubr (s_sys_compute_applicable_methods, 2, 0, 0, scm_sys_compute_applicable_methods)); + +SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_makmmacro, scm_m_atslot_ref); + +SCM +scm_m_atslot_ref (SCM xorig, SCM env) +{ + SCM x = SCM_CDR (xorig); + SCM_ASSYNT (scm_ilength (x) == 2, xorig, scm_s_expression, s_atslot_ref); + SCM_ASSYNT (SCM_INUMP (SCM_CADR (x)), SCM_CADR (x), SCM_ARG2, s_atslot_ref); + return scm_cons (SCM_IM_SLOT_REF, x); +} + +SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_makmmacro, scm_m_atslot_set_x); + +SCM +scm_m_atslot_set_x (SCM xorig, SCM env) +{ + SCM x = SCM_CDR (xorig); + SCM_ASSYNT (scm_ilength (x) == 3, xorig, scm_s_expression, s_atslot_set_x); + SCM_ASSYNT (SCM_INUMP (SCM_CADR (x)), SCM_CADR (x), SCM_ARG2, s_atslot_set_x); + return scm_cons (SCM_IM_SLOT_SET_X, x); +} + +SCM_SYNTAX (s_atdispatch, "@dispatch", scm_makmmacro, scm_m_atdispatch); + +SCM_SYMBOL (sym_atdispatch, s_atdispatch); + +SCM +scm_m_atdispatch (SCM xorig, SCM env) +{ + SCM args, n, v, gf, x = SCM_CDR (xorig); + SCM_ASSYNT (scm_ilength (x) == 4, xorig, scm_s_expression, s_atdispatch); + args = SCM_CAR (x); + SCM_ASSYNT (SCM_NIMP (args) && (SCM_CONSP (args) || SCM_SYMBOLP (args)), + args, SCM_ARG1, s_atdispatch); + x = SCM_CDR (x); + n = SCM_XEVALCAR (x, env); + SCM_ASSYNT (SCM_INUMP (n), n, SCM_ARG2, s_atdispatch); + SCM_ASSYNT (SCM_INUM (n) >= 1, n, SCM_OUTOFRANGE, s_atdispatch); + x = SCM_CDR (x); + v = SCM_XEVALCAR (x, env); + SCM_ASSYNT (SCM_NIMP (v) && SCM_VECTORP (v), v, SCM_ARG3, s_atdispatch); + x = SCM_CDR (x); + gf = SCM_XEVALCAR (x, env); + SCM_ASSYNT (SCM_NIMP (gf) && SCM_STRUCTP (gf) && SCM_PUREGENERICP (gf), + gf, SCM_ARG4, s_atdispatch); + return SCM_LIST5 (SCM_IM_DISPATCH, args, n, v, gf); +} + +#ifdef USE_THREADS +static void +lock_cache_mutex (void *m) +{ + SCM mutex = (SCM) m; + scm_lock_mutex (mutex); +} + +static void +unlock_cache_mutex (void *m) +{ + SCM mutex = (SCM) m; + scm_unlock_mutex (mutex); +} +#endif + +static SCM +call_memoize_method (void *a) +{ + SCM args = (SCM) a; + SCM gf = SCM_CAR (args); + SCM x = SCM_CADR (args); + /* First check if another thread has inserted a method between + * the cache miss and locking the mutex. + */ + SCM cmethod = scm_mcache_lookup_cmethod (x, SCM_CDDR (args)); + if (SCM_NIMP (cmethod)) + return cmethod; + /*fixme* Use scm_apply */ + return CALL_GF3 ("memoize-method!", gf, SCM_CDDR (args), x); +} + +SCM +scm_memoize_method (SCM x, SCM args) +{ + SCM gf = SCM_CAR (scm_last_pair (x)); +#ifdef USE_THREADS + return scm_internal_dynamic_wind (lock_cache_mutex, + call_memoize_method, + unlock_cache_mutex, + (void *) scm_cons2 (gf, x, args), + (void *) SCM_SLOT (gf, scm_si_cache_mutex)); +#else + return call_memoize_method ((void *) scm_cons2 (gf, x, args)); +#endif +} + +/****************************************************************************** + * + * A simple make (which will be redefined later in Scheme) + * This version handles only creation of gf, methods and classes (no instances) + * + * Since this code will disappear when Goops will be fully booted, + * no precaution is taken to be efficient. + * + ******************************************************************************/ + +SCM_KEYWORD (k_setter, "setter"); +SCM_KEYWORD (k_specializers, "specializers"); +SCM_KEYWORD (k_procedure, "procedure"); +SCM_KEYWORD (k_dsupers, "dsupers"); +SCM_KEYWORD (k_slots, "slots"); +SCM_KEYWORD (k_gf, "generic-function"); + +SCM_PROC (s_make, "make", 0, 0, 1, scm_make); + +SCM +scm_make (SCM args) +{ + SCM class, z; + int len = scm_ilength (args); + + if (len <= 0 || (len & 1) == 0) + scm_wrong_num_args (scm_makfrom0str (s_make)); + + class = SCM_CAR(args); + args = SCM_CDR(args); + + if (class == scm_class_generic || class == scm_class_generic_with_setter) + { +#ifdef USE_THREADS + z = scm_make_struct (class, SCM_INUM0, + SCM_LIST4 (SCM_EOL, + SCM_INUM0, + SCM_BOOL_F, + scm_make_mutex ())); +#else + z = scm_make_struct (class, SCM_INUM0, + SCM_LIST3 (SCM_EOL, SCM_INUM0, SCM_BOOL_F)); +#endif + scm_set_procedure_property_x (z, scm_sym_name, + scm_get_keyword (k_name, + args, + SCM_BOOL_F)); + clear_method_cache (z); + if (class == scm_class_generic_with_setter) + { + SCM setter = scm_get_keyword (k_setter, args, SCM_BOOL_F); + if (SCM_NIMP (setter)) + scm_sys_set_object_setter_x (z, setter); + } + } + else + { + z = scm_sys_allocate_instance (class, args); + + if (class == scm_class_method + || class == scm_class_simple_method + || class == scm_class_accessor) + { + SCM_SLOT (z, scm_si_generic_function) = + scm_i_get_keyword (k_gf, + args, + len - 1, + SCM_BOOL_F, + s_make); + SCM_SLOT (z, scm_si_specializers) = + scm_i_get_keyword (k_specializers, + args, + len - 1, + SCM_EOL, + s_make); + SCM_SLOT (z, scm_si_procedure) = + scm_i_get_keyword (k_procedure, + args, + len - 1, + SCM_EOL, + s_make); + SCM_SLOT (z, scm_si_code_table) = SCM_EOL; + } + else + { + /* In all the others case, make a new class .... No instance here */ + SCM_SLOT (z, scm_si_name) = + scm_i_get_keyword (k_name, + args, + len - 1, + Intern ("???"), + s_make); + SCM_SLOT (z, scm_si_direct_supers) = + scm_i_get_keyword (k_dsupers, + args, + len - 1, + SCM_EOL, + s_make); + SCM_SLOT (z, scm_si_direct_slots) = + scm_i_get_keyword (k_slots, + args, + len - 1, + SCM_EOL, + s_make); + } + } + return z; +} + +SCM_PROC (s_find_method, "find-method", 0, 0, 1, scm_find_method); + +SCM +scm_find_method (SCM l) +{ + SCM gf; + int len = scm_ilength (l); + + if (len == 0) + scm_wrong_num_args (scm_makfrom0str (s_find_method)); + + gf = SCM_CAR(l); l = SCM_CDR(l); + SCM_ASSERT (SCM_NIMP (gf) && GENERICP (gf), gf, SCM_ARG1, s_find_method); + if (SCM_NULLP (SCM_SLOT (gf, scm_si_methods))) + scm_misc_error (s_find_method, + "no methods for generic ~S", + SCM_LIST1 (gf)); + + return scm_compute_applicable_methods (gf, l, len - 1, 1); +} + +SCM_PROC (s_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0, scm_sys_method_more_specific_p); + +SCM +scm_sys_method_more_specific_p (SCM m1, SCM m2, SCM targs) +{ + SCM l, v; + int i, len; + + SCM_ASSERT (SCM_NIMP (m1) && METHODP (m1), + m1, SCM_ARG1, s_sys_method_more_specific_p); + SCM_ASSERT (SCM_NIMP (m2) && METHODP (m2), + m2, SCM_ARG2, s_sys_method_more_specific_p); + SCM_ASSERT ((len = scm_ilength (targs)) != -1, + targs, SCM_ARG3, s_sys_method_more_specific_p); + + /* Verify that all the arguments of targs are classes and place them in a vector*/ + v = scm_make_vector (SCM_MAKINUM (len), SCM_EOL); + + for (i=0, l=targs; SCM_NNULLP(l); i++, l=SCM_CDR(l)) { + SCM_ASSERT (SCM_NIMP (SCM_CAR (l)) && CLASSP (SCM_CAR (l)), + targs, SCM_ARG3, s_sys_method_more_specific_p); + SCM_VELTS(v)[i] = SCM_CAR(l); + } + return more_specificp (m1, m2, SCM_VELTS(v)) ? SCM_BOOL_T: SCM_BOOL_F; +} + + + +/****************************************************************************** + * + * Initializations + * + ******************************************************************************/ + + +static void +make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots) +{ + SCM tmp = Intern(name); + + *var = scm_permanent_object (scm_basic_make_class (meta, + tmp, + SCM_CONSP (super) + ? super + : SCM_LIST1 (super), + slots)); + DEFVAR(tmp, *var); +} + + +SCM_KEYWORD (k_slot_definition, "slot-definition"); + +static void +create_standard_classes (void) +{ + SCM slots; + SCM method_slots = SCM_LIST4 (Intern ("generic-function"), + Intern ("specializers"), + Intern ("procedure"), + Intern ("code-table")); + SCM amethod_slots = SCM_LIST1 (SCM_LIST3 (Intern ("slot-definition"), + k_init_keyword, + k_slot_definition)); +#ifdef USE_THREADS + SCM mutex_slot = SCM_LIST1 (Intern ("make-mutex")); +#else + SCM mutex_slot = SCM_BOOL_F; +#endif + SCM gf_slots = SCM_LIST4 (Intern ("methods"), + SCM_LIST3 (Intern ("n-specialized"), + k_init_value, + SCM_INUM0), + SCM_LIST3 (Intern ("used-by"), + k_init_value, + SCM_BOOL_F), + SCM_LIST3 (Intern ("cache-mutex"), + k_init_thunk, + scm_closure (SCM_LIST2 (SCM_EOL, + mutex_slot), + SCM_EOL))); + + /* Foreign class slot classes */ + make_stdcls (&scm_class_foreign_slot, "", + scm_class_class, scm_class_top, SCM_EOL); + make_stdcls (&scm_class_protected, "", + scm_class_class, scm_class_foreign_slot, SCM_EOL); + make_stdcls (&scm_class_opaque, "", + scm_class_class, scm_class_foreign_slot, SCM_EOL); + make_stdcls (&scm_class_read_only, "", + scm_class_class, scm_class_foreign_slot, SCM_EOL); + make_stdcls (&scm_class_self, "", + scm_class_class, + SCM_LIST2 (scm_class_foreign_slot, scm_class_read_only), + SCM_EOL); + make_stdcls (&scm_class_protected_opaque, "", + scm_class_class, + SCM_LIST2 (scm_class_protected, scm_class_opaque), + SCM_EOL); + make_stdcls (&scm_class_protected_read_only, "", + scm_class_class, + SCM_LIST2 (scm_class_protected, scm_class_read_only), + SCM_EOL); + make_stdcls (&scm_class_scm, "", + scm_class_class, scm_class_protected, SCM_EOL); + make_stdcls (&scm_class_int, "", + scm_class_class, scm_class_foreign_slot, SCM_EOL); + make_stdcls (&scm_class_float, "", + scm_class_class, scm_class_foreign_slot, SCM_EOL); + make_stdcls (&scm_class_double, "", + scm_class_class, scm_class_foreign_slot, SCM_EOL); + + /* Continue initialization of class */ + + slots = build_class_class_slots (); + SCM_SLOT (scm_class_class, scm_si_direct_slots) = slots; + SCM_SLOT (scm_class_class, scm_si_slots) = slots; + SCM_SLOT (scm_class_class, scm_si_getters_n_setters) + = compute_getters_n_setters (slots); + + make_stdcls (&scm_class_foreign_class, "", + scm_class_class, scm_class_class, + SCM_LIST2 (SCM_LIST3 (Intern ("constructor"), + k_class, + scm_class_opaque), + SCM_LIST3 (Intern ("destructor"), + k_class, + scm_class_opaque))); + make_stdcls (&scm_class_foreign_object, "", + scm_class_foreign_class, scm_class_object, SCM_EOL); + SCM_SET_CLASS_FLAGS (scm_class_foreign_object, SCM_CLASSF_FOREIGN); + + /* scm_class_generic functions classes */ + make_stdcls (&scm_class_procedure_class, "", + scm_class_class, scm_class_class, SCM_EOL); + make_stdcls (&scm_class_entity_class, "", + scm_class_class, scm_class_procedure_class, SCM_EOL); + make_stdcls (&scm_class_operator_class, "", + scm_class_class, scm_class_procedure_class, SCM_EOL); + make_stdcls (&scm_class_operator_with_setter_class, + "", + scm_class_class, scm_class_operator_class, SCM_EOL); + make_stdcls (&scm_class_method, "", + scm_class_class, scm_class_object, method_slots); + make_stdcls (&scm_class_simple_method, "", + scm_class_class, scm_class_method, SCM_EOL); + SCM_SET_CLASS_FLAGS (scm_class_simple_method, SCM_CLASSF_SIMPLE_METHOD); + make_stdcls (&scm_class_accessor, "", + scm_class_class, scm_class_simple_method, amethod_slots); + SCM_SET_CLASS_FLAGS (scm_class_accessor, SCM_CLASSF_ACCESSOR_METHOD); + make_stdcls (&scm_class_entity, "", + scm_class_entity_class, scm_class_object, SCM_EOL); + make_stdcls (&scm_class_entity_with_setter, "", + scm_class_entity_class, scm_class_entity, SCM_EOL); + make_stdcls (&scm_class_generic, "", + scm_class_entity_class, scm_class_entity, gf_slots); + SCM_SET_CLASS_FLAGS (scm_class_generic, SCM_CLASSF_PURE_GENERIC); + make_stdcls (&scm_class_generic_with_setter, "", + scm_class_entity_class, + SCM_LIST2 (scm_class_generic, scm_class_entity_with_setter), + SCM_EOL); +#if 0 + /* Patch cpl since compute_cpl doesn't support multiple inheritance. */ + SCM_SLOT (scm_class_generic_with_setter, scm_si_cpl) = + scm_append (SCM_LIST3 (SCM_LIST2 (scm_class_generic_with_setter, + scm_class_generic), + SCM_SLOT (scm_class_entity_with_setter, + scm_si_cpl), + SCM_EOL)); +#endif + SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter, SCM_CLASSF_PURE_GENERIC); + + /* Primitive types classes */ + make_stdcls (&scm_class_boolean, "", + scm_class_class, scm_class_top, SCM_EOL); + make_stdcls (&scm_class_char, "", + scm_class_class, scm_class_top, SCM_EOL); + make_stdcls (&scm_class_list, "", + scm_class_class, scm_class_top, SCM_EOL); + make_stdcls (&scm_class_pair, "", + scm_class_class, scm_class_list, SCM_EOL); + make_stdcls (&scm_class_null, "", + scm_class_class, scm_class_list, SCM_EOL); + make_stdcls (&scm_class_string, "", + scm_class_class, scm_class_top, SCM_EOL); + make_stdcls (&scm_class_symbol, "", + scm_class_class, scm_class_top, SCM_EOL); + make_stdcls (&scm_class_vector, "", + scm_class_class, scm_class_top, SCM_EOL); + make_stdcls (&scm_class_number, "", + scm_class_class, scm_class_top, SCM_EOL); + make_stdcls (&scm_class_complex, "", + scm_class_class, scm_class_number, SCM_EOL); + make_stdcls (&scm_class_real, "", + scm_class_class, scm_class_complex, SCM_EOL); + make_stdcls (&scm_class_integer, "", + scm_class_class, scm_class_real, SCM_EOL); + make_stdcls (&scm_class_keyword, "", + scm_class_class, scm_class_top, SCM_EOL); + make_stdcls (&scm_class_unknown, "", + scm_class_class, scm_class_top, SCM_EOL); + make_stdcls (&scm_class_procedure, "", + scm_class_procedure_class, scm_class_top, SCM_EOL); + make_stdcls (&scm_class_procedure_with_setter, "", + scm_class_procedure_class, scm_class_procedure, SCM_EOL); + make_stdcls (&scm_class_primitive_generic, "", + scm_class_procedure_class, scm_class_procedure, SCM_EOL); + make_stdcls (&scm_class_port, "", + scm_class_class, scm_class_top, SCM_EOL); + make_stdcls (&scm_class_input_port, "", + scm_class_class, scm_class_port, SCM_EOL); + make_stdcls (&scm_class_output_port, "", + scm_class_class, scm_class_port, SCM_EOL); + make_stdcls (&scm_class_input_output_port, "", + scm_class_class, + SCM_LIST2 (scm_class_input_port, scm_class_output_port), + SCM_EOL); +} + +/********************************************************************** + * + * Smob classes + * + **********************************************************************/ + +static SCM +make_class_from_template (char *template, char *type_name, SCM supers) +{ + SCM class, name; + if (type_name) + { + char buffer[100]; + sprintf (buffer, template, type_name); + name = Intern (buffer); + } + else + name = SCM_GOOPS_UNBOUND; + + class = scm_permanent_object (scm_basic_make_class (scm_class_class, + name, + supers, + SCM_EOL)); + + /* Only define name if doesn't already exist. */ + if (!SCM_GOOPS_UNBOUNDP (name) + && SCM_FALSEP (scm_apply (scm_goops_lookup_closure, + SCM_LIST2 (name, SCM_BOOL_F), + SCM_EOL))) + { + /* Make sure we add the binding in the GOOPS module. + * This kludge is needed until DEFVAR ceases to use `define-public' + * or `define-public' ceases to use `current-module'. + */ + SCM old_module = scm_select_module (scm_module_goops); + DEFVAR (name, class); + scm_select_module (old_module); + } + return class; +} + +SCM +scm_make_extended_class (char *type_name) +{ + return make_class_from_template ("<%s>", + type_name, + SCM_LIST1 (scm_class_top)); +} + +static void +create_smob_classes (void) +{ + int i; + + scm_smob_class = (SCM *) malloc (255 * sizeof (SCM)); + 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) + if (!scm_smob_class[i]) + scm_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i)); +} + +void +scm_make_port_classes (int ptobnum, char *type_name) +{ + SCM c, class = make_class_from_template ("<%s-port>", + type_name, + SCM_LIST1 (scm_class_port)); + scm_port_class[SCM_IN_PCLASS_INDEX + ptobnum] + = make_class_from_template ("<%s-input-port>", + type_name, + SCM_LIST2 (class, scm_class_input_port)); + scm_port_class[SCM_OUT_PCLASS_INDEX + ptobnum] + = make_class_from_template ("<%s-output-port>", + type_name, + SCM_LIST2 (class, scm_class_output_port)); + scm_port_class[SCM_INOUT_PCLASS_INDEX + ptobnum] + = c + = make_class_from_template ("<%s-input-output-port>", + type_name, + SCM_LIST2 (class, + scm_class_input_output_port)); + /* Patch cpl (since this tree is too complex for the C level compute-cpl) */ + SCM_SLOT (c, scm_si_cpl) + = scm_cons2 (c, class, SCM_SLOT (scm_class_input_output_port, scm_si_cpl)); +} + +static void +create_port_classes (void) +{ + int i; + + scm_port_class = (SCM *) malloc (3 * 256 * sizeof (SCM)); + for (i = 0; i < 3 * 256; ++i) + scm_port_class[i] = 0; + + for (i = 0; i < scm_numptob; ++i) + scm_make_port_classes (i, SCM_PTOBNAME (i)); +} + +static SCM +make_struct_class (void *closure, SCM key, SCM data, SCM prev) +{ + if (SCM_NFALSEP (SCM_STRUCT_TABLE_NAME (data))) + SCM_SET_STRUCT_TABLE_CLASS (data, + scm_make_extended_class + (SCM_ROCHARS (SCM_STRUCT_TABLE_NAME (data)))); + return SCM_UNSPECIFIED; +} + +static void +create_struct_classes (void) +{ + scm_internal_hash_fold (make_struct_class, 0, SCM_BOOL_F, scm_struct_table); +} + +/********************************************************************** + * + * C interface + * + **********************************************************************/ + +void +scm_load_goops () +{ + if (!goops_loaded_p) + scm_resolve_module (scm_read_0str ("(oop goops)")); +} + +SCM +scm_make_foreign_object (SCM class, SCM initargs) +{ + void * (*constructor) (SCM) + = (void * (*) (SCM)) SCM_SLOT (class, scm_si_constructor); + SCM_ASSERT (constructor != 0, class, "Can't make instances of this class", + s_make); + return scm_wrap_object (class, constructor (initargs)); +} + +static size_t +scm_free_foreign_object (SCM *class, SCM *data) +{ + size_t (*destructor) (void *) + = (size_t (*) (void *)) class[scm_si_destructor]; + return destructor (data); +} + +SCM +scm_make_class (SCM meta, char *s_name, SCM supers, size_t size, + void * (*constructor) (SCM initargs), + size_t (*destructor) (void *)) +{ + SCM name, class; + name = Intern (s_name); + if (SCM_IMP (supers)) + supers = SCM_LIST1 (scm_class_foreign_object); + class = scm_basic_basic_make_class (meta, name, supers, SCM_EOL); + scm_sys_inherit_magic_x (class, supers); + + if (destructor != 0) + { + SCM_SLOT (class, scm_si_destructor) = (SCM) destructor; + SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object); + } + else if (size > 0) + { + SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light); + SCM_SET_CLASS_INSTANCE_SIZE (class, size); + } + + SCM_SLOT (class, scm_si_layout) = SCM_CAR (scm_intern ("", 0)); + SCM_SLOT (class, scm_si_constructor) = (SCM) constructor; + + return class; +} + +SCM_SYMBOL (sym_o, "o"); +SCM_SYMBOL (sym_x, "x"); + +SCM_KEYWORD (k_accessor, "accessor"); +SCM_KEYWORD (k_getter, "getter"); + +static SCM +default_setter (SCM obj, SCM c) +{ + scm_misc_error ("slot-set!", "read-only slot", SCM_EOL); + return 0; +} + +void +scm_add_slot (SCM class, char *slot_name, SCM slot_class, + SCM (*getter) (SCM obj), + SCM (*setter) (SCM obj, SCM x), + char *accessor_name) +{ + { + SCM get = scm_make_subr_opt ("goops:get", scm_tc7_subr_1, getter, 0); + SCM set = scm_make_subr_opt ("goops:set", scm_tc7_subr_2, + setter ? setter : default_setter, 0); + SCM getm = scm_closure (SCM_LIST2 (SCM_LIST1 (sym_o), + SCM_LIST2 (get, sym_o)), + SCM_EOL); + SCM setm = scm_closure (SCM_LIST2 (SCM_LIST2 (sym_o, sym_x), + SCM_LIST3 (set, sym_o, sym_x)), + SCM_EOL); + { + SCM name = SCM_CAR (scm_intern0 (slot_name)); + SCM aname = SCM_CAR (scm_intern0 (accessor_name)); + SCM gf = scm_ensure_accessor (aname); + SCM slot = SCM_LIST5 (name, + k_class, slot_class, + setter ? k_accessor : k_getter, + gf); + SCM gns = SCM_LIST4 (name, SCM_BOOL_F, get, set); + + scm_add_method (gf, scm_make (SCM_LIST5 (scm_class_accessor, + k_specializers, + SCM_LIST1 (class), + k_procedure, getm))); + scm_add_method (scm_setter (gf), + scm_make (SCM_LIST5 (scm_class_accessor, + k_specializers, + SCM_LIST2 (class, + scm_class_top), + k_procedure, setm))); + DEFVAR (aname, gf); + + SCM_SLOT (class, scm_si_slots) + = scm_append_x (SCM_LIST2 (SCM_SLOT (class, scm_si_slots), + SCM_LIST1 (slot))); + SCM_SLOT (class, scm_si_getters_n_setters) + = scm_append_x (SCM_LIST2 (SCM_SLOT (class, scm_si_getters_n_setters), + SCM_LIST1 (gns))); + } + } + { + int n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); + + SCM_SLOT (class, scm_si_nfields) + = SCM_MAKINUM (n + 1); + } +} + +SCM +scm_wrap_object (SCM class, void *data) +{ + SCM z; + SCM_NEWCELL2 (z); + SCM_SETCDR (z, (SCM) data); + SCM_SET_STRUCT_GC_CHAIN (z, 0); + SCM_SETCAR (z, SCM_UNPACK (SCM_CDR (class)) | scm_tc3_cons_gloc); + return z; +} + +SCM scm_components; + +SCM +scm_wrap_component (SCM class, SCM container, void *data) +{ + SCM obj = scm_wrap_object (class, data); + SCM handle = scm_hash_fn_create_handle_x (scm_components, + obj, + SCM_BOOL_F, + scm_struct_ihashq, + scm_sloppy_assq, + 0); + SCM_SETCDR (handle, container); + return obj; +} + +SCM +scm_ensure_accessor (SCM name) +{ + SCM gf = scm_apply (SCM_TOP_LEVEL_LOOKUP_CLOSURE, + SCM_LIST2 (name, SCM_BOOL_F), + SCM_EOL); + if (!SCM_IS_A_P (gf, scm_class_generic_with_setter)) + { + gf = scm_make (SCM_LIST3 (scm_class_generic, k_name, name)); + gf = scm_make (SCM_LIST5 (scm_class_generic_with_setter, + k_name, name, + k_setter, gf)); + } + return gf; +} + +SCM_SYMBOL (sym_internal_add_method_x, "internal-add-method!"); + +void +scm_add_method (SCM gf, SCM m) +{ + scm_eval2 (SCM_LIST3 (sym_internal_add_method_x, gf, m), + scm_goops_lookup_closure); +} + +#ifdef GUILE_DEBUG +/* + * Debugging utilities + */ + +SCM_PROC (s_pure_generic_p, "pure-generic?", 1, 0, 0, scm_pure_generic_p); + +SCM +scm_pure_generic_p (SCM obj) +{ + return (SCM_NIMP (obj) && SCM_STRUCTP (obj) && SCM_PUREGENERICP (obj) + ? SCM_BOOL_T + : SCM_BOOL_F); +} + +#endif /* GUILE_DEBUG */ + +/* + * Initialization + */ + +SCM_PROC (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0, sys_goops_loaded); + +static SCM +sys_goops_loaded () +{ + goops_loaded_p = 1; + var_compute_applicable_methods + = SCM_CDR (scm_apply (scm_goops_lookup_closure, + SCM_LIST2 (SCM_CAR (var_compute_applicable_methods), + SCM_BOOL_F), + SCM_EOL)); + return SCM_UNSPECIFIED; +} + +SCM scm_module_goops; + +void +scm_init_goops (void) +{ + SCM old_module; + scm_module_goops = scm_make_module (scm_read_0str ("(oop goops)")); + old_module = scm_select_module (scm_module_goops); + + scm_goops_lookup_closure = scm_module_lookup_closure (scm_module_goops); + + scm_components = scm_permanent_object (scm_make_weak_key_hash_table + (SCM_MAKINUM (37))); + + goops_rstate = scm_c_make_rstate ("GOOPS", 5); + +#include "libguile/goops.x" + + list_of_no_method = scm_permanent_object (SCM_LIST1 (sym_no_method)); + + hell = scm_must_malloc (hell_size, "hell"); +#ifdef USE_THREADS + scm_mutex_init (&hell_mutex); +#endif + + create_basic_classes (); + create_standard_classes (); + create_smob_classes (); + create_struct_classes (); + create_port_classes (); + + { + SCM name = SCM_CAR (scm_intern0 ("no-applicable-method")); + scm_no_applicable_method + = scm_permanent_object (scm_make (SCM_LIST3 (scm_class_generic, + k_name, + name))); + DEFVAR (name, scm_no_applicable_method); + } + + scm_select_module (old_module); +} + +void +scm_init_oop_goops_goopscore_module () +{ + scm_register_module_xxx ("oop goops goopscore", (void *) scm_init_goops); +} From 0518d3e277a89017949169f3532cc067235f7d8f Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 25 Oct 2000 14:49:47 +0000 Subject: [PATCH 0334/2047] * goops.h: Removed various superfluous conditions. --- libguile/goops.h | 268 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 268 insertions(+) create mode 100644 libguile/goops.h diff --git a/libguile/goops.h b/libguile/goops.h new file mode 100644 index 000000000..d34fa5041 --- /dev/null +++ b/libguile/goops.h @@ -0,0 +1,268 @@ +/* classes: h_files */ + +#ifndef GOOPSH +#define GOOPSH +/* Copyright (C) 1998, 1999, 2000 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 + * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + + +/* This software is a derivative work of other copyrighted softwares; the + * copyright notices of these softwares are placed in the file COPYRIGHTS + * + * This file is based upon stklos.h from the STk distribution by + * Erick Gallesio . + */ + +#include "libguile/__scm.h" + +/* + * scm_class_class + */ + +#define SCM_CLASS_CLASS_LAYOUT "pruosrpwpopopwururururururururpwpwpwpwpwpwpwpwpwpwpwpw" + +#define scm_si_layout 0 /* the struct layout */ +#define scm_si_vcell 1 +#define scm_si_vtable 2 +#define scm_si_print 3 /* the struct print closure */ +#define scm_si_proc 4 +#define scm_si_setter 5 + +#define scm_si_goops_fields 6 + +/* Defined in libguile/objects.c: +#define scm_si_redefined 6 The class to which class was redefined. +#define scm_si_hashsets 7 +*/ +#define scm_si_name 15 /* a symbol */ +#define scm_si_direct_supers 16 /* (class ...) */ +#define scm_si_direct_slots 17 /* ((name . options) ...) */ +#define scm_si_direct_subclasses 18 /* (class ...) */ +#define scm_si_direct_methods 19 /* (methods ...) */ +#define scm_si_cpl 20 /* (class ...) */ +#define scm_si_slotdef_class 21 +#define scm_si_slots 22 /* ((name . options) ...) */ +#define scm_si_name_access 23 +#define scm_si_keyword_access 24 +#define scm_si_nfields 25 /* an integer */ +#define scm_si_environment 26 /* The environment in which class is built */ +#define SCM_N_CLASS_SLOTS 27 + +typedef struct scm_method_t { + SCM generic_function; + SCM specializers; + SCM procedure; +} scm_method_t; + +#define SCM_METHOD(obj) ((scm_method_t *) SCM_STRUCT_DATA (obj)) + +#define SCM_CLASSF_SIMPLE_METHOD (0x004 << 20) +#define SCM_CLASSF_ACCESSOR_METHOD (0x008 << 20) + +/* Defined in libguile/objects.c */ +/* #define SCM_CLASSF_PURE_GENERIC (0x010 << 20) */ + +#define SCM_CLASSF_FOREIGN (0x020 << 20) +#define SCM_CLASSF_METACLASS (0x040 << 20) + +/* Defined in libguile/objects.c */ +/* #define SCM_CLASSF_GOOPS_VALID (0x080 << 20) */ +/* #define SCM_CLASSF_GOOPS (0x100 << 20) */ +#define SCM_CLASSF_GOOPS_OR_VALID (SCM_CLASSF_GOOPS | SCM_CLASSF_GOOPS_VALID) + +#define SCM_CLASSF_INHERIT (~(SCM_CLASSF_PURE_GENERIC \ + | SCM_CLASSF_SIMPLE_METHOD \ + | SCM_CLASSF_ACCESSOR_METHOD \ + | SCM_STRUCTF_LIGHT) \ + & SCM_CLASSF_MASK) + +#define SCM_INST(x) SCM_STRUCT_DATA (x) +#define SCM_INST_TYPE(x) SCM_OBJ_CLASS_FLAGS (x) +/* Also defined in libguuile/objects.c */ +#define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x) +#define SCM_ACCESSORS_OF(x) (SCM_STRUCT_VTABLE_DATA (x)[scm_si_getters_n_setters]) +#define SCM_NUMBER_OF_SLOTS(x)\ + (SCM_UNPACK (SCM_STRUCT_DATA (x)[scm_struct_i_n_words]) \ + - scm_struct_n_extra_words) \ + +#define SCM_INSTANCEP(x) (SCM_STRUCTP (x) \ + && (SCM_INST_TYPE (x) & SCM_CLASSF_GOOPS)) + +#define SCM_PUREGENERICP(x) (SCM_INST_TYPE(x) & SCM_CLASSF_PURE_GENERIC) +#define SCM_SIMPLEMETHODP(x) (SCM_INST_TYPE(x) & SCM_CLASSF_SIMPLE_METHOD) +#define SCM_ACCESSORP(x) (SCM_INST_TYPE(x) & SCM_CLASSF_ACCESSOR_METHOD) +#define SCM_FASTMETHODP(x) (SCM_INST_TYPE(x) \ + & (SCM_CLASSF_ACCESSOR_METHOD \ + | SCM_CLASSF_SIMPLE_METHOD)) + +#define SCM_SLOT(x, i) (SCM_INST(x)[i]) +#define SCM_SUBCLASSP(c1, c2) SCM_NNULLP (scm_sloppy_memq (c2, SCM_SLOT (c1, scm_si_cpl))) +#define SCM_IS_A_P(x, c) (SCM_NIMP (x) \ + && SCM_INSTANCEP (x) \ + && SCM_SUBCLASSP (SCM_CLASS_OF (x), c)) + +#define SCM_MCACHE_N_SPECIALIZED(C) SCM_CADDR (C) +#define SCM_SET_MCACHE_N_SPECIALIZED(C, X) SCM_SETCAR (SCM_CDDR (C), X) + +#define SCM_INITIAL_MCACHE_SIZE 1 + +#define scm_si_getters_n_setters scm_si_name_access + +#define scm_si_constructor SCM_N_CLASS_SLOTS +#define scm_si_destructor SCM_N_CLASS_SLOTS + 1 + +#define scm_si_methods 0 /* offset of methods slot in a */ +#define scm_si_n_specialized 1 +#define scm_si_used_by 2 +#define scm_si_cache_mutex 3 + +#define scm_si_generic_function 0 /* offset of gf slot in a */ +#define scm_si_specializers 1 /* offset of spec. slot in a */ + +#define scm_si_procedure 2 /* offset of proc. slot in a */ +#define scm_si_code_table 3 /* offset of code. slot in a */ + +/* C interface */ +extern SCM scm_class_top, scm_class_object, scm_class_class; +extern SCM scm_class_entity, scm_class_entity_with_setter; +extern SCM scm_class_generic, scm_class_generic_with_setter, scm_class_method; +extern SCM scm_class_simple_method, scm_class_accessor; +extern SCM scm_class_procedure_class; +extern SCM scm_class_operator_class, scm_class_operator_with_setter_class; +extern SCM scm_class_entity_class; +extern SCM scm_class_number, scm_class_list; +extern SCM scm_class_keyword; +extern SCM scm_class_port, scm_class_input_output_port; +extern SCM scm_class_input_port, scm_class_output_port; +extern SCM scm_class_foreign_class, scm_class_foreign_object; +extern SCM scm_class_foreign_slot; +extern SCM scm_class_self, scm_class_protected; +extern SCM scm_class_opaque, scm_class_read_only; +extern SCM scm_class_protected_opaque, scm_class_protected_read_only; +extern SCM scm_class_scm; +extern SCM scm_class_int, scm_class_float, scm_class_double; +extern const char *scm_s_slot_set_x; + +extern SCM scm_module_goops; + +SCM scm_goops_version (void); +SCM scm_oldfmt (SCM); +char *scm_c_oldfmt0 (char *); +char *scm_c_oldfmt (char *, int n); +void scm_load_goops (void); +SCM scm_make_foreign_object (SCM class, SCM initargs); +SCM scm_make_class (SCM meta, char *s_name, SCM supers, size_t size, + void * (*constructor) (SCM initargs), + size_t (*destructor) (void *)); +void scm_add_slot (SCM c, char *slot, SCM slot_class, + SCM (*getter) (SCM obj), + SCM (*setter) (SCM obj, SCM x), + char *accessor_name); +SCM scm_wrap_object (SCM c, void *); +SCM scm_wrap_component (SCM c, SCM obj, void *); +SCM scm_ensure_accessor (SCM name); +void scm_add_method (SCM gf, SCM m); + +/* Low level functions exported */ +SCM scm_make_next_method (SCM methods, SCM args, SCM gf); +SCM scm_basic_basic_make_class (SCM c, SCM name, SCM dsupers, SCM dslots); +SCM scm_basic_make_class (SCM c, SCM name, SCM dsupers, SCM dslots); + +/* Primitives exported */ +SCM scm_sys_allocate_instance (SCM c, SCM initargs); +SCM scm_sys_set_object_setter_x (SCM obj, SCM setter); +SCM scm_slot_ref (SCM obj, SCM slot_name); +SCM scm_slot_set_x (SCM obj, SCM slot_name, SCM value); + +SCM scm_compute_applicable_methods (SCM gf, SCM args, int len, int scm_find_method); +SCM scm_sys_compute_applicable_methods (SCM gf, SCM args); +SCM scm_m_atslot_ref (SCM xorig, SCM env); +SCM scm_m_atslot_set_x (SCM xorig, SCM env); +SCM scm_m_atdispatch (SCM xorig, SCM env); +#ifdef GUILE_DEBUG +SCM scm_pure_generic_p (SCM obj); +#endif +extern void scm_init_oop_goops_goopscore_module (void); + +SCM scm_sys_compute_slots (SCM c); +SCM scm_i_get_keyword (SCM key, SCM l, int len, SCM default_value, const char *subr); +SCM scm_get_keyword (SCM key, SCM l, SCM default_value); +SCM scm_sys_initialize_object (SCM obj, SCM initargs); +SCM scm_sys_prep_layout_x (SCM c); +SCM scm_sys_inherit_magic_x (SCM c, SCM dsupers); +SCM scm_instance_p (SCM obj); +SCM scm_class_name (SCM obj); +SCM scm_class_direct_supers (SCM obj); +SCM scm_class_direct_slots (SCM obj); +SCM scm_class_direct_subclasses (SCM obj); +SCM scm_class_direct_methods (SCM obj); +SCM scm_class_precedence_list (SCM obj); +SCM scm_class_slots (SCM obj); +SCM scm_class_environment (SCM obj); +SCM scm_generic_function_name (SCM obj); +SCM scm_generic_function_methods (SCM obj); +SCM scm_method_generic_function (SCM obj); +SCM scm_method_specializers (SCM obj); +SCM scm_method_procedure (SCM obj); +SCM scm_accessor_method_slot_definition (SCM obj); +SCM scm_sys_fast_slot_ref (SCM obj, SCM index); +SCM scm_sys_fast_slot_set_x (SCM obj, SCM index, SCM value); +SCM scm_slot_ref_using_class (SCM class, SCM obj, SCM slot_name); +SCM scm_slot_set_using_class_x (SCM class, SCM obj, SCM slot_name, SCM value); +SCM scm_slot_bound_using_class_p (SCM class, SCM obj, SCM slot_name); +SCM scm_slot_exists_using_class_p (SCM class, SCM obj, SCM slot_name); +SCM scm_slot_bound_p (SCM obj, SCM slot_name); +SCM scm_slots_exists_p (SCM obj, SCM slot_name); +SCM scm_sys_modify_instance (SCM old, SCM new); +SCM scm_sys_modify_class (SCM old, SCM new); +SCM scm_sys_invalidate_class (SCM class); +SCM scm_make_method_cache (SCM gf); +SCM scm_sys_invalidate_method_cache_x (SCM gf); +SCM scm_generic_capability_p (SCM proc); +SCM scm_enable_primitive_generic_x (SCM subrs); +SCM scm_primitive_generic_generic (SCM subr); +SCM stklos_version (void); +SCM scm_make (SCM args); +SCM scm_find_method (SCM args); +SCM scm_sys_method_more_specific_p (SCM m1, SCM m2, SCM targs); +void scm_init_goops (void); + +#endif /* GOOPSH */ From acfee8e1d04a3ef4841bf6541dcb406c0575337c Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 25 Oct 2000 14:49:56 +0000 Subject: [PATCH 0335/2047] * init.c (scm_init_guile_1): Call the goops module registration function. Added #include "libguile/goops.h". --- libguile/init.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/libguile/init.c b/libguile/init.c index 955cd8d9a..19530f6b6 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -79,6 +79,7 @@ #include "libguile/fports.h" #include "libguile/gc.h" #include "libguile/gdbint.h" +#include "libguile/goops.h" #include "libguile/gsubr.h" #include "libguile/hash.h" #include "libguile/hashtab.h" @@ -585,6 +586,9 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_init_dynamic_linking (); scm_init_lang (); scm_init_script (); + + scm_init_oop_goops_goopscore_module (); + scm_initialized_p = 1; scm_block_gc = 0; /* permit the gc to run */ From 5e8904311f10522a2288b9d2d340964fe21028a7 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 25 Oct 2000 14:50:28 +0000 Subject: [PATCH 0336/2047] * goops.c, objects.c, objects.h, eval.c (scm_make_extended_class, scm_make_port_classes, scm_change_object_class, scm_memoize_method): Changed to ordinary functions (was plugin slots). --- libguile/eval.c | 2 -- libguile/objects.c | 4 ---- libguile/objects.h | 10 +++++----- 3 files changed, 5 insertions(+), 11 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index 5b89e197c..92f20a2c5 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -104,8 +104,6 @@ char *alloca (); #include "libguile/validate.h" #include "libguile/eval.h" -SCM (*scm_memoize_method) (SCM, SCM); - /* The evaluator contains a plethora of EVAL symbols. diff --git a/libguile/objects.c b/libguile/objects.c index dab44d1f0..700662ba2 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -82,10 +82,6 @@ SCM *scm_smob_class = 0; SCM scm_no_applicable_method; -SCM (*scm_make_extended_class) (char *type_name); -void (*scm_make_port_classes) (int ptobnum, char *type_name); -void (*scm_change_object_class) (SCM, SCM, SCM); - /* This function is used for efficient type dispatch. */ SCM scm_class_of (SCM x) diff --git a/libguile/objects.h b/libguile/objects.h index 389552c2b..aa5836e9f 100644 --- a/libguile/objects.h +++ b/libguile/objects.h @@ -210,11 +210,11 @@ extern SCM *scm_smob_class; extern SCM scm_no_applicable_method; -/* Plugin Goops functions. */ -extern SCM (*scm_make_extended_class) (char *type_name); -extern void (*scm_make_port_classes) (int ptobnum, char *type_name); -extern void (*scm_change_object_class) (SCM, SCM, SCM); -extern SCM (*scm_memoize_method) (SCM x, SCM args); +/* Goops functions. */ +extern SCM scm_make_extended_class (char *type_name); +extern void scm_make_port_classes (int ptobnum, char *type_name); +extern void scm_change_object_class (SCM, SCM, SCM); +extern SCM scm_memoize_method (SCM x, SCM args); extern SCM scm_class_of (SCM obj); extern SCM scm_mcache_lookup_cmethod (SCM cache, SCM args); From 14f1d9fec8091a5d29c3f2ac57b31c28825476cb Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 25 Oct 2000 14:51:33 +0000 Subject: [PATCH 0337/2047] *** empty log message *** --- ChangeLog | 7 + Makefile.am | 2 +- NEWS | 65 ++ configure.in | 2 +- libguile.h | 1 + libguile/ChangeLog | 35 + oop/ChangeLog | 4 + oop/Makefile.am | 33 + oop/goops.scm | 1503 ++++++++++++++++++++++++++++++++++ oop/goops/Makefile.am | 33 + oop/goops/active-slot.scm | 68 ++ oop/goops/compile.scm | 136 +++ oop/goops/composite-slot.scm | 84 ++ oop/goops/describe.scm | 202 +++++ oop/goops/dispatch.scm | 270 ++++++ oop/goops/internal.scm | 28 + oop/goops/save.scm | 876 ++++++++++++++++++++ oop/goops/stklos.scm | 98 +++ oop/goops/util.scm | 112 +++ 19 files changed, 3557 insertions(+), 2 deletions(-) create mode 100644 oop/ChangeLog create mode 100644 oop/Makefile.am create mode 100644 oop/goops.scm create mode 100644 oop/goops/Makefile.am create mode 100644 oop/goops/active-slot.scm create mode 100644 oop/goops/compile.scm create mode 100644 oop/goops/composite-slot.scm create mode 100644 oop/goops/describe.scm create mode 100644 oop/goops/dispatch.scm create mode 100644 oop/goops/internal.scm create mode 100644 oop/goops/save.scm create mode 100644 oop/goops/stklos.scm create mode 100644 oop/goops/util.scm diff --git a/ChangeLog b/ChangeLog index e45f5f71e..d9012543f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2000-10-25 Mikael Djurfeldt + + * GUILE-VERSION (LIBGUILE_MAJOR_VERSION): Incremented major + version number to 10 due to the merge of GOOPS. + + * oop: New directory. + 2000-09-20 Keisuke Nishida * libguile.h: #include "libguile/properties.h". diff --git a/Makefile.am b/Makefile.am index 97d238ee0..847e90e33 100644 --- a/Makefile.am +++ b/Makefile.am @@ -19,7 +19,7 @@ ## to the Free Software Foundation, Inc., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA -SUBDIRS = ice-9 qt libltdl libguile guile-config guile-readline doc +SUBDIRS = ice-9 oop qt libltdl libguile guile-config guile-readline doc include_HEADERS = libguile.h diff --git a/NEWS b/NEWS index cb6e69f6e..a4e93984a 100644 --- a/NEWS +++ b/NEWS @@ -8,8 +8,73 @@ Changes since Guile 1.4: * Changes to the distribution +** New modules (oop goops) etc + +The new modules + + (oop goops) + (oop goops describe) + (oop goops save) + (oop goops active-slot) + (oop goops composite-slot) + +plus some GOOPS utility modules have been added. + * Changes to the stand-alone interpreter +** GOOPS has been merged into Guile + +The Guile Object Oriented Programming System has been integrated into +Guile. + +Type + + (use-modules (oop goops)) + +access GOOPS bindings. + +We're now ready to try some basic GOOPS functionality. + +Generic functions + + (define-method (+ (x ) (y )) + (string-append x y)) + + (+ 1 2) --> 3 + (+ "abc" "de") --> "abcde" + +User-defined types + + (define-class <2D-vector> () + (x #:init-value 0 #:accessor x-component #:init-keyword #:x) + (y #:init-value 0 #:accessor y-component #:init-keyword #:y)) + + (define-method write ((obj <2D-vector>) port) + (display (format #f "<~S, ~S>" (x-component obj) (y-component obj)) + port)) + + (define v (make <2D-vector> #:x 3 #:y 4)) + v --> <3, 4> + + (define-method + ((x <2D-vector>) (y <2D-vector>)) + (make <2D-vector> + #:x (+ (x-component x) (x-component y)) + #:y (+ (y-component x) (y-component y)))) + + (+ v v) --> <6, 8> + +Asking for the type of an object + + (class-of v) --> #< <2D-vector> 40241ac0> + <2D-vector> --> #< <2D-vector> 40241ac0> + (class-of 1) --> #< 401b2a98> + --> #< 401b2a98> + + (is-a? v <2D-vector>) --> #t + +See further in the GOOPS tutorial available in the guile-doc +distribution in info (goops.info) and texinfo formats. + ** It's now possible to create modules with controlled environments Example: diff --git a/configure.in b/configure.in index 09e897dee..39f848d3c 100644 --- a/configure.in +++ b/configure.in @@ -507,7 +507,7 @@ AC_SUBST(AWK) AC_SUBST(LIBLOBJS) AC_SUBST(EXTRA_DOT_DOC_FILES) -AC_OUTPUT([Makefile libguile/Makefile libguile/guile-snarf libguile/guile-doc-snarf libguile/guile-func-name-check libguile/guile-snarf.awk libguile/versiondat.h ice-9/Makefile qt/Makefile qt/qt.h qt/md/Makefile qt/time/Makefile guile-config/Makefile doc/Makefile], [chmod +x libguile/guile-snarf libguile/guile-doc-snarf libguile/guile-func-name-check]) +AC_OUTPUT([Makefile libguile/Makefile libguile/guile-snarf libguile/guile-doc-snarf libguile/guile-func-name-check libguile/guile-snarf.awk libguile/versiondat.h ice-9/Makefile oop/Makefile oop/goops/Makefile qt/Makefile qt/qt.h qt/md/Makefile qt/time/Makefile guile-config/Makefile doc/Makefile], [chmod +x libguile/guile-snarf libguile/guile-doc-snarf libguile/guile-func-name-check]) dnl Local Variables: dnl comment-start: "dnl " diff --git a/libguile.h b/libguile.h index 14a80703c..71e641564 100644 --- a/libguile.h +++ b/libguile.h @@ -78,6 +78,7 @@ extern "C" { #include "libguile/fports.h" #include "libguile/gc.h" #include "libguile/gdbint.h" +#include "libguile/goops.h" #include "libguile/gsubr.h" #include "libguile/guardians.h" #include "libguile/hash.h" diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6a1ce3a17..2845fdc77 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,37 @@ +2000-10-25 Mikael Djurfeldt + + This change merges the GOOPS code into Guile. However, GOOPS + is still not initialized until someone asks for the module. + We need to optimize GOOPS initialization time before initializing + it together with the rest of libguile. We also need to add the + C API + primitive methods. Then we can start using it to + modularize Guile, implement a real exception system etc. + + * goops.c, objects.c, objects.h, eval.c (scm_make_extended_class, + scm_make_port_classes, scm_change_object_class, + scm_memoize_method): Changed to ordinary functions (was plugin + slots). + + * goops.c (wrap_init, scm_wrap_object): Unconditionally use + SCM_STRUCT_GC_CHAIN. + (scm_goops_version): Removed. + (scm_oldfmt): and all uses of it: Removed. + (scm_shared_array_root, scm_shared_array_offset, + scm_shared_array_increments): Removed. + (scm_init_goops): No need to support two arg mutex init. + Removed #include "versiondat.h", #include "goops.h". + + * goops.h: Removed various superfluous conditions. + + * init.c (scm_init_guile_1): Call the goops module registration + function. + Added #include "libguile/goops.h". + + * Makefile.am (libguile_la_SOURCES): Added goops.c + (DOT_X_FILES): Added goops.x + (DOT_DOC_FILES): Added goops.doc + (modinclude_HEADERS): Added goops.h + 2000-10-25 Dirk Herrmann * gc.c (scm_igc): Remove references to scm_vector_set_length_x. @@ -59,6 +93,7 @@ * validated.h (SCM_VALIDATE_STRINGORSUBSTR): Deprecated. +>>>>>>> 1.1152 2000-10-20 Marius Vollmer * init.c (scm_init_guile_1, invoke_main_func): Call diff --git a/oop/ChangeLog b/oop/ChangeLog new file mode 100644 index 000000000..8dd08b4f9 --- /dev/null +++ b/oop/ChangeLog @@ -0,0 +1,4 @@ +2000-10-23 Mikael Djurfeldt + + * goops.scm (goops-error): Removed use of oldfmt. + diff --git a/oop/Makefile.am b/oop/Makefile.am new file mode 100644 index 000000000..0587c83be --- /dev/null +++ b/oop/Makefile.am @@ -0,0 +1,33 @@ +## Process this file with automake to produce Makefile.in. +## +## Copyright (C) 2000 Free Software Foundation, Inc. +## +## This file is part of GUILE. +## +## GUILE 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, or +## (at your option) any later version. +## +## GUILE 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 GUILE; see the file COPYING. If not, write +## to the Free Software Foundation, Inc., 59 Temple Place, Suite +## 330, Boston, MA 02111-1307 USA + +AUTOMAKE_OPTIONS = foreign + +SUBDIRS = goops + +# These should be installed and distributed. +oop_sources = goops.scm + +subpkgdatadir = $(pkgdatadir)/$(VERSION)/oop +subpkgdata_DATA = $(oop_sources) +ETAGS_ARGS = $(subpkgdata_DATA) + +EXTRA_DIST = $(oop_sources) diff --git a/oop/goops.scm b/oop/goops.scm new file mode 100644 index 000000000..892cb9ab6 --- /dev/null +++ b/oop/goops.scm @@ -0,0 +1,1503 @@ +;;; installed-scm-file + +;;;; Copyright (C) 1998, 1999, 2000 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; + + +;;;; This software is a derivative work of other copyrighted softwares; the +;;;; copyright notices of these softwares are placed in the file COPYRIGHTS +;;;; +;;;; This file is based upon stklos.stk from the STk distribution by +;;;; Erick Gallesio . +;;;; + +(define-module (oop goops) + :use-module (oop goops goopscore) + :use-module (oop goops util) + :use-module (oop goops dispatch) + :use-module (oop goops compile) + :no-backtrace + ) + +(export ; Define the exported symbols of this file + goops-version is-a? + ensure-metaclass ensure-metaclass-with-supers + define-class class make-class + define-generic make-generic ensure-generic + define-accessor make-accessor ensure-accessor + define-method make-method method add-method! + object-eqv? object-equal? + class-slot-ref class-slot-set! slot-unbound slot-missing + slot-definition-name slot-definition-options slot-definition-allocation + slot-definition-getter slot-definition-setter slot-definition-accessor + slot-definition-init-value slot-definition-init-form + slot-definition-init-thunk slot-definition-init-keyword + slot-init-function class-slot-definition + method-source + compute-cpl compute-std-cpl compute-get-n-set compute-slots + compute-getter-method compute-setter-method + allocate-instance initialize make-instance make + no-next-method no-applicable-method no-method + change-class update-instance-for-different-class + shallow-clone deep-clone + class-redefinition + apply-generic apply-method apply-methods + compute-applicable-methods %compute-applicable-methods + method-more-specific? sort-applicable-methods + class-subclasses class-methods + goops-error + min-fixnum max-fixnum +) + +;;; *fixme* Should go into goops.c + +(export + instance? slot-ref-using-class + slot-set-using-class! slot-bound-using-class? + slot-exists-using-class? slot-ref slot-set! slot-bound? class-of + class-name class-direct-supers class-direct-subclasses + class-direct-methods class-direct-slots class-precedence-list + class-slots class-environment + generic-function-name + generic-function-methods method-generic-function method-specializers + primitive-generic-generic enable-primitive-generic! + method-procedure accessor-method-slot-definition + slot-exists? make find-method get-keyword + %logand) + + +(define min-fixnum (- (expt 2 29))) + +(define max-fixnum (- (expt 2 29) 1)) + +;; +;; goops-error +;; +(define (goops-error format-string . args) + (save-stack) + (scm-error 'goops-error #f format-string args '())) + +;; +;; is-a? +;; +(define (is-a? obj class) + (and (memq class (class-precedence-list (class-of obj))) #t)) + + +;;; +;;; {Meta classes} +;;; + +(define ensure-metaclass-with-supers + (let ((table-of-metas '())) + (lambda (meta-supers) + (let ((entry (assoc meta-supers table-of-metas))) + (if entry + ;; Found a previously created metaclass + (cdr entry) + ;; Create a new meta-class which inherit from "meta-supers" + (let ((new (make #:dsupers meta-supers + #:slots '() + #:name (gensym "metaclass")))) + (set! table-of-metas (cons (cons meta-supers new) table-of-metas)) + new)))))) + +(define (ensure-metaclass supers env) + (if (null? supers) + + (let* ((all-metas (map (lambda (x) (class-of x)) supers)) + (all-cpls (apply append + (map (lambda (m) + (cdr (class-precedence-list m))) + all-metas))) + (needed-metas '())) + ;; Find the most specific metaclasses. The new metaclass will be + ;; a subclass of these. + (for-each + (lambda (meta) + (if (and (not (member meta all-cpls)) + (not (member meta needed-metas))) + (set! needed-metas (append needed-metas (list meta))))) + all-metas) + ;; Now return a subclass of the metaclasses we found. + (if (null? (cdr needed-metas)) + (car needed-metas) ; If there's only one, just use it. + (ensure-metaclass-with-supers needed-metas))))) + +;;; +;;; {Classes} +;;; + +;;; (define-class NAME (SUPER ...) SLOT-DEFINITION ... OPTION ...) +;;; +;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...) +;;; OPTION ::= KEYWORD VALUE +;;; +(define (define-class-pre-definition keyword exp env) + (case keyword + ((#:getter #:setter) + (if (defined? exp env) + `(define ,exp (ensure-generic ,exp ',exp)) + `(define ,exp (make-generic ',exp)))) + ((#:accessor) + (if (defined? exp env) + `(define ,exp (ensure-accessor ,exp ',exp)) + `(define ,exp (make-accessor ',exp)))) + (else #f))) + +;;; This code should be implemented in C. +;;; +(define define-class + (letrec (;; Some slot options require extra definitions to be made. + ;; In particular, we want to make sure that the generic + ;; function objects which represent accessors exist + ;; before `make-class' tries to add methods to them. + ;; + ;; Postpone error handling to class macro. + ;; + (pre-definitions + (lambda (slots env) + (do ((slots slots (cdr slots)) + (definitions '() + (if (pair? (car slots)) + (do ((options (cdar slots) (cddr options)) + (definitions definitions + (cond ((not (symbol? (cadr options))) + definitions) + ((define-class-pre-definition + (car options) + (cadr options) + env) + => (lambda (definition) + (cons definition definitions))) + (else definitions)))) + ((not (and (pair? options) + (pair? (cdr options)))) + definitions)) + definitions))) + ((or (not (pair? slots)) + (keyword? (car slots))) + (reverse definitions))))) + + ;; Syntax + (name cadr) + (slots cdddr)) + + (procedure->macro + (lambda (exp env) + (cond ((not (top-level-env? env)) + (goops-error "define-class: Only allowed at top level")) + ((not (and (list? exp) (>= (length exp) 3))) + (goops-error "missing or extra expression")) + (else + (let ((name (name exp))) + `(begin + ;; define accessors + ,@(pre-definitions (slots exp) env) + + ,(if (defined? name env) + + ;; redefine an old class + `(define ,name + (let ((old ,name) + (new (class ,@(cddr exp) #:name ',name))) + (if (and (is-a? old ) + ;; Prevent redefinition of non-objects + (memq + (class-precedence-list old))) + (class-redefinition old new) + new))) + + ;; define a new class + `(define ,name + (class ,@(cddr exp) #:name ',name))))))))))) + +(define standard-define-class define-class) + +;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...) +;;; +;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...) +;;; OPTION ::= KEYWORD VALUE +;;; +(define class + (letrec ((slot-option-keyword car) + (slot-option-value cadr) + (process-slot-options + (lambda (options) + (let loop ((options options) + (res '())) + (cond ((null? options) + (reverse res)) + ((null? (cdr options)) + (goops-error "malformed slot option list")) + ((not (keyword? (slot-option-keyword options))) + (goops-error "malformed slot option list")) + (else + (case (slot-option-keyword options) + ((#:init-form) + (loop (cddr options) + (append (list `(lambda () + ,(slot-option-value options)) + #:init-thunk + (list 'quote + (slot-option-value options)) + #:init-form) + res))) + (else + (loop (cddr options) + (cons (cadr options) + (cons (car options) + res))))))))))) + + (procedure->memoizing-macro + (let ((supers cadr) + (slots cddr) + (options cdddr)) + (lambda (exp env) + (cond ((not (and (list? exp) (>= (length exp) 2))) + (goops-error "missing or extra expression")) + ((not (list? (supers exp))) + (goops-error "malformed superclass list: ~S" (supers exp))) + (else + (let ((slot-defs (cons #f '()))) + (do ((slots (slots exp) (cdr slots)) + (defs slot-defs (cdr defs))) + ((or (null? slots) + (keyword? (car slots))) + `(make-class + ;; evaluate super class variables + (list ,@(supers exp)) + ;; evaluate slot definitions, except the slot name! + (list ,@(cdr slot-defs)) + ;; evaluate class options + ,@slots + ;; place option last in case someone wants to + ;; pass a different value + #:environment ',env)) + (set-cdr! + defs + (list (if (pair? (car slots)) + `(list ',(slot-definition-name (car slots)) + ,@(process-slot-options + (slot-definition-options + (car slots)))) + `(list ',(car slots)))))))))))))) + +(define (make-class supers slots . options) + (let ((env (or (get-keyword #:environment options #f) + (top-level-env)))) + (let* ((name (get-keyword #:name options (make-unbound))) + (supers (if (not (or-map (lambda (class) + (memq + (class-precedence-list class))) + supers)) + (append supers (list )) + supers)) + (metaclass (or (get-keyword #:metaclass options #f) + (ensure-metaclass supers env)))) + + ;; Verify that all direct slots are different and that we don't inherit + ;; several time from the same class + (let ((tmp1 (find-duplicate supers)) + (tmp2 (find-duplicate (map slot-definition-name slots)))) + (if tmp1 + (goops-error "make-class: super class ~S is duplicate in class ~S" + tmp1 name)) + (if tmp2 + (goops-error "make-class: slot ~S is duplicate in class ~S" + tmp2 name))) + + ;; Everything seems correct, build the class + (apply make metaclass + #:dsupers supers + #:slots slots + #:name name + #:environment env + options)))) + +;;; +;;; {Generic functions and accessors} +;;; + +(define define-generic + (procedure->macro + (lambda (exp env) + (let ((name (cadr exp))) + (cond ((not (symbol? name)) + (goops-error "bad generic function name: ~S" name)) + ((defined? name env) + `(define ,name + (if (is-a? ,name ) + (make #:name ',name) + (ensure-generic ,name ',name)))) + (else + `(define ,name (make #:name ',name)))))))) + +(define (make-generic . name) + (let ((name (and (pair? name) (car name)))) + (make #:name name))) + +(define (ensure-generic old-definition . name) + (let ((name (and (pair? name) (car name)))) + (cond ((is-a? old-definition ) old-definition) + ((procedure-with-setter? old-definition) + (make + #:name name + #:default (procedure old-definition) + #:setter (setter old-definition))) + ((procedure? old-definition) + (make #:name name #:default old-definition)) + (else (make #:name name))))) + +(define define-accessor + (procedure->macro + (lambda (exp env) + (let ((name (cadr exp))) + (cond ((not (symbol? name)) + (goops-error "bad accessor name: ~S" name)) + ((defined? name env) + `(define ,name + (if (and (is-a? ,name ) + (is-a? (setter ,name) )) + (make-accessor ',name) + (ensure-accessor ,name ',name)))) + (else + `(define ,name (make-accessor ',name)))))))) + +(define (make-setter-name name) + (string->symbol (string-append "setter:" (symbol->string name)))) + +(define (make-accessor . name) + (let ((name (and (pair? name) (car name)))) + (make + #:name name + #:setter (make + #:name (and name (make-setter-name name)))))) + +(define (ensure-accessor proc . name) + (let ((name (and (pair? name) (car name)))) + (cond ((is-a? proc ) + (if (is-a? (setter proc) ) + proc + (upgrade-generic-with-setter proc (setter proc)))) + ((is-a? proc ) + (upgrade-generic-with-setter proc (make-generic name))) + ((procedure-with-setter? proc) + (make + #:name name + #:default (procedure proc) + #:setter (ensure-generic (setter proc) name))) + ((procedure? proc) + (ensure-accessor (ensure-generic proc name) name)) + (else + (make-accessor name))))) + +(define (upgrade-generic-with-setter generic setter) + (let ((methods (generic-function-methods generic)) + (gws (make + #:name (generic-function-name generic) + #:setter setter))) + ;; Steal old methods + (for-each (lambda (method) + (slot-set! method 'generic-function gws)) + methods) + (slot-set! gws 'methods methods) + gws)) + +;;; +;;; {Methods} +;;; + +(define define-method + (procedure->memoizing-macro + (lambda (exp env) + (let ((name (cadr exp))) + (if (and (pair? name) + (eq? (car name) 'setter) + (pair? (cdr name)) + (symbol? (cadr name)) + (null? (cddr name))) + (let ((name (cadr name))) + (cond ((not (symbol? name)) + (goops-error "bad method name: ~S" name)) + ((defined? name env) + `(begin + ;; *fixme* Temporary hack for the current module system + (if (not ,name) + (define-generic ,name)) + (add-method! (setter ,name) (method ,@(cddr exp))))) + (else + `(begin + (define-accessor ,name) + (add-method! (setter ,name) (method ,@(cddr exp))))))) + (cond ((pair? name) + ;; Convert new syntax to old + `(define-method ,(car name) ,(cdr name) ,@(cddr exp))) + ((not (symbol? name)) + (goops-error "bad method name: ~S" name)) + ((defined? name env) + `(begin + ;; *fixme* Temporary hack for the current module system + (if (not ,name) + (define-generic ,name)) + (add-method! ,name (method ,@(cddr exp))))) + (else + `(begin + (define-generic ,name) + (add-method! ,name (method ,@(cddr exp))))))))))) + +(define (make-method specializers procedure) + (make + #:specializers specializers + #:procedure procedure)) + +(define method + (letrec ((specializers + (lambda (ls) + (cond ((null? ls) (list ls)) + ((pair? ls) (cons (if (pair? (car ls)) + (cadar ls) + ') + (specializers (cdr ls)))) + (else '())))) + (formals + (lambda (ls) + (if (pair? ls) + (cons (if (pair? (car ls)) (caar ls) (car ls)) + (formals (cdr ls))) + ls)))) + (procedure->memoizing-macro + (lambda (exp env) + (let ((args (cadr exp)) + (body (cddr exp))) + `(make + #:specializers (list* ,@(specializers args)) + #:procedure (lambda ,(formals args) + ,@(if (null? body) + (list *unspecified*) + body)))))))) + +;;; +;;; {add-method!} +;;; + +(define (add-method-in-classes! m) + ;; Add method in all the classes which appears in its specializers list + (for-each* (lambda (x) + (let ((dm (class-direct-methods x))) + (if (not (memv m dm)) + (slot-set! x 'direct-methods (cons m dm))))) + (method-specializers m))) + +(define (remove-method-in-classes! m) + ;; Remove method in all the classes which appears in its specializers list + (for-each* (lambda (x) + (slot-set! x + 'direct-methods + (delv! m (class-direct-methods x)))) + (method-specializers m))) + +(define (compute-new-list-of-methods gf new) + (let ((new-spec (method-specializers new)) + (methods (generic-function-methods gf))) + (let loop ((l methods)) + (if (null? l) + (cons new methods) + (if (equal? (method-specializers (car l)) new-spec) + (begin + ;; This spec. list already exists. Remove old method from dependents + (remove-method-in-classes! (car l)) + (set-car! l new) + methods) + (loop (cdr l))))))) + +(define (internal-add-method! gf m) + (slot-set! m 'generic-function gf) + (slot-set! gf 'methods (compute-new-list-of-methods gf m)) + (let ((specializers (slot-ref m 'specializers))) + (slot-set! gf 'n-specialized + (let ((n-specialized (slot-ref gf 'n-specialized))) + ;; The magnitude indicates # specializers. + ;; A negative value indicates that at least one + ;; method has rest arguments. (Ugly but effective + ;; space optimization saving one slot in GF objects.) + (cond ((negative? n-specialized) + (- (max (+ 1 (length* specializers)) + (abs n-specialized)))) + ((list? specializers) + (max (length specializers) + n-specialized)) + (else + (- (+ 1 (max (length* specializers) + n-specialized))))) + ))) + (%invalidate-method-cache! gf) + (add-method-in-classes! m) + *unspecified*) + +(define-generic add-method!) + +(internal-add-method! add-method! + (make + #:specializers (list ) + #:procedure internal-add-method!)) + +(define-method add-method! ((proc ) (m )) + (if (generic-capability? proc) + (begin + (enable-primitive-generic! proc) + (add-method! proc m)) + (next-method))) + +(define-method add-method! ((pg ) (m )) + (add-method! (primitive-generic-generic pg) m)) + +(define-method add-method! (obj (m )) + (goops-error "~S is not a valid generic function" obj)) + +;;; +;;; {Access to meta objects} +;;; + +;;; +;;; Methods +;;; +(define-method method-source ((m )) + (let* ((spec (map* class-name (slot-ref m 'specializers))) + (proc (procedure-source (slot-ref m 'procedure))) + (args (cadr proc)) + (body (cddr proc))) + (cons 'method + (cons (map* list args spec) + body)))) + +;;; +;;; Slots +;;; +(define slot-definition-name car) + +(define slot-definition-options cdr) + +(define (slot-definition-allocation s) + (get-keyword #:allocation (cdr s) #:instance)) + +(define (slot-definition-getter s) + (get-keyword #:getter (cdr s) #f)) + +(define (slot-definition-setter s) + (get-keyword #:setter (cdr s) #f)) + +(define (slot-definition-accessor s) + (get-keyword #:accessor (cdr s) #f)) + +(define (slot-definition-init-value s) + ;; can be #f, so we can't use #f as non-value + (get-keyword #:init-value (cdr s) (make-unbound))) + +(define (slot-definition-init-form s) + (get-keyword #:init-form (cdr s) (make-unbound))) + +(define (slot-definition-init-thunk s) + (get-keyword #:init-thunk (cdr s) #f)) + +(define (slot-definition-init-keyword s) + (get-keyword #:init-keyword (cdr s) #f)) + +(define (class-slot-definition class slot-name) + (assq slot-name (class-slots class))) + +(define (slot-init-function class slot-name) + (cadr (assq slot-name (slot-ref class 'getters-n-setters)))) + + +;;; +;;; {Standard methods used by the C runtime} +;;; + +;;; Methods to compare objects +;;; + +(define-method object-eqv? (x y) #f) +(define-method object-equal? (x y) (eqv? x y)) + +;;; +;;; methods to display/write an object +;;; + +; Code for writing objects must test that the slots they use are +; bound. Otherwise a slot-unbound method will be called and will +; conduct to an infinite loop. + +;; Write +(define (display-address o file) + (display (number->string (object-address o) 16) file)) + +(define-method write (o file) + (display "# file)) + +(define write-object (primitive-generic-generic write)) + +(define-method write ((o ) file) + (let ((class (class-of o))) + (if (slot-bound? class 'name) + (begin + (display "#<" file) + (display (class-name class) file) + (display #\space file) + (display-address o file) + (display #\> file)) + (next-method)))) + +(define-method write ((o ) file) + (let ((class (class-of o))) + (if (slot-bound? class 'name) + (begin + (display "# file)) + (next-method)))) + +(define-method write ((class ) file) + (let ((meta (class-of class))) + (if (and (slot-bound? class 'name) + (slot-bound? meta 'name)) + (begin + (display "#<" file) + (display (class-name meta) file) + (display #\space file) + (display (class-name class) file) + (display #\space file) + (display-address class file) + (display #\> file)) + (next-method)))) + +(define-method write ((gf ) file) + (let ((meta (class-of gf))) + (if (and (slot-bound? meta 'name) + (slot-bound? gf 'methods)) + (begin + (display "#<" file) + (display (class-name meta) file) + (let ((name (generic-function-name gf))) + (if name + (begin + (display #\space file) + (display name file)))) + (display " (" file) + (display (length (generic-function-methods gf)) file) + (display ")>" file)) + (next-method)))) + +(define-method write ((o ) file) + (let ((meta (class-of o))) + (if (and (slot-bound? meta 'name) + (slot-bound? o 'specializers)) + (begin + (display "#<" file) + (display (class-name meta) file) + (display #\space file) + (display (map* (lambda (spec) + (if (slot-bound? spec 'name) + (slot-ref spec 'name) + spec)) + (method-specializers o)) + file) + (display #\space file) + (display-address o file) + (display #\> file)) + (next-method)))) + +;; Display (do the same thing as write by default) +(define-method display (o file) + (write-object o file)) + +;;; +;;; slot access +;;; + +(define (class-slot-g-n-s class slot-name) + (let* ((this-slot (assq slot-name (slot-ref class 'slots))) + (g-n-s (cddr (or (assq slot-name (slot-ref class 'getters-n-setters)) + (slot-missing class slot-name))))) + (if (not (memq (slot-definition-allocation this-slot) + '(#:class #:each-subclass))) + (slot-missing class slot-name)) + g-n-s)) + +(define (class-slot-ref class slot) + (let ((x ((car (class-slot-g-n-s class slot)) #f))) + (if (unbound? x) + (slot-unbound class slot) + x))) + +(define (class-slot-set! class slot value) + ((cadr (class-slot-g-n-s class slot)) #f value)) + +(define-method slot-unbound ((c ) (o ) s) + (goops-error "Slot `~S' is unbound in object ~S" s o)) + +(define-method slot-unbound ((c ) s) + (goops-error "Slot `~S' is unbound in class ~S" s c)) + +(define-method slot-unbound ((o )) + (goops-error "Unbound slot in object ~S" o)) + +(define-method slot-missing ((c ) (o ) s) + (goops-error "No slot with name `~S' in object ~S" s o)) + +(define-method slot-missing ((c ) s) + (goops-error "No class slot with name `~S' in class ~S" s c)) + + +(define-method slot-missing ((c ) (o ) s value) + (slot-missing c o s)) + +;;; Methods for the possible error we can encounter when calling a gf + +(define-method no-next-method ((gf ) args) + (goops-error "No next method when calling ~S\nwith arguments ~S" gf args)) + +(define-method no-applicable-method ((gf ) args) + (goops-error "No applicable method for ~S in call ~S" + gf (cons (generic-function-name gf) args))) + +(define-method no-method ((gf ) args) + (goops-error "No method defined for ~S" gf)) + +;;; +;;; {Cloning functions (from rdeline@CS.CMU.EDU)} +;;; + +(define-method shallow-clone ((self )) + (let ((clone (%allocate-instance (class-of self) '())) + (slots (map slot-definition-name + (class-slots (class-of self))))) + (for-each (lambda (slot) + (if (slot-bound? self slot) + (slot-set! clone slot (slot-ref self slot)))) + slots) + clone)) + +(define-method deep-clone ((self )) + (let ((clone (%allocate-instance (class-of self) '())) + (slots (map slot-definition-name + (class-slots (class-of self))))) + (for-each (lambda (slot) + (if (slot-bound? self slot) + (slot-set! clone slot + (let ((value (slot-ref self slot))) + (if (instance? value) + (deep-clone value) + value))))) + slots) + clone)) + +;;; +;;; {Class redefinition utilities} +;;; + +;;; (class-redefinition OLD NEW) +;;; + +;;; Has correct the following conditions: + +;;; Methods +;;; +;;; 1. New accessor specializers refer to new header +;;; +;;; Classes +;;; +;;; 1. New class cpl refers to the new class header +;;; 2. Old class header exists on old super classes direct-subclass lists +;;; 3. New class header exists on new super classes direct-subclass lists + +(define-method class-redefinition ((old ) (new )) + ;; Work on direct methods: + ;; 1. Remove accessor methods from the old class + ;; 2. Patch the occurences of new in the specializers by old + ;; 3. Displace the methods from old to new + (remove-class-accessors! old) ;; -1- + (let ((methods (class-direct-methods new))) + (for-each (lambda (m) + (update-direct-method! m new old)) ;; -2- + methods) + (slot-set! new + 'direct-methods + (append methods (class-direct-methods old)))) + + ;; Substitute old for new in new cpl + (set-car! (slot-ref new 'cpl) old) + + ;; Remove the old class from the direct-subclasses list of its super classes + (for-each (lambda (c) (slot-set! c 'direct-subclasses + (delv! old (class-direct-subclasses c)))) + (class-direct-supers old)) + + ;; Replace the new class with the old in the direct-subclasses of the supers + (for-each (lambda (c) + (slot-set! c 'direct-subclasses + (cons old (delv! new (class-direct-subclasses c))))) + (class-direct-supers new)) + + ;; Swap object headers + (%modify-class old new) + + ;; Now old is NEW! + + ;; Redefine all the subclasses of old to take into account modification + (for-each + (lambda (c) + (update-direct-subclass! c new old)) + (class-direct-subclasses new)) + + ;; Invalidate class so that subsequent instances slot accesses invoke + ;; change-object-class + (slot-set! new 'redefined old) + (%invalidate-class new) ;must come after slot-set! + + old) + +;;; +;;; remove-class-accessors! +;;; + +(define-method remove-class-accessors! ((c )) + (for-each (lambda (m) + (if (is-a? m ) + (remove-method-in-classes! m))) + (class-direct-methods c))) + +;;; +;;; update-direct-method! +;;; + +(define-method update-direct-method! ((m ) + (old ) + (new )) + (let loop ((l (method-specializers m))) + ;; Note: the in dotted list is never used. + ;; So we can work as if we had only proper lists. + (if (pair? l) + (begin + (if (eqv? (car l) old) + (set-car! l new)) + (loop (cdr l)))))) + +;;; +;;; update-direct-subclass! +;;; + +(define-method update-direct-subclass! ((c ) + (old ) + (new )) + (class-redefinition c + (make-class (class-direct-supers c) + (class-direct-slots c) + #:name (class-name c) + #:environment (slot-ref c 'environment) + #:metaclass (class-of c)))) + +;;; +;;; {Utilities for INITIALIZE methods} +;;; + +;;; compute-slot-accessors +;;; +(define (compute-slot-accessors class slots env) + (for-each + (lambda (s g-n-s) + (let ((name (slot-definition-name s)) + (getter-function (slot-definition-getter s)) + (setter-function (slot-definition-setter s)) + (accessor (slot-definition-accessor s))) + (if getter-function + (add-method! getter-function + (compute-getter-method class g-n-s))) + (if setter-function + (add-method! setter-function + (compute-setter-method class g-n-s))) + (if accessor + (begin + (add-method! accessor + (compute-getter-method class g-n-s)) + (add-method! (setter accessor) + (compute-setter-method class g-n-s)))))) + slots (slot-ref class 'getters-n-setters))) + +(define-method compute-getter-method ((class ) slotdef) + (let ((init-thunk (cadr slotdef)) + (g-n-s (cddr slotdef))) + (make + #:specializers (list class) + #:procedure (cond ((pair? g-n-s) + (if init-thunk + (car g-n-s) + (make-generic-bound-check-getter (car g-n-s)) + )) + (init-thunk + (standard-get g-n-s)) + (else + (bound-check-get g-n-s))) + #:slot-definition slotdef))) + +(define-method compute-setter-method ((class ) slotdef) + (let ((g-n-s (cddr slotdef))) + (make + #:specializers (list class ) + #:procedure (if (pair? g-n-s) + (cadr g-n-s) + (standard-set g-n-s)) + #:slot-definition slotdef))) + +(define (make-generic-bound-check-getter proc) + (let ((source (and (closure? proc) (procedure-source proc)))) + (if (and source (null? (cdddr source))) + (let ((obj (caadr source))) + ;; smart closure compilation + (local-eval + `(lambda (,obj) (,assert-bound ,(caddr source) ,obj)) + (procedure-environment proc))) + (lambda (o) (assert-bound (proc o) o))))) + +(define n-standard-accessor-methods 10) + +(define bound-check-get-methods (make-vector n-standard-accessor-methods #f)) +(define standard-get-methods (make-vector n-standard-accessor-methods #f)) +(define standard-set-methods (make-vector n-standard-accessor-methods #f)) + +(define (standard-accessor-method make methods) + (lambda (index) + (cond ((>= index n-standard-accessor-methods) (make index)) + ((vector-ref methods index)) + (else (let ((m (make index))) + (vector-set! methods index m) + m))))) + +(define (make-bound-check-get index) + (local-eval `(lambda (o) (@assert-bound-ref o ,index)) (the-environment))) + +(define (make-get index) + (local-eval `(lambda (o) (@slot-ref o ,index)) (the-environment))) + +(define (make-set index) + (local-eval `(lambda (o v) (@slot-set! o ,index v)) (the-environment))) + +(define bound-check-get + (standard-accessor-method make-bound-check-get bound-check-get-methods)) +(define standard-get (standard-accessor-method make-get standard-get-methods)) +(define standard-set (standard-accessor-method make-set standard-set-methods)) + +;;; compute-getters-n-setters +;;; +(define (compute-getters-n-setters class slots env) + + (define (compute-slot-init-function s) + (or (slot-definition-init-thunk s) + (let ((init (slot-definition-init-value s))) + (and (not (unbound? init)) + (lambda () init))))) + + (define (verify-accessors slot l) + (if (pair? l) + (let ((get (car l)) + (set (cadr l))) + (if (not (and (closure? get) + (= (car (procedure-property get 'arity)) 1))) + (goops-error "Bad getter closure for slot `~S' in ~S: ~S" + slot class get)) + (if (not (and (closure? set) + (= (car (procedure-property set 'arity)) 2))) + (goops-error "Bad setter closure for slot `~S' in ~S: ~S" + slot class set))))) + + (map (lambda (s) + (let* ((g-n-s (compute-get-n-set class s)) + (name (slot-definition-name s))) + ; For each slot we have '(name init-function getter setter) + ; If slot, we have the simplest form '(name init-function . index) + (verify-accessors name g-n-s) + (cons name + (cons (compute-slot-init-function s) + g-n-s)))) + slots)) + +;;; compute-cpl +;;; +;;; Correct behaviour: +;;; +;;; (define-class food ()) +;;; (define-class fruit (food)) +;;; (define-class spice (food)) +;;; (define-class apple (fruit)) +;;; (define-class cinnamon (spice)) +;;; (define-class pie (apple cinnamon)) +;;; => cpl (pie) = pie apple fruit cinnamon spice food object top +;;; +;;; (define-class d ()) +;;; (define-class e ()) +;;; (define-class f ()) +;;; (define-class b (d e)) +;;; (define-class c (e f)) +;;; (define-class a (b c)) +;;; => cpl (a) = a b d c e f object top +;;; + +(define-method compute-cpl ((class )) + (compute-std-cpl class class-direct-supers)) + +;; Support + +(define (only-non-null lst) + (filter (lambda (l) (not (null? l))) lst)) + +(define (compute-std-cpl c get-direct-supers) + (let ((c-direct-supers (get-direct-supers c))) + (merge-lists (list c) + (only-non-null (append (map class-precedence-list + c-direct-supers) + (list c-direct-supers)))))) + +(define (merge-lists reversed-partial-result inputs) + (cond + ((every null? inputs) + (reverse! reversed-partial-result)) + (else + (let* ((candidate (lambda (c) + (and (not (any (lambda (l) + (memq c (cdr l))) + inputs)) + c))) + (candidate-car (lambda (l) + (and (not (null? l)) + (candidate (car l))))) + (next (any candidate-car inputs))) + (if (not next) + (goops-error "merge-lists: Inconsistent precedence graph")) + (let ((remove-next (lambda (l) + (if (eq? (car l) next) + (cdr l) + l)))) + (merge-lists (cons next reversed-partial-result) + (only-non-null (map remove-next inputs)))))))) + +;; Modified from TinyClos: +;; +;; A simple topological sort. +;; +;; It's in this file so that both TinyClos and Objects can use it. +;; +;; This is a fairly modified version of code I originally got from Anurag +;; Mendhekar . +;; + +(define (compute-clos-cpl c get-direct-supers) + (top-sort ((build-transitive-closure get-direct-supers) c) + ((build-constraints get-direct-supers) c) + (std-tie-breaker get-direct-supers))) + + +(define (top-sort elements constraints tie-breaker) + (let loop ((elements elements) + (constraints constraints) + (result '())) + (if (null? elements) + result + (let ((can-go-in-now + (filter + (lambda (x) + (every (lambda (constraint) + (or (not (eq? (cadr constraint) x)) + (memq (car constraint) result))) + constraints)) + elements))) + (if (null? can-go-in-now) + (goops-error "top-sort: Invalid constraints") + (let ((choice (if (null? (cdr can-go-in-now)) + (car can-go-in-now) + (tie-breaker result + can-go-in-now)))) + (loop + (filter (lambda (x) (not (eq? x choice))) + elements) + constraints + (append result (list choice))))))))) + +(define (std-tie-breaker get-supers) + (lambda (partial-cpl min-elts) + (let loop ((pcpl (reverse partial-cpl))) + (let ((current-elt (car pcpl))) + (let ((ds-of-ce (get-supers current-elt))) + (let ((common (filter (lambda (x) + (memq x ds-of-ce)) + min-elts))) + (if (null? common) + (if (null? (cdr pcpl)) + (goops-error "std-tie-breaker: Nothing valid") + (loop (cdr pcpl))) + (car common)))))))) + + +(define (build-transitive-closure get-follow-ons) + (lambda (x) + (let track ((result '()) + (pending (list x))) + (if (null? pending) + result + (let ((next (car pending))) + (if (memq next result) + (track result (cdr pending)) + (track (cons next result) + (append (get-follow-ons next) + (cdr pending))))))))) + +(define (build-constraints get-follow-ons) + (lambda (x) + (let loop ((elements ((build-transitive-closure get-follow-ons) x)) + (this-one '()) + (result '())) + (if (or (null? this-one) (null? (cdr this-one))) + (if (null? elements) + result + (loop (cdr elements) + (cons (car elements) + (get-follow-ons (car elements))) + result)) + (loop elements + (cdr this-one) + (cons (list (car this-one) (cadr this-one)) + result)))))) + +;;; compute-get-n-set +;;; +(define-method compute-get-n-set ((class ) s) + (case (slot-definition-allocation s) + ((#:instance) ;; Instance slot + ;; get-n-set is just its offset + (let ((already-allocated (slot-ref class 'nfields))) + (slot-set! class 'nfields (+ already-allocated 1)) + already-allocated)) + + ((#:class) ;; Class slot + ;; Class-slots accessors are implemented as 2 closures around + ;; a Scheme variable. As instance slots, class slots must be + ;; unbound at init time. + (let ((name (slot-definition-name s))) + (if (memq name (map slot-definition-name (class-direct-slots class))) + ;; This slot is direct; create a new shared variable + (make-closure-variable class) + ;; Slot is inherited. Find its definition in superclass + (let loop ((l (cdr (class-precedence-list class)))) + (let ((r (assoc name (slot-ref (car l) 'getters-n-setters)))) + (if r + (cddr r) + (loop (cdr l)))))))) + + ((#:each-subclass) ;; slot shared by instances of direct subclass. + ;; (Thomas Buerger, April 1998) + (make-closure-variable class)) + + ((#:virtual) ;; No allocation + ;; slot-ref and slot-set! function must be given by the user + (let ((get (get-keyword #:slot-ref (slot-definition-options s) #f)) + (set (get-keyword #:slot-set! (slot-definition-options s) #f)) + (env (class-environment class))) + (if (not (and get set)) + (goops-error "You must supply a :slot-ref and a :slot-set! in ~S" + s)) + (list get set))) + (else (next-method)))) + +(define (make-closure-variable class) + (let ((shared-variable (make-unbound))) + (list (lambda (o) shared-variable) + (lambda (o v) (set! shared-variable v))))) + +(define-method compute-get-n-set ((o ) s) + (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s))) + +(define-method compute-slots ((class )) + (%compute-slots class)) + +;;; +;;; {Initialize} +;;; + +(define-method initialize ((object ) initargs) + (%initialize-object object initargs)) + +(define-method initialize ((class ) initargs) + (next-method) + (let ((dslots (get-keyword #:slots initargs '())) + (supers (get-keyword #:dsupers initargs '())) + (env (get-keyword #:environment initargs (top-level-env)))) + + (slot-set! class 'name (get-keyword #:name initargs '???)) + (slot-set! class 'direct-supers supers) + (slot-set! class 'direct-slots dslots) + (slot-set! class 'direct-subclasses '()) + (slot-set! class 'direct-methods '()) + (slot-set! class 'cpl (compute-cpl class)) + (slot-set! class 'redefined #f) + (slot-set! class 'environment env) + (let ((slots (compute-slots class))) + (slot-set! class 'slots slots) + (slot-set! class 'nfields 0) + (slot-set! class 'getters-n-setters (compute-getters-n-setters class + slots + env)) + ;; Build getters - setters - accessors + (compute-slot-accessors class slots env)) + + ;; Update the "direct-subclasses" of each inherited classes + (for-each (lambda (x) + (slot-set! x + 'direct-subclasses + (cons class (slot-ref x 'direct-subclasses)))) + supers) + + ;; Support for the underlying structs: + + ;; Inherit class flags (invisible on scheme level) from supers + (%inherit-magic! class supers) + + ;; Set the layout slot + (%prep-layout! class))) + +(define object-procedure-tags + '(utag_closure utag_subr_1 utag_subr_2 utag_subr3 utag_lsubr_2)) + +(define (initialize-object-procedure object initargs) + (let ((proc (get-keyword #:procedure initargs #f))) + (cond ((not proc)) + ((pair? proc) + (apply set-object-procedure! object proc)) + ((memq (tag proc) object-procedure-tags) + (set-object-procedure! object proc)) + (else + (set-object-procedure! object + (lambda args (apply proc args))))))) + +(define-method initialize ((class ) initargs) + (next-method) + (initialize-object-procedure class initargs)) + +(define-method initialize ((owsc ) initargs) + (next-method) + (%set-object-setter! owsc (get-keyword #:setter initargs #f))) + +(define-method initialize ((entity ) initargs) + (next-method) + (initialize-object-procedure entity initargs)) + +(define-method initialize ((ews ) initargs) + (next-method) + (%set-object-setter! ews (get-keyword #:setter initargs #f))) + +(define-method initialize ((generic ) initargs) + (let ((previous-definition (get-keyword #:default initargs #f)) + (name (get-keyword #:name initargs #f))) + (next-method) + (slot-set! generic 'methods (if (is-a? previous-definition ) + (list (make + #:specializers + #:procedure + (lambda l + (apply previous-definition + l)))) + '())) + (if name + (set-procedure-property! generic 'name name)) + )) + +(define-method initialize ((method ) initargs) + (next-method) + (slot-set! method 'generic-function (get-keyword #:generic-function initargs #f)) + (slot-set! method 'specializers (get-keyword #:specializers initargs '())) + (slot-set! method 'procedure (get-keyword #:procedure initargs (lambda l '()))) + (slot-set! method 'code-table '())) + +(define-method initialize ((obj ) initargs)) + +;;; +;;; {Change-class} +;;; + +(define (change-object-class old-instance old-class new-class) + (let ((new-instance (allocate-instance new-class ()))) + ;; Initalize the slot of the new instance + (for-each (lambda (slot) + (if (and (slot-exists-using-class? old-class old-instance slot) + (eq? (slot-definition-allocation + (class-slot-definition old-class slot)) + #:instance) + (slot-bound-using-class? old-class old-instance slot)) + ;; Slot was present and allocated in old instance; copy it + (slot-set-using-class! + new-class + new-instance + slot + (slot-ref-using-class old-class old-instance slot)) + ;; slot was absent; initialize it with its default value + (let ((init (slot-init-function new-class slot))) + (if init + (slot-set-using-class! + new-class + new-instance + slot + (apply init '())))))) + (map slot-definition-name (class-slots new-class))) + ;; Exchange old and new instance in place to keep pointers valid + (%modify-instance old-instance new-instance) + ;; Allow class specific updates of instances (which now are swapped) + (update-instance-for-different-class new-instance old-instance) + old-instance)) + + +(define-method update-instance-for-different-class ((old-instance ) + (new-instance + )) + ;;not really important what we do, we just need a default method + new-instance) + +(define-method change-class ((old-instance ) (new-class )) + (change-object-class old-instance (class-of old-instance) new-class)) + +;;; +;;; {make} +;;; +;;; A new definition which overwrites the previous one which was built-in +;;; + +(define-method allocate-instance ((class ) initargs) + (%allocate-instance class initargs)) + +(define-method make-instance ((class ) . initargs) + (let ((instance (allocate-instance class initargs))) + (initialize instance initargs) + instance)) + +(define make make-instance) + +;;; +;;; {apply-generic} +;;; +;;; Protocol for calling standard generic functions. This protocol is +;;; not used for real functions (in this case we use a +;;; completely C hard-coded protocol). Apply-generic is used by +;;; goops for calls to subclasses of and . +;;; The code below is similar to the first MOP described in AMOP. In +;;; particular, it doesn't used the currified approach to gf +;;; call. There are 2 reasons for that: +;;; - the protocol below is exposed to mimic completely the one written in C +;;; - the currified protocol would be imho inefficient in C. +;;; + +(define-method apply-generic ((gf ) args) + (if (null? (slot-ref gf 'methods)) + (no-method gf args)) + (let ((methods (compute-applicable-methods gf args))) + (if methods + (apply-methods gf (sort-applicable-methods gf methods args) args) + (no-applicable-method gf args)))) + +;; compute-applicable-methods is bound to %compute-applicable-methods. +;; *fixme* use let +(define %%compute-applicable-methods + (make #:name 'compute-applicable-methods)) + +(define-method %%compute-applicable-methods ((gf ) args) + (%compute-applicable-methods gf args)) + +(set! compute-applicable-methods %%compute-applicable-methods) + +(define-method sort-applicable-methods ((gf ) methods args) + (let ((targs (map class-of args))) + (sort methods (lambda (m1 m2) (method-more-specific? m1 m2 targs))))) + +(define-method method-more-specific? ((m1 ) (m2 ) targs) + (%method-more-specific? m1 m2 targs)) + +(define-method apply-method ((gf ) methods build-next args) + (apply (method-procedure (car methods)) + (build-next (cdr methods) args) + args)) + +(define-method apply-methods ((gf ) (l ) args) + (letrec ((next (lambda (procs args) + (lambda new-args + (let ((a (if (null? new-args) args new-args))) + (if (null? procs) + (no-next-method gf a) + (apply-method gf procs next a))))))) + (apply-method gf l next args))) + +;; We don't want the following procedure to turn up in backtraces: +(for-each (lambda (proc) + (set-procedure-property! proc 'system-procedure #t)) + (list slot-unbound + slot-missing + no-next-method + no-applicable-method + no-method + )) + +;;; +;;; { and } +;;; + +;(autoload "active-slot" ) +;(autoload "composite-slot" ) +;(export ) + +;;; +;;; {Tools} +;;; + +;; list2set +;; +;; duplicate the standard list->set function but using eq instead of +;; eqv which really sucks a lot, uselessly here +;; +(define (list2set l) + (let loop ((l l) + (res '())) + (cond + ((null? l) res) + ((memq (car l) res) (loop (cdr l) res)) + (else (loop (cdr l) (cons (car l) res)))))) + +(define (class-subclasses c) + (letrec ((allsubs (lambda (c) + (cons c (mapappend allsubs + (class-direct-subclasses c)))))) + (list2set (cdr (allsubs c))))) + +(define (class-methods c) + (list2set (mapappend class-direct-methods + (cons c (class-subclasses c))))) + +;;; +;;; {Final initialization} +;;; + +;; Tell C code that the main bulk of Goops has been loaded +(%goops-loaded) diff --git a/oop/goops/Makefile.am b/oop/goops/Makefile.am new file mode 100644 index 000000000..73a77e474 --- /dev/null +++ b/oop/goops/Makefile.am @@ -0,0 +1,33 @@ +## Process this file with automake to produce Makefile.in. +## +## Copyright (C) 2000 Free Software Foundation, Inc. +## +## This file is part of GUILE. +## +## GUILE 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, or +## (at your option) any later version. +## +## GUILE 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 GUILE; see the file COPYING. If not, write +## to the Free Software Foundation, Inc., 59 Temple Place, Suite +## 330, Boston, MA 02111-1307 USA + +AUTOMAKE_OPTIONS = foreign + +# These should be installed and distributed. +goops_sources = \ + active-slot.scm compile.scm composite-slot.scm describe.scm \ + dispatch.scm internal.scm save.scm stklos.scm util.scm + +subpkgdatadir = $(pkgdatadir)/$(VERSION)/oop/goops +subpkgdata_DATA = $(goops_sources) +ETAGS_ARGS = $(subpkgdata_DATA) + +EXTRA_DIST = $(goops_sources) diff --git a/oop/goops/active-slot.scm b/oop/goops/active-slot.scm new file mode 100644 index 000000000..ca9424d0f --- /dev/null +++ b/oop/goops/active-slot.scm @@ -0,0 +1,68 @@ +;;; installed-scm-file + +;;;; Copyright (C) 1999 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; + + +;;;; This software is a derivative work of other copyrighted softwares; the +;;;; copyright notices of these softwares are placed in the file COPYRIGHTS +;;;; +;;;; This file is based upon active-slot.stklos from the STk +;;;; distribution by Erick Gallesio . +;;;; + +(define-module (oop goops active-slot) + :use-module (oop goops internal)) + +(export ) + +(define-class ()) + +(define-method compute-get-n-set ((class ) slot) + (if (eq? (slot-definition-allocation slot) #:active) + (let* ((index (slot-ref class 'nfields)) + (name (car slot)) + (s (cdr slot)) + (env (class-environment class)) + (before-ref (get-keyword #:before-slot-ref s #f)) + (after-ref (get-keyword #:after-slot-ref s #f)) + (before-set! (get-keyword #:before-slot-set! s #f)) + (after-set! (get-keyword #:after-slot-set! s #f)) + (unbound (make-unbound))) + (slot-set! class 'nfields (+ index 1)) + (list (lambda (o) + (if before-ref + (if (before-ref o) + (let ((res (%fast-slot-ref o index))) + (and after-ref (not (eqv? res unbound)) (after-ref o)) + res) + (make-unbound)) + (let ((res (%fast-slot-ref o index))) + (and after-ref (not (eqv? res unbound)) (after-ref o)) + res))) + + (lambda (o v) + (if before-set! + (if (before-set! o v) + (begin + (%fast-slot-set! o index v) + (and after-set! (after-set! o v)))) + (begin + (%fast-slot-set! o index v) + (and after-set! (after-set! o v))))))) + (next-method))) diff --git a/oop/goops/compile.scm b/oop/goops/compile.scm new file mode 100644 index 000000000..ab185f3c5 --- /dev/null +++ b/oop/goops/compile.scm @@ -0,0 +1,136 @@ +;;;; Copyright (C) 1999 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; + + +(define-module (oop goops compile) + :use-module (oop goops) + :use-module (oop goops util) + :no-backtrace + ) + +(export compute-cmethod compute-entry-with-cmethod + compile-method cmethod-code cmethod-environment) + +(define source-formals cadr) +(define source-body cddr) + +(define cmethod-code cdr) +(define cmethod-environment car) + + +;;; +;;; Method entries +;;; + +(define code-table-lookup + (letrec ((check-entry (lambda (entry types) + (if (null? types) + (and (not (struct? (car entry))) + entry) + (and (eq? (car entry) (car types)) + (check-entry (cdr entry) (cdr types))))))) + (lambda (code-table types) + (cond ((null? code-table) #f) + ((check-entry (car code-table) types) + => (lambda (cmethod) + (cons (car code-table) cmethod))) + (else (code-table-lookup (cdr code-table) types)))))) + +(define (compute-entry-with-cmethod methods types) + (or (code-table-lookup (slot-ref (car methods) 'code-table) types) + (let* ((method (car methods)) + (place-holder (list #f)) + (entry (append types place-holder))) + ;; In order to handle recursion nicely, put the entry + ;; into the code-table before compiling the method + (slot-set! (car methods) 'code-table + (cons entry (slot-ref (car methods) 'code-table))) + (let ((cmethod (compile-method methods types))) + (set-car! place-holder (car cmethod)) + (set-cdr! place-holder (cdr cmethod))) + (cons entry place-holder)))) + +(define (compute-cmethod methods types) + (cdr (compute-entry-with-cmethod methods types))) + +;;; +;;; Next methods +;;; + +;;; Temporary solution---return #f if x doesn't refer to `next-method'. +(define (next-method? x) + (and (pair? x) + (or (eq? (car x) 'next-method) + (next-method? (car x)) + (next-method? (cdr x))))) + +(define (make-final-make-next-method method) + (lambda default-args + (lambda args + (@apply method (if (null? args) default-args args))))) + +(define (make-final-make-no-next-method gf) + (lambda default-args + (lambda args + (no-next-method gf (if (null? args) default-args args))))) + +(define (make-make-next-method vcell gf methods types) + (lambda default-args + (lambda args + (if (null? methods) + (begin + (set-cdr! vcell (make-final-make-no-next-method gf)) + (no-next-method gf (if (null? args) default-args args))) + (let* ((cmethod (compute-cmethod methods types)) + (method (local-eval (cons 'lambda (cmethod-code cmethod)) + (cmethod-environment cmethod)))) + (set-cdr! vcell (make-final-make-next-method method)) + (@apply method (if (null? args) default-args args))))))) + +;;; +;;; Method compilation +;;; + +;;; NOTE: This section is far from finished. It will finally be +;;; implemented on C level. + +(define (compile-method methods types) + (let* ((proc (method-procedure (car methods))) + (src (procedure-source proc)) + (formals (source-formals src)) + (body (source-body src))) + (if (next-method? body) + (let ((vcell (cons 'goops:make-next-method #f))) + (set-cdr! vcell + (make-make-next-method + vcell + (method-generic-function (car methods)) + (cdr methods) types)) + ;;*fixme* + `(,(cons vcell (procedure-environment proc)) + ,formals + ;;*fixme* Only do this on source where next-method can't be inlined + (let ((next-method ,(if (list? formals) + `(goops:make-next-method ,@formals) + `(apply goops:make-next-method + ,@(improper->proper formals))))) + ,@body))) + (cons (procedure-environment proc) + (cons formals + body)) + ))) diff --git a/oop/goops/composite-slot.scm b/oop/goops/composite-slot.scm new file mode 100644 index 000000000..4f44f0619 --- /dev/null +++ b/oop/goops/composite-slot.scm @@ -0,0 +1,84 @@ +;;; installed-scm-file + +;;;; Copyright (C) 1999, 2000 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; + + +;;;; This software is a derivative work of other copyrighted softwares; the +;;;; copyright notices of these softwares are placed in the file COPYRIGHTS +;;;; +;;;; This file is based upon composite-slot.stklos from the STk +;;;; distribution by Erick Gallesio . +;;;; + +(define-module (oop goops composite-slot) + :use-module (oop goops)) + +(export ) + +;;; +;;; (define-class CLASS SUPERS +;;; ... +;;; (OBJECT ...) +;;; ... +;;; (SLOT #:allocation #:propagated +;;; #:propagate-to '(PROPAGATION ...)) +;;; ... +;;; #:metaclass ) +;;; +;;; PROPAGATION ::= OBJECT | (OBJECT TARGETSLOT) +;;; +;;; The slot SLOT will be propagated to the slot TARGETSLOT in the object +;;; stored in slot OBJECT. If TARGETSLOT is omitted, assume that the target +;;; slot is named SLOT. +;;; + +(define-class ()) + +(define-method compute-get-n-set ((class ) slot) + (if (eq? (slot-definition-allocation slot) #:propagated) + (compute-propagated-get-n-set slot) + (next-method))) + +(define (compute-propagated-get-n-set s) + (let ((prop (get-keyword #:propagate-to (cdr s) #f)) + (s-name (slot-definition-name s))) + + (if (not prop) + (goops-error "Propagation not specified for slot ~S" s-name)) + (if (not (pair? prop)) + (goops-error "Bad propagation list for slot ~S" s-name)) + + (let ((objects (map (lambda (p) (if (pair? p) (car p) p)) prop)) + (slots (map (lambda (p) (if (pair? p) (cadr p) s-name)) prop))) + (let ((first-object (car objects)) + (first-slot (car slots))) + (list + ;; The getter + (lambda (o) + (slot-ref (slot-ref o first-object) first-slot)) + + ;; The setter + (if (null? (cdr objects)) + (lambda (o v) + (slot-set! (slot-ref o first-object) first-slot v)) + (lambda (o v) + (for-each (lambda (object slot) + (slot-set! (slot-ref o object) slot v)) + objects + slots)))))))) diff --git a/oop/goops/describe.scm b/oop/goops/describe.scm new file mode 100644 index 000000000..c6e51084e --- /dev/null +++ b/oop/goops/describe.scm @@ -0,0 +1,202 @@ +;;; installed-scm-file + +;;;; Copyright (C) 1998, 1999 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; + + +;;;; This software is a derivative work of other copyrighted softwares; the +;;;; copyright notices of these softwares are placed in the file COPYRIGHTS +;;;; +;;;; This file is based upon describe.stklos from the STk distribution by +;;;; Erick Gallesio . +;;;; + +(define-module (oop goops describe) + :use-module (oop goops) + :use-module (ice-9 session) + :use-module (ice-9 format)) + +(export describe) ; Export the describe generic function + +;;; +;;; describe for simple objects +;;; +(define-method describe ((x )) + (format #t "~s is " x) + (cond + ((integer? x) (format #t "an integer")) + ((real? x) (format #t "a real")) + ((complex? x) (format #t "a complex number")) + ((null? x) (format #t "an empty list")) + ((boolean? x) (format #t "a boolean value (~s)" (if x 'true 'false))) + ((char? x) (format #t "a character, ascii value is ~s" + (char->integer x))) + ((symbol? x) (format #t "a symbol")) + ((list? x) (format #t "a list")) + ((pair? x) (if (pair? (cdr x)) + (format #t "an improper list") + (format #t "a pair"))) + ((string? x) (if (eqv? x "") + (format #t "an empty string") + (format #t "a string of length ~s" (string-length x)))) + ((vector? x) (if (eqv? x '#()) + (format #t "an empty vector") + (format #t "a vector of length ~s" (vector-length x)))) + ((eof-object? x) (format #t "the end-of-file object")) + (else (format #t "an unknown object (~s)" x))) + (format #t ".~%") + *unspecified*) + +(define-method describe ((x )) + (let ((name (procedure-name x))) + (if name + (format #t "`~s'" name) + (display x)) + (display " is ") + (display (if name #\a "an anonymous")) + (display (cond ((closure? x) " procedure") + ((not (struct? x)) " primitive procedure") + ((entity? x) " entity") + (else " operator"))) + (display " with ") + (arity x))) + +;;; +;;; describe for GOOPS instances +;;; +(define (safe-class-name class) + (if (slot-bound? class 'name) + (class-name class) + class)) + +(define-method describe ((x )) + (format #t "~S is an instance of class ~A~%" + x (safe-class-name (class-of x))) + + ;; print all the instance slots + (format #t "Slots are: ~%") + (for-each (lambda (slot) + (let ((name (slot-definition-name slot))) + (format #t " ~S = ~A~%" + name + (if (slot-bound? x name) + (format #f "~S" (slot-ref x name)) + "#")))) + (class-slots (class-of x))) + *unspecified*) + +;;; +;;; Describe for classes +;;; +(define-method describe ((x )) + (format #t "~S is a class. It's an instance of ~A~%" + (safe-class-name x) (safe-class-name (class-of x))) + + ;; Super classes + (format #t "Superclasses are:~%") + (for-each (lambda (class) (format #t " ~A~%" (safe-class-name class))) + (class-direct-supers x)) + + ;; Direct slots + (let ((slots (class-direct-slots x))) + (if (null? slots) + (format #t "(No direct slot)~%") + (begin + (format #t "Directs slots are:~%") + (for-each (lambda (s) + (format #t " ~A~%" (slot-definition-name s))) + slots)))) + + + ;; Direct subclasses + (let ((classes (class-direct-subclasses x))) + (if (null? classes) + (format #t "(No direct subclass)~%") + (begin + (format #t "Directs subclasses are:~%") + (for-each (lambda (s) + (format #t " ~A~%" (safe-class-name s))) + classes)))) + + ;; CPL + (format #t "Class Precedence List is:~%") + (for-each (lambda (s) (format #t " ~A~%" (safe-class-name s))) + (class-precedence-list x)) + + ;; Direct Methods + (let ((methods (class-direct-methods x))) + (if (null? methods) + (format #t "(No direct method)~%") + (begin + (format #t "Class direct methods are:~%") + (for-each describe methods)))) + +; (format #t "~%Field Initializers ~% ") +; (write (slot-ref x 'initializers)) (newline) + +; (format #t "~%Getters and Setters~% ") +; (write (slot-ref x 'getters-n-setters)) (newline) +) + +;;; +;;; Describe for generic functions +;;; +(define-method describe ((x )) + (let ((name (generic-function-name x)) + (methods (generic-function-methods x))) + ;; Title + (format #t "~S is a generic function. It's an instance of ~A.~%" + name (safe-class-name (class-of x))) + ;; Methods + (if (null? methods) + (format #t "(No method defined for ~S)~%" name) + (begin + (format #t "Methods defined for ~S~%" name) + (for-each (lambda (x) (describe x #t)) methods))))) + +;;; +;;; Describe for methods +;;; +(define-method describe ((x ) . omit-generic) + (letrec ((print-args (lambda (args) + ;; take care of dotted arg lists + (cond ((null? args) (newline)) + ((pair? args) + (display #\space) + (display (safe-class-name (car args))) + (print-args (cdr args))) + (else + (display #\space) + (display (safe-class-name args)) + (newline)))))) + + ;; Title + (format #t " Method ~A~%" x) + + ;; Associated generic + (if (null? omit-generic) + (let ((gf (method-generic-function x))) + (if gf + (format #t "\t Generic: ~A~%" (generic-function-name gf)) + (format #t "\t(No generic)~%")))) + + ;; GF specializers + (format #t "\tSpecializers:") + (print-args (method-specializers x)))) + +(provide "describe") diff --git a/oop/goops/dispatch.scm b/oop/goops/dispatch.scm new file mode 100644 index 000000000..26d832a6e --- /dev/null +++ b/oop/goops/dispatch.scm @@ -0,0 +1,270 @@ +;;;; Copyright (C) 1999, 2000 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; + + +(define-module (oop goops dispatch) + :use-module (oop goops) + :use-module (oop goops util) + :use-module (oop goops compile) + :no-backtrace + ) + +(export memoize-method!) + +;;; +;;; This file implements method memoization. It will finally be +;;; implemented on C level in order to obtain fast generic function +;;; application also during the first pass through the code. +;;; + +;;; +;;; Constants +;;; + +(define hashsets 8) +(define hashset-index 7) + +(define hash-threshold 3) +(define initial-hash-size 4) ;must be a power of 2 and >= hash-threshold + +(define initial-hash-size-1 (- initial-hash-size 1)) + +(define the-list-of-no-method '(no-method)) + +;;; +;;; Method cache +;;; + +;; (#@dispatch args N-SPECIALIZED #((TYPE1 ... ENV FORMALS FORM1 ...) ...) GF) +;; (#@dispatch args N-SPECIALIZED HASHSET MASK +;; #((TYPE1 ... ENV FORMALS FORM1 ...) ...) +;; GF) + +;;; Representation + +;; non-hashed form + +(define method-cache-entries cadddr) + +(define (set-method-cache-entries! mcache entries) + (set-car! (cdddr mcache) entries)) + +(define (method-cache-n-methods exp) + (n-cache-methods (method-cache-entries exp))) + +(define (method-cache-methods exp) + (cache-methods (method-cache-entries exp))) + +;; hashed form + +(define (set-hashed-method-cache-hashset! exp hashset) + (set-car! (cdddr exp) hashset)) + +(define (set-hashed-method-cache-mask! exp mask) + (set-car! (cddddr exp) mask)) + +(define (hashed-method-cache-entries exp) + (list-ref exp 5)) + +(define (set-hashed-method-cache-entries! exp entries) + (set-car! (list-cdr-ref exp 5) entries)) + +;; either form + +(define (method-cache-generic-function exp) + (list-ref exp (if (method-cache-hashed? exp) 6 4))) + +;;; Predicates + +(define (method-cache-hashed? x) + (integer? (cadddr x))) + +(define max-non-hashed-index (- hash-threshold 2)) + +(define (passed-hash-threshold? exp) + (and (> (vector-length (method-cache-entries exp)) max-non-hashed-index) + (struct? (car (vector-ref (method-cache-entries exp) + max-non-hashed-index))))) + +;;; Converting a method cache to hashed form + +(define (method-cache->hashed! exp) + (set-cdr! (cddr exp) (cons 0 (cons initial-hash-size-1 (cdddr exp)))) + exp) + +;;; +;;; Cache entries +;;; + +(define (n-cache-methods entries) + (do ((i (- (vector-length entries) 1) (- i 1))) + ((or (< i 0) (struct? (car (vector-ref entries i)))) + (+ i 1)))) + +(define (cache-methods entries) + (do ((i (- (vector-length entries) 1) (- i 1)) + (methods '() (let ((entry (vector-ref entries i))) + (if (struct? (car entry)) + (cons entry methods) + methods)))) + ((< i 0) methods))) + +;;; +;;; Method insertion +;;; + +(define (method-cache-insert! exp entry) + (let* ((entries (method-cache-entries exp)) + (n (n-cache-methods entries))) + (if (>= n (vector-length entries)) + ;; grow cache + (let ((new-entries (make-vector (* 2 (vector-length entries)) + the-list-of-no-method))) + (do ((i 0 (+ i 1))) + ((= i n)) + (vector-set! new-entries i (vector-ref entries i))) + (vector-set! new-entries n entry) + (set-method-cache-entries! exp new-entries)) + (vector-set! entries n entry)))) + +(define (hashed-method-cache-insert! exp entry) + (let* ((cache (hashed-method-cache-entries exp)) + (size (vector-length cache))) + (let* ((entries (cons entry (cache-methods cache))) + (size (if (<= (length entries) size) + size + ;; larger size required + (let ((new-size (* 2 size))) + (set-hashed-method-cache-mask! exp (- new-size 1)) + new-size))) + (min-misses size) + (best #f)) + (do ((hashset 0 (+ 1 hashset))) + ((= hashset hashsets)) + (let* ((test-cache (make-vector size the-list-of-no-method)) + (misses (cache-try-hash! min-misses hashset test-cache entries))) + (cond ((zero? misses) + (set! min-misses 0) + (set! best hashset) + (set! cache test-cache) + (set! hashset (- hashsets 1))) + ((< misses min-misses) + (set! min-misses misses) + (set! best hashset) + (set! cache test-cache))))) + (set-hashed-method-cache-hashset! exp best) + (set-hashed-method-cache-entries! exp cache)))) + +;;; +;;; Caching +;;; + +(define environment? pair?) + +(define (cache-hashval hashset entry) + (let ((hashset-index (+ hashset-index hashset))) + (do ((sum 0) + (classes entry (cdr classes))) + ((environment? (car classes)) sum) + (set! sum (+ sum (struct-ref (car classes) hashset-index)))))) + +(define (cache-try-hash! min-misses hashset cache entries) + (let ((max-misses 0) + (mask (- (vector-length cache) 1))) + (catch 'misses + (lambda () + (do ((ls entries (cdr ls)) + (misses 0 0)) + ((null? ls) max-misses) + (do ((i (%logand mask (cache-hashval hashset (car ls))) + (%logand mask (+ i 1)))) + ((not (struct? (car (vector-ref cache i)))) + (vector-set! cache i (car ls))) + (set! misses (+ 1 misses)) + (if (>= misses min-misses) + (throw 'misses misses))) + (if (> misses max-misses) + (set! max-misses misses)))) + (lambda (key misses) + misses)))) + +;;; +;;; Memoization +;;; + +;; Backward compatibility +(if (not (defined? 'lookup-create-cmethod)) + (define (lookup-create-cmethod gf args) + (no-applicable-method (car args) (cadr args)))) + +(define (memoize-method! gf args exp) + (if (not (slot-ref gf 'used-by)) + (slot-set! gf 'used-by '())) + (let ((applicable ((if (eq? gf compute-applicable-methods) + %compute-applicable-methods + compute-applicable-methods) + gf args))) + (cond (applicable + ;; *fixme* dispatch.scm needs rewriting Since the current + ;; code mutates the method cache, we have to work on a + ;; copy. Otherwise we might disturb another thread + ;; currently dispatching on the cache. (No need to copy + ;; the vector.) + (let* ((new (list-copy exp)) + (res + (cond ((method-cache-hashed? new) + (method-cache-install! hashed-method-cache-insert! + new args applicable)) + ((passed-hash-threshold? new) + (method-cache-install! hashed-method-cache-insert! + (method-cache->hashed! new) + args + applicable)) + (else + (method-cache-install! method-cache-insert! + new args applicable))))) + (set-cdr! (cdr exp) (cddr new)) + res)) + ((null? args) + (lookup-create-cmethod no-applicable-method (list gf '()))) + (else + ;; Mutate arglist to fit no-applicable-method + (set-cdr! args (list (cons (car args) (cdr args)))) + (set-car! args gf) + (lookup-create-cmethod no-applicable-method args))))) + +(set-procedure-property! memoize-method! 'system-procedure #t) + +(define method-cache-install! + (letrec ((first-n + (lambda (ls n) + (if (or (zero? n) (null? ls)) + '() + (cons (car ls) (first-n (cdr ls) (- n 1))))))) + (lambda (insert! exp args applicable) + (let* ((specializers (method-specializers (car applicable))) + (n-specializers + (if (list? specializers) + (length specializers) + (abs (slot-ref (method-cache-generic-function exp) + 'n-specialized))))) + (let* ((types (map class-of (first-n args n-specializers))) + (entry+cmethod (compute-entry-with-cmethod applicable types))) + (insert! exp (car entry+cmethod)) ; entry = types + cmethod + (cdr entry+cmethod) ; cmethod + ))))) diff --git a/oop/goops/internal.scm b/oop/goops/internal.scm new file mode 100644 index 000000000..6331ef6df --- /dev/null +++ b/oop/goops/internal.scm @@ -0,0 +1,28 @@ +;;; installed-scm-file + +;;;; Copyright (C) 1999 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; + + +(define-module (oop goops internal) + :use-module (oop goops)) + +;; Export all bindings from (oop goops) +(module-for-each (lambda (sym var) + (module-add! %module-public-interface sym var)) + (nested-ref the-root-module '(app modules oop goops))) diff --git a/oop/goops/save.scm b/oop/goops/save.scm new file mode 100644 index 000000000..148264dc4 --- /dev/null +++ b/oop/goops/save.scm @@ -0,0 +1,876 @@ +;;; installed-scm-file + +;;;; Copyright (C) 2000 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; + + +(define-module (oop goops save) + :use-module (oop goops internal) + :use-module (oop goops util) + ) + +(export save-objects load-objects restore make-unbound + enumerate! enumerate-component! + write-readably write-component write-component-procedure + literal? readable make-readable) + +;;; +;;; save-objects ALIST PORT [EXCLUDED] [USES] +;;; +;;; ALIST ::= ((NAME . OBJECT) ...) +;;; +;;; Save OBJECT ... to PORT so that when the data is read and evaluated +;;; OBJECT ... are re-created under names NAME ... . +;;; Exclude any references to objects in the list EXCLUDED. +;;; Add a (use-modules . USES) line to the top of the saved text. +;;; +;;; In some instances, when `save-object' doesn't know how to produce +;;; readable syntax for an object, you can explicitly register read +;;; syntax for an object using the special form `readable'. +;;; +;;; Example: +;;; +;;; The function `foo' produces an object of obscure structure. +;;; Only `foo' can construct such objects. Because of this, an +;;; object such as +;;; +;;; (define x (vector 1 (foo))) +;;; +;;; cannot be saved by `save-objects'. But if you instead write +;;; +;;; (define x (vector 1 (readable (foo)))) +;;; +;;; `save-objects' will happily produce the necessary read syntax. +;;; +;;; To add new read syntax, hang methods on `enumerate!' and +;;; `write-readably'. +;;; +;;; enumerate! OBJECT ENV +;;; Should call `enumerate-component!' (which takes same args) on +;;; each component object. Should return #t if the composite object +;;; can be written as a literal. (`enumerate-component!' returns #t +;;; if the component is a literal. +;;; +;;; write-readably OBJECT PORT ENV +;;; Should write a readable representation of OBJECT to PORT. +;;; Should use `write-component' to print each component object. +;;; Use `literal?' to decide if a component is a literal. +;;; +;;; Utilities: +;;; +;;; enumerate-component! OBJECT ENV +;;; +;;; write-component OBJECT PATCHER PORT ENV +;;; PATCHER is an expression which, when evaluated, stores OBJECT +;;; into its current location. +;;; +;;; Example: +;;; +;;; (write-component (car ls) `(set-car! ,ls ,(car ls)) file env) +;;; +;;; write-component is a macro. +;;; +;;; literal? COMPONENT ENV +;;; + +(define-method immediate? ((o )) #f) + +(define-method immediate? ((o )) #t) +(define-method immediate? ((o )) #t) +(define-method immediate? ((o )) #t) +(define-method immediate? ((o )) #t) +(define-method immediate? ((o )) #t) +(define-method immediate? ((o )) #t) + +;;; enumerate! OBJECT ENVIRONMENT +;;; +;;; Return #t if object is a literal. +;;; +(define-method enumerate! ((o ) env) #t) + +(define-method write-readably ((o ) file env) + ;;(goops-error "No read-syntax defined for object `~S'" o) + (write o file) ;doesn't catch bugs, but is much more flexible + ) + +;;; +;;; Readables +;;; + +(if (or (not (defined? 'readables)) + (not readables)) + (define readables (make-weak-key-hash-table 61))) + +(define readable + (procedure->memoizing-macro + (lambda (exp env) + `(make-readable ,(cadr exp) ',(copy-tree (cadr exp)))))) + +(define (make-readable obj expr) + (hashq-set! readables obj expr) + obj) + +(define (readable-expression obj) + `(readable ,(hashq-ref readables obj))) + +(define (readable? obj) + (hashq-get-handle readables obj)) + +;;; +;;; Strings +;;; + +(define-method enumerate! ((o ) env) #f) + +;;; +;;; Vectors +;;; + +(define-method enumerate! ((o ) env) + (or (not (vector? o)) + (let ((literal? #t)) + (array-for-each (lambda (o) + (if (not (enumerate-component! o env)) + (set! literal? #f))) + o) + literal?))) + +(define-method write-readably ((o ) file env) + (if (not (vector? o)) + (write o file) + (let ((n (vector-length o))) + (if (zero? n) + (display "#()" file) + (let ((not-literal? (not (literal? o env)))) + (display (if not-literal? + "(vector " + "#(") + file) + (if (and not-literal? + (literal? (vector-ref o 0) env)) + (display #\' file)) + (write-component (vector-ref o 0) + `(vector-set! ,o 0 ,(vector-ref o 0)) + file + env) + (do ((i 1 (+ 1 i))) + ((= i n)) + (display #\space file) + (if (and not-literal? + (literal? (vector-ref o i) env)) + (display #\' file)) + (write-component (vector-ref o i) + `(vector-set! ,o ,i ,(vector-ref o i)) + file + env)) + (display #\) file)))))) + + +;;; +;;; Arrays +;;; + +(define-method enumerate! ((o ) env) + (enumerate-component! (shared-array-root o) env)) + +(define (make-mapper array) + (let* ((dims (array-dimensions array)) + (n (array-rank array)) + (indices (reverse (if (<= n 11) + (list-tail '(t s r q p n m l k j i) (- 11 n)) + (let loop ((n n) + (ls '())) + (if (zero? n) + ls + (loop (- n 1) + (cons (gensym "i") ls)))))))) + `(lambda ,indices + (+ ,(shared-array-offset array) + ,@(map (lambda (ind dim inc) + `(* ,inc ,(if (pair? dim) `(- ,ind ,(car dim)) ind))) + indices + (array-dimensions array) + (shared-array-increments array)))))) + +(define (write-array prefix o not-literal? file env) + (letrec ((inner (lambda (n indices) + (if (not (zero? n)) + (let ((el (apply array-ref o + (reverse (cons 0 indices))))) + (if (and not-literal? + (literal? el env)) + (display #\' file)) + (write-component + el + `(array-set! ,o ,el ,@indices) + file + env))) + (do ((i 1 (+ 1 i))) + ((= i n)) + (display #\space file) + (let ((el (apply array-ref o + (reverse (cons i indices))))) + (if (and not-literal? + (literal? el env)) + (display #\' file)) + (write-component + el + `(array-set! ,o ,el ,@indices) + file + env)))))) + (display prefix file) + (let loop ((dims (array-dimensions o)) + (indices '())) + (cond ((null? (cdr dims)) + (inner (car dims) indices)) + (else + (let ((n (car dims))) + (do ((i 0 (+ 1 i))) + ((= i n)) + (if (> i 0) + (display #\space file)) + (display prefix file) + (loop (cdr dims) (cons i indices)) + (display #\) file)))))) + (display #\) file))) + +(define-method write-readably ((o ) file env) + (let ((root (shared-array-root o))) + (cond ((literal? o env) + (if (not (vector? root)) + (write o file) + (begin + (display #\# file) + (display (array-rank o) file) + (write-array #\( o #f file env)))) + ((binding? root env) + (display "(make-shared-array " file) + (if (literal? root env) + (display #\' file)) + (write-component root + (goops-error "write-readably(): internal error") + file + env) + (display #\space file) + (display (make-mapper o) file) + (for-each (lambda (dim) + (display #\space file) + (display dim file)) + (array-dimensions o)) + (display #\) file)) + (else + (display "(list->uniform-array " file) + (display (array-rank o) file) + (display " '() " file) + (write-array "(list " o file env))))) + +;;; +;;; Pairs +;;; + +;;; These methods have more complex structure than is required for +;;; most objects, since they take over some of the logic of +;;; `write-component'. +;;; + +(define-method enumerate! ((o ) env) + (let ((literal? (enumerate-component! (car o) env))) + (and (enumerate-component! (cdr o) env) + literal?))) + +(define-method write-readably ((o ) file env) + (let ((proper? (let loop ((ls o)) + (or (null? ls) + (and (pair? ls) + (not (binding? (cdr ls) env)) + (loop (cdr ls)))))) + (1? (or (not (pair? (cdr o))) + (binding? (cdr o) env))) + (not-literal? (not (literal? o env))) + (infos '()) + (refs (ref-stack env))) + (display (cond ((not not-literal?) #\() + (proper? "(list ") + (1? "(cons ") + (else "(list* ")) + file) + (if (and not-literal? + (literal? (car o) env)) + (display #\' file)) + (write-component (car o) `(set-car! ,o ,(car o)) file env) + (do ((ls (cdr o) (cdr ls)) + (prev o ls)) + ((or (not (pair? ls)) + (binding? ls env)) + (if (not (null? ls)) + (begin + (if (not not-literal?) + (display " ." file)) + (display #\space file) + (if (and not-literal? + (literal? ls env)) + (display #\' file)) + (write-component ls `(set-cdr! ,prev ,ls) file env))) + (display #\) file)) + (display #\space file) + (set! infos (cons (object-info ls env) infos)) + (push-ref! ls env) ;*fixme* optimize + (set! (visiting? (car infos)) #t) + (if (and not-literal? + (literal? (car ls) env)) + (display #\' file)) + (write-component (car ls) `(set-car! ,ls ,(car ls)) file env) + ) + (for-each (lambda (info) + (set! (visiting? info) #f)) + infos) + (set! (ref-stack env) refs) + )) + +;;; +;;; Objects +;;; + +;;; Doesn't yet handle unbound slots + +;; Don't export this function! This is all very temporary. +;; +(define (get-set-for-each proc class) + (for-each (lambda (slotdef g-n-s) + (let ((g-n-s (cddr g-n-s))) + (cond ((integer? g-n-s) + (proc (standard-get g-n-s) (standard-set g-n-s))) + ((not (memq (slot-definition-allocation slotdef) + '(#:class #:each-subclass))) + (proc (car g-n-s) (cadr g-n-s)))))) + (class-slots class) + (slot-ref class 'getters-n-setters))) + +(define (access-for-each proc class) + (for-each (lambda (slotdef g-n-s) + (let ((g-n-s (cddr g-n-s)) + (a (slot-definition-accessor slotdef))) + (cond ((integer? g-n-s) + (proc (slot-definition-name slotdef) + (and a (generic-function-name a)) + (standard-get g-n-s) + (standard-set g-n-s))) + ((not (memq (slot-definition-allocation slotdef) + '(#:class #:each-subclass))) + (proc (slot-definition-name slotdef) + (and a (generic-function-name a)) + (car g-n-s) + (cadr g-n-s)))))) + (class-slots class) + (slot-ref class 'getters-n-setters))) + +(define restore + (procedure->macro + (lambda (exp env) + "(restore CLASS (SLOT-NAME1 ...) EXP1 ...)" + `(let ((o (,%allocate-instance ,(cadr exp) '()))) + (for-each (lambda (name val) + (,slot-set! o name val)) + ',(caddr exp) + (list ,@(cdddr exp))) + o)))) + +(define-method enumerate! ((o ) env) + (get-set-for-each (lambda (get set) + (let ((val (get o))) + (if (not (unbound? val)) + (enumerate-component! val env)))) + (class-of o)) + #f) + +(define-method write-readably ((o ) file env) + (let ((class (class-of o))) + (display "(restore " file) + (display (class-name class) file) + (display " (" file) + (let ((slotdefs + (filter (lambda (slotdef) + (not (or (memq (slot-definition-allocation slotdef) + '(#:class #:each-subclass)) + (and (slot-bound? o (slot-definition-name slotdef)) + (excluded? + (slot-ref o (slot-definition-name slotdef)) + env))))) + (class-slots class)))) + (if (not (null? slotdefs)) + (begin + (display (slot-definition-name (car slotdefs)) file) + (for-each (lambda (slotdef) + (display #\space file) + (display (slot-definition-name slotdef) file)) + (cdr slotdefs))))) + (display #\) file) + (access-for-each (lambda (name aname get set) + (display #\space file) + (let ((val (get o))) + (cond ((unbound? val) + (display '(make-unbound) file)) + ((excluded? val env)) + (else + (if (literal? val env) + (display #\' file)) + (write-component val + (if aname + `(set! (,aname ,o) ,val) + `(slot-set! ,o ',name ,val)) + file env))))) + class) + (display #\) file))) + +;;; +;;; Classes +;;; + +;;; Currently, we don't support reading in class objects +;;; + +(define-method enumerate! ((o ) env) #f) + +(define-method write-readably ((o ) file env) + (display (class-name o) file)) + +;;; +;;; Generics +;;; + +;;; Currently, we don't support reading in generic functions +;;; + +(define-method enumerate! ((o ) env) #f) + +(define-method write-readably ((o ) file env) + (display (generic-function-name o) file)) + +;;; +;;; Method +;;; + +;;; Currently, we don't support reading in methods +;;; + +(define-method enumerate! ((o ) env) #f) + +(define-method write-readably ((o ) file env) + (goops-error "No read-syntax for defined")) + +;;; +;;; Environments +;;; + +(define-class () + (object-info #:accessor object-info + #:init-form (make-hash-table 61)) + (excluded #:accessor excluded + #:init-form (make-hash-table 61)) + (pass-2? #:accessor pass-2? + #:init-value #f) + (ref-stack #:accessor ref-stack + #:init-value '()) + (objects #:accessor objects + #:init-value '()) + (pre-defines #:accessor pre-defines + #:init-value '()) + (locals #:accessor locals + #:init-value '()) + (stand-ins #:accessor stand-ins + #:init-value '()) + (post-defines #:accessor post-defines + #:init-value '()) + (patchers #:accessor patchers + #:init-value '()) + (multiple-bound #:accessor multiple-bound + #:init-value '()) + ) + +(define-method (initialize (env ) initargs) + (next-method) + (cond ((get-keyword #:excluded initargs #f) + => (lambda (excludees) + (for-each (lambda (e) + (hashq-create-handle! (excluded env) e #f)) + excludees))))) + +(define-method (object-info o env) + (hashq-ref (object-info env) o)) + +(define-method ((setter object-info) o env x) + (hashq-set! (object-info env) o x)) + +(define (excluded? o env) + (hashq-get-handle (excluded env) o)) + +(define (add-patcher! patcher env) + (set! (patchers env) (cons patcher (patchers env)))) + +(define (push-ref! o env) + (set! (ref-stack env) (cons o (ref-stack env)))) + +(define (pop-ref! env) + (set! (ref-stack env) (cdr (ref-stack env)))) + +(define (container env) + (car (ref-stack env))) + +(define-class () + (visiting #:accessor visiting + #:init-value #f) + (binding #:accessor binding + #:init-value #f) + (literal? #:accessor literal? + #:init-value #f) + ) + +(define visiting? visiting) + +(define-method (binding (info )) + #f) + +(define-method (binding o env) + (binding (object-info o env))) + +(define binding? binding) + +(define-method (literal? (info )) + #t) + +;;; Note that this method is intended to be used only during the +;;; writing pass +;;; +(define-method (literal? o env) + (or (immediate? o) + (excluded? o env) + (let ((info (object-info o env))) + ;; write-component sets all bindings first to #:defining, + ;; then to #:defined + (and (or (not (binding? info)) + ;; we might be using `literal?' in a write-readably method + ;; to query about the object being defined + (and (eq? (visiting info) #:defining) + (null? (cdr (ref-stack env))))) + (literal? info))))) + +;;; +;;; Enumeration +;;; + +;;; Enumeration has two passes. +;;; +;;; Pass 1: Detect common substructure, circular references and order +;;; +;;; Pass 2: Detect literals + +(define (enumerate-component! o env) + (cond ((immediate? o) #t) + ((readable? o) #f) + ((excluded? o env) #t) + ((pass-2? env) + (let ((info (object-info o env))) + (if (binding? info) + ;; if circular reference, we print as a literal + ;; (note that during pass-2, circular references are + ;; forward references, i.e. *not* yet marked with #:pass-2 + (not (eq? (visiting? info) #:pass-2)) + (and (enumerate! o env) + (begin + (set! (literal? info) #t) + #t))))) + ((object-info o env) + => (lambda (info) + (set! (binding info) #t) + (if (visiting? info) + ;; circular reference--mark container + (set! (binding (object-info (container env) env)) #t)))) + (else + (let ((info (make ))) + (set! (object-info o env) info) + (push-ref! o env) + (set! (visiting? info) #t) + (enumerate! o env) + (set! (visiting? info) #f) + (pop-ref! env) + (set! (objects env) (cons o (objects env))))))) + +(define (write-component-procedure o file env) + "Return #f if circular reference" + (cond ((immediate? o) (write o file) #t) + ((readable? o) (write (readable-expression o) file) #t) + ((excluded? o env) (display #f file) #t) + (else + (let ((info (object-info o env))) + (cond ((not (binding? info)) (write-readably o file env) #t) + ((not (eq? (visiting info) #:defined)) #f) ;forward reference + (else (display (binding info) file) #t)))))) + +;;; write-component OBJECT PATCHER FILE ENV +;;; +(define write-component + (procedure->memoizing-macro + (lambda (exp env) + `(or (write-component-procedure ,(cadr exp) ,@(cdddr exp)) + (begin + (display #f ,(cadddr exp)) + (add-patcher! ,(caddr exp) env)))))) + +;;; +;;; Main engine +;;; + +(define binding-name car) +(define binding-object cdr) + +(define (pass-1! alist env) + ;; Determine object order and necessary bindings + (for-each (lambda (binding) + (enumerate-component! (binding-object binding) env)) + alist)) + +(define (make-local i) + (string->symbol (string-append "%o" (number->string i)))) + +(define (name-bindings! alist env) + ;; Name top-level bindings + (for-each (lambda (b) + (let ((o (binding-object b))) + (if (not (or (immediate? o) + (readable? o) + (excluded? o env))) + (let ((info (object-info o env))) + (if (symbol? (binding info)) + ;; already bound to a variable + (set! (multiple-bound env) + (acons (binding info) + (binding-name b) + (multiple-bound env))) + (set! (binding info) + (binding-name b))))))) + alist) + ;; Name rest of bindings and create stand-in and definition lists + (let post-loop ((ls (objects env)) + (post-defs '())) + (cond ((or (null? ls) + (eq? (binding (car ls) env) #t)) + (set! (post-defines env) post-defs) + (set! (objects env) ls)) + ((not (binding (car ls) env)) + (post-loop (cdr ls) post-defs)) + (else + (post-loop (cdr ls) (cons (car ls) post-defs))))) + (let pre-loop ((ls (reverse (objects env))) + (i 0) + (pre-defs '()) + (locs '()) + (sins '())) + (if (null? ls) + (begin + (set! (pre-defines env) (reverse pre-defs)) + (set! (locals env) (reverse locs)) + (set! (stand-ins env) (reverse sins))) + (let ((info (object-info (car ls) env))) + (cond ((not (binding? info)) + (pre-loop (cdr ls) i pre-defs locs sins)) + ((boolean? (binding info)) + ;; local + (set! (binding info) (make-local i)) + (pre-loop (cdr ls) + (+ 1 i) + pre-defs + (cons (car ls) locs) + sins)) + ((null? locs) + (pre-loop (cdr ls) + i + (cons (car ls) pre-defs) + locs + sins)) + (else + (let ((real-name (binding info))) + (set! (binding info) (make-local i)) + (pre-loop (cdr ls) + (+ 1 i) + pre-defs + (cons (car ls) locs) + (acons (binding info) real-name sins))))))))) + +(define (pass-2! env) + (set! (pass-2? env) #t) + (for-each (lambda (o) + (let ((info (object-info o env))) + (set! (literal? info) (enumerate! o env)) + (set! (visiting info) #:pass-2))) + (append (pre-defines env) + (locals env) + (post-defines env)))) + +(define (write-define! name val literal? file) + (display "(define " file) + (display name file) + (display #\space file) + (if literal? (display #\' file)) + (write val file) + (display ")\n" file)) + +(define (write-empty-defines! file env) + (for-each (lambda (stand-in) + (write-define! (cdr stand-in) #f #f file)) + (stand-ins env)) + (for-each (lambda (o) + (write-define! (binding o env) #f #f file)) + (post-defines env))) + +(define (write-definition! prefix o file env) + (display prefix file) + (let ((info (object-info o env))) + (display (binding info) file) + (display #\space file) + (if (literal? info) + (display #\' file)) + (push-ref! o env) + (set! (visiting info) #:defining) + (write-readably o file env) + (set! (visiting info) #:defined) + (pop-ref! env) + (display #\) file))) + +(define (write-let*-head! file env) + (display "(let* (" file) + (write-definition! "(" (car (locals env)) file env) + (for-each (lambda (o) + (write-definition! "\n (" o file env)) + (cdr (locals env))) + (display ")\n" file)) + +(define (write-rebindings! prefix bindings file env) + (for-each (lambda (patch) + (display prefix file) + (display (cdr patch) file) + (display #\space file) + (display (car patch) file) + (display ")\n" file)) + bindings)) + +(define (write-definitions! selector prefix file env) + (for-each (lambda (o) + (write-definition! prefix o file env) + (newline file)) + (selector env))) + +(define (write-patches! prefix file env) + (for-each (lambda (patch) + (display prefix file) + (display (let name-objects ((patcher patch)) + (cond ((binding patcher env) + => (lambda (name) + (cond ((assq name (stand-ins env)) + => cdr) + (else name)))) + ((pair? patcher) + (cons (name-objects (car patcher)) + (name-objects (cdr patcher)))) + (else patcher))) + file) + (newline file)) + (reverse (patchers env)))) + +(define (write-immediates! alist file) + (for-each (lambda (b) + (if (immediate? (binding-object b)) + (write-define! (binding-name b) + (binding-object b) + #t + file))) + alist)) + +(define (write-readables! alist file env) + (let ((written '())) + (for-each (lambda (b) + (cond ((not (readable? (binding-object b)))) + ((assq (binding-object b) written) + => (lambda (p) + (set! (multiple-bound env) + (acons (cdr p) + (binding-name b) + (multiple-bound env))))) + (else + (write-define! (binding-name b) + (readable-expression (binding-object b)) + #f + file) + (set! written (acons (binding-object b) + (binding-name b) + written))))) + alist))) + +(define-method save-objects ((alist ) (file ) . rest) + (let ((port (open-output-file file))) + (apply save-objects alist port rest) + (close-port port) + *unspecified*)) + +(define-method save-objects ((alist ) (file ) . rest) + (let ((excluded (if (>= (length rest) 1) (car rest) '())) + (uses (if (>= (length rest) 2) (cadr rest) '()))) + (let ((env (make #:excluded excluded))) + (pass-1! alist env) + (name-bindings! alist env) + (pass-2! env) + (if (not (null? uses)) + (begin + (write `(use-modules ,@uses) file) + (newline file))) + (write-immediates! alist file) + (if (null? (locals env)) + (begin + (write-definitions! post-defines "(define " file env) + (write-patches! "" file env)) + (begin + (write-definitions! pre-defines "(define " file env) + (write-empty-defines! file env) + (write-let*-head! file env) + (write-rebindings! " (set! " (stand-ins env) file env) + (write-definitions! post-defines " (set! " file env) + (write-patches! " " file env) + (display " )\n" file))) + (write-readables! alist file env) + (write-rebindings! "(define " (reverse (multiple-bound env)) file env)))) + +(define-method load-objects ((file )) + (let* ((port (open-input-file file)) + (objects (load-objects port))) + (close-port port) + objects)) + +(define-method load-objects ((file )) + (let ((m (make-module))) + (module-use! m the-scm-module) + (module-use! m %module-public-interface) + (save-module-excursion + (lambda () + (set-current-module m) + (let loop ((sexp (read file))) + (if (not (eof-object? sexp)) + (begin + (eval-in-module sexp m) + (loop (read file))))))) + (module-map (lambda (name var) + (cons name (variable-ref var))) + m))) diff --git a/oop/goops/stklos.scm b/oop/goops/stklos.scm new file mode 100644 index 000000000..be9594faa --- /dev/null +++ b/oop/goops/stklos.scm @@ -0,0 +1,98 @@ +;;;; Copyright (C) 1999 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; + + +(define-module (oop goops stklos) + :use-module (oop goops internal) + :no-backtrace + ) + +;;; +;;; This is the stklos compatibility module. +;;; +;;; WARNING: This module is under construction. While we expect to be able +;;; to run most stklos code without problems in the future, this is not the +;;; case now. The current compatibility is only superficial. +;;; +;;; Any comments/complaints/patches are welcome. Tell us about +;;; your incompatibility problems (bug-guile@gnu.org). +;;; + +;; Export all bindings that are exported from (oop goops)... +(module-for-each (lambda (sym var) + (module-add! %module-public-interface sym var)) + (nested-ref the-root-module '(app modules oop goops + %module-public-interface))) + +;; ...but replace the following bindings: +(export define-class define-method) + +;; Also export the following +(export write-object) + +;;; Enable keyword support (*fixme*---currently this has global effect) +(read-set! keywords 'prefix) + +(define standard-define-class-transformer + (macro-transformer standard-define-class)) + +(define define-class + ;; Syntax + (let ((name cadr) + (supers caddr) + (slots cadddr) + (rest cddddr)) + (procedure->macro + (lambda (exp env) + (standard-define-class-transformer + `(define-class ,(name exp) ,(supers exp) ,@(slots exp) + ,@(rest exp)) + env))))) + +(define define-method + (procedure->memoizing-macro + (lambda (exp env) + (let ((name (cadr exp))) + (if (and (pair? name) + (eq? (car name) 'setter) + (pair? (cdr name)) + (null? (cddr name))) + (let ((name (cadr name))) + (cond ((not (symbol? name)) + (goops-error "bad method name: ~S" name)) + ((defined? name env) + `(begin + (if (not (is-a? ,name )) + (define-accessor ,name)) + (add-method! (setter ,name) (method ,@(cddr exp))))) + (else + `(begin + (define-accessor ,name) + (add-method! (setter ,name) (method ,@(cddr exp))))))) + (cond ((not (symbol? name)) + (goops-error "bad method name: ~S" name)) + ((defined? name env) + `(begin + (if (not (or (is-a? ,name ) + (is-a? ,name ))) + (define-generic ,name)) + (add-method! ,name (method ,@(cddr exp))))) + (else + `(begin + (define-generic ,name) + (add-method! ,name (method ,@(cddr exp))))))))))) diff --git a/oop/goops/util.scm b/oop/goops/util.scm new file mode 100644 index 000000000..0e6df4147 --- /dev/null +++ b/oop/goops/util.scm @@ -0,0 +1,112 @@ +;;;; Copyright (C) 1999, 2000 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; + + +(define-module (oop goops util) + :no-backtrace + ) + +(export any every filter + mapappend find-duplicate top-level-env top-level-env? + map* for-each* length* improper->proper + ) + +;;; +;;; {Utilities} +;;; + +(define (any pred lst . rest) + (if (null? rest) ;fast path + (and (not (null? lst)) + (let loop ((head (car lst)) (tail (cdr lst))) + (if (null? tail) + (pred head) + (or (pred head) + (loop (car tail) (cdr tail)))))) + (let ((lsts (cons lst rest))) + (and (not (any null? lsts)) + (let loop ((heads (map car lsts)) (tails (map cdr lsts))) + (if (any null? tails) + (apply pred heads) + (or (apply pred heads) + (loop (map car tails) (map cdr tails))))))))) + +(define (every pred lst . rest) + (if (null? rest) ;fast path + (or (null? lst) + (let loop ((head (car lst)) (tail (cdr lst))) + (if (null? tail) + (pred head) + (and (pred head) + (loop (car tail) (cdr tail)))))) + (let ((lsts (cons lst rest))) + (or (any null? lsts) + (let loop ((heads (map car lsts)) (tails (map cdr lsts))) + (if (any null? tails) + (apply pred heads) + (and (apply pred heads) + (loop (map car tails) (map cdr tails))))))))) + +(define (filter test? list) + (cond ((null? list) '()) + ((test? (car list)) (cons (car list) (filter test? (cdr list)))) + (else (filter test? (cdr list))))) + +(define (mapappend func . args) + (if (memv '() args) + '() + (append (apply func (map car args)) + (apply mapappend func (map cdr args))))) + +(define (find-duplicate l) ; find a duplicate in a list; #f otherwise + (cond + ((null? l) #f) + ((memv (car l) (cdr l)) (car l)) + (else (find-duplicate (cdr l))))) + +(define (top-level-env) + (if *top-level-lookup-closure* + (list *top-level-lookup-closure*) + '())) + +(define (top-level-env? env) + (or (null? env) + (procedure? (car env)))) + +(define (map* fn . l) ; A map which accepts dotted lists (arg lists + (cond ; must be "isomorph" + ((null? (car l)) '()) + ((pair? (car l)) (cons (apply fn (map car l)) + (apply map* fn (map cdr l)))) + (else (apply fn l)))) + +(define (for-each* fn . l) ; A for-each which accepts dotted lists (arg lists + (cond ; must be "isomorph" + ((null? (car l)) '()) + ((pair? (car l)) (apply fn (map car l)) (apply for-each* fn (map cdr l))) + (else (apply fn l)))) + +(define (length* ls) + (do ((n 0 (+ 1 n)) + (ls ls (cdr ls))) + ((not (pair? ls)) n))) + +(define (improper->proper ls) + (if (pair? ls) + (cons (car ls) (improper->proper (cdr ls))) + (list ls))) From 42b586db774ba1fe1c729bff89d6ed6abce1be02 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 25 Oct 2000 15:51:06 +0000 Subject: [PATCH 0338/2047] * goops.h: Renamed class --> cls, new --> newinst in order to accomodate C++. --- libguile/goops.h | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/libguile/goops.h b/libguile/goops.h index d34fa5041..84f67b4e9 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -188,7 +188,7 @@ SCM scm_oldfmt (SCM); char *scm_c_oldfmt0 (char *); char *scm_c_oldfmt (char *, int n); void scm_load_goops (void); -SCM scm_make_foreign_object (SCM class, SCM initargs); +SCM scm_make_foreign_object (SCM cls, SCM initargs); SCM scm_make_class (SCM meta, char *s_name, SCM supers, size_t size, void * (*constructor) (SCM initargs), size_t (*destructor) (void *)); @@ -245,15 +245,15 @@ SCM scm_method_procedure (SCM obj); SCM scm_accessor_method_slot_definition (SCM obj); SCM scm_sys_fast_slot_ref (SCM obj, SCM index); SCM scm_sys_fast_slot_set_x (SCM obj, SCM index, SCM value); -SCM scm_slot_ref_using_class (SCM class, SCM obj, SCM slot_name); -SCM scm_slot_set_using_class_x (SCM class, SCM obj, SCM slot_name, SCM value); -SCM scm_slot_bound_using_class_p (SCM class, SCM obj, SCM slot_name); -SCM scm_slot_exists_using_class_p (SCM class, SCM obj, SCM slot_name); +SCM scm_slot_ref_using_class (SCM cls, SCM obj, SCM slot_name); +SCM scm_slot_set_using_class_x (SCM cls, SCM obj, SCM slot_name, SCM value); +SCM scm_slot_bound_using_class_p (SCM cls, SCM obj, SCM slot_name); +SCM scm_slot_exists_using_class_p (SCM cls, SCM obj, SCM slot_name); SCM scm_slot_bound_p (SCM obj, SCM slot_name); SCM scm_slots_exists_p (SCM obj, SCM slot_name); -SCM scm_sys_modify_instance (SCM old, SCM new); -SCM scm_sys_modify_class (SCM old, SCM new); -SCM scm_sys_invalidate_class (SCM class); +SCM scm_sys_modify_instance (SCM old, SCM newinst); +SCM scm_sys_modify_class (SCM old, SCM newcls); +SCM scm_sys_invalidate_class (SCM cls); SCM scm_make_method_cache (SCM gf); SCM scm_sys_invalidate_method_cache_x (SCM gf); SCM scm_generic_capability_p (SCM proc); From f4553de8f823dc03a4ee4c5ec920f8a897327c35 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 25 Oct 2000 15:51:29 +0000 Subject: [PATCH 0339/2047] *** empty log message *** --- libguile/ChangeLog | 2 ++ 1 file changed, 2 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 2845fdc77..43756efcf 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -22,6 +22,8 @@ Removed #include "versiondat.h", #include "goops.h". * goops.h: Removed various superfluous conditions. + Renamed class --> cls, new --> newinst in order to accomodate + C++. * init.c (scm_init_guile_1): Call the goops module registration function. From 4b5d86e0334f6b8c0b37c55cf47a4cd30e7803e0 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 25 Oct 2000 16:05:11 +0000 Subject: [PATCH 0340/2047] * mop.text: Preliminary documentation of the GOOPS meta object protocol. --- doc/mop.text | 0 1 file changed, 0 insertions(+), 0 deletions(-) create mode 100644 doc/mop.text diff --git a/doc/mop.text b/doc/mop.text new file mode 100644 index 000000000..e69de29bb From c6c2ea9fa8ca18f59d37b0d6d1d52d36e11626ea Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 25 Oct 2000 16:06:09 +0000 Subject: [PATCH 0341/2047] *** empty log message *** --- doc/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/ChangeLog b/doc/ChangeLog index e7ba2180e..086f97aff 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,8 @@ +2000-10-25 Mikael Djurfeldt + + * mop.text: Preliminary documentation of the GOOPS meta object + protocol. + 2000-07-28 Neil Jerram * data-rep.texi (Garbage Collection): Fix "accomodate" spelling From e9bfab50e4ec7787db05605727a06f98fe30f5b6 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 26 Oct 2000 18:18:28 +0000 Subject: [PATCH 0342/2047] * String comparison functions don't accept symbols as arguments any more. * Added macro SCM_STRING_COERCE_0TERMINATION_X. --- libguile/ChangeLog | 15 +++++ libguile/random.c | 1 + libguile/strings.h | 4 ++ libguile/strorder.c | 133 +++++++++++++++++++++++++------------------- 4 files changed, 97 insertions(+), 56 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 43756efcf..cff3cdf6a 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,18 @@ +2000-10-26 Dirk Herrmann + + * random.c: Include unif.h. + + * strings.h (SCM_STRING_COERCE_0TERMINATION_X): Added. This is + intended to replace the macro SCM_COERCE_SUBSTR. Such a macro + will be necessary, even after copy-on-write strings will be added + to guile, but the current naming is inappropriate. + + * strorder.c (scm_string_equal_p, scm_string_ci_equal_p, + scm_string_less_p, scm_string_ci_less_p): Don't accept symbols as + input parameters. Further, the functions that test for equality + are rewritten to compare from back to front, the others are also a + little bit more polished. + 2000-10-25 Mikael Djurfeldt This change merges the GOOPS code into Guile. However, GOOPS diff --git a/libguile/random.c b/libguile/random.c index 6467bb8e3..4ff289f4b 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -53,6 +53,7 @@ #include "libguile/numbers.h" #include "libguile/feature.h" #include "libguile/strings.h" +#include "libguile/unif.h" #include "libguile/vectors.h" #include "libguile/validate.h" diff --git a/libguile/strings.h b/libguile/strings.h index e6a9cf8b6..8e3ca5eb3 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -59,6 +59,10 @@ /* Is X a writable string (i.e., not a substring)? */ #define SCM_RWSTRINGP(x) (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_string)) +#define SCM_STRING_COERCE_0TERMINATION_X(x) \ + { if (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_substring)) \ + x = scm_makfromstr (SCM_ROCHARS (x), SCM_STRING_LENGTH (x), 0); } + extern SCM scm_string_p (SCM x); diff --git a/libguile/strorder.c b/libguile/strorder.c index 8d2453fea..c370aca77 100644 --- a/libguile/strorder.c +++ b/libguile/strorder.c @@ -63,25 +63,33 @@ SCM_DEFINE1 (scm_string_equal_p, "string=?", scm_tc7_rpsubr, "@samp{string=?} treats upper and lower case as distinct characters.") #define FUNC_NAME s_scm_string_equal_p { - register scm_sizet i; - register unsigned char *c1, *c2; - SCM_VALIDATE_ROSTRING (1,s1); - SCM_VALIDATE_ROSTRING (2,s2); + scm_sizet length; - i = SCM_ROLENGTH (s2); - if (SCM_ROLENGTH (s1) != i) + SCM_VALIDATE_STRING (1, s1); + SCM_VALIDATE_STRING (2, s2); + + length = SCM_STRING_LENGTH (s2); + if (SCM_STRING_LENGTH (s1) == length) + { + unsigned char *c1 = SCM_ROUCHARS (s1) + length - 1; + unsigned char *c2 = SCM_ROUCHARS (s2) + length - 1; + scm_sizet i; + + /* comparing from back to front typically finds mismatches faster */ + for (i = 0; i != length; ++i, --c1, --c2) + if (*c1 != *c2) + return SCM_BOOL_F; + + return SCM_BOOL_T; + } + else { return SCM_BOOL_F; } - c1 = SCM_ROUCHARS (s1); - c2 = SCM_ROUCHARS (s2); - while (0 != i--) - if (*c1++ != *c2++) - return SCM_BOOL_F; - return SCM_BOOL_T; } #undef FUNC_NAME + SCM_DEFINE1 (scm_string_ci_equal_p, "string-ci=?", scm_tc7_rpsubr, (SCM s1, SCM s2), "Case-insensitive string equality predicate; returns @t{#t} if\n" @@ -89,58 +97,62 @@ SCM_DEFINE1 (scm_string_ci_equal_p, "string-ci=?", scm_tc7_rpsubr, "match (ignoring case) at each position; otherwise returns @t{#f}. (r5rs)") #define FUNC_NAME s_scm_string_ci_equal_p { - register scm_sizet i; - register unsigned char *c1, *c2; - SCM_VALIDATE_ROSTRING (1,s1); - SCM_VALIDATE_ROSTRING (2,s2); + scm_sizet length; - i = SCM_ROLENGTH (s2); - if (SCM_ROLENGTH (s1) != i) + SCM_VALIDATE_STRING (1, s1); + SCM_VALIDATE_STRING (2, s2); + + length = SCM_STRING_LENGTH (s2); + if (SCM_STRING_LENGTH (s1) == length) + { + unsigned char *c1 = SCM_ROUCHARS (s1) + length - 1; + unsigned char *c2 = SCM_ROUCHARS (s2) + length - 1; + scm_sizet i; + + /* comparing from back to front typically finds mismatches faster */ + for (i = 0; i != length; ++i, --c1, --c2) + if (scm_upcase (*c1) != scm_upcase (*c2)) + return SCM_BOOL_F; + + return SCM_BOOL_T; + } + else { return SCM_BOOL_F; } - c1 = SCM_ROUCHARS (s1); - c2 = SCM_ROUCHARS (s2); - while (0 != i--) - if (scm_upcase(*c1++) != scm_upcase(*c2++)) - return SCM_BOOL_F; - return SCM_BOOL_T; } #undef FUNC_NAME + SCM_DEFINE1 (scm_string_less_p, "strings2len) len = s2len; + SCM_VALIDATE_STRING (1, s1); + SCM_VALIDATE_STRING (2, s2); + + length1 = SCM_STRING_LENGTH (s1); + length2 = SCM_STRING_LENGTH (s2); + lengthm = min (length1, length2); c1 = SCM_ROUCHARS (s1); c2 = SCM_ROUCHARS (s2); - for (i = 0;i0) - return SCM_BOOL_F; - if (c<0) - return SCM_BOOL_T; - } - { - SCM answer; - answer = SCM_BOOL(s2len != len); - return answer; + for (i = 0; i != lengthm; ++i, ++c1, ++c2) { + int c = *c1 - *c2; + if (c < 0) return SCM_BOOL_T; + if (c > 0) return SCM_BOOL_F; } + + return SCM_BOOL (length1 < length2); } #undef FUNC_NAME + SCM_DEFINE1 (scm_string_leq_p, "string<=?", scm_tc7_rpsubr, (SCM s1, SCM s2), "Lexicographic ordering predicate; returns @t{#t} if @var{s1}\n" @@ -151,6 +163,7 @@ SCM_DEFINE1 (scm_string_leq_p, "string<=?", scm_tc7_rpsubr, } #undef FUNC_NAME + SCM_DEFINE1 (scm_string_gr_p, "string>?", scm_tc7_rpsubr, (SCM s1, SCM s2), "Lexicographic ordering predicate; returns @t{#t} if @var{s1}\n" @@ -161,6 +174,7 @@ SCM_DEFINE1 (scm_string_gr_p, "string>?", scm_tc7_rpsubr, } #undef FUNC_NAME + SCM_DEFINE1 (scm_string_geq_p, "string>=?", scm_tc7_rpsubr, (SCM s1, SCM s2), "Lexicographic ordering predicate; returns @t{#t} if @var{s1}\n" @@ -171,6 +185,7 @@ SCM_DEFINE1 (scm_string_geq_p, "string>=?", scm_tc7_rpsubr, } #undef FUNC_NAME + SCM_DEFINE1 (scm_string_ci_less_p, "string-cis2len) len = s2len; + scm_sizet i, length1, length2, lengthm; + unsigned char *c1, *c2; + + SCM_VALIDATE_STRING (1, s1); + SCM_VALIDATE_STRING (2, s2); + + length1 = SCM_STRING_LENGTH (s1); + length2 = SCM_STRING_LENGTH (s2); + lengthm = min (length1, length2); c1 = SCM_ROUCHARS (s1); c2 = SCM_ROUCHARS (s2); - for (i = 0;i0) return SCM_BOOL_F; - if (c<0) return SCM_BOOL_T; + + for (i = 0; i != lengthm; ++i, ++c1, ++c2) { + int c = scm_upcase (*c1) - scm_upcase (*c2); + if (c < 0) return SCM_BOOL_T; + if (c > 0) return SCM_BOOL_F; } - return SCM_BOOL(s2len != len); + + return SCM_BOOL (length1 < length2); } #undef FUNC_NAME + SCM_DEFINE1 (scm_string_ci_leq_p, "string-ci<=?", scm_tc7_rpsubr, (SCM s1, SCM s2), "Case insensitive lexicographic ordering predicate; \n" @@ -208,6 +227,7 @@ SCM_DEFINE1 (scm_string_ci_leq_p, "string-ci<=?", scm_tc7_rpsubr, } #undef FUNC_NAME + SCM_DEFINE1 (scm_string_ci_gr_p, "string-ci>?", scm_tc7_rpsubr, (SCM s1, SCM s2), "Case insensitive lexicographic ordering predicate; \n" @@ -219,6 +239,7 @@ SCM_DEFINE1 (scm_string_ci_gr_p, "string-ci>?", scm_tc7_rpsubr, } #undef FUNC_NAME + SCM_DEFINE1 (scm_string_ci_geq_p, "string-ci>=?", scm_tc7_rpsubr, (SCM s1, SCM s2), "Case insensitive lexicographic ordering predicate; \n" From a6d9e5abe5b110dc30e8cf914bcb4de4d28baf43 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 30 Oct 2000 11:42:26 +0000 Subject: [PATCH 0343/2047] * Change a couple of functions to accept either symbols or strings only. * Get rid of remainig uses of SCM_LENGTH etc. --- NEWS | 27 ++++++++- RELEASE | 5 +- libguile/ChangeLog | 66 +++++++++++++++++++++- libguile/dynl.c | 80 +++++++++++++------------- libguile/error.c | 32 +++++++++-- libguile/filesys.c | 124 ++++++++++++++++++++--------------------- libguile/fports.c | 14 ++--- libguile/ioext.c | 10 ++-- libguile/load.c | 38 ++++++------- libguile/net_db.c | 37 ++++++------ libguile/numbers.c | 4 +- libguile/ports.c | 14 ++--- libguile/posix.c | 121 ++++++++++++++++++++-------------------- libguile/regex-posix.c | 12 ++-- libguile/simpos.c | 11 ++-- libguile/socket.c | 13 ++--- libguile/stime.c | 24 ++++---- libguile/strop.c | 18 +++--- libguile/strports.c | 4 +- libguile/symbols.c | 4 +- libguile/symbols.h | 15 ++--- libguile/unif.h | 21 ++++--- libguile/validate.h | 38 ++++++------- libguile/vports.c | 6 +- 24 files changed, 418 insertions(+), 320 deletions(-) diff --git a/NEWS b/NEWS index a4e93984a..60db8e26d 100644 --- a/NEWS +++ b/NEWS @@ -202,17 +202,42 @@ collector has set this variable. But, this is an implementation detail that may change. Further, scm_gc_heap_lock is not set throughout gc, thus the use of this variable is (and has been) not fully safe anyway. +** New macros: SCM_CONTINUATION_LENGTH, SCM_CCLO_LENGTH, SCM_STACK_LENGTH, +SCM_STRING_LENGTH, SCM_SYMBOL_LENGTH, SCM_UVECTOR_LENGTH, +SCM_BITVECTOR_LENGTH, SCM_VECTOR_LENGTH. + +Use these instead of SCM_LENGTH. + +** New macros: SCM_STRING_CHARS, SCM_SYMBOL_CHARS, SCM_CCLO_BASE, +SCM_VECTOR_BASE, SCM_UVECTOR_BASE, SCM_BITVECTOR_BASE, SCM_COMPLEX_MEM, +SCM_ARRAY_MEM + +Use these instead of SCM_CHARS or SCM_VELTS. + +** New macro: SCM_BITVECTOR_P + +** New macro: SCM_STRING_COERCE_0TERMINATION_X + +Use instead of SCM_COERCE_SUBSTR. + ** Deprecated macros: SCM_OUTOFRANGE, SCM_NALLOC, SCM_HUP_SIGNAL, SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD, SCM_ORD_SIG, SCM_NUM_SIGS, SCM_SYMBOL_SLOTS, SCM_SLOTS, SCM_SLOPPY_STRINGP, -SCM_VALIDATE_STRINGORSUBSTR, SCM_FREEP, SCM_NFREEP +SCM_VALIDATE_STRINGORSUBSTR, SCM_FREEP, SCM_NFREEP, SCM_CHARS, SCM_UCHARS, +SCM_VALIDATE_ROSTRING, SCM_VALIDATE_ROSTRING_COPY, +SCM_VALIDATE_NULLORROSTRING_COPY, SCM_ROLENGTH, SCM_LENGTH, SCM_HUGE_LENGTH, +SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of SCM_OUTOFRANGE. Use scm_memory_error instead of SCM_NALLOC. Use SCM_STRINGP instead of SCM_SLOPPY_STRINGP. Use SCM_VALIDATE_STRING instead of SCM_VALIDATE_STRINGORSUBSTR. Use SCM_FREE_CELL_P instead of SCM_FREEP/SCM_NFREEP +Use a type specific accessor macro instead of SCM_CHARS/SCM_UCHARS. +Use a type specific accessor instead of SCM(_|_RO|_HUGE_)LENGTH. +Use SCM_VALIDATE_(SYMBOL|STRING) instead of SCM_VALIDATE_ROSTRING. +Use SCM_STRING_COERCE_0TERMINATION_X instead of SCM_COERCE_SUBSTR. ** Removed function: scm_struct_init diff --git a/RELEASE b/RELEASE index 93ecc9962..e2773c54d 100644 --- a/RELEASE +++ b/RELEASE @@ -46,7 +46,10 @@ In release 1.6: SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD, SCM_ORD_SIG, SCM_NUM_SIGS, SCM_SLOPPY_STRINGP, SCM_VALIDATE_STRINGORSUBSTR, - SCM_FREEP, SCM_NFREEP + SCM_FREEP, SCM_NFREEP, SCM_CHARS, SCM_UCHARS, SCM_VALIDATE_ROSTRING, + SCM_VALIDATE_ROSTRING_COPY, SCM_VALIDATE_NULLORROSTRING_COPY, SCM_ROLENGTH, + SCM_LENGTH, SCM_HUGE_LENGTH, SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, + SCM_COERCE_SUBSTR - remove scm_vector_set_length_x - remove function scm_call_catching_errors (replaced by catch functions from throw.[ch]) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index cff3cdf6a..d2b0d79b1 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,68 @@ +2000-10-27 Dirk Herrmann + + * dynl.c (scm_dynamic_link, scm_dynamic_func, scm_dynamic_call, + scm_dynamic_args_call), filesys.c (scm_chown, scm_chmod, + scm_open_fdes, scm_stat, scm_link, scm_rename, scm_delete_file, + scm_mkdir, scm_rmdir, scm_opendir, scm_chdir, scm_symlink, + scm_readlink, scm_lstat, scm_copy_file), fports.c (scm_open_file), + ioext.c (scm_read_delimited_x, scm_fdopen), load.c + (scm_primitive_load, scm_parse_path, scm_search_path, + scm_sys_search_load_path, scm_primitive_load_path), net_db.c + (scm_inet_aton, scm_gethost, scm_getnet, scm_getproto, + scm_getserv), numbers.c (scm_string_to_number), ports.c + (scm_truncate_file, scm_sys_make_void_port), posix.c + (scm_getpwuid, scm_getgrgid, scm_execl, scm_execlp, + environ_list_to_c, scm_execle, scm_utime, scm_access, + scm_setlocale, scm_mknod), regex-posix.c (scm_make_regexp), + simpos.c (scm_system, scm_getenv), socket.c (scm_fill_sockaddr, + scm_send, scm_sendto), stime.c (scm_strftime, scm_strptime), + strop.c (scm_i_index, scm_string_null_p, scm_string_to_list), + strports.c (scm_mkstrport), symbols.c + (scm_string_to_obarray_symbol), vports.c (scm_make_soft_port): + Don't accept symbols as input parameters. Use SCM_STRING_LENGTH + instead of SCM_ROLENGTH. + + * dynl.c (scm_dynamic_link, scm_dynamic_func), error.c + (scm_error_scm), filesys.c (scm_chown, scm_chmod, scm_open_fdes, + scm_stat, scm_link, scm_rename, scm_delete_file, scm_mkdir, + scm_rmdir, scm_opendir, scm_chdir, scm_symlink, scm_readlink, + scm_lstat, scm_copy_file), fports.c (scm_open_file), ioext.c + (scm_fdopen), net_db.c (scm_inet_aton, scm_gethost, scm_getnet, + scm_getproto, scm_getserv), ports.c (scm_truncate_file, + scm_sys_make_void_port), posix.c (scm_getpwuid, scm_getgrgid, + scm_execl, scm_execlp, scm_execle, scm_utime, scm_access, + scm_setlocale, scm_mknod), regex-posix.c (scm_make_regexp, + scm_regexp_exec), simpos.c (scm_system, scm_getenv), stime.c + (setzone, scm_strftime, scm_strptime), vports.c + (scm_make_soft_port): Use SCM_STRING_COERCE_0TERMINATION_X to + make sure the characters of a string are followed by a \0. + Further, use SCM_STRING_CHARS instead of SCM_ROCHARS on the + resulting string. + + * dynl.c (scm_make_argv_from_stringlist), posix.c + (scm_convert_exec_args): Aligned to match each other. + + * dynl.c (scm_coerce_rostring): Removed. + + (scm_dynamic_func): Changed the comment to reflect that the + function name has to be a string. Further, hide implementation + details from the scheme comment. + + * error (scm_error_scm): Don't accept a symbol as message + parameter. Fix substring handling. + + * posix.c (environ_list_to_c): Use memcpy to copy environment + strings. Handle substrings which don't have a trailing \0. + + * symbols.h (SCM_LENGTH, SCM_ROLENGTH, SCM_SUBSTRP, + SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR): + Deprecated. + + * unif.h (SCM_HUGE_LENGTH): Deprecated. + + * validate.h (SCM_VALIDATE_ROSTRING, SCM_VALIDATE_ROSTRING_COPY, + SCM_VALIDATE_NULLORROSTRING_COPY): Deprecated. + 2000-10-26 Dirk Herrmann * random.c: Include unif.h. @@ -110,7 +175,6 @@ * validated.h (SCM_VALIDATE_STRINGORSUBSTR): Deprecated. ->>>>>>> 1.1152 2000-10-20 Marius Vollmer * init.c (scm_init_guile_1, invoke_main_func): Call diff --git a/libguile/dynl.c b/libguile/dynl.c index 595517045..9d3346f1f 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -74,33 +74,41 @@ maybe_drag_in_eprintf () #include "libguile/validate.h" +/* Create a new C argv array from a scheme list of strings. */ +/* Dirk:FIXME:: A quite similar function is implemented in posix.c */ +/* Dirk:FIXME:: In case of assertion errors, we get memory leaks */ + /* Converting a list of SCM strings into a argv-style array. You must have ints disabled for the whole lifetime of the created argv (from before MAKE_ARGV_FROM_STRINGLIST until after MUST_FREE_ARGV). Atleast this is was the documentation for MAKARGVFROMSTRS says, it isn't really used that way. - This code probably belongs into strings.c */ + This code probably belongs into strings.c + (Dirk: IMO strings.c is not the right place.) */ static char ** scm_make_argv_from_stringlist (SCM args,int *argcp,const char *subr,int argn) { char **argv; - int argc, i; + int argc; + int i; argc = scm_ilength (args); - argv = (char **) scm_must_malloc ((1L + argc) * sizeof (char *), subr); - for (i = 0; SCM_NNULLP (args); args = SCM_CDR (args), i++) { - size_t len; - char *dst, *src; - SCM str = SCM_CAR (args); + SCM_ASSERT (argc >= 0, args, argn, subr); + argv = (char **) scm_must_malloc ((argc + 1) * sizeof (char *), subr); + for (i = 0; !SCM_NULLP (args); args = SCM_CDR (args), ++i) { + SCM arg = SCM_CAR (args); + scm_sizet len; + char *dst; + char *src; - SCM_ASSERT (SCM_ROSTRINGP (str), str, argn, subr); - len = 1 + SCM_ROLENGTH (str); - dst = (char *) scm_must_malloc ((long) len, subr); - src = SCM_ROCHARS (str); - while (len--) - dst[len] = src[len]; + SCM_ASSERT (SCM_STRINGP (arg), args, argn, subr); + len = SCM_STRING_LENGTH (arg); + src = SCM_ROCHARS (arg); + dst = (char *) scm_must_malloc (len + 1, subr); + memcpy (dst, src, len); + dst[len] = 0; argv[i] = dst; } @@ -119,18 +127,6 @@ scm_must_free_argv(char **argv) free (argv); } -/* Coerce an arbitrary readonly-string into a zero-terminated string. - */ - -static SCM -scm_coerce_rostring (SCM rostr,const char *subr,int argn) -{ - SCM_ASSERT (SCM_ROSTRINGP (rostr), rostr, argn, subr); - if (SCM_SUBSTRP (rostr)) - rostr = scm_makfromstr (SCM_ROCHARS (rostr), SCM_STRING_LENGTH (rostr), 0); - return rostr; -} - /* Module registry */ @@ -353,11 +349,10 @@ SCM_DEFINE (scm_dynamic_link, "dynamic-link", 1, 0, 0, #define FUNC_NAME s_scm_dynamic_link { void *handle; - char *chars; - fname = scm_coerce_rostring (fname, FUNC_NAME, 1); - chars = SCM_STRINGP (fname) ? SCM_STRING_CHARS (fname) : SCM_SYMBOL_CHARS (fname); - handle = sysdep_dynl_link (chars, FUNC_NAME); + SCM_VALIDATE_STRING (1, fname); + SCM_STRING_COERCE_0TERMINATION_X (fname); + handle = sysdep_dynl_link (SCM_STRING_CHARS (fname), FUNC_NAME); SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj, SCM_UNPACK (fname), handle); } #undef FUNC_NAME @@ -401,24 +396,24 @@ SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0, SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0, - (SCM symb, SCM dobj), - "Import the symbol @var{func} from @var{lib} (a dynamic library handle).\n" - "A @dfn{function handle} representing the imported function is returned.\n" - "GJB:FIXME:DOC: 2nd version below\n" - "Search the C function indicated by @var{function} (a string or symbol)\n" - "in @var{dynobj} and return some Scheme object that can later be used\n" - "with @code{dynamic-call} to actually call this function. Right now,\n" - "these Scheme objects are formed by casting the address of the function\n" - "to @code{long} and converting this number to its Scheme representation.\n\n" + (SCM name, SCM dobj), + "Search the dynamic object @var{dobj} for the C function\n" + "indicated by the string @var{name} and return some Scheme\n" + "handle that can later be used with @code{dynamic-call} to\n" + "actually call the function.\n\n" "Regardless whether your C compiler prepends an underscore @samp{_} to\n" "the global names in a program, you should @strong{not} include this\n" "underscore in @var{function}. Guile knows whether the underscore is\n" "needed or not and will add it when necessary.") #define FUNC_NAME s_scm_dynamic_func { + /* The returned handle is formed by casting the address of the function to a + * long value and converting this to a scheme number + */ + void (*func) (); - symb = scm_coerce_rostring (symb, FUNC_NAME, 1); + SCM_VALIDATE_STRING (1, name); /*fixme* GC-problem */ SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj); if (DYNL_HANDLE (dobj) == NULL) { @@ -427,7 +422,8 @@ SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0, char *chars; SCM_DEFER_INTS; - chars = SCM_STRINGP (symb) ? SCM_STRING_CHARS (symb) : SCM_SYMBOL_CHARS (symb); + SCM_STRING_COERCE_0TERMINATION_X (name); + chars = SCM_STRING_CHARS (name); func = (void (*) ()) sysdep_dynl_func (chars, DYNL_HANDLE (dobj), FUNC_NAME); SCM_ALLOW_INTS; return scm_ulong2num ((unsigned long) func); @@ -458,7 +454,7 @@ SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0, { void (*fptr) (); - if (SCM_ROSTRINGP (func)) + if (SCM_STRINGP (func)) func = scm_dynamic_func (func, dobj); fptr = (void (*) ()) SCM_NUM2ULONG (1, func); SCM_DEFER_INTS; @@ -494,7 +490,7 @@ SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0, int result, argc; char **argv; - if (SCM_ROSTRINGP (func)) + if (SCM_STRINGP (func)) func = scm_dynamic_func (func, dobj); fptr = (int (*) (int, char **)) SCM_NUM2ULONG (1, func); diff --git a/libguile/error.c b/libguile/error.c index 4790df734..69f680ee5 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -116,10 +116,34 @@ SCM_DEFINE (scm_error_scm, "scm-error", 5, 0, 0, { char *szSubr; char *szMessage; - SCM_VALIDATE_SYMBOL (1,key); - SCM_VALIDATE_NULLORROSTRING_COPY (2,subr,szSubr); - SCM_VALIDATE_NULLORROSTRING_COPY (3,message,szMessage); - SCM_COERCE_SUBSTR (message); + + SCM_VALIDATE_SYMBOL (1, key); + + if (SCM_FALSEP (subr)) + { + szSubr = NULL; + } + else if (SCM_SYMBOLP (subr)) + { + szSubr = SCM_SYMBOL_CHARS (subr); + } + else + { + SCM_VALIDATE_STRING (2, subr); + SCM_STRING_COERCE_0TERMINATION_X (subr); + szSubr = SCM_STRING_CHARS (subr); + } + + if (SCM_FALSEP (message)) + { + szMessage = NULL; + } + else + { + SCM_VALIDATE_STRING (2, message); + SCM_STRING_COERCE_0TERMINATION_X (message); + szMessage = SCM_STRING_CHARS (message); + } scm_error (key, szSubr, szMessage, args, rest); /* not reached. */ diff --git a/libguile/filesys.c b/libguile/filesys.c index c7de1c615..7e280652e 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -155,9 +155,9 @@ SCM_DEFINE (scm_chown, "chown", 3, 0, 0, else #endif { - SCM_VALIDATE_ROSTRING(1,object); - SCM_COERCE_SUBSTR (object); - SCM_SYSCALL (rv = chown (SCM_ROCHARS (object), + SCM_VALIDATE_STRING (1, object); + SCM_STRING_COERCE_0TERMINATION_X (object); + SCM_SYSCALL (rv = chown (SCM_STRING_CHARS (object), SCM_INUM (owner), SCM_INUM (group))); } if (rv == -1) @@ -194,9 +194,9 @@ SCM_DEFINE (scm_chmod, "chmod", 2, 0, 0, } else { - SCM_VALIDATE_ROSTRING (1,object); - SCM_COERCE_SUBSTR (object); - SCM_SYSCALL (rv = chmod (SCM_ROCHARS (object), SCM_INUM (mode))); + SCM_VALIDATE_STRING (1, object); + SCM_STRING_COERCE_0TERMINATION_X (object); + SCM_SYSCALL (rv = chmod (SCM_STRING_CHARS (object), SCM_INUM (mode))); } if (rv == -1) SCM_SYSERROR; @@ -239,11 +239,11 @@ SCM_DEFINE (scm_open_fdes, "open-fdes", 2, 1, 0, int iflags; int imode; - SCM_VALIDATE_ROSTRING (1,path); - SCM_COERCE_SUBSTR (path); + SCM_VALIDATE_STRING (1, path); + SCM_STRING_COERCE_0TERMINATION_X (path); iflags = SCM_NUM2LONG(2,flags); imode = SCM_NUM2LONG_DEF(3,mode,0666); - SCM_SYSCALL (fd = open (SCM_ROCHARS (path), iflags, imode)); + SCM_SYSCALL (fd = open (SCM_STRING_CHARS (path), iflags, imode)); if (fd == -1) SCM_SYSERROR; return SCM_MAKINUM (fd); @@ -505,10 +505,10 @@ SCM_DEFINE (scm_stat, "stat", 1, 0, 0, else { SCM_VALIDATE_NIM (1,object); - if (SCM_ROSTRINGP (object)) + if (SCM_STRINGP (object)) { - SCM_COERCE_SUBSTR (object); - SCM_SYSCALL (rv = stat (SCM_ROCHARS (object), &stat_temp)); + SCM_STRING_COERCE_0TERMINATION_X (object); + SCM_SYSCALL (rv = stat (SCM_STRING_CHARS (object), &stat_temp)); } else { @@ -544,15 +544,11 @@ SCM_DEFINE (scm_link, "link", 2, 0, 0, { int val; - SCM_VALIDATE_ROSTRING (1,oldpath); - if (SCM_SUBSTRP (oldpath)) - oldpath = scm_makfromstr (SCM_ROCHARS (oldpath), - SCM_STRING_LENGTH (oldpath), 0); - SCM_VALIDATE_ROSTRING (2,newpath); - if (SCM_SUBSTRP (newpath)) - newpath = scm_makfromstr (SCM_ROCHARS (newpath), - SCM_STRING_LENGTH (newpath), 0); - SCM_SYSCALL (val = link (SCM_ROCHARS (oldpath), SCM_ROCHARS (newpath))); + SCM_VALIDATE_STRING (1, oldpath); + SCM_STRING_COERCE_0TERMINATION_X (oldpath); + SCM_VALIDATE_STRING (2, newpath); + SCM_STRING_COERCE_0TERMINATION_X (newpath); + SCM_SYSCALL (val = link (SCM_STRING_CHARS (oldpath), SCM_STRING_CHARS (newpath))); if (val != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; @@ -568,20 +564,20 @@ SCM_DEFINE (scm_rename, "rename-file", 2, 0, 0, #define FUNC_NAME s_scm_rename { int rv; - SCM_VALIDATE_ROSTRING (1,oldname); - SCM_VALIDATE_ROSTRING (2,newname); - SCM_COERCE_SUBSTR (oldname); - SCM_COERCE_SUBSTR (newname); + SCM_VALIDATE_STRING (1, oldname); + SCM_VALIDATE_STRING (2, newname); + SCM_STRING_COERCE_0TERMINATION_X (oldname); + SCM_STRING_COERCE_0TERMINATION_X (newname); #ifdef HAVE_RENAME - SCM_SYSCALL (rv = rename (SCM_ROCHARS (oldname), SCM_ROCHARS (newname))); + SCM_SYSCALL (rv = rename (SCM_STRING_CHARS (oldname), SCM_STRING_CHARS (newname))); #else - SCM_SYSCALL (rv = link (SCM_ROCHARS (oldname), SCM_ROCHARS (newname))); + SCM_SYSCALL (rv = link (SCM_STRING_CHARS (oldname), SCM_STRING_CHARS (newname))); if (rv == 0) { - SCM_SYSCALL (rv = unlink (SCM_ROCHARS (oldname)));; + SCM_SYSCALL (rv = unlink (SCM_STRING_CHARS (oldname)));; if (rv != 0) /* unlink failed. remove new name */ - SCM_SYSCALL (unlink (SCM_ROCHARS (newname))); + SCM_SYSCALL (unlink (SCM_STRING_CHARS (newname))); } #endif if (rv != 0) @@ -597,9 +593,9 @@ SCM_DEFINE (scm_delete_file, "delete-file", 1, 0, 0, #define FUNC_NAME s_scm_delete_file { int ans; - SCM_VALIDATE_ROSTRING (1,str); - SCM_COERCE_SUBSTR (str); - SCM_SYSCALL (ans = unlink (SCM_ROCHARS (str))); + SCM_VALIDATE_STRING (1, str); + SCM_STRING_COERCE_0TERMINATION_X (str); + SCM_SYSCALL (ans = unlink (SCM_STRING_CHARS (str))); if (ans != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; @@ -617,18 +613,18 @@ SCM_DEFINE (scm_mkdir, "mkdir", 1, 1, 0, { int rv; mode_t mask; - SCM_VALIDATE_ROSTRING (1,path); - SCM_COERCE_SUBSTR (path); + SCM_VALIDATE_STRING (1, path); + SCM_STRING_COERCE_0TERMINATION_X (path); if (SCM_UNBNDP (mode)) { mask = umask (0); umask (mask); - SCM_SYSCALL (rv = mkdir (SCM_ROCHARS (path), 0777 ^ mask)); + SCM_SYSCALL (rv = mkdir (SCM_STRING_CHARS (path), 0777 ^ mask)); } else { SCM_VALIDATE_INUM (2,mode); - SCM_SYSCALL (rv = mkdir (SCM_ROCHARS (path), SCM_INUM (mode))); + SCM_SYSCALL (rv = mkdir (SCM_STRING_CHARS (path), SCM_INUM (mode))); } if (rv != 0) SCM_SYSERROR; @@ -646,9 +642,9 @@ SCM_DEFINE (scm_rmdir, "rmdir", 1, 0, 0, { int val; - SCM_VALIDATE_ROSTRING (1,path); - SCM_COERCE_SUBSTR (path); - SCM_SYSCALL (val = rmdir (SCM_ROCHARS (path))); + SCM_VALIDATE_STRING (1, path); + SCM_STRING_COERCE_0TERMINATION_X (path); + SCM_SYSCALL (val = rmdir (SCM_STRING_CHARS (path))); if (val != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; @@ -679,9 +675,9 @@ SCM_DEFINE (scm_opendir, "opendir", 1, 0, 0, #define FUNC_NAME s_scm_opendir { DIR *ds; - SCM_VALIDATE_ROSTRING (1,dirname); - SCM_COERCE_SUBSTR (dirname); - SCM_SYSCALL (ds = opendir (SCM_ROCHARS (dirname))); + SCM_VALIDATE_STRING (1, dirname); + SCM_STRING_COERCE_0TERMINATION_X (dirname); + SCM_SYSCALL (ds = opendir (SCM_STRING_CHARS (dirname))); if (ds == NULL) SCM_SYSERROR; SCM_RETURN_NEWSMOB (scm_tc16_dir | SCM_OPN, ds); @@ -781,9 +777,9 @@ SCM_DEFINE (scm_chdir, "chdir", 1, 0, 0, { int ans; - SCM_VALIDATE_ROSTRING (1,str); - SCM_COERCE_SUBSTR (str); - SCM_SYSCALL (ans = chdir (SCM_ROCHARS (str))); + SCM_VALIDATE_STRING (1, str); + SCM_STRING_COERCE_0TERMINATION_X (str); + SCM_SYSCALL (ans = chdir (SCM_STRING_CHARS (str))); if (ans != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; @@ -1206,11 +1202,11 @@ SCM_DEFINE (scm_symlink, "symlink", 2, 0, 0, { int val; - SCM_VALIDATE_ROSTRING (1,oldpath); - SCM_VALIDATE_ROSTRING (2,newpath); - SCM_COERCE_SUBSTR (oldpath); - SCM_COERCE_SUBSTR (newpath); - SCM_SYSCALL (val = symlink(SCM_ROCHARS(oldpath), SCM_ROCHARS(newpath))); + SCM_VALIDATE_STRING (1, oldpath); + SCM_VALIDATE_STRING (2, newpath); + SCM_STRING_COERCE_0TERMINATION_X (oldpath); + SCM_STRING_COERCE_0TERMINATION_X (newpath); + SCM_SYSCALL (val = symlink (SCM_STRING_CHARS (oldpath), SCM_STRING_CHARS (newpath))); if (val != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; @@ -1230,10 +1226,10 @@ SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0, int size = 100; char *buf; SCM result; - SCM_VALIDATE_ROSTRING (1,path); - SCM_COERCE_SUBSTR (path); + SCM_VALIDATE_STRING (1, path); + SCM_STRING_COERCE_0TERMINATION_X (path); buf = scm_must_malloc (size, FUNC_NAME); - while ((rv = readlink (SCM_ROCHARS (path), buf, size)) == size) + while ((rv = readlink (SCM_STRING_CHARS (path), buf, size)) == size) { scm_must_free (buf); size *= 2; @@ -1259,9 +1255,9 @@ SCM_DEFINE (scm_lstat, "lstat", 1, 0, 0, int rv; struct stat stat_temp; - SCM_VALIDATE_ROSTRING (1,str); - SCM_COERCE_SUBSTR (str); - SCM_SYSCALL(rv = lstat(SCM_ROCHARS(str), &stat_temp)); + SCM_VALIDATE_STRING (1, str); + SCM_STRING_COERCE_0TERMINATION_X (str); + SCM_SYSCALL (rv = lstat (SCM_STRING_CHARS (str), &stat_temp)); if (rv != 0) { int en = errno; @@ -1287,20 +1283,18 @@ SCM_DEFINE (scm_copy_file, "copy-file", 2, 0, 0, char buf[BUFSIZ]; struct stat oldstat; - SCM_VALIDATE_ROSTRING (1,oldfile); - if (SCM_SUBSTRP (oldfile)) - oldfile = scm_makfromstr (SCM_ROCHARS (oldfile), SCM_STRING_LENGTH (oldfile), 0); - SCM_VALIDATE_ROSTRING (2,newfile); - if (SCM_SUBSTRP (newfile)) - newfile = scm_makfromstr (SCM_ROCHARS (newfile), SCM_STRING_LENGTH (newfile), 0); - if (stat (SCM_ROCHARS (oldfile), &oldstat) == -1) + SCM_VALIDATE_STRING (1, oldfile); + SCM_STRING_COERCE_0TERMINATION_X (oldfile); + SCM_VALIDATE_STRING (2, newfile); + SCM_STRING_COERCE_0TERMINATION_X (newfile); + if (stat (SCM_STRING_CHARS (oldfile), &oldstat) == -1) SCM_SYSERROR; - oldfd = open (SCM_ROCHARS (oldfile), O_RDONLY); + oldfd = open (SCM_STRING_CHARS (oldfile), O_RDONLY); if (oldfd == -1) SCM_SYSERROR; /* use POSIX flags instead of 07777?. */ - newfd = open (SCM_ROCHARS (newfile), O_WRONLY | O_CREAT | O_TRUNC, + newfd = open (SCM_STRING_CHARS (newfile), O_WRONLY | O_CREAT | O_TRUNC, oldstat.st_mode & 07777); if (newfd == -1) SCM_SYSERROR; diff --git a/libguile/fports.c b/libguile/fports.c index bd955e314..658ab2675 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -276,15 +276,13 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0, char *mode; char *ptr; - SCM_VALIDATE_ROSTRING (1,filename); - SCM_VALIDATE_ROSTRING (2,modes); - if (SCM_SUBSTRP (filename)) - filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_STRING_LENGTH (filename), 0); - if (SCM_SUBSTRP (modes)) - modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_STRING_LENGTH (modes), 0); + SCM_VALIDATE_STRING (1, filename); + SCM_VALIDATE_STRING (2, modes); + SCM_STRING_COERCE_0TERMINATION_X (filename); + SCM_STRING_COERCE_0TERMINATION_X (modes); - file = SCM_ROCHARS (filename); - mode = SCM_ROCHARS (modes); + file = SCM_STRING_CHARS (filename); + mode = SCM_STRING_CHARS (modes); switch (*mode) { diff --git a/libguile/ioext.c b/libguile/ioext.c index c6d49d7f1..9cb84560e 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -93,8 +93,8 @@ SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0, char *cdelims; int num_delims; - SCM_VALIDATE_ROSTRING_COPY (1,delims,cdelims); - num_delims = SCM_ROLENGTH (delims); + SCM_VALIDATE_STRING_COPY (1, delims, cdelims); + num_delims = SCM_STRING_LENGTH (delims); SCM_VALIDATE_STRING_COPY (2,buf,cbuf); cend = SCM_STRING_LENGTH (buf); if (SCM_UNBNDP (port)) @@ -457,10 +457,10 @@ SCM_DEFINE (scm_fdopen, "fdopen", 2, 0, 0, #define FUNC_NAME s_scm_fdopen { SCM_VALIDATE_INUM (1,fdes); - SCM_VALIDATE_ROSTRING (2,modes); - SCM_COERCE_SUBSTR (modes); + SCM_VALIDATE_STRING (2, modes); + SCM_STRING_COERCE_0TERMINATION_X (modes); - return scm_fdes_to_port (SCM_INUM (fdes), SCM_ROCHARS (modes), SCM_BOOL_F); + return scm_fdes_to_port (SCM_INUM (fdes), SCM_STRING_CHARS (modes), SCM_BOOL_F); } #undef FUNC_NAME diff --git a/libguile/load.c b/libguile/load.c index 06eacbd8f..ca84cc454 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -118,7 +118,7 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0, #define FUNC_NAME s_scm_primitive_load { SCM hook = *scm_loc_load_hook; - SCM_VALIDATE_ROSTRING (1,filename); + SCM_VALIDATE_STRING (1, filename); SCM_ASSERT (SCM_FALSEP (hook) || (SCM_EQ_P (scm_procedure_p (hook), SCM_BOOL_T)), hook, "value of %load-hook is neither a procedure nor #f", FUNC_NAME); @@ -225,7 +225,7 @@ SCM_DEFINE (scm_parse_path, "parse-path", 1, 1, 0, "") #define FUNC_NAME s_scm_parse_path { - SCM_ASSERT (SCM_FALSEP (path) || (SCM_ROSTRINGP (path)), + SCM_ASSERT (SCM_FALSEP (path) || (SCM_STRINGP (path)), path, SCM_ARG1, FUNC_NAME); if (SCM_UNBNDP (tail)) @@ -276,14 +276,14 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, size_t max_ext_len; /* maximum length of any EXTENSIONS element */ SCM_VALIDATE_LIST (1,path); - SCM_VALIDATE_ROSTRING (2,filename); + SCM_VALIDATE_STRING (2, filename); if (SCM_UNBNDP (extensions)) extensions = SCM_EOL; else SCM_VALIDATE_LIST (3,extensions); filename_chars = SCM_ROCHARS (filename); - filename_len = SCM_ROLENGTH (filename); + filename_len = SCM_STRING_LENGTH (filename); /* If FILENAME is absolute, return it unchanged. */ if (filename_len >= 1 && filename_chars[0] == '/') @@ -294,14 +294,14 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, SCM walk; max_path_len = 0; - for (walk = path; SCM_NNULLP (walk); walk = SCM_CDR (walk)) + for (walk = path; !SCM_NULLP (walk); walk = SCM_CDR (walk)) { SCM elt = SCM_CAR (walk); - SCM_ASSERT (SCM_ROSTRINGP (elt), elt, + SCM_ASSERT (SCM_STRINGP (elt), elt, "path is not a list of strings", FUNC_NAME); - if (SCM_ROLENGTH (elt) > max_path_len) - max_path_len = SCM_ROLENGTH (elt); + if (SCM_STRING_LENGTH (elt) > max_path_len) + max_path_len = SCM_STRING_LENGTH (elt); } } @@ -333,14 +333,14 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, SCM walk; max_ext_len = 0; - for (walk = extensions; SCM_NNULLP (walk); walk = SCM_CDR (walk)) + for (walk = extensions; !SCM_NULLP (walk); walk = SCM_CDR (walk)) { SCM elt = SCM_CAR (walk); - SCM_ASSERT (SCM_ROSTRINGP (elt), elt, + SCM_ASSERT (SCM_STRINGP (elt), elt, "extension list is not a list of strings", FUNC_NAME); - if (SCM_ROLENGTH (elt) > max_ext_len) - max_ext_len = SCM_ROLENGTH (elt); + if (SCM_STRING_LENGTH (elt) > max_ext_len) + max_ext_len = SCM_STRING_LENGTH (elt); } } @@ -357,14 +357,14 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, /* Try every path element. At this point, we know the path is a proper list of strings. */ - for (; SCM_NNULLP (path); path = SCM_CDR (path)) + for (; !SCM_NULLP (path); path = SCM_CDR (path)) { int len; SCM dir = SCM_CAR (path); SCM exts; /* Concatenate the path name and the filename. */ - len = SCM_ROLENGTH (dir); + len = SCM_STRING_LENGTH (dir); memcpy (buf, SCM_ROCHARS (dir), len); if (len >= 1 && buf[len - 1] != '/') buf[len++] = '/'; @@ -373,10 +373,10 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, /* Try every extension. At this point, we know the extension list is a proper, nonempty list of strings. */ - for (exts = extensions; SCM_NNULLP (exts); exts = SCM_CDR (exts)) + for (exts = extensions; !SCM_NULLP (exts); exts = SCM_CDR (exts)) { SCM ext = SCM_CAR (exts); - int ext_len = SCM_ROLENGTH (ext); + int ext_len = SCM_STRING_LENGTH (ext); struct stat mode; /* Concatenate the extension. */ @@ -420,7 +420,7 @@ SCM_DEFINE (scm_sys_search_load_path, "%search-load-path", 1, 0, 0, { SCM path = *scm_loc_load_path; SCM exts = *scm_loc_load_extensions; - SCM_VALIDATE_ROSTRING (1,filename); + SCM_VALIDATE_STRING (1, filename); SCM_ASSERT (scm_ilength (path) >= 0, path, "load path is not a proper list", FUNC_NAME); @@ -441,13 +441,13 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0, { SCM full_filename; - SCM_VALIDATE_ROSTRING (1,filename); + SCM_VALIDATE_STRING (1, filename); full_filename = scm_sys_search_load_path (filename); if (SCM_FALSEP (full_filename)) { - int absolute = (SCM_ROLENGTH (filename) >= 1 + int absolute = (SCM_STRING_LENGTH (filename) >= 1 && SCM_ROCHARS (filename)[0] == '/'); SCM_MISC_ERROR ((absolute ? "Unable to load file ~S" diff --git a/libguile/net_db.c b/libguile/net_db.c index 1df26f4f1..c29597979 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -95,10 +95,9 @@ SCM_DEFINE (scm_inet_aton, "inet-aton", 1, 0, 0, { struct in_addr soka; - SCM_VALIDATE_ROSTRING (1,address); - if (SCM_SUBSTRP (address)) - address = scm_makfromstr (SCM_ROCHARS (address), SCM_ROLENGTH (address), 0); - if (inet_aton (SCM_ROCHARS (address), &soka) == 0) + SCM_VALIDATE_STRING (1, address); + SCM_STRING_COERCE_0TERMINATION_X (address); + if (inet_aton (SCM_STRING_CHARS (address), &soka) == 0) SCM_MISC_ERROR ("bad address", SCM_EOL); return scm_ulong2num (ntohl (soka.s_addr)); } @@ -277,10 +276,10 @@ SCM_DEFINE (scm_gethost, "gethost", 0, 1, 0, return SCM_BOOL_F; } } - else if (SCM_ROSTRINGP (host)) + else if (SCM_STRINGP (host)) { - SCM_COERCE_SUBSTR (host); - entry = gethostbyname (SCM_ROCHARS (host)); + SCM_STRING_COERCE_0TERMINATION_X (host); + entry = gethostbyname (SCM_STRING_CHARS (host)); } else { @@ -351,10 +350,10 @@ SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0, return SCM_BOOL_F; } } - else if (SCM_ROSTRINGP (net)) + else if (SCM_STRINGP (net)) { - SCM_COERCE_SUBSTR (net); - entry = getnetbyname (SCM_ROCHARS (net)); + SCM_STRING_COERCE_0TERMINATION_X (net); + entry = getnetbyname (SCM_STRING_CHARS (net)); } else { @@ -403,10 +402,10 @@ SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0, return SCM_BOOL_F; } } - else if (SCM_ROSTRINGP (protocol)) + else if (SCM_STRINGP (protocol)) { - SCM_COERCE_SUBSTR (protocol); - entry = getprotobyname (SCM_ROCHARS (protocol)); + SCM_STRING_COERCE_0TERMINATION_X (protocol); + entry = getprotobyname (SCM_STRING_CHARS (protocol)); } else { @@ -468,17 +467,17 @@ SCM_DEFINE (scm_getserv, "getserv", 0, 2, 0, } return scm_return_entry (entry); } - SCM_VALIDATE_ROSTRING (2,protocol); - SCM_COERCE_SUBSTR (protocol); - if (SCM_ROSTRINGP (name)) + SCM_VALIDATE_STRING (2, protocol); + SCM_STRING_COERCE_0TERMINATION_X (protocol); + if (SCM_STRINGP (name)) { - SCM_COERCE_SUBSTR (name); - entry = getservbyname (SCM_ROCHARS (name), SCM_ROCHARS (protocol)); + SCM_STRING_COERCE_0TERMINATION_X (name); + entry = getservbyname (SCM_STRING_CHARS (name), SCM_STRING_CHARS (protocol)); } else { SCM_VALIDATE_INUM (1,name); - entry = getservbyport (htons (SCM_INUM (name)), SCM_ROCHARS (protocol)); + entry = getservbyport (htons (SCM_INUM (name)), SCM_STRING_CHARS (protocol)); } if (!entry) SCM_SYSERROR_MSG("no such service ~A", diff --git a/libguile/numbers.c b/libguile/numbers.c index 7e6a79281..a1491b8b7 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -2806,10 +2806,10 @@ SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0, { SCM answer; int base; - SCM_VALIDATE_ROSTRING (1,string); + SCM_VALIDATE_STRING (1, string); SCM_VALIDATE_INUM_MIN_DEF_COPY (2,radix,2,10,base); answer = scm_istring2number (SCM_ROCHARS (string), - SCM_ROLENGTH (string), + SCM_STRING_LENGTH (string), base); return scm_return_first (answer, string); } diff --git a/libguile/ports.c b/libguile/ports.c index 84df7e5d6..fe7ea9003 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1163,7 +1163,7 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, if (SCM_UNBNDP (length)) { /* must supply length if object is a filename. */ - if (SCM_ROSTRINGP (object)) + if (SCM_STRINGP (object)) SCM_MISC_ERROR("must supply length if OBJECT is a filename",SCM_EOL); length = scm_seek (object, SCM_INUM0, SCM_MAKINUM (SEEK_CUR)); @@ -1194,9 +1194,9 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, } else { - SCM_VALIDATE_ROSTRING (1,object); - SCM_COERCE_SUBSTR (object); - SCM_SYSCALL (rv = truncate (SCM_ROCHARS (object), c_length)); + SCM_VALIDATE_STRING (1, object); + SCM_STRING_COERCE_0TERMINATION_X (object); + SCM_SYSCALL (rv = truncate (SCM_STRING_CHARS (object), c_length)); } if (rv == -1) SCM_SYSERROR; @@ -1386,9 +1386,9 @@ SCM_DEFINE (scm_sys_make_void_port, "%make-void-port", 1, 0, 0, "documentation for @code{open-file} in @ref{File Ports}.") #define FUNC_NAME s_scm_sys_make_void_port { - SCM_VALIDATE_ROSTRING (1,mode); - SCM_COERCE_SUBSTR (mode); - return scm_void_port (SCM_ROCHARS (mode)); + SCM_VALIDATE_STRING (1, mode); + SCM_STRING_COERCE_0TERMINATION_X (mode); + return scm_void_port (SCM_STRING_CHARS (mode)); } #undef FUNC_NAME diff --git a/libguile/posix.c b/libguile/posix.c index 1782928a6..623ca2012 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -264,10 +264,9 @@ SCM_DEFINE (scm_getpwuid, "getpw", 0, 1, 0, } else { - SCM_VALIDATE_ROSTRING (1,user); - if (SCM_SUBSTRP (user)) - user = scm_makfromstr (SCM_ROCHARS (user), SCM_STRING_LENGTH (user), 0); - entry = getpwnam (SCM_ROCHARS (user)); + SCM_VALIDATE_STRING (1, user); + SCM_STRING_COERCE_0TERMINATION_X (user); + entry = getpwnam (SCM_STRING_CHARS (user)); } if (!entry) SCM_MISC_ERROR ("entry not found", SCM_EOL); @@ -334,9 +333,9 @@ SCM_DEFINE (scm_getgrgid, "getgr", 0, 1, 0, SCM_SYSCALL (entry = getgrgid (SCM_INUM (name))); else { - SCM_VALIDATE_ROSTRING (1,name); - SCM_COERCE_SUBSTR (name); - SCM_SYSCALL (entry = getgrnam (SCM_ROCHARS (name))); + SCM_VALIDATE_STRING (1, name); + SCM_STRING_COERCE_0TERMINATION_X (name); + SCM_SYSCALL (entry = getgrnam (SCM_STRING_CHARS (name))); } if (!entry) SCM_SYSERROR; @@ -802,35 +801,37 @@ SCM_DEFINE (scm_tcsetpgrp, "tcsetpgrp", 2, 0, 0, #undef FUNC_NAME #endif /* HAVE_TCSETPGRP */ -/* Copy exec args from an SCM vector into a new C array. */ +/* Create a new C argv array from a scheme list of strings. */ +/* Dirk:FIXME:: A quite similar function is implemented in dynl.c */ +/* Dirk:FIXME:: In case of assertion errors, we get memory leaks */ static char ** -scm_convert_exec_args (SCM args, int pos, const char *subr) +scm_convert_exec_args (SCM args, int argn, const char *subr) { - char **execargv; - int num_args; + char **argv; + int argc; int i; - num_args = scm_ilength (args); - SCM_ASSERT (num_args >= 0, args, pos, subr); - execargv = (char **) - scm_must_malloc ((num_args + 1) * sizeof (char *), subr); + argc = scm_ilength (args); + SCM_ASSERT (argc >= 0, args, argn, subr); + argv = (char **) scm_must_malloc ((argc + 1) * sizeof (char *), subr); for (i = 0; !SCM_NULLP (args); args = SCM_CDR (args), ++i) { + SCM arg = SCM_CAR (args); scm_sizet len; char *dst; char *src; - SCM_ASSERT (SCM_ROSTRINGP (SCM_CAR (args)), - SCM_CAR (args), SCM_ARGn, subr); - len = 1 + SCM_ROLENGTH (SCM_CAR (args)); - dst = (char *) scm_must_malloc ((long) len, subr); - src = SCM_ROCHARS (SCM_CAR (args)); - while (len--) - dst[len] = src[len]; - execargv[i] = dst; + + SCM_ASSERT (SCM_STRINGP (arg), args, argn, subr); + len = SCM_STRING_LENGTH (arg); + src = SCM_ROCHARS (arg); + dst = (char *) scm_must_malloc (len + 1, subr); + memcpy (dst, src, len); + dst[len] = 0; + argv[i] = dst; } - execargv[i] = 0; - return execargv; + argv[i] = 0; + return argv; } SCM_DEFINE (scm_execl, "execl", 1, 0, 1, @@ -847,10 +848,10 @@ SCM_DEFINE (scm_execl, "execl", 1, 0, 1, #define FUNC_NAME s_scm_execl { char **execargv; - SCM_VALIDATE_ROSTRING (1,filename); - SCM_COERCE_SUBSTR (filename); + SCM_VALIDATE_STRING (1, filename); + SCM_STRING_COERCE_0TERMINATION_X (filename); execargv = scm_convert_exec_args (args, SCM_ARG2, FUNC_NAME); - execv (SCM_ROCHARS (filename), execargv); + execv (SCM_STRING_CHARS (filename), execargv); SCM_SYSERROR; /* not reached. */ return SCM_BOOL_F; @@ -868,10 +869,10 @@ SCM_DEFINE (scm_execlp, "execlp", 1, 0, 1, #define FUNC_NAME s_scm_execlp { char **execargv; - SCM_VALIDATE_ROSTRING (1,filename); - SCM_COERCE_SUBSTR (filename); + SCM_VALIDATE_STRING (1, filename); + SCM_STRING_COERCE_0TERMINATION_X (filename); execargv = scm_convert_exec_args (args, SCM_ARG2, FUNC_NAME); - execvp (SCM_ROCHARS (filename), execargv); + execvp (SCM_STRING_CHARS (filename), execargv); SCM_SYSERROR; /* not reached. */ return SCM_BOOL_F; @@ -883,30 +884,27 @@ environ_list_to_c (SCM envlist, int arg, const char *proc) { int num_strings; char **result; - int i = 0; + int i; - SCM_ASSERT (SCM_NULLP (envlist) || SCM_CONSP (envlist), - envlist, arg, proc); num_strings = scm_ilength (envlist); + SCM_ASSERT (num_strings >= 0, envlist, arg, proc); result = (char **) malloc ((num_strings + 1) * sizeof (char *)); if (result == NULL) scm_memory_error (proc); - while (SCM_NNULLP (envlist)) + for (i = 0; !SCM_NULLP (envlist); ++i, envlist = SCM_CDR (envlist)) { + SCM str = SCM_CAR (envlist); int len; char *src; - SCM_ASSERT (SCM_ROSTRINGP (SCM_CAR (envlist)), - envlist, arg, proc); - len = 1 + SCM_ROLENGTH (SCM_CAR (envlist)); - result[i] = malloc ((long) len); + SCM_ASSERT (SCM_STRINGP (str), envlist, arg, proc); + len = SCM_STRING_LENGTH (str); + src = SCM_ROCHARS (str); + result[i] = malloc (len + 1); if (result[i] == NULL) scm_memory_error (proc); - src = SCM_ROCHARS (SCM_CAR (envlist)); - while (len--) - result[i][len] = src[len]; - envlist = SCM_CDR (envlist); - i++; + memcpy (result[i], src, len); + result[i][len] = 0; } result[i] = 0; return result; @@ -924,12 +922,12 @@ SCM_DEFINE (scm_execle, "execle", 2, 0, 1, char **execargv; char **exec_env; - SCM_VALIDATE_ROSTRING (1,filename); - SCM_COERCE_SUBSTR (filename); + SCM_VALIDATE_STRING (1, filename); + SCM_STRING_COERCE_0TERMINATION_X (filename); execargv = scm_convert_exec_args (args, SCM_ARG1, FUNC_NAME); exec_env = environ_list_to_c (env, SCM_ARG2, FUNC_NAME); - execve (SCM_ROCHARS (filename), execargv, exec_env); + execve (SCM_STRING_CHARS (filename), execargv, exec_env); SCM_SYSERROR; /* not reached. */ return SCM_BOOL_F; @@ -1052,8 +1050,8 @@ SCM_DEFINE (scm_utime, "utime", 1, 2, 0, int rv; struct utimbuf utm_tmp; - SCM_VALIDATE_ROSTRING (1,pathname); - SCM_COERCE_SUBSTR (pathname); + SCM_VALIDATE_STRING (1, pathname); + SCM_STRING_COERCE_0TERMINATION_X (pathname); if (SCM_UNBNDP (actime)) SCM_SYSCALL (time (&utm_tmp.actime)); else @@ -1064,7 +1062,7 @@ SCM_DEFINE (scm_utime, "utime", 1, 2, 0, else utm_tmp.modtime = SCM_NUM2ULONG (3,modtime); - SCM_SYSCALL (rv = utime (SCM_ROCHARS (pathname), &utm_tmp)); + SCM_SYSCALL (rv = utime (SCM_STRING_CHARS (pathname), &utm_tmp)); if (rv != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; @@ -1100,11 +1098,10 @@ SCM_DEFINE (scm_access, "access?", 2, 0, 0, { int rv; - SCM_VALIDATE_ROSTRING (1,path); - if (SCM_SUBSTRP (path)) - path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0); - SCM_VALIDATE_INUM (2,how); - rv = access (SCM_ROCHARS (path), SCM_INUM (how)); + SCM_VALIDATE_STRING (1, path); + SCM_STRING_COERCE_0TERMINATION_X (path); + SCM_VALIDATE_INUM (2, how); + rv = access (SCM_STRING_CHARS (path), SCM_INUM (how)); return SCM_NEGATE_BOOL(rv); } #undef FUNC_NAME @@ -1172,9 +1169,9 @@ SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0, } else { - SCM_VALIDATE_ROSTRING (2,locale); - SCM_COERCE_SUBSTR (locale); - clocale = SCM_ROCHARS (locale); + SCM_VALIDATE_STRING (2, locale); + SCM_STRING_COERCE_0TERMINATION_X (locale); + clocale = SCM_STRING_CHARS (locale); } rv = setlocale (SCM_INUM (category), clocale); @@ -1207,11 +1204,11 @@ SCM_DEFINE (scm_mknod, "mknod", 4, 0, 0, char *p; int ctype = 0; - SCM_VALIDATE_ROSTRING (1,path); + SCM_VALIDATE_STRING (1, path); SCM_VALIDATE_SYMBOL (2,type); SCM_VALIDATE_INUM (3,perms); SCM_VALIDATE_INUM (4,dev); - SCM_COERCE_SUBSTR (path); + SCM_STRING_COERCE_0TERMINATION_X (path); p = SCM_SYMBOL_CHARS (type); if (strcmp (p, "regular") == 0) @@ -1233,8 +1230,8 @@ SCM_DEFINE (scm_mknod, "mknod", 4, 0, 0, else SCM_OUT_OF_RANGE (2,type); - SCM_SYSCALL (val = mknod(SCM_ROCHARS(path), ctype | SCM_INUM (perms), - SCM_INUM (dev))); + SCM_SYSCALL (val = mknod (SCM_STRING_CHARS (path), ctype | SCM_INUM (perms), + SCM_INUM (dev))); if (val != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index d706bd6ba..9c79e23c5 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -184,9 +184,9 @@ SCM_DEFINE (scm_make_regexp, "make-regexp", 1, 0, 1, regex_t *rx; int status, cflags; - SCM_VALIDATE_ROSTRING (1,pat); + SCM_VALIDATE_STRING (1, pat); SCM_VALIDATE_REST_ARGUMENT (flags); - SCM_COERCE_SUBSTR (pat); + SCM_STRING_COERCE_0TERMINATION_X (pat); /* Examine list of regexp flags. If REG_BASIC is supplied, then turn off REG_EXTENDED flag (on by default). */ @@ -202,7 +202,7 @@ SCM_DEFINE (scm_make_regexp, "make-regexp", 1, 0, 1, } rx = SCM_MUST_MALLOC_TYPE (regex_t); - status = regcomp (rx, SCM_ROCHARS (pat), + status = regcomp (rx, SCM_STRING_CHARS (pat), /* Make sure they're not passing REG_NOSUB; regexp-exec assumes we're getting match data. */ cflags & ~REG_NOSUB); @@ -232,13 +232,13 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, SCM mvec = SCM_BOOL_F; SCM_VALIDATE_RGXP (1,rx); - SCM_VALIDATE_STRING (2,str); + SCM_VALIDATE_STRING (2, str); SCM_VALIDATE_INUM_DEF_COPY (3,start,0,offset); SCM_ASSERT_RANGE (3,start, offset >= 0 && offset <= SCM_STRING_LENGTH (str)); if (SCM_UNBNDP (flags)) flags = SCM_INUM0; SCM_VALIDATE_INUM (4,flags); - SCM_COERCE_SUBSTR (str); + SCM_STRING_COERCE_0TERMINATION_X (str); /* re_nsub doesn't account for the `subexpression' representing the whole regexp, so add 1 to nmatches. */ @@ -246,7 +246,7 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, nmatches = SCM_RGX(rx)->re_nsub + 1; SCM_DEFER_INTS; matches = SCM_MUST_MALLOC_TYPE_NUM (regmatch_t,nmatches); - status = regexec (SCM_RGX (rx), SCM_ROCHARS (str) + offset, + status = regexec (SCM_RGX (rx), SCM_STRING_CHARS (str) + offset, nmatches, matches, SCM_INUM (flags)); if (!status) diff --git a/libguile/simpos.c b/libguile/simpos.c index f8f1ab940..d21c81d7e 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -82,12 +82,11 @@ SCM_DEFINE (scm_system, "system", 0, 1, 0, rv = system (NULL); return SCM_BOOL(rv); } - SCM_VALIDATE_ROSTRING (1,cmd); + SCM_VALIDATE_STRING (1, cmd); SCM_DEFER_INTS; errno = 0; - if (SCM_SUBSTRP (cmd)) - cmd = scm_makfromstr (SCM_ROCHARS (cmd), SCM_STRING_LENGTH (cmd), 0); - rv = system(SCM_ROCHARS(cmd)); + SCM_STRING_COERCE_0TERMINATION_X (cmd); + rv = system (SCM_STRING_CHARS (cmd)); if (rv == -1 || (rv == 127 && errno != 0)) SCM_SYSERROR; SCM_ALLOW_INTS; @@ -105,8 +104,8 @@ SCM_DEFINE (scm_getenv, "getenv", 1, 0, 0, #define FUNC_NAME s_scm_getenv { char *val; - SCM_VALIDATE_ROSTRING (1,nam); - nam = scm_makfromstr (SCM_ROCHARS (nam), SCM_ROLENGTH (nam), 0); + SCM_VALIDATE_STRING (1, nam); + SCM_STRING_COERCE_0TERMINATION_X (nam); val = getenv (SCM_STRING_CHARS (nam)); return (val) ? scm_makfromstr(val, (scm_sizet)strlen(val), 0) : SCM_BOOL_F; } diff --git a/libguile/socket.c b/libguile/socket.c index 0a7f2937f..ae799d963 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -430,10 +430,9 @@ scm_fill_sockaddr (int fam,SCM address,SCM *args,int which_arg,const char *proc, scm_must_malloc (sizeof (struct sockaddr_un), proc); memset (soka, 0, sizeof (struct sockaddr_un)); soka->sun_family = AF_UNIX; - SCM_ASSERT (SCM_ROSTRINGP (address), address, - which_arg, proc); + SCM_ASSERT (SCM_STRINGP (address), address, which_arg, proc); memcpy (soka->sun_path, SCM_ROCHARS (address), - 1 + SCM_ROLENGTH (address)); + 1 + SCM_STRING_LENGTH (address)); *size = sizeof (struct sockaddr_un); return (struct sockaddr *) soka; } @@ -735,11 +734,11 @@ SCM_DEFINE (scm_send, "send", 2, 1, 0, sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1,sock); - SCM_VALIDATE_ROSTRING (2,message); + SCM_VALIDATE_STRING (2, message); SCM_VALIDATE_INUM_DEF_COPY (3,flags,0,flg); fd = SCM_FPORT_FDES (sock); - SCM_SYSCALL (rv = send (fd, SCM_ROCHARS (message), SCM_ROLENGTH (message), flg)); + SCM_SYSCALL (rv = send (fd, SCM_ROCHARS (message), SCM_STRING_LENGTH (message), flg)); if (rv == -1) SCM_SYSERROR; return SCM_MAKINUM (rv); @@ -845,7 +844,7 @@ SCM_DEFINE (scm_sendto, "sendto", 4, 0, 1, sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_FPORT (1,sock); - SCM_VALIDATE_ROSTRING (2,message); + SCM_VALIDATE_STRING (2, message); SCM_VALIDATE_INUM (3,fam); fd = SCM_FPORT_FDES (sock); soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args_and_flags, 4, @@ -857,7 +856,7 @@ SCM_DEFINE (scm_sendto, "sendto", 4, 0, 1, SCM_VALIDATE_CONS (5,args_and_flags); flg = SCM_NUM2ULONG (5,SCM_CAR (args_and_flags)); } - SCM_SYSCALL (rv = sendto (fd, SCM_ROCHARS (message), SCM_ROLENGTH (message), + SCM_SYSCALL (rv = sendto (fd, SCM_ROCHARS (message), SCM_STRING_LENGTH (message), flg, soka, size)); save_err = errno; scm_must_free ((char *) soka); diff --git a/libguile/stime.c b/libguile/stime.c index 6e99a008c..19c428dec 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -307,9 +307,9 @@ setzone (SCM zone, int pos, const char *subr) char *buf; SCM_ASSERT (SCM_STRINGP (zone), zone, pos, subr); - SCM_COERCE_SUBSTR (zone); + SCM_STRING_COERCE_0TERMINATION_X (zone); buf = scm_must_malloc (SCM_STRING_LENGTH (zone) + sizeof (tzvar) + 1, subr); - sprintf (buf, "%s=%s", tzvar, SCM_ROCHARS (zone)); + sprintf (buf, "%s=%s", tzvar, SCM_STRING_CHARS (zone)); oldenv = environ; tmpenv[0] = buf; tmpenv[1] = 0; @@ -573,12 +573,12 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, int len; SCM result; - SCM_VALIDATE_ROSTRING (1,format); + SCM_VALIDATE_STRING (1, format); bdtime2c (stime, &t, SCM_ARG2, FUNC_NAME); - SCM_COERCE_SUBSTR (format); - fmt = SCM_ROCHARS (format); - len = SCM_ROLENGTH (format); + SCM_STRING_COERCE_0TERMINATION_X (format); + fmt = SCM_STRING_CHARS (format); + len = SCM_STRING_LENGTH (format); /* Ugly hack: strftime can return 0 if its buffer is too small, but some valid time strings (e.g. "%p") can sometimes produce @@ -666,13 +666,13 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, struct tm t; char *fmt, *str, *rest; - SCM_VALIDATE_ROSTRING (1,format); - SCM_VALIDATE_ROSTRING (2,string); + SCM_VALIDATE_STRING (1, format); + SCM_VALIDATE_STRING (2, string); - SCM_COERCE_SUBSTR (format); - SCM_COERCE_SUBSTR (string); - fmt = SCM_ROCHARS (format); - str = SCM_ROCHARS (string); + SCM_STRING_COERCE_0TERMINATION_X (format); + SCM_STRING_COERCE_0TERMINATION_X (string); + fmt = SCM_STRING_CHARS (format); + str = SCM_STRING_CHARS (string); /* initialize the struct tm */ #define tm_init(field) t.field = 0 diff --git a/libguile/strop.c b/libguile/strop.c index cc8b53933..1ecf4258c 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -61,7 +61,7 @@ scm_i_index (SCM *str, SCM chr, int direction, SCM sub_start, int upper; int ch; - SCM_ASSERT (SCM_ROSTRINGP (*str), *str, SCM_ARG1, why); + SCM_ASSERT (SCM_STRINGP (*str), *str, SCM_ARG1, why); SCM_ASSERT (SCM_CHARP (chr), chr, SCM_ARG2, why); if (SCM_FALSEP (sub_start)) @@ -69,17 +69,15 @@ scm_i_index (SCM *str, SCM chr, int direction, SCM sub_start, SCM_ASSERT (SCM_INUMP (sub_start), sub_start, SCM_ARG3, why); lower = SCM_INUM (sub_start); - if (lower < 0 - || lower > SCM_ROLENGTH (*str)) + if (lower < 0 || lower > SCM_STRING_LENGTH (*str)) scm_out_of_range (why, sub_start); if (SCM_FALSEP (sub_end)) - sub_end = SCM_MAKINUM (SCM_ROLENGTH (*str)); + sub_end = SCM_MAKINUM (SCM_STRING_LENGTH (*str)); SCM_ASSERT (SCM_INUMP (sub_end), sub_end, SCM_ARG4, why); upper = SCM_INUM (sub_end); - if (upper < SCM_INUM (sub_start) - || upper > SCM_ROLENGTH (*str)) + if (upper < SCM_INUM (sub_start) || upper > SCM_STRING_LENGTH (*str)) scm_out_of_range (why, sub_end); if (direction > 0) @@ -309,8 +307,8 @@ SCM_DEFINE (scm_string_null_p, "string-null?", 1, 0, 0, "@end example") #define FUNC_NAME s_scm_string_null_p { - SCM_VALIDATE_ROSTRING (1,str); - return SCM_NEGATE_BOOL(SCM_ROLENGTH (str)); + SCM_VALIDATE_STRING (1,str); + return SCM_NEGATE_BOOL (SCM_STRING_LENGTH (str)); } #undef FUNC_NAME @@ -328,9 +326,9 @@ SCM_DEFINE (scm_string_to_list, "string->list", 1, 0, 0, long i; SCM res = SCM_EOL; unsigned char *src; - SCM_VALIDATE_ROSTRING (1,str); + SCM_VALIDATE_STRING (1,str); src = SCM_ROUCHARS (str); - for (i = SCM_ROLENGTH (str)-1;i >= 0;i--) res = scm_cons (SCM_MAKE_CHAR (src[i]), res); + for (i = SCM_STRING_LENGTH (str)-1;i >= 0;i--) res = scm_cons (SCM_MAKE_CHAR (src[i]), res); return res; } #undef FUNC_NAME diff --git a/libguile/strports.c b/libguile/strports.c index 274008684..8717e9843 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -270,8 +270,8 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) int str_len; SCM_ASSERT (SCM_INUMP(pos) && SCM_INUM(pos) >= 0, pos, SCM_ARG1, caller); - SCM_ASSERT (SCM_ROSTRINGP(str), str, SCM_ARG1, caller); - str_len = SCM_ROLENGTH (str); + SCM_ASSERT (SCM_STRINGP (str), str, SCM_ARG1, caller); + str_len = SCM_STRING_LENGTH (str); if (SCM_INUM (pos) > str_len) scm_out_of_range (caller, pos); if (!((modes & SCM_WRTNG) || (modes & SCM_RDNG))) diff --git a/libguile/symbols.c b/libguile/symbols.c index 65679fe8a..56a4cd9ca 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -524,7 +524,7 @@ SCM_DEFINE (scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, SCM answer; int softness; - SCM_VALIDATE_ROSTRING (2,s); + SCM_VALIDATE_STRING (2, s); SCM_ASSERT (SCM_BOOLP (o) || SCM_VECTORP (o), o, SCM_ARG1, FUNC_NAME); softness = (!SCM_UNBNDP (softp) && !SCM_FALSEP(softp)); @@ -535,7 +535,7 @@ SCM_DEFINE (scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, o = SCM_BOOL_F; vcell = scm_intern_obarray_soft (SCM_ROCHARS(s), - (scm_sizet)SCM_ROLENGTH(s), + SCM_STRING_LENGTH (s), o, softness); if (SCM_FALSEP (vcell)) diff --git a/libguile/symbols.h b/libguile/symbols.h index 3331bd63c..e742f18b5 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -62,7 +62,6 @@ extern int scm_symhash_dim; #define SCM_SYMBOL_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_LENGTH_MAX (0xffffffL) -#define SCM_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_SETLENGTH(x, v, t) (SCM_SET_CELL_WORD_0 ((x), ((v) << 8) + (t))) #define SCM_SETCHARS(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_bits_t) (v))) @@ -88,14 +87,6 @@ extern int scm_symhash_dim; : ((SCM_TYP7 (x) == scm_tc7_string) \ ? SCM_STRING_UCHARS (x) \ : SCM_SYMBOL_UCHARS (x))) -#define SCM_ROLENGTH(x) SCM_LENGTH (x) -#define SCM_SUBSTRP(x) (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_substring)) -#define SCM_SUBSTR_STR(x) (SCM_CDDR (x)) -#define SCM_SUBSTR_OFFSET(x) (SCM_CADR (x)) - -#define SCM_COERCE_SUBSTR(x) { if (SCM_SUBSTRP (x)) \ - x = scm_makfromstr (SCM_ROCHARS (x), \ - SCM_STRING_LENGTH (x), 0); } @@ -139,6 +130,12 @@ extern void scm_init_symbols (void); #define SCM_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) #define SCM_UCHARS(x) ((unsigned char *) (SCM_CELL_WORD_1 (x))) #define SCM_SLOPPY_SUBSTRP(x) (SCM_SUBSTRP (x)) +#define SCM_SUBSTR_STR(x) (SCM_CDDR (x)) +#define SCM_SUBSTR_OFFSET(x) (SCM_CADR (x)) +#define SCM_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) +#define SCM_ROLENGTH(x) SCM_LENGTH (x) +#define SCM_SUBSTRP(x) (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_substring)) +#define SCM_COERCE_SUBSTR(x) SCM_STRING_COERCE_0TERMINATION_X (x) #define scm_strhash(str, len, n) (scm_string_hash ((str), (len)) % (n)) #endif /* SCM_DEBUG_DEPRECATED == 0 */ diff --git a/libguile/unif.h b/libguile/unif.h index 5fce7b467..932ceec82 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -93,14 +93,6 @@ extern long scm_tc16_array; #define SCM_BITVECTOR_BASE(x) ((void *) (SCM_CELL_WORD_1 (x))) #define SCM_BITVECTOR_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) -/* apparently it's possible to have more than SCM_LENGTH_MAX elements - in an array: if the length is SCM_LENGTH_MAX then the SCM_VELTS - block begins with the true length (a long int). I wonder if it - works. */ - -#define SCM_HUGE_LENGTH(x)\ - (SCM_LENGTH_MAX==SCM_LENGTH(x) ? *((long *)SCM_VELTS(x)) : SCM_LENGTH(x)) - extern scm_sizet scm_uniform_element_size (SCM obj); @@ -140,6 +132,19 @@ extern int scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate); extern SCM scm_array_prototype (SCM ra); extern void scm_init_unif (void); + + +#if (SCM_DEBUG_DEPRECATED == 0) + +/* apparently it's possible to have more than SCM_LENGTH_MAX elements + in an array: if the length is SCM_LENGTH_MAX then the SCM_VELTS + block begins with the true length (a long int). I wonder if it + works. */ +#define SCM_HUGE_LENGTH(x)\ + (SCM_LENGTH_MAX==SCM_LENGTH(x) ? *((long *)SCM_VELTS(x)) : SCM_LENGTH(x)) + +#endif /* SCM_DEBUG_DEPRECATED == 0 */ + #endif /* UNIFH */ /* diff --git a/libguile/validate.h b/libguile/validate.h index 4115c8200..e80f5708a 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -1,4 +1,4 @@ -/* $Id: validate.h,v 1.18 2000-10-25 11:01:03 dirk Exp $ */ +/* $Id: validate.h,v 1.19 2000-10-30 11:42:26 dirk Exp $ */ /* Copyright (C) 1999, 2000 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify @@ -124,24 +124,6 @@ cvar = SCM_CHAR (scm); \ } while (0) -#define SCM_VALIDATE_ROSTRING(pos, str) SCM_MAKE_VALIDATE (pos, str, ROSTRINGP) - -#define SCM_VALIDATE_ROSTRING_COPY(pos, str, cvar) \ - do { \ - SCM_ASSERT (SCM_ROSTRINGP (str), str, pos, FUNC_NAME); \ - cvar = SCM_ROCHARS (str); \ - } while (0) - -#define SCM_VALIDATE_NULLORROSTRING_COPY(pos, str, cvar) \ - do { \ - SCM_ASSERT (SCM_FALSEP (str) || SCM_ROSTRINGP (str), \ - str, pos, FUNC_NAME); \ - if (SCM_FALSEP(str)) \ - cvar = NULL; \ - else \ - cvar = SCM_ROCHARS(str); \ - } while (0) - #define SCM_VALIDATE_STRING(pos, str) SCM_MAKE_VALIDATE (pos, str, STRINGP) #define SCM_VALIDATE_STRING_COPY(pos, str, cvar) \ @@ -416,6 +398,24 @@ #define SCM_VALIDATE_STRINGORSUBSTR SCM_VALIDATE_STRING +#define SCM_VALIDATE_ROSTRING(pos, str) SCM_MAKE_VALIDATE (pos, str, ROSTRINGP) + +#define SCM_VALIDATE_ROSTRING_COPY(pos, str, cvar) \ + do { \ + SCM_ASSERT (SCM_ROSTRINGP (str), str, pos, FUNC_NAME); \ + cvar = SCM_ROCHARS (str); \ + } while (0) + +#define SCM_VALIDATE_NULLORROSTRING_COPY(pos, str, cvar) \ + do { \ + SCM_ASSERT (SCM_FALSEP (str) || SCM_ROSTRINGP (str), \ + str, pos, FUNC_NAME); \ + if (SCM_FALSEP(str)) \ + cvar = NULL; \ + else \ + cvar = SCM_ROCHARS(str); \ + } while (0) + #endif /* SCM_DEBUG_DEPRECATED == 0 */ #endif diff --git a/libguile/vports.c b/libguile/vports.c index d36888606..877da5c40 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -182,13 +182,13 @@ SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0, scm_port *pt; SCM z; SCM_VALIDATE_VECTOR_LEN (1,pv,5); - SCM_VALIDATE_ROSTRING (2,modes); - SCM_COERCE_SUBSTR (modes); + SCM_VALIDATE_STRING (2, modes); + SCM_STRING_COERCE_0TERMINATION_X (modes); SCM_NEWCELL (z); SCM_DEFER_INTS; pt = scm_add_to_port_table (z); scm_port_non_buffer (pt); - SCM_SET_CELL_TYPE (z, scm_tc16_sfport | scm_mode_bits (SCM_ROCHARS (modes))); + SCM_SET_CELL_TYPE (z, scm_tc16_sfport | scm_mode_bits (SCM_STRING_CHARS (modes))); SCM_SETPTAB_ENTRY (z, pt); SCM_SETSTREAM (z, SCM_UNPACK (pv)); SCM_ALLOW_INTS; From b3b8952a94399329370a2da09f27684528c096ab Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 30 Oct 2000 17:32:55 +0000 Subject: [PATCH 0344/2047] =?UTF-8?q?*=20Reflect=20the=20fact=20that=20str?= =?UTF-8?q?ing=3D=3F=20is=20fixed=20in=20the=20test-suite.?= --- test-suite/ChangeLog | 4 ++++ test-suite/tests/strings.test | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 6e58b99e5..c1b395a9a 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2000-10-30 Dirk Herrmann + + * tests/strings.test: string=? is fixed. + 2000-10-13 Dirk Herrmann * tests/list.test: Removed references to sloppy-mem(q|v|ber) diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test index 9305128f8..ffd3fab35 100644 --- a/test-suite/tests/strings.test +++ b/test-suite/tests/strings.test @@ -21,7 +21,7 @@ (use-modules (test-suite lib)) -(expect-fail "string=? does not accept symbols" +(pass-if "string=? does not accept symbols" (catch 'wrong-type-arg (lambda () (string=? 'a 'b) From a3a329390f25cf1ea73f639a7967f7eb0b3a3d8f Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 30 Oct 2000 17:47:52 +0000 Subject: [PATCH 0345/2047] * Remove the code that implemented the SCM_HUGE_LENGTH trick. --- libguile/ChangeLog | 18 ++++++++++ libguile/unif.c | 89 +++++++++++++++++----------------------------- 2 files changed, 50 insertions(+), 57 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d2b0d79b1..ebe55bab4 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,21 @@ +2000-10-30 Dirk Herrmann + + * unif.c (scm_make_uve, scm_dimensions_to_uniform_array): Don't + allow vectors longer than SCM_LENGTH_MAX. This removes the + SCM_HUGE_LENGTH trick, i. e. storing a vector length greater than + SCM_LENGTH_MAX at the beginning of the vector's memory. Since not + all of guile's code was implemented to be aware of this trick, it + is unlikely that it was used anyway. We can implement such a + feature more cleanly by using double cells for uniform vector + types. + + (scm_shap2ra): Replace SCM_IMP and SCM_NIMP tests by more + straightforward predicates. + + (scm_dimensions_to_uniform_array): Require that for dimensions + given as lower-bound/upper-bound pairs the upper-bound is never + less than the lower bound. + 2000-10-27 Dirk Herrmann * dynl.c (scm_dynamic_link, scm_dynamic_func, scm_dynamic_call, diff --git a/libguile/unif.c b/libguile/unif.c index 444bec62c..6d9fc67e7 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -153,9 +153,13 @@ singp (SCM obj) SCM scm_make_uve (long k, SCM prot) +#define FUNC_NAME "scm_make_uve" { SCM v; long i, type; + + SCM_ASSERT_RANGE (1, scm_long2num (k), k <= SCM_LENGTH_MAX); + if (SCM_EQ_P (prot, SCM_BOOL_T)) { i = sizeof (long) * ((k + SCM_LONG_BIT - 1) / SCM_LONG_BIT); @@ -225,10 +229,12 @@ scm_make_uve (long k, SCM prot) SCM_NEWCELL (v); SCM_DEFER_INTS; SCM_SETCHARS (v, (char *) scm_must_malloc (i ? i : 1, "vector")); - SCM_SETLENGTH (v, (k < SCM_LENGTH_MAX ? k : SCM_LENGTH_MAX), type); + SCM_SETLENGTH (v, k, type); SCM_ALLOW_INTS; return v; } +#undef FUNC_NAME + SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0, (SCM v), @@ -523,14 +529,12 @@ scm_shap2ra (SCM args, const char *what) ra = scm_make_ra (ndim); SCM_ARRAY_BASE (ra) = 0; s = SCM_ARRAY_DIMS (ra); - for (; SCM_NIMP (args); s++, args = SCM_CDR (args)) + for (; !SCM_NULLP (args); s++, args = SCM_CDR (args)) { spec = SCM_CAR (args); - if (SCM_IMP (spec)) - + if (SCM_INUMP (spec)) { - SCM_ASSERT (SCM_INUMP (spec) && SCM_INUM (spec) >= 0, spec, - s_bad_spec, what); + SCM_ASSERT (SCM_INUM (spec) >= 0, spec, s_bad_spec, what); s->lbnd = 0; s->ubnd = SCM_INUM (spec) - 1; s->inc = 1; @@ -560,26 +564,24 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, "@var{prototype} is used.") #define FUNC_NAME s_scm_dimensions_to_uniform_array { - scm_sizet k, vlen = 1; - long rlen = 1; + scm_sizet k; + unsigned long int rlen = 1; scm_array_dim *s; SCM ra; if (SCM_INUMP (dims)) { - if (SCM_INUM (dims) < SCM_LENGTH_MAX) - { - SCM answer = scm_make_uve (SCM_INUM (dims), prot); + SCM answer; - if (!SCM_UNBNDP (fill)) - scm_array_fill_x (answer, fill); - else if (SCM_SYMBOLP (prot)) - scm_array_fill_x (answer, SCM_MAKINUM (0)); - else - scm_array_fill_x (answer, prot); - return answer; - } - else - dims = scm_cons (dims, SCM_EOL); + SCM_ASSERT_RANGE (1, dims, SCM_INUM (dims) <= SCM_LENGTH_MAX); + + answer = scm_make_uve (SCM_INUM (dims), prot); + if (!SCM_UNBNDP (fill)) + scm_array_fill_x (answer, fill); + else if (SCM_SYMBOLP (prot)) + scm_array_fill_x (answer, SCM_MAKINUM (0)); + else + scm_array_fill_x (answer, prot); + return answer; } SCM_ASSERT (SCM_NULLP (dims) || SCM_CONSP (dims), dims, SCM_ARG1, FUNC_NAME); @@ -589,49 +591,22 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, k = SCM_ARRAY_NDIM (ra); while (k--) { - s[k].inc = (rlen > 0 ? rlen : 0); + s[k].inc = rlen; + SCM_ASSERT_RANGE (1, dims, s[k].lbnd <= s[k].ubnd); rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc; - vlen *= (s[k].ubnd - s[k].lbnd + 1); - } - if (rlen < SCM_LENGTH_MAX) - SCM_ARRAY_V (ra) = scm_make_uve ((rlen > 0 ? rlen : 0L), prot); - else - { - scm_sizet bit; - switch (SCM_TYP7 (scm_make_uve (0L, prot))) - { - default: - bit = SCM_LONG_BIT; - break; - case scm_tc7_bvect: - bit = 1; - break; - case scm_tc7_string: - bit = SCM_CHAR_BIT; - break; - case scm_tc7_fvect: - bit = sizeof (float) * SCM_CHAR_BIT / sizeof (char); - break; - case scm_tc7_dvect: - bit = sizeof (double) * SCM_CHAR_BIT / sizeof (char); - break; - case scm_tc7_cvect: - bit = 2 * sizeof (double) * SCM_CHAR_BIT / sizeof (char); - break; - } - SCM_ARRAY_BASE (ra) = (SCM_LONG_BIT + bit - 1) / bit; - rlen += SCM_ARRAY_BASE (ra); - SCM_ARRAY_V (ra) = scm_make_uve (rlen, prot); - *((long *) SCM_VELTS (SCM_ARRAY_V (ra))) = rlen; } + + SCM_ASSERT_RANGE (1, dims, rlen <= SCM_LENGTH_MAX); + + SCM_ARRAY_V (ra) = scm_make_uve (rlen, prot); + if (!SCM_UNBNDP (fill)) - { - scm_array_fill_x (ra, fill); - } + scm_array_fill_x (ra, fill); else if (SCM_SYMBOLP (prot)) scm_array_fill_x (ra, SCM_MAKINUM (0)); else scm_array_fill_x (ra, prot); + if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra)) if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc)) return SCM_ARRAY_V (ra); From f304437e707be319ab93f062b02c66d61a4e578c Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 1 Nov 2000 09:37:30 +0000 Subject: [PATCH 0346/2047] =?UTF-8?q?*=20string=3D=3F=20requires=20a=20str?= =?UTF-8?q?ing=20argument.=20=20Thanks=20to=20Dale=20P.=20Smith.?= --- ice-9/ChangeLog | 5 +++++ ice-9/syncase.scm | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 8a67766ab..76deabca7 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2000-10-10 Dirk Herrmann + + * syncase.scm (eval): string=? requires a string argument. + Thanks to Dale P. Smith for the patch. + 2000-10-15 Neil Jerram * optargs.scm: Fix typos in commentary for bound? and lambda*. diff --git a/ice-9/syncase.scm b/ice-9/syncase.scm index 4a5e61b97..0074285a6 100644 --- a/ice-9/syncase.scm +++ b/ice-9/syncase.scm @@ -155,7 +155,7 @@ (define-public (eval x environment) (internal-eval (if (and (pair? x) - (string=? (car x) "noexpand")) + (equal? (car x) "noexpand")) (cadr x) (sc-expand x)) environment)) From 709a308dfc4065e1d8c660d1e22a08b2d95e3624 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 1 Nov 2000 16:13:38 +0000 Subject: [PATCH 0347/2047] * Fix output. Thanks to I. N. Golubev for the patch. --- THANKS | 1 + guile-config/ChangeLog | 5 +++++ guile-config/guile-config.in | 2 +- 3 files changed, 7 insertions(+), 1 deletion(-) diff --git a/THANKS b/THANKS index d49924da2..4859f06ca 100644 --- a/THANKS +++ b/THANKS @@ -13,6 +13,7 @@ Contributors since the last release: For fixes or providing information which led to a fix: Ian Bicking + I. N. Golubev Brad Knotwell Matthias Köppe Bruce Korb diff --git a/guile-config/ChangeLog b/guile-config/ChangeLog index cfe3233f7..144576ceb 100644 --- a/guile-config/ChangeLog +++ b/guile-config/ChangeLog @@ -1,3 +1,8 @@ +2000-11-01 Dirk Herrmann + + * guile-config.in (display-line-port): Make sure all output is + sent to the given port. Thanks to I. N. Golubev for the patch. + 2000-01-12 Marius Vollmer * Makefile.am (EXTRA_DIST): Added "guile.m4". diff --git a/guile-config/guile-config.in b/guile-config/guile-config.in index 3705a9082..bf55768d5 100644 --- a/guile-config/guile-config.in +++ b/guile-config/guile-config.in @@ -255,7 +255,7 @@ (define (display-line-port port . args) (for-each (lambda (arg) (display arg port)) args) - (newline)) + (newline port)) (define (display-separated args) (let loop ((args args)) From 0f87853a56fbd749f7b42ee9a3ed56c7d4d001c0 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 1 Nov 2000 16:59:45 +0000 Subject: [PATCH 0348/2047] * Don't recompute symbol hash values. The symbol holds them already. * Speed up interning of symbols by comparing hash values. --- libguile/ChangeLog | 9 +++++++++ libguile/symbols.c | 12 ++++++------ 2 files changed, 15 insertions(+), 6 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index ebe55bab4..b16dbb77e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2000-11-01 Dirk Herrmann + + * symbols.c (scm_sym2vcell, scm_sym2ovcell_soft, + scm_intern_symbol, scm_unintern_symbol): Symbol objects already + hold their hash values, no need to recompute them. + + (scm_intern_obarray_soft): Speed up search for a matching symbol + by comparing the hash values first. + 2000-10-30 Dirk Herrmann * unif.c (scm_make_uve, scm_dimensions_to_uniform_array): Don't diff --git a/libguile/symbols.c b/libguile/symbols.c index 56a4cd9ca..9dd80dd87 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -143,8 +143,7 @@ scm_sym2vcell (SCM sym, SCM thunk, SCM definep) SCM lsym; SCM * lsymp; SCM z; - scm_sizet hash - = scm_string_hash (SCM_SYMBOL_UCHARS (sym), SCM_SYMBOL_LENGTH (sym)) % scm_symhash_dim; + scm_sizet hash = SCM_SYMBOL_HASH (sym) % scm_symhash_dim; SCM_DEFER_INTS; for (lsym = SCM_VELTS (scm_symhash)[hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) @@ -188,8 +187,7 @@ SCM scm_sym2ovcell_soft (SCM sym, SCM obarray) { SCM lsym, z; - scm_sizet hash - = scm_string_hash (SCM_SYMBOL_UCHARS (sym), SCM_SYMBOL_LENGTH (sym)) % SCM_VECTOR_LENGTH (obarray); + scm_sizet hash = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (obarray); SCM_REDEFER_INTS; for (lsym = SCM_VELTS (obarray)[hash]; SCM_NIMP (lsym); @@ -265,6 +263,8 @@ scm_intern_obarray_soft (const char *name,scm_sizet len,SCM obarray,unsigned int SCM a = SCM_CAR (lsym); SCM z = SCM_CAR (a); unsigned char *tmp = SCM_SYMBOL_UCHARS (z); + if (SCM_SYMBOL_HASH (z) != raw_hash) + goto trynext; if (SCM_SYMBOL_LENGTH (z) != len) goto trynext; for (i = len; i--;) @@ -557,7 +557,7 @@ SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0, if (SCM_FALSEP (o)) o = scm_symhash; SCM_VALIDATE_VECTOR (1,o); - hval = scm_string_hash (SCM_SYMBOL_UCHARS (s), SCM_SYMBOL_LENGTH (s)) % SCM_VECTOR_LENGTH (o); + hval = SCM_SYMBOL_HASH (s) % SCM_VECTOR_LENGTH (o); /* If the symbol is already interned, simply return. */ SCM_REDEFER_INTS; { @@ -594,7 +594,7 @@ SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0, if (SCM_FALSEP (o)) o = scm_symhash; SCM_VALIDATE_VECTOR (1,o); - hval = scm_string_hash (SCM_SYMBOL_UCHARS (s), SCM_SYMBOL_LENGTH (s)) % SCM_VECTOR_LENGTH (o); + hval = SCM_SYMBOL_HASH (s) % SCM_VECTOR_LENGTH (o); SCM_DEFER_INTS; { SCM lsym_follow; From 66460dfba3bbce33320df9d44652c47d545b4332 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 1 Nov 2000 17:55:41 +0000 Subject: [PATCH 0349/2047] * environments.c: Don't use '==' to compare SCM objects. * posix.c (scm_getgroups): Don't create a redundant string object. --- libguile/ChangeLog | 7 +++++++ libguile/environments.c | 6 +++--- libguile/posix.c | 46 ++++++++++++++++++----------------------- 3 files changed, 30 insertions(+), 29 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b16dbb77e..373e4b3a1 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2000-11-01 Dirk Herrmann + + * environments.c (obarray_replace, obarray_retrieve, + obarray_remove): Don't use '==' to compare SCM objects. + + * posix.c (scm_getgroups): Don't create a redundant string. + 2000-11-01 Dirk Herrmann * symbols.c (scm_sym2vcell, scm_sym2ovcell_soft, diff --git a/libguile/environments.c b/libguile/environments.c index cb366f0fb..ced455be7 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -545,7 +545,7 @@ obarray_replace (SCM obarray, SCM symbol, SCM data) for (lsym = SCM_VELTS (obarray)[hash]; !SCM_NULLP (lsym); lsym = SCM_CDR (lsym)) { SCM old_entry = SCM_CAR (lsym); - if (SCM_CAR (old_entry) == symbol) + if (SCM_EQ_P (SCM_CAR (old_entry), symbol)) { SCM_SETCAR (lsym, new_entry); return old_entry; @@ -571,7 +571,7 @@ obarray_retrieve (SCM obarray, SCM sym) for (lsym = SCM_VELTS (obarray)[hash]; !SCM_NULLP (lsym); lsym = SCM_CDR (lsym)) { SCM entry = SCM_CAR (lsym); - if (SCM_CAR (entry) == sym) + if (SCM_EQ_P (SCM_CAR (entry), sym)) return entry; } @@ -596,7 +596,7 @@ obarray_remove (SCM obarray, SCM sym) lsym = *(lsymp = SCM_CDRLOC (lsym))) { SCM entry = SCM_CAR (lsym); - if (SCM_CAR (entry) == sym) + if (SCM_EQ_P (SCM_CAR (entry), sym)) { *lsymp = SCM_CDR (lsym); return entry; diff --git a/libguile/posix.c b/libguile/posix.c index 623ca2012..8dfd4175e 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -205,33 +205,27 @@ SCM_DEFINE (scm_getgroups, "getgroups", 0, 0, 0, "Returns a vector of integers representing the current supplimentary group IDs.") #define FUNC_NAME s_scm_getgroups { - SCM grps, ans; - int ngroups = getgroups (0, NULL); - if (!ngroups) - SCM_SYSERROR; - SCM_NEWCELL(grps); - SCM_DEFER_INTS; - { - GETGROUPS_T *groups; - int val; + SCM ans; + int ngroups; + scm_sizet size; + GETGROUPS_T *groups; - groups = SCM_MUST_MALLOC_TYPE_NUM(GETGROUPS_T,ngroups); - val = getgroups(ngroups, groups); - if (val < 0) - { - int en = errno; - scm_must_free((char *)groups); - errno = en; - SCM_SYSERROR; - } - SCM_SETCHARS(grps, groups); /* set up grps as a GC protect */ - SCM_SETLENGTH(grps, 0L + ngroups * sizeof(GETGROUPS_T), scm_tc7_string); - ans = scm_make_vector (SCM_MAKINUM(ngroups), SCM_UNDEFINED); - while (--ngroups >= 0) SCM_VELTS(ans)[ngroups] = SCM_MAKINUM(groups[ngroups]); - SCM_SETCHARS(grps, groups); /* to make sure grps stays around. */ - SCM_ALLOW_INTS; - return ans; - } + ngroups = getgroups (0, NULL); + if (ngroups <= 0) + SCM_SYSERROR; + + size = ngroups * sizeof (GETGROUPS_T); + groups = scm_must_malloc (size, FUNC_NAME); + getgroups (ngroups, groups); + + ans = scm_make_vector (SCM_MAKINUM (ngroups), SCM_UNDEFINED); + while (--ngroups >= 0) + SCM_VELTS (ans) [ngroups] = SCM_MAKINUM (groups [ngroups]); + + scm_must_free (groups); + scm_done_free (size); + + return ans; } #undef FUNC_NAME #endif From b24b5e13bf0de4825fcd8b5b36f454ef1ddc3493 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 2 Nov 2000 10:36:31 +0000 Subject: [PATCH 0350/2047] * Get rid of calls to SCM_ROSTRINGP. * Fix some string/symbol output problems with regards to substrings. * Fix error output to prefer procedure name parameters over stack data. * Use SCM_(SET_)?FILENAME where appropriate. * Prefer calling scm_remember over scm_protect/unprotect_object calls. --- NEWS | 4 +++- RELEASE | 2 +- libguile/backtrace.c | 16 +++++++--------- libguile/fports.c | 14 +++++++------- libguile/gc.c | 6 ++++-- libguile/gh_data.c | 27 +++++++++------------------ libguile/goops.c | 2 +- libguile/objects.c | 2 +- libguile/ports.c | 5 +++-- libguile/ports.h | 1 + libguile/print.c | 23 ++++++++++++++++------- libguile/symbols.h | 4 ++-- 12 files changed, 55 insertions(+), 51 deletions(-) diff --git a/NEWS b/NEWS index 60db8e26d..5a9c3e204 100644 --- a/NEWS +++ b/NEWS @@ -227,7 +227,8 @@ SCM_ORD_SIG, SCM_NUM_SIGS, SCM_SYMBOL_SLOTS, SCM_SLOTS, SCM_SLOPPY_STRINGP, SCM_VALIDATE_STRINGORSUBSTR, SCM_FREEP, SCM_NFREEP, SCM_CHARS, SCM_UCHARS, SCM_VALIDATE_ROSTRING, SCM_VALIDATE_ROSTRING_COPY, SCM_VALIDATE_NULLORROSTRING_COPY, SCM_ROLENGTH, SCM_LENGTH, SCM_HUGE_LENGTH, -SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR +SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR, +SCM_ROSTRINGP Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of SCM_OUTOFRANGE. Use scm_memory_error instead of SCM_NALLOC. @@ -238,6 +239,7 @@ Use a type specific accessor macro instead of SCM_CHARS/SCM_UCHARS. Use a type specific accessor instead of SCM(_|_RO|_HUGE_)LENGTH. Use SCM_VALIDATE_(SYMBOL|STRING) instead of SCM_VALIDATE_ROSTRING. Use SCM_STRING_COERCE_0TERMINATION_X instead of SCM_COERCE_SUBSTR. +Use SCM_STRINGP or SCM_SYMBOLP instead of SCM_ROSTRINGP. ** Removed function: scm_struct_init diff --git a/RELEASE b/RELEASE index e2773c54d..37c17ffda 100644 --- a/RELEASE +++ b/RELEASE @@ -49,7 +49,7 @@ In release 1.6: SCM_FREEP, SCM_NFREEP, SCM_CHARS, SCM_UCHARS, SCM_VALIDATE_ROSTRING, SCM_VALIDATE_ROSTRING_COPY, SCM_VALIDATE_NULLORROSTRING_COPY, SCM_ROLENGTH, SCM_LENGTH, SCM_HUGE_LENGTH, SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, - SCM_COERCE_SUBSTR + SCM_COERCE_SUBSTR, SCM_ROSTRINGP - remove scm_vector_set_length_x - remove function scm_call_catching_errors (replaced by catch functions from throw.[ch]) diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 7a8ee3a47..6c2b4e3d8 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -110,15 +110,15 @@ display_header (SCM source, SCM port) void scm_display_error_message (SCM message, SCM args, SCM port) { - if (SCM_ROSTRINGP (message) && SCM_NFALSEP (scm_list_p (args))) + if (SCM_STRINGP (message) && !SCM_FALSEP (scm_list_p (args))) { scm_simple_format (port, message, args); scm_newline (port); } else { - scm_prin1 (message, port, 0); - scm_putc ('\n', port); + scm_display (message, port); + scm_newline (port); } } @@ -131,7 +131,7 @@ display_expression (SCM frame,SCM pname,SCM source,SCM port) pstate->fancyp = 1; pstate->level = 2; pstate->length = 3; - if (SCM_ROSTRINGP (pname)) + if (SCM_SYMBOLP (pname) || SCM_STRINGP (pname)) { if (SCM_FRAMEP (frame) && SCM_FRAME_EVAL_ARGS_P (frame)) @@ -170,8 +170,8 @@ display_error_body (struct display_error_args *a) { SCM current_frame = SCM_BOOL_F; SCM source = SCM_BOOL_F; - SCM pname = SCM_BOOL_F; SCM prev_frame = SCM_BOOL_F; + SCM pname = a->subr; if (SCM_DEBUGGINGP && SCM_STACKP (a->stack) @@ -182,13 +182,11 @@ display_error_body (struct display_error_args *a) prev_frame = SCM_FRAME_PREV (current_frame); if (!SCM_MEMOIZEDP (source) && !SCM_FALSEP (prev_frame)) source = SCM_FRAME_SOURCE (prev_frame); - if (SCM_FRAME_PROC_P (current_frame) + if (!SCM_SYMBOLP (pname) && !SCM_STRINGP (pname) && SCM_FRAME_PROC_P (current_frame) && SCM_EQ_P (scm_procedure_p (SCM_FRAME_PROC (current_frame)), SCM_BOOL_T)) pname = scm_procedure_name (SCM_FRAME_PROC (current_frame)); } - if (!SCM_ROSTRINGP (pname)) - pname = a->subr; - if (SCM_ROSTRINGP (pname) || SCM_MEMOIZEDP (source)) + if (SCM_SYMBOLP (pname) || SCM_STRINGP (pname) || SCM_MEMOIZEDP (source)) { display_header (source, a->port); display_expression (current_frame, pname, source, a->port); diff --git a/libguile/fports.c b/libguile/fports.c index 658ab2675..046bdf60a 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -77,7 +77,7 @@ static void scm_fport_buffer_add (SCM port, int read_size, int write_size) { struct scm_fport *fp = SCM_FSTREAM (port); - scm_port *pt = SCM_PTAB_ENTRY (port); + scm_port *pt = SCM_PTAB_ENTRY (port); char *s_scm_fport_buffer_add = "scm_fport_buffer_add"; if (read_size == -1 || write_size == -1) @@ -377,7 +377,7 @@ scm_fdes_to_port (int fdes, char *mode, SCM name) else scm_fport_buffer_add (port, -1, -1); } - SCM_PTAB_ENTRY (port)->file_name = name; + SCM_SET_FILENAME (port, name); SCM_ALLOW_INTS; return port; } @@ -429,11 +429,11 @@ prinfport (SCM exp,SCM port,scm_print_state *pstate) if (SCM_OPFPORTP (exp)) { int fdes; - SCM name = SCM_PTAB_ENTRY (exp)->file_name; - scm_puts (SCM_ROSTRINGP (name) - ? SCM_ROCHARS (name) - : SCM_PTOBNAME (SCM_PTOBNUM (exp)), - port); + SCM name = SCM_FILENAME (exp); + if (SCM_STRINGP (name) || SCM_SYMBOLP (name)) + scm_display (name, port); + else + scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port); scm_putc (' ', port); fdes = (SCM_FSTREAM (exp))->fdes; diff --git a/libguile/gc.c b/libguile/gc.c index fa6474296..222553d3a 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1319,7 +1319,7 @@ gc_mark_nimp: if (!(i < scm_numptob)) goto def; if (SCM_PTAB_ENTRY(ptr)) - scm_gc_mark (SCM_PTAB_ENTRY(ptr)->file_name); + scm_gc_mark (SCM_FILENAME (ptr)); if (scm_ptobs[i].mark) { ptr = (scm_ptobs[i].mark) (ptr); @@ -2272,7 +2272,9 @@ SCM_DEFINE (scm_unhash_name, "unhash-name", 1, 0, 0, void scm_remember (SCM *ptr) -{ /* empty */ } +{ + /* empty */ +} /* diff --git a/libguile/gh_data.c b/libguile/gh_data.c index 0e359dc54..abcf27808 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -113,18 +113,16 @@ gh_set_substr (char *src, SCM dst, int start, int len) unsigned long dst_len; unsigned long effective_length; - SCM_ASSERT (SCM_STRINGP (dst), dst, SCM_ARG3, - "gh_set_substr"); + SCM_ASSERT (SCM_STRINGP (dst), dst, SCM_ARG3, "gh_set_substr"); dst_ptr = SCM_STRING_CHARS (dst); dst_len = SCM_STRING_LENGTH (dst); SCM_ASSERT (len >= 0 && (unsigned) len <= dst_len, dst, SCM_ARG4, "gh_set_substr"); - scm_protect_object (dst); effective_length = ((unsigned) len < dst_len) ? len : dst_len; memmove (dst_ptr + start, src, effective_length); - scm_unprotect_object (dst); + scm_remember (&dst); } /* Return the symbol named SYMBOL_STR. */ @@ -539,19 +537,17 @@ gh_scm2newstr (SCM str, int *lenp) SCM_ASSERT (SCM_STRINGP (str), str, SCM_ARG3, "gh_scm2newstr"); - /* protect str from GC while we copy off its data */ - scm_protect_object (str); - len = SCM_STRING_LENGTH (str); ret_str = (char *) scm_must_malloc ((len + 1) * sizeof (char), "gh_scm2newstr"); /* so we copy tmp_str to ret_str, which is what we will allocate */ memcpy (ret_str, SCM_ROCHARS (str), len); /* test ROCHARS here -twp */ + /* from now on we don't mind if str gets GC collected. */ + scm_remember (&str); /* now make sure we null-terminate it */ ret_str[len] = '\0'; - scm_unprotect_object (str); if (lenp != NULL) { @@ -575,12 +571,11 @@ gh_get_substr (SCM src, char *dst, int start, int len) int src_len, effective_length; SCM_ASSERT (SCM_STRINGP (src), src, SCM_ARG3, "gh_get_substr"); - scm_protect_object (src); src_len = SCM_STRING_LENGTH (src); effective_length = (len < src_len) ? len : src_len; memcpy (dst + start, SCM_ROCHARS (src), effective_length * sizeof (char)); /* FIXME: must signal an error if len > src_len */ - scm_unprotect_object (src); + scm_remember (&src); } @@ -597,23 +592,19 @@ gh_symbol2newstr (SCM sym, int *lenp) char *ret_str; int len; - SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG3, - "gh_scm2newsymbol"); - - /* protect str from GC while we copy off its data */ - scm_protect_object (sym); + SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG3, "gh_scm2newsymbol"); len = SCM_SYMBOL_LENGTH (sym); ret_str = (char *) scm_must_malloc ((len + 1) * sizeof (char), "gh_symbol2newstr"); - /* so we copy tmp_str to ret_str, which is what we will allocate */ + /* so we copy sym to ret_str, which is what we will allocate */ memcpy (ret_str, SCM_SYMBOL_CHARS (sym), len); + /* from now on we don't mind if sym gets GC collected. */ + scm_remember (&sym); /* now make sure we null-terminate it */ ret_str[len] = '\0'; - scm_unprotect_object (sym); - if (lenp != NULL) { *lenp = len; diff --git a/libguile/goops.c b/libguile/goops.c index 83876e0d7..a470ab65a 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -2479,7 +2479,7 @@ make_struct_class (void *closure, SCM key, SCM data, SCM prev) if (SCM_NFALSEP (SCM_STRUCT_TABLE_NAME (data))) SCM_SET_STRUCT_TABLE_CLASS (data, scm_make_extended_class - (SCM_ROCHARS (SCM_STRUCT_TABLE_NAME (data)))); + (SCM_SYMBOL_CHARS (SCM_STRUCT_TABLE_NAME (data)))); return SCM_UNSPECIFIED; } diff --git a/libguile/objects.c b/libguile/objects.c index 700662ba2..68836dea5 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -191,7 +191,7 @@ scm_class_of (SCM x) { SCM name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle)); SCM class = scm_make_extended_class (SCM_NFALSEP (name) - ? SCM_ROCHARS (name) + ? SCM_SYMBOL_CHARS (name) : 0); SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class); return class; diff --git a/libguile/ports.c b/libguile/ports.c index fe7ea9003..3f952a60a 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1271,7 +1271,7 @@ SCM_DEFINE (scm_port_filename, "port-filename", 1, 0, 0, { port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1,port); - return SCM_PTAB_ENTRY (port)->file_name; + return SCM_FILENAME (port); } #undef FUNC_NAME @@ -1286,7 +1286,8 @@ SCM_DEFINE (scm_set_port_filename_x, "set-port-filename!", 2, 0, 0, port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1,port); /* We allow the user to set the filename to whatever he likes. */ - return SCM_PTAB_ENTRY (port)->file_name = filename; + SCM_SET_FILENAME (port, filename); + return SCM_UNSPECIFIED; } #undef FUNC_NAME diff --git a/libguile/ports.h b/libguile/ports.h index b39c27fc1..0b12af557 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -169,6 +169,7 @@ extern int scm_port_table_size; /* Number of ports in scm_port_table. */ #define SCM_STREAM(x) (SCM_PTAB_ENTRY(x)->stream) #define SCM_SETSTREAM(x,s) (SCM_PTAB_ENTRY(x)->stream = (scm_bits_t) (s)) #define SCM_FILENAME(x) (SCM_PTAB_ENTRY(x)->file_name) +#define SCM_SET_FILENAME(x, n) (SCM_PTAB_ENTRY(x)->file_name = (n)) #define SCM_LINUM(x) (SCM_PTAB_ENTRY(x)->line_number) #define SCM_COL(x) (SCM_PTAB_ENTRY(x)->column_number) #define SCM_REVEALED(x) (SCM_PTAB_ENTRY(x)->revealed) diff --git a/libguile/print.c b/libguile/print.c index 16ac4e4f4..a7408491e 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -439,10 +439,15 @@ taloop: env = SCM_ENV (exp); scm_puts ("#', port); @@ -972,6 +977,7 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, int fReturnString = 0; int writingp; char *start; + char *end; char *p; if (SCM_EQ_P (destination, SCM_BOOL_T)) @@ -995,13 +1001,16 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, SCM_VALIDATE_REST_ARGUMENT (args); start = SCM_ROCHARS (message); - for (p = start; *p != '\0'; ++p) + end = start + SCM_STRING_LENGTH (message); + for (p = start; p != end; ++p) if (*p == '~') { - if (SCM_IMP (args) || SCM_NCONSP (args)) + if (!SCM_CONSP (args)) + continue; + + if (++p == end) continue; - ++p; if (*p == 'A' || *p == 'a') writingp = 0; else if (*p == 'S' || *p == 's') diff --git a/libguile/symbols.h b/libguile/symbols.h index e742f18b5..6160afc49 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -75,8 +75,6 @@ extern int scm_symhash_dim; #define SCM_SYMBOL_HASH(X) (SCM_CELL_WORD_2 (X)) #define SCM_SET_SYMBOL_HASH(X, v) (SCM_SET_CELL_WORD_2 ((X), (v))) -#define SCM_ROSTRINGP(x) (SCM_NIMP(x) && ((SCM_TYP7S(x)==scm_tc7_string) \ - || (SCM_TYP7(x) == scm_tc7_symbol))) #define SCM_ROCHARS(x) ((SCM_TYP7 (x) == scm_tc7_substring) \ ? (SCM_INUM (SCM_CADR (x)) + SCM_STRING_CHARS (SCM_CDDR (x))) \ : ((SCM_TYP7 (x) == scm_tc7_string) \ @@ -133,6 +131,8 @@ extern void scm_init_symbols (void); #define SCM_SUBSTR_STR(x) (SCM_CDDR (x)) #define SCM_SUBSTR_OFFSET(x) (SCM_CADR (x)) #define SCM_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) +#define SCM_ROSTRINGP(x) (SCM_NIMP(x) && ((SCM_TYP7S(x)==scm_tc7_string) \ + || (SCM_TYP7(x) == scm_tc7_symbol))) #define SCM_ROLENGTH(x) SCM_LENGTH (x) #define SCM_SUBSTRP(x) (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_substring)) #define SCM_COERCE_SUBSTR(x) SCM_STRING_COERCE_0TERMINATION_X (x) From 931dd6e12594f414401b472f3e01833969fdb8a4 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 2 Nov 2000 10:41:33 +0000 Subject: [PATCH 0351/2047] * Ahem, forgot to send the changelog with the last set of patches... --- libguile/ChangeLog | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 373e4b3a1..a47fef9cd 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,37 @@ +2000-11-01 Dirk Herrmann + + * backtrace.c (display_expression, display_error_body), fports.c + (prinfport), print.c (scm_iprin1): Test for symbols and strings + explicitly instead of using SCM_ROSTRINGP. + + * backtrace.c (scm_display_error_message): Don't pass a symbol to + scm_simple_format. Prefer high-level output functions. + + (display_error_body): When displaying procedure names, give + preference to the name passed as a parameter. Only if none is + given extract a name from the stack information. + + * fports.c (scm_fdes_to_port, prinfport), gc.c (scm_gc_mark), + ports.c (scm_port_filename, scm_set_port_filename_x): Use + SCM_(SET_)?FILENAME. + + * gh_data.c (gh_set_substr, gh_scm2newstr, gh_get_substr, + gh_symbol2newstr): Use scm_remember instead of a pair of calls to + scm_protect/unprotect_object. + + * goops.c (make_struct_class), objects.c (scm_class_of): Struct + table names are symbols. + + * ports.h (SCM_SET_FILENAME): Added. + + * print.c (scm_iprin1): Don't use scm_puts to write symbols or + strings in order to treat substrings right. Reposition call to + scm_remember after the last use of object's data. + + (scm_simple_format): Treat messages that are substrings right. + + * symbols.h (SCM_ROSTRINGP): Deprecated. + 2000-11-01 Dirk Herrmann * environments.c (obarray_replace, obarray_retrieve, From 53a53bd75ec2c4c4acca1ad41481bea87649393e Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 3 Nov 2000 17:52:20 +0000 Subject: [PATCH 0352/2047] * Add test to check whether the after-gc-hook is run correctly. --- test-suite/ChangeLog | 4 +++ test-suite/tests/gc.test | 67 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 71 insertions(+) create mode 100644 test-suite/tests/gc.test diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index c1b395a9a..71eab5aba 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2000-11-03 Dirk Herrmann + + * tests/gc.test: Added. + 2000-10-30 Dirk Herrmann * tests/strings.test: string=? is fixed. diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test new file mode 100644 index 000000000..c997320e3 --- /dev/null +++ b/test-suite/tests/gc.test @@ -0,0 +1,67 @@ +;;;; gc.test --- test guile's garbage collection -*- scheme -*- +;;;; Copyright (C) 2000 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. + +(use-modules (ice-9 documentation)) + + +;;; +;;; miscellaneous +;;; + + +(define (documented? object) + (object-documentation object)) + + +;;; +;;; +;;; + +(with-test-prefix "gc" + + (pass-if "after-gc-hook gets called" + (let* ((foo #f) + (thunk (lambda () (set! foo #t)))) + (add-hook! after-gc-hook thunk) + (gc) + (remove-hook! after-gc-hook thunk) + foo))) From eb5c0a2a6cccd7313611558e1b7929fd5a3d4deb Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sat, 4 Nov 2000 23:24:14 +0000 Subject: [PATCH 0353/2047] 2000-11-04 Gary Houston * ports.c (scm_port_p): new function, implements "port?" which is mentioned in R5RS. * ports.h: declare scm_port_p. --- NEWS | 5 +++++ libguile/ChangeLog | 6 ++++++ libguile/ports.c | 10 ++++++++++ libguile/ports.h | 1 + 4 files changed, 22 insertions(+) diff --git a/NEWS b/NEWS index 5a9c3e204..943de3428 100644 --- a/NEWS +++ b/NEWS @@ -169,6 +169,11 @@ Guile. Instead, use scm_memq, scm_memv, scm_member. +** New function: port? X + +Returns a boolean indicating whether X is a port. Equivalent to +`(or (input-port? X) (output-port? X))'. + * Changes to the gh_ interface * Changes to the scm_ interface diff --git a/libguile/ChangeLog b/libguile/ChangeLog index a47fef9cd..5b3a541a5 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2000-11-04 Gary Houston + + * ports.c (scm_port_p): new function, implements "port?" which + is mentioned in R5RS. + * ports.h: declare scm_port_p. + 2000-11-01 Dirk Herrmann * backtrace.c (display_expression, display_error_body), fports.c diff --git a/libguile/ports.c b/libguile/ports.c index 3f952a60a..7476613a0 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -735,6 +735,16 @@ SCM_DEFINE (scm_output_port_p, "output-port?", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_port_p, "port?", 1, 0, 0, + (SCM x), + "Returns a boolean indicating whether @var{x} is a port.\n" + "Equivalent to @code{(or (input-port? X) (output-port? X))}.") +#define FUNC_NAME s_scm_port_p +{ + return SCM_BOOL (SCM_PORTP (x)); +} +#undef FUNC_NAME + SCM_DEFINE (scm_port_closed_p, "port-closed?", 1, 0, 0, (SCM port), "Returns @code{#t} if @var{port} is closed or @code{#f} if it is open.") diff --git a/libguile/ports.h b/libguile/ports.h index 0b12af557..d4f884ee3 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -269,6 +269,7 @@ extern SCM scm_close_port (SCM port); extern SCM scm_close_all_ports_except (SCM ports); extern SCM scm_input_port_p (SCM x); extern SCM scm_output_port_p (SCM x); +extern SCM scm_port_p (SCM x); extern SCM scm_port_closed_p (SCM port); extern SCM scm_eof_object_p (SCM x); extern SCM scm_force_output (SCM port); From 55c4a1324010fe863ffda9c827d434b4da5c074c Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Tue, 7 Nov 2000 02:17:58 +0000 Subject: [PATCH 0354/2047] * goops.c (scm_sys_invalidate_method_cache_x): Don't convert scm_si_n_specialized from fixnum and don't take absolute value. (Thanks to Lars J. Aas.) --- libguile/goops.c | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/libguile/goops.c b/libguile/goops.c index a470ab65a..485d067a3 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1634,10 +1634,9 @@ scm_sys_invalidate_method_cache_x (SCM gf) SCM_SLOT (SCM_CAR (methods), scm_si_code_table) = SCM_EOL; } { - int n = SCM_INUM (SCM_SLOT (gf, scm_si_n_specialized)); + SCM n = SCM_SLOT (gf, scm_si_n_specialized); /* The sign of n is a flag indicating rest args. */ - SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf), - SCM_MAKINUM (n >= 0 ? n : -n)); + SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf), n); } return SCM_UNSPECIFIED; } From 4ea6a43186c41e3946c9c0710a8ad4d9bbcd24f5 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Tue, 7 Nov 2000 02:18:11 +0000 Subject: [PATCH 0355/2047] * eval.c (SCM_IM_DISPATCH), objects.c (scm_mcache_lookup_cmethod): Count n_specialized + 1 turns before letting a match through. --- libguile/eval.c | 4 ++-- libguile/objects.c | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index 92f20a2c5..5fa006362 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2292,7 +2292,7 @@ dispatch: [scm_si_hashsets + hashset]; t.arg1 = SCM_CDR (t.arg1); } - while (--j && SCM_NIMP (t.arg1)); + while (j-- && SCM_NIMP (t.arg1)); i &= mask; end = i; } @@ -2312,7 +2312,7 @@ dispatch: t.arg1 = SCM_CDR (t.arg1); z = SCM_CDR (z); } - while (--j && SCM_NIMP (t.arg1)); + while (j-- && SCM_NIMP (t.arg1)); /* Fewer arguments than specifiers => CAR != ENV */ if (!(SCM_IMP (SCM_CAR (z)) || SCM_CONSP (SCM_CAR (z)))) goto next_method; diff --git a/libguile/objects.c b/libguile/objects.c index 68836dea5..5fe685349 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -276,7 +276,7 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args) [scm_si_hashsets + hashset]; ls = SCM_CDR (ls); } - while (--j && SCM_NIMP (ls)); + while (j-- && SCM_NIMP (ls)); i &= mask; end = i; } @@ -296,7 +296,7 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args) ls = SCM_CDR (ls); z = SCM_CDR (z); } - while (--j && SCM_NIMP (ls)); + while (j-- && SCM_NIMP (ls)); /* Fewer arguments than specifiers => CAR != ENV */ if (!(SCM_IMP (SCM_CAR (z)) || SCM_CONSP (SCM_CAR (z)))) goto next_method; From 81211c73cc7228612bacc255b35b46f29bd203d8 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Tue, 7 Nov 2000 02:18:52 +0000 Subject: [PATCH 0356/2047] * goops.scm (internal-add-method!): Set n-specialized of a generic function to the number of specializers regardless if it has rest args or not. --- oop/goops.scm | 17 ++--------------- 1 file changed, 2 insertions(+), 15 deletions(-) diff --git a/oop/goops.scm b/oop/goops.scm index 892cb9ab6..94d4e1d12 100644 --- a/oop/goops.scm +++ b/oop/goops.scm @@ -531,21 +531,8 @@ (slot-set! gf 'methods (compute-new-list-of-methods gf m)) (let ((specializers (slot-ref m 'specializers))) (slot-set! gf 'n-specialized - (let ((n-specialized (slot-ref gf 'n-specialized))) - ;; The magnitude indicates # specializers. - ;; A negative value indicates that at least one - ;; method has rest arguments. (Ugly but effective - ;; space optimization saving one slot in GF objects.) - (cond ((negative? n-specialized) - (- (max (+ 1 (length* specializers)) - (abs n-specialized)))) - ((list? specializers) - (max (length specializers) - n-specialized)) - (else - (- (+ 1 (max (length* specializers) - n-specialized))))) - ))) + (max (length* specializers) + (slot-ref gf 'n-specialized)))) (%invalidate-method-cache! gf) (add-method-in-classes! m) *unspecified*) From ef42490f6651af21e86a4521e24d81cc314df5cb Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Tue, 7 Nov 2000 02:19:03 +0000 Subject: [PATCH 0357/2047] * goops/dispatch.scm (method-cache-install!): Use n-specialized + 1 args for type matching. (Thanks to Lars J. Aas.) --- oop/goops/dispatch.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/oop/goops/dispatch.scm b/oop/goops/dispatch.scm index 26d832a6e..a1e031f4d 100644 --- a/oop/goops/dispatch.scm +++ b/oop/goops/dispatch.scm @@ -261,7 +261,7 @@ (n-specializers (if (list? specializers) (length specializers) - (abs (slot-ref (method-cache-generic-function exp) + (+ 1 (slot-ref (method-cache-generic-function exp) 'n-specialized))))) (let* ((types (map class-of (first-n args n-specializers))) (entry+cmethod (compute-entry-with-cmethod applicable types))) From b100f5eed22720eed9a8c2caa5dd46b0f712bae8 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Tue, 7 Nov 2000 02:19:13 +0000 Subject: [PATCH 0358/2047] *** empty log message *** --- THANKS | 1 + libguile/ChangeLog | 9 +++++++++ oop/ChangeLog | 9 +++++++++ 3 files changed, 19 insertions(+) diff --git a/THANKS b/THANKS index 4859f06ca..bb493317c 100644 --- a/THANKS +++ b/THANKS @@ -12,6 +12,7 @@ Contributors since the last release: For fixes or providing information which led to a fix: + Lars J. Aas Ian Bicking I. N. Golubev Brad Knotwell diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 5b3a541a5..63a972b23 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2000-11-06 Mikael Djurfeldt + + * eval.c (SCM_IM_DISPATCH), objects.c (scm_mcache_lookup_cmethod): + Count n_specialized + 1 turns before letting a match through. + + * goops.c (scm_sys_invalidate_method_cache_x): Don't convert + scm_si_n_specialized from fixnum and don't take absolute value. + (Thanks to Lars J. Aas.) + 2000-11-04 Gary Houston * ports.c (scm_port_p): new function, implements "port?" which diff --git a/oop/ChangeLog b/oop/ChangeLog index 8dd08b4f9..78497dfc0 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -1,3 +1,12 @@ +2000-11-06 Mikael Djurfeldt + + * goops.scm (internal-add-method!): Set n-specialized of a generic + function to the number of specializers regardless if it has rest + args or not. + + * goops/dispatch.scm (method-cache-install!): Use n-specialized + + 1 args for type matching. (Thanks to Lars J. Aas.) + 2000-10-23 Mikael Djurfeldt * goops.scm (goops-error): Removed use of oldfmt. From c2ca44933f8b2b43ec3efa541a6824537c45a560 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Tue, 7 Nov 2000 21:34:45 +0000 Subject: [PATCH 0359/2047] 2000-11-07 Gary Houston * ports.c (scm_port_for_each): new proc. implements port-for-each, which applies a procedure to each port in the port table. ports.h: declare scm_port_for_each. * ioext.c (scm_dup2): new proc. implements "dup2" which is a simple wrapper for the dup2 system call (unlike dup->fdes or primitive-move->fdes). * ioext.h: declare scm_dup2. * filesys.c (scm_close_fdes): new proc. implements "close-fdes" which is a simple wrapper for close system call (unlike scm_close). * filesys.h: declare for scm_close_fdes. --- libguile/ChangeLog | 15 +++++++++++++++ libguile/filesys.c | 20 ++++++++++++++++++++ libguile/filesys.h | 1 + libguile/ioext.c | 25 +++++++++++++++++++++++++ libguile/ioext.h | 1 + libguile/ports.c | 20 ++++++++++++++++++++ libguile/ports.h | 1 + 7 files changed, 83 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 63a972b23..4d7f024b9 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,18 @@ +2000-11-07 Gary Houston + + * ports.c (scm_port_for_each): new proc. implements port-for-each, + which applies a procedure to each port in the port table. + ports.h: declare scm_port_for_each. + + * ioext.c (scm_dup2): new proc. implements "dup2" which is a simple + wrapper for the dup2 system call (unlike dup->fdes or + primitive-move->fdes). + * ioext.h: declare scm_dup2. + + * filesys.c (scm_close_fdes): new proc. implements "close-fdes" + which is a simple wrapper for close system call (unlike scm_close). + * filesys.h: declare for scm_close_fdes. + 2000-11-06 Mikael Djurfeldt * eval.c (SCM_IM_DISPATCH), objects.c (scm_mcache_lookup_cmethod): diff --git a/libguile/filesys.c b/libguile/filesys.c index 7e280652e..e8e62b1d5 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -335,6 +335,26 @@ SCM_DEFINE (scm_close, "close", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_close_fdes, "close-fdes", 1, 0, 0, + (SCM fd), + "A simple wrapper for the @code{close} system call.\n" + "Close file descriptor @var{fd}, which must be an integer.\n" + "Unlike close (@pxref{Ports and File Descriptors, close}),\n" + "the file descriptor will be closed even if a port is using it.\n" + "The return value is unspecified.") +#define FUNC_NAME s_scm_close_fdes +{ + int c_fd; + int rv; + + SCM_VALIDATE_INUM_COPY (1, fd, c_fd); + SCM_SYSCALL (rv = close (c_fd)); + if (rv < 0) + SCM_SYSERROR; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + /* {Files} */ diff --git a/libguile/filesys.h b/libguile/filesys.h index f20240a8c..b6e8de297 100644 --- a/libguile/filesys.h +++ b/libguile/filesys.h @@ -64,6 +64,7 @@ extern SCM scm_umask (SCM mode); extern SCM scm_open_fdes (SCM path, SCM flags, SCM mode); extern SCM scm_open (SCM path, SCM flags, SCM mode); extern SCM scm_close (SCM fd_or_port); +extern SCM scm_close_fdes (SCM fd); extern SCM scm_stat (SCM object); extern SCM scm_link (SCM oldpath, SCM newpath); extern SCM scm_rename (SCM oldname, SCM newname); diff --git a/libguile/ioext.c b/libguile/ioext.c index 9cb84560e..439a7d7a0 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -412,6 +412,31 @@ SCM_DEFINE (scm_dup_to_fdes, "dup->fdes", 1, 1, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_dup2, "dup2", 2, 0, 0, + (SCM oldfd, SCM newfd), + "A simple wrapper for the @code{dup2} system call.\n" + "Copies the file descriptor @var{oldfd} to descriptor\n" + "number @var{newfd}, replacing the previous meaning\n" + "of @var{newfd}. Both @var{oldfd} and @var{newfd} must\n" + "be integers.\n" + "Unlike for dup->fdes or primitive-move->fdes, no attempt\n" + "is made to move away ports which are using @var{newfd}\n". + "The return value is unspecified.") +#define FUNC_NAME s_scm_dup2 +{ + int c_oldfd; + int c_newfd; + int rv; + + SCM_VALIDATE_INUM_COPY (1, oldfd, c_oldfd); + SCM_VALIDATE_INUM_COPY (2, newfd, c_newfd); + rv = dup2 (c_oldfd, c_newfd); + if (rv == -1) + SCM_SYSERROR; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + SCM_DEFINE (scm_fileno, "fileno", 1, 0, 0, (SCM port), "Returns the integer file descriptor underlying @var{port}.\n" diff --git a/libguile/ioext.h b/libguile/ioext.h index 37aa09559..a79b1a5b5 100644 --- a/libguile/ioext.h +++ b/libguile/ioext.h @@ -54,6 +54,7 @@ extern SCM scm_write_line (SCM obj, SCM port); extern SCM scm_ftell (SCM object); extern SCM scm_redirect_port (SCM into_pt, SCM from_pt); extern SCM scm_dup_to_fdes (SCM fd_or_port, SCM newfd); +extern SCM scm_dup2 (SCM oldfd, SCM newfd); extern SCM scm_fileno (SCM port); extern SCM scm_isatty_p (SCM port); extern SCM scm_fdopen (SCM fdes, SCM modes); diff --git a/libguile/ports.c b/libguile/ports.c index 7476613a0..f6b9eeaff 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -668,6 +668,26 @@ SCM_DEFINE (scm_close_output_port, "close-output-port", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_port_for_each, "port-for-each", 1, 0, 0, + (SCM proc), + "Apply @var{proc} to each port in the Guile port table\n" + "in turn. The return value is unspecified.") +#define FUNC_NAME s_scm_port_for_each +{ + int i; + SCM_VALIDATE_PROC (1, proc); + + /* when pre-emptive multithreading is supported, access to the port + table will need to be controlled by a mutex. */ + SCM_DEFER_INTS; + for (i = 0; i < scm_port_table_size; i++) + { + scm_apply (proc, scm_cons (scm_port_table[i]->port, SCM_EOL), SCM_EOL); + } + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + SCM_DEFINE (scm_close_all_ports_except, "close-all-ports-except", 0, 0, 1, (SCM ports), "Close all open file ports used by the interpreter\n" diff --git a/libguile/ports.h b/libguile/ports.h index d4f884ee3..22d69db47 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -266,6 +266,7 @@ extern SCM scm_port_mode (SCM port); extern SCM scm_close_input_port (SCM port); extern SCM scm_close_output_port (SCM port); extern SCM scm_close_port (SCM port); +extern SCM scm_port_for_each (SCM proc); extern SCM scm_close_all_ports_except (SCM ports); extern SCM scm_input_port_p (SCM x); extern SCM scm_output_port_p (SCM x); From 8ccc61e837208c2bca299b2d33d6c52b431343c3 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Tue, 7 Nov 2000 21:36:42 +0000 Subject: [PATCH 0360/2047] 2000-11-06 Gary Houston * popen.scm (open-process): bug fix: don't use close-all-ports-except to close ports in the child process, since it causes port buffers to be flushed. they may be flushed again in the parent, causing duplicate output. use a more elaborate method for setting up the child descriptors (thanks to David Pirotte for the bug report). standard file descriptors 0, 1, 2 in the child process are now set up from current-input-port etc., where possible. --- ice-9/ChangeLog | 11 +++++++++ ice-9/popen.scm | 63 +++++++++++++++++++++++++++++++++++++++++++++---- 2 files changed, 70 insertions(+), 4 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 76deabca7..bc2abc993 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,14 @@ +2000-11-06 Gary Houston + + * popen.scm (open-process): bug fix: don't use + close-all-ports-except to close ports in the child process, since + it causes port buffers to be flushed. they may be flushed again + in the parent, causing duplicate output. use a more elaborate + method for setting up the child descriptors (thanks to David + Pirotte for the bug report). + standard file descriptors 0, 1, 2 in the child process + are now set up from current-input-port etc., where possible. + 2000-10-10 Dirk Herrmann * syncase.scm (eval): string=? requires a string argument. diff --git a/ice-9/popen.scm b/ice-9/popen.scm index 6919f0eca..874477ba5 100644 --- a/ice-9/popen.scm +++ b/ice-9/popen.scm @@ -12,6 +12,10 @@ ;; a weak hash-table to store the process ids. (define-public port/pid-table (make-weak-key-hash-table 31)) +(define (ensure-fdes port mode) + (or (false-if-exception (fileno port)) + (open-fdes *null-device* mode))) + ;; run a process connected to an input or output port. ;; mode: OPEN_READ or OPEN_WRITE. ;; returns port/pid pair. @@ -23,10 +27,61 @@ (cond ((= pid 0) ;; child (set-batch-mode?! #t) - (close-all-ports-except (if reading (cdr p) (car p))) - (move->fdes (if reading (cdr p) (car p)) - (if reading 1 0)) - (apply execlp prog prog args)) + + ;; select the three file descriptors to be used as + ;; standard descriptors 0, 1, 2 for the new process. one + ;; is the pipe to the parent, the other two are taken + ;; from the current Scheme input/output/error ports if + ;; possible. + + (let ((input-fdes (if reading + (ensure-fdes (current-input-port) + O_RDONLY) + (fileno (car p)))) + (output-fdes (if reading + (fileno (cdr p)) + (ensure-fdes (current-output-port) + O_WRONLY))) + (error-fdes (ensure-fdes (current-error-port) + O_WRONLY))) + + ;; close all file descriptors in ports inherited from + ;; the parent except for the three selected above. + ;; this is to avoid causing problems for other pipes in + ;; the parent. + + ;; use low-level system calls, not close-port or the + ;; scsh routines, to avoid side-effects such as + ;; flushing port buffers or evicting ports. + + (port-for-each (lambda (pt-entry) + (false-if-exception + (let ((pt-fileno (fileno pt-entry))) + (if (not (or (= pt-fileno input-fdes) + (= pt-fileno output-fdes) + (= 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. + + (cond ((not (= input-fdes 0)) + (if (= output-fdes 0) + (set! output-fdes (dup->fdes 0))) + (if (= error-fdes 0) + (set! error-fdes (dup->fdes 0))) + (dup2 input-fdes 0))) + + (cond ((not (= output-fdes 1)) + (if (= error-fdes 1) + (set! error-fdes (dup->fdes 1))) + (dup2 output-fdes 1))) + + (dup2 error-fdes 2) + + (apply execlp prog prog args))) + (else ;; parent (if reading From 9f9919eb84ffc03c4c27f060476e94b263752dec Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Tue, 7 Nov 2000 21:38:03 +0000 Subject: [PATCH 0361/2047] *** empty log message *** --- THANKS | 1 + 1 file changed, 1 insertion(+) diff --git a/THANKS b/THANKS index bb493317c..8d815d770 100644 --- a/THANKS +++ b/THANKS @@ -21,6 +21,7 @@ For fixes or providing information which led to a fix: Shuji Narazaki Nicolas Neuss Han-Wen Nienhuys + David Pirotte William Webber Dale P. Smith Ralf Mattes From 34526073e85b0b4ab89c95f45e55286960a1b11e Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Tue, 7 Nov 2000 22:42:35 +0000 Subject: [PATCH 0362/2047] *** empty log message *** --- libguile/ioext.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/ioext.c b/libguile/ioext.c index 439a7d7a0..6193679c1 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -412,6 +412,7 @@ SCM_DEFINE (scm_dup_to_fdes, "dup->fdes", 1, 1, 0, } #undef FUNC_NAME + SCM_DEFINE (scm_dup2, "dup2", 2, 0, 0, (SCM oldfd, SCM newfd), "A simple wrapper for the @code{dup2} system call.\n" @@ -420,7 +421,7 @@ SCM_DEFINE (scm_dup2, "dup2", 2, 0, 0, "of @var{newfd}. Both @var{oldfd} and @var{newfd} must\n" "be integers.\n" "Unlike for dup->fdes or primitive-move->fdes, no attempt\n" - "is made to move away ports which are using @var{newfd}\n". + "is made to move away ports which are using @var{newfd}.\n" "The return value is unspecified.") #define FUNC_NAME s_scm_dup2 { From 34b56ec407e35275d67045615285c480e141ba4d Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Thu, 9 Nov 2000 22:41:58 +0000 Subject: [PATCH 0363/2047] *** empty log message *** --- NEWS | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/NEWS b/NEWS index 943de3428..3ba743414 100644 --- a/NEWS +++ b/NEWS @@ -174,6 +174,36 @@ Instead, use scm_memq, scm_memv, scm_member. Returns a boolean indicating whether X is a port. Equivalent to `(or (input-port? X) (output-port? X))'. +** New function: port-for-each proc + +Apply PROC to each port in the Guile port table in turn. The +return value is unspecified. + +** New function: dup2 oldfd newfd + +A simple wrapper for the `dup2' system call. Copies the file +descriptor OLDFD to descriptor number NEWFD, replacing the +previous meaning of NEWFD. Both OLDFD and NEWFD must be integers. +Unlike for dup->fdes or primitive-move->fdes, no attempt is made +to move away ports which are using NEWFD\n". The return value is +unspecified. + +** New function: close-fdes fd + +A simple wrapper for the `close' system call. Close file +descriptor FD, which must be an integer. Unlike close (*note +close: Ports and File Descriptors.), the file descriptor will be +closed even if a port is using it. The return value is +unspecified. + +** Deprecated: close-all-ports-except. This was intended for closing +ports in a child process after a fork, but it has the undesirable side +effect of flushing buffers. port-for-each is more flexible. + +** The (ice-9 popen) module now attempts to set up file descriptors in +the child process from the current Scheme ports, instead of using the +current values of file descriptors 0, 1, and 2 in the parent process. + * Changes to the gh_ interface * Changes to the scm_ interface From b875c46853e6f25c43eb76b277f3b0fa92254699 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Thu, 9 Nov 2000 22:44:09 +0000 Subject: [PATCH 0364/2047] 2000-11-09 Gary Houston * ports.c, ports.h (scm_close_all_ports_except): deprecated. use port-for-each. Updated its docstring. --- libguile/ChangeLog | 5 +++++ libguile/ports.c | 11 ++++++++--- libguile/ports.h | 3 ++- 3 files changed, 15 insertions(+), 4 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 4d7f024b9..0c93cdbe9 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-11-09 Gary Houston + + * ports.c, ports.h (scm_close_all_ports_except): deprecated. + use port-for-each. Updated its docstring. + 2000-11-07 Gary Houston * ports.c (scm_port_for_each): new proc. implements port-for-each, diff --git a/libguile/ports.c b/libguile/ports.c index f6b9eeaff..d868e2971 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -688,12 +688,16 @@ SCM_DEFINE (scm_port_for_each, "port-for-each", 1, 0, 0, } #undef FUNC_NAME +#if (SCM_DEBUG_DEPRECATED == 0) + SCM_DEFINE (scm_close_all_ports_except, "close-all-ports-except", 0, 0, 1, (SCM ports), - "Close all open file ports used by the interpreter\n" + "[DEPRECATED] Close all open file ports used by the interpreter\n" "except for those supplied as arguments. This procedure\n" - "is intended to be used before an exec call to close file descriptors\n" - "which are not needed in the new process.") + "was intended to be used before an exec call to close file descriptors\n" + "which are not needed in the new process. However it has the\n" + "undesirable side-effect of flushing buffes, so it's deprecated.\n" + "Use port-for-each instead.") #define FUNC_NAME s_scm_close_all_ports_except { int i = 0; @@ -723,6 +727,7 @@ SCM_DEFINE (scm_close_all_ports_except, "close-all-ports-except", 0, 0, 1, } #undef FUNC_NAME +#endif /* Utter miscellany. Gosh, we should clean this up some time. */ diff --git a/libguile/ports.h b/libguile/ports.h index 22d69db47..9315c9d9f 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -267,7 +267,6 @@ extern SCM scm_close_input_port (SCM port); extern SCM scm_close_output_port (SCM port); extern SCM scm_close_port (SCM port); extern SCM scm_port_for_each (SCM proc); -extern SCM scm_close_all_ports_except (SCM ports); extern SCM scm_input_port_p (SCM x); extern SCM scm_output_port_p (SCM x); extern SCM scm_port_p (SCM x); @@ -316,6 +315,8 @@ extern SCM scm_pt_member (SCM member); #define SCM_INPORTP(x) SCM_INPUT_PORT_P (x) #define SCM_OUTPORTP(x) SCM_OUTPUT_PORT_P (x) +extern SCM scm_close_all_ports_except (SCM ports); + #endif /* SCM_DEBUG_DEPRECATED == 0 */ #endif /* PORTSH */ From a9c632a2f3d043d7e1effc78de31822c823d1e8e Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Thu, 9 Nov 2000 22:46:07 +0000 Subject: [PATCH 0365/2047] 2000-11-07 Gary Houston * popen.scm (open-output-pipe): added docstrings for open-input-pipe and open-output-pipe. --- ice-9/ChangeLog | 5 +++++ ice-9/popen.scm | 9 +++++++-- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index bc2abc993..4661db3f7 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2000-11-07 Gary Houston + + * popen.scm (open-output-pipe): added docstrings for open-input-pipe + and open-output-pipe. + 2000-11-06 Gary Houston * popen.scm (open-process): bug fix: don't use diff --git a/ice-9/popen.scm b/ice-9/popen.scm index 874477ba5..eca3dfe26 100644 --- a/ice-9/popen.scm +++ b/ice-9/popen.scm @@ -152,5 +152,10 @@ information on how to interpret this value." (add-hook! after-gc-hook reap-pipes) -(define-public (open-input-pipe command) (open-pipe command OPEN_READ)) -(define-public (open-output-pipe command) (open-pipe command OPEN_WRITE)) +(define-public (open-input-pipe command) + "Equivalent to @code{open-pipe} with mode @code{OPEN_READ}" + (open-pipe command OPEN_READ)) + +(define-public (open-output-pipe command) + "Equivalent to @code{open-pipe} with mode @code{OPEN_WRITE}" + (open-pipe command OPEN_WRITE)) From 9f561420d3125cdf68f102b4f30d5b5d141abda7 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 12 Nov 2000 12:20:52 +0000 Subject: [PATCH 0366/2047] * fports.c (scm_open_file): fix the 'b' option. Thanks to George Caswell. --- THANKS | 1 + libguile/ChangeLog | 5 +++++ libguile/fports.c | 6 +++++- 3 files changed, 11 insertions(+), 1 deletion(-) diff --git a/THANKS b/THANKS index 8d815d770..6f00ba104 100644 --- a/THANKS +++ b/THANKS @@ -14,6 +14,7 @@ For fixes or providing information which led to a fix: Lars J. Aas Ian Bicking + George Caswell I. N. Golubev Brad Knotwell Matthias Köppe diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 0c93cdbe9..03f7fb717 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-11-12 Gary Houston + + * fports.c (scm_open_file): fix the 'b' option. Thanks + to George Caswell. + 2000-11-09 Gary Houston * ports.c, ports.h (scm_close_all_ports_except): deprecated. diff --git a/libguile/fports.c b/libguile/fports.c index 046bdf60a..a14130b40 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -306,8 +306,12 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0, case '+': flags = (flags & ~(O_RDONLY | O_WRONLY)) | O_RDWR; break; + case 'b': +#if defined (O_BINARY) + flags |= O_BINARY; +#endif + break; case '0': /* unbuffered: handled later. */ - case 'b': /* 'binary' mode: ignored. */ case 'l': /* line buffered: handled during output. */ break; default: From 6b72ac1d10d8b1ab78f3afa6e92b835c1e77c80e Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Mon, 13 Nov 2000 23:16:38 +0000 Subject: [PATCH 0367/2047] * fports.c: include gc.h. (fport_flush, fport_close): silently ignore I/O errors when closing a port during gc. it's better than aborting in scm_error. * throw.c (scm_handle_by_message): remove obsolete comment. --- libguile/ChangeLog | 8 ++++++++ libguile/fports.c | 24 +++++++++++++++++++----- libguile/throw.c | 3 --- 3 files changed, 27 insertions(+), 8 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 03f7fb717..b284072c1 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2000-11-13 Gary Houston + + * fports.c: include gc.h. + (fport_flush, fport_close): silently ignore I/O errors when + closing a port during gc. it's better than aborting in scm_error. + + * throw.c (scm_handle_by_message): remove obsolete comment. + 2000-11-12 Gary Houston * fports.c (scm_open_file): fix the 'b' option. Thanks diff --git a/libguile/fports.c b/libguile/fports.c index a14130b40..9438bbd0d 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -48,8 +48,9 @@ #include #include "libguile/_scm.h" #include "libguile/strings.h" - #include "libguile/validate.h" +#include "libguile/gc.h" + #include "libguile/fports.h" #ifdef HAVE_STRING_H @@ -643,9 +644,7 @@ fport_flush (SCM port) } pt->write_pos = pt->write_buf + remaining; } - if (!terminating) - scm_syserror ("fport_flush"); - else + if (terminating) { const char *msg = "Error: could not flush file-descriptor "; char buf[11]; @@ -656,6 +655,14 @@ fport_flush (SCM port) count = remaining; } + else if (scm_gc_running_p) + { + /* silently ignore the error. scm_error would abort if we + called it now. */ + count = remaining; + } + else + scm_syserror ("fport_flush"); } ptr += count; remaining -= count; @@ -694,7 +701,14 @@ fport_close (SCM port) fport_flush (port); SCM_SYSCALL (rv = close (fp->fdes)); if (rv == -1 && errno != EBADF) - scm_syserror ("fport_close"); + { + if (scm_gc_running_p) + /* silently ignore the error. scm_error would abort if we + called it now. */ + ; + else + scm_syserror ("fport_close"); + } if (pt->read_buf == pt->putback_buf) pt->read_buf = pt->saved_read_buf; if (pt->read_buf != &pt->shortbuf) diff --git a/libguile/throw.c b/libguile/throw.c index afa9ffaec..dfcb4c44d 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -485,9 +485,6 @@ scm_handle_by_message (void *handler_data, SCM tag, SCM args) } handler_message (handler_data, tag, args); - /* try to flush the error message first before the rest of the - ports: if any throw error, it currently causes a bus - exception. */ exit (2); } From 8dc9439fc660ef7914d63fd8c1fc58092b5f6fa5 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 17 Nov 2000 16:25:05 +0000 Subject: [PATCH 0368/2047] * alist.c, arbiters.c, async.c, backtrace.c, boolean.c, chars.c, continuations.c, debug-malloc.c, debug.c, dynl.c, dynwind.c, environments.c, eq.c, error.c, eval.c, evalext.c, feature.c, filesys.c, fluids.c, fports.c, gc.c, goops.c, guardians.c, hash.c, hashtab.c, hooks.c, ioext.c, iselect.c, keywords.c, lang.c, list.c, load.c, macros.c, modules.c, net_db.c, numbers.c, objects.c, objprop.c, options.c, pairs.c, ports.c, posix.c, print.c, procprop.c, procs.c, properties.c, ramap.c, random.c, read.c, regex-posix.c, root.c, scmsigs.c, script.c, simpos.c, socket.c, sort.c, srcprop.c, stackchk.c, stacks.c, stime.c, strings.c, strop.c, strorder.c, strports.c, struct.c, symbols.c, tag.c, threads.c, throw.c, unif.c, variable.c, vectors.c, version.c, vports.c, weaks.c: Makes sure the snarfer output inclusion is disabled when the snarfer is run on the file. Thanks to Lars J. Aas! * Makefile.am: Install guile-procedures.txt in version-specific directory to enable multiple installed guile versions. Suggested by Karl M. Hegbloom + + * alist.c, arbiters.c, async.c, backtrace.c, boolean.c, chars.c, + continuations.c, debug-malloc.c, debug.c, dynl.c, dynwind.c, + environments.c, eq.c, error.c, eval.c, evalext.c, feature.c, + filesys.c, fluids.c, fports.c, gc.c, goops.c, guardians.c, hash.c, + hashtab.c, hooks.c, ioext.c, iselect.c, keywords.c, lang.c, + list.c, load.c, macros.c, modules.c, net_db.c, numbers.c, + objects.c, objprop.c, options.c, pairs.c, ports.c, posix.c, + print.c, procprop.c, procs.c, properties.c, ramap.c, random.c, + read.c, regex-posix.c, root.c, scmsigs.c, script.c, simpos.c, + socket.c, sort.c, srcprop.c, stackchk.c, stacks.c, stime.c, + strings.c, strop.c, strorder.c, strports.c, struct.c, symbols.c, + tag.c, threads.c, throw.c, unif.c, variable.c, vectors.c, + version.c, vports.c, weaks.c: Makes sure the snarfer output + inclusion is disabled when the snarfer is run on the file. Thanks + to Lars J. Aas! + + * Makefile.am: Install guile-procedures.txt in version-specific + directory to enable multiple installed guile versions. Suggested + by Karl M. Hegbloom * fports.c: include gc.h. diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 0d63b5c8b..b85f86373 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -200,7 +200,8 @@ guile-procedures.txt: guile.texi rm -f $@ makeinfo --force -o $@ $< || test -f $@ -pkgdata_DATA = guile-procedures.txt +schemelibdir = $(pkgdatadir)/$(VERSION) +schemelib_DATA = guile-procedures.txt ## Add -MG to make the .x magic work with auto-dep code. MKDEP = gcc -M -MG $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) diff --git a/libguile/alist.c b/libguile/alist.c index 31a9aabda..cd4f182ff 100644 --- a/libguile/alist.c +++ b/libguile/alist.c @@ -406,7 +406,9 @@ SCM_DEFINE (scm_assoc_remove_x, "assoc-remove!", 2, 0, 0, void scm_init_alist () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/alist.x" +#endif } diff --git a/libguile/arbiters.c b/libguile/arbiters.c index 414cbffa6..69e68d7f3 100644 --- a/libguile/arbiters.c +++ b/libguile/arbiters.c @@ -128,7 +128,9 @@ scm_init_arbiters () { scm_tc16_arbiter = scm_make_smob_type_mfpe ("arbiter", 0, scm_markcdr, NULL, prinarb, NULL); +#ifndef SCM_MAGIC_SNARFER #include "libguile/arbiters.x" +#endif } /* diff --git a/libguile/async.c b/libguile/async.c index 62008a39b..79baedda9 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -462,7 +462,9 @@ scm_init_async () tc16_async = scm_make_smob_type ("async", 0); scm_set_smob_mark (tc16_async, mark_async); +#ifndef SCM_MAGIC_SNARFER #include "libguile/async.x" +#endif } /* diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 6c2b4e3d8..9b279e15a 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -637,7 +637,9 @@ scm_init_backtrace () SCM f = scm_make_fluid (); scm_the_last_stack_fluid = scm_sysintern ("the-last-stack", f); +#ifndef SCM_MAGIC_SNARFER #include "libguile/backtrace.x" +#endif } /* diff --git a/libguile/boolean.c b/libguile/boolean.c index 6807d16b1..9fd89a611 100644 --- a/libguile/boolean.c +++ b/libguile/boolean.c @@ -76,7 +76,9 @@ SCM_DEFINE (scm_boolean_p, "boolean?", 1, 0, 0, void scm_init_boolean () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/boolean.x" +#endif } diff --git a/libguile/chars.c b/libguile/chars.c index f0c0637c1..38257012b 100644 --- a/libguile/chars.c +++ b/libguile/chars.c @@ -407,7 +407,9 @@ int scm_n_charnames = sizeof (scm_charnames) / sizeof (char *); void scm_init_chars () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/chars.x" +#endif } diff --git a/libguile/continuations.c b/libguile/continuations.c index 419a2f01b..2a3780074 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -235,7 +235,9 @@ scm_call_continuation (SCM cont, SCM val) void scm_init_continuations () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/continuations.x" +#endif } diff --git a/libguile/debug-malloc.c b/libguile/debug-malloc.c index a7c5974a3..d0fba532e 100644 --- a/libguile/debug-malloc.c +++ b/libguile/debug-malloc.c @@ -256,5 +256,8 @@ scm_debug_malloc_prehistory () void scm_init_debug_malloc () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/debug-malloc.x" +#endif } + diff --git a/libguile/debug.c b/libguile/debug.c index 72e7c2d53..93cbf6aa9 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -642,7 +642,9 @@ scm_init_debug () #endif scm_add_feature ("debug-extensions"); +#ifndef SCM_MAGIC_SNARFER #include "libguile/debug.x" +#endif } /* diff --git a/libguile/dynl.c b/libguile/dynl.c index 9d3346f1f..f9e984d6d 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -511,7 +511,9 @@ scm_init_dynamic_linking () scm_set_smob_mark (scm_tc16_dynamic_obj, mark_dynl_obj); scm_set_smob_print (scm_tc16_dynamic_obj, print_dynl_obj); sysdep_dynl_init (); +#ifndef SCM_MAGIC_SNARFER #include "libguile/dynl.x" +#endif } /* diff --git a/libguile/dynwind.c b/libguile/dynwind.c index 7a3f5437d..b131c0a8d 100644 --- a/libguile/dynwind.c +++ b/libguile/dynwind.c @@ -273,7 +273,9 @@ scm_init_dynwind () { tc16_guards = scm_make_smob_type_mfpe ("guards", 0, NULL, scm_free0, printguards, NULL); +#ifndef SCM_MAGIC_SNARFER #include "libguile/dynwind.x" +#endif } /* diff --git a/libguile/environments.c b/libguile/environments.c index ced455be7..d577e50ad 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -2317,7 +2317,9 @@ scm_environments_prehistory () void scm_init_environments () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/environments.x" +#endif } diff --git a/libguile/eq.c b/libguile/eq.c index 596a1ed30..275fa717f 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -205,7 +205,9 @@ SCM_DEFINE1 (scm_equal_p, "equal?", scm_tc7_rpsubr, void scm_init_eq () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/eq.x" +#endif } diff --git a/libguile/error.c b/libguile/error.c index 69f680ee5..56454c844 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -362,7 +362,9 @@ void scm_init_error () { #include "libguile/cpp_err_symbols.c" +#ifndef SCM_MAGIC_SNARFER #include "libguile/error.x" +#endif } diff --git a/libguile/eval.c b/libguile/eval.c index 5fa006362..18d0c315d 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3983,7 +3983,9 @@ scm_init_eval () scm_sym_trace = SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED)); #endif +#ifndef SCM_MAGIC_SNARFER #include "libguile/eval.x" +#endif scm_add_feature ("delay"); } diff --git a/libguile/evalext.c b/libguile/evalext.c index 124320503..b9e0130c3 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -148,7 +148,9 @@ void scm_init_evalext () { scm_make_synt (scm_s_set_x, scm_makmmacro, scm_m_generalized_set_x); +#ifndef SCM_MAGIC_SNARFER #include "libguile/evalext.x" +#endif } /* diff --git a/libguile/feature.c b/libguile/feature.c index 3829153ce..bd9c94aed 100644 --- a/libguile/feature.c +++ b/libguile/feature.c @@ -129,7 +129,9 @@ scm_init_feature() scm_sysintern ("char-code-limit", SCM_MAKINUM (SCM_CHAR_CODE_LIMIT)); +#ifndef SCM_MAGIC_SNARFER #include "libguile/feature.x" +#endif } /* diff --git a/libguile/filesys.c b/libguile/filesys.c index e8e62b1d5..eeb9611c8 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1478,7 +1478,9 @@ scm_sysintern ("F_SETOWN", scm_long2num (F_SETOWN)); scm_sysintern ("FD_CLOEXEC", scm_long2num (FD_CLOEXEC)); #endif +#ifndef SCM_MAGIC_SNARFER #include "libguile/filesys.x" +#endif } /* diff --git a/libguile/fluids.c b/libguile/fluids.c index 425956d41..b7e09c39c 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -260,7 +260,9 @@ scm_init_fluids () { scm_tc16_fluid = scm_make_smob_type_mfpe ("fluid", 0, NULL, NULL, print_fluid, NULL); +#ifndef SCM_MAGIC_SNARFER #include "libguile/fluids.x" +#endif } /* diff --git a/libguile/fports.c b/libguile/fports.c index 9438bbd0d..69bf89603 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -745,7 +745,9 @@ scm_make_fptob () void scm_init_fports () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/fports.x" +#endif scm_sysintern ("_IOFBF", SCM_MAKINUM (_IOFBF)); scm_sysintern ("_IOLBF", SCM_MAKINUM (_IOLBF)); scm_sysintern ("_IONBF", SCM_MAKINUM (_IONBF)); diff --git a/libguile/gc.c b/libguile/gc.c index 222553d3a..26c1c0c2a 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -2590,7 +2590,9 @@ scm_init_gc () scm_c_hook_add (&scm_after_gc_c_hook, mark_gc_async, NULL, 0); +#ifndef SCM_MAGIC_SNARFER #include "libguile/gc.x" +#endif } /* diff --git a/libguile/goops.c b/libguile/goops.c index 485d067a3..1c4cb1087 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -2718,7 +2718,9 @@ scm_init_goops (void) goops_rstate = scm_c_make_rstate ("GOOPS", 5); +#ifndef SCM_MAGIC_SNARFER #include "libguile/goops.x" +#endif list_of_no_method = scm_permanent_object (SCM_LIST1 (sym_no_method)); diff --git a/libguile/guardians.c b/libguile/guardians.c index ba092a86e..edaa8c8f8 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -334,7 +334,9 @@ scm_init_guardian() scm_c_hook_add (&scm_before_mark_c_hook, scm_guardian_gc_init, 0, 0); scm_c_hook_add (&scm_before_sweep_c_hook, scm_guardian_zombify, 0, 0); +#ifndef SCM_MAGIC_SNARFER #include "libguile/guardians.x" +#endif } /* diff --git a/libguile/hash.c b/libguile/hash.c index baf95532c..78ea1ab0f 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -252,7 +252,9 @@ SCM_DEFINE (scm_hash, "hash", 2, 0, 0, void scm_init_hash () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/hash.x" +#endif } diff --git a/libguile/hashtab.c b/libguile/hashtab.c index 0d3588910..1efb64781 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -558,7 +558,9 @@ scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table) void scm_init_hashtab () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/hashtab.x" +#endif } /* diff --git a/libguile/hooks.c b/libguile/hooks.c index 14609cb5e..a507f3367 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -354,7 +354,9 @@ scm_init_hooks () scm_set_smob_mark (scm_tc16_hook, scm_markcdr); scm_set_smob_print (scm_tc16_hook, print_hook); +#ifndef SCM_MAGIC_SNARFER #include "libguile/hooks.x" +#endif } /* diff --git a/libguile/ioext.c b/libguile/ioext.c index 6193679c1..b88dfa21b 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -562,7 +562,9 @@ scm_init_ioext () { scm_add_feature ("i/o-extensions"); +#ifndef SCM_MAGIC_SNARFER #include "libguile/ioext.x" +#endif } diff --git a/libguile/iselect.c b/libguile/iselect.c index ea0be94f0..d18213c4c 100644 --- a/libguile/iselect.c +++ b/libguile/iselect.c @@ -627,7 +627,9 @@ scm_init_iselect () timeout0.tv_usec = 0; #endif init_bc (0x80, 0, 0); +#ifndef SCM_MAGIC_SNARFER #include "libguile/iselect.x" +#endif } #endif /* GUILE_ISELECT */ diff --git a/libguile/keywords.c b/libguile/keywords.c index 45a40baca..017b6fc51 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -134,7 +134,9 @@ scm_init_keywords () scm_markcdr, NULL, prin_keyword, NULL); scm_keyword_obarray = scm_make_vector (SCM_MAKINUM (256), SCM_EOL); +#ifndef SCM_MAGIC_SNARFER #include "libguile/keywords.x" +#endif } diff --git a/libguile/lang.c b/libguile/lang.c index 5182ea619..e2c00d177 100644 --- a/libguile/lang.c +++ b/libguile/lang.c @@ -150,7 +150,9 @@ SCM_DEFINE1 (scm_nil_eq, "nil-eq", scm_tc7_rpsubr, void scm_init_lang () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/lang.x" +#endif scm_make_synt ("nil-while", scm_makacro, scm_m_while); } diff --git a/libguile/list.c b/libguile/list.c index d4305ee1f..5b0458ff7 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -827,7 +827,9 @@ SCM_DEFINE (scm_delete1_x, "delete1!", 2, 0, 0, void scm_init_list () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/list.x" +#endif } /* diff --git a/libguile/load.c b/libguile/load.c index ca84cc454..54df73186 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -517,7 +517,9 @@ scm_init_load () init_build_info (); +#ifndef SCM_MAGIC_SNARFER #include "libguile/load.x" +#endif } /* diff --git a/libguile/macros.c b/libguile/macros.c index 16562fcb9..977abd41d 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -181,7 +181,9 @@ scm_init_macros () { scm_tc16_macro = scm_make_smob_type_mfpe ("macro", 0, scm_markcdr, NULL, NULL, NULL); +#ifndef SCM_MAGIC_SNARFER #include "libguile/macros.x" +#endif } /* diff --git a/libguile/modules.c b/libguile/modules.c index 04ba8546d..9b06432d9 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -269,7 +269,9 @@ SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0, void scm_init_modules () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/modules.x" +#endif module_make_local_var_x = scm_sysintern ("module-make-local-var!", SCM_UNDEFINED); scm_eval_closure_tag = scm_make_smob_type ("eval-closure", 0); diff --git a/libguile/net_db.c b/libguile/net_db.c index c29597979..9e92c7071 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -569,7 +569,9 @@ scm_init_net_db () #endif scm_add_feature ("net-db"); +#ifndef SCM_MAGIC_SNARFER #include "libguile/net_db.x" +#endif } /* diff --git a/libguile/numbers.c b/libguile/numbers.c index a1491b8b7..08dc14e0b 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -4374,7 +4374,9 @@ scm_init_numbers () scm_dblprec = scm_dblprec - 1; } #endif /* DBL_DIG */ +#ifndef SCM_MAGIC_SNARFER #include "libguile/numbers.x" +#endif } /* diff --git a/libguile/objects.c b/libguile/objects.c index 5fe685349..3838a9c8c 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -484,7 +484,9 @@ scm_init_objects () SCM_SET_CLASS_DESTRUCTOR (et, scm_struct_free_entity); scm_sysintern ("", et); +#ifndef SCM_MAGIC_SNARFER #include "libguile/objects.x" +#endif } /* diff --git a/libguile/objprop.c b/libguile/objprop.c index 1a485b2d6..04b3106d8 100644 --- a/libguile/objprop.c +++ b/libguile/objprop.c @@ -121,7 +121,9 @@ void scm_init_objprop () { scm_object_whash = scm_make_weak_key_hash_table (SCM_MAKINUM (511)); +#ifndef SCM_MAGIC_SNARFER #include "libguile/objprop.x" +#endif } diff --git a/libguile/options.c b/libguile/options.c index 030cc2f7b..051286d5c 100644 --- a/libguile/options.c +++ b/libguile/options.c @@ -233,7 +233,9 @@ void scm_init_options () { protected_objects = scm_permanent_object (scm_cons (SCM_UNDEFINED, SCM_EOL)); +#ifndef SCM_MAGIC_SNARFER #include "libguile/options.x" +#endif } /* diff --git a/libguile/pairs.c b/libguile/pairs.c index 1b885c789..26ab6330f 100644 --- a/libguile/pairs.c +++ b/libguile/pairs.c @@ -171,7 +171,9 @@ scm_init_pairs () for (subnr = 0; cxrs [subnr]; subnr++) scm_make_subr(cxrs [subnr], scm_tc7_cxr, NULL); +#ifndef SCM_MAGIC_SNARFER #include "libguile/pairs.x" +#endif } diff --git a/libguile/ports.c b/libguile/ports.c index d868e2971..03284f879 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1441,7 +1441,9 @@ scm_init_ports () scm_tc16_void_port = scm_make_port_type ("void", fill_input_void_port, write_void_port); +#ifndef SCM_MAGIC_SNARFER #include "libguile/ports.x" +#endif } /* diff --git a/libguile/posix.c b/libguile/posix.c index 8dfd4175e..fb7d39308 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1314,7 +1314,9 @@ scm_sysintern ("PIPE_BUF", scm_long2num (PIPE_BUF)); #endif #include "libguile/cpp_sig_symbols.c" +#ifndef SCM_MAGIC_SNARFER #include "libguile/posix.x" +#endif } /* diff --git a/libguile/print.c b/libguile/print.c index a7408491e..ec80fc21b 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1149,7 +1149,9 @@ scm_init_print () scm_set_smob_mark (scm_tc16_port_with_ps, scm_markcdr); scm_set_smob_print (scm_tc16_port_with_ps, print_port_with_ps); +#ifndef SCM_MAGIC_SNARFER #include "libguile/print.x" +#endif } /* diff --git a/libguile/procprop.c b/libguile/procprop.c index b2e76bbb7..cd458eb99 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -247,7 +247,9 @@ SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0, void scm_init_procprop () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/procprop.x" +#endif } diff --git a/libguile/procs.c b/libguile/procs.c index f979cd097..1e48c3cff 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -390,7 +390,9 @@ scm_init_subr_table () void scm_init_procs () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/procs.x" +#endif } /* diff --git a/libguile/properties.c b/libguile/properties.c index cc5941d9f..5da889138 100644 --- a/libguile/properties.c +++ b/libguile/properties.c @@ -145,7 +145,9 @@ void scm_init_properties () { scm_properties_whash = scm_make_weak_key_hash_table (SCM_MAKINUM (511)); +#ifndef SCM_MAGIC_SNARFER #include "libguile/properties.x" +#endif } diff --git a/libguile/ramap.c b/libguile/ramap.c index 6aa7efbfd..b360dee29 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -2049,7 +2049,9 @@ scm_init_ramap () init_raprocs (ra_asubrs); scm_make_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p); scm_smobs[0x0ff & (scm_tc16_array >> 8)].equalp = scm_raequal; +#ifndef SCM_MAGIC_SNARFER #include "libguile/ramap.x" +#endif scm_add_feature (s_scm_array_for_each); } diff --git a/libguile/random.c b/libguile/random.c index 4ff289f4b..dd9a75e29 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -584,7 +584,9 @@ scm_init_random () for (i = m >> 1; i < m; ++i) scm_masktab[i] = m - 1; +#ifndef SCM_MAGIC_SNARFER #include "libguile/random.x" +#endif /* Check that the assumptions about bits per bignum digit are correct. */ #if SIZEOF_INT == 4 diff --git a/libguile/read.c b/libguile/read.c index 367decb11..8b23fb4bd 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -806,7 +806,9 @@ scm_init_read () SCM_CDRLOC (scm_sysintern ("read-hash-procedures", SCM_EOL)); scm_init_opts (scm_read_options, scm_read_opts, SCM_N_READ_OPTIONS); +#ifndef SCM_MAGIC_SNARFER #include "libguile/read.x" +#endif } /* diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index 9c79e23c5..6866fb071 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -293,7 +293,9 @@ scm_init_regex_posix () scm_sysintern ("regexp/notbol", scm_long2num (REG_NOTBOL)); scm_sysintern ("regexp/noteol", scm_long2num (REG_NOTEOL)); +#ifndef SCM_MAGIC_SNARFER #include "libguile/regex-posix.x" +#endif scm_add_feature ("regex"); } diff --git a/libguile/root.c b/libguile/root.c index 821d6f1a6..86eee6452 100644 --- a/libguile/root.c +++ b/libguile/root.c @@ -443,7 +443,9 @@ scm_init_root () scm_set_smob_mark (scm_tc16_root, mark_root); scm_set_smob_print (scm_tc16_root, print_root); +#ifndef SCM_MAGIC_SNARFER #include "libguile/root.x" +#endif } /* diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index 6d49e8e99..795367a29 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -543,7 +543,9 @@ scm_init_scmsigs () scm_sysintern ("SA_RESTART", scm_long2num (SA_RESTART)); #endif +#ifndef SCM_MAGIC_SNARFER #include "libguile/scmsigs.x" +#endif } diff --git a/libguile/script.c b/libguile/script.c index 2ab76161e..e031991d4 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -652,7 +652,9 @@ scm_shell (int argc, char **argv) void scm_init_script () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/script.x" +#endif } /* diff --git a/libguile/simpos.c b/libguile/simpos.c index d21c81d7e..041fe70d1 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -133,7 +133,9 @@ SCM_DEFINE (scm_primitive_exit, "primitive-exit", 0, 1, 0, void scm_init_simpos () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/simpos.x" +#endif } diff --git a/libguile/socket.c b/libguile/socket.c index ae799d963..3365f3ee4 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -976,7 +976,9 @@ scm_init_socket () scm_add_feature ("socket"); scm_init_addr_buffer (); +#ifndef SCM_MAGIC_SNARFER #include "libguile/socket.x" +#endif } diff --git a/libguile/sort.c b/libguile/sort.c index 154a9e2d3..e25f19cd9 100644 --- a/libguile/sort.c +++ b/libguile/sort.c @@ -924,7 +924,9 @@ SCM_DEFINE (scm_sort_list, "sort-list", 2, 0, 0, void scm_init_sort () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/sort.x" +#endif scm_add_feature ("sort"); } diff --git a/libguile/srcprop.c b/libguile/srcprop.c index 0ac089cfd..ca3907408 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -334,7 +334,9 @@ scm_init_srcprop () scm_sym_breakpoint = SCM_CAR (scm_sysintern ("breakpoint", SCM_UNDEFINED)); scm_sysintern ("source-whash", scm_source_whash); +#ifndef SCM_MAGIC_SNARFER #include "libguile/srcprop.x" +#endif } void diff --git a/libguile/stackchk.c b/libguile/stackchk.c index a2b0e4dcd..3b31ff263 100644 --- a/libguile/stackchk.c +++ b/libguile/stackchk.c @@ -104,7 +104,9 @@ scm_stack_report () void scm_init_stackchk () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/stackchk.x" +#endif } /* diff --git a/libguile/stacks.c b/libguile/stacks.c index 3b0535202..c048d94cd 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -743,7 +743,9 @@ scm_init_stacks () SCM_EOL))); scm_set_struct_vtable_name_x (scm_stack_type, SCM_CAR (scm_intern0 ("stack"))); +#ifndef SCM_MAGIC_SNARFER #include "libguile/stacks.x" +#endif } /* diff --git a/libguile/stime.c b/libguile/stime.c index 19c428dec..e5a524fcb 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -712,7 +712,9 @@ scm_init_stime() if (!scm_my_base) scm_my_base = mytime(); scm_add_feature ("current-time"); +#ifndef SCM_MAGIC_SNARFER #include "libguile/stime.x" +#endif } diff --git a/libguile/strings.c b/libguile/strings.c index 4b8d115e8..0427efcef 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -392,7 +392,9 @@ SCM_DEFINE (scm_make_shared_substring, "make-shared-substring", 1, 2, 0, void scm_init_strings () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/strings.x" +#endif } diff --git a/libguile/strop.c b/libguile/strop.c index 1ecf4258c..fb192c0a1 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -477,7 +477,9 @@ SCM_DEFINE (scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0, void scm_init_strop () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/strop.x" +#endif } /* diff --git a/libguile/strorder.c b/libguile/strorder.c index c370aca77..ddb83a19d 100644 --- a/libguile/strorder.c +++ b/libguile/strorder.c @@ -256,7 +256,9 @@ SCM_DEFINE1 (scm_string_ci_geq_p, "string-ci>=?", scm_tc7_rpsubr, void scm_init_strorder () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/strorder.x" +#endif } diff --git a/libguile/strports.c b/libguile/strports.c index 8717e9843..5a52165fd 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -432,7 +432,9 @@ scm_make_stptob () void scm_init_strports () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/strports.x" +#endif } diff --git a/libguile/struct.c b/libguile/struct.c index a47358516..20bddc79f 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -825,7 +825,9 @@ scm_init_struct () scm_sysintern ("vtable-index-vtable", SCM_MAKINUM (scm_vtable_index_vtable)); scm_sysintern ("vtable-index-printer", SCM_MAKINUM (scm_vtable_index_printer)); scm_sysintern ("vtable-offset-user", SCM_MAKINUM (scm_vtable_offset_user)); +#ifndef SCM_MAGIC_SNARFER #include "libguile/struct.x" +#endif } /* diff --git a/libguile/symbols.c b/libguile/symbols.c index 9dd80dd87..48c438d45 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -908,7 +908,9 @@ scm_init_symbols () { gensym_counter = 0; gentemp_counter = 0; +#ifndef SCM_MAGIC_SNARFER #include "libguile/symbols.x" +#endif } /* diff --git a/libguile/tag.c b/libguile/tag.c index ed60a0d1c..db385905f 100644 --- a/libguile/tag.c +++ b/libguile/tag.c @@ -218,7 +218,9 @@ SCM_DEFINE (scm_tag, "tag", 1, 0, 0, void scm_init_tag () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/tag.x" +#endif } diff --git a/libguile/threads.c b/libguile/threads.c index 5685a8907..8bedc5453 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -146,7 +146,9 @@ scm_init_threads (SCM_STACKITEM *i) scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (coop_m)); scm_tc16_condvar = scm_make_smob_type ("condition-variable", sizeof (coop_c)); +#ifndef SCM_MAGIC_SNARFER #include "libguile/threads.x" +#endif /* Initialize implementation specific details of the threads support */ scm_threads_init (i); } diff --git a/libguile/throw.c b/libguile/throw.c index dfcb4c44d..d0abcb8a0 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -706,7 +706,9 @@ scm_init_throw () NULL, print_lazy_catch, NULL); +#ifndef SCM_MAGIC_SNARFER #include "libguile/throw.x" +#endif } /* diff --git a/libguile/unif.c b/libguile/unif.c index 6d9fc67e7..a4119be8e 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -2557,7 +2557,9 @@ scm_init_unif () scm_raprin1, scm_array_equal_p); scm_add_feature ("array"); +#ifndef SCM_MAGIC_SNARFER #include "libguile/unif.x" +#endif } /* diff --git a/libguile/variable.c b/libguile/variable.c index 4dcfc0e67..304ea009b 100644 --- a/libguile/variable.c +++ b/libguile/variable.c @@ -235,7 +235,9 @@ scm_init_variable () scm_tc16_variable = scm_make_smob_type_mfpe ("variable", 0, scm_markvar, NULL, prin_var, var_equal); anonymous_variable_sym = SCM_CAR (scm_sysintern ("anonymous-variable", SCM_UNDEFINED)); +#ifndef SCM_MAGIC_SNARFER #include "libguile/variable.x" +#endif } diff --git a/libguile/vectors.c b/libguile/vectors.c index 1281ddcd5..9dd7d8b66 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -407,7 +407,9 @@ SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0, void scm_init_vectors () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/vectors.x" +#endif } diff --git a/libguile/version.c b/libguile/version.c index 053df21f2..98c8691e9 100644 --- a/libguile/version.c +++ b/libguile/version.c @@ -100,7 +100,9 @@ SCM_DEFINE (scm_version, "version", 0, 0, 0, void scm_init_version () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/version.x" +#endif } /* diff --git a/libguile/vports.c b/libguile/vports.c index 877da5c40..512d55862 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -211,7 +211,9 @@ scm_make_sfptob () void scm_init_vports () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/vports.x" +#endif } /* diff --git a/libguile/weaks.c b/libguile/weaks.c index 4d7d5a091..1d803401b 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -327,7 +327,9 @@ scm_weaks_prehistory () void scm_init_weaks () { +#ifndef SCM_MAGIC_SNARFER #include "libguile/weaks.x" +#endif } From fc40e1fd212ad5ba343c654b5f567ab98b8ab8bd Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sat, 18 Nov 2000 22:18:03 +0000 Subject: [PATCH 0369/2047] * Makefile.am (.c.x): don't prefix ".:" to $PATH when running guile-doc-snarf. it doesn't seem to do anything useful, but would fail if $PATH contained whitespace. Thanks to Lars J. Aas. --- libguile/ChangeLog | 6 ++++++ libguile/Makefile.am | 4 ++-- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 30eb1ca35..c6b092147 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2000-11-18 Gary Houston + + * Makefile.am (.c.x): don't prefix ".:" to $PATH when running + guile-doc-snarf. it doesn't seem to do anything useful, but would + fail if $PATH contained whitespace. Thanks to Lars J. Aas. + 2000-11-17 Marius Vollmer * alist.c, arbiters.c, async.c, backtrace.c, boolean.c, chars.c, diff --git a/libguile/Makefile.am b/libguile/Makefile.am index b85f86373..fb523e2aa 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -182,10 +182,10 @@ libpath.h: $(srcdir)/Makefile.in $(top_builddir)/config.status SUFFIXES = .x .doc .c.x: - PATH=.:${PATH} ./guile-doc-snarf $< $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \ + ./guile-doc-snarf $< $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \ || { rm $@; false; } .x.doc: - PATH=.:${PATH} ./guile-doc-snarf $(srcdir)/$*.c $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $(srcdir)/$*.c > /dev/null \ + ./guile-doc-snarf $(srcdir)/$*.c $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $(srcdir)/$*.c > /dev/null \ || { rm $@; false; } error.x: cpp_err_symbols.c From c2c276029351aeaade33050102e3f1a71e464015 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 19 Nov 2000 12:21:36 +0000 Subject: [PATCH 0370/2047] * configure.in: test $ac_cv_lib_readline_readline instead of $ac_cv_lib_readline_main. Thanks to Lars J. Aas. --- guile-readline/ChangeLog | 5 +++++ guile-readline/configure.in | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 43e7a2c72..cdb1174ca 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,8 @@ +2000-11-19 Gary Houston + + * configure.in: test $ac_cv_lib_readline_readline instead of + $ac_cv_lib_readline_main. Thanks to Lars J. Aas. + 2000-09-17 Marius Vollmer * configure.in: Check for curses, terminfo and termlib libraries diff --git a/guile-readline/configure.in b/guile-readline/configure.in index 8daafb5ab..1b0984023 100644 --- a/guile-readline/configure.in +++ b/guile-readline/configure.in @@ -90,7 +90,7 @@ if test "${ac_cv_var_rl_getc_function}" = "yes"; then AC_DEFINE(HAVE_RL_GETC_FUNCTION) fi -if test $ac_cv_lib_readline_main = yes \ +if test $ac_cv_lib_readline_readline = yes \ -a $ac_cv_var_rl_getc_function = no; then AC_MSG_WARN([*** libreadline is too old on your system.]) AC_MSG_WARN([*** You need readline version 2.1 or later.]) From f0942910aff219e4a153d6d2f446c100127b0048 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 21 Nov 2000 17:32:38 +0000 Subject: [PATCH 0371/2047] * Deprecated SCM_RWSTRINGP and SCM_VALIDATE_RWSTRING. * Prepared SCM_STRING_U?CHARS to replace SCM_ROU?CHARS. --- ChangeLog | 4 ++++ NEWS | 4 +++- RELEASE | 2 +- acconfig.h | 3 --- libguile/ChangeLog | 14 ++++++++++++++ libguile/ports.c | 1 + libguile/strings.c | 7 ++++++- libguile/strings.h | 14 +++++++++++--- 8 files changed, 40 insertions(+), 9 deletions(-) diff --git a/ChangeLog b/ChangeLog index d9012543f..e5cd22a1c 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2000-11-21 Dirk Herrmann + + * acconfig.h: Removed bogus #ifndef. Thanks to Lars J. Aas. + 2000-10-25 Mikael Djurfeldt * GUILE-VERSION (LIBGUILE_MAJOR_VERSION): Incremented major diff --git a/NEWS b/NEWS index 3ba743414..0e7a4976b 100644 --- a/NEWS +++ b/NEWS @@ -263,7 +263,7 @@ SCM_VALIDATE_STRINGORSUBSTR, SCM_FREEP, SCM_NFREEP, SCM_CHARS, SCM_UCHARS, SCM_VALIDATE_ROSTRING, SCM_VALIDATE_ROSTRING_COPY, SCM_VALIDATE_NULLORROSTRING_COPY, SCM_ROLENGTH, SCM_LENGTH, SCM_HUGE_LENGTH, SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR, -SCM_ROSTRINGP +SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of SCM_OUTOFRANGE. Use scm_memory_error instead of SCM_NALLOC. @@ -275,6 +275,8 @@ Use a type specific accessor instead of SCM(_|_RO|_HUGE_)LENGTH. Use SCM_VALIDATE_(SYMBOL|STRING) instead of SCM_VALIDATE_ROSTRING. Use SCM_STRING_COERCE_0TERMINATION_X instead of SCM_COERCE_SUBSTR. Use SCM_STRINGP or SCM_SYMBOLP instead of SCM_ROSTRINGP. +Use SCM_STRINGP instead of SCM_RWSTRINGP. +Use SCM_VALIDATE_STRING instead of SCM_VALIDATE_RWSTRING. ** Removed function: scm_struct_init diff --git a/RELEASE b/RELEASE index 37c17ffda..8ba49614f 100644 --- a/RELEASE +++ b/RELEASE @@ -49,7 +49,7 @@ In release 1.6: SCM_FREEP, SCM_NFREEP, SCM_CHARS, SCM_UCHARS, SCM_VALIDATE_ROSTRING, SCM_VALIDATE_ROSTRING_COPY, SCM_VALIDATE_NULLORROSTRING_COPY, SCM_ROLENGTH, SCM_LENGTH, SCM_HUGE_LENGTH, SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, - SCM_COERCE_SUBSTR, SCM_ROSTRINGP + SCM_COERCE_SUBSTR, SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING - remove scm_vector_set_length_x - remove function scm_call_catching_errors (replaced by catch functions from throw.[ch]) diff --git a/acconfig.h b/acconfig.h index b7b42bc3d..dd51a227e 100644 --- a/acconfig.h +++ b/acconfig.h @@ -44,9 +44,6 @@ * If you do not wish that, delete this exception notice. */ -#ifndef PORTSH -#define PORTSH - /* Define these two if you want support for debugging of Scheme programs. */ #undef DEBUG_EXTENSIONS diff --git a/libguile/ChangeLog b/libguile/ChangeLog index c6b092147..75f282ae5 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,17 @@ +2000-11-21 Dirk Herrmann + + * ports.c: Include eval.h. + + * strings.c (scm_string_set_x), strings.h (SCM_RWSTRINGP), + validate.h (SCM_VALIDATE_RWSTRING): Deprecate SCM_RWSTRINGP and + SCM_VALIDATE_RWSTRING. + + * strings.h (SCM_STRING_UCHARS, SCM_STRING_CHARS): Handle strings + and substrings uniformly. However, substring handling is + deprecated. + + (SCM_RWSTRINGP): Deprecated. + 2000-11-18 Gary Houston * Makefile.am (.c.x): don't prefix ".:" to $PATH when running diff --git a/libguile/ports.c b/libguile/ports.c index 03284f879..292daa984 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -47,6 +47,7 @@ #include #include "libguile/_scm.h" +#include "libguile/eval.h" #include "libguile/objects.h" #include "libguile/smob.h" #include "libguile/chars.h" diff --git a/libguile/strings.c b/libguile/strings.c index 0427efcef..bfd7caa9f 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -261,13 +261,18 @@ SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0, } #undef FUNC_NAME + SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0, (SCM str, SCM k, SCM chr), "Stores CHR in element K of STRING and returns an unspecified value.\n" "K must be a valid index of STR.") #define FUNC_NAME s_scm_string_set_x { - SCM_VALIDATE_RWSTRING (1,str); +#if (SCM_DEBUG_DEPRECATED == 0) + SCM_VALIDATE_RWSTRING (1, str); +#else + SCM_VALIDATE_STRING (1, str); +#endif SCM_VALIDATE_INUM_RANGE (2,k,0,SCM_STRING_LENGTH(str)); SCM_VALIDATE_CHAR (3,chr); SCM_STRING_UCHARS (str)[SCM_INUM (k)] = SCM_CHAR (chr); diff --git a/libguile/strings.h b/libguile/strings.h index 8e3ca5eb3..8503f3e32 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -52,13 +52,12 @@ #define SCM_STRINGP(x) (SCM_NIMP (x) && (SCM_TYP7S (x) == scm_tc7_string)) +#if (SCM_DEBUG_DEPRECATED == 1) #define SCM_STRING_UCHARS(x) ((unsigned char *) (SCM_CELL_WORD_1 (x))) #define SCM_STRING_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) +#endif #define SCM_STRING_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) -/* Is X a writable string (i.e., not a substring)? */ -#define SCM_RWSTRINGP(x) (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_string)) - #define SCM_STRING_COERCE_0TERMINATION_X(x) \ { if (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_substring)) \ x = scm_makfromstr (SCM_ROCHARS (x), SCM_STRING_LENGTH (x), 0); } @@ -89,7 +88,16 @@ extern void scm_init_strings (void); #define SCM_SLOPPY_STRINGP(x) (SCM_STRINGP(x)) #define SCM_NSTRINGP(x) (!SCM_STRINGP(x)) +#define SCM_RWSTRINGP(x) (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_string)) #define SCM_NRWSTRINGP(x) (! SCM_RWSTRINGP (x)) +#define SCM_STRING_UCHARS(x) \ + ((SCM_TYP7 (x) == scm_tc7_substring) \ + ? (unsigned char *) SCM_CELL_WORD_1 (SCM_CDDR (x)) + SCM_INUM (SCM_CADR (x)) \ + : (unsigned char *) SCM_CELL_WORD_1 (x)) +#define SCM_STRING_CHARS(x) \ + ((SCM_TYP7 (x) == scm_tc7_substring) \ + ? (char *) SCM_CELL_WORD_1 (SCM_CDDR (x)) + SCM_INUM (SCM_CADR (x)) \ + : (char *) SCM_CELL_WORD_1 (x)) extern SCM scm_make_shared_substring (SCM str, SCM frm, SCM to); #endif /* SCM_DEBUG_DEPRECATED == 0 */ From 395d8627b90c1b90b48f562436d189e037ff05a6 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 22 Nov 2000 09:16:06 +0000 Subject: [PATCH 0372/2047] * This patch belongs to the previous one, it deprecates SCM_VALIDATE_RWSTRING. --- libguile/validate.h | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/libguile/validate.h b/libguile/validate.h index e80f5708a..5250f7645 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -1,4 +1,4 @@ -/* $Id: validate.h,v 1.19 2000-10-30 11:42:26 dirk Exp $ */ +/* $Id: validate.h,v 1.20 2000-11-22 09:16:06 dirk Exp $ */ /* Copyright (C) 1999, 2000 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify @@ -132,13 +132,6 @@ cvar = SCM_STRING_CHARS(str); \ } while (0) -#define SCM_VALIDATE_RWSTRING(pos, str) \ - do { \ - SCM_ASSERT (SCM_STRINGP (str), str, pos, FUNC_NAME); \ - if (!SCM_RWSTRINGP (str)) \ - scm_misc_error (FUNC_NAME, "argument is a read-only string", str); \ - } while (0) - #define SCM_VALIDATE_REAL(pos, z) SCM_MAKE_VALIDATE (pos, z, REALP) #define SCM_VALIDATE_NUMBER_COPY(pos, z, cvar) \ @@ -416,6 +409,13 @@ cvar = SCM_ROCHARS(str); \ } while (0) +#define SCM_VALIDATE_RWSTRING(pos, str) \ + do { \ + SCM_ASSERT (SCM_STRINGP (str), str, pos, FUNC_NAME); \ + if (!SCM_RWSTRINGP (str)) \ + scm_misc_error (FUNC_NAME, "argument is a read-only string", str); \ + } while (0) + #endif /* SCM_DEBUG_DEPRECATED == 0 */ #endif From 34f0f2b8af3585c4057cf076739151accde02147 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 22 Nov 2000 11:20:03 +0000 Subject: [PATCH 0373/2047] * Deprecated macros SCM_ROCHARS and SCM_ROUCHARS. --- NEWS | 5 ++++- RELEASE | 3 ++- libguile/ChangeLog | 22 ++++++++++++++++++++++ libguile/dynl.c | 2 +- libguile/filesys.c | 6 +++--- libguile/gh_data.c | 4 ++-- libguile/hash.c | 3 +-- libguile/load.c | 10 +++++----- libguile/numbers.c | 2 +- libguile/ports.c | 2 +- libguile/posix.c | 6 +++--- libguile/print.c | 11 +++++------ libguile/random.c | 2 +- libguile/socket.c | 6 +++--- libguile/strings.c | 6 +++--- libguile/strings.h | 2 +- libguile/strop.c | 8 ++++---- libguile/strorder.c | 16 ++++++++-------- libguile/strports.c | 2 +- libguile/struct.c | 2 +- libguile/symbols.c | 8 ++++---- libguile/symbols.h | 21 ++++++++++----------- 22 files changed, 86 insertions(+), 63 deletions(-) diff --git a/NEWS b/NEWS index 0e7a4976b..99e6d6694 100644 --- a/NEWS +++ b/NEWS @@ -263,7 +263,8 @@ SCM_VALIDATE_STRINGORSUBSTR, SCM_FREEP, SCM_NFREEP, SCM_CHARS, SCM_UCHARS, SCM_VALIDATE_ROSTRING, SCM_VALIDATE_ROSTRING_COPY, SCM_VALIDATE_NULLORROSTRING_COPY, SCM_ROLENGTH, SCM_LENGTH, SCM_HUGE_LENGTH, SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR, -SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING +SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING, SCM_ROCHARS, +SCM_ROUCHARS Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of SCM_OUTOFRANGE. Use scm_memory_error instead of SCM_NALLOC. @@ -277,6 +278,8 @@ Use SCM_STRING_COERCE_0TERMINATION_X instead of SCM_COERCE_SUBSTR. Use SCM_STRINGP or SCM_SYMBOLP instead of SCM_ROSTRINGP. Use SCM_STRINGP instead of SCM_RWSTRINGP. Use SCM_VALIDATE_STRING instead of SCM_VALIDATE_RWSTRING. +Use SCM_STRING_CHARS instead of SCM_ROCHARS. +Use SCM_STRING_UCHARS instead of SCM_ROUCHARS. ** Removed function: scm_struct_init diff --git a/RELEASE b/RELEASE index 8ba49614f..98520bb76 100644 --- a/RELEASE +++ b/RELEASE @@ -49,7 +49,8 @@ In release 1.6: SCM_FREEP, SCM_NFREEP, SCM_CHARS, SCM_UCHARS, SCM_VALIDATE_ROSTRING, SCM_VALIDATE_ROSTRING_COPY, SCM_VALIDATE_NULLORROSTRING_COPY, SCM_ROLENGTH, SCM_LENGTH, SCM_HUGE_LENGTH, SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, - SCM_COERCE_SUBSTR, SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING + SCM_COERCE_SUBSTR, SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING, + SCM_ROCHARS, SCM_ROUCHARS - remove scm_vector_set_length_x - remove function scm_call_catching_errors (replaced by catch functions from throw.[ch]) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 75f282ae5..9934bd78a 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,25 @@ +2000-11-22 Dirk Herrmann + + * dynl.c (scm_make_argv_from_stringlist), filesys.c (scm_dirname, + scm_basename), gh_data.c (gh_scm2newstr, gh_get_substr), hash.c + (scm_hasher), load.c (scm_parse_path, scm_search_path, + scm_primitive_load_path), numbers.c (scm_string_to_number), + ports.c (scm_unread_string), posix.c (scm_convert_exec_args, + environ_list_to_c, scm_putenv), print.c (scm_iprin1, + scm_simple_format), random.c (scm_seed_to_random_state), socket.c + (scm_fill_sockaddr, scm_send, scm_sendto), strings.c + (scm_string_ref, scm_substring, scm_string_append), strings.h + (SCM_STRING_COERCE_0TERMINATION_X), strop.c (scm_i_index, + scm_string_to_list, scm_string_copy), strorder.c + (scm_string_equal_p, scm_string_ci_equal_p, scm_string_less_p, + scm_string_ci_less_p), strports.c (scm_mkstrport), struct.c + (scm_make_struct_layout), symbols.c (scm_string_to_symbol, + scm_string_to_obarray_symbol, scm_gensym, scm_gentemp): Replace + calls to SCM_ROU?CHARS with the corresponding call to + SCM_STRING_U?CHARS. + + * symbols.h (SCM_ROCHARS, SCM_ROUCHARS): Deprecated. + 2000-11-21 Dirk Herrmann * ports.c: Include eval.h. diff --git a/libguile/dynl.c b/libguile/dynl.c index f9e984d6d..f554c39c0 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -105,7 +105,7 @@ scm_make_argv_from_stringlist (SCM args,int *argcp,const char *subr,int argn) SCM_ASSERT (SCM_STRINGP (arg), args, argn, subr); len = SCM_STRING_LENGTH (arg); - src = SCM_ROCHARS (arg); + src = SCM_STRING_CHARS (arg); dst = (char *) scm_must_malloc (len + 1, subr); memcpy (dst, src, len); dst[len] = 0; diff --git a/libguile/filesys.c b/libguile/filesys.c index eeb9611c8..3340fe4cb 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1349,7 +1349,7 @@ SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0, SCM_VALIDATE_STRING (1,filename); - s = SCM_ROCHARS (filename); + s = SCM_STRING_CHARS (filename); len = SCM_STRING_LENGTH (filename); i = len - 1; @@ -1377,7 +1377,7 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0, int i, j, len, end; SCM_VALIDATE_STRING (1,filename); - f = SCM_ROCHARS (filename); + f = SCM_STRING_CHARS (filename); len = SCM_STRING_LENGTH (filename); if (SCM_UNBNDP (suffix)) @@ -1385,7 +1385,7 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0, else { SCM_VALIDATE_STRING (2, suffix); - s = SCM_ROCHARS (suffix); + s = SCM_STRING_CHARS (suffix); j = SCM_STRING_LENGTH (suffix) - 1; } i = len - 1; diff --git a/libguile/gh_data.c b/libguile/gh_data.c index abcf27808..2d11c54a7 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -542,7 +542,7 @@ gh_scm2newstr (SCM str, int *lenp) ret_str = (char *) scm_must_malloc ((len + 1) * sizeof (char), "gh_scm2newstr"); /* so we copy tmp_str to ret_str, which is what we will allocate */ - memcpy (ret_str, SCM_ROCHARS (str), len); /* test ROCHARS here -twp */ + memcpy (ret_str, SCM_STRING_CHARS (str), len); /* from now on we don't mind if str gets GC collected. */ scm_remember (&str); /* now make sure we null-terminate it */ @@ -573,7 +573,7 @@ gh_get_substr (SCM src, char *dst, int start, int len) src_len = SCM_STRING_LENGTH (src); effective_length = (len < src_len) ? len : src_len; - memcpy (dst + start, SCM_ROCHARS (src), effective_length * sizeof (char)); + memcpy (dst + start, SCM_STRING_CHARS (src), effective_length * sizeof (char)); /* FIXME: must signal an error if len > src_len */ scm_remember (&src); } diff --git a/libguile/hash.c b/libguile/hash.c index 78ea1ab0f..b26de9c04 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -119,9 +119,8 @@ scm_hasher(SCM obj, unsigned long n, scm_sizet d) obj = scm_number_to_string(obj, SCM_MAKINUM(10)); } case scm_tc7_string: - return scm_string_hash (SCM_STRING_UCHARS (obj), SCM_STRING_LENGTH (obj)) % n; case scm_tc7_substring: - return scm_string_hash (SCM_ROUCHARS (obj), SCM_STRING_LENGTH (obj)) % n; + return scm_string_hash (SCM_STRING_UCHARS (obj), SCM_STRING_LENGTH (obj)) % n; case scm_tc7_symbol: return SCM_SYMBOL_HASH (obj) % n; case scm_tc7_wvect: diff --git a/libguile/load.c b/libguile/load.c index 54df73186..162d338d4 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -232,7 +232,7 @@ SCM_DEFINE (scm_parse_path, "parse-path", 1, 1, 0, tail = SCM_EOL; return (SCM_FALSEP (path) ? tail - : scm_internal_parse_path (SCM_ROCHARS (path), tail)); + : scm_internal_parse_path (SCM_STRING_CHARS (path), tail)); } #undef FUNC_NAME @@ -282,7 +282,7 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, else SCM_VALIDATE_LIST (3,extensions); - filename_chars = SCM_ROCHARS (filename); + filename_chars = SCM_STRING_CHARS (filename); filename_len = SCM_STRING_LENGTH (filename); /* If FILENAME is absolute, return it unchanged. */ @@ -365,7 +365,7 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, /* Concatenate the path name and the filename. */ len = SCM_STRING_LENGTH (dir); - memcpy (buf, SCM_ROCHARS (dir), len); + memcpy (buf, SCM_STRING_CHARS (dir), len); if (len >= 1 && buf[len - 1] != '/') buf[len++] = '/'; memcpy (buf + len, filename_chars, filename_len); @@ -380,7 +380,7 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, struct stat mode; /* Concatenate the extension. */ - memcpy (buf + len, SCM_ROCHARS (ext), ext_len); + memcpy (buf + len, SCM_STRING_CHARS (ext), ext_len); buf[len + ext_len] = '\0'; /* If the file exists at all, we should return it. If the @@ -448,7 +448,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0, if (SCM_FALSEP (full_filename)) { int absolute = (SCM_STRING_LENGTH (filename) >= 1 - && SCM_ROCHARS (filename)[0] == '/'); + && SCM_STRING_CHARS (filename)[0] == '/'); SCM_MISC_ERROR ((absolute ? "Unable to load file ~S" : "Unable to find file ~S in load path"), diff --git a/libguile/numbers.c b/libguile/numbers.c index 08dc14e0b..588c4a0e5 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -2808,7 +2808,7 @@ SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0, int base; SCM_VALIDATE_STRING (1, string); SCM_VALIDATE_INUM_MIN_DEF_COPY (2,radix,2,10,base); - answer = scm_istring2number (SCM_ROCHARS (string), + answer = scm_istring2number (SCM_STRING_CHARS (string), SCM_STRING_LENGTH (string), base); return scm_return_first (answer, string); diff --git a/libguile/ports.c b/libguile/ports.c index 292daa984..f94d1c7cc 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1120,7 +1120,7 @@ SCM_DEFINE (scm_unread_string, "unread-string", 2, 0, 0, else SCM_VALIDATE_OPINPORT (2,port); - scm_ungets (SCM_ROCHARS (str), SCM_STRING_LENGTH (str), port); + scm_ungets (SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str), port); return str; } diff --git a/libguile/posix.c b/libguile/posix.c index fb7d39308..a8e88fc31 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -818,7 +818,7 @@ scm_convert_exec_args (SCM args, int argn, const char *subr) SCM_ASSERT (SCM_STRINGP (arg), args, argn, subr); len = SCM_STRING_LENGTH (arg); - src = SCM_ROCHARS (arg); + src = SCM_STRING_CHARS (arg); dst = (char *) scm_must_malloc (len + 1, subr); memcpy (dst, src, len); dst[len] = 0; @@ -893,7 +893,7 @@ environ_list_to_c (SCM envlist, int arg, const char *proc) SCM_ASSERT (SCM_STRINGP (str), envlist, arg, proc); len = SCM_STRING_LENGTH (str); - src = SCM_ROCHARS (str); + src = SCM_STRING_CHARS (str); result[i] = malloc (len + 1); if (result[i] == NULL) scm_memory_error (proc); @@ -1130,7 +1130,7 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0, ptr = malloc (SCM_STRING_LENGTH (str) + 1); if (ptr == NULL) SCM_MEMORY_ERROR; - strncpy (ptr, SCM_ROCHARS (str), SCM_STRING_LENGTH (str)); + strncpy (ptr, SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str)); ptr[SCM_STRING_LENGTH (str)] = 0; rv = putenv (ptr); if (rv < 0) diff --git a/libguile/print.c b/libguile/print.c index ec80fc21b..59004fd85 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -447,7 +447,7 @@ taloop: else if (SCM_STRINGP (name)) { scm_putc (' ', port); - scm_lfwrite (SCM_ROCHARS (name), SCM_STRING_LENGTH (name), port); + scm_lfwrite (SCM_STRING_CHARS (name), SCM_STRING_LENGTH (name), port); } if (!SCM_UNBNDP (code)) { @@ -483,20 +483,19 @@ taloop: scm_putc ('"', port); for (i = 0; i < SCM_STRING_LENGTH (exp); ++i) - switch (SCM_ROCHARS (exp)[i]) + switch (SCM_STRING_CHARS (exp)[i]) { case '"': case '\\': scm_putc ('\\', port); default: - scm_putc (SCM_ROCHARS (exp)[i], port); + scm_putc (SCM_STRING_CHARS (exp)[i], port); } scm_putc ('"', port); break; } else - scm_lfwrite (SCM_ROCHARS (exp), (scm_sizet) SCM_STRING_LENGTH (exp), - port); + scm_lfwrite (SCM_STRING_CHARS (exp), SCM_STRING_LENGTH (exp), port); break; case scm_tc7_symbol: { @@ -1000,7 +999,7 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, SCM_VALIDATE_STRING (2, message); SCM_VALIDATE_REST_ARGUMENT (args); - start = SCM_ROCHARS (message); + start = SCM_STRING_CHARS (message); end = start + SCM_STRING_LENGTH (message); for (p = start; p != end; ++p) if (*p == '~') diff --git a/libguile/random.c b/libguile/random.c index dd9a75e29..b33d4e3b8 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -405,7 +405,7 @@ SCM_DEFINE (scm_seed_to_random_state, "seed->random-state", 1, 0, 0, if (SCM_NUMBERP (seed)) seed = scm_number_to_string (seed, SCM_UNDEFINED); SCM_VALIDATE_STRING (1,seed); - return make_rstate (scm_c_make_rstate (SCM_ROCHARS (seed), + return make_rstate (scm_c_make_rstate (SCM_STRING_CHARS (seed), SCM_STRING_LENGTH (seed))); } #undef FUNC_NAME diff --git a/libguile/socket.c b/libguile/socket.c index 3365f3ee4..23f44851d 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -431,7 +431,7 @@ scm_fill_sockaddr (int fam,SCM address,SCM *args,int which_arg,const char *proc, memset (soka, 0, sizeof (struct sockaddr_un)); soka->sun_family = AF_UNIX; SCM_ASSERT (SCM_STRINGP (address), address, which_arg, proc); - memcpy (soka->sun_path, SCM_ROCHARS (address), + memcpy (soka->sun_path, SCM_STRING_CHARS (address), 1 + SCM_STRING_LENGTH (address)); *size = sizeof (struct sockaddr_un); return (struct sockaddr *) soka; @@ -738,7 +738,7 @@ SCM_DEFINE (scm_send, "send", 2, 1, 0, SCM_VALIDATE_INUM_DEF_COPY (3,flags,0,flg); fd = SCM_FPORT_FDES (sock); - SCM_SYSCALL (rv = send (fd, SCM_ROCHARS (message), SCM_STRING_LENGTH (message), flg)); + SCM_SYSCALL (rv = send (fd, SCM_STRING_CHARS (message), SCM_STRING_LENGTH (message), flg)); if (rv == -1) SCM_SYSERROR; return SCM_MAKINUM (rv); @@ -856,7 +856,7 @@ SCM_DEFINE (scm_sendto, "sendto", 4, 0, 1, SCM_VALIDATE_CONS (5,args_and_flags); flg = SCM_NUM2ULONG (5,SCM_CAR (args_and_flags)); } - SCM_SYSCALL (rv = sendto (fd, SCM_ROCHARS (message), SCM_STRING_LENGTH (message), + SCM_SYSCALL (rv = sendto (fd, SCM_STRING_CHARS (message), SCM_STRING_LENGTH (message), flg, soka, size)); save_err = errno; scm_must_free ((char *) soka); diff --git a/libguile/strings.c b/libguile/strings.c index bfd7caa9f..d17260746 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -257,7 +257,7 @@ SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0, SCM_VALIDATE_STRING (1, str); SCM_VALIDATE_INUM_COPY (2, k, idx); SCM_ASSERT_RANGE (2, k, idx >= 0 && idx < SCM_STRING_LENGTH (str)); - return SCM_MAKE_CHAR (SCM_ROUCHARS (str)[idx]); + return SCM_MAKE_CHAR (SCM_STRING_UCHARS (str)[idx]); } #undef FUNC_NAME @@ -302,7 +302,7 @@ SCM_DEFINE (scm_substring, "substring", 2, 1, 0, to = SCM_INUM (end); SCM_ASSERT_RANGE (3, end, from <= to && to <= SCM_STRING_LENGTH (str)); - return scm_makfromstr (&SCM_ROCHARS (str)[from], (scm_sizet) (to - from), 0); + return scm_makfromstr (&SCM_STRING_CHARS (str)[from], (scm_sizet) (to - from), 0); } #undef FUNC_NAME @@ -328,7 +328,7 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, data = SCM_STRING_UCHARS (res); for (l = args;SCM_NIMP (l);l = SCM_CDR (l)) { s = SCM_CAR (l); - for (i = 0;i 0) { - p = (unsigned char *)SCM_ROCHARS (*str) + lower; + p = SCM_STRING_UCHARS (*str) + lower; ch = SCM_CHAR (chr); for (x = SCM_INUM (sub_start); x < upper; ++x, ++p) @@ -91,7 +91,7 @@ scm_i_index (SCM *str, SCM chr, int direction, SCM sub_start, } else { - p = upper - 1 + (unsigned char *)SCM_ROCHARS (*str); + p = upper - 1 + SCM_STRING_UCHARS (*str); ch = SCM_CHAR (chr); for (x = upper - 1; x >= lower; --x, --p) if (*p == ch) @@ -327,7 +327,7 @@ SCM_DEFINE (scm_string_to_list, "string->list", 1, 0, 0, SCM res = SCM_EOL; unsigned char *src; SCM_VALIDATE_STRING (1,str); - src = SCM_ROUCHARS (str); + src = SCM_STRING_UCHARS (str); for (i = SCM_STRING_LENGTH (str)-1;i >= 0;i--) res = scm_cons (SCM_MAKE_CHAR (src[i]), res); return res; } @@ -341,7 +341,7 @@ SCM_DEFINE (scm_string_copy, "string-copy", 1, 0, 0, #define FUNC_NAME s_scm_string_copy { SCM_VALIDATE_STRING (1, str); - return scm_makfromstr (SCM_ROCHARS (str), SCM_STRING_LENGTH (str), 0); + return scm_makfromstr (SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str), 0); } #undef FUNC_NAME diff --git a/libguile/strorder.c b/libguile/strorder.c index ddb83a19d..815488a92 100644 --- a/libguile/strorder.c +++ b/libguile/strorder.c @@ -71,8 +71,8 @@ SCM_DEFINE1 (scm_string_equal_p, "string=?", scm_tc7_rpsubr, length = SCM_STRING_LENGTH (s2); if (SCM_STRING_LENGTH (s1) == length) { - unsigned char *c1 = SCM_ROUCHARS (s1) + length - 1; - unsigned char *c2 = SCM_ROUCHARS (s2) + length - 1; + unsigned char *c1 = SCM_STRING_UCHARS (s1) + length - 1; + unsigned char *c2 = SCM_STRING_UCHARS (s2) + length - 1; scm_sizet i; /* comparing from back to front typically finds mismatches faster */ @@ -105,8 +105,8 @@ SCM_DEFINE1 (scm_string_ci_equal_p, "string-ci=?", scm_tc7_rpsubr, length = SCM_STRING_LENGTH (s2); if (SCM_STRING_LENGTH (s1) == length) { - unsigned char *c1 = SCM_ROUCHARS (s1) + length - 1; - unsigned char *c2 = SCM_ROUCHARS (s2) + length - 1; + unsigned char *c1 = SCM_STRING_UCHARS (s1) + length - 1; + unsigned char *c2 = SCM_STRING_UCHARS (s2) + length - 1; scm_sizet i; /* comparing from back to front typically finds mismatches faster */ @@ -139,8 +139,8 @@ SCM_DEFINE1 (scm_string_less_p, "stringwrite_buf = pt->read_buf = SCM_ROUCHARS (str); + pt->write_buf = pt->read_buf = SCM_STRING_UCHARS (str); pt->read_pos = pt->write_pos = pt->read_buf + SCM_INUM (pos); pt->write_buf_size = pt->read_buf_size = str_len; pt->write_end = pt->read_end = pt->read_buf + pt->read_buf_size; diff --git a/libguile/struct.c b/libguile/struct.c index 20bddc79f..e6e0c5ec6 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -88,7 +88,7 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, int x; len = SCM_STRING_LENGTH (fields); - field_desc = SCM_ROCHARS (fields); + field_desc = SCM_STRING_CHARS (fields); SCM_ASSERT (!(len & 1), fields, "odd length field specification", FUNC_NAME); for (x = 0; x < len; x += 2) diff --git a/libguile/symbols.c b/libguile/symbols.c index 48c438d45..17d08981c 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -498,7 +498,7 @@ SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0, SCM answer; SCM_VALIDATE_STRING (1,s); - vcell = scm_intern (SCM_ROCHARS (s), SCM_STRING_LENGTH (s)); + vcell = scm_intern (SCM_STRING_CHARS (s), SCM_STRING_LENGTH (s)); answer = SCM_CAR (vcell); return answer; } @@ -534,7 +534,7 @@ SCM_DEFINE (scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, else if (SCM_EQ_P (o, SCM_BOOL_T)) o = SCM_BOOL_F; - vcell = scm_intern_obarray_soft (SCM_ROCHARS(s), + vcell = scm_intern_obarray_soft (SCM_STRING_CHARS(s), SCM_STRING_LENGTH (s), o, softness); @@ -837,7 +837,7 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, len = SCM_STRING_LENGTH (prefix); if (len > MAX_PREFIX_LENGTH) name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); - strncpy (name, SCM_ROCHARS (prefix), len); + strncpy (name, SCM_STRING_CHARS (prefix), len); } { int n_digits = scm_iint2str (gensym_counter++, 10, &name[len]); @@ -875,7 +875,7 @@ SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0, len = SCM_STRING_LENGTH (prefix); if (len > MAX_PREFIX_LENGTH) name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); - strncpy (name, SCM_ROCHARS (prefix), len); + strncpy (name, SCM_STRING_CHARS (prefix), len); } if (SCM_UNBNDP (obarray)) diff --git a/libguile/symbols.h b/libguile/symbols.h index 6160afc49..2654cf4fe 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -75,17 +75,6 @@ extern int scm_symhash_dim; #define SCM_SYMBOL_HASH(X) (SCM_CELL_WORD_2 (X)) #define SCM_SET_SYMBOL_HASH(X, v) (SCM_SET_CELL_WORD_2 ((X), (v))) -#define SCM_ROCHARS(x) ((SCM_TYP7 (x) == scm_tc7_substring) \ - ? (SCM_INUM (SCM_CADR (x)) + SCM_STRING_CHARS (SCM_CDDR (x))) \ - : ((SCM_TYP7 (x) == scm_tc7_string) \ - ? SCM_STRING_CHARS (x) \ - : SCM_SYMBOL_CHARS (x))) -#define SCM_ROUCHARS(x) ((SCM_TYP7 (x) == scm_tc7_substring) \ - ? (SCM_INUM (SCM_CADR (x)) + SCM_STRING_UCHARS (SCM_CDDR (x))) \ - : ((SCM_TYP7 (x) == scm_tc7_string) \ - ? SCM_STRING_UCHARS (x) \ - : SCM_SYMBOL_UCHARS (x))) - extern unsigned long scm_string_hash (const unsigned char *str, scm_sizet len); @@ -134,6 +123,16 @@ extern void scm_init_symbols (void); #define SCM_ROSTRINGP(x) (SCM_NIMP(x) && ((SCM_TYP7S(x)==scm_tc7_string) \ || (SCM_TYP7(x) == scm_tc7_symbol))) #define SCM_ROLENGTH(x) SCM_LENGTH (x) +#define SCM_ROCHARS(x) ((SCM_TYP7 (x) == scm_tc7_substring) \ + ? (SCM_INUM (SCM_CADR (x)) + SCM_STRING_CHARS (SCM_CDDR (x))) \ + : ((SCM_TYP7 (x) == scm_tc7_string) \ + ? SCM_STRING_CHARS (x) \ + : SCM_SYMBOL_CHARS (x))) +#define SCM_ROUCHARS(x) ((SCM_TYP7 (x) == scm_tc7_substring) \ + ? (SCM_INUM (SCM_CADR (x)) + SCM_STRING_UCHARS (SCM_CDDR (x))) \ + : ((SCM_TYP7 (x) == scm_tc7_string) \ + ? SCM_STRING_UCHARS (x) \ + : SCM_SYMBOL_UCHARS (x))) #define SCM_SUBSTRP(x) (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_substring)) #define SCM_COERCE_SUBSTR(x) SCM_STRING_COERCE_0TERMINATION_X (x) #define scm_strhash(str, len, n) (scm_string_hash ((str), (len)) % (n)) From bc0eaf7b78140d9215d2ae7b88ca93000145e4a3 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 22 Nov 2000 14:45:41 +0000 Subject: [PATCH 0374/2047] * Added SCM_SET_VECTOR_LENGTH as one replacement for SCM_SETLENGTH. --- NEWS | 4 ++++ libguile/ChangeLog | 7 +++++++ libguile/vectors.c | 2 +- libguile/vectors.h | 1 + libguile/weaks.c | 3 ++- 5 files changed, 15 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index 99e6d6694..bad32a89b 100644 --- a/NEWS +++ b/NEWS @@ -243,6 +243,10 @@ SCM_BITVECTOR_LENGTH, SCM_VECTOR_LENGTH. Use these instead of SCM_LENGTH. +** New macros: SCM_SET_VECTOR_LENGTH + +Use these instead of SCM_SETLENGTH + ** New macros: SCM_STRING_CHARS, SCM_SYMBOL_CHARS, SCM_CCLO_BASE, SCM_VECTOR_BASE, SCM_UVECTOR_BASE, SCM_BITVECTOR_BASE, SCM_COMPLEX_MEM, SCM_ARRAY_MEM diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 9934bd78a..c0901f54b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2000-11-22 Dirk Herrmann + + * vectors.c (scm_make_vector), weaks.c (scm_make_weak_vector): + Use SCM_SET_VECTOR_LENGTH instead of SCM_SETLENGTH. + + * vectors.h (SCM_SET_VECTOR_LENGTH): Added. + 2000-11-22 Dirk Herrmann * dynl.c (scm_make_argv_from_stringlist), filesys.c (scm_dirname, diff --git a/libguile/vectors.c b/libguile/vectors.c index 9dd7d8b66..f4225c754 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -293,7 +293,7 @@ SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0, velts[j] = SCM_UNPACK (fill); SCM_SETCHARS (v, velts); - SCM_SETLENGTH (v, i, scm_tc7_vector); + SCM_SET_VECTOR_LENGTH (v, i, scm_tc7_vector); } SCM_ALLOW_INTS; diff --git a/libguile/vectors.h b/libguile/vectors.h index 55404554d..3d64a1b91 100644 --- a/libguile/vectors.h +++ b/libguile/vectors.h @@ -54,6 +54,7 @@ #define SCM_VECTORP(x) (SCM_NIMP (x) && (SCM_TYP7S (x) == scm_tc7_vector)) #define SCM_VECTOR_BASE(x) ((scm_bits_t *) SCM_CELL_WORD_1 (x)) #define SCM_VECTOR_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) +#define SCM_SET_VECTOR_LENGTH(v, l, t) (SCM_SET_CELL_WORD_0 ((v), ((l) << 8) + (t))) #define SCM_VELTS(x) ((SCM *) SCM_CELL_WORD_1 (x)) #define SCM_VELTS_AS_STACKITEMS(x) ((SCM_STACKITEM *) SCM_CELL_WORD_1 (x)) diff --git a/libguile/weaks.c b/libguile/weaks.c index 1d803401b..e7f6cd89d 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -63,10 +63,11 @@ SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0, "@var{fill}. The default value for @var{fill} is the empty list.") #define FUNC_NAME s_scm_make_weak_vector { + /* Dirk:FIXME:: We should probably rather use a double cell for weak vectors. */ SCM v; v = scm_make_vector (scm_sum (k, SCM_MAKINUM (2)), fill); SCM_DEFER_INTS; - SCM_SETLENGTH(v, SCM_INUM (k), scm_tc7_wvect); + SCM_SET_VECTOR_LENGTH (v, SCM_INUM (k), scm_tc7_wvect); SCM_SETVELTS(v, SCM_VELTS(v) + 2); SCM_VELTS(v)[-2] = SCM_EOL; SCM_UNPACK (SCM_VELTS (v)[-1]) = 0; From d7cf43257826796a0503e33b162cb7424a65bdc4 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 22 Nov 2000 15:36:58 +0000 Subject: [PATCH 0375/2047] * Added SCM_SET_CONTINUATION_LENGTH to replace SCM_SETLENGTH. --- NEWS | 2 +- libguile/ChangeLog | 7 +++++++ libguile/continuations.c | 2 +- libguile/continuations.h | 1 + 4 files changed, 10 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index bad32a89b..052c16596 100644 --- a/NEWS +++ b/NEWS @@ -243,7 +243,7 @@ SCM_BITVECTOR_LENGTH, SCM_VECTOR_LENGTH. Use these instead of SCM_LENGTH. -** New macros: SCM_SET_VECTOR_LENGTH +** New macros: SCM_SET_CONTINUATION_LENGTH, SCM_SET_VECTOR_LENGTH Use these instead of SCM_SETLENGTH diff --git a/libguile/ChangeLog b/libguile/ChangeLog index c0901f54b..7beb584ec 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2000-11-22 Dirk Herrmann + + * continuations.c (scm_make_cont): Use + SCM_SET_CONTINUATION_LENGTH instead of SCM_SETLENGTH. + + * continuations.h (SCM_SET_CONTINUATION_LENGTH): Added. + 2000-11-22 Dirk Herrmann * vectors.c (scm_make_vector), weaks.c (scm_make_weak_vector): diff --git a/libguile/continuations.c b/libguile/continuations.c index 2a3780074..ca647b154 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -89,7 +89,7 @@ scm_make_cont (SCM *answer) SCM_THROW_VALUE (cont) = SCM_EOL; src = SCM_BASE (cont) = SCM_BASE (scm_rootcont); SCM_SEQ (cont) = SCM_SEQ (scm_rootcont); - SCM_SETLENGTH (cont, j, scm_tc7_contin); + SCM_SET_CONTINUATION_LENGTH (cont, j); SCM_EXIT_A_SECTION; #ifndef SCM_STACK_GROWS_UP src -= SCM_CONTINUATION_LENGTH (cont); diff --git a/libguile/continuations.h b/libguile/continuations.h index 11aa75c5a..d107f8797 100644 --- a/libguile/continuations.h +++ b/libguile/continuations.h @@ -64,6 +64,7 @@ typedef struct #define SCM_CONTREGS(x) ((scm_contregs *) SCM_CELL_WORD_1 (x)) #define SCM_SET_CONTREGS(x, r) (SCM_SET_CELL_WORD_1 ((x), (scm_bits_t) (r))) #define SCM_CONTINUATION_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) +#define SCM_SET_CONTINUATION_LENGTH(x, l) (SCM_SET_CELL_WORD_0 ((x), ((l) << 8) + scm_tc7_contin)) #define SCM_JMPBUF(x) ((SCM_CONTREGS (x))->jmpbuf) #define SCM_DYNENV(x) ((SCM_CONTREGS (x))->dynenv) From 9377887701ecd64970fb8c65929ab2e8516ca929 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 23 Nov 2000 08:59:22 +0000 Subject: [PATCH 0376/2047] * Deprecated SCM_SETLENGTH. --- NEWS | 7 +++++-- RELEASE | 2 +- libguile/ChangeLog | 16 ++++++++++++++++ libguile/gc.c | 10 ++++++++-- libguile/gh_data.c | 2 +- libguile/strings.c | 4 ++-- libguile/strings.h | 1 + libguile/symbols.c | 4 ++-- libguile/symbols.h | 3 ++- libguile/unif.c | 19 +++++++++++++++---- libguile/unif.h | 2 ++ 11 files changed, 55 insertions(+), 15 deletions(-) diff --git a/NEWS b/NEWS index 052c16596..0df20a281 100644 --- a/NEWS +++ b/NEWS @@ -243,7 +243,9 @@ SCM_BITVECTOR_LENGTH, SCM_VECTOR_LENGTH. Use these instead of SCM_LENGTH. -** New macros: SCM_SET_CONTINUATION_LENGTH, SCM_SET_VECTOR_LENGTH +** New macros: SCM_SET_CONTINUATION_LENGTH, SCM_SET_STRING_LENGTH, +SCM_SET_SYMBOL_LENGTH, SCM_SET_VECTOR_LENGTH, SCM_SET_UVECTOR_LENGTH, +SCM_SET_BITVECTOR_LENGTH Use these instead of SCM_SETLENGTH @@ -268,7 +270,7 @@ SCM_VALIDATE_ROSTRING, SCM_VALIDATE_ROSTRING_COPY, SCM_VALIDATE_NULLORROSTRING_COPY, SCM_ROLENGTH, SCM_LENGTH, SCM_HUGE_LENGTH, SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR, SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING, SCM_ROCHARS, -SCM_ROUCHARS +SCM_ROUCHARS, SCM_SETLENGTH Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of SCM_OUTOFRANGE. Use scm_memory_error instead of SCM_NALLOC. @@ -284,6 +286,7 @@ Use SCM_STRINGP instead of SCM_RWSTRINGP. Use SCM_VALIDATE_STRING instead of SCM_VALIDATE_RWSTRING. Use SCM_STRING_CHARS instead of SCM_ROCHARS. Use SCM_STRING_UCHARS instead of SCM_ROUCHARS. +Use a type specific setter macro instead of SCM_SETLENGTH. ** Removed function: scm_struct_init diff --git a/RELEASE b/RELEASE index 98520bb76..81fa9281d 100644 --- a/RELEASE +++ b/RELEASE @@ -50,7 +50,7 @@ In release 1.6: SCM_VALIDATE_ROSTRING_COPY, SCM_VALIDATE_NULLORROSTRING_COPY, SCM_ROLENGTH, SCM_LENGTH, SCM_HUGE_LENGTH, SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR, SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING, - SCM_ROCHARS, SCM_ROUCHARS + SCM_ROCHARS, SCM_ROUCHARS, SCM_SETLENGTH - remove scm_vector_set_length_x - remove function scm_call_catching_errors (replaced by catch functions from throw.[ch]) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 7beb584ec..5d47dbfb5 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,19 @@ +2000-11-22 Dirk Herrmann + + * gc.c (scm_gc_sweep), unif.c (scm_make_uve): Don't allocate or + free memory for empty bitvectors. + + * gh_data.c (makvect), strings.c (scm_makstr, scm_take_str), + symbols.c (scm_intern_obarray_soft, + scm_sysintern0_no_module_lookup), unif.c (scm_make_uve): Use + appropriate SCM_SET__LENGTH macro instead of SCM_SETLENGTH. + + * strings.h (SCM_SET_STRING_LENGTH), symbols.h + (SCM_SET_SYMBOL_LENGTH), unif.h (SCM_SET_UVECTOR_LENGTH, + SCM_SET_BITVECTOR_LENGTH): Added. + + * symbols.h (SCM_SETLENGTH): Deprecated. + 2000-11-22 Dirk Herrmann * continuations.c (scm_make_cont): Use diff --git a/libguile/gc.c b/libguile/gc.c index 26c1c0c2a..0a6e968f3 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1621,8 +1621,14 @@ scm_gc_sweep () #endif #ifdef HAVE_ARRAYS case scm_tc7_bvect: - m += sizeof (long) * ((SCM_BITVECTOR_LENGTH (scmptr) + SCM_LONG_BIT - 1) / SCM_LONG_BIT); - scm_must_free (SCM_BITVECTOR_BASE (scmptr)); + { + unsigned long int length = SCM_BITVECTOR_LENGTH (scmptr); + if (length > 0) + { + m += sizeof (long) * ((length + SCM_LONG_BIT - 1) / SCM_LONG_BIT); + scm_must_free (SCM_BITVECTOR_BASE (scmptr)); + } + } break; case scm_tc7_byvect: case scm_tc7_ivect: diff --git a/libguile/gh_data.c b/libguile/gh_data.c index 2d11c54a7..c16526bcf 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -170,7 +170,7 @@ makvect (char* m, int len, int type) SCM_NEWCELL (ans); SCM_DEFER_INTS; SCM_SETCHARS (ans, m); - SCM_SETLENGTH (ans, len, type); + SCM_SET_UVECTOR_LENGTH (ans, len, type); SCM_ALLOW_INTS; return ans; } diff --git a/libguile/strings.c b/libguile/strings.c index d17260746..470b3206f 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -133,7 +133,7 @@ scm_makstr (long len, int dummy) mem[len] = 0; SCM_NEWCELL (s); SCM_SETCHARS (s, mem); - SCM_SETLENGTH (s, len, scm_tc7_string); + SCM_SET_STRING_LENGTH (s, len); return s; } @@ -168,7 +168,7 @@ scm_take_str (char *s, int len) SCM answer; SCM_NEWCELL (answer); SCM_DEFER_INTS; - SCM_SETLENGTH (answer, len, scm_tc7_string); + SCM_SET_STRING_LENGTH (answer, len); scm_done_malloc (len + 1); SCM_SETCHARS (answer, s); SCM_ALLOW_INTS; diff --git a/libguile/strings.h b/libguile/strings.h index 343c655e6..b19707af9 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -57,6 +57,7 @@ #define SCM_STRING_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) #endif #define SCM_STRING_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) +#define SCM_SET_STRING_LENGTH(s, l) (SCM_SET_CELL_WORD_0 ((s), ((l) << 8) + scm_tc7_string)) #define SCM_STRING_COERCE_0TERMINATION_X(x) \ { if (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_substring)) \ diff --git a/libguile/symbols.c b/libguile/symbols.c index 17d08981c..074573100 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -294,7 +294,7 @@ scm_intern_obarray_soft (const char *name,scm_sizet len,SCM obarray,unsigned int SCM_SETCHARS (lsym, duplicate_string (name, len)); SCM_SET_SYMBOL_HASH (lsym, raw_hash); SCM_SET_PROP_SLOTS (lsym, scm_cons (SCM_BOOL_F, SCM_EOL)); - SCM_SETLENGTH (lsym, (long) len, scm_tc7_symbol); + SCM_SET_SYMBOL_LENGTH (lsym, (long) len); if (SCM_FALSEP (obarray)) { @@ -369,7 +369,7 @@ scm_sysintern0_no_module_lookup (const char *name) SCM_SETCHARS (lsym, name); SCM_SET_SYMBOL_HASH (lsym, raw_hash); SCM_SET_PROP_SLOTS (lsym, scm_cons (SCM_BOOL_F, SCM_EOL)); - SCM_SETLENGTH (lsym, (long) len, scm_tc7_symbol); + SCM_SET_SYMBOL_LENGTH (lsym, (long) len); lsym = scm_cons (lsym, SCM_UNDEFINED); SCM_VELTS (scm_symhash)[hash] = scm_cons (lsym, SCM_VELTS (scm_symhash)[hash]); diff --git a/libguile/symbols.h b/libguile/symbols.h index 2654cf4fe..2e32a422f 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -60,9 +60,9 @@ extern int scm_symhash_dim; #define SCM_SYMBOL_UCHARS(x) ((unsigned char *) (SCM_CELL_WORD_1 (x))) #define SCM_SYMBOL_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) #define SCM_SYMBOL_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) +#define SCM_SET_SYMBOL_LENGTH(s, l) (SCM_SET_CELL_WORD_0 ((s), ((l) << 8) + scm_tc7_symbol)) #define SCM_LENGTH_MAX (0xffffffL) -#define SCM_SETLENGTH(x, v, t) (SCM_SET_CELL_WORD_0 ((x), ((v) << 8) + (t))) #define SCM_SETCHARS(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_bits_t) (v))) @@ -120,6 +120,7 @@ extern void scm_init_symbols (void); #define SCM_SUBSTR_STR(x) (SCM_CDDR (x)) #define SCM_SUBSTR_OFFSET(x) (SCM_CADR (x)) #define SCM_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) +#define SCM_SETLENGTH(x, v, t) (SCM_SET_CELL_WORD_0 ((x), ((v) << 8) + (t))) #define SCM_ROSTRINGP(x) (SCM_NIMP(x) && ((SCM_TYP7S(x)==scm_tc7_string) \ || (SCM_TYP7(x) == scm_tc7_symbol))) #define SCM_ROLENGTH(x) SCM_LENGTH (x) diff --git a/libguile/unif.c b/libguile/unif.c index a4119be8e..77f9e7a42 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -162,8 +162,19 @@ scm_make_uve (long k, SCM prot) if (SCM_EQ_P (prot, SCM_BOOL_T)) { - i = sizeof (long) * ((k + SCM_LONG_BIT - 1) / SCM_LONG_BIT); - type = scm_tc7_bvect; + SCM_NEWCELL (v); + if (k > 0) + { + i = sizeof (long) * ((k + SCM_LONG_BIT - 1) / SCM_LONG_BIT); + SCM_SETCHARS (v, (char *) scm_must_malloc (i, "vector")); + SCM_SET_BITVECTOR_LENGTH (v, k); + } + else + { + SCM_SETCHARS (v, 0); + SCM_SET_BITVECTOR_LENGTH (v, 0); + } + return v; } else if (SCM_CHARP (prot) && (SCM_CHAR (prot) == '\0')) { @@ -173,7 +184,7 @@ scm_make_uve (long k, SCM prot) else if (SCM_CHARP (prot)) { i = sizeof (char) * k; - type = scm_tc7_string; + return scm_makstr (i, 0); } else if (SCM_INUMP (prot)) { @@ -229,7 +240,7 @@ scm_make_uve (long k, SCM prot) SCM_NEWCELL (v); SCM_DEFER_INTS; SCM_SETCHARS (v, (char *) scm_must_malloc (i ? i : 1, "vector")); - SCM_SETLENGTH (v, k, type); + SCM_SET_UVECTOR_LENGTH (v, k, type); SCM_ALLOW_INTS; return v; } diff --git a/libguile/unif.h b/libguile/unif.h index 932ceec82..4a859ce23 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -88,10 +88,12 @@ extern long scm_tc16_array; #define SCM_UVECTOR_BASE(x) ((void *) (SCM_CELL_WORD_1 (x))) #define SCM_UVECTOR_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) +#define SCM_SET_UVECTOR_LENGTH(v, l, t) (SCM_SET_CELL_WORD_0 ((v), ((l) << 8) + (t))) #define SCM_BITVECTOR_P(x) (!SCM_IMP (x) && (SCM_TYP7 (x) == scm_tc7_bvect)) #define SCM_BITVECTOR_BASE(x) ((void *) (SCM_CELL_WORD_1 (x))) #define SCM_BITVECTOR_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) +#define SCM_SET_BITVECTOR_LENGTH(v, l) (SCM_SET_CELL_WORD_0 ((v), ((l) << 8) + scm_tc7_bvect)) From 6a0476fd113e72d94277b7fd59a72db9bff66b28 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 23 Nov 2000 13:54:49 +0000 Subject: [PATCH 0377/2047] * SCM_SETCHARS deprecated. --- NEWS | 9 ++++++++- RELEASE | 2 +- libguile/ChangeLog | 15 +++++++++++++++ libguile/gh_data.c | 2 +- libguile/numbers.c | 5 ++--- libguile/numbers.h | 1 + libguile/strings.c | 4 ++-- libguile/strings.h | 1 + libguile/symbols.c | 4 ++-- libguile/symbols.h | 4 ++-- libguile/unif.c | 6 +++--- libguile/unif.h | 2 ++ libguile/vectors.c | 2 +- libguile/vectors.h | 1 + 14 files changed, 42 insertions(+), 16 deletions(-) diff --git a/NEWS b/NEWS index 0df20a281..70442dea5 100644 --- a/NEWS +++ b/NEWS @@ -255,6 +255,12 @@ SCM_ARRAY_MEM Use these instead of SCM_CHARS or SCM_VELTS. +** New macros: SCM_SET_BIGNUM_BASE, SCM_SET_STRING_CHARS, +SCM_SET_SYMBOL_CHARS, SCM_SET_UVECTOR_BASE, SCM_SET_BITVECTOR_BASE, +SCM_SET_VECTOR_BASE + +Use these instead of SCM_SETCHARS. + ** New macro: SCM_BITVECTOR_P ** New macro: SCM_STRING_COERCE_0TERMINATION_X @@ -270,7 +276,7 @@ SCM_VALIDATE_ROSTRING, SCM_VALIDATE_ROSTRING_COPY, SCM_VALIDATE_NULLORROSTRING_COPY, SCM_ROLENGTH, SCM_LENGTH, SCM_HUGE_LENGTH, SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR, SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING, SCM_ROCHARS, -SCM_ROUCHARS, SCM_SETLENGTH +SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of SCM_OUTOFRANGE. Use scm_memory_error instead of SCM_NALLOC. @@ -287,6 +293,7 @@ Use SCM_VALIDATE_STRING instead of SCM_VALIDATE_RWSTRING. Use SCM_STRING_CHARS instead of SCM_ROCHARS. Use SCM_STRING_UCHARS instead of SCM_ROUCHARS. Use a type specific setter macro instead of SCM_SETLENGTH. +Use a type specific setter macro instead of SCM_SETCHARS. ** Removed function: scm_struct_init diff --git a/RELEASE b/RELEASE index 81fa9281d..6c1360325 100644 --- a/RELEASE +++ b/RELEASE @@ -50,7 +50,7 @@ In release 1.6: SCM_VALIDATE_ROSTRING_COPY, SCM_VALIDATE_NULLORROSTRING_COPY, SCM_ROLENGTH, SCM_LENGTH, SCM_HUGE_LENGTH, SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR, SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING, - SCM_ROCHARS, SCM_ROUCHARS, SCM_SETLENGTH + SCM_ROCHARS, SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS - remove scm_vector_set_length_x - remove function scm_call_catching_errors (replaced by catch functions from throw.[ch]) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 5d47dbfb5..3743abeb7 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,18 @@ +2000-11-22 Dirk Herrmann + + * gh_data.c (makvect), numbers.c (scm_mkbig, scm_adjbig), + strings.c (scm_makstr, scm_take_str), symbols.c + (scm_intern_obarray_soft, scm_sysintern0_no_module_lookup), unif.c + (scm_make_uve), vectors.c (scm_make_vector): Use appropriate + SCM_SET__(CHARS|BASE) macro instead of SCM_SETCHARS. + + * numbers.h (SCM_SET_BIGNUM_BASE), strings.h + (SCM_SET_STRING_CHARS), symbols.h (SCM_SET_SYMBOL_CHARS), unif.h + (SCM_SET_UVECTOR_BASE, SCM_SET_BITVECTOR_BASE), vectors.h + (SCM_SET_VECTOR_BASE): Added. + + * symbols.c (SCM_SETCHARS): Deprecated. + 2000-11-22 Dirk Herrmann * gc.c (scm_gc_sweep), unif.c (scm_make_uve): Don't allocate or diff --git a/libguile/gh_data.c b/libguile/gh_data.c index c16526bcf..91403c363 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -169,7 +169,7 @@ makvect (char* m, int len, int type) SCM ans; SCM_NEWCELL (ans); SCM_DEFER_INTS; - SCM_SETCHARS (ans, m); + SCM_SET_UVECTOR_BASE (ans, m); SCM_SET_UVECTOR_LENGTH (ans, len, type); SCM_ALLOW_INTS; return ans; diff --git a/libguile/numbers.c b/libguile/numbers.c index 588c4a0e5..022c34cd9 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1323,8 +1323,7 @@ scm_mkbig (scm_sizet nlen, int sign) SCM_NEWCELL (v); SCM_DEFER_INTS; - SCM_SETCHARS (v, scm_must_malloc ((long) (nlen * sizeof (SCM_BIGDIG)), - s_bignum)); + SCM_SET_BIGNUM_BASE (v, scm_must_malloc (nlen * sizeof (SCM_BIGDIG), s_bignum)); SCM_SETNUMDIGS (v, nlen, sign); SCM_ALLOW_INTS; return v; @@ -1366,7 +1365,7 @@ scm_adjbig (SCM b, scm_sizet nlen) (long) (SCM_NUMDIGS (b) * sizeof (SCM_BIGDIG)), (long) (nsiz * sizeof (SCM_BIGDIG)), s_bignum)); - SCM_SETCHARS (b, digits); + SCM_SET_BIGNUM_BASE (b, digits); SCM_SETNUMDIGS (b, nsiz, SCM_BIGSIGN (b)); } SCM_ALLOW_INTS; diff --git a/libguile/numbers.h b/libguile/numbers.h index 2dc879ca4..6a78c5910 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -179,6 +179,7 @@ #define SCM_BIGSIZEFIELD 17 #define SCM_BIGSIGN(x) (SCM_CELL_WORD_0 (x) & SCM_BIGSIGNFLAG) #define SCM_BDIGITS(x) ((SCM_BIGDIG *) (SCM_CELL_WORD_1 (x))) +#define SCM_SET_BIGNUM_BASE(n, b) (SCM_SET_CELL_WORD_1 ((n), (b))) #define SCM_NUMDIGS(x) ((scm_sizet) (SCM_CELL_WORD_0 (x) >> SCM_BIGSIZEFIELD)) #define SCM_SETNUMDIGS(x, v, sign) \ SCM_SET_CELL_WORD_0 (x, \ diff --git a/libguile/strings.c b/libguile/strings.c index 470b3206f..677a1d4bd 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -132,7 +132,7 @@ scm_makstr (long len, int dummy) mem[len] = 0; SCM_NEWCELL (s); - SCM_SETCHARS (s, mem); + SCM_SET_STRING_CHARS (s, mem); SCM_SET_STRING_LENGTH (s, len); return s; @@ -170,7 +170,7 @@ scm_take_str (char *s, int len) SCM_DEFER_INTS; SCM_SET_STRING_LENGTH (answer, len); scm_done_malloc (len + 1); - SCM_SETCHARS (answer, s); + SCM_SET_STRING_CHARS (answer, s); SCM_ALLOW_INTS; return answer; } diff --git a/libguile/strings.h b/libguile/strings.h index b19707af9..53a6e2ba9 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -56,6 +56,7 @@ #define SCM_STRING_UCHARS(x) ((unsigned char *) (SCM_CELL_WORD_1 (x))) #define SCM_STRING_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) #endif +#define SCM_SET_STRING_CHARS(s, c) (SCM_SET_CELL_WORD_1 ((s), (c))) #define SCM_STRING_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_SET_STRING_LENGTH(s, l) (SCM_SET_CELL_WORD_0 ((s), ((l) << 8) + scm_tc7_string)) diff --git a/libguile/symbols.c b/libguile/symbols.c index 074573100..f3bd4a500 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -291,7 +291,7 @@ scm_intern_obarray_soft (const char *name,scm_sizet len,SCM obarray,unsigned int } SCM_NEWCELL2 (lsym); - SCM_SETCHARS (lsym, duplicate_string (name, len)); + SCM_SET_SYMBOL_CHARS (lsym, duplicate_string (name, len)); SCM_SET_SYMBOL_HASH (lsym, raw_hash); SCM_SET_PROP_SLOTS (lsym, scm_cons (SCM_BOOL_F, SCM_EOL)); SCM_SET_SYMBOL_LENGTH (lsym, (long) len); @@ -366,7 +366,7 @@ scm_sysintern0_no_module_lookup (const char *name) scm_sizet hash = raw_hash % scm_symhash_dim; SCM_NEWCELL2 (lsym); - SCM_SETCHARS (lsym, name); + SCM_SET_SYMBOL_CHARS (lsym, name); SCM_SET_SYMBOL_HASH (lsym, raw_hash); SCM_SET_PROP_SLOTS (lsym, scm_cons (SCM_BOOL_F, SCM_EOL)); SCM_SET_SYMBOL_LENGTH (lsym, (long) len); diff --git a/libguile/symbols.h b/libguile/symbols.h index 2e32a422f..949a28a81 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -59,13 +59,12 @@ extern int scm_symhash_dim; #define SCM_SYMBOLP(x) (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_symbol)) #define SCM_SYMBOL_UCHARS(x) ((unsigned char *) (SCM_CELL_WORD_1 (x))) #define SCM_SYMBOL_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) +#define SCM_SET_SYMBOL_CHARS(s, c) (SCM_SET_CELL_WORD_1 ((s), (c))) #define SCM_SYMBOL_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_SET_SYMBOL_LENGTH(s, l) (SCM_SET_CELL_WORD_0 ((s), ((l) << 8) + scm_tc7_symbol)) #define SCM_LENGTH_MAX (0xffffffL) -#define SCM_SETCHARS(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_bits_t) (v))) - #define SCM_PROP_SLOTS(X) (SCM_CELL_WORD_3 (X)) #define SCM_SET_PROP_SLOTS(X, v) (SCM_SET_CELL_WORD_3 ((X), (v))) #define SCM_SYMBOL_FUNC(X) (SCM_CAR (SCM_CELL_WORD_3 (X))) @@ -116,6 +115,7 @@ extern void scm_init_symbols (void); #define SCM_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) #define SCM_UCHARS(x) ((unsigned char *) (SCM_CELL_WORD_1 (x))) +#define SCM_SETCHARS(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_bits_t) (v))) #define SCM_SLOPPY_SUBSTRP(x) (SCM_SUBSTRP (x)) #define SCM_SUBSTR_STR(x) (SCM_CDDR (x)) #define SCM_SUBSTR_OFFSET(x) (SCM_CADR (x)) diff --git a/libguile/unif.c b/libguile/unif.c index 77f9e7a42..9af99a038 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -166,12 +166,12 @@ scm_make_uve (long k, SCM prot) if (k > 0) { i = sizeof (long) * ((k + SCM_LONG_BIT - 1) / SCM_LONG_BIT); - SCM_SETCHARS (v, (char *) scm_must_malloc (i, "vector")); + SCM_SET_BITVECTOR_BASE (v, (char *) scm_must_malloc (i, "vector")); SCM_SET_BITVECTOR_LENGTH (v, k); } else { - SCM_SETCHARS (v, 0); + SCM_SET_BITVECTOR_BASE (v, 0); SCM_SET_BITVECTOR_LENGTH (v, 0); } return v; @@ -239,7 +239,7 @@ scm_make_uve (long k, SCM prot) SCM_NEWCELL (v); SCM_DEFER_INTS; - SCM_SETCHARS (v, (char *) scm_must_malloc (i ? i : 1, "vector")); + SCM_SET_UVECTOR_BASE (v, (char *) scm_must_malloc (i ? i : 1, "vector")); SCM_SET_UVECTOR_LENGTH (v, k, type); SCM_ALLOW_INTS; return v; diff --git a/libguile/unif.h b/libguile/unif.h index 4a859ce23..3ac772d6f 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -87,11 +87,13 @@ extern long scm_tc16_array; #define SCM_ARRAY_DIMS(a) ((scm_array_dim *)((char *) SCM_ARRAY_MEM (a) + sizeof (scm_array))) #define SCM_UVECTOR_BASE(x) ((void *) (SCM_CELL_WORD_1 (x))) +#define SCM_SET_UVECTOR_BASE(v, b) (SCM_SET_CELL_WORD_1 ((v), (b))) #define SCM_UVECTOR_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_SET_UVECTOR_LENGTH(v, l, t) (SCM_SET_CELL_WORD_0 ((v), ((l) << 8) + (t))) #define SCM_BITVECTOR_P(x) (!SCM_IMP (x) && (SCM_TYP7 (x) == scm_tc7_bvect)) #define SCM_BITVECTOR_BASE(x) ((void *) (SCM_CELL_WORD_1 (x))) +#define SCM_SET_BITVECTOR_BASE(v, b) (SCM_SET_CELL_WORD_1 ((v), (b))) #define SCM_BITVECTOR_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_SET_BITVECTOR_LENGTH(v, l) (SCM_SET_CELL_WORD_0 ((v), ((l) << 8) + scm_tc7_bvect)) diff --git a/libguile/vectors.c b/libguile/vectors.c index f4225c754..3848a8bbb 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -292,7 +292,7 @@ SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0, for (j = 0; j != i; ++j) velts[j] = SCM_UNPACK (fill); - SCM_SETCHARS (v, velts); + SCM_SET_VECTOR_BASE (v, velts); SCM_SET_VECTOR_LENGTH (v, i, scm_tc7_vector); } SCM_ALLOW_INTS; diff --git a/libguile/vectors.h b/libguile/vectors.h index 3d64a1b91..69616f0ca 100644 --- a/libguile/vectors.h +++ b/libguile/vectors.h @@ -53,6 +53,7 @@ #define SCM_VECTORP(x) (SCM_NIMP (x) && (SCM_TYP7S (x) == scm_tc7_vector)) #define SCM_VECTOR_BASE(x) ((scm_bits_t *) SCM_CELL_WORD_1 (x)) +#define SCM_SET_VECTOR_BASE(v, b) (SCM_SET_CELL_WORD_1 ((v), (b))) #define SCM_VECTOR_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_SET_VECTOR_LENGTH(v, l, t) (SCM_SET_CELL_WORD_0 ((v), ((l) << 8) + (t))) From 5b9eb8ae1687cbbb2bbf2f74be7eaef790851160 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 23 Nov 2000 15:26:24 +0000 Subject: [PATCH 0378/2047] * Deprecated SCM_LENGTH_MAX. --- NEWS | 7 ++++++- RELEASE | 2 +- libguile/ChangeLog | 17 ++++++++++++++++- libguile/symbols.h | 3 +-- libguile/unif.c | 18 ++++++------------ libguile/unif.h | 2 ++ 6 files changed, 32 insertions(+), 17 deletions(-) diff --git a/NEWS b/NEWS index 70442dea5..dca5b9aee 100644 --- a/NEWS +++ b/NEWS @@ -237,6 +237,10 @@ collector has set this variable. But, this is an implementation detail that may change. Further, scm_gc_heap_lock is not set throughout gc, thus the use of this variable is (and has been) not fully safe anyway. +** New macros: SCM_BITVECTOR_MAX_LENGTH, SCM_UVECTOR_MAX_LENGTH + +Use these instead of SCM_LENGTH_MAX. + ** New macros: SCM_CONTINUATION_LENGTH, SCM_CCLO_LENGTH, SCM_STACK_LENGTH, SCM_STRING_LENGTH, SCM_SYMBOL_LENGTH, SCM_UVECTOR_LENGTH, SCM_BITVECTOR_LENGTH, SCM_VECTOR_LENGTH. @@ -276,7 +280,7 @@ SCM_VALIDATE_ROSTRING, SCM_VALIDATE_ROSTRING_COPY, SCM_VALIDATE_NULLORROSTRING_COPY, SCM_ROLENGTH, SCM_LENGTH, SCM_HUGE_LENGTH, SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR, SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING, SCM_ROCHARS, -SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS +SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS, SCM_LENGTH_MAX Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of SCM_OUTOFRANGE. Use scm_memory_error instead of SCM_NALLOC. @@ -294,6 +298,7 @@ Use SCM_STRING_CHARS instead of SCM_ROCHARS. Use SCM_STRING_UCHARS instead of SCM_ROUCHARS. Use a type specific setter macro instead of SCM_SETLENGTH. Use a type specific setter macro instead of SCM_SETCHARS. +Use a type specific length macro instead of SCM_LENGTH_MAX. ** Removed function: scm_struct_init diff --git a/RELEASE b/RELEASE index 6c1360325..ca5ae7ffb 100644 --- a/RELEASE +++ b/RELEASE @@ -50,7 +50,7 @@ In release 1.6: SCM_VALIDATE_ROSTRING_COPY, SCM_VALIDATE_NULLORROSTRING_COPY, SCM_ROLENGTH, SCM_LENGTH, SCM_HUGE_LENGTH, SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR, SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING, - SCM_ROCHARS, SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS + SCM_ROCHARS, SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS, SCM_LENGTH_MAX - remove scm_vector_set_length_x - remove function scm_call_catching_errors (replaced by catch functions from throw.[ch]) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 3743abeb7..aef92d226 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,4 +1,19 @@ -2000-11-22 Dirk Herrmann +2000-11-23 Dirk Herrmann + + * symbols.h (SCM_LENGTH_MAX): Deprecated. + + * unif.c (scm_make_uve): Use SCM_BITVECTOR_MAX_LENGTH and + SCM_UVECTOR_MAX_LENGTH instead of SCM_LENGTH_MAX. Postpone length + checks for strings and vectors to their constructors. Eliminate + redundant SCM_IMP test. + + (scm_dimensions_to_uniform_array): Postpone length checks to + scm_make_uve. + + * unif.h (SCM_BITVECTOR_MAX_LENGTH, SCM_UVECTOR_MAX_LENGTH): + Added. + +2000-11-23 Dirk Herrmann * gh_data.c (makvect), numbers.c (scm_mkbig, scm_adjbig), strings.c (scm_makstr, scm_take_str), symbols.c diff --git a/libguile/symbols.h b/libguile/symbols.h index 949a28a81..db846f2c7 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -63,8 +63,6 @@ extern int scm_symhash_dim; #define SCM_SYMBOL_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_SET_SYMBOL_LENGTH(s, l) (SCM_SET_CELL_WORD_0 ((s), ((l) << 8) + scm_tc7_symbol)) -#define SCM_LENGTH_MAX (0xffffffL) - #define SCM_PROP_SLOTS(X) (SCM_CELL_WORD_3 (X)) #define SCM_SET_PROP_SLOTS(X, v) (SCM_SET_CELL_WORD_3 ((X), (v))) #define SCM_SYMBOL_FUNC(X) (SCM_CAR (SCM_CELL_WORD_3 (X))) @@ -119,6 +117,7 @@ extern void scm_init_symbols (void); #define SCM_SLOPPY_SUBSTRP(x) (SCM_SUBSTRP (x)) #define SCM_SUBSTR_STR(x) (SCM_CDDR (x)) #define SCM_SUBSTR_OFFSET(x) (SCM_CADR (x)) +#define SCM_LENGTH_MAX (0xffffffL) #define SCM_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_SETLENGTH(x, v, t) (SCM_SET_CELL_WORD_0 ((x), ((v) << 8) + (t))) #define SCM_ROSTRINGP(x) (SCM_NIMP(x) && ((SCM_TYP7S(x)==scm_tc7_string) \ diff --git a/libguile/unif.c b/libguile/unif.c index 9af99a038..4eccbc338 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -158,13 +158,12 @@ scm_make_uve (long k, SCM prot) SCM v; long i, type; - SCM_ASSERT_RANGE (1, scm_long2num (k), k <= SCM_LENGTH_MAX); - if (SCM_EQ_P (prot, SCM_BOOL_T)) { SCM_NEWCELL (v); if (k > 0) { + SCM_ASSERT_RANGE (1, scm_long2num (k), k <= SCM_BITVECTOR_MAX_LENGTH); i = sizeof (long) * ((k + SCM_LONG_BIT - 1) / SCM_LONG_BIT); SCM_SET_BITVECTOR_BASE (v, (char *) scm_must_malloc (i, "vector")); SCM_SET_BITVECTOR_LENGTH (v, k); @@ -180,7 +179,7 @@ scm_make_uve (long k, SCM prot) { i = sizeof (char) * k; type = scm_tc7_byvect; - } + } else if (SCM_CHARP (prot)) { i = sizeof (char) * k; @@ -216,8 +215,7 @@ scm_make_uve (long k, SCM prot) return scm_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED); } } - else - if (SCM_IMP (prot) || !SCM_INEXACTP (prot)) + else if (!SCM_INEXACTP (prot)) /* Huge non-unif vectors are NOT supported. */ /* no special scm_vector */ return scm_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED); @@ -237,6 +235,8 @@ scm_make_uve (long k, SCM prot) type = scm_tc7_dvect; } + SCM_ASSERT_RANGE (1, scm_long2num (k), k <= SCM_UVECTOR_MAX_LENGTH); + SCM_NEWCELL (v); SCM_DEFER_INTS; SCM_SET_UVECTOR_BASE (v, (char *) scm_must_malloc (i ? i : 1, "vector")); @@ -581,11 +581,7 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, SCM ra; if (SCM_INUMP (dims)) { - SCM answer; - - SCM_ASSERT_RANGE (1, dims, SCM_INUM (dims) <= SCM_LENGTH_MAX); - - answer = scm_make_uve (SCM_INUM (dims), prot); + SCM answer = scm_make_uve (SCM_INUM (dims), prot); if (!SCM_UNBNDP (fill)) scm_array_fill_x (answer, fill); else if (SCM_SYMBOLP (prot)) @@ -607,8 +603,6 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc; } - SCM_ASSERT_RANGE (1, dims, rlen <= SCM_LENGTH_MAX); - SCM_ARRAY_V (ra) = scm_make_uve (rlen, prot); if (!SCM_UNBNDP (fill)) diff --git a/libguile/unif.h b/libguile/unif.h index 3ac772d6f..432ac0e11 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -88,12 +88,14 @@ extern long scm_tc16_array; #define SCM_UVECTOR_BASE(x) ((void *) (SCM_CELL_WORD_1 (x))) #define SCM_SET_UVECTOR_BASE(v, b) (SCM_SET_CELL_WORD_1 ((v), (b))) +#define SCM_UVECTOR_MAX_LENGTH (0xffffffL) #define SCM_UVECTOR_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_SET_UVECTOR_LENGTH(v, l, t) (SCM_SET_CELL_WORD_0 ((v), ((l) << 8) + (t))) #define SCM_BITVECTOR_P(x) (!SCM_IMP (x) && (SCM_TYP7 (x) == scm_tc7_bvect)) #define SCM_BITVECTOR_BASE(x) ((void *) (SCM_CELL_WORD_1 (x))) #define SCM_SET_BITVECTOR_BASE(v, b) (SCM_SET_CELL_WORD_1 ((v), (b))) +#define SCM_BITVECTOR_MAX_LENGTH (0xffffffL) #define SCM_BITVECTOR_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_SET_BITVECTOR_LENGTH(v, l) (SCM_SET_CELL_WORD_0 ((v), ((l) << 8) + scm_tc7_bvect)) From 08b5e6c31617be5dfc139891e177c482654730ef Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 24 Nov 2000 10:24:04 +0000 Subject: [PATCH 0379/2047] * Don't uses anything deprecated any more. --- guile-readline/ChangeLog | 10 ++++++++++ guile-readline/readline.c | 20 ++++++++++---------- 2 files changed, 20 insertions(+), 10 deletions(-) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index cdb1174ca..a26018ea2 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,13 @@ +2000-11-24 Dirk Herrmann + + * readline.c (scm_readline, scm_add_history, completion_function, + scm_filename_completion_function): Replace calls to + SCM_COERCE_SUBSTR with SCM_STRING_COERCE_0TERMINATION_X. + + (internal_readline, scm_add_history, scm_read_history, + scm_write_history, scm_filename_completion_function, + completion_function): Replace SCM_CHARS with SCM_STRING_CHARS. + 2000-11-19 Gary Houston * configure.in: test $ac_cv_lib_readline_readline instead of diff --git a/guile-readline/readline.c b/guile-readline/readline.c index 8d6f6fc3c..228b42705 100644 --- a/guile-readline/readline.c +++ b/guile-readline/readline.c @@ -172,7 +172,7 @@ SCM_DEFINE (scm_readline, "%readline", 0, 4, 0, --in_readline; scm_wrong_type_arg (s_scm_readline, SCM_ARG1, text); } - SCM_COERCE_SUBSTR (text); + SCM_STRING_COERCE_0TERMINATION_X (text); } if (!((SCM_UNBNDP (inp) && SCM_NIMP (scm_cur_inp) && SCM_OPINFPORTP (inp)) @@ -256,7 +256,7 @@ internal_readline (SCM text) { SCM ret; char *s; - char *prompt = SCM_UNBNDP (text) ? "" : SCM_CHARS (text); + char *prompt = SCM_UNBNDP (text) ? "" : SCM_STRING_CHARS (text); promptp = 1; s = readline (prompt); @@ -328,9 +328,9 @@ SCM_DEFINE (scm_add_history, "add-history", 1, 0, 0, { char* s; SCM_VALIDATE_STRING (1,text); - SCM_COERCE_SUBSTR (text); + SCM_STRING_COERCE_0TERMINATION_X (text); - s = SCM_CHARS (text); + s = SCM_STRING_CHARS (text); add_history (strdup (s)); return SCM_UNSPECIFIED; @@ -344,7 +344,7 @@ SCM_DEFINE (scm_read_history, "read-history", 1, 0, 0, #define FUNC_NAME s_scm_read_history { SCM_VALIDATE_STRING (1,file); - return SCM_NEGATE_BOOL(read_history (SCM_ROCHARS (file))); + return SCM_NEGATE_BOOL (read_history (SCM_STRING_CHARS (file))); } #undef FUNC_NAME @@ -355,7 +355,7 @@ SCM_DEFINE (scm_write_history, "write-history", 1, 0, 0, #define FUNC_NAME s_scm_write_history { SCM_VALIDATE_STRING (1,file); - return SCM_NEGATE_BOOL(write_history (SCM_ROCHARS (file))); + return SCM_NEGATE_BOOL (write_history (SCM_STRING_CHARS (file))); } #undef FUNC_NAME @@ -368,8 +368,8 @@ SCM_DEFINE (scm_filename_completion_function, "filename-completion-function", 2, char *s; SCM ans; SCM_VALIDATE_STRING (1,text); - SCM_COERCE_SUBSTR (text); - s = filename_completion_function (SCM_CHARS (text), SCM_NFALSEP (continuep)); + SCM_STRING_COERCE_0TERMINATION_X (text); + s = filename_completion_function (SCM_STRING_CHARS (text), SCM_NFALSEP (continuep)); ans = scm_makfrom0str (s); free (s); return ans; @@ -404,8 +404,8 @@ completion_function (char *text, int continuep) scm_misc_error (s_scm_readline, "Completion function returned bogus value: %S", SCM_LIST1 (res)); - SCM_COERCE_SUBSTR (res); - return strdup (SCM_CHARS (res)); + SCM_STRING_COERCE_0TERMINATION_X (res); + return strdup (SCM_STRING_CHARS (res)); } } From 379b35daaa0d13f9e77979b358cec0c17861d29e Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 24 Nov 2000 10:38:57 +0000 Subject: [PATCH 0380/2047] * Fixed readline default input/output port parameter handling. * Removed redundant SCM_N?IMP tests. --- guile-readline/ChangeLog | 11 +++++++++++ guile-readline/readline.c | 18 +++++++++--------- 2 files changed, 20 insertions(+), 9 deletions(-) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index a26018ea2..7b762054b 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,14 @@ +2000-11-24 Dirk Herrmann + + * readline.c (current_input_getc): Use more explicit predicate + than SCM_NIMP. + + (scm_readline, scm_readline_init_ports, completion_function): + Remove redundant SCM_N?IMP tests. + + (scm_readline): Fixed default input/output port parameter + handling. + 2000-11-24 Dirk Herrmann * readline.c (scm_readline, scm_add_history, completion_function, diff --git a/guile-readline/readline.c b/guile-readline/readline.c index 228b42705..037bcf7a2 100644 --- a/guile-readline/readline.c +++ b/guile-readline/readline.c @@ -129,7 +129,7 @@ static SCM before_read; static int current_input_getc (FILE *in) { - if (promptp && SCM_NIMP (before_read)) + if (promptp && !SCM_FALSEP (before_read)) { scm_apply (before_read, SCM_EOL, SCM_EOL); promptp = 0; @@ -167,7 +167,7 @@ SCM_DEFINE (scm_readline, "%readline", 0, 4, 0, if (!SCM_UNBNDP (text)) { - if (!(SCM_NIMP (text) && SCM_STRINGP (text))) + if (!SCM_STRINGP (text)) { --in_readline; scm_wrong_type_arg (s_scm_readline, SCM_ARG1, text); @@ -175,8 +175,8 @@ SCM_DEFINE (scm_readline, "%readline", 0, 4, 0, SCM_STRING_COERCE_0TERMINATION_X (text); } - if (!((SCM_UNBNDP (inp) && SCM_NIMP (scm_cur_inp) && SCM_OPINFPORTP (inp)) - || (SCM_NIMP (inp) && SCM_OPINFPORTP (inp)))) + if (!((SCM_UNBNDP (inp) && SCM_OPINFPORTP (scm_cur_inp)) + || SCM_OPINFPORTP (inp))) { --in_readline; scm_misc_error (s_scm_readline, @@ -184,8 +184,8 @@ SCM_DEFINE (scm_readline, "%readline", 0, 4, 0, SCM_EOL); } - if (!((SCM_UNBNDP (outp) && SCM_NIMP (scm_cur_outp) && SCM_OPINFPORTP (outp)) - || (SCM_NIMP (outp) && SCM_OPOUTFPORTP (outp)))) + if (!((SCM_UNBNDP (outp) && SCM_OPINFPORTP (scm_cur_outp)) + || SCM_OPOUTFPORTP (outp))) { --in_readline; scm_misc_error (s_scm_readline, @@ -302,13 +302,13 @@ scm_readline_init_ports (SCM inp, SCM outp) if (SCM_UNBNDP (outp)) outp = scm_cur_outp; - if (!(SCM_NIMP (inp) && SCM_OPINFPORTP (inp))) { + if (!SCM_OPINFPORTP (inp)) { scm_misc_error (0, "Input port is not open or not a file port", SCM_EOL); } - if (!(SCM_NIMP (outp) && SCM_OPOUTFPORTP (outp))) { + if (!SCM_OPOUTFPORTP (outp)) { scm_misc_error (0, "Output port is not open or not a file port", SCM_EOL); @@ -400,7 +400,7 @@ completion_function (char *text, int continuep) if (SCM_FALSEP (res)) return NULL; - if (!(SCM_NIMP (res) && SCM_STRINGP (res))) + if (!SCM_STRINGP (res)) scm_misc_error (s_scm_readline, "Completion function returned bogus value: %S", SCM_LIST1 (res)); From ca83b028dc92ef4f86bb9203e914bcca63bf729c Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 24 Nov 2000 10:55:23 +0000 Subject: [PATCH 0381/2047] * Goops does not provide its own version of logand any more. * Removed use of deprecated stuff from goops. --- libguile/ChangeLog | 16 ++++++++ libguile/goops.c | 83 +++++++++++------------------------------- libguile/goops.h | 2 +- oop/ChangeLog | 7 ++++ oop/goops.scm | 3 +- oop/goops/dispatch.scm | 4 +- 6 files changed, 48 insertions(+), 67 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index aef92d226..72a18d976 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,19 @@ +2000-11-24 Dirk Herrmann + + * goops.c: Include validate.h. + + (DEFVAR, scm_add_method): Don't use deprecated scm_eval2. + + (scm_sys_fast_slot_ref, scm_sys_fast_slot_set_x, + scm_m_atdispatch): Provide FUNC_NAME definition. Don't use + deprecated SCM_OUTOFRANGE macro. + + (scm_sloppy_num2ulong, scm_sys_logand): Removed. Guile's logand + function now provides the desired behaviour. + + * goops.c (filter_cpl, remove_duplicate_slots), goops.h + (SCM_SUBCLASSP): Don't use deprecated scm_sloppy_memq. + 2000-11-23 Dirk Herrmann * symbols.h (SCM_LENGTH_MAX): Deprecated. diff --git a/libguile/goops.c b/libguile/goops.c index 1c4cb1087..699627b5e 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -69,6 +69,7 @@ #include "libguile/vectors.h" #include "libguile/weaks.h" +#include "libguile/validate.h" #include "libguile/goops.h" #define CLASSP(x) (SCM_STRUCTP (x) \ @@ -81,8 +82,8 @@ #define DEFVAR(v,val) \ -{ scm_eval2 (SCM_LIST3 (scm_sym_define_public, (v), (val)), \ - scm_goops_lookup_closure); } +{ scm_i_eval (SCM_LIST3 (scm_sym_define_public, (v), (val)), \ + scm_top_level_env (scm_goops_lookup_closure)); } /* Temporary hack until we get the new module system */ /*fixme* Should optimize by keeping track of the variable object itself */ #define GETVAR(v) (SCM_CDDR (scm_apply (scm_goops_lookup_closure, \ @@ -217,7 +218,7 @@ filter_cpl (SCM ls) while (SCM_NIMP (ls)) { SCM el = SCM_CAR (ls); - if (SCM_IMP (scm_sloppy_memq (el, res))) + if (SCM_IMP (scm_memq (el, res))) res = scm_cons (el, res); ls = SCM_CDR (ls); } @@ -258,7 +259,7 @@ remove_duplicate_slots (SCM l, SCM res, SCM slots_already_seen) "bad slot name ~S", SCM_LIST1 (tmp)); - if (SCM_NULLP (scm_sloppy_memq (tmp, slots_already_seen))) { + if (SCM_NULLP (scm_memq (tmp, slots_already_seen))) { res = scm_cons (SCM_CAR (l), res); slots_already_seen = scm_cons (tmp, slots_already_seen); } @@ -991,6 +992,7 @@ SCM_PROC (s_sys_fast_slot_ref, "%fast-slot-ref", 2, 0, 0, scm_sys_fast_slot_ref) SCM scm_sys_fast_slot_ref (SCM obj, SCM index) +#define FUNC_NAME s_sys_fast_slot_ref { register long i; @@ -998,15 +1000,18 @@ scm_sys_fast_slot_ref (SCM obj, SCM index) obj, SCM_ARG1, s_sys_fast_slot_ref); SCM_ASSERT (SCM_INUMP (index), index, SCM_ARG2, s_sys_fast_slot_ref); i = SCM_INUM (index); - SCM_ASSERT (i >= 0 && i < SCM_NUMBER_OF_SLOTS (obj), - index, SCM_OUTOFRANGE, s_sys_fast_slot_ref); + + SCM_ASSERT_RANGE (2, index, i >= 0 && i < SCM_NUMBER_OF_SLOTS (obj)); return scm_at_assert_bound_ref (obj, index); } +#undef FUNC_NAME + SCM_PROC (s_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0, scm_sys_fast_slot_set_x); SCM scm_sys_fast_slot_set_x (SCM obj, SCM index, SCM value) +#define FUNC_NAME s_sys_fast_slot_set_x { register long i; @@ -1014,12 +1019,13 @@ scm_sys_fast_slot_set_x (SCM obj, SCM index, SCM value) obj, SCM_ARG1, s_sys_fast_slot_set_x); SCM_ASSERT (SCM_INUMP (index), index, SCM_ARG2, s_sys_fast_slot_set_x); i = SCM_INUM (index); - SCM_ASSERT (i >= 0 && i < SCM_NUMBER_OF_SLOTS (obj), - index, SCM_OUTOFRANGE, s_sys_fast_slot_set_x); - + SCM_ASSERT_RANGE (2, index, i >= 0 && i < SCM_NUMBER_OF_SLOTS (obj)); SCM_SLOT (obj, i) = value; + return SCM_UNSPECIFIED; } +#undef FUNC_NAME + /** Utilities **/ @@ -1129,56 +1135,6 @@ test_slot_existence (SCM class, SCM obj, SCM slot_name) return SCM_BOOL_F; } -/* The current libguile logand doesn't handle bignums. - * This (primitive) version handles them up to 32 bits. - */ - -SCM_PROC1 (s_sys_logand, "%logand", scm_tc7_asubr, scm_sys_logand); - -static unsigned long -scm_sloppy_num2ulong (SCM num, char *pos, const char *s_caller) -{ - unsigned long res; - - if (SCM_INUMP (num)) - { - if (SCM_INUM (num) < 0) - goto out_of_range; - res = SCM_INUM (num); - return res; - } - SCM_ASRTGO (SCM_NIMP (num), wrong_type_arg); - if (SCM_BIGP (num)) - { - scm_sizet l; - - res = 0; - for (l = SCM_NUMDIGS (num); l--;) - res = SCM_BIGUP (res) + SCM_BDIGITS (num)[l]; - return res; - } - wrong_type_arg: - scm_wrong_type_arg (s_caller, (int) pos, num); - out_of_range: - scm_out_of_range (s_caller, num); -} - -static SCM -scm_sys_logand (SCM n1, SCM n2) -{ - if (SCM_UNBNDP (n2)) - { - if (SCM_UNBNDP (n1)) - return SCM_MAKINUM (-1); - return n1; - } - { - unsigned long u1 = scm_sloppy_num2ulong (n1, (char *) 1, s_sys_logand); - unsigned long u2 = scm_sloppy_num2ulong (n2, (char *) 2, s_sys_logand); - return scm_ulong2num (u1 & u2); - } -} - /* ======================================== */ SCM_PROC (s_slot_ref_using_class, "slot-ref-using-class", 3, 0, 0, scm_slot_ref_using_class); @@ -1951,6 +1907,7 @@ SCM_SYMBOL (sym_atdispatch, s_atdispatch); SCM scm_m_atdispatch (SCM xorig, SCM env) +#define FUNC_NAME s_atdispatch { SCM args, n, v, gf, x = SCM_CDR (xorig); SCM_ASSYNT (scm_ilength (x) == 4, xorig, scm_s_expression, s_atdispatch); @@ -1960,7 +1917,7 @@ scm_m_atdispatch (SCM xorig, SCM env) x = SCM_CDR (x); n = SCM_XEVALCAR (x, env); SCM_ASSYNT (SCM_INUMP (n), n, SCM_ARG2, s_atdispatch); - SCM_ASSYNT (SCM_INUM (n) >= 1, n, SCM_OUTOFRANGE, s_atdispatch); + SCM_ASSERT_RANGE (0, n, SCM_INUM (n) >= 1); x = SCM_CDR (x); v = SCM_XEVALCAR (x, env); SCM_ASSYNT (SCM_NIMP (v) && SCM_VECTORP (v), v, SCM_ARG3, s_atdispatch); @@ -1970,6 +1927,8 @@ scm_m_atdispatch (SCM xorig, SCM env) gf, SCM_ARG4, s_atdispatch); return SCM_LIST5 (SCM_IM_DISPATCH, args, n, v, gf); } +#undef FUNC_NAME + #ifdef USE_THREADS static void @@ -2663,8 +2622,8 @@ SCM_SYMBOL (sym_internal_add_method_x, "internal-add-method!"); void scm_add_method (SCM gf, SCM m) { - scm_eval2 (SCM_LIST3 (sym_internal_add_method_x, gf, m), - scm_goops_lookup_closure); + scm_i_eval (SCM_LIST3 (sym_internal_add_method_x, gf, m), + scm_top_level_env (scm_goops_lookup_closure)); } #ifdef GUILE_DEBUG diff --git a/libguile/goops.h b/libguile/goops.h index 84f67b4e9..f1399222a 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -134,7 +134,7 @@ typedef struct scm_method_t { | SCM_CLASSF_SIMPLE_METHOD)) #define SCM_SLOT(x, i) (SCM_INST(x)[i]) -#define SCM_SUBCLASSP(c1, c2) SCM_NNULLP (scm_sloppy_memq (c2, SCM_SLOT (c1, scm_si_cpl))) +#define SCM_SUBCLASSP(c1, c2) SCM_NNULLP (scm_memq (c2, SCM_SLOT (c1, scm_si_cpl))) #define SCM_IS_A_P(x, c) (SCM_NIMP (x) \ && SCM_INSTANCEP (x) \ && SCM_SUBCLASSP (SCM_CLASS_OF (x), c)) diff --git a/oop/ChangeLog b/oop/ChangeLog index 78497dfc0..246c4e3ff 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -1,3 +1,10 @@ +2000-11-24 Dirk Herrmann + + * goops.scm: Don't export removed %logand any more. + + * goops/dispatch.scm (cache-try-hash!): Use logand instead of + %logand. + 2000-11-06 Mikael Djurfeldt * goops.scm (internal-add-method!): Set n-specialized of a generic diff --git a/oop/goops.scm b/oop/goops.scm index 94d4e1d12..3de529e66 100644 --- a/oop/goops.scm +++ b/oop/goops.scm @@ -77,8 +77,7 @@ generic-function-methods method-generic-function method-specializers primitive-generic-generic enable-primitive-generic! method-procedure accessor-method-slot-definition - slot-exists? make find-method get-keyword - %logand) + slot-exists? make find-method get-keyword) (define min-fixnum (- (expt 2 29))) diff --git a/oop/goops/dispatch.scm b/oop/goops/dispatch.scm index a1e031f4d..ebd3623ea 100644 --- a/oop/goops/dispatch.scm +++ b/oop/goops/dispatch.scm @@ -191,8 +191,8 @@ (do ((ls entries (cdr ls)) (misses 0 0)) ((null? ls) max-misses) - (do ((i (%logand mask (cache-hashval hashset (car ls))) - (%logand mask (+ i 1)))) + (do ((i (logand mask (cache-hashval hashset (car ls))) + (logand mask (+ i 1)))) ((not (struct? (car (vector-ref cache i)))) (vector-set! cache i (car ls))) (set! misses (+ 1 misses)) From 7f555fb4ed423ad783c961bed500c19d3159886a Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 24 Nov 2000 14:43:41 +0000 Subject: [PATCH 0382/2047] * Fix previous change (thanks to Matthias Koeppe). --- libguile/ChangeLog | 7 +++++++ libguile/goops.c | 4 ++-- libguile/goops.h | 2 +- 3 files changed, 10 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 72a18d976..9d6d19237 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2000-11-24 Matthias Koeppe + + * goops.c (filter_cpl, remove_duplicate_slots), goops.h + (SCM_SUBCLASSP): Fix previous change: In contrast to + scm_sloppy_memq the function scm_memq returns #f if the + object was not contained in the list. + 2000-11-24 Dirk Herrmann * goops.c: Include validate.h. diff --git a/libguile/goops.c b/libguile/goops.c index 699627b5e..154c7d085 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -218,7 +218,7 @@ filter_cpl (SCM ls) while (SCM_NIMP (ls)) { SCM el = SCM_CAR (ls); - if (SCM_IMP (scm_memq (el, res))) + if (SCM_FALSEP (scm_memq (el, res))) res = scm_cons (el, res); ls = SCM_CDR (ls); } @@ -259,7 +259,7 @@ remove_duplicate_slots (SCM l, SCM res, SCM slots_already_seen) "bad slot name ~S", SCM_LIST1 (tmp)); - if (SCM_NULLP (scm_memq (tmp, slots_already_seen))) { + if (SCM_FALSEP (scm_memq (tmp, slots_already_seen))) { res = scm_cons (SCM_CAR (l), res); slots_already_seen = scm_cons (tmp, slots_already_seen); } diff --git a/libguile/goops.h b/libguile/goops.h index f1399222a..db4659b72 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -134,7 +134,7 @@ typedef struct scm_method_t { | SCM_CLASSF_SIMPLE_METHOD)) #define SCM_SLOT(x, i) (SCM_INST(x)[i]) -#define SCM_SUBCLASSP(c1, c2) SCM_NNULLP (scm_memq (c2, SCM_SLOT (c1, scm_si_cpl))) +#define SCM_SUBCLASSP(c1, c2) (!SCM_FALSEP (scm_memq (c2, SCM_SLOT (c1, scm_si_cpl)))) #define SCM_IS_A_P(x, c) (SCM_NIMP (x) \ && SCM_INSTANCEP (x) \ && SCM_SUBCLASSP (SCM_CLASS_OF (x), c)) From 5f144b105db0dcbe3b33947317d3e9b98cbd5269 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sat, 25 Nov 2000 16:58:25 +0000 Subject: [PATCH 0383/2047] * use an applicable SMOB to represent continuations, instead of a custom tc7 type. This will make it easier to support R5RS multiple value continuations, without the use of a Scheme-level wrapper. * continuations.c (scm_tc16_continuation, continuation_mark, continuation_free, continuation_print, continuation_apply): new SMOB support. (scm_make_continuation): new procedure, replaces scm_make_cont with a different interface. (copy_stack_and_call, scm_dynthrow, scm_init_continuations): rewritten. (CHEAP_CONTINUATIONS): removed non-working code completely. (scm_call_continuation): removed. * continuations.h (struct scm_contregs): add num_stack_items and stack fields. previously stack was stored following this struct: use a tail array instead. (SCM_CONTINUATIONP): new macro. (SCM_CONTINUATION_LENGTH, SCM_SET_CONTINUATION_LENGTH): rewritten. (SCM_SET_CONTREGS): removed. * tags.h: removed scm_tc7_contin (was tag 61). * debug.c, gc.c, hash.c, print.c, procprop.c, procs.c: removed scm_tc7_contin support. * eval.c: use scm_make_continuation instead of scm_make_cont. don't set jump buffers here. remove scm_tc7_contin support. * init.c, root.c: create SMOB continuation for rootcont instead of scm_tc7_contin. call scm_init_continuations before scm_init_root. * root.c: remove support for static jmpbuf. It's not used by default and I broke it. create SMOB continuation for rootcont. * stacks.c: use SCM_CONTINUATIONP. --- libguile/ChangeLog | 34 ++++++ libguile/continuations.c | 231 ++++++++++++++++++++------------------- libguile/continuations.h | 31 ++++-- libguile/debug.c | 2 - libguile/eval.c | 65 ++++++----- libguile/gc.c | 14 --- libguile/hash.c | 1 - libguile/init.c | 14 ++- libguile/print.c | 7 -- libguile/procprop.c | 1 - libguile/procs.c | 4 +- libguile/root.c | 38 +++---- libguile/stacks.c | 6 +- libguile/tags.h | 2 +- 14 files changed, 240 insertions(+), 210 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 9d6d19237..d7d3d8ca4 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,37 @@ +2000-11-25 Gary Houston + + * use an applicable SMOB to represent continuations, instead of a + custom tc7 type. This will make it easier to support R5RS + multiple value continuations, without the use of a Scheme-level + wrapper. + + * continuations.c (scm_tc16_continuation, continuation_mark, + continuation_free, continuation_print, continuation_apply): + new SMOB support. + (scm_make_continuation): new procedure, replaces scm_make_cont + with a different interface. + (copy_stack_and_call, scm_dynthrow, scm_init_continuations): rewritten. + (CHEAP_CONTINUATIONS): removed non-working code completely. + (scm_call_continuation): removed. + * continuations.h (struct scm_contregs): add num_stack_items and + stack fields. previously stack was stored following this struct: + use a tail array instead. + (SCM_CONTINUATIONP): new macro. + (SCM_CONTINUATION_LENGTH, SCM_SET_CONTINUATION_LENGTH): + rewritten. + (SCM_SET_CONTREGS): removed. + * tags.h: removed scm_tc7_contin (was tag 61). + * debug.c, gc.c, hash.c, print.c, procprop.c, procs.c: + removed scm_tc7_contin support. + * eval.c: use scm_make_continuation instead of scm_make_cont. + don't set jump buffers here. remove scm_tc7_contin support. + * init.c, root.c: create SMOB continuation for rootcont instead + of scm_tc7_contin. call scm_init_continuations before + scm_init_root. + * root.c: remove support for static jmpbuf. It's not used by + default and I broke it. create SMOB continuation for rootcont. + * stacks.c: use SCM_CONTINUATIONP. + 2000-11-24 Matthias Koeppe * goops.c (filter_cpl, remove_duplicate_slots), goops.h diff --git a/libguile/continuations.c b/libguile/continuations.c index ca647b154..108465d03 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -48,10 +48,13 @@ #include "libguile/_scm.h" #include "libguile/root.h" #include "libguile/stackchk.h" +#include "libguile/smob.h" +#include "libguile/ports.h" +#include "libguile/dynwind.h" + #ifdef DEBUG_EXTENSIONS #include "libguile/debug.h" #endif -#include "libguile/dynwind.h" #include "libguile/continuations.h" @@ -60,52 +63,92 @@ /* {Continuations} */ -static char s_cont[] = "continuation"; +scm_bits_t scm_tc16_continuation; -static void scm_dynthrow (SCM, SCM); - - -#ifndef CHEAP_CONTINUATIONS - - -SCM -scm_make_cont (SCM *answer) +static SCM continuation_mark (SCM obj) { - long j; - SCM cont; - SCM_STACKITEM * src; - SCM_STACKITEM * dst; + scm_contregs *continuation = SCM_CONTREGS (obj); - SCM_NEWCELL (cont); - *answer = cont; - SCM_ENTER_A_SECTION; - SCM_FLUSH_REGISTER_WINDOWS; - j = scm_stack_size (SCM_BASE (scm_rootcont)); - SCM_SET_CONTREGS (cont, - scm_must_malloc (sizeof (scm_contregs) - + j * sizeof (SCM_STACKITEM), - s_cont)); - SCM_DYNENV (cont) = scm_dynwinds; - SCM_THROW_VALUE (cont) = SCM_EOL; - src = SCM_BASE (cont) = SCM_BASE (scm_rootcont); - SCM_SEQ (cont) = SCM_SEQ (scm_rootcont); - SCM_SET_CONTINUATION_LENGTH (cont, j); - SCM_EXIT_A_SECTION; -#ifndef SCM_STACK_GROWS_UP - src -= SCM_CONTINUATION_LENGTH (cont); -#endif /* ndef SCM_STACK_GROWS_UP */ - dst = (SCM_STACKITEM *) ((char *) SCM_CONTREGS (cont) + sizeof (scm_contregs)); - - /* memcpy should be safe: src and dst will never overlap */ - memcpy (dst, src, sizeof (SCM_STACKITEM) * SCM_CONTINUATION_LENGTH (cont)); - -#ifdef DEBUG_EXTENSIONS - SCM_DFRAME (cont) = scm_last_debug_frame; -#endif - - return cont; + scm_gc_mark (continuation->throw_value); + scm_mark_locations (continuation->stack, continuation->num_stack_items); + return continuation->dynenv; } +static scm_sizet continuation_free (SCM obj) +{ + scm_contregs *continuation = SCM_CONTREGS (obj); + /* stack array size is 1 if num_stack_items is 0 (rootcont). */ + scm_sizet extra_items = (continuation->num_stack_items > 0) + ? (continuation->num_stack_items - 1) + : 0; + scm_sizet bytes_free = sizeof (scm_contregs) + + extra_items * sizeof (SCM_STACKITEM); + + scm_must_free (continuation); + return bytes_free; +} + +static int continuation_print (SCM obj, SCM port, scm_print_state *state) +{ + scm_contregs *continuation = SCM_CONTREGS (obj); + + scm_puts ("#num_stack_items, 10, port); + scm_puts (" @ ", port); + scm_intprint (SCM_CELL_WORD_1 (obj), 16, port); + scm_putc ('>', port); + return 1; +} + +/* this may return more than once: the first time with the escape + procedure, then subsequently with the value to be passed to the + continuation. */ +#define FUNC_NAME "scm_make_continuation" +SCM +scm_make_continuation (int *first) +{ + SCM cont; + scm_contregs *continuation; + scm_contregs *rootcont = SCM_CONTREGS (scm_rootcont); + long stack_size; + SCM_STACKITEM * src; + + SCM_ENTER_A_SECTION; + SCM_FLUSH_REGISTER_WINDOWS; + stack_size = scm_stack_size (rootcont->base); + continuation = scm_must_malloc (sizeof (scm_contregs) + + (stack_size - 1) * sizeof (SCM_STACKITEM), + FUNC_NAME); + continuation->num_stack_items = stack_size; + continuation->dynenv = scm_dynwinds; + continuation->throw_value = SCM_EOL; + continuation->base = src = rootcont->base; + continuation->seq = rootcont->seq; +#ifdef DEBUG_EXTENSIONS + continuation->dframe = scm_last_debug_frame; +#endif + SCM_NEWSMOB (cont, scm_tc16_continuation, continuation); + SCM_EXIT_A_SECTION; + +#ifndef SCM_STACK_GROWS_UP + src -= stack_size; +#endif + memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size); + + if (setjmp (continuation->jmpbuf)) + { + *first = 0; + return continuation->throw_value; + } + else + { + *first = 1; + return cont; + } +} +#undef FUNC_NAME + +static void scm_dynthrow (SCM, SCM); /* Grow the stack by a fixed amount to provide space to copy in the * continuation. Possibly this function has to be called several times @@ -131,18 +174,18 @@ grow_stack (SCM cont, SCM val) * own frame are overwritten. Thus, memcpy can be used for best performance. */ static void -copy_stack_and_call (SCM cont, SCM val, - SCM_STACKITEM * src, SCM_STACKITEM * dst) +copy_stack_and_call (scm_contregs *continuation, SCM val, + SCM_STACKITEM * dst) { - /* memcpy should be safe: src and dst will never overlap */ - memcpy (dst, src, sizeof (SCM_STACKITEM) * SCM_CONTINUATION_LENGTH (cont)); + memcpy (dst, continuation->stack, + sizeof (SCM_STACKITEM) * continuation->num_stack_items); #ifdef DEBUG_EXTENSIONS - scm_last_debug_frame = SCM_DFRAME (cont); + scm_last_debug_frame = continuation->dframe; #endif - SCM_THROW_VALUE (cont) = val; - longjmp (SCM_JMPBUF (cont), 1); + continuation->throw_value = val; + longjmp (continuation->jmpbuf, 1); } @@ -153,94 +196,60 @@ copy_stack_and_call (SCM cont, SCM val, static void scm_dynthrow (SCM cont, SCM val) { - SCM_STACKITEM * src; + scm_contregs *continuation = SCM_CONTREGS (cont); SCM_STACKITEM * dst = SCM_BASE (scm_rootcont); SCM_STACKITEM stack_top_element; #ifdef SCM_STACK_GROWS_UP - if (SCM_PTR_GE (dst + SCM_CONTINUATION_LENGTH (cont), & stack_top_element)) + if (SCM_PTR_GE (dst + continuation->num_stack_items, &stack_top_element)) grow_stack (cont, val); #else - dst -= SCM_CONTINUATION_LENGTH (cont); - if (SCM_PTR_LE (dst, & stack_top_element)) + dst -= continuation->num_stack_items; + if (SCM_PTR_LE (dst, &stack_top_element)) grow_stack (cont, val); #endif /* def SCM_STACK_GROWS_UP */ + SCM_FLUSH_REGISTER_WINDOWS; - src = (SCM_STACKITEM *) ((char *) SCM_CONTREGS (cont) + sizeof (scm_contregs)); - copy_stack_and_call (cont, val, src, dst); + copy_stack_and_call (continuation, val, dst); } - -#else /* ifndef CHEAP_CONTINUATIONS */ - -/* Dirk:FIXME:: It seems that nobody has ever tried to use this code, since it - * contains syntactic errors and thus would not have compiled anyway. - */ - - -SCM -scm_make_cont (SCM *answer) +#define FUNC_NAME "continuation_apply" +static SCM continuation_apply (SCM cont, SCM args) { - SCM cont; + /* FIXME: support R5RS multiple value continuations. */ + scm_contregs *continuation = SCM_CONTREGS (cont); + scm_contregs *rootcont = SCM_CONTREGS (scm_rootcont); - SCM_NEWCELL (cont); - *answer = cont; - SCM_ENTER_A_SECTION; - SCM_SET_CONTREGS (cont, scm_must_malloc (sizeof (scm_contregs), s_cont)); - SCM_DYNENV (cont) = scm_dynwinds; - SCM_THROW_VALUE = SCM_EOL; - SCM_BASE (cont) = SCM_BASE (rootcont); - SCM_SEQ (cont) = SCM_SEQ (rootcont); - SCM_SETCAR (cont, scm_tc7_contin); - SCM_EXIT_A_SECTION; - -#ifdef DEBUG_EXTENSIONS - SCM_DFRAME (cont) = scm_last_debug_frame; -#endif - - return cont; -} - - -static void -scm_dynthrow (SCM cont, SCM val) -{ -#ifdef DEBUG_EXTENSIONS - scm_last_debug_frame = SCM_DFRAME (cont); -#endif - SCM_THROW_VALUE (cont) = val; - longjmp (SCM_JMPBUF (cont), 1); -} - - -#endif - - -SCM -scm_call_continuation (SCM cont, SCM val) -{ - if ((SCM_SEQ (cont) != SCM_SEQ (scm_rootcont)) - || (SCM_BASE (cont) != SCM_BASE (scm_rootcont))) - /* base compare not needed */ - scm_wta (cont, "continuation from wrong top level", s_cont); + SCM_ASSERT (scm_ilength (args) == 1, args, SCM_ARGn, FUNC_NAME); + if (continuation->seq != rootcont->seq + /* this base comparison isn't needed */ + || continuation->base != rootcont->base) + { + scm_wta (cont, "continuation from wrong top level", FUNC_NAME); + } - scm_dowinds (SCM_DYNENV (cont), - scm_ilength (scm_dynwinds) - scm_ilength (SCM_DYNENV (cont))); + scm_dowinds (continuation->dynenv, + scm_ilength (scm_dynwinds) - continuation->dynenv); - scm_dynthrow (cont, val); + scm_dynthrow (cont, SCM_CAR (args)); return SCM_UNSPECIFIED; /* not reached */ } - +#undef FUNC_NAME void scm_init_continuations () { + scm_tc16_continuation = scm_make_smob_type ("continuation", 0); + scm_set_smob_mark (scm_tc16_continuation, continuation_mark); + scm_set_smob_free (scm_tc16_continuation, continuation_free); + scm_set_smob_print (scm_tc16_continuation, continuation_print); + scm_set_smob_apply (scm_tc16_continuation, continuation_apply, 0, 0, 1); + #ifndef SCM_MAGIC_SNARFER #include "libguile/continuations.x" #endif } - /* Local Variables: c-file-style: "gnu" diff --git a/libguile/continuations.h b/libguile/continuations.h index d107f8797..ba87a3f27 100644 --- a/libguile/continuations.h +++ b/libguile/continuations.h @@ -47,25 +47,41 @@ +/* a continuation SCM is a non-immediate pointing to a heap cell with: + word 0: bits 0-15: unused. + bits 16-31: smob type tag: scm_tc16_continuation. + word 1: malloc block containing an scm_contregs structure with a + tail array of SCM_STACKITEM. the size of the array is stored + in the num_stack_items field of the structure. +*/ + +extern scm_bits_t scm_tc16_continuation; + typedef struct { SCM throw_value; jmp_buf jmpbuf; SCM dynenv; - SCM_STACKITEM *base; - unsigned long seq; + SCM_STACKITEM *base; /* base of the live stack, before it was saved. */ + scm_sizet num_stack_items; /* size of the saved stack. */ + unsigned long seq; /* dynamic root identifier. */ #ifdef DEBUG_EXTENSIONS + /* the most recently created debug frame on the live stack, before + it was saved. */ struct scm_debug_frame *dframe; #endif + SCM_STACKITEM stack[1]; /* copied stack of size num_stack_items. */ } scm_contregs; +#define SCM_CONTINUATIONP(x)\ + (SCM_NIMP (x) && (SCM_TYP16 (x) == scm_tc16_continuation)) -#define SCM_CONTREGS(x) ((scm_contregs *) SCM_CELL_WORD_1 (x)) -#define SCM_SET_CONTREGS(x, r) (SCM_SET_CELL_WORD_1 ((x), (scm_bits_t) (r))) -#define SCM_CONTINUATION_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) -#define SCM_SET_CONTINUATION_LENGTH(x, l) (SCM_SET_CELL_WORD_0 ((x), ((l) << 8) + scm_tc7_contin)) +#define SCM_CONTREGS(x) ((scm_contregs *) SCM_CELL_WORD_1 (x)) +#define SCM_CONTINUATION_LENGTH(x) (SCM_CONTREGS (x)->num_stack_items) +#define SCM_SET_CONTINUATION_LENGTH(x,n)\ + (SCM_CONTREGS (x)->num_stack_items = (n)) #define SCM_JMPBUF(x) ((SCM_CONTREGS (x))->jmpbuf) #define SCM_DYNENV(x) ((SCM_CONTREGS (x))->dynenv) #define SCM_THROW_VALUE(x) ((SCM_CONTREGS (x))->throw_value) @@ -75,8 +91,7 @@ typedef struct -extern SCM scm_make_cont (SCM * answer); -extern SCM scm_call_continuation (SCM cont, SCM val); +extern SCM scm_make_continuation (int *first); extern void scm_init_continuations (void); diff --git a/libguile/debug.c b/libguile/debug.c index 93cbf6aa9..f530c3f66 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -431,7 +431,6 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0, SCM_EOL, SCM_ENV (proc)))); } - case scm_tc7_contin: case scm_tcs_subrs: #ifdef CCLO case scm_tc7_cclo: @@ -455,7 +454,6 @@ SCM_DEFINE (scm_procedure_environment, "procedure-environment", 1, 0, 0, switch (SCM_TYP7 (proc)) { case scm_tcs_closures: return SCM_ENV (proc); - case scm_tc7_contin: case scm_tcs_subrs: #ifdef CCLO case scm_tc7_cclo: diff --git a/libguile/eval.c b/libguile/eval.c index 18d0c315d..3c44fba1a 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1621,8 +1621,9 @@ do { \ }\ else\ {\ - scm_make_cont (&tmp);\ - if (!setjmp (SCM_JMPBUF (tmp)))\ + int first;\ + tmp = scm_make_continuation (&first);\ + if (first)\ scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\ }\ }\ @@ -1875,10 +1876,14 @@ start: t.arg1 = scm_make_debugobj (&debug); else { - scm_make_cont (&t.arg1); - if (setjmp (SCM_JMPBUF (t.arg1))) + int first; + SCM val = scm_make_continuation (&first); + + if (first) + t.arg1 = val; + else { - x = SCM_THROW_VALUE (t.arg1); + x = val; if (SCM_IMP (x)) { RETURN (x); @@ -2218,13 +2223,15 @@ dispatch: goto evapply; case (SCM_ISYMNUM (SCM_IM_CONT)): - scm_make_cont (&t.arg1); - if (setjmp (SCM_JMPBUF (t.arg1))) - { - SCM val; - val = SCM_THROW_VALUE (t.arg1); - RETURN (val) - } + { + int first; + SCM val = scm_make_continuation (&first); + + if (first) + t.arg1 = val; + else + RETURN (val); + } proc = SCM_CDR (x); proc = evalcar (proc, env); SCM_ASRTGO (SCM_NIMP (proc), badfun); @@ -2681,7 +2688,6 @@ evapply: else goto badfun; } - case scm_tc7_contin: case scm_tc7_subr_1: case scm_tc7_subr_2: case scm_tc7_subr_2o: @@ -2815,8 +2821,6 @@ evapply: env = EXTEND_ENV (SCM_CAR (x), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc)); #endif goto cdrxbegin; - case scm_tc7_contin: - scm_call_continuation (proc, t.arg1); case scm_tcs_cons_gloc: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { @@ -2970,7 +2974,6 @@ evapply: case scm_tc7_subr_1o: case scm_tc7_subr_1: case scm_tc7_subr_3: - case scm_tc7_contin: goto wrongnumargs; default: goto badfun; @@ -3171,7 +3174,6 @@ evapply: case scm_tc7_subr_0: case scm_tc7_cxr: case scm_tc7_subr_1: - case scm_tc7_contin: goto wrongnumargs; default: goto badfun; @@ -3187,10 +3189,14 @@ exit: t.arg1 = scm_make_debugobj (&debug); else { - scm_make_cont (&t.arg1); - if (setjmp (SCM_JMPBUF (t.arg1))) + int first; + SCM val = scm_make_continuation (&first); + + if (first) + t.arg1 = val; + else { - proc = SCM_THROW_VALUE (t.arg1); + proc = val; goto ret; } } @@ -3342,8 +3348,10 @@ SCM_APPLY (SCM proc, SCM arg1, SCM args) tmp = scm_make_debugobj (&debug); else { - scm_make_cont (&tmp); - if (setjmp (SCM_JMPBUF (tmp))) + int first; + + tmp = scm_make_continuation (&first); + if (!first) goto entap; } scm_ithrow (scm_sym_enter_frame, scm_cons (tmp, SCM_EOL), 0); @@ -3492,9 +3500,6 @@ tail: RETURN (scm_smob_apply_2 (proc, arg1, SCM_CAR (args))) else RETURN (scm_smob_apply_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args))); - case scm_tc7_contin: - SCM_ASRTGO (SCM_NULLP (args), wrongnumargs); - scm_call_continuation (proc, arg1); #ifdef CCLO case scm_tc7_cclo: #ifdef DEVAL @@ -3565,10 +3570,14 @@ exit: arg1 = scm_make_debugobj (&debug); else { - scm_make_cont (&arg1); - if (setjmp (SCM_JMPBUF (arg1))) + int first; + SCM val = scm_make_continuation (&first); + + if (first) + arg1 = val; + else { - proc = SCM_THROW_VALUE (arg1); + proc = val; goto ret; } } diff --git a/libguile/gc.c b/libguile/gc.c index 0a6e968f3..5c8a86ac4 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1221,15 +1221,6 @@ gc_mark_nimp: ptr = SCM_VELTS (ptr)[0]; goto gc_mark_loop; #endif - case scm_tc7_contin: - if (SCM_VELTS (ptr)) - scm_mark_locations (SCM_VELTS_AS_STACKITEMS (ptr), - (scm_sizet) - (SCM_CONTINUATION_LENGTH (ptr) + - (sizeof (SCM_STACKITEM) + -1 + - sizeof (scm_contregs)) / - sizeof (SCM_STACKITEM))); - break; #ifdef HAVE_ARRAYS case scm_tc7_bvect: case scm_tc7_byvect: @@ -1654,11 +1645,6 @@ scm_gc_sweep () m += SCM_SYMBOL_LENGTH (scmptr) + 1; scm_must_free (SCM_SYMBOL_CHARS (scmptr)); break; - case scm_tc7_contin: - m += SCM_CONTINUATION_LENGTH (scmptr) * sizeof (SCM_STACKITEM) - + sizeof (scm_contregs); - scm_must_free (SCM_CONTREGS (scmptr)); - break; case scm_tcs_subrs: /* the various "subrs" (primitives) are never freed */ continue; diff --git a/libguile/hash.c b/libguile/hash.c index b26de9c04..529ad9fa0 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -150,7 +150,6 @@ scm_hasher(SCM obj, unsigned long n, scm_sizet d) case scm_tc7_port: return ((SCM_RDNG & SCM_CELL_WORD_0 (obj)) ? 260 : 261) % n; case scm_tcs_closures: - case scm_tc7_contin: case scm_tcs_subrs: return 262 % n; } diff --git a/libguile/init.c b/libguile/init.c index 19530f6b6..16211518a 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -183,11 +183,13 @@ start_stack (void *base) /* Create an object to hold the root continuation. */ - SCM_NEWCELL (scm_rootcont); - SCM_SET_CONTREGS (scm_rootcont, scm_must_malloc (sizeof (scm_contregs), - "continuation")); - SCM_SET_CELL_TYPE (scm_rootcont, scm_tc7_contin); - SCM_SEQ (scm_rootcont) = 0; + { + scm_contregs *contregs = scm_must_malloc (sizeof (scm_contregs), + "continuation"); + contregs->num_stack_items = 0; + contregs->seq = 0; + SCM_NEWSMOB (scm_rootcont, scm_tc16_continuation, contregs); + } /* The root continuation is further initialized by restart_stack. */ /* Create the look-aside stack for variables that are shared between @@ -488,6 +490,7 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_weaks_prehistory (); /* Must come after scm_init_storage */ scm_init_subr_table (); scm_environments_prehistory (); /* create the root environment */ + scm_init_continuations (); scm_init_root (); #ifdef USE_THREADS scm_init_threads (base); @@ -501,7 +504,6 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_init_async (); scm_init_boolean (); scm_init_chars (); - scm_init_continuations (); #ifdef GUILE_DEBUG_MALLOC scm_init_debug_malloc (); #endif diff --git a/libguile/print.c b/libguile/print.c index 59004fd85..ecdc40d27 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -673,13 +673,6 @@ taloop: } scm_putc ('>', port); break; - case scm_tc7_contin: - scm_puts ("#', port); - break; case scm_tc7_port: { register long i = SCM_PTOBNUM (exp); diff --git a/libguile/procprop.c b/libguile/procprop.c index cd458eb99..feb42f7b3 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -80,7 +80,6 @@ scm_i_procedure_arity (SCM proc) o = 1; case scm_tc7_subr_1: case scm_tc7_cxr: - case scm_tc7_contin: a += 1; break; case scm_tc7_subr_2: diff --git a/libguile/procs.c b/libguile/procs.c index 1e48c3cff..c36871954 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -196,7 +196,6 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0, if (!SCM_I_OPERATORP (obj)) break; case scm_tcs_closures: - case scm_tc7_contin: case scm_tcs_subrs: #ifdef CCLO case scm_tc7_cclo: @@ -278,8 +277,7 @@ SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0, #define FUNC_NAME s_scm_procedure_documentation { SCM code; - SCM_ASSERT (SCM_EQ_P (scm_procedure_p (proc), SCM_BOOL_T) - && SCM_NIMP (proc) && SCM_TYP7 (proc) != scm_tc7_contin, + SCM_ASSERT (SCM_EQ_P (scm_procedure_p (proc), SCM_BOOL_T) && SCM_NIMP (proc), proc, SCM_ARG1, FUNC_NAME); switch (SCM_TYP7 (proc)) { diff --git a/libguile/root.c b/libguile/root.c index 86eee6452..c0c8ebfa6 100644 --- a/libguile/root.c +++ b/libguile/root.c @@ -58,12 +58,6 @@ #include "libguile/root.h" -/* Define this if you want to try out the stack allocation of cwdr's - jumpbuf. It works for me but I'm still worried that the dynwinds - might be able to make a mess. */ - -#undef USE_STACKJMPBUF - SCM scm_sys_protects[SCM_NUM_PROTECTS]; long scm_tc16_root; @@ -248,9 +242,6 @@ scm_internal_cwdr (scm_catch_body_t body, void *body_data, scm_catch_handler_t handler, void *handler_data, SCM_STACKITEM *stack_start) { -#ifdef USE_STACKJMPBUF - scm_contregs static_contregs; -#endif int old_ints_disabled = scm_ints_disabled; SCM old_rootcont, old_winds; struct cwdr_handler_data my_handler_data; @@ -259,22 +250,22 @@ scm_internal_cwdr (scm_catch_body_t body, void *body_data, /* Create a fresh root continuation. */ { SCM new_rootcont; - SCM_NEWCELL (new_rootcont); + SCM_REDEFER_INTS; -#ifdef USE_STACKJMPBUF - SCM_SET_CONTREGS (new_rootcont, &static_contregs); -#else - SCM_SET_CONTREGS (new_rootcont, - scm_must_malloc (sizeof (scm_contregs), - "inferior root continuation")); -#endif - SCM_SET_CELL_TYPE (new_rootcont, scm_tc7_contin); - SCM_DYNENV (new_rootcont) = SCM_EOL; - SCM_BASE (new_rootcont) = stack_start; - SCM_SEQ (new_rootcont) = ++n_dynamic_roots; + { + scm_contregs *contregs = scm_must_malloc (sizeof (scm_contregs), + "inferior root continuation"); + + contregs->num_stack_items = 0; + contregs->dynenv = SCM_EOL; + contregs->base = stack_start; + contregs->seq = ++n_dynamic_roots; + contregs->throw_value = SCM_BOOL_F; #ifdef DEBUG_EXTENSIONS - SCM_DFRAME (new_rootcont) = 0; + contregs->dframe = 0; #endif + SCM_NEWSMOB (new_rootcont, scm_tc16_continuation, contregs); + } old_rootcont = scm_rootcont; scm_rootcont = new_rootcont; SCM_REALLOW_INTS; @@ -298,9 +289,6 @@ scm_internal_cwdr (scm_catch_body_t body, void *body_data, scm_dowinds (old_winds, - scm_ilength (old_winds)); SCM_REDEFER_INTS; -#ifdef USE_STACKCJMPBUF - SCM_SET_CONTREGS (scm_rootcont, NULL); -#endif #ifdef DEBUG_EXTENSIONS scm_last_debug_frame = SCM_DFRAME (old_rootcont); #endif diff --git a/libguile/stacks.c b/libguile/stacks.c index c048d94cd..e3de7eb23 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -433,7 +433,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, FUNC_NAME); if (SCM_DEBUGOBJP (obj)) dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (obj); - else if (scm_tc7_contin == SCM_TYP7 (obj)) + else if (SCM_CONTINUATIONP (obj)) { offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (obj) + sizeof (scm_contregs)) - SCM_BASE (obj)); @@ -517,7 +517,7 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0, SCM_VALIDATE_NIM (1,stack); if (SCM_DEBUGOBJP (stack)) dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (stack); - else if (scm_tc7_contin == SCM_TYP7 (stack)) + else if (SCM_CONTINUATIONP (stack)) { offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (stack) + sizeof (scm_contregs)) - SCM_BASE (stack)); @@ -587,7 +587,7 @@ SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0, SCM_VALIDATE_NIM (1,obj); if (SCM_DEBUGOBJP (obj)) dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (obj); - else if (scm_tc7_contin == SCM_TYP7 (obj)) + else if (SCM_CONTINUATIONP (obj)) { offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (obj) + sizeof (scm_contregs)) - SCM_BASE (obj)); diff --git a/libguile/tags.h b/libguile/tags.h index 7082603aa..a3f7ccb0a 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -356,7 +356,7 @@ typedef long scm_bits_t; #define scm_tc7_ivect 79 #endif -#define scm_tc7_contin 61 +/* free 61 */ #define scm_tc7_cclo 63 #define scm_tc7_rpsubr 69 #define scm_tc7_subr_0 85 From ce212434187cb3c800a223508a0c55b8b72cce64 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 26 Nov 2000 18:27:49 +0000 Subject: [PATCH 0384/2047] * reimplementation of values, call-with-values as primitives: * values.c, values.h: new files. use a struct to contain multiple values, similar to the previous Scheme-level implementation. * Makefile.am: add values.c, values.h, values.x. * continuations.c (continuation_apply): support R5RS multiple value continuations. * init.c: call scm_init_values. * struct.h: define SCM_SET_STRUCT_PRINTER. --- libguile/ChangeLog | 12 +++ libguile/Makefile.am | 12 +-- libguile/continuations.c | 5 +- libguile/init.c | 8 +- libguile/struct.h | 2 + libguile/values.c | 154 +++++++++++++++++++++++++++++++++++++++ libguile/values.h | 60 +++++++++++++++ 7 files changed, 242 insertions(+), 11 deletions(-) create mode 100644 libguile/values.c create mode 100644 libguile/values.h diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d7d3d8ca4..f3d90c0f5 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,15 @@ +2000-11-26 Gary Houston + + * reimplementation of values, call-with-values as primitives: + + * values.c, values.h: new files. use a struct to contain multiple + values, similar to the previous Scheme-level implementation. + * Makefile.am: add values.c, values.h, values.x. + * continuations.c (continuation_apply): support R5RS multiple value + continuations. + * init.c: call scm_init_values. + * struct.h: define SCM_SET_STRUCT_PRINTER. + 2000-11-25 Gary Houston * use an applicable SMOB to represent continuations, instead of a diff --git a/libguile/Makefile.am b/libguile/Makefile.am index fb523e2aa..938ca1794 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -49,7 +49,7 @@ libguile_la_SOURCES = \ print.c procprop.c procs.c random.c read.c root.c scmsigs.c \ script.c simpos.c smob.c sort.c srcprop.c stackchk.c stacks.c \ stime.c strings.c strop.c strorder.c strports.c struct.c symbols.c \ - tag.c throw.c variable.c vectors.c version.c vports.c weaks.c \ + tag.c throw.c values.c variable.c vectors.c version.c vports.c weaks.c \ gc_os_dep.c properties.c DOT_X_FILES = \ @@ -64,7 +64,7 @@ DOT_X_FILES = \ procs.x random.x read.x root.x scmsigs.x \ script.x simpos.x smob.x socket.x sort.x srcprop.x stackchk.x \ stacks.x stime.x strings.x strop.x strorder.x strports.x struct.x \ - symbols.x tag.x throw.x variable.x vectors.x \ + symbols.x tag.x throw.x values.x variable.x vectors.x \ version.x vports.x weaks.x properties.x EXTRA_DOT_X_FILES = debug-malloc.x filesys.x net_db.x posix.x ramap.x \ @@ -83,8 +83,9 @@ DOT_DOC_FILES = \ procprop.doc procs.doc random.doc read.doc root.doc scmsigs.doc \ script.doc simpos.doc smob.doc socket.doc sort.doc srcprop.doc \ stackchk.doc stacks.doc stime.doc strings.doc strop.doc strorder.doc \ - strports.doc struct.doc symbols.doc tag.doc throw.doc variable.doc \ - vectors.doc version.doc vports.doc weaks.doc properties.doc + strports.doc struct.doc symbols.doc tag.doc throw.doc values.doc \ + variable.doc vectors.doc version.doc vports.doc weaks.doc \ + properties.doc EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@ @@ -129,7 +130,8 @@ modinclude_HEADERS = \ ramap.h read.h root.h scmsigs.h validate.h script.h simpos.h \ smob.h socket.h sort.h srcprop.h stackchk.h stacks.h stime.h \ strings.h strop.h strorder.h strports.h struct.h symbols.h tag.h \ - tags.h throw.h unif.h variable.h vectors.h version.h vports.h \ + tags.h throw.h unif.h values.h variable.h vectors.h version.h \ + vports.h \ weaks.h snarf.h threads.h coop-defs.h fluids.h iselect.h \ debug-malloc.h properties.h diff --git a/libguile/continuations.c b/libguile/continuations.c index 108465d03..5ef2219f1 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -51,6 +51,7 @@ #include "libguile/smob.h" #include "libguile/ports.h" #include "libguile/dynwind.h" +#include "libguile/values.h" #ifdef DEBUG_EXTENSIONS #include "libguile/debug.h" @@ -216,11 +217,9 @@ scm_dynthrow (SCM cont, SCM val) #define FUNC_NAME "continuation_apply" static SCM continuation_apply (SCM cont, SCM args) { - /* FIXME: support R5RS multiple value continuations. */ scm_contregs *continuation = SCM_CONTREGS (cont); scm_contregs *rootcont = SCM_CONTREGS (scm_rootcont); - SCM_ASSERT (scm_ilength (args) == 1, args, SCM_ARGn, FUNC_NAME); if (continuation->seq != rootcont->seq /* this base comparison isn't needed */ || continuation->base != rootcont->base) @@ -231,7 +230,7 @@ static SCM continuation_apply (SCM cont, SCM args) scm_dowinds (continuation->dynenv, scm_ilength (scm_dynwinds) - continuation->dynenv); - scm_dynthrow (cont, SCM_CAR (args)); + scm_dynthrow (cont, scm_values (args)); return SCM_UNSPECIFIED; /* not reached */ } #undef FUNC_NAME diff --git a/libguile/init.c b/libguile/init.c index 16211518a..b4d7467d8 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -132,6 +132,7 @@ #include "libguile/tag.h" #include "libguile/throw.h" #include "libguile/unif.h" +#include "libguile/values.h" #include "libguile/variable.h" #include "libguile/vectors.h" #include "libguile/version.h" @@ -491,7 +492,7 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_init_subr_table (); scm_environments_prehistory (); /* create the root environment */ scm_init_continuations (); - scm_init_root (); + scm_init_root (); /* requires continuations */ #ifdef USE_THREADS scm_init_threads (base); #endif @@ -552,11 +553,12 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_init_srcprop (); #endif scm_init_stackchk (); - scm_init_struct (); /* Requires struct */ - scm_init_stacks (); + scm_init_struct (); + scm_init_stacks (); /* Requires struct */ scm_init_strports (); scm_init_symbols (); scm_init_tag (); + scm_init_values (); /* Requires struct */ scm_init_load (); scm_init_objects (); /* Requires struct */ scm_init_print (); /* Requires struct */ diff --git a/libguile/struct.h b/libguile/struct.h index b78f9a7f9..7c784eb3b 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -87,6 +87,8 @@ typedef scm_sizet (*scm_struct_free_t) (scm_bits_t * vtable, scm_bits_t * data); #define SCM_STRUCT_VTABLE(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_vtable])) #define SCM_STRUCT_PRINTER(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_printer])) +#define SCM_SET_STRUCT_PRINTER(x, v)\ + (SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_printer] = (v)) #define SCM_SET_VTABLE_DESTRUCTOR(X, D) (SCM_STRUCT_DATA (X) [scm_struct_i_free] = (scm_bits_t) (D)) /* Efficiency is important in the following macro, since it's used in GC */ #define SCM_LAYOUT_TAILP(X) (((X) & 32) == 0) /* R, W or O */ diff --git a/libguile/values.c b/libguile/values.c new file mode 100644 index 000000000..6575a147c --- /dev/null +++ b/libguile/values.c @@ -0,0 +1,154 @@ +/* Copyright (C) 2000 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 + * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +#include "libguile/_scm.h" +#include "libguile/eval.h" +#include "libguile/feature.h" +#include "libguile/gc.h" +#include "libguile/numbers.h" +#include "libguile/ports.h" +#include "libguile/root.h" +#include "libguile/strings.h" +#include "libguile/struct.h" +#include "libguile/validate.h" + +#include "libguile/values.h" + +static SCM values_vtable; + +#define SCM_VALUESP(x) (SCM_STRUCTP (x)\ + && SCM_EQ_P (scm_struct_vtable (x), values_vtable)) + +static SCM +print_values (SCM obj, SCM pwps) +{ + SCM values = scm_struct_ref (obj, SCM_INUM0); + SCM port = SCM_PORT_WITH_PS_PORT (pwps); + scm_print_state *ps = SCM_PRINT_STATE (SCM_PORT_WITH_PS_PS (pwps)); + + while (SCM_CONSP (values)) + { + scm_iprin1 (SCM_CAR (values), port, ps); + values = SCM_CDR (values); + if (SCM_CONSP (values)) + scm_newline (port); + } + return SCM_UNSPECIFIED; +} + +SCM_DEFINE (scm_values, "values", 0, 0, 1, + (SCM args), + "Delivers all of its arguments to its continuation. Except for\n" + "continuations created by the `call-with-values' procedure, all\n" + "continuations take exactly one value. The effect of passing no\n" + "value or more than one value to continuations that were not\n" + "created by call-with-values is unspecified.") +#define FUNC_NAME s_scm_values +{ + long n; + SCM result; + + SCM_VALIDATE_LIST_COPYLEN (1, args, n); + if (n == 1) + result = SCM_CAR (args); + else + { + result = scm_make_struct (values_vtable, SCM_INUM0, + scm_cons (args, SCM_EOL)); + } + + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_call_with_values, "call-with-values", 2, 0, 0, + (SCM producer, SCM consumer), + "Calls its @var{producer} argument with no values and a\n" + "continuation that, when passed some values, calls the\n" + "@var{consumer} procedure with those values as arguments. The\n" + "continuation for the call to @var{consumer} is the continuation\n" + "of the call to call-with-values.\n\n" + "@example\n" + "(call-with-values (lambda () (values 4 5))\n" + " (lambda (a b) b))\n" + " ==> 5\n\n" + "@end example\n" + "@example\n" + "(call-with-values * -) ==> -1\n" + "@end example") +#define FUNC_NAME s_scm_call_with_values +{ + SCM product; + + SCM_VALIDATE_PROC (1, producer); + SCM_VALIDATE_PROC (2, consumer); + + product = scm_apply (producer, SCM_EOL, SCM_EOL); + if (SCM_VALUESP (product)) + product = scm_struct_ref (product, SCM_INUM0); + else + product = scm_cons (product, SCM_EOL); + return scm_apply (consumer, product, SCM_EOL); +} +#undef FUNC_NAME + +void +scm_init_values (void) +{ + SCM print = scm_make_subr ("%print-values", scm_tc7_subr_2, print_values); + + values_vtable + = scm_permanent_object (scm_make_vtable_vtable (scm_makfrom0str ("pr"), + SCM_INUM0, SCM_EOL)); + SCM_SET_STRUCT_PRINTER (values_vtable, print); + + scm_add_feature ("values"); + +#ifndef SCM_MAGIC_SNARFER +#include "libguile/values.x" +#endif +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/values.h b/libguile/values.h new file mode 100644 index 000000000..79cdcf6fb --- /dev/null +++ b/libguile/values.h @@ -0,0 +1,60 @@ +/* classes: h_files */ + +#ifndef SCM_VALUES_H +#define SCM_VALUES_H +/* Copyright (C) 2000 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 + * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + + + +#include "libguile/__scm.h" + +extern SCM scm_values (SCM args); +extern SCM scm_call_with_values (SCM producer, SCM consumer); +extern void scm_init_values (void); + +#endif /* SCM_VALUES_H */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ From 3923fa6d06d0a84827296a23aa038b8dbe710321 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 26 Nov 2000 18:28:57 +0000 Subject: [PATCH 0385/2047] * boot-9.scm: values?, get-values, values, call-with-values: removed. values and call-with-values are now primitives and the other two were only exported by accident. don't define *values-rtd* record type or handle multiple values in scm-style-repl. --- ice-9/ChangeLog | 8 ++++++++ ice-9/boot-9.scm | 34 +--------------------------------- 2 files changed, 9 insertions(+), 33 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 4661db3f7..3373a9981 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,11 @@ +2000-11-26 Gary Houston + + * boot-9.scm: values?, get-values, values, call-with-values: + removed. values and call-with-values are now primitives and + the other two were only exported by accident. don't define + *values-rtd* record type or handle multiple values in + scm-style-repl. + 2000-11-07 Gary Houston * popen.scm (open-output-pipe): added docstrings for open-input-pipe diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index b6da0a85e..e128ec795 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -510,36 +510,6 @@ answer (loop (cons init answer) (- n 1))))) - - -;;; {Multiple return values} - -(define *values-rtd* - (make-record-type "values" - '(values))) - -;;; These two are needed internally in boot-9.scm. -;;; They shouldn't be visible outside this module. -(define values? (record-predicate *values-rtd*)) -(define get-values (record-accessor *values-rtd* 'values)) - -(define values - (let ((make-values (record-constructor *values-rtd*))) - (lambda x - (if (and (not (null? x)) - (null? (cdr x))) - (car x) - (make-values x))))) - -(define call-with-values - (lambda (producer consumer) - (let ((result (producer))) - (if (values? result) - (apply consumer (get-values result)) - (consumer result))))) - -(provide 'values) - ;;; {and-map and or-map} ;;; @@ -2591,9 +2561,7 @@ (lambda (result) (if (not scm-repl-silent) (begin - (if (values? result) - (for-each maybe-print (get-values result)) - (maybe-print result)) + (maybe-print result) (if scm-repl-verbose (repl-report)) (force-output)))))) From 9fb77163dddbf129de69c9a6e56e6e3bf8845845 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 28 Nov 2000 11:48:01 +0000 Subject: [PATCH 0386/2047] * Don't use make-shared-substring any more. --- guile-config/ChangeLog | 5 +++++ guile-config/guile-config.in | 6 +++--- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/guile-config/ChangeLog b/guile-config/ChangeLog index 144576ceb..90457a0e6 100644 --- a/guile-config/ChangeLog +++ b/guile-config/ChangeLog @@ -1,3 +1,8 @@ +2000-11-28 Dirk Herrmann + + * guile-config.in (build-link): Use substring instead of + make-shared-substring. + 2000-11-01 Dirk Herrmann * guile-config.in (display-line-port): Make sure all output is diff --git a/guile-config/guile-config.in b/guile-config/guile-config.in index bf55768d5..0e917889c 100644 --- a/guile-config/guile-config.in +++ b/guile-config/guile-config.in @@ -130,9 +130,9 @@ (let* ((base (basename path)) (len (string-length base))) (if (and (> len 5) - (string=? (make-shared-substring base 0 3) "lib") - (string=? (make-shared-substring base (- len 2)) ".a")) - (make-shared-substring base 3 (- len 2)) + (string=? (substring base 0 3) "lib") + (string=? (substring base (- len 2)) ".a")) + (substring base 3 (- len 2)) #f))) (if (> (length args) 0) From 4e15fee80f0abb1d4b1d8e0a683a810c53164166 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 28 Nov 2000 13:40:40 +0000 Subject: [PATCH 0387/2047] * Don't use make-shared-substring any more. --- ice-9/ChangeLog | 16 ++++++++++++ ice-9/boot-9.scm | 2 +- ice-9/lineio.scm | 2 +- ice-9/regex.scm | 15 ++++------- ice-9/slib.scm | 2 +- ice-9/string-fun.scm | 60 ++++++++++++++++++++++---------------------- 6 files changed, 54 insertions(+), 43 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 3373a9981..0f89081fd 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,19 @@ +2000-11-28 Dirk Herrmann + + * boot-9.scm (read-delimited), lineio.scm + (make-line-buffering-input-port), regex.scm (match:prefix, + match:suffix, match:substring, regexp-substitute/global), slib.scm + (slib-parent-dir), string-fun.scm (split-after-char, + split-before-char, split-discarding-char, split-after-char-last, + split-before-char-last, split-discarding-char-last, + split-before-predicate, split-after-predicate, + split-discarding-predicate, separate-fields-discarding-char, + separate-fields-after-char, separate-fields-before-char, + string-prefix-predicate, sans-surrounding-whitespace, + sans-trailing-whitespace, sans-leading-whitespace, + sans-final-newline): Use substring instead of + make-shared-substring. + 2000-11-26 Gary Houston * boot-9.scm: values?, get-values, values, call-with-values: diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index e128ec795..f9e134fd6 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -254,7 +254,7 @@ (not (eof-object? terminator))) (string terminator) "") - (cons (make-shared-substring buf 0 nchars) + (cons (substring buf 0 nchars) substrings)))))) (new-total (+ total-chars nchars))) (cond ((not terminator) diff --git a/ice-9/lineio.scm b/ice-9/lineio.scm index 1311bad88..e40b89353 100644 --- a/ice-9/lineio.scm +++ b/ice-9/lineio.scm @@ -86,7 +86,7 @@ (let ((c (string-ref (car buffers)))) (if (= 1 (string-length (car buffers))) (set! buffers (cdr buffers)) - (set-car! buffers (make-shared-substring (car buffers) 1))) + (set-car! buffers (substring (car buffers) 1))) c)))) (propogate-close (lambda () (close-port underlying-port))) diff --git a/ice-9/regex.scm b/ice-9/regex.scm index 8ca080988..3bda38b84 100644 --- a/ice-9/regex.scm +++ b/ice-9/regex.scm @@ -36,13 +36,10 @@ (vector-ref match 0)) (define-public (match:prefix match) - (make-shared-substring (match:string match) - 0 - (match:start match 0))) + (substring (match:string match) 0 (match:start match 0))) (define-public (match:suffix match) - (make-shared-substring (match:string match) - (match:end match 0))) + (substring (match:string match) (match:end match 0))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; SCSH compatibility routines. @@ -90,9 +87,7 @@ 0)) (start (match:start match matchnum)) (end (match:end match matchnum))) - (and start end (make-shared-substring (match:string match) - start - end)))) + (and start end (substring (match:string match) start end)))) (define-public (string-match pattern str . args) (let ((rx (make-regexp pattern)) @@ -167,7 +162,7 @@ (let next-match ((matches (list-matches regexp string)) (start 0)) (if (null? matches) - (display (make-shared-substring string start) port) + (display (substring string start) port) (let ((m (car matches))) ;; Process all of the items for this match. Don't use @@ -182,7 +177,7 @@ ((procedure? item) (display (item m) port)) ((eq? item 'pre) (display - (make-shared-substring string start (match:start m)) + (substring string start (match:start m)) port)) ((eq? item 'post) (next-match (cdr matches) (match:end m))) diff --git a/ice-9/slib.scm b/ice-9/slib.scm index 2bb33df13..72e7a6404 100644 --- a/ice-9/slib.scm +++ b/ice-9/slib.scm @@ -162,7 +162,7 @@ (define slib-parent-dir (let* ((path (%search-load-path "slib/require.scm"))) (if path - (make-shared-substring path 0 (- (string-length path) 17)) + (substring path 0 (- (string-length path) 17)) (error "Could not find slib/require.scm in " %load-path)))) (define-public (implementation-vicinity) diff --git a/ice-9/string-fun.scm b/ice-9/string-fun.scm index 92635d9b2..1973ef47b 100644 --- a/ice-9/string-fun.scm +++ b/ice-9/string-fun.scm @@ -92,71 +92,71 @@ (let ((end (cond ((string-index str char) => 1+) (else (string-length str))))) - (ret (make-shared-substring str 0 end) - (make-shared-substring str end)))) + (ret (substring str 0 end) + (substring str end)))) (define-public (split-before-char char str ret) (let ((end (or (string-index str char) (string-length str)))) - (ret (make-shared-substring str 0 end) - (make-shared-substring str end)))) + (ret (substring str 0 end) + (substring str end)))) (define-public (split-discarding-char char str ret) (let ((end (string-index str char))) (if (not end) (ret str "") - (ret (make-shared-substring str 0 end) - (make-shared-substring str (1+ end)))))) + (ret (substring str 0 end) + (substring str (1+ end)))))) (define-public (split-after-char-last char str ret) (let ((end (cond ((string-rindex str char) => 1+) (else 0)))) - (ret (make-shared-substring str 0 end) - (make-shared-substring str end)))) + (ret (substring str 0 end) + (substring str end)))) (define-public (split-before-char-last char str ret) (let ((end (or (string-rindex str char) 0))) - (ret (make-shared-substring str 0 end) - (make-shared-substring str end)))) + (ret (substring str 0 end) + (substring str end)))) (define-public (split-discarding-char-last char str ret) (let ((end (string-rindex str char))) (if (not end) (ret str "") - (ret (make-shared-substring str 0 end) - (make-shared-substring str (1+ end)))))) + (ret (substring str 0 end) + (substring str (1+ end)))))) (define-public (split-before-predicate pred str ret) (let loop ((n 0)) (cond ((= n (string-length str)) (ret str "")) ((not (pred (string-ref str n))) (loop (1+ n))) - (else (ret (make-shared-substring str 0 n) - (make-shared-substring str n)))))) + (else (ret (substring str 0 n) + (substring str n)))))) (define-public (split-after-predicate pred str ret) (let loop ((n 0)) (cond ((= n (string-length str)) (ret str "")) ((not (pred (string-ref str n))) (loop (1+ n))) - (else (ret (make-shared-substring str 0 (1+ n)) - (make-shared-substring str (1+ n))))))) + (else (ret (substring str 0 (1+ n)) + (substring str (1+ n))))))) (define-public (split-discarding-predicate pred str ret) (let loop ((n 0)) (cond ((= n (string-length str)) (ret str "")) ((not (pred (string-ref str n))) (loop (1+ n))) - (else (ret (make-shared-substring str 0 n) - (make-shared-substring str (1+ n))))))) + (else (ret (substring str 0 n) + (substring str (1+ n))))))) (define-public (separate-fields-discarding-char ch str ret) (let loop ((fields '()) (str str)) (cond ((string-rindex str ch) - => (lambda (w) (loop (cons (make-shared-substring str (+ 1 w)) fields) - (make-shared-substring str 0 w)))) + => (lambda (w) (loop (cons (substring str (+ 1 w)) fields) + (substring str 0 w)))) (else (apply ret str fields))))) (define-public (separate-fields-after-char ch str ret) @@ -165,8 +165,8 @@ (str str)) (cond ((string-index str ch) - => (lambda (w) (loop (cons (make-shared-substring str 0 (+ 1 w)) fields) - (make-shared-substring str (+ 1 w))))) + => (lambda (w) (loop (cons (substring str 0 (+ 1 w)) fields) + (substring str (+ 1 w))))) (else (apply ret str fields)))))) (define-public (separate-fields-before-char ch str ret) @@ -174,8 +174,8 @@ (str str)) (cond ((string-rindex str ch) - => (lambda (w) (loop (cons (make-shared-substring str w) fields) - (make-shared-substring str 0 w)))) + => (lambda (w) (loop (cons (substring str w) fields) + (substring str 0 w)))) (else (apply ret str fields))))) @@ -185,14 +185,14 @@ ;;; ;;; (define-public ((string-prefix-predicate pred?) prefix str) ;;; (and (<= (string-length prefix) (string-length str)) -;;; (pred? prefix (make-shared-substring str 0 (string-length prefix))))) +;;; (pred? prefix (substring str 0 (string-length prefix))))) ;;; ;;; (define-public string-prefix=? (string-prefix-predicate string=?)) ;;; (define-public ((string-prefix-predicate pred?) prefix str) (and (<= (string-length prefix) (string-length str)) - (pred? prefix (make-shared-substring str 0 (string-length prefix))))) + (pred? prefix (substring str 0 (string-length prefix))))) (define-public string-prefix=? (string-prefix-predicate string=?)) @@ -218,7 +218,7 @@ (set! end (1- end))) (if (< end st) "" - (make-shared-substring s st end)))) + (substring s st end)))) (define-public (sans-trailing-whitespace s) (let ((st 0) @@ -228,7 +228,7 @@ (set! end (1- end))) (if (< end st) "" - (make-shared-substring s st end)))) + (substring s st end)))) (define-public (sans-leading-whitespace s) (let ((st 0) @@ -238,7 +238,7 @@ (set! st (1+ st))) (if (< end st) "" - (make-shared-substring s st end)))) + (substring s st end)))) (define-public (sans-final-newline str) (cond @@ -246,7 +246,7 @@ str) ((char=? #\nl (string-ref str (1- (string-length str)))) - (make-shared-substring str 0 (1- (string-length str)))) + (substring str 0 (1- (string-length str)))) (else str))) From e51fe79c72be4b40e17fda03ba5dec2a06ae9bea Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 28 Nov 2000 16:37:40 +0000 Subject: [PATCH 0388/2047] * Removed SCM_SYMBOL_UCHARS. --- NEWS | 3 ++- libguile/ChangeLog | 9 +++++++++ libguile/struct.c | 16 ++++++++-------- libguile/symbols.c | 4 ++-- libguile/symbols.h | 15 +++++++-------- 5 files changed, 28 insertions(+), 19 deletions(-) diff --git a/NEWS b/NEWS index dca5b9aee..dd1d5df83 100644 --- a/NEWS +++ b/NEWS @@ -257,7 +257,8 @@ Use these instead of SCM_SETLENGTH SCM_VECTOR_BASE, SCM_UVECTOR_BASE, SCM_BITVECTOR_BASE, SCM_COMPLEX_MEM, SCM_ARRAY_MEM -Use these instead of SCM_CHARS or SCM_VELTS. +Use these instead of SCM_CHARS, SCM_UCHARS, SCM_ROCHARS, SCM_ROUCHARS or +SCM_VELTS. ** New macros: SCM_SET_BIGNUM_BASE, SCM_SET_STRING_CHARS, SCM_SET_SYMBOL_CHARS, SCM_SET_UVECTOR_BASE, SCM_SET_BITVECTOR_BASE, diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f3d90c0f5..f45b998c8 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2000-11-28 Dirk Herrmann + + * struct.c (scm_struct_ref, scm_struct_set_x), symbols.c + (scm_intern_obarray_soft), symbols.h (SCM_ROUCHARS): Eliminate + use of SCM_SYMBOL_UCHARS by using chars instead of unsigned + chars. + + (SCM_SYMBOL_UCHARS): Removed. + 2000-11-26 Gary Houston * reimplementation of values, call-with-values as primitives: diff --git a/libguile/struct.c b/libguile/struct.c index e6e0c5ec6..56de9c5c0 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -566,8 +566,8 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0, SCM layout; int p; scm_bits_t n_fields; - unsigned char * fields_desc; - unsigned char field_type = 0; + char * fields_desc; + char field_type = 0; SCM_VALIDATE_STRUCT (1,handle); @@ -577,14 +577,14 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0, data = SCM_STRUCT_DATA (handle); p = SCM_INUM (pos); - fields_desc = SCM_SYMBOL_UCHARS (layout); + fields_desc = SCM_SYMBOL_CHARS (layout); n_fields = data[scm_struct_i_n_words]; SCM_ASSERT_RANGE(1,pos, p < n_fields); if (p * 2 < SCM_SYMBOL_LENGTH (layout)) { - unsigned char ref; + char ref; field_type = fields_desc[p * 2]; ref = fields_desc[p * 2 + 1]; if ((ref != 'r') && (ref != 'w')) @@ -644,8 +644,8 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0, SCM layout; int p; int n_fields; - unsigned char * fields_desc; - unsigned char field_type = 0; + char * fields_desc; + char field_type = 0; SCM_VALIDATE_STRUCT (1,handle); SCM_VALIDATE_INUM (2,pos); @@ -654,14 +654,14 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0, data = SCM_STRUCT_DATA (handle); p = SCM_INUM (pos); - fields_desc = SCM_SYMBOL_UCHARS (layout); + fields_desc = SCM_SYMBOL_CHARS (layout); n_fields = data[scm_struct_i_n_words]; SCM_ASSERT_RANGE (1,pos, p < n_fields); if (p * 2 < SCM_SYMBOL_LENGTH (layout)) { - unsigned char set_x; + char set_x; field_type = fields_desc[p * 2]; set_x = fields_desc [p * 2 + 1]; if (set_x != 'w') diff --git a/libguile/symbols.c b/libguile/symbols.c index f3bd4a500..e4add2728 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -262,13 +262,13 @@ scm_intern_obarray_soft (const char *name,scm_sizet len,SCM obarray,unsigned int scm_sizet i; SCM a = SCM_CAR (lsym); SCM z = SCM_CAR (a); - unsigned char *tmp = SCM_SYMBOL_UCHARS (z); + char *tmp = SCM_SYMBOL_CHARS (z); if (SCM_SYMBOL_HASH (z) != raw_hash) goto trynext; if (SCM_SYMBOL_LENGTH (z) != len) goto trynext; for (i = len; i--;) - if (((unsigned char *) name)[i] != tmp[i]) + if (name[i] != tmp[i]) goto trynext; { SCM_REALLOW_INTS; diff --git a/libguile/symbols.h b/libguile/symbols.h index db846f2c7..2ce698652 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -56,12 +56,13 @@ extern int scm_symhash_dim; * SCM_SYMBOL_CHARS(SYM) is the address of the first character of SYM's name. */ -#define SCM_SYMBOLP(x) (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_symbol)) -#define SCM_SYMBOL_UCHARS(x) ((unsigned char *) (SCM_CELL_WORD_1 (x))) -#define SCM_SYMBOL_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) -#define SCM_SET_SYMBOL_CHARS(s, c) (SCM_SET_CELL_WORD_1 ((s), (c))) -#define SCM_SYMBOL_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) +#define SCM_SYMBOLP(x) (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_symbol)) +#define SCM_SYMBOL_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_SET_SYMBOL_LENGTH(s, l) (SCM_SET_CELL_WORD_0 ((s), ((l) << 8) + scm_tc7_symbol)) +#define SCM_SYMBOL_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) +#define SCM_SET_SYMBOL_CHARS(s, c) (SCM_SET_CELL_WORD_1 ((s), (c))) +#define SCM_SYMBOL_HASH(X) ((unsigned long) SCM_CELL_WORD_2 (X)) +#define SCM_SET_SYMBOL_HASH(X, v) (SCM_SET_CELL_WORD_2 ((X), (v))) #define SCM_PROP_SLOTS(X) (SCM_CELL_WORD_3 (X)) #define SCM_SET_PROP_SLOTS(X, v) (SCM_SET_CELL_WORD_3 ((X), (v))) @@ -69,8 +70,6 @@ extern int scm_symhash_dim; #define SCM_SET_SYMBOL_FUNC(X, v) (SCM_SETCAR (SCM_CELL_WORD_3 (X), (v))) #define SCM_SYMBOL_PROPS(X) (SCM_CDR (SCM_CELL_WORD_3 (X))) #define SCM_SET_SYMBOL_PROPS(X, v) (SCM_SETCDR (SCM_CELL_WORD_3 (X), (v))) -#define SCM_SYMBOL_HASH(X) (SCM_CELL_WORD_2 (X)) -#define SCM_SET_SYMBOL_HASH(X, v) (SCM_SET_CELL_WORD_2 ((X), (v))) @@ -132,7 +131,7 @@ extern void scm_init_symbols (void); ? (SCM_INUM (SCM_CADR (x)) + SCM_STRING_UCHARS (SCM_CDDR (x))) \ : ((SCM_TYP7 (x) == scm_tc7_string) \ ? SCM_STRING_UCHARS (x) \ - : SCM_SYMBOL_UCHARS (x))) + : (unsigned char *) SCM_SYMBOL_CHARS (x))) #define SCM_SUBSTRP(x) (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_substring)) #define SCM_COERCE_SUBSTR(x) SCM_STRING_COERCE_0TERMINATION_X (x) #define scm_strhash(str, len, n) (scm_string_hash ((str), (len)) % (n)) From 2b7b76d505397cbe7679d11c7f79c5279ee2a753 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 28 Nov 2000 18:22:23 +0000 Subject: [PATCH 0389/2047] * Removed outdated comment. --- libguile/ChangeLog | 4 ++++ libguile/strop.c | 6 +----- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f45b998c8..34c76e823 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2000-11-28 Dirk Herrmann + + * strop.c (scm_i_index): Removed outdated comment. + 2000-11-28 Dirk Herrmann * struct.c (scm_struct_ref, scm_struct_set_x), symbols.c diff --git a/libguile/strop.c b/libguile/strop.c index ce6beeb01..fd78a9f3f 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -44,11 +44,7 @@ xSCM_DEFINE (scm_i_index, "i-index", 2, 2, 0, "@deftypefn {Internal C Function} {static int} scm_i_index (SCM *@var{str}, \n" "SCM @var{chr}, int @var{direction}, SCM @var{sub_start}, SCM @var{sub_end}, char *@var{why}) "This is a workhorse function that performs either an @code{index} or\n" - "@code{rindex} function, depending on the value of @var{direction}. I'm\n" - "not at all clear on the usage of the pos arguments, though the purpose\n" - "seems to be correct reporting of which argument values are reporting\n" - "errors. Why you would do that, rather than just use @code{SCM_ARG[1234]}\n" - "explicitly is beyond me. Anyone holding any enlightenment?" + "@code{rindex} function, depending on the value of @var{direction}." */ /* implements index if direction > 0 otherwise rindex. */ static int From 818febc097198ab0b01cc87e485d2b1a36e70ee1 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Wed, 29 Nov 2000 21:27:13 +0000 Subject: [PATCH 0390/2047] *** empty log message *** --- NEWS | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/NEWS b/NEWS index dd1d5df83..3629ee473 100644 --- a/NEWS +++ b/NEWS @@ -87,6 +87,9 @@ Example: * Changes to Scheme functions and syntax +** Escape procedures created by call-with-current-continuation now +accept any number of arguments, as required by R5RS. + ** New function `make-object-property' This function returns a new `procedure with setter' P that can be used @@ -303,6 +306,9 @@ Use a type specific length macro instead of SCM_LENGTH_MAX. ** Removed function: scm_struct_init +** Renamed function: scm_make_cont has been replaced by +scm_make_continuation, which has a different interface. + ** Deprecated function: scm_call_catching_errors Use scm_catch or scm_lazy_catch from throw.[ch] instead. From 21e8f468cf4a1ebad24b286249ae1983b672af47 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 30 Nov 2000 10:26:44 +0000 Subject: [PATCH 0391/2047] * coop-threads.c: Don't join finished threads. Thanks to Julian Satchell. * coop.c: Removed old non-working code. --- THANKS | 9 +++++---- libguile/ChangeLog | 10 ++++++++++ libguile/coop-threads.c | 19 ++++++++++++++++--- libguile/coop.c | 11 +---------- 4 files changed, 32 insertions(+), 17 deletions(-) diff --git a/THANKS b/THANKS index 6f00ba104..62c8b1030 100644 --- a/THANKS +++ b/THANKS @@ -1,14 +1,14 @@ The Guile maintainer committee consists of Jim Blandy + Mikael Djurfeldt Maciej Stachowiak Marius Vollmer - Mikael Djurfeldt Contributors since the last release: - Greg Harvey Jost Boekemeier + Greg Harvey For fixes or providing information which led to a fix: @@ -19,11 +19,12 @@ For fixes or providing information which led to a fix: Brad Knotwell Matthias Köppe Bruce Korb + Ralf Mattes Shuji Narazaki Nicolas Neuss Han-Wen Nienhuys David Pirotte - William Webber + Julian Satchell Dale P. Smith - Ralf Mattes Jacques A. Vidrine. + William Webber diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 34c76e823..22c712fa4 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,13 @@ +2000-11-30 Dirk Herrmann + + Thanks to Julian Satchell for the bug report: + + * coop-threads.c (scm_join_thread): Check whether a thread is + finished before trying to join it. + + * coop.c (coop_aborthelp, coop_join): When a thread finishes, its + stack base is not set to NULL any more. + 2000-11-28 Dirk Herrmann * strop.c (scm_i_index): Removed outdated comment. diff --git a/libguile/coop-threads.c b/libguile/coop-threads.c index 8214584e8..60f07f64e 100644 --- a/libguile/coop-threads.c +++ b/libguile/coop-threads.c @@ -377,11 +377,24 @@ scm_spawn_thread (scm_catch_body_t body, void *body_data, } SCM -scm_join_thread (SCM t) +scm_join_thread (SCM thread) #define FUNC_NAME s_join_thread { - SCM_VALIDATE_THREAD (1,t); - coop_join (SCM_THREAD_DATA (t)); + coop_t *thread_data; + SCM_VALIDATE_THREAD (1, thread); + /* Dirk:FIXME:: SCM_THREAD_DATA is a handle for a thread. It may be that a + * certain thread implementation uses a value of 0 as a valid thread handle. + * With the following code, this thread would always be considered finished. + */ + /* Dirk:FIXME:: With preemptive threading, a thread may finish immediately + * after SCM_THREAD_DATA is read. Thus, it must be guaranteed that the + * handle remains valid until the thread-object is garbage collected, or + * a mutex has to be used for reading and modifying SCM_THREAD_DATA. + */ + thread_data = SCM_THREAD_DATA (thread); + if (thread_data) + /* The thread is still alive */ + coop_join (thread_data); return SCM_BOOL_T; } #undef FUNC_NAME diff --git a/libguile/coop.c b/libguile/coop.c index a79c416f0..339acc95e 100644 --- a/libguile/coop.c +++ b/libguile/coop.c @@ -40,7 +40,7 @@ * If you do not wish that, delete this exception notice. */ -/* $Id: coop.c,v 1.25 2000-04-21 14:16:30 mdj Exp $ */ +/* $Id: coop.c,v 1.26 2000-11-30 10:26:44 dirk Exp $ */ /* Cooperative thread library, based on QuickThreads */ @@ -698,11 +698,6 @@ coop_aborthelp (qt_t *sp, void *old, void *null) { coop_t *oldthread = (coop_t *) old; -#if 0 - /* Marking old->base NULL indicates that this thread is dead */ - oldthread->base = NULL; -#endif - if (oldthread->specific) free (oldthread->specific); #ifndef GUILE_PTHREAD_COMPAT @@ -721,10 +716,6 @@ coop_join(coop_t *t) { coop_t *old, *newthread; - /* Check if t is already finished */ - if (t->base == NULL) - return; - /* Create a join list if necessary */ if (t->joining == NULL) { From 23437298cc331ea70e7a85ecd33d6ff457383fb2 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 1 Dec 2000 16:05:33 +0000 Subject: [PATCH 0392/2047] * Started goops cleanup. --- libguile/ChangeLog | 8 ++++ libguile/goops.c | 108 ++++++++++++++++++++++++++------------------- 2 files changed, 71 insertions(+), 45 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 22c712fa4..d36f3dde3 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2000-12-01 Dirk Herrmann + + * goops.c (scm_sys_compute_slots, scm_i_get_keyword, + scm_get_keyword, scm_slot_ref_using_class, + scm_slot_set_using_class_x): Update the code to match guile's + current style (e. g. using SCM_DEFINE, adding comments, removing + unnecessary SCM_NIMP tests etc.). + 2000-11-30 Dirk Herrmann Thanks to Julian Satchell for the bug report: diff --git a/libguile/goops.c b/libguile/goops.c index 154c7d085..d0e04533d 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -293,16 +293,21 @@ maplist (SCM ls) return orig; } -SCM_PROC (s_sys_compute_slots, "%compute-slots", 1, 0, 0, scm_sys_compute_slots); -SCM -scm_sys_compute_slots (SCM class) +SCM_DEFINE (scm_sys_compute_slots, "%compute-slots", 1, 0, 0, + (SCM class), + "Return a list consisting of the names of all slots belonging\n" + "to class CLASS, i. e. the slots of CLASS and of all of its\n" + "superclasses.") +#define FUNC_NAME s_scm_sys_compute_slots { - SCM_ASSERT (SCM_NIMP (class) && CLASSP (class), - class, SCM_ARG1, s_sys_compute_slots); + SCM_ASSERT (CLASSP (class), class, SCM_ARG1, FUNC_NAME); + return build_slots_list (SCM_SLOT (class, scm_si_direct_slots), SCM_SLOT (class, scm_si_cpl)); } +#undef FUNC_NAME + /****************************************************************************** * @@ -354,36 +359,44 @@ compute_getters_n_setters (SCM slots) SCM scm_i_get_keyword (SCM key, SCM l, int len, SCM default_value, const char *subr) { - int i; - for (i = 0; i < len; i += 2) + unsigned int i; + + for (i = 0; i != len; i += 2) { - if (!(SCM_NIMP (SCM_CAR (l)) && SCM_KEYWORDP (SCM_CAR (l)))) - scm_misc_error (subr, - "bad keyword: ~S", - SCM_LIST1 (SCM_CAR (l))); - if (SCM_CAR (l) == key) + SCM obj = SCM_CAR (l); + + if (!SCM_KEYWORDP (obj)) + scm_misc_error (subr, "bad keyword: ~S", SCM_LIST1 (obj)); + else if (SCM_EQ_P (obj, key)) return SCM_CADR (l); - l = SCM_CDDR (l); + else + l = SCM_CDDR (l); } + return default_value; } -SCM_PROC (s_get_keyword, "get-keyword", 3, 0, 0, scm_get_keyword); -SCM -scm_get_keyword (SCM key, SCM l, SCM default_value) +SCM_DEFINE (scm_get_keyword, "get-keyword", 3, 0, 0, + (SCM key, SCM l, SCM default_value), + "Determine an associated value for the keyword KEY from the\n" + "list L. The list L has to consist of an even number of\n" + "elements, where, starting with the first, every second element\n" + "is a keyword, followed by its associated value. If L does not\n" + "hold a value for KEY, the value DEFAULT_VALUE is returned.") +#define FUNC_NAME s_scm_get_keyword { int len; - SCM_ASSERT (SCM_NIMP (key) && SCM_KEYWORDP (key), - key, - "Bad keyword: ~S", - s_get_keyword); + + SCM_ASSERT (SCM_KEYWORDP (key), key, SCM_ARG1, FUNC_NAME); len = scm_ilength (l); - SCM_ASSERT (len >= 0 && (len & 1) == 0, l, - "Bad keyword-value list: ~S", - s_get_keyword); - return scm_i_get_keyword (key, l, len, default_value, s_get_keyword); + if (len < 0 || len % 1 == 1) + scm_misc_error (FUNC_NAME, "Bad keyword-value list: ~S", SCM_LIST1 (l)); + + return scm_i_get_keyword (key, l, len, default_value, FUNC_NAME); } +#undef FUNC_NAME + SCM_PROC (s_sys_initialize_object, "%initialize-object", 2, 0, 0, scm_sys_initialize_object); @@ -1052,7 +1065,7 @@ get_slot_value (SCM class, SCM obj, SCM slotdef) /* Two cases here: * - access is an integer (the offset of this slot in the slots vector) * - otherwise (car access) is the getter function to apply - */ + */ if (SCM_INUMP (access)) return SCM_SLOT (obj, SCM_INUM (access)); else @@ -1137,39 +1150,38 @@ test_slot_existence (SCM class, SCM obj, SCM slot_name) /* ======================================== */ -SCM_PROC (s_slot_ref_using_class, "slot-ref-using-class", 3, 0, 0, scm_slot_ref_using_class); - -SCM -scm_slot_ref_using_class (SCM class, SCM obj, SCM slot_name) +SCM_DEFINE (scm_slot_ref_using_class, "slot-ref-using-class", 3, 0, 0, + (SCM class, SCM obj, SCM slot_name), + "") +#define FUNC_NAME s_scm_slot_ref_using_class { SCM res; - SCM_ASSERT (SCM_NIMP (class) && CLASSP (class), - class, SCM_ARG1, s_slot_ref_using_class); - SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj), - obj, SCM_ARG1, s_slot_ref_using_class); - SCM_ASSERT (SCM_NIMP (slot_name) && SCM_SYMBOLP (slot_name), - obj, SCM_ARG3, s_slot_ref_using_class); + SCM_ASSERT (CLASSP (class), class, SCM_ARG1, FUNC_NAME); + SCM_ASSERT (SCM_INSTANCEP (obj), obj, SCM_ARG1, FUNC_NAME); + SCM_ASSERT (SCM_SYMBOLP (slot_name), obj, SCM_ARG3, FUNC_NAME); res = get_slot_value_using_name (class, obj, slot_name); if (SCM_GOOPS_UNBOUNDP (res)) return CALL_GF3 ("slot-unbound", class, obj, slot_name); return res; } - -SCM_PROC (s_slot_set_using_class_x, "slot-set-using-class!", 4, 0, 0, scm_slot_set_using_class_x); +#undef FUNC_NAME -SCM -scm_slot_set_using_class_x (SCM class, SCM obj, SCM slot_name, SCM value) + +SCM_DEFINE (scm_slot_set_using_class_x, "slot-set-using-class!", 4, 0, 0, + (SCM class, SCM obj, SCM slot_name, SCM value), + "") +#define FUNC_NAME s_scm_slot_set_using_class_x { - SCM_ASSERT (SCM_NIMP (class) && CLASSP (class), - class, SCM_ARG1, s_slot_set_using_class_x); - SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj), - obj, SCM_ARG2, s_slot_set_using_class_x); - SCM_ASSERT (SCM_NIMP (slot_name) && SCM_SYMBOLP (slot_name), - obj, SCM_ARG3, s_slot_set_using_class_x); + SCM_ASSERT (CLASSP (class), class, SCM_ARG1, FUNC_NAME); + SCM_ASSERT (SCM_INSTANCEP (obj), obj, SCM_ARG2, FUNC_NAME); + SCM_ASSERT (SCM_SYMBOLP (slot_name), obj, SCM_ARG3, FUNC_NAME); + return set_slot_value_using_name (class, obj, slot_name, value); } +#undef FUNC_NAME + SCM_PROC (s_slot_bound_using_class_p, "slot-bound-using-class?", 3, 0, 0, scm_slot_bound_using_class_p); @@ -2711,3 +2723,9 @@ scm_init_oop_goops_goopscore_module () { scm_register_module_xxx ("oop goops goopscore", (void *) scm_init_goops); } + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ From 79a3dafe673529ac2ad909259dc6752226c5a484 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 1 Dec 2000 17:57:42 +0000 Subject: [PATCH 0393/2047] * Added scm_c_memq as a fast C level alternative for scm_memq. --- NEWS | 12 +++++++++++- libguile/ChangeLog | 10 ++++++++++ libguile/goops.c | 23 ++++------------------- libguile/goops.h | 2 +- libguile/list.c | 26 ++++++++++++++++++++------ libguile/list.h | 1 + 6 files changed, 47 insertions(+), 27 deletions(-) diff --git a/NEWS b/NEWS index 3629ee473..946ea9999 100644 --- a/NEWS +++ b/NEWS @@ -170,7 +170,7 @@ Guile. ** Deprecated: scm_sloppy_memq, scm_sloppy_memv, scm_sloppy_member -Instead, use scm_memq, scm_memv, scm_member. +Instead, use scm_c_memq or scm_memq, scm_memv, scm_member. ** New function: port? X @@ -231,6 +231,16 @@ amount of smob memory you free. The previous method, which involved calling scm_done_malloc with negative argument, was somewhat unintuitive (and is still available, of course). +** New function: scm_c_memq (SCM obj, SCM list) + +This function provides a fast C level alternative for scm_memq for the case +that the list parameter is known to be a proper list. The function is a +replacement for scm_sloppy_memq, but is stricter in its requirements on its +list input parameter, since for anything else but a proper list the function's +behaviour is undefined - it may even crash or loop endlessly. Further, for +the case that the object is not found in the list, scm_c_memq returns #f which +is similar to scm_memq, but different from scm_sloppy_memq's behaviour. + ** New global variable scm_gc_running_p introduced. Use this variable to find out if garbage collection is being executed. Up to diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d36f3dde3..bad410348 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,13 @@ +2000-12-01 Dirk Herrmann + + * list.[ch] (scm_c_memq): Added as a fast C level alternative for + scm_memq for the case that the list parameter is known to be a + proper list. + + * goops.c (filter_cpl, remove_duplicate_slots, applicablep), + goops.h (SCM_SUBCLASSP): Use scm_c_memq if we are sure that we + pass proper lists. + 2000-12-01 Dirk Herrmann * goops.c (scm_sys_compute_slots, scm_i_get_keyword, diff --git a/libguile/goops.c b/libguile/goops.c index d0e04533d..470d14616 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -218,7 +218,7 @@ filter_cpl (SCM ls) while (SCM_NIMP (ls)) { SCM el = SCM_CAR (ls); - if (SCM_FALSEP (scm_memq (el, res))) + if (SCM_FALSEP (scm_c_memq (el, res))) res = scm_cons (el, res); ls = SCM_CDR (ls); } @@ -259,7 +259,7 @@ remove_duplicate_slots (SCM l, SCM res, SCM slots_already_seen) "bad slot name ~S", SCM_LIST1 (tmp)); - if (SCM_FALSEP (scm_memq (tmp, slots_already_seen))) { + if (SCM_FALSEP (scm_c_memq (tmp, slots_already_seen))) { res = scm_cons (SCM_CAR (l), res); slots_already_seen = scm_cons (tmp, slots_already_seen); } @@ -1674,23 +1674,8 @@ scm_primitive_generic_generic (SCM subr) static int applicablep (SCM actual, SCM formal) { - register SCM ptr; - - /* We test that (memq formal (slot-ref actual 'cpl)) - * However, we don't call memq here since we already know that - * the list is well formed - */ - for (ptr=SCM_SLOT(actual, scm_si_cpl); SCM_NNULLP(ptr); ptr = SCM_CDR(ptr)) { - if (SCM_NIMP (ptr) && SCM_CONSP (ptr)) { - if (SCM_CAR (ptr) == formal) - return 1; - } - else - scm_misc_error (0, - "Internal error in applicable: bad list ~S", - SCM_LIST1 (actual)); - } - return 0; + /* We already know that the cpl is well formed. */ + return !SCM_FALSEP (scm_c_memq (formal, SCM_SLOT (actual, scm_si_cpl))); } static int diff --git a/libguile/goops.h b/libguile/goops.h index db4659b72..2092f9082 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -134,7 +134,7 @@ typedef struct scm_method_t { | SCM_CLASSF_SIMPLE_METHOD)) #define SCM_SLOT(x, i) (SCM_INST(x)[i]) -#define SCM_SUBCLASSP(c1, c2) (!SCM_FALSEP (scm_memq (c2, SCM_SLOT (c1, scm_si_cpl)))) +#define SCM_SUBCLASSP(c1, c2) (!SCM_FALSEP (scm_c_memq (c2, SCM_SLOT (c1, scm_si_cpl)))) #define SCM_IS_A_P(x, c) (SCM_NIMP (x) \ && SCM_INSTANCEP (x) \ && SCM_SUBCLASSP (SCM_CLASS_OF (x), c)) diff --git a/libguile/list.c b/libguile/list.c index 5b0458ff7..0f62c1873 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -558,6 +558,25 @@ SCM_DEFINE (scm_sloppy_member, "sloppy-member", 2, 0, 0, #endif /* DEPRECATED */ +/* The function scm_c_memq returns the first sublist of list whose car is + * 'eq?' obj, where the sublists of list are the non-empty lists returned by + * (list-tail list k) for k less than the length of list. If obj does not + * occur in list, then #f (not the empty list) is returned. (r5rs) + * List must be a proper list, otherwise scm_c_memq may crash or loop + * endlessly. + */ +SCM +scm_c_memq (SCM obj, SCM list) +{ + for (; !SCM_NULLP (list); list = SCM_CDR (list)) + { + if (SCM_EQ_P (SCM_CAR (list), obj)) + return list; + } + return SCM_BOOL_F; +} + + SCM_DEFINE (scm_memq, "memq", 2, 0, 0, (SCM x, SCM lst), "Return the first sublist of LST whose car is `eq?' to X\n" @@ -568,12 +587,7 @@ SCM_DEFINE (scm_memq, "memq", 2, 0, 0, #define FUNC_NAME s_scm_memq { SCM_VALIDATE_LIST (2, lst); - for (; !SCM_NULLP (lst); lst = SCM_CDR (lst)) - { - if (SCM_EQ_P (SCM_CAR (lst), x)) - return lst; - } - return SCM_BOOL_F; + return scm_c_memq (x, lst); } #undef FUNC_NAME diff --git a/libguile/list.h b/libguile/list.h index f24d54331..96163ec87 100644 --- a/libguile/list.h +++ b/libguile/list.h @@ -83,6 +83,7 @@ extern SCM scm_list_set_x (SCM lst, SCM k, SCM val); extern SCM scm_list_cdr_set_x (SCM lst, SCM k, SCM val); extern SCM scm_last_pair (SCM sx); extern SCM scm_list_tail (SCM lst, SCM k); +extern SCM scm_c_memq (SCM x, SCM lst); extern SCM scm_memq (SCM x, SCM lst); extern SCM scm_memv (SCM x, SCM lst); extern SCM scm_member (SCM x, SCM lst); From 8c921d5c8df4a6621619b85d3b94e7c6d5f5bde7 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 4 Dec 2000 16:31:03 +0000 Subject: [PATCH 0394/2047] * Eliminate hard-coded value of scm_tc7_smob. --- libguile/ChangeLog | 5 +++++ libguile/tags.h | 13 +++++-------- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index bad410348..9290e1b66 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-12-04 Dirk Herrmann + + * tags.h (scm_tc_free_cell, scm_tc16_big, scm_tc16_real, + scm_tc16_complex): Eliminate hard-coded value of scm_tc7_smob. + 2000-12-01 Dirk Herrmann * list.[ch] (scm_c_memq): Added as a fast C level alternative for diff --git a/libguile/tags.h b/libguile/tags.h index a3f7ccb0a..d07f2aaa1 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -395,16 +395,13 @@ typedef long scm_bits_t; /* scm_tc_free_cell is also the 0th smob type. We place this * in free cells to tell the conservative marker not to trace it. */ -#define scm_tc_free_cell 0x007f +#define scm_tc_free_cell (scm_tc7_smob + 0 * 256L) -/* Smob type 1 (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 0x017f - -/* Smob types 2 and 3: - */ -#define scm_tc16_real 0x027f -#define scm_tc16_complex 0x037f +#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 362306b956fae0a8f7c345ef699a1376b24810f2 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 4 Dec 2000 17:19:35 +0000 Subject: [PATCH 0395/2047] =?UTF-8?q?*=20Minor=20cleanup/optimization=20fo?= =?UTF-8?q?r=20char=3D=3F.=20*=20Cleanup=20CCLO=20handling.?= --- libguile/ChangeLog | 9 +++++++++ libguile/chars.c | 6 +++--- libguile/gc.c | 20 ++++++++++++-------- libguile/procprop.c | 35 +++++++++++++++++++++-------------- 4 files changed, 45 insertions(+), 25 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 9290e1b66..f41e71819 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2000-12-04 Dirk Herrmann + + * chars.c (scm_char_eq_p): Minor cleanup/optimization. + + * gc.c (scm_gc_mark): Don't use SCM_VELTS for CCLOs. + + * procprop.c (scm_i_procedure_arity): Separate handling of smobs + and CCLOs. + 2000-12-04 Dirk Herrmann * tags.h (scm_tc_free_cell, scm_tc16_big, scm_tc16_real, diff --git a/libguile/chars.c b/libguile/chars.c index 38257012b..9ca1fac6b 100644 --- a/libguile/chars.c +++ b/libguile/chars.c @@ -66,9 +66,9 @@ SCM_DEFINE1 (scm_char_eq_p, "char=?", scm_tc7_rpsubr, "Return @code{#t} iff @var{x} is the same character as @var{y}, else @code{#f}.") #define FUNC_NAME s_scm_char_eq_p { - SCM_VALIDATE_CHAR (1,x); - SCM_VALIDATE_CHAR (2,y); - return SCM_BOOL(SCM_CHAR(x) == SCM_CHAR(y)); + SCM_VALIDATE_CHAR (1, x); + SCM_VALIDATE_CHAR (2, y); + return SCM_BOOL (SCM_EQ_P (x, y)); } #undef FUNC_NAME diff --git a/libguile/gc.c b/libguile/gc.c index 5c8a86ac4..3f24dc3ee 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1212,14 +1212,18 @@ gc_mark_nimp: goto gc_mark_loop; #ifdef CCLO case scm_tc7_cclo: - i = SCM_CCLO_LENGTH (ptr); - if (i == 0) - break; - while (--i > 0) - if (SCM_NIMP (SCM_VELTS (ptr)[i])) - scm_gc_mark (SCM_VELTS (ptr)[i]); - ptr = SCM_VELTS (ptr)[0]; - goto gc_mark_loop; + { + unsigned long int i = SCM_CCLO_LENGTH (ptr); + unsigned long int j; + for (j = 1; j != i; ++j) + { + SCM obj = SCM_CCLO_REF (ptr, j); + if (!SCM_IMP (obj)) + scm_gc_mark (obj); + } + ptr = SCM_CCLO_REF (ptr, 0); + goto gc_mark_loop; + } #endif #ifdef HAVE_ARRAYS case scm_tc7_bvect: diff --git a/libguile/procprop.c b/libguile/procprop.c index feb42f7b3..9d9a131eb 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -98,26 +98,33 @@ scm_i_procedure_arity (SCM proc) r = 1; break; case scm_tc7_smob: - { - int type; - if (!SCM_SMOB_DESCRIPTOR (proc).apply) - return SCM_BOOL_F; - type = SCM_SMOB_DESCRIPTOR (proc).gsubr_type; - goto gsubr_type; - case scm_tc7_cclo: - if (SCM_EQ_P (SCM_CCLO_SUBR (proc), scm_f_gsubr_apply)) + if (SCM_SMOB_DESCRIPTOR (proc).apply) { - type = SCM_INUM (SCM_GSUBR_TYPE (proc)); - gsubr_type: + int type = SCM_SMOB_DESCRIPTOR (proc).gsubr_type; a += SCM_GSUBR_REQ (type); o = SCM_GSUBR_OPT (type); r = SCM_GSUBR_REST (type); break; } - proc = SCM_CCLO_SUBR (proc); - a -= 1; - goto loop; - } + else + { + return SCM_BOOL_F; + } + case scm_tc7_cclo: + if (SCM_EQ_P (SCM_CCLO_SUBR (proc), scm_f_gsubr_apply)) + { + int type = SCM_INUM (SCM_GSUBR_TYPE (proc)); + a += SCM_GSUBR_REQ (type); + o = SCM_GSUBR_OPT (type); + r = SCM_GSUBR_REST (type); + break; + } + else + { + proc = SCM_CCLO_SUBR (proc); + a -= 1; + goto loop; + } case scm_tc7_pws: proc = SCM_PROCEDURE (proc); goto loop; From 01449aa511158bc6f2639dfeff67eec56fc1b696 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 5 Dec 2000 03:04:20 +0000 Subject: [PATCH 0396/2047] * Changed guardian representation to applicable smob. * Improved error reporting for dynamic loading. --- libguile/ChangeLog | 27 ++++++++ libguile/dynl.c | 7 +- libguile/guardians.c | 162 ++++++++++++++++++++++--------------------- 3 files changed, 116 insertions(+), 80 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f41e71819..b572145ce 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,30 @@ +2000-12-05 Dirk Herrmann + + * dynl.c (sysdep_dynl_link): Improved error reporting. + + * guardians.c: Changed the representation from a compiled closure + to an applicable smob. + + (guard1, CCLO_G): Removed. + + (guard, g_mark, g_print, scm_tc16_guardian, scm_guardian_gc_init, + scm_guardian_zombify): Renamed to guardian_apply, guardian_mark, + guardian_print, tc16_guardian, guardian_gc_init and + guardian_zombify, respectively. + + (guardian_free): Added, fixes a memory leak. + + (guardian_print): Don't use sprintf hack. + + (guardian_apply, scm_guard, scm_get_one_zombie, + scm_make_guardian): Don't use a compiled closure. + + (guardian_zombify): Prefer !SCM_NULLP over SCM_NIMP. No need to + use SCM_GCCDR any more. Simplified loop condition. + + (scm_init_guardian): Don't use scm_make_smob_type_mfpe for smob + initialization. Initialize applicable smob. + 2000-12-04 Dirk Herrmann * chars.c (scm_char_eq_p): Minor cleanup/optimization. diff --git a/libguile/dynl.c b/libguile/dynl.c index f554c39c0..6b301ea84 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -239,8 +239,13 @@ sysdep_dynl_link (const char *fname, const char *subr) handle = lt_dlopenext (fname); if (NULL == handle) { + SCM fn; + SCM msg; + SCM_ALLOW_INTS; - scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL); + fn = scm_makfrom0str (fname); + msg = scm_makfrom0str (lt_dlerror ()); + scm_misc_error (subr, "file: ~S, message: ~S", SCM_LIST2 (fn, msg)); } return (void *) handle; } diff --git a/libguile/guardians.c b/libguile/guardians.c index edaa8c8f8..7cf09522e 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -54,24 +54,29 @@ * Modified by: Mikael Djurfeldt */ -#include -#include #include "libguile/_scm.h" #include "libguile/ports.h" #include "libguile/print.h" #include "libguile/smob.h" -#include "libguile/vectors.h" #include "libguile/validate.h" #include "libguile/guardians.h" -static long scm_tc16_guardian; /* The live and zombies FIFOs are implemented as tconcs as described in Dybvig's paper. This decouples addition and removal of elements so that no synchronization between these needs to take place. */ + +typedef struct tconc_t +{ + SCM head; + SCM tail; +} tconc_t; + +#define TCONC_EMPTYP(tc) (SCM_EQ_P ((tc).head, (tc).tail)) + #define TCONC_IN(tc, obj, pair) \ do { \ SCM_SETCAR ((tc).tail, obj); \ @@ -87,13 +92,8 @@ do { \ (tc).head = SCM_CDR ((tc).head); \ } while (0) -#define TCONC_EMPTYP(tc) (SCM_EQ_P ((tc).head, (tc).tail)) -typedef struct tconc_t -{ - SCM head; - SCM tail; -} tconc_t; +static long tc16_guardian; typedef struct guardian_t { @@ -107,59 +107,96 @@ typedef struct guardian_t #define GUARDIAN_ZOMBIES(x) (GUARDIAN (x)->zombies) #define GUARDIAN_NEXT(x) (GUARDIAN (x)->next) -#define CCLO_G(cclo) (SCM_VELTS (cclo)[1]) -/* subr constructed from guard below. */ -static SCM guard1; +/* during the gc mark phase, live guardians are linked into a list here. */ +static guardian_t *first_live_guardian = NULL; +static guardian_t **current_link_field = NULL; -/* this is wrapped in a compiled closure and is the Scheme entry point - for each guardian: if arg is an object, it's added to the - guardian's live list. if arg is unbound, the next available - zombified object (or #f if none) is returned. */ + +/* mark a guardian by adding it to the live guardian list. */ static SCM -guard (SCM cclo, SCM arg) +guardian_mark (SCM ptr) +{ + *current_link_field = GUARDIAN (ptr); + current_link_field = &GUARDIAN_NEXT (ptr); + GUARDIAN_NEXT (ptr) = NULL; + + /* the objects protected by the guardian are not marked here: that + would prevent them from ever getting collected. instead marking + is done at the end of the mark phase by scm_guardian_zombify. */ + return SCM_BOOL_F; +} + + +static scm_sizet +guardian_free (SCM ptr) +{ + scm_must_free (GUARDIAN (ptr)); + return sizeof (guardian_t); +} + + +static int +guardian_print (SCM g, SCM port, scm_print_state *pstate) +{ + scm_puts ("#", port); + + return 1; +} + + +/* This is the Scheme entry point for each guardian: If arg is an object, it's + * added to the guardian's live list. If arg is unbound, the next available + * zombified object (or #f if none) is returned. + */ +static SCM +guardian_apply (SCM guardian, SCM arg) { if (!SCM_UNBNDP (arg)) { - scm_guard (cclo, arg); + scm_guard (guardian, arg); return SCM_UNSPECIFIED; } else - return scm_get_one_zombie (cclo); + return scm_get_one_zombie (guardian); } + void scm_guard (SCM guardian, SCM obj) { - SCM g = CCLO_G (guardian); - - if (SCM_NIMP (obj)) + if (!SCM_IMP (obj)) { SCM z; - + SCM_NEWCELL (z); /* This critical section barrier will be replaced by a mutex. */ SCM_DEFER_INTS; - TCONC_IN (GUARDIAN_LIVE (g), obj, z); + TCONC_IN (GUARDIAN_LIVE (guardian), obj, z); SCM_ALLOW_INTS; } } + SCM scm_get_one_zombie (SCM guardian) { - SCM g = CCLO_G (guardian); SCM res = SCM_BOOL_F; /* This critical section barrier will be replaced by a mutex. */ SCM_DEFER_INTS; - if (!TCONC_EMPTYP (GUARDIAN_ZOMBIES (g))) - TCONC_OUT (GUARDIAN_ZOMBIES (g), res); + if (!TCONC_EMPTYP (GUARDIAN_ZOMBIES (guardian))) + TCONC_OUT (GUARDIAN_ZOMBIES (guardian), res); SCM_ALLOW_INTS; return res; } + SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 0, 0, (), "Create a new guardian.\n" @@ -181,8 +218,7 @@ SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 0, 0, "and Implementation, June 1993.") #define FUNC_NAME s_scm_make_guardian { - SCM cclo = scm_makcclo (guard1, 2L); - guardian_t *g = SCM_MUST_MALLOC_TYPE(guardian_t); + guardian_t *g = SCM_MUST_MALLOC_TYPE (guardian_t); SCM z1 = scm_cons (SCM_BOOL_F, SCM_EOL); SCM z2 = scm_cons (SCM_BOOL_F, SCM_EOL); SCM z; @@ -191,23 +227,16 @@ SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 0, 0, g->live.head = g->live.tail = z1; g->zombies.head = g->zombies.tail = z2; - SCM_NEWSMOB (z, scm_tc16_guardian, g); + SCM_NEWSMOB (z, tc16_guardian, g); - CCLO_G (cclo) = z; - - return cclo; + return z; } #undef FUNC_NAME -/* during the gc mark phase, live guardians are linked into a list - here. */ -static guardian_t *first_live_guardian = NULL; -static guardian_t **current_link_field = NULL; -/* called before gc mark phase begins to initialise the live guardian - list. */ +/* called before gc mark phase begins to initialise the live guardian list. */ static void * -scm_guardian_gc_init (void *dummy1, void *dummy2, void *dummy3) +guardian_gc_init (void *dummy1, void *dummy2, void *dummy3) { current_link_field = &first_live_guardian; first_live_guardian = NULL; @@ -215,25 +244,12 @@ scm_guardian_gc_init (void *dummy1, void *dummy2, void *dummy3) return 0; } -/* mark a guardian by adding it to the live guardian list. */ -static SCM -g_mark (SCM ptr) -{ - *current_link_field = GUARDIAN (ptr); - current_link_field = &GUARDIAN_NEXT (ptr); - GUARDIAN_NEXT (ptr) = NULL; - - /* the objects protected by the guardian are not marked here: that - would prevent them from ever getting collected. instead marking - is done at the end of the mark phase by scm_guardian_zombify. */ - return SCM_BOOL_F; -} /* this is called by the garbage collector between the mark and sweep phases. for each marked guardian, it moves any unmarked object in its live list (tconc) to its zombie list (tconc). */ static void * -scm_guardian_zombify (void *dummy1, void *dummy2, void *dummy3) +guardian_zombify (void *dummy1, void *dummy2, void *dummy3) { guardian_t *first_guardian; guardian_t **link_field = &first_live_guardian; @@ -282,7 +298,7 @@ scm_guardian_zombify (void *dummy1, void *dummy2, void *dummy3) /* Mark the cells of the live list (yes, the cells in the list, even though we don't care about objects pointed to by the list cars, since we know they are already marked). */ - for (pair = g->live.head; SCM_NIMP (pair); pair = SCM_GCCDR (pair)) + for (pair = g->live.head; !SCM_NULLP (pair); pair = SCM_CDR (pair)) SCM_SETGCMARK (pair); } @@ -294,45 +310,33 @@ scm_guardian_zombify (void *dummy1, void *dummy2, void *dummy3) guardian procedure to return an object which is referenced, so not collectable? The paper doesn't give this impression. - + cmm: the paper does explicitly say that an object that is guarded more than once should be returned more than once. I believe this covers the above scenario. */ - + /* Preserve the zombies in their undead state, by marking to prevent collection. Note that this may uncover zombified guardians -- if so, they'll be processed in the next loop. */ - - for (g = first_guardian; g && (!*link_field || g != *link_field); g = g->next) + for (g = first_guardian; g != *link_field; g = g->next) scm_gc_mark (g->zombies.head); - } while (current_link_field != link_field); return 0; } -/* not generally used, since guardian smob is wrapped in a closure. - maybe useful for debugging. */ -static int -g_print (SCM exp, SCM port, scm_print_state *pstate) -{ - char buf[256]; - sprintf (buf, "#", - scm_ilength (SCM_CDR (GUARDIAN_LIVE (exp).head)), - scm_ilength (SCM_CDR (GUARDIAN_ZOMBIES (exp).head))); - scm_puts (buf, port); - - return 1; -} void scm_init_guardian() { - scm_tc16_guardian = scm_make_smob_type_mfpe ("guardian", sizeof (guardian_t), - g_mark, NULL, g_print, NULL); - guard1 = scm_make_subr_opt ("guardian", scm_tc7_subr_2o, guard, 0); - scm_c_hook_add (&scm_before_mark_c_hook, scm_guardian_gc_init, 0, 0); - scm_c_hook_add (&scm_before_sweep_c_hook, scm_guardian_zombify, 0, 0); + tc16_guardian = scm_make_smob_type ("guardian", 0); + scm_set_smob_mark (tc16_guardian, guardian_mark); + scm_set_smob_free (tc16_guardian, guardian_free); + scm_set_smob_print (tc16_guardian, guardian_print); + scm_set_smob_apply (tc16_guardian, guardian_apply, 0, 1, 0); + + scm_c_hook_add (&scm_before_mark_c_hook, guardian_gc_init, 0, 0); + scm_c_hook_add (&scm_before_sweep_c_hook, guardian_zombify, 0, 0); #ifndef SCM_MAGIC_SNARFER #include "libguile/guardians.x" From e34f941a3ae0ae86d7fd6a78fe6087a3d9d7ebf1 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 5 Dec 2000 14:07:03 +0000 Subject: [PATCH 0397/2047] * Use scm_tc3_* codes instead of hardcoded values. --- libguile/ChangeLog | 6 ++++++ libguile/print.c | 31 +++++++++++++++++++------------ 2 files changed, 25 insertions(+), 12 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b572145ce..be1ab2a7a 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2000-12-05 Dirk Herrmann + + * print.c (scm_iprin1): Use scm_tc3_* codes instead of hardcoded + values. Added comment about tc3 codes that may appear in + immediates. Got rid of one goto command. + 2000-12-05 Dirk Herrmann * dynl.c (sysdep_dynl_link): Improved error reporting. diff --git a/libguile/print.c b/libguile/print.c index ecdc40d27..6ec1f11d7 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -312,16 +312,24 @@ scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) taloop: switch (SCM_ITAG3 (exp)) { - case 2: - case 6: + case scm_tc3_closure: + case scm_tc3_tc7_1: + case scm_tc3_tc7_2: + /* These tc3 tags should never occur in an immediate value. They are + * only used in cell types of non-immediates, i. e. the value returned + * by SCM_CELL_TYPE (exp) can use these tags. + */ + scm_ipruk ("immediate", exp, port); + break; + case scm_tc3_int_1: + case scm_tc3_int_2: scm_intprint (SCM_INUM (exp), 10, port); break; - case 4: + case scm_tc3_imm24: if (SCM_CHARP (exp)) { - register long i; + long i = SCM_CHAR (exp); - i = SCM_CHAR (exp); if (SCM_WRITINGP (pstate)) { scm_puts ("#\\", port); @@ -350,18 +358,17 @@ taloop: scm_intprint (SCM_IDIST (exp), 10, port); } else - goto idef; + { + /* unknown immediate value */ + scm_ipruk ("immediate", exp, port); + } break; - case 1: + case scm_tc3_cons_gloc: /* gloc */ scm_puts ("#@", port); exp = SCM_GLOC_SYM (exp); goto taloop; - default: - idef: - scm_ipruk ("immediate", exp, port); - break; - case 0: + case scm_tc3_cons: switch (SCM_TYP7 (exp)) { case scm_tcs_cons_gloc: From fd3363659b0000cef1cbce5be7c4ac8e914238c3 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 6 Dec 2000 15:16:59 +0000 Subject: [PATCH 0398/2047] * eval.c: remove commented code, remove #ifdef CCLO conditionals * remove uses of older GC marking and cell accessing macros --- NEWS | 8 ++++- RELEASE | 3 +- libguile/ChangeLog | 24 +++++++++++++ libguile/async.c | 2 +- libguile/eval.c | 84 ---------------------------------------------- libguile/gc.h | 14 +++----- libguile/gdbint.c | 18 +++++----- libguile/gh_data.c | 2 +- libguile/procs.c | 2 +- libguile/tags.h | 1 - libguile/weaks.c | 2 +- 11 files changed, 51 insertions(+), 109 deletions(-) diff --git a/NEWS b/NEWS index 946ea9999..cc847018d 100644 --- a/NEWS +++ b/NEWS @@ -294,7 +294,8 @@ SCM_VALIDATE_ROSTRING, SCM_VALIDATE_ROSTRING_COPY, SCM_VALIDATE_NULLORROSTRING_COPY, SCM_ROLENGTH, SCM_LENGTH, SCM_HUGE_LENGTH, SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR, SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING, SCM_ROCHARS, -SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS, SCM_LENGTH_MAX +SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS, SCM_LENGTH_MAX, SCM_GC8MARKP, +SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of SCM_OUTOFRANGE. Use scm_memory_error instead of SCM_NALLOC. @@ -313,6 +314,11 @@ Use SCM_STRING_UCHARS instead of SCM_ROUCHARS. Use a type specific setter macro instead of SCM_SETLENGTH. Use a type specific setter macro instead of SCM_SETCHARS. Use a type specific length macro instead of SCM_LENGTH_MAX. +Use SCM_GCMARKP instead of SCM_GC8MARKP. +Use SCM_SETGCMARK instead of SCM_SETGC8MARK. +Use SCM_CLRGCMARK instead of SCM_CLRGC8MARK. +Use SCM_TYP16 instead of SCM_GCTYP16. +Use SCM_CDR instead of SCM_GCCDR. ** Removed function: scm_struct_init diff --git a/RELEASE b/RELEASE index ca5ae7ffb..1e2caf3b3 100644 --- a/RELEASE +++ b/RELEASE @@ -50,7 +50,8 @@ In release 1.6: SCM_VALIDATE_ROSTRING_COPY, SCM_VALIDATE_NULLORROSTRING_COPY, SCM_ROLENGTH, SCM_LENGTH, SCM_HUGE_LENGTH, SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR, SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING, - SCM_ROCHARS, SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS, SCM_LENGTH_MAX + SCM_ROCHARS, SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS, SCM_LENGTH_MAX, + SCM_GC8MARKP, SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR - remove scm_vector_set_length_x - remove function scm_call_catching_errors (replaced by catch functions from throw.[ch]) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index be1ab2a7a..2733dc024 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,27 @@ +2000-12-06 Dirk Herrmann + + * async.c (SCM_ASYNCP): Use SCM_TYP16 instead of SCM_GCTYP16. + + * eval.c (scm_m_vref, scm_m_vset, scm_m_define, SCM_CEVAL, + SCM_APPLY, scm_copy_tree): Remove commented code. + + (SCM_CEVAL, SCM_APPLY): Remove #ifdef CCLO conditionals. Without + CCLO being defined, guile would not compile at all anyway. + + * gc.h (SCM_GC8MARKP, SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, + SCM_GCCDR): Deprecated. + + * gdbint.c (unmark_port, remark_port, gdb_read), procs.c + (scm_mark_subr_table): Use SCM_(SET|CLR)?GCMARK(P)? instead of + SCM_(SET|CLR)?GC8MARK(P)?. + + * gh_data.c (gh_scm2char): Remove bogus ';'. + + * tags.h: Removed comment about GCTYP16 macro. + + * weaks.c (scm_mark_weak_vector_spines): Use SCM_CDR instead of + SCM_GCCDR. + 2000-12-05 Dirk Herrmann * print.c (scm_iprin1): Use scm_tc3_* codes instead of hardcoded diff --git a/libguile/async.c b/libguile/async.c index 79baedda9..dc4ed3156 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -116,7 +116,7 @@ static long tc16_async; /* cmm: this has SCM_ prefix because SCM_MAKE_VALIDATE expects it. this is ugly. */ -#define SCM_ASYNCP(X) (SCM_NIMP(X) && (tc16_async == SCM_GCTYP16 (X))) +#define SCM_ASYNCP(X) (SCM_NIMP(X) && (tc16_async == SCM_TYP16 (X))) #define VALIDATE_ASYNC(pos,a) SCM_MAKE_VALIDATE(pos, a, ASYNCP) diff --git a/libguile/eval.c b/libguile/eval.c index 3c44fba1a..7ba7e5a06 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -547,40 +547,6 @@ scm_m_set_x (SCM xorig, SCM env) } -#if 0 - -SCM -scm_m_vref (SCM xorig, SCM env) -{ - SCM x = SCM_CDR (xorig); - SCM_ASSYNT (1 == scm_ilength (x), xorig, scm_s_expression, s_vref); - if (SCM_NIMP(x) && UDSCM_VARIABLEP (SCM_CAR (x))) - { - /* scm_everr (SCM_UNDEFINED, env,..., "global variable reference") */ - scm_misc_error (NULL, - "Bad variable: ~S", - scm_listify (SCM_CAR (SCM_CDR (x)), SCM_UNDEFINED)); - } - SCM_ASSYNT (SCM_NIMP(x) && DEFSCM_VARIABLEP (SCM_CAR (x)), - xorig, scm_s_variable, s_vref); - return scm_cons (IM_VREF, x); -} - - - -SCM -scm_m_vset (SCM xorig, SCM env) -{ - SCM x = SCM_CDR (xorig); - SCM_ASSYNT (3 == scm_ilength (x), xorig, scm_s_expression, s_vset); - SCM_ASSYNT ((DEFSCM_VARIABLEP (SCM_CAR (x)) - || UDSCM_VARIABLEP (SCM_CAR (x))), - xorig, scm_s_variable, s_vset); - return scm_cons (IM_VSET, x); -} -#endif - - SCM_SYNTAX(s_and, "and", scm_makmmacro, scm_m_and); SCM_GLOBAL_SYMBOL(scm_sym_and, s_and); @@ -865,7 +831,6 @@ scm_m_define (SCM x, SCM env) { SCM proc, arg1 = x; x = SCM_CDR (x); - /* SCM_ASSYNT(SCM_NULLP(env), x, "bad placement", s_define);*/ SCM_ASSYNT (scm_ilength (x) >= 2, arg1, scm_s_expression, s_define); proc = SCM_CAR (x); x = SCM_CDR (x); @@ -2168,19 +2133,6 @@ dispatch: SCM_ASRTGO (SCM_ISYMP (proc), badfun); switch SCM_ISYMNUM (proc) { -#if 0 - case (SCM_ISYMNUM (IM_VREF)): - { - SCM var; - var = SCM_CAR (SCM_CDR (x)); - RETURN (SCM_CDR(var)); - } - case (SCM_ISYMNUM (IM_VSET)): - SCM_CDR (SCM_CAR ( SCM_CDR (x))) = EVALCAR( SCM_CDR ( SCM_CDR (x)), env); - SCM_CAR (SCM_CAR ( SCM_CDR (x))) = scm_tc16_variable; - RETURN (SCM_UNSPECIFIED) -#endif - case (SCM_ISYMNUM (SCM_IM_APPLY)): proc = SCM_CDR (x); proc = EVALCAR (proc, env); @@ -2476,9 +2428,7 @@ dispatch: case scm_tc7_substring: case scm_tc7_smob: case scm_tcs_closures: -#ifdef CCLO case scm_tc7_cclo: -#endif case scm_tc7_pws: case scm_tcs_subrs: RETURN (x); @@ -2557,16 +2507,6 @@ dispatch: #ifdef DEVAL if (!SCM_CLOSUREP (SCM_CDR (proc))) { - -#if 0 /* Top-level defines doesn't very often occur in backtraces */ - if (scm_m_define == SCM_SUBRF (SCM_CDR (proc)) && SCM_TOP_LEVEL (env)) - /* Prevent memoizing result of define macro */ - { - debug.info->e.exp = scm_cons (SCM_CAR (x), SCM_CDR (x)); - scm_set_source_properties_x (debug.info->e.exp, - scm_source_properties (x)); - } -#endif SCM_DEFER_INTS; SCM_SETCAR (x, SCM_CAR (t.arg1)); SCM_SETCDR (x, SCM_CDR (t.arg1)); @@ -2641,7 +2581,6 @@ evapply: if (!SCM_SMOB_DESCRIPTOR (proc).apply) goto badfun; RETURN (scm_smob_apply_0 (proc)); -#ifdef CCLO case scm_tc7_cclo: t.arg1 = proc; proc = SCM_CCLO_SUBR (proc); @@ -2650,7 +2589,6 @@ evapply: debug.info->a.args = scm_cons (t.arg1, SCM_EOL); #endif goto evap1; -#endif case scm_tc7_pws: proc = SCM_PROCEDURE (proc); #ifdef DEVAL @@ -2792,7 +2730,6 @@ evapply: if (!SCM_SMOB_DESCRIPTOR (proc).apply) goto badfun; RETURN (scm_smob_apply_1 (proc, t.arg1)); -#ifdef CCLO case scm_tc7_cclo: arg2 = t.arg1; t.arg1 = proc; @@ -2802,7 +2739,6 @@ evapply: debug.info->a.proc = proc; #endif goto evap2; -#endif case scm_tc7_pws: proc = SCM_PROCEDURE (proc); #ifdef DEVAL @@ -2889,9 +2825,7 @@ evapply: x = SCM_CDR (x); if (SCM_NULLP (x)) { ENTER_APPLY; -#ifdef CCLO evap2: -#endif switch (SCM_TYP7 (proc)) { /* have two arguments */ case scm_tc7_subr_2: @@ -2912,7 +2846,6 @@ evapply: if (!SCM_SMOB_DESCRIPTOR (proc).apply) goto badfun; RETURN (scm_smob_apply_2 (proc, t.arg1, arg2)); -#ifdef CCLO cclon: case scm_tc7_cclo: #ifdef DEVAL @@ -2927,13 +2860,6 @@ evapply: env, proc))), SCM_EOL)); -#endif - /* case scm_tc7_cclo: - x = scm_cons(arg2, scm_eval_args(x, env)); - arg2 = t.arg1; - t.arg1 = proc; - proc = SCM_CCLO_SUBR(proc); - goto evap3; */ #endif case scm_tcs_cons_gloc: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) @@ -3060,10 +2986,8 @@ evapply: goto badfun; RETURN (scm_smob_apply_3 (proc, t.arg1, arg2, SCM_CDDR (debug.info->a.args))); -#ifdef CCLO case scm_tc7_cclo: goto cclon; -#endif case scm_tc7_pws: proc = SCM_PROCEDURE (proc); debug.info->a.proc = proc; @@ -3124,10 +3048,8 @@ evapply: goto badfun; RETURN (scm_smob_apply_3 (proc, t.arg1, arg2, scm_eval_args (x, env, proc))); -#ifdef CCLO case scm_tc7_cclo: goto cclon; -#endif case scm_tc7_pws: proc = SCM_PROCEDURE (proc); if (!SCM_CLOSUREP (proc)) @@ -3334,7 +3256,6 @@ SCM_APPLY (SCM proc, SCM arg1, SCM args) } else { - /* SCM_ASRTGO(SCM_CONSP(args), wrongnumargs); */ args = scm_nconc2last (args); #ifdef DEVAL debug.vect[0].a.args = scm_cons (arg1, args); @@ -3359,9 +3280,7 @@ SCM_APPLY (SCM proc, SCM arg1, SCM args) entap: ENTER_APPLY; #endif -#ifdef CCLO tail: -#endif switch (SCM_TYP7 (proc)) { case scm_tc7_subr_2o: @@ -3500,7 +3419,6 @@ tail: RETURN (scm_smob_apply_2 (proc, arg1, SCM_CAR (args))) else RETURN (scm_smob_apply_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args))); -#ifdef CCLO case scm_tc7_cclo: #ifdef DEVAL args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args); @@ -3514,7 +3432,6 @@ tail: proc = SCM_CCLO_SUBR (proc); #endif goto tail; -#endif case scm_tc7_pws: proc = SCM_PROCEDURE (proc); #ifdef DEVAL @@ -3838,7 +3755,6 @@ SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0, } if (SCM_NCONSP (obj)) return obj; -/* return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */ ans = tl = scm_cons_source (obj, scm_copy_tree (SCM_CAR (obj)), SCM_UNSPECIFIED); diff --git a/libguile/gc.h b/libguile/gc.h index 2db7fe755..9397e562d 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -162,15 +162,6 @@ typedef unsigned long scm_c_bvec_limb_t; #define SCM_SETGCMARK(x) SCM_GC_CELL_SET_BIT (x) #define SCM_CLRGCMARK(x) SCM_GC_CELL_CLR_BIT (x) -/* compatibility stuff: */ - -#define SCM_GC8MARKP(x) SCM_GCMARKP (x) -#define SCM_SETGC8MARK(x) SCM_SETGCMARK (x) -#define SCM_CLRGC8MARK(x) SCM_CLRGCMARK (x) - -#define SCM_GCTYP16(x) SCM_TYP16 (x) -#define SCM_GCCDR(x) SCM_CDR (x) - /* Low level cell data accessing macros: */ @@ -375,6 +366,11 @@ extern void scm_init_gc (void); #define SCM_FREEP(x) (SCM_FREE_CELL_P (x)) #define SCM_NFREEP(x) (!SCM_FREE_CELL_P (x)) +#define SCM_GC8MARKP(x) SCM_GCMARKP (x) +#define SCM_SETGC8MARK(x) SCM_SETGCMARK (x) +#define SCM_CLRGC8MARK(x) SCM_CLRGCMARK (x) +#define SCM_GCTYP16(x) SCM_TYP16 (x) +#define SCM_GCCDR(x) SCM_CDR (x) #endif /* SCM_DEBUG_DEPRECATED == 0 */ diff --git a/libguile/gdbint.c b/libguile/gdbint.c index b873325ed..2f6a036aa 100644 --- a/libguile/gdbint.c +++ b/libguile/gdbint.c @@ -144,14 +144,14 @@ static void unmark_port (SCM port) { SCM stream, string; - port_mark_p = SCM_GC8MARKP (port); - SCM_CLRGC8MARK (port); + port_mark_p = SCM_GCMARKP (port); + SCM_CLRGCMARK (port); stream = SCM_PACK (SCM_STREAM (port)); stream_mark_p = SCM_GCMARKP (stream); SCM_CLRGCMARK (stream); string = SCM_CDR (stream); - string_mark_p = SCM_GC8MARKP (string); - SCM_CLRGC8MARK (string); + string_mark_p = SCM_GCMARKP (string); + SCM_CLRGCMARK (string); } @@ -160,9 +160,9 @@ remark_port (SCM port) { SCM stream = SCM_PACK (SCM_STREAM (port)); SCM string = SCM_CDR (stream); - if (string_mark_p) SCM_SETGC8MARK (string); + if (string_mark_p) SCM_SETGCMARK (string); if (stream_mark_p) SCM_SETGCMARK (stream); - if (port_mark_p) SCM_SETGC8MARK (port); + if (port_mark_p) SCM_SETGCMARK (port); } @@ -213,8 +213,8 @@ gdb_read (char *str) scm_truncate_file (gdb_input_port, SCM_UNDEFINED); scm_seek (gdb_input_port, SCM_INUM0, SCM_MAKINUM (SEEK_SET)); /* Read one object */ - tok_buf_mark_p = SCM_GC8MARKP (tok_buf); - SCM_CLRGC8MARK (tok_buf); + tok_buf_mark_p = SCM_GCMARKP (tok_buf); + SCM_CLRGCMARK (tok_buf); ans = scm_lreadr (&tok_buf, gdb_input_port, &ans); if (SCM_GC_P) { @@ -231,7 +231,7 @@ gdb_read (char *str) scm_permanent_object (ans); exit: if (tok_buf_mark_p) - SCM_SETGC8MARK (tok_buf); + SCM_SETGCMARK (tok_buf); remark_port (gdb_input_port); SCM_END_FOREIGN_BLOCK; return status; diff --git a/libguile/gh_data.c b/libguile/gh_data.c index 91403c363..a65f75efa 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -258,7 +258,7 @@ gh_scm2char (SCM obj) SCM_VALIDATE_CHAR (SCM_ARG1, obj); return SCM_CHAR (obj); } -#undef FUNC_NAME; +#undef FUNC_NAME /* Convert a vector, weak vector, string, substring or uniform vector into an array of chars. If result array in arg 2 is NULL, malloc a diff --git a/libguile/procs.c b/libguile/procs.c index c36871954..787098bf2 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -138,7 +138,7 @@ scm_mark_subr_table () int i; for (i = 0; i < scm_subr_table_size; ++i) { - SCM_SETGC8MARK (scm_subr_table[i].name); + SCM_SETGCMARK (scm_subr_table[i].name); if (scm_subr_table[i].generic && *scm_subr_table[i].generic) scm_gc_mark (*scm_subr_table[i].generic); if (SCM_NIMP (scm_subr_table[i].properties)) diff --git a/libguile/tags.h b/libguile/tags.h index d07f2aaa1..76fe2fe51 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -249,7 +249,6 @@ typedef long scm_bits_t; * * TYP16 * TYP16S - * GCTYP16 * * TYP16S functions similarly wrt to TYP16 as TYP7S to TYP7, * but a different option bit is used (bit 2 for TYP7S, diff --git a/libguile/weaks.c b/libguile/weaks.c index e7f6cd89d..e6d47a376 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -243,7 +243,7 @@ scm_mark_weak_vector_spines (void *dummy1, void *dummy2, void *dummy3) { SCM_SETGCMARK (alist); SCM_SETGCMARK (SCM_CAR (alist)); - alist = SCM_GCCDR (alist); + alist = SCM_CDR (alist); } } } From a4bb4e6d09ed50324bb0587e3465f63d64623fff Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 6 Dec 2000 16:24:00 +0000 Subject: [PATCH 0399/2047] * Various minor cleanups. --- libguile/ChangeLog | 11 +++++++++++ libguile/gsubr.c | 21 +++++++++++---------- 2 files changed, 22 insertions(+), 10 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 2733dc024..a028b94de 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2000-12-06 Dirk Herrmann + + * gsubr.c: No need to include vector.h. + + (scm_gsubr_apply): Use SCM_GSUBR_MAX instead of hard-coded value. + Added FUNC_NAME wrapping. Improved (temporarily?) disabled + debugging code. Replaced SCM_IMP with SCM_NULLP. Eliminated call + to ASRTGO. + + (scm_init_gsubr): Eliminated outdated comment. + 2000-12-06 Dirk Herrmann * async.c (SCM_ASYNCP): Use SCM_TYP16 instead of SCM_GCTYP16. diff --git a/libguile/gsubr.c b/libguile/gsubr.c index cccbabc29..03e27b621 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -48,7 +48,6 @@ #include "libguile/_scm.h" #include "libguile/procprop.h" #include "libguile/root.h" -#include "libguile/vectors.h" #include "libguile/gsubr.h" @@ -132,21 +131,24 @@ scm_make_gsubr_with_generic (const char *name, SCM scm_gsubr_apply (SCM args) +#define FUNC_NAME "scm_gsubr_apply" { SCM self = SCM_CAR(args); SCM (*fcn)() = SCM_SUBRF(SCM_GSUBR_PROC(self)); - SCM v[10]; /* must agree with greatest supported arity */ + SCM v[SCM_GSUBR_MAX]; int typ = SCM_INUM(SCM_GSUBR_TYPE(self)); int i, n = SCM_GSUBR_REQ(typ) + SCM_GSUBR_OPT(typ) + SCM_GSUBR_REST(typ); #if 0 - SCM_ASSERT(n <= sizeof(v)/sizeof(SCM), - self, "internal programming error", FUNC_NAME); + if (n > SCM_GSUBR_MAX) + scm_misc_error (FUNC_NAME, + "Function ~S has illegal arity ~S.", + SCM_LIST2 (self, SCM_MAKINUM (n))); #endif args = SCM_CDR(args); for (i = 0; i < SCM_GSUBR_REQ(typ); i++) { #ifndef SCM_RECKLESS - if (SCM_IMP(args)) - wnargs: scm_wrong_num_args (SCM_SNAME(SCM_GSUBR_PROC(self))); + if (SCM_NULLP (args)) + scm_wrong_num_args (SCM_SNAME (SCM_GSUBR_PROC (self))); #endif v[i] = SCM_CAR(args); args = SCM_CDR(args); @@ -161,8 +163,8 @@ scm_gsubr_apply (SCM args) } if (SCM_GSUBR_REST(typ)) v[i] = args; - else - SCM_ASRTGO(SCM_NULLP(args), wnargs); + else if (!SCM_NULLP (args)) + scm_wrong_num_args (SCM_SNAME (SCM_GSUBR_PROC (self))); switch (n) { case 2: return (*fcn)(v[0], v[1]); case 3: return (*fcn)(v[0], v[1], v[2]); @@ -176,6 +178,7 @@ scm_gsubr_apply (SCM args) } return SCM_BOOL_F; /* Never reached. */ } +#undef FUNC_NAME #ifdef GSUBR_TEST @@ -203,8 +206,6 @@ gsubr_21l(SCM req1, SCM req2, SCM opt, SCM rst) void scm_init_gsubr() { - /* GJB:FIXME:MD: Use scm_make_subr_opt instead -- gsubr-apply should not be a - published primitive available at the Scheme level */ scm_f_gsubr_apply = scm_make_subr_opt("gsubr-apply", scm_tc7_lsubr, scm_gsubr_apply, 0); scm_sym_name = SCM_CAR (scm_sysintern ("name", SCM_UNDEFINED)); scm_permanent_object (scm_sym_name); From 78573619d0f574b39f656239da6cc7565e745ffd Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 6 Dec 2000 16:42:16 +0000 Subject: [PATCH 0400/2047] * No binding is created for %gc-thunk any more. --- libguile/ChangeLog | 4 ++++ libguile/gc.c | 3 +-- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index a028b94de..c0060424e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2000-12-06 Dirk Herrmann + + * gc.c (scm_init_gc): Don't create a binding for %gc-thunk. + 2000-12-06 Dirk Herrmann * gsubr.c: No need to include vector.h. diff --git a/libguile/gc.c b/libguile/gc.c index 3f24dc3ee..30fd43f15 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -2580,8 +2580,7 @@ scm_init_gc () #if (SCM_DEBUG_DEPRECATED == 0) scm_gc_vcell = scm_sysintern ("gc-thunk", SCM_BOOL_F); #endif /* SCM_DEBUG_DEPRECATED == 0 */ - /* Dirk:FIXME:: We don't really want a binding here. */ - after_gc_thunk = scm_make_gsubr ("%gc-thunk", 0, 0, 0, gc_async_thunk); + after_gc_thunk = scm_make_subr_opt ("%gc-thunk", scm_tc7_subr_0, gc_async_thunk, 0); gc_async = scm_system_async (after_gc_thunk); scm_c_hook_add (&scm_after_gc_c_hook, mark_gc_async, NULL, 0); From 73369d674458d975995bf37c2da155e8b74124ce Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 6 Dec 2000 17:11:46 +0000 Subject: [PATCH 0401/2047] * Fixed: gc_async must be protected from gc. --- libguile/ChangeLog | 5 +++++ libguile/gc.c | 1 + 2 files changed, 6 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index c0060424e..d1fbc14bd 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-12-06 Dirk Herrmann + + * gc.c (scm_init_gc): gc_async must be protected from gc. I + wonder why we never ran into problems up to now... + 2000-12-06 Dirk Herrmann * gc.c (scm_init_gc): Don't create a binding for %gc-thunk. diff --git a/libguile/gc.c b/libguile/gc.c index 30fd43f15..96011f14f 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -2582,6 +2582,7 @@ scm_init_gc () #endif /* SCM_DEBUG_DEPRECATED == 0 */ after_gc_thunk = scm_make_subr_opt ("%gc-thunk", scm_tc7_subr_0, gc_async_thunk, 0); gc_async = scm_system_async (after_gc_thunk); + scm_permanent_object (gc_async); scm_c_hook_add (&scm_after_gc_c_hook, mark_gc_async, NULL, 0); From 701513780dc1b4877286f1addbe207a25242f0dc Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Thu, 7 Dec 2000 00:39:51 +0000 Subject: [PATCH 0402/2047] Added some ignorable files. --- .cvsignore | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.cvsignore b/.cvsignore index 2491c28a2..074a0cc72 100644 --- a/.cvsignore +++ b/.cvsignore @@ -3,9 +3,13 @@ Makefile.in aclocal.m4 config.build-subdirs config.cache +config.guess +config.sub config.h.in config.log config.status configure guile-*.tar.gz libtool +ltconfig +ltmain.sh From 85270b4033139a2564b912079d308028a1801b29 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Thu, 7 Dec 2000 00:40:31 +0000 Subject: [PATCH 0403/2047] .cvsignore --- oop/.cvsignore | 2 ++ oop/goops/.cvsignore | 2 ++ 2 files changed, 4 insertions(+) create mode 100644 oop/.cvsignore create mode 100644 oop/goops/.cvsignore diff --git a/oop/.cvsignore b/oop/.cvsignore new file mode 100644 index 000000000..282522db0 --- /dev/null +++ b/oop/.cvsignore @@ -0,0 +1,2 @@ +Makefile +Makefile.in diff --git a/oop/goops/.cvsignore b/oop/goops/.cvsignore new file mode 100644 index 000000000..282522db0 --- /dev/null +++ b/oop/goops/.cvsignore @@ -0,0 +1,2 @@ +Makefile +Makefile.in From cb1c46c57e1ed8e4ce34866c59509cf419d1f653 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Thu, 7 Dec 2000 00:55:12 +0000 Subject: [PATCH 0404/2047] Improved smob calls. --- libguile/ChangeLog | 22 +++ libguile/eval.c | 24 +-- libguile/smob.c | 415 ++++++++++++++++++++++++++++----------------- libguile/smob.h | 6 +- 4 files changed, 303 insertions(+), 164 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d1fbc14bd..f24abe03b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,25 @@ +2000-12-06 Keisuke Nishida + + * smob.h (scm_smob_descriptor): New fields `apply_0', `apply_1', + `apply_2', and `apply_3'. + * smob.c (scm_make_smob_type): Init new fields. + (SCM_SMOB_APPLY0, SCM_SMOB_APPLY1, SCM_SMOB_APPLY2, SCM_SMOB_APPLY3): + New macros. + (scm_smob_apply_0_000, scm_smob_apply_0_010, scm_smob_apply_0_020, + scm_smob_apply_0_030, scm_smob_apply_0_001, scm_smob_apply_0_011, + scm_smob_apply_0_021, scm_smob_apply_0_error, + scm_smob_apply_1_010, scm_smob_apply_1_020, scm_smob_apply_1_030, + scm_smob_apply_1_001, scm_smob_apply_1_011, scm_smob_apply_1_021, + scm_smob_apply_1_error, + scm_smob_apply_2_020, scm_smob_apply_2_030, scm_smob_apply_2_001, + scm_smob_apply_2_011, scm_smob_apply_2_021, scm_smob_apply_2_error, + scm_smob_apply_3_030, scm_smob_apply_3_001, scm_smob_apply_3_011, + scm_smob_apply_3_021, scm_smob_apply_3_error): New functions. + (scm_set_smob_apply): Set new fields to the above functions. + (scm_smob_apply_0, scm_smob_apply_1, scm_smob_apply_2, + scm_smob_apply_3): Removed. + * eval.c (SCM_CEVAL, SCM_APPLY): Rewrote smob calls. + 2000-12-06 Dirk Herrmann * gc.c (scm_init_gc): gc_async must be protected from gc. I diff --git a/libguile/eval.c b/libguile/eval.c index 7ba7e5a06..dc1f0905a 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2580,7 +2580,7 @@ evapply: case scm_tc7_smob: if (!SCM_SMOB_DESCRIPTOR (proc).apply) goto badfun; - RETURN (scm_smob_apply_0 (proc)); + RETURN (SCM_SMOB_DESCRIPTOR (proc).apply_0 (proc)); case scm_tc7_cclo: t.arg1 = proc; proc = SCM_CCLO_SUBR (proc); @@ -2729,7 +2729,7 @@ evapply: case scm_tc7_smob: if (!SCM_SMOB_DESCRIPTOR (proc).apply) goto badfun; - RETURN (scm_smob_apply_1 (proc, t.arg1)); + RETURN (SCM_SMOB_DESCRIPTOR (proc).apply_1 (proc, t.arg1)); case scm_tc7_cclo: arg2 = t.arg1; t.arg1 = proc; @@ -2845,7 +2845,7 @@ evapply: case scm_tc7_smob: if (!SCM_SMOB_DESCRIPTOR (proc).apply) goto badfun; - RETURN (scm_smob_apply_2 (proc, t.arg1, arg2)); + RETURN (SCM_SMOB_DESCRIPTOR (proc).apply_2 (proc, t.arg1, arg2)); cclon: case scm_tc7_cclo: #ifdef DEVAL @@ -2984,8 +2984,8 @@ evapply: case scm_tc7_smob: if (!SCM_SMOB_DESCRIPTOR (proc).apply) goto badfun; - RETURN (scm_smob_apply_3 (proc, t.arg1, arg2, - SCM_CDDR (debug.info->a.args))); + RETURN (SCM_SMOB_DESCRIPTOR (proc).apply_3 + (proc, t.arg1, arg2, SCM_CDDR (debug.info->a.args))); case scm_tc7_cclo: goto cclon; case scm_tc7_pws: @@ -3046,8 +3046,8 @@ evapply: case scm_tc7_smob: if (!SCM_SMOB_DESCRIPTOR (proc).apply) goto badfun; - RETURN (scm_smob_apply_3 (proc, t.arg1, arg2, - scm_eval_args (x, env, proc))); + RETURN (SCM_SMOB_DESCRIPTOR (proc).apply_3 + (proc, t.arg1, arg2, scm_eval_args (x, env, proc))); case scm_tc7_cclo: goto cclon; case scm_tc7_pws: @@ -3412,13 +3412,15 @@ tail: if (!SCM_SMOB_DESCRIPTOR (proc).apply) goto badproc; if (SCM_UNBNDP (arg1)) - RETURN (scm_smob_apply_0 (proc)) + RETURN (SCM_SMOB_DESCRIPTOR (proc).apply_0 (proc)) else if (SCM_NULLP (args)) - RETURN (scm_smob_apply_1 (proc, arg1)) + RETURN (SCM_SMOB_DESCRIPTOR (proc).apply_1 (proc, arg1)) else if (SCM_NULLP (SCM_CDR (args))) - RETURN (scm_smob_apply_2 (proc, arg1, SCM_CAR (args))) + RETURN (SCM_SMOB_DESCRIPTOR (proc).apply_2 + (proc, arg1, SCM_CAR (args))) else - RETURN (scm_smob_apply_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args))); + RETURN (SCM_SMOB_DESCRIPTOR (proc).apply_3 + (proc, arg1, SCM_CAR (args), SCM_CDR (args))); case scm_tc7_cclo: #ifdef DEVAL args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args); diff --git a/libguile/smob.c b/libguile/smob.c index 1be908356..9475542fd 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -125,169 +125,174 @@ scm_smob_print (SCM exp, SCM port, scm_print_state *pstate) /* {Apply} */ -/* - * A possible future optimization: - * - * Let's call each of the forms of call below a "trampoline". - * - * We could make a function out of each trampoline and store four - * pointers to trampolines in the descriptor, one corresponding to - * each arity of call (apply_0, apply_1 etc.) - * - * Which trampoline to store in which field is chosen in scm_set_smob_apply. - */ +#define SCM_SMOB_APPLY0(SMOB) \ + SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB) +#define SCM_SMOB_APPLY1(SMOB,A1) \ + SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1) +#define SCM_SMOB_APPLY2(SMOB,A1,A2) \ + SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2) +#define SCM_SMOB_APPLY3(SMOB,A1,A2,A3) \ + SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2, A3) -SCM -scm_smob_apply_0 (SCM smob) +static SCM +scm_smob_apply_0_000 (SCM smob) { - int type = SCM_SMOB_DESCRIPTOR (smob).gsubr_type; - switch (type) - { - case SCM_GSUBR_MAKTYPE (0, 0, 0): - return SCM_SMOB_DESCRIPTOR (smob).apply (); - case SCM_GSUBR_MAKTYPE (0, 1, 0): - return SCM_SMOB_DESCRIPTOR (smob).apply (smob, SCM_UNDEFINED); - case SCM_GSUBR_MAKTYPE (0, 0, 1): - return SCM_SMOB_DESCRIPTOR (smob).apply (smob, SCM_EOL); - case SCM_GSUBR_MAKTYPE (0, 2, 0): - return SCM_SMOB_DESCRIPTOR (smob).apply (smob, - SCM_UNDEFINED, - SCM_UNDEFINED); - case SCM_GSUBR_MAKTYPE (0, 1, 1): - return SCM_SMOB_DESCRIPTOR (smob).apply (smob, - SCM_UNDEFINED, - SCM_EOL); - case SCM_GSUBR_MAKTYPE (0, 3, 0): - return SCM_SMOB_DESCRIPTOR (smob).apply (smob, - SCM_UNDEFINED, - SCM_UNDEFINED, - SCM_UNDEFINED); - case SCM_GSUBR_MAKTYPE (0, 2, 1): - return SCM_SMOB_DESCRIPTOR (smob).apply (smob, - SCM_UNDEFINED, - SCM_UNDEFINED, - SCM_EOL); - default: - if (SCM_GSUBR_REQ (type) > 0) - scm_wrong_num_args (smob); - scm_misc_error ("scm_smob_apply_0", - "Unsupported smob application: ~S", - SCM_LIST1 (smob)); - } + return SCM_SMOB_APPLY0 (smob); } -SCM -scm_smob_apply_1 (SCM smob, SCM a1) +static SCM +scm_smob_apply_0_010 (SCM smob) { - int type = SCM_SMOB_DESCRIPTOR (smob).gsubr_type; - switch (type) - { - case SCM_GSUBR_MAKTYPE (0, 0, 0): - scm_wrong_num_args (smob); - case SCM_GSUBR_MAKTYPE (1, 0, 0): - case SCM_GSUBR_MAKTYPE (0, 1, 0): - return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1); - case SCM_GSUBR_MAKTYPE (0, 0, 1): - return SCM_SMOB_DESCRIPTOR (smob).apply (smob, SCM_LIST1 (a1)); - case SCM_GSUBR_MAKTYPE (1, 1, 0): - case SCM_GSUBR_MAKTYPE (0, 2, 0): - return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, SCM_UNDEFINED); - case SCM_GSUBR_MAKTYPE (1, 0, 1): - case SCM_GSUBR_MAKTYPE (0, 1, 1): - return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, SCM_EOL); - case SCM_GSUBR_MAKTYPE (1, 2, 0): - case SCM_GSUBR_MAKTYPE (0, 3, 0): - return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, - SCM_UNDEFINED, - SCM_UNDEFINED); - case SCM_GSUBR_MAKTYPE (1, 1, 1): - case SCM_GSUBR_MAKTYPE (0, 2, 1): - return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, - SCM_UNDEFINED, - SCM_EOL); - default: - if (SCM_GSUBR_REQ (type) > 1) - scm_wrong_num_args (smob); - scm_misc_error ("scm_smob_apply_1", - "Unsupported smob application: ~S", - SCM_LIST1 (smob)); - } + return SCM_SMOB_APPLY1 (smob, SCM_UNDEFINED); } -SCM -scm_smob_apply_2 (SCM smob, SCM a1, SCM a2) +static SCM +scm_smob_apply_0_020 (SCM smob) { - int type = SCM_SMOB_DESCRIPTOR (smob).gsubr_type; - switch (type) - { - case SCM_GSUBR_MAKTYPE (0, 0, 0): - case SCM_GSUBR_MAKTYPE (1, 0, 0): - case SCM_GSUBR_MAKTYPE (0, 1, 0): - scm_wrong_num_args (smob); - case SCM_GSUBR_MAKTYPE (0, 0, 1): - return SCM_SMOB_DESCRIPTOR (smob).apply (smob, SCM_LIST2 (a1, a2)); - case SCM_GSUBR_MAKTYPE (2, 0, 0): - case SCM_GSUBR_MAKTYPE (1, 1, 0): - case SCM_GSUBR_MAKTYPE (0, 2, 0): - return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, a2); - case SCM_GSUBR_MAKTYPE (1, 0, 1): - case SCM_GSUBR_MAKTYPE (0, 1, 1): - return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, SCM_LIST1 (a2)); - case SCM_GSUBR_MAKTYPE (2, 1, 0): - case SCM_GSUBR_MAKTYPE (1, 2, 0): - case SCM_GSUBR_MAKTYPE (0, 3, 0): - return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, a2, SCM_UNDEFINED); - case SCM_GSUBR_MAKTYPE (2, 0, 1): - case SCM_GSUBR_MAKTYPE (1, 1, 1): - case SCM_GSUBR_MAKTYPE (0, 2, 1): - return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, a2, SCM_EOL); - default: - if (SCM_GSUBR_REQ (type) > 2) - scm_wrong_num_args (smob); - scm_misc_error ("scm_smob_apply_2", - "Unsupported smob application: ~S", - SCM_LIST1 (smob)); - } + return SCM_SMOB_APPLY2 (smob, SCM_UNDEFINED, SCM_UNDEFINED); } -SCM -scm_smob_apply_3 (SCM smob, SCM a1, SCM a2, SCM rest) +static SCM +scm_smob_apply_0_030 (SCM smob) { - int type = SCM_SMOB_DESCRIPTOR (smob).gsubr_type; - switch (type) - { - case SCM_GSUBR_MAKTYPE (0, 0, 0): - case SCM_GSUBR_MAKTYPE (1, 0, 0): - case SCM_GSUBR_MAKTYPE (0, 1, 0): - case SCM_GSUBR_MAKTYPE (2, 0, 0): - case SCM_GSUBR_MAKTYPE (1, 1, 0): - case SCM_GSUBR_MAKTYPE (0, 2, 0): - scm_wrong_num_args (smob); - case SCM_GSUBR_MAKTYPE (0, 0, 1): - return SCM_SMOB_DESCRIPTOR (smob).apply (smob, scm_cons (a1, scm_cons (a2, rest))); - case SCM_GSUBR_MAKTYPE (1, 0, 1): - case SCM_GSUBR_MAKTYPE (0, 1, 1): - return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, scm_cons (a2, rest)); - case SCM_GSUBR_MAKTYPE (3, 0, 0): - case SCM_GSUBR_MAKTYPE (2, 1, 0): - case SCM_GSUBR_MAKTYPE (1, 2, 0): - case SCM_GSUBR_MAKTYPE (0, 3, 0): - if (!SCM_NULLP (SCM_CDR (rest))) - scm_wrong_num_args (smob); - return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, a2, SCM_CAR (rest)); - case SCM_GSUBR_MAKTYPE (2, 0, 1): - case SCM_GSUBR_MAKTYPE (1, 1, 1): - case SCM_GSUBR_MAKTYPE (0, 2, 1): - return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, a2, rest); - default: - if (SCM_GSUBR_REQ (type) > 3) - scm_wrong_num_args (smob); - scm_misc_error ("scm_smob_apply_3", - "Unsupported smob application: ~S", - SCM_LIST1 (smob)); - } + return SCM_SMOB_APPLY3 (smob, SCM_UNDEFINED, SCM_UNDEFINED, SCM_UNDEFINED); } +static SCM +scm_smob_apply_0_001 (SCM smob) +{ + return SCM_SMOB_APPLY1 (smob, SCM_EOL); +} + +static SCM +scm_smob_apply_0_011 (SCM smob) +{ + return SCM_SMOB_APPLY2 (smob, SCM_UNDEFINED, SCM_EOL); +} + +static SCM +scm_smob_apply_0_021 (SCM smob) +{ + return SCM_SMOB_APPLY3 (smob, SCM_UNDEFINED, SCM_UNDEFINED, SCM_EOL); +} + +static SCM +scm_smob_apply_0_error (SCM smob) +{ + scm_wrong_num_args (smob); +} + +static SCM +scm_smob_apply_1_010 (SCM smob, SCM a1) +{ + return SCM_SMOB_APPLY1 (smob, a1); +} + +static SCM +scm_smob_apply_1_020 (SCM smob, SCM a1) +{ + return SCM_SMOB_APPLY2 (smob, a1, SCM_UNDEFINED); +} + +static SCM +scm_smob_apply_1_030 (SCM smob, SCM a1) +{ + return SCM_SMOB_APPLY3 (smob, a1, SCM_UNDEFINED, SCM_UNDEFINED); +} + +static SCM +scm_smob_apply_1_001 (SCM smob, SCM a1) +{ + return SCM_SMOB_APPLY1 (smob, SCM_LIST1 (a1)); +} + +static SCM +scm_smob_apply_1_011 (SCM smob, SCM a1) +{ + return SCM_SMOB_APPLY2 (smob, a1, SCM_EOL); +} + +static SCM +scm_smob_apply_1_021 (SCM smob, SCM a1) +{ + return SCM_SMOB_APPLY3 (smob, a1, SCM_UNDEFINED, SCM_EOL); +} + +static SCM +scm_smob_apply_1_error (SCM smob, SCM a1) +{ + scm_wrong_num_args (smob); +} + +static SCM +scm_smob_apply_2_020 (SCM smob, SCM a1, SCM a2) +{ + return SCM_SMOB_APPLY2 (smob, a1, a2); +} + +static SCM +scm_smob_apply_2_030 (SCM smob, SCM a1, SCM a2) +{ + return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_UNDEFINED); +} + +static SCM +scm_smob_apply_2_001 (SCM smob, SCM a1, SCM a2) +{ + return SCM_SMOB_APPLY1 (smob, SCM_LIST2 (a1, a2)); + } + +static SCM +scm_smob_apply_2_011 (SCM smob, SCM a1, SCM a2) +{ + return SCM_SMOB_APPLY2 (smob, a1, SCM_LIST1 (a2)); +} + +static SCM +scm_smob_apply_2_021 (SCM smob, SCM a1, SCM a2) +{ + return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_EOL); +} + +static SCM +scm_smob_apply_2_error (SCM smob, SCM a1, SCM a2) +{ + scm_wrong_num_args (smob); +} + +static SCM +scm_smob_apply_3_030 (SCM smob, SCM a1, SCM a2, SCM rst) +{ + if (!SCM_NULLP (SCM_CDR (rst))) + scm_wrong_num_args (smob); + return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_CAR (rst)); +} + +static SCM +scm_smob_apply_3_001 (SCM smob, SCM a1, SCM a2, SCM rst) +{ + return SCM_SMOB_APPLY1 (smob, scm_cons2 (a1, a2, rst)); +} + +static SCM +scm_smob_apply_3_011 (SCM smob, SCM a1, SCM a2, SCM rst) +{ + return SCM_SMOB_APPLY2 (smob, a1, scm_cons (a2, rst)); +} + +static SCM +scm_smob_apply_3_021 (SCM smob, SCM a1, SCM a2, SCM rst) +{ + return SCM_SMOB_APPLY3 (smob, a1, a2, rst); +} + +static SCM +scm_smob_apply_3_error (SCM smob, SCM a1, SCM a2, SCM rst) +{ + scm_wrong_num_args (smob); +} + + long scm_make_smob_type (char *name, scm_sizet size) { @@ -308,7 +313,10 @@ scm_make_smob_type (char *name, scm_sizet size) scm_smobs[scm_numsmob].print = scm_smob_print; scm_smobs[scm_numsmob].equalp = 0; scm_smobs[scm_numsmob].apply = 0; - scm_smobs[scm_numsmob].gsubr_type = 0; + scm_smobs[scm_numsmob].apply_0 = 0; + scm_smobs[scm_numsmob].apply_1 = 0; + scm_smobs[scm_numsmob].apply_2 = 0; + scm_smobs[scm_numsmob].apply_3 = 0; scm_numsmob++; } SCM_ALLOW_INTS; @@ -363,8 +371,111 @@ scm_set_smob_equalp (long tc, SCM (*equalp) (SCM, SCM)) void scm_set_smob_apply (long tc, SCM (*apply) (), int req, int opt, int rst) { + SCM (*apply_0) (SCM); + SCM (*apply_1) (SCM, SCM); + SCM (*apply_2) (SCM, SCM, SCM); + SCM (*apply_3) (SCM, SCM, SCM, SCM); + int type = SCM_GSUBR_MAKTYPE (req, opt, rst); + + if (!(req >= 0 && opt >= 0 && (rst == 0 || rst == 1) + && req + opt + rst <= 3)) + { + puts ("Unsupported smob application type"); + abort (); + } + + switch (type) + { + case SCM_GSUBR_MAKTYPE (0, 0, 0): + apply_0 = scm_smob_apply_0_000; break; + case SCM_GSUBR_MAKTYPE (0, 1, 0): + apply_0 = scm_smob_apply_0_010; break; + case SCM_GSUBR_MAKTYPE (0, 2, 0): + apply_0 = scm_smob_apply_0_020; break; + case SCM_GSUBR_MAKTYPE (0, 3, 0): + apply_0 = scm_smob_apply_0_030; break; + case SCM_GSUBR_MAKTYPE (0, 0, 1): + apply_0 = scm_smob_apply_0_001; break; + case SCM_GSUBR_MAKTYPE (0, 1, 1): + apply_0 = scm_smob_apply_0_011; break; + case SCM_GSUBR_MAKTYPE (0, 2, 1): + apply_0 = scm_smob_apply_0_021; break; + default: + apply_0 = scm_smob_apply_0_error; break; + } + + switch (type) + { + case SCM_GSUBR_MAKTYPE (1, 0, 0): + case SCM_GSUBR_MAKTYPE (0, 1, 0): + apply_1 = scm_smob_apply_1_010; break; + case SCM_GSUBR_MAKTYPE (1, 1, 0): + case SCM_GSUBR_MAKTYPE (0, 2, 0): + apply_1 = scm_smob_apply_1_020; break; + case SCM_GSUBR_MAKTYPE (1, 2, 0): + case SCM_GSUBR_MAKTYPE (0, 3, 0): + apply_1 = scm_smob_apply_1_030; break; + case SCM_GSUBR_MAKTYPE (0, 0, 1): + apply_1 = scm_smob_apply_1_001; break; + case SCM_GSUBR_MAKTYPE (1, 0, 1): + case SCM_GSUBR_MAKTYPE (0, 1, 1): + apply_1 = scm_smob_apply_1_011; break; + case SCM_GSUBR_MAKTYPE (1, 1, 1): + case SCM_GSUBR_MAKTYPE (0, 2, 1): + apply_1 = scm_smob_apply_1_021; break; + default: + apply_1 = scm_smob_apply_1_error; break; + } + + switch (type) + { + case SCM_GSUBR_MAKTYPE (2, 0, 0): + case SCM_GSUBR_MAKTYPE (1, 1, 0): + case SCM_GSUBR_MAKTYPE (0, 2, 0): + apply_2 = scm_smob_apply_2_020; break; + case SCM_GSUBR_MAKTYPE (2, 1, 0): + case SCM_GSUBR_MAKTYPE (1, 2, 0): + case SCM_GSUBR_MAKTYPE (0, 3, 0): + apply_2 = scm_smob_apply_2_030; break; + case SCM_GSUBR_MAKTYPE (0, 0, 1): + apply_2 = scm_smob_apply_2_001; break; + case SCM_GSUBR_MAKTYPE (1, 0, 1): + case SCM_GSUBR_MAKTYPE (0, 1, 1): + apply_2 = scm_smob_apply_2_011; break; + case SCM_GSUBR_MAKTYPE (2, 0, 1): + case SCM_GSUBR_MAKTYPE (1, 1, 1): + case SCM_GSUBR_MAKTYPE (0, 2, 1): + apply_2 = scm_smob_apply_2_021; break; + default: + apply_2 = scm_smob_apply_2_error; break; + } + + switch (type) + { + case SCM_GSUBR_MAKTYPE (3, 0, 0): + case SCM_GSUBR_MAKTYPE (2, 1, 0): + case SCM_GSUBR_MAKTYPE (1, 2, 0): + case SCM_GSUBR_MAKTYPE (0, 3, 0): + apply_3 = scm_smob_apply_3_030; break; + case SCM_GSUBR_MAKTYPE (0, 0, 1): + apply_3 = scm_smob_apply_3_001; break; + case SCM_GSUBR_MAKTYPE (1, 0, 1): + case SCM_GSUBR_MAKTYPE (0, 1, 1): + apply_3 = scm_smob_apply_3_011; break; + case SCM_GSUBR_MAKTYPE (2, 0, 1): + case SCM_GSUBR_MAKTYPE (1, 1, 1): + case SCM_GSUBR_MAKTYPE (0, 2, 1): + apply_3 = scm_smob_apply_3_021; break; + default: + apply_3 = scm_smob_apply_3_error; break; + } + + scm_smobs[SCM_TC2SMOBNUM (tc)].gsubr_type = type; /* Used in procprop.c */ scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply; - scm_smobs[SCM_TC2SMOBNUM (tc)].gsubr_type = SCM_GSUBR_MAKTYPE (req, opt, rst); + scm_smobs[SCM_TC2SMOBNUM (tc)].apply_0 = apply_0; + scm_smobs[SCM_TC2SMOBNUM (tc)].apply_1 = apply_1; + scm_smobs[SCM_TC2SMOBNUM (tc)].apply_2 = apply_2; + scm_smobs[SCM_TC2SMOBNUM (tc)].apply_3 = apply_3; } void diff --git a/libguile/smob.h b/libguile/smob.h index b6de488b6..96589fb63 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -57,8 +57,12 @@ typedef struct scm_smob_descriptor scm_sizet (*free) (SCM); int (*print) (SCM exp, SCM port, scm_print_state *pstate); SCM (*equalp) (SCM, SCM); - SCM (*apply) (); int gsubr_type; + SCM (*apply) (); + SCM (*apply_0) (SCM); + SCM (*apply_1) (SCM, SCM); + SCM (*apply_2) (SCM, SCM, SCM); + SCM (*apply_3) (SCM, SCM, SCM, SCM); } scm_smob_descriptor; From 23cc31b8ee07cb9f18d706d8a971fda5cf0ed0c0 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Thu, 7 Dec 2000 01:40:55 +0000 Subject: [PATCH 0405/2047] Test suite for applicable smobs. --- test-suite/tests/asmobs/Makefile | 0 test-suite/tests/asmobs/README | 0 test-suite/tests/asmobs/asmobs-test.scm | 0 test-suite/tests/asmobs/asmobs.c | 0 4 files changed, 0 insertions(+), 0 deletions(-) create mode 100644 test-suite/tests/asmobs/Makefile create mode 100644 test-suite/tests/asmobs/README create mode 100644 test-suite/tests/asmobs/asmobs-test.scm create mode 100644 test-suite/tests/asmobs/asmobs.c diff --git a/test-suite/tests/asmobs/Makefile b/test-suite/tests/asmobs/Makefile new file mode 100644 index 000000000..e69de29bb diff --git a/test-suite/tests/asmobs/README b/test-suite/tests/asmobs/README new file mode 100644 index 000000000..e69de29bb diff --git a/test-suite/tests/asmobs/asmobs-test.scm b/test-suite/tests/asmobs/asmobs-test.scm new file mode 100644 index 000000000..e69de29bb diff --git a/test-suite/tests/asmobs/asmobs.c b/test-suite/tests/asmobs/asmobs.c new file mode 100644 index 000000000..e69de29bb From 68b069240f6039116c62a62c51ca0ea32e6ff92f Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Thu, 7 Dec 2000 07:10:26 +0000 Subject: [PATCH 0406/2047] Some cleanup on smob calls. --- libguile/ChangeLog | 8 ++++++++ libguile/eval.c | 36 +++++++++++++++++------------------- libguile/procprop.c | 2 +- libguile/smob.c | 3 ++- libguile/smob.h | 7 ++++++- 5 files changed, 34 insertions(+), 22 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f24abe03b..25cfb5d63 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2000-12-07 Keisuke Nishida + + * smob.h (SCM_SMOB_APPLICABLE_P, SCM_SMOB_APPLY_0, + SCM_SMOB_APPLY_1, SCM_SMOB_APPLY_2, SCM_SMOB_APPLY_3): New macros. + * eval.c (SCM_CEVAL, SCM_APPLY): Use macros above. + * procprop.c (scm_i_procedure_arity): Ditto. + * smob.c (scm_make_smob_type): Initialize gsubr_type. + 2000-12-06 Keisuke Nishida * smob.h (scm_smob_descriptor): New fields `apply_0', `apply_1', diff --git a/libguile/eval.c b/libguile/eval.c index dc1f0905a..dbabf73af 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2578,9 +2578,9 @@ evapply: case scm_tc7_asubr: RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED)); case scm_tc7_smob: - if (!SCM_SMOB_DESCRIPTOR (proc).apply) + if (!SCM_SMOB_APPLICABLE_P (proc)) goto badfun; - RETURN (SCM_SMOB_DESCRIPTOR (proc).apply_0 (proc)); + RETURN (SCM_SMOB_APPLY_0 (proc)); case scm_tc7_cclo: t.arg1 = proc; proc = SCM_CCLO_SUBR (proc); @@ -2727,9 +2727,9 @@ evapply: RETURN (SCM_SUBRF (proc) (scm_cons (t.arg1, SCM_EOL))); #endif case scm_tc7_smob: - if (!SCM_SMOB_DESCRIPTOR (proc).apply) + if (!SCM_SMOB_APPLICABLE_P (proc)) goto badfun; - RETURN (SCM_SMOB_DESCRIPTOR (proc).apply_1 (proc, t.arg1)); + RETURN (SCM_SMOB_APPLY_1 (proc, t.arg1)); case scm_tc7_cclo: arg2 = t.arg1; t.arg1 = proc; @@ -2843,9 +2843,9 @@ evapply: case scm_tc7_asubr: RETURN (SCM_SUBRF (proc) (t.arg1, arg2)); case scm_tc7_smob: - if (!SCM_SMOB_DESCRIPTOR (proc).apply) + if (!SCM_SMOB_APPLICABLE_P (proc)) goto badfun; - RETURN (SCM_SMOB_DESCRIPTOR (proc).apply_2 (proc, t.arg1, arg2)); + RETURN (SCM_SMOB_APPLY_2 (proc, t.arg1, arg2)); cclon: case scm_tc7_cclo: #ifdef DEVAL @@ -2982,10 +2982,10 @@ evapply: case scm_tc7_lsubr: RETURN (SCM_SUBRF (proc) (debug.info->a.args)) case scm_tc7_smob: - if (!SCM_SMOB_DESCRIPTOR (proc).apply) + if (!SCM_SMOB_APPLICABLE_P (proc)) goto badfun; - RETURN (SCM_SMOB_DESCRIPTOR (proc).apply_3 - (proc, t.arg1, arg2, SCM_CDDR (debug.info->a.args))); + RETURN (SCM_SMOB_APPLY_3 (proc, t.arg1, arg2, + SCM_CDDR (debug.info->a.args))); case scm_tc7_cclo: goto cclon; case scm_tc7_pws: @@ -3044,10 +3044,10 @@ evapply: arg2, scm_eval_args (x, env, proc)))); case scm_tc7_smob: - if (!SCM_SMOB_DESCRIPTOR (proc).apply) + if (!SCM_SMOB_APPLICABLE_P (proc)) goto badfun; - RETURN (SCM_SMOB_DESCRIPTOR (proc).apply_3 - (proc, t.arg1, arg2, scm_eval_args (x, env, proc))); + RETURN (SCM_SMOB_APPLY_3 (proc, t.arg1, arg2, + scm_eval_args (x, env, proc))); case scm_tc7_cclo: goto cclon; case scm_tc7_pws: @@ -3409,18 +3409,16 @@ tail: } RETURN (EVALCAR (proc, args)); case scm_tc7_smob: - if (!SCM_SMOB_DESCRIPTOR (proc).apply) + if (!SCM_SMOB_APPLICABLE_P (proc)) goto badproc; if (SCM_UNBNDP (arg1)) - RETURN (SCM_SMOB_DESCRIPTOR (proc).apply_0 (proc)) + RETURN (SCM_SMOB_APPLY_0 (proc)) else if (SCM_NULLP (args)) - RETURN (SCM_SMOB_DESCRIPTOR (proc).apply_1 (proc, arg1)) + RETURN (SCM_SMOB_APPLY_1 (proc, arg1)) else if (SCM_NULLP (SCM_CDR (args))) - RETURN (SCM_SMOB_DESCRIPTOR (proc).apply_2 - (proc, arg1, SCM_CAR (args))) + RETURN (SCM_SMOB_APPLY_2 (proc, arg1, SCM_CAR (args))) else - RETURN (SCM_SMOB_DESCRIPTOR (proc).apply_3 - (proc, arg1, SCM_CAR (args), SCM_CDR (args))); + RETURN (SCM_SMOB_APPLY_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args))); case scm_tc7_cclo: #ifdef DEVAL args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args); diff --git a/libguile/procprop.c b/libguile/procprop.c index 9d9a131eb..f0ec8dd2e 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -98,7 +98,7 @@ scm_i_procedure_arity (SCM proc) r = 1; break; case scm_tc7_smob: - if (SCM_SMOB_DESCRIPTOR (proc).apply) + if (SCM_SMOB_APPLICABLE_P (proc)) { int type = SCM_SMOB_DESCRIPTOR (proc).gsubr_type; a += SCM_GSUBR_REQ (type); diff --git a/libguile/smob.c b/libguile/smob.c index 9475542fd..ca23373bb 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -317,6 +317,7 @@ scm_make_smob_type (char *name, scm_sizet size) scm_smobs[scm_numsmob].apply_1 = 0; scm_smobs[scm_numsmob].apply_2 = 0; scm_smobs[scm_numsmob].apply_3 = 0; + scm_smobs[scm_numsmob].gsubr_type = 0; scm_numsmob++; } SCM_ALLOW_INTS; @@ -470,12 +471,12 @@ scm_set_smob_apply (long tc, SCM (*apply) (), int req, int opt, int rst) apply_3 = scm_smob_apply_3_error; break; } - scm_smobs[SCM_TC2SMOBNUM (tc)].gsubr_type = type; /* Used in procprop.c */ scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply; scm_smobs[SCM_TC2SMOBNUM (tc)].apply_0 = apply_0; scm_smobs[SCM_TC2SMOBNUM (tc)].apply_1 = apply_1; scm_smobs[SCM_TC2SMOBNUM (tc)].apply_2 = apply_2; scm_smobs[SCM_TC2SMOBNUM (tc)].apply_3 = apply_3; + scm_smobs[SCM_TC2SMOBNUM (tc)].gsubr_type = type; } void diff --git a/libguile/smob.h b/libguile/smob.h index 96589fb63..437eaccc9 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -57,12 +57,12 @@ typedef struct scm_smob_descriptor scm_sizet (*free) (SCM); int (*print) (SCM exp, SCM port, scm_print_state *pstate); SCM (*equalp) (SCM, SCM); - int gsubr_type; SCM (*apply) (); SCM (*apply_0) (SCM); SCM (*apply_1) (SCM, SCM); SCM (*apply_2) (SCM, SCM, SCM); SCM (*apply_3) (SCM, SCM, SCM, SCM); + int gsubr_type; /* Used in procprop.c */ } scm_smob_descriptor; @@ -119,6 +119,11 @@ do { \ #define SCM_SMOB_PREDICATE(tag, obj) (SCM_NIMP (obj) \ && SCM_TYP16 (obj) == (tag)) #define SCM_SMOB_DESCRIPTOR(x) (scm_smobs[SCM_SMOBNUM (x)]) +#define SCM_SMOB_APPLICABLE_P(x) (SCM_SMOB_DESCRIPTOR (x).apply) +#define SCM_SMOB_APPLY_0(x) (SCM_SMOB_DESCRIPTOR (x).apply_0 (x)) +#define SCM_SMOB_APPLY_1(x,a1) (SCM_SMOB_DESCRIPTOR (x).apply_1 (x, (a1))) +#define SCM_SMOB_APPLY_2(x,a1,a2) (SCM_SMOB_DESCRIPTOR (x).apply_2 (x, (a1), (a2))) +#define SCM_SMOB_APPLY_3(x,a1,a2,rst) (SCM_SMOB_DESCRIPTOR (x).apply_3 (x, (a1), (a2), (rst))) extern int scm_numsmob; extern scm_smob_descriptor *scm_smobs; From 7c58e21b087b4b73835a6365045377d7dd1d22f3 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Thu, 7 Dec 2000 12:04:48 +0000 Subject: [PATCH 0407/2047] Deprecated scm_make_smob_type_mfpe and scm_set_smob_mfpe. Some optimization on applicable smobs. (Thanks to Dirk Herrmann) --- libguile/ChangeLog | 12 ++++++ libguile/smob.c | 91 ++++++++++++++++++++-------------------------- libguile/smob.h | 29 ++++++--------- 3 files changed, 64 insertions(+), 68 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 25cfb5d63..814a4f180 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,15 @@ +2000-12-07 Keisuke Nishida + + * smob.h (scm_smob_apply_0, scm_smob_apply_1, scm_smob_apply_2, + scm_smob_apply_3): Removed declarations. + (scm_set_smob_apply): Takes unsigned integers. + (scm_make_smob_type_mfpe, scm_set_smob_mfpe): Deprecated. + * smob.c (scm_smob_apply_0_000, scm_smob_apply_1_010, + scm_smob_apply_2_020): Removed. + (scm_set_smob_apply): Takes unsigned integers + some optimization. + (Thanks to Dirk Herrmann) + (scm_make_smob_type_mfpe, scm_set_smob_mfpe): Deprecated. + 2000-12-07 Keisuke Nishida * smob.h (SCM_SMOB_APPLICABLE_P, SCM_SMOB_APPLY_0, diff --git a/libguile/smob.c b/libguile/smob.c index ca23373bb..5b9a0703c 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -134,12 +134,6 @@ scm_smob_print (SCM exp, SCM port, scm_print_state *pstate) #define SCM_SMOB_APPLY3(SMOB,A1,A2,A3) \ SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2, A3) -static SCM -scm_smob_apply_0_000 (SCM smob) -{ - return SCM_SMOB_APPLY0 (smob); -} - static SCM scm_smob_apply_0_010 (SCM smob) { @@ -182,12 +176,6 @@ scm_smob_apply_0_error (SCM smob) scm_wrong_num_args (smob); } -static SCM -scm_smob_apply_1_010 (SCM smob, SCM a1) -{ - return SCM_SMOB_APPLY1 (smob, a1); -} - static SCM scm_smob_apply_1_020 (SCM smob, SCM a1) { @@ -224,12 +212,6 @@ scm_smob_apply_1_error (SCM smob, SCM a1) scm_wrong_num_args (smob); } -static SCM -scm_smob_apply_2_020 (SCM smob, SCM a1, SCM a2) -{ - return SCM_SMOB_APPLY2 (smob, a1, a2); -} - static SCM scm_smob_apply_2_030 (SCM smob, SCM a1, SCM a2) { @@ -240,7 +222,7 @@ static SCM scm_smob_apply_2_001 (SCM smob, SCM a1, SCM a2) { return SCM_SMOB_APPLY1 (smob, SCM_LIST2 (a1, a2)); - } +} static SCM scm_smob_apply_2_011 (SCM smob, SCM a1, SCM a2) @@ -333,18 +315,6 @@ scm_make_smob_type (char *name, scm_sizet size) return scm_tc7_smob + (scm_numsmob - 1) * 256; } -long -scm_make_smob_type_mfpe (char *name, scm_sizet size, - SCM (*mark) (SCM), - scm_sizet (*free) (SCM), - int (*print) (SCM, SCM, scm_print_state *), - SCM (*equalp) (SCM, SCM)) -{ - long answer = scm_make_smob_type (name, size); - scm_set_smob_mfpe (answer, mark, free, print, equalp); - return answer; -} - void scm_set_smob_mark (long tc, SCM (*mark) (SCM)) { @@ -370,7 +340,8 @@ scm_set_smob_equalp (long tc, SCM (*equalp) (SCM, SCM)) } void -scm_set_smob_apply (long tc, SCM (*apply) (), int req, int opt, int rst) +scm_set_smob_apply (long tc, SCM (*apply) (), + unsigned int req, unsigned int opt, unsigned int rst) { SCM (*apply_0) (SCM); SCM (*apply_1) (SCM, SCM); @@ -378,8 +349,7 @@ scm_set_smob_apply (long tc, SCM (*apply) (), int req, int opt, int rst) SCM (*apply_3) (SCM, SCM, SCM, SCM); int type = SCM_GSUBR_MAKTYPE (req, opt, rst); - if (!(req >= 0 && opt >= 0 && (rst == 0 || rst == 1) - && req + opt + rst <= 3)) + if (rst > 1 || req + opt + rst > 3) { puts ("Unsupported smob application type"); abort (); @@ -388,7 +358,7 @@ scm_set_smob_apply (long tc, SCM (*apply) (), int req, int opt, int rst) switch (type) { case SCM_GSUBR_MAKTYPE (0, 0, 0): - apply_0 = scm_smob_apply_0_000; break; + apply_0 = apply; break; case SCM_GSUBR_MAKTYPE (0, 1, 0): apply_0 = scm_smob_apply_0_010; break; case SCM_GSUBR_MAKTYPE (0, 2, 0): @@ -409,7 +379,7 @@ scm_set_smob_apply (long tc, SCM (*apply) (), int req, int opt, int rst) { case SCM_GSUBR_MAKTYPE (1, 0, 0): case SCM_GSUBR_MAKTYPE (0, 1, 0): - apply_1 = scm_smob_apply_1_010; break; + apply_1 = apply; break; case SCM_GSUBR_MAKTYPE (1, 1, 0): case SCM_GSUBR_MAKTYPE (0, 2, 0): apply_1 = scm_smob_apply_1_020; break; @@ -433,7 +403,7 @@ scm_set_smob_apply (long tc, SCM (*apply) (), int req, int opt, int rst) case SCM_GSUBR_MAKTYPE (2, 0, 0): case SCM_GSUBR_MAKTYPE (1, 1, 0): case SCM_GSUBR_MAKTYPE (0, 2, 0): - apply_2 = scm_smob_apply_2_020; break; + apply_2 = apply; break; case SCM_GSUBR_MAKTYPE (2, 1, 0): case SCM_GSUBR_MAKTYPE (1, 2, 0): case SCM_GSUBR_MAKTYPE (0, 3, 0): @@ -479,20 +449,6 @@ scm_set_smob_apply (long tc, SCM (*apply) (), int req, int opt, int rst) scm_smobs[SCM_TC2SMOBNUM (tc)].gsubr_type = type; } -void -scm_set_smob_mfpe (long tc, - SCM (*mark) (SCM), - scm_sizet (*free) (SCM), - int (*print) (SCM, SCM, scm_print_state *), - SCM (*equalp) (SCM, SCM)) -{ - if (mark) scm_set_smob_mark (tc, mark); - if (free) scm_set_smob_free (tc, free); - if (print) scm_set_smob_print (tc, print); - if (equalp) scm_set_smob_equalp (tc, equalp); -} - - SCM scm_make_smob (long tc) { @@ -514,6 +470,39 @@ scm_make_smob (long tc) return z; } + +/* {Deprecated stuff} + */ + +#if (SCM_DEBUG_DEPRECATED == 0) + +long +scm_make_smob_type_mfpe (char *name, scm_sizet size, + SCM (*mark) (SCM), + scm_sizet (*free) (SCM), + int (*print) (SCM, SCM, scm_print_state *), + SCM (*equalp) (SCM, SCM)) +{ + long answer = scm_make_smob_type (name, size); + scm_set_smob_mfpe (answer, mark, free, print, equalp); + return answer; +} + +void +scm_set_smob_mfpe (long tc, + SCM (*mark) (SCM), + scm_sizet (*free) (SCM), + int (*print) (SCM, SCM, scm_print_state *), + SCM (*equalp) (SCM, SCM)) +{ + if (mark) scm_set_smob_mark (tc, mark); + if (free) scm_set_smob_free (tc, free); + if (print) scm_set_smob_print (tc, print); + if (equalp) scm_set_smob_equalp (tc, equalp); +} + +#endif /* SCM_DEBUG_DEPRECATED == 0 */ + /* {Initialization for i/o types, float, bignum, the type of free cells} */ diff --git a/libguile/smob.h b/libguile/smob.h index 437eaccc9..878bd62e8 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -136,11 +136,6 @@ extern scm_sizet scm_free0 (SCM ptr); extern scm_sizet scm_smob_free (SCM obj); extern int scm_smob_print (SCM exp, SCM port, scm_print_state *pstate); -extern SCM scm_smob_apply_0 (SCM smob); -extern SCM scm_smob_apply_1 (SCM smob, SCM a1); -extern SCM scm_smob_apply_2 (SCM smob, SCM a1, SCM a2); -extern SCM scm_smob_apply_3 (SCM smob, SCM a1, SCM a2, SCM rest); - /* The following set of functions is the standard way to create new * SMOB types. * @@ -157,14 +152,19 @@ extern void scm_set_smob_print (long tc, int (*print) (SCM, SCM, scm_print_state*)); extern void scm_set_smob_equalp (long tc, SCM (*equalp) (SCM, SCM)); -extern void scm_set_smob_apply (long tc, SCM (*apply) (), int req, int opt, int rst); +extern void scm_set_smob_apply (long tc, SCM (*apply) (), + unsigned int req, + unsigned int opt, + unsigned int rst); +/* Function for creating smobs */ -/* Functions for registering multiple handler functions simultaneously. - * - * (There is a discussion among the developers whether or not these - * should be deprecated in the future.) - */ +extern SCM scm_make_smob (long tc); +extern void scm_smob_prehistory (void); + + + +#if (SCM_DEBUG_DEPRECATED == 0) extern long scm_make_smob_type_mfpe (char *name, scm_sizet size, SCM (*mark) (SCM), @@ -178,12 +178,7 @@ extern void scm_set_smob_mfpe (long tc, int (*print) (SCM, SCM, scm_print_state*), SCM (*equalp) (SCM, SCM)); -/* Function for creating smobs */ - -extern SCM scm_make_smob (long tc); -extern void scm_smob_prehistory (void); - - +#endif /* SCM_DEBUG_DEPRECATED == 0 */ #endif /* SMOBH */ From 23670993da5437eb5560559b45164eae539f3319 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 7 Dec 2000 13:46:33 +0000 Subject: [PATCH 0408/2047] * Undid my last patch and added a comment why it was unnecessary. --- libguile/ChangeLog | 6 ++++++ libguile/gc.c | 3 +-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 814a4f180..52a2ffce2 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2000-12-07 Dirk Herrmann + + * gc.c (scm_init_gc): gc_async is already protected from gc, + namely via scm_asyncs. Thanks to Keisuke Nishida for pointing + this out. + 2000-12-07 Keisuke Nishida * smob.h (scm_smob_apply_0, scm_smob_apply_1, scm_smob_apply_2, diff --git a/libguile/gc.c b/libguile/gc.c index 96011f14f..b50281cda 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -2581,8 +2581,7 @@ scm_init_gc () scm_gc_vcell = scm_sysintern ("gc-thunk", SCM_BOOL_F); #endif /* SCM_DEBUG_DEPRECATED == 0 */ after_gc_thunk = scm_make_subr_opt ("%gc-thunk", scm_tc7_subr_0, gc_async_thunk, 0); - gc_async = scm_system_async (after_gc_thunk); - scm_permanent_object (gc_async); + gc_async = scm_system_async (after_gc_thunk); /* protected via scm_asyncs */ scm_c_hook_add (&scm_after_gc_c_hook, mark_gc_async, NULL, 0); From 93d40df216ff9d8b528d67d20b7867e31ad89827 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 8 Dec 2000 13:41:56 +0000 Subject: [PATCH 0409/2047] * Guile does not assume a hash table size of scm_symhash_dim any more. --- NEWS | 2 ++ libguile/ChangeLog | 20 ++++++++++++++++++++ libguile/environments.c | 5 +++-- libguile/gc.c | 9 ++++++--- libguile/symbols.c | 37 ++++++++++++++----------------------- libguile/symbols.h | 2 -- 6 files changed, 45 insertions(+), 30 deletions(-) diff --git a/NEWS b/NEWS index cc847018d..028cb1315 100644 --- a/NEWS +++ b/NEWS @@ -322,6 +322,8 @@ Use SCM_CDR instead of SCM_GCCDR. ** Removed function: scm_struct_init +** Removed variable: scm_symhash_dim + ** Renamed function: scm_make_cont has been replaced by scm_make_continuation, which has a different interface. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 52a2ffce2..809d565c5 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,23 @@ +2000-12-08 Dirk Herrmann + + * environments.c (DEFAULT_OBARRAY_SIZE), gc.c + (DEFAULT_SYMHASH_SIZE): Added to locally determine arbitrary + default values for obarrays, thus removing the dependency from + scm_symhash_dim. + + * environments.c (scm_make_leaf_environment, + scm_make_eval_environment), gc.c (scm_init_storage): Don't use + scm_symhash_dim. + + * symbols.c (NUM_HASH_BUCKETS), symbols.[ch] (scm_symhash_dim): + Removed. + + * symbols.c (scm_sym2vcell, scm_sysintern0_no_module_lookup): + Eliminate a redundant SCM_IMP test. + + (scm_sym2vcell, scm_sysintern0_no_module_lookup): + Don't assume a fixed obarray size any more. + 2000-12-07 Dirk Herrmann * gc.c (scm_init_gc): gc_async is already protected from gc, diff --git a/libguile/environments.c b/libguile/environments.c index d577e50ad..8f6910648 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -58,6 +58,7 @@ long scm_tc16_environment; long scm_tc16_observer; +#define DEFAULT_OBARRAY_SIZE 137 @@ -1036,7 +1037,7 @@ SCM_DEFINE (scm_make_leaf_environment, "make-leaf-environment", 0, 0, 0, env = scm_make_environment (body); core_environments_init (&body->base, &leaf_environment_funcs); - body->obarray = scm_make_vector (SCM_MAKINUM (scm_symhash_dim), SCM_EOL); + body->obarray = scm_make_vector (SCM_MAKINUM (DEFAULT_OBARRAY_SIZE), SCM_EOL); return env; } @@ -1428,7 +1429,7 @@ SCM_DEFINE (scm_make_eval_environment, "make-eval-environment", 2, 0, 0, env = scm_make_environment (body); core_environments_init (&body->base, &eval_environment_funcs); - body->obarray = scm_make_vector (SCM_MAKINUM (scm_symhash_dim), SCM_EOL); + body->obarray = scm_make_vector (SCM_MAKINUM (DEFAULT_OBARRAY_SIZE), SCM_EOL); body->imported = imported; body->imported_observer = SCM_ENVIRONMENT_OBSERVE (imported, eval_environment_observer, env, 1); diff --git a/libguile/gc.c b/libguile/gc.c index b50281cda..e04d50b18 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -2506,9 +2506,12 @@ scm_init_storage (scm_sizet init_heap_size_1, int gc_trigger_1, scm_listofnull = scm_cons (SCM_EOL, SCM_EOL); scm_nullstr = scm_makstr (0L, 0); scm_nullvect = scm_make_vector (SCM_INUM0, SCM_UNDEFINED); - scm_symhash = scm_make_vector (SCM_MAKINUM (scm_symhash_dim), SCM_EOL); - scm_weak_symhash = scm_make_weak_key_hash_table (SCM_MAKINUM (scm_symhash_dim)); - scm_symhash_vars = scm_make_vector (SCM_MAKINUM (scm_symhash_dim), SCM_EOL); + +#define DEFAULT_SYMHASH_SIZE 277 + scm_symhash = scm_make_vector (SCM_MAKINUM (DEFAULT_SYMHASH_SIZE), SCM_EOL); + scm_weak_symhash = scm_make_weak_key_hash_table (SCM_MAKINUM (DEFAULT_SYMHASH_SIZE)); + scm_symhash_vars = scm_make_vector (SCM_MAKINUM (DEFAULT_SYMHASH_SIZE), SCM_EOL); + scm_stand_in_procs = SCM_EOL; scm_permobjs = SCM_EOL; scm_protects = scm_make_vector (SCM_MAKINUM (31), SCM_EOL); diff --git a/libguile/symbols.c b/libguile/symbols.c index e4add2728..aef98d09f 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -66,12 +66,6 @@ -/* NUM_HASH_BUCKETS is the number of symbol scm_hash table buckets. - */ -#define NUM_HASH_BUCKETS 137 - - - static char * duplicate_string (const char * src, unsigned long length) { @@ -109,9 +103,6 @@ scm_string_hash (const unsigned char *str, scm_sizet len) } -int scm_symhash_dim = NUM_HASH_BUCKETS; - - /* scm_sym2vcell * looks up the symbol in the symhash table. */ @@ -131,24 +122,23 @@ scm_sym2vcell (SCM sym, SCM thunk, SCM definep) if (SCM_FALSEP (var)) return SCM_BOOL_F; + else if (SCM_VARIABLEP (var)) + return SCM_VARVCELL (var); else - { - if (SCM_IMP(var) || !SCM_VARIABLEP (var)) - scm_wta (sym, "strangely interned symbol? ", ""); - return SCM_VARVCELL (var); - } + scm_wta (sym, "strangely interned symbol? ", ""); } else { SCM lsym; SCM * lsymp; - SCM z; - scm_sizet hash = SCM_SYMBOL_HASH (sym) % scm_symhash_dim; + scm_sizet hash1; + scm_sizet hash2; SCM_DEFER_INTS; - for (lsym = SCM_VELTS (scm_symhash)[hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) + hash1 = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (scm_symhash); + for (lsym = SCM_VELTS (scm_symhash)[hash1]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) { - z = SCM_CAR (lsym); + SCM z = SCM_CAR (lsym); if (SCM_EQ_P (SCM_CAR (z), sym)) { SCM_ALLOW_INTS; @@ -156,19 +146,20 @@ scm_sym2vcell (SCM sym, SCM thunk, SCM definep) } } - for (lsym = *(lsymp = &SCM_VELTS (scm_weak_symhash)[hash]); + hash2 = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (scm_weak_symhash); + for (lsym = *(lsymp = &SCM_VELTS (scm_weak_symhash)[hash2]); SCM_NIMP (lsym); lsym = *(lsymp = SCM_CDRLOC (lsym))) { - z = SCM_CAR (lsym); + SCM z = SCM_CAR (lsym); if (SCM_EQ_P (SCM_CAR (z), sym)) { if (SCM_NFALSEP (definep)) { /* Move handle from scm_weak_symhash to scm_symhash. */ *lsymp = SCM_CDR (lsym); - SCM_SETCDR (lsym, SCM_VELTS(scm_symhash)[hash]); - SCM_VELTS(scm_symhash)[hash] = lsym; + SCM_SETCDR (lsym, SCM_VELTS(scm_symhash)[hash1]); + SCM_VELTS(scm_symhash)[hash1] = lsym; } SCM_ALLOW_INTS; return z; @@ -363,7 +354,7 @@ scm_sysintern0_no_module_lookup (const char *name) SCM lsym; scm_sizet len = strlen (name); scm_sizet raw_hash = scm_string_hash ((unsigned char *) name, len); - scm_sizet hash = raw_hash % scm_symhash_dim; + scm_sizet hash = raw_hash % SCM_VECTOR_LENGTH (scm_symhash); SCM_NEWCELL2 (lsym); SCM_SET_SYMBOL_CHARS (lsym, name); diff --git a/libguile/symbols.h b/libguile/symbols.h index 2ce698652..7db965dc6 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -50,8 +50,6 @@ #include "libguile/__scm.h" -extern int scm_symhash_dim; - /* SCM_SYMBOL_LENGTH(SYM) is the length of SYM's name in characters, and * SCM_SYMBOL_CHARS(SYM) is the address of the first character of SYM's name. */ From 40fa5c3f3a207327e630663565f8f327a3c67d32 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 8 Dec 2000 15:39:10 +0000 Subject: [PATCH 0410/2047] * Fix spelling mistake. --- ice-9/ChangeLog | 4 ++++ ice-9/emacs.scm | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 0f89081fd..530f80c8d 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2000-12-07 Neil Jerram + + * emacs.scm (flush-whitespace): Fix spelling typo ("recieving"). + 2000-11-28 Dirk Herrmann * boot-9.scm (read-delimited), lineio.scm diff --git a/ice-9/emacs.scm b/ice-9/emacs.scm index 850571d42..4fa6bcd2f 100644 --- a/ice-9/emacs.scm +++ b/ice-9/emacs.scm @@ -116,7 +116,7 @@ (lambda () (let loop ((c (read-char port))) (cond ((eq? c the-eof-object) - (error "End of file while recieving Emacs data")) + (error "End of file while receiving Emacs data")) ((memq c whitespace-chars) (loop (read-char port))) ((eq? c #\;) (flush-line port) (loop (read-char port))) (else (unread-char c port)))) From 23ade5e759a010813491085ee63e0f9219715ba8 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 8 Dec 2000 16:32:36 +0000 Subject: [PATCH 0411/2047] * New functions: scm_str2symbol, scm_mem2symbol --- NEWS | 7 +++++++ libguile/ChangeLog | 7 +++++++ libguile/symbols.c | 14 ++++++++++++++ libguile/symbols.h | 4 ++++ 4 files changed, 32 insertions(+) diff --git a/NEWS b/NEWS index 028cb1315..75f991117 100644 --- a/NEWS +++ b/NEWS @@ -216,6 +216,13 @@ current values of file descriptors 0, 1, and 2 in the parent process. In contrast to scm_boot_guile, scm_init_guile will return normally after initializing Guile. It is not available on all systems, tho. +** New functions: scm_str2symbol, scm_mem2symbol + +The function scm_str2symbol takes a const char* pointing to a zero-terminated +field of characters and creates a scheme symbol object from that C string. +The function scm_mem2symbol takes a const char* and a number of characters and +creates a symbol from the characters in that memory area. + ** New functions: scm_primitive_make_property scm_primitive_property_ref scm_primitive_property_set_x diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 809d565c5..13ef22727 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2000-12-08 Dirk Herrmann + + * symbols.[ch] (scm_mem2symbol, scm_str2symbol): New functions. + These shall replace all those calls to scm_intern... which are + only required to create a scheme symbol from a C string or a field + of chars. + 2000-12-08 Dirk Herrmann * environments.c (DEFAULT_OBARRAY_SIZE), gc.c diff --git a/libguile/symbols.c b/libguile/symbols.c index aef98d09f..42e4d2900 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -316,6 +316,20 @@ scm_intern_obarray_soft (const char *name,scm_sizet len,SCM obarray,unsigned int } +SCM +scm_mem2symbol (const char *mem, scm_sizet len) +{ + return SCM_CAR (scm_intern_obarray_soft (mem, len, scm_symhash, 0)); +} + + +SCM +scm_str2symbol (const char *str) +{ + return SCM_CAR (scm_intern_obarray_soft (str, strlen (str), scm_symhash, 0)); +} + + SCM scm_intern_obarray (const char *name,scm_sizet len,SCM obarray) { diff --git a/libguile/symbols.h b/libguile/symbols.h index 7db965dc6..848d985f9 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -72,6 +72,10 @@ extern unsigned long scm_string_hash (const unsigned char *str, scm_sizet len); + +extern SCM scm_mem2symbol (const char*, scm_sizet); +extern SCM scm_str2symbol (const char*); + extern SCM scm_sym2vcell (SCM sym, SCM thunk, SCM definep); extern SCM scm_sym2ovcell_soft (SCM sym, SCM obarray); extern SCM scm_sym2ovcell (SCM sym, SCM obarray); From 38ae064c6e462bafc7e188b4586fb3e6eedec876 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 8 Dec 2000 17:08:34 +0000 Subject: [PATCH 0412/2047] * Use scm_mem2symbol or scm_str2symbol to create symbol objects. --- libguile/ChangeLog | 35 +++++++++++ libguile/feature.c | 2 +- libguile/gh_data.c | 2 +- libguile/goops.c | 143 ++++++++++++++++++++++----------------------- libguile/load.c | 2 +- libguile/print.c | 2 +- libguile/ramap.c | 2 +- libguile/read.c | 14 ++--- libguile/snarf.h | 4 +- libguile/stacks.c | 3 +- libguile/struct.c | 2 +- libguile/symbols.c | 15 ++--- libguile/throw.c | 2 +- libguile/unif.c | 4 +- 14 files changed, 127 insertions(+), 105 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 13ef22727..94f730661 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,38 @@ +2000-12-08 Dirk Herrmann + + * feature.c (scm_add_feature), gh_data.c (gh_symbol2scm), goops.c + (scm_sys_prep_layout_x, scm_make_class, scm_add_slot, + scm_init_goops), load.c (init_build_info), print.c + (scm_init_print), read.c (scm_lreadr), snarf.h (SCM_SYMBOL, + SCM_GLOBAL_SYMBOL), stacks.c (scm_init_stacks), struct.c + (scm_make_struct_layout), symbols.c (scm_sysintern0, + scm_string_to_symbol, scm_gensym), throw.c + (scm_handle_by_message): Use scm_mem2symbol or scm_str2symbol + instead of scm_intern_* to create a symbol object. + + * goops.c (Intern): Removed. + + (CALL_GF1, CALL_GF2, CALL_GF3, CALL_GF4, build_class_class_slots, + create_basic_classes, scm_class_name, scm_class_direct_supers, + scm_class_direct_slots, scm_class_direct_subclasses, + scm_class_direct_methods, scm_class_precedence_list, + scm_class_slots, scm_class_environment, + scm_generic_function_methods, scm_method_generic_function, + scm_method_specializers, scm_method_procedure, + scm_accessor_method_slot_definition, purgatory, scm_make, + make_stdcls, create_standard_classes, make_class_from_template, + scm_make_class): Replaced calls to Intern with calls to + scm_str2symbol. + + * ramap.c (init_raprocs): Use scm_symbol_binding instead of + scm_intern. + + * symbols.c (scm_sym2vcell): Add a bogus return to avoid compiler + warnings. + + * unif.c (scm_array_prototype): Fix prototype return value for + svects and llvects. + 2000-12-08 Dirk Herrmann * symbols.[ch] (scm_mem2symbol, scm_str2symbol): New functions. diff --git a/libguile/feature.c b/libguile/feature.c index bd9c94aed..4b4320901 100644 --- a/libguile/feature.c +++ b/libguile/feature.c @@ -65,7 +65,7 @@ void scm_add_feature (const char *str) { SCM old = SCM_CDR (features); - SCM new = scm_cons (SCM_CAR (scm_intern (str, strlen (str))), old); + SCM new = scm_cons (scm_str2symbol (str), old); SCM_SETCDR (features, new); } diff --git a/libguile/gh_data.c b/libguile/gh_data.c index a65f75efa..f7e74e5af 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -129,7 +129,7 @@ gh_set_substr (char *src, SCM dst, int start, int len) SCM gh_symbol2scm (const char *symbol_str) { - return SCM_CAR (scm_intern (symbol_str, strlen (symbol_str))); + return scm_str2symbol(symbol_str); } SCM diff --git a/libguile/goops.c b/libguile/goops.c index 470d14616..18db4aebf 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -89,20 +89,15 @@ #define GETVAR(v) (SCM_CDDR (scm_apply (scm_goops_lookup_closure, \ SCM_LIST2 ((v), SCM_BOOL_F), \ SCM_EOL))) -static SCM -Intern (const char *s) -{ - return SCM_CAR (scm_intern (s, strlen (s))); -} /* Fixme: Should use already interned symbols */ -#define CALL_GF1(name,a) (scm_apply (GETVAR (Intern(name)), \ +#define CALL_GF1(name,a) (scm_apply (GETVAR (scm_str2symbol (name)), \ SCM_LIST1 (a), SCM_EOL)) -#define CALL_GF2(name,a,b) (scm_apply (GETVAR (Intern(name)), \ +#define CALL_GF2(name,a,b) (scm_apply (GETVAR (scm_str2symbol (name)), \ SCM_LIST2 (a, b), SCM_EOL)) -#define CALL_GF3(name,a,b,c) (scm_apply (GETVAR (Intern(name)), \ +#define CALL_GF3(name,a,b,c) (scm_apply (GETVAR (scm_str2symbol (name)), \ SCM_LIST3 (a, b, c), SCM_EOL)) -#define CALL_GF4(name,a,b,c,d) (scm_apply (GETVAR (Intern(name)), \ +#define CALL_GF4(name,a,b,c,d) (scm_apply (GETVAR (scm_str2symbol (name)), \ SCM_LIST4 (a, b, c, d), SCM_EOL)) /* Class redefinition protocol: @@ -548,7 +543,7 @@ scm_sys_prep_layout_x (SCM class) s[i + 1] = a; slots = SCM_CDR (slots); } - SCM_SLOT (class, scm_si_layout) = SCM_CAR (scm_intern (s, n)); + SCM_SLOT (class, scm_si_layout) = scm_mem2symbol (s, n); if (s) scm_must_free (s); return SCM_UNSPECIFIED; @@ -685,59 +680,59 @@ static SCM build_class_class_slots () { return maplist ( - scm_cons (SCM_LIST3 (Intern ("layout"), + scm_cons (SCM_LIST3 (scm_str2symbol ("layout"), k_class, scm_class_protected_read_only), - scm_cons (SCM_LIST3 (Intern ("vcell"), + scm_cons (SCM_LIST3 (scm_str2symbol ("vcell"), k_class, scm_class_opaque), - scm_cons (SCM_LIST3 (Intern ("vtable"), + scm_cons (SCM_LIST3 (scm_str2symbol ("vtable"), k_class, scm_class_self), - scm_cons (Intern ("print"), - scm_cons (SCM_LIST3 (Intern ("procedure"), + scm_cons (scm_str2symbol ("print"), + scm_cons (SCM_LIST3 (scm_str2symbol ("procedure"), k_class, scm_class_protected_opaque), - scm_cons (SCM_LIST3 (Intern ("setter"), + scm_cons (SCM_LIST3 (scm_str2symbol ("setter"), k_class, scm_class_protected_opaque), - scm_cons (Intern ("redefined"), - scm_cons (SCM_LIST3 (Intern ("h0"), + scm_cons (scm_str2symbol ("redefined"), + scm_cons (SCM_LIST3 (scm_str2symbol ("h0"), k_class, scm_class_int), - scm_cons (SCM_LIST3 (Intern ("h1"), + scm_cons (SCM_LIST3 (scm_str2symbol ("h1"), k_class, scm_class_int), - scm_cons (SCM_LIST3 (Intern ("h2"), + scm_cons (SCM_LIST3 (scm_str2symbol ("h2"), k_class, scm_class_int), - scm_cons (SCM_LIST3 (Intern ("h3"), + scm_cons (SCM_LIST3 (scm_str2symbol ("h3"), k_class, scm_class_int), - scm_cons (SCM_LIST3 (Intern ("h4"), + scm_cons (SCM_LIST3 (scm_str2symbol ("h4"), k_class, scm_class_int), - scm_cons (SCM_LIST3 (Intern ("h5"), + scm_cons (SCM_LIST3 (scm_str2symbol ("h5"), k_class, scm_class_int), - scm_cons (SCM_LIST3 (Intern ("h6"), + scm_cons (SCM_LIST3 (scm_str2symbol ("h6"), k_class, scm_class_int), - scm_cons (SCM_LIST3 (Intern ("h7"), + scm_cons (SCM_LIST3 (scm_str2symbol ("h7"), k_class, scm_class_int), - scm_cons (Intern ("name"), - scm_cons (Intern ("direct-supers"), - scm_cons (Intern ("direct-slots"), - scm_cons (Intern ("direct-subclasses"), - scm_cons (Intern ("direct-methods"), - scm_cons (Intern ("cpl"), - scm_cons (Intern ("default-slot-definition-class"), - scm_cons (Intern ("slots"), - scm_cons (Intern ("getters-n-setters"), /* name-access */ - scm_cons (Intern ("keyword-access"), - scm_cons (Intern ("nfields"), - scm_cons (Intern ("environment"), + scm_cons (scm_str2symbol ("name"), + scm_cons (scm_str2symbol ("direct-supers"), + scm_cons (scm_str2symbol ("direct-slots"), + scm_cons (scm_str2symbol ("direct-subclasses"), + scm_cons (scm_str2symbol ("direct-methods"), + scm_cons (scm_str2symbol ("cpl"), + scm_cons (scm_str2symbol ("default-slot-definition-class"), + scm_cons (scm_str2symbol ("slots"), + scm_cons (scm_str2symbol ("getters-n-setters"), /* name-access */ + scm_cons (scm_str2symbol ("keyword-access"), + scm_cons (scm_str2symbol ("nfields"), + scm_cons (scm_str2symbol ("environment"), SCM_EOL)))))))))))))))))))))))))))); } @@ -749,7 +744,7 @@ create_basic_classes (void) /**** ****/ SCM cs = scm_makfrom0str (SCM_CLASS_CLASS_LAYOUT + 2 * scm_vtable_offset_user); - SCM name = Intern (""); + SCM name = scm_str2symbol (""); scm_class_class = scm_permanent_object (scm_make_vtable_vtable (cs, SCM_INUM0, SCM_EOL)); @@ -775,7 +770,7 @@ create_basic_classes (void) DEFVAR(name, scm_class_class); /**** ****/ - name = Intern (""); + name = scm_str2symbol (""); scm_class_top = scm_permanent_object (scm_basic_make_class (scm_class_class, name, SCM_EOL, @@ -784,7 +779,7 @@ create_basic_classes (void) DEFVAR(name, scm_class_top); /**** ****/ - name = Intern(""); + name = scm_str2symbol (""); scm_class_object = scm_permanent_object (scm_basic_make_class (scm_class_class, name, SCM_LIST1 (scm_class_top), @@ -823,7 +818,7 @@ SCM scm_class_name (SCM obj) { SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), obj, SCM_ARG1, s_class_name); - return scm_slot_ref (obj, Intern ("name")); + return scm_slot_ref (obj, scm_str2symbol ("name")); } SCM_PROC (s_class_direct_supers, "class-direct-supers", 1, 0, 0, scm_class_direct_supers); @@ -832,7 +827,7 @@ SCM scm_class_direct_supers (SCM obj) { SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), obj, SCM_ARG1, s_class_direct_supers); - return scm_slot_ref (obj, Intern("direct-supers")); + return scm_slot_ref (obj, scm_str2symbol ("direct-supers")); } SCM_PROC (s_class_direct_slots, "class-direct-slots", 1, 0, 0, scm_class_direct_slots); @@ -842,7 +837,7 @@ scm_class_direct_slots (SCM obj) { SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), obj, SCM_ARG1, s_class_direct_slots); - return scm_slot_ref (obj, Intern ("direct-slots")); + return scm_slot_ref (obj, scm_str2symbol ("direct-slots")); } SCM_PROC (s_class_direct_subclasses, "class-direct-subclasses", 1, 0, 0, scm_class_direct_subclasses); @@ -852,7 +847,7 @@ scm_class_direct_subclasses (SCM obj) { SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), obj, SCM_ARG1, s_class_direct_subclasses); - return scm_slot_ref(obj, Intern ("direct-subclasses")); + return scm_slot_ref(obj, scm_str2symbol ("direct-subclasses")); } SCM_PROC (s_class_direct_methods, "class-direct-methods", 1, 0, 0, scm_class_direct_methods); @@ -862,7 +857,7 @@ scm_class_direct_methods (SCM obj) { SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), obj, SCM_ARG1, s_class_direct_methods); - return scm_slot_ref (obj, Intern("direct-methods")); + return scm_slot_ref (obj, scm_str2symbol ("direct-methods")); } SCM_PROC (s_class_direct_precedence_list, "class-precedence-list", 1, 0, 0, scm_class_precedence_list); @@ -872,7 +867,7 @@ scm_class_precedence_list (SCM obj) { SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), obj, SCM_ARG1, s_class_direct_precedence_list); - return scm_slot_ref (obj, Intern ("cpl")); + return scm_slot_ref (obj, scm_str2symbol ("cpl")); } SCM_PROC (s_class_slots, "class-slots", 1, 0, 0, scm_class_slots); @@ -882,7 +877,7 @@ scm_class_slots (SCM obj) { SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), obj, SCM_ARG1, s_class_slots); - return scm_slot_ref (obj, Intern ("slots")); + return scm_slot_ref (obj, scm_str2symbol ("slots")); } SCM_PROC (s_class_environment, "class-environment", 1, 0, 0, scm_class_environment); @@ -892,7 +887,7 @@ scm_class_environment (SCM obj) { SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), obj, SCM_ARG1, s_class_environment); - return scm_slot_ref(obj, Intern ("environment")); + return scm_slot_ref(obj, scm_str2symbol ("environment")); } @@ -913,7 +908,7 @@ scm_generic_function_methods (SCM obj) { SCM_ASSERT (SCM_NIMP (obj) && GENERICP (obj), obj, SCM_ARG1, s_generic_function_methods); - return scm_slot_ref (obj, Intern ("methods")); + return scm_slot_ref (obj, scm_str2symbol ("methods")); } @@ -924,7 +919,7 @@ scm_method_generic_function (SCM obj) { SCM_ASSERT (SCM_NIMP (obj) && METHODP (obj), obj, SCM_ARG1, s_method_generic_function); - return scm_slot_ref (obj, Intern ("generic-function")); + return scm_slot_ref (obj, scm_str2symbol ("generic-function")); } SCM_PROC (s_method_specializers, "method-specializers", 1, 0, 0, scm_method_specializers); @@ -934,7 +929,7 @@ scm_method_specializers (SCM obj) { SCM_ASSERT (SCM_NIMP (obj) && METHODP (obj), obj, SCM_ARG1, s_method_specializers); - return scm_slot_ref (obj, Intern ("specializers")); + return scm_slot_ref (obj, scm_str2symbol ("specializers")); } SCM_PROC (s_method_procedure, "method-procedure", 1, 0, 0, scm_method_procedure); @@ -944,7 +939,7 @@ scm_method_procedure (SCM obj) { SCM_ASSERT (SCM_NIMP (obj) && METHODP (obj), obj, SCM_ARG1, s_method_procedure); - return scm_slot_ref (obj, Intern ("procedure")); + return scm_slot_ref (obj, scm_str2symbol ("procedure")); } SCM_PROC (s_accessor_method_slot_definition, "accessor-method-slot-definition", 1, 0, 0, scm_accessor_method_slot_definition); @@ -954,7 +949,7 @@ scm_accessor_method_slot_definition (SCM obj) { SCM_ASSERT (SCM_NIMP (obj) && SCM_ACCESSORP (obj), obj, SCM_ARG1, s_method_procedure); - return scm_slot_ref (obj, Intern ("slot-definition")); + return scm_slot_ref (obj, scm_str2symbol ("slot-definition")); } @@ -1529,7 +1524,7 @@ go_to_heaven (void *o) static SCM purgatory (void *args) { - return scm_apply (GETVAR (Intern ("change-class")), (SCM) args, SCM_EOL); + return scm_apply (GETVAR (scm_str2symbol ("change-class")), (SCM) args, SCM_EOL); } void @@ -2064,7 +2059,7 @@ scm_make (SCM args) scm_i_get_keyword (k_name, args, len - 1, - Intern ("???"), + scm_str2symbol ("???"), s_make); SCM_SLOT (z, scm_si_direct_supers) = scm_i_get_keyword (k_dsupers, @@ -2142,7 +2137,7 @@ scm_sys_method_more_specific_p (SCM m1, SCM m2, SCM targs) static void make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots) { - SCM tmp = Intern(name); + SCM tmp = scm_str2symbol (name); *var = scm_permanent_object (scm_basic_make_class (meta, tmp, @@ -2160,26 +2155,26 @@ static void create_standard_classes (void) { SCM slots; - SCM method_slots = SCM_LIST4 (Intern ("generic-function"), - Intern ("specializers"), - Intern ("procedure"), - Intern ("code-table")); - SCM amethod_slots = SCM_LIST1 (SCM_LIST3 (Intern ("slot-definition"), + SCM method_slots = SCM_LIST4 (scm_str2symbol ("generic-function"), + scm_str2symbol ("specializers"), + scm_str2symbol ("procedure"), + scm_str2symbol ("code-table")); + SCM amethod_slots = SCM_LIST1 (SCM_LIST3 (scm_str2symbol ("slot-definition"), k_init_keyword, k_slot_definition)); #ifdef USE_THREADS - SCM mutex_slot = SCM_LIST1 (Intern ("make-mutex")); + SCM mutex_slot = SCM_LIST1 (scm_str2symbol ("make-mutex")); #else SCM mutex_slot = SCM_BOOL_F; #endif - SCM gf_slots = SCM_LIST4 (Intern ("methods"), - SCM_LIST3 (Intern ("n-specialized"), + SCM gf_slots = SCM_LIST4 (scm_str2symbol ("methods"), + SCM_LIST3 (scm_str2symbol ("n-specialized"), k_init_value, SCM_INUM0), - SCM_LIST3 (Intern ("used-by"), + SCM_LIST3 (scm_str2symbol ("used-by"), k_init_value, SCM_BOOL_F), - SCM_LIST3 (Intern ("cache-mutex"), + SCM_LIST3 (scm_str2symbol ("cache-mutex"), k_init_thunk, scm_closure (SCM_LIST2 (SCM_EOL, mutex_slot), @@ -2225,10 +2220,10 @@ create_standard_classes (void) make_stdcls (&scm_class_foreign_class, "", scm_class_class, scm_class_class, - SCM_LIST2 (SCM_LIST3 (Intern ("constructor"), + SCM_LIST2 (SCM_LIST3 (scm_str2symbol ("constructor"), k_class, scm_class_opaque), - SCM_LIST3 (Intern ("destructor"), + SCM_LIST3 (scm_str2symbol ("destructor"), k_class, scm_class_opaque))); make_stdcls (&scm_class_foreign_object, "", @@ -2336,7 +2331,7 @@ make_class_from_template (char *template, char *type_name, SCM supers) { char buffer[100]; sprintf (buffer, template, type_name); - name = Intern (buffer); + name = scm_str2symbol (buffer); } else name = SCM_GOOPS_UNBOUND; @@ -2481,7 +2476,7 @@ scm_make_class (SCM meta, char *s_name, SCM supers, size_t size, size_t (*destructor) (void *)) { SCM name, class; - name = Intern (s_name); + name = scm_str2symbol (s_name); if (SCM_IMP (supers)) supers = SCM_LIST1 (scm_class_foreign_object); class = scm_basic_basic_make_class (meta, name, supers, SCM_EOL); @@ -2498,7 +2493,7 @@ scm_make_class (SCM meta, char *s_name, SCM supers, size_t size, SCM_SET_CLASS_INSTANCE_SIZE (class, size); } - SCM_SLOT (class, scm_si_layout) = SCM_CAR (scm_intern ("", 0)); + SCM_SLOT (class, scm_si_layout) = scm_str2symbol (""); SCM_SLOT (class, scm_si_constructor) = (SCM) constructor; return class; @@ -2534,8 +2529,8 @@ scm_add_slot (SCM class, char *slot_name, SCM slot_class, SCM_LIST3 (set, sym_o, sym_x)), SCM_EOL); { - SCM name = SCM_CAR (scm_intern0 (slot_name)); - SCM aname = SCM_CAR (scm_intern0 (accessor_name)); + SCM name = scm_str2symbol (slot_name); + SCM aname = scm_str2symbol (accessor_name); SCM gf = scm_ensure_accessor (aname); SCM slot = SCM_LIST5 (name, k_class, slot_class, @@ -2692,7 +2687,7 @@ scm_init_goops (void) create_port_classes (); { - SCM name = SCM_CAR (scm_intern0 ("no-applicable-method")); + SCM name = scm_str2symbol ("no-applicable-method"); scm_no_applicable_method = scm_permanent_object (scm_make (SCM_LIST3 (scm_class_generic, k_name, diff --git a/libguile/load.c b/libguile/load.c index 162d338d4..fee5e1893 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -496,7 +496,7 @@ init_build_info () unsigned int i; for (i = 0; i < (sizeof (info) / sizeof (info[0])); i++) - *loc = scm_acons (SCM_CAR (scm_intern0 (info[i].name)), + *loc = scm_acons (scm_str2symbol (info[i].name), scm_makfrom0str (info[i].value), *loc); } diff --git a/libguile/print.c b/libguile/print.c index 6ec1f11d7..64dc6657e 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1138,7 +1138,7 @@ scm_init_print () vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL); layout = scm_make_struct_layout (scm_makfrom0str (SCM_PRINT_STATE_LAYOUT)); type = scm_make_struct (vtable, SCM_INUM0, SCM_LIST1 (layout)); - scm_set_struct_vtable_name_x (type, SCM_CAR (scm_intern0 ("print-state"))); + scm_set_struct_vtable_name_x (type, scm_str2symbol ("print-state")); print_state_pool = scm_permanent_object (scm_cons (type, SCM_EOL)); scm_print_state_vtable = type; diff --git a/libguile/ramap.c b/libguile/ramap.c index b360dee29..1db100b0d 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -2038,7 +2038,7 @@ static void init_raprocs (ra_iproc *subra) { for (; subra->name; subra++) - subra->sproc = SCM_CDR (scm_intern (subra->name, strlen (subra->name))); + subra->sproc = scm_symbol_binding (SCM_BOOL_F, scm_str2symbol (subra->name)); } diff --git a/libguile/read.c b/libguile/read.c index 8b23fb4bd..d3babdcca 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -381,8 +381,7 @@ tryagain_no_flush_ws: case '{': j = scm_read_token (c, tok_buf, port, 1); - p = scm_intern (SCM_STRING_CHARS (*tok_buf), j); - return SCM_CAR (p); + return scm_mem2symbol (SCM_STRING_CHARS (*tok_buf), j); case '\\': c = scm_getc (port); @@ -404,8 +403,8 @@ tryagain_no_flush_ws: /* #:SYMBOL is a syntax for keywords supported in all contexts. */ case ':': j = scm_read_token ('-', tok_buf, port, 0); - p = scm_intern (SCM_STRING_CHARS (*tok_buf), j); - return scm_make_keyword_from_dash_symbol (SCM_CAR (p)); + p = scm_mem2symbol (SCM_STRING_CHARS (*tok_buf), j); + return scm_make_keyword_from_dash_symbol (p); default: callshrp: @@ -509,8 +508,8 @@ tryagain_no_flush_ws: if (SCM_EQ_P (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_prefix)) { j = scm_read_token ('-', tok_buf, port, 0); - p = scm_intern (SCM_STRING_CHARS (*tok_buf), j); - return scm_make_keyword_from_dash_symbol (SCM_CAR (p)); + p = scm_mem2symbol (SCM_STRING_CHARS (*tok_buf), j); + return scm_make_keyword_from_dash_symbol (p); } /* fallthrough */ default: @@ -518,8 +517,7 @@ tryagain_no_flush_ws: /* fallthrough */ tok: - p = scm_intern (SCM_STRING_CHARS (*tok_buf), j); - return SCM_CAR (p); + return scm_mem2symbol (SCM_STRING_CHARS (*tok_buf), j); } } diff --git a/libguile/snarf.h b/libguile/snarf.h index 95371244f..e3d2d331d 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -153,11 +153,11 @@ SCM_SNARF_INIT(scm_make_synt (RANAME, TYPE, CFN)) #define SCM_SYMBOL(c_name, scheme_name) \ SCM_SNARF_HERE(static SCM c_name) \ -SCM_SNARF_INIT(c_name = scm_permanent_object (SCM_CAR (scm_intern0 (scheme_name)))) +SCM_SNARF_INIT(c_name = scm_permanent_object (scm_str2symbol (scheme_name))) #define SCM_GLOBAL_SYMBOL(c_name, scheme_name) \ SCM_SNARF_HERE(SCM c_name) \ -SCM_SNARF_INIT(c_name = scm_permanent_object (SCM_CAR (scm_intern0 (scheme_name)))) +SCM_SNARF_INIT(c_name = scm_permanent_object (scm_str2symbol (scheme_name))) #define SCM_KEYWORD(c_name, scheme_name) \ SCM_SNARF_HERE(static SCM c_name) \ diff --git a/libguile/stacks.c b/libguile/stacks.c index e3de7eb23..5cfa4ca90 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -741,8 +741,7 @@ scm_init_stacks () = scm_permanent_object (scm_make_struct (vtable, SCM_INUM0, scm_cons (stack_layout, SCM_EOL))); - scm_set_struct_vtable_name_x (scm_stack_type, - SCM_CAR (scm_intern0 ("stack"))); + scm_set_struct_vtable_name_x (scm_stack_type, scm_str2symbol ("stack")); #ifndef SCM_MAGIC_SNARFER #include "libguile/stacks.x" #endif diff --git a/libguile/struct.c b/libguile/struct.c index 56de9c5c0..5c533f172 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -138,7 +138,7 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, } #endif } - new_sym = SCM_CAR (scm_intern_obarray (field_desc, len, SCM_BOOL_F)); + new_sym = scm_mem2symbol (field_desc, len); } return scm_return_first (new_sym, fields); } diff --git a/libguile/symbols.c b/libguile/symbols.c index 42e4d2900..a50c57367 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -125,7 +125,7 @@ scm_sym2vcell (SCM sym, SCM thunk, SCM definep) else if (SCM_VARIABLEP (var)) return SCM_VARVCELL (var); else - scm_wta (sym, "strangely interned symbol? ", ""); + return scm_wta (sym, "strangely interned symbol? ", ""); } else { @@ -402,7 +402,7 @@ scm_sysintern0 (const char *name) if (scm_module_system_booted_p && SCM_NIMP (lookup_proc = SCM_TOP_LEVEL_LOOKUP_CLOSURE)) { - SCM sym = SCM_CAR (scm_intern0 (name)); + SCM sym = scm_str2symbol (name); SCM vcell = scm_sym2vcell (sym, lookup_proc, SCM_BOOL_T); if (SCM_FALSEP (vcell)) scm_misc_error ("sysintern0", "can't define variable", sym); @@ -499,13 +499,8 @@ SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0, "@end format") #define FUNC_NAME s_scm_string_to_symbol { - SCM vcell; - SCM answer; - - SCM_VALIDATE_STRING (1,s); - vcell = scm_intern (SCM_STRING_CHARS (s), SCM_STRING_LENGTH (s)); - answer = SCM_CAR (vcell); - return answer; + SCM_VALIDATE_STRING (1, s); + return scm_mem2symbol (SCM_STRING_CHARS (s), SCM_STRING_LENGTH (s)); } #undef FUNC_NAME @@ -846,7 +841,7 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, } { int n_digits = scm_iint2str (gensym_counter++, 10, &name[len]); - SCM res = SCM_CAR (scm_intern (name, len + n_digits)); + SCM res = scm_mem2symbol (name, len + n_digits); if (name != buf) scm_must_free (name); return res; diff --git a/libguile/throw.c b/libguile/throw.c index d0abcb8a0..ebd2a2bfe 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -479,7 +479,7 @@ handler_message (void *handler_data, SCM tag, SCM args) SCM scm_handle_by_message (void *handler_data, SCM tag, SCM args) { - if (SCM_NFALSEP (scm_eq_p (tag, SCM_CAR (scm_intern0 ("quit"))))) + if (SCM_NFALSEP (scm_eq_p (tag, scm_str2symbol ("quit")))) { exit (scm_exit_status (args)); } diff --git a/libguile/unif.c b/libguile/unif.c index 4eccbc338..0d13c46e4 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -2523,10 +2523,10 @@ loop: case scm_tc7_ivect: return SCM_MAKINUM (-1L); case scm_tc7_svect: - return SCM_CDR (scm_intern ("s", 1)); + return scm_str2symbol ("s"); #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: - return SCM_CDR (scm_intern ("l", 1)); + return scm_str2symbol ("l"); #endif case scm_tc7_fvect: return scm_make_real (1.0); From e841c3e0c006a4c80d873f93cb512f0ec71a5705 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 8 Dec 2000 17:32:56 +0000 Subject: [PATCH 0413/2047] Smob-related creanup. --- libguile/ChangeLog | 142 +++++++++++++++++++++++++++++++++++++++ libguile/arbiters.c | 9 +-- libguile/async.c | 11 ++- libguile/continuations.c | 10 +-- libguile/continuations.h | 3 +- libguile/debug.c | 18 ++--- libguile/debug.h | 17 +++-- libguile/dynl.c | 13 ++-- libguile/dynwind.c | 10 +-- libguile/environments.c | 80 ++++++++++------------ libguile/environments.h | 4 +- libguile/eval.c | 8 +-- libguile/eval.h | 2 +- libguile/filesys.c | 7 +- libguile/filesys.h | 2 +- libguile/fluids.c | 8 +-- libguile/fluids.h | 2 +- libguile/fports.c | 4 +- libguile/guardians.c | 2 +- libguile/hooks.c | 7 +- libguile/hooks.h | 10 +-- libguile/keywords.c | 11 +-- libguile/keywords.h | 3 +- libguile/macros.c | 10 +-- libguile/macros.h | 2 +- libguile/mallocs.c | 16 ++--- libguile/mallocs.h | 2 +- libguile/modules.c | 10 +-- libguile/modules.h | 5 +- libguile/ports.c | 2 +- libguile/print.c | 6 +- libguile/print.h | 6 +- libguile/random.c | 8 +-- libguile/random.h | 6 +- libguile/regex-posix.c | 8 +-- libguile/regex-posix.h | 2 +- libguile/root.c | 10 +-- libguile/root.h | 4 +- libguile/smob.c | 29 ++++---- libguile/smob.h | 3 +- libguile/srcprop.c | 15 +++-- libguile/srcprop.h | 4 +- libguile/tags.h | 2 + libguile/threads.c | 8 +-- libguile/threads.h | 16 ++--- libguile/throw.c | 40 +++++------ libguile/unif.c | 16 ++--- libguile/unif.h | 4 +- libguile/validate.h | 4 +- libguile/variable.c | 21 +++--- libguile/variable.h | 2 +- 51 files changed, 385 insertions(+), 259 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 94f730661..37d79f592 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,145 @@ +2000-12-08 Keisuke Nishida + + * tags.h (SCM_TYP16_PREDICATE): New macro. + * arbiters.c (scm_tc16_arbiter): Typed as scm_bits_t. + (arbiter_print): Renamed from prinarb. + (scm_init_arbiters): Don't use scm_make_smob_type_mfpe. + * async.c (tc16_async): Typed as scm_bits_t. + (SCM_ASYNCP): Use SCM_TYP16_PREDICATE. + (async_mark): Renamed from mark_async. + (scm_init_async): Updated. + * continuations.h (SCM_CONTINUATIONP): Use SCM_TYP16_PREDICATE. + * debug.c (scm_tc16_memoized, scm_tc16_debugobj): Typed as scm_bits_t. + (memoized_print): Renamed from prinmemoized. + (debugobj_print): Renamed from prindebugobj. + (scm_init_debug): Don't use scm_make_smob_type_mfpe. + * debug.h (scm_tc16_memoized, scm_tc16_debugobj): Typed as scm_bits_t. + (SCM_DEBUGOBJP, SCM_MEMOIZEDP): Use SCM_TYP16_PREDICATE. + * dynl.c (scm_tc16_dynamic_obj): Typed as scm_bits_t. + (dynl_obj_mark): Renamed from mark_dynl_obj. + (dynl_obj_print): Renamed from print_dynl_obj. + (scm_dynamic_object_p): Use SCM_TYP16_PREDICATE. + (scm_init_dynamic_linking): Updated. + * dynwind.c (SCM_GUARDSP): Use SCM_TYP16_PREDICATE. + (tc16_guards): Typed as scm_bits_t. + (guards_print): Renamed from printguards. + (scm_init_dynwind): Don't use scm_make_smob_type_mfpe. + * environments.c (scm_tc16_environment, scm_tc16_observer): + Typed as scm_bits_t. + (environment_mark, environment_free, environment_print, + observer_mark, observer_print, leaf_environment_mark, + leaf_environment_free, leaf_environment_print, + eval_environment_mark, eval_environment_free, + eval_environment_print, import_environment_mark, + import_environment_free, import_environment_print, + export_environment_mark, export_environment_free, + export_environment_print): Renamed from mark_environment, + free_environment, print_environment, mark_observer, + print_observer, mark_leaf_environment, free_leaf_environment, + print_leaf_environment, mark_eval_environment, + free_eval_environment, print_eval_environment, + mark_import_environment, free_import_environment, + print_import_environment, mark_export_environment, + free_export_environment, and print_export_environment, respectively. + (free_observer): Removed. + (leaf_environment_funcs, eval_environment_funcs, + import_environment_funcs, export_environment_funcs, + scm_environments_prehistory): Updated. + * environments.h (scm_tc16_environment, scm_tc16_observer): + Typed as scm_bits_t. + * eval.c (scm_tc16_promise): Typed as scm_bits_t. + (promise_print): Renamed from prinprom. + (scm_promise_p): Use SCM_TYP16_PREDICATE. + (scm_init_eval): Updated. + * eval.h (scm_tc16_promise): Typed as scm_bits_t. + * filesys.c (scm_tc16_dir): Typed as scm_bits_t. + (scm_init_filesys): Don't use scm_make_smob_type_mfpe. + * filesys.h (scm_tc16_dir): Typed as scm_bits_t. + * fluids.c (scm_tc16_fluid): Typed as scm_bits_t. + (fluid_print): Renamed from print_fluid. + (scm_init_fluids): Don't use scm_make_smob_type_mfpe. + * fluids.h (scm_tc16_fluid): Typed as scm_bits_t. + * fports.c (fport_print): Renamed from prinfport. + (scm_make_fptob): Updated. + * guardians.c (tc16_guardian): Typed as scm_bits_t. + * hooks.c (scm_tc16_hook): Typed as scm_bits_t. + (hook_print): Renamed from print_hook. + (scm_init_hooks): Updated. + * hooks.h (scm_tc16_hook): Typed as scm_bits_t. + (SCM_HOOKP): Use SCM_TYP16_PREDICATE. + * keywords.c (scm_tc16_keyword): Typed as scm_bits_t. + (keyword_print): Renamed from prin_keyword. + (scm_init_keywords): Don't use scm_make_smob_type_mfpe. + * keywords.h (scm_tc16_keyword): Typed as scm_bits_t. + * macros.c (scm_tc16_macro): Typed as scm_bits_t. + (scm_macro_p, scm_macro_type): Use SCM_TYP16_PREDICATE. + (scm_init_macros): Don't use scm_make_smob_type_mfpe. + * macros.h (scm_tc16_macro): Typed as scm_bits_t. + * mallocs.c (scm_tc16_malloc): Typed as scm_bits_t. + (malloc_free): Renamed from fmalloc. + (malloc_print): Renamed from prinmalloc. + (scm_init_mallocs): Don't use scm_make_smob_type_mfpe. + * mallocs.h (scm_tc16_malloc): Typed as scm_bits_t. + * modules.h (SCM_EVAL_CLOSURE_P): Use SCM_TYP16_PREDICATE. + (scm_tc16_eval_closure): Renamed from scm_eval_closure_tag. + (scm_standard_eval_closure, scm_init_modules): Updated. + * ports.c (scm_tc16_void_port): Typed as scm_bits_t. + * print.c (scm_tc16_port_with_ps): Typed as scm_bits_t. + (port_with_ps_print): Renamed from print_port_with_ps. + (scm_init_print): Updated. + * print.h (scm_tc16_port_with_ps): Typed as scm_bits_t. + (SCM_PORT_WITH_PS_P): Use SCM_TYP16_PREDICATE. + * random.c (scm_tc16_rstate): Typed as scm_bits_t. + (rstate_free): Renamed from free_rstate. + (scm_init_random): Don't use scm_make_smob_type_mfpe. + * random.h (scm_tc16_rstate): Typed as scm_bits_t. + (SCM_RSTATEP): Use SCM_TYP16_PREDICATE. + * regex-posix.c (scm_tc16_regex): Typed as scm_bits_t. + (regex_free): Renamed from free_regex. + (scm_init_regex_posix): Don't use scm_make_smob_type_mfpe. + * regex-posix.h (scm_tc16_regex): Typed as scm_bits_t. + * root.c (scm_tc16_root): Typed as scm_bits_t. + (root_mark): Renamed from mark_root. + (root_print): Renamed from print_root. + (scm_init_root): Updated. + * root.h (scm_tc16_root): Typed as scm_bits_t. + (SCM_ROOTP): Use SCM_TYP16_PREDICATE. + * smob.c (free_print): Renamed from freeprint. + (scm_smob_prehistory): Don't use scm_make_smob_type_mfpe. + * smob.h (SCM_SMOB_PREDICATE): Use SCM_TYP16_PREDICATE. + * srcprop.c (scm_tc16_srcprops): Typed as scm_bits_t. + (srcprops_mark): Renamed from marksrcprops. + (srcprops_free): Renamed from freesrcprops. + (srcprops_print): Renamed from prinsrcprops. + (scm_init_srcprop): Don't use scm_make_smob_type_mfpe. + * srcprop.h (scm_tc16_srcprops): Typed as scm_bits_t. + (SRCPROPSP): Use SCM_TYP16_PREDICATE. + * threads.c (scm_tc16_thread, scm_tc16_mutex, scm_tc16_condvar): + Typed as scm_bits_t. + * threads.h (scm_tc16_thread, scm_tc16_mutex, scm_tc16_condvar): + Typed as scm_bits_t. + (SCM_THREADP, SCM_MUTEXP, SCM_CONDVARP): Use SCM_TYP16_PREDICATE. + * throw.c (tc16_jmpbuffer): Renamed from scm_tc16_jmpbuffer. + (make_jmpbuf): Updated. + (tc16_lazy_catch): Typed as scm_bits_t. + (SCM_JMPBUFP, SCM_LAZY_CATCH_P): Use SCM_TYP16_PREDICATE. + (jmpbuffer_print): Renamed from printjb. + (lazy_catch_print): Renamed from print_lazy_catch. + (scm_init_throw): Don't use scm_make_smob_type_mfpe. + * unif.c (scm_tc16_array): Typed as scm_bits_t. + (array_mark): Renamed from markra. + (array_free): Renamed from freera. + (scm_init_unif): Don't use scm_make_smob_type_mfpe. + * unif.h (scm_tc16_array): Typed as scm_bits_t. + (SCM_ARRAYP): Use SCM_TYP16_PREDICATE. + * validate.h (SCM_VALIDATE_SMOB): Use SCM_TYP16_PREDICATE. + * variable.c (scm_tc16_variable): Typed as scm_bits_t. + (variable_print): Renamed from prin_var. + (variable_equalp): Renamed from var_equal. + (scm_markvar): Removed. + (scm_init_variable): Don't use scm_make_smob_type_mfpe. + * variable.h (scm_tc16_variable): Typed as scm_bits_t. + 2000-12-08 Dirk Herrmann * feature.c (scm_add_feature), gh_data.c (gh_symbol2scm), goops.c diff --git a/libguile/arbiters.c b/libguile/arbiters.c index 69e68d7f3..073d80bb6 100644 --- a/libguile/arbiters.c +++ b/libguile/arbiters.c @@ -60,7 +60,7 @@ * SCM_DEFER_INTS). */ -static long scm_tc16_arbiter; +static scm_bits_t scm_tc16_arbiter; #define SCM_ARB_LOCKED(arb) ((SCM_CELL_WORD_0 (arb)) & (1L << 16)) @@ -68,7 +68,7 @@ static long scm_tc16_arbiter; #define SCM_UNLOCK_ARB(arb) (SCM_SET_CELL_WORD_0 ((arb), scm_tc16_arbiter)); static int -prinarb (SCM exp, SCM port, scm_print_state *pstate) +arbiter_print (SCM exp, SCM port, scm_print_state *pstate) { scm_puts ("#> 16) #define SET_ASYNC_GOT_IT(X, V) (SCM_SET_CELL_WORD_0 ((X), SCM_TYP16 (X) | ((V) << 16))) @@ -280,7 +279,7 @@ scm_async_click () static SCM -mark_async (SCM obj) +async_mark (SCM obj) { return ASYNC_THUNK (obj); } @@ -460,7 +459,7 @@ scm_init_async () { scm_asyncs = SCM_EOL; tc16_async = scm_make_smob_type ("async", 0); - scm_set_smob_mark (tc16_async, mark_async); + scm_set_smob_mark (tc16_async, async_mark); #ifndef SCM_MAGIC_SNARFER #include "libguile/async.x" diff --git a/libguile/continuations.c b/libguile/continuations.c index 5ef2219f1..7624f637b 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -66,7 +66,8 @@ scm_bits_t scm_tc16_continuation; -static SCM continuation_mark (SCM obj) +static SCM +continuation_mark (SCM obj) { scm_contregs *continuation = SCM_CONTREGS (obj); @@ -75,7 +76,8 @@ static SCM continuation_mark (SCM obj) return continuation->dynenv; } -static scm_sizet continuation_free (SCM obj) +static scm_sizet +continuation_free (SCM obj) { scm_contregs *continuation = SCM_CONTREGS (obj); /* stack array size is 1 if num_stack_items is 0 (rootcont). */ @@ -89,7 +91,8 @@ static scm_sizet continuation_free (SCM obj) return bytes_free; } -static int continuation_print (SCM obj, SCM port, scm_print_state *state) +static int +continuation_print (SCM obj, SCM port, scm_print_state *state) { scm_contregs *continuation = SCM_CONTREGS (obj); @@ -243,7 +246,6 @@ scm_init_continuations () scm_set_smob_free (scm_tc16_continuation, continuation_free); scm_set_smob_print (scm_tc16_continuation, continuation_print); scm_set_smob_apply (scm_tc16_continuation, continuation_apply, 0, 0, 1); - #ifndef SCM_MAGIC_SNARFER #include "libguile/continuations.x" #endif diff --git a/libguile/continuations.h b/libguile/continuations.h index ba87a3f27..adc962976 100644 --- a/libguile/continuations.h +++ b/libguile/continuations.h @@ -74,8 +74,7 @@ typedef struct SCM_STACKITEM stack[1]; /* copied stack of size num_stack_items. */ } scm_contregs; -#define SCM_CONTINUATIONP(x)\ - (SCM_NIMP (x) && (SCM_TYP16 (x) == scm_tc16_continuation)) +#define SCM_CONTINUATIONP(x) SCM_TYP16_PREDICATE (scm_tc16_continuation, x) #define SCM_CONTREGS(x) ((scm_contregs *) SCM_CELL_WORD_1 (x)) diff --git a/libguile/debug.c b/libguile/debug.c index f530c3f66..946306db1 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -144,11 +144,10 @@ static SCM scm_sym_procname; /* {Memoized Source} */ -long scm_tc16_memoized; - +scm_bits_t scm_tc16_memoized; static int -prinmemoized (SCM obj,SCM port,scm_print_state *pstate) +memoized_print (SCM obj, SCM port, scm_print_state *pstate) { int writingp = SCM_WRITINGP (pstate); scm_puts ("#mark)) (env); } static scm_sizet -free_environment (SCM env) +environment_free (SCM env) { return (*(SCM_ENVIRONMENT_FUNCS (env)->free)) (env); } static int -print_environment (SCM env, SCM port, scm_print_state *pstate) +environment_print (SCM env, SCM port, scm_print_state *pstate) { return (*(SCM_ENVIRONMENT_FUNCS (env)->print)) (env, port, pstate); } @@ -477,7 +477,7 @@ print_environment (SCM env, SCM port, scm_print_state *pstate) /* observers */ static SCM -mark_observer (SCM observer) +observer_mark (SCM observer) { scm_gc_mark (SCM_OBSERVER_ENVIRONMENT (observer)); scm_gc_mark (SCM_OBSERVER_DATA (observer)); @@ -485,15 +485,8 @@ mark_observer (SCM observer) } -static scm_sizet -free_observer (SCM observer_smob) -{ - return 0; -} - - static int -print_observer (SCM type, SCM port, scm_print_state *pstate) +observer_print (SCM type, SCM port, scm_print_state *pstate) { SCM address = scm_ulong2num (SCM_UNPACK (type)); SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16)); @@ -971,7 +964,7 @@ leaf_environment_cell(SCM env, SCM sym, int for_write) static SCM -mark_leaf_environment (SCM env) +leaf_environment_mark (SCM env) { scm_gc_mark (LEAF_ENVIRONMENT (env)->obarray); return core_environments_mark (env); @@ -979,7 +972,7 @@ mark_leaf_environment (SCM env) static scm_sizet -free_leaf_environment (SCM env) +leaf_environment_free (SCM env) { core_environments_finalize (env); @@ -989,7 +982,7 @@ free_leaf_environment (SCM env) static int -print_leaf_environment (SCM type, SCM port, scm_print_state *pstate) +leaf_environment_print (SCM type, SCM port, scm_print_state *pstate) { SCM address = scm_ulong2num (SCM_UNPACK (type)); SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16)); @@ -1011,9 +1004,9 @@ static struct scm_environment_funcs leaf_environment_funcs = { leaf_environment_cell, core_environments_observe, core_environments_unobserve, - mark_leaf_environment, - free_leaf_environment, - print_leaf_environment + leaf_environment_mark, + leaf_environment_free, + leaf_environment_print }; @@ -1324,7 +1317,7 @@ eval_environment_cell (SCM env, SCM sym, int for_write) static SCM -mark_eval_environment (SCM env) +eval_environment_mark (SCM env) { struct eval_environment *body = EVAL_ENVIRONMENT (env); @@ -1339,7 +1332,7 @@ mark_eval_environment (SCM env) static scm_sizet -free_eval_environment (SCM env) +eval_environment_free (SCM env) { core_environments_finalize (env); @@ -1349,7 +1342,7 @@ free_eval_environment (SCM env) static int -print_eval_environment (SCM type, SCM port, scm_print_state *pstate) +eval_environment_print (SCM type, SCM port, scm_print_state *pstate) { SCM address = scm_ulong2num (SCM_UNPACK (type)); SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16)); @@ -1371,9 +1364,9 @@ static struct scm_environment_funcs eval_environment_funcs = { eval_environment_cell, core_environments_observe, core_environments_unobserve, - mark_eval_environment, - free_eval_environment, - print_eval_environment + eval_environment_mark, + eval_environment_free, + eval_environment_print }; @@ -1740,7 +1733,7 @@ import_environment_cell (SCM env, SCM sym, int for_write) static SCM -mark_import_environment (SCM env) +import_environment_mark (SCM env) { scm_gc_mark (IMPORT_ENVIRONMENT (env)->imports); scm_gc_mark (IMPORT_ENVIRONMENT (env)->import_observers); @@ -1750,7 +1743,7 @@ mark_import_environment (SCM env) static scm_sizet -free_import_environment (SCM env) +import_environment_free (SCM env) { core_environments_finalize (env); @@ -1760,7 +1753,7 @@ free_import_environment (SCM env) static int -print_import_environment (SCM type, SCM port, scm_print_state *pstate) +import_environment_print (SCM type, SCM port, scm_print_state *pstate) { SCM address = scm_ulong2num (SCM_UNPACK (type)); SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16)); @@ -1782,9 +1775,9 @@ static struct scm_environment_funcs import_environment_funcs = { import_environment_cell, core_environments_observe, core_environments_unobserve, - mark_import_environment, - free_import_environment, - print_import_environment + import_environment_mark, + import_environment_free, + import_environment_print }; @@ -2034,7 +2027,7 @@ export_environment_cell (SCM env, SCM sym, int for_write) static SCM -mark_export_environment (SCM env) +export_environment_mark (SCM env) { struct export_environment *body = EXPORT_ENVIRONMENT (env); @@ -2047,7 +2040,7 @@ mark_export_environment (SCM env) static scm_sizet -free_export_environment (SCM env) +export_environment_free (SCM env) { core_environments_finalize (env); @@ -2057,7 +2050,7 @@ free_export_environment (SCM env) static int -print_export_environment (SCM type, SCM port, scm_print_state *pstate) +export_environment_print (SCM type, SCM port, scm_print_state *pstate) { SCM address = scm_ulong2num (SCM_UNPACK (type)); SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16)); @@ -2079,9 +2072,9 @@ static struct scm_environment_funcs export_environment_funcs = { export_environment_cell, core_environments_observe, core_environments_unobserve, - mark_export_environment, - free_export_environment, - print_export_environment + export_environment_mark, + export_environment_free, + export_environment_print }; @@ -2303,15 +2296,14 @@ scm_environments_prehistory () { /* create environment smob */ scm_tc16_environment = scm_make_smob_type ("environment", 0); - scm_set_smob_mark (scm_tc16_environment, mark_environment); - scm_set_smob_free (scm_tc16_environment, free_environment); - scm_set_smob_print (scm_tc16_environment, print_environment); + scm_set_smob_mark (scm_tc16_environment, environment_mark); + scm_set_smob_free (scm_tc16_environment, environment_free); + scm_set_smob_print (scm_tc16_environment, environment_print); /* create observer smob */ scm_tc16_observer = scm_make_smob_type ("observer", 0); - scm_set_smob_mark (scm_tc16_observer, mark_observer); - scm_set_smob_free (scm_tc16_observer, free_observer); - scm_set_smob_print (scm_tc16_observer, print_observer); + scm_set_smob_mark (scm_tc16_observer, observer_mark); + scm_set_smob_print (scm_tc16_observer, observer_print); } diff --git a/libguile/environments.h b/libguile/environments.h index 9ed5cabc0..4e0d0b054 100644 --- a/libguile/environments.h +++ b/libguile/environments.h @@ -85,7 +85,7 @@ struct scm_environment_funcs { #define SCM_ENVIRONMENT_LOCATION_IMMUTABLE SCM_MAKINUM (1) #define SCM_ENVIRONMENT_LOCATION_NO_CELL SCM_BOOL_F -extern long scm_tc16_environment; +extern scm_bits_t scm_tc16_environment; #define SCM_ENVIRONMENT_P(x) \ (!SCM_IMP (x) && SCM_CELL_TYPE (x) == scm_tc16_environment) @@ -110,7 +110,7 @@ extern long scm_tc16_environment; #define SCM_ENVIRONMENT_UNOBSERVE(env, token) \ ((*(SCM_ENVIRONMENT_FUNCS (env)->unobserve)) (env, token)) -extern long scm_tc16_observer; +extern scm_bits_t scm_tc16_observer; #define SCM_OBSERVER_P(x) \ (!SCM_IMP (x) && (SCM_CELL_TYPE (x) == scm_tc16_observer)) diff --git a/libguile/eval.c b/libguile/eval.c index dbabf73af..4a3b8e12e 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3656,7 +3656,7 @@ scm_closure (SCM code, SCM env) } -long scm_tc16_promise; +scm_bits_t scm_tc16_promise; SCM scm_makprom (SCM code) @@ -3667,7 +3667,7 @@ scm_makprom (SCM code) static int -prinprom (SCM exp,SCM port,scm_print_state *pstate) +promise_print (SCM exp, SCM port, scm_print_state *pstate) { int writingp = SCM_WRITINGP (pstate); scm_puts ("#> 16) -#define SCM_HOOK_PROCEDURES(hook) SCM_CELL_OBJECT_1 (hook) -#define SCM_SET_HOOK_PROCEDURES(hook, procs) SCM_SET_CELL_OBJECT_1 ((hook), (procs)) +extern scm_bits_t scm_tc16_hook; -extern long scm_tc16_hook; +#define SCM_HOOKP(x) SCM_TYP16_PREDICATE (scm_tc16_hook, x) +#define SCM_HOOK_ARITY(hook) (SCM_CELL_WORD_0 (hook) >> 16) +#define SCM_HOOK_PROCEDURES(hook) SCM_CELL_OBJECT_1 (hook) +#define SCM_SET_HOOK_PROCEDURES(hook, procs) SCM_SET_CELL_OBJECT_1 ((hook), (procs)) extern SCM scm_make_hook (SCM n_args); extern SCM scm_create_hook (const char* name, int n_args); diff --git a/libguile/keywords.c b/libguile/keywords.c index 017b6fc51..b8af91c08 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -55,16 +55,16 @@ #include "libguile/keywords.h" +scm_bits_t scm_tc16_keyword; + static int -prin_keyword (SCM exp,SCM port,scm_print_state *pstate) +keyword_print (SCM exp, SCM port, scm_print_state *pstate) { scm_puts ("#:", port); scm_puts(1 + SCM_SYMBOL_CHARS (SCM_CDR (exp)), port); return 1; } -int scm_tc16_keyword; - SCM_DEFINE (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", 1, 0, 0, (SCM symbol), @@ -130,8 +130,9 @@ SCM_DEFINE (scm_keyword_dash_symbol, "keyword-dash-symbol", 1, 0, 0, void scm_init_keywords () { - scm_tc16_keyword = scm_make_smob_type_mfpe ("keyword", 0, - scm_markcdr, NULL, prin_keyword, NULL); + scm_tc16_keyword = scm_make_smob_type ("keyword", 0); + scm_set_smob_mark (scm_tc16_keyword, scm_markcdr); + scm_set_smob_print (scm_tc16_keyword, keyword_print); scm_keyword_obarray = scm_make_vector (SCM_MAKINUM (256), SCM_EOL); #ifndef SCM_MAGIC_SNARFER diff --git a/libguile/keywords.h b/libguile/keywords.h index b4f5d7811..4bac54acc 100644 --- a/libguile/keywords.h +++ b/libguile/keywords.h @@ -51,7 +51,8 @@ -extern int scm_tc16_keyword; +extern scm_bits_t scm_tc16_keyword; + #define SCM_KEYWORDP(X) (!SCM_IMP (X) && (SCM_CELL_TYPE (X) == scm_tc16_keyword)) #define SCM_KEYWORDSYM(X) (SCM_CELL_OBJECT_1 (X)) diff --git a/libguile/macros.c b/libguile/macros.c index 977abd41d..fd6ae53b2 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -51,7 +51,7 @@ #include "libguile/validate.h" #include "libguile/macros.h" -long scm_tc16_macro; +scm_bits_t scm_tc16_macro; SCM_DEFINE (scm_makacro, "procedure->syntax", 1, 0, 0, (SCM code), @@ -116,7 +116,7 @@ SCM_DEFINE (scm_macro_p, "macro?", 1, 0, 0, "syntax transformer.") #define FUNC_NAME s_scm_macro_p { - return SCM_BOOL(SCM_NIMP (obj) && SCM_TYP16 (obj) == scm_tc16_macro); + return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_macro, obj)); } #undef FUNC_NAME @@ -133,7 +133,7 @@ SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0, "@code{#f} is returned.") #define FUNC_NAME s_scm_macro_type { - if (!(SCM_NIMP (m) && SCM_TYP16 (m) == scm_tc16_macro)) + if (!SCM_TYP16_PREDICATE (scm_tc16_macro, m)) return SCM_BOOL_F; switch (SCM_CELL_WORD_0 (m) >> 16) { @@ -179,8 +179,8 @@ scm_make_synt (const char *name, SCM (*macroizer) (), SCM (*fcn)() ) void scm_init_macros () { - scm_tc16_macro = scm_make_smob_type_mfpe ("macro", 0, - scm_markcdr, NULL, NULL, NULL); + scm_tc16_macro = scm_make_smob_type ("macro", 0); + scm_set_smob_mark (scm_tc16_macro, scm_markcdr); #ifndef SCM_MAGIC_SNARFER #include "libguile/macros.x" #endif diff --git a/libguile/macros.h b/libguile/macros.h index 7871be156..af7ee7014 100644 --- a/libguile/macros.h +++ b/libguile/macros.h @@ -50,7 +50,7 @@ #define SCM_ASSYNT(_cond, _arg, _pos, _subr) if(!(_cond))scm_wta(_arg, (char *)_pos, _subr); -extern long scm_tc16_macro; +extern scm_bits_t scm_tc16_macro; extern SCM scm_makacro (SCM code); extern SCM scm_makmacro (SCM code); diff --git a/libguile/mallocs.c b/libguile/mallocs.c index fd58a2f4c..f0f9606c6 100644 --- a/libguile/mallocs.c +++ b/libguile/mallocs.c @@ -38,11 +38,11 @@ - +scm_bits_t scm_tc16_malloc; static scm_sizet -fmalloc(SCM ptr) +malloc_free (SCM ptr) { if (SCM_MALLOCDATA (ptr)) free (SCM_MALLOCDATA (ptr)); @@ -51,7 +51,7 @@ fmalloc(SCM ptr) static int -prinmalloc (SCM exp,SCM port,scm_print_state *pstate) +malloc_print (SCM exp, SCM port, scm_print_state *pstate) { scm_puts("#writingp) #define SCM_SET_WRITINGP(pstate, x) { (pstate)->writingp = (x); } -#define SCM_PORT_WITH_PS_P(p) (SCM_NIMP(p) && (SCM_TYP16 (p) == scm_tc16_port_with_ps)) +#define SCM_PORT_WITH_PS_P(p) SCM_TYP16_PREDICATE (scm_tc16_port_with_ps, p) #define SCM_PORT_WITH_PS_PORT(p) SCM_CADR (p) -#define SCM_PORT_WITH_PS_PS(p) SCM_CDDR (p) +#define SCM_PORT_WITH_PS_PS(p) SCM_CDDR (p) #define SCM_COERCE_OUTPORT(p) (SCM_NIMP (p) && SCM_PORT_WITH_PS_P (p) \ ? SCM_PORT_WITH_PS_PORT (p) \ @@ -101,7 +101,7 @@ typedef struct scm_print_state { extern SCM scm_print_state_vtable; /* ? scm or long? print.h and print.c disagree */ -extern long scm_tc16_port_with_ps; +extern scm_bits_t scm_tc16_port_with_ps; extern SCM scm_print_options (SCM setting); SCM scm_make_print_state (void); diff --git a/libguile/random.c b/libguile/random.c index b33d4e3b8..2e342467e 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -329,7 +329,7 @@ scm_c_random_bignum (scm_rstate *state, SCM m) * Scheme level representation of random states. */ -long scm_tc16_rstate; +scm_bits_t scm_tc16_rstate; static SCM make_rstate (scm_rstate *state) @@ -338,7 +338,7 @@ make_rstate (scm_rstate *state) } static scm_sizet -free_rstate (SCM rstate) +rstate_free (SCM rstate) { free (SCM_RSTATE (rstate)); return scm_the_rng.rstate_size; @@ -577,8 +577,8 @@ scm_init_random () }; scm_the_rng = rng; - scm_tc16_rstate = scm_make_smob_type_mfpe ("random-state", 0, - NULL, free_rstate, NULL, NULL); + scm_tc16_rstate = scm_make_smob_type ("random-state", 0); + scm_set_smob_free (scm_tc16_rstate, rstate_free); for (m = 1; m <= 0x100; m <<= 1) for (i = m >> 1; i < m; ++i) diff --git a/libguile/random.h b/libguile/random.h index 38aba09ff..797bae4a0 100644 --- a/libguile/random.h +++ b/libguile/random.h @@ -108,9 +108,9 @@ extern SCM scm_c_random_bignum (scm_rstate *, SCM m); /* * Scheme level interface */ -extern long scm_tc16_rstate; -#define SCM_RSTATE(obj) ((scm_rstate *) SCM_CELL_WORD_1 (obj)) -#define SCM_RSTATEP(obj) (SCM_NIMP(obj) && (SCM_TYP16 (obj) == scm_tc16_rstate)) +extern scm_bits_t scm_tc16_rstate; +#define SCM_RSTATEP(obj) SCM_TYP16_PREDICATE (scm_tc16_rstate, obj) +#define SCM_RSTATE(obj) ((scm_rstate *) SCM_CELL_WORD_1 (obj)) extern unsigned char scm_masktab[256]; diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index 6866fb071..0abb4b8da 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -92,10 +92,10 @@ #define REG_BASIC 0 #endif -long scm_tc16_regex; +scm_bits_t scm_tc16_regex; static scm_sizet -free_regex (SCM obj) +regex_free (SCM obj) { regfree (SCM_RGX (obj)); free (SCM_RGX (obj)); @@ -280,8 +280,8 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, void scm_init_regex_posix () { - scm_tc16_regex = scm_make_smob_type_mfpe ("regexp", sizeof (regex_t), - NULL, free_regex, NULL, NULL); + scm_tc16_regex = scm_make_smob_type ("regexp", sizeof (regex_t)); + scm_set_smob_free (scm_tc16_regex, regex_free); /* Compilation flags. */ scm_sysintern ("regexp/basic", scm_long2num (REG_BASIC)); diff --git a/libguile/regex-posix.h b/libguile/regex-posix.h index ab979b799..07ff7a147 100644 --- a/libguile/regex-posix.h +++ b/libguile/regex-posix.h @@ -50,7 +50,7 @@ #include "libguile/__scm.h" -extern long scm_tc16_regex; +extern scm_bits_t scm_tc16_regex; #define SCM_RGX(X) ((regex_t *) SCM_CELL_WORD_1 (X)) #define SCM_RGXP(X) (SCM_NIMP (X) && (SCM_CELL_TYPE (X) == scm_tc16_regex)) diff --git a/libguile/root.c b/libguile/root.c index c0c8ebfa6..88ae8b0ca 100644 --- a/libguile/root.c +++ b/libguile/root.c @@ -60,7 +60,7 @@ SCM scm_sys_protects[SCM_NUM_PROTECTS]; -long scm_tc16_root; +scm_bits_t scm_tc16_root; #ifndef USE_THREADS struct scm_root_state *scm_root; @@ -69,7 +69,7 @@ struct scm_root_state *scm_root; static SCM -mark_root (SCM root) +root_mark (SCM root) { scm_root_state *s = SCM_ROOT_STATE (root); @@ -92,7 +92,7 @@ mark_root (SCM root) static int -print_root (SCM exp,SCM port,scm_print_state *pstate) +root_print (SCM exp, SCM port, scm_print_state *pstate) { scm_puts ("# rootcont), 16, port); @@ -428,8 +428,8 @@ void scm_init_root () { scm_tc16_root = scm_make_smob_type ("root", sizeof (struct scm_root_state)); - scm_set_smob_mark (scm_tc16_root, mark_root); - scm_set_smob_print (scm_tc16_root, print_root); + scm_set_smob_mark (scm_tc16_root, root_mark); + scm_set_smob_print (scm_tc16_root, root_print); #ifndef SCM_MAGIC_SNARFER #include "libguile/root.x" diff --git a/libguile/root.h b/libguile/root.h index b06285b62..cc07ec622 100644 --- a/libguile/root.h +++ b/libguile/root.h @@ -82,9 +82,9 @@ extern SCM scm_sys_protects[]; -extern long scm_tc16_root; +extern scm_bits_t scm_tc16_root; -#define SCM_ROOTP(obj) (SCM_NIMP(obj) && (scm_tc16_root == SCM_TYP16 (obj))) +#define SCM_ROOTP(obj) SCM_TYP16_PREDICATE (scm_tc16_root, obj) #define SCM_ROOT_STATE(root) ((scm_root_state *) SCM_CELL_WORD_1 (root)) typedef struct scm_root_state diff --git a/libguile/smob.c b/libguile/smob.c index 5b9a0703c..9c8463250 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -508,38 +508,41 @@ scm_set_smob_mfpe (long tc, */ static int -freeprint (SCM exp, - SCM port, - scm_print_state *pstate) +free_print (SCM exp, SCM port, scm_print_state *pstate) { char buf[100]; - sprintf (buf, "#", (void *) SCM_UNPACK (exp)); + sprintf (buf, "#", + (void *) SCM_UNPACK (exp)); scm_puts (buf, port); return 1; } - void scm_smob_prehistory () { + scm_bits_t tc; + scm_numsmob = 0; scm_smobs = ((scm_smob_descriptor *) malloc (7 * sizeof (scm_smob_descriptor))); /* WARNING: These scm_make_smob_type calls must be done in this order */ - scm_make_smob_type_mfpe ("free", 0, - NULL, NULL, freeprint, NULL); + tc = scm_make_smob_type ("free", 0); + scm_set_smob_print (tc, free_print); - scm_make_smob_type_mfpe ("big", 0, /* freed in gc */ - NULL, NULL, scm_bigprint, scm_bigequal); + tc = scm_make_smob_type ("big", 0); /* freed in gc */ + scm_set_smob_print (tc, scm_bigprint); + scm_set_smob_equalp (tc, scm_bigequal); - scm_make_smob_type_mfpe ("real", 0, /* freed in gc */ - NULL, NULL, scm_print_real, scm_real_equalp); + 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); - scm_make_smob_type_mfpe ("complex", 0, /* freed in gc */ - NULL, NULL, scm_print_complex, scm_complex_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/smob.h b/libguile/smob.h index 878bd62e8..065001b69 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -116,8 +116,7 @@ do { \ #define SCM_SMOBNUM(x) (SCM_TC2SMOBNUM (SCM_CELL_TYPE (x))) /* SCM_SMOBNAME can be 0 if name is missing */ #define SCM_SMOBNAME(smobnum) (scm_smobs[smobnum].name) -#define SCM_SMOB_PREDICATE(tag, obj) (SCM_NIMP (obj) \ - && SCM_TYP16 (obj) == (tag)) +#define SCM_SMOB_PREDICATE(tag, obj) SCM_TYP16_PREDICATE (tag, obj) #define SCM_SMOB_DESCRIPTOR(x) (scm_smobs[SCM_SMOBNUM (x)]) #define SCM_SMOB_APPLICABLE_P(x) (SCM_SMOB_DESCRIPTOR (x).apply) #define SCM_SMOB_APPLY_0(x) (SCM_SMOB_DESCRIPTOR (x).apply_0 (x)) diff --git a/libguile/srcprop.c b/libguile/srcprop.c index ca3907408..7df11f8f2 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -82,13 +82,13 @@ SCM scm_sym_line; SCM scm_sym_column; SCM scm_sym_breakpoint; -long scm_tc16_srcprops; +scm_bits_t scm_tc16_srcprops; static scm_srcprops_chunk *srcprops_chunklist = 0; static scm_srcprops *srcprops_freelist = 0; static SCM -marksrcprops (SCM obj) +srcprops_mark (SCM obj) { scm_gc_mark (SRCPROPFNAME (obj)); scm_gc_mark (SRCPROPCOPY (obj)); @@ -97,7 +97,7 @@ marksrcprops (SCM obj) static scm_sizet -freesrcprops (SCM obj) +srcprops_free (SCM obj) { *((scm_srcprops **) SCM_CELL_WORD_1 (obj)) = srcprops_freelist; srcprops_freelist = (scm_srcprops *) SCM_CELL_WORD_1 (obj); @@ -106,7 +106,7 @@ freesrcprops (SCM obj) static int -prinsrcprops (SCM obj,SCM port,scm_print_state *pstate) +srcprops_print (SCM obj, SCM port, scm_print_state *pstate) { int writingp = SCM_WRITINGP (pstate); scm_puts ("#pos #define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12) diff --git a/libguile/tags.h b/libguile/tags.h index 76fe2fe51..6d4b6ed70 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -323,6 +323,8 @@ typedef long scm_bits_t; #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_NIMP (x) && SCM_TYP16 (x) == (tag)) + #define scm_tc7_symbol 5 diff --git a/libguile/threads.c b/libguile/threads.c index 8bedc5453..85f38ca96 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -71,11 +71,9 @@ -long scm_tc16_thread; - -long scm_tc16_mutex; - -long scm_tc16_condvar; +scm_bits_t scm_tc16_thread; +scm_bits_t scm_tc16_mutex; +scm_bits_t scm_tc16_condvar; /* Scheme-visible thread functions. */ diff --git a/libguile/threads.h b/libguile/threads.h index 8fba1775a..10142feb0 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -55,17 +55,17 @@ /* smob tags for the thread datatypes */ -extern long scm_tc16_thread; -extern long scm_tc16_mutex; -extern long scm_tc16_condvar; +extern scm_bits_t scm_tc16_thread; +extern scm_bits_t scm_tc16_mutex; +extern scm_bits_t scm_tc16_condvar; -#define SCM_THREADP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_thread)) -#define SCM_THREAD_DATA(x) ((void *) SCM_CELL_WORD_1 (x)) +#define SCM_THREADP(x) SCM_TYP16_PREDICATE (scm_tc16_thread, x) +#define SCM_THREAD_DATA(x) ((void *) SCM_CELL_WORD_1 (x)) -#define SCM_MUTEXP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_mutex)) -#define SCM_MUTEX_DATA(x) ((void *) SCM_CELL_WORD_1 (x)) +#define SCM_MUTEXP(x) SCM_TYP16_PREDICATE (scm_tc16_mutex, x)) +#define SCM_MUTEX_DATA(x) ((void *) SCM_CELL_WORD_1 (x)) -#define SCM_CONDVARP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_condvar)) +#define SCM_CONDVARP(x) SCM_TYP16_PREDICATE (scm_tc16_condvar, x) #define SCM_CONDVAR_DATA(x) ((void *) SCM_CELL_WORD_1 (x)) /* Initialize implementation specific details of the threads support */ diff --git a/libguile/throw.c b/libguile/throw.c index ebd2a2bfe..60d5bc9cc 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -66,13 +66,13 @@ /* the jump buffer data structure */ -static int scm_tc16_jmpbuffer; +static scm_bits_t tc16_jmpbuffer; -#define SCM_JMPBUFP(OBJ) (SCM_NIMP(OBJ) && (SCM_TYP16(OBJ) == scm_tc16_jmpbuffer)) +#define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ) -#define JBACTIVE(OBJ) (SCM_CELL_WORD_0 (OBJ) & (1L << 16L)) -#define ACTIVATEJB(OBJ) (SCM_SETOR_CAR (OBJ, (1L << 16L))) -#define DEACTIVATEJB(OBJ) (SCM_SETAND_CAR (OBJ, ~(1L << 16L))) +#define JBACTIVE(OBJ) (SCM_CELL_WORD_0 (OBJ) & (1L << 16L)) +#define ACTIVATEJB(OBJ) (SCM_SETOR_CAR (OBJ, (1L << 16L))) +#define DEACTIVATEJB(OBJ) (SCM_SETAND_CAR (OBJ, ~(1L << 16L))) #define JBJMPBUF(OBJ) ((jmp_buf *) SCM_CELL_WORD_1 (OBJ)) #define SETJBJMPBUF(x,v) (SCM_SET_CELL_WORD_1 ((x), (v))) @@ -82,17 +82,15 @@ static int scm_tc16_jmpbuffer; #endif static int -printjb (SCM exp, SCM port, scm_print_state *pstate) +jmpbuffer_print (SCM exp, SCM port, scm_print_state *pstate) { scm_puts ("#', port); return 1 ; } - static SCM make_jmpbuf (void) { @@ -100,9 +98,9 @@ make_jmpbuf (void) SCM_REDEFER_INTS; { #ifdef DEBUG_EXTENSIONS - SCM_NEWSMOB2 (answer, scm_tc16_jmpbuffer, 0, 0); + SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0); #else - SCM_NEWSMOB (answer, scm_tc16_jmpbuffer, 0); + SCM_NEWSMOB (answer, tc16_jmpbuffer, 0); #endif SETJBJMPBUF(answer, (jmp_buf *)0); DEACTIVATEJB(answer); @@ -218,7 +216,7 @@ scm_internal_catch (SCM tag, scm_catch_body_t body, void *body_data, scm_catch_h /* scm_internal_lazy_catch (the guts of lazy catching) */ /* The smob tag for lazy_catch smobs. */ -static long tc16_lazy_catch; +static scm_bits_t tc16_lazy_catch; /* This is the structure we put on the wind list for a lazy catch. It stores the handler function to call, and the data pointer to pass @@ -238,7 +236,7 @@ struct lazy_catch { appear in normal data structures, only in the wind list. However, it might be nice for debugging someday... */ static int -print_lazy_catch (SCM closure, SCM port, scm_print_state *pstate) +lazy_catch_print (SCM closure, SCM port, scm_print_state *pstate) { struct lazy_catch *c = (struct lazy_catch *) SCM_CELL_WORD_1 (closure); char buf[200]; @@ -260,7 +258,7 @@ make_lazy_catch (struct lazy_catch *c) SCM_RETURN_NEWSMOB (tc16_lazy_catch, c); } -#define SCM_LAZY_CATCH_P(obj) (SCM_SMOB_PREDICATE (tc16_lazy_catch, obj)) +#define SCM_LAZY_CATCH_P(obj) (SCM_TYP16_PREDICATE (tc16_lazy_catch, obj)) /* Exactly like scm_internal_catch, except: @@ -694,18 +692,12 @@ scm_ithrow (SCM key, SCM args, int noreturn) void scm_init_throw () { - scm_tc16_jmpbuffer = scm_make_smob_type_mfpe ("jmpbuffer", - 0, - NULL, /* mark */ - NULL, - printjb, - NULL); + tc16_jmpbuffer = scm_make_smob_type ("jmpbuffer", 0); + scm_set_smob_print (tc16_jmpbuffer, jmpbuffer_print); + + tc16_lazy_catch = scm_make_smob_type ("lazy-catch", 0); + scm_set_smob_print (tc16_lazy_catch, lazy_catch_print); - tc16_lazy_catch = scm_make_smob_type_mfpe ("lazy-catch", 0, - NULL, - NULL, - print_lazy_catch, - NULL); #ifndef SCM_MAGIC_SNARFER #include "libguile/throw.x" #endif diff --git a/libguile/unif.c b/libguile/unif.c index 0d13c46e4..96d1fd472 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -86,7 +86,7 @@ * long long llvect */ -long scm_tc16_array; +scm_bits_t scm_tc16_array; /* return the size of an element in a uniform array or 0 if type not found. */ @@ -2540,14 +2540,14 @@ loop: static SCM -markra (SCM ptr) +array_mark (SCM ptr) { return SCM_ARRAY_V (ptr); } static scm_sizet -freera (SCM ptr) +array_free (SCM ptr) { scm_must_free (SCM_ARRAY_MEM (ptr)); return sizeof (scm_array) + SCM_ARRAY_NDIM (ptr) * sizeof (scm_array_dim); @@ -2556,11 +2556,11 @@ freera (SCM ptr) void scm_init_unif () { - scm_tc16_array = scm_make_smob_type_mfpe ("array", 0, - markra, - freera, - scm_raprin1, - scm_array_equal_p); + scm_tc16_array = scm_make_smob_type ("array", 0); + scm_set_smob_mark (scm_tc16_array, array_mark); + scm_set_smob_free (scm_tc16_array, array_free); + scm_set_smob_print (scm_tc16_array, scm_raprin1); + scm_set_smob_equalp (scm_tc16_array, scm_array_equal_p); scm_add_feature ("array"); #ifndef SCM_MAGIC_SNARFER #include "libguile/unif.x" diff --git a/libguile/unif.h b/libguile/unif.h index 432ac0e11..fd4d0e744 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -75,8 +75,8 @@ typedef struct scm_array_dim } scm_array_dim; -extern long scm_tc16_array; -#define SCM_ARRAYP(a) (SCM_NIMP(a) && (scm_tc16_array == SCM_TYP16(a))) +extern scm_bits_t scm_tc16_array; +#define SCM_ARRAYP(a) SCM_TYP16_PREDICATE (scm_tc16_array, a) #define SCM_ARRAY_NDIM(x) ((scm_sizet) (SCM_CELL_WORD_0 (x) >> 17)) #define SCM_ARRAY_CONTIGUOUS 0x10000 #define SCM_ARRAY_CONTP(x) (SCM_ARRAY_CONTIGUOUS & (SCM_CELL_WORD_0 (x))) diff --git a/libguile/validate.h b/libguile/validate.h index 5250f7645..bab069efe 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -1,4 +1,4 @@ -/* $Id: validate.h,v 1.20 2000-11-22 09:16:06 dirk Exp $ */ +/* $Id: validate.h,v 1.21 2000-12-08 17:32:56 kei Exp $ */ /* Copyright (C) 1999, 2000 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify @@ -283,7 +283,7 @@ #define SCM_VALIDATE_SMOB(pos, obj, type) \ do { \ - SCM_ASSERT ((SCM_NIMP (obj) && SCM_TYP16 (obj) == scm_tc16_ ## type), \ + SCM_ASSERT (SCM_TYP16_PREDICATE (scm_tc16_ ## type, obj), \ obj, pos, FUNC_NAME); \ } while (0) diff --git a/libguile/variable.c b/libguile/variable.c index 304ea009b..163fb8ed2 100644 --- a/libguile/variable.c +++ b/libguile/variable.c @@ -54,9 +54,10 @@ #include "libguile/validate.h" #include "libguile/variable.h" +scm_bits_t scm_tc16_variable; static int -prin_var (SCM exp,SCM port,scm_print_state *pstate) +variable_print (SCM exp, SCM port, scm_print_state *pstate) { scm_puts ("# Date: Fri, 8 Dec 2000 18:10:57 +0000 Subject: [PATCH 0414/2047] Added entries of smob_mfpe and smob_apply --- NEWS | 8 ++++++++ RELEASE | 1 + 2 files changed, 9 insertions(+) diff --git a/NEWS b/NEWS index 75f991117..d12d31c30 100644 --- a/NEWS +++ b/NEWS @@ -360,6 +360,14 @@ scm_tc7_lvector There is now only a single symbol type scm_tc7_symbol. The tag scm_tc7_lvector was not used anyway. +** Deprecated function: scm_make_smob_type_mfpe, scm_set_smob_mfpe. + +Use scm_make_smob_type and scm_set_smob_XXX instead. + +** New function scm_set_smob_apply. + +This can be used to set an apply function to a smob type. + Changes since Guile 1.3.4: diff --git a/RELEASE b/RELEASE index 1e2caf3b3..2a3c6a22d 100644 --- a/RELEASE +++ b/RELEASE @@ -40,6 +40,7 @@ In release 1.6: - remove deprecated functions: eval.c: scm_eval2, scm_eval_3 load.c: scm_read_and_eval_x + smob.c: scm_make_smob_type_mfpe, scm_set_smob_mfpe - remove deprecated procedures: boot-9.scm:eval-in-module - remove deprecated macros: SCM_OUTOFRANGE, SCM_NALLOC, SCM_HUP_SIGNAL, From e325b23886fe2530f39f79f7966e6c1f0298d26b Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 10 Dec 2000 20:34:01 +0000 Subject: [PATCH 0415/2047] * threads.h (SCM_MUTEXP): Typo: removed extra parenthesis. --- libguile/threads.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/threads.h b/libguile/threads.h index 10142feb0..319a6e410 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -62,7 +62,7 @@ extern scm_bits_t scm_tc16_condvar; #define SCM_THREADP(x) SCM_TYP16_PREDICATE (scm_tc16_thread, x) #define SCM_THREAD_DATA(x) ((void *) SCM_CELL_WORD_1 (x)) -#define SCM_MUTEXP(x) SCM_TYP16_PREDICATE (scm_tc16_mutex, x)) +#define SCM_MUTEXP(x) SCM_TYP16_PREDICATE (scm_tc16_mutex, x) #define SCM_MUTEX_DATA(x) ((void *) SCM_CELL_WORD_1 (x)) #define SCM_CONDVARP(x) SCM_TYP16_PREDICATE (scm_tc16_condvar, x) From 24737ba02af8cb63982f50b7df45955b4b375298 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 10 Dec 2000 20:34:12 +0000 Subject: [PATCH 0416/2047] *** empty log message *** --- libguile/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 37d79f592..32e6e7bfe 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2000-12-10 Mikael Djurfeldt + + * threads.h (SCM_MUTEXP): Typo: removed extra parenthesis. + 2000-12-08 Keisuke Nishida * tags.h (SCM_TYP16_PREDICATE): New macro. From 85db4a2c8eead51392bb16ea383526ba1ddfd23f Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 11 Dec 2000 14:48:23 +0000 Subject: [PATCH 0417/2047] * Initialize symbols using SCM_(GLOBAL_)?SYMBOL instead of scm_sysintern... * Use scm_str2symbol instead of scm_sysintern0. * Garbage collection initialization code now within gc.c only. --- libguile/ChangeLog | 27 +++++++++++++++++++++++++ libguile/debug.c | 10 ++++------ libguile/eval.c | 25 +++++++++-------------- libguile/gc.c | 48 ++++++++++++++++++++++++++++----------------- libguile/gc.h | 4 +--- libguile/gsubr.c | 10 +++++++--- libguile/init.c | 22 ++------------------- libguile/keywords.c | 9 ++++++--- libguile/options.c | 12 +++++++++--- libguile/srcprop.c | 18 ++++++----------- libguile/variable.c | 3 +-- 11 files changed, 102 insertions(+), 86 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 32e6e7bfe..4f08f902c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,30 @@ +2000-12-11 Dirk Herrmann + + * debug.c (scm_sym_procname, scm_sym_dots, scm_sym_source, + scm_init_debug), eval.c (scm_sym_dot, scm_sym_arrow, scm_sym_else, + scm_sym_unquote, scm_sym_uq_splicing, scm_sym_enter_frame, + scm_sym_apply_frame, scm_sym_exit_frame, scm_sym_trace, + scm_init_eval), gsubr.c (scm_sym_name, scm_init_gsubr), srcprop.c + (scm_sym_filename, scm_sym_copy, scm_sym_line, scm_sym_column, + scm_sym_breakpoint), variable.c (anonymous_variable_sym): + Initialize symbols by using SCM_(GLOBAL_)?SYMBOL. + + * gc.c (scm_i_getenv_int): Moved here from init.c. + + * gc.[ch] (scm_init_storage): Read gc configuration environment + variables here, not in init.c. + + * init.c (scm_i_getenv_int): Moved to gc.c. + + (scm_init_guile_1): Move configuration code to scm_init_storage. + Make sure procprops get initialized early. + + * keywords.c (scm_c_make_keyword): Report amount of memory freed + by scm_must_free. Use scm_str2symbol instead of scm_sysintern0. + + * options.c (scm_init_opts): Use scm_str2symbol instead of + scm_sysintern0. + 2000-12-10 Mikael Djurfeldt * threads.h (SCM_MUTEXP): Typo: removed extra parenthesis. diff --git a/libguile/debug.c b/libguile/debug.c index 946306db1..d0600ea22 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -138,8 +138,10 @@ SCM_DEFINE (scm_with_traps, "with-traps", 1, 0, 0, #undef FUNC_NAME -static SCM scm_sym_source, scm_sym_dots; -static SCM scm_sym_procname; + +SCM_SYMBOL (scm_sym_procname, "procname"); +SCM_SYMBOL (scm_sym_dots, "..."); +SCM_SYMBOL (scm_sym_source, "source"); /* {Memoized Source} */ @@ -615,10 +617,6 @@ scm_init_debug () scm_tc16_debugobj = scm_make_smob_type ("debug-object", 0); scm_set_smob_print (scm_tc16_debugobj, debugobj_print); - scm_sym_procname = SCM_CAR (scm_sysintern ("procname", SCM_UNDEFINED)); - scm_sym_dots = SCM_CAR (scm_sysintern ("...", SCM_UNDEFINED)); - scm_sym_source = SCM_CAR (scm_sysintern ("source", SCM_UNDEFINED)); - #ifdef GUILE_DEBUG scm_sysintern ("SCM_IM_AND", SCM_IM_AND); scm_sysintern ("SCM_IM_BEGIN", SCM_IM_BEGIN); diff --git a/libguile/eval.c b/libguile/eval.c index 4a3b8e12e..190c06017 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -448,14 +448,19 @@ const char scm_s_variable[] = "bad variable"; const char scm_s_clauses[] = "bad or missing clauses"; const char scm_s_formals[] = "bad formals"; -SCM scm_sym_dot, scm_sym_arrow, scm_sym_else; -SCM scm_sym_unquote, scm_sym_uq_splicing, scm_sym_apply; +SCM_GLOBAL_SYMBOL (scm_sym_dot, "."); +SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>"); +SCM_GLOBAL_SYMBOL (scm_sym_else, "else"); +SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote"); +SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing"); SCM scm_f_apply; #ifdef DEBUG_EXTENSIONS -SCM scm_sym_enter_frame, scm_sym_apply_frame, scm_sym_exit_frame; -SCM scm_sym_trace; +SCM_GLOBAL_SYMBOL (scm_sym_enter_frame, "enter-frame"); +SCM_GLOBAL_SYMBOL (scm_sym_apply_frame, "apply-frame"); +SCM_GLOBAL_SYMBOL (scm_sym_exit_frame, "exit-frame"); +SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace"); #endif @@ -3880,11 +3885,6 @@ scm_init_eval () scm_f_apply = scm_make_subr ("apply", scm_tc7_lsubr_2, scm_apply); scm_system_transformer = scm_sysintern ("scm:eval-transformer", scm_make_fluid ()); - scm_sym_dot = SCM_CAR (scm_sysintern (".", SCM_UNDEFINED)); - scm_sym_arrow = SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED)); - scm_sym_else = SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED)); - scm_sym_unquote = SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED)); - scm_sym_uq_splicing = SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED)); scm_lisp_nil = scm_sysintern ("nil", SCM_UNDEFINED); SCM_SETCDR (scm_lisp_nil, SCM_CAR (scm_lisp_nil)); @@ -3901,13 +3901,6 @@ scm_init_eval () scm_sysintern ("*top-level-lookup-closure*", scm_make_fluid ()); #endif -#ifdef DEBUG_EXTENSIONS - scm_sym_enter_frame = SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED)); - scm_sym_apply_frame = SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED)); - scm_sym_exit_frame = SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED)); - scm_sym_trace = SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED)); -#endif - #ifndef SCM_MAGIC_SNARFER #include "libguile/eval.x" #endif diff --git a/libguile/gc.c b/libguile/gc.c index e04d50b18..3aa9c0205 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -2435,17 +2435,30 @@ init_freelist (scm_freelist_t *freelist, freelist->heap_size = 0; } -int -scm_init_storage (scm_sizet init_heap_size_1, int gc_trigger_1, - scm_sizet init_heap_size_2, int gc_trigger_2, - scm_sizet max_segment_size) -{ - scm_sizet j; - if (!init_heap_size_1) - init_heap_size_1 = scm_default_init_heap_size_1; - if (!init_heap_size_2) - init_heap_size_2 = scm_default_init_heap_size_2; +/* Get an integer from an environment variable. */ +static int +scm_i_getenv_int (const char *var, int def) +{ + char *end, *val = getenv (var); + long res; + if (!val) + return def; + res = strtol (val, &end, 10); + if (end == val) + return def; + return res; +} + + +int +scm_init_storage () +{ + scm_sizet gc_trigger_1; + scm_sizet gc_trigger_2; + scm_sizet init_heap_size_1; + scm_sizet init_heap_size_2; + scm_sizet j; j = SCM_NUM_PROTECTS; while (j) @@ -2454,14 +2467,11 @@ scm_init_storage (scm_sizet init_heap_size_1, int gc_trigger_1, scm_freelist = SCM_EOL; scm_freelist2 = SCM_EOL; - init_freelist (&scm_master_freelist, - 1, SCM_CLUSTER_SIZE_1, - gc_trigger_1 ? gc_trigger_1 : scm_default_min_yield_1); - init_freelist (&scm_master_freelist2, - 2, SCM_CLUSTER_SIZE_2, - gc_trigger_2 ? gc_trigger_2 : scm_default_min_yield_2); - scm_max_segment_size - = max_segment_size ? max_segment_size : scm_default_max_segment_size; + gc_trigger_1 = scm_i_getenv_int ("GUILE_MIN_YIELD_1", scm_default_min_yield_1); + init_freelist (&scm_master_freelist, 1, SCM_CLUSTER_SIZE_1, gc_trigger_1); + gc_trigger_2 = scm_i_getenv_int ("GUILE_MIN_YIELD_2", scm_default_min_yield_2); + init_freelist (&scm_master_freelist2, 2, SCM_CLUSTER_SIZE_2, gc_trigger_2); + scm_max_segment_size = scm_i_getenv_int ("GUILE_MAX_SEGMENT_SIZE", scm_default_max_segment_size); scm_expmem = 0; @@ -2473,6 +2483,8 @@ scm_init_storage (scm_sizet init_heap_size_1, int gc_trigger_1, mark_space_ptr = &mark_space_head; + init_heap_size_1 = scm_i_getenv_int ("GUILE_INIT_SEGMENT_SIZE_1", scm_default_init_heap_size_1); + init_heap_size_2 = scm_i_getenv_int ("GUILE_INIT_SEGMENT_SIZE_2", scm_default_init_heap_size_2); if (make_initial_segment (init_heap_size_1, &scm_master_freelist) || make_initial_segment (init_heap_size_2, &scm_master_freelist2)) return 1; diff --git a/libguile/gc.h b/libguile/gc.h index 9397e562d..02e39890b 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -354,9 +354,7 @@ extern int scm_return_first_int (int x, ...); extern SCM scm_permanent_object (SCM obj); extern SCM scm_protect_object (SCM obj); extern SCM scm_unprotect_object (SCM obj); -extern int scm_init_storage (scm_sizet init_heap_size, int trig, - scm_sizet init_heap2_size, int trig2, - scm_sizet max_segment_size); +extern int scm_init_storage (void); extern void *scm_get_stack_base (void); extern void scm_init_gc (void); diff --git a/libguile/gsubr.c b/libguile/gsubr.c index 03e27b621..83c268479 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -59,7 +59,8 @@ /* #define GSUBR_TEST */ -SCM scm_sym_name; +SCM_GLOBAL_SYMBOL (scm_sym_name, "name"); + SCM scm_f_gsubr_apply; SCM @@ -207,11 +208,14 @@ void scm_init_gsubr() { scm_f_gsubr_apply = scm_make_subr_opt("gsubr-apply", scm_tc7_lsubr, scm_gsubr_apply, 0); - scm_sym_name = SCM_CAR (scm_sysintern ("name", SCM_UNDEFINED)); - scm_permanent_object (scm_sym_name); + #ifdef GSUBR_TEST scm_make_gsubr("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */ #endif + +#ifndef SCM_MAGIC_SNARFER +#include "libguile/gsubr.x" +#endif } /* diff --git a/libguile/init.c b/libguile/init.c index b4d7467d8..b703dcf17 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -368,20 +368,6 @@ scm_load_startup_files () } } -/* Get an integer from an environment variable. */ -static int -scm_i_getenv_int (const char *var, int def) -{ - char *end, *val = getenv (var); - long res; - if (!val) - return def; - res = strtol (val, &end, 10); - if (end == val) - return def; - return res; -} - /* The main init code. */ @@ -482,11 +468,7 @@ scm_init_guile_1 (SCM_STACKITEM *base) #ifdef GUILE_DEBUG_MALLOC scm_debug_malloc_prehistory (); #endif - scm_init_storage (scm_i_getenv_int ("GUILE_INIT_SEGMENT_SIZE_1", 0), - scm_i_getenv_int ("GUILE_MIN_YIELD_1", 0), - scm_i_getenv_int ("GUILE_INIT_SEGMENT_SIZE_2", 0), - scm_i_getenv_int ("GUILE_MIN_YIELD_2", 0), - scm_i_getenv_int ("GUILE_MAX_SEGMENT_SIZE", 0)); + scm_init_storage (); scm_struct_prehistory (); /* Must come after scm_init_storage */ scm_weaks_prehistory (); /* Must come after scm_init_storage */ scm_init_subr_table (); @@ -498,6 +480,7 @@ scm_init_guile_1 (SCM_STACKITEM *base) #endif start_stack (base); scm_init_gsubr (); + scm_init_procprop (); scm_init_environments (); scm_init_feature (); scm_init_alist (); @@ -542,7 +525,6 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_init_regex_posix (); #endif scm_init_procs (); - scm_init_procprop (); scm_init_scmsigs (); #ifdef HAVE_NETWORKING scm_init_net_db (); diff --git a/libguile/keywords.c b/libguile/keywords.c index b8af91c08..f14627144 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -95,13 +95,16 @@ SCM_DEFINE (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", SCM scm_c_make_keyword (char *s) { - SCM vcell; char *buf = scm_must_malloc (strlen (s) + 2, "keyword"); + SCM symbol; + buf[0] = '-'; strcpy (buf + 1, s); - vcell = scm_sysintern0 (buf); + symbol = scm_str2symbol (buf); scm_must_free (buf); - return scm_make_keyword_from_dash_symbol (SCM_CAR (vcell)); + scm_done_free (strlen (s) + 2); + + return scm_make_keyword_from_dash_symbol (symbol); } SCM_DEFINE (scm_keyword_p, "keyword?", 1, 0, 0, diff --git a/libguile/options.c b/libguile/options.c index 051286d5c..94e74d573 100644 --- a/libguile/options.c +++ b/libguile/options.c @@ -218,9 +218,15 @@ scm_init_opts (SCM (*func) (SCM), scm_option options[], int n) for (i = 0; i < n; ++i) { - options[i].name = (char *) SCM_CAR (scm_sysintern0 (options[i].name)); - options[i].doc = (char *) scm_permanent_object (scm_take0str - (options[i].doc)); + SCM name; + SCM doc; + + name = scm_str2symbol (options[i].name); + options[i].name = (char *) name; + scm_permanent_object (name); + doc = scm_take0str (options[i].doc); + options[i].doc = (char *) doc; + scm_permanent_object (doc); if (options[i].type == SCM_OPTION_SCM) SCM_SETCDR (protected_objects, scm_cons (SCM_PACK(options[i].val), SCM_CDR (protected_objects))); diff --git a/libguile/srcprop.c b/libguile/srcprop.c index 7df11f8f2..0fa027283 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -76,11 +76,11 @@ * */ -SCM scm_sym_filename; -SCM scm_sym_copy; -SCM scm_sym_line; -SCM scm_sym_column; -SCM scm_sym_breakpoint; +SCM_GLOBAL_SYMBOL (scm_sym_filename, "filename"); +SCM_GLOBAL_SYMBOL (scm_sym_copy, "copy"); +SCM_GLOBAL_SYMBOL (scm_sym_line, "line"); +SCM_GLOBAL_SYMBOL (scm_sym_column, "column"); +SCM_GLOBAL_SYMBOL (scm_sym_breakpoint, "breakpoint"); scm_bits_t scm_tc16_srcprops; static scm_srcprops_chunk *srcprops_chunklist = 0; @@ -329,14 +329,8 @@ scm_init_srcprop () scm_set_smob_print (scm_tc16_srcprops, srcprops_print); scm_source_whash = scm_make_weak_key_hash_table (SCM_MAKINUM (2047)); - - scm_sym_filename = SCM_CAR (scm_sysintern ("filename", SCM_UNDEFINED)); - scm_sym_copy = SCM_CAR (scm_sysintern ("copy", SCM_UNDEFINED)); - scm_sym_line = SCM_CAR (scm_sysintern ("line", SCM_UNDEFINED)); - scm_sym_column = SCM_CAR (scm_sysintern ("column", SCM_UNDEFINED)); - scm_sym_breakpoint = SCM_CAR (scm_sysintern ("breakpoint", SCM_UNDEFINED)); - scm_sysintern ("source-whash", scm_source_whash); + #ifndef SCM_MAGIC_SNARFER #include "libguile/srcprop.x" #endif diff --git a/libguile/variable.c b/libguile/variable.c index 163fb8ed2..0b586c721 100644 --- a/libguile/variable.c +++ b/libguile/variable.c @@ -83,7 +83,7 @@ variable_equalp (SCM var1, SCM var2) } -static SCM anonymous_variable_sym; +SCM_SYMBOL (anonymous_variable_sym, "anonymous-variable"); static SCM @@ -229,7 +229,6 @@ scm_init_variable () scm_set_smob_print (scm_tc16_variable, variable_print); scm_set_smob_equalp (scm_tc16_variable, variable_equalp); - anonymous_variable_sym = SCM_CAR (scm_sysintern ("anonymous-variable", SCM_UNDEFINED)); #ifndef SCM_MAGIC_SNARFER #include "libguile/variable.x" #endif From 70f95333429db49ade8c511ff14c95488fe5e080 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 11 Dec 2000 18:09:07 +0000 Subject: [PATCH 0418/2047] * gc_os_dep.c (scm_get_stack_base) [MSWIN32]: Added detection of page size on the w32 architecture. Updated from Boehms gc5.2. Thanks to Lars J. Aas! --- libguile/gc_os_dep.c | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/libguile/gc_os_dep.c b/libguile/gc_os_dep.c index 4ce37ec2e..d9a11bf06 100644 --- a/libguile/gc_os_dep.c +++ b/libguile/gc_os_dep.c @@ -1572,9 +1572,16 @@ void *scm_get_stack_base() { int dummy; ptr_t sp = (ptr_t)(&dummy); - ptr_t trunc_sp = (ptr_t)((word)sp & ~(GC_page_size - 1)); - word size = GC_get_writable_length(trunc_sp, 0); - + ptr_t trunc_sp; + word size; + static word GC_page_size = 0; + if (!GC_page_size) { + SYSTEM_INFO sysinfo; + GetSystemInfo(&sysinfo); + GC_page_size = sysinfo.dwPageSize; + } + trunc_sp = (ptr_t)((word)sp & ~(GC_page_size - 1)); + size = GC_get_writable_length(trunc_sp, 0); return(trunc_sp + size); } From 30eaf3ccd829f3eec93a8cbe0ea8a1bfab07595b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 11 Dec 2000 18:09:35 +0000 Subject: [PATCH 0419/2047] *** empty log message *** --- libguile/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 4f08f902c..8b13ca64c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2000-12-11 Marius Vollmer + + * gc_os_dep.c (scm_get_stack_base) [MSWIN32]: Added detection of + page size on the w32 architecture. Updated from Boehms gc5.2. + Thanks to Lars J. Aas! + 2000-12-11 Dirk Herrmann * debug.c (scm_sym_procname, scm_sym_dots, scm_sym_source, From ba3932579cf70feac6d4bc622cda071e418700f4 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 12 Dec 2000 13:57:26 +0000 Subject: [PATCH 0420/2047] * Moved function scm_string_hash to hash.c. --- libguile/ChangeLog | 5 +++++ libguile/hash.c | 22 ++++++++++++++++++++++ libguile/hash.h | 1 + libguile/symbols.c | 23 +---------------------- libguile/symbols.h | 2 -- 5 files changed, 29 insertions(+), 24 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 8b13ca64c..9485de2cc 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-12-12 Dirk Herrmann + + * hash.[ch] (scm_string_hash), symbols.[ch] (scm_string_hash): + Moved function scm_string_hash to hash.c. + 2000-12-11 Marius Vollmer * gc_os_dep.c (scm_get_stack_base) [MSWIN32]: Added detection of diff --git a/libguile/hash.c b/libguile/hash.c index 529ad9fa0..ff9e45fd3 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -61,6 +61,28 @@ extern double floor(); #endif +unsigned long +scm_string_hash (const unsigned char *str, scm_sizet len) +{ + if (len > 5) + { + scm_sizet i = 5; + unsigned long h = 264; + while (i--) + h = (h << 8) + ((unsigned) (scm_downcase (str[h % len]))); + return h; + } + else + { + scm_sizet i = len; + unsigned long h = 0; + while (i) + h = (h << 8) + ((unsigned) (scm_downcase (str[--i]))); + return h; + } +} + + /* Dirk:FIXME:: why downcase for characters? (2x: scm_hasher, scm_ihashv) */ /* Dirk:FIXME:: scm_hasher could be made static. */ diff --git a/libguile/hash.h b/libguile/hash.h index 6017a5e93..0b2ba1037 100644 --- a/libguile/hash.h +++ b/libguile/hash.h @@ -48,6 +48,7 @@ +extern unsigned long scm_string_hash (const unsigned char *str, scm_sizet len); extern unsigned long scm_hasher (SCM obj, unsigned long n, scm_sizet d); extern unsigned int scm_ihashq (SCM obj, unsigned int n); extern SCM scm_hashq (SCM obj, SCM n); diff --git a/libguile/symbols.c b/libguile/symbols.c index a50c57367..dc5be4729 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -48,6 +48,7 @@ #include "libguile/_scm.h" #include "libguile/chars.h" #include "libguile/eval.h" +#include "libguile/hash.h" #include "libguile/smob.h" #include "libguile/variable.h" #include "libguile/alist.h" @@ -81,28 +82,6 @@ duplicate_string (const char * src, unsigned long length) */ -unsigned long -scm_string_hash (const unsigned char *str, scm_sizet len) -{ - if (len > 5) - { - scm_sizet i = 5; - unsigned long h = 264; - while (i--) - h = (h << 8) + ((unsigned) (scm_downcase (str[h % len]))); - return h; - } - else - { - scm_sizet i = len; - unsigned long h = 0; - while (i) - h = (h << 8) + ((unsigned) (scm_downcase (str[--i]))); - return h; - } -} - - /* scm_sym2vcell * looks up the symbol in the symhash table. */ diff --git a/libguile/symbols.h b/libguile/symbols.h index 848d985f9..423a7a148 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -71,8 +71,6 @@ -extern unsigned long scm_string_hash (const unsigned char *str, scm_sizet len); - extern SCM scm_mem2symbol (const char*, scm_sizet); extern SCM scm_str2symbol (const char*); From a3fc3be99d9d2725be75f59d55a4f8d58a1d0792 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 12 Dec 2000 14:07:06 +0000 Subject: [PATCH 0421/2047] * Make the creation of bindings more straightforward. --- libguile/ChangeLog | 8 ++++++++ libguile/hooks.c | 3 +-- libguile/script.c | 5 +---- libguile/snarf.h | 8 ++++---- 4 files changed, 14 insertions(+), 10 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 9485de2cc..090653efa 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2000-12-12 Dirk Herrmann + + * hooks.c (scm_create_hook), script.c + (scm_compile_shell_switches), snarf.h (SCM_VCELL, + SCM_GLOBAL_VCELL, SCM_VCELL_INIT, SCM_GLOBAL_VCELL_INIT): Create + a binding in one go (instead of first creating a vcell and then + setting its cdr). + 2000-12-12 Dirk Herrmann * hash.[ch] (scm_string_hash), symbols.[ch] (scm_string_hash): diff --git a/libguile/hooks.c b/libguile/hooks.c index 57fce99a6..47437f7e9 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -200,9 +200,8 @@ SCM_SYMBOL (symbol_name, "name"); SCM scm_create_hook (const char* name, int n_args) { - SCM vcell = scm_sysintern0 (name); SCM hook = make_hook (SCM_MAKINUM (n_args), "scm_create_hook"); - SCM_SETCDR (vcell, hook); + scm_sysintern (name, hook); scm_set_object_property_x (hook, symbol_name, scm_makfrom0str (name)); scm_protect_object (hook); return hook; diff --git a/libguile/script.c b/libguile/script.c index e031991d4..7bbc51aec 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -578,10 +578,7 @@ scm_compile_shell_switches (int argc, char **argv) scm_set_program_arguments (argc ? argc - i : 0, argv + i, argv0); /* If the --emacs switch was set, now is when we process it. */ - { - SCM vcell = scm_sysintern0_no_module_lookup ("use-emacs-interface"); - SCM_SETCDR (vcell, SCM_BOOL(use_emacs_interface)); - } + scm_sysintern ("use-emacs-interface", SCM_BOOL (use_emacs_interface)); /* Handle the `-e' switch, if it was specified. */ if (!SCM_NULLP (entry_point)) diff --git a/libguile/snarf.h b/libguile/snarf.h index e3d2d331d..436454427 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -169,19 +169,19 @@ SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_make_keyword (scheme_name))) #define SCM_VCELL(c_name, scheme_name) \ SCM_SNARF_HERE(static SCM c_name) \ -SCM_SNARF_INIT(c_name = scm_permanent_object (scm_intern0 (scheme_name)); SCM_SETCDR (c_name, SCM_BOOL_F)) +SCM_SNARF_INIT(c_name = scm_permanent_object (scm_sysintern (scheme_name, SCM_BOOL_F));) #define SCM_GLOBAL_VCELL(c_name, scheme_name) \ SCM_SNARF_HERE(SCM c_name) \ -SCM_SNARF_INIT(c_name = scm_permanent_object (scm_intern0 (scheme_name)); SCM_SETCDR (c_name, SCM_BOOL_F)) +SCM_SNARF_INIT(c_name = scm_permanent_object (scm_sysintern (scheme_name, SCM_BOOL_F));) #define SCM_VCELL_INIT(c_name, scheme_name, init_val) \ SCM_SNARF_HERE(static SCM c_name) \ -SCM_SNARF_INIT(c_name = scm_permanent_object (scm_intern0 (scheme_name)); SCM_SETCDR (c_name, init_val)) +SCM_SNARF_INIT(c_name = scm_permanent_object (scm_sysintern (scheme_name, init_val));) #define SCM_GLOBAL_VCELL_INIT(c_name, scheme_name, init_val) \ SCM_SNARF_HERE(SCM c_name) \ -SCM_SNARF_INIT(c_name = scm_permanent_object (scm_intern0 (scheme_name)); SCM_SETCDR (c_name, init_val)) +SCM_SNARF_INIT(c_name = scm_permanent_object (scm_sysintern (scheme_name, init_val));) #define SCM_CONST_LONG(c_name, scheme_name,value) \ SCM_VCELL_INIT(c_name, scheme_name, scm_long2num(value)) From 6b098fecdcdbf35551584a21bc8b98c4e0d6b442 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 12 Dec 2000 18:10:56 +0000 Subject: [PATCH 0422/2047] * Lookup 'use-emacs-interface in the-root-module. --- guile-readline/ChangeLog | 5 +++++ guile-readline/readline.scm | 5 ++--- ice-9/ChangeLog | 5 +++++ ice-9/boot-9.scm | 2 +- 4 files changed, 13 insertions(+), 4 deletions(-) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 7b762054b..1fad43605 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,8 @@ +2000-12-12 Dirk Herrmann + + * readline.scm (activate-readline): Lookup 'use-emacs-interface + in the-root-module. + 2000-11-24 Dirk Herrmann * readline.c (current_input_getc): Use more explicit predicate diff --git a/guile-readline/readline.scm b/guile-readline/readline.scm index 104647e45..23adf4387 100644 --- a/guile-readline/readline.scm +++ b/guile-readline/readline.scm @@ -169,9 +169,8 @@ (define-public (activate-readline) (if (and (isatty? (current-input-port)) - (not (and (module-defined? the-root-module - 'use-emacs-interface) - use-emacs-interface))) + (not (and (module-defined? the-root-module 'use-emacs-interface) + (module-ref the-root-module 'use-emacs-interface)))) (let ((read-hook (lambda () (run-hook before-read-hook)))) (set-current-input-port (readline-port)) (set! repl-reader diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 530f80c8d..d543b3058 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2000-12-12 Dirk Herrmann + + * boot-9.scm (top-repl): Lookup 'use-emacs-interface in + the-root-module. + 2000-12-07 Neil Jerram * emacs.scm (flush-whitespace): Fix spelling typo ("recieving"). diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index f9e134fd6..c674f1b6b 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -2793,7 +2793,7 @@ ;; Load emacs interface support if emacs option is given. (if (and (module-defined? the-root-module 'use-emacs-interface) - use-emacs-interface) + (module-ref the-root-module 'use-emacs-interface)) (load-emacs-interface)) ;; Place the user in the guile-user module. From b52e071bc5a7b63fcfa763991fb065f712930041 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 12 Dec 2000 18:36:35 +0000 Subject: [PATCH 0423/2047] * The creation of symbols and bindings are two separate issues now. --- NEWS | 4 + ice-9/ChangeLog | 5 + ice-9/session.scm | 9 +- libguile/ChangeLog | 35 +++++++ libguile/gc.c | 2 +- libguile/root.h | 4 +- libguile/stacks.c | 6 +- libguile/symbols.c | 229 ++++++++++++++++++++------------------------- libguile/symbols.h | 1 - 9 files changed, 153 insertions(+), 142 deletions(-) diff --git a/NEWS b/NEWS index d12d31c30..d8e2f79e7 100644 --- a/NEWS +++ b/NEWS @@ -207,6 +207,10 @@ effect of flushing buffers. port-for-each is more flexible. the child process from the current Scheme ports, instead of using the current values of file descriptors 0, 1, and 2 in the parent process. +** Removed function: builtin-weak-bindings + +There is no such concept as a weak binding any more. + * Changes to the gh_ interface * Changes to the scm_ interface diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index d543b3058..74d41b334 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2000-12-12 Dirk Herrmann + + * session.scm (apropos, apropos-fold): There are no weak bindings + any more. + 2000-12-12 Dirk Herrmann * boot-9.scm (top-repl): Lookup 'use-emacs-interface in diff --git a/ice-9/session.scm b/ice-9/session.scm index 3cde2e5fa..a8d2878db 100644 --- a/ice-9/session.scm +++ b/ice-9/session.scm @@ -199,8 +199,7 @@ where OPTIONSET is one of debug, read, eval, print (eq? module the-root-module))) (name (module-name module)) (obarrays (if builtin - (list (builtin-weak-bindings) - (builtin-bindings)) + (list (builtin-bindings)) (list (module-obarray module)))) (get-refs (if builtin (list id id) @@ -278,10 +277,8 @@ Fourth arg FOLDER is one of (cond ((or (eq? module the-scm-module) (eq? module the-root-module)) (hash-fold obarray-filter - (hash-fold obarray-filter - data - (builtin-bindings)) - (builtin-weak-bindings))) + data + (builtin-bindings))) (module (hash-fold module-filter data (module-obarray module))) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 090653efa..4e2575552 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,38 @@ +2000-12-12 Dirk Herrmann + + * gc.c (scm_init_storage), root.h (scm_weak_symhash, scm_symbols): + Removed the former scm_weak_symhash hash table. Added scm_symbols + hash table. + + * stacks.c (get_applybody): scm_sym2vcell may return #f. + + * symbols.c (scm_mem2symbol): This function is now responsible + for creating symbol objects and storing them in the global + scm_symbols hash table. + + (scm_str2symbol): Rewritten in terms of scm_mem2symbol. + + (scm_sym2vcell): For system bindings, there is now only one + obarray - scm_symhash. If scm_sym2vcell is called to look up a + symbol that can't be found and shall not be created, #f is + returned. Most callers of scm_sym2vcell have expected this + behaviour anyway. + + (scm_intern_obarray_soft): Removed reference to scm_weak_symhash + from comment. + + (scm_intern_obarray_soft, scm_sysintern0_no_module_lookup): These + functions are not responsible for symbol creation any more, only + for creation of bindings. + + (scm_symbol_value0): Don't use scm_intern_obarray_soft to create + a symbol object. + + (scm_symbol_interned_p): scm_weak_symhash is removed. + + * symbols.[ch] (scm_builtin_weak_bindings): Removed. There are + no weak bindings any more. + 2000-12-12 Dirk Herrmann * hooks.c (scm_create_hook), script.c diff --git a/libguile/gc.c b/libguile/gc.c index 3aa9c0205..eaf8ec709 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -2521,7 +2521,7 @@ scm_init_storage () #define DEFAULT_SYMHASH_SIZE 277 scm_symhash = scm_make_vector (SCM_MAKINUM (DEFAULT_SYMHASH_SIZE), SCM_EOL); - scm_weak_symhash = scm_make_weak_key_hash_table (SCM_MAKINUM (DEFAULT_SYMHASH_SIZE)); + scm_symbols = scm_make_weak_key_hash_table (SCM_MAKINUM (DEFAULT_SYMHASH_SIZE)); scm_symhash_vars = scm_make_vector (SCM_MAKINUM (DEFAULT_SYMHASH_SIZE), SCM_EOL); scm_stand_in_procs = SCM_EOL; diff --git a/libguile/root.h b/libguile/root.h index cc07ec622..950d12f54 100644 --- a/libguile/root.h +++ b/libguile/root.h @@ -61,8 +61,8 @@ #define scm_undefineds scm_sys_protects[2] #define scm_nullvect scm_sys_protects[3] #define scm_nullstr scm_sys_protects[4] -#define scm_symhash scm_sys_protects[5] -#define scm_weak_symhash scm_sys_protects[6] +#define scm_symbols scm_sys_protects[5] +#define scm_symhash scm_sys_protects[6] #define scm_symhash_vars scm_sys_protects[7] #define scm_keyword_obarray scm_sys_protects[8] #define scm_stand_in_procs scm_sys_protects[9] diff --git a/libguile/stacks.c b/libguile/stacks.c index 5cfa4ca90..2a61e92e2 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -222,9 +222,9 @@ read_frame (scm_debug_frame *dframe,long offset,scm_info_frame *iframe) static SCM get_applybody () { - SCM proc = SCM_CDR (scm_sym2vcell (scm_sym_apply, SCM_BOOL_F, SCM_BOOL_F)); - if (SCM_CLOSUREP (proc)) - return SCM_CADR (SCM_CODE (proc)); + SCM cell = scm_sym2vcell (scm_sym_apply, SCM_BOOL_F, SCM_BOOL_F); + if (SCM_CONSP (cell) && SCM_CLOSUREP (SCM_CDR (cell))) + return SCM_CADR (SCM_CODE (SCM_CDR (cell))); else return SCM_UNDEFINED; } diff --git a/libguile/symbols.c b/libguile/symbols.c index dc5be4729..824dcadf0 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -82,6 +82,67 @@ duplicate_string (const char * src, unsigned long length) */ +SCM +scm_mem2symbol (const char *name, scm_sizet len) +{ + scm_sizet raw_hash = scm_string_hash ((const unsigned char *) name, len); + scm_sizet hash = raw_hash % SCM_VECTOR_LENGTH (scm_symbols); + + { + /* Try to find the symbol in the scm_symbols table */ + + SCM l; + + for (l = SCM_VELTS (scm_symbols) [hash]; !SCM_NULLP (l); l = SCM_CDR (l)) + { + SCM sym = SCM_CAAR (l); + if (SCM_SYMBOL_HASH (sym) == raw_hash && SCM_SYMBOL_LENGTH (sym) == len) + { + char *chrs = SCM_SYMBOL_CHARS (sym); + scm_sizet i = len; + + while (i != 0) + { + --i; + if (name[i] != chrs[i]) + goto next_symbol; + } + + return sym; + } + next_symbol: + } + } + + { + /* The symbol was not found - create it. */ + + SCM symbol; + SCM cell; + SCM slot; + + SCM_NEWCELL2 (symbol); + SCM_SET_SYMBOL_CHARS (symbol, duplicate_string (name, len)); + SCM_SET_SYMBOL_HASH (symbol, raw_hash); + SCM_SET_PROP_SLOTS (symbol, scm_cons (SCM_BOOL_F, SCM_EOL)); + SCM_SET_SYMBOL_LENGTH (symbol, (long) len); + + cell = scm_cons (symbol, SCM_UNDEFINED); + slot = SCM_VELTS (scm_symbols) [hash]; + SCM_VELTS (scm_symbols) [hash] = scm_cons (cell, slot); + + return symbol; + } +} + + +SCM +scm_str2symbol (const char *str) +{ + return scm_mem2symbol (str, strlen (str)); +} + + /* scm_sym2vcell * looks up the symbol in the symhash table. */ @@ -109,13 +170,11 @@ scm_sym2vcell (SCM sym, SCM thunk, SCM definep) else { SCM lsym; - SCM * lsymp; - scm_sizet hash1; - scm_sizet hash2; + scm_sizet hash; SCM_DEFER_INTS; - hash1 = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (scm_symhash); - for (lsym = SCM_VELTS (scm_symhash)[hash1]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) + hash = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (scm_symhash); + for (lsym = SCM_VELTS (scm_symhash)[hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) { SCM z = SCM_CAR (lsym); if (SCM_EQ_P (SCM_CAR (z), sym)) @@ -125,27 +184,21 @@ scm_sym2vcell (SCM sym, SCM thunk, SCM definep) } } - hash2 = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (scm_weak_symhash); - for (lsym = *(lsymp = &SCM_VELTS (scm_weak_symhash)[hash2]); - SCM_NIMP (lsym); - lsym = *(lsymp = SCM_CDRLOC (lsym))) + if (!SCM_FALSEP (definep)) { - SCM z = SCM_CAR (lsym); - if (SCM_EQ_P (SCM_CAR (z), sym)) - { - if (SCM_NFALSEP (definep)) - { - /* Move handle from scm_weak_symhash to scm_symhash. */ - *lsymp = SCM_CDR (lsym); - SCM_SETCDR (lsym, SCM_VELTS(scm_symhash)[hash1]); - SCM_VELTS(scm_symhash)[hash1] = lsym; - } - SCM_ALLOW_INTS; - return z; - } + SCM cell = scm_cons (sym, SCM_UNDEFINED); + SCM slot = SCM_VELTS (scm_symhash) [hash]; + + SCM_VELTS (scm_symhash) [hash] = scm_cons (cell, slot); + + SCM_ALLOW_INTS; + return cell; + } + else + { + SCM_ALLOW_INTS; + return SCM_BOOL_F; } - SCM_ALLOW_INTS; - return scm_wta (sym, "uninterned symbol? ", ""); } } @@ -203,112 +256,51 @@ scm_sym2ovcell (SCM sym, SCM obarray) in OBARRAY; instead, just return #f. If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and - return (SYMBOL . SCM_UNDEFINED). - - If OBARRAY is scm_symhash, and that doesn't contain the symbol, - check scm_weak_symhash instead. */ + return (SYMBOL . SCM_UNDEFINED). */ SCM scm_intern_obarray_soft (const char *name,scm_sizet len,SCM obarray,unsigned int softness) { - scm_sizet raw_hash = scm_string_hash ((unsigned char *) name, len); + SCM symbol = scm_mem2symbol (name, len); + scm_sizet raw_hash = SCM_SYMBOL_HASH (symbol); scm_sizet hash; SCM lsym; - SCM_REDEFER_INTS; - if (SCM_FALSEP (obarray)) { - hash = raw_hash % 1019; - goto uninterned_symbol; + if (softness) + return SCM_BOOL_F; + else + return scm_cons (symbol, SCM_UNDEFINED); } hash = raw_hash % SCM_VECTOR_LENGTH (obarray); - retry_new_obarray: for (lsym = SCM_VELTS (obarray)[hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) { - scm_sizet i; SCM a = SCM_CAR (lsym); SCM z = SCM_CAR (a); - char *tmp = SCM_SYMBOL_CHARS (z); - if (SCM_SYMBOL_HASH (z) != raw_hash) - goto trynext; - if (SCM_SYMBOL_LENGTH (z) != len) - goto trynext; - for (i = len; i--;) - if (name[i] != tmp[i]) - goto trynext; - { - SCM_REALLOW_INTS; + if (SCM_EQ_P (z, symbol)) return a; - } - trynext:; - } - - if (SCM_EQ_P (obarray, scm_symhash)) - { - obarray = scm_weak_symhash; - goto retry_new_obarray; } - uninterned_symbol: if (softness) { - SCM_REALLOW_INTS; return SCM_BOOL_F; } - - SCM_NEWCELL2 (lsym); - SCM_SET_SYMBOL_CHARS (lsym, duplicate_string (name, len)); - SCM_SET_SYMBOL_HASH (lsym, raw_hash); - SCM_SET_PROP_SLOTS (lsym, scm_cons (SCM_BOOL_F, SCM_EOL)); - SCM_SET_SYMBOL_LENGTH (lsym, (long) len); - - if (SCM_FALSEP (obarray)) - { - SCM answer; - SCM_REALLOW_INTS; - SCM_NEWCELL (answer); - SCM_DEFER_INTS; - SCM_SETCAR (answer, lsym); - SCM_SETCDR (answer, SCM_UNDEFINED); - SCM_REALLOW_INTS; - return answer; - } else { - SCM a; - SCM b; + SCM cell = scm_cons (symbol, SCM_UNDEFINED); + SCM slot = SCM_VELTS (obarray) [hash]; - SCM_NEWCELL (a); - SCM_NEWCELL (b); - SCM_SETCAR (a, lsym); - SCM_SETCDR (a, SCM_UNDEFINED); - SCM_SETCAR (b, a); - SCM_SETCDR (b, SCM_VELTS(obarray)[hash]); - SCM_VELTS(obarray)[hash] = b; - SCM_REALLOW_INTS; - return SCM_CAR (b); + SCM_VELTS (obarray) [hash] = scm_cons (cell, slot); + + return cell; } } -SCM -scm_mem2symbol (const char *mem, scm_sizet len) -{ - return SCM_CAR (scm_intern_obarray_soft (mem, len, scm_symhash, 0)); -} - - -SCM -scm_str2symbol (const char *str) -{ - return SCM_CAR (scm_intern_obarray_soft (str, strlen (str), scm_symhash, 0)); -} - - SCM scm_intern_obarray (const char *name,scm_sizet len,SCM obarray) { @@ -334,9 +326,10 @@ scm_intern0 (const char * name) SCM scm_sysintern0_no_module_lookup (const char *name) { + scm_sizet len = strlen (name); SCM easy_answer; SCM_DEFER_INTS; - easy_answer = scm_intern_obarray_soft (name, strlen (name), scm_symhash, 1); + easy_answer = scm_intern_obarray_soft (name, len, scm_symhash, 1); if (SCM_NIMP (easy_answer)) { SCM_ALLOW_INTS; @@ -344,21 +337,15 @@ scm_sysintern0_no_module_lookup (const char *name) } else { - SCM lsym; - scm_sizet len = strlen (name); - scm_sizet raw_hash = scm_string_hash ((unsigned char *) name, len); + SCM symbol = scm_mem2symbol (name, len); + scm_sizet raw_hash = SCM_SYMBOL_HASH (symbol); scm_sizet hash = raw_hash % SCM_VECTOR_LENGTH (scm_symhash); + SCM cell = scm_cons (symbol, SCM_UNDEFINED); + SCM slot = SCM_VELTS (scm_symhash) [hash]; - SCM_NEWCELL2 (lsym); - SCM_SET_SYMBOL_CHARS (lsym, name); - SCM_SET_SYMBOL_HASH (lsym, raw_hash); - SCM_SET_PROP_SLOTS (lsym, scm_cons (SCM_BOOL_F, SCM_EOL)); - SCM_SET_SYMBOL_LENGTH (lsym, (long) len); - - lsym = scm_cons (lsym, SCM_UNDEFINED); - SCM_VELTS (scm_symhash)[hash] = scm_cons (lsym, SCM_VELTS (scm_symhash)[hash]); + SCM_VELTS (scm_symhash) [hash] = scm_cons (cell, slot); SCM_ALLOW_INTS; - return lsym; + return cell; } } @@ -399,10 +386,8 @@ scm_symbol_value0 (const char *name) /* This looks silly - we look up the symbol twice. But it is in fact necessary given the current module system because the module lookup closures are written in scheme which needs real symbols. */ - SCM symbol = scm_intern_obarray_soft (name, strlen (name), scm_symhash, 0); - SCM vcell = scm_sym2vcell (SCM_CAR (symbol), - SCM_TOP_LEVEL_LOOKUP_CLOSURE, - SCM_BOOL_F); + SCM symbol = scm_str2symbol (name); + SCM vcell = scm_sym2vcell (symbol, SCM_TOP_LEVEL_LOOKUP_CLOSURE, SCM_BOOL_F); if (SCM_FALSEP (vcell)) return SCM_UNDEFINED; return SCM_CDR (vcell); @@ -632,8 +617,6 @@ SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 2, 0, 0, o = scm_symhash; SCM_VALIDATE_VECTOR (1,o); vcell = scm_sym2ovcell_soft (s, o); - if (SCM_IMP (vcell) && SCM_EQ_P (o, scm_symhash)) - vcell = scm_sym2ovcell_soft (s, scm_weak_symhash); return (SCM_NIMP(vcell) ? SCM_BOOL_T : SCM_BOOL_F); @@ -778,18 +761,6 @@ SCM_DEFINE (scm_builtin_bindings, "builtin-bindings", 0, 0, 0, #undef FUNC_NAME -SCM_DEFINE (scm_builtin_weak_bindings, "builtin-weak-bindings", 0, 0, 0, - (), - "") -#define FUNC_NAME s_scm_builtin_weak_bindings -{ - int length = SCM_VECTOR_LENGTH (scm_weak_symhash); - SCM obarray = scm_make_doubly_weak_hash_table (SCM_MAKINUM (length)); - copy_and_prune_obarray (scm_weak_symhash, obarray); - return obarray; -} -#undef FUNC_NAME - #define MAX_PREFIX_LENGTH 30 static int gensym_counter; diff --git a/libguile/symbols.h b/libguile/symbols.h index 423a7a148..bad3cbcd4 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -101,7 +101,6 @@ extern SCM scm_symbol_fset_x (SCM s, SCM val); extern SCM scm_symbol_pset_x (SCM s, SCM val); extern SCM scm_symbol_hash (SCM s); extern SCM scm_builtin_bindings (void); -extern SCM scm_builtin_weak_bindings (void); extern SCM scm_gensym (SCM prefix); extern SCM scm_gentemp (SCM prefix, SCM obarray); extern void scm_init_symbols (void); From 10764e3c341f94ba10470a689e449b8208172123 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 13 Dec 2000 09:44:28 +0000 Subject: [PATCH 0424/2047] * Fixed the last patch (which was uncomplete). Thanks to Dale P. Smith. --- ice-9/ChangeLog | 5 ++++ ice-9/session.scm | 64 ++++++++++++++++++++++------------------------- 2 files changed, 35 insertions(+), 34 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 74d41b334..2703c0ee5 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2000-12-13 Dirk Herrmann + + * session.scm (apropos): Completed the last patch, which did only + half the job. Thanks to Dale P. Smith. + 2000-12-12 Dirk Herrmann * session.scm (apropos, apropos-fold): There are no weak bindings diff --git a/ice-9/session.scm b/ice-9/session.scm index a8d2878db..1148bbcf8 100644 --- a/ice-9/session.scm +++ b/ice-9/session.scm @@ -198,40 +198,36 @@ where OPTIONSET is one of debug, read, eval, print (let* ((builtin (or (eq? module the-scm-module) (eq? module the-root-module))) (name (module-name module)) - (obarrays (if builtin - (list (builtin-bindings)) - (list (module-obarray module)))) - (get-refs (if builtin - (list id id) - (list variable-ref))) - ) - (for-each - (lambda (obarray get-ref) - (array-for-each - (lambda (oblist) - (for-each - (lambda (x) - (cond ((regexp-exec match (symbol->string (car x))) - (display name) - (display ": ") - (display (car x)) - (cond ((procedure? (get-ref (cdr x))) - (display separator) - (display (get-ref (cdr x)))) - (value - (display separator) - (display (get-ref (cdr x))))) - (if (and shadow - (not (eq? (module-ref module - (car x)) - (module-ref (current-module) - (car x))))) - (display " shadowed")) - (newline) - ))) - oblist)) - obarray)) - obarrays get-refs))) + (obarray (if builtin + (builtin-bindings) + (module-obarray module))) + (get-ref (if builtin + id + variable-ref))) + (array-for-each + (lambda (oblist) + (for-each + (lambda (x) + (cond ((regexp-exec match (symbol->string (car x))) + (display name) + (display ": ") + (display (car x)) + (cond ((procedure? (get-ref (cdr x))) + (display separator) + (display (get-ref (cdr x)))) + (value + (display separator) + (display (get-ref (cdr x))))) + (if (and shadow + (not (eq? (module-ref module + (car x)) + (module-ref (current-module) + (car x))))) + (display " shadowed")) + (newline) + ))) + oblist)) + obarray))) modules)))) (define-public (apropos-internal rgx) From 0f979f3fb6897ce09fc8e570368decf1e4a5f2f4 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 13 Dec 2000 11:38:30 +0000 Subject: [PATCH 0425/2047] * Renamed scm_symbols to symbols and made it static in symbols.c. --- NEWS | 2 ++ libguile/ChangeLog | 20 ++++++++++++++++++++ libguile/gc.c | 6 ------ libguile/init.c | 5 +++-- libguile/root.h | 25 ++++++++++++------------- libguile/symbols.c | 24 +++++++++++++++++++----- 6 files changed, 56 insertions(+), 26 deletions(-) diff --git a/NEWS b/NEWS index d8e2f79e7..f364f62f7 100644 --- a/NEWS +++ b/NEWS @@ -211,6 +211,8 @@ current values of file descriptors 0, 1, and 2 in the parent process. There is no such concept as a weak binding any more. +** Removed constants: most-positive-fixnum, most-negative-fixnum, bignum-radix + * Changes to the gh_ interface * Changes to the scm_ interface diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 4e2575552..dfd554b8c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,23 @@ +2000-12-12 Dirk Herrmann + + The variable scm_symbols is made static within symbols.c and + renamed to symbols. The initialization of the symbols hash table + is done in function scm_symbols_prehistory. + + * gc.c (scm_init_storage): Don't initialize scm_symbols. Don't + define most-positive-fixnum, most-negative-fixnum and + bignum-radix. + + * init.c (scm_init_guile_1): Call scm_symbols_prehistory. + + * root.h (scm_symbols): Not in scm_sys_protects any more. + + * symbols.c (symbols): Renamed from scm_symbols and made static. + + (scm_mem2symbol): scm_symbols is renamed to symbols. + + * symbols.[ch] (scm_symbols_prehistory): Added. + 2000-12-12 Dirk Herrmann * gc.c (scm_init_storage), root.h (scm_weak_symhash, scm_symbols): diff --git a/libguile/gc.c b/libguile/gc.c index eaf8ec709..23eff9ae7 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -2521,17 +2521,11 @@ scm_init_storage () #define DEFAULT_SYMHASH_SIZE 277 scm_symhash = scm_make_vector (SCM_MAKINUM (DEFAULT_SYMHASH_SIZE), SCM_EOL); - scm_symbols = scm_make_weak_key_hash_table (SCM_MAKINUM (DEFAULT_SYMHASH_SIZE)); scm_symhash_vars = scm_make_vector (SCM_MAKINUM (DEFAULT_SYMHASH_SIZE), SCM_EOL); scm_stand_in_procs = SCM_EOL; scm_permobjs = SCM_EOL; scm_protects = scm_make_vector (SCM_MAKINUM (31), SCM_EOL); - scm_sysintern ("most-positive-fixnum", SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)); - scm_sysintern ("most-negative-fixnum", SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM)); -#ifdef SCM_BIGDIG - scm_sysintern ("bignum-radix", SCM_MAKINUM (SCM_BIGRAD)); -#endif return 0; } diff --git a/libguile/init.c b/libguile/init.c index b703dcf17..d20cdc236 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -469,8 +469,9 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_debug_malloc_prehistory (); #endif scm_init_storage (); - scm_struct_prehistory (); /* Must come after scm_init_storage */ - scm_weaks_prehistory (); /* Must come after scm_init_storage */ + scm_struct_prehistory (); /* requires storage */ + scm_symbols_prehistory (); /* requires storage */ + scm_weaks_prehistory (); /* requires storage */ scm_init_subr_table (); scm_environments_prehistory (); /* create the root environment */ scm_init_continuations (); diff --git a/libguile/root.h b/libguile/root.h index 950d12f54..82e12312c 100644 --- a/libguile/root.h +++ b/libguile/root.h @@ -61,21 +61,20 @@ #define scm_undefineds scm_sys_protects[2] #define scm_nullvect scm_sys_protects[3] #define scm_nullstr scm_sys_protects[4] -#define scm_symbols scm_sys_protects[5] -#define scm_symhash scm_sys_protects[6] -#define scm_symhash_vars scm_sys_protects[7] -#define scm_keyword_obarray scm_sys_protects[8] -#define scm_stand_in_procs scm_sys_protects[9] -#define scm_object_whash scm_sys_protects[10] -#define scm_permobjs scm_sys_protects[11] -#define scm_asyncs scm_sys_protects[12] -#define scm_protects scm_sys_protects[13] -#define scm_properties_whash scm_sys_protects[14] +#define scm_symhash scm_sys_protects[5] +#define scm_symhash_vars scm_sys_protects[6] +#define scm_keyword_obarray scm_sys_protects[7] +#define scm_stand_in_procs scm_sys_protects[8] +#define scm_object_whash scm_sys_protects[9] +#define scm_permobjs scm_sys_protects[10] +#define scm_asyncs scm_sys_protects[11] +#define scm_protects scm_sys_protects[12] +#define scm_properties_whash scm_sys_protects[13] #ifdef DEBUG_EXTENSIONS -#define scm_source_whash scm_sys_protects[15] -#define SCM_NUM_PROTECTS 16 -#else +#define scm_source_whash scm_sys_protects[14] #define SCM_NUM_PROTECTS 15 +#else +#define SCM_NUM_PROTECTS 14 #endif extern SCM scm_sys_protects[]; diff --git a/libguile/symbols.c b/libguile/symbols.c index 824dcadf0..779369748 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -67,6 +67,10 @@ +static SCM symbols; + + + static char * duplicate_string (const char * src, unsigned long length) { @@ -86,14 +90,14 @@ SCM scm_mem2symbol (const char *name, scm_sizet len) { scm_sizet raw_hash = scm_string_hash ((const unsigned char *) name, len); - scm_sizet hash = raw_hash % SCM_VECTOR_LENGTH (scm_symbols); + scm_sizet hash = raw_hash % SCM_VECTOR_LENGTH (symbols); { - /* Try to find the symbol in the scm_symbols table */ + /* Try to find the symbol in the symbols table */ SCM l; - for (l = SCM_VELTS (scm_symbols) [hash]; !SCM_NULLP (l); l = SCM_CDR (l)) + for (l = SCM_VELTS (symbols) [hash]; !SCM_NULLP (l); l = SCM_CDR (l)) { SCM sym = SCM_CAAR (l); if (SCM_SYMBOL_HASH (sym) == raw_hash && SCM_SYMBOL_LENGTH (sym) == len) @@ -128,8 +132,8 @@ scm_mem2symbol (const char *name, scm_sizet len) SCM_SET_SYMBOL_LENGTH (symbol, (long) len); cell = scm_cons (symbol, SCM_UNDEFINED); - slot = SCM_VELTS (scm_symbols) [hash]; - SCM_VELTS (scm_symbols) [hash] = scm_cons (cell, slot); + slot = SCM_VELTS (symbols) [hash]; + SCM_VELTS (symbols) [hash] = scm_cons (cell, slot); return symbol; } @@ -393,6 +397,7 @@ scm_symbol_value0 (const char *name) return SCM_CDR (vcell); } + SCM_DEFINE (scm_symbol_p, "symbol?", 1, 0, 0, (SCM obj), "Returns @t{#t} if @var{obj} is a symbol, otherwise returns @t{#f}. (r5rs)") @@ -853,6 +858,15 @@ SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0, } #undef FUNC_NAME + +void +scm_symbols_prehistory () +{ + symbols = scm_make_weak_key_hash_table (SCM_MAKINUM (277)); + scm_permanent_object (symbols); +} + + void scm_init_symbols () { From a261c0e933983a0668bb83b164e077702eda09e9 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 14 Dec 2000 00:08:56 +0000 Subject: [PATCH 0426/2047] * Re-introduced most-positive-fixnum and most-negative-fixnum. --- NEWS | 2 +- libguile/ChangeLog | 6 ++++++ libguile/numbers.c | 7 +++++++ 3 files changed, 14 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index f364f62f7..d714dcdf2 100644 --- a/NEWS +++ b/NEWS @@ -211,7 +211,7 @@ current values of file descriptors 0, 1, and 2 in the parent process. There is no such concept as a weak binding any more. -** Removed constants: most-positive-fixnum, most-negative-fixnum, bignum-radix +** Removed constants: bignum-radix * Changes to the gh_ interface diff --git a/libguile/ChangeLog b/libguile/ChangeLog index dfd554b8c..c56656314 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2000-12-13 Dirk Herrmann + + * numbers.c (scm_init_numbers): Re-introduced bindings for + most-positive-fixnum and most-negative-fixnum as requested by + Mikael Djurfeldt. + 2000-12-12 Dirk Herrmann The variable scm_symbols is made static within symbols.c and diff --git a/libguile/numbers.c b/libguile/numbers.c index 022c34cd9..e72d734a4 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -4353,6 +4353,13 @@ scm_num2ulong (SCM num, char *pos, const char *s_caller) void scm_init_numbers () { + /* It may be possible to tune the performance of some algorithms by using + * the following constants to avoid the creation of bignums. Please, before + * using these values, remember the two rules of program optimization: + * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */ + scm_sysintern ("most-positive-fixnum", SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)); + scm_sysintern ("most-negative-fixnum", SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM)); + scm_add_feature ("complex"); scm_add_feature ("inexact"); scm_flo0 = scm_make_real (0.0); From 3b505adf7d5ebc1e02bbde6cd4cb0eeacf7b554a Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 15 Dec 2000 09:53:56 +0000 Subject: [PATCH 0427/2047] * Use eval instead of eval-in-module. --- oop/ChangeLog | 5 +++++ oop/goops/save.scm | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/oop/ChangeLog b/oop/ChangeLog index 246c4e3ff..c9536231d 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -1,3 +1,8 @@ +2000-12-15 Dirk Herrmann + + * goops/save.scm (load-objects): eval-in-module is deprecated. + Use eval instead. + 2000-11-24 Dirk Herrmann * goops.scm: Don't export removed %logand any more. diff --git a/oop/goops/save.scm b/oop/goops/save.scm index 148264dc4..e2a9e54d7 100644 --- a/oop/goops/save.scm +++ b/oop/goops/save.scm @@ -869,7 +869,7 @@ (let loop ((sexp (read file))) (if (not (eof-object? sexp)) (begin - (eval-in-module sexp m) + (eval sexp m) (loop (read file))))))) (module-map (lambda (name var) (cons name (variable-ref var))) From 09074dbf9cac6009982610712ba78f5b4d0eb0dc Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 15 Dec 2000 14:00:18 +0000 Subject: [PATCH 0428/2047] * Fix a bug in scm_eval. --- libguile/ChangeLog | 9 +++++++++ libguile/eval.c | 45 +++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 52 insertions(+), 2 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index c56656314..9b41ead57 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2000-12-15 Dirk Herrmann + + * eval.c (change_environment, inner_eval, restore_environment): + New functions. + + (scm_eval): Bring the global variable that holds the current + environment up to date when entering or leaving the scope of the + evaluated code. Thanks to Matthias Koeppe for the bug report. + 2000-12-13 Dirk Herrmann * numbers.c (scm_init_numbers): Re-introduced bindings for diff --git a/libguile/eval.c b/libguile/eval.c index 190c06017..c66a7ebf3 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -81,6 +81,7 @@ char *alloca (); #include #include "libguile/_scm.h" #include "libguile/debug.h" +#include "libguile/dynwind.h" #include "libguile/alist.h" #include "libguile/eq.h" #include "libguile/continuations.h" @@ -3808,15 +3809,55 @@ scm_eval_x (SCM exp, SCM module) * environment explicit. */ +static void +change_environment (void *data) +{ + SCM pair = SCM_PACK (data); + SCM new_module = SCM_CAR (pair); + SCM old_module = scm_selected_module (); + SCM_SETCDR (pair, old_module); + scm_select_module (new_module); +} + + +static SCM +inner_eval (void *data) +{ + SCM pair = SCM_PACK (data); + SCM exp = SCM_CAR (pair); + SCM env = SCM_CDR (pair); + SCM result = scm_i_eval (exp, env); + return result; +} + + +static void +restore_environment (void *data) +{ + SCM pair = SCM_PACK (data); + SCM old_module = SCM_CDR (pair); + scm_select_module (old_module); +} + + SCM_DEFINE (scm_eval, "eval", 2, 0, 0, (SCM exp, SCM environment), "Evaluate @var{exp}, a list representing a Scheme expression, in the\n" "environment given by @var{environment specifier}.") #define FUNC_NAME s_scm_eval { + SCM copied_exp; + SCM env_closure; + SCM_VALIDATE_MODULE (2, environment); - return scm_i_eval (scm_copy_tree (exp), - scm_top_level_env (SCM_MODULE_EVAL_CLOSURE (environment))); + + copied_exp = scm_copy_tree (exp); + env_closure = scm_top_level_env (SCM_MODULE_EVAL_CLOSURE (environment)); + + return scm_internal_dynamic_wind + (change_environment, inner_eval, restore_environment, + (void *) SCM_UNPACK (scm_cons (copied_exp, env_closure)), + (void *) SCM_UNPACK (scm_cons (environment, SCM_BOOL_F))); } #undef FUNC_NAME From 9e07b6667f52d48e24ff585fa0226bba93e73361 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 15 Dec 2000 22:01:30 +0000 Subject: [PATCH 0429/2047] * Avoid using eval-in-module in example code. Thanks to Neil Jerram. --- NEWS | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index d714dcdf2..da16b1ed4 100644 --- a/NEWS +++ b/NEWS @@ -82,8 +82,8 @@ Example: (use-modules (ice-9 safe)) (define m (make-safe-module)) ;;; m will now be a module containing only a safe subset of R5RS -(eval-in-module '(+ 1 2) m) --> 3 -(eval-in-module 'load m) --> ERROR: Unbound variable: load +(eval '(+ 1 2) m) --> 3 +(eval 'load m) --> ERROR: Unbound variable: load * Changes to Scheme functions and syntax From de42a0ee0fc8dcb915e2009893b686c766715dc4 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 15 Dec 2000 23:21:06 +0000 Subject: [PATCH 0430/2047] * New environment variable scm_system_environment to replace scm_symhash. --- libguile/ChangeLog | 11 +++++++++++ libguile/environments.c | 6 ++++++ libguile/environments.h | 2 ++ libguile/init.c | 10 +++++----- 4 files changed, 24 insertions(+), 5 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 9b41ead57..cdd7cceff 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2000-12-16 Dirk Herrmann + + * environments.[ch] (scm_system_environment): New variable, will + replace scm_symhash soon. We may decide for a better name and + also to split this up into a set of environments later. + + (scm_environments_prehistory): Initialize scm_system_environment. + + * init.c (scm_init_guile_1): scm_environments_prehistory requires + storage to be initialized. + 2000-12-15 Dirk Herrmann * eval.c (change_environment, inner_eval, restore_environment): diff --git a/libguile/environments.c b/libguile/environments.c index 85fbea5d5..8e42afa58 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -60,6 +60,8 @@ scm_bits_t scm_tc16_environment; scm_bits_t scm_tc16_observer; #define DEFAULT_OBARRAY_SIZE 137 +SCM scm_system_environment; + /* error conditions */ @@ -2304,6 +2306,10 @@ scm_environments_prehistory () scm_tc16_observer = scm_make_smob_type ("observer", 0); scm_set_smob_mark (scm_tc16_observer, observer_mark); scm_set_smob_print (scm_tc16_observer, observer_print); + + /* create system environment */ + scm_system_environment = scm_make_leaf_environment (); + scm_permanent_object (scm_system_environment); } diff --git a/libguile/environments.h b/libguile/environments.h index 4e0d0b054..04332d0a0 100644 --- a/libguile/environments.h +++ b/libguile/environments.h @@ -121,6 +121,8 @@ extern scm_bits_t scm_tc16_observer; #define SCM_OBSERVER_PROC(x) \ ((scm_environment_observer) SCM_CELL_WORD_3 (x)) +extern SCM scm_system_environment; + extern void scm_error_environment_unbound (const char *, SCM, SCM) SCM_NORETURN; extern void scm_error_environment_immutable_binding (const char *, SCM, SCM) SCM_NORETURN; extern void scm_error_environment_immutable_location (const char *, SCM, SCM) SCM_NORETURN; diff --git a/libguile/init.c b/libguile/init.c index d20cdc236..e180b99ae 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -469,13 +469,13 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_debug_malloc_prehistory (); #endif scm_init_storage (); - scm_struct_prehistory (); /* requires storage */ - scm_symbols_prehistory (); /* requires storage */ - scm_weaks_prehistory (); /* requires storage */ + scm_struct_prehistory (); /* requires storage */ + scm_symbols_prehistory (); /* requires storage */ + scm_weaks_prehistory (); /* requires storage */ scm_init_subr_table (); - scm_environments_prehistory (); /* create the root environment */ + scm_environments_prehistory (); /* requires storage */ scm_init_continuations (); - scm_init_root (); /* requires continuations */ + scm_init_root (); /* requires continuations */ #ifdef USE_THREADS scm_init_threads (base); #endif From 0c8549d8d8de85d86479535b4d0454f2271e70a7 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sat, 16 Dec 2000 18:27:40 +0000 Subject: [PATCH 0431/2047] Added prototype. --- libguile/ChangeLog | 4 ++++ libguile/symbols.h | 1 + 2 files changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index cdd7cceff..16e8db57f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2000-12-16 Keisuke Nishida + + * symbols.h (scm_symbols_prehistory): Added prototype. + 2000-12-16 Dirk Herrmann * environments.[ch] (scm_system_environment): New variable, will diff --git a/libguile/symbols.h b/libguile/symbols.h index bad3cbcd4..94ebc3c20 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -103,6 +103,7 @@ extern SCM scm_symbol_hash (SCM s); extern SCM scm_builtin_bindings (void); extern SCM scm_gensym (SCM prefix); extern SCM scm_gentemp (SCM prefix, SCM obarray); +extern void scm_symbols_prehistory (void); extern void scm_init_symbols (void); From 09a9200ade5ee092445445fa803e2f143b9f6454 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Sat, 16 Dec 2000 19:25:05 +0000 Subject: [PATCH 0432/2047] *** empty log message *** --- devel/tasks.text | 2 -- 1 file changed, 2 deletions(-) diff --git a/devel/tasks.text b/devel/tasks.text index a95ecc88b..9374274a4 100644 --- a/devel/tasks.text +++ b/devel/tasks.text @@ -119,8 +119,6 @@ dirk *** Orbit CORBA interface -livshin - Local Variables: mode: outline From b8d3f9a8ee830ed7710c6b3e3a7c8ca4a5265e2a Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sat, 16 Dec 2000 19:58:28 +0000 Subject: [PATCH 0433/2047] Ignore guile.texi. --- libguile/.cvsignore | 1 + 1 file changed, 1 insertion(+) diff --git a/libguile/.cvsignore b/libguile/.cvsignore index 5a221da57..648719c01 100644 --- a/libguile/.cvsignore +++ b/libguile/.cvsignore @@ -26,6 +26,7 @@ guile-func-name-check guile-procedures.txt guile-snarf guile-snarf.awk +guile.texi libpath.h libtool scmconfig.h From 398d8ee17e6928ce7db571dc7fc22566eee3a795 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sat, 16 Dec 2000 20:25:08 +0000 Subject: [PATCH 0434/2047] Some GOOPS cleanup. --- libguile/ChangeLog | 37 +++ libguile/goops.c | 625 +++++++++++++++++++++----------------------- libguile/goops.h | 14 + libguile/objects.c | 7 +- libguile/validate.h | 5 +- 5 files changed, 363 insertions(+), 325 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 16e8db57f..1cc56f2b4 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,40 @@ +2000-12-16 Keisuke Nishida + + * validate.h (SCM_WRONG_NUM_ARGS): New macro. + * goops.h: #include "libguile/validate.h" + (SCM_CLASSP, SCM_GENERICP, SCM_METHODP): Moved from goops.c with + prefix "SCM_". + (SCM_VALIDATE_INSTANCE, SCM_VALIDATE_ACCESSOR, SCM_VALIDATE_CLASS, + SCM_VALIDATE_GENERIC, SCM_VALIDATE_METHOD): New macros. + * goops.c (CLASSP, GENERICP, METHODP): Moved to goops.h with + prefix "SCM_". + (scm_sys_compute_slots, scm_sys_initialize_object, + scm_sys_prep_layout_x, s_sys_inherit_magic_x, scm_instance_p, + scm_class_name, scm_class_direct_supers, scm_class_direct_slots, + scm_class_direct_subclasses, scm_class_direct_methods, + scm_class_precedence_list, scm_class_slots, scm_class_environment, + scm_generic_function_name, scm_generic_function_methods, + scm_method_generic_function, scm_method_specializers, + scm_method_procedure, scm_accessor_method_slot_definition, + scm_make_unbound, scm_unbound_p, scm_assert_bound, + scm_at_assert_bound_ref, scm_sys_fast_slot_ref, + scm_sys_fast_slot_set_x, scm_slot_ref_using_class, + scm_slot_set_using_class_x, scm_slot_bound_using_class_p, + scm_slot_exists_using_class_p, scm_slot_ref, scm_slot_set_x, + scm_slot_bound_p, scm_slots_exists_p, scm_sys_allocate_instance, + scm_sys_set_object_setter_x, scm_sys_modify_instance, + scm_sys_modify_class, scm_sys_invalidate_class, + scm_sys_invalidate_method_cache_x, scm_generic_capability_p, + scm_enable_primitive_generic_x, scm_primitive_generic_generic, + scm_make, scm_find_method, scm_sys_method_more_specific_p, + scm_pure_generic_p, scm_sys_goops_loaded): Replaced SCM_PROC by + SCM_DEFINE. Use validate macros defined above. + (scm_assert_bound, scm_at_assert_bound_ref, scm_sys_goops_loaded): + Declared as static functions. + (s_class_of, scm_class_of): Replaced SCM_PROC by SCM_DEFINE + in object.c. + * object.c (scm_class_of): Use SCM_DEFINE. + 2000-12-16 Keisuke Nishida * symbols.h (scm_symbols_prehistory): Added prototype. diff --git a/libguile/goops.c b/libguile/goops.c index 18db4aebf..9b0112a85 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -72,15 +72,8 @@ #include "libguile/validate.h" #include "libguile/goops.h" -#define CLASSP(x) (SCM_STRUCTP (x) \ - && SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_METACLASS) -#define GENERICP(x) (SCM_INSTANCEP (x) \ - && SCM_SUBCLASSP (SCM_CLASS_OF (x), scm_class_generic)) -#define METHODP(x) (SCM_INSTANCEP (x) \ - && SCM_SUBCLASSP(SCM_CLASS_OF(x), scm_class_method)) #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers) - #define DEFVAR(v,val) \ { scm_i_eval (SCM_LIST3 (scm_sym_define_public, (v), (val)), \ scm_top_level_env (scm_goops_lookup_closure)); } @@ -166,6 +159,9 @@ SCM_SYMBOL (scm_sym_define_public, "define-public"); static SCM scm_make_unbound (void); static SCM scm_unbound_p (SCM obj); +static SCM scm_assert_bound (SCM value, SCM obj); +static SCM scm_at_assert_bound_ref (SCM obj, SCM index); +static SCM scm_sys_goops_loaded (void); /****************************************************************************** * @@ -296,8 +292,7 @@ SCM_DEFINE (scm_sys_compute_slots, "%compute-slots", 1, 0, 0, "superclasses.") #define FUNC_NAME s_scm_sys_compute_slots { - SCM_ASSERT (CLASSP (class), class, SCM_ARG1, FUNC_NAME); - + SCM_VALIDATE_CLASS (1, class); return build_slots_list (SCM_SLOT (class, scm_si_direct_slots), SCM_SLOT (class, scm_si_cpl)); } @@ -393,25 +388,23 @@ SCM_DEFINE (scm_get_keyword, "get-keyword", 3, 0, 0, #undef FUNC_NAME -SCM_PROC (s_sys_initialize_object, "%initialize-object", 2, 0, 0, scm_sys_initialize_object); - SCM_KEYWORD (k_init_keyword, "init-keyword"); static SCM get_slot_value (SCM class, SCM obj, SCM slotdef); static SCM set_slot_value (SCM class, SCM obj, SCM slotdef, SCM value); -SCM -scm_sys_initialize_object (SCM obj, SCM initargs) +SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0, + (SCM obj, SCM initargs), + "") +#define FUNC_NAME s_scm_sys_initialize_object { SCM tmp, get_n_set, slots; SCM class = SCM_CLASS_OF (obj); int n_initargs; - SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj), - obj, SCM_ARG1, s_sys_initialize_object); + SCM_VALIDATE_INSTANCE (1, obj); n_initargs = scm_ilength (initargs); - SCM_ASSERT ((n_initargs & 1) == 0, - initargs, SCM_ARG2, s_sys_initialize_object); + SCM_ASSERT ((n_initargs & 1) == 0, initargs, SCM_ARG2, FUNC_NAME); get_n_set = SCM_SLOT (class, scm_si_getters_n_setters); slots = SCM_SLOT (class, scm_si_slots); @@ -429,27 +422,25 @@ scm_sys_initialize_object (SCM obj, SCM initargs) /* This slot admits (perhaps) to be initialized at creation time */ int n = scm_ilength (SCM_CDR (slot_name)); if (n & 1) /* odd or -1 */ - scm_misc_error (s_sys_initialize_object, - "class contains bogus slot definition: ~S", + SCM_MISC_ERROR ("class contains bogus slot definition: ~S", SCM_LIST1 (slot_name)); tmp = scm_i_get_keyword (k_init_keyword, SCM_CDR (slot_name), n, 0, - s_sys_initialize_object); + FUNC_NAME); slot_name = SCM_CAR (slot_name); if (tmp) { /* an initarg was provided for this slot */ if (!(SCM_NIMP (tmp) && SCM_KEYWORDP (tmp))) - scm_misc_error (s_sys_initialize_object, - "initarg must be a keyword. It was ~S", + SCM_MISC_ERROR ("initarg must be a keyword. It was ~S", SCM_LIST1 (tmp)); slot_value = scm_i_get_keyword (tmp, initargs, n_initargs, 0, - s_sys_initialize_object); + FUNC_NAME); } } @@ -478,46 +469,40 @@ scm_sys_initialize_object (SCM obj, SCM initargs) return obj; } +#undef FUNC_NAME SCM_KEYWORD (k_class, "class"); -SCM_PROC (s_sys_prep_layout_x, "%prep-layout!", 1, 0, 0, scm_sys_prep_layout_x); - -SCM -scm_sys_prep_layout_x (SCM class) +SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0, + (SCM class), + "") +#define FUNC_NAME s_scm_sys_prep_layout_x { int i, n, len; char *s, p, a; SCM nfields, slots, type; - SCM_ASSERT (SCM_NIMP (class) && SCM_INSTANCEP (class), - class, - SCM_ARG1, - s_sys_prep_layout_x); + SCM_VALIDATE_INSTANCE (1, class); slots = SCM_SLOT (class, scm_si_slots); nfields = SCM_SLOT (class, scm_si_nfields); if (!SCM_INUMP (nfields) || SCM_INUM (nfields) < 0) - scm_misc_error (s_sys_prep_layout_x, - "bad value in nfields slot: ~S", + SCM_MISC_ERROR ("bad value in nfields slot: ~S", SCM_LIST1 (nfields)); n = 2 * SCM_INUM (nfields); if (n < sizeof (SCM_CLASS_CLASS_LAYOUT) - 1 && SCM_SUBCLASSP (class, scm_class_class)) - scm_misc_error (s_sys_prep_layout_x, - "class object doesn't have enough fields: ~S", + SCM_MISC_ERROR ("class object doesn't have enough fields: ~S", SCM_LIST1 (nfields)); - s = n > 0 ? scm_must_malloc (n, s_sys_prep_layout_x) : 0; + s = n > 0 ? scm_must_malloc (n, FUNC_NAME) : 0; for (i = 0; i < n; i += 2) { if (!(SCM_NIMP (slots) && SCM_CONSP (slots))) - scm_misc_error (s_sys_prep_layout_x, - "to few slot definitions", - SCM_EOL); + SCM_MISC_ERROR ("to few slot definitions", SCM_EOL); len = scm_ilength (SCM_CDAR (slots)); type = scm_i_get_keyword (k_class, SCM_CDAR (slots), len, SCM_BOOL_F, - s_sys_prep_layout_x); + FUNC_NAME); if (SCM_NIMP (type) && SCM_SUBCLASSP (type, scm_class_foreign_slot)) { if (SCM_SUBCLASSP (type, scm_class_self)) @@ -548,20 +533,18 @@ scm_sys_prep_layout_x (SCM class) scm_must_free (s); return SCM_UNSPECIFIED; } +#undef FUNC_NAME static void prep_hashsets (SCM); -SCM_PROC (s_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0, scm_sys_inherit_magic_x); - -SCM -scm_sys_inherit_magic_x (SCM class, SCM dsupers) +SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0, + (SCM class, SCM dsupers), + "") +#define FUNC_NAME s_scm_sys_inherit_magic_x { SCM ls = dsupers; long flags = 0; - SCM_ASSERT (SCM_NIMP (class) && SCM_INSTANCEP (class), - class, - SCM_ARG1, - s_sys_inherit_magic_x); + SCM_VALIDATE_INSTANCE (1, class); while (SCM_NNULLP (ls)) { SCM_ASSERT (SCM_NIMP (ls) @@ -570,7 +553,7 @@ scm_sys_inherit_magic_x (SCM class, SCM dsupers) && SCM_INSTANCEP (SCM_CAR (ls)), dsupers, SCM_ARG2, - s_sys_inherit_magic_x); + FUNC_NAME); flags |= SCM_CLASS_FLAGS (SCM_CAR (ls)); ls = SCM_CDR (ls); } @@ -603,6 +586,7 @@ scm_sys_inherit_magic_x (SCM class, SCM dsupers) return SCM_UNSPECIFIED; } +#undef FUNC_NAME void prep_hashsets (SCM class) @@ -796,161 +780,162 @@ create_basic_classes (void) /******************************************************************************/ -SCM_PROC (s_instance_p, "instance?", 1, 0, 0, scm_instance_p); - -SCM -scm_instance_p (SCM obj) +SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_instance_p { return SCM_NIMP (obj) && SCM_INSTANCEP (obj) ? SCM_BOOL_T : SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC (s_class_of, "class-of", 1, 0, 0, scm_class_of); -/* scm_class_of is defined in libguile */ /****************************************************************************** * * Meta object accessors * ******************************************************************************/ -SCM_PROC (s_class_name, "class-name", 1, 0, 0, scm_class_name); - -SCM -scm_class_name (SCM obj) +SCM_DEFINE (scm_class_name, "class-name", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_class_name { - SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), obj, SCM_ARG1, s_class_name); + SCM_VALIDATE_CLASS (1, obj); return scm_slot_ref (obj, scm_str2symbol ("name")); } +#undef FUNC_NAME -SCM_PROC (s_class_direct_supers, "class-direct-supers", 1, 0, 0, scm_class_direct_supers); - -SCM -scm_class_direct_supers (SCM obj) +SCM_DEFINE (scm_class_direct_supers, "class-direct-supers", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_class_direct_supers { - SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), obj, SCM_ARG1, s_class_direct_supers); + SCM_VALIDATE_CLASS (1, obj); return scm_slot_ref (obj, scm_str2symbol ("direct-supers")); } +#undef FUNC_NAME -SCM_PROC (s_class_direct_slots, "class-direct-slots", 1, 0, 0, scm_class_direct_slots); - -SCM -scm_class_direct_slots (SCM obj) +SCM_DEFINE (scm_class_direct_slots, "class-direct-slots", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_class_direct_slots { - SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), - obj, SCM_ARG1, s_class_direct_slots); + SCM_VALIDATE_CLASS (1, obj); return scm_slot_ref (obj, scm_str2symbol ("direct-slots")); } +#undef FUNC_NAME -SCM_PROC (s_class_direct_subclasses, "class-direct-subclasses", 1, 0, 0, scm_class_direct_subclasses); - -SCM -scm_class_direct_subclasses (SCM obj) +SCM_DEFINE (scm_class_direct_subclasses, "class-direct-subclasses", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_class_direct_subclasses { - SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), - obj, SCM_ARG1, s_class_direct_subclasses); + SCM_VALIDATE_CLASS (1, obj); return scm_slot_ref(obj, scm_str2symbol ("direct-subclasses")); } +#undef FUNC_NAME -SCM_PROC (s_class_direct_methods, "class-direct-methods", 1, 0, 0, scm_class_direct_methods); - -SCM -scm_class_direct_methods (SCM obj) +SCM_DEFINE (scm_class_direct_methods, "class-direct-methods", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_class_direct_methods { - SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), - obj, SCM_ARG1, s_class_direct_methods); + SCM_VALIDATE_CLASS (1, obj); return scm_slot_ref (obj, scm_str2symbol ("direct-methods")); } +#undef FUNC_NAME -SCM_PROC (s_class_direct_precedence_list, "class-precedence-list", 1, 0, 0, scm_class_precedence_list); - -SCM -scm_class_precedence_list (SCM obj) +SCM_DEFINE (scm_class_precedence_list, "class-precedence-list", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_class_precedence_list { - SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), - obj, SCM_ARG1, s_class_direct_precedence_list); + SCM_VALIDATE_CLASS (1, obj); return scm_slot_ref (obj, scm_str2symbol ("cpl")); } +#undef FUNC_NAME -SCM_PROC (s_class_slots, "class-slots", 1, 0, 0, scm_class_slots); - -SCM -scm_class_slots (SCM obj) +SCM_DEFINE (scm_class_slots, "class-slots", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_class_slots { - SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), - obj, SCM_ARG1, s_class_slots); + SCM_VALIDATE_CLASS (1, obj); return scm_slot_ref (obj, scm_str2symbol ("slots")); } +#undef FUNC_NAME -SCM_PROC (s_class_environment, "class-environment", 1, 0, 0, scm_class_environment); - -SCM -scm_class_environment (SCM obj) +SCM_DEFINE (scm_class_environment, "class-environment", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_class_environment { - SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), - obj, SCM_ARG1, s_class_environment); + SCM_VALIDATE_CLASS (1, obj); return scm_slot_ref(obj, scm_str2symbol ("environment")); } +#undef FUNC_NAME -SCM_PROC (s_generic_function_name, "generic-function-name", 1, 0, 0, scm_generic_function_name); - -SCM -scm_generic_function_name (SCM obj) +SCM_DEFINE (scm_generic_function_name, "generic-function-name", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_generic_function_name { - SCM_ASSERT (SCM_NIMP (obj) && GENERICP (obj), - obj, SCM_ARG1, s_generic_function_name); + SCM_VALIDATE_GENERIC (1, obj); return scm_procedure_property (obj, scm_sym_name); } +#undef FUNC_NAME -SCM_PROC (s_generic_function_methods, "generic-function-methods", 1, 0, 0, scm_generic_function_methods); - -SCM -scm_generic_function_methods (SCM obj) +SCM_DEFINE (scm_generic_function_methods, "generic-function-methods", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_generic_function_methods { - SCM_ASSERT (SCM_NIMP (obj) && GENERICP (obj), - obj, SCM_ARG1, s_generic_function_methods); + SCM_VALIDATE_GENERIC (1, obj); return scm_slot_ref (obj, scm_str2symbol ("methods")); } +#undef FUNC_NAME -SCM_PROC (s_method_generic_function, "method-generic-function", 1, 0, 0, scm_method_generic_function); - -SCM -scm_method_generic_function (SCM obj) +SCM_DEFINE (scm_method_generic_function, "method-generic-function", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_method_generic_function { - SCM_ASSERT (SCM_NIMP (obj) && METHODP (obj), - obj, SCM_ARG1, s_method_generic_function); + SCM_VALIDATE_METHOD (1, obj); return scm_slot_ref (obj, scm_str2symbol ("generic-function")); } +#undef FUNC_NAME -SCM_PROC (s_method_specializers, "method-specializers", 1, 0, 0, scm_method_specializers); - -SCM -scm_method_specializers (SCM obj) +SCM_DEFINE (scm_method_specializers, "method-specializers", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_method_specializers { - SCM_ASSERT (SCM_NIMP (obj) && METHODP (obj), - obj, SCM_ARG1, s_method_specializers); + SCM_VALIDATE_METHOD (1, obj); return scm_slot_ref (obj, scm_str2symbol ("specializers")); } +#undef FUNC_NAME -SCM_PROC (s_method_procedure, "method-procedure", 1, 0, 0, scm_method_procedure); - -SCM -scm_method_procedure (SCM obj) +SCM_DEFINE (scm_method_procedure, "method-procedure", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_method_procedure { - SCM_ASSERT (SCM_NIMP (obj) && METHODP (obj), - obj, SCM_ARG1, s_method_procedure); + SCM_VALIDATE_METHOD (1, obj); return scm_slot_ref (obj, scm_str2symbol ("procedure")); } +#undef FUNC_NAME -SCM_PROC (s_accessor_method_slot_definition, "accessor-method-slot-definition", 1, 0, 0, scm_accessor_method_slot_definition); - -SCM -scm_accessor_method_slot_definition (SCM obj) +SCM_DEFINE (scm_accessor_method_slot_definition, "accessor-method-slot-definition", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_accessor_method_slot_definition { - SCM_ASSERT (SCM_NIMP (obj) && SCM_ACCESSORP (obj), - obj, SCM_ARG1, s_method_procedure); + SCM_VALIDATE_ACCESSOR (1, obj); return scm_slot_ref (obj, scm_str2symbol ("slot-definition")); -} +} +#undef FUNC_NAME /****************************************************************************** @@ -959,54 +944,56 @@ scm_accessor_method_slot_definition (SCM obj) * ******************************************************************************/ -SCM_PROC (s_make_unbound, "make-unbound", 0, 0, 0, scm_make_unbound); - -static SCM -scm_make_unbound () +SCM_DEFINE (scm_make_unbound, "make-unbound", 0, 0, 0, + (), + "") +#define FUNC_NAME s_scm_make_unbound { return SCM_GOOPS_UNBOUND; } +#undef FUNC_NAME -SCM_PROC (s_unbound_p, "unbound?", 1, 0, 0, scm_unbound_p); - -static SCM -scm_unbound_p (SCM obj) +SCM_DEFINE (scm_unbound_p, "unbound?", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_unbound_p { return SCM_GOOPS_UNBOUNDP (obj) ? SCM_BOOL_T : SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC (s_assert_bound, "assert-bound", 2, 0, 0, scm_assert_bound); - -static SCM -scm_assert_bound (SCM value, SCM obj) +SCM_DEFINE (scm_assert_bound, "assert-bound", 2, 0, 0, + (SCM value, SCM obj), + "") +#define FUNC_NAME s_scm_assert_bound { if (SCM_GOOPS_UNBOUNDP (value)) return CALL_GF1 ("slot-unbound", obj); return value; } +#undef FUNC_NAME -SCM_PROC (s_at_assert_bound_ref, "@assert-bound-ref", 2, 0, 0, scm_at_assert_bound_ref); - -static SCM -scm_at_assert_bound_ref (SCM obj, SCM index) +SCM_DEFINE (scm_at_assert_bound_ref, "@assert-bound-ref", 2, 0, 0, + (SCM obj, SCM index), + "") +#define FUNC_NAME s_scm_at_assert_bound_ref { SCM value = SCM_SLOT (obj, SCM_INUM (index)); if (SCM_GOOPS_UNBOUNDP (value)) return CALL_GF1 ("slot-unbound", obj); return value; } +#undef FUNC_NAME -SCM_PROC (s_sys_fast_slot_ref, "%fast-slot-ref", 2, 0, 0, scm_sys_fast_slot_ref); - -SCM -scm_sys_fast_slot_ref (SCM obj, SCM index) -#define FUNC_NAME s_sys_fast_slot_ref +SCM_DEFINE (scm_sys_fast_slot_ref, "%fast-slot-ref", 2, 0, 0, + (SCM obj, SCM index), + "") +#define FUNC_NAME s_scm_sys_fast_slot_ref { register long i; - SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj), - obj, SCM_ARG1, s_sys_fast_slot_ref); - SCM_ASSERT (SCM_INUMP (index), index, SCM_ARG2, s_sys_fast_slot_ref); + SCM_VALIDATE_INSTANCE (1, obj); + SCM_VALIDATE_INUM (2, index); i = SCM_INUM (index); SCM_ASSERT_RANGE (2, index, i >= 0 && i < SCM_NUMBER_OF_SLOTS (obj)); @@ -1014,18 +1001,15 @@ scm_sys_fast_slot_ref (SCM obj, SCM index) } #undef FUNC_NAME - -SCM_PROC (s_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0, scm_sys_fast_slot_set_x); - -SCM -scm_sys_fast_slot_set_x (SCM obj, SCM index, SCM value) -#define FUNC_NAME s_sys_fast_slot_set_x +SCM_DEFINE (scm_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0, + (SCM obj, SCM index, SCM value), + "") +#define FUNC_NAME s_scm_sys_fast_slot_set_x { register long i; - SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj), - obj, SCM_ARG1, s_sys_fast_slot_set_x); - SCM_ASSERT (SCM_INUMP (index), index, SCM_ARG2, s_sys_fast_slot_set_x); + SCM_VALIDATE_INSTANCE (1, obj); + SCM_VALIDATE_INUM (2, index); i = SCM_INUM (index); SCM_ASSERT_RANGE (2, index, i >= 0 && i < SCM_NUMBER_OF_SLOTS (obj)); SCM_SLOT (obj, i) = value; @@ -1152,9 +1136,9 @@ SCM_DEFINE (scm_slot_ref_using_class, "slot-ref-using-class", 3, 0, 0, { SCM res; - SCM_ASSERT (CLASSP (class), class, SCM_ARG1, FUNC_NAME); - SCM_ASSERT (SCM_INSTANCEP (obj), obj, SCM_ARG1, FUNC_NAME); - SCM_ASSERT (SCM_SYMBOLP (slot_name), obj, SCM_ARG3, FUNC_NAME); + SCM_VALIDATE_CLASS (1, class); + SCM_VALIDATE_INSTANCE (2, obj); + SCM_VALIDATE_SYMBOL (3, slot_name); res = get_slot_value_using_name (class, obj, slot_name); if (SCM_GOOPS_UNBOUNDP (res)) @@ -1169,58 +1153,53 @@ SCM_DEFINE (scm_slot_set_using_class_x, "slot-set-using-class!", 4, 0, 0, "") #define FUNC_NAME s_scm_slot_set_using_class_x { - SCM_ASSERT (CLASSP (class), class, SCM_ARG1, FUNC_NAME); - SCM_ASSERT (SCM_INSTANCEP (obj), obj, SCM_ARG2, FUNC_NAME); - SCM_ASSERT (SCM_SYMBOLP (slot_name), obj, SCM_ARG3, FUNC_NAME); + SCM_VALIDATE_CLASS (1, class); + SCM_VALIDATE_INSTANCE (2, obj); + SCM_VALIDATE_SYMBOL (3, slot_name); return set_slot_value_using_name (class, obj, slot_name, value); } #undef FUNC_NAME -SCM_PROC (s_slot_bound_using_class_p, "slot-bound-using-class?", 3, 0, 0, scm_slot_bound_using_class_p); - -SCM -scm_slot_bound_using_class_p (SCM class, SCM obj, SCM slot_name) +SCM_DEFINE (scm_slot_bound_using_class_p, "slot-bound-using-class?", 3, 0, 0, + (SCM class, SCM obj, SCM slot_name), + "") +#define FUNC_NAME s_scm_slot_bound_using_class_p { - SCM_ASSERT (SCM_NIMP (class) && CLASSP (class), - class, SCM_ARG1, s_slot_bound_using_class_p); - SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj), - obj, SCM_ARG2, s_slot_bound_using_class_p); - SCM_ASSERT (SCM_NIMP (slot_name) && SCM_SYMBOLP (slot_name), - obj, SCM_ARG3, s_slot_bound_using_class_p); + SCM_VALIDATE_CLASS (1, class); + SCM_VALIDATE_INSTANCE (2, obj); + SCM_VALIDATE_SYMBOL (3, slot_name); return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj, slot_name)) ? SCM_BOOL_F : SCM_BOOL_T); } +#undef FUNC_NAME -SCM_PROC (s_slot_exists_using_class_p, "slot-exists-using-class?", 3, 0, 0, scm_slot_exists_using_class_p); - -SCM -scm_slot_exists_using_class_p (SCM class, SCM obj, SCM slot_name) +SCM_DEFINE (scm_slot_exists_using_class_p, "slot-exists-using-class?", 3, 0, 0, + (SCM class, SCM obj, SCM slot_name), + "") +#define FUNC_NAME s_scm_slot_exists_using_class_p { - SCM_ASSERT (SCM_NIMP (class) && CLASSP (class), - class, SCM_ARG1, s_slot_exists_using_class_p); - SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj), - obj, SCM_ARG2, s_slot_exists_using_class_p); - SCM_ASSERT (SCM_NIMP (slot_name) && SCM_SYMBOLP (slot_name), - obj, SCM_ARG3, s_slot_exists_using_class_p); + SCM_VALIDATE_CLASS (1, class); + SCM_VALIDATE_INSTANCE (2, obj); + SCM_VALIDATE_SYMBOL (3, slot_name); return test_slot_existence (class, obj, slot_name); } +#undef FUNC_NAME /* ======================================== */ -SCM_PROC (s_slot_ref, "slot-ref", 2, 0, 0, scm_slot_ref); - -SCM -scm_slot_ref (SCM obj, SCM slot_name) +SCM_DEFINE (scm_slot_ref, "slot-ref", 2, 0, 0, + (SCM obj, SCM slot_name), + "") +#define FUNC_NAME s_scm_slot_ref { SCM res, class; - SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj), - obj, SCM_ARG1, s_slot_ref); + SCM_VALIDATE_INSTANCE (1, obj); TEST_CHANGE_CLASS (obj, class); res = get_slot_value_using_name (class, obj, slot_name); @@ -1228,32 +1207,32 @@ scm_slot_ref (SCM obj, SCM slot_name) return CALL_GF3 ("slot-unbound", class, obj, slot_name); return res; } +#undef FUNC_NAME -SCM_PROC (s_slot_set_x, "slot-set!", 3, 0, 0, scm_slot_set_x); - -const char *scm_s_slot_set_x = s_slot_set_x; - -SCM -scm_slot_set_x (SCM obj, SCM slot_name, SCM value) +SCM_DEFINE (scm_slot_set_x, "slot-set!", 3, 0, 0, + (SCM obj, SCM slot_name, SCM value), + "") +#define FUNC_NAME s_scm_slot_set_x { SCM class; - SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj), - obj, SCM_ARG1, s_slot_set_x); + SCM_VALIDATE_INSTANCE (1, obj); TEST_CHANGE_CLASS(obj, class); return set_slot_value_using_name (class, obj, slot_name, value); } +#undef FUNC_NAME -SCM_PROC (s_slot_bound_p, "slot-bound?", 2, 0, 0, scm_slot_bound_p); +const char *scm_s_slot_set_x = s_scm_slot_set_x; -SCM -scm_slot_bound_p (SCM obj, SCM slot_name) +SCM_DEFINE (scm_slot_bound_p, "slot-bound?", 2, 0, 0, + (SCM obj, SCM slot_name), + "") +#define FUNC_NAME s_scm_slot_bound_p { SCM class; - SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj), - obj, SCM_ARG1, s_slot_bound_p); + SCM_VALIDATE_INSTANCE (1, obj); TEST_CHANGE_CLASS(obj, class); return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, @@ -1262,22 +1241,22 @@ scm_slot_bound_p (SCM obj, SCM slot_name) ? SCM_BOOL_F : SCM_BOOL_T); } +#undef FUNC_NAME -SCM_PROC (s_slot_exists_p, "slot-exists?", 2, 0, 0, scm_slots_exists_p); - -SCM -scm_slots_exists_p (SCM obj, SCM slot_name) +SCM_DEFINE (scm_slots_exists_p, "slot-exists?", 2, 0, 0, + (SCM obj, SCM slot_name), + "") +#define FUNC_NAME s_scm_slots_exists_p { SCM class; - SCM_ASSERT (SCM_NIMP (obj) && SCM_INSTANCEP (obj), - obj, SCM_ARG1, s_slot_exists_p); - SCM_ASSERT (SCM_NIMP (slot_name) && SCM_SYMBOLP (slot_name), - slot_name, SCM_ARG2, s_slot_exists_p); + SCM_VALIDATE_INSTANCE (1, obj); + SCM_VALIDATE_SYMBOL (2, slot_name); TEST_CHANGE_CLASS (obj, class); return test_slot_existence (class, obj, slot_name); } +#undef FUNC_NAME /****************************************************************************** @@ -1306,16 +1285,15 @@ wrap_init (SCM class, SCM *m, int n) return z; } -SCM_PROC (s_sys_allocate_instance, "%allocate-instance", 2, 0, 0, scm_sys_allocate_instance); - -SCM -scm_sys_allocate_instance (SCM class, SCM initargs) +SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0, + (SCM class, SCM initargs), + "") +#define FUNC_NAME s_scm_sys_allocate_instance { SCM *m; int n; - SCM_ASSERT (SCM_NIMP (class) && CLASSP (class), - class, SCM_ARG1, s_sys_allocate_instance); + SCM_VALIDATE_CLASS (1, class); /* Most instances */ if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT) @@ -1378,24 +1356,26 @@ scm_sys_allocate_instance (SCM class, SCM initargs) return wrap_init (class, m, n); } } +#undef FUNC_NAME -SCM_PROC (s_sys_set_object_setter_x, "%set-object-setter!", 2, 0, 0, scm_sys_set_object_setter_x); - -SCM -scm_sys_set_object_setter_x (SCM obj, SCM setter) +SCM_DEFINE (scm_sys_set_object_setter_x, "%set-object-setter!", 2, 0, 0, + (SCM obj, SCM setter), + "") +#define FUNC_NAME s_scm_sys_set_object_setter_x { SCM_ASSERT (SCM_NIMP (obj) && SCM_STRUCTP (obj) && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR) || SCM_I_ENTITYP (obj)), obj, SCM_ARG1, - s_sys_set_object_setter_x); + FUNC_NAME); if (SCM_I_ENTITYP (obj)) SCM_ENTITY_SETTER (obj) = setter; else SCM_OPERATOR_CLASS (obj)->setter = setter; return SCM_UNSPECIFIED; } +#undef FUNC_NAME /****************************************************************************** * @@ -1403,15 +1383,13 @@ scm_sys_set_object_setter_x (SCM obj, SCM setter) * ******************************************************************************/ -SCM_PROC (s_sys_modify_instance, "%modify-instance", 2, 0, 0, scm_sys_modify_instance); - -SCM -scm_sys_modify_instance (SCM old, SCM new) +SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0, + (SCM old, SCM new), + "") +#define FUNC_NAME s_scm_sys_modify_instance { - SCM_ASSERT (SCM_NIMP (old) && SCM_INSTANCEP (old), - old, SCM_ARG1, s_sys_modify_instance); - SCM_ASSERT (SCM_NIMP (new) && SCM_INSTANCEP (new), - new, SCM_ARG2, s_sys_modify_instance); + SCM_VALIDATE_INSTANCE (1, old); + SCM_VALIDATE_INSTANCE (2, new); /* Exchange the data contained in old and new. We exchange rather than * scratch the old value with new to be correct with GC. @@ -1429,16 +1407,15 @@ scm_sys_modify_instance (SCM old, SCM new) SCM_REALLOW_INTS; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_sys_modify_class, "%modify-class", 2, 0, 0, scm_sys_modify_class); - -SCM -scm_sys_modify_class (SCM old, SCM new) +SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0, + (SCM old, SCM new), + "") +#define FUNC_NAME s_scm_sys_modify_class { - SCM_ASSERT (SCM_NIMP (old) && CLASSP (old), - old, SCM_ARG1, s_sys_modify_class); - SCM_ASSERT (SCM_NIMP (new) && CLASSP (new), - new, SCM_ARG2, s_sys_modify_class); + SCM_VALIDATE_CLASS (1, old); + SCM_VALIDATE_CLASS (2, new); SCM_REDEFER_INTS; { @@ -1454,18 +1431,18 @@ scm_sys_modify_class (SCM old, SCM new) SCM_REALLOW_INTS; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_sys_invalidate_class, "%invalidate-class", 1, 0, 0, scm_sys_invalidate_class); - -SCM -scm_sys_invalidate_class (SCM class) +SCM_DEFINE (scm_sys_invalidate_class, "%invalidate-class", 1, 0, 0, + (SCM class), + "") +#define FUNC_NAME s_scm_sys_invalidate_class { - SCM_ASSERT (SCM_NIMP (class) && CLASSP (class), - class, SCM_ARG1, s_sys_invalidate_class); - + SCM_VALIDATE_CLASS (1, class); SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID); return SCM_UNSPECIFIED; } +#undef FUNC_NAME /* When instances change class, they finally get a new body, but * before that, they go through purgatory in hell. Odd as it may @@ -1576,14 +1553,14 @@ clear_method_cache (SCM gf) SCM_SLOT (gf, scm_si_used_by) = SCM_BOOL_F; } -SCM_PROC (s_sys_invalidate_method_cache_x, "%invalidate-method-cache!", 1, 0, 0, scm_sys_invalidate_method_cache_x); - -SCM -scm_sys_invalidate_method_cache_x (SCM gf) +SCM_DEFINE (scm_sys_invalidate_method_cache_x, "%invalidate-method-cache!", 1, 0, 0, + (SCM gf), + "") +#define FUNC_NAME s_scm_sys_invalidate_method_cache_x { SCM used_by; SCM_ASSERT (SCM_NIMP (gf) && SCM_STRUCTP (gf) && SCM_PUREGENERICP (gf), - gf, SCM_ARG1, s_sys_invalidate_method_cache_x); + gf, SCM_ARG1, FUNC_NAME); used_by = SCM_SLOT (gf, scm_si_used_by); if (SCM_NFALSEP (used_by)) { @@ -1603,29 +1580,31 @@ scm_sys_invalidate_method_cache_x (SCM gf) } return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_generic_capability_p, "generic-capability?", 1, 0, 0, scm_generic_capability_p); - -SCM -scm_generic_capability_p (SCM proc) +SCM_DEFINE (scm_generic_capability_p, "generic-capability?", 1, 0, 0, + (SCM proc), + "") +#define FUNC_NAME s_scm_generic_capability_p { SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (proc)), - proc, SCM_ARG1, s_generic_capability_p); + proc, SCM_ARG1, FUNC_NAME); return (scm_subr_p (proc) && SCM_SUBR_GENERIC (proc) ? SCM_BOOL_T : SCM_BOOL_F); } +#undef FUNC_NAME -SCM_PROC (s_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1, scm_enable_primitive_generic_x); - -SCM -scm_enable_primitive_generic_x (SCM subrs) +SCM_DEFINE (scm_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1, + (SCM subrs), + "") +#define FUNC_NAME s_scm_enable_primitive_generic_x { while (SCM_NIMP (subrs)) { SCM subr = SCM_CAR (subrs); SCM_ASSERT (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr), - subr, SCM_ARGn, s_enable_primitive_generic_x); + subr, SCM_ARGn, FUNC_NAME); *SCM_SUBR_GENERIC (subr) = scm_make (SCM_LIST3 (scm_class_generic, k_name, @@ -1634,11 +1613,12 @@ scm_enable_primitive_generic_x (SCM subrs) } return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0, scm_primitive_generic_generic); - -SCM -scm_primitive_generic_generic (SCM subr) +SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0, + (SCM subr), + "") +#define FUNC_NAME s_scm_primitive_generic_generic { if (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr)) { @@ -1646,8 +1626,9 @@ scm_primitive_generic_generic (SCM subr) if (gf) return gf; } - return scm_wta (subr, (char *) SCM_ARG1, s_primitive_generic_generic); + return scm_wta (subr, (char *) SCM_ARG1, FUNC_NAME); } +#undef FUNC_NAME /****************************************************************************** * @@ -1860,14 +1841,15 @@ static const char s_sys_compute_applicable_methods[] = "%compute-applicable-meth SCM scm_sys_compute_applicable_methods (SCM gf, SCM args) +#define FUNC_NAME s_sys_compute_applicable_methods { int n; - SCM_ASSERT (SCM_NIMP (gf) && GENERICP (gf), - gf, SCM_ARG1, s_sys_compute_applicable_methods); + SCM_VALIDATE_GENERIC (1, gf); n = scm_ilength (args); - SCM_ASSERT (n >= 0, args, SCM_ARG2, s_sys_compute_applicable_methods); + SCM_ASSERT (n >= 0, args, SCM_ARG2, FUNC_NAME); return scm_compute_applicable_methods (gf, args, n, 1); } +#undef FUNC_NAME SCM_VCELL_INIT (var_compute_applicable_methods, "compute-applicable-methods", scm_make_gsubr (s_sys_compute_applicable_methods, 2, 0, 0, scm_sys_compute_applicable_methods)); @@ -1986,16 +1968,16 @@ SCM_KEYWORD (k_dsupers, "dsupers"); SCM_KEYWORD (k_slots, "slots"); SCM_KEYWORD (k_gf, "generic-function"); -SCM_PROC (s_make, "make", 0, 0, 1, scm_make); - -SCM -scm_make (SCM args) +SCM_DEFINE (scm_make, "make", 0, 0, 1, + (SCM args), + "") +#define FUNC_NAME s_scm_make { SCM class, z; int len = scm_ilength (args); if (len <= 0 || (len & 1) == 0) - scm_wrong_num_args (scm_makfrom0str (s_make)); + SCM_WRONG_NUM_ARGS (); class = SCM_CAR(args); args = SCM_CDR(args); @@ -2037,19 +2019,19 @@ scm_make (SCM args) args, len - 1, SCM_BOOL_F, - s_make); + FUNC_NAME); SCM_SLOT (z, scm_si_specializers) = scm_i_get_keyword (k_specializers, args, len - 1, SCM_EOL, - s_make); + FUNC_NAME); SCM_SLOT (z, scm_si_procedure) = scm_i_get_keyword (k_procedure, args, len - 1, SCM_EOL, - s_make); + FUNC_NAME); SCM_SLOT (z, scm_si_code_table) = SCM_EOL; } else @@ -2060,70 +2042,67 @@ scm_make (SCM args) args, len - 1, scm_str2symbol ("???"), - s_make); + FUNC_NAME); SCM_SLOT (z, scm_si_direct_supers) = scm_i_get_keyword (k_dsupers, args, len - 1, SCM_EOL, - s_make); + FUNC_NAME); SCM_SLOT (z, scm_si_direct_slots) = scm_i_get_keyword (k_slots, args, len - 1, SCM_EOL, - s_make); + FUNC_NAME); } } return z; } +#undef FUNC_NAME -SCM_PROC (s_find_method, "find-method", 0, 0, 1, scm_find_method); - -SCM -scm_find_method (SCM l) +SCM_DEFINE (scm_find_method, "find-method", 0, 0, 1, + (SCM l), + "") +#define FUNC_NAME s_scm_find_method { SCM gf; int len = scm_ilength (l); if (len == 0) - scm_wrong_num_args (scm_makfrom0str (s_find_method)); + SCM_WRONG_NUM_ARGS (); gf = SCM_CAR(l); l = SCM_CDR(l); - SCM_ASSERT (SCM_NIMP (gf) && GENERICP (gf), gf, SCM_ARG1, s_find_method); + SCM_VALIDATE_GENERIC (1, gf); if (SCM_NULLP (SCM_SLOT (gf, scm_si_methods))) - scm_misc_error (s_find_method, - "no methods for generic ~S", - SCM_LIST1 (gf)); + SCM_MISC_ERROR ("no methods for generic ~S", SCM_LIST1 (gf)); return scm_compute_applicable_methods (gf, l, len - 1, 1); } +#undef FUNC_NAME -SCM_PROC (s_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0, scm_sys_method_more_specific_p); - -SCM -scm_sys_method_more_specific_p (SCM m1, SCM m2, SCM targs) +SCM_DEFINE (scm_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0, + (SCM m1, SCM m2, SCM targs), + "") +#define FUNC_NAME s_scm_sys_method_more_specific_p { SCM l, v; int i, len; - SCM_ASSERT (SCM_NIMP (m1) && METHODP (m1), - m1, SCM_ARG1, s_sys_method_more_specific_p); - SCM_ASSERT (SCM_NIMP (m2) && METHODP (m2), - m2, SCM_ARG2, s_sys_method_more_specific_p); - SCM_ASSERT ((len = scm_ilength (targs)) != -1, - targs, SCM_ARG3, s_sys_method_more_specific_p); + SCM_VALIDATE_METHOD (1, m1); + SCM_VALIDATE_METHOD (2, m2); + SCM_ASSERT ((len = scm_ilength (targs)) != -1, targs, SCM_ARG3, FUNC_NAME); /* Verify that all the arguments of targs are classes and place them in a vector*/ v = scm_make_vector (SCM_MAKINUM (len), SCM_EOL); for (i=0, l=targs; SCM_NNULLP(l); i++, l=SCM_CDR(l)) { - SCM_ASSERT (SCM_NIMP (SCM_CAR (l)) && CLASSP (SCM_CAR (l)), - targs, SCM_ARG3, s_sys_method_more_specific_p); + SCM_ASSERT (SCM_CLASSP (SCM_CAR (l)), targs, SCM_ARG3, FUNC_NAME); SCM_VELTS(v)[i] = SCM_CAR(l); } return more_specificp (m1, m2, SCM_VELTS(v)) ? SCM_BOOL_T: SCM_BOOL_F; } +#undef FUNC_NAME @@ -2458,7 +2437,7 @@ scm_make_foreign_object (SCM class, SCM initargs) void * (*constructor) (SCM) = (void * (*) (SCM)) SCM_SLOT (class, scm_si_constructor); SCM_ASSERT (constructor != 0, class, "Can't make instances of this class", - s_make); + s_scm_make); return scm_wrap_object (class, constructor (initargs)); } @@ -2623,15 +2602,16 @@ scm_add_method (SCM gf, SCM m) * Debugging utilities */ -SCM_PROC (s_pure_generic_p, "pure-generic?", 1, 0, 0, scm_pure_generic_p); - -SCM -scm_pure_generic_p (SCM obj) +SCM_DEFINE (scm_pure_generic_p, "pure-generic?", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_pure_generic_p { return (SCM_NIMP (obj) && SCM_STRUCTP (obj) && SCM_PUREGENERICP (obj) ? SCM_BOOL_T : SCM_BOOL_F); } +#undef FUNC_NAME #endif /* GUILE_DEBUG */ @@ -2639,10 +2619,10 @@ scm_pure_generic_p (SCM obj) * Initialization */ -SCM_PROC (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0, sys_goops_loaded); - -static SCM -sys_goops_loaded () +SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0, + (), + "") +#define FUNC_NAME s_scm_sys_goops_loaded { goops_loaded_p = 1; var_compute_applicable_methods @@ -2652,6 +2632,7 @@ sys_goops_loaded () SCM_EOL)); return SCM_UNSPECIFIED; } +#undef FUNC_NAME SCM scm_module_goops; diff --git a/libguile/goops.h b/libguile/goops.h index 2092f9082..d9f792e0f 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -53,6 +53,8 @@ #include "libguile/__scm.h" +#include "libguile/validate.h" + /* * scm_class_class */ @@ -125,10 +127,12 @@ typedef struct scm_method_t { #define SCM_INSTANCEP(x) (SCM_STRUCTP (x) \ && (SCM_INST_TYPE (x) & SCM_CLASSF_GOOPS)) +#define SCM_VALIDATE_INSTANCE(pos, x) SCM_MAKE_VALIDATE (pos, x, INSTANCEP) #define SCM_PUREGENERICP(x) (SCM_INST_TYPE(x) & SCM_CLASSF_PURE_GENERIC) #define SCM_SIMPLEMETHODP(x) (SCM_INST_TYPE(x) & SCM_CLASSF_SIMPLE_METHOD) #define SCM_ACCESSORP(x) (SCM_INST_TYPE(x) & SCM_CLASSF_ACCESSOR_METHOD) +#define SCM_VALIDATE_ACCESSOR(pos, x) SCM_MAKE_VALIDATE (pos, x, ACCESSORP) #define SCM_FASTMETHODP(x) (SCM_INST_TYPE(x) \ & (SCM_CLASSF_ACCESSOR_METHOD \ | SCM_CLASSF_SIMPLE_METHOD)) @@ -139,6 +143,16 @@ typedef struct scm_method_t { && SCM_INSTANCEP (x) \ && SCM_SUBCLASSP (SCM_CLASS_OF (x), c)) +#define SCM_CLASSP(x) (SCM_STRUCTP (x) \ + && SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_METACLASS) +#define SCM_VALIDATE_CLASS(pos, x) SCM_MAKE_VALIDATE (pos, x, CLASSP) +#define SCM_GENERICP(x) (SCM_INSTANCEP (x) \ + && SCM_SUBCLASSP (SCM_CLASS_OF (x), scm_class_generic)) +#define SCM_VALIDATE_GENERIC(pos, x) SCM_MAKE_VALIDATE (pos, x, GENERICP) +#define SCM_METHODP(x) (SCM_INSTANCEP (x) \ + && SCM_SUBCLASSP(SCM_CLASS_OF(x), scm_class_method)) +#define SCM_VALIDATE_METHOD(pos, x) SCM_MAKE_VALIDATE (pos, x, METHODP) + #define SCM_MCACHE_N_SPECIALIZED(C) SCM_CADDR (C) #define SCM_SET_MCACHE_N_SPECIALIZED(C, X) SCM_SETCAR (SCM_CDDR (C), X) diff --git a/libguile/objects.c b/libguile/objects.c index 3838a9c8c..812e9594e 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -83,8 +83,10 @@ SCM *scm_smob_class = 0; SCM scm_no_applicable_method; /* This function is used for efficient type dispatch. */ -SCM -scm_class_of (SCM x) +SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, + (SCM x), + "") +#define FUNC_NAME s_scm_class_of { switch (SCM_ITAG3 (x)) { @@ -213,6 +215,7 @@ scm_class_of (SCM x) } return scm_class_unknown; } +#undef FUNC_NAME /* (SCM_IM_DISPATCH ARGS N-SPECIALIZED * #((TYPE1 ... ENV FORMALS FORM ...) ...) diff --git a/libguile/validate.h b/libguile/validate.h index bab069efe..cf9e603bc 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -1,4 +1,4 @@ -/* $Id: validate.h,v 1.21 2000-12-08 17:32:56 kei Exp $ */ +/* $Id: validate.h,v 1.22 2000-12-16 20:25:08 kei Exp $ */ /* Copyright (C) 1999, 2000 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify @@ -63,6 +63,9 @@ #define SCM_MISC_ERROR(str, args) \ do { scm_misc_error (FUNC_NAME, str, args); } while (0) +#define SCM_WRONG_NUM_ARGS() \ + do { scm_wrong_num_args (scm_makfrom0str (FUNC_NAME)); } while (0) + #define SCM_WRONG_TYPE_ARG(pos, obj) \ do { scm_wrong_type_arg (FUNC_NAME, pos, obj); } while (0) From 9d870e3ce4c7d1ff4a4abceb5578be8044b4caaa Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 17 Dec 2000 04:00:52 +0000 Subject: [PATCH 0435/2047] *** empty log message *** --- devel/tasks.text | 125 ----------------------------------------------- 1 file changed, 125 deletions(-) diff --git a/devel/tasks.text b/devel/tasks.text index 9374274a4..e69de29bb 100644 --- a/devel/tasks.text +++ b/devel/tasks.text @@ -1,125 +0,0 @@ -* People - -neil Neil Jerram -gjb Greg J. Badros -thi thi -peter Peter C. Norton -mvo Marius Vollmer -mdj Mikael Djurfeldt -livshin Michael Livshin -gregh Greg Harvey -niibe NIIBE Yutaka -dirk Dirk Herrmann -rlb Rob Browning -ryanw Ryan Weaver - -* Assigned core tasks - -(? = has shown interest, but has not yet taken on the task) - -** reference manual - -neil - -** docstrings - -gjb - -** Guile FAQ - -thi - -** Guile WWW pages at GNU - -peter - -** Guile project list - -thi - -** Guile Debian package maintainer - -rlb - -** Guile RPM package manager - -ryanw - -** generic translator support - -mdj - -** integration of Jost's environments - -dirk - -** generational garbage collection - -livshin - -** POSIX thread support - -niibe - -*** factorizing thread support out of libguile - -niibe -dirk - -*** Protecting common resources using mutecis from the new interface. - -maciej? - -*** Removing the dynamic roots - -*** Revise the fluid implementation - -Trying to use the thread library's support for thread local data -(get/setspecific). - -*** Implementing the GC thread synchronization (all threads: go to sleep!) - -One suitable synchronization point is probably SCM_TICK. - -Note also that threads which are in I/O or timeout should be regarded -as stopped and that we need synchronization points *after* each I/O or -timeout, so that they really stop afterward if Guile is still in GC. - -*** Implementing the libguileposix threads glue library - -This corresponds to the libguilecoop library implemented during the -thread factorization. - -** GOOPS - -*** integration into libguile - -mdj - -*** developing better representation for GOOPS objects - -livshin - -*** rewrite method cache management in C - -thi - -*** rewrite core macros (define-class et al) in C - -thi - -*** GOOPS C API - -mvo -dirk - -* Core tasks in need of attention - -** GOOPS - -*** Orbit CORBA interface - - -Local Variables: -mode: outline -End: From c312aca735fc56ca47001655aaf018080fd78de3 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 18 Dec 2000 17:36:44 +0000 Subject: [PATCH 0436/2047] * Remove some redundant SCM_N?IMP tests. --- libguile/ChangeLog | 9 +++++++++ libguile/goops.c | 40 ++++++++++++++++------------------------ 2 files changed, 25 insertions(+), 24 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 1cc56f2b4..f039a476f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2000-12-16 Dirk Herrmann + + * goops.c (remove_duplicate_slots, maplist, + scm_sys_initialize_object, scm_sys_prep_layout_x, + scm_sys_inherit_magic_x, scm_instance_p, + scm_sys_set_object_setter_x, scm_sys_invalidate_method_cache_x, + scm_compute_applicable_methods, scm_m_atdispatch, + scm_pure_generic_p): Remove redundant SCM_N?IMP tests. + 2000-12-16 Keisuke Nishida * validate.h (SCM_WRONG_NUM_ARGS): New macro. diff --git a/libguile/goops.c b/libguile/goops.c index 9b0112a85..2ddd89ff6 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -245,10 +245,8 @@ remove_duplicate_slots (SCM l, SCM res, SCM slots_already_seen) return res; tmp = SCM_CAAR (l); - if (!(SCM_NIMP (tmp) && SCM_SYMBOLP (tmp))) - scm_misc_error ("%compute-slots", - "bad slot name ~S", - SCM_LIST1 (tmp)); + if (!SCM_SYMBOLP (tmp)) + scm_misc_error ("%compute-slots", "bad slot name ~S", SCM_LIST1 (tmp)); if (SCM_FALSEP (scm_c_memq (tmp, slots_already_seen))) { res = scm_cons (SCM_CAR (l), res); @@ -277,7 +275,7 @@ maplist (SCM ls) SCM orig = ls; while (SCM_NIMP (ls)) { - if (!(SCM_NIMP (SCM_CAR (ls)) && SCM_CONSP (SCM_CAR (ls)))) + if (!SCM_CONSP (SCM_CAR (ls))) SCM_SETCAR (ls, scm_cons (SCM_CAR (ls), SCM_EOL)); ls = SCM_CDR (ls); } @@ -433,7 +431,7 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0, if (tmp) { /* an initarg was provided for this slot */ - if (!(SCM_NIMP (tmp) && SCM_KEYWORDP (tmp))) + if (!SCM_KEYWORDP (tmp)) SCM_MISC_ERROR ("initarg must be a keyword. It was ~S", SCM_LIST1 (tmp)); slot_value = scm_i_get_keyword (tmp, @@ -498,7 +496,7 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0, s = n > 0 ? scm_must_malloc (n, FUNC_NAME) : 0; for (i = 0; i < n; i += 2) { - if (!(SCM_NIMP (slots) && SCM_CONSP (slots))) + if (!SCM_CONSP (slots)) SCM_MISC_ERROR ("to few slot definitions", SCM_EOL); len = scm_ilength (SCM_CDAR (slots)); type = scm_i_get_keyword (k_class, SCM_CDAR (slots), len, SCM_BOOL_F, @@ -547,9 +545,7 @@ SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0, SCM_VALIDATE_INSTANCE (1, class); while (SCM_NNULLP (ls)) { - SCM_ASSERT (SCM_NIMP (ls) - && SCM_CONSP (ls) - && SCM_NIMP (SCM_CAR (ls)) + SCM_ASSERT (SCM_CONSP (ls) && SCM_INSTANCEP (SCM_CAR (ls)), dsupers, SCM_ARG2, @@ -785,7 +781,7 @@ SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0, "") #define FUNC_NAME s_scm_instance_p { - return SCM_NIMP (obj) && SCM_INSTANCEP (obj) ? SCM_BOOL_T : SCM_BOOL_F; + return SCM_BOOL (SCM_INSTANCEP (obj)); } #undef FUNC_NAME @@ -1363,7 +1359,7 @@ SCM_DEFINE (scm_sys_set_object_setter_x, "%set-object-setter!", 2, 0, 0, "") #define FUNC_NAME s_scm_sys_set_object_setter_x { - SCM_ASSERT (SCM_NIMP (obj) && SCM_STRUCTP (obj) + SCM_ASSERT (SCM_STRUCTP (obj) && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR) || SCM_I_ENTITYP (obj)), obj, @@ -1559,18 +1555,16 @@ SCM_DEFINE (scm_sys_invalidate_method_cache_x, "%invalidate-method-cache!", 1, 0 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x { SCM used_by; - SCM_ASSERT (SCM_NIMP (gf) && SCM_STRUCTP (gf) && SCM_PUREGENERICP (gf), + SCM_ASSERT (SCM_STRUCTP (gf) && SCM_PUREGENERICP (gf), gf, SCM_ARG1, FUNC_NAME); used_by = SCM_SLOT (gf, scm_si_used_by); if (SCM_NFALSEP (used_by)) { SCM methods = SCM_SLOT (gf, scm_si_methods); - for (; SCM_NIMP (used_by) && SCM_CONSP (used_by); - used_by = SCM_CDR (used_by)) + for (; SCM_CONSP (used_by); used_by = SCM_CDR (used_by)) scm_sys_invalidate_method_cache_x (SCM_CAR (used_by)); clear_method_cache (gf); - for (; SCM_NIMP (methods) && SCM_CONSP (methods); - methods = SCM_CDR (methods)) + for (; SCM_CONSP (methods); methods = SCM_CDR (methods)) SCM_SLOT (SCM_CAR (methods), scm_si_code_table) = SCM_EOL; } { @@ -1805,7 +1799,7 @@ scm_compute_applicable_methods (SCM gf, SCM args, int len, int find_method_p) continue; for (i = 0; ; i++, fl = SCM_CDR (fl)) { - if ((SCM_NIMP (fl) && SCM_INSTANCEP (fl)) + if (SCM_INSTANCEP (fl) /* We have a dotted argument list */ || (i >= len && SCM_NULLP (fl))) { /* both list exhausted */ @@ -1886,7 +1880,7 @@ scm_m_atdispatch (SCM xorig, SCM env) SCM args, n, v, gf, x = SCM_CDR (xorig); SCM_ASSYNT (scm_ilength (x) == 4, xorig, scm_s_expression, s_atdispatch); args = SCM_CAR (x); - SCM_ASSYNT (SCM_NIMP (args) && (SCM_CONSP (args) || SCM_SYMBOLP (args)), + SCM_ASSYNT (SCM_CONSP (args) || SCM_SYMBOLP (args), args, SCM_ARG1, s_atdispatch); x = SCM_CDR (x); n = SCM_XEVALCAR (x, env); @@ -1894,10 +1888,10 @@ scm_m_atdispatch (SCM xorig, SCM env) SCM_ASSERT_RANGE (0, n, SCM_INUM (n) >= 1); x = SCM_CDR (x); v = SCM_XEVALCAR (x, env); - SCM_ASSYNT (SCM_NIMP (v) && SCM_VECTORP (v), v, SCM_ARG3, s_atdispatch); + SCM_ASSYNT (SCM_VECTORP (v), v, SCM_ARG3, s_atdispatch); x = SCM_CDR (x); gf = SCM_XEVALCAR (x, env); - SCM_ASSYNT (SCM_NIMP (gf) && SCM_STRUCTP (gf) && SCM_PUREGENERICP (gf), + SCM_ASSYNT (SCM_STRUCTP (gf) && SCM_PUREGENERICP (gf), gf, SCM_ARG4, s_atdispatch); return SCM_LIST5 (SCM_IM_DISPATCH, args, n, v, gf); } @@ -2607,9 +2601,7 @@ SCM_DEFINE (scm_pure_generic_p, "pure-generic?", 1, 0, 0, "") #define FUNC_NAME s_scm_pure_generic_p { - return (SCM_NIMP (obj) && SCM_STRUCTP (obj) && SCM_PUREGENERICP (obj) - ? SCM_BOOL_T - : SCM_BOOL_F); + return SCM_BOOL (SCM_STRUCTP (obj) && SCM_PUREGENERICP (obj)); } #undef FUNC_NAME From 5bd44fc9ce4c73901c95a14c4b943402a5fe7112 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Wed, 20 Dec 2000 22:27:09 +0000 Subject: [PATCH 0437/2047] * continuations.c (continuation_apply): subtract the length of continuation->dynenv, not the dynenv itself. I broke it last time I changed this file. thanks to Bernard Urban. --- libguile/ChangeLog | 6 ++++++ libguile/continuations.c | 3 ++- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f039a476f..88fb7341f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2000-12-20 Gary Houston + + * continuations.c (continuation_apply): subtract the length of + continuation->dynenv, not the dynenv itself. I broke it last + time I changed this file. thanks to Bernard Urban. + 2000-12-16 Dirk Herrmann * goops.c (remove_duplicate_slots, maplist, diff --git a/libguile/continuations.c b/libguile/continuations.c index 7624f637b..12d313e50 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -231,7 +231,8 @@ static SCM continuation_apply (SCM cont, SCM args) } scm_dowinds (continuation->dynenv, - scm_ilength (scm_dynwinds) - continuation->dynenv); + scm_ilength (scm_dynwinds) + - scm_ilength (continuation->dynenv)); scm_dynthrow (cont, scm_values (args)); return SCM_UNSPECIFIED; /* not reached */ From 25ba37dffa569c3f2cfc6d402176d680b56c6947 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 21 Dec 2000 17:07:38 +0000 Subject: [PATCH 0438/2047] * Simplify the use of SCM_PUREGENERICP. --- libguile/ChangeLog | 7 +++++++ libguile/goops.c | 8 +++----- libguile/goops.h | 7 ++++--- 3 files changed, 14 insertions(+), 8 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 88fb7341f..489313dd7 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2000-12-21 Dirk Herrmann + + * goops.h (SCM_PUREGENERICP): Include the SCM_STRUCTP test. + + * goops.c (scm_sys_invalidate_method_cache_x, scm_m_atdispatch, + scm_pure_generic_p): The SCM_STRUCTP test is implied. + 2000-12-20 Gary Houston * continuations.c (continuation_apply): subtract the length of diff --git a/libguile/goops.c b/libguile/goops.c index 2ddd89ff6..0c4ffa6e9 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1555,8 +1555,7 @@ SCM_DEFINE (scm_sys_invalidate_method_cache_x, "%invalidate-method-cache!", 1, 0 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x { SCM used_by; - SCM_ASSERT (SCM_STRUCTP (gf) && SCM_PUREGENERICP (gf), - gf, SCM_ARG1, FUNC_NAME); + SCM_ASSERT (SCM_PUREGENERICP (gf), gf, SCM_ARG1, FUNC_NAME); used_by = SCM_SLOT (gf, scm_si_used_by); if (SCM_NFALSEP (used_by)) { @@ -1891,8 +1890,7 @@ scm_m_atdispatch (SCM xorig, SCM env) SCM_ASSYNT (SCM_VECTORP (v), v, SCM_ARG3, s_atdispatch); x = SCM_CDR (x); gf = SCM_XEVALCAR (x, env); - SCM_ASSYNT (SCM_STRUCTP (gf) && SCM_PUREGENERICP (gf), - gf, SCM_ARG4, s_atdispatch); + SCM_ASSYNT (SCM_PUREGENERICP (gf), gf, SCM_ARG4, s_atdispatch); return SCM_LIST5 (SCM_IM_DISPATCH, args, n, v, gf); } #undef FUNC_NAME @@ -2601,7 +2599,7 @@ SCM_DEFINE (scm_pure_generic_p, "pure-generic?", 1, 0, 0, "") #define FUNC_NAME s_scm_pure_generic_p { - return SCM_BOOL (SCM_STRUCTP (obj) && SCM_PUREGENERICP (obj)); + return SCM_BOOL (SCM_PUREGENERICP (obj)); } #undef FUNC_NAME diff --git a/libguile/goops.h b/libguile/goops.h index d9f792e0f..3c123c80b 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -125,11 +125,12 @@ typedef struct scm_method_t { (SCM_UNPACK (SCM_STRUCT_DATA (x)[scm_struct_i_n_words]) \ - scm_struct_n_extra_words) \ -#define SCM_INSTANCEP(x) (SCM_STRUCTP (x) \ - && (SCM_INST_TYPE (x) & SCM_CLASSF_GOOPS)) +#define SCM_INSTANCEP(x) \ + (SCM_STRUCTP (x) && (SCM_INST_TYPE (x) & SCM_CLASSF_GOOPS)) #define SCM_VALIDATE_INSTANCE(pos, x) SCM_MAKE_VALIDATE (pos, x, INSTANCEP) -#define SCM_PUREGENERICP(x) (SCM_INST_TYPE(x) & SCM_CLASSF_PURE_GENERIC) +#define SCM_PUREGENERICP(x) \ + (SCM_STRUCTP (x) && (SCM_INST_TYPE(x) & SCM_CLASSF_PURE_GENERIC)) #define SCM_SIMPLEMETHODP(x) (SCM_INST_TYPE(x) & SCM_CLASSF_SIMPLE_METHOD) #define SCM_ACCESSORP(x) (SCM_INST_TYPE(x) & SCM_CLASSF_ACCESSOR_METHOD) #define SCM_VALIDATE_ACCESSOR(pos, x) SCM_MAKE_VALIDATE (pos, x, ACCESSORP) From 2e9c835db9fc83de45f32074104b16c45cdb93c4 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 21 Dec 2000 17:51:55 +0000 Subject: [PATCH 0439/2047] * Make sure, re-entering the dynamic scope of an eval statement will restore the latest selected module. --- libguile/ChangeLog | 6 ++++++ libguile/eval.c | 2 ++ 2 files changed, 8 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 489313dd7..4aa74506f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2000-12-21 Dirk Herrmann + + * eval.c (restore_environment): Make sure that changes to the + current environment will take effect when re-entering the dynamic + scope. + 2000-12-21 Dirk Herrmann * goops.h (SCM_PUREGENERICP): Include the SCM_STRUCTP test. diff --git a/libguile/eval.c b/libguile/eval.c index c66a7ebf3..57943e6c4 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3836,6 +3836,8 @@ restore_environment (void *data) { SCM pair = SCM_PACK (data); SCM old_module = SCM_CDR (pair); + SCM new_module = scm_selected_module (); + SCM_SETCAR (pair, new_module); scm_select_module (old_module); } From c9c01b11259a4b7cd8e5143241ce12f57282976a Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 22 Dec 2000 16:46:17 +0000 Subject: [PATCH 0440/2047] * Removed unused member "documentation" from struct scm_subr_entry. * Eliminate use of scm_intern0/scm_sysintern0 in procs.c. --- NEWS | 2 +- RELEASE | 3 ++- libguile/ChangeLog | 14 ++++++++++++++ libguile/procs.c | 16 +++++++++++----- libguile/procs.h | 9 +++++++-- 5 files changed, 35 insertions(+), 9 deletions(-) diff --git a/NEWS b/NEWS index da16b1ed4..beb2775f8 100644 --- a/NEWS +++ b/NEWS @@ -308,7 +308,7 @@ SCM_VALIDATE_NULLORROSTRING_COPY, SCM_ROLENGTH, SCM_LENGTH, SCM_HUGE_LENGTH, SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR, SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING, SCM_ROCHARS, SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS, SCM_LENGTH_MAX, SCM_GC8MARKP, -SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR +SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR, SCM_SUBR_DOC Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of SCM_OUTOFRANGE. Use scm_memory_error instead of SCM_NALLOC. diff --git a/RELEASE b/RELEASE index 2a3c6a22d..16230478a 100644 --- a/RELEASE +++ b/RELEASE @@ -52,7 +52,8 @@ In release 1.6: SCM_LENGTH, SCM_HUGE_LENGTH, SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR, SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING, SCM_ROCHARS, SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS, SCM_LENGTH_MAX, - SCM_GC8MARKP, SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR + SCM_GC8MARKP, SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR, + SCM_SUBR_DOC - remove scm_vector_set_length_x - remove function scm_call_catching_errors (replaced by catch functions from throw.[ch]) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 4aa74506f..b00cba05b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,17 @@ +2000-12-22 Dirk Herrmann + + * procs.h (scm_subr_entry): Removed unused struct member + "documentation". + + (SCM_SUBR_DOC): Deprecated. + + * procs.c (scm_make_subr_opt): Eliminate use of scm_intern0 in + favor of scm_str2symbol. Similarly, prefer scm_sysintern over + scm_sysintern0. + + (scm_make_subr_opt, scm_mark_subr_table): Struct scm_subr_entry + does not have a member "documentation" any more. + 2000-12-21 Dirk Herrmann * eval.c (restore_environment): Make sure that changes to the diff --git a/libguile/procs.c b/libguile/procs.c index 787098bf2..d1279a21a 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -70,6 +70,7 @@ int scm_subr_table_room = 750; SCM scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set) { + SCM symbol; SCM symcell; register SCM z; int entry; @@ -87,14 +88,21 @@ scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set) } SCM_NEWCELL (z); - symcell = set ? scm_sysintern0 (name) : scm_intern0 (name); + if (set) + { + symcell = scm_sysintern (name, SCM_UNDEFINED); + symbol = SCM_CAR (symcell); + } + else + { + symbol = scm_str2symbol (name); + } entry = scm_subr_table_size; scm_subr_table[entry].handle = z; - scm_subr_table[entry].name = SCM_CAR (symcell); + scm_subr_table[entry].name = symbol; scm_subr_table[entry].generic = 0; scm_subr_table[entry].properties = SCM_EOL; - scm_subr_table[entry].documentation = SCM_BOOL_F; SCM_SET_SUBRF (z, fcn); SCM_SET_CELL_TYPE (z, (entry << 8) + type); @@ -143,8 +151,6 @@ scm_mark_subr_table () scm_gc_mark (*scm_subr_table[i].generic); if (SCM_NIMP (scm_subr_table[i].properties)) scm_gc_mark (scm_subr_table[i].properties); - if (SCM_NIMP (scm_subr_table[i].documentation)) - scm_gc_mark (scm_subr_table[i].documentation); } } diff --git a/libguile/procs.h b/libguile/procs.h index 0a3de0374..9a6ed62ef 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -63,7 +63,6 @@ typedef struct * *generic == 0 until first method */ SCM properties; /* procedure properties */ - SCM documentation; } scm_subr_entry; #define SCM_SUBRNUM(subr) (SCM_CELL_WORD_0 (subr) >> 8) @@ -88,7 +87,6 @@ typedef struct #define SCM_SUBR_GENERIC(x) (SCM_SUBR_ENTRY (x).generic) #define SCM_SUBR_PROPS(x) (SCM_SUBR_ENTRY (x).properties) -#define SCM_SUBR_DOC(x) (SCM_SUBR_ENTRY (x).documentation) /* Closures */ @@ -190,6 +188,13 @@ extern SCM scm_make_cclo (SCM proc, SCM len); #endif /*GUILE_DEBUG*/ + +#if (SCM_DEBUG_DEPRECATED == 0) + +#define SCM_SUBR_DOC(x) SCM_BOOL_F + +#endif /* SCM_DEBUG_DEPRECATED == 0 */ + #endif /* PROCSH */ /* From 54a33a61d92d8fa667a609dc6e3f50069320e790 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 23 Dec 2000 11:38:06 +0000 Subject: [PATCH 0441/2047] * Removed unused member "properties" from struct scm_subr_entry. --- NEWS | 3 ++- RELEASE | 2 +- libguile/ChangeLog | 10 ++++++++++ libguile/procs.c | 3 --- libguile/procs.h | 6 ++---- 5 files changed, 15 insertions(+), 9 deletions(-) diff --git a/NEWS b/NEWS index beb2775f8..fb1f4af5e 100644 --- a/NEWS +++ b/NEWS @@ -308,7 +308,8 @@ SCM_VALIDATE_NULLORROSTRING_COPY, SCM_ROLENGTH, SCM_LENGTH, SCM_HUGE_LENGTH, SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR, SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING, SCM_ROCHARS, SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS, SCM_LENGTH_MAX, SCM_GC8MARKP, -SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR, SCM_SUBR_DOC +SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR, SCM_SUBR_DOC, +SCM_SUBR_PROPS Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of SCM_OUTOFRANGE. Use scm_memory_error instead of SCM_NALLOC. diff --git a/RELEASE b/RELEASE index 16230478a..f0c912185 100644 --- a/RELEASE +++ b/RELEASE @@ -53,7 +53,7 @@ In release 1.6: SCM_COERCE_SUBSTR, SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING, SCM_ROCHARS, SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS, SCM_LENGTH_MAX, SCM_GC8MARKP, SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR, - SCM_SUBR_DOC + SCM_SUBR_DOC, SCM_SUBR_PROPS - remove scm_vector_set_length_x - remove function scm_call_catching_errors (replaced by catch functions from throw.[ch]) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b00cba05b..321e2da21 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,13 @@ +2000-12-23 Dirk Herrmann + + * procs.h (scm_subr_entry): Removed unused struct member + "properties". + + (SCM_SUBR_PROPS): Deprecated. + + * procs.c (scm_make_subr_opt, scm_mark_subr_table): Struct + scm_subr_entry does not have a member "properties" any more. + 2000-12-22 Dirk Herrmann * procs.h (scm_subr_entry): Removed unused struct member diff --git a/libguile/procs.c b/libguile/procs.c index d1279a21a..a79c7d79c 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -102,7 +102,6 @@ scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set) scm_subr_table[entry].handle = z; scm_subr_table[entry].name = symbol; scm_subr_table[entry].generic = 0; - scm_subr_table[entry].properties = SCM_EOL; SCM_SET_SUBRF (z, fcn); SCM_SET_CELL_TYPE (z, (entry << 8) + type); @@ -149,8 +148,6 @@ scm_mark_subr_table () SCM_SETGCMARK (scm_subr_table[i].name); if (scm_subr_table[i].generic && *scm_subr_table[i].generic) scm_gc_mark (*scm_subr_table[i].generic); - if (SCM_NIMP (scm_subr_table[i].properties)) - scm_gc_mark (scm_subr_table[i].properties); } } diff --git a/libguile/procs.h b/libguile/procs.h index 9a6ed62ef..a843525a4 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -62,7 +62,6 @@ typedef struct SCM *generic; /* 0 if no generic support * *generic == 0 until first method */ - SCM properties; /* procedure properties */ } scm_subr_entry; #define SCM_SUBRNUM(subr) (SCM_CELL_WORD_0 (subr) >> 8) @@ -73,6 +72,7 @@ typedef struct #define SCM_SUBRF(x) ((SCM (*)()) SCM_CELL_WORD_1 (x)) #define SCM_SET_SUBRF(x, v) (SCM_SET_CELL_WORD_1 ((x), (v))) #define SCM_DSUBRF(x) ((double (*)()) SCM_CELL_WORD_1 (x)) +#define SCM_SUBR_GENERIC(x) (SCM_SUBR_ENTRY (x).generic) #define SCM_CCLO_LENGTH(x) (SCM_CELL_WORD_0 (x) >> 8) #define SCM_SET_CCLO_LENGTH(x, v) (SCM_SET_CELL_WORD_0 ((x), ((v) << 8) + scm_tc7_cclo)) @@ -85,9 +85,6 @@ typedef struct #define SCM_CCLO_SUBR(x) (SCM_CCLO_REF ((x), 0)) #define SCM_SET_CCLO_SUBR(x, v) (SCM_CCLO_SET ((x), 0, (v))) -#define SCM_SUBR_GENERIC(x) (SCM_SUBR_ENTRY (x).generic) -#define SCM_SUBR_PROPS(x) (SCM_SUBR_ENTRY (x).properties) - /* Closures */ @@ -191,6 +188,7 @@ extern SCM scm_make_cclo (SCM proc, SCM len); #if (SCM_DEBUG_DEPRECATED == 0) +#define SCM_SUBR_PROPS(x) SCM_EOL #define SCM_SUBR_DOC(x) SCM_BOOL_F #endif /* SCM_DEBUG_DEPRECATED == 0 */ From ee2bf8b833355a5d948303a131dc21f3e6b0b69d Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 23 Dec 2000 17:27:04 +0000 Subject: [PATCH 0442/2047] =?UTF-8?q?Doc=20fixes=20from=20Martin=20Grabm?= =?UTF-8?q?=C3=BCller.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- ANON-CVS | 40 ++++++++++++++++------------------------ HACKING | 26 +++++++++++++------------- INSTALL | 1 + README | 20 ++++++++------------ SNAPSHOTS | 3 +-- 5 files changed, 39 insertions(+), 51 deletions(-) diff --git a/ANON-CVS b/ANON-CVS index 1cdba49ed..d782a03b9 100644 --- a/ANON-CVS +++ b/ANON-CVS @@ -18,28 +18,35 @@ And it allows us to start testing features earlier. Since the CVS tree is arranged for the convenience of the developers, it requires GCC and GNU Make, which together support automatic dependency management. You will also need to install autoconf, -automake, and libtool; the recommended versions are listed in README. +automake, and libtool; the recommended versions are listed in HACKING. To check out a CVS working directory: 1) Install CVS version 1.9 or later on your system. + 2) Log into the CVS server: - $ cvs -d :pserver:anoncvs@anoncvs.cygnus.com:/cvs/guile login - At the prompt for `CVS password:', type `anoncvs'. + + $ cvs -d :pserver:anoncvs@subversions.gnu.org:/cvs login + + At the prompt for `CVS password:', simply press the enter key. Once you have logged in, your password is saved in ~/.cvspass, and you will not need to enter it again. + 3) Check out a module: - $ cvs -z 9 -d :pserver:anoncvs@anoncvs.cygnus.com:/cvs/guile checkout guile-core + + $ cvs -z 9 -d :pserver:anoncvs@subversions.gnu.org:/cvs checkout guile-core + This should create a new directory `guile-core' in your current directory, and populate it with the current Guile sources. + 4) In the top directory of the source tree, run the command `./autogen.sh'. This builds the configure script, Makefile.in, and other derived files used by the build system. The modules available for checkout are: + guile-core --- The scheme interpreter itself. guile-doc --- Guile documentation-in-progress. - guile-oops --- GOOPS Guile Object Oriented Programming System. guile-tcltk --- An interface between Guile and Tcl/Tk. guile-scsh --- An incomplete port of SCSH 0.4.4 to Guile. guile-rgx-ctax --- This has been discontinued; use Andrew Archibald's @@ -52,27 +59,21 @@ and efficiently: 1) Go to the top directory of the source tree. That is, your current directory should be the one containing `configure.in', `README', and so on. + 2) Do the update: $ cvs update This will incorporate any changes the developers have made to Guile since your last update into your source tree. -The EGCS Project is kindly lending us space, time, and bandwidth on -their CVS server. Thanks, folks! - Change Notification ================================================== If you would like to receive mail when people commit changes to the -Guile CVS repository, you can subscribe to guile-cvs@egcs.cygnus.com -by sending a message to guile-cvs-subscribe@egcs.cygnus.com. Even -better, you can get daily digests of these commit messages by sending -a message to guile-cvs-digest-subscribe@egcs.cygnus.com. +Guile CVS repository, you can subscribe to guile-cvs@gnu.org by using +the Mailman mailing list interface at -If you want to subscribe an e-mail address other than the one that -appears in your From: header, say foo@bar.com, send a mail note to -guile-cvs-subscribe-foo=bar.com@egcs.cygnus.com. + Questions ============================================================ @@ -100,12 +101,3 @@ Questions ============================================================ command will not overwrite them; instead, CVS will try to merge its changes with your changes, as if you had applied a patch. Rejects are marked in the sources. - -- Why does the build process try to run autoconf, aclocal, or automake? - - It shouldn't; if it does, that's a bug, I think. Those are the - tools we use to generate `configure', `aclocal.m4', and the - `Makefile.in' files from their respective sources. Ideally, you - shouldn't need to have them installed, if you don't want to change - those sources. If you do, see the section in `README' called - `Hacking It Yourself'. diff --git a/HACKING b/HACKING index ad0e53a03..69258c4af 100644 --- a/HACKING +++ b/HACKING @@ -36,7 +36,7 @@ Contributing Your Changes ============================================ - If you have put together a change that meets the coding standards described below, we encourage you to submit it to Guile. The best -place to post it is guile@sourceware.cygnus.com. Please don't send it +place to post it is guile-devel@gnu.org. Please don't send it directly to me; I often don't have time to look things over. If you have tested your change, then you don't need to be shy. @@ -53,14 +53,14 @@ we're just going to regenerate those files anyway. CVS conventions ====================================================== - We use CVS to manage the Guile sources. The repository lives on -egcs.cygnus.com, in /cvs/guile; you will need an +subversions.gnu.org, in /cvs; you will need an account on that machine to access the repository. Also, for security -reasons, egcs presently only supports CVS connections via the SSH +reasons, subversions presently only supports CVS connections via the SSH protocol, so you must first install the SSH client. Then, you should set your CVS_RSH environment variable to ssh, and use the following as your CVS root: - :ext:USER@egcs.cygnus.com:/cvs/guile + :ext:USER@subversions.gnu.org:/cvs Either set your CVSROOT environment variable to that, or give it as the value of the global -d option to CVS when you check out a working @@ -73,7 +73,6 @@ The Guile sources live in several modules: - guile-core --- the interpreter, QuickThreads, and ice-9 - guile-doc --- documentation in progress. When complete, this will be incorporated into guile-core. - - guile-oops --- The Guile Object-Oriented Programming System (talk to mdj) - guile-tcltk --- the Guile/Tk interface - guile-tk --- the new Guile/Tk interface, based on STk's modified Tk - guile-rgx-ctax --- the Guile/Rx interface, and the ctax implementation @@ -131,12 +130,13 @@ make-stds.texi. - The Guile tree should compile without warnings under the following GCC switches, which are the default in the current configure script: - -O2 -Wall -Wpointer-arith -Wmissing-prototypes -The only warnings which can be tolerated are those about variables -being clobbered by longjmp/vfork in eval.c. The variables in question -are critical to the interpreter's performance; as far as I can tell, -it is difficult/annoying to avoid these warnings without slowing the -system down substantially. (If you can figure out a good fix, I'd be happy to see it.) + -O2 -Wall -Wpointer-arith -Wmissing-prototypes The only warnings +which can be tolerated are those about variables being clobbered by +longjmp/vfork in eval.c. The variables in question are critical to +the interpreter's performance; as far as I can tell, it is +difficult/annoying to avoid these warnings without slowing the system +down substantially. (If you can figure out a good fix, I'd be happy +to see it.) Note that the warnings generated vary from one version of GCC to the next, and from one architecture to the next (apparently). To provide @@ -169,7 +169,7 @@ is our purpose to remove functionality. Don't deprecate definitions if it is unclear when they will be removed. (This is to ensure that a valid way of implementing some functionality always exists.) -When deprecating a definition, always following this procedure: +When deprecating a definition, always follow this procedure: 1. Mark the definition using @@ -182,7 +182,7 @@ can manage without the deprecated definition. 3. Add an entry that the definition has been deprecated in NEWS -4. At the top of release, there is a list of releases with reminders +4. At the top of RELEASE, there is a list of releases with reminders about what to do at each release. Add a reminder about the removal of the deprecated defintion at the appropriate release. diff --git a/INSTALL b/INSTALL index 26646b007..c884b5061 100644 --- a/INSTALL +++ b/INSTALL @@ -103,6 +103,7 @@ A Guile compiled with this option provides the primitive `malloc-stats' which returns an alist with pairs of kind and the number of objects of that kind. +--enable-guile-debug --- Include internal debugging functions --disable-arrays --- omit array and uniform array support --disable-posix --- omit posix interfaces --disable-networking --- omit networking interfaces diff --git a/README b/README index b58be0e2c..85c290797 100644 --- a/README +++ b/README @@ -158,14 +158,10 @@ CVS, and by nightly snapshots, accessible via FTP. See the files `ANON-CVS' and `SNAPSHOTS' for details. If you would like to receive mail when people commit changes to the -Guile CVS repository, you can subscribe to guile-cvs@sourceware.cygnus.com -by sending a message to guile-cvs-subscribe@sourceware.cygnus.com. Even -better, you can get daily digests of these commit messages by sending -a message to guile-cvs-digest-subscribe@sourceware.cygnus.com. +Guile CVS repository, you can subscribe to guile-cvs@gnu.org by the +Mailman mailing list interface at -If you want to subscribe an e-mail address other than the one that -appears in your From: header, say foo@bar.com, send a mail note to -guile-cvs-subscribe-foo=bar.com@sourceware.cygnus.com. + Obtaining Guile ====================================================== @@ -174,8 +170,8 @@ The latest official Guile release is available via anonymous FTP from ftp://ftp.gnu.org/pub/gnu/guile/guile-1.4.tar.gz -The mailing list `guile@sourceware.cygnus.com' carries discussions, -questions, and often answers, about Guile. To subscribe, send mail to -guile-subscribe@sourceware.cygnus.com. Of course, please send bug -reports (and fixes!) to bug-guile@gnu.org. Note that one address is -@sourceware.cygnus.com, and the other is at @gnu.org. +The mailing list `guile-user@gnu.org' carries discussions, questions, +and often answers, about Guile. To subscribe, use the Mailman mailing +list interface at +Of course, please send bug reports (and fixes!) to bug-guile@gnu.org. + diff --git a/SNAPSHOTS b/SNAPSHOTS index c71dbe8a7..d179a4f65 100644 --- a/SNAPSHOTS +++ b/SNAPSHOTS @@ -24,8 +24,7 @@ Via the web, that's: For getit, that's: ftp.red-bean.com:/pub/guile/snapshots/guile-core-snap.tar.gz -The snapshot FTP site is mirrored at the following locations: - Austria: ftp://ftp.aec.at/pub/guile +The snapshot FTP site is mirrored at the following location: Japan: ftp://ftp.jaist.ac.jp/pub/lang/scheme/guile From 56495472c24c131152f75ec8c537d6ba07faac42 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Sat, 23 Dec 2000 23:00:23 +0000 Subject: [PATCH 0443/2047] * gc.c: (scm_gc_mark_dependencies): new function. like `scm_gc_mark', but doesn't mark the argument itself. defined using an arrangement similar to that in eval.c: `scm_gc_mark' and `scm_gc_mark_dependencies' are derived from the same "template" by ugly preprocessor magic. * gc.h: added prototype for `scm_gc_mark_dependencies'. * init.c (scm_init_guile_1): call the renamed `scm_init_guardians'. * guardians.h: changed prototypes for `scm_make_guardian' and `scm_init_guardians'. * guardians.c (guardian_t): added new fields `greedy_p' and `listed_p'. (GUARDIAN_P): predicate that says whether its argument is a guardian. (GUARDIAN_GREEDY_P, GUARDIAN_LISTED_P): new predicates. (greedy_guardians, sharing_guardians): new variables. hold the greedy and sharing live guardian lists, respectively. (first_live_guardian, current_link_field): removed. (greedily_guarded_prop): new variable. holds the "is greedily guarded" object property. (self_centered_zombies): new variable. stores guarded objects that are parts of cycles. (add_to_live_list): new function, introduced to decouple marking a guardian and adding it to the live list. (guardian_mark): call `add_to_live_list'. (guardian_print): print whether the guardian is greedy or not. also change "live" and "zombie" to "reachable" and "unreachable" respectively, to be less confusing. (scm_guard): if the guardian is greedy, test whether the object is already greedily marked. throw an error if so. (scm_get_one_zombie): if the guardian is greedy, remove the "greedily guarded" property from the object. (scm_make_guardian): add a new optional boolean argument which says whether the guardian is greedy or sharing. (guardian_gc_init): init the new live lists. (mark_dependencies): new function. (mark_and_zombify): new function. (guardian_zombify): reworked to support the new guardian semantics. move some logic to `mark_dependencies' and `mark_and_zombify'. (whine_about_self_centered_zombies): new function. installed in the `after-gc-hook' to complain about guarded objects which are parts of cycles. (scm_init_guardians): init the new stuff. renamed from `scm_init_guardian'. --- NEWS | 22 +++ libguile/ChangeLog | 52 +++++++ libguile/gc.c | 90 +++++++++--- libguile/gc.h | 1 + libguile/guardians.c | 331 ++++++++++++++++++++++++++++++++----------- libguile/guardians.h | 4 +- libguile/init.c | 2 +- 7 files changed, 399 insertions(+), 103 deletions(-) diff --git a/NEWS b/NEWS index fb1f4af5e..f171f8082 100644 --- a/NEWS +++ b/NEWS @@ -87,6 +87,28 @@ Example: * Changes to Scheme functions and syntax +** The "guardian" facility has changed (mostly compatibly). + +There are now two types of guardians: greedy and sharing. + +If you call (make-guardian #t) or without any arguments, you get a +greedy guardian, else a sharing guardian. + +Greedy guardians are made the default because they are more +"defensive". You can only greedily guard an object once. If you +guard an object more than once, then it is guaranteed that the object +won't be returned from sharing guardians as long as it is greedily +guarded. + +The second change is making sure that all objects returned by +guardians are properly live, i.e. it is impossible to return a +contained object before the containing object. + +One incompatible (but probably not very important) change resulting +from this is that it is no longer possible to guard objects that +indirectly reference themselves (i.e. are parts of cycles). If you do +so accidentally, you'll get a warning. + ** Escape procedures created by call-with-current-continuation now accept any number of arguments, as required by R5RS. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 321e2da21..9077d137e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,55 @@ +2000-12-24 Michael Livshin + + * gc.c: (scm_gc_mark_dependencies): new function. like + `scm_gc_mark', but doesn't mark the argument itself. defined + using an arrangement similar to that in eval.c: `scm_gc_mark' and + `scm_gc_mark_dependencies' are derived from the same "template" + by ugly preprocessor magic. + + * gc.h: added prototype for `scm_gc_mark_dependencies'. + + * init.c (scm_init_guile_1): call the renamed + `scm_init_guardians'. + + * guardians.h: changed prototypes for `scm_make_guardian' and + `scm_init_guardians'. + + * guardians.c (guardian_t): added new fields `greedy_p' and + `listed_p'. + (GUARDIAN_P): predicate that says whether its argument is a + guardian. + (GUARDIAN_GREEDY_P, GUARDIAN_LISTED_P): new predicates. + (greedy_guardians, sharing_guardians): new variables. hold the + greedy and sharing live guardian lists, respectively. + (first_live_guardian, current_link_field): removed. + (greedily_guarded_prop): new variable. holds the "is greedily + guarded" object property. + (self_centered_zombies): new variable. stores guarded objects + that are parts of cycles. + (add_to_live_list): new function, introduced to decouple marking a + guardian and adding it to the live list. + (guardian_mark): call `add_to_live_list'. + (guardian_print): print whether the guardian is greedy or not. + also change "live" and "zombie" to "reachable" and "unreachable" + respectively, to be less confusing. + (scm_guard): if the guardian is greedy, test whether the object is + already greedily marked. throw an error if so. + (scm_get_one_zombie): if the guardian is greedy, remove the + "greedily guarded" property from the object. + (scm_make_guardian): add a new optional boolean argument which + says whether the guardian is greedy or sharing. + (guardian_gc_init): init the new live lists. + (mark_dependencies): new function. + (mark_and_zombify): new function. + (guardian_zombify): reworked to support the new guardian + semantics. move some logic to `mark_dependencies' and + `mark_and_zombify'. + (whine_about_self_centered_zombies): new function. installed in + the `after-gc-hook' to complain about guarded objects which are + parts of cycles. + (scm_init_guardians): init the new stuff. renamed from + `scm_init_guardian'. + 2000-12-23 Dirk Herrmann * procs.h (scm_subr_entry): Removed unused struct member diff --git a/libguile/gc.c b/libguile/gc.c index 23eff9ae7..ebafc9f87 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -44,6 +44,11 @@ /* #define DEBUGINFO */ +/* SECTION: This code is compiled once. + */ + +#ifndef MARK_DEPENDENCIES + #include #include "libguile/_scm.h" @@ -1087,24 +1092,47 @@ scm_igc (const char *what) /* {Mark/Sweep} */ +#define MARK scm_gc_mark +#define FNAME "scm_gc_mark" +#endif /*!MARK_DEPENDENCIES*/ /* Mark an object precisely. */ void -scm_gc_mark (SCM p) -#define FUNC_NAME "scm_gc_mark" +MARK (SCM p) +#define FUNC_NAME FNAME { register long i; register SCM ptr; +#ifndef MARK_DEPENDENCIES +# define RECURSE scm_gc_mark +#else + /* go through the usual marking, but not for self-cycles. */ +# define RECURSE(x) do { if ((x) != p) scm_gc_mark (x); } while (0) +#endif ptr = p; +#ifdef MARK_DEPENDENCIES + goto gc_mark_loop_first_time; +#endif + gc_mark_loop: if (SCM_IMP (ptr)) return; gc_mark_nimp: + +#ifdef MARK_DEPENDENCIES + if (ptr == p) + return; + + scm_gc_mark (ptr); + +gc_mark_loop_first_time: +#endif + if (!SCM_CELLP (ptr)) SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL); @@ -1115,11 +1143,15 @@ gc_mark_nimp: #endif +#ifndef MARK_DEPENDENCIES + if (SCM_GCMARKP (ptr)) return; - + SCM_SETGCMARK (ptr); +#endif + switch (SCM_TYP7 (ptr)) { case scm_tcs_cons_nimcar: @@ -1128,14 +1160,14 @@ gc_mark_nimp: ptr = SCM_CAR (ptr); goto gc_mark_nimp; } - scm_gc_mark (SCM_CAR (ptr)); + RECURSE (SCM_CAR (ptr)); ptr = SCM_CDR (ptr); goto gc_mark_nimp; case scm_tcs_cons_imcar: ptr = SCM_CDR (ptr); goto gc_mark_loop; case scm_tc7_pws: - scm_gc_mark (SCM_CELL_OBJECT_2 (ptr)); + RECURSE (SCM_CELL_OBJECT_2 (ptr)); ptr = SCM_CDR (ptr); goto gc_mark_loop; case scm_tcs_cons_gloc: @@ -1153,7 +1185,7 @@ gc_mark_nimp: { /* ptr is a gloc */ SCM gloc_car = SCM_PACK (word0); - scm_gc_mark (gloc_car); + RECURSE (gloc_car); ptr = SCM_CDR (ptr); goto gc_mark_loop; } @@ -1167,8 +1199,8 @@ gc_mark_nimp: if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) { - scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_procedure])); - scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_setter])); + RECURSE (SCM_PACK (struct_data[scm_struct_i_procedure])); + RECURSE (SCM_PACK (struct_data[scm_struct_i_setter])); } if (len) { @@ -1176,14 +1208,14 @@ gc_mark_nimp: for (x = 0; x < len - 2; x += 2, ++struct_data) if (fields_desc[x] == 'p') - scm_gc_mark (SCM_PACK (*struct_data)); + RECURSE (SCM_PACK (*struct_data)); if (fields_desc[x] == 'p') { if (SCM_LAYOUT_TAILP (fields_desc[x + 1])) - for (x = *struct_data; x; --x) - scm_gc_mark (SCM_PACK (*++struct_data)); + for (x = *struct_data++; x; --x, ++struct_data) + RECURSE (SCM_PACK (*struct_data)); else - scm_gc_mark (SCM_PACK (*struct_data)); + RECURSE (SCM_PACK (*struct_data)); } } /* mark vtable */ @@ -1198,7 +1230,7 @@ gc_mark_nimp: ptr = SCM_CLOSCAR (ptr); goto gc_mark_nimp; } - scm_gc_mark (SCM_CLOSCAR (ptr)); + RECURSE (SCM_CLOSCAR (ptr)); ptr = SCM_CDR (ptr); goto gc_mark_nimp; case scm_tc7_vector: @@ -1207,7 +1239,7 @@ gc_mark_nimp: break; while (--i > 0) if (SCM_NIMP (SCM_VELTS (ptr)[i])) - scm_gc_mark (SCM_VELTS (ptr)[i]); + RECURSE (SCM_VELTS (ptr)[i]); ptr = SCM_VELTS (ptr)[0]; goto gc_mark_loop; #ifdef CCLO @@ -1219,7 +1251,7 @@ gc_mark_nimp: { SCM obj = SCM_CCLO_REF (ptr, j); if (!SCM_IMP (obj)) - scm_gc_mark (obj); + RECURSE (obj); } ptr = SCM_CCLO_REF (ptr, 0); goto gc_mark_loop; @@ -1293,13 +1325,13 @@ gc_mark_nimp: * won't prematurely drop table entries. */ if (!weak_keys) - scm_gc_mark (SCM_CAR (kvpair)); + RECURSE (SCM_CAR (kvpair)); if (!weak_values) - scm_gc_mark (SCM_CDR (kvpair)); + RECURSE (SCM_CDR (kvpair)); alist = next_alist; } if (SCM_NIMP (alist)) - scm_gc_mark (alist); + RECURSE (alist); } } break; @@ -1314,7 +1346,7 @@ gc_mark_nimp: if (!(i < scm_numptob)) goto def; if (SCM_PTAB_ENTRY(ptr)) - scm_gc_mark (SCM_FILENAME (ptr)); + RECURSE (SCM_FILENAME (ptr)); if (scm_ptobs[i].mark) { ptr = (scm_ptobs[i].mark) (ptr); @@ -1352,6 +1384,24 @@ gc_mark_nimp: } #undef FUNC_NAME +#ifndef MARK_DEPENDENCIES + +#undef MARK +#undef RECURSE +#undef FNAME + +/* And here we define `scm_gc_mark_dependencies', by including this + * same file in itself. + */ +#define MARK scm_gc_mark_dependencies +#define FNAME "scm_gc_mark_dependencies" +#define MARK_DEPENDENCIES +#include "gc.c" +#undef MARK_DEPENDENCIES +#undef MARK +#undef RECURSE +#undef FNAME + /* Mark a Region Conservatively */ @@ -2599,6 +2649,8 @@ scm_init_gc () #endif } +#endif /*MARK_DEPENDENCIES*/ + /* Local Variables: c-file-style: "gnu" diff --git a/libguile/gc.h b/libguile/gc.h index 02e39890b..c0c8ce70b 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -338,6 +338,7 @@ extern void scm_alloc_cluster (struct scm_freelist_t *master); #endif extern void scm_igc (const char *what); extern void scm_gc_mark (SCM p); +extern void scm_gc_mark_dependencies (SCM p); extern void scm_mark_locations (SCM_STACKITEM x[], scm_sizet n); extern int scm_cellp (SCM value); extern void scm_gc_sweep (void); diff --git a/libguile/guardians.c b/libguile/guardians.c index c32746ecf..5a53a6222 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -50,8 +50,14 @@ * Programming Language Design and Implementation, June 1993 * ftp://ftp.cs.indiana.edu/pub/scheme-repository/doc/pubs/guardians.ps.gz * - * Author: Michael N. Livshin - * Modified by: Mikael Djurfeldt + * By this point, the semantics are actually quite different from + * those described in the abovementioned paper. The semantic changes + * are there to improve safety and intuitiveness. The interface is + * still (mostly) the one described by the paper, however. + * + * Original design: Mikael Djurfeldt + * Original implementation: Michael Livshin + * Hacked on since by: everybody */ @@ -59,8 +65,10 @@ #include "libguile/ports.h" #include "libguile/print.h" #include "libguile/smob.h" - #include "libguile/validate.h" +#include "libguile/properties.h" +#include "libguile/root.h" + #include "libguile/guardians.h" @@ -100,30 +108,63 @@ typedef struct guardian_t tconc_t live; tconc_t zombies; struct guardian_t *next; + int greedy_p; + int listed_p; } guardian_t; +#define GUARDIAN_P(x) SCM_SMOB_PREDICATE(tc16_guardian, x) #define GUARDIAN(x) ((guardian_t *) SCM_CELL_WORD_1 (x)) #define GUARDIAN_LIVE(x) (GUARDIAN (x)->live) #define GUARDIAN_ZOMBIES(x) (GUARDIAN (x)->zombies) #define GUARDIAN_NEXT(x) (GUARDIAN (x)->next) +#define GUARDIAN_GREEDY_P(x) (GUARDIAN (x)->greedy_p) +#define GUARDIAN_LISTED_P(x) (GUARDIAN (x)->listed_p) -/* during the gc mark phase, live guardians are linked into a list here. */ -static guardian_t *first_live_guardian = NULL; -static guardian_t **current_link_field = NULL; +/* during the gc mark phase, live guardians are linked into the lists + here. */ +static guardian_t *greedy_guardians = NULL; +static guardian_t *sharing_guardians = NULL; +/* greedily guarded objects have this property set, so that we can + catch any attempt to greedily guard them again */ +static SCM greedily_guarded_prop = SCM_EOL; + +/* this is the list of guarded objects that are parts of cycles. we + don't know in which order to return them from guardians, so we just + unguard them and whine about it in after-gc-hook */ +static SCM self_centered_zombies = SCM_EOL; + + +static void +add_to_live_list (SCM g) +{ + if (GUARDIAN_LISTED_P (g)) + return; + + if (GUARDIAN_GREEDY_P (g)) + { + GUARDIAN_NEXT (g) = greedy_guardians; + greedy_guardians = GUARDIAN (g); + } + else + { + GUARDIAN_NEXT (g) = sharing_guardians; + sharing_guardians = GUARDIAN (g); + } + + GUARDIAN_LISTED_P (g) = 1; +} /* mark a guardian by adding it to the live guardian list. */ static SCM guardian_mark (SCM ptr) { - *current_link_field = GUARDIAN (ptr); - current_link_field = &GUARDIAN_NEXT (ptr); - GUARDIAN_NEXT (ptr) = NULL; + add_to_live_list (ptr); /* the objects protected by the guardian are not marked here: that would prevent them from ever getting collected. instead marking - is done at the end of the mark phase by scm_guardian_zombify. */ + is done at the end of the mark phase by guardian_zombify. */ return SCM_BOOL_F; } @@ -139,11 +180,14 @@ guardian_free (SCM ptr) static int guardian_print (SCM g, SCM port, scm_print_state *pstate) { - scm_puts ("#", port); + scm_puts (")>", port); return 1; } @@ -173,8 +217,19 @@ scm_guard (SCM guardian, SCM obj) { SCM z; - SCM_NEWCELL (z); + if (GUARDIAN_GREEDY_P (guardian)) + { + if (SCM_NFALSEP (scm_primitive_property_ref + (greedily_guarded_prop, obj))) + scm_misc_error ("guard", + "object is already greedily guarded", obj); + else + scm_primitive_property_set_x (greedily_guarded_prop, + obj, SCM_BOOL_T); + } + SCM_NEWCELL (z); + /* This critical section barrier will be replaced by a mutex. */ SCM_DEFER_INTS; TCONC_IN (GUARDIAN_LIVE (guardian), obj, z); @@ -193,12 +248,19 @@ scm_get_one_zombie (SCM guardian) if (!TCONC_EMPTYP (GUARDIAN_ZOMBIES (guardian))) TCONC_OUT (GUARDIAN_ZOMBIES (guardian), res); SCM_ALLOW_INTS; + + if (SCM_NFALSEP (res) + && GUARDIAN_GREEDY_P (guardian) + && SCM_NFALSEP (scm_primitive_property_ref + (greedily_guarded_prop, res))) + scm_primitive_property_del_x (greedily_guarded_prop, res); + return res; } -SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 0, 0, - (), +SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 1, 0, + (SCM greedy_p), "Create a new guardian.\n" "A guardian protects a set of objects from garbage collection,\n" "allowing a program to apply cleanup or other actions.\n\n" @@ -212,10 +274,18 @@ SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 0, 0, "Objects which are returned in this way are removed from\n" "the guardian.\n\n" + "make-guardian takes one optional argument that says whether the\n" + "new guardian should be greedy or not. if there is any chance\n" + "that any object protected by the guardian may be resurrected,\n" + "then make the guardian greedy (this is the default).\n\n" + "See R. Kent Dybvig, Carl Bruggeman, and David Eby (1993)\n" "\"Guardians in a Generation-Based Garbage Collector\".\n" "ACM SIGPLAN Conference on Programming Language Design\n" - "and Implementation, June 1993.") + "and Implementation, June 1993.\n\n" + + "(the semantics are slightly different at this point, but the\n" + "paper still (mostly) accurately describes the interface).") #define FUNC_NAME s_scm_make_guardian { guardian_t *g = SCM_MUST_MALLOC_TYPE (guardian_t); @@ -226,6 +296,12 @@ SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 0, 0, /* A tconc starts out with one tail pair. */ g->live.head = g->live.tail = z1; g->zombies.head = g->zombies.tail = z2; + g->listed_p = 0; + + if (SCM_UNBNDP (greedy_p)) + g->greedy_p = 1; + else + g->greedy_p = SCM_NFALSEP (greedy_p); SCM_NEWSMOB (z, tc16_guardian, g); @@ -238,12 +314,94 @@ SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 0, 0, static void * guardian_gc_init (void *dummy1, void *dummy2, void *dummy3) { - current_link_field = &first_live_guardian; - first_live_guardian = NULL; + greedy_guardians = sharing_guardians = NULL; return 0; } +static void +mark_dependencies (guardian_t *g) +{ + SCM pair, next_pair; + SCM *prev_ptr; + + /* scan the live list for unmarked objects, and mark their + dependencies */ + for (pair = g->live.head, prev_ptr = &g->live.head; + ! SCM_EQ_P (pair, g->live.tail); + pair = next_pair) + { + SCM obj = SCM_CAR (pair); + next_pair = SCM_CDR (pair); + + if (! SCM_MARKEDP (obj)) + { + /* a candidate for finalizing */ + scm_gc_mark_dependencies (obj); + + if (SCM_MARKEDP (obj)) + { + /* uh oh. a cycle. transfer this object (the + spine cell, to be exact) to + self_centered_zombies, so we'll be able to + complain about it later. */ + *prev_ptr = next_pair; + SCM_SETGCMARK (pair); + SCM_SETCDR (pair, SCM_CDR (self_centered_zombies)); + SCM_SETCDR (self_centered_zombies, pair); + } + else + { + /* see if this is a guardian. if yes, list it (but don't + mark it yet). */ + if (GUARDIAN_P (obj)) + add_to_live_list (obj); + + prev_ptr = SCM_CDRLOC (pair); + } + } + } +} + +static void +mark_and_zombify (guardian_t *g) +{ + SCM tconc_tail = g->live.tail; + SCM *prev_ptr = &g->live.head; + SCM pair = g->live.head; + + while (! SCM_EQ_P (pair, tconc_tail)) + { + SCM next_pair = SCM_CDR (pair); + + if (SCM_NMARKEDP (SCM_CAR (pair))) + { + /* got you, zombie! */ + + /* out of the live list! */ + *prev_ptr = next_pair; + + if (g->greedy_p) + /* if the guardian is greedy, mark this zombie now. this + way it won't be zombified again this time around. */ + SCM_SETGCMARK (SCM_CAR (pair)); + + /* into the zombie list! */ + TCONC_IN (g->zombies, SCM_CAR (pair), pair); + } + else + prev_ptr = SCM_CDRLOC (pair); + + pair = next_pair; + } + + /* Mark the cells of the live list (yes, the cells in the list, we + don't care about objects pointed to by the list cars, since we + know they are already marked). */ + for (pair = g->live.head; !SCM_NULLP (pair); pair = SCM_CDR (pair)) + SCM_SETGCMARK (pair); +} + /* this is called by the garbage collector between the mark and sweep phases. for each marked guardian, it moves any unmarked object in @@ -251,83 +409,86 @@ guardian_gc_init (void *dummy1, void *dummy2, void *dummy3) static void * guardian_zombify (void *dummy1, void *dummy2, void *dummy3) { - guardian_t *first_guardian; - guardian_t **link_field = &first_live_guardian; + guardian_t *last_greedy_guardian = NULL; + guardian_t *last_sharing_guardian = NULL; + guardian_t *first_greedy_guardian = NULL; + guardian_t *first_sharing_guardian = NULL; + guardian_t *g; - /* Note that new guardians may be stuck on the end of the live - guardian list as we run this loop. As we move unmarked objects - to the zombie list and mark them, we may find some guarded - guardians. The guardian mark function will stick them on the end - of this list, so they'll be processed properly. */ + /* First, find all newly unreachable objects and mark their + dependencies. + + Note that new guardians may be stuck on the end of the live + guardian lists as we run this loop, since guardians might be + guarded too. When we mark a guarded guardian, its mark function + sticks in the appropriate live guardian list. The loop + terminates when no new guardians are found. */ do { - guardian_t *g; - - first_guardian = *link_field; - link_field = current_link_field; + first_greedy_guardian = greedy_guardians; + first_sharing_guardian = sharing_guardians; - /* first, scan all the guardians that are currently known to be live - and move their unmarked objects to zombie lists. */ + for (g = greedy_guardians; g != last_greedy_guardian; + g = g->next) + mark_dependencies (g); + for (g = sharing_guardians; g != last_sharing_guardian; + g = g->next) + mark_dependencies (g); - for (g = first_guardian; g; g = g->next) - { - SCM tconc_tail = g->live.tail; - SCM *prev_ptr = &g->live.head; - SCM pair = g->live.head; + last_greedy_guardian = first_greedy_guardian; + last_sharing_guardian = first_sharing_guardian; + } while (first_greedy_guardian != greedy_guardians + || first_sharing_guardian != sharing_guardians); - while (! SCM_EQ_P (pair, tconc_tail)) - { - SCM next_pair = SCM_CDR (pair); + /* now, scan all the guardians that are currently known to be live + and move their unmarked objects to zombie lists. */ - if (SCM_NMARKEDP (SCM_CAR (pair))) - { - /* got you, zombie! */ + for (g = greedy_guardians; g; g = g->next) + { + mark_and_zombify (g); + g->listed_p = 0; + } + for (g = sharing_guardians; g; g = g->next) + { + mark_and_zombify (g); + g->listed_p = 0; + } + + /* Preserve the zombies in their undead state, by marking to prevent + collection. */ + for (g = greedy_guardians; g; g = g->next) + scm_gc_mark (g->zombies.head); + for (g = sharing_guardians; g; g = g->next) + scm_gc_mark (g->zombies.head); - /* out of the live list! */ - *prev_ptr = next_pair; + return 0; +} - /* into the zombie list! */ - TCONC_IN (g->zombies, SCM_CAR (pair), pair); - } - else - prev_ptr = SCM_CDRLOC (pair); +static void * +whine_about_self_centered_zombies (void *dummy1, void *dummy2, void *dummy3) +{ + if (! SCM_NULLP (SCM_CDR (self_centered_zombies))) + { + SCM pair; + + scm_puts ("** WARNING: the following guarded objects were unguarded due to cycles:", + scm_cur_errp); + scm_newline (scm_cur_errp); + for (pair = SCM_CDR (self_centered_zombies); + ! SCM_NULLP (pair); pair = SCM_CDR (pair)) + { + scm_display (SCM_CAR (pair), scm_cur_errp); + scm_newline (scm_cur_errp); + } - pair = next_pair; - } - - /* Mark the cells of the live list (yes, the cells in the list, - even though we don't care about objects pointed to by the list - cars, since we know they are already marked). */ - for (pair = g->live.head; !SCM_NULLP (pair); pair = SCM_CDR (pair)) - SCM_SETGCMARK (pair); - } - - /* ghouston: Doesn't it seem a bit disturbing that if a zombie - is returned to full life after getting returned from the - guardian procedure, it may reference objects which are in a - guardian's zombie list? Is it not necessary to move such - zombies back to the live list, to avoid allowing the - guardian procedure to return an object which is referenced, - so not collectable? The paper doesn't give this - impression. - - cmm: the paper does explicitly say that an object that is - guarded more than once should be returned more than once. - I believe this covers the above scenario. */ - - /* Preserve the zombies in their undead state, by marking to - prevent collection. Note that this may uncover zombified - guardians -- if so, they'll be processed in the next loop. */ - for (g = first_guardian; g != *link_field; g = g->next) - scm_gc_mark (g->zombies.head); - } while (current_link_field != link_field); + SCM_SETCDR (self_centered_zombies, SCM_EOL); + } return 0; } - void -scm_init_guardian() +scm_init_guardians () { tc16_guardian = scm_make_smob_type ("guardian", 0); scm_set_smob_mark (tc16_guardian, guardian_mark); @@ -338,6 +499,14 @@ scm_init_guardian() scm_c_hook_add (&scm_before_mark_c_hook, guardian_gc_init, 0, 0); scm_c_hook_add (&scm_before_sweep_c_hook, guardian_zombify, 0, 0); + greedily_guarded_prop = + scm_permanent_object (scm_primitive_make_property (SCM_BOOL_F)); + + self_centered_zombies = + scm_permanent_object (scm_cons (SCM_UNDEFINED, SCM_EOL)); + scm_c_hook_add (&scm_after_gc_c_hook, + whine_about_self_centered_zombies, 0, 0); + #ifndef SCM_MAGIC_SNARFER #include "libguile/guardians.x" #endif diff --git a/libguile/guardians.h b/libguile/guardians.h index 2c98c3711..687f6c435 100644 --- a/libguile/guardians.h +++ b/libguile/guardians.h @@ -46,13 +46,13 @@ #include "libguile/__scm.h" -SCM scm_make_guardian (void); +SCM scm_make_guardian (SCM exclusive_p); /* these are to be called from C: */ void scm_guard (SCM guardian, SCM obj); SCM scm_get_one_zombie (SCM guardian); -void scm_init_guardian (void); +void scm_init_guardians (void); #endif /* !SCM_GUARDIANH */ diff --git a/libguile/init.c b/libguile/init.c index e180b99ae..ff37d9c0a 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -555,7 +555,7 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_init_vectors (); scm_init_version (); scm_init_weaks (); - scm_init_guardian (); + scm_init_guardians (); scm_init_vports (); scm_init_eval (); scm_init_evalext (); From 3405cffa63fde1241c3bfc2696c887a311a55036 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Sun, 24 Dec 2000 00:41:14 +0000 Subject: [PATCH 0444/2047] *** empty log message *** --- libguile/guardians.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/guardians.h b/libguile/guardians.h index 687f6c435..e6fadea9a 100644 --- a/libguile/guardians.h +++ b/libguile/guardians.h @@ -46,7 +46,7 @@ #include "libguile/__scm.h" -SCM scm_make_guardian (SCM exclusive_p); +SCM scm_make_guardian (SCM greedy_p); /* these are to be called from C: */ void scm_guard (SCM guardian, SCM obj); From 0209177b7762f923d0cc56e9cf710f267263d259 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Sun, 24 Dec 2000 09:54:24 +0000 Subject: [PATCH 0445/2047] * gc.c: (scm_gc_mark_dependencies): use SCM_EQ_P for SCMs, not '=='. also, return after calling `scm_gc_mark'. --- libguile/ChangeLog | 5 +++++ libguile/gc.c | 6 +++--- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 9077d137e..262a3ab2c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2000-12-24 Michael Livshin + + * gc.c: (scm_gc_mark_dependencies): use SCM_EQ_P for SCMs, not + '=='. also, return after calling `scm_gc_mark'. + 2000-12-24 Michael Livshin * gc.c: (scm_gc_mark_dependencies): new function. like diff --git a/libguile/gc.c b/libguile/gc.c index ebafc9f87..b1095d135 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1125,10 +1125,11 @@ gc_mark_loop: gc_mark_nimp: #ifdef MARK_DEPENDENCIES - if (ptr == p) + if (SCM_EQ_P (ptr, p)) return; scm_gc_mark (ptr); + return; gc_mark_loop_first_time: #endif @@ -1381,13 +1382,13 @@ gc_mark_loop_first_time: def: SCM_MISC_ERROR ("unknown type", SCM_EOL); } +#undef RECURSE } #undef FUNC_NAME #ifndef MARK_DEPENDENCIES #undef MARK -#undef RECURSE #undef FNAME /* And here we define `scm_gc_mark_dependencies', by including this @@ -1399,7 +1400,6 @@ gc_mark_loop_first_time: #include "gc.c" #undef MARK_DEPENDENCIES #undef MARK -#undef RECURSE #undef FNAME From c275ccf59e31d76edf35385e62d6b82c0da2543d Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Thu, 28 Dec 2000 14:26:12 +0000 Subject: [PATCH 0446/2047] * guardians.c (mark_dependencies_in_tconc): new function. (mark_dependencies): bug fix. mark the dependencies of the known zombies, too. duh. --- libguile/ChangeLog | 6 ++++++ libguile/guardians.c | 15 +++++++++++---- 2 files changed, 17 insertions(+), 4 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 262a3ab2c..fcc3b94a7 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2000-12-28 Michael Livshin + + * guardians.c (mark_dependencies_in_tconc): new function. + (mark_dependencies): bug fix. mark the dependencies of the known + zombies, too. duh. + 2000-12-24 Michael Livshin * gc.c: (scm_gc_mark_dependencies): use SCM_EQ_P for SCMs, not diff --git a/libguile/guardians.c b/libguile/guardians.c index 5a53a6222..130b3e1df 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -320,15 +320,15 @@ guardian_gc_init (void *dummy1, void *dummy2, void *dummy3) } static void -mark_dependencies (guardian_t *g) +mark_dependencies_in_tconc (tconc_t *tc) { SCM pair, next_pair; SCM *prev_ptr; - /* scan the live list for unmarked objects, and mark their + /* scan the list for unmarked objects, and mark their dependencies */ - for (pair = g->live.head, prev_ptr = &g->live.head; - ! SCM_EQ_P (pair, g->live.tail); + for (pair = tc->head, prev_ptr = &tc->head; + ! SCM_EQ_P (pair, tc->tail); pair = next_pair) { SCM obj = SCM_CAR (pair); @@ -363,6 +363,13 @@ mark_dependencies (guardian_t *g) } } +static void +mark_dependencies (guardian_t *g) +{ + mark_dependencies_in_tconc (&g->zombies); + mark_dependencies_in_tconc (&g->live); +} + static void mark_and_zombify (guardian_t *g) { From 23a62df4fea25cfaa41382f283aa8b2411d7015b Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 28 Dec 2000 15:09:56 +0000 Subject: [PATCH 0447/2047] * Re-introduces the unused member "documentation" of struct scm_subr_entry. --- NEWS | 3 +-- RELEASE | 2 +- libguile/ChangeLog | 12 ++++++++++++ libguile/procs.c | 3 +++ libguile/procs.h | 3 ++- 5 files changed, 19 insertions(+), 4 deletions(-) diff --git a/NEWS b/NEWS index f171f8082..13950944d 100644 --- a/NEWS +++ b/NEWS @@ -330,8 +330,7 @@ SCM_VALIDATE_NULLORROSTRING_COPY, SCM_ROLENGTH, SCM_LENGTH, SCM_HUGE_LENGTH, SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR, SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING, SCM_ROCHARS, SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS, SCM_LENGTH_MAX, SCM_GC8MARKP, -SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR, SCM_SUBR_DOC, -SCM_SUBR_PROPS +SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR, SCM_SUBR_DOC Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of SCM_OUTOFRANGE. Use scm_memory_error instead of SCM_NALLOC. diff --git a/RELEASE b/RELEASE index f0c912185..16230478a 100644 --- a/RELEASE +++ b/RELEASE @@ -53,7 +53,7 @@ In release 1.6: SCM_COERCE_SUBSTR, SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING, SCM_ROCHARS, SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS, SCM_LENGTH_MAX, SCM_GC8MARKP, SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR, - SCM_SUBR_DOC, SCM_SUBR_PROPS + SCM_SUBR_DOC - remove scm_vector_set_length_x - remove function scm_call_catching_errors (replaced by catch functions from throw.[ch]) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index fcc3b94a7..665d820d6 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,15 @@ +2000-12-28 Dirk Herrmann + + This patch re-introduces the unused member "documentation" of + struct scm_subr_entry as requested by Mikael Djurfeldt. + + * procs.h (scm_subr_entry): Re-introduced member "documentation". + + (SCM_SUBR_DOC): Un-deprecated. + + * procs.c (scm_make_subr_opt, scm_mark_subr_table): Struct + scm_subr_entry has a member "documentation" again. + 2000-12-28 Michael Livshin * guardians.c (mark_dependencies_in_tconc): new function. diff --git a/libguile/procs.c b/libguile/procs.c index a79c7d79c..d1279a21a 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -102,6 +102,7 @@ scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set) scm_subr_table[entry].handle = z; scm_subr_table[entry].name = symbol; scm_subr_table[entry].generic = 0; + scm_subr_table[entry].properties = SCM_EOL; SCM_SET_SUBRF (z, fcn); SCM_SET_CELL_TYPE (z, (entry << 8) + type); @@ -148,6 +149,8 @@ scm_mark_subr_table () SCM_SETGCMARK (scm_subr_table[i].name); if (scm_subr_table[i].generic && *scm_subr_table[i].generic) scm_gc_mark (*scm_subr_table[i].generic); + if (SCM_NIMP (scm_subr_table[i].properties)) + scm_gc_mark (scm_subr_table[i].properties); } } diff --git a/libguile/procs.h b/libguile/procs.h index a843525a4..3e332f0ab 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -62,6 +62,7 @@ typedef struct SCM *generic; /* 0 if no generic support * *generic == 0 until first method */ + SCM properties; /* procedure properties */ } scm_subr_entry; #define SCM_SUBRNUM(subr) (SCM_CELL_WORD_0 (subr) >> 8) @@ -72,6 +73,7 @@ typedef struct #define SCM_SUBRF(x) ((SCM (*)()) SCM_CELL_WORD_1 (x)) #define SCM_SET_SUBRF(x, v) (SCM_SET_CELL_WORD_1 ((x), (v))) #define SCM_DSUBRF(x) ((double (*)()) SCM_CELL_WORD_1 (x)) +#define SCM_SUBR_PROPS(x) (SCM_SUBR_ENTRY (x).properties) #define SCM_SUBR_GENERIC(x) (SCM_SUBR_ENTRY (x).generic) #define SCM_CCLO_LENGTH(x) (SCM_CELL_WORD_0 (x) >> 8) @@ -188,7 +190,6 @@ extern SCM scm_make_cclo (SCM proc, SCM len); #if (SCM_DEBUG_DEPRECATED == 0) -#define SCM_SUBR_PROPS(x) SCM_EOL #define SCM_SUBR_DOC(x) SCM_BOOL_F #endif /* SCM_DEBUG_DEPRECATED == 0 */ From fcba9b58c677407263282a4028f55c33151d2ca5 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 28 Dec 2000 16:06:56 +0000 Subject: [PATCH 0448/2047] * Get rid of the annoying variable-gets-clobbered-by-longjmp warning. --- HACKING | 9 ++------- libguile/ChangeLog | 7 +++++++ libguile/continuations.c | 2 +- 3 files changed, 10 insertions(+), 8 deletions(-) diff --git a/HACKING b/HACKING index 69258c4af..17f3fd7bf 100644 --- a/HACKING +++ b/HACKING @@ -130,13 +130,8 @@ make-stds.texi. - The Guile tree should compile without warnings under the following GCC switches, which are the default in the current configure script: - -O2 -Wall -Wpointer-arith -Wmissing-prototypes The only warnings -which can be tolerated are those about variables being clobbered by -longjmp/vfork in eval.c. The variables in question are critical to -the interpreter's performance; as far as I can tell, it is -difficult/annoying to avoid these warnings without slowing the system -down substantially. (If you can figure out a good fix, I'd be happy -to see it.) + + -O2 -Wall -Wpointer-arith -Wmissing-prototypes Note that the warnings generated vary from one version of GCC to the next, and from one architecture to the next (apparently). To provide diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 665d820d6..1c940a079 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2000-12-28 Dirk Herrmann + + * continuations.c (scm_make_continuation): Make variable cont + volatile to let the compiler know that it won't be clobbered by + longjmp. (It wouldn't be anyway, but for some reason the compiler + is not able to see that.) + 2000-12-28 Dirk Herrmann This patch re-introduces the unused member "documentation" of diff --git a/libguile/continuations.c b/libguile/continuations.c index 12d313e50..8a160e91b 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -111,7 +111,7 @@ continuation_print (SCM obj, SCM port, scm_print_state *state) SCM scm_make_continuation (int *first) { - SCM cont; + volatile SCM cont; scm_contregs *continuation; scm_contregs *rootcont = SCM_CONTREGS (scm_rootcont); long stack_size; From 5d2b97cd077bb3d63e47729c800edc349e583f8e Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 28 Dec 2000 16:49:09 +0000 Subject: [PATCH 0449/2047] * Fixed the changelog entry regarding re-introduction of struct member properties (I continuously talked of member 'documentation' instead) * Replace calls to scm_remember with calls to scm_remember_upto_here_1. --- NEWS | 10 ++++++++++ RELEASE | 1 + libguile/ChangeLog | 20 ++++++++++++++++---- libguile/eval.c | 2 +- libguile/gc.c | 47 ++++++++++++++++++++++++++++++++++++++++++++++ libguile/gc.h | 5 ++++- libguile/gh_data.c | 10 ++++------ libguile/print.c | 2 +- 8 files changed, 84 insertions(+), 13 deletions(-) diff --git a/NEWS b/NEWS index 13950944d..f5f6746f9 100644 --- a/NEWS +++ b/NEWS @@ -276,6 +276,16 @@ behaviour is undefined - it may even crash or loop endlessly. Further, for the case that the object is not found in the list, scm_c_memq returns #f which is similar to scm_memq, but different from scm_sloppy_memq's behaviour. +** New functions: scm_remember_upto_here_1, scm_remember_upto_here_2, +scm_remember_upto_here + +These functions replace the function scm_remember. + +** Deprecated function: scm_remember + +Use one of the new functions scm_remember_upto_here_1, +scm_remember_upto_here_2 or scm_remember_upto_here instead. + ** New global variable scm_gc_running_p introduced. Use this variable to find out if garbage collection is being executed. Up to diff --git a/RELEASE b/RELEASE index 16230478a..21ffa085b 100644 --- a/RELEASE +++ b/RELEASE @@ -41,6 +41,7 @@ In release 1.6: eval.c: scm_eval2, scm_eval_3 load.c: scm_read_and_eval_x smob.c: scm_make_smob_type_mfpe, scm_set_smob_mfpe + gc.c: scm_remember - remove deprecated procedures: boot-9.scm:eval-in-module - remove deprecated macros: SCM_OUTOFRANGE, SCM_NALLOC, SCM_HUP_SIGNAL, diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 1c940a079..5961def8e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,15 @@ +2000-12-28 Dirk Herrmann + + * eval.c (check_map_args), gh_data.c (gh_set_substr, + gh_scm2newstr, gh_get_substr, gh_symbol2newstr), print.c + (scm_iprin1): Use scm_remember_upto_here_1 instead of + scm_remember. + + * gc.[ch] (scm_remember_upto_here_1, scm_remember_upto_here_2, + scm_remember_upto_here): New functions. + + (scm_remember): Deprecated. + 2000-12-28 Dirk Herrmann * continuations.c (scm_make_continuation): Make variable cont @@ -7,15 +19,15 @@ 2000-12-28 Dirk Herrmann - This patch re-introduces the unused member "documentation" of + This patch re-introduces the unused member "properties" of struct scm_subr_entry as requested by Mikael Djurfeldt. - * procs.h (scm_subr_entry): Re-introduced member "documentation". + * procs.h (scm_subr_entry): Re-introduced member "properties". - (SCM_SUBR_DOC): Un-deprecated. + (SCM_SUBR_PROPS): Un-deprecated. * procs.c (scm_make_subr_opt, scm_mark_subr_table): Struct - scm_subr_entry has a member "documentation" again. + scm_subr_entry has a member "properties" again. 2000-12-28 Michael Livshin diff --git a/libguile/eval.c b/libguile/eval.c index 57943e6c4..b7cf5be11 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3550,7 +3550,7 @@ check_map_args (SCM argv, scm_out_of_range (who, ve[i]); } - scm_remember (&argv); + scm_remember_upto_here_1 (argv); } diff --git a/libguile/gc.c b/libguile/gc.c index b1095d135..d6767651d 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -2316,12 +2316,59 @@ SCM_DEFINE (scm_unhash_name, "unhash-name", 1, 0, 0, */ +/* + * If within a function you need to protect one or more scheme objects from + * garbage collection, pass them as parameters to one of the + * scm_remember_upto_here* functions below. These functions don't do + * anything, but since the compiler does not know that they are actually + * no-ops, it will generate code that calls these functions with the given + * parameters. Therefore, you can be sure that the compiler will keep those + * scheme values alive (on the stack or in a register) up to the point where + * scm_remember_upto_here* is called. In other words, place the call to + * scm_remember_upt_here* _behind_ the last code in your function, that + * depends on the scheme object to exist. + * + * Example: We want to make sure, that the string object str does not get + * garbage collected during the execution of 'some_function', because + * otherwise the characters belonging to str would be freed and + * 'some_function' might access freed memory. To make sure that the compiler + * keeps str alive on the stack or in a register such that it is visible to + * the conservative gc we add the call to scm_remember_upto_here_1 _after_ the + * call to 'some_function'. Note that this would not be necessary if str was + * used anyway after the call to 'some_function'. + * char *chars = SCM_STRING_CHARS (str); + * some_function (chars); + * scm_remember_upto_here_1 (str); // str will be alive up to this point. + */ + +void +scm_remember_upto_here_1 (SCM obj) +{ + /* Empty. Protects a single object from garbage collection. */ +} + +void +scm_remember_upto_here_2 (SCM obj1, SCM obj2) +{ + /* Empty. Protects two objects from garbage collection. */ +} + +void +scm_remember_upto_here (SCM obj, ...) +{ + /* Empty. Protects any number of objects from garbage collection. */ +} + + +#if (SCM_DEBUG_DEPRECATED == 0) + void scm_remember (SCM *ptr) { /* empty */ } +#endif /* SCM_DEBUG_DEPRECATED == 0 */ /* These crazy functions prevent garbage collection diff --git a/libguile/gc.h b/libguile/gc.h index c0c8ce70b..893c262e7 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -349,7 +349,9 @@ extern void * scm_must_realloc (void *where, extern void scm_done_malloc (long size); extern void scm_done_free (long size); extern void scm_must_free (void *obj); -extern void scm_remember (SCM * ptr); +extern void scm_remember_upto_here_1 (SCM obj); +extern void scm_remember_upto_here_2 (SCM obj1, SCM obj2); +extern void scm_remember_upto_here (SCM obj1, ...); extern SCM scm_return_first (SCM elt, ...); extern int scm_return_first_int (int x, ...); extern SCM scm_permanent_object (SCM obj); @@ -370,6 +372,7 @@ extern void scm_init_gc (void); #define SCM_CLRGC8MARK(x) SCM_CLRGCMARK (x) #define SCM_GCTYP16(x) SCM_TYP16 (x) #define SCM_GCCDR(x) SCM_CDR (x) +extern void scm_remember (SCM * ptr); #endif /* SCM_DEBUG_DEPRECATED == 0 */ diff --git a/libguile/gh_data.c b/libguile/gh_data.c index f7e74e5af..33c615251 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -122,7 +122,7 @@ gh_set_substr (char *src, SCM dst, int start, int len) effective_length = ((unsigned) len < dst_len) ? len : dst_len; memmove (dst_ptr + start, src, effective_length); - scm_remember (&dst); + scm_remember_upto_here_1 (dst); } /* Return the symbol named SYMBOL_STR. */ @@ -543,8 +543,7 @@ gh_scm2newstr (SCM str, int *lenp) "gh_scm2newstr"); /* so we copy tmp_str to ret_str, which is what we will allocate */ memcpy (ret_str, SCM_STRING_CHARS (str), len); - /* from now on we don't mind if str gets GC collected. */ - scm_remember (&str); + scm_remember_upto_here_1 (str); /* now make sure we null-terminate it */ ret_str[len] = '\0'; @@ -575,7 +574,7 @@ gh_get_substr (SCM src, char *dst, int start, int len) effective_length = (len < src_len) ? len : src_len; memcpy (dst + start, SCM_STRING_CHARS (src), effective_length * sizeof (char)); /* FIXME: must signal an error if len > src_len */ - scm_remember (&src); + scm_remember_upto_here_1 (src); } @@ -600,8 +599,7 @@ gh_symbol2newstr (SCM sym, int *lenp) "gh_symbol2newstr"); /* so we copy sym to ret_str, which is what we will allocate */ memcpy (ret_str, SCM_SYMBOL_CHARS (sym), len); - /* from now on we don't mind if sym gets GC collected. */ - scm_remember (&sym); + scm_remember_upto_here_1 (sym); /* now make sure we null-terminate it */ ret_str[len] = '\0'; diff --git a/libguile/print.c b/libguile/print.c index a07d61fe6..0dc7b82ff 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -578,7 +578,7 @@ taloop: } if (pos < end) scm_lfwrite (str + pos, end - pos, port); - scm_remember (&exp); + scm_remember_upto_here_1 (exp); if (weird) scm_lfwrite ("}#", 2, port); break; From 174663302558e2eda063dfe185beef860b39deb2 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 29 Dec 2000 15:47:16 +0000 Subject: [PATCH 0450/2047] * Remove calls to symbol-interned? which have always been useless, but now have become wrong since symbols and bindings are separated. --- ice-9/ChangeLog | 10 ++++++++++ ice-9/boot-9.scm | 6 ++---- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 2703c0ee5..dc624c644 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,13 @@ +2000-12-29 Dirk Herrmann + + * boot-9.scm (root-module-closure, scm-module-closure): Remove + calls '(symbol-interned? #f s)'. Formerly, these calls were + basically no-ops, guaranteed to return #t if 's' was a symbol. + After the separation of symbols and bindings, a call to + '(symbol-interned? #f s)' will only return #t if there really is a + binding for 's' in the scm_symhash table. Thanks to Dale P. Smith + for providing a test case that helped finding this bug. + 2000-12-13 Dirk Herrmann * session.scm (apropos): Completed the last patch, which did only diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index c674f1b6b..c6a48099a 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1440,8 +1440,7 @@ (define (root-module-closure m s define?) - (let ((bi (and (symbol-interned? #f s) - (builtin-variable s)))) + (let ((bi (builtin-variable s))) (and bi (or define? (variable-bound? bi)) (begin @@ -1462,8 +1461,7 @@ ;; (define (scm-module-closure m s define?) - (let ((bi (and (symbol-interned? #f s) - (builtin-variable s)))) + (let ((bi (builtin-variable s))) (and bi (variable-bound? bi) (begin From d9dcd93362ef2956d9d11a46024173c74e197f3c Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Fri, 29 Dec 2000 22:18:06 +0000 Subject: [PATCH 0451/2047] * weaks.c (scm_scan_weak_vectors): move the calculation of the `weak_keys' and `weak_values' flags out of the inner loop. * guardians.c: (greedily_guarded_prop): deleted. (greedily_guarded_whash): new variable. a doubly-weak hash table used to keep the "greedily hashed" object property. the previous implementation (via primitive object properties) was incorrect due to its only-the-key-is-weak semantics. (scm_guard, get_one_zombie, scm_init_guardians): use/init `greedily_guarded_whash'. --- libguile/ChangeLog | 15 +++++++++++++++ libguile/guardians.c | 27 +++++++++++++-------------- libguile/weaks.c | 7 ++----- 3 files changed, 30 insertions(+), 19 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 5961def8e..5ca3307c2 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,18 @@ +2000-12-30 Michael Livshin + + * weaks.c (scm_scan_weak_vectors): move the calculation of the + `weak_keys' and `weak_values' flags out of the inner loop. + +2000-12-29 Michael Livshin + + * guardians.c: (greedily_guarded_prop): deleted. + (greedily_guarded_whash): new variable. a doubly-weak hash table + used to keep the "greedily hashed" object property. the previous + implementation (via primitive object properties) was incorrect due + to its only-the-key-is-weak semantics. + (scm_guard, get_one_zombie, scm_init_guardians): use/init + `greedily_guarded_whash'. + 2000-12-28 Dirk Herrmann * eval.c (check_map_args), gh_data.c (gh_set_substr, diff --git a/libguile/guardians.c b/libguile/guardians.c index 130b3e1df..207567cd2 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -66,8 +66,9 @@ #include "libguile/print.h" #include "libguile/smob.h" #include "libguile/validate.h" -#include "libguile/properties.h" #include "libguile/root.h" +#include "libguile/hashtab.h" +#include "libguile/weaks.h" #include "libguile/guardians.h" @@ -126,9 +127,7 @@ typedef struct guardian_t static guardian_t *greedy_guardians = NULL; static guardian_t *sharing_guardians = NULL; -/* greedily guarded objects have this property set, so that we can - catch any attempt to greedily guard them again */ -static SCM greedily_guarded_prop = SCM_EOL; +static SCM greedily_guarded_whash = SCM_EOL; /* this is the list of guarded objects that are parts of cycles. we don't know in which order to return them from guardians, so we just @@ -219,13 +218,13 @@ scm_guard (SCM guardian, SCM obj) if (GUARDIAN_GREEDY_P (guardian)) { - if (SCM_NFALSEP (scm_primitive_property_ref - (greedily_guarded_prop, obj))) + if (SCM_NFALSEP (scm_hashq_get_handle + (greedily_guarded_whash, obj))) scm_misc_error ("guard", "object is already greedily guarded", obj); else - scm_primitive_property_set_x (greedily_guarded_prop, - obj, SCM_BOOL_T); + scm_hashq_create_handle_x (greedily_guarded_whash, + obj, guardian); } SCM_NEWCELL (z); @@ -251,9 +250,9 @@ scm_get_one_zombie (SCM guardian) if (SCM_NFALSEP (res) && GUARDIAN_GREEDY_P (guardian) - && SCM_NFALSEP (scm_primitive_property_ref - (greedily_guarded_prop, res))) - scm_primitive_property_del_x (greedily_guarded_prop, res); + && SCM_NFALSEP (scm_hashq_get_handle + (greedily_guarded_whash, res))) + scm_hashq_remove_x (greedily_guarded_whash, res); return res; } @@ -506,14 +505,14 @@ scm_init_guardians () scm_c_hook_add (&scm_before_mark_c_hook, guardian_gc_init, 0, 0); scm_c_hook_add (&scm_before_sweep_c_hook, guardian_zombify, 0, 0); - greedily_guarded_prop = - scm_permanent_object (scm_primitive_make_property (SCM_BOOL_F)); - self_centered_zombies = scm_permanent_object (scm_cons (SCM_UNDEFINED, SCM_EOL)); scm_c_hook_add (&scm_after_gc_c_hook, whine_about_self_centered_zombies, 0, 0); + greedily_guarded_whash = + scm_permanent_object (scm_make_doubly_weak_hash_table (SCM_MAKINUM (31))); + #ifndef SCM_MAGIC_SNARFER #include "libguile/guardians.x" #endif diff --git a/libguile/weaks.c b/libguile/weaks.c index e6d47a376..f0b006a5a 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -273,6 +273,8 @@ scm_scan_weak_vectors (void *dummy1, void *dummy2, void *dummy3) SCM obj = w; register long n = SCM_VECTOR_LENGTH (w); register long j; + int weak_keys = SCM_IS_WHVEC (obj) || SCM_IS_WHVEC_B (obj); + int weak_values = SCM_IS_WHVEC_V (obj) || SCM_IS_WHVEC_B (obj); ptr = SCM_VELTS (w); @@ -280,11 +282,6 @@ scm_scan_weak_vectors (void *dummy1, void *dummy2, void *dummy3) { SCM * fixup; SCM alist; - int weak_keys; - int weak_values; - - weak_keys = SCM_IS_WHVEC (obj) || SCM_IS_WHVEC_B (obj); - weak_values = SCM_IS_WHVEC_V (obj) || SCM_IS_WHVEC_B (obj); fixup = ptr + j; alist = *fixup; From 75bc0690c8ca491927cba001238605e3856c5ff8 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Sat, 30 Dec 2000 19:26:37 +0000 Subject: [PATCH 0452/2047] * guardians.c (guardian_print): for sharing guardians, print that they are sharing. (scm_guard, scm_get_one_zombie): place the critical section barriers more correctly. --- libguile/ChangeLog | 5 +++++ libguile/guardians.c | 24 +++++++++++++++++------- 2 files changed, 22 insertions(+), 7 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 5ca3307c2..cb8d92eca 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,10 @@ 2000-12-30 Michael Livshin + * guardians.c (guardian_print): for sharing guardians, print that + they are sharing. + (scm_guard, scm_get_one_zombie): place the critical section + barriers more correctly. + * weaks.c (scm_scan_weak_vectors): move the calculation of the `weak_keys' and `weak_values' flags out of the inner loop. diff --git a/libguile/guardians.c b/libguile/guardians.c index 207567cd2..58802a6bd 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -182,6 +182,8 @@ guardian_print (SCM g, SCM port, scm_print_state *pstate) scm_puts ("#<", port); if (GUARDIAN_GREEDY_P (g)) scm_puts ("greedy ", port); + else + scm_puts ("sharing ", port); scm_puts ("guardian (reachable: ", port); scm_display (scm_length (SCM_CDR (GUARDIAN_LIVE (g).head)), port); scm_puts (" unreachable: ", port); @@ -216,24 +218,30 @@ scm_guard (SCM guardian, SCM obj) { SCM z; + SCM_NEWCELL (z); + + /* This critical section barrier will be replaced by a mutex. */ + SCM_DEFER_INTS; + if (GUARDIAN_GREEDY_P (guardian)) { if (SCM_NFALSEP (scm_hashq_get_handle (greedily_guarded_whash, obj))) - scm_misc_error ("guard", - "object is already greedily guarded", obj); + { + SCM_ALLOW_INTS; + scm_misc_error ("guard", + "object is already greedily guarded", obj); + } else scm_hashq_create_handle_x (greedily_guarded_whash, obj, guardian); } - SCM_NEWCELL (z); - - /* This critical section barrier will be replaced by a mutex. */ - SCM_DEFER_INTS; TCONC_IN (GUARDIAN_LIVE (guardian), obj, z); + SCM_ALLOW_INTS; } + } @@ -244,15 +252,17 @@ scm_get_one_zombie (SCM guardian) /* This critical section barrier will be replaced by a mutex. */ SCM_DEFER_INTS; + if (!TCONC_EMPTYP (GUARDIAN_ZOMBIES (guardian))) TCONC_OUT (GUARDIAN_ZOMBIES (guardian), res); - SCM_ALLOW_INTS; if (SCM_NFALSEP (res) && GUARDIAN_GREEDY_P (guardian) && SCM_NFALSEP (scm_hashq_get_handle (greedily_guarded_whash, res))) scm_hashq_remove_x (greedily_guarded_whash, res); + + SCM_ALLOW_INTS; return res; } From 0c6d2191efac1342a0306d7182e32f0aaf1a402c Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Tue, 2 Jan 2001 00:38:41 +0000 Subject: [PATCH 0453/2047] * fports.c (fport_write): bugfix: handle short writes for unbuffered ports too. optimize the buffered case by minimizing the number of write/flush calls. (write_all): new helper procedure. --- libguile/ChangeLog | 7 ++++ libguile/fports.c | 90 +++++++++++++++++++++++++++++++++------------- 2 files changed, 73 insertions(+), 24 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index cb8d92eca..7aa776caf 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2001-01-01 Gary Houston + + * fports.c (fport_write): bugfix: handle short writes for + unbuffered ports too. optimize the buffered case by minimizing + the number of write/flush calls. + (write_all): new helper procedure. + 2000-12-30 Michael Livshin * guardians.c (guardian_print): for sharing guardians, print that diff --git a/libguile/fports.c b/libguile/fports.c index f8a717001..9d0f96d51 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -573,41 +573,83 @@ fport_truncate (SCM port, off_t length) scm_syserror ("ftruncate"); } +/* helper for fport_write: try to write data, using multiple system + calls if required. */ +#define FUNC_NAME "write_all" +static void write_all (SCM port, const void *data, size_t remaining) +{ + int fdes = SCM_FSTREAM (port)->fdes; + + while (remaining > 0) + { + ssize_t done; + + SCM_SYSCALL (done = write (fdes, data, remaining)); + + if (done == -1) + SCM_SYSERROR; + remaining -= done; + data = ((const char *) data) + done; + } +} +#undef FUNC_NAME + static void fport_write (SCM port, const void *data, size_t size) { + /* this procedure tries to minimize the number of writes/flushes. */ scm_port *pt = SCM_PTAB_ENTRY (port); - if (pt->write_buf == &pt->shortbuf) + if (pt->write_buf == &pt->shortbuf + || (pt->write_pos == pt->write_buf && size >= pt->write_buf_size)) { - /* "unbuffered" port. */ - int fdes = SCM_FSTREAM (port)->fdes; - - if (write (fdes, data, size) == -1) - scm_syserror ("fport_write"); + /* "unbuffered" port, or + port with empty buffer and data won't fit in buffer. */ + write_all (port, data, size); + return; } - else - { - const char *input = (char *) data; - size_t remaining = size; - while (remaining > 0) - { - int space = pt->write_end - pt->write_pos; - int write_len = (remaining > space) ? space : remaining; + { + off_t space = pt->write_end - pt->write_pos; - memcpy (pt->write_pos, input, write_len); - pt->write_pos += write_len; - remaining -= write_len; - input += write_len; - if (write_len == space) + if (size <= space) + { + /* data fits in buffer. */ + memcpy (pt->write_pos, data, size); + pt->write_pos += size; + if (pt->write_pos == pt->write_end) + { fport_flush (port); - } - - /* handle line buffering. */ - if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && memchr (data, '\n', size)) + /* we can skip the line-buffering check if nothing's buffered. */ + return; + } + } + else + { + memcpy (pt->write_pos, data, space); + pt->write_pos = pt->write_end; fport_flush (port); - } + { + const void *ptr = ((const char *) data) + space; + size_t remaining = size - space; + + if (size >= pt->write_buf_size) + { + write_all (port, ptr, remaining); + return; + } + else + { + memcpy (pt->write_pos, ptr, remaining); + pt->write_pos += remaining; + } + } + } + + /* handle line buffering. */ + if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && memchr (data, '\n', size)) + fport_flush (port); + } } /* becomes 1 when process is exiting: normal exception handling won't From c0a5d8883541452d292c23a90ff4af445df22a05 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Thu, 4 Jan 2001 13:00:31 +0000 Subject: [PATCH 0454/2047] * guardians.c (F_GREEDY, F_LISTED, F_DESTROYED, GREEDY_P, SET_GREEDY, LISTED_P, SET_LISTED, CLR_LISTED, DESTROYED_P, SET_DESTROYED): new defines/macros. (GUARDIAN_LIVE, GUARDIAN_ZOMBIES, GUARDIAN_NEXT): deleted. (add_to_live_list): takes a `guardian_t *' now, not SCM. (guardian_print): print more info. (guardian_apply): check if the guardian is destroyed, and throw an error if so. take one more optional argument `throw_p'. (scm_guard): depending on the value of `throw_p', return a boolean result. (scm_get_one_zombie): remove redundant property test. (guardian_t): represent the various (currently 3, I hope nothing more gets added) boolean fields as bit flags. (scm_guardian_destroyed_p, scm_guardian_greedy_p): new predicates. (scm_destroy_guardian_x): new procedure. * guardians.h: added prototypes for `scm_guardian_greedy_p' and `scm_guardian_destroyed_p'. changed prototype for `scm_guard'. --- NEWS | 49 +++++++--- libguile/ChangeLog | 23 ++++- libguile/guardians.c | 221 ++++++++++++++++++++++++++++++++----------- libguile/guardians.h | 6 +- 4 files changed, 227 insertions(+), 72 deletions(-) diff --git a/NEWS b/NEWS index f5f6746f9..3ce9a76bb 100644 --- a/NEWS +++ b/NEWS @@ -87,28 +87,51 @@ Example: * Changes to Scheme functions and syntax -** The "guardian" facility has changed (mostly compatibly). +** The semantics of guardians has changed. -There are now two types of guardians: greedy and sharing. +The changes are for the most part compatible. An important criteria +was to keep the typical usage of guardians as simple as before, but to +make the semantics safer and (as a result) more useful. -If you call (make-guardian #t) or without any arguments, you get a -greedy guardian, else a sharing guardian. +*** All objects returned from guardians are now properly alive. -Greedy guardians are made the default because they are more -"defensive". You can only greedily guard an object once. If you -guard an object more than once, then it is guaranteed that the object -won't be returned from sharing guardians as long as it is greedily -guarded. - -The second change is making sure that all objects returned by -guardians are properly live, i.e. it is impossible to return a -contained object before the containing object. +It is now guaranteed that any object referenced by an object returned +from a guardian is alive. It's now impossible for a guardian to +return a "contained" object before its "containing" object. One incompatible (but probably not very important) change resulting from this is that it is no longer possible to guard objects that indirectly reference themselves (i.e. are parts of cycles). If you do so accidentally, you'll get a warning. +*** There are now two types of guardians: greedy and sharing. + +If you call (make-guardian #t) or just (make-guardian), you'll get a +greedy guardian, and for (make-guardian #f) a sharing guardian. + +Greedy guardians are the default because they are more "defensive". +You can only greedily guard an object once. If you guard an object +more than once, once in a greedy guardian and the rest of times in +sharing guardians, then it is guaranteed that the object won't be +returned from sharing guardians as long as it is greedily guarded +and/or alive. + +Guardians returned by calls to `make-guardian' can now take one more +optional parameter, which says whether to throw an error in case an +attempt is made to greedily guard an object that is already greedily +guarded. The default is true, i.e. throw an error. If the parameter +is false, the guardian invocation returns #t if guarding was +successful and #f if it wasn't. + +Also, since greedy guarding is, in effect, a side-effecting operation +on objects, a new function is introduced: `destroy-guardian!'. +Invoking this function on a guardian renders it unoperative and, if +the guardian is greedy, clears the "greedily guarded" property of the +objects that were guarded by it, thus undoing the side effect. + +Note that all this hair is hardly very important, since guardian +objects are usually permanent. + ** Escape procedures created by call-with-current-continuation now accept any number of arguments, as required by R5RS. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 7aa776caf..93c3ec4a5 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,24 @@ +2001-01-03 Michael Livshin + + * guardians.c (F_GREEDY, F_LISTED, F_DESTROYED, GREEDY_P, + SET_GREEDY, LISTED_P, SET_LISTED, CLR_LISTED, DESTROYED_P, + SET_DESTROYED): new defines/macros. + (GUARDIAN_LIVE, GUARDIAN_ZOMBIES, GUARDIAN_NEXT): deleted. + (add_to_live_list): takes a `guardian_t *' now, not SCM. + (guardian_print): print more info. + (guardian_apply): check if the guardian is destroyed, and throw an + error if so. take one more optional argument `throw_p'. + (scm_guard): depending on the value of `throw_p', return a boolean + result. + (scm_get_one_zombie): remove redundant property test. + (guardian_t): represent the various (currently 3, I hope nothing + more gets added) boolean fields as bit flags. + (scm_guardian_destroyed_p, scm_guardian_greedy_p): new predicates. + (scm_destroy_guardian_x): new procedure. + + * guardians.h: added prototypes for `scm_guardian_greedy_p' and + `scm_guardian_destroyed_p'. changed prototype for `scm_guard'. + 2001-01-01 Gary Houston * fports.c (fport_write): bugfix: handle short writes for @@ -19,7 +40,7 @@ * guardians.c: (greedily_guarded_prop): deleted. (greedily_guarded_whash): new variable. a doubly-weak hash table - used to keep the "greedily hashed" object property. the previous + used to keep the "greedily guarded" object property. the previous implementation (via primitive object properties) was incorrect due to its only-the-key-is-weak semantics. (scm_guard, get_one_zombie, scm_init_guardians): use/init diff --git a/libguile/guardians.c b/libguile/guardians.c index 58802a6bd..4a2200f2b 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -109,18 +109,25 @@ typedef struct guardian_t tconc_t live; tconc_t zombies; struct guardian_t *next; - int greedy_p; - int listed_p; + unsigned long flags; } guardian_t; #define GUARDIAN_P(x) SCM_SMOB_PREDICATE(tc16_guardian, x) #define GUARDIAN(x) ((guardian_t *) SCM_CELL_WORD_1 (x)) -#define GUARDIAN_LIVE(x) (GUARDIAN (x)->live) -#define GUARDIAN_ZOMBIES(x) (GUARDIAN (x)->zombies) -#define GUARDIAN_NEXT(x) (GUARDIAN (x)->next) -#define GUARDIAN_GREEDY_P(x) (GUARDIAN (x)->greedy_p) -#define GUARDIAN_LISTED_P(x) (GUARDIAN (x)->listed_p) +#define F_GREEDY 1L +#define F_LISTED (1L << 1) +#define F_DESTROYED (1L << 2) + +#define GREEDY_P(x) (((x)->flags & F_GREEDY) != 0) +#define SET_GREEDY(x) ((x)->flags |= F_GREEDY) + +#define LISTED_P(x) (((x)->flags & F_LISTED) != 0) +#define SET_LISTED(x) ((x)->flags |= F_LISTED) +#define CLR_LISTED(x) ((x)->flags &= ~F_LISTED) + +#define DESTROYED_P(x) (((x)->flags & F_DESTROYED) != 0) +#define SET_DESTROYED(x) ((x)->flags |= F_DESTROYED) /* during the gc mark phase, live guardians are linked into the lists here. */ @@ -136,30 +143,30 @@ static SCM self_centered_zombies = SCM_EOL; static void -add_to_live_list (SCM g) +add_to_live_list (guardian_t *g) { - if (GUARDIAN_LISTED_P (g)) + if (LISTED_P (g)) return; - if (GUARDIAN_GREEDY_P (g)) + if (GREEDY_P (g)) { - GUARDIAN_NEXT (g) = greedy_guardians; - greedy_guardians = GUARDIAN (g); + g->next = greedy_guardians; + greedy_guardians = g; } else { - GUARDIAN_NEXT (g) = sharing_guardians; - sharing_guardians = GUARDIAN (g); + g->next = sharing_guardians; + sharing_guardians = g; } - GUARDIAN_LISTED_P (g) = 1; + SET_LISTED (g); } /* mark a guardian by adding it to the live guardian list. */ static SCM guardian_mark (SCM ptr) { - add_to_live_list (ptr); + add_to_live_list (GUARDIAN (ptr)); /* the objects protected by the guardian are not marked here: that would prevent them from ever getting collected. instead marking @@ -177,43 +184,69 @@ guardian_free (SCM ptr) static int -guardian_print (SCM g, SCM port, scm_print_state *pstate) +guardian_print (SCM guardian, SCM port, scm_print_state *pstate) { + guardian_t *g = GUARDIAN (guardian); + scm_puts ("#<", port); - if (GUARDIAN_GREEDY_P (g)) - scm_puts ("greedy ", port); + + if (DESTROYED_P (g)) + scm_puts ("destroyed ", port); + + if (GREEDY_P (g)) + scm_puts ("greedy", port); else - scm_puts ("sharing ", port); - scm_puts ("guardian (reachable: ", port); - scm_display (scm_length (SCM_CDR (GUARDIAN_LIVE (g).head)), port); - scm_puts (" unreachable: ", port); - scm_display (scm_length (SCM_CDR (GUARDIAN_ZOMBIES (g).head)), port); - scm_puts (")>", port); + scm_puts ("sharing", port); + + scm_puts (" guardian 0x", port); + scm_intprint ((long) g, 16, port); + + if (! DESTROYED_P (g)) + { + scm_puts (" (reachable: ", port); + scm_display (scm_length (SCM_CDR (g->live.head)), port); + scm_puts (" unreachable: ", port); + scm_display (scm_length (SCM_CDR (g->zombies.head)), port); + scm_puts (")", port); + } + + scm_puts (">", port); return 1; } -/* This is the Scheme entry point for each guardian: If arg is an object, it's - * added to the guardian's live list. If arg is unbound, the next available - * zombified object (or #f if none) is returned. +/* This is the Scheme entry point for each guardian: If OBJ is an + * object, it's added to the guardian's live list. If OBJ is unbound, + * the next available unreachable object (or #f if none) is returned. + * + * If the second optional argument THROW_P is true (the default), then + * an error is raised if GUARDIAN is greedy and OBJ is already greedily + * guarded. If THROW_P is false, #f is returned instead of raising the + * error, and #t is returned if everything is fine. */ static SCM -guardian_apply (SCM guardian, SCM arg) +guardian_apply (SCM guardian, SCM obj, SCM throw_p) { - if (!SCM_UNBNDP (arg)) - { - scm_guard (guardian, arg); - return SCM_UNSPECIFIED; - } + if (DESTROYED_P (GUARDIAN (guardian))) + scm_misc_error ("guard", "attempted use of destroyed guardian: ~A", + SCM_LIST1 (guardian)); + + if (!SCM_UNBNDP (obj)) + return scm_guard (guardian, obj, + (SCM_UNBNDP (throw_p) + ? 1 + : SCM_NFALSEP (throw_p))); else return scm_get_one_zombie (guardian); } -void -scm_guard (SCM guardian, SCM obj) +SCM +scm_guard (SCM guardian, SCM obj, int throw_p) { + guardian_t *g = GUARDIAN (guardian); + if (!SCM_IMP (obj)) { SCM z; @@ -223,43 +256,49 @@ scm_guard (SCM guardian, SCM obj) /* This critical section barrier will be replaced by a mutex. */ SCM_DEFER_INTS; - if (GUARDIAN_GREEDY_P (guardian)) + if (GREEDY_P (g)) { if (SCM_NFALSEP (scm_hashq_get_handle (greedily_guarded_whash, obj))) { SCM_ALLOW_INTS; - scm_misc_error ("guard", - "object is already greedily guarded", obj); + + if (throw_p) + scm_misc_error ("guard", + "object is already greedily guarded: ~A", + SCM_LIST1 (obj)); + else + return SCM_BOOL_F; } else scm_hashq_create_handle_x (greedily_guarded_whash, obj, guardian); } - TCONC_IN (GUARDIAN_LIVE (guardian), obj, z); + TCONC_IN (g->live, obj, z); SCM_ALLOW_INTS; } + return throw_p ? SCM_UNSPECIFIED : SCM_BOOL_T; + } SCM scm_get_one_zombie (SCM guardian) { + guardian_t *g = GUARDIAN (guardian); SCM res = SCM_BOOL_F; /* This critical section barrier will be replaced by a mutex. */ SCM_DEFER_INTS; - if (!TCONC_EMPTYP (GUARDIAN_ZOMBIES (guardian))) - TCONC_OUT (GUARDIAN_ZOMBIES (guardian), res); + if (!TCONC_EMPTYP (g->zombies)) + TCONC_OUT (g->zombies, res); if (SCM_NFALSEP (res) - && GUARDIAN_GREEDY_P (guardian) - && SCM_NFALSEP (scm_hashq_get_handle - (greedily_guarded_whash, res))) + && GREEDY_P (g)) scm_hashq_remove_x (greedily_guarded_whash, res); SCM_ALLOW_INTS; @@ -284,9 +323,9 @@ SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 1, 0, "the guardian.\n\n" "make-guardian takes one optional argument that says whether the\n" - "new guardian should be greedy or not. if there is any chance\n" + "new guardian should be greedy or sharing. if there is any chance\n" "that any object protected by the guardian may be resurrected,\n" - "then make the guardian greedy (this is the default).\n\n" + "then you should make the guardian greedy (this is the default).\n\n" "See R. Kent Dybvig, Carl Bruggeman, and David Eby (1993)\n" "\"Guardians in a Generation-Based Garbage Collector\".\n" @@ -305,13 +344,14 @@ SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 1, 0, /* A tconc starts out with one tail pair. */ g->live.head = g->live.tail = z1; g->zombies.head = g->zombies.tail = z2; - g->listed_p = 0; - if (SCM_UNBNDP (greedy_p)) - g->greedy_p = 1; - else - g->greedy_p = SCM_NFALSEP (greedy_p); + g->next = NULL; + g->flags = 0L; + /* [cmm] the UNBNDP check below is redundant but I like it. */ + if (SCM_UNBNDP (greedy_p) || SCM_NFALSEP (greedy_p)) + SET_GREEDY (g); + SCM_NEWSMOB (z, tc16_guardian, g); return z; @@ -319,6 +359,73 @@ SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 1, 0, #undef FUNC_NAME +SCM_DEFINE (scm_guardian_destroyed_p, "guardian-destroyed?", 1, 0, 0, + (SCM guardian), + "Is @var{guardian} destroyed?") +#define FUNC_NAME s_scm_guardian_destroyed_p +{ + SCM res = SCM_BOOL_F; + + /* This critical section barrier will be replaced by a mutex. */ + SCM_DEFER_INTS; + + res = SCM_BOOL (DESTROYED_P (GUARDIAN (guardian))); + + SCM_ALLOW_INTS; + + return res; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_guardian_greedy_p, "guardian_greedy?", 1, 0, 0, + (SCM guardian), + "Is @var{guardian} greedy?") +#define FUNC_NAME s_scm_guardian_greedy_p +{ + return SCM_BOOL (GREEDY_P (GUARDIAN (guardian))); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_destroy_guardian_x, "destroy-guardian!", 1, 0, 0, + (SCM guardian), + "Destroys @var{guardian}, by making it impossible to put any more\n" + "objects in it or get any objects from it. It also unguards any\n" + "objects guarded by @var{guardian}.") +#define FUNC_NAME s_scm_destroy_guardian_x +{ + guardian_t *g = GUARDIAN (guardian); + + /* This critical section barrier will be replaced by a mutex. */ + SCM_DEFER_INTS; + + if (DESTROYED_P (g)) + { + SCM_ALLOW_INTS; + SCM_MISC_ERROR ("guardian is already destroyed: ~A", SCM_LIST1 (guardian)); + } + + if (GREEDY_P (g)) + { + /* clear the "greedily guarded" property of the objects */ + SCM pair; + for (pair = g->live.head; pair != g->live.tail; pair = SCM_CDR (pair)) + scm_hashq_remove_x (greedily_guarded_whash, SCM_CAR (pair)); + for (pair = g->zombies.head; pair != g->zombies.tail; pair = SCM_CDR (pair)) + scm_hashq_remove_x (greedily_guarded_whash, SCM_CAR (pair)); + } + + /* empty the lists */ + g->live.head = g->live.tail; + g->zombies.head = g->zombies.tail; + + SET_DESTROYED (g); + + SCM_ALLOW_INTS; + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + /* called before gc mark phase begins to initialise the live guardian list. */ static void * guardian_gc_init (void *dummy1, void *dummy2, void *dummy3) @@ -364,7 +471,7 @@ mark_dependencies_in_tconc (tconc_t *tc) /* see if this is a guardian. if yes, list it (but don't mark it yet). */ if (GUARDIAN_P (obj)) - add_to_live_list (obj); + add_to_live_list (GUARDIAN (obj)); prev_ptr = SCM_CDRLOC (pair); } @@ -397,7 +504,7 @@ mark_and_zombify (guardian_t *g) /* out of the live list! */ *prev_ptr = next_pair; - if (g->greedy_p) + if (GREEDY_P (g)) /* if the guardian is greedy, mark this zombie now. this way it won't be zombified again this time around. */ SCM_SETGCMARK (SCM_CAR (pair)); @@ -462,12 +569,12 @@ guardian_zombify (void *dummy1, void *dummy2, void *dummy3) for (g = greedy_guardians; g; g = g->next) { mark_and_zombify (g); - g->listed_p = 0; + CLR_LISTED (g); } for (g = sharing_guardians; g; g = g->next) { mark_and_zombify (g); - g->listed_p = 0; + CLR_LISTED (g); } /* Preserve the zombies in their undead state, by marking to prevent @@ -510,7 +617,7 @@ scm_init_guardians () scm_set_smob_mark (tc16_guardian, guardian_mark); scm_set_smob_free (tc16_guardian, guardian_free); scm_set_smob_print (tc16_guardian, guardian_print); - scm_set_smob_apply (tc16_guardian, guardian_apply, 0, 1, 0); + scm_set_smob_apply (tc16_guardian, guardian_apply, 0, 2, 0); scm_c_hook_add (&scm_before_mark_c_hook, guardian_gc_init, 0, 0); scm_c_hook_add (&scm_before_sweep_c_hook, guardian_zombify, 0, 0); diff --git a/libguile/guardians.h b/libguile/guardians.h index e6fadea9a..eb79c1305 100644 --- a/libguile/guardians.h +++ b/libguile/guardians.h @@ -47,9 +47,13 @@ #include "libguile/__scm.h" SCM scm_make_guardian (SCM greedy_p); +SCM scm_destroy_guardian_x (SCM guardian); + +SCM scm_guardian_greedy_p (SCM guardian); +SCM scm_guardian_destroyed_p (SCM guardian); /* these are to be called from C: */ -void scm_guard (SCM guardian, SCM obj); +SCM scm_guard (SCM guardian, SCM obj, int throw_p); SCM scm_get_one_zombie (SCM guardian); void scm_init_guardians (void); From b7d69200c08ec424a9f3138e90370f27ee8e0d4b Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 5 Jan 2001 09:29:12 +0000 Subject: [PATCH 0455/2047] * Fix typos in entry about guardian semantic changes. --- NEWS | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index 3ce9a76bb..49b1b80fe 100644 --- a/NEWS +++ b/NEWS @@ -87,9 +87,9 @@ Example: * Changes to Scheme functions and syntax -** The semantics of guardians has changed. +** The semantics of guardians have changed. -The changes are for the most part compatible. An important criteria +The changes are for the most part compatible. An important criterion was to keep the typical usage of guardians as simple as before, but to make the semantics safer and (as a result) more useful. From e8a46ba8c316fe69d2616d9a24bfdc31eecf701c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 6 Jan 2001 18:46:48 +0000 Subject: [PATCH 0456/2047] * validate.h (SCM_VALIDATE_NUMBER): New. --- libguile/validate.h | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/libguile/validate.h b/libguile/validate.h index cf9e603bc..d15460aa5 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -1,4 +1,4 @@ -/* $Id: validate.h,v 1.22 2000-12-16 20:25:08 kei Exp $ */ +/* $Id: validate.h,v 1.23 2001-01-06 18:46:48 mvo Exp $ */ /* Copyright (C) 1999, 2000 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify @@ -137,6 +137,8 @@ #define SCM_VALIDATE_REAL(pos, z) SCM_MAKE_VALIDATE (pos, z, REALP) +#define SCM_VALIDATE_NUMBER(pos, z) SCM_MAKE_VALIDATE (pos, z, NUMBERP) + #define SCM_VALIDATE_NUMBER_COPY(pos, z, cvar) \ do { \ if (SCM_INUMP (z)) \ From 4651d663fa7fabc7326efe0696244f751fc17598 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 6 Jan 2001 18:47:12 +0000 Subject: [PATCH 0457/2047] *** empty log message *** --- libguile/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 93c3ec4a5..565b97f45 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2001-01-06 Marius Vollmer + + * validate.h (SCM_VALIDATE_NUMBER): New. + 2001-01-03 Michael Livshin * guardians.c (F_GREEDY, F_LISTED, F_DESTROYED, GREEDY_P, From c2da26487a71b44786e279588e37a71a9f036ada Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sat, 6 Jan 2001 22:03:07 +0000 Subject: [PATCH 0458/2047] * ioext.c (scm_read_string_x_partial): new procedure, implements read-string!/partial. * ports.c (scm_take_from_input_buffers): new procedure used by scm_read_string_x_partial. (scm_drain_input): use scm_take_from_input_buffers. --- libguile/ChangeLog | 8 ++++ libguile/fports.c | 5 +-- libguile/ioext.c | 104 +++++++++++++++++++++++++++++++++++++++++++++ libguile/ioext.h | 5 ++- libguile/ports.c | 43 ++++++++++++++----- libguile/ports.h | 1 + 6 files changed, 151 insertions(+), 15 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 565b97f45..9d1101522 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2001-01-06 Gary Houston + + * ioext.c (scm_read_string_x_partial): new procedure, implements + read-string!/partial. + * ports.c (scm_take_from_input_buffers): new procedure used by + scm_read_string_x_partial. + (scm_drain_input): use scm_take_from_input_buffers. + 2001-01-06 Marius Vollmer * validate.h (SCM_VALIDATE_NUMBER): New. diff --git a/libguile/fports.c b/libguile/fports.c index 9d0f96d51..093a4ee45 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -486,9 +486,8 @@ fport_wait_for_input (SCM port) static void fport_flush (SCM port); -/* fill a port's read-buffer with a single read. - returns the first char and moves the read_pos pointer past it. - or returns EOF if end of file. */ +/* fill a port's read-buffer with a single read. returns the first + char or EOF if end of file. */ static int fport_fill_input (SCM port) { diff --git a/libguile/ioext.c b/libguile/ioext.c index b88dfa21b..ee0e9c631 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -69,6 +69,110 @@ #endif +SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0, + (SCM str, SCM port_or_fdes, SCM start, SCM end), + "Read characters from an fport or file descriptor into a\n" + "string @var{str}. This procedure is scsh-compatible\n" + "and can efficiently read large strings. It will:\n\n" + "@itemize\n" + "@item\n" + "attempt to fill the entire string, unless the @var{start}\n" + "and/or @var{end} arguments are supplied. i.e., @var{start}\n" + "defaults to 0 and @var{end} defaults to\n" + "@code{(string-length str)}\n" + "@item\n" + "use the current input port if @var{port_or_fdes} is not\n" + "supplied.\n" + "@item\n" + "read any characters that are currently available,\n" + "without waiting for the rest (short reads are possible).\n\n" + "@item\n" + "wait for as long as it needs to for the first character to\n" + "become available, unless the port is in non-blocking mode\n" + "@item\n" + "return @code{#f} if end-of-file is encountered before reading\n" + "any characters, otherwise return the number of characters\n" + "read.\n" + "@item\n" + "return 0 if the port is in non-blocking mode and no characters\n" + "are immediately available.\n" + "@item\n" + "return 0 if the request is for 0 bytes, with no\n" + "end-of-file check\n" + "@end itemize") +#define FUNC_NAME s_scm_read_string_x_partial +{ + char *dest; + long read_len; + long chars_read = 0; + int fdes = -1; + SCM port = SCM_BOOL_F; + + SCM_VALIDATE_STRING_COPY (1, str, dest); + if (SCM_UNBNDP (port_or_fdes)) + port = scm_cur_inp; + else if (SCM_INUMP (port_or_fdes)) + fdes = SCM_INUM (port_or_fdes); + else + { + SCM_VALIDATE_OPFPORT (2, port_or_fdes); + SCM_VALIDATE_INPUT_PORT (2, port_or_fdes); + port = port_or_fdes; + } + + { + long string_len = SCM_STRING_LENGTH (str); + long offset = SCM_NUM2LONG_DEF (3, start, 0); + long last = SCM_NUM2LONG_DEF (4, end, string_len); + + if (offset < 0 || offset > string_len) + SCM_OUT_OF_RANGE (3, start); + if (last < offset || last > string_len) + SCM_OUT_OF_RANGE (4, end); + + dest += offset; + read_len = last - offset; + } + + if (fdes == -1) + { + /* if there's anything in the port buffers, use it. but if + something is read from the buffers, don't touch the file + descriptor. otherwise the "return immediately if something + is available" rule may be violated. */ + chars_read = scm_take_from_input_buffers (port, dest, read_len); + + } + + if (chars_read == 0 && read_len > 0) /* don't confuse read_len == 0 with + EOF. */ + { + if (fdes == -1) + fdes = SCM_FPORT_FDES (port); + + SCM_SYSCALL (chars_read = read (fdes, dest, read_len)); + if (chars_read == -1) + { +#if defined (EWOULDBLOCK) || defined (EAGAIN) + if ( +#if defined (EWOULDBLOCK) + errno == EWOULDBLOCK +#else + errno == EAGAIN +#endif + ) + chars_read = 0; + else +#endif + SCM_SYSERROR; + } + else if (chars_read == 0) + return SCM_BOOL_F; + } + return scm_long2num (chars_read); +} +#undef FUNC_NAME + SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0, (SCM delims, SCM buf, SCM gobble, SCM port, SCM start, SCM end), "Read characters from @var{port} into @var{buf} until one of the\n" diff --git a/libguile/ioext.h b/libguile/ioext.h index a79b1a5b5..579da70e6 100644 --- a/libguile/ioext.h +++ b/libguile/ioext.h @@ -48,7 +48,10 @@ -extern SCM scm_read_delimited_x (SCM delims, SCM buf, SCM gobble, SCM port, SCM offset, SCM length); +extern SCM scm_read_string_x_partial (SCM str, SCM port_or_fdes, SCM start, + SCM end); +extern SCM scm_read_delimited_x (SCM delims, SCM buf, SCM gobble, SCM port, + SCM offset, SCM length); extern SCM scm_read_line (SCM port); extern SCM scm_write_line (SCM obj, SCM port); extern SCM scm_ftell (SCM object); diff --git a/libguile/ports.c b/libguile/ports.c index 4e703cbdd..f955b0302 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -272,6 +272,37 @@ SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0, } #undef FUNC_NAME +/* move up to read_len chars from port's putback and/or read buffers + into memory starting at dest. returns the number of chars moved. */ +size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len) +{ + scm_port *pt = SCM_PTAB_ENTRY (port); + size_t chars_read = 0; + size_t from_buf = min (pt->read_end - pt->read_pos, read_len); + + if (from_buf > 0) + { + memcpy (dest, pt->read_pos, from_buf); + pt->read_pos += from_buf; + chars_read += from_buf; + read_len -= from_buf; + dest += from_buf; + } + + /* if putback was active, try the real input buffer too. */ + if (pt->read_buf == pt->putback_buf) + { + from_buf = min (pt->saved_read_end - pt->saved_read_pos, read_len); + if (from_buf > 0) + { + memcpy (dest, pt->saved_read_pos, from_buf); + pt->saved_read_pos += from_buf; + chars_read += from_buf; + } + } + return chars_read; +} + /* Clear a port's read buffers, returning the contents. */ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, (SCM port), @@ -282,7 +313,6 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, SCM result; scm_port *pt = SCM_PTAB_ENTRY (port); int count; - char *dst; SCM_VALIDATE_OPINPORT (1,port); @@ -291,16 +321,7 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, count += pt->saved_read_end - pt->saved_read_pos; result = scm_makstr (count, 0); - dst = SCM_STRING_CHARS (result); - - while (pt->read_pos < pt->read_end) - *dst++ = *(pt->read_pos++); - - if (pt->read_buf == pt->putback_buf) - { - while (pt->saved_read_pos < pt->saved_read_end) - *dst++ = *(pt->saved_read_pos++); - } + scm_take_from_input_buffers (port, SCM_STRING_CHARS (result), count); return result; } diff --git a/libguile/ports.h b/libguile/ports.h index 9315c9d9f..9676bde18 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -244,6 +244,7 @@ extern void scm_set_port_truncate (long tc, off_t length)); extern void scm_set_port_input_waiting (long tc, int (*input_waiting) (SCM)); extern SCM scm_char_ready_p (SCM port); +size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len); extern SCM scm_drain_input (SCM port); extern SCM scm_current_input_port (void); extern SCM scm_current_output_port (void); From 264e9cbc9317f94fe29a89fad6f2b5d617f0be27 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sat, 6 Jan 2001 22:04:04 +0000 Subject: [PATCH 0459/2047] *** empty log message *** --- NEWS | 29 ++++++++++++++++++++++++++++- 1 file changed, 28 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index 49b1b80fe..bc449f706 100644 --- a/NEWS +++ b/NEWS @@ -217,6 +217,33 @@ Guile. Instead, use scm_c_memq or scm_memq, scm_memv, scm_member. +** New function: read-string!/partial str [port_or_fdes [start [end]]] + + Read characters from an fport or file descriptor into a string + STR. This procedure is scsh-compatible and can efficiently read + large strings. It will: + + * attempt to fill the entire string, unless the START and/or + END arguments are supplied. i.e., START defaults to 0 and + END defaults to `(string-length str)' + + * use the current input port if PORT_OR_FDES is not supplied. + + * read any characters that are currently available, without + waiting for the rest (short reads are possible). + + * wait for as long as it needs to for the first character to + become available, unless the port is in non-blocking mode + + * return `#f' if end-of-file is encountered before reading any + characters, otherwise return the number of characters read. + + * return 0 if the port is in non-blocking mode and no characters + are immediately available. + + * return 0 if the request is for 0 bytes, with no end-of-file + check + ** New function: port? X Returns a boolean indicating whether X is a port. Equivalent to @@ -233,7 +260,7 @@ A simple wrapper for the `dup2' system call. Copies the file descriptor OLDFD to descriptor number NEWFD, replacing the previous meaning of NEWFD. Both OLDFD and NEWFD must be integers. Unlike for dup->fdes or primitive-move->fdes, no attempt is made -to move away ports which are using NEWFD\n". The return value is +to move away ports which are using NEWFD. The return value is unspecified. ** New function: close-fdes fd From 60d02d0914b57ba7e1ecd78a9ec27387cfd98b57 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Mon, 8 Jan 2001 23:10:06 +0000 Subject: [PATCH 0460/2047] * validate.h (SCM_VALIDATE_SUBSTRING_SPEC_COPY): new macro. * ioext.c (scm_read_string_x_partial, scm_read_delimited_x), socket.c (scm_recvfrom): use the new macro, plus minor docstring changes. * ioext.c (scm_read_string_x_partial): don't crash if -1 is supplied for fdes. if current input port is used, check that it's a file port. --- libguile/ChangeLog | 10 ++++++ libguile/ioext.c | 84 +++++++++++++++++---------------------------- libguile/socket.c | 43 ++++++----------------- libguile/validate.h | 18 +++++++++- 4 files changed, 70 insertions(+), 85 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 9d1101522..ac082ca0f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,13 @@ +2001-01-08 Gary Houston + + * validate.h (SCM_VALIDATE_SUBSTRING_SPEC_COPY): new macro. + * ioext.c (scm_read_string_x_partial, scm_read_delimited_x), + socket.c (scm_recvfrom): use the new macro, plus minor docstring + changes. + * ioext.c (scm_read_string_x_partial): don't crash if -1 is supplied + for fdes. if current input port is used, check that it's a file + port. + 2001-01-06 Gary Houston * ioext.c (scm_read_string_x_partial): new procedure, implements diff --git a/libguile/ioext.c b/libguile/ioext.c index ee0e9c631..bf757c1ee 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -105,51 +105,38 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0, char *dest; long read_len; long chars_read = 0; - int fdes = -1; - SCM port = SCM_BOOL_F; - - SCM_VALIDATE_STRING_COPY (1, str, dest); - if (SCM_UNBNDP (port_or_fdes)) - port = scm_cur_inp; - else if (SCM_INUMP (port_or_fdes)) - fdes = SCM_INUM (port_or_fdes); - else - { - SCM_VALIDATE_OPFPORT (2, port_or_fdes); - SCM_VALIDATE_INPUT_PORT (2, port_or_fdes); - port = port_or_fdes; - } + int fdes; { - long string_len = SCM_STRING_LENGTH (str); - long offset = SCM_NUM2LONG_DEF (3, start, 0); - long last = SCM_NUM2LONG_DEF (4, end, string_len); - - if (offset < 0 || offset > string_len) - SCM_OUT_OF_RANGE (3, start); - if (last < offset || last > string_len) - SCM_OUT_OF_RANGE (4, end); + long offset; + long last; + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, dest, 3, start, offset, + 4, end, last); dest += offset; read_len = last - offset; } - if (fdes == -1) + if (SCM_INUMP (port_or_fdes)) + fdes = SCM_INUM (port_or_fdes); + else { - /* if there's anything in the port buffers, use it. but if - something is read from the buffers, don't touch the file - descriptor. otherwise the "return immediately if something - is available" rule may be violated. */ - chars_read = scm_take_from_input_buffers (port, dest, read_len); + SCM port = SCM_UNBNDP (port_or_fdes) ? scm_cur_inp : port_or_fdes; + SCM_VALIDATE_OPFPORT (2, port); + SCM_VALIDATE_INPUT_PORT (2, port); + + /* if there's anything in the port buffers, use it, but then + don't touch the file descriptor. otherwise the + "return immediately if something is available" rule may + be violated. */ + chars_read = scm_take_from_input_buffers (port, dest, read_len); + fdes = SCM_FPORT_FDES (port); } if (chars_read == 0 && read_len > 0) /* don't confuse read_len == 0 with EOF. */ { - if (fdes == -1) - fdes = SCM_FPORT_FDES (port); - SCM_SYSCALL (chars_read = read (fdes, dest, read_len)); if (chars_read == -1) { @@ -174,46 +161,39 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0, #undef FUNC_NAME SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0, - (SCM delims, SCM buf, SCM gobble, SCM port, SCM start, SCM end), - "Read characters from @var{port} into @var{buf} until one of the\n" - "characters in the @var{delims} string is encountered. If @var{gobble?}\n" - "is true, store the delimiter character in @var{buf} as well; otherwise,\n" - "discard it. If @var{port} is not specified, use the value of\n" + (SCM delims, SCM str, SCM gobble, SCM port, SCM start, SCM end), + "Read characters from @var{port} into @var{str} until one of the\n" + "characters in the @var{delims} string is encountered. If @var{gobble}\n" + "is true, discard the delimiter character; otherwise, leave it\n" + "in the input stream for the next read.\n" + "If @var{port} is not specified, use the value of\n" "@code{(current-input-port)}. If @var{start} or @var{end} are specified,\n" - "store data only into the substring of @var{buf} bounded by @var{start}\n" - "and @var{end} (which default to the beginning and end of the buffer,\n" + "store data only into the substring of @var{str} bounded by @var{start}\n" + "and @var{end} (which default to the beginning and end of the string,\n" "respectively).\n\n" "Return a pair consisting of the delimiter that terminated the string and\n" "the number of characters read. If reading stopped at the end of file,\n" - "the delimiter returned is the @var{eof-object}; if the buffer was filled\n" + "the delimiter returned is the @var{eof-object}; if the string was filled\n" "without encountering a delimiter, this value is @var{#f}.") #define FUNC_NAME s_scm_read_delimited_x { long j; - char *cbuf; + char *buf; long cstart; - long cend, tend; + long cend; int c; char *cdelims; int num_delims; SCM_VALIDATE_STRING_COPY (1, delims, cdelims); num_delims = SCM_STRING_LENGTH (delims); - SCM_VALIDATE_STRING_COPY (2,buf,cbuf); - cend = SCM_STRING_LENGTH (buf); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, str, buf, 5, start, cstart, + 6, end, cend); if (SCM_UNBNDP (port)) port = scm_cur_inp; else SCM_VALIDATE_OPINPORT (4,port); - SCM_VALIDATE_INUM_DEF_COPY (5,start,0,cstart); - SCM_ASSERT_RANGE(5, start, cstart >= 0 && cstart < cend); - - SCM_VALIDATE_INUM_DEF_COPY (6,end,cend,tend); - SCM_ASSERT_RANGE(6, end, tend > cstart && tend <= cend); - - cend = tend; - for (j = cstart; j < cend; j++) { int k; @@ -234,7 +214,7 @@ SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0, return scm_cons (SCM_EOF_VAL, scm_long2num (j - cstart)); - cbuf[j] = c; + buf[j] = c; } return scm_cons (SCM_BOOL_F, scm_long2num (j - cstart)); } diff --git a/libguile/socket.c b/libguile/socket.c index 23f44851d..fc306a321 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -746,12 +746,12 @@ SCM_DEFINE (scm_send, "send", 2, 1, 0, #undef FUNC_NAME SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0, - (SCM sock, SCM buf, SCM flags, SCM start, SCM end), + (SCM sock, SCM str, SCM flags, SCM start, SCM end), "Returns data from the socket port @var{socket} and also information about\n" "where the data was received from. @var{socket} must already\n" "be bound to the address from which data is to be received.\n" - "@code{buf}, is a string into which\n" - "the data will be written. The size of @var{buf} limits the amount of\n" + "@code{str}, is a string into which\n" + "the data will be written. The size of @var{str} limits the amount of\n" "data which can be received: in the case of packet\n" "protocols, if a packet larger than this limit is encountered then some data\n" "will be irrevocably lost.\n\n" @@ -760,7 +760,7 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0, "The value returned is a pair: the CAR is the number of bytes read from\n" "the socket and the CDR an address object in the same form as returned by\n" "@code{accept}.\n\n" - "The @var{start} and @var{end} arguments specify a substring of @var{buf}\n" + "The @var{start} and @var{end} arguments specify a substring of @var{str}\n" "to which the data should be written.\n\n" "Note that the data is read directly from the socket file descriptor:\n" "any unread buffered port data is ignored.") @@ -769,44 +769,23 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0, int rv; int fd; int flg; - int offset = 0; + char *buf; + int offset; int cend; size_t tmp_size; SCM address; SCM_VALIDATE_OPFPORT (1,sock); - SCM_VALIDATE_STRING (2,buf); - cend = SCM_STRING_LENGTH (buf); - + fd = SCM_FPORT_FDES (sock); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, str, buf, 4, start, offset, + 5, end, cend); if (SCM_UNBNDP (flags)) flg = 0; else - { - flg = SCM_NUM2ULONG (3,flags); - - if (!SCM_UNBNDP (start)) - { - offset = (int) SCM_NUM2LONG (4,start); - - if (offset < 0 || offset >= cend) - SCM_OUT_OF_RANGE (4, start); - - if (!SCM_UNBNDP (end)) - { - int tend = (int) SCM_NUM2LONG (5,end); - - if (tend <= offset || tend > cend) - SCM_OUT_OF_RANGE (5, end); - - cend = tend; - } - } - } - - fd = SCM_FPORT_FDES (sock); + SCM_VALIDATE_ULONG_COPY (3, flags, flg); tmp_size = scm_addr_buffer_size; - SCM_SYSCALL (rv = recvfrom (fd, SCM_STRING_CHARS (buf) + offset, + SCM_SYSCALL (rv = recvfrom (fd, buf + offset, cend - offset, flg, (struct sockaddr *) scm_addr_buffer, &tmp_size)); diff --git a/libguile/validate.h b/libguile/validate.h index d15460aa5..d44d36c5a 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -1,4 +1,4 @@ -/* $Id: validate.h,v 1.23 2001-01-06 18:46:48 mvo Exp $ */ +/* $Id: validate.h,v 1.24 2001-01-08 23:10:06 ghouston Exp $ */ /* Copyright (C) 1999, 2000 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify @@ -135,6 +135,22 @@ cvar = SCM_STRING_CHARS(str); \ } while (0) +/* validate a string and optional start/end arguments which default to + 0/string-len. this is unrelated to the old shared substring + support, so please do not deprecate it :) */ +#define SCM_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, c_str, \ + pos_start, start, c_start,\ + pos_end, end, c_end) \ + do {\ + SCM_VALIDATE_STRING_COPY (pos_str, str, c_str);\ + SCM_VALIDATE_INUM_DEF_COPY (pos_start, start, 0, c_start);\ + SCM_VALIDATE_INUM_DEF_COPY (pos_end, end, SCM_STRING_LENGTH (str), c_end);\ + SCM_ASSERT_RANGE (pos_start, start,\ + 0 <= c_start && c_start <= SCM_STRING_LENGTH (str));\ + SCM_ASSERT_RANGE (pos_end, end,\ + c_start <= c_end && c_end <= SCM_STRING_LENGTH (str));\ + } while (0) + #define SCM_VALIDATE_REAL(pos, z) SCM_MAKE_VALIDATE (pos, z, REALP) #define SCM_VALIDATE_NUMBER(pos, z) SCM_MAKE_VALIDATE (pos, z, NUMBERP) From 322ec19d3cede3e4d74c209e8155b4faba21f5f5 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Thu, 11 Jan 2001 21:03:18 +0000 Subject: [PATCH 0461/2047] * objects.h (SCM_SET_ENTITY_SETTER): new macro. SCM_ENTITY_SETTER casts its result, so doesn't yield an lvalue per ANSI C. * goops.c (s_scm_sys_set_object_setter_x): use SCM_SET_ENTITY_SETTER. (clear_method_cache): use SCM_SET_ENTITY_PROCEDURE. * gc.h (SCM_GC_SET_CARD_BVEC): new macro. SCM_GC_CARD_BVEC casts its result, so doesn't yield an lvalue per ANSI C. (SCM_GC_SET_CARD_FLAGS): ditto for SCM_GC_GET_CARD_FLAGS. (SCM_GC_CLR_CARD_FLAGS): redefined in terms of SCM_GC_SET_CARD_FLAGS. (SCM_GC_SET_CARD_FLAG, SCM_GC_CLR_CARD_FLAGS): ditto. * gc.c (INIT_CARD): use the explicit setter macro to set the bvec. --- libguile/ChangeLog | 20 ++++++++++++++++++++ libguile/gc.c | 2 +- libguile/gc.h | 13 +++++++++---- libguile/goops.c | 5 +++-- libguile/objects.h | 2 ++ 5 files changed, 35 insertions(+), 7 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index ac082ca0f..8c286e6d9 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,23 @@ +2001-01-11 Michael Livshin + + from Matthias Köppe: + + * objects.h (SCM_SET_ENTITY_SETTER): new macro. SCM_ENTITY_SETTER + casts its result, so doesn't yield an lvalue per ANSI C. + + * goops.c (s_scm_sys_set_object_setter_x): use + SCM_SET_ENTITY_SETTER. + (clear_method_cache): use SCM_SET_ENTITY_PROCEDURE. + + * gc.h (SCM_GC_SET_CARD_BVEC): new macro. SCM_GC_CARD_BVEC casts + its result, so doesn't yield an lvalue per ANSI C. + (SCM_GC_SET_CARD_FLAGS): ditto for SCM_GC_GET_CARD_FLAGS. + (SCM_GC_CLR_CARD_FLAGS): redefined in terms of + SCM_GC_SET_CARD_FLAGS. + (SCM_GC_SET_CARD_FLAG, SCM_GC_CLR_CARD_FLAGS): ditto. + + * gc.c (INIT_CARD): use the explicit setter macro to set the bvec. + 2001-01-08 Gary Houston * validate.h (SCM_VALIDATE_SUBSTRING_SPEC_COPY): new macro. diff --git a/libguile/gc.c b/libguile/gc.c index d6767651d..5d4aa0063 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -2026,7 +2026,7 @@ int scm_n_heap_segs = 0; #define INIT_CARD(card, span) \ do { \ - SCM_GC_CARD_BVEC (card) = get_bvec (); \ + SCM_GC_SET_CARD_BVEC (card, get_bvec ()); \ if ((span) == 2) \ SCM_GC_SET_CARD_DOUBLECELL (card); \ } while (0) diff --git a/libguile/gc.h b/libguile/gc.h index 893c262e7..18852624a 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -94,14 +94,19 @@ typedef scm_cell * SCM_CELLPTR; SCM_PTR_LT ((scm_cell *) (x), SCM_GC_CELL_CARD (x) + SCM_GC_CARD_N_HEADER_CELLS) #define SCM_GC_CARD_BVEC(card) ((scm_c_bvec_limb_t *) ((card)->word_0)) +#define SCM_GC_SET_CARD_BVEC(card, bvec) \ + ((card)->word_0 = (scm_bits_t) (bvec)) #define SCM_GC_GET_CARD_FLAGS(card) ((long) ((card)->word_1)) -#define SCM_GC_SET_CARD_FLAGS(card, flags) (SCM_GC_GET_CARD_FLAGS (card) = (flags)) -#define SCM_GC_CLR_CARD_FLAGS(card) (SCM_GC_GET_CARD_FLAGS (card) = 0L) +#define SCM_GC_SET_CARD_FLAGS(card, flags) \ + ((card)->word_1 = (scm_bits_t) (flags)) +#define SCM_GC_CLR_CARD_FLAGS(card) (SCM_GC_SET_CARD_FLAGS (card, 0L)) #define SCM_GC_GET_CARD_FLAG(card, shift) (SCM_GC_GET_CARD_FLAGS (card) & (1L << (shift))) -#define SCM_GC_SET_CARD_FLAG(card, shift) (SCM_GC_GET_CARD_FLAGS (card) |= (1L << (shift))) -#define SCM_GC_CLR_CARD_FLAG(card, shift) (SCM_GC_GET_CARD_FLAGS (card) &= ~(1L << (shift))) +#define SCM_GC_SET_CARD_FLAG(card, shift) \ + (SCM_GC_SET_CARD_FLAGS (card, SCM_GC_GET_CARD_FLAGS(card) | (1L << (shift)))) +#define SCM_GC_CLR_CARD_FLAG(card, shift) \ + (SCM_GC_SET_CARD_FLAGS (card, SCM_GC_GET_CARD_FLAGS(card) & ~(1L << (shift)))) #define SCM_GC_CARDF_DOUBLECELL 0 diff --git a/libguile/goops.c b/libguile/goops.c index 0c4ffa6e9..4d7ce1484 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1366,7 +1366,7 @@ SCM_DEFINE (scm_sys_set_object_setter_x, "%set-object-setter!", 2, 0, 0, SCM_ARG1, FUNC_NAME); if (SCM_I_ENTITYP (obj)) - SCM_ENTITY_SETTER (obj) = setter; + SCM_SET_ENTITY_SETTER (obj, setter); else SCM_OPERATOR_CLASS (obj)->setter = setter; return SCM_UNSPECIFIED; @@ -1545,7 +1545,8 @@ scm_make_method_cache (SCM gf) static void clear_method_cache (SCM gf) { - SCM_ENTITY_PROCEDURE (gf) = scm_make_method_cache (gf); + SCM cache = scm_make_method_cache (gf); + SCM_SET_ENTITY_PROCEDURE (gf, cache); SCM_SLOT (gf, scm_si_used_by) = SCM_BOOL_F; } diff --git a/libguile/objects.h b/libguile/objects.h index aa5836e9f..110158a8e 100644 --- a/libguile/objects.h +++ b/libguile/objects.h @@ -94,6 +94,8 @@ #define SCM_SET_ENTITY_PROCEDURE(obj,v) \ (SCM_STRUCT_DATA (obj) [scm_struct_i_procedure] = SCM_UNPACK (v)) #define SCM_ENTITY_SETTER(obj) (SCM_PACK (SCM_STRUCT_DATA (obj)[scm_struct_i_setter])) +#define SCM_SET_ENTITY_SETTER(obj, v) \ + (SCM_STRUCT_DATA (obj) [scm_struct_i_setter] = SCM_UNPACK (v)) #define SCM_SET_CLASS_DESTRUCTOR(c, d) SCM_SET_VTABLE_DESTRUCTOR (c, d) #define SCM_SET_CLASS_INSTANCE_SIZE(c, s) \ From 8a39e3fc79cfe382e5f5844fbd5750eb4ea05e28 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 15 Jan 2001 17:15:13 +0000 Subject: [PATCH 0462/2047] * Return type of scm_make_smob_type is scm_bits_t now. --- THANKS | 1 + libguile/ChangeLog | 5 +++++ libguile/smob.c | 2 +- libguile/smob.h | 2 +- 4 files changed, 8 insertions(+), 2 deletions(-) diff --git a/THANKS b/THANKS index 62c8b1030..4f32c7f24 100644 --- a/THANKS +++ b/THANKS @@ -25,6 +25,7 @@ For fixes or providing information which led to a fix: Han-Wen Nienhuys David Pirotte Julian Satchell + Bill Schottstaedt Dale P. Smith Jacques A. Vidrine. William Webber diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 8c286e6d9..5b73ff0f0 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-01-15 Dirk Herrmann + + * smob.[ch] (scm_make_smob_type): Return type is scm_bits_t now. + Thanks to Bill Schottstaedt. + 2001-01-11 Michael Livshin from Matthias Köppe: diff --git a/libguile/smob.c b/libguile/smob.c index 9c8463250..a14ca2c94 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -275,7 +275,7 @@ scm_smob_apply_3_error (SCM smob, SCM a1, SCM a2, SCM rst) } -long +scm_bits_t scm_make_smob_type (char *name, scm_sizet size) { char *tmp; diff --git a/libguile/smob.h b/libguile/smob.h index 065001b69..0b67ef950 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -143,7 +143,7 @@ extern int scm_smob_print (SCM exp, SCM port, scm_print_state *pstate); * values using `scm_set_smob_xxx'. */ -extern long scm_make_smob_type (char *name, scm_sizet size); +extern scm_bits_t scm_make_smob_type (char *name, scm_sizet size); extern void scm_set_smob_mark (long tc, SCM (*mark) (SCM)); extern void scm_set_smob_free (long tc, scm_sizet (*free) (SCM)); From debe0dc24ffb36c0e53c6e48caff1ee5d9ad4eb6 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 16 Jan 2001 11:19:36 +0000 Subject: [PATCH 0463/2047] * Comment fixed. --- THANKS | 1 + libguile/ChangeLog | 5 +++++ libguile/symbols.c | 2 +- 3 files changed, 7 insertions(+), 1 deletion(-) diff --git a/THANKS b/THANKS index 4f32c7f24..e5e9cbbb0 100644 --- a/THANKS +++ b/THANKS @@ -15,6 +15,7 @@ For fixes or providing information which led to a fix: Lars J. Aas Ian Bicking George Caswell + Chris Cramer I. N. Golubev Brad Knotwell Matthias Köppe diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 5b73ff0f0..47ee02b89 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-01-16 Dirk Herrmann + + * symbols.c (scm_symbol_bound_p): Fixed comment. + Thanks to Chris Cramer. + 2001-01-15 Dirk Herrmann * smob.[ch] (scm_make_smob_type): Return type is scm_bits_t now. diff --git a/libguile/symbols.c b/libguile/symbols.c index 779369748..a212b3126 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -633,7 +633,7 @@ SCM_DEFINE (scm_symbol_bound_p, "symbol-bound?", 2, 0, 0, (SCM o, SCM s), "Return @var{#t} if @var{obarray} contains a symbol with name\n" "@var{string} bound to a defined value. This differs from\n" - "@var{symbol-bound?} in that the mere mention of a symbol usually causes\n" + "@var{symbol-interned?} in that the mere mention of a symbol usually causes\n" "it to be interned; @code{symbol-bound?} determines whether a symbol has\n" "been given any meaningful value.") #define FUNC_NAME s_scm_symbol_bound_p From ac0c002c62752249db3b3095bf70f3c2d66c229f Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 17 Jan 2001 18:15:30 +0000 Subject: [PATCH 0464/2047] * Fixed a couple of bugs with quotient, remainder, bit-extract and logand. --- THANKS | 1 + libguile/ChangeLog | 17 ++++++++++ libguile/__scm.h | 2 ++ libguile/numbers.c | 84 +++++++++++++++++++++++++++++++++++++--------- 4 files changed, 89 insertions(+), 15 deletions(-) diff --git a/THANKS b/THANKS index e5e9cbbb0..dbabae485 100644 --- a/THANKS +++ b/THANKS @@ -14,6 +14,7 @@ For fixes or providing information which led to a fix: Lars J. Aas Ian Bicking + Rob Browning George Caswell Chris Cramer I. N. Golubev diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 47ee02b89..f8ed2b5a2 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,20 @@ +2001-01-17 Dirk Herrmann + + * __scm.h (SCM_FIXNUM_BIT): Added. The name is chosen in analogy + to the names in limits.h. + + * numbers.c (abs_most_negative_fixnum): Added. + + (scm_quotient, scm_remainder): Fixed the fixnum-min / (abs + fixnum-min) special case. + + (scm_big_and): Fix for negative first parameter. + + (scm_bit_extract): Fix for fixnum paramters. + Thanks to Rob Browning for the bug report. + + (scm_init_numbers): Initialize abs_most_negative_fixnum. + 2001-01-16 Dirk Herrmann * symbols.c (scm_symbol_bound_p): Fixed comment. diff --git a/libguile/__scm.h b/libguile/__scm.h index 2146ca9ac..7723396bc 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -217,6 +217,7 @@ typedef unsigned long long ulong_long; # else # define SCM_CHAR_CODE_LIMIT 256L # endif /* def UCHAR_MAX */ +# define SCM_FIXNUM_BIT (LONG_BIT - 2) # define SCM_MOST_POSITIVE_FIXNUM (LONG_MAX>>2) # ifdef _UNICOS /* Stupid cray bug */ # define SCM_MOST_NEGATIVE_FIXNUM ((long)LONG_MIN/4) @@ -225,6 +226,7 @@ typedef unsigned long long ulong_long; # endif /* UNICOS */ #else # define SCM_CHAR_CODE_LIMIT 256L +# define SCM_FIXNUM_BIT 30 # define SCM_MOST_POSITIVE_FIXNUM ((long)((unsigned long)~0L>>3)) # if (0 != ~0) # define SCM_MOST_NEGATIVE_FIXNUM (-SCM_MOST_POSITIVE_FIXNUM-1) diff --git a/libguile/numbers.c b/libguile/numbers.c index e72d734a4..362a56514 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -96,6 +96,10 @@ static SCM scm_divbigint (SCM x, long z, int sgn, int mode); +static SCM abs_most_negative_fixnum; + + + SCM_DEFINE (scm_exact_p, "exact?", 1, 0, 0, (SCM x), @@ -201,7 +205,14 @@ scm_quotient (SCM x, SCM y) } } } else if (SCM_BIGP (y)) { - return SCM_INUM0; + if (SCM_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM + && scm_bigcomp (abs_most_negative_fixnum, y) == 0) + { + /* Special case: x == fixnum-min && y == abs (fixnum-min) */ + return SCM_MAKINUM (-1); + } + else + return SCM_MAKINUM (0); } else { SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient); } @@ -262,7 +273,14 @@ scm_remainder (SCM x, SCM y) return SCM_MAKINUM (z); } } else if (SCM_BIGP (y)) { - return x; + if (SCM_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM + && scm_bigcomp (abs_most_negative_fixnum, y) == 0) + { + /* Special case: x == fixnum-min && y == abs (fixnum-min) */ + return SCM_MAKINUM (0); + } + else + return x; } else { SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder); } @@ -654,12 +672,14 @@ SCM scm_big_and(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy, int zsgn) if (!num) return scm_normbig(z); } } - else if (xsgn) do { - num += x[i]; - if (num < 0) {zds[i] &= num + SCM_BIGRAD; num = -1;} - else {zds[i] &= ~SCM_BIGLO(num); num = 0;} - } while (++i < nx); - else do zds[i] = zds[i] & x[i]; while (++i < nx); + else if (xsgn) { + unsigned long int carry = 1; + do { + unsigned long int mask = (SCM_BIGDIG) ~x[i] + carry; + zds[i] = zds[i] & (SCM_BIGDIG) mask; + carry = (mask >= SCM_BIGRAD) ? 1 : 0; + } while (++i < nx); + } else do zds[i] = zds[i] & x[i]; while (++i < nx); return scm_normbig(z); } @@ -1181,19 +1201,50 @@ SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0, "@end lisp") #define FUNC_NAME s_scm_bit_extract { - int istart, iend; + unsigned long int istart, iend; SCM_VALIDATE_INUM_MIN_COPY (2,start,0,istart); SCM_VALIDATE_INUM_MIN_COPY (3, end, 0, iend); SCM_ASSERT_RANGE (3, end, (iend >= istart)); if (SCM_INUMP (n)) { - return SCM_MAKINUM ((SCM_INUM (n) >> istart) & ((1L << (iend - istart)) - 1)); + long int in = SCM_INUM (n); + unsigned long int bits = iend - istart; + + if (in < 0 && bits >= SCM_FIXNUM_BIT) + { + /* Since we emulate two's complement encoded numbers, this special + * case requires us to produce a result that has more bits than can be + * stored in a fixnum. Thus, we fall back to the more general + * algorithm that is used for bignums. + */ + goto generalcase; + } + + if (istart < SCM_FIXNUM_BIT) + { + in = in >> istart; + if (bits < SCM_FIXNUM_BIT) + return SCM_MAKINUM (in & ((1L << bits) - 1)); + else /* we know: in >= 0 */ + return SCM_MAKINUM (in); + } + else if (in < 0) + { + return SCM_MAKINUM (-1L & ((1L << bits) - 1)); + } + else + { + return SCM_MAKINUM (0); + } } else if (SCM_BIGP (n)) { - SCM num1 = SCM_MAKINUM (1L); - SCM num2 = SCM_MAKINUM (2L); - SCM bits = SCM_MAKINUM (iend - istart); - SCM mask = scm_difference (scm_integer_expt (num2, bits), num1); - return scm_logand (mask, scm_ash (n, SCM_MAKINUM (-istart))); + generalcase: + { + SCM num1 = SCM_MAKINUM (1L); + SCM num2 = SCM_MAKINUM (2L); + SCM bits = SCM_MAKINUM (iend - istart); + SCM mask = scm_difference (scm_integer_expt (num2, bits), num1); + return scm_logand (mask, scm_ash (n, SCM_MAKINUM (-istart))); + } } else { SCM_WRONG_TYPE_ARG (SCM_ARG1, n); } @@ -4353,6 +4404,9 @@ scm_num2ulong (SCM num, char *pos, const char *s_caller) void scm_init_numbers () { + abs_most_negative_fixnum = scm_long2big (- SCM_MOST_NEGATIVE_FIXNUM); + scm_permanent_object (abs_most_negative_fixnum); + /* It may be possible to tune the performance of some algorithms by using * the following constants to avoid the creation of bignums. Please, before * using these values, remember the two rules of program optimization: From 339bfe47a1d2acee88f84e1ef5653b7b85d1d98a Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 17 Jan 2001 18:22:26 +0000 Subject: [PATCH 0465/2047] * Added tests for bit-operations. --- test-suite/ChangeLog | 4 + test-suite/tests/bit-operations.test | 352 +++++++++++++++++++++++++++ 2 files changed, 356 insertions(+) create mode 100644 test-suite/tests/bit-operations.test diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 71eab5aba..1d2706aca 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2001-01-17 Dirk Herrmann + + * tests/bit-operations.test: Added. + 2000-11-03 Dirk Herrmann * tests/gc.test: Added. diff --git a/test-suite/tests/bit-operations.test b/test-suite/tests/bit-operations.test new file mode 100644 index 000000000..469d63073 --- /dev/null +++ b/test-suite/tests/bit-operations.test @@ -0,0 +1,352 @@ +;;;; bit-operations.test --- bitwise operations on numbers -*- scheme -*- +;;;; Copyright (C) 2000 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. + +(use-modules (ice-9 documentation)) + + +;;; +;;; miscellaneous +;;; + +(define (run-tests name-proc test-proc arg-sets) + (for-each + (lambda (arg-set) + (pass-if (apply name-proc arg-set) + (apply test-proc arg-set))) + arg-sets)) + +(define (documented? object) + (object-documentation object)) + +(define fixnum-bit 30) +(define fixnum-min most-negative-fixnum) +(define fixnum-max most-positive-fixnum) + +(with-test-prefix "bit-extract" + + (pass-if "documented?" + (documented? bit-extract)) + + (with-test-prefix "extract from zero" + + (run-tests + (lambda (a b c d) + (string-append "single bit " (number->string b))) + (lambda (a b c d) + (= (bit-extract a b c) d)) + (list + (list 0 0 1 0) + (list 0 1 2 0) + (list 0 (+ fixnum-bit -2) (+ fixnum-bit -1) 0) + (list 0 (+ fixnum-bit -1) (+ fixnum-bit 0) 0) + (list 0 (+ fixnum-bit 0) (+ fixnum-bit 1) 0) + (list 0 (+ fixnum-bit 1) (+ fixnum-bit 2) 0))) + + (run-tests + (lambda (a b c d) + (string-append "fixnum-bit - 1 bits starting at " (number->string b))) + (lambda (a b c d) + (= (bit-extract a b c) d)) + (list + (list 0 0 (+ fixnum-bit -1) 0) + (list 0 1 (+ fixnum-bit 0) 0) + (list 0 2 (+ fixnum-bit 1) 0) + (list 0 (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -3) 0) + (list 0 (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -2) 0) + (list 0 (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit -1) 0) + (list 0 (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 0) 0))) + + (run-tests + (lambda (a b c d) + (string-append "fixnum-bit bits starting at " (number->string b))) + (lambda (a b c d) + (= (bit-extract a b c) d)) + (list + (list 0 0 (+ fixnum-bit 0) 0) + (list 0 1 (+ fixnum-bit 1) 0) + (list 0 2 (+ fixnum-bit 2) 0) + (list 0 (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -2) 0) + (list 0 (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -1) 0) + (list 0 (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 0) 0) + (list 0 (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 1) 0))) + + (run-tests + (lambda (a b c d) + (string-append "fixnum-bit + 1 bits starting at " (number->string b))) + (lambda (a b c d) + (= (bit-extract a b c) d)) + (list + (list 0 0 (+ fixnum-bit 1) 0) + (list 0 1 (+ fixnum-bit 2) 0) + (list 0 2 (+ fixnum-bit 3) 0) + (list 0 (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -1) 0) + (list 0 (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit 0) 0) + (list 0 (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 1) 0) + (list 0 (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 2) 0)))) + + (with-test-prefix "extract from fixnum-max" + + (run-tests + (lambda (a b c d) + (string-append "single bit " (number->string b))) + (lambda (a b c d) + (= (bit-extract a b c) d)) + (list + (list fixnum-max 0 1 1) + (list fixnum-max 1 2 1) + (list fixnum-max (+ fixnum-bit -2) (+ fixnum-bit -1) 1) + (list fixnum-max (+ fixnum-bit -1) (+ fixnum-bit 0) 0) + (list fixnum-max (+ fixnum-bit 0) (+ fixnum-bit 1) 0) + (list fixnum-max (+ fixnum-bit 1) (+ fixnum-bit 2) 0))) + + (run-tests + (lambda (a b c d) + (string-append "fixnum-bit - 1 bits starting at " (number->string b))) + (lambda (a b c d) + (= (bit-extract a b c) d)) + (list + (list fixnum-max 0 (+ fixnum-bit -1) (ash fixnum-max 0)) + (list fixnum-max 1 (+ fixnum-bit 0) (ash fixnum-max -1)) + (list fixnum-max 2 (+ fixnum-bit 1) (ash fixnum-max -2)) + (list fixnum-max (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -3) 1) + (list fixnum-max (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -2) 0) + (list fixnum-max (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit -1) 0) + (list fixnum-max (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 0) 0))) + + (run-tests + (lambda (a b c d) + (string-append "fixnum-bit bits starting at " (number->string b))) + (lambda (a b c d) + (= (bit-extract a b c) d)) + (list + (list fixnum-max 0 (+ fixnum-bit 0) (ash fixnum-max 0)) + (list fixnum-max 1 (+ fixnum-bit 1) (ash fixnum-max -1)) + (list fixnum-max 2 (+ fixnum-bit 2) (ash fixnum-max -2)) + (list fixnum-max (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -2) 1) + (list fixnum-max (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -1) 0) + (list fixnum-max (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 0) 0) + (list fixnum-max (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 1) 0))) + + (run-tests + (lambda (a b c d) + (string-append "fixnum-bit + 1 bits starting at " (number->string b))) + (lambda (a b c d) + (= (bit-extract a b c) d)) + (list + (list fixnum-max 0 (+ fixnum-bit 1) (ash fixnum-max 0)) + (list fixnum-max 1 (+ fixnum-bit 2) (ash fixnum-max -1)) + (list fixnum-max 2 (+ fixnum-bit 3) (ash fixnum-max -2)) + (list fixnum-max (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -1) 1) + (list fixnum-max (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit 0) 0) + (list fixnum-max (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 1) 0) + (list fixnum-max (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 2) 0)))) + + (with-test-prefix "extract from fixnum-max + 1" + + (run-tests + (lambda (a b c d) + (string-append "single bit " (number->string b))) + (lambda (a b c d) + (= (bit-extract a b c) d)) + (list + (list (+ fixnum-max 1) 0 1 0) + (list (+ fixnum-max 1) 1 2 0) + (list (+ fixnum-max 1) (+ fixnum-bit -2) (+ fixnum-bit -1) 0) + (list (+ fixnum-max 1) (+ fixnum-bit -1) (+ fixnum-bit 0) 1) + (list (+ fixnum-max 1) (+ fixnum-bit 0) (+ fixnum-bit 1) 0) + (list (+ fixnum-max 1) (+ fixnum-bit 1) (+ fixnum-bit 2) 0))) + + (run-tests + (lambda (a b c d) + (string-append "fixnum-bit - 1 bits starting at " (number->string b))) + (lambda (a b c d) + (= (bit-extract a b c) d)) + (list + (list (+ fixnum-max 1) 0 (+ fixnum-bit -1) (ash 0 (- fixnum-bit 1))) + (list (+ fixnum-max 1) 1 (+ fixnum-bit 0) (ash 1 (- fixnum-bit 2))) + (list (+ fixnum-max 1) 2 (+ fixnum-bit 1) (ash 1 (- fixnum-bit 3))) + (list (+ fixnum-max 1) (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -3) 2) + (list (+ fixnum-max 1) (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -2) 1) + (list (+ fixnum-max 1) (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit -1) 0) + (list (+ fixnum-max 1) (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 0) 0))) + + (run-tests + (lambda (a b c d) + (string-append "fixnum-bit bits starting at " (number->string b))) + (lambda (a b c d) + (= (bit-extract a b c) d)) + (list + (list (+ fixnum-max 1) 0 (+ fixnum-bit 0) (ash 1 (- fixnum-bit 1))) + (list (+ fixnum-max 1) 1 (+ fixnum-bit 1) (ash 1 (- fixnum-bit 2))) + (list (+ fixnum-max 1) 2 (+ fixnum-bit 2) (ash 1 (- fixnum-bit 3))) + (list (+ fixnum-max 1) (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -2) 2) + (list (+ fixnum-max 1) (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -1) 1) + (list (+ fixnum-max 1) (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 0) 0) + (list (+ fixnum-max 1) (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 1) 0))) + + (run-tests + (lambda (a b c d) + (string-append "fixnum-bit + 1 bits starting at " (number->string b))) + (lambda (a b c d) + (= (bit-extract a b c) d)) + (list + (list (+ fixnum-max 1) 0 (+ fixnum-bit 1) (ash 1 (- fixnum-bit 1))) + (list (+ fixnum-max 1) 1 (+ fixnum-bit 2) (ash 1 (- fixnum-bit 2))) + (list (+ fixnum-max 1) 2 (+ fixnum-bit 3) (ash 1 (- fixnum-bit 3))) + (list (+ fixnum-max 1) (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -1) 2) + (list (+ fixnum-max 1) (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit 0) 1) + (list (+ fixnum-max 1) (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 1) 0) + (list (+ fixnum-max 1) (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 2) 0)))) + + (with-test-prefix "extract from fixnum-min" + + (run-tests + (lambda (a b c d) + (string-append "single bit " (number->string b))) + (lambda (a b c d) + (= (bit-extract a b c) d)) + (list + (list fixnum-min 0 1 0) + (list fixnum-min 1 2 0) + (list fixnum-min (+ fixnum-bit -2) (+ fixnum-bit -1) 0) + (list fixnum-min (+ fixnum-bit -1) (+ fixnum-bit 0) 1) + (list fixnum-min (+ fixnum-bit 0) (+ fixnum-bit 1) 1) + (list fixnum-min (+ fixnum-bit 1) (+ fixnum-bit 2) 1))) + + (run-tests + (lambda (a b c d) + (string-append "fixnum-bit - 1 bits starting at " (number->string b))) + (lambda (a b c d) + (= (bit-extract a b c) d)) + (list + (list fixnum-min 0 (+ fixnum-bit -1) (ash 0 (- fixnum-bit 1))) + (list fixnum-min 1 (+ fixnum-bit 0) (ash 1 (- fixnum-bit 2))) + (list fixnum-min 2 (+ fixnum-bit 1) (ash 3 (- fixnum-bit 3))) + (list fixnum-min (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -3) (- (ash 1 (- fixnum-bit 1)) 2)) + (list fixnum-min (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -2) (- (ash 1 (- fixnum-bit 1)) 1)) + (list fixnum-min (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit -1) (- (ash 1 (- fixnum-bit 1)) 1)) + (list fixnum-min (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 0) (- (ash 1 (- fixnum-bit 1)) 1)))) + + (run-tests + (lambda (a b c d) + (string-append "fixnum-bit bits starting at " (number->string b))) + (lambda (a b c d) + (= (bit-extract a b c) d)) + (list + (list fixnum-min 0 (+ fixnum-bit 0) (ash 1 (- fixnum-bit 1))) + (list fixnum-min 1 (+ fixnum-bit 1) (ash 3 (- fixnum-bit 2))) + (list fixnum-min 2 (+ fixnum-bit 2) (ash 7 (- fixnum-bit 3))) + (list fixnum-min (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -2) (- (ash 1 fixnum-bit) 2)) + (list fixnum-min (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -1) (- (ash 1 fixnum-bit) 1)) + (list fixnum-min (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 0) (- (ash 1 fixnum-bit) 1)) + (list fixnum-min (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 1) (- (ash 1 fixnum-bit) 1)))) + + (run-tests + (lambda (a b c d) + (string-append "fixnum-bit + 1 bits starting at " (number->string b))) + (lambda (a b c d) + (= (bit-extract a b c) d)) + (list + (list fixnum-min 0 (+ fixnum-bit 1) (ash 3 (- fixnum-bit 1))) + (list fixnum-min 1 (+ fixnum-bit 2) (ash 7 (- fixnum-bit 2))) + (list fixnum-min 2 (+ fixnum-bit 3) (ash 15 (- fixnum-bit 3))) + (list fixnum-min (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -1) (- (ash 1 (+ fixnum-bit 1)) 2)) + (list fixnum-min (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit 0) (- (ash 1 (+ fixnum-bit 1)) 1)) + (list fixnum-min (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 1) (- (ash 1 (+ fixnum-bit 1)) 1)) + (list fixnum-min (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 2) (- (ash 1 (+ fixnum-bit 1)) 1))))) + + (with-test-prefix "extract from fixnum-min - 1" + + (run-tests + (lambda (a b c d) + (string-append "single bit " (number->string b))) + (lambda (a b c d) + (= (bit-extract a b c) d)) + (list + (list (- fixnum-min 1) 0 1 1) + (list (- fixnum-min 1) 1 2 1) + (list (- fixnum-min 1) (+ fixnum-bit -2) (+ fixnum-bit -1) 1) + (list (- fixnum-min 1) (+ fixnum-bit -1) (+ fixnum-bit 0) 0) + (list (- fixnum-min 1) (+ fixnum-bit 0) (+ fixnum-bit 1) 1) + (list (- fixnum-min 1) (+ fixnum-bit 1) (+ fixnum-bit 2) 1))) + + (run-tests + (lambda (a b c d) + (string-append "fixnum-bit - 1 bits starting at " (number->string b))) + (lambda (a b c d) + (= (bit-extract a b c) d)) + (list + (list (- fixnum-min 1) 0 (+ fixnum-bit -1) (- (ash 1 (- fixnum-bit 1)) 1 (ash 0 (- fixnum-bit 1)))) + (list (- fixnum-min 1) 1 (+ fixnum-bit 0) (- (ash 1 (- fixnum-bit 1)) 1 (ash 1 (- fixnum-bit 2)))) + (list (- fixnum-min 1) 2 (+ fixnum-bit 1) (- (ash 1 (- fixnum-bit 1)) 1 (ash 1 (- fixnum-bit 3)))) + (list (- fixnum-min 1) (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -3) (- (ash 1 (- fixnum-bit 1)) 3)) + (list (- fixnum-min 1) (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -2) (- (ash 1 (- fixnum-bit 1)) 2)) + (list (- fixnum-min 1) (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit -1) (- (ash 1 (- fixnum-bit 1)) 1)) + (list (- fixnum-min 1) (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 0) (- (ash 1 (- fixnum-bit 1)) 1)))) + + (run-tests + (lambda (a b c d) + (string-append "fixnum-bit bits starting at " (number->string b))) + (lambda (a b c d) + (= (bit-extract a b c) d)) + (list + (list (- fixnum-min 1) 0 (+ fixnum-bit 0) (- (ash 1 fixnum-bit) 1 (ash 1 (- fixnum-bit 1)))) + (list (- fixnum-min 1) 1 (+ fixnum-bit 1) (- (ash 1 fixnum-bit) 1 (ash 1 (- fixnum-bit 2)))) + (list (- fixnum-min 1) 2 (+ fixnum-bit 2) (- (ash 1 fixnum-bit) 1 (ash 1 (- fixnum-bit 3)))) + (list (- fixnum-min 1) (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -2) (- (ash 1 fixnum-bit) 3)) + (list (- fixnum-min 1) (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -1) (- (ash 1 fixnum-bit) 2)) + (list (- fixnum-min 1) (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 0) (- (ash 1 fixnum-bit) 1)) + (list (- fixnum-min 1) (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 1) (- (ash 1 fixnum-bit) 1)))) + + (run-tests + (lambda (a b c d) + (string-append "fixnum-bit + 1 bits starting at " (number->string b))) + (lambda (a b c d) + (= (bit-extract a b c) d)) + (list + (list (- fixnum-min 1) 0 (+ fixnum-bit 1) (- (ash 1 (+ fixnum-bit 1)) 1 (ash 1 (- fixnum-bit 1)))) + (list (- fixnum-min 1) 1 (+ fixnum-bit 2) (- (ash 1 (+ fixnum-bit 1)) 1 (ash 1 (- fixnum-bit 2)))) + (list (- fixnum-min 1) 2 (+ fixnum-bit 3) (- (ash 1 (+ fixnum-bit 1)) 1 (ash 1 (- fixnum-bit 3)))) + (list (- fixnum-min 1) (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -1) (- (ash 1 (+ fixnum-bit 1)) 3)) + (list (- fixnum-min 1) (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit 0) (- (ash 1 (+ fixnum-bit 1)) 2)) + (list (- fixnum-min 1) (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 1) (- (ash 1 (+ fixnum-bit 1)) 1)) + (list (- fixnum-min 1) (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 2) (- (ash 1 (+ fixnum-bit 1)) 1)))))) From 5c75b29f1d3f318318a1645a268cd17d6452cbf5 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 18 Jan 2001 13:35:45 +0000 Subject: [PATCH 0466/2047] * Cleaned up some limits-definitions. --- libguile/ChangeLog | 15 ++++++++++++ libguile/__scm.h | 57 +++++++++++++++++++++++++++------------------- libguile/numbers.h | 16 +++++-------- 3 files changed, 54 insertions(+), 34 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f8ed2b5a2..c9250adca 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,18 @@ +2001-01-18 Dirk Herrmann + + * __scm.h: Added comment about architecture and compiler + properties that are required by guile. + + (SCM_FIXNUM_BIT, SCM_MOST_POSITIVE_FIXNUM, + SCM_MOST_NEGATIVE_FIXNUM): Moved to numbers.h. + + (SCM_CHAR_BIT, SCM_LONG_BIT): Moved here from numbers.h. + + * numbers.h (SCM_CHAR_BIT, SCM_LONG_BIT): Moved to __scm.h. + + (SCM_FIXNUM_BIT, SCM_MOST_POSITIVE_FIXNUM, + SCM_MOST_NEGATIVE_FIXNUM): Moved here from __scm.h. + 2001-01-17 Dirk Herrmann * __scm.h (SCM_FIXNUM_BIT): Added. The name is chosen in analogy diff --git a/libguile/__scm.h b/libguile/__scm.h index 7723396bc..75a01a934 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -203,37 +203,46 @@ typedef unsigned long long ulong_long; -/* Define +/* {Architecture and compiler properties} * - * SCM_CHAR_CODE_LIMIT == UCHAR_MAX + 1 - * SCM_MOST_POSITIVE_FIXNUM (LONG_MAX>>2) - * SCM_MOST_NEGATIVE_FIXNUM == SCM_SRS((long)LONG_MIN, 2) + * Guile as of today can only work on systems which fulfill at least the + * following requirements: + * - long ints have at least 32 bits. + * Guile's type system is based on this assumption. + * - long ints consist of at least four characters. + * It is assumed that cells, i. e. pairs of long ints, are eight character + * aligned, because three bits of a cell pointer are used for type data. + * - sizeof (void*) == sizeof (long int) + * Pointers are stored in SCM objects, and sometimes SCM objects are passed + * as void*. Thus, there has to be a one-to-one correspondence. + * - numbers are encoded using two's complement. + * The implementation of the bitwise scheme level operations is based on + * this assumption. + * - ... add more */ #ifdef HAVE_LIMITS_H # include -# ifdef UCHAR_MAX -# define SCM_CHAR_CODE_LIMIT (UCHAR_MAX+1L) -# else -# define SCM_CHAR_CODE_LIMIT 256L -# endif /* def UCHAR_MAX */ -# define SCM_FIXNUM_BIT (LONG_BIT - 2) -# define SCM_MOST_POSITIVE_FIXNUM (LONG_MAX>>2) -# ifdef _UNICOS /* Stupid cray bug */ -# define SCM_MOST_NEGATIVE_FIXNUM ((long)LONG_MIN/4) -# else -# define SCM_MOST_NEGATIVE_FIXNUM SCM_SRS((long)LONG_MIN, 2) -# endif /* UNICOS */ +#endif + +#ifdef CHAR_BIT +# define SCM_CHAR_BIT CHAR_BIT +#else +# define SCM_CHAR_BIT 8 +#endif + +#ifdef LONG_BIT +# define SCM_LONG_BIT LONG_BIT +#else +# define SCM_LONG_BIT (SCM_CHAR_BIT * sizeof (long) / sizeof (char)) +#endif + +#ifdef UCHAR_MAX +# define SCM_CHAR_CODE_LIMIT (UCHAR_MAX + 1L) #else # define SCM_CHAR_CODE_LIMIT 256L -# define SCM_FIXNUM_BIT 30 -# define SCM_MOST_POSITIVE_FIXNUM ((long)((unsigned long)~0L>>3)) -# if (0 != ~0) -# define SCM_MOST_NEGATIVE_FIXNUM (-SCM_MOST_POSITIVE_FIXNUM-1) -# else -# define SCM_MOST_NEGATIVE_FIXNUM (-SCM_MOST_POSITIVE_FIXNUM) -# endif /* (0 != ~0) */ -#endif /* def HAVE_LIMITS_H */ +#endif + #ifdef STDC_HEADERS diff --git a/libguile/numbers.h b/libguile/numbers.h index 6a78c5910..d5b2809e7 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -52,7 +52,6 @@ - /* Immediate Numbers * * Inums are exact integer data that fits within an SCM word. @@ -63,6 +62,11 @@ * SCM_INUMP (SCM_CAR (x)) can give wrong answers. */ +#define SCM_FIXNUM_BIT (SCM_LONG_BIT - 2) +#define SCM_MOST_POSITIVE_FIXNUM ((1L << (SCM_FIXNUM_BIT - 1)) - 1) +#define SCM_MOST_NEGATIVE_FIXNUM (-SCM_MOST_POSITIVE_FIXNUM - 1) + + /* SCM_SRS is signed right shift */ #if (-1 == (((-1) << 2) + 2) >> 2) # define SCM_SRS(x, y) ((x) >> (y)) @@ -111,15 +115,7 @@ /* SCM_INTBUFLEN is the maximum number of characters neccessary for the * printed or scm_string representation of an exact immediate. */ - -#ifndef SCM_CHAR_BIT -# define SCM_CHAR_BIT 8 -#endif /* ndef SCM_CHAR_BIT */ -#ifndef SCM_LONG_BIT -# define SCM_LONG_BIT (SCM_CHAR_BIT*sizeof(long)/sizeof(char)) -#endif /* ndef SCM_LONG_BIT */ -#define SCM_INTBUFLEN (5+SCM_LONG_BIT) - +#define SCM_INTBUFLEN (5 + SCM_LONG_BIT) From 8f379a8f61310fd4b75664777653044aaa54d173 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 18 Jan 2001 15:12:51 +0000 Subject: [PATCH 0467/2047] * Simplified gh_ints2scm by using SCM_FIXABLE. --- libguile/ChangeLog | 4 ++++ libguile/gh_data.c | 6 ++---- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index c9250adca..3bf635e5a 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2001-01-18 Dirk Herrmann + + * gh_data.c (gh_ints2scm): Simplified using SCM_FIXABLE. + 2001-01-18 Dirk Herrmann * __scm.h: Added comment about architecture and compiler diff --git a/libguile/gh_data.c b/libguile/gh_data.c index 33c615251..5597e9a88 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -140,10 +140,8 @@ gh_ints2scm (int *d, int n) SCM *velts = SCM_VELTS(v); for (i = 0; i < n; ++i) - velts[i] = (d[i] >= SCM_MOST_NEGATIVE_FIXNUM - && d[i] <= SCM_MOST_POSITIVE_FIXNUM - ? SCM_MAKINUM (d[i]) - : scm_long2big (d[i])); + velts[i] = (SCM_FIXABLE (d[i]) ? SCM_MAKINUM (d[i]) : scm_long2big (d[i])); + return v; } From 21e39e8fe6a5aefb62a9343d3e7f118c5efd6a44 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 18 Jan 2001 17:24:10 +0000 Subject: [PATCH 0468/2047] * Converted to real boundary testing. --- test-suite/ChangeLog | 4 + test-suite/tests/numbers.test | 1215 ++++++++++++++++++++------------- 2 files changed, 759 insertions(+), 460 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 1d2706aca..e2b9cf075 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2001-01-18 Dirk Herrmann + + * tests/numbers.test: Converted to do real boundary testing. + 2001-01-17 Dirk Herrmann * tests/bit-operations.test: Added. diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 8319ed1b7..6a53e5d1a 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -47,37 +47,12 @@ ;;; miscellaneous ;;; - (define (documented? object) (object-documentation object)) - -(define (make-test-name . args) - (with-output-to-string - (lambda () - (for-each display args)))) - - -(define bit-widths '(8 16 27 28 29 30 31 32 64 128 256)) - - -(define (2^x-1 x) - (- (expt 2 x) 1)) - -(define (2^ x) - (expt 2 x)) - -(define (n=2^x-1 x) - (make-test-name "n = 2^" x " - 1")) - -(define (n=-2^x+1 x) - (make-test-name "n = -2^" x " + 1")) - -(define (n=2^ x) - (make-test-name "n = 2^" x)) - -(define (n=-2^ x) - (make-test-name "n = -2^" x)) +(define fixnum-bit 30) +(define fixnum-min most-negative-fixnum) +(define fixnum-max most-positive-fixnum) ;;; @@ -86,39 +61,35 @@ (with-test-prefix "exact?" - ;; Is documentation available? - (pass-if "documented?" (documented? exact?)) - ;; Special case: 0 + (with-test-prefix "integers" - (pass-if "0" - (eq? #t (exact? 0))) + (pass-if "0" + (exact? 0)) - ;; integers: + (pass-if "fixnum-max" + (exact? fixnum-max)) - (for-each - (lambda (x) - (pass-if (make-test-name "2^" x " - 1") - (eq? #t (exact? (2^x-1 x)))) - (pass-if (make-test-name "-2^" x " + 1") - (eq? #t (exact? (- (2^x-1 x))))) - (pass-if (make-test-name "2^" x) - (eq? #t (exact? (2^ x)))) - (pass-if (make-test-name "-2^" x) - (eq? #t (exact? (- (2^ x)))))) - bit-widths) + (pass-if "fixnum-max + 1" + (exact? (+ fixnum-max 1))) - ;; floats: (FIXME: need more examples) + (pass-if "fixnum-min" + (exact? fixnum-min)) - (for-each - (lambda (x) - (pass-if (make-test-name "sqrt((2^" x " - 1)^2 - 1)") - (eq? #f (exact? (sqrt (- (* (2^x-1 x) (2^x-1 x)) 1))))) - (pass-if (make-test-name "sqrt((2^" x ")^2 + 1)") - (eq? #f (exact? (sqrt (+ (* (2^ x) (2^ x)) 1)))))) - bit-widths)) + (pass-if "fixnum-min - 1" + (exact? (- fixnum-min 1)))) + + (with-test-prefix "reals" + + ;; (FIXME: need better examples.) + + (pass-if "sqrt (fixnum-max^2 - 1)" + (eq? #f (exact? (sqrt (- (expt fixnum-max 2) 1))))) + + (pass-if "sqrt ((fixnum-max+1)^2 - 1)" + (eq? #f (exact? (sqrt (- (expt (+ fixnum-max 1) 2) 1))))))) ;;; ;;; odd? @@ -141,13 +112,9 @@ (with-test-prefix "quotient" - ;; Is documentation available? - (expect-fail "documented?" (documented? quotient)) - ;; Special case: 0 / n - (with-test-prefix "0 / n" (pass-if "n = 1" @@ -156,77 +123,158 @@ (pass-if "n = -1" (eqv? 0 (quotient 0 -1))) - (for-each - (lambda (x) - (pass-if (n=2^x-1 x) - (eqv? 0 (quotient 0 (2^x-1 x)))) - (pass-if (n=-2^x+1 x) - (eqv? 0 (quotient 0 (- (2^x-1 x))))) - (pass-if (n=2^ x) - (eqv? 0 (quotient 0 (expt 2 x)))) - (pass-if (n=-2^ x) - (eqv? 0 (quotient 0 (- (expt 2 x)))))) - bit-widths)) - - ;; Special case: n / 1 + (pass-if "n = 2" + (eqv? 0 (quotient 0 2))) - (with-test-prefix "n / 1" + (pass-if "n = fixnum-max" + (eqv? 0 (quotient 0 fixnum-max))) + + (pass-if "n = fixnum-max + 1" + (eqv? 0 (quotient 0 (+ fixnum-max 1)))) + + (pass-if "n = fixnum-min" + (eqv? 0 (quotient 0 fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (eqv? 0 (quotient 0 (- fixnum-min 1))))) + + (with-test-prefix "1 / n" (pass-if "n = 1" (eqv? 1 (quotient 1 1))) (pass-if "n = -1" - (eqv? -1 (quotient -1 1))) + (eqv? -1 (quotient 1 -1))) - (for-each - (lambda (x) - (pass-if (n=2^x-1 x) - (eqv? (2^x-1 x) (quotient (2^x-1 x) 1))) - (pass-if (n=-2^x+1 x) - (eqv? (- (2^x-1 x)) (quotient (- (2^x-1 x)) 1))) - (pass-if (n=2^ x) - (eqv? (2^ x) (quotient (2^ x) 1))) - (pass-if (n=-2^ x) - (eqv? (- (2^ x)) (quotient (- (2^ x)) 1)))) - bit-widths)) + (pass-if "n = 2" + (eqv? 0 (quotient 1 2))) - ;; Special case: n / -1 + (pass-if "n = fixnum-max" + (eqv? 0 (quotient 1 fixnum-max))) - (with-test-prefix "n / -1" + (pass-if "n = fixnum-max + 1" + (eqv? 0 (quotient 1 (+ fixnum-max 1)))) + + (pass-if "n = fixnum-min" + (eqv? 0 (quotient 1 fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (eqv? 0 (quotient 1 (- fixnum-min 1))))) + + (with-test-prefix "-1 / n" (pass-if "n = 1" - (eqv? -1 (quotient 1 -1))) + (eqv? -1 (quotient -1 1))) (pass-if "n = -1" (eqv? 1 (quotient -1 -1))) - (for-each - (lambda (x) - (pass-if (n=2^x-1 x) - (eqv? (- (2^x-1 x)) (quotient (2^x-1 x) -1))) - (pass-if (n=-2^x+1 x) - (eqv? (2^x-1 x) (quotient (- (2^x-1 x)) -1))) - (pass-if (n=2^ x) - (eqv? (- (2^ x)) (quotient (2^ x) -1))) - (pass-if (n=-2^ x) - (eqv? (2^ x) (quotient (- (2^ x)) -1)))) - bit-widths)) + (pass-if "n = 2" + (eqv? 0 (quotient -1 2))) - ;; Special case: n / n + (pass-if "n = fixnum-max" + (eqv? 0 (quotient -1 fixnum-max))) - (with-test-prefix "n / n" + (pass-if "n = fixnum-max + 1" + (eqv? 0 (quotient -1 (+ fixnum-max 1)))) - (for-each - (lambda (x) - (pass-if (n=2^x-1 x) - (eqv? 1 (quotient (2^x-1 x) (2^x-1 x)))) - (pass-if (n=-2^x+1 x) - (eqv? 1 (quotient (- (2^x-1 x)) (- (2^x-1 x))))) - (pass-if (n=2^ x) - (eqv? 1 (quotient (2^ x) (2^ x)))) - (pass-if (n=-2^ x) - (eqv? 1 (quotient (- (2^ x)) (- (2^ x)))))) - bit-widths)) + (pass-if "n = fixnum-min" + (eqv? 0 (quotient -1 fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (eqv? 0 (quotient -1 (- fixnum-min 1))))) + + (with-test-prefix "fixnum-max / n" + + (pass-if "n = 1" + (eqv? fixnum-max (quotient fixnum-max 1))) + + (pass-if "n = -1" + (eqv? (- fixnum-max) (quotient fixnum-max -1))) + + (pass-if "n = 2" + (eqv? fixnum-max (+ (* (quotient fixnum-max 2) 2) 1))) + + (pass-if "n = fixnum-max" + (eqv? 1 (quotient fixnum-max fixnum-max))) + + (pass-if "n = fixnum-max + 1" + (eqv? 0 (quotient fixnum-max (+ fixnum-max 1)))) + + (pass-if "n = fixnum-min" + (eqv? 0 (quotient fixnum-max fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (eqv? 0 (quotient fixnum-max (- fixnum-min 1))))) + + (with-test-prefix "(fixnum-max + 1) / n" + + (pass-if "n = 1" + (eqv? (+ fixnum-max 1) (quotient (+ fixnum-max 1) 1))) + + (pass-if "n = -1" + (eqv? (- (+ fixnum-max 1)) (quotient (+ fixnum-max 1) -1))) + + (pass-if "n = 2" + (eqv? (+ fixnum-max 1) (* (quotient (+ fixnum-max 1) 2) 2))) + + (pass-if "n = fixnum-max" + (eqv? 1 (quotient (+ fixnum-max 1) fixnum-max))) + + (pass-if "n = fixnum-max + 1" + (eqv? 1 (quotient (+ fixnum-max 1) (+ fixnum-max 1)))) + + (pass-if "n = fixnum-min" + (eqv? -1 (quotient (+ fixnum-max 1) fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (eqv? 0 (quotient (+ fixnum-max 1) (- fixnum-min 1))))) + + (with-test-prefix "fixnum-min / n" + + (pass-if "n = 1" + (eqv? fixnum-min (quotient fixnum-min 1))) + + (pass-if "n = -1" + (eqv? (- fixnum-min) (quotient fixnum-min -1))) + + (pass-if "n = 2" + (eqv? fixnum-min (* (quotient fixnum-min 2) 2))) + + (pass-if "n = fixnum-max" + (eqv? -1 (quotient fixnum-min fixnum-max))) + + (pass-if "n = fixnum-max + 1" + (eqv? -1 (quotient fixnum-min (+ fixnum-max 1)))) + + (pass-if "n = fixnum-min" + (eqv? 1 (quotient fixnum-min fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (eqv? 0 (quotient fixnum-min (- fixnum-min 1))))) + + (with-test-prefix "(fixnum-min - 1) / n" + + (pass-if "n = 1" + (eqv? (- fixnum-min 1) (quotient (- fixnum-min 1) 1))) + + (pass-if "n = -1" + (eqv? (- (- fixnum-min 1)) (quotient (- fixnum-min 1) -1))) + + (pass-if "n = 2" + (eqv? fixnum-min (* (quotient (- fixnum-min 1) 2) 2))) + + (pass-if "n = fixnum-max" + (eqv? -1 (quotient (- fixnum-min 1) fixnum-max))) + + (pass-if "n = fixnum-max + 1" + (eqv? -1 (quotient (- fixnum-min 1) (+ fixnum-max 1)))) + + (pass-if "n = fixnum-min" + (eqv? 1 (quotient (- fixnum-min 1) fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (eqv? 1 (quotient (- fixnum-min 1) (- fixnum-min 1))))) ;; Positive dividend and divisor @@ -260,13 +308,9 @@ (with-test-prefix "remainder" - ;; Is documentation available? - (expect-fail "documented?" (documented? remainder)) - ;; Special case: 0 / n - (with-test-prefix "0 / n" (pass-if "n = 1" @@ -275,77 +319,137 @@ (pass-if "n = -1" (eqv? 0 (remainder 0 -1))) - (for-each - (lambda (x) - (pass-if (n=2^x-1 x) - (eqv? 0 (remainder 0 (2^x-1 x)))) - (pass-if (n=-2^x+1 x) - (eqv? 0 (remainder 0 (- (2^x-1 x))))) - (pass-if (n=2^ x) - (eqv? 0 (remainder 0 (2^ x)))) - (pass-if (n=-2^ x) - (eqv? 0 (remainder 0 (- (2^ x)))))) - bit-widths)) + (pass-if "n = fixnum-max" + (eqv? 0 (remainder 0 fixnum-max))) - ;; Special case: n / 1 + (pass-if "n = fixnum-max + 1" + (eqv? 0 (remainder 0 (+ fixnum-max 1)))) - (with-test-prefix "n / 1" + (pass-if "n = fixnum-min" + (eqv? 0 (remainder 0 fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (eqv? 0 (remainder 0 (- fixnum-min 1))))) + + (with-test-prefix "1 / n" (pass-if "n = 1" (eqv? 0 (remainder 1 1))) (pass-if "n = -1" - (eqv? 0 (remainder -1 1))) + (eqv? 0 (remainder 1 -1))) - (for-each - (lambda (x) - (pass-if (n=2^x-1 x) - (eqv? 0 (remainder (2^x-1 x) 1))) - (pass-if (n=-2^x+1 x) - (eqv? 0 (remainder (- (2^x-1 x)) 1))) - (pass-if (n=2^ x) - (eqv? 0 (remainder (2^ x) 1))) - (pass-if (n=-2^ x) - (eqv? 0 (remainder (- (2^ x)) 1)))) - bit-widths)) + (pass-if "n = fixnum-max" + (eqv? 1 (remainder 1 fixnum-max))) - ;; Special case: n / -1 + (pass-if "n = fixnum-max + 1" + (eqv? 1 (remainder 1 (+ fixnum-max 1)))) - (with-test-prefix "n / -1" + (pass-if "n = fixnum-min" + (eqv? 1 (remainder 1 fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (eqv? 1 (remainder 1 (- fixnum-min 1))))) + + (with-test-prefix "-1 / n" (pass-if "n = 1" - (eqv? 0 (remainder 1 -1))) + (eqv? 0 (remainder -1 1))) (pass-if "n = -1" (eqv? 0 (remainder -1 -1))) - (for-each - (lambda (x) - (pass-if (n=2^x-1 x) - (eqv? 0 (remainder (2^x-1 x) -1))) - (pass-if (n=-2^x+1 x) - (eqv? 0 (remainder (- (2^x-1 x)) -1))) - (pass-if (n=2^ x) - (eqv? 0 (remainder (2^ x) -1))) - (pass-if (n=-2^ x) - (eqv? 0 (remainder (- (2^ x)) -1)))) - bit-widths)) + (pass-if "n = fixnum-max" + (eqv? -1 (remainder -1 fixnum-max))) - ;; Special case: n / n + (pass-if "n = fixnum-max + 1" + (eqv? -1 (remainder -1 (+ fixnum-max 1)))) - (with-test-prefix "n / n" + (pass-if "n = fixnum-min" + (eqv? -1 (remainder -1 fixnum-min))) - (for-each - (lambda (x) - (pass-if (n=2^x-1 x) - (eqv? 0 (remainder (2^x-1 x) (2^x-1 x)))) - (pass-if (n=-2^x+1 x) - (eqv? 0 (remainder (- (2^x-1 x)) (- (2^x-1 x))))) - (pass-if (n=2^ x) - (eqv? 0 (remainder (2^ x) (2^ x)))) - (pass-if (n=-2^ x) - (eqv? 0 (remainder (- (2^ x)) (- (2^ x)))))) - bit-widths)) + (pass-if "n = fixnum-min - 1" + (eqv? -1 (remainder -1 (- fixnum-min 1))))) + + (with-test-prefix "fixnum-max / n" + + (pass-if "n = 1" + (eqv? 0 (remainder fixnum-max 1))) + + (pass-if "n = -1" + (eqv? 0 (remainder fixnum-max -1))) + + (pass-if "n = fixnum-max" + (eqv? 0 (remainder fixnum-max fixnum-max))) + + (pass-if "n = fixnum-max + 1" + (eqv? fixnum-max (remainder fixnum-max (+ fixnum-max 1)))) + + (pass-if "n = fixnum-min" + (eqv? fixnum-max (remainder fixnum-max fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (eqv? fixnum-max (remainder fixnum-max (- fixnum-min 1))))) + + (with-test-prefix "(fixnum-max + 1) / n" + + (pass-if "n = 1" + (eqv? 0 (remainder (+ fixnum-max 1) 1))) + + (pass-if "n = -1" + (eqv? 0 (remainder (+ fixnum-max 1) -1))) + + (pass-if "n = fixnum-max" + (eqv? 1 (remainder (+ fixnum-max 1) fixnum-max))) + + (pass-if "n = fixnum-max + 1" + (eqv? 0 (remainder (+ fixnum-max 1) (+ fixnum-max 1)))) + + (pass-if "n = fixnum-min" + (eqv? 0 (remainder (+ fixnum-max 1) fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (eqv? (+ fixnum-max 1) (remainder (+ fixnum-max 1) (- fixnum-min 1))))) + + (with-test-prefix "fixnum-min / n" + + (pass-if "n = 1" + (eqv? 0 (remainder fixnum-min 1))) + + (pass-if "n = -1" + (eqv? 0 (remainder fixnum-min -1))) + + (pass-if "n = fixnum-max" + (eqv? -1 (remainder fixnum-min fixnum-max))) + + (pass-if "n = fixnum-max + 1" + (eqv? 0 (remainder fixnum-min (+ fixnum-max 1)))) + + (pass-if "n = fixnum-min" + (eqv? 0 (remainder fixnum-min fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (eqv? fixnum-min (remainder fixnum-min (- fixnum-min 1))))) + + (with-test-prefix "(fixnum-min - 1) / n" + + (pass-if "n = 1" + (eqv? 0 (remainder (- fixnum-min 1) 1))) + + (pass-if "n = -1" + (eqv? 0 (remainder (- fixnum-min 1) -1))) + + (pass-if "n = fixnum-max" + (eqv? -2 (remainder (- fixnum-min 1) fixnum-max))) + + (pass-if "n = fixnum-max + 1" + (eqv? -1 (remainder (- fixnum-min 1) (+ fixnum-max 1)))) + + (pass-if "n = fixnum-min" + (eqv? -1 (remainder (- fixnum-min 1) fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (eqv? 0 (remainder (- fixnum-min 1) (- fixnum-min 1))))) ;; Positive dividend and divisor @@ -379,13 +483,9 @@ (with-test-prefix "modulo" - ;; Is documentation available? - (expect-fail "documented?" (documented? modulo)) - ;; Special case: 0 % n - (with-test-prefix "0 % n" (pass-if "n = 1" @@ -394,77 +494,137 @@ (pass-if "n = -1" (eqv? 0 (modulo 0 -1))) - (for-each - (lambda (x) - (pass-if (n=2^x-1 x) - (eqv? 0 (modulo 0 (2^x-1 x)))) - (pass-if (n=-2^x+1 x) - (eqv? 0 (modulo 0 (- (2^x-1 x))))) - (pass-if (n=2^ x) - (eqv? 0 (modulo 0 (2^ x)))) - (pass-if (n=-2^ x) - (eqv? 0 (modulo 0 (- (2^ x)))))) - bit-widths)) + (pass-if "n = fixnum-max" + (eqv? 0 (modulo 0 fixnum-max))) - ;; Special case: n % 1 + (pass-if "n = fixnum-max + 1" + (eqv? 0 (modulo 0 (+ fixnum-max 1)))) - (with-test-prefix "n % 1" + (pass-if "n = fixnum-min" + (eqv? 0 (modulo 0 fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (eqv? 0 (modulo 0 (- fixnum-min 1))))) + + (with-test-prefix "1 % n" (pass-if "n = 1" (eqv? 0 (modulo 1 1))) (pass-if "n = -1" - (eqv? 0 (modulo -1 1))) + (eqv? 0 (modulo 1 -1))) - (for-each - (lambda (x) - (pass-if (n=2^x-1 x) - (eqv? 0 (modulo (2^x-1 x) 1))) - (pass-if (n=-2^x+1 x) - (eqv? 0 (modulo (- (2^x-1 x)) 1))) - (pass-if (n=2^ x) - (eqv? 0 (modulo (2^ x) 1))) - (pass-if (n=-2^ x) - (eqv? 0 (modulo (- (2^ x)) 1)))) - bit-widths)) + (pass-if "n = fixnum-max" + (eqv? 1 (modulo 1 fixnum-max))) - ;; Special case: n % -1 + (pass-if "n = fixnum-max + 1" + (eqv? 1 (modulo 1 (+ fixnum-max 1)))) - (with-test-prefix "n % -1" + (pass-if "n = fixnum-min" + (eqv? (+ fixnum-min 1) (modulo 1 fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (eqv? fixnum-min (modulo 1 (- fixnum-min 1))))) + + (with-test-prefix "-1 % n" (pass-if "n = 1" - (eqv? 0 (modulo 1 -1))) + (eqv? 0 (modulo -1 1))) (pass-if "n = -1" (eqv? 0 (modulo -1 -1))) - (for-each - (lambda (x) - (pass-if (n=2^x-1 x) - (eqv? 0 (modulo (2^x-1 x) -1))) - (pass-if (n=-2^x+1 x) - (eqv? 0 (modulo (- (2^x-1 x)) -1))) - (pass-if (n=2^ x) - (eqv? 0 (modulo (2^ x) -1))) - (pass-if (n=-2^ x) - (eqv? 0 (modulo (- (2^ x)) -1)))) - bit-widths)) + (pass-if "n = fixnum-max" + (eqv? (- fixnum-max 1) (modulo -1 fixnum-max))) - ;; Special case: n % n + (pass-if "n = fixnum-max + 1" + (eqv? fixnum-max (modulo -1 (+ fixnum-max 1)))) - (with-test-prefix "n % n" + (pass-if "n = fixnum-min" + (eqv? -1 (modulo -1 fixnum-min))) - (for-each - (lambda (x) - (pass-if (n=2^x-1 x) - (eqv? 0 (modulo (2^x-1 x) (2^x-1 x)))) - (pass-if (n=-2^x+1 x) - (eqv? 0 (modulo (- (2^x-1 x)) (- (2^x-1 x))))) - (pass-if (n=2^ x) - (eqv? 0 (modulo (2^ x) (2^ x)))) - (pass-if (n=-2^ x) - (eqv? 0 (modulo (- (2^ x)) (- (2^ x)))))) - bit-widths)) + (pass-if "n = fixnum-min - 1" + (eqv? -1 (modulo -1 (- fixnum-min 1))))) + + (with-test-prefix "fixnum-max % n" + + (pass-if "n = 1" + (eqv? 0 (modulo fixnum-max 1))) + + (pass-if "n = -1" + (eqv? 0 (modulo fixnum-max -1))) + + (pass-if "n = fixnum-max" + (eqv? 0 (modulo fixnum-max fixnum-max))) + + (pass-if "n = fixnum-max + 1" + (eqv? fixnum-max (modulo fixnum-max (+ fixnum-max 1)))) + + (pass-if "n = fixnum-min" + (eqv? -1 (modulo fixnum-max fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (eqv? -2 (modulo fixnum-max (- fixnum-min 1))))) + + (with-test-prefix "(fixnum-max + 1) % n" + + (pass-if "n = 1" + (eqv? 0 (modulo (+ fixnum-max 1) 1))) + + (pass-if "n = -1" + (eqv? 0 (modulo (+ fixnum-max 1) -1))) + + (pass-if "n = fixnum-max" + (eqv? 1 (modulo (+ fixnum-max 1) fixnum-max))) + + (pass-if "n = fixnum-max + 1" + (eqv? 0 (modulo (+ fixnum-max 1) (+ fixnum-max 1)))) + + (pass-if "n = fixnum-min" + (eqv? 0 (modulo (+ fixnum-max 1) fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (eqv? -1 (modulo (+ fixnum-max 1) (- fixnum-min 1))))) + + (with-test-prefix "fixnum-min % n" + + (pass-if "n = 1" + (eqv? 0 (modulo fixnum-min 1))) + + (pass-if "n = -1" + (eqv? 0 (modulo fixnum-min -1))) + + (pass-if "n = fixnum-max" + (eqv? (- fixnum-max 1) (modulo fixnum-min fixnum-max))) + + (pass-if "n = fixnum-max + 1" + (eqv? 0 (modulo fixnum-min (+ fixnum-max 1)))) + + (pass-if "n = fixnum-min" + (eqv? 0 (modulo fixnum-min fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (eqv? fixnum-min (modulo fixnum-min (- fixnum-min 1))))) + + (with-test-prefix "(fixnum-min - 1) % n" + + (pass-if "n = 1" + (eqv? 0 (modulo (- fixnum-min 1) 1))) + + (pass-if "n = -1" + (eqv? 0 (modulo (- fixnum-min 1) -1))) + + (pass-if "n = fixnum-max" + (eqv? (- fixnum-max 2) (modulo (- fixnum-min 1) fixnum-max))) + + (pass-if "n = fixnum-max + 1" + (eqv? fixnum-max (modulo (- fixnum-min 1) (+ fixnum-max 1)))) + + (pass-if "n = fixnum-min" + (eqv? -1 (modulo (- fixnum-min 1) fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (eqv? 0 (modulo (- fixnum-min 1) (- fixnum-min 1))))) ;; Positive dividend and divisor @@ -510,146 +670,169 @@ (with-test-prefix "gcd" - ;; Is documentation available? - (expect-fail "documented?" (documented? gcd)) - ;; Special case: gcd 0 n - (with-test-prefix "(0 n)" + (pass-if "n = 0" + (eqv? 0 (gcd 0 0))) + (pass-if "n = 1" (eqv? 1 (gcd 0 1))) (pass-if "n = -1" (eqv? 1 (gcd 0 -1))) - (for-each - (lambda (x) - (pass-if (n=2^x-1 x) - (eqv? (2^x-1 x) (gcd 0 (2^x-1 x)))) - (pass-if (n=-2^x+1 x) - (eqv? (2^x-1 x) (gcd 0 (- (2^x-1 x))))) - (pass-if (n=2^ x) - (eqv? (2^ x) (gcd 0 (2^ x)))) - (pass-if (n=-2^ x) - (eqv? (2^ x) (gcd 0 (- (2^ x)))))) - bit-widths)) + (pass-if "n = fixnum-max" + (eqv? fixnum-max (gcd 0 fixnum-max))) - ;; Special case: gcd n 0 + (pass-if "n = fixnum-max + 1" + (eqv? (+ fixnum-max 1) (gcd 0 (+ fixnum-max 1)))) - (with-test-prefix "(n 0)" + (pass-if "n = fixnum-min" + (eqv? (- fixnum-min) (gcd 0 fixnum-min))) - (pass-if "n = 1" - (eqv? 1 (gcd 1 0))) - - (pass-if "n = -1" - (eqv? 1 (gcd -1 0))) - - (for-each - (lambda (x) - (pass-if (n=2^x-1 x) - (eqv? (2^x-1 x) (gcd (2^x-1 x) 0))) - (pass-if (n=-2^x+1 x) - (eqv? (2^x-1 x) (gcd (- (2^x-1 x)) 0))) - (pass-if (n=2^ x) - (eqv? (2^ x) (gcd (2^ x) 0))) - (pass-if (n=-2^ x) - (eqv? (2^ x) (gcd (- (2^ x)) 0)))) - bit-widths)) - - ;; Special case: gcd 1 n + (pass-if "n = fixnum-min - 1" + (eqv? (- (- fixnum-min 1)) (gcd 0 (- fixnum-min 1))))) (with-test-prefix "(1 n)" + (pass-if "n = 0" + (eqv? 1 (gcd 1 0))) + (pass-if "n = 1" (eqv? 1 (gcd 1 1))) (pass-if "n = -1" (eqv? 1 (gcd 1 -1))) - (for-each - (lambda (x) - (pass-if (n=2^x-1 x) - (eqv? 1 (gcd 1 (2^x-1 x)))) - (pass-if (n=-2^x+1 x) - (eqv? 1 (gcd 1 (- (2^x-1 x))))) - (pass-if (n=2^ x) - (eqv? 1 (gcd 1 (2^ x)))) - (pass-if (n=-2^ x) - (eqv? 1 (gcd 1 (- (2^ x)))))) - bit-widths)) + (pass-if "n = fixnum-max" + (eqv? 1 (gcd 1 fixnum-max))) - ;; Special case: gcd n 1 + (pass-if "n = fixnum-max + 1" + (eqv? 1 (gcd 1 (+ fixnum-max 1)))) - (with-test-prefix "(n 1)" + (pass-if "n = fixnum-min" + (eqv? 1 (gcd 1 fixnum-min))) - (pass-if "n = -1" - (eqv? 1 (gcd -1 1))) - - (for-each - (lambda (x) - (pass-if (n=2^x-1 x) - (eqv? 1 (gcd (2^x-1 x) 1))) - (pass-if (n=-2^x+1 x) - (eqv? 1 (gcd (- (2^x-1 x)) 1))) - (pass-if (n=2^ x) - (eqv? 1 (gcd (2^ x) 1))) - (pass-if (n=-2^ x) - (eqv? 1 (gcd (- (2^ x)) 1)))) - bit-widths)) - - ;; Special case: gcd -1 n + (pass-if "n = fixnum-min - 1" + (eqv? 1 (gcd 1 (- fixnum-min 1))))) (with-test-prefix "(-1 n)" + (pass-if "n = 0" + (eqv? 1 (gcd -1 0))) + + (pass-if "n = 1" + (eqv? 1 (gcd -1 1))) + (pass-if "n = -1" (eqv? 1 (gcd -1 -1))) - (for-each - (lambda (x) - (pass-if (n=2^x-1 x) - (eqv? 1 (gcd -1 (2^x-1 x)))) - (pass-if (n=-2^x+1 x) - (eqv? 1 (gcd -1 (- (2^x-1 x))))) - (pass-if (n=2^ x) - (eqv? 1 (gcd -1 (2^ x)))) - (pass-if (n=-2^ x) - (eqv? 1 (gcd -1 (- (2^ x)))))) - bit-widths)) + (pass-if "n = fixnum-max" + (eqv? 1 (gcd -1 fixnum-max))) - ;; Special case: gcd n -1 + (pass-if "n = fixnum-max + 1" + (eqv? 1 (gcd -1 (+ fixnum-max 1)))) - (with-test-prefix "(n -1)" + (pass-if "n = fixnum-min" + (eqv? 1 (gcd -1 fixnum-min))) - (for-each - (lambda (x) - (pass-if (n=2^x-1 x) - (eqv? 1 (gcd (2^x-1 x) -1))) - (pass-if (n=-2^x+1 x) - (eqv? 1 (gcd (- (2^x-1 x)) -1))) - (pass-if (n=2^ x) - (eqv? 1 (gcd (2^ x) -1))) - (pass-if (n=-2^ x) - (eqv? 1 (gcd (- (2^ x)) -1)))) - bit-widths)) + (pass-if "n = fixnum-min - 1" + (eqv? 1 (gcd -1 (- fixnum-min 1))))) - ;; Special case: gcd n n + (with-test-prefix "(fixnum-max n)" - (with-test-prefix "(n n)" + (pass-if "n = 0" + (eqv? fixnum-max (gcd fixnum-max 0))) - (for-each - (lambda (x) - (pass-if (n=2^x-1 x) - (eqv? (2^x-1 x) (gcd (2^x-1 x) (2^x-1 x)))) - (pass-if (n=-2^x+1 x) - (eqv? (2^x-1 x) (gcd (- (2^x-1 x)) (- (2^x-1 x))))) - (pass-if (n=2^ x) - (eqv? (2^ x) (gcd (2^ x) (2^ x)))) - (pass-if (n=-2^ x) - (eqv? (2^ x) (gcd (- (2^ x)) (- (2^ x)))))) - bit-widths)) + (pass-if "n = 1" + (eqv? 1 (gcd fixnum-max 1))) + + (pass-if "n = -1" + (eqv? 1 (gcd fixnum-max -1))) + + (pass-if "n = fixnum-max" + (eqv? fixnum-max (gcd fixnum-max fixnum-max))) + + (pass-if "n = fixnum-max + 1" + (eqv? 1 (gcd fixnum-max (+ fixnum-max 1)))) + + (pass-if "n = fixnum-min" + (eqv? 1 (gcd fixnum-max fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (eqv? 1 (gcd fixnum-max (- fixnum-min 1))))) + + (with-test-prefix "((+ fixnum-max 1) n)" + + (pass-if "n = 0" + (eqv? (+ fixnum-max 1) (gcd (+ fixnum-max 1) 0))) + + (pass-if "n = 1" + (eqv? 1 (gcd (+ fixnum-max 1) 1))) + + (pass-if "n = -1" + (eqv? 1 (gcd (+ fixnum-max 1) -1))) + + (pass-if "n = fixnum-max" + (eqv? 1 (gcd (+ fixnum-max 1) fixnum-max))) + + (pass-if "n = fixnum-max + 1" + (eqv? (+ fixnum-max 1) (gcd (+ fixnum-max 1) (+ fixnum-max 1)))) + + (pass-if "n = fixnum-min" + (eqv? (+ fixnum-max 1) (gcd (+ fixnum-max 1) fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (eqv? 1 (gcd (+ fixnum-max 1) (- fixnum-min 1))))) + + (with-test-prefix "(fixnum-min n)" + + (pass-if "n = 0" + (eqv? (- fixnum-min) (gcd fixnum-min 0))) + + (pass-if "n = 1" + (eqv? 1 (gcd fixnum-min 1))) + + (pass-if "n = -1" + (eqv? 1 (gcd fixnum-min -1))) + + (pass-if "n = fixnum-max" + (eqv? 1 (gcd fixnum-min fixnum-max))) + + (pass-if "n = fixnum-max + 1" + (eqv? (+ fixnum-max 1) (gcd fixnum-min (+ fixnum-max 1)))) + + (pass-if "n = fixnum-min" + (eqv? (- fixnum-min) (gcd fixnum-min fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (eqv? 1 (gcd fixnum-min (- fixnum-min 1))))) + + (with-test-prefix "((- fixnum-min 1) n)" + + (pass-if "n = 0" + (eqv? (- (- fixnum-min 1)) (gcd (- fixnum-min 1) 0))) + + (pass-if "n = 1" + (eqv? 1 (gcd (- fixnum-min 1) 1))) + + (pass-if "n = -1" + (eqv? 1 (gcd (- fixnum-min 1) -1))) + + (pass-if "n = fixnum-max" + (eqv? 1 (gcd (- fixnum-min 1) fixnum-max))) + + (pass-if "n = fixnum-max + 1" + (eqv? 1 (gcd (- fixnum-min 1) (+ fixnum-max 1)))) + + (pass-if "n = fixnum-min" + (eqv? 1 (gcd (- fixnum-min 1) fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (eqv? (- (- fixnum-min 1)) (gcd (- fixnum-min 1) (- fixnum-min 1))))) ;; Are wrong type arguments detected correctly? @@ -661,13 +844,9 @@ (with-test-prefix "<" - ;; Is documentation available? - (expect-fail "documented?" (documented? <)) - ;; Special case: 0 < n - (with-test-prefix "(< 0 n)" (pass-if "n = 0" @@ -688,20 +867,18 @@ (pass-if "n = -1.0" (not (< 0 -1.0))) - (for-each ;; FIXME: compare agains floats. - (lambda (x) - (pass-if (n=2^x-1 x) - (< 0 (2^x-1 x))) - (pass-if (n=-2^x+1 x) - (not (< 0 (- (2^x-1 x))))) - (pass-if (n=2^ x) - (< 0 (2^ x))) - (pass-if (n=-2^ x) - (not (< 0 (- (2^ x)))))) - bit-widths)) - - ;; Special case: 0.0 < n + (pass-if "n = fixnum-max" + (< 0 fixnum-max)) + (pass-if "n = fixnum-max + 1" + (< 0 (+ fixnum-max 1))) + + (pass-if "n = fixnum-min" + (not (< 0 fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (not (< 0 (- fixnum-min 1))))) + (with-test-prefix "(< 0.0 n)" (pass-if "n = 0" @@ -722,152 +899,270 @@ (pass-if "n = -1.0" (not (< 0.0 -1.0))) - (for-each ;; FIXME: compare agains floats. - (lambda (x) - (pass-if (n=2^x-1 x) - (< 0.0 (2^x-1 x))) - (pass-if (n=-2^x+1 x) - (not (< 0.0 (- (2^x-1 x))))) - (pass-if (n=2^ x) - (< 0.0 (2^ x))) - (pass-if (n=-2^ x) - (not (< 0.0 (- (2^ x)))))) - bit-widths)) - - ;; Special case: n < 0 + (pass-if "n = fixnum-max" + (< 0.0 fixnum-max)) - (with-test-prefix "(< n 0)" + (pass-if "n = fixnum-max + 1" + (< 0.0 (+ fixnum-max 1))) + + (pass-if "n = fixnum-min" + (not (< 0.0 fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (not (< 0.0 (- fixnum-min 1))))) + + (with-test-prefix "(< 1 n)" - (pass-if "n = 1" + (pass-if "n = 0" (not (< 1 0))) - (pass-if "n = 1.0" - (not (< 1.0 0))) - - (pass-if "n = -1" - (< -1 0)) - - (pass-if "n = -1.0" - (< -1.0 0)) - - (for-each ;; FIXME: compare agains floats. - (lambda (x) - (pass-if (n=2^x-1 x) - (not (< (2^x-1 x) 0))) - (pass-if (n=-2^x+1 x) - (< (- (2^x-1 x)) 0)) - (pass-if (n=2^ x) - (not (< (2^ x) 0))) - (pass-if (n=-2^ x) - (< (- (2^ x)) 0))) - bit-widths)) - - ;; Special case: n < 0.0 - - (with-test-prefix "(< n 0.0)" - - (pass-if "n = 1" + (pass-if "n = 0.0" (not (< 1 0.0))) - (pass-if "n = 1.0" - (not (< 1.0 0.0))) - - (pass-if "n = -1" - (< -1 0.0)) - - (pass-if "n = -1.0" - (< -1.0 0.0)) - - (for-each ;; FIXME: compare agains floats. - (lambda (x) - (pass-if (n=2^x-1 x) - (not (< (2^x-1 x) 0.0))) - (pass-if (n=-2^x+1 x) - (< (- (2^x-1 x)) 0.0)) - (pass-if (n=2^ x) - (not (< (2^ x) 0.0))) - (pass-if (n=-2^ x) - (< (- (2^ x)) 0.0))) - bit-widths)) - - ;; Special case: n < n - - (with-test-prefix "(< n n)" - (pass-if "n = 1" (not (< 1 1))) + (pass-if "n = 1.0" + (not (< 1 1.0))) + + (pass-if "n = -1" + (not (< 1 -1))) + + (pass-if "n = -1.0" + (not (< 1 -1.0))) + + (pass-if "n = fixnum-max" + (< 1 fixnum-max)) + + (pass-if "n = fixnum-max + 1" + (< 1 (+ fixnum-max 1))) + + (pass-if "n = fixnum-min" + (not (< 1 fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (not (< 1 (- fixnum-min 1))))) + + (with-test-prefix "(< 1.0 n)" + + (pass-if "n = 0" + (not (< 1.0 0))) + + (pass-if "n = 0.0" + (not (< 1.0 0.0))) + + (pass-if "n = 1" + (not (< 1.0 1))) + (pass-if "n = 1.0" (not (< 1.0 1.0))) + (pass-if "n = -1" + (not (< 1.0 -1))) + + (pass-if "n = -1.0" + (not (< 1.0 -1.0))) + + (pass-if "n = fixnum-max" + (< 1.0 fixnum-max)) + + (pass-if "n = fixnum-max + 1" + (< 1.0 (+ fixnum-max 1))) + + (pass-if "n = fixnum-min" + (not (< 1.0 fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (not (< 1.0 (- fixnum-min 1))))) + + (with-test-prefix "(< -1 n)" + + (pass-if "n = 0" + (< -1 0)) + + (pass-if "n = 0.0" + (< -1 0.0)) + + (pass-if "n = 1" + (< -1 1)) + + (pass-if "n = 1.0" + (< -1 1.0)) + (pass-if "n = -1" (not (< -1 -1))) (pass-if "n = -1.0" - (not (< -1.0 -1.0))) + (not (< -1 -1.0))) - (for-each ;; FIXME: compare agains floats. - (lambda (x) - (pass-if (n=2^x-1 x) - (not (< (2^x-1 x) (2^x-1 x)))) - (pass-if (n=-2^x+1 x) - (not (< (- (2^x-1 x)) (- (2^x-1 x))))) - (pass-if (n=2^ x) - (not (< (2^ x) (2^ x)))) - (pass-if (n=-2^ x) - (not (< (- (2^ x)) (- (2^ x)))))) - bit-widths)) + (pass-if "n = fixnum-max" + (< -1 fixnum-max)) - ;; Special case: n < n + 1 + (pass-if "n = fixnum-max + 1" + (< -1 (+ fixnum-max 1))) - (with-test-prefix "(< n (+ n 1))" + (pass-if "n = fixnum-min" + (not (< -1 fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (not (< -1 (- fixnum-min 1))))) + + (with-test-prefix "(< -1.0 n)" - (pass-if "n = 1" - (< 1 2)) + (pass-if "n = 0" + (< -1.0 0)) - (pass-if "n = 1.0" - (< 1.0 2.0)) - - (pass-if "n = -1" - (< -1 0)) - - (pass-if "n = -1.0" + (pass-if "n = 0.0" (< -1.0 0.0)) - (for-each ;; FIXME: compare agains floats. - (lambda (x) - (pass-if (n=2^x-1 x) - (< (2^x-1 x) (+ (2^x-1 x) 1))) - (pass-if (n=-2^x+1 x) - (< (- (2^x-1 x)) (+ (- (2^x-1 x)) 1))) - (pass-if (n=2^ x) - (< (2^ x) (+ (2^ x) 1))) - (pass-if (n=-2^ x) - (< (- (2^ x)) (+ (- (2^ x)) 1)))) - bit-widths)) - - ;; Special case: n < n - 1 - - (with-test-prefix "(< n (- n 1))" + (pass-if "n = 1" + (< -1.0 1)) + + (pass-if "n = 1.0" + (< -1.0 1.0)) (pass-if "n = -1" - (not (< -1 -2))) + (not (< -1.0 -1))) (pass-if "n = -1.0" - (not (< -1.0 -2.0))) + (not (< -1.0 -1.0))) - (for-each ;; FIXME: compare agains floats. - (lambda (x) - (pass-if (n=2^x-1 x) - (not (< (2^x-1 x) (- (2^x-1 x) 1)))) - (pass-if (n=-2^x+1 x) - (not (< (- (2^x-1 x)) (- (- (2^x-1 x)) 1)))) - (pass-if (n=2^ x) - (not (< (2^ x) (- (2^ x) 1)))) - (pass-if (n=-2^ x) - (not (< (- (2^ x)) (- (- (2^ x)) 1))))) - bit-widths)) + (pass-if "n = fixnum-max" + (< -1.0 fixnum-max)) - ;; Special case: + (pass-if "n = fixnum-max + 1" + (< -1.0 (+ fixnum-max 1))) - ) \ No newline at end of file + (pass-if "n = fixnum-min" + (not (< -1.0 fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (not (< -1.0 (- fixnum-min 1))))) + + (with-test-prefix "(< fixnum-max n)" + + (pass-if "n = 0" + (not (< fixnum-max 0))) + + (pass-if "n = 0.0" + (not (< fixnum-max 0.0))) + + (pass-if "n = 1" + (not (< fixnum-max 1))) + + (pass-if "n = 1.0" + (not (< fixnum-max 1.0))) + + (pass-if "n = -1" + (not (< fixnum-max -1))) + + (pass-if "n = -1.0" + (not (< fixnum-max -1.0))) + + (pass-if "n = fixnum-max" + (not (< fixnum-max fixnum-max))) + + (pass-if "n = fixnum-max + 1" + (< fixnum-max (+ fixnum-max 1))) + + (pass-if "n = fixnum-min" + (not (< fixnum-max fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (not (< fixnum-max (- fixnum-min 1))))) + + (with-test-prefix "(< (+ fixnum-max 1) n)" + + (pass-if "n = 0" + (not (< (+ fixnum-max 1) 0))) + + (pass-if "n = 0.0" + (not (< (+ fixnum-max 1) 0.0))) + + (pass-if "n = 1" + (not (< (+ fixnum-max 1) 1))) + + (pass-if "n = 1.0" + (not (< (+ fixnum-max 1) 1.0))) + + (pass-if "n = -1" + (not (< (+ fixnum-max 1) -1))) + + (pass-if "n = -1.0" + (not (< (+ fixnum-max 1) -1.0))) + + (pass-if "n = fixnum-max" + (not (< (+ fixnum-max 1) fixnum-max))) + + (pass-if "n = fixnum-max + 1" + (not (< (+ fixnum-max 1) (+ fixnum-max 1)))) + + (pass-if "n = fixnum-min" + (not (< (+ fixnum-max 1) fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (not (< (+ fixnum-max 1) (- fixnum-min 1))))) + + (with-test-prefix "(< fixnum-min n)" + + (pass-if "n = 0" + (< fixnum-min 0)) + + (pass-if "n = 0.0" + (< fixnum-min 0.0)) + + (pass-if "n = 1" + (< fixnum-min 1)) + + (pass-if "n = 1.0" + (< fixnum-min 1.0)) + + (pass-if "n = -1" + (< fixnum-min -1)) + + (pass-if "n = -1.0" + (< fixnum-min -1.0)) + + (pass-if "n = fixnum-max" + (< fixnum-min fixnum-max)) + + (pass-if "n = fixnum-max + 1" + (< fixnum-min (+ fixnum-max 1))) + + (pass-if "n = fixnum-min" + (not (< fixnum-min fixnum-min))) + + (pass-if "n = fixnum-min - 1" + (not (< fixnum-min (- fixnum-min 1))))) + + (with-test-prefix "(< (- fixnum-min 1) n)" + + (pass-if "n = 0" + (< (- fixnum-min 1) 0)) + + (pass-if "n = 0.0" + (< (- fixnum-min 1) 0.0)) + + (pass-if "n = 1" + (< (- fixnum-min 1) 1)) + + (pass-if "n = 1.0" + (< (- fixnum-min 1) 1.0)) + + (pass-if "n = -1" + (< (- fixnum-min 1) -1)) + + (pass-if "n = -1.0" + (< (- fixnum-min 1) -1.0)) + + (pass-if "n = fixnum-max" + (< (- fixnum-min 1) fixnum-max)) + + (pass-if "n = fixnum-max + 1" + (< (- fixnum-min 1) (+ fixnum-max 1))) + + (pass-if "n = fixnum-min" + (< (- fixnum-min 1) fixnum-min)) + + (pass-if "n = fixnum-min - 1" + (not (< (- fixnum-min 1) (- fixnum-min 1)))))) From 10288a0948382f088cfb3e81b986db627a647adc Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Thu, 18 Jan 2001 22:54:54 +0000 Subject: [PATCH 0469/2047] * ioext.c: further simplify scm_read_string_x_partial by defining a macro SCM_EBLOCK. --- libguile/ChangeLog | 5 +++++ libguile/ioext.c | 26 +++++++++++++++++--------- 2 files changed, 22 insertions(+), 9 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 3bf635e5a..572ae53ce 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-01-18 Gary Houston + + * ioext.c: further simplify scm_read_string_x_partial by defining + a macro SCM_EBLOCK. + 2001-01-18 Dirk Herrmann * gh_data.c (gh_ints2scm): Simplified using SCM_FIXABLE. diff --git a/libguile/ioext.c b/libguile/ioext.c index bf757c1ee..894982394 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -69,6 +69,22 @@ #endif +#if defined (EAGAIN) +#define SCM_MAYBE_EAGAIN || errno == EAGAIN +#else +#define SCM_MAYBE_EAGAIN +#endif + +#if defined (EWOULDBLOCK) +#define SCM_MAYBE_EWOULDBLOCK || errno == EWOULDBLOCK +#else +#define SCM_MAYBE_EWOULDBLOCK +#endif + +/* MAYBE there is EAGAIN way of defining this macro but now I EWOULDBLOCK. */ +#define SCM_EBLOCK(errno) \ + (0 SCM_MAYBE_EAGAIN SCM_MAYBE_EWOULDBLOCK) + SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0, (SCM str, SCM port_or_fdes, SCM start, SCM end), "Read characters from an fport or file descriptor into a\n" @@ -140,17 +156,9 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0, SCM_SYSCALL (chars_read = read (fdes, dest, read_len)); if (chars_read == -1) { -#if defined (EWOULDBLOCK) || defined (EAGAIN) - if ( -#if defined (EWOULDBLOCK) - errno == EWOULDBLOCK -#else - errno == EAGAIN -#endif - ) + if (SCM_EBLOCK (errno)) chars_read = 0; else -#endif SCM_SYSERROR; } else if (chars_read == 0) From 6c29a390fab934c0e37e459d2e03449dc1a8920c Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 19 Jan 2001 09:00:05 +0000 Subject: [PATCH 0470/2047] * Make the readline port input-only. --- guile-readline/ChangeLog | 5 +++++ guile-readline/readline.scm | 4 ++-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 1fad43605..4c227c692 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,8 @@ +2001-01-18 Neil Jerram + + * readline.scm (make-readline-port): Make readline port + input-only. + 2000-12-12 Dirk Herrmann * readline.scm (activate-readline): Lookup 'use-emacs-interface diff --git a/guile-readline/readline.scm b/guile-readline/readline.scm index 23adf4387..cbb0c4308 100644 --- a/guile-readline/readline.scm +++ b/guile-readline/readline.scm @@ -83,8 +83,8 @@ (set! string-index (+ 1 string-index)) res)))))) (make-soft-port - (vector write-char display #f get-character #f) - "rw")))) + (vector #f #f #f get-character #f) + "r")))) ;;; We only create one readline port. There's no point in having ;;; more, since they would all share the tty and history --- From 4567ed787c01a8a8510a5c4ad6ca24e199ffe21c Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 19 Jan 2001 17:16:52 +0000 Subject: [PATCH 0471/2047] * Applied Martin Grabmueller's fix of case's handling of 'else. --- THANKS | 1 + libguile/ChangeLog | 6 ++++++ libguile/eval.c | 3 ++- 3 files changed, 9 insertions(+), 1 deletion(-) diff --git a/THANKS b/THANKS index dbabae485..2845273c9 100644 --- a/THANKS +++ b/THANKS @@ -18,6 +18,7 @@ For fixes or providing information which led to a fix: George Caswell Chris Cramer I. N. Golubev + Martin Grabmueller Brad Knotwell Matthias Köppe Bruce Korb diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 572ae53ce..4e1bce790 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2001-01-19 Dirk Herrmann + + * eval.c (scm_m_case): The 'else' clause of a 'case' statement + now has to be the last clause, as required by R5RS. Thanks to + Martin Grabmueller for the patch. + 2001-01-18 Gary Houston * ioext.c: further simplify scm_read_string_x_partial by defining diff --git a/libguile/eval.c b/libguile/eval.c index b7cf5be11..feb7808c5 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -595,7 +595,8 @@ scm_m_case (SCM xorig, SCM env) proc = SCM_CAR (x); SCM_ASSYNT (scm_ilength (proc) >= 2, xorig, scm_s_clauses, s_case); SCM_ASSYNT (scm_ilength (SCM_CAR (proc)) >= 0 - || SCM_EQ_P (scm_sym_else, SCM_CAR (proc)), + || (SCM_EQ_P (scm_sym_else, SCM_CAR (proc)) + && SCM_NULLP (SCM_CDR (x))), xorig, scm_s_clauses, s_case); } return scm_cons (SCM_IM_CASE, cdrx); From 9d7748147efdb9d84be57817a014b4e80f13e989 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 21 Jan 2001 22:11:29 +0000 Subject: [PATCH 0472/2047] * rdelim.scm: new file implementing module (ice-9 rdelim). * ice-9.scm (scm-line-incrementors read-line! read-delimited! read-delimited read-line): moved to rdelim.scm. scm-line-incrementors is not exported. * boot-9.scm: import (ice-9 rdelim) for backwards compatibility, for now. * lineio.scm: use module (ice-9 rdelim). * Makefile.am (ice9_sources): add rdelim.scm. --- NEWS | 37 ++++++---- ice-9/ChangeLog | 11 +++ ice-9/Makefile.am | 2 +- ice-9/boot-9.scm | 154 ++--------------------------------------- ice-9/lineio.scm | 3 +- ice-9/rdelim.scm | 173 ++++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 218 insertions(+), 162 deletions(-) create mode 100644 ice-9/rdelim.scm diff --git a/NEWS b/NEWS index bc449f706..0b32f0514 100644 --- a/NEWS +++ b/NEWS @@ -8,9 +8,7 @@ Changes since Guile 1.4: * Changes to the distribution -** New modules (oop goops) etc - -The new modules +** New modules (oop goops) etc.: (oop goops) (oop goops describe) @@ -18,14 +16,8 @@ The new modules (oop goops active-slot) (oop goops composite-slot) -plus some GOOPS utility modules have been added. - -* Changes to the stand-alone interpreter - -** GOOPS has been merged into Guile - -The Guile Object Oriented Programming System has been integrated into -Guile. +The Guile Object Oriented Programming System (GOOPS) has been +integrated into Guile. Type @@ -75,6 +67,27 @@ Asking for the type of an object See further in the GOOPS tutorial available in the guile-doc distribution in info (goops.info) and texinfo formats. +** New module (ice-9 rdelim). + +This exports the following procedures which were previously defined +in the root module: + +read-line read-line! read-delimited read-delimited! +;; TODO: read-string!/partial %read-delimited! %read-line write-line + +For backwards compatibility the definitions are also imported into the +root module in this version of Guile. However you should add: + +(use-modules (ice-9 rdelim)) + +to any program which uses the definitions, since this may be removed +in in a future version. + +Alternatively, if guile-scsh is installed, the (scsh rdelim) module +can be used for similar functionality. + +* Changes to the stand-alone interpreter + ** It's now possible to create modules with controlled environments Example: @@ -283,7 +296,7 @@ current values of file descriptors 0, 1, and 2 in the parent process. There is no such concept as a weak binding any more. -** Removed constants: bignum-radix +** Removed constants: bignum-radix, scm-line-incrementors * Changes to the gh_ interface diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index dc624c644..8b10caa3e 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,14 @@ +2001-01-21 Gary Houston + + * rdelim.scm: new file implementing module (ice-9 rdelim). + * ice-9.scm (scm-line-incrementors read-line! read-delimited! + read-delimited read-line): moved to rdelim.scm. + scm-line-incrementors is not exported. + * boot-9.scm: import (ice-9 rdelim) for backwards compatibility, + for now. + * lineio.scm: use module (ice-9 rdelim). + * Makefile.am (ice9_sources): add rdelim.scm. + 2000-12-29 Dirk Herrmann * boot-9.scm (root-module-closure, scm-module-closure): Remove diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index 0cff73751..4580ed7c2 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -28,7 +28,7 @@ ice9_sources = \ format.scm getopt-long.scm hcons.scm lineio.scm ls.scm \ mapping.scm networking.scm null.scm optargs.scm poe.scm popen.scm \ posix.scm psyntax.pp psyntax.ss q.scm r4rs.scm r5rs.scm \ - receive.scm srfi-8.scm \ + rdelim.scm receive.scm srfi-8.scm \ regex.scm runq.scm safe-r5rs.scm safe.scm session.scm slib.scm \ streams.scm string-fun.scm syncase.scm tags.scm threads.scm diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index c6a48099a..d1e37185f 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -166,152 +166,6 @@ -;;; {Line and Delimited I/O} - -;;; corresponds to SCM_LINE_INCREMENTORS in libguile. -(define scm-line-incrementors "\n") - -(define (read-line! string . maybe-port) - (let* ((port (if (pair? maybe-port) - (car maybe-port) - (current-input-port)))) - (let* ((rv (%read-delimited! scm-line-incrementors - string - #t - port)) - (terminator (car rv)) - (nchars (cdr rv))) - (cond ((and (= nchars 0) - (eof-object? terminator)) - terminator) - ((not terminator) #f) - (else nchars))))) - -(define (read-delimited! delims buf . args) - (let* ((num-args (length args)) - (port (if (> num-args 0) - (car args) - (current-input-port))) - (handle-delim (if (> num-args 1) - (cadr args) - 'trim)) - (start (if (> num-args 2) - (caddr args) - 0)) - (end (if (> num-args 3) - (cadddr args) - (string-length buf)))) - (let* ((rv (%read-delimited! delims - buf - (not (eq? handle-delim 'peek)) - port - start - end)) - (terminator (car rv)) - (nchars (cdr rv))) - (cond ((or (not terminator) ; buffer filled - (eof-object? terminator)) - (if (zero? nchars) - (if (eq? handle-delim 'split) - (cons terminator terminator) - terminator) - (if (eq? handle-delim 'split) - (cons nchars terminator) - nchars))) - (else - (case handle-delim - ((trim peek) nchars) - ((concat) (string-set! buf (+ nchars start) terminator) - (+ nchars 1)) - ((split) (cons nchars terminator)) - (else (error "unexpected handle-delim value: " - handle-delim)))))))) - -(define (read-delimited delims . args) - (let* ((port (if (pair? args) - (let ((pt (car args))) - (set! args (cdr args)) - pt) - (current-input-port))) - (handle-delim (if (pair? args) - (car args) - 'trim))) - (let loop ((substrings ()) - (total-chars 0) - (buf-size 100)) ; doubled each time through. - (let* ((buf (make-string buf-size)) - (rv (%read-delimited! delims - buf - (not (eq? handle-delim 'peek)) - port)) - (terminator (car rv)) - (nchars (cdr rv)) - (join-substrings - (lambda () - (apply string-append - (reverse - (cons (if (and (eq? handle-delim 'concat) - (not (eof-object? terminator))) - (string terminator) - "") - (cons (substring buf 0 nchars) - substrings)))))) - (new-total (+ total-chars nchars))) - (cond ((not terminator) - ;; buffer filled. - (loop (cons (substring buf 0 nchars) substrings) - new-total - (* buf-size 2))) - ((eof-object? terminator) - (if (zero? new-total) - (if (eq? handle-delim 'split) - (cons terminator terminator) - terminator) - (if (eq? handle-delim 'split) - (cons (join-substrings) terminator) - (join-substrings)))) - (else - (case handle-delim - ((trim peek concat) (join-substrings)) - ((split) (cons (join-substrings) terminator)) - - - (else (error "unexpected handle-delim value: " - handle-delim))))))))) - -;;; read-line [PORT [HANDLE-DELIM]] reads a newline-terminated string -;;; from PORT. The return value depends on the value of HANDLE-DELIM, -;;; which may be one of the symbols `trim', `concat', `peek' and -;;; `split'. If it is `trim' (the default), the trailing newline is -;;; removed and the string is returned. If `concat', the string is -;;; returned with the trailing newline intact. If `peek', the newline -;;; is left in the input port buffer and the string is returned. If -;;; `split', the newline is split from the string and read-line -;;; returns a pair consisting of the truncated string and the newline. - -(define (read-line . args) - (let* ((port (if (null? args) - (current-input-port) - (car args))) - (handle-delim (if (> (length args) 1) - (cadr args) - 'trim)) - (line/delim (%read-line port)) - (line (car line/delim)) - (delim (cdr line/delim))) - (case handle-delim - ((trim) line) - ((split) line/delim) - ((concat) (if (and (string? line) (char? delim)) - (string-append line (string delim)) - line)) - ((peek) (if (char? delim) - (unread-char delim port)) - line) - (else - (error "unexpected handle-delim value: " handle-delim))))) - - ;;; {Arrays} ;;; @@ -2483,6 +2337,7 @@ (read (current-input-port)))) (define (scm-style-repl) + (letrec ( (start-gc-rt #f) (start-rt #f) @@ -2770,6 +2625,7 @@ + ;;; {Load emacs interface support if emacs option is given.} (define (load-emacs-interface) @@ -2779,14 +2635,16 @@ +;; temporary, for backwards compatibility. +(use-modules (ice-9 rdelim)) + + (define using-readline? (let ((using-readline? (make-fluid))) (make-procedure-with-setter (lambda () (fluid-ref using-readline?)) (lambda (v) (fluid-set! using-readline? v))))) -;; this is just (scm-style-repl) with a wrapper to install and remove -;; signal handlers. (define (top-repl) ;; Load emacs interface support if emacs option is given. diff --git a/ice-9/lineio.scm b/ice-9/lineio.scm index e40b89353..25711f8c3 100644 --- a/ice-9/lineio.scm +++ b/ice-9/lineio.scm @@ -20,7 +20,8 @@ -(define-module (ice-9 lineio)) +(define-module (ice-9 lineio) + :use-module (ice-9 readline)) ;;; {Line Buffering Input Ports} diff --git a/ice-9/rdelim.scm b/ice-9/rdelim.scm new file mode 100644 index 000000000..c6d6b2aa8 --- /dev/null +++ b/ice-9/rdelim.scm @@ -0,0 +1,173 @@ +;;; installed-scm-file + +;;;; Copyright (C) 1997 1999 2000 2001 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; + + +;;; Module for delimited I/O. This is similar to (scsh rdelim) but is +;;; somewhat incompatible. + +(define-module (ice-9 rdelim)) + +(export read-line read-line! read-delimited read-delimited!) +;; TODO: split the C part of this module out of libguile and into its +;; own top-level directory. +;; (export read-string!/partial %read-delimited! %read-line write-line) + +(define (read-line! string . maybe-port) + ;; corresponds to SCM_LINE_INCREMENTORS in libguile. + (define scm-line-incrementors "\n") + + (let* ((port (if (pair? maybe-port) + (car maybe-port) + (current-input-port)))) + (let* ((rv (%read-delimited! scm-line-incrementors + string + #t + port)) + (terminator (car rv)) + (nchars (cdr rv))) + (cond ((and (= nchars 0) + (eof-object? terminator)) + terminator) + ((not terminator) #f) + (else nchars))))) + +(define (read-delimited! delims buf . args) + (let* ((num-args (length args)) + (port (if (> num-args 0) + (car args) + (current-input-port))) + (handle-delim (if (> num-args 1) + (cadr args) + 'trim)) + (start (if (> num-args 2) + (caddr args) + 0)) + (end (if (> num-args 3) + (cadddr args) + (string-length buf)))) + (let* ((rv (%read-delimited! delims + buf + (not (eq? handle-delim 'peek)) + port + start + end)) + (terminator (car rv)) + (nchars (cdr rv))) + (cond ((or (not terminator) ; buffer filled + (eof-object? terminator)) + (if (zero? nchars) + (if (eq? handle-delim 'split) + (cons terminator terminator) + terminator) + (if (eq? handle-delim 'split) + (cons nchars terminator) + nchars))) + (else + (case handle-delim + ((trim peek) nchars) + ((concat) (string-set! buf (+ nchars start) terminator) + (+ nchars 1)) + ((split) (cons nchars terminator)) + (else (error "unexpected handle-delim value: " + handle-delim)))))))) + +(define (read-delimited delims . args) + (let* ((port (if (pair? args) + (let ((pt (car args))) + (set! args (cdr args)) + pt) + (current-input-port))) + (handle-delim (if (pair? args) + (car args) + 'trim))) + (let loop ((substrings ()) + (total-chars 0) + (buf-size 100)) ; doubled each time through. + (let* ((buf (make-string buf-size)) + (rv (%read-delimited! delims + buf + (not (eq? handle-delim 'peek)) + port)) + (terminator (car rv)) + (nchars (cdr rv)) + (join-substrings + (lambda () + (apply string-append + (reverse + (cons (if (and (eq? handle-delim 'concat) + (not (eof-object? terminator))) + (string terminator) + "") + (cons (substring buf 0 nchars) + substrings)))))) + (new-total (+ total-chars nchars))) + (cond ((not terminator) + ;; buffer filled. + (loop (cons (substring buf 0 nchars) substrings) + new-total + (* buf-size 2))) + ((eof-object? terminator) + (if (zero? new-total) + (if (eq? handle-delim 'split) + (cons terminator terminator) + terminator) + (if (eq? handle-delim 'split) + (cons (join-substrings) terminator) + (join-substrings)))) + (else + (case handle-delim + ((trim peek concat) (join-substrings)) + ((split) (cons (join-substrings) terminator)) + + + (else (error "unexpected handle-delim value: " + handle-delim))))))))) + +;;; read-line [PORT [HANDLE-DELIM]] reads a newline-terminated string +;;; from PORT. The return value depends on the value of HANDLE-DELIM, +;;; which may be one of the symbols `trim', `concat', `peek' and +;;; `split'. If it is `trim' (the default), the trailing newline is +;;; removed and the string is returned. If `concat', the string is +;;; returned with the trailing newline intact. If `peek', the newline +;;; is left in the input port buffer and the string is returned. If +;;; `split', the newline is split from the string and read-line +;;; returns a pair consisting of the truncated string and the newline. + +(define (read-line . args) + (let* ((port (if (null? args) + (current-input-port) + (car args))) + (handle-delim (if (> (length args) 1) + (cadr args) + 'trim)) + (line/delim (%read-line port)) + (line (car line/delim)) + (delim (cdr line/delim))) + (case handle-delim + ((trim) line) + ((split) line/delim) + ((concat) (if (and (string? line) (char? delim)) + (string-append line (string delim)) + line)) + ((peek) (if (char? delim) + (unread-char delim port)) + line) + (else + (error "unexpected handle-delim value: " handle-delim))))) From 312ae976ad5bba1b62f18a3b7c0df514df563911 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 22 Jan 2001 13:32:08 +0000 Subject: [PATCH 0473/2047] * Move all real functionality from scm_eval into inner_eval. * Avoid to copy the evaluated expression twice. --- libguile/ChangeLog | 6 ++++++ libguile/eval.c | 13 ++++++++----- 2 files changed, 14 insertions(+), 5 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 4e1bce790..09eede2ed 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2001-01-22 Dirk Herrmann + + * eval.c (inner_eval, scm_eval): Move all real functionality into + inner_eval. Avoid to copy the expression twice by inlining some + code from scm_i_eval. + 2001-01-19 Dirk Herrmann * eval.c (scm_m_case): The 'else' clause of a 'case' statement diff --git a/libguile/eval.c b/libguile/eval.c index feb7808c5..0a3ff46f7 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3827,8 +3827,13 @@ inner_eval (void *data) SCM pair = SCM_PACK (data); SCM exp = SCM_CAR (pair); SCM env = SCM_CDR (pair); - SCM result = scm_i_eval (exp, env); - return result; + SCM transformer = scm_fluid_ref (SCM_CDR (scm_system_transformer)); + + exp = scm_copy_tree (exp); + if (SCM_NIMP (transformer)) + exp = scm_apply (transformer, exp, scm_listofnull); + + return SCM_XEVAL (exp, env); } @@ -3849,17 +3854,15 @@ SCM_DEFINE (scm_eval, "eval", 2, 0, 0, "environment given by @var{environment specifier}.") #define FUNC_NAME s_scm_eval { - SCM copied_exp; SCM env_closure; SCM_VALIDATE_MODULE (2, environment); - copied_exp = scm_copy_tree (exp); env_closure = scm_top_level_env (SCM_MODULE_EVAL_CLOSURE (environment)); return scm_internal_dynamic_wind (change_environment, inner_eval, restore_environment, - (void *) SCM_UNPACK (scm_cons (copied_exp, env_closure)), + (void *) SCM_UNPACK (scm_cons (exp, env_closure)), (void *) SCM_UNPACK (scm_cons (environment, SCM_BOOL_F))); } #undef FUNC_NAME From 30ea841d0cdecb2e879e643726d94ce66bd14ddd Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 24 Jan 2001 00:02:43 +0000 Subject: [PATCH 0474/2047] * Separate the handling of OPEN flags between ports and directories. --- NEWS | 8 +++++++- RELEASE | 2 +- libguile/ChangeLog | 18 ++++++++++++++++++ libguile/filesys.c | 46 +++++++++++++++++++++++++++------------------ libguile/filesys.h | 13 ++++++++++++- libguile/validate.h | 6 +++--- 6 files changed, 69 insertions(+), 24 deletions(-) diff --git a/NEWS b/NEWS index 0b32f0514..aac239065 100644 --- a/NEWS +++ b/NEWS @@ -393,6 +393,10 @@ Use these instead of SCM_SETCHARS. Use instead of SCM_COERCE_SUBSTR. +** New macros: SCM_DIR_OPEN_P, SCM_DIR_FLAG_OPEN + +For directory objects, use these instead of SCM_OPDIRP and SCM_OPN. + ** Deprecated macros: SCM_OUTOFRANGE, SCM_NALLOC, SCM_HUP_SIGNAL, SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD, @@ -403,7 +407,8 @@ SCM_VALIDATE_NULLORROSTRING_COPY, SCM_ROLENGTH, SCM_LENGTH, SCM_HUGE_LENGTH, SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR, SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING, SCM_ROCHARS, SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS, SCM_LENGTH_MAX, SCM_GC8MARKP, -SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR, SCM_SUBR_DOC +SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR, SCM_SUBR_DOC, +SCM_OPDIRP, SCM_VALIDATE_OPDIR Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of SCM_OUTOFRANGE. Use scm_memory_error instead of SCM_NALLOC. @@ -427,6 +432,7 @@ Use SCM_SETGCMARK instead of SCM_SETGC8MARK. Use SCM_CLRGCMARK instead of SCM_CLRGC8MARK. Use SCM_TYP16 instead of SCM_GCTYP16. Use SCM_CDR instead of SCM_GCCDR. +Use SCM_DIR_OPEN_P instead of SCM_OPDIRP. ** Removed function: scm_struct_init diff --git a/RELEASE b/RELEASE index 21ffa085b..eb6db9c39 100644 --- a/RELEASE +++ b/RELEASE @@ -54,7 +54,7 @@ In release 1.6: SCM_COERCE_SUBSTR, SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING, SCM_ROCHARS, SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS, SCM_LENGTH_MAX, SCM_GC8MARKP, SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR, - SCM_SUBR_DOC + SCM_SUBR_DOC, SCM_OPDIRP, SCM_VALIDATE_OPDIR - remove scm_vector_set_length_x - remove function scm_call_catching_errors (replaced by catch functions from throw.[ch]) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 09eede2ed..ec419a2af 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,21 @@ +2001-01-24 Dirk Herrmann + + * filesys.h (SCM_DIR_FLAG_OPEN, SCM_DIR_OPEN_P): Added. + + (SCM_OPDIRP): Deprecated. + + * filesys.c (scm_opendir): Use SCM_DIR_FLAG_OPEN instead of + SCM_OPN. + + (scm_readdir, scm_rewinddir): Don't use SCM_VALIDATE_OPDIR. + Instead, give an explicit error message in case the directory is + closed. + + (scm_closedir, scm_dir_print): Rewritten to use SCM_DIR_OPEN_P + instead of SCM_OPENP and SCM_CLOSEDP. + + * validate.h (SCM_VALIDATE_OPDIR): Deprecated. + 2001-01-22 Dirk Herrmann * eval.c (inner_eval, scm_eval): Move all real functionality into diff --git a/libguile/filesys.c b/libguile/filesys.c index f9faedafe..9ea6fca10 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -673,21 +673,24 @@ SCM_DEFINE (scm_rmdir, "rmdir", 1, 0, 0, #endif + /* {Examining Directories} */ scm_bits_t scm_tc16_dir; + SCM_DEFINE (scm_directory_stream_p, "directory-stream?", 1, 0, 0, (SCM obj), "Returns a boolean indicating whether @var{object} is a directory stream\n" "as returned by @code{opendir}.") #define FUNC_NAME s_scm_directory_stream_p { - return SCM_BOOL(SCM_DIRP (obj)); + return SCM_BOOL (SCM_DIRP (obj)); } #undef FUNC_NAME + SCM_DEFINE (scm_opendir, "opendir", 1, 0, 0, (SCM dirname), "Open the directory specified by @var{path} and return a directory\n" @@ -700,7 +703,7 @@ SCM_DEFINE (scm_opendir, "opendir", 1, 0, 0, SCM_SYSCALL (ds = opendir (SCM_STRING_CHARS (dirname))); if (ds == NULL) SCM_SYSERROR; - SCM_RETURN_NEWSMOB (scm_tc16_dir | SCM_OPN, ds); + SCM_RETURN_NEWSMOB (scm_tc16_dir | SCM_DIR_FLAG_OPEN, ds); } #undef FUNC_NAME @@ -713,61 +716,68 @@ SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0, #define FUNC_NAME s_scm_readdir { struct dirent *rdent; - SCM_VALIDATE_OPDIR (1,port); + + SCM_VALIDATE_DIR (1, port); + if (!SCM_DIR_OPEN_P (port)) + SCM_MISC_ERROR ("Directory ~S is not open.", SCM_LIST1 (port)); + errno = 0; SCM_SYSCALL (rdent = readdir ((DIR *) SCM_CELL_WORD_1 (port))); if (errno != 0) SCM_SYSERROR; + return (rdent ? scm_makfromstr (rdent->d_name, NAMLEN (rdent), 0) : SCM_EOF_VAL); } #undef FUNC_NAME - SCM_DEFINE (scm_rewinddir, "rewinddir", 1, 0, 0, (SCM port), "Reset the directory port @var{stream} so that the next call to\n" "@code{readdir} will return the first directory entry.") #define FUNC_NAME s_scm_rewinddir { - SCM_VALIDATE_OPDIR (1,port); + SCM_VALIDATE_DIR (1, port); + if (!SCM_DIR_OPEN_P (port)) + SCM_MISC_ERROR ("Directory ~S is not open.", SCM_LIST1 (port)); + rewinddir ((DIR *) SCM_CELL_WORD_1 (port)); + return SCM_UNSPECIFIED; } #undef FUNC_NAME - SCM_DEFINE (scm_closedir, "closedir", 1, 0, 0, (SCM port), "Close the directory stream @var{stream}.\n" "The return value is unspecified.") #define FUNC_NAME s_scm_closedir { - int sts; + SCM_VALIDATE_DIR (1, port); - SCM_VALIDATE_DIR (1,port); - if (SCM_CLOSEDP (port)) + if (SCM_DIR_OPEN_P (port)) { - return SCM_UNSPECIFIED; + int sts; + + SCM_SYSCALL (sts = closedir ((DIR *) SCM_CELL_WORD_1 (port))); + if (sts != 0) + SCM_SYSERROR; + + SCM_SET_CELL_WORD_0 (port, scm_tc16_dir); } - SCM_SYSCALL (sts = closedir ((DIR *) SCM_CELL_WORD_1 (port))); - if (sts != 0) - SCM_SYSERROR; - SCM_SET_CELL_WORD_0 (port, scm_tc16_dir); + return SCM_UNSPECIFIED; } #undef FUNC_NAME - - static int scm_dir_print (SCM exp, SCM port, scm_print_state *pstate) { scm_puts ("#<", port); - if (SCM_CLOSEDP (exp)) + if (!SCM_DIR_OPEN_P (exp)) scm_puts ("closed: ", port); scm_puts ("directory stream ", port); scm_intprint (SCM_CELL_WORD_1 (exp), 16, port); @@ -779,7 +789,7 @@ scm_dir_print (SCM exp, SCM port, scm_print_state *pstate) static scm_sizet scm_dir_free (SCM p) { - if (SCM_OPENP (p)) + if (SCM_DIR_OPEN_P (p)) closedir ((DIR *) SCM_CELL_WORD_1 (p)); return 0; } diff --git a/libguile/filesys.h b/libguile/filesys.h index 67bbc74bf..c71d844f2 100644 --- a/libguile/filesys.h +++ b/libguile/filesys.h @@ -53,8 +53,11 @@ extern scm_bits_t scm_tc16_dir; + +#define SCM_DIR_FLAG_OPEN (1L << 16) + #define SCM_DIRP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_dir)) -#define SCM_OPDIRP(x) (!SCM_IMP (x) && (SCM_CELL_WORD_0 (x) == (scm_tc16_dir | SCM_OPN))) +#define SCM_DIR_OPEN_P(x) (SCM_CELL_WORD_0 (x) & SCM_DIR_FLAG_OPEN) @@ -90,6 +93,14 @@ extern SCM scm_basename (SCM filename, SCM suffix); extern void scm_init_filesys (void); + + +#if (SCM_DEBUG_DEPRECATED == 0) + +#define SCM_OPDIRP(x) (SCM_DIRP (x) && (SCM_DIR_OPEN_P (x))) + +#endif /* SCM_DEBUG_DEPRECATED == 0 */ + #endif /* FILESYSH */ /* diff --git a/libguile/validate.h b/libguile/validate.h index d44d36c5a..2212c273e 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -1,4 +1,4 @@ -/* $Id: validate.h,v 1.24 2001-01-08 23:10:06 ghouston Exp $ */ +/* $Id: validate.h,v 1.25 2001-01-24 00:02:43 dirk Exp $ */ /* Copyright (C) 1999, 2000 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify @@ -337,8 +337,6 @@ #define SCM_VALIDATE_RGXP(pos, a) SCM_MAKE_VALIDATE (pos, a, RGXP) -#define SCM_VALIDATE_OPDIR(pos, port) SCM_MAKE_VALIDATE (pos, port, OPDIRP) - #define SCM_VALIDATE_DIR(pos, port) SCM_MAKE_VALIDATE (pos, port, DIRP) #define SCM_VALIDATE_PORT(pos, port) SCM_MAKE_VALIDATE (pos, port, PORTP) @@ -437,6 +435,8 @@ scm_misc_error (FUNC_NAME, "argument is a read-only string", str); \ } while (0) +#define SCM_VALIDATE_OPDIR(pos, port) SCM_MAKE_VALIDATE (pos, port, OPDIRP) + #endif /* SCM_DEBUG_DEPRECATED == 0 */ #endif From f1e06a96a26f12359f62190868630bf6b5811d43 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 24 Jan 2001 01:26:44 +0000 Subject: [PATCH 0475/2047] * eval.c (SCM_APPLY): Added # args check for application of procedures with arity 3. (Thanks to Anders Holst.) --- THANKS | 1 + libguile/ChangeLog | 5 +++++ libguile/eval.c | 6 +++++- 3 files changed, 11 insertions(+), 1 deletion(-) diff --git a/THANKS b/THANKS index 2845273c9..1b3ca3414 100644 --- a/THANKS +++ b/THANKS @@ -19,6 +19,7 @@ For fixes or providing information which led to a fix: Chris Cramer I. N. Golubev Martin Grabmueller + Andres Holst Brad Knotwell Matthias Köppe Bruce Korb diff --git a/libguile/ChangeLog b/libguile/ChangeLog index ec419a2af..e29d442d7 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-01-23 Mikael Djurfeldt + + * eval.c (SCM_APPLY): Added # args check for application of + procedures with arity 3. (Thanks to Anders Holst.) + 2001-01-24 Dirk Herrmann * filesys.h (SCM_DIR_FLAG_OPEN, SCM_DIR_OPEN_P): Added. diff --git a/libguile/eval.c b/libguile/eval.c index 0a3ff46f7..62bef0b4b 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 96, 97, 98, 99, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001 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 @@ -3338,6 +3338,10 @@ tail: RETURN (arg1) } case scm_tc7_subr_3: + SCM_ASRTGO (SCM_NNULLP (args) + && SCM_NNULLP (SCM_CDR (args)) + && SCM_NULLP (SCM_CDDR (args)), + wrongnumargs); RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CAR (SCM_CDR (args)))) case scm_tc7_lsubr: #ifdef DEVAL From e40a4095d60261f10850b8ef7b11b46bac300f44 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 24 Jan 2001 15:58:46 +0000 Subject: [PATCH 0476/2047] * Make sure that scm_display_error validates its port argument. --- libguile/ChangeLog | 11 +++++++++++ libguile/backtrace.c | 25 +++++++++++++++++++++---- libguile/backtrace.h | 1 + libguile/throw.c | 2 +- 4 files changed, 34 insertions(+), 5 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index e29d442d7..586663225 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2001-01-24 Dirk Herrmann + + * backtrace.[ch] (scm_i_display_error): New function. + + * backtrace.c (scm_display_error): Added parameter check and + extracted the core functionality into function + scm_i_display_error. + + * throw.c (handler_message): Call scm_i_display_error to display + the error message. + 2001-01-23 Mikael Djurfeldt * eval.c (SCM_APPLY): Added # args check for application of diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 9b279e15a..67d8e2a27 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -219,10 +219,14 @@ display_error_handler (struct display_error_handler_data *data, return SCM_UNSPECIFIED; } -SCM_DEFINE (scm_display_error, "display-error", 6, 0, 0, - (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest), -"") -#define FUNC_NAME s_scm_display_error + +/* The function scm_i_display_error prints out a detailed error message. This + * function will be called directly within libguile to signal error messages. + * No parameter checks will be performed by scm_i_display_error. Thus, User + * code should rather use the function scm_display_error. + */ +void +scm_i_display_error (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest) { struct display_error_args a; struct display_error_handler_data data; @@ -237,10 +241,23 @@ SCM_DEFINE (scm_display_error, "display-error", 6, 0, 0, scm_internal_catch (SCM_BOOL_T, (scm_catch_body_t) display_error_body, &a, (scm_catch_handler_t) display_error_handler, &data); +} + + +SCM_DEFINE (scm_display_error, "display-error", 6, 0, 0, + (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest), + "") +#define FUNC_NAME s_scm_display_error +{ + SCM_VALIDATE_OUTPUT_PORT (2, port); + + scm_i_display_error (stack, port, subr, message, args, rest); + return SCM_UNSPECIFIED; } #undef FUNC_NAME + typedef struct { int level; int length; diff --git a/libguile/backtrace.h b/libguile/backtrace.h index 49e5475e8..68f85a2c7 100644 --- a/libguile/backtrace.h +++ b/libguile/backtrace.h @@ -52,6 +52,7 @@ extern SCM scm_the_last_stack_fluid; void scm_display_error_message (SCM message, SCM args, SCM port); +void scm_i_display_error (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest); SCM scm_display_error (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest); SCM scm_display_application (SCM frame, SCM port, SCM indent); SCM scm_display_backtrace (SCM stack, SCM port, SCM first, SCM depth); diff --git a/libguile/throw.c b/libguile/throw.c index 60d5bc9cc..faf2040ab 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -434,7 +434,7 @@ handler_message (void *handler_data, SCM tag, SCM args) scm_display_backtrace (stack, p, SCM_UNDEFINED, SCM_UNDEFINED); scm_newline (p); } - scm_display_error (stack, p, subr, message, parts, rest); + scm_i_display_error (stack, p, subr, message, parts, rest); } else { From ed6a2db9d7cd31d0b7483c5c7d6803e226439efb Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 24 Jan 2001 16:06:20 +0000 Subject: [PATCH 0477/2047] * Ooops: Forgot to credit Neil for the bug report. --- THANKS | 1 + libguile/ChangeLog | 3 +++ 2 files changed, 4 insertions(+) diff --git a/THANKS b/THANKS index 1b3ca3414..14825bf91 100644 --- a/THANKS +++ b/THANKS @@ -20,6 +20,7 @@ For fixes or providing information which led to a fix: I. N. Golubev Martin Grabmueller Andres Holst + Neil Jerram Brad Knotwell Matthias Köppe Bruce Korb diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 586663225..3fa5ceda2 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,8 @@ 2001-01-24 Dirk Herrmann + This patch modifies scm_display_error to perform parameter + checking. Thanks to Neil Jerram for the bug report. + * backtrace.[ch] (scm_i_display_error): New function. * backtrace.c (scm_display_error): Added parameter check and From 3ba5a6c2f2be7ee559f336d96f923e490b4d145b Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 24 Jan 2001 18:07:29 +0000 Subject: [PATCH 0478/2047] * Make sure that parameter errors are reported correctly. Thanks to Martin Grabmueller for sending this patch. --- libguile/ChangeLog | 20 +++++++++++ libguile/strorder.c | 82 ++++++++++++++++++++++++++++++++------------- 2 files changed, 79 insertions(+), 23 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 3fa5ceda2..66e913e43 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,23 @@ +2001-01-24 Dirk Herrmann + + This patch was sent by Martin Grabmueller and makes sure that + parameter errors are reported correctly by the lexicographic + ordering predicates. + + * strorder.c (string_less_p, string_ci_less_p): New functions. + + (scm_string_less_p, scm_string_ci_less_p): Extracted the core + functionality into string_less_p, string_ci_less_p respectively. + The remaining code is just a wrapper to do the parameter + checking. + + (scm_string_leq_p, scm_string_gr_p, scm_string_geq_p): Check the + parameters and call string_less_p instead of scm_string_less_p. + + (scm_string_ci_leq_p, scm_string_ci_gr_p, scm_string_ci_geq_p): + Check the parameters and call string_less_ci_p instead of + scm_string_ci_less_p. + 2001-01-24 Dirk Herrmann This patch modifies scm_display_error to perform parameter diff --git a/libguile/strorder.c b/libguile/strorder.c index 815488a92..adea5de92 100644 --- a/libguile/strorder.c +++ b/libguile/strorder.c @@ -124,18 +124,14 @@ SCM_DEFINE1 (scm_string_ci_equal_p, "string-ci=?", scm_tc7_rpsubr, #undef FUNC_NAME -SCM_DEFINE1 (scm_string_less_p, "string?", scm_tc7_rpsubr, "is lexicographically greater than @var{s2}. (r5rs)") #define FUNC_NAME s_scm_string_gr_p { - return scm_string_less_p (s2, s1); + SCM_VALIDATE_STRING (1, s1); + SCM_VALIDATE_STRING (2, s2); + + return string_less_p (s2, s1); } #undef FUNC_NAME @@ -181,24 +196,22 @@ SCM_DEFINE1 (scm_string_geq_p, "string>=?", scm_tc7_rpsubr, "is lexicographically greater than or equal to @var{s2}. (r5rs)") #define FUNC_NAME s_scm_string_geq_p { - return SCM_BOOL_NOT (scm_string_less_p (s1, s2)); + SCM_VALIDATE_STRING (1, s1); + SCM_VALIDATE_STRING (2, s2); + + return SCM_BOOL_NOT (string_less_p (s1, s2)); } #undef FUNC_NAME -SCM_DEFINE1 (scm_string_ci_less_p, "string-ci?", scm_tc7_rpsubr, "@var{s2} regardless of case. (r5rs)") #define FUNC_NAME s_scm_string_ci_gr_p { - return scm_string_ci_less_p (s2, s1); + SCM_VALIDATE_STRING (1, s1); + SCM_VALIDATE_STRING (2, s2); + + return string_ci_less_p (s2, s1); } #undef FUNC_NAME @@ -247,7 +280,10 @@ SCM_DEFINE1 (scm_string_ci_geq_p, "string-ci>=?", scm_tc7_rpsubr, "or equal to @var{s2} regardless of case. (r5rs)") #define FUNC_NAME s_scm_string_ci_geq_p { - return SCM_BOOL_NOT (scm_string_ci_less_p (s1, s2)); + SCM_VALIDATE_STRING (1, s1); + SCM_VALIDATE_STRING (2, s2); + + return SCM_BOOL_NOT (string_ci_less_p (s1, s2)); } #undef FUNC_NAME From 1c8cbd62c5d9e8358cb5e5e4ce22f555a0995231 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Wed, 24 Jan 2001 21:31:39 +0000 Subject: [PATCH 0479/2047] *** empty log message *** --- NEWS | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/NEWS b/NEWS index aac239065..813f3ac4a 100644 --- a/NEWS +++ b/NEWS @@ -70,18 +70,18 @@ distribution in info (goops.info) and texinfo formats. ** New module (ice-9 rdelim). This exports the following procedures which were previously defined -in the root module: +in the default environment: -read-line read-line! read-delimited read-delimited! -;; TODO: read-string!/partial %read-delimited! %read-line write-line +read-line read-line! read-delimited read-delimited! %read-delimited! +%read-line write-line -For backwards compatibility the definitions are also imported into the -root module in this version of Guile. However you should add: +For backwards compatibility the definitions are still imported into the +default environment in this version of Guile. However you should add: (use-modules (ice-9 rdelim)) -to any program which uses the definitions, since this may be removed -in in a future version. +to any program which uses the definitions, since this may change in +future. Alternatively, if guile-scsh is installed, the (scsh rdelim) module can be used for similar functionality. From 6d36532c1c49cdb353c63275625c8343484107e9 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Wed, 24 Jan 2001 21:45:09 +0000 Subject: [PATCH 0480/2047] * boot-9.scm: don't import (ice-9 rdelim) here. it's done in C for now. * rdelim.scm: export the C primitives too. * documentation.scm: use (ice-9 rdelim). * filesys.c (scm_link): docstring fix. * fports.h (scm_setfileno): obsolete declaration removed. * posix.c: bogus popen declaration removed. * rdelim.c: new file, split from ioext.c with new proc scm_init_rdelim. * rdelim.h: new file. * Makefile.am: add rdelim.c and related files. * init.c: call scm_init_rdelim. include rdelim.h. --- ice-9/ChangeLog | 7 + ice-9/boot-9.scm | 5 +- ice-9/documentation.scm | 1 + ice-9/rdelim.scm | 10 +- libguile/ChangeLog | 11 ++ libguile/filesys.c | 12 +- libguile/ioext.c | 233 +----------------------------- libguile/ioext.h | 6 +- libguile/posix.c | 1 - libguile/rdelim.c | 311 ++++++++++++++++++++++++++++++++++++++++ libguile/rdelim.h | 61 ++++++++ 11 files changed, 407 insertions(+), 251 deletions(-) create mode 100644 libguile/rdelim.c create mode 100644 libguile/rdelim.h diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 8b10caa3e..e4da0a6b0 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,10 @@ +2001-01-24 Gary Houston + + * boot-9.scm: don't import (ice-9 rdelim) here. it's done + in C for now. + * rdelim.scm: export the C primitives too. + * documentation.scm: use (ice-9 rdelim). + 2001-01-21 Gary Houston * rdelim.scm: new file implementing module (ice-9 rdelim). diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index d1e37185f..c929c0617 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -2635,10 +2635,6 @@ -;; temporary, for backwards compatibility. -(use-modules (ice-9 rdelim)) - - (define using-readline? (let ((using-readline? (make-fluid))) (make-procedure-with-setter @@ -2723,3 +2719,4 @@ (define-module (guile)) (append! %load-path (cons "." ())) + diff --git a/ice-9/documentation.scm b/ice-9/documentation.scm index 3a7f1c24f..5ea3ecd84 100644 --- a/ice-9/documentation.scm +++ b/ice-9/documentation.scm @@ -17,6 +17,7 @@ ;;;; (define-module (ice-9 documentation) + :use-module (ice-9 rdelim) :no-backtrace) diff --git a/ice-9/rdelim.scm b/ice-9/rdelim.scm index c6d6b2aa8..9d961a0af 100644 --- a/ice-9/rdelim.scm +++ b/ice-9/rdelim.scm @@ -1,6 +1,6 @@ ;;; installed-scm-file -;;;; Copyright (C) 1997 1999 2000 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 1997, 1999, 2000, 2001 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 @@ -19,15 +19,13 @@ ;;;; -;;; Module for delimited I/O. This is similar to (scsh rdelim) but is -;;; somewhat incompatible. +;;; This is the Scheme part of the module for delimited I/O. It's +;;; similar to (scsh rdelim) but somewhat incompatible. (define-module (ice-9 rdelim)) (export read-line read-line! read-delimited read-delimited!) -;; TODO: split the C part of this module out of libguile and into its -;; own top-level directory. -;; (export read-string!/partial %read-delimited! %read-line write-line) +(export %read-delimited! %read-line write-line) ; C (define (read-line! string . maybe-port) ;; corresponds to SCM_LINE_INCREMENTORS in libguile. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 66e913e43..fb15ec74f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2001-01-24 Gary Houston + + * filesys.c (scm_link): docstring fix. + * fports.h (scm_setfileno): obsolete declaration removed. + * posix.c: bogus popen declaration removed. + + * rdelim.c: new file, split from ioext.c. + * rdelim.h: new file, split from ioext.h + * Makefile.am: add rdelim.c and related files. + * init.c: call scm_init_rdelim. include rdelim.h. + 2001-01-24 Dirk Herrmann This patch was sent by Martin Grabmueller and makes sure that diff --git a/libguile/filesys.c b/libguile/filesys.c index 9ea6fca10..1b4fe2b68 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -557,9 +557,10 @@ SCM_DEFINE (scm_stat, "stat", 1, 0, 0, SCM_DEFINE (scm_link, "link", 2, 0, 0, (SCM oldpath, SCM newpath), - "Creates a new name @var{path-to} in the file system for the file\n" - "named by @var{path-from}. If @var{path-from} is a symbolic link, the\n" - "link may or may not be followed depending on the system.") + "Creates a new name @var{newpath} in the file system for the\n" + "file named by @var{oldpath}. If @var{oldpath} is a symbolic\n" + "link, the link may or may not be followed depending on the\n" + "system.") #define FUNC_NAME s_scm_link { int val; @@ -568,7 +569,8 @@ SCM_DEFINE (scm_link, "link", 2, 0, 0, SCM_STRING_COERCE_0TERMINATION_X (oldpath); SCM_VALIDATE_STRING (2, newpath); SCM_STRING_COERCE_0TERMINATION_X (newpath); - SCM_SYSCALL (val = link (SCM_STRING_CHARS (oldpath), SCM_STRING_CHARS (newpath))); + SCM_SYSCALL (val = link (SCM_STRING_CHARS (oldpath), + SCM_STRING_CHARS (newpath))); if (val != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; @@ -579,7 +581,7 @@ SCM_DEFINE (scm_link, "link", 2, 0, 0, SCM_DEFINE (scm_rename, "rename-file", 2, 0, 0, (SCM oldname, SCM newname), - "Renames the file specified by @var{path-from} to @var{path-to}.\n" + "Renames the file specified by @var{oldname} to @var{newname}.\n" "The return value is unspecified.") #define FUNC_NAME s_scm_rename { diff --git a/libguile/ioext.c b/libguile/ioext.c index 894982394..c3d976964 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -44,20 +44,14 @@ - -#include #include "libguile/_scm.h" -#include "libguile/ports.h" -#include "libguile/read.h" +#include "libguile/ioext.h" #include "libguile/fports.h" -#include "libguile/unif.h" -#include "libguile/chars.h" #include "libguile/feature.h" +#include "libguile/ports.h" #include "libguile/root.h" #include "libguile/strings.h" - #include "libguile/validate.h" -#include "libguile/ioext.h" #include @@ -168,227 +162,6 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0, - (SCM delims, SCM str, SCM gobble, SCM port, SCM start, SCM end), - "Read characters from @var{port} into @var{str} until one of the\n" - "characters in the @var{delims} string is encountered. If @var{gobble}\n" - "is true, discard the delimiter character; otherwise, leave it\n" - "in the input stream for the next read.\n" - "If @var{port} is not specified, use the value of\n" - "@code{(current-input-port)}. If @var{start} or @var{end} are specified,\n" - "store data only into the substring of @var{str} bounded by @var{start}\n" - "and @var{end} (which default to the beginning and end of the string,\n" - "respectively).\n\n" - "Return a pair consisting of the delimiter that terminated the string and\n" - "the number of characters read. If reading stopped at the end of file,\n" - "the delimiter returned is the @var{eof-object}; if the string was filled\n" - "without encountering a delimiter, this value is @var{#f}.") -#define FUNC_NAME s_scm_read_delimited_x -{ - long j; - char *buf; - long cstart; - long cend; - int c; - char *cdelims; - int num_delims; - - SCM_VALIDATE_STRING_COPY (1, delims, cdelims); - num_delims = SCM_STRING_LENGTH (delims); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, str, buf, 5, start, cstart, - 6, end, cend); - if (SCM_UNBNDP (port)) - port = scm_cur_inp; - else - SCM_VALIDATE_OPINPORT (4,port); - - for (j = cstart; j < cend; j++) - { - int k; - - c = scm_getc (port); - for (k = 0; k < num_delims; k++) - { - if (cdelims[k] == c) - { - if (SCM_FALSEP (gobble)) - scm_ungetc (c, port); - - return scm_cons (SCM_MAKE_CHAR (c), - scm_long2num (j - cstart)); - } - } - if (c == EOF) - return scm_cons (SCM_EOF_VAL, - scm_long2num (j - cstart)); - - buf[j] = c; - } - return scm_cons (SCM_BOOL_F, scm_long2num (j - cstart)); -} -#undef FUNC_NAME - -static unsigned char * -scm_do_read_line (SCM port, int *len_p) -{ - scm_port *pt = SCM_PTAB_ENTRY (port); - unsigned char *end; - - /* I thought reading lines was simple. Mercy me. */ - - /* The common case: the buffer contains a complete line. - This needs to be fast. */ - if ((end = memchr (pt->read_pos, '\n', (pt->read_end - pt->read_pos))) - != 0) - { - int buf_len = (end + 1) - pt->read_pos; - /* Allocate a buffer of the perfect size. */ - unsigned char *buf = scm_must_malloc (buf_len + 1, "%read-line"); - - memcpy (buf, pt->read_pos, buf_len); - pt->read_pos += buf_len; - - buf[buf_len] = '\0'; - - *len_p = buf_len; - return buf; - } - - /* The buffer contains no newlines. */ - { - /* When live, len is always the number of characters in the - current buffer that are part of the current line. */ - int len = (pt->read_end - pt->read_pos); - int buf_size = (len < 50) ? 60 : len * 2; - /* Invariant: buf always has buf_size + 1 characters allocated; - the `+ 1' is for the final '\0'. */ - unsigned char *buf = scm_must_malloc (buf_size + 1, "%read-line"); - int buf_len = 0; - - for (;;) - { - if (buf_len + len > buf_size) - { - int new_size = (buf_len + len) * 2; - buf = scm_must_realloc (buf, buf_size + 1, new_size + 1, - "%read-line"); - buf_size = new_size; - } - - /* Copy what we've got out of the port, into our buffer. */ - memcpy (buf + buf_len, pt->read_pos, len); - buf_len += len; - pt->read_pos += len; - - /* If we had seen a newline, we're done now. */ - if (end) - break; - - /* Get more characters. */ - if (scm_fill_input (port) == EOF) - { - /* If we're missing a final newline in the file, return - what we did get, sans newline. */ - if (buf_len > 0) - break; - - free (buf); - return 0; - } - - /* Search the buffer for newlines. */ - if ((end = memchr (pt->read_pos, '\n', - (len = (pt->read_end - pt->read_pos)))) - != 0) - len = (end - pt->read_pos) + 1; - } - - /* I wonder how expensive this realloc is. */ - buf = scm_must_realloc (buf, buf_size + 1, buf_len + 1, "%read-line"); - buf[buf_len] = '\0'; - *len_p = buf_len; - return buf; - } -} - - -/* - * %read-line - * truncates any terminating newline from its input, and returns - * a cons of the string read and its terminating character. Doing - * so makes it easy to implement the hairy `read-line' options - * efficiently in Scheme. - */ - -SCM_DEFINE (scm_read_line, "%read-line", 0, 1, 0, - (SCM port), - "Read a newline-terminated line from @var{port}, allocating storage as\n" - "necessary. The newline terminator (if any) is removed from the string,\n" - "and a pair consisting of the line and its delimiter is returned. The\n" - "delimiter may be either a newline or the @var{eof-object}; if\n" - "@code{%read-line} is called at the end of file, it returns the pair\n" - "@code{(# . #)}.") -#define FUNC_NAME s_scm_read_line -{ - scm_port *pt; - char *s; - int slen; - SCM line, term; - - if (SCM_UNBNDP (port)) - port = scm_cur_inp; - SCM_VALIDATE_OPINPORT (1,port); - - pt = SCM_PTAB_ENTRY (port); - if (pt->rw_active == SCM_PORT_WRITE) - scm_ptobs[SCM_PTOBNUM (port)].flush (port); - - s = (char *) scm_do_read_line (port, &slen); - - if (s == NULL) - term = line = SCM_EOF_VAL; - else - { - if (s[slen-1] == '\n') - { - term = SCM_MAKE_CHAR ('\n'); - s[slen-1] = '\0'; - line = scm_take_str (s, slen-1); - scm_done_malloc (-1); - SCM_INCLINE (port); - } - else - { - /* Fix: we should check for eof on the port before assuming this. */ - term = SCM_EOF_VAL; - line = scm_take_str (s, slen); - SCM_COL (port) += slen; - } - } - - if (pt->rw_random) - pt->rw_active = SCM_PORT_READ; - - return scm_cons (line, term); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_write_line, "write-line", 1, 1, 0, - (SCM obj, SCM port), - "Display @var{obj} and a newline character to @var{port}. If @var{port}\n" - "is not specified, @code{(current-output-port)} is used. This function\n" - "is equivalent to:\n\n" - "@smalllisp\n" - "(display obj [port])\n" - "(newline [port])\n" - "@end smalllisp") -#define FUNC_NAME s_scm_write_line -{ - scm_display (obj, port); - return scm_newline (port); -} -#undef FUNC_NAME - SCM_DEFINE (scm_ftell, "ftell", 1, 0, 0, (SCM object), "Returns an integer representing the current position of @var{fd/port},\n" diff --git a/libguile/ioext.h b/libguile/ioext.h index 579da70e6..36f0ac49e 100644 --- a/libguile/ioext.h +++ b/libguile/ioext.h @@ -2,7 +2,7 @@ #ifndef IOEXTH #define IOEXTH -/* Copyright (C) 1995, 1996, 1997, 1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001 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 @@ -50,10 +50,6 @@ extern SCM scm_read_string_x_partial (SCM str, SCM port_or_fdes, SCM start, SCM end); -extern SCM scm_read_delimited_x (SCM delims, SCM buf, SCM gobble, SCM port, - SCM offset, SCM length); -extern SCM scm_read_line (SCM port); -extern SCM scm_write_line (SCM obj, SCM port); extern SCM scm_ftell (SCM object); extern SCM scm_redirect_port (SCM into_pt, SCM from_pt); extern SCM scm_dup_to_fdes (SCM fd_or_port, SCM newfd); diff --git a/libguile/posix.c b/libguile/posix.c index a8e88fc31..cf8146b67 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -100,7 +100,6 @@ extern char *ttyname(); #include -extern FILE *popen (); extern char ** environ; #include diff --git a/libguile/rdelim.c b/libguile/rdelim.c new file mode 100644 index 000000000..f08df3c92 --- /dev/null +++ b/libguile/rdelim.c @@ -0,0 +1,311 @@ +/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001 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 + * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + + * This is the C part of the module for delimited I/O. It's + * similar to (scsh rdelim) but somewhat incompatible. */ + +#include "libguile/_scm.h" + +#include + +#ifdef HAVE_STRING_H +#include +#endif + +#include "libguile/chars.h" +#include "libguile/modules.h" +#include "libguile/ports.h" +#include "libguile/rdelim.h" +#include "libguile/root.h" +#include "libguile/strings.h" +#include "libguile/strports.h" +#include "libguile/validate.h" + +SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0, + (SCM delims, SCM str, SCM gobble, SCM port, SCM start, SCM end), + "Read characters from @var{port} into @var{str} until one of the\n" + "characters in the @var{delims} string is encountered. If @var{gobble}\n" + "is true, discard the delimiter character; otherwise, leave it\n" + "in the input stream for the next read.\n" + "If @var{port} is not specified, use the value of\n" + "@code{(current-input-port)}. If @var{start} or @var{end} are specified,\n" + "store data only into the substring of @var{str} bounded by @var{start}\n" + "and @var{end} (which default to the beginning and end of the string,\n" + "respectively).\n\n" + "Return a pair consisting of the delimiter that terminated the string and\n" + "the number of characters read. If reading stopped at the end of file,\n" + "the delimiter returned is the @var{eof-object}; if the string was filled\n" + "without encountering a delimiter, this value is @var{#f}.") +#define FUNC_NAME s_scm_read_delimited_x +{ + long j; + char *buf; + long cstart; + long cend; + int c; + char *cdelims; + int num_delims; + + SCM_VALIDATE_STRING_COPY (1, delims, cdelims); + num_delims = SCM_STRING_LENGTH (delims); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, str, buf, 5, start, cstart, + 6, end, cend); + if (SCM_UNBNDP (port)) + port = scm_cur_inp; + else + SCM_VALIDATE_OPINPORT (4,port); + + for (j = cstart; j < cend; j++) + { + int k; + + c = scm_getc (port); + for (k = 0; k < num_delims; k++) + { + if (cdelims[k] == c) + { + if (SCM_FALSEP (gobble)) + scm_ungetc (c, port); + + return scm_cons (SCM_MAKE_CHAR (c), + scm_long2num (j - cstart)); + } + } + if (c == EOF) + return scm_cons (SCM_EOF_VAL, + scm_long2num (j - cstart)); + + buf[j] = c; + } + return scm_cons (SCM_BOOL_F, scm_long2num (j - cstart)); +} +#undef FUNC_NAME + +static unsigned char * +scm_do_read_line (SCM port, int *len_p) +{ + scm_port *pt = SCM_PTAB_ENTRY (port); + unsigned char *end; + + /* I thought reading lines was simple. Mercy me. */ + + /* The common case: the buffer contains a complete line. + This needs to be fast. */ + if ((end = memchr (pt->read_pos, '\n', (pt->read_end - pt->read_pos))) + != 0) + { + int buf_len = (end + 1) - pt->read_pos; + /* Allocate a buffer of the perfect size. */ + unsigned char *buf = scm_must_malloc (buf_len + 1, "%read-line"); + + memcpy (buf, pt->read_pos, buf_len); + pt->read_pos += buf_len; + + buf[buf_len] = '\0'; + + *len_p = buf_len; + return buf; + } + + /* The buffer contains no newlines. */ + { + /* When live, len is always the number of characters in the + current buffer that are part of the current line. */ + int len = (pt->read_end - pt->read_pos); + int buf_size = (len < 50) ? 60 : len * 2; + /* Invariant: buf always has buf_size + 1 characters allocated; + the `+ 1' is for the final '\0'. */ + unsigned char *buf = scm_must_malloc (buf_size + 1, "%read-line"); + int buf_len = 0; + + for (;;) + { + if (buf_len + len > buf_size) + { + int new_size = (buf_len + len) * 2; + buf = scm_must_realloc (buf, buf_size + 1, new_size + 1, + "%read-line"); + buf_size = new_size; + } + + /* Copy what we've got out of the port, into our buffer. */ + memcpy (buf + buf_len, pt->read_pos, len); + buf_len += len; + pt->read_pos += len; + + /* If we had seen a newline, we're done now. */ + if (end) + break; + + /* Get more characters. */ + if (scm_fill_input (port) == EOF) + { + /* If we're missing a final newline in the file, return + what we did get, sans newline. */ + if (buf_len > 0) + break; + + free (buf); + return 0; + } + + /* Search the buffer for newlines. */ + if ((end = memchr (pt->read_pos, '\n', + (len = (pt->read_end - pt->read_pos)))) + != 0) + len = (end - pt->read_pos) + 1; + } + + /* I wonder how expensive this realloc is. */ + buf = scm_must_realloc (buf, buf_size + 1, buf_len + 1, "%read-line"); + buf[buf_len] = '\0'; + *len_p = buf_len; + return buf; + } +} + + +/* + * %read-line + * truncates any terminating newline from its input, and returns + * a cons of the string read and its terminating character. Doing + * so makes it easy to implement the hairy `read-line' options + * efficiently in Scheme. + */ + +SCM_DEFINE (scm_read_line, "%read-line", 0, 1, 0, + (SCM port), + "Read a newline-terminated line from @var{port}, allocating storage as\n" + "necessary. The newline terminator (if any) is removed from the string,\n" + "and a pair consisting of the line and its delimiter is returned. The\n" + "delimiter may be either a newline or the @var{eof-object}; if\n" + "@code{%read-line} is called at the end of file, it returns the pair\n" + "@code{(# . #)}.") +#define FUNC_NAME s_scm_read_line +{ + scm_port *pt; + char *s; + int slen; + SCM line, term; + + if (SCM_UNBNDP (port)) + port = scm_cur_inp; + SCM_VALIDATE_OPINPORT (1,port); + + pt = SCM_PTAB_ENTRY (port); + if (pt->rw_active == SCM_PORT_WRITE) + scm_ptobs[SCM_PTOBNUM (port)].flush (port); + + s = (char *) scm_do_read_line (port, &slen); + + if (s == NULL) + term = line = SCM_EOF_VAL; + else + { + if (s[slen-1] == '\n') + { + term = SCM_MAKE_CHAR ('\n'); + s[slen-1] = '\0'; + line = scm_take_str (s, slen-1); + scm_done_malloc (-1); + SCM_INCLINE (port); + } + else + { + /* Fix: we should check for eof on the port before assuming this. */ + term = SCM_EOF_VAL; + line = scm_take_str (s, slen); + SCM_COL (port) += slen; + } + } + + if (pt->rw_random) + pt->rw_active = SCM_PORT_READ; + + return scm_cons (line, term); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_write_line, "write-line", 1, 1, 0, + (SCM obj, SCM port), + "Display @var{obj} and a newline character to @var{port}. If @var{port}\n" + "is not specified, @code{(current-output-port)} is used. This function\n" + "is equivalent to:\n\n" + "@smalllisp\n" + "(display obj [port])\n" + "(newline [port])\n" + "@end smalllisp") +#define FUNC_NAME s_scm_write_line +{ + scm_display (obj, port); + return scm_newline (port); +} +#undef FUNC_NAME + +void +scm_init_rdelim (void) +{ + SCM rdelim_module = scm_make_module (scm_read_0str ("(ice-9 rdelim)")); + SCM old_module = scm_select_module (rdelim_module); + +#ifndef SCM_MAGIC_SNARFER +#include "libguile/rdelim.x" +#endif + + scm_select_module (old_module); + +#if DEBUG_DEPRECATED == 0 + { + const char expr[] = "\ +(define-module (guile) :use-module (ice-9 rdelim))\ +(define-module (guile-user) :use-module (ice-9 rdelim))"; + + scm_eval_string (scm_makfromstr (expr, (sizeof expr) - 1, 0)); + } + scm_select_module (old_module); +#endif +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/rdelim.h b/libguile/rdelim.h new file mode 100644 index 000000000..1f27a1d17 --- /dev/null +++ b/libguile/rdelim.h @@ -0,0 +1,61 @@ +/* classes: h_files */ + +#ifndef SCM_RDELIM +#define SCM_RDELIM +/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001 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 + * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + + +#include "libguile/__scm.h" + +extern SCM scm_read_delimited_x (SCM delims, SCM buf, SCM gobble, SCM port, + SCM offset, SCM length); +extern SCM scm_read_line (SCM port); +extern SCM scm_write_line (SCM obj, SCM port); +void scm_init_rdelim (void); + +#endif + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ From 22d356150dbc225a064b0c1ad719fd855fbb9f46 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Wed, 24 Jan 2001 21:46:04 +0000 Subject: [PATCH 0481/2047] * tests/ports.test: include (ice-9 rdelim) module. --- test-suite/ChangeLog | 4 ++++ test-suite/tests/ports.test | 4 +++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index e2b9cf075..3a6c32214 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2001-01-24 Gary Houston + + * tests/ports.test: include (ice-9 rdelim) module. + 2001-01-18 Dirk Herrmann * tests/numbers.test: Converted to do real boundary testing. diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index 71f4882f7..dbdca077c 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -19,7 +19,8 @@ ;;;; Boston, MA 02111-1307 USA (use-modules (test-suite lib) - (ice-9 popen)) + (ice-9 popen) + (ice-9 rdelim)) (define (display-line . args) (for-each display args) @@ -200,6 +201,7 @@ (let ((errno (car (list-ref args 3)))) (or (= errno EAGAIN) (= errno EWOULDBLOCK)))))))) + ;;;; Pipe (popen) ports. From fd937ecb0272a296b714dae05d988f69c6786dc9 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Wed, 24 Jan 2001 21:47:23 +0000 Subject: [PATCH 0482/2047] *** empty log message *** --- libguile/Makefile.am | 11 +++++++---- libguile/fports.h | 1 - libguile/init.c | 6 ++++++ 3 files changed, 13 insertions(+), 5 deletions(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 938ca1794..aaab474e7 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -46,7 +46,8 @@ libguile_la_SOURCES = \ goops.c gsubr.c guardians.c hash.c hashtab.c hooks.c init.c ioext.c \ iselect.c keywords.c lang.c list.c load.c macros.c mallocs.c \ modules.c numbers.c objects.c objprop.c options.c pairs.c ports.c \ - print.c procprop.c procs.c random.c read.c root.c scmsigs.c \ + print.c procprop.c procs.c random.c rdelim.c \ + read.c root.c scmsigs.c \ script.c simpos.c smob.c sort.c srcprop.c stackchk.c stacks.c \ stime.c strings.c strop.c strorder.c strports.c struct.c symbols.c \ tag.c throw.c values.c variable.c vectors.c version.c vports.c weaks.c \ @@ -61,7 +62,7 @@ DOT_X_FILES = \ hooks.x init.x ioext.x iselect.x keywords.x lang.x list.x load.x \ macros.x mallocs.x modules.x net_db.x numbers.x objects.x \ objprop.x options.x pairs.x ports.x posix.x print.x procprop.x \ - procs.x random.x read.x root.x scmsigs.x \ + procs.x random.x rdelim.x read.x root.x scmsigs.x \ script.x simpos.x smob.x socket.x sort.x srcprop.x stackchk.x \ stacks.x stime.x strings.x strop.x strorder.x strports.x struct.x \ symbols.x tag.x throw.x values.x variable.x vectors.x \ @@ -80,7 +81,8 @@ DOT_DOC_FILES = \ ioext.doc iselect.doc keywords.doc lang.doc list.doc load.doc \ macros.doc mallocs.doc modules.doc net_db.doc numbers.doc objects.doc \ objprop.doc options.doc pairs.doc ports.doc posix.doc print.doc \ - procprop.doc procs.doc random.doc read.doc root.doc scmsigs.doc \ + procprop.doc procs.doc random.doc rdelim.doc \ + read.doc root.doc scmsigs.doc \ script.doc simpos.doc smob.doc socket.doc sort.doc srcprop.doc \ stackchk.doc stacks.doc stime.doc strings.doc strop.doc strorder.doc \ strports.doc struct.doc symbols.doc tag.doc throw.doc values.doc \ @@ -127,7 +129,8 @@ modinclude_HEADERS = \ ioext.h keywords.h lang.h list.h load.h macros.h mallocs.h \ modules.h net_db.h numbers.h objects.h objprop.h options.h pairs.h \ ports.h posix.h regex-posix.h print.h procprop.h procs.h random.h \ - ramap.h read.h root.h scmsigs.h validate.h script.h simpos.h \ + ramap.h rdelim.h \ + read.h root.h scmsigs.h validate.h script.h simpos.h \ smob.h socket.h sort.h srcprop.h stackchk.h stacks.h stime.h \ strings.h strop.h strorder.h strports.h struct.h symbols.h tag.h \ tags.h throw.h unif.h values.h variable.h vectors.h version.h \ diff --git a/libguile/fports.h b/libguile/fports.h index 13c823536..d543c63df 100644 --- a/libguile/fports.h +++ b/libguile/fports.h @@ -72,7 +72,6 @@ struct scm_fport { extern SCM scm_setbuf0 (SCM port); extern SCM scm_setvbuf (SCM port, SCM mode, SCM size); -extern void scm_setfileno (FILE *fs, int fd); extern void scm_evict_ports (int fd); extern SCM scm_open_file (SCM filename, SCM modes); extern SCM scm_fdes_to_port (int fdes, char *mode, SCM name); diff --git a/libguile/init.c b/libguile/init.c index ff37d9c0a..674510680 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -112,6 +112,7 @@ #include "libguile/properties.h" #include "libguile/ramap.h" #include "libguile/random.h" +#include "libguile/rdelim.h" #include "libguile/read.h" #include "libguile/scmsigs.h" #include "libguile/script.h" @@ -586,6 +587,11 @@ scm_init_guile_1 (SCM_STACKITEM *base) #endif scm_load_startup_files (); + + /* this is located here, not from a deep understanding of the + module system, but as a way of avoiding segv and other + undesirable side effects that arise from various alternatives. */ + scm_init_rdelim (); } /* Record here whether SCM_BOOT_GUILE_1 has already been called. This From 0419a52877944ff360f44cec75d76f1cb29f4262 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 25 Jan 2001 11:09:21 +0000 Subject: [PATCH 0483/2047] * Fix handling of (set-source-property! 'copy ). --- libguile/ChangeLog | 5 +++++ libguile/srcprop.c | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index fb15ec74f..0d03bc3c7 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-01-25 Dirk Herrmann + + * srcprop.c (scm_set_source_property_x): Fix to handle + (set-source-property! 'copy ) correctly. + 2001-01-24 Gary Houston * filesys.c (scm_link): docstring fix. diff --git a/libguile/srcprop.c b/libguile/srcprop.c index 0fa027283..f17125f91 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -306,7 +306,7 @@ SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0, else SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, datum, SCM_UNDEFINED, p)); } - else if (SCM_EQ_P (scm_sym_filename, key)) + else if (SCM_EQ_P (scm_sym_copy, key)) { if (SRCPROPSP (p)) SRCPROPCOPY (p) = datum; From a98bddfd12b05872eedada5dedbd0e4967ace237 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 25 Jan 2001 17:18:41 +0000 Subject: [PATCH 0484/2047] * Made the port implementations less tightly coupled within guile. --- libguile/ChangeLog | 30 ++++++++++++++++++++++++++++++ libguile/fports.c | 22 +++++++++++++++------- libguile/fports.h | 10 ++++++---- libguile/init.c | 6 +++--- libguile/ports.c | 14 +------------- libguile/ports.h | 9 +++++---- libguile/posix.c | 2 +- libguile/strports.c | 15 +++++++++++---- libguile/tags.h | 8 +------- libguile/vports.c | 14 ++++++++++---- 10 files changed, 83 insertions(+), 47 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 0d03bc3c7..8ce25d60b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,33 @@ +2001-01-25 Dirk Herrmann + + * tags.h (scm_tc16_fport, scm_tc16_strport, scm_tc16_sfport): + These are now defined in fports.c, strports.c and vports.c. + + * fports.[ch] (scm_tc16_fport), strports.c (scm_tc16_strport), + vports.c (scm_tc16_sfport): Made variables (were macros defined in + tags.h). + + fports.c (scm_make_fptob), strports.c (scm_make_stptob), vports.c + (scm_make_sfptob): Made static. These return a type code now. + + fports.c (scm_init_fports), strports.c (scm_init_strports), + vports.c (scm_init_vports): Create the corresponding port types. + + * fports.h (SCM_FPORTP, SCM_OPFPORTP, SCM_OPINFPORTP, + SCM_OPOUTFPORTP): Redefined in terms of scm_tc16_fport. + + * init.c (scm_init_guile_1): Make sure strports are initialized + before gdbint. + + * ports.[ch] (scm_make_port_type): Changed the return type to + scm_bits_t. + + * ports.c (scm_ports_prehistory): Don't create any port types + here. + + * posix.c (scm_ttyname): Use SCM_FPORTP instead of comparing + against scm_tc16_fport directly. + 2001-01-25 Dirk Herrmann * srcprop.c (scm_set_source_property_x): Fix to handle diff --git a/libguile/fports.c b/libguile/fports.c index 093a4ee45..302303f5e 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -69,6 +69,10 @@ scm_sizet fwrite (); #include "libguile/iselect.h" + +scm_bits_t scm_tc16_fport; + + /* default buffer size, used if the O/S won't supply a value. */ static const int default_buffer_size = 1024; @@ -767,12 +771,11 @@ fport_free (SCM port) return 0; } -void scm_make_fptob (void); /* Called from ports.c */ - -void +static scm_bits_t scm_make_fptob () { - long tc = scm_make_port_type ("file", fport_fill_input, fport_write); + scm_bits_t tc = scm_make_port_type ("file", fport_fill_input, fport_write); + scm_set_port_free (tc, fport_free); scm_set_port_print (tc, fport_print); scm_set_port_flush (tc, fport_flush); @@ -781,17 +784,22 @@ scm_make_fptob () scm_set_port_seek (tc, fport_seek); scm_set_port_truncate (tc, fport_truncate); scm_set_port_input_waiting (tc, fport_input_waiting); + + return tc; } void scm_init_fports () { -#ifndef SCM_MAGIC_SNARFER -#include "libguile/fports.x" -#endif + scm_tc16_fport = scm_make_fptob (); + scm_sysintern ("_IOFBF", SCM_MAKINUM (_IOFBF)); scm_sysintern ("_IOLBF", SCM_MAKINUM (_IOLBF)); scm_sysintern ("_IONBF", SCM_MAKINUM (_IONBF)); + +#ifndef SCM_MAGIC_SNARFER +#include "libguile/fports.x" +#endif } /* diff --git a/libguile/fports.h b/libguile/fports.h index d543c63df..8fc992579 100644 --- a/libguile/fports.h +++ b/libguile/fports.h @@ -58,13 +58,15 @@ struct scm_fport { int fdes; /* file descriptor. */ }; +extern scm_bits_t scm_tc16_fport; + #define SCM_FSTREAM(x) ((struct scm_fport *) SCM_STREAM (x)) #define SCM_FPORT_FDES(x) (SCM_FSTREAM (x)->fdes) -#define SCM_FPORTP(x) (!SCM_IMP (x) && (SCM_TYP16S (x) == scm_tc7_port)) -#define SCM_OPFPORTP(x) (!SCM_IMP (x) && (((0xfeff | SCM_OPN) & SCM_CELL_WORD_0 (x)) == (scm_tc7_port | SCM_OPN))) -#define SCM_OPINFPORTP(x) (!SCM_IMP (x) && (((0xfeff | SCM_OPN | SCM_RDNG) & SCM_CELL_WORD_0 (x)) == (scm_tc7_port | SCM_OPN | SCM_RDNG))) -#define SCM_OPOUTFPORTP(x) (!SCM_IMP(x) && (((0xfeff | SCM_OPN | SCM_WRTNG) & SCM_CELL_WORD_0 (x)) == (scm_tc7_port | SCM_OPN | SCM_WRTNG))) +#define SCM_FPORTP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_fport)) +#define SCM_OPFPORTP(x) (SCM_FPORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_OPN)) +#define SCM_OPINFPORTP(x) (SCM_OPFPORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_RDNG)) +#define SCM_OPOUTFPORTP(x) (SCM_OPFPORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_WRTNG)) /* test whether fdes supports random access. */ #define SCM_FDES_RANDOM_P(fdes) ((lseek (fdes, 0, SEEK_CUR) == -1) ? 0 : 1) diff --git a/libguile/init.c b/libguile/init.c index 674510680..2c079df7b 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -499,7 +499,8 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_init_fluids (); scm_init_backtrace (); /* Requires fluids */ scm_init_fports (); - scm_init_gdbint (); + scm_init_strports (); + scm_init_gdbint (); /* Requires strports */ scm_init_hash (); scm_init_hashtab (); scm_init_objprop (); @@ -539,7 +540,6 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_init_stackchk (); scm_init_struct (); scm_init_stacks (); /* Requires struct */ - scm_init_strports (); scm_init_symbols (); scm_init_tag (); scm_init_values (); /* Requires struct */ @@ -570,7 +570,7 @@ scm_init_guile_1 (SCM_STACKITEM *base) #endif scm_init_simpos (); scm_init_load_path (); - scm_init_standard_ports (); + scm_init_standard_ports (); /* Requires fports */ scm_init_dynamic_linking (); scm_init_lang (); scm_init_script (); diff --git a/libguile/ports.c b/libguile/ports.c index f955b0302..a840ff538 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -115,7 +115,7 @@ end_input_default (SCM port, int offset) { } -long +scm_bits_t scm_make_port_type (char *name, int (*fill_input) (SCM port), void (*write) (SCM port, const void *data, size_t size)) @@ -1382,23 +1382,11 @@ scm_port_print (SCM exp, SCM port, scm_print_state *pstate) return 1; } -extern void scm_make_fptob (); -extern void scm_make_stptob (); -extern void scm_make_sfptob (); - void scm_ports_prehistory () { scm_numptob = 0; scm_ptobs = (scm_ptob_descriptor *) malloc (sizeof (scm_ptob_descriptor)); - - /* WARNING: These scm_newptob calls must be done in this order. - * They must agree with the port declarations in tags.h. - */ - /* scm_tc16_fport = */ scm_make_fptob (); - /* scm_tc16_pipe was here */ scm_make_fptob (); /* dummy. */ - /* scm_tc16_strport = */ scm_make_stptob (); - /* scm_tc16_sfport = */ scm_make_sfptob (); } diff --git a/libguile/ports.h b/libguile/ports.h index 9676bde18..fe2c0dc92 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -217,10 +217,11 @@ extern int scm_port_table_room; extern SCM scm_markstream (SCM ptr); -extern long scm_make_port_type (char *name, - int (*fill_input) (SCM port), - void (*write) (SCM port, const void *data, - size_t size)); +extern scm_bits_t scm_make_port_type (char *name, + int (*fill_input) (SCM port), + void (*write) (SCM port, + const void *data, + size_t size)); extern void scm_set_port_mark (long tc, SCM (*mark) (SCM)); extern void scm_set_port_free (long tc, scm_sizet (*free) (SCM)); extern void scm_set_port_print (long tc, diff --git a/libguile/posix.c b/libguile/posix.c index cf8146b67..b766cb4c1 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -716,7 +716,7 @@ SCM_DEFINE (scm_ttyname, "ttyname", 1, 0, 0, port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPPORT (1,port); - if (scm_tc16_fport != SCM_TYP16 (port)) + if (!SCM_FPORTP (port)) return SCM_BOOL_F; fd = SCM_FPORT_FDES (port); SCM_SYSCALL (ans = ttyname (fd)); diff --git a/libguile/strports.c b/libguile/strports.c index d0b9f57a6..0e48e0f7d 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -79,6 +79,10 @@ when rw_active is SCM_PORT_NEITHER. */ + +static scm_bits_t scm_tc16_strport; + + static int stfill_buffer (SCM port) { @@ -416,22 +420,25 @@ SCM_DEFINE (scm_eval_string, "eval-string", 1, 0, 0, } #undef FUNC_NAME -void scm_make_stptob (void); /* Called from ports.c */ - -void +static scm_bits_t scm_make_stptob () { - long tc = scm_make_port_type ("string", stfill_buffer, st_write); + scm_bits_t tc = scm_make_port_type ("string", stfill_buffer, st_write); + scm_set_port_mark (tc, scm_markstream); scm_set_port_end_input (tc, st_end_input); scm_set_port_flush (tc, st_flush); scm_set_port_seek (tc, st_seek); scm_set_port_truncate (tc, st_truncate); + + return tc; } void scm_init_strports () { + scm_tc16_strport = scm_make_stptob (); + #ifndef SCM_MAGIC_SNARFER #include "libguile/strports.x" #endif diff --git a/libguile/tags.h b/libguile/tags.h index 6d4b6ed70..02ddeec9e 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -372,16 +372,10 @@ typedef long scm_bits_t; #define scm_tc7_lsubr 119 -/* There are 256 port subtypes. Here are the first few. - * These must agree with the init function in ports.c +/* There are 256 port subtypes. */ #define scm_tc7_port 125 -#define scm_tc16_fport (scm_tc7_port + 0 * 256L) -/* scm_tc16_pipe was here. */ -#define scm_tc16_strport (scm_tc7_port + 2 * 256L) -#define scm_tc16_sfport (scm_tc7_port + 3 * 256L) - /* There are 256 smob subtypes. Here are the first four. */ diff --git a/libguile/vports.c b/libguile/vports.c index 512d55862..cdb43598d 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -67,6 +67,9 @@ */ +static scm_bits_t scm_tc16_sfport; + + static void sf_flush (SCM port) { @@ -197,20 +200,23 @@ SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0, #undef FUNC_NAME -void scm_make_sfptob (void); /* Called from ports.c */ - -void +static scm_bits_t scm_make_sfptob () { - long tc = scm_make_port_type ("soft", sf_fill_input, sf_write); + scm_bits_t tc = scm_make_port_type ("soft", sf_fill_input, sf_write); + scm_set_port_mark (tc, scm_markstream); scm_set_port_flush (tc, sf_flush); scm_set_port_close (tc, sf_close); + + return tc; } void scm_init_vports () { + scm_tc16_sfport = scm_make_sfptob (); + #ifndef SCM_MAGIC_SNARFER #include "libguile/vports.x" #endif From efa40607b133c6b490f4cb83a9bcab909b8171ee Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 25 Jan 2001 17:40:50 +0000 Subject: [PATCH 0485/2047] * Added a file-port? primitive. --- NEWS | 4 ++++ libguile/ChangeLog | 4 ++++ libguile/fports.c | 11 +++++++++++ libguile/fports.h | 1 + 4 files changed, 20 insertions(+) diff --git a/NEWS b/NEWS index 813f3ac4a..fc58c02c0 100644 --- a/NEWS +++ b/NEWS @@ -262,6 +262,10 @@ Instead, use scm_c_memq or scm_memq, scm_memv, scm_member. Returns a boolean indicating whether X is a port. Equivalent to `(or (input-port? X) (output-port? X))'. +** New function: file-port? + +Determines whether a given object is a port that is related to a file. + ** New function: port-for-each proc Apply PROC to each port in the Guile port table in turn. The diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 8ce25d60b..6114d7aba 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2001-01-25 Dirk Herrmann + + * fports.[ch] (scm_file_port_p): New primitive. + 2001-01-25 Dirk Herrmann * tags.h (scm_tc16_fport, scm_tc16_strport, scm_tc16_sfport): diff --git a/libguile/fports.c b/libguile/fports.c index 302303f5e..b71107104 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -226,6 +226,17 @@ scm_evict_ports (int fd) } } + +SCM_DEFINE (scm_file_port_p, "file-port?", 1, 0, 0, + (SCM obj), + "Determine whether OBJ is a port that is related to a file.") +#define FUNC_NAME s_scm_file_port_p +{ + return SCM_BOOL (SCM_FPORTP (obj)); +} +#undef FUNC_NAME + + /* scm_open_file * Return a new port open on a given file. * diff --git a/libguile/fports.h b/libguile/fports.h index 8fc992579..3d970d9a8 100644 --- a/libguile/fports.h +++ b/libguile/fports.h @@ -77,6 +77,7 @@ extern SCM scm_setvbuf (SCM port, SCM mode, SCM size); extern void scm_evict_ports (int fd); extern SCM scm_open_file (SCM filename, SCM modes); extern SCM scm_fdes_to_port (int fdes, char *mode, SCM name); +extern SCM scm_file_port_p (SCM obj); extern void scm_init_fports (void); #endif /* FPORTSH */ From c4a9b7bbd1f209bee50738a521e467672e7dd496 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 25 Jan 2001 17:57:29 +0000 Subject: [PATCH 0486/2047] * Make sure that only open file ports are used as readline ports. --- guile-readline/ChangeLog | 7 +++++++ guile-readline/readline.scm | 18 ++++++++++++++++-- 2 files changed, 23 insertions(+), 2 deletions(-) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 4c227c692..9bd1bf61c 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,10 @@ +2001-01-25 Dirk Herrmann + + * readline.scm (set-readline-input-port!, + set-readline-output-port!): Make sure that only valid port + parameters are passed. Thanks to Martin Grabmueller for sending + a patch that formed the basis for this change. + 2001-01-18 Neil Jerram * readline.scm (make-readline-port): Make readline port diff --git a/guile-readline/readline.scm b/guile-readline/readline.scm index cbb0c4308..16adca408 100644 --- a/guile-readline/readline.scm +++ b/guile-readline/readline.scm @@ -140,10 +140,24 @@ (set! prompt2 (car rest)))) (define-public (set-readline-input-port! p) - (set! input-port p)) + (cond ((or (not (file-port? p)) (not (input-port? p))) + (scm-error 'wrong-type-arg "set-readline-input-port!" + "Not a file input port: ~S" (list p) #f)) + ((port-closed? p) + (scm-error 'misc-error "set-readline-input-port!" + "Port not open: ~S" (list p) #f)) + (else + (set! input-port p)))) (define-public (set-readline-output-port! p) - (set! output-port p)) + (cond ((or (not (file-port? p)) (not (output-port? p))) + (scm-error 'wrong-type-arg "set-readline-input-port!" + "Not a file output port: ~S" (list p) #f)) + ((port-closed? p) + (scm-error 'misc-error "set-readline-output-port!" + "Port not open: ~S" (list p) #f)) + (else + (set! output-port p)))) (define-public (set-readline-read-hook! h) (set! read-hook h)) From 2f2b390c831230217d86db9221b86c9a0045b99b Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 25 Jan 2001 23:34:31 +0000 Subject: [PATCH 0487/2047] * On errors, show line and column information even for unnamed ports. --- libguile/ChangeLog | 7 +++++++ libguile/backtrace.c | 34 +++++++++++++++++++++------------- 2 files changed, 28 insertions(+), 13 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6114d7aba..8c3271045 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2001-01-25 Dirk Herrmann + + * backtrace.c (display_header): Make sure that line and column + information is shown independent of whether the port the code was + read from had an associated filename. Thanks to Martin + Grabmueller for providing this patch. + 2001-01-25 Dirk Herrmann * fports.[ch] (scm_file_port_p): New primitive. diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 67d8e2a27..729f6d8e2 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -86,20 +86,28 @@ SCM scm_the_last_stack_fluid; static void display_header (SCM source, SCM port) { - SCM fname = (SCM_MEMOIZEDP (source) - ? scm_source_property (source, scm_sym_filename) - : SCM_BOOL_F); - if (SCM_STRINGP (fname)) + if (SCM_MEMOIZEDP (source)) { - scm_prin1 (fname, port, 0); - scm_putc (':', port); - scm_intprint (SCM_INUM (scm_source_property (source, scm_sym_line)) + 1, - 10, - port); - scm_putc (':', port); - scm_intprint (SCM_INUM (scm_source_property (source, scm_sym_column)) + 1, - 10, - port); + SCM fname = scm_source_property (source, scm_sym_filename); + SCM line = scm_source_property (source, scm_sym_line); + SCM col = scm_source_property (source, scm_sym_column); + + /* Dirk:FIXME:: Maybe we should store the _port_ rather than the + * filename with the source properties? Then we could in case of + * non-file ports give at least some more details than just + * "". */ + if (SCM_STRINGP (fname)) + scm_prin1 (fname, port, 0); + else + scm_puts ("", port); + + if (!SCM_FALSEP (line) && !SCM_FALSEP (col)) + { + scm_putc (':', port); + scm_intprint (SCM_INUM (line) + 1, 10, port); + scm_putc (':', port); + scm_intprint (SCM_INUM (col) + 1, 10, port); + } } else scm_puts ("ERROR", port); From 1ff7abbe3ffaeacb42166cfdff62b8037c4bc349 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 26 Jan 2001 13:44:57 +0000 Subject: [PATCH 0488/2047] * Added Thien-Thi Nguyen's patch to support "make check". --- ChangeLog | 10 +++++ Makefile.am | 2 + THANKS | 1 + configure.in | 6 ++- test-suite/ChangeLog | 27 ++++++++++++ test-suite/README | 9 +--- test-suite/guile-test | 98 +++++++++++++++++++++++++++++++------------ test-suite/paths.scm | 0 8 files changed, 119 insertions(+), 34 deletions(-) delete mode 100644 test-suite/paths.scm diff --git a/ChangeLog b/ChangeLog index e5cd22a1c..7214bff2a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,13 @@ +2001-01-26 Dirk Herrmann + + The following patch was sent by Thien-Thi Nguyen. + + * check-guile.in: New file. + + * Makefile.am: Add TESTS rule. + + * configure.in: Add support for "make check". + 2000-11-21 Dirk Herrmann * acconfig.h: Removed bogus #ifndef. Thanks to Lars J. Aas. diff --git a/Makefile.am b/Makefile.am index 847e90e33..76b1af194 100644 --- a/Makefile.am +++ b/Makefile.am @@ -25,5 +25,7 @@ include_HEADERS = libguile.h EXTRA_DIST = qthreads.m4 HACKING GUILE-VERSION ANON-CVS SNAPSHOTS +TESTS = check-guile + # The rule will cd to $(top_srcdir). ACLOCAL = ./guile-aclocal.sh diff --git a/THANKS b/THANKS index 14825bf91..84faf45ac 100644 --- a/THANKS +++ b/THANKS @@ -27,6 +27,7 @@ For fixes or providing information which led to a fix: Ralf Mattes Shuji Narazaki Nicolas Neuss + Thien-Thi Nguyen Han-Wen Nienhuys David Pirotte Julian Satchell diff --git a/configure.in b/configure.in index 39f848d3c..5705f5b01 100644 --- a/configure.in +++ b/configure.in @@ -507,7 +507,11 @@ AC_SUBST(AWK) AC_SUBST(LIBLOBJS) AC_SUBST(EXTRA_DOT_DOC_FILES) -AC_OUTPUT([Makefile libguile/Makefile libguile/guile-snarf libguile/guile-doc-snarf libguile/guile-func-name-check libguile/guile-snarf.awk libguile/versiondat.h ice-9/Makefile oop/Makefile oop/goops/Makefile qt/Makefile qt/qt.h qt/md/Makefile qt/time/Makefile guile-config/Makefile doc/Makefile], [chmod +x libguile/guile-snarf libguile/guile-doc-snarf libguile/guile-func-name-check]) +# Support for "make check" +test_suite_dir="`(cd $srcdir ; pwd)`/test-suite" +AC_SUBST(test_suite_dir) + +AC_OUTPUT([Makefile libguile/Makefile libguile/guile-snarf libguile/guile-doc-snarf libguile/guile-func-name-check libguile/guile-snarf.awk libguile/versiondat.h ice-9/Makefile oop/Makefile oop/goops/Makefile qt/Makefile qt/qt.h qt/md/Makefile qt/time/Makefile guile-config/Makefile doc/Makefile check-guile], [chmod +x libguile/guile-snarf libguile/guile-doc-snarf libguile/guile-func-name-check check-guile]) dnl Local Variables: dnl comment-start: "dnl " diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 3a6c32214..0f4ff9d3c 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,30 @@ +2001-01-26 Dirk Herrmann + + The following patch was sent by Thien-Thi Nguyen and a little bit + modified by me. + + * guile-test: Usage and installation comments improved. Added + support for --test-suite and --debug command line options. + + (default-test-suite): Added to allow for simplified + configurability. No need to load the paths file any more. + + (enable-debug-mode): New function. Will be called when the + --debug command line option is given. + + (test-root): Removed. The test directory has to be fully given. + This allows for arbitrarily named test directories. + + (test-file-name, enumerate-tets): Take the test directory as a + paramter instead of using the global variable 'test-root'. + + (main): Handle the new command line options. Return an exit code + depending on whether all tests came out as expected. + + * README: Updated. + + * paths.scm: Removed. + 2001-01-24 Gary Houston * tests/ports.test: include (ice-9 rdelim) module. diff --git a/test-suite/README b/test-suite/README index d13e76c51..116869e17 100644 --- a/test-suite/README +++ b/test-suite/README @@ -5,13 +5,8 @@ To run these tests, you will need a version of Guile more recent than 15 Feb 1999 --- the tests use the (ice-9 and-let*) and (ice-9 getopt-long) modules, which were added to Guile around then. -To run the test suite, you'll need to: -- edit the path to the guile interpreter in `guile-test', and -- edit the paths in `paths.scm', so `guile-test' can find the test - scripts. - -Once that's done, you can just run the `guile-test' script. That -script has usage instructions in the comments at the top. +For information about how to run the test suite, read the usage +instructions in the comments at the top of the guile-test script. You can reference the file `lib.scm' from your own code as the module (test-suite lib); it also has comments at the top and before each diff --git a/test-suite/guile-test b/test-suite/guile-test index faa9a1c13..20591a637 100755 --- a/test-suite/guile-test +++ b/test-suite/guile-test @@ -1,4 +1,4 @@ -#!/usr/local/bin/guile \ +#!/home/dirk/bin/guile \ -e main -s !# @@ -23,34 +23,48 @@ ;;;; Boston, MA 02111-1307 USA - -;;;; Usage: guile-test [--log-file LOG] [TEST ...] +;;;; Usage: [guile -e main -s] guile-test [OPTIONS] [TEST ...] ;;;; ;;;; Run tests from the Guile test suite. Report failures and ;;;; unexpected passes to the standard output, along with a summary of ;;;; all the results. Record each reported test outcome in the log -;;;; file, `guile.log'. +;;;; file, `guile.log'. The exit status is #f if any of the tests +;;;; fail or pass unexpectedly. ;;;; ;;;; Normally, guile-test scans the test directory, and executes all ;;;; files whose names end in `.test'. (It assumes they contain ;;;; Scheme code.) However, you can have it execute specific tests by ;;;; listing their filenames on the command line. ;;;; +;;;; The option '--test-suite' can be given to specify the test +;;;; directory. If no such option is given, the test directory is +;;;; taken from the environment variable TEST_SUITE_DIR (if defined), +;;;; otherwise a default directory that is hardcoded in this file is +;;;; used (see "Installation" below). +;;;; ;;;; If present, the `--log-file LOG' option tells `guile-test' to put ;;;; the log output in a file named LOG. ;;;; +;;;; If present, the '--debug' option will enable a debugging mode. +;;;; +;;;; ;;;; Installation: ;;;; -;;;; Change the #! line at the top of this script to point at the -;;;; Guile interpreter you want to test. Edit `test-suite/paths.scm' -;;;; so that datadir points to the parent directory of the `tests' tree. +;;;; If you change the #! line at the top of this script to point at +;;;; the Guile interpreter you want to test, you can call this script +;;;; as an executable instead of having to pass it as a parameter to +;;;; guile via "guile -e main -s guile-test". Further, you can edit +;;;; the definition of default-test-suite to point to the parent +;;;; directory of the `tests' tree, which makes it unnecessary to set +;;;; the environment variable `TEST_SUITE_DIR'. +;;;; ;;;; ;;;; Shortcomings: ;;;; ;;;; At the moment, due to a simple-minded implementation, test files ;;;; must live in the test directory, and you must specify their names ;;;; relative to the top of the test directory. If you want to send -;;;; me a patche that fixes this, but still leaves sane test names in +;;;; me a patch that fixes this, but still leaves sane test names in ;;;; the log file, that would be great. At the moment, all the tests ;;;; I care about are in the test directory, though. ;;;; @@ -59,14 +73,25 @@ ;;;; change which Guile interpreter you're testing, you need to edit ;;;; the #! line at the top of this file, which is stupid. + +;;; User configurable settings: +(define default-test-suite + (string-append (getenv "HOME") "/guile-core/test-suite")) + + (use-modules (test-suite lib) - (test-suite paths) (ice-9 getopt-long) (ice-9 and-let*)) ;;; General utilities, that probably should be in a library somewhere. +;;; Enable debugging +(define (enable-debug-mode) + (write-line %load-path) + (set! %load-verbosely #t) + (debug-enable 'backtrace 'debug)) + ;;; Traverse the directory tree at ROOT, applying F to the name of ;;; each file in the tree, including ROOT itself. For a subdirectory ;;; SUB, if (F SUB) is true, we recurse into SUB. Do not follow @@ -93,18 +118,16 @@ (visit (string-append root "/" entry)) (loop)))))))))) - ;;; The test driver. -(define test-root (in-vicinity datadir "tests")) - -(define (test-file-name test) - (in-vicinity test-root test)) +(define (test-file-name test-dir test) + (in-vicinity test-dir test)) ;;; Return a list of all the test files in the test tree. -(define (enumerate-tests) - (let ((root-len (+ 1 (string-length test-root))) +(define (enumerate-tests test-dir) + + (let ((root-len (+ 1 (string-length test-dir))) (tests '())) (for-each-file (lambda (file) (if (has-suffix? file ".test") @@ -112,7 +135,7 @@ (substring file root-len))) (set! tests (cons short-name tests)))) #t) - test-root) + test-dir) ;; for-each-file presents the files in whatever order it finds ;; them in the directory. We sort them here, so they'll always @@ -122,29 +145,51 @@ (define (main args) (let ((options (getopt-long args - `((log-file (single-char #\l) - (value #t)))))) + `((test-suite + (single-char #\t) + (value #t)) + (log-file + (single-char #\l) + (value #t)) + (debug + (single-char #\d)))))) (define (opt tag default) (let ((pair (assq tag options))) (if pair (cdr pair) default))) - (let ((log-file (opt 'log-file "guile.log")) - (tests (let ((foo (opt '() '()))) - (if (null? foo) (enumerate-tests) - foo)))) + + (if (opt 'debug #f) + (enable-debug-mode)) + + (let* ((test-suite + (or (opt 'test-suite #f) + (getenv "TEST_SUITE_DIR") + default-test-suite)) + (tests + (let ((foo (opt '() '()))) + (if (null? foo) + (enumerate-tests test-suite) + foo))) + (log-file + (opt 'log-file "guile.log"))) ;; Open the log file. (let ((log-port (open-output-file log-file))) ;; Register some reporters. - (let ((counter (make-count-reporter))) + (let ((global-pass #t) + (counter (make-count-reporter))) (register-reporter (car counter)) (register-reporter (make-log-reporter log-port)) (register-reporter user-reporter) + (register-reporter (lambda results + (case (car results) + ((fail upass unresolved error) + (set! global-pass #f))))) ;; Run the tests. (for-each (lambda (test) (with-test-prefix test - (load (test-file-name test)))) + (load (test-file-name test-suite test)))) tests) ;; Display the final counts, both to the user and in the log @@ -153,7 +198,8 @@ (print-counts counts) (print-counts counts log-port)) - (close-port log-port)))))) + (close-port log-port) + (quit global-pass)))))) ;;; Local Variables: diff --git a/test-suite/paths.scm b/test-suite/paths.scm deleted file mode 100644 index e69de29bb..000000000 From 8992c8a2eff76d02794ba9350433a623b5889fdc Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 26 Jan 2001 13:47:53 +0000 Subject: [PATCH 0489/2047] * Forgot to add the file check-guile.in with the latest commit. --- check-guile.in | 43 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) create mode 100644 check-guile.in diff --git a/check-guile.in b/check-guile.in new file mode 100644 index 000000000..89410eae0 --- /dev/null +++ b/check-guile.in @@ -0,0 +1,43 @@ +#! /bin/sh +# Usage: check-guile [-i GUILE-INTERPRETER] [GUILE-TEST-ARGS] +# If `-i GUILE-INTERPRETER' is omitted, use libguile/guile. +# See test-suite/guile-test for documentation on GUILE-TEST-ARGS. +# +# Example invocations: +# ./check-guile +# ./check-guile numbers.test +# ./check-guile -i /usr/local/bin/guile +# ./check-guile -i /usr/local/bin/guile numbers.test +# +# Dependencies: dirname sed + +TEST_SUITE_DIR=@test_suite_dir@ +parent=`dirname $TEST_SUITE_DIR` + +if [ x"$1" = x-i ] ; then + guile=$2 + shift + shift +else + guile=$parent/libguile/guile + glp=$parent +fi + +if [ -f "$guile" -a -x "$guile" ] ; then + echo Testing $guile ... "$@" + if [ x"$glp" = x ] ; then + glp=`$guile -c "(for-each write-line %load-path)"` + glp=`echo $glp | sed 's/ /:/g'`:$parent + fi + GUILE_LOAD_PATH=$glp + export GUILE_LOAD_PATH + echo with GUILE_LOAD_PATH: $GUILE_LOAD_PATH +else + echo ERROR: Cannot execute $guile + exit 1 +fi + +cd $TEST_SUITE_DIR +exec $guile -e main -s guile-test --test-suite $TEST_SUITE_DIR/tests "$@" + +# check-guile ends here From efb07c899c29d5bfe89eb599fad935c0fc3cc081 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 26 Jan 2001 16:49:28 +0000 Subject: [PATCH 0490/2047] * Fixed things that I had broken with the last patch :-( --- test-suite/ChangeLog | 25 +++++++++++++++++++++++++ test-suite/guile-test | 29 ++++++++++++++++++++--------- test-suite/lib.scm | 14 +------------- test-suite/tests/r4rs.test | 18 +++++++++--------- 4 files changed, 55 insertions(+), 31 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 0f4ff9d3c..77f682754 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,28 @@ +2001-01-26 Dirk Herrmann + + This patch fixes things that I have broken with the last one :-( + + * guile-test (test-suite): New variable. + + (data-file-name): New function. Has the same purpose as the + former function data-file from lib.scm. Moved here in order to + have all file name handling at the same place. In contrast to the + former 'data-file function, it is not checked whether a file + exists. This allows to use this function also for file names of + files that are still to be created. + + (test-file-name): Use the global 'test-suite variable. + + (main): Initialize 'test-suite instead of a local variable. + + * lib.scm: Don't import paths any more. + + (data-file): Removed. Resurrected with a sligtly different + functionality as 'data-file-name' in guile-test. + + * r4rs.scm: For all references to temporary file, make use of + data-file-name. + 2001-01-26 Dirk Herrmann The following patch was sent by Thien-Thi Nguyen and a little bit diff --git a/test-suite/guile-test b/test-suite/guile-test index 20591a637..4cdbbb7b4 100755 --- a/test-suite/guile-test +++ b/test-suite/guile-test @@ -83,6 +83,10 @@ (ice-9 getopt-long) (ice-9 and-let*)) + +;;; Variables that will receive their actual values later. +(define test-suite default-test-suite) + ;;; General utilities, that probably should be in a library somewhere. @@ -121,12 +125,18 @@ ;;; The test driver. -(define (test-file-name test-dir test) - (in-vicinity test-dir test)) + +;;; Localizing test files and temporary data files relative to the +;;; test suite directory. + +(define (data-file-name filename) + (in-vicinity test-suite filename)) + +(define (test-file-name test) + (in-vicinity test-suite test)) ;;; Return a list of all the test files in the test tree. (define (enumerate-tests test-dir) - (let ((root-len (+ 1 (string-length test-dir))) (tests '())) (for-each-file (lambda (file) @@ -160,11 +170,12 @@ (if (opt 'debug #f) (enable-debug-mode)) - (let* ((test-suite - (or (opt 'test-suite #f) - (getenv "TEST_SUITE_DIR") - default-test-suite)) - (tests + (set! test-suite + (or (opt 'test-suite #f) + (getenv "TEST_SUITE_DIR") + default-test-suite)) + + (let* ((tests (let ((foo (opt '() '()))) (if (null? foo) (enumerate-tests test-suite) @@ -189,7 +200,7 @@ ;; Run the tests. (for-each (lambda (test) (with-test-prefix test - (load (test-file-name test-suite test)))) + (load (test-file-name test)))) tests) ;; Display the final counts, both to the user and in the log diff --git a/test-suite/lib.scm b/test-suite/lib.scm index fa730973b..87efcc034 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -16,8 +16,7 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA -(define-module (test-suite lib) - #:use-module (test-suite paths)) +(define-module (test-suite lib)) (export @@ -424,17 +423,6 @@ (set! default-reporter full-reporter) - -;;;; Helping test cases find their files - -;;; Returns FILENAME, relative to the directory the test suite data -;;; files were installed in, and makes sure the file exists. -(define (data-file filename) - (let ((f (in-vicinity datadir filename))) - (or (file-exists? f) - (error "Test suite data file does not exist: " f)) - f)) - ;;;; Detecting whether errors occur diff --git a/test-suite/tests/r4rs.test b/test-suite/tests/r4rs.test index c915b515c..28b86b095 100644 --- a/test-suite/tests/r4rs.test +++ b/test-suite/tests/r4rs.test @@ -547,14 +547,14 @@ (set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13) (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj))) (test #t call-with-output-file - "tmp3" + (data-file-name "tmp3") (lambda (test-file) (write-char #\; test-file) (display write-test-obj test-file) (newline test-file) (write load-test-obj test-file) (output-port? test-file))) - (check-test-file "tmp3") + (check-test-file (data-file-name "tmp3")) (set! write-test-obj wto) (set! display-test-obj dto) (set! load-test-obj lto) @@ -935,8 +935,8 @@ (SECTION 6 10 1) (test #t input-port? (current-input-port)) (test #t output-port? (current-output-port)) -(test #t call-with-input-file (data-file "tests/r4rs.test") input-port?) -(define this-file (open-input-file (data-file "tests/r4rs.test"))) +(test #t call-with-input-file (data-file-name "r4rs.test") input-port?) +(define this-file (open-input-file (data-file-name "r4rs.test"))) (test #t input-port? this-file) (SECTION 6 10 2) (test #\; peek-char this-file) @@ -968,23 +968,23 @@ (define load-test-obj (list 'define 'foo (list 'quote write-test-obj))) (test #t call-with-output-file - "tmp1" + (data-file-name "tmp1") (lambda (test-file) (write-char #\; test-file) (display write-test-obj test-file) (newline test-file) (write load-test-obj test-file) (output-port? test-file))) -(check-test-file "tmp1") +(check-test-file (data-file-name "tmp1")) -(define test-file (open-output-file "tmp2")) +(define test-file (open-output-file (data-file-name "tmp2"))) (write-char #\; test-file) (display write-test-obj test-file) (newline test-file) (write load-test-obj test-file) (test #t output-port? test-file) (close-output-port test-file) -(check-test-file "tmp2") +(check-test-file (data-file-name "tmp2")) (define (test-sc4) (SECTION 6 7) (test '(#\P #\space #\l) string->list "P l") @@ -997,7 +997,7 @@ (test '#(dididit dah) list->vector '(dididit dah)) (test '#() list->vector '()) (SECTION 6 10 4) - (load (data-file "tmp1")) + (load (data-file-name "tmp1")) (test write-test-obj 'load foo) (report-errs)) From e9bab9df3dd725085bb603de21a5d105a532bfe3 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 26 Jan 2001 16:58:48 +0000 Subject: [PATCH 0491/2047] * Make readline run-time options accessible. --- guile-readline/ChangeLog | 12 +++ guile-readline/readline.scm | 25 ++++++ ice-9/ChangeLog | 11 +++ ice-9/boot-9.scm | 165 ++++++++++++++++++------------------ 4 files changed, 130 insertions(+), 83 deletions(-) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 9bd1bf61c..546d3637a 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,15 @@ +2001-01-26 Dirk Herrmann + + This patch fixes a problem reported by Martin Grabmueller about + the impossibility to access readline's run-time options. + + * readline.scm: Added a comment about guile's behaviour if one of + the ports used by readline are closed. + + (readline-options readline-enable readline-disable, + readline-set!): These are now defined here instead of in + boot-9.scm. + 2001-01-25 Dirk Herrmann * readline.scm (set-readline-input-port!, diff --git a/guile-readline/readline.scm b/guile-readline/readline.scm index 16adca408..8d499d5aa 100644 --- a/guile-readline/readline.scm +++ b/guile-readline/readline.scm @@ -21,11 +21,15 @@ ;;;; Extensions based upon code by ;;;; Andrew Archibald . + + (define-module (ice-9 readline) :use-module (ice-9 session) :use-module (ice-9 regex) :no-backtrace) + + ;;; Dynamically link the glue code for accessing the readline library, ;;; but only when it isn't already present. @@ -39,9 +43,30 @@ '() '())) + + +;;; Run-time options + +(export + readline-options + readline-enable + readline-disable) +(export-syntax + readline-set!) + +(define-option-interface + (readline-options-interface + (readline-options readline-enable readline-disable) + (readline-set!))) + + + ;;; MDJ 980513 : ;;; There should probably be low-level support instead of this code. +;;; Dirk:FIXME:: If the-readline-port, input-port or output-port are closed, +;;; guile will enter an endless loop or crash. + (define prompt "") (define prompt2 "") (define input-port (current-input-port)) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index e4da0a6b0..6ac39d8f7 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,14 @@ +2001-01-26 Dirk Herrmann + + This patch fixes a problem reported by Martin Grabmueller about + the impossibility to access readline's run-time options. + + * boot-9.scm (define-option-interface): New macro. Allows to + conveniently define a group of option interface functions. + + (readline-options readline-enable readline-disable, + readline-set!): Moved to guile-readline/readline.scm. + 2001-01-24 Gary Houston * boot-9.scm: don't import (ice-9 rdelim) here. it's done diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index c929c0617..fc13ebc39 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -2015,97 +2015,96 @@ ;;; {Run-time options} -((let* ((names '((eval-options-interface - (eval-options eval-enable eval-disable) - (eval-set!)) - - (debug-options-interface - (debug-options debug-enable debug-disable) - (debug-set!)) - - (evaluator-traps-interface - (traps trap-enable trap-disable) - (trap-set!)) - - (read-options-interface - (read-options read-enable read-disable) - (read-set!)) - - (print-options-interface - (print-options print-enable print-disable) - (print-set!)) +(define define-option-interface + (let* ((option-name car) + (option-value cadr) + (option-documentation caddr) - (readline-options-interface - (readline-options readline-enable readline-disable) - (readline-set!)) - )) - (option-name car) - (option-value cadr) - (option-documentation caddr) + (print-option (lambda (option) + (display (option-name option)) + (if (< (string-length + (symbol->string (option-name option))) + 8) + (display #\tab)) + (display #\tab) + (display (option-value option)) + (display #\tab) + (display (option-documentation option)) + (newline))) - (print-option (lambda (option) - (display (option-name option)) - (if (< (string-length - (symbol->string (option-name option))) - 8) - (display #\tab)) - (display #\tab) - (display (option-value option)) - (display #\tab) - (display (option-documentation option)) - (newline))) + ;; Below follow the macros defining the run-time option interfaces. - ;; Below follows the macros defining the run-time option interfaces. + (make-options (lambda (interface) + `(lambda args + (cond ((null? args) (,interface)) + ((list? (car args)) + (,interface (car args)) (,interface)) + (else (for-each ,print-option + (,interface #t))))))) - (make-options (lambda (interface) - `(lambda args - (cond ((null? args) (,interface)) - ((list? (car args)) - (,interface (car args)) (,interface)) - (else (for-each ,print-option - (,interface #t))))))) - - (make-enable (lambda (interface) - `(lambda flags - (,interface (append flags (,interface))) - (,interface)))) - - (make-disable (lambda (interface) + (make-enable (lambda (interface) `(lambda flags - (let ((options (,interface))) - (for-each (lambda (flag) - (set! options (delq! flag options))) - flags) - (,interface options) - (,interface))))) + (,interface (append flags (,interface))) + (,interface)))) - (make-set! (lambda (interface) - `((name exp) - (,'quasiquote - (begin (,interface (append (,interface) - (list '(,'unquote name) - (,'unquote exp)))) - (,interface)))))) - ) - (procedure->macro + (make-disable (lambda (interface) + `(lambda flags + (let ((options (,interface))) + (for-each (lambda (flag) + (set! options (delq! flag options))) + flags) + (,interface options) + (,interface))))) + + (make-set! (lambda (interface) + `((name exp) + (,'quasiquote + (begin (,interface (append (,interface) + (list '(,'unquote name) + (,'unquote exp)))) + (,interface))))))) + (procedure->macro (lambda (exp env) (cons 'begin - (apply append - (map (lambda (group) - (let ((interface (car group))) - (append (map (lambda (name constructor) - `(define ,name - ,(constructor interface))) - (cadr group) - (list make-options - make-enable - make-disable)) - (map (lambda (name constructor) - `(defmacro ,name - ,@(constructor interface))) - (caddr group) - (list make-set!))))) - names))))))) + (let* ((option-group (cadr exp)) + (interface (car option-group))) + (append (map (lambda (name constructor) + `(define ,name + ,(constructor interface))) + (cadr option-group) + (list make-options + make-enable + make-disable)) + (map (lambda (name constructor) + `(defmacro ,name + ,@(constructor interface))) + (caddr option-group) + (list make-set!))))))))) + +(define-option-interface + (eval-options-interface + (eval-options eval-enable eval-disable) + (eval-set!))) + +(define-option-interface + (debug-options-interface + (debug-options debug-enable debug-disable) + (debug-set!))) + +(define-option-interface + (evaluator-traps-interface + (traps trap-enable trap-disable) + (trap-set!))) + +(define-option-interface + (read-options-interface + (read-options read-enable read-disable) + (read-set!))) + +(define-option-interface + (print-options-interface + (print-options print-enable print-disable) + (print-set!))) From 13070bd3b0f960b3c541a67d71a6766fd95969cc Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 26 Jan 2001 17:30:54 +0000 Subject: [PATCH 0492/2047] * Added missing includes of string.h. --- libguile/ChangeLog | 5 +++++ libguile/continuations.c | 2 ++ libguile/dynl.c | 2 ++ libguile/keywords.c | 2 ++ libguile/load.c | 2 ++ 5 files changed, 13 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 8c3271045..38720c2ed 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-01-26 Dirk Herrmann + + * continuations.c, dynl.c, keywords.c, load.c: Include + strings.h. Thanks to Bill Schottstaedt for the bug report. + 2001-01-25 Dirk Herrmann * backtrace.c (display_header): Make sure that line and column diff --git a/libguile/continuations.c b/libguile/continuations.c index 8a160e91b..ee1e7cb77 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -45,6 +45,8 @@ #include +#include + #include "libguile/_scm.h" #include "libguile/root.h" #include "libguile/stackchk.h" diff --git a/libguile/dynl.c b/libguile/dynl.c index e3e971be7..1fa856cc6 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -65,6 +65,8 @@ maybe_drag_in_eprintf () #endif #include +#include + #include "libguile/_scm.h" #include "libguile/dynl.h" #include "libguile/smob.h" diff --git a/libguile/keywords.c b/libguile/keywords.c index f14627144..78563bc92 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -45,6 +45,8 @@ #include +#include + #include "libguile/_scm.h" #include "libguile/ports.h" #include "libguile/root.h" diff --git a/libguile/load.c b/libguile/load.c index fee5e1893..af78ea6f9 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -45,6 +45,8 @@ #include +#include + #include "libguile/_scm.h" #include "libguile/libpath.h" #include "libguile/fports.h" From a49af0c0f790e83a30e7f186729b1319bab8c6fb Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 26 Jan 2001 18:04:32 +0000 Subject: [PATCH 0493/2047] * Fix parameter error reporting and avoid redundant parameter checks. --- libguile/ChangeLog | 15 ++++++ libguile/strop.c | 111 ++++++++++++++++++++++++++++++++------------- 2 files changed, 95 insertions(+), 31 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 38720c2ed..b4b7a2df7 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,18 @@ +2001-01-26 Dirk Herrmann + + The following patch was sent by Martin Grabmueller. It makes sure + that in case of parameter errors the correct function name is + shown, and that parameter types are only checked once. + + * strop.c (string_copy, string_upcase_x, string_downcase_x, + string_capitalize_x): New functions. Each one performs the core + functionality of the corresponding scm_* function. + + (scm_string_copy, scm_string_upcase_x, scm_string_upcase, + scm_string_downcase_x, scm_string_downcase, + scm_string_capitalize_x, scm_string_capitalize): Reduced to + parameter checking wrappers of the above functions. + 2001-01-26 Dirk Herrmann * continuations.c, dynl.c, keywords.c, load.c: Include diff --git a/libguile/strop.c b/libguile/strop.c index fd78a9f3f..1ad572283 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -330,14 +330,23 @@ SCM_DEFINE (scm_string_to_list, "string->list", 1, 0, 0, #undef FUNC_NAME +/* Helper function for the string copy and string conversion functions. + * No argument checking is performed. */ +static SCM +string_copy (SCM str) +{ + return scm_makfromstr (SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str), 0); +} + SCM_DEFINE (scm_string_copy, "string-copy", 1, 0, 0, - (SCM str), + (SCM str), "Returns a newly allocated copy of the given @var{string}. (r5rs)") #define FUNC_NAME s_scm_string_copy { SCM_VALIDATE_STRING (1, str); - return scm_makfromstr (SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str), 0); + + return string_copy (str); } #undef FUNC_NAME @@ -357,8 +366,23 @@ SCM_DEFINE (scm_string_fill_x, "string-fill!", 2, 0, 0, } #undef FUNC_NAME + +/* Helper function for the string uppercase conversion functions. + * No argument checking is performed. */ +static SCM +string_upcase_x (SCM v) +{ + unsigned long k; + + for (k = 0; k < SCM_STRING_LENGTH (v); ++k) + SCM_STRING_UCHARS (v) [k] = scm_upcase (SCM_STRING_UCHARS (v) [k]); + + return v; +} + + SCM_DEFINE (scm_string_upcase_x, "string-upcase!", 1, 0, 0, - (SCM v), + (SCM str), "Destructively upcase every character in @code{str}.\n\n" "(qdocs:) Converts each element in @var{str} to upper case.\n\n" "@example\n" @@ -369,28 +393,41 @@ SCM_DEFINE (scm_string_upcase_x, "string-upcase!", 1, 0, 0, "@end example") #define FUNC_NAME s_scm_string_upcase_x { - unsigned long k; + SCM_VALIDATE_STRING (1, str); - SCM_VALIDATE_STRING (1, v); - - for (k = 0; k < SCM_STRING_LENGTH (v); ++k) - SCM_STRING_UCHARS (v) [k] = scm_upcase (SCM_STRING_UCHARS (v) [k]); - - return v; + return string_upcase_x (str); } #undef FUNC_NAME + SCM_DEFINE (scm_string_upcase, "string-upcase", 1, 0, 0, - (SCM str), + (SCM str), "Upcase every character in @code{str}.") #define FUNC_NAME s_scm_string_upcase { - return scm_string_upcase_x(scm_string_copy(str)); + SCM_VALIDATE_STRING (1, str); + + return string_upcase_x (string_copy (str)); } #undef FUNC_NAME + +/* Helper function for the string lowercase conversion functions. + * No argument checking is performed. */ +static SCM +string_downcase_x (SCM v) +{ + unsigned long k; + + for (k = 0; k < SCM_STRING_LENGTH (v); ++k) + SCM_STRING_UCHARS (v) [k] = scm_downcase (SCM_STRING_UCHARS (v) [k]); + + return v; +} + + SCM_DEFINE (scm_string_downcase_x, "string-downcase!", 1, 0, 0, - (SCM v), + (SCM str), "Destructively downcase every character in @code{str}.\n\n" "(qdocs:) Converts each element in @var{str} to lower case.\n\n" "@example\n" @@ -403,35 +440,33 @@ SCM_DEFINE (scm_string_downcase_x, "string-downcase!", 1, 0, 0, "@end example") #define FUNC_NAME s_scm_string_downcase_x { - unsigned long k; + SCM_VALIDATE_STRING (1, str); - SCM_VALIDATE_STRING (1, v); - - for (k = 0; k < SCM_STRING_LENGTH (v); ++k) - SCM_STRING_UCHARS (v) [k] = scm_downcase (SCM_STRING_UCHARS (v) [k]); - - return v; + return string_downcase_x (str); } #undef FUNC_NAME + SCM_DEFINE (scm_string_downcase, "string-downcase", 1, 0, 0, - (SCM str), + (SCM str), "Downcase every character in @code{str}.") #define FUNC_NAME s_scm_string_downcase { - SCM_VALIDATE_STRING (1,str); - return scm_string_downcase_x(scm_string_copy(str)); + SCM_VALIDATE_STRING (1, str); + + return string_downcase_x (string_copy (str)); } #undef FUNC_NAME -SCM_DEFINE (scm_string_capitalize_x, "string-capitalize!", 1, 0, 0, - (SCM str), - "Destructively capitalize every character in @code{str}.") -#define FUNC_NAME s_scm_string_capitalize_x + +/* Helper function for the string capitalization functions. + * No argument checking is performed. */ +static SCM +string_capitalize_x (SCM str) { char *sz; int i, len, in_word=0; - SCM_VALIDATE_STRING (1,str); + len = SCM_STRING_LENGTH(str); sz = SCM_STRING_CHARS (str); for(i=0; isymbol", 1, 0, 0, (SCM str), "Return the symbol whose name is @var{str}, downcased in necessary(???).") From b6311c08329b4052a9dea7377ac410ce16516d54 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sat, 27 Jan 2001 00:13:55 +0000 Subject: [PATCH 0494/2047] goops.c (s_scm_get_keyword): Bug fix. --- libguile/ChangeLog | 4 ++++ libguile/goops.c | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b4b7a2df7..eb8a51143 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2001-01-26 Keisuke Nishida + + * goops.c (s_scm_get_keyword): Bug fix. + 2001-01-26 Dirk Herrmann The following patch was sent by Martin Grabmueller. It makes sure diff --git a/libguile/goops.c b/libguile/goops.c index 4d7ce1484..07c494e25 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -378,7 +378,7 @@ SCM_DEFINE (scm_get_keyword, "get-keyword", 3, 0, 0, SCM_ASSERT (SCM_KEYWORDP (key), key, SCM_ARG1, FUNC_NAME); len = scm_ilength (l); - if (len < 0 || len % 1 == 1) + if (len < 0 || len % 2 == 1) scm_misc_error (FUNC_NAME, "Bad keyword-value list: ~S", SCM_LIST1 (l)); return scm_i_get_keyword (key, l, len, default_value, FUNC_NAME); From 539fdb77e0a7d8fbb1c3bce2385daa1adb2aa4ae Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 28 Jan 2001 17:56:34 +0000 Subject: [PATCH 0495/2047] * readline.scm (make-readline-port): PROMPT becomes PROMPT2 as soon as GET-CHARACTER returns any character at all that was previously read. This makes the continuation prompt appear properly for partial expressions. Thanks to Neil Jerram! --- guile-readline/readline.scm | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/guile-readline/readline.scm b/guile-readline/readline.scm index 8d499d5aa..6d482c4e2 100644 --- a/guile-readline/readline.scm +++ b/guile-readline/readline.scm @@ -98,15 +98,14 @@ (if (not (eof-object? read-string)) (begin (or (string=? read-string "") - (begin - (add-history read-string) - (set! prompt prompt2))) + (add-history read-string)) (get-character)) read-string))) (else (let ((res (string-ref read-string string-index))) (set! string-index (+ 1 string-index)) - res)))))) + (set! prompt prompt2) + res)))))) (make-soft-port (vector #f #f #f get-character #f) "r")))) From d42b03fd66f4ab537de9abe988d9020928749463 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 28 Jan 2001 17:56:46 +0000 Subject: [PATCH 0496/2047] *** empty log message *** --- guile-readline/ChangeLog | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 546d3637a..9f1a09a72 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,10 @@ +2001-01-28 Marius Vollmer + + * readline.scm (make-readline-port): PROMPT becomes PROMPT2 as + soon as GET-CHARACTER returns any character at all that was + previously read. This makes the continuation prompt appear + properly for partial expressions. Thanks to Neil Jerram! + 2001-01-26 Dirk Herrmann This patch fixes a problem reported by Martin Grabmueller about From 41ee56dde37d65598ec82de66fbd3c984292eafb Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Mon, 29 Jan 2001 18:23:34 +0000 Subject: [PATCH 0497/2047] * eval.c (SCM_APPLY): Check that primitives which take 1 arg really get that arg. --- libguile/ChangeLog | 5 +++++ libguile/eval.c | 1 + 2 files changed, 6 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index eb8a51143..8123b7241 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-01-29 Mikael Djurfeldt + + * eval.c (SCM_APPLY): Check that primitives which take 1 arg + really get that arg. + 2001-01-26 Keisuke Nishida * goops.c (s_scm_get_keyword): Bug fix. diff --git a/libguile/eval.c b/libguile/eval.c index 62bef0b4b..eaef7570e 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3302,6 +3302,7 @@ tail: SCM_ASRTGO (SCM_UNBNDP (arg1), wrongnumargs); RETURN (SCM_SUBRF (proc) ()) case scm_tc7_subr_1: + SCM_ASRTGO (!SCM_UNBNDP (arg1), wrongnumargs); case scm_tc7_subr_1o: SCM_ASRTGO (SCM_NULLP (args), wrongnumargs); RETURN (SCM_SUBRF (proc) (arg1)) From e32398681a4c31260ce85e087f17edb29962b14c Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 30 Jan 2001 14:53:20 +0000 Subject: [PATCH 0498/2047] * Added docstrings by Martin Grabmueller. --- libguile/ChangeLog | 16 ++++++++++++++ libguile/sort.c | 54 ++++++++++++++++++++++++++++++++++++---------- libguile/srcprop.c | 11 ++++++---- libguile/struct.c | 13 +++++------ libguile/weaks.c | 10 +++++---- 5 files changed, 79 insertions(+), 25 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 8123b7241..3477aa69e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,19 @@ +2001-01-29 Martin Grabmueller + + * struct.c (scm_make_vtable_vtable): Removed unnecessary "" from + end of docstring. + + * struct.c (scm_struct_set_x, scm_struct_vtable_tag, + scm_struct_vtable_name, scm_set_struct_vtable_name_x), weaks.c + (scm_make_weak_value_hash_table, scm_make_doubly_weak_hash_table, + scm_weak_value_hash_table_p, scm_doubly_weak_hash_table_p), + srcprop.c (scm_source_properties, scm_set_source_properties_x, + scm_source_property, scm_set_source_property_x), sort.c + (scm_sort_list_x, scm_restricted_vector_sort_x, scm_sorted_p, + scm_merge, scm_merge_x, scm_sort_x, scm_sort, scm_stable_sort_x, + scm_stable_sort, scm_sort_list_x, scm_sort_list): Added + docstrings. + 2001-01-29 Mikael Djurfeldt * eval.c (SCM_APPLY): Check that primitives which take 1 arg diff --git a/libguile/sort.c b/libguile/sort.c index e25f19cd9..8b7dd62da 100644 --- a/libguile/sort.c +++ b/libguile/sort.c @@ -418,7 +418,10 @@ scm_cmp_function (SCM p) SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0, (SCM vec, SCM less, SCM startpos, SCM endpos), -"") + "Sort the vector @var{vec}, using @var{less} for comparing\n" + "the vector elements. @var{startpos} and @var{endpos} delimit\n" + "the range of the vector which gets sorted. The return value\n" + "is not specified.") #define FUNC_NAME s_scm_restricted_vector_sort_x { size_t vlen, spos, len, size = sizeof (SCM); @@ -447,7 +450,9 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0, * (not (less? (list-ref list i) (list-ref list (- i 1)))). */ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0, (SCM items, SCM less), -"") + "Return @code{#t} iff @var{items} is a list or a vector such that\n" + "for all 1 <= i <= m, the predicate @var{less} returns true when\n" + "applied to all elements i - 1 and i") #define FUNC_NAME s_scm_sorted_p { long len, j; /* list/vector length, temp j */ @@ -514,7 +519,12 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0, Note: this does _not_ accept vectors. */ SCM_DEFINE (scm_merge, "merge", 3, 0, 0, (SCM alist, SCM blist, SCM less), -"") + "Takes two lists @var{alist} and @var{blist} such that\n" + "@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and\n" + "returns a new list in which the elements of @var{alist} and\n" + "@var{blist} have been stably interleaved so that\n" + "@code{(sorted? (merge alist blist less?) less?)}.\n" + "Note: this does _not_ accept vectors.") #define FUNC_NAME s_scm_merge { long alen, blen; /* list lengths */ @@ -621,7 +631,13 @@ scm_merge_list_x (SCM alist, SCM blist, SCM_DEFINE (scm_merge_x, "merge!", 3, 0, 0, (SCM alist, SCM blist, SCM less), -"") + "Takes two lists @var{alist} and @var{blist} such that\n" + "@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and\n" + "returns a new list in which the elements of @var{alist} and\n" + "@var{blist} have been stably interleaved so that\n" + " @code{(sorted? (merge alist blist less?) less?)}.\n" + "This is the destructive variant of @code{merge}\n" + "Note: this does _not_ accept vectors.") #define FUNC_NAME s_scm_merge_x { long alen, blen; /* list lengths */ @@ -693,7 +709,11 @@ scm_merge_list_step (SCM * seq, /* scm_sort_x manages lists and vectors, not stable sort */ SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0, (SCM items, SCM less), -"") + "Sort the sequence @var{items}, which may be a list or a\n" + "vector. @var{less} is used for comparing the sequence\n" + "elements. The sorting is destructive, that means that the\n" + "input sequence is modified to produce the sorted result.\n" + "This is not a stable sort.") #define FUNC_NAME s_scm_sort_x { long len; /* list/vector length */ @@ -725,7 +745,9 @@ SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0, SCM_DEFINE (scm_sort, "sort", 2, 0, 0, (SCM items, SCM less), -"") + "Sort the sequence @var{items}, which may be a list or a\n" + "vector. @var{less} is used for comparing the sequence\n" + "elements. This is not a stable sort.") #define FUNC_NAME s_scm_sort { SCM sortvec; /* the vector we actually sort */ @@ -816,7 +838,11 @@ scm_merge_vector_step (void *const vp, SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0, (SCM items, SCM less), -"") + "Sort the sequence @var{items}, which may be a list or a\n" + "vector. @var{less} is used for comparing the sequence elements.\n" + "The sorting is destructive, that means that the input sequence\n" + "is modified to produce the sorted result.\n" + "This is a stable sort.") #define FUNC_NAME s_scm_stable_sort_x { long len; /* list/vector length */ @@ -854,7 +880,9 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0, SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0, (SCM items, SCM less), -"") + "Sort the sequence @var{items}, which may be a list or a\n" + "vector. @var{less} is used for comparing the sequence elements.\n" + "This is a stable sort.") #define FUNC_NAME s_scm_stable_sort { long len; /* list/vector length */ @@ -897,7 +925,10 @@ SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0, /* stable */ SCM_DEFINE (scm_sort_list_x, "sort-list!", 2, 0, 0, (SCM items, SCM less), -"") + "Sort the list @var{items}, using @var{less} for comparing the\n" + "list elements. The sorting is destructive, that means that the\n" + "input list is modified to produce the sorted result.\n" + "This is a stable sort.") #define FUNC_NAME s_scm_sort_list_x { long len; @@ -909,8 +940,9 @@ SCM_DEFINE (scm_sort_list_x, "sort-list!", 2, 0, 0, /* stable */ SCM_DEFINE (scm_sort_list, "sort-list", 2, 0, 0, - (SCM items, SCM less), -"") + (SCM items, SCM less), + "Sort the list @var{items}, using @var{less} for comparing the\n" + "list elements. This is a stable sort.") #define FUNC_NAME s_scm_sort_list { long len; diff --git a/libguile/srcprop.c b/libguile/srcprop.c index f17125f91..341c9a670 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -167,7 +167,7 @@ scm_srcprops_to_plist (SCM obj) SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0, (SCM obj), -"") + "Return the source property association list of @var{obj}.") #define FUNC_NAME s_scm_source_properties { SCM p; @@ -189,7 +189,8 @@ SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0, and try to make a srcprops-object...? */ SCM_DEFINE (scm_set_source_properties_x, "set-source-properties!", 2, 0, 0, (SCM obj, SCM plist), -"") + "Install the association list @var{plist} as the source property\n" + "list for @var{obj}.") #define FUNC_NAME s_scm_set_source_properties_x { SCM handle; @@ -208,7 +209,8 @@ SCM_DEFINE (scm_set_source_properties_x, "set-source-properties!", 2, 0, 0, SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0, (SCM obj, SCM key), -"") + "Return the source property specified by @var{key} from\n" + "@var{obj}'s source property list.") #define FUNC_NAME s_scm_source_property { SCM p; @@ -240,7 +242,8 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0, SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0, (SCM obj, SCM key, SCM datum), -"") + "Set the source property of object @var{obj}, which is specified by\n" + "@var{key} to @var{datum}. Normally, the key will be a symbol.") #define FUNC_NAME s_scm_set_source_property_x { scm_whash_handle h; diff --git a/libguile/struct.c b/libguile/struct.c index 5c533f172..0746c0b9f 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -513,8 +513,7 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, "(define (make-ball type owner) (make-struct type 0 owner))\n\n" "(define ball (make-ball green 'Nisse))\n" "ball @result{} #\n" - "@end example\n" - "") + "@end example\n") #define FUNC_NAME s_scm_make_vtable_vtable { SCM fields; @@ -637,7 +636,9 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0, SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0, (SCM handle, SCM pos, SCM val), - "") + "Set the slot of the structure @var{handle} with index @var{pos}\n" + "to @var{val}. Signal an error if the slot can not be written\n" + "to.") #define FUNC_NAME s_scm_struct_set_x { scm_bits_t * data; @@ -722,7 +723,7 @@ SCM_DEFINE (scm_struct_vtable, "struct-vtable", 1, 0, 0, SCM_DEFINE (scm_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0, (SCM handle), - "") + "Return the vtable tag of the structure @var{handle}.") #define FUNC_NAME s_scm_struct_vtable_tag { SCM_VALIDATE_VTABLE (1,handle); @@ -761,7 +762,7 @@ scm_struct_create_handle (SCM obj) SCM_DEFINE (scm_struct_vtable_name, "struct-vtable-name", 1, 0, 0, (SCM vtable), - "") + "Return the name of the vtable @var{vtable}.") #define FUNC_NAME s_scm_struct_vtable_name { SCM_VALIDATE_VTABLE (1,vtable); @@ -771,7 +772,7 @@ SCM_DEFINE (scm_struct_vtable_name, "struct-vtable-name", 1, 0, 0, SCM_DEFINE (scm_set_struct_vtable_name_x, "set-struct-vtable-name!", 2, 0, 0, (SCM vtable, SCM name), - "") + "Set the name of the vtable @var{vtable} to @var{name}.") #define FUNC_NAME s_scm_set_struct_vtable_name_x { SCM_VALIDATE_VTABLE (1,vtable); diff --git a/libguile/weaks.c b/libguile/weaks.c index f0b006a5a..f340922fe 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -144,7 +144,8 @@ SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 1, 0, 0, SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 1, 0, 0, (SCM k), - "") + "Return a hash table with weak values with @var{size} buckets.\n" + "(@pxref{Hash Tables})") #define FUNC_NAME s_scm_make_weak_value_hash_table { SCM v; @@ -161,7 +162,8 @@ SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 1, 0, SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0, (SCM k), - "") + "Return a hash table with weak keys and values with @var{size}\n" + "buckets. (@pxref{Hash Tables})") #define FUNC_NAME s_scm_make_doubly_weak_hash_table { SCM v; @@ -190,7 +192,7 @@ SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0, SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0, (SCM x), - "") + "Return @var{#t} if @var{x} is a weak value hash table.") #define FUNC_NAME s_scm_weak_value_hash_table_p { return SCM_BOOL(SCM_WVECTP (x) && SCM_IS_WHVEC_V(x)); @@ -200,7 +202,7 @@ SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0, SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0, (SCM x), - "") + "Return @var{#t} if @var{x} is a doubly weak hash table.") #define FUNC_NAME s_scm_doubly_weak_hash_table_p { return SCM_BOOL(SCM_WVECTP (x) && SCM_IS_WHVEC_B (x)); From c2886a5ae11f376ff8e7c8307d96f7ad96bc407e Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 31 Jan 2001 15:14:53 +0000 Subject: [PATCH 0499/2047] Added #include "libguile/rdelim.h". --- ChangeLog | 4 ++++ libguile.h | 3 ++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 7214bff2a..7ea07ec79 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2001-01-29 Mikael Djurfeldt + + * libguile.h: Added #include "libguile/rdelim.h". + 2001-01-26 Dirk Herrmann The following patch was sent by Thien-Thi Nguyen. diff --git a/libguile.h b/libguile.h index 71e641564..1ab96bf41 100644 --- a/libguile.h +++ b/libguile.h @@ -1,7 +1,7 @@ #ifndef LIBGUILEH #define LIBGUILEH -/* Copyright (C) 1995, 1996, 1997, 1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001 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 @@ -85,6 +85,7 @@ extern "C" { #include "libguile/hashtab.h" #include "libguile/init.h" #include "libguile/ioext.h" +#include "libguile/rdelim.h" #include "libguile/keywords.h" #include "libguile/list.h" #include "libguile/load.h" From b8446ce883e7155def42f479a39b6a870b318720 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 31 Jan 2001 15:18:47 +0000 Subject: [PATCH 0500/2047] * unif.c (rapr1): Don't apply scm_uniform_vector_length on arrays. --- libguile/ChangeLog | 4 ++++ libguile/unif.c | 6 ++++-- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 3477aa69e..89e41586b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2001-01-31 Mikael Djurfeldt + + * unif.c (rapr1): Don't apply scm_uniform_vector_length on arrays. + 2001-01-29 Martin Grabmueller * struct.c (scm_make_vtable_vtable): Removed unnecessary "" from diff --git a/libguile/unif.c b/libguile/unif.c index 96d1fd472..0eef7cfc4 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998, 2000, 2001 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 @@ -2225,7 +2225,9 @@ static void rapr1 (SCM ra,scm_sizet j,scm_sizet k,SCM port,scm_print_state *pstate) { long inc = 1; - long n = SCM_INUM (scm_uniform_vector_length (ra)); + long n = (SCM_TYP7 (ra) == scm_tc7_smob + ? 0 + : SCM_INUM (scm_uniform_vector_length (ra))); int enclosed = 0; tail: switch SCM_TYP7 (ra) From 00ffa0e7d666ed7d7b4f7a63c95de69d18e2bee8 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 2 Feb 2001 04:56:25 +0000 Subject: [PATCH 0501/2047] New functions: scm_c_make_vector, scm_c_make_hash_table. --- libguile/ChangeLog | 24 ++++++++++++++++++++++++ libguile/environments.c | 4 ++-- libguile/eval.c | 2 +- libguile/filesys.c | 2 +- libguile/fluids.c | 5 ++--- libguile/gc.c | 8 ++++---- libguile/gh_data.c | 4 ++-- libguile/goops.c | 10 +++++----- libguile/hashtab.c | 5 +++++ libguile/hashtab.h | 2 ++ libguile/keywords.c | 4 ++-- libguile/net_db.c | 8 ++++---- libguile/posix.c | 8 ++++---- libguile/print.c | 5 ++--- libguile/regex-posix.c | 2 +- libguile/scmsigs.c | 3 +-- libguile/socket.c | 4 ++-- libguile/stime.c | 4 ++-- libguile/symbols.c | 3 ++- libguile/unif.c | 4 ++-- libguile/vectors.c | 26 +++++++++++++++----------- libguile/vectors.h | 2 ++ 22 files changed, 87 insertions(+), 52 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 89e41586b..d7d1e2b0d 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,27 @@ +2001-02-01 Keisuke Nishida + + * vectors.c (scm_c_make_vector): New function. + * vectors.h (scm_c_make_vector): Declared. + * eval.c (scm_copy_tree), filesys.c (scm_stat2scm), fluids.c + (scm_make_initial_fluids, grow_fluids), gc.c (scm_init_storage), + gh_data.c (gh_ints2scm, gh_doubles2scm): goops.c + (scm_make_method_cache, scm_i_vector2list, + scm_compute_applicable_methods, scm_sys_method_more_specific_p), + init.c (start_stack), net_db.c (scm_gethost, scm_getnet, + scm_getproto, scm_return_entry), posix.c (scm_getgroups, + scm_getpwuid, scm_getgrgid, scm_uname), print.c (make_print_state, + grow_ref_stack), regex-posix.c (scm_regexp_exec), scmsigs.c + (scm_init_scmsigs), socket.c (scm_addr_vector, scm_addr_vector), + stime.c (scm_times, filltime), unif.c (scm_make_uve), vectors.c + (scm_vector, scm_make_vector): Use scm_c_make_vector. + + * hashtab.c (scm_c_make_hash_table): New function. + * hashtab.h (scm_c_make_hash_table): Declared. + * environments.c (scm_make_leaf_environment, + scm_make_eval_environment), gc.c (scm_init_storage), + keywords.c (scm_init_keywords), symbols.c (scm_builtin_bindings): + Use scm_c_make_hash_table. + 2001-01-31 Mikael Djurfeldt * unif.c (rapr1): Don't apply scm_uniform_vector_length on arrays. diff --git a/libguile/environments.c b/libguile/environments.c index 8e42afa58..710d29ad1 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -1032,7 +1032,7 @@ SCM_DEFINE (scm_make_leaf_environment, "make-leaf-environment", 0, 0, 0, env = scm_make_environment (body); core_environments_init (&body->base, &leaf_environment_funcs); - body->obarray = scm_make_vector (SCM_MAKINUM (DEFAULT_OBARRAY_SIZE), SCM_EOL); + body->obarray = scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE); return env; } @@ -1424,7 +1424,7 @@ SCM_DEFINE (scm_make_eval_environment, "make-eval-environment", 2, 0, 0, env = scm_make_environment (body); core_environments_init (&body->base, &eval_environment_funcs); - body->obarray = scm_make_vector (SCM_MAKINUM (DEFAULT_OBARRAY_SIZE), SCM_EOL); + body->obarray = scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE); body->imported = imported; body->imported_observer = SCM_ENVIRONMENT_OBSERVE (imported, eval_environment_observer, env, 1); diff --git a/libguile/eval.c b/libguile/eval.c index eaef7570e..b1cc84f96 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3760,7 +3760,7 @@ SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0, if (SCM_VECTORP (obj)) { scm_sizet i = SCM_VECTOR_LENGTH (obj); - ans = scm_make_vector (SCM_MAKINUM (i), SCM_UNSPECIFIED); + ans = scm_c_make_vector (i, SCM_UNSPECIFIED); while (i--) SCM_VELTS (ans)[i] = scm_copy_tree (SCM_VELTS (obj)[i]); return ans; diff --git a/libguile/filesys.c b/libguile/filesys.c index 1b4fe2b68..a809e7f36 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -373,7 +373,7 @@ SCM_SYMBOL (scm_sym_unknown, "unknown"); static SCM scm_stat2scm (struct stat *stat_temp) { - SCM ans = scm_make_vector (SCM_MAKINUM (15), SCM_UNSPECIFIED); + SCM ans = scm_c_make_vector (15, SCM_UNSPECIFIED); SCM *ve = SCM_VELTS (ans); ve[0] = scm_ulong2num ((unsigned long) stat_temp->st_dev); diff --git a/libguile/fluids.c b/libguile/fluids.c index bcac1f824..a52b2c8df 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -61,8 +61,7 @@ scm_bits_t scm_tc16_fluid; SCM scm_make_initial_fluids () { - return scm_make_vector (SCM_MAKINUM (INITIAL_FLUIDS), - SCM_BOOL_F); + return scm_c_make_vector (INITIAL_FLUIDS, SCM_BOOL_F); } static void @@ -73,7 +72,7 @@ grow_fluids (scm_root_state *root_state, int new_length) old_fluids = root_state->fluids; old_length = SCM_VECTOR_LENGTH (old_fluids); - new_fluids = scm_make_vector (SCM_MAKINUM (new_length), SCM_BOOL_F); + new_fluids = scm_c_make_vector (new_length, SCM_BOOL_F); i = 0; while (i < old_length) { diff --git a/libguile/gc.c b/libguile/gc.c index 5d4aa0063..0057ed372 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -2614,15 +2614,15 @@ scm_init_storage () scm_listofnull = scm_cons (SCM_EOL, SCM_EOL); scm_nullstr = scm_makstr (0L, 0); - scm_nullvect = scm_make_vector (SCM_INUM0, SCM_UNDEFINED); + scm_nullvect = scm_c_make_vector (0, SCM_UNDEFINED); #define DEFAULT_SYMHASH_SIZE 277 - scm_symhash = scm_make_vector (SCM_MAKINUM (DEFAULT_SYMHASH_SIZE), SCM_EOL); - scm_symhash_vars = scm_make_vector (SCM_MAKINUM (DEFAULT_SYMHASH_SIZE), SCM_EOL); + scm_symhash = scm_c_make_hash_table (DEFAULT_SYMHASH_SIZE); + scm_symhash_vars = scm_c_make_hash_table (DEFAULT_SYMHASH_SIZE); scm_stand_in_procs = SCM_EOL; scm_permobjs = SCM_EOL; - scm_protects = scm_make_vector (SCM_MAKINUM (31), SCM_EOL); + scm_protects = scm_c_make_hash_table (31); return 0; } diff --git a/libguile/gh_data.c b/libguile/gh_data.c index 5597e9a88..6e7eab19c 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -136,7 +136,7 @@ SCM gh_ints2scm (int *d, int n) { int i; - SCM v = scm_make_vector(SCM_MAKINUM(n), SCM_UNSPECIFIED); + SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED); SCM *velts = SCM_VELTS(v); for (i = 0; i < n; ++i) @@ -149,7 +149,7 @@ SCM gh_doubles2scm (const double *d, int n) { int i; - SCM v = scm_make_vector(SCM_MAKINUM(n), SCM_UNSPECIFIED); + SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED); SCM *velts = SCM_VELTS(v); for(i = 0; i < n; i++) diff --git a/libguile/goops.c b/libguile/goops.c index 07c494e25..9794aca6f 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1537,8 +1537,8 @@ SCM scm_make_method_cache (SCM gf) { return SCM_LIST5 (SCM_IM_DISPATCH, scm_sym_args, SCM_MAKINUM (1), - scm_make_vector (SCM_MAKINUM (SCM_INITIAL_MCACHE_SIZE), - list_of_no_method), + scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE, + list_of_no_method), gf); } @@ -1693,7 +1693,7 @@ static SCM scm_i_vector2list (SCM l, int len) { int j; - SCM z = scm_make_vector (SCM_MAKINUM (len), SCM_UNDEFINED); + SCM z = scm_c_make_vector (len, SCM_UNDEFINED); for (j = 0; j < len; j++, l = SCM_CDR (l)) { SCM_VELTS (z)[j] = SCM_CAR (l); @@ -1777,7 +1777,7 @@ scm_compute_applicable_methods (SCM gf, SCM args, int len, int find_method_p) /* Build the list of arguments types */ if (len >= BUFFSIZE) { - tmp = scm_make_vector (SCM_MAKINUM (len), SCM_UNDEFINED); + tmp = scm_c_make_vector (len, SCM_UNDEFINED); /* NOTE: Using pointers to malloced memory won't work if we 1. have preemtive threading, and, 2. have a GC which moves objects. */ @@ -2087,7 +2087,7 @@ SCM_DEFINE (scm_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0, SCM_ASSERT ((len = scm_ilength (targs)) != -1, targs, SCM_ARG3, FUNC_NAME); /* Verify that all the arguments of targs are classes and place them in a vector*/ - v = scm_make_vector (SCM_MAKINUM (len), SCM_EOL); + v = scm_c_make_vector (len, SCM_EOL); for (i=0, l=targs; SCM_NNULLP(l); i++, l=SCM_CDR(l)) { SCM_ASSERT (SCM_CLASSP (SCM_CAR (l)), targs, SCM_ARG3, FUNC_NAME); diff --git a/libguile/hashtab.c b/libguile/hashtab.c index 1efb64781..1f001f236 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -55,6 +55,11 @@ #include "libguile/hashtab.h" +SCM +scm_c_make_hash_table (unsigned long k) +{ + return scm_c_make_vector (k, SCM_EOL); +} SCM scm_hash_fn_get_handle (SCM table,SCM obj,unsigned int (*hash_fn)(),SCM (*assoc_fn)(),void * closure) diff --git a/libguile/hashtab.h b/libguile/hashtab.h index b05979a3a..ff79cc701 100644 --- a/libguile/hashtab.h +++ b/libguile/hashtab.h @@ -53,6 +53,8 @@ typedef SCM scm_assoc_fn_t (SCM key, SCM alist, void *closure); typedef SCM scm_delete_fn_t (SCM elt, SCM list); #endif +extern SCM scm_c_make_hash_table (unsigned long k); + extern SCM scm_hash_fn_get_handle (SCM table, SCM obj, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), void * closure); extern SCM scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), void * closure); extern SCM scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), void * closure); diff --git a/libguile/keywords.c b/libguile/keywords.c index 78563bc92..c979d4123 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -51,7 +51,7 @@ #include "libguile/ports.h" #include "libguile/root.h" #include "libguile/smob.h" -#include "libguile/vectors.h" +#include "libguile/hashtab.h" #include "libguile/validate.h" #include "libguile/keywords.h" @@ -139,7 +139,7 @@ scm_init_keywords () scm_set_smob_mark (scm_tc16_keyword, scm_markcdr); scm_set_smob_print (scm_tc16_keyword, keyword_print); - scm_keyword_obarray = scm_make_vector (SCM_MAKINUM (256), SCM_EOL); + scm_keyword_obarray = scm_c_make_hash_table (256); #ifndef SCM_MAGIC_SNARFER #include "libguile/keywords.x" #endif diff --git a/libguile/net_db.c b/libguile/net_db.c index 9e92c7071..19a826d09 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -251,7 +251,7 @@ SCM_DEFINE (scm_gethost, "gethost", 0, 1, 0, "@code{system-error} or @code{misc_error} keys.") #define FUNC_NAME s_scm_gethost { - SCM ans = scm_make_vector (SCM_MAKINUM (5), SCM_UNSPECIFIED); + SCM ans = scm_c_make_vector (5, SCM_UNSPECIFIED); SCM *ve = SCM_VELTS (ans); SCM lst = SCM_EOL; struct hostent *entry; @@ -336,7 +336,7 @@ SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0, SCM *ve; struct netent *entry; - ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED); + ans = scm_c_make_vector (4, SCM_UNSPECIFIED); ve = SCM_VELTS (ans); if (SCM_UNBNDP (net)) { @@ -388,7 +388,7 @@ SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0, SCM *ve; struct protoent *entry; - ans = scm_make_vector (SCM_MAKINUM (3), SCM_UNSPECIFIED); + ans = scm_c_make_vector (3, SCM_UNSPECIFIED); ve = SCM_VELTS (ans); if (SCM_UNBNDP (protocol)) { @@ -430,7 +430,7 @@ scm_return_entry (struct servent *entry) SCM ans; SCM *ve; - ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED); + ans = scm_c_make_vector (4, SCM_UNSPECIFIED); ve = SCM_VELTS (ans); ve[0] = scm_makfromstr (entry->s_name, (scm_sizet) strlen (entry->s_name), 0); ve[1] = scm_makfromstrs (-1, entry->s_aliases); diff --git a/libguile/posix.c b/libguile/posix.c index b766cb4c1..c85ec6c28 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -217,7 +217,7 @@ SCM_DEFINE (scm_getgroups, "getgroups", 0, 0, 0, groups = scm_must_malloc (size, FUNC_NAME); getgroups (ngroups, groups); - ans = scm_make_vector (SCM_MAKINUM (ngroups), SCM_UNDEFINED); + ans = scm_c_make_vector (ngroups, SCM_UNDEFINED); while (--ngroups >= 0) SCM_VELTS (ans) [ngroups] = SCM_MAKINUM (groups [ngroups]); @@ -241,7 +241,7 @@ SCM_DEFINE (scm_getpwuid, "getpw", 0, 1, 0, struct passwd *entry; SCM *ve; - result = scm_make_vector (SCM_MAKINUM (7), SCM_UNSPECIFIED); + result = scm_c_make_vector (7, SCM_UNSPECIFIED); ve = SCM_VELTS (result); if (SCM_UNBNDP (user) || SCM_FALSEP (user)) { @@ -312,7 +312,7 @@ SCM_DEFINE (scm_getgrgid, "getgr", 0, 1, 0, SCM result; struct group *entry; SCM *ve; - result = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED); + result = scm_c_make_vector (4, SCM_UNSPECIFIED); ve = SCM_VELTS (result); if (SCM_UNBNDP (name) || SCM_FALSEP (name)) { @@ -952,7 +952,7 @@ SCM_DEFINE (scm_uname, "uname", 0, 0, 0, #define FUNC_NAME s_scm_uname { struct utsname buf; - SCM ans = scm_make_vector (SCM_MAKINUM(5), SCM_UNSPECIFIED); + SCM ans = scm_c_make_vector (5, SCM_UNSPECIFIED); SCM *ve = SCM_VELTS (ans); if (uname (&buf) < 0) SCM_SYSERROR; diff --git a/libguile/print.c b/libguile/print.c index 0dc7b82ff..c7fa4b157 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -212,8 +212,7 @@ make_print_state (void) SCM_INUM0, SCM_EOL); scm_print_state *pstate = SCM_PRINT_STATE (print_state); - pstate->ref_vect = scm_make_vector (SCM_MAKINUM (PSTATE_SIZE), - SCM_UNDEFINED); + pstate->ref_vect = scm_c_make_vector (PSTATE_SIZE, SCM_UNDEFINED); pstate->ref_stack = SCM_VELTS (pstate->ref_vect); pstate->ceiling = SCM_VECTOR_LENGTH (pstate->ref_vect); return print_state; @@ -262,7 +261,7 @@ grow_ref_stack (scm_print_state *pstate) unsigned long int old_size = SCM_VECTOR_LENGTH (pstate->ref_vect); SCM *old_elts = SCM_VELTS (pstate->ref_vect); unsigned long int new_size = 2 * pstate->ceiling; - SCM new_vect = scm_make_vector (SCM_MAKINUM (new_size), SCM_UNDEFINED); + SCM new_vect = scm_c_make_vector (new_size, SCM_UNDEFINED); SCM *new_elts = SCM_VELTS (new_vect); unsigned long int i; diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index 0abb4b8da..da18e9119 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -254,7 +254,7 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, int i; /* The match vector must include a cell for the string that was matched, so add 1. */ - mvec = scm_make_vector (SCM_MAKINUM (nmatches + 1), SCM_UNSPECIFIED); + mvec = scm_c_make_vector (nmatches + 1, SCM_UNSPECIFIED); SCM_VELTS(mvec)[0] = str; for (i = 0; i < nmatches; ++i) if (matches[i].rm_so == -1) diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index 795367a29..415169915 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -493,8 +493,7 @@ scm_init_scmsigs () signal_handlers = SCM_CDRLOC (scm_sysintern ("signal-handlers", - scm_make_vector (SCM_MAKINUM (NSIG), - SCM_BOOL_F))); + scm_c_make_vector (NSIG, SCM_BOOL_F))); thunk = scm_make_gsubr ("%deliver-signals", 0, 0, 0, sys_deliver_signals); signal_async = scm_system_async (thunk); diff --git a/libguile/socket.c b/libguile/socket.c index fc306a321..d765383a2 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -555,7 +555,7 @@ scm_addr_vector (struct sockaddr *address,const char *proc) if (fam == AF_UNIX) { struct sockaddr_un *nad = (struct sockaddr_un *) address; - result = scm_make_vector (SCM_MAKINUM (2), SCM_UNSPECIFIED); + result = scm_c_make_vector (2, SCM_UNSPECIFIED); ve = SCM_VELTS (result); ve[0] = scm_ulong2num ((unsigned long) fam); ve[1] = scm_makfromstr (nad->sun_path, @@ -566,7 +566,7 @@ scm_addr_vector (struct sockaddr *address,const char *proc) if (fam == AF_INET) { struct sockaddr_in *nad = (struct sockaddr_in *) address; - result = scm_make_vector (SCM_MAKINUM (3), SCM_UNSPECIFIED); + result = scm_c_make_vector (3, SCM_UNSPECIFIED); ve = SCM_VELTS (result); ve[0] = scm_ulong2num ((unsigned long) fam); ve[1] = scm_ulong2num (ntohl (nad->sin_addr.s_addr)); diff --git a/libguile/stime.c b/libguile/stime.c index e5a524fcb..cb5b75822 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -186,7 +186,7 @@ SCM_DEFINE (scm_times, "times", 0, 0, 0, struct tms t; clock_t rv; - SCM result = scm_make_vector (SCM_MAKINUM(5), SCM_UNDEFINED); + SCM result = scm_c_make_vector (5, SCM_UNDEFINED); rv = times (&t); if (rv == -1) SCM_SYSERROR; @@ -273,7 +273,7 @@ SCM_DEFINE (scm_gettimeofday, "gettimeofday", 0, 0, 0, static SCM filltime (struct tm *bd_time, int zoff, char *zname) { - SCM result = scm_make_vector (SCM_MAKINUM(11), SCM_UNDEFINED); + SCM result = scm_c_make_vector (11, SCM_UNDEFINED); SCM_VELTS (result)[0] = SCM_MAKINUM (bd_time->tm_sec); SCM_VELTS (result)[1] = SCM_MAKINUM (bd_time->tm_min); diff --git a/libguile/symbols.c b/libguile/symbols.c index a212b3126..4477bd683 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -55,6 +55,7 @@ #include "libguile/fluids.h" #include "libguile/strings.h" #include "libguile/vectors.h" +#include "libguile/hashtab.h" #include "libguile/weaks.h" #include "libguile/modules.h" @@ -759,7 +760,7 @@ SCM_DEFINE (scm_builtin_bindings, "builtin-bindings", 0, 0, 0, #define FUNC_NAME s_scm_builtin_bindings { int length = SCM_VECTOR_LENGTH (scm_symhash); - SCM obarray = scm_make_vector (SCM_MAKINUM (length), SCM_EOL); + SCM obarray = scm_c_make_hash_table (length); copy_and_prune_obarray (scm_symhash, obarray); return obarray; } diff --git a/libguile/unif.c b/libguile/unif.c index 0eef7cfc4..889189ea7 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -212,13 +212,13 @@ scm_make_uve (long k, SCM prot) #endif else { - return scm_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED); + return scm_c_make_vector (k, SCM_UNDEFINED); } } else if (!SCM_INEXACTP (prot)) /* Huge non-unif vectors are NOT supported. */ /* no special scm_vector */ - return scm_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED); + return scm_c_make_vector (k, SCM_UNDEFINED); else if (singp (prot)) { i = sizeof (float) * k; diff --git a/libguile/vectors.c b/libguile/vectors.c index 3848a8bbb..292252ebd 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -184,7 +184,7 @@ SCM_DEFINE (scm_vector, "vector", 0, 0, 1, register SCM *data; int i; SCM_VALIDATE_LIST_COPYLEN (1,l,i); - res = scm_make_vector (SCM_MAKINUM (i), SCM_UNSPECIFIED); + res = scm_c_make_vector (i, SCM_UNSPECIFIED); data = SCM_VELTS (res); for(; i && SCM_NIMP(l); --i, l = SCM_CDR (l)) *data++ = SCM_CAR (l); @@ -270,30 +270,35 @@ SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0, "Otherwise the initial contents of each element is unspecified. (r5rs)") #define FUNC_NAME s_scm_make_vector { - SCM v; - unsigned long int i; - scm_bits_t *velts; - SCM_VALIDATE_INUM_MIN (1, k, 0); if (SCM_UNBNDP (fill)) fill = SCM_UNSPECIFIED; + return scm_c_make_vector (SCM_INUM (k), fill); +} +#undef FUNC_NAME + +SCM +scm_c_make_vector (unsigned long int k, SCM fill) +#define FUNC_NAME s_scm_make_vector +{ + SCM v; + scm_bits_t *velts; - i = SCM_INUM (k); SCM_NEWCELL (v); - velts = (i != 0) - ? scm_must_malloc (i * sizeof (scm_bits_t), FUNC_NAME) + velts = (k != 0) + ? scm_must_malloc (k * sizeof (scm_bits_t), FUNC_NAME) : NULL; SCM_DEFER_INTS; { unsigned long int j; - for (j = 0; j != i; ++j) + for (j = 0; j != k; ++j) velts[j] = SCM_UNPACK (fill); SCM_SET_VECTOR_BASE (v, velts); - SCM_SET_VECTOR_LENGTH (v, i, scm_tc7_vector); + SCM_SET_VECTOR_LENGTH (v, k, scm_tc7_vector); } SCM_ALLOW_INTS; @@ -301,7 +306,6 @@ SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0, } #undef FUNC_NAME - SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0, (SCM v), "@samp{Vector->list} returns a newly allocated list of the objects contained\n" diff --git a/libguile/vectors.h b/libguile/vectors.h index 69616f0ca..f8449a714 100644 --- a/libguile/vectors.h +++ b/libguile/vectors.h @@ -73,6 +73,8 @@ +extern SCM scm_c_make_vector (unsigned long int k, SCM fill); + extern SCM scm_vector_p (SCM x); extern SCM scm_vector_length (SCM v); extern SCM scm_vector (SCM l); From 03416a991eb905e89b27c5a940142b392019040f Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sat, 3 Feb 2001 04:59:16 +0000 Subject: [PATCH 0502/2047] New files: dump.c, dump.h. --- libguile/ChangeLog | 17 + libguile/Makefile.am | 110 +++--- libguile/dump.c | 778 +++++++++++++++++++++++++++++++++++++++++++ libguile/dump.h | 69 ++++ libguile/init.c | 4 +- libguile/keywords.c | 20 ++ libguile/smob.c | 58 +++- libguile/smob.h | 39 ++- 8 files changed, 1009 insertions(+), 86 deletions(-) create mode 100644 libguile/dump.c create mode 100644 libguile/dump.h diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d7d1e2b0d..43169668b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,20 @@ +2001-02-02 Keisuke Nishida + + * dump.c, dump.h: New files. + * Makefile.am: Added dump.c, dump.h, dump.x, dump.doc. + * init.c: #include "libguile/dump.h". + (scm_init_guile_1): Call scm_init_dump. + * smob.h (scm_smob_descriptor): New slots: dump_mark, + dump_dealloc, dump_store, undump_alloc, undump_restore, + undump_init. + * smob.c (scm_make_smob_type): Init the new slots. + (scm_set_smob_dump, scm_set_smob_undump): New functions. + * smob.h (scm_set_smob_dump, scm_set_smob_undump): Declared. + + * keywords.c: #include "libguile/dump.h". + (keyword_dealloc, keyword_alloc): New functions. + (scm_init_keywords): Set smob_dump and smob_undump. + 2001-02-01 Keisuke Nishida * vectors.c (scm_c_make_vector): New function. diff --git a/libguile/Makefile.am b/libguile/Makefile.am index aaab474e7..0aaad3aaf 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -38,56 +38,47 @@ guile_SOURCES = guile.c guile_LDADD = libguile.la ${THREAD_LIBS_LOCAL} guile_LDFLAGS = @DLPREOPEN@ -libguile_la_SOURCES = \ - alist.c arbiters.c async.c backtrace.c boolean.c chars.c \ - continuations.c debug.c dynl.c dynwind.c environments.c eq.c error.c \ - eval.c evalext.c feature.c fluids.c fports.c gc.c gdbint.c gh_data.c \ - gh_eval.c gh_funcs.c gh_init.c gh_io.c gh_list.c gh_predicates.c \ - goops.c gsubr.c guardians.c hash.c hashtab.c hooks.c init.c ioext.c \ - iselect.c keywords.c lang.c list.c load.c macros.c mallocs.c \ - modules.c numbers.c objects.c objprop.c options.c pairs.c ports.c \ - print.c procprop.c procs.c random.c rdelim.c \ - read.c root.c scmsigs.c \ - script.c simpos.c smob.c sort.c srcprop.c stackchk.c stacks.c \ - stime.c strings.c strop.c strorder.c strports.c struct.c symbols.c \ - tag.c throw.c values.c variable.c vectors.c version.c vports.c weaks.c \ - gc_os_dep.c properties.c +libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ + chars.c continuations.c debug.c dump.c dynl.c dynwind.c \ + environments.c eq.c error.c eval.c evalext.c feature.c fluids.c fports.c \ + gc.c gc_os_dep.c gdbint.c gh_data.c gh_eval.c gh_funcs.c gh_init.c \ + gh_io.c gh_list.c gh_predicates.c goops.c gsubr.c guardians.c hash.c \ + hashtab.c hooks.c init.c ioext.c iselect.c keywords.c lang.c list.c \ + load.c macros.c mallocs.c modules.c numbers.c objects.c objprop.c \ + options.c pairs.c ports.c print.c procprop.c procs.c properties.c \ + random.c rdelim.c read.c root.c scmsigs.c script.c simpos.c smob.c \ + sort.c srcprop.c stackchk.c stacks.c stime.c strings.c strop.c \ + strorder.c strports.c struct.c symbols.c tag.c throw.c values.c \ + variable.c vectors.c version.c vports.c weaks.c -DOT_X_FILES = \ - alist.x arbiters.x \ - async.x backtrace.x boolean.x chars.x continuations.x debug.x \ - dynl.x dynwind.x environments.x eq.x error.x eval.x evalext.x \ - feature.x \ - fluids.x fports.x gc.x goops.x gsubr.x guardians.x hash.x hashtab.x \ - hooks.x init.x ioext.x iselect.x keywords.x lang.x list.x load.x \ - macros.x mallocs.x modules.x net_db.x numbers.x objects.x \ - objprop.x options.x pairs.x ports.x posix.x print.x procprop.x \ - procs.x random.x rdelim.x read.x root.x scmsigs.x \ - script.x simpos.x smob.x socket.x sort.x srcprop.x stackchk.x \ - stacks.x stime.x strings.x strop.x strorder.x strports.x struct.x \ - symbols.x tag.x throw.x values.x variable.x vectors.x \ - version.x vports.x weaks.x properties.x +DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ + continuations.x debug.x dump.x dynl.x dynwind.x environments.x eq.x \ + error.x eval.x evalext.x feature.x fluids.x fports.x gc.x goops.x \ + gsubr.x guardians.x hash.x hashtab.x hooks.x init.x ioext.x iselect.x \ + keywords.x lang.x list.x load.x macros.x mallocs.x modules.x net_db.x \ + numbers.x objects.x objprop.x options.x pairs.x ports.x posix.x print.x \ + procprop.x procs.x properties.x random.x rdelim.x read.x root.x \ + scmsigs.x script.x simpos.x smob.x socket.x sort.x srcprop.x \ + stackchk.x stacks.x stime.x strings.x strop.x strorder.x strports.x \ + struct.x symbols.x tag.x throw.x values.x variable.x vectors.x \ + version.x vports.x weaks.x EXTRA_DOT_X_FILES = debug-malloc.x filesys.x net_db.x posix.x ramap.x \ regex-posix.x socket.x threads.x unif.x -DOT_DOC_FILES = \ - alist.doc arbiters.doc async.doc backtrace.doc boolean.doc \ - chars.doc continuations.doc debug.doc dynl.doc dynwind.doc \ - environments.doc eq.doc \ - error.doc eval.doc evalext.doc feature.doc fluids.doc fports.doc \ - gc.doc goops.doc gsubr.doc guardians.doc hash.doc hashtab.doc \ - hooks.doc init.doc \ - ioext.doc iselect.doc keywords.doc lang.doc list.doc load.doc \ - macros.doc mallocs.doc modules.doc net_db.doc numbers.doc objects.doc \ - objprop.doc options.doc pairs.doc ports.doc posix.doc print.doc \ - procprop.doc procs.doc random.doc rdelim.doc \ - read.doc root.doc scmsigs.doc \ - script.doc simpos.doc smob.doc socket.doc sort.doc srcprop.doc \ - stackchk.doc stacks.doc stime.doc strings.doc strop.doc strorder.doc \ - strports.doc struct.doc symbols.doc tag.doc throw.doc values.doc \ - variable.doc vectors.doc version.doc vports.doc weaks.doc \ - properties.doc +DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \ + boolean.doc chars.doc continuations.doc debug.doc dump.doc dynl.doc \ + dynwind.doc environments.doc eq.doc error.doc eval.doc evalext.doc \ + feature.doc fluids.doc fports.doc gc.doc goops.doc gsubr.doc \ + guardians.doc hash.doc hashtab.doc hooks.doc init.doc ioext.doc \ + iselect.doc keywords.doc lang.doc list.doc load.doc macros.doc \ + mallocs.doc modules.doc net_db.doc numbers.doc objects.doc objprop.doc \ + options.doc pairs.doc ports.doc posix.doc print.doc procprop.doc \ + procs.doc properties.doc random.doc rdelim.doc read.doc root.doc \ + scmsigs.doc script.doc simpos.doc smob.doc socket.doc sort.doc \ + srcprop.doc stackchk.doc stacks.doc stime.doc strings.doc strop.doc \ + strorder.doc strports.doc struct.doc symbols.doc tag.doc throw.doc \ + values.doc variable.doc vectors.doc version.doc vports.doc weaks.doc EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@ @@ -120,23 +111,18 @@ pkginclude_HEADERS = gh.h # These are headers visible as . modincludedir = $(includedir)/libguile -modinclude_HEADERS = \ - __scm.h alist.h arbiters.h async.h backtrace.h boolean.h chars.h \ - continuations.h debug.h dynl.h dynwind.h environments.h eq.h \ - error.h eval.h \ - evalext.h feature.h filesys.h fports.h gc.h gdb_interface.h \ - gdbint.h goops.h gsubr.h guardians.h hash.h hashtab.h hooks.h init.h \ - ioext.h keywords.h lang.h list.h load.h macros.h mallocs.h \ - modules.h net_db.h numbers.h objects.h objprop.h options.h pairs.h \ - ports.h posix.h regex-posix.h print.h procprop.h procs.h random.h \ - ramap.h rdelim.h \ - read.h root.h scmsigs.h validate.h script.h simpos.h \ - smob.h socket.h sort.h srcprop.h stackchk.h stacks.h stime.h \ - strings.h strop.h strorder.h strports.h struct.h symbols.h tag.h \ - tags.h throw.h unif.h values.h variable.h vectors.h version.h \ - vports.h \ - weaks.h snarf.h threads.h coop-defs.h fluids.h iselect.h \ - debug-malloc.h properties.h +modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h boolean.h \ + chars.h continuations.h coop-defs.h debug.h debug-malloc.h dump.h \ + dynl.h dynwind.h environments.h eq.h error.h eval.h evalext.h \ + feature.h filesys.h fluids.h fports.h gc.h gdb_interface.h gdbint.h \ + goops.h gsubr.h guardians.h hash.h hashtab.h hooks.h init.h ioext.h \ + iselect.h keywords.h lang.h list.h load.h macros.h mallocs.h modules.h \ + net_db.h numbers.h objects.h objprop.h options.h pairs.h ports.h posix.h \ + regex-posix.h print.h procprop.h procs.h properties.h random.h ramap.h \ + rdelim.h read.h root.h scmsigs.h validate.h script.h simpos.h smob.h \ + snarf.h socket.h sort.h srcprop.h stackchk.h stacks.h stime.h strings.h \ + strop.h strorder.h strports.h struct.h symbols.h tag.h tags.h threads.h \ + throw.h unif.h values.h variable.h vectors.h version.h vports.h weaks.h ## This file is generated at configure time. That is why it is DATA ## and not a header -- headers are included in the distribution. diff --git a/libguile/dump.c b/libguile/dump.c new file mode 100644 index 000000000..95630b989 --- /dev/null +++ b/libguile/dump.c @@ -0,0 +1,778 @@ +/* Copyright (C) 2001 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 + * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + + + +#include +#include +#include +#include +#include + +#include "libguile/_scm.h" +#include "libguile/tags.h" +#include "libguile/root.h" +#include "libguile/alist.h" +#include "libguile/smob.h" +#include "libguile/ports.h" +#include "libguile/fports.h" +#include "libguile/strings.h" +#include "libguile/hashtab.h" +#include "libguile/vectors.h" +#include "libguile/validate.h" +#include "libguile/dump.h" + +#define SCM_DUMP_COOKIE "\x7fGBF-0.0" + +#define SCM_DUMP_INITIAL_HASH_SIZE 511 +#define SCM_DUMP_INITIAL_IMAGE_SIZE 4096 + +#define SCM_DUMP_INDEX_TO_WORD(x) ((scm_bits_t) ((x) << 3)) +#define SCM_DUMP_WORD_TO_INDEX(x) ((long) ((x) >> 3)) + +struct scm_dump_header { + scm_bits_t cookie; /* cookie string */ + scm_bits_t version; /* version string */ + scm_bits_t nmeta; /* the number of meta data */ + scm_bits_t init; /* initial object indicator */ +}; + +struct scm_dump_meta { + scm_bits_t tc; /* the type of objects */ + scm_bits_t nobjs; /* the number of objects */ +}; + + +/* + * Dump state + */ + +static scm_bits_t scm_tc16_dstate; + +struct scm_dstate { + int mmapped; + scm_sizet image_size; + int image_index; + char *image_base; /* memory image */ + SCM table; /* object table */ +}; + +#define SCM_DSTATE_DATA(d) ((struct scm_dstate *) SCM_SMOB_DATA (d)) + +#define SCM_DSTATE_TABLE(d) (SCM_DSTATE_DATA (d)->table) +#define SCM_DSTATE_TABLE_LENGTH(d) SCM_VECTOR_LENGTH (SCM_DSTATE_TABLE (d)) +#define SCM_DSTATE_TABLE_BASE(d) SCM_VELTS (SCM_DSTATE_TABLE (d)) + +static SCM +make_dstate () +#define FUNC_NAME "make_dstate" +{ + struct scm_dstate *p = SCM_MUST_MALLOC (sizeof (struct scm_dstate)); + p->mmapped = 0; + p->image_size = SCM_DUMP_INITIAL_IMAGE_SIZE; + p->image_index = 0; + p->image_base = SCM_MUST_MALLOC (p->image_size); + p->table = SCM_BOOL_F; + SCM_RETURN_NEWSMOB (scm_tc16_dstate, p); +} +#undef FUNC_NAME + +static SCM +make_dstate_by_mmap (int fd) +#define FUNC_NAME "make_dstate_by_mmap" +{ + int ret; + char *addr; + struct stat st; + struct scm_dstate *p = SCM_MUST_MALLOC (sizeof (struct scm_dstate)); + + SCM_SYSCALL (ret = fstat (fd, &st)); + if (ret < 0) + SCM_SYSERROR; + + SCM_SYSCALL (addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0)); + if (addr == MAP_FAILED) + SCM_SYSERROR; + + p->mmapped = 1; + p->image_size = st.st_size; + p->image_index = 0; + p->image_base = addr; + p->table = SCM_BOOL_F; + SCM_RETURN_NEWSMOB (scm_tc16_dstate, p); +} +#undef FUNC_NAME + +static SCM +dstate_mark (SCM obj) +{ + return SCM_DSTATE_TABLE (obj); +} + +static scm_sizet +dstate_free (SCM obj) +#define FUNC_NAME "dstate_free" +{ + int size = sizeof (struct scm_dstate); + struct scm_dstate *p = SCM_DSTATE_DATA (obj); + if (p->mmapped) + { + int rv; + SCM_SYSCALL (rv = munmap (p->image_base, p->image_size)); + if (rv < 0) + SCM_SYSERROR; + } + else + { + size += p->image_size; + if (p->image_base) + scm_must_free (p->image_base); + } + scm_must_free (p); + return size; +} +#undef FUNC_NAME + +static void +dstate_extend (struct scm_dstate *p) +{ + scm_sizet old_size = p->image_size; + p->image_size *= 2; + p->image_base = scm_must_realloc (p->image_base, + old_size, + p->image_size, + "dstate_extend"); +} + + +/* + * Object indicator + */ + +static scm_bits_t +scm_object_indicator (SCM obj, SCM dstate) +{ + if (SCM_IMP (obj)) + return SCM_UNPACK (obj); + else + { + int i; + int len = SCM_DSTATE_TABLE_LENGTH (dstate); + SCM *base = SCM_DSTATE_TABLE_BASE (dstate); + for (i = 0; i < len; i++) + if (SCM_EQ_P (obj, base[i])) + return SCM_DUMP_INDEX_TO_WORD (i); + } + scm_misc_error ("scm_object_indicator", + "Non-marked object: ~A", SCM_LIST1 (obj)); + return 0; +} + +static SCM +scm_indicator_object (scm_bits_t word, SCM dstate) +{ + if (SCM_IMP (SCM_PACK (word))) + return SCM_PACK (word); + else + return SCM_DSTATE_TABLE_BASE (dstate)[SCM_DUMP_WORD_TO_INDEX (word)]; +} + + +/* + * Dump interface + */ + +static void +scm_store_pad (SCM dstate) +{ + struct scm_dstate *p = SCM_DSTATE_DATA (dstate); + while (p->image_index + sizeof (scm_bits_t) >= p->image_size) + dstate_extend (p); + while (p->image_index % sizeof (scm_bits_t) != 0) + p->image_base[p->image_index++] = '\0'; +} + +static void +scm_store_chars (const char *addr, scm_sizet size, SCM dstate) +{ + struct scm_dstate *p = SCM_DSTATE_DATA (dstate); + while (p->image_index + size >= p->image_size) + dstate_extend (p); + memcpy (p->image_base + p->image_index, addr, size); + memcpy (p->image_base + p->image_index + size, "\0", 1); + p->image_index += size + 1; +} + +void +scm_store_string (const char *addr, scm_sizet size, SCM dstate) +{ + scm_store_chars (addr, size, dstate); + scm_store_pad (dstate); +} + +void +scm_store_bytes (const char *addr, scm_sizet size, SCM dstate) +{ + struct scm_dstate *p = SCM_DSTATE_DATA (dstate); + while (p->image_index + size >= p->image_size) + dstate_extend (p); + memcpy (p->image_base + p->image_index, addr, size); + p->image_index += size; + scm_store_pad (dstate); +} + +void +scm_store_word (const scm_bits_t word, SCM dstate) +{ + scm_store_bytes ((const char *) &word, sizeof (scm_bits_t), dstate); +} + +void +scm_store_object (SCM obj, SCM dstate) +{ + scm_store_word (scm_object_indicator (obj, dstate), dstate); +} + +static void +scm_restore_pad (SCM dstate) +{ + struct scm_dstate *p = SCM_DSTATE_DATA (dstate); + while (p->image_index % sizeof (scm_bits_t) != 0) + p->image_index++; +} + +static const char * +scm_restore_chars (SCM dstate, int *lenp) +{ + struct scm_dstate *p = SCM_DSTATE_DATA (dstate); + const char *addr = p->image_base + p->image_index; + *lenp = strlen (addr); + p->image_index += *lenp + 1; + return addr; +} + +const char * +scm_restore_string (SCM dstate, int *lenp) +{ + const char *addr = scm_restore_chars (dstate, lenp); + scm_restore_pad (dstate); + return addr; +} + +const char * +scm_restore_bytes (SCM dstate, scm_sizet size) +{ + struct scm_dstate *p = SCM_DSTATE_DATA (dstate); + const char *addr = p->image_base + p->image_index; + p->image_index += size; + scm_restore_pad (dstate); + return addr; +} + +scm_bits_t +scm_restore_word (SCM dstate) +{ + struct scm_dstate *p = SCM_DSTATE_DATA (dstate); + scm_bits_t word = *(scm_bits_t *) (p->image_base + p->image_index); + p->image_index += sizeof (scm_bits_t); + return word; +} + +SCM +scm_restore_object (SCM dstate) +{ + return scm_indicator_object (scm_restore_word (dstate), dstate); +} + + +/* + * Dump routine + */ + +void +scm_dump_mark (SCM obj, SCM dstate) +{ + SCM table = SCM_DSTATE_TABLE (dstate); + + loop: + /* Nothing with immediates */ + if (SCM_IMP (obj)) + return; + + /* Return if already marked */ + if (!SCM_FALSEP (scm_hashq_ref (table, obj, SCM_BOOL_F))) + return; + + if (SCM_SLOPPY_CONSP (obj)) + { + scm_hashq_set_x (table, obj, SCM_MAKINUM (scm_tc3_cons)); + scm_dump_mark (SCM_CAR (obj), dstate); + obj = SCM_CDR (obj); + goto loop; + } + + switch (SCM_TYP7 (obj)) + { + case scm_tc7_symbol: + scm_hashq_set_x (table, obj, SCM_MAKINUM (scm_tc7_symbol)); + return; + case scm_tc7_substring: + case scm_tc7_string: + scm_hashq_set_x (table, obj, SCM_MAKINUM (scm_tc7_string)); + return; + case scm_tc7_vector: + { + int i; + int len = SCM_VECTOR_LENGTH (obj); + SCM *base = SCM_VELTS (obj); + scm_hashq_set_x (table, obj, SCM_MAKINUM (scm_tc7_vector)); + for (i = 0; i < len; i++) + scm_dump_mark (base[i], dstate); + return; + } + case scm_tc7_smob: + { + SCM (*mark) () = SCM_SMOB_DESCRIPTOR (obj).dump_mark; + void (*dealloc) () = SCM_SMOB_DESCRIPTOR (obj).dump_dealloc; + void (*store) () = SCM_SMOB_DESCRIPTOR (obj).dump_store; + + if (!(mark || dealloc || store)) + break; + + scm_hashq_set_x (table, obj, SCM_MAKINUM (SCM_CELL_TYPE (obj))); + if (mark) + { + obj = mark (obj, dstate); + goto loop; + } + return; + } + } + scm_misc_error ("scm_dump_mark", "Cannot dump: ~A", SCM_LIST1 (obj)); +} + +static void +scm_dump_dealloc (scm_bits_t tc, int nobjs, SCM *table, SCM dstate) +{ + switch (SCM_ITAG7 (SCM_PACK (tc))) + { + case scm_tc7_symbol: + { + int i; + for (i = 0; i < nobjs; i++) + { + SCM obj = table[i]; + scm_store_chars (SCM_SYMBOL_CHARS (obj), + SCM_SYMBOL_LENGTH (obj), + dstate); + } + scm_store_pad (dstate); + return; + } + case scm_tc7_string: + { + int i; + for (i = 0; i < nobjs; i++) + { + SCM obj = table[i]; + scm_store_chars (SCM_STRING_CHARS (obj), + SCM_STRING_LENGTH (obj), + dstate); + } + scm_store_pad (dstate); + return; + } + case scm_tc7_vector: + { + int i; + for (i = 0; i < nobjs; i++) + scm_store_word (SCM_VECTOR_LENGTH (table[i]), dstate); + return; + } + case scm_tc7_smob: + { + int i; + void (*dealloc) () = scm_smobs[SCM_TC2SMOBNUM(tc)].dump_dealloc; + if (dealloc) + for (i = 0; i < nobjs; i++) + dealloc (table[i], dstate); + return; + } + } +} + +static void +scm_dump_store (scm_bits_t tc, int nobjs, SCM *table, SCM dstate) +{ + if (SCM_ITAG3 (SCM_PACK (tc)) == scm_tc3_cons) + { + int i; + for (i = 0; i < nobjs; i++) + { + SCM obj = table[i]; + scm_store_object (SCM_CAR (obj), dstate); + scm_store_object (SCM_CDR (obj), dstate); + } + return; + } + + switch (SCM_ITAG7 (SCM_PACK (tc))) + { + case scm_tc7_vector: + { + int i, j; + for (i = 0; i < nobjs; i++) + { + SCM obj = table[i]; + int len = SCM_VECTOR_LENGTH (obj); + SCM *base = SCM_VELTS (obj); + for (j = 0; j < len; j++) + scm_store_object (base[j], dstate); + } + return; + } + case scm_tc7_smob: + { + int i; + void (*store) () = scm_smobs[SCM_TC2SMOBNUM(tc)].dump_store; + if (store) + for (i = 0; i < nobjs; i++) + store (table[i], dstate); + return; + } + } +} + +static void +scm_undump_alloc (scm_bits_t tc, int nobjs, SCM *table, SCM dstate) +{ + if (SCM_ITAG3 (SCM_PACK (tc)) == scm_tc3_cons) + { + int i; + for (i = 0; i < nobjs; i++) + SCM_NEWCELL (table[i]); + return; + } + + switch (SCM_ITAG7 (SCM_PACK (tc))) + { + case scm_tc7_symbol: + { + int i; + for (i = 0; i < nobjs; i++) + { + int len; + const char *mem = scm_restore_chars (dstate, &len); + table[i] = scm_mem2symbol (mem, len); + } + scm_restore_pad (dstate); + return; + } + case scm_tc7_string: + { + int i; + for (i = 0; i < nobjs; i++) + { + int len; + const char *mem = scm_restore_chars (dstate, &len); + table[i] = scm_makfromstr (mem, len, 0); + } + scm_restore_pad (dstate); + return; + } + case scm_tc7_vector: + { + int i; + for (i = 0; i < nobjs; i++) + { + int len = scm_restore_word (dstate); + table[i] = scm_c_make_vector (len, SCM_BOOL_F); + } + return; + } + case scm_tc7_smob: + { + int i; + SCM (*alloc) () = scm_smobs[SCM_TC2SMOBNUM(tc)].undump_alloc; + if (!alloc) + break; + for (i = 0; i < nobjs; i++) + table[i] = alloc (dstate); + return; + } + } + scm_misc_error ("scm_undump_alloc", "Cannot undump", SCM_EOL); +} + +static void +scm_undump_restore (scm_bits_t tc, int nobjs, SCM *table, SCM dstate) +#define FUNC_NAME "scm_undump_restore" +{ + if (SCM_ITAG3 (SCM_PACK (tc)) == scm_tc3_cons) + { + int i; + for (i = 0; i < nobjs; i++) + { + SCM obj = table[i]; + SCM_SETCAR (obj, scm_restore_object (dstate)); + SCM_SETCDR (obj, scm_restore_object (dstate)); + } + return; + } + + switch (SCM_ITAG7 (SCM_PACK (tc))) + { + case scm_tc7_vector: + { + int i, j; + for (i = 0; i < nobjs; i++) + { + SCM obj = table[i]; + int len = SCM_VECTOR_LENGTH (obj); + SCM *base = SCM_VELTS (obj); + for (j = 0; j < len; j++) + base[j] = scm_restore_object (dstate); + } + return; + } + case scm_tc7_smob: + { + int i; + void (*restore) () = scm_smobs[SCM_TC2SMOBNUM(tc)].undump_restore; + if (restore) + for (i = 0; i < nobjs; i++) + restore (table[i], dstate); + } + } +} +#undef FUNC_NAME + +static void +scm_undump_init (scm_bits_t tc, int nobjs, SCM *table, SCM dstate) +{ + if (SCM_ITAG7 (SCM_PACK (tc)) == scm_tc7_smob) + { + int i; + void (*init) () = scm_smobs[SCM_TC2SMOBNUM(tc)].undump_init; + if (init) + for (i = 0; i < nobjs; i++) + init (table[i]); + } +} + + +/* + * Scheme interface + */ + +#define DUMP_APPLY(f,nmeta,meta,table) \ +{ \ + int i; \ + int len = 0; \ + for (i = 0; i < nmeta; i++) \ + { \ + f (meta[i].tc, meta[i].nobjs, table + len, dstate); \ + len += meta[i].nobjs; \ + } \ +} + +static SCM +scm_dump_table_fold (void *proc, SCM key, SCM data, SCM value) +{ + SCM handle = scm_sloppy_assq (data, value); + if (SCM_CONSP (handle)) + { + SCM_SETCDR (handle, scm_cons (key, SCM_CDR (handle))); + return value; + } + else + return scm_acons (data, SCM_LIST1 (key), value); +} + +SCM_DEFINE (scm_binary_write, "binary-write", 1, 1, 0, + (SCM obj, SCM port), + "Write OBJ to PORT in a binary format.") +#define FUNC_NAME s_scm_binary_write +{ + int i, index, len, nmeta; + struct scm_dump_header header; + struct scm_dump_meta *meta; + SCM dstate, alist, list, *base; + + /* Check port */ + if (SCM_UNBNDP (port)) + port = scm_cur_outp; + else + SCM_VALIDATE_OUTPUT_PORT (2, port); + + /* Mark objects */ + dstate = make_dstate (); + SCM_DSTATE_TABLE (dstate) = + scm_c_make_hash_table (SCM_DUMP_INITIAL_HASH_SIZE); + scm_dump_mark (obj, dstate); + + /* Build meta information */ + alist = scm_internal_hash_fold (scm_dump_table_fold, 0, SCM_EOL, + SCM_DSTATE_TABLE (dstate)); + nmeta = scm_ilength (alist); + meta = alloca (nmeta * sizeof (struct scm_dump_meta)); + list = alist; + len = 0; + for (i = 0; i < nmeta; i++) + { + meta[i].tc = SCM_INUM (SCM_CAAR (list)); + meta[i].nobjs = scm_ilength (SCM_CDAR (list)); + len += meta[i].nobjs; + list = SCM_CDR (list); + } + + /* Build object table */ + SCM_DSTATE_TABLE (dstate) = scm_c_make_vector (len, SCM_BOOL_F); + base = SCM_DSTATE_TABLE_BASE (dstate); + index = 0; + for (i = 0; i < nmeta; i++) + { + SCM list; + for (list = SCM_CDAR (alist); !SCM_NULLP (list); list = SCM_CDR (list)) + base[index++] = SCM_CAR (list); + alist = SCM_CDR (alist); + } + + /* Dump */ + DUMP_APPLY (scm_dump_dealloc, nmeta, meta, base); + DUMP_APPLY (scm_dump_store, nmeta, meta, base); + + /* Write header */ + header.cookie = ((scm_bits_t *) SCM_DUMP_COOKIE)[0]; + header.version = ((scm_bits_t *) SCM_DUMP_COOKIE)[1]; + header.nmeta = nmeta; + header.init = scm_object_indicator (obj, dstate); + scm_lfwrite ((const char *) &header, sizeof (struct scm_dump_header), port); + + /* Write the rest */ + scm_lfwrite ((const char *) meta, + nmeta * sizeof (struct scm_dump_meta), + port); + scm_lfwrite (SCM_DSTATE_DATA (dstate)->image_base, + SCM_DSTATE_DATA (dstate)->image_index, + port); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_binary_read, "binary-read", 0, 1, 0, + (SCM port), + "Read an object from PORT in a binary format.") +#define FUNC_NAME s_scm_binary_read +{ + int i, len; + scm_bits_t *data; + struct scm_dump_header *header; + struct scm_dump_meta *meta; + SCM dstate, *base; + + /* Check port */ + if (SCM_UNBNDP (port)) + port = scm_cur_inp; + else + SCM_VALIDATE_INPUT_PORT (1, port); + + /* Initialize */ + if (SCM_FPORTP (port)) + /* Undump with mmap */ + dstate = make_dstate_by_mmap (SCM_FPORT_FDES (port)); + else + /* Undump with malloc */ + SCM_MISC_ERROR ("Not supported yet", SCM_EOL); + + /* Read header */ + header = (struct scm_dump_header *) SCM_DSTATE_DATA (dstate)->image_base; + if (SCM_DSTATE_DATA (dstate)->image_size < sizeof (*header)) + SCM_MISC_ERROR ("Invalid binary format: ~A", SCM_LIST1 (port)); + if (header->cookie != ((scm_bits_t *) SCM_DUMP_COOKIE)[0]) + SCM_MISC_ERROR ("Invalid binary format: ~A", SCM_LIST1 (port)); + if (header->version != ((scm_bits_t *) SCM_DUMP_COOKIE)[1]) + SCM_MISC_ERROR ("Unsupported binary version: ~A", SCM_LIST1 (port)); + + /* Read the rest */ + meta = (struct scm_dump_meta *) ((char *) header + sizeof (*header)); + data = (scm_bits_t *) (meta + header->nmeta); + SCM_DSTATE_DATA (dstate)->image_index = (char *) data - (char *) header; + + /* Create object table */ + len = 0; + for (i = 0; i < header->nmeta; i++) + len += meta[i].nobjs; + SCM_DSTATE_TABLE (dstate) = scm_c_make_vector (len, SCM_BOOL_F); + base = SCM_DSTATE_TABLE_BASE (dstate); + + /* Undump */ + DUMP_APPLY (scm_undump_alloc, header->nmeta, meta, base); + DUMP_APPLY (scm_undump_restore, header->nmeta, meta, base); + DUMP_APPLY (scm_undump_init, header->nmeta, meta, base); + + /* Return */ + { + SCM obj = scm_indicator_object (header->init, dstate); + SCM_DSTATE_TABLE (dstate) = SCM_BOOL_F; + return obj; + } +} +#undef FUNC_NAME + + +void +scm_init_dump () +{ + scm_tc16_dstate = scm_make_smob_type ("dstate", 0); + scm_set_smob_mark (scm_tc16_dstate, dstate_mark); + scm_set_smob_free (scm_tc16_dstate, dstate_free); +#ifndef SCM_MAGIC_SNARFER +#include "libguile/dump.x" +#endif +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/dump.h b/libguile/dump.h new file mode 100644 index 000000000..157e98ae7 --- /dev/null +++ b/libguile/dump.h @@ -0,0 +1,69 @@ +/* classes: h_files */ + +#ifndef DUMPH +#define DUMPH +/* Copyright (C) 2001 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 + * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +#include "libguile/__scm.h" + +extern void scm_dump_mark (SCM obj, SCM dstate); +extern void scm_store_string (const char *addr, scm_sizet size, SCM dstate); +extern void scm_store_bytes (const char *addr, scm_sizet size, SCM dstate); +extern void scm_store_word (const scm_bits_t word, SCM dstate); +extern void scm_store_object (SCM obj, SCM dstate); +extern const char *scm_restore_string (SCM dstate, int *lenp); +extern const char *scm_restore_bytes (SCM dstate, scm_sizet size); +extern scm_bits_t scm_restore_word (SCM dstate); +extern SCM scm_restore_object (SCM dstate); + +extern SCM scm_binary_write (SCM obj, SCM port); +extern SCM scm_binary_read (SCM port); + +extern void scm_init_dump (void); + +#endif /* DUMPH */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/init.c b/libguile/init.c index 2c079df7b..329f18857 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -66,6 +66,7 @@ #ifdef GUILE_DEBUG_MALLOC #include "libguile/debug-malloc.h" #endif +#include "libguile/dump.h" #include "libguile/dynl.h" #include "libguile/dynwind.h" #include "libguile/environments.h" @@ -197,7 +198,7 @@ start_stack (void *base) /* Create the look-aside stack for variables that are shared between * captured continuations. */ - scm_continuation_stack = scm_make_vector (SCM_MAKINUM (512), SCM_UNDEFINED); + scm_continuation_stack = scm_c_make_vector (512, SCM_UNDEFINED); /* The continuation stack is further initialized by restart_stack. */ /* The remainder of stack initialization is factored out to another @@ -493,6 +494,7 @@ scm_init_guile_1 (SCM_STACKITEM *base) #ifdef GUILE_DEBUG_MALLOC scm_init_debug_malloc (); #endif + scm_init_dump (); scm_init_dynwind (); scm_init_eq (); scm_init_error (); diff --git a/libguile/keywords.c b/libguile/keywords.c index c979d4123..a1cc1c8c9 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -51,6 +51,7 @@ #include "libguile/ports.h" #include "libguile/root.h" #include "libguile/smob.h" +#include "libguile/dump.h" #include "libguile/hashtab.h" #include "libguile/validate.h" @@ -67,6 +68,23 @@ keyword_print (SCM exp, SCM port, scm_print_state *pstate) return 1; } +static void +keyword_dealloc (SCM obj, SCM dstate) +{ + SCM sym = scm_keyword_dash_symbol (obj); + scm_store_string (SCM_SYMBOL_CHARS (sym), + SCM_SYMBOL_LENGTH (sym), + dstate); +} + +static SCM +keyword_alloc (SCM dstate) +{ + int len; + const char *mem = scm_restore_string (dstate, &len); + SCM sym = scm_mem2symbol (mem, len); + return scm_make_keyword_from_dash_symbol (sym); +} SCM_DEFINE (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", 1, 0, 0, (SCM symbol), @@ -138,6 +156,8 @@ scm_init_keywords () scm_tc16_keyword = scm_make_smob_type ("keyword", 0); scm_set_smob_mark (scm_tc16_keyword, scm_markcdr); scm_set_smob_print (scm_tc16_keyword, keyword_print); + scm_set_smob_dump (scm_tc16_keyword, 0, keyword_dealloc, 0); + scm_set_smob_undump (scm_tc16_keyword, keyword_alloc, 0, 0); scm_keyword_obarray = scm_c_make_hash_table (256); #ifndef SCM_MAGIC_SNARFER diff --git a/libguile/smob.c b/libguile/smob.c index a14ca2c94..bcc665ac3 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -288,18 +288,24 @@ scm_make_smob_type (char *name, scm_sizet size) if (tmp) { scm_smobs = (scm_smob_descriptor *) tmp; - scm_smobs[scm_numsmob].name = name; - scm_smobs[scm_numsmob].size = size; - scm_smobs[scm_numsmob].mark = 0; - scm_smobs[scm_numsmob].free = (size == 0 ? scm_free0 : scm_smob_free); - scm_smobs[scm_numsmob].print = scm_smob_print; - scm_smobs[scm_numsmob].equalp = 0; - scm_smobs[scm_numsmob].apply = 0; + scm_smobs[scm_numsmob].name = name; + scm_smobs[scm_numsmob].size = size; + scm_smobs[scm_numsmob].mark = 0; + scm_smobs[scm_numsmob].free = (size == 0 ? scm_free0 : scm_smob_free); + scm_smobs[scm_numsmob].print = scm_smob_print; + scm_smobs[scm_numsmob].equalp = 0; + scm_smobs[scm_numsmob].apply = 0; scm_smobs[scm_numsmob].apply_0 = 0; scm_smobs[scm_numsmob].apply_1 = 0; scm_smobs[scm_numsmob].apply_2 = 0; scm_smobs[scm_numsmob].apply_3 = 0; - scm_smobs[scm_numsmob].gsubr_type = 0; + scm_smobs[scm_numsmob].gsubr_type = 0; + scm_smobs[scm_numsmob].dump_mark = 0; + scm_smobs[scm_numsmob].dump_dealloc = 0; + scm_smobs[scm_numsmob].dump_store = 0; + scm_smobs[scm_numsmob].undump_alloc = 0; + scm_smobs[scm_numsmob].undump_restore = 0; + scm_smobs[scm_numsmob].undump_init = 0; scm_numsmob++; } SCM_ALLOW_INTS; @@ -316,31 +322,31 @@ scm_make_smob_type (char *name, scm_sizet size) } void -scm_set_smob_mark (long tc, SCM (*mark) (SCM)) +scm_set_smob_mark (scm_bits_t tc, SCM (*mark) (SCM)) { scm_smobs[SCM_TC2SMOBNUM (tc)].mark = mark; } void -scm_set_smob_free (long tc, scm_sizet (*free) (SCM)) +scm_set_smob_free (scm_bits_t tc, scm_sizet (*free) (SCM)) { scm_smobs[SCM_TC2SMOBNUM (tc)].free = free; } void -scm_set_smob_print (long tc, int (*print) (SCM, SCM, scm_print_state*)) +scm_set_smob_print (scm_bits_t tc, int (*print) (SCM, SCM, scm_print_state*)) { scm_smobs[SCM_TC2SMOBNUM (tc)].print = print; } void -scm_set_smob_equalp (long tc, SCM (*equalp) (SCM, SCM)) +scm_set_smob_equalp (scm_bits_t tc, SCM (*equalp) (SCM, SCM)) { scm_smobs[SCM_TC2SMOBNUM (tc)].equalp = equalp; } void -scm_set_smob_apply (long tc, SCM (*apply) (), +scm_set_smob_apply (scm_bits_t tc, SCM (*apply) (), unsigned int req, unsigned int opt, unsigned int rst) { SCM (*apply_0) (SCM); @@ -441,7 +447,7 @@ scm_set_smob_apply (long tc, SCM (*apply) (), apply_3 = scm_smob_apply_3_error; break; } - scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply; + scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply; scm_smobs[SCM_TC2SMOBNUM (tc)].apply_0 = apply_0; scm_smobs[SCM_TC2SMOBNUM (tc)].apply_1 = apply_1; scm_smobs[SCM_TC2SMOBNUM (tc)].apply_2 = apply_2; @@ -449,8 +455,30 @@ scm_set_smob_apply (long tc, SCM (*apply) (), scm_smobs[SCM_TC2SMOBNUM (tc)].gsubr_type = type; } +void +scm_set_smob_dump (scm_bits_t tc, + SCM (*mark) (SCM, SCM), + void (*dealloc) (SCM, SCM), + void (*store) (SCM, SCM)) +{ + scm_smobs[SCM_TC2SMOBNUM (tc)].dump_mark = mark; + scm_smobs[SCM_TC2SMOBNUM (tc)].dump_dealloc = dealloc; + scm_smobs[SCM_TC2SMOBNUM (tc)].dump_store = store; +} + +void +scm_set_smob_undump (scm_bits_t tc, + SCM (*alloc) (SCM), + void (*restore) (SCM, SCM), + void (*init) (SCM)) +{ + scm_smobs[SCM_TC2SMOBNUM (tc)].undump_alloc = alloc; + scm_smobs[SCM_TC2SMOBNUM (tc)].undump_restore = restore; + scm_smobs[SCM_TC2SMOBNUM (tc)].undump_init = init; +} + SCM -scm_make_smob (long tc) +scm_make_smob (scm_bits_t tc) { int n = SCM_TC2SMOBNUM (tc); scm_sizet size = scm_smobs[n].size; diff --git a/libguile/smob.h b/libguile/smob.h index 0b67ef950..f37b0263f 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -53,16 +53,28 @@ typedef struct scm_smob_descriptor { char *name; scm_sizet size; + + /* Basic functions */ SCM (*mark) (SCM); scm_sizet (*free) (SCM); int (*print) (SCM exp, SCM port, scm_print_state *pstate); SCM (*equalp) (SCM, SCM); + + /* Apply functions */ SCM (*apply) (); SCM (*apply_0) (SCM); SCM (*apply_1) (SCM, SCM); SCM (*apply_2) (SCM, SCM, SCM); SCM (*apply_3) (SCM, SCM, SCM, SCM); int gsubr_type; /* Used in procprop.c */ + + /* Dump functions */ + SCM (*dump_mark) (SCM, SCM); + void (*dump_dealloc) (SCM, SCM); + void (*dump_store) (SCM, SCM); + SCM (*undump_alloc) (SCM); + void (*undump_restore) (SCM, SCM); + void (*undump_init) (SCM); } scm_smob_descriptor; @@ -145,20 +157,31 @@ extern int scm_smob_print (SCM exp, SCM port, scm_print_state *pstate); extern scm_bits_t scm_make_smob_type (char *name, scm_sizet size); -extern void scm_set_smob_mark (long tc, SCM (*mark) (SCM)); -extern void scm_set_smob_free (long tc, scm_sizet (*free) (SCM)); -extern void scm_set_smob_print (long tc, int (*print) (SCM, - SCM, - scm_print_state*)); -extern void scm_set_smob_equalp (long tc, SCM (*equalp) (SCM, SCM)); -extern void scm_set_smob_apply (long tc, SCM (*apply) (), +extern void scm_set_smob_mark (scm_bits_t tc, + SCM (*mark) (SCM)); +extern void scm_set_smob_free (scm_bits_t tc, + scm_sizet (*free) (SCM)); +extern void scm_set_smob_print (scm_bits_t tc, + int (*print) (SCM, SCM, scm_print_state*)); +extern void scm_set_smob_equalp (scm_bits_t tc, + SCM (*equalp) (SCM, SCM)); +extern void scm_set_smob_apply (scm_bits_t tc, + SCM (*apply) (), unsigned int req, unsigned int opt, unsigned int rst); +extern void scm_set_smob_dump (scm_bits_t tc, + SCM (*mark) (SCM, SCM), + void (*dealloc) (SCM, SCM), + void (*store) (SCM, SCM)); +extern void scm_set_smob_undump (scm_bits_t tc, + SCM (*alloc) (SCM), + void (*restore) (SCM, SCM), + void (*init) (SCM)); /* Function for creating smobs */ -extern SCM scm_make_smob (long tc); +extern SCM scm_make_smob (scm_bits_t tc); extern void scm_smob_prehistory (void); From ec89608938601a57850080dd998e894232535aba Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sat, 3 Feb 2001 05:01:07 +0000 Subject: [PATCH 0503/2047] *** empty log message *** --- ChangeLog | 4 ++++ libguile.h | 1 + 2 files changed, 5 insertions(+) diff --git a/ChangeLog b/ChangeLog index 7ea07ec79..e988a15bf 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2001-02-02 Keisuke Nishida + + * libguile.h: Added #include "libguile/dump.h". + 2001-01-29 Mikael Djurfeldt * libguile.h: Added #include "libguile/rdelim.h". diff --git a/libguile.h b/libguile.h index 1ab96bf41..7e99e0efc 100644 --- a/libguile.h +++ b/libguile.h @@ -66,6 +66,7 @@ extern "C" { #include "libguile/debug.h" #include "libguile/stacks.h" #endif +#include "libguile/dump.h" #include "libguile/dynl.h" #include "libguile/dynwind.h" #include "libguile/eq.h" From ecf470a2aa5cef069664801aed27e567a9c88690 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Sat, 3 Feb 2001 12:26:38 +0000 Subject: [PATCH 0504/2047] SCM_DOUBLE_CELLP deprecated and made unused --- RELEASE | 1 + libguile/ChangeLog | 7 +++++++ libguile/gc.c | 7 +++++-- libguile/tags.h | 2 ++ 4 files changed, 15 insertions(+), 2 deletions(-) diff --git a/RELEASE b/RELEASE index eb6db9c39..551af20e3 100644 --- a/RELEASE +++ b/RELEASE @@ -33,6 +33,7 @@ In release 1.5: - remove deprecated types, functions and macros from numbers.h: scm_dblproc, SCM_UNEGFIXABLE, SCM_FLOBUFLEN, SCM_INEXP, SCM_CPLXP, SCM_REAL, SCM_IMAG, SCM_REALPART, scm_makdbl, SCM_SINGP, SCM_NUM2DBL, SCM_NO_BIGDIG +- remove deprecated macro from tags.h: SCM_DOUBLE_CELLP In release 1.6: - remove deprecated variables: diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 43169668b..2c3e14a1e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2001-02-03 Michael Livshin + + * gc.c (DOUBLECELL_ALIGNED_P): new macro, a better-named analog of + the deprecated SCM_DOUBLE_CELLP. + + * tags.h (SCM_DOUBLE_CELLP): deprecated. + 2001-02-02 Keisuke Nishida * dump.c, dump.h: New files. diff --git a/libguile/gc.c b/libguile/gc.c index 0057ed372..052859210 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -65,6 +65,7 @@ #include "libguile/vectors.h" #include "libguile/weaks.h" #include "libguile/hashtab.h" +#include "libguile/tags.h" #include "libguile/validate.h" #include "libguile/gc.h" @@ -252,6 +253,8 @@ int scm_default_max_segment_size = 2097000L;/* a little less (adm) than 2 Mb */ # endif /* UNICOS */ #endif /* PROT386 */ +#define DOUBLECELL_ALIGNED_P(x) (((2 * sizeof (scm_cell) - 1) & SCM_UNPACK (x)) == 0) + #define ALIGNMENT_SLACK(freelist) (SCM_GC_CARD_SIZE - 1) #define CLUSTER_SIZE_IN_BYTES(freelist) \ (((freelist)->cluster_size / (SCM_GC_CARD_N_DATA_CELLS / (freelist)->span)) * SCM_GC_CARD_SIZE) @@ -1461,7 +1464,7 @@ scm_mark_locations (SCM_STACKITEM x[], scm_sizet n) break; if (scm_heap_table[seg_id].span == 1 - || SCM_DOUBLE_CELLP (obj)) + || DOUBLECELL_ALIGNED_P (obj)) scm_gc_mark (obj); break; @@ -1495,7 +1498,7 @@ scm_cellp (SCM value) if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr) && SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr) - && (scm_heap_table[i].span == 1 || SCM_DOUBLE_CELLP (value)) + && (scm_heap_table[i].span == 1 || DOUBLECELL_ALIGNED_P (value)) && !SCM_GC_IN_CARD_HEADERP (ptr) ) return 1; diff --git a/libguile/tags.h b/libguile/tags.h index 02ddeec9e..f69031d81 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -293,7 +293,9 @@ typedef long scm_bits_t; #define SCM_CELLP(x) (((sizeof (scm_cell) - 1) & SCM_UNPACK (x)) == 0) #define SCM_NCELLP(x) (!SCM_CELLP (x)) +#if (SCM_DEBUG_DEPRECATED == 0) #define SCM_DOUBLE_CELLP(x) (((2 * sizeof (scm_cell) - 1) & SCM_UNPACK (x)) == 0) +#endif /* SCM_DEBUG_DEPRECATED == 0 */ /* See numbers.h for macros relating to immediate integers. */ From 7ecbf85dde4688009bdc39dd77b3bc78ac306e12 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 4 Feb 2001 17:29:06 +0000 Subject: [PATCH 0505/2047] * data-rep.texi: Use SCM_SMOB_DATA instead of SCM_CDR. Also things like SCM_SMOB_PREDICATE and SCM_NEWSMOB. Thanks to Dale P. Smith! --- doc/data-rep.texi | 28 ++++++++++++---------------- 1 file changed, 12 insertions(+), 16 deletions(-) diff --git a/doc/data-rep.texi b/doc/data-rep.texi index b9d9a8438..acf774416 100644 --- a/doc/data-rep.texi +++ b/doc/data-rep.texi @@ -46,7 +46,7 @@ by the Free Software Foundation. @sp 10 @comment The title is printed in a large font. @title Data Representation in Guile -@subtitle $Id: data-rep.texi,v 1.13 2000-07-28 13:19:01 ossau Exp $ +@subtitle $Id: data-rep.texi,v 1.14 2001-02-04 17:29:06 mvo Exp $ @subtitle For use with Guile @value{VERSION} @author Jim Blandy @author Free Software Foundation @@ -1366,11 +1366,10 @@ clear_image (SCM image_smob) int area; struct image *image; - SCM_ASSERT ((SCM_NIMP (image_smob) - && SCM_CAR (image_smob) == image_tag), + SCM_ASSERT (SCM_SMOB_PREDICATE (image_tag, image_smob), image_smob, SCM_ARG1, "clear-image"); - image = (struct image *) SCM_CDR (image_smob); + image = (struct image *) SCM_SMOB_DATA (image_smob); area = image->width * image->height; memset (image->pixels, 0, area); @@ -1449,7 +1448,7 @@ SCM mark_image (SCM image_smob) @{ /* Mark the image's name and update function. */ - struct image *image = (struct image *) SCM_CDR (image_smob); + struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); scm_gc_mark (image->name); scm_gc_mark (image->update_func); @@ -1475,7 +1474,7 @@ SCM mark_image (SCM image_smob) @{ /* Mark the image's name and update function. */ - struct image *image = (struct image *) SCM_CDR (image_smob); + struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); scm_gc_mark (image->name); return image->update_func; @@ -1502,7 +1501,7 @@ type: scm_sizet free_image (SCM image_smob) @{ - struct image *image = (struct image *) SCM_CDR (image_smob); + struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); scm_sizet size = image->width * image->height + sizeof (*image); free (image->pixels); @@ -1695,9 +1694,7 @@ make_image (SCM name, SCM s_width, SCM s_height) image->name = name; image->update_func = SCM_BOOL_F; - SCM_NEWCELL (image_smob); - SCM_SETCDR (image_smob, image); - SCM_SETCAR (image_smob, image_tag); + SCM_NEWSMOB (image_smob, image_tag, image); return image_smob; @} @@ -1708,11 +1705,10 @@ clear_image (SCM image_smob) int area; struct image *image; - SCM_ASSERT ((SCM_NIMP (image_smob) - && SCM_CAR (image_smob) == image_tag), + SCM_ASSERT (SCM_SMOB_PREDICATE (image_tag, image_smob), image_smob, SCM_ARG1, "clear-image"); - image = (struct image *) SCM_CDR (image_smob); + image = (struct image *) SCM_SMOB_DATA (image_smob); area = image->width * image->height; memset (image->pixels, 0, area); @@ -1726,7 +1722,7 @@ clear_image (SCM image_smob) static SCM mark_image (SCM image_smob) @{ - struct image *image = (struct image *) SCM_CDR (image_smob); + struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); scm_gc_mark (image->name); return image->update_func; @@ -1735,7 +1731,7 @@ mark_image (SCM image_smob) static scm_sizet free_image (SCM image_smob) @{ - struct image *image = (struct image *) SCM_CDR (image_smob); + struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); scm_sizet size = image->width * image->height + sizeof (struct image); free (image->pixels); @@ -1747,7 +1743,7 @@ free_image (SCM image_smob) static int print_image (SCM image_smob, SCM port, scm_print_state *pstate) @{ - struct image *image = (struct image *) SCM_CDR (image_smob); + struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); scm_puts ("#name, port); From bd7d4f408d061d2f6121972bc45476a9c89cc65c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 4 Feb 2001 17:30:00 +0000 Subject: [PATCH 0506/2047] *** empty log message *** --- doc/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/doc/ChangeLog b/doc/ChangeLog index 086f97aff..8f158822c 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,9 @@ +2001-02-04 Marius Vollmer + + * data-rep.texi: Use SCM_SMOB_DATA instead of SCM_CDR. Also + things like SCM_SMOB_PREDICATE and SCM_NEWSMOB. Thanks to Dale + P. Smith! + 2000-10-25 Mikael Djurfeldt * mop.text: Preliminary documentation of the GOOPS meta object From fbf0c8c7b194202e01338f8b5324126bf73af4c9 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 4 Feb 2001 18:21:38 +0000 Subject: [PATCH 0507/2047] *** empty log message *** --- NEWS | 9 +++++++++ RELEASE | 4 ++++ ice-9/ChangeLog | 14 ++++++++++++++ 3 files changed, 27 insertions(+) diff --git a/NEWS b/NEWS index fc58c02c0..fc80a4c18 100644 --- a/NEWS +++ b/NEWS @@ -8,6 +8,15 @@ Changes since Guile 1.4: * Changes to the distribution +** The module (ice-9 and-let*) has been renamed to (ice-9 and-let-star) + +This has been done to prevent problems on lesser operating systems +that can't tolerate `*'s in file names. The exported macro continues +to be named `and-let*', of course. + +On systems that support it, there is also a compatability module named +(ice-9 and-let*). It will go away in the next release. + ** New modules (oop goops) etc.: (oop goops) diff --git a/RELEASE b/RELEASE index 551af20e3..0995419fd 100644 --- a/RELEASE +++ b/RELEASE @@ -7,6 +7,10 @@ absinthe, etc. However, the first release containing the module system should be called Godot: "This is the one you've been waiting for." +* Remove compatability module (ice-9 and-let*) eventually (when a + major release with the real module (ice-9 and-let-star) has been out + long enough, probably release 1.6). + * Deprecate `read-only-string?'. After signal handling and threading have been fixed: diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 6ac39d8f7..4823b0097 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,17 @@ +2001-02-04 Marius Vollmer + + Avoid the use of "*" in file names for the benefit of lesser + operating systems. + + * and-let-star.scm, and-let*.scm: Renamed `and-let*.scm' to + `and-let-star.scm'. Updated module name as well. + * and-let-star-compat.scm: New file, installed as `and-let*.scm'. + * Makefile.am (ice9_sources): Replaced "and-let*.scm" with + "and-let-star.scm". + (install-data-local): Install "and-let-star-compat.scm" as + "and-let*.scm", ignoring errors. + (EXTRA_DIST): Distribute `and-let-star-compat.scm'. + 2001-01-26 Dirk Herrmann This patch fixes a problem reported by Martin Grabmueller about From 93a6e9c4a7f3f179133ad700f20c0f04a910cb17 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 4 Feb 2001 18:22:18 +0000 Subject: [PATCH 0508/2047] * and-let-star.scm, and-let*.scm: Renamed `and-let*.scm' to `and-let-star.scm'. Updated module name as well. * and-let-star-compat.scm: New file, installed as `and-let*.scm'. * Makefile.am (ice9_sources): Replaced "and-let*.scm" with "and-let-star.scm". (install-data-local): Install "and-let-star-compat.scm" as "and-let*.scm", ignoring errors. (EXTRA_DIST): Distribute `and-let-star-compat.scm'. --- ice-9/Makefile.am | 22 +++++++++------- ice-9/and-let*.scm | 0 ice-9/and-let-star-compat.scm | 11 ++++++++ ice-9/and-let-star.scm | 48 +++++++++++++++++++++++++++++++++++ 4 files changed, 72 insertions(+), 9 deletions(-) delete mode 100644 ice-9/and-let*.scm create mode 100644 ice-9/and-let-star-compat.scm create mode 100644 ice-9/and-let-star.scm diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index 4580ed7c2..c0f0e0d74 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -22,19 +22,23 @@ AUTOMAKE_OPTIONS = foreign # These should be installed and distributed. -ice9_sources = \ - and-let*.scm arrays.scm boot-9.scm calling.scm common-list.scm \ - debug.scm debugger.scm documentation.scm emacs.scm expect.scm \ - format.scm getopt-long.scm hcons.scm lineio.scm ls.scm \ - mapping.scm networking.scm null.scm optargs.scm poe.scm popen.scm \ - posix.scm psyntax.pp psyntax.ss q.scm r4rs.scm r5rs.scm \ - rdelim.scm receive.scm srfi-8.scm \ - regex.scm runq.scm safe-r5rs.scm safe.scm session.scm slib.scm \ +ice9_sources = \ + and-let-star.scm arrays.scm boot-9.scm calling.scm common-list.scm \ + debug.scm debugger.scm documentation.scm emacs.scm expect.scm \ + format.scm getopt-long.scm hcons.scm lineio.scm ls.scm \ + mapping.scm networking.scm null.scm optargs.scm poe.scm popen.scm \ + posix.scm psyntax.pp psyntax.ss q.scm r4rs.scm r5rs.scm \ + rdelim.scm receive.scm srfi-8.scm \ + regex.scm runq.scm safe-r5rs.scm safe.scm session.scm slib.scm \ streams.scm string-fun.scm syncase.scm tags.scm threads.scm subpkgdatadir = $(pkgdatadir)/$(VERSION)/ice-9 subpkgdata_DATA = $(ice9_sources) ETAGS_ARGS = $(subpkgdata_DATA) +install-data-local: + -$(INSTALL_DATA) and-let-star-compat.scm \ + $(subpkgdatadir)/'and-let*.scm' + ## test.scm is not currently installed. -EXTRA_DIST = $(ice9_sources) test.scm +EXTRA_DIST = $(ice9_sources) test.scm and-let-star-compat.scm diff --git a/ice-9/and-let*.scm b/ice-9/and-let*.scm deleted file mode 100644 index e69de29bb..000000000 diff --git a/ice-9/and-let-star-compat.scm b/ice-9/and-let-star-compat.scm new file mode 100644 index 000000000..497082458 --- /dev/null +++ b/ice-9/and-let-star-compat.scm @@ -0,0 +1,11 @@ +;;;; This file will be installed as "and-let*.scm" on systems that +;;;; support it. It will go away in the future, use the module +;;;; (and-let-star) instead. + +(define-module (ice-9 and-let*) + :use-module (ice-9 and-let-star)) + +(display ";;; The module name (ice-9 and-let*) is deprecated.\n") +(display ";;; Use (ice-9 and-let-star) instead.\n\n") + +(export-syntax and-let*) diff --git a/ice-9/and-let-star.scm b/ice-9/and-let-star.scm new file mode 100644 index 000000000..4055d17fe --- /dev/null +++ b/ice-9/and-let-star.scm @@ -0,0 +1,48 @@ +;;;; and-let-star.scm --- and-let* syntactic form (draft SRFI-2) for Guile +;;;; written by Michael Livshin +;;;; +;;;; Copyright (C) 1999 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +(define-module (ice-9 and-let-star)) + +(defmacro and-let* (vars . body) + + (define (expand vars body) + (cond + ((null? vars) + `(begin ,@body)) + ((pair? vars) + (let ((exp (car vars))) + (cond + ((pair? exp) + (cond + ((null? (cdr exp)) + `(and ,(car exp) ,(expand (cdr vars) body))) + (else + (let ((var (car exp)) + (val (cadr exp))) + `(let (,exp) + (and ,var ,(expand (cdr vars) body))))))) + (else + `(and ,exp ,(expand (cdr vars) body)))))) + (else + (error "not a proper list" vars)))) + + (expand vars body)) + +(export-syntax and-let*) From 914cceec2c305c960c2f4948620b96e67fa7a5da Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Mon, 5 Feb 2001 08:46:21 +0000 Subject: [PATCH 0509/2047] New dump/undump scheme. --- libguile/ChangeLog | 16 ++ libguile/dump.c | 642 +++++++++++++++++++------------------------- libguile/dump.h | 6 +- libguile/keywords.c | 8 +- libguile/smob.c | 28 +- libguile/smob.h | 27 +- 6 files changed, 312 insertions(+), 415 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 2c3e14a1e..efd196325 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,19 @@ +2001-02-05 Keisuke Nishida + + * dump.c, dump.h: Modified a lot. + (scm_dump_mark): Removed. + (scm_restore_cell_object, scm_store_cell_object): New functions. + + * smob.h (scm_smob_descriptor): Removed slots: dump_mark, + dump_dealloc, dump_store, undump_alloc, undump_restore, undump_init. + New slots: dump, undump. + * smob.c (scm_make_smob_type, scm_set_smob_dump, scm_set_smob_undump): + Updated. + + * keywords.c (keyword_dump): Renamed from keyword_dealloc. + (keyword_undump): Renamed from keyword_alloc. + (scm_init_keywords): Set keyword_dump and keyword_undump. + 2001-02-03 Michael Livshin * gc.c (DOUBLECELL_ALIGNED_P): new macro, a better-named analog of diff --git a/libguile/dump.c b/libguile/dump.c index 95630b989..71141c6a6 100644 --- a/libguile/dump.c +++ b/libguile/dump.c @@ -62,22 +62,30 @@ #define SCM_DUMP_COOKIE "\x7fGBF-0.0" -#define SCM_DUMP_INITIAL_HASH_SIZE 511 -#define SCM_DUMP_INITIAL_IMAGE_SIZE 4096 +#define SCM_DUMP_HASH_SIZE 151 +#define SCM_DUMP_IMAGE_SIZE 4096 #define SCM_DUMP_INDEX_TO_WORD(x) ((scm_bits_t) ((x) << 3)) #define SCM_DUMP_WORD_TO_INDEX(x) ((long) ((x) >> 3)) struct scm_dump_header { - scm_bits_t cookie; /* cookie string */ - scm_bits_t version; /* version string */ - scm_bits_t nmeta; /* the number of meta data */ - scm_bits_t init; /* initial object indicator */ + scm_bits_t cookie; /* cookie string */ + scm_bits_t version; /* version string */ + scm_bits_t nobjs; /* the number of objects */ + /* or immediate value */ }; -struct scm_dump_meta { - scm_bits_t tc; /* the type of objects */ - scm_bits_t nobjs; /* the number of objects */ +struct scm_dump_object_update { + scm_bits_t id; /* object identifier */ + scm_bits_t *addr; /* object address */ + struct scm_dump_object_update *next; /* next update */ +}; + +struct scm_dump_cell_update { + scm_bits_t id; /* object identifier */ + SCM cell; /* cell */ + int n; /* 0-3 */ + struct scm_dump_cell_update *next; /* next update */ }; @@ -88,29 +96,41 @@ struct scm_dump_meta { static scm_bits_t scm_tc16_dstate; struct scm_dstate { + /* Memory image */ int mmapped; scm_sizet image_size; int image_index; - char *image_base; /* memory image */ - SCM table; /* object table */ + char *image_base; + + /* Object table */ + int table_index; + SCM table; + + /* Update schedule */ + struct scm_dump_object_update *object_updates; + struct scm_dump_cell_update *cell_updates; }; -#define SCM_DSTATE_DATA(d) ((struct scm_dstate *) SCM_SMOB_DATA (d)) - -#define SCM_DSTATE_TABLE(d) (SCM_DSTATE_DATA (d)->table) -#define SCM_DSTATE_TABLE_LENGTH(d) SCM_VECTOR_LENGTH (SCM_DSTATE_TABLE (d)) -#define SCM_DSTATE_TABLE_BASE(d) SCM_VELTS (SCM_DSTATE_TABLE (d)) +#define SCM_DSTATE_DATA(d) ((struct scm_dstate *) SCM_SMOB_DATA (d)) +#define SCM_DSTATE_TABLE(d) (SCM_DSTATE_DATA (d)->table) +#define SCM_DSTATE_TABLE_REF(d,i) (SCM_VELTS (SCM_DSTATE_TABLE (d))[i]) +#define SCM_DSTATE_TABLE_SET(d,i,x) (SCM_VELTS (SCM_DSTATE_TABLE (d))[i] = (x)) +#define SCM_DSTATE_OBJECT_UPDATES(d)(SCM_DSTATE_DATA (d)->object_updates) +#define SCM_DSTATE_CELL_UPDATES(d) (SCM_DSTATE_DATA (d)->cell_updates) static SCM make_dstate () #define FUNC_NAME "make_dstate" { struct scm_dstate *p = SCM_MUST_MALLOC (sizeof (struct scm_dstate)); - p->mmapped = 0; - p->image_size = SCM_DUMP_INITIAL_IMAGE_SIZE; - p->image_index = 0; - p->image_base = SCM_MUST_MALLOC (p->image_size); - p->table = SCM_BOOL_F; + p->mmapped = 0; + p->image_size = SCM_DUMP_IMAGE_SIZE; + p->image_index = 0; + p->image_base = SCM_MUST_MALLOC (p->image_size); + p->table_index = 0; + p->table = SCM_BOOL_F; + p->object_updates = 0; + p->cell_updates = 0; SCM_RETURN_NEWSMOB (scm_tc16_dstate, p); } #undef FUNC_NAME @@ -132,11 +152,14 @@ make_dstate_by_mmap (int fd) if (addr == MAP_FAILED) SCM_SYSERROR; - p->mmapped = 1; - p->image_size = st.st_size; - p->image_index = 0; - p->image_base = addr; - p->table = SCM_BOOL_F; + p->mmapped = 1; + p->image_size = st.st_size; + p->image_index = 0; + p->image_base = addr; + p->table_index = 0; + p->table = SCM_BOOL_F; + p->object_updates = 0; + p->cell_updates = 0; SCM_RETURN_NEWSMOB (scm_tc16_dstate, p); } #undef FUNC_NAME @@ -153,6 +176,8 @@ dstate_free (SCM obj) { int size = sizeof (struct scm_dstate); struct scm_dstate *p = SCM_DSTATE_DATA (obj); + + /* Free dump image */ if (p->mmapped) { int rv; @@ -166,6 +191,23 @@ dstate_free (SCM obj) if (p->image_base) scm_must_free (p->image_base); } + + /* Free update schedules */ + while (p->object_updates) + { + struct scm_dump_object_update *next = p->object_updates->next; + scm_must_free (p->object_updates); + size += sizeof (struct scm_dump_object_update); + p->object_updates = next; + } + while (p->cell_updates) + { + struct scm_dump_cell_update *next = p->cell_updates->next; + scm_must_free (p->cell_updates); + size += sizeof (struct scm_dump_cell_update); + p->cell_updates = next; + } + scm_must_free (p); return size; } @@ -191,19 +233,17 @@ static scm_bits_t scm_object_indicator (SCM obj, SCM dstate) { if (SCM_IMP (obj)) - return SCM_UNPACK (obj); + { + return SCM_UNPACK (obj); + } else { - int i; - int len = SCM_DSTATE_TABLE_LENGTH (dstate); - SCM *base = SCM_DSTATE_TABLE_BASE (dstate); - for (i = 0; i < len; i++) - if (SCM_EQ_P (obj, base[i])) - return SCM_DUMP_INDEX_TO_WORD (i); + SCM id = scm_hashq_ref (SCM_DSTATE_TABLE (dstate), obj, SCM_BOOL_F); + if (SCM_FALSEP (id)) + return -1; + else + return SCM_DUMP_INDEX_TO_WORD (SCM_INUM (id)); } - scm_misc_error ("scm_object_indicator", - "Non-marked object: ~A", SCM_LIST1 (obj)); - return 0; } static SCM @@ -212,7 +252,7 @@ scm_indicator_object (scm_bits_t word, SCM dstate) if (SCM_IMP (SCM_PACK (word))) return SCM_PACK (word); else - return SCM_DSTATE_TABLE_BASE (dstate)[SCM_DUMP_WORD_TO_INDEX (word)]; + return SCM_DSTATE_TABLE_REF (dstate, SCM_DUMP_WORD_TO_INDEX (word)); } @@ -220,6 +260,8 @@ scm_indicator_object (scm_bits_t word, SCM dstate) * Dump interface */ +/* store functions */ + static void scm_store_pad (SCM dstate) { @@ -230,21 +272,15 @@ scm_store_pad (SCM dstate) p->image_base[p->image_index++] = '\0'; } -static void -scm_store_chars (const char *addr, scm_sizet size, SCM dstate) +void +scm_store_string (const char *addr, scm_sizet size, SCM dstate) { struct scm_dstate *p = SCM_DSTATE_DATA (dstate); - while (p->image_index + size >= p->image_size) + while (p->image_index + size + 1 >= p->image_size) dstate_extend (p); memcpy (p->image_base + p->image_index, addr, size); memcpy (p->image_base + p->image_index + size, "\0", 1); p->image_index += size + 1; -} - -void -scm_store_string (const char *addr, scm_sizet size, SCM dstate) -{ - scm_store_chars (addr, size, dstate); scm_store_pad (dstate); } @@ -268,9 +304,30 @@ scm_store_word (const scm_bits_t word, SCM dstate) void scm_store_object (SCM obj, SCM dstate) { - scm_store_word (scm_object_indicator (obj, dstate), dstate); + scm_bits_t id = scm_object_indicator (obj, dstate); + if (id == -1) + { + /* OBJ is not stored yet. Do it later */ + struct scm_dstate *p = SCM_DSTATE_DATA (dstate); + struct scm_dump_object_update *update = + scm_must_malloc (sizeof (struct scm_dump_object_update), + "scm_store_object"); + update->id = SCM_UNPACK (obj); + update->addr = (scm_bits_t *) p->image_index; + update->next = p->object_updates; + p->object_updates = update; + } + scm_store_word (id, dstate); } +void +scm_store_cell_object (SCM cell, int n, SCM dstate) +{ + scm_store_object (SCM_CELL_OBJECT (cell, n), dstate); +} + +/* restore functions */ + static void scm_restore_pad (SCM dstate) { @@ -279,20 +336,13 @@ scm_restore_pad (SCM dstate) p->image_index++; } -static const char * -scm_restore_chars (SCM dstate, int *lenp) +const char * +scm_restore_string (SCM dstate, int *lenp) { struct scm_dstate *p = SCM_DSTATE_DATA (dstate); const char *addr = p->image_base + p->image_index; *lenp = strlen (addr); p->image_index += *lenp + 1; - return addr; -} - -const char * -scm_restore_string (SCM dstate, int *lenp) -{ - const char *addr = scm_restore_chars (dstate, lenp); scm_restore_pad (dstate); return addr; } @@ -316,10 +366,42 @@ scm_restore_word (SCM dstate) return word; } -SCM -scm_restore_object (SCM dstate) +void +scm_restore_object (SCM *objp, SCM dstate) { - return scm_indicator_object (scm_restore_word (dstate), dstate); + scm_bits_t id = scm_restore_word (dstate); + *objp = scm_indicator_object (id, dstate); + + if (SCM_UNBNDP (*objp)) + { + struct scm_dump_object_update *update = + scm_must_malloc (sizeof (struct scm_dump_object_update), + "scm_restore_object"); + update->id = id; + update->addr = (scm_bits_t *) objp; + update->next = SCM_DSTATE_OBJECT_UPDATES (dstate); + SCM_DSTATE_OBJECT_UPDATES (dstate) = update; + } +} + +void +scm_restore_cell_object (SCM cell, int n, SCM dstate) +{ + scm_bits_t id = scm_restore_word (dstate); + SCM obj = scm_indicator_object (id, dstate); + SCM_SET_CELL_OBJECT (cell, n, obj); + + if (SCM_UNBNDP (obj)) + { + struct scm_dump_cell_update *update = + scm_must_malloc (sizeof (struct scm_dump_cell_update), + "scm_restore_cell_object"); + update->id = id; + update->cell = cell; + update->n = n; + update->next = SCM_DSTATE_CELL_UPDATES (dstate); + SCM_DSTATE_CELL_UPDATES (dstate) = update; + } } @@ -327,275 +409,145 @@ scm_restore_object (SCM dstate) * Dump routine */ -void -scm_dump_mark (SCM obj, SCM dstate) +static void +scm_dump (SCM obj, SCM dstate) { - SCM table = SCM_DSTATE_TABLE (dstate); + struct scm_dstate *p = SCM_DSTATE_DATA (dstate); - loop: - /* Nothing with immediates */ - if (SCM_IMP (obj)) + /* Check if immediate or already dumpped */ + if (scm_object_indicator (obj, dstate) != -1) return; - /* Return if already marked */ - if (!SCM_FALSEP (scm_hashq_ref (table, obj, SCM_BOOL_F))) - return; + /* Mark it */ + scm_hashq_set_x (p->table, obj, SCM_MAKINUM (p->table_index)); + p->table_index++; if (SCM_SLOPPY_CONSP (obj)) { - scm_hashq_set_x (table, obj, SCM_MAKINUM (scm_tc3_cons)); - scm_dump_mark (SCM_CAR (obj), dstate); - obj = SCM_CDR (obj); - goto loop; + scm_store_word (scm_tc3_cons, dstate); + /* Store cdr first in order to avoid a possible deep recursion + * with a long list */ + scm_store_cell_object (obj, 1, dstate); + scm_store_cell_object (obj, 0, dstate); + goto next_dump; } - switch (SCM_TYP7 (obj)) { case scm_tc7_symbol: - scm_hashq_set_x (table, obj, SCM_MAKINUM (scm_tc7_symbol)); - return; + { + scm_store_word (scm_tc7_symbol, dstate); + scm_store_string (SCM_SYMBOL_CHARS (obj), + SCM_SYMBOL_LENGTH (obj), + dstate); + return; + } case scm_tc7_substring: case scm_tc7_string: - scm_hashq_set_x (table, obj, SCM_MAKINUM (scm_tc7_string)); - return; + { + scm_store_word (scm_tc7_string, dstate); + scm_store_string (SCM_STRING_CHARS (obj), + SCM_STRING_LENGTH (obj), + dstate); + return; + } case scm_tc7_vector: { int i; int len = SCM_VECTOR_LENGTH (obj); SCM *base = SCM_VELTS (obj); - scm_hashq_set_x (table, obj, SCM_MAKINUM (scm_tc7_vector)); + scm_store_word (scm_tc7_vector, dstate); + scm_store_word (len, dstate); for (i = 0; i < len; i++) - scm_dump_mark (base[i], dstate); - return; + scm_store_object (base[i], dstate); + goto next_dump; } case scm_tc7_smob: { - SCM (*mark) () = SCM_SMOB_DESCRIPTOR (obj).dump_mark; - void (*dealloc) () = SCM_SMOB_DESCRIPTOR (obj).dump_dealloc; - void (*store) () = SCM_SMOB_DESCRIPTOR (obj).dump_store; + void (*dump) () = SCM_SMOB_DESCRIPTOR (obj).dump; + if (!dump) + goto error; - if (!(mark || dealloc || store)) - break; - - scm_hashq_set_x (table, obj, SCM_MAKINUM (SCM_CELL_TYPE (obj))); - if (mark) - { - obj = mark (obj, dstate); - goto loop; - } - return; + /* FIXME: SCM_CELL_TYPE may change when undump!! */ + scm_store_word (SCM_CELL_TYPE (obj), dstate); + dump (obj, dstate); + goto next_dump; } + default: + error: + scm_misc_error ("scm_dump_mark", "Cannot dump: ~A", SCM_LIST1 (obj)); } - scm_misc_error ("scm_dump_mark", "Cannot dump: ~A", SCM_LIST1 (obj)); -} -static void -scm_dump_dealloc (scm_bits_t tc, int nobjs, SCM *table, SCM dstate) -{ - switch (SCM_ITAG7 (SCM_PACK (tc))) + next_dump: + while (p->object_updates) { - case scm_tc7_symbol: - { - int i; - for (i = 0; i < nobjs; i++) - { - SCM obj = table[i]; - scm_store_chars (SCM_SYMBOL_CHARS (obj), - SCM_SYMBOL_LENGTH (obj), - dstate); - } - scm_store_pad (dstate); - return; - } - case scm_tc7_string: - { - int i; - for (i = 0; i < nobjs; i++) - { - SCM obj = table[i]; - scm_store_chars (SCM_STRING_CHARS (obj), - SCM_STRING_LENGTH (obj), - dstate); - } - scm_store_pad (dstate); - return; - } - case scm_tc7_vector: - { - int i; - for (i = 0; i < nobjs; i++) - scm_store_word (SCM_VECTOR_LENGTH (table[i]), dstate); - return; - } - case scm_tc7_smob: - { - int i; - void (*dealloc) () = scm_smobs[SCM_TC2SMOBNUM(tc)].dump_dealloc; - if (dealloc) - for (i = 0; i < nobjs; i++) - dealloc (table[i], dstate); - return; - } + struct scm_dump_object_update *update = p->object_updates; + p->object_updates = update->next; + scm_dump (SCM_PACK (update->id), dstate); + *(scm_bits_t *) (p->image_base + (int) update->addr) = + scm_object_indicator (SCM_PACK (update->id), dstate); + scm_must_free (update); } } static void -scm_dump_store (scm_bits_t tc, int nobjs, SCM *table, SCM dstate) +scm_undump (SCM dstate) { + struct scm_dstate *p = SCM_DSTATE_DATA (dstate); + scm_bits_t tc = scm_restore_word (dstate); + SCM obj; + if (SCM_ITAG3 (SCM_PACK (tc)) == scm_tc3_cons) { - int i; - for (i = 0; i < nobjs; i++) - { - SCM obj = table[i]; - scm_store_object (SCM_CAR (obj), dstate); - scm_store_object (SCM_CDR (obj), dstate); - } - return; - } - - switch (SCM_ITAG7 (SCM_PACK (tc))) - { - case scm_tc7_vector: - { - int i, j; - for (i = 0; i < nobjs; i++) - { - SCM obj = table[i]; - int len = SCM_VECTOR_LENGTH (obj); - SCM *base = SCM_VELTS (obj); - for (j = 0; j < len; j++) - scm_store_object (base[j], dstate); - } - return; - } - case scm_tc7_smob: - { - int i; - void (*store) () = scm_smobs[SCM_TC2SMOBNUM(tc)].dump_store; - if (store) - for (i = 0; i < nobjs; i++) - store (table[i], dstate); - return; - } - } -} - -static void -scm_undump_alloc (scm_bits_t tc, int nobjs, SCM *table, SCM dstate) -{ - if (SCM_ITAG3 (SCM_PACK (tc)) == scm_tc3_cons) - { - int i; - for (i = 0; i < nobjs; i++) - SCM_NEWCELL (table[i]); - return; + SCM_NEWCELL (obj); + /* cdr was stored first */ + scm_restore_cell_object (obj, 1, dstate); + scm_restore_cell_object (obj, 0, dstate); + goto store_object; } switch (SCM_ITAG7 (SCM_PACK (tc))) { case scm_tc7_symbol: { - int i; - for (i = 0; i < nobjs; i++) - { - int len; - const char *mem = scm_restore_chars (dstate, &len); - table[i] = scm_mem2symbol (mem, len); - } - scm_restore_pad (dstate); - return; + int len; + const char *mem = scm_restore_string (dstate, &len); + obj = scm_mem2symbol (mem, len); + goto store_object; } case scm_tc7_string: { - int i; - for (i = 0; i < nobjs; i++) - { - int len; - const char *mem = scm_restore_chars (dstate, &len); - table[i] = scm_makfromstr (mem, len, 0); - } - scm_restore_pad (dstate); - return; + int len; + const char *mem = scm_restore_string (dstate, &len); + obj = scm_makfromstr (mem, len, 0); + goto store_object; } case scm_tc7_vector: { int i; - for (i = 0; i < nobjs; i++) - { - int len = scm_restore_word (dstate); - table[i] = scm_c_make_vector (len, SCM_BOOL_F); - } - return; + int len = scm_restore_word (dstate); + SCM *base; + obj = scm_c_make_vector (len, SCM_BOOL_F); + base = SCM_VELTS (obj); + for (i = 0; i < len; i++) + scm_restore_object (&base[i], dstate); + goto store_object; } case scm_tc7_smob: { - int i; - SCM (*alloc) () = scm_smobs[SCM_TC2SMOBNUM(tc)].undump_alloc; - if (!alloc) - break; - for (i = 0; i < nobjs; i++) - table[i] = alloc (dstate); - return; + SCM (*undump) () = scm_smobs[SCM_TC2SMOBNUM (tc)].undump; + if (!undump) + goto error; + obj = undump (dstate); + goto store_object; } - } - scm_misc_error ("scm_undump_alloc", "Cannot undump", SCM_EOL); -} - -static void -scm_undump_restore (scm_bits_t tc, int nobjs, SCM *table, SCM dstate) -#define FUNC_NAME "scm_undump_restore" -{ - if (SCM_ITAG3 (SCM_PACK (tc)) == scm_tc3_cons) - { - int i; - for (i = 0; i < nobjs; i++) - { - SCM obj = table[i]; - SCM_SETCAR (obj, scm_restore_object (dstate)); - SCM_SETCDR (obj, scm_restore_object (dstate)); - } - return; + default: + error: + scm_misc_error ("scm_undump", "Cannot undump", SCM_EOL); } - switch (SCM_ITAG7 (SCM_PACK (tc))) - { - case scm_tc7_vector: - { - int i, j; - for (i = 0; i < nobjs; i++) - { - SCM obj = table[i]; - int len = SCM_VECTOR_LENGTH (obj); - SCM *base = SCM_VELTS (obj); - for (j = 0; j < len; j++) - base[j] = scm_restore_object (dstate); - } - return; - } - case scm_tc7_smob: - { - int i; - void (*restore) () = scm_smobs[SCM_TC2SMOBNUM(tc)].undump_restore; - if (restore) - for (i = 0; i < nobjs; i++) - restore (table[i], dstate); - } - } -} -#undef FUNC_NAME - -static void -scm_undump_init (scm_bits_t tc, int nobjs, SCM *table, SCM dstate) -{ - if (SCM_ITAG7 (SCM_PACK (tc)) == scm_tc7_smob) - { - int i; - void (*init) () = scm_smobs[SCM_TC2SMOBNUM(tc)].undump_init; - if (init) - for (i = 0; i < nobjs; i++) - init (table[i]); - } + store_object: + SCM_DSTATE_TABLE_SET (dstate, p->table_index, obj); + p->table_index++; } @@ -603,39 +555,14 @@ scm_undump_init (scm_bits_t tc, int nobjs, SCM *table, SCM dstate) * Scheme interface */ -#define DUMP_APPLY(f,nmeta,meta,table) \ -{ \ - int i; \ - int len = 0; \ - for (i = 0; i < nmeta; i++) \ - { \ - f (meta[i].tc, meta[i].nobjs, table + len, dstate); \ - len += meta[i].nobjs; \ - } \ -} - -static SCM -scm_dump_table_fold (void *proc, SCM key, SCM data, SCM value) -{ - SCM handle = scm_sloppy_assq (data, value); - if (SCM_CONSP (handle)) - { - SCM_SETCDR (handle, scm_cons (key, SCM_CDR (handle))); - return value; - } - else - return scm_acons (data, SCM_LIST1 (key), value); -} - SCM_DEFINE (scm_binary_write, "binary-write", 1, 1, 0, (SCM obj, SCM port), "Write OBJ to PORT in a binary format.") #define FUNC_NAME s_scm_binary_write { - int i, index, len, nmeta; + struct scm_dstate *p; struct scm_dump_header header; - struct scm_dump_meta *meta; - SCM dstate, alist, list, *base; + SCM dstate; /* Check port */ if (SCM_UNBNDP (port)) @@ -643,57 +570,21 @@ SCM_DEFINE (scm_binary_write, "binary-write", 1, 1, 0, else SCM_VALIDATE_OUTPUT_PORT (2, port); - /* Mark objects */ + /* Dump objects */ dstate = make_dstate (); - SCM_DSTATE_TABLE (dstate) = - scm_c_make_hash_table (SCM_DUMP_INITIAL_HASH_SIZE); - scm_dump_mark (obj, dstate); + p = SCM_DSTATE_DATA (dstate); + p->table = scm_c_make_hash_table (SCM_DUMP_HASH_SIZE); + scm_dump (obj, dstate); - /* Build meta information */ - alist = scm_internal_hash_fold (scm_dump_table_fold, 0, SCM_EOL, - SCM_DSTATE_TABLE (dstate)); - nmeta = scm_ilength (alist); - meta = alloca (nmeta * sizeof (struct scm_dump_meta)); - list = alist; - len = 0; - for (i = 0; i < nmeta; i++) - { - meta[i].tc = SCM_INUM (SCM_CAAR (list)); - meta[i].nobjs = scm_ilength (SCM_CDAR (list)); - len += meta[i].nobjs; - list = SCM_CDR (list); - } - - /* Build object table */ - SCM_DSTATE_TABLE (dstate) = scm_c_make_vector (len, SCM_BOOL_F); - base = SCM_DSTATE_TABLE_BASE (dstate); - index = 0; - for (i = 0; i < nmeta; i++) - { - SCM list; - for (list = SCM_CDAR (alist); !SCM_NULLP (list); list = SCM_CDR (list)) - base[index++] = SCM_CAR (list); - alist = SCM_CDR (alist); - } - - /* Dump */ - DUMP_APPLY (scm_dump_dealloc, nmeta, meta, base); - DUMP_APPLY (scm_dump_store, nmeta, meta, base); - - /* Write header */ + /* Write image */ header.cookie = ((scm_bits_t *) SCM_DUMP_COOKIE)[0]; header.version = ((scm_bits_t *) SCM_DUMP_COOKIE)[1]; - header.nmeta = nmeta; - header.init = scm_object_indicator (obj, dstate); + header.nobjs = (p->table_index + ? SCM_DUMP_INDEX_TO_WORD (p->table_index) + : SCM_UNPACK (obj)); scm_lfwrite ((const char *) &header, sizeof (struct scm_dump_header), port); - - /* Write the rest */ - scm_lfwrite ((const char *) meta, - nmeta * sizeof (struct scm_dump_meta), - port); - scm_lfwrite (SCM_DSTATE_DATA (dstate)->image_base, - SCM_DSTATE_DATA (dstate)->image_index, - port); + if (p->image_index) + scm_lfwrite (p->image_base, p->image_index, port); return SCM_UNSPECIFIED; } @@ -704,11 +595,10 @@ SCM_DEFINE (scm_binary_read, "binary-read", 0, 1, 0, "Read an object from PORT in a binary format.") #define FUNC_NAME s_scm_binary_read { - int i, len; - scm_bits_t *data; + int i, nobjs; + struct scm_dstate *p; struct scm_dump_header *header; - struct scm_dump_meta *meta; - SCM dstate, *base; + SCM dstate; /* Check port */ if (SCM_UNBNDP (port)) @@ -723,37 +613,53 @@ SCM_DEFINE (scm_binary_read, "binary-read", 0, 1, 0, else /* Undump with malloc */ SCM_MISC_ERROR ("Not supported yet", SCM_EOL); + p = SCM_DSTATE_DATA (dstate); /* Read header */ - header = (struct scm_dump_header *) SCM_DSTATE_DATA (dstate)->image_base; - if (SCM_DSTATE_DATA (dstate)->image_size < sizeof (*header)) + header = (struct scm_dump_header *) p->image_base; + p->image_index += sizeof (struct scm_dump_header); + if (p->image_size < sizeof (*header)) SCM_MISC_ERROR ("Invalid binary format: ~A", SCM_LIST1 (port)); if (header->cookie != ((scm_bits_t *) SCM_DUMP_COOKIE)[0]) SCM_MISC_ERROR ("Invalid binary format: ~A", SCM_LIST1 (port)); if (header->version != ((scm_bits_t *) SCM_DUMP_COOKIE)[1]) SCM_MISC_ERROR ("Unsupported binary version: ~A", SCM_LIST1 (port)); - /* Read the rest */ - meta = (struct scm_dump_meta *) ((char *) header + sizeof (*header)); - data = (scm_bits_t *) (meta + header->nmeta); - SCM_DSTATE_DATA (dstate)->image_index = (char *) data - (char *) header; + /* Check for immediate */ + if (SCM_IMP (SCM_PACK (header->nobjs))) + return SCM_PACK (header->nobjs); /* Create object table */ - len = 0; - for (i = 0; i < header->nmeta; i++) - len += meta[i].nobjs; - SCM_DSTATE_TABLE (dstate) = scm_c_make_vector (len, SCM_BOOL_F); - base = SCM_DSTATE_TABLE_BASE (dstate); + nobjs = SCM_DUMP_WORD_TO_INDEX (header->nobjs); + p->table = scm_c_make_vector (nobjs, SCM_UNDEFINED); /* Undump */ - DUMP_APPLY (scm_undump_alloc, header->nmeta, meta, base); - DUMP_APPLY (scm_undump_restore, header->nmeta, meta, base); - DUMP_APPLY (scm_undump_init, header->nmeta, meta, base); + for (i = 0; i < nobjs; i++) + scm_undump (dstate); + + /* Update references */ + while (p->object_updates) + { + struct scm_dump_object_update *update = p->object_updates; + p->object_updates = update->next; + *(update->addr) = SCM_UNPACK (scm_indicator_object (update->id, dstate)); + scm_must_free (update); + } + /* Link objects */ + while (p->cell_updates) + { + struct scm_dump_cell_update *update = p->cell_updates; + p->cell_updates = update->next; + SCM_SET_CELL_OBJECT (update->cell, + update->n, + scm_indicator_object (update->id, dstate)); + scm_must_free (update); + } /* Return */ { - SCM obj = scm_indicator_object (header->init, dstate); - SCM_DSTATE_TABLE (dstate) = SCM_BOOL_F; + SCM obj = SCM_DSTATE_TABLE_REF (dstate, 0); + p->table = SCM_BOOL_F; return obj; } } diff --git a/libguile/dump.h b/libguile/dump.h index 157e98ae7..1c7181809 100644 --- a/libguile/dump.h +++ b/libguile/dump.h @@ -45,15 +45,17 @@ #include "libguile/__scm.h" -extern void scm_dump_mark (SCM obj, SCM dstate); extern void scm_store_string (const char *addr, scm_sizet size, SCM dstate); extern void scm_store_bytes (const char *addr, scm_sizet size, SCM dstate); extern void scm_store_word (const scm_bits_t word, SCM dstate); extern void scm_store_object (SCM obj, SCM dstate); +extern void scm_store_cell_object (SCM cell, int n, SCM dstate); + extern const char *scm_restore_string (SCM dstate, int *lenp); extern const char *scm_restore_bytes (SCM dstate, scm_sizet size); extern scm_bits_t scm_restore_word (SCM dstate); -extern SCM scm_restore_object (SCM dstate); +extern void scm_restore_object (SCM *objp, SCM dstate); +extern void scm_restore_cell_object (SCM cell, int n, SCM dstate); extern SCM scm_binary_write (SCM obj, SCM port); extern SCM scm_binary_read (SCM port); diff --git a/libguile/keywords.c b/libguile/keywords.c index a1cc1c8c9..7361499b8 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -69,7 +69,7 @@ keyword_print (SCM exp, SCM port, scm_print_state *pstate) } static void -keyword_dealloc (SCM obj, SCM dstate) +keyword_dump (SCM obj, SCM dstate) { SCM sym = scm_keyword_dash_symbol (obj); scm_store_string (SCM_SYMBOL_CHARS (sym), @@ -78,7 +78,7 @@ keyword_dealloc (SCM obj, SCM dstate) } static SCM -keyword_alloc (SCM dstate) +keyword_undump (SCM dstate) { int len; const char *mem = scm_restore_string (dstate, &len); @@ -156,8 +156,8 @@ scm_init_keywords () scm_tc16_keyword = scm_make_smob_type ("keyword", 0); scm_set_smob_mark (scm_tc16_keyword, scm_markcdr); scm_set_smob_print (scm_tc16_keyword, keyword_print); - scm_set_smob_dump (scm_tc16_keyword, 0, keyword_dealloc, 0); - scm_set_smob_undump (scm_tc16_keyword, keyword_alloc, 0, 0); + scm_set_smob_dump (scm_tc16_keyword, keyword_dump); + scm_set_smob_undump (scm_tc16_keyword, keyword_undump); scm_keyword_obarray = scm_c_make_hash_table (256); #ifndef SCM_MAGIC_SNARFER diff --git a/libguile/smob.c b/libguile/smob.c index bcc665ac3..104c81ce7 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -299,13 +299,9 @@ scm_make_smob_type (char *name, scm_sizet size) scm_smobs[scm_numsmob].apply_1 = 0; scm_smobs[scm_numsmob].apply_2 = 0; scm_smobs[scm_numsmob].apply_3 = 0; - scm_smobs[scm_numsmob].gsubr_type = 0; - scm_smobs[scm_numsmob].dump_mark = 0; - scm_smobs[scm_numsmob].dump_dealloc = 0; - scm_smobs[scm_numsmob].dump_store = 0; - scm_smobs[scm_numsmob].undump_alloc = 0; - scm_smobs[scm_numsmob].undump_restore = 0; - scm_smobs[scm_numsmob].undump_init = 0; + scm_smobs[scm_numsmob].gsubr_type = 0; + scm_smobs[scm_numsmob].dump = 0; + scm_smobs[scm_numsmob].undump = 0; scm_numsmob++; } SCM_ALLOW_INTS; @@ -456,25 +452,15 @@ scm_set_smob_apply (scm_bits_t tc, SCM (*apply) (), } void -scm_set_smob_dump (scm_bits_t tc, - SCM (*mark) (SCM, SCM), - void (*dealloc) (SCM, SCM), - void (*store) (SCM, SCM)) +scm_set_smob_dump (scm_bits_t tc, void (*dump) (SCM, SCM)) { - scm_smobs[SCM_TC2SMOBNUM (tc)].dump_mark = mark; - scm_smobs[SCM_TC2SMOBNUM (tc)].dump_dealloc = dealloc; - scm_smobs[SCM_TC2SMOBNUM (tc)].dump_store = store; + scm_smobs[SCM_TC2SMOBNUM (tc)].dump = dump; } void -scm_set_smob_undump (scm_bits_t tc, - SCM (*alloc) (SCM), - void (*restore) (SCM, SCM), - void (*init) (SCM)) +scm_set_smob_undump (scm_bits_t tc, SCM (*undump) (SCM)) { - scm_smobs[SCM_TC2SMOBNUM (tc)].undump_alloc = alloc; - scm_smobs[SCM_TC2SMOBNUM (tc)].undump_restore = restore; - scm_smobs[SCM_TC2SMOBNUM (tc)].undump_init = init; + scm_smobs[SCM_TC2SMOBNUM (tc)].undump = undump; } SCM diff --git a/libguile/smob.h b/libguile/smob.h index f37b0263f..f0a167963 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -69,12 +69,8 @@ typedef struct scm_smob_descriptor int gsubr_type; /* Used in procprop.c */ /* Dump functions */ - SCM (*dump_mark) (SCM, SCM); - void (*dump_dealloc) (SCM, SCM); - void (*dump_store) (SCM, SCM); - SCM (*undump_alloc) (SCM); - void (*undump_restore) (SCM, SCM); - void (*undump_init) (SCM); + void (*dump) (SCM, SCM); + SCM (*undump) (SCM); } scm_smob_descriptor; @@ -157,27 +153,18 @@ extern int scm_smob_print (SCM exp, SCM port, scm_print_state *pstate); extern scm_bits_t scm_make_smob_type (char *name, scm_sizet size); -extern void scm_set_smob_mark (scm_bits_t tc, - SCM (*mark) (SCM)); -extern void scm_set_smob_free (scm_bits_t tc, - scm_sizet (*free) (SCM)); +extern void scm_set_smob_mark (scm_bits_t tc, SCM (*mark) (SCM)); +extern void scm_set_smob_free (scm_bits_t tc, scm_sizet (*free) (SCM)); extern void scm_set_smob_print (scm_bits_t tc, int (*print) (SCM, SCM, scm_print_state*)); -extern void scm_set_smob_equalp (scm_bits_t tc, - SCM (*equalp) (SCM, SCM)); +extern void scm_set_smob_equalp (scm_bits_t tc, SCM (*equalp) (SCM, SCM)); extern void scm_set_smob_apply (scm_bits_t tc, SCM (*apply) (), unsigned int req, unsigned int opt, unsigned int rst); -extern void scm_set_smob_dump (scm_bits_t tc, - SCM (*mark) (SCM, SCM), - void (*dealloc) (SCM, SCM), - void (*store) (SCM, SCM)); -extern void scm_set_smob_undump (scm_bits_t tc, - SCM (*alloc) (SCM), - void (*restore) (SCM, SCM), - void (*init) (SCM)); +extern void scm_set_smob_dump (scm_bits_t tc, void (*dump) (SCM, SCM)); +extern void scm_set_smob_undump (scm_bits_t tc, SCM (*undump) (SCM)); /* Function for creating smobs */ From 35d99e4aebd35cf468415ada168ee3c76a3c9109 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Mon, 5 Feb 2001 19:00:56 +0000 Subject: [PATCH 0510/2047] *** empty log message *** --- libltdl/.cvsignore | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) create mode 100644 libltdl/.cvsignore diff --git a/libltdl/.cvsignore b/libltdl/.cvsignore new file mode 100644 index 000000000..a76fe0370 --- /dev/null +++ b/libltdl/.cvsignore @@ -0,0 +1,21 @@ +.libs +COPYING.LIB +Makefile +Makefile.am +Makefile.in +README +acconfig.h +acinclude.m4 +aclocal.m4 +config.h +config.h.in +config.log +config.status +configure +configure.in +libltdlc.la +libtool +ltdl.c +ltdl.h +ltdl.lo +stamp-h From 5f17c66f82b418ccb1612e0c90bbc893c6b5a6fb Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Mon, 5 Feb 2001 19:14:20 +0000 Subject: [PATCH 0511/2047] Minor modifications. --- libguile/ChangeLog | 1 + libguile/dump.c | 22 +++++++++++----------- libguile/dump.h | 6 +++--- libguile/keywords.c | 2 +- 4 files changed, 16 insertions(+), 15 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index efd196325..46729996d 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,6 +1,7 @@ 2001-02-05 Keisuke Nishida * dump.c, dump.h: Modified a lot. + (SCM_DUMP_COOKIE): Version 0.1 (scm_dump_mark): Removed. (scm_restore_cell_object, scm_store_cell_object): New functions. diff --git a/libguile/dump.c b/libguile/dump.c index 71141c6a6..870c08df4 100644 --- a/libguile/dump.c +++ b/libguile/dump.c @@ -60,7 +60,7 @@ #include "libguile/validate.h" #include "libguile/dump.h" -#define SCM_DUMP_COOKIE "\x7fGBF-0.0" +#define SCM_DUMP_COOKIE "\x7fGBF-0.1" #define SCM_DUMP_HASH_SIZE 151 #define SCM_DUMP_IMAGE_SIZE 4096 @@ -285,7 +285,7 @@ scm_store_string (const char *addr, scm_sizet size, SCM dstate) } void -scm_store_bytes (const char *addr, scm_sizet size, SCM dstate) +scm_store_bytes (const void *addr, scm_sizet size, SCM dstate) { struct scm_dstate *p = SCM_DSTATE_DATA (dstate); while (p->image_index + size >= p->image_size) @@ -298,7 +298,7 @@ scm_store_bytes (const char *addr, scm_sizet size, SCM dstate) void scm_store_word (const scm_bits_t word, SCM dstate) { - scm_store_bytes ((const char *) &word, sizeof (scm_bits_t), dstate); + scm_store_bytes (&word, sizeof (scm_bits_t), dstate); } void @@ -337,21 +337,21 @@ scm_restore_pad (SCM dstate) } const char * -scm_restore_string (SCM dstate, int *lenp) +scm_restore_string (scm_sizet *sizep, SCM dstate) { struct scm_dstate *p = SCM_DSTATE_DATA (dstate); const char *addr = p->image_base + p->image_index; - *lenp = strlen (addr); - p->image_index += *lenp + 1; + *sizep = strlen (addr); + p->image_index += *sizep + 1; scm_restore_pad (dstate); return addr; } -const char * -scm_restore_bytes (SCM dstate, scm_sizet size) +const void * +scm_restore_bytes (scm_sizet size, SCM dstate) { struct scm_dstate *p = SCM_DSTATE_DATA (dstate); - const char *addr = p->image_base + p->image_index; + const void *addr = p->image_base + p->image_index; p->image_index += size; scm_restore_pad (dstate); return addr; @@ -510,14 +510,14 @@ scm_undump (SCM dstate) case scm_tc7_symbol: { int len; - const char *mem = scm_restore_string (dstate, &len); + const char *mem = scm_restore_string (&len, dstate); obj = scm_mem2symbol (mem, len); goto store_object; } case scm_tc7_string: { int len; - const char *mem = scm_restore_string (dstate, &len); + const char *mem = scm_restore_string (&len, dstate); obj = scm_makfromstr (mem, len, 0); goto store_object; } diff --git a/libguile/dump.h b/libguile/dump.h index 1c7181809..f00b95866 100644 --- a/libguile/dump.h +++ b/libguile/dump.h @@ -46,13 +46,13 @@ #include "libguile/__scm.h" extern void scm_store_string (const char *addr, scm_sizet size, SCM dstate); -extern void scm_store_bytes (const char *addr, scm_sizet size, SCM dstate); +extern void scm_store_bytes (const void *addr, scm_sizet size, SCM dstate); extern void scm_store_word (const scm_bits_t word, SCM dstate); extern void scm_store_object (SCM obj, SCM dstate); extern void scm_store_cell_object (SCM cell, int n, SCM dstate); -extern const char *scm_restore_string (SCM dstate, int *lenp); -extern const char *scm_restore_bytes (SCM dstate, scm_sizet size); +extern const char *scm_restore_string (scm_sizet *sizep, SCM dstate); +extern const void *scm_restore_bytes (scm_sizet size, SCM dstate); extern scm_bits_t scm_restore_word (SCM dstate); extern void scm_restore_object (SCM *objp, SCM dstate); extern void scm_restore_cell_object (SCM cell, int n, SCM dstate); diff --git a/libguile/keywords.c b/libguile/keywords.c index 7361499b8..1810d6df0 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -81,7 +81,7 @@ static SCM keyword_undump (SCM dstate) { int len; - const char *mem = scm_restore_string (dstate, &len); + const char *mem = scm_restore_string (&len, dstate); SCM sym = scm_mem2symbol (mem, len); return scm_make_keyword_from_dash_symbol (sym); } From bf8f0922803b0885853ab0a4cebdd6f90d1a4daa Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Tue, 6 Feb 2001 02:12:10 +0000 Subject: [PATCH 0512/2047] Removed redundant code. --- libguile/ChangeLog | 9 +++ libguile/dump.c | 191 ++++++++++++++++---------------------------- libguile/dump.h | 8 +- libguile/keywords.c | 6 +- 4 files changed, 83 insertions(+), 131 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 46729996d..9265dc481 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2001-02-05 Keisuke Nishida + + * dump.c (scm_store_cell_object, scm_restore_cell_object): Removed. + (scm_dump_cell_update): Removed. + (scm_dump_update): Renamed from scm_dump_object_update. + (scm_restore_string, scm_restore_bytes, scm_restore_word): Takes + a pointer instead of returning a value. + * keywords.c (keyword_undump): Updated. + 2001-02-05 Keisuke Nishida * dump.c, dump.h: Modified a lot. diff --git a/libguile/dump.c b/libguile/dump.c index 870c08df4..785636110 100644 --- a/libguile/dump.c +++ b/libguile/dump.c @@ -75,17 +75,10 @@ struct scm_dump_header { /* or immediate value */ }; -struct scm_dump_object_update { +struct scm_dump_update { scm_bits_t id; /* object identifier */ scm_bits_t *addr; /* object address */ - struct scm_dump_object_update *next; /* next update */ -}; - -struct scm_dump_cell_update { - scm_bits_t id; /* object identifier */ - SCM cell; /* cell */ - int n; /* 0-3 */ - struct scm_dump_cell_update *next; /* next update */ + struct scm_dump_update *next; /* next update */ }; @@ -96,41 +89,33 @@ struct scm_dump_cell_update { static scm_bits_t scm_tc16_dstate; struct scm_dstate { - /* Memory image */ int mmapped; scm_sizet image_size; int image_index; - char *image_base; - - /* Object table */ + char *image_base; /* Memory image */ int table_index; - SCM table; - - /* Update schedule */ - struct scm_dump_object_update *object_updates; - struct scm_dump_cell_update *cell_updates; + SCM table; /* Object table */ + struct scm_dump_update *updates; /* Update schedule */ }; #define SCM_DSTATE_DATA(d) ((struct scm_dstate *) SCM_SMOB_DATA (d)) #define SCM_DSTATE_TABLE(d) (SCM_DSTATE_DATA (d)->table) #define SCM_DSTATE_TABLE_REF(d,i) (SCM_VELTS (SCM_DSTATE_TABLE (d))[i]) #define SCM_DSTATE_TABLE_SET(d,i,x) (SCM_VELTS (SCM_DSTATE_TABLE (d))[i] = (x)) -#define SCM_DSTATE_OBJECT_UPDATES(d)(SCM_DSTATE_DATA (d)->object_updates) -#define SCM_DSTATE_CELL_UPDATES(d) (SCM_DSTATE_DATA (d)->cell_updates) +#define SCM_DSTATE_UPDATES(d) (SCM_DSTATE_DATA (d)->updates) static SCM make_dstate () #define FUNC_NAME "make_dstate" { struct scm_dstate *p = SCM_MUST_MALLOC (sizeof (struct scm_dstate)); - p->mmapped = 0; - p->image_size = SCM_DUMP_IMAGE_SIZE; - p->image_index = 0; - p->image_base = SCM_MUST_MALLOC (p->image_size); - p->table_index = 0; - p->table = SCM_BOOL_F; - p->object_updates = 0; - p->cell_updates = 0; + p->mmapped = 0; + p->image_size = SCM_DUMP_IMAGE_SIZE; + p->image_index = 0; + p->image_base = SCM_MUST_MALLOC (p->image_size); + p->table_index = 0; + p->table = SCM_BOOL_F; + p->updates = 0; SCM_RETURN_NEWSMOB (scm_tc16_dstate, p); } #undef FUNC_NAME @@ -152,14 +137,13 @@ make_dstate_by_mmap (int fd) if (addr == MAP_FAILED) SCM_SYSERROR; - p->mmapped = 1; - p->image_size = st.st_size; - p->image_index = 0; - p->image_base = addr; - p->table_index = 0; - p->table = SCM_BOOL_F; - p->object_updates = 0; - p->cell_updates = 0; + p->mmapped = 1; + p->image_size = st.st_size; + p->image_index = 0; + p->image_base = addr; + p->table_index = 0; + p->table = SCM_BOOL_F; + p->updates = 0; SCM_RETURN_NEWSMOB (scm_tc16_dstate, p); } #undef FUNC_NAME @@ -193,19 +177,12 @@ dstate_free (SCM obj) } /* Free update schedules */ - while (p->object_updates) + while (p->updates) { - struct scm_dump_object_update *next = p->object_updates->next; - scm_must_free (p->object_updates); - size += sizeof (struct scm_dump_object_update); - p->object_updates = next; - } - while (p->cell_updates) - { - struct scm_dump_cell_update *next = p->cell_updates->next; - scm_must_free (p->cell_updates); - size += sizeof (struct scm_dump_cell_update); - p->cell_updates = next; + struct scm_dump_update *next = p->updates->next; + scm_must_free (p->updates); + size += sizeof (struct scm_dump_update); + p->updates = next; } scm_must_free (p); @@ -309,98 +286,69 @@ scm_store_object (SCM obj, SCM dstate) { /* OBJ is not stored yet. Do it later */ struct scm_dstate *p = SCM_DSTATE_DATA (dstate); - struct scm_dump_object_update *update = - scm_must_malloc (sizeof (struct scm_dump_object_update), + struct scm_dump_update *update = + scm_must_malloc (sizeof (struct scm_dump_update), "scm_store_object"); update->id = SCM_UNPACK (obj); update->addr = (scm_bits_t *) p->image_index; - update->next = p->object_updates; - p->object_updates = update; + update->next = p->updates; + p->updates = update; } scm_store_word (id, dstate); } -void -scm_store_cell_object (SCM cell, int n, SCM dstate) -{ - scm_store_object (SCM_CELL_OBJECT (cell, n), dstate); -} - /* restore functions */ static void -scm_restore_pad (SCM dstate) +scm_restore_pad (struct scm_dstate *p) { - struct scm_dstate *p = SCM_DSTATE_DATA (dstate); while (p->image_index % sizeof (scm_bits_t) != 0) p->image_index++; } -const char * -scm_restore_string (scm_sizet *sizep, SCM dstate) +void +scm_restore_string (const char **pp, scm_sizet *sizep, SCM dstate) { struct scm_dstate *p = SCM_DSTATE_DATA (dstate); - const char *addr = p->image_base + p->image_index; - *sizep = strlen (addr); + *pp = p->image_base + p->image_index; + *sizep = strlen (*pp); p->image_index += *sizep + 1; - scm_restore_pad (dstate); - return addr; + scm_restore_pad (p); } -const void * -scm_restore_bytes (scm_sizet size, SCM dstate) +void +scm_restore_bytes (const void **pp, scm_sizet size, SCM dstate) { struct scm_dstate *p = SCM_DSTATE_DATA (dstate); - const void *addr = p->image_base + p->image_index; + *pp = p->image_base + p->image_index; p->image_index += size; - scm_restore_pad (dstate); - return addr; + scm_restore_pad (p); } -scm_bits_t -scm_restore_word (SCM dstate) +void +scm_restore_word (scm_bits_t *wordp, SCM dstate) { struct scm_dstate *p = SCM_DSTATE_DATA (dstate); - scm_bits_t word = *(scm_bits_t *) (p->image_base + p->image_index); + *wordp = *(scm_bits_t *) (p->image_base + p->image_index); p->image_index += sizeof (scm_bits_t); - return word; } void scm_restore_object (SCM *objp, SCM dstate) { - scm_bits_t id = scm_restore_word (dstate); + scm_bits_t id; + scm_restore_word (&id, dstate); *objp = scm_indicator_object (id, dstate); if (SCM_UNBNDP (*objp)) { - struct scm_dump_object_update *update = - scm_must_malloc (sizeof (struct scm_dump_object_update), + struct scm_dump_update *update = + scm_must_malloc (sizeof (struct scm_dump_update), "scm_restore_object"); update->id = id; update->addr = (scm_bits_t *) objp; - update->next = SCM_DSTATE_OBJECT_UPDATES (dstate); - SCM_DSTATE_OBJECT_UPDATES (dstate) = update; - } -} - -void -scm_restore_cell_object (SCM cell, int n, SCM dstate) -{ - scm_bits_t id = scm_restore_word (dstate); - SCM obj = scm_indicator_object (id, dstate); - SCM_SET_CELL_OBJECT (cell, n, obj); - - if (SCM_UNBNDP (obj)) - { - struct scm_dump_cell_update *update = - scm_must_malloc (sizeof (struct scm_dump_cell_update), - "scm_restore_cell_object"); - update->id = id; - update->cell = cell; - update->n = n; - update->next = SCM_DSTATE_CELL_UPDATES (dstate); - SCM_DSTATE_CELL_UPDATES (dstate) = update; + update->next = SCM_DSTATE_UPDATES (dstate); + SCM_DSTATE_UPDATES (dstate) = update; } } @@ -427,8 +375,8 @@ scm_dump (SCM obj, SCM dstate) scm_store_word (scm_tc3_cons, dstate); /* Store cdr first in order to avoid a possible deep recursion * with a long list */ - scm_store_cell_object (obj, 1, dstate); - scm_store_cell_object (obj, 0, dstate); + scm_store_object (SCM_CDR (obj), dstate); + scm_store_object (SCM_CAR (obj), dstate); goto next_dump; } switch (SCM_TYP7 (obj)) @@ -478,10 +426,10 @@ scm_dump (SCM obj, SCM dstate) } next_dump: - while (p->object_updates) + while (p->updates) { - struct scm_dump_object_update *update = p->object_updates; - p->object_updates = update->next; + struct scm_dump_update *update = p->updates; + p->updates = update->next; scm_dump (SCM_PACK (update->id), dstate); *(scm_bits_t *) (p->image_base + (int) update->addr) = scm_object_indicator (SCM_PACK (update->id), dstate); @@ -493,15 +441,17 @@ static void scm_undump (SCM dstate) { struct scm_dstate *p = SCM_DSTATE_DATA (dstate); - scm_bits_t tc = scm_restore_word (dstate); + scm_bits_t tc; SCM obj; + scm_restore_word (&tc, dstate); + if (SCM_ITAG3 (SCM_PACK (tc)) == scm_tc3_cons) { SCM_NEWCELL (obj); /* cdr was stored first */ - scm_restore_cell_object (obj, 1, dstate); - scm_restore_cell_object (obj, 0, dstate); + scm_restore_object ((SCM *) &SCM_CDR (obj), dstate); + scm_restore_object ((SCM *) &SCM_CAR (obj), dstate); goto store_object; } @@ -510,22 +460,25 @@ scm_undump (SCM dstate) case scm_tc7_symbol: { int len; - const char *mem = scm_restore_string (&len, dstate); + const char *mem; + scm_restore_string (&mem, &len, dstate); obj = scm_mem2symbol (mem, len); goto store_object; } case scm_tc7_string: { int len; - const char *mem = scm_restore_string (&len, dstate); + const char *mem; + scm_restore_string (&mem, &len, dstate); obj = scm_makfromstr (mem, len, 0); goto store_object; } case scm_tc7_vector: { int i; - int len = scm_restore_word (dstate); + scm_bits_t len; SCM *base; + scm_restore_word (&len, dstate); obj = scm_c_make_vector (len, SCM_BOOL_F); base = SCM_VELTS (obj); for (i = 0; i < len; i++) @@ -638,23 +591,13 @@ SCM_DEFINE (scm_binary_read, "binary-read", 0, 1, 0, scm_undump (dstate); /* Update references */ - while (p->object_updates) + while (p->updates) { - struct scm_dump_object_update *update = p->object_updates; - p->object_updates = update->next; + struct scm_dump_update *update = p->updates; + p->updates = update->next; *(update->addr) = SCM_UNPACK (scm_indicator_object (update->id, dstate)); scm_must_free (update); } - /* Link objects */ - while (p->cell_updates) - { - struct scm_dump_cell_update *update = p->cell_updates; - p->cell_updates = update->next; - SCM_SET_CELL_OBJECT (update->cell, - update->n, - scm_indicator_object (update->id, dstate)); - scm_must_free (update); - } /* Return */ { diff --git a/libguile/dump.h b/libguile/dump.h index f00b95866..583bc0ea8 100644 --- a/libguile/dump.h +++ b/libguile/dump.h @@ -49,13 +49,11 @@ extern void scm_store_string (const char *addr, scm_sizet size, SCM dstate); extern void scm_store_bytes (const void *addr, scm_sizet size, SCM dstate); extern void scm_store_word (const scm_bits_t word, SCM dstate); extern void scm_store_object (SCM obj, SCM dstate); -extern void scm_store_cell_object (SCM cell, int n, SCM dstate); -extern const char *scm_restore_string (scm_sizet *sizep, SCM dstate); -extern const void *scm_restore_bytes (scm_sizet size, SCM dstate); -extern scm_bits_t scm_restore_word (SCM dstate); +extern void scm_restore_string (const char **pp, scm_sizet *sizep, SCM dstate); +extern void scm_restore_bytes (const void **pp, scm_sizet size, SCM dstate); +extern void scm_restore_word (scm_bits_t *wordp, SCM dstate); extern void scm_restore_object (SCM *objp, SCM dstate); -extern void scm_restore_cell_object (SCM cell, int n, SCM dstate); extern SCM scm_binary_write (SCM obj, SCM port); extern SCM scm_binary_read (SCM port); diff --git a/libguile/keywords.c b/libguile/keywords.c index 1810d6df0..d3e9f8c94 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -81,8 +81,10 @@ static SCM keyword_undump (SCM dstate) { int len; - const char *mem = scm_restore_string (&len, dstate); - SCM sym = scm_mem2symbol (mem, len); + const char *mem; + SCM sym; + scm_restore_string (&mem, &len, dstate); + sym = scm_mem2symbol (mem, len); return scm_make_keyword_from_dash_symbol (sym); } From e382fdbe0f4c540dd70e6e77ccbf9368d7cea2e4 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 8 Feb 2001 10:48:01 +0000 Subject: [PATCH 0513/2047] * Fixed parameter checking for make-vector. --- libguile/ChangeLog | 9 +++++++++ libguile/vectors.c | 48 ++++++++++++++++++++++++++++------------------ libguile/vectors.h | 1 + 3 files changed, 39 insertions(+), 19 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 9265dc481..14033e6b5 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2001-02-08 Dirk Herrmann + + * vectors.h (SCM_VECTOR_MAX_LENGTH): New macro. + + * vectors.c (scm_make_vector, scm_c_make_vector): Improved the + checking of the size parameter for type correctness and valid + range. Thanks to Rob Browning for reporting the problem. Instead + of deferring interrupts, scm_remember_upto_here_1 is used. + 2001-02-05 Keisuke Nishida * dump.c (scm_store_cell_object, scm_restore_cell_object): Removed. diff --git a/libguile/vectors.c b/libguile/vectors.c index 292252ebd..7e36ebafc 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -270,42 +270,52 @@ SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0, "Otherwise the initial contents of each element is unspecified. (r5rs)") #define FUNC_NAME s_scm_make_vector { - SCM_VALIDATE_INUM_MIN (1, k, 0); if (SCM_UNBNDP (fill)) fill = SCM_UNSPECIFIED; - return scm_c_make_vector (SCM_INUM (k), fill); + + if (SCM_INUMP (k)) + { + SCM_ASSERT_RANGE (1, k, k >= 0); + return scm_c_make_vector (SCM_INUM (k), fill); + } + else if (SCM_BIGP (k)) + SCM_OUT_OF_RANGE (1, k); + else + SCM_WRONG_TYPE_ARG (1, k); } #undef FUNC_NAME + SCM scm_c_make_vector (unsigned long int k, SCM fill) #define FUNC_NAME s_scm_make_vector { SCM v; - scm_bits_t *velts; + scm_bits_t *base; + + if (k > 0) + { + unsigned long int j; + + SCM_ASSERT_RANGE (1, scm_ulong2num (k), k <= SCM_VECTOR_MAX_LENGTH); + + base = scm_must_malloc (k * sizeof (scm_bits_t), FUNC_NAME); + for (j = 0; j != k; ++j) + base[j] = SCM_UNPACK (fill); + } + else + base = NULL; SCM_NEWCELL (v); - - velts = (k != 0) - ? scm_must_malloc (k * sizeof (scm_bits_t), FUNC_NAME) - : NULL; - - SCM_DEFER_INTS; - { - unsigned long int j; - - for (j = 0; j != k; ++j) - velts[j] = SCM_UNPACK (fill); - - SCM_SET_VECTOR_BASE (v, velts); - SCM_SET_VECTOR_LENGTH (v, k, scm_tc7_vector); - } - SCM_ALLOW_INTS; + SCM_SET_VECTOR_BASE (v, base); + SCM_SET_VECTOR_LENGTH (v, k, scm_tc7_vector); + scm_remember_upto_here_1 (fill); return v; } #undef FUNC_NAME + SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0, (SCM v), "@samp{Vector->list} returns a newly allocated list of the objects contained\n" diff --git a/libguile/vectors.h b/libguile/vectors.h index f8449a714..d479d1b80 100644 --- a/libguile/vectors.h +++ b/libguile/vectors.h @@ -54,6 +54,7 @@ #define SCM_VECTORP(x) (SCM_NIMP (x) && (SCM_TYP7S (x) == scm_tc7_vector)) #define SCM_VECTOR_BASE(x) ((scm_bits_t *) SCM_CELL_WORD_1 (x)) #define SCM_SET_VECTOR_BASE(v, b) (SCM_SET_CELL_WORD_1 ((v), (b))) +#define SCM_VECTOR_MAX_LENGTH ((1L << 24) - 1) #define SCM_VECTOR_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_SET_VECTOR_LENGTH(v, l, t) (SCM_SET_CELL_WORD_0 ((v), ((l) << 8) + (t))) From cb0d8be234beaaa95481f2c5c7a2a0849d4f2a0f Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 8 Feb 2001 11:40:51 +0000 Subject: [PATCH 0514/2047] * Fixed parameter checking for make-string. * Corrected a bug introduced with the last patch. --- libguile/ChangeLog | 13 ++++++++++ libguile/strings.c | 59 +++++++++++++++++++++++++++++++--------------- libguile/strings.h | 1 + libguile/vectors.c | 2 +- 4 files changed, 55 insertions(+), 20 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 14033e6b5..fa1ac14f3 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,16 @@ +2001-02-08 Dirk Herrmann + + * strings.h (SCM_STRING_MAX_LENGTH): New macro. + + * strings.c (scm_makstr, scm_take_str, scm_make_string): Added + range checking for the size parameter. Thanks to Martin + Grabmueller for the hint. + + (scm_makstr): Reordered string initialization to make interrupt + deferring unnecessary. + + * vectors.c (scm_make_vector): Fixed range checking. + 2001-02-08 Dirk Herrmann * vectors.h (SCM_VECTOR_MAX_LENGTH): New macro. diff --git a/libguile/strings.c b/libguile/strings.c index 677a1d4bd..751521cb4 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -124,19 +124,27 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1, } #undef FUNC_NAME + SCM scm_makstr (long len, int dummy) +#define FUNC_NAME "scm_makstr" { SCM s; - char *mem = (char *) scm_must_malloc (len + 1, "scm_makstr"); + char *mem; + SCM_ASSERT_RANGE (1, scm_long2num (len), len <= SCM_STRING_MAX_LENGTH); + + mem = (char *) scm_must_malloc (len + 1, FUNC_NAME); mem[len] = 0; + SCM_NEWCELL (s); SCM_SET_STRING_CHARS (s, mem); SCM_SET_STRING_LENGTH (s, len); return s; } +#undef FUNC_NAME + /* converts C scm_array of strings to SCM scm_list of strings. */ /* If argc < 0, a null terminated scm_array is assumed. */ @@ -164,16 +172,21 @@ scm_makfromstrs (int argc, char **argv) made up. */ SCM scm_take_str (char *s, int len) +#define FUNC_NAME "scm_take_str" { SCM answer; + + SCM_ASSERT_RANGE (2, scm_ulong2num (len), len <= SCM_STRING_MAX_LENGTH); + SCM_NEWCELL (answer); - SCM_DEFER_INTS; + SCM_SET_STRING_CHARS (answer, s); SCM_SET_STRING_LENGTH (answer, len); scm_done_malloc (len + 1); - SCM_SET_STRING_CHARS (answer, s); - SCM_ALLOW_INTS; + return answer; } +#undef FUNC_NAME + /* `s' must be a malloc'd string. See scm_take_str. */ SCM @@ -208,8 +221,6 @@ scm_makfrom0str_opt (const char *src) } - - SCM_DEFINE (scm_make_string, "make-string", 1, 1, 0, (SCM k, SCM chr), "Returns a newly allocated string of\n" @@ -218,24 +229,34 @@ SCM_DEFINE (scm_make_string, "make-string", 1, 1, 0, "STRING are unspecified.\n") #define FUNC_NAME s_scm_make_string { - SCM res; - register long i; - SCM_VALIDATE_INUM_MIN_COPY (1,k,0,i); - res = scm_makstr (i, 0); - if (!SCM_UNBNDP (chr)) + if (SCM_INUMP (k)) { - SCM_VALIDATE_CHAR (2,chr); - { - unsigned char *dst = SCM_STRING_UCHARS (res); - char c = SCM_CHAR (chr); - - memset (dst, c, i); - } + long int i = SCM_INUM (k); + SCM res; + + SCM_ASSERT_RANGE (1, k, i >= 0); + + res = scm_makstr (i, 0); + if (!SCM_UNBNDP (chr)) + { + unsigned char *dst; + + SCM_VALIDATE_CHAR (2, chr); + + dst = SCM_STRING_UCHARS (res); + memset (dst, SCM_CHAR (chr), i); + } + + return res; } - return res; + else if (SCM_BIGP (k)) + SCM_OUT_OF_RANGE (1, k); + else + SCM_WRONG_TYPE_ARG (1, k); } #undef FUNC_NAME + SCM_DEFINE (scm_string_length, "string-length", 1, 0, 0, (SCM string), "Returns the number of characters in STRING") diff --git a/libguile/strings.h b/libguile/strings.h index 53a6e2ba9..cc3b54669 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -57,6 +57,7 @@ #define SCM_STRING_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) #endif #define SCM_SET_STRING_CHARS(s, c) (SCM_SET_CELL_WORD_1 ((s), (c))) +#define SCM_STRING_MAX_LENGTH ((1L << 24) - 1) #define SCM_STRING_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_SET_STRING_LENGTH(s, l) (SCM_SET_CELL_WORD_0 ((s), ((l) << 8) + scm_tc7_string)) diff --git a/libguile/vectors.c b/libguile/vectors.c index 7e36ebafc..d55a51cf3 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -275,7 +275,7 @@ SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0, if (SCM_INUMP (k)) { - SCM_ASSERT_RANGE (1, k, k >= 0); + SCM_ASSERT_RANGE (1, k, SCM_INUM (k) >= 0); return scm_c_make_vector (SCM_INUM (k), fill); } else if (SCM_BIGP (k)) From 6a721afbc84fcf7881376107b0b8eaffff2bc3b5 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 8 Feb 2001 18:39:08 +0000 Subject: [PATCH 0515/2047] * and-let-star-compat.scm: Display the warning to the `current-error-port'. --- ice-9/and-let-star-compat.scm | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/ice-9/and-let-star-compat.scm b/ice-9/and-let-star-compat.scm index 497082458..e69de29bb 100644 --- a/ice-9/and-let-star-compat.scm +++ b/ice-9/and-let-star-compat.scm @@ -1,11 +0,0 @@ -;;;; This file will be installed as "and-let*.scm" on systems that -;;;; support it. It will go away in the future, use the module -;;;; (and-let-star) instead. - -(define-module (ice-9 and-let*) - :use-module (ice-9 and-let-star)) - -(display ";;; The module name (ice-9 and-let*) is deprecated.\n") -(display ";;; Use (ice-9 and-let-star) instead.\n\n") - -(export-syntax and-let*) From fdfe6305a5f234694b213a851617645552ed853b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 8 Feb 2001 18:44:34 +0000 Subject: [PATCH 0516/2047] * ports.c (scm_port_for_each): Make a snapshot of the port table before iterating over it. The table might change while the user code is running. With the snapshot, the user can depend on the fact that each port that was open at teh start of the iteration is encountered exactly once. (ice-9 popen) depends on this. --- libguile/ports.c | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/libguile/ports.c b/libguile/ports.c index a840ff538..391981bcc 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -697,15 +697,32 @@ SCM_DEFINE (scm_port_for_each, "port-for-each", 1, 0, 0, #define FUNC_NAME s_scm_port_for_each { int i; + SCM ports; + SCM_VALIDATE_PROC (1, proc); /* when pre-emptive multithreading is supported, access to the port table will need to be controlled by a mutex. */ + + /* Even without pre-emptive multithreading, running arbitrary code + while scanning the port table is unsafe because the port table + can change arbitrarily (from a GC, for example). So we build a + list in advance while blocking the GC. -mvo */ + SCM_DEFER_INTS; + scm_block_gc++; + ports = SCM_EOL; for (i = 0; i < scm_port_table_size; i++) + ports = scm_cons (scm_port_table[i]->port, ports); + scm_block_gc--; + SCM_ALLOW_INTS; + + while (ports != SCM_EOL) { - scm_apply (proc, scm_cons (scm_port_table[i]->port, SCM_EOL), SCM_EOL); + scm_apply (proc, scm_cons (SCM_CAR (ports), SCM_EOL), SCM_EOL); + ports = SCM_CDR (ports); } + return SCM_UNSPECIFIED; } #undef FUNC_NAME From aa767bc58fdad82fc83af75abc995a0b7c0c8ef2 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 8 Feb 2001 18:49:52 +0000 Subject: [PATCH 0517/2047] * modules.h (scm_selected_module, scm_current_module): Renamed scm_selected_module to scm_current_module to synchronize Scheme and C names. (scm_select_module, scm_set_current_module): Likewise. Changed all uses. --- libguile/eval.c | 10 +++++----- libguile/eval.h | 2 +- libguile/goops.c | 8 ++++---- libguile/load.c | 4 ++-- libguile/modules.c | 8 ++++---- libguile/modules.h | 4 ++-- libguile/rdelim.c | 6 +++--- 7 files changed, 21 insertions(+), 21 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index b1cc84f96..b8479e4bf 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3820,9 +3820,9 @@ change_environment (void *data) { SCM pair = SCM_PACK (data); SCM new_module = SCM_CAR (pair); - SCM old_module = scm_selected_module (); + SCM old_module = scm_current_module (); SCM_SETCDR (pair, old_module); - scm_select_module (new_module); + scm_set_current_module (new_module); } @@ -3847,9 +3847,9 @@ restore_environment (void *data) { SCM pair = SCM_PACK (data); SCM old_module = SCM_CDR (pair); - SCM new_module = scm_selected_module (); + SCM new_module = scm_current_module (); SCM_SETCAR (pair, new_module); - scm_select_module (old_module); + scm_set_current_module (old_module); } @@ -3874,7 +3874,7 @@ SCM_DEFINE (scm_eval, "eval", 2, 0, 0, #if (SCM_DEBUG_DEPRECATED == 0) -/* Use scm_selected_module () or scm_interaction_environment () +/* Use scm_current_module () or scm_interaction_environment () * instead. The former is the module selected during loading of code. * The latter is the module in which the user of this thread currently * types expressions. diff --git a/libguile/eval.h b/libguile/eval.h index 33a2f6f96..69aaec83d 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -125,7 +125,7 @@ extern SCM scm_eval_options_interface (SCM setting); /*fixme* This should probably be removed throught the code. */ #define SCM_TOP_LEVEL_LOOKUP_CLOSURE \ - SCM_MODULE_EVAL_CLOSURE (scm_selected_module ()) + SCM_MODULE_EVAL_CLOSURE (scm_current_module ()) #if SCM_DEBUG_DEPRECATED == 0 diff --git a/libguile/goops.c b/libguile/goops.c index 9794aca6f..c43d0a196 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -2323,9 +2323,9 @@ make_class_from_template (char *template, char *type_name, SCM supers) * This kludge is needed until DEFVAR ceases to use `define-public' * or `define-public' ceases to use `current-module'. */ - SCM old_module = scm_select_module (scm_module_goops); + SCM old_module = scm_set_current_module (scm_module_goops); DEFVAR (name, class); - scm_select_module (old_module); + scm_set_current_module (old_module); } return class; } @@ -2632,7 +2632,7 @@ scm_init_goops (void) { SCM old_module; scm_module_goops = scm_make_module (scm_read_0str ("(oop goops)")); - old_module = scm_select_module (scm_module_goops); + old_module = scm_set_current_module (scm_module_goops); scm_goops_lookup_closure = scm_module_lookup_closure (scm_module_goops); @@ -2667,7 +2667,7 @@ scm_init_goops (void) DEFVAR (name, scm_no_applicable_method); } - scm_select_module (old_module); + scm_set_current_module (old_module); } void diff --git a/libguile/load.c b/libguile/load.c index af78ea6f9..9c7d00675 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -103,7 +103,7 @@ load (void *data) scm_i_eval_x (form, scm_module_system_booted_p ? (scm_top_level_env - (SCM_MODULE_EVAL_CLOSURE (scm_selected_module ()))) + (SCM_MODULE_EVAL_CLOSURE (scm_current_module ()))) : SCM_EOL); } return SCM_UNSPECIFIED; @@ -479,7 +479,7 @@ SCM_DEFINE (scm_read_and_eval_x, "read-and-eval!", 0, 1, 0, SCM form = scm_read (port); if (SCM_EOF_OBJECT_P (form)) scm_ithrow (scm_end_of_file_key, SCM_EOL, 1); - return scm_eval_x (form, scm_selected_module ()); + return scm_eval_x (form, scm_current_module ()); } #undef FUNC_NAME diff --git a/libguile/modules.c b/libguile/modules.c index 1551d2813..45c9c83bf 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -73,7 +73,7 @@ scm_the_root_module () static SCM the_module; SCM -scm_selected_module () +scm_current_module () { return scm_fluid_ref (SCM_CDR (the_module)); } @@ -86,9 +86,9 @@ static SCM set_current_module; */ SCM -scm_select_module (SCM module) +scm_set_current_module (SCM module) { - SCM old = scm_selected_module (); + SCM old = scm_current_module (); scm_apply (SCM_CDR (set_current_module), SCM_LIST1 (module), SCM_EOL); return old; } @@ -102,7 +102,7 @@ SCM_DEFINE (scm_interaction_environment, "interaction-environment", 0, 0, 0, "dynamically typed by the user.") #define FUNC_NAME s_scm_interaction_environment { - return scm_selected_module (); + return scm_current_module (); } #undef FUNC_NAME diff --git a/libguile/modules.h b/libguile/modules.h index bd14e5ffe..57db947ba 100644 --- a/libguile/modules.h +++ b/libguile/modules.h @@ -83,9 +83,9 @@ extern SCM scm_module_system_booted_p; extern SCM scm_module_tag; extern SCM scm_the_root_module (void); -extern SCM scm_selected_module (void); +extern SCM scm_current_module (void); extern SCM scm_interaction_environment (void); -extern SCM scm_select_module (SCM module); +extern SCM scm_set_current_module (SCM module); extern SCM scm_make_module (SCM name); extern SCM scm_ensure_user_module (SCM name); extern SCM scm_module_lookup_closure (SCM module); diff --git a/libguile/rdelim.c b/libguile/rdelim.c index f08df3c92..20fe8150c 100644 --- a/libguile/rdelim.c +++ b/libguile/rdelim.c @@ -284,13 +284,13 @@ void scm_init_rdelim (void) { SCM rdelim_module = scm_make_module (scm_read_0str ("(ice-9 rdelim)")); - SCM old_module = scm_select_module (rdelim_module); + SCM old_module = scm_set_current_module (rdelim_module); #ifndef SCM_MAGIC_SNARFER #include "libguile/rdelim.x" #endif - scm_select_module (old_module); + scm_set_current_module (old_module); #if DEBUG_DEPRECATED == 0 { @@ -300,7 +300,7 @@ scm_init_rdelim (void) scm_eval_string (scm_makfromstr (expr, (sizeof expr) - 1, 0)); } - scm_select_module (old_module); + scm_set_current_module (old_module); #endif } From e11e60d6351e328350fbdb8c89e81ed757c742a7 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 8 Feb 2001 18:50:50 +0000 Subject: [PATCH 0518/2047] * guile-test: Use (ice-9 and-let-star) instead of (ice-9 and-let*). --- test-suite/guile-test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test-suite/guile-test b/test-suite/guile-test index 4cdbbb7b4..e234322d4 100755 --- a/test-suite/guile-test +++ b/test-suite/guile-test @@ -81,7 +81,7 @@ (use-modules (test-suite lib) (ice-9 getopt-long) - (ice-9 and-let*)) + (ice-9 and-let-star)) ;;; Variables that will receive their actual values later. From 548728ea6df31c8dcdd06be89fdb156aaf16cf52 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 8 Feb 2001 18:52:05 +0000 Subject: [PATCH 0519/2047] *** empty log message *** --- ice-9/ChangeLog | 5 +++++ libguile/ChangeLog | 14 ++++++++++++++ test-suite/ChangeLog | 5 +++++ 3 files changed, 24 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 4823b0097..e4e7d4ae6 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2001-02-08 Marius Vollmer + + * and-let-star-compat.scm: Display the warning to the + `current-error-port'. + 2001-02-04 Marius Vollmer Avoid the use of "*" in file names for the benefit of lesser diff --git a/libguile/ChangeLog b/libguile/ChangeLog index fa1ac14f3..d78043411 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,17 @@ +2001-02-08 Marius Vollmer + + * modules.h (scm_selected_module, scm_current_module): Renamed + scm_selected_module to scm_current_module to synchronize Scheme + and C names. + (scm_select_module, scm_set_current_module): Likewise. Changed + all uses. + + * ports.c (scm_port_for_each): Make a snapshot of the port table + before iterating over it. The table might change while the user + code is running. With the snapshot, the user can depend on the + fact that each port that was open at teh start of the iteration is + encountered exactly once. (ice-9 popen) depends on this. + 2001-02-08 Dirk Herrmann * strings.h (SCM_STRING_MAX_LENGTH): New macro. diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 77f682754..973038dd9 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2001-02-08 Marius Vollmer + + * guile-test: Use (ice-9 and-let-star) instead of (ice-9 + and-let*). + 2001-01-26 Dirk Herrmann This patch fixes things that I have broken with the last one :-( From c5408bc31f31699afc6152469a0cef15cc788be6 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 8 Feb 2001 18:53:48 +0000 Subject: [PATCH 0520/2047] s/open/existed/ in description of port-for-each change. --- libguile/ChangeLog | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d78043411..a1332ce35 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -9,7 +9,7 @@ * ports.c (scm_port_for_each): Make a snapshot of the port table before iterating over it. The table might change while the user code is running. With the snapshot, the user can depend on the - fact that each port that was open at teh start of the iteration is + fact that each port that existed at the start of the iteration is encountered exactly once. (ice-9 popen) depends on this. 2001-02-08 Dirk Herrmann From 1be4270af397a8134c71afe467c92dda43fe48f1 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 9 Feb 2001 07:12:05 +0000 Subject: [PATCH 0521/2047] Bug fixed. --- libguile/ChangeLog | 4 ++++ libguile/ports.c | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index a1332ce35..06b96ea63 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2001-02-08 Keisuke Nishida + + * ports.c (scm_unread_char): Take an optional argument. + 2001-02-08 Marius Vollmer * modules.h (scm_selected_module, scm_current_module): Renamed diff --git a/libguile/ports.c b/libguile/ports.c index 391981bcc..36f59fabb 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1121,7 +1121,7 @@ SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_unread_char, "unread-char", 2, 0, 0, +SCM_DEFINE (scm_unread_char, "unread-char", 1, 1, 0, (SCM cobj, SCM port), "Place @var{char} in @var{port} so that it will be read by the\n" "next read operation. If called multiple times, the unread characters\n" From a6dfbbbbce7994deb4697b1697dc6ccee08c2877 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 9 Feb 2001 14:36:27 +0000 Subject: [PATCH 0522/2047] Blurb about new guarantee of port-for-each --- NEWS | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/NEWS b/NEWS index fc80a4c18..91e757b19 100644 --- a/NEWS +++ b/NEWS @@ -109,6 +109,15 @@ Example: * Changes to Scheme functions and syntax +** `port-for-each' makes an additional guarantee. + +From the docstring: @var{proc} is applied exactly once to every port +that exists in the system at the time @var{port-for-each} is invoked. +Changes to the port table while @var{port-for-each} is running have no +effect as far as @var{port-for-each} is concerned. + +This guarantee is important to make (ice-9 popen) work reliable. + ** The semantics of guardians have changed. The changes are for the most part compatible. An important criterion From 88c927e9507e99fc9f298049937fb0a1b92fa1a1 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 9 Feb 2001 14:37:30 +0000 Subject: [PATCH 0523/2047] * macros.c (scm_macro_name, scm_macro_transformer): Use SCM_SMOB_DATA instead of SCM_CDR. Provided by Martin Grabmueller. Thanks! --- libguile/macros.c | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/libguile/macros.c b/libguile/macros.c index fd6ae53b2..1d5aadd18 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -148,22 +148,23 @@ SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0, SCM_DEFINE (scm_macro_name, "macro-name", 1, 0, 0, (SCM m), - "") + "Return the name of the macro @var{m}.") #define FUNC_NAME s_scm_macro_name { SCM_VALIDATE_SMOB (1,m,macro); - return scm_procedure_name (SCM_CDR (m)); + return scm_procedure_name (SCM_PACK (SCM_SMOB_DATA (m))); } #undef FUNC_NAME SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0, (SCM m), - "") + "Return the transformer of the macro @var{m}.") #define FUNC_NAME s_scm_macro_transformer { SCM_VALIDATE_SMOB (1,m,macro); - return SCM_CLOSUREP (SCM_CDR (m)) ? SCM_CDR (m) : SCM_BOOL_F; + return ((SCM_CLOSUREP (SCM_PACK (SCM_SMOB_DATA (m)))) ? + SCM_PACK(SCM_SMOB_DATA (m)) : SCM_BOOL_F); } #undef FUNC_NAME From 2f1bbcfd5f2533ae993b801eccba83472eac51b6 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 9 Feb 2001 14:38:27 +0000 Subject: [PATCH 0524/2047] Docstring of port-for-each updated to new behaviour. --- libguile/ports.c | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/libguile/ports.c b/libguile/ports.c index 36f59fabb..1cc9058b7 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -693,7 +693,11 @@ SCM_DEFINE (scm_close_output_port, "close-output-port", 1, 0, 0, SCM_DEFINE (scm_port_for_each, "port-for-each", 1, 0, 0, (SCM proc), "Apply @var{proc} to each port in the Guile port table\n" - "in turn. The return value is unspecified.") + "in turn. The return value is unspecified. More specifically,\n" + "@var{proc} is applied exactly once to every port that exists\n" + "in the system at the time @var{port-for-each} is invoked.\n" + "Changes to the port table while @var{port-for-each} is running\n" + "have no effect as far as @var{port-for-each} is concerned.\n") #define FUNC_NAME s_scm_port_for_each { int i; From bf942687d72bf684736e9a2a53b34073eb99f68f Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 9 Feb 2001 22:37:10 +0000 Subject: [PATCH 0525/2047] * dump.c: Use double cells for update schedule. --- libguile/ChangeLog | 4 ++ libguile/dump.c | 101 ++++++++++++++++++++++----------------------- 2 files changed, 53 insertions(+), 52 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 06b96ea63..b00c9d5b4 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2001-02-09 Keisuke Nishida + + * dump.c: Use double cells for update schedule. + 2001-02-08 Keisuke Nishida * ports.c (scm_unread_char): Take an optional argument. diff --git a/libguile/dump.c b/libguile/dump.c index 785636110..69af7ebb0 100644 --- a/libguile/dump.c +++ b/libguile/dump.c @@ -75,12 +75,6 @@ struct scm_dump_header { /* or immediate value */ }; -struct scm_dump_update { - scm_bits_t id; /* object identifier */ - scm_bits_t *addr; /* object address */ - struct scm_dump_update *next; /* next update */ -}; - /* * Dump state @@ -92,17 +86,24 @@ struct scm_dstate { int mmapped; scm_sizet image_size; int image_index; - char *image_base; /* Memory image */ + char *image_base; /* Memory image */ int table_index; - SCM table; /* Object table */ - struct scm_dump_update *updates; /* Update schedule */ + SCM table; /* Object table */ + SCM task; /* Update task */ }; #define SCM_DSTATE_DATA(d) ((struct scm_dstate *) SCM_SMOB_DATA (d)) #define SCM_DSTATE_TABLE(d) (SCM_DSTATE_DATA (d)->table) #define SCM_DSTATE_TABLE_REF(d,i) (SCM_VELTS (SCM_DSTATE_TABLE (d))[i]) #define SCM_DSTATE_TABLE_SET(d,i,x) (SCM_VELTS (SCM_DSTATE_TABLE (d))[i] = (x)) -#define SCM_DSTATE_UPDATES(d) (SCM_DSTATE_DATA (d)->updates) +#define SCM_DSTATE_TASK(d) (SCM_DSTATE_DATA (d)->task) + +#define SCM_DTASK_ID(t) ((scm_bits_t) SCM_CELL_WORD_1 (t)) +#define SCM_DTASK_ADDR(t) ((scm_bits_t *) SCM_CELL_WORD_2 (t)) +#define SCM_DTASK_NEXT(t) (SCM_CELL_OBJECT_3 (t)) +#define SCM_SET_DTASK_ID(t,x) SCM_SET_CELL_WORD_1 (t, x) +#define SCM_SET_DTASK_ADDR(t,x) SCM_SET_CELL_WORD_2 (t, x) +#define SCM_SET_DTASK_NEXT(t,x) SCM_SET_CELL_OBJECT_3 (t, x) static SCM make_dstate () @@ -115,7 +116,7 @@ make_dstate () p->image_base = SCM_MUST_MALLOC (p->image_size); p->table_index = 0; p->table = SCM_BOOL_F; - p->updates = 0; + p->task = SCM_EOL; SCM_RETURN_NEWSMOB (scm_tc16_dstate, p); } #undef FUNC_NAME @@ -143,7 +144,7 @@ make_dstate_by_mmap (int fd) p->image_base = addr; p->table_index = 0; p->table = SCM_BOOL_F; - p->updates = 0; + p->task = SCM_EOL; SCM_RETURN_NEWSMOB (scm_tc16_dstate, p); } #undef FUNC_NAME @@ -151,7 +152,11 @@ make_dstate_by_mmap (int fd) static SCM dstate_mark (SCM obj) { - return SCM_DSTATE_TABLE (obj); + SCM task; + struct scm_dstate *p = SCM_DSTATE_DATA (obj); + for (task = p->task; !SCM_NULLP (task); task = SCM_DTASK_NEXT (task)) + scm_gc_mark (task); + return p->table; } static scm_sizet @@ -176,15 +181,6 @@ dstate_free (SCM obj) scm_must_free (p->image_base); } - /* Free update schedules */ - while (p->updates) - { - struct scm_dump_update *next = p->updates->next; - scm_must_free (p->updates); - size += sizeof (struct scm_dump_update); - p->updates = next; - } - scm_must_free (p); return size; } @@ -286,13 +282,12 @@ scm_store_object (SCM obj, SCM dstate) { /* OBJ is not stored yet. Do it later */ struct scm_dstate *p = SCM_DSTATE_DATA (dstate); - struct scm_dump_update *update = - scm_must_malloc (sizeof (struct scm_dump_update), - "scm_store_object"); - update->id = SCM_UNPACK (obj); - update->addr = (scm_bits_t *) p->image_index; - update->next = p->updates; - p->updates = update; + SCM task; + SCM_NEWCELL2 (task); + SCM_SET_DTASK_ID (task, SCM_UNPACK (obj)); + SCM_SET_DTASK_ADDR (task, p->image_index); + SCM_SET_DTASK_NEXT (task, p->task); + p->task = task; } scm_store_word (id, dstate); } @@ -342,13 +337,13 @@ scm_restore_object (SCM *objp, SCM dstate) if (SCM_UNBNDP (*objp)) { - struct scm_dump_update *update = - scm_must_malloc (sizeof (struct scm_dump_update), - "scm_restore_object"); - update->id = id; - update->addr = (scm_bits_t *) objp; - update->next = SCM_DSTATE_UPDATES (dstate); - SCM_DSTATE_UPDATES (dstate) = update; + struct scm_dstate *p = SCM_DSTATE_DATA (dstate); + SCM task; + SCM_NEWCELL2 (task); + SCM_SET_DTASK_ID (task, id); + SCM_SET_DTASK_ADDR (task, objp); + SCM_SET_DTASK_NEXT (task, p->task); + p->task = task; } } @@ -426,15 +421,16 @@ scm_dump (SCM obj, SCM dstate) } next_dump: - while (p->updates) - { - struct scm_dump_update *update = p->updates; - p->updates = update->next; - scm_dump (SCM_PACK (update->id), dstate); - *(scm_bits_t *) (p->image_base + (int) update->addr) = - scm_object_indicator (SCM_PACK (update->id), dstate); - scm_must_free (update); - } + { + SCM task; + for (task = p->task; !SCM_NULLP (task); task = SCM_DTASK_NEXT (task)) + { + SCM obj = SCM_PACK (SCM_DTASK_ID (task)); + scm_dump (obj, dstate); + *(scm_bits_t *) (p->image_base + (int) SCM_DTASK_ADDR (task)) = + scm_object_indicator (obj, dstate); + } + } } static void @@ -591,13 +587,14 @@ SCM_DEFINE (scm_binary_read, "binary-read", 0, 1, 0, scm_undump (dstate); /* Update references */ - while (p->updates) - { - struct scm_dump_update *update = p->updates; - p->updates = update->next; - *(update->addr) = SCM_UNPACK (scm_indicator_object (update->id, dstate)); - scm_must_free (update); - } + { + SCM task; + for (task = p->task; !SCM_NULLP (task); task = SCM_DTASK_NEXT (task)) + { + *SCM_DTASK_ADDR (task) = + SCM_UNPACK (scm_indicator_object (SCM_DTASK_ID (task), dstate)); + } + } /* Return */ { From 42417394f248401682d883776b369583db6746a7 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sat, 10 Feb 2001 07:09:45 +0000 Subject: [PATCH 0526/2047] * dump.c (scm_store_bytes, scm_restore_bytes): Store/restore size. --- libguile/ChangeLog | 6 ++++ libguile/dump.c | 64 +++++++++++++++++++++++++----------------- libguile/dump.h | 69 ---------------------------------------------- 3 files changed, 44 insertions(+), 95 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b00c9d5b4..92589c2c6 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2001-02-10 Keisuke Nishida + + * dump.c (scm_store_bytes): Store data size before data. + (scm_restore_bytes): Restore data size. Takes a pointer to size. + * dump.h (scm_restore_bytes): Updated. + 2001-02-09 Keisuke Nishida * dump.c: Use double cells for update schedule. diff --git a/libguile/dump.c b/libguile/dump.c index 69af7ebb0..de0b46d63 100644 --- a/libguile/dump.c +++ b/libguile/dump.c @@ -245,6 +245,28 @@ scm_store_pad (SCM dstate) p->image_base[p->image_index++] = '\0'; } +void +scm_store_word (const scm_bits_t word, SCM dstate) +{ + struct scm_dstate *p = SCM_DSTATE_DATA (dstate); + while (p->image_index + sizeof (scm_bits_t) >= p->image_size) + dstate_extend (p); + memcpy (p->image_base + p->image_index, &word, sizeof (scm_bits_t)); + p->image_index += sizeof (scm_bits_t); +} + +void +scm_store_bytes (const void *addr, scm_sizet size, SCM dstate) +{ + struct scm_dstate *p = SCM_DSTATE_DATA (dstate); + scm_store_word (size, dstate); + while (p->image_index + size + sizeof (scm_bits_t) >= p->image_size) + dstate_extend (p); + memcpy (p->image_base + p->image_index, addr, size); + p->image_index += size; + scm_store_pad (dstate); +} + void scm_store_string (const char *addr, scm_sizet size, SCM dstate) { @@ -257,23 +279,6 @@ scm_store_string (const char *addr, scm_sizet size, SCM dstate) scm_store_pad (dstate); } -void -scm_store_bytes (const void *addr, scm_sizet size, SCM dstate) -{ - struct scm_dstate *p = SCM_DSTATE_DATA (dstate); - while (p->image_index + size >= p->image_size) - dstate_extend (p); - memcpy (p->image_base + p->image_index, addr, size); - p->image_index += size; - scm_store_pad (dstate); -} - -void -scm_store_word (const scm_bits_t word, SCM dstate) -{ - scm_store_bytes (&word, sizeof (scm_bits_t), dstate); -} - void scm_store_object (SCM obj, SCM dstate) { @@ -302,30 +307,37 @@ scm_restore_pad (struct scm_dstate *p) } void -scm_restore_string (const char **pp, scm_sizet *sizep, SCM dstate) +scm_restore_word (scm_bits_t *wordp, SCM dstate) { struct scm_dstate *p = SCM_DSTATE_DATA (dstate); - *pp = p->image_base + p->image_index; - *sizep = strlen (*pp); - p->image_index += *sizep + 1; - scm_restore_pad (p); + *wordp = *(scm_bits_t *) (p->image_base + p->image_index); + p->image_index += sizeof (scm_bits_t); } void -scm_restore_bytes (const void **pp, scm_sizet size, SCM dstate) +scm_restore_bytes (const void **pp, scm_sizet *sizep, SCM dstate) { + scm_bits_t size; struct scm_dstate *p = SCM_DSTATE_DATA (dstate); + scm_restore_word (&size, dstate); + if (sizep) + *sizep = size; *pp = p->image_base + p->image_index; p->image_index += size; scm_restore_pad (p); } void -scm_restore_word (scm_bits_t *wordp, SCM dstate) +scm_restore_string (const char **pp, scm_sizet *sizep, SCM dstate) { + int len; struct scm_dstate *p = SCM_DSTATE_DATA (dstate); - *wordp = *(scm_bits_t *) (p->image_base + p->image_index); - p->image_index += sizeof (scm_bits_t); + *pp = p->image_base + p->image_index; + len = strlen (*pp); + if (sizep) + *sizep = len; + p->image_index += len + 1; + scm_restore_pad (p); } void diff --git a/libguile/dump.h b/libguile/dump.h index 583bc0ea8..e69de29bb 100644 --- a/libguile/dump.h +++ b/libguile/dump.h @@ -1,69 +0,0 @@ -/* classes: h_files */ - -#ifndef DUMPH -#define DUMPH -/* Copyright (C) 2001 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 - * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ - -#include "libguile/__scm.h" - -extern void scm_store_string (const char *addr, scm_sizet size, SCM dstate); -extern void scm_store_bytes (const void *addr, scm_sizet size, SCM dstate); -extern void scm_store_word (const scm_bits_t word, SCM dstate); -extern void scm_store_object (SCM obj, SCM dstate); - -extern void scm_restore_string (const char **pp, scm_sizet *sizep, SCM dstate); -extern void scm_restore_bytes (const void **pp, scm_sizet size, SCM dstate); -extern void scm_restore_word (scm_bits_t *wordp, SCM dstate); -extern void scm_restore_object (SCM *objp, SCM dstate); - -extern SCM scm_binary_write (SCM obj, SCM port); -extern SCM scm_binary_read (SCM port); - -extern void scm_init_dump (void); - -#endif /* DUMPH */ - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ From 083629bea45242d2d38d8cb6b89e84d8df7f06ff Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 11 Feb 2001 18:04:31 +0000 Subject: [PATCH 0527/2047] * eval.h (scm_primitive_eval, scm_primitive_eval_x): New prototypes. (scm_i_eval, scm_i_eval_x, scm_eval, scm_eval_x): Changed argument names to better reflect their meaning. --- libguile/eval.h | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/libguile/eval.h b/libguile/eval.h index 69aaec83d..880cd5d5b 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -241,10 +241,13 @@ extern SCM scm_copy_tree (SCM obj); extern SCM scm_eval_3 (SCM obj, int copyp, SCM env); extern SCM scm_eval2 (SCM obj, SCM env_thunk); #endif -extern SCM scm_i_eval_x (SCM obj, SCM env); -extern SCM scm_i_eval (SCM obj, SCM env); -extern SCM scm_eval (SCM obj, SCM environment); -extern SCM scm_eval_x (SCM obj, SCM environment); +extern SCM scm_i_eval_x (SCM exp, SCM env); +extern SCM scm_i_eval (SCM exp, SCM env); +extern SCM scm_primitive_eval (SCM exp); +extern SCM scm_primitive_eval_x (SCM exp); +extern SCM scm_eval (SCM exp, SCM module); +extern SCM scm_eval_x (SCM exp, SCM module); + extern void scm_init_eval (void); #endif /* EVALH */ From 4163eb7236d7a2bf0429844f20eeeb482e938ecb Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 11 Feb 2001 18:13:07 +0000 Subject: [PATCH 0528/2047] * eval.c (scm_ceval, scm_deval): Recognize when `begin' is being evaluated at top-level and synronize lookup closure before executing every subform. (scm_primitve_eval_x, scm_primitive_eval): New functions. (scm_eval_x, scm_eval): Reimplement in terms of scm_primitive_eval_x and scm_primitive_eval, respectively. --- libguile/eval.c | 168 +++++++++++++++++++++++++++++++++++------------- 1 file changed, 122 insertions(+), 46 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index b8479e4bf..06d2af0c6 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1904,20 +1904,37 @@ dispatch: x = SCM_CDR (x); begin: - t.arg1 = x; - while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) + /* If we are on toplevel with a lookup closure, we need to sync + with the current module. */ + if (SCM_CONSP(env) && !SCM_CONSP(SCM_CAR(env))) { - if (SCM_IMP (SCM_CAR (x))) + t.arg1 = x; + while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) { - if (SCM_ISYMP (SCM_CAR (x))) - { - x = scm_m_expand_body (x, env); - goto begin; - } + SCM_SETCAR (env, scm_current_module_lookup_closure ()); + SCM_CEVAL (SCM_CAR (x), env); + x = t.arg1; + } + /* once more, for the last form */ + SCM_SETCAR (env, scm_current_module_lookup_closure ()); + } + else + { + t.arg1 = x; + while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) + { + if (SCM_IMP (SCM_CAR (x))) + { + if (SCM_ISYMP (SCM_CAR (x))) + { + x = scm_m_expand_body (x, env); + goto begin; + } + } + else + SCM_CEVAL (SCM_CAR (x), env); + x = t.arg1; } - else - SCM_CEVAL (SCM_CAR (x), env); - x = t.arg1; } carloop: /* scm_eval car of last form in list */ @@ -3782,8 +3799,47 @@ SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0, #undef FUNC_NAME +/* We have three levels of EVAL here: + + - scm_i_eval (exp, env) + + evaluates EXP in environment ENV. ENV is a lexical environment + structure as used by the actual tree code evaluator. When ENV is + a top-level environment, then changes to the current module are + tracked by modifying ENV so that it continues to be in sync with + the current module. + + - scm_primitive_eval (exp) + + evaluates EXP in the top-level environment as determined by the + current module. This is done by constructing a suitable + environment and calling scm_i_eval. Thus, changes to the + top-level module are tracked normally. + + - scm_eval (exp, mod) + + evaluates EXP while MOD is the current module. Thius is done by + setting the current module to MOD, invoking scm_primitive_eval on + EXP, and then restoring the current module to the value it had + previously. That is, while EXP is evaluated, changes to the + current module are tracked, but these changes do not persist when + scm_eval returns. + + For each level of evals, there are two variants, distinguished by a + _x suffix: the ordinary variant does not modify EXP while the _x + variant can destructively modify EXP into something completely + unintelligible. A Scheme data structure passed as EXP to one of the + _x variants should not ever be used again for anything. So when in + doubt, use the ordinary variant. + +*/ + SCM scm_system_transformer; +// XXX - scm_i_eval is meant to be useable for evaluation in +// non-toplevel environments, for example when used by the debugger. +// Can the system transform deal with this? + SCM scm_i_eval_x (SCM exp, SCM env) { @@ -3803,17 +3859,27 @@ scm_i_eval (SCM exp, SCM env) } SCM -scm_eval_x (SCM exp, SCM module) +scm_primitive_eval_x (SCM exp) { - return scm_i_eval_x (exp, - scm_top_level_env (SCM_MODULE_EVAL_CLOSURE (module))); + SCM env = scm_top_level_env (scm_current_module_lookup_closure ()); + return scm_i_eval_x (exp, env); } +SCM_DEFINE (scm_primitive_eval, "primitive-eval", 1, 0, 0, + (SCM exp), + "Evaluate @var{epx} in the top-level environment specified by\n" + "the current module.") +#define FUNC_NAME s_scm_primitive_eval +{ + SCM env = scm_top_level_env (scm_current_module_lookup_closure ()); + return scm_i_eval (exp, env); +} +#undef FUNC_NAME + /* Eval does not take the second arg optionally. This is intentional * in order to be R5RS compatible, and to prepare for the new module * system, where we would like to make the choice of evaluation - * environment explicit. - */ + * environment explicit. */ static void change_environment (void *data) @@ -3826,22 +3892,6 @@ change_environment (void *data) } -static SCM -inner_eval (void *data) -{ - SCM pair = SCM_PACK (data); - SCM exp = SCM_CAR (pair); - SCM env = SCM_CDR (pair); - SCM transformer = scm_fluid_ref (SCM_CDR (scm_system_transformer)); - - exp = scm_copy_tree (exp); - if (SCM_NIMP (transformer)) - exp = scm_apply (transformer, exp, scm_listofnull); - - return SCM_XEVAL (exp, env); -} - - static void restore_environment (void *data) { @@ -3852,23 +3902,46 @@ restore_environment (void *data) scm_set_current_module (old_module); } +static SCM +inner_eval_x (void *data) +{ + return scm_primitive_eval_x (SCM_PACK(data)); +} + +SCM +scm_eval_x (SCM exp, SCM module) +#define FUNC_NAME "eval!" +{ + SCM_VALIDATE_MODULE (2, module); + + return scm_internal_dynamic_wind + (change_environment, inner_eval_x, restore_environment, + (void *) SCM_UNPACK (exp), + (void *) SCM_UNPACK (scm_cons (module, SCM_BOOL_F))); +} +#undef FUNC_NAME + +static SCM +inner_eval (void *data) +{ + return scm_primitive_eval (SCM_PACK(data)); +} SCM_DEFINE (scm_eval, "eval", 2, 0, 0, - (SCM exp, SCM environment), - "Evaluate @var{exp}, a list representing a Scheme expression, in the\n" - "environment given by @var{environment specifier}.") + (SCM exp, SCM module), + "Evaluate @var{exp}, a list representing a Scheme expression,\n" + "in the top-level environment specified by @var{module}.\n" + "While @var{exp} is evaluated (using @var{primitive-eval}),\n" + "@var{module} is made the current module. The current module\n" + "is reset to its previous value when @var{eval} returns.") #define FUNC_NAME s_scm_eval { - SCM env_closure; - - SCM_VALIDATE_MODULE (2, environment); - - env_closure = scm_top_level_env (SCM_MODULE_EVAL_CLOSURE (environment)); + SCM_VALIDATE_MODULE (2, module); return scm_internal_dynamic_wind (change_environment, inner_eval, restore_environment, - (void *) SCM_UNPACK (scm_cons (exp, env_closure)), - (void *) SCM_UNPACK (scm_cons (environment, SCM_BOOL_F))); + (void *) SCM_UNPACK (exp), + (void *) SCM_UNPACK (scm_cons (module, SCM_BOOL_F))); } #undef FUNC_NAME @@ -3885,7 +3958,8 @@ SCM scm_top_level_lookup_closure_var; /* Avoid using this functionality altogether (except for implementing * libguile, where you can use scm_i_eval or scm_i_eval_x). * - * Applications should use either C level scm_eval_x or Scheme scm_eval. */ + * Applications should use either C level scm_eval_x or Scheme + * scm_eval; or scm_primitive_eval_x or scm_primitive_eval. */ SCM scm_eval_3 (SCM obj, int copyp, SCM env) @@ -3898,9 +3972,11 @@ scm_eval_3 (SCM obj, int copyp, SCM env) SCM_DEFINE (scm_eval2, "eval2", 2, 0, 0, (SCM obj, SCM env_thunk), - "Evaluate @var{exp}, a Scheme expression, in the environment designated\n" - "by @var{lookup}, a symbol-lookup function. @code{(eval exp)} is\n" - "equivalent to @code{(eval2 exp *top-level-lookup-closure*)}.") + "Evaluate @var{exp}, a Scheme expression, in the environment\n" + "designated by @var{lookup}, a symbol-lookup function." + "Do not use this version of eval, it does not play well\n" + "with the module system. Use @code{eval} or\n" + "@code{primitive-eval} instead.") #define FUNC_NAME s_scm_eval2 { return scm_i_eval (obj, scm_top_level_env (env_thunk)); From 9e57344b1d19957afcaefadb8b30e0e9070e894a Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 11 Feb 2001 18:14:34 +0000 Subject: [PATCH 0529/2047] * modules.h. modules.c (scm_current_module_lookup_closure): New function. --- libguile/modules.c | 9 +++++++++ libguile/modules.h | 1 + 2 files changed, 10 insertions(+) diff --git a/libguile/modules.c b/libguile/modules.c index 45c9c83bf..cae2d1747 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -144,6 +144,15 @@ scm_module_lookup_closure (SCM module) return SCM_MODULE_EVAL_CLOSURE (module); } +SCM +scm_current_module_lookup_closure () +{ + if (scm_module_system_booted_p) + return scm_module_lookup_closure (scm_current_module ()); + else + return SCM_BOOL_F; +} + static SCM resolve_module; SCM diff --git a/libguile/modules.h b/libguile/modules.h index 57db947ba..95906261f 100644 --- a/libguile/modules.h +++ b/libguile/modules.h @@ -84,6 +84,7 @@ extern SCM scm_module_tag; extern SCM scm_the_root_module (void); extern SCM scm_current_module (void); +extern SCM scm_current_module_lookup_closure (void); extern SCM scm_interaction_environment (void); extern SCM scm_set_current_module (SCM module); extern SCM scm_make_module (SCM name); From 22b30766712c7ed3dc3f027d257b9e12e88c8951 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 11 Feb 2001 18:16:58 +0000 Subject: [PATCH 0530/2047] * boot-9.scm (scm-style-repl): Use `primitive-eval' instead of `eval'. (define-public): Do not use `eval'. --- ice-9/boot-9.scm | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index fc13ebc39..e4db6f867 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -2402,7 +2402,7 @@ (-eval (lambda (sourc) (repl-report-start-timing) (start-stack 'repl-stack - (eval sourc (interaction-environment))))) + (primitive-eval sourc)))) (-print (let ((maybe-print (lambda (result) (if (or scm-repl-print-unspecified @@ -2569,13 +2569,8 @@ (module-add! public-i ',name (module-variable (current-module) ',name))) - ;; Now (re)define the var normally. Bernard URBAN - ;; suggests we use eval here to accomodate Hobbit; it lets - ;; the interpreter handle the define-private form, which - ;; Hobbit can't digest. - (eval '(define-private ,@ args) (interaction-environment))))))) - - + ;; Now (re)define the var normally. + (define-private ,@ args) (interaction-environment)))))) (defmacro defmacro-public args (define (syntax) From ec9709f00fd88a8b0dc5041fe6b210d61603a4d7 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 11 Feb 2001 18:17:56 +0000 Subject: [PATCH 0531/2047] *** empty log message *** --- ice-9/ChangeLog | 6 ++++++ libguile/ChangeLog | 26 ++++++++++++++++++++++++++ 2 files changed, 32 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index e4e7d4ae6..7c02592c4 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,9 @@ +2001-02-11 Marius Vollmer + + * boot-9.scm (scm-style-repl): Use `primitive-eval' instead of + `eval'. + (define-public): Do not use `eval'. + 2001-02-08 Marius Vollmer * and-let-star-compat.scm: Display the warning to the diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 92589c2c6..9d025fcde 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,29 @@ +2001-02-11 Marius Vollmer + + Fix evaluator so that top-level expressions are correctly + evaluated with respect to the module system. + + * modules.h. modules.c (scm_current_module_lookup_closure): New + function. + + * eval.h (scm_primitive_eval, scm_primitive_eval_x): New + prototypes. + (scm_i_eval, scm_i_eval_x, scm_eval, scm_eval_x): Changed argument + names to better reflect their meaning. + + * eval.c (scm_ceval, scm_deval): Recognize when `begin' is being + evaluated at top-level and synronize lookup closure before + executing every subform. + (scm_primitve_eval_x, scm_primitive_eval): New functions. + (scm_eval_x, scm_eval): Reimplement in terms of + scm_primitive_eval_x and scm_primitive_eval, respectively. + +2001-02-09 Marius Vollmer + + * macros.c (scm_macro_name, scm_macro_transformer): Use + SCM_SMOB_DATA instead of SCM_CDR. Provided by Martin Grabmueller. + Thanks! + 2001-02-10 Keisuke Nishida * dump.c (scm_store_bytes): Store data size before data. From 5d6bb34916b52f87f1f4789dabfdfbdb7a176549 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Mon, 12 Feb 2001 21:45:22 +0000 Subject: [PATCH 0532/2047] * list.c (scm_list_copy): Validate the first argument. --- libguile/ChangeLog | 4 ++++ libguile/list.c | 2 ++ 2 files changed, 6 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 9d025fcde..b3ac66e4c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2001-02-12 Keisuke Nishida + + * list.c (scm_list_copy): Validate the first argument. + 2001-02-11 Marius Vollmer Fix evaluator so that top-level expressions are correctly diff --git a/libguile/list.c b/libguile/list.c index 0f62c1873..6493df8de 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -485,6 +485,8 @@ SCM_DEFINE (scm_list_copy, "list-copy", 1, 0, 0, SCM * fill_here; SCM from_here; + SCM_VALIDATE_LIST (1, lst); + newlst = SCM_EOL; fill_here = &newlst; from_here = lst; From 645e38d9ac0cc1415b2d7d41f3996007dbfbdafd Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 13 Feb 2001 01:07:45 +0000 Subject: [PATCH 0533/2047] * boot-9.scm (define-public): Removed spurious call to `interaction-evironment'. (define-public, defmacro-public): Use `export' instead of explicit module magic. (eval-when): New macro. (define-module, use-modules, use-syntax, export): Use it to restrict the use of these forms to the top level. (define-public, defmacro-public): Only export binding when on top-level. (process-define-module): Call `set-current-module' with the defined module. (define-module): Simply call `process-define-module' without any fuss (but only on top-level). (named-module-use!): New function. (top-repl): Do not use `define-module'. Use equivalent low-level means instead. --- ice-9/boot-9.scm | 140 ++++++++++++++++++++++++++++------------------- 1 file changed, 84 insertions(+), 56 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index e4db6f867..672234887 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1691,6 +1691,7 @@ (append (cadr kws) exports))) (else (error "unrecognized defmodule argument" kws)))))) + (set-current-module module) module)) ;;; {Autoload} @@ -2509,16 +2510,51 @@ (car rest) `(lambda ,(cdr first) ,@rest)))) `(define ,name (defmacro:syntax-transformer ,transformer)))) + +;; EVAL-WHEN +;; +;; (eval-when ((situation*) forms)* (else forms)?) +;; +;; Evaluate certain code based on the situation that eval-when is used +;; in. The only defined situation right now is `load-toplevel' which +;; triggers for code evaluated at the top-level, for example from the +;; REPL or when loading a file. + +(define eval-when + (procedure->memoizing-macro + (lambda (exp env) + (define (toplevel-env? env) + (or (not (pair? env)) (not (pair? (car env))))) + (define (syntax) + (error "syntax error in eval-when")) + (let loop ((clauses (cdr exp))) + (cond + ((null? clauses) + #f) + ((not (list? (car clauses))) + (syntax)) + ((eq? 'else (caar clauses)) + (or (null? (cdr clauses)) + (syntax)) + (cons 'begin (cdar clauses))) + ((not (list? (caar clauses))) + (syntax)) + ((and (toplevel-env? env) + (memq 'load-toplevel (caar clauses))) + (cons 'begin (cdar clauses))) + (else + (loop (cdr clauses)))))))) + ;;; {Module System Macros} ;;; (defmacro define-module args - `(let* ((process-define-module process-define-module) - (set-current-module set-current-module) - (module (process-define-module ',args))) - (set-current-module module) - module)) + `(eval-when + ((load-toplevel) + (process-define-module ',args)) + (else + (error "define-module can only be used at the top level")))) ;; the guts of the use-modules macro. add the interfaces of the named ;; modules to the use-list of the current module, in order @@ -2531,16 +2567,23 @@ (reverse module-names))) (defmacro use-modules modules - `(process-use-modules ',modules)) + `(eval-when + ((load-toplevel) + (process-use-modules ',modules)) + (else + (error "use-modules can only be used at the top level")))) (defmacro use-syntax (spec) - `(begin + `(eval-when + ((load-toplevel) ,@(if (pair? spec) `((process-use-modules ',(list spec)) (set-module-transformer! (current-module) ,(car (last-pair spec)))) `((set-module-transformer! (current-module) ,spec))) - (fluid-set! scm:eval-transformer (module-transformer (current-module))))) + (fluid-set! scm:eval-transformer (module-transformer (current-module)))) + (else + (error "use-modules can only be used at the top level")))) (define define-private define) @@ -2553,52 +2596,29 @@ ((pair? n) (defined-name (car n))) (else (syntax)))) (cond - ((null? args) (syntax)) - - (#t (let ((name (defined-name (car args)))) - `(begin - (let ((public-i (module-public-interface (current-module)))) - ;; Make sure there is a local variable: - ;; - (module-define! (current-module) - ',name - (module-ref (current-module) ',name #f)) - - ;; Make sure that local is exported: - ;; - (module-add! public-i ',name - (module-variable (current-module) ',name))) - - ;; Now (re)define the var normally. - (define-private ,@ args) (interaction-environment)))))) + ((null? args) + (syntax)) + (#t + (let ((name (defined-name (car args)))) + `(begin + (eval-when ((load-toplevel) (export ,name))) + (define-private ,@args)))))) (defmacro defmacro-public args (define (syntax) (error "bad syntax" (list 'defmacro-public args))) (define (defined-name n) (cond - ((symbol? n) n) - (else (syntax)))) + ((symbol? n) n) + (else (syntax)))) (cond - ((null? args) (syntax)) - - (#t (let ((name (defined-name (car args)))) - `(begin - (let ((public-i (module-public-interface (current-module)))) - ;; Make sure there is a local variable: - ;; - (module-define! (current-module) - ',name - (module-ref (current-module) ',name #f)) - - ;; Make sure that local is exported: - ;; - (module-add! public-i ',name (module-variable (current-module) ',name))) - - ;; Now (re)define the var normally. - ;; - (defmacro ,@ args)))))) - + ((null? args) + (syntax)) + (#t + (let ((name (defined-name (car args)))) + `(begin + (eval-when ((load-toplevel) (export ,name))) + (defmacro ,@args)))))) (define (module-export! m names) (let ((public-i (module-public-interface m))) @@ -2610,7 +2630,11 @@ names))) (defmacro export names - `(module-export! (current-module) ',names)) + `(eval-when + ((load-toplevel) + (module-export! (current-module) ',names)) + (else + (error "export can only be used at the top level")))) (define export-syntax export) @@ -2622,10 +2646,13 @@ ;;; {Load emacs interface support if emacs option is given.} +(define (named-module-use! user usee) + (module-use! (resolve-module user) (resolve-module usee))) + (define (load-emacs-interface) (if (memq 'debug-extensions *features*) (debug-enable 'backtrace)) - (define-module (guile-user) :use-module (ice-9 emacs))) + (named-module-use! '(guile-user) '(ice-9 emacs))) @@ -2643,15 +2670,16 @@ (load-emacs-interface)) ;; Place the user in the guile-user module. - (define-module (guile-user) - :use-module (guile) ;so that bindings will be checked here first - :use-module (ice-9 session) - :use-module (ice-9 debug) - :autoload (ice-9 debugger) (debug)) ;load debugger on demand + (process-define-module + '((guile-user) + :use-module (guile) ;so that bindings will be checked here first + :use-module (ice-9 session) + :use-module (ice-9 debug) + :autoload (ice-9 debugger) (debug))) ;load debugger on demand (if (memq 'threads *features*) - (define-module (guile-user) :use-module (ice-9 threads))) + (named-module-use! '(guile-user) '(ice-9 threads))) (if (memq 'regex *features*) - (define-module (guile-user) :use-module (ice-9 regex))) + (named-module-use! '(guile-user) '(ice-9 regex))) (let ((old-handlers #f) (signals (if (provided? 'posix) From a2abcb58235c31fcdc75aa5a5f0360c7d3b5a3a0 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 13 Feb 2001 01:09:00 +0000 Subject: [PATCH 0534/2047] * eval.c (scm_ceval, scm_deval): use `SIDEVAL' instead of SCM_CEVAL when evaluating subforms of `begin' forms. SCM_CEVAL can not deal with immediates. --- libguile/eval.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/eval.c b/libguile/eval.c index 06d2af0c6..3b0e8847b 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1912,7 +1912,7 @@ dispatch: while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) { SCM_SETCAR (env, scm_current_module_lookup_closure ()); - SCM_CEVAL (SCM_CAR (x), env); + SIDEVAL (SCM_CAR(x), env); x = t.arg1; } /* once more, for the last form */ From 7af4defed1bb0c9fe9a878c6801f4b07304628d7 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 13 Feb 2001 01:09:25 +0000 Subject: [PATCH 0535/2047] *** empty log message *** --- ice-9/ChangeLog | 19 +++++++++++++++++++ libguile/ChangeLog | 6 ++++++ 2 files changed, 25 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 7c02592c4..d2f021a06 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,22 @@ +2001-02-13 Marius Vollmer + + * boot-9.scm (define-public): Removed spurious call to + `interaction-evironment'. + (define-public, defmacro-public): Use `export' instead of explicit + module magic. + (eval-when): New macro. + (define-module, use-modules, use-syntax, export): Use it to + restrict the use of these forms to the top level. + (define-public, defmacro-public): Only export binding when on + top-level. + (process-define-module): Call `set-current-module' with the + defined module. + (define-module): Simply call `process-define-module' without any + fuss (but only on top-level). + (named-module-use!): New function. + (top-repl): Do not use `define-module'. Use equivalent low-level + means instead. + 2001-02-11 Marius Vollmer * boot-9.scm (scm-style-repl): Use `primitive-eval' instead of diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b3ac66e4c..d54ee5d5d 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2001-02-13 Marius Vollmer + + * eval.c (scm_ceval, scm_deval): use `SIDEVAL' instead of + SCM_CEVAL when evaluating subforms of `begin' forms. SCM_CEVAL + can not deal with immediates. + 2001-02-12 Keisuke Nishida * list.c (scm_list_copy): Validate the first argument. From bc286d9f8edbc501b443906515355d2604741834 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 13 Feb 2001 18:37:19 +0000 Subject: [PATCH 0536/2047] * gc_os_dep.c: Do not include . It makes no sense to compile for a specific kernel version. Do not include while defining __KERNEL__. This hack should no longer be needed and caused problems. --- libguile/gc_os_dep.c | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/libguile/gc_os_dep.c b/libguile/gc_os_dep.c index d9a11bf06..9b0bea170 100644 --- a/libguile/gc_os_dep.c +++ b/libguile/gc_os_dep.c @@ -1379,15 +1379,19 @@ word x; # endif # if defined(LINUX) && !defined(POWERPC) + +#if 0 # include # if (LINUX_VERSION_CODE <= 0x10400) - /* Ugly hack to get struct sigcontext_struct definition. Required */ + /* Ugly hack to get struct sigcontext_struct definition. Required */ /* for some early 1.3.X releases. Will hopefully go away soon. */ /* in some later Linux releases, asm/sigcontext.h may have to */ /* be included instead. */ # define __KERNEL__ # include # undef __KERNEL__ +#endif + # else /* Kernels prior to 2.1.1 defined struct sigcontext_struct instead of */ /* struct sigcontext. libc6 (glibc2) uses "struct sigcontext" in */ From 3178f75169c9c6f91a204b478f5e45eea9a30463 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 13 Feb 2001 18:38:11 +0000 Subject: [PATCH 0537/2047] *** empty log message *** --- libguile/ChangeLog | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d54ee5d5d..f94fe7bea 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2001-02-13 Marius Vollmer + + * gc_os_dep.c: Do not include . It makes no + sense to compile for a specific kernel version. Do not include + while defining __KERNEL__. This hack should no + longer be needed and caused problems. + 2001-02-13 Marius Vollmer * eval.c (scm_ceval, scm_deval): use `SIDEVAL' instead of From 6f76852b4c433b7c5aa945a6155faa77b7852615 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 13 Feb 2001 22:31:29 +0000 Subject: [PATCH 0538/2047] *** empty log message *** --- NEWS | 32 ++++++++++++++++++++++++++++++++ 1 file changed, 32 insertions(+) diff --git a/NEWS b/NEWS index 91e757b19..9c8f90848 100644 --- a/NEWS +++ b/NEWS @@ -109,6 +109,38 @@ Example: * Changes to Scheme functions and syntax +** The module system has been made more disciplined. + +The function `eval' will now save and restore the current module +around the evaluation of the specified expression. While this +expression is evaluated, `(current-module)' will now return the right +module, which is the module specified as the second argument to +`eval'. + +A consequence of this change is that `eval' is not particularily +useful when you want allow the evaluated code to change what module is +designated as the current module and have this change persist from one +call to `eval' to the next. The read-eval-print-loop is an example +where `eval' is now inadequate. To compensate, there is a new +function `primitive-eval' that does not take a module specifier and +that does not save/restore the current module. You should use this +function together with `set-current-module', `current-module', etc +when you want to have more control over the state that is carried from +one eval to the next. + +Additionally, it has been made sure that forms that are evaluated at +the top level are always evaluated with respect to the current module. +Previously, subforms of top-level forms such as `begin', `case', +etc. did not respect changes to the current module although these +subforms are at the top-level as well. + +To prevent strange behaviour, the forms `define-module', +`use-modules', `use-syntax', and `export' have been restricted to only +work on the top level. The forms `define-public' and +`defmacro-public' only export the new binding on the top level. They +behave just like `define' and `defmacro', respectively, when they are +used in a lexical environment. + ** `port-for-each' makes an additional guarantee. From the docstring: @var{proc} is applied exactly once to every port From 5159b33653c0f3fcf10da8cb9108038026fbe04d Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 15 Feb 2001 15:38:26 +0000 Subject: [PATCH 0539/2047] Corrected indentation of new #if stuff. --- libguile/gc_os_dep.c | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/libguile/gc_os_dep.c b/libguile/gc_os_dep.c index 9b0bea170..0001cf824 100644 --- a/libguile/gc_os_dep.c +++ b/libguile/gc_os_dep.c @@ -1380,7 +1380,7 @@ word x; # if defined(LINUX) && !defined(POWERPC) -#if 0 +# if 0 # include # if (LINUX_VERSION_CODE <= 0x10400) /* Ugly hack to get struct sigcontext_struct definition. Required */ @@ -1390,9 +1390,10 @@ word x; # define __KERNEL__ # include # undef __KERNEL__ -#endif +# endif + +# else -# else /* Kernels prior to 2.1.1 defined struct sigcontext_struct instead of */ /* struct sigcontext. libc6 (glibc2) uses "struct sigcontext" in */ /* prototypes, so we have to include the top-level sigcontext.h to */ From 018008c17fad8ded6952e3b371b18687a4b06830 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 15 Feb 2001 15:39:32 +0000 Subject: [PATCH 0540/2047] Do not use "//" comment syntax. It's not ANSI. --- libguile/eval.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index 3b0e8847b..a69fadacb 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3836,9 +3836,9 @@ SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0, SCM scm_system_transformer; -// XXX - scm_i_eval is meant to be useable for evaluation in -// non-toplevel environments, for example when used by the debugger. -// Can the system transform deal with this? +/* XXX - scm_i_eval is meant to be useable for evaluation in + non-toplevel environments, for example when used by the debugger. + Can the system transform deal with this? */ SCM scm_i_eval_x (SCM exp, SCM env) From 8d5a2737c64714f64deb43e766bae87e4ea11229 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 15 Feb 2001 15:39:49 +0000 Subject: [PATCH 0541/2047] * symbols.c (scm_mem2symbol): Put a empty statement after the next_symbol label. This is mandated by ANSI, appearantly. --- libguile/symbols.c | 1 + 1 file changed, 1 insertion(+) diff --git a/libguile/symbols.c b/libguile/symbols.c index 4477bd683..d7c1fb9ef 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -116,6 +116,7 @@ scm_mem2symbol (const char *name, scm_sizet len) return sym; } next_symbol: + ; } } From 1552a59dfceb478e7c44035640738aeb62bf2a85 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 15 Feb 2001 15:40:14 +0000 Subject: [PATCH 0542/2047] *** empty log message *** --- libguile/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f94fe7bea..2b5ce5b49 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-02-15 Marius Vollmer + + * symbols.c (scm_mem2symbol): Put a empty statement after the + next_symbol label. This is mandated by ANSI, appearantly. + 2001-02-13 Marius Vollmer * gc_os_dep.c: Do not include . It makes no From 07347b492ebc4656c546aa90cafe791883cb7532 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 15 Feb 2001 22:15:25 +0000 Subject: [PATCH 0543/2047] * Retire this copy of data-rep.texi. --- doc/ChangeLog | 6 + doc/data-rep.texi | 1794 --------------------------------------------- 2 files changed, 6 insertions(+), 1794 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 8f158822c..180b948ef 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,9 @@ +2001-02-15 Neil Jerram + + * data-rep.texi: Replace this copy of data-rep.texi with a notice + indicating that it has been retired. The master copy of + data-rep.texi is at guile-doc/ref/data-rep.texi. + 2001-02-04 Marius Vollmer * data-rep.texi: Use SCM_SMOB_DATA instead of SCM_CDR. Also diff --git a/doc/data-rep.texi b/doc/data-rep.texi index acf774416..e69de29bb 100644 --- a/doc/data-rep.texi +++ b/doc/data-rep.texi @@ -1,1794 +0,0 @@ -\input texinfo -@c -*-texinfo-*- -@c %**start of header -@setfilename data-rep.info -@settitle Data Representation in Guile -@c %**end of header - -@include version.texi - -@dircategory The Algorithmic Language Scheme -@direntry -* data-rep: (data-rep). Data Representation in Guile --- how to use - Guile objects in your C code. -@end direntry - -@setchapternewpage off - -@ifinfo -Data Representation in Guile - -Copyright (C) 1998, 1999, 2000 Free Software Foundation - -Permission is granted to make and distribute verbatim copies of -this manual provided the copyright notice and this permission notice -are preserved on all copies. - -@ignore -Permission is granted to process this file through TeX and print the -results, provided the printed document carries copying permission -notice identical to this one except for the removal of this paragraph -(this paragraph not being relevant to the printed manual). -@end ignore - -Permission is granted to copy and distribute modified versions of this -manual under the conditions for verbatim copying, provided that the entire -resulting derived work is distributed under the terms of a permission -notice identical to this one. - -Permission is granted to copy and distribute translations of this manual -into another language, under the above conditions for modified versions, -except that this permission notice may be stated in a translation approved -by the Free Software Foundation. -@end ifinfo - -@titlepage -@sp 10 -@comment The title is printed in a large font. -@title Data Representation in Guile -@subtitle $Id: data-rep.texi,v 1.14 2001-02-04 17:29:06 mvo Exp $ -@subtitle For use with Guile @value{VERSION} -@author Jim Blandy -@author Free Software Foundation -@author @email{jimb@@red-bean.com} -@c The following two commands start the copyright page. -@page -@vskip 0pt plus 1filll -@vskip 0pt plus 1filll -Copyright @copyright{} 1998 Free Software Foundation - -Permission is granted to make and distribute verbatim copies of -this manual provided the copyright notice and this permission notice -are preserved on all copies. - -Permission is granted to copy and distribute modified versions of this -manual under the conditions for verbatim copying, provided that the entire -resulting derived work is distributed under the terms of a permission -notice identical to this one. - -Permission is granted to copy and distribute translations of this manual -into another language, under the above conditions for modified versions, -except that this permission notice may be stated in a translation approved -by Free Software Foundation. -@end titlepage - -@c @smallbook -@c @finalout -@headings double - - -@node Top, Data Representation in Scheme, (dir), (dir) -@top Data Representation in Guile - -@ifinfo -This essay is meant to provide the background necessary to read and -write C code that manipulates Scheme values in a way that conforms to -libguile's interface. If you would like to write or maintain a -Guile-based application in C or C++, this is the first information you -need. - -In order to make sense of Guile's @code{SCM_} functions, or read -libguile's source code, it's essential to have a good grasp of how Guile -actually represents Scheme values. Otherwise, a lot of the code, and -the conventions it follows, won't make very much sense. - -We assume you know both C and Scheme, but we do not assume you are -familiar with Guile's C interface. -@end ifinfo - -@menu -* Data Representation in Scheme:: Why things aren't just totally - straightforward, in general terms. -* How Guile does it:: How to write C code that manipulates - Guile values, with an explanation - of Guile's garbage collector. -* Defining New Types (Smobs):: How to extend Guile with your own - application-specific datatypes. -@end menu - -@node Data Representation in Scheme, How Guile does it, Top, Top -@section Data Representation in Scheme - -Scheme is a latently-typed language; this means that the system cannot, -in general, determine the type of a given expression at compile time. -Types only become apparent at run time. Variables do not have fixed -types; a variable may hold a pair at one point, an integer at the next, -and a thousand-element vector later. Instead, values, not variables, -have fixed types. - -In order to implement standard Scheme functions like @code{pair?} and -@code{string?} and provide garbage collection, the representation of -every value must contain enough information to accurately determine its -type at run time. Often, Scheme systems also use this information to -determine whether a program has attempted to apply an operation to an -inappropriately typed value (such as taking the @code{car} of a string). - -Because variables, pairs, and vectors may hold values of any type, -Scheme implementations use a uniform representation for values --- a -single type large enough to hold either a complete value or a pointer -to a complete value, along with the necessary typing information. - -The following sections will present a simple typing system, and then -make some refinements to correct its major weaknesses. However, this is -not a description of the system Guile actually uses. It is only an -illustration of the issues Guile's system must address. We provide all -the information one needs to work with Guile's data in @ref{How Guile -does it}. - - -@menu -* A Simple Representation:: -* Faster Integers:: -* Cheaper Pairs:: -* Guile Is Hairier:: -@end menu - -@node A Simple Representation, Faster Integers, Data Representation in Scheme, Data Representation in Scheme -@subsection A Simple Representation - -The simplest way to meet the above requirements in C would be to -represent each value as a pointer to a structure containing a type -indicator, followed by a union carrying the real value. Assuming that -@code{SCM} is the name of our universal type, we can write: - -@example -enum type @{ integer, pair, string, vector, ... @}; - -typedef struct value *SCM; - -struct value @{ - enum type type; - union @{ - int integer; - struct @{ SCM car, cdr; @} pair; - struct @{ int length; char *elts; @} string; - struct @{ int length; SCM *elts; @} vector; - ... - @} value; -@}; -@end example -with the ellipses replaced with code for the remaining Scheme types. - -This representation is sufficient to implement all of Scheme's -semantics. If @var{x} is an @code{SCM} value: -@itemize @bullet -@item - To test if @var{x} is an integer, we can write @code{@var{x}->type == integer}. -@item - To find its value, we can write @code{@var{x}->value.integer}. -@item - To test if @var{x} is a vector, we can write @code{@var{x}->type == vector}. -@item - If we know @var{x} is a vector, we can write - @code{@var{x}->value.vector.elts[0]} to refer to its first element. -@item - If we know @var{x} is a pair, we can write - @code{@var{x}->value.pair.car} to extract its car. -@end itemize - - -@node Faster Integers, Cheaper Pairs, A Simple Representation, Data Representation in Scheme -@subsection Faster Integers - -Unfortunately, the above representation has a serious disadvantage. In -order to return an integer, an expression must allocate a @code{struct -value}, initialize it to represent that integer, and return a pointer to -it. Furthermore, fetching an integer's value requires a memory -reference, which is much slower than a register reference on most -processors. Since integers are extremely common, this representation is -too costly, in both time and space. Integers should be very cheap to -create and manipulate. - -One possible solution comes from the observation that, on many -architectures, structures must be aligned on a four-byte boundary. -(Whether or not the machine actually requires it, we can write our own -allocator for @code{struct value} objects that assures this is true.) -In this case, the lower two bits of the structure's address are known to -be zero. - -This gives us the room we need to provide an improved representation -for integers. We make the following rules: -@itemize @bullet -@item -If the lower two bits of an @code{SCM} value are zero, then the SCM -value is a pointer to a @code{struct value}, and everything proceeds as -before. -@item -Otherwise, the @code{SCM} value represents an integer, whose value -appears in its upper bits. -@end itemize - -Here is C code implementing this convention: -@example -enum type @{ pair, string, vector, ... @}; - -typedef struct value *SCM; - -struct value @{ - enum type type; - union @{ - struct @{ SCM car, cdr; @} pair; - struct @{ int length; char *elts; @} string; - struct @{ int length; SCM *elts; @} vector; - ... - @} value; -@}; - -#define POINTER_P(x) (((int) (x) & 3) == 0) -#define INTEGER_P(x) (! POINTER_P (x)) - -#define GET_INTEGER(x) ((int) (x) >> 2) -#define MAKE_INTEGER(x) ((SCM) (((x) << 2) | 1)) -@end example - -Notice that @code{integer} no longer appears as an element of @code{enum -type}, and the union has lost its @code{integer} member. Instead, we -use the @code{POINTER_P} and @code{INTEGER_P} macros to make a coarse -classification of values into integers and non-integers, and do further -type testing as before. - -Here's how we would answer the questions posed above (again, assume -@var{x} is an @code{SCM} value): -@itemize @bullet -@item - To test if @var{x} is an integer, we can write @code{INTEGER_P (@var{x})}. -@item - To find its value, we can write @code{GET_INTEGER (@var{x})}. -@item - To test if @var{x} is a vector, we can write: -@example - @code{POINTER_P (@var{x}) && @var{x}->type == vector} -@end example - Given the new representation, we must make sure @var{x} is truly a - pointer before we dereference it to determine its complete type. -@item - If we know @var{x} is a vector, we can write - @code{@var{x}->value.vector.elts[0]} to refer to its first element, as - before. -@item - If we know @var{x} is a pair, we can write - @code{@var{x}->value.pair.car} to extract its car, just as before. -@end itemize - -This representation allows us to operate more efficiently on integers -than the first. For example, if @var{x} and @var{y} are known to be -integers, we can compute their sum as follows: -@example -MAKE_INTEGER (GET_INTEGER (@var{x}) + GET_INTEGER (@var{y})) -@end example -Now, integer math requires no allocation or memory references. Most -real Scheme systems actually use an even more efficient representation, -but this essay isn't about bit-twiddling. (Hint: what if pointers had -@code{01} in their least significant bits, and integers had @code{00}?) - - -@node Cheaper Pairs, Guile Is Hairier, Faster Integers, Data Representation in Scheme -@subsection Cheaper Pairs - -However, there is yet another issue to confront. Most Scheme heaps -contain more pairs than any other type of object; Jonathan Rees says -that pairs occupy 45% of the heap in his Scheme implementation, Scheme -48. However, our representation above spends three @code{SCM}-sized -words per pair --- one for the type, and two for the @sc{car} and -@sc{cdr}. Is there any way to represent pairs using only two words? - -Let us refine the convention we established earlier. Let us assert -that: -@itemize @bullet -@item - If the bottom two bits of an @code{SCM} value are @code{#b00}, then - it is a pointer, as before. -@item - If the bottom two bits are @code{#b01}, then the upper bits are an - integer. This is a bit more restrictive than before. -@item - If the bottom two bits are @code{#b10}, then the value, with the bottom - two bits masked out, is the address of a pair. -@end itemize - -Here is the new C code: -@example -enum type @{ string, vector, ... @}; - -typedef struct value *SCM; - -struct value @{ - enum type type; - union @{ - struct @{ int length; char *elts; @} string; - struct @{ int length; SCM *elts; @} vector; - ... - @} value; -@}; - -struct pair @{ - SCM car, cdr; -@}; - -#define POINTER_P(x) (((int) (x) & 3) == 0) - -#define INTEGER_P(x) (((int) (x) & 3) == 1) -#define GET_INTEGER(x) ((int) (x) >> 2) -#define MAKE_INTEGER(x) ((SCM) (((x) << 2) | 1)) - -#define PAIR_P(x) (((int) (x) & 3) == 2) -#define GET_PAIR(x) ((struct pair *) ((int) (x) & ~3)) -@end example - -Notice that @code{enum type} and @code{struct value} now only contain -provisions for vectors and strings; both integers and pairs have become -special cases. The code above also assumes that an @code{int} is large -enough to hold a pointer, which isn't generally true. - - -Our list of examples is now as follows: -@itemize @bullet -@item - To test if @var{x} is an integer, we can write @code{INTEGER_P - (@var{x})}; this is as before. -@item - To find its value, we can write @code{GET_INTEGER (@var{x})}, as - before. -@item - To test if @var{x} is a vector, we can write: -@example - @code{POINTER_P (@var{x}) && @var{x}->type == vector} -@end example - We must still make sure that @var{x} is a pointer to a @code{struct - value} before dereferencing it to find its type. -@item - If we know @var{x} is a vector, we can write - @code{@var{x}->value.vector.elts[0]} to refer to its first element, as - before. -@item - We can write @code{PAIR_P (@var{x})} to determine if @var{x} is a - pair, and then write @code{GET_PAIR (@var{x})->car} to refer to its - car. -@end itemize - -This change in representation reduces our heap size by 15%. It also -makes it cheaper to decide if a value is a pair, because no memory -references are necessary; it suffices to check the bottom two bits of -the @code{SCM} value. This may be significant when traversing lists, a -common activity in a Scheme system. - -Again, most real Scheme systems use a slighty different implementation; -for example, if GET_PAIR subtracts off the low bits of @code{x}, instead -of masking them off, the optimizer will often be able to combine that -subtraction with the addition of the offset of the structure member we -are referencing, making a modified pointer as fast to use as an -unmodified pointer. - - -@node Guile Is Hairier, , Cheaper Pairs, Data Representation in Scheme -@subsection Guile Is Hairier - -We originally started with a very simple typing system --- each object -has a field that indicates its type. Then, for the sake of efficiency -in both time and space, we moved some of the typing information directly -into the @code{SCM} value, and left the rest in the @code{struct value}. -Guile itself employs a more complex hierarchy, storing finer and finer -gradations of type information in different places, depending on the -object's coarser type. - -In the author's opinion, Guile could be simplified greatly without -significant loss of efficiency, but the simplified system would still be -more complex than what we've presented above. - - -@node How Guile does it, Defining New Types (Smobs), Data Representation in Scheme, Top -@section How Guile does it - -Here we present the specifics of how Guile represents its data. We -don't go into complete detail; an exhaustive description of Guile's -system would be boring, and we do not wish to encourage people to write -code which depends on its details anyway. We do, however, present -everything one need know to use Guile's data. - - -@menu -* General Rules:: -* Garbage Collection:: -* Immediates vs. Non-immediates:: -* Immediate Datatypes:: -* Non-immediate Datatypes:: -* Signalling Type Errors:: -@end menu - -@node General Rules, Garbage Collection, How Guile does it, How Guile does it -@subsection General Rules - -Any code which operates on Guile datatypes must @code{#include} the -header file @code{}. This file contains a definition for -the @code{SCM} typedef (Guile's universal type, as in the examples -above), and definitions and declarations for a host of macros and -functions that operate on @code{SCM} values. - -All identifiers declared by @code{} begin with @code{scm_} -or @code{SCM_}. - -@c [[I wish this were true, but I don't think it is at the moment. -JimB]] -@c Macros do not evaluate their arguments more than once, unless documented -@c to do so. - -The functions described here generally check the types of their -@code{SCM} arguments, and signal an error if their arguments are of an -inappropriate type. Macros generally do not, unless that is their -specified purpose. You must verify their argument types beforehand, as -necessary. - -Macros and functions that return a boolean value have names ending in -@code{P} or @code{_p} (for ``predicate''). Those that return a negated -boolean value have names starting with @code{SCM_N}. For example, -@code{SCM_IMP (@var{x})} is a predicate which returns non-zero iff -@var{x} is an immediate value (an @code{IM}). @code{SCM_NCONSP -(@var{x})} is a predicate which returns non-zero iff @var{x} is -@emph{not} a pair object (a @code{CONS}). - - -@node Garbage Collection, Immediates vs. Non-immediates, General Rules, How Guile does it -@subsection Garbage Collection - -Aside from the latent typing, the major source of constraints on a -Scheme implementation's data representation is the garbage collector. -The collector must be able to traverse every live object in the heap, to -determine which objects are not live. - -There are many ways to implement this, but Guile uses an algorithm -called @dfn{mark and sweep}. The collector scans the system's global -variables and the local variables on the stack to determine which -objects are immediately accessible by the C code. It then scans those -objects to find the objects they point to, @i{et cetera}. The collector -sets a @dfn{mark bit} on each object it finds, so each object is -traversed only once. This process is called @dfn{tracing}. - -When the collector can find no unmarked objects pointed to by marked -objects, it assumes that any objects that are still unmarked will never -be used by the program (since there is no path of dereferences from any -global or local variable that reaches them) and deallocates them. - -In the above paragraphs, we did not specify how the garbage collector -finds the global and local variables; as usual, there are many different -approaches. Frequently, the programmer must maintain a list of pointers -to all global variables that refer to the heap, and another list -(adjusted upon entry to and exit from each function) of local variables, -for the collector's benefit. - -The list of global variables is usually not too difficult to maintain, -since global variables are relatively rare. However, an explicitly -maintained list of local variables (in the author's personal experience) -is a nightmare to maintain. Thus, Guile uses a technique called -@dfn{conservative garbage collection}, to make the local variable list -unnecessary. - -The trick to conservative collection is to treat the stack as an -ordinary range of memory, and assume that @emph{every} word on the stack -is a pointer into the heap. Thus, the collector marks all objects whose -addresses appear anywhere in the stack, without knowing for sure how -that word is meant to be interpreted. - -Obviously, such a system will occasionally retain objects that are -actually garbage, and should be freed. In practice, this is not a -problem. The alternative, an explicitly maintained list of local -variable addresses, is effectively much less reliable, due to programmer -error. - -To accommodate this technique, data must be represented so that the -collector can accurately determine whether a given stack word is a -pointer or not. Guile does this as follows: -@itemize @bullet - -@item -Every heap object has a two-word header, called a @dfn{cell}. Some -objects, like pairs, fit entirely in a cell's two words; others may -store pointers to additional memory in either of the words. For -example, strings and vectors store their length in the first word, and a -pointer to their elements in the second. - -@item -Guile allocates whole arrays of cells at a time, called @dfn{heap -segments}. These segments are always allocated so that the cells they -contain fall on eight-byte boundaries, or whatever is appropriate for -the machine's word size. Guile keeps all cells in a heap segment -initialized, whether or not they are currently in use. - -@item -Guile maintains a sorted table of heap segments. - -@end itemize - -Thus, given any random word @var{w} fetched from the stack, Guile's -garbage collector can consult the table to see if @var{w} falls within a -known heap segment, and check @var{w}'s alignment. If both tests pass, -the collector knows that @var{w} is a valid pointer to a cell, -intentional or not, and proceeds to trace the cell. - -Note that heap segments do not contain all the data Guile uses; cells -for objects like vectors and strings contain pointers to other memory -areas. However, since those pointers are internal, and not shared among -many pieces of code, it is enough for the collector to find the cell, -and then use the cell's type to find more pointers to trace. - - -@node Immediates vs. Non-immediates, Immediate Datatypes, Garbage Collection, How Guile does it -@subsection Immediates vs. Non-immediates - -Guile classifies Scheme objects into two kinds: those that fit entirely -within an @code{SCM}, and those that require heap storage. - -The former class are called @dfn{immediates}. The class of immediates -includes small integers, characters, boolean values, the empty list, the -mysterious end-of-file object, and some others. - -The remaining types are called, not suprisingly, @dfn{non-immediates}. -They include pairs, procedures, strings, vectors, and all other data -types in Guile. - -@deftypefn Macro int SCM_IMP (SCM @var{x}) -Return non-zero iff @var{x} is an immediate object. -@end deftypefn - -@deftypefn Macro int SCM_NIMP (SCM @var{x}) -Return non-zero iff @var{x} is a non-immediate object. This is the -exact complement of @code{SCM_IMP}, above. - -You must use this macro before calling a finer-grained predicate to -determine @var{x}'s type. For example, to see if @var{x} is a pair, you -must write: -@example -SCM_NIMP (@var{x}) && SCM_CONSP (@var{x}) -@end example -This is because Guile stores typing information for non-immediate values -in their cells, rather than in the @code{SCM} value itself; thus, you -must determine whether @var{x} refers to a cell before looking inside -it. - -This is somewhat of a pity, because it means that the programmer needs -to know which types Guile implements as immediates vs. non-immediates. -There are (possibly better) representations in which @code{SCM_CONSP} -can be self-sufficient. The immediate type predicates do not suffer -from this weakness. -@end deftypefn - - -@node Immediate Datatypes, Non-immediate Datatypes, Immediates vs. Non-immediates, How Guile does it -@subsection Immediate Datatypes - -The following datatypes are immediate values; that is, they fit entirely -within an @code{SCM} value. The @code{SCM_IMP} and @code{SCM_NIMP} -macros will distinguish these from non-immediates; see @ref{Immediates -vs. Non-immediates} for an explanation of the distinction. - -Note that the type predicates for immediate values work correctly on any -@code{SCM} value; you do not need to call @code{SCM_IMP} first, to -establish that a value is immediate. This differs from the -non-immediate type predicates, which work correctly only on -non-immediate values; you must be sure the value is @code{SCM_NIMP} -before applying them. - - -@menu -* Integers:: -* Characters:: -* Booleans:: -* Unique Values:: -@end menu - -@node Integers, Characters, Immediate Datatypes, Immediate Datatypes -@subsubsection Integers - -Here are functions for operating on small integers, that fit within an -@code{SCM}. Such integers are called @dfn{immediate numbers}, or -@dfn{INUMs}. In general, INUMs occupy all but two bits of an -@code{SCM}. - -Bignums and floating-point numbers are non-immediate objects, and have -their own, separate accessors. The functions here will not work on -them. This is not as much of a problem as you might think, however, -because the system never constructs bignums that could fit in an INUM, -and never uses floating point values for exact integers. - -@deftypefn Macro int SCM_INUMP (SCM @var{x}) -Return non-zero iff @var{x} is a small integer value. -@end deftypefn - -@deftypefn Macro int SCM_NINUMP (SCM @var{x}) -The complement of SCM_INUMP. -@end deftypefn - -@deftypefn Macro int SCM_INUM (SCM @var{x}) -Return the value of @var{x} as an ordinary, C integer. If @var{x} -is not an INUM, the result is undefined. -@end deftypefn - -@deftypefn Macro SCM SCM_MAKINUM (int @var{i}) -Given a C integer @var{i}, return its representation as an @code{SCM}. -This function does not check for overflow. -@end deftypefn - - -@node Characters, Booleans, Integers, Immediate Datatypes -@subsubsection Characters - -Here are functions for operating on characters. - -@deftypefn Macro int SCM_CHARP (SCM @var{x}) -Return non-zero iff @var{x} is a character value. -@end deftypefn - -@deftypefn Macro {unsigned int} SCM_CHAR (SCM @var{x}) -Return the value of @code{x} as a C character. If @var{x} is not a -Scheme character, the result is undefined. -@end deftypefn - -@deftypefn Macro SCM SCM_MAKE_CHAR (int @var{c}) -Given a C character @var{c}, return its representation as a Scheme -character value. -@end deftypefn - - -@node Booleans, Unique Values, Characters, Immediate Datatypes -@subsubsection Booleans - -Here are functions and macros for operating on booleans. - -@deftypefn Macro SCM SCM_BOOL_T -@deftypefnx Macro SCM SCM_BOOL_F -The Scheme true and false values. -@end deftypefn - -@deftypefn Macro int SCM_NFALSEP (@var{x}) -Convert the Scheme boolean value to a C boolean. Since every object in -Scheme except @code{#f} is true, this amounts to comparing @var{x} to -@code{#f}; hence the name. -@c Noel feels a chill here. -@end deftypefn - -@deftypefn Macro SCM SCM_BOOL_NOT (@var{x}) -Return the boolean inverse of @var{x}. If @var{x} is not a -Scheme boolean, the result is undefined. -@end deftypefn - - -@node Unique Values, , Booleans, Immediate Datatypes -@subsubsection Unique Values - -The immediate values that are neither small integers, characters, nor -booleans are all unique values --- that is, datatypes with only one -instance. - -@deftypefn Macro SCM SCM_EOL -The Scheme empty list object, or ``End Of List'' object, usually written -in Scheme as @code{'()}. -@end deftypefn - -@deftypefn Macro SCM SCM_EOF_VAL -The Scheme end-of-file value. It has no standard written -representation, for obvious reasons. -@end deftypefn - -@deftypefn Macro SCM SCM_UNSPECIFIED -The value returned by expressions which the Scheme standard says return -an ``unspecified'' value. - -This is sort of a weirdly literal way to take things, but the standard -read-eval-print loop prints nothing when the expression returns this -value, so it's not a bad idea to return this when you can't think of -anything else helpful. -@end deftypefn - -@deftypefn Macro SCM SCM_UNDEFINED -The ``undefined'' value. Its most important property is that is not -equal to any valid Scheme value. This is put to various internal uses -by C code interacting with Guile. - -For example, when you write a C function that is callable from Scheme -and which takes optional arguments, the interpreter passes -@code{SCM_UNDEFINED} for any arguments you did not receive. - -We also use this to mark unbound variables. -@end deftypefn - -@deftypefn Macro int SCM_UNBNDP (SCM @var{x}) -Return true if @var{x} is @code{SCM_UNDEFINED}. Apply this to a -symbol's value to see if it has a binding as a global variable. -@end deftypefn - - -@node Non-immediate Datatypes, Signalling Type Errors, Immediate Datatypes, How Guile does it -@subsection Non-immediate Datatypes - -A non-immediate datatype is one which lives in the heap, either because -it cannot fit entirely within a @code{SCM} word, or because it denotes a -specific storage location (in the nomenclature of the Revised^4 Report -on Scheme). - -The @code{SCM_IMP} and @code{SCM_NIMP} macros will distinguish these -from immediates; see @ref{Immediates vs. Non-immediates}. - -Given a cell, Guile distinguishes between pairs and other non-immediate -types by storing special @dfn{tag} values in a non-pair cell's car, that -cannot appear in normal pairs. A cell with a non-tag value in its car -is an ordinary pair. The type of a cell with a tag in its car depends -on the tag; the non-immediate type predicates test this value. If a tag -value appears elsewhere (in a vector, for example), the heap may become -corrupted. - - -@menu -* Non-immediate Type Predicates:: Special rules for using the type - predicates described here. -* Pairs:: -* Vectors:: -* Procedures:: -* Closures:: -* Subrs:: -* Ports:: -@end menu - -@node Non-immediate Type Predicates, Pairs, Non-immediate Datatypes, Non-immediate Datatypes -@subsubsection Non-immediate Type Predicates - -As mentioned in @ref{Garbage Collection}, all non-immediate objects -start with a @dfn{cell}, or a pair of words. Furthermore, all type -information that distinguishes one kind of non-immediate from another is -stored in the cell. The type information in the @code{SCM} value -indicates only that the object is a non-immediate; all finer -distinctions require one to examine the cell itself, usually with the -appropriate type predicate macro. - -The type predicates for non-immediate objects generally assume that -their argument is a non-immediate value. Thus, you must be sure that a -value is @code{SCM_NIMP} first before passing it to a non-immediate type -predicate. Thus, the idiom for testing whether a value is a cell or not -is: -@example -SCM_NIMP (@var{x}) && SCM_CONSP (@var{x}) -@end example - - -@node Pairs, Vectors, Non-immediate Type Predicates, Non-immediate Datatypes -@subsubsection Pairs - -Pairs are the essential building block of list structure in Scheme. A -pair object has two fields, called the @dfn{car} and the @dfn{cdr}. - -It is conventional for a pair's @sc{car} to contain an element of a -list, and the @sc{cdr} to point to the next pair in the list, or to -contain @code{SCM_EOL}, indicating the end of the list. Thus, a set of -pairs chained through their @sc{cdr}s constitutes a singly-linked list. -Scheme and libguile define many functions which operate on lists -constructed in this fashion, so although lists chained through the -@sc{car}s of pairs will work fine too, they may be less convenient to -manipulate, and receive less support from the community. - -Guile implements pairs by mapping the @sc{car} and @sc{cdr} of a pair -directly into the two words of the cell. - - -@deftypefn Macro int SCM_CONSP (SCM @var{x}) -Return non-zero iff @var{x} is a Scheme pair object. -The results are undefined if @var{x} is an immediate value. -@end deftypefn - -@deftypefn Macro int SCM_NCONSP (SCM @var{x}) -The complement of SCM_CONSP. -@end deftypefn - -@deftypefn Macro void SCM_NEWCELL (SCM @var{into}) -Allocate a new cell, and set @var{into} to point to it. This macro -expands to a statement, not an expression, and @var{into} must be an -lvalue of type SCM. - -This is the most primitive way to allocate a cell; it is quite fast. - -The @sc{car} of the cell initially tags it as a ``free cell''. If the -caller intends to use it as an ordinary cons, she must store ordinary -SCM values in its @sc{car} and @sc{cdr}. - -If the caller intends to use it as a header for some other type, she -must store an appropriate magic value in the cell's @sc{car}, to mark -it as a member of that type, and store whatever value in the @sc{cdr} -that type expects. You should generally not do this, unless you are -implementing a new datatype, and thoroughly understand the code in -@code{}. -@end deftypefn - -@deftypefun SCM scm_cons (SCM @var{car}, SCM @var{cdr}) -Allocate (``CONStruct'') a new pair, with @var{car} and @var{cdr} as its -contents. -@end deftypefun - - -The macros below perform no typechecking. The results are undefined if -@var{cell} is an immediate. However, since all non-immediate Guile -objects are constructed from cells, and these macros simply return the -first element of a cell, they actually can be useful on datatypes other -than pairs. (Of course, it is not very modular to use them outside of -the code which implements that datatype.) - -@deftypefn Macro SCM SCM_CAR (SCM @var{cell}) -Return the @sc{car}, or first field, of @var{cell}. -@end deftypefn - -@deftypefn Macro SCM SCM_CDR (SCM @var{cell}) -Return the @sc{cdr}, or second field, of @var{cell}. -@end deftypefn - -@deftypefn Macro void SCM_SETCAR (SCM @var{cell}, SCM @var{x}) -Set the @sc{car} of @var{cell} to @var{x}. -@end deftypefn - -@deftypefn Macro void SCM_SETCDR (SCM @var{cell}, SCM @var{x}) -Set the @sc{cdr} of @var{cell} to @var{x}. -@end deftypefn - -@deftypefn Macro SCM SCM_CAAR (SCM @var{cell}) -@deftypefnx Macro SCM SCM_CADR (SCM @var{cell}) -@deftypefnx Macro SCM SCM_CDAR (SCM @var{cell}) @dots{} -@deftypefnx Macro SCM SCM_CDDDDR (SCM @var{cell}) -Return the @sc{car} of the @sc{car} of @var{cell}, the @sc{car} of the -@sc{cdr} of @var{cell}, @i{et cetera}. -@end deftypefn - - -@node Vectors, Procedures, Pairs, Non-immediate Datatypes -@subsubsection Vectors, Strings, and Symbols - -Vectors, strings, and symbols have some properties in common. They all -have a length, and they all have an array of elements. In the case of a -vector, the elements are @code{SCM} values; in the case of a string or -symbol, the elements are characters. - -All these types store their length (along with some tagging bits) in the -@sc{car} of their header cell, and store a pointer to the elements in -their @sc{cdr}. Thus, the @code{SCM_CAR} and @code{SCM_CDR} macros -are (somewhat) meaningful when applied to these datatypes. - -@deftypefn Macro int SCM_VECTORP (SCM @var{x}) -Return non-zero iff @var{x} is a vector. -The results are undefined if @var{x} is an immediate value. -@end deftypefn - -@deftypefn Macro int SCM_STRINGP (SCM @var{x}) -Return non-zero iff @var{x} is a string. -The results are undefined if @var{x} is an immediate value. -@end deftypefn - -@deftypefn Macro int SCM_SYMBOLP (SCM @var{x}) -Return non-zero iff @var{x} is a symbol. -The results are undefined if @var{x} is an immediate value. -@end deftypefn - -@deftypefn Macro int SCM_LENGTH (SCM @var{x}) -Return the length of the object @var{x}. -The results are undefined if @var{x} is not a vector, string, or symbol. -@end deftypefn - -@deftypefn Macro {SCM *} SCM_VELTS (SCM @var{x}) -Return a pointer to the array of elements of the vector @var{x}. -The results are undefined if @var{x} is not a vector. -@end deftypefn - -@deftypefn Macro {char *} SCM_CHARS (SCM @var{x}) -Return a pointer to the characters of @var{x}. -The results are undefined if @var{x} is not a symbol or a string. -@end deftypefn - -There are also a few magic values stuffed into memory before a symbol's -characters, but you don't want to know about those. What cruft! - - -@node Procedures, Closures, Vectors, Non-immediate Datatypes -@subsubsection Procedures - -Guile provides two kinds of procedures: @dfn{closures}, which are the -result of evaluating a @code{lambda} expression, and @dfn{subrs}, which -are C functions packaged up as Scheme objects, to make them available to -Scheme programmers. - -(There are actually other sorts of procedures: compiled closures, and -continuations; see the source code for details about them.) - -@deftypefun SCM scm_procedure_p (SCM @var{x}) -Return @code{SCM_BOOL_T} iff @var{x} is a Scheme procedure object, of -any sort. Otherwise, return @code{SCM_BOOL_F}. -@end deftypefun - - -@node Closures, Subrs, Procedures, Non-immediate Datatypes -@subsubsection Closures - -[FIXME: this needs to be further subbed, but texinfo has no subsubsub] - -A closure is a procedure object, generated as the value of a -@code{lambda} expression in Scheme. The representation of a closure is -straightforward --- it contains a pointer to the code of the lambda -expression from which it was created, and a pointer to the environment -it closes over. - -In Guile, each closure also has a property list, allowing the system to -store information about the closure. I'm not sure what this is used for -at the moment --- the debugger, maybe? - -@deftypefn Macro int SCM_CLOSUREP (SCM @var{x}) -Return non-zero iff @var{x} is a closure. The results are -undefined if @var{x} is an immediate value. -@end deftypefn - -@deftypefn Macro SCM SCM_PROCPROPS (SCM @var{x}) -Return the property list of the closure @var{x}. The results are -undefined if @var{x} is not a closure. -@end deftypefn - -@deftypefn Macro void SCM_SETPROCPROPS (SCM @var{x}, SCM @var{p}) -Set the property list of the closure @var{x} to @var{p}. The results -are undefined if @var{x} is not a closure. -@end deftypefn - -@deftypefn Macro SCM SCM_CODE (SCM @var{x}) -Return the code of the closure @var{x}. The results are undefined if -@var{x} is not a closure. - -This function should probably only be used internally by the -interpreter, since the representation of the code is intimately -connected with the interpreter's implementation. -@end deftypefn - -@deftypefn Macro SCM SCM_ENV (SCM @var{x}) -Return the environment enclosed by @var{x}. -The results are undefined if @var{x} is not a closure. - -This function should probably only be used internally by the -interpreter, since the representation of the environment is intimately -connected with the interpreter's implementation. -@end deftypefn - - -@node Subrs, Ports, Closures, Non-immediate Datatypes -@subsubsection Subrs - -[FIXME: this needs to be further subbed, but texinfo has no subsubsub] - -A subr is a pointer to a C function, packaged up as a Scheme object to -make it callable by Scheme code. In addition to the function pointer, -the subr also contains a pointer to the name of the function, and -information about the number of arguments accepted by the C fuction, for -the sake of error checking. - -There is no single type predicate macro that recognizes subrs, as -distinct from other kinds of procedures. The closest thing is -@code{scm_procedure_p}; see @ref{Procedures}. - -@deftypefn Macro {char *} SCM_SNAME (@var{x}) -Return the name of the subr @var{x}. The results are undefined if -@var{x} is not a subr. -@end deftypefn - -@deftypefun SCM scm_make_gsubr (char *@var{name}, int @var{req}, int @var{opt}, int @var{rest}, SCM (*@var{function})()) -Create a new subr object named @var{name}, based on the C function -@var{function}, make it visible to Scheme the value of as a global -variable named @var{name}, and return the subr object. - -The subr object accepts @var{req} required arguments, @var{opt} optional -arguments, and a @var{rest} argument iff @var{rest} is non-zero. The C -function @var{function} should accept @code{@var{req} + @var{opt}} -arguments, or @code{@var{req} + @var{opt} + 1} arguments if @code{rest} -is non-zero. - -When a subr object is applied, it must be applied to at least @var{req} -arguments, or else Guile signals an error. @var{function} receives the -subr's first @var{req} arguments as its first @var{req} arguments. If -there are fewer than @var{opt} arguments remaining, then @var{function} -receives the value @code{SCM_UNDEFINED} for any missing optional -arguments. If @var{rst} is non-zero, then any arguments after the first -@code{@var{req} + @var{opt}} are packaged up as a list as passed as -@var{function}'s last argument. - -Note that subrs can actually only accept a predefined set of -combinations of required, optional, and rest arguments. For example, a -subr can take one required argument, or one required and one optional -argument, but a subr can't take one required and two optional arguments. -It's bizarre, but that's the way the interpreter was written. If the -arguments to @code{scm_make_gsubr} do not fit one of the predefined -patterns, then @code{scm_make_gsubr} will return a compiled closure -object instead of a subr object. -@end deftypefun - - -@node Ports, , Subrs, Non-immediate Datatypes -@subsubsection Ports - -Haven't written this yet, 'cos I don't understand ports yet. - - -@node Signalling Type Errors, , Non-immediate Datatypes, How Guile does it -@subsection Signalling Type Errors - -Every function visible at the Scheme level should aggressively check the -types of its arguments, to avoid misinterpreting a value, and perhaps -causing a segmentation fault. Guile provides some macros to make this -easier. - -@deftypefn Macro void SCM_ASSERT (int @var{test}, SCM @var{obj}, int @var{position}, char *@var{subr}) -If @var{test} is zero, signal an error, attributed to the subroutine -named @var{subr}, operating on the value @var{obj}. The @var{position} -value determines exactly what sort of error to signal. - -If @var{position} is a string, @code{SCM_ASSERT} raises a -``miscellaneous'' error whose message is that string. - -Otherwise, @var{position} should be one of the values defined below. -@end deftypefn - -@deftypefn Macro int SCM_ARG1 -@deftypefnx Macro int SCM_ARG2 -@deftypefnx Macro int SCM_ARG3 -@deftypefnx Macro int SCM_ARG4 -@deftypefnx Macro int SCM_ARG5 -Signal a ``wrong type argument'' error. When used as the @var{position} -argument of @code{SCM_ASSERT}, @code{SCM_ARG@var{n}} claims that -@var{obj} has the wrong type for the @var{n}'th argument of @var{subr}. - -The only way to complain about the type of an argument after the fifth -is to use @code{SCM_ARGn}, defined below, which doesn't specify which -argument is wrong. You could pass your own error message to -@code{SCM_ASSERT} as the @var{position}, but then the error signalled is -a ``miscellaneous'' error, not a ``wrong type argument'' error. This -seems kludgy to me. -@comment Any function with more than two arguments is wrong --- Perlis -@comment Despite Perlis, I agree. Why not have two Macros, one with -@comment a string error message, and the other with an integer position -@comment that only claims a type error in an argument? -@comment --- Keith Wright -@end deftypefn - -@deftypefn Macro int SCM_ARGn -As above, but does not specify which argument's type is incorrect. -@end deftypefn - -@deftypefn Macro int SCM_WNA -Signal an error complaining that the function received the wrong number -of arguments. - -Interestingly, the message is attributed to the function named by -@var{obj}, not @var{subr}, so @var{obj} must be a Scheme string object -naming the function. Usually, Guile catches these errors before ever -invoking the subr, so we don't run into these problems. -@end deftypefn - - -@node Defining New Types (Smobs), , How Guile does it, Top -@section Defining New Types (Smobs) - -@dfn{Smobs} are Guile's mechanism for adding new non-immediate types to -the system.@footnote{The term ``smob'' was coined by Aubrey Jaffer, who -says it comes from ``small object'', referring to the fact that only the -@sc{cdr} and part of the @sc{car} of a smob's cell are available for -use.} To define a new smob type, the programmer provides Guile with -some essential information about the type --- how to print it, how to -garbage collect it, and so on --- and Guile returns a fresh type tag for -use in the @sc{car} of new cells. The programmer can then use -@code{scm_make_gsubr} to make a set of C functions that create and -operate on these objects visible to Scheme code. - -(You can find a complete version of the example code used in this -section in the Guile distribution, in @file{doc/example-smob}. That -directory includes a makefile and a suitable @code{main} function, so -you can build a complete interactive Guile shell, extended with the -datatypes described here.) - -@menu -* Describing a New Type:: -* Creating Instances:: -* Typechecking:: -* Garbage Collecting Smobs:: -* A Common Mistake In Allocating Smobs:: -* Garbage Collecting Simple Smobs:: -* A Complete Example:: -@end menu - -@node Describing a New Type, Creating Instances, Defining New Types (Smobs), Defining New Types (Smobs) -@subsection Describing a New Type - -To define a new type, the programmer must write four functions to -manage instances of the type: - -@table @code -@item mark -Guile will apply this function to each instance of the new type it -encounters during garbage collection. This function is responsible for -telling the collector about any other non-immediate objects the object -refers to. The default smob mark function is to not mark any data. -@xref{Garbage Collecting Smobs}, for more details. - -@item free -Guile will apply this function to each instance of the new type it could -not find any live pointers to. The function should release all -resources held by the object and return the number of bytes released. -This is analagous to the Java finalization method-- it is invoked at -an unspecified time (when garbage collection occurs) after the object -is dead. -The default free function frees the smob data (if the size of the struct -passed to @code{scm_make_smob_type} or @code{scm_make_smob_type_mfpe} is -non-zero) using @code{scm_must_free} and returns the size of that -struct. @xref{Garbage Collecting Smobs}, for more details. - -@item print -@c GJB:FIXME:: @var{exp} and @var{port} need to refer to a prototype of -@c the print function.... where is that, or where should it go? -Guile will apply this function to each instance of the new type to print -the value, as for @code{display} or @code{write}. The function should -write a printed representation of @var{exp} on @var{port}, in accordance -with the parameters in @var{pstate}. (For more information on print -states, see @ref{Ports}.) The default print function prints @code{#} -where @code{NAME} is the first argument passed to @code{scm_make_smob_type} or -@code{scm_make_smob_type_mfpe}. - -@item equalp -If Scheme code asks the @code{equal?} function to compare two instances -of the same smob type, Guile calls this function. It should return -@code{SCM_BOOL_T} if @var{a} and @var{b} should be considered -@code{equal?}, or @code{SCM_BOOL_F} otherwise. If @code{equalp} is -@code{NULL}, @code{equal?} will assume that two instances of this type are -never @code{equal?} unless they are @code{eq?}. - -@end table - -To actually register the new smob type, call @code{scm_make_smob_type}: - -@deftypefun long scm_make_smob_type (const char *name, scm_sizet size) -This function implements the standard way of adding a new smob type, -named @var{name}, with instance size @var{size}, to the system. The -return value is a tag that is used in creating instances of the type. -If @var{size} is 0, then no memory will be allocated when instances of -the smob are created, and nothing will be freed by the default free -function. Default values are provided for mark, free, print, and, -equalp, as described above. If you want to customize any of these -functions, the call to @code{scm_make_smob_type} should be immediately -followed by calls to one or several of @code{scm_set_smob_mark}, -@code{scm_set_smob_free}, @code{scm_set_smob_print}, and/or -@code{scm_set_smob_equalp}. -@end deftypefun - -Each of the below @code{scm_set_smob_XXX} functions registers a smob -special function for a given type. Each function is intended to be used -only zero or one time per type, and the call should be placed -immediately following the call to @code{scm_make_smob_type}. - -@deftypefun void scm_set_smob_mark (long tc, SCM (*mark) (SCM)) -This function sets the smob marking procedure for the smob type specified by -the tag @var{tc}. @var{tc} is the tag returned by @code{scm_make_smob_type}. -@end deftypefun - -@deftypefun void scm_set_smob_free (long tc, scm_sizet (*free) (SCM)) -This function sets the smob freeing procedure for the smob type specified by -the tag @var{tc}. @var{tc} is the tag returned by @code{scm_make_smob_type}. -@end deftypefun - -@deftypefun void scm_set_smob_print (long tc, int (*print) (SCM,SCM,scm_print_state*)) -This function sets the smob printing procedure for the smob type specified by -the tag @var{tc}. @var{tc} is the tag returned by @code{scm_make_smob_type}. -@end deftypefun - -@deftypefun void scm_set_smob_equalp (long tc, SCM (*equalp) (SCM,SCM)) -This function sets the smob equality-testing predicate for the smob type specified by -the tag @var{tc}. @var{tc} is the tag returned by @code{scm_make_smob_type}. -@end deftypefun - -Instead of using @code{scm_make_smob_type} and calling each of the -individual @code{scm_set_smob_XXX} functions to register each special -function independently, you can use @code{scm_make_smob_type_mfpe} to -register all of the special functions at once as you create the smob -type@footnote{Warning: There is an ongoing discussion among the developers which -may result in deprecating @code{scm_make_smob_type_mfpe} in next release -of Guile.}: - -@deftypefun long scm_make_smob_type_mfpe(const char *name, scm_sizet size, SCM (*mark) (SCM), scm_sizet (*free) (SCM), int (*print) (SCM, SCM, scm_print_state*), SCM (*equalp) (SCM, SCM)) -This function invokes @code{scm_make_smob_type} on its first two arguments -to add a new smob type named @var{name}, with instance size @var{size} to the system. -It also registers the @var{mark}, @var{free}, @var{print}, @var{equalp} smob -special functions for that new type. Any of these parameters can be @code{NULL} -to have that special function use the default behaviour for guile. -The return value is a tag that is used in creating instances of the type. If @var{size} -is 0, then no memory will be allocated when instances of the smob are created, and -nothing will be freed by the default free function. -@end deftypefun - -For example, here is how one might declare and register a new type -representing eight-bit grayscale images: -@example -#include - -long image_tag; - -void -init_image_type () -@{ - image_tag = scm_make_smob_type_mfpe ("image",sizeof(struct image), - mark_image, free_image, print_image, NULL); -@} -@end example - - -@node Creating Instances, Typechecking, Describing a New Type, Defining New Types (Smobs) -@subsection Creating Instances - -Like other non-immediate types, smobs start with a cell whose @sc{car} -contains typing information, and whose @code{cdr} is free for any use. For smobs, -the @code{cdr} stores a pointer to the internal C structure holding the -smob-specific data. -To create an instance of a smob type following these standards, you should -use @code{SCM_NEWSMOB}: - -@deftypefn Macro void SCM_NEWSMOB(SCM value,long tag,void *data) -Make @var{value} contain a smob instance of the type with tag @var{tag} -and smob data @var{data}. @var{value} must be previously declared -as C type @code{SCM}. -@end deftypefn - -Since it is often the case (e.g., in smob constructors) that you will -create a smob instance and return it, there is also a slightly specialized -macro for this situation: - -@deftypefn Macro fn_returns SCM_RETURN_NEWSMOB(long tab, void *data) -This macro expands to a block of code that creates a smob instance of -the type with tag @var{tag} and smob data @var{data}, and returns -that @code{SCM} value. It should be the last piece of code in -a block. -@end deftypefn - -Guile provides the following functions for managing memory, which are -often helpful when implementing smobs: - -@deftypefun {char *} scm_must_malloc (long @var{len}, char *@var{what}) -Allocate @var{len} bytes of memory, using @code{malloc}, and return a -pointer to them. - -If there is not enough memory available, invoke the garbage collector, -and try once more. If there is still not enough, signal an error, -reporting that we could not allocate @var{what}. - -This function also helps maintain statistics about the size of the heap. -@end deftypefun - -@deftypefun {char *} scm_must_realloc (char *@var{addr}, long @var{olen}, long @var{len}, char *@var{what}) -Resize (and possibly relocate) the block of memory at @var{addr}, to -have a size of @var{len} bytes, by calling @code{realloc}. Return a -pointer to the new block. - -If there is not enough memory available, invoke the garbage collector, -and try once more. If there is still not enough, signal an error, -reporting that we could not allocate @var{what}. - -The value @var{olen} should be the old size of the block of memory at -@var{addr}; it is only used for keeping statistics on the size of the -heap. -@end deftypefun - -@deftypefun void scm_must_free (char *@var{addr}) -Free the block of memory at @var{addr}, using @code{free}. If -@var{addr} is zero, signal an error, complaining of an attempt to free -something that is already free. - -This does no record-keeping; instead, the smob's @code{free} function -must take care of that. - -This function isn't usually sufficiently different from the usual -@code{free} function to be worth using. -@end deftypefun - - -Continuing the above example, if the global variable @code{image_tag} -contains a tag returned by @code{scm_newsmob}, here is how we could -construct a smob whose @sc{cdr} contains a pointer to a freshly -allocated @code{struct image}: - -@example -struct image @{ - int width, height; - char *pixels; - - /* The name of this image */ - SCM name; - - /* A function to call when this image is - modified, e.g., to update the screen, - or SCM_BOOL_F if no action necessary */ - SCM update_func; -@}; - -SCM -make_image (SCM name, SCM s_width, SCM s_height) -@{ - struct image *image; - int width, height; - - SCM_ASSERT (SCM_NIMP (name) && SCM_STRINGP (name), name, - SCM_ARG1, "make-image"); - SCM_ASSERT (SCM_INUMP (s_width), s_width, SCM_ARG2, "make-image"); - SCM_ASSERT (SCM_INUMP (s_height), s_height, SCM_ARG3, "make-image"); - - width = SCM_INUM (s_width); - height = SCM_INUM (s_height); - - image = (struct image *) scm_must_malloc (sizeof (struct image), "image"); - image->width = width; - image->height = height; - image->pixels = scm_must_malloc (width * height, "image pixels"); - image->name = name; - image->update_func = SCM_BOOL_F; - - SCM_RETURN_NEWSMOB (image_tag, image); -@} -@end example - - -@node Typechecking, Garbage Collecting Smobs, Creating Instances, Defining New Types (Smobs) -@subsection Typechecking - -Functions that operate on smobs should aggressively check the types of -their arguments, to avoid misinterpreting some other datatype as a smob, -and perhaps causing a segmentation fault. Fortunately, this is pretty -simple to do. The function need only verify that its argument is a -non-immediate, whose @sc{car} is the type tag returned by -@code{scm_newsmob}. - -For example, here is a simple function that operates on an image smob, -and checks the type of its argument. We also present an expanded -version of the @code{init_image_type} function, to make -@code{clear_image} and the image constructor function @code{make_image} -visible to Scheme code. -@example -SCM -clear_image (SCM image_smob) -@{ - int area; - struct image *image; - - SCM_ASSERT (SCM_SMOB_PREDICATE (image_tag, image_smob), - image_smob, SCM_ARG1, "clear-image"); - - image = (struct image *) SCM_SMOB_DATA (image_smob); - area = image->width * image->height; - memset (image->pixels, 0, area); - - /* Invoke the image's update function. */ - if (image->update_func != SCM_BOOL_F) - scm_apply (image->update_func, SCM_EOL, SCM_EOL); - - return SCM_UNSPECIFIED; -@} - - -void -init_image_type () -@{ - image_tag = scm_newsmob (&image_funs); - - scm_make_gsubr ("make-image", 3, 0, 0, make_image); - scm_make_gsubr ("clear-image", 1, 0, 0, clear_image); -@} -@end example - -Note that checking types is a little more complicated during garbage -collection; see the description of @code{SCM_GCTYP16} in @ref{Garbage -Collecting Smobs}. - -@c GJB:FIXME:: should talk about guile-snarf somewhere! - -@node Garbage Collecting Smobs, A Common Mistake In Allocating Smobs, Typechecking, Defining New Types (Smobs) -@subsection Garbage Collecting Smobs - -Once a smob has been released to the tender mercies of the Scheme -system, it must be prepared to survive garbage collection. Guile calls -the @code{mark} and @code{free} functions of the @code{scm_smobfuns} -structure to manage this. - -As described before (@pxref{Garbage Collection}), every object in the -Scheme system has a @dfn{mark bit}, which the garbage collector uses to -tell live objects from dead ones. When collection starts, every -object's mark bit is clear. The collector traces pointers through the -heap, starting from objects known to be live, and sets the mark bit on -each object it encounters. When it can find no more unmarked objects, -the collector walks all objects, live and dead, frees those whose mark -bits are still clear, and clears the mark bit on the others. - -The two main portions of the collection are called the @dfn{mark phase}, -during which the collector marks live objects, and the @dfn{sweep -phase}, during which the collector frees all unmarked objects. - -The mark bit of a smob lives in its @sc{car}, along with the smob's type -tag. When the collector encounters a smob, it sets the smob's mark bit, -and uses the smob's type tag to find the appropriate @code{mark} -function for that smob: the one listed in that smob's -@code{scm_smobfuns} structure. It then calls the @code{mark} function, -passing it the smob as its only argument. - -The @code{mark} function is responsible for marking any other Scheme -objects the smob refers to. If it does not do so, the objects' mark -bits will still be clear when the collector begins to sweep, and the -collector will free them. If this occurs, it will probably break, or at -least confuse, any code operating on the smob; the smob's @code{SCM} -values will have become dangling references. - -To mark an arbitrary Scheme object, the @code{mark} function may call -this function: - -@deftypefun void scm_gc_mark (SCM @var{x}) -Mark the object @var{x}, and recurse on any objects @var{x} refers to. -If @var{x}'s mark bit is already set, return immediately. -@end deftypefun - -Thus, here is how we might write the @code{mark} function for the image -smob type discussed above: -@example -@group -SCM -mark_image (SCM image_smob) -@{ - /* Mark the image's name and update function. */ - struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); - - scm_gc_mark (image->name); - scm_gc_mark (image->update_func); - - return SCM_BOOL_F; -@} -@end group -@end example - -Note that, even though the image's @code{update_func} could be an -arbitrarily complex structure (representing a procedure and any values -enclosed in its environment), @code{scm_gc_mark} will recurse as -necessary to mark all its components. Because @code{scm_gc_mark} sets -an object's mark bit before it recurses, it is not confused by -circular structures. - -As an optimization, the collector will mark whatever value is returned -by the @code{mark} function; this helps limit depth of recursion during -the mark phase. Thus, the code above could also be written as: -@example -@group -SCM -mark_image (SCM image_smob) -@{ - /* Mark the image's name and update function. */ - struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); - - scm_gc_mark (image->name); - return image->update_func; -@} -@end group -@end example - - -Finally, when the collector encounters an unmarked smob during the sweep -phase, it uses the smob's tag to find the appropriate @code{free} -function for the smob. It then calls the function, passing it the smob -as its only argument. - -The @code{free} function must release any resources used by the smob. -However, it need not free objects managed by the collector; the -collector will take care of them. The return type of the @code{free} -function should be @code{scm_sizet}, an unsigned integral type; the -@code{free} function should return the number of bytes released, to help -the collector maintain statistics on the size of the heap. - -Here is how we might write the @code{free} function for the image smob -type: -@example -scm_sizet -free_image (SCM image_smob) -@{ - struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); - scm_sizet size = image->width * image->height + sizeof (*image); - - free (image->pixels); - free (image); - - return size; -@} -@end example - -During the sweep phase, the garbage collector will clear the mark bits -on all live objects. The code which implements a smob need not do this -itself. - -There is no way for smob code to be notified when collection is -complete. - -Note that, since a smob's mark bit lives in its @sc{car}, along with the -smob's type tag, the technique for checking the type of a smob described -in @ref{Typechecking} will not necessarily work during GC. If you need -to find out whether a given object is a particular smob type during GC, -use the following macro: - -@deftypefn Macro void SCM_GCTYP16 (SCM @var{x}) -Return the type bits of the smob @var{x}, with the mark bit clear. - -Use this macro instead of @code{SCM_CAR} to check the type of a smob -during GC. Usually, only code called by the smob's @code{mark} function -need worry about this. -@end deftypefn - -It is usually a good idea to minimize the amount of processing done -during garbage collection; keep @code{mark} and @code{free} functions -very simple. Since collections occur at unpredictable times, it is easy -for any unusual activity to interfere with normal code. - - -@node A Common Mistake In Allocating Smobs, Garbage Collecting Simple Smobs, Garbage Collecting Smobs, Defining New Types (Smobs) -@subsection A Common Mistake In Allocating Smobs - -When constructing new objects, you must be careful that the garbage -collector can always find any new objects you allocate. For example, -suppose we wrote the @code{make_image} function this way: - -@example -SCM -make_image (SCM name, SCM s_width, SCM s_height) -@{ - struct image *image; - SCM image_smob; - int width, height; - - SCM_ASSERT (SCM_NIMP (name) && SCM_STRINGP (name), name, - SCM_ARG1, "make-image"); - SCM_ASSERT (SCM_INUMP (s_width), s_width, SCM_ARG2, "make-image"); - SCM_ASSERT (SCM_INUMP (s_height), s_height, SCM_ARG3, "make-image"); - - width = SCM_INUM (s_width); - height = SCM_INUM (s_height); - - image = (struct image *) scm_must_malloc (sizeof (struct image), "image"); - image->width = width; - image->height = height; - image->pixels = scm_must_malloc (width * height, "image pixels"); - - /* THESE TWO LINES HAVE CHANGED: */ - image->name = scm_string_copy (name); - image->update_func = scm_make_gsubr (@dots{}); - - SCM_NEWCELL (image_smob); - SCM_SETCDR (image_smob, image); - SCM_SETCAR (image_smob, image_tag); - - return image_smob; -@} -@end example - -This code is incorrect. The calls to @code{scm_string_copy} and -@code{scm_make_gsubr} allocate fresh objects. Allocating any new object -may cause the garbage collector to run. If @code{scm_make_gsubr} -invokes a collection, the garbage collector has no way to discover that -@code{image->name} points to the new string object; the @code{image} -structure is not yet part of any Scheme object, so the garbage collector -will not traverse it. Since the garbage collector cannot find any -references to the new string object, it will free it, leaving -@code{image} pointing to a dead object. - -A correct implementation might say, instead: -@example - image->name = SCM_BOOL_F; - image->update_func = SCM_BOOL_F; - - SCM_NEWCELL (image_smob); - SCM_SETCDR (image_smob, image); - SCM_SETCAR (image_smob, image_tag); - - image->name = scm_string_copy (name); - image->update_func = scm_make_gsubr (@dots{}); - - return image_smob; -@end example - -Now, by the time we allocate the new string and function objects, -@code{image_smob} points to @code{image}. If the garbage collector -scans the stack, it will find a reference to @code{image_smob} and -traverse @code{image}, so any objects @code{image} points to will be -preserved. - - -@node Garbage Collecting Simple Smobs, A Complete Example, A Common Mistake In Allocating Smobs, Defining New Types (Smobs) -@subsection Garbage Collecting Simple Smobs - -It is often useful to define very simple smob types --- smobs which have -no data to mark, other than the cell itself, or smobs whose @sc{cdr} is -simply an ordinary Scheme object, to be marked recursively. Guile -provides some functions to handle these common cases; you can use these -functions as your smob type's @code{mark} function, if your smob's -structure is simple enough. - -If the smob refers to no other Scheme objects, then no action is -necessary; the garbage collector has already marked the smob cell -itself. In that case, you can use zero as your mark function. - -@deftypefun SCM scm_markcdr (SCM @var{x}) -Mark the references in the smob @var{x}, assuming that @var{x}'s -@sc{cdr} contains an ordinary Scheme object, and @var{x} refers to no -other objects. This function simply returns @var{x}'s @sc{cdr}. -@end deftypefun - -@deftypefun scm_sizet scm_free0 (SCM @var{x}) -Do nothing; return zero. This function is appropriate for smobs that -use either zero or @code{scm_markcdr} as their marking functions, and -refer to no heap storage, including memory managed by @code{malloc}, -other than the smob's header cell. -@end deftypefun - - -@node A Complete Example, , Garbage Collecting Simple Smobs, Defining New Types (Smobs) -@subsection A Complete Example - -Here is the complete text of the implementation of the image datatype, -as presented in the sections above. We also provide a definition for -the smob's @code{print} function, and make some objects and functions -static, to clarify exactly what the surrounding code is using. - -As mentioned above, you can find this code in the Guile distribution, in -@file{doc/example-smob}. That directory includes a makefile and a -suitable @code{main} function, so you can build a complete interactive -Guile shell, extended with the datatypes described here.) - -@example -/* file "image-type.c" */ - -#include -#include - -static long image_tag; - -struct image @{ - int width, height; - char *pixels; - - /* The name of this image */ - SCM name; - - /* A function to call when this image is - modified, e.g., to update the screen, - or SCM_BOOL_F if no action necessary */ - SCM update_func; -@}; - -static SCM -make_image (SCM name, SCM s_width, SCM s_height) -@{ - struct image *image; - SCM image_smob; - int width, height; - - SCM_ASSERT (SCM_NIMP (name) && SCM_STRINGP (name), name, - SCM_ARG1, "make-image"); - SCM_ASSERT (SCM_INUMP (s_width), s_width, SCM_ARG2, "make-image"); - SCM_ASSERT (SCM_INUMP (s_height), s_height, SCM_ARG3, "make-image"); - - width = SCM_INUM (s_width); - height = SCM_INUM (s_height); - - image = (struct image *) scm_must_malloc (sizeof (struct image), "image"); - image->width = width; - image->height = height; - image->pixels = scm_must_malloc (width * height, "image pixels"); - image->name = name; - image->update_func = SCM_BOOL_F; - - SCM_NEWSMOB (image_smob, image_tag, image); - - return image_smob; -@} - -static SCM -clear_image (SCM image_smob) -@{ - int area; - struct image *image; - - SCM_ASSERT (SCM_SMOB_PREDICATE (image_tag, image_smob), - image_smob, SCM_ARG1, "clear-image"); - - image = (struct image *) SCM_SMOB_DATA (image_smob); - area = image->width * image->height; - memset (image->pixels, 0, area); - - /* Invoke the image's update function. */ - if (image->update_func != SCM_BOOL_F) - scm_apply (image->update_func, SCM_EOL, SCM_EOL); - - return SCM_UNSPECIFIED; -@} - -static SCM -mark_image (SCM image_smob) -@{ - struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); - - scm_gc_mark (image->name); - return image->update_func; -@} - -static scm_sizet -free_image (SCM image_smob) -@{ - struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); - scm_sizet size = image->width * image->height + sizeof (struct image); - - free (image->pixels); - free (image); - - return size; -@} - -static int -print_image (SCM image_smob, SCM port, scm_print_state *pstate) -@{ - struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); - - scm_puts ("#name, port); - scm_puts (">", port); - - /* non-zero means success */ - return 1; -@} - -static scm_smobfuns image_funs = @{ - mark_image, free_image, print_image, 0 -@}; - -void -init_image_type () -@{ - image_tag = scm_newsmob (&image_funs); - - scm_make_gsubr ("clear-image", 1, 0, 0, clear_image); - scm_make_gsubr ("make-image", 3, 0, 0, make_image); -@} -@end example - -Here is a sample build and interaction with the code from the -@file{example-smob} directory, on the author's machine: - -@example -zwingli:example-smob$ make CC=gcc -gcc `guile-config compile` -c image-type.c -o image-type.o -gcc `guile-config compile` -c myguile.c -o myguile.o -gcc image-type.o myguile.o `guile-config link` -o myguile -zwingli:example-smob$ ./myguile -guile> make-image -# -guile> (define i (make-image "Whistler's Mother" 100 100)) -guile> i -# -guile> (clear-image i) -guile> (clear-image 4) -ERROR: In procedure clear-image in expression (clear-image 4): -ERROR: Wrong type argument in position 1: 4 -ABORT: (wrong-type-arg) - -Type "(backtrace)" to get more information. -guile> -@end example - -@bye From 14dd0e27c3e094000a8f4c851081c2df1aedce29 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 15 Feb 2001 22:54:40 +0000 Subject: [PATCH 0544/2047] * Remove data-rep.texi from Makefile.am. * Explain data-rep.texi retirement in README. --- doc/ChangeLog | 4 ++++ doc/Makefile.am | 2 -- doc/README | 19 +++++++++++-------- 3 files changed, 15 insertions(+), 10 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 180b948ef..6b36ebf49 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,5 +1,9 @@ 2001-02-15 Neil Jerram + * README: Explain retirement of `data-rep.texi'. + + * Makefile.am (info_TEXINFOS, data_rep_TEXINFOS): Removed. + * data-rep.texi: Replace this copy of data-rep.texi with a notice indicating that it has been retired. The master copy of data-rep.texi is at guile-doc/ref/data-rep.texi. diff --git a/doc/Makefile.am b/doc/Makefile.am index e98fae083..aecb266f2 100644 --- a/doc/Makefile.am +++ b/doc/Makefile.am @@ -18,8 +18,6 @@ ## License along with GUILE; see the file COPYING. If not, write ## to the Free Software Foundation, Inc., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA -info_TEXINFOS = data-rep.texi -data_rep_TEXINFOS = data-rep.texi version.texi # This rule overrides automake's rule for version.texi. It causes # version.texi to be created even in non-maintainer-mode. diff --git a/doc/README b/doc/README index 141b29876..47f120c4e 100644 --- a/doc/README +++ b/doc/README @@ -1,15 +1,18 @@ This directory contains documentation on the Guile core. At the moment, we don't have a full manual on Guile; that's at the -head of our task list. - -The file `data-rep.texi' is an essay on how to write C code that uses -Guile values. If you're interested in writing a application which is -extensible via Guile, this is a good place to start. Make builds the -`info' manual by default, designed to be read on-line; if you want to -print it out, go to the `doc' subdirectory of the tree you're building -in, and run `make data-rep.ps'. +head of our task list. You can see a snapshot of the new Guile +reference manual by checking out the `guile-doc' CVS module. The file `oldfmt.c' contains a function which can be used by application writers to support both old-style and new-style error format strings. + +The file `data-rep.texi', which used to be in this directory, is now +integrated into the Guile reference manual: the integrated version of +this essay is the `Data Representation' chapter. (This chapter is an +essay on how to write C code that uses Guile values. If you're +interested in writing a application which is extensible via Guile, +this is a good place to start.) To update the Texinfo source for this +essay - for example, when the smob interface changes - please update +the file `guile-doc/ref/data-rep.texi' in the guile-doc module. From e228a20323943a15d1023e093a8d129a5ee707b3 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 16 Feb 2001 00:57:11 +0000 Subject: [PATCH 0545/2047] * dump.c (scm_undump): Bug fixed. --- libguile/ChangeLog | 7 +++++++ libguile/dump.c | 10 +++++----- 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 2b5ce5b49..ebeb3cc1c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2001-02-15 Keisuke Nishida + + * dump.c (scm_undump): Use SCM_CARLOC/SCM_CDRLOC to obtain the + address of car/cdr. (Thanks to Dirk Herrmann) + Use scm_sizet to obtain the length of strings. + (Thanks to Matthias Koeppe) + 2001-02-15 Marius Vollmer * symbols.c (scm_mem2symbol): Put a empty statement after the diff --git a/libguile/dump.c b/libguile/dump.c index de0b46d63..12c42bd41 100644 --- a/libguile/dump.c +++ b/libguile/dump.c @@ -408,7 +408,7 @@ scm_dump (SCM obj, SCM dstate) case scm_tc7_vector: { int i; - int len = SCM_VECTOR_LENGTH (obj); + scm_bits_t len = SCM_VECTOR_LENGTH (obj); SCM *base = SCM_VELTS (obj); scm_store_word (scm_tc7_vector, dstate); scm_store_word (len, dstate); @@ -458,8 +458,8 @@ scm_undump (SCM dstate) { SCM_NEWCELL (obj); /* cdr was stored first */ - scm_restore_object ((SCM *) &SCM_CDR (obj), dstate); - scm_restore_object ((SCM *) &SCM_CAR (obj), dstate); + scm_restore_object (SCM_CDRLOC (obj), dstate); + scm_restore_object (SCM_CARLOC (obj), dstate); goto store_object; } @@ -467,7 +467,7 @@ scm_undump (SCM dstate) { case scm_tc7_symbol: { - int len; + scm_sizet len; const char *mem; scm_restore_string (&mem, &len, dstate); obj = scm_mem2symbol (mem, len); @@ -475,7 +475,7 @@ scm_undump (SCM dstate) } case scm_tc7_string: { - int len; + scm_sizet len; const char *mem; scm_restore_string (&mem, &len, dstate); obj = scm_makfromstr (mem, len, 0); From 0137a31b73db65302aa6081e1096faead7343f49 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 16 Feb 2001 14:53:55 +0000 Subject: [PATCH 0546/2047] (scm_lognot): Removed unnecessary "" from docstrings. (scm_sys_expt, scm_sys_atan2): Added docstrings. --- libguile/numbers.c | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 362a56514..5541aa5c0 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1081,8 +1081,7 @@ SCM_DEFINE (scm_lognot, "lognot", 1, 0, 0, " @result{} \"-10000001\"\n" "(number->string (lognot #b0) 2)\n" " @result{} \"-1\"\n" - "@end lisp\n" - "") + "@end lisp\n") #define FUNC_NAME s_scm_lognot { return scm_difference (SCM_MAKINUM (-1L), n); @@ -3980,7 +3979,8 @@ scm_two_doubles (SCM z1, SCM z2, const char *sstring, struct dpair *xy) SCM_DEFINE (scm_sys_expt, "$expt", 2, 0, 0, (SCM z1, SCM z2), - "") + "Return @var{z1} raised to the power or @var{z2}. This\n" + "procedure does not accept complex arguments.") #define FUNC_NAME s_scm_sys_expt { struct dpair xy; @@ -3992,7 +3992,11 @@ SCM_DEFINE (scm_sys_expt, "$expt", 2, 0, 0, SCM_DEFINE (scm_sys_atan2, "$atan2", 2, 0, 0, (SCM z1, SCM z2), - "") + "Return the arc tangent of the two arguments @var{z1} and\n" + "@var{z2}. This is similar to calculating the arc tangent of\n" + "@var{z1} / @var{z2}, except that the signs of both arguments\n" + "are used to determine the quadrant of the result. This\n" + "procedure does not accept complex arguments.") #define FUNC_NAME s_scm_sys_atan2 { struct dpair xy; From 64ba8e858ceb164f2034d39a1a98944c10350b0d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 16 Feb 2001 14:55:54 +0000 Subject: [PATCH 0547/2047] (scm_random, scm_random_normal, scm_random_solid_sphere_x, scm_random_hollow_sphere_x, scm_random_normal_vector_x, scm_random_exp): Removed unnecessary "" from docstrings. --- libguile/random.c | 18 ++++++------------ 1 file changed, 6 insertions(+), 12 deletions(-) diff --git a/libguile/random.c b/libguile/random.c index 2e342467e..73f8cfaf9 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -363,8 +363,7 @@ SCM_DEFINE (scm_random, "random", 1, 1, 0, "`seed->random-state'. It defaults to the value of the variable\n" "*random-state*. This object is used to maintain the state of\n" "the pseudo-random-number generator and is altered as a side\n" - "effect of the random operation.\n" - "") + "effect of the random operation.") #define FUNC_NAME s_scm_random { if (SCM_UNBNDP (state)) @@ -427,8 +426,7 @@ SCM_DEFINE (scm_random_normal, "random:normal", 0, 1, 0, "Returns an inexact real in a normal distribution.\n" "The distribution used has mean 0 and standard deviation 1.\n" "For a normal distribution with mean m and standard deviation\n" - "d use @code{(+ m (* d (random:normal)))}.\n" - "") + "d use @code{(+ m (* d (random:normal)))}.") #define FUNC_NAME s_scm_random_normal { if (SCM_UNBNDP (state)) @@ -484,8 +482,7 @@ SCM_DEFINE (scm_random_solid_sphere_x, "random:solid-sphere!", 1, 1, 0, "Thinking of vect as coordinates in space of \n" "dimension n = (vector-length vect), the coordinates \n" "are uniformly distributed within the unit n-shere.\n" - "The sum of the squares of the numbers is returned.\n" - "") + "The sum of the squares of the numbers is returned.") #define FUNC_NAME s_scm_random_solid_sphere_x { SCM_VALIDATE_VECTOR_OR_DVECTOR (1,v); @@ -508,8 +505,7 @@ SCM_DEFINE (scm_random_hollow_sphere_x, "random:hollow-sphere!", 1, 1, 0, "Thinking of vect as coordinates in space of \n" "dimension n = (vector-length vect), the coordinates\n" "are uniformly distributed over the surface of the \n" - "unit n-shere.\n" - "") + "unit n-shere.") #define FUNC_NAME s_scm_random_hollow_sphere_x { SCM_VALIDATE_VECTOR_OR_DVECTOR (1,v); @@ -527,8 +523,7 @@ SCM_DEFINE (scm_random_normal_vector_x, "random:normal-vector!", 1, 1, 0, (SCM v, SCM state), "Fills vect with inexact real random numbers that are\n" "independent and standard normally distributed\n" - "(i.e., with mean 0 and variance 1).\n" - "") + "(i.e., with mean 0 and variance 1).") #define FUNC_NAME s_scm_random_normal_vector_x { int n; @@ -552,8 +547,7 @@ SCM_DEFINE (scm_random_normal_vector_x, "random:normal-vector!", 1, 1, 0, SCM_DEFINE (scm_random_exp, "random:exp", 0, 1, 0, (SCM state), "Returns an inexact real in an exponential distribution with mean 1.\n" - "For an exponential distribution with mean u use (* u (random:exp)).\n" - "") + "For an exponential distribution with mean u use (* u (random:exp)).") #define FUNC_NAME s_scm_random_exp { if (SCM_UNBNDP (state)) From 156149ad1701dfddfae810ec46dff7218a156d8f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 16 Feb 2001 14:57:33 +0000 Subject: [PATCH 0548/2047] (scm_dynamic_wind): Removed unnecessary "" from docstrings. (scm_wind_chain): Added docstring. --- libguile/dynwind.c | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/libguile/dynwind.c b/libguile/dynwind.c index 4d951c3c5..647c044ab 100644 --- a/libguile/dynwind.c +++ b/libguile/dynwind.c @@ -113,8 +113,7 @@ SCM_DEFINE (scm_dynamic_wind, "dynamic-wind", 3, 0, 0, "@result{} normal-binding\n\n" "a-cont\n" "@result{} special-binding\n" - "@end example\n" - "") + "@end example\n") #define FUNC_NAME s_scm_dynamic_wind { SCM ans; @@ -172,7 +171,9 @@ scm_internal_dynamic_wind (scm_guard_t before, #ifdef GUILE_DEBUG SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0, (), - "") + "Return the current wind chain. The wind chain contains all\n" + "information required by @code{dynamic-wind} to call its\n" + "argument thunks when entering/exiting its scope.") #define FUNC_NAME s_scm_wind_chain { return scm_dynwinds; From 6bcefd15e3c49297b555e9eeab4b0ed55967a376 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 16 Feb 2001 14:59:22 +0000 Subject: [PATCH 0549/2047] (scm_sys_initialize_object, scm_instance_p, scm_class_name, scm_class_precedence_list, scm_class_slots, scm_class_environment, scm_generic_function_name, scm_generic_function_methods, scm_method_generic_function, scm_method_specializers, scm_method_procedure, scm_make_unbound, scm_unbound_p, scm_assert_bound, scm_at_assert_bound_ref, scm_sys_fast_slot_ref, scm_sys_fast_slot_set_x, scm_slot_ref, scm_slot_set_x, _scm_slot_bound_p, scm_slots_exists_p, scm_sys_allocate_instance, scm_make, scm_pure_generic_p, scm_class_direct_supers, scm_class_direct_slots, scm_class_direct_subclasses, scm_class_direct_methods, scm_accessor_method_slot_definition, scm_sys_goops_loaded): Added docstrings. --- libguile/goops.c | 69 +++++++++++++++++++++++++++--------------------- 1 file changed, 39 insertions(+), 30 deletions(-) diff --git a/libguile/goops.c b/libguile/goops.c index c43d0a196..aa7a00e15 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -393,7 +393,8 @@ static SCM set_slot_value (SCM class, SCM obj, SCM slotdef, SCM value); SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0, (SCM obj, SCM initargs), - "") + "Initialize the object @var{obj} with the given arguments\n" + "@var{initargs}.") #define FUNC_NAME s_scm_sys_initialize_object { SCM tmp, get_n_set, slots; @@ -778,7 +779,7 @@ create_basic_classes (void) SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0, (SCM obj), - "") + "Return @code{#t} if @var{obj} is an instance.") #define FUNC_NAME s_scm_instance_p { return SCM_BOOL (SCM_INSTANCEP (obj)); @@ -793,7 +794,7 @@ SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0, ******************************************************************************/ SCM_DEFINE (scm_class_name, "class-name", 1, 0, 0, (SCM obj), - "") + "Return the class name of @var{obj}.") #define FUNC_NAME s_scm_class_name { SCM_VALIDATE_CLASS (1, obj); @@ -803,7 +804,7 @@ SCM_DEFINE (scm_class_name, "class-name", 1, 0, 0, SCM_DEFINE (scm_class_direct_supers, "class-direct-supers", 1, 0, 0, (SCM obj), - "") + "Return the direct superclasses of the class @var{obj}.") #define FUNC_NAME s_scm_class_direct_supers { SCM_VALIDATE_CLASS (1, obj); @@ -813,7 +814,7 @@ SCM_DEFINE (scm_class_direct_supers, "class-direct-supers", 1, 0, 0, SCM_DEFINE (scm_class_direct_slots, "class-direct-slots", 1, 0, 0, (SCM obj), - "") + "Return the direct slots of the class @var{obj}.") #define FUNC_NAME s_scm_class_direct_slots { SCM_VALIDATE_CLASS (1, obj); @@ -823,7 +824,7 @@ SCM_DEFINE (scm_class_direct_slots, "class-direct-slots", 1, 0, 0, SCM_DEFINE (scm_class_direct_subclasses, "class-direct-subclasses", 1, 0, 0, (SCM obj), - "") + "Return the direct subclasses of the class @var{obj}.") #define FUNC_NAME s_scm_class_direct_subclasses { SCM_VALIDATE_CLASS (1, obj); @@ -833,7 +834,7 @@ SCM_DEFINE (scm_class_direct_subclasses, "class-direct-subclasses", 1, 0, 0, SCM_DEFINE (scm_class_direct_methods, "class-direct-methods", 1, 0, 0, (SCM obj), - "") + "Return the direct methods of the class @var{obj}") #define FUNC_NAME s_scm_class_direct_methods { SCM_VALIDATE_CLASS (1, obj); @@ -843,7 +844,7 @@ SCM_DEFINE (scm_class_direct_methods, "class-direct-methods", 1, 0, 0, SCM_DEFINE (scm_class_precedence_list, "class-precedence-list", 1, 0, 0, (SCM obj), - "") + "Return the class precedence list of the class @var{obj}.") #define FUNC_NAME s_scm_class_precedence_list { SCM_VALIDATE_CLASS (1, obj); @@ -853,7 +854,7 @@ SCM_DEFINE (scm_class_precedence_list, "class-precedence-list", 1, 0, 0, SCM_DEFINE (scm_class_slots, "class-slots", 1, 0, 0, (SCM obj), - "") + "Return the slot list of the class @var{obj}.") #define FUNC_NAME s_scm_class_slots { SCM_VALIDATE_CLASS (1, obj); @@ -863,7 +864,7 @@ SCM_DEFINE (scm_class_slots, "class-slots", 1, 0, 0, SCM_DEFINE (scm_class_environment, "class-environment", 1, 0, 0, (SCM obj), - "") + "Return the environment of the class @var{obj}.") #define FUNC_NAME s_scm_class_environment { SCM_VALIDATE_CLASS (1, obj); @@ -874,7 +875,7 @@ SCM_DEFINE (scm_class_environment, "class-environment", 1, 0, 0, SCM_DEFINE (scm_generic_function_name, "generic-function-name", 1, 0, 0, (SCM obj), - "") + "Return the name of the generic function @var{obj}.") #define FUNC_NAME s_scm_generic_function_name { SCM_VALIDATE_GENERIC (1, obj); @@ -884,7 +885,7 @@ SCM_DEFINE (scm_generic_function_name, "generic-function-name", 1, 0, 0, SCM_DEFINE (scm_generic_function_methods, "generic-function-methods", 1, 0, 0, (SCM obj), - "") + "Return the methods of the generic function @var{obj}.") #define FUNC_NAME s_scm_generic_function_methods { SCM_VALIDATE_GENERIC (1, obj); @@ -895,7 +896,7 @@ SCM_DEFINE (scm_generic_function_methods, "generic-function-methods", 1, 0, 0, SCM_DEFINE (scm_method_generic_function, "method-generic-function", 1, 0, 0, (SCM obj), - "") + "Return the generic function fot the method @var{obj}.") #define FUNC_NAME s_scm_method_generic_function { SCM_VALIDATE_METHOD (1, obj); @@ -905,7 +906,7 @@ SCM_DEFINE (scm_method_generic_function, "method-generic-function", 1, 0, 0, SCM_DEFINE (scm_method_specializers, "method-specializers", 1, 0, 0, (SCM obj), - "") + "Return specializers of the method @var{obj}.") #define FUNC_NAME s_scm_method_specializers { SCM_VALIDATE_METHOD (1, obj); @@ -915,7 +916,7 @@ SCM_DEFINE (scm_method_specializers, "method-specializers", 1, 0, 0, SCM_DEFINE (scm_method_procedure, "method-procedure", 1, 0, 0, (SCM obj), - "") + "Return the procedure of the method @var{obj}.") #define FUNC_NAME s_scm_method_procedure { SCM_VALIDATE_METHOD (1, obj); @@ -925,7 +926,7 @@ SCM_DEFINE (scm_method_procedure, "method-procedure", 1, 0, 0, SCM_DEFINE (scm_accessor_method_slot_definition, "accessor-method-slot-definition", 1, 0, 0, (SCM obj), - "") + "Return the slot definition of the accessor @var{obj}.") #define FUNC_NAME s_scm_accessor_method_slot_definition { SCM_VALIDATE_ACCESSOR (1, obj); @@ -942,7 +943,7 @@ SCM_DEFINE (scm_accessor_method_slot_definition, "accessor-method-slot-definitio SCM_DEFINE (scm_make_unbound, "make-unbound", 0, 0, 0, (), - "") + "Return the unbound value.") #define FUNC_NAME s_scm_make_unbound { return SCM_GOOPS_UNBOUND; @@ -951,7 +952,7 @@ SCM_DEFINE (scm_make_unbound, "make-unbound", 0, 0, 0, SCM_DEFINE (scm_unbound_p, "unbound?", 1, 0, 0, (SCM obj), - "") + "Return @code{#t} if @var{obj} is unbound.") #define FUNC_NAME s_scm_unbound_p { return SCM_GOOPS_UNBOUNDP (obj) ? SCM_BOOL_T : SCM_BOOL_F; @@ -960,7 +961,8 @@ SCM_DEFINE (scm_unbound_p, "unbound?", 1, 0, 0, SCM_DEFINE (scm_assert_bound, "assert-bound", 2, 0, 0, (SCM value, SCM obj), - "") + "Return @var{value} if it is bound, and invoke the\n" + "@var{slot-unbound} method of @var{obj} if it is not.") #define FUNC_NAME s_scm_assert_bound { if (SCM_GOOPS_UNBOUNDP (value)) @@ -971,7 +973,8 @@ SCM_DEFINE (scm_assert_bound, "assert-bound", 2, 0, 0, SCM_DEFINE (scm_at_assert_bound_ref, "@assert-bound-ref", 2, 0, 0, (SCM obj, SCM index), - "") + "Like @code{assert-bound}, but use @var{index} for accessing\n" + "the value from @var{obj}.") #define FUNC_NAME s_scm_at_assert_bound_ref { SCM value = SCM_SLOT (obj, SCM_INUM (index)); @@ -983,7 +986,7 @@ SCM_DEFINE (scm_at_assert_bound_ref, "@assert-bound-ref", 2, 0, 0, SCM_DEFINE (scm_sys_fast_slot_ref, "%fast-slot-ref", 2, 0, 0, (SCM obj, SCM index), - "") + "Return the slot value with index @var{index} from @var{obj}.") #define FUNC_NAME s_scm_sys_fast_slot_ref { register long i; @@ -999,7 +1002,8 @@ SCM_DEFINE (scm_sys_fast_slot_ref, "%fast-slot-ref", 2, 0, 0, SCM_DEFINE (scm_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0, (SCM obj, SCM index, SCM value), - "") + "Set the slot with index @var{index} in @var{obj} to\n" + "@var{value}.") #define FUNC_NAME s_scm_sys_fast_slot_set_x { register long i; @@ -1190,7 +1194,8 @@ SCM_DEFINE (scm_slot_exists_using_class_p, "slot-exists-using-class?", 3, 0, 0, SCM_DEFINE (scm_slot_ref, "slot-ref", 2, 0, 0, (SCM obj, SCM slot_name), - "") + "Return the value from @var{obj}'s slot with the name\n" + "@var{slot_name}.") #define FUNC_NAME s_scm_slot_ref { SCM res, class; @@ -1207,7 +1212,7 @@ SCM_DEFINE (scm_slot_ref, "slot-ref", 2, 0, 0, SCM_DEFINE (scm_slot_set_x, "slot-set!", 3, 0, 0, (SCM obj, SCM slot_name, SCM value), - "") + "Set the slot named @var{slot_name} of @var{obj} to @var{value}.") #define FUNC_NAME s_scm_slot_set_x { SCM class; @@ -1223,7 +1228,8 @@ const char *scm_s_slot_set_x = s_scm_slot_set_x; SCM_DEFINE (scm_slot_bound_p, "slot-bound?", 2, 0, 0, (SCM obj, SCM slot_name), - "") + "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n" + "is bound.") #define FUNC_NAME s_scm_slot_bound_p { SCM class; @@ -1241,7 +1247,7 @@ SCM_DEFINE (scm_slot_bound_p, "slot-bound?", 2, 0, 0, SCM_DEFINE (scm_slots_exists_p, "slot-exists?", 2, 0, 0, (SCM obj, SCM slot_name), - "") + "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.") #define FUNC_NAME s_scm_slots_exists_p { SCM class; @@ -1283,7 +1289,8 @@ wrap_init (SCM class, SCM *m, int n) SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0, (SCM class, SCM initargs), - "") + "Create a new instance of class @var{class} and initialize it\n" + "from the arguments @var{initargs}.") #define FUNC_NAME s_scm_sys_allocate_instance { SCM *m; @@ -1963,7 +1970,8 @@ SCM_KEYWORD (k_gf, "generic-function"); SCM_DEFINE (scm_make, "make", 0, 0, 1, (SCM args), - "") + "Make a new object. @var{args} mist contain the class and\n" + "all necessary initialization information.") #define FUNC_NAME s_scm_make { SCM class, z; @@ -2597,7 +2605,7 @@ scm_add_method (SCM gf, SCM m) SCM_DEFINE (scm_pure_generic_p, "pure-generic?", 1, 0, 0, (SCM obj), - "") + "Return @code{#t} if @var{obj} is a pure generic.") #define FUNC_NAME s_scm_pure_generic_p { return SCM_BOOL (SCM_PUREGENERICP (obj)); @@ -2612,7 +2620,8 @@ SCM_DEFINE (scm_pure_generic_p, "pure-generic?", 1, 0, 0, SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0, (), - "") + "Announce that GOOPS is loaded and perform initialization\n" + "on the C level which depends on the loaded GOOPS modules.") #define FUNC_NAME s_scm_sys_goops_loaded { goops_loaded_p = 1; From ba94f79e5907ece639bfdfbf686c30b586e49cfe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 16 Feb 2001 15:00:41 +0000 Subject: [PATCH 0550/2047] (scm_with_traps, scm_memoized_p, scm_make_gloc, scm_gloc_p, scm_make_iloc, scm_iloc_p, scm_memcons, scm_mem_to_proc, scm_proc_to_mem, scm_unmemoize, scm_memoized_environment, scm_procedure_name, scm_procedure_source, scm_procedure_environment, scm_debug_hang): Added docstrings. --- libguile/debug.c | 41 ++++++++++++++++++++++++----------------- 1 file changed, 24 insertions(+), 17 deletions(-) diff --git a/libguile/debug.c b/libguile/debug.c index d0600ea22..6fbb08764 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -76,7 +76,9 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0, (SCM setting), -"") + "Option interface for the debug options. Instead of using\n" + "this procedure directly, use the procedures @code{debug-enable},\n" + "@code{debug-disable}, @code{debug-set!} and @var{debug-options}.") #define FUNC_NAME s_scm_debug_options { SCM ans; @@ -124,7 +126,7 @@ with_traps_inner (void *data) SCM_DEFINE (scm_with_traps, "with-traps", 1, 0, 0, (SCM thunk), -"") + "Call @var{thunk} with traps enabled.") #define FUNC_NAME s_scm_with_traps { int trap_flag; @@ -166,7 +168,7 @@ memoized_print (SCM obj, SCM port, scm_print_state *pstate) SCM_DEFINE (scm_memoized_p, "memoized?", 1, 0, 0, (SCM obj), -"") + "Return @code{#t} if @var{obj} is memoized.") #define FUNC_NAME s_scm_memoized_p { return SCM_BOOL(SCM_MEMOIZEDP (obj)); @@ -255,7 +257,8 @@ scm_make_memoized (SCM exp, SCM env) SCM_DEFINE (scm_make_gloc, "make-gloc", 1, 1, 0, (SCM var, SCM env), -"") + "Create a gloc for variable @var{var} in the environment\n" + "@var{env}.") #define FUNC_NAME s_scm_make_gloc { #if 1 /* Unsafe */ @@ -274,7 +277,7 @@ SCM_DEFINE (scm_make_gloc, "make-gloc", 1, 1, 0, SCM_DEFINE (scm_gloc_p, "gloc?", 1, 0, 0, (SCM obj), -"") + "Return @code{#t} if @var{obj} is a gloc.") #define FUNC_NAME s_scm_gloc_p { return SCM_BOOL((SCM_MEMOIZEDP (obj) @@ -284,7 +287,8 @@ SCM_DEFINE (scm_gloc_p, "gloc?", 1, 0, 0, SCM_DEFINE (scm_make_iloc, "make-iloc", 3, 0, 0, (SCM frame, SCM binding, SCM cdrp), -"") + "Return a new iloc with frame offset @var{frame}, binding\n" + "offset @var{binding} and the cdr flag @var{cdrp}.") #define FUNC_NAME s_scm_make_iloc { SCM_VALIDATE_INUM (1,frame); @@ -298,7 +302,7 @@ SCM_DEFINE (scm_make_iloc, "make-iloc", 3, 0, 0, SCM_DEFINE (scm_iloc_p, "iloc?", 1, 0, 0, (SCM obj), -"") + "Return @code{#t} if @var{obj} is an iloc.") #define FUNC_NAME s_scm_iloc_p { return SCM_BOOL(SCM_ILOCP (obj)); @@ -307,7 +311,8 @@ SCM_DEFINE (scm_iloc_p, "iloc?", 1, 0, 0, SCM_DEFINE (scm_memcons, "memcons", 2, 1, 0, (SCM car, SCM cdr, SCM env), -"") + "Return a new memoized cons cell with @var{car} and @var{cdr}\n" + "as members and @var{env} as the environment.") #define FUNC_NAME s_scm_memcons { if (SCM_MEMOIZEDP (car)) @@ -339,7 +344,8 @@ SCM_DEFINE (scm_memcons, "memcons", 2, 1, 0, SCM_DEFINE (scm_mem_to_proc, "mem->proc", 1, 0, 0, (SCM obj), -"") + "Convert a memoized object (which must be a lambda expression)\n" + "to a procedure.") #define FUNC_NAME s_scm_mem_to_proc { SCM env; @@ -355,7 +361,7 @@ SCM_DEFINE (scm_mem_to_proc, "mem->proc", 1, 0, 0, SCM_DEFINE (scm_proc_to_mem, "proc->mem", 1, 0, 0, (SCM obj), -"") + "Convert a procedure to a memoized object.") #define FUNC_NAME s_scm_proc_to_mem { SCM_VALIDATE_CLOSURE (1, obj); @@ -368,7 +374,7 @@ SCM_DEFINE (scm_proc_to_mem, "proc->mem", 1, 0, 0, SCM_DEFINE (scm_unmemoize, "unmemoize", 1, 0, 0, (SCM m), -"") + "Unmemoize the memoized expression @var{m},") #define FUNC_NAME s_scm_unmemoize { SCM_VALIDATE_MEMOIZED (1,m); @@ -378,7 +384,7 @@ SCM_DEFINE (scm_unmemoize, "unmemoize", 1, 0, 0, SCM_DEFINE (scm_memoized_environment, "memoized-environment", 1, 0, 0, (SCM m), -"") + "Return the environment of the memoized expression @var{m}.") #define FUNC_NAME s_scm_memoized_environment { SCM_VALIDATE_MEMOIZED (1,m); @@ -388,7 +394,7 @@ SCM_DEFINE (scm_memoized_environment, "memoized-environment", 1, 0, 0, SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0, (SCM proc), -"") + "Return the name of the procedure @var{proc}") #define FUNC_NAME s_scm_procedure_name { SCM_VALIDATE_PROC (1,proc); @@ -414,7 +420,7 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0, SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0, (SCM proc), -"") + "Return the source of the procedure @var{proc}.") #define FUNC_NAME s_scm_procedure_source { SCM_VALIDATE_NIM (1,proc); @@ -448,7 +454,7 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0, SCM_DEFINE (scm_procedure_environment, "procedure-environment", 1, 0, 0, (SCM proc), -"") + "Return the environment of the procedure @var{proc}.") #define FUNC_NAME s_scm_procedure_environment { SCM_VALIDATE_NIM (1,proc); @@ -567,7 +573,7 @@ debugobj_print (SCM obj, SCM port, scm_print_state *pstate) SCM_DEFINE (scm_debug_object_p, "debug-object?", 1, 0, 0, (SCM obj), - "") + "Return @code{#t} if @var{obj} is a debug object.") #define FUNC_NAME s_scm_debug_object_p { return SCM_BOOL(SCM_DEBUGOBJP (obj)); @@ -593,7 +599,8 @@ scm_make_debugobj (scm_debug_frame *frame) #ifdef GUILE_DEBUG SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0, (SCM obj), - "") + "Go into an endless loop, which can be only terminated with\n" + "a debugger.") #define FUNC_NAME s_scm_debug_hang { int go = 0; From 99ca0a7fd1f9b4856a15a8453f7c0ed21add5369 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 16 Feb 2001 15:02:35 +0000 Subject: [PATCH 0551/2047] (scm_class_of, scm_entity_p, scm_operator_p, scm_set_object_procedure_x, scm_object_procedure, scm_make_class_object): Added docstrings. --- libguile/objects.c | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/libguile/objects.c b/libguile/objects.c index 812e9594e..c5ddb0538 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -85,7 +85,7 @@ SCM scm_no_applicable_method; /* This function is used for efficient type dispatch. */ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, (SCM x), - "") + "Return the class of @var{x}.") #define FUNC_NAME s_scm_class_of { switch (SCM_ITAG3 (x)) @@ -356,7 +356,7 @@ scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3) SCM_DEFINE (scm_entity_p, "entity?", 1, 0, 0, (SCM obj), -"") + "Return @code{#t} if @var{obj} is an entity.") #define FUNC_NAME s_scm_entity_p { return SCM_BOOL(SCM_STRUCTP (obj) && SCM_I_ENTITYP (obj)); @@ -365,7 +365,7 @@ SCM_DEFINE (scm_entity_p, "entity?", 1, 0, 0, SCM_DEFINE (scm_operator_p, "operator?", 1, 0, 0, (SCM obj), -"") + "Return @code{#t} if @var{obj} is an operator.") #define FUNC_NAME s_scm_operator_p { return SCM_BOOL(SCM_STRUCTP (obj) @@ -376,7 +376,8 @@ SCM_DEFINE (scm_operator_p, "operator?", 1, 0, 0, SCM_DEFINE (scm_set_object_procedure_x, "set-object-procedure!", 2, 0, 0, (SCM obj, SCM proc), -"") + "Return the object procedure of @var{obj} to @var{proc}.\n" + "@var{obj} must be either an entity or an operator.") #define FUNC_NAME s_scm_set_object_procedure_x { SCM_ASSERT (SCM_STRUCTP (obj) @@ -399,7 +400,8 @@ SCM_DEFINE (scm_set_object_procedure_x, "set-object-procedure!", 2, 0, 0, #ifdef GUILE_DEBUG SCM_DEFINE (scm_object_procedure, "object-procedure", 1, 0, 0, (SCM obj), -"") + "Return the object procedure of @var{obj}. @var{obj} must be\n" + "an entity or an operator.") #define FUNC_NAME s_scm_object_procedure { SCM_ASSERT (SCM_STRUCTP (obj) @@ -434,7 +436,8 @@ scm_i_make_class_object (SCM meta, SCM_DEFINE (scm_make_class_object, "make-class-object", 2, 0, 0, (SCM metaclass, SCM layout), -"") + "Create a new class object of class @var{metaclass}, with the\n" + "slot layout specified by @var{layout}.") #define FUNC_NAME s_scm_make_class_object { unsigned long flags = 0; @@ -448,7 +451,8 @@ SCM_DEFINE (scm_make_class_object, "make-class-object", 2, 0, 0, SCM_DEFINE (scm_make_subclass_object, "make-subclass-object", 2, 0, 0, (SCM class, SCM layout), -"") + "Create a subclass object of @var{class}, with the slot layout\n" + "specified by @var{layout}.") #define FUNC_NAME s_scm_make_subclass_object { SCM pl; From 8d1b3ae9ade832790ff7537559afba19d4a33d69 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 16 Feb 2001 15:04:23 +0000 Subject: [PATCH 0552/2047] (scm_make_hook_with_name, scm_make_hook, scm_hook_p, scm_hook_empty_p, scm_add_hook_x, scm_remove_hook_x, scm_reset_hook_x, scm_run_hook, scm_hook_to_list): Added docstrings. --- libguile/hooks.c | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/libguile/hooks.c b/libguile/hooks.c index 47437f7e9..6fb1e63f8 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -212,7 +212,8 @@ scm_create_hook (const char* name, int n_args) SCM_DEFINE (scm_make_hook_with_name, "make-hook-with-name", 1, 1, 0, (SCM name, SCM n_args), -"") + "Create a named hook with the name @var{name} for storing\n" + "procedures of arity @var{n_args}.") #define FUNC_NAME s_scm_make_hook_with_name { SCM hook = make_hook (n_args, FUNC_NAME); @@ -226,7 +227,7 @@ SCM_DEFINE (scm_make_hook_with_name, "make-hook-with-name", 1, 1, 0, SCM_DEFINE (scm_make_hook, "make-hook", 0, 1, 0, (SCM n_args), -"") + "Create a hook for storing procedure of arity @var{n_args}.") #define FUNC_NAME s_scm_make_hook { return make_hook (n_args, FUNC_NAME); @@ -236,7 +237,7 @@ SCM_DEFINE (scm_make_hook, "make-hook", 0, 1, 0, SCM_DEFINE (scm_hook_p, "hook?", 1, 0, 0, (SCM x), -"") + "Return @code{#t} if @var{x} is a hook.") #define FUNC_NAME s_scm_hook_p { return SCM_BOOL (SCM_HOOKP (x)); @@ -246,7 +247,7 @@ SCM_DEFINE (scm_hook_p, "hook?", 1, 0, 0, SCM_DEFINE (scm_hook_empty_p, "hook-empty?", 1, 0, 0, (SCM hook), -"") + "Return @code{#t} if @var{hook} is an empty hook.") #define FUNC_NAME s_scm_hook_empty_p { SCM_VALIDATE_HOOK (1, hook); @@ -257,7 +258,9 @@ SCM_DEFINE (scm_hook_empty_p, "hook-empty?", 1, 0, 0, SCM_DEFINE (scm_add_hook_x, "add-hook!", 2, 1, 0, (SCM hook, SCM proc, SCM append_p), -"") + "Add the procedure @var{proc} to the hook @var{hook}. The\n" + "procedure is added to the end if @var{append_p} is true,\n" + "otherwise it is added to the front.") #define FUNC_NAME s_scm_add_hook_x { SCM arity, rest; @@ -283,7 +286,7 @@ SCM_DEFINE (scm_add_hook_x, "add-hook!", 2, 1, 0, SCM_DEFINE (scm_remove_hook_x, "remove-hook!", 2, 0, 0, (SCM hook, SCM proc), -"") + "Remove the procedure @var{proc} from the hook @var{hook}.") #define FUNC_NAME s_scm_remove_hook_x { SCM_VALIDATE_HOOK (1, hook); @@ -296,7 +299,7 @@ SCM_DEFINE (scm_remove_hook_x, "remove-hook!", 2, 0, 0, SCM_DEFINE (scm_reset_hook_x, "reset-hook!", 1, 0, 0, (SCM hook), -"") + "Remove all procedures from the hook @var{hook}.") #define FUNC_NAME s_scm_reset_hook_x { SCM_VALIDATE_HOOK (1,hook); @@ -308,7 +311,8 @@ SCM_DEFINE (scm_reset_hook_x, "reset-hook!", 1, 0, 0, SCM_DEFINE (scm_run_hook, "run-hook", 1, 0, 1, (SCM hook, SCM args), -"") + "Apply all procedures from the hook @var{hook} to the arguments\n" + "@var{args}.") #define FUNC_NAME s_scm_run_hook { SCM_VALIDATE_HOOK (1,hook); @@ -335,7 +339,7 @@ scm_c_run_hook (SCM hook, SCM args) SCM_DEFINE (scm_hook_to_list, "hook->list", 1, 0, 0, (SCM hook), -"") + "Convert the procedure list of @var{hook} to a list.") #define FUNC_NAME s_scm_hook_to_list { SCM_VALIDATE_HOOK (1, hook); From 950ba52d9ea912fe4544692311cf0282fbb0ab39 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 16 Feb 2001 15:05:38 +0000 Subject: [PATCH 0553/2047] (scm_nil_cons, scm_nil_car, scm_nil_cdr, scm_null, scm_nil_eq): Added docstrings. --- libguile/lang.c | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/libguile/lang.c b/libguile/lang.c index e2c00d177..82378e0ff 100644 --- a/libguile/lang.c +++ b/libguile/lang.c @@ -66,7 +66,9 @@ SCM_DEFINE (scm_nil_cons, "nil-cons", 2, 0, 0, (SCM x, SCM y), -"") + "Create a new cons cell with @var{x} as the car and @var{y} as\n" + "the cdr, but convert @var{y} to Scheme's end-of-list if it is\n" + "a LISP nil.") #define FUNC_NAME s_scm_nil_cons { register SCM z; @@ -80,7 +82,8 @@ SCM_DEFINE (scm_nil_cons, "nil-cons", 2, 0, 0, SCM_DEFINE (scm_nil_car, "nil-car", 1, 0, 0, (SCM x), -"") + "Return the car of @var{x}, but convert it to LISP nil if it\n" + "is Scheme's end-of-list.") #define FUNC_NAME s_scm_nil_car { if (SCM_NILP (x)) @@ -92,7 +95,8 @@ SCM_DEFINE (scm_nil_car, "nil-car", 1, 0, 0, SCM_DEFINE (scm_nil_cdr, "nil-cdr", 1, 0, 0, (SCM x), -"") + "Return the cdr of @var{x}, but convert it to LISP nil if it\n" + "is Scheme's end-of-list.") #define FUNC_NAME s_scm_nil_cdr { if (SCM_NILP (x)) @@ -106,7 +110,8 @@ SCM_DEFINE (scm_nil_cdr, "nil-cdr", 1, 0, 0, Could use SCM_BOOL, below, otherwise */ SCM_DEFINE (scm_null, "null", 1, 0, 0, (SCM x), -"") + "Return LISP's @code{t} if @var{x} is nil in the LISP sense,\n" + "return LISP's nil otherwise.") #define FUNC_NAME s_scm_null { return (SCM_NILP (x) || SCM_NULLP (x) || SCM_FALSEP (x)) ? scm_lisp_t : scm_lisp_nil; @@ -134,7 +139,8 @@ scm_m_while (SCM exp, SCM env) Could use SCM_BOOL, below, otherwise */ SCM_DEFINE1 (scm_nil_eq, "nil-eq", scm_tc7_rpsubr, (SCM x, SCM y), -"") + "Compare @var{x} and @var{y} and return LISP's t if they are\n" + "@code{eq?}, return LISP's nil otherwise.") #define FUNC_NAME s_scm_nil_eq { return ((SCM_EQ_P (x, y) From 713311884eb8e0fc5c6bb1c2113c96c68c534e4e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 16 Feb 2001 15:07:52 +0000 Subject: [PATCH 0554/2047] (scm_print_options, scm_port_with_print_state, scm_get_print_state): Added docstrings. --- libguile/print.c | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/libguile/print.c b/libguile/print.c index c7fa4b157..20bcad6c9 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -135,7 +135,9 @@ scm_option scm_print_opts[] = { SCM_DEFINE (scm_print_options, "print-options-interface", 0, 1, 0, (SCM setting), -"") + "Option interface for the print options. Instead of using\n" + "this procedure directly, use the procedures @code{print-enable},\n" + "@code{print-disable}, @code{print-set!} and @var{print-options}.") #define FUNC_NAME s_scm_print_options { SCM ans = scm_options (setting, @@ -1101,7 +1103,8 @@ scm_printer_apply (SCM proc, SCM exp, SCM port, scm_print_state *pstate) SCM_DEFINE (scm_port_with_print_state, "port-with-print-state", 2, 0, 0, (SCM port, SCM pstate), - "") + "Create a new port which behaves like @var{port}, but with an\n" + "included print state @var{pstate}.") #define FUNC_NAME s_scm_port_with_print_state { SCM pwps; @@ -1115,7 +1118,8 @@ SCM_DEFINE (scm_port_with_print_state, "port-with-print-state", 2, 0, 0, SCM_DEFINE (scm_get_print_state, "get-print-state", 1, 0, 0, (SCM port), - "") + "Return the print state of the port @var{port}. If @var{port}\n" + "has no associated print state, @code{#f} is returned.") #define FUNC_NAME s_scm_get_print_state { if (SCM_PORT_WITH_PS_P (port)) From 8cf97abf9116ead70a954b3c2506d3f0f2c05b76 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 16 Feb 2001 15:09:10 +0000 Subject: [PATCH 0555/2047] (scm_make_cclo, scm_procedure_p, scm_closure_p, scm_thunk_p, scm_procedure_with_setter_p, scm_make_procedure_with_setter, scm_procedure): Added docstrings. --- libguile/procs.c | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/libguile/procs.c b/libguile/procs.c index d1279a21a..44a869bfb 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -179,7 +179,8 @@ scm_makcclo (SCM proc, long len) #ifdef GUILE_DEBUG SCM_DEFINE (scm_make_cclo, "make-cclo", 2, 0, 0, (SCM proc, SCM len), -"") + "Create a compiled closure for @var{proc}, which reserves\n" + "@var{len} objects for its usage.") #define FUNC_NAME s_scm_make_cclo { return scm_makcclo (proc, SCM_INUM (len)); @@ -191,8 +192,8 @@ SCM_DEFINE (scm_make_cclo, "make-cclo", 2, 0, 0, SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0, - (SCM obj), -"") + (SCM obj), + "Return @code{#t} if @var{obj} is a procedure.") #define FUNC_NAME s_scm_procedure_p { if (SCM_NIMP (obj)) @@ -219,7 +220,7 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0, SCM_DEFINE (scm_closure_p, "closure?", 1, 0, 0, (SCM obj), -"") + "Return @code{#t} if @var{obj} is a closure.") #define FUNC_NAME s_scm_closure_p { return SCM_BOOL(SCM_CLOSUREP (obj)); @@ -227,8 +228,8 @@ SCM_DEFINE (scm_closure_p, "closure?", 1, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0, - (SCM obj), -"") + (SCM obj), + "Return @code{#t} if @var{obj} is a thunk.") #define FUNC_NAME s_scm_thunk_p { if (SCM_NIMP (obj)) @@ -314,7 +315,8 @@ SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0, SCM_DEFINE (scm_procedure_with_setter_p, "procedure-with-setter?", 1, 0, 0, (SCM obj), - "") + "Return @code{#t} if @var{obj} is a procedure with an\n" + "associated setter procedure.") #define FUNC_NAME s_scm_procedure_with_setter_p { return SCM_BOOL(SCM_PROCEDURE_WITH_SETTER_P (obj)); @@ -323,7 +325,8 @@ SCM_DEFINE (scm_procedure_with_setter_p, "procedure-with-setter?", 1, 0, 0, SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0, 0, (SCM procedure, SCM setter), - "") + "Create a new procedure which behaves like @var{procedure}, but\n" + "with the associated setter @var{setter}.") #define FUNC_NAME s_scm_make_procedure_with_setter { SCM z; @@ -341,7 +344,8 @@ SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0, SCM_DEFINE (scm_procedure, "procedure", 1, 0, 0, (SCM proc), - "") + "Return the procedure of @var{proc}, which must be either a\n" + "procedure with setter, or an operator struct.") #define FUNC_NAME s_scm_procedure { SCM_VALIDATE_NIM (1, proc); From 0b3e0adb05549de855ac1fb7d42689e28e04ba52 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 16 Feb 2001 15:10:12 +0000 Subject: [PATCH 0556/2047] (scm_lazy_catch): Added docstring. --- libguile/throw.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/libguile/throw.c b/libguile/throw.c index faf2040ab..a1060595c 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -551,7 +551,9 @@ SCM_DEFINE (scm_catch, "catch", 3, 0, 0, SCM_DEFINE (scm_lazy_catch, "lazy-catch", 3, 0, 0, (SCM tag, SCM thunk, SCM handler), - "") + "This behaves exactly like @code{catch}, except that it does\n" + "not unwind the stack (this is the major difference), and if\n" + "handler returns, its value is returned from the throw.") #define FUNC_NAME s_scm_lazy_catch { struct scm_body_thunk_data c; From 84526793a760f47dac3a56d329f7a3eae6a55391 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 16 Feb 2001 15:11:11 +0000 Subject: [PATCH 0557/2047] (scm_standard_eval_closure): Added docstring. --- libguile/modules.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/modules.c b/libguile/modules.c index cae2d1747..8e2edb1e3 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -268,7 +268,7 @@ scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep) SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0, (SCM module), - "") + "Return an eval closure for the module @var{module}.") #define FUNC_NAME s_scm_standard_eval_closure { SCM_RETURN_NEWSMOB (scm_tc16_eval_closure, SCM_UNPACK (module)); From d91788cb72c84dccefda3911995e0b0e3e0f1e08 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 16 Feb 2001 15:12:26 +0000 Subject: [PATCH 0558/2047] (scm_parse_path, scm_search_path): Added docstrings. --- libguile/load.c | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/libguile/load.c b/libguile/load.c index 9c7d00675..71a661d37 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -224,7 +224,10 @@ scm_internal_parse_path (char *path, SCM tail) SCM_DEFINE (scm_parse_path, "parse-path", 1, 1, 0, (SCM path, SCM tail), - "") + "Parse @var{path}, which is expected to be a colon-separated\n" + "string, into a list and return the resulting list with\n" + "@var{tail} appended. If @var{path} is @code{#f}, @var{tail}\n" + "is returned.") #define FUNC_NAME s_scm_parse_path { SCM_ASSERT (SCM_FALSEP (path) || (SCM_STRINGP (path)), @@ -269,7 +272,13 @@ SCM scm_listofnullstr; in PATH, we search for FILENAME concatenated with each EXTENSION. */ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, (SCM path, SCM filename, SCM extensions), - "") + "Search @var{path} for a directory containing a file named\n" + "@var{filename}. The file must be readable, and not a directory.\n" + "If we find one, return its full filename; otherwise, return\n" + "@code{#f}. If @var{filename} is absolute, return it unchanged.\n" + "If given, @var{extensions} is a list of strings; for each\n" + "directory in @var{path}, we search for @var{filename}\n" + "concatenated with each @var{extension}.") #define FUNC_NAME s_scm_search_path { char *filename_chars; From 67941e3cb54bf9cb1d6db30000307f148405730a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 16 Feb 2001 15:14:10 +0000 Subject: [PATCH 0559/2047] (scm_make_stack, scm_stack_ref, scm_stack_length, scm_frame_p, scm_last_stack_frame, scm_frame_number, scm_frame_source, scm_frame_procedure, scm_frame_arguments, scm_frame_previous, scm_frame_next, scm_frame_real_p, scm_frame_procedure_p, scm_frame_evaluating_args_p, scm_frame_overflow_p): Added docstrings. --- libguile/stacks.c | 62 +++++++++++++++++++++++++++-------------------- 1 file changed, 36 insertions(+), 26 deletions(-) diff --git a/libguile/stacks.c b/libguile/stacks.c index 2a61e92e2..91051f2c9 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -414,7 +414,12 @@ SCM_DEFINE (scm_stack_p, "stack?", 1, 0, 0, SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, (SCM obj, SCM args), - "") + "Create a new stack. If @var{obj} is @code{#t}, the current\n" + "evaluation stack is used for creating the stack frames,\n" + "otherwise the frames are taken from @var{obj} (which must be\n" + "either a debug object or a continuation).\n" + "@var{args} must be a list if integers and specifies how the\n" + "resulting stack will be narrowed.") #define FUNC_NAME s_scm_make_stack { int n, maxp, size; @@ -541,7 +546,7 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0, SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0, (SCM stack, SCM i), - "") + "Return the @var{i}'th frame from @var{stack}.") #define FUNC_NAME s_scm_stack_ref { SCM_VALIDATE_STACK (1,stack); @@ -554,8 +559,8 @@ SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0, - (SCM stack), - "") + (SCM stack), + "Return the length of @var{stack}.") #define FUNC_NAME s_scm_stack_length { SCM_VALIDATE_STACK (1,stack); @@ -568,7 +573,7 @@ SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0, SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0, (SCM obj), - "") + "Return @code{#t} if @var{obj} is a stack frame.") #define FUNC_NAME s_scm_frame_p { return SCM_BOOL(SCM_FRAMEP (obj)); @@ -576,8 +581,10 @@ SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0, - (SCM obj), - "") + (SCM obj), + "Return a stack which consists of a single frame, which is the\n" + "last stack frame for @var{obj}. @var{obj} must be either a\n" + "debug object or a continuation.") #define FUNC_NAME s_scm_last_stack_frame { scm_debug_frame *dframe; @@ -617,8 +624,8 @@ SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_frame_number, "frame-number", 1, 0, 0, - (SCM frame), - "") + (SCM frame), + "Return the frame number of @var{frame}.") #define FUNC_NAME s_scm_frame_number { SCM_VALIDATE_FRAME (1,frame); @@ -627,8 +634,8 @@ SCM_DEFINE (scm_frame_number, "frame-number", 1, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0, - (SCM frame), - "") + (SCM frame), + "Return the source of @var{frame}.") #define FUNC_NAME s_scm_frame_source { SCM_VALIDATE_FRAME (1,frame); @@ -637,8 +644,9 @@ SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0, - (SCM frame), - "") + (SCM frame), + "Return the procedure for @var{frame}, or @code{#f} if no\n" + "procedure is associated with @var{frame}.") #define FUNC_NAME s_scm_frame_procedure { SCM_VALIDATE_FRAME (1,frame); @@ -649,8 +657,8 @@ SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0, - (SCM frame), - "") + (SCM frame), + "Return the arguments of @var{frame}.") #define FUNC_NAME s_scm_frame_arguments { SCM_VALIDATE_FRAME (1,frame); @@ -659,8 +667,9 @@ SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0, - (SCM frame), - "") + (SCM frame), + "Return the previous frame of @var{frame}, or @code{#f} if\n" + "@var{frame} is the first frame in its stack.") #define FUNC_NAME s_scm_frame_previous { int n; @@ -675,7 +684,8 @@ SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0, SCM_DEFINE (scm_frame_next, "frame-next", 1, 0, 0, (SCM frame), - "") + "Return the next frame of @var{frame}, or @code{#f} if\n" + "@var{frame} is the last frame in its stack.") #define FUNC_NAME s_scm_frame_next { int n; @@ -689,8 +699,8 @@ SCM_DEFINE (scm_frame_next, "frame-next", 1, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_frame_real_p, "frame-real?", 1, 0, 0, - (SCM frame), - "") + (SCM frame), + "Return @code{#t} if @var{frame} is a real frame.") #define FUNC_NAME s_scm_frame_real_p { SCM_VALIDATE_FRAME (1,frame); @@ -699,8 +709,8 @@ SCM_DEFINE (scm_frame_real_p, "frame-real?", 1, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_frame_procedure_p, "frame-procedure?", 1, 0, 0, - (SCM frame), - "") + (SCM frame), + "Return @code{#t} if a procedure is associated with @var{frame}.") #define FUNC_NAME s_scm_frame_procedure_p { SCM_VALIDATE_FRAME (1,frame); @@ -709,8 +719,8 @@ SCM_DEFINE (scm_frame_procedure_p, "frame-procedure?", 1, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_frame_evaluating_args_p, "frame-evaluating-args?", 1, 0, 0, - (SCM frame), - "") + (SCM frame), + "Return @code{#t} if @var{frame} contains evaluated arguments.") #define FUNC_NAME s_scm_frame_evaluating_args_p { SCM_VALIDATE_FRAME (1,frame); @@ -719,8 +729,8 @@ SCM_DEFINE (scm_frame_evaluating_args_p, "frame-evaluating-args?", 1, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_frame_overflow_p, "frame-overflow?", 1, 0, 0, - (SCM frame), - "") + (SCM frame), + "Return @code{#t} if @var{frame} is an overflow frame.") #define FUNC_NAME s_scm_frame_overflow_p { SCM_VALIDATE_FRAME (1,frame); From fa6a543f0d2ab1d4f14b721def25c2cbf389d2a7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 16 Feb 2001 15:15:50 +0000 Subject: [PATCH 0560/2047] (scm_dirname, scm_basename): Added docstrings. --- libguile/filesys.c | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index a809e7f36..a2042c314 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1352,7 +1352,9 @@ SCM scm_dot_string; SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0, (SCM filename), - "") + "Return the directory name component of the file name\n" + "@var{filename}. If @var{filename} does not contain a directory\n" + "component, @code{.} is returned.") #define FUNC_NAME s_scm_dirname { char *s; @@ -1382,7 +1384,10 @@ SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0, SCM_DEFINE (scm_basename, "basename", 1, 1, 0, (SCM filename, SCM suffix), - "") + "Return the base name of the file name @var{filename}. The\n" + "base name is the file name without any directory components.\n" + "If @var{suffix} is privided, and is equal to the end of\n" + "@var{basename}, it is removed also.") #define FUNC_NAME s_scm_basename { char *f, *s = 0; From dc7fa443d650b3e4c483c320b7d8ca1aab9adf61 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 16 Feb 2001 15:17:20 +0000 Subject: [PATCH 0561/2047] (scm_read_options, scm_read, scm_read_hash_extend): Added docstrings. --- libguile/read.c | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/libguile/read.c b/libguile/read.c index d3babdcca..616134724 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -79,7 +79,9 @@ scm_option scm_read_opts[] = { SCM_DEFINE (scm_read_options, "read-options-interface", 0, 1, 0, (SCM setting), -"") + "Option interface for the read options. Instead of using\n" + "this procedure directly, use the procedures @code{read-enable},\n" + "@code{read-disable}, @code{read-set!} and @var{read-options}.") #define FUNC_NAME s_scm_read_options { SCM ans = scm_options (setting, @@ -97,7 +99,9 @@ static SCM *scm_read_hash_procedures; SCM_DEFINE (scm_read, "read", 0, 1, 0, (SCM port), -"") + "Read an s-expression from the input port @var{port}, or from\n" + "the current input port if @var{port} is not specified.\n" + "Any whitespace before the next token is discarded.") #define FUNC_NAME s_scm_read { int c; @@ -725,7 +729,11 @@ exit: Scheme, but maybe it will also be used by C code during initialisation. */ SCM_DEFINE (scm_read_hash_extend, "read-hash-extend", 2, 0, 0, (SCM chr, SCM proc), -"") + "Install the procedure @var{proc} for reading expressions\n" + "starting with the character sequence @code{#} and @var{chr}.\n" + "@var{proc} will be called with two arguments: the character\n" + "@var{chr} and the port to read further data from. The object\n" + "returned will be the return value of @code{read}.") #define FUNC_NAME s_scm_read_hash_extend { SCM this; From cf35941718c81e540ff1f45c9d3b1a1787d9ad3f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 16 Feb 2001 15:18:34 +0000 Subject: [PATCH 0562/2047] (scm_unhash_name): Added docstring. --- libguile/gc.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/gc.c b/libguile/gc.c index 052859210..60aaad34f 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -2274,7 +2274,8 @@ alloc_some_heap (scm_freelist_t *freelist, policy_on_error error_policy) SCM_DEFINE (scm_unhash_name, "unhash-name", 1, 0, 0, (SCM name), - "") + "Flushes the glocs for @var{name}, or all glocs if @var{name}\n" + "is @code{#t}.") #define FUNC_NAME s_scm_unhash_name { int x; From b3f26b140bacc34f89b449043cb4116756225ced Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 16 Feb 2001 15:20:00 +0000 Subject: [PATCH 0563/2047] (scm_eval_options_interface, scm_evaluator_traps, s_scm_nconc2last): Added docstrings. --- libguile/eval.c | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index a69fadacb..016f37a46 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1672,7 +1672,9 @@ scm_option scm_evaluator_trap_table[] = { SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0, (SCM setting), - "") + "Option interface for the evaluation options. Instead of using\n" + "this procedure directly, use the procedures @code{eval-enable},\n" + "@code{eval-disable}, @code{eval-set!} and @var{eval-options}.") #define FUNC_NAME s_scm_eval_options_interface { SCM ans; @@ -1689,7 +1691,7 @@ SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0, SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, (SCM setting), - "") + "Option interface for the evaluator trap options.") #define FUNC_NAME s_scm_evaluator_traps { SCM ans; @@ -3180,8 +3182,14 @@ ret: they're referring to, send me a patch to this comment. */ SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0, - (SCM lst), - "") + (SCM lst), + "Given a list (@var{arg1} @dots{} @var{args}), this function\n" + "conses the @var{arg1} @dots{} arguments onto the front of\n" + "@var{args}, and returns the resulting list. Note that\n" + "@var{args} is a list; thus, the argument to this function is\n" + "a list whose last element is a list.\n" + "Note: Rather than do new consing, @code{apply:nconc2last}\n" + "destroys its argument, so use with care.") #define FUNC_NAME s_scm_nconc2last { SCM *lloc; From c73bdd3a73ae35e6018df1cb0484a5b4eabf773f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 16 Feb 2001 15:21:21 +0000 Subject: [PATCH 0564/2047] (scm_display_error, scm_set_print_params_x, scm_display_application, scm_display_backtrace, scm_backtrace): Added docstrings. --- libguile/backtrace.c | 29 ++++++++++++++++++++++------- 1 file changed, 22 insertions(+), 7 deletions(-) diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 729f6d8e2..7661c19d6 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -254,7 +254,13 @@ scm_i_display_error (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM r SCM_DEFINE (scm_display_error, "display-error", 6, 0, 0, (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest), - "") + "Display an error message to the output port @var{port}.\n" + "@var{stack} is the saved stack for the error, @var{subr} is\n" + "the name of the procedure in which the error occured and\n" + "@var{message} is the actual error message, which may contain\n" + "formatting instructions. These will format the arguments in\n" + "the list @var{args} accordingly. @var{rest} is currently\n" + "ignored.") #define FUNC_NAME s_scm_display_error { SCM_VALIDATE_OUTPUT_PORT (2, port); @@ -283,7 +289,9 @@ static print_params_t *print_params = default_print_params; #ifdef GUILE_DEBUG SCM_DEFINE (scm_set_print_params_x, "set-print-params!", 1, 0, 0, (SCM params), -"") + "Set the print parameters to the values from @var{params}.\n" + "@var{params} must be a list of two-element lists which must\n" + "hold two integer values.") #define FUNC_NAME s_scm_set_print_params_x { int i; @@ -387,7 +395,9 @@ display_application (SCM frame,int indentation,SCM sport,SCM port,scm_print_stat SCM_DEFINE (scm_display_application, "display-application", 1, 2, 0, (SCM frame, SCM port, SCM indent), -"") + "Display a procedure application @var{frame} to the output port\n" + "@var{port}. @var{indent} specifies the indentation of the\n" + "output.") #define FUNC_NAME s_scm_display_application { SCM_VALIDATE_FRAME (1,frame); @@ -600,8 +610,12 @@ display_backtrace_body(struct display_backtrace_args *a) #undef FUNC_NAME SCM_DEFINE (scm_display_backtrace, "display-backtrace", 2, 2, 0, - (SCM stack, SCM port, SCM first, SCM depth), -"") + (SCM stack, SCM port, SCM first, SCM depth), + "Display a backtrace to the output port @var{port}. @var{stack}\n" + "is the stack to take the backtrace from, @var{first} specifies\n" + "where in the stack to start and @var{depth} how much frames\n" + "to display. Both @var{first} and @var{depth} can be @code{#f},\n" + "which means that default values will be used.") #define FUNC_NAME s_scm_display_backtrace { struct display_backtrace_args a; @@ -622,8 +636,9 @@ SCM_DEFINE (scm_display_backtrace, "display-backtrace", 2, 2, 0, SCM_VCELL (scm_has_shown_backtrace_hint_p_var, "has-shown-backtrace-hint?"); SCM_DEFINE (scm_backtrace, "backtrace", 0, 0, 0, - (), -"") + (), + "Display a backtrace of the stack saved by the last error\n" + "to the current output port.") #define FUNC_NAME s_scm_backtrace { SCM the_last_stack = scm_fluid_ref (SCM_CDR (scm_the_last_stack_fluid)); From 811cf8467acfe4d0a45c4e61b8f40bd02801ca66 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 16 Feb 2001 15:22:58 +0000 Subject: [PATCH 0565/2047] (scm_async, scm_system_async, scm_async_mark, scm_system_async_mark, scm_run_asyncs, scm_noop, scm_set_tick_rate, scm_set_switch_rate, scm_unmask_signals, scm_mask_signals): Added docstrings. --- libguile/async.c | 38 +++++++++++++++++++++----------------- 1 file changed, 21 insertions(+), 17 deletions(-) diff --git a/libguile/async.c b/libguile/async.c index 2728537b3..d1f834df0 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -287,8 +287,8 @@ async_mark (SCM obj) SCM_DEFINE (scm_async, "async", 1, 0, 0, - (SCM thunk), -"") + (SCM thunk), + "Create a new async for the procedure @var{thunk}.") #define FUNC_NAME s_scm_async { SCM_RETURN_NEWSMOB (tc16_async, SCM_UNPACK (thunk)); @@ -297,7 +297,8 @@ SCM_DEFINE (scm_async, "async", 1, 0, 0, SCM_DEFINE (scm_system_async, "system-async", 1, 0, 0, (SCM thunk), -"") + "Create a new async for the procedure @var{thunk}. Also\n" + "add it to the system's list of active async objects.") #define FUNC_NAME s_scm_system_async { SCM it; @@ -314,7 +315,7 @@ SCM_DEFINE (scm_system_async, "system-async", 1, 0, 0, SCM_DEFINE (scm_async_mark, "async-mark", 1, 0, 0, (SCM a), -"") + "Mark the async @var{a} for future execution.") #define FUNC_NAME s_scm_async_mark { VALIDATE_ASYNC (1, a); @@ -330,7 +331,7 @@ SCM_DEFINE (scm_async_mark, "async-mark", 1, 0, 0, SCM_DEFINE (scm_system_async_mark, "system-async-mark", 1, 0, 0, (SCM a), -"") + "Mark the async @var{a} for future execution.") #define FUNC_NAME s_scm_system_async_mark { VALIDATE_ASYNC (1, a); @@ -349,8 +350,8 @@ SCM_DEFINE (scm_system_async_mark, "system-async-mark", 1, 0, 0, SCM_DEFINE (scm_run_asyncs, "run-asyncs", 1, 0, 0, - (SCM list_of_a), -"") + (SCM list_of_a), + "Execute all thunks from the asyncs of the list @var{list_of_a}.") #define FUNC_NAME s_scm_run_asyncs { #ifdef GUILE_OLD_ASYNC_CLICK @@ -382,8 +383,9 @@ SCM_DEFINE (scm_run_asyncs, "run-asyncs", 1, 0, 0, SCM_DEFINE (scm_noop, "noop", 0, 0, 1, - (SCM args), -"") + (SCM args), + "Do nothing. When called without arguments, return @code{#f},\n" + "otherwise return the first argument.") #define FUNC_NAME s_scm_noop { SCM_VALIDATE_REST_ARGUMENT (args); @@ -397,8 +399,9 @@ SCM_DEFINE (scm_noop, "noop", 0, 0, 1, #ifdef GUILE_OLD_ASYNC_CLICK SCM_DEFINE (scm_set_tick_rate, "set-tick-rate", 1, 0, 0, - (SCM n), -"") + (SCM n), + "Set the rate of async ticks to @var{n}. Return the old rate\n" + "value.") #define FUNC_NAME s_scm_set_tick_rate { unsigned int old_n = scm_tick_rate; @@ -414,8 +417,9 @@ SCM_DEFINE (scm_set_tick_rate, "set-tick-rate", 1, 0, 0, SCM_DEFINE (scm_set_switch_rate, "set-switch-rate", 1, 0, 0, - (SCM n), -"") + (SCM n), + "Set the async switch rate to @var{n}. Return the old value\n" + "of the switch rate.") #define FUNC_NAME s_scm_set_switch_rate { unsigned int old_n = scm_switch_rate; @@ -432,8 +436,8 @@ SCM_DEFINE (scm_set_switch_rate, "set-switch-rate", 1, 0, 0, SCM_DEFINE (scm_unmask_signals, "unmask-signals", 0, 0, 0, - (), -"") + (), + "Unmask signals. The returned value is not specified.") #define FUNC_NAME s_scm_unmask_signals { scm_mask_ints = 0; @@ -443,8 +447,8 @@ SCM_DEFINE (scm_unmask_signals, "unmask-signals", 0, 0, 0, SCM_DEFINE (scm_mask_signals, "mask-signals", 0, 0, 0, - (), -"") + (), + "Mask signals. The returned value is not specified.") #define FUNC_NAME s_scm_mask_signals { scm_mask_ints = 1; From 73c0fdce7e198f9db2dbd981113acdb85a481364 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 16 Feb 2001 15:25:09 +0000 Subject: [PATCH 0566/2047] Massive docstring work. --- libguile/ChangeLog | 57 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 57 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index ebeb3cc1c..e202b3ad5 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,60 @@ +2001-02-16 Martin Grabmueller + + * numbers.c (scm_lognot), random.c (scm_random, + scm_random_normal, scm_random_solid_sphere_x, + scm_random_hollow_sphere_x, scm_random_normal_vector_x, + scm_random_exp), dynwind.c + (scm_dynamic_wind): Removed unnecessary "" from docstrings. + + * goops.c (scm_sys_initialize_object, scm_instance_p, + scm_class_name, scm_class_precedence_list, scm_class_slots, + scm_class_environment, scm_generic_function_name, + scm_generic_function_methods, scm_method_generic_function, + scm_method_specializers, scm_method_procedure, scm_make_unbound, + scm_unbound_p, scm_assert_bound, scm_at_assert_bound_ref, + scm_sys_fast_slot_ref, scm_sys_fast_slot_set_x, scm_slot_ref, + scm_slot_set_x, _scm_slot_bound_p, scm_slots_exists_p, + scm_sys_allocate_instance, scm_make, scm_pure_generic_p, + scm_class_direct_supers, scm_class_direct_slots, + scm_class_direct_subclasses, scm_class_direct_methods, + scm_accessor_method_slot_definition, scm_sys_goops_loaded), + debug.c (scm_with_traps, scm_memoized_p, scm_make_gloc, + scm_gloc_p, scm_make_iloc, scm_iloc_p, scm_memcons, + scm_mem_to_proc, scm_proc_to_mem, scm_unmemoize, + scm_memoized_environment, scm_procedure_name, + scm_procedure_source, scm_procedure_environment, scm_debug_hang), + objects.c + (scm_class_of, scm_entity_p, scm_operator_p, + scm_set_object_procedure_x, scm_object_procedure, + scm_make_class_object), hooks.c (scm_make_hook_with_name, + scm_make_hook, scm_hook_p, scm_hook_empty_p, scm_add_hook_x, + scm_remove_hook_x, scm_reset_hook_x, scm_run_hook, + scm_hook_to_list), lang.c + (scm_nil_cons, scm_nil_car, scm_nil_cdr, scm_null, scm_nil_eq), + numbers.c (scm_sys_expt, scm_sys_atan2), print.c + (scm_print_options, scm_port_with_print_state, + scm_get_print_state), procs.c (scm_make_cclo, scm_procedure_p, + scm_closure_p, scm_thunk_p, scm_procedure_with_setter_p, + scm_make_procedure_with_setter, scm_procedure), throw.c + (scm_lazy_catch), modules.c (scm_standard_eval_closure), load.c + (scm_parse_path, scm_search_path), stacks.c (scm_make_stack, + scm_stack_ref, scm_stack_length, scm_frame_p, + scm_last_stack_frame, scm_frame_number, scm_frame_source, + scm_frame_procedure, scm_frame_arguments, scm_frame_previous, + scm_frame_next, scm_frame_real_p, scm_frame_procedure_p, + scm_frame_evaluating_args_p, scm_frame_overflow_p), filesys.c + (scm_dirname, scm_basename), dynwind.c + (scm_wind_chain), read.c (scm_read_options, scm_read, + scm_read_hash_extend), gc.c + (scm_unhash_name), eval.c (scm_eval_options_interface, + scm_evaluator_traps, s_scm_nconc2last), backtrace.c + (scm_display_error, scm_set_print_params_x, + scm_display_application, scm_display_backtrace, scm_backtrace), + async.c (scm_async, scm_system_async, scm_async_mark, + scm_system_async_mark, scm_run_asyncs, scm_noop, + scm_set_tick_rate, scm_set_switch_rate, scm_unmask_signals, + scm_mask_signals): Added docstrings. + 2001-02-15 Keisuke Nishida * dump.c (scm_undump): Use SCM_CARLOC/SCM_CDRLOC to obtain the From 2570385024ae740fe9e5005e806d32c097417d4f Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 16 Feb 2001 18:57:11 +0000 Subject: [PATCH 0567/2047] * guile-snarf.awk.in: Quote any `@'s that occur in Scheme names, by doubling them to `@@'. --- libguile/ChangeLog | 5 +++++ libguile/guile-snarf.awk.in | 3 +++ 2 files changed, 8 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index e202b3ad5..67db1d438 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-02-16 Neil Jerram + + * guile-snarf.awk.in: Quote any `@'s that occur in Scheme names, + by doubling them to `@@'. + 2001-02-16 Martin Grabmueller * numbers.c (scm_lognot), random.c (scm_random, diff --git a/libguile/guile-snarf.awk.in b/libguile/guile-snarf.awk.in index 45ad42b88..3fbe217d9 100644 --- a/libguile/guile-snarf.awk.in +++ b/libguile/guile-snarf.awk.in @@ -40,6 +40,9 @@ BEGIN { FS="|"; sub(/ \)/,")",copy); # Now `copy' contains the nice scheme proc "prototype", e.g. # (set-car! pair value) + # Since this is destined to become Texinfo source, + # quote any `@'s that occur in the prototype. + gsub(/\@/,"@@",copy); # print copy > "/dev/stderr"; # for debugging sub(/^\(/,"",copy); sub(/\)[ \t]*$/,"",copy); From 03ba3d5b682e6e983d5219fe76174b6dc851f6c7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Sat, 17 Feb 2001 11:23:29 +0000 Subject: [PATCH 0568/2047] (scm_make_variable, scm_make_undefined_variable) (scm_variable_ref, scm_variable_set_x, scm_builtin_variable) (scm_variable_bound_p): Added texinfo markup. --- libguile/variable.c | 35 ++++++++++++++++++----------------- 1 file changed, 18 insertions(+), 17 deletions(-) diff --git a/libguile/variable.c b/libguile/variable.c index 0b586c721..a088be209 100644 --- a/libguile/variable.c +++ b/libguile/variable.c @@ -94,11 +94,11 @@ make_vcell_variable (SCM vcell) SCM_DEFINE (scm_make_variable, "make-variable", 1, 1, 0, (SCM init, SCM name_hint), - "Return a variable object initialized to value INIT.\n" - "If given, uses NAME-HINT as its internal (debugging)\n" + "Return a variable object initialized to value @var{init}.\n" + "If given, uses @var{name-hint} as its internal (debugging)\n" "name, otherwise just treat it as an anonymous variable.\n" "Remember, of course, that multiple bindings to the same\n" - "variable may exist, so NAME-HINT is just that---a hint.\n") + "variable may exist, so @var{name-hint} is just that---a hint.\n") #define FUNC_NAME s_scm_make_variable { SCM val_cell; @@ -119,10 +119,10 @@ SCM_DEFINE (scm_make_variable, "make-variable", 1, 1, 0, SCM_DEFINE (scm_make_undefined_variable, "make-undefined-variable", 0, 1, 0, (SCM name_hint), "Return a variable object initialized to an undefined value.\n" - "If given, uses NAME-HINT as its internal (debugging)\n" + "If given, uses @var{name-hint} as its internal (debugging)\n" "name, otherwise just treat it as an anonymous variable.\n" "Remember, of course, that multiple bindings to the same\n" - "variable may exist, so NAME-HINT is just that---a hint.\n") + "variable may exist, so @var{name-hint} is just that---a hint.\n") #define FUNC_NAME s_scm_make_undefined_variable { SCM vcell; @@ -142,7 +142,8 @@ SCM_DEFINE (scm_make_undefined_variable, "make-undefined-variable", 0, 1, 0, SCM_DEFINE (scm_variable_p, "variable?", 1, 0, 0, (SCM obj), - "Return #t iff OBJ is a variable object, else return #f\n") + "Return @code{#t} iff @var{obj} is a variable object, else\n" + "return @code{#f}\n") #define FUNC_NAME s_scm_variable_p { return SCM_BOOL (SCM_VARIABLEP (obj)); @@ -152,9 +153,9 @@ SCM_DEFINE (scm_variable_p, "variable?", 1, 0, 0, SCM_DEFINE (scm_variable_ref, "variable-ref", 1, 0, 0, (SCM var), - "Dereference VAR and return its value.\n" - "VAR must be a variable object; see `make-variable' and\n" - "`make-undefined-variable'") + "Dereference @var{var} and return its value.\n" + "@var{var} must be a variable object; see @code{make-variable}\n" + "and @code{make-undefined-variable}.") #define FUNC_NAME s_scm_variable_ref { SCM_VALIDATE_VARIABLE (1, var); @@ -166,9 +167,9 @@ SCM_DEFINE (scm_variable_ref, "variable-ref", 1, 0, 0, SCM_DEFINE (scm_variable_set_x, "variable-set!", 2, 0, 0, (SCM var, SCM val), - "Set the value of the variable VAR to VAL.\n" - "VAR must be a variable object, VAL can be any value.\n" - "Returns an unspecified value.\n") + "Set the value of the variable @var{var} to @var{val}.\n" + "@var{var} must be a variable object, @var{val} can be any\n" + "value. Return an unspecified value.\n") #define FUNC_NAME s_scm_variable_set_x { SCM_VALIDATE_VARIABLE (1,var); @@ -180,9 +181,9 @@ SCM_DEFINE (scm_variable_set_x, "variable-set!", 2, 0, 0, SCM_DEFINE (scm_builtin_variable, "builtin-variable", 1, 0, 0, (SCM name), - "Return the built-in variable with the name NAME.\n" - "NAME must be a symbol (not a string).\n" - "Then use `variable-ref' to access its value.\n") + "Return the built-in variable with the name @var{name}.\n" + "@var{name} must be a symbol (not a string).\n" + "Then use @code{variable-ref} to access its value.\n") #define FUNC_NAME s_scm_builtin_variable { SCM vcell; @@ -209,8 +210,8 @@ SCM_DEFINE (scm_builtin_variable, "builtin-variable", 1, 0, 0, SCM_DEFINE (scm_variable_bound_p, "variable-bound?", 1, 0, 0, (SCM var), - "Return #t iff VAR is bound to a value.\n" - "Throws an error if VAR is not a variable object.\n") + "Return @code{#t} iff @var{var} is bound to a value.\n" + "Throws an error if @var{var} is not a variable object.\n") #define FUNC_NAME s_scm_variable_bound_p { SCM_VALIDATE_VARIABLE (1,var); From 647e35e27c4073bf1c07aa877e01450b86acab6e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Sat, 17 Feb 2001 11:24:30 +0000 Subject: [PATCH 0569/2047] (scm_values): Added texinfo markup. --- libguile/values.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/libguile/values.c b/libguile/values.c index 6575a147c..59638174b 100644 --- a/libguile/values.c +++ b/libguile/values.c @@ -77,10 +77,10 @@ print_values (SCM obj, SCM pwps) SCM_DEFINE (scm_values, "values", 0, 0, 1, (SCM args), "Delivers all of its arguments to its continuation. Except for\n" - "continuations created by the `call-with-values' procedure, all\n" - "continuations take exactly one value. The effect of passing no\n" - "value or more than one value to continuations that were not\n" - "created by call-with-values is unspecified.") + "continuations created by the @code{call-with-values} procedure,\n" + "all continuations take exactly one value. The effect of\n" + "passing no value or more than one value to continuations that\n" + "were not created by @code{call-with-values} is unspecified.") #define FUNC_NAME s_scm_values { long n; @@ -105,7 +105,7 @@ SCM_DEFINE (scm_call_with_values, "call-with-values", 2, 0, 0, "continuation that, when passed some values, calls the\n" "@var{consumer} procedure with those values as arguments. The\n" "continuation for the call to @var{consumer} is the continuation\n" - "of the call to call-with-values.\n\n" + "of the call to @code{call-with-values}.\n\n" "@example\n" "(call-with-values (lambda () (values 4 5))\n" " (lambda (a b) b))\n" From c7eb87615a23ab34304cff858eb6dfc4bc56d659 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Sat, 17 Feb 2001 11:25:34 +0000 Subject: [PATCH 0570/2047] (scm_bit_count, scm_bit_set_star_x): Added texinfo markup. --- libguile/unif.c | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/libguile/unif.c b/libguile/unif.c index 889189ea7..b9987c36d 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1745,8 +1745,9 @@ static char cnt_tab[16] = {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4}; SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0, - (SCM b, SCM bitvector), - "Returns the number of occurrences of the boolean B in BITVECTOR.") + (SCM b, SCM bitvector), + "Returns the number of occurrences of the boolean @var{b} in\n" + "@var{bitvector}.") #define FUNC_NAME s_scm_bit_count { SCM_VALIDATE_BOOL (1, b); @@ -1845,14 +1846,15 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, - (SCM v, SCM kv, SCM obj), - "If uve is a bit-vector @var{bv} and uve must be of the same length. If\n" - "@var{bool} is @code{#t}, uve is OR'ed into @var{bv}; If @var{bool} is @code{#f}, the\n" - "inversion of uve is AND'ed into @var{bv}.\n\n" - "If uve is a unsigned integer vector all the elements of uve must be\n" - "between 0 and the @code{LENGTH} of @var{bv}. The bits of @var{bv}\n" - "corresponding to the indexes in uve are set to @var{bool}.\n\n" - "The return value is unspecified.") + (SCM v, SCM kv, SCM obj), + "If uve is a bit-vector @var{bv} and uve must be of the same\n" + "length. If @var{bool} is @code{#t}, uve is OR'ed into\n" + "@var{bv}; If @var{bool} is @code{#f}, the inversion of uve is\n" + "AND'ed into @var{bv}.\n\n" + "If uve is a unsigned integer vector all the elements of uve\n" + "must be between 0 and the @code{length} of @var{bv}. The bits\n" + "of @var{bv} corresponding to the indexes in uve are set to\n" + "@var{bool}. The return value is unspecified.") #define FUNC_NAME s_scm_bit_set_star_x { register long i, k, vlen; From 16bad70540dace9b28bf2e91359eea6eaee3423f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Sat, 17 Feb 2001 11:26:26 +0000 Subject: [PATCH 0571/2047] (scm_gentemp, scm_gensym): Added texinfo markup. --- libguile/symbols.c | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/libguile/symbols.c b/libguile/symbols.c index d7c1fb9ef..0345bf959 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -774,10 +774,11 @@ static int gensym_counter; SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, (SCM prefix), - "Create a new symbol with name constructed from a prefix and a counter value.\n" - "The string PREFIX can be specified as an optional argument.\n" - "Default prefix is @code{g}. The counter is increased by 1 at each call.\n" - "There is no provision for resetting the counter.") + "Create a new symbol with a name constructed from a prefix and\n" + "a counter value. The string @var{prefix} can be specified as\n" + "an optional argument. Default prefix is @code{g}. The counter\n" + "is increased by 1 at each call. There is no provision for\n" + "resetting the counter.") #define FUNC_NAME s_scm_gensym { char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; @@ -811,10 +812,11 @@ static int gentemp_counter; SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0, (SCM prefix, SCM obarray), "Create a new symbol with a name unique in an obarray.\n" - "The name is constructed from an optional string PREFIX and a counter\n" - "value. The default prefix is @var{t}. The OBARRAY is specified as a\n" - "second optional argument. Default is the system obarray where all\n" - "normal symbols are interned. The counter is increased by 1 at each\n" + "The name is constructed from an optional string @var{prefix}\n" + "and a counter value. The default prefix is @code{t}. The\n" + "@var{obarray} is specified as a second optional argument.\n" + "Default is the system obarray where all normal symbols are\n" + "interned. The counter is increased by 1 at each\n" "call. There is no provision for resetting the counter.") #define FUNC_NAME s_scm_gentemp { From 0d26a824c743fb264e4f333610baccf643448489 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Sat, 17 Feb 2001 11:27:41 +0000 Subject: [PATCH 0572/2047] (scm_string_p, scm_make_string, scm_read_only_string_p, scm_string_length) (scm_string_ref, scm_string_set_x, scm_substring, scm_string_append): Added texinfo markup. --- libguile/strings.c | 52 +++++++++++++++++++++++++--------------------- 1 file changed, 28 insertions(+), 24 deletions(-) diff --git a/libguile/strings.c b/libguile/strings.c index 751521cb4..3874b4a05 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -58,8 +58,9 @@ */ SCM_DEFINE (scm_string_p, "string?", 1, 0, 0, - (SCM obj), - "Returns #t iff OBJ is a string, else returns #f.") + (SCM obj), + "Returns @code{#t} iff @var{obj} is a string, else returns\n" + "@code{#f}.") #define FUNC_NAME s_scm_string_p { return SCM_BOOL (SCM_STRINGP (obj)); @@ -73,8 +74,8 @@ SCM_DEFINE (scm_string_p, "string?", 1, 0, 0, */ SCM_DEFINE (scm_read_only_string_p, "read-only-string?", 1, 0, 0, - (SCM x), - "Return true if OBJ can be read as a string,\n\n" + (SCM obj), + "Return true if @var{obj} can be read as a string,\n\n" "This illustrates the difference between @code{string?} and\n" "@code{read-only-string?}:\n\n" "@example\n" @@ -85,7 +86,7 @@ SCM_DEFINE (scm_read_only_string_p, "read-only-string?", 1, 0, 0, "@end example") #define FUNC_NAME s_scm_read_only_string_p { - return SCM_BOOL(SCM_ROSTRINGP (x)); + return SCM_BOOL(SCM_ROSTRINGP (obj)); } #undef FUNC_NAME @@ -96,7 +97,8 @@ SCM_REGISTER_PROC (s_scm_list_to_string, "list->string", 1, 0, 0, scm_string); SCM_DEFINE (scm_string, "string", 0, 0, 1, (SCM chrs), "@deffnx primitive list->string chrs\n" - "Returns a newly allocated string composed of the arguments, CHRS.") + "Returns a newly allocated string composed of the arguments,\n" + "@var{chrs}.") #define FUNC_NAME s_scm_string { SCM result; @@ -223,10 +225,10 @@ scm_makfrom0str_opt (const char *src) SCM_DEFINE (scm_make_string, "make-string", 1, 1, 0, (SCM k, SCM chr), - "Returns a newly allocated string of\n" - "length K. If CHR is given, then all elements of the string\n" - "are initialized to CHR, otherwise the contents of the\n" - "STRING are unspecified.\n") + "Return a newly allocated string of\n" + "length @var{k}. If @var{chr} is given, then all elements of\n" + "the string are initialized to @var{chr}, otherwise the contents\n" + "of the @var{string} are unspecified.\n") #define FUNC_NAME s_scm_make_string { if (SCM_INUMP (k)) @@ -258,8 +260,8 @@ SCM_DEFINE (scm_make_string, "make-string", 1, 1, 0, SCM_DEFINE (scm_string_length, "string-length", 1, 0, 0, - (SCM string), - "Returns the number of characters in STRING") + (SCM string), + "Return the number of characters in @var{string}.") #define FUNC_NAME s_scm_string_length { SCM_VALIDATE_STRING (1, string); @@ -269,8 +271,8 @@ SCM_DEFINE (scm_string_length, "string-length", 1, 0, 0, SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0, (SCM str, SCM k), - "Returns character K of STR using zero-origin indexing.\n" - "K must be a valid index of STR.") + "Return character @var{k} of @var{str} using zero-origin\n" + "indexing. @var{k} must be a valid index of @var{str}.") #define FUNC_NAME s_scm_string_ref { int idx; @@ -285,8 +287,9 @@ SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0, SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0, (SCM str, SCM k, SCM chr), - "Stores CHR in element K of STRING and returns an unspecified value.\n" - "K must be a valid index of STR.") + "Store @var{chr} in element @var{k} of @var{str} and return\n" + "an unspecified value. @var{k} must be a valid index of\n" + "@var{str}.") #define FUNC_NAME s_scm_string_set_x { #if (SCM_DEBUG_DEPRECATED == 0) @@ -303,12 +306,13 @@ SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0, SCM_DEFINE (scm_substring, "substring", 2, 1, 0, - (SCM str, SCM start, SCM end), - "Returns a newly allocated string formed from the characters\n" - "of STR beginning with index START (inclusive) and ending with\n" - "index END (exclusive).\n" - "STR must be a string, START and END must be exact integers satisfying:\n\n" - "0 <= START <= END <= (string-length STR).") + (SCM str, SCM start, SCM end), + "Return a newly allocated string formed from the characters\n" + "of @var{str} beginning with index @var{start} (inclusive) and\n" + "ending with index @var{end} (exclusive).\n" + "@var{str} must be a string, @var{start} and @var{end} must be\n" + "exact integers satisfying:\n\n" + "0 <= @var{start} <= @var{end} <= (string-length @var{str}).") #define FUNC_NAME s_scm_substring { long int from; @@ -330,8 +334,8 @@ SCM_DEFINE (scm_substring, "substring", 2, 1, 0, SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, (SCM args), - "Returns a newly allocated string whose characters form the\n" - "concatenation of the given strings, ARGS.") + "Return a newly allocated string whose characters form the\n" + "concatenation of the given strings, @var{args}.") #define FUNC_NAME s_scm_string_append { SCM res; From a8eac221a701cea05a961fb73e5b8838522f9dcd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Sat, 17 Feb 2001 11:28:30 +0000 Subject: [PATCH 0573/2047] (scm_strptime, scm_mktime): Added texinfo markup. --- libguile/stime.c | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/libguile/stime.c b/libguile/stime.c index cb5b75822..d797bf6c3 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -469,9 +469,9 @@ SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0, "@var{bd-time} is an object representing broken down time and @code{zone}\n" "is an optional time zone specifier (otherwise the TZ environment variable\n" "or the system default is used).\n\n" - "Returns a pair: the CAR is a corresponding\n" + "Returns a pair: the car is a corresponding\n" "integer time value like that returned\n" - "by @code{current-time}; the CDR is a broken down time object, similar to\n" + "by @code{current-time}; the cdr is a broken down time object, similar to\n" "as @var{bd-time} but with normalized values.") #define FUNC_NAME s_scm_mktime { @@ -651,16 +651,16 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, #ifdef HAVE_STRPTIME SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, (SCM format, SCM string), - "Performs the reverse action to @code{strftime}, parsing @var{string}\n" - "according to the specification supplied in @var{template}. The\n" - "interpretation of month and day names is dependent on the current\n" - "locale. The\n" - "value returned is a pair. The CAR has an object with time components \n" + "Performs the reverse action to @code{strftime}, parsing\n" + "@var{string} according to the specification supplied in\n" + "@var{template}. The interpretation of month and day names is\n" + "dependent on the current locale. The value returned is a pair.\n" + "The car has an object with time components\n" "in the form returned by @code{localtime} or @code{gmtime},\n" "but the time zone components\n" "are not usefully set.\n" - "The CDR reports the number of characters from @var{string} which\n" - "were used for the conversion.") + "The cdr reports the number of characters from @var{string}\n" + "which were used for the conversion.") #define FUNC_NAME s_scm_strptime { struct tm t; From 3b64451459f45f3644d456bb438d2e3429416e6b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Sat, 17 Feb 2001 11:29:16 +0000 Subject: [PATCH 0574/2047] (scm_seed_to_random_state, scm_copy_random_state, scm_random): Added texinfo markup. --- libguile/random.c | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/libguile/random.c b/libguile/random.c index 73f8cfaf9..4af5c4aa6 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -359,11 +359,11 @@ SCM_DEFINE (scm_random, "random", 1, 1, 0, "N (exclusive). The values returned have a uniform \n" "distribution.\n" "\n" - "The optional argument STATE must be of the type produced by\n" - "`seed->random-state'. It defaults to the value of the variable\n" - "*random-state*. This object is used to maintain the state of\n" - "the pseudo-random-number generator and is altered as a side\n" - "effect of the random operation.") + "The optional argument @var{state} must be of the type produced\n" + "by @code{seed->random-state}. It defaults to the value of the\n" + "variable @var{*random-state*}. This object is used to maintain\n" + "the state of the pseudo-random-number generator and is altered\n" + "as a side effect of the random operation.") #define FUNC_NAME s_scm_random { if (SCM_UNBNDP (state)) @@ -386,7 +386,7 @@ SCM_DEFINE (scm_random, "random", 1, 1, 0, SCM_DEFINE (scm_copy_random_state, "copy-random-state", 0, 1, 0, (SCM state), - "Return a copy of the random state STATE.") + "Return a copy of the random state @var{state}.") #define FUNC_NAME s_scm_copy_random_state { if (SCM_UNBNDP (state)) @@ -398,7 +398,7 @@ SCM_DEFINE (scm_copy_random_state, "copy-random-state", 0, 1, 0, SCM_DEFINE (scm_seed_to_random_state, "seed->random-state", 1, 0, 0, (SCM seed), - "Return a new random state using SEED.") + "Return a new random state using @var{seed}.") #define FUNC_NAME s_scm_seed_to_random_state { if (SCM_NUMBERP (seed)) From eca65e90f7018a3fc467d69ee22c8bb602f03f4f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Sat, 17 Feb 2001 11:29:58 +0000 Subject: [PATCH 0575/2047] (scm_newline, scm_write_char, scm_simple_format): Added texinfo markup. --- libguile/print.c | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/libguile/print.c b/libguile/print.c index 20bcad6c9..bc205ef79 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -964,13 +964,17 @@ scm_display (SCM obj, SCM port) SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, (SCM destination, SCM message, SCM args), - "Write MESSAGE to DESTINATION, defaulting to `current-output-port'.\n" - "MESSAGE can contain ~A (was %s) and ~S (was %S) escapes. When printed,\n" - "the escapes are replaced with corresponding members of ARGS:\n" - "~A formats using `display' and ~S formats using `write'.\n" - "If DESTINATION is #t, then use the `current-output-port',\n" - "if DESTINATION is #f, then return a string containing the formatted text.\n" - "Does not add a trailing newline.") + "Write @var{message} to @var{destination}, defaulting to\n" + "the current output port.\n" + "@var{message} can contain @code{~A} (was @code{%s}) and\n" + "@code{~S} (was @code{%S}) escapes. When printed,\n" + "the escapes are replaced with corresponding members of\n" + "@var{ARGS}:\n" + "@code{~A} formats using @code{display} and @code{~S} formats\n" + "using @code{write}.\n" + "If @var{destination} is @code{#t}, then use the current output\n" + "port, if @var{destination} is @code{#f}, then return a string\n" + "containing the formatted text. Does not add a trailing newline.") #define FUNC_NAME s_scm_simple_format { SCM answer = SCM_UNSPECIFIED; @@ -1035,7 +1039,7 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, SCM_DEFINE (scm_newline, "newline", 0, 1, 0, (SCM port), - "Send a newline to PORT.") + "Send a newline to @var{port}.") #define FUNC_NAME s_scm_newline { if (SCM_UNBNDP (port)) @@ -1050,7 +1054,7 @@ SCM_DEFINE (scm_newline, "newline", 0, 1, 0, SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0, (SCM chr, SCM port), - "Send character CHR to PORT.") + "Send character @var{chr} to @var{port}.") #define FUNC_NAME s_scm_write_char { if (SCM_UNBNDP (port)) From 6836c87b3adaae23e8aaf62c89377bd38649c66e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Sat, 17 Feb 2001 11:30:34 +0000 Subject: [PATCH 0576/2047] (scm_malloc_stats): Added texinfo markup. --- libguile/debug-malloc.c | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/libguile/debug-malloc.c b/libguile/debug-malloc.c index d0fba532e..8b2a08ceb 100644 --- a/libguile/debug-malloc.c +++ b/libguile/debug-malloc.c @@ -226,9 +226,11 @@ scm_malloc_reregister (void *old, void *new, const char *newwhat) SCM_DEFINE (scm_malloc_stats, "malloc-stats", 0, 0, 0, (), - "Return an alist ((WHAT . N) ...) describing number of malloced objects.\n" - "WHAT is the second argument to scm_must_malloc, N is the number of objects\n" - "of that type currently allocated.") + "Return an alist ((@var{what} . @var{n}) ...) describing number\n" + "of malloced objects.\n" + "@var{what} is the second argument to @code{scm_must_malloc},\n" + "@var{n} is the number of objects of that type currently\n" + "allocated.") #define FUNC_NAME s_scm_malloc_stats { SCM res = SCM_EOL; From 0fb104edbad22a6a785e2a08b04a04e788174d25 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Sat, 17 Feb 2001 11:32:16 +0000 Subject: [PATCH 0577/2047] (scm_environment_p) (scm_environment_bound_p, scm_environment_ref) (scm_environment_fold, scm_environment_define) (scm_environment_undefine, scm_environment_set_x) (scm_environment_cell, scm_environment_observe) (scm_environment_observe_weak, scm_environment_unobserve) (scm_make_eval_environment, scm_eval_environment_p) (scm_eval_environment_set_local_x, scm_eval_environment_local) (scm_eval_environment_imported) (scm_eval_environment_set_imported_x, scm_make_import_environment) (scm_import_environment_p, scm_import_environment_imports) (scm_import_environment_set_imports_x, scm_make_export_environment) (scm_export_environment_p, scm_export_environment_private) (scm_export_environment_set_private_x) (scm_export_environment_signature) (scm_export_environment_set_signature_x, scm_leaf_environment_p): Added texinfo markup. --- libguile/environments.c | 291 ++++++++++++++++++++++------------------ 1 file changed, 164 insertions(+), 127 deletions(-) diff --git a/libguile/environments.c b/libguile/environments.c index 710d29ad1..500943327 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -131,7 +131,8 @@ scm_make_environment (void *type) SCM_DEFINE (scm_environment_p, "environment?", 1, 0, 0, (SCM obj), - "Return #t if OBJ is an environment, or #f otherwise.") + "Return @code{#t} if @var{obj} is an environment, or @code{#f}\n" + "otherwise.") #define FUNC_NAME s_scm_environment_p { return SCM_BOOL (SCM_ENVIRONMENT_P (obj)); @@ -141,7 +142,8 @@ SCM_DEFINE (scm_environment_p, "environment?", 1, 0, 0, SCM_DEFINE (scm_environment_bound_p, "environment-bound?", 2, 0, 0, (SCM env, SCM sym), - "Return #t if SYM is bound in ENV, or #f otherwise.") + "Return @code{#t} if @var{sym} is bound in @var{env}, or\n" + "@code{#f} otherwise.") #define FUNC_NAME s_scm_environment_bound_p { SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); @@ -154,9 +156,9 @@ SCM_DEFINE (scm_environment_bound_p, "environment-bound?", 2, 0, 0, SCM_DEFINE (scm_environment_ref, "environment-ref", 2, 0, 0, (SCM env, SCM sym), - "Return the value of the location bound to SYM in ENV.\n" - "If SYM is unbound in ENV, signal an environment:unbound\n" - "error.") + "Return the value of the location bound to @var{sym} in\n" + "@var{env}. If @var{sym} is unbound in @var{env}, signal an\n" + "@code{environment:unbound} error.") #define FUNC_NAME s_scm_environment_ref { SCM val; @@ -196,30 +198,37 @@ environment_default_folder (SCM proc, SCM symbol, SCM value, SCM tail) SCM_DEFINE (scm_environment_fold, "environment-fold", 3, 0, 0, (SCM env, SCM proc, SCM init), - "Iterate over all the bindings in ENV, accumulating some value.\n" - "For each binding in ENV, apply PROC to the symbol bound, its\n" - "value, and the result from the previous application of PROC.\n" - "Use INIT as PROC's third argument the first time PROC is\n" - "applied.\n" - "If ENV contains no bindings, this function simply returns INIT.\n" - "If ENV binds the symbol sym1 to the value val1, sym2 to val2,\n" - "and so on, then this procedure computes:\n" + "Iterate over all the bindings in @var{env}, accumulating some\n" + "value.\n" + "For each binding in @var{env}, apply @var{proc} to the symbol\n" + "bound, its value, and the result from the previous application\n" + "of @var{proc}.\n" + "Use @var{init} as @var{proc}'s third argument the first time\n" + "@var{proc} is applied.\n" + "If @var{env} contains no bindings, this function simply returns\n" + "@var{init}.\n" + "If @var{env} binds the symbol sym1 to the value val1, sym2 to\n" + "val2, and so on, then this procedure computes:\n" + "@example\n" " (proc sym1 val1\n" " (proc sym2 val2\n" " ...\n" " (proc symn valn\n" " init)))\n" - "Each binding in ENV will be processed exactly once.\n" - "environment-fold makes no guarantees about the order in which\n" - "the bindings are processed.\n" + "@end example\n" + "Each binding in @var{env} will be processed exactly once.\n" + "@code{environment-fold} makes no guarantees about the order in\n" + "which the bindings are processed.\n" "Here is a function which, given an environment, constructs an\n" "association list representing that environment's bindings,\n" "using environment-fold:\n" + "@example\n" " (define (environment->alist env)\n" " (environment-fold env\n" " (lambda (sym val tail)\n" " (cons (cons sym val) tail))\n" - " '()))") + " '()))\n" + "@end example") #define FUNC_NAME s_scm_environment_fold { SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); @@ -248,12 +257,13 @@ scm_c_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init SCM_DEFINE (scm_environment_define, "environment-define", 3, 0, 0, (SCM env, SCM sym, SCM val), - "Bind SYM to a new location containing VAL in ENV. If SYM is\n" - "already bound to another location in ENV and the binding is\n" - "mutable, that binding is replaced. The new binding and\n" - "location are both mutable. The return value is unspecified.\n" - "If SYM is already bound in ENV, and the binding is immutable,\n" - "signal an environment:immutable-binding error.") + "Bind @var{sym} to a new location containing @var{val} in\n" + "@var{env}. If @var{sym} is already bound to another location\n" + "in @var{env} and the binding is mutable, that binding is\n" + "replaced. The new binding and location are both mutable. The\n" + "return value is unspecified.\n" + "If @var{sym} is already bound in @var{env}, and the binding is\n" + "immutable, signal an @code{environment:immutable-binding} error.") #define FUNC_NAME s_scm_environment_define { SCM status; @@ -275,10 +285,11 @@ SCM_DEFINE (scm_environment_define, "environment-define", 3, 0, 0, SCM_DEFINE (scm_environment_undefine, "environment-undefine", 2, 0, 0, (SCM env, SCM sym), - "Remove any binding for SYM from ENV. If SYM is unbound in ENV,\n" - "do nothing. The return value is unspecified.\n" - "If SYM is already bound in ENV, and the binding is immutable,\n" - "signal an environment:immutable-binding error.") + "Remove any binding for @var{sym} from @var{env}. If @var{sym}\n" + "is unbound in @var{env}, do nothing. The return value is\n" + "unspecified.\n" + "If @var{sym} is already bound in @var{env}, and the binding is\n" + "immutable, signal an @code{environment:immutable-binding} error.") #define FUNC_NAME s_scm_environment_undefine { SCM status; @@ -300,11 +311,13 @@ SCM_DEFINE (scm_environment_undefine, "environment-undefine", 2, 0, 0, SCM_DEFINE (scm_environment_set_x, "environment-set!", 3, 0, 0, (SCM env, SCM sym, SCM val), - "If ENV binds SYM to some location, change that location's\n" - "value to VAL. The return value is unspecified.\n" - "If SYM is not bound in ENV, signal an environment:unbound\n" - "error. If ENV binds SYM to an immutable location, signal an\n" - "environment:immutable-location error.") + "If @var{env} binds @var{sym} to some location, change that\n" + "location's value to @var{val}. The return value is\n" + "unspecified.\n" + "If @var{sym} is not bound in @var{env}, signal an\n" + "@code{environment:unbound} error. If @var{env} binds @var{sym}\n" + "to an immutable location, signal an\n" + "@code{environment:immutable-location} error.") #define FUNC_NAME s_scm_environment_set_x { SCM status; @@ -328,16 +341,18 @@ SCM_DEFINE (scm_environment_set_x, "environment-set!", 3, 0, 0, SCM_DEFINE (scm_environment_cell, "environment-cell", 3, 0, 0, (SCM env, SCM sym, SCM for_write), - "Return the value cell which ENV binds to SYM, or #f if the\n" - "binding does not live in a value cell.\n" - "The argument FOR-WRITE indicates whether the caller intends\n" - "to modify the variable's value by mutating the value cell. If\n" - "the variable is immutable, then environment-cell signals an\n" - "environment:immutable-location error.\n" - "If SYM is unbound in ENV, signal an environment:unbound error.\n" + "Return the value cell which @var{env} binds to @var{sym}, or\n" + "@code{#f} if the binding does not live in a value cell.\n" + "The argument @var{for-write} indicates whether the caller\n" + "intends to modify the variable's value by mutating the value\n" + "cell. If the variable is immutable, then\n" + "@code{environment-cell} signals an\n" + "@code{environment:immutable-location} error.\n" + "If @var{sym} is unbound in @var{env}, signal an\n" + "@code{environment:unbound} error.\n" "If you use this function, you should consider using\n" - "environment-observe, to be notified when SYM gets re-bound to\n" - "a new value cell, or becomes undefined.") + "@code{environment-observe}, to be notified when @var{sym} gets\n" + "re-bound to a new value cell, or becomes undefined.") #define FUNC_NAME s_scm_environment_cell { SCM location; @@ -384,11 +399,12 @@ environment_default_observer (SCM env, SCM proc) SCM_DEFINE (scm_environment_observe, "environment-observe", 2, 0, 0, (SCM env, SCM proc), - "Whenever ENV's bindings change, apply PROC to ENV.\n" + "Whenever @var{env}'s bindings change, apply @var{proc} to\n" + "@var{env}.\n" "This function returns an object, token, which you can pass to\n" - "environment-unobserve to remove PROC from the set of\n" - "procedures observing ENV. The type and value of token is\n" - "unspecified.") + "@code{environment-unobserve} to remove @var{proc} from the set\n" + "of procedures observing @var{env}. The type and value of\n" + "token is unspecified.") #define FUNC_NAME s_scm_environment_observe { SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); @@ -401,9 +417,10 @@ SCM_DEFINE (scm_environment_observe, "environment-observe", 2, 0, 0, SCM_DEFINE (scm_environment_observe_weak, "environment-observe-weak", 2, 0, 0, (SCM env, SCM proc), "This function is the same as environment-observe, except that\n" - "the reference ENV retains to PROC is a weak reference. This\n" - "means that, if there are no other live, non-weak references\n" - "to PROC, it will be garbage-collected, and dropped from ENV's\n" + "the reference @var{env} retains to @var{proc} is a weak\n" + "reference. This means that, if there are no other live,\n" + "non-weak references to @var{proc}, it will be\n" + "garbage-collected, and dropped from @var{env}'s\n" "list of observing procedures.") #define FUNC_NAME s_scm_environment_observe_weak { @@ -436,10 +453,11 @@ scm_c_environment_observe (SCM env, scm_environment_observer proc, SCM data, int SCM_DEFINE (scm_environment_unobserve, "environment-unobserve", 1, 0, 0, (SCM token), "Cancel the observation request which returned the value\n" - "TOKEN. The return value is unspecified.\n" - "If a call (environment-observe env proc) returns token, then\n" - "the call (environment-unobserve token) will cause proc to no\n" - "longer be called when env's bindings change.") + "@var{token}. The return value is unspecified.\n" + "If a call @code{(environment-observe env proc)} returns\n" + "@var{token}, then the call @code{(environment-unobserve token)}\n" + "will cause @var{proc} to no longer be called when @var{env}'s\n" + "bindings change.") #define FUNC_NAME s_scm_environment_unobserve { SCM env; @@ -1041,7 +1059,8 @@ SCM_DEFINE (scm_make_leaf_environment, "make-leaf-environment", 0, 0, 0, SCM_DEFINE (scm_leaf_environment_p, "leaf-environment?", 1, 0, 0, (SCM object), - "Return #t if object is a leaf environment, or #f otherwise.") + "Return @code{#t} if object is a leaf environment, or @code{#f}\n" + "otherwise.") #define FUNC_NAME s_scm_leaf_environment_p { return SCM_BOOL (SCM_LEAF_ENVIRONMENT_P (object)); @@ -1388,22 +1407,26 @@ eval_environment_observer (SCM caller, SCM eval_env) SCM_DEFINE (scm_make_eval_environment, "make-eval-environment", 2, 0, 0, (SCM local, SCM imported), "Return a new environment object eval whose bindings are the\n" - "union of the bindings in the environments local and imported,\n" - "with bindings from local taking precedence. Definitions made\n" - "in eval are placed in local.\n" - "Applying environment-define or environment-undefine to eval\n" - "has the same effect as applying the procedure to local.\n" - "Note that eval incorporates local and imported by reference:\n" + "union of the bindings in the environments @var{local} and\n" + "@var{imported}, with bindings from @var{local} taking\n" + "precedence. Definitions made in eval are placed in @var{local}.\n" + "Applying @code{environment-define} or\n" + "@code{environment-undefine} to eval has the same effect as\n" + "applying the procedure to @var{local}.\n" + "Note that eval incorporates @var{local} and @var{imported} by\n" + "reference:\n" "If, after creating eval, the program changes the bindings of\n" - "local or imported, those changes will be visible in eval.\n" + "@var{local} or @var{imported}, those changes will be visible\n" + "in eval.\n" "Since most Scheme evaluation takes place in eval environments,\n" - "they transparenty cache the bindings received from local and\n" - "imported. Thus, the first time the program looks up a symbol\n" - "in eval, eval may make calls to local or imported to find\n" - "their bindings, but subsequent references to that symbol will\n" - "be as fast as references to bindings in finite environments.\n" - "In typical use, local will be a finite environment, and\n" - "imported will be an import environment") + "they transparently cache the bindings received from @var{local}\n" + "and @var{imported}. Thus, the first time the program looks up\n" + "a symbol in eval, eval may make calls to @var{local} or\n" + "@var{imported} to find their bindings, but subsequent\n" + "references to that symbol will be as fast as references to\n" + "bindings in finite environments.\n" + "In typical use, @var{local} will be a finite environment, and\n" + "@var{imported} will be an import environment") #define FUNC_NAME s_scm_make_eval_environment { SCM env; @@ -1439,7 +1462,8 @@ SCM_DEFINE (scm_make_eval_environment, "make-eval-environment", 2, 0, 0, SCM_DEFINE (scm_eval_environment_p, "eval-environment?", 1, 0, 0, (SCM object), - "Return #t if object is an eval environment, or #f otherwise.") + "Return @code{#t} if object is an eval environment, or @code{#f}\n" + "otherwise.") #define FUNC_NAME s_scm_eval_environment_p { return SCM_BOOL (SCM_EVAL_ENVIRONMENT_P (object)); @@ -1449,7 +1473,7 @@ SCM_DEFINE (scm_eval_environment_p, "eval-environment?", 1, 0, 0, SCM_DEFINE (scm_eval_environment_local, "eval-environment-local", 1, 0, 0, (SCM env), - "Return the local environment of eval environment env.") + "Return the local environment of eval environment @var{env}.") #define FUNC_NAME s_scm_eval_environment_local { SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); @@ -1461,7 +1485,7 @@ SCM_DEFINE (scm_eval_environment_local, "eval-environment-local", 1, 0, 0, SCM_DEFINE (scm_eval_environment_set_local_x, "eval-environment-set-local!", 2, 0, 0, (SCM env, SCM local), - "Change env's local environment to LOCAL.") + "Change @var{env}'s local environment to @var{local}.") #define FUNC_NAME s_scm_eval_environment_set_local_x { struct eval_environment *body; @@ -1487,7 +1511,7 @@ SCM_DEFINE (scm_eval_environment_set_local_x, "eval-environment-set-local!", 2, SCM_DEFINE (scm_eval_environment_imported, "eval-environment-imported", 1, 0, 0, (SCM env), - "Return the imported environment of eval environment env.") + "Return the imported environment of eval environment @var{env}.") #define FUNC_NAME s_scm_eval_environment_imported { SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); @@ -1499,7 +1523,7 @@ SCM_DEFINE (scm_eval_environment_imported, "eval-environment-imported", 1, 0, 0, SCM_DEFINE (scm_eval_environment_set_imported_x, "eval-environment-set-imported!", 2, 0, 0, (SCM env, SCM imported), - "Change env's imported environment to IMPORTED.") + "Change @var{env}'s imported environment to @var{imported}.") #define FUNC_NAME s_scm_eval_environment_set_imported_x { struct eval_environment *body; @@ -1795,28 +1819,31 @@ import_environment_observer (SCM caller, SCM import_env) SCM_DEFINE (scm_make_import_environment, "make-import-environment", 2, 0, 0, (SCM imports, SCM conflict_proc), - "Return a new environment imp whose bindings are the union of\n" - "the bindings from the environments in imports; imports must\n" - "be a list of environments. That is, imp binds symbol to\n" - "location when some element of imports does.\n" - "If two different elements of imports have a binding for the\n" - "same symbol, the conflict-proc is called with the following\n" - "parameters: the import environment, the symbol and the list\n" - "of the imported environments that bind the symbol. If the\n" - "conflict-proc returns an environment env, the conflict is\n" - "considered as resolved and the binding from env is used. If\n" - "the conflict-proc returns some non-environment object, the\n" - "conflict is considered unresolved and the symbol is treated\n" - "as unspecified in the import environment.\n" - "The checking for conflicts may be performed lazily, i. e. at\m" + "Return a new environment @var{imp} whose bindings are the union\n" + "of the bindings from the environments in @var{imports};\n" + "@var{imports} must be a list of environments. That is,\n" + "@var{imp} binds a symbol to a location when some element of\n" + "@var{imports} does.\n" + "If two different elements of @var{imports} have a binding for\n" + "the same symbol, the @var{conflict-proc} is called with the\n" + "following parameters: the import environment, the symbol and\n" + "the list of the imported environments that bind the symbol.\n" + "If the @var{conflict-proc} returns an environment @var{env},\n" + "the conflict is considered as resolved and the binding from\n" + "@var{env} is used. If the @var{conflict-proc} returns some\n" + "non-environment object, the conflict is considered unresolved\n" + "and the symbol is treated as unspecified in the import\n" + "environment.\n" + "The checking for conflicts may be performed lazily, i. e. at\n" "the moment when a value or binding for a certain symbol is\n" "requested instead of the moment when the environment is\n" "created or the bindings of the imports change.\n" - "All bindings in imp are immutable. If you apply\n" - "environment-define or environment-undefine to imp, Guile\n" - "will signal an environment:immutable-binding error. However,\n" - "notice that the set of bindings in imp may still change, if\n" - "one of its imported environments changes.") + "All bindings in @var{imp} are immutable. If you apply\n" + "@code{environment-define} or @code{environment-undefine} to\n" + "@var{imp}, Guile will signal an\n" + " @code{environment:immutable-binding} error. However,\n" + "notice that the set of bindings in @var{imp} may still change,\n" + "if one of its imported environments changes.") #define FUNC_NAME s_scm_make_import_environment { scm_sizet size = sizeof (struct import_environment); @@ -1844,7 +1871,8 @@ SCM_DEFINE (scm_make_import_environment, "make-import-environment", 2, 0, 0, SCM_DEFINE (scm_import_environment_p, "import-environment?", 1, 0, 0, (SCM object), - "Return #t if object is an import environment, or #f otherwise.") + "Return @code{#t} if object is an import environment, or\n" + "@code{#f} otherwise.") #define FUNC_NAME s_scm_import_environment_p { return SCM_BOOL (SCM_IMPORT_ENVIRONMENT_P (object)); @@ -1854,7 +1882,8 @@ SCM_DEFINE (scm_import_environment_p, "import-environment?", 1, 0, 0, SCM_DEFINE (scm_import_environment_imports, "import-environment-imports", 1, 0, 0, (SCM env), - "Return the list of environments imported by the import environment env.") + "Return the list of environments imported by the import\n" + "environment @var{env}.") #define FUNC_NAME s_scm_import_environment_imports { SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); @@ -1866,7 +1895,8 @@ SCM_DEFINE (scm_import_environment_imports, "import-environment-imports", 1, 0, SCM_DEFINE (scm_import_environment_set_imports_x, "import-environment-set-imports!", 2, 0, 0, (SCM env, SCM imports), - "Change env's list of imported environments to imports, and check for conflicts.") + "Change @var{env}'s list of imported environments to\n" + "@var{imports}, and check for conflicts.") #define FUNC_NAME s_scm_import_environment_set_imports_x { struct import_environment *body = IMPORT_ENVIRONMENT (env); @@ -2092,40 +2122,46 @@ export_environment_observer (SCM caller, SCM export_env) SCM_DEFINE (scm_make_export_environment, "make-export-environment", 2, 0, 0, (SCM private, SCM signature), - "Return a new environment exp containing only those bindings\n" - "in private whose symbols are present in signature. The\n" - "private argument must be an environment.\n\n" - "The environment exp binds symbol to location when env does,\n" - "and symbol is exported by signature.\n\n" - "Signature is a list specifying which of the bindings in\n" - "private should be visible in exp. Each element of signature\n" - "should be a list of the form:\n" + "Return a new environment @var{exp} containing only those\n" + "bindings in private whose symbols are present in\n" + "@var{signature}. The @var{private} argument must be an\n" + "environment.\n\n" + "The environment @var{exp} binds symbol to location when\n" + "@var{env} does, and symbol is exported by @var{signature}.\n\n" + "@var{signature} is a list specifying which of the bindings in\n" + "@var{private} should be visible in @var{exp}. Each element of\n" + "@var{signature} should be a list of the form:\n" " (symbol attribute ...)\n" "where each attribute is one of the following:\n" - "* the symbol mutable-location exp should treat the location\n" - " bound to symbol as mutable. That is, exp will pass calls\n" - " to env-set! or environment-cell directly through to\n" - " private.\n" - "* the symbol immutable-location exp should treat the\n" - " location bound to symbol as immutable. If the program\n" - " applies environment-set! to exp and symbol, or calls\n" - " environment-cell to obtain a writable value cell,\n" - " environment-set! will signal an\n" - " environment:immutable-location error. Note that, even if\n" - " an export environment treats a location as immutable, the\n" + "@table @asis\n" + "@item the symbol @code{mutable-location}\n" + " @var{exp} should treat the\n" + " location bound to symbol as mutable. That is, @var{exp}\n" + " will pass calls to @code{environment-set!} or\n" + " @code{environment-cell} directly through to private.\n" + "@item the symbol @code{immutable-location}\n" + " @var{exp} should treat\n" + " the location bound to symbol as immutable. If the program\n" + " applies @code{environment-set!} to @var{exp} and symbol, or\n" + " calls @code{environment-cell} to obtain a writable value\n" + " cell, @code{environment-set!} will signal an\n" + " @code{environment:immutable-location} error. Note that, even\n" + " if an export environment treats a location as immutable, the\n" " underlying environment may treat it as mutable, so its\n" " value may change.\n" + "@end table\n" "It is an error for an element of signature to specify both\n" - "mutable-location and immutable-location. If neither is\n" - "specified, immutable-location is assumed.\n\n" + "@code{mutable-location} and @code{immutable-location}. If\n" + "neither is specified, @code{immutable-location} is assumed.\n\n" "As a special case, if an element of signature is a lone\n" - "symbol sym, it is equivalent to an element of the form\n" - "(sym).\n\n" - "All bindings in exp are immutable. If you apply\n" - "environment-define or environment-undefine to exp, Guile\n" - "will signal an environment:immutable-binding error. However,\n" - "notice that the set of bindings in exp may still change, if\n" - "the bindings in private change.") + "symbol @var{sym}, it is equivalent to an element of the form\n" + "@code{(sym)}.\n\n" + "All bindings in @var{exp} are immutable. If you apply\n" + "@code{environment-define} or @code{environment-undefine} to\n" + "@var{exp}, Guile will signal an\n" + "@code{environment:immutable-binding} error. However,\n" + "notice that the set of bindings in @var{exp} may still change,\n" + "if the bindings in private change.") #define FUNC_NAME s_scm_make_export_environment { scm_sizet size; @@ -2159,7 +2195,8 @@ SCM_DEFINE (scm_make_export_environment, "make-export-environment", 2, 0, 0, SCM_DEFINE (scm_export_environment_p, "export-environment?", 1, 0, 0, (SCM object), - "Return #t if object is an export environment, or #f otherwise.") + "Return @code{#t} if object is an export environment, or\n" + "@code{#f} otherwise.") #define FUNC_NAME s_scm_export_environment_p { return SCM_BOOL (SCM_EXPORT_ENVIRONMENT_P (object)); @@ -2169,7 +2206,7 @@ SCM_DEFINE (scm_export_environment_p, "export-environment?", 1, 0, 0, SCM_DEFINE (scm_export_environment_private, "export-environment-private", 1, 0, 0, (SCM env), - "Return the private environment of export environment env.") + "Return the private environment of export environment @var{env}.") #define FUNC_NAME s_scm_export_environment_private { SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); @@ -2181,7 +2218,7 @@ SCM_DEFINE (scm_export_environment_private, "export-environment-private", 1, 0, SCM_DEFINE (scm_export_environment_set_private_x, "export-environment-set-private!", 2, 0, 0, (SCM env, SCM private), - "Change the private environment of export environment env.") + "Change the private environment of export environment @var{env}.") #define FUNC_NAME s_scm_export_environment_set_private_x { struct export_environment *body; @@ -2203,7 +2240,7 @@ SCM_DEFINE (scm_export_environment_set_private_x, "export-environment-set-privat SCM_DEFINE (scm_export_environment_signature, "export-environment-signature", 1, 0, 0, (SCM env), - "Return the signature of export environment env.") + "Return the signature of export environment @var{env}.") #define FUNC_NAME s_scm_export_environment_signature { SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); @@ -2277,7 +2314,7 @@ export_environment_parse_signature (SCM signature, const char* caller) SCM_DEFINE (scm_export_environment_set_signature_x, "export-environment-set-signature!", 2, 0, 0, (SCM env, SCM signature), - "Change the signature of export environment env.") + "Change the signature of export environment @var{env}.") #define FUNC_NAME s_scm_export_environment_set_signature_x { SCM parsed_sig; From e1546b65f8c38e35655f37e96c3988df429b7499 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Sat, 17 Feb 2001 11:33:42 +0000 Subject: [PATCH 0578/2047] (scm_drain_input): Lowercased argument to @var. (scm_current_input_port, scm_current_output_port): Filled in missing explanation. (scm_current_load_port, scm_set_current_output_port) (scm_set_current_error_port, scm_port_line, scm_set_port_line_x): Added texinfo markup. --- libguile/ports.c | 37 +++++++++++++++++++------------------ 1 file changed, 19 insertions(+), 18 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 1cc9058b7..85015d100 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -306,8 +306,8 @@ size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len) /* Clear a port's read buffers, returning the contents. */ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, (SCM port), - "Drains @var{PORT}'s read buffers (including any pushed-back characters)\n" - "and returns the contents as a single string.") + "Drain @var{port}'s read buffers (including any pushed-back\n" + "characters) and returns the content as a single string.") #define FUNC_NAME s_scm_drain_input { SCM result; @@ -331,10 +331,10 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, /* Standard ports --- current input, output, error, and more(!). */ SCM_DEFINE (scm_current_input_port, "current-input-port", 0, 0, 0, - (), - "Returns the current input port. This is the default port used by many\n" - "input procedures. Initially, @code{current-input-port} returns the\n" - "value of @code{???}.") + (), + "Return the current input port. This is the default port used\n" + "by many input procedures. Initially, @code{current-input-port}\n" + "returns the @dfn{standard input} in Unix and C terminology.") #define FUNC_NAME s_scm_current_input_port { return scm_cur_inp; @@ -342,10 +342,11 @@ SCM_DEFINE (scm_current_input_port, "current-input-port", 0, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_current_output_port, "current-output-port", 0, 0, 0, - (), - "Returns the current output port. This is the default port used by many\n" - "output procedures. Initially, @code{current-output-port} returns the\n" - "value of @code{???}.") + (), + "Return the current output port. This is the default port used\n" + "by many output procedures. Initially, \n" + "@code{current-output-port} returns the @dfn{standard output} in\n" + "Unix and C terminology.") #define FUNC_NAME s_scm_current_output_port { return scm_cur_outp; @@ -363,9 +364,9 @@ SCM_DEFINE (scm_current_error_port, "current-error-port", 0, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_current_load_port, "current-load-port", 0, 0, 0, - (), + (), "Return the current-load-port.\n" - "The load port is used internally by `primitive-load'.") + "The load port is used internally by @code{primitive-load}.") #define FUNC_NAME s_scm_current_load_port { return scm_cur_loadp; @@ -390,8 +391,8 @@ SCM_DEFINE (scm_set_current_input_port, "set-current-input-port", 1, 0, 0, SCM_DEFINE (scm_set_current_output_port, "set-current-output-port", 1, 0, 0, - (SCM port), - "Set the current default output port to PORT.") + (SCM port), + "Set the current default output port to @var{port}.") #define FUNC_NAME s_scm_set_current_output_port { SCM ooutp = scm_cur_outp; @@ -404,8 +405,8 @@ SCM_DEFINE (scm_set_current_output_port, "set-current-output-port", 1, 0, 0, SCM_DEFINE (scm_set_current_error_port, "set-current-error-port", 1, 0, 0, - (SCM port), - "Set the current default error port to PORT.") + (SCM port), + "Set the current default error port to @var{port}.") #define FUNC_NAME s_scm_set_current_error_port { SCM oerrp = scm_cur_errp; @@ -1284,7 +1285,7 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, SCM_DEFINE (scm_port_line, "port-line", 1, 0, 0, (SCM port), - "Return the current line number for PORT.") + "Return the current line number for @var{port}.") #define FUNC_NAME s_scm_port_line { port = SCM_COERCE_OUTPORT (port); @@ -1295,7 +1296,7 @@ SCM_DEFINE (scm_port_line, "port-line", 1, 0, 0, SCM_DEFINE (scm_set_port_line_x, "set-port-line!", 2, 0, 0, (SCM port, SCM line), - "Set the current line number for PORT to LINE.") + "Set the current line number for @var{port} to @var{line}.") #define FUNC_NAME s_scm_set_port_line_x { port = SCM_COERCE_OUTPORT (port); From cb87e06ae60b6ca482fbbc20bbf3df5dc5bf4cb3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Sat, 17 Feb 2001 11:34:26 +0000 Subject: [PATCH 0579/2047] (scm_make_arbiter, scm_try_arbiter) (scm_release_arbiter): Added texinfo markup to docstrings. Changed `Returns' to `Return'. (arbiter_print): Changed SCM_CDR to SCM_SMOB_DATA. --- libguile/arbiters.c | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/libguile/arbiters.c b/libguile/arbiters.c index 073d80bb6..c388dfaf0 100644 --- a/libguile/arbiters.c +++ b/libguile/arbiters.c @@ -73,15 +73,16 @@ arbiter_print (SCM exp, SCM port, scm_print_state *pstate) scm_puts ("#', port); return !0; } SCM_DEFINE (scm_make_arbiter, "make-arbiter", 1, 0, 0, - (SCM name), -"Returns an object of type arbiter and name name. Its state is initially unlocked.\n" -"Arbiters are a way to achieve process synchronization.") + (SCM name), + "Return an object of type arbiter and name @var{name}. Its\n" + "state is initially unlocked. Arbiters are a way to achieve\n" + "process synchronization.") #define FUNC_NAME s_scm_make_arbiter { SCM_RETURN_NEWSMOB (scm_tc16_arbiter, SCM_UNPACK (name)); @@ -89,11 +90,12 @@ SCM_DEFINE (scm_make_arbiter, "make-arbiter", 1, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_try_arbiter, "try-arbiter", 1, 0, 0, - (SCM arb), -"Returns #t and locks arbiter if arbiter was unlocked. Otherwise, returns #f.") + (SCM arb), + "Return @code{#t} and lock the arbiter @var{arb} if the arbiter\n" + "was unlocked. Otherwise, return @code{#f}.") #define FUNC_NAME s_scm_try_arbiter { - SCM_VALIDATE_SMOB (1,arb,arbiter); + SCM_VALIDATE_SMOB (1, arb, arbiter); SCM_DEFER_INTS; if (SCM_ARB_LOCKED(arb)) arb = SCM_BOOL_F; @@ -109,12 +111,13 @@ SCM_DEFINE (scm_try_arbiter, "try-arbiter", 1, 0, 0, SCM_DEFINE (scm_release_arbiter, "release-arbiter", 1, 0, 0, - (SCM arb), -"Returns #t and unlocks arbiter if arbiter was locked. Otherwise, returns #f.") + (SCM arb), + "Return @code{#t} and unlock the arbiter @var{arb} if the\n" + "arbiter was locked. Otherwise, return @code{#f}.") #define FUNC_NAME s_scm_release_arbiter { - SCM_VALIDATE_SMOB (1,arb,arbiter); - if (! SCM_ARB_LOCKED(arb)) + SCM_VALIDATE_SMOB (1, arb, arbiter); + if (!SCM_ARB_LOCKED(arb)) return SCM_BOOL_F; SCM_UNLOCK_ARB (arb); return SCM_BOOL_T; From 7090240cf4c3b81a60da5a7483fef8cfbb3da84a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Sat, 17 Feb 2001 11:36:16 +0000 Subject: [PATCH 0580/2047] *** empty log message *** --- libguile/ChangeLog | 43 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 67db1d438..fac1930cd 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,46 @@ +2001-02-17 Martin Grabmueller + + * variable.c (scm_make_variable, scm_make_undefined_variable) + (scm_variable_ref, scm_variable_set_x, scm_builtin_variable) + (scm_variable_bound_p), values.c (scm_values) + (scm_call_with_values), unif.c (scm_bit_count) + (scm_bit_set_star_x), symbols.c (scm_gentemp) + (scm_gensym), strings.c (scm_string_p, scm_make_string) + (scm_read_only_string_p, scm_string_length, scm_string_ref) + (scm_string_set_x, scm_substring, scm_string_append), stime.c + (scm_strptime, scm_mktime), random.c (scm_seed_to_random_state) + (scm_copy_random_state, scm_random), print.c (scm_newline) + (scm_write_char, scm_simple_format), debug-malloc.c + (scm_malloc_stats), environments.c (scm_environment_p) + (scm_environment_bound_p, scm_environment_ref) + (scm_environment_fold, scm_environment_define) + (scm_environment_undefine, scm_environment_set_x) + (scm_environment_cell, scm_environment_observe) + (scm_environment_observe_weak, scm_environment_unobserve) + (scm_make_eval_environment, scm_eval_environment_p) + (scm_eval_environment_set_local_x, scm_eval_environment_local) + (scm_eval_environment_imported) + (scm_eval_environment_set_imported_x, scm_make_import_environment) + (scm_import_environment_p, scm_import_environment_imports) + (scm_import_environment_set_imports_x, scm_make_export_environment) + (scm_export_environment_p, scm_export_environment_private) + (scm_export_environment_set_private_x) + (scm_export_environment_signature) + (scm_export_environment_set_signature_x, scm_leaf_environment_p): + Added texinfo markup. + + * ports.c (scm_drain_input): Lowercased argument to @var. + (scm_current_input_port, scm_current_output_port): Filled in + missing explanation. + (scm_current_load_port, scm_set_current_output_port) + (scm_set_current_error_port, scm_port_line, scm_set_port_line_x): + Added texinfo markup. + + * arbiters.c (scm_make_arbiter, scm_try_arbiter) + (scm_release_arbiter): Added texinfo markup to docstrings. + Changed `Returns' to `Return'. + (arbiter_print): Changed SCM_CDR to SCM_SMOB_DATA. + 2001-02-16 Neil Jerram * guile-snarf.awk.in: Quote any `@'s that occur in Scheme names, From 9a42b923cf6666d0517da11ddb03763fd7ed992b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 21 Feb 2001 20:11:18 +0000 Subject: [PATCH 0581/2047] Added copyright notice. --- ice-9/popen.scm | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/ice-9/popen.scm b/ice-9/popen.scm index eca3dfe26..b8214abb7 100644 --- a/ice-9/popen.scm +++ b/ice-9/popen.scm @@ -1,5 +1,23 @@ ;; popen emulation, for non-stdio based ports. +;;;; Copyright (C) 1998, 1999, 2000 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; + (define-module (ice-9 popen)) ;; (define-module (guile popen) From 7b748b16491e8b971e06676e96f2a1c042fa8427 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 21 Feb 2001 20:11:44 +0000 Subject: [PATCH 0582/2047] * boot-9.scm (eval-when, eval-case): Renamed `eval-when' to `eval-case', everywhere. --- ice-9/boot-9.scm | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 672234887..718cfeac8 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -2511,22 +2511,22 @@ `(lambda ,(cdr first) ,@rest)))) `(define ,name (defmacro:syntax-transformer ,transformer)))) -;; EVAL-WHEN +;; EVAL-CASE ;; -;; (eval-when ((situation*) forms)* (else forms)?) +;; (eval-case ((situation*) forms)* (else forms)?) ;; -;; Evaluate certain code based on the situation that eval-when is used +;; Evaluate certain code based on the situation that eval-case is used ;; in. The only defined situation right now is `load-toplevel' which ;; triggers for code evaluated at the top-level, for example from the ;; REPL or when loading a file. -(define eval-when +(define eval-case (procedure->memoizing-macro (lambda (exp env) (define (toplevel-env? env) (or (not (pair? env)) (not (pair? (car env))))) (define (syntax) - (error "syntax error in eval-when")) + (error "syntax error in eval-case")) (let loop ((clauses (cdr exp))) (cond ((null? clauses) @@ -2550,7 +2550,7 @@ ;;; (defmacro define-module args - `(eval-when + `(eval-case ((load-toplevel) (process-define-module ',args)) (else @@ -2567,14 +2567,14 @@ (reverse module-names))) (defmacro use-modules modules - `(eval-when + `(eval-case ((load-toplevel) (process-use-modules ',modules)) (else (error "use-modules can only be used at the top level")))) (defmacro use-syntax (spec) - `(eval-when + `(eval-case ((load-toplevel) ,@(if (pair? spec) `((process-use-modules ',(list spec)) @@ -2601,7 +2601,7 @@ (#t (let ((name (defined-name (car args)))) `(begin - (eval-when ((load-toplevel) (export ,name))) + (eval-case ((load-toplevel) (export ,name))) (define-private ,@args)))))) (defmacro defmacro-public args @@ -2617,7 +2617,7 @@ (#t (let ((name (defined-name (car args)))) `(begin - (eval-when ((load-toplevel) (export ,name))) + (eval-case ((load-toplevel) (export ,name))) (defmacro ,@args)))))) (define (module-export! m names) @@ -2630,7 +2630,7 @@ names))) (defmacro export names - `(eval-when + `(eval-case ((load-toplevel) (module-export! (current-module) ',names)) (else From b8d69b374c1d85df35aa59666252dad4367c978f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 21 Feb 2001 20:12:17 +0000 Subject: [PATCH 0583/2047] *** empty log message *** --- ice-9/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index d2f021a06..23b1fd988 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2001-02-16 Marius Vollmer + + * boot-9.scm (eval-when, eval-case): Renamed `eval-when' to + `eval-case', everywhere. + 2001-02-13 Marius Vollmer * boot-9.scm (define-public): Removed spurious call to From e37a4fbae1bdc6f6fb831bb1247b0d8746c2c967 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 21 Feb 2001 20:14:47 +0000 Subject: [PATCH 0584/2047] * eval.c (scm_ceval, scm_deval): Check for wrong number of args before applying arrow procedure in `cond' and before applying receiver procedure in call-with-current-continuation. (scm_i_eval): Do not invoke scm_copy_tree in argument in SCM_XEVAL macro. The argument is expanded more than one time. --- libguile/eval.c | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/libguile/eval.c b/libguile/eval.c index 016f37a46..5b15619a2 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2005,6 +2005,8 @@ dispatch: SCM_ASRTGO (SCM_NIMP (proc), badfun); PREP_APPLY (proc, scm_cons (t.arg1, SCM_EOL)); ENTER_APPLY; + if (scm_badformalsp (proc, 1)) + goto umwrongnumargs; goto evap1; } } @@ -2215,6 +2217,8 @@ dispatch: SCM_ASRTGO (SCM_NIMP (proc), badfun); PREP_APPLY (proc, scm_cons (t.arg1, SCM_EOL)); ENTER_APPLY; + if (scm_badformalsp (proc, 1)) + goto umwrongnumargs; goto evap1; case (SCM_ISYMNUM (SCM_IM_DELAY)): @@ -3863,7 +3867,8 @@ scm_i_eval (SCM exp, SCM env) SCM transformer = scm_fluid_ref (SCM_CDR (scm_system_transformer)); if (SCM_NIMP (transformer)) exp = scm_apply (transformer, exp, scm_listofnull); - return SCM_XEVAL (scm_copy_tree (exp), env); + exp = scm_copy_tree (exp); + return SCM_XEVAL (exp, env); } SCM From d6a35f3f610ca2630614d1180b0f37fbf90296fa Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 21 Feb 2001 20:15:15 +0000 Subject: [PATCH 0585/2047] Added copyright and licence notice. --- libguile/guile-doc-snarf.in | 17 +++++++++++++++++ libguile/guile-func-name-check.in | 18 ++++++++++++++++++ libguile/guile-snarf.awk.in | 17 +++++++++++++++++ libguile/guile-snarf.in | 17 +++++++++++++++++ 4 files changed, 69 insertions(+) diff --git a/libguile/guile-doc-snarf.in b/libguile/guile-doc-snarf.in index cce78ed89..fa84c589f 100755 --- a/libguile/guile-doc-snarf.in +++ b/libguile/guile-doc-snarf.in @@ -1,5 +1,22 @@ #!/bin/sh # Extract the initialization actions for builtin things. +# +# Copyright (C) 1999, 2000 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 +# the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +# the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +# Boston, MA 02111-1307 USA fullfilename=$1; shift diff --git a/libguile/guile-func-name-check.in b/libguile/guile-func-name-check.in index 6516e468c..da1435192 100644 --- a/libguile/guile-func-name-check.in +++ b/libguile/guile-func-name-check.in @@ -1,4 +1,22 @@ #!/usr/bin/awk -f +# +# Copyright (C) 2000 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 +# the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +# the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +# Boston, MA 02111-1307 USA +# # Written by Greg J. Badros, # 11-Jan-2000 diff --git a/libguile/guile-snarf.awk.in b/libguile/guile-snarf.awk.in index 3fbe217d9..5c045fcf3 100644 --- a/libguile/guile-snarf.awk.in +++ b/libguile/guile-snarf.awk.in @@ -1,3 +1,20 @@ +# Copyright (C) 1999, 2000 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 +# the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +# the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +# Boston, MA 02111-1307 USA +# # Written by Greg J. Badros, # 12-Dec-1999 diff --git a/libguile/guile-snarf.in b/libguile/guile-snarf.in index a606b440b..d41f34c70 100644 --- a/libguile/guile-snarf.in +++ b/libguile/guile-snarf.in @@ -1,5 +1,22 @@ #!/bin/sh # Extract the initialization actions for builtin things. +# +# Copyright (C) 1996, 1997, 1998, 1999, 2000 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 +# the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +# the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +# Boston, MA 02111-1307 USA temp="/tmp/snarf.$$" trap "rm -f $temp" 0 1 2 15 From 134ec96519701d8187584f0bea2a5470bdec5970 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 21 Feb 2001 20:16:05 +0000 Subject: [PATCH 0586/2047] * numbers.c (scm_logior) [SCM_DIGSTOOBIG]: Correctly use SCM_BIGDIG instead of BIGDIG. Thanks to Steven G. Johnson! --- libguile/numbers.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 5541aa5c0..4c5d5be36 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -859,7 +859,7 @@ SCM_DEFINE1 (scm_logior, "logior", scm_tc7_asubr, (nn1 < 0) ? SCM_BIGSIGNFLAG : 0, n2, SCM_BIGSIGNFLAG); } # else - BIGDIG zdigs [DIGSPERLONG]; + SCM_BIGDIG zdigs [DIGSPERLONG]; scm_longdigs (nn1, zdigs); if ((!(nn1 < 0)) && !SCM_BIGSIGN (n2)) { return scm_big_ior (zdigs, SCM_DIGSPERLONG, From 09f2ab1e04847b05e676edf5de9a13bbc4d05c9f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 21 Feb 2001 20:19:31 +0000 Subject: [PATCH 0587/2047] *** empty log message *** --- libguile/ChangeLog | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index fac1930cd..91b6dd5b7 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,19 @@ +2001-02-21 Marius Vollmer + + * eval.c (scm_ceval, scm_deval): Check for wrong number of args + before applying arrow procedure in `cond' and before applying + receiver procedure in call-with-current-continuation. + (scm_i_eval): Do not invoke scm_copy_tree in argument in SCM_XEVAL + macro. The argument is expanded more than one time. + + * numbers.c (scm_logior) [SCM_DIGSTOOBIG]: Correctly use + SCM_BIGDIG instead of BIGDIG. Thanks to Steven G. Johnson! + +2001-02-20 Marius Vollmer + + * guile-doc-snarf.in, guile-func-name-check.in: Added copyright + notice and license. + 2001-02-17 Martin Grabmueller * variable.c (scm_make_variable, scm_make_undefined_variable) From afdd97aed1cbbc0883e2b961ae3dd94c92e12754 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 21 Feb 2001 22:51:23 +0000 Subject: [PATCH 0588/2047] Added copyright and license notice. --- HACKING | 17 +++++++++++++++++ INSTALL | 18 ++++++++++++++++++ 2 files changed, 35 insertions(+) diff --git a/HACKING b/HACKING index 17f3fd7bf..3aac223ae 100644 --- a/HACKING +++ b/HACKING @@ -1,3 +1,20 @@ +Guile Hacking Guide +Copyright (c) 1996, 1997, 1998, 1999, 2000 Free software Foundation, Inc. + + Permission is granted to anyone to make or distribute verbatim copies + of this document as received, in any medium, provided that the + copyright notice and permission notice are preserved, + and that the distributor grants the recipient permission + for further redistribution as permitted by this notice. + + Permission is granted to distribute modified versions + of this document, or of portions of it, + under the above conditions, provided also that they + carry prominent notices stating who last changed them, + and that any new or changed statements about the activities + of the Free Software Foundation are approved by the Foundation. + + Hacking It Yourself ================================================== As distributed, Guile needs only an ANSI C compiler and a Unix system diff --git a/INSTALL b/INSTALL index c884b5061..c96d81917 100644 --- a/INSTALL +++ b/INSTALL @@ -1,3 +1,20 @@ +Guile Installation Guide +Copyright (c) 1996, 1997, 1998, 1999, 2000 Free software Foundation, Inc. + + Permission is granted to anyone to make or distribute verbatim copies + of this document as received, in any medium, provided that the + copyright notice and permission notice are preserved, + and that the distributor grants the recipient permission + for further redistribution as permitted by this notice. + + Permission is granted to distribute modified versions + of this document, or of portions of it, + under the above conditions, provided also that they + carry prominent notices stating who last changed them, + and that any new or changed statements about the activities + of the Free Software Foundation are approved by the Foundation. + + Brief Installation Instructions =========================================== To build Guile on unix, there are two basic steps: @@ -249,3 +266,4 @@ Makefile(s), the header file containing system-dependent definitions The file `configure.in' is used as a template to create `configure' by a program called `autoconf'. You will only need it if you want to regenerate `configure' using a newer version of `autoconf'. + From a820af98a7525b4eb968646bb2d1b7b578508c86 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 21 Feb 2001 22:52:59 +0000 Subject: [PATCH 0589/2047] Only check number of arguments for closures, see last change. I just love this evaluator, man. --- libguile/eval.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index 5b15619a2..22ee142ee 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2005,7 +2005,7 @@ dispatch: SCM_ASRTGO (SCM_NIMP (proc), badfun); PREP_APPLY (proc, scm_cons (t.arg1, SCM_EOL)); ENTER_APPLY; - if (scm_badformalsp (proc, 1)) + if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1)) goto umwrongnumargs; goto evap1; } @@ -2217,7 +2217,7 @@ dispatch: SCM_ASRTGO (SCM_NIMP (proc), badfun); PREP_APPLY (proc, scm_cons (t.arg1, SCM_EOL)); ENTER_APPLY; - if (scm_badformalsp (proc, 1)) + if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1)) goto umwrongnumargs; goto evap1; From 5fa207514c8be28dacae27b5851f3802a4c6d976 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 22 Feb 2001 09:25:03 +0000 Subject: [PATCH 0590/2047] * numbers.c (s_scm_logior) [SCM_DIGSTOOBIG]: Also use SCM_DIGSPERLONG instead of DIGSPERLONG. --- libguile/numbers.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 4c5d5be36..816ad3d34 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -859,7 +859,7 @@ SCM_DEFINE1 (scm_logior, "logior", scm_tc7_asubr, (nn1 < 0) ? SCM_BIGSIGNFLAG : 0, n2, SCM_BIGSIGNFLAG); } # else - SCM_BIGDIG zdigs [DIGSPERLONG]; + SCM_BIGDIG zdigs [SCM_DIGSPERLONG]; scm_longdigs (nn1, zdigs); if ((!(nn1 < 0)) && !SCM_BIGSIGN (n2)) { return scm_big_ior (zdigs, SCM_DIGSPERLONG, From b42ff180903838650e2f6c0ba1fee55640e5a76b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 22 Feb 2001 09:25:32 +0000 Subject: [PATCH 0591/2047] *** empty log message *** --- libguile/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 91b6dd5b7..76befe376 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-02-22 Marius Vollmer + + * numbers.c (s_scm_logior) [SCM_DIGSTOOBIG]: Also use + SCM_DIGSPERLONG instead of DIGSPERLONG. + 2001-02-21 Marius Vollmer * eval.c (scm_ceval, scm_deval): Check for wrong number of args From f1b7a06676950dd77c6d81f205fd52f59cfac3a6 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 22 Feb 2001 20:52:46 +0000 Subject: [PATCH 0592/2047] * load.c (load): Use scm_primtive_eval_x instead of scm_i_eval_x. --- libguile/load.c | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/libguile/load.c b/libguile/load.c index 71a661d37..5002be721 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -97,14 +97,7 @@ load (void *data) SCM form = scm_read (port); if (SCM_EOF_OBJECT_P (form)) break; - /* Ugh! We need to re-check the environment for every form. - * We should change this in the new module system. - */ - scm_i_eval_x (form, - scm_module_system_booted_p - ? (scm_top_level_env - (SCM_MODULE_EVAL_CLOSURE (scm_current_module ()))) - : SCM_EOL); + scm_primitive_eval_x (form); } return SCM_UNSPECIFIED; } From 0ba8a0a583a0411cbf261f6fa076ecfdf62ce78d Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 22 Feb 2001 20:53:55 +0000 Subject: [PATCH 0593/2047] * goops.c (scm_add_method, DEFVAR): Use scm_eval instead of scm_i_eval. (make_class_from_template): Do not bother to set the current module around the call to DEFVAR, scm_eval takes care of that. (scm_init_goops): Make scm_module_goops and scm_goops_lookup_closure permanent objects. --- libguile/goops.c | 22 +++++++++------------- 1 file changed, 9 insertions(+), 13 deletions(-) diff --git a/libguile/goops.c b/libguile/goops.c index aa7a00e15..b2ae4ee20 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -75,8 +75,8 @@ #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers) #define DEFVAR(v,val) \ -{ scm_i_eval (SCM_LIST3 (scm_sym_define_public, (v), (val)), \ - scm_top_level_env (scm_goops_lookup_closure)); } +{ scm_eval (SCM_LIST3 (scm_sym_define_public, (v), (val)), \ + scm_module_goops); } /* Temporary hack until we get the new module system */ /*fixme* Should optimize by keeping track of the variable object itself */ #define GETVAR(v) (SCM_CDDR (scm_apply (scm_goops_lookup_closure, \ @@ -2326,15 +2326,7 @@ make_class_from_template (char *template, char *type_name, SCM supers) && SCM_FALSEP (scm_apply (scm_goops_lookup_closure, SCM_LIST2 (name, SCM_BOOL_F), SCM_EOL))) - { - /* Make sure we add the binding in the GOOPS module. - * This kludge is needed until DEFVAR ceases to use `define-public' - * or `define-public' ceases to use `current-module'. - */ - SCM old_module = scm_set_current_module (scm_module_goops); - DEFVAR (name, class); - scm_set_current_module (old_module); - } + DEFVAR (name, class); return class; } @@ -2594,8 +2586,7 @@ SCM_SYMBOL (sym_internal_add_method_x, "internal-add-method!"); void scm_add_method (SCM gf, SCM m) { - scm_i_eval (SCM_LIST3 (sym_internal_add_method_x, gf, m), - scm_top_level_env (scm_goops_lookup_closure)); + scm_eval (SCM_LIST3 (sym_internal_add_method_x, gf, m), scm_module_goops); } #ifdef GUILE_DEBUG @@ -2645,6 +2636,11 @@ scm_init_goops (void) scm_goops_lookup_closure = scm_module_lookup_closure (scm_module_goops); + /* Not really necessary right now, but who knows... + */ + scm_permanent_object (scm_module_goops); + scm_permanent_object (scm_goops_lookup_closure); + scm_components = scm_permanent_object (scm_make_weak_key_hash_table (SCM_MAKINUM (37))); From 23c46fa69a0e5491ef6d36b01d48954e528b19dd Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 22 Feb 2001 20:54:12 +0000 Subject: [PATCH 0594/2047] * eval.c (scm_ceval, scm_deval): When evaluating expressions on top level, create a fresh top-level environment for each expression instead of mutating the exisint frame. This is important when that frame is closed over. --- libguile/eval.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index 22ee142ee..2b245f1b5 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1913,12 +1913,12 @@ dispatch: t.arg1 = x; while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) { - SCM_SETCAR (env, scm_current_module_lookup_closure ()); + env = scm_top_level_env (scm_current_module_lookup_closure ()); SIDEVAL (SCM_CAR(x), env); x = t.arg1; } /* once more, for the last form */ - SCM_SETCAR (env, scm_current_module_lookup_closure ()); + env = scm_top_level_env (scm_current_module_lookup_closure ()); } else { From 97ea55f832fb04302e858aaad5a85cc949d3eb76 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 22 Feb 2001 20:54:36 +0000 Subject: [PATCH 0595/2047] *** empty log message *** --- libguile/ChangeLog | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 76befe376..568506faf 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,19 @@ 2001-02-22 Marius Vollmer + * load.c (load): Use scm_primtive_eval_x instead of scm_i_eval_x. + + * goops.c (scm_add_method, DEFVAR): Use scm_eval instead of + scm_i_eval. + (make_class_from_template): Do not bother to set the current + module around the call to DEFVAR, scm_eval takes care of that. + (scm_init_goops): Make scm_module_goops and + scm_goops_lookup_closure permanent objects. + + * eval.c (scm_ceval, scm_deval): When evaluating expressions on + top level, create a fresh top-level environment for each + expression instead of mutating the exisint frame. This is + important when that frame is closed over. + * numbers.c (s_scm_logior) [SCM_DIGSTOOBIG]: Also use SCM_DIGSPERLONG instead of DIGSPERLONG. From cf7b149fabfad3ab9bc51e7d67f04934e057ea63 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 23 Feb 2001 02:36:54 +0000 Subject: [PATCH 0596/2047] Initial revision. --- test-suite/tests/exceptions.test | 200 +++++++++++++++++++++++++++++++ 1 file changed, 200 insertions(+) create mode 100644 test-suite/tests/exceptions.test diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test new file mode 100644 index 000000000..36ca14557 --- /dev/null +++ b/test-suite/tests/exceptions.test @@ -0,0 +1,200 @@ +;;;; exceptions.test -*- scheme -*- +;;;; Copyright (C) 2001 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. + +;;;; Commentary: + +;;; All tests should use `expect-exception' (aliased to `goad' for +;;; brevity). Tests that fail (i.e., do NOT cause exception should be +;;; marked with a preceding line "no exception on DATE", where DATE is +;;; when you found the failure. If guile is fixed so that the test +;;; passes, do not delete the comment, but instead append "fixed on +;;; DATE" w/ the fix date. If the test itself changes (due to a change +;;; in the specification, for example), append "test amended on DATE" +;;; and some explanatory text. You can delete comments (and move the +;;; test up into the clump of uncommented tests) when the dates become +;;; very old. + +;;;; Code: + +(use-modules (test-suite lib) (ice-9 regex) (ice-9 common-list)) + +(defmacro expect-exception (name-snippet expression) + `(pass-if (with-output-to-string + (lambda () + (for-each display + (list + "`" + (let ((x (symbol->string ',name-snippet))) + (substring x 2 (string-length x))) + "' expected but not thrown: ")) + (write ',expression))) + (catch #t + (lambda () ,expression #f) ; conniving falsehood! + (lambda args + ;; squeeze value to `#t' + (not (notany (lambda (x) + (and (string? x) + (string-match ,name-snippet x))) + args)))))) + +(define goad expect-exception) + +;; Exception messages +;; Ideally, we would mine these out of libguile/error.[hc], etc. +;; (Someday, when guile is re-implemented in Scheme....) + +(define x:unbound-var "[Uu]nbound variable") +(define x:bad-var "[Bb]ad variable") +(define x:bad-formals "[Bb]ad formals") +(define x:bad-bindings "[Bb]ad bindings") +(define x:bad-body "[Bb]ad body") +(define x:bad/missing-clauses "[Bb]ad or missing clauses") +(define x:missing/extra-expr "[Mm]issing or extra expression") +(define x:wrong-num-args "[Ww]rong number of arguments") +(define x:wrong-type-arg "[Ww]rong type argument") + +;; This is to encourage people to write tests. + +(define x:hm "[Hh]m") ;-D + (define x:bad "[Bb]ad") ;-D + (define x:sick "[Ss]ick") ;-D + (define x:wrong "[Ww]rong") ;-D + (define x:stupid "[Ss]tupid") ;-D + (define x:strange "[Ss]trange") ;-D + (define x:unlikely "[Uu]nlikely") ;-D + (define x:inelegant "[Ii]nelegant") ;-D + (define x:suboptimal "[Ss]uboptimal") ;-D + (define x:bletcherous "[Bb]letcherous") ;-D h a t - t h e - ?!? + +;; Tests + +(with-test-prefix "syntax" + (with-test-prefix "let" + (goad x:bad-body (let)) + (goad x:bad-body (let 1)) + (goad x:bad-body (let ())) + (goad x:bad-body (let (x))) + (goad x:bad-bindings (let (x) 1)) ; maybe these should go under bindings? + (goad x:bad-bindings (let ((x)) 3)) + (goad x:bad-bindings (let ((x 1) y) x)) + (goad x:bad-body (let x ())) + (goad x:bad-body (let x (y))) + + ;; no exception on 2001-02-22 + (goad x:bad-bindings (let ((x 1) (x 2)) x)) + + ;; Add more (syntax let) exceptions here. + ) + (with-test-prefix "cond" + (goad x:bad/missing-clauses (cond)) + (goad x:bad/missing-clauses (cond #t)) + (goad x:bad/missing-clauses (cond 1)) + (goad x:bad/missing-clauses (cond 1 2)) + (goad x:bad/missing-clauses (cond 1 2 3)) + (goad x:bad/missing-clauses (cond 1 2 3 4)) + (goad x:bad/missing-clauses (cond ())) + (goad x:bad/missing-clauses (cond () 1)) + (goad x:bad/missing-clauses (cond (1) 1)) + ;; Add more (syntax cond) exceptions here. + ) + (with-test-prefix "if" + (goad x:missing/extra-expr (if)) + (goad x:missing/extra-expr (if 1 2 3 4)) + ;; Add more (syntax if) exceptions here. + ) + (with-test-prefix "define" + (goad x:missing/extra-expr (define)) + ;; Add more (syntax define) exceptions here. + ) + ;; Add more (syntax) exceptions here. + ) + +(with-test-prefix "bindings" + (goad x:unbound-var unlikely-to-be-bound) + (goad x:bad-var (set! "some-string" #t)) + (goad x:bad-var (set! 1 #t)) + (goad x:bad-var (set! #t #f)) + (goad x:bad-var (set! #f #t)) + (goad x:bad-var (set! #\space 'the-final-frontier)) + (goad x:wrong-type-arg (set! (symbol->string 'safe) 1)) + (goad x:wrong-type-arg (set! '"abc" 1)) ; from r5rs + (goad x:bad-var (set! "abc" 1)) + (goad x:wrong-type-arg (set! '145932 1)) + (goad x:bad-var (set! 145932 1)) + (goad x:wrong-type-arg (set! '#t 1)) + (goad x:wrong-type-arg (set! '#f 1)) + (goad x:bad-body (let)) + (goad x:bad-var (let ((1 2)) 3)) + + ;; no exception on 2001-02-22 + (goad x:bad-var (string-set! (symbol->string 'abc) 1 #\space)) + ;; no exception on 2001-02-22 + (goad x:bad-var (string-set! "abc" 1 #\space)) + + ;; Add more (bindings) exceptions here. + ) + +(with-test-prefix "lambda" + + (goad x:bad-formals (lambda (x 1) 2)) + (goad x:bad-formals (lambda (1 x) 2)) + (goad x:bad-formals (lambda (x "a") 2)) + (goad x:bad-formals (lambda ("a" x) 2)) + (goad x:bad-formals (lambda (x x) 1)) + (goad x:bad-formals (lambda (x x x) 1)) + + (with-test-prefix "cond-arrow-proc" + (goad x:bad-formals (cond (1 => (lambda (x 1) 2)))) + ;; Add more (lambda cond-arrow-proc) exceptions here. + ) + + ;; Add more (lambda) exceptions here. + ) + +(with-test-prefix "application" + (goad x:wrong-type-arg (+ 1 #f)) + (goad x:wrong-type-arg (+ "1" 2)) + (goad x:wrong-num-args (let ((x (lambda (a b) (+ a b)))) (x 3))) + ;; Add more (application) exceptions here. + ) + +;;; exceptions.test ends here From 8fbe69980ef0ef15c6ea33e6cc7ec247b422eb5b Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 23 Feb 2001 02:39:43 +0000 Subject: [PATCH 0597/2047] *** empty log message *** --- test-suite/ChangeLog | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 973038dd9..d58a14123 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2001-02-22 Thien-Thi Nguyen + + * tests/exceptions.test: New file. + 2001-02-08 Marius Vollmer * guile-test: Use (ice-9 and-let-star) instead of (ice-9 @@ -197,7 +201,7 @@ Fri Dec 17 12:14:10 1999 Greg J. Badros * tests/c-api.test: Refine the list of files that are checked in the seek-offset-test. Was just using files that end in "c", but - that caught the new ".doc" files, too, so make sure that files end + that caught the new ".doc" files, too, so make sure that files end in ".c" before requiring that they include unistd.h if they reference SEEK_(SET|CUR|END). @@ -219,7 +223,7 @@ Fri Dec 17 12:14:10 1999 Greg J. Badros * tests/reader.test: Check that number->string checks its radix properly. - + 1999-09-20 Jim Blandy * tests/ports.test: Check that our input functions cope when From c1ce8ca203d96d7cfb4713b07783959d2faefb27 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 23 Feb 2001 10:19:35 +0000 Subject: [PATCH 0598/2047] (syntax lambda): Renamed from (lambda). (syntax lambda cond-arrow-proc): Renamed from (lambda cond-arrow-proc). (syntax reading): New section. (syntax let*): New section. (syntax letrec): New section. (syntax set!): New section. (syntax misc): New section. (bindings unbound): New section. (bindings immutable-modification): New section. (bindings let): New section. (bindings let*): New section. (bindings letrec): New section. --- test-suite/tests/exceptions.test | 182 +++++++++++++++++++++++-------- 1 file changed, 137 insertions(+), 45 deletions(-) diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test index 36ca14557..dbb2ea7c5 100644 --- a/test-suite/tests/exceptions.test +++ b/test-suite/tests/exceptions.test @@ -52,11 +52,17 @@ ;;; and some explanatory text. You can delete comments (and move the ;;; test up into the clump of uncommented tests) when the dates become ;;; very old. +;;; +;;; By convention, test-prefix strings have no whitespace. This makes +;;; change log entries more regular. ;;;; Code: (use-modules (test-suite lib) (ice-9 regex) (ice-9 common-list)) +(define (read-string s) + (with-input-from-string s (lambda () (read)))) + (defmacro expect-exception (name-snippet expression) `(pass-if (with-output-to-string (lambda () @@ -65,7 +71,7 @@ "`" (let ((x (symbol->string ',name-snippet))) (substring x 2 (string-length x))) - "' expected but not thrown: ")) + "' expected: ")) (write ',expression))) (catch #t (lambda () ,expression #f) ; conniving falsehood! @@ -91,6 +97,8 @@ (define x:missing/extra-expr "[Mm]issing or extra expression") (define x:wrong-num-args "[Ww]rong number of arguments") (define x:wrong-type-arg "[Ww]rong type argument") +(define x:eof "[Ee]nd of file") +(define x:unexpected-rparen "[Uu]nexpected \")\"") ;; This is to encourage people to write tests. @@ -108,22 +116,69 @@ ;; Tests (with-test-prefix "syntax" + (with-test-prefix "reading" + (goad x:eof (read-string "(")) + (goad x:unexpected-rparen (read-string ")")) + (goad x:eof (read-string "#(")) + (goad x:unexpected-rparen (read-string ")")) + ;; Add more (syntax reading) exceptions here. + ) + (with-test-prefix "lambda" + + (goad x:bad-formals (lambda (x 1) 2)) + (goad x:bad-formals (lambda (1 x) 2)) + (goad x:bad-formals (lambda (x "a") 2)) + (goad x:bad-formals (lambda ("a" x) 2)) + + ;; no exception on 2001-02-22 + (goad x:bad-formals (lambda (x x) 1)) + ;; no exception on 2001-02-22 + (goad x:bad-formals (lambda (x x x) 1)) + + (with-test-prefix "cond-arrow-proc" + (goad x:bad-formals (cond (1 => (lambda (x 1) 2)))) + ;; Add more (syntax lambda cond-arrow-proc) exceptions here. + ) + + ;; Add more (syntax lambda) exceptions here. + ) + ;; Below, A1,B1 different from A2,B2 because A1,B1 are "named let". (with-test-prefix "let" (goad x:bad-body (let)) (goad x:bad-body (let 1)) (goad x:bad-body (let ())) (goad x:bad-body (let (x))) - (goad x:bad-bindings (let (x) 1)) ; maybe these should go under bindings? + (goad x:bad-bindings (let (x) 1)) (goad x:bad-bindings (let ((x)) 3)) (goad x:bad-bindings (let ((x 1) y) x)) - (goad x:bad-body (let x ())) - (goad x:bad-body (let x (y))) - - ;; no exception on 2001-02-22 - (goad x:bad-bindings (let ((x 1) (x 2)) x)) - + (goad x:bad-body (let x ())) ; A1 + (goad x:bad-body (let x (y))) ; B1 ;; Add more (syntax let) exceptions here. ) + (with-test-prefix "let*" + (goad x:bad-body (let*)) + (goad x:bad-body (let* 1)) + (goad x:bad-body (let* ())) + (goad x:bad-body (let* (x))) + (goad x:bad-bindings (let* (x) 1)) + (goad x:bad-bindings (let* ((x)) 3)) + (goad x:bad-bindings (let* ((x 1) y) x)) + (goad x:bad-bindings (let* x ())) ; A2 + (goad x:bad-bindings (let* x (y))) ; B2 + ;; Add more (syntax let*) exceptions here. + ) + (with-test-prefix "letrec" + (goad x:bad-body (letrec)) + (goad x:bad-body (letrec 1)) + (goad x:bad-body (letrec ())) + (goad x:bad-body (letrec (x))) + (goad x:bad-bindings (letrec (x) 1)) + (goad x:bad-bindings (letrec ((x)) 3)) + (goad x:bad-bindings (letrec ((x 1) y) x)) + (goad x:bad-bindings (letrec x ())) ; A2 + (goad x:bad-bindings (letrec x (y))) ; B2 + ;; Add more (syntax letrec) exceptions here. + ) (with-test-prefix "cond" (goad x:bad/missing-clauses (cond)) (goad x:bad/missing-clauses (cond #t)) @@ -145,49 +200,82 @@ (goad x:missing/extra-expr (define)) ;; Add more (syntax define) exceptions here. ) + (with-test-prefix "set!" + (goad x:missing/extra-expr (set!)) + (goad x:missing/extra-expr (set! 1)) + (goad x:missing/extra-expr (set! 1 2 3)) + ;; Add more (syntax set!) exceptions here. + ) + (with-test-prefix "misc" + (goad x:missing/extra-expr (quote)) + + ;; no exception on 2001-02-22 + ;; R5RS says: + ;; *Note:* In many dialects of Lisp, the empty combination, (), + ;; is a legitimate expression. In Scheme, combinations must + ;; have at least one subexpression, so () is not a syntactically + ;; valid expression. + (goad x:missing/extra-expr ()) + + ;; Add more (syntax misc) exceptions here. + ) ;; Add more (syntax) exceptions here. ) (with-test-prefix "bindings" - (goad x:unbound-var unlikely-to-be-bound) - (goad x:bad-var (set! "some-string" #t)) - (goad x:bad-var (set! 1 #t)) - (goad x:bad-var (set! #t #f)) - (goad x:bad-var (set! #f #t)) - (goad x:bad-var (set! #\space 'the-final-frontier)) - (goad x:wrong-type-arg (set! (symbol->string 'safe) 1)) - (goad x:wrong-type-arg (set! '"abc" 1)) ; from r5rs - (goad x:bad-var (set! "abc" 1)) - (goad x:wrong-type-arg (set! '145932 1)) - (goad x:bad-var (set! 145932 1)) - (goad x:wrong-type-arg (set! '#t 1)) - (goad x:wrong-type-arg (set! '#f 1)) - (goad x:bad-body (let)) - (goad x:bad-var (let ((1 2)) 3)) - - ;; no exception on 2001-02-22 - (goad x:bad-var (string-set! (symbol->string 'abc) 1 #\space)) - ;; no exception on 2001-02-22 - (goad x:bad-var (string-set! "abc" 1 #\space)) - - ;; Add more (bindings) exceptions here. - ) - -(with-test-prefix "lambda" - - (goad x:bad-formals (lambda (x 1) 2)) - (goad x:bad-formals (lambda (1 x) 2)) - (goad x:bad-formals (lambda (x "a") 2)) - (goad x:bad-formals (lambda ("a" x) 2)) - (goad x:bad-formals (lambda (x x) 1)) - (goad x:bad-formals (lambda (x x x) 1)) - - (with-test-prefix "cond-arrow-proc" - (goad x:bad-formals (cond (1 => (lambda (x 1) 2)))) - ;; Add more (lambda cond-arrow-proc) exceptions here. + (with-test-prefix "unbound" + (goad x:unbound-var unlikely-to-be-bound) + (goad x:unbound-var (unlikely-to-be-bound)) + ;; Add more (bindings unbound) exceptions here. ) + (with-test-prefix "immutable-modification" + (goad x:bad-var (set! "some-string" #t)) + (goad x:bad-var (set! 1 #t)) + (goad x:bad-var (set! #t #f)) + (goad x:bad-var (set! #f #t)) + (goad x:bad-var (set! #\space 'the-final-frontier)) + (goad x:wrong-type-arg (set! (symbol->string 'safe) 1)) + (goad x:wrong-type-arg (set! '"abc" 1)) ; from r5rs + (goad x:bad-var (set! "abc" 1)) + (goad x:wrong-type-arg (set! '145932 1)) + (goad x:bad-var (set! 145932 1)) + (goad x:wrong-type-arg (set! '#t 1)) + (goad x:wrong-type-arg (set! '#f 1)) - ;; Add more (lambda) exceptions here. + ;; no exception on 2001-02-22 + (goad x:bad-var (string-set! (symbol->string 'abc) 1 #\space)) + ;; no exception on 2001-02-22 + (goad x:bad-var (string-set! "abc" 1 #\space)) + + ;; Add more (bindings immutable-modification) exceptions here. + ) + (with-test-prefix "let" + (goad x:bad-var (let ((1 2)) 3)) + (goad x:unbound-var (let ((x 1) (y x)) y)) + + ;; no exception on 2001-02-22 + (goad x:bad-bindings (let ((x 1) (x 2)) x)) + + ;; Add more (bindings let) exceptions here. + ) + (with-test-prefix "let*" + (goad x:bad-var (let* ((1 2)) 3)) + + ;; no exception on 2001-02-22 + (goad x:bad-bindings (let* ((x 1) (x 2)) x)) + + ;; Add more (bindings let*) exceptions here. + ) + (with-test-prefix "letrec" + (goad x:bad-var (letrec ((1 2)) 3)) + (goad x:unbound-var (letrec ((x 1) (y x)) y)) + + ;; no exception on 2001-02-22 + (goad x:bad-bindings (letrec ((x 1) (x 2)) x)) + + ;; Add more (bindings letrec) exceptions here. + ) + ;; Add more (bindings) exceptions here. ) (with-test-prefix "application" @@ -197,4 +285,8 @@ ;; Add more (application) exceptions here. ) +;; Local variables: +;; eval: (put 'with-test-prefix 'scheme-indent-function 1) +;; End: + ;;; exceptions.test ends here From 5d7aab2e0de2e666ee09fe565c754f31f54460cc Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 23 Feb 2001 10:24:37 +0000 Subject: [PATCH 0599/2047] *** empty log message *** --- test-suite/ChangeLog | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index d58a14123..e797d4ce0 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,5 +1,18 @@ 2001-02-22 Thien-Thi Nguyen + * tests/exceptions.test (syntax lambda): Renamed from (lambda). + (syntax lambda cond-arrow-proc): Renamed from (lambda cond-arrow-proc). + (syntax reading): New section. + (syntax let*): New section. + (syntax letrec): New section. + (syntax set!): New section. + (syntax misc): New section. + (bindings unbound): New section. + (bindings immutable-modification): New section. + (bindings let): New section. + (bindings let*): New section. + (bindings letrec): New section. + * tests/exceptions.test: New file. 2001-02-08 Marius Vollmer From 19b6a58d523d0d407b9256290007ba92740c5569 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 23 Feb 2001 13:07:09 +0000 Subject: [PATCH 0600/2047] * goops.scm (method): Enclosed BODY by `(let () ...)'. This allows local defines at the beginning of methods. --- oop/ChangeLog | 5 +++++ oop/goops.scm | 6 +++--- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/oop/ChangeLog b/oop/ChangeLog index c9536231d..09dae3c64 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -1,3 +1,8 @@ +2001-02-23 Keisuke Nishida + + * goops.scm (method): Enclosed BODY by `(let () ...)'. + This allows local defines at the beginning of methods. + 2000-12-15 Dirk Herrmann * goops/save.scm (load-objects): eval-in-module is deprecated. diff --git a/oop/goops.scm b/oop/goops.scm index 3de529e66..b2405b283 100644 --- a/oop/goops.scm +++ b/oop/goops.scm @@ -487,9 +487,9 @@ `(make #:specializers (list* ,@(specializers args)) #:procedure (lambda ,(formals args) - ,@(if (null? body) - (list *unspecified*) - body)))))))) + ,(if (null? body) + *unspecified* + `(let () ,@body))))))))) ;;; ;;; {add-method!} From 2069af383559bce324c4ce26ae5ef605b4efb7ad Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 23 Feb 2001 20:24:15 +0000 Subject: [PATCH 0601/2047] * Minor docstring updates. --- libguile/ChangeLog | 10 +- libguile/dump.c | 636 ------------------------------------------- libguile/eval.c | 2 +- libguile/fports.c | 2 +- libguile/guardians.c | 14 +- 5 files changed, 18 insertions(+), 646 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 568506faf..bf2cb43ae 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,6 +1,13 @@ +2001-02-23 Neil Jerram + + * dump.c (scm_binary_write, scm_binary_read), eval.c + (scm_primitive_eval), guardians.c (scm_guardian_destroyed_p, + scm_guardian_greedy_p, scm_make_guardian), fports.c + (scm_file_port_p): Minor docstring fixes. + 2001-02-22 Marius Vollmer - * load.c (load): Use scm_primtive_eval_x instead of scm_i_eval_x. + * load.c (load): Use scm_primitive_eval_x instead of scm_i_eval_x. * goops.c (scm_add_method, DEFVAR): Use scm_eval instead of scm_i_eval. @@ -33,6 +40,7 @@ * guile-doc-snarf.in, guile-func-name-check.in: Added copyright notice and license. +>>>>>>> 1.1281 2001-02-17 Martin Grabmueller * variable.c (scm_make_variable, scm_make_undefined_variable) diff --git a/libguile/dump.c b/libguile/dump.c index 12c42bd41..e69de29bb 100644 --- a/libguile/dump.c +++ b/libguile/dump.c @@ -1,636 +0,0 @@ -/* Copyright (C) 2001 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 - * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ - - - -#include -#include -#include -#include -#include - -#include "libguile/_scm.h" -#include "libguile/tags.h" -#include "libguile/root.h" -#include "libguile/alist.h" -#include "libguile/smob.h" -#include "libguile/ports.h" -#include "libguile/fports.h" -#include "libguile/strings.h" -#include "libguile/hashtab.h" -#include "libguile/vectors.h" -#include "libguile/validate.h" -#include "libguile/dump.h" - -#define SCM_DUMP_COOKIE "\x7fGBF-0.1" - -#define SCM_DUMP_HASH_SIZE 151 -#define SCM_DUMP_IMAGE_SIZE 4096 - -#define SCM_DUMP_INDEX_TO_WORD(x) ((scm_bits_t) ((x) << 3)) -#define SCM_DUMP_WORD_TO_INDEX(x) ((long) ((x) >> 3)) - -struct scm_dump_header { - scm_bits_t cookie; /* cookie string */ - scm_bits_t version; /* version string */ - scm_bits_t nobjs; /* the number of objects */ - /* or immediate value */ -}; - - -/* - * Dump state - */ - -static scm_bits_t scm_tc16_dstate; - -struct scm_dstate { - int mmapped; - scm_sizet image_size; - int image_index; - char *image_base; /* Memory image */ - int table_index; - SCM table; /* Object table */ - SCM task; /* Update task */ -}; - -#define SCM_DSTATE_DATA(d) ((struct scm_dstate *) SCM_SMOB_DATA (d)) -#define SCM_DSTATE_TABLE(d) (SCM_DSTATE_DATA (d)->table) -#define SCM_DSTATE_TABLE_REF(d,i) (SCM_VELTS (SCM_DSTATE_TABLE (d))[i]) -#define SCM_DSTATE_TABLE_SET(d,i,x) (SCM_VELTS (SCM_DSTATE_TABLE (d))[i] = (x)) -#define SCM_DSTATE_TASK(d) (SCM_DSTATE_DATA (d)->task) - -#define SCM_DTASK_ID(t) ((scm_bits_t) SCM_CELL_WORD_1 (t)) -#define SCM_DTASK_ADDR(t) ((scm_bits_t *) SCM_CELL_WORD_2 (t)) -#define SCM_DTASK_NEXT(t) (SCM_CELL_OBJECT_3 (t)) -#define SCM_SET_DTASK_ID(t,x) SCM_SET_CELL_WORD_1 (t, x) -#define SCM_SET_DTASK_ADDR(t,x) SCM_SET_CELL_WORD_2 (t, x) -#define SCM_SET_DTASK_NEXT(t,x) SCM_SET_CELL_OBJECT_3 (t, x) - -static SCM -make_dstate () -#define FUNC_NAME "make_dstate" -{ - struct scm_dstate *p = SCM_MUST_MALLOC (sizeof (struct scm_dstate)); - p->mmapped = 0; - p->image_size = SCM_DUMP_IMAGE_SIZE; - p->image_index = 0; - p->image_base = SCM_MUST_MALLOC (p->image_size); - p->table_index = 0; - p->table = SCM_BOOL_F; - p->task = SCM_EOL; - SCM_RETURN_NEWSMOB (scm_tc16_dstate, p); -} -#undef FUNC_NAME - -static SCM -make_dstate_by_mmap (int fd) -#define FUNC_NAME "make_dstate_by_mmap" -{ - int ret; - char *addr; - struct stat st; - struct scm_dstate *p = SCM_MUST_MALLOC (sizeof (struct scm_dstate)); - - SCM_SYSCALL (ret = fstat (fd, &st)); - if (ret < 0) - SCM_SYSERROR; - - SCM_SYSCALL (addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0)); - if (addr == MAP_FAILED) - SCM_SYSERROR; - - p->mmapped = 1; - p->image_size = st.st_size; - p->image_index = 0; - p->image_base = addr; - p->table_index = 0; - p->table = SCM_BOOL_F; - p->task = SCM_EOL; - SCM_RETURN_NEWSMOB (scm_tc16_dstate, p); -} -#undef FUNC_NAME - -static SCM -dstate_mark (SCM obj) -{ - SCM task; - struct scm_dstate *p = SCM_DSTATE_DATA (obj); - for (task = p->task; !SCM_NULLP (task); task = SCM_DTASK_NEXT (task)) - scm_gc_mark (task); - return p->table; -} - -static scm_sizet -dstate_free (SCM obj) -#define FUNC_NAME "dstate_free" -{ - int size = sizeof (struct scm_dstate); - struct scm_dstate *p = SCM_DSTATE_DATA (obj); - - /* Free dump image */ - if (p->mmapped) - { - int rv; - SCM_SYSCALL (rv = munmap (p->image_base, p->image_size)); - if (rv < 0) - SCM_SYSERROR; - } - else - { - size += p->image_size; - if (p->image_base) - scm_must_free (p->image_base); - } - - scm_must_free (p); - return size; -} -#undef FUNC_NAME - -static void -dstate_extend (struct scm_dstate *p) -{ - scm_sizet old_size = p->image_size; - p->image_size *= 2; - p->image_base = scm_must_realloc (p->image_base, - old_size, - p->image_size, - "dstate_extend"); -} - - -/* - * Object indicator - */ - -static scm_bits_t -scm_object_indicator (SCM obj, SCM dstate) -{ - if (SCM_IMP (obj)) - { - return SCM_UNPACK (obj); - } - else - { - SCM id = scm_hashq_ref (SCM_DSTATE_TABLE (dstate), obj, SCM_BOOL_F); - if (SCM_FALSEP (id)) - return -1; - else - return SCM_DUMP_INDEX_TO_WORD (SCM_INUM (id)); - } -} - -static SCM -scm_indicator_object (scm_bits_t word, SCM dstate) -{ - if (SCM_IMP (SCM_PACK (word))) - return SCM_PACK (word); - else - return SCM_DSTATE_TABLE_REF (dstate, SCM_DUMP_WORD_TO_INDEX (word)); -} - - -/* - * Dump interface - */ - -/* store functions */ - -static void -scm_store_pad (SCM dstate) -{ - struct scm_dstate *p = SCM_DSTATE_DATA (dstate); - while (p->image_index + sizeof (scm_bits_t) >= p->image_size) - dstate_extend (p); - while (p->image_index % sizeof (scm_bits_t) != 0) - p->image_base[p->image_index++] = '\0'; -} - -void -scm_store_word (const scm_bits_t word, SCM dstate) -{ - struct scm_dstate *p = SCM_DSTATE_DATA (dstate); - while (p->image_index + sizeof (scm_bits_t) >= p->image_size) - dstate_extend (p); - memcpy (p->image_base + p->image_index, &word, sizeof (scm_bits_t)); - p->image_index += sizeof (scm_bits_t); -} - -void -scm_store_bytes (const void *addr, scm_sizet size, SCM dstate) -{ - struct scm_dstate *p = SCM_DSTATE_DATA (dstate); - scm_store_word (size, dstate); - while (p->image_index + size + sizeof (scm_bits_t) >= p->image_size) - dstate_extend (p); - memcpy (p->image_base + p->image_index, addr, size); - p->image_index += size; - scm_store_pad (dstate); -} - -void -scm_store_string (const char *addr, scm_sizet size, SCM dstate) -{ - struct scm_dstate *p = SCM_DSTATE_DATA (dstate); - while (p->image_index + size + 1 >= p->image_size) - dstate_extend (p); - memcpy (p->image_base + p->image_index, addr, size); - memcpy (p->image_base + p->image_index + size, "\0", 1); - p->image_index += size + 1; - scm_store_pad (dstate); -} - -void -scm_store_object (SCM obj, SCM dstate) -{ - scm_bits_t id = scm_object_indicator (obj, dstate); - if (id == -1) - { - /* OBJ is not stored yet. Do it later */ - struct scm_dstate *p = SCM_DSTATE_DATA (dstate); - SCM task; - SCM_NEWCELL2 (task); - SCM_SET_DTASK_ID (task, SCM_UNPACK (obj)); - SCM_SET_DTASK_ADDR (task, p->image_index); - SCM_SET_DTASK_NEXT (task, p->task); - p->task = task; - } - scm_store_word (id, dstate); -} - -/* restore functions */ - -static void -scm_restore_pad (struct scm_dstate *p) -{ - while (p->image_index % sizeof (scm_bits_t) != 0) - p->image_index++; -} - -void -scm_restore_word (scm_bits_t *wordp, SCM dstate) -{ - struct scm_dstate *p = SCM_DSTATE_DATA (dstate); - *wordp = *(scm_bits_t *) (p->image_base + p->image_index); - p->image_index += sizeof (scm_bits_t); -} - -void -scm_restore_bytes (const void **pp, scm_sizet *sizep, SCM dstate) -{ - scm_bits_t size; - struct scm_dstate *p = SCM_DSTATE_DATA (dstate); - scm_restore_word (&size, dstate); - if (sizep) - *sizep = size; - *pp = p->image_base + p->image_index; - p->image_index += size; - scm_restore_pad (p); -} - -void -scm_restore_string (const char **pp, scm_sizet *sizep, SCM dstate) -{ - int len; - struct scm_dstate *p = SCM_DSTATE_DATA (dstate); - *pp = p->image_base + p->image_index; - len = strlen (*pp); - if (sizep) - *sizep = len; - p->image_index += len + 1; - scm_restore_pad (p); -} - -void -scm_restore_object (SCM *objp, SCM dstate) -{ - scm_bits_t id; - scm_restore_word (&id, dstate); - *objp = scm_indicator_object (id, dstate); - - if (SCM_UNBNDP (*objp)) - { - struct scm_dstate *p = SCM_DSTATE_DATA (dstate); - SCM task; - SCM_NEWCELL2 (task); - SCM_SET_DTASK_ID (task, id); - SCM_SET_DTASK_ADDR (task, objp); - SCM_SET_DTASK_NEXT (task, p->task); - p->task = task; - } -} - - -/* - * Dump routine - */ - -static void -scm_dump (SCM obj, SCM dstate) -{ - struct scm_dstate *p = SCM_DSTATE_DATA (dstate); - - /* Check if immediate or already dumpped */ - if (scm_object_indicator (obj, dstate) != -1) - return; - - /* Mark it */ - scm_hashq_set_x (p->table, obj, SCM_MAKINUM (p->table_index)); - p->table_index++; - - if (SCM_SLOPPY_CONSP (obj)) - { - scm_store_word (scm_tc3_cons, dstate); - /* Store cdr first in order to avoid a possible deep recursion - * with a long list */ - scm_store_object (SCM_CDR (obj), dstate); - scm_store_object (SCM_CAR (obj), dstate); - goto next_dump; - } - switch (SCM_TYP7 (obj)) - { - case scm_tc7_symbol: - { - scm_store_word (scm_tc7_symbol, dstate); - scm_store_string (SCM_SYMBOL_CHARS (obj), - SCM_SYMBOL_LENGTH (obj), - dstate); - return; - } - case scm_tc7_substring: - case scm_tc7_string: - { - scm_store_word (scm_tc7_string, dstate); - scm_store_string (SCM_STRING_CHARS (obj), - SCM_STRING_LENGTH (obj), - dstate); - return; - } - case scm_tc7_vector: - { - int i; - scm_bits_t len = SCM_VECTOR_LENGTH (obj); - SCM *base = SCM_VELTS (obj); - scm_store_word (scm_tc7_vector, dstate); - scm_store_word (len, dstate); - for (i = 0; i < len; i++) - scm_store_object (base[i], dstate); - goto next_dump; - } - case scm_tc7_smob: - { - void (*dump) () = SCM_SMOB_DESCRIPTOR (obj).dump; - if (!dump) - goto error; - - /* FIXME: SCM_CELL_TYPE may change when undump!! */ - scm_store_word (SCM_CELL_TYPE (obj), dstate); - dump (obj, dstate); - goto next_dump; - } - default: - error: - scm_misc_error ("scm_dump_mark", "Cannot dump: ~A", SCM_LIST1 (obj)); - } - - next_dump: - { - SCM task; - for (task = p->task; !SCM_NULLP (task); task = SCM_DTASK_NEXT (task)) - { - SCM obj = SCM_PACK (SCM_DTASK_ID (task)); - scm_dump (obj, dstate); - *(scm_bits_t *) (p->image_base + (int) SCM_DTASK_ADDR (task)) = - scm_object_indicator (obj, dstate); - } - } -} - -static void -scm_undump (SCM dstate) -{ - struct scm_dstate *p = SCM_DSTATE_DATA (dstate); - scm_bits_t tc; - SCM obj; - - scm_restore_word (&tc, dstate); - - if (SCM_ITAG3 (SCM_PACK (tc)) == scm_tc3_cons) - { - SCM_NEWCELL (obj); - /* cdr was stored first */ - scm_restore_object (SCM_CDRLOC (obj), dstate); - scm_restore_object (SCM_CARLOC (obj), dstate); - goto store_object; - } - - switch (SCM_ITAG7 (SCM_PACK (tc))) - { - case scm_tc7_symbol: - { - scm_sizet len; - const char *mem; - scm_restore_string (&mem, &len, dstate); - obj = scm_mem2symbol (mem, len); - goto store_object; - } - case scm_tc7_string: - { - scm_sizet len; - const char *mem; - scm_restore_string (&mem, &len, dstate); - obj = scm_makfromstr (mem, len, 0); - goto store_object; - } - case scm_tc7_vector: - { - int i; - scm_bits_t len; - SCM *base; - scm_restore_word (&len, dstate); - obj = scm_c_make_vector (len, SCM_BOOL_F); - base = SCM_VELTS (obj); - for (i = 0; i < len; i++) - scm_restore_object (&base[i], dstate); - goto store_object; - } - case scm_tc7_smob: - { - SCM (*undump) () = scm_smobs[SCM_TC2SMOBNUM (tc)].undump; - if (!undump) - goto error; - obj = undump (dstate); - goto store_object; - } - default: - error: - scm_misc_error ("scm_undump", "Cannot undump", SCM_EOL); - } - - store_object: - SCM_DSTATE_TABLE_SET (dstate, p->table_index, obj); - p->table_index++; -} - - -/* - * Scheme interface - */ - -SCM_DEFINE (scm_binary_write, "binary-write", 1, 1, 0, - (SCM obj, SCM port), - "Write OBJ to PORT in a binary format.") -#define FUNC_NAME s_scm_binary_write -{ - struct scm_dstate *p; - struct scm_dump_header header; - SCM dstate; - - /* Check port */ - if (SCM_UNBNDP (port)) - port = scm_cur_outp; - else - SCM_VALIDATE_OUTPUT_PORT (2, port); - - /* Dump objects */ - dstate = make_dstate (); - p = SCM_DSTATE_DATA (dstate); - p->table = scm_c_make_hash_table (SCM_DUMP_HASH_SIZE); - scm_dump (obj, dstate); - - /* Write image */ - header.cookie = ((scm_bits_t *) SCM_DUMP_COOKIE)[0]; - header.version = ((scm_bits_t *) SCM_DUMP_COOKIE)[1]; - header.nobjs = (p->table_index - ? SCM_DUMP_INDEX_TO_WORD (p->table_index) - : SCM_UNPACK (obj)); - scm_lfwrite ((const char *) &header, sizeof (struct scm_dump_header), port); - if (p->image_index) - scm_lfwrite (p->image_base, p->image_index, port); - - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_binary_read, "binary-read", 0, 1, 0, - (SCM port), - "Read an object from PORT in a binary format.") -#define FUNC_NAME s_scm_binary_read -{ - int i, nobjs; - struct scm_dstate *p; - struct scm_dump_header *header; - SCM dstate; - - /* Check port */ - if (SCM_UNBNDP (port)) - port = scm_cur_inp; - else - SCM_VALIDATE_INPUT_PORT (1, port); - - /* Initialize */ - if (SCM_FPORTP (port)) - /* Undump with mmap */ - dstate = make_dstate_by_mmap (SCM_FPORT_FDES (port)); - else - /* Undump with malloc */ - SCM_MISC_ERROR ("Not supported yet", SCM_EOL); - p = SCM_DSTATE_DATA (dstate); - - /* Read header */ - header = (struct scm_dump_header *) p->image_base; - p->image_index += sizeof (struct scm_dump_header); - if (p->image_size < sizeof (*header)) - SCM_MISC_ERROR ("Invalid binary format: ~A", SCM_LIST1 (port)); - if (header->cookie != ((scm_bits_t *) SCM_DUMP_COOKIE)[0]) - SCM_MISC_ERROR ("Invalid binary format: ~A", SCM_LIST1 (port)); - if (header->version != ((scm_bits_t *) SCM_DUMP_COOKIE)[1]) - SCM_MISC_ERROR ("Unsupported binary version: ~A", SCM_LIST1 (port)); - - /* Check for immediate */ - if (SCM_IMP (SCM_PACK (header->nobjs))) - return SCM_PACK (header->nobjs); - - /* Create object table */ - nobjs = SCM_DUMP_WORD_TO_INDEX (header->nobjs); - p->table = scm_c_make_vector (nobjs, SCM_UNDEFINED); - - /* Undump */ - for (i = 0; i < nobjs; i++) - scm_undump (dstate); - - /* Update references */ - { - SCM task; - for (task = p->task; !SCM_NULLP (task); task = SCM_DTASK_NEXT (task)) - { - *SCM_DTASK_ADDR (task) = - SCM_UNPACK (scm_indicator_object (SCM_DTASK_ID (task), dstate)); - } - } - - /* Return */ - { - SCM obj = SCM_DSTATE_TABLE_REF (dstate, 0); - p->table = SCM_BOOL_F; - return obj; - } -} -#undef FUNC_NAME - - -void -scm_init_dump () -{ - scm_tc16_dstate = scm_make_smob_type ("dstate", 0); - scm_set_smob_mark (scm_tc16_dstate, dstate_mark); - scm_set_smob_free (scm_tc16_dstate, dstate_free); -#ifndef SCM_MAGIC_SNARFER -#include "libguile/dump.x" -#endif -} - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ diff --git a/libguile/eval.c b/libguile/eval.c index 2b245f1b5..bc9491d6b 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3880,7 +3880,7 @@ scm_primitive_eval_x (SCM exp) SCM_DEFINE (scm_primitive_eval, "primitive-eval", 1, 0, 0, (SCM exp), - "Evaluate @var{epx} in the top-level environment specified by\n" + "Evaluate @var{exp} in the top-level environment specified by\n" "the current module.") #define FUNC_NAME s_scm_primitive_eval { diff --git a/libguile/fports.c b/libguile/fports.c index b71107104..06dae4e6c 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -229,7 +229,7 @@ scm_evict_ports (int fd) SCM_DEFINE (scm_file_port_p, "file-port?", 1, 0, 0, (SCM obj), - "Determine whether OBJ is a port that is related to a file.") + "Determine whether @var{obj} is a port that is related to a file.") #define FUNC_NAME s_scm_file_port_p { return SCM_BOOL (SCM_FPORTP (obj)); diff --git a/libguile/guardians.c b/libguile/guardians.c index 4a2200f2b..fbecd9d9c 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -313,17 +313,17 @@ SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 1, 0, "A guardian protects a set of objects from garbage collection,\n" "allowing a program to apply cleanup or other actions.\n\n" - "make-guardian returns a procedure representing the guardian.\n" + "@code{make-guardian} returns a procedure representing the guardian.\n" "Calling the guardian procedure with an argument adds the\n" "argument to the guardian's set of protected objects.\n" "Calling the guardian procedure without an argument returns\n" "one of the protected objects which are ready for garbage\n" - "collection or @code{#f} if no such object is available.\n" + "collection, or @code{#f} if no such object is available.\n" "Objects which are returned in this way are removed from\n" "the guardian.\n\n" - "make-guardian takes one optional argument that says whether the\n" - "new guardian should be greedy or sharing. if there is any chance\n" + "@code{make-guardian} takes one optional argument that says whether the\n" + "new guardian should be greedy or sharing. If there is any chance\n" "that any object protected by the guardian may be resurrected,\n" "then you should make the guardian greedy (this is the default).\n\n" @@ -361,7 +361,7 @@ SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 1, 0, SCM_DEFINE (scm_guardian_destroyed_p, "guardian-destroyed?", 1, 0, 0, (SCM guardian), - "Is @var{guardian} destroyed?") + "Return @code{#t} if @var{guardian} has been destroyed, otherwise @code{#f}.") #define FUNC_NAME s_scm_guardian_destroyed_p { SCM res = SCM_BOOL_F; @@ -377,9 +377,9 @@ SCM_DEFINE (scm_guardian_destroyed_p, "guardian-destroyed?", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_guardian_greedy_p, "guardian_greedy?", 1, 0, 0, +SCM_DEFINE (scm_guardian_greedy_p, "guardian-greedy?", 1, 0, 0, (SCM guardian), - "Is @var{guardian} greedy?") + "Return @code{#t} if @var{guardian} is a greedy guardian, otherwise @code{#f}.\n") #define FUNC_NAME s_scm_guardian_greedy_p { return SCM_BOOL (GREEDY_P (GUARDIAN (guardian))); From 27c3700636f5ca87fb37975c7217ccd717906e38 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 24 Feb 2001 23:46:04 +0000 Subject: [PATCH 0602/2047] * numbers.c (scm_two_doubles, scm_sys_expt, scm_sys_atan2, scm_make_polar): Rename arguments `z1' and `z2' to `x' and `y', since use of `z' suggests that the arguments may be complex. * goops.c (scm_make), numbers.c (scm_sys_expt): Fix docstring typos. --- libguile/ChangeLog | 10 ++++++++- libguile/goops.c | 2 +- libguile/numbers.c | 56 +++++++++++++++++++++++----------------------- 3 files changed, 38 insertions(+), 30 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index bf2cb43ae..271c98a48 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2001-02-24 Neil Jerram + + * numbers.c (scm_two_doubles, scm_sys_expt, scm_sys_atan2, + scm_make_polar): Rename arguments `z1' and `z2' to `x' and `y', + since use of `z' suggests that the arguments may be complex. + + * goops.c (scm_make), numbers.c (scm_sys_expt): Fix docstring + typos. + 2001-02-23 Neil Jerram * dump.c (scm_binary_write, scm_binary_read), eval.c @@ -40,7 +49,6 @@ * guile-doc-snarf.in, guile-func-name-check.in: Added copyright notice and license. ->>>>>>> 1.1281 2001-02-17 Martin Grabmueller * variable.c (scm_make_variable, scm_make_undefined_variable) diff --git a/libguile/goops.c b/libguile/goops.c index b2ae4ee20..02c0acf33 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1970,7 +1970,7 @@ SCM_KEYWORD (k_gf, "generic-function"); SCM_DEFINE (scm_make, "make", 0, 0, 1, (SCM args), - "Make a new object. @var{args} mist contain the class and\n" + "Make a new object. @var{args} must contain the class and\n" "all necessary initialization information.") #define FUNC_NAME s_scm_make { diff --git a/libguile/numbers.c b/libguile/numbers.c index 816ad3d34..20f78abbb 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -3947,60 +3947,60 @@ struct dpair double x, y; }; -static void scm_two_doubles (SCM z1, - SCM z2, +static void scm_two_doubles (SCM x, + SCM y, const char *sstring, struct dpair * xy); static void -scm_two_doubles (SCM z1, SCM z2, const char *sstring, struct dpair *xy) +scm_two_doubles (SCM x, SCM y, const char *sstring, struct dpair *xy) { - if (SCM_INUMP (z1)) { - xy->x = SCM_INUM (z1); - } else if (SCM_BIGP (z1)) { - xy->x = scm_big2dbl (z1); - } else if (SCM_REALP (z1)) { - xy->x = SCM_REAL_VALUE (z1); + if (SCM_INUMP (x)) { + xy->x = SCM_INUM (x); + } else if (SCM_BIGP (x)) { + xy->x = scm_big2dbl (x); + } else if (SCM_REALP (x)) { + xy->x = SCM_REAL_VALUE (x); } else { - scm_wrong_type_arg (sstring, SCM_ARG1, z1); + scm_wrong_type_arg (sstring, SCM_ARG1, x); } - if (SCM_INUMP (z2)) { - xy->y = SCM_INUM (z2); - } else if (SCM_BIGP (z2)) { - xy->y = scm_big2dbl (z2); - } else if (SCM_REALP (z2)) { - xy->y = SCM_REAL_VALUE (z2); + if (SCM_INUMP (y)) { + xy->y = SCM_INUM (y); + } else if (SCM_BIGP (y)) { + xy->y = scm_big2dbl (y); + } else if (SCM_REALP (y)) { + xy->y = SCM_REAL_VALUE (y); } else { - scm_wrong_type_arg (sstring, SCM_ARG2, z2); + scm_wrong_type_arg (sstring, SCM_ARG2, y); } } SCM_DEFINE (scm_sys_expt, "$expt", 2, 0, 0, - (SCM z1, SCM z2), - "Return @var{z1} raised to the power or @var{z2}. This\n" + (SCM x, SCM y), + "Return @var{x} raised to the power of @var{y}. This\n" "procedure does not accept complex arguments.") #define FUNC_NAME s_scm_sys_expt { struct dpair xy; - scm_two_doubles (z1, z2, FUNC_NAME, &xy); + scm_two_doubles (x, y, FUNC_NAME, &xy); return scm_make_real (pow (xy.x, xy.y)); } #undef FUNC_NAME SCM_DEFINE (scm_sys_atan2, "$atan2", 2, 0, 0, - (SCM z1, SCM z2), - "Return the arc tangent of the two arguments @var{z1} and\n" - "@var{z2}. This is similar to calculating the arc tangent of\n" - "@var{z1} / @var{z2}, except that the signs of both arguments\n" + (SCM x, SCM y), + "Return the arc tangent of the two arguments @var{x} and\n" + "@var{y}. This is similar to calculating the arc tangent of\n" + "@var{x} / @var{y}, except that the signs of both arguments\n" "are used to determine the quadrant of the result. This\n" "procedure does not accept complex arguments.") #define FUNC_NAME s_scm_sys_atan2 { struct dpair xy; - scm_two_doubles (z1, z2, FUNC_NAME, &xy); + scm_two_doubles (x, y, FUNC_NAME, &xy); return scm_make_real (atan2 (xy.x, xy.y)); } #undef FUNC_NAME @@ -4021,12 +4021,12 @@ SCM_DEFINE (scm_make_rectangular, "make-rectangular", 2, 0, 0, SCM_DEFINE (scm_make_polar, "make-polar", 2, 0, 0, - (SCM z1, SCM z2), - "Return the complex number Z1 * e^(i * Z2).") + (SCM x, SCM y), + "Return the complex number X * e^(i * Y).") #define FUNC_NAME s_scm_make_polar { struct dpair xy; - scm_two_doubles (z1, z2, FUNC_NAME, &xy); + scm_two_doubles (x, y, FUNC_NAME, &xy); return scm_make_complex (xy.x * cos (xy.y), xy.x * sin (xy.y)); } #undef FUNC_NAME From c8762438f5a51036dc1d9fe6fec01ca197d48e97 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 25 Feb 2001 18:18:56 +0000 Subject: [PATCH 0603/2047] * match.scm: New file. --- ice-9/ChangeLog | 4 + ice-9/match.scm | 200 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 204 insertions(+) create mode 100644 ice-9/match.scm diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 23b1fd988..a08172b48 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2001-02-25 Keisuke Nishida + + * match.scm: New file, including Andrew K. Wright's pattern matcher. + 2001-02-16 Marius Vollmer * boot-9.scm (eval-when, eval-case): Renamed `eval-when' to diff --git a/ice-9/match.scm b/ice-9/match.scm new file mode 100644 index 000000000..d2c3844e6 --- /dev/null +++ b/ice-9/match.scm @@ -0,0 +1,200 @@ +;;; installed-scm-file + +;;;; Copyright (C) 2001 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; + +(define-module (ice-9 match) + :use-module (ice-9 slib) + :export (match match-lambda match-lambda* match-define + match-let match-let* match-letrec + define-structure define-const-structure + match:error match:set-error + match:error-control match:set-error-control + match:structure-control match:set-structure-control + match:runtime-structures match:set-runtime-structures)) + +;; The original code can be found at the Scheme Repository +;; +;; http://www.cs.indiana.edu/scheme-repository/code.match.html +;; +;; or Andrew K. Wright's web page: +;; +;; http://www.star-lab.com/wright/code.html + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Pattern Matching Syntactic Extensions for Scheme +;; +(define match:version "Version 1.19, Sep 15, 1995") +;; +;; Written by Andrew K. Wright, 1993 (wright@research.nj.nec.com). +;; Adapted from code originally written by Bruce F. Duba, 1991. +;; This package also includes a modified version of Kent Dybvig's +;; define-structure (see Dybvig, R.K., The Scheme Programming Language, +;; Prentice-Hall, NJ, 1987). +;; +;; This macro package extends Scheme with several new expression forms. +;; Following is a brief summary of the new forms. See the associated +;; LaTeX documentation for a full description of their functionality. +;; +;; +;; match expressions: +;; +;; exp ::= ... +;; | (match exp clause ...) +;; | (match-lambda clause ...) +;; | (match-lambda* clause ...) +;; | (match-let ((pat exp) ...) body) +;; | (match-let* ((pat exp) ...) body) +;; | (match-letrec ((pat exp) ...) body) +;; | (match-define pat exp) +;; +;; clause ::= (pat body) | (pat => exp) +;; +;; patterns: matches: +;; +;; pat ::= identifier anything, and binds identifier +;; | _ anything +;; | () the empty list +;; | #t #t +;; | #f #f +;; | string a string +;; | number a number +;; | character a character +;; | 'sexp an s-expression +;; | 'symbol a symbol (special case of s-expr) +;; | (pat_1 ... pat_n) list of n elements +;; | (pat_1 ... pat_n . pat_{n+1}) list of n or more +;; | (pat_1 ... pat_n pat_n+1 ooo) list of n or more, each element +;; of remainder must match pat_n+1 +;; | #(pat_1 ... pat_n) vector of n elements +;; | #(pat_1 ... pat_n pat_n+1 ooo) vector of n or more, each element +;; of remainder must match pat_n+1 +;; | #&pat box +;; | ($ struct-name pat_1 ... pat_n) a structure +;; | (= field pat) a field of a structure +;; | (and pat_1 ... pat_n) if all of pat_1 thru pat_n match +;; | (or pat_1 ... pat_n) if any of pat_1 thru pat_n match +;; | (not pat_1 ... pat_n) if all pat_1 thru pat_n don't match +;; | (? predicate pat_1 ... pat_n) if predicate true and all of +;; pat_1 thru pat_n match +;; | (set! identifier) anything, and binds setter +;; | (get! identifier) anything, and binds getter +;; | `qp a quasi-pattern +;; +;; ooo ::= ... zero or more +;; | ___ zero or more +;; | ..k k or more +;; | __k k or more +;; +;; quasi-patterns: matches: +;; +;; qp ::= () the empty list +;; | #t #t +;; | #f #f +;; | string a string +;; | number a number +;; | character a character +;; | identifier a symbol +;; | (qp_1 ... qp_n) list of n elements +;; | (qp_1 ... qp_n . qp_{n+1}) list of n or more +;; | (qp_1 ... qp_n qp_n+1 ooo) list of n or more, each element +;; of remainder must match qp_n+1 +;; | #(qp_1 ... qp_n) vector of n elements +;; | #(qp_1 ... qp_n qp_n+1 ooo) vector of n or more, each element +;; of remainder must match qp_n+1 +;; | #&qp box +;; | ,pat a pattern +;; | ,@pat a pattern +;; +;; The names (quote, quasiquote, unquote, unquote-splicing, ?, _, $, +;; and, or, not, set!, get!, ..., ___) cannot be used as pattern variables. +;; +;; +;; structure expressions: +;; +;; exp ::= ... +;; | (define-structure (id_0 id_1 ... id_n)) +;; | (define-structure (id_0 id_1 ... id_n) +;; ((id_{n+1} exp_1) ... (id_{n+m} exp_m))) +;; | (define-const-structure (id_0 arg_1 ... arg_n)) +;; | (define-const-structure (id_0 arg_1 ... arg_n) +;; ((arg_{n+1} exp_1) ... (arg_{n+m} exp_m))) +;; +;; arg ::= id | (! id) | (@ id) +;; +;; +;; match:error-control controls what code is generated for failed matches. +;; Possible values: +;; 'unspecified - do nothing, ie., evaluate (cond [#f #f]) +;; 'fail - call match:error, or die at car or cdr +;; 'error - call match:error with the unmatched value +;; 'match - call match:error with the unmatched value _and_ +;; the quoted match expression +;; match:error-control is set by calling match:set-error-control with +;; the new value. +;; +;; match:error is called for a failed match. +;; match:error is set by calling match:set-error with the new value. +;; +;; match:structure-control controls the uniqueness of structures +;; (does not exist for Scheme 48 version). +;; Possible values: +;; 'vector - (default) structures are vectors with a symbol in position 0 +;; 'disjoint - structures are fully disjoint from all other values +;; match:structure-control is set by calling match:set-structure-control +;; with the new value. +;; +;; match:runtime-structures controls whether local structure declarations +;; generate new structures each time they are reached +;; (does not exist for Scheme 48 version). +;; Possible values: +;; #t - (default) each runtime occurrence generates a new structure +;; #f - each lexical occurrence generates a new structure +;; +;; End of user visible/modifiable stuff. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(require (quote pretty-print)) +(define match:error (lambda (val . args) (for-each pretty-print args) (slib:error no matching clause for val))) +(define match:andmap (lambda (f l) (if (null? l) (and) (and (f (car l)) (match:andmap f (cdr l)))))) +(define match:syntax-err (lambda (obj msg) (slib:error msg obj))) +(define match:disjoint-structure-tags (quote ())) +(define match:make-structure-tag (lambda (name) (if (or (eq? match:structure-control (quote disjoint)) match:runtime-structures) (let ((tag (gentemp))) (set! match:disjoint-structure-tags (cons tag match:disjoint-structure-tags)) tag) (string->symbol (string-append < (symbol->string name) >))))) +(define match:structure? (lambda (tag) (memq tag match:disjoint-structure-tags))) +(define match:structure-control (quote vector)) +(define match:set-structure-control (lambda (v) (set! match:structure-control v))) +(define match:set-error (lambda (v) (set! match:error v))) +(define match:error-control (quote error)) +(define match:set-error-control (lambda (v) (set! match:error-control v))) +(define match:disjoint-predicates (cons (quote null) (quote (pair? symbol? boolean? number? string? char? procedure? vector?)))) +(define match:vector-structures (quote ())) +(define match:expanders (letrec ((genmatch (lambda (x clauses match-expr) (let* ((length>= (gentemp)) (eb-errf (error-maker match-expr)) (blist (car eb-errf)) (plist (map (lambda (c) (let* ((x (bound (validate-pattern (car c)))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gentemp)) (fail (and (pair? (cdr c)) (pair? (cadr c)) (eq? (caadr c) (quote =>)) (symbol? (cadadr c)) (pair? (cdadr c)) (null? (cddadr c)) (pair? (cddr c)) (cadadr c))) (bv2 (if fail (cons fail bv) bv)) (body (if fail (cddr c) (cdr c)))) (set! blist (cons (quasiquote ((unquote code) (lambda (unquote bv2) (unquote-splicing body)))) (append bindings blist))) (list p code bv (and fail (gentemp)) #f))) clauses)) (code (gen x (quote ()) plist (cdr eb-errf) length>= (gentemp)))) (unreachable plist match-expr) (inline-let (quasiquote (let (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) (unquote-splicing blist)) (unquote code))))))) (genletrec (lambda (pat exp body match-expr) (let* ((length>= (gentemp)) (eb-errf (error-maker match-expr)) (x (bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gentemp)) (plist (list (list p code bv #f #f))) (x (gentemp)) (m (gen x (quote ()) plist (cdr eb-errf) length>= (gentemp))) (gs (map (lambda (_) (gentemp)) bv))) (unreachable plist match-expr) (quasiquote (letrec (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) (unquote-splicing (map (lambda (v) (quasiquote ((unquote v) #f))) bv)) ((unquote x) (unquote exp)) ((unquote code) (lambda (unquote gs) (unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote v) (unquote g)))) bv gs)) (unquote-splicing body))) (unquote-splicing bindings) (unquote-splicing (car eb-errf))) (unquote m)))))) (gendefine (lambda (pat exp match-expr) (let* ((length>= (gentemp)) (eb-errf (error-maker match-expr)) (x (bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gentemp)) (plist (list (list p code bv #f #f))) (x (gentemp)) (m (gen x (quote ()) plist (cdr eb-errf) length>= (gentemp))) (gs (map (lambda (_) (gentemp)) bv))) (unreachable plist match-expr) (quasiquote (begin (unquote-splicing (map (lambda (v) (quasiquote (define (unquote v) #f))) bv)) (unquote (inline-let (quasiquote (let (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) ((unquote x) (unquote exp)) ((unquote code) (lambda (unquote gs) (unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote v) (unquote g)))) bv gs)) (cond (#f #f)))) (unquote-splicing bindings) (unquote-splicing (car eb-errf))) (unquote m)))))))))) (pattern-var? (lambda (x) (and (symbol? x) (not (dot-dot-k? x)) (not (memq x (quote (quasiquote quote unquote unquote-splicing ? _ $ = and or not set! get! ... ___))))))) (dot-dot-k? (lambda (s) (and (symbol? s) (if (memq s (quote (... ___))) 0 (let* ((s (symbol->string s)) (n (string-length s))) (and (<= 3 n) (memq (string-ref s 0) (quote (. _))) (memq (string-ref s 1) (quote (. _))) (match:andmap char-numeric? (string->list (substring s 2 n))) (string->number (substring s 2 n)))))))) (error-maker (lambda (match-expr) (cond ((eq? match:error-control (quote unspecified)) (cons (quote ()) (lambda (x) (quasiquote (cond (#f #f)))))) ((memq match:error-control (quote (error fail))) (cons (quote ()) (lambda (x) (quasiquote (match:error (unquote x)))))) ((eq? match:error-control (quote match)) (let ((errf (gentemp)) (arg (gentemp))) (cons (quasiquote (((unquote errf) (lambda ((unquote arg)) (match:error (unquote arg) (quote (unquote match-expr))))))) (lambda (x) (quasiquote ((unquote errf) (unquote x))))))) (else (match:syntax-err (quote (unspecified error fail match)) invalid value for match:error-control, legal values are))))) (unreachable (lambda (plist match-expr) (for-each (lambda (x) (if (not (car (cddddr x))) (begin (display Warning: unreachable pattern ) (display (car x)) (display in ) (display match-expr) (newline)))) plist))) (validate-pattern (lambda (pattern) (letrec ((simple? (lambda (x) (or (string? x) (boolean? x) (char? x) (number? x) (null? x)))) (ordinary (lambda (p) (let ((g157 (lambda (x y) (cons (ordinary x) (ordinary y))))) (if (simple? p) ((lambda (p) p) p) (if (equal? p (quote _)) ((lambda () (quote _))) (if (pattern-var? p) ((lambda (p) p) p) (if (pair? p) (if (equal? (car p) (quote quasiquote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) (quasi p)) (cadr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote quote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote ?)) (if (and (pair? (cdr p)) (list? (cddr p))) ((lambda (pred ps) (quasiquote (? (unquote pred) (unquote-splicing (map ordinary ps))))) (cadr p) (cddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote =)) (if (and (pair? (cdr p)) (pair? (cddr p)) (null? (cdddr p))) ((lambda (sel p) (quasiquote (= (unquote sel) (unquote (ordinary p))))) (cadr p) (caddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote and)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (and (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote or)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (or (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote not)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (not (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote $)) (if (and (pair? (cdr p)) (symbol? (cadr p)) (list? (cddr p))) ((lambda (r ps) (quasiquote ($ (unquote r) (unquote-splicing (map ordinary ps))))) (cadr p) (cddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote set!)) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote get!)) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote unquote)) (g157 (car p) (cdr p)) (if (equal? (car p) (quote unquote-splicing)) (g157 (car p) (cdr p)) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cddr p))) ((lambda (p ddk) (quasiquote ((unquote (ordinary p)) (unquote ddk)))) (car p) (cadr p)) (g157 (car p) (cdr p))))))))))))))) (if (vector? p) ((lambda (p) (let* ((pl (vector->list p)) (rpl (reverse pl))) (apply vector (if (and (not (null? rpl)) (dot-dot-k? (car rpl))) (reverse (cons (car rpl) (map ordinary (cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err pattern syntax error in pattern))))))))))) (quasi (lambda (p) (let ((g178 (lambda (x y) (cons (quasi x) (quasi y))))) (if (simple? p) ((lambda (p) p) p) (if (symbol? p) ((lambda (p) (quasiquote (quote (unquote p)))) p) (if (pair? p) (if (equal? (car p) (quote unquote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) (ordinary p)) (cadr p)) (g178 (car p) (cdr p))) (if (and (pair? (car p)) (equal? (caar p) (quote unquote-splicing)) (pair? (cdar p)) (null? (cddar p))) (if (null? (cdr p)) ((lambda (p) (ordinary p)) (cadar p)) ((lambda (p y) (append (ordlist p) (quasi y))) (cadar p) (cdr p))) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cddr p))) ((lambda (p ddk) (quasiquote ((unquote (quasi p)) (unquote ddk)))) (car p) (cadr p)) (g178 (car p) (cdr p))))) (if (vector? p) ((lambda (p) (let* ((pl (vector->list p)) (rpl (reverse pl))) (apply vector (if (dot-dot-k? (car rpl)) (reverse (cons (car rpl) (map quasi (cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err pattern syntax error in pattern)))))))))) (ordlist (lambda (p) (cond ((null? p) (quote ())) ((pair? p) (cons (ordinary (car p)) (ordlist (cdr p)))) (else (match:syntax-err pattern invalid use of unquote-splicing in pattern)))))) (ordinary pattern)))) (bound (lambda (pattern) (letrec ((pred-bodies (quote ())) (bound (lambda (p a k) (cond ((eq? (quote _) p) (k p a)) ((symbol? p) (if (memq p a) (match:syntax-err pattern duplicate variable in pattern)) (k p (cons p a))) ((and (pair? p) (eq? (quote quote) (car p))) (k p a)) ((and (pair? p) (eq? (quote ?) (car p))) (cond ((not (null? (cddr p))) (bound (quasiquote (and (? (unquote (cadr p))) (unquote-splicing (cddr p)))) a k)) ((or (not (symbol? (cadr p))) (memq (cadr p) a)) (let ((g (gentemp))) (set! pred-bodies (cons (quasiquote ((unquote g) (unquote (cadr p)))) pred-bodies)) (k (quasiquote (? (unquote g))) a))) (else (k p a)))) ((and (pair? p) (eq? (quote =) (car p))) (cond ((or (not (symbol? (cadr p))) (memq (cadr p) a)) (let ((g (gentemp))) (set! pred-bodies (cons (quasiquote ((unquote g) (unquote (cadr p)))) pred-bodies)) (bound (quasiquote (= (unquote g) (unquote (caddr p)))) a k))) (else (bound (caddr p) a (lambda (p2 a) (k (quasiquote (= (unquote (cadr p)) (unquote p2))) a)))))) ((and (pair? p) (eq? (quote and) (car p))) (bound* (cdr p) a (lambda (p a) (k (quasiquote (and (unquote-splicing p))) a)))) ((and (pair? p) (eq? (quote or) (car p))) (bound (cadr p) a (lambda (first-p first-a) (let or* ((plist (cddr p)) (k (lambda (plist) (k (quasiquote (or (unquote first-p) (unquote-splicing plist))) first-a)))) (if (null? plist) (k plist) (bound (car plist) a (lambda (car-p car-a) (if (not (permutation car-a first-a)) (match:syntax-err pattern variables of or-pattern differ in)) (or* (cdr plist) (lambda (cdr-p) (k (cons car-p cdr-p))))))))))) ((and (pair? p) (eq? (quote not) (car p))) (cond ((not (null? (cddr p))) (bound (quasiquote (not (or (unquote-splicing (cdr p))))) a k)) (else (bound (cadr p) a (lambda (p2 a2) (if (not (permutation a a2)) (match:syntax-err p no variables allowed in)) (k (quasiquote (not (unquote p2))) a)))))) ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p))) (bound (car p) a (lambda (q b) (let ((bvars (find-prefix b a))) (k (quasiquote ((unquote q) (unquote (cadr p)) (unquote bvars) (unquote (gentemp)) (unquote (gentemp)) (unquote (map (lambda (_) (gentemp)) bvars)))) b))))) ((and (pair? p) (eq? (quote $) (car p))) (bound* (cddr p) a (lambda (p1 a) (k (quasiquote ($ (unquote (cadr p)) (unquote-splicing p1))) a)))) ((and (pair? p) (eq? (quote set!) (car p))) (if (memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((and (pair? p) (eq? (quote get!) (car p))) (if (memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((pair? p) (bound (car p) a (lambda (car-p a) (bound (cdr p) a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))) ((vector? p) (boundv (vector->list p) a (lambda (pl a) (k (list->vector pl) a)))) (else (k p a))))) (boundv (lambda (plist a k) (let ((g184 (lambda () (k plist a)))) (if (pair? plist) (if (and (pair? (cdr plist)) (dot-dot-k? (cadr plist)) (null? (cddr plist))) ((lambda () (bound plist a k))) (if (null? plist) (g184) ((lambda (x y) (bound x a (lambda (car-p a) (boundv y a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))) (car plist) (cdr plist)))) (if (null? plist) (g184) (match:error plist)))))) (bound* (lambda (plist a k) (if (null? plist) (k plist a) (bound (car plist) a (lambda (car-p a) (bound* (cdr plist) a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))))) (find-prefix (lambda (b a) (if (eq? b a) (quote ()) (cons (car b) (find-prefix (cdr b) a))))) (permutation (lambda (p1 p2) (and (= (length p1) (length p2)) (match:andmap (lambda (x1) (memq x1 p2)) p1))))) (bound pattern (quote ()) (lambda (p a) (list p (reverse a) pred-bodies)))))) (inline-let (lambda (let-exp) (letrec ((occ (lambda (x e) (let loop ((e e)) (cond ((pair? e) (+ (loop (car e)) (loop (cdr e)))) ((eq? x e) 1) (else 0))))) (subst (lambda (e old new) (let loop ((e e)) (cond ((pair? e) (cons (loop (car e)) (loop (cdr e)))) ((eq? old e) new) (else e))))) (const? (lambda (sexp) (or (symbol? sexp) (boolean? sexp) (string? sexp) (char? sexp) (number? sexp) (null? sexp) (and (pair? sexp) (eq? (car sexp) (quote quote)) (pair? (cdr sexp)) (symbol? (cadr sexp)) (null? (cddr sexp)))))) (isval? (lambda (sexp) (or (const? sexp) (and (pair? sexp) (memq (car sexp) (quote (lambda quote match-lambda match-lambda*))))))) (small? (lambda (sexp) (or (const? sexp) (and (pair? sexp) (eq? (car sexp) (quote lambda)) (pair? (cdr sexp)) (pair? (cddr sexp)) (const? (caddr sexp)) (null? (cdddr sexp))))))) (let loop ((b (cadr let-exp)) (new-b (quote ())) (e (caddr let-exp))) (cond ((null? b) (if (null? new-b) e (quasiquote (let (unquote (reverse new-b)) (unquote e))))) ((isval? (cadr (car b))) (let* ((x (caar b)) (n (occ x e))) (cond ((= 0 n) (loop (cdr b) new-b e)) ((or (= 1 n) (small? (cadr (car b)))) (loop (cdr b) new-b (subst e x (cadr (car b))))) (else (loop (cdr b) (cons (car b) new-b) e))))) (else (loop (cdr b) (cons (car b) new-b) e))))))) (gen (lambda (x sf plist erract length>= eta) (if (null? plist) (erract x) (let* ((v (quote ())) (val (lambda (x) (cdr (assq x v)))) (fail (lambda (sf) (gen x sf (cdr plist) erract length>= eta))) (success (lambda (sf) (set-car! (cddddr (car plist)) #t) (let* ((code (cadr (car plist))) (bv (caddr (car plist))) (fail-sym (cadddr (car plist)))) (if fail-sym (let ((ap (quasiquote ((unquote code) (unquote fail-sym) (unquote-splicing (map val bv)))))) (quasiquote (call-with-current-continuation (lambda ((unquote fail-sym)) (let (((unquote fail-sym) (lambda () ((unquote fail-sym) (unquote (fail sf)))))) (unquote ap)))))) (quasiquote ((unquote code) (unquote-splicing (map val bv))))))))) (let next ((p (caar plist)) (e x) (sf sf) (kf fail) (ks success)) (cond ((eq? (quote _) p) (ks sf)) ((symbol? p) (set! v (cons (cons p e) v)) (ks sf)) ((null? p) (emit (quasiquote (null? (unquote e))) sf kf ks)) ((equal? p (quote (quote ()))) (emit (quasiquote (null? (unquote e))) sf kf ks)) ((string? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((boolean? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((char? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((number? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((and (pair? p) (eq? (quote quote) (car p))) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((and (pair? p) (eq? (quote ?) (car p))) (let ((tst (quasiquote ((unquote (cadr p)) (unquote e))))) (emit tst sf kf ks))) ((and (pair? p) (eq? (quote =) (car p))) (next (caddr p) (quasiquote ((unquote (cadr p)) (unquote e))) sf kf ks)) ((and (pair? p) (eq? (quote and) (car p))) (let loop ((p (cdr p)) (sf sf)) (if (null? p) (ks sf) (next (car p) e sf kf (lambda (sf) (loop (cdr p) sf)))))) ((and (pair? p) (eq? (quote or) (car p))) (let ((or-v v)) (let loop ((p (cdr p)) (sf sf)) (if (null? p) (kf sf) (begin (set! v or-v) (next (car p) e sf (lambda (sf) (loop (cdr p) sf)) ks)))))) ((and (pair? p) (eq? (quote not) (car p))) (next (cadr p) e sf ks kf)) ((and (pair? p) (eq? (quote $) (car p))) (let* ((tag (cadr p)) (fields (cdr p)) (rlen (length fields)) (tst (quasiquote ((unquote (symbol-append tag (quote ?))) (unquote e))))) (emit tst sf kf (let rloop ((n 1)) (lambda (sf) (if (= n rlen) (ks sf) (next (list-ref fields n) (quasiquote ((unquote (symbol-append tag (quote -) n)) (unquote e))) sf kf (rloop (+ 1 n))))))))) ((and (pair? p) (eq? (quote set!) (car p))) (set! v (cons (cons (cadr p) (setter e p)) v)) (ks sf)) ((and (pair? p) (eq? (quote get!) (car p))) (set! v (cons (cons (cadr p) (getter e p)) v)) (ks sf)) ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p))) (emit (quasiquote (list? (unquote e))) sf kf (lambda (sf) (let* ((k (dot-dot-k? (cadr p))) (ks (lambda (sf) (let ((bound (list-ref p 2))) (cond ((eq? (car p) (quote _)) (ks sf)) ((null? bound) (let* ((ptst (next (car p) eta sf (lambda (sf) #f) (lambda (sf) #t))) (tst (if (and (pair? ptst) (symbol? (car ptst)) (pair? (cdr ptst)) (eq? eta (cadr ptst)) (null? (cddr ptst))) (car ptst) (quasiquote (lambda ((unquote eta)) (unquote ptst)))))) (assm (quasiquote (match:andmap (unquote tst) (unquote e))) (kf sf) (ks sf)))) ((and (symbol? (car p)) (equal? (list (car p)) bound)) (next (car p) e sf kf ks)) (else (let* ((gloop (list-ref p 3)) (ge (list-ref p 4)) (fresh (list-ref p 5)) (p1 (next (car p) (quasiquote (car (unquote ge))) sf kf (lambda (sf) (quasiquote ((unquote gloop) (cdr (unquote ge)) (unquote-splicing (map (lambda (b f) (quasiquote (cons (unquote (val b)) (unquote f)))) bound fresh)))))))) (set! v (append (map cons bound (map (lambda (x) (quasiquote (reverse (unquote x)))) fresh)) v)) (quasiquote (let (unquote gloop) (((unquote ge) (unquote e)) (unquote-splicing (map (lambda (x) (quasiquote ((unquote x) (quote ())))) fresh))) (if (null? (unquote ge)) (unquote (ks sf)) (unquote p1))))))))))) (case k ((0) (ks sf)) ((1) (emit (quasiquote (pair? (unquote e))) sf kf ks)) (else (emit (quasiquote (((unquote length>=) (unquote k)) (unquote e))) sf kf ks))))))) ((pair? p) (emit (quasiquote (pair? (unquote e))) sf kf (lambda (sf) (next (car p) (add-a e) sf kf (lambda (sf) (next (cdr p) (add-d e) sf kf ks)))))) ((and (vector? p) (>= (vector-length p) 6) (dot-dot-k? (vector-ref p (- (vector-length p) 5)))) (let* ((vlen (- (vector-length p) 6)) (k (dot-dot-k? (vector-ref p (+ vlen 1)))) (minlen (+ vlen k)) (bound (vector-ref p (+ vlen 2)))) (emit (quasiquote (vector? (unquote e))) sf kf (lambda (sf) (assm (quasiquote (>= (vector-length (unquote e)) (unquote minlen))) (kf sf) ((let vloop ((n 0)) (lambda (sf) (cond ((not (= n vlen)) (next (vector-ref p n) (quasiquote (vector-ref (unquote e) (unquote n))) sf kf (vloop (+ 1 n)))) ((eq? (vector-ref p vlen) (quote _)) (ks sf)) (else (let* ((gloop (vector-ref p (+ vlen 3))) (ind (vector-ref p (+ vlen 4))) (fresh (vector-ref p (+ vlen 5))) (p1 (next (vector-ref p vlen) (quasiquote (vector-ref (unquote e) (unquote ind))) sf kf (lambda (sf) (quasiquote ((unquote gloop) (- (unquote ind) 1) (unquote-splicing (map (lambda (b f) (quasiquote (cons (unquote (val b)) (unquote f)))) bound fresh)))))))) (set! v (append (map cons bound fresh) v)) (quasiquote (let (unquote gloop) (((unquote ind) (- (vector-length (unquote e)) 1)) (unquote-splicing (map (lambda (x) (quasiquote ((unquote x) (quote ())))) fresh))) (if (> (unquote minlen) (unquote ind)) (unquote (ks sf)) (unquote p1))))))))) sf)))))) ((vector? p) (let ((vlen (vector-length p))) (emit (quasiquote (vector? (unquote e))) sf kf (lambda (sf) (emit (quasiquote (equal? (vector-length (unquote e)) (unquote vlen))) sf kf (let vloop ((n 0)) (lambda (sf) (if (= n vlen) (ks sf) (next (vector-ref p n) (quasiquote (vector-ref (unquote e) (unquote n))) sf kf (vloop (+ 1 n))))))))))) (else (display FATAL ERROR IN PATTERN MATCHER) (newline) (error #f THIS NEVER HAPPENS)))))))) (emit (lambda (tst sf kf ks) (cond ((in tst sf) (ks sf)) ((in (quasiquote (not (unquote tst))) sf) (kf sf)) (else (let* ((e (cadr tst)) (implied (cond ((eq? (car tst) (quote equal?)) (let ((p (caddr tst))) (cond ((string? p) (quasiquote ((string? (unquote e))))) ((boolean? p) (quasiquote ((boolean? (unquote e))))) ((char? p) (quasiquote ((char? (unquote e))))) ((number? p) (quasiquote ((number? (unquote e))))) ((and (pair? p) (eq? (quote quote) (car p))) (quasiquote ((symbol? (unquote e))))) (else (quote ()))))) ((eq? (car tst) (quote null?)) (quasiquote ((list? (unquote e))))) ((vec-structure? tst) (quasiquote ((vector? (unquote e))))) (else (quote ())))) (not-imp (case (car tst) ((list?) (quasiquote ((not (null? (unquote e)))))) (else (quote ())))) (s (ks (cons tst (append implied sf)))) (k (kf (cons (quasiquote (not (unquote tst))) (append not-imp sf))))) (assm tst k s)))))) (assm (lambda (tst f s) (cond ((equal? s f) s) ((and (eq? s #t) (eq? f #f)) tst) ((and (eq? (car tst) (quote pair?)) (memq match:error-control (quote (unspecified fail))) (memq (car f) (quote (cond match:error))) (guarantees s (cadr tst))) s) ((and (pair? s) (eq? (car s) (quote if)) (equal? (cadddr s) f)) (if (eq? (car (cadr s)) (quote and)) (quasiquote (if (and (unquote tst) (unquote-splicing (cdr (cadr s)))) (unquote (caddr s)) (unquote f))) (quasiquote (if (and (unquote tst) (unquote (cadr s))) (unquote (caddr s)) (unquote f))))) ((and (pair? s) (equal? (car s) (quote call-with-current-continuation)) (pair? (cdr s)) (pair? (cadr s)) (equal? (caadr s) (quote lambda)) (pair? (cdadr s)) (pair? (cadadr s)) (null? (cdr (cadadr s))) (pair? (cddadr s)) (pair? (car (cddadr s))) (equal? (caar (cddadr s)) (quote let)) (pair? (cdar (cddadr s))) (pair? (cadar (cddadr s))) (pair? (caadar (cddadr s))) (pair? (cdr (caadar (cddadr s)))) (pair? (cadr (caadar (cddadr s)))) (equal? (caadr (caadar (cddadr s))) (quote lambda)) (pair? (cdadr (caadar (cddadr s)))) (null? (cadadr (caadar (cddadr s)))) (pair? (cddadr (caadar (cddadr s)))) (pair? (car (cddadr (caadar (cddadr s))))) (pair? (cdar (cddadr (caadar (cddadr s))))) (null? (cddar (cddadr (caadar (cddadr s))))) (null? (cdr (cddadr (caadar (cddadr s))))) (null? (cddr (caadar (cddadr s)))) (null? (cdadar (cddadr s))) (pair? (cddar (cddadr s))) (null? (cdddar (cddadr s))) (null? (cdr (cddadr s))) (null? (cddr s)) (equal? f (cadar (cddadr (caadar (cddadr s)))))) (let ((k (car (cadadr s))) (fail (car (caadar (cddadr s)))) (s2 (caddar (cddadr s)))) (quasiquote (call-with-current-continuation (lambda ((unquote k)) (let (((unquote fail) (lambda () ((unquote k) (unquote f))))) (unquote (assm tst (quasiquote ((unquote fail))) s2)))))))) ((and #f (pair? s) (equal? (car s) (quote let)) (pair? (cdr s)) (pair? (cadr s)) (pair? (caadr s)) (pair? (cdaadr s)) (pair? (car (cdaadr s))) (equal? (caar (cdaadr s)) (quote lambda)) (pair? (cdar (cdaadr s))) (null? (cadar (cdaadr s))) (pair? (cddar (cdaadr s))) (null? (cdddar (cdaadr s))) (null? (cdr (cdaadr s))) (null? (cdadr s)) (pair? (cddr s)) (null? (cdddr s)) (equal? (caddar (cdaadr s)) f)) (let ((fail (caaadr s)) (s2 (caddr s))) (quasiquote (let (((unquote fail) (lambda () (unquote f)))) (unquote (assm tst (quasiquote ((unquote fail))) s2)))))) (else (quasiquote (if (unquote tst) (unquote s) (unquote f))))))) (guarantees (lambda (code x) (let ((a (add-a x)) (d (add-d x))) (let loop ((code code)) (cond ((not (pair? code)) #f) ((memq (car code) (quote (cond match:error))) #t) ((or (equal? code a) (equal? code d)) #t) ((eq? (car code) (quote if)) (or (loop (cadr code)) (and (loop (caddr code)) (loop (cadddr code))))) ((eq? (car code) (quote lambda)) #f) ((and (eq? (car code) (quote let)) (symbol? (cadr code))) #f) (else (or (loop (car code)) (loop (cdr code))))))))) (in (lambda (e l) (or (member e l) (and (eq? (car e) (quote list?)) (or (member (quasiquote (null? (unquote (cadr e)))) l) (member (quasiquote (pair? (unquote (cadr e)))) l))) (and (eq? (car e) (quote not)) (let* ((srch (cadr e)) (const-class (equal-test? srch))) (cond (const-class (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (equal? const-class (car x)))) (equal? x (quasiquote (not ((unquote const-class) (unquote (cadr srch)))))) (and (equal? (cadr x) (cadr srch)) (equal-test? x) (not (equal? (caddr srch) (caddr x)))) (mem (cdr l))))))) ((disjoint? srch) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (equal? (car x) (car srch)))) (mem (cdr l))))))) ((eq? (car srch) (quote list?)) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (memq (car x) (quote (list? pair? null?))))) (mem (cdr l))))))) ((vec-structure? srch) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (or (disjoint? x) (vec-structure? x)) (not (equal? (car x) (quote vector?))) (not (equal? (car x) (car srch)))) (equal? x (quasiquote (not (vector? (unquote (cadr srch)))))) (mem (cdr l))))))) (else #f))))))) (equal-test? (lambda (tst) (and (eq? (car tst) (quote equal?)) (let ((p (caddr tst))) (cond ((string? p) (quote string?)) ((boolean? p) (quote boolean?)) ((char? p) (quote char?)) ((number? p) (quote number?)) ((and (pair? p) (pair? (cdr p)) (null? (cddr p)) (eq? (quote quote) (car p)) (symbol? (cadr p))) (quote symbol?)) (else #f)))))) (disjoint? (lambda (tst) (memq (car tst) match:disjoint-predicates))) (vec-structure? (lambda (tst) (memq (car tst) match:vector-structures))) (add-a (lambda (a) (let ((new (and (pair? a) (assq (car a) c---rs)))) (if new (cons (cadr new) (cdr a)) (quasiquote (car (unquote a))))))) (add-d (lambda (a) (let ((new (and (pair? a) (assq (car a) c---rs)))) (if new (cons (cddr new) (cdr a)) (quasiquote (cdr (unquote a))))))) (c---rs (quote ((car caar . cdar) (cdr cadr . cddr) (caar caaar . cdaar) (cadr caadr . cdadr) (cdar cadar . cddar) (cddr caddr . cdddr) (caaar caaaar . cdaaar) (caadr caaadr . cdaadr) (cadar caadar . cdadar) (caddr caaddr . cdaddr) (cdaar cadaar . cddaar) (cdadr cadadr . cddadr) (cddar caddar . cdddar) (cdddr cadddr . cddddr)))) (setter (lambda (e p) (let ((mk-setter (lambda (s) (symbol-append (quote set-) s (quote !))))) (cond ((not (pair? e)) (match:syntax-err p unnested set! pattern)) ((eq? (car e) (quote vector-ref)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (vector-set! x (unquote (caddr e)) y))))) ((eq? (car e) (quote unbox)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-box! x y))))) ((eq? (car e) (quote car)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-car! x y))))) ((eq? (car e) (quote cdr)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-cdr! x y))))) ((let ((a (assq (car e) get-c---rs))) (and a (quasiquote (let ((x ((unquote (cadr a)) (unquote (cadr e))))) (lambda (y) ((unquote (mk-setter (cddr a))) x y))))))) (else (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) ((unquote (mk-setter (car e))) x y))))))))) (getter (lambda (e p) (cond ((not (pair? e)) (match:syntax-err p unnested get! pattern)) ((eq? (car e) (quote vector-ref)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (vector-ref x (unquote (caddr e))))))) ((eq? (car e) (quote unbox)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (unbox x))))) ((eq? (car e) (quote car)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (car x))))) ((eq? (car e) (quote cdr)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (cdr x))))) ((let ((a (assq (car e) get-c---rs))) (and a (quasiquote (let ((x ((unquote (cadr a)) (unquote (cadr e))))) (lambda () ((unquote (cddr a)) x))))))) (else (quasiquote (let ((x (unquote (cadr e)))) (lambda () ((unquote (car e)) x)))))))) (get-c---rs (quote ((caar car . car) (cadr cdr . car) (cdar car . cdr) (cddr cdr . cdr) (caaar caar . car) (caadr cadr . car) (cadar cdar . car) (caddr cddr . car) (cdaar caar . cdr) (cdadr cadr . cdr) (cddar cdar . cdr) (cdddr cddr . cdr) (caaaar caaar . car) (caaadr caadr . car) (caadar cadar . car) (caaddr caddr . car) (cadaar cdaar . car) (cadadr cdadr . car) (caddar cddar . car) (cadddr cdddr . car) (cdaaar caaar . cdr) (cdaadr caadr . cdr) (cdadar cadar . cdr) (cdaddr caddr . cdr) (cddaar cdaar . cdr) (cddadr cdadr . cdr) (cdddar cddar . cdr) (cddddr cdddr . cdr)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l))))) (rac (lambda (l) (if (null? (cdr l)) (car l) (rac (cdr l))))) (rdc (lambda (l) (if (null? (cdr l)) (quote ()) (cons (car l) (rdc (cdr l))))))) (list genmatch genletrec gendefine pattern-var?))) +(defmacro match args (cond ((and (list? args) (<= 1 (length args)) (match:andmap (lambda (y) (and (list? y) (<= 2 (length y)))) (cdr args))) (let* ((exp (car args)) (clauses (cdr args)) (e (if (symbol? exp) exp (gentemp)))) (if (symbol? exp) ((car match:expanders) e clauses (quasiquote (match (unquote-splicing args)))) (quasiquote (let (((unquote e) (unquote exp))) (unquote ((car match:expanders) e clauses (quasiquote (match (unquote-splicing args)))))))))) (else (match:syntax-err (quasiquote (match (unquote-splicing args))) syntax error in)))) +(defmacro match-lambda args (if (and (list? args) (match:andmap (lambda (g195) (if (and (pair? g195) (list? (cdr g195))) (pair? (cdr g195)) #f)) args)) ((lambda () (let ((e (gentemp))) (quasiquote (lambda ((unquote e)) (match (unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err (quasiquote (match-lambda (unquote-splicing args))) syntax error in))))) +(defmacro match-lambda* args (if (and (list? args) (match:andmap (lambda (g203) (if (and (pair? g203) (list? (cdr g203))) (pair? (cdr g203)) #f)) args)) ((lambda () (let ((e (gentemp))) (quasiquote (lambda (unquote e) (match (unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err (quasiquote (match-lambda* (unquote-splicing args))) syntax error in))))) +(defmacro match-let args (let ((g227 (lambda (pat exp body) (quasiquote (match (unquote exp) ((unquote pat) (unquote-splicing body)))))) (g223 (lambda (pat exp body) (let ((g (map (lambda (x) (gentemp)) pat)) (vpattern (list->vector pat))) (quasiquote (let (unquote (map list g exp)) (match (vector (unquote-splicing g)) ((unquote vpattern) (unquote-splicing body)))))))) (g215 (lambda () (match:syntax-err (quasiquote (match-let (unquote-splicing args))) syntax error in))) (g214 (lambda (p1 e1 p2 e2 body) (let ((g1 (gentemp)) (g2 (gentemp))) (quasiquote (let (((unquote g1) (unquote e1)) ((unquote g2) (unquote e2))) (match (cons (unquote g1) (unquote g2)) (((unquote p1) unquote p2) (unquote-splicing body)))))))) (g205 (cadddr match:expanders))) (if (pair? args) (if (symbol? (car args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g230 ((g231 (cadr args)) (g229 (quote ())) (g228 (quote ()))) (if (null? g231) (if (and (list? (cddr args)) (pair? (cddr args))) ((lambda (name pat exp body) (if (match:andmap (cadddr match:expanders) pat) (quasiquote (let (unquote-splicing args))) (quasiquote (letrec (((unquote name) (match-lambda* ((unquote pat) (unquote-splicing body))))) ((unquote name) (unquote-splicing exp)))))) (car args) (reverse g228) (reverse g229) (cddr args)) (g215)) (if (and (pair? (car g231)) (pair? (cdar g231)) (null? (cddar g231))) (g230 (cdr g231) (cons (cadar g231) g229) (cons (caar g231) g228)) (g215)))) (g215)) (if (list? (car args)) (if (match:andmap (lambda (g236) (if (and (pair? g236) (g205 (car g236)) (pair? (cdr g236))) (null? (cddr g236)) #f)) (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda () (quasiquote (let (unquote-splicing args))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaar args) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g214 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (if (pair? (car args)) (if (and (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaar args) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g214 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (g215)))) (g215)))) +(defmacro match-let* args (let ((g245 (lambda () (match:syntax-err (quasiquote (match-let* (unquote-splicing args))) syntax error in)))) (if (pair? args) (if (null? (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda (body) (quasiquote (let* (unquote-splicing args)))) (cdr args)) (g245)) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args)) (list? (cdar args)) (list? (cdr args)) (pair? (cdr args))) ((lambda (pat exp rest body) (if ((cadddr match:expanders) pat) (quasiquote (let (((unquote pat) (unquote exp))) (match-let* (unquote rest) (unquote-splicing body)))) (quasiquote (match (unquote exp) ((unquote pat) (match-let* (unquote rest) (unquote-splicing body))))))) (caaar args) (cadaar args) (cdar args) (cdr args)) (g245))) (g245)))) +(defmacro match-letrec args (let ((g269 (cadddr match:expanders)) (g268 (lambda (p1 e1 p2 e2 body) (quasiquote (match-letrec ((((unquote p1) unquote p2) (cons (unquote e1) (unquote e2)))) (unquote-splicing body))))) (g264 (lambda () (match:syntax-err (quasiquote (match-letrec (unquote-splicing args))) syntax error in))) (g263 (lambda (pat exp body) (quasiquote (match-letrec (((unquote (list->vector pat)) (vector (unquote-splicing exp)))) (unquote-splicing body))))) (g255 (lambda (pat exp body) ((cadr match:expanders) pat exp body (quasiquote (match-letrec (((unquote pat) (unquote exp))) (unquote-splicing body))))))) (if (pair? args) (if (list? (car args)) (if (match:andmap (lambda (g275) (if (and (pair? g275) (g269 (car g275)) (pair? (cdr g275))) (null? (cddr g275)) #f)) (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda () (quasiquote (letrec (unquote-splicing args))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g255 (caaar args) (cadaar args) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g268 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (if (pair? (car args)) (if (and (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g255 (caaar args) (cadaar args) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g268 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (g264))) (g264)))) +(defmacro match-define args (let ((g279 (cadddr match:expanders)) (g278 (lambda () (match:syntax-err (quasiquote (match-define (unquote-splicing args))) syntax error in)))) (if (pair? args) (if (g279 (car args)) (if (and (pair? (cdr args)) (null? (cddr args))) ((lambda () (quasiquote (begin (define (unquote-splicing args)))))) (g278)) (if (and (pair? (cdr args)) (null? (cddr args))) ((lambda (pat exp) ((caddr match:expanders) pat exp (quasiquote (match-define (unquote-splicing args))))) (car args) (cadr args)) (g278))) (g278)))) +(define match:runtime-structures #f) +(define match:set-runtime-structures (lambda (v) (set! match:runtime-structures v))) +(define match:primitive-vector? vector?) +(defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda () #t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda (x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x))))) (mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x)) (match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let ((g296 (lambda () (match:syntax-err (quasiquote (defstruct (unquote-splicing args))) syntax error in)))) (if (and (pair? args) (symbol? (car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args)) (symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args)) (g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate fields) (let* ((selectors (map selector-name fields)) (mutators (map mutator-name fields)) (tag (if match:runtime-structures (gentemp) (quasiquote (quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq? match:structure-control (quote disjoint)) (quote match:primitive-vector?)) ((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq? match:structure-control (quote disjoint)) (if (eq? vector? match:primitive-vector?) (set! vector? (lambda (v) (and (match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol? (vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not (memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates (cons predicate match:disjoint-predicates)))) ((eq? match:structure-control (quote vector)) (if (not (memq predicate match:vector-structures)) (set! match:vector-structures (cons predicate match:vector-structures)))) (else (match:syntax-err (quote (vector disjoint)) invalid value for match:structure-control, legal values are))) (quasiquote (begin (unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define (unquote constructor) (lambda (unquote selectors) (vector (unquote tag) (unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and ((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing (filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda (obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing (filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n) (lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators)))))) (car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299)) (g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296))))) +(defmacro define-structure args (let ((g311 (lambda () (match:syntax-err (quasiquote (define-structure (unquote-splicing args))) syntax error in)))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g308 ((g309 (cadr args)) (g307 (quote ())) (g306 (quote ()))) (if (null? g309) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let ((mk-id (lambda (id) (if (and (pair? id) (equal? (car id) (quote @)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda (x) x) (cadr id)) ((lambda () (quasiquote (! (unquote id))))))))) (quasiquote (define-const-structure ((unquote name) (unquote-splicing (map mk-id id1))) (unquote (map (lambda (id v) (quasiquote ((unquote (mk-id id)) (unquote v)))) id2 val)))))) (caar args) (cdar args) (reverse g306) (reverse g307)) (g311)) (if (and (pair? (car g309)) (pair? (cdar g309)) (null? (cddar g309))) (g308 (cdr g309) (cons (cadar g309) g307) (cons (caar g309) g306)) (g311)))) (g311))) (g311)))) +(defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol? id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda () #f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator? (lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote (define-const-structure (unquote-splicing args))) syntax error in)))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if (and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args)) (g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor (symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin (defstruct (unquote name) (unquote raw-constructor) (unquote predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if (has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i)) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))) (symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2) (quasiquote (define (unquote constructor) (unquote raw-constructor))) (let* ((make-fresh (lambda (x) (if (eq? (quote _) x) (gentemp) x))) (names1 (map make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1) (let* (unquote (map list names2 val)) ((unquote raw-constructor) (unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing (filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _)) #f (quasiquote (define (unquote (symbol-append name (quote -) (field-name field))) (unquote (symbol-append name (quote -) i)))))) id1id2)) (unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq? (field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote (define (unquote (symbol-append (quote set-) name (quote -) (field-name field) (quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331)) (g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333)) (null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons (car g329) g327)) (g335)))) (g335))) (g335))))) From e5005373cfe19fcf29f9a9a488d3457b6c337b0c Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 25 Feb 2001 18:24:41 +0000 Subject: [PATCH 0604/2047] News for (ice-9 match). --- NEWS | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/NEWS b/NEWS index 9c8f90848..8e87f1ef3 100644 --- a/NEWS +++ b/NEWS @@ -95,6 +95,20 @@ future. Alternatively, if guile-scsh is installed, the (scsh rdelim) module can be used for similar functionality. +** New module (ice-9 match) + +This module includes Andrew K. Wright's pattern matcher: + +(use-modules (ice-9 match)) + +(match '(+ 1 2) + (('+ x) x) + (('+ x y) `(add ,x ,y)) + (('- x y) `(sub ,x ,y))) => (add 1 2) + +See ice-9/match.scm for brief description or +http://www.star-lab.com/wright/code.html for complete documentation. + * Changes to the stand-alone interpreter ** It's now possible to create modules with controlled environments From d1334b51678d092150d6cd6ba445483c7edd8d68 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 25 Feb 2001 18:30:26 +0000 Subject: [PATCH 0605/2047] Include match.scm. --- ice-9/Makefile.am | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index c0f0e0d74..d2ad1ee3b 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -25,8 +25,8 @@ AUTOMAKE_OPTIONS = foreign ice9_sources = \ and-let-star.scm arrays.scm boot-9.scm calling.scm common-list.scm \ debug.scm debugger.scm documentation.scm emacs.scm expect.scm \ - format.scm getopt-long.scm hcons.scm lineio.scm ls.scm \ - mapping.scm networking.scm null.scm optargs.scm poe.scm popen.scm \ + format.scm getopt-long.scm hcons.scm lineio.scm ls.scm mapping.scm \ + match.scm networking.scm null.scm optargs.scm poe.scm popen.scm \ posix.scm psyntax.pp psyntax.ss q.scm r4rs.scm r5rs.scm \ rdelim.scm receive.scm srfi-8.scm \ regex.scm runq.scm safe-r5rs.scm safe.scm session.scm slib.scm \ From 51e7dab66ff5ade5ed8059cef13e84e8d58e9daf Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 25 Feb 2001 18:31:57 +0000 Subject: [PATCH 0606/2047] * Makefile.am (ice9_sources): Added match.scm. --- ice-9/ChangeLog | 1 + 1 file changed, 1 insertion(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index a08172b48..640d45dfb 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,6 +1,7 @@ 2001-02-25 Keisuke Nishida * match.scm: New file, including Andrew K. Wright's pattern matcher. + * Makefile.am (ice9_sources): Added match.scm. 2001-02-16 Marius Vollmer From 0df43a35bf453a6afefaf31555209625c7d2cfb3 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 25 Feb 2001 19:22:28 +0000 Subject: [PATCH 0607/2047] *** empty log message *** --- RELEASE | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/RELEASE b/RELEASE index 0995419fd..64eb723ea 100644 --- a/RELEASE +++ b/RELEASE @@ -71,6 +71,13 @@ In release 1.6: - remove scm_tc7_msymbol - remove scm_tcs_symbols - remove scm_sloppy_memq, scm_sloppy_memv, scm_sloppy_member +- consider removing the automatic loading of (ice-9 rdelim) when guile + starts up. This would be a brave move, since a lot of code will + assume that read-line is available by default. However it would make + it easier to use alternative implementations of this module, e.g., a + strictly scsh-compatible version which uses multiple values. For + interactive use it would be easy to load the module in ~/.guile. +- remove scm_close_all_ports_except Modules sort.c and random.c should be factored out into separate modules (but still be distributed with guile-core) when we get a new From 4ce31633b48c6bb57a6ccb83342c7b6853d590d5 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 25 Feb 2001 19:33:02 +0000 Subject: [PATCH 0608/2047] Add comment for (ice-9 match). --- NEWS | 2 ++ 1 file changed, 2 insertions(+) diff --git a/NEWS b/NEWS index 8e87f1ef3..024bed287 100644 --- a/NEWS +++ b/NEWS @@ -109,6 +109,8 @@ This module includes Andrew K. Wright's pattern matcher: See ice-9/match.scm for brief description or http://www.star-lab.com/wright/code.html for complete documentation. +This module requires SLIB to be installed and available from Guile. + * Changes to the stand-alone interpreter ** It's now possible to create modules with controlled environments From aad61af58226c4a4617e62c095dccd66d3ca5f73 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 25 Feb 2001 19:44:44 +0000 Subject: [PATCH 0609/2047] Bug fixes. --- ice-9/match.scm | 28 +++++++++++++++------------- 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/ice-9/match.scm b/ice-9/match.scm index d2c3844e6..a05d37eee 100644 --- a/ice-9/match.scm +++ b/ice-9/match.scm @@ -28,6 +28,8 @@ match:structure-control match:set-structure-control match:runtime-structures match:set-runtime-structures)) +(define slib:error error) + ;; The original code can be found at the Scheme Repository ;; ;; http://www.cs.indiana.edu/scheme-repository/code.match.html @@ -171,11 +173,11 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (require (quote pretty-print)) -(define match:error (lambda (val . args) (for-each pretty-print args) (slib:error no matching clause for val))) +(define match:error (lambda (val . args) (for-each pretty-print args) (slib:error "no matching clause for " val))) (define match:andmap (lambda (f l) (if (null? l) (and) (and (f (car l)) (match:andmap f (cdr l)))))) (define match:syntax-err (lambda (obj msg) (slib:error msg obj))) (define match:disjoint-structure-tags (quote ())) -(define match:make-structure-tag (lambda (name) (if (or (eq? match:structure-control (quote disjoint)) match:runtime-structures) (let ((tag (gentemp))) (set! match:disjoint-structure-tags (cons tag match:disjoint-structure-tags)) tag) (string->symbol (string-append < (symbol->string name) >))))) +(define match:make-structure-tag (lambda (name) (if (or (eq? match:structure-control (quote disjoint)) match:runtime-structures) (let ((tag (gentemp))) (set! match:disjoint-structure-tags (cons tag match:disjoint-structure-tags)) tag) (string->symbol (string-append "<" (symbol->string name) ">"))))) (define match:structure? (lambda (tag) (memq tag match:disjoint-structure-tags))) (define match:structure-control (quote vector)) (define match:set-structure-control (lambda (v) (set! match:structure-control v))) @@ -184,17 +186,17 @@ (define match:set-error-control (lambda (v) (set! match:error-control v))) (define match:disjoint-predicates (cons (quote null) (quote (pair? symbol? boolean? number? string? char? procedure? vector?)))) (define match:vector-structures (quote ())) -(define match:expanders (letrec ((genmatch (lambda (x clauses match-expr) (let* ((length>= (gentemp)) (eb-errf (error-maker match-expr)) (blist (car eb-errf)) (plist (map (lambda (c) (let* ((x (bound (validate-pattern (car c)))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gentemp)) (fail (and (pair? (cdr c)) (pair? (cadr c)) (eq? (caadr c) (quote =>)) (symbol? (cadadr c)) (pair? (cdadr c)) (null? (cddadr c)) (pair? (cddr c)) (cadadr c))) (bv2 (if fail (cons fail bv) bv)) (body (if fail (cddr c) (cdr c)))) (set! blist (cons (quasiquote ((unquote code) (lambda (unquote bv2) (unquote-splicing body)))) (append bindings blist))) (list p code bv (and fail (gentemp)) #f))) clauses)) (code (gen x (quote ()) plist (cdr eb-errf) length>= (gentemp)))) (unreachable plist match-expr) (inline-let (quasiquote (let (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) (unquote-splicing blist)) (unquote code))))))) (genletrec (lambda (pat exp body match-expr) (let* ((length>= (gentemp)) (eb-errf (error-maker match-expr)) (x (bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gentemp)) (plist (list (list p code bv #f #f))) (x (gentemp)) (m (gen x (quote ()) plist (cdr eb-errf) length>= (gentemp))) (gs (map (lambda (_) (gentemp)) bv))) (unreachable plist match-expr) (quasiquote (letrec (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) (unquote-splicing (map (lambda (v) (quasiquote ((unquote v) #f))) bv)) ((unquote x) (unquote exp)) ((unquote code) (lambda (unquote gs) (unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote v) (unquote g)))) bv gs)) (unquote-splicing body))) (unquote-splicing bindings) (unquote-splicing (car eb-errf))) (unquote m)))))) (gendefine (lambda (pat exp match-expr) (let* ((length>= (gentemp)) (eb-errf (error-maker match-expr)) (x (bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gentemp)) (plist (list (list p code bv #f #f))) (x (gentemp)) (m (gen x (quote ()) plist (cdr eb-errf) length>= (gentemp))) (gs (map (lambda (_) (gentemp)) bv))) (unreachable plist match-expr) (quasiquote (begin (unquote-splicing (map (lambda (v) (quasiquote (define (unquote v) #f))) bv)) (unquote (inline-let (quasiquote (let (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) ((unquote x) (unquote exp)) ((unquote code) (lambda (unquote gs) (unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote v) (unquote g)))) bv gs)) (cond (#f #f)))) (unquote-splicing bindings) (unquote-splicing (car eb-errf))) (unquote m)))))))))) (pattern-var? (lambda (x) (and (symbol? x) (not (dot-dot-k? x)) (not (memq x (quote (quasiquote quote unquote unquote-splicing ? _ $ = and or not set! get! ... ___))))))) (dot-dot-k? (lambda (s) (and (symbol? s) (if (memq s (quote (... ___))) 0 (let* ((s (symbol->string s)) (n (string-length s))) (and (<= 3 n) (memq (string-ref s 0) (quote (. _))) (memq (string-ref s 1) (quote (. _))) (match:andmap char-numeric? (string->list (substring s 2 n))) (string->number (substring s 2 n)))))))) (error-maker (lambda (match-expr) (cond ((eq? match:error-control (quote unspecified)) (cons (quote ()) (lambda (x) (quasiquote (cond (#f #f)))))) ((memq match:error-control (quote (error fail))) (cons (quote ()) (lambda (x) (quasiquote (match:error (unquote x)))))) ((eq? match:error-control (quote match)) (let ((errf (gentemp)) (arg (gentemp))) (cons (quasiquote (((unquote errf) (lambda ((unquote arg)) (match:error (unquote arg) (quote (unquote match-expr))))))) (lambda (x) (quasiquote ((unquote errf) (unquote x))))))) (else (match:syntax-err (quote (unspecified error fail match)) invalid value for match:error-control, legal values are))))) (unreachable (lambda (plist match-expr) (for-each (lambda (x) (if (not (car (cddddr x))) (begin (display Warning: unreachable pattern ) (display (car x)) (display in ) (display match-expr) (newline)))) plist))) (validate-pattern (lambda (pattern) (letrec ((simple? (lambda (x) (or (string? x) (boolean? x) (char? x) (number? x) (null? x)))) (ordinary (lambda (p) (let ((g157 (lambda (x y) (cons (ordinary x) (ordinary y))))) (if (simple? p) ((lambda (p) p) p) (if (equal? p (quote _)) ((lambda () (quote _))) (if (pattern-var? p) ((lambda (p) p) p) (if (pair? p) (if (equal? (car p) (quote quasiquote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) (quasi p)) (cadr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote quote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote ?)) (if (and (pair? (cdr p)) (list? (cddr p))) ((lambda (pred ps) (quasiquote (? (unquote pred) (unquote-splicing (map ordinary ps))))) (cadr p) (cddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote =)) (if (and (pair? (cdr p)) (pair? (cddr p)) (null? (cdddr p))) ((lambda (sel p) (quasiquote (= (unquote sel) (unquote (ordinary p))))) (cadr p) (caddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote and)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (and (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote or)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (or (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote not)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (not (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote $)) (if (and (pair? (cdr p)) (symbol? (cadr p)) (list? (cddr p))) ((lambda (r ps) (quasiquote ($ (unquote r) (unquote-splicing (map ordinary ps))))) (cadr p) (cddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote set!)) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote get!)) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote unquote)) (g157 (car p) (cdr p)) (if (equal? (car p) (quote unquote-splicing)) (g157 (car p) (cdr p)) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cddr p))) ((lambda (p ddk) (quasiquote ((unquote (ordinary p)) (unquote ddk)))) (car p) (cadr p)) (g157 (car p) (cdr p))))))))))))))) (if (vector? p) ((lambda (p) (let* ((pl (vector->list p)) (rpl (reverse pl))) (apply vector (if (and (not (null? rpl)) (dot-dot-k? (car rpl))) (reverse (cons (car rpl) (map ordinary (cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err pattern syntax error in pattern))))))))))) (quasi (lambda (p) (let ((g178 (lambda (x y) (cons (quasi x) (quasi y))))) (if (simple? p) ((lambda (p) p) p) (if (symbol? p) ((lambda (p) (quasiquote (quote (unquote p)))) p) (if (pair? p) (if (equal? (car p) (quote unquote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) (ordinary p)) (cadr p)) (g178 (car p) (cdr p))) (if (and (pair? (car p)) (equal? (caar p) (quote unquote-splicing)) (pair? (cdar p)) (null? (cddar p))) (if (null? (cdr p)) ((lambda (p) (ordinary p)) (cadar p)) ((lambda (p y) (append (ordlist p) (quasi y))) (cadar p) (cdr p))) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cddr p))) ((lambda (p ddk) (quasiquote ((unquote (quasi p)) (unquote ddk)))) (car p) (cadr p)) (g178 (car p) (cdr p))))) (if (vector? p) ((lambda (p) (let* ((pl (vector->list p)) (rpl (reverse pl))) (apply vector (if (dot-dot-k? (car rpl)) (reverse (cons (car rpl) (map quasi (cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err pattern syntax error in pattern)))))))))) (ordlist (lambda (p) (cond ((null? p) (quote ())) ((pair? p) (cons (ordinary (car p)) (ordlist (cdr p)))) (else (match:syntax-err pattern invalid use of unquote-splicing in pattern)))))) (ordinary pattern)))) (bound (lambda (pattern) (letrec ((pred-bodies (quote ())) (bound (lambda (p a k) (cond ((eq? (quote _) p) (k p a)) ((symbol? p) (if (memq p a) (match:syntax-err pattern duplicate variable in pattern)) (k p (cons p a))) ((and (pair? p) (eq? (quote quote) (car p))) (k p a)) ((and (pair? p) (eq? (quote ?) (car p))) (cond ((not (null? (cddr p))) (bound (quasiquote (and (? (unquote (cadr p))) (unquote-splicing (cddr p)))) a k)) ((or (not (symbol? (cadr p))) (memq (cadr p) a)) (let ((g (gentemp))) (set! pred-bodies (cons (quasiquote ((unquote g) (unquote (cadr p)))) pred-bodies)) (k (quasiquote (? (unquote g))) a))) (else (k p a)))) ((and (pair? p) (eq? (quote =) (car p))) (cond ((or (not (symbol? (cadr p))) (memq (cadr p) a)) (let ((g (gentemp))) (set! pred-bodies (cons (quasiquote ((unquote g) (unquote (cadr p)))) pred-bodies)) (bound (quasiquote (= (unquote g) (unquote (caddr p)))) a k))) (else (bound (caddr p) a (lambda (p2 a) (k (quasiquote (= (unquote (cadr p)) (unquote p2))) a)))))) ((and (pair? p) (eq? (quote and) (car p))) (bound* (cdr p) a (lambda (p a) (k (quasiquote (and (unquote-splicing p))) a)))) ((and (pair? p) (eq? (quote or) (car p))) (bound (cadr p) a (lambda (first-p first-a) (let or* ((plist (cddr p)) (k (lambda (plist) (k (quasiquote (or (unquote first-p) (unquote-splicing plist))) first-a)))) (if (null? plist) (k plist) (bound (car plist) a (lambda (car-p car-a) (if (not (permutation car-a first-a)) (match:syntax-err pattern variables of or-pattern differ in)) (or* (cdr plist) (lambda (cdr-p) (k (cons car-p cdr-p))))))))))) ((and (pair? p) (eq? (quote not) (car p))) (cond ((not (null? (cddr p))) (bound (quasiquote (not (or (unquote-splicing (cdr p))))) a k)) (else (bound (cadr p) a (lambda (p2 a2) (if (not (permutation a a2)) (match:syntax-err p no variables allowed in)) (k (quasiquote (not (unquote p2))) a)))))) ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p))) (bound (car p) a (lambda (q b) (let ((bvars (find-prefix b a))) (k (quasiquote ((unquote q) (unquote (cadr p)) (unquote bvars) (unquote (gentemp)) (unquote (gentemp)) (unquote (map (lambda (_) (gentemp)) bvars)))) b))))) ((and (pair? p) (eq? (quote $) (car p))) (bound* (cddr p) a (lambda (p1 a) (k (quasiquote ($ (unquote (cadr p)) (unquote-splicing p1))) a)))) ((and (pair? p) (eq? (quote set!) (car p))) (if (memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((and (pair? p) (eq? (quote get!) (car p))) (if (memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((pair? p) (bound (car p) a (lambda (car-p a) (bound (cdr p) a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))) ((vector? p) (boundv (vector->list p) a (lambda (pl a) (k (list->vector pl) a)))) (else (k p a))))) (boundv (lambda (plist a k) (let ((g184 (lambda () (k plist a)))) (if (pair? plist) (if (and (pair? (cdr plist)) (dot-dot-k? (cadr plist)) (null? (cddr plist))) ((lambda () (bound plist a k))) (if (null? plist) (g184) ((lambda (x y) (bound x a (lambda (car-p a) (boundv y a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))) (car plist) (cdr plist)))) (if (null? plist) (g184) (match:error plist)))))) (bound* (lambda (plist a k) (if (null? plist) (k plist a) (bound (car plist) a (lambda (car-p a) (bound* (cdr plist) a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))))) (find-prefix (lambda (b a) (if (eq? b a) (quote ()) (cons (car b) (find-prefix (cdr b) a))))) (permutation (lambda (p1 p2) (and (= (length p1) (length p2)) (match:andmap (lambda (x1) (memq x1 p2)) p1))))) (bound pattern (quote ()) (lambda (p a) (list p (reverse a) pred-bodies)))))) (inline-let (lambda (let-exp) (letrec ((occ (lambda (x e) (let loop ((e e)) (cond ((pair? e) (+ (loop (car e)) (loop (cdr e)))) ((eq? x e) 1) (else 0))))) (subst (lambda (e old new) (let loop ((e e)) (cond ((pair? e) (cons (loop (car e)) (loop (cdr e)))) ((eq? old e) new) (else e))))) (const? (lambda (sexp) (or (symbol? sexp) (boolean? sexp) (string? sexp) (char? sexp) (number? sexp) (null? sexp) (and (pair? sexp) (eq? (car sexp) (quote quote)) (pair? (cdr sexp)) (symbol? (cadr sexp)) (null? (cddr sexp)))))) (isval? (lambda (sexp) (or (const? sexp) (and (pair? sexp) (memq (car sexp) (quote (lambda quote match-lambda match-lambda*))))))) (small? (lambda (sexp) (or (const? sexp) (and (pair? sexp) (eq? (car sexp) (quote lambda)) (pair? (cdr sexp)) (pair? (cddr sexp)) (const? (caddr sexp)) (null? (cdddr sexp))))))) (let loop ((b (cadr let-exp)) (new-b (quote ())) (e (caddr let-exp))) (cond ((null? b) (if (null? new-b) e (quasiquote (let (unquote (reverse new-b)) (unquote e))))) ((isval? (cadr (car b))) (let* ((x (caar b)) (n (occ x e))) (cond ((= 0 n) (loop (cdr b) new-b e)) ((or (= 1 n) (small? (cadr (car b)))) (loop (cdr b) new-b (subst e x (cadr (car b))))) (else (loop (cdr b) (cons (car b) new-b) e))))) (else (loop (cdr b) (cons (car b) new-b) e))))))) (gen (lambda (x sf plist erract length>= eta) (if (null? plist) (erract x) (let* ((v (quote ())) (val (lambda (x) (cdr (assq x v)))) (fail (lambda (sf) (gen x sf (cdr plist) erract length>= eta))) (success (lambda (sf) (set-car! (cddddr (car plist)) #t) (let* ((code (cadr (car plist))) (bv (caddr (car plist))) (fail-sym (cadddr (car plist)))) (if fail-sym (let ((ap (quasiquote ((unquote code) (unquote fail-sym) (unquote-splicing (map val bv)))))) (quasiquote (call-with-current-continuation (lambda ((unquote fail-sym)) (let (((unquote fail-sym) (lambda () ((unquote fail-sym) (unquote (fail sf)))))) (unquote ap)))))) (quasiquote ((unquote code) (unquote-splicing (map val bv))))))))) (let next ((p (caar plist)) (e x) (sf sf) (kf fail) (ks success)) (cond ((eq? (quote _) p) (ks sf)) ((symbol? p) (set! v (cons (cons p e) v)) (ks sf)) ((null? p) (emit (quasiquote (null? (unquote e))) sf kf ks)) ((equal? p (quote (quote ()))) (emit (quasiquote (null? (unquote e))) sf kf ks)) ((string? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((boolean? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((char? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((number? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((and (pair? p) (eq? (quote quote) (car p))) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((and (pair? p) (eq? (quote ?) (car p))) (let ((tst (quasiquote ((unquote (cadr p)) (unquote e))))) (emit tst sf kf ks))) ((and (pair? p) (eq? (quote =) (car p))) (next (caddr p) (quasiquote ((unquote (cadr p)) (unquote e))) sf kf ks)) ((and (pair? p) (eq? (quote and) (car p))) (let loop ((p (cdr p)) (sf sf)) (if (null? p) (ks sf) (next (car p) e sf kf (lambda (sf) (loop (cdr p) sf)))))) ((and (pair? p) (eq? (quote or) (car p))) (let ((or-v v)) (let loop ((p (cdr p)) (sf sf)) (if (null? p) (kf sf) (begin (set! v or-v) (next (car p) e sf (lambda (sf) (loop (cdr p) sf)) ks)))))) ((and (pair? p) (eq? (quote not) (car p))) (next (cadr p) e sf ks kf)) ((and (pair? p) (eq? (quote $) (car p))) (let* ((tag (cadr p)) (fields (cdr p)) (rlen (length fields)) (tst (quasiquote ((unquote (symbol-append tag (quote ?))) (unquote e))))) (emit tst sf kf (let rloop ((n 1)) (lambda (sf) (if (= n rlen) (ks sf) (next (list-ref fields n) (quasiquote ((unquote (symbol-append tag (quote -) n)) (unquote e))) sf kf (rloop (+ 1 n))))))))) ((and (pair? p) (eq? (quote set!) (car p))) (set! v (cons (cons (cadr p) (setter e p)) v)) (ks sf)) ((and (pair? p) (eq? (quote get!) (car p))) (set! v (cons (cons (cadr p) (getter e p)) v)) (ks sf)) ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p))) (emit (quasiquote (list? (unquote e))) sf kf (lambda (sf) (let* ((k (dot-dot-k? (cadr p))) (ks (lambda (sf) (let ((bound (list-ref p 2))) (cond ((eq? (car p) (quote _)) (ks sf)) ((null? bound) (let* ((ptst (next (car p) eta sf (lambda (sf) #f) (lambda (sf) #t))) (tst (if (and (pair? ptst) (symbol? (car ptst)) (pair? (cdr ptst)) (eq? eta (cadr ptst)) (null? (cddr ptst))) (car ptst) (quasiquote (lambda ((unquote eta)) (unquote ptst)))))) (assm (quasiquote (match:andmap (unquote tst) (unquote e))) (kf sf) (ks sf)))) ((and (symbol? (car p)) (equal? (list (car p)) bound)) (next (car p) e sf kf ks)) (else (let* ((gloop (list-ref p 3)) (ge (list-ref p 4)) (fresh (list-ref p 5)) (p1 (next (car p) (quasiquote (car (unquote ge))) sf kf (lambda (sf) (quasiquote ((unquote gloop) (cdr (unquote ge)) (unquote-splicing (map (lambda (b f) (quasiquote (cons (unquote (val b)) (unquote f)))) bound fresh)))))))) (set! v (append (map cons bound (map (lambda (x) (quasiquote (reverse (unquote x)))) fresh)) v)) (quasiquote (let (unquote gloop) (((unquote ge) (unquote e)) (unquote-splicing (map (lambda (x) (quasiquote ((unquote x) (quote ())))) fresh))) (if (null? (unquote ge)) (unquote (ks sf)) (unquote p1))))))))))) (case k ((0) (ks sf)) ((1) (emit (quasiquote (pair? (unquote e))) sf kf ks)) (else (emit (quasiquote (((unquote length>=) (unquote k)) (unquote e))) sf kf ks))))))) ((pair? p) (emit (quasiquote (pair? (unquote e))) sf kf (lambda (sf) (next (car p) (add-a e) sf kf (lambda (sf) (next (cdr p) (add-d e) sf kf ks)))))) ((and (vector? p) (>= (vector-length p) 6) (dot-dot-k? (vector-ref p (- (vector-length p) 5)))) (let* ((vlen (- (vector-length p) 6)) (k (dot-dot-k? (vector-ref p (+ vlen 1)))) (minlen (+ vlen k)) (bound (vector-ref p (+ vlen 2)))) (emit (quasiquote (vector? (unquote e))) sf kf (lambda (sf) (assm (quasiquote (>= (vector-length (unquote e)) (unquote minlen))) (kf sf) ((let vloop ((n 0)) (lambda (sf) (cond ((not (= n vlen)) (next (vector-ref p n) (quasiquote (vector-ref (unquote e) (unquote n))) sf kf (vloop (+ 1 n)))) ((eq? (vector-ref p vlen) (quote _)) (ks sf)) (else (let* ((gloop (vector-ref p (+ vlen 3))) (ind (vector-ref p (+ vlen 4))) (fresh (vector-ref p (+ vlen 5))) (p1 (next (vector-ref p vlen) (quasiquote (vector-ref (unquote e) (unquote ind))) sf kf (lambda (sf) (quasiquote ((unquote gloop) (- (unquote ind) 1) (unquote-splicing (map (lambda (b f) (quasiquote (cons (unquote (val b)) (unquote f)))) bound fresh)))))))) (set! v (append (map cons bound fresh) v)) (quasiquote (let (unquote gloop) (((unquote ind) (- (vector-length (unquote e)) 1)) (unquote-splicing (map (lambda (x) (quasiquote ((unquote x) (quote ())))) fresh))) (if (> (unquote minlen) (unquote ind)) (unquote (ks sf)) (unquote p1))))))))) sf)))))) ((vector? p) (let ((vlen (vector-length p))) (emit (quasiquote (vector? (unquote e))) sf kf (lambda (sf) (emit (quasiquote (equal? (vector-length (unquote e)) (unquote vlen))) sf kf (let vloop ((n 0)) (lambda (sf) (if (= n vlen) (ks sf) (next (vector-ref p n) (quasiquote (vector-ref (unquote e) (unquote n))) sf kf (vloop (+ 1 n))))))))))) (else (display FATAL ERROR IN PATTERN MATCHER) (newline) (error #f THIS NEVER HAPPENS)))))))) (emit (lambda (tst sf kf ks) (cond ((in tst sf) (ks sf)) ((in (quasiquote (not (unquote tst))) sf) (kf sf)) (else (let* ((e (cadr tst)) (implied (cond ((eq? (car tst) (quote equal?)) (let ((p (caddr tst))) (cond ((string? p) (quasiquote ((string? (unquote e))))) ((boolean? p) (quasiquote ((boolean? (unquote e))))) ((char? p) (quasiquote ((char? (unquote e))))) ((number? p) (quasiquote ((number? (unquote e))))) ((and (pair? p) (eq? (quote quote) (car p))) (quasiquote ((symbol? (unquote e))))) (else (quote ()))))) ((eq? (car tst) (quote null?)) (quasiquote ((list? (unquote e))))) ((vec-structure? tst) (quasiquote ((vector? (unquote e))))) (else (quote ())))) (not-imp (case (car tst) ((list?) (quasiquote ((not (null? (unquote e)))))) (else (quote ())))) (s (ks (cons tst (append implied sf)))) (k (kf (cons (quasiquote (not (unquote tst))) (append not-imp sf))))) (assm tst k s)))))) (assm (lambda (tst f s) (cond ((equal? s f) s) ((and (eq? s #t) (eq? f #f)) tst) ((and (eq? (car tst) (quote pair?)) (memq match:error-control (quote (unspecified fail))) (memq (car f) (quote (cond match:error))) (guarantees s (cadr tst))) s) ((and (pair? s) (eq? (car s) (quote if)) (equal? (cadddr s) f)) (if (eq? (car (cadr s)) (quote and)) (quasiquote (if (and (unquote tst) (unquote-splicing (cdr (cadr s)))) (unquote (caddr s)) (unquote f))) (quasiquote (if (and (unquote tst) (unquote (cadr s))) (unquote (caddr s)) (unquote f))))) ((and (pair? s) (equal? (car s) (quote call-with-current-continuation)) (pair? (cdr s)) (pair? (cadr s)) (equal? (caadr s) (quote lambda)) (pair? (cdadr s)) (pair? (cadadr s)) (null? (cdr (cadadr s))) (pair? (cddadr s)) (pair? (car (cddadr s))) (equal? (caar (cddadr s)) (quote let)) (pair? (cdar (cddadr s))) (pair? (cadar (cddadr s))) (pair? (caadar (cddadr s))) (pair? (cdr (caadar (cddadr s)))) (pair? (cadr (caadar (cddadr s)))) (equal? (caadr (caadar (cddadr s))) (quote lambda)) (pair? (cdadr (caadar (cddadr s)))) (null? (cadadr (caadar (cddadr s)))) (pair? (cddadr (caadar (cddadr s)))) (pair? (car (cddadr (caadar (cddadr s))))) (pair? (cdar (cddadr (caadar (cddadr s))))) (null? (cddar (cddadr (caadar (cddadr s))))) (null? (cdr (cddadr (caadar (cddadr s))))) (null? (cddr (caadar (cddadr s)))) (null? (cdadar (cddadr s))) (pair? (cddar (cddadr s))) (null? (cdddar (cddadr s))) (null? (cdr (cddadr s))) (null? (cddr s)) (equal? f (cadar (cddadr (caadar (cddadr s)))))) (let ((k (car (cadadr s))) (fail (car (caadar (cddadr s)))) (s2 (caddar (cddadr s)))) (quasiquote (call-with-current-continuation (lambda ((unquote k)) (let (((unquote fail) (lambda () ((unquote k) (unquote f))))) (unquote (assm tst (quasiquote ((unquote fail))) s2)))))))) ((and #f (pair? s) (equal? (car s) (quote let)) (pair? (cdr s)) (pair? (cadr s)) (pair? (caadr s)) (pair? (cdaadr s)) (pair? (car (cdaadr s))) (equal? (caar (cdaadr s)) (quote lambda)) (pair? (cdar (cdaadr s))) (null? (cadar (cdaadr s))) (pair? (cddar (cdaadr s))) (null? (cdddar (cdaadr s))) (null? (cdr (cdaadr s))) (null? (cdadr s)) (pair? (cddr s)) (null? (cdddr s)) (equal? (caddar (cdaadr s)) f)) (let ((fail (caaadr s)) (s2 (caddr s))) (quasiquote (let (((unquote fail) (lambda () (unquote f)))) (unquote (assm tst (quasiquote ((unquote fail))) s2)))))) (else (quasiquote (if (unquote tst) (unquote s) (unquote f))))))) (guarantees (lambda (code x) (let ((a (add-a x)) (d (add-d x))) (let loop ((code code)) (cond ((not (pair? code)) #f) ((memq (car code) (quote (cond match:error))) #t) ((or (equal? code a) (equal? code d)) #t) ((eq? (car code) (quote if)) (or (loop (cadr code)) (and (loop (caddr code)) (loop (cadddr code))))) ((eq? (car code) (quote lambda)) #f) ((and (eq? (car code) (quote let)) (symbol? (cadr code))) #f) (else (or (loop (car code)) (loop (cdr code))))))))) (in (lambda (e l) (or (member e l) (and (eq? (car e) (quote list?)) (or (member (quasiquote (null? (unquote (cadr e)))) l) (member (quasiquote (pair? (unquote (cadr e)))) l))) (and (eq? (car e) (quote not)) (let* ((srch (cadr e)) (const-class (equal-test? srch))) (cond (const-class (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (equal? const-class (car x)))) (equal? x (quasiquote (not ((unquote const-class) (unquote (cadr srch)))))) (and (equal? (cadr x) (cadr srch)) (equal-test? x) (not (equal? (caddr srch) (caddr x)))) (mem (cdr l))))))) ((disjoint? srch) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (equal? (car x) (car srch)))) (mem (cdr l))))))) ((eq? (car srch) (quote list?)) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (memq (car x) (quote (list? pair? null?))))) (mem (cdr l))))))) ((vec-structure? srch) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (or (disjoint? x) (vec-structure? x)) (not (equal? (car x) (quote vector?))) (not (equal? (car x) (car srch)))) (equal? x (quasiquote (not (vector? (unquote (cadr srch)))))) (mem (cdr l))))))) (else #f))))))) (equal-test? (lambda (tst) (and (eq? (car tst) (quote equal?)) (let ((p (caddr tst))) (cond ((string? p) (quote string?)) ((boolean? p) (quote boolean?)) ((char? p) (quote char?)) ((number? p) (quote number?)) ((and (pair? p) (pair? (cdr p)) (null? (cddr p)) (eq? (quote quote) (car p)) (symbol? (cadr p))) (quote symbol?)) (else #f)))))) (disjoint? (lambda (tst) (memq (car tst) match:disjoint-predicates))) (vec-structure? (lambda (tst) (memq (car tst) match:vector-structures))) (add-a (lambda (a) (let ((new (and (pair? a) (assq (car a) c---rs)))) (if new (cons (cadr new) (cdr a)) (quasiquote (car (unquote a))))))) (add-d (lambda (a) (let ((new (and (pair? a) (assq (car a) c---rs)))) (if new (cons (cddr new) (cdr a)) (quasiquote (cdr (unquote a))))))) (c---rs (quote ((car caar . cdar) (cdr cadr . cddr) (caar caaar . cdaar) (cadr caadr . cdadr) (cdar cadar . cddar) (cddr caddr . cdddr) (caaar caaaar . cdaaar) (caadr caaadr . cdaadr) (cadar caadar . cdadar) (caddr caaddr . cdaddr) (cdaar cadaar . cddaar) (cdadr cadadr . cddadr) (cddar caddar . cdddar) (cdddr cadddr . cddddr)))) (setter (lambda (e p) (let ((mk-setter (lambda (s) (symbol-append (quote set-) s (quote !))))) (cond ((not (pair? e)) (match:syntax-err p unnested set! pattern)) ((eq? (car e) (quote vector-ref)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (vector-set! x (unquote (caddr e)) y))))) ((eq? (car e) (quote unbox)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-box! x y))))) ((eq? (car e) (quote car)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-car! x y))))) ((eq? (car e) (quote cdr)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-cdr! x y))))) ((let ((a (assq (car e) get-c---rs))) (and a (quasiquote (let ((x ((unquote (cadr a)) (unquote (cadr e))))) (lambda (y) ((unquote (mk-setter (cddr a))) x y))))))) (else (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) ((unquote (mk-setter (car e))) x y))))))))) (getter (lambda (e p) (cond ((not (pair? e)) (match:syntax-err p unnested get! pattern)) ((eq? (car e) (quote vector-ref)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (vector-ref x (unquote (caddr e))))))) ((eq? (car e) (quote unbox)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (unbox x))))) ((eq? (car e) (quote car)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (car x))))) ((eq? (car e) (quote cdr)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (cdr x))))) ((let ((a (assq (car e) get-c---rs))) (and a (quasiquote (let ((x ((unquote (cadr a)) (unquote (cadr e))))) (lambda () ((unquote (cddr a)) x))))))) (else (quasiquote (let ((x (unquote (cadr e)))) (lambda () ((unquote (car e)) x)))))))) (get-c---rs (quote ((caar car . car) (cadr cdr . car) (cdar car . cdr) (cddr cdr . cdr) (caaar caar . car) (caadr cadr . car) (cadar cdar . car) (caddr cddr . car) (cdaar caar . cdr) (cdadr cadr . cdr) (cddar cdar . cdr) (cdddr cddr . cdr) (caaaar caaar . car) (caaadr caadr . car) (caadar cadar . car) (caaddr caddr . car) (cadaar cdaar . car) (cadadr cdadr . car) (caddar cddar . car) (cadddr cdddr . car) (cdaaar caaar . cdr) (cdaadr caadr . cdr) (cdadar cadar . cdr) (cdaddr caddr . cdr) (cddaar cdaar . cdr) (cddadr cdadr . cdr) (cdddar cddar . cdr) (cddddr cdddr . cdr)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l))))) (rac (lambda (l) (if (null? (cdr l)) (car l) (rac (cdr l))))) (rdc (lambda (l) (if (null? (cdr l)) (quote ()) (cons (car l) (rdc (cdr l))))))) (list genmatch genletrec gendefine pattern-var?))) -(defmacro match args (cond ((and (list? args) (<= 1 (length args)) (match:andmap (lambda (y) (and (list? y) (<= 2 (length y)))) (cdr args))) (let* ((exp (car args)) (clauses (cdr args)) (e (if (symbol? exp) exp (gentemp)))) (if (symbol? exp) ((car match:expanders) e clauses (quasiquote (match (unquote-splicing args)))) (quasiquote (let (((unquote e) (unquote exp))) (unquote ((car match:expanders) e clauses (quasiquote (match (unquote-splicing args)))))))))) (else (match:syntax-err (quasiquote (match (unquote-splicing args))) syntax error in)))) -(defmacro match-lambda args (if (and (list? args) (match:andmap (lambda (g195) (if (and (pair? g195) (list? (cdr g195))) (pair? (cdr g195)) #f)) args)) ((lambda () (let ((e (gentemp))) (quasiquote (lambda ((unquote e)) (match (unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err (quasiquote (match-lambda (unquote-splicing args))) syntax error in))))) -(defmacro match-lambda* args (if (and (list? args) (match:andmap (lambda (g203) (if (and (pair? g203) (list? (cdr g203))) (pair? (cdr g203)) #f)) args)) ((lambda () (let ((e (gentemp))) (quasiquote (lambda (unquote e) (match (unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err (quasiquote (match-lambda* (unquote-splicing args))) syntax error in))))) -(defmacro match-let args (let ((g227 (lambda (pat exp body) (quasiquote (match (unquote exp) ((unquote pat) (unquote-splicing body)))))) (g223 (lambda (pat exp body) (let ((g (map (lambda (x) (gentemp)) pat)) (vpattern (list->vector pat))) (quasiquote (let (unquote (map list g exp)) (match (vector (unquote-splicing g)) ((unquote vpattern) (unquote-splicing body)))))))) (g215 (lambda () (match:syntax-err (quasiquote (match-let (unquote-splicing args))) syntax error in))) (g214 (lambda (p1 e1 p2 e2 body) (let ((g1 (gentemp)) (g2 (gentemp))) (quasiquote (let (((unquote g1) (unquote e1)) ((unquote g2) (unquote e2))) (match (cons (unquote g1) (unquote g2)) (((unquote p1) unquote p2) (unquote-splicing body)))))))) (g205 (cadddr match:expanders))) (if (pair? args) (if (symbol? (car args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g230 ((g231 (cadr args)) (g229 (quote ())) (g228 (quote ()))) (if (null? g231) (if (and (list? (cddr args)) (pair? (cddr args))) ((lambda (name pat exp body) (if (match:andmap (cadddr match:expanders) pat) (quasiquote (let (unquote-splicing args))) (quasiquote (letrec (((unquote name) (match-lambda* ((unquote pat) (unquote-splicing body))))) ((unquote name) (unquote-splicing exp)))))) (car args) (reverse g228) (reverse g229) (cddr args)) (g215)) (if (and (pair? (car g231)) (pair? (cdar g231)) (null? (cddar g231))) (g230 (cdr g231) (cons (cadar g231) g229) (cons (caar g231) g228)) (g215)))) (g215)) (if (list? (car args)) (if (match:andmap (lambda (g236) (if (and (pair? g236) (g205 (car g236)) (pair? (cdr g236))) (null? (cddr g236)) #f)) (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda () (quasiquote (let (unquote-splicing args))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaar args) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g214 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (if (pair? (car args)) (if (and (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaar args) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g214 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (g215)))) (g215)))) -(defmacro match-let* args (let ((g245 (lambda () (match:syntax-err (quasiquote (match-let* (unquote-splicing args))) syntax error in)))) (if (pair? args) (if (null? (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda (body) (quasiquote (let* (unquote-splicing args)))) (cdr args)) (g245)) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args)) (list? (cdar args)) (list? (cdr args)) (pair? (cdr args))) ((lambda (pat exp rest body) (if ((cadddr match:expanders) pat) (quasiquote (let (((unquote pat) (unquote exp))) (match-let* (unquote rest) (unquote-splicing body)))) (quasiquote (match (unquote exp) ((unquote pat) (match-let* (unquote rest) (unquote-splicing body))))))) (caaar args) (cadaar args) (cdar args) (cdr args)) (g245))) (g245)))) -(defmacro match-letrec args (let ((g269 (cadddr match:expanders)) (g268 (lambda (p1 e1 p2 e2 body) (quasiquote (match-letrec ((((unquote p1) unquote p2) (cons (unquote e1) (unquote e2)))) (unquote-splicing body))))) (g264 (lambda () (match:syntax-err (quasiquote (match-letrec (unquote-splicing args))) syntax error in))) (g263 (lambda (pat exp body) (quasiquote (match-letrec (((unquote (list->vector pat)) (vector (unquote-splicing exp)))) (unquote-splicing body))))) (g255 (lambda (pat exp body) ((cadr match:expanders) pat exp body (quasiquote (match-letrec (((unquote pat) (unquote exp))) (unquote-splicing body))))))) (if (pair? args) (if (list? (car args)) (if (match:andmap (lambda (g275) (if (and (pair? g275) (g269 (car g275)) (pair? (cdr g275))) (null? (cddr g275)) #f)) (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda () (quasiquote (letrec (unquote-splicing args))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g255 (caaar args) (cadaar args) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g268 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (if (pair? (car args)) (if (and (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g255 (caaar args) (cadaar args) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g268 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (g264))) (g264)))) -(defmacro match-define args (let ((g279 (cadddr match:expanders)) (g278 (lambda () (match:syntax-err (quasiquote (match-define (unquote-splicing args))) syntax error in)))) (if (pair? args) (if (g279 (car args)) (if (and (pair? (cdr args)) (null? (cddr args))) ((lambda () (quasiquote (begin (define (unquote-splicing args)))))) (g278)) (if (and (pair? (cdr args)) (null? (cddr args))) ((lambda (pat exp) ((caddr match:expanders) pat exp (quasiquote (match-define (unquote-splicing args))))) (car args) (cadr args)) (g278))) (g278)))) +(define match:expanders (letrec ((genmatch (lambda (x clauses match-expr) (let* ((length>= (gentemp)) (eb-errf (error-maker match-expr)) (blist (car eb-errf)) (plist (map (lambda (c) (let* ((x (bound (validate-pattern (car c)))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gentemp)) (fail (and (pair? (cdr c)) (pair? (cadr c)) (eq? (caadr c) (quote =>)) (symbol? (cadadr c)) (pair? (cdadr c)) (null? (cddadr c)) (pair? (cddr c)) (cadadr c))) (bv2 (if fail (cons fail bv) bv)) (body (if fail (cddr c) (cdr c)))) (set! blist (cons (quasiquote ((unquote code) (lambda (unquote bv2) (unquote-splicing body)))) (append bindings blist))) (list p code bv (and fail (gentemp)) #f))) clauses)) (code (gen x (quote ()) plist (cdr eb-errf) length>= (gentemp)))) (unreachable plist match-expr) (inline-let (quasiquote (let (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) (unquote-splicing blist)) (unquote code))))))) (genletrec (lambda (pat exp body match-expr) (let* ((length>= (gentemp)) (eb-errf (error-maker match-expr)) (x (bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gentemp)) (plist (list (list p code bv #f #f))) (x (gentemp)) (m (gen x (quote ()) plist (cdr eb-errf) length>= (gentemp))) (gs (map (lambda (_) (gentemp)) bv))) (unreachable plist match-expr) (quasiquote (letrec (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) (unquote-splicing (map (lambda (v) (quasiquote ((unquote v) #f))) bv)) ((unquote x) (unquote exp)) ((unquote code) (lambda (unquote gs) (unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote v) (unquote g)))) bv gs)) (unquote-splicing body))) (unquote-splicing bindings) (unquote-splicing (car eb-errf))) (unquote m)))))) (gendefine (lambda (pat exp match-expr) (let* ((length>= (gentemp)) (eb-errf (error-maker match-expr)) (x (bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gentemp)) (plist (list (list p code bv #f #f))) (x (gentemp)) (m (gen x (quote ()) plist (cdr eb-errf) length>= (gentemp))) (gs (map (lambda (_) (gentemp)) bv))) (unreachable plist match-expr) (quasiquote (begin (unquote-splicing (map (lambda (v) (quasiquote (define (unquote v) #f))) bv)) (unquote (inline-let (quasiquote (let (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) ((unquote x) (unquote exp)) ((unquote code) (lambda (unquote gs) (unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote v) (unquote g)))) bv gs)) (cond (#f #f)))) (unquote-splicing bindings) (unquote-splicing (car eb-errf))) (unquote m)))))))))) (pattern-var? (lambda (x) (and (symbol? x) (not (dot-dot-k? x)) (not (memq x (quote (quasiquote quote unquote unquote-splicing ? _ $ = and or not set! get! ... ___))))))) (dot-dot-k? (lambda (s) (and (symbol? s) (if (memq s (quote (... ___))) 0 (let* ((s (symbol->string s)) (n (string-length s))) (and (<= 3 n) (memq (string-ref s 0) (quote (#\. #\_))) (memq (string-ref s 1) (quote (#\. #\_))) (match:andmap char-numeric? (string->list (substring s 2 n))) (string->number (substring s 2 n)))))))) (error-maker (lambda (match-expr) (cond ((eq? match:error-control (quote unspecified)) (cons (quote ()) (lambda (x) (quasiquote (cond (#f #f)))))) ((memq match:error-control (quote (error fail))) (cons (quote ()) (lambda (x) (quasiquote (match:error (unquote x)))))) ((eq? match:error-control (quote match)) (let ((errf (gentemp)) (arg (gentemp))) (cons (quasiquote (((unquote errf) (lambda ((unquote arg)) (match:error (unquote arg) (quote (unquote match-expr))))))) (lambda (x) (quasiquote ((unquote errf) (unquote x))))))) (else (match:syntax-err (quote (unspecified error fail match)) "invalid value for match:error-control, legal values are"))))) (unreachable (lambda (plist match-expr) (for-each (lambda (x) (if (not (car (cddddr x))) (begin (display "Warning: unreachable pattern ") (display (car x)) (display " in ") (display match-expr) (newline)))) plist))) (validate-pattern (lambda (pattern) (letrec ((simple? (lambda (x) (or (string? x) (boolean? x) (char? x) (number? x) (null? x)))) (ordinary (lambda (p) (let ((g157 (lambda (x y) (cons (ordinary x) (ordinary y))))) (if (simple? p) ((lambda (p) p) p) (if (equal? p (quote _)) ((lambda () (quote _))) (if (pattern-var? p) ((lambda (p) p) p) (if (pair? p) (if (equal? (car p) (quote quasiquote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) (quasi p)) (cadr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote quote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote ?)) (if (and (pair? (cdr p)) (list? (cddr p))) ((lambda (pred ps) (quasiquote (? (unquote pred) (unquote-splicing (map ordinary ps))))) (cadr p) (cddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote =)) (if (and (pair? (cdr p)) (pair? (cddr p)) (null? (cdddr p))) ((lambda (sel p) (quasiquote (= (unquote sel) (unquote (ordinary p))))) (cadr p) (caddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote and)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (and (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote or)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (or (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote not)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (not (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote $)) (if (and (pair? (cdr p)) (symbol? (cadr p)) (list? (cddr p))) ((lambda (r ps) (quasiquote ($ (unquote r) (unquote-splicing (map ordinary ps))))) (cadr p) (cddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote set!)) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote get!)) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote unquote)) (g157 (car p) (cdr p)) (if (equal? (car p) (quote unquote-splicing)) (g157 (car p) (cdr p)) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cddr p))) ((lambda (p ddk) (quasiquote ((unquote (ordinary p)) (unquote ddk)))) (car p) (cadr p)) (g157 (car p) (cdr p))))))))))))))) (if (vector? p) ((lambda (p) (let* ((pl (vector->list p)) (rpl (reverse pl))) (apply vector (if (and (not (null? rpl)) (dot-dot-k? (car rpl))) (reverse (cons (car rpl) (map ordinary (cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err pattern "syntax error in pattern"))))))))))) (quasi (lambda (p) (let ((g178 (lambda (x y) (cons (quasi x) (quasi y))))) (if (simple? p) ((lambda (p) p) p) (if (symbol? p) ((lambda (p) (quasiquote (quote (unquote p)))) p) (if (pair? p) (if (equal? (car p) (quote unquote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) (ordinary p)) (cadr p)) (g178 (car p) (cdr p))) (if (and (pair? (car p)) (equal? (caar p) (quote unquote-splicing)) (pair? (cdar p)) (null? (cddar p))) (if (null? (cdr p)) ((lambda (p) (ordinary p)) (cadar p)) ((lambda (p y) (append (ordlist p) (quasi y))) (cadar p) (cdr p))) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cddr p))) ((lambda (p ddk) (quasiquote ((unquote (quasi p)) (unquote ddk)))) (car p) (cadr p)) (g178 (car p) (cdr p))))) (if (vector? p) ((lambda (p) (let* ((pl (vector->list p)) (rpl (reverse pl))) (apply vector (if (dot-dot-k? (car rpl)) (reverse (cons (car rpl) (map quasi (cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err pattern "syntax error in pattern")))))))))) (ordlist (lambda (p) (cond ((null? p) (quote ())) ((pair? p) (cons (ordinary (car p)) (ordlist (cdr p)))) (else (match:syntax-err pattern "invalid use of unquote-splicing in pattern")))))) (ordinary pattern)))) (bound (lambda (pattern) (letrec ((pred-bodies (quote ())) (bound (lambda (p a k) (cond ((eq? (quote _) p) (k p a)) ((symbol? p) (if (memq p a) (match:syntax-err pattern "duplicate variable in pattern")) (k p (cons p a))) ((and (pair? p) (eq? (quote quote) (car p))) (k p a)) ((and (pair? p) (eq? (quote ?) (car p))) (cond ((not (null? (cddr p))) (bound (quasiquote (and (? (unquote (cadr p))) (unquote-splicing (cddr p)))) a k)) ((or (not (symbol? (cadr p))) (memq (cadr p) a)) (let ((g (gentemp))) (set! pred-bodies (cons (quasiquote ((unquote g) (unquote (cadr p)))) pred-bodies)) (k (quasiquote (? (unquote g))) a))) (else (k p a)))) ((and (pair? p) (eq? (quote =) (car p))) (cond ((or (not (symbol? (cadr p))) (memq (cadr p) a)) (let ((g (gentemp))) (set! pred-bodies (cons (quasiquote ((unquote g) (unquote (cadr p)))) pred-bodies)) (bound (quasiquote (= (unquote g) (unquote (caddr p)))) a k))) (else (bound (caddr p) a (lambda (p2 a) (k (quasiquote (= (unquote (cadr p)) (unquote p2))) a)))))) ((and (pair? p) (eq? (quote and) (car p))) (bound* (cdr p) a (lambda (p a) (k (quasiquote (and (unquote-splicing p))) a)))) ((and (pair? p) (eq? (quote or) (car p))) (bound (cadr p) a (lambda (first-p first-a) (let or* ((plist (cddr p)) (k (lambda (plist) (k (quasiquote (or (unquote first-p) (unquote-splicing plist))) first-a)))) (if (null? plist) (k plist) (bound (car plist) a (lambda (car-p car-a) (if (not (permutation car-a first-a)) (match:syntax-err pattern "variables of or-pattern differ in")) (or* (cdr plist) (lambda (cdr-p) (k (cons car-p cdr-p))))))))))) ((and (pair? p) (eq? (quote not) (car p))) (cond ((not (null? (cddr p))) (bound (quasiquote (not (or (unquote-splicing (cdr p))))) a k)) (else (bound (cadr p) a (lambda (p2 a2) (if (not (permutation a a2)) (match:syntax-err p "no variables allowed in")) (k (quasiquote (not (unquote p2))) a)))))) ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p))) (bound (car p) a (lambda (q b) (let ((bvars (find-prefix b a))) (k (quasiquote ((unquote q) (unquote (cadr p)) (unquote bvars) (unquote (gentemp)) (unquote (gentemp)) (unquote (map (lambda (_) (gentemp)) bvars)))) b))))) ((and (pair? p) (eq? (quote $) (car p))) (bound* (cddr p) a (lambda (p1 a) (k (quasiquote ($ (unquote (cadr p)) (unquote-splicing p1))) a)))) ((and (pair? p) (eq? (quote set!) (car p))) (if (memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((and (pair? p) (eq? (quote get!) (car p))) (if (memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((pair? p) (bound (car p) a (lambda (car-p a) (bound (cdr p) a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))) ((vector? p) (boundv (vector->list p) a (lambda (pl a) (k (list->vector pl) a)))) (else (k p a))))) (boundv (lambda (plist a k) (let ((g184 (lambda () (k plist a)))) (if (pair? plist) (if (and (pair? (cdr plist)) (dot-dot-k? (cadr plist)) (null? (cddr plist))) ((lambda () (bound plist a k))) (if (null? plist) (g184) ((lambda (x y) (bound x a (lambda (car-p a) (boundv y a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))) (car plist) (cdr plist)))) (if (null? plist) (g184) (match:error plist)))))) (bound* (lambda (plist a k) (if (null? plist) (k plist a) (bound (car plist) a (lambda (car-p a) (bound* (cdr plist) a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))))) (find-prefix (lambda (b a) (if (eq? b a) (quote ()) (cons (car b) (find-prefix (cdr b) a))))) (permutation (lambda (p1 p2) (and (= (length p1) (length p2)) (match:andmap (lambda (x1) (memq x1 p2)) p1))))) (bound pattern (quote ()) (lambda (p a) (list p (reverse a) pred-bodies)))))) (inline-let (lambda (let-exp) (letrec ((occ (lambda (x e) (let loop ((e e)) (cond ((pair? e) (+ (loop (car e)) (loop (cdr e)))) ((eq? x e) 1) (else 0))))) (subst (lambda (e old new) (let loop ((e e)) (cond ((pair? e) (cons (loop (car e)) (loop (cdr e)))) ((eq? old e) new) (else e))))) (const? (lambda (sexp) (or (symbol? sexp) (boolean? sexp) (string? sexp) (char? sexp) (number? sexp) (null? sexp) (and (pair? sexp) (eq? (car sexp) (quote quote)) (pair? (cdr sexp)) (symbol? (cadr sexp)) (null? (cddr sexp)))))) (isval? (lambda (sexp) (or (const? sexp) (and (pair? sexp) (memq (car sexp) (quote (lambda quote match-lambda match-lambda*))))))) (small? (lambda (sexp) (or (const? sexp) (and (pair? sexp) (eq? (car sexp) (quote lambda)) (pair? (cdr sexp)) (pair? (cddr sexp)) (const? (caddr sexp)) (null? (cdddr sexp))))))) (let loop ((b (cadr let-exp)) (new-b (quote ())) (e (caddr let-exp))) (cond ((null? b) (if (null? new-b) e (quasiquote (let (unquote (reverse new-b)) (unquote e))))) ((isval? (cadr (car b))) (let* ((x (caar b)) (n (occ x e))) (cond ((= 0 n) (loop (cdr b) new-b e)) ((or (= 1 n) (small? (cadr (car b)))) (loop (cdr b) new-b (subst e x (cadr (car b))))) (else (loop (cdr b) (cons (car b) new-b) e))))) (else (loop (cdr b) (cons (car b) new-b) e))))))) (gen (lambda (x sf plist erract length>= eta) (if (null? plist) (erract x) (let* ((v (quote ())) (val (lambda (x) (cdr (assq x v)))) (fail (lambda (sf) (gen x sf (cdr plist) erract length>= eta))) (success (lambda (sf) (set-car! (cddddr (car plist)) #t) (let* ((code (cadr (car plist))) (bv (caddr (car plist))) (fail-sym (cadddr (car plist)))) (if fail-sym (let ((ap (quasiquote ((unquote code) (unquote fail-sym) (unquote-splicing (map val bv)))))) (quasiquote (call-with-current-continuation (lambda ((unquote fail-sym)) (let (((unquote fail-sym) (lambda () ((unquote fail-sym) (unquote (fail sf)))))) (unquote ap)))))) (quasiquote ((unquote code) (unquote-splicing (map val bv))))))))) (let next ((p (caar plist)) (e x) (sf sf) (kf fail) (ks success)) (cond ((eq? (quote _) p) (ks sf)) ((symbol? p) (set! v (cons (cons p e) v)) (ks sf)) ((null? p) (emit (quasiquote (null? (unquote e))) sf kf ks)) ((equal? p (quote (quote ()))) (emit (quasiquote (null? (unquote e))) sf kf ks)) ((string? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((boolean? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((char? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((number? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((and (pair? p) (eq? (quote quote) (car p))) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((and (pair? p) (eq? (quote ?) (car p))) (let ((tst (quasiquote ((unquote (cadr p)) (unquote e))))) (emit tst sf kf ks))) ((and (pair? p) (eq? (quote =) (car p))) (next (caddr p) (quasiquote ((unquote (cadr p)) (unquote e))) sf kf ks)) ((and (pair? p) (eq? (quote and) (car p))) (let loop ((p (cdr p)) (sf sf)) (if (null? p) (ks sf) (next (car p) e sf kf (lambda (sf) (loop (cdr p) sf)))))) ((and (pair? p) (eq? (quote or) (car p))) (let ((or-v v)) (let loop ((p (cdr p)) (sf sf)) (if (null? p) (kf sf) (begin (set! v or-v) (next (car p) e sf (lambda (sf) (loop (cdr p) sf)) ks)))))) ((and (pair? p) (eq? (quote not) (car p))) (next (cadr p) e sf ks kf)) ((and (pair? p) (eq? (quote $) (car p))) (let* ((tag (cadr p)) (fields (cdr p)) (rlen (length fields)) (tst (quasiquote ((unquote (symbol-append tag (quote ?))) (unquote e))))) (emit tst sf kf (let rloop ((n 1)) (lambda (sf) (if (= n rlen) (ks sf) (next (list-ref fields n) (quasiquote ((unquote (symbol-append tag (quote -) n)) (unquote e))) sf kf (rloop (+ 1 n))))))))) ((and (pair? p) (eq? (quote set!) (car p))) (set! v (cons (cons (cadr p) (setter e p)) v)) (ks sf)) ((and (pair? p) (eq? (quote get!) (car p))) (set! v (cons (cons (cadr p) (getter e p)) v)) (ks sf)) ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p))) (emit (quasiquote (list? (unquote e))) sf kf (lambda (sf) (let* ((k (dot-dot-k? (cadr p))) (ks (lambda (sf) (let ((bound (list-ref p 2))) (cond ((eq? (car p) (quote _)) (ks sf)) ((null? bound) (let* ((ptst (next (car p) eta sf (lambda (sf) #f) (lambda (sf) #t))) (tst (if (and (pair? ptst) (symbol? (car ptst)) (pair? (cdr ptst)) (eq? eta (cadr ptst)) (null? (cddr ptst))) (car ptst) (quasiquote (lambda ((unquote eta)) (unquote ptst)))))) (assm (quasiquote (match:andmap (unquote tst) (unquote e))) (kf sf) (ks sf)))) ((and (symbol? (car p)) (equal? (list (car p)) bound)) (next (car p) e sf kf ks)) (else (let* ((gloop (list-ref p 3)) (ge (list-ref p 4)) (fresh (list-ref p 5)) (p1 (next (car p) (quasiquote (car (unquote ge))) sf kf (lambda (sf) (quasiquote ((unquote gloop) (cdr (unquote ge)) (unquote-splicing (map (lambda (b f) (quasiquote (cons (unquote (val b)) (unquote f)))) bound fresh)))))))) (set! v (append (map cons bound (map (lambda (x) (quasiquote (reverse (unquote x)))) fresh)) v)) (quasiquote (let (unquote gloop) (((unquote ge) (unquote e)) (unquote-splicing (map (lambda (x) (quasiquote ((unquote x) (quote ())))) fresh))) (if (null? (unquote ge)) (unquote (ks sf)) (unquote p1))))))))))) (case k ((0) (ks sf)) ((1) (emit (quasiquote (pair? (unquote e))) sf kf ks)) (else (emit (quasiquote (((unquote length>=) (unquote k)) (unquote e))) sf kf ks))))))) ((pair? p) (emit (quasiquote (pair? (unquote e))) sf kf (lambda (sf) (next (car p) (add-a e) sf kf (lambda (sf) (next (cdr p) (add-d e) sf kf ks)))))) ((and (vector? p) (>= (vector-length p) 6) (dot-dot-k? (vector-ref p (- (vector-length p) 5)))) (let* ((vlen (- (vector-length p) 6)) (k (dot-dot-k? (vector-ref p (+ vlen 1)))) (minlen (+ vlen k)) (bound (vector-ref p (+ vlen 2)))) (emit (quasiquote (vector? (unquote e))) sf kf (lambda (sf) (assm (quasiquote (>= (vector-length (unquote e)) (unquote minlen))) (kf sf) ((let vloop ((n 0)) (lambda (sf) (cond ((not (= n vlen)) (next (vector-ref p n) (quasiquote (vector-ref (unquote e) (unquote n))) sf kf (vloop (+ 1 n)))) ((eq? (vector-ref p vlen) (quote _)) (ks sf)) (else (let* ((gloop (vector-ref p (+ vlen 3))) (ind (vector-ref p (+ vlen 4))) (fresh (vector-ref p (+ vlen 5))) (p1 (next (vector-ref p vlen) (quasiquote (vector-ref (unquote e) (unquote ind))) sf kf (lambda (sf) (quasiquote ((unquote gloop) (- (unquote ind) 1) (unquote-splicing (map (lambda (b f) (quasiquote (cons (unquote (val b)) (unquote f)))) bound fresh)))))))) (set! v (append (map cons bound fresh) v)) (quasiquote (let (unquote gloop) (((unquote ind) (- (vector-length (unquote e)) 1)) (unquote-splicing (map (lambda (x) (quasiquote ((unquote x) (quote ())))) fresh))) (if (> (unquote minlen) (unquote ind)) (unquote (ks sf)) (unquote p1))))))))) sf)))))) ((vector? p) (let ((vlen (vector-length p))) (emit (quasiquote (vector? (unquote e))) sf kf (lambda (sf) (emit (quasiquote (equal? (vector-length (unquote e)) (unquote vlen))) sf kf (let vloop ((n 0)) (lambda (sf) (if (= n vlen) (ks sf) (next (vector-ref p n) (quasiquote (vector-ref (unquote e) (unquote n))) sf kf (vloop (+ 1 n))))))))))) (else (display "FATAL ERROR IN PATTERN MATCHER") (newline) (error #f "THIS NEVER HAPPENS")))))))) (emit (lambda (tst sf kf ks) (cond ((in tst sf) (ks sf)) ((in (quasiquote (not (unquote tst))) sf) (kf sf)) (else (let* ((e (cadr tst)) (implied (cond ((eq? (car tst) (quote equal?)) (let ((p (caddr tst))) (cond ((string? p) (quasiquote ((string? (unquote e))))) ((boolean? p) (quasiquote ((boolean? (unquote e))))) ((char? p) (quasiquote ((char? (unquote e))))) ((number? p) (quasiquote ((number? (unquote e))))) ((and (pair? p) (eq? (quote quote) (car p))) (quasiquote ((symbol? (unquote e))))) (else (quote ()))))) ((eq? (car tst) (quote null?)) (quasiquote ((list? (unquote e))))) ((vec-structure? tst) (quasiquote ((vector? (unquote e))))) (else (quote ())))) (not-imp (case (car tst) ((list?) (quasiquote ((not (null? (unquote e)))))) (else (quote ())))) (s (ks (cons tst (append implied sf)))) (k (kf (cons (quasiquote (not (unquote tst))) (append not-imp sf))))) (assm tst k s)))))) (assm (lambda (tst f s) (cond ((equal? s f) s) ((and (eq? s #t) (eq? f #f)) tst) ((and (eq? (car tst) (quote pair?)) (memq match:error-control (quote (unspecified fail))) (memq (car f) (quote (cond match:error))) (guarantees s (cadr tst))) s) ((and (pair? s) (eq? (car s) (quote if)) (equal? (cadddr s) f)) (if (eq? (car (cadr s)) (quote and)) (quasiquote (if (and (unquote tst) (unquote-splicing (cdr (cadr s)))) (unquote (caddr s)) (unquote f))) (quasiquote (if (and (unquote tst) (unquote (cadr s))) (unquote (caddr s)) (unquote f))))) ((and (pair? s) (equal? (car s) (quote call-with-current-continuation)) (pair? (cdr s)) (pair? (cadr s)) (equal? (caadr s) (quote lambda)) (pair? (cdadr s)) (pair? (cadadr s)) (null? (cdr (cadadr s))) (pair? (cddadr s)) (pair? (car (cddadr s))) (equal? (caar (cddadr s)) (quote let)) (pair? (cdar (cddadr s))) (pair? (cadar (cddadr s))) (pair? (caadar (cddadr s))) (pair? (cdr (caadar (cddadr s)))) (pair? (cadr (caadar (cddadr s)))) (equal? (caadr (caadar (cddadr s))) (quote lambda)) (pair? (cdadr (caadar (cddadr s)))) (null? (cadadr (caadar (cddadr s)))) (pair? (cddadr (caadar (cddadr s)))) (pair? (car (cddadr (caadar (cddadr s))))) (pair? (cdar (cddadr (caadar (cddadr s))))) (null? (cddar (cddadr (caadar (cddadr s))))) (null? (cdr (cddadr (caadar (cddadr s))))) (null? (cddr (caadar (cddadr s)))) (null? (cdadar (cddadr s))) (pair? (cddar (cddadr s))) (null? (cdddar (cddadr s))) (null? (cdr (cddadr s))) (null? (cddr s)) (equal? f (cadar (cddadr (caadar (cddadr s)))))) (let ((k (car (cadadr s))) (fail (car (caadar (cddadr s)))) (s2 (caddar (cddadr s)))) (quasiquote (call-with-current-continuation (lambda ((unquote k)) (let (((unquote fail) (lambda () ((unquote k) (unquote f))))) (unquote (assm tst (quasiquote ((unquote fail))) s2)))))))) ((and #f (pair? s) (equal? (car s) (quote let)) (pair? (cdr s)) (pair? (cadr s)) (pair? (caadr s)) (pair? (cdaadr s)) (pair? (car (cdaadr s))) (equal? (caar (cdaadr s)) (quote lambda)) (pair? (cdar (cdaadr s))) (null? (cadar (cdaadr s))) (pair? (cddar (cdaadr s))) (null? (cdddar (cdaadr s))) (null? (cdr (cdaadr s))) (null? (cdadr s)) (pair? (cddr s)) (null? (cdddr s)) (equal? (caddar (cdaadr s)) f)) (let ((fail (caaadr s)) (s2 (caddr s))) (quasiquote (let (((unquote fail) (lambda () (unquote f)))) (unquote (assm tst (quasiquote ((unquote fail))) s2)))))) (else (quasiquote (if (unquote tst) (unquote s) (unquote f))))))) (guarantees (lambda (code x) (let ((a (add-a x)) (d (add-d x))) (let loop ((code code)) (cond ((not (pair? code)) #f) ((memq (car code) (quote (cond match:error))) #t) ((or (equal? code a) (equal? code d)) #t) ((eq? (car code) (quote if)) (or (loop (cadr code)) (and (loop (caddr code)) (loop (cadddr code))))) ((eq? (car code) (quote lambda)) #f) ((and (eq? (car code) (quote let)) (symbol? (cadr code))) #f) (else (or (loop (car code)) (loop (cdr code))))))))) (in (lambda (e l) (or (member e l) (and (eq? (car e) (quote list?)) (or (member (quasiquote (null? (unquote (cadr e)))) l) (member (quasiquote (pair? (unquote (cadr e)))) l))) (and (eq? (car e) (quote not)) (let* ((srch (cadr e)) (const-class (equal-test? srch))) (cond (const-class (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (equal? const-class (car x)))) (equal? x (quasiquote (not ((unquote const-class) (unquote (cadr srch)))))) (and (equal? (cadr x) (cadr srch)) (equal-test? x) (not (equal? (caddr srch) (caddr x)))) (mem (cdr l))))))) ((disjoint? srch) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (equal? (car x) (car srch)))) (mem (cdr l))))))) ((eq? (car srch) (quote list?)) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (memq (car x) (quote (list? pair? null?))))) (mem (cdr l))))))) ((vec-structure? srch) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (or (disjoint? x) (vec-structure? x)) (not (equal? (car x) (quote vector?))) (not (equal? (car x) (car srch)))) (equal? x (quasiquote (not (vector? (unquote (cadr srch)))))) (mem (cdr l))))))) (else #f))))))) (equal-test? (lambda (tst) (and (eq? (car tst) (quote equal?)) (let ((p (caddr tst))) (cond ((string? p) (quote string?)) ((boolean? p) (quote boolean?)) ((char? p) (quote char?)) ((number? p) (quote number?)) ((and (pair? p) (pair? (cdr p)) (null? (cddr p)) (eq? (quote quote) (car p)) (symbol? (cadr p))) (quote symbol?)) (else #f)))))) (disjoint? (lambda (tst) (memq (car tst) match:disjoint-predicates))) (vec-structure? (lambda (tst) (memq (car tst) match:vector-structures))) (add-a (lambda (a) (let ((new (and (pair? a) (assq (car a) c---rs)))) (if new (cons (cadr new) (cdr a)) (quasiquote (car (unquote a))))))) (add-d (lambda (a) (let ((new (and (pair? a) (assq (car a) c---rs)))) (if new (cons (cddr new) (cdr a)) (quasiquote (cdr (unquote a))))))) (c---rs (quote ((car caar . cdar) (cdr cadr . cddr) (caar caaar . cdaar) (cadr caadr . cdadr) (cdar cadar . cddar) (cddr caddr . cdddr) (caaar caaaar . cdaaar) (caadr caaadr . cdaadr) (cadar caadar . cdadar) (caddr caaddr . cdaddr) (cdaar cadaar . cddaar) (cdadr cadadr . cddadr) (cddar caddar . cdddar) (cdddr cadddr . cddddr)))) (setter (lambda (e p) (let ((mk-setter (lambda (s) (symbol-append (quote set-) s (quote !))))) (cond ((not (pair? e)) (match:syntax-err p "unnested set! pattern")) ((eq? (car e) (quote vector-ref)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (vector-set! x (unquote (caddr e)) y))))) ((eq? (car e) (quote unbox)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-box! x y))))) ((eq? (car e) (quote car)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-car! x y))))) ((eq? (car e) (quote cdr)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-cdr! x y))))) ((let ((a (assq (car e) get-c---rs))) (and a (quasiquote (let ((x ((unquote (cadr a)) (unquote (cadr e))))) (lambda (y) ((unquote (mk-setter (cddr a))) x y))))))) (else (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) ((unquote (mk-setter (car e))) x y))))))))) (getter (lambda (e p) (cond ((not (pair? e)) (match:syntax-err p "unnested get! pattern")) ((eq? (car e) (quote vector-ref)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (vector-ref x (unquote (caddr e))))))) ((eq? (car e) (quote unbox)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (unbox x))))) ((eq? (car e) (quote car)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (car x))))) ((eq? (car e) (quote cdr)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (cdr x))))) ((let ((a (assq (car e) get-c---rs))) (and a (quasiquote (let ((x ((unquote (cadr a)) (unquote (cadr e))))) (lambda () ((unquote (cddr a)) x))))))) (else (quasiquote (let ((x (unquote (cadr e)))) (lambda () ((unquote (car e)) x)))))))) (get-c---rs (quote ((caar car . car) (cadr cdr . car) (cdar car . cdr) (cddr cdr . cdr) (caaar caar . car) (caadr cadr . car) (cadar cdar . car) (caddr cddr . car) (cdaar caar . cdr) (cdadr cadr . cdr) (cddar cdar . cdr) (cdddr cddr . cdr) (caaaar caaar . car) (caaadr caadr . car) (caadar cadar . car) (caaddr caddr . car) (cadaar cdaar . car) (cadadr cdadr . car) (caddar cddar . car) (cadddr cdddr . car) (cdaaar caaar . cdr) (cdaadr caadr . cdr) (cdadar cadar . cdr) (cdaddr caddr . cdr) (cddaar cdaar . cdr) (cddadr cdadr . cdr) (cdddar cddar . cdr) (cddddr cdddr . cdr)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l))))) (rac (lambda (l) (if (null? (cdr l)) (car l) (rac (cdr l))))) (rdc (lambda (l) (if (null? (cdr l)) (quote ()) (cons (car l) (rdc (cdr l))))))) (list genmatch genletrec gendefine pattern-var?))) +(defmacro match args (cond ((and (list? args) (<= 1 (length args)) (match:andmap (lambda (y) (and (list? y) (<= 2 (length y)))) (cdr args))) (let* ((exp (car args)) (clauses (cdr args)) (e (if (symbol? exp) exp (gentemp)))) (if (symbol? exp) ((car match:expanders) e clauses (quasiquote (match (unquote-splicing args)))) (quasiquote (let (((unquote e) (unquote exp))) (unquote ((car match:expanders) e clauses (quasiquote (match (unquote-splicing args)))))))))) (else (match:syntax-err (quasiquote (match (unquote-splicing args))) "syntax error in")))) +(defmacro match-lambda args (if (and (list? args) (match:andmap (lambda (g195) (if (and (pair? g195) (list? (cdr g195))) (pair? (cdr g195)) #f)) args)) ((lambda () (let ((e (gentemp))) (quasiquote (lambda ((unquote e)) (match (unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err (quasiquote (match-lambda (unquote-splicing args))) "syntax error in"))))) +(defmacro match-lambda* args (if (and (list? args) (match:andmap (lambda (g203) (if (and (pair? g203) (list? (cdr g203))) (pair? (cdr g203)) #f)) args)) ((lambda () (let ((e (gentemp))) (quasiquote (lambda (unquote e) (match (unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err (quasiquote (match-lambda* (unquote-splicing args))) "syntax error in"))))) +(defmacro match-let args (let ((g227 (lambda (pat exp body) (quasiquote (match (unquote exp) ((unquote pat) (unquote-splicing body)))))) (g223 (lambda (pat exp body) (let ((g (map (lambda (x) (gentemp)) pat)) (vpattern (list->vector pat))) (quasiquote (let (unquote (map list g exp)) (match (vector (unquote-splicing g)) ((unquote vpattern) (unquote-splicing body)))))))) (g215 (lambda () (match:syntax-err (quasiquote (match-let (unquote-splicing args))) "syntax error in"))) (g214 (lambda (p1 e1 p2 e2 body) (let ((g1 (gentemp)) (g2 (gentemp))) (quasiquote (let (((unquote g1) (unquote e1)) ((unquote g2) (unquote e2))) (match (cons (unquote g1) (unquote g2)) (((unquote p1) unquote p2) (unquote-splicing body)))))))) (g205 (cadddr match:expanders))) (if (pair? args) (if (symbol? (car args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g230 ((g231 (cadr args)) (g229 (quote ())) (g228 (quote ()))) (if (null? g231) (if (and (list? (cddr args)) (pair? (cddr args))) ((lambda (name pat exp body) (if (match:andmap (cadddr match:expanders) pat) (quasiquote (let (unquote-splicing args))) (quasiquote (letrec (((unquote name) (match-lambda* ((unquote pat) (unquote-splicing body))))) ((unquote name) (unquote-splicing exp)))))) (car args) (reverse g228) (reverse g229) (cddr args)) (g215)) (if (and (pair? (car g231)) (pair? (cdar g231)) (null? (cddar g231))) (g230 (cdr g231) (cons (cadar g231) g229) (cons (caar g231) g228)) (g215)))) (g215)) (if (list? (car args)) (if (match:andmap (lambda (g236) (if (and (pair? g236) (g205 (car g236)) (pair? (cdr g236))) (null? (cddr g236)) #f)) (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda () (quasiquote (let (unquote-splicing args))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaar args) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g214 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (if (pair? (car args)) (if (and (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaar args) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g214 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (g215)))) (g215)))) +(defmacro match-let* args (let ((g245 (lambda () (match:syntax-err (quasiquote (match-let* (unquote-splicing args))) "syntax error in")))) (if (pair? args) (if (null? (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda (body) (quasiquote (let* (unquote-splicing args)))) (cdr args)) (g245)) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args)) (list? (cdar args)) (list? (cdr args)) (pair? (cdr args))) ((lambda (pat exp rest body) (if ((cadddr match:expanders) pat) (quasiquote (let (((unquote pat) (unquote exp))) (match-let* (unquote rest) (unquote-splicing body)))) (quasiquote (match (unquote exp) ((unquote pat) (match-let* (unquote rest) (unquote-splicing body))))))) (caaar args) (cadaar args) (cdar args) (cdr args)) (g245))) (g245)))) +(defmacro match-letrec args (let ((g269 (cadddr match:expanders)) (g268 (lambda (p1 e1 p2 e2 body) (quasiquote (match-letrec ((((unquote p1) unquote p2) (cons (unquote e1) (unquote e2)))) (unquote-splicing body))))) (g264 (lambda () (match:syntax-err (quasiquote (match-letrec (unquote-splicing args))) "syntax error in"))) (g263 (lambda (pat exp body) (quasiquote (match-letrec (((unquote (list->vector pat)) (vector (unquote-splicing exp)))) (unquote-splicing body))))) (g255 (lambda (pat exp body) ((cadr match:expanders) pat exp body (quasiquote (match-letrec (((unquote pat) (unquote exp))) (unquote-splicing body))))))) (if (pair? args) (if (list? (car args)) (if (match:andmap (lambda (g275) (if (and (pair? g275) (g269 (car g275)) (pair? (cdr g275))) (null? (cddr g275)) #f)) (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda () (quasiquote (letrec (unquote-splicing args))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g255 (caaar args) (cadaar args) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g268 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (if (pair? (car args)) (if (and (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g255 (caaar args) (cadaar args) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g268 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (g264))) (g264)))) +(defmacro match-define args (let ((g279 (cadddr match:expanders)) (g278 (lambda () (match:syntax-err (quasiquote (match-define (unquote-splicing args))) "syntax error in")))) (if (pair? args) (if (g279 (car args)) (if (and (pair? (cdr args)) (null? (cddr args))) ((lambda () (quasiquote (begin (define (unquote-splicing args)))))) (g278)) (if (and (pair? (cdr args)) (null? (cddr args))) ((lambda (pat exp) ((caddr match:expanders) pat exp (quasiquote (match-define (unquote-splicing args))))) (car args) (cadr args)) (g278))) (g278)))) (define match:runtime-structures #f) (define match:set-runtime-structures (lambda (v) (set! match:runtime-structures v))) (define match:primitive-vector? vector?) -(defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda () #t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda (x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x))))) (mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x)) (match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let ((g296 (lambda () (match:syntax-err (quasiquote (defstruct (unquote-splicing args))) syntax error in)))) (if (and (pair? args) (symbol? (car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args)) (symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args)) (g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate fields) (let* ((selectors (map selector-name fields)) (mutators (map mutator-name fields)) (tag (if match:runtime-structures (gentemp) (quasiquote (quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq? match:structure-control (quote disjoint)) (quote match:primitive-vector?)) ((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq? match:structure-control (quote disjoint)) (if (eq? vector? match:primitive-vector?) (set! vector? (lambda (v) (and (match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol? (vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not (memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates (cons predicate match:disjoint-predicates)))) ((eq? match:structure-control (quote vector)) (if (not (memq predicate match:vector-structures)) (set! match:vector-structures (cons predicate match:vector-structures)))) (else (match:syntax-err (quote (vector disjoint)) invalid value for match:structure-control, legal values are))) (quasiquote (begin (unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define (unquote constructor) (lambda (unquote selectors) (vector (unquote tag) (unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and ((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing (filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda (obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing (filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n) (lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators)))))) (car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299)) (g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296))))) -(defmacro define-structure args (let ((g311 (lambda () (match:syntax-err (quasiquote (define-structure (unquote-splicing args))) syntax error in)))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g308 ((g309 (cadr args)) (g307 (quote ())) (g306 (quote ()))) (if (null? g309) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let ((mk-id (lambda (id) (if (and (pair? id) (equal? (car id) (quote @)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda (x) x) (cadr id)) ((lambda () (quasiquote (! (unquote id))))))))) (quasiquote (define-const-structure ((unquote name) (unquote-splicing (map mk-id id1))) (unquote (map (lambda (id v) (quasiquote ((unquote (mk-id id)) (unquote v)))) id2 val)))))) (caar args) (cdar args) (reverse g306) (reverse g307)) (g311)) (if (and (pair? (car g309)) (pair? (cdar g309)) (null? (cddar g309))) (g308 (cdr g309) (cons (cadar g309) g307) (cons (caar g309) g306)) (g311)))) (g311))) (g311)))) -(defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol? id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda () #f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator? (lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote (define-const-structure (unquote-splicing args))) syntax error in)))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if (and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args)) (g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor (symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin (defstruct (unquote name) (unquote raw-constructor) (unquote predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if (has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i)) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))) (symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2) (quasiquote (define (unquote constructor) (unquote raw-constructor))) (let* ((make-fresh (lambda (x) (if (eq? (quote _) x) (gentemp) x))) (names1 (map make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1) (let* (unquote (map list names2 val)) ((unquote raw-constructor) (unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing (filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _)) #f (quasiquote (define (unquote (symbol-append name (quote -) (field-name field))) (unquote (symbol-append name (quote -) i)))))) id1id2)) (unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq? (field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote (define (unquote (symbol-append (quote set-) name (quote -) (field-name field) (quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331)) (g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333)) (null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons (car g329) g327)) (g335)))) (g335))) (g335))))) +(defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda () #t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda (x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x))))) (mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x)) (match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let ((g296 (lambda () (match:syntax-err (quasiquote (defstruct (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (symbol? (car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args)) (symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args)) (g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate fields) (let* ((selectors (map selector-name fields)) (mutators (map mutator-name fields)) (tag (if match:runtime-structures (gentemp) (quasiquote (quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq? match:structure-control (quote disjoint)) (quote match:primitive-vector?)) ((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq? match:structure-control (quote disjoint)) (if (eq? vector? match:primitive-vector?) (set! vector? (lambda (v) (and (match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol? (vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not (memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates (cons predicate match:disjoint-predicates)))) ((eq? match:structure-control (quote vector)) (if (not (memq predicate match:vector-structures)) (set! match:vector-structures (cons predicate match:vector-structures)))) (else (match:syntax-err (quote (vector disjoint)) "invalid value for match:structure-control, legal values are"))) (quasiquote (begin (unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define (unquote constructor) (lambda (unquote selectors) (vector (unquote tag) (unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and ((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing (filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda (obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing (filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n) (lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators)))))) (car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299)) (g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296))))) +(defmacro define-structure args (let ((g311 (lambda () (match:syntax-err (quasiquote (define-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g308 ((g309 (cadr args)) (g307 (quote ())) (g306 (quote ()))) (if (null? g309) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let ((mk-id (lambda (id) (if (and (pair? id) (equal? (car id) (quote @)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda (x) x) (cadr id)) ((lambda () (quasiquote (! (unquote id))))))))) (quasiquote (define-const-structure ((unquote name) (unquote-splicing (map mk-id id1))) (unquote (map (lambda (id v) (quasiquote ((unquote (mk-id id)) (unquote v)))) id2 val)))))) (caar args) (cdar args) (reverse g306) (reverse g307)) (g311)) (if (and (pair? (car g309)) (pair? (cdar g309)) (null? (cddar g309))) (g308 (cdr g309) (cons (cadar g309) g307) (cons (caar g309) g306)) (g311)))) (g311))) (g311)))) +(defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol? id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda () #f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator? (lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote (define-const-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if (and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args)) (g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor (symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin (defstruct (unquote name) (unquote raw-constructor) (unquote predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if (has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i)) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))) (symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2) (quasiquote (define (unquote constructor) (unquote raw-constructor))) (let* ((make-fresh (lambda (x) (if (eq? (quote _) x) (gentemp) x))) (names1 (map make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1) (let* (unquote (map list names2 val)) ((unquote raw-constructor) (unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing (filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _)) #f (quasiquote (define (unquote (symbol-append name (quote -) (field-name field))) (unquote (symbol-append name (quote -) i)))))) id1id2)) (unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq? (field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote (define (unquote (symbol-append (quote set-) name (quote -) (field-name field) (quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331)) (g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333)) (null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons (car g329) g327)) (g335)))) (g335))) (g335))))) From 6fe692e91158ebb68fabcb524c106adf1bc4f957 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Mon, 26 Feb 2001 03:06:57 +0000 Subject: [PATCH 0610/2047] ports.c, ports.h (scm_c_read, scm_c_write): New functions. ports.h (SCM_READ_BUFFER_EMPTY_P): New macro. --- NEWS | 19 +++++++++- libguile/ChangeLog | 6 ++++ libguile/ports.c | 89 ++++++++++++++++++++++++++++++++++++++++++++-- libguile/ports.h | 5 ++- 4 files changed, 114 insertions(+), 5 deletions(-) diff --git a/NEWS b/NEWS index 024bed287..6666ae5fd 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,5 @@ Guile NEWS --- history of user-visible changes. -*- text -*- -Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc. +Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 Free Software Foundation, Inc. See the end for copying conditions. Please send Guile bug reports to bug-guile@gnu.org. @@ -372,6 +372,23 @@ There is no such concept as a weak binding any more. * Changes to the scm_ interface +** New function: scm_c_read (SCM port, void *buffer, scm_sizet size) + +Used by an application to read arbitrary number of bytes from a port. +Same semantics as libc read, except that scm_c_read only returns less +than SIZE bytes if at end-of-file. + +Warning: Doesn't update port line and column counts! + +** New function: scm_c_write (SCM port, const void *ptr, scm_sizet size) + +Used by an application to write arbitrary number of bytes to an SCM +port. Similar semantics as libc write. However, unlike libc +write, scm_c_write writes the requested number of bytes and has no +return value. + +Warning: Doesn't update port line and column counts! + ** New function: scm_init_guile () In contrast to scm_boot_guile, scm_init_guile will return normally diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 271c98a48..71163e693 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2001-02-23 Mikael Djurfeldt + + * ports.c, ports.h (scm_c_read, scm_c_write): New functions. + + * ports.h (SCM_READ_BUFFER_EMPTY_P): New macro. + 2001-02-24 Neil Jerram * numbers.c (scm_two_doubles, scm_sys_expt, scm_sys_atan2, diff --git a/libguile/ports.c b/libguile/ports.c index 85015d100..fd7362031 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999, 2000, 2001 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 @@ -963,6 +963,14 @@ scm_puts (const char *s, SCM port) scm_lfwrite (s, strlen (s), port); } +/* scm_lfwrite + * + * Currently, this function has an identical implementation to + * scm_c_write. We could have turned it into a macro expanding into a + * call to scm_c_write. However, the implementation is small and + * might differ in the future. + */ + void scm_lfwrite (const char *ptr, scm_sizet size, SCM port) { @@ -978,6 +986,81 @@ scm_lfwrite (const char *ptr, scm_sizet size, SCM port) pt->rw_active = SCM_PORT_WRITE; } +/* scm_c_read + * + * Used by an application to read arbitrary number of bytes from an + * SCM port. Same semantics as libc read, except that scm_c_read only + * returns less than SIZE bytes if at end-of-file. + * + * Warning: Doesn't update port line and column counts! */ + +scm_sizet +scm_c_read (SCM port, void *buffer, scm_sizet size) +{ + scm_port *pt = SCM_PTAB_ENTRY (port); + scm_sizet n_read = 0, n_available; + + if (pt->rw_active == SCM_PORT_WRITE) + scm_ptobs[SCM_PTOBNUM (port)].flush (port); + + if (pt->rw_random) + pt->rw_active = SCM_PORT_READ; + + if (SCM_READ_BUFFER_EMPTY_P (pt)) + { + if (scm_fill_input (port) == EOF) + return 0; + } + + n_available = pt->read_end - pt->read_pos; + + while (n_available < size) + { + memcpy (buffer, pt->read_pos, n_available); + buffer += n_available; + pt->read_pos += n_available; + n_read += n_available; + + if (SCM_READ_BUFFER_EMPTY_P (pt)) + { + if (scm_fill_input (port) == EOF) + return n_read; + } + + size -= n_available; + n_available = pt->read_end - pt->read_pos; + } + + memcpy (buffer, pt->read_pos, size); + pt->read_pos += size; + + return n_read + size; +} + +/* scm_c_write + * + * Used by an application to write arbitrary number of bytes to an SCM + * port. Similar semantics as libc write. However, unlike libc + * write, scm_c_write writes the requested number of bytes and has no + * return value. + * + * Warning: Doesn't update port line and column counts! + */ + +void +scm_c_write (SCM port, const void *ptr, scm_sizet size) +{ + scm_port *pt = SCM_PTAB_ENTRY (port); + scm_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; + + if (pt->rw_active == SCM_PORT_READ) + scm_end_input (port); + + ptob->write (port, ptr, size); + + if (pt->rw_random) + pt->rw_active = SCM_PORT_WRITE; +} void scm_flush (SCM port) @@ -1199,8 +1282,8 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, object = SCM_COERCE_OUTPORT (object); - off = SCM_NUM2LONG (2,offset); - SCM_VALIDATE_INUM_COPY (3,whence,how); + off = SCM_NUM2LONG (2, offset); + SCM_VALIDATE_INUM_COPY (3, whence, how); if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END) SCM_OUT_OF_RANGE (3, whence); if (SCM_OPPORTP (object)) diff --git a/libguile/ports.h b/libguile/ports.h index fe2c0dc92..fabf744eb 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -2,7 +2,7 @@ #ifndef PORTSH #define PORTSH -/* Copyright (C) 1995,1996,1997,1998,1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999, 2000, 2001 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 @@ -135,6 +135,7 @@ typedef struct extern scm_port **scm_port_table; extern int scm_port_table_size; /* Number of ports in scm_port_table. */ +#define SCM_READ_BUFFER_EMPTY_P(c_port) (c_port->read_pos >= c_port->read_end) @@ -279,6 +280,8 @@ extern SCM scm_flush_all_ports (void); extern SCM scm_read_char (SCM port); extern void scm_putc (char c, SCM port); extern void scm_puts (const char *str_data, SCM port); +extern scm_sizet scm_c_read (SCM port, void *buffer, scm_sizet size); +extern void scm_c_write (SCM port, const void *buffer, scm_sizet size); extern void scm_lfwrite (const char *ptr, scm_sizet size, SCM port); extern void scm_flush (SCM port); extern void scm_end_input (SCM port); From 704f4e86cf372f1bcef391579d899998fadcc62c Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Tue, 27 Feb 2001 03:19:36 +0000 Subject: [PATCH 0611/2047] * boot-9.scm (save-stack): Use `primitive-eval' for stack cutting. Makes backtraces work again! Also added a reference to save-stack from the place in the repl where the primitive-eval frame is invoked. --- ice-9/ChangeLog | 7 +++++++ ice-9/boot-9.scm | 9 +++++++-- 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 640d45dfb..d7cb403ed 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,10 @@ +2001-02-26 Mikael Djurfeldt + + * boot-9.scm (save-stack): Use `primitive-eval' for stack + cutting. Makes backtraces work again! Also added a reference to + save-stack from the place in the repl where the primitive-eval + frame is invoked. + 2001-02-25 Keisuke Nishida * match.scm: New file, including Andrew K. Wright's pattern matcher. diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 718cfeac8..efd330815 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1,6 +1,6 @@ ;;; installed-scm-file -;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc. +;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001 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 @@ -2259,7 +2259,7 @@ the-last-stack (case (stack-id #t) ((repl-stack) - (apply make-stack #t save-stack eval #t 0 narrowing)) + (apply make-stack #t save-stack primitive-eval #t 0 narrowing)) ((load-stack) (apply make-stack #t save-stack 0 #t 0 narrowing)) ((tk-stack) @@ -2403,6 +2403,11 @@ (-eval (lambda (sourc) (repl-report-start-timing) (start-stack 'repl-stack + ;; If you change this procedure + ;; (primitive-eval), please also + ;; modify the repl-stack case in + ;; save-stack so that stack cutting + ;; continues to work. (primitive-eval sourc)))) (-print (let ((maybe-print (lambda (result) From ac6849ffee32ed6e568971bcb2e72a374efd8cc1 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 27 Feb 2001 11:10:07 +0000 Subject: [PATCH 0612/2047] * Cleaned up export list. --- test-suite/ChangeLog | 4 ++++ test-suite/lib.scm | 3 --- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index e797d4ce0..e37c2f5b8 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2001-02-27 Dirk Herrmann + + * lib.scm (data-file): Remove from export list. + 2001-02-22 Thien-Thi Nguyen * tests/exceptions.test (syntax lambda): Renamed from (lambda). diff --git a/test-suite/lib.scm b/test-suite/lib.scm index 87efcc034..e0669eb63 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -34,9 +34,6 @@ user-reporter format-test-name - ;; Finding test input files. - data-file - ;; Noticing whether an error occurs. signals-error? signals-error?*) From 5c96bc39a441306d1dc7bf8c069da2175afd6752 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 28 Feb 2001 08:41:06 +0000 Subject: [PATCH 0613/2047] * Make sure that tests return a boolean value. --- test-suite/ChangeLog | 14 ++++++++++++++ test-suite/lib.scm | 2 +- test-suite/tests/bit-operations.test | 2 +- test-suite/tests/common-list.test | 2 +- test-suite/tests/environments.test | 2 +- test-suite/tests/eval.test | 2 +- test-suite/tests/gc.test | 2 +- test-suite/tests/guardians.test | 2 +- test-suite/tests/hooks.test | 8 +++++--- test-suite/tests/interp.test | 4 ++-- test-suite/tests/list.test | 23 +++++++++++------------ test-suite/tests/numbers.test | 2 +- test-suite/tests/weaks.test | 12 ++++++++---- 13 files changed, 48 insertions(+), 29 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index e37c2f5b8..55dc1dd64 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,17 @@ +2001-02-27 Dirk Herrmann + + * lib.scm (pass-if): Tests shall return a boolean value. + + * tests/bit-operations.test (documented?), tests/common-list.test + (documented?), tests/environments.test (documented?), + tests/eval.test (documented?), tests/gc.test (documented?), + tests/numbers.test (documented?), tests/guardians.test, + tests/hooks.test, tests/interp.test, tests/weaks.test: Make sure + that tests return a boolean value. + + * tests/list.test (documented?): New function, replace all checks + for documentation with calls to this function. + 2001-02-27 Dirk Herrmann * lib.scm (data-file): Remove from export list. diff --git a/test-suite/lib.scm b/test-suite/lib.scm index e0669eb63..471ce5ace 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -241,7 +241,7 @@ ;;; A short form for tests that are expected to pass, taken from Greg. (defmacro pass-if (name body . rest) - `(run-test ,name #t (lambda () (not (not (begin ,body ,@rest)))))) + `(run-test ,name #t (lambda () ,body ,@rest))) ;;; A short form for tests that are expected to fail, taken from Greg. (defmacro expect-fail (name body . rest) diff --git a/test-suite/tests/bit-operations.test b/test-suite/tests/bit-operations.test index 469d63073..46c9fe1b8 100644 --- a/test-suite/tests/bit-operations.test +++ b/test-suite/tests/bit-operations.test @@ -55,7 +55,7 @@ arg-sets)) (define (documented? object) - (object-documentation object)) + (not (not (object-documentation object)))) (define fixnum-bit 30) (define fixnum-min most-negative-fixnum) diff --git a/test-suite/tests/common-list.test b/test-suite/tests/common-list.test index 349ba9e4f..6e404f7a8 100644 --- a/test-suite/tests/common-list.test +++ b/test-suite/tests/common-list.test @@ -50,7 +50,7 @@ (define (documented? object) - (object-documentation object)) + (not (not (object-documentation object)))) ;;; diff --git a/test-suite/tests/environments.test b/test-suite/tests/environments.test index 908ec5ab7..647b1594e 100644 --- a/test-suite/tests/environments.test +++ b/test-suite/tests/environments.test @@ -49,7 +49,7 @@ (define (documented? object) - (object-documentation object)) + (not (not (object-documentation object)))) (define (folder sym val res) (cons (cons sym val) res)) diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index ba6a4ef7e..552f3eb19 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -49,7 +49,7 @@ (define (documented? object) - (object-documentation object)) + (not (not (object-documentation object)))) ;;; diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test index c997320e3..7afeb4226 100644 --- a/test-suite/tests/gc.test +++ b/test-suite/tests/gc.test @@ -49,7 +49,7 @@ (define (documented? object) - (object-documentation object)) + (not (not (object-documentation object)))) ;;; diff --git a/test-suite/tests/guardians.test b/test-suite/tests/guardians.test index 4d8eac678..8d5a6eb2b 100644 --- a/test-suite/tests/guardians.test +++ b/test-suite/tests/guardians.test @@ -59,7 +59,7 @@ (else (set! seen-something-else #t))) (loop))))) (pass-if "g3-garbage saved" seen-g3-garbage) - (pass-if "g2-saved" seen-g2) + (pass-if "g2-saved" (procedure? seen-g2)) (pass-if "nothing else saved" (not seen-something-else)) (pass-if "g2-garbage saved" (and (procedure? seen-g2) (equal? (seen-g2) '(g2-garbage))))) diff --git a/test-suite/tests/hooks.test b/test-suite/tests/hooks.test index 21a357122..c4f3ec608 100644 --- a/test-suite/tests/hooks.test +++ b/test-suite/tests/hooks.test @@ -154,8 +154,9 @@ (let ((x (make-hook 1))) (add-hook! x proc1) (add-hook! x proc2) - (and (memq proc1 (hook->list x) ) - (memq proc2 (hook->list x))))) + (and (memq proc1 (hook->list x)) + (memq proc2 (hook->list x)) + #t))) (pass-if "reset-hook!" (let ((x (make-hook 1))) (add-hook! x proc1) @@ -165,7 +166,8 @@ (with-test-prefix "reset-hook!" (pass-if "empty hook" (let ((x (make-hook 1))) - (reset-hook! x))) + (reset-hook! x) + #t)) (pass-if "bad hook" (catch-error-returning-true #t diff --git a/test-suite/tests/interp.test b/test-suite/tests/interp.test index fb6e4d6f0..ac346b256 100644 --- a/test-suite/tests/interp.test +++ b/test-suite/tests/interp.test @@ -22,14 +22,14 @@ (or arg (and (procedure? foo) (foo 99)))))) (define bar (foo #f)) - (foo #f))) + (= (foo #f) 99))) (pass-if "Internal defines 2" (letrec ((foo 77) (bar #f) (retfoo (lambda () foo))) (define baz (retfoo)) - (retfoo))) + (= (retfoo) 77))) ;; Test that evaluation of closure bodies works as it should diff --git a/test-suite/tests/list.test b/test-suite/tests/list.test index 734c50629..22e898879 100644 --- a/test-suite/tests/list.test +++ b/test-suite/tests/list.test @@ -47,6 +47,9 @@ ;;; miscellaneous ;;; +(define (documented? object) + (not (not (object-documentation object)))) + ;; ;; This unique tag is reserved for the unroll and diff-unrolled functions. ;; @@ -161,9 +164,8 @@ (with-test-prefix "append!" - ;; Is documentation available? - - (pass-if "documented?" (object-documentation append!)) + (pass-if "documented?" + (documented? append!)) ;; Is the handling of empty lists as arguments correct? @@ -453,9 +455,8 @@ (with-test-prefix "list-ref" - ;; Is documentation available? - - (pass-if "documented?" (object-documentation list-ref)) + (pass-if "documented?" + (documented? list-ref)) (with-test-prefix "argument error" @@ -519,9 +520,8 @@ (with-test-prefix "list-set!" - ;; Is documentation available? - - (pass-if "documented?" (object-documentation list-set!)) + (pass-if "documented?" + (documented? list-set!)) (with-test-prefix "argument error" @@ -594,9 +594,8 @@ (with-test-prefix "list-cdr-set!" - ;; Is documentation available? - - (pass-if "documented?" (object-documentation list-cdr-set!)) + (pass-if "documented?" + (documented? list-cdr-set!)) (with-test-prefix "argument error" diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 6a53e5d1a..3fc369aef 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -48,7 +48,7 @@ ;;; (define (documented? object) - (object-documentation object)) + (not (not (object-documentation object)))) (define fixnum-bit 30) (define fixnum-min most-negative-fixnum) diff --git a/test-suite/tests/weaks.test b/test-suite/tests/weaks.test index c85bcf976..c7f0947cd 100644 --- a/test-suite/tests/weaks.test +++ b/test-suite/tests/weaks.test @@ -184,7 +184,8 @@ (gc) (and (hashq-ref x test-key) (hashq-ref y test-key) - (hashq-ref z test-key)))) + (hashq-ref z test-key) + #t))) (pass-if "weak-key dies" (begin (hashq-set! x "this" "is") @@ -199,7 +200,8 @@ (not (hashq-ref x "of")) (not (hashq-ref x "emergency")) (not (hashq-ref x "key"))) - (hashq-ref x test-key)))) + (hashq-ref x test-key) + #t))) (pass-if "weak-value dies" (begin @@ -214,7 +216,8 @@ (not (hashq-ref y "of")) (not (hashq-ref y "emergency")) (not (hashq-ref y "value"))) - (hashq-ref y test-key)))) + (hashq-ref y test-key) + #t))) (pass-if "doubly-weak dies" (begin (hashq-set! z "this" "is") @@ -228,4 +231,5 @@ (not (hashq-ref z "of")) (not (hashq-ref z "emergency")) (not (hashq-ref z "all"))) - (hashq-ref z test-key)))))) + (hashq-ref z test-key) + #t))))) From 9d372117f6d155446263376c027ef0c90f8547b3 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 28 Feb 2001 09:06:10 +0000 Subject: [PATCH 0614/2047] * Remove redundant test name prefix. --- test-suite/ChangeLog | 6 ++- test-suite/tests/alist.test | 80 ++++++++++++++++++------------------- 2 files changed, 45 insertions(+), 41 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 55dc1dd64..c37a3b690 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,4 +1,8 @@ -2001-02-27 Dirk Herrmann +2001-02-28 Dirk Herrmann + + * tests/alist.test: Remove redundant test name prefix. + +2001-02-28 Dirk Herrmann * lib.scm (pass-if): Tests shall return a boolean value. diff --git a/test-suite/tests/alist.test b/test-suite/tests/alist.test index 2c8f3df83..a984ba82a 100644 --- a/test-suite/tests/alist.test +++ b/test-suite/tests/alist.test @@ -73,102 +73,102 @@ (let ((a (acons 'a 'b (acons 'c 'd (acons 'e 'f ())))) (b (acons "this" "is" (acons "a" "test" ()))) (deformed '(a b c d e f g))) - (pass-if "alist: acons" + (pass-if "acons" (and (equal? a '((a . b) (c . d) (e . f))) (equal? b '(("this" . "is") ("a" . "test"))))) - (pass-if "alist: sloppy-assq" + (pass-if "sloppy-assq" (let ((x (sloppy-assq 'c a))) (and (pair? x) (eq? (car x) 'c) (eq? (cdr x) 'd)))) - (pass-if "alist: sloppy-assq not" + (pass-if "sloppy-assq not" (let ((x (sloppy-assq "this" b))) (not x))) - (pass-if "alist: sloppy-assv" + (pass-if "sloppy-assv" (let ((x (sloppy-assv 'c a))) (and (pair? x) (eq? (car x) 'c) (eq? (cdr x) 'd)))) - (pass-if "alist: sloppy-assv not" + (pass-if "sloppy-assv not" (let ((x (sloppy-assv "this" b))) (not x))) - (pass-if "alist: sloppy-assoc" + (pass-if "sloppy-assoc" (let ((x (sloppy-assoc "this" b))) (and (pair? x) (string=? (cdr x) "is")))) - (pass-if "alist: sloppy-assoc not" + (pass-if "sloppy-assoc not" (let ((x (sloppy-assoc "heehee" b))) (not x))) - (pass-if "alist: assq" + (pass-if "assq" (let ((x (assq 'c a))) (and (pair? x) (eq? (car x) 'c) (eq? (cdr x) 'd)))) - (pass-if "alist: assq deformed" + (pass-if "assq deformed" (catch 'wrong-type-arg (lambda () (assq 'x deformed)) (lambda (key . args) #t))) - (pass-if-not "alist: assq not" (assq 'r a)) - (pass-if "alist: assv" + (pass-if-not "assq not" (assq 'r a)) + (pass-if "assv" (let ((x (assv 'a a))) (and (pair? x) (eq? (car x) 'a) (eq? (cdr x) 'b)))) - (pass-if "alist: assv deformed" + (pass-if "assv deformed" (catch 'wrong-type-arg (lambda () (assv 'x deformed) #f) (lambda (key . args) #t))) - (pass-if-not "alist: assv not" (assq "this" b)) + (pass-if-not "assv not" (assq "this" b)) - (pass-if "alist: assoc" + (pass-if "assoc" (let ((x (assoc "this" b))) (and (pair? x) (string=? (car x) "this") (string=? (cdr x) "is")))) - (pass-if "alist: assoc deformed" + (pass-if "assoc deformed" (catch 'wrong-type-arg (lambda () (assoc 'x deformed) #f) (lambda (key . args) #t))) - (pass-if-not "alist: assoc not" (assoc "this isn't" b))) + (pass-if-not "assoc not" (assoc "this isn't" b))) ;;; Refers (let ((a '((foo bar) (baz quux))) (b '(("one" 2 3) ("four" 5 6) ("seven" 8 9))) (deformed '(thats a real sloppy assq you got there))) - (pass-if "alist: assq-ref" + (pass-if "assq-ref" (let ((x (assq-ref a 'foo))) (and (list? x) (eq? (car x) 'bar)))) - (pass-if-not "alist: assq-ref not" (assq-ref b "one")) - (pass-if "alist: assv-ref" + (pass-if-not "assq-ref not" (assq-ref b "one")) + (pass-if "assv-ref" (let ((x (assv-ref a 'baz))) (and (list? x) (eq? (car x) 'quux)))) - (pass-if-not "alist: assv-ref not" (assv-ref b "one")) + (pass-if-not "assv-ref not" (assv-ref b "one")) - (pass-if "alist: assoc-ref" + (pass-if "assoc-ref" (let ((x (assoc-ref b "one"))) (and (list? x) (eq? (car x) 2) (eq? (cadr x) 3)))) - (pass-if-not "alist: assoc-ref not" (assoc-ref a 'testing)) + (pass-if-not "assoc-ref not" (assoc-ref a 'testing)) (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref))) - (pass-if "alist: assv-ref deformed" + (pass-if "assv-ref deformed" (catch 'wrong-type-arg (lambda () (if (not have-sloppy-assv-ref?) (throw 'unsupported)) @@ -177,7 +177,7 @@ (lambda (key . args) #t))) - (pass-if "alist: assoc-ref deformed" + (pass-if "assoc-ref deformed" (catch 'wrong-type-arg (lambda () (if (not have-sloppy-assv-ref?) (throw 'unsupported)) @@ -186,7 +186,7 @@ (lambda (key . args) #t))) - (pass-if "alist: assq-ref deformed" + (pass-if "assq-ref deformed" (catch 'wrong-type-arg (lambda () (if (not have-sloppy-assv-ref?) (throw 'unsupported)) @@ -200,39 +200,39 @@ (let ((a '((another . silly) (alist . test-case))) (b '(("this" "one" "has") ("strings" "!"))) (deformed '(canada is a cold nation))) - (pass-if "alist: assq-set!" + (pass-if "assq-set!" (begin (set! a (assq-set! a 'another 'stupid)) (let ((x (safe-assq-ref a 'another))) (and x (symbol? x) (eq? x 'stupid))))) - (pass-if "alist: assq-set! add" + (pass-if "assq-set! add" (begin (set! a (assq-set! a 'fickle 'pickle)) (let ((x (safe-assq-ref a 'fickle))) (and x (symbol? x) (eq? x 'pickle))))) - (pass-if "alist: assv-set!" + (pass-if "assv-set!" (begin (set! a (assv-set! a 'another 'boring)) (let ((x (safe-assv-ref a 'another))) (and x (eq? x 'boring))))) - (pass-if "alist: assv-set! add" + (pass-if "assv-set! add" (begin (set! a (assv-set! a 'whistle '(while you work))) (let ((x (safe-assv-ref a 'whistle))) (and x (equal? x '(while you work)))))) - (pass-if "alist: assoc-set!" + (pass-if "assoc-set!" (begin (set! b (assoc-set! b "this" "has")) (let ((x (safe-assoc-ref b "this"))) (and x (string? x) (string=? x "has"))))) - (pass-if "alist: assoc-set! add" + (pass-if "assoc-set! add" (begin (set! b (assoc-set! b "flugle" "horn")) (let ((x (safe-assoc-ref b "flugle"))) @@ -241,7 +241,7 @@ (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref))) - (pass-if "alist: assq-set! deformed" + (pass-if "assq-set! deformed" (catch 'wrong-type-arg (lambda () (if (not have-sloppy-assv-ref?) (throw 'unsupported)) @@ -250,7 +250,7 @@ (lambda (key . args) #t))) - (pass-if "alist: assv-set! deformed" + (pass-if "assv-set! deformed" (catch 'wrong-type-arg (lambda () (if (not have-sloppy-assv-ref?) (throw 'unsupported)) @@ -259,7 +259,7 @@ (lambda (key . args) #t))) - (pass-if "alist: assoc-set! deformed" + (pass-if "assoc-set! deformed" (catch 'wrong-type-arg (lambda () (if (not have-sloppy-assv-ref?) (throw 'unsupported)) @@ -273,22 +273,22 @@ (let ((a '((a b) (c d) (e boring))) (b '(("what" . "else") ("could" . "I") ("say" . "here"))) (deformed 1)) - (pass-if "alist: assq-remove!" + (pass-if "assq-remove!" (begin (set! a (assq-remove! a 'a)) (equal? a '((c d) (e boring))))) - (pass-if "alist: assv-remove!" + (pass-if "assv-remove!" (begin (set! a (assv-remove! a 'c)) (equal? a '((e boring))))) - (pass-if "alist: assoc-remove!" + (pass-if "assoc-remove!" (begin (set! b (assoc-remove! b "what")) (equal? b '(("could" . "I") ("say" . "here"))))) (let* ((have-sloppy-assq-remove? (defined? 'sloppy-assq-remove))) - (pass-if "alist: assq-remove! deformed" + (pass-if "assq-remove! deformed" (catch 'wrong-type-arg (lambda () (if (not have-sloppy-assq-remove?) (throw 'unsupported)) @@ -297,7 +297,7 @@ (lambda (key . args) #t))) - (pass-if "alist: assv-remove! deformed" + (pass-if "assv-remove! deformed" (catch 'wrong-type-arg (lambda () (if (not have-sloppy-assq-remove?) (throw 'unsupported)) @@ -306,7 +306,7 @@ (lambda (key . args) #t))) - (pass-if "alist: assoc-remove! deformed" + (pass-if "assoc-remove! deformed" (catch 'wrong-type-arg (lambda () (if (not have-sloppy-assq-remove?) (throw 'unsupported)) From 6b4113afc5a0010eef2e9edae2cbd5f6b690be41 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 28 Feb 2001 11:25:40 +0000 Subject: [PATCH 0615/2047] * Provide and use new convenience macros to test for exceptions. --- test-suite/lib.scm | 58 +++++++++- test-suite/tests/alist.test | 137 ++++++++-------------- test-suite/tests/environments.test | 82 +++++-------- test-suite/tests/eval.test | 66 ++++------- test-suite/tests/hooks.test | 111 +++++++----------- test-suite/tests/list.test | 180 +++++++++-------------------- test-suite/tests/ports.test | 5 +- test-suite/tests/reader.test | 37 +++--- test-suite/tests/strings.test | 17 +-- test-suite/tests/weaks.test | 71 ++++-------- 10 files changed, 292 insertions(+), 472 deletions(-) diff --git a/test-suite/lib.scm b/test-suite/lib.scm index 471ce5ace..867b8eb7a 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -16,12 +16,18 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA -(define-module (test-suite lib)) +(define-module (test-suite lib) + :use-module (ice-9 regex)) (export + ;; Exceptions which are commonly being tested for. + exception:out-of-range exception:wrong-type-arg + ;; Reporting passes and failures. - run-test pass-if expect-fail + run-test + pass-if expect-fail + pass-if-exception expect-fail-exception ;; Naming groups of tests in a regular fashion. with-test-prefix with-test-prefix* current-test-prefix @@ -67,7 +73,9 @@ ;;;; environment. All other exceptions thrown by THUNK are considered as ;;;; errors. ;;;; -;;;; For convenience, the following macros are provided: +;;;; +;;;; Convenience macros for tests expected to pass or fail +;;;; ;;;; * (pass-if name body) is a short form for ;;;; (run-test name #t (lambda () body)) ;;;; * (expect-fail name body) is a short form for @@ -76,7 +84,24 @@ ;;;; For example: ;;;; ;;;; (pass-if "integer addition" (= 2 (+ 1 1))) - +;;;; +;;;; +;;;; Convenience macros to test for exceptions +;;;; +;;;; The following macros take exception parameters which are pairs +;;;; (type . message), where type is a symbol that denotes an exception type +;;;; like 'wrong-type-arg or 'out-of-range, and message is a string holding a +;;;; regular expression that describes the error message for the exception +;;;; like "Argument .* out of range". +;;;; +;;;; * (pass-if-exception name exception body) will pass if the execution of +;;;; body causes the given exception to be thrown. If no exception is +;;;; thrown, the test fails. If some other exception is thrown, is is an +;;;; error. +;;;; * (expect-fail-exception name exception body) will pass unexpectedly if +;;;; the execution of body causes the given exception to be thrown. If no +;;;; exception is thrown, the test fails expectedly. If some other +;;;; exception is thrown, it is an error. ;;;; TEST NAMES @@ -194,6 +219,12 @@ ;;;; MISCELLANEOUS ;;;; +;;; Define some exceptions which are commonly being tested for. +(define exception:out-of-range + (cons 'out-of-range "^Argument .*out of range")) +(define exception:wrong-type-arg + (cons 'wrong-type-arg "^Wrong type argument")) + ;;; Display all parameters to the default output port, followed by a newline. (define (display-line . objs) (for-each display objs) @@ -247,6 +278,25 @@ (defmacro expect-fail (name body . rest) `(run-test ,name #f (lambda () ,body ,@rest))) +;;; A helper function to implement the macros that test for exceptions. +(define (run-test-exception name exception expect-pass thunk) + (run-test name expect-pass + (lambda () + (catch (car exception) + (lambda () (thunk) #f) + (lambda (key proc message . rest) + (if (not (string-match (cdr exception) message)) + (apply throw key proc message rest) + #t)))))) + +;;; A short form for tests that expect a certain exception to be thrown. +(defmacro pass-if-exception (name exception body . rest) + `(,run-test-exception ,name ,exception #t (lambda () ,body ,@rest))) + +;;; A short form for tests expected to fail to throw a certain exception. +(defmacro expect-fail-exception (name exception body . rest) + `(,run-test-exception ,name ,exception #f (lambda () ,body ,@rest))) + ;;;; TEST NAMES ;;;; diff --git a/test-suite/tests/alist.test b/test-suite/tests/alist.test index a984ba82a..796d3b193 100644 --- a/test-suite/tests/alist.test +++ b/test-suite/tests/alist.test @@ -104,25 +104,18 @@ (and (pair? x) (eq? (car x) 'c) (eq? (cdr x) 'd)))) - (pass-if "assq deformed" - (catch 'wrong-type-arg - (lambda () - (assq 'x deformed)) - (lambda (key . args) - #t))) + (pass-if-exception "assq deformed" + exception:wrong-type-arg + (assq 'x deformed)) (pass-if-not "assq not" (assq 'r a)) (pass-if "assv" (let ((x (assv 'a a))) (and (pair? x) (eq? (car x) 'a) (eq? (cdr x) 'b)))) - (pass-if "assv deformed" - (catch 'wrong-type-arg - (lambda () - (assv 'x deformed) - #f) - (lambda (key . args) - #t))) + (pass-if-exception "assv deformed" + exception:wrong-type-arg + (assv 'x deformed)) (pass-if-not "assv not" (assq "this" b)) (pass-if "assoc" @@ -130,13 +123,9 @@ (and (pair? x) (string=? (car x) "this") (string=? (cdr x) "is")))) - (pass-if "assoc deformed" - (catch 'wrong-type-arg - (lambda () - (assoc 'x deformed) - #f) - (lambda (key . args) - #t))) + (pass-if-exception "assoc deformed" + exception:wrong-type-arg + (assoc 'x deformed)) (pass-if-not "assoc not" (assoc "this isn't" b))) @@ -168,32 +157,20 @@ (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref))) - (pass-if "assv-ref deformed" - (catch 'wrong-type-arg - (lambda () - (if (not have-sloppy-assv-ref?) (throw 'unsupported)) - (assv-ref deformed 'sloppy) - #f) - (lambda (key . args) - #t))) + (pass-if-exception "assv-ref deformed" + exception:wrong-type-arg + (if (not have-sloppy-assv-ref?) (throw 'unsupported)) + (assv-ref deformed 'sloppy)) - (pass-if "assoc-ref deformed" - (catch 'wrong-type-arg - (lambda () - (if (not have-sloppy-assv-ref?) (throw 'unsupported)) - (assoc-ref deformed 'sloppy) - #f) - (lambda (key . args) - #t))) + (pass-if-exception "assoc-ref deformed" + exception:wrong-type-arg + (if (not have-sloppy-assv-ref?) (throw 'unsupported)) + (assoc-ref deformed 'sloppy)) - (pass-if "assq-ref deformed" - (catch 'wrong-type-arg - (lambda () - (if (not have-sloppy-assv-ref?) (throw 'unsupported)) - (assq-ref deformed 'sloppy) - #f) - (lambda (key . args) - #t))))) + (pass-if-exception "assq-ref deformed" + exception:wrong-type-arg + (if (not have-sloppy-assv-ref?) (throw 'unsupported)) + (assq-ref deformed 'sloppy)))) ;;; Setters @@ -241,32 +218,20 @@ (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref))) - (pass-if "assq-set! deformed" - (catch 'wrong-type-arg - (lambda () - (if (not have-sloppy-assv-ref?) (throw 'unsupported)) - (assq-set! deformed 'cold '(very cold)) - #f) - (lambda (key . args) - #t))) + (pass-if-exception "assq-set! deformed" + exception:wrong-type-arg + (if (not have-sloppy-assv-ref?) (throw 'unsupported)) + (assq-set! deformed 'cold '(very cold))) - (pass-if "assv-set! deformed" - (catch 'wrong-type-arg - (lambda () - (if (not have-sloppy-assv-ref?) (throw 'unsupported)) - (assv-set! deformed 'canada 'Canada) - #f) - (lambda (key . args) - #t))) + (pass-if-exception "assv-set! deformed" + exception:wrong-type-arg + (if (not have-sloppy-assv-ref?) (throw 'unsupported)) + (assv-set! deformed 'canada 'Canada)) - (pass-if "assoc-set! deformed" - (catch 'wrong-type-arg - (lambda () - (if (not have-sloppy-assv-ref?) (throw 'unsupported)) - (assoc-set! deformed 'canada '(Iceland hence the name)) - #f) - (lambda (key . args) - #t))))) + (pass-if-exception "assoc-set! deformed" + exception:wrong-type-arg + (if (not have-sloppy-assv-ref?) (throw 'unsupported)) + (assoc-set! deformed 'canada '(Iceland hence the name))))) ;;; Removers @@ -288,29 +253,17 @@ (let* ((have-sloppy-assq-remove? (defined? 'sloppy-assq-remove))) - (pass-if "assq-remove! deformed" - (catch 'wrong-type-arg - (lambda () - (if (not have-sloppy-assq-remove?) (throw 'unsupported)) - (assq-remove! deformed 'puddle) - #f) - (lambda (key . args) - #t))) + (pass-if-exception "assq-remove! deformed" + exception:wrong-type-arg + (if (not have-sloppy-assq-remove?) (throw 'unsupported)) + (assq-remove! deformed 'puddle)) - (pass-if "assv-remove! deformed" - (catch 'wrong-type-arg - (lambda () - (if (not have-sloppy-assq-remove?) (throw 'unsupported)) - (assv-remove! deformed 'splashing) - #f) - (lambda (key . args) - #t))) + (pass-if-exception "assv-remove! deformed" + exception:wrong-type-arg + (if (not have-sloppy-assq-remove?) (throw 'unsupported)) + (assv-remove! deformed 'splashing)) - (pass-if "assoc-remove! deformed" - (catch 'wrong-type-arg - (lambda () - (if (not have-sloppy-assq-remove?) (throw 'unsupported)) - (assoc-remove! deformed 'fun) - #f) - (lambda (key . args) - #t))))) + (pass-if-exception "assoc-remove! deformed" + exception:wrong-type-arg + (if (not have-sloppy-assq-remove?) (throw 'unsupported)) + (assoc-remove! deformed 'fun)))) diff --git a/test-suite/tests/environments.test b/test-suite/tests/environments.test index 647b1594e..895850d16 100644 --- a/test-suite/tests/environments.test +++ b/test-suite/tests/environments.test @@ -47,6 +47,8 @@ ;;; miscellaneous ;;; +(define exception:unbound-symbol + (cons 'misc-error "^Symbol .* not bound in environment")) (define (documented? object) (not (not (object-documentation object)))) @@ -173,37 +175,21 @@ (environment-define env 'a #f) (not (eq? (environment-cell env 'a #t) cell))))) - (pass-if "reference an undefined symbol" - (catch #t - (lambda () - (environment-ref (make-leaf-environment) 'a) - #f) - (lambda args - #t))) + (pass-if-exception "reference an unbound symbol" + exception:unbound-symbol + (environment-ref (make-leaf-environment) 'a)) - (pass-if "set! an undefined symbol" - (catch #t - (lambda () - (environment-set! (make-leaf-environment) 'a) - #f) - (lambda args - #t))) + (pass-if-exception "set! an unbound symbol" + exception:unbound-symbol + (environment-set! (make-leaf-environment) 'a #f)) - (pass-if "get a readable cell for an undefined symbol" - (catch #t - (lambda () - (environment-cell (make-leaf-environment) 'a #f) - #f) - (lambda args - #t))) + (pass-if-exception "get a readable cell for an unbound symbol" + exception:unbound-symbol + (environment-cell (make-leaf-environment) 'a #f)) - (pass-if "get a writable cell for an undefined symbol" - (catch #t - (lambda () - (environment-cell (make-leaf-environment) 'a #t) - #f) - (lambda args - #t)))) + (pass-if-exception "get a writable cell for an unbound symbol" + exception:unbound-symbol + (environment-cell (make-leaf-environment) 'a #t))) (with-test-prefix "undefine" @@ -621,37 +607,21 @@ (imported (make-leaf-environment)) (env (make-eval-environment local imported))) - (pass-if "reference an undefined symbol" - (catch #t - (lambda () - (environment-ref env 'b) - #f) - (lambda args - #t))) + (pass-if-exception "reference an unbound symbol" + exception:unbound-symbol + (environment-ref env 'b)) - (pass-if "set! an undefined symbol" - (catch #t - (lambda () - (environment-set! env 'b) - #f) - (lambda args - #t))) + (pass-if-exception "set! an unbound symbol" + exception:unbound-symbol + (environment-set! env 'b #f)) - (pass-if "get a readable cell for an undefined symbol" - (catch #t - (lambda () - (environment-cell env 'b #f) - #f) - (lambda args - #t))) + (pass-if-exception "get a readable cell for an unbound symbol" + exception:unbound-symbol + (environment-cell env 'b #f)) - (pass-if "get a writable cell for an undefined symbol" - (catch #t - (lambda () - (environment-cell env 'b #t) - #f) - (lambda args - #t))))) + (pass-if-exception "get a writable cell for an unbound symbol" + exception:unbound-symbol + (environment-cell env 'b #t)))) (with-test-prefix "eval-environment-set-local!" diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index 552f3eb19..c06542f06 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -47,7 +47,6 @@ ;;; miscellaneous ;;; - (define (documented? object) (not (not (object-documentation object)))) @@ -64,24 +63,17 @@ ;; Macros are accepted as function parameters. ;; Functions that 'apply' macros are rewritten!!! - (expect-fail "macro as argument" + (expect-fail-exception "macro as argument" + exception:wrong-type-arg (let ((f (lambda (p a b) (p a b)))) - (catch 'wrong-type-arg - (lambda () - (f and #t #t) - #f) - (lambda (key . args) - #t)))) + (f and #t #t))) - (expect-fail "application of macro" - (let ((f (lambda (p a b) (p a b)))) - (catch 'wrong-type-arg - (lambda () - (let ((foo (procedure-source f))) - (f and #t #t) - (equal? (procedure-source f) foo))) - (lambda (key . args) - #t)))) + (expect-fail-exception "passing macro as parameter" + exception:wrong-type-arg + (let* ((f (lambda (p a b) (p a b))) + (foo (procedure-source f))) + (f and #t #t) + (equal? (procedure-source f) foo))) )) @@ -103,35 +95,19 @@ (with-test-prefix "different length lists" - (pass-if "first list empty" - (catch 'out-of-range - (lambda () - (map + '() '(1)) - #f) - (lambda (key . args) - #t))) + (pass-if-exception "first list empty" + exception:out-of-range + (map + '() '(1))) - (pass-if "second list empty" - (catch 'out-of-range - (lambda () - (map + '(1) '()) - #f) - (lambda (key . args) - #t))) + (pass-if-exception "second list empty" + exception:out-of-range + (map + '(1) '())) - (pass-if "first list shorter" - (catch 'out-of-range - (lambda () - (map + '(1) '(2 3)) - #f) - (lambda (key . args) - #t))) + (pass-if-exception "first list shorter" + exception:out-of-range + (map + '(1) '(2 3))) - (pass-if "second list shorter" - (catch 'out-of-range - (lambda () - (map + '(1 2) '(3)) - #f) - (lambda (key . args) - #t))) + (pass-if-exception "second list shorter" + exception:out-of-range + (map + '(1 2) '(3))) ))) diff --git a/test-suite/tests/hooks.test b/test-suite/tests/hooks.test index c4f3ec608..1f309e5f2 100644 --- a/test-suite/tests/hooks.test +++ b/test-suite/tests/hooks.test @@ -40,51 +40,32 @@ ;;;; whether to permit this exception to apply to your modifications. ;;;; If you do not wish that, delete this exception notice. -;;; {Description} ;;; -;;; A test suite for hooks. I maybe should've split off some of the -;;; stuff (like with alists), but this is small enough that it -;;; probably isn't worth the hassle. A little note: in some places it -;;; catches all errors when it probably shouldn't, since there's only -;;; one error we consider correct. This is mostly because the -;;; add-hook! error in released guiles isn't really accurate -;;; This should be changed once a released version returns -;;; wrong-type-arg from add-hook! +;;; miscellaneous +;;; -;; {Utility stuff} -;; Evaluate form inside a catch; if it throws an error, return true -;; This is good for checking that errors are not ignored +;; FIXME: Maybe a standard wrong-num-arg exception should be thrown instead +;; of a misc-error? If so, the tests should be changed to expect failure. +(define exception:wrong-num-hook-args + (cons 'misc-error "Hook .* requires .* arguments")) -(define-macro (catch-error-returning-true error . form) - `(catch ,error (lambda () (begin ,@form #f)) (lambda (key . args) #t))) +;;; +;;; {The tests} +;;; -;; Evaluate form inside a catch; if it throws an error, return false -;; Good for making sure that errors don't occur - -(define-macro (catch-error-returning-false error . form) - `(catch ,error (lambda () (begin ,@form #t)) (lambda (key . args) #f))) - -;; pass-if-not: syntactic sugar - -(define-macro (pass-if-not string form) - `(pass-if ,string (not ,form))) - -;; {The tests} - (let ((proc1 (lambda (x) (+ x 1))) +(let ((proc1 (lambda (x) (+ x 1))) (proc2 (lambda (x) (- x 1))) (bad-proc (lambda (x y) #t))) (with-test-prefix "hooks" (pass-if "make-hook" - (catch-error-returning-false - #t - (define x (make-hook 1)))) + (make-hook 1) + #t) (pass-if "add-hook!" - (catch-error-returning-false - #t - (let ((x (make-hook 1))) - (add-hook! x proc1) - (add-hook! x proc2)))) + (let ((x (make-hook 1))) + (add-hook! x proc1) + (add-hook! x proc2) + #t)) (with-test-prefix "add-hook!" (pass-if "append" @@ -93,34 +74,30 @@ (add-hook! x proc2 #t) (eq? (cadr (hook->list x)) proc2))) - (pass-if "illegal proc" - (catch-error-returning-true - #t - (let ((x (make-hook 1))) - (add-hook! x bad-proc)))) - (pass-if "illegal hook" - (catch-error-returning-true - 'wrong-type-arg - (add-hook! '(foo) proc1)))) + (pass-if-exception "illegal proc" + exception:wrong-type-arg + (let ((x (make-hook 1))) + (add-hook! x bad-proc))) + (pass-if-exception "illegal hook" + exception:wrong-type-arg + (add-hook! '(foo) proc1))) (pass-if "run-hook" (let ((x (make-hook 1))) - (catch-error-returning-false #t - (add-hook! x proc1) - (add-hook! x proc2) - (run-hook x 1)))) + (add-hook! x proc1) + (add-hook! x proc2) + (run-hook x 1) + #t)) (with-test-prefix "run-hook" - (pass-if "bad hook" - (catch-error-returning-true - #t - (let ((x (cons 'a 'b))) - (run-hook x 1)))) - (pass-if "too many args" - (let ((x (make-hook 1))) - (catch-error-returning-true - #t - (add-hook! x proc1) - (add-hook! x proc2) - (run-hook x 1 2)))) + (pass-if-exception "bad hook" + exception:wrong-type-arg + (let ((x (cons 'a 'b))) + (run-hook x 1))) + (pass-if-exception "too many args" + exception:wrong-num-hook-args + (let ((x (make-hook 1))) + (add-hook! x proc1) + (add-hook! x proc2) + (run-hook x 1 2))) (pass-if "destructive procs" @@ -146,10 +123,9 @@ ; Maybe it should error, but this is probably ; more convienient (pass-if "empty hook" - (catch-error-returning-false - #t - (let ((x (make-hook 1))) - (remove-hook! x proc1))))) + (let ((x (make-hook 1))) + (remove-hook! x proc1) + #t))) (pass-if "hook->list" (let ((x (make-hook 1))) (add-hook! x proc1) @@ -168,7 +144,6 @@ (let ((x (make-hook 1))) (reset-hook! x) #t)) - (pass-if "bad hook" - (catch-error-returning-true - #t - (reset-hook! '(a b))))))) + (pass-if-exception "bad hook" + exception:wrong-type-arg + (reset-hook! '(a b)))))) diff --git a/test-suite/tests/list.test b/test-suite/tests/list.test index 22e898879..746eeb8ad 100644 --- a/test-suite/tests/list.test +++ b/test-suite/tests/list.test @@ -375,29 +375,17 @@ (with-test-prefix "wrong argument" - (expect-fail "improper list and empty list" - (catch 'wrong-type-arg - (lambda () - (append! (cons 1 2) '()) - #f) - (lambda (key . args) - #t))) + (expect-fail-exception "improper list and empty list" + exception:wrong-type-arg + (append! (cons 1 2) '())) - (expect-fail "improper list and list" - (catch 'wrong-type-arg - (lambda () - (append! (cons 1 2) (list 3 4)) - #f) - (lambda (key . args) - #t))) + (expect-fail-exception "improper list and list" + exception:wrong-type-arg + (append! (cons 1 2) (list 3 4))) - (expect-fail "list, improper list and list" - (catch 'wrong-type-arg - (lambda () - (append! (list 1 2) (cons 3 4) (list 5 6)) - #f) - (lambda (key . args) - #t))) + (expect-fail-exception "list, improper list and list" + exception:wrong-type-arg + (append! (list 1 2) (cons 3 4) (list 5 6))) (expect-fail "circular list and empty list" (let ((foo (list 1 2 3))) @@ -473,47 +461,27 @@ (with-test-prefix "empty list" - (pass-if "index 0" - (catch 'out-of-range - (lambda () - (list-ref '() 0) - #f) - (lambda (key . args) - #t))) + (pass-if-exception "index 0" + exception:out-of-range + (list-ref '() 0)) - (pass-if "index > 0" - (catch 'out-of-range - (lambda () - (list-ref '() 1) - #f) - (lambda (key . args) - #t))) + (pass-if-exception "index > 0" + exception:out-of-range + (list-ref '() 1)) - (pass-if "index < 0" - (catch 'out-of-range - (lambda () - (list-ref '() -1) - #f) - (lambda (key . args) - #t)))) + (pass-if-exception "index < 0" + exception:out-of-range + (list-ref '() -1))) (with-test-prefix "non-empty list" - (pass-if "index > length" - (catch 'out-of-range - (lambda () - (list-ref '(1) 1) - #f) - (lambda (key . args) - #t))) + (pass-if-exception "index > length" + exception:out-of-range + (list-ref '(1) 1)) - (pass-if "index < 0" - (catch 'out-of-range - (lambda () - (list-ref '(1) -1) - #f) - (lambda (key . args) - #t))))))) + (pass-if-exception "index < 0" + exception:out-of-range + (list-ref '(1) -1)))))) ;;; list-set! @@ -541,47 +509,27 @@ (with-test-prefix "empty list" - (pass-if "index 0" - (catch 'out-of-range - (lambda () - (list-set! (list) 0 #t) - #f) - (lambda (key . args) - #t))) + (pass-if-exception "index 0" + exception:out-of-range + (list-set! (list) 0 #t)) - (pass-if "index > 0" - (catch 'out-of-range - (lambda () - (list-set! (list) 1 #t) - #f) - (lambda (key . args) - #t))) + (pass-if-exception "index > 0" + exception:out-of-range + (list-set! (list) 1 #t)) - (pass-if "index < 0" - (catch 'out-of-range - (lambda () - (list-set! (list) -1 #t) - #f) - (lambda (key . args) - #t)))) + (pass-if-exception "index < 0" + exception:out-of-range + (list-set! (list) -1 #t))) (with-test-prefix "non-empty list" - (pass-if "index > length" - (catch 'out-of-range - (lambda () - (list-set! (list 1) 1 #t) - #f) - (lambda (key . args) - #t))) + (pass-if-exception "index > length" + exception:out-of-range + (list-set! (list 1) 1 #t)) - (pass-if "index < 0" - (catch 'out-of-range - (lambda () - (list-set! (list 1) -1 #t) - #f) - (lambda (key . args) - #t))))))) + (pass-if-exception "index < 0" + exception:out-of-range + (list-set! (list 1) -1 #t)))))) ;;; list-cdr-ref @@ -615,47 +563,27 @@ (with-test-prefix "empty list" - (pass-if "index 0" - (catch 'out-of-range - (lambda () - (list-cdr-set! (list) 0 #t) - #f) - (lambda (key . args) - #t))) + (pass-if-exception "index 0" + exception:out-of-range + (list-cdr-set! (list) 0 #t)) - (pass-if "index > 0" - (catch 'out-of-range - (lambda () - (list-cdr-set! (list) 1 #t) - #f) - (lambda (key . args) - #t))) + (pass-if-exception "index > 0" + exception:out-of-range + (list-cdr-set! (list) 1 #t)) - (pass-if "index < 0" - (catch 'out-of-range - (lambda () - (list-cdr-set! (list) -1 #t) - #f) - (lambda (key . args) - #t)))) + (pass-if-exception "index < 0" + exception:out-of-range + (list-cdr-set! (list) -1 #t))) (with-test-prefix "non-empty list" - (pass-if "index > length" - (catch 'out-of-range - (lambda () - (list-cdr-set! (list 1) 1 #t) - #f) - (lambda (key . args) - #t))) + (pass-if-exception "index > length" + exception:out-of-range + (list-cdr-set! (list 1) 1 #t)) - (pass-if "index < 0" - (catch 'out-of-range - (lambda () - (list-cdr-set! (list 1) -1 #t) - #f) - (lambda (key . args) - #t))))))) + (pass-if-exception "index < 0" + exception:out-of-range + (list-cdr-set! (list 1) -1 #t)))))) ;;; list-head diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index dbdca077c..5429b20f7 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -427,7 +427,8 @@ (call-with-input-string "foo" (lambda (p) p)) (lambda () (close-port (current-input-port)) - (pass-if name - (signals-error? 'wrong-type-arg (procedure)))))) + (pass-if-exception name + exception:wrong-type-arg + (procedure))))) (list read read-char read-line) '("read" "read-char" "read-line"))) diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test index 97c89c5a7..41e8566c5 100644 --- a/test-suite/tests/reader.test +++ b/test-suite/tests/reader.test @@ -1,25 +1,22 @@ ;;;; reader.test --- test the Guile parser -*- scheme -*- ;;;; Jim Blandy --- September 1999 -(define (try-to-read string) - (pass-if (call-with-output-string (lambda (port) - (display "Try to read " port) - (write string port))) - (not (signals-error? - 'signal - (call-with-input-string string - (lambda (p) (read p))))))) +(define (read-string s) + (with-input-from-string s (lambda () (read)))) -(try-to-read "0") -(try-to-read "1++i") -(try-to-read "1+i+i") -(try-to-read "1+e10000i") +(with-test-prefix "reading" + (pass-if "0" + (equal? (read-string "0") 0)) + (pass-if "1++i" + (equal? (read-string "1++i") '1++i)) + (pass-if "1+i+i" + (equal? (read-string "1+i+i") '1+i+i)) + (pass-if "1+e10000i" + (equal? (read-string "1+e10000i") '1+e10000i))) -(pass-if "radix passed to number->string can't be zero" - (signals-error? - 'out-of-range - (number->string 10 0))) -(pass-if "radix passed to number->string can't be one either" - (signals-error? - 'out-of-range - (number->string 10 1))) +(pass-if-exception "radix passed to number->string can't be zero" + exception:out-of-range + (number->string 10 0)) +(pass-if-exception "radix passed to number->string can't be one either" + exception:out-of-range + (number->string 10 1)) diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test index ffd3fab35..5645f1fbb 100644 --- a/test-suite/tests/strings.test +++ b/test-suite/tests/strings.test @@ -21,19 +21,14 @@ (use-modules (test-suite lib)) -(pass-if "string=? does not accept symbols" - (catch 'wrong-type-arg - (lambda () - (string=? 'a 'b) - #f) - (lambda args - #t))) +(pass-if-exception "string=? does not accept symbols" + exception:wrong-type-arg + (string=? 'a 'b)) (pass-if "stringweak-vector" (pass-if "create" @@ -97,42 +82,32 @@ (eq? (vector-ref wv 4) 'e) (eq? (vector-ref wv 5) 'f) (eq? (vector-ref wv 6) 'g)))) - (pass-if "bad-args" - (catch-error-returning-true - 'wrong-type-arg - (define x (list->weak-vector 32))))) + (pass-if-exception "bad-args" + exception:wrong-type-arg + (list->weak-vector 32))) (with-test-prefix "make-weak-key-hash-table" (pass-if "create" - (catch-error-returning-false - #t - (define x (make-weak-key-hash-table 17)))) - (pass-if "bad-args" - (catch-error-returning-true - 'wrong-type-arg - (define x - (make-weak-key-hash-table '(bad arg)))))) + (make-weak-key-hash-table 17) + #t) + (pass-if-exception "bad-args" + exception:wrong-type-arg + (make-weak-key-hash-table '(bad arg)))) (with-test-prefix "make-weak-value-hash-table" (pass-if "create" - (catch-error-returning-false - #t - (define x (make-weak-value-hash-table 17)))) - (pass-if "bad-args" - (catch-error-returning-true - 'wrong-type-arg - (define x - (make-weak-value-hash-table '(bad arg)))))) + (make-weak-value-hash-table 17) + #t) + (pass-if-exception "bad-args" + exception:wrong-type-arg + (make-weak-value-hash-table '(bad arg)))) (with-test-prefix "make-doubly-weak-hash-table" (pass-if "create" - (catch-error-returning-false - #t - (define x (make-doubly-weak-hash-table 17)))) - (pass-if "bad-args" - (catch-error-returning-true - 'wrong-type-arg - (define x - (make-doubly-weak-hash-table '(bad arg))))))) + (make-doubly-weak-hash-table 17) + #t) + (pass-if-exception "bad-args" + exception:wrong-type-arg + (make-doubly-weak-hash-table '(bad arg))))) From 0bfa4a17a6ce4421ff5ab5be00f3584886aef381 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 28 Feb 2001 11:46:24 +0000 Subject: [PATCH 0616/2047] * Forgot to commit the changelog for the last change... --- test-suite/ChangeLog | 39 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 39 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index c37a3b690..234d2f642 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,42 @@ +2001-02-28 Dirk Herrmann + + * lib.scm: Added comment about new convenience functions/macros + to test for exceptions. + + (exception:out-of-range, exception:wrong-type-arg): New exported + constants. + + (run-test-exception): New function. + + (pass-if-exception, expect-fail-exception): New exported macros. + + * tests/environments.test: Fixed tests that were checking for + exceptions when set!ing an unbound symbol. + + (exception:unbound-symbol): New constant. + + * tests/hooks.test (catch-error-returning-true, pass-if-not, + catch-error-returning-false), tests/weaks.test + (catch-error-returning-true, pass-if-not, + catch-error-returning-false): Removed. The macro pass-if-not was + not used. The macro catch-error-returning-false is unnecessary + since exceptions are caught by the test-suite anyway. The + functionality of catch-error-returning-true is provided by the new + convenience macro pass-if-exception. + + * tests/hooks.test (exception:wrong-num-hook-args): New constant. + Maybe a standard wrong-num-arg exception should be thrown instead + of a misc-error? + + * tests/reader.test (try-to-read): Replaced by read-string. + + (read-string): New function. + + * tests/alist.test, tests/environments.test, tests/eval.test, + tests/hooks.test, tests/list.test, tests/ports.test, + tests/reader.test, tests/strings.test, tests/weaks.test: Replace + tests for exceptions with the new convenience macros. + 2001-02-28 Dirk Herrmann * tests/alist.test: Remove redundant test name prefix. From 88f9ab70d04f7c28bc96b273a7c8ca2480b7285f Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 28 Feb 2001 11:48:18 +0000 Subject: [PATCH 0617/2047] * Removed old system to check for exceptions. --- test-suite/ChangeLog | 4 ++++ test-suite/lib.scm | 31 +------------------------------ 2 files changed, 5 insertions(+), 30 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 234d2f642..b54179a95 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2001-02-28 Dirk Herrmann + + * lib.scm (signals-error?, signals-error?*): Removed. + 2001-02-28 Dirk Herrmann * lib.scm: Added comment about new convenience functions/macros diff --git a/test-suite/lib.scm b/test-suite/lib.scm index 867b8eb7a..7c8436450 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -38,10 +38,7 @@ make-log-reporter full-reporter user-reporter - format-test-name - - ;; Noticing whether an error occurs. - signals-error? signals-error?*) + format-test-name) ;;;; If you're using Emacs's Scheme mode: @@ -469,29 +466,3 @@ (apply full-reporter result name args))) (set! default-reporter full-reporter) - - -;;;; Detecting whether errors occur - -;;; (signals-error? KEY BODY ...) -;;; Evaluate the expressions BODY ... . If any errors occur, return #t; -;;; otherwise, return #f. -;;; -;;; KEY indicates the sort of errors to look for; it can be a symbol, -;;; indicating that only errors with that name should be caught, or -;;; #t, meaning that any kind of error should be caught. -(defmacro signals-error? key-and-body - `(signals-error?* ,(car key-and-body) - (lambda () ,@(cdr key-and-body)))) - -;;; (signals-error?* KEY THUNK) -;;; Apply THUNK, catching errors. If any errors occur, return #t; -;;; otherwise, return #f. -;;; -;;; KEY indicates the sort of errors to look for; it can be a symbol, -;;; indicating that only errors with that name should be caught, or -;;; #t, meaning that any kind of error should be caught. -(define (signals-error?* key thunk) - (catch key - (lambda () (thunk) #f) - (lambda args #t))) From ef9709dacc4d74c4b0faffaa5a80a6de47dc0a04 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 28 Feb 2001 13:17:47 +0000 Subject: [PATCH 0618/2047] * Moved reader related tests from exceptions.test to reader.test. --- test-suite/ChangeLog | 11 +++++++++++ test-suite/tests/exceptions.test | 12 ------------ test-suite/tests/reader.test | 19 +++++++++++++++++++ 3 files changed, 30 insertions(+), 12 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index b54179a95..1f07f0782 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,14 @@ +2001-02-28 Dirk Herrmann + + * reader.test, exceptions.test: Moved the reader related test + cases from exceptions.test to reader.test. + + * reader.test (exception:eof, exception:unexpected-rparen): New + constants. + + * exceptions.test (read-string, x:eof, x:unexpected-rparen): + Removed. + 2001-02-28 Dirk Herrmann * lib.scm (signals-error?, signals-error?*): Removed. diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test index dbb2ea7c5..b70db1608 100644 --- a/test-suite/tests/exceptions.test +++ b/test-suite/tests/exceptions.test @@ -60,9 +60,6 @@ (use-modules (test-suite lib) (ice-9 regex) (ice-9 common-list)) -(define (read-string s) - (with-input-from-string s (lambda () (read)))) - (defmacro expect-exception (name-snippet expression) `(pass-if (with-output-to-string (lambda () @@ -97,8 +94,6 @@ (define x:missing/extra-expr "[Mm]issing or extra expression") (define x:wrong-num-args "[Ww]rong number of arguments") (define x:wrong-type-arg "[Ww]rong type argument") -(define x:eof "[Ee]nd of file") -(define x:unexpected-rparen "[Uu]nexpected \")\"") ;; This is to encourage people to write tests. @@ -116,13 +111,6 @@ ;; Tests (with-test-prefix "syntax" - (with-test-prefix "reading" - (goad x:eof (read-string "(")) - (goad x:unexpected-rparen (read-string ")")) - (goad x:eof (read-string "#(")) - (goad x:unexpected-rparen (read-string ")")) - ;; Add more (syntax reading) exceptions here. - ) (with-test-prefix "lambda" (goad x:bad-formals (lambda (x 1) 2)) diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test index 41e8566c5..64bd05aa7 100644 --- a/test-suite/tests/reader.test +++ b/test-suite/tests/reader.test @@ -1,6 +1,11 @@ ;;;; reader.test --- test the Guile parser -*- scheme -*- ;;;; Jim Blandy --- September 1999 +(define exception:eof + (cons 'misc-error "^end of file")) +(define exception:unexpected-rparen + (cons 'misc-error "^unexpected \")\"")) + (define (read-string s) (with-input-from-string s (lambda () (read)))) @@ -20,3 +25,17 @@ (pass-if-exception "radix passed to number->string can't be one either" exception:out-of-range (number->string 10 1)) + +(with-test-prefix "mismatching parentheses" + (pass-if-exception "opening parenthesis" + exception:eof + (read-string "(")) + (pass-if-exception "closing parenthesis following mismatched opening" + exception:unexpected-rparen + (read-string ")")) + (pass-if-exception "opening vector parenthesis" + exception:eof + (read-string "#(")) + (pass-if-exception "closing parenthesis following mismatched vector opening" + exception:unexpected-rparen + (read-string ")"))) From 1b5b19c9a927ed433a14315cb1f2db4fc99f939d Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 28 Feb 2001 13:40:36 +0000 Subject: [PATCH 0619/2047] * Turn some test's result into XFAIL instead of FAIL. --- test-suite/ChangeLog | 8 +++++ test-suite/tests/exceptions.test | 51 ++++++++++++++++++++++---------- 2 files changed, 43 insertions(+), 16 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 1f07f0782..7388f1faa 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,11 @@ +2001-02-28 Dirk Herrmann + + * exceptions.test: Use expect-fail-exception to indicate test + cases where exceptions should occur, but don't. + + (exception:bad-bindings, exception:bad-formals, exception:bad-var, + exception:missing/extra-expr): New constants. + 2001-02-28 Dirk Herrmann * reader.test, exceptions.test: Moved the reader related test diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test index b70db1608..8528d4a58 100644 --- a/test-suite/tests/exceptions.test +++ b/test-suite/tests/exceptions.test @@ -85,6 +85,15 @@ ;; Ideally, we would mine these out of libguile/error.[hc], etc. ;; (Someday, when guile is re-implemented in Scheme....) +(define exception:bad-bindings + (cons 'misc-error "^bad bindings")) +(define exception:bad-formals + (cons 'misc-error "^bad formals")) +(define exception:bad-var + (cons 'misc-error "^bad variable")) +(define exception:missing/extra-expr + (cons 'misc-error "^missing or extra expression")) + (define x:unbound-var "[Uu]nbound variable") (define x:bad-var "[Bb]ad variable") (define x:bad-formals "[Bb]ad formals") @@ -118,10 +127,13 @@ (goad x:bad-formals (lambda (x "a") 2)) (goad x:bad-formals (lambda ("a" x) 2)) - ;; no exception on 2001-02-22 - (goad x:bad-formals (lambda (x x) 1)) - ;; no exception on 2001-02-22 - (goad x:bad-formals (lambda (x x x) 1)) + (expect-fail-exception "(lambda (x x) 1)" + exception:bad-formals + (lambda (x x) 1)) + + (expect-fail-exception "(lambda (x x x) 1)" + exception:bad-formals + (lambda (x x x) 1)) (with-test-prefix "cond-arrow-proc" (goad x:bad-formals (cond (1 => (lambda (x 1) 2)))) @@ -197,13 +209,14 @@ (with-test-prefix "misc" (goad x:missing/extra-expr (quote)) - ;; no exception on 2001-02-22 ;; R5RS says: ;; *Note:* In many dialects of Lisp, the empty combination, (), ;; is a legitimate expression. In Scheme, combinations must ;; have at least one subexpression, so () is not a syntactically ;; valid expression. - (goad x:missing/extra-expr ()) + (expect-fail-exception "empty parentheses \"()\"" + exception:missing/extra-expr + ()) ;; Add more (syntax misc) exceptions here. ) @@ -230,10 +243,13 @@ (goad x:wrong-type-arg (set! '#t 1)) (goad x:wrong-type-arg (set! '#f 1)) - ;; no exception on 2001-02-22 - (goad x:bad-var (string-set! (symbol->string 'abc) 1 #\space)) - ;; no exception on 2001-02-22 - (goad x:bad-var (string-set! "abc" 1 #\space)) + (expect-fail-exception "mutating string derived from symbol" + exception:bad-var + (string-set! (symbol->string 'abc) 1 #\space)) + + (expect-fail-exception "mutating string constant" + exception:bad-var + (string-set! "abc" 1 #\space)) ;; Add more (bindings immutable-modification) exceptions here. ) @@ -241,16 +257,18 @@ (goad x:bad-var (let ((1 2)) 3)) (goad x:unbound-var (let ((x 1) (y x)) y)) - ;; no exception on 2001-02-22 - (goad x:bad-bindings (let ((x 1) (x 2)) x)) + (expect-fail-exception "(let ((x 1) (x 2)) x)" + exception:bad-bindings + (let ((x 1) (x 2)) x)) ;; Add more (bindings let) exceptions here. ) (with-test-prefix "let*" (goad x:bad-var (let* ((1 2)) 3)) - ;; no exception on 2001-02-22 - (goad x:bad-bindings (let* ((x 1) (x 2)) x)) + (expect-fail-exception "(let* ((x 1) (x 2)) x)" + exception:bad-bindings + (let* ((x 1) (x 2)) x)) ;; Add more (bindings let*) exceptions here. ) @@ -258,8 +276,9 @@ (goad x:bad-var (letrec ((1 2)) 3)) (goad x:unbound-var (letrec ((x 1) (y x)) y)) - ;; no exception on 2001-02-22 - (goad x:bad-bindings (letrec ((x 1) (x 2)) x)) + (expect-fail-exception "(letrec ((x 1) (x 2)) x)" + exception:bad-bindings + (letrec ((x 1) (x 2)) x)) ;; Add more (bindings letrec) exceptions here. ) From 23deee81615f68d606381dba5880d0a3fe1dbd51 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 28 Feb 2001 16:58:12 +0000 Subject: [PATCH 0620/2047] * Minor fixes to error checking macros. --- libguile/ChangeLog | 7 +++++++ libguile/__scm.h | 2 +- libguile/validate.h | 4 ++-- 3 files changed, 10 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 71163e693..f2717de71 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2001-02-28 Dirk Herrmann + + * __scm.h (SCM_ASSERT_TYPE): Add missing macro parameter. + (Obviously nobody compiles with SCM_RECKLESS defined...) + + * validate.h (SCM_ASSERT_RANGE): Use the argument number. + 2001-02-23 Mikael Djurfeldt * ports.c, ports.h (scm_c_read, scm_c_write): New functions. diff --git a/libguile/__scm.h b/libguile/__scm.h index 75a01a934..d48ae66d6 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -483,7 +483,7 @@ do { \ #ifdef SCM_RECKLESS #define SCM_ASSERT(_cond, _arg, _pos, _subr) -#define SCM_ASSERT_TYPE(_cond, _arg, _pos, _subr) +#define SCM_ASSERT_TYPE(_cond, _arg, _pos, _subr, _msg) #define SCM_ASRTGO(_cond, _label) #else #define SCM_ASSERT(_cond, _arg, _pos, _subr) \ diff --git a/libguile/validate.h b/libguile/validate.h index 2212c273e..029d7e337 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -1,4 +1,4 @@ -/* $Id: validate.h,v 1.25 2001-01-24 00:02:43 dirk Exp $ */ +/* $Id: validate.h,v 1.26 2001-02-28 16:58:12 dirk Exp $ */ /* Copyright (C) 1999, 2000 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify @@ -83,7 +83,7 @@ do { scm_out_of_range_pos (FUNC_NAME, arg, SCM_MAKINUM (pos)); } while (0) #define SCM_ASSERT_RANGE(pos, arg, f) \ - do { if (!(f)) scm_out_of_range (FUNC_NAME, arg); } while (0) + do { if (!(f)) scm_out_of_range_pos (FUNC_NAME, arg, SCM_MAKINUM (pos)); } while (0) #define SCM_MUST_MALLOC_TYPE(type) \ ((type *) scm_must_malloc (sizeof (type), FUNC_NAME)) From 049fa4495bbc3adec77757a222ce296d1d0f8cd7 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 1 Mar 2001 17:57:50 +0000 Subject: [PATCH 0621/2047] * Extracted tests from exceptions.test into strings.test and symbols.test. * Added some tests to strings.test. --- test-suite/ChangeLog | 17 +++++++ test-suite/tests/exceptions.test | 8 ---- test-suite/tests/strings.test | 78 +++++++++++++++++++++++++++----- test-suite/tests/symbols.test | 31 +++++++++++++ 4 files changed, 114 insertions(+), 20 deletions(-) create mode 100644 test-suite/tests/symbols.test diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 7388f1faa..d53b8fa58 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,20 @@ +2001-03-01 Dirk Herrmann + + * symbols.test: New file. + + (exception:immutable-string): New constant. Currently, this is a + dummy since guile does not have immutable strings. + + * exceptions.test, strings.test, symbols.test: Moved the string + related test cases from exceptions.test to strings.test and the + symbol related test cases to symbols.test. + + * strings.test: Copyright notice updated. Added a couple of test + cases. + + (exception:immutable-string): New constant. Currently, this is a + dummy since guile does not have immutable strings. + 2001-02-28 Dirk Herrmann * exceptions.test: Use expect-fail-exception to indicate test diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test index 8528d4a58..7236cebaf 100644 --- a/test-suite/tests/exceptions.test +++ b/test-suite/tests/exceptions.test @@ -243,14 +243,6 @@ (goad x:wrong-type-arg (set! '#t 1)) (goad x:wrong-type-arg (set! '#f 1)) - (expect-fail-exception "mutating string derived from symbol" - exception:bad-var - (string-set! (symbol->string 'abc) 1 #\space)) - - (expect-fail-exception "mutating string constant" - exception:bad-var - (string-set! "abc" 1 #\space)) - ;; Add more (bindings immutable-modification) exceptions here. ) (with-test-prefix "let" diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test index 5645f1fbb..432100f6f 100644 --- a/test-suite/tests/strings.test +++ b/test-suite/tests/strings.test @@ -1,7 +1,7 @@ ;;;; strings.test --- test suite for Guile's string functions -*- scheme -*- ;;;; Jim Blandy --- August 1999 ;;;; -;;;; Copyright (C) 1999 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001 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 @@ -18,17 +18,71 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA -(use-modules (test-suite lib)) + +;; FIXME: As soon as guile supports immutable strings, this has to be +;; replaced with the appropriate error type and message. +(define exception:immutable-string + (cons 'some-error-type "^trying to modify an immutable string")) -(pass-if-exception "string=? does not accept symbols" - exception:wrong-type-arg - (string=? 'a 'b)) +(with-test-prefix "string=?" -(pass-if "stringstring" + + (expect-fail-exception "result is an immutable string" + exception:immutable-string + (string-set! (symbol->string 'abc) 1 #\space))) From f29b3454396fe6a3d8bae2827302c9569ac5f051 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 1 Mar 2001 22:00:02 +0000 Subject: [PATCH 0622/2047] * Moved the number related tests from exceptions.test to numbers.test. --- test-suite/ChangeLog | 7 ++ test-suite/tests/exceptions.test | 2 - test-suite/tests/numbers.test | 150 +++++++++++++++++++++++++++++++ 3 files changed, 157 insertions(+), 2 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index d53b8fa58..58d730c03 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,10 @@ +2001-03-01 Dirk Herrmann + + * exceptions.test, numbers.test: Moved the number related test + cases from exceptions.test to numbers.test. + + * numbers.test: Added a test case. + 2001-03-01 Dirk Herrmann * symbols.test: New file. diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test index 7236cebaf..91cf539e2 100644 --- a/test-suite/tests/exceptions.test +++ b/test-suite/tests/exceptions.test @@ -278,8 +278,6 @@ ) (with-test-prefix "application" - (goad x:wrong-type-arg (+ 1 #f)) - (goad x:wrong-type-arg (+ "1" 2)) (goad x:wrong-num-args (let ((x (lambda (a b) (+ a b)))) (x 3))) ;; Add more (application) exceptions here. ) diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 3fc369aef..139715f81 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -838,6 +838,46 @@ ) +;;; +;;; lcm +;;; + +;;; +;;; number->string +;;; + +;;; +;;; string->number +;;; + +;;; +;;; number? +;;; + +;;; +;;; complex? +;;; + +;;; +;;; real? +;;; + +;;; +;;; rational? +;;; + +;;; +;;; integer? +;;; + +;;; +;;; inexact? +;;; + +;;; +;;; = +;;; + ;;; ;;; < ;;; @@ -1166,3 +1206,113 @@ (pass-if "n = fixnum-min - 1" (not (< (- fixnum-min 1) (- fixnum-min 1)))))) + +;;; +;;; > +;;; + +;;; +;;; <= +;;; + +;;; +;;; >= +;;; + +;;; +;;; zero? +;;; + +;;; +;;; positive? +;;; + +;;; +;;; negative? +;;; + +;;; +;;; max +;;; + +;;; +;;; min +;;; + +;;; +;;; + +;;; + +(with-test-prefix "+" + + (expect-fail "documented?" + (documented? +)) + + (with-test-prefix "wrong type argument" + + (pass-if-exception "1st argument string" + exception:wrong-type-arg + (+ "1" 2)) + + (pass-if-exception "2nd argument bool" + exception:wrong-type-arg + (+ 1 #f)))) +;;; +;;; - +;;; + +;;; +;;; * +;;; + +;;; +;;; / +;;; + +;;; +;;; truncate +;;; + +;;; +;;; round +;;; + +;;; +;;; exact->inexact +;;; + +;;; +;;; floor +;;; + +;;; +;;; ceiling +;;; + +;;; +;;; make-rectangular +;;; + +;;; +;;; make-polar +;;; + +;;; +;;; real-part +;;; + +;;; +;;; imag-part +;;; + +;;; +;;; magnitude +;;; + +;;; +;;; angle +;;; + +;;; +;;; inexact->exact +;;; From 08c608e10a30e318732c52354e918fca16418786 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 2 Mar 2001 01:38:01 +0000 Subject: [PATCH 0623/2047] * extracted the tests from exceptions.test into eval.test and syntax.test. * added a few test cases. --- test-suite/ChangeLog | 53 +++-- test-suite/lib.scm | 7 +- test-suite/tests/eval.test | 58 +++++ test-suite/tests/exceptions.test | 273 +++------------------ test-suite/tests/r4rs.test | 6 + test-suite/tests/syntax.test | 397 +++++++++++++++++++++++++++++++ 6 files changed, 539 insertions(+), 255 deletions(-) create mode 100644 test-suite/tests/syntax.test diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 58d730c03..e69a9af32 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,44 +1,65 @@ 2001-03-01 Dirk Herrmann - * exceptions.test, numbers.test: Moved the number related test - cases from exceptions.test to numbers.test. + * lib.scm (exception:unbound-var, exception:wrong-num-args): New + exported constants. - * numbers.test: Added a test case. + * tests/r4rs.test: Make sure that no bindings for x and y exist + after the file is loaded. + + * tests/syntax.test: New file. + + * tests/exceptions.test, tests/syntax.test, tests/eval.test: + Moved the test cases that are related to guile's syntactic forms + from tests/exceptions.test to tests/syntax.test. Moved tests + related to evaluation and application to tests/eval.test. + + * tests/exceptions.test: Added some test cases that check guile's + exception handling. 2001-03-01 Dirk Herrmann - * symbols.test: New file. + * tests/exceptions.test, tests/numbers.test: Moved the number + related test cases from tests/exceptions.test to + tests/numbers.test. + + * tests/numbers.test: Added a test case. + +2001-03-01 Dirk Herrmann + + * tests/symbols.test: New file. (exception:immutable-string): New constant. Currently, this is a dummy since guile does not have immutable strings. - * exceptions.test, strings.test, symbols.test: Moved the string - related test cases from exceptions.test to strings.test and the - symbol related test cases to symbols.test. + * tests/exceptions.test, tests/strings.test, tests/symbols.test: + Moved the string related test cases from tests/exceptions.test to + tests/strings.test and the symbol related test cases to + tests/symbols.test. - * strings.test: Copyright notice updated. Added a couple of test - cases. + * tests/strings.test: Copyright notice updated. Added a couple + of test cases. (exception:immutable-string): New constant. Currently, this is a dummy since guile does not have immutable strings. 2001-02-28 Dirk Herrmann - * exceptions.test: Use expect-fail-exception to indicate test - cases where exceptions should occur, but don't. + * tests/exceptions.test: Use expect-fail-exception to indicate + test cases where exceptions should occur, but don't. (exception:bad-bindings, exception:bad-formals, exception:bad-var, exception:missing/extra-expr): New constants. 2001-02-28 Dirk Herrmann - * reader.test, exceptions.test: Moved the reader related test - cases from exceptions.test to reader.test. + * tests/reader.test, tests/exceptions.test: Moved the reader + related test cases from tests/exceptions.test to + tests/reader.test. - * reader.test (exception:eof, exception:unexpected-rparen): New - constants. + * tests/reader.test (exception:eof, exception:unexpected-rparen): + New constants. - * exceptions.test (read-string, x:eof, x:unexpected-rparen): + * tests/exceptions.test (read-string, x:eof, x:unexpected-rparen): Removed. 2001-02-28 Dirk Herrmann diff --git a/test-suite/lib.scm b/test-suite/lib.scm index 7c8436450..6cc48f24d 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -22,7 +22,8 @@ (export ;; Exceptions which are commonly being tested for. - exception:out-of-range exception:wrong-type-arg + exception:out-of-range exception:unbound-var + exception:wrong-num-args exception:wrong-type-arg ;; Reporting passes and failures. run-test @@ -219,6 +220,10 @@ ;;; Define some exceptions which are commonly being tested for. (define exception:out-of-range (cons 'out-of-range "^Argument .*out of range")) +(define exception:unbound-var + (cons 'unbound-variable "^Unbound variable")) +(define exception:wrong-num-args + (cons 'wrong-number-of-args "^Wrong number of arguments")) (define exception:wrong-type-arg (cons 'wrong-type-arg "^Wrong type argument")) diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index c06542f06..533b564bc 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -57,6 +57,20 @@ (with-test-prefix "evaluator" + (with-test-prefix "symbol lookup" + + (with-test-prefix "top level" + + (with-test-prefix "unbound" + + (pass-if-exception "variable reference" + exception:unbound-var + x) + + (pass-if-exception "procedure" + exception:unbound-var + (x))))) + (with-test-prefix "parameter error" ;; This is currently a bug in guile: @@ -77,6 +91,50 @@ )) +;;; +;;; apply +;;; + +(with-test-prefix "application" + + (with-test-prefix "wrong number of arguments" + + (pass-if-exception "((lambda () #f) 1)" + exception:wrong-num-args + ((lambda () #f) 1)) + + (pass-if-exception "((lambda (x) #f))" + exception:wrong-num-args + ((lambda (x) #f))) + + (pass-if-exception "((lambda (x) #f) 1 2)" + exception:wrong-num-args + ((lambda (x) #f) 1 2)) + + (pass-if-exception "((lambda (x y) #f))" + exception:wrong-num-args + ((lambda (x y) #f))) + + (pass-if-exception "((lambda (x y) #f) 1)" + exception:wrong-num-args + ((lambda (x y) #f) 1)) + + (pass-if-exception "((lambda (x y) #f) 1 2 3)" + exception:wrong-num-args + ((lambda (x y) #f) 1 2 3)) + + (pass-if-exception "((lambda (x . rest) #f))" + exception:wrong-num-args + ((lambda (x . rest) #f))) + + (pass-if-exception "((lambda (x y . rest) #f))" + exception:wrong-num-args + ((lambda (x y . rest) #f))) + + (pass-if-exception "((lambda (x y . rest) #f) 1)" + exception:wrong-num-args + ((lambda (x y . rest) #f) 1)))) + ;;; ;;; map ;;; diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test index 91cf539e2..6e3c0d9cd 100644 --- a/test-suite/tests/exceptions.test +++ b/test-suite/tests/exceptions.test @@ -1,4 +1,4 @@ -;;;; exceptions.test -*- scheme -*- +;;;; exceptions.test --- tests for Guile's exception handling -*- scheme -*- ;;;; Copyright (C) 2001 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify @@ -40,250 +40,47 @@ ;;;; whether to permit this exception to apply to your modifications. ;;;; If you do not wish that, delete this exception notice. -;;;; Commentary: -;;; All tests should use `expect-exception' (aliased to `goad' for -;;; brevity). Tests that fail (i.e., do NOT cause exception should be -;;; marked with a preceding line "no exception on DATE", where DATE is -;;; when you found the failure. If guile is fixed so that the test -;;; passes, do not delete the comment, but instead append "fixed on -;;; DATE" w/ the fix date. If the test itself changes (due to a change -;;; in the specification, for example), append "test amended on DATE" -;;; and some explanatory text. You can delete comments (and move the -;;; test up into the clump of uncommented tests) when the dates become -;;; very old. -;;; -;;; By convention, test-prefix strings have no whitespace. This makes -;;; change log entries more regular. +(with-test-prefix "throw/catch" -;;;; Code: + (with-test-prefix "wrong type argument" -(use-modules (test-suite lib) (ice-9 regex) (ice-9 common-list)) + (pass-if-exception "(throw 1)" + exception:wrong-type-arg + (throw 1))) -(defmacro expect-exception (name-snippet expression) - `(pass-if (with-output-to-string - (lambda () - (for-each display - (list - "`" - (let ((x (symbol->string ',name-snippet))) - (substring x 2 (string-length x))) - "' expected: ")) - (write ',expression))) - (catch #t - (lambda () ,expression #f) ; conniving falsehood! - (lambda args - ;; squeeze value to `#t' - (not (notany (lambda (x) - (and (string? x) - (string-match ,name-snippet x))) - args)))))) + (with-test-prefix "wrong number of arguments" -(define goad expect-exception) + (pass-if-exception "(throw)" + exception:wrong-num-args + (throw)) -;; Exception messages -;; Ideally, we would mine these out of libguile/error.[hc], etc. -;; (Someday, when guile is re-implemented in Scheme....) + (pass-if-exception "throw 1 / catch 0" + exception:wrong-num-args + (catch 'a + (lambda () (throw 'a)) + (lambda () #f))) -(define exception:bad-bindings - (cons 'misc-error "^bad bindings")) -(define exception:bad-formals - (cons 'misc-error "^bad formals")) -(define exception:bad-var - (cons 'misc-error "^bad variable")) -(define exception:missing/extra-expr - (cons 'misc-error "^missing or extra expression")) + (pass-if-exception "throw 2 / catch 1" + exception:wrong-num-args + (catch 'a + (lambda () (throw 'a 2)) + (lambda (x) #f))) -(define x:unbound-var "[Uu]nbound variable") -(define x:bad-var "[Bb]ad variable") -(define x:bad-formals "[Bb]ad formals") -(define x:bad-bindings "[Bb]ad bindings") -(define x:bad-body "[Bb]ad body") -(define x:bad/missing-clauses "[Bb]ad or missing clauses") -(define x:missing/extra-expr "[Mm]issing or extra expression") -(define x:wrong-num-args "[Ww]rong number of arguments") -(define x:wrong-type-arg "[Ww]rong type argument") + (pass-if-exception "throw 1 / catch 2" + exception:wrong-num-args + (catch 'a + (lambda () (throw 'a)) + (lambda (x y) #f))) -;; This is to encourage people to write tests. + (pass-if-exception "throw 3 / catch 2" + exception:wrong-num-args + (catch 'a + (lambda () (throw 'a 2 3)) + (lambda (y x) #f))) -(define x:hm "[Hh]m") ;-D - (define x:bad "[Bb]ad") ;-D - (define x:sick "[Ss]ick") ;-D - (define x:wrong "[Ww]rong") ;-D - (define x:stupid "[Ss]tupid") ;-D - (define x:strange "[Ss]trange") ;-D - (define x:unlikely "[Uu]nlikely") ;-D - (define x:inelegant "[Ii]nelegant") ;-D - (define x:suboptimal "[Ss]uboptimal") ;-D - (define x:bletcherous "[Bb]letcherous") ;-D h a t - t h e - ?!? - -;; Tests - -(with-test-prefix "syntax" - (with-test-prefix "lambda" - - (goad x:bad-formals (lambda (x 1) 2)) - (goad x:bad-formals (lambda (1 x) 2)) - (goad x:bad-formals (lambda (x "a") 2)) - (goad x:bad-formals (lambda ("a" x) 2)) - - (expect-fail-exception "(lambda (x x) 1)" - exception:bad-formals - (lambda (x x) 1)) - - (expect-fail-exception "(lambda (x x x) 1)" - exception:bad-formals - (lambda (x x x) 1)) - - (with-test-prefix "cond-arrow-proc" - (goad x:bad-formals (cond (1 => (lambda (x 1) 2)))) - ;; Add more (syntax lambda cond-arrow-proc) exceptions here. - ) - - ;; Add more (syntax lambda) exceptions here. - ) - ;; Below, A1,B1 different from A2,B2 because A1,B1 are "named let". - (with-test-prefix "let" - (goad x:bad-body (let)) - (goad x:bad-body (let 1)) - (goad x:bad-body (let ())) - (goad x:bad-body (let (x))) - (goad x:bad-bindings (let (x) 1)) - (goad x:bad-bindings (let ((x)) 3)) - (goad x:bad-bindings (let ((x 1) y) x)) - (goad x:bad-body (let x ())) ; A1 - (goad x:bad-body (let x (y))) ; B1 - ;; Add more (syntax let) exceptions here. - ) - (with-test-prefix "let*" - (goad x:bad-body (let*)) - (goad x:bad-body (let* 1)) - (goad x:bad-body (let* ())) - (goad x:bad-body (let* (x))) - (goad x:bad-bindings (let* (x) 1)) - (goad x:bad-bindings (let* ((x)) 3)) - (goad x:bad-bindings (let* ((x 1) y) x)) - (goad x:bad-bindings (let* x ())) ; A2 - (goad x:bad-bindings (let* x (y))) ; B2 - ;; Add more (syntax let*) exceptions here. - ) - (with-test-prefix "letrec" - (goad x:bad-body (letrec)) - (goad x:bad-body (letrec 1)) - (goad x:bad-body (letrec ())) - (goad x:bad-body (letrec (x))) - (goad x:bad-bindings (letrec (x) 1)) - (goad x:bad-bindings (letrec ((x)) 3)) - (goad x:bad-bindings (letrec ((x 1) y) x)) - (goad x:bad-bindings (letrec x ())) ; A2 - (goad x:bad-bindings (letrec x (y))) ; B2 - ;; Add more (syntax letrec) exceptions here. - ) - (with-test-prefix "cond" - (goad x:bad/missing-clauses (cond)) - (goad x:bad/missing-clauses (cond #t)) - (goad x:bad/missing-clauses (cond 1)) - (goad x:bad/missing-clauses (cond 1 2)) - (goad x:bad/missing-clauses (cond 1 2 3)) - (goad x:bad/missing-clauses (cond 1 2 3 4)) - (goad x:bad/missing-clauses (cond ())) - (goad x:bad/missing-clauses (cond () 1)) - (goad x:bad/missing-clauses (cond (1) 1)) - ;; Add more (syntax cond) exceptions here. - ) - (with-test-prefix "if" - (goad x:missing/extra-expr (if)) - (goad x:missing/extra-expr (if 1 2 3 4)) - ;; Add more (syntax if) exceptions here. - ) - (with-test-prefix "define" - (goad x:missing/extra-expr (define)) - ;; Add more (syntax define) exceptions here. - ) - (with-test-prefix "set!" - (goad x:missing/extra-expr (set!)) - (goad x:missing/extra-expr (set! 1)) - (goad x:missing/extra-expr (set! 1 2 3)) - ;; Add more (syntax set!) exceptions here. - ) - (with-test-prefix "misc" - (goad x:missing/extra-expr (quote)) - - ;; R5RS says: - ;; *Note:* In many dialects of Lisp, the empty combination, (), - ;; is a legitimate expression. In Scheme, combinations must - ;; have at least one subexpression, so () is not a syntactically - ;; valid expression. - (expect-fail-exception "empty parentheses \"()\"" - exception:missing/extra-expr - ()) - - ;; Add more (syntax misc) exceptions here. - ) - ;; Add more (syntax) exceptions here. - ) - -(with-test-prefix "bindings" - (with-test-prefix "unbound" - (goad x:unbound-var unlikely-to-be-bound) - (goad x:unbound-var (unlikely-to-be-bound)) - ;; Add more (bindings unbound) exceptions here. - ) - (with-test-prefix "immutable-modification" - (goad x:bad-var (set! "some-string" #t)) - (goad x:bad-var (set! 1 #t)) - (goad x:bad-var (set! #t #f)) - (goad x:bad-var (set! #f #t)) - (goad x:bad-var (set! #\space 'the-final-frontier)) - (goad x:wrong-type-arg (set! (symbol->string 'safe) 1)) - (goad x:wrong-type-arg (set! '"abc" 1)) ; from r5rs - (goad x:bad-var (set! "abc" 1)) - (goad x:wrong-type-arg (set! '145932 1)) - (goad x:bad-var (set! 145932 1)) - (goad x:wrong-type-arg (set! '#t 1)) - (goad x:wrong-type-arg (set! '#f 1)) - - ;; Add more (bindings immutable-modification) exceptions here. - ) - (with-test-prefix "let" - (goad x:bad-var (let ((1 2)) 3)) - (goad x:unbound-var (let ((x 1) (y x)) y)) - - (expect-fail-exception "(let ((x 1) (x 2)) x)" - exception:bad-bindings - (let ((x 1) (x 2)) x)) - - ;; Add more (bindings let) exceptions here. - ) - (with-test-prefix "let*" - (goad x:bad-var (let* ((1 2)) 3)) - - (expect-fail-exception "(let* ((x 1) (x 2)) x)" - exception:bad-bindings - (let* ((x 1) (x 2)) x)) - - ;; Add more (bindings let*) exceptions here. - ) - (with-test-prefix "letrec" - (goad x:bad-var (letrec ((1 2)) 3)) - (goad x:unbound-var (letrec ((x 1) (y x)) y)) - - (expect-fail-exception "(letrec ((x 1) (x 2)) x)" - exception:bad-bindings - (letrec ((x 1) (x 2)) x)) - - ;; Add more (bindings letrec) exceptions here. - ) - ;; Add more (bindings) exceptions here. - ) - -(with-test-prefix "application" - (goad x:wrong-num-args (let ((x (lambda (a b) (+ a b)))) (x 3))) - ;; Add more (application) exceptions here. - ) - -;; Local variables: -;; eval: (put 'with-test-prefix 'scheme-indent-function 1) -;; End: - -;;; exceptions.test ends here + (pass-if-exception "throw 1 / catch 2+" + exception:wrong-num-args + (catch 'a + (lambda () (throw 'a)) + (lambda (x y . rest) #f))))) diff --git a/test-suite/tests/r4rs.test b/test-suite/tests/r4rs.test index 28b86b095..d6deef1db 100644 --- a/test-suite/tests/r4rs.test +++ b/test-suite/tests/r4rs.test @@ -1012,3 +1012,9 @@ (test-sc4) (test-delay) "last item in file" + + +;; FIXME: We shouldn't create any global bindings in the test files or +;; alternatively execute every test file's code in a module of its own +(if (defined? 'x) (undefine x)) +(if (defined? 'y) (undefine y)) diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test new file mode 100644 index 000000000..550f7fa82 --- /dev/null +++ b/test-suite/tests/syntax.test @@ -0,0 +1,397 @@ +;;;; syntax.test --- test suite for Guile's syntactic forms -*- scheme -*- +;;;; +;;;; Copyright (C) 2001 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + + +(define exception:bad-bindings + (cons 'misc-error "^bad bindings")) +(define exception:bad-body + (cons 'misc-error "^bad body")) +(define exception:bad-formals + (cons 'misc-error "^bad formals")) +(define exception:bad-var + (cons 'misc-error "^bad variable")) +(define exception:bad/missing-clauses + (cons 'misc-error "^bad or missing clauses")) +(define exception:missing/extra-expr + (cons 'misc-error "^missing or extra expression")) + + +(with-test-prefix "expressions" + + (with-test-prefix "missing or extra expression" + + ;; R5RS says: + ;; *Note:* In many dialects of Lisp, the empty combination, (), + ;; is a legitimate expression. In Scheme, combinations must + ;; have at least one subexpression, so () is not a syntactically + ;; valid expression. + (expect-fail-exception "empty parentheses \"()\"" + exception:missing/extra-expr + ()))) + +(with-test-prefix "lambda" + + (with-test-prefix "bad formals" + + (pass-if-exception "(lambda (x 1) 2)" + exception:bad-formals + (lambda (x 1) 2)) + + (pass-if-exception "(lambda (1 x) 2)" + exception:bad-formals + (lambda (1 x) 2)) + + (pass-if-exception "(lambda (x \"a\") 2)" + exception:bad-formals + (lambda (x "a") 2)) + + (pass-if-exception "(lambda (\"a\" x) 2)" + exception:bad-formals + (lambda ("a" x) 2)) + + (expect-fail-exception "(lambda (x x) 1)" + exception:bad-formals + (lambda (x x) 1)) + + (expect-fail-exception "(lambda (x x x) 1)" + exception:bad-formals + (lambda (x x x) 1)))) + +(with-test-prefix "let" + + (with-test-prefix "bindings" + + (pass-if-exception "late binding" + exception:unbound-var + (let ((x 1) (y x)) y))) + + (with-test-prefix "bad body" + + (pass-if-exception "(let ())" + exception:bad-body + (let ())) + + (pass-if-exception "(let ((x 1)))" + exception:bad-body + (let ((x 1)))) + + ;; FIXME: Wouldn't one rather expect a 'bad bindings' error? + (pass-if-exception "(let)" + exception:bad-body + (let)) + + ;; FIXME: Wouldn't one rather expect a 'bad bindings' error? + (pass-if-exception "(let 1)" + exception:bad-body + (let 1)) + + ;; FIXME: Wouldn't one rather expect a 'bad bindings' error? + (pass-if-exception "(let (x))" + exception:bad-body + (let (x)))) + + (with-test-prefix "bad bindings" + + (pass-if-exception "(let (x) 1)" + exception:bad-bindings + (let (x) 1)) + + (pass-if-exception "(let ((x)) 3)" + exception:bad-bindings + (let ((x)) 3)) + + (pass-if-exception "(let ((x 1) y) x)" + exception:bad-bindings + (let ((x 1) y) x)) + + (pass-if-exception "(let ((1 2)) 3)" + exception:bad-var + (let ((1 2)) 3)) + + (expect-fail-exception "(let ((x 1) (x 2)) x)" + exception:bad-bindings + (let ((x 1) (x 2)) x)))) + +(with-test-prefix "named let" + + (with-test-prefix "bad body" + + (pass-if-exception "(let x ())" + exception:bad-body + (let x ())) + + (pass-if-exception "(let x ((y 1)))" + exception:bad-body + (let x ((y 1)))) + + ;; FIXME: Wouldn't one rather expect a 'bad bindings' error? + (pass-if-exception "(let x (y))" + exception:bad-body + (let x (y))))) + +(with-test-prefix "let*" + + (with-test-prefix "bad body" + + (pass-if-exception "(let* ())" + exception:bad-body + (let* ())) + + (pass-if-exception "(let* ((x 1)))" + exception:bad-body + (let* ((x 1)))) + + ;; FIXME: Wouldn't one rather expect a 'bad bindings' error? + (pass-if-exception "(let*)" + exception:bad-body + (let*)) + + ;; FIXME: Wouldn't one rather expect a 'bad bindings' error? + (pass-if-exception "(let* 1)" + exception:bad-body + (let* 1)) + + ;; FIXME: Wouldn't one rather expect a 'bad bindings' error? + (pass-if-exception "(let* (x))" + exception:bad-body + (let* (x)))) + + (with-test-prefix "bad bindings" + + (pass-if-exception "(let* (x) 1)" + exception:bad-bindings + (let* (x) 1)) + + (pass-if-exception "(let* ((x)) 3)" + exception:bad-bindings + (let* ((x)) 3)) + + (pass-if-exception "(let* ((x 1) y) x)" + exception:bad-bindings + (let* ((x 1) y) x)) + + (pass-if-exception "(let* x ())" + exception:bad-bindings + (let* x ())) + + (pass-if-exception "(let* x (y))" + exception:bad-bindings + (let* x (y))) + + (pass-if-exception "(let* ((1 2)) 3)" + exception:bad-var + (let* ((1 2)) 3)) + + (expect-fail-exception "(let* ((x 1) (x 2)) x)" + exception:bad-bindings + (let* ((x 1) (x 2)) x)))) + +(with-test-prefix "letrec" + + (with-test-prefix "bindings" + + (pass-if-exception "initial bindings are undefined" + exception:unbound-var + (let ((x 1)) + (letrec ((x 1) (y x)) y)))) + + (with-test-prefix "bad body" + + (pass-if-exception "(letrec ())" + exception:bad-body + (letrec ())) + + (pass-if-exception "(letrec ((x 1)))" + exception:bad-body + (letrec ((x 1)))) + + ;; FIXME: Wouldn't one rather expect a 'bad bindings' error? + (pass-if-exception "(letrec)" + exception:bad-body + (letrec)) + + ;; FIXME: Wouldn't one rather expect a 'bad bindings' error? + (pass-if-exception "(letrec 1)" + exception:bad-body + (letrec 1)) + + ;; FIXME: Wouldn't one rather expect a 'bad bindings' error? + (pass-if-exception "(letrec (x))" + exception:bad-body + (letrec (x)))) + + (with-test-prefix "bad bindings" + + (pass-if-exception "(letrec (x) 1)" + exception:bad-bindings + (letrec (x) 1)) + + (pass-if-exception "(letrec ((x)) 3)" + exception:bad-bindings + (letrec ((x)) 3)) + + (pass-if-exception "(letrec ((x 1) y) x)" + exception:bad-bindings + (letrec ((x 1) y) x)) + + (pass-if-exception "(letrec x ())" + exception:bad-bindings + (letrec x ())) + + (pass-if-exception "(letrec x (y))" + exception:bad-bindings + (letrec x (y))) + + (pass-if-exception "(letrec ((1 2)) 3)" + exception:bad-var + (letrec ((1 2)) 3)) + + (expect-fail-exception "(letrec ((x 1) (x 2)) x)" + exception:bad-bindings + (letrec ((x 1) (x 2)) x)))) + +(with-test-prefix "if" + + (with-test-prefix "missing or extra expressions" + + (pass-if-exception "(if)" + exception:missing/extra-expr + (if)) + + (pass-if-exception "(if 1 2 3 4)" + exception:missing/extra-expr + (if 1 2 3 4)))) + +(with-test-prefix "cond" + + (with-test-prefix "bad or missing clauses" + + (pass-if-exception "(cond)" + exception:bad/missing-clauses + (cond)) + + (pass-if-exception "(cond #t)" + exception:bad/missing-clauses + (cond #t)) + + (pass-if-exception "(cond 1)" + exception:bad/missing-clauses + (cond 1)) + + (pass-if-exception "(cond 1 2)" + exception:bad/missing-clauses + (cond 1 2)) + + (pass-if-exception "(cond 1 2 3)" + exception:bad/missing-clauses + (cond 1 2 3)) + + (pass-if-exception "(cond 1 2 3 4)" + exception:bad/missing-clauses + (cond 1 2 3 4)) + + (pass-if-exception "(cond ())" + exception:bad/missing-clauses + (cond ())) + + (pass-if-exception "(cond () 1)" + exception:bad/missing-clauses + (cond () 1)) + + (pass-if-exception "(cond (1) 1)" + exception:bad/missing-clauses + (cond (1) 1)))) + +(with-test-prefix "cond =>" + + (with-test-prefix "bad formals" + + (pass-if-exception "=> (lambda (x 1) 2)" + exception:bad-formals + (cond (1 => (lambda (x 1) 2)))))) + +(with-test-prefix "define" + + (with-test-prefix "missing or extra expressions" + + (pass-if-exception "(define)" + exception:missing/extra-expr + (define)))) + +(with-test-prefix "set!" + + (with-test-prefix "missing or extra expressions" + + (pass-if-exception "(set!)" + exception:missing/extra-expr + (set!)) + + (pass-if-exception "(set! 1)" + exception:missing/extra-expr + (set! 1)) + + (pass-if-exception "(set! 1 2 3)" + exception:missing/extra-expr + (set! 1 2 3))) + + (with-test-prefix "bad variable" + + (pass-if-exception "(set! \"\" #t)" + exception:bad-var + (set! "" #t)) + + (pass-if-exception "(set! 1 #t)" + exception:bad-var + (set! 1 #t)) + + (pass-if-exception "(set! #t #f)" + exception:bad-var + (set! #t #f)) + + (pass-if-exception "(set! #f #t)" + exception:bad-var + (set! #f #t)) + + (pass-if-exception "(set! #\space #f)" + exception:bad-var + (set! #\space #f)))) + +(with-test-prefix "generalized set! (SRFI 17)" + + (with-test-prefix "target is not procedure with setter" + + (pass-if-exception "(set! (symbol->string 'x) 1)" + exception:wrong-type-arg + (set! (symbol->string 'x) 1)) + + (pass-if-exception "(set! '#f 1)" + exception:wrong-type-arg + (set! '#f 1)))) + +(with-test-prefix "quote" + + (with-test-prefix "missing or extra expression" + + (pass-if-exception "(quote)" + exception:missing/extra-expr + (quote)) + + (pass-if-exception "(quote a b)" + exception:missing/extra-expr + (quote a b)))) From 942e5b9162916da882196fc89482cd8556c2125b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 2 Mar 2001 09:07:22 +0000 Subject: [PATCH 0624/2047] * vectors.c (s_scm_vector_p, list->vector, scm_vector) (scm_vector_ref, scm_vector_set_x, scm_vector_to_list) (scm_vector_fill_x), strorder.c (scm_string_equal_p) (scm_string_ci_equal_p, scm_string_less_p, scm_string_leq_p) (scm_string_gr_p, scm_string_geq_p, scm_string_ci_less_p) (scm_string_ci_geq_p), symbols.c (scm_symbol_p) (scm_symbol_to_string, scm_string_to_symbol): Changed use of @t{} to @code{} as the texinfo manual recommends, converted the examples to use a @lisp{}-environment. * strports.c (scm_eval_string): Cleaned up the docstring. * struct.c (scm_struct_p, scm_struct_vtable_p): Added texinfo markup. * numbers.c (scm_exact_p, scm_odd_p, scm_even_p) (scm_number_to_string, scm_string_to_number, scm_number_p) (scm_real_p, scm_integer_p, scm_inexact_p, scm_make_rectangular) (scm_make_polar, scm_inexact_to_exact): Added texinfo markup. (scm_ash): Added texinfo markup and removed obsolete @refill. (scm_gr_p): Corrected comment. (scm_gr_p, scm_leq_p, scm_geq_p): Added texinfo markup to (future docstring) comments. (scm_positive_p, scm_less_p, scm_num_eq_p, scm_real_p) (scm_number_p, scm_negative_p, scm_max, scm_min, scm_sum) (scm_difference, scm_product, scm_divide, scm_asinh, scm_acosh) (scm_atanh, scm_truncate, scm_round, scm_exact_to_inexact) (floor, ceiling, $sqrt, $abs, $exp, $log, $sin, $cos, $tan, $asin) ($acos, $atan, $sinh, $cosh, $tanh, scm_real_part, scm_imag_part) (scm_magnitude, scm_angle, scm_abs, scm_quotient, scm_remainder) (scm_modulo, scm_gcd, scm_lcm): Added (future docstring) comments. --- libguile/numbers.c | 224 +++++++++++++++++++++++++++++++------------- libguile/strorder.c | 57 ++++++----- libguile/strports.c | 7 +- libguile/struct.c | 5 +- libguile/symbols.c | 86 ++++++++--------- libguile/vectors.c | 83 +++++++--------- 6 files changed, 269 insertions(+), 193 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 20f78abbb..2b2cedbff 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -103,7 +103,8 @@ static SCM abs_most_negative_fixnum; SCM_DEFINE (scm_exact_p, "exact?", 1, 0, 0, (SCM x), - "Return #t if X is an exact number, #f otherwise.") + "Return @code{#t} if @var{x} is an exact number, @code{#f}\n" + "otherwise.") #define FUNC_NAME s_scm_exact_p { if (SCM_INUMP (x)) { @@ -119,7 +120,8 @@ SCM_DEFINE (scm_exact_p, "exact?", 1, 0, 0, SCM_DEFINE (scm_odd_p, "odd?", 1, 0, 0, (SCM n), - "Return #t if N is an odd number, #f otherwise.") + "Return @code{#t} if @var{n} is an odd number, @code{#f}\n" + "otherwise.") #define FUNC_NAME s_scm_odd_p { if (SCM_INUMP (n)) { @@ -135,7 +137,8 @@ SCM_DEFINE (scm_odd_p, "odd?", 1, 0, 0, SCM_DEFINE (scm_even_p, "even?", 1, 0, 0, (SCM n), - "Return #t if N is an even number, #f otherwise.") + "Return @code{#t} if @var{n} is an even number, @code{#f}\n" + "otherwise.") #define FUNC_NAME s_scm_even_p { if (SCM_INUMP (n)) { @@ -150,7 +153,8 @@ SCM_DEFINE (scm_even_p, "even?", 1, 0, 0, SCM_GPROC (s_abs, "abs", 1, 0, 0, scm_abs, g_abs); - +/* "Return the absolute value of @var{x}." + */ SCM scm_abs (SCM x) { @@ -182,7 +186,8 @@ scm_abs (SCM x) SCM_GPROC (s_quotient, "quotient", 2, 0, 0, scm_quotient, g_quotient); - +/* "Return the quotient of the numbers @var{x} and @var{y}." + */ SCM scm_quotient (SCM x, SCM y) { @@ -259,7 +264,12 @@ scm_quotient (SCM x, SCM y) SCM_GPROC (s_remainder, "remainder", 2, 0, 0, scm_remainder, g_remainder); - +/* "Return the remainder of the numbers @var{x} and @var{y}.\n" + * "@lisp\n" + * "(remainder 13 4) @result{} 1\n" + * "(remainder -13 4) @result{} -1\n" + * "@end lisp" + */ SCM scm_remainder (SCM x, SCM y) { @@ -306,7 +316,12 @@ scm_remainder (SCM x, SCM y) SCM_GPROC (s_modulo, "modulo", 2, 0, 0, scm_modulo, g_modulo); - +/* "Return the modulo of the numbers @var{x} and @var{y}.\n" + * "@lisp\n" + * "(modulo 13 4) @result{} 1\n" + * "(modulo -13 4) @result{} 3\n" + * "@end lisp" + */ SCM scm_modulo (SCM x, SCM y) { @@ -349,7 +364,9 @@ scm_modulo (SCM x, SCM y) SCM_GPROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd, g_gcd); - +/* "Return the greatest common divisor of all arguments.\n" + * "If called without arguments, 0 is returned." + */ SCM scm_gcd (SCM x, SCM y) { @@ -462,7 +479,9 @@ scm_gcd (SCM x, SCM y) SCM_GPROC1 (s_lcm, "lcm", scm_tc7_asubr, scm_lcm, g_lcm); - +/* "Return the least common multiple of the arguments.\n" + * "If called without arguments, 1 is returned." + */ SCM scm_lcm (SCM n1, SCM n2) { @@ -1130,14 +1149,15 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0, SCM_DEFINE (scm_ash, "ash", 2, 0, 0, (SCM n, SCM cnt), - "The function ash performs an arithmetic shift left by CNT bits\n" - "(or shift right, if CNT is negative). 'Arithmetic' means, that\n" - "the function does not guarantee to keep the bit structure of N,\n" - "but rather guarantees that the result will always be rounded\n" - "towards minus infinity. Therefore, the results of ash and a\n" - "corresponding bitwise shift will differ if N is negative.\n\n" + "The function ash performs an arithmetic shift left by @var{CNT}\n" + "bits (or shift right, if @var{cnt} is negative).\n" + "'Arithmetic' means, that the function does not guarantee to\n" + "keep the bit structure of @var{n}, but rather guarantees that\n" + "the result will always be rounded towards minus infinity.\n" + "Therefore, the results of ash and a corresponding bitwise\n" + "shift will differ if N is negative.\n\n" "Formally, the function returns an integer equivalent to\n" - "@code{(inexact->exact (floor (* N (expt 2 CNT))))}.@refill\n\n" + "@code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}.\n\n" "Example:\n" "@lisp\n" "(number->string (ash #b1 3) 2)\n" @@ -2265,8 +2285,8 @@ big2str (SCM b, unsigned int radix) SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0, (SCM n, SCM radix), "Return a string holding the external representation of the\n" - "number N in the given RADIX. If N is inexact, a radix of 10\n" - "will be used.") + "number @var{n} in the given @var{radix}. If @var{n} is\n" + "inexact, a radix of 10 will be used.") #define FUNC_NAME s_scm_number_to_string { int base; @@ -2845,12 +2865,13 @@ scm_istring2number (char *str, long len, long radix) SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0, (SCM string, SCM radix), "Returns a number of the maximally precise representation\n" - "expressed by the given STRING. RADIX must be an exact integer,\n" - "either 2, 8, 10, or 16. If supplied, RADIX is a default radix\n" - "that may be overridden by an explicit radix prefix in STRING\n" - "(e.g. \"#o177\"). If RADIX is not supplied, then the default\n" - "radix is 10. If string is not a syntactically valid notation\n" - "for a number, then `string->number' returns #f. (r5rs)") + "expressed by the given @var{string}. @var{radix} must be an\n" + "exact integer, either 2, 8, 10, or 16. If supplied, @var{RADIX}\n" + "is a default radix that may be overridden by an explicit\n" + "radix prefix in @var{string} (e.g. \"#o177\"). If @var{radix}\n" + "is not supplied, then the default radix is 10. If string is\n" + "not a syntactically valid notation for a number, then\n" + "@code{string->number} returns @code{#f}. (r5rs)") #define FUNC_NAME s_scm_string_to_number { SCM answer; @@ -2918,13 +2939,18 @@ scm_complex_equalp (SCM x, SCM y) SCM_REGISTER_PROC (s_number_p, "number?", 1, 0, 0, scm_number_p); - +/* "Return @code{#t} if @var{x} is a number, @code{#f}\n" + * "else. Note that the sets of complex, real, rational and\n" + * "integer values form subsets of the set of numbers, i. e. the\n" + * "predicate will be fulfilled for any number." + */ SCM_DEFINE (scm_number_p, "complex?", 1, 0, 0, (SCM x), - "Return #t if X is a complex number, #f else. Note that the\n" - "sets of real, rational and integer values form subsets of the\n" - "set of complex numbers, i. e. the predicate will also be\n" - "fulfilled if X is a real, rational or integer number.") + "Return @code{#t} if @var{x} is a complex number, @code{#f}\n" + "else. Note that the sets of real, rational and integer\n" + "values form subsets of the set of complex numbers, i. e. the\n" + "predicate will also be fulfilled if @var{x} is a real,\n" + "rational or integer number.") #define FUNC_NAME s_scm_number_p { return SCM_BOOL (SCM_NUMBERP (x)); @@ -2933,13 +2959,19 @@ SCM_DEFINE (scm_number_p, "complex?", 1, 0, 0, SCM_REGISTER_PROC (s_real_p, "real?", 1, 0, 0, scm_real_p); - +/* "Return @code{#t} if @var{x} is a real number, @code{#f} else.\n" + * "Note that the sets of integer and rational values form a subset\n" + * "of the set of real numbers, i. e. the predicate will also\n" + * "be fulfilled if @var{x} is an integer or a rational number." + */ SCM_DEFINE (scm_real_p, "rational?", 1, 0, 0, (SCM x), - "Return #t if X is a rational number, #f else. Note that the\n" - "set of integer values forms a subset of the set of rational\n" - "numbers, i. e. the predicate will also be fulfilled if X is an\n" - "integer number.") + "Return @code{#t} if @var{x} is a rational number, @code{#f}\n" + "else. Note that the set of integer values forms a subset of\n" + "the set of rational numbers, i. e. the predicate will also be\n" + "fulfilled if @var{x} is an integer number. Real numbers\n" + "will also satisfy this predicate, because of their limited\n" + "precision.") #define FUNC_NAME s_scm_real_p { if (SCM_INUMP (x)) { @@ -2959,7 +2991,8 @@ SCM_DEFINE (scm_real_p, "rational?", 1, 0, 0, SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0, (SCM x), - "Return #t if X is an integer number, #f else.") + "Return @code{#t} if @var{x} is an integer number, @code{#f}\n" + "else.") #define FUNC_NAME s_scm_integer_p { double r; @@ -2983,7 +3016,8 @@ SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0, SCM_DEFINE (scm_inexact_p, "inexact?", 1, 0, 0, (SCM x), - "Return #t if X is an inexact number, #f else.") + "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n" + "else.") #define FUNC_NAME s_scm_inexact_p { return SCM_BOOL (SCM_INEXACTP (x)); @@ -2992,7 +3026,7 @@ SCM_DEFINE (scm_inexact_p, "inexact?", 1, 0, 0, SCM_GPROC1 (s_eq_p, "=", scm_tc7_rpsubr, scm_num_eq_p, g_eq_p); - +/* "Return @code{#t} if all parameters are numerically equal." */ SCM scm_num_eq_p (SCM x, SCM y) { @@ -3060,7 +3094,9 @@ scm_num_eq_p (SCM x, SCM y) SCM_GPROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p, g_less_p); - +/* "Return @code{#t} if the list of parameters is monotonically\n" + * "increasing." + */ SCM scm_less_p (SCM x, SCM y) { @@ -3103,8 +3139,8 @@ scm_less_p (SCM x, SCM y) SCM_GPROC1 (s_scm_gr_p, ">", scm_tc7_rpsubr, scm_gr_p, g_gr_p); -/* "Return #t if the list of parameters is monotonically\n" - * "increasing." +/* "Return @code{#t} if the list of parameters is monotonically\n" + * "decreasing." */ #define FUNC_NAME s_scm_gr_p SCM @@ -3121,7 +3157,7 @@ scm_gr_p (SCM x, SCM y) SCM_GPROC1 (s_scm_leq_p, "<=", scm_tc7_rpsubr, scm_leq_p, g_leq_p); -/* "Return #t if the list of parameters is monotonically\n" +/* "Return @code{#t} if the list of parameters is monotonically\n" * "non-decreasing." */ #define FUNC_NAME s_scm_leq_p @@ -3139,7 +3175,7 @@ scm_leq_p (SCM x, SCM y) SCM_GPROC1 (s_scm_geq_p, ">=", scm_tc7_rpsubr, scm_geq_p, g_geq_p); -/* "Return #t if the list of parameters is monotonically\n" +/* "Return @code{#t} if the list of parameters is monotonically\n" * "non-increasing." */ #define FUNC_NAME s_scm_geq_p @@ -3157,7 +3193,9 @@ scm_geq_p (SCM x, SCM y) SCM_GPROC (s_zero_p, "zero?", 1, 0, 0, scm_zero_p, g_zero_p); - +/* "Return @code{#t} if @var{z} is an exact or inexact number equal to\n" + * "zero." + */ SCM scm_zero_p (SCM z) { @@ -3177,7 +3215,9 @@ scm_zero_p (SCM z) SCM_GPROC (s_positive_p, "positive?", 1, 0, 0, scm_positive_p, g_positive_p); - +/* "Return @code{#t} if @var{x} is an exact or inexact number greater than\n" + * "zero." + */ SCM scm_positive_p (SCM x) { @@ -3194,7 +3234,9 @@ scm_positive_p (SCM x) SCM_GPROC (s_negative_p, "negative?", 1, 0, 0, scm_negative_p, g_negative_p); - +/* "Return @code{#t} if @var{x} is an exact or inexact number less than\n" + * "zero." + */ SCM scm_negative_p (SCM x) { @@ -3211,7 +3253,8 @@ scm_negative_p (SCM x) SCM_GPROC1 (s_max, "max", scm_tc7_asubr, scm_max, g_max); - +/* "Return the maximum of all parameter values." + */ SCM scm_max (SCM x, SCM y) { @@ -3268,7 +3311,8 @@ scm_max (SCM x, SCM y) SCM_GPROC1 (s_min, "min", scm_tc7_asubr, scm_min, g_min); - +/* "Return the minium of all parameter values." + */ SCM scm_min (SCM x, SCM y) { @@ -3325,7 +3369,9 @@ scm_min (SCM x, SCM y) SCM_GPROC1 (s_sum, "+", scm_tc7_asubr, scm_sum, g_sum); - +/* "Return the sum of all parameter values. Return 0 if called without\n" + * "any parameters." + */ SCM scm_sum (SCM x, SCM y) { @@ -3430,7 +3476,10 @@ scm_sum (SCM x, SCM y) SCM_GPROC1 (s_difference, "-", scm_tc7_asubr, scm_difference, g_difference); - +/* "If called without arguments, 0 is returned. Otherwise the sum of\n" + * "all but the first argument are subtracted from the first\n" + * "argument." + */ SCM scm_difference (SCM x, SCM y) { @@ -3556,7 +3605,9 @@ scm_difference (SCM x, SCM y) SCM_GPROC1 (s_product, "*", scm_tc7_asubr, scm_product, g_product); - +/* "Return the product of all arguments. If called without arguments,\n" + * "1 is returned." + */ SCM scm_product (SCM x, SCM y) { @@ -3703,7 +3754,8 @@ scm_num2dbl (SCM a, const char *why) SCM_GPROC1 (s_divide, "/", scm_tc7_asubr, scm_divide, g_divide); - +/* "Divide the first argument by the product of the remaining arguments." + */ SCM scm_divide (SCM x, SCM y) { @@ -3859,7 +3911,8 @@ scm_divide (SCM x, SCM y) SCM_GPROC1 (s_asinh, "$asinh", scm_tc7_cxr, (SCM (*)()) scm_asinh, g_asinh); - +/* "Return the inverse hyperbolic sine of @var{x}." + */ double scm_asinh (double x) { @@ -3870,7 +3923,8 @@ scm_asinh (double x) SCM_GPROC1 (s_acosh, "$acosh", scm_tc7_cxr, (SCM (*)()) scm_acosh, g_acosh); - +/* "Return the inverse hyperbolic cosine of @var{x}." + */ double scm_acosh (double x) { @@ -3881,7 +3935,8 @@ scm_acosh (double x) SCM_GPROC1 (s_atanh, "$atanh", scm_tc7_cxr, (SCM (*)()) scm_atanh, g_atanh); - +/* "Return the inverse hyperbolic tangent of @var{x}." + */ double scm_atanh (double x) { @@ -3892,7 +3947,8 @@ scm_atanh (double x) SCM_GPROC1 (s_truncate, "truncate", scm_tc7_cxr, (SCM (*)()) scm_truncate, g_truncate); - +/* "Round the inexact number @var{x} towards zero." + */ double scm_truncate (double x) { @@ -3904,7 +3960,9 @@ scm_truncate (double x) SCM_GPROC1 (s_round, "round", scm_tc7_cxr, (SCM (*)()) scm_round, g_round); - +/* "Round the inexact number @var{x}. If @var{x} is halfway between two\n" + * "numbers, round towards even." + */ double scm_round (double x) { @@ -3918,7 +3976,8 @@ scm_round (double x) SCM_GPROC1 (s_exact_to_inexact, "exact->inexact", scm_tc7_cxr, (SCM (*)()) scm_exact_to_inexact, g_exact_to_inexact); - +/* Convert the number @var{x} to its inexact representation.\n" + */ double scm_exact_to_inexact (double z) { @@ -3927,20 +3986,50 @@ scm_exact_to_inexact (double z) SCM_GPROC1 (s_i_floor, "floor", scm_tc7_cxr, (SCM (*)()) floor, g_i_floor); +/* "Round the number @var{x} towards minus infinity." + */ SCM_GPROC1 (s_i_ceil, "ceiling", scm_tc7_cxr, (SCM (*)()) ceil, g_i_ceil); +/* "Round the number @var{x} towards infinity." + */ SCM_GPROC1 (s_i_sqrt, "$sqrt", scm_tc7_cxr, (SCM (*)()) sqrt, g_i_sqrt); +/* "Return the square root of the real number @var{x}." + */ SCM_GPROC1 (s_i_abs, "$abs", scm_tc7_cxr, (SCM (*)()) fabs, g_i_abs); +/* "Return the absolute value of the real number @var{x}." + */ SCM_GPROC1 (s_i_exp, "$exp", scm_tc7_cxr, (SCM (*)()) exp, g_i_exp); +/* "Return the @var{x}th power of e." + */ SCM_GPROC1 (s_i_log, "$log", scm_tc7_cxr, (SCM (*)()) log, g_i_log); +/* "Return the natural logarithm of the real number@var{x}." + */ SCM_GPROC1 (s_i_sin, "$sin", scm_tc7_cxr, (SCM (*)()) sin, g_i_sin); +/* "Return the sine of the real number @var{x}." + */ SCM_GPROC1 (s_i_cos, "$cos", scm_tc7_cxr, (SCM (*)()) cos, g_i_cos); +/* "Return the cosine of the real number @var{x}." + */ SCM_GPROC1 (s_i_tan, "$tan", scm_tc7_cxr, (SCM (*)()) tan, g_i_tan); +/* "Return the tangent of the real number @var{x}." + */ SCM_GPROC1 (s_i_asin, "$asin", scm_tc7_cxr, (SCM (*)()) asin, g_i_asin); +/* "Return the arc sine of the real number @var{x}." + */ SCM_GPROC1 (s_i_acos, "$acos", scm_tc7_cxr, (SCM (*)()) acos, g_i_acos); +/* "Return the arc cosine of the real number @var{x}." + */ SCM_GPROC1 (s_i_atan, "$atan", scm_tc7_cxr, (SCM (*)()) atan, g_i_atan); +/* "Return the arc tangent of the real number @var{x}." + */ SCM_GPROC1 (s_i_sinh, "$sinh", scm_tc7_cxr, (SCM (*)()) sinh, g_i_sinh); +/* "Return the hyperbolic sine of the real number @var{x}." + */ SCM_GPROC1 (s_i_cosh, "$cosh", scm_tc7_cxr, (SCM (*)()) cosh, g_i_cosh); +/* "Return the hyperbolic cosine of the real number @var{x}." + */ SCM_GPROC1 (s_i_tanh, "$tanh", scm_tc7_cxr, (SCM (*)()) tanh, g_i_tanh); +/* "Return the hyperbolic tangent of the real number @var{x}." + */ struct dpair { @@ -4008,8 +4097,8 @@ SCM_DEFINE (scm_sys_atan2, "$atan2", 2, 0, 0, SCM_DEFINE (scm_make_rectangular, "make-rectangular", 2, 0, 0, (SCM real, SCM imaginary), - "Return a complex number constructed of the given REAL and\n" - "IMAGINARY parts.") + "Return a complex number constructed of the given @var{real} and\n" + "@var{imaginary} parts.") #define FUNC_NAME s_scm_make_rectangular { struct dpair xy; @@ -4022,7 +4111,7 @@ SCM_DEFINE (scm_make_rectangular, "make-rectangular", 2, 0, 0, SCM_DEFINE (scm_make_polar, "make-polar", 2, 0, 0, (SCM x, SCM y), - "Return the complex number X * e^(i * Y).") + "Return the complex number @var{x} * e^(i * @var{y}).") #define FUNC_NAME s_scm_make_polar { struct dpair xy; @@ -4033,7 +4122,8 @@ SCM_DEFINE (scm_make_polar, "make-polar", 2, 0, 0, SCM_GPROC (s_real_part, "real-part", 1, 0, 0, scm_real_part, g_real_part); - +/* "Return the real part of the number @var{z}." + */ SCM scm_real_part (SCM z) { @@ -4052,7 +4142,8 @@ scm_real_part (SCM z) SCM_GPROC (s_imag_part, "imag-part", 1, 0, 0, scm_imag_part, g_imag_part); - +/* "Return the imaginary part of the number @var{z}." + */ SCM scm_imag_part (SCM z) { @@ -4071,7 +4162,9 @@ scm_imag_part (SCM z) SCM_GPROC (s_magnitude, "magnitude", 1, 0, 0, scm_magnitude, g_magnitude); - +/* "Return the magnitude of the number @var{z}. This is the same as\n" + * "@code{abs} for real arguments, but also allows complex numbers." + */ SCM scm_magnitude (SCM z) { @@ -4107,7 +4200,8 @@ scm_magnitude (SCM z) SCM_GPROC (s_angle, "angle", 1, 0, 0, scm_angle, g_angle); - +/* "Return the angle of the complex number @var{z}." + */ SCM scm_angle (SCM z) { @@ -4135,7 +4229,7 @@ scm_angle (SCM z) SCM_DEFINE (scm_inexact_to_exact, "inexact->exact", 1, 0, 0, (SCM z), - "Returns an exact number that is numerically closest to Z.") + "Returns an exact number that is numerically closest to @var{z}.") #define FUNC_NAME s_scm_inexact_to_exact { if (SCM_INUMP (z)) { diff --git a/libguile/strorder.c b/libguile/strorder.c index adea5de92..22f60db49 100644 --- a/libguile/strorder.c +++ b/libguile/strorder.c @@ -56,11 +56,13 @@ SCM_DEFINE1 (scm_string_equal_p, "string=?", scm_tc7_rpsubr, (SCM s1, SCM s2), "Lexicographic equality predicate; \n" - "Returns @t{#t} if the two strings are the same length and contain the same\n" - "characters in the same positions, otherwise returns @t{#f}. (r5rs)\n\n" - "@samp{String-ci=?} treats\n" - "upper and lower case letters as though they were the same character, but\n" - "@samp{string=?} treats upper and lower case as distinct characters.") + "Returns @code{#t} if the two strings are the same length and\n" + "contain the same characters in the same positions, otherwise\n" + "returns @code{#f}. (r5rs)\n\n" + "The procedure @code{string-ci=?} treats upper and lower case\n" + "letters as though they were the same character, but\n" + "@code{string=?} treats upper and lower case as distinct\n" + "characters.") #define FUNC_NAME s_scm_string_equal_p { scm_sizet length; @@ -92,9 +94,10 @@ SCM_DEFINE1 (scm_string_equal_p, "string=?", scm_tc7_rpsubr, SCM_DEFINE1 (scm_string_ci_equal_p, "string-ci=?", scm_tc7_rpsubr, (SCM s1, SCM s2), - "Case-insensitive string equality predicate; returns @t{#t} if\n" - "the two strings are the same length and their component characters\n" - "match (ignoring case) at each position; otherwise returns @t{#f}. (r5rs)") + "Case-insensitive string equality predicate; returns @code{#t}\n" + "if the two strings are the same length and their component\n" + "characters match (ignoring case) at each position; otherwise\n" + "returns @code{#f}. (r5rs)") #define FUNC_NAME s_scm_string_ci_equal_p { scm_sizet length; @@ -150,8 +153,8 @@ string_less_p (SCM s1, SCM s2) SCM_DEFINE1 (scm_string_less_p, "string?", scm_tc7_rpsubr, (SCM s1, SCM s2), - "Lexicographic ordering predicate; returns @t{#t} if @var{s1}\n" - "is lexicographically greater than @var{s2}. (r5rs)") + "Lexicographic ordering predicate; returns @code{#t} if\n" + "@var{s1} is lexicographically greater than @var{s2}. (r5rs)") #define FUNC_NAME s_scm_string_gr_p { SCM_VALIDATE_STRING (1, s1); @@ -192,8 +196,9 @@ SCM_DEFINE1 (scm_string_gr_p, "string>?", scm_tc7_rpsubr, SCM_DEFINE1 (scm_string_geq_p, "string>=?", scm_tc7_rpsubr, (SCM s1, SCM s2), - "Lexicographic ordering predicate; returns @t{#t} if @var{s1}\n" - "is lexicographically greater than or equal to @var{s2}. (r5rs)") + "Lexicographic ordering predicate; returns @code{#t} if\n" + "@var{s1} is lexicographically greater than or equal to\n" + "@var{s2}. (r5rs)") #define FUNC_NAME s_scm_string_geq_p { SCM_VALIDATE_STRING (1, s1); @@ -230,8 +235,8 @@ string_ci_less_p (SCM s1, SCM s2) SCM_DEFINE1 (scm_string_ci_less_p, "string-ci?", scm_tc7_rpsubr, (SCM s1, SCM s2), - "Case insensitive lexicographic ordering predicate; \n" - "returns @t{#t} if @var{s1} is lexicographically greater than\n" - "@var{s2} regardless of case. (r5rs)") + "Case insensitive lexicographic ordering predicate;\n" + "returns @code{#t} if @var{s1} is lexicographically greater\n" + "than @var{s2} regardless of case. (r5rs)") #define FUNC_NAME s_scm_string_ci_gr_p { SCM_VALIDATE_STRING (1, s1); @@ -275,9 +280,9 @@ SCM_DEFINE1 (scm_string_ci_gr_p, "string-ci>?", scm_tc7_rpsubr, SCM_DEFINE1 (scm_string_ci_geq_p, "string-ci>=?", scm_tc7_rpsubr, (SCM s1, SCM s2), - "Case insensitive lexicographic ordering predicate; \n" - "returns @t{#t} if @var{s1} is lexicographically greater than\n" - "or equal to @var{s2} regardless of case. (r5rs)") + "Case insensitive lexicographic ordering predicate;\n" + "returns @code{#t} if @var{s1} is lexicographically greater\n" + "than or equal to @var{s2} regardless of case. (r5rs)") #define FUNC_NAME s_scm_string_ci_geq_p { SCM_VALIDATE_STRING (1, s1); diff --git a/libguile/strports.c b/libguile/strports.c index 0e48e0f7d..8a99e618b 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -396,9 +396,10 @@ scm_eval_0str (const char *expr) SCM_DEFINE (scm_eval_string, "eval-string", 1, 0, 0, (SCM string), - "Evaluate @var{string} as the text representation of a Scheme form\n" - "or forms, and return whatever value they produce.\n" - "Evaluation takes place in (interaction-environment).") + "Evaluate @var{string} as the text representation of a Scheme\n" + "form or forms, and return whatever value they produce.\n" + "Evaluation takes place in the environment returned by the\n" + "procedure @code{interaction-environment}.") #define FUNC_NAME s_scm_eval_string { SCM port = scm_mkstrport (SCM_INUM0, string, SCM_OPN | SCM_RDNG, diff --git a/libguile/struct.c b/libguile/struct.c index 0746c0b9f..f2d065b80 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -236,7 +236,8 @@ scm_struct_init (SCM handle, SCM layout, scm_bits_t * mem, int tail_elts, SCM in SCM_DEFINE (scm_struct_p, "struct?", 1, 0, 0, (SCM x), - "Return #t iff @var{obj} is a structure object, else #f.") + "Return @code{#t} iff @var{obj} is a structure object, else\n" + "@code{#f}.") #define FUNC_NAME s_scm_struct_p { return SCM_BOOL(SCM_STRUCTP (x)); @@ -245,7 +246,7 @@ SCM_DEFINE (scm_struct_p, "struct?", 1, 0, 0, SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0, (SCM x), - "Return #t iff obj is a vtable structure.") + "Return @code{#t} iff obj is a vtable structure.") #define FUNC_NAME s_scm_struct_vtable_p { SCM layout; diff --git a/libguile/symbols.c b/libguile/symbols.c index 0345bf959..83b32560b 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -402,7 +402,8 @@ scm_symbol_value0 (const char *name) SCM_DEFINE (scm_symbol_p, "symbol?", 1, 0, 0, (SCM obj), - "Returns @t{#t} if @var{obj} is a symbol, otherwise returns @t{#f}. (r5rs)") + "Returns @code{#t} if @var{obj} is a symbol, otherwise returns\n" + "@code{#f}. (r5rs)") #define FUNC_NAME s_scm_symbol_p { return SCM_BOOL (SCM_SYMBOLP (obj)); @@ -411,28 +412,27 @@ SCM_DEFINE (scm_symbol_p, "symbol?", 1, 0, 0, SCM_DEFINE (scm_symbol_to_string, "symbol->string", 1, 0, 0, (SCM s), - "Returns the name of @var{symbol} as a string. If the symbol was part of\n" - "an object returned as the value of a literal expression (section\n" - "@pxref{Literal expressions,,,r4rs, The Revised^4 Report on Scheme}) or\n" - "by a call to the @samp{read} procedure, and its name contains alphabetic\n" - "characters, then the string returned will contain characters in the\n" - "implementation's preferred standard case---some implementations will\n" - "prefer upper case, others lower case. If the symbol was returned by\n" - "@samp{string->symbol}, the case of characters in the string returned\n" - "will be the same as the case in the string that was passed to\n" - "@samp{string->symbol}. It is an error to apply mutation procedures like\n" - "@code{string-set!} to strings returned by this procedure. (r5rs)\n\n" - "The following examples assume that the implementation's standard case is\n" - "lower case:\n\n" - "@format\n" - "@t{(symbol->string 'flying-fish) \n" - " ==> \"flying-fish\"\n" - "(symbol->string 'Martin) ==> \"martin\"\n" + "Returns the name of @var{symbol} as a string. If the symbol\n" + "was part of an object returned as the value of a literal\n" + "expression (section @pxref{Literal expressions,,,r4rs, The\n" + "Revised^4 Report on Scheme}) or by a call to the @code{read}\n" + "procedure, and its name contains alphabetic characters, then\n" + "the string returned will contain characters in the\n" + "implementation's preferred standard case---some implementations\n" + "will prefer upper case, others lower case. If the symbol was\n" + "returned by @code{string->symbol}, the case of characters in\n" + "the string returned will be the same as the case in the string\n" + "that was passed to @code{string->symbol}. It is an error to\n" + "apply mutation procedures like @code{string-set!} to strings\n" + "returned by this procedure. (r5rs)\n\n" + "The following examples assume that the implementation's\n" + "standard case is lower case:\n\n" + "@lisp\n" + "(symbol->string 'flying-fish) @result{} \"flying-fish\"\n" + "(symbol->string 'Martin) @result{} \"martin\"\n" "(symbol->string\n" - " (string->symbol \"Malvina\")) \n" - " ==> \"Malvina\"\n" - "}\n" - "@end format") + " (string->symbol \"Malvina\")) @result{} \"Malvina\"\n" + "@end lisp") #define FUNC_NAME s_scm_symbol_to_string { SCM_VALIDATE_SYMBOL (1, s); @@ -443,31 +443,23 @@ SCM_DEFINE (scm_symbol_to_string, "symbol->string", 1, 0, 0, SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0, (SCM s), - "Returns the symbol whose name is @var{string}. This procedure can\n" - "create symbols with names containing special characters or letters in\n" - "the non-standard case, but it is usually a bad idea to create such\n" - "symbols because in some implementations of Scheme they cannot be read as\n" - "themselves. See @samp{symbol->string}.\n\n" - "The following examples assume that the implementation's standard case is\n" - "lower case:\n\n" -"@format\n" -"@t{(eq? 'mISSISSIppi 'mississippi) \n" -" ==> #t\n" -"(string->symbol \"mISSISSIppi\") \n" -" ==>\n" -" @r{}the symbol with name \"mISSISSIppi\"\n" -"(eq? 'bitBlt (string->symbol \"bitBlt\")) \n" -" ==> #f\n" -"(eq? 'JollyWog\n" -" (string->symbol\n" -" (symbol->string 'JollyWog))) \n" -" ==> #t\n" -"(string=? \"K. Harper, M.D.\"\n" -" (symbol->string\n" -" (string->symbol \"K. Harper, M.D.\"))) \n" -" ==> #t\n" -"}\n" - "@end format") + "Returns the symbol whose name is @var{string}. This procedure\n" + "can create symbols with names containing special characters or\n" + "letters in the non-standard case, but it is usually a bad idea\n" + "to create such because in some implementations of Scheme they\n" + "cannot be read as themselves. See @code{symbol->string}.\n\n" + "The following examples assume that the implementation's\n" + "standard case is lower case:\n\n" + "@lisp\n" + "(eq? 'mISSISSIppi 'mississippi) @result{} #t\n" + "(string->symbol \"mISSISSIppi\") @result{} @r{the symbol with name \"mISSISSIppi\"}\n" + "(eq? 'bitBlt (string->symbol \"bitBlt\")) @result{} #f\n" + "(eq? 'JollyWog\n" + " (string->symbol (symbol->string 'JollyWog))) @result{} #t\n" + "(string=? \"K. Harper, M.D.\"\n" + " (symbol->string\n" + " (string->symbol \"K. Harper, M.D.\"))) @result{}#t\n" + "@end lisp") #define FUNC_NAME s_scm_string_to_symbol { SCM_VALIDATE_STRING (1, s); diff --git a/libguile/vectors.c b/libguile/vectors.c index d55a51cf3..25c7c8a36 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -139,7 +139,8 @@ scm_vector_set_length_x (SCM vect, SCM len) SCM_DEFINE (scm_vector_p, "vector?", 1, 0, 0, (SCM obj), - "Returns @t{#t} if @var{obj} is a vector, otherwise returns @t{#f}. (r5rs)") + "Returns @code{#t} if @var{obj} is a vector, otherwise returns\n" + "@code{#f}. (r5rs)") #define FUNC_NAME s_scm_vector_p { if (SCM_IMP (obj)) @@ -160,24 +161,21 @@ scm_vector_length (SCM v) SCM_REGISTER_PROC (s_list_to_vector, "list->vector", 1, 0, 0, scm_vector); /* - "@samp{List->vector} returns a newly\n" - "created vector initialized to the elements of the list @var{list}.\n\n" - "@format\n" - "@t{(vector->list '#(dah dah didah))\n" - "=> (dah dah didah)\n" - "list->vector '(dididit dah))\n" - "=> #(dididit dah)\n" - "}\n" - "@end format") + "Return a newly created vector initialized to the elements of" + "the list @var{list}.\n\n" + "@lisp\n" + "(vector->list '#(dah dah didah)) @result{} (dah dah didah)\n" + "(list->vector '(dididit dah)) @result{} #(dididit dah)\n" + "@end lisp") */ SCM_DEFINE (scm_vector, "vector", 0, 0, 1, (SCM l), "@deffnx primitive list->vector l\n" - "Returns a newly allocated vector whose elements contain the given\n" - "arguments. Analogous to @samp{list}. (r5rs)\n\n" - "@format\n" - "@t{(vector 'a 'b 'c) ==> #(a b c) }\n" - "@end format") + "Returns a newly allocated vector whose elements contain the\n" + "given arguments. Analogous to @code{list}. (r5rs)\n\n" + "@lisp\n" + "(vector 'a 'b 'c) @result{} #(a b c)\n" + "@end lisp") #define FUNC_NAME s_scm_vector { SCM res; @@ -198,18 +196,14 @@ SCM_GPROC (s_vector_ref, "vector-ref", 2, 0, 0, scm_vector_ref, g_vector_ref); "@var{k} must be a valid index of @var{vector}.\n" "@samp{Vector-ref} returns the contents of element @var{k} of\n" "@var{vector}.\n\n" - "@format\n" - "@t{(vector-ref '#(1 1 2 3 5 8 13 21)\n" - " 5)\n" - " ==> 8\n" + "@lisp\n" + "(vector-ref '#(1 1 2 3 5 8 13 21) 5) @result{} 8\n" "(vector-ref '#(1 1 2 3 5 8 13 21)\n" " (let ((i (round (* 2 (acos -1)))))\n" " (if (inexact? i)\n" " (inexact->exact i)\n" - " i))) \n" - " ==> 13\n" - "}\n" - "@end format" + " i))) @result{} 13\n" + "@end lisp" */ SCM @@ -227,23 +221,15 @@ scm_vector_ref (SCM v, SCM k) SCM_GPROC (s_vector_set_x, "vector-set!", 3, 0, 0, scm_vector_set_x, g_vector_set_x); -/* (r5rs) -@var{k} must be a valid index of @var{vector}. -@samp{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}. -The value returned by @samp{vector-set!} is unspecified. -@c - - -@format -@t{(let ((vec (vector 0 '(2 2 2 2) "Anna"))) - (vector-set! vec 1 '("Sue" "Sue")) - vec) - ==> #(0 ("Sue" "Sue") "Anna") - -(vector-set! '#(0 1 2) 1 "doe") - ==> @emph{error} ; constant vector -} -@end format +/* "@var{k} must be a valid index of @var{vector}.\n" + "@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}.\n" + "The value returned by @samp{vector-set!} is unspecified.\n" + "@lisp\n" + "(let ((vec (vector 0 '(2 2 2 2) "Anna")))\n" + " (vector-set! vec 1 '("Sue" "Sue"))\n" + " vec) @result{} #(0 ("Sue" "Sue") "Anna")\n" + "(vector-set! '#(0 1 2) 1 "doe") @result{} @emph{error} ; constant vector\n" + "@end lisp" */ SCM @@ -318,15 +304,12 @@ scm_c_make_vector (unsigned long int k, SCM fill) SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0, (SCM v), - "@samp{Vector->list} returns a newly allocated list of the objects contained\n" - "in the elements of @var{vector}. (r5rs)\n\n" - "@format\n" - "@t{(vector->list '#(dah dah didah))\n" - "=> (dah dah didah)\n" - "list->vector '(dididit dah))\n" - "=> #(dididit dah)\n" - "}\n" - "@end format") + "@samp{Vector->list} returns a newly allocated list of the\n" + "objects contained in the elements of @var{vector}. (r5rs)\n\n" + "@lisp\n" + "(vector->list '#(dah dah didah)) @result{} (dah dah didah)\n" + "(list->vector '(dididit dah)) @result{} #(dididit dah)\n" + "@end lisp") #define FUNC_NAME s_scm_vector_to_list { SCM res = SCM_EOL; @@ -343,7 +326,7 @@ SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0, SCM_DEFINE (scm_vector_fill_x, "vector-fill!", 2, 0, 0, (SCM v, SCM fill_x), "Stores @var{fill} in every element of @var{vector}.\n" - "The value returned by @samp{vector-fill!} is unspecified. (r5rs)") + "The value returned by @code{vector-fill!} is unspecified. (r5rs)") #define FUNC_NAME s_scm_vector_fill_x { register long i; From eae54bf07262ab5671a7021be17ba1d4c057c9db Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 2 Mar 2001 09:09:06 +0000 Subject: [PATCH 0625/2047] *** empty log message *** --- libguile/ChangeLog | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f2717de71..6d43ac1b0 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,37 @@ +2001-03-02 Martin Grabmueller + + * vectors.c (s_scm_vector_p, list->vector, scm_vector) + (scm_vector_ref, scm_vector_set_x, scm_vector_to_list) + (scm_vector_fill_x), strorder.c (scm_string_equal_p) + (scm_string_ci_equal_p, scm_string_less_p, scm_string_leq_p) + (scm_string_gr_p, scm_string_geq_p, scm_string_ci_less_p) + (scm_string_ci_geq_p), symbols.c (scm_symbol_p) + (scm_symbol_to_string, scm_string_to_symbol): Changed use of @t{} + to @code{} as the texinfo manual recommends, converted the + examples to use a @lisp{}-environment. + + * strports.c (scm_eval_string): Cleaned up the docstring. + + * struct.c (scm_struct_p, scm_struct_vtable_p): Added texinfo + markup. + + * numbers.c (scm_exact_p, scm_odd_p, scm_even_p) + (scm_number_to_string, scm_string_to_number, scm_number_p) + (scm_real_p, scm_integer_p, scm_inexact_p, scm_make_rectangular) + (scm_make_polar, scm_inexact_to_exact): Added texinfo markup. + (scm_ash): Added texinfo markup and removed obsolete @refill. + (scm_gr_p): Corrected comment. + (scm_gr_p, scm_leq_p, scm_geq_p): Added texinfo markup to (future + docstring) comments. + (scm_positive_p, scm_less_p, scm_num_eq_p, scm_real_p) + (scm_number_p, scm_negative_p, scm_max, scm_min, scm_sum) + (scm_difference, scm_product, scm_divide, scm_asinh, scm_acosh) + (scm_atanh, scm_truncate, scm_round, scm_exact_to_inexact) + (floor, ceiling, $sqrt, $abs, $exp, $log, $sin, $cos, $tan, $asin) + ($acos, $atan, $sinh, $cosh, $tanh, scm_real_part, scm_imag_part) + (scm_magnitude, scm_angle, scm_abs, scm_quotient, scm_remainder) + (scm_modulo, scm_gcd, scm_lcm): Added (future docstring) comments. + 2001-02-28 Dirk Herrmann * __scm.h (SCM_ASSERT_TYPE): Add missing macro parameter. From 9e6fc585b28869b547de3f8d460f19d96e85b17e Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 2 Mar 2001 23:41:18 +0000 Subject: [PATCH 0626/2047] Remove dump facilities. --- libguile/ChangeLog | 16 ++++++++++++++++ libguile/Makefile.am | 8 ++++---- libguile/dump.c | 0 libguile/dump.h | 0 libguile/init.c | 2 -- libguile/keywords.c | 23 ----------------------- libguile/smob.c | 14 -------------- libguile/smob.h | 10 ---------- 8 files changed, 20 insertions(+), 53 deletions(-) delete mode 100644 libguile/dump.c delete mode 100644 libguile/dump.h diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6d43ac1b0..ddb33adf4 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,19 @@ +2001-03-02 Keisuke Nishida + + * Remove dump facilities. + * dump.c, dump.h: Removed. + * Makefile.am: Remove dump.c, dump.h, dump.x, dump.doc. + * init.c: Remove #include "libguile/dump.h". + (scm_init_guile_1): Remove scm_init_dump. + * smob.h (scm_smob_descriptor): Remove slots: dump, undump. + (scm_set_smob_dump, scm_set_smob_undump): Remove declaration. + * smob.c (scm_make_smob_type): Remove initialization: dump, undump. + (scm_set_smob_dump, scm_set_smob_undump): Removed. + + * keywords.c: Remove #include "libguile/dump.h". + (keyword_dump, keyword_undump): Removed. + (scm_init_keywords): Remove scm_set_smob_dump and scm_set_smob_undump. + 2001-03-02 Martin Grabmueller * vectors.c (s_scm_vector_p, list->vector, scm_vector) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 0aaad3aaf..350282d61 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -39,7 +39,7 @@ guile_LDADD = libguile.la ${THREAD_LIBS_LOCAL} guile_LDFLAGS = @DLPREOPEN@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ - chars.c continuations.c debug.c dump.c dynl.c dynwind.c \ + chars.c continuations.c debug.c dynl.c dynwind.c \ environments.c eq.c error.c eval.c evalext.c feature.c fluids.c fports.c \ gc.c gc_os_dep.c gdbint.c gh_data.c gh_eval.c gh_funcs.c gh_init.c \ gh_io.c gh_list.c gh_predicates.c goops.c gsubr.c guardians.c hash.c \ @@ -52,7 +52,7 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ variable.c vectors.c version.c vports.c weaks.c DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ - continuations.x debug.x dump.x dynl.x dynwind.x environments.x eq.x \ + continuations.x debug.x dynl.x dynwind.x environments.x eq.x \ error.x eval.x evalext.x feature.x fluids.x fports.x gc.x goops.x \ gsubr.x guardians.x hash.x hashtab.x hooks.x init.x ioext.x iselect.x \ keywords.x lang.x list.x load.x macros.x mallocs.x modules.x net_db.x \ @@ -67,7 +67,7 @@ EXTRA_DOT_X_FILES = debug-malloc.x filesys.x net_db.x posix.x ramap.x \ regex-posix.x socket.x threads.x unif.x DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \ - boolean.doc chars.doc continuations.doc debug.doc dump.doc dynl.doc \ + boolean.doc chars.doc continuations.doc debug.doc dynl.doc \ dynwind.doc environments.doc eq.doc error.doc eval.doc evalext.doc \ feature.doc fluids.doc fports.doc gc.doc goops.doc gsubr.doc \ guardians.doc hash.doc hashtab.doc hooks.doc init.doc ioext.doc \ @@ -112,7 +112,7 @@ pkginclude_HEADERS = gh.h # These are headers visible as . modincludedir = $(includedir)/libguile modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h boolean.h \ - chars.h continuations.h coop-defs.h debug.h debug-malloc.h dump.h \ + chars.h continuations.h coop-defs.h debug.h debug-malloc.h \ dynl.h dynwind.h environments.h eq.h error.h eval.h evalext.h \ feature.h filesys.h fluids.h fports.h gc.h gdb_interface.h gdbint.h \ goops.h gsubr.h guardians.h hash.h hashtab.h hooks.h init.h ioext.h \ diff --git a/libguile/dump.c b/libguile/dump.c deleted file mode 100644 index e69de29bb..000000000 diff --git a/libguile/dump.h b/libguile/dump.h deleted file mode 100644 index e69de29bb..000000000 diff --git a/libguile/init.c b/libguile/init.c index 329f18857..8d3ca5f28 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -66,7 +66,6 @@ #ifdef GUILE_DEBUG_MALLOC #include "libguile/debug-malloc.h" #endif -#include "libguile/dump.h" #include "libguile/dynl.h" #include "libguile/dynwind.h" #include "libguile/environments.h" @@ -494,7 +493,6 @@ scm_init_guile_1 (SCM_STACKITEM *base) #ifdef GUILE_DEBUG_MALLOC scm_init_debug_malloc (); #endif - scm_init_dump (); scm_init_dynwind (); scm_init_eq (); scm_init_error (); diff --git a/libguile/keywords.c b/libguile/keywords.c index d3e9f8c94..8af562ec5 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -51,7 +51,6 @@ #include "libguile/ports.h" #include "libguile/root.h" #include "libguile/smob.h" -#include "libguile/dump.h" #include "libguile/hashtab.h" #include "libguile/validate.h" @@ -68,26 +67,6 @@ keyword_print (SCM exp, SCM port, scm_print_state *pstate) return 1; } -static void -keyword_dump (SCM obj, SCM dstate) -{ - SCM sym = scm_keyword_dash_symbol (obj); - scm_store_string (SCM_SYMBOL_CHARS (sym), - SCM_SYMBOL_LENGTH (sym), - dstate); -} - -static SCM -keyword_undump (SCM dstate) -{ - int len; - const char *mem; - SCM sym; - scm_restore_string (&mem, &len, dstate); - sym = scm_mem2symbol (mem, len); - return scm_make_keyword_from_dash_symbol (sym); -} - SCM_DEFINE (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", 1, 0, 0, (SCM symbol), "Make a keyword object from a @var{symbol} that starts with a dash.") @@ -158,8 +137,6 @@ scm_init_keywords () scm_tc16_keyword = scm_make_smob_type ("keyword", 0); scm_set_smob_mark (scm_tc16_keyword, scm_markcdr); scm_set_smob_print (scm_tc16_keyword, keyword_print); - scm_set_smob_dump (scm_tc16_keyword, keyword_dump); - scm_set_smob_undump (scm_tc16_keyword, keyword_undump); scm_keyword_obarray = scm_c_make_hash_table (256); #ifndef SCM_MAGIC_SNARFER diff --git a/libguile/smob.c b/libguile/smob.c index 104c81ce7..5c859e6d0 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -300,8 +300,6 @@ scm_make_smob_type (char *name, scm_sizet size) scm_smobs[scm_numsmob].apply_2 = 0; scm_smobs[scm_numsmob].apply_3 = 0; scm_smobs[scm_numsmob].gsubr_type = 0; - scm_smobs[scm_numsmob].dump = 0; - scm_smobs[scm_numsmob].undump = 0; scm_numsmob++; } SCM_ALLOW_INTS; @@ -451,18 +449,6 @@ scm_set_smob_apply (scm_bits_t tc, SCM (*apply) (), scm_smobs[SCM_TC2SMOBNUM (tc)].gsubr_type = type; } -void -scm_set_smob_dump (scm_bits_t tc, void (*dump) (SCM, SCM)) -{ - scm_smobs[SCM_TC2SMOBNUM (tc)].dump = dump; -} - -void -scm_set_smob_undump (scm_bits_t tc, SCM (*undump) (SCM)) -{ - scm_smobs[SCM_TC2SMOBNUM (tc)].undump = undump; -} - SCM scm_make_smob (scm_bits_t tc) { diff --git a/libguile/smob.h b/libguile/smob.h index f0a167963..aee18b557 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -53,24 +53,16 @@ typedef struct scm_smob_descriptor { char *name; scm_sizet size; - - /* Basic functions */ SCM (*mark) (SCM); scm_sizet (*free) (SCM); int (*print) (SCM exp, SCM port, scm_print_state *pstate); SCM (*equalp) (SCM, SCM); - - /* Apply functions */ SCM (*apply) (); SCM (*apply_0) (SCM); SCM (*apply_1) (SCM, SCM); SCM (*apply_2) (SCM, SCM, SCM); SCM (*apply_3) (SCM, SCM, SCM, SCM); int gsubr_type; /* Used in procprop.c */ - - /* Dump functions */ - void (*dump) (SCM, SCM); - SCM (*undump) (SCM); } scm_smob_descriptor; @@ -163,8 +155,6 @@ extern void scm_set_smob_apply (scm_bits_t tc, unsigned int req, unsigned int opt, unsigned int rst); -extern void scm_set_smob_dump (scm_bits_t tc, void (*dump) (SCM, SCM)); -extern void scm_set_smob_undump (scm_bits_t tc, SCM (*undump) (SCM)); /* Function for creating smobs */ From bf4aaed27ca93adc575e9f6f2647ecb4dd3e4f45 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 3 Mar 2001 14:58:22 +0000 Subject: [PATCH 0627/2047] * boot-9.scm, rdelim.scm: Use "'()" instead of "()" in all places where the empty list is meant. --- ice-9/boot-9.scm | 2 +- ice-9/rdelim.scm | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index efd330815..2ba387843 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -2745,5 +2745,5 @@ (define-module (guile)) -(append! %load-path (cons "." ())) +(append! %load-path (cons "." '())) diff --git a/ice-9/rdelim.scm b/ice-9/rdelim.scm index 9d961a0af..732163e5d 100644 --- a/ice-9/rdelim.scm +++ b/ice-9/rdelim.scm @@ -95,7 +95,7 @@ (handle-delim (if (pair? args) (car args) 'trim))) - (let loop ((substrings ()) + (let loop ((substrings '()) (total-chars 0) (buf-size 100)) ; doubled each time through. (let* ((buf (make-string buf-size)) From 5280aacabcc96b4178a8c0b02226fa5665324339 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 3 Mar 2001 15:10:37 +0000 Subject: [PATCH 0628/2047] * eval.h (SCM_EVALIM2): New macro. Use it when a immediate, literal constant should be evaluated. * eval.c (scm_s_duplicate_formals): New error message string. (scm_c_improper_memq): New function. (scm_m_lambda): Check for duplicate arguments. (scm_ceval, scm_deval): When executing a body: only cons a new toplevel environment frame when it is different from the existing one; use EVALCAR instead of SIDEVAL so that we can properly check for empty combinations; use SCM_EVALIM2 for the same reason in the non-toplevel loop. (nontoplevel_cdrxnoap, nontoplevel_cdrxbegin, nontoplevel_begin): New labels with the meaning of their non-"nontoplevel" partners, but they are used when it is known that the body is not evaluated at top-level. (scm_apply, scm_dapply): use SCM_EVALIM2 to get proper error reporting for empty combinations. --- libguile/eval.c | 89 ++++++++++++++++++++++++++++++++++--------------- libguile/eval.h | 15 ++++++--- 2 files changed, 73 insertions(+), 31 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index bc9491d6b..549d7b474 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -448,6 +448,7 @@ const char scm_s_bindings[] = "bad bindings"; const char scm_s_variable[] = "bad variable"; const char scm_s_clauses[] = "bad or missing clauses"; const char scm_s_formals[] = "bad formals"; +const char scm_s_duplicate_formals[] = "duplicate formals"; SCM_GLOBAL_SYMBOL (scm_sym_dot, "."); SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>"); @@ -635,6 +636,21 @@ scm_m_cond (SCM xorig, SCM env) SCM_SYNTAX(s_lambda, "lambda", scm_makmmacro, scm_m_lambda); SCM_GLOBAL_SYMBOL(scm_sym_lambda, s_lambda); +/* Return #t if OBJ is `eq?' to one of the elements of LIST or to the + cdr of the last cons. (Thus, LIST is not required to be a proper + list and when OBJ also found in the improper ending.) */ + +static int +scm_c_improper_memq (SCM obj, SCM list) +{ + for (; SCM_CONSP (list); list = SCM_CDR (list)) + { + if (SCM_EQ_P (SCM_CAR (list), obj)) + return SCM_BOOL_T; + } + return SCM_EQ_P (list, obj); +} + SCM scm_m_lambda (SCM xorig, SCM env) { @@ -663,6 +679,8 @@ scm_m_lambda (SCM xorig, SCM env) } if (!SCM_SYMBOLP (SCM_CAR (proc))) goto badforms; + else if (scm_c_improper_memq (SCM_CAR(proc), SCM_CDR(proc))) + scm_wta (xorig, scm_s_duplicate_formals, s_lambda); proc = SCM_CDR (proc); } if (SCM_NNULLP (proc)) @@ -1911,34 +1929,49 @@ dispatch: if (SCM_CONSP(env) && !SCM_CONSP(SCM_CAR(env))) { t.arg1 = x; + { + SCM p = scm_current_module_lookup_closure (); + if (p != SCM_CAR(env)) + env = scm_top_level_env (p); + } while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) { - env = scm_top_level_env (scm_current_module_lookup_closure ()); - SIDEVAL (SCM_CAR(x), env); + EVALCAR (x, env); x = t.arg1; + { + SCM p = scm_current_module_lookup_closure (); + if (p != SCM_CAR(env)) + env = scm_top_level_env (p); + } } - /* once more, for the last form */ - env = scm_top_level_env (scm_current_module_lookup_closure ()); + goto carloop; } else + goto nontoplevel_begin; + + nontoplevel_cdrxnoap: + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + nontoplevel_cdrxbegin: + x = SCM_CDR (x); + nontoplevel_begin: + t.arg1 = x; + while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) { - t.arg1 = x; - while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) + if (SCM_IMP (SCM_CAR (x))) { - if (SCM_IMP (SCM_CAR (x))) + if (SCM_ISYMP (SCM_CAR (x))) { - if (SCM_ISYMP (SCM_CAR (x))) - { - x = scm_m_expand_body (x, env); - goto begin; - } + x = scm_m_expand_body (x, env); + goto nontoplevel_begin; } else - SCM_CEVAL (SCM_CAR (x), env); - x = t.arg1; + SCM_EVALIM2 (SCM_CAR(x)); } + else + SCM_CEVAL (SCM_CAR (x), env); + x = t.arg1; } - + carloop: /* scm_eval car of last form in list */ if (SCM_NCELLP (SCM_CAR (x))) { @@ -2041,7 +2074,7 @@ dispatch: if (SCM_NULLP (x)) RETURN (SCM_UNSPECIFIED); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - goto begin; + goto nontoplevel_begin; case SCM_BIT8(SCM_IM_IF): @@ -2067,7 +2100,7 @@ dispatch: while (SCM_NIMP (proc = SCM_CDR (proc))); env = EXTEND_ENV (SCM_CAR (x), t.arg1, env); x = SCM_CDR (x); - goto cdrxnoap; + goto nontoplevel_cdrxnoap; case SCM_BIT8(SCM_IM_LETREC): @@ -2082,7 +2115,7 @@ dispatch: } while (SCM_NIMP (proc = SCM_CDR (proc))); SCM_SETCDR (SCM_CAR (env), t.arg1); - goto cdrxnoap; + goto nontoplevel_cdrxnoap; case SCM_BIT8(SCM_IM_LETSTAR): @@ -2091,7 +2124,7 @@ dispatch: if (SCM_IMP (proc)) { env = EXTEND_ENV (SCM_EOL, SCM_EOL, env); - goto cdrxnoap; + goto nontoplevel_cdrxnoap; } do { @@ -2100,7 +2133,7 @@ dispatch: env = EXTEND_ENV (t.arg1, EVALCAR (proc, env), env); } while (SCM_NIMP (proc = SCM_CDR (proc))); - goto cdrxnoap; + goto nontoplevel_cdrxnoap; case SCM_BIT8(SCM_IM_OR): x = SCM_CDR (x); @@ -2197,7 +2230,7 @@ dispatch: env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), argl, SCM_ENV (proc)); x = SCM_CODE (proc); - goto cdrxbegin; + goto nontoplevel_cdrxbegin; } proc = scm_f_apply; goto evapply; @@ -2310,7 +2343,7 @@ dispatch: arg2, SCM_CMETHOD_ENV (z)); x = SCM_CMETHOD_CODE (z); - goto cdrxbegin; + goto nontoplevel_cdrxbegin; next_method: i = (i + 1) & mask; } while (i != end); @@ -2631,7 +2664,7 @@ evapply: case scm_tcs_closures: x = SCM_CODE (proc); env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, SCM_ENV (proc)); - goto cdrxbegin; + goto nontoplevel_cdrxbegin; case scm_tcs_cons_gloc: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { @@ -2786,7 +2819,7 @@ evapply: #else env = EXTEND_ENV (SCM_CAR (x), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc)); #endif - goto cdrxbegin; + goto nontoplevel_cdrxbegin; case scm_tcs_cons_gloc: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { @@ -2953,7 +2986,7 @@ evapply: scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc)); #endif x = SCM_CODE (proc); - goto cdrxbegin; + goto nontoplevel_cdrxbegin; } } #ifdef SCM_CAUTIOUS @@ -3031,7 +3064,7 @@ evapply: debug.info->a.args, SCM_ENV (proc)); x = SCM_CODE (proc); - goto cdrxbegin; + goto nontoplevel_cdrxbegin; #else /* DEVAL */ case scm_tc7_subr_3: SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs); @@ -3103,7 +3136,7 @@ evapply: scm_eval_args (x, env, proc)), SCM_ENV (proc)); x = SCM_CODE (proc); - goto cdrxbegin; + goto nontoplevel_cdrxbegin; #endif /* DEVAL */ case scm_tcs_cons_gloc: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) @@ -3443,6 +3476,8 @@ tail: proc = scm_m_expand_body (proc, args); goto again; } + else + SCM_EVALIM2 (SCM_CAR (proc)); } else SCM_CEVAL (SCM_CAR (proc), args); diff --git a/libguile/eval.h b/libguile/eval.h index 880cd5d5b..450a7f754 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -97,14 +97,19 @@ extern SCM scm_eval_options_interface (SCM setting); * * For an explanation of symbols containing "EVAL", see beginning of eval.c. */ +#define SCM_EVALIM2(x) (((x) == SCM_EOL) \ + ? scm_wta ((x), scm_s_expression, NULL) \ + : (x)) #ifdef MEMOIZE_LOCALS -#define SCM_EVALIM(x, env) (SCM_ILOCP (x) ? *scm_ilookup ((x), env) : x) +#define SCM_EVALIM(x, env) (SCM_ILOCP (x) \ + ? *scm_ilookup ((x), env) \ + : SCM_EVALIM2(x)) #else -#define SCM_EVALIM(x, env) x +#define SCM_EVALIM(x, env) SCM_EVALIM2(x) #endif #ifdef DEBUG_EXTENSIONS #define SCM_XEVAL(x, env) (SCM_IMP (x) \ - ? (x) \ + ? SCM_EVALIM2(x) \ : (*scm_ceval_ptr) ((x), (env))) #define SCM_XEVALCAR(x, env) (SCM_NCELLP (SCM_CAR (x)) \ ? (SCM_IMP (SCM_CAR (x)) \ @@ -114,7 +119,9 @@ extern SCM scm_eval_options_interface (SCM setting); ? *scm_lookupcar (x, env, 1) \ : (*scm_ceval_ptr) (SCM_CAR (x), env))) #else -#define SCM_XEVAL(x, env) (SCM_IMP (x) ? (x) : scm_ceval ((x), (env))) +#define SCM_XEVAL(x, env) (SCM_IMP (x) \ + ? SCM_EVALIM2(x) \ + : scm_ceval ((x), (env))) #define SCM_XEVALCAR(x, env) EVALCAR (x, env) #endif /* DEBUG_EXTENSIONS */ From c8e39a67525ac9619304a51822e70d4f8a5ca7cc Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 3 Mar 2001 15:14:18 +0000 Subject: [PATCH 0629/2047] * tests/alist.test: Use "'()" instead of "()" in all places where the empty list is meant. --- test-suite/tests/alist.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test-suite/tests/alist.test b/test-suite/tests/alist.test index 796d3b193..39d676ada 100644 --- a/test-suite/tests/alist.test +++ b/test-suite/tests/alist.test @@ -70,8 +70,8 @@ (if x (cdr x) x))) ;;; Creators, getters -(let ((a (acons 'a 'b (acons 'c 'd (acons 'e 'f ())))) - (b (acons "this" "is" (acons "a" "test" ()))) +(let ((a (acons 'a 'b (acons 'c 'd (acons 'e 'f '())))) + (b (acons "this" "is" (acons "a" "test" '()))) (deformed '(a b c d e f g))) (pass-if "acons" (and (equal? a '((a . b) (c . d) (e . f))) From 2fd945df3442a0a630737dfbc3b7fed64f79960e Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 3 Mar 2001 15:17:05 +0000 Subject: [PATCH 0630/2047] *** empty log message *** --- ice-9/ChangeLog | 5 +++++ libguile/ChangeLog | 22 ++++++++++++++++++++++ test-suite/ChangeLog | 5 +++++ 3 files changed, 32 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index d7cb403ed..ec2063ce7 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2001-03-03 Marius Vollmer + + * boot-9.scm, rdelim.scm: Use "'()" instead of "()" in all places + where the empty list is meant. + 2001-02-26 Mikael Djurfeldt * boot-9.scm (save-stack): Use `primitive-eval' for stack diff --git a/libguile/ChangeLog b/libguile/ChangeLog index ddb33adf4..b95d5426f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,25 @@ +2001-03-03 Marius Vollmer + + * eval.h (SCM_EVALIM2): New macro. Use it when a + immediate, literal constant should be evaluated. + * eval.c (scm_s_duplicate_formals): New error message string. + (scm_c_improper_memq): New function. + (scm_m_lambda): Check for duplicate arguments. + (scm_ceval, scm_deval): When executing a body: only cons a new + toplevel environment frame when it is different from the + existing one; use EVALCAR instead of SIDEVAL so that we can properly + check for empty combinations; use SCM_EVALIM2 for the same reason + in the non-toplevel loop. + (nontoplevel_cdrxnoap, nontoplevel_cdrxbegin, nontoplevel_begin): + New labels with the meaning of their non-"nontoplevel" partners, + but they are used when it is known that the body is not evaluated at + top-level. + (scm_apply, scm_dapply): use SCM_EVALIM2 to get proper error + reporting for empty combinations. + + [ I think I recovered the lost performance with this. I will + further clean this up soon, too. ] + 2001-03-02 Keisuke Nishida * Remove dump facilities. diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index e69a9af32..2f5dc5da0 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2001-03-03 Marius Vollmer + + * tests/alist.test: Use "'()" instead of "()" in all places + where the empty list is meant. + 2001-03-01 Dirk Herrmann * lib.scm (exception:unbound-var, exception:wrong-num-args): New From d9d39d76e7022886c596d5db2c42e5cd178e2768 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 3 Mar 2001 17:24:51 +0000 Subject: [PATCH 0631/2047] Cosmetic cleanups. --- libguile/eval.c | 28 ++++++++++++++++------------ 1 file changed, 16 insertions(+), 12 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index 549d7b474..13ea0c02a 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1771,6 +1771,16 @@ scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc) /* SECTION: Some local definitions for the evaluator. */ +/* Update the toplevel environment frame ENV so that it refers to the + current module. +*/ +#define UPDATE_TOPLEVEL_ENV(env) \ + do { \ + SCM p = scm_current_module_lookup_closure (); \ + if (p != SCM_CAR(env)) \ + env = scm_top_level_env (p); \ + } while (0) + #ifndef DEVAL #define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B))))) #endif /* DEVAL */ @@ -1918,9 +1928,11 @@ dispatch: goto carloop; case SCM_BIT8(SCM_IM_BEGIN): - cdrxnoap: + /* (currently unused) + cdrxnoap: */ PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - cdrxbegin: + /* (currently unused) + cdrxbegin: */ x = SCM_CDR (x); begin: @@ -1929,20 +1941,12 @@ dispatch: if (SCM_CONSP(env) && !SCM_CONSP(SCM_CAR(env))) { t.arg1 = x; - { - SCM p = scm_current_module_lookup_closure (); - if (p != SCM_CAR(env)) - env = scm_top_level_env (p); - } + UPDATE_TOPLEVEL_ENV (env); while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) { EVALCAR (x, env); x = t.arg1; - { - SCM p = scm_current_module_lookup_closure (); - if (p != SCM_CAR(env)) - env = scm_top_level_env (p); - } + UPDATE_TOPLEVEL_ENV (env); } goto carloop; } From 14fe4fe9ce00c27426f9aa411fa777269f922926 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 3 Mar 2001 17:25:22 +0000 Subject: [PATCH 0632/2047] *** empty log message *** --- NEWS | 5 +++++ libguile/ChangeLog | 3 --- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/NEWS b/NEWS index 6666ae5fd..abdda6164 100644 --- a/NEWS +++ b/NEWS @@ -113,6 +113,11 @@ This module requires SLIB to be installed and available from Guile. * Changes to the stand-alone interpreter +** Evaluation of "()", the empty list, is now an error. + +Previously, you could for example write (cons 1 ()); now you need to +be more explicit and write (cons 1 '()). + ** It's now possible to create modules with controlled environments Example: diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b95d5426f..560d8d53c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -17,9 +17,6 @@ (scm_apply, scm_dapply): use SCM_EVALIM2 to get proper error reporting for empty combinations. - [ I think I recovered the lost performance with this. I will - further clean this up soon, too. ] - 2001-03-02 Keisuke Nishida * Remove dump facilities. From 1c54a87cb24661d21b371d4f4eb88fef23d7ac1b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 3 Mar 2001 17:29:09 +0000 Subject: [PATCH 0633/2047] * tests/syntax.test ("duplicate formals"): New category, move appropriate tests here. Expect them to pass. ("empty parentheses"): Expect to pass, bug has been fixed. --- test-suite/tests/syntax.test | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 550f7fa82..d2000195c 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -24,6 +24,8 @@ (cons 'misc-error "^bad body")) (define exception:bad-formals (cons 'misc-error "^bad formals")) +(define exception:duplicate-formals + (cons 'misc-error "^duplicate formals")) (define exception:bad-var (cons 'misc-error "^bad variable")) (define exception:bad/missing-clauses @@ -41,7 +43,9 @@ ;; is a legitimate expression. In Scheme, combinations must ;; have at least one subexpression, so () is not a syntactically ;; valid expression. - (expect-fail-exception "empty parentheses \"()\"" + + ;; Fixed on 2001-3-3 + (pass-if-exception "empty parentheses \"()\"" exception:missing/extra-expr ()))) @@ -63,14 +67,18 @@ (pass-if-exception "(lambda (\"a\" x) 2)" exception:bad-formals - (lambda ("a" x) 2)) + (lambda ("a" x) 2))) - (expect-fail-exception "(lambda (x x) 1)" - exception:bad-formals + (with-test-prefix "duplicate formals" + + ;; Fixed on 2001-3-3 + (pass-if-exception "(lambda (x x) 1)" + exception:duplicate-formals (lambda (x x) 1)) - (expect-fail-exception "(lambda (x x x) 1)" - exception:bad-formals + ;; Fixed on 2001-3-3 + (pass-if-exception "(lambda (x x x) 1)" + exception:duplicate-formals (lambda (x x x) 1)))) (with-test-prefix "let" From 97d41e3e07597eb2ffffd2f143ec813a7a1a4bb8 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 3 Mar 2001 17:30:52 +0000 Subject: [PATCH 0634/2047] *** empty log message *** --- test-suite/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 2f5dc5da0..67b74d381 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,5 +1,9 @@ 2001-03-03 Marius Vollmer + * tests/syntax.test ("duplicate formals"): New category, move + appropriate tests here. Expect them to pass. + ("empty parentheses"): Expect to pass, bug has been fixed. + * tests/alist.test: Use "'()" instead of "()" in all places where the empty list is meant. @@ -19,6 +23,7 @@ related to evaluation and application to tests/eval.test. * tests/exceptions.test: Added some test cases that check guile's + exception handling. 2001-03-01 Dirk Herrmann From 0109c4bf4952ad164c33cfc9054fe39c23e6c448 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sat, 3 Mar 2001 19:43:35 +0000 Subject: [PATCH 0635/2047] * stack-catch.scm: New file. * Makefile.am (ice9_sources): Added stack-catch.scm. --- NEWS | 6 ++++++ ice-9/ChangeLog | 6 ++++++ ice-9/Makefile.am | 10 +++++----- ice-9/stack-catch.scm | 46 +++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 63 insertions(+), 5 deletions(-) create mode 100644 ice-9/stack-catch.scm diff --git a/NEWS b/NEWS index abdda6164..51bfe1887 100644 --- a/NEWS +++ b/NEWS @@ -8,6 +8,12 @@ Changes since Guile 1.4: * Changes to the distribution +** New module (ice-9 stack-catch): + +stack-catch is like catch, but saves the current state of the stack in +the the-last-stack fluid for the debugger to inspect or in able to +re-throw an error. + ** The module (ice-9 and-let*) has been renamed to (ice-9 and-let-star) This has been done to prevent problems on lesser operating systems diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index ec2063ce7..cde7a3739 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,9 @@ +2001-03-03 Mikael Djurfeldt + + * stack-catch.scm: New file. + + * Makefile.am (ice9_sources): Added stack-catch.scm. + 2001-03-03 Marius Vollmer * boot-9.scm, rdelim.scm: Use "'()" instead of "()" in all places diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index d2ad1ee3b..597124072 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -1,6 +1,6 @@ ## Process this file with automake to produce Makefile.in. ## -## Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. +## Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -26,11 +26,11 @@ ice9_sources = \ and-let-star.scm arrays.scm boot-9.scm calling.scm common-list.scm \ debug.scm debugger.scm documentation.scm emacs.scm expect.scm \ format.scm getopt-long.scm hcons.scm lineio.scm ls.scm mapping.scm \ - match.scm networking.scm null.scm optargs.scm poe.scm popen.scm \ + match.scm networking.scm null.scm optargs.scm poe.scm popen.scm \ posix.scm psyntax.pp psyntax.ss q.scm r4rs.scm r5rs.scm \ - rdelim.scm receive.scm srfi-8.scm \ - regex.scm runq.scm safe-r5rs.scm safe.scm session.scm slib.scm \ - streams.scm string-fun.scm syncase.scm tags.scm threads.scm + rdelim.scm receive.scm srfi-8.scm regex.scm runq.scm \ + safe-r5rs.scm safe.scm session.scm slib.scm stack-catch.scm \ + streams.scm string-fun.scm syncase.scm tags.scm threads.scm subpkgdatadir = $(pkgdatadir)/$(VERSION)/ice-9 subpkgdata_DATA = $(ice9_sources) diff --git a/ice-9/stack-catch.scm b/ice-9/stack-catch.scm new file mode 100644 index 000000000..ff160f7b0 --- /dev/null +++ b/ice-9/stack-catch.scm @@ -0,0 +1,46 @@ +;;; installed-scm-file + +;;;; Copyright (C) 2001 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; + +(define-module (ice-9 stack-catch) + :export (stack-catch)) + +(define (stack-catch key thunk handler) + "Like @code{catch}, invoke @var{thunk} in the dynamic context of +@var{handler} for exceptions matching @var{key}, but also save the +current stack state in the @var{the-last-stack} fluid, for the purpose +of debugging or re-throwing of an error. If thunk throws to the +symbol @var{key}, then @var{handler} is invoked this way:\n +@example +(handler key args ...) +@end example\n +@var{key} is a symbol or #t.\n +@var{thunk} takes no arguments. If @var{thunk} returns normally, that +is the return value of @code{catch}.\n +Handler is invoked outside the scope of its own @code{catch}. If +@var{handler} again throws to the same key, a new handler from further +up the call chain is invoked.\n +If the key is @code{#t}, then a throw to @emph{any} symbol will match +this call to @code{catch}." + (catch key + (lambda () + (lazy-catch key + thunk + lazy-handler-dispatch)) + handler)) From 185ab0ef1050a0d1271061cabe9816c3b8a65b01 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 3 Mar 2001 23:52:57 +0000 Subject: [PATCH 0636/2047] * eval.c (scm_s_duplicate_bindings): New error message. (scm_m_letrec1, scm_m_letstar): Check for duplicate bindings. --- libguile/eval.c | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/libguile/eval.c b/libguile/eval.c index 13ea0c02a..f9ed72ffc 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -445,6 +445,7 @@ const char scm_s_expression[] = "missing or extra expression"; const char scm_s_test[] = "bad test"; const char scm_s_body[] = "bad body"; const char scm_s_bindings[] = "bad bindings"; +const char scm_s_duplicate_bindings[] = "duplicate bindings"; const char scm_s_variable[] = "bad variable"; const char scm_s_clauses[] = "bad or missing clauses"; const char scm_s_formals[] = "bad formals"; @@ -711,6 +712,8 @@ scm_m_letstar (SCM xorig, SCM env) arg1 = SCM_CAR (proc); SCM_ASSYNT (2 == scm_ilength (arg1), xorig, scm_s_bindings, s_letstar); SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), xorig, scm_s_variable, s_letstar); + if (scm_c_improper_memq (SCM_CAR (arg1), vars)) + scm_wta (xorig, scm_s_duplicate_bindings, s_letstar); *varloc = scm_cons2 (SCM_CAR (arg1), SCM_CAR (SCM_CDR (arg1)), SCM_EOL); varloc = SCM_CDRLOC (SCM_CDR (*varloc)); proc = SCM_CDR (proc); @@ -916,6 +919,8 @@ scm_m_letrec1 (SCM op, SCM imm, SCM xorig, SCM env) arg1 = SCM_CAR (proc); SCM_ASSYNT (2 == scm_ilength (arg1), xorig, scm_s_bindings, what); SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), xorig, scm_s_variable, what); + if (scm_c_improper_memq (SCM_CAR (arg1), vars)) + scm_wta (xorig, scm_s_duplicate_bindings, what); vars = scm_cons (SCM_CAR (arg1), vars); *initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL); initloc = SCM_CDRLOC (*initloc); @@ -970,7 +975,7 @@ scm_m_let (SCM xorig, SCM env) } SCM_ASSYNT (SCM_NIMP (proc), xorig, scm_s_bindings, s_let); - if (SCM_CONSP (proc)) + if (SCM_CONSP (proc)) { /* plain let, proc is */ return scm_m_letrec1 (SCM_IM_LET, SCM_IM_LET, xorig, env); From c0ed1605f13ba7a9352682eb7b24bb496160d70b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 3 Mar 2001 23:54:42 +0000 Subject: [PATCH 0637/2047] * tests/syntax.test ("let,duplicate bindings", "let*,duplicate bindings", "letrec,duplicate bindings"): Expect to pass, bug has been fixed. --- test-suite/tests/syntax.test | 36 +++++++++++++++++++++++++++--------- 1 file changed, 27 insertions(+), 9 deletions(-) diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index d2000195c..a1d3c6269 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -20,6 +20,8 @@ (define exception:bad-bindings (cons 'misc-error "^bad bindings")) +(define exception:duplicate-bindings + (cons 'misc-error "^duplicate bindings")) (define exception:bad-body (cons 'misc-error "^bad body")) (define exception:bad-formals @@ -100,16 +102,19 @@ (let ((x 1)))) ;; FIXME: Wouldn't one rather expect a 'bad bindings' error? + ;; Hmm, the body is bad as well, isn't it? (pass-if-exception "(let)" exception:bad-body (let)) ;; FIXME: Wouldn't one rather expect a 'bad bindings' error? + ;; Hmm, the body is bad as well, isn't it? (pass-if-exception "(let 1)" exception:bad-body (let 1)) ;; FIXME: Wouldn't one rather expect a 'bad bindings' error? + ;; Hmm, the body is bad as well, isn't it? (pass-if-exception "(let (x))" exception:bad-body (let (x)))) @@ -130,10 +135,12 @@ (pass-if-exception "(let ((1 2)) 3)" exception:bad-var - (let ((1 2)) 3)) + (let ((1 2)) 3))) - (expect-fail-exception "(let ((x 1) (x 2)) x)" - exception:bad-bindings + (with-test-prefix "duplicate bindings" + + (pass-if-exception "(let ((x 1) (x 2)) x)" + exception:duplicate-bindings (let ((x 1) (x 2)) x)))) (with-test-prefix "named let" @@ -149,6 +156,7 @@ (let x ((y 1)))) ;; FIXME: Wouldn't one rather expect a 'bad bindings' error? + ;; Hmm, the body is bad as well, isn't it? (pass-if-exception "(let x (y))" exception:bad-body (let x (y))))) @@ -166,16 +174,19 @@ (let* ((x 1)))) ;; FIXME: Wouldn't one rather expect a 'bad bindings' error? + ;; Hmm, the body is bad as well, isn't it? (pass-if-exception "(let*)" exception:bad-body (let*)) ;; FIXME: Wouldn't one rather expect a 'bad bindings' error? + ;; Hmm, the body is bad as well, isn't it? (pass-if-exception "(let* 1)" exception:bad-body (let* 1)) ;; FIXME: Wouldn't one rather expect a 'bad bindings' error? + ;; Hmm, the body is bad as well, isn't it? (pass-if-exception "(let* (x))" exception:bad-body (let* (x)))) @@ -204,10 +215,12 @@ (pass-if-exception "(let* ((1 2)) 3)" exception:bad-var - (let* ((1 2)) 3)) + (let* ((1 2)) 3))) - (expect-fail-exception "(let* ((x 1) (x 2)) x)" - exception:bad-bindings + (with-test-prefix "duplicate bindings" + + (pass-if-exception "(let* ((x 1) (x 2)) x)" + exception:duplicate-bindings (let* ((x 1) (x 2)) x)))) (with-test-prefix "letrec" @@ -230,16 +243,19 @@ (letrec ((x 1)))) ;; FIXME: Wouldn't one rather expect a 'bad bindings' error? + ;; Hmm, the body is bad as well, isn't it? (pass-if-exception "(letrec)" exception:bad-body (letrec)) ;; FIXME: Wouldn't one rather expect a 'bad bindings' error? + ;; Hmm, the body is bad as well, isn't it? (pass-if-exception "(letrec 1)" exception:bad-body (letrec 1)) ;; FIXME: Wouldn't one rather expect a 'bad bindings' error? + ;; Hmm, the body is bad as well, isn't it? (pass-if-exception "(letrec (x))" exception:bad-body (letrec (x)))) @@ -268,10 +284,12 @@ (pass-if-exception "(letrec ((1 2)) 3)" exception:bad-var - (letrec ((1 2)) 3)) + (letrec ((1 2)) 3))) - (expect-fail-exception "(letrec ((x 1) (x 2)) x)" - exception:bad-bindings + (with-test-prefix "duplicate bindings" + + (pass-if-exception "(letrec ((x 1) (x 2)) x)" + exception:duplicate-bindings (letrec ((x 1) (x 2)) x)))) (with-test-prefix "if" From d19b0aac73f37ff63e34598f3ae936e2b4e86ae1 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 3 Mar 2001 23:56:28 +0000 Subject: [PATCH 0638/2047] *** empty log message *** --- libguile/ChangeLog | 5 +++++ test-suite/ChangeLog | 6 ++++++ 2 files changed, 11 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 560d8d53c..dda0b491f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-03-04 Marius Vollmer + + * eval.c (scm_s_duplicate_bindings): New error message. + (scm_m_letrec1, scm_m_letstar): Check for duplicate bindings. + 2001-03-03 Marius Vollmer * eval.h (SCM_EVALIM2): New macro. Use it when a diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 67b74d381..e34d372ee 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,9 @@ +2001-03-04 Marius Vollmer + + * tests/syntax.test ("let,duplicate bindings", "let*,duplicate + bindings", "letrec,duplicate bindings"): Expect to pass, bug has + been fixed. + 2001-03-03 Marius Vollmer * tests/syntax.test ("duplicate formals"): New category, move From 87e7741df723f18cf3f6ef56cf7bb258146e9ba2 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 4 Mar 2001 05:27:41 +0000 Subject: [PATCH 0639/2047] * goops.c (scm_sys_pre_expand_closure_x): New procedure. --- libguile/ChangeLog | 4 ++++ libguile/goops.c | 19 ++++++++++++++++++- libguile/goops.h | 5 +++-- 3 files changed, 25 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index dda0b491f..3c8af2027 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2001-03-04 Mikael Djurfeldt + + * goops.c (scm_sys_pre_expand_closure_x): New procedure. + 2001-03-04 Marius Vollmer * eval.c (scm_s_duplicate_bindings): New error message. diff --git a/libguile/goops.c b/libguile/goops.c index 02c0acf33..d42ff2b51 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1998, 1999, 2000, 2001 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 @@ -934,6 +934,23 @@ SCM_DEFINE (scm_accessor_method_slot_definition, "accessor-method-slot-definitio } #undef FUNC_NAME +SCM_DEFINE (scm_sys_pre_expand_closure_x, "%pre-expand-closure!", 1, 0, 0, + (SCM closure), + "Internal GOOPS magic---don't use this function!") +#define FUNC_NAME s_scm_sys_pre_expand_closure_x +{ + SCM formals, code, env; + SCM_VALIDATE_CLOSURE (1, closure); + formals = SCM_CAR (SCM_CODE (closure)); + env = SCM_EXTEND_ENV (formals, formals, SCM_ENV (closure)); + code = SCM_CDR (SCM_CODE (closure)); + while (SCM_NNULLP (SCM_CDR (code)) + && SCM_IMP (SCM_CAR (code)) + && SCM_ISYMP (SCM_CAR (code))) + code = scm_m_expand_body (code, env); + return closure; +} +#undef FUNC_NAME /****************************************************************************** * diff --git a/libguile/goops.h b/libguile/goops.h index 3c123c80b..a443d4cc0 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -2,7 +2,7 @@ #ifndef GOOPSH #define GOOPSH -/* Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1998, 1999, 2000, 2001 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 @@ -257,7 +257,8 @@ SCM scm_generic_function_methods (SCM obj); SCM scm_method_generic_function (SCM obj); SCM scm_method_specializers (SCM obj); SCM scm_method_procedure (SCM obj); -SCM scm_accessor_method_slot_definition (SCM obj); +SCM scm_accessor_method_slot_definition (SCM obj); +SCM scm_sys_pre_expand_closure_x (SCM closure); SCM scm_sys_fast_slot_ref (SCM obj, SCM index); SCM scm_sys_fast_slot_set_x (SCM obj, SCM index, SCM value); SCM scm_slot_ref_using_class (SCM cls, SCM obj, SCM slot_name); From cc6c7feea443b5d5f95d2cc88e0b244ccf15b373 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 4 Mar 2001 05:28:21 +0000 Subject: [PATCH 0640/2047] * goops.scm (change-object-class): Quote empty list constants. (method): Reverted previous change (enclosing body); Quote empty list. (initialize ): Pre-expand the method closure. --- oop/ChangeLog | 7 +++++++ oop/goops.scm | 17 ++++++++++------- 2 files changed, 17 insertions(+), 7 deletions(-) diff --git a/oop/ChangeLog b/oop/ChangeLog index 09dae3c64..b071f5019 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -1,3 +1,10 @@ +2001-03-04 Mikael Djurfeldt + + * goops.scm (change-object-class): Quote empty list constants. + (method): Reverted previous change (enclosing body); + Quote empty list. + (initialize ): Pre-expand the method closure. + 2001-02-23 Keisuke Nishida * goops.scm (method): Enclosed BODY by `(let () ...)'. diff --git a/oop/goops.scm b/oop/goops.scm index b2405b283..a0af2b9bf 100644 --- a/oop/goops.scm +++ b/oop/goops.scm @@ -1,6 +1,6 @@ ;;; installed-scm-file -;;;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. +;;;; Copyright (C) 1998, 1999, 2000, 2001 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 @@ -468,7 +468,7 @@ (define method (letrec ((specializers (lambda (ls) - (cond ((null? ls) (list ls)) + (cond ((null? ls) '('())) ((pair? ls) (cons (if (pair? (car ls)) (cadar ls) ') @@ -487,9 +487,9 @@ `(make #:specializers (list* ,@(specializers args)) #:procedure (lambda ,(formals args) - ,(if (null? body) - *unspecified* - `(let () ,@body))))))))) + ,@(if (null? body) + (list *unspecified*) + body)))))))) ;;; ;;; {add-method!} @@ -1318,7 +1318,10 @@ (next-method) (slot-set! method 'generic-function (get-keyword #:generic-function initargs #f)) (slot-set! method 'specializers (get-keyword #:specializers initargs '())) - (slot-set! method 'procedure (get-keyword #:procedure initargs (lambda l '()))) + (slot-set! method + 'procedure + (%pre-expand-closure! + (get-keyword #:procedure initargs (lambda l '())))) (slot-set! method 'code-table '())) (define-method initialize ((obj ) initargs)) @@ -1328,7 +1331,7 @@ ;;; (define (change-object-class old-instance old-class new-class) - (let ((new-instance (allocate-instance new-class ()))) + (let ((new-instance (allocate-instance new-class '()))) ;; Initalize the slot of the new instance (for-each (lambda (slot) (if (and (slot-exists-using-class? old-class old-instance slot) From db4b4ca64f0480198cbc82e0f6fb3d3a8af5f580 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sun, 4 Mar 2001 17:09:34 +0000 Subject: [PATCH 0641/2047] * Eliminate some calls to scm_wta. --- libguile/ChangeLog | 13 +++++++++++++ libguile/continuations.c | 9 +++++++-- libguile/eval.c | 12 ++++++------ libguile/eval.h | 2 +- libguile/evalext.c | 3 ++- libguile/gc.c | 9 ++++++--- libguile/goops.c | 2 +- libguile/options.c | 3 ++- libguile/ports.c | 5 ++++- libguile/ramap.c | 2 +- libguile/read.c | 25 +++++++++++++++++-------- libguile/script.c | 26 +++++++++++++------------- libguile/unif.c | 5 ++++- 13 files changed, 77 insertions(+), 39 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 3c8af2027..83d86343c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,16 @@ +2001-03-04 Dirk Herrmann + + * continuations.c (continuation_apply), eval.c (scm_m_lambda, + scm_m_letstar, scm_m_letrec1, scm_m_let, SCM_APPLY), eval.h + (SCM_EVALIM2), evalext.c (scm_m_generalized_set_x), gc.c + (get_bvec, MARK), goops.c (scm_primitive_generic_generic), + options.c (scm_options), ports.c (scm_remove_from_port_table), + ramap.c (scm_ramapc), read.c (skip_scsh_block_comment, scm_lreadr, + scm_lreadparen, scm_lreadrecparen), script.c (script_get_octal, + script_get_backslash, script_read_arg), unif.c (scm_cvref): Don't + call function scm_wta, call scm_misc_error or scm_wrong_type_arg + instead. + 2001-03-04 Mikael Djurfeldt * goops.c (scm_sys_pre_expand_closure_x): New procedure. diff --git a/libguile/continuations.c b/libguile/continuations.c index ee1e7cb77..3b07e1f06 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -59,6 +59,7 @@ #include "libguile/debug.h" #endif +#include "libguile/validate.h" #include "libguile/continuations.h" @@ -219,8 +220,10 @@ scm_dynthrow (SCM cont, SCM val) copy_stack_and_call (continuation, val, dst); } + +static SCM +continuation_apply (SCM cont, SCM args) #define FUNC_NAME "continuation_apply" -static SCM continuation_apply (SCM cont, SCM args) { scm_contregs *continuation = SCM_CONTREGS (cont); scm_contregs *rootcont = SCM_CONTREGS (scm_rootcont); @@ -229,7 +232,8 @@ static SCM continuation_apply (SCM cont, SCM args) /* this base comparison isn't needed */ || continuation->base != rootcont->base) { - scm_wta (cont, "continuation from wrong top level", FUNC_NAME); + SCM_MISC_ERROR ("continuation from wrong top level: ~S", + SCM_LIST1 (cont)); } scm_dowinds (continuation->dynenv, @@ -241,6 +245,7 @@ static SCM continuation_apply (SCM cont, SCM args) } #undef FUNC_NAME + void scm_init_continuations () { diff --git a/libguile/eval.c b/libguile/eval.c index f9ed72ffc..90ba9973b 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -681,13 +681,13 @@ scm_m_lambda (SCM xorig, SCM env) if (!SCM_SYMBOLP (SCM_CAR (proc))) goto badforms; else if (scm_c_improper_memq (SCM_CAR(proc), SCM_CDR(proc))) - scm_wta (xorig, scm_s_duplicate_formals, s_lambda); + scm_misc_error (s_lambda, scm_s_duplicate_formals, SCM_EOL); proc = SCM_CDR (proc); } if (SCM_NNULLP (proc)) { badforms: - scm_wta (xorig, scm_s_formals, s_lambda); + scm_misc_error (s_lambda, scm_s_formals, SCM_EOL); } memlambda: @@ -713,7 +713,7 @@ scm_m_letstar (SCM xorig, SCM env) SCM_ASSYNT (2 == scm_ilength (arg1), xorig, scm_s_bindings, s_letstar); SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), xorig, scm_s_variable, s_letstar); if (scm_c_improper_memq (SCM_CAR (arg1), vars)) - scm_wta (xorig, scm_s_duplicate_bindings, s_letstar); + scm_misc_error (s_letstar, scm_s_duplicate_bindings, SCM_EOL); *varloc = scm_cons2 (SCM_CAR (arg1), SCM_CAR (SCM_CDR (arg1)), SCM_EOL); varloc = SCM_CDRLOC (SCM_CDR (*varloc)); proc = SCM_CDR (proc); @@ -920,7 +920,7 @@ scm_m_letrec1 (SCM op, SCM imm, SCM xorig, SCM env) SCM_ASSYNT (2 == scm_ilength (arg1), xorig, scm_s_bindings, what); SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), xorig, scm_s_variable, what); if (scm_c_improper_memq (SCM_CAR (arg1), vars)) - scm_wta (xorig, scm_s_duplicate_bindings, what); + scm_misc_error (what, scm_s_duplicate_bindings, SCM_EOL); vars = scm_cons (SCM_CAR (arg1), vars); *initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL); initloc = SCM_CDRLOC (*initloc); @@ -982,7 +982,7 @@ scm_m_let (SCM xorig, SCM env) } if (!SCM_SYMBOLP (proc)) - scm_wta (xorig, scm_s_bindings, s_let); /* bad let */ + scm_misc_error (s_let, scm_s_bindings, SCM_EOL); /* bad let */ name = proc; /* named let, build equiv letrec */ x = SCM_CDR (x); SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_body, s_let); @@ -3559,7 +3559,7 @@ tail: scm_wrong_num_args (proc); default: badproc: - scm_wta (proc, (char *) SCM_ARG1, "apply"); + scm_wrong_type_arg ("apply", SCM_ARG1, proc); RETURN (arg1); } #ifdef DEVAL diff --git a/libguile/eval.h b/libguile/eval.h index 450a7f754..0db28526f 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -98,7 +98,7 @@ extern SCM scm_eval_options_interface (SCM setting); * For an explanation of symbols containing "EVAL", see beginning of eval.c. */ #define SCM_EVALIM2(x) (((x) == SCM_EOL) \ - ? scm_wta ((x), scm_s_expression, NULL) \ + ? scm_misc_error (NULL, scm_s_expression, SCM_EOL), 0 \ : (x)) #ifdef MEMOIZE_LOCALS #define SCM_EVALIM(x, env) (SCM_ILOCP (x) \ diff --git a/libguile/evalext.c b/libguile/evalext.c index b9e0130c3..d24a543be 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -65,7 +65,8 @@ scm_m_generalized_set_x (SCM xorig, SCM env) else if (SCM_CONSP (SCM_CAR (x))) return scm_cons (SCM_LIST2 (scm_sym_setter, SCM_CAAR (x)), scm_append (SCM_LIST2 (SCM_CDAR (x), SCM_CDR (x)))); - return scm_wta (xorig, scm_s_variable, scm_s_set_x); + else + scm_misc_error (scm_s_set_x, scm_s_variable, SCM_EOL); } SCM_DEFINE (scm_definedp, "defined?", 1, 1, 0, diff --git a/libguile/gc.c b/libguile/gc.c index 60aaad34f..038822a50 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -408,6 +408,7 @@ static scm_mark_space_t *mark_space_head; static scm_c_bvec_limb_t * get_bvec () +#define FUNC_NAME "get_bvec" { scm_c_bvec_limb_t *res; @@ -415,7 +416,7 @@ get_bvec () { SCM_SYSCALL (current_mark_space = (scm_mark_space_t *) malloc (sizeof (scm_mark_space_t))); if (!current_mark_space) - scm_wta (SCM_UNDEFINED, "could not grow", "heap"); + SCM_MISC_ERROR ("could not grow heap", SCM_EOL); current_mark_space->bvec_space = NULL; current_mark_space->next = NULL; @@ -431,7 +432,7 @@ get_bvec () SCM_SYSCALL (current_mark_space->bvec_space = (scm_c_bvec_limb_t *) calloc (BVEC_GROW_SIZE_IN_BYTES, 1)); if (!(current_mark_space->bvec_space)) - scm_wta (SCM_UNDEFINED, "could not grow", "heap"); + SCM_MISC_ERROR ("could not grow heap", SCM_EOL); current_mark_space_offset = 0; @@ -450,6 +451,8 @@ get_bvec () return res; } +#undef FUNC_NAME + static void clear_mark_space () @@ -1143,7 +1146,7 @@ gc_mark_loop_first_time: #if (defined (GUILE_DEBUG_FREELIST)) if (SCM_GC_IN_CARD_HEADERP (SCM2PTR (ptr))) - scm_wta (ptr, "rogue pointer in heap", NULL); + SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL); #endif diff --git a/libguile/goops.c b/libguile/goops.c index d42ff2b51..e4dff3da8 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1644,7 +1644,7 @@ SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0, if (gf) return gf; } - return scm_wta (subr, (char *) SCM_ARG1, FUNC_NAME); + SCM_WRONG_TYPE_ARG (SCM_ARG1, subr); } #undef FUNC_NAME diff --git a/libguile/options.c b/libguile/options.c index 94e74d573..5bd622d30 100644 --- a/libguile/options.c +++ b/libguile/options.c @@ -190,7 +190,8 @@ scm_options (SCM arg, scm_option options[], int n, const char *s) } #ifndef SCM_RECKLESS scm_must_free ((char *) flags); - scm_wta (SCM_CAR (new_mode), "Unknown mode flag", s); + scm_misc_error (s, "Unknown mode flag: ~S", + SCM_LIST1 (SCM_CAR (new_mode))); #endif cont: new_mode = SCM_CDR (new_mode); diff --git a/libguile/ports.c b/libguile/ports.c index fd7362031..f0111671e 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -468,12 +468,13 @@ scm_add_to_port_table (SCM port) void scm_remove_from_port_table (SCM port) +#define FUNC_NAME "scm_remove_from_port_table" { scm_port *p = SCM_PTAB_ENTRY (port); int i = p->entry; if (i >= scm_port_table_size) - scm_wta (port, "Port not in table", "scm_remove_from_port_table"); + SCM_MISC_ERROR ("Port not in table: ~S", SCM_LIST1 (port)); if (p->putback_buf) free (p->putback_buf); free (p); @@ -487,6 +488,8 @@ scm_remove_from_port_table (SCM port) SCM_SETPTAB_ENTRY (port, 0); scm_port_table_size--; } +#undef FUNC_NAME + #ifdef GUILE_DEBUG /* Functions for debugging. */ diff --git a/libguile/ramap.c b/libguile/ramap.c index 1db100b0d..7ef09128d 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -329,7 +329,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) { default: case 0: - scm_wta (ra0, "array shape mismatch", what); + scm_misc_error (what, "array shape mismatch: ~S", ra0); case 2: case 3: case 4: /* Try unrolling arrays */ diff --git a/libguile/read.c b/libguile/read.c index 616134724..473562a35 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -255,6 +255,7 @@ recsexpr (SCM obj,int line,int column,SCM filename) static void skip_scsh_block_comment (SCM port) +#define FUNC_NAME "skip_scsh_block_comment" { /* Is this portable? Dear God, spare me from the non-eight-bit characters. But is it tasteful? */ @@ -265,8 +266,7 @@ skip_scsh_block_comment (SCM port) int c = scm_getc (port); if (c == EOF) - scm_wta (SCM_UNDEFINED, - "unterminated `#! ... !#' comment", "read"); + SCM_MISC_ERROR ("unterminated `#! ... !#' comment", SCM_EOL); history = ((history << 8) | (c & 0xff)) & 0xffffffff; /* Were the last four characters read "\n!#\n"? */ @@ -274,6 +274,8 @@ skip_scsh_block_comment (SCM port) return; } } +#undef FUNC_NAME + static SCM scm_get_hash_procedure(int c); @@ -281,6 +283,7 @@ static char s_list[]="list"; SCM scm_lreadr (SCM *tok_buf,SCM port,SCM *copy) +#define FUNC_NAME "scm_lreadr" { int c; scm_sizet j; @@ -299,7 +302,7 @@ tryagain_no_flush_ws: ? scm_lreadrecparen (tok_buf, port, s_list, copy) : scm_lreadparen (tok_buf, port, s_list, copy); case ')': - scm_wta (SCM_UNDEFINED, "unexpected \")\"", "read"); + SCM_MISC_ERROR ("unexpected \")\"", SCM_EOL); goto tryagain; case '\'': @@ -402,7 +405,7 @@ tryagain_no_flush_ws: if (scm_charnames[c] && (scm_casei_streq (scm_charnames[c], SCM_STRING_CHARS (*tok_buf)))) return SCM_MAKE_CHAR (scm_charnums[c]); - scm_wta (SCM_UNDEFINED, "unknown # object: #\\", SCM_STRING_CHARS (*tok_buf)); + SCM_MISC_ERROR ("unknown # object", SCM_EOL); /* #:SYMBOL is a syntax for keywords supported in all contexts. */ case ':': @@ -504,7 +507,7 @@ tryagain_no_flush_ws: c = SCM_STRING_CHARS (*tok_buf)[1]; goto callshrp; } - scm_wta (SCM_UNDEFINED, "unknown # object", SCM_STRING_CHARS (*tok_buf)); + SCM_MISC_ERROR ("unknown # object", SCM_EOL); } goto tok; @@ -524,6 +527,8 @@ tryagain_no_flush_ws: return scm_mem2symbol (SCM_STRING_CHARS (*tok_buf), j); } } +#undef FUNC_NAME + #ifdef _UNICOS _Pragma ("noopt"); /* # pragma _CRI noopt */ @@ -617,6 +622,7 @@ _Pragma ("opt"); /* # pragma _CRI opt */ SCM scm_lreadparen (SCM *tok_buf, SCM port, char *name, SCM *copy) +#define FUNC_NAME "scm_lreadparen" { SCM tmp; SCM tl; @@ -632,7 +638,7 @@ scm_lreadparen (SCM *tok_buf, SCM port, char *name, SCM *copy) ans = scm_lreadr (tok_buf, port, copy); closeit: if (')' != (c = scm_flush_ws (port, name))) - scm_wta (SCM_UNDEFINED, "missing close paren", ""); + SCM_MISC_ERROR ("missing close paren", SCM_EOL); return ans; } ans = tl = scm_cons (tmp, SCM_EOL); @@ -649,10 +655,12 @@ scm_lreadparen (SCM *tok_buf, SCM port, char *name, SCM *copy) } return ans; } +#undef FUNC_NAME SCM scm_lreadrecparen (SCM *tok_buf, SCM port, char *name, SCM *copy) +#define FUNC_NAME "scm_lreadrecparen" { register int c; register SCM tmp; @@ -670,7 +678,7 @@ scm_lreadrecparen (SCM *tok_buf, SCM port, char *name, SCM *copy) { ans = scm_lreadr (tok_buf, port, copy); if (')' != (c = scm_flush_ws (port, name))) - scm_wta (SCM_UNDEFINED, "missing close paren", ""); + SCM_MISC_ERROR ("missing close paren", SCM_EOL); return ans; } /* Build the head of the list structure. */ @@ -694,7 +702,7 @@ scm_lreadrecparen (SCM *tok_buf, SCM port, char *name, SCM *copy) : tmp, SCM_EOL)); if (')' != (c = scm_flush_ws (port, name))) - scm_wta (SCM_UNDEFINED, "missing close paren", ""); + SCM_MISC_ERROR ("missing close paren", SCM_EOL); goto exit; } @@ -721,6 +729,7 @@ exit: SCM_EOL)); return ans; } +#undef FUNC_NAME diff --git a/libguile/script.c b/libguile/script.c index 7bbc51aec..5e56c03b3 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -51,6 +51,7 @@ #include "libguile/load.h" #include "libguile/version.h" +#include "libguile/validate.h" #include "libguile/script.h" #ifdef HAVE_STRING_H @@ -168,6 +169,7 @@ scm_find_executable (const char *name) /* Read a \nnn-style escape. We've just read the backslash. */ static int script_get_octal (FILE *f) +#define FUNC_NAME "script_get_octal" { int i; int value = 0; @@ -178,16 +180,17 @@ script_get_octal (FILE *f) if ('0' <= c && c <= '7') value = (value * 8) + (c - '0'); else - scm_wta (SCM_UNDEFINED, - "malformed script: bad octal backslash escape", - "script argument parser"); + SCM_MISC_ERROR ("malformed script: bad octal backslash escape", + SCM_EOL); } return value; } +#undef FUNC_NAME static int script_get_backslash (FILE *f) +#define FUNC_NAME "script_get_backslash" { int c = getc (f); @@ -211,24 +214,22 @@ script_get_backslash (FILE *f) case '4': case '5': case '6': case '7': ungetc (c, f); return script_get_octal (f); - + case EOF: - scm_wta (SCM_UNDEFINED, - "malformed script: backslash followed by EOF", - "script argument parser"); + SCM_MISC_ERROR ("malformed script: backslash followed by EOF", SCM_EOL); return 0; /* not reached? */ default: - scm_wta (SCM_UNDEFINED, - "malformed script: bad backslash sequence", - "script argument parser"); + SCM_MISC_ERROR ("malformed script: bad backslash sequence", SCM_EOL); return 0; /* not reached? */ } } +#undef FUNC_NAME static char * script_read_arg (FILE *f) +#define FUNC_NAME "script_read_arg" { int size = 7; char *buf = malloc (size + 1); @@ -275,13 +276,12 @@ script_read_arg (FILE *f) case '\t': free (buf); - scm_wta (SCM_UNDEFINED, - "malformed script: TAB in meta-arguments", - "argument parser"); + SCM_MISC_ERROR ("malformed script: TAB in meta-arguments", SCM_EOL); return 0; /* not reached? */ } } } +#undef FUNC_NAME static int diff --git a/libguile/unif.c b/libguile/unif.c index b9987c36d..59b3fc659 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1156,11 +1156,12 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, SCM scm_cvref (SCM v, scm_sizet pos, SCM last) +#define FUNC_NAME "scm_cvref" { switch SCM_TYP7 (v) { default: - scm_wta (v, (char *) SCM_ARG1, "PROGRAMMING ERROR: scm_cvref"); + SCM_WRONG_TYPE_ARG (SCM_ARG1, v); case scm_tc7_bvect: if (SCM_BITVEC_REF(v,pos)) return SCM_BOOL_T; @@ -1222,6 +1223,8 @@ scm_cvref (SCM v, scm_sizet pos, SCM last) } } } +#undef FUNC_NAME + SCM_REGISTER_PROC(s_uniform_array_set1_x, "uniform-array-set1!", 3, 0, 0, scm_array_set_x); From 5e03762c12262629f059d60a47f9d3c08e0102b7 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 4 Mar 2001 20:46:04 +0000 Subject: [PATCH 0642/2047] * goops.c, goops.h (scm_sys_pre_expand_closure_x): Removed. (scm_sys_tag_body): Added. --- libguile/ChangeLog | 5 +++++ libguile/goops.c | 17 ++++------------- libguile/goops.h | 2 +- 3 files changed, 10 insertions(+), 14 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 83d86343c..2d1c80d8d 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-03-04 Mikael Djurfeldt + + * goops.c, goops.h (scm_sys_pre_expand_closure_x): Removed. + (scm_sys_tag_body): Added. + 2001-03-04 Dirk Herrmann * continuations.c (continuation_apply), eval.c (scm_m_lambda, diff --git a/libguile/goops.c b/libguile/goops.c index e4dff3da8..f3250c210 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -934,21 +934,12 @@ SCM_DEFINE (scm_accessor_method_slot_definition, "accessor-method-slot-definitio } #undef FUNC_NAME -SCM_DEFINE (scm_sys_pre_expand_closure_x, "%pre-expand-closure!", 1, 0, 0, - (SCM closure), +SCM_DEFINE (scm_sys_tag_body, "%tag-body", 1, 0, 0, + (SCM body), "Internal GOOPS magic---don't use this function!") -#define FUNC_NAME s_scm_sys_pre_expand_closure_x +#define FUNC_NAME s_scm_sys_tag_body { - SCM formals, code, env; - SCM_VALIDATE_CLOSURE (1, closure); - formals = SCM_CAR (SCM_CODE (closure)); - env = SCM_EXTEND_ENV (formals, formals, SCM_ENV (closure)); - code = SCM_CDR (SCM_CODE (closure)); - while (SCM_NNULLP (SCM_CDR (code)) - && SCM_IMP (SCM_CAR (code)) - && SCM_ISYMP (SCM_CAR (code))) - code = scm_m_expand_body (code, env); - return closure; + return scm_cons (SCM_IM_LAMBDA, body); } #undef FUNC_NAME diff --git a/libguile/goops.h b/libguile/goops.h index a443d4cc0..069fbfb38 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -258,7 +258,7 @@ SCM scm_method_generic_function (SCM obj); SCM scm_method_specializers (SCM obj); SCM scm_method_procedure (SCM obj); SCM scm_accessor_method_slot_definition (SCM obj); -SCM scm_sys_pre_expand_closure_x (SCM closure); +SCM scm_sys_tag_body (SCM body); SCM scm_sys_fast_slot_ref (SCM obj, SCM index); SCM scm_sys_fast_slot_set_x (SCM obj, SCM index, SCM value); SCM scm_slot_ref_using_class (SCM cls, SCM obj, SCM slot_name); From b432fb4b9929475c963e8be69ed6c7293bc964d2 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 4 Mar 2001 20:46:34 +0000 Subject: [PATCH 0643/2047] * goops/compile.scm (compile-method): Tag method closure for body expansion. * goops.scm (change-object-class): Quote empty list constants. (method): Reverted previous change (enclosing body); Quote empty list. (initialize ): Supply `dummy-procedure' as default instead of creating a new closure. * goops/internal.scm: Re-export (oop goops) without copying bindings. --- oop/ChangeLog | 9 ++++++++- oop/goops.scm | 8 ++++---- oop/goops/compile.scm | 7 +++++-- oop/goops/internal.scm | 8 +++----- 4 files changed, 20 insertions(+), 12 deletions(-) diff --git a/oop/ChangeLog b/oop/ChangeLog index b071f5019..cf3f52287 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -1,10 +1,17 @@ 2001-03-04 Mikael Djurfeldt + * goops/compile.scm (compile-method): Tag method closure for body + expansion. + * goops.scm (change-object-class): Quote empty list constants. (method): Reverted previous change (enclosing body); Quote empty list. - (initialize ): Pre-expand the method closure. + (initialize ): Supply `dummy-procedure' as default instead + of creating a new closure. + * goops/internal.scm: Re-export (oop goops) without copying + bindings. + 2001-02-23 Keisuke Nishida * goops.scm (method): Enclosed BODY by `(let () ...)'. diff --git a/oop/goops.scm b/oop/goops.scm index a0af2b9bf..ca5c85dec 100644 --- a/oop/goops.scm +++ b/oop/goops.scm @@ -1314,14 +1314,14 @@ (set-procedure-property! generic 'name name)) )) +(define dummy-procedure (lambda args *unspecified*)) + (define-method initialize ((method ) initargs) (next-method) (slot-set! method 'generic-function (get-keyword #:generic-function initargs #f)) (slot-set! method 'specializers (get-keyword #:specializers initargs '())) - (slot-set! method - 'procedure - (%pre-expand-closure! - (get-keyword #:procedure initargs (lambda l '())))) + (slot-set! method 'procedure + (get-keyword #:procedure initargs dummy-procedure)) (slot-set! method 'code-table '())) (define-method initialize ((obj ) initargs)) diff --git a/oop/goops/compile.scm b/oop/goops/compile.scm index ab185f3c5..8e99733a1 100644 --- a/oop/goops/compile.scm +++ b/oop/goops/compile.scm @@ -1,4 +1,4 @@ -;;;; Copyright (C) 1999 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001 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 @@ -109,6 +109,9 @@ ;;; NOTE: This section is far from finished. It will finally be ;;; implemented on C level. +(define %tag-body + (nested-ref the-root-module '(app modules oop goops %tag-body))) + (define (compile-method methods types) (let* ((proc (method-procedure (car methods))) (src (procedure-source proc)) @@ -132,5 +135,5 @@ ,@body))) (cons (procedure-environment proc) (cons formals - body)) + (%tag-body body))) ))) diff --git a/oop/goops/internal.scm b/oop/goops/internal.scm index 6331ef6df..864fdacf2 100644 --- a/oop/goops/internal.scm +++ b/oop/goops/internal.scm @@ -1,6 +1,6 @@ ;;; installed-scm-file -;;;; Copyright (C) 1999 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001 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 @@ -22,7 +22,5 @@ (define-module (oop goops internal) :use-module (oop goops)) -;; Export all bindings from (oop goops) -(module-for-each (lambda (sym var) - (module-add! %module-public-interface sym var)) - (nested-ref the-root-module '(app modules oop goops))) +(set-module-uses! %module-public-interface + (list (nested-ref the-root-module '(app modules oop goops)))) From 276dd6775cbb0fef46a7e75d3c004c4db1590703 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sun, 4 Mar 2001 22:48:13 +0000 Subject: [PATCH 0644/2047] * Eliminate another couple of calls to scm_wta. --- NEWS | 4 +++- RELEASE | 2 +- libguile/ChangeLog | 17 +++++++++++++++++ libguile/debug.c | 8 ++++---- libguile/print.c | 2 +- libguile/ramap.c | 4 ++-- libguile/sort.c | 8 ++++---- libguile/stacks.c | 8 ++++---- libguile/symbols.c | 10 ++++++++-- libguile/unif.c | 40 ++++++++++++++++++---------------------- libguile/validate.h | 16 ++++++++-------- 11 files changed, 70 insertions(+), 49 deletions(-) diff --git a/NEWS b/NEWS index 51bfe1887..61604043b 100644 --- a/NEWS +++ b/NEWS @@ -506,7 +506,7 @@ SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR, SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING, SCM_ROCHARS, SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS, SCM_LENGTH_MAX, SCM_GC8MARKP, SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR, SCM_SUBR_DOC, -SCM_OPDIRP, SCM_VALIDATE_OPDIR +SCM_OPDIRP, SCM_VALIDATE_OPDIR, SCM_WTA, RETURN_SCM_WTA Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of SCM_OUTOFRANGE. Use scm_memory_error instead of SCM_NALLOC. @@ -531,6 +531,8 @@ Use SCM_CLRGCMARK instead of SCM_CLRGC8MARK. Use SCM_TYP16 instead of SCM_GCTYP16. Use SCM_CDR instead of SCM_GCCDR. Use SCM_DIR_OPEN_P instead of SCM_OPDIRP. +Use SCM_MISC_ERROR or SCM_WRONG_TYPE_ARG instead of SCM_WTA. +Use SCM_MISC_ERROR or SCM_WRONG_TYPE_ARG instead of RETURN_SCM_WTA. ** Removed function: scm_struct_init diff --git a/RELEASE b/RELEASE index 64eb723ea..54471fc05 100644 --- a/RELEASE +++ b/RELEASE @@ -59,7 +59,7 @@ In release 1.6: SCM_COERCE_SUBSTR, SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING, SCM_ROCHARS, SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS, SCM_LENGTH_MAX, SCM_GC8MARKP, SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR, - SCM_SUBR_DOC, SCM_OPDIRP, SCM_VALIDATE_OPDIR + SCM_SUBR_DOC, SCM_OPDIRP, SCM_VALIDATE_OPDIR, SCM_WTA, RETURN_SCM_WTA - remove scm_vector_set_length_x - remove function scm_call_catching_errors (replaced by catch functions from throw.[ch]) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 2d1c80d8d..31363d904 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,20 @@ +2001-03-04 Dirk Herrmann + + * debug.c (scm_procedure_source, scm_procedure_environment), + print.c (scm_get_print_state), ramap.c (scm_array_fill_int, + scm_array_index_map_x), sort.c (scm_sort_x, scm_sort, + scm_stable_sort_x, scm_stable_sort), stacks.c (scm_make_stack, + scm_last_stack_frame), symbols.c (scm_sym2vcell, scm_sym2ovcell), + unif.c (scm_list_to_uniform_array, scm_uniform_vector_length, + scm_transpose_array, scm_enclose_array, scm_array_in_bounds_p, + scm_uniform_vector_ref, scm_array_set_x, scm_uniform_array_read_x, + scm_uniform_array_write, scm_bit_set_star_x, scm_bit_count_star, + scm_array_to_list, scm_array_prototype), validate.h + (SCM_VALIDATE_NUMBER_COPY): Don't call function scm_wta, call + scm_misc_error or scm_wrong_type_arg instead. + + * validate.h (SCM_WTA, RETURN_SCM_WTA): Deprecated. + 2001-03-04 Mikael Djurfeldt * goops.c, goops.h (scm_sys_pre_expand_closure_x): Removed. diff --git a/libguile/debug.c b/libguile/debug.c index 6fbb08764..275c05bc4 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -446,8 +446,8 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0, built in procedures! */ return scm_procedure_property (proc, scm_sym_source); default: - SCM_WTA(1,proc); - return SCM_BOOL_F; + SCM_WRONG_TYPE_ARG (1, proc); + /* not reached */ } } #undef FUNC_NAME @@ -467,8 +467,8 @@ SCM_DEFINE (scm_procedure_environment, "procedure-environment", 1, 0, 0, #endif return SCM_EOL; default: - SCM_WTA(1,proc); - return SCM_BOOL_F; + SCM_WRONG_TYPE_ARG (1, proc); + /* not reached */ } } #undef FUNC_NAME diff --git a/libguile/print.c b/libguile/print.c index bc205ef79..09f5c4547 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1130,7 +1130,7 @@ SCM_DEFINE (scm_get_print_state, "get-print-state", 1, 0, 0, return SCM_PORT_WITH_PS_PS (port); if (SCM_OUTPUT_PORT_P (port)) return SCM_BOOL_F; - RETURN_SCM_WTA (1,port); + SCM_WRONG_TYPE_ARG (1, port); } #undef FUNC_NAME diff --git a/libguile/ramap.c b/libguile/ramap.c index 7ef09128d..702979664 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -535,7 +535,7 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore) ve[i] |= ~(~0L << ((base + n) % SCM_LONG_BIT)); } else - badarg2:SCM_WTA (2,fill); + badarg2:SCM_WRONG_TYPE_ARG (2, fill); } else { @@ -1700,7 +1700,7 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0, switch (SCM_TYP7(ra)) { default: - badarg:SCM_WTA (1,ra); + badarg:SCM_WRONG_TYPE_ARG (1, ra); case scm_tc7_vector: case scm_tc7_wvect: { diff --git a/libguile/sort.c b/libguile/sort.c index 8b7dd62da..659c901bd 100644 --- a/libguile/sort.c +++ b/libguile/sort.c @@ -737,7 +737,7 @@ SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0, return items; } else - RETURN_SCM_WTA (1,items); + SCM_WRONG_TYPE_ARG (1, items); } #undef FUNC_NAME @@ -777,7 +777,7 @@ SCM_DEFINE (scm_sort, "sort", 2, 0, 0, } #endif else - RETURN_SCM_WTA (1,items); + SCM_WRONG_TYPE_ARG (1, items); } #undef FUNC_NAME @@ -872,7 +872,7 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0, return items; } else - RETURN_SCM_WTA (1,items); + SCM_WRONG_TYPE_ARG (1, items); } #undef FUNC_NAME @@ -918,7 +918,7 @@ SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0, } #endif else - RETURN_SCM_WTA (1,items); + SCM_WRONG_TYPE_ARG (1, items); } #undef FUNC_NAME diff --git a/libguile/stacks.c b/libguile/stacks.c index 91051f2c9..e223d4ff1 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -449,8 +449,8 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, } else { - SCM_WTA (SCM_ARG1, obj); - abort (); + SCM_WRONG_TYPE_ARG (SCM_ARG1, obj); + /* not reached */ } } @@ -605,8 +605,8 @@ SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0, } else { - SCM_WTA (1,obj); - abort (); + SCM_WRONG_TYPE_ARG (1, obj); + /* not reached */ } if (!dframe || SCM_VOIDFRAMEP (*dframe)) diff --git a/libguile/symbols.c b/libguile/symbols.c index 83b32560b..818fb5991 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -155,6 +155,7 @@ scm_str2symbol (const char *str) SCM scm_sym2vcell (SCM sym, SCM thunk, SCM definep) +#define FUNC_NAME "scm_sym2vcell" { if (SCM_NIMP (thunk)) { @@ -171,7 +172,7 @@ scm_sym2vcell (SCM sym, SCM thunk, SCM definep) else if (SCM_VARIABLEP (var)) return SCM_VARVCELL (var); else - return scm_wta (sym, "strangely interned symbol? ", ""); + SCM_MISC_ERROR ("strangely interned symbol: ~S", SCM_LIST1 (sym)); } else { @@ -207,6 +208,8 @@ scm_sym2vcell (SCM sym, SCM thunk, SCM definep) } } } +#undef FUNC_NAME + /* scm_sym2ovcell * looks up the symbol in an arbitrary obarray. @@ -236,14 +239,17 @@ scm_sym2ovcell_soft (SCM sym, SCM obarray) SCM scm_sym2ovcell (SCM sym, SCM obarray) +#define FUNC_NAME "scm_sym2ovcell" { SCM answer; answer = scm_sym2ovcell_soft (sym, obarray); if (!SCM_FALSEP (answer)) return answer; - scm_wta (sym, "uninterned symbol? ", ""); + SCM_MISC_ERROR ("uninterned symbol: ~S", SCM_LIST1 (sym)); return SCM_UNSPECIFIED; /* not reached */ } +#undef FUNC_NAME + /* Intern a symbol whose name is the LEN characters at NAME in OBARRAY. diff --git a/libguile/unif.c b/libguile/unif.c index 59b3fc659..1a801317b 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -256,7 +256,7 @@ SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0, switch SCM_TYP7 (v) { default: - badarg1:SCM_WTA(1,v); + badarg1:SCM_WRONG_TYPE_ARG (1, v); case scm_tc7_vector: case scm_tc7_wvect: return SCM_MAKINUM (SCM_VECTOR_LENGTH (v)); @@ -798,7 +798,7 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, switch (SCM_TYP7 (ra)) { default: - badarg:SCM_WTA (1,ra); + badarg:SCM_WRONG_TYPE_ARG (1, ra); case scm_tc7_bvect: case scm_tc7_string: case scm_tc7_byvect: @@ -911,7 +911,7 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, switch SCM_TYP7 (ra) { default: - badarg1:SCM_WTA (1,ra); + badarg1:SCM_WRONG_TYPE_ARG (1, ra); case scm_tc7_string: case scm_tc7_bvect: case scm_tc7_byvect: @@ -996,7 +996,7 @@ tail: switch SCM_TYP7 (v) { default: - badarg1:SCM_WTA (1,v); + badarg1:SCM_WRONG_TYPE_ARG (1, v); wna: scm_wrong_num_args (scm_makfrom0str (FUNC_NAME)); case scm_tc7_smob: k = SCM_ARRAY_NDIM (v); @@ -1095,8 +1095,8 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, if (SCM_NULLP (args)) return v; badarg: - SCM_WTA (1,v); - abort (); + SCM_WRONG_TYPE_ARG (1, v); + /* not reached */ outrng: scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos)); @@ -1265,8 +1265,8 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, switch (SCM_TYP7 (v)) { default: badarg1: - SCM_WTA (1,v); - abort (); + SCM_WRONG_TYPE_ARG (1, v); + /* not reached */ outrng: scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos)); wna: @@ -1279,7 +1279,7 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, else if (SCM_EQ_P (obj, SCM_BOOL_T)) SCM_BITVEC_SET(v,pos); else - badobj:SCM_WTA (2,obj); + badobj:SCM_WRONG_TYPE_ARG (2, obj); break; case scm_tc7_string: SCM_ASRTGO (SCM_CHARP (obj), badobj); @@ -1485,7 +1485,7 @@ loop: switch SCM_TYP7 (v) { default: - badarg1:SCM_WTA (SCM_ARG1,v); + badarg1:SCM_WRONG_TYPE_ARG (SCM_ARG1, v); case scm_tc7_smob: SCM_ASRTGO (SCM_ARRAYP (v), badarg1); cra = scm_ra2contig (ra, 0); @@ -1649,7 +1649,7 @@ loop: switch SCM_TYP7 (v) { default: - badarg1:SCM_WTA (1, v); + badarg1:SCM_WRONG_TYPE_ARG (1, v); case scm_tc7_smob: SCM_ASRTGO (SCM_ARRAYP (v), badarg1); v = scm_ra2contig (v, 1); @@ -1866,7 +1866,7 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, switch SCM_TYP7 (kv) { default: - badarg2:SCM_WTA (2,kv); + badarg2:SCM_WRONG_TYPE_ARG (2, kv); case scm_tc7_uvect: vlen = SCM_BITVECTOR_LENGTH (v); if (SCM_FALSEP (obj)) @@ -1886,7 +1886,7 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, SCM_BITVEC_SET(v,k); } else - badarg3:SCM_WTA (3,obj); + badarg3:SCM_WRONG_TYPE_ARG (3, obj); break; case scm_tc7_bvect: SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME); @@ -1924,7 +1924,7 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, { default: badarg2: - SCM_WTA (2,kv); + SCM_WRONG_TYPE_ARG (2, kv); case scm_tc7_uvect: vlen = SCM_BITVECTOR_LENGTH (v); if (SCM_FALSEP (obj)) @@ -1946,7 +1946,7 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, count++; } else - badarg3:SCM_WTA (3,obj); + badarg3:SCM_WRONG_TYPE_ARG (3, obj); break; case scm_tc7_bvect: SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME); @@ -2062,7 +2062,7 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, switch SCM_TYP7 (v) { default: - badarg1:SCM_WTA (1,v); + badarg1:SCM_WRONG_TYPE_ARG (1, v); case scm_tc7_smob: SCM_ASRTGO (SCM_ARRAYP (v), badarg1); return ra2l (v, SCM_ARRAY_BASE (v), 0); @@ -2138,8 +2138,6 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, #undef FUNC_NAME -static char s_bad_ralst[] = "Bad scm_array contents list"; - static int l2ra(SCM lst, SCM ra, scm_sizet base, scm_sizet k); SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, @@ -2167,7 +2165,6 @@ SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, ra = scm_dimensions_to_uniform_array (scm_reverse (shp), prot, SCM_UNDEFINED); if (SCM_NULLP (shp)) - { SCM_ASRTGO (1 == scm_ilength (lst), badlst); scm_array_set_x (ra, SCM_CAR (lst), SCM_EOL); @@ -2183,8 +2180,7 @@ SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, if (l2ra (lst, ra, SCM_ARRAY_BASE (ra), 0)) return ra; else - badlst:scm_wta (lst, s_bad_ralst, FUNC_NAME); - return SCM_BOOL_F; + badlst:SCM_MISC_ERROR ("Bad scm_array contents list: ~S", SCM_LIST1 (lst)); } #undef FUNC_NAME @@ -2509,7 +2505,7 @@ loop: switch SCM_TYP7 (ra) { default: - badarg:SCM_WTA (1,ra); + badarg:SCM_WRONG_TYPE_ARG (1, ra); case scm_tc7_smob: SCM_ASRTGO (SCM_ARRAYP (ra), badarg); if (enclosed++) diff --git a/libguile/validate.h b/libguile/validate.h index 029d7e337..87fdb716b 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -1,4 +1,4 @@ -/* $Id: validate.h,v 1.26 2001-02-28 16:58:12 dirk Exp $ */ +/* $Id: validate.h,v 1.27 2001-03-04 22:48:13 dirk Exp $ */ /* Copyright (C) 1999, 2000 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify @@ -54,12 +54,6 @@ #define SCM_SYSERROR_MSG(str, args, val) \ do { scm_syserror_msg (FUNC_NAME, (str), (args), (val)); } while (0) -#define SCM_WTA(pos, scm) \ - do { scm_wta (scm, (char *) pos, FUNC_NAME); } while (0) - -#define RETURN_SCM_WTA(pos, scm) \ - do { return scm_wta (scm, (char *) pos, FUNC_NAME); } while (0) - #define SCM_MISC_ERROR(str, args) \ do { scm_misc_error (FUNC_NAME, str, args); } while (0) @@ -166,7 +160,7 @@ else \ { \ cvar = 0.0; \ - SCM_WTA (pos, z); \ + SCM_WRONG_TYPE_ARG (pos, z); \ } \ } while (0) @@ -408,6 +402,12 @@ #if (SCM_DEBUG_DEPRECATED == 0) +#define SCM_WTA(pos, scm) \ + do { scm_wta (scm, (char *) pos, FUNC_NAME); } while (0) + +#define RETURN_SCM_WTA(pos, scm) \ + do { return scm_wta (scm, (char *) pos, FUNC_NAME); } while (0) + #define SCM_VALIDATE_STRINGORSUBSTR SCM_VALIDATE_STRING #define SCM_VALIDATE_ROSTRING(pos, str) SCM_MAKE_VALIDATE (pos, str, ROSTRINGP) From 439006bf6e35ca2230e280755bc370fba85e01f3 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 4 Mar 2001 23:34:16 +0000 Subject: [PATCH 0645/2047] * socket.c (scm_fill_sockaddr): don't allow buffer overflows when taking an unexpectedly large filename for an AF_UNIX socket from bind/connect/sendto (thanks to Martin Grabmueller). * socket.c (scm_sock_fd_to_port, SCM_SOCK_FD_TO_PORT): removed the former and adjusted the latter. (scm_socket, scm_socketpair): cosmetic changes. (scm_getsockopt, scm_setsockopt): declare optlen as int, not size_t as socklen_t substitute. don't restrict args/return values to INUM: allow full range of int or size_t. (scm_fill_sockaddr): check arguments before allocating memory, to avoid leakage. use malloc, not scm_must_malloc. (scm_connect, scm_bind, scm_sendto): use int, not size_t as socklen_t substitute. free the sockaddr structure before throwing an error. (scm_init_add_buffer): procedure removed, together with its static buffer scm_addr_buffer, which wouldn't be thread safe. instead, define a macro MAX_ADDR_SIZE and declare the buffer where needed. (scm_accept, scm_getpeername, scm_getsockname, scm_recvfrom, scm_sendto): use a local buffer instead of scm_addr_buffer. adjust for new SCM_SOCK_FD_TO_PORT. use int for address size, not size_t. (scm_recvfrom): set addr->sa_family to AF_UNSPEC before the recvfrom call to detect whether recvfrom could be bothered to set the address. (scm_init_socket): don't call scm_init_addr_buffer. --- libguile/ChangeLog | 28 ++++ libguile/socket.c | 368 ++++++++++++++++++++++++--------------------- 2 files changed, 228 insertions(+), 168 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 31363d904..dac5c6051 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,30 @@ +2001-03-04 Gary Houston + + * socket.c (scm_fill_sockaddr): don't allow buffer overflows when + taking an unexpectedly large filename for an AF_UNIX socket from + bind/connect/sendto (thanks to Martin Grabmueller). + + * socket.c (scm_sock_fd_to_port, SCM_SOCK_FD_TO_PORT): removed the + former and adjusted the latter. + (scm_socket, scm_socketpair): cosmetic changes. + (scm_getsockopt, scm_setsockopt): declare optlen as int, not + size_t as socklen_t substitute. don't restrict args/return values + to INUM: allow full range of int or size_t. + (scm_fill_sockaddr): check arguments before allocating memory, to + avoid leakage. use malloc, not scm_must_malloc. + (scm_connect, scm_bind, scm_sendto): use int, not size_t as socklen_t + substitute. free the sockaddr structure before throwing an error. + (scm_init_add_buffer): procedure removed, together with its static + buffer scm_addr_buffer, which wouldn't be thread safe. instead, + define a macro MAX_ADDR_SIZE and declare the buffer where needed. + (scm_accept, scm_getpeername, scm_getsockname, scm_recvfrom, + scm_sendto): use a local buffer instead of scm_addr_buffer. + adjust for new SCM_SOCK_FD_TO_PORT. use int for address size, + not size_t. + (scm_recvfrom): set addr->sa_family to AF_UNSPEC before the recvfrom + call to detect whether recvfrom could be bothered to set the address. + (scm_init_socket): don't call scm_init_addr_buffer. + 2001-03-04 Dirk Herrmann * debug.c (scm_procedure_source, scm_procedure_environment), @@ -33,6 +60,7 @@ call function scm_wta, call scm_misc_error or scm_wrong_type_arg instead. +>>>>>>> 1.1294 2001-03-04 Mikael Djurfeldt * goops.c (scm_sys_pre_expand_closure_x): New procedure. diff --git a/libguile/socket.c b/libguile/socket.c index d765383a2..a637aa7ea 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -71,6 +71,10 @@ #include #include +/* we are not currently using socklen_t. it's not defined on all systems, + so would need to be checked by configure. in the meantime, plain + int is the best alternative. */ + SCM_DEFINE (scm_htons, "htons", 1, 0, 0, @@ -133,18 +137,7 @@ SCM_DEFINE (scm_ntohl, "ntohl", 1, 0, 0, SCM_SYMBOL (sym_socket, "socket"); -static SCM -scm_sock_fd_to_port (int fd, const char *proc) -{ - SCM result; - if (fd == -1) - scm_syserror (proc); - result = scm_fdes_to_port (fd, "r+0", sym_socket); - return result; -} - - -#define SCM_SOCK_FD_TO_PORT(fd) (scm_sock_fd_to_port((fd),FUNC_NAME)) +#define SCM_SOCK_FD_TO_PORT(fd) scm_fdes_to_port (fd, "r+0", sym_socket) SCM_DEFINE (scm_socket, "socket", 3, 0, 0, (SCM family, SCM style, SCM proto), @@ -161,19 +154,17 @@ SCM_DEFINE (scm_socket, "socket", 3, 0, 0, #define FUNC_NAME s_scm_socket { int fd; - SCM result; - SCM_VALIDATE_INUM (1,family); - SCM_VALIDATE_INUM (2,style); - SCM_VALIDATE_INUM (3,proto); + SCM_VALIDATE_INUM (1, family); + SCM_VALIDATE_INUM (2, style); + SCM_VALIDATE_INUM (3, proto); fd = socket (SCM_INUM (family), SCM_INUM (style), SCM_INUM (proto)); - result = SCM_SOCK_FD_TO_PORT (fd); - return result; + if (fd == -1) + SCM_SYSERROR; + return SCM_SOCK_FD_TO_PORT (fd); } #undef FUNC_NAME - - #ifdef HAVE_SOCKETPAIR SCM_DEFINE (scm_socketpair, "socketpair", 3, 0, 0, (SCM family, SCM style, SCM proto), @@ -186,8 +177,6 @@ SCM_DEFINE (scm_socketpair, "socketpair", 3, 0, 0, { int fam; int fd[2]; - SCM a; - SCM b; SCM_VALIDATE_INUM (1,family); SCM_VALIDATE_INUM (2,style); @@ -198,9 +187,7 @@ SCM_DEFINE (scm_socketpair, "socketpair", 3, 0, 0, if (socketpair (fam, SCM_INUM (style), SCM_INUM (proto), fd) == -1) SCM_SYSERROR; - a = SCM_SOCK_FD_TO_PORT(fd[0]); - b = SCM_SOCK_FD_TO_PORT(fd[1]); - return scm_cons (a, b); + return scm_cons (SCM_SOCK_FD_TO_PORT (fd[0]), SCM_SOCK_FD_TO_PORT (fd[1])); } #undef FUNC_NAME #endif @@ -218,21 +205,17 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0, #define FUNC_NAME s_scm_getsockopt { int fd; - size_t optlen; + /* size of optval is the largest supported option. */ #ifdef HAVE_STRUCT_LINGER char optval[sizeof (struct linger)]; + int optlen = sizeof (struct linger); #else char optval[sizeof (scm_sizet)]; + int optlen = sizeof (scm_sizet); #endif int ilevel; int ioptname; -#ifdef HAVE_STRUCT_LINGER - optlen = sizeof (struct linger); -#else - optlen = sizeof (size_t); -#endif - sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1, sock); SCM_VALIDATE_INUM_COPY (2, level, ilevel); @@ -242,35 +225,36 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0, if (getsockopt (fd, ilevel, ioptname, (void *) optval, &optlen) == -1) SCM_SYSERROR; + if (ilevel == SOL_SOCKET) + { #ifdef SO_LINGER - if (ilevel == SOL_SOCKET && ioptname == SO_LINGER) - { + if (ioptname == SO_LINGER) + { #ifdef HAVE_STRUCT_LINGER - struct linger *ling = (struct linger *) optval; - return scm_cons (SCM_MAKINUM (ling->l_onoff), - SCM_MAKINUM (ling->l_linger)); + struct linger *ling = (struct linger *) optval; + + return scm_cons (scm_long2num (ling->l_onoff), + scm_long2num (ling->l_linger)); #else - scm_sizet *ling = (scm_sizet *) optval; - return scm_cons (SCM_MAKINUM (*ling), - SCM_MAKINUM (0)); + return scm_cons (scm_long2num (*(int *) optval) + SCM_MAKINUM (0)); #endif - } + } + else #endif + if (0 #ifdef SO_SNDBUF - if (ilevel == SOL_SOCKET && ioptname == SO_SNDBUF) - { - scm_sizet *bufsize = (scm_sizet *) optval; - return SCM_MAKINUM (*bufsize); - } + || ioptname == SO_SNDBUF #endif #ifdef SO_RCVBUF - if (ilevel == SOL_SOCKET && ioptname == SO_RCVBUF) - { - scm_sizet *bufsize = (scm_sizet *) optval; - return SCM_MAKINUM (*bufsize); - } + || ioptname == SO_RCVBUF #endif - return SCM_MAKINUM (*(int *) optval); + ) + { + return scm_long2num (*(scm_sizet *) optval); + } + } + return scm_long2num (*(int *) optval); } #undef FUNC_NAME @@ -289,66 +273,83 @@ SCM_DEFINE (scm_setsockopt, "setsockopt", 4, 0, 0, #define FUNC_NAME s_scm_setsockopt { int fd; - int optlen; + int optlen = -1; + /* size of optval is the largest supported option. */ #ifdef HAVE_STRUCT_LINGER - char optval[sizeof (struct linger)]; /* Biggest option :-( */ + char optval[sizeof (struct linger)]; #else char optval[sizeof (scm_sizet)]; #endif int ilevel, ioptname; + sock = SCM_COERCE_OUTPORT (sock); - SCM_VALIDATE_OPFPORT (1,sock); - SCM_VALIDATE_INUM_COPY (2,level,ilevel); - SCM_VALIDATE_INUM_COPY (3,optname,ioptname); + + SCM_VALIDATE_OPFPORT (1, sock); + SCM_VALIDATE_INUM_COPY (2, level, ilevel); + SCM_VALIDATE_INUM_COPY (3, optname, ioptname); + fd = SCM_FPORT_FDES (sock); - if (0); + + if (ilevel == SOL_SOCKET) + { #ifdef SO_LINGER - else if (ilevel == SOL_SOCKET && ioptname == SO_LINGER) - { + if (ioptname == SO_LINGER) + { #ifdef HAVE_STRUCT_LINGER - struct linger ling; - SCM_ASSERT (SCM_CONSP (value) - && SCM_INUMP (SCM_CAR (value)) - && SCM_INUMP (SCM_CDR (value)), - value, SCM_ARG4, FUNC_NAME); - ling.l_onoff = SCM_INUM (SCM_CAR (value)); - ling.l_linger = SCM_INUM (SCM_CDR (value)); - optlen = (int) sizeof (struct linger); - memcpy (optval, (void *) &ling, optlen); + struct linger ling; + long lv; + + SCM_ASSERT (SCM_CONSP (value), value, SCM_ARG4, FUNC_NAME); + lv = SCM_NUM2LONG (4, SCM_CAR (value)); + ling.l_onoff = (int) lv; + SCM_ASSERT_RANGE (SCM_ARG4, value, ling.l_onoff == lv); + lv = SCM_NUM2LONG (4, SCM_CDR (value)); + ling.l_linger = (int) lv; + SCM_ASSERT_RANGE (SCM_ARG4, value, ling.l_linger == lv); + optlen = (int) sizeof (struct linger); + memcpy (optval, (void *) &ling, optlen); #else - scm_sizet ling; - SCM_ASSERT (SCM_CONSP (value) - && SCM_INUMP (SCM_CAR (value)) - && SCM_INUMP (SCM_CDR (value)), - value, SCM_ARG4, FUNC_NAME); - ling = SCM_INUM (SCM_CAR (value)); - optlen = (int) sizeof (scm_sizet); - (*(scm_sizet *) optval) = (scm_sizet) SCM_INUM (value); + int ling; + long lv; + + SCM_ASSERT (SCM_CONSP (value), value, SCM_ARG4, FUNC_NAME); + /* timeout is ignored, but may as well validate it. */ + lv = SCM_NUM2LONG (4, SCM_CDR (value)); + ling = (int) lv; + SCM_ASSERT_RANGE (SCM_ARG4, value, ling == lv); + lv = SCM_NUM2LONG (4, SCM_CAR (value)); + ling = (int) lv; + SCM_ASSERT_RANGE (SCM_ARG4, value, ling == lv); + optlen = (int) sizeof (int); + (*(int *) optval) = ling; #endif - } + } + else #endif + if (0 #ifdef SO_SNDBUF - else if (ilevel == SOL_SOCKET && ioptname == SO_SNDBUF) - { - SCM_VALIDATE_INUM (4,value); - optlen = (int) sizeof (scm_sizet); - (*(scm_sizet *) optval) = (scm_sizet) SCM_INUM (value); - } + || ioptname == SO_SNDBUF #endif #ifdef SO_RCVBUF - else if (ilevel == SOL_SOCKET && ioptname == SO_RCVBUF) - { - SCM_VALIDATE_INUM (4,value); - optlen = (int) sizeof (scm_sizet); - (*(scm_sizet *) optval) = (scm_sizet) SCM_INUM (value); - } + || ioptname == SO_RCVBUF #endif - else + ) + { + long lv = SCM_NUM2LONG (4, value); + + optlen = (int) sizeof (scm_sizet); + (*(scm_sizet *) optval) = (scm_sizet) lv; + } + } + if (optlen == -1) { - /* Most options just take an int. */ - SCM_VALIDATE_INUM (4,value); + /* Most options take an int. */ + long lv = SCM_NUM2LONG (4, value); + int val = (int) lv; + + SCM_ASSERT_RANGE (SCM_ARG4, value, val == lv); optlen = (int) sizeof (int); - (*(int *) optval) = (int) SCM_INUM (value); + (*(int *) optval) = val; } if (setsockopt (fd, ilevel, ioptname, (void *) optval, optlen) == -1) SCM_SYSERROR; @@ -394,9 +395,9 @@ SCM_DEFINE (scm_shutdown, "shutdown", 2, 0, 0, proc is the name of the original procedure. size returns the size of the structure allocated. */ - static struct sockaddr * -scm_fill_sockaddr (int fam,SCM address,SCM *args,int which_arg,const char *proc,scm_sizet *size) +scm_fill_sockaddr (int fam, SCM address, SCM *args, int which_arg, + const char *proc, int *size) { switch (fam) { @@ -405,18 +406,19 @@ scm_fill_sockaddr (int fam,SCM address,SCM *args,int which_arg,const char *proc, SCM isport; struct sockaddr_in *soka; - soka = (struct sockaddr_in *) - scm_must_malloc (sizeof (struct sockaddr_in), proc); + SCM_ASSERT (SCM_CONSP (*args), *args, + which_arg + 1, proc); + isport = SCM_CAR (*args); + SCM_ASSERT (SCM_INUMP (isport), isport, which_arg + 1, proc); + soka = (struct sockaddr_in *) malloc (sizeof (struct sockaddr_in)); + if (!soka) + scm_memory_error (proc); /* e.g., for BSDs which don't like invalid sin_len. */ memset (soka, 0, sizeof (struct sockaddr_in)); soka->sin_family = AF_INET; soka->sin_addr.s_addr = htonl (scm_num2ulong (address, (char *) which_arg, proc)); - SCM_ASSERT (SCM_CONSP (*args), *args, - which_arg + 1, proc); - isport = SCM_CAR (*args); *args = SCM_CDR (*args); - SCM_ASSERT (SCM_INUMP (isport), isport, which_arg + 1, proc); soka->sin_port = htons (SCM_INUM (isport)); *size = sizeof (struct sockaddr_in); return (struct sockaddr *) soka; @@ -425,15 +427,25 @@ scm_fill_sockaddr (int fam,SCM address,SCM *args,int which_arg,const char *proc, case AF_UNIX: { struct sockaddr_un *soka; + int addr_size; - soka = (struct sockaddr_un *) - scm_must_malloc (sizeof (struct sockaddr_un), proc); - memset (soka, 0, sizeof (struct sockaddr_un)); - soka->sun_family = AF_UNIX; SCM_ASSERT (SCM_STRINGP (address), address, which_arg, proc); + /* the static buffer size in sockaddr_un seems to be arbitrary + and not necessarily a hard limit. e.g., the glibc manual + suggests it may be possible to declare it size 0. let's + ignore it. if the O/S doesn't like the size it will cause + connect/bind etc., to fail. sun_path is always the last + member of the structure. */ + addr_size = sizeof (struct sockaddr_un) + + max (0, SCM_STRING_LENGTH (address) + 1 - (sizeof soka->sun_path)); + soka = (struct sockaddr_un *) malloc (addr_size); + if (!soka) + scm_memory_error (proc); + memset (soka, 0, addr_size); /* for sun_len: see sin_len above. */ + soka->sun_family = AF_UNIX; memcpy (soka->sun_path, SCM_STRING_CHARS (address), - 1 + SCM_STRING_LENGTH (address)); - *size = sizeof (struct sockaddr_un); + SCM_STRING_LENGTH (address)); + *size = SUN_LEN (soka); return (struct sockaddr *) soka; } #endif @@ -459,16 +471,23 @@ SCM_DEFINE (scm_connect, "connect", 3, 0, 1, { int fd; struct sockaddr *soka; - scm_sizet size; + int size; sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1,sock); SCM_VALIDATE_INUM (2,fam); fd = SCM_FPORT_FDES (sock); - soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, FUNC_NAME, &size); + soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, FUNC_NAME, + &size); if (connect (fd, soka, size) == -1) - SCM_SYSERROR; - scm_must_free ((char *) soka); + { + int save_errno = errno; + + free (soka); + errno = save_errno; + SCM_SYSERROR; + } + free (soka); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -504,20 +523,25 @@ SCM_DEFINE (scm_bind, "bind", 3, 0, 1, "The return value is unspecified.") #define FUNC_NAME s_scm_bind { - int rv; struct sockaddr *soka; - scm_sizet size; + int size; int fd; sock = SCM_COERCE_OUTPORT (sock); - SCM_VALIDATE_OPFPORT (1,sock); - SCM_VALIDATE_INUM (2,fam); - soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, FUNC_NAME, &size); + SCM_VALIDATE_OPFPORT (1, sock); + SCM_VALIDATE_INUM (2, fam); + soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, FUNC_NAME, + &size); fd = SCM_FPORT_FDES (sock); - rv = bind (fd, soka, size); - if (rv == -1) + if (bind (fd, soka, size) == -1) + { + int save_errno = errno; + + free (soka); + errno = save_errno; SCM_SYSERROR; - scm_must_free ((char *) soka); + } + free (soka); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -544,17 +568,18 @@ SCM_DEFINE (scm_listen, "listen", 2, 0, 0, #undef FUNC_NAME /* Put the components of a sockaddr into a new SCM vector. */ - static SCM -scm_addr_vector (struct sockaddr *address,const char *proc) +scm_addr_vector (struct sockaddr *address, const char *proc) { short int fam = address->sa_family; SCM result; SCM *ve; + #ifdef HAVE_UNIX_DOMAIN_SOCKETS if (fam == AF_UNIX) { struct sockaddr_un *nad = (struct sockaddr_un *) address; + result = scm_c_make_vector (2, SCM_UNSPECIFIED); ve = SCM_VELTS (result); ve[0] = scm_ulong2num ((unsigned long) fam); @@ -566,6 +591,7 @@ scm_addr_vector (struct sockaddr *address,const char *proc) if (fam == AF_INET) { struct sockaddr_in *nad = (struct sockaddr_in *) address; + result = scm_c_make_vector (3, SCM_UNSPECIFIED); ve = SCM_VELTS (result); ve[0] = scm_ulong2num ((unsigned long) fam); @@ -579,24 +605,17 @@ scm_addr_vector (struct sockaddr *address,const char *proc) return result; } -/* Allocate a buffer large enough to hold any sockaddr type. */ -static char *scm_addr_buffer; -static size_t scm_addr_buffer_size; +/* calculate the size of a buffer large enough to hold any supported + sockaddr type. if the buffer isn't large enough, certain system + calls will return a truncated address. */ -static void -scm_init_addr_buffer (void) -{ - scm_addr_buffer_size = -#ifdef HAVE_UNIX_DOMAIN_SOCKETS - sizeof (struct sockaddr_un) +#if defined (HAVE_UNIX_DOMAIN_SOCKETS) +#define MAX_SIZE_UN sizeof (struct sockaddr_un) #else - 0 +#define MAX_SIZE_UN 0 #endif - ; - if (sizeof (struct sockaddr_in) > scm_addr_buffer_size) - scm_addr_buffer_size = sizeof (struct sockaddr_in); - scm_addr_buffer = scm_must_malloc (scm_addr_buffer_size, "address buffer"); -} + +#define MAX_ADDR_SIZE max (sizeof (struct sockaddr_in), MAX_SIZE_UN) SCM_DEFINE (scm_accept, "accept", 1, 0, 0, (SCM sock), @@ -617,16 +636,19 @@ SCM_DEFINE (scm_accept, "accept", 1, 0, 0, int newfd; SCM address; SCM newsock; + int addr_size = MAX_ADDR_SIZE; + char max_addr[MAX_ADDR_SIZE]; + struct sockaddr *addr = (struct sockaddr *) max_addr; - size_t tmp_size; sock = SCM_COERCE_OUTPORT (sock); - SCM_VALIDATE_OPFPORT (1,sock); + SCM_VALIDATE_OPFPORT (1, sock); fd = SCM_FPORT_FDES (sock); - tmp_size = scm_addr_buffer_size; - newfd = accept (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size); - newsock = scm_sock_fd_to_port (newfd, FUNC_NAME); - if (tmp_size > 0) - address = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, FUNC_NAME); + newfd = accept (fd, addr, &addr_size); + if (newfd == -1) + SCM_SYSERROR; + newsock = SCM_SOCK_FD_TO_PORT (newfd); + if (addr_size > 0) + address = scm_addr_vector (addr, FUNC_NAME); else address = SCM_BOOL_F; @@ -641,17 +663,19 @@ SCM_DEFINE (scm_getsockname, "getsockname", 1, 0, 0, "in the @code{AF_FILE} namespace cannot be read.") #define FUNC_NAME s_scm_getsockname { - size_t tmp_size; int fd; SCM result; + int addr_size = MAX_ADDR_SIZE; + char max_addr[MAX_ADDR_SIZE]; + struct sockaddr *addr = (struct sockaddr *) max_addr; + sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1,sock); fd = SCM_FPORT_FDES (sock); - tmp_size = scm_addr_buffer_size; - if (getsockname (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size) == -1) + if (getsockname (fd, addr, &addr_size) == -1) SCM_SYSERROR; - if (tmp_size > 0) - result = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, FUNC_NAME); + if (addr_size > 0) + result = scm_addr_vector (addr, FUNC_NAME); else result = SCM_BOOL_F; return result; @@ -666,17 +690,19 @@ SCM_DEFINE (scm_getpeername, "getpeername", 1, 0, 0, "in the @code{AF_FILE} namespace cannot be read.") #define FUNC_NAME s_scm_getpeername { - size_t tmp_size; int fd; SCM result; + int addr_size = MAX_ADDR_SIZE; + char max_addr[MAX_ADDR_SIZE]; + struct sockaddr *addr = (struct sockaddr *) max_addr; + sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1,sock); fd = SCM_FPORT_FDES (sock); - tmp_size = scm_addr_buffer_size; - if (getpeername (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size) == -1) + if (getpeername (fd, addr, &addr_size) == -1) SCM_SYSERROR; - if (tmp_size > 0) - result = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, FUNC_NAME); + if (addr_size > 0) + result = scm_addr_vector (addr, FUNC_NAME); else result = SCM_BOOL_F; return result; @@ -772,8 +798,10 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0, char *buf; int offset; int cend; - size_t tmp_size; SCM address; + int addr_size = MAX_ADDR_SIZE; + char max_addr[MAX_ADDR_SIZE]; + struct sockaddr *addr = (struct sockaddr *) max_addr; SCM_VALIDATE_OPFPORT (1,sock); fd = SCM_FPORT_FDES (sock); @@ -784,15 +812,17 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0, else SCM_VALIDATE_ULONG_COPY (3, flags, flg); - tmp_size = scm_addr_buffer_size; + /* recvfrom will not necessarily return an address. e.g., linux + 2.4.2 doesn't change addr or addr_size if socket is + AF_INET/SOCK_STREAM. */ + addr->sa_family = AF_UNSPEC; SCM_SYSCALL (rv = recvfrom (fd, buf + offset, cend - offset, flg, - (struct sockaddr *) scm_addr_buffer, - &tmp_size)); + addr, &addr_size)); if (rv == -1) SCM_SYSERROR; - if (tmp_size > 0) - address = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, FUNC_NAME); + if (addr_size > 0 && addr->sa_family != AF_UNSPEC) + address = scm_addr_vector (addr, FUNC_NAME); else address = SCM_BOOL_F; @@ -818,8 +848,7 @@ SCM_DEFINE (scm_sendto, "sendto", 4, 0, 1, int fd; int flg; struct sockaddr *soka; - scm_sizet size; - int save_err; + int size; sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_FPORT (1,sock); @@ -835,13 +864,17 @@ SCM_DEFINE (scm_sendto, "sendto", 4, 0, 1, SCM_VALIDATE_CONS (5,args_and_flags); flg = SCM_NUM2ULONG (5,SCM_CAR (args_and_flags)); } - SCM_SYSCALL (rv = sendto (fd, SCM_STRING_CHARS (message), SCM_STRING_LENGTH (message), + SCM_SYSCALL (rv = sendto (fd, SCM_STRING_CHARS (message), + SCM_STRING_LENGTH (message), flg, soka, size)); - save_err = errno; - scm_must_free ((char *) soka); - errno = save_err; if (rv == -1) - SCM_SYSERROR; + { + int save_errno = errno; + free (soka); + errno = save_errno; + SCM_SYSERROR; + } + free (soka); return SCM_MAKINUM (rv); } #undef FUNC_NAME @@ -953,7 +986,6 @@ scm_init_socket () #endif scm_add_feature ("socket"); - scm_init_addr_buffer (); #ifndef SCM_MAGIC_SNARFER #include "libguile/socket.x" From 2772dc1af32683c7821ff2b20ec5f00e92890fe0 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 4 Mar 2001 23:35:21 +0000 Subject: [PATCH 0646/2047] *** empty log message *** --- libguile/ChangeLog | 1 - 1 file changed, 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index dac5c6051..f6645b726 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -60,7 +60,6 @@ call function scm_wta, call scm_misc_error or scm_wrong_type_arg instead. ->>>>>>> 1.1294 2001-03-04 Mikael Djurfeldt * goops.c (scm_sys_pre_expand_closure_x): New procedure. From 1dd05fd8aa1044dca6df3de7026a49f79246a5dc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 5 Mar 2001 07:25:56 +0000 Subject: [PATCH 0647/2047] * print.c (scm_print_options): Fixed texinfo in docstring. * net_db.c (scm_getserv, scm_getproto, scm_getnet): Return #f if the underlying functions getservent, getprotoent or getnetent return NULL instead of signalling an error. --- libguile/ChangeLog | 8 ++++++++ libguile/net_db.c | 27 ++++++++++++--------------- libguile/print.c | 5 +++-- 3 files changed, 23 insertions(+), 17 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f6645b726..bd8b61460 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2001-03-05 Martin Grabmueller + + * print.c (scm_print_options): Fixed texinfo in docstring. + + * net_db.c (scm_getserv, scm_getproto, scm_getnet): Return #f if + the underlying functions getservent, getprotoent or getnetent + return NULL instead of signalling an error. + 2001-03-04 Gary Houston * socket.c (scm_fill_sockaddr): don't allow buffer overflows when diff --git a/libguile/net_db.c b/libguile/net_db.c index 19a826d09..408400f58 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -340,14 +340,13 @@ SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0, ve = SCM_VELTS (ans); if (SCM_UNBNDP (net)) { - errno = 0; entry = getnetent (); if (! entry) { - if (errno) - SCM_SYSERROR; - else - return SCM_BOOL_F; + /* There's no good way to tell whether zero means an error + or end-of-file, so we always return #f. See `gethost' + for details. */ + return SCM_BOOL_F; } } else if (SCM_STRINGP (net)) @@ -392,14 +391,13 @@ SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0, ve = SCM_VELTS (ans); if (SCM_UNBNDP (protocol)) { - errno = 0; entry = getprotoent (); if (! entry) { - if (errno) - SCM_SYSERROR; - else - return SCM_BOOL_F; + /* There's no good way to tell whether zero means an error + or end-of-file, so we always return #f. See `gethost' + for details. */ + return SCM_BOOL_F; } } else if (SCM_STRINGP (protocol)) @@ -456,14 +454,13 @@ SCM_DEFINE (scm_getserv, "getserv", 0, 2, 0, struct servent *entry; if (SCM_UNBNDP (name)) { - errno = 0; entry = getservent (); if (!entry) { - if (errno) - SCM_SYSERROR; - else - return SCM_BOOL_F; + /* There's no good way to tell whether zero means an error + or end-of-file, so we always return #f. See `gethost' + for details. */ + return SCM_BOOL_F; } return scm_return_entry (entry); } diff --git a/libguile/print.c b/libguile/print.c index 09f5c4547..1e86d854d 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -136,8 +136,9 @@ scm_option scm_print_opts[] = { SCM_DEFINE (scm_print_options, "print-options-interface", 0, 1, 0, (SCM setting), "Option interface for the print options. Instead of using\n" - "this procedure directly, use the procedures @code{print-enable},\n" - "@code{print-disable}, @code{print-set!} and @var{print-options}.") + "this procedure directly, use the procedures\n" + "@code{print-enable}, @code{print-disable}, @code{print-set!}\n" + "and @code{print-options}.") #define FUNC_NAME s_scm_print_options { SCM ans = scm_options (setting, From 8bc4547c4e21093453c0e1480fc6e4025c179f72 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 5 Mar 2001 11:05:02 +0000 Subject: [PATCH 0648/2047] * Preserve the original error's stack for re-throwing. --- test-suite/ChangeLog | 6 +++++- test-suite/lib.scm | 3 ++- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index e34d372ee..9a0037ff7 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2001-03-05 Dirk Herrmann + + * lib.scm (run-test-exception): Preserve the original error's + stack for re-throwing. + 2001-03-04 Marius Vollmer * tests/syntax.test ("let,duplicate bindings", "let*,duplicate @@ -29,7 +34,6 @@ related to evaluation and application to tests/eval.test. * tests/exceptions.test: Added some test cases that check guile's - exception handling. 2001-03-01 Dirk Herrmann diff --git a/test-suite/lib.scm b/test-suite/lib.scm index 6cc48f24d..2ef8aee45 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -17,6 +17,7 @@ ;;;; Boston, MA 02111-1307 USA (define-module (test-suite lib) + :use-module (ice-9 stack-catch) :use-module (ice-9 regex)) (export @@ -284,7 +285,7 @@ (define (run-test-exception name exception expect-pass thunk) (run-test name expect-pass (lambda () - (catch (car exception) + (stack-catch (car exception) (lambda () (thunk) #f) (lambda (key proc message . rest) (if (not (string-match (cdr exception) message)) From c2ab898653f9bce6cc6cbfc9e8cbcd19325496d1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 5 Mar 2001 14:26:55 +0000 Subject: [PATCH 0649/2047] * guile-config.in (build-link): Fixed duplicate binding bug reported by Ralf Mattes. --- guile-config/guile-config.in | 50 ++++++++++++++++++------------------ 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/guile-config/guile-config.in b/guile-config/guile-config.in index 0e917889c..6bb8c1e59 100644 --- a/guile-config/guile-config.in +++ b/guile-config/guile-config.in @@ -140,36 +140,36 @@ (string-append program-name " link: arguments to subcommand not yet implemented"))) - (let* ((flags - (let loop ((libs - ;; Get the string of linker flags we used to build - ;; Guile, and break it up into a list. - (separate-fields-discarding-char #\space - (get-build-info 'LIBS) - list))) + (let ((flags + (let loop ((libs + ;; Get the string of linker flags we used to build + ;; Guile, and break it up into a list. + (separate-fields-discarding-char #\space + (get-build-info 'LIBS) + list))) - (cond - ((null? libs) '()) + (cond + ((null? libs) '()) - ;; Turn any "FOO/libBAR.a" elements into "-lBAR". - ((match-lib (car libs)) - => (lambda (bar) - (cons (string-append "-l" bar) - (loop (cdr libs))))) - - ;; Remove any empty strings that may have seeped in there. - ((string=? (car libs) "") (loop (cdr libs))) + ;; Turn any "FOO/libBAR.a" elements into "-lBAR". + ((match-lib (car libs)) + => (lambda (bar) + (cons (string-append "-l" bar) + (loop (cdr libs))))) - (else (cons (car libs) (loop (cdr libs))))))) + ;; Remove any empty strings that may have seeped in there. + ((string=? (car libs) "") (loop (cdr libs))) + + (else (cons (car libs) (loop (cdr libs)))))))) - ;; Include libguile itself in the list, along with the - ;; directory it was installed in. - (flags (cons (string-append "-L" (get-build-info 'libdir)) - (cons "-lguile" flags)))) + ;; Include libguile itself in the list, along with the + ;; directory it was installed in. + (let (flags (cons (string-append "-L" (get-build-info 'libdir)) + (cons "-lguile" flags))) - ;; Display the flags, separated by spaces. - (display-separated flags) - (newline))) + ;; Display the flags, separated by spaces. + (display-separated flags) + (newline)))) (define (help-link) (let ((dle display-line-error)) From 417b11b41f6afdd8e325985acf1fde74eb807b3a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 5 Mar 2001 14:27:40 +0000 Subject: [PATCH 0650/2047] * guile-config.in (build-link): Fixed duplicate binding bug reported by Ralf Mattes. --- guile-config/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/guile-config/ChangeLog b/guile-config/ChangeLog index 90457a0e6..277512916 100644 --- a/guile-config/ChangeLog +++ b/guile-config/ChangeLog @@ -1,3 +1,8 @@ +2001-03-05 Martin Grabmueller + + * guile-config.in (build-link): Fixed duplicate binding bug + reported by Ralf Mattes. + 2000-11-28 Dirk Herrmann * guile-config.in (build-link): Use substring instead of From 586d7da23739c354a1e4afea913b61c282c7be68 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Mon, 5 Mar 2001 18:54:55 +0000 Subject: [PATCH 0651/2047] * eval.c (scm_m_letstar): Removed check for duplicate bindings. Duplicate bindings are OK in a let* since a let* is semantically equivalent to a nested set of let:s. --- libguile/ChangeLog | 6 ++++++ libguile/eval.c | 2 -- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index bd8b61460..2978ce298 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2001-03-05 Mikael Djurfeldt + + * eval.c (scm_m_letstar): Removed check for duplicate bindings. + Duplicate bindings are OK in a let* since a let* is semantically + equivalent to a nested set of let:s. + 2001-03-05 Martin Grabmueller * print.c (scm_print_options): Fixed texinfo in docstring. diff --git a/libguile/eval.c b/libguile/eval.c index 90ba9973b..93a4a166a 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -712,8 +712,6 @@ scm_m_letstar (SCM xorig, SCM env) arg1 = SCM_CAR (proc); SCM_ASSYNT (2 == scm_ilength (arg1), xorig, scm_s_bindings, s_letstar); SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), xorig, scm_s_variable, s_letstar); - if (scm_c_improper_memq (SCM_CAR (arg1), vars)) - scm_misc_error (s_letstar, scm_s_duplicate_bindings, SCM_EOL); *varloc = scm_cons2 (SCM_CAR (arg1), SCM_CAR (SCM_CDR (arg1)), SCM_EOL); varloc = SCM_CDRLOC (SCM_CDR (*varloc)); proc = SCM_CDR (proc); From 9155e458e0dbfa0e0e50985636275edce3a13f99 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Mon, 5 Mar 2001 23:12:57 +0000 Subject: [PATCH 0652/2047] * New module (ice-9 buffered-input); use it in (ice-9 readline). --- guile-readline/ChangeLog | 6 +++ guile-readline/readline.scm | 51 +++++++-------------- ice-9/ChangeLog | 5 +++ ice-9/Makefile.am | 3 +- ice-9/buffered-input.scm | 89 +++++++++++++++++++++++++++++++++++++ 5 files changed, 118 insertions(+), 36 deletions(-) create mode 100644 ice-9/buffered-input.scm diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 9f1a09a72..1c587252d 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,9 @@ +2001-03-05 Neil Jerram + + * readline.scm (make-readline-port): Rewrite using + make-line-buffered-input-port. + (activate-readline): Call set-buffered-input-continuation?!. + 2001-01-28 Marius Vollmer * readline.scm (make-readline-port): PROMPT becomes PROMPT2 as diff --git a/guile-readline/readline.scm b/guile-readline/readline.scm index 6d482c4e2..c76e51a39 100644 --- a/guile-readline/readline.scm +++ b/guile-readline/readline.scm @@ -26,6 +26,7 @@ (define-module (ice-9 readline) :use-module (ice-9 session) :use-module (ice-9 regex) + :use-module (ice-9 buffered-input) :no-backtrace) @@ -74,41 +75,20 @@ (define read-hook #f) (define (make-readline-port) - (let ((read-string "") - (string-index -1)) - (letrec ((get-character - (lambda () - (cond - ((eof-object? read-string) - read-string) - ((>= string-index (string-length read-string)) - (begin - (set! string-index -1) - #\nl)) - ((= string-index -1) - (begin - (set! read-string - (%readline (if (string? prompt) - prompt - (prompt)) - input-port - output-port - read-hook)) - (set! string-index 0) - (if (not (eof-object? read-string)) - (begin - (or (string=? read-string "") - (add-history read-string)) - (get-character)) - read-string))) - (else - (let ((res (string-ref read-string string-index))) - (set! string-index (+ 1 string-index)) - (set! prompt prompt2) - res)))))) - (make-soft-port - (vector #f #f #f get-character #f) - "r")))) + (make-line-buffered-input-port (lambda (continuation?) + (let* ((prompt (if continuation? + prompt2 + prompt)) + (str (%readline (if (string? prompt) + prompt + (prompt)) + input-port + output-port + read-hook))) + (or (eof-object? str) + (string=? str "") + (add-history str)) + str)))) ;;; We only create one readline port. There's no point in having ;;; more, since they would all share the tty and history --- @@ -215,6 +195,7 @@ (lambda (prompt) (dynamic-wind (lambda () + (set-buffered-input-continuation?! (readline-port) #f) (set-readline-prompt! prompt "... ") (set-readline-read-hook! read-hook)) (lambda () (read)) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index cde7a3739..7b2fee1bc 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2001-03-05 Neil Jerram + + * buffered-input.scm: New file, with guts of line buffered input + port implementation extracted from guile-readline/readline.scm. + 2001-03-03 Mikael Djurfeldt * stack-catch.scm: New file. diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index 597124072..5bfe317e8 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -30,7 +30,8 @@ ice9_sources = \ posix.scm psyntax.pp psyntax.ss q.scm r4rs.scm r5rs.scm \ rdelim.scm receive.scm srfi-8.scm regex.scm runq.scm \ safe-r5rs.scm safe.scm session.scm slib.scm stack-catch.scm \ - streams.scm string-fun.scm syncase.scm tags.scm threads.scm + streams.scm string-fun.scm syncase.scm tags.scm threads.scm \ + buffered-input.scm subpkgdatadir = $(pkgdatadir)/$(VERSION)/ice-9 subpkgdata_DATA = $(ice9_sources) diff --git a/ice-9/buffered-input.scm b/ice-9/buffered-input.scm new file mode 100644 index 000000000..4e35d4d4b --- /dev/null +++ b/ice-9/buffered-input.scm @@ -0,0 +1,89 @@ +;;;; buffered-input.scm --- construct a port from a buffered input reader +;;;; +;;;; Copyright (C) 2001 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +(define-module (ice-9 buffered-input) + #:export (make-line-buffered-input-port + set-buffered-input-continuation?!)) + +;; @code{buffered-input-continuation?} is a property of the ports +;; created by @code{make-line-buffered-input-port} that stores the +;; read continuation flag for each such port. +(define buffered-input-continuation? (make-object-property)) + +(define (set-buffered-input-continuation?! port val) + "Set the read continuation flag for @var{port} to @var{val}. + +See @code{make-line-buffered-input-port} for the meaning and use of +this flag." + (set! (buffered-input-continuation? port) val)) + +(define (make-line-buffered-input-port reader) + "Construct a line-buffered input port from the specified @var{reader}. +@var{reader} should be a procedure of one argument that somehow reads +a line of input and returns it as a string @emph{without} the +terminating newline character. + +The port created by @code{make-line-buffered-input-port} automatically +adds a newline character after each string returned by @var{reader}; +this makes these ports useful for reading strings that extend across +more than one input line. + +@var{reader} should take a boolean @var{continuation?} argument. +@var{continuation?} indicates whether @var{reader} is being called to +start a logically new read operation (in which case +@var{continuation?} is @code{#f}) or to continue a read operation for +which some input has already been read (in which case +@var{continuation?} is @code{#t}). Some @var{reader} implementations +use the @var{continuation?} argument to determine what prompt to +display to the user. + +The new/continuation distinction is largely an application-level +concept, and @code{set-buffered-input-continuation?!} allows an +application some control over when a read operation is considered to +be new. But note that if there is data already buffered in the port +when a new read operation starts, this data will be read before the +first call to @var{reader}, and so @var{reader} will be called with +@var{continuation?} set to @code{#t}." + (let ((read-string "") + (string-index -1)) + (letrec ((get-character + (lambda () + (cond + ((eof-object? read-string) + read-string) + ((>= string-index (string-length read-string)) + (set! string-index -1) + #\nl) + ((= string-index -1) + (set! read-string (reader (buffered-input-continuation? port))) + (set! string-index 0) + (if (not (eof-object? read-string)) + (get-character) + read-string)) + (else + (let ((res (string-ref read-string string-index))) + (set! string-index (+ 1 string-index)) + (set! (buffered-input-continuation? port) #t) + res))))) + (port #f)) + (set! port (make-soft-port (vector #f #f #f get-character #f) "r")) + (set! (buffered-input-continuation? port) #f) + port))) + +;;; buffered-input.scm ends here From 618196705bda325bdf04c049f6c946844c9fbec1 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Mon, 5 Mar 2001 23:52:09 +0000 Subject: [PATCH 0653/2047] * Use "'()" instead of "()" in optargs.scm. --- ice-9/ChangeLog | 3 +++ ice-9/optargs.scm | 4 ++-- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 7b2fee1bc..dc33ec28a 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,5 +1,8 @@ 2001-03-05 Neil Jerram + * optargs.scm (rest-arg->keyword-binding-list): Use "'()" instead + of "()". + * buffered-input.scm: New file, with guts of line buffered input port implementation extracted from guile-readline/readline.scm. diff --git a/ice-9/optargs.scm b/ice-9/optargs.scm index 5de0fa43a..5506a388c 100644 --- a/ice-9/optargs.scm +++ b/ice-9/optargs.scm @@ -171,10 +171,10 @@ (define (rest-arg->keyword-binding-list rest-arg keywords allow-other-keys?) (if (null? rest-arg) - () + '() (let loop ((first (car rest-arg)) (rest (cdr rest-arg)) - (accum ())) + (accum '())) (let ((next (lambda (a) (if (null? (cdr rest)) a From d42df0557f79e42b1fa2b0379e8d5ae1aaacb66b Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 6 Mar 2001 01:00:18 +0000 Subject: [PATCH 0654/2047] * Don't include libguile/dump.h any more. --- ChangeLog | 4 ++++ libguile.h | 1 - 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index e988a15bf..7a9c75957 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2001-03-06 Dirk Herrmann + + * libguile.h: Removed #include "libguile/dump.h". + 2001-02-02 Keisuke Nishida * libguile.h: Added #include "libguile/dump.h". diff --git a/libguile.h b/libguile.h index 7e99e0efc..1ab96bf41 100644 --- a/libguile.h +++ b/libguile.h @@ -66,7 +66,6 @@ extern "C" { #include "libguile/debug.h" #include "libguile/stacks.h" #endif -#include "libguile/dump.h" #include "libguile/dynl.h" #include "libguile/dynwind.h" #include "libguile/eq.h" From 2ade72d773d77b516d881bdd5b05647ddc83bc0d Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 6 Mar 2001 01:22:37 +0000 Subject: [PATCH 0655/2047] * Remove uses of SCM_ASSERT that may result in error messages different from wrong-type-arg errors. --- libguile/ChangeLog | 15 ++++++++++ libguile/coop-threads.c | 21 +++++++------- libguile/load.c | 27 ++++++++---------- libguile/random.c | 10 +++++-- libguile/smob.c | 13 +++++---- libguile/struct.c | 62 ++++++++++++++++++++--------------------- 6 files changed, 84 insertions(+), 64 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 2978ce298..4528fab21 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,18 @@ +2001-03-06 Dirk Herrmann + + * coop-threads.c (scm_call_with_new_thread), load.c + (scm_primitive_load, scm_sys_search_load_path), random.c + (scm_c_default_rstate), struct.c (scm_make_struct_layout, + scm_struct_ref, scm_struct_set_x): Don't use SCM_ASSERT to + (potentially) issue a scm-misc-error or wrong-num-args error + message. + + * load.c (scm_search_path): Use SCM_ASSERT_TYPE to give details + about the expected type with the wrong-type-arg error message. + + * smob.c (scm_make_smob): Abort on misuse of smob - it indicates + a C level bug that can't be fixed from scheme anyway. + 2001-03-05 Mikael Djurfeldt * eval.c (scm_m_letstar): Removed check for duplicate bindings. diff --git a/libguile/coop-threads.c b/libguile/coop-threads.c index 60f07f64e..aa668e401 100644 --- a/libguile/coop-threads.c +++ b/libguile/coop-threads.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1997, 1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001 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 @@ -220,8 +220,10 @@ scheme_launch_thread (void *p) SCM_DEFER_INTS; } + SCM scm_call_with_new_thread (SCM argl) +#define FUNC_NAME s_call_with_new_thread { SCM thread; @@ -229,26 +231,23 @@ scm_call_with_new_thread (SCM argl) { register SCM args = argl; SCM thunk, handler; - SCM_ASSERT (SCM_NIMP (args), - scm_makfrom0str (s_call_with_new_thread), - SCM_WNA, NULL); + if (!SCM_CONSP (args)) + SCM_WRONG_NUM_ARGS (); thunk = SCM_CAR (args); SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk)), thunk, SCM_ARG1, s_call_with_new_thread); args = SCM_CDR (args); - SCM_ASSERT (SCM_NIMP (args), - scm_makfrom0str (s_call_with_new_thread), - SCM_WNA, NULL); + if (!SCM_CONSP (args)) + SCM_WRONG_NUM_ARGS (); handler = SCM_CAR (args); SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (handler)), handler, SCM_ARG2, s_call_with_new_thread); - SCM_ASSERT (SCM_NULLP (SCM_CDR (args)), - scm_makfrom0str (s_call_with_new_thread), - SCM_WNA, NULL); + if (!SCM_NULLP (SCM_CDR (args)) + SCM_WRONG_NUM_ARGS (); } /* Make new thread. */ @@ -285,6 +284,8 @@ scm_call_with_new_thread (SCM argl) return thread; } +#undef FUNC_NAME + /* This is the second thread spawning mechanism: threads from C */ diff --git a/libguile/load.c b/libguile/load.c index 5002be721..8be776db7 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001 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 @@ -114,9 +114,9 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0, { SCM hook = *scm_loc_load_hook; SCM_VALIDATE_STRING (1, filename); - SCM_ASSERT (SCM_FALSEP (hook) || (SCM_EQ_P (scm_procedure_p (hook), SCM_BOOL_T)), - hook, "value of %load-hook is neither a procedure nor #f", - FUNC_NAME); + if (!SCM_FALSEP (hook) && !SCM_EQ_P (scm_procedure_p (hook), SCM_BOOL_T)) + SCM_MISC_ERROR ("value of %load-hook is neither a procedure nor #f", + SCM_EOL); if (! SCM_FALSEP (hook)) scm_apply (hook, scm_listify (filename, SCM_UNDEFINED), SCM_EOL); @@ -301,9 +301,8 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, for (walk = path; !SCM_NULLP (walk); walk = SCM_CDR (walk)) { SCM elt = SCM_CAR (walk); - SCM_ASSERT (SCM_STRINGP (elt), elt, - "path is not a list of strings", - FUNC_NAME); + SCM_ASSERT_TYPE (SCM_STRINGP (elt), path, 1, FUNC_NAME, + "list of strings"); if (SCM_STRING_LENGTH (elt) > max_path_len) max_path_len = SCM_STRING_LENGTH (elt); } @@ -340,9 +339,8 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, for (walk = extensions; !SCM_NULLP (walk); walk = SCM_CDR (walk)) { SCM elt = SCM_CAR (walk); - SCM_ASSERT (SCM_STRINGP (elt), elt, - "extension list is not a list of strings", - FUNC_NAME); + SCM_ASSERT_TYPE (SCM_STRINGP (elt), elt, 3, FUNC_NAME, + "list of strings"); if (SCM_STRING_LENGTH (elt) > max_ext_len) max_ext_len = SCM_STRING_LENGTH (elt); } @@ -426,11 +424,10 @@ SCM_DEFINE (scm_sys_search_load_path, "%search-load-path", 1, 0, 0, SCM exts = *scm_loc_load_extensions; SCM_VALIDATE_STRING (1, filename); - SCM_ASSERT (scm_ilength (path) >= 0, path, "load path is not a proper list", - FUNC_NAME); - SCM_ASSERT (scm_ilength (exts) >= 0, exts, - "load extension list is not a proper list", - FUNC_NAME); + if (scm_ilength (path) < 0) + SCM_MISC_ERROR ("%load-path is not a proper list", SCM_EOL); + if (scm_ilength (exts) < 0) + SCM_MISC_ERROR ("%load-extension list is not a proper list", SCM_EOL); return scm_search_path (path, filename, exts); } #undef FUNC_NAME diff --git a/libguile/random.c b/libguile/random.c index 4af5c4aa6..f06d984f2 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1999,2000,2001 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 * the Free Software Foundation; either version 2, or (at your option) @@ -192,14 +192,18 @@ scm_c_make_rstate (char *seed, int n) return state; } + scm_rstate * scm_c_default_rstate () +#define FUNC_NAME "scm_c_default_rstate" { SCM state = SCM_CDR (scm_var_random_state); - SCM_ASSERT (SCM_RSTATEP (state), - state, "*random-state* contains bogus random state", 0); + if (!SCM_RSTATEP (state)) + SCM_MISC_ERROR ("*random-state* contains bogus random state", SCM_EOL); return SCM_RSTATE (state); } +#undef FUNC_NAME + inline double scm_c_uniform01 (scm_rstate *state) diff --git a/libguile/smob.c b/libguile/smob.c index 5c859e6d0..87f721207 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001 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 @@ -459,10 +459,13 @@ scm_make_smob (scm_bits_t tc) if (size != 0) { #if 0 - SCM_ASSERT (scm_smobs[n].mark == 0, - 0, - "forbidden operation for smobs with GC data, use SCM_NEWSMOB", - SCM_SMOBNAME (n)); + if (scm_smobs[n].mark != 0) + { + fprintf + (stderr, + "forbidden operation for smobs with GC data, use SCM_NEWSMOB\n"); + abort (); + } #endif SCM_SET_SMOB_DATA (z, scm_must_malloc (size, SCM_SMOBNAME (n))); } diff --git a/libguile/struct.c b/libguile/struct.c index f2d065b80..52af06f2e 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1996, 97, 98, 99, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1996,1997,1998,1999,2000,2001 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 @@ -82,14 +82,18 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, { SCM new_sym; SCM_VALIDATE_STRING (1, fields); + { /* scope */ char * field_desc; - int len; + scm_sizet len; int x; len = SCM_STRING_LENGTH (fields); + if (len % 2 == 1) + SCM_MISC_ERROR ("odd length field specification: ~S", + SCM_LIST1 (fields)); + field_desc = SCM_STRING_CHARS (fields); - SCM_ASSERT (!(len & 1), fields, "odd length field specification", FUNC_NAME); for (x = 0; x < len; x += 2) { @@ -104,35 +108,38 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, case 's': break; default: - SCM_ASSERT (0, SCM_MAKE_CHAR (field_desc[x]) , "unrecognized field type", FUNC_NAME); + SCM_MISC_ERROR ("unrecognized field type: ~S", + SCM_LIST1 (SCM_MAKE_CHAR (field_desc[x]))); } switch (field_desc[x + 1]) { case 'w': - SCM_ASSERT (field_desc[x] != 's', SCM_MAKE_CHAR (field_desc[x + 1]), - "self fields not writable", FUNC_NAME); - + if (field_desc[x] == 's') + SCM_MISC_ERROR ("self fields not writable", SCM_EOL); case 'r': case 'o': break; case 'R': case 'W': case 'O': - SCM_ASSERT (field_desc[x] != 's', SCM_MAKE_CHAR (field_desc[x + 1]), - "self fields not allowed in tail array", - FUNC_NAME); - SCM_ASSERT (x == len - 2, SCM_MAKE_CHAR (field_desc[x + 1]), - "tail array field must be last field in layout", - FUNC_NAME); + if (field_desc[x] == 's') + SCM_MISC_ERROR ("self fields not allowed in tail array", + SCM_EOL); + if (x != len - 2) + SCM_MISC_ERROR ("tail array field must be last field in layout", + SCM_EOL); break; default: - SCM_ASSERT (0, SCM_MAKE_CHAR (field_desc[x]) , "unrecognized ref specification", FUNC_NAME); + SCM_MISC_ERROR ("unrecognized ref specification: ~S", + SCM_LIST1 (SCM_MAKE_CHAR (field_desc[x + 1]))); } #if 0 if (field_desc[x] == 'd') { - SCM_ASSERT (field_desc[x + 2] == '-', SCM_MAKINUM (x / 2), "missing dash field", FUNC_NAME); + if (field_desc[x + 2] != '-') + SCM_MISC_ERROR ("missing dash field at position ~A", + SCM_LIST1 (SCM_MAKINUM (x / 2))); x += 2; goto recheck_ref; } @@ -592,16 +599,13 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0, if ((ref == 'R') || (ref == 'W')) field_type = 'u'; else - SCM_ASSERT (0, pos, "ref denied", FUNC_NAME); + SCM_MISC_ERROR ("ref denied for field ~A", SCM_LIST1 (pos)); } } else if (fields_desc[SCM_SYMBOL_LENGTH (layout) - 1] != 'O') field_type = fields_desc[SCM_SYMBOL_LENGTH (layout) - 2]; else - { - SCM_ASSERT (0, pos, "ref denied", FUNC_NAME); - abort (); - } + SCM_MISC_ERROR ("ref denied for field ~A", SCM_LIST1 (pos)); switch (field_type) { @@ -626,8 +630,8 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0, default: - SCM_ASSERT (0, SCM_MAKE_CHAR (field_type), "unrecognized field type", FUNC_NAME); - break; + SCM_MISC_ERROR ("unrecognized field type: ~S", + SCM_LIST1 (SCM_MAKE_CHAR (field_type))); } return answer; @@ -667,15 +671,12 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0, field_type = fields_desc[p * 2]; set_x = fields_desc [p * 2 + 1]; if (set_x != 'w') - SCM_ASSERT (0, pos, "set_x denied", FUNC_NAME); + SCM_MISC_ERROR ("set! denied for field ~A", SCM_LIST1 (pos)); } else if (fields_desc[SCM_SYMBOL_LENGTH (layout) - 1] == 'W') field_type = fields_desc[SCM_SYMBOL_LENGTH (layout) - 2]; else - { - SCM_ASSERT (0, pos, "set_x denied", FUNC_NAME); - abort (); - } + SCM_MISC_ERROR ("set! denied for field ~A", SCM_LIST1 (pos)); switch (field_type) { @@ -698,12 +699,11 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0, break; case 's': - SCM_ASSERT (0, SCM_MAKE_CHAR (field_type), "self fields immutable", FUNC_NAME); - break; + SCM_MISC_ERROR ("self fields immutable", SCM_EOL); default: - SCM_ASSERT (0, SCM_MAKE_CHAR (field_type), "unrecognized field type", FUNC_NAME); - break; + SCM_MISC_ERROR ("unrecognized field type: ~S", + SCM_LIST1 (SCM_MAKE_CHAR (field_type))); } return val; From 387c1a3bc0adc035dd5aa068288699b50105d250 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 6 Mar 2001 13:27:33 +0000 Subject: [PATCH 0656/2047] * The last patch has introduced a bad-bindings bug. Since it was unnecessary anyway, I simply reverted it. --- guile-config/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/guile-config/ChangeLog b/guile-config/ChangeLog index 277512916..5d620b5a2 100644 --- a/guile-config/ChangeLog +++ b/guile-config/ChangeLog @@ -1,3 +1,7 @@ +2001-03-06 Dirk Herrmann + + * guile-config.in (build-link): Reverted the previous patch. + 2001-03-05 Martin Grabmueller * guile-config.in (build-link): Fixed duplicate binding bug From 66418d34653d7a5bef7829f7bf1416e26f849541 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 7 Mar 2001 06:06:16 +0000 Subject: [PATCH 0657/2047] fix problems with gcc-2.96. --- libguile/ChangeLog | 9 +++++++++ libguile/Makefile.am | 5 ++++- libguile/guile-snarf.awk.in | 3 ++- 3 files changed, 15 insertions(+), 2 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 4528fab21..bb68ee217 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2001-03-07 Keisuke Nishida + + * Makefile.am (*.x): Add dependency on snarf.h and guile-doc-snarf.in. + (*.doc): Add dependency on guile-snarf.awk.in. + + * guile-snarf.awk.in: Neglect spaces at the end of + SCM_SNARF_DOCSTRING_END. Skip lines "# NN ..." in the + middle of docstrings. (To avoid the problem with gcc-2.96.) + 2001-03-06 Dirk Herrmann * coop-threads.c (scm_call_with_new_thread), load.c diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 350282d61..648cfdbe2 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -175,10 +175,13 @@ SUFFIXES = .x .doc .c.x: ./guile-doc-snarf $< $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \ || { rm $@; false; } -.x.doc: +.x.doc: ./guile-doc-snarf $(srcdir)/$*.c $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $(srcdir)/$*.c > /dev/null \ || { rm $@; false; } +*.x: snarf.h guile-doc-snarf.in +*.doc: guile-snarf.awk.in + error.x: cpp_err_symbols.c posix.x: cpp_sig_symbols.c load.x: libpath.h diff --git a/libguile/guile-snarf.awk.in b/libguile/guile-snarf.awk.in index 5c045fcf3..034aa9e6c 100644 --- a/libguile/guile-snarf.awk.in +++ b/libguile/guile-snarf.awk.in @@ -98,6 +98,7 @@ BEGIN { FS="|"; /SCM_SNARF_DOCSTRING_START/,/SCM_SNARF_DOCSTRING_END.*$/ { copy = $0; gsub(/.*SCM_SNARF_DOCSTRING_START/,"",copy); + sub(/^\#.*/,"", copy); sub(/^[ \t]*\"?/,"", copy); sub(/\"?[ \t]*SCM_SNARF_DOCSTRING_END.*$/,"", copy); gsub(/\\n\\n\"?/,"\n",copy); @@ -107,7 +108,7 @@ BEGIN { FS="|"; if (copy != "") { print copy > dot_doc_file } } -/SCM_SNARF_DOCSTRING_END[ \t]/ { print "@end deffn" >> dot_doc_file; } +/SCM_SNARF_DOCSTRING_END[ \t]*/ { print "@end deffn" >> dot_doc_file; } /\*&\*&\*&\*SCM_ARG_BETTER_BE_IN_POSITION/ { copy = $0; sub(/.*\*&\*&\*&\*SCM_ARG_BETTER_BE_IN_POSITION\([ \t]*/,"",copy); From 403a334593c717312a87f8a85f9ba8d7467a6933 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Wed, 7 Mar 2001 23:03:37 +0000 Subject: [PATCH 0658/2047] * Don't set continuation flag for leading whitespace. --- ice-9/ChangeLog | 6 ++++++ ice-9/buffered-input.scm | 3 ++- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index dc33ec28a..b45997dac 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,9 @@ +2001-03-07 Neil Jerram + + * buffered-input.scm (make-line-buffered-input-port): Don't set + the continuation flag for leading whitespace. Thanks to Dirk + Herrmann for the suggestion. + 2001-03-05 Neil Jerram * optargs.scm (rest-arg->keyword-binding-list): Use "'()" instead diff --git a/ice-9/buffered-input.scm b/ice-9/buffered-input.scm index 4e35d4d4b..df42cd533 100644 --- a/ice-9/buffered-input.scm +++ b/ice-9/buffered-input.scm @@ -79,7 +79,8 @@ first call to @var{reader}, and so @var{reader} will be called with (else (let ((res (string-ref read-string string-index))) (set! string-index (+ 1 string-index)) - (set! (buffered-input-continuation? port) #t) + (if (not (char-whitespace? res)) + (set! (buffered-input-continuation? port) #t)) res))))) (port #f)) (set! port (make-soft-port (vector #f #f #f get-character #f) "r")) From 75667911712fa9a17a8b991d0b93869f96a39859 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Thu, 8 Mar 2001 02:06:02 +0000 Subject: [PATCH 0659/2047] Removed some junk --- ice-9/ChangeLog | 1 - 1 file changed, 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index b45997dac..8733e6a66 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -324,7 +324,6 @@ (process-define-module): Bugfix: Make sure that exports are done *after* all used interfaces has been added. ->>>>>>> 1.341 2000-07-24 Marius Vollmer * common-list.scm (uniq): Made tail-recursive. Thanks to thi! From e96452c4e4e799259119b8282f19dfabef04ee79 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Thu, 8 Mar 2001 02:43:20 +0000 Subject: [PATCH 0660/2047] * guile-config.in (build-link): Really reverted the change of 2001-03-05. --- guile-config/ChangeLog | 5 ++++ guile-config/guile-config.in | 50 ++++++++++++++++++------------------ 2 files changed, 30 insertions(+), 25 deletions(-) diff --git a/guile-config/ChangeLog b/guile-config/ChangeLog index 5d620b5a2..ac7fa0ef0 100644 --- a/guile-config/ChangeLog +++ b/guile-config/ChangeLog @@ -1,3 +1,8 @@ +2001-03-07 Mikael Djurfeldt + + * guile-config.in (build-link): Really reverted the change of + 2001-03-05. + 2001-03-06 Dirk Herrmann * guile-config.in (build-link): Reverted the previous patch. diff --git a/guile-config/guile-config.in b/guile-config/guile-config.in index 6bb8c1e59..0e917889c 100644 --- a/guile-config/guile-config.in +++ b/guile-config/guile-config.in @@ -140,36 +140,36 @@ (string-append program-name " link: arguments to subcommand not yet implemented"))) - (let ((flags - (let loop ((libs - ;; Get the string of linker flags we used to build - ;; Guile, and break it up into a list. - (separate-fields-discarding-char #\space - (get-build-info 'LIBS) - list))) + (let* ((flags + (let loop ((libs + ;; Get the string of linker flags we used to build + ;; Guile, and break it up into a list. + (separate-fields-discarding-char #\space + (get-build-info 'LIBS) + list))) - (cond - ((null? libs) '()) + (cond + ((null? libs) '()) - ;; Turn any "FOO/libBAR.a" elements into "-lBAR". - ((match-lib (car libs)) - => (lambda (bar) - (cons (string-append "-l" bar) - (loop (cdr libs))))) + ;; Turn any "FOO/libBAR.a" elements into "-lBAR". + ((match-lib (car libs)) + => (lambda (bar) + (cons (string-append "-l" bar) + (loop (cdr libs))))) + + ;; Remove any empty strings that may have seeped in there. + ((string=? (car libs) "") (loop (cdr libs))) - ;; Remove any empty strings that may have seeped in there. - ((string=? (car libs) "") (loop (cdr libs))) - - (else (cons (car libs) (loop (cdr libs)))))))) + (else (cons (car libs) (loop (cdr libs))))))) - ;; Include libguile itself in the list, along with the - ;; directory it was installed in. - (let (flags (cons (string-append "-L" (get-build-info 'libdir)) - (cons "-lguile" flags))) + ;; Include libguile itself in the list, along with the + ;; directory it was installed in. + (flags (cons (string-append "-L" (get-build-info 'libdir)) + (cons "-lguile" flags)))) - ;; Display the flags, separated by spaces. - (display-separated flags) - (newline)))) + ;; Display the flags, separated by spaces. + (display-separated flags) + (newline))) (define (help-link) (let ((dle display-line-error)) From 70ce100d8a806ae87cb9afee0d2385dfaa2faaf6 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Thu, 8 Mar 2001 02:45:39 +0000 Subject: [PATCH 0661/2047] * coop-threads.c: Fixed change of 2001-03-06. --- libguile/coop-threads.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/coop-threads.c b/libguile/coop-threads.c index aa668e401..b8e52ef5f 100644 --- a/libguile/coop-threads.c +++ b/libguile/coop-threads.c @@ -246,7 +246,7 @@ scm_call_with_new_thread (SCM argl) handler, SCM_ARG2, s_call_with_new_thread); - if (!SCM_NULLP (SCM_CDR (args)) + if (!SCM_NULLP (SCM_CDR (args))) SCM_WRONG_NUM_ARGS (); } From a4c91488d316735f26c8b23b62938ebcc2303a0e Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Thu, 8 Mar 2001 02:46:38 +0000 Subject: [PATCH 0662/2047] * symbols.c, symbols.h (scm_sys_symbols): New function GUILE_DEBUG function. --- libguile/symbols.c | 15 +++++++++++++-- libguile/symbols.h | 5 ++++- 2 files changed, 17 insertions(+), 3 deletions(-) diff --git a/libguile/symbols.c b/libguile/symbols.c index 818fb5991..76e15cb8a 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998, 2000, 2001 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 @@ -70,6 +70,17 @@ static SCM symbols; +#ifdef GUILE_DEBUG +SCM_DEFINE (scm_sys_symbols, "%symbols", 0, 0, 0, + (), + "Return the system symbol obarray.") +#define FUNC_NAME s_scm_sys_symbols +{ + return symbols; +} +#undef FUNC_NAME +#endif + static char * @@ -864,7 +875,7 @@ SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0, void scm_symbols_prehistory () { - symbols = scm_make_weak_key_hash_table (SCM_MAKINUM (277)); + symbols = scm_make_weak_key_hash_table (SCM_MAKINUM (1009)); scm_permanent_object (symbols); } diff --git a/libguile/symbols.h b/libguile/symbols.h index 94ebc3c20..a2987aa47 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -2,7 +2,7 @@ #ifndef SYMBOLSH #define SYMBOLSH -/* Copyright (C) 1995,1996,1997,1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998, 2000, 2001 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 @@ -71,6 +71,9 @@ +#ifdef GUILE_DEBUG +extern SCM scm_sys_symbols (void); +#endif extern SCM scm_mem2symbol (const char*, scm_sizet); extern SCM scm_str2symbol (const char*); From 04a4d6664ae804493d1f18f808200d77ab891ca8 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Thu, 8 Mar 2001 02:49:34 +0000 Subject: [PATCH 0663/2047] *** empty log message *** --- libguile/ChangeLog | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index bb68ee217..f15e2b63b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,15 @@ +2001-03-07 Mikael Djurfeldt + + * symmbols.c (scm_symbols_prehistory): Changed symbol hash table + size from 277 --> 1009. + + * symbols.c, symbols.h (scm_sys_symbols): New function GUILE_DEBUG + function. + + * coop-threads.c: Fixed change of 2001-03-06. + + * validate.h: Code formatting. + 2001-03-07 Keisuke Nishida * Makefile.am (*.x): Add dependency on snarf.h and guile-doc-snarf.in. From 86b96c166b9925dc6c0048814e25bcb5ae846b0c Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Thu, 8 Mar 2001 18:05:39 +0000 Subject: [PATCH 0664/2047] * psyntax.ss: Added FSF copyright notice. Added a notice of changes in order to comply with paragraph 2a of the GPL. --- ice-9/ChangeLog | 5 +++++ ice-9/psyntax.ss | 25 ++++++++++++++++++++++++- 2 files changed, 29 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 8733e6a66..a82952e93 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2001-03-08 Mikael Djurfeldt + + * psyntax.ss: Added FSF copyright notice. Added a notice of + changes in order to comply with paragraph 2a of the GPL. + 2001-03-07 Neil Jerram * buffered-input.scm (make-line-buffered-input-port): Don't set diff --git a/ice-9/psyntax.ss b/ice-9/psyntax.ss index b49d148e1..608f99f5a 100644 --- a/ice-9/psyntax.ss +++ b/ice-9/psyntax.ss @@ -1,7 +1,31 @@ +;;;; Copyright (C) 2001 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; + + ;;; Portable implementation of syntax-case ;;; Extracted from Chez Scheme Version 5.9f ;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman +;;; Modified by Mikael Djurfeldt according +;;; to the ChangeLog distributed in the same directory as this file: +;;; 1997-08-19, 1997-09-03, 1997-09-10, 2000-08-13, 2000-08-24, +;;; 2000-09-12, 2001-03-08 + ;;; Copyright (c) 1992-1997 Cadence Research Systems ;;; Permission to copy this software, in whole or in part, to use this ;;; software for any lawful purpose, and to redistribute this software @@ -13,7 +37,6 @@ ;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY ;;; NATURE WHATSOEVER. - ;;; Before attempting to port this code to a new implementation of ;;; Scheme, please read the notes below carefully. From 3ffd876ae8c45568736ff0236bbe62487066d47b Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Thu, 8 Mar 2001 18:06:46 +0000 Subject: [PATCH 0665/2047] *** empty log message *** --- ice-9/ChangeLog | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index a82952e93..182ebe1e2 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,7 +1,8 @@ 2001-03-08 Mikael Djurfeldt * psyntax.ss: Added FSF copyright notice. Added a notice of - changes in order to comply with paragraph 2a of the GPL. + changes in order to comply with paragraph 2a of the GPL. (Thanks + to Keith Wright.) 2001-03-07 Neil Jerram From 9636b49cd2a1e3008c2df2eddcd8283ad45bc44a Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Thu, 8 Mar 2001 18:14:33 +0000 Subject: [PATCH 0666/2047] * hash.c (scm_string_hash): Don't downcase characters. --- libguile/ChangeLog | 6 +++++- libguile/hash.c | 6 +++--- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f15e2b63b..ea4f02905 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,6 +1,10 @@ +2001-03-08 Mikael Djurfeldt + + * hash.c (scm_string_hash): Don't downcase characters. + 2001-03-07 Mikael Djurfeldt - * symmbols.c (scm_symbols_prehistory): Changed symbol hash table + * symbols.c (scm_symbols_prehistory): Changed symbol hash table size from 277 --> 1009. * symbols.c, symbols.h (scm_sys_symbols): New function GUILE_DEBUG diff --git a/libguile/hash.c b/libguile/hash.c index ff9e45fd3..8f8dfbb7a 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997, 2000, 2001 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 @@ -69,7 +69,7 @@ scm_string_hash (const unsigned char *str, scm_sizet len) scm_sizet i = 5; unsigned long h = 264; while (i--) - h = (h << 8) + ((unsigned) (scm_downcase (str[h % len]))); + h = (h << 8) + (unsigned) str[h % len]; return h; } else @@ -77,7 +77,7 @@ scm_string_hash (const unsigned char *str, scm_sizet len) scm_sizet i = len; unsigned long h = 0; while (i) - h = (h << 8) + ((unsigned) (scm_downcase (str[--i]))); + h = (h << 8) + (unsigned) str[--i]; return h; } } From 5e4a4d09fe46d48f059b2869d0f4a0abd342c017 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Thu, 8 Mar 2001 19:34:41 +0000 Subject: [PATCH 0667/2047] * ramap.c (racp): Removed optimization which caused array copying to fail if the two arrays shared storage. Re-inserted the IVDEP macros removed in the change of 2000-03-09. (Don't really have a complete grasp of what they are for, but they seem to be necessary on Crays. This needs testing!) Thanks to Miroslav Silovic. --- libguile/ChangeLog | 6 +++ libguile/ramap.c | 106 ++++++++++++++++++++++++--------------------- 2 files changed, 63 insertions(+), 49 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index ea4f02905..8ebcea4c1 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,11 @@ 2001-03-08 Mikael Djurfeldt + * ramap.c (racp): Removed optimization which caused array copying + to fail if the two arrays shared storage. Re-inserted the IVDEP + macros removed in the change of 2000-03-09. (Don't really have a + complete grasp of what they are for, but they seem to be necessary + on Crays. This needs testing!) Thanks to Miroslav Silovic. + * hash.c (scm_string_hash): Don't downcase characters. 2001-03-07 Mikael Djurfeldt diff --git a/libguile/ramap.c b/libguile/ramap.c index 702979664..92aa19681 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1996, 1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1996, 1998, 2000, 2001 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 @@ -647,14 +647,6 @@ racp (SCM src, SCM dst) src = SCM_ARRAY_V (src); dst = SCM_ARRAY_V (dst); - - /* untested optimization: don't copy if we're we. This allows the - ugly UNICOS macros (IVDEP) to go . - */ - - if (SCM_EQ_P (src, dst)) - return 1 ; - switch SCM_TYP7 (dst) { default: @@ -663,7 +655,9 @@ racp (SCM src, SCM dst) case scm_tc7_wvect: for (; n-- > 0; i_s += inc_s, i_d += inc_d) - scm_array_set_x (dst, scm_cvref (src, i_s, SCM_UNDEFINED), SCM_MAKINUM (i_d)); + scm_array_set_x (dst, + scm_cvref (src, i_s, SCM_UNDEFINED), + SCM_MAKINUM (i_d)); break; case scm_tc7_string: if (SCM_TYP7 (src) != scm_tc7_string) @@ -675,7 +669,8 @@ racp (SCM src, SCM dst) if (SCM_TYP7 (src) != scm_tc7_byvect) goto gencase; for (; n-- > 0; i_s += inc_s, i_d += inc_d) - ((char *) SCM_UVECTOR_BASE (dst))[i_d] = ((char *) SCM_UVECTOR_BASE (src))[i_s]; + ((char *) SCM_UVECTOR_BASE (dst))[i_d] + = ((char *) SCM_UVECTOR_BASE (src))[i_s]; break; case scm_tc7_bvect: if (SCM_TYP7 (src) != scm_tc7_bvect) @@ -693,8 +688,9 @@ racp (SCM src, SCM dst) sv++; n -= SCM_LONG_BIT - (i_s % SCM_LONG_BIT); } + IVDEP (src != dst, for (; n >= SCM_LONG_BIT; n -= SCM_LONG_BIT, sv++, dv++) - * dv = *sv; + *dv = *sv;) if (n) /* trailing partial word */ *dv = (*dv & (~0L << n)) | (*sv & ~(~0L << n)); } @@ -713,8 +709,9 @@ racp (SCM src, SCM dst) else { long *d = (long *) SCM_VELTS (dst), *s = (long *) SCM_VELTS (src); + IVDEP (src != dst, for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = s[i_s]; + d[i_d] = s[i_s];) break; } case scm_tc7_ivect: @@ -723,9 +720,10 @@ racp (SCM src, SCM dst) else { long *d = (long *) SCM_VELTS (dst), *s = (long *) SCM_VELTS (src); - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = s[i_s]; - break; + IVDEP (src != dst, + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + d[i_d] = s[i_s];) + break; } case scm_tc7_fvect: { @@ -738,17 +736,20 @@ racp (SCM src, SCM dst) goto gencase; case scm_tc7_ivect: case scm_tc7_uvect: - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = ((long *) s)[i_s]; + IVDEP (src != dst, + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + d[i_d] = ((long *) s)[i_s];) break; case scm_tc7_fvect: - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = s[i_s]; + IVDEP (src != dst, + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + d[i_d] = s[i_s];) break; case scm_tc7_dvect: - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = ((double *) s)[i_s]; - break; + IVDEP (src !=dst, + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + d[i_d] = ((double *) s)[i_s];) + break; } break; } @@ -763,16 +764,19 @@ racp (SCM src, SCM dst) goto gencase; case scm_tc7_ivect: case scm_tc7_uvect: - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = ((long *) s)[i_s]; + IVDEP (src != dst, + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + d[i_d] = ((long *) s)[i_s];) break; case scm_tc7_fvect: - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = ((float *) s)[i_s]; + IVDEP (src != dst, + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + d[i_d] = ((float *) s)[i_s];) break; case scm_tc7_dvect: - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = s[i_s]; + IVDEP (src != dst, + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + d[i_d] = s[i_s];) break; } break; @@ -788,33 +792,37 @@ racp (SCM src, SCM dst) goto gencase; case scm_tc7_ivect: case scm_tc7_uvect: - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - { - d[i_d][0] = ((long *) s)[i_s]; - d[i_d][1] = 0.0; - } + IVDEP (src != dst, + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + { + d[i_d][0] = ((long *) s)[i_s]; + d[i_d][1] = 0.0; + }) break; case scm_tc7_fvect: - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - { - d[i_d][0] = ((float *) s)[i_s]; - d[i_d][1] = 0.0; - } + IVDEP (src != dst, + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + { + d[i_d][0] = ((float *) s)[i_s]; + d[i_d][1] = 0.0; + }) break; case scm_tc7_dvect: - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - { - d[i_d][0] = ((double *) s)[i_s]; - d[i_d][1] = 0.0; - } + IVDEP (src != dst, + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + { + d[i_d][0] = ((double *) s)[i_s]; + d[i_d][1] = 0.0; + }) break; case scm_tc7_cvect: - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - { - d[i_d][0] = s[i_s][0]; - d[i_d][1] = s[i_s][1]; + IVDEP (src != dst, + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + { + d[i_d][0] = s[i_s][0]; + d[i_d][1] = s[i_s][1]; + }) } - } break; } } From 6798371657d7091275315650604ab15cb26b0a40 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Thu, 8 Mar 2001 19:36:35 +0000 Subject: [PATCH 0668/2047] *** empty log message *** --- THANKS | 2 ++ 1 file changed, 2 insertions(+) diff --git a/THANKS b/THANKS index 84faf45ac..16d4d78ff 100644 --- a/THANKS +++ b/THANKS @@ -32,6 +32,8 @@ For fixes or providing information which led to a fix: David Pirotte Julian Satchell Bill Schottstaedt + Miroslav Silovic Dale P. Smith Jacques A. Vidrine. William Webber + Keith Wright From 650a1cf92946fd4ca4d1e5752055fbc717ae32ed Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 9 Mar 2001 00:21:27 +0000 Subject: [PATCH 0669/2047] * Docstring fixes. --- libguile/ChangeLog | 5 +++++ libguile/ports.c | 6 +++--- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 8ebcea4c1..23b5369d7 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-03-08 Neil Jerram + + * ports.c (scm_port_column): Docstring fixes: (i) port-line arg is + not optional (ii) "recommend" spelling correction. + 2001-03-08 Mikael Djurfeldt * ramap.c (racp): Removed optimization which caused array copying diff --git a/libguile/ports.c b/libguile/ports.c index f0111671e..313dea63e 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1395,13 +1395,13 @@ SCM_DEFINE (scm_set_port_line_x, "set-port-line!", 2, 0, 0, SCM_DEFINE (scm_port_column, "port-column", 1, 0, 0, (SCM port), - "@deffnx primitive port-line [input-port]\n" - "Return the current column number or line number of @var{input-port},\n" + "@deffnx primitive port-line port\n" + "Return the current column number or line number of @var{port},\n" "using the current input port if none is specified. If the number is\n" "unknown, the result is #f. Otherwise, the result is a 0-origin integer\n" "- i.e. the first character of the first line is line 0, column 0.\n" "(However, when you display a file position, for example in an error\n" - "message, we recommand you add 1 to get 1-origin integers. This is\n" + "message, we recommend you add 1 to get 1-origin integers. This is\n" "because lines and column numbers traditionally start with 1, and that is\n" "what non-programmers will find most natural.)") #define FUNC_NAME s_scm_port_column From a55134eded43dd41a8fbee7597c7e415d5ebfe77 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 9 Mar 2001 05:16:05 +0000 Subject: [PATCH 0670/2047] * match.scm: export defstruct. --- ice-9/ChangeLog | 4 ++++ ice-9/match.scm | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 182ebe1e2..67b350f40 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2001-03-09 Keisuke Nishida + + * match.scm: export defstruct. + 2001-03-08 Mikael Djurfeldt * psyntax.ss: Added FSF copyright notice. Added a notice of diff --git a/ice-9/match.scm b/ice-9/match.scm index a05d37eee..3a83aeac8 100644 --- a/ice-9/match.scm +++ b/ice-9/match.scm @@ -22,7 +22,7 @@ :use-module (ice-9 slib) :export (match match-lambda match-lambda* match-define match-let match-let* match-letrec - define-structure define-const-structure + defstruct define-structure define-const-structure match:error match:set-error match:error-control match:set-error-control match:structure-control match:set-structure-control From 4bc59ee759ca95cd47fd4962de9ece43f7ccc142 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 9 Mar 2001 08:09:48 +0000 Subject: [PATCH 0671/2047] * Removed old copy of data-rep.texi. --- doc/ChangeLog | 4 ++++ doc/data-rep.texi | 0 2 files changed, 4 insertions(+) delete mode 100644 doc/data-rep.texi diff --git a/doc/ChangeLog b/doc/ChangeLog index 6b36ebf49..00d087658 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,7 @@ +2001-03-09 Neil Jerram + + * data-rep.texi: Removed. + 2001-02-15 Neil Jerram * README: Explain retirement of `data-rep.texi'. diff --git a/doc/data-rep.texi b/doc/data-rep.texi deleted file mode 100644 index e69de29bb..000000000 From da00aada47a92ccd36fead74bd6a3638f4be6fd1 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 9 Mar 2001 08:16:16 +0000 Subject: [PATCH 0672/2047] Removed texinfo.tex --- doc/ChangeLog | 5 + doc/texinfo.tex | 4977 ----------------------------------------------- 2 files changed, 5 insertions(+), 4977 deletions(-) delete mode 100644 doc/texinfo.tex diff --git a/doc/ChangeLog b/doc/ChangeLog index 00d087658..2ccefcd44 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,5 +1,10 @@ 2001-03-09 Neil Jerram + Both the following files are about to be replaced by files from + guile-doc/ref. + + * texinfo.tex: Removed. + * data-rep.texi: Removed. 2001-02-15 Neil Jerram diff --git a/doc/texinfo.tex b/doc/texinfo.tex deleted file mode 100644 index 128a59b18..000000000 --- a/doc/texinfo.tex +++ /dev/null @@ -1,4977 +0,0 @@ -% texinfo.tex -- TeX macros to handle Texinfo files. -% $Id: texinfo.tex,v 1.1 1998-10-07 07:37:17 jimb Exp $ -% -% Copyright (C) 1985, 86, 88, 90, 91, 92, 93, 94, 95, 96, 97, 98 -% Free Software Foundation, Inc. -% -% This texinfo.tex file 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, or (at -% your option) any later version. -% -% This texinfo.tex file 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 this texinfo.tex file; see the file COPYING. If not, write -% to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -% Boston, MA 02111-1307, USA. -% -% In other words, you are welcome to use, share and improve this program. -% You are forbidden to forbid anyone else to use, share and improve -% what you give them. Help stamp out software-hoarding! -% -% Please try the latest version of texinfo.tex before submitting bug -% reports; you can get the latest version from: -% ftp://ftp.cs.umb.edu/pub/tex/texinfo.tex -% /home/gd/gnu/doc/texinfo.tex on the GNU machines. -% -% Send bug reports to bug-texinfo@gnu.org. -% Please include a precise test case in each bug report, -% including a complete document with which we can reproduce the problem. -% -% Texinfo macros (with @macro) are *not* supported by texinfo.tex. You -% have to run makeinfo -E to expand macros first; the texi2dvi script -% does this. - - -% Make it possible to create a .fmt file just by loading this file: -% if the underlying format is not loaded, start by loading it now. -% Added by gildea November 1993. -\expandafter\ifx\csname fmtname\endcsname\relax\input plain\fi - -% This automatically updates the version number based on RCS. -\def\deftexinfoversion$#1: #2 ${\def\texinfoversion{#2}} -\deftexinfoversion$Revision: 1.1 $ -\message{Loading texinfo package [Version \texinfoversion]:} - -% If in a .fmt file, print the version number -% and turn on active characters that we couldn't do earlier because -% they might have appeared in the input file name. -\everyjob{\message{[Texinfo version \texinfoversion]}\message{} - \catcode`+=\active \catcode`\_=\active} - -% Save some parts of plain tex whose names we will redefine. - -\let\ptexb=\b -\let\ptexbullet=\bullet -\let\ptexc=\c -\let\ptexcomma=\, -\let\ptexdot=\. -\let\ptexdots=\dots -\let\ptexend=\end -\let\ptexequiv=\equiv -\let\ptexexclam=\! -\let\ptexi=\i -\let\ptexlbrace=\{ -\let\ptexrbrace=\} -\let\ptexstar=\* -\let\ptext=\t - -% Be sure we're in horizontal mode when doing a tie, since we make space -% equivalent to this in @example-like environments. Otherwise, a space -% at the beginning of a line will start with \penalty -- and -% since \penalty is valid in vertical mode, we'd end up putting the -% penalty on the vertical list instead of in the new paragraph. -{\catcode`@ = 11 - % Avoid using \@M directly, because that causes trouble - % if the definition is written into an index file. - \global\let\tiepenalty = \@M - \gdef\tie{\leavevmode\penalty\tiepenalty\ } -} - - -\message{Basics,} -\chardef\other=12 - -% If this character appears in an error message or help string, it -% starts a new line in the output. -\newlinechar = `^^J - -% Set up fixed words for English. -\ifx\putwordChapter\undefined{\gdef\putwordChapter{Chapter}}\fi% -\def\putwordInfo{Info}% -\ifx\putwordSee\undefined{\gdef\putwordSee{See}}\fi% -\ifx\putwordsee\undefined{\gdef\putwordsee{see}}\fi% -\ifx\putwordfile\undefined{\gdef\putwordfile{file}}\fi% -\ifx\putwordpage\undefined{\gdef\putwordpage{page}}\fi% -\ifx\putwordsection\undefined{\gdef\putwordsection{section}}\fi% -\ifx\putwordSection\undefined{\gdef\putwordSection{Section}}\fi% -\ifx\putwordTableofContents\undefined{\gdef\putwordTableofContents{Table of Contents}}\fi% -\ifx\putwordShortContents\undefined{\gdef\putwordShortContents{Short Contents}}\fi% -\ifx\putwordAppendix\undefined{\gdef\putwordAppendix{Appendix}}\fi% - -% Ignore a token. -% -\def\gobble#1{} - -\hyphenation{ap-pen-dix} -\hyphenation{mini-buf-fer mini-buf-fers} -\hyphenation{eshell} -\hyphenation{white-space} - -% Margin to add to right of even pages, to left of odd pages. -\newdimen \bindingoffset -\newdimen \normaloffset -\newdimen\pagewidth \newdimen\pageheight - -% Sometimes it is convenient to have everything in the transcript file -% and nothing on the terminal. We don't just call \tracingall here, -% since that produces some useless output on the terminal. -% -\def\gloggingall{\begingroup \globaldefs = 1 \loggingall \endgroup}% -\def\loggingall{\tracingcommands2 \tracingstats2 - \tracingpages1 \tracingoutput1 \tracinglostchars1 - \tracingmacros2 \tracingparagraphs1 \tracingrestores1 - \showboxbreadth\maxdimen\showboxdepth\maxdimen -}% - -% For @cropmarks command. -% Do @cropmarks to get crop marks. -% -\newif\ifcropmarks -\let\cropmarks = \cropmarkstrue -% -% Dimensions to add cropmarks at corners. -% Added by P. A. MacKay, 12 Nov. 1986 -% -\newdimen\cornerlong \newdimen\cornerthick -\newdimen\topandbottommargin -\newdimen\outerhsize \newdimen\outervsize -\cornerlong=1pc\cornerthick=.3pt % These set size of cropmarks -\outerhsize=7in -%\outervsize=9.5in -% Alternative @smallbook page size is 9.25in -\outervsize=9.25in -\topandbottommargin=.75in - -% Main output routine. -\chardef\PAGE = 255 -\output = {\onepageout{\pagecontents\PAGE}} - -\newbox\headlinebox -\newbox\footlinebox - -% \onepageout takes a vbox as an argument. Note that \pagecontents -% does insertions, but you have to call it yourself. -\def\onepageout#1{% - \ifcropmarks \hoffset=0pt \else \hoffset=\normaloffset \fi - % - \ifodd\pageno \advance\hoffset by \bindingoffset - \else \advance\hoffset by -\bindingoffset\fi - % - % Do this outside of the \shipout so @code etc. will be expanded in - % the headline as they should be, not taken literally (outputting ''code). - \setbox\headlinebox = \vbox{\let\hsize=\pagewidth \makeheadline}% - \setbox\footlinebox = \vbox{\let\hsize=\pagewidth \makefootline}% - % - {% - % Have to do this stuff outside the \shipout because we want it to - % take effect in \write's, yet the group defined by the \vbox ends - % before the \shipout runs. - % - \escapechar = `\\ % use backslash in output files. - \indexdummies % don't expand commands in the output. - \normalturnoffactive % \ in index entries must not stay \, e.g., if - % the page break happens to be in the middle of an example. - \shipout\vbox{% - \ifcropmarks \vbox to \outervsize\bgroup - \hsize = \outerhsize - \line{\ewtop\hfil\ewtop}% - \nointerlineskip - \line{% - \vbox{\moveleft\cornerthick\nstop}% - \hfill - \vbox{\moveright\cornerthick\nstop}% - }% - \vskip\topandbottommargin - \line\bgroup - \hfil % center the page within the outer (page) hsize. - \ifodd\pageno\hskip\bindingoffset\fi - \vbox\bgroup - \fi - % - \unvbox\headlinebox - \pagebody{#1}% - \ifdim\ht\footlinebox > 0pt - % Only leave this space if the footline is nonempty. - % (We lessened \vsize for it in \oddfootingxxx.) - % The \baselineskip=24pt in plain's \makefootline has no effect. - \vskip 2\baselineskip - \unvbox\footlinebox - \fi - % - \ifcropmarks - \egroup % end of \vbox\bgroup - \hfil\egroup % end of (centering) \line\bgroup - \vskip\topandbottommargin plus1fill minus1fill - \boxmaxdepth = \cornerthick - \line{% - \vbox{\moveleft\cornerthick\nsbot}% - \hfill - \vbox{\moveright\cornerthick\nsbot}% - }% - \nointerlineskip - \line{\ewbot\hfil\ewbot}% - \egroup % \vbox from first cropmarks clause - \fi - }% end of \shipout\vbox - }% end of group with \turnoffactive - \advancepageno - \ifnum\outputpenalty>-20000 \else\dosupereject\fi -} - -\newinsert\margin \dimen\margin=\maxdimen - -\def\pagebody#1{\vbox to\pageheight{\boxmaxdepth=\maxdepth #1}} -{\catcode`\@ =11 -\gdef\pagecontents#1{\ifvoid\topins\else\unvbox\topins\fi -% marginal hacks, juha@viisa.uucp (Juha Takala) -\ifvoid\margin\else % marginal info is present - \rlap{\kern\hsize\vbox to\z@{\kern1pt\box\margin \vss}}\fi -\dimen@=\dp#1 \unvbox#1 -\ifvoid\footins\else\vskip\skip\footins\footnoterule \unvbox\footins\fi -\ifr@ggedbottom \kern-\dimen@ \vfil \fi} -} - -% Here are the rules for the cropmarks. Note that they are -% offset so that the space between them is truly \outerhsize or \outervsize -% (P. A. MacKay, 12 November, 1986) -% -\def\ewtop{\vrule height\cornerthick depth0pt width\cornerlong} -\def\nstop{\vbox - {\hrule height\cornerthick depth\cornerlong width\cornerthick}} -\def\ewbot{\vrule height0pt depth\cornerthick width\cornerlong} -\def\nsbot{\vbox - {\hrule height\cornerlong depth\cornerthick width\cornerthick}} - -% Parse an argument, then pass it to #1. The argument is the rest of -% the input line (except we remove a trailing comment). #1 should be a -% macro which expects an ordinary undelimited TeX argument. -% -\def\parsearg#1{% - \let\next = #1% - \begingroup - \obeylines - \futurelet\temp\parseargx -} - -% If the next token is an obeyed space (from an @example environment or -% the like), remove it and recurse. Otherwise, we're done. -\def\parseargx{% - % \obeyedspace is defined far below, after the definition of \sepspaces. - \ifx\obeyedspace\temp - \expandafter\parseargdiscardspace - \else - \expandafter\parseargline - \fi -} - -% Remove a single space (as the delimiter token to the macro call). -{\obeyspaces % - \gdef\parseargdiscardspace {\futurelet\temp\parseargx}} - -{\obeylines % - \gdef\parseargline#1^^M{% - \endgroup % End of the group started in \parsearg. - % - % First remove any @c comment, then any @comment. - % Result of each macro is put in \toks0. - \argremovec #1\c\relax % - \expandafter\argremovecomment \the\toks0 \comment\relax % - % - % Call the caller's macro, saved as \next in \parsearg. - \expandafter\next\expandafter{\the\toks0}% - }% -} - -% Since all \c{,omment} does is throw away the argument, we can let TeX -% do that for us. The \relax here is matched by the \relax in the call -% in \parseargline; it could be more or less anything, its purpose is -% just to delimit the argument to the \c. -\def\argremovec#1\c#2\relax{\toks0 = {#1}} -\def\argremovecomment#1\comment#2\relax{\toks0 = {#1}} - -% \argremovec{,omment} might leave us with trailing spaces, though; e.g., -% @end itemize @c foo -% will have two active spaces as part of the argument with the -% `itemize'. Here we remove all active spaces from #1, and assign the -% result to \toks0. -% -% This loses if there are any *other* active characters besides spaces -% in the argument -- _ ^ +, for example -- since they get expanded. -% Fortunately, Texinfo does not define any such commands. (If it ever -% does, the catcode of the characters in questionwill have to be changed -% here.) But this means we cannot call \removeactivespaces as part of -% \argremovec{,omment}, since @c uses \parsearg, and thus the argument -% that \parsearg gets might well have any character at all in it. -% -\def\removeactivespaces#1{% - \begingroup - \ignoreactivespaces - \edef\temp{#1}% - \global\toks0 = \expandafter{\temp}% - \endgroup -} - -% Change the active space to expand to nothing. -% -\begingroup - \obeyspaces - \gdef\ignoreactivespaces{\obeyspaces\let =\empty} -\endgroup - - -\def\flushcr{\ifx\par\lisppar \def\next##1{}\else \let\next=\relax \fi \next} - -%% These are used to keep @begin/@end levels from running away -%% Call \inENV within environments (after a \begingroup) -\newif\ifENV \ENVfalse \def\inENV{\ifENV\relax\else\ENVtrue\fi} -\def\ENVcheck{% -\ifENV\errmessage{Still within an environment. Type Return to continue.} -\endgroup\fi} % This is not perfect, but it should reduce lossage - -% @begin foo is the same as @foo, for now. -\newhelp\EMsimple{Type to continue.} - -\outer\def\begin{\parsearg\beginxxx} - -\def\beginxxx #1{% -\expandafter\ifx\csname #1\endcsname\relax -{\errhelp=\EMsimple \errmessage{Undefined command @begin #1}}\else -\csname #1\endcsname\fi} - -% @end foo executes the definition of \Efoo. -% -\def\end{\parsearg\endxxx} -\def\endxxx #1{% - \removeactivespaces{#1}% - \edef\endthing{\the\toks0}% - % - \expandafter\ifx\csname E\endthing\endcsname\relax - \expandafter\ifx\csname \endthing\endcsname\relax - % There's no \foo, i.e., no ``environment'' foo. - \errhelp = \EMsimple - \errmessage{Undefined command `@end \endthing'}% - \else - \unmatchedenderror\endthing - \fi - \else - % Everything's ok; the right environment has been started. - \csname E\endthing\endcsname - \fi -} - -% There is an environment #1, but it hasn't been started. Give an error. -% -\def\unmatchedenderror#1{% - \errhelp = \EMsimple - \errmessage{This `@end #1' doesn't have a matching `@#1'}% -} - -% Define the control sequence \E#1 to give an unmatched @end error. -% -\def\defineunmatchedend#1{% - \expandafter\def\csname E#1\endcsname{\unmatchedenderror{#1}}% -} - - -% Single-spacing is done by various environments (specifically, in -% \nonfillstart and \quotations). -\newskip\singlespaceskip \singlespaceskip = 12.5pt -\def\singlespace{% - % Why was this kern here? It messes up equalizing space above and below - % environments. --karl, 6may93 - %{\advance \baselineskip by -\singlespaceskip - %\kern \baselineskip}% - \setleading \singlespaceskip -} - -%% Simple single-character @ commands - -% @@ prints an @ -% Kludge this until the fonts are right (grr). -\def\@{{\tt \char '100}} - -% This is turned off because it was never documented -% and you can use @w{...} around a quote to suppress ligatures. -%% Define @` and @' to be the same as ` and ' -%% but suppressing ligatures. -%\def\`{{`}} -%\def\'{{'}} - -% Used to generate quoted braces. -\def\mylbrace {{\tt \char '173}} -\def\myrbrace {{\tt \char '175}} -\let\{=\mylbrace -\let\}=\myrbrace -\begingroup - % Definitions to produce actual \{ & \} command in an index. - \catcode`\{ = 12 \catcode`\} = 12 - \catcode`\[ = 1 \catcode`\] = 2 - \catcode`\@ = 0 \catcode`\\ = 12 - @gdef@lbracecmd[\{]% - @gdef@rbracecmd[\}]% -@endgroup - -% Accents: @, @dotaccent @ringaccent @ubaraccent @udotaccent -% Others are defined by plain TeX: @` @' @" @^ @~ @= @v @H. -\let\, = \c -\let\dotaccent = \. -\def\ringaccent#1{{\accent23 #1}} -\let\tieaccent = \t -\let\ubaraccent = \b -\let\udotaccent = \d - -% Other special characters: @questiondown @exclamdown -% Plain TeX defines: @AA @AE @O @OE @L (and lowercase versions) @ss. -\def\questiondown{?`} -\def\exclamdown{!`} - -% Dotless i and dotless j, used for accents. -\def\imacro{i} -\def\jmacro{j} -\def\dotless#1{% - \def\temp{#1}% - \ifx\temp\imacro \ptexi - \else\ifx\temp\jmacro \j - \else \errmessage{@dotless can be used only with i or j}% - \fi\fi -} - -% @: forces normal size whitespace following. -\def\:{\spacefactor=1000 } - -% @* forces a line break. -\def\*{\hfil\break\hbox{}\ignorespaces} - -% @. is an end-of-sentence period. -\def\.{.\spacefactor=3000 } - -% @! is an end-of-sentence bang. -\def\!{!\spacefactor=3000 } - -% @? is an end-of-sentence query. -\def\?{?\spacefactor=3000 } - -% @w prevents a word break. Without the \leavevmode, @w at the -% beginning of a paragraph, when TeX is still in vertical mode, would -% produce a whole line of output instead of starting the paragraph. -\def\w#1{\leavevmode\hbox{#1}} - -% @group ... @end group forces ... to be all on one page, by enclosing -% it in a TeX vbox. We use \vtop instead of \vbox to construct the box -% to keep its height that of a normal line. According to the rules for -% \topskip (p.114 of the TeXbook), the glue inserted is -% max (\topskip - \ht (first item), 0). If that height is large, -% therefore, no glue is inserted, and the space between the headline and -% the text is small, which looks bad. -% -\def\group{\begingroup - \ifnum\catcode13=\active \else - \errhelp = \groupinvalidhelp - \errmessage{@group invalid in context where filling is enabled}% - \fi - % - % The \vtop we start below produces a box with normal height and large - % depth; thus, TeX puts \baselineskip glue before it, and (when the - % next line of text is done) \lineskip glue after it. (See p.82 of - % the TeXbook.) Thus, space below is not quite equal to space - % above. But it's pretty close. - \def\Egroup{% - \egroup % End the \vtop. - \endgroup % End the \group. - }% - % - \vtop\bgroup - % We have to put a strut on the last line in case the @group is in - % the midst of an example, rather than completely enclosing it. - % Otherwise, the interline space between the last line of the group - % and the first line afterwards is too small. But we can't put the - % strut in \Egroup, since there it would be on a line by itself. - % Hence this just inserts a strut at the beginning of each line. - \everypar = {\strut}% - % - % Since we have a strut on every line, we don't need any of TeX's - % normal interline spacing. - \offinterlineskip - % - % OK, but now we have to do something about blank - % lines in the input in @example-like environments, which normally - % just turn into \lisppar, which will insert no space now that we've - % turned off the interline space. Simplest is to make them be an - % empty paragraph. - \ifx\par\lisppar - \edef\par{\leavevmode \par}% - % - % Reset ^^M's definition to new definition of \par. - \obeylines - \fi - % - % Do @comment since we are called inside an environment such as - % @example, where each end-of-line in the input causes an - % end-of-line in the output. We don't want the end-of-line after - % the `@group' to put extra space in the output. Since @group - % should appear on a line by itself (according to the Texinfo - % manual), we don't worry about eating any user text. - \comment -} -% -% TeX puts in an \escapechar (i.e., `@') at the beginning of the help -% message, so this ends up printing `@group can only ...'. -% -\newhelp\groupinvalidhelp{% -group can only be used in environments such as @example,^^J% -where each line of input produces a line of output.} - -% @need space-in-mils -% forces a page break if there is not space-in-mils remaining. - -\newdimen\mil \mil=0.001in - -\def\need{\parsearg\needx} - -% Old definition--didn't work. -%\def\needx #1{\par % -%% This method tries to make TeX break the page naturally -%% if the depth of the box does not fit. -%{\baselineskip=0pt% -%\vtop to #1\mil{\vfil}\kern -#1\mil\penalty 10000 -%\prevdepth=-1000pt -%}} - -\def\needx#1{% - % Go into vertical mode, so we don't make a big box in the middle of a - % paragraph. - \par - % - % Don't add any leading before our big empty box, but allow a page - % break, since the best break might be right here. - \allowbreak - \nointerlineskip - \vtop to #1\mil{\vfil}% - % - % TeX does not even consider page breaks if a penalty added to the - % main vertical list is 10000 or more. But in order to see if the - % empty box we just added fits on the page, we must make it consider - % page breaks. On the other hand, we don't want to actually break the - % page after the empty box. So we use a penalty of 9999. - % - % There is an extremely small chance that TeX will actually break the - % page at this \penalty, if there are no other feasible breakpoints in - % sight. (If the user is using lots of big @group commands, which - % almost-but-not-quite fill up a page, TeX will have a hard time doing - % good page breaking, for example.) However, I could not construct an - % example where a page broke at this \penalty; if it happens in a real - % document, then we can reconsider our strategy. - \penalty9999 - % - % Back up by the size of the box, whether we did a page break or not. - \kern -#1\mil - % - % Do not allow a page break right after this kern. - \nobreak -} - -% @br forces paragraph break - -\let\br = \par - -% @dots{} output an ellipsis using the current font. -% We do .5em per period so that it has the same spacing in a typewriter -% font as three actual period characters. -% -\def\dots{\hbox to 1.5em{% - \hskip 0pt plus 0.25fil minus 0.25fil - .\hss.\hss.% - \hskip 0pt plus 0.5fil minus 0.5fil -}} - -% @enddots{} is an end-of-sentence ellipsis. -% -\def\enddots{% - \hbox to 2em{% - \hskip 0pt plus 0.25fil minus 0.25fil - .\hss.\hss.\hss.% - \hskip 0pt plus 0.5fil minus 0.5fil - }% - \spacefactor=3000 -} - - -% @page forces the start of a new page - -\def\page{\par\vfill\supereject} - -% @exdent text.... -% outputs text on separate line in roman font, starting at standard page margin - -% This records the amount of indent in the innermost environment. -% That's how much \exdent should take out. -\newskip\exdentamount - -% This defn is used inside fill environments such as @defun. -\def\exdent{\parsearg\exdentyyy} -\def\exdentyyy #1{{\hfil\break\hbox{\kern -\exdentamount{\rm#1}}\hfil\break}} - -% This defn is used inside nofill environments such as @example. -\def\nofillexdent{\parsearg\nofillexdentyyy} -\def\nofillexdentyyy #1{{\advance \leftskip by -\exdentamount -\leftline{\hskip\leftskip{\rm#1}}}} - -% @inmargin{TEXT} puts TEXT in the margin next to the current paragraph. - -\def\inmargin#1{% -\strut\vadjust{\nobreak\kern-\strutdepth - \vtop to \strutdepth{\baselineskip\strutdepth\vss - \llap{\rightskip=\inmarginspacing \vbox{\noindent #1}}\null}}} -\newskip\inmarginspacing \inmarginspacing=1cm -\def\strutdepth{\dp\strutbox} - -%\hbox{{\rm#1}}\hfil\break}} - -% @include file insert text of that file as input. -% Allow normal characters that we make active in the argument (a file name). -\def\include{\begingroup - \catcode`\\=12 - \catcode`~=12 - \catcode`^=12 - \catcode`_=12 - \catcode`|=12 - \catcode`<=12 - \catcode`>=12 - \catcode`+=12 - \parsearg\includezzz} -% Restore active chars for included file. -\def\includezzz#1{\endgroup\begingroup - % Read the included file in a group so nested @include's work. - \def\thisfile{#1}% - \input\thisfile -\endgroup} - -\def\thisfile{} - -% @center line outputs that line, centered - -\def\center{\parsearg\centerzzz} -\def\centerzzz #1{{\advance\hsize by -\leftskip -\advance\hsize by -\rightskip -\centerline{#1}}} - -% @sp n outputs n lines of vertical space - -\def\sp{\parsearg\spxxx} -\def\spxxx #1{\vskip #1\baselineskip} - -% @comment ...line which is ignored... -% @c is the same as @comment -% @ignore ... @end ignore is another way to write a comment - -\def\comment{\catcode 64=\other \catcode 123=\other \catcode 125=\other% -\parsearg \commentxxx} - -\def\commentxxx #1{\catcode 64=0 \catcode 123=1 \catcode 125=2 } - -\let\c=\comment - -% @paragraphindent is defined for the Info formatting commands only. -\let\paragraphindent=\comment - -% Prevent errors for section commands. -% Used in @ignore and in failing conditionals. -\def\ignoresections{% -\let\chapter=\relax -\let\unnumbered=\relax -\let\top=\relax -\let\unnumberedsec=\relax -\let\unnumberedsection=\relax -\let\unnumberedsubsec=\relax -\let\unnumberedsubsection=\relax -\let\unnumberedsubsubsec=\relax -\let\unnumberedsubsubsection=\relax -\let\section=\relax -\let\subsec=\relax -\let\subsubsec=\relax -\let\subsection=\relax -\let\subsubsection=\relax -\let\appendix=\relax -\let\appendixsec=\relax -\let\appendixsection=\relax -\let\appendixsubsec=\relax -\let\appendixsubsection=\relax -\let\appendixsubsubsec=\relax -\let\appendixsubsubsection=\relax -\let\contents=\relax -\let\smallbook=\relax -\let\titlepage=\relax -} - -% Used in nested conditionals, where we have to parse the Texinfo source -% and so want to turn off most commands, in case they are used -% incorrectly. -% -\def\ignoremorecommands{% - \let\defcodeindex = \relax - \let\defcv = \relax - \let\deffn = \relax - \let\deffnx = \relax - \let\defindex = \relax - \let\defivar = \relax - \let\defmac = \relax - \let\defmethod = \relax - \let\defop = \relax - \let\defopt = \relax - \let\defspec = \relax - \let\deftp = \relax - \let\deftypefn = \relax - \let\deftypefun = \relax - \let\deftypevar = \relax - \let\deftypevr = \relax - \let\defun = \relax - \let\defvar = \relax - \let\defvr = \relax - \let\ref = \relax - \let\xref = \relax - \let\printindex = \relax - \let\pxref = \relax - \let\settitle = \relax - \let\setchapternewpage = \relax - \let\setchapterstyle = \relax - \let\everyheading = \relax - \let\evenheading = \relax - \let\oddheading = \relax - \let\everyfooting = \relax - \let\evenfooting = \relax - \let\oddfooting = \relax - \let\headings = \relax - \let\include = \relax - \let\lowersections = \relax - \let\down = \relax - \let\raisesections = \relax - \let\up = \relax - \let\set = \relax - \let\clear = \relax - \let\item = \relax -} - -% Ignore @ignore ... @end ignore. -% -\def\ignore{\doignore{ignore}} - -% Ignore @ifinfo, @ifhtml, @ifnottex, @html, @menu, and @direntry text. -% -\def\ifinfo{\doignore{ifinfo}} -\def\ifhtml{\doignore{ifhtml}} -\def\ifnottex{\doignore{ifnottex}} -\def\html{\doignore{html}} -\def\menu{\doignore{menu}} -\def\direntry{\doignore{direntry}} - -% Also ignore @macro ... @end macro. The user must run texi2dvi, -% which runs makeinfo to do macro expansion. Ignore @unmacro, too. -\def\macro{\doignore{macro}} -\let\unmacro = \comment - - -% @dircategory CATEGORY -- specify a category of the dir file -% which this file should belong to. Ignore this in TeX. -\let\dircategory = \comment - -% Ignore text until a line `@end #1'. -% -\def\doignore#1{\begingroup - % Don't complain about control sequences we have declared \outer. - \ignoresections - % - % Define a command to swallow text until we reach `@end #1'. - \long\def\doignoretext##1\end #1{\enddoignore}% - % - % Make sure that spaces turn into tokens that match what \doignoretext wants. - \catcode32 = 10 - % - % Ignore braces, too, so mismatched braces don't cause trouble. - \catcode`\{ = 9 - \catcode`\} = 9 - % - % And now expand that command. - \doignoretext -} - -% What we do to finish off ignored text. -% -\def\enddoignore{\endgroup\ignorespaces}% - -\newif\ifwarnedobs\warnedobsfalse -\def\obstexwarn{% - \ifwarnedobs\relax\else - % We need to warn folks that they may have trouble with TeX 3.0. - % This uses \immediate\write16 rather than \message to get newlines. - \immediate\write16{} - \immediate\write16{***WARNING*** for users of Unix TeX 3.0!} - \immediate\write16{This manual trips a bug in TeX version 3.0 (tex hangs).} - \immediate\write16{If you are running another version of TeX, relax.} - \immediate\write16{If you are running Unix TeX 3.0, kill this TeX process.} - \immediate\write16{ Then upgrade your TeX installation if you can.} - \immediate\write16{ (See ftp://ftp.gnu.ai.mit.edu/pub/gnu/TeX.README.)} - \immediate\write16{If you are stuck with version 3.0, run the} - \immediate\write16{ script ``tex3patch'' from the Texinfo distribution} - \immediate\write16{ to use a workaround.} - \immediate\write16{} - \global\warnedobstrue - \fi -} - -% **In TeX 3.0, setting text in \nullfont hangs tex. For a -% workaround (which requires the file ``dummy.tfm'' to be installed), -% uncomment the following line: -%%%%%\font\nullfont=dummy\let\obstexwarn=\relax - -% Ignore text, except that we keep track of conditional commands for -% purposes of nesting, up to an `@end #1' command. -% -\def\nestedignore#1{% - \obstexwarn - % We must actually expand the ignored text to look for the @end - % command, so that nested ignore constructs work. Thus, we put the - % text into a \vbox and then do nothing with the result. To minimize - % the change of memory overflow, we follow the approach outlined on - % page 401 of the TeXbook: make the current font be a dummy font. - % - \setbox0 = \vbox\bgroup - % Don't complain about control sequences we have declared \outer. - \ignoresections - % - % Define `@end #1' to end the box, which will in turn undefine the - % @end command again. - \expandafter\def\csname E#1\endcsname{\egroup\ignorespaces}% - % - % We are going to be parsing Texinfo commands. Most cause no - % trouble when they are used incorrectly, but some commands do - % complicated argument parsing or otherwise get confused, so we - % undefine them. - % - % We can't do anything about stray @-signs, unfortunately; - % they'll produce `undefined control sequence' errors. - \ignoremorecommands - % - % Set the current font to be \nullfont, a TeX primitive, and define - % all the font commands to also use \nullfont. We don't use - % dummy.tfm, as suggested in the TeXbook, because not all sites - % might have that installed. Therefore, math mode will still - % produce output, but that should be an extremely small amount of - % stuff compared to the main input. - % - \nullfont - \let\tenrm = \nullfont \let\tenit = \nullfont \let\tensl = \nullfont - \let\tenbf = \nullfont \let\tentt = \nullfont \let\smallcaps = \nullfont - \let\tensf = \nullfont - % Similarly for index fonts (mostly for their use in - % smallexample) - \let\indrm = \nullfont \let\indit = \nullfont \let\indsl = \nullfont - \let\indbf = \nullfont \let\indtt = \nullfont \let\indsc = \nullfont - \let\indsf = \nullfont - % - % Don't complain when characters are missing from the fonts. - \tracinglostchars = 0 - % - % Don't bother to do space factor calculations. - \frenchspacing - % - % Don't report underfull hboxes. - \hbadness = 10000 - % - % Do minimal line-breaking. - \pretolerance = 10000 - % - % Do not execute instructions in @tex - \def\tex{\doignore{tex}}% -} - -% @set VAR sets the variable VAR to an empty value. -% @set VAR REST-OF-LINE sets VAR to the value REST-OF-LINE. -% -% Since we want to separate VAR from REST-OF-LINE (which might be -% empty), we can't just use \parsearg; we have to insert a space of our -% own to delimit the rest of the line, and then take it out again if we -% didn't need it. Make sure the catcode of space is correct to avoid -% losing inside @example, for instance. -% -\def\set{\begingroup\catcode` =10 - \catcode`\-=12 \catcode`\_=12 % Allow - and _ in VAR. - \parsearg\setxxx} -\def\setxxx#1{\setyyy#1 \endsetyyy} -\def\setyyy#1 #2\endsetyyy{% - \def\temp{#2}% - \ifx\temp\empty \global\expandafter\let\csname SET#1\endcsname = \empty - \else \setzzz{#1}#2\endsetzzz % Remove the trailing space \setxxx inserted. - \fi - \endgroup -} -% Can't use \xdef to pre-expand #2 and save some time, since \temp or -% \next or other control sequences that we've defined might get us into -% an infinite loop. Consider `@set foo @cite{bar}'. -\def\setzzz#1#2 \endsetzzz{\expandafter\gdef\csname SET#1\endcsname{#2}} - -% @clear VAR clears (i.e., unsets) the variable VAR. -% -\def\clear{\parsearg\clearxxx} -\def\clearxxx#1{\global\expandafter\let\csname SET#1\endcsname=\relax} - -% @value{foo} gets the text saved in variable foo. -% -\def\value{\begingroup - \catcode`\-=12 \catcode`\_=12 % Allow - and _ in VAR. - \valuexxx} -\def\valuexxx#1{% - \expandafter\ifx\csname SET#1\endcsname\relax - {\{No value for ``#1''\}}% - \else - \csname SET#1\endcsname - \fi -\endgroup} - -% @ifset VAR ... @end ifset reads the `...' iff VAR has been defined -% with @set. -% -\def\ifset{\parsearg\ifsetxxx} -\def\ifsetxxx #1{% - \expandafter\ifx\csname SET#1\endcsname\relax - \expandafter\ifsetfail - \else - \expandafter\ifsetsucceed - \fi -} -\def\ifsetsucceed{\conditionalsucceed{ifset}} -\def\ifsetfail{\nestedignore{ifset}} -\defineunmatchedend{ifset} - -% @ifclear VAR ... @end ifclear reads the `...' iff VAR has never been -% defined with @set, or has been undefined with @clear. -% -\def\ifclear{\parsearg\ifclearxxx} -\def\ifclearxxx #1{% - \expandafter\ifx\csname SET#1\endcsname\relax - \expandafter\ifclearsucceed - \else - \expandafter\ifclearfail - \fi -} -\def\ifclearsucceed{\conditionalsucceed{ifclear}} -\def\ifclearfail{\nestedignore{ifclear}} -\defineunmatchedend{ifclear} - -% @iftex, @ifnothtml, @ifnotinfo always succeed; we read the text -% following, through the first @end iftex (etc.). Make `@end iftex' -% (etc.) valid only after an @iftex. -% -\def\iftex{\conditionalsucceed{iftex}} -\def\ifnothtml{\conditionalsucceed{ifnothtml}} -\def\ifnotinfo{\conditionalsucceed{ifnotinfo}} -\defineunmatchedend{iftex} -\defineunmatchedend{ifnothtml} -\defineunmatchedend{ifnotinfo} - -% We can't just want to start a group at @iftex (for example) and end it -% at @end iftex, since then @set commands inside the conditional have no -% effect (they'd get reverted at the end of the group). So we must -% define \Eiftex to redefine itself to be its previous value. (We can't -% just define it to fail again with an ``unmatched end'' error, since -% the @ifset might be nested.) -% -\def\conditionalsucceed#1{% - \edef\temp{% - % Remember the current value of \E#1. - \let\nece{prevE#1} = \nece{E#1}% - % - % At the `@end #1', redefine \E#1 to be its previous value. - \def\nece{E#1}{\let\nece{E#1} = \nece{prevE#1}}% - }% - \temp -} - -% We need to expand lots of \csname's, but we don't want to expand the -% control sequences after we've constructed them. -% -\def\nece#1{\expandafter\noexpand\csname#1\endcsname} - -% @asis just yields its argument. Used with @table, for example. -% -\def\asis#1{#1} - -% @math means output in math mode. -% We don't use $'s directly in the definition of \math because control -% sequences like \math are expanded when the toc file is written. Then, -% we read the toc file back, the $'s will be normal characters (as they -% should be, according to the definition of Texinfo). So we must use a -% control sequence to switch into and out of math mode. -% -% This isn't quite enough for @math to work properly in indices, but it -% seems unlikely it will ever be needed there. -% -\let\implicitmath = $ -\def\math#1{\implicitmath #1\implicitmath} - -% @bullet and @minus need the same treatment as @math, just above. -\def\bullet{\implicitmath\ptexbullet\implicitmath} -\def\minus{\implicitmath-\implicitmath} - -\def\node{\ENVcheck\parsearg\nodezzz} -\def\nodezzz#1{\nodexxx [#1,]} -\def\nodexxx[#1,#2]{\gdef\lastnode{#1}} -\let\nwnode=\node -\let\lastnode=\relax - -\def\donoderef{\ifx\lastnode\relax\else -\expandafter\expandafter\expandafter\setref{\lastnode}\fi -\global\let\lastnode=\relax} - -\def\unnumbnoderef{\ifx\lastnode\relax\else -\expandafter\expandafter\expandafter\unnumbsetref{\lastnode}\fi -\global\let\lastnode=\relax} - -\def\appendixnoderef{\ifx\lastnode\relax\else -\expandafter\expandafter\expandafter\appendixsetref{\lastnode}\fi -\global\let\lastnode=\relax} - -% @refill is a no-op. -\let\refill=\relax - -% @setfilename is done at the beginning of every texinfo file. -% So open here the files we need to have open while reading the input. -% This makes it possible to make a .fmt file for texinfo. -\def\setfilename{% - \readauxfile - \opencontents - \openindices - \fixbackslash % Turn off hack to swallow `\input texinfo'. - \global\let\setfilename=\comment % Ignore extra @setfilename cmds. - % - % If texinfo.cnf is present on the system, read it. - % Useful for site-wide @afourpaper, etc. - % Just to be on the safe side, close the input stream before the \input. - \openin 1 texinfo.cnf - \ifeof1 \let\temp=\relax \else \def\temp{\input texinfo.cnf }\fi - \closein1 - \temp - % - \comment % Ignore the actual filename. -} - -% @bye. -\outer\def\bye{\pagealignmacro\tracingstats=1\ptexend} - -% \def\macro#1{\begingroup\ignoresections\catcode`\#=6\def\macrotemp{#1}\parsearg\macroxxx} -% \def\macroxxx#1#2 \end macro{% -% \expandafter\gdef\macrotemp#1{#2}% -% \endgroup} - -%\def\linemacro#1{\begingroup\ignoresections\catcode`\#=6\def\macrotemp{#1}\parsearg\linemacroxxx} -%\def\linemacroxxx#1#2 \end linemacro{% -%\let\parsearg=\relax -%\edef\macrotempx{\csname M\butfirst\expandafter\string\macrotemp\endcsname}% -%\expandafter\xdef\macrotemp{\parsearg\macrotempx}% -%\expandafter\gdef\macrotempx#1{#2}% -%\endgroup} - -%\def\butfirst#1{} - - -\message{fonts,} - -% Font-change commands. - -% Texinfo supports the sans serif font style, which plain TeX does not. -% So we set up a \sf analogous to plain's \rm, etc. -\newfam\sffam -\def\sf{\fam=\sffam \tensf} -\let\li = \sf % Sometimes we call it \li, not \sf. - -% We don't need math for this one. -\def\ttsl{\tenttsl} - -% Use Computer Modern fonts at \magstephalf (11pt). -\newcount\mainmagstep -\mainmagstep=\magstephalf - -% Set the font macro #1 to the font named #2, adding on the -% specified font prefix (normally `cm'). -% #3 is the font's design size, #4 is a scale factor -\def\setfont#1#2#3#4{\font#1=\fontprefix#2#3 scaled #4} - -% Use cm as the default font prefix. -% To specify the font prefix, you must define \fontprefix -% before you read in texinfo.tex. -\ifx\fontprefix\undefined -\def\fontprefix{cm} -\fi -% Support font families that don't use the same naming scheme as CM. -\def\rmshape{r} -\def\rmbshape{bx} %where the normal face is bold -\def\bfshape{b} -\def\bxshape{bx} -\def\ttshape{tt} -\def\ttbshape{tt} -\def\ttslshape{sltt} -\def\itshape{ti} -\def\itbshape{bxti} -\def\slshape{sl} -\def\slbshape{bxsl} -\def\sfshape{ss} -\def\sfbshape{ss} -\def\scshape{csc} -\def\scbshape{csc} - -\ifx\bigger\relax -\let\mainmagstep=\magstep1 -\setfont\textrm\rmshape{12}{1000} -\setfont\texttt\ttshape{12}{1000} -\else -\setfont\textrm\rmshape{10}{\mainmagstep} -\setfont\texttt\ttshape{10}{\mainmagstep} -\fi -% Instead of cmb10, you many want to use cmbx10. -% cmbx10 is a prettier font on its own, but cmb10 -% looks better when embedded in a line with cmr10. -\setfont\textbf\bfshape{10}{\mainmagstep} -\setfont\textit\itshape{10}{\mainmagstep} -\setfont\textsl\slshape{10}{\mainmagstep} -\setfont\textsf\sfshape{10}{\mainmagstep} -\setfont\textsc\scshape{10}{\mainmagstep} -\setfont\textttsl\ttslshape{10}{\mainmagstep} -\font\texti=cmmi10 scaled \mainmagstep -\font\textsy=cmsy10 scaled \mainmagstep - -% A few fonts for @defun, etc. -\setfont\defbf\bxshape{10}{\magstep1} %was 1314 -\setfont\deftt\ttshape{10}{\magstep1} -\def\df{\let\tentt=\deftt \let\tenbf = \defbf \bf} - -% Fonts for indices and small examples (9pt). -% We actually use the slanted font rather than the italic, -% because texinfo normally uses the slanted fonts for that. -% Do not make many font distinctions in general in the index, since they -% aren't very useful. -\setfont\ninett\ttshape{9}{1000} -\setfont\indrm\rmshape{9}{1000} -\setfont\indit\slshape{9}{1000} -\let\indsl=\indit -\let\indtt=\ninett -\let\indttsl=\ninett -\let\indsf=\indrm -\let\indbf=\indrm -\setfont\indsc\scshape{10}{900} -\font\indi=cmmi9 -\font\indsy=cmsy9 - -% Fonts for title page: -\setfont\titlerm\rmbshape{12}{\magstep3} -\setfont\titleit\itbshape{10}{\magstep4} -\setfont\titlesl\slbshape{10}{\magstep4} -\setfont\titlett\ttbshape{12}{\magstep3} -\setfont\titlettsl\ttslshape{10}{\magstep4} -\setfont\titlesf\sfbshape{17}{\magstep1} -\let\titlebf=\titlerm -\setfont\titlesc\scbshape{10}{\magstep4} -\font\titlei=cmmi12 scaled \magstep3 -\font\titlesy=cmsy10 scaled \magstep4 -\def\authorrm{\secrm} - -% Chapter (and unnumbered) fonts (17.28pt). -\setfont\chaprm\rmbshape{12}{\magstep2} -\setfont\chapit\itbshape{10}{\magstep3} -\setfont\chapsl\slbshape{10}{\magstep3} -\setfont\chaptt\ttbshape{12}{\magstep2} -\setfont\chapttsl\ttslshape{10}{\magstep3} -\setfont\chapsf\sfbshape{17}{1000} -\let\chapbf=\chaprm -\setfont\chapsc\scbshape{10}{\magstep3} -\font\chapi=cmmi12 scaled \magstep2 -\font\chapsy=cmsy10 scaled \magstep3 - -% Section fonts (14.4pt). -\setfont\secrm\rmbshape{12}{\magstep1} -\setfont\secit\itbshape{10}{\magstep2} -\setfont\secsl\slbshape{10}{\magstep2} -\setfont\sectt\ttbshape{12}{\magstep1} -\setfont\secttsl\ttslshape{10}{\magstep2} -\setfont\secsf\sfbshape{12}{\magstep1} -\let\secbf\secrm -\setfont\secsc\scbshape{10}{\magstep2} -\font\seci=cmmi12 scaled \magstep1 -\font\secsy=cmsy10 scaled \magstep2 - -% \setfont\ssecrm\bxshape{10}{\magstep1} % This size an font looked bad. -% \setfont\ssecit\itshape{10}{\magstep1} % The letters were too crowded. -% \setfont\ssecsl\slshape{10}{\magstep1} -% \setfont\ssectt\ttshape{10}{\magstep1} -% \setfont\ssecsf\sfshape{10}{\magstep1} - -%\setfont\ssecrm\bfshape{10}{1315} % Note the use of cmb rather than cmbx. -%\setfont\ssecit\itshape{10}{1315} % Also, the size is a little larger than -%\setfont\ssecsl\slshape{10}{1315} % being scaled magstep1. -%\setfont\ssectt\ttshape{10}{1315} -%\setfont\ssecsf\sfshape{10}{1315} - -%\let\ssecbf=\ssecrm - -% Subsection fonts (13.15pt). -\setfont\ssecrm\rmbshape{12}{\magstephalf} -\setfont\ssecit\itbshape{10}{1315} -\setfont\ssecsl\slbshape{10}{1315} -\setfont\ssectt\ttbshape{12}{\magstephalf} -\setfont\ssecttsl\ttslshape{10}{1315} -\setfont\ssecsf\sfbshape{12}{\magstephalf} -\let\ssecbf\ssecrm -\setfont\ssecsc\scbshape{10}{\magstep1} -\font\sseci=cmmi12 scaled \magstephalf -\font\ssecsy=cmsy10 scaled 1315 -% The smallcaps and symbol fonts should actually be scaled \magstep1.5, -% but that is not a standard magnification. - -% In order for the font changes to affect most math symbols and letters, -% we have to define the \textfont of the standard families. Since -% texinfo doesn't allow for producing subscripts and superscripts, we -% don't bother to reset \scriptfont and \scriptscriptfont (which would -% also require loading a lot more fonts). -% -\def\resetmathfonts{% - \textfont0 = \tenrm \textfont1 = \teni \textfont2 = \tensy - \textfont\itfam = \tenit \textfont\slfam = \tensl \textfont\bffam = \tenbf - \textfont\ttfam = \tentt \textfont\sffam = \tensf -} - - -% The font-changing commands redefine the meanings of \tenSTYLE, instead -% of just \STYLE. We do this so that font changes will continue to work -% in math mode, where it is the current \fam that is relevant in most -% cases, not the current font. Plain TeX does \def\bf{\fam=\bffam -% \tenbf}, for example. By redefining \tenbf, we obviate the need to -% redefine \bf itself. -\def\textfonts{% - \let\tenrm=\textrm \let\tenit=\textit \let\tensl=\textsl - \let\tenbf=\textbf \let\tentt=\texttt \let\smallcaps=\textsc - \let\tensf=\textsf \let\teni=\texti \let\tensy=\textsy \let\tenttsl=\textttsl - \resetmathfonts} -\def\titlefonts{% - \let\tenrm=\titlerm \let\tenit=\titleit \let\tensl=\titlesl - \let\tenbf=\titlebf \let\tentt=\titlett \let\smallcaps=\titlesc - \let\tensf=\titlesf \let\teni=\titlei \let\tensy=\titlesy - \let\tenttsl=\titlettsl - \resetmathfonts \setleading{25pt}} -\def\titlefont#1{{\titlefonts\rm #1}} -\def\chapfonts{% - \let\tenrm=\chaprm \let\tenit=\chapit \let\tensl=\chapsl - \let\tenbf=\chapbf \let\tentt=\chaptt \let\smallcaps=\chapsc - \let\tensf=\chapsf \let\teni=\chapi \let\tensy=\chapsy \let\tenttsl=\chapttsl - \resetmathfonts \setleading{19pt}} -\def\secfonts{% - \let\tenrm=\secrm \let\tenit=\secit \let\tensl=\secsl - \let\tenbf=\secbf \let\tentt=\sectt \let\smallcaps=\secsc - \let\tensf=\secsf \let\teni=\seci \let\tensy=\secsy \let\tenttsl=\secttsl - \resetmathfonts \setleading{16pt}} -\def\subsecfonts{% - \let\tenrm=\ssecrm \let\tenit=\ssecit \let\tensl=\ssecsl - \let\tenbf=\ssecbf \let\tentt=\ssectt \let\smallcaps=\ssecsc - \let\tensf=\ssecsf \let\teni=\sseci \let\tensy=\ssecsy \let\tenttsl=\ssecttsl - \resetmathfonts \setleading{15pt}} -\let\subsubsecfonts = \subsecfonts % Maybe make sssec fonts scaled magstephalf? -\def\indexfonts{% - \let\tenrm=\indrm \let\tenit=\indit \let\tensl=\indsl - \let\tenbf=\indbf \let\tentt=\indtt \let\smallcaps=\indsc - \let\tensf=\indsf \let\teni=\indi \let\tensy=\indsy \let\tenttsl=\indttsl - \resetmathfonts \setleading{12pt}} - -% Set up the default fonts, so we can use them for creating boxes. -% -\textfonts - -% Define these so they can be easily changed for other fonts. -\def\angleleft{$\langle$} -\def\angleright{$\rangle$} - -% Count depth in font-changes, for error checks -\newcount\fontdepth \fontdepth=0 - -% Fonts for short table of contents. -\setfont\shortcontrm\rmshape{12}{1000} -\setfont\shortcontbf\bxshape{12}{1000} -\setfont\shortcontsl\slshape{12}{1000} - -%% Add scribe-like font environments, plus @l for inline lisp (usually sans -%% serif) and @ii for TeX italic - -% \smartitalic{ARG} outputs arg in italics, followed by an italic correction -% unless the following character is such as not to need one. -\def\smartitalicx{\ifx\next,\else\ifx\next-\else\ifx\next.\else\/\fi\fi\fi} -\def\smartitalic#1{{\sl #1}\futurelet\next\smartitalicx} - -\let\i=\smartitalic -\let\var=\smartitalic -\let\dfn=\smartitalic -\let\emph=\smartitalic -\let\cite=\smartitalic - -\def\b#1{{\bf #1}} -\let\strong=\b - -% We can't just use \exhyphenpenalty, because that only has effect at -% the end of a paragraph. Restore normal hyphenation at the end of the -% group within which \nohyphenation is presumably called. -% -\def\nohyphenation{\hyphenchar\font = -1 \aftergroup\restorehyphenation} -\def\restorehyphenation{\hyphenchar\font = `- } - -\def\t#1{% - {\tt \rawbackslash \frenchspacing #1}% - \null -} -\let\ttfont=\t -\def\samp#1{`\tclose{#1}'\null} -\setfont\smallrm\rmshape{8}{1000} -\font\smallsy=cmsy9 -\def\key#1{{\smallrm\textfont2=\smallsy \leavevmode\hbox{% - \raise0.4pt\hbox{\angleleft}\kern-.08em\vtop{% - \vbox{\hrule\kern-0.4pt - \hbox{\raise0.4pt\hbox{\vphantom{\angleleft}}#1}}% - \kern-0.4pt\hrule}% - \kern-.06em\raise0.4pt\hbox{\angleright}}}} -% The old definition, with no lozenge: -%\def\key #1{{\ttsl \nohyphenation \uppercase{#1}}\null} -\def\ctrl #1{{\tt \rawbackslash \hat}#1} - -\let\file=\samp - -% @code is a modification of @t, -% which makes spaces the same size as normal in the surrounding text. -\def\tclose#1{% - {% - % Change normal interword space to be same as for the current font. - \spaceskip = \fontdimen2\font - % - % Switch to typewriter. - \tt - % - % But `\ ' produces the large typewriter interword space. - \def\ {{\spaceskip = 0pt{} }}% - % - % Turn off hyphenation. - \nohyphenation - % - \rawbackslash - \frenchspacing - #1% - }% - \null -} - -% We *must* turn on hyphenation at `-' and `_' in \code. -% Otherwise, it is too hard to avoid overfull hboxes -% in the Emacs manual, the Library manual, etc. - -% Unfortunately, TeX uses one parameter (\hyphenchar) to control -% both hyphenation at - and hyphenation within words. -% We must therefore turn them both off (\tclose does that) -% and arrange explicitly to hyphenate at a dash. -% -- rms. -{ -\catcode`\-=\active -\catcode`\_=\active -\catcode`\|=\active -\global\def\code{\begingroup \catcode`\-=\active \let-\codedash \catcode`\_=\active \let_\codeunder \codex} -% The following is used by \doprintindex to insure that long function names -% wrap around. It is necessary for - and _ to be active before the index is -% read from the file, as \entry parses the arguments long before \code is -% ever called. -- mycroft -% _ is always active; and it shouldn't be \let = to an _ that is a -% subscript character anyway. Then, @cindex @samp{_} (for example) -% fails. --karl -\global\def\indexbreaks{% - \catcode`\-=\active \let-\realdash -} -} - -\def\realdash{-} -\def\codedash{-\discretionary{}{}{}} -\def\codeunder{\ifusingtt{\normalunderscore\discretionary{}{}{}}{\_}} -\def\codex #1{\tclose{#1}\endgroup} - -%\let\exp=\tclose %Was temporary - -% @kbd is like @code, except that if the argument is just one @key command, -% then @kbd has no effect. - -% @kbdinputstyle -- arg is `distinct' (@kbd uses slanted tty font always), -% `example' (@kbd uses ttsl only inside of @example and friends), -% or `code' (@kbd uses normal tty font always). -\def\kbdinputstyle{\parsearg\kbdinputstylexxx} -\def\kbdinputstylexxx#1{% - \def\arg{#1}% - \ifx\arg\worddistinct - \gdef\kbdexamplefont{\ttsl}\gdef\kbdfont{\ttsl}% - \else\ifx\arg\wordexample - \gdef\kbdexamplefont{\ttsl}\gdef\kbdfont{\tt}% - \else\ifx\arg\wordcode - \gdef\kbdexamplefont{\tt}\gdef\kbdfont{\tt}% - \fi\fi\fi -} -\def\worddistinct{distinct} -\def\wordexample{example} -\def\wordcode{code} - -% Default is kbdinputdistinct. (Too much of a hassle to call the macro, -% the catcodes are wrong for parsearg to work.) -\gdef\kbdexamplefont{\ttsl}\gdef\kbdfont{\ttsl} - -\def\xkey{\key} -\def\kbdfoo#1#2#3\par{\def\one{#1}\def\three{#3}\def\threex{??}% -\ifx\one\xkey\ifx\threex\three \key{#2}% -\else{\tclose{\kbdfont\look}}\fi -\else{\tclose{\kbdfont\look}}\fi} - -% @url. Quotes do not seem necessary, so use \code. -\let\url=\code - -% @uref (abbreviation for `urlref') takes an optional second argument -% specifying the text to display. First (mandatory) arg is the url. -% Perhaps eventually put in a hypertex \special here. -% -\def\uref#1{\urefxxx #1,,\finish} -\def\urefxxx#1,#2,#3\finish{% - \setbox0 = \hbox{\ignorespaces #2}% - \ifdim\wd0 > 0pt - \unhbox0\ (\code{#1})% - \else - \code{#1}% - \fi -} - -% rms does not like the angle brackets --karl, 17may97. -% So now @email is just like @uref. -%\def\email#1{\angleleft{\tt #1}\angleright} -\let\email=\uref - -% Check if we are currently using a typewriter font. Since all the -% Computer Modern typewriter fonts have zero interword stretch (and -% shrink), and it is reasonable to expect all typewriter fonts to have -% this property, we can check that font parameter. -% -\def\ifmonospace{\ifdim\fontdimen3\font=0pt } - -% Typeset a dimension, e.g., `in' or `pt'. The only reason for the -% argument is to make the input look right: @dmn{pt} instead of -% @dmn{}pt. -% -\def\dmn#1{\thinspace #1} - -\def\kbd#1{\def\look{#1}\expandafter\kbdfoo\look??\par} - -% @l was never documented to mean ``switch to the Lisp font'', -% and it is not used as such in any manual I can find. We need it for -% Polish suppressed-l. --karl, 22sep96. -%\def\l#1{{\li #1}\null} - -\def\r#1{{\rm #1}} % roman font -% Use of \lowercase was suggested. -\def\sc#1{{\smallcaps#1}} % smallcaps font -\def\ii#1{{\it #1}} % italic font - -% @pounds{} is a sterling sign. -\def\pounds{{\it\$}} - - -\message{page headings,} - -\newskip\titlepagetopglue \titlepagetopglue = 1.5in -\newskip\titlepagebottomglue \titlepagebottomglue = 2pc - -% First the title page. Must do @settitle before @titlepage. -\newif\ifseenauthor -\newif\iffinishedtitlepage - -\def\shorttitlepage{\parsearg\shorttitlepagezzz} -\def\shorttitlepagezzz #1{\begingroup\hbox{}\vskip 1.5in \chaprm \centerline{#1}% - \endgroup\page\hbox{}\page} - -\def\titlepage{\begingroup \parindent=0pt \textfonts - \let\subtitlerm=\tenrm -% I deinstalled the following change because \cmr12 is undefined. -% This change was not in the ChangeLog anyway. --rms. -% \let\subtitlerm=\cmr12 - \def\subtitlefont{\subtitlerm \normalbaselineskip = 13pt \normalbaselines}% - % - \def\authorfont{\authorrm \normalbaselineskip = 16pt \normalbaselines}% - % - % Leave some space at the very top of the page. - \vglue\titlepagetopglue - % - % Now you can print the title using @title. - \def\title{\parsearg\titlezzz}% - \def\titlezzz##1{\leftline{\titlefonts\rm ##1} - % print a rule at the page bottom also. - \finishedtitlepagefalse - \vskip4pt \hrule height 4pt width \hsize \vskip4pt}% - % No rule at page bottom unless we print one at the top with @title. - \finishedtitlepagetrue - % - % Now you can put text using @subtitle. - \def\subtitle{\parsearg\subtitlezzz}% - \def\subtitlezzz##1{{\subtitlefont \rightline{##1}}}% - % - % @author should come last, but may come many times. - \def\author{\parsearg\authorzzz}% - \def\authorzzz##1{\ifseenauthor\else\vskip 0pt plus 1filll\seenauthortrue\fi - {\authorfont \leftline{##1}}}% - % - % Most title ``pages'' are actually two pages long, with space - % at the top of the second. We don't want the ragged left on the second. - \let\oldpage = \page - \def\page{% - \iffinishedtitlepage\else - \finishtitlepage - \fi - \oldpage - \let\page = \oldpage - \hbox{}}% -% \def\page{\oldpage \hbox{}} -} - -\def\Etitlepage{% - \iffinishedtitlepage\else - \finishtitlepage - \fi - % It is important to do the page break before ending the group, - % because the headline and footline are only empty inside the group. - % If we use the new definition of \page, we always get a blank page - % after the title page, which we certainly don't want. - \oldpage - \endgroup - \HEADINGSon -} - -\def\finishtitlepage{% - \vskip4pt \hrule height 2pt width \hsize - \vskip\titlepagebottomglue - \finishedtitlepagetrue -} - -%%% Set up page headings and footings. - -\let\thispage=\folio - -\newtoks \evenheadline % Token sequence for heading line of even pages -\newtoks \oddheadline % Token sequence for heading line of odd pages -\newtoks \evenfootline % Token sequence for footing line of even pages -\newtoks \oddfootline % Token sequence for footing line of odd pages - -% Now make Tex use those variables -\headline={{\textfonts\rm \ifodd\pageno \the\oddheadline - \else \the\evenheadline \fi}} -\footline={{\textfonts\rm \ifodd\pageno \the\oddfootline - \else \the\evenfootline \fi}\HEADINGShook} -\let\HEADINGShook=\relax - -% Commands to set those variables. -% For example, this is what @headings on does -% @evenheading @thistitle|@thispage|@thischapter -% @oddheading @thischapter|@thispage|@thistitle -% @evenfooting @thisfile|| -% @oddfooting ||@thisfile - -\def\evenheading{\parsearg\evenheadingxxx} -\def\oddheading{\parsearg\oddheadingxxx} -\def\everyheading{\parsearg\everyheadingxxx} - -\def\evenfooting{\parsearg\evenfootingxxx} -\def\oddfooting{\parsearg\oddfootingxxx} -\def\everyfooting{\parsearg\everyfootingxxx} - -{\catcode`\@=0 % - -\gdef\evenheadingxxx #1{\evenheadingyyy #1@|@|@|@|\finish} -\gdef\evenheadingyyy #1@|#2@|#3@|#4\finish{% -\global\evenheadline={\rlap{\centerline{#2}}\line{#1\hfil#3}}} - -\gdef\oddheadingxxx #1{\oddheadingyyy #1@|@|@|@|\finish} -\gdef\oddheadingyyy #1@|#2@|#3@|#4\finish{% -\global\oddheadline={\rlap{\centerline{#2}}\line{#1\hfil#3}}} - -\gdef\everyheadingxxx#1{\oddheadingxxx{#1}\evenheadingxxx{#1}}% - -\gdef\evenfootingxxx #1{\evenfootingyyy #1@|@|@|@|\finish} -\gdef\evenfootingyyy #1@|#2@|#3@|#4\finish{% -\global\evenfootline={\rlap{\centerline{#2}}\line{#1\hfil#3}}} - -\gdef\oddfootingxxx #1{\oddfootingyyy #1@|@|@|@|\finish} -\gdef\oddfootingyyy #1@|#2@|#3@|#4\finish{% - \global\oddfootline = {\rlap{\centerline{#2}}\line{#1\hfil#3}}% - % - % Leave some space for the footline. Hopefully ok to assume - % @evenfooting will not be used by itself. - \global\advance\pageheight by -\baselineskip - \global\advance\vsize by -\baselineskip -} - -\gdef\everyfootingxxx#1{\oddfootingxxx{#1}\evenfootingxxx{#1}} -% -}% unbind the catcode of @. - -% @headings double turns headings on for double-sided printing. -% @headings single turns headings on for single-sided printing. -% @headings off turns them off. -% @headings on same as @headings double, retained for compatibility. -% @headings after turns on double-sided headings after this page. -% @headings doubleafter turns on double-sided headings after this page. -% @headings singleafter turns on single-sided headings after this page. -% By default, they are off at the start of a document, -% and turned `on' after @end titlepage. - -\def\headings #1 {\csname HEADINGS#1\endcsname} - -\def\HEADINGSoff{ -\global\evenheadline={\hfil} \global\evenfootline={\hfil} -\global\oddheadline={\hfil} \global\oddfootline={\hfil}} -\HEADINGSoff -% When we turn headings on, set the page number to 1. -% For double-sided printing, put current file name in lower left corner, -% chapter name on inside top of right hand pages, document -% title on inside top of left hand pages, and page numbers on outside top -% edge of all pages. -\def\HEADINGSdouble{ -\global\pageno=1 -\global\evenfootline={\hfil} -\global\oddfootline={\hfil} -\global\evenheadline={\line{\folio\hfil\thistitle}} -\global\oddheadline={\line{\thischapter\hfil\folio}} -\global\let\contentsalignmacro = \chapoddpage -} -\let\contentsalignmacro = \chappager - -% For single-sided printing, chapter title goes across top left of page, -% page number on top right. -\def\HEADINGSsingle{ -\global\pageno=1 -\global\evenfootline={\hfil} -\global\oddfootline={\hfil} -\global\evenheadline={\line{\thischapter\hfil\folio}} -\global\oddheadline={\line{\thischapter\hfil\folio}} -\global\let\contentsalignmacro = \chappager -} -\def\HEADINGSon{\HEADINGSdouble} - -\def\HEADINGSafter{\let\HEADINGShook=\HEADINGSdoublex} -\let\HEADINGSdoubleafter=\HEADINGSafter -\def\HEADINGSdoublex{% -\global\evenfootline={\hfil} -\global\oddfootline={\hfil} -\global\evenheadline={\line{\folio\hfil\thistitle}} -\global\oddheadline={\line{\thischapter\hfil\folio}} -\global\let\contentsalignmacro = \chapoddpage -} - -\def\HEADINGSsingleafter{\let\HEADINGShook=\HEADINGSsinglex} -\def\HEADINGSsinglex{% -\global\evenfootline={\hfil} -\global\oddfootline={\hfil} -\global\evenheadline={\line{\thischapter\hfil\folio}} -\global\oddheadline={\line{\thischapter\hfil\folio}} -\global\let\contentsalignmacro = \chappager -} - -% Subroutines used in generating headings -% Produces Day Month Year style of output. -\def\today{\number\day\space -\ifcase\month\or -January\or February\or March\or April\or May\or June\or -July\or August\or September\or October\or November\or December\fi -\space\number\year} - -% Use this if you want the Month Day, Year style of output. -%\def\today{\ifcase\month\or -%January\or February\or March\or April\or May\or June\or -%July\or August\or September\or October\or November\or December\fi -%\space\number\day, \number\year} - -% @settitle line... specifies the title of the document, for headings -% It generates no output of its own - -\def\thistitle{No Title} -\def\settitle{\parsearg\settitlezzz} -\def\settitlezzz #1{\gdef\thistitle{#1}} - - -\message{tables,} - -% @tabs -- simple alignment - -% These don't work. For one thing, \+ is defined as outer. -% So these macros cannot even be defined. - -%\def\tabs{\parsearg\tabszzz} -%\def\tabszzz #1{\settabs\+#1\cr} -%\def\tabline{\parsearg\tablinezzz} -%\def\tablinezzz #1{\+#1\cr} -%\def\&{&} - -% Tables -- @table, @ftable, @vtable, @item(x), @kitem(x), @xitem(x). - -% default indentation of table text -\newdimen\tableindent \tableindent=.8in -% default indentation of @itemize and @enumerate text -\newdimen\itemindent \itemindent=.3in -% margin between end of table item and start of table text. -\newdimen\itemmargin \itemmargin=.1in - -% used internally for \itemindent minus \itemmargin -\newdimen\itemmax - -% Note @table, @vtable, and @vtable define @item, @itemx, etc., with -% these defs. -% They also define \itemindex -% to index the item name in whatever manner is desired (perhaps none). - -\newif\ifitemxneedsnegativevskip - -\def\itemxpar{\par\ifitemxneedsnegativevskip\nobreak\vskip-\parskip\nobreak\fi} - -\def\internalBitem{\smallbreak \parsearg\itemzzz} -\def\internalBitemx{\itemxpar \parsearg\itemzzz} - -\def\internalBxitem "#1"{\def\xitemsubtopix{#1} \smallbreak \parsearg\xitemzzz} -\def\internalBxitemx "#1"{\def\xitemsubtopix{#1} \itemxpar \parsearg\xitemzzz} - -\def\internalBkitem{\smallbreak \parsearg\kitemzzz} -\def\internalBkitemx{\itemxpar \parsearg\kitemzzz} - -\def\kitemzzz #1{\dosubind {kw}{\code{#1}}{for {\bf \lastfunction}}% - \itemzzz {#1}} - -\def\xitemzzz #1{\dosubind {kw}{\code{#1}}{for {\bf \xitemsubtopic}}% - \itemzzz {#1}} - -\def\itemzzz #1{\begingroup % - \advance\hsize by -\rightskip - \advance\hsize by -\tableindent - \setbox0=\hbox{\itemfont{#1}}% - \itemindex{#1}% - \nobreak % This prevents a break before @itemx. - % - % Be sure we are not still in the middle of a paragraph. - %{\parskip = 0in - %\par - %}% - % - % If the item text does not fit in the space we have, put it on a line - % by itself, and do not allow a page break either before or after that - % line. We do not start a paragraph here because then if the next - % command is, e.g., @kindex, the whatsit would get put into the - % horizontal list on a line by itself, resulting in extra blank space. - \ifdim \wd0>\itemmax - % - % Make this a paragraph so we get the \parskip glue and wrapping, - % but leave it ragged-right. - \begingroup - \advance\leftskip by-\tableindent - \advance\hsize by\tableindent - \advance\rightskip by0pt plus1fil - \leavevmode\unhbox0\par - \endgroup - % - % We're going to be starting a paragraph, but we don't want the - % \parskip glue -- logically it's part of the @item we just started. - \nobreak \vskip-\parskip - % - % Stop a page break at the \parskip glue coming up. Unfortunately - % we can't prevent a possible page break at the following - % \baselineskip glue. - \nobreak - \endgroup - \itemxneedsnegativevskipfalse - \else - % The item text fits into the space. Start a paragraph, so that the - % following text (if any) will end up on the same line. Since that - % text will be indented by \tableindent, we make the item text be in - % a zero-width box. - \noindent - \rlap{\hskip -\tableindent\box0}\ignorespaces% - \endgroup% - \itemxneedsnegativevskiptrue% - \fi -} - -\def\item{\errmessage{@item while not in a table}} -\def\itemx{\errmessage{@itemx while not in a table}} -\def\kitem{\errmessage{@kitem while not in a table}} -\def\kitemx{\errmessage{@kitemx while not in a table}} -\def\xitem{\errmessage{@xitem while not in a table}} -\def\xitemx{\errmessage{@xitemx while not in a table}} - -%% Contains a kludge to get @end[description] to work -\def\description{\tablez{\dontindex}{1}{}{}{}{}} - -\def\table{\begingroup\inENV\obeylines\obeyspaces\tablex} -{\obeylines\obeyspaces% -\gdef\tablex #1^^M{% -\tabley\dontindex#1 \endtabley}} - -\def\ftable{\begingroup\inENV\obeylines\obeyspaces\ftablex} -{\obeylines\obeyspaces% -\gdef\ftablex #1^^M{% -\tabley\fnitemindex#1 \endtabley -\def\Eftable{\endgraf\afterenvbreak\endgroup}% -\let\Etable=\relax}} - -\def\vtable{\begingroup\inENV\obeylines\obeyspaces\vtablex} -{\obeylines\obeyspaces% -\gdef\vtablex #1^^M{% -\tabley\vritemindex#1 \endtabley -\def\Evtable{\endgraf\afterenvbreak\endgroup}% -\let\Etable=\relax}} - -\def\dontindex #1{} -\def\fnitemindex #1{\doind {fn}{\code{#1}}}% -\def\vritemindex #1{\doind {vr}{\code{#1}}}% - -{\obeyspaces % -\gdef\tabley#1#2 #3 #4 #5 #6 #7\endtabley{\endgroup% -\tablez{#1}{#2}{#3}{#4}{#5}{#6}}} - -\def\tablez #1#2#3#4#5#6{% -\aboveenvbreak % -\begingroup % -\def\Edescription{\Etable}% Necessary kludge. -\let\itemindex=#1% -\ifnum 0#3>0 \advance \leftskip by #3\mil \fi % -\ifnum 0#4>0 \tableindent=#4\mil \fi % -\ifnum 0#5>0 \advance \rightskip by #5\mil \fi % -\def\itemfont{#2}% -\itemmax=\tableindent % -\advance \itemmax by -\itemmargin % -\advance \leftskip by \tableindent % -\exdentamount=\tableindent -\parindent = 0pt -\parskip = \smallskipamount -\ifdim \parskip=0pt \parskip=2pt \fi% -\def\Etable{\endgraf\afterenvbreak\endgroup}% -\let\item = \internalBitem % -\let\itemx = \internalBitemx % -\let\kitem = \internalBkitem % -\let\kitemx = \internalBkitemx % -\let\xitem = \internalBxitem % -\let\xitemx = \internalBxitemx % -} - -% This is the counter used by @enumerate, which is really @itemize - -\newcount \itemno - -\def\itemize{\parsearg\itemizezzz} - -\def\itemizezzz #1{% - \begingroup % ended by the @end itemsize - \itemizey {#1}{\Eitemize} -} - -\def\itemizey #1#2{% -\aboveenvbreak % -\itemmax=\itemindent % -\advance \itemmax by -\itemmargin % -\advance \leftskip by \itemindent % -\exdentamount=\itemindent -\parindent = 0pt % -\parskip = \smallskipamount % -\ifdim \parskip=0pt \parskip=2pt \fi% -\def#2{\endgraf\afterenvbreak\endgroup}% -\def\itemcontents{#1}% -\let\item=\itemizeitem} - -% Set sfcode to normal for the chars that usually have another value. -% These are `.?!:;,' -\def\frenchspacing{\sfcode46=1000 \sfcode63=1000 \sfcode33=1000 - \sfcode58=1000 \sfcode59=1000 \sfcode44=1000 } - -% \splitoff TOKENS\endmark defines \first to be the first token in -% TOKENS, and \rest to be the remainder. -% -\def\splitoff#1#2\endmark{\def\first{#1}\def\rest{#2}}% - -% Allow an optional argument of an uppercase letter, lowercase letter, -% or number, to specify the first label in the enumerated list. No -% argument is the same as `1'. -% -\def\enumerate{\parsearg\enumeratezzz} -\def\enumeratezzz #1{\enumeratey #1 \endenumeratey} -\def\enumeratey #1 #2\endenumeratey{% - \begingroup % ended by the @end enumerate - % - % If we were given no argument, pretend we were given `1'. - \def\thearg{#1}% - \ifx\thearg\empty \def\thearg{1}\fi - % - % Detect if the argument is a single token. If so, it might be a - % letter. Otherwise, the only valid thing it can be is a number. - % (We will always have one token, because of the test we just made. - % This is a good thing, since \splitoff doesn't work given nothing at - % all -- the first parameter is undelimited.) - \expandafter\splitoff\thearg\endmark - \ifx\rest\empty - % Only one token in the argument. It could still be anything. - % A ``lowercase letter'' is one whose \lccode is nonzero. - % An ``uppercase letter'' is one whose \lccode is both nonzero, and - % not equal to itself. - % Otherwise, we assume it's a number. - % - % We need the \relax at the end of the \ifnum lines to stop TeX from - % continuing to look for a . - % - \ifnum\lccode\expandafter`\thearg=0\relax - \numericenumerate % a number (we hope) - \else - % It's a letter. - \ifnum\lccode\expandafter`\thearg=\expandafter`\thearg\relax - \lowercaseenumerate % lowercase letter - \else - \uppercaseenumerate % uppercase letter - \fi - \fi - \else - % Multiple tokens in the argument. We hope it's a number. - \numericenumerate - \fi -} - -% An @enumerate whose labels are integers. The starting integer is -% given in \thearg. -% -\def\numericenumerate{% - \itemno = \thearg - \startenumeration{\the\itemno}% -} - -% The starting (lowercase) letter is in \thearg. -\def\lowercaseenumerate{% - \itemno = \expandafter`\thearg - \startenumeration{% - % Be sure we're not beyond the end of the alphabet. - \ifnum\itemno=0 - \errmessage{No more lowercase letters in @enumerate; get a bigger - alphabet}% - \fi - \char\lccode\itemno - }% -} - -% The starting (uppercase) letter is in \thearg. -\def\uppercaseenumerate{% - \itemno = \expandafter`\thearg - \startenumeration{% - % Be sure we're not beyond the end of the alphabet. - \ifnum\itemno=0 - \errmessage{No more uppercase letters in @enumerate; get a bigger - alphabet} - \fi - \char\uccode\itemno - }% -} - -% Call itemizey, adding a period to the first argument and supplying the -% common last two arguments. Also subtract one from the initial value in -% \itemno, since @item increments \itemno. -% -\def\startenumeration#1{% - \advance\itemno by -1 - \itemizey{#1.}\Eenumerate\flushcr -} - -% @alphaenumerate and @capsenumerate are abbreviations for giving an arg -% to @enumerate. -% -\def\alphaenumerate{\enumerate{a}} -\def\capsenumerate{\enumerate{A}} -\def\Ealphaenumerate{\Eenumerate} -\def\Ecapsenumerate{\Eenumerate} - -% Definition of @item while inside @itemize. - -\def\itemizeitem{% -\advance\itemno by 1 -{\let\par=\endgraf \smallbreak}% -\ifhmode \errmessage{In hmode at itemizeitem}\fi -{\parskip=0in \hskip 0pt -\hbox to 0pt{\hss \itemcontents\hskip \itemmargin}% -\vadjust{\penalty 1200}}% -\flushcr} - -% @multitable macros -% Amy Hendrickson, 8/18/94, 3/6/96 -% -% @multitable ... @end multitable will make as many columns as desired. -% Contents of each column will wrap at width given in preamble. Width -% can be specified either with sample text given in a template line, -% or in percent of \hsize, the current width of text on page. - -% Table can continue over pages but will only break between lines. - -% To make preamble: -% -% Either define widths of columns in terms of percent of \hsize: -% @multitable @columnfractions .25 .3 .45 -% @item ... -% -% Numbers following @columnfractions are the percent of the total -% current hsize to be used for each column. You may use as many -% columns as desired. - - -% Or use a template: -% @multitable {Column 1 template} {Column 2 template} {Column 3 template} -% @item ... -% using the widest term desired in each column. -% -% For those who want to use more than one line's worth of words in -% the preamble, break the line within one argument and it -% will parse correctly, i.e., -% -% @multitable {Column 1 template} {Column 2 template} {Column 3 -% template} -% Not: -% @multitable {Column 1 template} {Column 2 template} -% {Column 3 template} - -% Each new table line starts with @item, each subsequent new column -% starts with @tab. Empty columns may be produced by supplying @tab's -% with nothing between them for as many times as empty columns are needed, -% ie, @tab@tab@tab will produce two empty columns. - -% @item, @tab, @multitable or @end multitable do not need to be on their -% own lines, but it will not hurt if they are. - -% Sample multitable: - -% @multitable {Column 1 template} {Column 2 template} {Column 3 template} -% @item first col stuff @tab second col stuff @tab third col -% @item -% first col stuff -% @tab -% second col stuff -% @tab -% third col -% @item first col stuff @tab second col stuff -% @tab Many paragraphs of text may be used in any column. -% -% They will wrap at the width determined by the template. -% @item@tab@tab This will be in third column. -% @end multitable - -% Default dimensions may be reset by user. -% @multitableparskip is vertical space between paragraphs in table. -% @multitableparindent is paragraph indent in table. -% @multitablecolmargin is horizontal space to be left between columns. -% @multitablelinespace is space to leave between table items, baseline -% to baseline. -% 0pt means it depends on current normal line spacing. -% -\newskip\multitableparskip -\newskip\multitableparindent -\newdimen\multitablecolspace -\newskip\multitablelinespace -\multitableparskip=0pt -\multitableparindent=6pt -\multitablecolspace=12pt -\multitablelinespace=0pt - -% Macros used to set up halign preamble: -% -\let\endsetuptable\relax -\def\xendsetuptable{\endsetuptable} -\let\columnfractions\relax -\def\xcolumnfractions{\columnfractions} -\newif\ifsetpercent - -% 2/1/96, to allow fractions to be given with more than one digit. -\def\pickupwholefraction#1 {\global\advance\colcount by1 % -\expandafter\xdef\csname col\the\colcount\endcsname{.#1\hsize}% -\setuptable} - -\newcount\colcount -\def\setuptable#1{\def\firstarg{#1}% -\ifx\firstarg\xendsetuptable\let\go\relax% -\else - \ifx\firstarg\xcolumnfractions\global\setpercenttrue% - \else - \ifsetpercent - \let\go\pickupwholefraction % In this case arg of setuptable - % is the decimal point before the - % number given in percent of hsize. - % We don't need this so we don't use it. - \else - \global\advance\colcount by1 - \setbox0=\hbox{#1 }% Add a normal word space as a separator; - % typically that is always in the input, anyway. - \expandafter\xdef\csname col\the\colcount\endcsname{\the\wd0}% - \fi% - \fi% -\ifx\go\pickupwholefraction\else\let\go\setuptable\fi% -\fi\go} - -% multitable syntax -\def\tab{&\hskip1sp\relax} % 2/2/96 - % tiny skip here makes sure this column space is - % maintained, even if it is never used. - -% @multitable ... @end multitable definitions: - -\def\multitable{\parsearg\dotable} -\def\dotable#1{\bgroup - \vskip\parskip - \let\item\crcr - \tolerance=9500 - \hbadness=9500 - \setmultitablespacing - \parskip=\multitableparskip - \parindent=\multitableparindent - \overfullrule=0pt - \global\colcount=0 - \def\Emultitable{\global\setpercentfalse\cr\egroup\egroup}% - % - % To parse everything between @multitable and @item: - \setuptable#1 \endsetuptable - % - % \everycr will reset column counter, \colcount, at the end of - % each line. Every column entry will cause \colcount to advance by one. - % The table preamble - % looks at the current \colcount to find the correct column width. - \everycr{\noalign{% - % - % \filbreak%% keeps underfull box messages off when table breaks over pages. - % Maybe so, but it also creates really weird page breaks when the table - % breaks over pages. Wouldn't \vfil be better? Wait until the problem - % manifests itself, so it can be fixed for real --karl. - \global\colcount=0\relax}}% - % - % This preamble sets up a generic column definition, which will - % be used as many times as user calls for columns. - % \vtop will set a single line and will also let text wrap and - % continue for many paragraphs if desired. - \halign\bgroup&\global\advance\colcount by 1\relax - \multistrut\vtop{\hsize=\expandafter\csname col\the\colcount\endcsname - % - % In order to keep entries from bumping into each other - % we will add a \leftskip of \multitablecolspace to all columns after - % the first one. - % - % If a template has been used, we will add \multitablecolspace - % to the width of each template entry. - % - % If the user has set preamble in terms of percent of \hsize we will - % use that dimension as the width of the column, and the \leftskip - % will keep entries from bumping into each other. Table will start at - % left margin and final column will justify at right margin. - % - % Make sure we don't inherit \rightskip from the outer environment. - \rightskip=0pt - \ifnum\colcount=1 - % The first column will be indented with the surrounding text. - \advance\hsize by\leftskip - \else - \ifsetpercent \else - % If user has not set preamble in terms of percent of \hsize - % we will advance \hsize by \multitablecolspace. - \advance\hsize by \multitablecolspace - \fi - % In either case we will make \leftskip=\multitablecolspace: - \leftskip=\multitablecolspace - \fi - % Ignoring space at the beginning and end avoids an occasional spurious - % blank line, when TeX decides to break the line at the space before the - % box from the multistrut, so the strut ends up on a line by itself. - % For example: - % @multitable @columnfractions .11 .89 - % @item @code{#} - % @tab Legal holiday which is valid in major parts of the whole country. - % Is automatically provided with highlighting sequences respectively marking - % characters. - \noindent\ignorespaces##\unskip\multistrut}\cr -} - -\def\setmultitablespacing{% test to see if user has set \multitablelinespace. -% If so, do nothing. If not, give it an appropriate dimension based on -% current baselineskip. -\ifdim\multitablelinespace=0pt -%% strut to put in table in case some entry doesn't have descenders, -%% to keep lines equally spaced -\let\multistrut = \strut -%% Test to see if parskip is larger than space between lines of -%% table. If not, do nothing. -%% If so, set to same dimension as multitablelinespace. -\else -\gdef\multistrut{\vrule height\multitablelinespace depth\dp0 -width0pt\relax} \fi -\ifdim\multitableparskip>\multitablelinespace -\global\multitableparskip=\multitablelinespace -\global\advance\multitableparskip-7pt %% to keep parskip somewhat smaller - %% than skip between lines in the table. -\fi% -\ifdim\multitableparskip=0pt -\global\multitableparskip=\multitablelinespace -\global\advance\multitableparskip-7pt %% to keep parskip somewhat smaller - %% than skip between lines in the table. -\fi} - - -\message{indexing,} -% Index generation facilities - -% Define \newwrite to be identical to plain tex's \newwrite -% except not \outer, so it can be used within \newindex. -{\catcode`\@=11 -\gdef\newwrite{\alloc@7\write\chardef\sixt@@n}} - -% \newindex {foo} defines an index named foo. -% It automatically defines \fooindex such that -% \fooindex ...rest of line... puts an entry in the index foo. -% It also defines \fooindfile to be the number of the output channel for -% the file that accumulates this index. The file's extension is foo. -% The name of an index should be no more than 2 characters long -% for the sake of vms. - -\def\newindex #1{ -\expandafter\newwrite \csname#1indfile\endcsname% Define number for output file -\openout \csname#1indfile\endcsname \jobname.#1 % Open the file -\expandafter\xdef\csname#1index\endcsname{% % Define \xxxindex -\noexpand\doindex {#1}} -} - -% @defindex foo == \newindex{foo} - -\def\defindex{\parsearg\newindex} - -% Define @defcodeindex, like @defindex except put all entries in @code. - -\def\newcodeindex #1{ -\expandafter\newwrite \csname#1indfile\endcsname% Define number for output file -\openout \csname#1indfile\endcsname \jobname.#1 % Open the file -\expandafter\xdef\csname#1index\endcsname{% % Define \xxxindex -\noexpand\docodeindex {#1}} -} - -\def\defcodeindex{\parsearg\newcodeindex} - -% @synindex foo bar makes index foo feed into index bar. -% Do this instead of @defindex foo if you don't want it as a separate index. -\def\synindex #1 #2 {% -\expandafter\let\expandafter\synindexfoo\expandafter=\csname#2indfile\endcsname -\expandafter\let\csname#1indfile\endcsname=\synindexfoo -\expandafter\xdef\csname#1index\endcsname{% % Define \xxxindex -\noexpand\doindex {#2}}% -} - -% @syncodeindex foo bar similar, but put all entries made for index foo -% inside @code. -\def\syncodeindex #1 #2 {% -\expandafter\let\expandafter\synindexfoo\expandafter=\csname#2indfile\endcsname -\expandafter\let\csname#1indfile\endcsname=\synindexfoo -\expandafter\xdef\csname#1index\endcsname{% % Define \xxxindex -\noexpand\docodeindex {#2}}% -} - -% Define \doindex, the driver for all \fooindex macros. -% Argument #1 is generated by the calling \fooindex macro, -% and it is "foo", the name of the index. - -% \doindex just uses \parsearg; it calls \doind for the actual work. -% This is because \doind is more useful to call from other macros. - -% There is also \dosubind {index}{topic}{subtopic} -% which makes an entry in a two-level index such as the operation index. - -\def\doindex#1{\edef\indexname{#1}\parsearg\singleindexer} -\def\singleindexer #1{\doind{\indexname}{#1}} - -% like the previous two, but they put @code around the argument. -\def\docodeindex#1{\edef\indexname{#1}\parsearg\singlecodeindexer} -\def\singlecodeindexer #1{\doind{\indexname}{\code{#1}}} - -\def\indexdummies{% -% Take care of the plain tex accent commands. -\def\"{\realbackslash "}% -\def\`{\realbackslash `}% -\def\'{\realbackslash '}% -\def\^{\realbackslash ^}% -\def\~{\realbackslash ~}% -\def\={\realbackslash =}% -\def\b{\realbackslash b}% -\def\c{\realbackslash c}% -\def\d{\realbackslash d}% -\def\u{\realbackslash u}% -\def\v{\realbackslash v}% -\def\H{\realbackslash H}% -% Take care of the plain tex special European modified letters. -\def\oe{\realbackslash oe}% -\def\ae{\realbackslash ae}% -\def\aa{\realbackslash aa}% -\def\OE{\realbackslash OE}% -\def\AE{\realbackslash AE}% -\def\AA{\realbackslash AA}% -\def\o{\realbackslash o}% -\def\O{\realbackslash O}% -\def\l{\realbackslash l}% -\def\L{\realbackslash L}% -\def\ss{\realbackslash ss}% -% Take care of texinfo commands likely to appear in an index entry. -% (Must be a way to avoid doing expansion at all, and thus not have to -% laboriously list every single command here.) -\def\@{@}% will be @@ when we switch to @ as escape char. -%\let\{ = \lbracecmd -%\let\} = \rbracecmd -\def\_{{\realbackslash _}}% -\def\w{\realbackslash w }% -\def\bf{\realbackslash bf }% -%\def\rm{\realbackslash rm }% -\def\sl{\realbackslash sl }% -\def\sf{\realbackslash sf}% -\def\tt{\realbackslash tt}% -\def\gtr{\realbackslash gtr}% -\def\less{\realbackslash less}% -\def\hat{\realbackslash hat}% -%\def\char{\realbackslash char}% -\def\TeX{\realbackslash TeX}% -\def\dots{\realbackslash dots }% -\def\result{\realbackslash result}% -\def\equiv{\realbackslash equiv}% -\def\expansion{\realbackslash expansion}% -\def\print{\realbackslash print}% -\def\error{\realbackslash error}% -\def\point{\realbackslash point}% -\def\copyright{\realbackslash copyright}% -\def\tclose##1{\realbackslash tclose {##1}}% -\def\code##1{\realbackslash code {##1}}% -\def\dotless##1{\realbackslash dotless {##1}}% -\def\samp##1{\realbackslash samp {##1}}% -\def\,##1{\realbackslash ,{##1}}% -\def\t##1{\realbackslash t {##1}}% -\def\r##1{\realbackslash r {##1}}% -\def\i##1{\realbackslash i {##1}}% -\def\b##1{\realbackslash b {##1}}% -\def\sc##1{\realbackslash sc {##1}}% -\def\cite##1{\realbackslash cite {##1}}% -\def\key##1{\realbackslash key {##1}}% -\def\file##1{\realbackslash file {##1}}% -\def\var##1{\realbackslash var {##1}}% -\def\kbd##1{\realbackslash kbd {##1}}% -\def\dfn##1{\realbackslash dfn {##1}}% -\def\emph##1{\realbackslash emph {##1}}% -\def\value##1{\realbackslash value {##1}}% -\unsepspaces -} - -% If an index command is used in an @example environment, any spaces -% therein should become regular spaces in the raw index file, not the -% expansion of \tie (\\leavevmode \penalty \@M \ ). -{\obeyspaces - \gdef\unsepspaces{\obeyspaces\let =\space}} - -% \indexnofonts no-ops all font-change commands. -% This is used when outputting the strings to sort the index by. -\def\indexdummyfont#1{#1} -\def\indexdummytex{TeX} -\def\indexdummydots{...} - -\def\indexnofonts{% -% Just ignore accents. -\let\,=\indexdummyfont -\let\"=\indexdummyfont -\let\`=\indexdummyfont -\let\'=\indexdummyfont -\let\^=\indexdummyfont -\let\~=\indexdummyfont -\let\==\indexdummyfont -\let\b=\indexdummyfont -\let\c=\indexdummyfont -\let\d=\indexdummyfont -\let\u=\indexdummyfont -\let\v=\indexdummyfont -\let\H=\indexdummyfont -\let\dotless=\indexdummyfont -% Take care of the plain tex special European modified letters. -\def\oe{oe}% -\def\ae{ae}% -\def\aa{aa}% -\def\OE{OE}% -\def\AE{AE}% -\def\AA{AA}% -\def\o{o}% -\def\O{O}% -\def\l{l}% -\def\L{L}% -\def\ss{ss}% -\let\w=\indexdummyfont -\let\t=\indexdummyfont -\let\r=\indexdummyfont -\let\i=\indexdummyfont -\let\b=\indexdummyfont -\let\emph=\indexdummyfont -\let\strong=\indexdummyfont -\let\cite=\indexdummyfont -\let\sc=\indexdummyfont -%Don't no-op \tt, since it isn't a user-level command -% and is used in the definitions of the active chars like <, >, |... -%\let\tt=\indexdummyfont -\let\tclose=\indexdummyfont -\let\code=\indexdummyfont -\let\file=\indexdummyfont -\let\samp=\indexdummyfont -\let\kbd=\indexdummyfont -\let\key=\indexdummyfont -\let\var=\indexdummyfont -\let\TeX=\indexdummytex -\let\dots=\indexdummydots -\def\@{@}% -} - -% To define \realbackslash, we must make \ not be an escape. -% We must first make another character (@) an escape -% so we do not become unable to do a definition. - -{\catcode`\@=0 \catcode`\\=\other -@gdef@realbackslash{\}} - -\let\indexbackslash=0 %overridden during \printindex. - -\let\SETmarginindex=\relax %initialize! -% workhorse for all \fooindexes -% #1 is name of index, #2 is stuff to put there -\def\doind #1#2{% - % Put the index entry in the margin if desired. - \ifx\SETmarginindex\relax\else - \insert\margin{\hbox{\vrule height8pt depth3pt width0pt #2}}% - \fi - {% - \count255=\lastpenalty - {% - \indexdummies % Must do this here, since \bf, etc expand at this stage - \escapechar=`\\ - {% - \let\folio=0% We will expand all macros now EXCEPT \folio. - \def\rawbackslashxx{\indexbackslash}% \indexbackslash isn't defined now - % so it will be output as is; and it will print as backslash. - % - % First process the index-string with all font commands turned off - % to get the string to sort by. - {\indexnofonts \xdef\indexsorttmp{#2}}% - % - % Now produce the complete index entry, with both the sort key and the - % original text, including any font commands. - \toks0 = {#2}% - \edef\temp{% - \write\csname#1indfile\endcsname{% - \realbackslash entry{\indexsorttmp}{\folio}{\the\toks0}}% - }% - \temp - }% - }% - \penalty\count255 - }% -} - -\def\dosubind #1#2#3{% -{\count10=\lastpenalty % -{\indexdummies % Must do this here, since \bf, etc expand at this stage -\escapechar=`\\% -{\let\folio=0% -\def\rawbackslashxx{\indexbackslash}% -% -% Now process the index-string once, with all font commands turned off, -% to get the string to sort the index by. -{\indexnofonts -\xdef\temp1{#2 #3}% -}% -% Now produce the complete index entry. We process the index-string again, -% this time with font commands expanded, to get what to print in the index. -\edef\temp{% -\write \csname#1indfile\endcsname{% -\realbackslash entry {\temp1}{\folio}{#2}{#3}}}% -\temp }% -}\penalty\count10}} - -% The index entry written in the file actually looks like -% \entry {sortstring}{page}{topic} -% or -% \entry {sortstring}{page}{topic}{subtopic} -% The texindex program reads in these files and writes files -% containing these kinds of lines: -% \initial {c} -% before the first topic whose initial is c -% \entry {topic}{pagelist} -% for a topic that is used without subtopics -% \primary {topic} -% for the beginning of a topic that is used with subtopics -% \secondary {subtopic}{pagelist} -% for each subtopic. - -% Define the user-accessible indexing commands -% @findex, @vindex, @kindex, @cindex. - -\def\findex {\fnindex} -\def\kindex {\kyindex} -\def\cindex {\cpindex} -\def\vindex {\vrindex} -\def\tindex {\tpindex} -\def\pindex {\pgindex} - -\def\cindexsub {\begingroup\obeylines\cindexsub} -{\obeylines % -\gdef\cindexsub "#1" #2^^M{\endgroup % -\dosubind{cp}{#2}{#1}}} - -% Define the macros used in formatting output of the sorted index material. - -% @printindex causes a particular index (the ??s file) to get printed. -% It does not print any chapter heading (usually an @unnumbered). -% -\def\printindex{\parsearg\doprintindex} -\def\doprintindex#1{\begingroup - \dobreak \chapheadingskip{10000}% - % - \indexfonts \rm - \tolerance = 9500 - \indexbreaks - % - % See if the index file exists and is nonempty. - % Change catcode of @ here so that if the index file contains - % \initial {@} - % as its first line, TeX doesn't complain about mismatched braces - % (because it thinks @} is a control sequence). - \catcode`\@ = 11 - \openin 1 \jobname.#1s - \ifeof 1 - % \enddoublecolumns gets confused if there is no text in the index, - % and it loses the chapter title and the aux file entries for the - % index. The easiest way to prevent this problem is to make sure - % there is some text. - (Index is nonexistent) - \else - % - % If the index file exists but is empty, then \openin leaves \ifeof - % false. We have to make TeX try to read something from the file, so - % it can discover if there is anything in it. - \read 1 to \temp - \ifeof 1 - (Index is empty) - \else - % Index files are almost Texinfo source, but we use \ as the escape - % character. It would be better to use @, but that's too big a change - % to make right now. - \def\indexbackslash{\rawbackslashxx}% - \catcode`\\ = 0 - \escapechar = `\\ - \begindoublecolumns - \input \jobname.#1s - \enddoublecolumns - \fi - \fi - \closein 1 -\endgroup} - -% These macros are used by the sorted index file itself. -% Change them to control the appearance of the index. - -% Same as \bigskipamount except no shrink. -% \balancecolumns gets confused if there is any shrink. -\newskip\initialskipamount \initialskipamount 12pt plus4pt - -\def\initial #1{% -{\let\tentt=\sectt \let\tt=\sectt \let\sf=\sectt -\ifdim\lastskip<\initialskipamount -\removelastskip \penalty-200 \vskip \initialskipamount\fi -\line{\secbf#1\hfill}\kern 2pt\penalty10000}} - -% This typesets a paragraph consisting of #1, dot leaders, and then #2 -% flush to the right margin. It is used for index and table of contents -% entries. The paragraph is indented by \leftskip. -% -\def\entry #1#2{\begingroup - % - % Start a new paragraph if necessary, so our assignments below can't - % affect previous text. - \par - % - % Do not fill out the last line with white space. - \parfillskip = 0in - % - % No extra space above this paragraph. - \parskip = 0in - % - % Do not prefer a separate line ending with a hyphen to fewer lines. - \finalhyphendemerits = 0 - % - % \hangindent is only relevant when the entry text and page number - % don't both fit on one line. In that case, bob suggests starting the - % dots pretty far over on the line. Unfortunately, a large - % indentation looks wrong when the entry text itself is broken across - % lines. So we use a small indentation and put up with long leaders. - % - % \hangafter is reset to 1 (which is the value we want) at the start - % of each paragraph, so we need not do anything with that. - \hangindent=2em - % - % When the entry text needs to be broken, just fill out the first line - % with blank space. - \rightskip = 0pt plus1fil - % - % Start a ``paragraph'' for the index entry so the line breaking - % parameters we've set above will have an effect. - \noindent - % - % Insert the text of the index entry. TeX will do line-breaking on it. - #1% - % The following is kludged to not output a line of dots in the index if - % there are no page numbers. The next person who breaks this will be - % cursed by a Unix daemon. - \def\tempa{{\rm }}% - \def\tempb{#2}% - \edef\tempc{\tempa}% - \edef\tempd{\tempb}% - \ifx\tempc\tempd\ \else% - % - % If we must, put the page number on a line of its own, and fill out - % this line with blank space. (The \hfil is overwhelmed with the - % fill leaders glue in \indexdotfill if the page number does fit.) - \hfil\penalty50 - \null\nobreak\indexdotfill % Have leaders before the page number. - % - % The `\ ' here is removed by the implicit \unskip that TeX does as - % part of (the primitive) \par. Without it, a spurious underfull - % \hbox ensues. - \ #2% The page number ends the paragraph. - \fi% - \par -\endgroup} - -% Like \dotfill except takes at least 1 em. -\def\indexdotfill{\cleaders - \hbox{$\mathsurround=0pt \mkern1.5mu ${\it .}$ \mkern1.5mu$}\hskip 1em plus 1fill} - -\def\primary #1{\line{#1\hfil}} - -\newskip\secondaryindent \secondaryindent=0.5cm - -\def\secondary #1#2{ -{\parfillskip=0in \parskip=0in -\hangindent =1in \hangafter=1 -\noindent\hskip\secondaryindent\hbox{#1}\indexdotfill #2\par -}} - -% Define two-column mode, which we use to typeset indexes. -% Adapted from the TeXbook, page 416, which is to say, -% the manmac.tex format used to print the TeXbook itself. -\catcode`\@=11 - -\newbox\partialpage -\newdimen\doublecolumnhsize - -\def\begindoublecolumns{\begingroup % ended by \enddoublecolumns - % Grab any single-column material above us. - \output = {\global\setbox\partialpage = \vbox{% - % - % Here is a possibility not foreseen in manmac: if we accumulate a - % whole lot of material, we might end up calling this \output - % routine twice in a row (see the doublecol-lose test, which is - % essentially a couple of indexes with @setchapternewpage off). In - % that case, we must prevent the second \partialpage from - % simply overwriting the first, causing us to lose the page. - % This will preserve it until a real output routine can ship it - % out. Generally, \partialpage will be empty when this runs and - % this will be a no-op. - \unvbox\partialpage - % - % Unvbox the main output page. - \unvbox255 - \kern-\topskip \kern\baselineskip - }}% - \eject - % - % Use the double-column output routine for subsequent pages. - \output = {\doublecolumnout}% - % - % Change the page size parameters. We could do this once outside this - % routine, in each of @smallbook, @afourpaper, and the default 8.5x11 - % format, but then we repeat the same computation. Repeating a couple - % of assignments once per index is clearly meaningless for the - % execution time, so we may as well do it in one place. - % - % First we halve the line length, less a little for the gutter between - % the columns. We compute the gutter based on the line length, so it - % changes automatically with the paper format. The magic constant - % below is chosen so that the gutter has the same value (well, +-<1pt) - % as it did when we hard-coded it. - % - % We put the result in a separate register, \doublecolumhsize, so we - % can restore it in \pagesofar, after \hsize itself has (potentially) - % been clobbered. - % - \doublecolumnhsize = \hsize - \advance\doublecolumnhsize by -.04154\hsize - \divide\doublecolumnhsize by 2 - \hsize = \doublecolumnhsize - % - % Double the \vsize as well. (We don't need a separate register here, - % since nobody clobbers \vsize.) - \vsize = 2\vsize -} -\def\doublecolumnout{% - \splittopskip=\topskip \splitmaxdepth=\maxdepth - % Get the available space for the double columns -- the normal - % (undoubled) page height minus any material left over from the - % previous page. - \dimen@=\pageheight \advance\dimen@ by-\ht\partialpage - % box0 will be the left-hand column, box2 the right. - \setbox0=\vsplit255 to\dimen@ \setbox2=\vsplit255 to\dimen@ - \onepageout\pagesofar - \unvbox255 - \penalty\outputpenalty -} -\def\pagesofar{% - % Re-output the contents of the output page -- any previous material, - % followed by the two boxes we just split. - \unvbox\partialpage - \hsize = \doublecolumnhsize - \wd0=\hsize \wd2=\hsize \hbox to\pagewidth{\box0\hfil\box2}% -} -\def\enddoublecolumns{% - \output = {\balancecolumns}\eject % split what we have - \endgroup % started in \begindoublecolumns - % - % Back to normal single-column typesetting, but take account of the - % fact that we just accumulated some stuff on the output page. - \pagegoal = \vsize -} -\def\balancecolumns{% - % Called at the end of the double column material. - \setbox0 = \vbox{\unvbox255}% - \dimen@ = \ht0 - \advance\dimen@ by \topskip - \advance\dimen@ by-\baselineskip - \divide\dimen@ by 2 - \splittopskip = \topskip - % Loop until we get a decent breakpoint. - {\vbadness=10000 \loop - \global\setbox3=\copy0 - \global\setbox1=\vsplit3 to\dimen@ - \ifdim\ht3>\dimen@ \global\advance\dimen@ by1pt - \repeat}% - \setbox0=\vbox to\dimen@{\unvbox1}% - \setbox2=\vbox to\dimen@{\unvbox3}% - \pagesofar -} -\catcode`\@ = \other - - -\message{sectioning,} -% Define chapters, sections, etc. - -\newcount\chapno -\newcount\secno \secno=0 -\newcount\subsecno \subsecno=0 -\newcount\subsubsecno \subsubsecno=0 - -% This counter is funny since it counts through charcodes of letters A, B, ... -\newcount\appendixno \appendixno = `\@ -\def\appendixletter{\char\the\appendixno} - -\newwrite\contentsfile -% This is called from \setfilename. -\def\opencontents{\openout\contentsfile = \jobname.toc } - -% Each @chapter defines this as the name of the chapter. -% page headings and footings can use it. @section does likewise - -\def\thischapter{} \def\thissection{} -\def\seccheck#1{\ifnum \pageno<0 - \errmessage{@#1 not allowed after generating table of contents}% -\fi} - -\def\chapternofonts{% - \let\rawbackslash=\relax - \let\frenchspacing=\relax - \def\result{\realbackslash result}% - \def\equiv{\realbackslash equiv}% - \def\expansion{\realbackslash expansion}% - \def\print{\realbackslash print}% - \def\TeX{\realbackslash TeX}% - \def\dots{\realbackslash dots}% - \def\result{\realbackslash result}% - \def\equiv{\realbackslash equiv}% - \def\expansion{\realbackslash expansion}% - \def\print{\realbackslash print}% - \def\error{\realbackslash error}% - \def\point{\realbackslash point}% - \def\copyright{\realbackslash copyright}% - \def\tt{\realbackslash tt}% - \def\bf{\realbackslash bf}% - \def\w{\realbackslash w}% - \def\less{\realbackslash less}% - \def\gtr{\realbackslash gtr}% - \def\hat{\realbackslash hat}% - \def\char{\realbackslash char}% - \def\tclose##1{\realbackslash tclose{##1}}% - \def\code##1{\realbackslash code{##1}}% - \def\samp##1{\realbackslash samp{##1}}% - \def\r##1{\realbackslash r{##1}}% - \def\b##1{\realbackslash b{##1}}% - \def\key##1{\realbackslash key{##1}}% - \def\file##1{\realbackslash file{##1}}% - \def\kbd##1{\realbackslash kbd{##1}}% - % These are redefined because @smartitalic wouldn't work inside xdef. - \def\i##1{\realbackslash i{##1}}% - \def\cite##1{\realbackslash cite{##1}}% - \def\var##1{\realbackslash var{##1}}% - \def\emph##1{\realbackslash emph{##1}}% - \def\dfn##1{\realbackslash dfn{##1}}% -} - -\newcount\absseclevel % used to calculate proper heading level -\newcount\secbase\secbase=0 % @raise/lowersections modify this count - -% @raisesections: treat @section as chapter, @subsection as section, etc. -\def\raisesections{\global\advance\secbase by -1} -\let\up=\raisesections % original BFox name - -% @lowersections: treat @chapter as section, @section as subsection, etc. -\def\lowersections{\global\advance\secbase by 1} -\let\down=\lowersections % original BFox name - -% Choose a numbered-heading macro -% #1 is heading level if unmodified by @raisesections or @lowersections -% #2 is text for heading -\def\numhead#1#2{\absseclevel=\secbase\advance\absseclevel by #1 -\ifcase\absseclevel - \chapterzzz{#2} -\or - \seczzz{#2} -\or - \numberedsubseczzz{#2} -\or - \numberedsubsubseczzz{#2} -\else - \ifnum \absseclevel<0 - \chapterzzz{#2} - \else - \numberedsubsubseczzz{#2} - \fi -\fi -} - -% like \numhead, but chooses appendix heading levels -\def\apphead#1#2{\absseclevel=\secbase\advance\absseclevel by #1 -\ifcase\absseclevel - \appendixzzz{#2} -\or - \appendixsectionzzz{#2} -\or - \appendixsubseczzz{#2} -\or - \appendixsubsubseczzz{#2} -\else - \ifnum \absseclevel<0 - \appendixzzz{#2} - \else - \appendixsubsubseczzz{#2} - \fi -\fi -} - -% like \numhead, but chooses numberless heading levels -\def\unnmhead#1#2{\absseclevel=\secbase\advance\absseclevel by #1 -\ifcase\absseclevel - \unnumberedzzz{#2} -\or - \unnumberedseczzz{#2} -\or - \unnumberedsubseczzz{#2} -\or - \unnumberedsubsubseczzz{#2} -\else - \ifnum \absseclevel<0 - \unnumberedzzz{#2} - \else - \unnumberedsubsubseczzz{#2} - \fi -\fi -} - - -\def\thischaptername{No Chapter Title} -\outer\def\chapter{\parsearg\chapteryyy} -\def\chapteryyy #1{\numhead0{#1}} % normally numhead0 calls chapterzzz -\def\chapterzzz #1{\seccheck{chapter}% -\secno=0 \subsecno=0 \subsubsecno=0 -\global\advance \chapno by 1 \message{\putwordChapter \the\chapno}% -\chapmacro {#1}{\the\chapno}% -\gdef\thissection{#1}% -\gdef\thischaptername{#1}% -% We don't substitute the actual chapter name into \thischapter -% because we don't want its macros evaluated now. -\xdef\thischapter{\putwordChapter{} \the\chapno: \noexpand\thischaptername}% -{\chapternofonts% -\toks0 = {#1}% -\edef\temp{{\realbackslash chapentry{\the\toks0}{\the\chapno}{\noexpand\folio}}}% -\escapechar=`\\% -\write \contentsfile \temp % -\donoderef % -\global\let\section = \numberedsec -\global\let\subsection = \numberedsubsec -\global\let\subsubsection = \numberedsubsubsec -}} - -\outer\def\appendix{\parsearg\appendixyyy} -\def\appendixyyy #1{\apphead0{#1}} % normally apphead0 calls appendixzzz -\def\appendixzzz #1{\seccheck{appendix}% -\secno=0 \subsecno=0 \subsubsecno=0 -\global\advance \appendixno by 1 \message{Appendix \appendixletter}% -\chapmacro {#1}{\putwordAppendix{} \appendixletter}% -\gdef\thissection{#1}% -\gdef\thischaptername{#1}% -\xdef\thischapter{\putwordAppendix{} \appendixletter: \noexpand\thischaptername}% -{\chapternofonts% -\toks0 = {#1}% -\edef\temp{{\realbackslash chapentry{\the\toks0}% - {\putwordAppendix{} \appendixletter}{\noexpand\folio}}}% -\escapechar=`\\% -\write \contentsfile \temp % -\appendixnoderef % -\global\let\section = \appendixsec -\global\let\subsection = \appendixsubsec -\global\let\subsubsection = \appendixsubsubsec -}} - -% @centerchap is like @unnumbered, but the heading is centered. -\outer\def\centerchap{\parsearg\centerchapyyy} -\def\centerchapyyy #1{{\let\unnumbchapmacro=\centerchapmacro \unnumberedyyy{#1}}} - -\outer\def\top{\parsearg\unnumberedyyy} -\outer\def\unnumbered{\parsearg\unnumberedyyy} -\def\unnumberedyyy #1{\unnmhead0{#1}} % normally unnmhead0 calls unnumberedzzz -\def\unnumberedzzz #1{\seccheck{unnumbered}% -\secno=0 \subsecno=0 \subsubsecno=0 -% -% This used to be simply \message{#1}, but TeX fully expands the -% argument to \message. Therefore, if #1 contained @-commands, TeX -% expanded them. For example, in `@unnumbered The @cite{Book}', TeX -% expanded @cite (which turns out to cause errors because \cite is meant -% to be executed, not expanded). -% -% Anyway, we don't want the fully-expanded definition of @cite to appear -% as a result of the \message, we just want `@cite' itself. We use -% \the to achieve this: TeX expands \the only once, -% simply yielding the contents of the . -\toks0 = {#1}\message{(\the\toks0)}% -% -\unnumbchapmacro {#1}% -\gdef\thischapter{#1}\gdef\thissection{#1}% -{\chapternofonts% -\toks0 = {#1}% -\edef\temp{{\realbackslash unnumbchapentry{\the\toks0}{\noexpand\folio}}}% -\escapechar=`\\% -\write \contentsfile \temp % -\unnumbnoderef % -\global\let\section = \unnumberedsec -\global\let\subsection = \unnumberedsubsec -\global\let\subsubsection = \unnumberedsubsubsec -}} - -\outer\def\numberedsec{\parsearg\secyyy} -\def\secyyy #1{\numhead1{#1}} % normally calls seczzz -\def\seczzz #1{\seccheck{section}% -\subsecno=0 \subsubsecno=0 \global\advance \secno by 1 % -\gdef\thissection{#1}\secheading {#1}{\the\chapno}{\the\secno}% -{\chapternofonts% -\toks0 = {#1}% -\edef\temp{{\realbackslash secentry % -{\the\toks0}{\the\chapno}{\the\secno}{\noexpand\folio}}}% -\escapechar=`\\% -\write \contentsfile \temp % -\donoderef % -\penalty 10000 % -}} - -\outer\def\appendixsection{\parsearg\appendixsecyyy} -\outer\def\appendixsec{\parsearg\appendixsecyyy} -\def\appendixsecyyy #1{\apphead1{#1}} % normally calls appendixsectionzzz -\def\appendixsectionzzz #1{\seccheck{appendixsection}% -\subsecno=0 \subsubsecno=0 \global\advance \secno by 1 % -\gdef\thissection{#1}\secheading {#1}{\appendixletter}{\the\secno}% -{\chapternofonts% -\toks0 = {#1}% -\edef\temp{{\realbackslash secentry % -{\the\toks0}{\appendixletter}{\the\secno}{\noexpand\folio}}}% -\escapechar=`\\% -\write \contentsfile \temp % -\appendixnoderef % -\penalty 10000 % -}} - -\outer\def\unnumberedsec{\parsearg\unnumberedsecyyy} -\def\unnumberedsecyyy #1{\unnmhead1{#1}} % normally calls unnumberedseczzz -\def\unnumberedseczzz #1{\seccheck{unnumberedsec}% -\plainsecheading {#1}\gdef\thissection{#1}% -{\chapternofonts% -\toks0 = {#1}% -\edef\temp{{\realbackslash unnumbsecentry{\the\toks0}{\noexpand\folio}}}% -\escapechar=`\\% -\write \contentsfile \temp % -\unnumbnoderef % -\penalty 10000 % -}} - -\outer\def\numberedsubsec{\parsearg\numberedsubsecyyy} -\def\numberedsubsecyyy #1{\numhead2{#1}} % normally calls numberedsubseczzz -\def\numberedsubseczzz #1{\seccheck{subsection}% -\gdef\thissection{#1}\subsubsecno=0 \global\advance \subsecno by 1 % -\subsecheading {#1}{\the\chapno}{\the\secno}{\the\subsecno}% -{\chapternofonts% -\toks0 = {#1}% -\edef\temp{{\realbackslash subsecentry % -{\the\toks0}{\the\chapno}{\the\secno}{\the\subsecno}{\noexpand\folio}}}% -\escapechar=`\\% -\write \contentsfile \temp % -\donoderef % -\penalty 10000 % -}} - -\outer\def\appendixsubsec{\parsearg\appendixsubsecyyy} -\def\appendixsubsecyyy #1{\apphead2{#1}} % normally calls appendixsubseczzz -\def\appendixsubseczzz #1{\seccheck{appendixsubsec}% -\gdef\thissection{#1}\subsubsecno=0 \global\advance \subsecno by 1 % -\subsecheading {#1}{\appendixletter}{\the\secno}{\the\subsecno}% -{\chapternofonts% -\toks0 = {#1}% -\edef\temp{{\realbackslash subsecentry % -{\the\toks0}{\appendixletter}{\the\secno}{\the\subsecno}{\noexpand\folio}}}% -\escapechar=`\\% -\write \contentsfile \temp % -\appendixnoderef % -\penalty 10000 % -}} - -\outer\def\unnumberedsubsec{\parsearg\unnumberedsubsecyyy} -\def\unnumberedsubsecyyy #1{\unnmhead2{#1}} %normally calls unnumberedsubseczzz -\def\unnumberedsubseczzz #1{\seccheck{unnumberedsubsec}% -\plainsubsecheading {#1}\gdef\thissection{#1}% -{\chapternofonts% -\toks0 = {#1}% -\edef\temp{{\realbackslash unnumbsubsecentry{\the\toks0}{\noexpand\folio}}}% -\escapechar=`\\% -\write \contentsfile \temp % -\unnumbnoderef % -\penalty 10000 % -}} - -\outer\def\numberedsubsubsec{\parsearg\numberedsubsubsecyyy} -\def\numberedsubsubsecyyy #1{\numhead3{#1}} % normally numberedsubsubseczzz -\def\numberedsubsubseczzz #1{\seccheck{subsubsection}% -\gdef\thissection{#1}\global\advance \subsubsecno by 1 % -\subsubsecheading {#1} - {\the\chapno}{\the\secno}{\the\subsecno}{\the\subsubsecno}% -{\chapternofonts% -\toks0 = {#1}% -\edef\temp{{\realbackslash subsubsecentry{\the\toks0} - {\the\chapno}{\the\secno}{\the\subsecno}{\the\subsubsecno} - {\noexpand\folio}}}% -\escapechar=`\\% -\write \contentsfile \temp % -\donoderef % -\penalty 10000 % -}} - -\outer\def\appendixsubsubsec{\parsearg\appendixsubsubsecyyy} -\def\appendixsubsubsecyyy #1{\apphead3{#1}} % normally appendixsubsubseczzz -\def\appendixsubsubseczzz #1{\seccheck{appendixsubsubsec}% -\gdef\thissection{#1}\global\advance \subsubsecno by 1 % -\subsubsecheading {#1} - {\appendixletter}{\the\secno}{\the\subsecno}{\the\subsubsecno}% -{\chapternofonts% -\toks0 = {#1}% -\edef\temp{{\realbackslash subsubsecentry{\the\toks0}% - {\appendixletter} - {\the\secno}{\the\subsecno}{\the\subsubsecno}{\noexpand\folio}}}% -\escapechar=`\\% -\write \contentsfile \temp % -\appendixnoderef % -\penalty 10000 % -}} - -\outer\def\unnumberedsubsubsec{\parsearg\unnumberedsubsubsecyyy} -\def\unnumberedsubsubsecyyy #1{\unnmhead3{#1}} %normally unnumberedsubsubseczzz -\def\unnumberedsubsubseczzz #1{\seccheck{unnumberedsubsubsec}% -\plainsubsubsecheading {#1}\gdef\thissection{#1}% -{\chapternofonts% -\toks0 = {#1}% -\edef\temp{{\realbackslash unnumbsubsubsecentry{\the\toks0}{\noexpand\folio}}}% -\escapechar=`\\% -\write \contentsfile \temp % -\unnumbnoderef % -\penalty 10000 % -}} - -% These are variants which are not "outer", so they can appear in @ifinfo. -% Actually, they should now be obsolete; ordinary section commands should work. -\def\infotop{\parsearg\unnumberedzzz} -\def\infounnumbered{\parsearg\unnumberedzzz} -\def\infounnumberedsec{\parsearg\unnumberedseczzz} -\def\infounnumberedsubsec{\parsearg\unnumberedsubseczzz} -\def\infounnumberedsubsubsec{\parsearg\unnumberedsubsubseczzz} - -\def\infoappendix{\parsearg\appendixzzz} -\def\infoappendixsec{\parsearg\appendixseczzz} -\def\infoappendixsubsec{\parsearg\appendixsubseczzz} -\def\infoappendixsubsubsec{\parsearg\appendixsubsubseczzz} - -\def\infochapter{\parsearg\chapterzzz} -\def\infosection{\parsearg\sectionzzz} -\def\infosubsection{\parsearg\subsectionzzz} -\def\infosubsubsection{\parsearg\subsubsectionzzz} - -% These macros control what the section commands do, according -% to what kind of chapter we are in (ordinary, appendix, or unnumbered). -% Define them by default for a numbered chapter. -\global\let\section = \numberedsec -\global\let\subsection = \numberedsubsec -\global\let\subsubsection = \numberedsubsubsec - -% Define @majorheading, @heading and @subheading - -% NOTE on use of \vbox for chapter headings, section headings, and -% such: -% 1) We use \vbox rather than the earlier \line to permit -% overlong headings to fold. -% 2) \hyphenpenalty is set to 10000 because hyphenation in a -% heading is obnoxious; this forbids it. -% 3) Likewise, headings look best if no \parindent is used, and -% if justification is not attempted. Hence \raggedright. - - -\def\majorheading{\parsearg\majorheadingzzz} -\def\majorheadingzzz #1{% -{\advance\chapheadingskip by 10pt \chapbreak }% -{\chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000 - \parindent=0pt\raggedright - \rm #1\hfill}}\bigskip \par\penalty 200} - -\def\chapheading{\parsearg\chapheadingzzz} -\def\chapheadingzzz #1{\chapbreak % -{\chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000 - \parindent=0pt\raggedright - \rm #1\hfill}}\bigskip \par\penalty 200} - -% @heading, @subheading, @subsubheading. -\def\heading{\parsearg\plainsecheading} -\def\subheading{\parsearg\plainsubsecheading} -\def\subsubheading{\parsearg\plainsubsubsecheading} - -% These macros generate a chapter, section, etc. heading only -% (including whitespace, linebreaking, etc. around it), -% given all the information in convenient, parsed form. - -%%% Args are the skip and penalty (usually negative) -\def\dobreak#1#2{\par\ifdim\lastskip<#1\removelastskip\penalty#2\vskip#1\fi} - -\def\setchapterstyle #1 {\csname CHAPF#1\endcsname} - -%%% Define plain chapter starts, and page on/off switching for it -% Parameter controlling skip before chapter headings (if needed) - -\newskip\chapheadingskip - -\def\chapbreak{\dobreak \chapheadingskip {-4000}} -\def\chappager{\par\vfill\supereject} -\def\chapoddpage{\chappager \ifodd\pageno \else \hbox to 0pt{} \chappager\fi} - -\def\setchapternewpage #1 {\csname CHAPPAG#1\endcsname} - -\def\CHAPPAGoff{ -\global\let\contentsalignmacro = \chappager -\global\let\pchapsepmacro=\chapbreak -\global\let\pagealignmacro=\chappager} - -\def\CHAPPAGon{ -\global\let\contentsalignmacro = \chappager -\global\let\pchapsepmacro=\chappager -\global\let\pagealignmacro=\chappager -\global\def\HEADINGSon{\HEADINGSsingle}} - -\def\CHAPPAGodd{ -\global\let\contentsalignmacro = \chapoddpage -\global\let\pchapsepmacro=\chapoddpage -\global\let\pagealignmacro=\chapoddpage -\global\def\HEADINGSon{\HEADINGSdouble}} - -\CHAPPAGon - -\def\CHAPFplain{ -\global\let\chapmacro=\chfplain -\global\let\unnumbchapmacro=\unnchfplain -\global\let\centerchapmacro=\centerchfplain} - -% Plain chapter opening. -% #1 is the text, #2 the chapter number or empty if unnumbered. -\def\chfplain#1#2{% - \pchapsepmacro - {% - \chapfonts \rm - \def\chapnum{#2}% - \setbox0 = \hbox{#2\ifx\chapnum\empty\else\enspace\fi}% - \vbox{\hyphenpenalty=10000 \tolerance=5000 \parindent=0pt \raggedright - \hangindent = \wd0 \centerparametersmaybe - \unhbox0 #1\par}% - }% - \nobreak\bigskip % no page break after a chapter title - \nobreak -} - -% Plain opening for unnumbered. -\def\unnchfplain#1{\chfplain{#1}{}} - -% @centerchap -- centered and unnumbered. -\let\centerparametersmaybe = \relax -\def\centerchfplain#1{{% - \def\centerparametersmaybe{% - \advance\rightskip by 3\rightskip - \leftskip = \rightskip - \parfillskip = 0pt - }% - \chfplain{#1}{}% -}} - -\CHAPFplain % The default - -\def\unnchfopen #1{% -\chapoddpage {\chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000 - \parindent=0pt\raggedright - \rm #1\hfill}}\bigskip \par\penalty 10000 % -} - -\def\chfopen #1#2{\chapoddpage {\chapfonts -\vbox to 3in{\vfil \hbox to\hsize{\hfil #2} \hbox to\hsize{\hfil #1} \vfil}}% -\par\penalty 5000 % -} - -\def\centerchfopen #1{% -\chapoddpage {\chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000 - \parindent=0pt - \hfill {\rm #1}\hfill}}\bigskip \par\penalty 10000 % -} - -\def\CHAPFopen{ -\global\let\chapmacro=\chfopen -\global\let\unnumbchapmacro=\unnchfopen -\global\let\centerchapmacro=\centerchfopen} - - -% Section titles. -\newskip\secheadingskip -\def\secheadingbreak{\dobreak \secheadingskip {-1000}} -\def\secheading#1#2#3{\sectionheading{sec}{#2.#3}{#1}} -\def\plainsecheading#1{\sectionheading{sec}{}{#1}} - -% Subsection titles. -\newskip \subsecheadingskip -\def\subsecheadingbreak{\dobreak \subsecheadingskip {-500}} -\def\subsecheading#1#2#3#4{\sectionheading{subsec}{#2.#3.#4}{#1}} -\def\plainsubsecheading#1{\sectionheading{subsec}{}{#1}} - -% Subsubsection titles. -\let\subsubsecheadingskip = \subsecheadingskip -\let\subsubsecheadingbreak = \subsecheadingbreak -\def\subsubsecheading#1#2#3#4#5{\sectionheading{subsubsec}{#2.#3.#4.#5}{#1}} -\def\plainsubsubsecheading#1{\sectionheading{subsubsec}{}{#1}} - - -% Print any size section title. -% -% #1 is the section type (sec/subsec/subsubsec), #2 is the section -% number (maybe empty), #3 the text. -\def\sectionheading#1#2#3{% - {% - \expandafter\advance\csname #1headingskip\endcsname by \parskip - \csname #1headingbreak\endcsname - }% - {% - % Switch to the right set of fonts. - \csname #1fonts\endcsname \rm - % - % Only insert the separating space if we have a section number. - \def\secnum{#2}% - \setbox0 = \hbox{#2\ifx\secnum\empty\else\enspace\fi}% - % - \vbox{\hyphenpenalty=10000 \tolerance=5000 \parindent=0pt \raggedright - \hangindent = \wd0 % zero if no section number - \unhbox0 #3}% - }% - \ifdim\parskip<10pt \nobreak\kern10pt\nobreak\kern-\parskip\fi \nobreak -} - - -\message{toc printing,} -% Finish up the main text and prepare to read what we've written -% to \contentsfile. - -\newskip\contentsrightmargin \contentsrightmargin=1in -\def\startcontents#1{% - % If @setchapternewpage on, and @headings double, the contents should - % start on an odd page, unlike chapters. Thus, we maintain - % \contentsalignmacro in parallel with \pagealignmacro. - % From: Torbjorn Granlund - \contentsalignmacro - \immediate\closeout \contentsfile - \ifnum \pageno>0 - \pageno = -1 % Request roman numbered pages. - \fi - % Don't need to put `Contents' or `Short Contents' in the headline. - % It is abundantly clear what they are. - \unnumbchapmacro{#1}\def\thischapter{}% - \begingroup % Set up to handle contents files properly. - \catcode`\\=0 \catcode`\{=1 \catcode`\}=2 \catcode`\@=11 - % We can't do this, because then an actual ^ in a section - % title fails, e.g., @chapter ^ -- exponentiation. --karl, 9jul97. - %\catcode`\^=7 % to see ^^e4 as \"a etc. juha@piuha.ydi.vtt.fi - \raggedbottom % Worry more about breakpoints than the bottom. - \advance\hsize by -\contentsrightmargin % Don't use the full line length. -} - - -% Normal (long) toc. -\outer\def\contents{% - \startcontents{\putwordTableofContents}% - \input \jobname.toc - \endgroup - \vfill \eject -} - -% And just the chapters. -\outer\def\summarycontents{% - \startcontents{\putwordShortContents}% - % - \let\chapentry = \shortchapentry - \let\unnumbchapentry = \shortunnumberedentry - % We want a true roman here for the page numbers. - \secfonts - \let\rm=\shortcontrm \let\bf=\shortcontbf \let\sl=\shortcontsl - \rm - \hyphenpenalty = 10000 - \advance\baselineskip by 1pt % Open it up a little. - \def\secentry ##1##2##3##4{} - \def\unnumbsecentry ##1##2{} - \def\subsecentry ##1##2##3##4##5{} - \def\unnumbsubsecentry ##1##2{} - \def\subsubsecentry ##1##2##3##4##5##6{} - \def\unnumbsubsubsecentry ##1##2{} - \input \jobname.toc - \endgroup - \vfill \eject -} -\let\shortcontents = \summarycontents - -% These macros generate individual entries in the table of contents. -% The first argument is the chapter or section name. -% The last argument is the page number. -% The arguments in between are the chapter number, section number, ... - -% Chapter-level things, for both the long and short contents. -\def\chapentry#1#2#3{\dochapentry{#2\labelspace#1}{#3}} - -% See comments in \dochapentry re vbox and related settings -\def\shortchapentry#1#2#3{% - \tocentry{\shortchaplabel{#2}\labelspace #1}{\doshortpageno{#3}}% -} - -% Typeset the label for a chapter or appendix for the short contents. -% The arg is, e.g. `Appendix A' for an appendix, or `3' for a chapter. -% We could simplify the code here by writing out an \appendixentry -% command in the toc file for appendices, instead of using \chapentry -% for both, but it doesn't seem worth it. -\setbox0 = \hbox{\shortcontrm \putwordAppendix } -\newdimen\shortappendixwidth \shortappendixwidth = \wd0 - -\def\shortchaplabel#1{% - % We typeset #1 in a box of constant width, regardless of the text of - % #1, so the chapter titles will come out aligned. - \setbox0 = \hbox{#1}% - \dimen0 = \ifdim\wd0 > \shortappendixwidth \shortappendixwidth \else 0pt \fi - % - % This space should be plenty, since a single number is .5em, and the - % widest letter (M) is 1em, at least in the Computer Modern fonts. - % (This space doesn't include the extra space that gets added after - % the label; that gets put in by \shortchapentry above.) - \advance\dimen0 by 1.1em - \hbox to \dimen0{#1\hfil}% -} - -\def\unnumbchapentry#1#2{\dochapentry{#1}{#2}} -\def\shortunnumberedentry#1#2{\tocentry{#1}{\doshortpageno{#2}}} - -% Sections. -\def\secentry#1#2#3#4{\dosecentry{#2.#3\labelspace#1}{#4}} -\def\unnumbsecentry#1#2{\dosecentry{#1}{#2}} - -% Subsections. -\def\subsecentry#1#2#3#4#5{\dosubsecentry{#2.#3.#4\labelspace#1}{#5}} -\def\unnumbsubsecentry#1#2{\dosubsecentry{#1}{#2}} - -% And subsubsections. -\def\subsubsecentry#1#2#3#4#5#6{% - \dosubsubsecentry{#2.#3.#4.#5\labelspace#1}{#6}} -\def\unnumbsubsubsecentry#1#2{\dosubsubsecentry{#1}{#2}} - -% This parameter controls the indentation of the various levels. -\newdimen\tocindent \tocindent = 3pc - -% Now for the actual typesetting. In all these, #1 is the text and #2 is the -% page number. -% -% If the toc has to be broken over pages, we want it to be at chapters -% if at all possible; hence the \penalty. -\def\dochapentry#1#2{% - \penalty-300 \vskip1\baselineskip plus.33\baselineskip minus.25\baselineskip - \begingroup - \chapentryfonts - \tocentry{#1}{\dopageno{#2}}% - \endgroup - \nobreak\vskip .25\baselineskip plus.1\baselineskip -} - -\def\dosecentry#1#2{\begingroup - \secentryfonts \leftskip=\tocindent - \tocentry{#1}{\dopageno{#2}}% -\endgroup} - -\def\dosubsecentry#1#2{\begingroup - \subsecentryfonts \leftskip=2\tocindent - \tocentry{#1}{\dopageno{#2}}% -\endgroup} - -\def\dosubsubsecentry#1#2{\begingroup - \subsubsecentryfonts \leftskip=3\tocindent - \tocentry{#1}{\dopageno{#2}}% -\endgroup} - -% Final typesetting of a toc entry; we use the same \entry macro as for -% the index entries, but we want to suppress hyphenation here. (We -% can't do that in the \entry macro, since index entries might consist -% of hyphenated-identifiers-that-do-not-fit-on-a-line-and-nothing-else.) -\def\tocentry#1#2{\begingroup - \vskip 0pt plus1pt % allow a little stretch for the sake of nice page breaks - % Do not use \turnoffactive in these arguments. Since the toc is - % typeset in cmr, so characters such as _ would come out wrong; we - % have to do the usual translation tricks. - \entry{#1}{#2}% -\endgroup} - -% Space between chapter (or whatever) number and the title. -\def\labelspace{\hskip1em \relax} - -\def\dopageno#1{{\rm #1}} -\def\doshortpageno#1{{\rm #1}} - -\def\chapentryfonts{\secfonts \rm} -\def\secentryfonts{\textfonts} -\let\subsecentryfonts = \textfonts -\let\subsubsecentryfonts = \textfonts - - -\message{environments,} - -% Since these characters are used in examples, it should be an even number of -% \tt widths. Each \tt character is 1en, so two makes it 1em. -% Furthermore, these definitions must come after we define our fonts. -\newbox\dblarrowbox \newbox\longdblarrowbox -\newbox\pushcharbox \newbox\bullbox -\newbox\equivbox \newbox\errorbox - -%{\tentt -%\global\setbox\dblarrowbox = \hbox to 1em{\hfil$\Rightarrow$\hfil} -%\global\setbox\longdblarrowbox = \hbox to 1em{\hfil$\mapsto$\hfil} -%\global\setbox\pushcharbox = \hbox to 1em{\hfil$\dashv$\hfil} -%\global\setbox\equivbox = \hbox to 1em{\hfil$\ptexequiv$\hfil} -% Adapted from the manmac format (p.420 of TeXbook) -%\global\setbox\bullbox = \hbox to 1em{\kern.15em\vrule height .75ex width .85ex -% depth .1ex\hfil} -%} - -% @point{}, @result{}, @expansion{}, @print{}, @equiv{}. -\def\point{$\star$} -\def\result{\leavevmode\raise.15ex\hbox to 1em{\hfil$\Rightarrow$\hfil}} -\def\expansion{\leavevmode\raise.1ex\hbox to 1em{\hfil$\mapsto$\hfil}} -\def\print{\leavevmode\lower.1ex\hbox to 1em{\hfil$\dashv$\hfil}} -\def\equiv{\leavevmode\lower.1ex\hbox to 1em{\hfil$\ptexequiv$\hfil}} - -% Adapted from the TeXbook's \boxit. -{\tentt \global\dimen0 = 3em}% Width of the box. -\dimen2 = .55pt % Thickness of rules -% The text. (`r' is open on the right, `e' somewhat less so on the left.) -\setbox0 = \hbox{\kern-.75pt \tensf error\kern-1.5pt} - -\global\setbox\errorbox=\hbox to \dimen0{\hfil - \hsize = \dimen0 \advance\hsize by -5.8pt % Space to left+right. - \advance\hsize by -2\dimen2 % Rules. - \vbox{ - \hrule height\dimen2 - \hbox{\vrule width\dimen2 \kern3pt % Space to left of text. - \vtop{\kern2.4pt \box0 \kern2.4pt}% Space above/below. - \kern3pt\vrule width\dimen2}% Space to right. - \hrule height\dimen2} - \hfil} - -% The @error{} command. -\def\error{\leavevmode\lower.7ex\copy\errorbox} - -% @tex ... @end tex escapes into raw Tex temporarily. -% One exception: @ is still an escape character, so that @end tex works. -% But \@ or @@ will get a plain tex @ character. - -\def\tex{\begingroup - \catcode `\\=0 \catcode `\{=1 \catcode `\}=2 - \catcode `\$=3 \catcode `\&=4 \catcode `\#=6 - \catcode `\^=7 \catcode `\_=8 \catcode `\~=13 \let~=\tie - \catcode `\%=14 - \catcode 43=12 % plus - \catcode`\"=12 - \catcode`\==12 - \catcode`\|=12 - \catcode`\<=12 - \catcode`\>=12 - \escapechar=`\\ - % - \let\b=\ptexb - \let\bullet=\ptexbullet - \let\c=\ptexc - \let\,=\ptexcomma - \let\.=\ptexdot - \let\dots=\ptexdots - \let\equiv=\ptexequiv - \let\!=\ptexexclam - \let\i=\ptexi - \let\{=\ptexlbrace - \let\}=\ptexrbrace - \let\*=\ptexstar - \let\t=\ptext - % - \def\endldots{\mathinner{\ldots\ldots\ldots\ldots}}% - \def\enddots{\relax\ifmmode\endldots\else$\mathsurround=0pt \endldots\,$\fi}% - \def\@{@}% -\let\Etex=\endgroup} - -% Define @lisp ... @endlisp. -% @lisp does a \begingroup so it can rebind things, -% including the definition of @endlisp (which normally is erroneous). - -% Amount to narrow the margins by for @lisp. -\newskip\lispnarrowing \lispnarrowing=0.4in - -% This is the definition that ^^M gets inside @lisp, @example, and other -% such environments. \null is better than a space, since it doesn't -% have any width. -\def\lisppar{\null\endgraf} - -% Make each space character in the input produce a normal interword -% space in the output. Don't allow a line break at this space, as this -% is used only in environments like @example, where each line of input -% should produce a line of output anyway. -% -{\obeyspaces % -\gdef\sepspaces{\obeyspaces\let =\tie}} - -% Define \obeyedspace to be our active space, whatever it is. This is -% for use in \parsearg. -{\sepspaces% -\global\let\obeyedspace= } - -% This space is always present above and below environments. -\newskip\envskipamount \envskipamount = 0pt - -% Make spacing and below environment symmetrical. We use \parskip here -% to help in doing that, since in @example-like environments \parskip -% is reset to zero; thus the \afterenvbreak inserts no space -- but the -% start of the next paragraph will insert \parskip -% -\def\aboveenvbreak{{\advance\envskipamount by \parskip -\endgraf \ifdim\lastskip<\envskipamount -\removelastskip \penalty-50 \vskip\envskipamount \fi}} - -\let\afterenvbreak = \aboveenvbreak - -% \nonarrowing is a flag. If "set", @lisp etc don't narrow margins. -\let\nonarrowing=\relax - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -% \cartouche: draw rectangle w/rounded corners around argument -\font\circle=lcircle10 -\newdimen\circthick -\newdimen\cartouter\newdimen\cartinner -\newskip\normbskip\newskip\normpskip\newskip\normlskip -\circthick=\fontdimen8\circle -% -\def\ctl{{\circle\char'013\hskip -6pt}}% 6pt from pl file: 1/2charwidth -\def\ctr{{\hskip 6pt\circle\char'010}} -\def\cbl{{\circle\char'012\hskip -6pt}} -\def\cbr{{\hskip 6pt\circle\char'011}} -\def\carttop{\hbox to \cartouter{\hskip\lskip - \ctl\leaders\hrule height\circthick\hfil\ctr - \hskip\rskip}} -\def\cartbot{\hbox to \cartouter{\hskip\lskip - \cbl\leaders\hrule height\circthick\hfil\cbr - \hskip\rskip}} -% -\newskip\lskip\newskip\rskip - -\long\def\cartouche{% -\begingroup - \lskip=\leftskip \rskip=\rightskip - \leftskip=0pt\rightskip=0pt %we want these *outside*. - \cartinner=\hsize \advance\cartinner by-\lskip - \advance\cartinner by-\rskip - \cartouter=\hsize - \advance\cartouter by 18pt % allow for 3pt kerns on either -% side, and for 6pt waste from -% each corner char - \normbskip=\baselineskip \normpskip=\parskip \normlskip=\lineskip - % Flag to tell @lisp, etc., not to narrow margin. - \let\nonarrowing=\comment - \vbox\bgroup - \baselineskip=0pt\parskip=0pt\lineskip=0pt - \carttop - \hbox\bgroup - \hskip\lskip - \vrule\kern3pt - \vbox\bgroup - \hsize=\cartinner - \kern3pt - \begingroup - \baselineskip=\normbskip - \lineskip=\normlskip - \parskip=\normpskip - \vskip -\parskip -\def\Ecartouche{% - \endgroup - \kern3pt - \egroup - \kern3pt\vrule - \hskip\rskip - \egroup - \cartbot - \egroup -\endgroup -}} - - -% This macro is called at the beginning of all the @example variants, -% inside a group. -\def\nonfillstart{% - \aboveenvbreak - \inENV % This group ends at the end of the body - \hfuzz = 12pt % Don't be fussy - \sepspaces % Make spaces be word-separators rather than space tokens. - \singlespace - \let\par = \lisppar % don't ignore blank lines - \obeylines % each line of input is a line of output - \parskip = 0pt - \parindent = 0pt - \emergencystretch = 0pt % don't try to avoid overfull boxes - % @cartouche defines \nonarrowing to inhibit narrowing - % at next level down. - \ifx\nonarrowing\relax - \advance \leftskip by \lispnarrowing - \exdentamount=\lispnarrowing - \let\exdent=\nofillexdent - \let\nonarrowing=\relax - \fi -} - -% To ending an @example-like environment, we first end the paragraph -% (via \afterenvbreak's vertical glue), and then the group. That way we -% keep the zero \parskip that the environments set -- \parskip glue -% will be inserted at the beginning of the next paragraph in the -% document, after the environment. -% -\def\nonfillfinish{\afterenvbreak\endgroup}% - -\def\lisp{\begingroup - \nonfillstart - \let\Elisp = \nonfillfinish - \tt - % Make @kbd do something special, if requested. - \let\kbdfont\kbdexamplefont - \rawbackslash % have \ input char produce \ char from current font - \gobble -} - -% Define the \E... control sequence only if we are inside the -% environment, so the error checking in \end will work. -% -% We must call \lisp last in the definition, since it reads the -% return following the @example (or whatever) command. -% -\def\example{\begingroup \def\Eexample{\nonfillfinish\endgroup}\lisp} -\def\smallexample{\begingroup \def\Esmallexample{\nonfillfinish\endgroup}\lisp} -\def\smalllisp{\begingroup \def\Esmalllisp{\nonfillfinish\endgroup}\lisp} - -% @smallexample and @smalllisp. This is not used unless the @smallbook -% command is given. Originally contributed by Pavel@xerox. -% -\def\smalllispx{\begingroup - \nonfillstart - \let\Esmalllisp = \nonfillfinish - \let\Esmallexample = \nonfillfinish - % - % Smaller fonts for small examples. - \indexfonts \tt - \rawbackslash % make \ output the \ character from the current font (tt) - \gobble -} - -% This is @display; same as @lisp except use roman font. -% -\def\display{\begingroup - \nonfillstart - \let\Edisplay = \nonfillfinish - \gobble -} - -% This is @format; same as @display except don't narrow margins. -% -\def\format{\begingroup - \let\nonarrowing = t - \nonfillstart - \let\Eformat = \nonfillfinish - \gobble -} - -% @flushleft (same as @format) and @flushright. -% -\def\flushleft{\begingroup - \let\nonarrowing = t - \nonfillstart - \let\Eflushleft = \nonfillfinish - \gobble -} -\def\flushright{\begingroup - \let\nonarrowing = t - \nonfillstart - \let\Eflushright = \nonfillfinish - \advance\leftskip by 0pt plus 1fill - \gobble} - -% @quotation does normal linebreaking (hence we can't use \nonfillstart) -% and narrows the margins. -% -\def\quotation{% - \begingroup\inENV %This group ends at the end of the @quotation body - {\parskip=0pt \aboveenvbreak}% because \aboveenvbreak inserts \parskip - \singlespace - \parindent=0pt - % We have retained a nonzero parskip for the environment, since we're - % doing normal filling. So to avoid extra space below the environment... - \def\Equotation{\parskip = 0pt \nonfillfinish}% - % - % @cartouche defines \nonarrowing to inhibit narrowing at next level down. - \ifx\nonarrowing\relax - \advance\leftskip by \lispnarrowing - \advance\rightskip by \lispnarrowing - \exdentamount = \lispnarrowing - \let\nonarrowing = \relax - \fi -} - -\message{defuns,} -% Define formatter for defuns -% First, allow user to change definition object font (\df) internally -\def\setdeffont #1 {\csname DEF#1\endcsname} - -\newskip\defbodyindent \defbodyindent=.4in -\newskip\defargsindent \defargsindent=50pt -\newskip\deftypemargin \deftypemargin=12pt -\newskip\deflastargmargin \deflastargmargin=18pt - -\newcount\parencount -% define \functionparens, which makes ( and ) and & do special things. -% \functionparens affects the group it is contained in. -\def\activeparens{% -\catcode`\(=\active \catcode`\)=\active \catcode`\&=\active -\catcode`\[=\active \catcode`\]=\active} - -% Make control sequences which act like normal parenthesis chars. -\let\lparen = ( \let\rparen = ) - -{\activeparens % Now, smart parens don't turn on until &foo (see \amprm) - -% Be sure that we always have a definition for `(', etc. For example, -% if the fn name has parens in it, \boldbrax will not be in effect yet, -% so TeX would otherwise complain about undefined control sequence. -\global\let(=\lparen \global\let)=\rparen -\global\let[=\lbrack \global\let]=\rbrack - -\gdef\functionparens{\boldbrax\let&=\amprm\parencount=0 } -\gdef\boldbrax{\let(=\opnr\let)=\clnr\let[=\lbrb\let]=\rbrb} -% This is used to turn on special parens -% but make & act ordinary (given that it's active). -\gdef\boldbraxnoamp{\let(=\opnr\let)=\clnr\let[=\lbrb\let]=\rbrb\let&=\ampnr} - -% Definitions of (, ) and & used in args for functions. -% This is the definition of ( outside of all parentheses. -\gdef\oprm#1 {{\rm\char`\(}#1 \bf \let(=\opnested - \global\advance\parencount by 1 -} -% -% This is the definition of ( when already inside a level of parens. -\gdef\opnested{\char`\(\global\advance\parencount by 1 } -% -\gdef\clrm{% Print a paren in roman if it is taking us back to depth of 0. - % also in that case restore the outer-level definition of (. - \ifnum \parencount=1 {\rm \char `\)}\sl \let(=\oprm \else \char `\) \fi - \global\advance \parencount by -1 } -% If we encounter &foo, then turn on ()-hacking afterwards -\gdef\amprm#1 {{\rm\}\let(=\oprm \let)=\clrm\ } -% -\gdef\normalparens{\boldbrax\let&=\ampnr} -} % End of definition inside \activeparens -%% These parens (in \boldbrax) actually are a little bolder than the -%% contained text. This is especially needed for [ and ] -\def\opnr{{\sf\char`\(}\global\advance\parencount by 1 } -\def\clnr{{\sf\char`\)}\global\advance\parencount by -1 } -\def\ampnr{\&} -\def\lbrb{{\bf\char`\[}} -\def\rbrb{{\bf\char`\]}} - -% First, defname, which formats the header line itself. -% #1 should be the function name. -% #2 should be the type of definition, such as "Function". - -\def\defname #1#2{% -% Get the values of \leftskip and \rightskip as they were -% outside the @def... -\dimen2=\leftskip -\advance\dimen2 by -\defbodyindent -\dimen3=\rightskip -\advance\dimen3 by -\defbodyindent -\noindent % -\setbox0=\hbox{\hskip \deflastargmargin{\rm #2}\hskip \deftypemargin}% -\dimen0=\hsize \advance \dimen0 by -\wd0 % compute size for first line -\dimen1=\hsize \advance \dimen1 by -\defargsindent %size for continuations -\parshape 2 0in \dimen0 \defargsindent \dimen1 % -% Now output arg 2 ("Function" or some such) -% ending at \deftypemargin from the right margin, -% but stuck inside a box of width 0 so it does not interfere with linebreaking -{% Adjust \hsize to exclude the ambient margins, -% so that \rightline will obey them. -\advance \hsize by -\dimen2 \advance \hsize by -\dimen3 -\rlap{\rightline{{\rm #2}\hskip \deftypemargin}}}% -% Make all lines underfull and no complaints: -\tolerance=10000 \hbadness=10000 -\advance\leftskip by -\defbodyindent -\exdentamount=\defbodyindent -{\df #1}\enskip % Generate function name -} - -% Actually process the body of a definition -% #1 should be the terminating control sequence, such as \Edefun. -% #2 should be the "another name" control sequence, such as \defunx. -% #3 should be the control sequence that actually processes the header, -% such as \defunheader. - -\def\defparsebody #1#2#3{\begingroup\inENV% Environment for definitionbody -\medbreak % -% Define the end token that this defining construct specifies -% so that it will exit this group. -\def#1{\endgraf\endgroup\medbreak}% -\def#2{\begingroup\obeylines\activeparens\spacesplit#3}% -\parindent=0in -\advance\leftskip by \defbodyindent \advance \rightskip by \defbodyindent -\exdentamount=\defbodyindent -\begingroup % -\catcode 61=\active % 61 is `=' -\obeylines\activeparens\spacesplit#3} - -\def\defmethparsebody #1#2#3#4 {\begingroup\inENV % -\medbreak % -% Define the end token that this defining construct specifies -% so that it will exit this group. -\def#1{\endgraf\endgroup\medbreak}% -\def#2##1 {\begingroup\obeylines\activeparens\spacesplit{#3{##1}}}% -\parindent=0in -\advance\leftskip by \defbodyindent \advance \rightskip by \defbodyindent -\exdentamount=\defbodyindent -\begingroup\obeylines\activeparens\spacesplit{#3{#4}}} - -\def\defopparsebody #1#2#3#4#5 {\begingroup\inENV % -\medbreak % -% Define the end token that this defining construct specifies -% so that it will exit this group. -\def#1{\endgraf\endgroup\medbreak}% -\def#2##1 ##2 {\def#4{##1}% -\begingroup\obeylines\activeparens\spacesplit{#3{##2}}}% -\parindent=0in -\advance\leftskip by \defbodyindent \advance \rightskip by \defbodyindent -\exdentamount=\defbodyindent -\begingroup\obeylines\activeparens\spacesplit{#3{#5}}} - -% These parsing functions are similar to the preceding ones -% except that they do not make parens into active characters. -% These are used for "variables" since they have no arguments. - -\def\defvarparsebody #1#2#3{\begingroup\inENV% Environment for definitionbody -\medbreak % -% Define the end token that this defining construct specifies -% so that it will exit this group. -\def#1{\endgraf\endgroup\medbreak}% -\def#2{\begingroup\obeylines\spacesplit#3}% -\parindent=0in -\advance\leftskip by \defbodyindent \advance \rightskip by \defbodyindent -\exdentamount=\defbodyindent -\begingroup % -\catcode 61=\active % -\obeylines\spacesplit#3} - -% This is used for \def{tp,vr}parsebody. It could probably be used for -% some of the others, too, with some judicious conditionals. -% -\def\parsebodycommon#1#2#3{% - \begingroup\inENV % - \medbreak % - % Define the end token that this defining construct specifies - % so that it will exit this group. - \def#1{\endgraf\endgroup\medbreak}% - \def#2##1 {\begingroup\obeylines\spacesplit{#3{##1}}}% - \parindent=0in - \advance\leftskip by \defbodyindent \advance \rightskip by \defbodyindent - \exdentamount=\defbodyindent - \begingroup\obeylines -} - -\def\defvrparsebody#1#2#3#4 {% - \parsebodycommon{#1}{#2}{#3}% - \spacesplit{#3{#4}}% -} - -% This loses on `@deftp {Data Type} {struct termios}' -- it thinks the -% type is just `struct', because we lose the braces in `{struct -% termios}' when \spacesplit reads its undelimited argument. Sigh. -% \let\deftpparsebody=\defvrparsebody -% -% So, to get around this, we put \empty in with the type name. That -% way, TeX won't find exactly `{...}' as an undelimited argument, and -% won't strip off the braces. -% -\def\deftpparsebody #1#2#3#4 {% - \parsebodycommon{#1}{#2}{#3}% - \spacesplit{\parsetpheaderline{#3{#4}}}\empty -} - -% Fine, but then we have to eventually remove the \empty *and* the -% braces (if any). That's what this does. -% -\def\removeemptybraces\empty#1\relax{#1} - -% After \spacesplit has done its work, this is called -- #1 is the final -% thing to call, #2 the type name (which starts with \empty), and #3 -% (which might be empty) the arguments. -% -\def\parsetpheaderline#1#2#3{% - #1{\removeemptybraces#2\relax}{#3}% -}% - -\def\defopvarparsebody #1#2#3#4#5 {\begingroup\inENV % -\medbreak % -% Define the end token that this defining construct specifies -% so that it will exit this group. -\def#1{\endgraf\endgroup\medbreak}% -\def#2##1 ##2 {\def#4{##1}% -\begingroup\obeylines\spacesplit{#3{##2}}}% -\parindent=0in -\advance\leftskip by \defbodyindent \advance \rightskip by \defbodyindent -\exdentamount=\defbodyindent -\begingroup\obeylines\spacesplit{#3{#5}}} - -% Split up #2 at the first space token. -% call #1 with two arguments: -% the first is all of #2 before the space token, -% the second is all of #2 after that space token. -% If #2 contains no space token, all of it is passed as the first arg -% and the second is passed as empty. - -{\obeylines -\gdef\spacesplit#1#2^^M{\endgroup\spacesplitfoo{#1}#2 \relax\spacesplitfoo}% -\long\gdef\spacesplitfoo#1#2 #3#4\spacesplitfoo{% -\ifx\relax #3% -#1{#2}{}\else #1{#2}{#3#4}\fi}} - -% So much for the things common to all kinds of definitions. - -% Define @defun. - -% First, define the processing that is wanted for arguments of \defun -% Use this to expand the args and terminate the paragraph they make up - -\def\defunargs #1{\functionparens \sl -% Expand, preventing hyphenation at `-' chars. -% Note that groups don't affect changes in \hyphenchar. -\hyphenchar\tensl=0 -#1% -\hyphenchar\tensl=45 -\ifnum\parencount=0 \else \errmessage{Unbalanced parentheses in @def}\fi% -\interlinepenalty=10000 -\advance\rightskip by 0pt plus 1fil -\endgraf\penalty 10000\vskip -\parskip\penalty 10000% -} - -\def\deftypefunargs #1{% -% Expand, preventing hyphenation at `-' chars. -% Note that groups don't affect changes in \hyphenchar. -% Use \boldbraxnoamp, not \functionparens, so that & is not special. -\boldbraxnoamp -\tclose{#1}% avoid \code because of side effects on active chars -\interlinepenalty=10000 -\advance\rightskip by 0pt plus 1fil -\endgraf\penalty 10000\vskip -\parskip\penalty 10000% -} - -% Do complete processing of one @defun or @defunx line already parsed. - -% @deffn Command forward-char nchars - -\def\deffn{\defmethparsebody\Edeffn\deffnx\deffnheader} - -\def\deffnheader #1#2#3{\doind {fn}{\code{#2}}% -\begingroup\defname {#2}{#1}\defunargs{#3}\endgroup % -\catcode 61=\other % Turn off change made in \defparsebody -} - -% @defun == @deffn Function - -\def\defun{\defparsebody\Edefun\defunx\defunheader} - -\def\defunheader #1#2{\doind {fn}{\code{#1}}% Make entry in function index -\begingroup\defname {#1}{Function}% -\defunargs {#2}\endgroup % -\catcode 61=\other % Turn off change made in \defparsebody -} - -% @deftypefun int foobar (int @var{foo}, float @var{bar}) - -\def\deftypefun{\defparsebody\Edeftypefun\deftypefunx\deftypefunheader} - -% #1 is the data type. #2 is the name and args. -\def\deftypefunheader #1#2{\deftypefunheaderx{#1}#2 \relax} -% #1 is the data type, #2 the name, #3 the args. -\def\deftypefunheaderx #1#2 #3\relax{% -\doind {fn}{\code{#2}}% Make entry in function index -\begingroup\defname {\defheaderxcond#1\relax$$$#2}{Function}% -\deftypefunargs {#3}\endgroup % -\catcode 61=\other % Turn off change made in \defparsebody -} - -% @deftypefn {Library Function} int foobar (int @var{foo}, float @var{bar}) - -\def\deftypefn{\defmethparsebody\Edeftypefn\deftypefnx\deftypefnheader} - -% \defheaderxcond#1\relax$$$ -% puts #1 in @code, followed by a space, but does nothing if #1 is null. -\def\defheaderxcond#1#2$$${\ifx#1\relax\else\code{#1#2} \fi} - -% #1 is the classification. #2 is the data type. #3 is the name and args. -\def\deftypefnheader #1#2#3{\deftypefnheaderx{#1}{#2}#3 \relax} -% #1 is the classification, #2 the data type, #3 the name, #4 the args. -\def\deftypefnheaderx #1#2#3 #4\relax{% -\doind {fn}{\code{#3}}% Make entry in function index -\begingroup -\normalparens % notably, turn off `&' magic, which prevents -% at least some C++ text from working -\defname {\defheaderxcond#2\relax$$$#3}{#1}% -\deftypefunargs {#4}\endgroup % -\catcode 61=\other % Turn off change made in \defparsebody -} - -% @defmac == @deffn Macro - -\def\defmac{\defparsebody\Edefmac\defmacx\defmacheader} - -\def\defmacheader #1#2{\doind {fn}{\code{#1}}% Make entry in function index -\begingroup\defname {#1}{Macro}% -\defunargs {#2}\endgroup % -\catcode 61=\other % Turn off change made in \defparsebody -} - -% @defspec == @deffn Special Form - -\def\defspec{\defparsebody\Edefspec\defspecx\defspecheader} - -\def\defspecheader #1#2{\doind {fn}{\code{#1}}% Make entry in function index -\begingroup\defname {#1}{Special Form}% -\defunargs {#2}\endgroup % -\catcode 61=\other % Turn off change made in \defparsebody -} - -% This definition is run if you use @defunx -% anywhere other than immediately after a @defun or @defunx. - -\def\deffnx #1 {\errmessage{@deffnx in invalid context}} -\def\defunx #1 {\errmessage{@defunx in invalid context}} -\def\defmacx #1 {\errmessage{@defmacx in invalid context}} -\def\defspecx #1 {\errmessage{@defspecx in invalid context}} -\def\deftypefnx #1 {\errmessage{@deftypefnx in invalid context}} -\def\deftypemethodx #1 {\errmessage{@deftypemethodx in invalid context}} -\def\deftypeunx #1 {\errmessage{@deftypeunx in invalid context}} - -% @defmethod, and so on - -% @defop {Funny Method} foo-class frobnicate argument - -\def\defop #1 {\def\defoptype{#1}% -\defopparsebody\Edefop\defopx\defopheader\defoptype} - -\def\defopheader #1#2#3{% -\dosubind {fn}{\code{#2}}{on #1}% Make entry in function index -\begingroup\defname {#2}{\defoptype{} on #1}% -\defunargs {#3}\endgroup % -} - -% @deftypemethod foo-class return-type foo-method args -% -\def\deftypemethod{% - \defmethparsebody\Edeftypemethod\deftypemethodx\deftypemethodheader} -% -% #1 is the class name, #2 the data type, #3 the method name, #4 the args. -\def\deftypemethodheader#1#2#3#4{% - \deftypefnheaderx{Method on #1}{#2}#3 #4\relax -} - -% @defmethod == @defop Method - -\def\defmethod{\defmethparsebody\Edefmethod\defmethodx\defmethodheader} - -\def\defmethodheader #1#2#3{% -\dosubind {fn}{\code{#2}}{on #1}% entry in function index -\begingroup\defname {#2}{Method on #1}% -\defunargs {#3}\endgroup % -} - -% @defcv {Class Option} foo-class foo-flag - -\def\defcv #1 {\def\defcvtype{#1}% -\defopvarparsebody\Edefcv\defcvx\defcvarheader\defcvtype} - -\def\defcvarheader #1#2#3{% -\dosubind {vr}{\code{#2}}{of #1}% Make entry in var index -\begingroup\defname {#2}{\defcvtype{} of #1}% -\defvarargs {#3}\endgroup % -} - -% @defivar == @defcv {Instance Variable} - -\def\defivar{\defvrparsebody\Edefivar\defivarx\defivarheader} - -\def\defivarheader #1#2#3{% -\dosubind {vr}{\code{#2}}{of #1}% Make entry in var index -\begingroup\defname {#2}{Instance Variable of #1}% -\defvarargs {#3}\endgroup % -} - -% These definitions are run if you use @defmethodx, etc., -% anywhere other than immediately after a @defmethod, etc. - -\def\defopx #1 {\errmessage{@defopx in invalid context}} -\def\defmethodx #1 {\errmessage{@defmethodx in invalid context}} -\def\defcvx #1 {\errmessage{@defcvx in invalid context}} -\def\defivarx #1 {\errmessage{@defivarx in invalid context}} - -% Now @defvar - -% First, define the processing that is wanted for arguments of @defvar. -% This is actually simple: just print them in roman. -% This must expand the args and terminate the paragraph they make up -\def\defvarargs #1{\normalparens #1% -\interlinepenalty=10000 -\endgraf\penalty 10000\vskip -\parskip\penalty 10000} - -% @defvr Counter foo-count - -\def\defvr{\defvrparsebody\Edefvr\defvrx\defvrheader} - -\def\defvrheader #1#2#3{\doind {vr}{\code{#2}}% -\begingroup\defname {#2}{#1}\defvarargs{#3}\endgroup} - -% @defvar == @defvr Variable - -\def\defvar{\defvarparsebody\Edefvar\defvarx\defvarheader} - -\def\defvarheader #1#2{\doind {vr}{\code{#1}}% Make entry in var index -\begingroup\defname {#1}{Variable}% -\defvarargs {#2}\endgroup % -} - -% @defopt == @defvr {User Option} - -\def\defopt{\defvarparsebody\Edefopt\defoptx\defoptheader} - -\def\defoptheader #1#2{\doind {vr}{\code{#1}}% Make entry in var index -\begingroup\defname {#1}{User Option}% -\defvarargs {#2}\endgroup % -} - -% @deftypevar int foobar - -\def\deftypevar{\defvarparsebody\Edeftypevar\deftypevarx\deftypevarheader} - -% #1 is the data type. #2 is the name, perhaps followed by text that -% is actually part of the data type, which should not be put into the index. -\def\deftypevarheader #1#2{% -\dovarind#2 \relax% Make entry in variables index -\begingroup\defname {\defheaderxcond#1\relax$$$#2}{Variable}% -\interlinepenalty=10000 -\endgraf\penalty 10000\vskip -\parskip\penalty 10000 -\endgroup} -\def\dovarind#1 #2\relax{\doind{vr}{\code{#1}}} - -% @deftypevr {Global Flag} int enable - -\def\deftypevr{\defvrparsebody\Edeftypevr\deftypevrx\deftypevrheader} - -\def\deftypevrheader #1#2#3{\dovarind#3 \relax% -\begingroup\defname {\defheaderxcond#2\relax$$$#3}{#1} -\interlinepenalty=10000 -\endgraf\penalty 10000\vskip -\parskip\penalty 10000 -\endgroup} - -% This definition is run if you use @defvarx -% anywhere other than immediately after a @defvar or @defvarx. - -\def\defvrx #1 {\errmessage{@defvrx in invalid context}} -\def\defvarx #1 {\errmessage{@defvarx in invalid context}} -\def\defoptx #1 {\errmessage{@defoptx in invalid context}} -\def\deftypevarx #1 {\errmessage{@deftypevarx in invalid context}} -\def\deftypevrx #1 {\errmessage{@deftypevrx in invalid context}} - -% Now define @deftp -% Args are printed in bold, a slight difference from @defvar. - -\def\deftpargs #1{\bf \defvarargs{#1}} - -% @deftp Class window height width ... - -\def\deftp{\deftpparsebody\Edeftp\deftpx\deftpheader} - -\def\deftpheader #1#2#3{\doind {tp}{\code{#2}}% -\begingroup\defname {#2}{#1}\deftpargs{#3}\endgroup} - -% This definition is run if you use @deftpx, etc -% anywhere other than immediately after a @deftp, etc. - -\def\deftpx #1 {\errmessage{@deftpx in invalid context}} - - -\message{cross reference,} -% Define cross-reference macros -\newwrite \auxfile - -\newif\ifhavexrefs % True if xref values are known. -\newif\ifwarnedxrefs % True if we warned once that they aren't known. - -% @inforef is simple. -\def\inforef #1{\inforefzzz #1,,,,**} -\def\inforefzzz #1,#2,#3,#4**{\putwordSee{} \putwordInfo{} \putwordfile{} \file{\ignorespaces #3{}}, - node \samp{\ignorespaces#1{}}} - -% \setref{foo} defines a cross-reference point named foo. - -\def\setref#1{% -\dosetq{#1-title}{Ytitle}% -\dosetq{#1-pg}{Ypagenumber}% -\dosetq{#1-snt}{Ysectionnumberandtype}} - -\def\unnumbsetref#1{% -\dosetq{#1-title}{Ytitle}% -\dosetq{#1-pg}{Ypagenumber}% -\dosetq{#1-snt}{Ynothing}} - -\def\appendixsetref#1{% -\dosetq{#1-title}{Ytitle}% -\dosetq{#1-pg}{Ypagenumber}% -\dosetq{#1-snt}{Yappendixletterandtype}} - -% \xref, \pxref, and \ref generate cross-references to specified points. -% For \xrefX, #1 is the node name, #2 the name of the Info -% cross-reference, #3 the printed node name, #4 the name of the Info -% file, #5 the name of the printed manual. All but the node name can be -% omitted. -% -\def\pxref#1{\putwordsee{} \xrefX[#1,,,,,,,]} -\def\xref#1{\putwordSee{} \xrefX[#1,,,,,,,]} -\def\ref#1{\xrefX[#1,,,,,,,]} -\def\xrefX[#1,#2,#3,#4,#5,#6]{\begingroup - \def\printedmanual{\ignorespaces #5}% - \def\printednodename{\ignorespaces #3}% - \setbox1=\hbox{\printedmanual}% - \setbox0=\hbox{\printednodename}% - \ifdim \wd0 = 0pt - % No printed node name was explicitly given. - \expandafter\ifx\csname SETxref-automatic-section-title\endcsname\relax - % Use the node name inside the square brackets. - \def\printednodename{\ignorespaces #1}% - \else - % Use the actual chapter/section title appear inside - % the square brackets. Use the real section title if we have it. - \ifdim \wd1>0pt% - % It is in another manual, so we don't have it. - \def\printednodename{\ignorespaces #1}% - \else - \ifhavexrefs - % We know the real title if we have the xref values. - \def\printednodename{\refx{#1-title}{}}% - \else - % Otherwise just copy the Info node name. - \def\printednodename{\ignorespaces #1}% - \fi% - \fi - \fi - \fi - % - % If we use \unhbox0 and \unhbox1 to print the node names, TeX does not - % insert empty discretionaries after hyphens, which means that it will - % not find a line break at a hyphen in a node names. Since some manuals - % are best written with fairly long node names, containing hyphens, this - % is a loss. Therefore, we give the text of the node name again, so it - % is as if TeX is seeing it for the first time. - \ifdim \wd1 > 0pt - \putwordsection{} ``\printednodename'' in \cite{\printedmanual}% - \else - % _ (for example) has to be the character _ for the purposes of the - % control sequence corresponding to the node, but it has to expand - % into the usual \leavevmode...\vrule stuff for purposes of - % printing. So we \turnoffactive for the \refx-snt, back on for the - % printing, back off for the \refx-pg. - {\turnoffactive \refx{#1-snt}{}}% - \space [\printednodename],\space - \turnoffactive \putwordpage\tie\refx{#1-pg}{}% - \fi -\endgroup} - -% \dosetq is the interface for calls from other macros - -% Use \turnoffactive so that punctuation chars such as underscore -% work in node names. -\def\dosetq #1#2{{\let\folio=0 \turnoffactive -\edef\next{\write\auxfile{\internalsetq {#1}{#2}}}% -\next}} - -% \internalsetq {foo}{page} expands into -% CHARACTERS 'xrdef {foo}{...expansion of \Ypage...} -% When the aux file is read, ' is the escape character - -\def\internalsetq #1#2{'xrdef {#1}{\csname #2\endcsname}} - -% Things to be expanded by \internalsetq - -\def\Ypagenumber{\folio} - -\def\Ytitle{\thissection} - -\def\Ynothing{} - -\def\Ysectionnumberandtype{% -\ifnum\secno=0 \putwordChapter\xreftie\the\chapno % -\else \ifnum \subsecno=0 \putwordSection\xreftie\the\chapno.\the\secno % -\else \ifnum \subsubsecno=0 % -\putwordSection\xreftie\the\chapno.\the\secno.\the\subsecno % -\else % -\putwordSection\xreftie\the\chapno.\the\secno.\the\subsecno.\the\subsubsecno % -\fi \fi \fi } - -\def\Yappendixletterandtype{% -\ifnum\secno=0 \putwordAppendix\xreftie'char\the\appendixno{}% -\else \ifnum \subsecno=0 \putwordSection\xreftie'char\the\appendixno.\the\secno % -\else \ifnum \subsubsecno=0 % -\putwordSection\xreftie'char\the\appendixno.\the\secno.\the\subsecno % -\else % -\putwordSection\xreftie'char\the\appendixno.\the\secno.\the\subsecno.\the\subsubsecno % -\fi \fi \fi } - -\gdef\xreftie{'tie} - -% Use TeX 3.0's \inputlineno to get the line number, for better error -% messages, but if we're using an old version of TeX, don't do anything. -% -\ifx\inputlineno\thisisundefined - \let\linenumber = \empty % Non-3.0. -\else - \def\linenumber{\the\inputlineno:\space} -\fi - -% Define \refx{NAME}{SUFFIX} to reference a cross-reference string named NAME. -% If its value is nonempty, SUFFIX is output afterward. - -\def\refx#1#2{% - \expandafter\ifx\csname X#1\endcsname\relax - % If not defined, say something at least. - \angleleft un\-de\-fined\angleright - \ifhavexrefs - \message{\linenumber Undefined cross reference `#1'.}% - \else - \ifwarnedxrefs\else - \global\warnedxrefstrue - \message{Cross reference values unknown; you must run TeX again.}% - \fi - \fi - \else - % It's defined, so just use it. - \csname X#1\endcsname - \fi - #2% Output the suffix in any case. -} - -% This is the macro invoked by entries in the aux file. -% -\def\xrdef#1{\begingroup - % Reenable \ as an escape while reading the second argument. - \catcode`\\ = 0 - \afterassignment\endgroup - \expandafter\gdef\csname X#1\endcsname -} - -% Read the last existing aux file, if any. No error if none exists. -\def\readauxfile{\begingroup - \catcode`\^^@=\other - \catcode`\^^A=\other - \catcode`\^^B=\other - \catcode`\^^C=\other - \catcode`\^^D=\other - \catcode`\^^E=\other - \catcode`\^^F=\other - \catcode`\^^G=\other - \catcode`\^^H=\other - \catcode`\^^K=\other - \catcode`\^^L=\other - \catcode`\^^N=\other - \catcode`\^^P=\other - \catcode`\^^Q=\other - \catcode`\^^R=\other - \catcode`\^^S=\other - \catcode`\^^T=\other - \catcode`\^^U=\other - \catcode`\^^V=\other - \catcode`\^^W=\other - \catcode`\^^X=\other - \catcode`\^^Z=\other - \catcode`\^^[=\other - \catcode`\^^\=\other - \catcode`\^^]=\other - \catcode`\^^^=\other - \catcode`\^^_=\other - \catcode`\@=\other - \catcode`\^=\other - % It was suggested to define this as 7, which would allow ^^e4 etc. - % in xref tags, i.e., node names. But since ^^e4 notation isn't - % supported in the main text, it doesn't seem desirable. Furthermore, - % that is not enough: for node names that actually contain a ^ - % character, we would end up writing a line like this: 'xrdef {'hat - % b-title}{'hat b} and \xrdef does a \csname...\endcsname on the first - % argument, and \hat is not an expandable control sequence. It could - % all be worked out, but why? Either we support ^^ or we don't. - % - % The other change necessary for this was to define \auxhat: - % \def\auxhat{\def^{'hat }}% extra space so ok if followed by letter - % and then to call \auxhat in \setq. - % - \catcode`\~=\other - \catcode`\[=\other - \catcode`\]=\other - \catcode`\"=\other - \catcode`\_=\other - \catcode`\|=\other - \catcode`\<=\other - \catcode`\>=\other - \catcode`\$=\other - \catcode`\#=\other - \catcode`\&=\other - % `\+ does not work, so use 43. - \catcode43=\other - % Make the characters 128-255 be printing characters - {% - \count 1=128 - \def\loop{% - \catcode\count 1=\other - \advance\count 1 by 1 - \ifnum \count 1<256 \loop \fi - }% - }% - % The aux file uses ' as the escape (for now). - % Turn off \ as an escape so we do not lose on - % entries which were dumped with control sequences in their names. - % For example, 'xrdef {$\leq $-fun}{page ...} made by @defun ^^ - % Reference to such entries still does not work the way one would wish, - % but at least they do not bomb out when the aux file is read in. - \catcode`\{=1 - \catcode`\}=2 - \catcode`\%=\other - \catcode`\'=0 - \catcode`\\=\other - % - \openin 1 \jobname.aux - \ifeof 1 \else - \closein 1 - \input \jobname.aux - \global\havexrefstrue - \global\warnedobstrue - \fi - % Open the new aux file. TeX will close it automatically at exit. - \openout\auxfile=\jobname.aux -\endgroup} - - -% Footnotes. - -\newcount \footnoteno - -% The trailing space in the following definition for supereject is -% vital for proper filling; pages come out unaligned when you do a -% pagealignmacro call if that space before the closing brace is -% removed. (Generally, numeric constants should always be followed by a -% space to prevent strange expansion errors.) -\def\supereject{\par\penalty -20000\footnoteno =0 } - -% @footnotestyle is meaningful for info output only. -\let\footnotestyle=\comment - -\let\ptexfootnote=\footnote - -{\catcode `\@=11 -% -% Auto-number footnotes. Otherwise like plain. -\gdef\footnote{% - \global\advance\footnoteno by \@ne - \edef\thisfootno{$^{\the\footnoteno}$}% - % - % In case the footnote comes at the end of a sentence, preserve the - % extra spacing after we do the footnote number. - \let\@sf\empty - \ifhmode\edef\@sf{\spacefactor\the\spacefactor}\/\fi - % - % Remove inadvertent blank space before typesetting the footnote number. - \unskip - \thisfootno\@sf - \footnotezzz -}% - -% Don't bother with the trickery in plain.tex to not require the -% footnote text as a parameter. Our footnotes don't need to be so general. -% -% Oh yes, they do; otherwise, @ifset and anything else that uses -% \parseargline fail inside footnotes because the tokens are fixed when -% the footnote is read. --karl, 16nov96. -% -\long\gdef\footnotezzz{\insert\footins\bgroup - % We want to typeset this text as a normal paragraph, even if the - % footnote reference occurs in (for example) a display environment. - % So reset some parameters. - \interlinepenalty\interfootnotelinepenalty - \splittopskip\ht\strutbox % top baseline for broken footnotes - \splitmaxdepth\dp\strutbox - \floatingpenalty\@MM - \leftskip\z@skip - \rightskip\z@skip - \spaceskip\z@skip - \xspaceskip\z@skip - \parindent\defaultparindent - % - % Hang the footnote text off the number. - \hang - \textindent{\thisfootno}% - % - % Don't crash into the line above the footnote text. Since this - % expands into a box, it must come within the paragraph, lest it - % provide a place where TeX can split the footnote. - \footstrut - \futurelet\next\fo@t -} -\def\fo@t{\ifcat\bgroup\noexpand\next \let\next\f@@t - \else\let\next\f@t\fi \next} -\def\f@@t{\bgroup\aftergroup\@foot\let\next} -\def\f@t#1{#1\@foot} -\def\@foot{\strut\egroup} - -}%end \catcode `\@=11 - -% Set the baselineskip to #1, and the lineskip and strut size -% correspondingly. There is no deep meaning behind these magic numbers -% used as factors; they just match (closely enough) what Knuth defined. -% -\def\lineskipfactor{.08333} -\def\strutheightpercent{.70833} -\def\strutdepthpercent {.29167} -% -\def\setleading#1{% - \normalbaselineskip = #1\relax - \normallineskip = \lineskipfactor\normalbaselineskip - \normalbaselines - \setbox\strutbox =\hbox{% - \vrule width0pt height\strutheightpercent\baselineskip - depth \strutdepthpercent \baselineskip - }% -} - -% @| inserts a changebar to the left of the current line. It should -% surround any changed text. This approach does *not* work if the -% change spans more than two lines of output. To handle that, we would -% have adopt a much more difficult approach (putting marks into the main -% vertical list for the beginning and end of each change). -% -\def\|{% - % \vadjust can only be used in horizontal mode. - \leavevmode - % - % Append this vertical mode material after the current line in the output. - \vadjust{% - % We want to insert a rule with the height and depth of the current - % leading; that is exactly what \strutbox is supposed to record. - \vskip-\baselineskip - % - % \vadjust-items are inserted at the left edge of the type. So - % the \llap here moves out into the left-hand margin. - \llap{% - % - % For a thicker or thinner bar, change the `1pt'. - \vrule height\baselineskip width1pt - % - % This is the space between the bar and the text. - \hskip 12pt - }% - }% -} - -% For a final copy, take out the rectangles -% that mark overfull boxes (in case you have decided -% that the text looks ok even though it passes the margin). -% -\def\finalout{\overfullrule=0pt} - -% @image. We use the macros from epsf.tex to support this. -% If epsf.tex is not installed and @image is used, we complain. -% -% Check for and read epsf.tex up front. If we read it only at @image -% time, we might be inside a group, and then its definitions would get -% undone and the next image would fail. -\openin 1 = epsf.tex -\ifeof 1 \else - \closein 1 - \def\epsfannounce{\toks0 = }% do not bother showing banner - \input epsf.tex -\fi -% -\newif\ifwarnednoepsf -\newhelp\noepsfhelp{epsf.tex must be installed for images to - work. It is also included in the Texinfo distribution, or you can get - it from ftp://ftp.tug.org/tex/epsf.tex.} -% -% Only complain once about lack of epsf.tex. -\def\image#1{% - \ifx\epsfbox\undefined - \ifwarnednoepsf \else - \errhelp = \noepsfhelp - \errmessage{epsf.tex not found, images will be ignored}% - \global\warnednoepsftrue - \fi - \else - \imagexxx #1,,,\finish - \fi -} -% -% Arguments to @image: -% #1 is (mandatory) image filename; we tack on .eps extension. -% #2 is (optional) width, #3 is (optional) height. -% #4 is just the usual extra ignored arg for parsing this stuff. -\def\imagexxx#1,#2,#3,#4\finish{% - % \epsfbox itself resets \epsf?size at each figure. - \setbox0 = \hbox{\ignorespaces #2}\ifdim\wd0 > 0pt \epsfxsize=#2\relax \fi - \setbox0 = \hbox{\ignorespaces #3}\ifdim\wd0 > 0pt \epsfysize=#3\relax \fi - \epsfbox{#1.eps}% -} - -% End of control word definitions. - - -\message{and turning on texinfo input format.} - -\def\openindices{% - \newindex{cp}% - \newcodeindex{fn}% - \newcodeindex{vr}% - \newcodeindex{tp}% - \newcodeindex{ky}% - \newcodeindex{pg}% -} - -% Set some numeric style parameters, for 8.5 x 11 format. - -\hsize = 6in -\hoffset = .25in -\newdimen\defaultparindent \defaultparindent = 15pt -\parindent = \defaultparindent -\parskip 3pt plus 2pt minus 1pt -\setleading{13.2pt} -\advance\topskip by 1.2cm - -\chapheadingskip = 15pt plus 4pt minus 2pt -\secheadingskip = 12pt plus 3pt minus 2pt -\subsecheadingskip = 9pt plus 2pt minus 2pt - -% Prevent underfull vbox error messages. -\vbadness=10000 - -% Following George Bush, just get rid of widows and orphans. -\widowpenalty=10000 -\clubpenalty=10000 - -% Use TeX 3.0's \emergencystretch to help line breaking, but if we're -% using an old version of TeX, don't do anything. We want the amount of -% stretch added to depend on the line length, hence the dependence on -% \hsize. This makes it come to about 9pt for the 8.5x11 format. -% -\ifx\emergencystretch\thisisundefined - % Allow us to assign to \emergencystretch anyway. - \def\emergencystretch{\dimen0}% -\else - \emergencystretch = \hsize - \divide\emergencystretch by 45 -\fi - -% Use @smallbook to reset parameters for 7x9.5 format (or else 7x9.25) -\def\smallbook{ - \global\chapheadingskip = 15pt plus 4pt minus 2pt - \global\secheadingskip = 12pt plus 3pt minus 2pt - \global\subsecheadingskip = 9pt plus 2pt minus 2pt - % - \global\lispnarrowing = 0.3in - \setleading{12pt} - \advance\topskip by -1cm - \global\parskip 2pt plus 1pt - \global\hsize = 5in - \global\vsize=7.5in - \global\tolerance=700 - \global\hfuzz=1pt - \global\contentsrightmargin=0pt - \global\deftypemargin=0pt - \global\defbodyindent=.5cm - % - \global\pagewidth=\hsize - \global\pageheight=\vsize - % - \global\let\smalllisp=\smalllispx - \global\let\smallexample=\smalllispx - \global\def\Esmallexample{\Esmalllisp} -} - -% Use @afourpaper to print on European A4 paper. -\def\afourpaper{ -\global\tolerance=700 -\global\hfuzz=1pt -\setleading{12pt} -\global\parskip 15pt plus 1pt - -\global\vsize= 53\baselineskip -\advance\vsize by \topskip -%\global\hsize= 5.85in % A4 wide 10pt -\global\hsize= 6.5in -\global\outerhsize=\hsize -\global\advance\outerhsize by 0.5in -\global\outervsize=\vsize -\global\advance\outervsize by 0.6in - -\global\pagewidth=\hsize -\global\pageheight=\vsize -} - -\bindingoffset=0pt -\normaloffset=\hoffset -\pagewidth=\hsize -\pageheight=\vsize - -% Allow control of the text dimensions. Parameters in order: textheight; -% textwidth; voffset; hoffset; binding offset; topskip. -% All require a dimension; -% header is additional; added length extends the bottom of the page. - -\def\changepagesizes#1#2#3#4#5#6{ - \global\vsize= #1 - \global\topskip= #6 - \advance\vsize by \topskip - \global\voffset= #3 - \global\hsize= #2 - \global\outerhsize=\hsize - \global\advance\outerhsize by 0.5in - \global\outervsize=\vsize - \global\advance\outervsize by 0.6in - \global\pagewidth=\hsize - \global\pageheight=\vsize - \global\normaloffset= #4 - \global\bindingoffset= #5} - -% A specific text layout, 24x15cm overall, intended for A4 paper. Top margin -% 29mm, hence bottom margin 28mm, nominal side margin 3cm. -\def\afourlatex - {\global\tolerance=700 - \global\hfuzz=1pt - \setleading{12pt} - \global\parskip 15pt plus 1pt - \advance\baselineskip by 1.6pt - \changepagesizes{237mm}{150mm}{3.6mm}{3.6mm}{3mm}{7mm} - } - -% Use @afourwide to print on European A4 paper in wide format. -\def\afourwide{\afourpaper -\changepagesizes{9.5in}{6.5in}{\hoffset}{\normaloffset}{\bindingoffset}{7mm}} - -% Define macros to output various characters with catcode for normal text. -\catcode`\"=\other -\catcode`\~=\other -\catcode`\^=\other -\catcode`\_=\other -\catcode`\|=\other -\catcode`\<=\other -\catcode`\>=\other -\catcode`\+=\other -\def\normaldoublequote{"} -\def\normaltilde{~} -\def\normalcaret{^} -\def\normalunderscore{_} -\def\normalverticalbar{|} -\def\normalless{<} -\def\normalgreater{>} -\def\normalplus{+} - -% This macro is used to make a character print one way in ttfont -% where it can probably just be output, and another way in other fonts, -% where something hairier probably needs to be done. -% -% #1 is what to print if we are indeed using \tt; #2 is what to print -% otherwise. Since all the Computer Modern typewriter fonts have zero -% interword stretch (and shrink), and it is reasonable to expect all -% typewriter fonts to have this, we can check that font parameter. -% -\def\ifusingtt#1#2{\ifdim \fontdimen3\the\font=0pt #1\else #2\fi} - -% Turn off all special characters except @ -% (and those which the user can use as if they were ordinary). -% Most of these we simply print from the \tt font, but for some, we can -% use math or other variants that look better in normal text. - -\catcode`\"=\active -\def\activedoublequote{{\tt \char '042}} -\let"=\activedoublequote -\catcode`\~=\active -\def~{{\tt \char '176}} -\chardef\hat=`\^ -\catcode`\^=\active -\def^{{\tt \hat}} - -\catcode`\_=\active -\def_{\ifusingtt\normalunderscore\_} -% Subroutine for the previous macro. -\def\_{\leavevmode \kern.06em \vbox{\hrule width.3em height.1ex}} - -\catcode`\|=\active -\def|{{\tt \char '174}} -\chardef \less=`\< -\catcode`\<=\active -\def<{{\tt \less}} -\chardef \gtr=`\> -\catcode`\>=\active -\def>{{\tt \gtr}} -\catcode`\+=\active -\def+{{\tt \char 43}} -%\catcode 27=\active -%\def^^[{$\diamondsuit$} - -% Set up an active definition for =, but don't enable it most of the time. -{\catcode`\==\active -\global\def={{\tt \char 61}}} - -\catcode`+=\active -\catcode`\_=\active - -% If a .fmt file is being used, characters that might appear in a file -% name cannot be active until we have parsed the command line. -% So turn them off again, and have \everyjob (or @setfilename) turn them on. -% \otherifyactive is called near the end of this file. -\def\otherifyactive{\catcode`+=\other \catcode`\_=\other} - -\catcode`\@=0 - -% \rawbackslashxx output one backslash character in current font -\global\chardef\rawbackslashxx=`\\ -%{\catcode`\\=\other -%@gdef@rawbackslashxx{\}} - -% \rawbackslash redefines \ as input to do \rawbackslashxx. -{\catcode`\\=\active -@gdef@rawbackslash{@let\=@rawbackslashxx }} - -% \normalbackslash outputs one backslash in fixed width font. -\def\normalbackslash{{\tt\rawbackslashxx}} - -% Say @foo, not \foo, in error messages. -\escapechar=`\@ - -% \catcode 17=0 % Define control-q -\catcode`\\=\active - -% Used sometimes to turn off (effectively) the active characters -% even after parsing them. -@def@turnoffactive{@let"=@normaldoublequote -@let\=@realbackslash -@let~=@normaltilde -@let^=@normalcaret -@let_=@normalunderscore -@let|=@normalverticalbar -@let<=@normalless -@let>=@normalgreater -@let+=@normalplus} - -@def@normalturnoffactive{@let"=@normaldoublequote -@let\=@normalbackslash -@let~=@normaltilde -@let^=@normalcaret -@let_=@normalunderscore -@let|=@normalverticalbar -@let<=@normalless -@let>=@normalgreater -@let+=@normalplus} - -% Make _ and + \other characters, temporarily. -% This is canceled by @fixbackslash. -@otherifyactive - -% If a .fmt file is being used, we don't want the `\input texinfo' to show up. -% That is what \eatinput is for; after that, the `\' should revert to printing -% a backslash. -% -@gdef@eatinput input texinfo{@fixbackslash} -@global@let\ = @eatinput - -% On the other hand, perhaps the file did not have a `\input texinfo'. Then -% the first `\{ in the file would cause an error. This macro tries to fix -% that, assuming it is called before the first `\' could plausibly occur. -% Also back turn on active characters that might appear in the input -% file name, in case not using a pre-dumped format. -% -@gdef@fixbackslash{@ifx\@eatinput @let\ = @normalbackslash @fi - @catcode`+=@active @catcode`@_=@active} - -%% These look ok in all fonts, so just make them not special. The @rm below -%% makes sure that the current font starts out as the newly loaded cmr10 -@catcode`@$=@other @catcode`@%=@other @catcode`@&=@other @catcode`@#=@other - -@textfonts -@rm - -@c Local variables: -@c page-delimiter: "^\\\\message" -@c End: From 38a93523eb67cdf5428c27a597a0321210a6b970 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 9 Mar 2001 08:22:00 +0000 Subject: [PATCH 0673/2047] Move doc files into guile-core distribution (1) --- doc/appendices.texi | 279 +++ doc/data-rep.texi | 1818 ++++++++++++++ doc/deprecated.texi | 8 + doc/env.texi | 1165 +++++++++ doc/expect.texi | 141 ++ doc/extend.texi | 23 + doc/gh.texi | 815 ++++++ doc/goops-tutorial.texi | 809 ++++++ doc/goops.texi | 2798 +++++++++++++++++++++ doc/guile.texi | 368 +++ doc/hierarchy.eps | 0 doc/hierarchy.txt | 0 doc/indices.texi | 31 + doc/intro.texi | 579 +++++ doc/mbapi.texi | 987 ++++++++ doc/mltext.texi | 146 ++ doc/posix.texi | 2247 +++++++++++++++++ doc/preface.texi | 131 + doc/r4rs.texi | 0 doc/r5rs.texi | 0 doc/scheme-binding.texi | 37 + doc/scheme-control.texi | 236 ++ doc/scheme-data.texi | 4718 +++++++++++++++++++++++++++++++++++ doc/scheme-debug.texi | 196 ++ doc/scheme-evaluation.texi | 255 ++ doc/scheme-ideas.texi | 1458 +++++++++++ doc/scheme-indices.texi | 17 + doc/scheme-intro.texi | 0 doc/scheme-io.texi | 762 ++++++ doc/scheme-memory.texi | 244 ++ doc/scheme-modules.texi | 675 +++++ doc/scheme-options.texi | 337 +++ doc/scheme-procedures.texi | 206 ++ doc/scheme-reading.texi | 27 + doc/scheme-scheduling.texi | 381 +++ doc/scheme-translation.texi | 49 + doc/scheme-utility.texi | 219 ++ doc/scm.texi | 453 ++++ doc/scripts.texi | 202 ++ doc/scsh.texi | 0 doc/slib.texi | 0 doc/tcltk.texi | 0 doc/texinfo.tex | 0 43 files changed, 22817 insertions(+) create mode 100644 doc/appendices.texi create mode 100644 doc/data-rep.texi create mode 100644 doc/deprecated.texi create mode 100644 doc/env.texi create mode 100644 doc/expect.texi create mode 100644 doc/extend.texi create mode 100644 doc/gh.texi create mode 100644 doc/goops-tutorial.texi create mode 100644 doc/goops.texi create mode 100644 doc/guile.texi create mode 100644 doc/hierarchy.eps create mode 100644 doc/hierarchy.txt create mode 100644 doc/indices.texi create mode 100644 doc/intro.texi create mode 100644 doc/mbapi.texi create mode 100644 doc/mltext.texi create mode 100644 doc/posix.texi create mode 100644 doc/preface.texi create mode 100644 doc/r4rs.texi create mode 100644 doc/r5rs.texi create mode 100644 doc/scheme-binding.texi create mode 100644 doc/scheme-control.texi create mode 100755 doc/scheme-data.texi create mode 100644 doc/scheme-debug.texi create mode 100644 doc/scheme-evaluation.texi create mode 100644 doc/scheme-ideas.texi create mode 100644 doc/scheme-indices.texi create mode 100644 doc/scheme-intro.texi create mode 100644 doc/scheme-io.texi create mode 100644 doc/scheme-memory.texi create mode 100644 doc/scheme-modules.texi create mode 100644 doc/scheme-options.texi create mode 100644 doc/scheme-procedures.texi create mode 100644 doc/scheme-reading.texi create mode 100644 doc/scheme-scheduling.texi create mode 100644 doc/scheme-translation.texi create mode 100644 doc/scheme-utility.texi create mode 100644 doc/scm.texi create mode 100644 doc/scripts.texi create mode 100644 doc/scsh.texi create mode 100644 doc/slib.texi create mode 100644 doc/tcltk.texi create mode 100644 doc/texinfo.tex diff --git a/doc/appendices.texi b/doc/appendices.texi new file mode 100644 index 000000000..058a69b86 --- /dev/null +++ b/doc/appendices.texi @@ -0,0 +1,279 @@ +@node Obtaining and Installing Guile +@appendix Obtaining and Installing Guile + +Here is the information you will need to get and install Guile and extra +packages and documentation you might need or find interesting. + +@menu +* The Basic Guile Package:: +* Packages not shipped with Guile:: +@end menu + +@node The Basic Guile Package +@section The Basic Guile Package + +Guile can be obtained from the main GNU archive site +@url{ftp://prep.ai.mit.edu/pub/gnu} or any of its mirrors. The file +will be named guile-version.tar.gz. The current version is +@value{VERSION}, so the file you should grab is: + +@url{ftp://prep.ai.mit.edu/pub/gnu/guile-@value{VERSION}.tar.gz} + +To unbundle Guile use the instruction +@example +zcat guile-@value{VERSION}.tar.gz | tar xvf - +@end example +which will create a directory called @file{guile-@value{VERSION}} with +all the sources. You can look at the file @file{INSTALL} for detailed +instructions on how to build and install Guile, but you should be able +to just do +@example +cd guile-@value{VERSION} +./configure +make install +@end example + +This will install the Guile executable @file{guile}, the Guile library +@file{libguile.a} and various associated header files and support +libraries. It will also install the Guile tutorial and reference manual. + +@c [[include instructions for getting R4RS]] + +Since this manual frequently refers to the Scheme ``standard'', also +known as R4RS, or the +@iftex +``Revised$^4$ Report on the Algorithmic Language Scheme'', +@end iftex +@ifinfo +``Revised^4 Report on the Algorithmic Language Scheme'', +@end ifinfo +we have included the report in the Guile distribution; +@xref{Top, , Introduction, r4rs, Revised(4) Report on the Algorithmic +Language Scheme}. +This will also be installed in your info directory. + + +@node Packages not shipped with Guile +@section Packages not shipped with Guile + +We ship the Guile tutorial and reference manual with the Guile +distribution [FIXME: this is not currently true (Sat Sep 20 14:13:33 MDT +1997), but will be soon.] Since the Scheme standard (R4RS) is a stable +document, we ship that too. + +Here are references (usually World Wide Web URLs) to some other freely +redistributable documents and packages which you might find useful if +you are using Guile. + +@table @strong +@item SCSH +the Scheme Shell. Gary Houston has ported SCSH to Guile. The relevant +chapter (@pxref{The Scheme shell (scsh)}) has references to the SCSH web +page with all its documentation. + +@item SLIB +a portable Scheme library maintained by Aubrey Jaffer. SLIB can be +obtained by ftp from @url{ftp://prep.ai.mit.edu/pub/gnu/jacal/}. + +The SLIB package should be unpacked somewhere in Guile's load path. It +will typically be unpacked in @file{/usr/local/share/guile/site}, so +that it will be @file{/usr/local/share/guile/site/slib}. + +Guile might have been installed with a different prefix, in which case +the load path can be checked from inside the interpreter with: + +@smalllisp +guile> %load-path +("/usr/local/share/guile/site" "/usr/local/share/guile/1.3a" "/usr/local/share/guile" ".") +@end smalllisp + +The relevant chapter (@pxref{SLIB}) has details on how to use SLIB with +Guile. + +@item JACAL +a symbolic math package by Aubrey Jaffer. The latest version of Jacal +can be obtained from @url{ftp://prep.ai.mit.edu/pub/gnu/jacal/}, and +should be unpacked in @file{/usr/local/share/guile/site/slib} so that +it will be in @file{/usr/local/share/guile/site/slib/jacal}. + +The relevant section (@pxref{JACAL}) has details on how to use Jacal. +@end table + + +@page +@node Debugger User Interface +@appendix Debugger User Interface + +@c --- The title and introduction of this appendix need to +@c distinguish this clearly from the chapter on the internal +@c debugging interface. + +When debugging a program, programmers often find it helpful to examine +the program's internal status while it runs: the values of internal +variables, the choices made in @code{if} and @code{cond} statements, and +so forth. Guile Scheme provides a debugging interface that programmers +can use to single-step through Scheme functions and examine symbol +bindings. This is different from the @ref{Debugging}, which permits +programmers to debug the Guile interpreter itself. Most programmers +will be more interested in debugging their own Scheme programs than the +interpreter which evaluates them. + +[FIXME: should we include examples of traditional debuggers +and explain why they can't be used to debug interpreted Scheme or Lisp?] + +@menu +* Single-Step:: Execute a program or function one step at a time. +* Trace:: Print a report each time a given function is called. +* Backtrace:: See a list of the statements that caused an error. +* Stacks and Frames:: Examine the state of an interrupted program. +@end menu + +@node Single-Step +@appendixsec Single-Step + +@node Trace +@appendixsec Trace + +When a function is @dfn{traced}, it means that every call to that +function is reported to the user during a program run. This can help a +programmer determine whether a function is being called at the wrong +time or with the wrong set of arguments. + +@defun trace function +Enable debug tracing on @code{function}. While a program is being run, Guile +will print a brief report at each call to a traced function, +advising the user which function was called and the arguments that were +passed to it. +@end defun + +@defun untrace function +Disable debug tracing for @code{function}. +@end defun + +Example: + +@lisp +(define (rev ls) + (if (null? ls) + '() + (append (rev (cdr ls)) + (cons (car ls) '())))) @result{} rev + +(trace rev) @result{} (rev) + +(rev '(a b c d e)) +@result{} [rev (a b c d e)] + | [rev (b c d e)] + | | [rev (c d e)] + | | | [rev (d e)] + | | | | [rev (e)] + | | | | | [rev ()] + | | | | | () + | | | | (e) + | | | (e d) + | | (e d c) + | (e d c b) + (e d c b a) + (e d c b a) +@end lisp + +Note the way Guile indents the output, illustrating the depth of +execution at each function call. This can be used to demonstrate, for +example, that Guile implements self-tail-recursion properly: + +@lisp +(define (rev ls sl) + (if (null? ls) + sl + (rev (cdr ls) + (cons (car ls) sl)))) @result{} rev + +(trace rev) @result{} (rev) + +(rev '(a b c d e) '()) +@result{} [rev (a b c d e) ()] + [rev (b c d e) (a)] + [rev (c d e) (b a)] + [rev (d e) (c b a)] + [rev (e) (d c b a)] + [rev () (e d c b a)] + (e d c b a) + (e d c b a) +@end lisp + +Since the tail call is effectively optimized to a @code{goto} statement, +there is no need for Guile to create a new stack frame for each +iteration. Using @code{trace} here helps us see why this is so. + +@node Backtrace +@appendixsec Backtrace + +@node Stacks and Frames +@appendixsec Stacks and Frames + +When a running program is interrupted, usually upon reaching an error or +breakpoint, its state is represented by a @dfn{stack} of suspended +function calls, each of which is called a @dfn{frame}. The programmer +can learn more about the program's state at the point of interruption by +inspecting and modifying these frames. + +@deffn primitive stack? obj +Return @code{#t} if @var{obj} is a calling stack. +@end deffn + +@deffn primitive make-stack +@end deffn + +@deffn syntax start-stack id exp +Evaluate @var{exp} on a new calling stack with identity @var{id}. If +@var{exp} is interrupted during evaluation, backtraces will not display +frames farther back than @var{exp}'s top-level form. This macro is a +way of artificially limiting backtraces and stack procedures, largely as +a convenience to the user. +@end deffn + +@deffn primitive stack-id stack +Return the identifier given to @var{stack} by @code{start-stack}. +@end deffn + +@deffn primitive stack-ref +@end deffn + +@deffn primitive stack-length +@end deffn + +@deffn primitive frame? +@end deffn + +@deffn primitive last-stack-frame +@end deffn + +@deffn primitive frame-number +@end deffn + +@deffn primitive frame-source +@end deffn + +@deffn primitive frame-procedure +@end deffn + +@deffn primitive frame-arguments +@end deffn + +@deffn primitive frame-previous +@end deffn + +@deffn primitive frame-next +@end deffn + +@deffn primitive frame-real? +@end deffn + +@deffn primitive frame-procedure? +@end deffn + +@deffn primitive frame-evaluating-args? +@end deffn + +@deffn primitive frame-overflow +@end deffn diff --git a/doc/data-rep.texi b/doc/data-rep.texi new file mode 100644 index 000000000..9b7b87977 --- /dev/null +++ b/doc/data-rep.texi @@ -0,0 +1,1818 @@ +@c essay \input texinfo +@c essay @c -*-texinfo-*- +@c essay @c %**start of header +@c essay @setfilename data-rep.info +@c essay @settitle Data Representation in Guile +@c essay @c %**end of header + +@c essay @include version.texi + +@c essay @dircategory The Algorithmic Language Scheme +@c essay @direntry +@c essay * data-rep: (data-rep). Data Representation in Guile --- how to use + Guile objects in your C code. +@c essay @end direntry + +@c essay @setchapternewpage off + +@c essay @ifinfo +@c essay Data Representation in Guile + +@c essay Copyright (C) 1998, 1999, 2000 Free Software Foundation + +@c essay Permission is granted to make and distribute verbatim copies of +@c essay this manual provided the copyright notice and this permission notice +@c essay are preserved on all copies. + +@c essay @ignore +@c essay Permission is granted to process this file through TeX and print the +@c essay results, provided the printed document carries copying permission +@c essay notice identical to this one except for the removal of this paragraph +@c essay (this paragraph not being relevant to the printed manual). +@c essay @end ignore + +@c essay Permission is granted to copy and distribute modified versions of this +@c essay manual under the conditions for verbatim copying, provided that the entire +@c essay resulting derived work is distributed under the terms of a permission +@c essay notice identical to this one. + +@c essay Permission is granted to copy and distribute translations of this manual +@c essay into another language, under the above conditions for modified versions, +@c essay except that this permission notice may be stated in a translation approved +@c essay by the Free Software Foundation. +@c essay @end ifinfo + +@c essay @titlepage +@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.17 2001-03-09 08:21:59 ossau Exp $ +@c essay @subtitle For use with Guile @value{VERSION} +@c essay @author Jim Blandy +@c essay @author Free Software Foundation +@c essay @author @email{jimb@@red-bean.com} +@c essay @c The following two commands start the copyright page. +@c essay @page +@c essay @vskip 0pt plus 1filll +@c essay @vskip 0pt plus 1filll +@c essay Copyright @copyright{} 1998 Free Software Foundation + +@c essay Permission is granted to make and distribute verbatim copies of +@c essay this manual provided the copyright notice and this permission notice +@c essay are preserved on all copies. + +@c essay Permission is granted to copy and distribute modified versions of this +@c essay manual under the conditions for verbatim copying, provided that the entire +@c essay resulting derived work is distributed under the terms of a permission +@c essay notice identical to this one. + +@c essay Permission is granted to copy and distribute translations of this manual +@c essay into another language, under the above conditions for modified versions, +@c essay except that this permission notice may be stated in a translation approved +@c essay by Free Software Foundation. +@c essay @end titlepage + +@c essay @c @smallbook +@c essay @c @finalout +@c essay @headings double + + +@c essay @node Top, Data Representation in Scheme, (dir), (dir) +@c essay @top Data Representation in Guile + +@c essay @ifinfo +@c essay This essay is meant to provide the background necessary to read and +@c essay write C code that manipulates Scheme values in a way that conforms to +@c essay libguile's interface. If you would like to write or maintain a +@c essay Guile-based application in C or C++, this is the first information you +@c essay need. + +@c essay In order to make sense of Guile's @code{SCM_} functions, or read +@c essay libguile's source code, it's essential to have a good grasp of how Guile +@c essay actually represents Scheme values. Otherwise, a lot of the code, and +@c essay the conventions it follows, won't make very much sense. + +@c essay We assume you know both C and Scheme, but we do not assume you are +@c essay familiar with Guile's C interface. +@c essay @end ifinfo + + +@page +@node Data Representation +@chapter Data Representation in Guile + +@strong{by Jim Blandy} + +[Due to the rather non-orthogonal and performance-oriented nature of the +SCM interface, you need to understand SCM internals *before* you can use +the SCM API. That's why this chapter comes first.] + +[NOTE: this is Jim Blandy's essay almost entirely unmodified. It has to +be adapted to fit this manual smoothly.] + +In order to make sense of Guile's SCM_ functions, or read libguile's +source code, it's essential to have a good grasp of how Guile actually +represents Scheme values. Otherwise, a lot of the code, and the +conventions it follows, won't make very much sense. This essay is meant +to provide the background necessary to read and write C code that +manipulates Scheme values in a way that is compatible with libguile. + +We assume you know both C and Scheme, but we do not assume you are +familiar with Guile's implementation. + +@menu +* Data Representation in Scheme:: Why things aren't just totally + straightforward, in general terms. +* How Guile does it:: How to write C code that manipulates + Guile values, with an explanation + of Guile's garbage collector. +* Defining New Types (Smobs):: How to extend Guile with your own + application-specific datatypes. +@end menu + +@node Data Representation in Scheme +@section Data Representation in Scheme + +Scheme is a latently-typed language; this means that the system cannot, +in general, determine the type of a given expression at compile time. +Types only become apparent at run time. Variables do not have fixed +types; a variable may hold a pair at one point, an integer at the next, +and a thousand-element vector later. Instead, values, not variables, +have fixed types. + +In order to implement standard Scheme functions like @code{pair?} and +@code{string?} and provide garbage collection, the representation of +every value must contain enough information to accurately determine its +type at run time. Often, Scheme systems also use this information to +determine whether a program has attempted to apply an operation to an +inappropriately typed value (such as taking the @code{car} of a string). + +Because variables, pairs, and vectors may hold values of any type, +Scheme implementations use a uniform representation for values --- a +single type large enough to hold either a complete value or a pointer +to a complete value, along with the necessary typing information. + +The following sections will present a simple typing system, and then +make some refinements to correct its major weaknesses. However, this is +not a description of the system Guile actually uses. It is only an +illustration of the issues Guile's system must address. We provide all +the information one needs to work with Guile's data in @ref{How Guile +does it}. + + +@menu +* A Simple Representation:: +* Faster Integers:: +* Cheaper Pairs:: +* Guile Is Hairier:: +@end menu + +@node A Simple Representation +@subsection A Simple Representation + +The simplest way to meet the above requirements in C would be to +represent each value as a pointer to a structure containing a type +indicator, followed by a union carrying the real value. Assuming that +@code{SCM} is the name of our universal type, we can write: + +@example +enum type @{ integer, pair, string, vector, ... @}; + +typedef struct value *SCM; + +struct value @{ + enum type type; + union @{ + int integer; + struct @{ SCM car, cdr; @} pair; + struct @{ int length; char *elts; @} string; + struct @{ int length; SCM *elts; @} vector; + ... + @} value; +@}; +@end example +with the ellipses replaced with code for the remaining Scheme types. + +This representation is sufficient to implement all of Scheme's +semantics. If @var{x} is an @code{SCM} value: +@itemize @bullet +@item + To test if @var{x} is an integer, we can write @code{@var{x}->type == integer}. +@item + To find its value, we can write @code{@var{x}->value.integer}. +@item + To test if @var{x} is a vector, we can write @code{@var{x}->type == vector}. +@item + If we know @var{x} is a vector, we can write + @code{@var{x}->value.vector.elts[0]} to refer to its first element. +@item + If we know @var{x} is a pair, we can write + @code{@var{x}->value.pair.car} to extract its car. +@end itemize + + +@node Faster Integers +@subsection Faster Integers + +Unfortunately, the above representation has a serious disadvantage. In +order to return an integer, an expression must allocate a @code{struct +value}, initialize it to represent that integer, and return a pointer to +it. Furthermore, fetching an integer's value requires a memory +reference, which is much slower than a register reference on most +processors. Since integers are extremely common, this representation is +too costly, in both time and space. Integers should be very cheap to +create and manipulate. + +One possible solution comes from the observation that, on many +architectures, structures must be aligned on a four-byte boundary. +(Whether or not the machine actually requires it, we can write our own +allocator for @code{struct value} objects that assures this is true.) +In this case, the lower two bits of the structure's address are known to +be zero. + +This gives us the room we need to provide an improved representation +for integers. We make the following rules: +@itemize @bullet +@item +If the lower two bits of an @code{SCM} value are zero, then the SCM +value is a pointer to a @code{struct value}, and everything proceeds as +before. +@item +Otherwise, the @code{SCM} value represents an integer, whose value +appears in its upper bits. +@end itemize + +Here is C code implementing this convention: +@example +enum type @{ pair, string, vector, ... @}; + +typedef struct value *SCM; + +struct value @{ + enum type type; + union @{ + struct @{ SCM car, cdr; @} pair; + struct @{ int length; char *elts; @} string; + struct @{ int length; SCM *elts; @} vector; + ... + @} value; +@}; + +#define POINTER_P(x) (((int) (x) & 3) == 0) +#define INTEGER_P(x) (! POINTER_P (x)) + +#define GET_INTEGER(x) ((int) (x) >> 2) +#define MAKE_INTEGER(x) ((SCM) (((x) << 2) | 1)) +@end example + +Notice that @code{integer} no longer appears as an element of @code{enum +type}, and the union has lost its @code{integer} member. Instead, we +use the @code{POINTER_P} and @code{INTEGER_P} macros to make a coarse +classification of values into integers and non-integers, and do further +type testing as before. + +Here's how we would answer the questions posed above (again, assume +@var{x} is an @code{SCM} value): +@itemize @bullet +@item + To test if @var{x} is an integer, we can write @code{INTEGER_P (@var{x})}. +@item + To find its value, we can write @code{GET_INTEGER (@var{x})}. +@item + To test if @var{x} is a vector, we can write: +@example + @code{POINTER_P (@var{x}) && @var{x}->type == vector} +@end example + Given the new representation, we must make sure @var{x} is truly a + pointer before we dereference it to determine its complete type. +@item + If we know @var{x} is a vector, we can write + @code{@var{x}->value.vector.elts[0]} to refer to its first element, as + before. +@item + If we know @var{x} is a pair, we can write + @code{@var{x}->value.pair.car} to extract its car, just as before. +@end itemize + +This representation allows us to operate more efficiently on integers +than the first. For example, if @var{x} and @var{y} are known to be +integers, we can compute their sum as follows: +@example +MAKE_INTEGER (GET_INTEGER (@var{x}) + GET_INTEGER (@var{y})) +@end example +Now, integer math requires no allocation or memory references. Most +real Scheme systems actually use an even more efficient representation, +but this essay isn't about bit-twiddling. (Hint: what if pointers had +@code{01} in their least significant bits, and integers had @code{00}?) + + +@node Cheaper Pairs +@subsection Cheaper Pairs + +However, there is yet another issue to confront. Most Scheme heaps +contain more pairs than any other type of object; Jonathan Rees says +that pairs occupy 45% of the heap in his Scheme implementation, Scheme +48. However, our representation above spends three @code{SCM}-sized +words per pair --- one for the type, and two for the @sc{car} and +@sc{cdr}. Is there any way to represent pairs using only two words? + +Let us refine the convention we established earlier. Let us assert +that: +@itemize @bullet +@item + If the bottom two bits of an @code{SCM} value are @code{#b00}, then + it is a pointer, as before. +@item + If the bottom two bits are @code{#b01}, then the upper bits are an + integer. This is a bit more restrictive than before. +@item + If the bottom two bits are @code{#b10}, then the value, with the bottom + two bits masked out, is the address of a pair. +@end itemize + +Here is the new C code: +@example +enum type @{ string, vector, ... @}; + +typedef struct value *SCM; + +struct value @{ + enum type type; + union @{ + struct @{ int length; char *elts; @} string; + struct @{ int length; SCM *elts; @} vector; + ... + @} value; +@}; + +struct pair @{ + SCM car, cdr; +@}; + +#define POINTER_P(x) (((int) (x) & 3) == 0) + +#define INTEGER_P(x) (((int) (x) & 3) == 1) +#define GET_INTEGER(x) ((int) (x) >> 2) +#define MAKE_INTEGER(x) ((SCM) (((x) << 2) | 1)) + +#define PAIR_P(x) (((int) (x) & 3) == 2) +#define GET_PAIR(x) ((struct pair *) ((int) (x) & ~3)) +@end example + +Notice that @code{enum type} and @code{struct value} now only contain +provisions for vectors and strings; both integers and pairs have become +special cases. The code above also assumes that an @code{int} is large +enough to hold a pointer, which isn't generally true. + + +Our list of examples is now as follows: +@itemize @bullet +@item + To test if @var{x} is an integer, we can write @code{INTEGER_P + (@var{x})}; this is as before. +@item + To find its value, we can write @code{GET_INTEGER (@var{x})}, as + before. +@item + To test if @var{x} is a vector, we can write: +@example + @code{POINTER_P (@var{x}) && @var{x}->type == vector} +@end example + We must still make sure that @var{x} is a pointer to a @code{struct + value} before dereferencing it to find its type. +@item + If we know @var{x} is a vector, we can write + @code{@var{x}->value.vector.elts[0]} to refer to its first element, as + before. +@item + We can write @code{PAIR_P (@var{x})} to determine if @var{x} is a + pair, and then write @code{GET_PAIR (@var{x})->car} to refer to its + car. +@end itemize + +This change in representation reduces our heap size by 15%. It also +makes it cheaper to decide if a value is a pair, because no memory +references are necessary; it suffices to check the bottom two bits of +the @code{SCM} value. This may be significant when traversing lists, a +common activity in a Scheme system. + +Again, most real Scheme systems use a slighty different implementation; +for example, if GET_PAIR subtracts off the low bits of @code{x}, instead +of masking them off, the optimizer will often be able to combine that +subtraction with the addition of the offset of the structure member we +are referencing, making a modified pointer as fast to use as an +unmodified pointer. + + +@node Guile Is Hairier +@subsection Guile Is Hairier + +We originally started with a very simple typing system --- each object +has a field that indicates its type. Then, for the sake of efficiency +in both time and space, we moved some of the typing information directly +into the @code{SCM} value, and left the rest in the @code{struct value}. +Guile itself employs a more complex hierarchy, storing finer and finer +gradations of type information in different places, depending on the +object's coarser type. + +In the author's opinion, Guile could be simplified greatly without +significant loss of efficiency, but the simplified system would still be +more complex than what we've presented above. + + +@node How Guile does it +@section How Guile does it + +Here we present the specifics of how Guile represents its data. We +don't go into complete detail; an exhaustive description of Guile's +system would be boring, and we do not wish to encourage people to write +code which depends on its details anyway. We do, however, present +everything one need know to use Guile's data. + + +@menu +* General Rules:: +* Conservative GC:: +* Immediates vs. Non-immediates:: +* Immediate Datatypes:: +* Non-immediate Datatypes:: +* Signalling Type Errors:: +@end menu + +@node General Rules +@subsection General Rules + +Any code which operates on Guile datatypes must @code{#include} the +header file @code{}. This file contains a definition for +the @code{SCM} typedef (Guile's universal type, as in the examples +above), and definitions and declarations for a host of macros and +functions that operate on @code{SCM} values. + +All identifiers declared by @code{} begin with @code{scm_} +or @code{SCM_}. + +@c [[I wish this were true, but I don't think it is at the moment. -JimB]] +@c Macros do not evaluate their arguments more than once, unless documented +@c to do so. + +The functions described here generally check the types of their +@code{SCM} arguments, and signal an error if their arguments are of an +inappropriate type. Macros generally do not, unless that is their +specified purpose. You must verify their argument types beforehand, as +necessary. + +Macros and functions that return a boolean value have names ending in +@code{P} or @code{_p} (for ``predicate''). Those that return a negated +boolean value have names starting with @code{SCM_N}. For example, +@code{SCM_IMP (@var{x})} is a predicate which returns non-zero iff +@var{x} is an immediate value (an @code{IM}). @code{SCM_NCONSP +(@var{x})} is a predicate which returns non-zero iff @var{x} is +@emph{not} a pair object (a @code{CONS}). + + +@node Conservative GC +@subsection Conservative Garbage Collection + +Aside from the latent typing, the major source of constraints on a +Scheme implementation's data representation is the garbage collector. +The collector must be able to traverse every live object in the heap, to +determine which objects are not live. + +There are many ways to implement this, but Guile uses an algorithm +called @dfn{mark and sweep}. The collector scans the system's global +variables and the local variables on the stack to determine which +objects are immediately accessible by the C code. It then scans those +objects to find the objects they point to, @i{et cetera}. The collector +sets a @dfn{mark bit} on each object it finds, so each object is +traversed only once. This process is called @dfn{tracing}. + +When the collector can find no unmarked objects pointed to by marked +objects, it assumes that any objects that are still unmarked will never +be used by the program (since there is no path of dereferences from any +global or local variable that reaches them) and deallocates them. + +In the above paragraphs, we did not specify how the garbage collector +finds the global and local variables; as usual, there are many different +approaches. Frequently, the programmer must maintain a list of pointers +to all global variables that refer to the heap, and another list +(adjusted upon entry to and exit from each function) of local variables, +for the collector's benefit. + +The list of global variables is usually not too difficult to maintain, +since global variables are relatively rare. However, an explicitly +maintained list of local variables (in the author's personal experience) +is a nightmare to maintain. Thus, Guile uses a technique called +@dfn{conservative garbage collection}, to make the local variable list +unnecessary. + +The trick to conservative collection is to treat the stack as an +ordinary range of memory, and assume that @emph{every} word on the stack +is a pointer into the heap. Thus, the collector marks all objects whose +addresses appear anywhere in the stack, without knowing for sure how +that word is meant to be interpreted. + +Obviously, such a system will occasionally retain objects that are +actually garbage, and should be freed. In practice, this is not a +problem. The alternative, an explicitly maintained list of local +variable addresses, is effectively much less reliable, due to programmer +error. + +To accommodate this technique, data must be represented so that the +collector can accurately determine whether a given stack word is a +pointer or not. Guile does this as follows: +@itemize @bullet + +@item +Every heap object has a two-word header, called a @dfn{cell}. Some +objects, like pairs, fit entirely in a cell's two words; others may +store pointers to additional memory in either of the words. For +example, strings and vectors store their length in the first word, and a +pointer to their elements in the second. + +@item +Guile allocates whole arrays of cells at a time, called @dfn{heap +segments}. These segments are always allocated so that the cells they +contain fall on eight-byte boundaries, or whatever is appropriate for +the machine's word size. Guile keeps all cells in a heap segment +initialized, whether or not they are currently in use. + +@item +Guile maintains a sorted table of heap segments. + +@end itemize + +Thus, given any random word @var{w} fetched from the stack, Guile's +garbage collector can consult the table to see if @var{w} falls within a +known heap segment, and check @var{w}'s alignment. If both tests pass, +the collector knows that @var{w} is a valid pointer to a cell, +intentional or not, and proceeds to trace the cell. + +Note that heap segments do not contain all the data Guile uses; cells +for objects like vectors and strings contain pointers to other memory +areas. However, since those pointers are internal, and not shared among +many pieces of code, it is enough for the collector to find the cell, +and then use the cell's type to find more pointers to trace. + + +@node Immediates vs. Non-immediates +@subsection Immediates vs. Non-immediates + +Guile classifies Scheme objects into two kinds: those that fit entirely +within an @code{SCM}, and those that require heap storage. + +The former class are called @dfn{immediates}. The class of immediates +includes small integers, characters, boolean values, the empty list, the +mysterious end-of-file object, and some others. + +The remaining types are called, not suprisingly, @dfn{non-immediates}. +They include pairs, procedures, strings, vectors, and all other data +types in Guile. + +@deftypefn Macro int SCM_IMP (SCM @var{x}) +Return non-zero iff @var{x} is an immediate object. +@end deftypefn + +@deftypefn Macro int SCM_NIMP (SCM @var{x}) +Return non-zero iff @var{x} is a non-immediate object. This is the +exact complement of @code{SCM_IMP}, above. + +You must use this macro before calling a finer-grained predicate to +determine @var{x}'s type. For example, to see if @var{x} is a pair, you +must write: +@example +SCM_NIMP (@var{x}) && SCM_CONSP (@var{x}) +@end example +This is because Guile stores typing information for non-immediate values +in their cells, rather than in the @code{SCM} value itself; thus, you +must determine whether @var{x} refers to a cell before looking inside +it. + +This is somewhat of a pity, because it means that the programmer needs +to know which types Guile implements as immediates vs. non-immediates. +There are (possibly better) representations in which @code{SCM_CONSP} +can be self-sufficient. The immediate type predicates do not suffer +from this weakness. +@end deftypefn + + +@node Immediate Datatypes +@subsection Immediate Datatypes + +The following datatypes are immediate values; that is, they fit entirely +within an @code{SCM} value. The @code{SCM_IMP} and @code{SCM_NIMP} +macros will distinguish these from non-immediates; see @ref{Immediates +vs. Non-immediates} for an explanation of the distinction. + +Note that the type predicates for immediate values work correctly on any +@code{SCM} value; you do not need to call @code{SCM_IMP} first, to +establish that a value is immediate. This differs from the +non-immediate type predicates, which work correctly only on +non-immediate values; you must be sure the value is @code{SCM_NIMP} +before applying them. + + +@menu +* Integer Data:: +* Character Data:: +* Boolean Data:: +* Unique Values:: +@end menu + +@node Integer Data +@subsubsection Integers + +Here are functions for operating on small integers, that fit within an +@code{SCM}. Such integers are called @dfn{immediate numbers}, or +@dfn{INUMs}. In general, INUMs occupy all but two bits of an +@code{SCM}. + +Bignums and floating-point numbers are non-immediate objects, and have +their own, separate accessors. The functions here will not work on +them. This is not as much of a problem as you might think, however, +because the system never constructs bignums that could fit in an INUM, +and never uses floating point values for exact integers. + +@deftypefn Macro int SCM_INUMP (SCM @var{x}) +Return non-zero iff @var{x} is a small integer value. +@end deftypefn + +@deftypefn Macro int SCM_NINUMP (SCM @var{x}) +The complement of SCM_INUMP. +@end deftypefn + +@deftypefn Macro int SCM_INUM (SCM @var{x}) +Return the value of @var{x} as an ordinary, C integer. If @var{x} +is not an INUM, the result is undefined. +@end deftypefn + +@deftypefn Macro SCM SCM_MAKINUM (int @var{i}) +Given a C integer @var{i}, return its representation as an @code{SCM}. +This function does not check for overflow. +@end deftypefn + + +@node Character Data +@subsubsection Characters + +Here are functions for operating on characters. + +@deftypefn Macro int SCM_CHARP (SCM @var{x}) +Return non-zero iff @var{x} is a character value. +@end deftypefn + +@deftypefn Macro {unsigned int} SCM_CHAR (SCM @var{x}) +Return the value of @code{x} as a C character. If @var{x} is not a +Scheme character, the result is undefined. +@end deftypefn + +@deftypefn Macro SCM SCM_MAKE_CHAR (int @var{c}) +Given a C character @var{c}, return its representation as a Scheme +character value. +@end deftypefn + + +@node Boolean Data +@subsubsection Booleans + +Here are functions and macros for operating on booleans. + +@deftypefn Macro SCM SCM_BOOL_T +@deftypefnx Macro SCM SCM_BOOL_F +The Scheme true and false values. +@end deftypefn + +@deftypefn Macro int SCM_NFALSEP (@var{x}) +Convert the Scheme boolean value to a C boolean. Since every object in +Scheme except @code{#f} is true, this amounts to comparing @var{x} to +@code{#f}; hence the name. +@c Noel feels a chill here. +@end deftypefn + +@deftypefn Macro SCM SCM_BOOL_NOT (@var{x}) +Return the boolean inverse of @var{x}. If @var{x} is not a +Scheme boolean, the result is undefined. +@end deftypefn + + +@node Unique Values +@subsubsection Unique Values + +The immediate values that are neither small integers, characters, nor +booleans are all unique values --- that is, datatypes with only one +instance. + +@deftypefn Macro SCM SCM_EOL +The Scheme empty list object, or ``End Of List'' object, usually written +in Scheme as @code{'()}. +@end deftypefn + +@deftypefn Macro SCM SCM_EOF_VAL +The Scheme end-of-file value. It has no standard written +representation, for obvious reasons. +@end deftypefn + +@deftypefn Macro SCM SCM_UNSPECIFIED +The value returned by expressions which the Scheme standard says return +an ``unspecified'' value. + +This is sort of a weirdly literal way to take things, but the standard +read-eval-print loop prints nothing when the expression returns this +value, so it's not a bad idea to return this when you can't think of +anything else helpful. +@end deftypefn + +@deftypefn Macro SCM SCM_UNDEFINED +The ``undefined'' value. Its most important property is that is not +equal to any valid Scheme value. This is put to various internal uses +by C code interacting with Guile. + +For example, when you write a C function that is callable from Scheme +and which takes optional arguments, the interpreter passes +@code{SCM_UNDEFINED} for any arguments you did not receive. + +We also use this to mark unbound variables. +@end deftypefn + +@deftypefn Macro int SCM_UNBNDP (SCM @var{x}) +Return true if @var{x} is @code{SCM_UNDEFINED}. Apply this to a +symbol's value to see if it has a binding as a global variable. +@end deftypefn + + +@node Non-immediate Datatypes +@subsection Non-immediate Datatypes + +A non-immediate datatype is one which lives in the heap, either because +it cannot fit entirely within a @code{SCM} word, or because it denotes a +specific storage location (in the nomenclature of the Revised^4 Report +on Scheme). + +The @code{SCM_IMP} and @code{SCM_NIMP} macros will distinguish these +from immediates; see @ref{Immediates vs. Non-immediates}. + +Given a cell, Guile distinguishes between pairs and other non-immediate +types by storing special @dfn{tag} values in a non-pair cell's car, that +cannot appear in normal pairs. A cell with a non-tag value in its car +is an ordinary pair. The type of a cell with a tag in its car depends +on the tag; the non-immediate type predicates test this value. If a tag +value appears elsewhere (in a vector, for example), the heap may become +corrupted. + + +@menu +* Non-immediate Type Predicates:: Special rules for using the type + predicates described here. +* Pair Data:: +* Vector Data:: +* Procedures:: +* Closures:: +* Subrs:: +* Port Data:: +@end menu + +@node Non-immediate Type Predicates +@subsubsection Non-immediate Type Predicates + +As mentioned in @ref{Conservative GC}, all non-immediate objects +start with a @dfn{cell}, or a pair of words. Furthermore, all type +information that distinguishes one kind of non-immediate from another is +stored in the cell. The type information in the @code{SCM} value +indicates only that the object is a non-immediate; all finer +distinctions require one to examine the cell itself, usually with the +appropriate type predicate macro. + +The type predicates for non-immediate objects generally assume that +their argument is a non-immediate value. Thus, you must be sure that a +value is @code{SCM_NIMP} first before passing it to a non-immediate type +predicate. Thus, the idiom for testing whether a value is a cell or not +is: +@example +SCM_NIMP (@var{x}) && SCM_CONSP (@var{x}) +@end example + + +@node Pair Data +@subsubsection Pairs + +Pairs are the essential building block of list structure in Scheme. A +pair object has two fields, called the @dfn{car} and the @dfn{cdr}. + +It is conventional for a pair's @sc{car} to contain an element of a +list, and the @sc{cdr} to point to the next pair in the list, or to +contain @code{SCM_EOL}, indicating the end of the list. Thus, a set of +pairs chained through their @sc{cdr}s constitutes a singly-linked list. +Scheme and libguile define many functions which operate on lists +constructed in this fashion, so although lists chained through the +@sc{car}s of pairs will work fine too, they may be less convenient to +manipulate, and receive less support from the community. + +Guile implements pairs by mapping the @sc{car} and @sc{cdr} of a pair +directly into the two words of the cell. + + +@deftypefn Macro int SCM_CONSP (SCM @var{x}) +Return non-zero iff @var{x} is a Scheme pair object. +The results are undefined if @var{x} is an immediate value. +@end deftypefn + +@deftypefn Macro int SCM_NCONSP (SCM @var{x}) +The complement of SCM_CONSP. +@end deftypefn + +@deftypefn Macro void SCM_NEWCELL (SCM @var{into}) +Allocate a new cell, and set @var{into} to point to it. This macro +expands to a statement, not an expression, and @var{into} must be an +lvalue of type SCM. + +This is the most primitive way to allocate a cell; it is quite fast. + +The @sc{car} of the cell initially tags it as a ``free cell''. If the +caller intends to use it as an ordinary cons, she must store ordinary +SCM values in its @sc{car} and @sc{cdr}. + +If the caller intends to use it as a header for some other type, she +must store an appropriate magic value in the cell's @sc{car}, to mark +it as a member of that type, and store whatever value in the @sc{cdr} +that type expects. You should generally not do this, unless you are +implementing a new datatype, and thoroughly understand the code in +@code{}. +@end deftypefn + +@deftypefun SCM scm_cons (SCM @var{car}, SCM @var{cdr}) +Allocate (``CONStruct'') a new pair, with @var{car} and @var{cdr} as its +contents. +@end deftypefun + + +The macros below perform no typechecking. The results are undefined if +@var{cell} is an immediate. However, since all non-immediate Guile +objects are constructed from cells, and these macros simply return the +first element of a cell, they actually can be useful on datatypes other +than pairs. (Of course, it is not very modular to use them outside of +the code which implements that datatype.) + +@deftypefn Macro SCM SCM_CAR (SCM @var{cell}) +Return the @sc{car}, or first field, of @var{cell}. +@end deftypefn + +@deftypefn Macro SCM SCM_CDR (SCM @var{cell}) +Return the @sc{cdr}, or second field, of @var{cell}. +@end deftypefn + +@deftypefn Macro void SCM_SETCAR (SCM @var{cell}, SCM @var{x}) +Set the @sc{car} of @var{cell} to @var{x}. +@end deftypefn + +@deftypefn Macro void SCM_SETCDR (SCM @var{cell}, SCM @var{x}) +Set the @sc{cdr} of @var{cell} to @var{x}. +@end deftypefn + +@deftypefn Macro SCM SCM_CAAR (SCM @var{cell}) +@deftypefnx Macro SCM SCM_CADR (SCM @var{cell}) +@deftypefnx Macro SCM SCM_CDAR (SCM @var{cell}) @dots{} +@deftypefnx Macro SCM SCM_CDDDDR (SCM @var{cell}) +Return the @sc{car} of the @sc{car} of @var{cell}, the @sc{car} of the +@sc{cdr} of @var{cell}, @i{et cetera}. +@end deftypefn + + +@node Vector Data +@subsubsection Vectors, Strings, and Symbols + +Vectors, strings, and symbols have some properties in common. They all +have a length, and they all have an array of elements. In the case of a +vector, the elements are @code{SCM} values; in the case of a string or +symbol, the elements are characters. + +All these types store their length (along with some tagging bits) in the +@sc{car} of their header cell, and store a pointer to the elements in +their @sc{cdr}. Thus, the @code{SCM_CAR} and @code{SCM_CDR} macros +are (somewhat) meaningful when applied to these datatypes. + +@deftypefn Macro int SCM_VECTORP (SCM @var{x}) +Return non-zero iff @var{x} is a vector. +The results are undefined if @var{x} is an immediate value. +@end deftypefn + +@deftypefn Macro int SCM_STRINGP (SCM @var{x}) +Return non-zero iff @var{x} is a string. +The results are undefined if @var{x} is an immediate value. +@end deftypefn + +@deftypefn Macro int SCM_SYMBOLP (SCM @var{x}) +Return non-zero iff @var{x} is a symbol. +The results are undefined if @var{x} is an immediate value. +@end deftypefn + +@deftypefn Macro int SCM_LENGTH (SCM @var{x}) +Return the length of the object @var{x}. +The results are undefined if @var{x} is not a vector, string, or symbol. +@end deftypefn + +@deftypefn Macro {SCM *} SCM_VELTS (SCM @var{x}) +Return a pointer to the array of elements of the vector @var{x}. +The results are undefined if @var{x} is not a vector. +@end deftypefn + +@deftypefn Macro {char *} SCM_CHARS (SCM @var{x}) +Return a pointer to the characters of @var{x}. +The results are undefined if @var{x} is not a symbol or a string. +@end deftypefn + +There are also a few magic values stuffed into memory before a symbol's +characters, but you don't want to know about those. What cruft! + + +@node Procedures +@subsubsection Procedures + +Guile provides two kinds of procedures: @dfn{closures}, which are the +result of evaluating a @code{lambda} expression, and @dfn{subrs}, which +are C functions packaged up as Scheme objects, to make them available to +Scheme programmers. + +(There are actually other sorts of procedures: compiled closures, and +continuations; see the source code for details about them.) + +@deftypefun SCM scm_procedure_p (SCM @var{x}) +Return @code{SCM_BOOL_T} iff @var{x} is a Scheme procedure object, of +any sort. Otherwise, return @code{SCM_BOOL_F}. +@end deftypefun + + +@node Closures +@subsubsection Closures + +[FIXME: this needs to be further subbed, but texinfo has no subsubsub] + +A closure is a procedure object, generated as the value of a +@code{lambda} expression in Scheme. The representation of a closure is +straightforward --- it contains a pointer to the code of the lambda +expression from which it was created, and a pointer to the environment +it closes over. + +In Guile, each closure also has a property list, allowing the system to +store information about the closure. I'm not sure what this is used for +at the moment --- the debugger, maybe? + +@deftypefn Macro int SCM_CLOSUREP (SCM @var{x}) +Return non-zero iff @var{x} is a closure. The results are +undefined if @var{x} is an immediate value. +@end deftypefn + +@deftypefn Macro SCM SCM_PROCPROPS (SCM @var{x}) +Return the property list of the closure @var{x}. The results are +undefined if @var{x} is not a closure. +@end deftypefn + +@deftypefn Macro void SCM_SETPROCPROPS (SCM @var{x}, SCM @var{p}) +Set the property list of the closure @var{x} to @var{p}. The results +are undefined if @var{x} is not a closure. +@end deftypefn + +@deftypefn Macro SCM SCM_CODE (SCM @var{x}) +Return the code of the closure @var{x}. The results are undefined if +@var{x} is not a closure. + +This function should probably only be used internally by the +interpreter, since the representation of the code is intimately +connected with the interpreter's implementation. +@end deftypefn + +@deftypefn Macro SCM SCM_ENV (SCM @var{x}) +Return the environment enclosed by @var{x}. +The results are undefined if @var{x} is not a closure. + +This function should probably only be used internally by the +interpreter, since the representation of the environment is intimately +connected with the interpreter's implementation. +@end deftypefn + + +@node Subrs +@subsubsection Subrs + +[FIXME: this needs to be further subbed, but texinfo has no subsubsub] + +A subr is a pointer to a C function, packaged up as a Scheme object to +make it callable by Scheme code. In addition to the function pointer, +the subr also contains a pointer to the name of the function, and +information about the number of arguments accepted by the C fuction, for +the sake of error checking. + +There is no single type predicate macro that recognizes subrs, as +distinct from other kinds of procedures. The closest thing is +@code{scm_procedure_p}; see @ref{Procedures}. + +@deftypefn Macro {char *} SCM_SNAME (@var{x}) +Return the name of the subr @var{x}. The results are undefined if +@var{x} is not a subr. +@end deftypefn + +@deftypefun SCM scm_make_gsubr (char *@var{name}, int @var{req}, int @var{opt}, int @var{rest}, SCM (*@var{function})()) +Create a new subr object named @var{name}, based on the C function +@var{function}, make it visible to Scheme the value of as a global +variable named @var{name}, and return the subr object. + +The subr object accepts @var{req} required arguments, @var{opt} optional +arguments, and a @var{rest} argument iff @var{rest} is non-zero. The C +function @var{function} should accept @code{@var{req} + @var{opt}} +arguments, or @code{@var{req} + @var{opt} + 1} arguments if @code{rest} +is non-zero. + +When a subr object is applied, it must be applied to at least @var{req} +arguments, or else Guile signals an error. @var{function} receives the +subr's first @var{req} arguments as its first @var{req} arguments. If +there are fewer than @var{opt} arguments remaining, then @var{function} +receives the value @code{SCM_UNDEFINED} for any missing optional +arguments. If @var{rst} is non-zero, then any arguments after the first +@code{@var{req} + @var{opt}} are packaged up as a list as passed as +@var{function}'s last argument. + +Note that subrs can actually only accept a predefined set of +combinations of required, optional, and rest arguments. For example, a +subr can take one required argument, or one required and one optional +argument, but a subr can't take one required and two optional arguments. +It's bizarre, but that's the way the interpreter was written. If the +arguments to @code{scm_make_gsubr} do not fit one of the predefined +patterns, then @code{scm_make_gsubr} will return a compiled closure +object instead of a subr object. +@end deftypefun + + +@node Port Data +@subsubsection Ports + +Haven't written this yet, 'cos I don't understand ports yet. + + +@node Signalling Type Errors +@subsection Signalling Type Errors + +Every function visible at the Scheme level should aggressively check the +types of its arguments, to avoid misinterpreting a value, and perhaps +causing a segmentation fault. Guile provides some macros to make this +easier. + +@deftypefn Macro void SCM_ASSERT (int @var{test}, SCM @var{obj}, int @var{position}, char *@var{subr}) +If @var{test} is zero, signal an error, attributed to the subroutine +named @var{subr}, operating on the value @var{obj}. The @var{position} +value determines exactly what sort of error to signal. + +If @var{position} is a string, @code{SCM_ASSERT} raises a +``miscellaneous'' error whose message is that string. + +Otherwise, @var{position} should be one of the values defined below. +@end deftypefn + +@deftypefn Macro int SCM_ARG1 +@deftypefnx Macro int SCM_ARG2 +@deftypefnx Macro int SCM_ARG3 +@deftypefnx Macro int SCM_ARG4 +@deftypefnx Macro int SCM_ARG5 +Signal a ``wrong type argument'' error. When used as the @var{position} +argument of @code{SCM_ASSERT}, @code{SCM_ARG@var{n}} claims that +@var{obj} has the wrong type for the @var{n}'th argument of @var{subr}. + +The only way to complain about the type of an argument after the fifth +is to use @code{SCM_ARGn}, defined below, which doesn't specify which +argument is wrong. You could pass your own error message to +@code{SCM_ASSERT} as the @var{position}, but then the error signalled is +a ``miscellaneous'' error, not a ``wrong type argument'' error. This +seems kludgy to me. +@comment Any function with more than two arguments is wrong --- Perlis +@comment Despite Perlis, I agree. Why not have two Macros, one with +@comment a string error message, and the other with an integer position +@comment that only claims a type error in an argument? +@comment --- Keith Wright +@end deftypefn + +@deftypefn Macro int SCM_ARGn +As above, but does not specify which argument's type is incorrect. +@end deftypefn + +@deftypefn Macro int SCM_WNA +Signal an error complaining that the function received the wrong number +of arguments. + +Interestingly, the message is attributed to the function named by +@var{obj}, not @var{subr}, so @var{obj} must be a Scheme string object +naming the function. Usually, Guile catches these errors before ever +invoking the subr, so we don't run into these problems. +@end deftypefn + + +@node Defining New Types (Smobs) +@section Defining New Types (Smobs) + +@dfn{Smobs} are Guile's mechanism for adding new non-immediate types to +the system.@footnote{The term ``smob'' was coined by Aubrey Jaffer, who +says it comes from ``small object'', referring to the fact that only the +@sc{cdr} and part of the @sc{car} of a smob's cell are available for +use.} To define a new smob type, the programmer provides Guile with +some essential information about the type --- how to print it, how to +garbage collect it, and so on --- and Guile returns a fresh type tag for +use in the @sc{car} of new cells. The programmer can then use +@code{scm_make_gsubr} to make a set of C functions that create and +operate on these objects visible to Scheme code. + +(You can find a complete version of the example code used in this +section in the Guile distribution, in @file{doc/example-smob}. That +directory includes a makefile and a suitable @code{main} function, so +you can build a complete interactive Guile shell, extended with the +datatypes described here.) + +@menu +* Describing a New Type:: +* Creating Instances:: +* Typechecking:: +* Garbage Collecting Smobs:: +* A Common Mistake In Allocating Smobs:: +* Garbage Collecting Simple Smobs:: +* A Complete Example:: +@end menu + +@node Describing a New Type +@subsection Describing a New Type + +To define a new type, the programmer must write four functions to +manage instances of the type: + +@table @code +@item mark +Guile will apply this function to each instance of the new type it +encounters during garbage collection. This function is responsible for +telling the collector about any other non-immediate objects the object +refers to. The default smob mark function is to not mark any data. +@xref{Garbage Collecting Smobs}, for more details. + +@item free +Guile will apply this function to each instance of the new type it could +not find any live pointers to. The function should release all +resources held by the object and return the number of bytes released. +This is analagous to the Java finalization method-- it is invoked at +an unspecified time (when garbage collection occurs) after the object +is dead. +The default free function frees the smob data (if the size of the struct +passed to @code{scm_make_smob_type} or @code{scm_make_smob_type_mfpe} is +non-zero) using @code{scm_must_free} and returns the size of that +struct. @xref{Garbage Collecting Smobs}, for more details. + +@item print +@c GJB:FIXME:: @var{exp} and @var{port} need to refer to a prototype of +@c the print function.... where is that, or where should it go? +Guile will apply this function to each instance of the new type to print +the value, as for @code{display} or @code{write}. The function should +write a printed representation of @var{exp} on @var{port}, in accordance +with the parameters in @var{pstate}. (For more information on print +states, see @ref{Port Data}.) The default print function prints @code{#} +where @code{NAME} is the first argument passed to @code{scm_make_smob_type} or +@code{scm_make_smob_type_mfpe}. + +@item equalp +If Scheme code asks the @code{equal?} function to compare two instances +of the same smob type, Guile calls this function. It should return +@code{SCM_BOOL_T} if @var{a} and @var{b} should be considered +@code{equal?}, or @code{SCM_BOOL_F} otherwise. If @code{equalp} is +@code{NULL}, @code{equal?} will assume that two instances of this type are +never @code{equal?} unless they are @code{eq?}. + +@end table + +To actually register the new smob type, call @code{scm_make_smob_type}: + +@deftypefun long scm_make_smob_type (const char *name, scm_sizet size) +This function implements the standard way of adding a new smob type, +named @var{name}, with instance size @var{size}, to the system. The +return value is a tag that is used in creating instances of the type. +If @var{size} is 0, then no memory will be allocated when instances of +the smob are created, and nothing will be freed by the default free +function. Default values are provided for mark, free, print, and, +equalp, as described above. If you want to customize any of these +functions, the call to @code{scm_make_smob_type} should be immediately +followed by calls to one or several of @code{scm_set_smob_mark}, +@code{scm_set_smob_free}, @code{scm_set_smob_print}, and/or +@code{scm_set_smob_equalp}. +@end deftypefun + +Each of the below @code{scm_set_smob_XXX} functions registers a smob +special function for a given type. Each function is intended to be used +only zero or one time per type, and the call should be placed +immediately following the call to @code{scm_make_smob_type}. + +@deftypefun void scm_set_smob_mark (long tc, SCM (*mark) (SCM)) +This function sets the smob marking procedure for the smob type specified by +the tag @var{tc}. @var{tc} is the tag returned by @code{scm_make_smob_type}. +@end deftypefun + +@deftypefun void scm_set_smob_free (long tc, scm_sizet (*free) (SCM)) +This function sets the smob freeing procedure for the smob type specified by +the tag @var{tc}. @var{tc} is the tag returned by @code{scm_make_smob_type}. +@end deftypefun + +@deftypefun void scm_set_smob_print (long tc, int (*print) (SCM,SCM,scm_print_state*)) +This function sets the smob printing procedure for the smob type specified by +the tag @var{tc}. @var{tc} is the tag returned by @code{scm_make_smob_type}. +@end deftypefun + +@deftypefun void scm_set_smob_equalp (long tc, SCM (*equalp) (SCM,SCM)) +This function sets the smob equality-testing predicate for the smob type specified by +the tag @var{tc}. @var{tc} is the tag returned by @code{scm_make_smob_type}. +@end deftypefun + +Instead of using @code{scm_make_smob_type} and calling each of the +individual @code{scm_set_smob_XXX} functions to register each special +function independently, you can use @code{scm_make_smob_type_mfpe} to +register all of the special functions at once as you create the smob +type@footnote{Warning: There is an ongoing discussion among the developers which +may result in deprecating @code{scm_make_smob_type_mfpe} in next release +of Guile.}: + +@deftypefun long scm_make_smob_type_mfpe(const char *name, scm_sizet size, SCM (*mark) (SCM), scm_sizet (*free) (SCM), int (*print) (SCM, SCM, scm_print_state*), SCM (*equalp) (SCM, SCM)) +This function invokes @code{scm_make_smob_type} on its first two arguments +to add a new smob type named @var{name}, with instance size @var{size} to the system. +It also registers the @var{mark}, @var{free}, @var{print}, @var{equalp} smob +special functions for that new type. Any of these parameters can be @code{NULL} +to have that special function use the default behaviour for guile. +The return value is a tag that is used in creating instances of the type. If @var{size} +is 0, then no memory will be allocated when instances of the smob are created, and +nothing will be freed by the default free function. +@end deftypefun + +For example, here is how one might declare and register a new type +representing eight-bit grayscale images: +@example +#include + +long image_tag; + +void +init_image_type () +@{ + image_tag = scm_make_smob_type_mfpe ("image",sizeof(struct image), + mark_image, free_image, print_image, NULL); +@} +@end example + + +@node Creating Instances +@subsection Creating Instances + +Like other non-immediate types, smobs start with a cell whose @sc{car} +contains typing information, and whose @code{cdr} is free for any use. For smobs, +the @code{cdr} stores a pointer to the internal C structure holding the +smob-specific data. +To create an instance of a smob type following these standards, you should +use @code{SCM_NEWSMOB}: + +@deftypefn Macro void SCM_NEWSMOB(SCM value,long tag,void *data) +Make @var{value} contain a smob instance of the type with tag @var{tag} +and smob data @var{data}. @var{value} must be previously declared +as C type @code{SCM}. +@end deftypefn + +Since it is often the case (e.g., in smob constructors) that you will +create a smob instance and return it, there is also a slightly specialized +macro for this situation: + +@deftypefn Macro fn_returns SCM_RETURN_NEWSMOB(long tab, void *data) +This macro expands to a block of code that creates a smob instance of +the type with tag @var{tag} and smob data @var{data}, and returns +that @code{SCM} value. It should be the last piece of code in +a block. +@end deftypefn + +Guile provides the following functions for managing memory, which are +often helpful when implementing smobs: + +@deftypefun {char *} scm_must_malloc (long @var{len}, char *@var{what}) +Allocate @var{len} bytes of memory, using @code{malloc}, and return a +pointer to them. + +If there is not enough memory available, invoke the garbage collector, +and try once more. If there is still not enough, signal an error, +reporting that we could not allocate @var{what}. + +This function also helps maintain statistics about the size of the heap. +@end deftypefun + +@deftypefun {char *} scm_must_realloc (char *@var{addr}, long @var{olen}, long @var{len}, char *@var{what}) +Resize (and possibly relocate) the block of memory at @var{addr}, to +have a size of @var{len} bytes, by calling @code{realloc}. Return a +pointer to the new block. + +If there is not enough memory available, invoke the garbage collector, +and try once more. If there is still not enough, signal an error, +reporting that we could not allocate @var{what}. + +The value @var{olen} should be the old size of the block of memory at +@var{addr}; it is only used for keeping statistics on the size of the +heap. +@end deftypefun + +@deftypefun void scm_must_free (char *@var{addr}) +Free the block of memory at @var{addr}, using @code{free}. If +@var{addr} is zero, signal an error, complaining of an attempt to free +something that is already free. + +This does no record-keeping; instead, the smob's @code{free} function +must take care of that. + +This function isn't usually sufficiently different from the usual +@code{free} function to be worth using. +@end deftypefun + + +Continuing the above example, if the global variable @code{image_tag} +contains a tag returned by @code{scm_newsmob}, here is how we could +construct a smob whose @sc{cdr} contains a pointer to a freshly +allocated @code{struct image}: + +@example +struct image @{ + int width, height; + char *pixels; + + /* The name of this image */ + SCM name; + + /* A function to call when this image is + modified, e.g., to update the screen, + or SCM_BOOL_F if no action necessary */ + SCM update_func; +@}; + +SCM +make_image (SCM name, SCM s_width, SCM s_height) +@{ + struct image *image; + int width, height; + + SCM_ASSERT (SCM_NIMP (name) && SCM_STRINGP (name), name, + SCM_ARG1, "make-image"); + SCM_ASSERT (SCM_INUMP (s_width), s_width, SCM_ARG2, "make-image"); + SCM_ASSERT (SCM_INUMP (s_height), s_height, SCM_ARG3, "make-image"); + + width = SCM_INUM (s_width); + height = SCM_INUM (s_height); + + image = (struct image *) scm_must_malloc (sizeof (struct image), "image"); + image->width = width; + image->height = height; + image->pixels = scm_must_malloc (width * height, "image pixels"); + image->name = name; + image->update_func = SCM_BOOL_F; + + SCM_RETURN_NEWSMOB (image_tag, image); +@} +@end example + + +@node Typechecking +@subsection Typechecking + +Functions that operate on smobs should aggressively check the types of +their arguments, to avoid misinterpreting some other datatype as a smob, +and perhaps causing a segmentation fault. Fortunately, this is pretty +simple to do. The function need only verify that its argument is a +non-immediate, whose @sc{car} is the type tag returned by +@code{scm_newsmob}. + +For example, here is a simple function that operates on an image smob, +and checks the type of its argument. We also present an expanded +version of the @code{init_image_type} function, to make +@code{clear_image} and the image constructor function @code{make_image} +visible to Scheme code. +@example +SCM +clear_image (SCM image_smob) +@{ + int area; + struct image *image; + + SCM_ASSERT (SCM_SMOB_PREDICATE (image_tag, image_smob), + image_smob, SCM_ARG1, "clear-image"); + + image = (struct image *) SCM_SMOB_DATA (image_smob); + area = image->width * image->height; + memset (image->pixels, 0, area); + + /* Invoke the image's update function. */ + if (image->update_func != SCM_BOOL_F) + scm_apply (image->update_func, SCM_EOL, SCM_EOL); + + return SCM_UNSPECIFIED; +@} + + +void +init_image_type () +@{ + image_tag = scm_newsmob (&image_funs); + + scm_make_gsubr ("make-image", 3, 0, 0, make_image); + scm_make_gsubr ("clear-image", 1, 0, 0, clear_image); +@} +@end example + +Note that checking types is a little more complicated during garbage +collection; see the description of @code{SCM_GCTYP16} in @ref{Garbage +Collecting Smobs}. + +@c GJB:FIXME:: should talk about guile-snarf somewhere! + +@node Garbage Collecting Smobs +@subsection Garbage Collecting Smobs + +Once a smob has been released to the tender mercies of the Scheme +system, it must be prepared to survive garbage collection. Guile calls +the @code{mark} and @code{free} functions of the @code{scm_smobfuns} +structure to manage this. + +As described before (@pxref{Conservative GC}), every object in the +Scheme system has a @dfn{mark bit}, which the garbage collector uses to +tell live objects from dead ones. When collection starts, every +object's mark bit is clear. The collector traces pointers through the +heap, starting from objects known to be live, and sets the mark bit on +each object it encounters. When it can find no more unmarked objects, +the collector walks all objects, live and dead, frees those whose mark +bits are still clear, and clears the mark bit on the others. + +The two main portions of the collection are called the @dfn{mark phase}, +during which the collector marks live objects, and the @dfn{sweep +phase}, during which the collector frees all unmarked objects. + +The mark bit of a smob lives in its @sc{car}, along with the smob's type +tag. When the collector encounters a smob, it sets the smob's mark bit, +and uses the smob's type tag to find the appropriate @code{mark} +function for that smob: the one listed in that smob's +@code{scm_smobfuns} structure. It then calls the @code{mark} function, +passing it the smob as its only argument. + +The @code{mark} function is responsible for marking any other Scheme +objects the smob refers to. If it does not do so, the objects' mark +bits will still be clear when the collector begins to sweep, and the +collector will free them. If this occurs, it will probably break, or at +least confuse, any code operating on the smob; the smob's @code{SCM} +values will have become dangling references. + +To mark an arbitrary Scheme object, the @code{mark} function may call +this function: + +@deftypefun void scm_gc_mark (SCM @var{x}) +Mark the object @var{x}, and recurse on any objects @var{x} refers to. +If @var{x}'s mark bit is already set, return immediately. +@end deftypefun + +Thus, here is how we might write the @code{mark} function for the image +smob type discussed above: +@example +@group +SCM +mark_image (SCM image_smob) +@{ + /* Mark the image's name and update function. */ + struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); + + scm_gc_mark (image->name); + scm_gc_mark (image->update_func); + + return SCM_BOOL_F; +@} +@end group +@end example + +Note that, even though the image's @code{update_func} could be an +arbitrarily complex structure (representing a procedure and any values +enclosed in its environment), @code{scm_gc_mark} will recurse as +necessary to mark all its components. Because @code{scm_gc_mark} sets +an object's mark bit before it recurses, it is not confused by +circular structures. + +As an optimization, the collector will mark whatever value is returned +by the @code{mark} function; this helps limit depth of recursion during +the mark phase. Thus, the code above could also be written as: +@example +@group +SCM +mark_image (SCM image_smob) +@{ + /* Mark the image's name and update function. */ + struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); + + scm_gc_mark (image->name); + return image->update_func; +@} +@end group +@end example + + +Finally, when the collector encounters an unmarked smob during the sweep +phase, it uses the smob's tag to find the appropriate @code{free} +function for the smob. It then calls the function, passing it the smob +as its only argument. + +The @code{free} function must release any resources used by the smob. +However, it need not free objects managed by the collector; the +collector will take care of them. The return type of the @code{free} +function should be @code{scm_sizet}, an unsigned integral type; the +@code{free} function should return the number of bytes released, to help +the collector maintain statistics on the size of the heap. + +Here is how we might write the @code{free} function for the image smob +type: +@example +scm_sizet +free_image (SCM image_smob) +@{ + struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); + scm_sizet size = image->width * image->height + sizeof (*image); + + free (image->pixels); + free (image); + + return size; +@} +@end example + +During the sweep phase, the garbage collector will clear the mark bits +on all live objects. The code which implements a smob need not do this +itself. + +There is no way for smob code to be notified when collection is +complete. + +Note that, since a smob's mark bit lives in its @sc{car}, along with the +smob's type tag, the technique for checking the type of a smob described +in @ref{Typechecking} will not necessarily work during GC. If you need +to find out whether a given object is a particular smob type during GC, +use the following macro: + +@deftypefn Macro void SCM_GCTYP16 (SCM @var{x}) +Return the type bits of the smob @var{x}, with the mark bit clear. + +Use this macro instead of @code{SCM_CAR} to check the type of a smob +during GC. Usually, only code called by the smob's @code{mark} function +need worry about this. +@end deftypefn + +It is usually a good idea to minimize the amount of processing done +during garbage collection; keep @code{mark} and @code{free} functions +very simple. Since collections occur at unpredictable times, it is easy +for any unusual activity to interfere with normal code. + + +@node A Common Mistake In Allocating Smobs, Garbage Collecting Simple Smobs, Garbage Collecting Smobs, Defining New Types (Smobs) +@subsection A Common Mistake In Allocating Smobs + +When constructing new objects, you must be careful that the garbage +collector can always find any new objects you allocate. For example, +suppose we wrote the @code{make_image} function this way: + +@example +SCM +make_image (SCM name, SCM s_width, SCM s_height) +@{ + struct image *image; + SCM image_smob; + int width, height; + + SCM_ASSERT (SCM_NIMP (name) && SCM_STRINGP (name), name, + SCM_ARG1, "make-image"); + SCM_ASSERT (SCM_INUMP (s_width), s_width, SCM_ARG2, "make-image"); + SCM_ASSERT (SCM_INUMP (s_height), s_height, SCM_ARG3, "make-image"); + + width = SCM_INUM (s_width); + height = SCM_INUM (s_height); + + image = (struct image *) scm_must_malloc (sizeof (struct image), "image"); + image->width = width; + image->height = height; + image->pixels = scm_must_malloc (width * height, "image pixels"); + + /* THESE TWO LINES HAVE CHANGED: */ + image->name = scm_string_copy (name); + image->update_func = scm_make_gsubr (@dots{}); + + SCM_NEWCELL (image_smob); + SCM_SETCDR (image_smob, image); + SCM_SETCAR (image_smob, image_tag); + + return image_smob; +@} +@end example + +This code is incorrect. The calls to @code{scm_string_copy} and +@code{scm_make_gsubr} allocate fresh objects. Allocating any new object +may cause the garbage collector to run. If @code{scm_make_gsubr} +invokes a collection, the garbage collector has no way to discover that +@code{image->name} points to the new string object; the @code{image} +structure is not yet part of any Scheme object, so the garbage collector +will not traverse it. Since the garbage collector cannot find any +references to the new string object, it will free it, leaving +@code{image} pointing to a dead object. + +A correct implementation might say, instead: +@example + image->name = SCM_BOOL_F; + image->update_func = SCM_BOOL_F; + + SCM_NEWCELL (image_smob); + SCM_SETCDR (image_smob, image); + SCM_SETCAR (image_smob, image_tag); + + image->name = scm_string_copy (name); + image->update_func = scm_make_gsubr (@dots{}); + + return image_smob; +@end example + +Now, by the time we allocate the new string and function objects, +@code{image_smob} points to @code{image}. If the garbage collector +scans the stack, it will find a reference to @code{image_smob} and +traverse @code{image}, so any objects @code{image} points to will be +preserved. + + +@node Garbage Collecting Simple Smobs, A Complete Example, A Common Mistake In Allocating Smobs, Defining New Types (Smobs) +@subsection Garbage Collecting Simple Smobs + +It is often useful to define very simple smob types --- smobs which have +no data to mark, other than the cell itself, or smobs whose @sc{cdr} is +simply an ordinary Scheme object, to be marked recursively. Guile +provides some functions to handle these common cases; you can use these +functions as your smob type's @code{mark} function, if your smob's +structure is simple enough. + +If the smob refers to no other Scheme objects, then no action is +necessary; the garbage collector has already marked the smob cell +itself. In that case, you can use zero as your mark function. + +@deftypefun SCM scm_markcdr (SCM @var{x}) +Mark the references in the smob @var{x}, assuming that @var{x}'s +@sc{cdr} contains an ordinary Scheme object, and @var{x} refers to no +other objects. This function simply returns @var{x}'s @sc{cdr}. +@end deftypefun + +@deftypefun scm_sizet scm_free0 (SCM @var{x}) +Do nothing; return zero. This function is appropriate for smobs that +use either zero or @code{scm_markcdr} as their marking functions, and +refer to no heap storage, including memory managed by @code{malloc}, +other than the smob's header cell. +@end deftypefun + + +@node A Complete Example +@subsection A Complete Example + +Here is the complete text of the implementation of the image datatype, +as presented in the sections above. We also provide a definition for +the smob's @code{print} function, and make some objects and functions +static, to clarify exactly what the surrounding code is using. + +As mentioned above, you can find this code in the Guile distribution, in +@file{doc/example-smob}. That directory includes a makefile and a +suitable @code{main} function, so you can build a complete interactive +Guile shell, extended with the datatypes described here.) + +@example +/* file "image-type.c" */ + +#include +#include + +static long image_tag; + +struct image @{ + int width, height; + char *pixels; + + /* The name of this image */ + SCM name; + + /* A function to call when this image is + modified, e.g., to update the screen, + or SCM_BOOL_F if no action necessary */ + SCM update_func; +@}; + +static SCM +make_image (SCM name, SCM s_width, SCM s_height) +@{ + struct image *image; + SCM image_smob; + int width, height; + + SCM_ASSERT (SCM_NIMP (name) && SCM_STRINGP (name), name, + SCM_ARG1, "make-image"); + SCM_ASSERT (SCM_INUMP (s_width), s_width, SCM_ARG2, "make-image"); + SCM_ASSERT (SCM_INUMP (s_height), s_height, SCM_ARG3, "make-image"); + + width = SCM_INUM (s_width); + height = SCM_INUM (s_height); + + image = (struct image *) scm_must_malloc (sizeof (struct image), "image"); + image->width = width; + image->height = height; + image->pixels = scm_must_malloc (width * height, "image pixels"); + image->name = name; + image->update_func = SCM_BOOL_F; + + SCM_NEWSMOB (image_smob, image_tag, image); + + return image_smob; +@} + +static SCM +clear_image (SCM image_smob) +@{ + int area; + struct image *image; + + SCM_ASSERT (SCM_SMOB_PREDICATE (image_tag, image_smob), + image_smob, SCM_ARG1, "clear-image"); + + image = (struct image *) SCM_SMOB_DATA (image_smob); + area = image->width * image->height; + memset (image->pixels, 0, area); + + /* Invoke the image's update function. */ + if (image->update_func != SCM_BOOL_F) + scm_apply (image->update_func, SCM_EOL, SCM_EOL); + + return SCM_UNSPECIFIED; +@} + +static SCM +mark_image (SCM image_smob) +@{ + struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); + + scm_gc_mark (image->name); + return image->update_func; +@} + +static scm_sizet +free_image (SCM image_smob) +@{ + struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); + scm_sizet size = image->width * image->height + sizeof (struct image); + + free (image->pixels); + free (image); + + return size; +@} + +static int +print_image (SCM image_smob, SCM port, scm_print_state *pstate) +@{ + struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); + + scm_puts ("#name, port); + scm_puts (">", port); + + /* non-zero means success */ + return 1; +@} + +static scm_smobfuns image_funs = @{ + mark_image, free_image, print_image, 0 +@}; + +void +init_image_type () +@{ + image_tag = scm_newsmob (&image_funs); + + scm_make_gsubr ("clear-image", 1, 0, 0, clear_image); + scm_make_gsubr ("make-image", 3, 0, 0, make_image); +@} +@end example + +Here is a sample build and interaction with the code from the +@file{example-smob} directory, on the author's machine: + +@example +zwingli:example-smob$ make CC=gcc +gcc `guile-config compile` -c image-type.c -o image-type.o +gcc `guile-config compile` -c myguile.c -o myguile.o +gcc image-type.o myguile.o `guile-config link` -o myguile +zwingli:example-smob$ ./myguile +guile> make-image +# +guile> (define i (make-image "Whistler's Mother" 100 100)) +guile> i +# +guile> (clear-image i) +guile> (clear-image 4) +ERROR: In procedure clear-image in expression (clear-image 4): +ERROR: Wrong type argument in position 1: 4 +ABORT: (wrong-type-arg) + +Type "(backtrace)" to get more information. +guile> +@end example + +@c essay @bye diff --git a/doc/deprecated.texi b/doc/deprecated.texi new file mode 100644 index 000000000..6eab2b584 --- /dev/null +++ b/doc/deprecated.texi @@ -0,0 +1,8 @@ +@node Deprecated +@chapter Deprecated + +@c docstring begin (texi-doc-string "guile" "tag") +@deffn primitive tag x +Return an integer corresponding to the type of X. Deprecated. +@end deffn + diff --git a/doc/env.texi b/doc/env.texi new file mode 100644 index 000000000..8c79fe146 --- /dev/null +++ b/doc/env.texi @@ -0,0 +1,1165 @@ +\input texinfo @c -*-texinfo-*- +@c %**start of header +@setfilename env.info +@settitle Top-level Environments in Guile +@c %**end of header + +@setchapternewpage odd + +@c Changes since Jost's implementation: +@c "finite environments" -> "leaf environments" +@c "scm_foo_internal" -> "scm_c_foo" + +@c To do: +@c add spec for soft environments + +@c When merged into the main manual, add cross-references for: +@c weak references +@c smobs (esp. module's mark and free functions) + + +[[add refs for all conditions signalled]] + +@ifinfo +Copyright 1999 Free Software Foundation, Inc. +@end ifinfo + +@titlepage +@sp 10 +@comment The title is printed in a large font. +@center @titlefont{Top-level Environments in Guile} + +@c The following two commands start the copyright page. +@page +@vskip 0pt plus 1filll +Copyright @copyright{} 1999 Free Software Foundation, Inc. +@end titlepage + +@node Top, Motivation, (dir), (dir) + +@menu +* Motivation:: +* Top-Level Environments in Guile:: +* Modules:: +@end menu + +@node Motivation, Top-Level Environments in Guile, Top, Top +@chapter Motivation + +@example +$Id: env.texi,v 1.1 2001-03-09 08:21:59 ossau Exp $ +@end example + +This is a draft proposal for a new datatype for representing top-level +environments in Guile. Upon completion, this proposal will be posted to +the mailing list @samp{guile@@cygnus.com} for discussion, revised in +light of whatever insights that may produce, and eventually implemented. + +Note that this is @emph{not} a proposal for a module system; rather, it +is a proposal for a data structure which encapsulates the ideas one +needs when writing a module system, and, most importantly, a fixed +interface which insulates the interpreter from the details of the module +system. Using these environments, one could implement any module system +one pleased, without changing the interpreter. + +I hope this text will eventually become a chapter of the Guile manual; +thus, the description of environments in written in the present tense, +as if it were already implemented, not in the future tense. However, +this text does not actually describe the present state of Guile. + +I'm especially interested in improving the vague, rambling presentation +of environments in the section "Modules and Environments". I'm trying +to orient the user for the discussion that follows, but I wonder if I'm +just confusing the issue. I would appreciate suggestions if they are +concrete --- please provide new wording. + +Note also: I'm trying out a convention I'm considering for use in the +manual. When a Scheme procedure which is directly implemented by a C +procedure, and both are useful to call from their respective languages, +we document the Scheme procedure only, and call it a "Primitive". If a +Scheme function is marked as a primitive, you can derive the name of the +corresponding C function by changing @code{-} to @code{_}, @code{!} to +@code{_x}, @code{?} to @code{_p}, and prepending @code{scm_}. The C +function's arguments will be all of the Scheme procedure's argumements, +both required and optional; if the Scheme procedure takes a ``rest'' +argument, that will be a final argument to the C function. The C +function's arguments, as well as its return type, will be @code{SCM}. +Thus, a procedure documented like this: +@deffn Primitive set-car! pair value +@end deffn + +has a corresponding C function which would be documented like this: +@deftypefn {Libguile function} SCM scm_set_car_x (SCM @var{pair}, SCM @var{value}) +@end deftypefn + +The hope is that this will be an uncluttered way to document both the C +and Scheme interfaces, without unduly confusing users interested only in +the Scheme level. + +When there is a C function which provides the same functionality as a +primitive, but with a different interface tailored for C's needs, it +usually has the same name as the primitive's C function, but with the +prefix @code{scm_c_} instead of simply @code{scm_}. Thus, +@code{scm_c_environment_ref} is almost identical to +@code{scm_environment_ref}, except that it indicates an unbound variable +in a manner friendlier to C code. + + + +@node Top-Level Environments in Guile, Modules, Motivation, Top +@chapter Top-Level Environments in Guile + +In Guile, an environment is a mapping from symbols onto variables, and +a variable is a location containing a value. Guile uses the datatype +described here to represent its top-level environments. + + +@menu +* Modules and Environments:: Modules are environments, with bookkeeping. +* Common Environment Operations:: Looking up bindings, creating bindings, etc. +* Standard Environment Types:: Guile has some fundamental environment types. +* Implementing Environments:: You can extend Guile with new kinds of + environments. +* Switching to Environments:: Changes needed to today's Guile to + implement the features described here. +@end menu + +@node Modules and Environments, Common Environment Operations, Top-Level Environments in Guile, Top-Level Environments in Guile +@section Modules and Environments + +Guile distinguishes between environments and modules. A module is a +unit of code sharing; it has a name, like @code{(math random)}, an +implementation (e.g., Scheme source code, a dynamically linked library, +or a set of primitives built into Guile), and finally, an environment +containing the definitions which the module exports for its users. + +An environment, by contrast, is simply an abstract data type +representing a mapping from symbols onto variables which the Guile +interpreter uses to look up top-level definitions. The @code{eval} +procedure interprets its first argument, an expression, in the context +of its second argument, an environment. + +Guile uses environments to implement its module system. A module +created by loading Scheme code might be built from several environments. +In addition to the environment of exported definitions, such a module +might have an internal top-level environment, containing both exported +and private definitions, and perhaps environments for imported +definitions alone and local definitions alone. + +The interface described here includes a full set of functions for +mutating environments, and the system goes to some length to maintain +its consistency as environments' bindings change. This is necessary +because Guile is an interactive system. The user may create new +definitions or modify and reload modules while Guile is running; the +system should handle these changes in a consistent and predictable way. + +A typical Guile system will have several distinct top-level +environments. (This is why we call them ``top-level'', and not +``global''.) For example, consider the following fragment of an +interactive Guile session: + +@example +guile> (use-modules (ice-9 regex)) +guile> (define pattern "^(..+)\\1+$") +guile> (string-match pattern "xxxx") +#("xxxx" (0 . 4) (0 . 2)) +guile> (string-match pattern "xxxxx") +#f +guile> +@end example +@noindent +Guile evaluates the expressions the user types in a top-level +environment reserved for that purpose; the definition of @code{pattern} +goes there. That environment is distinct from the one holding the +private definitions of the @code{(ice-9 regex)} module. At the Guile +prompt, the user does not see the module's private definitions, and the +module is unaffected by definitions the user makes at the prompt. The +@code{use-modules} form copies the module's public bindings into the +user's environment. + +All Scheme evaluation takes place with respect to some top-level +environment. Just as the procedure created by a @code{lambda} form +closes over any local scopes surrounding that form, it also closes over +the surrounding top-level environment. Thus, since the +@code{string-match} procedure is defined in the @code{(ice-9 regex)} +module, it closes over that module's top-level environment. Thus, when +the user calls @code{string-match} from the Guile prompt, any free +variables in @code{string-match}'s definition are resolved with respect +to the module's top-level environment, not the user's. + +Although the Guile interaction loop maintains a ``current'' top-level +environment in which it evaluates the user's input, it would be +misleading to extend the concept of a ``current top-level environment'' +to the system as a whole. Each procedure closes over its own top-level +environment, in which that procedure will find bindings for its free +variables. Thus, the top-level environment in force at any given time +depends on the procedure Guile happens to be executing. The global +``current'' environment is a figment of the interaction loop's +imagination. + +Since environments provide all the operations the Guile interpreter +needs to evaluate code, they effectively insulate the interpreter from +the details of the module system. Without changing the interpreter, you +can implement any module system you like, as long as its efforts produce +an environment object the interpreter can consult. + +Finally, environments may prove a convenient way for Guile to access the +features of other systems. For example, one might export the The GIMP's +Procedural Database to Guile as a custom environment type; this +environment could create Scheme procedure objects corresponding to GIMP +procedures, as the user referenced them. + + +@node Common Environment Operations, Standard Environment Types, Modules and Environments, Top-Level Environments in Guile +@section Common Environment Operations + +This section describes the common set of operations that all environment +objects support. To create an environment object, or to perform an +operation specific to a particular kind of environment, see +@ref{Standard Environment Types}. + +In this section, the following names for formal parameters imply that +the actual parameters must have a certain type: + +@table @var + +@item env +an environment + +@item symbol +a symbol + +@item proc +a procedure + +@item value +@itemx object +an arbitrary Scheme value + +@end table + + +@menu +* Examining Environments:: +* Changing Environments:: +* Caching Environment Lookups:: +* Observing Changes to Environments :: +* Environment Errors:: +@end menu + +@node Examining Environments, Changing Environments, Common Environment Operations, Common Environment Operations +@subsection Examining Environments + +@deffn Primitive environment? object +Return @code{#t} if @var{object} is an environment, or @code{#f} otherwise. +@end deffn + +@deffn Primitive environment-ref env symbol +Return the value of the location bound to @var{symbol} in @var{env}. +If @var{symbol} is unbound in @var{env}, signal an @code{environment:unbound} +error (@pxref{Environment Errors}). +@end deffn + +@deffn Primitive environment-bound? env symbol +Return @code{#t} if @var{symbol} is bound in @var{env}, or @code{#f} +otherwise. +@end deffn + +@deffn Primitive environment-fold env proc init +Iterate over all the bindings in an environment, accumulating some value. + +For each binding in @var{env}, apply @var{proc} to the symbol bound, its +value, and the result from the previous application of @var{proc}. Use +@var{init} as @var{proc}'s third argument the first time @var{proc} is +applied. + +If @var{env} contains no bindings, this function simply returns @var{init}. + +If @var{env} binds the symbol @var{sym1} to the value @var{val1}, +@var{sym2} to @var{val2}, and so on, then this procedure computes: +@example +(@var{proc} @var{sym1} @var{val1} + (@var{proc} @var{sym2} @var{val2} + ... + (@var{proc} @var{symn} @var{valn} + @var{init}))) +@end example + +Each binding in @var{env} is processed at most once. +@code{environment-fold} makes no guarantees about the order in which the +bindings are processed. + +If @var{env} is not modified while the iteration is taking place, +@code{environment-fold} will apply @var{proc} to each binding in +@var{env} exactly once. + +If @var{env} is modified while the iteration is taking place, we need to +be more subtle in describing @code{environment-fold}'s behavior. +@code{environment-fold} repeatedly applies @var{proc} to a binding which +was present in @var{env} when @code{environment-fold} was invoked and is +still present in @var{env}, until there are no such bindings remaining. +(If no mutations take place, this definition is equivalent to the +simpler one given above.) By this definition, bindings added during the +iteration will not be passed to @var{proc}. + +Here is a function which, given an environment, constructs an +association list representing that environment's bindings, using +@code{environment-fold}: +@example +(define (environment->alist env) + (environment-fold env + (lambda (sym val tail) + (cons (cons sym val) tail)) + '())) +@end example +@end deffn + +@deftypefn {Libguile macro} int SCM_ENVP (@var{object}) +Return non-zero if @var{object} is an environment. +@end deftypefn + +@deftypefn {Libguile function} SCM scm_c_environment_ref (SCM @var{env}, SCM @var{symbol}) +This C function is identical to @code{environment-ref}, except that if +@var{symbol} is unbound in @var{env}, it returns the value +@code{SCM_UNDEFINED}, instead of signalling an error. +@end deftypefn + +@deftypefn {Libguile function} SCM scm_c_environment_fold (SCM @var{env}, scm_environment_folder *@var{proc}, SCM @var{data}, SCM @var{init}) +This is the C-level analog of @code{environment-fold}. For each binding in +@var{env}, make the call: +@example +(*@var{proc}) (@var{data}, @var{symbol}, @var{value}, @var{previous}) +@end example +@noindent +where @var{previous} is the value returned from the last call to +@code{*@var{proc}}, or @var{init} for the first call. If @var{env} +contains no bindings, return @var{init}. +@end deftypefn + +@deftp {Libguile data type} scm_environment_folder SCM (SCM @var{data}, SCM @var{symbol}, SCM @var{value}, SCM @var{tail}) +The type of a folding function to pass to @code{scm_c_environment_fold}. +@end deftp + + +@node Changing Environments, Caching Environment Lookups, Examining Environments, Common Environment Operations +@subsection Changing Environments + +Here are functions for changing symbols' bindings and values. + +Although it is common to say that an environment binds a symbol to a +value, this is not quite accurate; an environment binds a symbol to a +location, and the location contains a value. In the descriptions below, +we will try to make clear how each function affects bindings and +locations. + +Note that some environments may contain some immutable bindings, or may +bind symbols to immutable locations. If you attempt to change an +immutable binding or value, these functions will signal an +@code{environment:immutable-binding} or +@code{environment:immutable-location} error. However, simply because a +binding cannot be changed via these functions does @emph{not} imply that +it is constant. Mechanisms outside the scope of this section (say, +re-loading a module's source code) may change a binding or value which +is immutable via these functions. + +@deffn Primitive environment-define env symbol value +Bind @var{symbol} to a new location containing @var{value} in @var{env}. +If @var{symbol} is already bound to another location in @var{env}, that +binding is replaced. The new binding and location are both mutable. +The return value is unspecified. + +If @var{symbol} is already bound in @var{env}, and the binding is +immutable, signal an @code{environment:immutable-binding} error. +@end deffn + +@deffn Primitive environment-undefine env symbol +Remove any binding for @var{symbol} from @var{env}. If @var{symbol} is +unbound in @var{env}, do nothing. The return value is unspecified. + +If @var{symbol} is already bound in @var{env}, and the binding is +immutable, signal an @code{environment:immutable-binding} error. +@end deffn + +@deffn Primitive environment-set! env symbol value +If @var{env} binds @var{symbol} to some location, change that location's +value to @var{value}. The return value is unspecified. + +If @var{symbol} is not bound in @var{env}, signal an +@code{environment:unbound} error. If @var{env} binds @var{symbol} to an +immutable location, signal an @code{environment:immutable-location} +error. +@end deffn + + +@node Caching Environment Lookups, Observing Changes to Environments , Changing Environments, Common Environment Operations +@subsection Caching Environment Lookups + +Some applications refer to variables' values so frequently that the +overhead of @code{environment-ref} and @code{environment-set!} is +unacceptable. For example, variable reference speed is a critical +factor in the performance of the Guile interpreter itself. If an +application can tolerate some additional complexity, the +@code{environment-cell} function described here can provide very +efficient access to variable values. + +In the Guile interpreter, most variables are represented by pairs; the +@sc{cdr} of the pair holds the variable's value. Thus, a variable +reference corresponds to taking the @sc{cdr} of one of these pairs, and +setting a variable corresponds to a @code{set-cdr!} operation. A pair +used to represent a variable's value in this manner is called a +@dfn{value cell}. Value cells represent the ``locations'' to which +environments bind symbols. + +The @code{environment-cell} function returns the value cell bound to a +symbol. For example, an interpreter might make the call +@code{(environment-cell @var{env} @var{symbol} #t)} to find the value +cell which @var{env} binds to @var{symbol}, and then use @code{cdr} and +@code{set-cdr!} to reference and assign to that variable, instead of +calling @code{environment-ref} or @var{environment-set!} for each +variable reference. + +There are a few caveats that apply here: + +@itemize @bullet + +@item +Environments are not required to represent variables' values using value +cells. An environment is free to return @code{#f} in response to a +request for a symbol's value cell; in this case, the caller must use +@code{environment-ref} and @code{environment-set!} to manipulate the +variable. + +@item +An environment's binding for a symbol may change. For example, the user +could override an imported variable with a local definition, associating +a new value cell with that symbol. If an interpreter has used +@code{environment-cell} to obtain the variable's value cell, it no +longer needs to use @code{environment-ref} and @code{environment-set!} +to access the variable, and it may not see the new binding. + +Thus, code which uses @code{environment-cell} should almost always use +@code{environment-observe} to track changes to the symbol's binding; +this is the additional complexity hinted at above. @xref{Observing +Changes to Environments}. + +@item +Some variables should be immutable. If a program uses +@code{environment-cell} to obtain the value cell of such a variable, +then it is impossible for the environment to prevent the program from +changing the variable's value, using @code{set-cdr!}. However, this is +discouraged; it is probably better to redesign the interface than to +disregard such a request. To make it easy for programs to honor the +immutability of a variable, @code{environment-cell} takes an argument +indicating whether the caller intends to mutate the cell's value; if +this argument is true, then @code{environment-cell} signals an +@code{environment:immutable-location} error. + +Programs should therefore make separate calls to @code{environment-cell} +to obtain value cells for reference and for assignment. It is incorrect +for a program to call @code{environment-cell} once to obtain a value +cell, and then use that cell for both reference and mutation. + +@end itemize + +@deffn Primitive environment-cell env symbol for-write +Return the value cell which @var{env} binds to @var{symbol}, or +@code{#f} if the binding does not live in a value cell. + +The argument @var{for-write} indicates whether the caller intends to +modify the variable's value by mutating the value cell. If the variable +is immutable, then @code{environment-cell} signals an +@code{environment:immutable-location} error. + +If @var{symbol} is unbound in @var{env}, signal an @code{environment:unbound} +error. + +If you use this function, you should consider using +@code{environment-observe}, to be notified when @code{symbol} gets +re-bound to a new value cell, or becomes undefined. +@end deffn + +@deftypefn {Libguile function} SCM scm_c_environment_cell (SCM @var{env}, SCM @var{symbol}, int for_write) +This C function is identical to @code{environment-cell}, except that if +@var{symbol} is unbound in @var{env}, it returns the value +@code{SCM_UNDEFINED}, instead of signalling an error. +@end deftypefn + +[[After we have some experience using this, we may find that we want to +be able to explicitly ask questions like, "Is this variable mutable?" +without the annoyance of error handling. But maybe this is fine.]] + + +@node Observing Changes to Environments , Environment Errors, Caching Environment Lookups, Common Environment Operations +@subsection Observing Changes to Environments + +The procedures described here allow you to add and remove @dfn{observing +procedures} for an environment. + + +@menu +* Registering Observing Procedures:: +* Observations and Garbage Collection:: +* Observing Environments from C Code:: +@end menu + +@node Registering Observing Procedures, Observations and Garbage Collection, Observing Changes to Environments , Observing Changes to Environments +@subsubsection Registering Observing Procedures + +A program may register an @dfn{observing procedure} for an environment, +which will be called whenever a binding in a particular environment +changes. For example, if the user changes a module's source code and +re-loads the module, other parts of the system may want to throw away +information they have cached about the bindings of the older version of +the module. To support this, each environment retains a set of +observing procedures which it will invoke whenever its bindings change. +We say that these procedures @dfn{observe} the environment's bindings. +You can register new observing procedures for an environment using +@code{environment-observe}. + +@deffn Primitive environment-observe env proc +Whenever @var{env}'s bindings change, apply @var{proc} to @var{env}. + +This function returns an object, @var{token}, which you can pass to +@code{environment-unobserve} to remove @var{proc} from the set of +procedures observing @var{env}. The type and value of @var{token} is +unspecified. +@end deffn + +@deffn Primitive environment-unobserve token +Cancel the observation request which returned the value @var{token}. +The return value is unspecified. + +If a call @code{(environment-observe @var{env} @var{proc})} returns +@var{token}, then the call @code{(environment-unobserve @var{token})} +will cause @var{proc} to no longer be called when @var{env}'s bindings +change. +@end deffn + +There are some limitations on observation: +@itemize @bullet +@item +These procedures do not allow you to observe specific bindings; you +can only observe an entire environment. +@item +These procedures observe bindings, not locations. There is no way +to receive notification when a location's value changes, using these +procedures. +@item +These procedures do not promise to call the observing procedure for each +individual binding change. However, if multiple bindings do change +between calls to the observing procedure, those changes will appear +atomic to the entire system, not just to a few observing procedures. +@item +Since a single environment may have several procedures observing it, a +correct design obviously may not assume that nothing else in the system +has yet observed a given change. +@end itemize + +(One weakness of this observation architecture is that observing +procedures make no promises to the observer. That's fine if you're just +trying to implement an accurate cache, but too weak to implement things +that walk the environment tree.) + +@node Observations and Garbage Collection, Observing Environments from C Code, Registering Observing Procedures, Observing Changes to Environments +@subsubsection Observations and Garbage Collection + +When writing observing procedures, pay close attention to garbage +collection issues. If you use @code{environment-observe} to register +observing procedures for an environment, the environment will hold a +reference to those procedures; while that environment is alive, its +observing procedures will live, as will any data they close over. If +this is not appropriate, you can use the @code{environment-observe-weak} +procedure to create a weak reference from the environment to the +observing procedure. + +For example, suppose an interpreter uses @code{environment-cell} to +reference variables efficiently, as described above in @ref{Caching +Environment Lookups}. That interpreter must register observing +procedures to track changes to the environment. If those procedures +retain any reference to the data structure representing the program +being interpreted, then that structure cannot be collected as long as +the observed environment lives. This is almost certainly incorrect --- +if there are no other references to the structure, it can never be +invoked, so it should be collected. In this case, the interpreter +should register its observing procedure using +@code{environment-observe-weak}, and retain a pointer to it from the +code it updates. Thus, when the code is no longer referenced elsewhere +in the system, the weak link will be broken, and Guile will collect the +code (and its observing procedure). + +@deffn Primitive environment-observe-weak env proc +This function is the same as @code{environment-observe}, except that the +reference @var{env} retains to @var{proc} is a weak reference. This +means that, if there are no other live, non-weak references to +@var{proc}, it will be garbage-collected, and dropped from @var{env}'s +list of observing procedures. +@end deffn + + +@node Observing Environments from C Code, , Observations and Garbage Collection, Observing Changes to Environments +@subsubsection Observing Environments from C Code + +It is also possible to write code that observes an environment in C. +The @code{scm_c_environment_observe} function registers a C +function to observe an environment. The typedef +@code{scm_environment_observer} is the type a C observer function must +have. + +@deftypefn {Libguile function} SCM scm_c_environment_observe (SCM @var{env}, scm_environment_observer *proc, SCM @var{data}, int weak_p) +This is the C-level analog of the Scheme function +@code{environment-observe}. Whenever @var{env}'s bindings change, call +the function @var{proc}, passing it @var{env} and @var{data}. If +@var{weak_p} is non-zero, @var{env} will retain only a weak reference to +@var{data}, and if @var{data} is garbage collected, the entire +observation will be dropped. + +This function returns a token, with the same meaning as those returned +by @code{environment-observe}. +@end deftypefn + +@deftp {Libguile data type} scm_environment_observer void (SCM @var{env}, SCM @var{data}) +The type for observing functions written in C. A function meant to be +passed to @code{scm_c_environment_observe} should have the type +@code{scm_environment_observer}. +@end deftp + +Note that, like all other primitives, @code{environment-observe} is also +available from C, under the name @code{scm_environment_observe}. + + +@node Environment Errors, , Observing Changes to Environments , Common Environment Operations +@subsection Environment Errors + +Here are the error conditions signalled by the environment routines +described above. In these conditions, @var{func} is a string naming a +particular procedure. + +@deffn Condition environment:unbound func message args env symbol +By calling @var{func}, the program attempted to retrieve the value of +@var{symbol} in @var{env}, but @var{symbol} is unbound in @var{env}. +@end deffn + +@deffn Condition environment:immutable-binding func message args env symbol +By calling @var{func}, the program attempted to change the binding of +@var{symbol} in @var{env}, but that binding is immutable. +@end deffn + +@deffn Condition environment:immutable-location func message args env symbol +By calling @var{func}, the program attempted to change the value of +the location to which @var{symbol} is bound in @var{env}, but that +location is immutable. +@end deffn + + +@node Standard Environment Types, Implementing Environments, Common Environment Operations, Top-Level Environments in Guile +@section Standard Environment Types + +Guile supports several different kinds of environments. The operations +described above are actually only the common functionality provided by +all the members of a family of environment types, each designed for a +separate purpose. + +Each environment type has a constructor procedure for building elements +of that type, and extends the set of common operations with its own +procedures, providing specialized functions. For an example of how +these environment types work together, see @ref{Modules of Interpreted +Scheme Code}. + +Guile allows users to define their own environment types. Given a set +of procedures that implement the common environment operations, Guile +will construct a new environment object based on those procedures. + +@menu +* Leaf Environments:: A simple set of bindings. +* Eval Environments:: Local definitions, shadowing + imported definitions. +* Import Environments:: The union of a list of environments. +* Export Environments:: A selected subset of an environment. +* General Environments:: Environments implemented by user + functions. +@end menu + +@node Leaf Environments, Eval Environments, Standard Environment Types, Standard Environment Types +@subsection Leaf Environments + +A @dfn{leaf} environment is simply a mutable set of definitions. A mutable +environment supports no operations beyond the common set. + +@deffn Primitive make-leaf-environment +Create a new leaf environment, containing no bindings. All bindings +and locations in the new environment are mutable. +@end deffn + +@deffn Primitive leaf-environment? object +Return @code{#t} if @var{object} is a leaf environment, or @var{#f} +otherwise. +@end deffn + + +In Guile, each module of interpreted Scheme code uses a leaf +environment to hold the definitions made in that module. + +Leaf environments are so named because their bindings are not computed +from the contents of other environments. Most other environment types +have no bindings of their own, but compute their binding sets based on +those of their operand environments. Thus, the environments in a +running Guile system form a tree, with interior nodes computing their +contents from their child nodes. Leaf environments are the leaves of +such trees. + + +@node Eval Environments, Import Environments, Leaf Environments, Standard Environment Types +@subsection Eval Environments + +A module's source code refers to definitions imported from other +modules, and definitions made within itself. An @dfn{eval} environment +combines two environments --- a @dfn{local} environment and an +@dfn{imported} environment --- to produce a new environment in which +both sorts of references can be resolved. + +@deffn Primitive make-eval-environment local imported +Return a new environment object @var{eval} whose bindings are the union +of the bindings in the environments @var{local} and @var{imported}, with +bindings from @var{local} taking precedence. Definitions made in +@var{eval} are placed in @var{local}. + +Applying @code{environment-define} or @code{environment-undefine} to +@var{eval} has the same effect as applying the procedure to @var{local}. +This means that applying @code{environment-undefine} to a symbol bound +in @var{imported} and free in @var{local} has no effect on the bindings +visible in @var{eval}, which may be surprising. + +Note that @var{eval} incorporates @var{local} and @var{imported} +@emph{by reference} --- if, after creating @var{eval}, the program +changes the bindings of @var{local} or @var{imported}, those changes +will be visible in @var{eval}. + +Since most Scheme evaluation takes place in @var{eval} environments, +they transparenty cache the bindings received from @var{local} and +@var{imported}. Thus, the first time the program looks up a symbol in +@var{eval}, @var{eval} may make calls to @var{local} or @var{imported} +to find their bindings, but subsequent references to that symbol will be +as fast as references to bindings in leaf environments. + +In typical use, @var{local} will be a leaf environment, and +@var{imported} will be an import environment, described below. +@end deffn + +@deffn Primitive eval-environment? object +Return @code{#t} if @var{object} is an eval environment, or @code{#f} +otherwise. +@end deffn + +@deffn Primitive eval-environment-local env +@deffnx Primitive eval-environment-imported env +Return the @var{local} or @var{imported} environment of @var{env}; +@var{env} must be an eval environment. +@end deffn + + +@node Import Environments, Export Environments, Eval Environments, Standard Environment Types +@subsection Import Environments + +An @dfn{import} environment combines the bindings of a set of +argument environments, and checks for naming clashes. + +@deffn Primitive make-import-environment imports conflict-proc +Return a new environment @var{imp} whose bindings are the union of the +bindings from the environments in @var{imports}; @var{imports} must be a +list of environments. That is, @var{imp} binds @var{symbol} to +@var{location} when some element of @var{imports} does. + +If two different elements of @var{imports} have a binding for the same +symbol, apply @var{conflict-proc} to the two environments. If the bindings +of any of the @var{imports} ever changes, check for conflicts again. + +All bindings in @var{imp} are immutable. If you apply +@code{environment-define} or @code{environment-undefine} to @var{imp}, +Guile will signal an @code{environment:immutable-binding} error. +However, notice that the set of bindings in @var{imp} may still change, +if one of its imported environments changes. +@end deffn + +@deffn Primitive import-environment? object +Return @code{#t} if @var{object} is an import environment, or @code{#f} +otherwise. +@end deffn + +@deffn Primitive import-environment-imports env +Return the list of @var{env}'s imported environments; @var{env} must be +an import env. +@end deffn + +@deffn Primitive import-environment-set-imports! env imports +Change @var{env}'s list of imported environments to @var{imports}, and +check for conflicts. +@end deffn + +I'm not at all sure about the way @var{conflict-proc} works. I think +module systems should warn you if it seems you're likely to get the +wrong binding, but exactly how and when those warnings should be +generated, I don't know. + + +@node Export Environments, General Environments, Import Environments, Standard Environment Types +@subsection Export Environments + +An export environment restricts an environment a specified set of +bindings. + +@deffn Primitive make-export-environment private signature +Return a new environment @var{exp} containing only those bindings in +@var{private} whose symbols are present in @var{signature}. The +@var{private} argument must be an environment. + +The environment @var{exp} binds @var{symbol} to @var{location} when +@var{env} does, and @var{symbol} is exported by @var{signature}. + +@var{Signature} is a list specifying which of the bindings in +@var{private} should be visible in @var{exp}. Each element of +@var{signature} should be a list of the form: +@example +(@var{symbol} @var{attribute} ...) +@end example +@noindent +where each @var{attribute} is one of the following: +@table @asis +@item the symbol @code{mutable-location} +@var{exp} should treat the location bound to @var{symbol} as mutable. +That is, @var{exp} will pass calls to @var{env-set!} or +@code{environment-cell} directly through to @var{private}. + +@item the symbol @code{immutable-location} +@var{exp} should treat the location bound to @var{symbol} as immutable. +If the program applies @code{environment-set!} to @var{exp} and +@var{symbol}, or calls @code{environment-cell} to obtain a writable +value cell, @code{environment-set!} will signal an +@code{environment:immutable-location} error. + +Note that, even if an export environment treats a location as immutable, +the underlying environment may treat it as mutable, so its value may +change. +@end table + +It is an error for an element of @var{signature} to specify both +@code{mutable-location} and @code{immutable-location}. If neither is +specified, @code{immutable-location} is assumed. + +As a special case, if an element of @var{signature} is a lone symbol +@var{sym}, it is equivalent to an element of the form +@code{(@var{sym})}. + +All bindings in @var{exp} are immutable. If you apply +@code{environment-define} or @code{environment-undefine} to @var{exp}, +Guile will signal an @code{environment:immutable-binding} error. +However, notice that the set of bindings in @var{exp} may still change, +if the bindings in @var{private} change. +@end deffn + +@deffn Primitive export-environment? object +Return @code{#t} if @var{object} is an export environment, or @code{#f} +otherwise. +@end deffn + +@deffn Primitive export-environment-private env +@deffnx Primitive export-environment-set-private! env +@deffnx Primitive export-environment-signature env +@deffnx Primitive export-environment-set-signature! env +Accessors and mutators for the private environment and signature of +@var{env}; @var{env} must be an export environment. +@end deffn + + +@node General Environments, , Export Environments, Standard Environment Types +@subsection General Environments + +[[user provides the procedures]] +[[A observers B and C; B observes C; C changes; A should only be +notified once, right?]] +[[observation loops?]] + +@node Implementing Environments, Switching to Environments, Standard Environment Types, Top-Level Environments in Guile +@section Implementing Environments + +This section describes how to implement new environment types in Guile. + +Guile's internal representation of environments allows you to extend +Guile with new kinds of environments without modifying Guile itself. +Every environment object carries a pointer to a structure of pointers to +functions implementing the common operations for that environment. The +procedures @code{environment-ref}, @code{environment-set!}, etc. simply +find this structure and invoke the appropriate function. + +[[It would be nice to have an example around here. How about a +persistent environment, bound to a directory, where ref and set actually +access files? Ref on a directory would return another +environment... Hey, let's import my home directory!]] + + +@menu +* Environment Function Tables:: +* Environment Data:: +* Environment Example:: +@end menu + + +@node Environment Function Tables, Environment Data, Implementing Environments, Implementing Environments +@subsection Environment Function Tables + +An environment object is a smob whose @sc{cdr} is a pointer to a pointer +to a @code{struct environment_funcs}: +@example +struct environment_funcs @{ + SCM (*ref) (SCM self, SCM symbol); + SCM (*fold) (SCM self, scm_environment_folder *proc, SCM data, SCM init); + void (*define) (SCM self, SCM symbol, SCM value); + void (*undefine) (SCM self, SCM symbol); + void (*set) (SCM self, SCM symbol, SCM value); + SCM (*cell) (SCM self, SCM symbol, int for_write); + SCM (*observe) (SCM self, scm_environment_observer *proc, SCM data, int weak_p); + void (*unobserve) (SCM self, SCM token); + SCM (*mark) (SCM self); + scm_sizet (*free) (SCM self); + int (*print) (SCM self, SCM port, scm_print_state *pstate); +@}; +@end example + +You can use the following macro to access an environment's function table: + +@deftypefn {Libguile macro} struct environment_funcs *SCM_ENVIRONMENT_FUNCS (@var{env}) +Return a pointer to the @code{struct environment_func} for the environment +@var{env}. If @var{env} is not an environment object, the behavior of +this macro is undefined. +@end deftypefn + +Here is what each element of @var{env_funcs} must do to correctly +implement an environment. In all of these calls, @var{self} is the +environment whose function is being invoked. + +@table @code + +@item SCM ref (SCM @var{self}, SCM @var{symbol}); +This function must have the effect described above for the C call: +@example +scm_c_environment_ref (@var{self}, @var{symbol}) +@end example +@xref{Examining Environments}. + +Note that the @code{ref} element of a @code{struct environment_funcs} +may be zero if a @code{cell} function is provided. + +@item SCM fold (SCM self, scm_environment_folder *proc, SCM data, SCM init); +This function must have the effect described above for the C call: +@example +scm_c_environment_fold (@var{self}, @var{proc}, @var{data}, @var{init}) +@end example +@xref{Examining Environments}. + +@item void define (SCM self, SCM symbol, SCM value); +This function must have the effect described above for the Scheme call: +@example +(environment-define @var{self} @var{symbol} @var{value}) +@end example +@xref{Changing Environments}. + +@item void undefine (SCM self, SCM symbol); +This function must have the effect described above for the Scheme call: +@example +(environment-undefine @var{self} @var{symbol}) +@end example +@xref{Changing Environments}. + +@item void set (SCM self, SCM symbol, SCM value); +This function must have the effect described above for the Scheme call: +@example +(environment-set! @var{self} @var{symbol} @var{value}) +@end example +@xref{Changing Environments}. + +Note that the @code{set} element of a @code{struct environment_funcs} +may be zero if a @code{cell} function is provided. + +@item SCM cell (SCM self, SCM symbol, int for_write); +This function must have the effect described above for the C call: +@example +scm_c_environment_cell (@var{self}, @var{symbol}) +@end example +@xref{Caching Environment Lookups}. + +@item SCM observe (SCM self, scm_environment_observer *proc, SCM data, int weak_p); +This function must have the effect described above for the C call: +@example +scm_c_environment_observe (@var{env}, @var{proc}, @var{data}, @var{weak_p}) +@end example +@xref{Observing Changes to Environments}. + +@item void unobserve (SCM self, SCM token); +Cancel the request to observe @var{self} that returned @var{token}. +@xref{Observing Changes to Environments}. + +@item SCM mark (SCM self); +Set the garbage collection mark all Scheme cells referred to by +@var{self}. Assume that @var{self} itself is already marked. Return a +final object to be marked recursively. + +@item scm_sizet free (SCM self); +Free all non-cell storage associated with @var{self}; return the number +of bytes freed that were obtained using @code{scm_must_malloc} or +@code{scm_must_realloc}. + +@item SCM print (SCM self, SCM port, scm_print_state *pstate); +Print an external representation of @var{self} on @var{port}, passing +@var{pstate} to any recursive calls to the object printer. + +@end table + + +@node Environment Data, Environment Example, Environment Function Tables, Implementing Environments +@subsection Environment Data + +When you implement a new environment type, you will likely want to +associate some data of your own design with each environment object. +Since ANSI C promises that casts will safely convert between a pointer +to a structure and a pointer to its first element, you can have the +@sc{cdr} of an environment smob point to your structure, as long as your +structure's first element is a pointer to a @code{struct +environment_funcs}. Then, your code can use the macro below to retrieve +a pointer to the structure, and cast it to the appropriate type. + +@deftypefn {Libguile macro} struct environment_funcs **SCM_ENVIRONMENT_DATA (@var{env}) +Return the @sc{cdr} of @var{env}, as a pointer to a pointer to an +@code{environment_funcs} structure. +@end deftypefn + +@node Environment Example, , Environment Data, Implementing Environments +@subsection Environment Example + +[[perhaps a simple environment based on association lists]] + + +@node Switching to Environments, , Implementing Environments, Top-Level Environments in Guile +@section Switching to Environments + +Here's what we'd need to do to today's Guile to install the system +described above. This work would probably be done on a branch, because +it involves crippling Guile while a lot of work gets done. Also, it +could change the default set of bindings available pretty drastically, +so the next minor release should not contain these changes. + +After each step here, we should have a Guile that we can at least +interact with, perhaps with some limitations. + +@itemize @bullet + +@item +For testing purposes, make an utterly minimal version of +@file{boot-9.scm}: no module system, no R4RS, nothing. I think a simple +REPL is all we need. + +@item +Implement the environment datatypes in libguile, and test them using +this utterly minimal system. + +@item +Change the interpreter to use the @code{environment-cell} and +@code{environment-observe} instead of the symbol value slots, +first-class variables, etc. Modify the rest of libguile as necessary to +register all the primitives in a single environment. We'll segregate +them into modules later. + +@item +Reimplement the current module system in terms of environments. It +should still be in Scheme. + +@item +Reintegrate the rest of @file{boot-9.scm}. This might be a good point +to move it into modules. + +@item +Do some profiling and optimization. + +@end itemize + +Once this is done, we can make the following simplifications to Guile: + +@itemize @bullet + +@item +A good portion of symbols.c can go away. Symbols no longer need value +slots. The mismash of @code{scm_sym2ovcell}, +@code{scm_intern_obarray_soft}, etc. can go away. @code{intern} becomes +simpler. + +@item +Remove first-class variables: @file{variables.c} and @file{variables.h}. + +@item +Organize the primitives into environments. + +@item +The family of environment types is clearly an abstract class/concrete +subclass arrangement. We should provide GOOPS classes/metaclasses that +make defining new environment types easy and consistent. + +@end itemize + + + +@node Modules, , Top-Level Environments in Guile, Top +@chapter Modules + +The material here is just a sketch. Don't take it too seriously. The +point is that environments allow us to experiment without getting +tangled up with the interpreter. + +@menu +* Modules of Guile Primitives:: +* Modules of Interpreted Scheme Code:: +@end menu + +@node Modules of Guile Primitives, Modules of Interpreted Scheme Code, Modules, Modules +@section Modules of Guile Primitives + +@node Modules of Interpreted Scheme Code, , Modules of Guile Primitives, Modules +@section Modules of Interpreted Scheme Code + +If a module is implemented by interpreted Scheme code, Guile represents +it using several environments: + +@table @asis + +@item the @dfn{local} environment +This environment holds all the definitions made locally by the module, +both public and private. + +@item the @dfn{import} environment +This environment holds all the definitions this module imports from +other modules. + +@item the @dfn{evaluation} environment +This is the environment in which the module's code is actually +evaluated, and the one closed over by the module's procedures, both +public and private. Its bindings are the union of the @var{local} and +@var{import} environments, with local bindings taking precedence. + +@item the @dfn{exported} environment +This environment holds the module's public definitions. This is the +only environment that the module's users have access to. It is the +@var{evaluation} environment, restricted to the set of exported +definitions. + +@end table + +Each of these environments is implemented using a separate environment +type. Some of these types, like the evaluation and import environments, +actually just compute their bindings by consulting other environments; +they have no bindings in their own right. They implement operations +like @code{environment-ref} and @code{environment-define} by passing +them through to the environments from which they are derived. For +example, the evaluation environment will pass definitions through to the +local environment, and search for references and assignments first in +the local environment, and then in the import environment. + + + +@bye diff --git a/doc/expect.texi b/doc/expect.texi new file mode 100644 index 000000000..5b5be1307 --- /dev/null +++ b/doc/expect.texi @@ -0,0 +1,141 @@ +@node Expect +@chapter Expect + +The macros in this section are made available with: + +@smalllisp +(use-modules (ice-9 expect)) +@end smalllisp + +@code{expect} is a macro for selecting actions based on the output from +a port. The name comes from a tool of similar functionality by Don Libes. +Actions can be taken when a particular string is matched, when a timeout +occurs, or when end-of-file is seen on the port. The @code{expect} macro +is described below; @code{expect-strings} is a front-end to @code{expect} +based on regexec (see the regular expression documentation). + +@defmac expect-strings clause @dots{} +By default, @code{expect-strings} will read from the current input port. +The first term in each clause consists of an expression evaluating to +a string pattern (regular expression). As characters +are read one-by-one from the port, they are accumulated in a buffer string +which is matched against each of the patterns. When a +pattern matches, the remaining expression(s) in +the clause are evaluated and the value of the last is returned. For example: + +@smalllisp +(with-input-from-file "/etc/passwd" + (lambda () + (expect-strings + ("^nobody" (display "Got a nobody user.\n") + (display "That's no problem.\n")) + ("^daemon" (display "Got a daemon user.\n"))))) +@end smalllisp + +The regular expression is compiled with the @code{REG_NEWLINE} flag, so +that the ^ and $ anchors will match at any newline, not just at the start +and end of the string. + +There are two other ways to write a clause: + +The expression(s) to evaluate +can be omitted, in which case the result of the regular expression match +(converted to strings, as obtained from regexec with match-pick set to "") +will be returned if the pattern matches. + +The symbol @code{=>} can be used to indicate that the expression is a +procedure which will accept the result of a successful regular expression +match. E.g., + +@smalllisp +("^daemon" => write) +("^d\\(aemon\\)" => (lambda args (for-each write args))) +("^da\\(em\\)on" => (lambda (all sub) + (write all) (newline) + (write sub) (newline))) +@end smalllisp + +The order of the substrings corresponds to the order in which the +opening brackets occur. + +A number of variables can be used to control the behaviour +of @code{expect} (and @code{expect-strings}). +Most have default top-level bindings to the value @code{#f}, +which produces the default behaviour. +They can be redefined at the +top level or locally bound in a form enclosing the expect expression. + +@table @code +@item expect-port +A port to read characters from, instead of the current input port. +@item expect-timeout +@code{expect} will terminate after this number of +seconds, returning @code{#f} or the value returned by expect-timeout-proc. +@item expect-timeout-proc +A procedure called if timeout occurs. The procedure takes a single argument: +the accumulated string. +@item expect-eof-proc +A procedure called if end-of-file is detected on the input port. The +procedure takes a single argument: the accumulated string. +@item expect-char-proc +A procedure to be called every time a character is read from the +port. The procedure takes a single argument: the character which was read. +@item expect-strings-compile-flags +Flags to be used when compiling a regular expression, which are passed +to @code{make-regexp} @xref{Regexp Functions}. The default value +is @code{regexp/newline}. +@item expect-strings-exec-flags +Flags to be used when executing a regular expression, which are +passed to regexp-exec @xref{Regexp Functions}. +The default value is @code{regexp/noteol}, which prevents @code{$} +from matching the end of the string while it is still accumulating, +but still allows it to match after a line break or at the end of file. +@end table + +Here's an example using all of the variables: + +@smalllisp +(let ((expect-port (open-input-file "/etc/passwd")) + (expect-timeout 1) + (expect-timeout-proc + (lambda (s) (display "Times up!\n"))) + (expect-eof-proc + (lambda (s) (display "Reached the end of the file!\n"))) + (expect-char-proc display) + (expect-strings-compile-flags (logior regexp/newline regexp/icase)) + (expect-strings-exec-flags 0)) + (expect-strings + ("^nobody" (display "Got a nobody user\n")))) +@end smalllisp +@end defmac + +@defmac expect clause @dots{} +@code{expect} is used in the same way as @code{expect-strings}, +but tests are specified not as patterns, but as procedures. The +procedures are called in turn after each character is read from the +port, with two arguments: the value of the accumulated string and +a flag to indicate whether end-of-file has been reached. The flag +will usually be @code{#f}, but if end-of-file is reached, the procedures +are called an additional time with the final accumulated string and +@code{#t}. + +The test is successful if the procedure returns a non-false value. + +If the @code{=>} syntax is used, then if the test succeeds it must return +a list containing the arguments to be provided to the corresponding +expression. + +In the following example, a string will only be matched at the beginning +of the file: + +@smalllisp +(let ((expect-port (open-input-file "/etc/passwd"))) + (expect + ((lambda (s eof?) (string=? s "fnord!")) + (display "Got a nobody user!\n")))) +@end smalllisp + +The control variables described for @code{expect-strings} also +influence the behaviour of @code{expect}, with the exception of +variables whose names begin with @code{expect-strings-}. +@end defmac diff --git a/doc/extend.texi b/doc/extend.texi new file mode 100644 index 000000000..e9e7cdd0f --- /dev/null +++ b/doc/extend.texi @@ -0,0 +1,23 @@ +@page +@node Libguile Intro +@chapter Using Guile as an Extension Language + +The chapters in this part of the manual explain how to use Guile as a +powerful application extension language. + +The following chapter, ``GH: A Portable C to Scheme Interface,'' shows +how to call Guile from your application's C code, and how to add new +Scheme level procedures to Guile whose behaviour is specified by +application specific code written in C. The Guile interface functions +documented in this chapter make up a high level, portable interface +which (we hope) will also someday work with other Scheme interpreters, +allowing you to write C code which will work with any of several Scheme +systems. + +The portable interface is rich enough to support simple use of Guile as +an application extension language, but is limited by its own portability +where a deeper integration is desired between Guile and your +application's code. The subsequent chapters therefore present aspects +of libguile that allow you to use more of Guile's C level features, and +to extend your application in more complex ways than is possible with +the portable interface. diff --git a/doc/gh.texi b/doc/gh.texi new file mode 100644 index 000000000..6c18dd98a --- /dev/null +++ b/doc/gh.texi @@ -0,0 +1,815 @@ +@node GH +@chapter GH: A Portable C to Scheme Interface +@cindex libguile - gh +@cindex gh +@cindex gh - reference manual + +The Guile interpreter is based on Aubrey Jaffer's @emph{SCM} interpreter +(@pxref{Overview, SCM: a portable Scheme interpreter, Overview, scm, +SCM: a portable Scheme interpreter}) with some modifications to make it +suitable as an embedded interpreter, and further modifications as Guile +evolves. +@cindex SCM interpreter +@cindex Jaffer, Aubrey + +Part of the modification has been to provide a restricted interface to +limit access to the SCM internals; this is called the @code{gh_} +interface, or @emph{libguile} interface. +@cindex gh_ interface +@cindex libguile interface + +If you are @emph{programming with Guile}, you should only use the C +subroutines described in this manual, which all begin with +@code{gh_}. + +If instead you are @emph{extending Guile}, you have the entire SCM +source to play with. This manual will not help you at all, but you can +consult Aubrey Jaffer's SCM manual (@pxref{Internals, SCM: a portable +Scheme interpreter, Internals, scm, SCM: a portable Scheme +interpreter}). +@cindex Guile - extending +@cindex extending Guile +@cindex SCM internals + +If you are @emph{adding a module to Guile}, I recommend that you stick +to the @code{gh_} interface: this interface is guaranteed to not +change drastically, while the SCM internals might change as Guile is +developed. + + +@menu +* gh preliminaries:: +* Data types and constants defined by gh:: +* Starting and controlling the interpreter:: +* Error messages:: +* Executing Scheme code:: +* Defining new Scheme procedures in C:: +* Converting data between C and Scheme:: +* Type predicates:: +* Equality predicates:: +* Memory allocation and garbage collection:: +* Calling Scheme procedures from C:: +* Mixing gh and scm APIs:: +@end menu + +@page +@node gh preliminaries +@section gh preliminaries + +To use gh, you must have the following toward the beginning of your C +source: +@smallexample +#include +@end smallexample +@cindex gh - headers + +When you link, you will have to add at least @code{-lguile} to the list +of libraries. If you are using more of Guile than the basic Scheme +interpreter, you will have to add more libraries. +@cindex gh - linking + + +@page +@node Data types and constants defined by gh +@section Data types and constants defined by gh +@cindex libguile - data types + +The following C constants and data types are defined in gh: + +@deftp {Data type} SCM +This is a C data type used to store all Scheme data, no matter what the +Scheme type. Values are converted between C data types and the SCM type +with utility functions described below (@pxref{Converting data between C +and Scheme}). [FIXME: put in references to Jim's essay and so forth.] +@end deftp +@cindex SCM data type + +@defvr Constant SCM_BOOL_T +@defvrx Constant SCM_BOOL_F +The @emph{Scheme} values returned by many boolean procedures in +libguile. + +This can cause confusion because they are different from 0 and 1. In +testing a boolean function in libguile programming, you must always make +sure that you check the spec: @code{gh_} and @code{scm_} functions will +usually return @code{SCM_BOOL_T} and @code{SCM_BOOL_F}, but other C +functions usually can be tested against 0 and 1, so programmers' fingers +tend to just type @code{if (boolean_function()) @{ ... @}} +@end defvr + +@defvr Constant SCM_UNSPECIFIED +This is an SCM object which does not correspond to any legal Scheme +value. It can be used in C to terminate functions with variable numbers +of arguments, such as @code{gh_list()}. +@end defvr + +@page +@node Starting and controlling the interpreter +@section Starting and controlling the interpreter +@cindex libguile - start interpreter + +In almost every case, your first @code{gh_} call will be: + +@deftypefun void gh_enter (int @var{argc}, char *@var{argv}[], void (*@var{main_prog})()) +Starts up a Scheme interpreter with all the builtin Scheme primitives. +@code{gh_enter()} never exits, and the user's code should all be in the +@code{@var{main_prog}()} function. @code{argc} and @code{argv} will be +passed to @var{main_prog}. + +@deftypefun void main_prog (int @var{argc}, char *@var{argv}[]) +This is the user's main program. It will be invoked by +@code{gh_enter()} after Guile has been started up. +@end deftypefun + +Note that you can use @code{gh_repl} inside @code{gh_enter} (in other +words, inside the code for @code{main-prog}) if you want the program to +be controled by a Scheme read-eval-print loop. +@end deftypefun + +@cindex read eval print loop -- from the gh_ interface +@cindex REPL -- from the gh_ interface +A convenience routine which enters the Guile interpreter with the +standard Guile read-eval-print loop (@dfn{REPL}) is: + +@deftypefun void gh_repl (int @var{argc}, char *@var{argv}[]) +Enters the Scheme interpreter giving control to the Scheme REPL. +Arguments are processed as if the Guile program @file{guile} were being +invoked. + +Note that @code{gh_repl} should be used @emph{inside} @code{gh_enter}, +since any Guile interpreter calls are meaningless unless they happen in +the context of the interpreter. + +Also note that when you use @code{gh_repl}, your program will be +controlled by Guile's REPL (which is written in Scheme and has many +useful features). Use straight C code inside @code{gh_enter} if you +want to maintain execution control in your C program. +@end deftypefun + +You will typically use @code{gh_enter} and @code{gh_repl} when you +want a Guile interpreter enhanced by your own libraries, but otherwise +quite normal. For example, to build a Guile--derived program that +includes some random number routines @dfn{GSL} (GNU Scientific Library), +you would write a C program that looks like this: + +@smallexample +#include +#include + +/* random number suite */ +SCM gw_ran_seed(SCM s) +@{ + gsl_ran_seed(gh_scm2int(s)); + return SCM_UNSPECIFIED; +@} + +SCM gw_ran_random() +@{ + SCM x; + + x = gh_ulong2scm(gsl_ran_random()); + return x; +@} + +SCM gw_ran_uniform() +@{ + SCM x; + + x = gh_double2scm(gsl_ran_uniform()); + return x; +@} +SCM gw_ran_max() +@{ + return gh_double2scm(gsl_ran_max()); +@} + +void +init_gsl() +@{ + /* random number suite */ + gh_new_procedure("gsl-ran-seed", gw_ran_seed, 1, 0, 0); + gh_new_procedure("gsl-ran-random", gw_ran_random, 0, 0, 0); + gh_new_procedure("gsl-ran-uniform", gw_ran_uniform, 0, 0, 0); + gh_new_procedure("gsl-ran-max", gw_ran_max, 0, 0, 0); +@} + +void +main_prog (int argc, char *argv[]) +@{ + init_gsl(); + + gh_repl(argc, argv); +@} + +int +main (int argc, char *argv[]) +@{ + gh_enter (argc, argv, main_prog); +@} +@end smallexample + +Then, supposing the C program is in @file{guile-gsl.c}, you could +compile it with @kbd{gcc -o guile-gsl guile-gsl.c -lguile -lgsl}. + +The resulting program @file{guile-gsl} would have new primitive +procedures @code{gsl-ran-random}, @code{gsl-ran-gaussian} and so forth. + + +@page +@node Error messages +@section Error messages +@cindex libguile - error messages +@cindex error messages in libguile + +[FIXME: need to fill this based on Jim's new mechanism] + + +@page +@node Executing Scheme code +@section Executing Scheme code +@cindex libguile - executing Scheme +@cindex executing Scheme + +Once you have an interpreter running, you can ask it to evaluate Scheme +code. There are two calls that implement this: + +@deftypefun SCM gh_eval_str (char *@var{scheme_code}) +This asks the interpreter to evaluate a single string of Scheme code, +and returns the result of the last expression evaluated. + +Note that the line of code in @var{scheme_code} must be a well formed +Scheme expression. If you have many lines of code before you balance +parentheses, you must either concatenate them into one string, or use +@code{gh_eval_file()}. +@end deftypefun + +@deftypefun SCM gh_eval_file (char *@var{fname}) +@deftypefunx SCM gh_load (char *@var{fname}) +@code{gh_eval_file} is completely analogous to @code{gh_eval_str()}, +except that a whole file is evaluated instead of a string. Returns the +result of the last expression evaluated. + +@code{gh_load} is identical to @code{gh_eval_file} (it's a macro that +calls @code{gh_eval_file} on its argument). It is provided to start +making the @code{gh_} interface match the R4RS Scheme procedures +closely. +@end deftypefun + + + +@page +@node Defining new Scheme procedures in C +@section Defining new Scheme procedures in C +@cindex libguile - new procedures +@cindex new procedures +@cindex procedures, new +@cindex new primitives +@cindex primitives, new + +The real interface between C and Scheme comes when you can write new +Scheme procedures in C. This is done through the routine + + +@deftypefn {Libguile high} SCM gh_new_procedure (char *@var{proc_name}, SCM (*@var{fn})(), int @var{n_required_args}, int @var{n_optional_args}, int @var{restp}) +@code{gh_new_procedure} defines a new Scheme procedure. Its Scheme name +will be @var{proc_name}, it will be implemented by the C function +(*@var{fn})(), it will take at least @var{n_required_args} arguments, +and at most @var{n_optional_args} extra arguments. + +When the @var{restp} parameter is 1, the procedure takes a final +argument: a list of remaining parameters. + +@code{gh_new_procedure} returns an SCM value representing the procedure. + +The C function @var{fn} should have the form +@deftypefn {Libguile high} SCM fn (SCM @var{req1}, SCM @var{req2}, ..., SCM @var{opt1}, SCM @var{opt2}, ..., SCM @var{rest_args}) +The arguments are all passed as SCM values, so the user will have to use +the conversion functions to convert to standard C types. + +Examples of C functions used as new Scheme primitives can be found in +the sample programs @code{learn0} and @code{learn1}. +@end deftypefn + +@end deftypefn + +@strong{Rationale:} this is the correct way to define new Scheme +procedures in C. The ugly mess of arguments is required because of how +C handles procedures with variable numbers of arguments. + +@strong{Note:} what about documentation strings? + +@cartouche +There are several important considerations to be made when writing the C +routine @code{(*fn)()}. + +First of all the C routine has to return type @code{SCM}. + +Second, all arguments passed to the C funcion will be of type +@code{SCM}. + +Third: the C routine is now subject to Scheme flow control, which means +that it could be interrupted at any point, and then reentered. This +means that you have to be very careful with operations such as +allocating memory, modifying static data @dots{} + +Fourth: to get around the latter issue, you can use +@code{GH_DEFER_INTS} and @code{GH_ALLOW_INTS}. +@end cartouche + +@defmac GH_DEFER_INTS +@defmacx GH_ALLOW_INTS +These macros disable and reenable Scheme's flow control. They +@end defmac + + +@c [??? have to do this right; maybe using subsections, or maybe creating a +@c section called Flow control issues...] + +@c [??? Go into exhaustive detail with examples of the various possible +@c combinations of required and optional args...] + + +@page +@node Converting data between C and Scheme +@section Converting data between C and Scheme +@cindex libguile - converting data +@cindex data conversion +@cindex converting data + +Guile provides mechanisms to convert data between C and Scheme. This +allows new builtin procedures to understand their arguments (which are +of type @code{SCM}) and return values of type @code{SCM}. + + +@menu +* C to Scheme:: +* Scheme to C:: +@end menu + +@node C to Scheme +@subsection C to Scheme + +@deftypefun SCM gh_bool2scm (int @var{x}) +Returns @code{#f} if @var{x} is zero, @code{#t} otherwise. +@end deftypefun + +@deftypefun SCM gh_ulong2scm (unsigned long @var{x}) +@deftypefunx SCM gh_long2scm (long @var{x}) +@deftypefunx SCM gh_double2scm (double @var{x}) +@deftypefunx SCM gh_char2scm (char @var{x}) +Returns a Scheme object with the value of the C quantity @var{x}. +@end deftypefun + +@deftypefun SCM gh_str2scm (char *@var{s}, int @var{len}) +Returns a new Scheme string with the (not necessarily null-terminated) C +array @var{s} data. +@end deftypefun + +@deftypefun SCM gh_str02scm (char *@var{s}) +Returns a new Scheme string with the null-terminated C string @var{s} +data. +@end deftypefun + +@deftypefun SCM gh_set_substr (char *@var{src}, SCM @var{dst}, int @var{start}, int @var{len}) +Copy @var{len} characters at @var{src} into the @emph{existing} Scheme +string @var{dst}, starting at @var{start}. @var{start} is an index into +@var{dst}; zero means the beginning of the string. + +If @var{start} + @var{len} is off the end of @var{dst}, signal an +out-of-range error. +@end deftypefun + +@deftypefun SCM gh_symbol2scm (char *@var{name}) +Given a null-terminated string @var{name}, return the symbol with that +name. +@end deftypefun + +@deftypefun SCM gh_ints2scm (int *@var{dptr}, int @var{n}) +@deftypefunx SCM gh_doubles2scm (double *@var{dptr}, int @var{n}) +Make a scheme vector containing the @var{n} ints or doubles at memory +location @var{dptr}. +@end deftypefun + +@deftypefun SCM gh_chars2byvect (char *@var{dptr}, int @var{n}) +@deftypefunx SCM gh_shorts2svect (short *@var{dptr}, int @var{n}) +@deftypefunx SCM gh_longs2ivect (long *@var{dptr}, int @var{n}) +@deftypefunx SCM gh_ulongs2uvect (ulong *@var{dptr}, int @var{n}) +@deftypefunx SCM gh_floats2fvect (float *@var{dptr}, int @var{n}) +@deftypefunx SCM gh_doubles2dvect (double *@var{dptr}, int @var{n}) +Make a scheme uniform vector containing the @var{n} chars, shorts, +longs, unsigned longs, floats or doubles at memory location @var{dptr}. +@end deftypefun + + + +@node Scheme to C +@subsection Scheme to C + +@deftypefun int gh_scm2bool (SCM @var{obj}) +@deftypefunx {unsigned long} gh_scm2ulong (SCM @var{obj}) +@deftypefunx long gh_scm2long (SCM @var{obj}) +@deftypefunx double gh_scm2double (SCM @var{obj}) +@deftypefunx int gh_scm2char (SCM @var{obj}) +These routines convert the Scheme object to the given C type. +@end deftypefun + +@deftypefun char *gh_scm2newstr (SCM @var{str}, int *@var{lenp}) +Given a Scheme string @var{str}, return a pointer to a new copy of its +contents, followed by a null byte. If @var{lenp} is non-null, set +@code{*@var{lenp}} to the string's length. + +This function uses malloc to obtain storage for the copy; the caller is +responsible for freeing it. + +Note that Scheme strings may contain arbitrary data, including null +characters. This means that null termination is not a reliable way to +determine the length of the returned value. However, the function +always copies the complete contents of @var{str}, and sets @var{*lenp} +to the true length of the string (when @var{lenp} is non-null). +@end deftypefun + + +@deftypefun void gh_get_substr (SCM str, char *return_str, int *lenp) +Copy @var{len} characters at @var{start} from the Scheme string +@var{src} to memory at @var{dst}. @var{start} is an index into +@var{src}; zero means the beginning of the string. @var{dst} has +already been allocated by the caller. + +If @var{start} + @var{len} is off the end of @var{src}, signal an +out-of-range error. +@end deftypefun + +@deftypefun char *gh_symbol2newstr (SCM @var{sym}, int *@var{lenp}) +Takes a Scheme symbol and returns a string of the form +@code{"'symbol-name"}. If @var{lenp} is non-null, the string's length +is returned in @code{*@var{lenp}}. + +This function uses malloc to obtain storage for the returned string; the +caller is responsible for freeing it. +@end deftypefun + +@deftypefun char *gh_scm2chars (SCM @var{vector}, chars *@var{result}) +@deftypefunx short *gh_scm2shorts (SCM @var{vector}, short *@var{result}) +@deftypefunx long *gh_scm2longs (SCM @var{vector}, long *@var{result}) +@deftypefunx float *gh_scm2floats (SCM @var{vector}, float *@var{result}) +@deftypefunx double *gh_scm2doubles (SCM @var{vector}, double *@var{result}) +Copy the numbers in @var{vector} to the array pointed to by @var{result} +and return it. If @var{result} is NULL, allocate a double array large +enough. + +@var{vector} can be an ordinary vector, a weak vector, or a signed or +unsigned uniform vector of the same type as the result array. For +chars, @var{vector} can be a string or substring. For floats and +doubles, @var{vector} can contain a mix of inexact and integer values. + +If @var{vector} is of unsigned type and contains values too large to fit +in the signed destination array, those values will be wrapped around, +that is, data will be copied as if the destination array was unsigned. +@end deftypefun + + +@page +@node Type predicates +@section Type predicates + +These C functions mirror Scheme's type predicate procedures with one +important difference. The C routines return C boolean values (0 and 1) +instead of @code{SCM_BOOL_T} and @code{SCM_BOOL_F}. + +The Scheme notational convention of putting a @code{?} at the end of +predicate procedure names is mirrored in C by placing @code{_p} at the +end of the procedure. For example, @code{(pair? ...)} maps to +@code{gh_pair_p(...)}. + +@deftypefun int gh_boolean_p (SCM @var{val}) +Returns 1 if @var{val} is a boolean, 0 otherwise. +@end deftypefun + +@deftypefun int gh_symbol_p (SCM @var{val}) +Returns 1 if @var{val} is a symbol, 0 otherwise. +@end deftypefun + +@deftypefun int gh_char_p (SCM @var{val}) +Returns 1 if @var{val} is a char, 0 otherwise. +@end deftypefun + +@deftypefun int gh_vector_p (SCM @var{val}) +Returns 1 if @var{val} is a vector, 0 otherwise. +@end deftypefun + +@deftypefun int gh_pair_p (SCM @var{val}) +Returns 1 if @var{val} is a pair, 0 otherwise. +@end deftypefun + +@deftypefun int gh_procedure_p (SCM @var{val}) +Returns 1 if @var{val} is a procedure, 0 otherwise. +@end deftypefun + +@deftypefun int gh_list_p (SCM @var{val}) +Returns 1 if @var{val} is a list, 0 otherwise. +@end deftypefun + +@deftypefun int gh_inexact_p (SCM @var{val}) +Returns 1 if @var{val} is an inexact number, 0 otherwise. +@end deftypefun + +@deftypefun int gh_exact_p (SCM @var{val}) +Returns 1 if @var{val} is an exact number, 0 otherwise. +@end deftypefun + + +@page +@node Equality predicates +@section Equality predicates + +These C functions mirror Scheme's equality predicate procedures with one +important difference. The C routines return C boolean values (0 and 1) +instead of @code{SCM_BOOL_T} and @code{SCM_BOOL_F}. + +The Scheme notational convention of putting a @code{?} at the end of +predicate procedure names is mirrored in C by placing @code{_p} at the +end of the procedure. For example, @code{(equal? ...)} maps to +@code{gh_equal_p(...)}. + +@deftypefun int gh_eq_p (SCM x, SCM y) +Returns 1 if @var{x} and @var{y} are equal in the sense of Scheme's +@code{eq?} predicate, 0 otherwise. +@end deftypefun + +@deftypefun int gh_eqv_p (SCM x, SCM y) +Returns 1 if @var{x} and @var{y} are equal in the sense of Scheme's +@code{eqv?} predicate, 0 otherwise. +@end deftypefun + +@deftypefun int gh_equal_p (SCM x, SCM y) +Returns 1 if @var{x} and @var{y} are equal in the sense of Scheme's +@code{equal?} predicate, 0 otherwise. +@end deftypefun + +@deftypefun int gh_string_equal_p (SCM @var{s1}, SCM @var{s2}) +Returns 1 if the strings @var{s1} and @var{s2} are equal, 0 otherwise. +@end deftypefun + +@deftypefun int gh_null_p (SCM @var{l}) +Returns 1 if @var{l} is an empty list or pair; 0 otherwise. +@end deftypefun + + +@page +@node Memory allocation and garbage collection +@section Memory allocation and garbage collection + +@c [FIXME: flesh this out with some description of garbage collection in +@c scm/guile] + +@c @deftypefun SCM gh_mkarray (int size) +@c Allocate memory for a Scheme object in a garbage-collector-friendly +@c manner. +@c @end deftypefun + + +@page +@node Calling Scheme procedures from C +@section Calling Scheme procedures from C + +Many of the Scheme primitives are available in the @code{gh_} +interface; they take and return objects of type SCM, and one could +basically use them to write C code that mimics Scheme code. + +I will list these routines here without much explanation, since what +they do is the same as documented in @ref{Standard Procedures, R4RS, , +r4rs, R4RS}. But I will point out that when a procedure takes a +variable number of arguments (such as @code{gh_list}), you should pass +the constant @var{SCM_EOL} from C to signify the end of the list. + +@deftypefun SCM gh_define (char *@var{name}, SCM @var{val}) +Corresponds to the Scheme @code{(define name val)}: it binds a value to +the given name (which is a C string). Returns the new object. +@end deftypefun + +@heading Pairs and lists + +@deftypefun SCM gh_cons (SCM @var{a}, SCM @var{b}) +@deftypefunx SCM gh_list (SCM l0, SCM l1, ... , SCM_UNDEFINED) +These correspond to the Scheme @code{(cons a b)} and @code{(list l0 l1 +...)} procedures. Note that @code{gh_list()} is a C macro that invokes +@code{scm_listify()}. +@end deftypefun + +@deftypefun SCM gh_set_car (SCM @var{obj}, SCM @var{val}) +@deftypefunx SCM gh_set_cdr (SCM @var{obj}, SCM @var{val}) +These correspond to the Scheme @code{(set-car! ...)} and @code{(set-cdr! +...)} procedures. +@end deftypefun + + +@deftypefun SCM gh_car (SCM @var{obj}) +@deftypefunx SCM gh_cdr (SCM @var{obj}) +@dots{} + +@deftypefunx SCM gh_c[ad][ad][ad][ad]r (SCM @var{obj}) +These correspond to the Scheme @code{(caadar ls)} procedures etc @dots{} +@end deftypefun + +@deftypefun SCM gh_set_car_x(SCM @var{pair}, SCM @var{value}) +Modifies the CAR of @var{pair} to be @var{value}. This is equivalent to +the Scheme procedure @code{(set-car! ...)}. +@end deftypefun + +@deftypefun SCM gh_set_cdr_x(SCM @var{pair}, SCM @var{value}) +Modifies the CDR of @var{pair} to be @var{value}. This is equivalent to +the Scheme procedure @code{(set-cdr! ...)}. +@end deftypefun + +@deftypefun {unsigned long} gh_length (SCM @var{ls}) +Returns the length of the list. +@end deftypefun + +@deftypefun SCM gh_append (SCM @var{args}) +@deftypefunx SCM gh_append2 (SCM @var{l1}, SCM @var{l2}) +@deftypefunx SCM gh_append3 (SCM @var{l1}, SCM @var{l2}, @var{l3}) +@deftypefunx SCM gh_append4 (SCM @var{l1}, SCM @var{l2}, @var{l3}, @var{l4}) +@code{gh_append()} takes @var{args}, which is a list of lists +@code{(list1 list2 ...)}, and returns a list containing all the elements +of the individual lists. + +A typical invocation of @code{gh_append()} to append 5 lists together +would be +@smallexample + gh_append(gh_list(l1, l2, l3, l4, l5, SCM_UNDEFINED)); +@end smallexample + +The functions @code{gh_append2()}, @code{gh_append2()}, +@code{gh_append3()} and @code{gh_append4()} are convenience routines to +make it easier for C programs to form the list of lists that goes as an +argument to @code{gh_append()}. +@end deftypefun + +@deftypefun SCM gh_reverse (SCM @var{ls}) +Returns a new list that has the same elements as @var{ls} but in the +reverse order. Note that this is implemented as a macro which calls +@code{scm_reverse()}. +@end deftypefun + +@deftypefun SCM gh_list_tail (SCM @var{ls}, SCM @var{k}) +Returns the sublist of @var{ls} with the last @var{k} elements. +@end deftypefun + +@deftypefun SCM gh_list_ref (SCM @var{ls}, SCM @var{k}) +Returns the @var{k}th element of the list @var{ls}. +@end deftypefun + +@deftypefun SCM gh_memq (SCM @var{x}, SCM @var{ls}) +@deftypefunx SCM gh_memv (SCM @var{x}, SCM @var{ls}) +@deftypefunx SCM gh_member (SCM @var{x}, SCM @var{ls}) +These functions return the first sublist of @var{ls} whose CAR is +@var{x}. They correspond to @code{(memq x ls)}, @code{(memv x ls)} and +@code{(member x ls)}, and hence use (respectively) @code{eq?}, +@code{eqv?} and @code{equal?} to do comparisons. + +If @var{x} does not appear in @var{ls}, the value @code{SCM_BOOL_F} (not +the empty list) is returned. + +Note that these functions are implemented as macros which call +@code{scm_memq()}, @code{scm_memv()} and @code{scm_member()} +respectively. +@end deftypefun + +@deftypefun SCM gh_assq (SCM @var{x}, SCM @var{alist}) +@deftypefunx SCM gh_assv (SCM @var{x}, SCM @var{alist}) +@deftypefunx SCM gh_assoc (SCM @var{x}, SCM @var{alist}) +These functions search an @dfn{association list} (list of pairs) +@var{alist} for the first pair whose CAR is @var{x}, and they return +that pair. + +If no pair in @var{alist} has @var{x} as its CAR, the value +@code{SCM_BOOL_F} (not the empty list) is returned. + +Note that these functions are implemented as macros which call +@code{scm_assq()}, @code{scm_assv()} and @code{scm_assoc()} +respectively. +@end deftypefun + + +@heading Symbols + +@c @deftypefun SCM gh_symbol (SCM str, SCM len) +@c @deftypefunx SCM gh_tmp_symbol (SCM str, SCM len) +@c Takes the given string @var{str} of length @var{len} and returns a +@c symbol corresponding to that string. +@c @end deftypefun + + +@heading Vectors + +@deftypefun SCM gh_make_vector (SCM @var{n}, SCM @var{fill}) +@deftypefunx SCM gh_vector (SCM @var{ls}) +@deftypefunx SCM gh_vector_ref (SCM @var{v}, SCM @var{i}) +@deftypefunx SCM gh_vector_set (SCM @var{v}, SCM @var{i}, SCM @var{val}) +@deftypefunx {unsigned long} gh_vector_length (SCM @var{v}) +@deftypefunx SCM gh_list_to_vector (SCM @var{ls}) +These correspond to the Scheme @code{(make-vector n fill)}, +@code{(vector a b c ...)} @code{(vector-ref v i)} @code{(vector-set v i +value)} @code{(vector-length v)} @code{(list->vector ls)} procedures. + +The correspondence is not perfect for @code{gh_vector}: this routine +taks a list @var{ls} instead of the individual list elements, thus +making it identical to @code{gh_list_to_vector}. + +There is also a difference in gh_vector_length: the value returned is a +C @code{unsigned long} instead of an SCM object. +@end deftypefun + + +@heading Procedures + +@c @deftypefun SCM gh_make_subr (SCM (*@var{fn})(), int @var{req}, int @var{opt}, int @var{restp}, char *@var{sym}) +@c Make the C function @var{fn} available to Scheme programs. The function +@c will be bound to the symbol @var{sym}. The arguments @var{req}, +@c @var{opt} and @var{restp} describe @var{fn}'s calling conventions. The +@c function must take @var{req} required arguments and may take @var{opt} +@c optional arguments. Any optional arguments which are not supplied by +@c the caller will be bound to @var{SCM_UNSPECIFIED}. If @var{restp} is +@c non-zero, it means that @var{fn} may be called with an arbitrary number +@c of arguments, and that any extra arguments supplied by the caller will +@c be passed to @var{fn} as a list. The @var{restp} argument is exactly +@c like Scheme's @code{(lambda (arg1 arg2 . arglist))} calling convention. +@c +@c For example, the procedure @code{read-line}, which takes optional +@c @var{port} and @var{handle-delim} arguments, would be declared like so: +@c +@c @example +@c SCM scm_read_line (SCM port, SCM handle_delim); +@c gh_make_subr (scm_read_line, 0, 2, 0, "read-line"); +@c @end example +@c +@c The @var{req} argument to @code{gh_make_subr} is 0 to indicate that +@c there are no required arguments, so @code{read-line} may be called +@c without any arguments at all. The @var{opt} argument is 2, to indicate +@c that both the @var{port} and @var{handle_delim} arguments to +@c @code{scm_read_line} are optional, and will be bound to +@c @code{SCM_UNSPECIFIED} if the calling program does not supply them. +@c Because the @var{restp} argument is 0, this function may not be called +@c with more than two arguments. +@c @end deftypefun + +@deftypefun SCM gh_apply (SCM proc, SCM args) +Call the Scheme procedure @var{proc}, with the elements of @var{args} as +arguments. @var{args} must be a proper list. +@end deftypefun + +@deftypefun SCM gh_call0 (SCM proc) +@deftypefunx SCM gh_call1 (SCM proc, SCM arg) +@deftypefunx SCM gh_call2 (SCM proc, SCM arg1, SCM arg2) +@deftypefunx SCM gh_call3 (SCM proc, SCM arg1, SCM arg2, SCM arg3) +Call the Scheme procedure @var{proc} with no arguments +(@code{gh_call0}), one argument (@code{gh_call1}), and so on. You can +get the same effect by wrapping the arguments up into a list, and +calling @code{gh_apply}; Guile provides these functions for convenience. +@end deftypefun + + +@deftypefun SCM gh_catch (SCM key, SCM thunk, SCM handler) +@deftypefunx SCM gh_throw (SCM key, SCM args) +Corresponds to the Scheme @code{catch} and @code{throw} procedures, +which in Guile are provided as primitives. +@end deftypefun + +@c [FIXME: must add the I/O section in gscm.h] + +@deftypefun SCM gh_is_eq (SCM a, SCM b) +@deftypefunx SCM gh_is_eqv (SCM a, SCM b) +@deftypefunx SCM gh_is_equal (SCM a, SCM b) +These correspond to the Scheme @code{eq?}, @code{eqv?} and @code{equal?} +predicates. +@end deftypefun + +@deftypefun int gh_obj_length (SCM @var{obj}) +Returns the raw object length. +@end deftypefun + +@heading Data lookup + +For now I just include Tim Pierce's comments from the @file{gh_data.c} +file; it should be organized into a documentation of the two functions +here. + +@smallexample +/* Data lookups between C and Scheme + + Look up a symbol with a given name, and return the object to which + it is bound. gh_lookup examines the Guile top level, and + gh_module_lookup checks the module namespace specified by the + `vec' argument. + + The return value is the Scheme object to which SNAME is bound, or + SCM_UNDEFINED if SNAME is not bound in the given context. [FIXME: + should this be SCM_UNSPECIFIED? Can a symbol ever legitimately be + bound to SCM_UNDEFINED or SCM_UNSPECIFIED? What is the difference? + -twp] */ +@end smallexample + + +@page +@node Mixing gh and scm APIs +@section Mixing gh and scm APIs diff --git a/doc/goops-tutorial.texi b/doc/goops-tutorial.texi new file mode 100644 index 000000000..7897b9f40 --- /dev/null +++ b/doc/goops-tutorial.texi @@ -0,0 +1,809 @@ +@c Original attribution: + +@c +@c STk Reference manual (Appendix: An Introduction to STklos) +@c +@c Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI +@c Permission to use, copy, modify, distribute,and license this +@c software and its documentation for any purpose is hereby granted, +@c provided that existing copyright notices are retained in all +@c copies and that this notice is included verbatim in any +@c distributions. No written agreement, license, or royalty fee is +@c required for any of the authorized uses. +@c This software is provided ``AS IS'' without express or implied +@c warranty. +@c + +@c Adapted for use in Guile with the authors permission + +@c @macro goops @c was {\stklos} +@c GOOPS +@c @end macro + +@c @macro guile @c was {\stk} +@c Guile +@c @end macro + +This is chapter was originally written by Erick Gallesio as an appendix +for the STk reference manual, and subsequently adapted to @goops{}. + +@menu +* Copyright:: +* Intro:: +* Class definition and instantiation:: +* Inheritance:: +* Generic functions:: +@end menu + +@node Copyright, Intro, Tutorial, Tutorial +@section Copyright + +Original attribution: + +STk Reference manual (Appendix: An Introduction to STklos) + +Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI +Permission to use, copy, modify, distribute,and license this +software and its documentation for any purpose is hereby granted, +provided that existing copyright notices are retained in all +copies and that this notice is included verbatim in any +distributions. No written agreement, license, or royalty fee is +required for any of the authorized uses. +This software is provided ``AS IS'' without express or implied +warranty. + +Adapted for use in Guile with the authors permission + +@node Intro, Class definition and instantiation, Copyright, Tutorial +@section Introduction + +@goops{} is the object oriented extension to @guile{}. Its +implementation is derived from @w{STk-3.99.3} by Erick Gallesio and +version 1.3 of the Gregor Kiczales @cite{Tiny-Clos}. It is very close +to CLOS, the Common Lisp Object System (@cite{CLtL2}) but is adapted for +the Scheme language. + +Briefly stated, the @goops{} extension gives the user a full object +oriented system with multiple inheritance and generic functions with +multi-method dispatch. Furthermore, the implementation relies on a true +meta object protocol, in the spirit of the one defined for CLOS +(@cite{Gregor Kiczales: A Metaobject Protocol}). + +The purpose of this tutorial is to introduce briefly the @goops{} +package and in no case will it replace the @goops{} reference manual +(which needs to be urgently written now@ @dots{}). + +Note that the operations described in this tutorial resides in modules +that may need to be imported before being available. The main module is +imported by evaluating: + +@lisp +(use-modules (oop goops)) +@end lisp +@findex (oop goops) +@cindex main module +@cindex loading +@cindex preparing + +@node Class definition and instantiation, Inheritance, Intro, Tutorial +@section Class definition and instantiation + +@menu +* Class definition:: +@end menu + +@node Class definition, , Class definition and instantiation, Class definition and instantiation +@subsection Class definition + +A new class is defined with the @code{define-class}@footnote{Don't +forget to import the @code{(oop goops)} module} macro. The syntax of +@code{define-class} is close to CLOS @code{defclass}: + +@findex define-class +@cindex class +@lisp +(define-class @var{class} (@var{superclass} @dots{}) + @var{slot-description} @dots{} + @var{class-option} @dots{}) +@end lisp + +Class options will not be discussed in this tutorial. The list of +@var{superclass}es specifies which classes to inherit properties from +@var{class} (see @ref{Inheritance} for more details). A +@var{slot-description} gives the name of a slot and, eventually, some +``properties'' of this slot (such as its initial value, the function +which permit to access its value, @dots{}). Slot descriptions will be +discussed in @ref{Slot description}. +@cindex slot + +As an example, let us define a type for representation of complex +numbers in terms of real numbers. This can be done with the following +class definition: + +@lisp +(define-class () + r i) +@end lisp + +This binds the variable @code{}@footnote{@code{} is in +fact a builtin class in GOOPS. Because of this, GOOPS will create a new +class. The old class will still serve as the type for Guile's native +complex numbers.} to a new class whose instances contain two +slots. These slots are called @code{r} an @code{i} and we suppose here +that they contain respectively the real part and the imaginary part of a +complex number. Note that this class inherits from @code{} which +is a pre-defined class. (@code{} is the direct super class of +the pre-defined class @code{} which, in turn, is the super +class of @code{} which is the super of +@code{}.)@footnote{With the new definition of @code{}, +a @code{} is not a @code{} since @code{} inherits +from @code{ } rather than @code{}. In practice, +inheritance could be modified @emph{a posteriori}, if needed. However, +this necessitates some knowledge of the meta object protocol and it will +not be shown in this document}. + +@node Inheritance, Generic functions, Class definition and instantiation, Tutorial +@section Inheritance +@c \label{inheritance} + +@menu +* Class hierarchy and inheritance of slots:: +* Instance creation and slot access:: +* Slot description:: +* Class precedence list:: +@end menu + +@node Class hierarchy and inheritance of slots, Instance creation and slot access, Inheritance, Inheritance +@subsection Class hierarchy and inheritance of slots +Inheritance is specified upon class definition. As said in the +introduction, @goops{} supports multiple inheritance. Here are some +class definitions: + +@lisp +(define-class A () a) +(define-class B () b) +(define-class C () c) +(define-class D (A B) d a) +(define-class E (A C) e c) +(define-class F (D E) f) +@end lisp + +@code{A}, @code{B}, @code{C} have a null list of super classes. In this +case, the system will replace it by the list which only contains +@code{}, the root of all the classes defined by +@code{define-class}. @code{D}, @code{E}, @code{F} use multiple +inheritance: each class inherits from two previously defined classes. +Those class definitions define a hierarchy which is shown in Figure@ 1. +In this figure, the class @code{} is also shown; this class is the +super class of all Scheme objects. In particular, @code{} is the +super class of all standard Scheme types. + +@example +@group +@image{hierarchy} +@center @emph{Fig 1: A class hierarchy} +@iftex +@emph{(@code{} which is the direct subclass of @code{} +and the direct superclass of @code{} has been omitted in this +figure.)} +@end iftex +@end group +@end example + +The set of slots of a given class is calculated by taking the union of the +slots of all its super class. For instance, each instance of the class +D, defined before will have three slots (@code{a}, @code{b} and +@code{d}). The slots of a class can be obtained by the @code{class-slots} +primitive. For instance, + +@lisp +(class-slots A) @result{} ((a)) +(class-slots E) @result{} ((a) (e) (c)) +(class-slots F) @result{} ((e) (c) (b) (d) (a) (f)) +@c used to be ((d) (a) (b) (c) (f)) +@end lisp + +@emph{Note: } The order of slots is not significant. + +@node Instance creation and slot access, Slot description, Class hierarchy and inheritance of slots, Inheritance +@subsection Instance creation and slot access + +Creation of an instance of a previously defined +class can be done with the @code{make} procedure. This +procedure takes one mandatory parameter which is the class of the +instance which must be created and a list of optional +arguments. Optional arguments are generally used to initialize some +slots of the newly created instance. For instance, the following form + +@findex make +@cindex instance +@lisp +(define c (make )) +@end lisp + +will create a new @code{} object and will bind it to the @code{c} +Scheme variable. + +Accessing the slots of the new complex number can be done with the +@code{slot-ref} and the @code{slot-set!} primitives. @code{Slot-set!} +primitive permits to set the value of an object slot and @code{slot-ref} +permits to get its value. + +@findex slot-set! +@findex slot-ref +@lisp +@group +(slot-set! c 'r 10) +(slot-set! c 'i 3) +(slot-ref c 'r) @result{} 10 +(slot-ref c 'i) @result{} 3 +@end group +@end lisp + +Using the @code{describe} function is a simple way to see all the +slots of an object at one time: this function prints all the slots of an +object on the standard output. + +First load the module @code{(oop goops describe)}: + +@example +@code{(use-modules (oop goops describe))} +@end example + +The expression + +@smalllisp +(describe c) +@end smalllisp + +will now print the following information on the standard output: + +@lisp +#< 401d8638> is an instance of class +Slots are: + r = 10 + i = 3 +@end lisp + +@node Slot description, Class precedence list, Instance creation and slot access, Inheritance +@subsection Slot description +@c \label{slot-description} + +When specifying a slot, a set of options can be given to the +system. Each option is specified with a keyword. The list of authorized +keywords is given below: + +@cindex keyword +@itemize @bullet +@item +@code{#:init-value} permits to supply a default value for the slot. This +default value is obtained by evaluating the form given after the +@code{#:init-form} in the global environment, at class definition time. +@cindex default slot value +@findex #:init-value +@cindex top level environment + +@item +@code{#:init-thunk} permits to supply a thunk that will provide a +default value for the slot. The value is obtained by evaluating the +thunk a instance creation time. +@c CHECKME: in the global environment? +@findex default slot value +@findex #:init-thunk +@cindex top level environment + +@item +@code{#:init-keyword} permits to specify the keyword for initializing a +slot. The init-keyword may be provided during instance creation (i.e. in +the @code{make} optional parameter list). Specifying such a keyword +during instance initialization will supersede the default slot +initialization possibly given with @code{#:init-form}. +@findex #:init-keyword + +@item +@code{#:getter} permits to supply the name for the +slot getter. The name binding is done in the +environment of the @code{define-class} macro. +@findex #:getter +@cindex top level environment +@cindex getter + +@item +@code{#:setter} permits to supply the name for the +slot setter. The name binding is done in the +environment of the @code{define-class} macro. +@findex #:setter +@cindex top level environment +@cindex setter + +@item +@code{#:accessor} permits to supply the name for the +slot accessor. The name binding is done in the global +environment. An accessor permits to get and +set the value of a slot. Setting the value of a slot is done with the extended +version of @code{set!}. +@findex set! +@findex #:accessor +@cindex top level environment +@cindex accessor + +@item +@code{#:allocation} permits to specify how storage for +the slot is allocated. Three kinds of allocation are provided. +They are described below: + +@itemize @minus +@item +@code{#:instance} indicates that each instance gets its own storage for +the slot. This is the default. +@item +@code{#:class} indicates that there is one storage location used by all +the direct and indirect instances of the class. This permits to define a +kind of global variable which can be accessed only by (in)direct +instances of the class which defines this slot. +@item +@code{#:each-subclass} indicates that there is one storage location used +by all the direct instances of the class. In other words, if two classes +are not siblings in the class hierarchy, they will not see the same +value. +@item +@code{#:virtual} indicates that no storage will be allocated for this +slot. It is up to the user to define a getter and a setter function for +this slot. Those functions must be defined with the @code{#:slot-ref} +and @code{#:slot-set!} options. See the example below. +@findex #:slot-set! +@findex #:slot-ref +@findex #:virtual +@findex #:class +@findex #:each-subclass +@findex #:instance +@findex #:allocation +@end itemize +@end itemize + +To illustrate slot description, we shall redefine the @code{} class +seen before. A definition could be: + +@lisp +(define-class () + (r #:init-value 0 #:getter get-r #:setter set-r! #:init-keyword #:r) + (i #:init-value 0 #:getter get-i #:setter set-i! #:init-keyword #:i)) +@end lisp + +With this definition, the @code{r} and @code{i} slot are set to 0 by +default. Value of a slot can also be specified by calling @code{make} +with the @code{#:r} and @code{#:i} keywords. Furthermore, the generic +functions @code{get-r} and @code{set-r!} (resp. @code{get-i} and +@code{set-i!}) are automatically defined by the system to read and write +the @code{r} (resp. @code{i}) slot. + +@lisp +(define c1 (make #:r 1 #:i 2)) +(get-r c1) @result{} 1 +(set-r! c1 12) +(get-r c1) @result{} 12 +(define c2 (make #:r 2)) +(get-r c2) @result{} 2 +(get-i c2) @result{} 0 +@end lisp + +Accessors provide an uniform access for reading and writing an object +slot. Writing a slot is done with an extended form of @code{set!} +which is close to the Common Lisp @code{setf} macro. So, another +definition of the previous @code{} class, using the +@code{#:accessor} option, could be: + +@findex set! +@lisp +(define-class () + (r #:init-value 0 #:accessor real-part #:init-keyword #:r) + (i #:init-value 0 #:accessor imag-part #:init-keyword #:i)) +@end lisp + +Using this class definition, reading the real part of the @code{c} +complex can be done with: +@lisp +(real-part c) +@end lisp +and setting it to the value contained in the @code{new-value} variable +can be done using the extended form of @code{set!}. +@lisp +(set! (real-part c) new-value) +@end lisp + +Suppose now that we have to manipulate complex numbers with rectangular +coordinates as well as with polar coordinates. One solution could be to +have a definition of complex numbers which uses one particular +representation and some conversion functions to pass from one +representation to the other. A better solution uses virtual slots. A +complete definition of the @code{} class using virtual slots is +given in Figure@ 2. + +@example +@group +@lisp +(define-class () + ;; True slots use rectangular coordinates + (r #:init-value 0 #:accessor real-part #:init-keyword #:r) + (i #:init-value 0 #:accessor imag-part #:init-keyword #:i) + ;; Virtual slots access do the conversion + (m #:accessor magnitude #:init-keyword #:magn + #:allocation #:virtual + #:slot-ref (lambda (o) + (let ((r (slot-ref o 'r)) (i (slot-ref o 'i))) + (sqrt (+ (* r r) (* i i))))) + #:slot-set! (lambda (o m) + (let ((a (slot-ref o 'a))) + (slot-set! o 'r (* m (cos a))) + (slot-set! o 'i (* m (sin a)))))) + (a #:accessor angle #:init-keyword #:angle + #:allocation #:virtual + #:slot-ref (lambda (o) + (atan (slot-ref o 'i) (slot-ref o 'r))) + #:slot-set! (lambda(o a) + (let ((m (slot-ref o 'm))) + (slot-set! o 'r (* m (cos a))) + (slot-set! o 'i (* m (sin a))))))) + +@end lisp +@center @emph{Fig 2: A @code{} number class definition using virtual slots} +@end group +@end example + +@sp 3 +This class definition implements two real slots (@code{r} and +@code{i}). Values of the @code{m} and @code{a} virtual slots are +calculated from real slot values. Reading a virtual slot leads to the +application of the function defined in the @code{#:slot-ref} +option. Writing such a slot leads to the application of the function +defined in the @code{#:slot-set!} option. For instance, the following +expression + +@findex #:slot-set! +@findex #:slot-ref +@lisp +(slot-set! c 'a 3) +@end lisp + +permits to set the angle of the @code{c} complex number. This expression +conducts, in fact, to the evaluation of the following expression + +@lisp +((lambda o m) + (let ((m (slot-ref o 'm))) + (slot-set! o 'r (* m (cos a))) + (slot-set! o 'i (* m (sin a)))) + c 3) +@end lisp + +A more complete example is given below: + +@example +@group +@lisp +(define c (make #:r 12 #:i 20)) +(real-part c) @result{} 12 +(angle c) @result{} 1.03037682652431 +(slot-set! c 'i 10) +(set! (real-part c) 1) +(describe c) @result{} + #< 401e9b58> is an instance of class + Slots are: + r = 1 + i = 10 + m = 10.0498756211209 + a = 1.47112767430373 +@end lisp +@end group +@end example + +Since initialization keywords have been defined for the four slots, we +can now define the @code{make-rectangular} and @code{make-polar} standard +Scheme primitives. + +@lisp +(define make-rectangular + (lambda (x y) (make #:r x #:i y))) + +(define make-polar + (lambda (x y) (make #:magn x #:angle y))) +@end lisp + +@node Class precedence list, , Slot description, Inheritance +@subsection Class precedence list + +A class may have more than one superclass. @footnote{This section is an +adaptation of Jeff Dalton's (J.Dalton@@ed.ac.uk) @cite{Brief +introduction to CLOS}} With single inheritance (one superclass), it is +easy to order the super classes from most to least specific. This is the +rule: + +@display +@cartouche +Rule 1: Each class is more specific than its superclasses.@c was \bf +@end cartouche +@end display + +With multiple inheritance, ordering is harder. Suppose we have + +@lisp +(define-class X () + (x #:init-value 1)) + +(define-class Y () + (x #:init-value 2)) + +(define-class Z (X Y) + (@dots{})) +@end lisp + +In this case, the @code{Z} class is more specific than the @code{X} or +@code{Y} class for instances of @code{Z}. However, the @code{#:init-value} +specified in @code{X} and @code{Y} leads to a problem: which one +overrides the other? The rule in @goops{}, as in CLOS, is that the +superclasses listed earlier are more specific than those listed later. +So: + +@display +@cartouche +Rule 2: For a given class, superclasses listed earlier are more + specific than those listed later. +@end cartouche +@end display + +These rules are used to compute a linear order for a class and all its +superclasses, from most specific to least specific. This order is +called the ``class precedence list'' of the class. Given these two +rules, we can claim that the initial form for the @code{x} slot of +previous example is 1 since the class @code{X} is placed before @code{Y} +in class precedence list of @code{Z}. + +These two rules are not always enough to determine a unique order, +however, but they give an idea of how things work. Taking the @code{F} +class shown in Figure@ 1, the class precedence list is + +@example +(f d e a c b ) +@end example + +However, it is usually considered a bad idea for programmers to rely on +exactly what the order is. If the order for some superclasses is important, +it can be expressed directly in the class definition. + +The precedence list of a class can be obtained by the function +@code{class-precedence-list}. This function returns a ordered +list whose first element is the most specific class. For instance, + +@lisp +(class-precedence-list B) @result{} (#< B 401b97c8> + #< 401e4a10> + #< 4026a9d8>) +@end lisp + +However, this result is not too much readable; using the function +@code{class-name} yields a clearer result: + +@lisp +(map class-name (class-precedence-list B)) @result{} (B ) +@end lisp + +@node Generic functions, , Inheritance, Tutorial +@section Generic functions + +@menu +* Generic functions and methods:: +* Next-method:: +* Example:: +@end menu + +@node Generic functions and methods, Next-method, Generic functions, Generic functions +@subsection Generic functions and methods + +@c \label{gf-n-methods} +Neither @goops{} nor CLOS use the message mechanism for methods as most +Object Oriented language do. Instead, they use the notion of +@dfn{generic functions}. A generic function can be seen as a methods +``tanker''. When the evaluator requested the application of a generic +function, all the methods of this generic function will be grabbed and +the most specific among them will be applied. We say that a method +@var{M} is @emph{more specific} than a method @var{M'} if the class of +its parameters are more specific than the @var{M'} ones. To be more +precise, when a generic function must be ``called'' the system will: + +@cindex generic function +@enumerate +@item +search among all the generic function those which are applicable +@item +sort the list of applicable methods in the ``most specific'' order +@item +call the most specific method of this list (i.e. the first method of +the sorted methods list). +@end enumerate + +The definition of a generic function is done with the +@code{define-generic} macro. Definition of a new method is done with the +@code{define-method} macro. Note that @code{define-method} automatically +defines the generic function if it has not been defined +before. Consequently, most of the time, the @code{define-generic} needs +not be used. +@findex define-generic +@findex define-method +Consider the following definitions: + +@lisp +(define-generic G) +(define-method G ((a ) b) 'integer) +(define-method G ((a ) b) 'real) +(define-method G (a b) 'top) +@end lisp + +The @code{define-generic} call defines @var{G} as a generic +function. Note that the signature of the generic function is not given +upon definition, contrarily to CLOS. This will permit methods with +different signatures for a given generic function, as we shall see +later. The three next lines define methods for the @var{G} generic +function. Each method uses a sequence of @dfn{parameter specializers} +that specify when the given method is applicable. A specializer permits +to indicate the class a parameter must belong to (directly or +indirectly) to be applicable. If no specializer is given, the system +defaults it to @code{}. Thus, the first method definition is +equivalent to + +@cindex parameter specializers +@lisp +(define-method G ((a ) (b )) 'integer) +@end lisp + +Now, let us look at some possible calls to generic function @var{G}: + +@lisp +(G 2 3) @result{} integer +(G 2 #t) @result{} integer +(G 1.2 'a) @result{} real +@c (G #3 'a) @result{} real @c was {\sharpsign} +(G #t #f) @result{} top +(G 1 2 3) @result{} error (since no method exists for 3 parameters) +@end lisp + +The preceding methods use only one specializer per parameter list. Of +course, each parameter can use a specializer. In this case, the +parameter list is scanned from left to right to determine the +applicability of a method. Suppose we declare now + +@lisp +(define-method G ((a ) (b )) 'integer-number) +(define-method G ((a ) (b )) 'integer-real) +(define-method G ((a ) (b )) 'integer-integer) +(define-method G (a (b )) 'top-number) +@end lisp + +In this case, + +@lisp +(G 1 2) @result{} integer-integer +(G 1 1.0) @result{} integer-real +(G 1 #t) @result{} integer +(G 'a 1) @result{} top-number +@end lisp + +@node Next-method, Example, Generic functions and methods, Generic functions +@subsection Next-method + +When a generic function is called, the list of applicable methods is +built. As mentioned before, the most specific method of this list is +applied (see@ @ref{Generic functions and methods}). This method may call +the next method in the list of applicable methods. This is done by using +the special form @code{next-method}. Consider the following definitions + +@lisp +(define-method Test ((a )) (cons 'integer (next-method))) +(define-method Test ((a )) (cons 'number (next-method))) +(define-method Test (a) (list 'top)) +@end lisp + +With those definitions, + +@lisp +(Test 1) @result{} (integer number top) +(Test 1.0) @result{} (number top) +(Test #t) @result{} (top) +@end lisp + +@node Example, , Next-method, Generic functions +@subsection Example + +In this section we shall continue to define operations on the @code{} +class defined in Figure@ 2. Suppose that we want to use it to implement +complex numbers completely. For instance a definition for the addition of +two complexes could be + +@lisp +(define-method new-+ ((a ) (b )) + (make-rectangular (+ (real-part a) (real-part b)) + (+ (imag-part a) (imag-part b)))) +@end lisp + +To be sure that the @code{+} used in the method @code{new-+} is the standard +addition we can do: + +@lisp +(define-generic new-+) + +(let ((+ +)) + (define-method new-+ ((a ) (b )) + (make-rectangular (+ (real-part a) (real-part b)) + (+ (imag-part a) (imag-part b))))) +@end lisp + +The @code{define-generic} ensures here that @code{new-+} will be defined +in the global environment. Once this is done, we can add methods to the +generic function @code{new-+} which make a closure on the @code{+} +symbol. A complete writing of the @code{new-+} methods is shown in +Figure@ 3. + +@example +@group +@lisp +(define-generic new-+) + +(let ((+ +)) + + (define-method new-+ ((a ) (b )) (+ a b)) + + (define-method new-+ ((a ) (b )) + (make-rectangular (+ a (real-part b)) (imag-part b))) + + (define-method new-+ ((a ) (b )) + (make-rectangular (+ (real-part a) b) (imag-part a))) + + (define-method new-+ ((a ) (b )) + (make-rectangular (+ (real-part a) (real-part b)) + (+ (imag-part a) (imag-part b)))) + + (define-method new-+ ((a )) a) + + (define-method new-+ () 0) + + (define-method new-+ args (new-+ (car args) + (apply new-+ (cdr args))))) + +(set! + new-+) +@end lisp + +@center @emph{Fig 3: Extending @code{+} for dealing with complex numbers} +@end group +@end example + +@sp 3 +We use here the fact that generic function are not obliged to have the +same number of parameters, contrarily to CLOS. The four first methods +implement the dyadic addition. The fifth method says that the addition +of a single element is this element itself. The sixth method says that +using the addition with no parameter always return 0. The last method +takes an arbitrary number of parameters@footnote{The third parameter of +a @code{define-method} is a parameter list which follow the conventions +used for lambda expressions. In particular it can use the dot notation +or a symbol to denote an arbitrary number of parameters}. This method +acts as a kind of @code{reduce}: it calls the dyadic addition on the +@emph{car} of the list and on the result of applying it on its rest. To +finish, the @code{set!} permits to redefine the @code{+} symbol to our +extended addition. + +@sp 3 +To terminate our implementation (integration?) of complex numbers, we can +redefine standard Scheme predicates in the following manner: + +@lisp +(define-method complex? (c ) #t) +(define-method complex? (c) #f) + +(define-method number? (n ) #t) +(define-method number? (n) #f) +@dots{} +@dots{} +@end lisp + +Standard primitives in which complex numbers are involved could also be +redefined in the same manner. + diff --git a/doc/goops.texi b/doc/goops.texi new file mode 100644 index 000000000..918b4697a --- /dev/null +++ b/doc/goops.texi @@ -0,0 +1,2798 @@ +\input texinfo +@c -*-texinfo-*- +@c %**start of header +@setfilename goops.info +@settitle Goops Manual +@setchapternewpage odd +@paragraphindent 0 +@c %**end of header + +@set VERSION 0.2 + +@dircategory The Algorithmic Language Scheme +@direntry +* GOOPS: (goops). The GOOPS reference manual. +@end direntry + +@macro goops +GOOPS +@end macro + +@macro guile +Guile +@end macro + +@ifinfo +This file documents GOOPS, an object oriented extension for Guile. + +Copyright (C) 1999, 2000 Free Software Foundation + +Permission is granted to make and distribute verbatim copies of +this manual provided the copyright notice and this permission notice +are preserved on all copies. + +@end ifinfo + +@c This title page illustrates only one of the +@c two methods of forming a title page. + +@titlepage +@title Goops Manual +@subtitle For use with GOOPS @value{VERSION} +@author Christian Lynbech +@author @email{chl@@tbit.dk} +@author +@author Mikael Djurfeldt +@author @email{djurfeldt@@nada.kth.se} +@author +@author Neil Jerram +@author @email{neil@@ossau.uklinux.net} + +@c The following two commands +@c start the copyright page. +@page +@vskip 0pt plus 1filll +Copyright @copyright{} 1999 Free Software Foundation + +Permission is granted to make and distribute verbatim copies of +this manual provided the copyright notice and this permission notice +are preserved on all copies. + +@end titlepage + +@node Top, Introduction, (dir), (dir) + +@menu +[When the manual is completed, this will be a flat index in the style of + the Emacs manual. More nodes will turn up under parts I-III.] + +Part I: Preliminaries + +* Introduction:: +* Getting Started:: + +Part II: Reference Manual + +* Reference Manual:: + +Part III: GOOPS Meta Object Protocol + +* MOP Specification:: + +The GOOPS tutorial + +* Tutorial:: + +* Index:: +* Concept Index:: +* Function and Variable Index:: +@end menu + +@iftex +@chapter Preliminaries +@end iftex + +@node Introduction, Getting Started, Top, Top +@section Introduction + +@goops{} is the object oriented extension to @guile{}. Its +implementation is derived from @w{STk-3.99.3} by Erick Gallesio and +version 1.3 of Gregor Kiczales @cite{Tiny-Clos}. It is very close in +spirit to CLOS, the Common Lisp Object System (@cite{CLtL2}) but is +adapted for the Scheme language. While GOOPS is not compatible with any +of these systems, GOOPS contains a compatibility module which allows for +execution of STKlos programs. + +Briefly stated, the @goops{} extension gives the user a full object +oriented system with multiple inheritance and generic functions with +multi-method dispatch. Furthermore, the implementation relies on a true +meta object protocol, in the spirit of the one defined for CLOS +(@cite{Gregor Kiczales: A Metaobject Protocol}). + +@node Getting Started, Reference Manual, Introduction, Top +@section Getting Started + +@menu +* Running GOOPS:: + +Examples of some basic GOOPS functionality. + +* Methods:: +* User-defined types:: +* Asking for the type of an object:: + +See further in the GOOPS tutorial available in this distribution in +info (goops.info) and texinfo format. +@end menu + +@node Running GOOPS, Methods, Getting Started, Getting Started +@subsection Running GOOPS + +@enumerate +@item +Type + +@smalllisp +guile-oops +@end smalllisp + +You should now be at the Guile prompt ("guile> "). + +@item +Type + +@smalllisp +(use-modules (oop goops)) +@end smalllisp + +to load GOOPS. (If your system supports dynamic loading, you +should be able to do this not only from `guile-oops' but from an +arbitrary Guile interpreter.) +@end enumerate + +We're now ready to try some basic GOOPS functionality. + +@node Methods, User-defined types, Running GOOPS, Getting Started +@subsection Methods + +@smalllisp +@group +(define-method + ((x ) (y )) + (string-append x y)) + +(+ 1 2) --> 3 +(+ "abc" "de") --> "abcde" +@end group +@end smalllisp + +@node User-defined types, Asking for the type of an object, Methods, Getting Started +@subsection User-defined types + +@smalllisp +(define-class <2D-vector> () + (x #:init-value 0 #:accessor x-component #:init-keyword #:x) + (y #:init-value 0 #:accessor y-component #:init-keyword #:y)) + +@group +(use-modules (ice-9 format)) + +(define-method write ((obj <2D-vector>) port) + (display (format #f "<~S, ~S>" (x-component obj) (y-component obj)) + port)) + +(define v (make <2D-vector> #:x 3 #:y 4)) + +v --> <3, 4> +@end group + +@group +(define-method + ((x <2D-vector>) (y <2D-vector>)) + (make <2D-vector> + #:x (+ (x-component x) (x-component y)) + #:y (+ (y-component x) (y-component y)))) + +(+ v v) --> <6, 8> +@end group +@end smalllisp + +@node Asking for the type of an object, , User-defined types, Getting Started +@subsection Types + +@example +(class-of v) --> #< <2D-vector> 40241ac0> +<2D-vector> --> #< <2D-vector> 40241ac0> +(class-of 1) --> #< 401b2a98> + --> #< 401b2a98> + +(is-a? v <2D-vector>) --> #t +@end example + +@node Reference Manual, MOP Specification, Getting Started, Top +@chapter Reference Manual + +This chapter is the GOOPS reference manual. It aims to describe all the +syntax, procedures, options and associated concepts that a typical +application author would need to understand in order to use GOOPS +effectively in their application. It also describes what is meant by +the GOOPS ``metaobject protocol'' (aka ``MOP''), and indicates how +authors can use the metaobject protocol to customize the behaviour of +GOOPS itself. + +For a detailed specification of the GOOPS metaobject protocol, see +@ref{MOP Specification}. + +@menu +* Introductory Remarks:: +* Defining New Classes:: +* Creating Instances:: +* Accessing Slots:: +* Creating Generic Functions:: +* Adding Methods to Generic Functions:: +* Invoking Generic Functions:: +* Redefining a Class:: +* Changing the Class of an Instance:: +* Introspection:: +* Miscellaneous Functions:: +@end menu + +@node Introductory Remarks +@section Introductory Remarks + +GOOPS is an object-oriented programming system based on a ``metaobject +protocol'' derived from the ones used in CLOS (the Common Lisp Object +System), tiny-clos (a small Scheme implementation of a subset of CLOS +functionality) and STKlos. + +GOOPS can be used by application authors at a basic level without any +need to understand what the metaobject protocol (aka ``MOP'') is and how +it works. On the other hand, the MOP underlies even the customizations +that application authors are likely to make use of very quickly --- such +as defining an @code{initialize} method to customize the initialization +of instances of an application-defined class --- and an understanding of +the MOP makes it much easier to explain such customizations in a precise +way. And in the long run, understanding the MOP is the key both to +understanding GOOPS at a deeper level and to taking full advantage of +GOOPS' power, by customizing the behaviour of GOOPS itself. + +Each of the following sections of the reference manual is arranged +such that the most basic usage is introduced first, and then subsequent +subsections discuss the related internal functions and metaobject +protocols, finishing with a description of how to customize that area of +functionality. + +These introductory remarks continue with a few words about metaobjects +and the MOP. Readers who do not want to be bothered yet with the MOP +and customization could safely skip this subsection on a first reading, +and should correspondingly skip subsequent subsections that are +concerned with internals and customization. + +In general, this reference manual assumes familiarity with standard +object oriented concepts and terminology. However, some of the terms +used in GOOPS is less well known, so the Terminology subsection +provides definitions for these terms. + +@menu +* Metaobjects and the Metaobject Protocol:: +* Terminology:: +@end menu + +@node Metaobjects and the Metaobject Protocol +@subsection Metaobjects and the Metaobject Protocol + +The conceptual building blocks of GOOPS are classes, slot definitions, +instances, generic functions and methods. A class is a grouping of +inheritance relations and slot definitions. An instance is an object +with slots that are allocated following the rules implied by its class's +superclasses and slot definitions. A generic function is a collection +of methods and rules for determining which of those methods to apply +when the generic function is invoked. A method is a procedure and a set +of specializers that specify the type of arguments to which the +procedure is applicable. + +Of these entities, GOOPS represents classes, generic functions and +methods as ``metaobjects''. In other words, the values in a GOOPS +program that describe classes, generic functions and methods, are +themselves instances (or ``objects'') of special GOOPS classes that +encapsulate the behaviour, respectively, of classes, generic functions, +and methods. + +(The other two entities are slot definitions and instances. Slot +definitions are not strictly instances, but every slot definition is +associated with a GOOPS class that specifies the behaviour of the slot +as regards accessibility and protection from garbage collection. +Instances are of course objects in the usual sense, and there is no +benefit from thinking of them as metaobjects.) + +The ``metaobject protocol'' (aka ``MOP'') is the specification of the +generic functions which determine the behaviour of these metaobjects and +the circumstances in which these generic functions are invoked. + +For a concrete example of what this means, consider how GOOPS calculates +the set of slots for a class that is being defined using +@code{define-class}. The desired set of slots is the union of the new +class's direct slots and the slots of all its superclasses. But +@code{define-class} itself does not perform this calculation. Instead, +there is a method of the @code{initialize} generic function that is +specialized for instances of type @code{}, and it is this method +that performs the slot calculation. + +@code{initialize} is a generic function which GOOPS calls whenever a new +instance is created, immediately after allocating memory for a new +instance, in order to initialize the new instance's slots. The sequence +of steps is as follows. + +@itemize @bullet +@item +@code{define-class} uses @code{make} to make a new instance of the +@code{}, passing as initialization arguments the superclasses, +slot definitions and class options that were specified in the +@code{define-class} form. + +@item +@code{make} allocates memory for the new instance, and then invokes the +@code{initialize} generic function to initialize the new instance's +slots. + +@item +The @code{initialize} generic function applies the method that is +specialized for instances of type @code{}, and this method +performs the slot calculation. +@end itemize + +In other words, rather than being hardcoded in @code{define-class}, the +behaviour of class definition is encapsulated by generic function +methods that are specialized for the class @code{}. + +It is possible to create a new class that inherits from @code{}, +which is called a ``metaclass'', and to write a new @code{initialize} +method that is specialized for instances of the new metaclass. Then, if +the @code{define-class} form includes a @code{#:metaclass} class option +whose value is the new metaclass, the class that is defined by the +@code{define-class} form will be an instance of the new metaclass rather +than of the default @code{}, and will be defined in accordance +with the new @code{initialize} method. Thus the default slot +calculation, as well as any other aspect of the new class's relationship +with its superclasses, can be modified or overridden. + +In a similar way, the behaviour of generic functions can be modified or +overridden by creating a new class that inherits from the standard +generic function class @code{}, writing appropriate methods +that are specialized to the new class, and creating new generic +functions that are instances of the new class. + +The same is true for method metaobjects. And the same basic mechanism +allows the application class author to write an @code{initialize} method +that is specialized to their application class, to initialize instances +of that class. + +Such is the power of the MOP. Note that @code{initialize} is just one +of a large number of generic functions that can be customized to modify +the behaviour of application objects and classes and of GOOPS itself. +Each subsequent section of the reference manual covers a particular area +of GOOPS functionality, and describes the generic functions that are +relevant for customization of that area. + +We conclude this subsection by emphasizing a point that may seem +obvious, but contrasts with the corresponding situation in some other +MOP implementations, such as CLOS. The point is simply that an +identifier which represents a GOOPS class or generic function is a +variable with a first-class value, the value being an instance of class +@code{} or @code{}. (In CLOS, on the other hand, a +class identifier is a symbol that indexes the corresponding class +metaobject in a separate namespace for classes.) This is, of course, +simply an extension of the tendency in Scheme to avoid the unnecessary +use of, on the one hand, syntactic forms that require unevaluated +arguments and, on the other, separate identifier namespaces (e.g. for +class names), but it is worth noting that GOOPS conforms fully to this +Schemely principle. + +@node Terminology +@subsection Terminology + +It is assumed that the reader is already familiar with standard object +orientation concepts such as classes, objects/instances, +inheritance/subclassing, generic functions and methods, encapsulation +and polymorphism. + +This section explains some of the less well known concepts and +terminology that GOOPS uses, which are assumed by the following sections +of the reference manual. + +@menu +* Metaclass:: +* Class Precedence List:: +* Accessor:: +@end menu + +@node Metaclass +@subsubsection Metaclass + +A @dfn{metaclass} is the class of an object which represents a GOOPS +class. Put more succinctly, a metaclass is a class's class. + +Most GOOPS classes have the metaclass @code{} and, by default, +any new class that is created using @code{define-class} has the +metaclass @code{}. + +But what does this really mean? To find out, let's look in more detail +at what happens when a new class is created using @code{define-class}: + +@example +(define-class () . slots) +@end example + +GOOPS actually expands the @code{define-class} form to something like +this + +@example +(define (class () . slots)) +@end example + +and thence to + +@example +(define + (make #:supers (list ) #:slots slots)) +@end example + +In other words, the value of @code{} is in fact an instance of +the class @code{} with slot values specifying the superclasses +and slot definitions for the class @code{}. (@code{#:supers} +and @code{#:slots} are initialization keywords for the @code{dsupers} +and @code{dslots} slots of the @code{} class.) + +In order to take advantage of the full power of the GOOPS metaobject +protocol (@pxref{MOP Specification}), it is sometimes desirable to +create a new class with a metaclass other than the default +@code{}. This is done by writing: + +@example +(define-class () + slot @dots{} + #:metaclass ) +@end example + +GOOPS expands this to something like: + +@example +(define + (make #:supers (list ) #:slots slots)) +@end example + +In this case, the value of @code{} is an instance of the more +specialized class @code{}. Note that +@code{} itself must previously have been defined as a +subclass of @code{}. For a full discussion of when and how it is +useful to define new metaclasses, see @ref{MOP Specification}. + +Now let's make an instance of @code{}: + +@example +(define my-object (make ...)) +@end example + +All of the following statements are correct expressions of the +relationships between @code{my-object}, @code{}, +@code{} and @code{}. + +@itemize @bullet +@item +@code{my-object} is an instance of the class @code{}. + +@item +@code{} is an instance of the class @code{}. + +@item +@code{} is an instance of the class @code{}. + +@item +The class of @code{my-object} is @code{}. + +@item +The metaclass of @code{my-object} is @code{}. + +@item +The class of @code{} is @code{}. + +@item +The metaclass of @code{} is @code{}. + +@item +The class of @code{} is @code{}. + +@item +The metaclass of @code{} is @code{}. + +@item +@code{} is not a metaclass, since it is does not inherit from +@code{}. + +@item +@code{} is a metaclass, since it inherits from +@code{}. +@end itemize + +@node Class Precedence List +@subsubsection Class Precedence List + +The @dfn{class precedence list} of a class is the list of all direct and +indirect superclasses of that class, including the class itself. + +In the absence of multiple inheritance, the class precedence list is +ordered straightforwardly, beginning with the class itself and ending +with @code{}. + +For example, given this inheritance hierarchy: + +@example +(define-class () @dots{}) +(define-class () @dots{}) +(define-class () @dots{}) +@end example + +the class precedence list of would be + +@example +( ) +@end example + +With multiple inheritance, the algorithm is a little more complicated. +A full description is provided by the GOOPS Tutorial: see @ref{Class +precedence list}. + +``Class precedence list'' is often abbreviated, in documentation and +Scheme variable names, to @dfn{cpl}. + +@node Accessor +@subsubsection Accessor + +An @dfn{accessor} is a generic function with both reference and setter +methods. + +@example +(define-accessor perimeter) +@end example + +Reference methods for an accessor are defined in the same way as generic +function methods. + +@example +(define-method perimeter ((s )) + (* 4 (side-length s))) +@end example + +Setter methods for an accessor are defined by specifying ``(setter +)'' as the first parameter of the @code{define-method} +call. + +@example +(define-method (setter perimeter) ((s ) (n )) + (set! (side-length s) (/ n 4))) +@end example + +Once an appropriate setter method has been defined in this way, it can +be invoked using the generalized @code{set!} syntax, as in: + +@example +(set! (perimeter s1) 18.3) +@end example + +@node Defining New Classes +@section Defining New Classes + +[ *fixme* Somewhere in this manual there needs to be an introductory +discussion about GOOPS classes, generic functions and methods, covering + +@itemize @bullet +@item +how classes encapsulate related items of data in @dfn{slots} + +@item +why it is that, unlike in C++ and Java, a class does not encapsulate the +methods that act upon the class (at least not in the C++/Java sense) + +@item +how generic functions provide a more general solution that provides for +dispatch on all argument types, and avoids idiosyncracies like C++'s +friend classes + +@item +how encapsulation in the sense of data- and code-hiding, or of +distinguishing interface from implementation, is treated in Guile as an +orthogonal concept to object orientation, and is the responsibility of +the module system. +@end itemize + +Some of this is covered in the Tutorial chapter, in @ref{Generic +functions and methods} - perhaps the best solution would be to expand +the discussion there. ] + +@menu +* Basic Class Definition:: +* Class Options:: +* Slot Options:: +* Class Definition Internals:: +* Customizing Class Definition:: +* STKlos Compatibility:: +@end menu + +@node Basic Class Definition +@subsection Basic Class Definition + +New classes are defined using the @code{define-class} syntax, with +arguments that specify the classes that the new class should inherit +from, the direct slots of the new class, and any required class options. + +@deffn syntax define-class name (super @dots{}) slot-definition @dots{} . options +Define a class called @var{name} that inherits from @var{super}s, with +direct slots defined by @var{slot-definition}s and class options +@var{options}. The newly created class is bound to the variable name +@var{name} in the current environment. + +Each @var{slot-definition} is either a symbol that names the slot or a +list, + +@example +(@var{slot-name-symbol} . @var{slot-options}) +@end example + +where @var{slot-name-symbol} is a symbol and @var{slot-options} is a +list with an even number of elements. The even-numbered elements of +@var{slot-options} (counting from zero) are slot option keywords; the +odd-numbered elements are the corresponding values for those keywords. + +@var{options} is a similarly structured list containing class option +keywords and corresponding values. +@end deffn + +The standard GOOPS class and slot options are described in the following +subsections: see @ref{Class Options} and @ref{Slot Options}. + +Example 1. Define a class that combines two pre-existing classes by +inheritance but adds no new slots. + +@example +(define-class ( )) +@end example + +Example 2. Define a @code{regular-polygon} class with slots for side +length and number of sides that have default values and can be accessed +via the generic functions @code{side-length} and @code{num-sides}. + +@example +(define-class () + (sl #:init-value 1 #:accessor side-length) + (ns #:init-value 5 #:accessor num-sides)) +@end example + +Example 3. Define a class whose behavior (and that of its instances) is +customized via an application-defined metaclass. + +@example +(define-class () + (s #:init-value #f #:accessor state) + ... + #:metaclass ) +@end example + +@node Class Options +@subsection Class Options + +@deffn {class option} #:metaclass metaclass +The @code{#:metaclass} class option specifies the metaclass of the class +being defined. @var{metaclass} must be a class that inherits from +@code{}. For an introduction to the use of metaclasses, see +@ref{Metaobjects and the Metaobject Protocol} and @ref{Metaclass}. + +If the @code{#:metaclass} option is absent, GOOPS reuses or constructs a +metaclass for the new class by calling @code{ensure-metaclass} +(@pxref{Class Definition Internals,, ensure-metaclass}). +@end deffn + +@deffn {class option} #:name name +The @code{#:name} class option specifies the new class's name. This +name is used to identify the class whenever related objects - the class +itself, its instances and its subclasses - are printed. + +If the @code{#:name} option is absent, GOOPS uses the first argument to +@code{define-class} as the class name. +@end deffn + +@deffn {class option} #:environment environment +*fixme* Not sure about this one, but I think that the +@code{#:environment} option specifies the environment in which the +class's getters and setters are computed and evaluated. + +If the @code{#:environment} option is not specified, the class's +environment defaults to the top-level environment in which the +@code{define-class} form appears. +@end deffn + +@node Slot Options +@subsection Slot Options + +@deffn {slot option} #:allocation allocation +The @code{#:allocation} option tells GOOPS how to allocate storage for +the slot. Possible values for @var{allocation} are + +@itemize @bullet +@item @code{#:instance} + +Indicates that GOOPS should create separate storage for this slot in +each new instance of the containing class (and its subclasses). + +@item @code{#:class} + +Indicates that GOOPS should create storage for this slot that is shared +by all instances of the containing class (and its subclasses). In other +words, a slot in class @var{C} with allocation @code{#:class} is shared +by all @var{instance}s for which @code{(is-a? @var{instance} @var{c})}. + +@item @code{#:each-subclass} + +Indicates that GOOPS should create storage for this slot that is shared +by all @emph{direct} instances of the containing class, and that +whenever a subclass of the containing class is defined, GOOPS should +create a new storage for the slot that is shared by all @emph{direct} +instances of the subclass. In other words, a slot with allocation +@code{#:each-subclass} is shared by all instances with the same +@code{class-of}. + +@item @code{#:virtual} + +Indicates that GOOPS should not allocate storage for this slot. The +slot definition must also include the @code{#:slot-ref} and +@code{#:slot-set!} options to specify how to reference and set the value +for this slot. +@end itemize + +The default value is @code{#:instance}. + +Slot allocation options are processed when defining a new class by the +generic function @code{compute-get-n-set}, which is specialized by the +class's metaclass. Hence new types of slot allocation can be +implemented by defining a new metaclass and a method for +@code{compute-get-n-set} that is specialized for the new metaclass. For +an example of how to do this, see @ref{Customizing Class Definition}. +@end deffn + +@deffn {slot option} #:slot-ref getter +@deffnx {slot option} #:slot-set! setter +The @code{#:slot-ref} and @code{#:slot-set!} options must be specified +if the slot allocation is @code{#:virtual}, and are ignored otherwise. + +@var{getter} should be a closure taking a single @var{instance} parameter +that returns the current slot value. @var{setter} should be a closure +taking two parameters - @var{instance} and @var{new-val} - that sets the +slot value to @var{new-val}. +@end deffn + +@deffn {slot option} #:getter getter +@deffnx {slot option} #:setter setter +@deffnx {slot option} #:accessor accessor +These options, if present, tell GOOPS to create generic function and +method definitions that can be used to get and set the slot value more +conveniently than by using @code{slot-ref} and @code{slot-set!}. + +@var{getter} specifies a generic function to which GOOPS will add a +method for getting the slot value. @var{setter} specifies a generic +function to which GOOPS will add a method for setting the slot value. +@var{accessor} specifies an accessor to which GOOPS will add methods for +both getting and setting the slot value. + +So if a class includes a slot definition like this: + +@example +(c #:getter get-count #:setter set-count #:accessor count) +@end example + +GOOPS defines generic function methods such that the slot value can be +referenced using either the getter or the accessor - + +@example +(let ((current-count (get-count obj))) @dots{}) +(let ((current-count (count obj))) @dots{}) +@end example + +- and set using either the setter or the accessor - + +@example +(set-count obj (+ 1 current-count)) +(set! (count obj) (+ 1 current-count)) +@end example + +Note that + +@itemize @bullet +@item +with an accessor, the slot value is set using the generalized +@code{set!} syntax + +@item +in practice, it is unusual for a slot to use all three of these options: +read-only, write-only and read-write slots would typically use only +@code{#:getter}, @code{#:setter} and @code{#:accessor} options +respectively. +@end itemize + +If the specified names are already bound in the top-level environment to +values that cannot be upgraded to generic functions, those values are +overwritten during evaluation of the @code{define-class} that contains +the slot definition. For details, see @ref{Generic Function Internals,, +ensure-generic}. +@end deffn + +@deffn {slot option} #:init-value init-value +@deffnx {slot option} #:init-form init-form +@deffnx {slot option} #:init-thunk init-thunk +@deffnx {slot option} #:init-keyword init-keyword +These options provide various ways to specify how to initialize the +slot's value at instance creation time. @var{init-value} is a fixed +value. @var{init-thunk} is a procedure of no arguments that is called +when a new instance is created and should return the desired initial +slot value. @var{init-form} is an unevaluated expression that gets +evaluated when a new instance is created and should return the desired +initial slot value. @var{init-keyword} is a keyword that can be used to +pass an initial slot value to @code{make} when creating a new instance. + +If more than one of these options is specified for the same slot, the +order of precedence, highest first is + +@itemize @bullet +@item +@code{#:init-keyword}, if @var{init-keyword} is present in the options +passed to @code{make} + +@item +@code{#:init-thunk}, @code{#:init-form} or @code{#:init-value}. +@end itemize + +If the slot definition contains more than one initialization option of +the same precedence, the later ones are ignored. If a slot is not +initialized at all, its value is unbound. + +In general, slots that are shared between more than one instance are +only initialized at new instance creation time if the slot value is +unbound at that time. However, if the new instance creation specifies +a valid init keyword and value for a shared slot, the slot is +re-initialized regardless of its previous value. + +Note, however, that the power of GOOPS' metaobject protocol means that +everything written here may be customized or overridden for particular +classes! The slot initializations described here are performed by the least +specialized method of the generic function @code{initialize}, whose +signature is + +@example +(define-method initialize ((object ) initargs) ...) +@end example + +The initialization of instances of any given class can be customized by +defining a @code{initialize} method that is specialized for that class, +and the author of the specialized method may decide to call +@code{next-method} - which will result in a call to the next less +specialized @code{initialize} method - at any point within the +specialized code, or maybe not at all. In general, therefore, the +initialization mechanisms described here may be modified or overridden by +more specialized code, or may not be supported at all for particular +classes. +@end deffn + +@node Class Definition Internals +@subsection Class Definition Internals + +Implementation notes: @code{define-class} expands to an expression which + +@itemize @bullet +@item +checks that it is being evaluated only at top level + +@item +defines any accessors that are implied by the @var{slot-definition}s + +@item +uses @code{class} to create the new class (@pxref{Class Definition +Internals,, class}) + +@item +checks for a previous class definition for @var{name} and, if found, +handles the redefinition by invoking @code{class-redefinition} +(@pxref{Redefining a Class}). +@end itemize + +@deffn syntax class name (super @dots{}) slot-definition @dots{} . options +Return a newly created class that inherits from @var{super}s, with +direct slots defined by @var{slot-definition}s and class options +@var{options}. For the format of @var{slot-definition}s and +@var{options}, see @ref{Basic Class Definition,, define-class}. +@end deffn + +Implementation notes: @code{class} expands to an expression which + +@itemize @bullet +@item +processes the class and slot definition options to check that they are +well-formed, to convert the @code{#:init-form} option to an +@code{#:init-thunk} option, to supply a default environment parameter +(the current top-level environment) and to evaluate all the bits that +need to be evaluated + +@item +calls @code{make-class} to create the class with the processed and +evaluated parameters. +@end itemize + +@deffn procedure make-class supers slots . options +Return a newly created class that inherits from @var{supers}, with +direct slots defined by @var{slots} and class options @var{options}. +For the format of @var{slots} and @var{options}, see @ref{Basic Class +Definition,, define-class}, except note that for @code{make-class}, +@var{slots} and @var{options} are separate list parameters: @var{slots} +here is a list of slot definitions. +@end deffn + +Implementation notes: @code{make-class} + +@itemize @bullet +@item +adds @code{} to the @var{supers} list if @var{supers} is empty +or if none of the classes in @var{supers} have @code{} in their +class precedence list + +@item +defaults the @code{#:environment}, @code{#:name} and @code{#:metaclass} +options, if they are not specified by @var{options}, to the current +top-level environment, the unbound value, and @code{(ensure-metaclass +@var{supers})} respectively (@pxref{Class Definition Internals,, +ensure-metaclass}) + +@item +checks for duplicate classes in @var{supers} and duplicate slot names in +@var{slots}, and signals an error if there are any duplicates + +@item +calls @code{make}, passing the metaclass as the first parameter and all +other parameters as option keywords with values. +@end itemize + +@deffn procedure ensure-metaclass supers env +Return a metaclass suitable for a class that inherits from the list of +classes in @var{supers}. The returned metaclass is the union by +inheritance of the metaclasses of the classes in @var{supers}. + +In the simplest case, where all the @var{supers} are straightforward +classes with metaclass @code{}, the returned metaclass is just +@code{}. + +For a more complex example, suppose that @var{supers} contained one +class with metaclass @code{} and one with metaclass +@code{}. Then the returned metaclass would be a +class that inherits from both @code{} and +@code{}. + +If @var{supers} is the empty list, @code{ensure-metaclass} returns the +default GOOPS metaclass @code{}. + +GOOPS keeps a list of the metaclasses created by +@code{ensure-metaclass}, so that each required type of metaclass only +has to be created once. + +The @code{env} parameter is ignored. +@end deffn + +@deffn procedure ensure-metaclass-with-supers meta-supers +@code{ensure-metaclass-with-supers} is an internal procedure used by +@code{ensure-metaclass} (@pxref{Class Definition Internals,, +ensure-metaclass}). It returns a metaclass that is the union by +inheritance of the metaclasses in @var{meta-supers}. +@end deffn + +The internals of @code{make}, which is ultimately used to create the new +class object, are described in @ref{Customizing Instance Creation}, +which covers the creation and initialization of instances in general. + +@node Customizing Class Definition +@subsection Customizing Class Definition + +During the initialization of a new class, GOOPS calls a number of generic +functions with the newly allocated class instance as the first +argument. Specifically, GOOPS calls the generic function + +@itemize @bullet +@item +(initialize @var{class} @dots{}) +@end itemize + +where @var{class} is the newly allocated class instance, and the default +@code{initialize} method for arguments of type @code{} calls the +generic functions + +@itemize @bullet +@item +(compute-cpl @var{class}) + +@item +(compute-slots @var{class}) + +@item +(compute-get-n-set @var{class} @var{slot-def}), for each of the slot +definitions returned by @code{compute-slots} + +@item +(compute-getter-method @var{class} @var{slot-def}), for each of the +slot definitions returned by @code{compute-slots} that includes a +@code{#:getter} or @code{#:accessor} slot option + +@item +(compute-setter-method @var{class} @var{slot-def}), for each of the +slot definitions returned by @code{compute-slots} that includes a +@code{#:setter} or @code{#:accessor} slot option. +@end itemize + +If the metaclass of the new class is something more specialized than the +default @code{}, then the type of @var{class} in the calls above +is more specialized than @code{}, and hence it becomes possible +to define generic function methods, specialized for the new class's +metaclass, that can modify or override the default behaviour of +@code{initialize}, @code{compute-cpl} or @code{compute-get-n-set}. + +@code{compute-cpl} computes the class precedence list (``CPL'') for the +new class (@pxref{Class precedence list}), and returns it as a list of +class objects. The CPL is important because it defines a superclass +ordering that is used, when a generic function is invoked upon an +instance of the class, to decide which of the available generic function +methods is the most specific. Hence @code{compute-cpl} could be +customized in order to modify the CPL ordering algorithm for all classes +with a special metaclass. + +The default CPL algorithm is encapsulated by the @code{compute-std-cpl} +procedure, which is in turn called by the default @code{compute-cpl} +method. + +@deffn procedure compute-std-cpl class +Compute and return the class precedence list for @var{class} according +to the algorithm described in @ref{Class precedence list}. +@end deffn + +@code{compute-slots} computes and returns a list of all slot definitions +for the new class. By default, this list includes the direct slot +definitions from the @code{define-class} form, plus the slot definitions +that are inherited from the new class's superclasses. The default +@code{compute-slots} method uses the CPL computed by @code{compute-cpl} +to calculate this union of slot definitions, with the rule that slots +inherited from superclasses are shadowed by direct slots with the same +name. One possible reason for customizing @code{compute-slots} would be +to implement an alternative resolution strategy for slot name conflicts. + +@code{compute-get-n-set} computes the low-level closures that will be +used to get and set the value of a particular slot, and returns them in +a list with two elements. + +The closures returned depend on how storage for that slot is allocated. +The standard @code{compute-get-n-set} method, specialized for classes of +type @code{}, handles the standard GOOPS values for the +@code{#:allocation} slot option (@pxref{Slot Options,, allocation}). By +defining a new @code{compute-get-n-set} method for a more specialized +metaclass, it is possible to support new types of slot allocation. + +Suppose you wanted to create a large number of instances of some class +with a slot that should be shared between some but not all instances of +that class - say every 10 instances should share the same slot storage. +The following example shows how to implement and use a new type of slot +allocation to do this. + +@example +(define-class ()) + +(let ((batch-allocation-count 0) + (batch-get-n-set #f)) + (define-method compute-get-n-set ((class ) s) + (case (slot-definition-allocation s) + ((#:batched) + ;; If we've already used the same slot storage for 10 instances, + ;; reset variables. + (if (= batch-allocation-count 10) + (begin + (set! batch-allocation-count 0) + (set! batch-get-n-set #f))) + ;; If we don't have a current pair of get and set closures, + ;; create one. make-closure-variable returns a pair of closures + ;; around a single Scheme variable - see goops.scm for details. + (or batch-get-n-set + (set! batch-get-n-set (make-closure-variable))) + ;; Increment the batch allocation count. + (set! batch-allocation-count (+ batch-allocation-count 1)) + batch-get-n-set) + + ;; Call next-method to handle standard allocation types. + (else (next-method))))) + +(define-class () + ... + (c #:allocation #:batched) + ... + #:metaclass ) +@end example + +The usage of @code{compute-getter-method} and @code{compute-setter-method} +is described in @ref{MOP Specification}. + +@code{compute-cpl} and @code{compute-get-n-set} are called by the +standard @code{initialize} method for classes whose metaclass is +@code{}. But @code{initialize} itself can also be modified, by +defining an @code{initialize} method specialized to the new class's +metaclass. Such a method could complete override the standard +behaviour, by not calling @code{(next-method)} at all, but more +typically it would perform additional class initialization steps before +and/or after calling @code{(next-method)} for the standard behaviour. + +@node STKlos Compatibility +@subsection STKlos Compatibility + +If the STKlos compatibility module is loaded, @code{define-class} is +overwritten by a STKlos-specific definition; the standard GOOPS +definition of @code{define-class} remains available in +@code{standard-define-class}. + +@deffn syntax standard-define-class name (super @dots{}) slot-definition @dots{} . options +@code{standard-define-class} is equivalent to the standard GOOPS +@code{define-class}. +@end deffn + +@node Creating Instances +@section Creating Instances + +@menu +* Basic Instance Creation:: +* Customizing Instance Creation:: +@end menu + +@node Basic Instance Creation +@subsection Basic Instance Creation + +To create a new instance of any GOOPS class, use the generic function +@code{make} or @code{make-instance}, passing the required class and any +appropriate instance initialization arguments as keyword and value +pairs. Note that @code{make} and @code{make-instances} are aliases for +each other - their behaviour is identical. + +@deffn generic make +@deffnx method make (class ) . initargs +Create and return a new instance of class @var{class}, initialized using +@var{initargs}. + +In theory, @var{initargs} can have any structure that is understood by +whatever methods get applied when the @code{initialize} generic function +is applied to the newly allocated instance. + +In practice, specialized @code{initialize} methods would normally call +@code{(next-method)}, and so eventually the standard GOOPS +@code{initialize} methods are applied. These methods expect +@var{initargs} to be a list with an even number of elements, where +even-numbered elements (counting from zero) are keywords and +odd-numbered elements are the corresponding values. + +GOOPS processes initialization argument keywords automatically for slots +whose definition includes the @code{#:init-keyword} option (@pxref{Slot +Options,, init-keyword}). Other keyword value pairs can only be +processed by an @code{initialize} method that is specialized for the new +instance's class. Any unprocessed keyword value pairs are ignored. +@end deffn + +@deffn generic make-instance +@deffnx method make-instance (class ) . initargs +@code{make-instance} is an alias for @code{make}. +@end deffn + +@node Customizing Instance Creation +@subsection Customizing Instance Creation + +@code{make} itself is a generic function. Hence the @code{make} +invocation itself can be customized in the case where the new instance's +metaclass is more specialized than the default @code{}, by +defining a @code{make} method that is specialized to that metaclass. + +Normally, however, the method for classes with metaclass @code{} +will be applied. This method calls two generic functions: + +@itemize @bullet +@item +(allocate-instance @var{class} . @var{initargs}) + +@item +(initialize @var{instance} . @var{initargs}) +@end itemize + +@code{allocate-instance} allocates storage for and returns the new +instance, uninitialized. You might customize @code{allocate-instance}, +for example, if you wanted to provide a GOOPS wrapper around some other +object programming system. + +To do this, you would create a specialized metaclass, which would act as +the metaclass for all classes and instances from the other system. Then +define an @code{allocate-instance} method, specialized to that +metaclass, which calls a Guile primitive C function, which in turn +allocates the new instance using the interface of the other object +system. + +In this case, for a complete system, you would also need to customize a +number of other generic functions like @code{make} and +@code{initialize}, so that GOOPS knows how to make classes from the +other system, access instance slots, and so on. + +@code{initialize} initializes the instance that is returned by +@code{allocate-instance}. The standard GOOPS methods perform +initializations appropriate to the instance class. + +@itemize @bullet +@item +At the least specialized level, the method for instances of type +@code{} performs internal GOOPS instance initialization, and +initializes the instance's slots according to the slot definitions and +any slot initialization keywords that appear in @var{initargs}. + +@item +The method for instances of type @code{} calls +@code{(next-method)}, then performs the class initializations described +in @ref{Customizing Class Definition}. + +@item +and so on for generic functions, method, operator classes @dots{} +@end itemize + +Similarly, you can customize the initialization of instances of any +application-defined class by defining an @code{initialize} method +specialized to that class. + +Imagine a class whose instances' slots need to be initialized at +instance creation time by querying a database. Although it might be +possible to achieve this a combination of @code{#:init-thunk} keywords +and closures in the slot definitions, it is neater to write an +@code{initialize} method for the class that queries the database once +and initializes all the dependent slot values according to the results. + +@node Accessing Slots +@section Accessing Slots + +The definition of a slot contains at the very least a slot name, and may +also contain various slot options, including getter, setter and/or +accessor functions for the slot. + +It is always possible to access slots by name, using the various +``slot-ref'' and ``slot-set!'' procedures described in the following +subsections. For example, + +@example +(define-class () ;; Define a class with slots + (count #:init-value 0) ;; named "count" and "cache". + (cache #:init-value '()) + @dots{}) + +(define inst (make )) ;; Make an instance of this class. + +(slot-set! inst 'count 5) ;; Set the value of the "count" + ;; slot to 5. + +(slot-set! inst 'cache ;; Modify the value of the + (cons (cons "^it" "It") ;; "cache" slot. + (slot-ref inst 'cache))) +@end example + +If a slot definition includes a getter, setter or accessor function, +these can be used instead of @code{slot-ref} and @code{slot-set!} to +access the slot. + +@example +(define-class () ;; Define a new class whose slots + (count #:setter set-count) ;; use a getter, a setter and + (cache #:accessor cache) ;; an accessor. + (csize #:getter cache-size) + @dots{}) + +(define inst (make )) ;; Make an instance of this class. + +(set-count inst 5) ;; Set the value of the "count" + ;; slot to 5. + +(set! (cache inst) ;; Modify the value of the + (cons (cons "^it" "It") ;; "cache" slot. + (cache inst))) + +(let ((size (cache-size inst))) ;; Get the value of the "csize" + @dots{}) ;; slot. +@end example + +Whichever of these methods is used to access slots, GOOPS always calls +the low-level @dfn{getter} and @dfn{setter} closures for the slot to get +and set its value. These closures make sure that the slot behaves +according to the @code{#:allocation} type that was specified in the slot +definition (@pxref{Slot Options,, allocation}). (For more about these +closures, see @ref{Customizing Class Definition,, compute-get-n-set}.) + +@menu +* Instance Slots:: +* Class Slots:: +* Handling Slot Access Errors:: +@end menu + +@node Instance Slots +@subsection Instance Slots + +Any slot, regardless of its allocation, can be queried, referenced and +set using the following four primitive procedures. + +@deffn {primitive procedure} slot-exists? obj slot-name +Return @code{#t} if @var{obj} has a slot with name @var{slot-name}, +otherwise @code{#f}. +@end deffn + +@deffn {primitive procedure} slot-bound? obj slot-name +Return @code{#t} if the slot named @var{slot-name} in @var{obj} has a +value, otherwise @code{#f}. + +@code{slot-bound?} calls the generic function @code{slot-missing} if +@var{obj} does not have a slot called @var{slot-name} (@pxref{Handling +Slot Access Errors, slot-missing}). +@end deffn + +@deffn {primitive procedure} slot-ref obj slot-name +Return the value of the slot named @var{slot-name} in @var{obj}. + +@code{slot-ref} calls the generic function @code{slot-missing} if +@var{obj} does not have a slot called @var{slot-name} (@pxref{Handling +Slot Access Errors, slot-missing}). + +@code{slot-ref} calls the generic function @code{slot-unbound} if the +named slot in @var{obj} does not have a value (@pxref{Handling Slot +Access Errors, slot-unbound}). +@end deffn + +@deffn {primitive procedure} slot-set! obj slot-name value +Set the value of the slot named @var{slot-name} in @var{obj} to @var{value}. + +@code{slot-set!} calls the generic function @code{slot-missing} if +@var{obj} does not have a slot called @var{slot-name} (@pxref{Handling +Slot Access Errors, slot-missing}). +@end deffn + +GOOPS stores information about slots in class metaobjects. Internally, +all of these procedures work by looking up the slot definition for the +slot named @var{slot-name} in the class metaobject for @code{(class-of +@var{obj})}, and then using the slot definition's ``getter'' and +``setter'' closures to get and set the slot value. + +The next four procedures differ from the previous ones in that they take +the class metaobject as an explicit argument, rather than assuming +@code{(class-of @var{obj})}. Therefore they allow you to apply the +``getter'' and ``setter'' closures of a slot definition in one class to +an instance of a different class. + +[ *fixme* I have no idea why this is useful! Perhaps when a slot in +@code{(class-of @var{obj})} shadows a slot with the same name in one of +its superclasses? There should be an enlightening example here. ] + +@deffn {primitive procedure} slot-exists-using-class? class obj slot-name +Return @code{#t} if the class metaobject @var{class} has a slot +definition for a slot with name @var{slot-name}, otherwise @code{#f}. +@end deffn + +@deffn {primitive procedure} slot-bound-using-class? class obj slot-name +Return @code{#t} if applying @code{slot-ref-using-class} to the same +arguments would call the generic function @code{slot-unbound}, otherwise +@code{#f}. + +@code{slot-bound-using-class?} calls the generic function +@code{slot-missing} if @var{class} does not have a slot definition for a +slot called @var{slot-name} (@pxref{Handling Slot Access Errors, +slot-missing}). +@end deffn + +@deffn {primitive procedure} slot-ref-using-class class obj slot-name +Apply the ``getter'' closure for the slot named @var{slot-name} in +@var{class} to @var{obj}, and return its result. + +@code{slot-ref-using-class} calls the generic function +@code{slot-missing} if @var{class} does not have a slot definition for a +slot called @var{slot-name} (@pxref{Handling Slot Access Errors, +slot-missing}). + +@code{slot-ref-using-class} calls the generic function +@code{slot-unbound} if the application of the ``getter'' closure to +@var{obj} returns an unbound value (@pxref{Handling Slot Access Errors, +slot-unbound}). +@end deffn + +@deffn {primitive procedure} slot-set-using-class! class obj slot-name value +Apply the ``setter'' closure for the slot named @var{slot-name} in +@var{class} to @var{obj} and @var{value}. + +@code{slot-set-using-class!} calls the generic function +@code{slot-missing} if @var{class} does not have a slot definition for a +slot called @var{slot-name} (@pxref{Handling Slot Access Errors, +slot-missing}). +@end deffn + +@node Class Slots +@subsection Class Slots + +Slots whose allocation is per-class rather than per-instance can be +referenced and set without needing to specify any particular instance. + +@deffn procedure class-slot-ref class slot-name +Return the value of the slot named @var{slot-name} in class @var{class}. +The named slot must have @code{#:class} or @code{#:each-subclass} +allocation (@pxref{Slot Options,, allocation}). + +If there is no such slot with @code{#:class} or @code{#:each-subclass} +allocation, @code{class-slot-ref} calls the @code{slot-missing} generic +function with arguments @var{class} and @var{slot-name}. Otherwise, if +the slot value is unbound, @code{class-slot-ref} calls the +@code{slot-missing} generic function, with the same arguments. +@end deffn + +@deffn procedure class-slot-set! class slot-name value +Set the value of the slot named @var{slot-name} in class @var{class} to +@var{value}. The named slot must have @code{#:class} or +@code{#:each-subclass} allocation (@pxref{Slot Options,, allocation}). + +If there is no such slot with @code{#:class} or @code{#:each-subclass} +allocation, @code{class-slot-ref} calls the @code{slot-missing} generic +function with arguments @var{class} and @var{slot-name}. +@end deffn + +@node Handling Slot Access Errors +@subsection Handling Slot Access Errors + +GOOPS calls one of the following generic functions when a ``slot-ref'' +or ``slot-set!'' call specifies a non-existent slot name, or tries to +reference a slot whose value is unbound. + +@deffn generic slot-missing +@deffnx method slot-missing (class ) slot-name +@deffnx method slot-missing (class ) (object ) slot-name +@deffnx method slot-missing (class ) (object ) slot-name value +When an application attempts to reference or set a class or instance +slot by name, and the slot name is invalid for the specified @var{class} +or @var{object}, GOOPS calls the @code{slot-missing} generic function. + +The default methods all call @code{goops-error} with an appropriate +message. +@end deffn + +@deffn generic slot-unbound +@deffnx method slot-unbound (object ) +@deffnx method slot-unbound (class ) slot-name +@deffnx method slot-unbound (class ) (object ) slot-name +When an application attempts to reference a class or instance slot, and +the slot's value is unbound, GOOPS calls the @code{slot-unbound} generic +function. + +The default methods all call @code{goops-error} with an appropriate +message. +@end deffn + +@node Creating Generic Functions +@section Creating Generic Functions + +A generic function is a collection of methods, with rules for +determining which of the methods should be applied for any given +invocation of the generic function. + +GOOPS represents generic functions as metaobjects of the class +@code{} (or one of its subclasses). + +@menu +* Basic Generic Function Creation:: +* Generic Function Internals:: +* Extending Guiles Primitives:: +@end menu + +@node Basic Generic Function Creation +@subsection Basic Generic Function Creation + +The following forms may be used to bind a variable to a generic +function. Depending on that variable's pre-existing value, the generic +function may be created empty - with no methods - or it may contain +methods that are inferred from the pre-existing value. + +It is not, in general, necessary to use @code{define-generic} or +@code{define-accessor} before defining methods for the generic function +using @code{define-method}, since @code{define-method} will +automatically interpolate a @code{define-generic} call, or upgrade an +existing generic to an accessor, if that is implied by the +@code{define-method} call. Note in particular that, +if the specified variable already has a @emph{generic function} value, +@code{define-generic} and @code{define-accessor} will @emph{discard} it! +Obviously it is application-dependent whether this is desirable or not. + +If, for example, you wanted to extend @code{+} for a class representing +a new numerical type, you probably want to inherit any existing methods +for @code{+} and so should not use @code{define-generic}. If, on the +other hand, you do not want to risk inheriting methods whose behaviour +might surprise you, you can use @code{define-generic} or +@code{define-accessor} to wipe the slate clean. + +@deffn syntax define-generic symbol +Create a generic function with name @var{symbol} and bind it to the +variable @var{symbol}. + +If the variable @var{symbol} was previously bound to a Scheme procedure +(or procedure-with-setter), the old procedure (and setter) is +incorporated into the new generic function as its default procedure (and +setter). Any other previous value that was bound to @var{symbol}, +including an existing generic function, is overwritten by the new +generic function. +@end deffn + +@deffn syntax define-accessor symbol +Create an accessor with name @var{symbol} and bind it to the variable +@var{symbol}. + +If the variable @var{symbol} was previously bound to a Scheme procedure +(or procedure-with-setter), the old procedure (and setter) is +incorporated into the new accessor as its default procedure (and +setter). Any other previous value that was bound to @var{symbol}, +including an existing generic function or accessor, is overwritten by +the new definition. +@end deffn + +@node Generic Function Internals +@subsection Generic Function Internals + +@code{define-generic} calls @code{ensure-generic} to upgrade a +pre-existing procedure value, or @code{make} with metaclass +@code{} to create a new generic function. + +@code{define-accessor} calls @code{ensure-accessor} to upgrade a +pre-existing procedure value, or @code{make-accessor} to create a new +accessor. + +@deffn procedure ensure-generic old-definition [name] +Return a generic function with name @var{name}, if possible by using or +upgrading @var{old-definition}. If unspecified, @var{name} defaults to +@code{#f}. + +If @var{old-definition} is already a generic function, it is returned +unchanged. + +If @var{old-definition} is a Scheme procedure or procedure-with-setter, +@code{ensure-generic} returns a new generic function that uses +@var{old-definition} for its default procedure and setter. + +Otherwise @code{ensure-generic} returns a new generic function with no +defaults and no methods. +@end deffn + +@deffn procedure make-generic [name] +Return a new generic function with name @code{(car @var{name})}. If +unspecified, @var{name} defaults to @code{#f}. +@end deffn + +@code{ensure-generic} calls @code{make} with metaclasses +@code{} and @code{}, depending on the +previous value of the variable that it is trying to upgrade. + +@code{make-generic} is a simple wrapper for @code{make} with metaclass +@code{}. + +@deffn procedure ensure-accessor proc [name] +Return an accessor with name @var{name}, if possible by using or +upgrading @var{proc}. If unspecified, @var{name} defaults to @code{#f}. + +If @var{proc} is already an accessor, it is returned unchanged. + +If @var{proc} is a Scheme procedure, procedure-with-setter or generic +function, @code{ensure-accessor} returns an accessor that reuses the +reusable elements of @var{proc}. + +Otherwise @code{ensure-accessor} returns a new accessor with no defaults +and no methods. +@end deffn + +@deffn procedure make-accessor [name] +Return a new accessor with name @code{(car @var{name})}. If +unspecified, @var{name} defaults to @code{#f}. +@end deffn + +@code{ensure-accessor} calls @code{make} with +metaclass @code{}, as well as calls to +@code{ensure-generic}, @code{make-accessor} and (tail recursively) +@code{ensure-accessor}. + +@code{make-accessor} calls @code{make} twice, first +with metaclass @code{} to create a generic function for the +setter, then with metaclass @code{} to create the +accessor, passing the setter generic function as the value of the +@code{#:setter} keyword. + +@node Extending Guiles Primitives +@subsection Extending Guile's Primitives + +When GOOPS is loaded, many of Guile's primitive procedures can be +extended by giving them a generic function definition that operates +in conjunction with their normal C-coded implementation. For +primitives that are extended in this way, the result from the user- +or application-level point of view is that the extended primitive +behaves exactly like a generic function with the C-coded implementation +as its default method. + +The @code{generic-capability?} predicate should be used to determine +whether a particular primitive is extensible in this way. + +@deffn {primitive procedure} generic-capability? primitive +Return @code{#t} if @var{primitive} can be extended by giving it a +generic function definition, otherwise @code{#f}. +@end deffn + +Even when a primitive procedure is extensible like this, its generic +function definition is not created until it is needed by a call to +@code{define-method}, or until the application explicitly requests it +by calling @code{enable-primitive-generic!}. + +@deffn {primitive procedure} enable-primitive-generic! primitive +Force the creation of a generic function definition for +@var{primitive}. +@end deffn + +Once the generic function definition for a primitive has been created, +it can be retrieved using @code{primitive-generic-generic}. + +@deffn {primitive procedure} primitive-generic-generic primitive +Return the generic function definition of @var{primitive}. + +@code{primitive-generic-generic} raises an error if @var{primitive} +is not a primitive with generic capability, or if its generic capability +has not yet been enabled, whether implicitly (by @code{define-method}) +or explicitly (by @code{enable-primitive-generic!}). +@end deffn + +Note that the distinction between, on the one hand, primitives with +additional generic function definitions and, on the other hand, generic +functions with a default method, may disappear when GOOPS is fully +integrated into the core of Guile. Consequently, the +procedures described in this section may disappear as well. + +@node Adding Methods to Generic Functions +@section Adding Methods to Generic Functions + +@menu +* Basic Method Definition:: +* Method Definition Internals:: +@end menu + +@node Basic Method Definition +@subsection Basic Method Definition + +To add a method to a generic function, use the @code{define-method} form. + +@deffn syntax define-method symbol (parameter @dots{}) . body +Define a method for the generic function or accessor @var{symbol} with +parameters @var{parameter}s and body @var{body}. + +@var{symbol} must be either a symbol for a variable bound to a generic +function or accessor, or @code{(setter @var{accessor-symbol})}, where +@var{accessor-symbol} is a symbol for a variable bound to an accessor. +If the former, @code{define-method} defines a reference method for the +specified generic function or accessor; if the latter, +@code{define-method} defines a setter method for the specified accessor. +The @var{symbol} parameter is subject to these restrictions (rather than +being allowed to be anything that evaluates to a generic function) so +that @code{define-method} can construct a call to @code{define-generic} +or @code{define-accessor} if @var{symbol} is not already defined as a +generic function. + +Each @var{parameter} must be either a symbol or a two-element list +@code{(@var{symbol} @var{class})}. The symbols refer to variables in +the @var{body} that will be bound to the parameters supplied by the +caller when calling this method. The @var{class}es, if present, +specify the possible combinations of parameters to which this method +can be applied. + +@var{body} is the body of the method definition. +@end deffn + +@code{define-method} expressions look a little like normal Scheme +procedure definitions of the form + +@example +(define name (lambda (formals @dots{}) . body)) +@end example + +The most important difference is that each formal parameter, apart from the +possible ``rest'' argument, can be qualified by a class name: +@code{@var{formal}} becomes @code{(@var{formal} @var{class})}. The +meaning of this qualification is that the method being defined +will only be applicable in a particular generic function invocation if +the corresponding argument is an instance of @code{@var{class}} (or one of +its subclasses). If more than one of the formal parameters is qualified +in this way, then the method will only be applicable if each of the +corresponding arguments is an instance of its respective qualifying class. + +Note that unqualified formal parameters act as though they are qualified +by the class @code{}, which GOOPS uses to mean the superclass of +all valid Scheme types, including both primitive types and GOOPS classes. + +For example, if a generic function method is defined with +@var{parameter}s @code{((s1 ) (n ))}, that method is +only applicable to invocations of its generic function that have two +parameters where the first parameter is an instance of the +@code{} class and the second parameter is a number. + +If a generic function is invoked with a combination of parameters for which +there is no applicable method, GOOPS raises an error. For more about +invocation error handling, and generic function invocation in general, +see @ref{Invoking Generic Functions}. + +@node Method Definition Internals +@subsection Method Definition Internals + +@code{define-method} + +@itemize @bullet +@item +checks the form of the first parameter, and applies the following steps +to the accessor's setter if it has the @code{(setter @dots{})} form + +@item +interpolates a call to @code{define-generic} or @code{define-accessor} +if a generic function is not already defined with the supplied name + +@item +calls @code{method} with the @var{parameter}s and @var{body}, to make a +new method instance + +@item +calls @code{add-method!} to add this method to the relevant generic +function. +@end itemize + +@deffn syntax method (parameter @dots{}) . body +Make a method whose specializers are defined by the classes in +@var{parameter}s and whose procedure definition is constructed from the +@var{parameter} symbols and @var{body} forms. + +The @var{parameter} and @var{body} parameters should be as for +@code{define-method} (@pxref{Basic Method Definition,, define-method}). +@end deffn + +@code{method} + +@itemize @bullet +@item +extracts formals and specializing classes from the @var{parameter}s, +defaulting the class for unspecialized parameters to @code{} + +@item +creates a closure using the formals and the @var{body} forms + +@item +calls @code{make} with metaclass @code{} and the specializers +and closure using the @code{#:specializers} and @code{#:procedure} +keywords. +@end itemize + +@deffn procedure make-method specializers procedure +Make a method using @var{specializers} and @var{procedure}. + +@var{specializers} should be a list of classes that specifies the +parameter combinations to which this method will be applicable. + +@var{procedure} should be the closure that will applied to the generic +function parameters when this method is invoked. +@end deffn + +@code{make-method} is a simple wrapper around @code{make} with metaclass +@code{}. + +@deffn generic add-method! target method +Generic function for adding method @var{method} to @var{target}. +@end deffn + +@deffn method add-method! (generic ) (method ) +Add method @var{method} to the generic function @var{generic}. +@end deffn + +@deffn method add-method! (proc ) (method ) +If @var{proc} is a procedure with generic capability (@pxref{Extending +Guiles Primitives,, generic-capability?}), upgrade it to a +primitive generic and add @var{method} to its generic function +definition. +@end deffn + +@deffn method add-method! (pg ) (method ) +Add method @var{method} to the generic function definition of @var{pg}. + +Implementation: @code{(add-method! (primitive-generic-generic pg) method)}. +@end deffn + +@deffn method add-method! (whatever ) (method ) +Raise an error indicating that @var{whatever} is not a valid generic +function. +@end deffn + +@node Invoking Generic Functions +@section Invoking Generic Functions + +When a variable with a generic function definition appears as the first +element of a list that is being evaluated, the Guile evaluator tries +to apply the generic function to the arguments obtained by evaluating +the remaining elements of the list. [ *fixme* How do I put this in a +more Schemely and less Lispy way? ] + +Usually a generic function contains several method definitions, with +varying degrees of formal parameter specialization (@pxref{Basic +Method Definition,, define-method}). So it is necessary to sort these +methods by specificity with respect to the supplied arguments, and then +apply the most specific method definition. Less specific methods +may be applied subsequently if a method that is being applied calls +@code{next-method}. + +@menu +* Determining Which Methods to Apply:: +* Handling Invocation Errors:: +@end menu + +@node Determining Which Methods to Apply +@subsection Determining Which Methods to Apply + +[ *fixme* Sorry - this is the area of GOOPS that I understand least of +all, so I'm afraid I have to pass on this section. Would some other +kind person consider filling it in? ] + +@deffn generic apply-generic +@deffnx method apply-generic (gf ) args +@end deffn + +@deffn generic compute-applicable-methods +@deffnx method compute-applicable-methods (gf ) args +@end deffn + +@deffn generic sort-applicable-methods +@deffnx method sort-applicable-methods (gf ) methods args +@end deffn + +@deffn generic method-more-specific? +@deffnx method method-more-specific? (m1 ) (m2 ) args +@end deffn + +@deffn generic apply-method +@deffnx method apply-method (gf ) methods build-next args +@end deffn + +@deffn generic apply-methods +@deffnx method apply-methods (gf ) (l ) args +@end deffn + +@node Handling Invocation Errors +@subsection Handling Invocation Errors + +@deffn generic no-method +@deffnx method no-method (gf ) args +When an application invokes a generic function, and no methods at all +have been defined for that generic function, GOOPS calls the +@code{no-method} generic function. The default method calls +@code{goops-error} with an appropriate message. +@end deffn + +@deffn generic no-applicable-method +@deffnx method no-applicable-method (gf ) args +When an application applies a generic function to a set of arguments, +and no methods have been defined for those argument types, GOOPS calls +the @code{no-applicable-method} generic function. The default method +calls @code{goops-error} with an appropriate message. +@end deffn + +@deffn generic no-next-method +@deffnx method no-next-method (gf ) args +When a generic function method calls @code{(next-method)} to invoke the +next less specialized method for that generic function, and no less +specialized methods have been defined for the current generic function +arguments, GOOPS calls the @code{no-next-method} generic function. The +default method calls @code{goops-error} with an appropriate message. +@end deffn + +@node Redefining a Class +@section Redefining a Class + +Suppose that a class @code{} is defined using @code{define-class} +(@pxref{Basic Class Definition,, define-class}), with slots that have +accessor functions, and that an application has created several instances +of @code{} using @code{make} (@pxref{Basic Instance Creation,, +make}). What then happens if @code{} is redefined by calling +@code{define-class} again? + +@menu +* Default Class Redefinition Behaviour:: +* Customizing Class Redefinition:: +@end menu + +@node Default Class Redefinition Behaviour +@subsection Default Class Redefinition Behaviour + +GOOPS' default answer to this question is as follows. + +@itemize @bullet +@item +All existing direct instances of @code{} are converted to be +instances of the new class. This is achieved by preserving the values +of slots that exist in both the old and new definitions, and initializing the +values of new slots in the usual way (@pxref{Basic Instance Creation,, +make}). + +@item +All existing subclasses of @code{} are redefined, as though +the @code{define-class} expressions that defined them were re-evaluated +following the redefinition of @code{}, and the class +redefinition process described here is applied recursively to the +redefined subclasses. + +@item +Once all of its instances and subclasses have been updated, the class +metaobject previously bound to the variable @code{} is no +longer needed and so can be allowed to be garbage collected. +@end itemize + +To keep things tidy, GOOPS also needs to do a little housekeeping on +methods that are associated with the redefined class. + +@itemize @bullet +@item +Slot accessor methods for slots in the old definition should be removed +from their generic functions. They will be replaced by accessor methods +for the slots of the new class definition. + +@item +Any generic function method that uses the old @code{} metaobject +as one of its formal parameter specializers must be updated to refer to +the new @code{} metaobject. (Whenever a new generic function +method is defined, @code{define-method} adds the method to a list stored +in the class metaobject for each class used as a formal parameter +specializer, so it is easy to identify all the methods that must be +updated when a class is redefined.) +@end itemize + +If this class redefinition strategy strikes you as rather counter-intuitive, +bear in mind that it is derived from similar behaviour in other object +systems such as CLOS, and that experience in those systems has shown it to be +very useful in practice. + +Also bear in mind that, like most of GOOPS' default behaviour, it can +be customized@dots{} + +@node Customizing Class Redefinition +@subsection Customizing Class Redefinition + +When @code{define-class} notices that a class is being redefined, +it constructs the new class metaobject as usual, and then invokes the +@code{class-redefinition} generic function with the old and new classes +as arguments. Therefore, if the old or new classes have metaclasses +other than the default @code{}, class redefinition behaviour can +be customized by defining a @code{class-redefinition} method that is +specialized for the relevant metaclasses. + +@deffn generic class-redefinition +Handle the class redefinition from @var{old-class} to @var{new-class}, +and return the new class metaobject that should be bound to the +variable specified by @code{define-class}'s first argument. +@end deffn + +@deffn method class-redefinition (old-class ) (new-class ) +Implements GOOPS' default class redefinition behaviour, as described in +@ref{Default Class Redefinition Behaviour}. Returns the metaobject +for the new class definition. +@end deffn + +An alternative class redefinition strategy could be to leave all +existing instances as instances of the old class, but accepting that the +old class is now ``nameless'', since its name has been taken over by the +new definition. In this strategy, any existing subclasses could also +be left as they are, on the understanding that they inherit from a nameless +superclass. + +This strategy is easily implemented in GOOPS, by defining a new metaclass, +that will be used as the metaclass for all classes to which the strategy +should apply, and then defining a @code{class-redefinition} method that +is specialized for this metaclass: + +@example +(define-class ()) + +(define-method class-redefinition ((old ) (new )) + new) +@end example + +When customization can be as easy as this, aren't you glad that GOOPS +implements the far more difficult strategy as its default! + +Finally, note that, if @code{class-redefinition} itself is not customized, +the default @code{class-redefinition} method invokes three further +generic functions that could be individually customized: + +@itemize @bullet +@item +(remove-class-accessors! @var{old-class}) + +@item +(update-direct-method! @var{method} @var{old-class} @var{new-class}) + +@item +(update-direct-subclass! @var{subclass} @var{old-class} @var{new-class}) +@end itemize + +and the default methods for these generic functions invoke further +generic functions, and so on@dots{} The detailed protocol for all of these +is described in @ref{MOP Specification}. + +@node Changing the Class of an Instance +@section Changing the Class of an Instance + +You can change the class of an existing instance by invoking the +generic function @code{change-class} with two arguments: the instance +and the new class. + +@deffn generic change-class +@end deffn + +The default method for @code{change-class} decides how to implement the +change of class by looking at the slot definitions for the instance's +existing class and for the new class. If the new class has slots with +the same name as slots in the existing class, the values for those slots +are preserved. Slots that are present only in the existing class are +discarded. Slots that are present only in the new class are initialized +using the corresponding slot definition's init function (@pxref{Classes,, +slot-init-function}). + +@deffn {method} change-class (obj ) (new ) +Modify instance @var{obj} to make it an instance of class @var{new}. + +The value of each of @var{obj}'s slots is preserved only if a similarly named +slot exists in @var{new}; any other slot values are discarded. + +The slots in @var{new} that do not correspond to any of @var{obj}'s +pre-existing slots are initialized according to @var{new}'s slot definitions' +init functions. +@end deffn + +Customized change of class behaviour can be implemented by defining +@code{change-class} methods that are specialized either by the class +of the instances to be modified or by the metaclass of the new class. + +When a class is redefined (@pxref{Redefining a Class}), and the default +class redefinition behaviour is not overridden, GOOPS (eventually) +invokes the @code{change-class} generic function for each existing +instance of the redefined class. + +@node Introspection +@section Introspection + +@dfn{Introspection}, also known as @dfn{reflection}, is the name given +to the ability to obtain information dynamically about GOOPS metaobjects. +It is perhaps best illustrated by considering an object oriented language +that does not provide any introspection, namely C++. + +Nothing in C++ allows a running program to obtain answers to the following +types of question: + +@itemize @bullet +@item +What are the data members of this object or class? + +@item +What classes does this class inherit from? + +@item +Is this method call virtual or non-virtual? + +@item +If I invoke @code{Employee::adjustHoliday()}, what class contains the +@code{adjustHoliday()} method that will be applied? +@end itemize + +In C++, answers to such questions can only be determined by looking at +the source code, if you have access to it. GOOPS, on the other hand, +includes procedures that allow answers to these questions --- or their +GOOPS equivalents --- to be obtained dynamically, at run time. + +@menu +* Classes:: +* Slots:: +* Instances:: +* Generic Functions:: +* Generic Function Methods:: +@end menu + +@node Classes +@subsection Classes + +@deffn {primitive procedure} class-name class +Return the name of class @var{class}. +This is the value of the @var{class} metaobject's @code{name} slot. +@end deffn + +@deffn {primitive procedure} class-direct-supers class +Return a list containing the direct superclasses of @var{class}. +This is the value of the @var{class} metaobject's +@code{direct-supers} slot. +@end deffn + +@deffn {primitive procedure} class-direct-slots class +Return a list containing the slot definitions of the direct slots of +@var{class}. +This is the value of the @var{class} metaobject's @code{direct-slots} +slot. +@end deffn + +@deffn {primitive procedure} class-direct-subclasses class +Return a list containing the direct subclasses of @var{class}. +This is the value of the @var{class} metaobject's +@code{direct-subclasses} slot. +@end deffn + +@deffn {primitive procedure} class-direct-methods class +Return a list of all the generic function methods that use @var{class} +as a formal parameter specializer. +This is the value of the @var{class} metaobject's @code{direct-methods} +slot. +@end deffn + +@deffn {primitive procedure} class-precedence-list class +Return the class precedence list for class @var{class} (@pxref{Class +precedence list}). +This is the value of the @var{class} metaobject's @code{cpl} slot. +@end deffn + +@deffn {primitive procedure} class-slots class +Return a list containing the slot definitions for all @var{class}'s slots, +including any slots that are inherited from superclasses. +This is the value of the @var{class} metaobject's @code{slots} slot. +@end deffn + +@deffn {primitive procedure} class-environment class +Return the value of @var{class}'s @code{environment} slot. +[ *fixme* I don't know what this value is used for. ] +@end deffn + +@deffn procedure class-subclasses class +Return a list of all subclasses of @var{class}. +@end deffn + +@deffn procedure class-methods class +Return a list of all methods that use @var{class} or a subclass of +@var{class} as one of its formal parameter specializers. +@end deffn + +@node Slots +@subsection Slots + +@deffn procedure class-slot-definition class slot-name +Return the slot definition for the slot named @var{slot-name} in class +@var{class}. @var{slot-name} should be a symbol. +@end deffn + +@deffn procedure slot-definition-name slot-def +Extract and return the slot name from @var{slot-def}. +@end deffn + +@deffn procedure slot-definition-options slot-def +Extract and return the slot options from @var{slot-def}. +@end deffn + +@deffn procedure slot-definition-allocation slot-def +Extract and return the slot allocation option from @var{slot-def}. This +is the value of the @code{#:allocation} keyword (@pxref{Slot Options,, +allocation}), or @code{#:instance} if the @code{#:allocation} keyword is +absent. +@end deffn + +@deffn procedure slot-definition-getter slot-def +Extract and return the slot getter option from @var{slot-def}. This is +the value of the @code{#:getter} keyword (@pxref{Slot Options,, +getter}), or @code{#f} if the @code{#:getter} keyword is absent. +@end deffn + +@deffn procedure slot-definition-setter slot-def +Extract and return the slot setter option from @var{slot-def}. This is +the value of the @code{#:setter} keyword (@pxref{Slot Options,, +setter}), or @code{#f} if the @code{#:setter} keyword is absent. +@end deffn + +@deffn procedure slot-definition-accessor slot-def +Extract and return the slot accessor option from @var{slot-def}. This +is the value of the @code{#:accessor} keyword (@pxref{Slot Options,, +accessor}), or @code{#f} if the @code{#:accessor} keyword is absent. +@end deffn + +@deffn procedure slot-definition-init-value slot-def +Extract and return the slot init-value option from @var{slot-def}. This +is the value of the @code{#:init-value} keyword (@pxref{Slot Options,, +init-value}), or the unbound value if the @code{#:init-value} keyword is +absent. +@end deffn + +@deffn procedure slot-definition-init-form slot-def +Extract and return the slot init-form option from @var{slot-def}. This +is the value of the @code{#:init-form} keyword (@pxref{Slot Options,, +init-form}), or the unbound value if the @code{#:init-form} keyword is +absent. +@end deffn + +@deffn procedure slot-definition-init-thunk slot-def +Extract and return the slot init-thunk option from @var{slot-def}. This +is the value of the @code{#:init-thunk} keyword (@pxref{Slot Options,, +init-thunk}), or @code{#f} if the @code{#:init-thunk} keyword is absent. +@end deffn + +@deffn procedure slot-definition-init-keyword slot-def +Extract and return the slot init-keyword option from @var{slot-def}. +This is the value of the @code{#:init-keyword} keyword (@pxref{Slot +Options,, init-keyword}), or @code{#f} if the @code{#:init-keyword} +keyword is absent. +@end deffn + +@deffn procedure slot-init-function class slot-name +Return the initialization function for the slot named @var{slot-name} in +class @var{class}. @var{slot-name} should be a symbol. + +The returned initialization function incorporates the effects of the +standard @code{#:init-thunk}, @code{#:init-form} and @code{#:init-value} +slot options. These initializations can be overridden by the +@code{#:init-keyword} slot option or by a specialized @code{initialize} +method, so, in general, the function returned by +@code{slot-init-function} may be irrelevant. For a fuller discussion, +see @ref{Slot Options,, init-value}. +@end deffn + +@node Instances +@subsection Instances + +@deffn {primitive procedure} class-of value +Return the GOOPS class of any Scheme @var{value}. +@end deffn + +@deffn {primitive procedure} instance? object +Return @code{#t} if @var{object} is any GOOPS instance, otherwise +@code{#f}. +@end deffn + +@deffn procedure is-a? object class +Return @code{#t} if @var{object} is an instance of @var{class} or one of +its subclasses. +@end deffn + +Implementation notes: @code{is-a?} uses @code{class-of} and +@code{class-precedence-list} to obtain the class precedence list for +@var{object}. + +@node Generic Functions +@subsection Generic Functions + +@deffn {primitive procedure} generic-function-name gf +Return the name of generic function @var{gf}. +@end deffn + +@deffn {primitive procedure} generic-function-methods gf +Return a list of the methods of generic function @var{gf}. +This is the value of the @var{gf} metaobject's @code{methods} slot. +@end deffn + +@node Generic Function Methods +@subsection Generic Function Methods + +@deffn {primitive procedure} method-generic-function method +Return the generic function that @var{method} belongs to. +This is the value of the @var{method} metaobject's +@code{generic-function} slot. +@end deffn + +@deffn {primitive procedure} method-specializers method +Return a list of @var{method}'s formal parameter specializers . +This is the value of the @var{method} metaobject's +@code{specializers} slot. +@end deffn + +@deffn {primitive procedure} method-procedure method +Return the procedure that implements @var{method}. +This is the value of the @var{method} metaobject's +@code{procedure} slot. +@end deffn + +@deffn generic method-source +@deffnx method method-source (m ) +Return an expression that prints to show the definition of method +@var{m}. + +@example +(define-generic cube) + +(define-method cube ((n )) + (* n n n)) + +(map method-source (generic-function-methods cube)) +@result{} +((method ((n )) (* n n n))) +@end example +@end deffn + +@node Miscellaneous Functions +@section Miscellaneous Functions + +@menu +* Administrative Functions:: +* Error Handling:: +* Object Comparisons:: +* Cloning Objects:: +* Write and Display:: +@end menu + +@node Administrative Functions +@subsection Administration Functions + +This section describes administrative, non-technical GOOPS functions. + +@deffn primitive goops-version +Return the current GOOPS version as a string, for example ``0.2''. +@end deffn + +@node Error Handling +@subsection Error Handling + +The procedure @code{goops-error} is called to raise an appropriate error +by the default methods of the following generic functions: + +@itemize @bullet +@item +@code{slot-missing} (@pxref{Handling Slot Access Errors,, slot-missing}) + +@item +@code{slot-unbound} (@pxref{Handling Slot Access Errors,, slot-unbound}) + +@item +@code{no-method} (@pxref{Handling Invocation Errors,, no-method}) + +@item +@code{no-applicable-method} (@pxref{Handling Invocation Errors,, +no-applicable-method}) + +@item +@code{no-next-method} (@pxref{Handling Invocation Errors,, +no-next-method}) +@end itemize + +If you customize these functions for particular classes or metaclasses, +you may still want to use @code{goops-error} to signal any error +conditions that you detect. + +@deffn procedure goops-error format-string . args +Raise an error with key @code{goops-error} and error message constructed +from @var{format-string} and @var{args}. Error message formatting is +as done by @code{scm-error}. +@end deffn + +@node Object Comparisons +@subsection Object Comparisons + +@deffn generic object-eqv? +@deffnx method object-eqv? ((x ) (y )) +@deffnx generic object-equal? +@deffnx method object-equal? ((x ) (y )) +Generic functions and default (unspecialized) methods for comparing two +GOOPS objects. + +The default methods always return @code{#f}. Application class authors +may wish to define specialized methods for @code{object-eqv?} and +@code{object-equal?} that compare instances of the same class for +equality in whatever sense is useful to the application. +@end deffn + +@node Cloning Objects +@subsection Cloning Objects + +@deffn generic shallow-clone +@deffnx method shallow-clone (self ) +Return a ``shallow'' clone of @var{self}. The default method makes a +shallow clone by allocating a new instance and copying slot values from +self to the new instance. Each slot value is copied either as an +immediate value or by reference. +@end deffn + +@deffn generic deep-clone +@deffnx method deep-clone (self ) +Return a ``deep'' clone of @var{self}. The default method makes a deep +clone by allocating a new instance and copying or cloning slot values +from self to the new instance. If a slot value is an instance +(satisfies @code{instance?}), it is cloned by calling @code{deep-clone} +on that value. Other slot values are copied either as immediate values +or by reference. +@end deffn + +@node Write and Display +@subsection Write and Display + +@deffn {primitive generic} write object port +@deffnx {primitive generic} display object port +When GOOPS is loaded, @code{write} and @code{display} become generic +functions with special methods for printing + +@itemize @bullet +@item +objects - instances of the class @code{} + +@item +foreign objects - instances of the class @code{} + +@item +classes - instances of the class @code{} + +@item +generic functions - instances of the class @code{} + +@item +methods - instances of the class @code{}. +@end itemize + +@code{write} and @code{display} print non-GOOPS values in the same way +as the Guile primitive @code{write} and @code{display} functions. +@end deffn + +@node MOP Specification, Tutorial, Reference Manual, Top +@chapter MOP Specification + +For an introduction to metaobjects and the metaobject protocol, +see @ref{Metaobjects and the Metaobject Protocol}. + +The aim of the MOP specification in this chapter is to specify all the +customizable generic function invocations that can be made by the standard +GOOPS syntax, procedures and methods, and to explain the protocol for +customizing such invocations. + +A generic function invocation is customizable if the types of the arguments +to which it is applied are not all determined by the lexical context in +which the invocation appears. For example, + +@itemize @bullet +@item +the @code{(initialize @var{instance} @var{initargs})} invocation in the +default @code{make-instance} method is customizable, because the type of the +@code{@var{instance}} argument is determined by the class that was passed to +@code{make-instance}. + +@item +the @code{(make #:name ',name)} invocation in @code{define-generic} +is not customizable, because all of its arguments have lexically determined +types. +@end itemize + +When using this rule to decide whether a given generic function invocation +is customizable, we ignore arguments that are expected to be handled in +method definitions as a single ``rest'' list argument. + +For each customizable generic function invocation, the @dfn{invocation +protocol} is explained by specifying + +@itemize @bullet +@item +what, conceptually, the applied method is intended to do + +@item +what assumptions, if any, the caller makes about the applied method's side +effects + +@item +what the caller expects to get as the applied method's return value. +@end itemize + +@menu +* Class Definition:: +* Instance Creation:: +* Class Redefinition:: +* Method Definition:: +* Generic Function Invocation:: +@end menu + +@node Class Definition +@section Class Definition + +@code{define-class} (syntax) + +@itemize @bullet +@item +@code{class} (syntax) + +@itemize @bullet +@item +@code{make-class} (procedure) + +@itemize @bullet +@item +@code{make @var{metaclass} @dots{}} (generic) + +@var{metaclass} is the metaclass of the class being defined, either +taken from the @code{#:metaclass} class option or computed by +@code{ensure-metaclass}. The applied method must create and return the +fully initialized class metaobject for the new class definition. +@end itemize + +@end itemize + +@item +@code{class-redefinition @var{old-class} @var{new-class}} (generic) + +@code{define-class} calls @code{class-redefinition} if the variable +specified by its first argument already held a GOOPS class definition. +@var{old-class} and @var{new-class} are the old and new class metaobjects. +The applied method should perform whatever is necessary to handle the +redefinition, and should return the class metaobject that is to be bound +to @code{define-class}'s variable. The default class redefinition +protocol is described in @ref{Class Redefinition}. +@end itemize + +The @code{(make @var{metaclass} @dots{})} invocation above will create +an class metaobject with metaclass @var{metaclass}. By default, this +metaobject will be initialized by the @code{initialize} method that is +specialized for instances of type @code{}. + +@code{initialize @var{initargs}} (method) + +@itemize @bullet +@item +@code{compute-cpl @var{class}} (generic) + +The applied method should compute and return the class precedence list +for @var{class} as a list of class metaobjects. When @code{compute-cpl} +is called, the following @var{class} metaobject slots have all been +initialized: @code{name}, @code{direct-supers}, @code{direct-slots}, +@code{direct-subclasses} (empty), @code{direct-methods}. The value +returned by @code{compute-cpl} will be stored in the @code{cpl} slot. + +@item +@code{compute-slots @var{class}} (generic) + +The applied method should compute and return the slots (union of direct +and inherited) for @var{class} as a list of slot definitions. When +@code{compute-slots} is called, all the @var{class} metaobject slots +mentioned for @code{compute-cpl} have been initialized, plus the +following: @code{cpl}, @code{redefined} (@code{#f}), @code{environment}. +The value returned by @code{compute-slots} will be stored in the +@code{slots} slot. + +@item +@code{compute-get-n-set @var{class} @var{slot-def}} (generic) + +@code{initialize} calls @code{compute-get-n-set} for each slot computed +by @code{compute-slots}. The applied method should compute and return a +pair of closures that, respectively, get and set the value of the specified +slot. The get closure should have arity 1 and expect a single argument +that is the instance whose slot value is to be retrieved. The set closure +should have arity 2 and expect two arguments, where the first argument is +the instance whose slot value is to be set and the second argument is the +new value for that slot. The closures should be returned in a two element +list: @code{(list @var{get} @var{set})}. + +The closures returned by @code{compute-get-n-set} are stored as part of +the value of the @var{class} metaobject's @code{getters-n-setters} slot. +Specifically, the value of this slot is a list with the same number of +elements as there are slots in the class, and each element looks either like + +@example +@code{(@var{slot-name-symbol} @var{init-function} . @var{index})} +@end example + +or like + +@example +@code{(@var{slot-name-symbol} @var{init-function} @var{get} @var{set})} +@end example + +Where the get and set closures are replaced by @var{index}, the slot is +an instance slot and @var{index} is the slot's index in the underlying +structure: GOOPS knows how to get and set the value of such slots and so +does not need specially constructed get and set closures. Otherwise, +@var{get} and @var{set} are the closures returned by @code{compute-get-n-set}. + +The structure of the @code{getters-n-setters} slot value is important when +understanding the next customizable generic functions that @code{initialize} +calls@dots{} + +@item +@code{compute-getter-method @var{class} @var{gns}} (generic) + +@code{initialize} calls @code{compute-getter-method} for each of the class's +slots (as determined by @code{compute-slots}) that includes a +@code{#:getter} or @code{#:accessor} slot option. @var{gns} is the +element of the @var{class} metaobject's @code{getters-n-setters} slot that +specifies how the slot in question is referenced and set, as described +above under @code{compute-get-n-set}. The applied method should create +and return a method that is specialized for instances of type @var{class} +and uses the get closure to retrieve the slot's value. [ *fixme Need +to insert something here about checking that the value is not unbound. ] +@code{initialize} uses @code{add-method!} to add the returned method to +the generic function named by the slot definition's @code{#:getter} or +@code{#:accessor} option. + +@item +@code{compute-setter-method @var{class} @var{gns}} (generic) + +@code{compute-setter-method} is invoked with the same arguments as +@code{compute-getter-method}, for each of the class's slots that includes +a @code{#:setter} or @code{#:accessor} slot option. The applied method +should create and return a method that is specialized for instances of +type @var{class} and uses the set closure to set the slot's value. +@code{initialize} then uses @code{add-method!} to add the returned method +to the generic function named by the slot definition's @code{#:setter} +or @code{#:accessor} option. +@end itemize + +@node Instance Creation +@section Instance Creation + +@code{make . @var{initargs}} (method) + +@itemize @bullet +@item +@code{allocate-instance @var{class} @var{initargs}} (generic) + +The applied @code{allocate-instance} method should allocate storage for +a new instance of class @var{class} and return the uninitialized instance. + +@item +@code{initialize @var{instance} @var{initargs}} (generic) + +@var{instance} is the uninitialized instance returned by +@code{allocate-instance}. The applied method should initialize the new +instance in whatever sense is appropriate for its class. The method's +return value is ignored. +@end itemize + +@node Class Redefinition +@section Class Redefinition + +The default @code{class-redefinition} method, specialized for classes +with the default metaclass @code{}, has the following internal +protocol. + +[ *fixme* I'm not sure that I understand this sufficiently to explain +it. Also, the internals of the default class redefinition method are +extremely implementation-specific, and I'm not sure that there is that +much point trying to describe the internal protocol such that it could +be customized without going to look at the source code. ] + +@code{class-redefinition @var{(old )} @var{(new )}} +(method) + +@itemize @bullet +@item +@code{remove-class-accessors! @var{old}} (generic) + +@item +@code{update-direct-method! @var{method} @var{old} @var{new}} (generic) + +@item +@code{update-direct-subclass! @var{subclass} @var{old} @var{new}} (generic) +@end itemize + +The default @code{update-direct-subclass!} method invokes +@code{class-redefinition} recursively to handle the redefinition of the +subclass. + +When a class is redefined, any existing instance of the redefined class +will be modified for the new class definition before the next time that +any of the instance's slot is referenced or set. GOOPS modifies each +instance by calling the generic function @code{change-class}. [ *fixme* +Actually it sometimes calls @code{change-class} and sometimes +@code{change-object-class}, and I don't understand why. ] + +The default @code{change-class} method copies slot values from the old +to the modified instance, and initializes new slots, as described in +@ref{Changing the Class of an Instance}. After doing so, it makes a +generic function invocation that can be used to customize the instance +update algorithm. + +@code{change-class @var{(old-instance )} @var{(new )}} (method) + +@itemize @bullet +@item +@code{update-instance-for-different-class @var{old-instance} @var{new-instance}} (generic) + +@code{change-class} invokes @code{update-instance-for-different-class} +as the last thing that it does before returning. The applied method can +make any further adjustments to @var{new-instance} that are required to +complete or modify the change of class. The return value from the +applied method is ignored. + +The default @code{update-instance-for-different-class} method does +nothing. +@end itemize + +@node Method Definition +@section Method Definition + +@code{define-method} (syntax) + +@itemize @bullet +@item +@code{add-method! @var{target} @var{method}} (generic) + +@code{define-method} invokes the @code{add-method!} generic function to +handle adding the new method to a variety of possible targets. GOOPS +includes methods to handle @var{target} as + +@itemize @bullet +@item +a generic function (the most common case) + +@item +a procedure + +@item +a primitive generic (@pxref{Extending Guiles Primitives}) +@end itemize + +By defining further methods for @code{add-method!}, you can +theoretically handle adding methods to further types of target. +@end itemize + +@node Generic Function Invocation +@section Generic Function Invocation + +[ *fixme* Description required here. ] + +@code{apply-generic} + +@itemize @bullet +@item +@code{no-method} + +@item +@code{compute-applicable-methods} + +@item +@code{sort-applicable-methods} + +@item +@code{apply-methods} + +@item +@code{no-applicable-method} +@end itemize + +@code{sort-applicable-methods} + +@itemize @bullet +@item +@code{method-more-specific?} +@end itemize + +@code{apply-methods} + +@itemize @bullet +@item +@code{apply-method} +@end itemize + +@code{next-method} + +@itemize @bullet +@item +@code{no-next-method} +@end itemize + +@node Tutorial, Index, MOP Specification, Top +@chapter Tutorial +@include goops-tutorial.texi + +@node Index, Concept Index, Tutorial, Top +@chapter Index +@page +@node Concept Index, Function and Variable Index, Index, Top +@unnumberedsec Concept Index + +@printindex cp + +@node Function and Variable Index, , Concept Index, Top +@unnumberedsec Function and Variable Index + +@printindex fn + +@summarycontents +@contents +@bye diff --git a/doc/guile.texi b/doc/guile.texi new file mode 100644 index 000000000..09519b3f3 --- /dev/null +++ b/doc/guile.texi @@ -0,0 +1,368 @@ +\input texinfo +@c -*-texinfo-*- +@c %**start of header +@setfilename guile.info +@settitle Guile Reference Manual +@c %**end of header + +@c Neil's notes: + +@c This file started life as a copy of guile-ref.texi, which I then +@c modified to reflect the organization described in +@c sources/jimb-org.texi. + +@c Jim's notes: + +@c Remember to use "subr" whereever appropriate. +@c Actually, use "primitive", not "subr." Why coin a new term? +@c FIXME: gotta change existing "subr" uses to "Primitive". +@c In my text for the Guile snarfer, I've used the term "subr" to denote +@c a C function made available to the Scheme world as a function. This +@c terminology is weird, but consistent with the function names and also +@c with Emacs Lisp, which I assume takes Maclisp's lead. + +@c Tim's notes: + +@c When adding a new function to the Guile manual, please document +@c it with @deffn as one of `primitive', `procedure', or `syntax'. +@c +@c The following Guile primitives are not documented. We have a lot +@c of work to do. +@c +@c arbiters.c: make-arbiter, try-arbiter, release-arbiter +@c async.c: async, async-mark, system-async, system-async-mark, +@c run-asyncs, noop, set-tick-rate, set-switch-rate, +@c unmask-signals, mask-signals +@c backtrace.c: backtrace, display-error, display-application, +@c display-backtrace +@c chars.c: char-is-both? +@c debug.c: single-step, memoized?, unmemoize, memoized-environment, +@c procedure-name, procedure-source, procedure-environment, +@c local-eval, debug-object?, debug-hang +@c dynl.c: c-registered-modules, c-clear-registered-modules, +@c dynamic-link, dynamic-object?, dynamic-unlink, dynamic-func, +@c dynamic-call, dynamic-args-call +@c eval.c: procedure->syntax, procedure->macro, procedure->memoizing-macro, +@c macro-name, macro-transformer +@c fluids.c: make-fluid, fluid?, fluid-ref, fluid-set, with-fluids* +@c gc.c: map-free-list, unhash-name +@c kw.c: make-keyword-from-dash-symbol +@c net_db.c: sethost, setnet, setproto, setserv +@c print.c: current-pstate +@c procs.c: make-cclo, closure?, thunk? +@c read.c: read-hash-extend +@c readline.c: readline, add-history +@c srcprop.c: source-properties, set-source-properties!, +@c source-property, set-source-property! +@c stacks.c: make-stack, stack-ref, stack-length, +@c frame?, last-stack-frame, frame-number, frame-source, +@c frame-procedure, frame-arguments, frame-previous, frame-next, +@c frame-real?, frame-procedure?, frame-evaluating-args?, +@c frame-overflow +@c struct.c: struct-vtable-tag +@c symbols.c: builtin-weak-bindings +@c tag.c: tag +@c threads.c: single-active-thread?, yield, call-with-new-thread, +@c make-condition-variable, wait-condition-variable, +@c signal-condition-variable +@c throw.c: lazy-catch, vector-set-length! +@c unif.c: uniform-vector-ref, uniform-array-set1! +@c variable.c: make-variable, make-undefined-variable, variable?, +@c variable-ref, variable-set!, builtin-variable, variable-bound? +@c weaks.c: make-weak-vector, weak-vector, list->weak-vector, +@c weak-vector? make-weak-key-hash-table, +@c make-weak-value-hash-table, make-doubly-weak-hash-table, +@c weak-key-hash-table?, weak-value-hash-table?, +@c doubly-weak-hash-table? +@c +@c If you have worked with some of these concepts, implemented them, +@c or just happen to know what they do, please write up a little +@c explanation -- it would be a big help. Alternatively, if you +@c know of a great reason why some of these should *not* go in the +@c manual, please let me know. +@c +@c The following functions are currently left undocumented for various reasons. +@c * should be documented in a section on debugging or Guile internals: +@c ports.c: pt-size, pt-member +@c eval.c: apply:nconc2last +@c * trivial underlying implementations of R4RS functions: +@c numbers.c: $asinh, $acosh, $atanh, $sqrt, $abs, $exp, $log, $sin, +@c $cos, $tan, $asin, $acos, $atan, $sinh, $cosh, $tanh, $expt, +@c $atan2 +@c +@c Thanks. -twp + +@c Define indices that are used in the Guile Scheme part of the +@c reference manual to group stuff according to whether it is R5RS or a +@c Guile extension. +@defcodeindex r5 +@defcodeindex ge + +@include version.texi + +@c @iftex +@c @cropmarks +@c @end iftex + +@dircategory The Algorithmic Language Scheme +@direntry +* Guile Reference: (guile). The Guile reference manual. +@end direntry + +@setchapternewpage off + +@ifinfo +Guile Reference Manual +Copyright (C) 1996 Free Software Foundation @* +Copyright (C) 1997 Free Software Foundation @* +Copyright (C) 2000 Free Software Foundation @* +Copyright (C) 2001 Free Software Foundation + +Permission is granted to make and distribute verbatim copies of +this manual provided the copyright notice and this permission notice +are preserved on all copies. + +@ignore +Permission is granted to process this file through TeX and print the +results, provided the printed document carries copying permission +notice identical to this one except for the removal of this paragraph +(this paragraph not being relevant to the printed manual). +@end ignore + +Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided that the entire +resulting derived work is distributed under the terms of a permission +notice identical to this one. + +Permission is granted to copy and distribute translations of this manual +into another language, under the above conditions for modified versions, +except that this permission notice may be stated in a translation approved +by the Free Software Foundation. +@end ifinfo + +@titlepage +@sp 10 +@comment The title is printed in a large font. +@title Guile Reference Manual +@subtitle $Id: guile.texi,v 1.1 2001-03-09 08:21:59 ossau Exp $ +@subtitle For use with Guile @value{VERSION} +@author Mark Galassi +@author Cygnus Solution and Los Alamos National Laboratory +@author @email{rosalia@@cygnus.com} +@author +@author Jim Blandy +@author Free Software Foundation and MIT AI Lab +@author @email{jimb@@red-bean.com} +@author +@author Gary Houston +@author @email{ghouston@@actrix.gen.nz} +@author +@author Tim Pierce +@author @email{twp@@skepsis.com} +@author +@author Neil Jerram +@author @email{neil@@ossau.uklinux.net} +@c The following two commands start the copyright page. +@page +@vskip 0pt plus 1filll +@vskip 0pt plus 1filll +Copyright @copyright{} 1996 Free Software Foundation + +Copyright @copyright{} 1997 Free Software Foundation + +Copyright @copyright{} 2000 Free Software Foundation + +Permission is granted to make and distribute verbatim copies of +this manual provided the copyright notice and this permission notice +are preserved on all copies. + +Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided that the entire +resulting derived work is distributed under the terms of a permission +notice identical to this one. + +Permission is granted to copy and distribute translations of this manual +into another language, under the above conditions for modified versions, +except that this permission notice may be stated in a translation approved +by Free Software Foundation. +@end titlepage + +@c @smallbook +@finalout +@headings double + +@c Where to find Guile examples. +@set example-dir doc/examples + +@ifinfo +@node Top, Guile License, (dir), (dir) +@top The Guile Reference Manual + +This reference manual documents Guile, GNU's Ubiquitous Intelligent +Language for Extensions. It describes how to use Guile in many useful +and interesting ways. + +This Info file contains edition 1.0 of the reference manual, +corresponding to Guile version @value{VERSION}. +@end ifinfo + +@menu +Preface + +* Guile License:: Conditions for copying and using Guile. +* Manual Layout:: How to read the rest of this manual. + +Part I: Introduction to Guile + +* What is Guile?:: And what does it do? +* Whirlwind Tour:: An introductory whirlwind tour. +* Reporting Bugs:: Reporting bugs in Guile or this manual. + +Part II: Guile Scheme + +* Scheme Intro:: Introduction to Guile Scheme. +* Basic Ideas:: Basic ideas in Scheme. +* Data Types:: Data types for generic use. +* Procedures and Macros:: Procedures and macros. +* Utility Functions:: General utility functions. +* Binding Constructs:: Definitions and variable bindings. +* Control Mechanisms:: Controlling the flow of program execution. +* Input and Output:: Ports, reading and writing. +* Read/Load/Eval:: Reading and evaluating Scheme code. +* Memory Management:: Memory management and garbage collection. +* Objects:: Low level object orientation support. +* Modules:: Designing reusable code libraries. +* Scheduling:: Threads, mutexes, asyncs and dynamic roots. +* Options and Config:: Runtime options and configuration. +* Translation:: Support for translating other languages. +* Debugging:: Internal debugging interface. +* Deprecated:: Features that are planned to disappear. +* Further Reading:: Where to find out more about Scheme programming. +* R5RS Index:: +* Guile Extensions Index:: + +Part III: Guile Modules + +* SLIB:: Using the SLIB Scheme library. +* POSIX:: POSIX system calls and networking. +* Expect:: Controlling interactive programs with Guile. +* The Scheme shell (scsh):: + The SCSH compatibility module has been made an + add-on, so maybe it shouldn't be documented here + (though it is nice to have a link from here to the + Guile-scsh manual, if one exists). +* Tcl/Tk Interface:: + +Part IV: Guile Scripting + +* Guile Scripting:: How to write Guile scripts. + +Part V: Extending Applications Using Guile + +* Libguile Intro:: Using Guile as an extension language. +* GH:: GH: a portable C to Scheme interface. +* Data Representation:: Data representation in Guile. +* Scheme Primitives:: Writing Scheme primitives in C. +* I/O Extensions:: Using and extending ports in C. +* Handling Errors:: How to handle errors in C code. + +Appendices + +* Obtaining and Installing Guile:: +* Debugger User Interface:: + +Indices + +* Concept Index:: +* Procedure Index:: +* Variable Index:: +* Type Index:: + +@end menu + +@include preface.texi + +@c preliminary +@iftex +@page +@unnumbered{Part I: Introduction to Guile} +@end iftex + +@include intro.texi + +@c programming in Scheme +@iftex +@page +@unnumbered{Part II: Guile Scheme} +@end iftex + +@include scheme-intro.texi +@include scheme-ideas.texi +@include scheme-data.texi +@include scheme-procedures.texi +@include scheme-utility.texi +@include scheme-binding.texi +@include scheme-control.texi +@include scheme-io.texi +@include scheme-evaluation.texi +@include scheme-memory.texi +@include scheme-modules.texi +@include scheme-scheduling.texi +@c object orientation support here +@include scheme-options.texi +@include scheme-translation.texi +@include scheme-debug.texi +@include deprecated.texi +@include scheme-reading.texi +@include scheme-indices.texi + +@c Unix system interface +@iftex +@page +@unnumbered{Part III: Guile Modules} +@end iftex + +@include slib.texi +@include posix.texi +@include expect.texi +@include scsh.texi +@include tcltk.texi + +@c Guile as an scripting language +@iftex +@page +@unnumbered{Part IV: Guile Scripting} +@end iftex + +@include scripts.texi + +@c Guile as an extension language +@iftex +@page +@unnumbered{Part V: Extending Applications Using Guile} +@end iftex + +@include extend.texi +@include gh.texi +@include data-rep.texi +@include scm.texi + +@c Appendices +@iftex +@page +@unnumbered{Appendices} +@end iftex + +@include appendices.texi + +@c Indices +@iftex +@page +@unnumbered{Indices} +@end iftex + +@include indices.texi + +@contents + +@bye diff --git a/doc/hierarchy.eps b/doc/hierarchy.eps new file mode 100644 index 000000000..e69de29bb diff --git a/doc/hierarchy.txt b/doc/hierarchy.txt new file mode 100644 index 000000000..e69de29bb diff --git a/doc/indices.texi b/doc/indices.texi new file mode 100644 index 000000000..69760b0bb --- /dev/null +++ b/doc/indices.texi @@ -0,0 +1,31 @@ +@node Concept Index +@unnumbered Concept Index +@printindex cp + + +@node Procedure Index +@unnumbered Procedure Index +This is an alphabetical list of all the procedures and macros in Guile. +[[Remind people to look for functions under their Scheme names as well +as their C names.]] +@printindex fn + + +@node Variable Index +@unnumbered Variable Index +This is an alphabetical list of all the important variables and +constants in Guile. +[[Remind people to look for variables under their Scheme names as well +as their C names.]] +@printindex vr + + +@c Spell out this node fully, because it is the last real node +@c in the top-level menu. Leaving off the pointers here causes +@c spurious makeinfo errors. +@node Type Index +@unnumbered Type Index +This is an alphabetical list of all the important data types defined in +the Guile Programmers Manual. +@printindex tp + diff --git a/doc/intro.texi b/doc/intro.texi new file mode 100644 index 000000000..e126fbcf8 --- /dev/null +++ b/doc/intro.texi @@ -0,0 +1,579 @@ +@c $Id: intro.texi,v 1.1 2001-03-09 08:21:59 ossau Exp $ + +@page +@node What is Guile? +@chapter What is Guile? + +Guile is an interpreter for the Scheme programming language, packaged +for use in a wide variety of environments. Guile implements Scheme as +described in the +@tex +Revised$^5$ +@end tex +@ifinfo +Revised^5 +@end ifinfo +Report on the Algorithmic Language Scheme (usually known as R5RS), +providing clean and general data and control structures. Guile goes +beyond the rather austere language presented in R5RS, extending it with +a module system, full access to POSIX system calls, networking support, +multiple threads, dynamic linking, a foreign function call interface, +powerful string processing, and many other features needed for +programming in the real world. + +Like a shell, Guile can run interactively, reading expressions from the +user, evaluating them, and displaying the results, or as a script +interpreter, reading and executing Scheme code from a file. However, +Guile is also packaged as an object library, allowing other applications +to easily incorporate a complete Scheme interpreter. An application can +use Guile as an extension language, a clean and powerful configuration +language, or as multi-purpose ``glue'', connecting primitives provided +by the application. It is easy to call Scheme code from C code and vice +versa, giving the application designer full control of how and when to +invoke the interpreter. Applications can add new functions, data types, +control structures, and even syntax to Guile, creating a domain-specific +language tailored to the task at hand, but based on a robust language +design. + +Guile's module system allows one to break up a large program into +manageable sections with well-defined interfaces between them. Modules +may contain a mixture of interpreted and compiled code; Guile can use +either static or dynamic linking to incorporate compiled code. Modules +also encourage developers to package up useful collections of routines +for general distribution; as of this writing, one can find Emacs +interfaces, database access routines, compilers, GUI toolkit interfaces, +and HTTP client functions, among others. + +In the future, we hope to expand Guile to support other languages like +Tcl and Perl by translating them to Scheme code. This means that users +can program applications which use Guile in the language of their +choice, rather than having the tastes of the application's author +imposed on them. + + +@page +@node Whirlwind Tour +@chapter A Whirlwind Tour + +This chapter presents a quick tour of all the ways that Guile can be +used. + +@menu +* Running Guile Interactively:: +* Guile Scripts:: +* Linking Programs With Guile:: +* Writing Guile Modules:: +@end menu + + +@node Running Guile Interactively +@section Running Guile Interactively + +In its simplest form, Guile acts as an interactive interpreter for the +Scheme programming language, reading and evaluating Scheme expressions +the user enters from the terminal. Here is a sample interaction between +Guile and a user; the user's input appears after the @code{$} and +@code{guile>} prompts: + +@example +$ guile +guile> (+ 1 2 3) ; add some numbers +6 +guile> (define (factorial n) ; define a function + (if (zero? n) 1 (* n (factorial (- n 1))))) +guile> (factorial 20) +2432902008176640000 +guile> (getpwnam "jimb") ; find my entry in /etc/passwd +#("jimb" ".0krIpK2VqNbU" 4008 10 "Jim Blandy" "/u/jimb" + "/usr/local/bin/bash") +guile> @kbd{C-d} +$ +@end example + +@c [[When we get a fancier read-eval-print loop, with features for bouncing +@c around among modules, referring to the value of the last expression, +@c etc. then this section will get longer.]] + + +@node Guile Scripts +@section Guile Scripts + +Like AWK, Perl, or any shell, Guile can interpret script files. A Guile +script is simply a file of Scheme code with some extra information at +the beginning which tells the operating system how to invoke Guile, and +then tells Guile how to handle the Scheme code. + +Before we present the details, here is a trivial Guile script: + +@example +#!/usr/local/bin/guile -s +!# +(display "Hello, world!") +(newline) +@end example + +@menu +* The Top of a Script File:: How to start a Guile script. +* Scripting Examples:: Simple Guile scripts, explained. +@end menu + + +@node The Top of a Script File +@subsection The Top of a Script File + +The first line of a Guile script must tell the operating system to use +Guile to evaluate the script, and then tell Guile how to go about doing +that. Here is the simplest case: + +@itemize @bullet + +@item +The first two characters of the file must be @samp{#!}. + +The operating system interprets this to mean that the rest of the line +is the name of an executable that can interpret the script. Guile, +however, interprets these characters as the beginning of a multi-line +comment, terminated by the characters @samp{!#} on a line by themselves. +(This is an extension to the syntax described in R5RS, added to support +shell scripts.) + +@item +Immediately after those two characters must come the full pathname to +the Guile interpreter. On most systems, this would be +@samp{/usr/local/bin/guile}. + +@item +Then must come a space, followed by a command-line argument to pass to +Guile; this should be @samp{-s}. This switch tells Guile to run a +script, instead of soliciting the user for input from the terminal. +There are more elaborate things one can do here; see @ref{The Meta +Switch}. + +@item +Follow this with a newline. + +@item +The second line of the script should contain only the characters +@samp{!#} --- just like the top of the file, but reversed. The +operating system never reads this far, but Guile treats this as the end +of the comment begun on the first line by the @samp{#!} characters. + +@item +The rest of the file should be a Scheme program. + +@end itemize + +Guile reads the program, evaluating expressions in the order that they +appear. Upon reaching the end of the file, Guile exits. + +The function @code{command-line} returns the name of the script file and +any command-line arguments passed by the user, as a list of strings. + +For example, consider the following script file: +@example +#!/usr/local/bin/guile -s +!# +(write (command-line)) +(newline) +@end example + +If you put that text in a file called @file{foo} in the current +directory, then you could make it executable and try it out like this: +@example +$ chmod a+x foo +$ ./foo +("./foo") +$ ./foo bar baz +("./foo" "bar" "baz") +$ +@end example + +As another example, here is a simple replacement for the POSIX +@code{echo} command: +@example +#!/usr/local/bin/guile -s +!# +(for-each (lambda (s) (display s) (display " ")) + (cdr (command-line))) +(newline) +@end example + +@deffn procedure command-line +@deffnx primitive program-arguments +Return a list of the command-line arguments passed to the currently +running program. If the program invoked Guile with the @samp{-s}, +@samp{-c} or @samp{--} switches, these procedures ignore everything up +to and including those switches. +@end deffn + + +@node Scripting Examples +@subsection Scripting Examples + +To start with, here are some examples of invoking Guile directly: + +@table @code + +@item guile -- a b c +Run Guile interactively; @code{(command-line)} will return @* +@code{("/usr/local/bin/guile" "a" "b" "c")}. + +@item guile -s /u/jimb/ex2 a b c +Load the file @file{/u/jimb/ex2}; @code{(command-line)} will return @* +@code{("/u/jimb/ex2" "a" "b" "c")}. + +@item guile -c '(write %load-path) (newline)' +Write the value of the variable @code{%load-path}, print a newline, +and exit. + +@item guile -e main -s /u/jimb/ex4 foo +Load the file @file{/u/jimb/ex4}, and then call the function +@code{main}, passing it the list @code{("/u/jimb/ex4" "foo")}. + +@item guile -l first -ds -l last -s script +Load the files @file{first}, @file{script}, and @file{last}, in that +order. The @code{-ds} switch says when to process the @code{-s} +switch. For a more motivated example, see the scripts below. + +@end table + + +Here is a very simple Guile script: +@example +#!/usr/local/bin/guile -s +!# +(display "Hello, world!") +(newline) +@end example +The first line marks the file as a Guile script. When the user invokes +it, the system runs @file{/usr/local/bin/guile} to interpret the script, +passing @code{-s}, the script's filename, and any arguments given to the +script as command-line arguments. When Guile sees @code{-s +@var{script}}, it loads @var{script}. Thus, running this program +produces the output: +@example +Hello, world! +@end example + +Here is a script which prints the factorial of its argument: +@example +#!/usr/local/bin/guile -s +!# +(define (fact n) + (if (zero? n) 1 + (* n (fact (- n 1))))) + +(display (fact (string->number (cadr (command-line))))) +(newline) +@end example +In action: +@example +$ fact 5 +120 +$ +@end example + +However, suppose we want to use the definition of @code{fact} in this +file from another script. We can't simply @code{load} the script file, +and then use @code{fact}'s definition, because the script will try to +compute and display a factorial when we load it. To avoid this problem, +we might write the script this way: + +@example +#!/usr/local/bin/guile \ +-e main -s +!# +(define (fact n) + (if (zero? n) 1 + (* n (fact (- n 1))))) + +(define (main args) + (display (fact (string->number (cadr args)))) + (newline)) +@end example +This version packages the actions the script should perform in a +function, @code{main}. This allows us to load the file purely for its +definitions, without any extraneous computation taking place. Then we +used the meta switch @code{\} and the entry point switch @code{-e} to +tell Guile to call @code{main} after loading the script. +@example +$ fact 50 +30414093201713378043612608166064768844377641568960512000000000000 +@end example + +Suppose that we now want to write a script which computes the +@code{choose} function: given a set of @var{m} distinct objects, +@code{(choose @var{n} @var{m})} is the number of distinct subsets +containing @var{n} objects each. It's easy to write @code{choose} given +@code{fact}, so we might write the script this way: +@example +#!/usr/local/bin/guile \ +-l fact -e main -s +!# +(define (choose n m) + (/ (fact m) (* (fact (- m n)) (fact n)))) + +(define (main args) + (let ((n (string->number (cadr args))) + (m (string->number (caddr args)))) + (display (choose n m)) + (newline))) +@end example + +The command-line arguments here tell Guile to first load the file +@file{fact}, and then run the script, with @code{main} as the entry +point. In other words, the @code{choose} script can use definitions +made in the @code{fact} script. Here are some sample runs: +@example +$ choose 0 4 +1 +$ choose 1 4 +4 +$ choose 2 4 +6 +$ choose 3 4 +4 +$ choose 4 4 +1 +$ choose 50 100 +100891344545564193334812497256 +@end example + + +@node Linking Programs With Guile +@section Linking Programs With Guile + +The Guile interpreter is available as an object library, to be linked +into applications using Scheme as a configuration or extension +language. This chapter covers the mechanics of linking your program +with Guile on a typical POSIX system. + +Parts III and IV of this manual describe the C functions Guile provides. +Furthermore, any Scheme function described in this manual as a +``Primitive'' is also callable from C; see @ref{Scheme Primitives}. + +The header file @code{} provides declarations for all of +Guile's functions and constants. You should @code{#include} it at the +head of any C source file that uses identifiers described in this +manual. + +Once you've compiled your source files, you can link them against Guile +by passing the flag @code{-lguile} to your linker. If you installed +Guile with multi-thread support (by passing @code{--enable-threads} to +the @code{configure} script), you may also need to link against the +QuickThreads library, @code{-lqt}. Guile refers to various mathematical +functions, so you will probably need to link against the mathematical +library, @code{-lm}, as well. + +@menu +* Guile Initialization Functions:: What to call first. +* A Sample Guile Main Program:: Sources and makefiles. +@end menu + + +@node Guile Initialization Functions +@subsection Guile Initialization Functions + +To initialize Guile, use this function: + +@deftypefun void scm_boot_guile (int @var{argc}, char **@var{argv}, void (*@var{main_func}) (), void *@var{closure}) +Initialize the Guile Scheme interpreter. Then call @var{main_func}, +passing it @var{closure}, @var{argc}, and @var{argv}. @var{main_func} +should do all the work of the program (initializing other packages, +defining application-specific functions, reading user input, and so on) +before returning. When @var{main_func} returns, call @code{exit (0)}; +@code{scm_boot_guile} never returns. If you want some other exit value, +have @var{main_func} call exit itself. + +@code{scm_boot_guile} arranges for the Scheme @code{command-line} +function to return the strings given by @var{argc} and @var{argv}. If +@var{main_func} modifies @var{argc} or @var{argv}, it should call +@code{scm_set_program_arguments} with the final list, so Scheme code +will know which arguments have been processed. + +@code{scm_boot_guile} establishes a catch-all error handler which prints +an error message and exits the process. This means that Guile exits in +a coherent way if a system error occurs and the user isn't prepared to +handle it. If the user doesn't like this behavior, they can establish +their own universal catcher in @var{main_func} to shadow this one. + +Why must the caller do all the real work from @var{main_func}? Guile's +garbage collector assumes that all local variables which reference +Scheme objects will be above @code{scm_boot_guile}'s stack frame on the +stack. If you try to manipulate Scheme objects after this function +returns, it's the luck of the draw whether Guile's storage manager will +be able to find the objects you allocate. So, @code{scm_boot_guile} +function exits, rather than returning, to discourage you from making +that mistake. +@end deftypefun + +One common way to use Guile is to write a set of C functions which +perform some useful task, make them callable from Scheme, and then link +the program with Guile. This yields a Scheme interpreter just like +@code{guile}, but augmented with extra functions for some specific +application --- a special-purpose scripting language. + +In this situation, the application should probably process its +command-line arguments in the same manner as the stock Guile +interpreter. To make that straightforward, Guile provides this +function: + +@deftypefun void scm_shell (int @var{argc}, char **@var{argv}) +Process command-line arguments in the manner of the @code{guile} +executable. This includes loading the normal Guile initialization +files, interacting with the user or running any scripts or expressions +specified by @code{-s} or @code{-e} options, and then exiting. +@xref{Invoking Guile}, for more details. + +Since this function does not return, you must do all +application-specific initialization before calling this function. + +If you do not use this function to start Guile, you are responsible for +making sure Guile's usual initialization files, @file{init.scm} and +@file{ice-9/boot-9.scm}, get loaded. This will change soon. +@end deftypefun + + +@node A Sample Guile Main Program +@subsection A Sample Guile Main Program + +Here is @file{simple-guile.c}, source code for a @code{main} and an +@code{inner_main} function that will produce a complete Guile +interpreter. + +@example +/* simple-guile.c --- how to start up the Guile + interpreter from C code. */ + +/* Get declarations for all the scm_ functions. */ +#include + +static void +inner_main (void *closure, int argc, char **argv) +@{ + /* module initializations would go here */ + scm_shell (argc, argv); +@} + +int +main (int argc, char **argv) +@{ + scm_boot_guile (argc, argv, inner_main, 0); + return 0; /* never reached */ +@} +@end example + +The @code{main} function calls @code{scm_boot_guile} to initialize +Guile, passing it @code{inner_main}. Once @code{scm_boot_guile} is +ready, it invokes @code{inner_main}, which calls @code{scm_shell} to +process the command-line arguments in the usual way. + +Here is a Makefile which you can use to compile the above program. +@example +# Use GCC, if you have it installed. +CC=gcc + +# Tell the C compiler where to find and -lguile. +CFLAGS=-I/usr/local/include -L/usr/local/lib + +# Include -lqt and -lrx if they are present on your system. +LIBS=-lguile -lqt -lrx -lm + +simple-guile: simple-guile.o + $@{CC@} $@{CFLAGS@} simple-guile.o $@{LIBS@} -o simple-guile +simple-guile.o: simple-guile.c + $@{CC@} -c $@{CFLAGS@} simple-guile.c +@end example + +If you are using the GNU Autoconf package to make your application more +portable, Autoconf will settle many of the details in the Makefile above +automatically, making it much simpler and more portable; we recommend +using Autoconf with Guile. Here is a @file{configure.in} file for +@code{simple-guile}, which Autoconf can use as a template to generate a +@code{configure} script: +@example +AC_INIT(simple-guile.c) + +# Find a C compiler. +AC_PROG_CC + +# Check for libraries. +AC_CHECK_LIB(m, sin) +AC_CHECK_LIB(rx, regcomp) +AC_CHECK_LIB(qt, main) +AC_CHECK_LIB(guile, scm_boot_guile) + +# Generate a Makefile, based on the results. +AC_OUTPUT(Makefile) +@end example + +Here is a @code{Makefile.in} template, from which the @code{configure} +script produces a Makefile customized for the host system: +@example +# The configure script fills in these values. +CC=@@CC@@ +CFLAGS=@@CFLAGS@@ +LIBS=@@LIBS@@ + +simple-guile: simple-guile.o + $@{CC@} $@{CFLAGS@} simple-guile.o $@{LIBS@} -o simple-guile +simple-guile.o: simple-guile.c + $@{CC@} -c $@{CFLAGS@} simple-guile.c +@end example + +The developer should use Autoconf to generate the @file{configure} +script from the @file{configure.in} template, and distribute +@file{configure} with the application. Here's how a user might go about +building the application: + +@example +$ ls +Makefile.in configure* configure.in simple-guile.c +$ ./configure +creating cache ./config.cache +checking for gcc... gcc +checking whether the C compiler (gcc ) works... yes +checking whether the C compiler (gcc ) is a cross-compiler... no +checking whether we are using GNU C... yes +checking whether gcc accepts -g... yes +checking for sin in -lm... yes +checking for regcomp in -lrx... yes +checking for main in -lqt... yes +checking for scm_boot_guile in -lguile... yes +updating cache ./config.cache +creating ./config.status +creating Makefile +$ make +gcc -c -g -O2 simple-guile.c +gcc -g -O2 simple-guile.o -lguile -lqt -lrx -lm -o simple-guile +$ ./simple-guile +guile> (+ 1 2 3) +6 +guile> (getpwnam "jimb") +#("jimb" "83Z7d75W2tyJQ" 4008 10 "Jim Blandy" "/u/jimb" + "/usr/local/bin/bash") +guile> (exit) +$ +@end example + + +@node Writing Guile Modules +@section Writing Guile Modules + +[to be written] + + +@page +@node Reporting Bugs +@chapter Reporting Bugs + +Any problems with the installation should be reported to +@email{bug-guile@@gnu.org}. + +[[how about an explanation of what makes a good bug report?]] +[[don't complain to us about problems with contributed modules?]] + + +@c Local Variables: +@c TeX-master: "guile.texi" +@c End: diff --git a/doc/mbapi.texi b/doc/mbapi.texi new file mode 100644 index 000000000..3f53ccdb2 --- /dev/null +++ b/doc/mbapi.texi @@ -0,0 +1,987 @@ +\input texinfo +@setfilename mbapi.info +@settitle Multibyte API +@setchapternewpage off + +@c Open issues: + +@c What's the best way to report errors? Should functions return a +@c magic value, according to C tradition, or should they signal a +@c Guile exception? + +@c + + +@node Working With Multibyte Strings in C +@chapter Working With Multibyte Strings in C + +Guile allows strings to contain characters drawn from a wide variety of +languages, including many Asian, Eastern European, and Middle Eastern +languages, in a uniform and unrestricted way. The string representation +normally used in C code --- an array of @sc{ASCII} characters --- is not +sufficient for Guile strings, since they may contain characters not +present in @sc{ASCII}. + +Instead, Guile uses a very large character set, and encodes each +character as a sequence of one or more bytes. We call this +variable-width encoding a @dfn{multibyte} encoding. Guile uses this +single encoding internally for all strings, symbol names, error +messages, etc., and performs appropriate conversions upon input and +output. + +The use of this variable-width encoding is almost invisible to Scheme +code. Strings are still indexed by character number, not by byte +offset; @code{string-length} still returns the length of a string in +characters, not in bytes. @code{string-ref} and @code{string-set!} are +no longer guaranteed to be constant-time operations, but Guile uses +various strategies to reduce the impact of this change. + +However, the encoding is visible via Guile's C interface, which gives +the user direct access to a string's bytes. This chapter explains how +to work with Guile multibyte text in C code. Since variable-width +encodings are clumsier to work with than simple fixed-width encodings, +Guile provides a set of standard macros and functions for manipulating +multibyte text to make the job easier. Furthermore, Guile makes some +promises about the encoding which you can use in writing your own text +processing code. + +While we discuss guaranteed properties of Guile's encoding, and provide +functions to operate on its character set, we do not actually specify +either the character set or encoding here. This is because we expect +both of them to change in the future: currently, Guile uses the same +encoding as GNU Emacs 20.4, but we hope to change Guile (and GNU Emacs +as well) to use Unicode and UTF-8, with some extensions. This will make +it more comfortable to use Guile with other systems which use UTF-8, +like the GTk user interface toolkit. + +@menu +* Multibyte String Terminology:: +* Promised Properties of the Guile Multibyte Encoding:: +* Functions for Operating on Multibyte Text:: +* Multibyte Text Processing Errors:: +* Why Guile Does Not Use a Fixed-Width Encoding:: +@end menu + + +@node Multibyte String Terminology, Promised Properties of the Guile Multibyte Encoding, Working With Multibyte Strings in C, Working With Multibyte Strings in C +@section Multibyte String Terminology + +In the descriptions which follow, we make the following definitions: +@table @dfn + +@item byte +A @dfn{byte} is a number between 0 and 255. It has no inherent textual +interpretation. So 65 is a byte, not a character. + +@item character +A @dfn{character} is a unit of text. It has no inherent numeric value. +@samp{A} and @samp{.} are characters, not bytes. (This is different +from the C language's definition of @dfn{character}; in this chapter, we +will always use a phrase like ``the C language's @code{char} type'' when +that's what we mean.) + +@item character set +A @dfn{character set} is an invertible mapping between numbers and a +given set of characters. @sc{ASCII} is a character set assigning +characters to the numbers 0 through 127. It maps @samp{A} onto the +number 65, and @samp{.} onto 46. + +Note that a character set maps characters onto numbers, @emph{not +necessarily} onto bytes. For example, the Unicode character set maps +the Greek lower-case @samp{alpha} character onto the number 945, which +is not a byte. + +(This is what Internet standards would call a "coding character set".) + +@item encoding +An encoding maps numbers onto sequences of bytes. For example, the +UTF-8 encoding, defined in the Unicode Standard, would map the number +945 onto the sequence of bytes @samp{206 177}. When using the +@sc{ASCII} character set, every number assigned also happens to be a +byte, so there is an obvious trivial encoding for @sc{ASCII} in bytes. + +(This is what Internet standards would call a "character encoding +scheme".) + +@end table + +Thus, to turn a character into a sequence of bytes, you need a character +set to assign a number to that character, and then an encoding to turn +that number into a sequence of bytes. + +Likewise, to interpret a sequence of bytes as a sequence of characters, +you use an encoding to extract a sequence of numbers from the bytes, and +then a character set to turn the numbers into characters. + +Errors can occur while carrying out either of these processes. For +example, under a particular encoding, a given string of bytes might not +correspond to any number. For example, the byte sequence @samp{128 128} +is not a valid encoding of any number under UTF-8. + +Having carefully defined our terminology, we will now abuse it. + +We will sometimes use the word @dfn{character} to refer to the number +assigned to a character by a character set, in contexts where it's +obvious we mean a number. + +Sometimes there is a close association between a particular encoding and +a particular character set. Thus, we may sometimes refer to the +character set and encoding together as an @dfn{encoding}. + + +@node Promised Properties of the Guile Multibyte Encoding, Functions for Operating on Multibyte Text, Multibyte String Terminology, Working With Multibyte Strings in C +@section Promised Properties of the Guile Multibyte Encoding + +Internally, Guile uses a single encoding for all text --- symbols, +strings, error messages, etc. Here we list a number of helpful +properties of Guile's encoding. It is correct to write code which +assumes these properties; code which uses these assumptions will be +portable to all future versions of Guile, as far as we know. + +@b{Every @sc{ASCII} character is encoded as a single byte from 0 to 127, in +the obvious way.} This means that a standard C string containing only +@sc{ASCII} characters is a valid Guile string (except for the terminator; +Guile strings store the length explicitly, so they can contain null +characters). + +@b{The encodings of non-@sc{ASCII} characters use only bytes between 128 +and 255.} That is, when we turn a non-@sc{ASCII} character into a +series of bytes, none of those bytes can ever be mistaken for the +encoding of an @sc{ASCII} character. This means that you can search a +Guile string for an @sc{ASCII} character using the standard +@code{memchr} library function. By extension, you can search for an +@sc{ASCII} substring in a Guile string using a traditional substring +search algorithm --- you needn't add special checks to verify encoding +boundaries, etc. + +@b{No character encoding is a subsequence of any other character +encoding.} (This is just a stronger version of the previous promise.) +This means that you can search for occurrences of one Guile string +within another Guile string just as if they were raw byte strings. You +can use the stock @code{memmem} function (provided on GNU systems, at +least) for such searches. If you don't need the ability to represent +null characters in your text, you can still use null-termination for +strings, and use the traditional string-handling functions like +@code{strlen}, @code{strstr}, and @code{strcat}. + +@b{You can always determine the full length of a character's encoding +from its first byte.} Guile provides the macro @code{scm_mb_len} which +computes the encoding's length from its first byte. Given the first +rule, you can see that @code{scm_mb_len (@var{b})}, for any @code{0 <= +@var{b} <= 127}, returns 1. + +@b{Given an arbitrary byte position in a Guile string, you can always +find the beginning and end of the character containing that byte without +scanning too far in either direction.} This means that, if you are sure +a byte sequence is a valid encoding of a character sequence, you can +find character boundaries without keeping track of the beginning and +ending of the overall string. This promise relies on the fact that, in +addition to storing the string's length explicitly, Guile always either +terminates the string's storage with a zero byte, or shares it with +another string which is terminated this way. + + +@node Functions for Operating on Multibyte Text, Multibyte Text Processing Errors, Promised Properties of the Guile Multibyte Encoding, Working With Multibyte Strings in C +@section Functions for Operating on Multibyte Text + +Guile provides a variety of functions, variables, and types for working +with multibyte text. + +@menu +* Basic Multibyte Character Processing:: +* Finding Character Encoding Boundaries:: +* Multibyte String Functions:: +* Exchanging Guile Text With the Outside World in C:: +* Implementing Your Own Text Conversions:: +@end menu + + +@node Basic Multibyte Character Processing, Finding Character Encoding Boundaries, Functions for Operating on Multibyte Text, Functions for Operating on Multibyte Text +@subsection Basic Multibyte Character Processing + +Here are the essential types and functions for working with Guile text. +Guile uses the C type @code{unsigned char *} to refer to text encoded +with Guile's encoding. + +Note that any operation marked here as a ``Libguile Macro'' might +evaluate its argument multiple times. + +@deftp {Libguile Type} scm_char_t +This is a signed integral type large enough to hold any character in +Guile's character set. All character numbers are positive. +@end deftp + +@deftypefn {Libguile Macro} scm_char_t scm_mb_get (const unsigned char *@var{p}) +Return the character whose encoding starts at @var{p}. If @var{p} does +not point at a valid character encoding, the behavior is undefined. +@end deftypefn + +@deftypefn {Libguile Macro} int scm_mb_put (unsigned char *@var{p}, scm_char_t @var{c}) +Place the encoded form of the Guile character @var{c} at @var{p}, and +return its length in bytes. If @var{c} is not a Guile character, the +behavior is undefined. +@end deftypefn + +@deftypevr {Libguile Constant} int scm_mb_max_len +The maximum length of any character's encoding, in bytes. You may +assume this is relatively small --- less than a dozen or so. +@end deftypevr + +@deftypefn {Libguile Macro} int scm_mb_len (unsigned char @var{b}) +If @var{b} is the first byte of a character's encoding, return the full +length of the character's encoding, in bytes. If @var{b} is not a valid +leading byte, the behavior is undefined. +@end deftypefn + +@deftypefn {Libguile Macro} int scm_mb_char_len (scm_char_t @var{c}) +Return the length of the encoding of the character @var{c}, in bytes. +If @var{c} is not a valid Guile character, the behavior is undefined. +@end deftypefn + +@deftypefn {Libguile Function} scm_char_t scm_mb_get_func (const unsigned char *@var{p}) +@deftypefnx {Libguile Function} int scm_mb_put_func (unsigned char *@var{p}, scm_char_t @var{c}) +@deftypefnx {Libguile Function} int scm_mb_len_func (unsigned char @var{b}) +@deftypefnx {Libguile Function} int scm_mb_char_len_func (scm_char_t @var{c}) +These are functions identical to the corresponding macros. You can use +them in situations where the overhead of a function call is acceptable, +and the cleaner semantics of function application are desireable. +@end deftypefn + + +@node Finding Character Encoding Boundaries, Multibyte String Functions, Basic Multibyte Character Processing, Functions for Operating on Multibyte Text +@subsection Finding Character Encoding Boundaries + +These are functions for finding the boundaries between characters in +multibyte text. + +Note that any operation marked here as a ``Libguile Macro'' might +evaluate its argument multiple times, unless the definition promises +otherwise. + +@deftypefn {Libguile Macro} int scm_mb_boundary_p (const unsigned char *@var{p}) +Return non-zero iff @var{p} points to the start of a character in +multibyte text. + +This macro will evaluate its argument only once. +@end deftypefn + +@deftypefn {Libguile Function} {const unsigned char *} scm_mb_floor (const unsigned char *@var{p}) +``Round'' @var{p} to the previous character boundary. That is, if +@var{p} points to the middle of the encoding of a Guile character, +return a pointer to the first byte of the encoding. If @var{p} points +to the start of the encoding of a Guile character, return @var{p} +unchanged. +@end deftypefn + +@deftypefn {libguile Function} {const unsigned char *} scm_mb_ceiling (const unsigned char *@var{p}) +``Round'' @var{p} to the next character boundary. That is, if @var{p} +points to the middle of the encoding of a Guile character, return a +pointer to the first byte of the encoding of the next character. If +@var{p} points to the start of the encoding of a Guile character, return +@var{p} unchanged. +@end deftypefn + +Note that it is usually not friendly for functions to silently correct +byte offsets that point into the middle of a character's encoding. Such +offsets almost always indicate a programming error, and they should be +reported as early as possible. So, when you write code which operates +on multibyte text, you should not use functions like these to ``clean +up'' byte offsets which the originator believes to be correct; instead, +your code should signal a @code{text:not-char-boundary} error as soon as +it detects an invalid offset. @xref{Multibyte Text Processing Errors}. + + +@node Multibyte String Functions, Exchanging Guile Text With the Outside World in C, Finding Character Encoding Boundaries, Functions for Operating on Multibyte Text +@subsection Multibyte String Functions + +These functions allow you to operate on multibyte strings: sequences of +character encodings. + +@deftypefn {Libguile Function} int scm_mb_count (const unsigned char *@var{p}, int @var{len}) +Return the number of Guile characters encoded by the @var{len} bytes at +@var{p}. + +If the sequence contains any invalid character encodings, or ends with +an incomplete character encoding, signal a @code{text:bad-encoding} +error. +@end deftypefn + +@deftypefn {Libguile Macro} scm_char_t scm_mb_walk (unsigned char **@var{pp}) +Return the character whose encoding starts at @code{*@var{pp}}, and +advance @code{*@var{pp}} to the start of the next character. Return -1 +if @code{*@var{pp}} does not point to a valid character encoding. +@end deftypefn + +@deftypefn {Libguile Function} {const unsigned char *} scm_mb_prev (const unsigned char *@var{p}) +If @var{p} points to the middle of the encoding of a Guile character, +return a pointer to the first byte of the encoding. If @var{p} points +to the start of the encoding of a Guile character, return the start of +the previous character's encoding. + +This is like @code{scm_mb_floor}, but the returned pointer will always +be before @var{p}. If you use this function to drive an iteration, it +guarantees backward progress. +@end deftypefn + +@deftypefn {Libguile Function} {const unsigned char *} scm_mb_next (const unsigned char *@var{p}) +If @var{p} points to the encoding of a Guile character, return a pointer +to the first byte of the encoding of the next character. + +This is like @code{scm_mb_ceiling}, but the returned pointer will always +be after @var{p}. If you use this function to drive an iteration, it +guarantees forward progress. +@end deftypefn + +@deftypefn {Libguile Function} {const unsigned char *} scm_mb_index (const unsigned char *@var{p}, int @var{len}, int @var{i}) +Assuming that the @var{len} bytes starting at @var{p} are a +concatenation of valid character encodings, return a pointer to the +start of the @var{i}'th character encoding in the sequence. + +This function scans the sequence from the beginning to find the +@var{i}'th character, and will generally require time proportional to +the distance from @var{p} to the returned address. + +If the sequence contains any invalid character encodings, or ends with +an incomplete character encoding, signal a @code{text:bad-encoding} +error. +@end deftypefn + +It is common to process the characters in a string from left to right. +However, if you fetch each character using @code{scm_mb_index}, each +call will scan the text from the beginning, so your loop will require +time proportional to at least the square of the length of the text. To +avoid this poor performance, you can use an @code{scm_mb_cache} +structure and the @code{scm_mb_index_cached} macro. + +@deftp {Libguile Type} {struct scm_mb_cache} +This structure holds information that allows a string scanning operation +to use the results from a previous scan of the string. It has the +following members: +@table @code + +@item character +An index, in characters, into the string. + +@item byte +The index, in bytes, of the start of that character. + +@end table + +In other words, @code{byte} is the byte offset of the +@code{character}'th character of the string. Note that if @code{byte} +and @code{character} are equal, then all characters before that point +must have encodings exactly one byte long, and the string can be indexed +normally. + +All elements of a @code{struct scm_mb_cache} structure should be +initialized to zero before its first use, and whenever the string's text +changes. +@end deftp + +@deftypefn {Libguile Macro} const unsigned char *scm_mb_index_cached (const unsigned char *@var{p}, int @var{len}, int @var{i}, struct scm_mb_cache *@var{cache}) +@deftypefnx {Libguile Function} const unsigned char *scm_mb_index_cached_func (const unsigned char *@var{p}, int @var{len}, int @var{i}, struct scm_mb_cache *@var{cache}) +This macro and this function are identical to @code{scm_mb_index}, +except that they may consult and update *@var{cache} in order to avoid +scanning the string from the beginning. @code{scm_mb_index_cached} is a +macro, so it may have less overhead than +@code{scm_mb_index_cached_func}, but it may evaluate its arguments more +than once. + +Using @code{scm_mb_index_cached} or @code{scm_mb_index_cached_func}, you +can scan a string from left to right, or from right to left, in time +proportional to the length of the string. As long as each character +fetched is less than some constant distance before or after the previous +character fetched with @var{cache}, each access will require constant +time. +@end deftypefn + +Guile also provides functions to convert between an encoded sequence of +characters, and an array of @code{scm_char_t} objects. + +@deftypefn {Libguile Function} scm_char_t *scm_mb_multibyte_to_fixed (const unsigned char *@var{p}, int @var{len}, int *@var{result_len}) +Convert the variable-width text in the @var{len} bytes at @var{p} +to an array of @code{scm_char_t} values. Return a pointer to the array, +and set @code{*@var{result_len}} to the number of elements it contains. +The returned array is allocated with @code{malloc}, and it is the +caller's responsibility to free it. + +If the text is not a sequence of valid character encodings, this +function will signal a @code{text:bad-encoding} error. +@end deftypefn + +@deftypefn {Libguile Function} unsigned char *scm_mb_fixed_to_multibyte (const scm_char_t *@var{fixed}, int @var{len}, int *@var{result_len}) +Convert the array of @code{scm_char_t} values to a sequence of +variable-width character encodings. Return a pointer to the array of +bytes, and set @code{*@var{result_len}} to its length, in bytes. + +The returned byte sequence is terminated with a zero byte, which is not +counted in the length returned in @code{*@var{result_len}}. + +The returned byte sequence is allocated with @code{malloc}; it is the +caller's responsibility to free it. + +If the text is not a sequence of valid character encodings, this +function will signal a @code{text:bad-encoding} error. +@end deftypefn + + +@node Exchanging Guile Text With the Outside World in C, Implementing Your Own Text Conversions, Multibyte String Functions, Functions for Operating on Multibyte Text +@subsection Exchanging Guile Text With the Outside World in C + +[[This is kind of a heavy-weight model, given that one end of the +conversion is always going to be the Guile encoding. Any way to shorten +things a bit?]] + +Guile provides functions for converting between Guile's internal text +representation and encodings popular in the outside world. These +functions are closely modeled after the @code{iconv} functions available +on some systems. + +To convert text between two encodings, you should first call +@code{scm_mb_iconv_open} to indicate the source and destination +encodings; this function returns a context object which records the +conversion to perform. + +Then, you should call @code{scm_mb_iconv} to actually convert the text. +This function expects input and output buffers, and a pointer to the +context you got from @var{scm_mb_iconv_open}. You don't need to pass +all your input to @code{scm_mb_iconv} at once; you can invoke it on +successive blocks of input (as you read it from a file, say), and it +will convert as much as it can each time, indicating when you should +grow your output buffer. + +An encoding may be @dfn{stateless}, or @dfn{stateful}. In most +encodings, a contiguous group of bytes from the sequence completely +specifies a particular character; these are stateless encodings. +However, some encodings require you to look back an unbounded number of +bytes in the stream to assign a meaning to a particular byte sequence; +such encodings are stateful. + +For example, in the @samp{ISO-2022-JP} encoding for Japanese text, the +byte sequence @samp{27 36 66} indicates that subsequent bytes should be +taken in pairs and interpreted as characters from the JIS-0208 character +set. An arbitrary number of byte pairs may follow this sequence. The +byte sequence @samp{27 40 66} indicates that subsequent bytes should be +interpreted as @sc{ASCII}. In this encoding, you cannot tell whether a +given byte is an @sc{ASCII} character without looking back an arbitrary +distance for the most recent escape sequence, so it is a stateful +encoding. + +In Guile, if a conversion involves a stateful encoding, the context +object carries any necessary state. Thus, you can have many independent +conversions to or from stateful encodings taking place simultaneously, +as long as each data stream uses its own context object for the +conversion. + +@deftp {Libguile Type} {struct scm_mb_iconv} +This is the type for context objects, which represent the encodings and +current state of an ongoing text conversion. A @code{struct +scm_mb_iconv} records the source and destination encodings, and keeps +track of any information needed to handle stateful encodings. +@end deftp + +@deftypefn {Libguile Function} {struct scm_mb_iconv *} scm_mb_iconv_open (const char *@var{tocode}, const char *@var{fromcode}) +Return a pointer to a new @code{struct scm_mb_iconv} context object, +ready to convert from the encoding named @var{fromcode} to the encoding +named @var{tocode}. For stateful encodings, the context object is in +some appropriate initial state, ready for use with the +@code{scm_mb_iconv} function. + +When you are done using a context object, you may call +@code{scm_mb_iconv_close} to free it. + +If either @var{tocode} or @var{fromcode} is not the name of a known +encoding, this function will signal the @code{text:unknown-conversion} +error, described below. + +@c Try to use names here from the IANA list: +@c see ftp://ftp.isi.edu/in-notes/iana/assignments/character-sets +Guile supports at least these encodings: +@table @samp + +@item US-ASCII +@sc{US-ASCII}, in the standard one-character-per-byte encoding. + +@item ISO-8859-1 +The usual character set for Western European languages, in its usual +one-character-per-byte encoding. + +@item Guile-MB +Guile's current internal multibyte encoding. The actual encoding this +name refers to will change from one version of Guile to the next. You +should use this when converting data between external sources and the +encoding used by Guile objects. + +You should @emph{not} use this as the encoding for data presented to the +outside world, for two reasons. 1) Its meaning will change over time, +so data written using the @samp{guile} encoding with one version of +Guile might not be readable with the @samp{guile} encoding in another +version of Guile. 2) It currently corresponds to @samp{Emacs-Mule}, +which invented for Emacs's internal use, and was never intended to serve +as an exchange medium. + +@item Guile-Wide +Guile's character set, as an array of @code{scm_char_t} values. + +Note that this encoding is even less suitable for public use than +@samp{Guile}, since the exact sequence of bytes depends heavily on the +size and endianness the host system uses for @code{scm_char_t}. Using +this encoding is very much like calling the +@code{scm_mb_multibyte_to_fixed} or @code{scm_mb_fixed_to_multibyte} +functions, except that @code{scm_mb_iconv} gives you more control over +buffer allocation and management. + +@item Emacs-Mule +This is the variable-length encoding for multi-lingual text by GNU +Emacs, at least through version 20.4. You probably should not use this +encoding, as it is designed only for Emacs's internal use. However, we +provide it here because it's trivial to support, and some people +probably do have @samp{emacs-mule}-format files lying around. + +@end table + +(At the moment, this list doesn't include any character sets suitable for +external use that can actually handle multilingual data; this is +unfortunate, as it encourages users to write data in Emacs-Mule format, +which nobody but Emacs and Guile understands. We hope to add support +for Unicode in UTF-8 soon, which should solve this problem.) + +Case is not significant in encoding names. + +You can define your own conversions; see @ref{Implementing Your Own Text +Conversions}. +@end deftypefn + +@deftypefn {Libguile Function} int scm_mb_have_encoding (const char *@var{encoding}) +Return a non-zero value if Guile supports the encoding named @var{encoding}[[]] +@end deftypefn + +@deftypefn {Libguile Function} size_t scm_mb_iconv (struct scm_mb_iconv *@var{context}, const char **@var{inbuf}, size_t *@var{inbytesleft}, char **@var{outbuf}, size_t *@var{outbytesleft}) +Convert a sequence of characters from one encoding to another. The +argument @var{context} specifies the encodings to use for the input and +output, and carries state for stateful encodings; use +@code{scm_mb_iconv_open} to create a @var{context} object for a +particular conversion. + +Upon entry to the function, @code{*@var{inbuf}} should point to the +input buffer, and @code{*@var{inbytesleft}} should hold the number of +input bytes present in the buffer; @code{*@var{outbuf}} should point to +the output buffer, and @code{*@var{outbytesleft}} should hold the number +of bytes available to hold the conversion results in that buffer. + +Upon exit from the function, @code{*@var{inbuf}} points to the first +unconsumed byte of input, and @code{*@var{inbytesleft}} holds the number +of unconsumed input bytes; @code{*@var{outbuf}} points to the byte after +the last output byte, and @code{*@var{outbyteleft}} holds the number of +bytes left unused in the output buffer. + +For stateful encodings, @var{context} carries encoding state from one +call to @code{scm_mb_iconv} to the next. Thus, successive calls to +@var{scm_mb_iconv} which use the same context object can convert a +stream of data one chunk at a time. + +If @var{inbuf} is zero or @code{*@var{inbuf}} is zero, then the call is +taken as a request to reset the states of the input and the output +encodings. If @var{outbuf} is non-zero and @code{*@var{outbuf}} is +non-zero, then @code{scm_mb_iconv} stores a byte sequence in the output +buffer to put the output encoding in its initial state. If the output +buffer is not large enough to hold this byte sequence, +@code{scm_mb_iconv} returns @code{scm_mb_iconv_too_big}, and leaves +the shift states of @var{context}'s input and output encodings +unchanged. + +The @code{scm_mb_iconv} function always consumes only complete +characters or shift sequences from the input buffer, and the output +buffer always contains a sequence of complete characters or escape +sequences. + +If the input sequence contains characters which are not expressible in +the output encoding, @code{scm_mb_iconv} converts it in an +implementation-defined way. It may simply delete the character. + +Some encodings use byte sequences which do not correspond to any textual +character. For example, the escape sequence of a stateful encoding has +no textual meaning. When converting from such an encoding, a call to +@code{scm_mb_iconv} might consume input but produce no output, since the +input sequence might contain only escape sequences. + +Normally, @code{scm_mb_iconv} returns the number of input characters it +could not convert perfectly to the ouput encoding. However, it may +return one of the @code{scm_mb_iconv_} codes described below, to +indicate an error. All of these codes are negative values. + +If the input sequence contains an invalid character encoding, conversion +stops before the invalid input character, and @code{scm_mb_iconv} +returns the constant value @code{scm_mb_iconv_bad_encoding}. + +If the input sequence ends with an incomplete character encoding, +@code{scm_mb_iconv} will leave it in the input buffer, unconsumed, and +return the constant value @code{scm_mb_iconv_incomplete_encoding}. This +is not necessarily an error, if you expect to call @code{scm_mb_iconv} +again with more data which might contain the rest of the encoding +fragment. + +If the output buffer does not contain enough room to hold the converted +form of the complete input text, @code{scm_mb_iconv} converts as much as +it can, changes the input and output pointers to reflect the amount of +text successfully converted, and then returns +@code{scm_mb_iconv_too_big}. +@end deftypefn + +Here are the status codes that might be returned by @code{scm_mb_iconv}. +They are all negative integers. +@table @code + +@item scm_mb_iconv_too_big +The conversion needs more room in the output buffer. Some characters +may have been consumed from the input buffer, and some characters may +have been placed in the available space in the output buffer. + +@item scm_mb_iconv_bad_encoding +@code{scm_mb_iconv} encountered an invalid character encoding in the +input buffer. Conversion stopped before the invalid character, so there +may be some characters consumed from the input buffer, and some +converted text in the output buffer. + +@item scm_mb_iconv_incomplete_encoding +The input buffer ends with an incomplete character encoding. The +incomplete encoding is left in the input buffer, unconsumed. This is +not necessarily an error, if you expect to call @code{scm_mb_iconv} +again with more data which might contain the rest of the incomplete +encoding. + +@end table + + +Finally, Guile provides a function for destroying conversion contexts. + +@deftypefn {Libguile Function} void scm_mb_iconv_close (struct scm_mb_iconv *@var{context}) +Deallocate the conversion context object @var{context}, and all other +resources allocated by the call to @code{scm_mb_iconv_open} which +returned @var{context}. +@end deftypefn + + +@node Implementing Your Own Text Conversions, , Exchanging Guile Text With the Outside World in C, Functions for Operating on Multibyte Text +@subsection Implementing Your Own Text Conversions + +[[note that conversions to and from Guile must produce streams +containing only valid character encodings, or else Guile will crash]] + +This section describes the interface for adding your own encoding +conversions for use with @code{scm_mb_iconv}. The interface here is +borrowed from the GNOME Project's @file{libunicode} library. + +Guile's @code{scm_mb_iconv} function works by converting the input text +to a stream of @code{scm_char_t} characters, and then converting +those characters to the desired output encoding. This makes it easy +for Guile to choose the appropriate conversion back ends for an +arbitrary pair of input and output encodings, but it also means that the +accuracy and quality of the conversions depends on the fidelity of +Guile's internal character set to the source and destination encodings. +Since @code{scm_mb_iconv} will be used almost exclusively for converting +to and from Guile's internal character set, this shouldn't be a problem. + +To add support for a particular encoding to Guile, you must provide one +function (called the @dfn{read} function) which converts from your +encoding to an array of @code{scm_char_t}'s, and another function +(called the @dfn{write} function) to convert from an array of +@code{scm_char_t}'s back into your encoding. To convert from some +encoding @var{a} to some other encoding @var{b}, Guile pairs up +@var{a}'s read function with @var{b}'s write function. Each call to +@code{scm_mb_iconv} passes text in encoding @var{a} through the read +function, to produce an array of @code{scm_char_t}'s, and then passes +that array to the write function, to produce text in encoding @var{b}. + +For stateful encodings, a read or write function can hang its own data +structures off the conversion object, and provide its own functions to +allocate and destroy them; this allows read and write functions to +maintain whatever state they like. + +The Guile conversion back end represents each available encoding with a +@code{struct scm_mb_encoding} object. + +@deftp {Libguile Type} {struct scm_mb_encoding} +This data structure describes an encoding. It has the following +members: + +@table @code + +@item char **names +An array of strings, giving the various names for this encoding. The +array should be terminated by a zero pointer. Case is not significant +in encoding names. + +The @code{scm_mb_iconv_open} function searches the list of registered +encodings for an encoding whose @code{names} array matches its +@var{tocode} or @var{fromcode} argument. + +@item int (*init) (void **@var{cookie}) +An initialization function for the encoding's private data. +@code{scm_mb_iconv_open} will call this function, passing it the address +of the cookie for this encoding in this context. (We explain cookies +below.) There is no way for the @code{init} function to tell whether +the encoding will be used for reading or writing. + +Note that @code{init} receives a @emph{pointer} to the cookie, not the +cookie itself. Because the type of @var{cookie} is @code{void **}, the +C compiler will not check it as carefully as it would other types. + +The @code{init} member may be zero, indicating that no initialization is +necessary for this encoding. + +@item int (*destroy) (void **@var{cookie}) +A deallocation function for the encoding's private data. +@code{scm_mb_iconv_close} calls this function, passing it the address of +the cookie for this encoding in this context. The @code{destroy} +function should free any data the @code{init} function allocated. + +Note that @code{destroy} receives a @emph{pointer} to the cookie, not the +cookie itself. Because the type of @var{cookie} is @code{void **}, the +C compiler will not check it as carefully as it would other types. + +The @code{destroy} member may be zero, indicating that this encoding +doesn't need to perform any special action to destroy its local data. + +@item int (*reset) (void *@var{cookie}, char **@var{outbuf}, size_t *@var{outbytesleft}) +Put the encoding into its initial shift state. Guile calls this +function whether the encoding is being used for input or output, so this +should take appropriate steps for both directions. If @var{outbuf} and +@var{outbytesleft} are valid, the reset function should emit an escape +sequence to reset the output stream to its initial state; @var{outbuf} +and @var{outbytesleft} should be handled just as for +@code{scm_mb_iconv}. + +This function can return an @code{scm_mb_iconv_} error code +(@pxref{Exchanging Guile Text With the Outside World in C}). If it +returns @code{scm_mb_iconv_too_big}, then the output buffer's shift +state must be left unchanged. + +Note that @code{reset} receives the cookie's value itself, not a pointer +to the cookie, as the @code{init} and @code{destroy} functions do. + +The @code{reset} member may be zero, indicating that this encoding +doesn't use a shift state. + +@item enum scm_mb_read_result (*read) (void *@var{cookie}, const char **@var{inbuf}, size_t *@var{inbytesleft}, scm_char_t **@var{outbuf}, size_t *@var{outcharsleft}) +Read some bytes and convert into an array of Guile characters. This is +the encoding's read function. + +On entry, there are *@var{inbytesleft} bytes of text at *@var{inbuf} to +be converted, and *@var{outcharsleft} characters available at +*@var{outbuf} to hold the results. + +On exit, *@var{inbytesleft} and *@var{inbuf} indicate the input bytes +still not consumed. *@var{outcharsleft} and *@var{outbuf} indicate the +output buffer space still not filled. (By exclusion, these indicate +which input bytes were consumed, and which output characters were +produced.) + +Return one of the @code{enum scm_mb_read_result} values, described below. + +Note that @code{read} receives the cookie's value itself, not a pointer +to the cookie, as the @code{init} and @code{destroy} functions do. + +@item enum scm_mb_write_result (*write) (void *@var{cookie}, scm_char_t **@var{inbuf}, size_t *@var{incharsleft}, **@var{outbuf}, size_t *@var{outbytesleft}) +Convert an array of Guile characters to output bytes. This is +the encoding's write function. + +On entry, there are *@var{incharsleft} Guile characters available at +*@var{inbuf}, and *@var{outbytesleft} bytes available to store output at +*@var{outbuf}. + +On exit, *@var{incharsleft} and *@var{inbuf} indicate the number of +Guile characters left unconverted (because there was insufficient room +in the output buffer to hold their converted forms), and +*@var{outbytesleft} and *@var{outbuf} indicate the unused portion of the +output buffer. + +Return one of the @code{scm_mb_write_result} values, described below. + +Note that @code{write} receives the cookie's value itself, not a pointer +to the cookie, as the @code{init} and @code{destroy} functions do. + +@item struct scm_mb_encoding *next +This is used by Guile to maintain a linked list of encodings. It is +filled in when you call @code{scm_mb_register_encoding} to add your +encoding to the list. + +@end table +@end deftp + +Here is the enumerated type for the values an encoding's read function +can return: + +@deftp {Libguile Type} {enum scm_mb_read_result} +This type represents the result of a call to an encoding's read +function. It has the following values: + +@table @code + +@item scm_mb_read_ok +The read function consumed at least one byte of input. + +@item scm_mb_read_incomplete +The data present in the input buffer does not contain a complete +character encoding. No input was consumed, and no characters were +produced as output. This is not necessarily an error status, if there +is more data to pass through. + +@item scm_mb_read_error +The input contains an invalid character encoding. + +@end table +@end deftp + +Here is the enumerated type for the values an encoding's write function +can return: + +@deftp {Libguile Type} {enum scm_mb_write_result} +This type represents the result of a call to an encoding's write +function. It has the following values: + +@table @code + +@item scm_mb_write_ok +The write function was able to convert all the characters in @var{inbuf} +successfully. + +@item scm_mb_write_too_big +The write function filled the output buffer, but there are still +characters in @var{inbuf} left unconsumed; @var{inbuf} and +@var{incharsleft} indicate the unconsumed portion of the input buffer. + +@end table +@end deftp + + +Conversions to or from stateful encodings need to keep track of each +encoding's current state. Each conversion context contains two +@code{void *} variables called @dfn{cookies}, one for the input +encoding, and one for the output encoding. These cookies are passed to +the encodings' functions, for them to use however they please. A +stateful encoding can use its cookie to hold a pointer to some object +which maintains the context's current shift state. Stateless encodings +will probably not use their cookies. + +The cookies' lifetime is the same as that of the context object. When +the user calls @code{scm_mb_iconv_close} to destroy a context object, +@code{scm_mb_iconv_close} calls the input and output encodings' +@code{destroy} functions, passing them their respective cookies, so each +encoding can free any data it allocated for that context. + +Note that, if a read or write function returns a successful result code +like @code{scm_mb_read_ok} or @code{scm_mb_write_ok}, then the remaining +input, together with the output, must together represent the complete +input text; the encoding may not store any text temporarily in its +cookie. This is because, if @code{scm_mb_iconv} returns a successful +result to the user, it is correct for the user to assume that all the +consumed input has been converted and placed in the output buffer. +There is no ``flush'' operation to push any final results out of the +encodings' buffers. + +Here is the function you call to register a new encoding with the +conversion system: + +@deftypefn {Libguile Function} void scm_mb_register_encoding (struct scm_mb_encoding *@var{encoding}) +Add the encoding described by @code{*@var{encoding}} to the set +understood by @code{scm_mb_iconv_open}. Once you have registered your +encoding, you can use it by calling @code{scm_mb_iconv_open} with one of +the names in @code{@var{encoding}->names}. +@end deftypefn + + +@node Multibyte Text Processing Errors, Why Guile Does Not Use a Fixed-Width Encoding, Functions for Operating on Multibyte Text, Working With Multibyte Strings in C +@section Multibyte Text Processing Errors + +This section describes error conditions which code can signal to +indicate problems encountered while processing multibyte text. In each +case, the arguments @var{message} and @var{args} are an error format +string and arguments to be substituted into the string, as accepted by +the @code{display-error} function. + +@deffn Condition text:not-char-boundary func message args object offset +By calling @var{func}, the program attempted to access a character at +byte offset @var{offset} in the Guile object @var{object}, but +@var{offset} is not the start of a character's encoding in @var{object}. + +Typically, @var{object} is a string or symbol. If the function signalling +the error cannot find the Guile object that contains the text it is +inspecting, it should use @code{#f} for @var{object}. +@end deffn + +@deffn Condition text:bad-encoding func message args object +By calling @var{func}, the program attempted to interpret the text in +@var{object}, but @var{object} contains a byte sequence which is not a +valid encoding for any character. +@end deffn + +@deffn Condition text:not-guile-char func message args number +By calling @var{func}, the program attempted to treat @var{number} as the +number of a character in the Guile character set, but @var{number} does +not correspond to any character in the Guile character set. +@end deffn + +@deffn Condition text:unknown-conversion func message args from to +By calling @var{func}, the program attempted to convert from an encoding +named @var{from} to an encoding named @var{to}, but Guile does not +support such a conversion. +@end deffn + +@deftypevr {Libguile Variable} SCM scm_text_not_char_boundary +@deftypevrx {Libguile Variable} SCM scm_text_bad_encoding +@deftypevrx {Libguile Variable} SCM scm_text_not_guile_char +These variables hold the scheme symbol objects whose names are the +condition symbols above. You can use these when signalling these +errors, instead of looking them up yourself. +@end deftypevr + + +@node Why Guile Does Not Use a Fixed-Width Encoding, , Multibyte Text Processing Errors, Working With Multibyte Strings in C +@section Why Guile Does Not Use a Fixed-Width Encoding + +Multibyte encodings are clumsier to work with than encodings which use a +fixed number of bytes for every character. For example, using a +fixed-width encoding, we can extract the @var{i}th character of a string +in constant time, and we can always substitute the @var{i}th character +of a string with any other character without reallocating or copying the +string. + +However, there are no fixed-width encodings which include the characters +we wish to include, and also fit in a reasonable amount of space. +Despite the Unicode standard's claims to the contrary, Unicode is not +really a fixed-width encoding. Unicode uses surrogate pairs to +represent characters outside the 16-bit range; a surrogate pair must be +treated as a single character, but occupies two 16-bit spaces. As of +this writing, there are already plans to assign characters to the +surrogate character codes. Three- and four-byte encodings are +too wasteful for a majority of Guile's users, who only need @sc{ASCII} +and a few accented characters. + +Another alternative would be to have several different fixed-width +string representations, each with a different element size. For each +string, Guile would use the smallest element size capable of +accomodating the string's text. This would allow users of English and +the Western European languages to use the traditional memory-efficient +encodings. However, if Guile has @var{n} string representations, then +users must write @var{n} versions of any code which manipulates text +directly --- one for each element size. And if a user wants to operate +on two strings simultaneously, and wants to avoid testing the string +sizes within the loop, she must make @var{n}*@var{n} copies of the loop. +Most users will simply not bother. Instead, they will write code which +supports only one string size, leaving us back where we started. By +using a single internal representation, Guile makes it easier for users +to write multilingual code. + +[[What about tagging each string with its encoding? +"Every extension must be written to deal with every encoding"]] + +[[You don't really want to index strings anyway.]] + +Finally, Guile's multibyte encoding is not so bad. Unlike a two- or +four-byte encoding, it is efficient in space for American and European +users. Furthermore, the properties described above mean that many +functions can be coded just as they would for a single-byte encoding; +see @ref{Promised Properties of the Guile Multibyte Encoding}. + +@bye diff --git a/doc/mltext.texi b/doc/mltext.texi new file mode 100644 index 000000000..64bcdafa3 --- /dev/null +++ b/doc/mltext.texi @@ -0,0 +1,146 @@ +@node Working with Multilingual Text +@chapter Working with Multilingual Text + +@node Guile Character Properties, Exchanging Text With The Outside World, Multibyte String Functions, Functions for Operating on Multibyte Text +@section Guile Character Properties + +These functions give information about the nature of a given Guile +character. These are defined for any @code{scm_mb_char_t} value. + +@deftypefn {Libguile Function} int scm_mb_isalnum (scm_mb_char_t @var{c}) +Return non-zero iff @var{c} is an alphabetic or numeric character. +@end deftypefn + +@deftypefn {Libguile Function} int scm_mb_is_alpha (scm_mb_char_t @var{c}) +Return non-zero iff @var{c} is an alphabetic character. +@end deftypefn + +@deftypefn {Libguile Function} int scm_mb_iscntrl (scm_mb_char_t @var{c}) +Return non-zero iff @var{c} is a control character. +@end deftypefn + +@deftypefn {Libguile Function} int scm_mb_isdigit (scm_mb_char_t @var{c}) +Return non-zero iff @var{c} is a digit. +@end deftypefn + +@deftypefn {Libguile Function} int scm_mb_isgraph (scm_mb_char_t @var{c}) +Return non-zero iff @var{c} is a visible character. +@end deftypefn + +@deftypefn {Libguile Function} int scm_mb_isupper (scm_mb_char_t @var{c}) +Return non-zero iff @var{c} is an upper-case character. +@end deftypefn + +@deftypefn {Libguile Function} int scm_mb_islower (scm_mb_char_t @var{c}) +Return non-zero iff @var{c} is a lower-case character. +@end deftypefn + +@deftypefn {Libguile Function} int scm_mb_istitle (scm_mb_char_t @var{c}) +Return non-zero iff @var{c} is a title-case character. See the Unicode +standard for an explanation of title case. +@end deftypefn + +@deftypefn {Libguile Function} int scm_mb_isprint (scm_mb_char_t @var{c}) +Return non-zero iff @var{c} is a printable character. +@end deftypefn + +@deftypefn {Libguile Function} int scm_mb_ispunct (scm_mb_char_t @var{c}) +Return non-zero iff @var{c} is a punctuation character. +@end deftypefn + +@deftypefn {Libguile Function} int scm_mb_isspace (scm_mb_char_t @var{c}) +Return non-zero iff @var{c} is a whitespace character. +@end deftypefn + +@deftypefn {Libguile Function} int scm_mb_isxdigit (scm_mb_char_t @var{c}) +Return non-zero iff @var{c} is a hexidecimal digit. +@end deftypefn + +@deftypefn {Libguile Function} int scm_mb_isdefined (scm_mb_char_t @var{c}) +Return non-zero iff @var{c} is a valid character. +@end deftypefn + +@deftypefn {Libguile Function} scm_mb_char_t scm_mb_char_toupper (scm_mb_char_t @var{c}) +@deftypefnx {Libguile Function} scm_mb_char_t scm_mb_char_tolower (scm_mb_char_t @var{c}) +@deftypefnx {Libguile Function} scm_mb_char_t scm_mb_char_totitle (scm_mb_char_t @var{c}) +Convert @var{c} to upper, lower, or title case. If @var{c} has no +equivalent in the requested case, or is already in that case, return it +unchanged. +@end deftypefn + +@deftypefn {Libguile Function} in scm_mb_digit_value (scm_mb_char_t @var{c}) +If @var{c} is a hexidecimal digit (according to +@code{scm_mb_isxdigit}), then return its numeric value. Otherwise +return -1. +@end deftypefn + +@deftypefn {Libguile Function} in scm_mb_digit_value (scm_mb_char_t @var{c}) +If @var{c} is a digit (according to @code{scm_mb_isdigit}), then +return its numeric value. Otherwise return -1. +@end deftypefn + + +@node Multibyte Character Tables, Multibyte Character Categories, Exchanging Text With The Outside World, Functions for Operating on Multibyte Text +@section Multibyte Character Tables + +A @dfn{character table} is a table mapping @code{scm_mb_char_t} values +onto Guile objects. Guile provides functions for creating character +tables, setting entries, and looking up characters. Character tables +are Guile objects, so they are managed by Guile's garbage collector. + +A character table can have a ``parent'' table, from which it inherits +values for characters. If a character table @var{child}, with a parent +table @var{parent} maps some character @var{c} to the value +@code{SCM_UNDEFINED}, then @code{scm_c_char_table_ref (@var{child}, +@var{c})} will look up @var{c} in @var{parent}, and return the value it +finds there. + +This section describes only the C API for working with character tables. +For the Scheme-level API, see @ref{some other section}. + +@deftypefn {Libguile Function} scm_make_char_table (SCM @var{init}, SCM @var{parent}) +Return a new character table object which maps every character to +@var{init}. If @var{parent} is a character table, then @var{parent} is +the new table's parent. If @var{parent} table is @code{SCM_UNDEFINED}, +then the new table has no parent. Otherwise, signal a type error. +@end deffn + +@deftypefn {Libguile Function} SCM scm_c_char_table_ref (SCM @var{table}, scm_mb_char_t @var{c}) +Look up the character @var{c} in the character table @var{table}, and +return the value found there. If @var{table} maps @var{c} to +@code{SCM_UNDEFINED}, and @var{table} has a parent, then look up @var{c} +in the parent. + +If @var{table} is not a character table, signal an error. +@end deftypefn + +@deftypefn {Libguile Function} SCM scm_c_char_table_set_x (SCM @var{table}, scm_mb_char_t @var{c}, SCM @var{value}) +Set @var{table}'s value for the character @var{c} to @var{value}. +If @var{value} is @code{SCM_UNDEFINED}, then @var{table}'s parent's +value will show through for @var{c}. + +If @var{table} is not a character table, signal an error. + +This function changes only @var{table} itself, never @var{table}'s +parent. +@end deftypefn + +[[this is all wrong. what about default values?]] + + + + + +@node Multibyte Character Categories, , Multibyte Character Tables, Functions for Operating on Multibyte Text +@section Multibyte Character Categories + +[[This will describe an ADT representing subsets of the Guile character +set.]] + + + + +@node Exchanging Guile Text With the Outside World +@subsection Exchanging Guile Text With the Outside World + +[[Scheme-level functions for converting between encodings]] diff --git a/doc/posix.texi b/doc/posix.texi new file mode 100644 index 000000000..7a4cc8e40 --- /dev/null +++ b/doc/posix.texi @@ -0,0 +1,2247 @@ +@node POSIX +@chapter POSIX System Calls and Networking + +@menu +* Conventions:: Conventions employed by the POSIX interface. +* Ports and File Descriptors:: Scheme ``ports'' and Unix file descriptors + have different representations. +* File System:: stat, chown, chmod, etc. +* User Information:: Retrieving a user's GECOS (/etc/passwd) entry. +* Time:: gettimeofday, localtime, strftime, etc. +* Runtime Environment:: Accessing and modifying Guile's environment. +* Processes:: getuid, getpid, etc. +* Signals:: sigaction, kill, pause, alarm, etc. +* Terminals and Ptys:: ttyname, tcsetpgrp, etc. +* Pipes:: Communicating data between processes. +* Networking:: gethostbyaddr, getnetent, socket, bind, listen. +* System Identification:: `uname' and getting info about this machine. +* Locales:: setlocale, etc. +@end menu + +@node Conventions +@section POSIX Interface Conventions + +These interfaces provide access to operating system facilities. +They provide a simple wrapping around the underlying C interfaces +to make usage from Scheme more convenient. They are also used +to implement the Guile port of @ref{The Scheme shell (scsh)}. + +Generally there is a single procedure for each corresponding Unix +facility. There are some exceptions, such as procedures implemented for +speed and convenience in Scheme with no primitive Unix equivalent, +e.g., @code{copy-file}. + +The interfaces are intended as far as possible to be portable across +different versions of Unix. In some cases procedures which can't be +implemented on particular systems may become no-ops, or perform limited +actions. In other cases they may throw errors. + +General naming conventions are as follows: + +@itemize @bullet +@item +The Scheme name is often identical to the name of the underlying Unix +facility. +@item +Underscores in Unix procedure names are converted to hyphens. +@item +Procedures which destructively modify Scheme data have exclaimation +marks appended, e.g., @code{recv!}. +@item +Predicates (returning only @code{#t} or @code{#f}) have question marks +appended, e.g., @code{access?}. +@item +Some names are changed to avoid conflict with dissimilar interfaces +defined by scsh, e.g., @code{primitive-fork}. +@item +Unix preprocessor names such as @code{EPERM} or @code{R_OK} are converted +to Scheme variables of the same name (underscores are not replaced +with hyphens). +@end itemize + +Unexpected conditions are generally handled by raising exceptions. +There are a few procedures which return a special value if they don't +succeed, e.g., @code{getenv} returns @code{#f} if it the requested +string is not found in the environment. These cases are noted in +the documentation. + +For ways to deal with exceptions, @ref{Exceptions}. + +Errors which the C-library would report by returning a NULL +pointer or through some other means are reported by raising a +@code{system-error} exception. +The value of the Unix @code{errno} variable is available +in the data passed by the exception. + +Here's an ad-hoc@footnote{This may be changed in the future; be prepared +to rewrite this sort of code.} way to extract the @code{errno} value +from an exception: + +@example +(catch + 'system-error + (lambda () + (mkdir "/this-ought-to-fail-if-I'm-not-root")) + (lambda stuff + (let ((errno (car (list-ref stuff 4)))) + (cond + ((= errno EACCES) + (display "You're not allowed to do that.")) + ((= errno EEXIST) + (display "Already exists.")) + (#t + (display (strerror errno)))) + (newline)))) +@end example + +The important thing to note is that the @code{errno} value can be +extracted with @code{(car (list-ref stuff 4))}. + +@node Ports and File Descriptors +@section Ports and File Descriptors + +Conventions generally follow those of scsh, @ref{The Scheme shell (scsh)}. + +File ports are implemented using low-level operating system I/O +facilities, with optional buffering to improve efficiency +@pxref{File Ports} + +Note that some procedures (e.g., @code{recv!}) will accept ports as +arguments, but will actually operate directly on the file descriptor +underlying the port. Any port buffering is ignored, including the +buffer which implements @code{peek-char} and @code{unread-char}. + +The @code{force-output} and @code{drain-input} procedures can be used +to clear the buffers. + +Each open file port has an associated operating system file descriptor. +File descriptors are generally not useful in Scheme programs; however +they may be needed when interfacing with foreign code and the Unix +environment. + +A file descriptor can be extracted from a port and a new port can be +created from a file descriptor. However a file descriptor is just an +integer and the garbage collector doesn't recognise it as a reference +to the port. If all other references to the port were dropped, then +it's likely that the garbage collector would free the port, with the +side-effect of closing the file descriptor prematurely. + +To assist the programmer in avoiding this problem, each port has an +associated "revealed count" which can be used to keep track of how many +times the underlying file descriptor has been stored in other places. +If a port's revealed count is greater than zero, the file descriptor +will not be closed when the port is gabage collected. A programmer +can therefore ensure that the revealed count will be greater than +zero if the file descriptor is needed elsewhere. + +For the simple case where a file descriptor is "imported" once to become +a port, it does not matter if the file descriptor is closed when the +port is garbage collected. There is no need to maintain a revealed +count. Likewise when "exporting" a file descriptor to the external +environment, setting the revealed count is not required provided the +port is kept open (i.e., is pointed to by a live Scheme binding) while +the file descriptor is in use. + +To correspond with traditional Unix behaviour, the three file +descriptors (0, 1 and 2) are automatically imported when a program +starts up and assigned to the initial values of the current input, +output and error ports. The revealed count for each is initially set to +one, so that dropping references to one of these ports will not result +in its garbage collection: it could be retrieved with fdopen or +fdes->ports. + +@c docstring begin (texi-doc-string "guile" "port-revealed") +@deffn primitive port-revealed port +Returns the revealed count for @var{port}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "set-port-revealed!") +@deffn primitive set-port-revealed! port rcount +Sets the revealed count for a port to a given value. +The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "fileno") +@deffn primitive fileno port +Returns the integer file descriptor underlying @var{port}. +Does not change its revealed count. +@end deffn + +@deffn procedure port->fdes port +Returns the integer file descriptor underlying @var{port}. As a +side effect the revealed count of @var{port} is incremented. +@end deffn + +@c docstring begin (texi-doc-string "guile" "fdopen") +@deffn primitive fdopen fdes modes +Returns a new port based on the file descriptor @var{fdes}. +Modes are given by the string @var{modes}. The revealed count of the port +is initialized to zero. The modes string is the same as that accepted +by @ref{File Ports, open-file}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "fdes->ports") +@deffn primitive fdes->ports fd +Returns a list of existing ports which have @var{fdes} as an +underlying file descriptor, without changing their revealed counts. +@end deffn + +@deffn procedure fdes->inport fdes +Returns an existing input port which has @var{fdes} as its underlying file +descriptor, if one exists, and increments its revealed count. +Otherwise, returns a new input port with a revealed count of 1. +@end deffn + +@deffn procedure fdes->outport fdes +Returns an existing output port which has @var{fdes} as its underlying file +descriptor, if one exists, and increments its revealed count. +Otherwise, returns a new output port with a revealed count of 1. +@end deffn + +@c docstring begin (texi-doc-string "guile" "primitive-move->fdes") +@deffn primitive primitive-move->fdes port fd +Moves the underlying file descriptor for @var{port} to the integer +value @var{fdes} without changing the revealed count of @var{port}. +Any other ports already using this descriptor will be automatically +shifted to new descriptors and their revealed counts reset to zero. +The return value is @code{#f} if the file descriptor already had the +required value or @code{#t} if it was moved. +@end deffn + +@deffn procedure move->fdes port fdes +Moves the underlying file descriptor for @var{port} to the integer +value @var{fdes} and sets its revealed count to one. Any other ports +already using this descriptor will be automatically +shifted to new descriptors and their revealed counts reset to zero. +The return value is unspecified. +@end deffn + +@deffn procedure release-port-handle port +Decrements the revealed count for a port. +@end deffn + +@c docstring begin (texi-doc-string "guile" "fsync") +@deffn primitive fsync object +Copies any unwritten data for the specified output file descriptor to disk. +If @var{port/fd} is a port, its buffer is flushed before the underlying +file descriptor is fsync'd. +The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "open") +@deffn primitive open path flags [mode] +Open the file named by @var{path} for reading and/or writing. +@var{flags} is an integer specifying how the file should be opened. +@var{mode} is an integer specifying the permission bits of the file, if +it needs to be created, before the umask is applied. The default is 666 +(Unix itself has no default). + +@var{flags} can be constructed by combining variables using @code{logior}. +Basic flags are: + +@defvar O_RDONLY +Open the file read-only. +@end defvar +@defvar O_WRONLY +Open the file write-only. +@end defvar +@defvar O_RDWR +Open the file read/write. +@end defvar +@defvar O_APPEND +Append to the file instead of truncating. +@end defvar +@defvar O_CREAT +Create the file if it does not already exist. +@end defvar + +See the Unix documentation of the @code{open} system call +for additional flags. +@end deffn + +@c docstring begin (texi-doc-string "guile" "open-fdes") +@deffn primitive open-fdes path flags [mode] +Similar to @code{open} but returns a file descriptor instead of a +port. +@end deffn + +@c docstring begin (texi-doc-string "guile" "close") +@deffn primitive close fd_or_port +Similar to close-port (@pxref{Closing, close-port}), but also works on +file descriptors. A side effect of closing a file descriptor is that +any ports using that file descriptor are moved to a different file +descriptor and have their revealed counts set to zero. +@end deffn + +@c docstring begin (texi-doc-string "guile" "close-fdes") +@deffn primitive close-fdes fd +A simple wrapper for the @code{close} system call. +Close file descriptor @var{fd}, which must be an integer. +Unlike close (@pxref{Ports and File Descriptors, close}), +the file descriptor will be closed even if a port is using it. +The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "unread-char") +@deffn primitive unread-char char [port] +Place @var{char} in @var{port} so that it will be read by the +next read operation. If called multiple times, the unread characters +will be read again in last-in first-out order. If @var{port} is +not supplied, the current input port is used. +@end deffn + +@c docstring begin (texi-doc-string "guile" "unread-string") +@deffn primitive unread-string str port +Place the string @var{str} in @var{port} so that its characters will be +read in subsequent read operations. If called multiple times, the +unread characters will be read again in last-in first-out order. If +@var{port} is not supplied, the current-input-port is used. +@end deffn + +@c docstring begin (texi-doc-string "guile" "pipe") +@deffn primitive pipe +Returns a newly created pipe: a pair of ports which are linked +together on the local machine. The CAR is the input port and +the CDR is the output port. Data written (and flushed) to the +output port can be read from the input port. +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}. + +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. +@end deffn + +The next group of procedures perform a @code{dup2} +system call, if @var{newfd} (an +integer) is supplied, otherwise a @code{dup}. The file descriptor to be +duplicated can be supplied as an integer or contained in a port. The +type of value returned varies depending on which procedure is used. + +All procedures also have the side effect when performing @code{dup2} that any +ports using @var{newfd} are moved to a different file descriptor and have +their revealed counts set to zero. + +@c docstring begin (texi-doc-string "guile" "dup->fdes") +@deffn primitive dup->fdes fd_or_port [fd] +Returns an integer file descriptor. +@end deffn + +@deffn procedure dup->inport port/fd [newfd] +Returns a new input port using the new file descriptor. +@end deffn + +@deffn procedure dup->outport port/fd [newfd] +Returns a new output port using the new file descriptor. +@end deffn + +@deffn procedure dup port/fd [newfd] +Returns a new port if @var{port/fd} is a port, with the same mode as the +supplied port, otherwise returns an integer file descriptor. +@end deffn + +@deffn procedure dup->port port/fd mode [newfd] +Returns a new port using the new file descriptor. @var{mode} supplies a +mode string for the port (@pxref{File Ports, open-file}). +@end deffn + +@deffn procedure duplicate-port port modes +Returns a new port which is opened on a duplicate of the file +descriptor underlying @var{port}, with mode string @var{modes} +as for @ref{File Ports, open-file}. The two ports +will share a file position and file status flags. + +Unexpected behaviour can result if both ports are subsequently used +and the original and/or duplicate ports are buffered. +The mode string can include @code{0} to obtain an unbuffered duplicate +port. + +This procedure is equivalent to @code{(dup->port @var{port} @var{modes})}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "redirect-port") +@deffn primitive redirect-port old new +This procedure takes two ports and duplicates the underlying file +descriptor from @var{old-port} into @var{new-port}. The +current file descriptor in @var{new-port} will be closed. +After the redirection the two ports will share a file position +and file status flags. + +The return value is unspecified. + +Unexpected behaviour can result if both ports are subsequently used +and the original and/or duplicate ports are buffered. + +This procedure does not have any side effects on other ports or +revealed counts. +@end deffn + +@c docstring begin (texi-doc-string "guile" "dup2") +@deffn primitive dup2 oldfd newfd +A simple wrapper for the @code{dup2} system call. +Copies the file descriptor @var{oldfd} to descriptor +number @var{newfd}, replacing the previous meaning +of @var{newfd}. Both @var{oldfd} and @var{newfd} must +be integers. +Unlike for dup->fdes or primitive-move->fdes, no attempt +is made to move away ports which are using @var{newfd}. +The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "port-mode") +@deffn primitive port-mode port +Returns the port modes associated with the open port @var{port}. These +will not necessarily be identical to the modes used when the port was +opened, since modes such as "append" which are used only during +port creation are not retained. +@end deffn + +@c docstring begin (texi-doc-string "guile" "close-all-ports-except") +@deffn primitive close-all-ports-except . ports +[DEPRECATED] Close all open file ports used by the interpreter +except for those supplied as arguments. This procedure +was intended to be used before an exec call to close file descriptors +which are not needed in the new process. However it has the +undesirable side-effect of flushing buffes, so it's deprecated. +Use port-for-each instead. +@end deffn + +@c docstring begin (texi-doc-string "guile" "port-for-each") +@deffn primitive port-for-each proc +Apply @var{proc} to each port in the Guile port table +in turn. The return value is unspecified. More specifically, +@var{proc} is applied exactly once to every port that exists +in the system at the time @var{port-for-each} is invoked. +Changes to the port table while @var{port-for-each} is running +have no effect as far as @var{port-for-each} is concerned. +@end deffn + +@c docstring begin (texi-doc-string "guile" "setvbuf") +@deffn primitive setvbuf port mode [size] +Set the buffering mode for @var{port}. @var{mode} can be: +@table @code +@item _IONBF +non-buffered +@item _IOLBF +line buffered +@item _IOFBF +block buffered, using a newly allocated buffer of @var{size} bytes. +If @var{size} is omitted, a default size will be used. +@end table +@end deffn + +@c docstring begin (texi-doc-string "guile" "fcntl") +@deffn primitive fcntl object cmd [value] +Apply @var{command} to the specified file descriptor or the underlying +file descriptor of the specified port. @var{value} is an optional +integer argument. + +Values for @var{command} are: + +@table @code +@item F_DUPFD +Duplicate a file descriptor +@item F_GETFD +Get flags associated with the file descriptor. +@item F_SETFD +Set flags associated with the file descriptor to @var{value}. +@item F_GETFL +Get flags associated with the open file. +@item F_SETFL +Set flags associated with the open file to @var{value} +@item F_GETOWN +Get the process ID of a socket's owner, for @code{SIGIO} signals. +@item F_SETOWN +Set the process that owns a socket to @var{value}, for @code{SIGIO} signals. +@item FD_CLOEXEC +The value used to indicate the "close on exec" flag with @code{F_GETFL} or +@code{F_SETFL}. +@end table +@end deffn + +@c docstring begin (texi-doc-string "guile" "select") +@deffn primitive select reads writes excepts [secs [usecs]] +This procedure has a variety of uses: waiting for the ability +to provide input, accept output, or the existance of +exceptional conditions on a collection of ports or file +descriptors, or waiting for a timeout to occur. +It also returns if interrupted by a signal. + +@var{reads}, @var{writes} and @var{excepts} can be lists or +vectors, with each member a port or a file descriptor. +The value returned is a list of three corresponding +lists or vectors containing only the members which meet the +specified requirement. The ability of port buffers to +provide input or accept output is taken into account. +Ordering of the input lists or vectors is not preserved. + +The optional arguments @var{secs} and @var{usecs} specify the +timeout. Either @var{secs} can be specified alone, as +either an integer or a real number, or both @var{secs} and +@var{usecs} can be specified as integers, in which case +@var{usecs} is an additional timeout expressed in +microseconds. If @var{secs} is omitted or is @code{#f} then +select will wait for as long as it takes for one of the other +conditions to be satisfied. + +The scsh version of @code{select} differs as follows: +Only vectors are accepted for the first three arguments. +The @var{usecs} argument is not supported. +Multiple values are returned instead of a list. +Duplicates in the input vectors appear only once in output. +An additional @code{select!} interface is provided. +@end deffn + +@node File System +@section File System + +These procedures allow querying and setting file system attributes +(such as owner, +permissions, sizes and types of files); deleting, copying, renaming and +linking files; creating and removing directories and querying their +contents; syncing the file system and creating special files. + +@c docstring begin (texi-doc-string "guile" "access?") +@deffn primitive access? path how +Returns @code{#t} if @var{path} corresponds to an existing +file and the current process +has the type of access specified by @var{how}, otherwise +@code{#f}. +@var{how} should be specified +using the values of the variables listed below. Multiple values can +be combined using a bitwise or, in which case @code{#t} will only +be returned if all accesses are granted. + +Permissions are checked using the real id of the current process, +not the effective id, although it's the effective id which determines +whether the access would actually be granted. + +@defvar R_OK +test for read permission. +@end defvar +@defvar W_OK +test for write permission. +@end defvar +@defvar X_OK +test for execute permission. +@end defvar +@defvar F_OK +test for existence of the file. +@end defvar +@end deffn + +@findex fstat +@c docstring begin (texi-doc-string "guile" "stat") +@deffn primitive stat object +Returns an object containing various information +about the file determined by @var{obj}. +@var{obj} can be a string containing a file name or a port or integer file +descriptor which is open on a file (in which case @code{fstat} is used +as the underlying system call). + +The object returned by @code{stat} can be passed as a single parameter +to the following procedures, all of which return integers: + +@table @code +@item stat:dev +The device containing the file. +@item stat:ino +The file serial number, which distinguishes this file from all other +files on the same device. +@item stat:mode +The mode of the file. This includes file type information +and the file permission bits. See @code{stat:type} and @code{stat:perms} +below. +@item stat:nlink +The number of hard links to the file. +@item stat:uid +The user ID of the file's owner. +@item stat:gid +The group ID of the file. +@item stat:rdev +Device ID; this entry is defined only for character or block +special files. +@item stat:size +The size of a regular file in bytes. +@item stat:atime +The last access time for the file. +@item stat:mtime +The last modification time for the file. +@item stat:ctime +The last modification time for the attributes of the file. +@item stat:blksize +The optimal block size for reading or writing the file, in bytes. +@item stat:blocks +The amount of disk space that the file occupies measured in units of +512 byte blocks. +@end table + +In addition, the following procedures return the information +from stat:mode in a more convenient form: + +@table @code +@item stat:type +A symbol representing the type of file. Possible values are +regular, directory, symlink, block-special, char-special, +fifo, socket and unknown +@item stat:perms +An integer representing the access permission bits. +@end table +@end deffn + +@c docstring begin (texi-doc-string "guile" "lstat") +@deffn primitive lstat str +Similar to @code{stat}, but does not follow symbolic links, i.e., +it will return information about a symbolic link itself, not the +file it points to. @var{path} must be a string. +@end deffn + +@c docstring begin (texi-doc-string "guile" "readlink") +@deffn primitive readlink path +Returns the value of the symbolic link named by +@var{path} (a string), i.e., the +file that the link points to. +@end deffn + +@findex fchown +@findex lchown +@c docstring begin (texi-doc-string "guile" "chown") +@deffn primitive chown object owner group +Change the ownership and group of the file referred to by @var{object} to +the integer values @var{owner} and @var{group}. @var{object} can be +a string containing a file name or, if the platform +supports fchown, a port or integer file descriptor +which is open on the file. The return value +is unspecified. + +If @var{object} is a symbolic link, either the +ownership of the link or the ownership of the referenced file will be +changed depending on the operating system (lchown is +unsupported at present). If @var{owner} or @var{group} is specified +as @code{-1}, then that ID is not changed. +@end deffn + +@findex fchmod +@c docstring begin (texi-doc-string "guile" "chmod") +@deffn primitive chmod object mode +Changes the permissions of the file referred to by @var{obj}. +@var{obj} can be a string containing a file name or a port or integer file +descriptor which is open on a file (in which case @code{fchmod} is used +as the underlying system call). +@var{mode} specifies +the new permissions as a decimal number, e.g., @code{(chmod "foo" #o755)}. +The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "utime") +@deffn primitive utime pathname [actime [modtime]] +@code{utime} sets the access and modification times for +the file named by @var{path}. If @var{actime} or @var{modtime} +is not supplied, then the current time is used. +@var{actime} and @var{modtime} +must be integer time values as returned by the @code{current-time} +procedure. + +E.g., + +@smalllisp +(utime "foo" (- (current-time) 3600)) +@end smalllisp + +will set the access time to one hour in the past and the modification +time to the current time. +@end deffn + +@findex unlink +@c docstring begin (texi-doc-string "guile" "delete-file") +@deffn primitive delete-file str +Deletes (or "unlinks") the file specified by @var{path}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "copy-file") +@deffn primitive copy-file oldfile newfile +Copy the file specified by @var{path-from} to @var{path-to}. +The return value is unspecified. +@end deffn + +@findex rename +@c docstring begin (texi-doc-string "guile" "rename-file") +@deffn primitive rename-file oldname newname +Renames the file specified by @var{oldname} to @var{newname}. +The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "link") +@deffn primitive link oldpath newpath +Creates a new name @var{newpath} in the file system for the +file named by @var{oldpath}. If @var{oldpath} is a symbolic +link, the link may or may not be followed depending on the +system. +@end deffn + +@c docstring begin (texi-doc-string "guile" "symlink") +@deffn primitive symlink oldpath newpath +Create a symbolic link named @var{path-to} with the value (i.e., pointing to) +@var{path-from}. The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "mkdir") +@deffn primitive mkdir path [mode] +Create a new directory named by @var{path}. If @var{mode} is omitted +then the permissions of the directory file are set using the current +umask. Otherwise they are set to the decimal value specified with +@var{mode}. The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "rmdir") +@deffn primitive rmdir path +Remove the existing directory named by @var{path}. The directory must +be empty for this to succeed. The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "opendir") +@deffn primitive opendir dirname +Open the directory specified by @var{path} and return a directory +stream. +@end deffn + +@c docstring begin (texi-doc-string "guile" "directory-stream?") +@deffn primitive directory-stream? obj +Returns a boolean indicating whether @var{object} is a directory stream +as returned by @code{opendir}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "readdir") +@deffn primitive readdir port +Return (as a string) the next directory entry from the directory stream +@var{stream}. If there is no remaining entry to be read then the +end of file object is returned. +@end deffn + +@c docstring begin (texi-doc-string "guile" "rewinddir") +@deffn primitive rewinddir port +Reset the directory port @var{stream} so that the next call to +@code{readdir} will return the first directory entry. +@end deffn + +@c docstring begin (texi-doc-string "guile" "closedir") +@deffn primitive closedir port +Close the directory stream @var{stream}. +The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "sync") +@deffn primitive sync +Flush the operating system disk buffers. +The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "mknod") +@deffn primitive mknod path type perms dev +Creates a new special file, such as a file corresponding to a device. +@var{path} specifies the name of the file. @var{type} should +be one of the following symbols: +regular, directory, symlink, block-special, char-special, +fifo, or socket. @var{perms} (an integer) specifies the file permissions. +@var{dev} (an integer) specifies which device the special file refers +to. Its exact interpretation depends on the kind of special file +being created. + +E.g., +@example +(mknod "/dev/fd0" 'block-special #o660 (+ (* 2 256) 2)) +@end example + +The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "tmpnam") +@deffn primitive tmpnam +Create a new file in the file system with a unique name. The return +value is the name of the new file. This function is implemented with +the @code{tmpnam} function in the system libraries. +@end deffn + +@c docstring begin (texi-doc-string "guile" "dirname") +@deffn primitive dirname filename +Return the directory name component of the file name +@var{filename}. If @var{filename} does not contain a directory +component, @code{.} is returned. +@end deffn + +@c docstring begin (texi-doc-string "guile" "basename") +@deffn primitive basename filename [suffix] +Return the base name of the file name @var{filename}. The +base name is the file name without any directory components. +If @var{suffix} is privided, and is equal to the end of +@var{basename}, it is removed also. +@end deffn + + +@node User Information +@section User Information + +The facilities in this section provide an interface to the user and +group database. +They should be used with care since they are not reentrant. + +The following functions accept an object representing user information +and return a selected component: + +@table @code +@item passwd:name +The name of the userid. +@item passwd:passwd +The encrypted passwd. +@item passwd:uid +The user id number. +@item passwd:gid +The group id number. +@item passwd:gecos +The full name. +@item passwd:dir +The home directory. +@item passwd:shell +The login shell. +@end table + +@deffn procedure getpwuid uid +Look up an integer userid in the user database. +@end deffn + +@deffn procedure getpwnam name +Look up a user name string in the user database. +@end deffn + +@deffn procedure setpwent +Initializes a stream used by @code{getpwent} to read from the user database. +The next use of @code{getpwent} will return the first entry. The +return value is unspecified. +@end deffn + +@deffn procedure getpwent +Return the next entry in the user database, using the stream set by +@code{setpwent}. +@end deffn + +@deffn procedure endpwent +Closes the stream used by @code{getpwent}. The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "setpw") +@deffn primitive setpw [arg] +If called with a true argument, initialize or reset the password data +stream. Otherwise, close the stream. The @code{setpwent} and +@code{endpwent} procedures are implemented on top of this. +@end deffn + +@c docstring begin (texi-doc-string "guile" "getpw") +@deffn primitive getpw [user] +Look up an entry in the user database. @var{obj} can be an integer, +a string, or omitted, giving the behaviour of getpwuid, getpwnam +or getpwent respectively. +@end deffn + +The following functions accept an object representing group information +and return a selected component: + +@table @code +@item group:name +The group name. +@item group:passwd +The encrypted group password. +@item group:gid +The group id number. +@item group:mem +A list of userids which have this group as a supplimentary group. +@end table + +@deffn procedure getgrgid gid +Look up an integer groupid in the group database. +@end deffn + +@deffn procedure getgrnam name +Look up a group name in the group database. +@end deffn + +@deffn procedure setgrent +Initializes a stream used by @code{getgrent} to read from the group database. +The next use of @code{getgrent} will return the first entry. +The return value is unspecified. +@end deffn + +@deffn procedure getgrent +Return the next entry in the group database, using the stream set by +@code{setgrent}. +@end deffn + +@deffn procedure endgrent +Closes the stream used by @code{getgrent}. +The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "setgr") +@deffn primitive setgr [arg] +If called with a true argument, initialize or reset the group data +stream. Otherwise, close the stream. The @code{setgrent} and +@code{endgrent} procedures are implemented on top of this. +@end deffn + +@c docstring begin (texi-doc-string "guile" "getgr") +@deffn primitive getgr [name] +Look up an entry in the group database. @var{obj} can be an integer, +a string, or omitted, giving the behaviour of getgrgid, getgrnam +or getgrent respectively. +@end deffn + +@node Time +@section Time + +@c docstring begin (texi-doc-string "guile" "current-time") +@deffn primitive current-time +Returns the number of seconds since 1970-01-01 00:00:00 UTC, excluding +leap seconds. +@end deffn + +@c docstring begin (texi-doc-string "guile" "gettimeofday") +@deffn primitive gettimeofday +Returns a pair containing the number of seconds and microseconds since +1970-01-01 00:00:00 UTC, excluding leap seconds. Note: whether true +microsecond resolution is available depends on the operating system. +@end deffn + +The following procedures either accept an object representing a broken down +time and return a selected component, or accept an object representing +a broken down time and a value and set the component to the value. +The numbers in parentheses give the usual range. + +@table @code +@item tm:sec, set-tm:sec +Seconds (0-59). +@item tm:min, set-tm:min +Minutes (0-59). +@item tm:hour, set-tm:hour +Hours (0-23). +@item tm:mday, set-tm:mday +Day of the month (1-31). +@item tm:mon, set-tm:mon +Month (0-11). +@item tm:year, set-tm:year +Year (70-), the year minus 1900. +@item tm:wday, set-tm:wday +Day of the week (0-6) with Sunday represented as 0. +@item tm:yday, set-tm:yday +Day of the year (0-364, 365 in leap years). +@item tm:isdst, set-tm:isdst +Daylight saving indicator (0 for "no", greater than 0 for "yes", less than +0 for "unknown"). +@item tm:gmtoff, set-tm:gmtoff +Time zone offset in seconds west of UTC (-46800 to 43200). +@item tm:zone, set-tm:zone +Time zone label (a string), not necessarily unique. +@end table + +@c docstring begin (texi-doc-string "guile" "localtime") +@deffn primitive localtime time [zone] +Returns an object representing the broken down components of @var{time}, +an integer like the one returned by @code{current-time}. The time zone +for the calculation is optionally specified by @var{zone} (a string), +otherwise the @code{TZ} environment variable or the system default is +used. +@end deffn + +@c docstring begin (texi-doc-string "guile" "gmtime") +@deffn primitive gmtime time +Returns an object representing the broken down components of @var{time}, +an integer like the one returned by @code{current-time}. The values +are calculated for UTC. +@end deffn + +@c docstring begin (texi-doc-string "guile" "mktime") +@deffn primitive mktime sbd_time [zone] +@var{bd-time} is an object representing broken down time and @code{zone} +is an optional time zone specifier (otherwise the TZ environment variable +or the system default is used). + +Returns a pair: the car is a corresponding +integer time value like that returned +by @code{current-time}; the cdr is a broken down time object, similar to +as @var{bd-time} but with normalized values. +@end deffn + +@c docstring begin (texi-doc-string "guile" "tzset") +@deffn primitive tzset +Initialize the timezone from the TZ environment variable +or the system default. It's not usually necessary to call this procedure +since it's done automatically by other procedures that depend on the +timezone. +@end deffn + +@c docstring begin (texi-doc-string "guile" "strftime") +@deffn primitive strftime format stime +Formats a time specification @var{time} using @var{template}. @var{time} +is an object with time components in the form returned by @code{localtime} +or @code{gmtime}. @var{template} is a string which can include formatting +specifications introduced by a @code{%} character. The formatting of +month and day names is dependent on the current locale. The value returned +is the formatted string. +@xref{Formatting Date and Time, , , libc, The GNU C Library Reference Manual}.) +@end deffn + +@c docstring begin (texi-doc-string "guile" "strptime") +@deffn primitive strptime format string +Performs the reverse action to @code{strftime}, parsing +@var{string} according to the specification supplied in +@var{template}. The interpretation of month and day names is +dependent on the current locale. The value returned is a pair. +The car has an object with time components +in the form returned by @code{localtime} or @code{gmtime}, +but the time zone components +are not usefully set. +The cdr reports the number of characters from @var{string} +which were used for the conversion. +@end deffn + +@defvar internal-time-units-per-second +The value of this variable is the number of time units per second +reported by the following procedures. +@end defvar + +@c docstring begin (texi-doc-string "guile" "times") +@deffn primitive times +Returns an object with information about real and processor time. +The following procedures accept such an object as an argument and +return a selected component: + +@table @code +@item tms:clock +The current real time, expressed as time units relative to an +arbitrary base. +@item tms:utime +The CPU time units used by the calling process. +@item tms:stime +The CPU time units used by the system on behalf of the calling process. +@item tms:cutime +The CPU time units used by terminated child processes of the calling +process, whose status has been collected (e.g., using @code{waitpid}). +@item tms:cstime +Similarly, the CPU times units used by the system on behalf of +terminated child processes. +@end table +@end deffn + +@c docstring begin (texi-doc-string "guile" "get-internal-real-time") +@deffn primitive get-internal-real-time +Returns the number of time units since the interpreter was started. +@end deffn + +@c docstring begin (texi-doc-string "guile" "get-internal-run-time") +@deffn primitive get-internal-run-time +Returns the number of time units of processor time used by the interpreter. +Both "system" and "user" time are included but subprocesses are not. +@end deffn + +@node Runtime Environment +@section Runtime Environment + +@c docstring begin (texi-doc-string "guile" "program-arguments") +@deffn primitive program-arguments +@deffnx procedure command-line +Return the list of command line arguments passed to Guile, as a list of +strings. The list includes the invoked program name, which is usually +@code{"guile"}, but excludes switches and parameters for command line +options like @code{-e} and @code{-l}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "getenv") +@deffn primitive getenv nam +Looks up the string @var{name} in the current environment. The return +value is @code{#f} unless a string of the form @code{NAME=VALUE} is +found, in which case the string @code{VALUE} is returned. +@end deffn + +@c begin (scm-doc-string "boot-9.scm" "setenv") +@deffn procedure setenv name value +Modifies the environment of the current process, which is +also the default environment inherited by child processes. + +If @var{value} is @code{#f}, then @var{name} is removed from the +environment. Otherwise, the string @var{name}=@var{value} is added +to the environment, replacing any existing string with name matching +@var{name}. + +The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "environ") +@deffn primitive environ [env] +If @var{env} is omitted, returns the current environment as a list of strings. +Otherwise it sets the current environment, which is also the +default environment for child processes, to the supplied list of strings. +Each member of @var{env} should be of the form +@code{NAME=VALUE} and values of @code{NAME} should not be duplicated. +If @var{env} is supplied then the return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "putenv") +@deffn primitive putenv str +Modifies the environment of the current process, which is +also the default environment inherited by child processes. + +If @var{string} is of the form @code{NAME=VALUE} then it will be written +directly into the environment, replacing any existing environment string +with +name matching @code{NAME}. If @var{string} does not contain an equal +sign, then any existing string with name matching @var{string} will +be removed. + +The return value is unspecified. +@end deffn + + +@node Processes +@section Processes + +@findex cd +@c docstring begin (texi-doc-string "guile" "chdir") +@deffn primitive chdir str +Change the current working directory to @var{path}. +The return value is unspecified. +@end deffn + +@findex pwd +@c docstring begin (texi-doc-string "guile" "getcwd") +@deffn primitive getcwd +Returns the name of the current working directory. +@end deffn + +@c docstring begin (texi-doc-string "guile" "umask") +@deffn primitive umask [mode] +If @var{mode} is omitted, retuns a decimal number representing the current +file creation mask. Otherwise the file creation mask is set to +@var{mode} and the previous value is returned. + +E.g., @code{(umask #o022)} sets the mask to octal 22, decimal 18. +@end deffn + +@c docstring begin (texi-doc-string "guile" "getpid") +@deffn primitive getpid +Returns an integer representing the current process ID. +@end deffn + +@c docstring begin (texi-doc-string "guile" "getgroups") +@deffn primitive getgroups +Returns a vector of integers representing the current supplimentary group IDs. +@end deffn + +@c docstring begin (texi-doc-string "guile" "getppid") +@deffn primitive getppid +Returns an integer representing the process ID of the parent process. +@end deffn + +@c docstring begin (texi-doc-string "guile" "getuid") +@deffn primitive getuid +Returns an integer representing the current real user ID. +@end deffn + +@c docstring begin (texi-doc-string "guile" "getgid") +@deffn primitive getgid +Returns an integer representing the current real group ID. +@end deffn + +@c docstring begin (texi-doc-string "guile" "geteuid") +@deffn primitive geteuid +Returns an integer representing the current effective user ID. +If the system does not support effective IDs, then the real ID +is returned. @code{(feature? 'EIDs)} reports whether the system +supports effective IDs. +@end deffn + +@c docstring begin (texi-doc-string "guile" "getegid") +@deffn primitive getegid +Returns an integer representing the current effective group ID. +If the system does not support effective IDs, then the real ID +is returned. @code{(feature? 'EIDs)} reports whether the system +supports effective IDs. +@end deffn + +@c docstring begin (texi-doc-string "guile" "setuid") +@deffn primitive setuid id +Sets both the real and effective user IDs to the integer @var{id}, provided +the process has appropriate privileges. +The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "setgid") +@deffn primitive setgid id +Sets both the real and effective group IDs to the integer @var{id}, provided +the process has appropriate privileges. +The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "seteuid") +@deffn primitive seteuid id +Sets the effective user ID to the integer @var{id}, provided the process +has appropriate privileges. If effective IDs are not supported, the +real ID is set instead -- @code{(feature? 'EIDs)} reports whether the +system supports effective IDs. +The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "setegid") +@deffn primitive setegid id +Sets the effective group ID to the integer @var{id}, provided the process +has appropriate privileges. If effective IDs are not supported, the +real ID is set instead -- @code{(feature? 'EIDs)} reports whether the +system supports effective IDs. +The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "getpgrp") +@deffn primitive getpgrp +Returns an integer representing the current process group ID. +This is the POSIX definition, not BSD. +@end deffn + +@c docstring begin (texi-doc-string "guile" "setpgid") +@deffn primitive setpgid pid pgid +Move the process @var{pid} into the process group @var{pgid}. @var{pid} or +@var{pgid} must be integers: they can be zero to indicate the ID of the +current process. +Fails on systems that do not support job control. +The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "setsid") +@deffn primitive setsid +Creates a new session. The current process becomes the session leader +and is put in a new process group. The process will be detached +from its controlling terminal if it has one. +The return value is an integer representing the new process group ID. +@end deffn + +@c docstring begin (texi-doc-string "guile" "waitpid") +@deffn primitive waitpid pid [options] +This procedure collects status information from a child process which +has terminated or (optionally) stopped. Normally it will +suspend the calling process until this can be done. If more than one +child process is eligible then one will be chosen by the operating system. + +The value of @var{pid} determines the behaviour: + +@table @r +@item @var{pid} greater than 0 +Request status information from the specified child process. +@item @var{pid} equal to -1 or WAIT_ANY +Request status information for any child process. +@item @var{pid} equal to 0 or WAIT_MYPGRP +Request status information for any child process in the current process +group. +@item @var{pid} less than -1 +Request status information for any child process whose process group ID +is -@var{PID}. +@end table + +The @var{options} argument, if supplied, should be the bitwise OR of the +values of zero or more of the following variables: + +@defvar WNOHANG +Return immediately even if there are no child processes to be collected. +@end defvar + +@defvar WUNTRACED +Report status information for stopped processes as well as terminated +processes. +@end defvar + +The return value is a pair containing: + +@enumerate +@item +The process ID of the child process, or 0 if @code{WNOHANG} was +specified and no process was collected. +@item +The integer status value. +@end enumerate +@end deffn + +The following three +functions can be used to decode the process status code returned +by @code{waitpid}. + +@c docstring begin (texi-doc-string "guile" "status:exit-val") +@deffn primitive status:exit-val status +Returns the exit status value, as would be +set if a process ended normally through a +call to @code{exit} or @code{_exit}, if any, otherwise @code{#f}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "status:term-sig") +@deffn primitive status:term-sig status +Returns the signal number which terminated the +process, if any, otherwise @code{#f}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "status:stop-sig") +@deffn primitive status:stop-sig status +Returns the signal number which stopped the +process, if any, otherwise @code{#f}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "system") +@deffn primitive system [cmd] +Executes @var{cmd} using the operating system's "command processor". +Under Unix this is usually the default shell @code{sh}. The value +returned is @var{cmd}'s exit status as returned by @code{waitpid}, which +can be interpreted using the functions above. + +If @code{system} is called without arguments, it returns a boolean +indicating whether the command processor is available. +@end deffn + +@c docstring begin (texi-doc-string "guile" "primitive-exit") +@deffn primitive primitive-exit [status] +Terminate the current process without unwinding the Scheme stack. +This is would typically be useful after a fork. The exit status +is @var{status} if supplied, otherwise zero. +@end deffn + +@c docstring begin (texi-doc-string "guile" "execl") +@deffn primitive execl filename . args +Executes the file named by @var{path} as a new process image. +The remaining arguments are supplied to the process; from a C program +they are accessable as the @code{argv} argument to @code{main}. +Conventionally the first @var{arg} is the same as @var{path}. +All arguments must be strings. + +If @var{arg} is missing, @var{path} is executed with a null +argument list, which may have system-dependent side-effects. + +This procedure is currently implemented using the @code{execv} system +call, but we call it @code{execl} because of its Scheme calling interface. +@end deffn + +@c docstring begin (texi-doc-string "guile" "execlp") +@deffn primitive execlp filename . args +Similar to @code{execl}, however if +@var{filename} does not contain a slash +then the file to execute will be located by searching the +directories listed in the @code{PATH} environment variable. + +This procedure is currently implemented using the @code{execvp} system +call, but we call it @code{execlp} because of its Scheme calling interface. +@end deffn + +@c docstring begin (texi-doc-string "guile" "execle") +@deffn primitive execle filename env . args +Similar to @code{execl}, but the environment of the new process is +specified by @var{env}, which must be a list of strings as returned by the +@code{environ} procedure. + +This procedure is currently implemented using the @code{execve} system +call, but we call it @code{execle} because of its Scheme calling interface. +@end deffn + +@c docstring begin (texi-doc-string "guile" "primitive-fork") +@deffn primitive primitive-fork +Creates a new "child" process by duplicating the current "parent" process. +In the child the return value is 0. In the parent the return value is +the integer process ID of the child. + +This procedure has been renamed from @code{fork} to avoid a naming conflict +with the scsh fork. +@end deffn + +@c docstring begin (texi-doc-string "guile" "nice") +@deffn primitive nice incr +Increment the priority of the current process by @var{incr}. A higher +priority value means that the process runs less often. +The return value is unspecified. +@end deffn + +@node Signals +@section Signals + +Procedures to raise, handle and wait for signals. + +@c docstring begin (texi-doc-string "guile" "kill") +@deffn primitive kill pid sig +Sends a signal to the specified process or group of processes. + +@var{pid} specifies the processes to which the signal is sent: + +@table @r +@item @var{pid} greater than 0 +The process whose identifier is @var{pid}. +@item @var{pid} equal to 0 +All processes in the current process group. +@item @var{pid} less than -1 +The process group whose identifier is -@var{pid} +@item @var{pid} equal to -1 +If the process is privileged, all processes except for some special +system processes. Otherwise, all processes with the current effective +user ID. +@end table + +@var{sig} should be specified using a variable corresponding to +the Unix symbolic name, e.g., + +@defvar SIGHUP +Hang-up signal. +@end defvar + +@defvar SIGINT +Interrupt signal. +@end defvar +@end deffn + +@c docstring begin (texi-doc-string "guile" "raise") +@deffn primitive raise sig +Sends a specified signal @var{sig} to the current process, where +@var{sig} is as described for the kill procedure. +@end deffn + +@c docstring begin (texi-doc-string "guile" "sigaction") +@deffn primitive sigaction signum [handler [flags]] +Install or report the signal handler for a specified signal. + +@var{signum} is the signal number, which can be specified using the value +of variables such as @code{SIGINT}. + +If @var{action} is omitted, @code{sigaction} returns a pair: the +CAR is the current +signal hander, which will be either an integer with the value @code{SIG_DFL} +(default action) or @code{SIG_IGN} (ignore), or the Scheme procedure which +handles the signal, or @code{#f} if a non-Scheme procedure handles the +signal. The CDR contains the current @code{sigaction} flags for the handler. + +If @var{action} is provided, it is installed as the new handler for +@var{signum}. @var{action} can be a Scheme procedure taking one +argument, or the value of @code{SIG_DFL} (default action) or +@code{SIG_IGN} (ignore), or @code{#f} to restore whatever signal handler +was installed before @code{sigaction} was first used. Flags can +optionally be specified for the new handler (@code{SA_RESTART} will +always be added if it's available and the system is using restartable +system calls.) The return value is a pair with information about the +old handler as described above. + +This interface does not provide access to the "signal blocking" +facility. Maybe this is not needed, since the thread support may +provide solutions to the problem of consistent access to data +structures. +@end deffn + +@c docstring begin (texi-doc-string "guile" "restore-signals") +@deffn primitive restore-signals +Return all signal handlers to the values they had before any call to +@code{sigaction} was made. The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "alarm") +@deffn primitive alarm i +Set a timer to raise a @code{SIGALRM} signal after the specified +number of seconds (an integer). It's advisable to install a signal +handler for +@code{SIGALRM} beforehand, since the default action is to terminate +the process. + +The return value indicates the time remaining for the previous alarm, +if any. The new value replaces the previous alarm. If there was +no previous alarm, the return value is zero. +@end deffn + +@c docstring begin (texi-doc-string "guile" "pause") +@deffn primitive pause +Pause the current process (thread?) until a signal arrives whose +action is to either terminate the current process or invoke a +handler procedure. The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "sleep") +@deffn primitive sleep i +Wait for the given number of seconds (an integer) or until a signal +arrives. The return value is zero if the time elapses or the number +of seconds remaining otherwise. +@end deffn + +@c docstring begin (texi-doc-string "guile" "usleep") +@deffn primitive usleep i +Sleep for I microseconds. +`usleep' is not available on all platforms. +@end deffn + +@node Terminals and Ptys +@section Terminals and Ptys + +@c docstring begin (texi-doc-string "guile" "isatty?") +@deffn primitive isatty? port +Returns @code{#t} if @var{port} is using a serial +non-file device, otherwise @code{#f}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "ttyname") +@deffn primitive ttyname port +Returns a string with the name of the serial terminal device underlying +@var{port}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "ctermid") +@deffn primitive ctermid +Returns a string containing the file name of the controlling terminal +for the current process. +@end deffn + +@c docstring begin (texi-doc-string "guile" "tcgetpgrp") +@deffn primitive tcgetpgrp port +Returns the process group ID of the foreground +process group associated with the terminal open on the file descriptor +underlying @var{port}. + +If there is no foreground process group, the return value is a +number greater than 1 that does not match the process group ID +of any existing process group. This can happen if all of the +processes in the job that was formerly the foreground job have +terminated, and no other job has yet been moved into the +foreground. +@end deffn + +@c docstring begin (texi-doc-string "guile" "tcsetpgrp") +@deffn primitive tcsetpgrp port pgid +Set the foreground process group ID for the terminal used by the file +descriptor underlying @var{port} to the integer @var{pgid}. +The calling process +must be a member of the same session as @var{pgid} and must have the same +controlling terminal. The return value is unspecified. +@end deffn + +@node Pipes +@section Pipes + +The following procedures provide an interface to the @code{popen} and +@code{pclose} system routines. The code is in a separate "popen" +module: + +@smalllisp +(use-modules (ice-9 popen)) +@end smalllisp + +@findex popen +@deffn procedure open-pipe command modes +Executes the shell command @var{command} (a string) in a subprocess. +A pipe to the process is created and returned. @var{modes} specifies +whether an input or output pipe to the process is created: it should +be the value of @code{OPEN_READ} or @code{OPEN_WRITE}. +@end deffn + +@deffn procedure open-input-pipe command +Equivalent to @code{open-pipe} with mode @code{OPEN_READ}. +@end deffn + +@deffn procedure open-output-pipe command +Equivalent to @code{open-pipe} with mode @code{OPEN_WRITE}. +@end deffn + +@findex pclose +@deffn procedure close-pipe port +Closes the pipe created by @code{open-pipe}, then waits for the process +to terminate and returns its status value, @xref{Processes, waitpid}, for +information on how to interpret this value. + +@code{close-port} (@pxref{Closing, close-port}) can also be used to +close a pipe, but doesn't return the status. +@end deffn + +@node Networking +@section Networking + +@menu +* Network Databases and Address Conversion:: +* Network Sockets and Communication:: +@end menu + +@node Network Databases and Address Conversion +@subsection Network Databases and Address Conversion + +This section describes procedures which convert internet addresses +and query various network databases. Care should be taken when using +the database routines since they are not reentrant. + +@subsubsection Address Conversion + +@c docstring begin (texi-doc-string "guile" "inet-aton") +@deffn primitive inet-aton address +Converts a string containing an Internet host address in the traditional +dotted decimal notation into an integer. + +@smalllisp +(inet-aton "127.0.0.1") @result{} 2130706433 + +@end smalllisp +@end deffn + +@c docstring begin (texi-doc-string "guile" "inet-ntoa") +@deffn primitive inet-ntoa inetid +Converts an integer Internet host address into a string with the +traditional dotted decimal representation. + +@smalllisp +(inet-ntoa 2130706433) @result{} "127.0.0.1" +@end smalllisp +@end deffn + +@c docstring begin (texi-doc-string "guile" "inet-netof") +@deffn primitive inet-netof address +Returns the network number part of the given integer Internet address. + +@smalllisp +(inet-netof 2130706433) @result{} 127 +@end smalllisp +@end deffn + +@c docstring begin (texi-doc-string "guile" "inet-lnaof") +@deffn primitive inet-lnaof address +Returns the local-address-with-network part of the given Internet +address. + +@smalllisp +(inet-lnaof 2130706433) @result{} 1 +@end smalllisp +@end deffn + +@c docstring begin (texi-doc-string "guile" "inet-makeaddr") +@deffn primitive inet-makeaddr net lna +Makes an Internet host address by combining the network number @var{net} +with the local-address-within-network number @var{lna}. + +@smalllisp +(inet-makeaddr 127 1) @result{} 2130706433 +@end smalllisp +@end deffn + +@subsubsection The Host Database + +A @dfn{host object} is a structure that represents what is known about a +network host, and is the usual way of representing a system's network +identity inside software. + +The following functions accept a host object and return a selected +component: + +@deffn procedure hostent:name host +The "official" hostname for @var{host}. +@end deffn +@deffn procedure hostent:aliases host +A list of aliases for @var{host}. +@end deffn +@deffn procedure hostent:addrtype host +The host address type. For hosts with Internet addresses, this will +return @code{AF_INET}. +@end deffn +@deffn procedure hostent:length host +The length of each address for @var{host}, in bytes. +@end deffn +@deffn procedure hostent:addr-list host +The list of network addresses associated with @var{host}. +@end deffn + +The following procedures are used to search the host database: + +@c docstring begin (texi-doc-string "guile" "gethost") +@deffn primitive gethost [host] +@deffnx procedure gethostbyname hostname +@deffnx procedure gethostbyaddr address +Look up a host by name or address, returning a host object. The +@code{gethost} procedure will accept either a string name or an integer +address; if given no arguments, it behaves like @code{gethostent} (see +below). If a name or address is supplied but the address can not be +found, an error will be thrown to one of the keys: +@code{host-not-found}, @code{try-again}, @code{no-recovery} or +@code{no-data}, corresponding to the equivalent @code{h_error} values. +Unusual conditions may result in errors thrown to the +@code{system-error} or @code{misc_error} keys. +@end deffn + +The following procedures may be used to step through the host +database from beginning to end. + +@deffn procedure sethostent [stayopen] +Initialize an internal stream from which host objects may be read. This +procedure must be called before any calls to @code{gethostent}, and may +also be called afterward to reset the host entry stream. If +@var{stayopen} is supplied and is not @code{#f}, the database is not +closed by subsequent @code{gethostbyname} or @code{gethostbyaddr} calls, +possibly giving an efficiency gain. +@end deffn + +@deffn procedure gethostent +Return the next host object from the host database, or @code{#f} if +there are no more hosts to be found (or an error has been encountered). +This procedure may not be used before @code{sethostent} has been called. +@end deffn + +@deffn procedure endhostent +Close the stream used by @code{gethostent}. The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "sethost") +@deffn primitive sethost [stayopen] +If @var{stayopen} is omitted, this is equivalent to @code{endhostent}. +Otherwise it is equivalent to @code{sethostent stayopen}. +@end deffn +@subsubsection The Network Database + +The following functions accept an object representing a network +and return a selected component: + +@deffn procedure netent:name net +The "official" network name. +@end deffn +@deffn procedure netent:aliases net +A list of aliases for the network. +@end deffn +@deffn procedure netent:addrtype net +The type of the network number. Currently, this returns only +@code{AF_INET}. +@end deffn +@deffn procedure netent:net net +The network number. +@end deffn + +The following procedures are used to search the network database: + +@c docstring begin (texi-doc-string "guile" "getnet") +@deffn primitive getnet [net] +@deffnx procedure getnetbyname net-name +@deffnx procedure getnetbyaddr net-number +Look up a network by name or net number in the network database. The +@var{net-name} argument must be a string, and the @var{net-number} +argument must be an integer. @code{getnet} will accept either type of +argument, behaving like @code{getnetent} (see below) if no arguments are +given. +@end deffn + +The following procedures may be used to step through the network +database from beginning to end. + +@deffn procedure setnetent [stayopen] +Initialize an internal stream from which network objects may be read. This +procedure must be called before any calls to @code{getnetent}, and may +also be called afterward to reset the net entry stream. If +@var{stayopen} is supplied and is not @code{#f}, the database is not +closed by subsequent @code{getnetbyname} or @code{getnetbyaddr} calls, +possibly giving an efficiency gain. +@end deffn + +@deffn procedure getnetent +Return the next entry from the network database. +@end deffn + +@deffn procedure endnetent +Close the stream used by @code{getnetent}. The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "setnet") +@deffn primitive setnet [stayopen] +If @var{stayopen} is omitted, this is equivalent to @code{endnetent}. +Otherwise it is equivalent to @code{setnetent stayopen}. +@end deffn + +@subsubsection The Protocol Database + +The following functions accept an object representing a protocol +and return a selected component: + +@deffn procedure protoent:name protocol +The "official" protocol name. +@end deffn +@deffn procedure protoent:aliases protocol +A list of aliases for the protocol. +@end deffn +@deffn procedure protoent:proto protocol +The protocol number. +@end deffn + +The following procedures are used to search the protocol database: + +@c docstring begin (texi-doc-string "guile" "getproto") +@deffn primitive getproto [protocol] +@deffnx procedure getprotobyname name +@deffnx procedure getprotobynumber number +Look up a network protocol by name or by number. @code{getprotobyname} +takes a string argument, and @code{getprotobynumber} takes an integer +argument. @code{getproto} will accept either type, behaving like +@code{getprotoent} (see below) if no arguments are supplied. +@end deffn + +The following procedures may be used to step through the protocol +database from beginning to end. + +@deffn procedure setprotoent [stayopen] +Initialize an internal stream from which protocol objects may be read. This +procedure must be called before any calls to @code{getprotoent}, and may +also be called afterward to reset the protocol entry stream. If +@var{stayopen} is supplied and is not @code{#f}, the database is not +closed by subsequent @code{getprotobyname} or @code{getprotobynumber} calls, +possibly giving an efficiency gain. +@end deffn + +@deffn procedure getprotoent +Return the next entry from the protocol database. +@end deffn + +@deffn procedure endprotoent +Close the stream used by @code{getprotoent}. The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "setproto") +@deffn primitive setproto [stayopen] +If @var{stayopen} is omitted, this is equivalent to @code{endprotoent}. +Otherwise it is equivalent to @code{setprotoent stayopen}. +@end deffn + +@subsubsection The Service Database + +The following functions accept an object representing a service +and return a selected component: + +@deffn procedure servent:name serv +The "official" name of the network service. +@end deffn +@deffn procedure servent:aliases serv +A list of aliases for the network service. +@end deffn +@deffn procedure servent:port serv +The Internet port used by the service. +@end deffn +@deffn procedure servent:proto serv +The protocol used by the service. A service may be listed many times +in the database under different protocol names. +@end deffn + +The following procedures are used to search the service database: + +@c docstring begin (texi-doc-string "guile" "getserv") +@deffn primitive getserv [name [protocol]] +@deffnx procedure getservbyname name protocol +@deffnx procedure getservbyport port protocol +Look up a network service by name or by service number, and return a +network service object. The @var{protocol} argument specifies the name +of the desired protocol; if the protocol found in the network service +database does not match this name, a system error is signalled. + +The @code{getserv} procedure will take either a service name or number +as its first argument; if given no arguments, it behaves like +@code{getservent} (see below). +@end deffn + +The following procedures may be used to step through the service +database from beginning to end. + +@deffn procedure setservent [stayopen] +Initialize an internal stream from which service objects may be read. This +procedure must be called before any calls to @code{getservent}, and may +also be called afterward to reset the service entry stream. If +@var{stayopen} is supplied and is not @code{#f}, the database is not +closed by subsequent @code{getservbyname} or @code{getservbyport} calls, +possibly giving an efficiency gain. +@end deffn + +@deffn procedure getservent +Return the next entry from the services database. +@end deffn + +@deffn procedure endservent +Close the stream used by @code{getservent}. The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "setserv") +@deffn primitive setserv [stayopen] +If @var{stayopen} is omitted, this is equivalent to @code{endservent}. +Otherwise it is equivalent to @code{setservent stayopen}. +@end deffn + +@node Network Sockets and Communication +@subsection Network Sockets and Communication + +Socket ports can be created using @code{socket} and @code{socketpair}. +The ports are initially unbuffered, to +makes reading and writing to the same port more reliable. +A buffer can be added to the port using @code{setvbuf}, +@xref{Ports and File Descriptors}. + +The convention used for "host" vs "network" addresses is that addresses +are always held in host order at the Scheme level. The procedures in +this section automatically convert between host and network order when +required. The arguments and return values are thus in host order. + +@c docstring begin (texi-doc-string "guile" "socket") +@deffn primitive socket family style proto +Returns a new socket port of the type specified by @var{family}, @var{style} +and @var{protocol}. All three parameters are integers. Typical values +for @var{family} are the values of @code{AF_UNIX} +and @code{AF_INET}. Typical values for @var{style} are +the values of @code{SOCK_STREAM}, @code{SOCK_DGRAM} and @code{SOCK_RAW}. + +@var{protocol} can be obtained from a protocol name using +@code{getprotobyname}. A value of +zero specifies the default protocol, which is usually right. + +A single socket port cannot by used for communication until +it has been connected to another socket. +@end deffn + +@c docstring begin (texi-doc-string "guile" "socketpair") +@deffn primitive socketpair family style proto +Returns a pair of connected (but unnamed) socket ports of the type specified +by @var{family}, @var{style} and @var{protocol}. +Many systems support only +socket pairs of the @code{AF_UNIX} family. Zero is likely to be +the only meaningful value for @var{protocol}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "getsockopt") +@deffn primitive getsockopt sock level optname +Returns the value of a particular socket option for the socket +port @var{socket}. @var{level} is an integer code for type of option +being requested, e.g., @code{SOL_SOCKET} for socket-level options. +@var{optname} is an +integer code for the option required and should be specified using one of +the symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc. + +The returned value is typically an integer but @code{SO_LINGER} returns a +pair of integers. +@end deffn + +@c docstring begin (texi-doc-string "guile" "setsockopt") +@deffn primitive setsockopt sock level optname value +Sets the value of a particular socket option for the socket +port @var{socket}. @var{level} is an integer code for type of option +being set, e.g., @code{SOL_SOCKET} for socket-level options. +@var{optname} is an +integer code for the option to set and should be specified using one of +the symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc. +@var{value} is the value to which the option should be set. For +most options this must be an integer, but for @code{SO_LINGER} it must +be a pair. + +The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "shutdown") +@deffn primitive shutdown sock how +Sockets can be closed simply by using @code{close-port}. The +@code{shutdown} procedure allows reception or tranmission on a +connection to be shut down individually, according to the parameter +@var{how}: + +@table @asis +@item 0 +Stop receiving data for this socket. If further data arrives, reject it. +@item 1 +Stop trying to transmit data from this socket. Discard any +data waiting to be sent. Stop looking for acknowledgement of +data already sent; don't retransmit it if it is lost. +@item 2 +Stop both reception and transmission. +@end table + +The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "connect") +@deffn primitive connect sock fam address . args +Initiates a connection from @var{socket} to the address +specified by @var{address} and possibly @var{arg @dots{}}. The format +required for @var{address} +and @var{arg} @dots{} depends on the family of the socket. + +For a socket of family @code{AF_UNIX}, +only @code{address} is specified and must be a string with the +filename where the socket is to be created. + +For a socket of family @code{AF_INET}, +@code{address} must be an integer Internet host address and @var{arg} @dots{} +must be a single integer port number. + +The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "bind") +@deffn primitive bind sock fam address . args +Assigns an address to the socket port @var{socket}. +Generally this only needs to be done for server sockets, +so they know where to look for incoming connections. A socket +without an address will be assigned one automatically when it +starts communicating. + +The format of @var{address} and @var{ARG} @dots{} depends on the family +of the socket. + +For a socket of family @code{AF_UNIX}, only @var{address} is specified +and must be a string with the filename where the socket is to be +created. + +For a socket of family @code{AF_INET}, @var{address} must be an integer +Internet host address and @var{arg} @dots{} must be a single integer +port number. + +The values of the following variables can also be used for @var{address}: + +@defvar INADDR_ANY +Allow connections from any address. +@end defvar + +@defvar INADDR_LOOPBACK +The address of the local host using the loopback device. +@end defvar + +@defvar INADDR_BROADCAST +The broadcast address on the local network. +@end defvar + +@defvar INADDR_NONE +No address. +@end defvar + +The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "listen") +@deffn primitive listen sock backlog +This procedure enables @var{socket} to accept connection +requests. @var{backlog} is an integer specifying +the maximum length of the queue for pending connections. +If the queue fills, new clients will fail to connect until the +server calls @code{accept} to accept a connection from the queue. + +The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "accept") +@deffn primitive accept sock +Accepts a connection on a bound, listening socket @var{socket}. If there +are no pending connections in the queue, it waits until +one is available unless the non-blocking option has been set on the +socket. + +The return value is a +pair in which the CAR is a new socket port for the connection and +the CDR is an object with address information about the client which +initiated the connection. + +If the address is not available then the CDR will be an empty vector. + +@var{socket} does not become part of the +connection and will continue to accept new requests. +@end deffn + +The following functions take a socket address object, as returned +by @code{accept} and other procedures, and return a selected component. + +@table @code +@item sockaddr:fam +The socket family, typically equal to the value of @code{AF_UNIX} or +@code{AF_INET}. +@item sockaddr:path +If the socket family is @code{AF_UNIX}, returns the path of the +filename the socket is based on. +@item sockaddr:addr +If the socket family is @code{AF_INET}, returns the Internet host +address. +@item sockaddr:port +If the socket family is @code{AF_INET}, returns the Internet port +number. +@end table + +@c docstring begin (texi-doc-string "guile" "getsockname") +@deffn primitive getsockname sock +Returns the address of @var{socket}, in the same form as the object +returned by @code{accept}. On many systems the address of a socket +in the @code{AF_FILE} namespace cannot be read. +@end deffn + +@c docstring begin (texi-doc-string "guile" "getpeername") +@deffn primitive getpeername sock +Returns the address of the socket that the socket @var{socket} is connected to, +in the same form as the object +returned by @code{accept}. On many systems the address of a socket +in the @code{AF_FILE} namespace cannot be read. +@end deffn + +@c docstring begin (texi-doc-string "guile" "recv!") +@deffn primitive recv! sock buf [flags] +Receives data from the socket port @var{socket}. @var{socket} must already +be bound to the address from which data is to be received. +@var{buf} is a string into which +the data will be written. The size of @var{buf} limits the amount of +data which can be received: in the case of packet +protocols, if a packet larger than this limit is encountered then some data +will be irrevocably lost. + +The optional @var{flags} argument is a value or +bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc. + +The value returned is the number of bytes read from the socket. + +Note that the data is read directly from the socket file descriptor: +any unread buffered port data is ignored. +@end deffn + +@c docstring begin (texi-doc-string "guile" "send") +@deffn primitive send sock message [flags] +Transmits the string @var{message} on the socket port @var{socket}. +@var{socket} must already be bound to a destination address. The +value returned is the number of bytes transmitted -- it's possible for +this to be less than the length of @var{message} if the socket is +set to be non-blocking. The optional @var{flags} argument is a value or +bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc. + +Note that the data is written directly to the socket file descriptor: +any unflushed buffered port data is ignored. +@end deffn + +@c docstring begin (texi-doc-string "guile" "recvfrom!") +@deffn primitive recvfrom! sock str [flags [start [end]]] +Returns data from the socket port @var{socket} and also information about +where the data was received from. @var{socket} must already +be bound to the address from which data is to be received. +@code{str}, is a string into which +the data will be written. The size of @var{str} limits the amount of +data which can be received: in the case of packet +protocols, if a packet larger than this limit is encountered then some data +will be irrevocably lost. + +The optional @var{flags} argument is a value or +bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc. + +The value returned is a pair: the CAR is the number of bytes read from +the socket and the CDR an address object in the same form as returned by +@code{accept}. + +The @var{start} and @var{end} arguments specify a substring of @var{str} +to which the data should be written. + +Note that the data is read directly from the socket file descriptor: +any unread buffered port data is ignored. +@end deffn + +@c docstring begin (texi-doc-string "guile" "sendto") +@deffn primitive sendto sock message fam address . args_and_flags +Transmits the string @var{message} on the socket port @var{socket}. The +destination address is specified using the @var{family}, @var{address} and +@var{arg} arguments, in a similar way to the @code{connect} +procedure. The +value returned is the number of bytes transmitted -- it's possible for +this to be less than the length of @var{message} if the socket is +set to be non-blocking. The optional @var{flags} argument is a value or +bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc. + +Note that the data is written directly to the socket file descriptor: +any unflushed buffered port data is ignored. +@end deffn + +The following functions can be used to convert short and long integers +between "host" and "network" order. Although the procedures above do +this automatically for addresses, the conversion will still need to +be done when sending or receiving encoded integer data from the network. + +@c docstring begin (texi-doc-string "guile" "htons") +@deffn primitive htons in +Returns a new integer from @var{value} by converting from host to +network order. @var{value} must be within the range of a C unsigned +short integer. +@end deffn + +@c docstring begin (texi-doc-string "guile" "ntohs") +@deffn primitive ntohs in +Returns a new integer from @var{value} by converting from network to +host order. @var{value} must be within the range of a C unsigned short +integer. +@end deffn + +@c docstring begin (texi-doc-string "guile" "htonl") +@deffn primitive htonl in +Returns a new integer from @var{value} by converting from host to +network order. @var{value} must be within the range of a C unsigned +long integer. +@end deffn + +@c docstring begin (texi-doc-string "guile" "ntohl") +@deffn primitive ntohl in +Returns a new integer from @var{value} by converting from network to +host order. @var{value} must be within the range of a C unsigned +long integer. +@end deffn + +These procedures are inconvenient to use at present, but consider: + +@example +(define write-network-long + (lambda (value port) + (let ((v (make-uniform-vector 1 1 0))) + (uniform-vector-set! v 0 (htonl value)) + (uniform-vector-write v port)))) + +(define read-network-long + (lambda (port) + (let ((v (make-uniform-vector 1 1 0))) + (uniform-vector-read! v port) + (ntohl (uniform-vector-ref v 0))))) +@end example + +@node System Identification +@section System Identification + +@c docstring begin (texi-doc-string "guile" "uname") +@deffn primitive uname +Returns an object with some information about the computer system the +program is running on. +@end deffn + +The following procedures accept an object as returned by @code{uname} +and return a selected component. + +@table @code +@item utsname:sysname +The name of the operating system. +@item utsname:nodename +The network name of the computer. +@item utsname:release +The current release level of the operating system implementation. +@item utsname:version +The current version level within the release of the operating system. +@item utsname:machine +A description of the hardware. +@end table + +@deffn primitive software-type +Return a symbol describing the current platform's operating system. +This may be one of AIX, VMS, UNIX, COHERENT, WINDOWS, MS-DOS, OS/2, +THINKC, AMIGA, ATARIST, MACH, or ACORN. + +Note that most varieties of Unix are considered to be simply "UNIX". +That is because when a program depends on features that are not present +on every operating system, it is usually better to test for the presence +or absence of that specific feature. The return value of +@code{software-type} should only be used for this purpose when there is +no other easy or unambiguous way of detecting such features. +@end deffn + +@node Locales +@section Locales + +@c docstring begin (texi-doc-string "guile" "setlocale") +@deffn primitive setlocale category [locale] +If @var{locale} is omitted, returns the current value of the specified +locale category as a system-dependent string. +@var{category} should be specified using the values @code{LC_COLLATE}, +@code{LC_ALL} etc. + +Otherwise the specified locale category is set to +the string @var{locale} +and the new value is returned as a system-dependent string. If @var{locale} +is an empty string, the locale will be set using envirionment variables. +@end deffn diff --git a/doc/preface.texi b/doc/preface.texi new file mode 100644 index 000000000..2391e135c --- /dev/null +++ b/doc/preface.texi @@ -0,0 +1,131 @@ +@iftex +@page +@unnumbered Preface + +This reference manual documents Guile, GNU's Ubiquitous Intelligent +Language for Extensions. It describes how to use Guile in many useful +and interesting ways. + +This is edition 1.0 of the reference manual, and corresponds to Guile +version @value{VERSION}. +@end iftex + + +@iftex +@section The Guile License +@end iftex + +@ifnottex +@node Guile License +@chapter The Guile License +@end ifnottex + +The license of Guile consists of the GNU GPL plus a special statement +giving blanket permission to link with non-free software. This is the +license statement as found in any individual file that it applies to: + +@quotation +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, 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 this software; see the file COPYING. If not, write to the Free +Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +02111-1307 USA + +As a special exception, the Free Software Foundation gives permission +for additional uses of the text contained in its release of GUILE. + +The exception is that, if you link the GUILE library with other files to +produce an executable, this does not by itself cause the resulting +executable to be covered by the GNU General Public License. Your use of +that executable is in no way restricted on account of linking the GUILE +library code into it. + +This exception does not however invalidate any other reasons why the +executable file might be covered by the GNU General Public License. + +This exception applies only to the code released by the Free Software +Foundation under the name GUILE. If you copy code from other Free +Software Foundation releases into a copy of GUILE, as the General Public +License permits, the exception does not apply to the code that you add +in this way. To avoid misleading anyone as to the status of such +modified files, you must delete this exception notice from them. + +If you write modifications of your own for GUILE, it is your choice +whether to permit this exception to apply to your modifications. If you +do not wish that, delete this exception notice. +@end quotation + + +@iftex +@section Layout of this Manual +@end iftex + +@ifnottex +@node Manual Layout +@chapter Layout of this Manual +@end ifnottex + +This manual is divided into five parts. + +@strong{Part I: Introduction to Guile} provides an overview of what +Guile is and how you can use it. A whirlwind tour shows how Guile can +be used interactively and as a script interpreter, how to link Guile +into your own applications, and how to write modules of interpreted and +compiled code for use with Guile. All of the ideas introduced here are +documented in full by the later parts of the manual. + +@strong{Part II: Guile Scheme} documents the core Scheme language and +features that Guile implements. Although the basis for this is the +Scheme language described in R5RS, this part of the manual does not +assume any prior familiarity with R5RS in particular, or with Scheme in +general. Basic Scheme concepts, standard aspects of the Scheme language +and Guile extensions on top of R5RS are all documented from scratch, and +organized by functionality rather than by the defining standards. + +@strong{Part III: Guile Modules} describes some important modules, +distributed as part of the Guile distribution, that extend the +functionality provided by the Guile Scheme core, most notably: + +@itemize @bullet +@item +the POSIX module, which provides Scheme level procedures for system and +network programming, conforming to the POSIX standard + +@item +the SLIB module, which makes Aubrey Jaffer's portable Scheme library +available for use in Guile. +@end itemize + +@strong{Part IV: Guile Scripting} documents the use of Guile as a script +interpreter, and illustrates this with a series of examples. + +@strong{Part V: Extending Applications Using Guile} explains the options +available for using Guile as a application extension language. At the +simpler end of the scale, an application might use Guile to define some +application-specific primitives in C and then load an application Scheme +file. In this case most of the application code is written on the +Scheme level, and uses the application-specific primitives as an +extension to standard Scheme. At the other end of the scale, an +application might be predominantly written in C --- with its main +control loop implemented in C --- but make occasional forays into Scheme +to, say, read configuration data or run user-defined customization code. +This part of the manual covers the complete range of application +extension options. + +Finally, the appendices explain how to obtain the latest version of +Guile, how to install it, where to find modules to work with Guile, and +how to use the Guile debugger. + + +@c Local Variables: +@c TeX-master: "guile.texi" +@c End: diff --git a/doc/r4rs.texi b/doc/r4rs.texi new file mode 100644 index 000000000..e69de29bb diff --git a/doc/r5rs.texi b/doc/r5rs.texi new file mode 100644 index 000000000..e69de29bb diff --git a/doc/scheme-binding.texi b/doc/scheme-binding.texi new file mode 100644 index 000000000..d23ff2fb5 --- /dev/null +++ b/doc/scheme-binding.texi @@ -0,0 +1,37 @@ +@page +@node Binding Constructs +@chapter Definitions and Variable Bindings + +@menu +* Top Level:: Top level variable definitions. +* Local Bindings:: Local variable bindings. +* Internal Definitions:: Internal definitions. +* Binding Reflection:: Querying variable bindings. +@end menu + + +@node Top Level +@section Top Level Variable Definitions + + +@node Local Bindings +@section Local Variable Bindings + + +@node Internal Definitions +@section Internal definitions + + +@node Binding Reflection +@section Querying variable bindings + +@c NJFIXME explain [env] +@c docstring begin (texi-doc-string "guile" "defined?") +@deffn primitive defined? sym [env] +Return @code{#t} if @var{sym} is defined in the top-level environment. +@end deffn + + +@c Local Variables: +@c TeX-master: "guile.texi" +@c End: diff --git a/doc/scheme-control.texi b/doc/scheme-control.texi new file mode 100644 index 000000000..cd3cbc1bd --- /dev/null +++ b/doc/scheme-control.texi @@ -0,0 +1,236 @@ +@page +@node Control Mechanisms +@chapter Controlling the Flow of Program Execution + +@menu +* begin:: Evaluating a sequence of expressions. +* if cond case:: Simple conditional evaluation. +* and or:: Conditional evaluation of a sequence. +* while do:: Iteration mechanisms. +* Continuations:: Continuations. +* Multiple Values:: Returning and accepting multiple values. +* Exceptions:: Throwing and catching exceptions. +* Error Reporting:: Procedures for signaling errors. +* Dynamic Wind:: Guarding against non-local entrance/exit. +@end menu + + +@node begin +@section Evaluating a Sequence of Expressions + + +@node if cond case +@section Simple Conditional Evaluation + + +@node and or +@section Conditional Evaluation of a Sequence of Expressions + + +@node while do +@section Iteration mechanisms + + +@node Continuations +@section Continuations + + +@node Multiple Values +@section Returning and Accepting Multiple Values + +@deffn primitive 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. +@end deffn + +@deffn primitive call-with-values producer consumer +Calls its @var{producer} argument with no values and a +continuation that, when passed some values, calls the +@var{consumer} procedure with those values as arguments. The +continuation for the call to @var{consumer} is the continuation +of the call to @code{call-with-values}. + +@example +(call-with-values (lambda () (values 4 5)) + (lambda (a b) b)) + ==> 5 + +@end example +@example +(call-with-values * -) ==> -1 +@end example +@end deffn + + +@node Exceptions +@section Exceptions +@cindex error handling +@cindex exception handling + +It is traditional in Scheme to implement exception systems using +@code{call-with-current-continuation}. Guile does not do this, for +performance reasons. The implementation of +@code{call-with-current-continuation} is a stack copying implementation. +This allows it to interact well with ordinary C code. Unfortunately, a +stack-copying implementation can be slow -- creating a new continuation +involves a block copy of the stack. + +Instead of using @code{call-with-current-continuation}, the exception +primitives documented here are implemented as built-ins that take +advantage of the @emph{upward only} nature of exceptions. + +@c ARGFIXME tag/key +@c docstring begin (texi-doc-string "guile" "catch") +@deffn primitive catch tag thunk handler +Invoke @var{thunk} in the dynamic context of @var{handler} for +exceptions matching @var{key}. If thunk throws to the symbol @var{key}, +then @var{handler} is invoked this way: + +@example +(handler key args ...) +@end example + +@var{key} is a symbol or #t. + +@var{thunk} takes no arguments. If @var{thunk} returns normally, that +is the return value of @code{catch}. + +Handler is invoked outside the scope of its own @code{catch}. If +@var{handler} again throws to the same key, a new handler from further +up the call chain is invoked. + +If the key is @code{#t}, then a throw to @emph{any} symbol will match +this call to @code{catch}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "throw") +@deffn primitive throw key . args +Invoke the catch form matching @var{key}, passing @var{args} to the +@var{handler}. + +@var{key} is a symbol. It will match catches of the same symbol or of +#t. + +If there is no handler at all, an error is signaled. +@end deffn + +@c docstring begin (texi-doc-string "guile" "lazy-catch") +@deffn primitive lazy-catch tag thunk handler +This behaves exactly like @code{catch}, except that it does +not unwind the stack (this is the major difference), and if +handler returns, its value is returned from the throw. +@end deffn + + +@node Error Reporting +@section Procedures for Signaling Errors + +Guile provides a set of convenience procedures for signaling error +conditions that are implemented on top of the exception primitives just +described. + +@c begin (scm-doc-string "boot-9.scm" "error") +@deffn procedure error msg args @dots{} +Raise an error with key @code{misc-error} and a message constructed by +displaying @var{msg} and writing @var{args}. +@end deffn +@c end + +@c ARGFIXME rest/data +@c docstring begin (texi-doc-string "guile" "scm-error") +@deffn primitive scm-error key subr message args rest +Raise an error with key @var{key}. @var{subr} can be a string naming +the procedure associated with the error, or @code{#f}. @var{message} +is the error message string, possibly containing @code{~S} and @code{~A} +escapes. When an error is reported, these are replaced by formating the +corresponding members of @var{args}: @code{~A} (was @code{%s}) formats using @code{display} +and @code{~S} (was @code{%S}) formats using @code{write}. @var{data} is a +list or @code{#f} depending on @var{key}: if @var{key} is +@code{system-error} then it should be a list +containing the Unix @code{errno} value; If @var{key} is @code{signal} then +it should be a list containing the Unix signal number; otherwise it +will usually be @code{#f}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "strerror") +@deffn primitive strerror err +Returns the Unix error message corresponding to @var{err}, an integer. +@end deffn + +@c begin (scm-doc-string "boot-9.scm" "false-if-exception") +@deffn syntax false-if-exception expr +Returns the result of evaluating its argument; however +if an exception occurs then @code{#f} is returned instead. +@end deffn +@c end + + +@node Dynamic Wind +@section Dynamic Wind + +[FIXME: this is pasted in from Tom Lord's original guile.texi and should +be reviewed] + +@c ARGFIXME in-guard/thunk1 thunk/thunk2 out-guard/thunk3 +@c docstring begin (texi-doc-string "guile" "dynamic-wind") +@deffn primitive dynamic-wind thunk1 thunk2 thunk3 +All three arguments must be 0-argument procedures. + +@var{in-guard} is called, then @var{thunk}, then @var{out-guard}. + +If, any time during the execution of @var{thunk}, the continuation +of the @code{dynamic-wind} expression is escaped non-locally, @var{out-guard} +is called. If the continuation of the dynamic-wind is re-entered, +@var{in-guard} is called. Thus @var{in-guard} and @var{out-guard} may +be called any number of times. + +@example +(define x 'normal-binding) +@result{} x + +(define a-cont (call-with-current-continuation + (lambda (escape) + (let ((old-x x)) + (dynamic-wind + ;; in-guard: + ;; + (lambda () (set! x 'special-binding)) + + ;; thunk + ;; + (lambda () (display x) (newline) + (call-with-current-continuation escape) + (display x) (newline) + x) + + ;; out-guard: + ;; + (lambda () (set! x old-x))))))) + +;; Prints: +special-binding +;; Evaluates to: +@result{} a-cont + +x +@result{} normal-binding + +(a-cont #f) +;; Prints: +special-binding +;; Evaluates to: +@result{} a-cont ;; the value of the (define a-cont...) + +x +@result{} normal-binding + +a-cont +@result{} special-binding +@end example +@end deffn +@c Local Variables: +@c TeX-master: "guile.texi" +@c End: diff --git a/doc/scheme-data.texi b/doc/scheme-data.texi new file mode 100755 index 000000000..0d5ea363c --- /dev/null +++ b/doc/scheme-data.texi @@ -0,0 +1,4718 @@ +@page +@node Data Types +@chapter Data Types for Generic Use + +This chapter describes all the data types that Guile provides for +``generic use''. + +One of the great strengths of Scheme is that there is no straightforward +distinction between ``data'' and ``functionality''. For example, +Guile's support for dynamic linking could be described + +@itemize +@item +either in a ``data-centric'' way, as the behaviour and properties of the +``dynamically linked object'' data type, and the operations that may be +applied to instances of this type + +@item +or in a ``functionality-centric'' way, as the set of procedures that +constitute Guile's support for dynamic linking, in the context of the +module system. +@end itemize + +The contents of this chapter are, therefore, a matter of judgement. By +``generic use'', we mean to select those data types whose typical use as +@emph{data} in a wide variety of programming contexts is more important +than their use in the implementation of a particular piece of +@emph{functionality}. + +@ifinfo +The following menu +@end ifinfo +@iftex +The table of contents for this chapter +@end iftex +@ifhtml +The following table of contents +@end ifhtml +shows the data types that are documented in this chapter. The final +section of this chapter lists all the core Guile data types that are not +documented here, and provides links to the ``functionality-centric'' +sections of this manual that cover them. + +@menu +* Booleans:: True/false values. +* Numbers:: Numerical data types. +* Characters:: New character names. +* Strings:: Special things about strings. +* Regular Expressions:: Pattern matching and substitution. +* Symbols and Variables:: Manipulating the Scheme symbol table. +* Keywords:: Self-quoting, customizable display keywords. +* Pairs:: Scheme's basic building block. +* Lists:: Special list functions supported by Guile. +* Records:: +* Structures:: +* Arrays:: +* Association Lists and Hash Tables:: +* Vectors:: +* Hooks:: User-customizable event lists. +* Other Data Types:: Data types that are documented elsewhere. +@end menu + + +@node Booleans +@section Booleans + +The two boolean values are @code{#t} for true and @code{#f} for false. + +Boolean values are returned by predicate procedures, such as the general +equality predicates @code{eq?}, @code{eqv?} and @code{equal?} +(@pxref{Equality}) and numerical and string comparison operators like +@code{string=?} (REFFIXME) and @code{<=} (REFFIXME). + +@lisp +(<= 3 8) +@result{} +#t + +(<= 3 -3) +@result{} +#f + +(equal? "house" "houses") +@result{} +#f + +(eq? #f #f) +@result{} +#t +@end lisp + +In test condition contexts like @code{if} (REFFIXME) and @code{cond} +(REFFIXME), where a group of subexpressions will be evaluated only if a +@var{condition} expression evaluates to ``true'', ``true'' means any +value at all except @code{#f}. + +@lisp +(if #t "yes" "no") +@result{} +"yes" + +(if 0 "yes" "no") +@result{} +"yes" + +(if #f "yes" "no") +@result{} +"no" +@end lisp + +A result of this asymmetry is that typical Scheme source code more often +uses @code{#f} explicitly than @code{#t}: @code{#f} is necessary to +represent an @code{if} or @code{cond} false value, whereas @code{#t} is +not necessary to represent an @code{if} or @code{cond} true value. + +It is important to note that @code{#f} is @strong{not} equivalent to any +other Scheme value. In particular, @code{#f} is not the same as the +number 0 (like in C and C++), and not the same as the ``empty list'' +(like in some Lisp dialects). + +The @code{not} procedure returns the boolean inverse of its argument: + +@c docstring begin (texi-doc-string "guile" "not") +@deffn primitive not x +Return @code{#t} iff @var{x} is @code{#f}, else return @code{#f}. +@end deffn + +The @code{boolean?} procedure is a predicate that returns @code{#t} if +its argument is one of the boolean values, otherwise @code{#f}. + +@c docstring begin (texi-doc-string "guile" "boolean?") +@deffn primitive boolean? obj +Return @code{#t} iff @var{obj} is either @code{#t} or @code{#f}. +@end deffn + + +@node Numbers +@section Numerical data types + +Guile supports a rich ``tower'' of numerical types --- integer, +rational, real and complex --- and provides an extensive set of +mathematical and scientific functions for operating on numerical +data. This section of the manual documents those types and functions. + +You may also find it illuminating to read R5RS's presentation of numbers +in Scheme, which is particularly clear and accessible: see +@xref{Numbers,,,r5rs}. + +@menu +* Numerical Tower:: Scheme's numerical "tower". +* Integers:: Whole numbers. +* Reals and Rationals:: Real and rational numbers. +* Complex Numbers:: Complex numbers. +* Exactness:: Exactness and inexactness. +* Number Syntax:: Read syntax for numerical data. +* Integer Operations:: Operations on integer values. +* Comparison:: Comparison predicates. +* Conversion:: Converting numbers to and from strings. +* Complex:: Complex number operations. +* Arithmetic:: Arithmetic functions. +* Scientific:: Scientific functions. +* Primitive Numerics:: Primitive numeric functions. +* Bitwise Operations:: Logical AND, OR, NOT, and so on. +* Random:: Random number generation. +@end menu + + +@node Numerical Tower +@subsection Scheme's Numerical ``Tower'' + +Scheme's numerical ``tower'' consists of the following categories of +numbers: + +@itemize +@item +integers (whole numbers) + +@item +rationals (the set of numbers that can be expressed as P/Q where P and Q +are integers) + +@item +real numbers (the set of numbers that describes all possible positions +along a one dimensional line) + +@item +complex numbers (the set of numbers that describes all possible +positions in a two dimensional space) +@end itemize + +It is called a tower because each category ``sits on'' the one that +follows it, in the sense that every integer is also a rational, every +rational is also real, and every real number is also a complex number +(but with zero imaginary part). + +Of these, Guile implements integers, reals and complex numbers as +distinct types. Rationals are implemented as regards the read syntax +for rational numbers that is specified by R5RS, but are immediately +converted by Guile to the corresponding real number. + +The @code{number?} predicate may be applied to any Scheme value to +discover whether the value is any of the supported numerical types. + +@c docstring begin (texi-doc-string "guile" "number?") +@deffn primitive number? obj +Return @code{#t} if @var{obj} is any kind of number, @code{#f} else. +@end deffn + +For example: + +@lisp +(number? 3) +@result{} +#t + +(number? "hello there!") +@result{} +#f + +(define pi 3.141592654) +(number? pi) +@result{} +#t +@end lisp + +The next few subsections document each of Guile's numerical data types +in detail. + + +@node Integers +@subsection Integers + +Integers are whole numbers, that is numbers with no fractional part, +such as 2, 83 and -3789. + +Integers in Guile can be arbitrarily big, as shown by the following +example. + +@lisp +(define (factorial n) + (let loop ((n n) (product 1)) + (if (= n 0) + product + (loop (- n 1) (* product n))))) + +(factorial 3) +@result{} +6 + +(factorial 20) +@result{} +2432902008176640000 + +(- (factorial 45)) +@result{} +-119622220865480194561963161495657715064383733760000000000 +@end lisp + +Readers whose background is in programming languages where integers are +limited by the need to fit into just 4 or 8 bytes of memory may find +this surprising, or suspect that Guile's representation of integers is +inefficient. In fact, Guile achieves a near optimal balance of +convenience and efficiency by using the host computer's native +representation of integers where possible, and a more general +representation where the required number does not fit in the native +form. Conversion between these two representations is automatic and +completely invisible to the Scheme level programmer. + +@c REFFIXME Maybe point here to discussion of handling immediates/bignums +@c on the C level, where the conversion is not so automatic - NJ + +@c docstring begin (texi-doc-string "guile" "integer?") +@deffn primitive integer? obj +Return @code{#t} if @var{obj} is an integer number, @code{#f} else. + +@lisp +(integer? 487) +@result{} +#t + +(integer? -3.4) +@result{} +#f +@end lisp +@end deffn + + +@node Reals and Rationals +@subsection Real and Rational Numbers + +Mathematically, the real numbers are the set of numbers that describe +all possible points along a continuous, infinite, one-dimensional line. +The rational numbers are the set of all numbers that can be written as +fractions P/Q, where P and Q are integers. All rational numbers are +also real, but there are real numbers that are not rational, for example +the square root of 2, and pi. + +Guile represents both real and rational numbers approximately using a +floating point encoding with limited precision. Even though the actual +encoding is in binary, it may be helpful to think of it as a decimal +number with a limited number of significant figures and a decimal point +somewhere, since this corresponds to the standard notation for non-whole +numbers. For example: + +@lisp +0.34 +-0.00000142857931198 +-5648394822220000000000.0 +4.0 +@end lisp + +The limited precision of Guile's encoding means that any ``real'' number +in Guile can be written in a rational form, by multiplying and then dividing +by sufficient powers of 10 (or in fact, 2). For example, +@code{-0.00000142857931198} is the same as @code{142857931198} divided by +@code{100000000000000000}. In Guile's current incarnation, therefore, +the @code{rational?} and @code{real?} predicates are equivalent. + +Another aspect of this equivalence is that Guile currently does not +preserve the exactness that is possible with rational arithmetic. +If such exactness is needed, it is of course possible to implement +exact rational arithmetic at the Scheme level using Guile's arbitrary +size integers. + +A planned future revision of Guile's numerical tower will make it +possible to implement exact representations and arithmetic for both +rational numbers and real irrational numbers such as square roots, +and in such a way that the new kinds of number integrate seamlessly +with those that are already implemented. + +@c docstring begin (texi-doc-string "guile" "real?") +@deffn primitive real? obj +Return @code{#t} if @var{obj} is a real number, @code{#f} else. +Note that the sets of integer and rational values form subsets +of the set of real numbers, so the predicate will also be fulfilled +if @var{obj} is an integer number or a rational number. +@end deffn + +@c docstring begin (texi-doc-string "guile" "rational?") +@deffn primitive rational? obj +Return @code{#t} if @var{obj} is a rational number, @code{#f} else. +Note that the set of integer values forms a subset of the set of +rational numbers, so the predicate will also be fulfilled if @var{obj} +is an integer number. +@end deffn + + +@node Complex Numbers +@subsection Complex Numbers + +Complex numbers are the set of numbers that describe all possible points +in a two-dimensional space. The two coordinates of a particular point +in this space are known as the @dfn{real} and @dfn{imaginary} parts of +the complex number that describes that point. + +In Guile, complex numbers are written in rectangular form as the sum of +their real and imaginary parts, using the symbol @code{i} to indicate +the imaginary part. + +@lisp +3+4i +@result{} +3.0+4.0i + +(* 3-8i 2.3+0.3i) +@result{} +9.3-17.5i +@end lisp + +Guile represents a complex number as a pair of numbers both of which are +real, so the real and imaginary parts of a complex number have the same +properties of inexactness and limited precision as single real numbers. + +@c docstring begin (texi-doc-string "guile" "complex?") +@deffn primitive complex? obj +Return @code{#t} if @var{obj} is a complex number, @code{#f} else. +Note that the sets of real, rational and integer values form subsets of +the set of complex numbers, so the predicate will also be fulfilled if +@var{obj} is a real, rational or integer number. +@end deffn + + +@node Exactness +@subsection Exact and Inexact Numbers + +R5RS requires that a calculation involving inexact numbers always +produces an inexact result. To meet this requirement, Guile +distinguishes between an exact integer value such as @code{5} and the +corresponding inexact real value which, to the limited precision +available, has no fractional part, and is printed as @code{5.0}. Guile +will only convert the latter value to the former when forced to do so by +an invocation of the @code{inexact->exact} procedure. + +@c docstring begin (texi-doc-string "guile" "exact?") +@deffn primitive exact? x +Return #t if X is an exact number, #f otherwise. +@end deffn + +@c docstring begin (texi-doc-string "guile" "inexact?") +@deffn primitive inexact? x +Return #t if X is an inexact number, #f else. +@end deffn + +@c docstring begin (texi-doc-string "guile" "inexact->exact") +@deffn primitive inexact->exact z +Returns an exact number that is numerically closest to Z. +@end deffn + +@c begin (texi-doc-string "guile" "exact->inexact") +@deffn primitive exact->inexact +@end deffn + + +@node Number Syntax +@subsection Read Syntax for Numerical Data + +The read syntax for integers is a string of digits, optionally +preceded by a minus or plus character, a code indicating the +base in which the integer is encoded, and a code indicating whether +the number is exact or inexact. The supported base codes are: + +@itemize @bullet +@item +@code{#b}, @code{#B} --- the integer is written in binary (base 2) + +@item +@code{#o}, @code{#O} --- the integer is written in octal (base 8) + +@item +@code{#d}, @code{#D} --- the integer is written in decimal (base 10) + +@item +@code{#x}, @code{#X} --- the integer is written in hexadecimal (base 16). +@end itemize + +If the base code is omitted, the integer is assumed to be decimal. The +following examples show how these base codes are used. + +@lisp +-13 +@result{} +-13 + +#d-13 +@result{} +-13 + +#x-13 +@result{} +-19 + +#b+1101 +@result{} +13 + +#o377 +@result{} +255 +@end lisp + +The codes for indicating exactness (which can, incidentally, be applied +to all numerical values) are: + +@itemize @bullet +@item +@code{#e}, @code{#E} --- the number is exact + +@item +@code{#i}, @code{#I} --- the number is inexact. +@end itemize + +If the exactness indicator is omitted, the integer is assumed to be exact, +since Guile's internal representation for integers is always exact. +Real numbers have limited precision similar to the precision of the +@code{double} type in C. A consequence of the limited precision is that +all real numbers in Guile are also rational, since any number R with a +limited number of decimal places, say N, can be made into an integer by +multiplying by 10^N. + + +@node Integer Operations +@subsection Operations on Integer Values + +@c docstring begin (texi-doc-string "guile" "odd?") +@deffn primitive odd? n +Return #t if N is an odd number, #f otherwise. +@end deffn + +@c docstring begin (texi-doc-string "guile" "even?") +@deffn primitive even? n +Return #t if N is an even number, #f otherwise. +@end deffn + +@c begin (texi-doc-string "guile" "quotient") +@deffn primitive quotient +@end deffn + +@c begin (texi-doc-string "guile" "remainder") +@deffn primitive remainder +@end deffn + +@c begin (texi-doc-string "guile" "modulo") +@deffn primitive modulo +@end deffn + +@c begin (texi-doc-string "guile" "gcd") +@deffn primitive gcd +@end deffn + +@c begin (texi-doc-string "guile" "lcm") +@deffn primitive lcm +@end deffn + + +@node Comparison +@subsection Comparison Predicates + +@c begin (texi-doc-string "guile" "=") +@deffn primitive = +@end deffn + +@c begin (texi-doc-string "guile" "<") +@deffn primitive < +@end deffn + +@c begin (texi-doc-string "guile" ">") +@deffn primitive > +@end deffn + +@c begin (texi-doc-string "guile" "<=") +@deffn primitive <= +@end deffn + +@c begin (texi-doc-string "guile" ">=") +@deffn primitive >= +@end deffn + +@c begin (texi-doc-string "guile" "zero?") +@deffn primitive zero? +@end deffn + +@c begin (texi-doc-string "guile" "positive?") +@deffn primitive positive? +@end deffn + +@c begin (texi-doc-string "guile" "negative?") +@deffn primitive negative? +@end deffn + + +@node Conversion +@subsection Converting Numbers To and From Strings + +@c docstring begin (texi-doc-string "guile" "number->string") +@deffn primitive number->string n [radix] +Return a string holding the external representation of the +number N in the given RADIX. If N is inexact, a radix of 10 +will be used. +@end deffn + +@c docstring begin (texi-doc-string "guile" "string->number") +@deffn primitive string->number string [radix] +Returns a number of the maximally precise representation +expressed by the given STRING. RADIX must be an exact integer, +either 2, 8, 10, or 16. If supplied, RADIX is a default radix +that may be overridden by an explicit radix prefix in STRING +(e.g. "#o177"). If RADIX is not supplied, then the default +radix is 10. If string is not a syntactically valid notation +for a number, then `string->number' returns #f. (r5rs) +@end deffn + + +@node Complex +@subsection Complex Number Operations + +@c docstring begin (texi-doc-string "guile" "make-rectangular") +@deffn primitive make-rectangular real imaginary +Return a complex number constructed of the given REAL and +IMAGINARY parts. +@end deffn + +@c docstring begin (texi-doc-string "guile" "make-polar") +@deffn primitive make-polar x y +Return the complex number X * e^(i * Y). +@end deffn + +@c begin (texi-doc-string "guile" "real-part") +@deffn primitive real-part +@end deffn + +@c begin (texi-doc-string "guile" "imag-part") +@deffn primitive imag-part +@end deffn + +@c begin (texi-doc-string "guile" "magnitude") +@deffn primitive magnitude +@end deffn + +@c begin (texi-doc-string "guile" "angle") +@deffn primitive angle +@end deffn + + +@node Arithmetic +@subsection Arithmetic Functions + +@c begin (texi-doc-string "guile" "+") +@deffn primitive + +@end deffn + +@c begin (texi-doc-string "guile" "-") +@deffn primitive - +@end deffn + +@c begin (texi-doc-string "guile" "*") +@deffn primitive * +@end deffn + +@c begin (texi-doc-string "guile" "/") +@deffn primitive / +@end deffn + +@c begin (texi-doc-string "guile" "abs") +@deffn primitive abs +@end deffn + +@c begin (texi-doc-string "guile" "max") +@deffn primitive max +@end deffn + +@c begin (texi-doc-string "guile" "min") +@deffn primitive min +@end deffn + +@c begin (texi-doc-string "guile" "truncate") +@deffn primitive truncate +@end deffn + +@c begin (texi-doc-string "guile" "round") +@deffn primitive round +@end deffn + +@c begin (texi-doc-string "guile" "floor") +@deffn primitive floor +@end deffn + +@c begin (texi-doc-string "guile" "ceiling") +@deffn primitive ceiling +@end deffn + + +@node Scientific +@subsection Scientific Functions + +The following procedures accept any kind of number as arguments, +including complex numbers. + +@c begin (texi-doc-string "guile" "sqrt") +@deffn procedure sqrt z +Return the square root of @var{z}. +@end deffn + +@c begin (texi-doc-string "guile" "expt") +@deffn procedure expt z1 z2 +Return @var{z1} raised to the power of @var{z2}. +@end deffn + +@c begin (texi-doc-string "guile" "sin") +@deffn procedure sin z +Return the sine of @var{z}. +@end deffn + +@c begin (texi-doc-string "guile" "cos") +@deffn procedure cos z +Return the cosine of @var{z}. +@end deffn + +@c begin (texi-doc-string "guile" "tan") +@deffn procedure tan z +Return the tangent of @var{z}. +@end deffn + +@c begin (texi-doc-string "guile" "asin") +@deffn procedure asin z +Return the arcsine of @var{z}. +@end deffn + +@c begin (texi-doc-string "guile" "acos") +@deffn procedure acos z +Return the arccosine of @var{z}. +@end deffn + +@c begin (texi-doc-string "guile" "atan") +@deffn procedure atan z +Return the arctangent of @var{z}. +@end deffn + +@c begin (texi-doc-string "guile" "exp") +@deffn procedure exp z +Return e to the power of @var{z}, where e is the base of natural +logarithms (2.71828@dots{}). +@end deffn + +@c begin (texi-doc-string "guile" "log") +@deffn procedure log z +Return the natural logarithm of @var{z}. +@end deffn + +@c begin (texi-doc-string "guile" "log10") +@deffn procedure log10 z +Return the base 10 logarithm of @var{z}. +@end deffn + +@c begin (texi-doc-string "guile" "sinh") +@deffn procedure sinh z +Return the hyperbolic sine of @var{z}. +@end deffn + +@c begin (texi-doc-string "guile" "cosh") +@deffn procedure cosh z +Return the hyperbolic cosine of @var{z}. +@end deffn + +@c begin (texi-doc-string "guile" "tanh") +@deffn procedure tanh z +Return the hyperbolic tangent of @var{z}. +@end deffn + +@c begin (texi-doc-string "guile" "asinh") +@deffn procedure asinh z +Return the hyperbolic arcsine of @var{z}. +@end deffn + +@c begin (texi-doc-string "guile" "acosh") +@deffn procedure acosh z +Return the hyperbolic arccosine of @var{z}. +@end deffn + +@c begin (texi-doc-string "guile" "atanh") +@deffn procedure atanh z +Return the hyperbolic arctangent of @var{z}. +@end deffn + + +@node Primitive Numerics +@subsection Primitive Numeric Functions + +Many of Guile's numeric procedures which accept any kind of numbers as +arguments, including complex numbers, are implemented as Scheme +procedures that use the following real number-based primitives. These +primitives signal an error if they are called with complex arguments. + +@c begin (texi-doc-string "guile" "$abs") +@deffn primitive $abs x +Return the absolute value of @var{x}. +@end deffn + +@c begin (texi-doc-string "guile" "$sqrt") +@deffn primitive $sqrt x +Return the square root of @var{x}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "$expt") +@deffn primitive $expt x y +Return @var{x} raised to the power of @var{y}. This +procedure does not accept complex arguments. +@end deffn + +@c begin (texi-doc-string "guile" "$sin") +@deffn primitive $sin x +Return the sine of @var{x}. +@end deffn + +@c begin (texi-doc-string "guile" "$cos") +@deffn primitive $cos x +Return the cosine of @var{x}. +@end deffn + +@c begin (texi-doc-string "guile" "$tan") +@deffn primitive $tan x +Return the tangent of @var{x}. +@end deffn + +@c begin (texi-doc-string "guile" "$asin") +@deffn primitive $asin x +Return the arcsine of @var{x}. +@end deffn + +@c begin (texi-doc-string "guile" "$acos") +@deffn primitive $acos x +Return the arccosine of @var{x}. +@end deffn + +@c begin (texi-doc-string "guile" "$atan") +@deffn primitive $atan x +Return the arctangent of @var{x} in the range -PI/2 to PI/2. +@end deffn + +@c docstring begin (texi-doc-string "guile" "$atan2") +@deffn primitive $atan2 x y +Return the arc tangent of the two arguments @var{x} and +@var{y}. This is similar to calculating the arc tangent of +@var{x} / @var{y}, except that the signs of both arguments +are used to determine the quadrant of the result. This +procedure does not accept complex arguments. +@end deffn + +@c begin (texi-doc-string "guile" "$exp") +@deffn primitive $exp x +Return e to the power of @var{x}, where e is the base of natural +logarithms (2.71828@dots{}). +@end deffn + +@c begin (texi-doc-string "guile" "$log") +@deffn primitive $log x +Return the natural logarithm of @var{x}. +@end deffn + +@c begin (texi-doc-string "guile" "$sinh") +@deffn primitive $sinh x +Return the hyperbolic sine of @var{x}. +@end deffn + +@c begin (texi-doc-string "guile" "$cosh") +@deffn primitive $cosh x +Return the hyperbolic cosine of @var{x}. +@end deffn + +@c begin (texi-doc-string "guile" "$tanh") +@deffn primitive $tanh x +Return the hyperbolic tangent of @var{x}. +@end deffn + +@c begin (texi-doc-string "guile" "$asinh") +@deffn primitive $asinh x +Return the hyperbolic arcsine of @var{x}. +@end deffn + +@c begin (texi-doc-string "guile" "$acosh") +@deffn primitive $acosh x +Return the hyperbolic arccosine of @var{x}. +@end deffn + +@c begin (texi-doc-string "guile" "$atanh") +@deffn primitive $atanh x +Return the hyperbolic arctangent of @var{x}. +@end deffn + + +@node Bitwise Operations +@subsection Bitwise Operations + +@c docstring begin (texi-doc-string "guile" "logand") +@deffn primitive logand n1 n2 +Returns the integer which is the bit-wise AND of the two integer +arguments. + +Example: +@lisp +(number->string (logand #b1100 #b1010) 2) + @result{} "1000" +@end lisp +@end deffn + +@c docstring begin (texi-doc-string "guile" "logior") +@deffn primitive logior n1 n2 +Returns the integer which is the bit-wise OR of the two integer +arguments. + +Example: +@lisp +(number->string (logior #b1100 #b1010) 2) + @result{} "1110" +@end lisp +@end deffn + +@c docstring begin (texi-doc-string "guile" "logxor") +@deffn primitive logxor n1 n2 +Returns the integer which is the bit-wise XOR of the two integer +arguments. + +Example: +@lisp +(number->string (logxor #b1100 #b1010) 2) + @result{} "110" +@end lisp +@end deffn + +@c docstring begin (texi-doc-string "guile" "lognot") +@deffn primitive lognot n +Returns the integer which is the 2s-complement of the integer argument. + +Example: +@lisp +(number->string (lognot #b10000000) 2) + @result{} "-10000001" +(number->string (lognot #b0) 2) + @result{} "-1" +@end lisp +@end deffn + +@c ARGFIXME j/n1 k/n2 +@c docstring begin (texi-doc-string "guile" "logtest") +@deffn primitive logtest n1 n2 +@example +(logtest j k) @equiv{} (not (zero? (logand j k))) + +(logtest #b0100 #b1011) @result{} #f +(logtest #b0100 #b0111) @result{} #t +@end example +@end deffn + +@c docstring begin (texi-doc-string "guile" "logbit?") +@deffn primitive logbit? index j +@example +(logbit? index j) @equiv{} (logtest (integer-expt 2 index) j) + +(logbit? 0 #b1101) @result{} #t +(logbit? 1 #b1101) @result{} #f +(logbit? 2 #b1101) @result{} #t +(logbit? 3 #b1101) @result{} #t +(logbit? 4 #b1101) @result{} #f +@end example +@end deffn + +@c ARGFIXME n/int cnt/count +@c docstring begin (texi-doc-string "guile" "ash") +@deffn primitive ash n cnt +The function ash performs an arithmetic shift left by CNT bits +(or shift right, if CNT is negative). 'Arithmetic' means, that +the function does not guarantee to keep the bit structure of N, +but rather guarantees that the result will always be rounded +towards minus infinity. Therefore, the results of ash and a +corresponding bitwise shift will differ if N is negative. + +Formally, the function returns an integer equivalent to +@code{(inexact->exact (floor (* N (expt 2 CNT))))}.@refill + +Example: +@lisp +(number->string (ash #b1 3) 2) + @result{} "1000" +(number->string (ash #b1010 -1) 2) + @result{} "101" +@end lisp +@end deffn + +@c docstring begin (texi-doc-string "guile" "logcount") +@deffn primitive logcount n +Returns the number of bits in integer @var{n}. If integer is positive, +the 1-bits in its binary representation are counted. If negative, the +0-bits in its two's-complement binary representation are counted. If 0, +0 is returned. + +Example: +@lisp +(logcount #b10101010) + @result{} 4 +(logcount 0) + @result{} 0 +(logcount -2) + @result{} 1 +@end lisp +@end deffn + +@c docstring begin (texi-doc-string "guile" "integer-length") +@deffn primitive integer-length n +Returns the number of bits neccessary to represent @var{n}. + +Example: +@lisp +(integer-length #b10101010) + @result{} 8 +(integer-length 0) + @result{} 0 +(integer-length #b1111) + @result{} 4 +@end lisp +@end deffn + +@c docstring begin (texi-doc-string "guile" "integer-expt") +@deffn primitive integer-expt n k +Returns @var{n} raised to the non-negative integer exponent @var{k}. + +Example: +@lisp +(integer-expt 2 5) + @result{} 32 +(integer-expt -3 3) + @result{} -27 +@end lisp +@end deffn + +@c docstring begin (texi-doc-string "guile" "bit-extract") +@deffn primitive bit-extract n start end +Returns the integer composed of the @var{start} (inclusive) through +@var{end} (exclusive) bits of @var{n}. The @var{start}th bit becomes +the 0-th bit in the result.@refill + +Example: +@lisp +(number->string (bit-extract #b1101101010 0 4) 2) + @result{} "1010" +(number->string (bit-extract #b1101101010 4 9) 2) + @result{} "10110" +@end lisp +@end deffn + + +@node Random +@subsection Random Number Generation + +@c docstring begin (texi-doc-string "guile" "copy-random-state") +@deffn primitive copy-random-state [state] +Return a copy of the random state @var{state}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "random") +@deffn primitive random n [state] +Return a number in [0,N). +Accepts a positive integer or real n and returns a +number of the same type between zero (inclusive) and +N (exclusive). The values returned have a uniform +distribution. +The optional argument @var{state} must be of the type produced +by @code{seed->random-state}. It defaults to the value of the +variable @var{*random-state*}. This object is used to maintain +the state of the pseudo-random-number generator and is altered +as a side effect of the random operation. +@end deffn + +@c docstring begin (texi-doc-string "guile" "random:exp") +@deffn primitive random:exp [state] +Returns an inexact real in an exponential distribution with mean 1. +For an exponential distribution with mean u use (* u (random:exp)). +@end deffn + +@c docstring begin (texi-doc-string "guile" "random:hollow-sphere!") +@deffn primitive random:hollow-sphere! v [state] +Fills vect with inexact real random numbers +the sum of whose squares is equal to 1.0. +Thinking of vect as coordinates in space of +dimension n = (vector-length vect), the coordinates +are uniformly distributed over the surface of the +unit n-shere. +@end deffn + +@c docstring begin (texi-doc-string "guile" "random:normal") +@deffn primitive random:normal [state] +Returns an inexact real in a normal distribution. +The distribution used has mean 0 and standard deviation 1. +For a normal distribution with mean m and standard deviation +d use @code{(+ m (* d (random:normal)))}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "random:normal-vector!") +@deffn primitive random:normal-vector! v [state] +Fills vect with inexact real random numbers that are +independent and standard normally distributed +(i.e., with mean 0 and variance 1). +@end deffn + +@c docstring begin (texi-doc-string "guile" "random:solid-sphere!") +@deffn primitive random:solid-sphere! v [state] +Fills vect with inexact real random numbers +the sum of whose squares is less than 1.0. +Thinking of vect as coordinates in space of +dimension n = (vector-length vect), the coordinates +are uniformly distributed within the unit n-shere. +The sum of the squares of the numbers is returned. +@end deffn + +@c docstring begin (texi-doc-string "guile" "random:uniform") +@deffn primitive random:uniform [state] +Returns a uniformly distributed inexact real random number in [0,1). +@end deffn + +@c docstring begin (texi-doc-string "guile" "seed->random-state") +@deffn primitive seed->random-state seed +Return a new random state using @var{seed}. +@end deffn + + +@node Characters +@section Characters + +Most of the characters in the ASCII character set may be referred to by +name: for example, @code{#\tab}, @code{#\esc}, @code{#\stx}, and so on. +The following table describes the ASCII names for each character. + +@multitable @columnfractions .25 .25 .25 .25 +@item 0 = @code{#\nul} + @tab 1 = @code{#\soh} + @tab 2 = @code{#\stx} + @tab 3 = @code{#\etx} +@item 4 = @code{#\eot} + @tab 5 = @code{#\enq} + @tab 6 = @code{#\ack} + @tab 7 = @code{#\bel} +@item 8 = @code{#\bs} + @tab 9 = @code{#\ht} + @tab 10 = @code{#\nl} + @tab 11 = @code{#\vt} +@item 12 = @code{#\np} + @tab 13 = @code{#\cr} + @tab 14 = @code{#\so} + @tab 15 = @code{#\si} +@item 16 = @code{#\dle} + @tab 17 = @code{#\dc1} + @tab 18 = @code{#\dc2} + @tab 19 = @code{#\dc3} +@item 20 = @code{#\dc4} + @tab 21 = @code{#\nak} + @tab 22 = @code{#\syn} + @tab 23 = @code{#\etb} +@item 24 = @code{#\can} + @tab 25 = @code{#\em} + @tab 26 = @code{#\sub} + @tab 27 = @code{#\esc} +@item 28 = @code{#\fs} + @tab 29 = @code{#\gs} + @tab 30 = @code{#\rs} + @tab 31 = @code{#\us} +@item 32 = @code{#\sp} +@end multitable + +The @code{delete} character (octal 177) may be referred to with the name +@code{#\del}. + +Several characters have more than one name: + +@itemize @bullet +@item +#\space, #\sp +@item +#\newline, #\nl +@item +#\tab, #\ht +@item +#\backspace, #\bs +@item +#\return, #\cr +@item +#\page, #\np +@item +#\null, #\nul +@end itemize + +@c docstring begin (texi-doc-string "guile" "char?") +@deffn primitive char? x +Return @code{#t} iff @var{x} is a character, else @code{#f}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "char=?") +@deffn primitive char=? x y +Return @code{#t} iff @var{x} is the same character as @var{y}, else @code{#f}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "char?") +@deffn primitive char>? x y +Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII +sequence, else @code{#f}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "char>=?") +@deffn primitive char>=? x y +Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the +ASCII sequence, else @code{#f}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "char-ci=?") +@deffn primitive char-ci=? x y +Return @code{#t} iff @var{x} is the same character as @var{y} ignoring +case, else @code{#f}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "char-ci?") +@deffn primitive char-ci>? x y +Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII +sequence ignoring case, else @code{#f}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "char-ci>=?") +@deffn primitive char-ci>=? x y +Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the +ASCII sequence ignoring case, else @code{#f}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "char-alphabetic?") +@deffn primitive char-alphabetic? chr +Return @code{#t} iff @var{chr} is alphabetic, else @code{#f}. +Alphabetic means the same thing as the isalpha C library function. +@end deffn + +@c docstring begin (texi-doc-string "guile" "char-numeric?") +@deffn primitive char-numeric? chr +Return @code{#t} iff @var{chr} is numeric, else @code{#f}. +Numeric means the same thing as the isdigit C library function. +@end deffn + +@c docstring begin (texi-doc-string "guile" "char-whitespace?") +@deffn primitive char-whitespace? chr +Return @code{#t} iff @var{chr} is whitespace, else @code{#f}. +Whitespace means the same thing as the isspace C library function. +@end deffn + +@c docstring begin (texi-doc-string "guile" "char-upper-case?") +@deffn primitive char-upper-case? chr +Return @code{#t} iff @var{chr} is uppercase, else @code{#f}. +Uppercase means the same thing as the isupper C library function. +@end deffn + +@c docstring begin (texi-doc-string "guile" "char-lower-case?") +@deffn primitive char-lower-case? chr +Return @code{#t} iff @var{chr} is lowercase, else @code{#f}. +Lowercase means the same thing as the islower C library function. +@end deffn + +@c docstring begin (texi-doc-string "guile" "char-is-both?") +@deffn primitive char-is-both? chr +Return @code{#t} iff @var{chr} is either uppercase or lowercase, else @code{#f}. +Uppercase and lowercase are as defined by the isupper and islower +C library functions. +@end deffn + +@c docstring begin (texi-doc-string "guile" "char->integer") +@deffn primitive char->integer chr +Return the number corresponding to ordinal position of @var{chr} in the +ASCII sequence. +@end deffn + +@c docstring begin (texi-doc-string "guile" "integer->char") +@deffn primitive integer->char n +Return the character at position @var{n} in the ASCII sequence. +@end deffn + +@c docstring begin (texi-doc-string "guile" "char-upcase") +@deffn primitive char-upcase chr +Return the uppercase character version of @var{chr}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "char-downcase") +@deffn primitive char-downcase chr +Return the lowercase character version of @var{chr}. +@end deffn + + +@node Strings +@section Strings + +[FIXME: this is pasted in from Tom Lord's original guile.texi and should +be reviewed] + +For the sake of efficiency, two special kinds of strings are available +in Guile: shared substrings and the misleadingly named ``read-only'' +strings. It is not necessary to know about these to program in Guile, +but you are likely to run into one or both of these special string types +eventually, and it will be helpful to know how they work. + +@menu +* String Fun:: New functions for manipulating strings. +* Shared Substrings:: Strings which share memory with each other. +* Read Only Strings:: Treating certain non-strings as strings. +@end menu + +@node String Fun +@subsection String Fun + +@c docstring begin (texi-doc-string "guile" "string") +@c docstring begin (texi-doc-string "guile" "list->string") +@deffn primitive string . chrs +@deffnx primitive list->string chrs +Returns a newly allocated string composed of the arguments, +@var{chrs}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "make-string") +@deffn primitive make-string k [chr] +Return a newly allocated string of +length @var{k}. If @var{chr} is given, then all elements of +the string are initialized to @var{chr}, otherwise the contents +of the @var{string} are unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "string-append") +@deffn primitive string-append . args +Return a newly allocated string whose characters form the +concatenation of the given strings, @var{args}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "string-length") +@deffn primitive string-length string +Return the number of characters in @var{string}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "string-ref") +@deffn primitive string-ref str k +Return character @var{k} of @var{str} using zero-origin +indexing. @var{k} must be a valid index of @var{str}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "string-set!") +@deffn primitive string-set! str k chr +Store @var{chr} in element @var{k} of @var{str} and return +an unspecified value. @var{k} must be a valid index of +@var{str}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "string?") +@deffn primitive string? obj +Returns @code{#t} iff @var{obj} is a string, else returns +@code{#f}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "substring") +@deffn primitive substring str start [end] +Return a newly allocated string formed from the characters +of @var{str} beginning with index @var{start} (inclusive) and +ending with index @var{end} (exclusive). +@var{str} must be a string, @var{start} and @var{end} must be +exact integers satisfying: + +0 <= @var{start} <= @var{end} <= (string-length @var{str}). +@end deffn + +@c docstring begin (texi-doc-string "guile" "string-index") +@deffn primitive string-index str chr [frm [to]] +Return the index of the first occurrence of @var{chr} in @var{str}. The +optional integer arguments @var{frm} and @var{to} limit the search to +a portion of the string. This procedure essentially implements the +@code{index} or @code{strchr} functions from the C library. + +(qdocs:) Returns the index of @var{char} in @var{str}, or @code{#f} if the +@var{char} isn't in @var{str}. If @var{frm} is given and not @code{#f}, +it is used as the starting index; if @var{to} is given and not @var{#f}, +it is used as the ending index (exclusive). + +@example +(string-index "weiner" #\e) +@result{} 1 + +(string-index "weiner" #\e 2) +@result{} 4 + +(string-index "weiner" #\e 2 4) +@result{} #f +@end example +@end deffn + +@c docstring begin (texi-doc-string "guile" "string-rindex") +@deffn primitive string-rindex str chr [frm [to]] +Like @code{string-index}, but search from the right of the string rather +than from the left. This procedure essentially implements the +@code{rindex} or @code{strrchr} functions from the C library. + +(qdocs:) The same as @code{string-index}, except it gives the rightmost occurance +of @var{char} in the range [@var{frm}, @var{to}-1], which defaults to +the entire string. + +@example +(string-rindex "weiner" #\e) +@result{} 4 + +(string-rindex "weiner" #\e 2 4) +@result{} #f + +(string-rindex "weiner" #\e 2 5) +@result{} 4 +@end example +@end deffn + +@c docstring begin (texi-doc-string "guile" "substring-move!") +@c docstring begin (texi-doc-string "guile" "substring-move-left!") +@c docstring begin (texi-doc-string "guile" "substring-move-right!") +@deffn primitive substring-move! str1 start1 end1 str2 start2 +@deffnx primitive substring-move-left! str1 start1 end1 str2 start2 +@deffnx primitive substring-move-right! str1 start1 end1 str2 start2 +Copy the substring of @var{str1} bounded by @var{start1} and @var{end1} +into @var{str2} beginning at position @var{end2}. +@code{substring-move-right!} begins copying from the rightmost character +and moves left, and @code{substring-move-left!} copies from the leftmost +character moving right. + +It is useful to have two functions that copy in different directions so +that substrings can be copied back and forth within a single string. If +you wish to copy text from the left-hand side of a string to the +right-hand side of the same string, and the source and destination +overlap, you must be careful to copy the rightmost characters of the +text first, to avoid clobbering your data. Hence, when @var{str1} and +@var{str2} are the same string, you should use +@code{substring-move-right!} when moving text from left to right, and +@code{substring-move-left!} otherwise. If @code{str1} and @samp{str2} +are different strings, it does not matter which function you use. +@end deffn + +@deffn primitive substring-move-left! str1 start1 end1 str2 start2 +@end deffn +@deftypefn {C Function} SCM scm_substring_move_left_x (SCM @var{str1}, SCM @var{start1}, SCM @var{end1}, SCM @var{str2}, SCM @var{start2}) +[@strong{Note:} this is only valid if you've applied the strop patch]. + +Moves a substring of @var{str1}, from @var{start1} to @var{end1} +(@var{end1} is exclusive), into @var{str2}, starting at +@var{start2}. Allows overlapping strings. + +@example +(define x (make-string 10 #\a)) +(define y "bcd") +(substring-move-left! x 2 5 y 0) +y +@result{} "aaa" + +x +@result{} "aaaaaaaaaa" + +(define y "bcdefg") +(substring-move-left! x 2 5 y 0) +y +@result{} "aaaefg" + +(define y "abcdefg") +(substring-move-left! y 2 5 y 3) +y +@result{} "abccccg" +@end example +@end deftypefn + +@deffn substring-move-right! str1 start1 end1 str2 start2 +@end deffn +@deftypefn {C Function} SCM scm_substring_move_right_x (SCM @var{str1}, SCM @var{start1}, SCM @var{end1}, SCM @var{str2}, SCM @var{start2}) +[@strong{Note:} this is only valid if you've applied the strop patch, if +it hasn't made it into the guile tree]. + +Does much the same thing as @code{substring-move-left!}, except it +starts moving at the end of the sequence, rather than the beginning. +@example +(define y "abcdefg") +(substring-move-right! y 2 5 y 0) +y +@result{} "ededefg" + +(define y "abcdefg") +(substring-move-right! y 2 5 y 3) +y +@result{} "abccdeg" +@end example +@end deftypefn + +@c docstring begin (texi-doc-string "guile" "vector-move-left!") +@deffn primitive vector-move-left! vec1 start1 end1 vec2 start2 +Vector version of @code{substring-move-left!}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "vector-move-right!") +@deffn primitive vector-move-right! vec1 start1 end1 vec2 start2 +Vector version of @code{substring-move-right!}. +@end deffn + +@c ARGFIXME fill/fill-char +@c docstring begin (texi-doc-string "guile" "substring-fill!") +@deffn primitive substring-fill! str start end fill +Change every character in @var{str} between @var{start} and @var{end} to +@var{fill-char}. + +(qdocs:) Destructively fills @var{str}, from @var{start} to @var{end}, with @var{fill}. + +@example +(define y "abcdefg") +(substring-fill! y 1 3 #\r) +y +@result{} "arrdefg" +@end example +@end deffn + +@c docstring begin (texi-doc-string "guile" "string-null?") +@deffn primitive string-null? str +Return @code{#t} if @var{str}'s length is nonzero, and @code{#f} +otherwise. + +(qdocs:) Returns @code{#t} if @var{str} is empty, else returns @code{#f}. + +@example +(string-null? "") +@result{} #t + +(string-null? y) +@result{} #f +@end example +@end deffn + +@c ARGFIXME v/str +@c docstring begin (texi-doc-string "guile" "string-upcase!") +@deffn primitive string-upcase! str +Destructively upcase every character in @code{str}. + +(qdocs:) Converts each element in @var{str} to upper case. + +@example +(string-upcase! y) +@result{} "ARRDEFG" + +y +@result{} "ARRDEFG" +@end example +@end deffn + +@c docstring begin (texi-doc-string "guile" "string-upcase") +@deffn primitive string-upcase str +Upcase every character in @code{str}. +@end deffn + +@c ARGFIXME v/str +@c docstring begin (texi-doc-string "guile" "string-downcase!") +@deffn primitive string-downcase! str +Destructively downcase every character in @code{str}. + +(qdocs:) Converts each element in @var{str} to lower case. + +@example +y +@result{} "ARRDEFG" + +(string-downcase! y) +@result{} "arrdefg" + +y +@result{} "arrdefg" +@end example +@end deffn + +@c docstring begin (texi-doc-string "guile" "string-downcase") +@deffn primitive string-downcase str +Downcase every character in @code{str}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "string-capitalize!") +@deffn primitive string-capitalize! str +Destructively capitalize every character in @code{str}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "string-capitalize") +@deffn primitive string-capitalize str +Capitalize every character in @code{str}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "string-ci<=?") +@deffn primitive string-ci<=? s1 s2 +Case insensitive lexicographic ordering predicate; +returns @t{#t} if @var{s1} is lexicographically less than +or equal to @var{s2} regardless of case. (r5rs) +@end deffn + +@c docstring begin (texi-doc-string "guile" "string-ci=?") +@deffn primitive string-ci>=? s1 s2 +Case insensitive lexicographic ordering predicate; +returns @t{#t} if @var{s1} is lexicographically greater than +or equal to @var{s2} regardless of case. (r5rs) +@end deffn + +@c docstring begin (texi-doc-string "guile" "string-ci>?") +@deffn primitive string-ci>? s1 s2 +Case insensitive lexicographic ordering predicate; +returns @t{#t} if @var{s1} is lexicographically greater than +@var{s2} regardless of case. (r5rs) +@end deffn + +@c docstring begin (texi-doc-string "guile" "string<=?") +@deffn primitive string<=? s1 s2 +Lexicographic ordering predicate; returns @t{#t} if @var{s1} +is lexicographically less than or equal to @var{s2}. (r5rs) +@end deffn + +@c docstring begin (texi-doc-string "guile" "string=?") +@deffn primitive string>=? s1 s2 +Lexicographic ordering predicate; returns @t{#t} if @var{s1} +is lexicographically greater than or equal to @var{s2}. (r5rs) +@end deffn + +@c docstring begin (texi-doc-string "guile" "string>?") +@deffn primitive string>? s1 s2 +Lexicographic ordering predicate; returns @t{#t} if @var{s1} +is lexicographically greater than @var{s2}. (r5rs) +@end deffn + +@c docstring begin (texi-doc-string "guile" "string->list") +@deffn primitive string->list str +@samp{String->list} returns a newly allocated list of the +characters that make up the given string. @samp{List->string} +returns a newly allocated string formed from the characters in the list +@var{list}, which must be a list of characters. @samp{String->list} +and @samp{list->string} are +inverses so far as @samp{equal?} is concerned. (r5rs) +@end deffn + +@c docstring begin (texi-doc-string "guile" "string-ci->symbol") +@deffn primitive string-ci->symbol str +Return the symbol whose name is @var{str}, downcased in necessary(???). +@end deffn + +@c docstring begin (texi-doc-string "guile" "string-copy") +@deffn primitive string-copy str +Returns a newly allocated copy of the given @var{string}. (r5rs) +@end deffn + +@c docstring begin (texi-doc-string "guile" "string-fill!") +@deffn primitive string-fill! str chr +Stores @var{char} in every element of the given @var{string} and returns an +unspecified value. (r5rs) +@end deffn + + +@node Shared Substrings +@subsection Shared Substrings + +Whenever you extract a substring using @code{substring}, the Scheme +interpreter allocates a new string and copies data from the old string. +This is expensive, but @code{substring} is so convenient for +manipulating text that programmers use it often. + +Guile Scheme provides the concept of the @dfn{shared substring} to +improve performance of many substring-related operations. A shared +substring is an object that mostly behaves just like an ordinary +substring, except that it actually shares storage space with its parent +string. + +@c ARGFIXME frm/start to/end +@c docstring begin (texi-doc-string "guile" "make-shared-substring") +@deffn primitive make-shared-substring str [frm [to]] +Return a shared substring of @var{str}. The semantics are the same as +for the @code{substring} function: the shared substring returned +includes all of the text from @var{str} between indexes @var{start} +(inclusive) and @var{end} (exclusive). If @var{end} is omitted, it +defaults to the end of @var{str}. The shared substring returned by +@code{make-shared-substring} occupies the same storage space as +@var{str}. +@end deffn + +Example: + +@example +(define foo "the quick brown fox") +(define bar (make-shared-substring some-string 4 9)) + +foo => "t h e q u i c k b r o w n f o x" +bar =========> |---------| +@end example + +The shared substring @var{bar} is not given its own storage space. +Instead, the Guile interpreter notes internally that @var{bar} points to +a portion of the memory allocated to @var{foo}. However, @var{bar} +behaves like an ordinary string in most respects: it may be used with +string primitives like @code{string-length}, @code{string-ref}, +@code{string=?}. Guile makes the necessary translation between indices +of @var{bar} and indices of @var{foo} automatically. + +@example +(string-length? bar) @result{} 5 ; bar only extends from indices 4 to 9 +(string-ref bar 3) @result{} #\c ; same as (string-ref foo 7) +(make-shared-substring bar 2) + @result{} "ick" ; can even make a shared substring! +@end example + +Because creating a shared substring does not require allocating new +storage from the heap, it is a very fast operation. However, because it +shares memory with its parent string, a change to the contents of the +parent string will implicitly change the contents of its shared +substrings. + +@example +(string-set! foo 7 #\r) +bar @result{} "quirk" +@end example + +Guile considers shared substrings to be immutable. This is because +programmers might not always be aware that a given string is really a +shared substring, and might innocently try to mutate it without +realizing that the change would affect its parent string. (We are +currently considering a "copy-on-write" strategy that would permit +modifying shared substrings without affecting the parent string.) + +In general, shared substrings are useful in circumstances where it is +important to divide a string into smaller portions, but you do not +expect to change the contents of any of the strings involved. + +@node Read Only Strings +@subsection Read Only Strings + +Type-checking in Guile primitives distinguishes between mutable strings +and read only strings. Mutable strings answer @code{#t} to +@code{string?} while read only strings may or may not. All kinds of +strings, whether or not they are mutable return #t to this: + +@c ARGFIXME x/obj +@c docstring begin (texi-doc-string "guile" "read-only-string?") +@deffn primitive read-only-string? obj +Return true if @var{obj} can be read as a string, + +This illustrates the difference between @code{string?} and +@code{read-only-string?}: + +@example +(string? "a string") @result{} #t +(string? 'a-symbol) @result{} #f + +(read-only-string? "a string") @result{} #t +(read-only-string? 'a-symbol) @result{} #t +@end example +@end deffn + +"Read-only" refers to how the string will be used, not how the string is +permitted to be used. In particular, all strings are "read-only +strings" even if they are mutable, because a function that only reads +from a string can certainly operate on even a mutable string. + +Symbols are an example of read-only strings. Many string functions, +such as @code{string-append} are happy to operate on symbols. Many +functions that expect a string argument, such as @code{open-file}, will +accept a symbol as well. + +Shared substrings, discussed in the previous chapter, also happen to be +read-only strings. + + +@node Regular Expressions +@section Regular Expressions + +@cindex regular expressions +@cindex regex +@cindex emacs regexp + +A @dfn{regular expression} (or @dfn{regexp}) is a pattern that +describes a whole class of strings. A full description of regular +expressions and their syntax is beyond the scope of this manual; +an introduction can be found in the Emacs manual (@pxref{Regexps, +, Syntax of Regular Expressions, emacs, The GNU Emacs Manual}, or +in many general Unix reference books. + +If your system does not include a POSIX regular expression library, and +you have not linked Guile with a third-party regexp library such as Rx, +these functions will not be available. You can tell whether your Guile +installation includes regular expression support by checking whether the +@code{*features*} list includes the @code{regex} symbol. + +@menu +* Regexp Functions:: Functions that create and match regexps. +* Match Structures:: Finding what was matched by a regexp. +* Backslash Escapes:: Removing the special meaning of regexp metacharacters. +* Rx Interface:: Tom Lord's Rx library does things differently. +@end menu + +[FIXME: it may be useful to include an Examples section. Parts of this +interface are bewildering on first glance.] + +@node Regexp Functions +@subsection Regexp Functions + +By default, Guile supports POSIX extended regular expressions. +That means that the characters @samp{(}, @samp{)}, @samp{+} and +@samp{?} are special, and must be escaped if you wish to match the +literal characters. + +This regular expression interface was modeled after that +implemented by SCSH, the Scheme Shell. It is intended to be +upwardly compatible with SCSH regular expressions. + +@c begin (scm-doc-string "regex.scm" "string-match") +@deffn procedure string-match pattern str [start] +Compile the string @var{pattern} into a regular expression and compare +it with @var{str}. The optional numeric argument @var{start} specifies +the position of @var{str} at which to begin matching. + +@code{string-match} returns a @dfn{match structure} which +describes what, if anything, was matched by the regular +expression. @xref{Match Structures}. If @var{str} does not match +@var{pattern} at all, @code{string-match} returns @code{#f}. +@end deffn + +Each time @code{string-match} is called, it must compile its +@var{pattern} argument into a regular expression structure. This +operation is expensive, which makes @code{string-match} inefficient if +the same regular expression is used several times (for example, in a +loop). For better performance, you can compile a regular expression in +advance and then match strings against the compiled regexp. + +@c ARGFIXME pat/str flags/flag +@c docstring begin (texi-doc-string "guile" "make-regexp") +@deffn primitive make-regexp pat . flags +Compile the regular expression described by @var{str}, and return the +compiled regexp structure. If @var{str} does not describe a legal +regular expression, @code{make-regexp} throws a +@code{regular-expression-syntax} error. + +The @var{flag} arguments change the behavior of the compiled regexp. +The following flags may be supplied: + +@table @code +@item regexp/icase +Consider uppercase and lowercase letters to be the same when matching. + +@item regexp/newline +If a newline appears in the target string, then permit the @samp{^} and +@samp{$} operators to match immediately after or immediately before the +newline, respectively. Also, the @samp{.} and @samp{[^...]} operators +will never match a newline character. The intent of this flag is to +treat the target string as a buffer containing many lines of text, and +the regular expression as a pattern that may match a single one of those +lines. + +@item regexp/basic +Compile a basic (``obsolete'') regexp instead of the extended +(``modern'') regexps that are the default. Basic regexps do not +consider @samp{|}, @samp{+} or @samp{?} to be special characters, and +require the @samp{@{...@}} and @samp{(...)} metacharacters to be +backslash-escaped (@pxref{Backslash Escapes}). There are several other +differences between basic and extended regular expressions, but these +are the most significant. + +@item regexp/extended +Compile an extended regular expression rather than a basic regexp. This +is the default behavior; this flag will not usually be needed. If a +call to @code{make-regexp} includes both @code{regexp/basic} and +@code{regexp/extended} flags, the one which comes last will override +the earlier one. +@end table +@end deffn + +@c ARGFIXME rx/regexp +@c docstring begin (texi-doc-string "guile" "regexp-exec") +@deffn primitive regexp-exec rx str [start [flags]] +Match the compiled regular expression @var{regexp} against @code{str}. +If the optional integer @var{start} argument is provided, begin matching +from that position in the string. Return a match structure describing +the results of the match, or @code{#f} if no match could be found. +@end deffn + +@c ARGFIXME x/obj +@c docstring begin (texi-doc-string "guile" "regexp?") +@deffn primitive regexp? x +Return @code{#t} if @var{obj} is a compiled regular expression, or +@code{#f} otherwise. +@end deffn + +Regular expressions are commonly used to find patterns in one string and +replace them with the contents of another string. + +@c begin (scm-doc-string "regex.scm" "regexp-substitute") +@deffn procedure regexp-substitute port match [item@dots{}] +Write to the output port @var{port} selected contents of the match +structure @var{match}. Each @var{item} specifies what should be +written, and may be one of the following arguments: + +@itemize @bullet +@item +A string. String arguments are written out verbatim. + +@item +An integer. The submatch with that number is written. + +@item +The symbol @samp{pre}. The portion of the matched string preceding +the regexp match is written. + +@item +The symbol @samp{post}. The portion of the matched string following +the regexp match is written. +@end itemize + +@var{port} may be @code{#f}, in which case nothing is written; instead, +@code{regexp-substitute} constructs a string from the specified +@var{item}s and returns that. +@end deffn + +@c begin (scm-doc-string "regex.scm" "regexp-substitute") +@deffn procedure regexp-substitute/global port regexp target [item@dots{}] +Similar to @code{regexp-substitute}, but can be used to perform global +substitutions on @var{str}. Instead of taking a match structure as an +argument, @code{regexp-substitute/global} takes two string arguments: a +@var{regexp} string describing a regular expression, and a @var{target} +string which should be matched against this regular expression. + +Each @var{item} behaves as in @var{regexp-substitute}, with the +following exceptions: + +@itemize @bullet +@item +A function may be supplied. When this function is called, it will be +passed one argument: a match structure for a given regular expression +match. It should return a string to be written out to @var{port}. + +@item +The @samp{post} symbol causes @code{regexp-substitute/global} to recurse +on the unmatched portion of @var{str}. This @emph{must} be supplied in +order to perform global search-and-replace on @var{str}; if it is not +present among the @var{item}s, then @code{regexp-substitute/global} will +return after processing a single match. +@end itemize +@end deffn + +@node Match Structures +@subsection Match Structures + +@cindex match structures + +A @dfn{match structure} is the object returned by @code{string-match} and +@code{regexp-exec}. It describes which portion of a string, if any, +matched the given regular expression. Match structures include: a +reference to the string that was checked for matches; the starting and +ending positions of the regexp match; and, if the regexp included any +parenthesized subexpressions, the starting and ending positions of each +submatch. + +In each of the regexp match functions described below, the @code{match} +argument must be a match structure returned by a previous call to +@code{string-match} or @code{regexp-exec}. Most of these functions +return some information about the original target string that was +matched against a regular expression; we will call that string +@var{target} for easy reference. + +@c begin (scm-doc-string "regex.scm" "regexp-match?") +@deffn procedure regexp-match? obj +Return @code{#t} if @var{obj} is a match structure returned by a +previous call to @code{regexp-exec}, or @code{#f} otherwise. +@end deffn + +@c begin (scm-doc-string "regex.scm" "match:substring") +@deffn procedure match:substring match [n] +Return the portion of @var{target} matched by subexpression number +@var{n}. Submatch 0 (the default) represents the entire regexp match. +If the regular expression as a whole matched, but the subexpression +number @var{n} did not match, return @code{#f}. +@end deffn + +@c begin (scm-doc-string "regex.scm" "match:start") +@deffn procedure match:start match [n] +Return the starting position of submatch number @var{n}. +@end deffn + +@c begin (scm-doc-string "regex.scm" "match:end") +@deffn procedure match:end match [n] +Return the ending position of submatch number @var{n}. +@end deffn + +@c begin (scm-doc-string "regex.scm" "match:prefix") +@deffn procedure match:prefix match +Return the unmatched portion of @var{target} preceding the regexp match. +@end deffn + +@c begin (scm-doc-string "regex.scm" "match:suffix") +@deffn procedure match:suffix match +Return the unmatched portion of @var{target} following the regexp match. +@end deffn + +@c begin (scm-doc-string "regex.scm" "match:count") +@deffn procedure match:count match +Return the number of parenthesized subexpressions from @var{match}. +Note that the entire regular expression match itself counts as a +subexpression, and failed submatches are included in the count. +@end deffn + +@c begin (scm-doc-string "regex.scm" "match:string") +@deffn procedure match:string match +Return the original @var{target} string. +@end deffn + +@node Backslash Escapes +@subsection Backslash Escapes + +Sometimes you will want a regexp to match characters like @samp{*} or +@samp{$} exactly. For example, to check whether a particular string +represents a menu entry from an Info node, it would be useful to match +it against a regexp like @samp{^* [^:]*::}. However, this won't work; +because the asterisk is a metacharacter, it won't match the @samp{*} at +the beginning of the string. In this case, we want to make the first +asterisk un-magic. + +You can do this by preceding the metacharacter with a backslash +character @samp{\}. (This is also called @dfn{quoting} the +metacharacter, and is known as a @dfn{backslash escape}.) When Guile +sees a backslash in a regular expression, it considers the following +glyph to be an ordinary character, no matter what special meaning it +would ordinarily have. Therefore, we can make the above example work by +changing the regexp to @samp{^\* [^:]*::}. The @samp{\*} sequence tells +the regular expression engine to match only a single asterisk in the +target string. + +Since the backslash is itself a metacharacter, you may force a regexp to +match a backslash in the target string by preceding the backslash with +itself. For example, to find variable references in a @TeX{} program, +you might want to find occurrences of the string @samp{\let\} followed +by any number of alphabetic characters. The regular expression +@samp{\\let\\[A-Za-z]*} would do this: the double backslashes in the +regexp each match a single backslash in the target string. + +@c begin (scm-doc-string "regex.scm" "regexp-quote") +@deffn procedure regexp-quote str +Quote each special character found in @var{str} with a backslash, and +return the resulting string. +@end deffn + +@strong{Very important:} Using backslash escapes in Guile source code +(as in Emacs Lisp or C) can be tricky, because the backslash character +has special meaning for the Guile reader. For example, if Guile +encounters the character sequence @samp{\n} in the middle of a string +while processing Scheme code, it replaces those characters with a +newline character. Similarly, the character sequence @samp{\t} is +replaced by a horizontal tab. Several of these @dfn{escape sequences} +are processed by the Guile reader before your code is executed. +Unrecognized escape sequences are ignored: if the characters @samp{\*} +appear in a string, they will be translated to the single character +@samp{*}. + +This translation is obviously undesirable for regular expressions, since +we want to be able to include backslashes in a string in order to +escape regexp metacharacters. Therefore, to make sure that a backslash +is preserved in a string in your Guile program, you must use @emph{two} +consecutive backslashes: + +@lisp +(define Info-menu-entry-pattern (make-regexp "^\\* [^:]*")) +@end lisp + +The string in this example is preprocessed by the Guile reader before +any code is executed. The resulting argument to @code{make-regexp} is +the string @samp{^\* [^:]*}, which is what we really want. + +This also means that in order to write a regular expression that matches +a single backslash character, the regular expression string in the +source code must include @emph{four} backslashes. Each consecutive pair +of backslashes gets translated by the Guile reader to a single +backslash, and the resulting double-backslash is interpreted by the +regexp engine as matching a single backslash character. Hence: + +@lisp +(define tex-variable-pattern (make-regexp "\\\\let\\\\=[A-Za-z]*")) +@end lisp + +The reason for the unwieldiness of this syntax is historical. Both +regular expression pattern matchers and Unix string processing systems +have traditionally used backslashes with the special meanings +described above. The POSIX regular expression specification and ANSI C +standard both require these semantics. Attempting to abandon either +convention would cause other kinds of compatibility problems, possibly +more severe ones. Therefore, without extending the Scheme reader to +support strings with different quoting conventions (an ungainly and +confusing extension when implemented in other languages), we must adhere +to this cumbersome escape syntax. + +@node Rx Interface +@subsection Rx Interface + +[FIXME: this is taken from Gary and Mark's quick summaries and should be +reviewed and expanded. Rx is pretty stable, so could already be done!] + +@cindex rx +@cindex finite automaton + +Guile includes an interface to Tom Lord's Rx library (currently only to +POSIX regular expressions). Use of the library requires a two step +process: compile a regular expression into an efficient structure, then +use the structure in any number of string comparisons. + +For example, given the +regular expression @samp{abc.} (which matches any string containing +@samp{abc} followed by any single character): + +@smalllisp +guile> @kbd{(define r (regcomp "abc."))} +guile> @kbd{r} +# +guile> @kbd{(regexec r "abc")} +#f +guile> @kbd{(regexec r "abcd")} +#((0 . 4)) +guile> +@end smalllisp + +The definitions of @code{regcomp} and @code{regexec} are as follows: + +@c NJFIXME not in libguile! +@deffn primitive regcomp pattern [flags] +Compile the regular expression pattern using POSIX rules. Flags is +optional and should be specified using symbolic names: +@defvar REG_EXTENDED +use extended POSIX syntax +@end defvar +@defvar REG_ICASE +use case-insensitive matching +@end defvar +@defvar REG_NEWLINE +allow anchors to match after newline characters in the +string and prevents @code{.} or @code{[^...]} from matching newlines. +@end defvar + +The @code{logior} procedure can be used to combine multiple flags. +The default is to use +POSIX basic syntax, which makes @code{+} and @code{?} literals and @code{\+} +and @code{\?} +operators. Backslashes in @var{pattern} must be escaped if specified in a +literal string e.g., @code{"\\(a\\)\\?"}. +@end deffn + +@c NJFIXME not in libguile! +@deffn primitive regexec regex string [match-pick] [flags] + +Match @var{string} against the compiled POSIX regular expression +@var{regex}. +@var{match-pick} and @var{flags} are optional. Possible flags (which can be +combined using the logior procedure) are: + +@defvar REG_NOTBOL +The beginning of line operator won't match the beginning of +@var{string} (presumably because it's not the beginning of a line) +@end defvar + +@defvar REG_NOTEOL +Similar to REG_NOTBOL, but prevents the end of line operator +from matching the end of @var{string}. +@end defvar + +If no match is possible, regexec returns #f. Otherwise @var{match-pick} +determines the return value: + +@code{#t} or unspecified: a newly-allocated vector is returned, +containing pairs with the indices of the matched part of @var{string} and any +substrings. + +@code{""}: a list is returned: the first element contains a nested list +with the matched part of @var{string} surrounded by the the unmatched parts. +Remaining elements are matched substrings (if any). All returned +substrings share memory with @var{string}. + +@code{#f}: regexec returns #t if a match is made, otherwise #f. + +vector: the supplied vector is returned, with the first element replaced +by a pair containing the indices of the matched portion of @var{string} and +further elements replaced by pairs containing the indices of matched +substrings (if any). + +list: a list will be returned, with each member of the list +specified by a code in the corresponding position of the supplied list: + +a number: the numbered matching substring (0 for the entire match). + +@code{#\<}: the beginning of @var{string} to the beginning of the part matched +by regex. + +@code{#\>}: the end of the matched part of @var{string} to the end of +@var{string}. + +@code{#\c}: the "final tag", which seems to be associated with the "cut +operator", which doesn't seem to be available through the posix +interface. + +e.g., @code{(list #\< 0 1 #\>)}. The returned substrings share memory with +@var{string}. +@end deffn + +Here are some other procedures that might be used when using regular +expressions: + +@c NJFIXME not in libguile! +@deffn primitive compiled-regexp? obj +Test whether obj is a compiled regular expression. +@end deffn + +@c NJFIXME not in libguile! +@deffn primitive regexp->dfa regex [flags] +@end deffn + +@c NJFIXME not in libguile! +@deffn primitive dfa-fork dfa +@end deffn + +@c NJFIXME not in libguile! +@deffn primitive reset-dfa! dfa +@end deffn + +@c NJFIXME not in libguile! +@deffn primitive dfa-final-tag dfa +@end deffn + +@c NJFIXME not in libguile! +@deffn primitive dfa-continuable? dfa +@end deffn + +@c NJFIXME not in libguile! +@deffn primitive advance-dfa! dfa string +@end deffn + + +@node Symbols and Variables +@section Symbols and Variables + +Guile symbol tables are hash tables. Each hash table, also called an +@dfn{obarray} (for `object array'), is a vector of association lists. +Each entry in the alists is a pair (@var{SYMBOL} . @var{VALUE}). To +@dfn{intern} a symbol in a symbol table means to return its +(@var{SYMBOL} . @var{VALUE}) pair, adding a new entry to the symbol +table (with an undefined value) if none is yet present. + +@c docstring begin (texi-doc-string "guile" "builtin-bindings") +@deffn primitive builtin-bindings +Create and return a copy of the global symbol table, removing all +unbound symbols. +@end deffn + +@c docstring begin (texi-doc-string "guile" "gensym") +@deffn primitive 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 @code{g}. The counter +is increased by 1 at each call. There is no provision for +resetting the counter. +@end deffn + +@c docstring begin (texi-doc-string "guile" "gentemp") +@deffn primitive gentemp [prefix [obarray]] +Create a new symbol with a name unique in an obarray. +The name is constructed from an optional string @var{prefix} +and a counter value. The default prefix is @code{t}. The +@var{obarray} is specified as a second optional argument. +Default is the system obarray where all normal symbols are +interned. The counter is increased by 1 at each +call. There is no provision for resetting the counter. +@end deffn + +@c docstring begin (texi-doc-string "guile" "intern-symbol") +@deffn primitive intern-symbol obarray string +Add a new symbol to @var{obarray} with name @var{string}, bound to an +unspecified initial value. The symbol table is not modified if a symbol +with this name is already present. +@end deffn + +@c docstring begin (texi-doc-string "guile" "string->obarray-symbol") +@deffn primitive string->obarray-symbol obarray string [soft?] +Intern a new symbol in @var{obarray}, a symbol table, with name +@var{string}. + +If @var{obarray} is @code{#f}, use the default system symbol table. If +@var{obarray} is @code{#t}, the symbol should not be interned in any +symbol table; merely return the pair (@var{symbol} +. @var{#}). + +The @var{soft?} argument determines whether new symbol table entries +should be created when the specified symbol is not already present in +@var{obarray}. If @var{soft?} is specified and is a true value, then +new entries should not be added for symbols not already present in the +table; instead, simply return @code{#f}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "string->symbol") +@deffn primitive string->symbol string +Returns the symbol whose name is @var{string}. This procedure can +create symbols with names containing special characters or letters in +the non-standard case, but it is usually a bad idea to create such +symbols because in some implementations of Scheme they cannot be read as +themselves. See @samp{symbol->string}. + +The following examples assume that the implementation's standard case is +lower case: + +@format +@t{(eq? 'mISSISSIppi 'mississippi) + ==> #t +(string->symbol "mISSISSIppi") + ==> + @r{}the symbol with name "mISSISSIppi" +(eq? 'bitBlt (string->symbol "bitBlt")) + ==> #f +(eq? 'JollyWog + (string->symbol + (symbol->string 'JollyWog))) + ==> #t +(string=? "K. Harper, M.D." + (symbol->string + (string->symbol "K. Harper, M.D."))) + ==> #t +} +@end format +@end deffn + +@c docstring begin (texi-doc-string "guile" "symbol->string") +@deffn primitive symbol->string symbol +Returns the name of @var{symbol} as a string. If the symbol was part of +an object returned as the value of a literal expression (section +@pxref{Literal expressions,,,r4rs, The Revised^4 Report on Scheme}) or +by a call to the @samp{read} procedure, and its name contains alphabetic +characters, then the string returned will contain characters in the +implementation's preferred standard case---some implementations will +prefer upper case, others lower case. If the symbol was returned by +@samp{string->symbol}, the case of characters in the string returned +will be the same as the case in the string that was passed to +@samp{string->symbol}. It is an error to apply mutation procedures like +@code{string-set!} to strings returned by this procedure. (r5rs) + +The following examples assume that the implementation's standard case is +lower case: + +@format +@t{(symbol->string 'flying-fish) + ==> "flying-fish" +(symbol->string 'Martin) ==> "martin" +(symbol->string + (string->symbol "Malvina")) + ==> "Malvina" +} +@end format +@end deffn + +@c docstring begin (texi-doc-string "guile" "symbol-binding") +@deffn primitive symbol-binding obarray string +Look up in @var{obarray} the symbol whose name is @var{string}, and +return the value to which it is bound. If @var{obarray} is @code{#f}, +use the global symbol table. If @var{string} is not interned in +@var{obarray}, an error is signalled. +@end deffn + +@c docstring begin (texi-doc-string "guile" "symbol-bound?") +@deffn primitive symbol-bound? obarray string +Return @var{#t} if @var{obarray} contains a symbol with name +@var{string} bound to a defined value. This differs from +@var{symbol-interned?} in that the mere mention of a symbol usually causes +it to be interned; @code{symbol-bound?} determines whether a symbol has +been given any meaningful value. +@end deffn + +@c docstring begin (texi-doc-string "guile" "symbol-fref") +@deffn primitive symbol-fref symbol +Return the contents of @var{symbol}'s @dfn{function slot}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "symbol-fset!") +@deffn primitive symbol-fset! symbol value +Change the binding of @var{symbol}'s function slot. +@end deffn + +@c docstring begin (texi-doc-string "guile" "symbol-hash") +@deffn primitive symbol-hash symbol +Return a hash value for @var{symbol}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "symbol-interned?") +@deffn primitive symbol-interned? obarray string +Return @var{#t} if @var{obarray} contains a symbol with name +@var{string}, and @var{#f} otherwise. +@end deffn + +@c docstring begin (texi-doc-string "guile" "symbol-pref") +@deffn primitive symbol-pref symbol +Return the @dfn{property list} currently associated with @var{symbol}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "symbol-pset!") +@deffn primitive symbol-pset! symbol value +Change the binding of @var{symbol}'s property slot. +@end deffn + +@c docstring begin (texi-doc-string "guile" "symbol-set!") +@deffn primitive symbol-set! obarray string value +Find the symbol in @var{obarray} whose name is @var{string}, and rebind +it to @var{value}. An error is signalled if @var{string} is not present +in @var{obarray}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "symbol?") +@deffn primitive symbol? obj +Returns @t{#t} if @var{obj} is a symbol, otherwise returns @t{#f}. (r5rs) +@end deffn + +@c docstring begin (texi-doc-string "guile" "unintern-symbol") +@deffn primitive unintern-symbol obarray string +Remove the symbol with name @var{string} from @var{obarray}. This +function returns @code{#t} if the symbol was present and @code{#f} +otherwise. +@end deffn + +@c docstring begin (texi-doc-string "guile" "builtin-variable") +@deffn primitive builtin-variable name +Return the built-in variable with the name @var{name}. +@var{name} must be a symbol (not a string). +Then use @code{variable-ref} to access its value. +@end deffn + +@c docstring begin (texi-doc-string "guile" "make-undefined-variable") +@deffn primitive make-undefined-variable [name-hint] +Return a variable object initialized to an undefined value. +If given, uses @var{name-hint} as its internal (debugging) +name, otherwise just treat it as an anonymous variable. +Remember, of course, that multiple bindings to the same +variable may exist, so @var{name-hint} is just that---a hint. +@end deffn + +@c docstring begin (texi-doc-string "guile" "make-variable") +@deffn primitive make-variable init [name-hint] +Return a variable object initialized to value @var{init}. +If given, uses @var{name-hint} as its internal (debugging) +name, otherwise just treat it as an anonymous variable. +Remember, of course, that multiple bindings to the same +variable may exist, so @var{name-hint} is just that---a hint. +@end deffn + +@c docstring begin (texi-doc-string "guile" "variable-bound?") +@deffn primitive variable-bound? var +Return @code{#t} iff @var{var} is bound to a value. +Throws an error if @var{var} is not a variable object. +@end deffn + +@c docstring begin (texi-doc-string "guile" "variable-ref") +@deffn primitive variable-ref var +Dereference @var{var} and return its value. +@var{var} must be a variable object; see @code{make-variable} +and @code{make-undefined-variable}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "variable-set!") +@deffn primitive variable-set! var val +Set the value of the variable @var{var} to @var{val}. +@var{var} must be a variable object, @var{val} can be any +value. Return an unspecified value. +@end deffn + +@c docstring begin (texi-doc-string "guile" "variable?") +@deffn primitive variable? obj +Return @code{#t} iff @var{obj} is a variable object, else +return @code{#f} +@end deffn + + +@node Keywords +@section Keywords + +Keywords are self-evaluating objects with a convenient read syntax that +makes them easy to type. + +Guile's keyword support conforms to R4RS, and adds a (switchable) read +syntax extension to permit keywords to begin with @code{:} as well as +@code{#:}. + +@menu +* Why Use Keywords?:: +* Coding With Keywords:: +* Keyword Read Syntax:: +* Keyword Primitives:: +@end menu + +@node Why Use Keywords? +@subsection Why Use Keywords? + +Keywords are useful in contexts where a program or procedure wants to be +able to accept a large number of optional arguments without making its +interface unmanageable. + +To illustrate this, consider a hypothetical @code{make-window} +procedure, which creates a new window on the screen for drawing into +using some graphical toolkit. There are many parameters that the caller +might like to specify, but which could also be sensibly defaulted, for +example: + +@itemize @bullet +@item +colour depth -- Default: the colour depth for the screen + +@item +background colour -- Default: white + +@item +width -- Default: 600 + +@item +height -- Default: 400 +@end itemize + +If @code{make-window} did not use keywords, the caller would have to +pass in a value for each possible argument, remembering the correct +argument order and using a special value to indicate the default value +for that argument: + +@lisp +(make-window 'default ;; Colour depth + 'default ;; Background colour + 800 ;; Width + 100 ;; Height + @dots{}) ;; More make-window arguments +@end lisp + +With keywords, on the other hand, defaulted arguments are omitted, and +non-default arguments are clearly tagged by the appropriate keyword. As +a result, the invocation becomes much clearer: + +@lisp +(make-window #:width 800 #:height 100) +@end lisp + +On the other hand, for a simpler procedure with few arguments, the use +of keywords would be a hindrance rather than a help. The primitive +procedure @code{cons}, for example, would not be improved if it had to +be invoked as + +@lisp +(cons #:car x #:cdr y) +@end lisp + +So the decision whether to use keywords or not is purely pragmatic: use +them if they will clarify the procedure invocation at point of call. + +@node Coding With Keywords +@subsection Coding With Keywords + +If a procedure wants to support keywords, it should take a rest argument +and then use whatever means is convenient to extract keywords and their +corresponding arguments from the contents of that rest argument. + +The following example illustrates the principle: the code for +@code{make-window} uses a helper procedure called +@code{get-keyword-value} to extract individual keyword arguments from +the rest argument. + +@lisp +(define (get-keyword-value args keyword default) + (let ((kv (memq keyword args))) + (if (and kv (>= (length kv) 2)) + (cadr kv) + default))) + +(define (make-window . args) + (let ((depth (get-keyword-value args #:depth screen-depth)) + (bg (get-keyword-value args #:bg "white")) + (width (get-keyword-value args #:width 800)) + (height (get-keyword-value args #:height 100)) + @dots{}) + @dots{})) +@end lisp + +But you don't need to write @code{get-keyword-value}. The @code{(ice-9 +optargs)} module provides a set of powerful macros that you can use to +implement keyword-supporting procedures like this: + +@lisp +(use-modules (ice-9 optargs)) + +(define (make-window . args) + (let-keywords args #f ((depth screen-depth) + (bg "white") + (width 800) + (height 100)) + ...)) +@end lisp + +@noindent +Or, even more economically, like this: + +@lisp +(use-modules (ice-9 optargs)) + +(define* (make-window #:key (depth screen-depth) + (bg "white") + (width 800) + (height 100)) + ...) +@end lisp + +For further details on @code{let-keywords}, @code{define*} and other +facilities provided by the @code{(ice-9 optargs)} module, @ref{Optional +Arguments}. + + +@node Keyword Read Syntax +@subsection Keyword Read Syntax + +Guile, by default, only recognizes the keyword syntax specified by R5RS. +A token of the form @code{#:NAME}, where @code{NAME} has the same syntax +as a Scheme symbol, is the external representation of the keyword named +@code{NAME}. Keyword objects print using this syntax as well, so values +containing keyword objects can be read back into Guile. When used in an +expression, keywords are self-quoting objects. + +If the @code{keyword} read option is set to @code{'prefix}, Guile also +recognizes the alternative read syntax @code{:NAME}. Otherwise, tokens +of the form @code{:NAME} are read as symbols, as required by R4RS. + +To enable and disable the alternative non-R4RS keyword syntax, you use +the @code{read-options} procedure documented in @ref{General option +interface} and @ref{Reader options}. + +@smalllisp +(read-set! keywords 'prefix) + +#:type +@result{} +#:type + +:type +@result{} +#:type + +(read-set! keywords #f) + +#:type +@result{} +#:type + +:type +@result{} +ERROR: In expression :type: +ERROR: Unbound variable: :type +ABORT: (unbound-variable) +@end smalllisp + +@node Keyword Primitives +@subsection Keyword Primitives + +Internally, a keyword is implemented as something like a tagged symbol, +where the tag identifies the keyword as being self-evaluating, and the +symbol, known as the keyword's @dfn{dash symbol} has the same name as +the keyword name but prefixed by a single dash. For example, the +keyword @code{#:name} has the corresponding dash symbol @code{-name}. + +Most keyword objects are constructed automatically by the reader when it +reads a token beginning with @code{#:}. However, if you need to +construct a keyword object programmatically, you can do so by calling +@code{make-keyword-from-dash-symbol} with the corresponding dash symbol +(as the reader does). The dash symbol for a keyword object can be +retrieved using the @code{keyword-dash-symbol} procedure. + +@c docstring begin (texi-doc-string "guile" "make-keyword-from-dash-symbol") +@deffn primitive make-keyword-from-dash-symbol symbol +Make a keyword object from a @var{symbol} that starts with a dash. +@end deffn + +@c docstring begin (texi-doc-string "guile" "keyword?") +@deffn primitive keyword? obj +Returns @code{#t} if the argument @var{obj} is a keyword, else @code{#f}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "keyword-dash-symbol") +@deffn primitive keyword-dash-symbol keyword +Return the dash symbol for @var{keyword}. +This is the inverse of @code{make-keyword-from-dash-symbol}. +@end deffn + + +@node Pairs +@section Pairs + +@c docstring begin (texi-doc-string "guile" "cons") +@deffn primitive cons x y +Returns a newly allocated pair whose car is @var{x} and whose cdr is +@var{y}. The pair is guaranteed to be different (in the sense of +@code{eqv?}) from every previously existing object. +@end deffn + +@c docstring begin (texi-doc-string "guile" "pair?") +@deffn primitive pair? x +Returns @code{#t} if @var{x} is a pair; otherwise returns @code{#f}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "set-car!") +@deffn primitive set-car! pair value +Stores @var{value} in the car field of @var{pair}. The value returned +by @code{set-car!} is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "set-cdr!") +@deffn primitive set-cdr! pair value +Stores @var{value} in the cdr field of @var{pair}. The value returned +by @code{set-cdr!} is unspecified. +@end deffn + + +@node Lists +@section Lists + +@c docstring begin (texi-doc-string "guile" "list") +@deffn primitive list . objs +Return a list containing OBJS, the arguments to `list'. +@end deffn + +@c docstring begin (texi-doc-string "guile" "cons*") +@deffn primitive cons* arg . rest +@deffnx primitive list* arg . rest +Like `list', but the last arg provides the tail of the constructed list, +returning (cons ARG1 (cons ARG2 (cons ... ARGn))). +Requires at least one argument. If given one argument, that argument +is returned as result. +This function is called `list*' in some other Schemes and in Common LISP. +@end deffn + +@c docstring begin (texi-doc-string "guile" "list?") +@deffn primitive list? x +Return #t iff X is a proper list, else #f. +@end deffn + +@c docstring begin (texi-doc-string "guile" "null?") +@deffn primitive null? x +Return #t iff X is the empty list, else #f. +@end deffn + +@c docstring begin (texi-doc-string "guile" "length") +@deffn primitive length lst +Return the number of elements in list LST. +@end deffn + +@c docstring begin (texi-doc-string "guile" "append") +@deffn primitive append . args +Returns a list consisting of the elements of the first LIST +followed by the elements of the other LISTs. + +@example + (append '(x) '(y)) => (x y) + (append '(a) '(b c d)) => (a b c d) + (append '(a (b)) '((c))) => (a (b) (c)) +@end example + +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. + +@example + (append '(a b) '(c . d)) => (a b c . d) + (append '() 'a) => a +@end example +@end deffn + +@c ARGFIXME args ? +@c docstring begin (texi-doc-string "guile" "append!") +@deffn primitive append! . args +A destructive version of @code{append} (@pxref{Pairs and Lists,,,r4rs, +The Revised^4 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. +@end deffn + +@c docstring begin (texi-doc-string "guile" "last-pair") +@deffn primitive last-pair lst +Return a pointer to the last pair in @var{lst}, signalling an error if +@var{lst} is circular. +@end deffn + +@c docstring begin (texi-doc-string "guile" "reverse") +@deffn primitive reverse lst +Return a new list that contains the elements of LST but in reverse order. +@end deffn + +@c NJFIXME explain new_tail +@c docstring begin (texi-doc-string "guile" "reverse!") +@deffn primitive reverse! lst [new_tail] +A destructive version of @code{reverse} (@pxref{Pairs and Lists,,,r4rs, +The Revised^4 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. + +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!} +@end deffn + +@c docstring begin (texi-doc-string "guile" "list-ref") +@deffn primitive list-ref list k +Return the Kth element from LIST. +@end deffn + +@c docstring begin (texi-doc-string "guile" "list-set!") +@deffn primitive list-set! list k val +Set the @var{k}th element of @var{list} to @var{val}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "list-tail") +@c docstring begin (texi-doc-string "guile" "list-cdr-ref") +@deffn primitive list-tail lst k +@deffnx primitive list-cdr-ref lst k +Return the "tail" of @var{lst} beginning with its @var{k}th element. +The first element of the list is considered to be element 0. + +@code{list-tail} and @code{list-cdr-ref} are identical. It may help to +think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list, +or returning the results of cdring @var{k} times down @var{lst}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "list-cdr-set!") +@deffn primitive list-cdr-set! list k val +Set the @var{k}th cdr of @var{list} to @var{val}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "list-head") +@deffn primitive list-head lst k +Copy the first @var{k} elements from @var{lst} into a new list, and +return it. +@end deffn + +@c docstring begin (texi-doc-string "guile" "list-copy") +@deffn primitive list-copy lst +Return a (newly-created) copy of @var{lst}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "memq") +@deffn primitive memq x lst +Return the first sublist of LST whose car is `eq?' to X +where the sublists of LST are the non-empty lists returned +by `(list-tail LST K)' for K less than the length of LST. If +X does not occur in LST, then `#f' (not the empty list) is +returned. +@end deffn + +@c docstring begin (texi-doc-string "guile" "memv") +@deffn primitive memv x lst +Return the first sublist of LST whose car is `eqv?' to X +where the sublists of LST are the non-empty lists returned +by `(list-tail LST K)' for K less than the length of LST. If +X does not occur in LST, then `#f' (not the empty list) is +returned. +@end deffn + +@c docstring begin (texi-doc-string "guile" "member") +@deffn primitive member x lst +Return the first sublist of LST whose car is `equal?' to X +where the sublists of LST are the non-empty lists returned +by `(list-tail LST K)' for K less than the length of LST. If +X does not occur in LST, then `#f' (not the empty list) is +returned. +@end deffn + +@c docstring begin (texi-doc-string "guile" "delq") +@deffn primitive delq item lst +Return a newly-created copy of @var{lst} with elements `eq?' to @var{item} removed. +This procedure mirrors @code{memq}: +@code{delq} compares elements of @var{lst} against @var{item} with +@code{eq?}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "delv") +@deffn primitive delv item lst +Return a newly-created copy of @var{lst} with elements `eqv?' to @var{item} removed. +This procedure mirrors @code{memv}: +@code{delv} compares elements of @var{lst} against @var{item} with +@code{eqv?}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "delete") +@deffn primitive delete item lst +Return a newly-created copy of @var{lst} with elements `equal?' to @var{item} removed. +This procedure mirrors @code{member}: +@code{delete} compares elements of @var{lst} against @var{item} with +@code{equal?}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "delq!") +@c docstring begin (texi-doc-string "guile" "delv!") +@c docstring begin (texi-doc-string "guile" "delete!") +@deffn primitive delq! item lst +@deffnx primitive delv! item lst +@deffnx primitive delete! item lst +These procedures are destructive versions of @code{delq}, @code{delv} +and @code{delete}: they modify the pointers in the existing @var{lst} +rather than creating a new list. Caveat evaluator: Like other +destructive list functions, these functions cannot modify the binding of +@var{lst}, and so cannot be used to delete the first element of +@var{lst} destructively. +@end deffn + +@c docstring begin (texi-doc-string "guile" "delq1!") +@deffn primitive delq1! item lst +Like `delq!', but only deletes the first occurrence of ITEM from LST. +Tests for equality using `eq?'. See also `delv1!' and `delete1!'. +@end deffn + +@c docstring begin (texi-doc-string "guile" "delv1!") +@deffn primitive delv1! item lst +Like `delv!', but only deletes the first occurrence of ITEM from LST. +Tests for equality using `eqv?'. See also `delq1!' and `delete1!'. +@end deffn + +@c docstring begin (texi-doc-string "guile" "delete1!") +@deffn primitive delete1! item lst +Like `delete!', but only deletes the first occurrence of ITEM from LST. +Tests for equality using `equal?'. See also `delq1!' and `delv1!'. +@end deffn + +[FIXME: is there any reason to have the `sloppy' functions available at +high level at all? Maybe these docs should be relegated to a "Guile +Internals" node or something. -twp] + +@c docstring begin (texi-doc-string "guile" "sloppy-memq") +@deffn primitive sloppy-memq x lst +This procedure behaves like @code{memq}, but does no type or error checking. +Its use is recommended only in writing Guile internals, +not for high-level Scheme programs. +@end deffn + +@c docstring begin (texi-doc-string "guile" "sloppy-memv") +@deffn primitive sloppy-memv x lst +This procedure behaves like @code{memv}, but does no type or error checking. +Its use is recommended only in writing Guile internals, +not for high-level Scheme programs. +@end deffn + +@c docstring begin (texi-doc-string "guile" "sloppy-member") +@deffn primitive sloppy-member x lst +This procedure behaves like @code{member}, but does no type or error checking. +Its use is recommended only in writing Guile internals, +not for high-level Scheme programs. +@end deffn + +@c begin (texi-doc-string "guile" "map") +@c docstring begin (texi-doc-string "guile" "map-in-order") +@deffn primitive map proc arg1 . args +@deffnx primitive map-in-order proc arg1 . args +@end deffn + +@c begin (texi-doc-string "guile" "for-each") +@deffn primitive for-each proc arg1 . args +@end deffn + + +@node Records +@section Records + +[FIXME: this is pasted in from Tom Lord's original guile.texi and should +be reviewed] + +A @dfn{record type} is a first class object representing a user-defined +data type. A @dfn{record} is an instance of a record type. + +@deffn procedure record? obj +Returns @code{#t} if @var{obj} is a record of any type and @code{#f} +otherwise. + +Note that @code{record?} may be true of any Scheme value; there is no +promise that records are disjoint with other Scheme types. +@end deffn + +@deffn procedure make-record-type type-name field-names +Returns a @dfn{record-type descriptor}, a value representing a new data +type disjoint from all others. The @var{type-name} argument must be a +string, but is only used for debugging purposes (such as the printed +representation of a record of the new type). The @var{field-names} +argument is a list of symbols naming the @dfn{fields} of a record of the +new type. It is an error if the list contains any duplicates. It is +unspecified how record-type descriptors are represented.@refill +@end deffn + +@deffn procedure record-constructor rtd [field-names] +Returns a procedure for constructing new members of the type represented +by @var{rtd}. The returned procedure accepts exactly as many arguments +as there are symbols in the given list, @var{field-names}; these are +used, in order, as the initial values of those fields in a new record, +which is returned by the constructor procedure. The values of any +fields not named in that list are unspecified. The @var{field-names} +argument defaults to the list of field names in the call to +@code{make-record-type} that created the type represented by @var{rtd}; +if the @var{field-names} argument is provided, it is an error if it +contains any duplicates or any symbols not in the default list.@refill +@end deffn + +@deffn procedure record-predicate rtd +Returns a procedure for testing membership in the type represented by +@var{rtd}. The returned procedure accepts exactly one argument and +returns a true value if the argument is a member of the indicated record +type; it returns a false value otherwise.@refill +@end deffn + +@deffn procedure record-accessor rtd field-name +Returns a procedure for reading the value of a particular field of a +member of the type represented by @var{rtd}. The returned procedure +accepts exactly one argument which must be a record of the appropriate +type; it returns the current value of the field named by the symbol +@var{field-name} in that record. The symbol @var{field-name} must be a +member of the list of field-names in the call to @code{make-record-type} +that created the type represented by @var{rtd}.@refill +@end deffn + +@deffn procedure record-modifier rtd field-name +Returns a procedure for writing the value of a particular field of a +member of the type represented by @var{rtd}. The returned procedure +accepts exactly two arguments: first, a record of the appropriate type, +and second, an arbitrary Scheme value; it modifies the field named by +the symbol @var{field-name} in that record to contain the given value. +The returned value of the modifier procedure is unspecified. The symbol +@var{field-name} must be a member of the list of field-names in the call +to @code{make-record-type} that created the type represented by +@var{rtd}.@refill +@end deffn + +@deffn procedure record-type-descriptor record +Returns a record-type descriptor representing the type of the given +record. That is, for example, if the returned descriptor were passed to +@code{record-predicate}, the resulting predicate would return a true +value when passed the given record. Note that it is not necessarily the +case that the returned descriptor is the one that was passed to +@code{record-constructor} in the call that created the constructor +procedure that created the given record.@refill +@end deffn + +@deffn procedure record-type-name rtd +Returns the type-name associated with the type represented by rtd. The +returned value is @code{eqv?} to the @var{type-name} argument given in +the call to @code{make-record-type} that created the type represented by +@var{rtd}.@refill +@end deffn + +@deffn procedure record-type-fields rtd +Returns a list of the symbols naming the fields in members of the type +represented by @var{rtd}. The returned value is @code{equal?} to the +field-names argument given in the call to @code{make-record-type} that +created the type represented by @var{rtd}.@refill +@end deffn + + +@node Structures +@section Structures + +[FIXME: this is pasted in from Tom Lord's original guile.texi and should +be reviewed] + +A @dfn{structure type} is a first class user-defined data type. A +@dfn{structure} is an instance of a structure type. A structure type is +itself a structure. + +Structures are less abstract and more general than traditional records. +In fact, in Guile Scheme, records are implemented using structures. + +@menu +* Structure Concepts:: The structure of Structures +* Structure Layout:: Defining the layout of structure types +* Structure Basics:: make-, -ref and -set! procedures for structs +* Vtables:: Accessing type-specific data +@end menu + +@node Structure Concepts +@subsection Structure Concepts + +A structure object consists of a handle, structure data, and a vtable. +The handle is a Scheme value which points to both the vtable and the +structure's data. Structure data is a dynamically allocated region of +memory, private to the structure, divided up into typed fields. A +vtable is another structure used to hold type-specific data. Multiple +structures can share a common vtable. + +Three concepts are key to understanding structures. + +@itemize @bullet{} +@item @dfn{layout specifications} + +Layout specifications determine how memory allocated to structures is +divided up into fields. Programmers must write a layout specification +whenever a new type of structure is defined. + +@item @dfn{structural accessors} + +Structure access is by field number. There is only one set of +accessors common to all structure objects. + +@item @dfn{vtables} + +Vtables, themselves structures, are first class representations of +disjoint sub-types of structures in general. In most cases, when a +new structure is created, programmers must specifiy a vtable for the +new structure. Each vtable has a field describing the layout of its +instances. Vtables can have additional, user-defined fields as well. +@end itemize + + + +@node Structure Layout +@subsection Structure Layout + +When a structure is created, a region of memory is allocated to hold its +state. The @dfn{layout} of the structure's type determines how that +memory is divided into fields. + +Each field has a specified type. There are only three types allowed, each +corresponding to a one letter code. The allowed types are: + +@itemize @bullet{} +@item 'u' -- unprotected + +The field holds binary data that is not GC protected. + +@item 'p' -- protected + +The field holds a Scheme value and is GC protected. + +@item 's' -- self + +The field holds a Scheme value and is GC protected. When a structure is +created with this type of field, the field is initialized to refer to +the structure's own handle. This kind of field is mainly useful when +mixing Scheme and C code in which the C code may need to compute a +structure's handle given only the address of its malloced data. +@end itemize + + +Each field also has an associated access protection. There are only +three kinds of protection, each corresponding to a one letter code. +The allowed protections are: + +@itemize @bullet{} +@item 'w' -- writable + +The field can be read and written. + +@item 'r' -- readable + +The field can be read, but not written. + +@item 'o' -- opaque + +The field can be neither read nor written. This kind +of protection is for fields useful only to built-in routines. +@end itemize + +A layout specification is described by stringing together pairs +of letters: one to specify a field type and one to specify a field +protection. For example, a traditional cons pair type object could +be described as: + +@example +; cons pairs have two writable fields of Scheme data +"pwpw" +@end example + +A pair object in which the first field is held constant could be: + +@example +"prpw" +@end example + +Binary fields, (fields of type "u"), hold one @emph{word} each. The +size of a word is a machine dependent value defined to be equal to the +value of the C expression: @code{sizeof (long)}. + +The last field of a structure layout may specify a tail array. +A tail array is indicated by capitalizing the field's protection +code ('W', 'R' or 'O'). A tail-array field is replaced by +a read-only binary data field containing an array size. The array +size is determined at the time the structure is created. It is followed +by a corresponding number of fields of the type specified for the +tail array. For example, a conventional Scheme vector can be +described as: + +@example +; A vector is an arbitrary number of writable fields holding Scheme +; values: +"pW" +@end example + +In the above example, field 0 contains the size of the vector and +fields beginning at 1 contain the vector elements. + +A kind of tagged vector (a constant tag followed by conventioal +vector elements) might be: + +@example +"prpW" +@end example + + +Structure layouts are represented by specially interned symbols whose +name is a string of type and protection codes. To create a new +structure layout, use this procedure: + +@c docstring begin (texi-doc-string "guile" "make-struct-layout") +@deffn primitive make-struct-layout fields +Return a new structure layout object. + +@var{fields} must be a string made up of pairs of characters +strung together. The first character of each pair describes a field +type, the second a field protection. Allowed types are 'p' for +GC-protected Scheme data, 'u' for unprotected binary data, and 's' for +a field that points to the structure itself. Allowed protections +are 'w' for mutable fields, 'r' for read-only fields, and 'o' for opaque +fields. The last field protection specification may be capitalized to +indicate that the field is a tail-array. +@end deffn + + + +@node Structure Basics +@subsection Structure Basics + +This section describes the basic procedures for creating and accessing +structures. + +@c docstring begin (texi-doc-string "guile" "make-struct") +@deffn primitive make-struct vtable tail_array_size . init +Create a new structure. + +@var{type} must be a vtable structure (@pxref{Vtables}). + +@var{tail-elts} must be a non-negative integer. If the layout +specification indicated by @var{type} includes a tail-array, +this is the number of elements allocated to that array. + +The @var{init1}, @dots{} are optional arguments describing how +successive fields of the structure should be initialized. Only fields +with protection 'r' or 'w' can be initialized, except for fields of +type 's', which are automatically initialized to point to the new +structure itself; fields with protection 'o' can not be initialized by +Scheme programs. + +If fewer optional arguments than initializable fields are supplied, +fields of type 'p' get default value #f while fields of type 'u' are +initialized to 0. + +Structs are currently the basic representation for record-like data +structures in Guile. The plan is to eventually replace them with a +new representation which will at the same time be easier to use and +more powerful. + +For more information, see the documentation for @code{make-vtable-vtable}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "struct?") +@deffn primitive struct? x +Return #t iff @var{obj} is a structure object, else #f. +@end deffn + + +@c docstring begin (texi-doc-string "guile" "struct-ref") +@c docstring begin (texi-doc-string "guile" "struct-set!") +@deffn primitive struct-ref handle pos +@deffnx primitive struct-set! struct n value +Access (or modify) the @var{n}th field of @var{struct}. + +If the field is of type 'p', then it can be set to an arbitrary value. + +If the field is of type 'u', then it can only be set to a non-negative +integer value small enough to fit in one machine word. +@end deffn + + + +@node Vtables +@subsection Vtables + +Vtables are structures that are used to represent structure types. Each +vtable contains a layout specification in field +@code{vtable-index-layout} -- instances of the type are laid out +according to that specification. Vtables contain additional fields +which are used only internally to libguile. The variable +@code{vtable-offset-user} is bound to a field number. Vtable fields +at that position or greater are user definable. + +@c docstring begin (texi-doc-string "guile" "struct-vtable") +@deffn primitive struct-vtable handle +Return the vtable structure that describes the type of @var{struct}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "struct-vtable?") +@deffn primitive struct-vtable? x +Return #t iff obj is a vtable structure. +@end deffn + +If you have a vtable structure, @code{V}, you can create an instance of +the type it describes by using @code{(make-struct V ...)}. But where +does @code{V} itself come from? One possibility is that @code{V} is an +instance of a user-defined vtable type, @code{V'}, so that @code{V} is +created by using @code{(make-struct V' ...)}. Another possibility is +that @code{V} is an instance of the type it itself describes. Vtable +structures of the second sort are created by this procedure: + +@c docstring begin (texi-doc-string "guile" "make-vtable-vtable") +@deffn primitive make-vtable-vtable user_fields tail_array_size . init +Return a new, self-describing vtable structure. + +@var{user-fields} is a string describing user defined fields of the +vtable beginning at index @code{vtable-offset-user} +(see @code{make-struct-layout}). + +@var{tail-size} specifies the size of the tail-array (if any) of +this vtable. + +@var{init1}, @dots{} are the optional initializers for the fields of +the vtable. + +Vtables have one initializable system field---the struct printer. +This field comes before the user fields in the initializers passed +to @code{make-vtable-vtable} and @code{make-struct}, and thus works as +a third optional argument to @code{make-vtable-vtable} and a fourth to +@code{make-struct} when creating vtables: + +If the value is a procedure, it will be called instead of the standard +printer whenever a struct described by this vtable is printed. +The procedure will be called with arguments STRUCT and PORT. + +The structure of a struct is described by a vtable, so the vtable is +in essence the type of the struct. The vtable is itself a struct with +a vtable. This could go on forever if it weren't for the +vtable-vtables which are self-describing vtables, and thus terminate +the chain. + +There are several potential ways of using structs, but the standard +one is to use three kinds of structs, together building up a type +sub-system: one vtable-vtable working as the root and one or several +"types", each with a set of "instances". (The vtable-vtable should be +compared to the class which is the class of itself.) + +@example +(define ball-root (make-vtable-vtable "pr" 0)) + +(define (make-ball-type ball-color) + (make-struct ball-root 0 + (make-struct-layout "pw") + (lambda (ball port) + (format port "#" + (color ball) + (owner ball))) + ball-color)) +(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user)) +(define (owner ball) (struct-ref ball 0)) + +(define red (make-ball-type 'red)) +(define green (make-ball-type 'green)) + +(define (make-ball type owner) (make-struct type 0 owner)) + +(define ball (make-ball green 'Nisse)) +ball @result{} # +@end example +@end deffn + +@c docstring begin (texi-doc-string "guile" "struct-vtable-name") +@deffn primitive struct-vtable-name vtable +Return the name of the vtable @var{vtable}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "set-struct-vtable-name!") +@deffn primitive set-struct-vtable-name! vtable name +Set the name of the vtable @var{vtable} to @var{name}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "struct-vtable-tag") +@deffn primitive struct-vtable-tag handle +Return the vtable tag of the structure @var{handle}. +@end deffn + + +@node Arrays +@section Arrays + +@menu +* Conventional Arrays:: Arrays with arbitrary data. +* Array Mapping:: Applying a procedure to the contents of an array. +* Uniform Arrays:: Arrays with data of a single type. +* Bit Vectors:: Vectors of bits. +@end menu + +@node Conventional Arrays +@subsection Conventional Arrays + +@dfn{Conventional arrays} are a collection of cells organised into an +arbitrary number of dimensions. Each cell can hold any kind of Scheme +value and can be accessed in constant time by supplying an index for +each dimension. This contrasts with uniform arrays, which use memory +more efficiently but can hold data of only a single type, and lists +where inserting and deleting cells is more efficient, but more time +is usually required to access a particular cell. + +A conventional array is displayed as @code{#} followed by the @dfn{rank} +(number of dimensions) followed by the cells, organised into dimensions +using parentheses. The nesting depth of the parentheses is equal to +the rank. + +When an array is created, the number of dimensions and range of each +dimension must be specified, e.g., to create a 2x3 array with a +zero-based index: + +@example +(make-array 'ho 2 3) @result{} +#2((ho ho ho) (ho ho ho)) +@end example + +The range of each dimension can also be given explicitly, e.g., another +way to create the same array: + +@example +(make-array 'ho '(0 1) '(0 2)) @result{} +#2((ho ho ho) (ho ho ho)) +@end example + +A conventional array with one dimension based at zero is identical to +a vector: + +@example +(make-array 'ho 3) @result{} +#(ho ho ho) +@end example + +The following procedures can be used with conventional arrays (or vectors). + +@c docstring begin (texi-doc-string "guile" "array?") +@deffn primitive array? v [prot] +Returns @code{#t} if the @var{obj} is an array, and @code{#f} if not. + +The @var{prototype} argument is used with uniform arrays and is described +elsewhere. +@end deffn + +@deffn procedure make-array initial-value bound1 bound2 @dots{} +Creates and returns an array that has as many dimensions as there are +@var{bound}s and fills it with @var{initial-value}. +@end deffn + +@c array-ref's type is `compiled-closure'. There's some weird stuff +@c going on in array.c, too. Let's call it a primitive. -twp + +@c docstring begin (texi-doc-string "guile" "uniform-vector-ref") +@c docstring begin (texi-doc-string "guile" "array-ref") +@deffn primitive uniform-vector-ref v args +@deffnx primitive array-ref v . args +Returns the element at the @code{(index1, index2)} element in @var{array}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "array-in-bounds?") +@deffn primitive array-in-bounds? v . args +Returns @code{#t} if its arguments would be acceptable to array-ref. +@end deffn + +@c docstring begin (texi-doc-string "guile" "array-set!") +@c docstring begin (texi-doc-string "guile" "uniform-array-set1!") +@deffn primitive array-set! v obj . args +@deffnx primitive uniform-array-set1! v obj args +Sets the element at the @code{(index1, index2)} element in @var{array} to +@var{new-value}. The value returned by array-set! is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "make-shared-array") +@deffn primitive make-shared-array oldra mapfunc . dims +@code{make-shared-array} can be used to create shared subarrays of other +arrays. The @var{mapper} is a function that translates coordinates in +the new array into coordinates in the old array. A @var{mapper} must be +linear, and its range must stay within the bounds of the old array, but +it can be otherwise arbitrary. A simple example: +@example +(define fred (make-array #f 8 8)) +(define freds-diagonal + (make-shared-array fred (lambda (i) (list i i)) 8)) +(array-set! freds-diagonal 'foo 3) +(array-ref fred 3 3) @result{} foo +(define freds-center + (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2)) +(array-ref freds-center 0 0) @result{} foo +@end example +@end deffn + +@c docstring begin (texi-doc-string "guile" "shared-array-increments") +@deffn primitive shared-array-increments ra +For each dimension, return the distance between elements in the root vector. +@end deffn + +@c docstring begin (texi-doc-string "guile" "shared-array-offset") +@deffn primitive shared-array-offset ra +Return the root vector index of the first element in the array. +@end deffn + +@c docstring begin (texi-doc-string "guile" "shared-array-root") +@deffn primitive shared-array-root ra +Return the root vector of a shared array. +@end deffn + +@c docstring begin (texi-doc-string "guile" "transpose-array") +@deffn primitive transpose-array ra . args +Returns an array sharing contents with @var{array}, but with dimensions +arranged in a different order. There must be one @var{dim} argument for +each dimension of @var{array}. @var{dim0}, @var{dim1}, @dots{} should +be integers between 0 and the rank of the array to be returned. Each +integer in that range must appear at least once in the argument list. + +The values of @var{dim0}, @var{dim1}, @dots{} correspond to dimensions +in the array to be returned, their positions in the argument list to +dimensions of @var{array}. Several @var{dim}s may have the same value, +in which case the returned array will have smaller rank than +@var{array}. + +examples: +@example +(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d)) +(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d) +(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{} + #2((a 4) (b 5) (c 6)) +@end example +@end deffn + +@c docstring begin (texi-doc-string "guile" "enclose-array") +@deffn primitive enclose-array ra . axes +@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than +the rank of @var{array}. @var{enclose-array} returns an array +resembling an array of shared arrays. The dimensions of each shared +array are the same as the @var{dim}th dimensions of the original array, +the dimensions of the outer array are the same as those of the original +array that did not match a @var{dim}. + +An enclosed array is not a general Scheme array. Its elements may not +be set using @code{array-set!}. Two references to the same element of +an enclosed array will be @code{equal?} but will not in general be +@code{eq?}. The value returned by @var{array-prototype} when given an +enclosed array is unspecified. + +examples: +@example +(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{} + # + +(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{} + # +@end example +@end deffn + +@deffn procedure array-shape array +Returns a list of inclusive bounds of integers. +@example +(array-shape (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) (0 4)) +@end example +@end deffn + +@c docstring begin (texi-doc-string "guile" "array-dimensions") +@deffn primitive array-dimensions ra +@code{Array-dimensions} is similar to @code{array-shape} but replaces +elements with a @code{0} minimum with one greater than the maximum. So: +@example +(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5) +@end example +@end deffn + +@c docstring begin (texi-doc-string "guile" "array-rank") +@deffn primitive array-rank ra +Returns the number of dimensions of @var{obj}. If @var{obj} is not an +array, @code{0} is returned. +@end deffn + +@c docstring begin (texi-doc-string "guile" "array->list") +@deffn primitive array->list v +Returns a list consisting of all the elements, in order, of @var{array}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "array-copy!") +@c docstring begin (texi-doc-string "guile" "array-copy-in-order!") +@deffn primitive array-copy! src dst +@deffnx primitive array-copy-in-order! src dst +Copies every element from vector or array @var{source} to the +corresponding element of @var{destination}. @var{destination} must have +the same rank as @var{source}, and be at least as large in each +dimension. The order is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "array-fill!") +@deffn primitive array-fill! ra fill +Stores @var{fill} in every element of @var{array}. The value returned +is unspecified. +@end deffn + +@c begin (texi-doc-string "guile" "array-equal?") +@deffn primitive array-equal? ra0 ra1 +Returns @code{#t} iff all arguments are arrays with the same shape, the +same type, and have corresponding elements which are either +@code{equal?} or @code{array-equal?}. This function differs from +@code{equal?} in that a one dimensional shared array may be +@var{array-equal?} but not @var{equal?} to a vector or uniform vector. +@end deffn + +@c docstring begin (texi-doc-string "guile" "array-contents") +@deffn primitive array-contents ra [strict] +@deffnx primitive array-contents array strict +If @var{array} may be @dfn{unrolled} into a one dimensional shared array +without changing their order (last subscript changing fastest), then +@code{array-contents} returns that shared array, otherwise it returns +@code{#f}. All arrays made by @var{make-array} and +@var{make-uniform-array} may be unrolled, some arrays made by +@var{make-shared-array} may not be. + +If the optional argument @var{strict} is provided, a shared array will +be returned only if its elements are stored internally contiguous in +memory. +@end deffn + +@node Array Mapping +@subsection Array Mapping + +@c docstring begin (texi-doc-string "guile" "array-map!") +@c docstring begin (texi-doc-string "guile" "array-map-in-order!") +@deffn primitive array-map! ra0 proc . lra +@deffnx primitive array-map-in-order! ra0 proc . lra +@var{array1}, @dots{} must have the same number of dimensions as +@var{array0} and have a range for each index which includes the range +for the corresponding index in @var{array0}. @var{proc} is applied to +each tuple of elements of @var{array1} @dots{} and the result is stored +as the corresponding element in @var{array0}. The value returned is +unspecified. The order of application is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "array-for-each") +@deffn primitive array-for-each proc ra0 . lra +@var{proc} is applied to each tuple of elements of @var{array0} @dots{} +in row-major order. The value returned is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "array-index-map!") +@deffn primitive array-index-map! ra proc +applies @var{proc} to the indices of each element of @var{array} in +turn, storing the result in the corresponding element. The value +returned and the order of application are unspecified. + +One can implement @var{array-indexes} as +@example +(define (array-indexes array) + (let ((ra (apply make-array #f (array-shape array)))) + (array-index-map! ra (lambda x x)) + ra)) +@end example +Another example: +@example +(define (apl:index-generator n) + (let ((v (make-uniform-vector n 1))) + (array-index-map! v (lambda (i) i)) + v)) +@end example +@end deffn + +@node Uniform Arrays +@subsection Uniform Arrays + +@noindent +@dfn{Uniform arrays} have elements all of the +same type and occupy less storage than conventional +arrays. Uniform arrays with a single zero-based dimension +are also known as @dfn{uniform vectors}. The procedures in +this section can also be used on conventional arrays, vectors, +bit-vectors and strings. + +@noindent +When creating a uniform array, the type of data to be stored +is indicated with a @var{prototype} argument. The following table +lists the types available and example prototypes: + +@example +prototype type printing character + +#t boolean (bit-vector) b +#\a char (string) a +#\nul byte (integer) y +'s short (integer) h +1 unsigned long (integer) u +-1 signed long (integer) e +'l signed long long (integer) l +1.0 float (single precision) s +1/3 double (double precision float) i +0+i complex (double precision) c +() conventional vector +@end example + +@noindent +Unshared uniform arrays of characters with a single zero-based dimension +are identical to strings: + +@example +(make-uniform-array #\a 3) @result{} +"aaa" +@end example + +@noindent +Unshared uniform arrays of booleans with a single zero-based dimension +are identical to @ref{Bit Vectors, bit-vectors}. + +@example +(make-uniform-array #t 3) @result{} +#*111 +@end example + +@noindent +Other uniform vectors are written in a form similar to that of vectors, +except that a single character from the above table is put between +@code{#} and @code{(}. For example, a uniform vector of signed +long integers is displayed in the form @code{'#e(3 5 9)}. + +@c docstring begin (texi-doc-string "guile" "array?") +@deffn primitive array? v [prot] +Returns @code{#t} if the @var{obj} is an array, and @code{#f} if not. + +The @var{prototype} argument is used with uniform arrays and is described +elsewhere. +@end deffn + +@deffn procedure make-uniform-array prototype bound1 bound2 @dots{} +Creates and returns a uniform array of type corresponding to +@var{prototype} that has as many dimensions as there are @var{bound}s +and fills it with @var{prototype}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "array-prototype") +@deffn primitive array-prototype ra +Returns an object that would produce an array of the same type as +@var{array}, if used as the @var{prototype} for +@code{make-uniform-array}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "list->uniform-array") +@deffn primitive list->uniform-array ndim prot lst +@deffnx procedure list->uniform-vector prot lst +Returns a uniform array of the type indicated by prototype @var{prot} +with elements the same as those of @var{lst}. Elements must be of the +appropriate type, no coercions are done. +@end deffn + +@deffn primitive uniform-vector-fill! uve fill +Stores @var{fill} in every element of @var{uve}. The value returned is +unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "uniform-vector-length") +@deffn primitive uniform-vector-length v +Returns the number of elements in @var{uve}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "dimensions->uniform-array") +@deffn primitive dimensions->uniform-array dims prot [fill] +@deffnx primitive make-uniform-vector length prototype [fill] +Creates and returns a uniform array or vector of type corresponding to +@var{prototype} with dimensions @var{dims} or length @var{length}. If +@var{fill} is supplied, it's used to fill the array, otherwise +@var{prototype} is used. +@end deffn + +@c Another compiled-closure. -twp + +@c docstring begin (texi-doc-string "guile" "uniform-array-read!") +@deffn primitive uniform-array-read! ra [port_or_fd [start [end]]] +@deffnx primitive uniform-vector-read! uve [port-or-fdes] [start] [end] +Attempts to read all elements of @var{ura}, in lexicographic order, as +binary objects from @var{port-or-fdes}. +If an end of file is encountered during +uniform-array-read! the objects up to that point only are put into @var{ura} +(starting at the beginning) and the remainder of the array is +unchanged. + +The optional arguments @var{start} and @var{end} allow +a specified region of a vector (or linearized array) to be read, +leaving the remainder of the vector unchanged. + +@code{uniform-array-read!} returns the number of objects read. +@var{port-or-fdes} may be omitted, in which case it defaults to the value +returned by @code{(current-input-port)}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "uniform-array-write") +@deffn primitive uniform-array-write v [port_or_fd [start [end]]] +@deffnx primitive uniform-vector-write uve [port-or-fdes] [start] [end] +Writes all elements of @var{ura} as binary objects to +@var{port-or-fdes}. + +The optional arguments @var{start} +and @var{end} allow +a specified region of a vector (or linearized array) to be written. + +The number of objects actually written is returned. +@var{port-or-fdes} may be +omitted, in which case it defaults to the value returned by +@code{(current-output-port)}. +@end deffn + +@node Bit Vectors +@subsection Bit Vectors + +@noindent +Bit vectors are a specific type of uniform array: an array of booleans +with a single zero-based index. + +@noindent +They are displayed as a sequence of @code{0}s and +@code{1}s prefixed by @code{#*}, e.g., + +@example +(make-uniform-vector 8 #t #f) @result{} +#*00000000 + +#b(#t #f #t) @result{} +#*101 +@end example + +@c docstring begin (texi-doc-string "guile" "bit-count") +@deffn primitive bit-count b bitvector +Returns the number of occurrences of the boolean @var{b} in +@var{bitvector}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "bit-position") +@deffn primitive bit-position item v k +Returns the minimum index of an occurrence of @var{bool} in @var{bv} +which is at least @var{k}. If no @var{bool} occurs within the specified +range @code{#f} is returned. +@end deffn + +@c docstring begin (texi-doc-string "guile" "bit-invert!") +@deffn primitive bit-invert! v +Modifies @var{bv} by replacing each element with its negation. +@end deffn + +@c docstring begin (texi-doc-string "guile" "bit-set*!") +@deffn primitive bit-set*! v kv obj +If uve is a bit-vector @var{bv} and uve must be of the same +length. If @var{bool} is @code{#t}, uve is OR'ed into +@var{bv}; If @var{bool} is @code{#f}, the inversion of uve is +AND'ed into @var{bv}. + +If uve is a unsigned integer vector all the elements of uve +must be between 0 and the @code{length} of @var{bv}. The bits +of @var{bv} corresponding to the indexes in uve are set to +@var{bool}. The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "bit-count*") +@deffn primitive bit-count* v kv obj +Returns +@example +(bit-count (bit-set*! (if bool bv (bit-invert! bv)) uve #t) #t). +@end example +@var{bv} is not modified. +@end deffn + + +@node Association Lists and Hash Tables +@section Association Lists and Hash Tables + +This chapter discusses dictionary objects: data structures that are +useful for organizing and indexing large bodies of information. + +@menu +* Dictionary Types:: About dictionary types; what they're good for. +* Association Lists:: +* Hash Tables:: +@end menu + +@node Dictionary Types +@subsection Dictionary Types + +A @dfn{dictionary} object is a data structure used to index +information in a user-defined way. In standard Scheme, the main +aggregate data types are lists and vectors. Lists are not really +indexed at all, and vectors are indexed only by number +(e.g. @code{(vector-ref foo 5)}). Often you will find it useful +to index your data on some other type; for example, in a library +catalog you might want to look up a book by the name of its +author. Dictionaries are used to help you organize information in +such a way. + +An @dfn{association list} (or @dfn{alist} for short) is a list of +key-value pairs. Each pair represents a single quantity or +object; the @code{car} of the pair is a key which is used to +identify the object, and the @code{cdr} is the object's value. + +A @dfn{hash table} also permits you to index objects with +arbitrary keys, but in a way that makes looking up any one object +extremely fast. A well-designed hash system makes hash table +lookups almost as fast as conventional array or vector references. + +Alists are popular among Lisp programmers because they use only +the language's primitive operations (lists, @dfn{car}, @dfn{cdr} +and the equality primitives). No changes to the language core are +necessary. Therefore, with Scheme's built-in list manipulation +facilities, it is very convenient to handle data stored in an +association list. Also, alists are highly portable and can be +easily implemented on even the most minimal Lisp systems. + +However, alists are inefficient, especially for storing large +quantities of data. Because we want Guile to be useful for large +software systems as well as small ones, Guile provides a rich set +of tools for using either association lists or hash tables. + +@node Association Lists +@subsection Association Lists +@cindex Association List +@cindex Alist +@cindex Database + +An association list is a conventional data structure that is often used +to implement simple key-value databases. It consists of a list of +entries in which each entry is a pair. The @dfn{key} of each entry is +the @code{car} of the pair and the @dfn{value} of each entry is the +@code{cdr}. + +@example +ASSOCIATION LIST ::= '( (KEY1 . VALUE1) + (KEY2 . VALUE2) + (KEY3 . VALUE3) + @dots{} + ) +@end example + +@noindent +Association lists are also known, for short, as @dfn{alists}. + +The structure of an association list is just one example of the infinite +number of possible structures that can be built using pairs and lists. +As such, the keys and values in an association list can be manipulated +using the general list structure procedures @code{cons}, @code{car}, +@code{cdr}, @code{set-car!}, @code{set-cdr!} and so on. However, +because association lists are so useful, Guile also provides specific +procedures for manipulating them. + +@menu +* Alist Key Equality:: +* Adding or Setting Alist Entries:: +* Retrieving Alist Entries:: +* Removing Alist Entries:: +* Sloppy Alist Functions:: +* Alist Example:: +@end menu + +@node Alist Key Equality +@subsubsection Alist Key Equality + +All of Guile's dedicated association list procedures, apart from +@code{acons}, come in three flavours, depending on the level of equality +that is required to decide whether an existing key in the association +list is the same as the key that the procedure call uses to identify the +required entry. + +@itemize @bullet +@item +Procedures with @dfn{assq} in their name use @code{eq?} to determine key +equality. + +@item +Procedures with @dfn{assv} in their name use @code{eqv?} to determine +key equality. + +@item +Procedures with @dfn{assoc} in their name use @code{equal?} to +determine key equality. +@end itemize + +@code{acons} is an exception because it is used to build association +lists which do not require their entries' keys to be unique. + +@node Adding or Setting Alist Entries +@subsubsection Adding or Setting Alist Entries +@findex acons +@findex assq-set! +@findex assv-set! +@findex assoc-set! +@r5index assq-set! +@r5index assv-set! +@r5index assoc-set! + +@code{acons} adds a new entry to an association list and returns the +combined association list. The combined alist is formed by consing the +new entry onto the head of the alist specified in the @code{acons} +procedure call. So the specified alist is not modified, but its +contents become shared with the tail of the combined alist that +@code{acons} returns. + +In the most common usage of @code{acons}, a variable holding the +original association list is updated with the combined alist: + +@example +(set! address-list (acons name address address-list)) +@end example + +In such cases, it doesn't matter that the old and new values of +@code{address-list} share some of their contents, since the old value is +usually no longer independently accessible. + +Note that @code{acons} adds the specified new entry regardless of +whether the alist may already contain entries with keys that are, in +some sense, the same as that of the new entry. Thus @code{acons} is +ideal for building alists where there is no concept of key uniqueness. + +@example +(set! task-list (acons 3 "pay gas bill" '())) +task-list +@result{} +((3 . "pay gas bill")) + +(set! task-list (acons 3 "tidy bedroom" task-list)) +task-list +@result{} +((3 . "tidy bedroom") (3 . "pay gas bill")) +@end example + +@code{assq-set!}, @code{assv-set!} and @code{assoc-set!} are used to add +or replace an entry in an association list where there @emph{is} a +concept of key uniqueness. If the specified association list already +contains an entry whose key is the same as that specified in the +procedure call, the existing entry is replaced by the new one. +Otherwise, the new entry is consed onto the head of the old association +list to create the combined alist. In all cases, these procedures +return the combined alist. + +@code{assq-set!} and friends @emph{may} destructively modify the +structure of the old association list in such a way that an existing +variable is correctly updated without having to @code{set!} it to the +value returned: + +@example +address-list +@result{} +(("mary" . "34 Elm Road") ("james" . "16 Bow Street")) + +(assoc-set! address-list "james" "1a London Road") +@result{} +(("mary" . "34 Elm Road") ("james" . "1a London Road")) + +address-list +@result{} +(("mary" . "34 Elm Road") ("james" . "1a London Road")) +@end example + +Or they may not: + +@example +(assoc-set! address-list "bob" "11 Newington Avenue") +@result{} +(("bob" . "11 Newington Avenue") ("mary" . "34 Elm Road") + ("james" . "1a London Road")) + +address-list +@result{} +(("mary" . "34 Elm Road") ("james" . "1a London Road")) +@end example + +The only safe way to update an association list variable when adding or +replacing an entry like this is to @code{set!} the variable to the +returned value: + +@example +(set! address-list + (assoc-set! address-list "bob" "11 Newington Avenue")) +address-list +@result{} +(("bob" . "11 Newington Avenue") ("mary" . "34 Elm Road") + ("james" . "1a London Road")) +@end example + +Because of this slight inconvenience, you may find it more convenient to +use hash tables to store dictionary data. If your application will not +be modifying the contents of an alist very often, this may not make much +difference to you. + +If you need to keep the old value of an association list in a form +independent from the list that results from modification by +@code{acons}, @code{assq-set!}, @code{assv-set!} or @code{assoc-set!}, +use @code{list-copy} to copy the old association list before modifying +it. + +@c docstring begin (texi-doc-string "guile" "acons") +@deffn primitive acons key value alist +Adds a new key-value pair to @var{alist}. A new pair is +created whose car is @var{key} and whose cdr is @var{value}, and the +pair is consed onto @var{alist}, and the new list is returned. This +function is @emph{not} destructive; @var{alist} is not modified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "assq-set!") +@c docstring begin (texi-doc-string "guile" "assv-set!") +@c docstring begin (texi-doc-string "guile" "assoc-set!") +@deffn primitive assq-set! alist key val +@deffnx primitive assv-set! alist key value +@deffnx primitive assoc-set! alist key value +Reassociate @var{key} in @var{alist} with @var{value}: find any existing +@var{alist} entry for @var{key} and associate it with the new +@var{value}. If @var{alist} does not contain an entry for @var{key}, +add a new one. Return the (possibly new) alist. + +These functions do not attempt to verify the structure of @var{alist}, +and so may cause unusual results if passed an object that is not an +association list. +@end deffn + +@node Retrieving Alist Entries +@subsubsection Retrieving Alist Entries +@findex assq +@findex assv +@findex assoc +@findex assq-ref +@findex assv-ref +@findex assoc-ref +@r5index assq +@r5index assv +@r5index assoc +@r5index assq-ref +@r5index assv-ref +@r5index assoc-ref + +@code{assq}, @code{assv} and @code{assoc} take an alist and a key as +arguments and return the entry for that key if an entry exists, or +@code{#f} if there is no entry for that key. Note that, in the cases +where an entry exists, these procedures return the complete entry, that +is @code{(KEY . VALUE)}, not just the value. + +@c docstring begin (texi-doc-string "guile" "assq") +@c docstring begin (texi-doc-string "guile" "assv") +@c docstring begin (texi-doc-string "guile" "assoc") +@deffn primitive assq key alist +@deffnx primitive assv key alist +@deffnx primitive assoc key alist +Fetches the entry in @var{alist} that is associated with @var{key}. To +decide whether the argument @var{key} matches a particular entry in +@var{alist}, @code{assq} compares keys with @code{eq?}, @code{assv} +uses @code{eqv?} and @code{assoc} uses @code{equal?}. If @var{key} +cannot be found in @var{alist} (according to whichever equality +predicate is in use), then @code{#f} is returned. These functions +return the entire alist entry found (i.e. both the key and the value). +@end deffn + +@code{assq-ref}, @code{assv-ref} and @code{assoc-ref}, on the other +hand, take an alist and a key and return @emph{just the value} for that +key, if an entry exists. If there is no entry for the specified key, +these procedures return @code{#f}. + +This creates an ambiguity: if the return value is @code{#f}, it means +either that there is no entry with the specified key, or that there +@emph{is} an entry for the specified key, with value @code{#f}. +Consequently, @code{assq-ref} and friends should only be used where it +is known that an entry exists, or where the ambiguity doesn't matter +for some other reason. + +@c docstring begin (texi-doc-string "guile" "assq-ref") +@c docstring begin (texi-doc-string "guile" "assv-ref") +@c docstring begin (texi-doc-string "guile" "assoc-ref") +@deffn primitive assq-ref alist key +@deffnx primitive assv-ref alist key +@deffnx primitive assoc-ref alist key +Like @code{assq}, @code{assv} and @code{assoc}, except that only the +value associated with @var{key} in @var{alist} is returned. These +functions are equivalent to + +@lisp +(let ((ent (@var{associator} @var{key} @var{alist}))) + (and ent (cdr ent))) +@end lisp + +where @var{associator} is one of @code{assq}, @code{assv} or @code{assoc}. +@end deffn + +@node Removing Alist Entries +@subsubsection Removing Alist Entries +@findex assq-remove! +@findex assv-remove! +@findex assoc-remove! + +To remove the element from an association list whose key matches a +specified key, use @code{assq-remove!}, @code{assv-remove!} or +@code{assoc-remove!} (depending, as usual, on the level of equality +required between the key that you specify and the keys in the +association list). + +As with @code{assq-set!} and friends, the specified alist may or may not +be modified destructively, and the only safe way to update a variable +containing the alist is to @code{set!} it to the value that +@code{assq-remove!} and friends return. + +@example +address-list +@result{} +(("bob" . "11 Newington Avenue") ("mary" . "34 Elm Road") + ("james" . "1a London Road")) + +(set! address-list (assoc-remove! address-list "mary")) +address-list +@result{} +(("bob" . "11 Newington Avenue") ("james" . "1a London Road")) +@end example + +Note that, when @code{assq/v/oc-remove!} is used to modify an +association list that has been constructed only using the corresponding +@code{assq/v/oc-set!}, there can be at most one matching entry in the +alist, so the question of multiple entries being removed in one go does +not arise. If @code{assq/v/oc-remove!} is applied to an association +list that has been constructed using @code{acons}, or an +@code{assq/v/oc-set!} with a different level of equality, or any mixture +of these, it removes only the first matching entry from the alist, even +if the alist might contain further matching entries. For example: + +@example +(define address-list '()) +(set! address-list (assq-set! address-list "mary" "11 Elm Street")) +(set! address-list (assq-set! address-list "mary" "57 Pine Drive")) +address-list +@result{} +(("mary" . "57 Pine Drive") ("mary" . "11 Elm Street")) + +(set! address-list (assoc-remove! address-list "mary")) +address-list +@result{} +(("mary" . "11 Elm Street")) +@end example + +In this example, the two instances of the string "mary" are not the same +when compared using @code{eq?}, so the two @code{assq-set!} calls add +two distinct entries to @code{address-list}. When compared using +@code{equal?}, both "mary"s in @code{address-list} are the same as the +"mary" in the @code{assoc-remove!} call, but @code{assoc-remove!} stops +after removing the first matching entry that it finds, and so one of the +"mary" entries is left in place. + +@c docstring begin (texi-doc-string "guile" "assq-remove!") +@c docstring begin (texi-doc-string "guile" "assv-remove!") +@c docstring begin (texi-doc-string "guile" "assoc-remove!") +@deffn primitive assq-remove! alist key +@deffnx primitive assv-remove! alist key +@deffnx primitive assoc-remove! alist key +Delete the first entry in @var{alist} associated with @var{key}, and return +the resulting alist. +@end deffn + +@node Sloppy Alist Functions +@subsubsection Sloppy Alist Functions +@findex sloppy-assq +@findex sloppy-assv +@findex sloppy-assoc + +@code{sloppy-assq}, @code{sloppy-assv} and @code{sloppy-assoc} behave +like the corresponding non-@code{sloppy-} procedures, except that they +return @code{#f} when the specified association list is not well-formed, +where the non-@code{sloppy-} versions would signal an error. + +Specifically, there are two conditions for which the non-@code{sloppy-} +procedures signal an error, which the @code{sloppy-} procedures handle +instead by returning @code{#f}. Firstly, if the specified alist as a +whole is not a proper list: + +@example +(assoc "mary" '((1 . 2) ("key" . "door") . "open sesame")) +@result{} +ERROR: In procedure assoc in expression (assoc "mary" (quote #)): +ERROR: Wrong type argument in position 2 (expecting NULLP): "open sesame" +ABORT: (wrong-type-arg) + +(sloppy-assoc "mary" '((1 . 2) ("key" . "door") . "open sesame")) +@result{} +#f +@end example + +@noindent +Secondly, if one of the entries in the specified alist is not a pair: + +@example +(assoc 2 '((1 . 1) 2 (3 . 9))) +@result{} +ERROR: In procedure assoc in expression (assoc 2 (quote #)): +ERROR: Wrong type argument in position 2 (expecting CONSP): 2 +ABORT: (wrong-type-arg) + +(sloppy-assoc 2 '((1 . 1) 2 (3 . 9))) +@result{} +#f +@end example + +Unless you are explicitly working with badly formed association lists, +it is much safer to use the non-@code{sloppy-} procedures, because they +help to highlight coding and data errors that the @code{sloppy-} +versions would silently cover up. + +@c docstring begin (texi-doc-string "guile" "sloppy-assq") +@deffn primitive sloppy-assq key alist +Behaves like @code{assq} but does not do any error checking. +Recommended only for use in Guile internals. +@end deffn + +@c docstring begin (texi-doc-string "guile" "sloppy-assv") +@deffn primitive sloppy-assv key alist +Behaves like @code{assv} but does not do any error checking. +Recommended only for use in Guile internals. +@end deffn + +@c docstring begin (texi-doc-string "guile" "sloppy-assoc") +@deffn primitive sloppy-assoc key alist +Behaves like @code{assoc} but does not do any error checking. +Recommended only for use in Guile internals. +@end deffn + +@node Alist Example +@subsubsection Alist Example + +Here is a longer example of how alists may be used in practice. + +@lisp +(define capitals '(("New York" . "Albany") + ("Oregon" . "Salem") + ("Florida" . "Miami"))) + +;; What's the capital of Oregon? +(assoc "Oregon" capitals) @result{} ("Oregon" . "Salem") +(assoc-ref capitals "Oregon") @result{} "Salem" + +;; We left out South Dakota. +(set! capitals + (assoc-set! capitals "South Dakota" "Bismarck")) +capitals +@result{} (("South Dakota" . "Bismarck") + ("New York" . "Albany") + ("Oregon" . "Salem") + ("Florida" . "Miami")) + +;; And we got Florida wrong. +(set! capitals + (assoc-set! capitals "Florida" "Tallahassee")) +capitals +@result{} (("South Dakota" . "Bismarck") + ("New York" . "Albany") + ("Oregon" . "Salem") + ("Florida" . "Tallahassee")) + +;; After Oregon secedes, we can remove it. +(set! capitals + (assoc-remove! capitals "Oregon")) +capitals +@result{} (("South Dakota" . "Bismarck") + ("New York" . "Albany") + ("Florida" . "Tallahassee")) +@end lisp + +@node Hash Tables +@subsection Hash Tables + +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?}. + +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. + +@c ARGFIXME obj/key +@c docstring begin (texi-doc-string "guile" "hashq-ref") +@deffn primitive hashq-ref table obj [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 `eq?' for equality testing. +@end deffn + +@c ARGFIXME obj/key +@c docstring begin (texi-doc-string "guile" "hashv-ref") +@deffn primitive hashv-ref table obj [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 `eqv?' for equality testing. +@end deffn + +@c ARGFIXME obj/key +@c docstring begin (texi-doc-string "guile" "hash-ref") +@deffn primitive hash-ref table obj [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 `equal?' for equality testing. +@end deffn + +@c ARGFIXME obj/key +@c docstring begin (texi-doc-string "guile" "hashq-set!") +@deffn primitive hashq-set! table obj val +Find the entry in @var{table} associated with @var{key}, and store +@var{value} there. Uses `eq?' for equality testing. +@end deffn + +@c ARGFIXME obj/key +@c docstring begin (texi-doc-string "guile" "hashv-set!") +@deffn primitive hashv-set! table obj val +Find the entry in @var{table} associated with @var{key}, and store +@var{value} there. Uses `eqv?' for equality testing. +@end deffn + +@c ARGFIXME obj/key +@c docstring begin (texi-doc-string "guile" "hash-set!") +@deffn primitive hash-set! table obj val +Find the entry in @var{table} associated with @var{key}, and store +@var{value} there. Uses `equal?' for equality testing. +@end deffn + +@c ARGFIXME obj/key +@c docstring begin (texi-doc-string "guile" "hashq-remove!") +@deffn primitive hashq-remove! table obj +Remove @var{key} (and any value associated with it) from @var{table}. +Uses `eq?' for equality tests. +@end deffn + +@c ARGFIXME obj/key +@c docstring begin (texi-doc-string "guile" "hashv-remove!") +@deffn primitive hashv-remove! table obj +Remove @var{key} (and any value associated with it) from @var{table}. +Uses `eqv?' for equality tests. +@end deffn + +@c ARGFIXME obj/key +@c docstring begin (texi-doc-string "guile" "hash-remove!") +@deffn primitive hash-remove! table obj +Remove @var{key} (and any value associated with it) from @var{table}. +Uses `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. + +@c docstring begin (texi-doc-string "guile" "hashq") +@deffn primitive hashq key size +Determine a hash value for KEY that is suitable for lookups in +a hashtable of size SIZE, where eq? is used as the equality +predicate. The function returns an integer in the range 0 to +SIZE - 1. NOTE that `hashq' may use internal addresses. +Thus two calls to hashq where the keys are 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: (hashq 'foo n) (gc) (hashq 'foo n) may produce two +different values, since 'foo will be garbage collected. +@end deffn + +@c docstring begin (texi-doc-string "guile" "hashv") +@deffn primitive hashv key size +Determine a hash value for KEY that is suitable for lookups in +a hashtable of size SIZE, where eqv? is used as the equality +predicate. The function returns an integer in the range 0 to +SIZE - 1. NOTE that (hashv key) may use internal addresses. +Thus two calls to hashv where the keys are 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: (hashv 'foo n) (gc) (hashv 'foo n) may produce two +different values, since 'foo will be garbage collected. +@end deffn + +@c docstring begin (texi-doc-string "guile" "hash") +@deffn primitive hash key size +Determine a hash value for KEY that is suitable for lookups in +a hashtable of size SIZE, where equal? is used as the equality +predicate. The function returns an integer in the range 0 to +SIZE - 1. +@end deffn + +@c ARGFIXME hash/hasher +@c docstring begin (texi-doc-string "guile" "hashx-ref") +@deffn primitive hashx-ref hash assoc table obj [dflt] +This behaves the same way as the corresponding @code{ref} +function, but uses @var{hasher} as a +hash function and @var{assoc} to compare keys. @code{hasher} 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-ref table key} is equivalent +to @code{hashx-ref hashq assq table key}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "hashx-set!") +@deffn primitive hashx-set! hash assoc table obj val +This behaves the same way as the corresponding @code{set!} +function, but uses @var{hasher} as a +hash function and @var{assoc} to compare keys. @code{hasher} 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 + +@c docstring begin (texi-doc-string "guile" "hashq-get-handle") +@deffn primitive hashq-get-handle table obj +This procedure is similar to its @code{-ref} cousin, but returns a +@dfn{handle} from the hash table rather than the value associated with +@var{key}. By convention, a handle in a hash table is the pair which +associates a key with a value. Where @code{hashq-ref table key} returns +only a @code{value}, @code{hashq-get-handle table key} returns the pair +@code{(key . value)}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "hashv-get-handle") +@deffn primitive hashv-get-handle table obj +This procedure is similar to its @code{-ref} cousin, but returns a +@dfn{handle} from the hash table rather than the value associated with +@var{key}. By convention, a handle in a hash table is the pair which +associates a key with a value. Where @code{hashv-ref table key} returns +only a @code{value}, @code{hashv-get-handle table key} returns the pair +@code{(key . value)}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "hash-get-handle") +@deffn primitive hash-get-handle table obj +This procedure is similar to its @code{-ref} cousin, but returns a +@dfn{handle} from the hash table rather than the value associated with +@var{key}. By convention, a handle in a hash table is the pair which +associates a key with a value. Where @code{hash-ref table key} returns +only a @code{value}, @code{hash-get-handle table key} returns the pair +@code{(key . value)}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "hashx-get-handle") +@deffn primitive hashx-get-handle hash assoc table obj +This behaves the same way as the corresponding @code{-get-handle} +function, but uses @var{hasher} as a +hash function and @var{assoc} to compare keys. @code{hasher} 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 + +@c docstring begin (texi-doc-string "guile" "hashq-create-handle!") +@deffn primitive hashq-create-handle! 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 + +@c docstring begin (texi-doc-string "guile" "hashv-create-handle!") +@deffn primitive hashv-create-handle! 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 + +@c docstring begin (texi-doc-string "guile" "hash-create-handle!") +@deffn primitive hash-create-handle! 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 + +@c docstring begin (texi-doc-string "guile" "hashx-create-handle!") +@deffn primitive hashx-create-handle! hash assoc table obj init +This behaves the same way as the corresponding @code{-create-handle} +function, but uses @var{hasher} as a +hash function and @var{assoc} to compare keys. @code{hasher} 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 + +@c docstring begin (texi-doc-string "guile" "hash-fold") +@deffn primitive 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. +@end deffn + + +@node Vectors +@section Vectors + +@c docstring begin (texi-doc-string "guile" "make-vector") +@deffn primitive make-vector k [fill] +Returns a newly allocated vector of @var{k} elements. If a second +argument is given, then each element is initialized to @var{fill}. +Otherwise the initial contents of each element is unspecified. (r5rs) +@end deffn + +@c docstring begin (texi-doc-string "guile" "vector") +@c docstring begin (texi-doc-string "guile" "list->vector") +@deffn primitive vector . l +@deffnx primitive list->vector l +Returns a newly allocated vector whose elements contain the given +arguments. Analogous to @samp{list}. (r5rs) + +@format +@t{(vector 'a 'b 'c) ==> #(a b c) } +@end format +@end deffn + +@c docstring begin (texi-doc-string "guile" "vector->list") +@deffn primitive vector->list v +@samp{Vector->list} returns a newly allocated list of the objects contained +in the elements of @var{vector}. (r5rs) + +@format +@t{(vector->list '#(dah dah didah)) +=> (dah dah didah) +list->vector '(dididit dah)) +=> #(dididit dah) +} +@end format +@end deffn + +@c docstring begin (texi-doc-string "guile" "vector-fill!") +@deffn primitive vector-fill! v fill_x +Stores @var{fill} in every element of @var{vector}. +The value returned by @samp{vector-fill!} is unspecified. (r5rs) +@end deffn + +@c docstring begin (texi-doc-string "guile" "vector?") +@deffn primitive vector? obj +Returns @t{#t} if @var{obj} is a vector, otherwise returns @t{#f}. (r5rs) +@end deffn + + +@node Hooks +@section Hooks + +@c docstring begin (texi-doc-string "guile" "make-hook-with-name") +@deffn primitive make-hook-with-name name [n_args] +Create a named hook with the name @var{name} for storing +procedures of arity @var{n_args}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "make-hook") +@deffn primitive make-hook [n_args] +Create a hook for storing procedure of arity @var{n_args}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "hook?") +@deffn primitive hook? x +Return @code{#t} if @var{x} is a hook. +@end deffn + +@c docstring begin (texi-doc-string "guile" "hook-empty?") +@deffn primitive hook-empty? hook +Return @code{#t} if @var{hook} is an empty hook. +@end deffn + +@c docstring begin (texi-doc-string "guile" "add-hook!") +@deffn primitive add-hook! hook proc [append_p] +Add the procedure @var{proc} to the hook @var{hook}. The +procedure is added to the end if @var{append_p} is true, +otherwise it is added to the front. +@end deffn + +@c docstring begin (texi-doc-string "guile" "remove-hook!") +@deffn primitive remove-hook! hook proc +Remove the procedure @var{proc} from the hook @var{hook}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "reset-hook!") +@deffn primitive reset-hook! hook +Remove all procedures from the hook @var{hook}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "run-hook") +@deffn primitive run-hook hook . args +Apply all procedures from the hook @var{hook} to the arguments +@var{args}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "hook->list") +@deffn primitive hook->list hook +Convert the procedure list of @var{hook} to a list. +@end deffn + + +@node Other Data Types +@section Other Core Guile Data Types + + +@c Local Variables: +@c TeX-master: "guile.texi" +@c End: diff --git a/doc/scheme-debug.texi b/doc/scheme-debug.texi new file mode 100644 index 000000000..da7d599cf --- /dev/null +++ b/doc/scheme-debug.texi @@ -0,0 +1,196 @@ +@page +@node Debugging +@chapter Internal Debugging Interface + +--- The name of this chapter needs to clearly distinguish it + from the appendix describing the debugger UI. The intro + should have a pointer to the UI appendix. + +@c docstring begin (texi-doc-string "guile" "display-error") +@deffn primitive display-error stack port subr message args rest +Display an error message to the output port @var{port}. +@var{stack} is the saved stack for the error, @var{subr} is +the name of the procedure in which the error occured and +@var{message} is the actual error message, which may contain +formatting instructions. These will format the arguments in +the list @var{args} accordingly. @var{rest} is currently +ignored. +@end deffn + +@c docstring begin (texi-doc-string "guile" "display-application") +@deffn primitive display-application frame [port [indent]] +Display a procedure application @var{frame} to the output port +@var{port}. @var{indent} specifies the indentation of the +output. +@end deffn + +@c docstring begin (texi-doc-string "guile" "display-backtrace") +@deffn primitive display-backtrace stack port [first [depth]] +Display a backtrace to the output port @var{port}. @var{stack} +is the stack to take the backtrace from, @var{first} specifies +where in the stack to start and @var{depth} how much frames +to display. Both @var{first} and @var{depth} can be @code{#f}, +which means that default values will be used. +@end deffn + +@c docstring begin (texi-doc-string "guile" "backtrace") +@deffn primitive backtrace +Display a backtrace of the stack saved by the last error +to the current output port. +@end deffn + +@c docstring begin (texi-doc-string "guile" "malloc-stats") +@deffn primitive malloc-stats +Return an alist ((@var{what} . @var{n}) ...) describing number +of malloced objects. +@var{what} is the second argument to @code{scm_must_malloc}, +@var{n} is the number of objects of that type currently +allocated. +@end deffn + +@c docstring begin (texi-doc-string "guile" "debug-options-interface") +@deffn primitive debug-options-interface [setting] +Option interface for the debug options. Instead of using +this procedure directly, use the procedures @code{debug-enable}, +@code{debug-disable}, @code{debug-set!} and @var{debug-options}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "with-traps") +@deffn primitive with-traps thunk +Call @var{thunk} with traps enabled. +@end deffn + +@c docstring begin (texi-doc-string "guile" "memoized?") +@deffn primitive memoized? obj +Return @code{#t} if @var{obj} is memoized. +@end deffn + +@c docstring begin (texi-doc-string "guile" "unmemoize") +@deffn primitive unmemoize m +Unmemoize the memoized expression @var{m}, +@end deffn + +@c docstring begin (texi-doc-string "guile" "memoized-environment") +@deffn primitive memoized-environment m +Return the environment of the memoized expression @var{m}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "procedure-name") +@deffn primitive procedure-name proc +Return the name of the procedure @var{proc} +@end deffn + +@c docstring begin (texi-doc-string "guile" "procedure-source") +@deffn primitive procedure-source proc +Return the source of the procedure @var{proc}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "procedure-environment") +@deffn primitive procedure-environment proc +Return the environment of the procedure @var{proc}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "debug-object?") +@deffn primitive debug-object? obj +Return @code{#t} if @var{obj} is a debug object. +@end deffn + +@c docstring begin (texi-doc-string "guile" "frame-arguments") +@deffn primitive frame-arguments frame +Return the arguments of @var{frame}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "frame-evaluating-args?") +@deffn primitive frame-evaluating-args? frame +Return @code{#t} if @var{frame} contains evaluated arguments. +@end deffn + +@c docstring begin (texi-doc-string "guile" "frame-next") +@deffn primitive frame-next frame +Return the next frame of @var{frame}, or @code{#f} if +@var{frame} is the last frame in its stack. +@end deffn + +@c docstring begin (texi-doc-string "guile" "frame-number") +@deffn primitive frame-number frame +Return the frame number of @var{frame}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "frame-overflow?") +@deffn primitive frame-overflow? frame +Return @code{#t} if @var{frame} is an overflow frame. +@end deffn + +@c docstring begin (texi-doc-string "guile" "frame-previous") +@deffn primitive frame-previous frame +Return the previous frame of @var{frame}, or @code{#f} if +@var{frame} is the first frame in its stack. +@end deffn + +@c docstring begin (texi-doc-string "guile" "frame-procedure") +@deffn primitive frame-procedure frame +Return the procedure for @var{frame}, or @code{#f} if no +procedure is associated with @var{frame}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "frame-procedure?") +@deffn primitive frame-procedure? frame +Return @code{#t} if a procedure is associated with @var{frame}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "frame-real?") +@deffn primitive frame-real? frame +Return @code{#t} if @var{frame} is a real frame. +@end deffn + +@c docstring begin (texi-doc-string "guile" "frame-source") +@deffn primitive frame-source frame +Return the source of @var{frame}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "frame?") +@deffn primitive frame? obj +Return @code{#t} if @var{obj} is a stack frame. +@end deffn + +@c docstring begin (texi-doc-string "guile" "last-stack-frame") +@deffn primitive last-stack-frame obj +Return a stack which consists of a single frame, which is the +last stack frame for @var{obj}. @var{obj} must be either a +debug object or a continuation. +@end deffn + +@c docstring begin (texi-doc-string "guile" "make-stack") +@deffn primitive make-stack obj . args +Create a new stack. If @var{obj} is @code{#t}, the current +evaluation stack is used for creating the stack frames, +otherwise the frames are taken from @var{obj} (which must be +either a debug object or a continuation). +@var{args} must be a list if integers and specifies how the +resulting stack will be narrowed. +@end deffn + +@c docstring begin (texi-doc-string "guile" "stack-id") +@deffn primitive stack-id stack +Return the identifier given to @var{stack} by @code{start-stack}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "stack-length") +@deffn primitive stack-length stack +Return the length of @var{stack}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "stack-ref") +@deffn primitive stack-ref stack i +Return the @var{i}'th frame from @var{stack}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "stack?") +@deffn primitive stack? obj +Return @code{#t} if @var{obj} is a calling stack. +@end deffn + + +@c Local Variables: +@c TeX-master: "guile.texi" +@c End: diff --git a/doc/scheme-evaluation.texi b/doc/scheme-evaluation.texi new file mode 100644 index 000000000..95c4910f8 --- /dev/null +++ b/doc/scheme-evaluation.texi @@ -0,0 +1,255 @@ +@page +@node Read/Load/Eval +@chapter Reading and Evaluating Scheme Code + +This chapter describes Guile functions that are concerned with reading, +loading and evaluating Scheme code at run time. + +@menu +* Scheme Syntax:: Standard and extended Scheme syntax. +* Scheme Read:: Reading Scheme code. +* Fly Evaluation:: Procedures for on the fly evaluation. +* Loading:: Loading Scheme code from file. +* Delayed Evaluation:: Postponing evaluation until it is needed. +* Local Evaluation:: Evaluation in a local environment. +* Evaluator Options:: +@end menu + + +@node Scheme Syntax +@section Scheme Syntax: Standard and Guile Extensions + +@menu +* Expression Syntax:: +* Comments:: +* Block Comments:: +* Case Sensitivity:: +* Keyword Syntax:: +* Reader Extensions:: +@end menu + + +@node Expression Syntax +@subsection Expression Syntax + + +@node Comments +@subsection Comments + + +@node Block Comments +@subsection Block Comments + + +@node Case Sensitivity +@subsection Case Sensitivity + + +@node Keyword Syntax +@subsection Keyword Syntax + + +@node Reader Extensions +@subsection Reader Extensions + +@c docstring begin (texi-doc-string "guile" "read-hash-extend") +@deffn primitive read-hash-extend chr proc +Install the procedure @var{proc} for reading expressions +starting with the character sequence @code{#} and @var{chr}. +@var{proc} will be called with two arguments: the character +@var{chr} and the port to read further data from. The object +returned will be the return value of @code{read}. +@end deffn + + +@node Scheme Read +@section Reading Scheme Code + +@c docstring begin (texi-doc-string "guile" "read-options-interface") +@deffn primitive read-options-interface [setting] +Option interface for the read options. Instead of using +this procedure directly, use the procedures @code{read-enable}, +@code{read-disable}, @code{read-set!} and @var{read-options}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "read") +@deffn primitive read [port] +Read an s-expression from the input port @var{port}, or from +the current input port if @var{port} is not specified. +Any whitespace before the next token is discarded. +@end deffn + + +@node Fly Evaluation +@section Procedures for On the Fly Evaluation + +@c ARGFIXME environment/environment specifier +@c docstring begin (texi-doc-string "guile" "eval") +@deffn primitive eval exp environment +Evaluate @var{exp}, a list representing a Scheme expression, in the +environment given by @var{environment specifier}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "interaction-environment") +@deffn primitive interaction-environment +This procedure returns a specifier for the environment that contains +implementation-defined bindings, typically a superset of those listed in +the report. The intent is that this procedure will return the +environment in which the implementation would evaluate expressions +dynamically typed by the user. +@end deffn + +@c docstring begin (texi-doc-string "guile" "eval-string") +@deffn primitive eval-string string +Evaluate @var{string} as the text representation of a Scheme form +or forms, and return whatever value they produce. +Evaluation takes place in (interaction-environment). +@end deffn + +@c docstring begin (texi-doc-string "guile" "apply:nconc2last") +@deffn primitive apply:nconc2last lst +Given a list (@var{arg1} @dots{} @var{args}), this function +conses the @var{arg1} @dots{} arguments onto the front of +@var{args}, and returns the resulting list. Note that +@var{args} is a list; thus, the argument to this function is +a list whose last element is a list. +Note: Rather than do new consing, @code{apply:nconc2last} +destroys its argument, so use with care. +@end deffn + +@deffn primitive primitive-eval exp +Evaluate @var{exp} in the top-level environment specified by +the current module. +@end deffn + +@deffn primitive eval2 obj env_thunk +Evaluate @var{exp}, a Scheme expression, in the environment +designated by @var{lookup}, a symbol-lookup function." +Do not use this version of eval, it does not play well +with the module system. Use @code{eval} or +@code{primitive-eval} instead. +@end deffn + +@deffn primitive read-and-eval! [port] +Read a form from @var{port} (standard input by default), and evaluate it +(memoizing it in the process) in the top-level environment. If no data +is left to be read from @var{port}, an @code{end-of-file} error is +signalled. +@end deffn + + +@node Loading +@section Loading Scheme Code from File + +@c ARGFIXME file/filename +@c docstring begin (texi-doc-string "guile" "primitive-load") +@deffn primitive primitive-load filename +Load @var{file} and evaluate its contents in the top-level environment. +The load paths are not searched; @var{file} must either be a full +pathname or be a pathname relative to the current directory. If the +variable @code{%load-hook} is defined, it should be bound to a procedure +that will be called before any code is loaded. See documentation for +@code{%load-hook} later in this section. +@end deffn + +@c ARGFIXME file/filename +@c docstring begin (texi-doc-string "guile" "primitive-load-path") +@deffn primitive primitive-load-path filename +Search @var{%load-path} for @var{file} and load it into the top-level +environment. If @var{file} is a relative pathname and is not found in +the list of search paths, an error is signalled. +@end deffn + +@c ARGFIXME file/filename +@c docstring begin (texi-doc-string "guile" "%search-load-path") +@deffn primitive %search-load-path filename +Search @var{%load-path} for @var{file}, which must be readable by the +current user. If @var{file} is found in the list of paths to search or +is an absolute pathname, return its full pathname. Otherwise, return +@code{#f}. Filenames may have any of the optional extensions in the +@code{%load-extensions} list; @code{%search-load-path} will try each +extension automatically. +@end deffn + +@defvar %load-hook +A procedure to be run whenever @code{primitive-load} is called. If this +procedure is defined, it will be called with the filename argument that +was passed to @code{primitive-load}. + +@example +(define %load-hook (lambda (file) + (display "Loading ") + (display file) + (write-line "...."))) @result{} undefined +(load-from-path "foo.scm") +@print{} Loading /usr/local/share/guile/site/foo.scm.... +@end example + +@end defvar + +@c docstring begin (texi-doc-string "guile" "current-load-port") +@deffn primitive current-load-port +Return the current-load-port. +The load port is used internally by @code{primitive-load}. +@end deffn + +@defvar %load-extensions +A list of default file extensions for files containing Scheme code. +@code{%search-load-path} tries each of these extensions when looking for +a file to load. By default, @code{%load-extensions} is bound to the +list @code{("" ".scm")}. +@end defvar + + +@node Delayed Evaluation +@section Delayed Evaluation + +[delay] + +@c ARGFIXME x/obj +@c docstring begin (texi-doc-string "guile" "promise?") +@deffn primitive promise? x +Return true if @var{obj} is a promise, i.e. a delayed computation +(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}). +@end deffn + +@c docstring begin (texi-doc-string "guile" "force") +@deffn primitive force x +If the promise X has not been computed yet, compute and return +X, otherwise just return the previously computed value. +@end deffn + + +@node Local Evaluation +@section Local Evaluation + +[the-environment] + +@c docstring begin (texi-doc-string "guile" "local-eval") +@deffn primitive local-eval exp [env] +Evaluate @var{exp} in its environment. If @var{env} is supplied, +it is the environment in which to evaluate @var{exp}. Otherwise, +@var{exp} must be a memoized code object (in which case, its environment +is implicit). +@end deffn + + +@node Evaluator Options +@section Evaluator Options + +@c docstring begin (texi-doc-string "guile" "eval-options-interface") +@deffn primitive eval-options-interface [setting] +Option interface for the evaluation options. Instead of using +this procedure directly, use the procedures @code{eval-enable}, +@code{eval-disable}, @code{eval-set!} and @var{eval-options}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "evaluator-traps-interface") +@deffn primitive evaluator-traps-interface [setting] +Option interface for the evaluator trap options. +@end deffn + + +@c Local Variables: +@c TeX-master: "guile.texi" +@c End: diff --git a/doc/scheme-ideas.texi b/doc/scheme-ideas.texi new file mode 100644 index 000000000..6db8ce219 --- /dev/null +++ b/doc/scheme-ideas.texi @@ -0,0 +1,1458 @@ +@page +@node Basic Ideas +@chapter Basic Ideas in Scheme + +In this chapter, we introduce the basic concepts that underpin the +elegance and power of the Scheme language. + +Readers who already possess a background knowledge of Scheme may happily +skip this chapter. For the reader who is new to the language, however, +the following discussions on data, procedures, expressions and closure +are designed to provide a minimum level of Scheme understanding that is +more or less assumed by the reference chapters that follow. + +The style of this introductory material aims about halfway between the +terse precision of R5RS and the discursive randomness of a Scheme +tutorial. + +@menu +* About Data:: Latent typing, types, values and variables. +* About Procedures:: The representation and use of procedures. +* About Expressions:: All kinds of expressions and their meaning. +* About Closure:: Closure, scoping and environments. +@end menu + + +@node About Data +@section Data Types, Values and Variables + +This section discusses the representation of data types and values, what +it means for Scheme to be a @dfn{latently typed} language, and the role +of variables. We conclude by introducing the Scheme syntaxes for +defining a new variable, and for changing the value of an existing +variable. + +@menu +* Latent Typing:: Scheme as a "latently typed" language. +* Values and Variables:: About data types, values and variables. +* Definition:: Defining variables and setting their values. +@end menu + + +@node Latent Typing +@subsection Latent Typing + +The term @dfn{latent typing} is used to descibe a computer language, +such as Scheme, for which you cannot, @emph{in general}, simply look at +a program's source code and determine what type of data will be +associated with a particular variable, or with the result of a +particular expression. + +Sometimes, of course, you @emph{can} tell from the code what the type of +an expression will be. If you have a line in your program that sets the +variable @code{x} to the numeric value 1, you can be certain that, +immediately after that line has executed (and in the absence of multiple +threads), @code{x} has the numeric value 1. Or if you write a procedure +that is designed to concatenate two strings, it is likely that the rest +of your application will always invoke this procedure with two string +parameters, and quite probable that the procedure would go wrong in some +way if it was ever invoked with parameters that were not both strings. + +Nevertheless, the point is that there is nothing in Scheme which +requires the procedure parameters always to be strings, or @code{x} +always to hold a numeric value, and there is no way of declaring in your +program that such constraints should always be obeyed. In the same +vein, there is no way to declare the expected type of a procedure's +return value. + +Instead, the types of variables and expressions are only known -- in +general -- at run time. If you @emph{need} to check at some point that +a value has the expected type, Scheme provides run time procedures that +you can invoke to do so. But equally, it can be perfectly valid for two +separate invocations of the same procedure to specify arguments with +different types, and to return values with different types. + +The next subsection explains what this means in practice, for the ways +that Scheme programs use data types, values and variables. + + +@node Values and Variables +@subsection Values and Variables + +Scheme provides many data types that you can use to represent your data. +Primitive types include characters, strings, numbers and procedures. +Compound types, which allow a group of primitive and compound values to +be stored together, include lists, pairs, vectors and multi-dimensional +arrays. In addition, Guile allows applications to define their own data +types, with the same status as the built-in standard Scheme types. + +As a Scheme program runs, values of all types pop in and out of +existence. Sometimes values are stored in variables, but more commonly +they pass seamlessly from being the result of one computation to being +one of the parameters for the next. + +Consider an example. A string value is created because the interpreter +reads in a literal string from your program's source code. Then a +numeric value is created as the result of calculating the length of the +string. A second numeric value is created by doubling the calculated +length. Finally the program creates a list with two elements -- the +doubled length and the original string itself -- and stores this list in +a program variable. + +All of the values involved here -- in fact, all values in Scheme -- +carry their type with them. In other words, every value ``knows,'' at +runtime, what kind of value it is. A number, a string, a list, +whatever. + +A variable, on the other hand, has no fixed type. A variable -- +@code{x}, say -- is simply the name of a location -- a box -- in which +you can store any kind of Scheme value. So the same variable in a +program may hold a number at one moment, a list of procedures the next, +and later a pair of strings. The ``type'' of a variable -- insofar as +the idea is meaningful at all -- is simply the type of whatever value +the variable happens to be storing at a particular moment. + + +@node Definition +@subsection Defining and Setting Variables + +To define a new variable, you use Scheme's @code{define} syntax like +this: + +@lisp +(define @var{variable-name} @var{value}) +@end lisp + +This makes a new variable called @var{variable-name} and stores +@var{value} in it as the variable's initial value. For example: + +@lisp +;; Make a variable `x' with initial numeric value 1. +(define x 1) + +;; Make a variable `organization' with an initial string value. +(define organization "Free Software Foundation") +@end lisp + +(In Scheme, a semicolon marks the beginning of a comment that continues +until the end of the line. So the lines beginning @code{;;} are +comments.) + +Changing the value of an already existing variable is very similar, +except that @code{define} is replaced by the Scheme syntax @code{set!}, +like this: + +@lisp +(set! @var{variable-name} @var{new-value}) +@end lisp + +Remember that variables do not have fixed types, so @var{new-value} may +have a completely different type from whatever was previously stored in +the location named by @var{variable-name}. Both of the following +examples are therefore correct. + +@lisp +;; Change the value of `x' to 5. +(set! x 5) + +;; Change the value of `organization' to the FSF's street number. +(set! organization 545) +@end lisp + +In these examples, @var{value} and @var{new-value} are literal numeric +or string values. In general, however, @var{value} and @var{new-value} +can be any Scheme expression. Even though we have not yet covered the +forms that Scheme expressions can take (@pxref{About Expressions}), you +can probably guess what the following @code{set!} example does@dots{} + +@lisp +(set! x (+ x 1)) +@end lisp + +(Note: this is not a complete description of @code{define} and +@code{set!}, because we need to introduce some other aspects of Scheme +before the missing pieces can be filled in. If, however, you are +already familiar with the structure of Scheme, you may like to read +about those missing pieces immediately by jumping ahead to the following +references. + +@itemize @bullet +@item +REFFIXME, to read about using @code{define} other than at top level in a +Scheme program, including a discussion of when it works to use +@code{define} rather than @code{set!} to change the value of an existing +variable. + +@item +@ref{Lambda Alternatives}, to read about an alternative form of the +@code{define} syntax that can be used when defining new procedures. + +@item +REFFIXME, to read about an alternative form of the @code{set!} syntax +that helps with changing a single value in the depths of a compound data +structure.) +@end itemize + + +@node About Procedures +@section The Representation and Use of Procedures + +This section introduces the basics of using and creating Scheme +procedures. It discusses the representation of procedures as just +another kind of Scheme value, and shows how procedure invocation +expressions are constructed. We then explain how @code{lambda} is used +to create new procedures, and conclude by presenting the various +shorthand forms of @code{define} that can be used instead of writing an +explicit @code{lambda} expression. + +@menu +* Procedures as Values:: Procedures are values like everything else. +* Simple Invocation:: How to write a simple procedure invocation. +* Creating a Procedure:: How to create your own procedures. +* Lambda Alternatives:: Other ways of writing procedure definitions. +@end menu + + +@node Procedures as Values +@subsection Procedures as Values + +One of the great simplifications of Scheme is that a procedure is just +another type of value, and that procedure values can be passed around +and stored in variables in exactly the same way as, for example, strings +and lists. When we talk about a built-in standard Scheme procedure such +as @code{open-input-file}, what we actually mean is that there is a +pre-defined top level variable called @code{open-input-file}, whose +value is a procedure that implements what R5RS says that +@code{open-input-file} should do. + +Note that this is quite different from many dialects of Lisp --- +including Emacs Lisp --- in which a program can use the same name with +two quite separate meanings: one meaning identifies a Lisp function, +while the other meaning identifies a Lisp variable, whose value need +have nothing to do with the function that is associated with the first +meaning. In these dialects, functions and variables are said to live in +different @dfn{namespaces}. + +In Scheme, on the other hand, all names belong to a single unified +namespace, and the variables that these names identify can hold any kind +of Scheme value, including procedure values. + +One consequence of the ``procedures as values'' idea is that, if you +don't happen to like the standard name for a Scheme procedure, you can +change it. + +For example, @code{call-with-current-continuation} is a very important +standard Scheme procedure, but it also has a very long name! So, many +programmers use the following definition to assign the same procedure +value to the more convenient name @code{call/cc}. + +@lisp +(define call/cc call-with-current-continuation) +@end lisp + +Let's understand exactly how this works. The definition creates a new +variable @code{call/cc}, and then sets its value to the value of the +variable @code{call-with-current-continuation}; the latter value is a +procedure that implements the behaviour that R5RS specifies under the +name ``call-with-current-continuation''. So @code{call/cc} ends up +holding this value as well. + +Now that @code{call/cc} holds the required procedure value, you could +choose to use @code{call-with-current-continuation} for a completely +different purpose, or just change its value so that you will get an +error if you accidentally use @code{call-with-current-continuation} as a +procedure in your program rather than @code{call/cc}. For example: + +@lisp +(set! call-with-current-continuation "Not a procedure any more!") +@end lisp + +Or you could just leave @code{call-with-current-continuation} as it was. +It's perfectly fine for more than one variable to hold the same +procedure value. + + +@node Simple Invocation +@subsection Simple Procedure Invocation + +A procedure invocation in Scheme is written like this: + +@lisp +(@var{procedure} [@var{arg1} [@var{arg2} @dots{}]]) +@end lisp + +In this expression, @var{procedure} can be any Scheme expression whose +value is a procedure. Most commonly, however, @var{procedure} is simply +the name of a variable whose value is a procedure. + +For example, @code{string-append} is a standard Scheme procedure whose +behaviour is to concatenate together all the arguments, which are +expected to be strings, that it is given. So the expression + +@lisp +(string-append "/home" "/" "andrew") +@end lisp + +@noindent +is a procedure invocation whose result is the string value +@code{"/home/andrew"}. + +Similarly, @code{string-length} is a standard Scheme procedure that +returns the length of a single string argument, so + +@lisp +(string-length "abc") +@end lisp + +@noindent +is a procedure invocation whose result is the numeric value 3. + +Each of the parameters in a procedure invocation can itself be any +Scheme expression. Since a procedure invocation is itself a type of +expression, we can put these two examples together to get + +@lisp +(string-length (string-append "/home" "/" "andrew")) +@end lisp + +@noindent +--- a procedure invocation whose result is the numeric value 12. + +(You may be wondering what happens if the two examples are combined the +other way round. If we do this, we can make a procedure invocation +expression that is @emph{syntactically} correct: + +@lisp +(string-append "/home" (string-length "abc")) +@end lisp + +@noindent +but when this expression is executed, it will cause an error, because +the result of @code{(string-length "abc")} is a numeric value, and +@code{string-append} is not designed to accept a numeric value as one of +its arguments.) + + +@node Creating a Procedure +@subsection Creating and Using a New Procedure + +Scheme has lots of standard procedures, and Guile provides all of these +via predefined top level variables. All of these standard procedures +are documented in the later chapters of this reference manual. + +Before very long, though, you will want to create new procedures that +encapsulate aspects of your own applications' functionality. To do +this, you can use the famous @code{lambda} syntax. + +For example, the value of the following Scheme expression + +@lisp +(lambda (name address) @var{expression} @dots{}) +@end lisp + +@noindent +is a newly created procedure that takes two arguments: +@code{name} and @code{address}. The behaviour of the +new procedure is determined by the sequence of @var{expression}s in the +@dfn{body} of the procedure definition. (Typically, these +@var{expression}s would use the arguments in some way, or else there +wouldn't be any point in giving them to the procedure.) When invoked, +the new procedure returns a value that is the value of the last +@var{expression} in the procedure body. + +To make things more concrete, let's suppose that the two arguments are +both strings, and that the purpose of this procedure is to form a +combined string that includes these arguments. Then the full lambda +expression might look like this: + +@lisp +(lambda (name address) + (string-append "Name=" name ":Address=" address)) +@end lisp + +We noted in the previous subsection that the @var{procedure} part of a +procedure invocation expression can be any Scheme expression whose value +is a procedure. But that's exactly what a lambda expression is! So we +can use a lambda expression directly in a procedure invocation, like +this: + +@lisp +((lambda (name address) + (string-append "Name=" name ":Address=" address)) + "FSF" + "Cambridge") +@end lisp + +@noindent +This is a valid procedure invocation expression, whose result is the +string @code{"Name=FSF:Address=Cambridge"}. + +It it more common, though, to store the procedure value in a variable --- + +@lisp +(define make-combined-string + (lambda (name address) + (string-append "Name=" name ":Address=" address))) +@end lisp + +@noindent +--- and then to use the variable name in the procedure invocation: + +@lisp +(make-combined-string "FSF" "Cambridge") +@end lisp + +@noindent +Which has exactly the same result. + +It's important to note that procedures created using @code{lambda} have +exactly the same status as the standard built in Scheme procedures, and +can be invoked, passed around, and stored in variables in exactly the +same ways. + + +@node Lambda Alternatives +@subsection Lambda Alternatives + +Since it is so common in Scheme programs to want to create a procedure +and then store it in a variable, there is an alternative form of the +@code{define} syntax that allows you to do just that. + +A @code{define} expression of the form + +@lisp +(define (@var{name} [@var{arg1} [@var{arg2} @dots{}]]) + @var{expression} @dots{}) +@end lisp + +@noindent +is exactly equivalent to the longer form + +@lisp +(define @var{name} + (lambda ([@var{arg1} [@var{arg2} @dots{}]]) + @var{expression} @dots{})) +@end lisp + +So, for example, the definition of @code{make-combined-string} in the +previous subsection could equally be written: + +@lisp +(define (make-combined-string name address) + (string-append "Name=" name ":Address=" address)) +@end lisp + +This kind of procedure definition creates a procedure that requires +exactly the expected number of arguments. There are two further forms +of the @code{lambda} expression, which create a procedure that can +accept a variable number of arguments: + +@lisp +(lambda (@var{arg1} @dots{} . @var{args}) @var{expression} @dots{}) + +(lambda @var{args} @var{expression} @dots{}) +@end lisp + +@noindent +The corresponding forms of the alternative @code{define} syntax are: + +@lisp +(define (@var{name} @var{arg1} @dots{} . @var{args}) @var{expression} @dots{}) + +(define (@var{name} . @var{args}) @var{expression} @dots{}) +@end lisp + +@noindent +For details on how these forms work, see @xref{Lambda}. + +(It could be argued that the alternative @code{define} forms are rather +confusing, especially for newcomers to the Scheme language, as they hide +both the role of @code{lambda} and the fact that procedures are values +that are stored in variables in the some way as any other kind of value. +On the other hand, they are very convenient, and they are also a good +example of another of Scheme's powerful features: the ability to specify +arbitrary syntactic transformations at run time, which can be applied to +subsequently read input.) + + +@node About Expressions +@section Expressions and Evaluation + +So far, we have met expressions that @emph{do} things, such as the +@code{define} expressions that create and initialize new variables, and +we have also talked about expressions that have @emph{values}, for +example the value of the procedure invocation expression: + +@lisp +(string-append "/home" "/" "andrew") +@end lisp + +@noindent +but we haven't yet been precise about what causes an expression like +this procedure invocation to be reduced to its ``value'', or how the +processing of such expressions relates to the execution of a Scheme +program as a whole. + +This section clarifies what we mean by an expression's value, by +introducing the idea of @dfn{evaluation}. It discusses the side effects +that evaluation can have, explains how each of the various types of +Scheme expression is evaluated, and describes the behaviour and use of +the Guile REPL as a mechanism for exploring evaluation. The section +concludes with a very brief summary of Scheme's common syntactic +expressions. + +@menu +* Evaluating:: How a Scheme program is executed. +* The REPL:: Interacting with the Guile interpreter. +* Syntax Summary:: Common syntactic expressions -- in brief. +@end menu + + +@node Evaluating +@subsection Evaluating Expressions and Executing Programs + +In Scheme, the process of executing an expression is known as +@dfn{evaluation}. Evaluation has two kinds of result: + +@itemize @bullet +@item +the @dfn{value} of the evaluated expression + +@item +the @dfn{side effects} of the evaluation, which consist of any effects of +evaluating the expression that are not represented by the value. +@end itemize + +Of the expressions that we have met so far, @code{define} and +@code{set!} expressions have side effects --- the creation or +modification of a variable --- but no value; @code{lambda} expressions +have values --- the newly constructed procedures --- but no side +effects; and procedure invocation expressions, in general, have either +values, or side effects, or both. + +It is tempting to try to define more intuitively what we mean by +``value'' and ``side effects'', and what the difference between them is. +In general, though, this is extremely difficult. It is also +unnecessary; instead, we can quite happily define the behaviour of a +Scheme program by specifying how Scheme executes a program as a whole, +and then by describing the value and side effects of evaluation for each +type of expression individually. + +@noindent +So, some@footnote{These definitions are approximate. For the whole and +detailed truth, see @xref{Formal syntax and semantics,R5RS +syntax,,r5rs}.} definitions@dots{} + +@itemize @bullet + +@item +A Scheme program consists of a sequence of expressions. + +@item +A Scheme interpreter executes the program by evaluating these +expressions in order, one by one. + +@item +An expression can be + +@itemize @bullet +@item +a piece of literal data, such as a number @code{2.3} or a string +@code{"Hello world!"} +@item +a variable name +@item +a procedure invocation expression +@item +one of Scheme's special syntactic expressions. +@end itemize +@end itemize + +@noindent +The following subsections describe how each of these types of expression +is evaluated. + +@menu +* Eval Literal:: Evaluating literal data. +* Eval Variable:: Evaluating variable references. +* Eval Procedure:: Evaluating procedure invocation expressions. +* Eval Special:: Evaluating special syntactic expressions. +@end menu + +@node Eval Literal +@subsubsection Evaluating Literal Data + +When a literal data expression is evaluated, the value of the expression +is simply the value that the expression describes. The evaluation of a +literal data expression has no side effects. + +@noindent +So, for example, + +@itemize @bullet +@item +the value of the expression @code{"abc"} is the string value +@code{"abc"} + +@item +the value of the expression @code{3+4i} is the complex number 3 + 4i + +@item +the value of the expression @code{#(1 2 3)} is a three-element vector +containing the numeric values 1, 2 and 3. +@end itemize + +For any data type which can be expressed literally like this, the syntax +of the literal data expression for that data type --- in other words, +what you need to write in your code to indicate a literal value of that +type --- is known as the data type's @dfn{read syntax}. This manual +specifies the read syntax for each such data type in the section that +describes that data type. + +Some data types do not have a read syntax. Procedures, for example, +cannot be expressed as literal data; they must be created using a +@code{lambda} expression (@pxref{Creating a Procedure}) or implicitly +using the shorthand form of @code{define} (@pxref{Lambda Alternatives}). + + +@node Eval Variable +@subsubsection Evaluating a Variable Reference + +When an expression that consists simply of a variable name is evaluated, +the value of the expression is the value of the named variable. The +evaluation of a variable reference expression has no side effects. + +So, after + +@lisp +(define key "Paul Evans") +@end lisp + +@noindent +the value of the expression @code{key} is the string value @code{"Paul +Evans"}. If @var{key} is then modified by + +@lisp +(set! key 3.74) +@end lisp + +@noindent +the value of the expression @code{key} is the numeric value 3.74. + +If there is no variable with the specified name, evaluation of the +variable reference expression signals an error. + + +@node Eval Procedure +@subsubsection Evaluating a Procedure Invocation Expression + +This is where evaluation starts getting interesting! As already noted, +a procedure invocation expression has the form + +@lisp +(@var{procedure} [@var{arg1} [@var{arg2} @dots{}]]) +@end lisp + +@noindent +where @var{procedure} must be an expression whose value, when evaluated, +is a procedure. + +The evaluation of a procedure invocation expression like this proceeds +by + +@itemize @bullet +@item +evaluating individually the expressions @var{procedure}, @var{arg1}, +@var{arg2}, and so on + +@item +calling the procedure that is the value of the @var{procedure} +expression with the list of values obtained from the evaluations of +@var{arg1}, @var{arg2} etc. as its parameters. +@end itemize + +For a procedure defined in Scheme, ``calling the procedure with the list +of values as its parameters'' means binding the values to the +procedure's formal parameters and then evaluating the sequence of +expressions that make up the body of the procedure definition. The +value of the procedure invocation expression is the value of the last +evaluated expression in the procedure body. The side effects of calling +the procedure are the combination of the side effects of the sequence of +evaluations of expressions in the procedure body. + +For a built-in procedure, the value and side-effects of calling the +procedure are best described by that procedure's documentation. + +Note that the complete side effects of evaluating a procedure invocation +expression consist not only of the side effects of the procedure call, +but also of any side effects of the preceding evaluation of the +expressions @var{procedure}, @var{arg1}, @var{arg2}, and so on. + +To illustrate this, let's look again at the procedure invocation +expression: + +@lisp +(string-length (string-append "/home" "/" "andrew")) +@end lisp + +In the outermost expression, @var{procedure} is @code{string-length} and +@var{arg1} is @code{(string-append "/home" "/" "andrew")}. + +@itemize @bullet +@item +Evaluation of @code{string-length}, which is a variable, gives a +procedure value that implements the expected behaviour for +``string-length''. + +@item +Evaluation of @code{(string-append "/home" "/" "andrew")}, which is +another procedure invocation expression, means evaluating each of + +@itemize @bullet +@item +@code{string-append}, which gives a procedure value that implements the +expected behaviour for ``string-append'' + +@item +@code{"/home"}, which gives the string value @code{"/home"} + +@item +@code{"/"}, which gives the string value @code{"/"} + +@item +@code{"andrew"}, which gives the string value @code{"andrew"} +@end itemize + +and then invoking the procedure value with this list of string values as +its arguments. The resulting value is a single string value that is the +concatenation of all the arguments, namely @code{"/home/andrew"}. +@end itemize + +In the evaluation of the outermost expression, the interpreter can now +invoke the procedure value obtained from @var{procedure} with the value +obtained from @var{arg1} as its arguments. The resulting value is a +numeric value that is the length of the argument string, which is 12. + + +@node Eval Special +@subsubsection Evaluating Special Syntactic Expressions + +When a procedure invocation expression is evaluated, the procedure and +@emph{all} the argument expressions must be evaluated before the +procedure can be invoked. Special syntactic expressions are special +because they are able to manipulate their arguments in an unevaluated +form, and can choose whether to evaluate any or all of the argument +expressions. + +Why is this needed? Consider a program fragment that asks the user +whether or not to delete a file, and then deletes the file if the user +answers yes. + +@lisp +(if (string=? (read-answer "Should I delete this file?") + "yes") + (delete-file file)) +@end lisp + +If the outermost @code{(if @dots{})} expression here was a procedure +invocation expression, the expression @code{(delete-file file)}, whose +effect is to actually delete a file, would already have been executed +before the @code{if} procedure even got invoked! Clearly this is no use +--- the whole point of an @code{if} expression is that the +@dfn{consequent} expression is only evaluated if the condition of the +@code{if} expression is ``true''. + +Therefore @code{if} must be special syntax, not a procedure. Other +special syntaxes that we have already met are @code{define}, @code{set!} +and @code{lambda}. @code{define} and @code{set!} are syntax because +they need to know the variable @emph{name} that is given as the first +argument in a @code{define} or @code{set!} expression, not that +variable's value. @code{lambda} is syntax because it does not +immediately evaluate the expressions that define the procedure body; +instead it creates a procedure object that incorporates these +expressions so that they can be evaluated in the future, when that +procedure is invoked. + +The rules for evaluating each special syntactic expression are specified +individually for each special syntax. For a summary of standard special +syntax, see @xref{Syntax Summary}. + + +@node The REPL +@subsection Using the Guile REPL + +If you start Guile without specifying a particular program for it to +execute, Guile enters its standard Read Evaluate Print Loop --- or +@dfn{REPL} for short. In this mode, Guile repeatedly reads in the next +Scheme expression that the user types, evaluates it, and prints the +resulting value. + +The REPL is a useful mechanism for exploring the evaluation behaviour +described in the previous subsection. If you type @code{string-append}, +for example, the REPL replies @code{#}, illustrating the relationship between the variable +@code{string-append} and the procedure value stored in that variable. + +In this manual, the notation @result{} is used to mean ``evaluates +to''. Wherever you see an example of the form + +@lisp +@var{expression} +@result{} +@var{result} +@end lisp + +@noindent +feel free to try it out yourself by typing @var{expression} into the +REPL and checking that it gives the expected @var{result}. + + +@node Syntax Summary +@subsection Summary of Common Syntax + +This subsection lists the most commonly used Scheme syntactic +expressions, simply so that you will recognize common special syntax +when you see it. For a full description of each of these syntaxes, +follow the appropriate reference. + +@code{if} (REFFIXME) and @code{cond} (REFFIXME) provide conditional +evaluation of argument expressions depending on whether one or more +conditions evaluate to ``true'' or ``false''. + +@code{case} (REFFIXME) provides conditional evaluation of argument +expressions depending on whether a variable has one of a specified group +of values. + +@code{define} (REFFIXME) is used to create a new variable and set its +initial value. + +@code{set!} (REFFIXME) is used to modify an existing variable's value. + +@code{lambda} (REFFIXME) is used to construct procedure objects. + +@code{let} (REFFIXME), @code{let*} (REFFIXME) and @code{letrec} +(REFFIXME) create an inner lexical environment for the evaluation of a +sequence of expressions, in which a specified set of local variables is +bound to the values of a corresponding set of expressions. For an +introduction to environments, see @xref{About Closure}. + +@code{begin} (REFFIXME) executes a sequence of expressions in order and +returns the value of the last expression. Note that this is not the +same as a procedure which returns its last argument, because the +evaluation of a procedure invocation expression does not guarantee to +evaluate the arguments in order. + +@code{and} (REFFIXME) executes a sequence of expressions in order until +either there are no expressions left, or one of them evaluates to +``false''. + +@code{or} (REFFIXME) executes a sequence of expressions in order until +either there are no expressions left, or one of them evaluates to +``true''. + + +@node About Closure +@section The Concept of Closure + +@cindex closure + +The concept of @dfn{closure} is the idea that a lambda expression +``captures'' the variable bindings that are in lexical scope at the +point where the lambda expression occurs. The procedure created by the +lambda expression can refer to and mutate the captured bindings, and the +values of those bindings persist between procedure calls. + +This section explains and explores the various parts of this idea in +more detail. + +@menu +* About Environments:: Names, locations, values and environments. +* Local Variables:: Local variables and local environments. +* Chaining:: Environment chaining. +* Lexical Scope:: The meaning of lexical scoping. +* Closure:: Explaining the concept of closure. +* Serial Number:: Example 1: a serial number generator. +* Shared Variable:: Example 2: a shared persistent variable. +* Callback Closure:: Example 3: the callback closure problem. +* OO Closure:: Example 4: object orientation. +@end menu + +@node About Environments +@subsection Names, Locations, Values and Environments + +@cindex location +@cindex environment +@cindex vcell +@cindex top level environment +@cindex environment, top level + +We said earlier that a variable name in a Scheme program is associated +with a location in which any kind of Scheme value may be stored. +(Incidentally, the term ``vcell'' is often used in Lisp and Scheme +circles as an alternative to ``location''.) Thus part of what we mean +when we talk about ``creating a variable'' is in fact establishing an +association between a name, or identifier, that is used by the Scheme +program code, and the variable location to which that name refers. +Although the value that is stored in that location may change, the +location to which a given name refers is always the same. + +We can illustrate this by breaking down the operation of the +@code{define} syntax into three parts: @code{define} + +@itemize @bullet +@item +creates a new location + +@item +establishes an association between that location and the name specified +as the first argument of the @code{define} expression + +@item +stores in that location the value obtained by evaluating the second +argument of the @code{define} expression. +@end itemize + +A collection of associations between names and locations is called an +@dfn{environment}. When you create a top level variable in a program +using @code{define}, the name-location association for that variable is +added to the ``top level'' environment. The ``top level'' environment +also includes name-location associations for all the procedures that are +supplied by standard Scheme. + +It is also possible to create environments other than the top level one, +and to create variable bindings, or name-location associations, in those +environments. This ability is a key ingredient in the concept of +closure; the next subsection shows how it is done. + + +@node Local Variables +@subsection Local Variables and Environments + +@cindex local variable +@cindex variable, local +@cindex local environment +@cindex environment, local + +We have seen how to create top level variables using the @code{define} +syntax (@pxref{Definition}). It is often useful to create variables +that are more limited in their scope, typically as part of a procedure +body. In Scheme, this is done using the @code{let} syntax, or one of +its modified forms @code{let*} and @code{letrec}. These syntaxes are +described in full later in the manual (REFFIXME). Here our purpose is +to illustrate their use just enough that we can see how local variables +work. + +For example, the following code uses a local variable @code{s} to +simplify the computation of the area of a triangle given the lengths of +its three sides. + +@lisp +(define a 5.3) +(define b 4.7) +(define c 2.8) + +(define area + (let ((s (/ (+ a b c) 2))) + (sqrt (* s (- s a) (- s b) (- s c))))) +@end lisp + +The effect of the @code{let} expression is to create a new environment +and, within this environment, an association between the name @code{s} +and a new location whose initial value is obtained by evaluating +@code{(/ (+ a b c) 2)}. The expressions in the body of the @code{let}, +namely @code{(sqrt (* s (- s a) (- s b) (- s c)))}, are then evaluated +in the context of the new environment, and the value of the last +expression evaluated becomes the value of the whole @code{let} +expression, and therefore the value of the variable @code{area}. + + +@node Chaining +@subsection Environment Chaining + +@cindex shadowing an imported variable binding +@cindex chaining environments + +In the example of the previous subsection, we glossed over an important +point. The body of the @code{let} expression in that example refers not +only to the local variable @code{s}, but also to the top level variables +@code{a}, @code{b}, @code{c} and @code{sqrt}. (@code{sqrt} is the +standard Scheme procedure for calculating a square root.) If the body +of the @code{let} expression is evaluated in the context of the +@emph{local} @code{let} environment, how does the evaluation get at the +values of these top level variables? + +The answer is that the local environment created by a @code{let} +expression automatically has a reference to its containing environment +--- in this case the top level environment --- and that the Scheme +interpreter automatically looks for a variable binding in the containing +environment if it doesn't find one in the local environment. More +generally, every environment except for the top level one has a +reference to its containing environment, and the interpreter keeps +searching back up the chain of environments --- from most local to top +level --- until it either finds a variable binding for the required +identifier or exhausts the chain. + +This description also determines what happens when there is more than +one variable binding with the same name. Suppose, continuing the +example of the previous subsection, that there was also a pre-existing +top level variable @code{s} created by the expression: + +@lisp +(define s "Some beans, my lord!") +@end lisp + +Then both the top level environment and the local @code{let} environment +would contain bindings for the name @code{s}. When evaluating code +within the @code{let} body, the interpreter looks first in the local +@code{let} environment, and so finds the binding for @code{s} created by +the @code{let} syntax. Even though this environment has a reference to +the top level environment, which also has a binding for @code{s}, the +interpreter doesn't get as far as looking there. When evaluating code +outside the @code{let} body, the interpreter looks up variable names in +the top level environment, so the name @code{s} refers to the top level +variable. + +Within the @code{let} body, the binding for @code{s} in the local +environment is said to @dfn{shadow} the binding for @code{s} in the top +level environment. + + +@node Lexical Scope +@subsection Lexical Scope + +The rules that we have just been describing are the details of how +Scheme implements ``lexical scoping''. This subsection takes a brief +diversion to explain what lexical scope means in general and to present +an example of non-lexical scoping. + +``Lexical scope'' in general is the idea that + +@itemize @bullet +@item +an identifier at a particular place in a program always refers to the +same variable location --- where ``always'' means ``every time that the +containing expression is executed'', and that + +@item +the variable location to which it refers can be determined by static +examination of the source code context in which that identifier appears, +without having to consider the flow of execution through the program as +a whole. +@end itemize + +In practice, lexical scoping is the norm for most programming languages, +and probably corresponds to what you would intuitively consider to be +``normal''. You may even be wondering how the situation could possibly +--- and usefully --- be otherwise. To demonstrate that another kind of +scoping is possible, therefore, and to compare it against lexical +scoping, the following subsection presents an example of non-lexical +scoping and examines in detail how its behavior differs from the +corresponding lexically scoped code. + +@menu +* Scoping Example:: An example of non-lexical scoping. +@end menu + + +@node Scoping Example +@subsubsection An Example of Non-Lexical Scoping + +To demonstrate that non-lexical scoping does exist and can be useful, we +present the following example from Emacs Lisp, which is a ``dynamically +scoped'' language. + +@lisp +(defvar currency-abbreviation "USD") + +(defun currency-string (units hundredths) + (concat currency-abbreviation + (number-to-string units) + "." + (number-to-string hundredths))) + +(defun french-currency-string (units hundredths) + (let ((currency-abbreviation "FRF")) + (currency-string units hundredths))) +@end lisp + +The question to focus on here is: what does the identifier +@code{currency-abbreviation} refer to in the @code{currency-string} +function? The answer, in Emacs Lisp, is that all variable bindings go +onto a single stack, and that @code{currency-abbreviation} refers to the +topmost binding from that stack which has the name +``currency-abbreviation''. The binding that is created by the +@code{defvar} form, to the value @code{"USD"}, is only relevant if none +of the code that calls @code{currency-string} rebinds the name +``currency-abbreviation'' in the meanwhile. + +The second function @code{french-currency-string} works precisely by +taking advantage of this behaviour. It creates a new binding for the +name ``currency-abbreviation'' which overrides the one established by +the @code{defvar} form. + +@lisp +;; Note! This is Emacs Lisp evaluation, not Scheme! +(french-currency-string 33 44) +@result{} +"FRF33.44" +@end lisp + +Now let's look at the corresponding, @emph{lexically scoped} Scheme +code: + +@lisp +(define currency-abbreviation "USD") + +(define (currency-string units hundredths) + (string-append currency-abbreviation + (number->string units) + "." + (number->string hundredths))) + +(define (french-currency-string units hundredths) + (let ((currency-abbreviation "FRF")) + (currency-string units hundredths))) +@end lisp + +According to the rules of lexical scoping, the +@code{currency-abbreviation} in @code{currency-string} refers to the +variable location in the innermost environment at that point in the code +which has a binding for @code{currency-abbreviation}, which is the +variable location in the top level environment created by the preceding +@code{(define currency-abbreviation @dots{})} expression. + +In Scheme, therefore, the @code{french-currency-string} procedure does +not work as intended. The variable binding that it creates for +``currency-abbreviation'' is purely local to the code that forms the +body of the @code{let} expression. Since this code doesn't directly use +the name ``currency-abbreviation'' at all, the binding is pointless. + +@lisp +(french-currency-string 33 44) +@result{} +"USD33.44" +@end lisp + +This begs the question of how the Emacs Lisp behaviour can be +implemented in Scheme. In general, this is a design question whose +answer depends upon the problem that is being addressed. In this case, +the best answer may be that @code{currency-string} should be +redesigned so that it can take an optional third argument. This third +argument, if supplied, is interpreted as a currency abbreviation that +overrides the default. + +It is possible to change @code{french-currency-string} so that it mostly +works without changing @code{currency-string}, but the fix is inelegant, +and susceptible to interrupts that could leave the +@code{currency-abbreviation} variable in the wrong state: + +@lisp +(define (french-currency-string units hundredths) + (set! currency-abbreviation "FRF") + (let ((result (currency-string units hundredths))) + (set! currency-abbreviation "USD") + result)) +@end lisp + +The key point here is that the code does not create any local binding +for the identifier @code{currency-abbreviation}, so all occurences of +this identifier refer to the top level variable. + + +@node Closure +@subsection Closure + +Consider a @code{let} expression that doesn't contain any +@code{lambda}s: + +@lisp +(let ((s (/ (+ a b c) 2))) + (sqrt (* s (- s a) (- s b) (- s c)))) +@end lisp + +@noindent +When the Scheme interpreter evaluates this, it + +@itemize @bullet +@item +creates a new environment with a reference to the environment that was +current when it encountered the @code{let} + +@item +creates a variable binding for @code{s} in the new environment, with +value given by @code{(/ (+ a b c) 2)} + +@item +evaluates the expression in the body of the @code{let} in the context of +the new local environment, and remembers the value @code{V} + +@item +forgets the local environment + +@item +continues evaluating the expression that contained the @code{let}, using +the value @code{V} as the value of the @code{let} expression, in the +context of the containing environment. +@end itemize + +After the @code{let} expression has been evaluated, the local +environment that was created is simply forgotten, and there is no longer +any way to access the binding that was created in this environment. If +the same code is evaluated again, it will follow the same steps again, +creating a second new local environment that has no connection with the +first, and then forgetting this one as well. + +If the @code{let} body contains a @code{lambda} expression, however, the +local environment is @emph{not} forgotten. Instead, it becomes +associated with the procedure that is created by the @code{lambda} +expression, and is reinstated every time that that procedure is called. +In detail, this works as follows. + +@itemize @bullet +@item +When the Scheme interpreter evaluates a @code{lambda} expression, to +create a procedure object, it stores the current environment as part of +the procedure definition. + +@item +Then, whenever that procedure is called, the interpreter reinstates the +environment that is stored in the procedure definition and evaluates the +procedure body within the context of that environment. +@end itemize + +The result is that the procedure body is always evaluated in the context +of the environment that was current when the procedure was created. + +This is what is meant by @dfn{closure}. The next few subsections +present examples that explore the usefulness of this concept. + + +@node Serial Number +@subsection Example 1: A Serial Number Generator + +This example uses closure to create a procedure with a variable binding +that is private to the procedure, like a local variable, but whose value +persists between procedure calls. + +@lisp +(define (make-serial-number-generator) + (let ((current-serial-number 0)) + (lambda () + (set! current-serial-number (+ current-serial-number 1)) + current-serial-number))) + +(define entry-sn-generator (make-serial-number-generator)) + +(entry-sn-generator) +@result{} +1 + +(entry-sn-generator) +@result{} +2 +@end lisp + +When @code{make-serial-number-generator} is called, it creates a local +environment with a binding for @code{current-serial-number} whose +initial value is 0, then, within this environment, creates a procedure. +The local environment is stored within the created procedure object and +so persists for the lifetime of the created procedure. + +Every time the created procedure is invoked, it increments the value of +the @code{current-serial-number} binding in the captured environment and +then returns the current value. + +Note that @code{make-serial-number-generator} can be called again to +create a second serial number generator that is independent of the +first. Every new invocation of @code{make-serial-number-generator} +creates a new local @code{let} environment and returns a new procedure +object with an association to this environment. + + +@node Shared Variable +@subsection Example 2: A Shared Persistent Variable + +This example uses closure to create two procedures, @code{get-balance} +and @code{deposit}, that both refer to the same captured local +environment so that they can both access the @code{balance} variable +binding inside that environment. The value of this variable binding +persists between calls to either procedure. + +Note that the captured @code{balance} variable binding is private to +these two procedures: it is not directly accessible to any other code. +It can only be accessed indirectly via @code{get-balance} or +@code{deposit}, as illustrated by the @code{withdraw} procedure. + +@lisp +(define get-balance #f) +(define deposit #f) + +(let ((balance 0)) + (set! get-balance + (lambda () + balance)) + (set! deposit + (lambda (amount) + (set! balance (+ balance amount)) + balance))) + +(define (withdraw amount) + (deposit (- amount))) + +(get-balance) +@result{} +0 + +(deposit 50) +@result{} +50 + +(withdraw 75) +@result{} +-25 +@end lisp + +A detail here is that the @code{get-balance} and @code{deposit} +variables must be set up by @code{define}ing them at top level and then +@code{set!}ing their values inside the @code{let} body. Using +@code{define} within the @code{let} body would not work: this would +create variable bindings within the local @code{let} environment that +would not be accessible at top level. + + +@node Callback Closure +@subsection Example 3: The Callback Closure Problem + +A frequently used programming model for library code is to allow an +application to register a callback function for the library to call when +some particular event occurs. It is often useful for the application to +make several such registrations using the same callback function, for +example if several similar library events can be handled using the same +application code, but the need then arises to distinguish the callback +function calls that are associated with one callback registration from +those that are associated with different callback registrations. + +In languages without the ability to create functions dynamically, this +problem is usually solved by passing a @code{user_data} parameter on the +registration call, and including the value of this parameter as one of +the parameters on the callback function. Here is an example of +declarations using this solution in C: + +@example +typedef void (event_handler_t) (int event_type, + void *user_data); + +void register_callback (int event_type, + event_handler_t *handler, + void *user_data); +@end example + +In Scheme, closure can be used to achieve the same functionality without +requiring the library code to store a @code{user-data} for each callback +registration. + +@lisp +;; In the library: + +(define (register-callback event-type handler-proc) + @dots{}) + +;; In the application: + +(define (make-handler event-type user-data) + (lambda () + @dots{} + + @dots{})) + +(register-callback event-type + (make-handler event-type @dots{})) +@end lisp + +As far as the library is concerned, @code{handler-proc} is a procedure +with no arguments, and all the library has to do is call it when the +appropriate event occurs. From the application's point of view, though, +the handler procedure has used closure to capture an environment that +includes all the context that the handler code needs --- +@code{event-type} and @code{user-data} --- to handle the event +correctly. + + +@node OO Closure +@subsection Example 4: Object Orientation + +Closure is the capture of an environment, containing persistent variable +bindings, within the definition of a procedure or a set of related +procedures. This is rather similar to the idea in some object oriented +languages of encapsulating a set of related data variables inside an +``object'', together with a set of ``methods'' that operate on the +encapsulated data. The following example shows how closure can be used +to emulate the ideas of objects, methods and encapsulation in Scheme. + +@lisp +(define (make-account) + (let ((balance 0)) + (define (get-balance) + balance) + (define (deposit amount) + (set! balance (+ balance amount)) + balance) + (define (withdraw amount) + (deposit (- amount))) + + (lambda args + (apply + (case (car args) + ((get-balance) get-balance) + ((deposit) deposit) + ((withdraw) withdraw) + (else (error "Invalid method!"))) + (cdr args))))) +@end lisp + +Each call to @code{make-account} creates and returns a new procedure, +created by the expression in the example code that begins ``(lambda +args''. + +@lisp +(define my-account (make-account)) + +my-account +@result{} +# +@end lisp + +This procedure acts as an account object with methods +@code{get-balance}, @code{deposit} and @code{withdraw}. To apply one of +the methods to the account, you call the procedure with a symbol +indicating the required method as the first parameter, followed by any +other parameters that are required by that method. + +@lisp +(my-account 'get-balance) +@result{} +0 + +(my-account 'withdraw 5) +@result{} +-5 + +(my-account 'deposit 396) +@result{} +391 + +(my-account 'get-balance) +@result{} +391 +@end lisp + +Note how, in this example, both the current balance and the helper +procedures @code{get-balance}, @code{deposit} and @code{withdraw}, used +to implement the guts of the account object's methods, are all stored in +variable bindings within the private local environment captured by the +@code{lambda} expression that creates the account object procedure. + + +@c Local Variables: +@c TeX-master: "guile.texi" +@c End: diff --git a/doc/scheme-indices.texi b/doc/scheme-indices.texi new file mode 100644 index 000000000..6e676143b --- /dev/null +++ b/doc/scheme-indices.texi @@ -0,0 +1,17 @@ +@page +@node R5RS Index +@chapter R5RS Index + +@printindex r5 + + +@page +@node Guile Extensions Index +@chapter Guile Extensions Index + +@printindex ge + + +@c Local Variables: +@c TeX-master: "guile.texi" +@c End: diff --git a/doc/scheme-intro.texi b/doc/scheme-intro.texi new file mode 100644 index 000000000..e69de29bb diff --git a/doc/scheme-io.texi b/doc/scheme-io.texi new file mode 100644 index 000000000..a3de2f1a8 --- /dev/null +++ b/doc/scheme-io.texi @@ -0,0 +1,762 @@ +@page +@node Input and Output +@chapter Input and Output + +@menu +* Ports:: The idea of the port abstraction. +* Reading:: Procedures for reading from a port. +* Writing:: Procedures for writing to a port. +* Closing:: Procedures to close a port. +* Random Access:: Moving around a random access port. +* Line/Delimited:: Read and write lines or delimited text. +* Binary IO:: Save and restore Scheme objects. +* Default Ports:: Defaults for input, output and errors. +* Port Types:: Types of port and how to make them. +@end menu + + +@node Ports +@section Ports + +[Concept of the port abstraction.] + +Sequential input/output in Scheme is represented by operations on a +@dfn{port}. Characters can be read from an input port and +written to an output port. This chapter explains the operations +that Guile provides for working with ports. + +The formal definition of a port is very generic: an input port is +simply ``an object which can deliver characters on command,'' and +an output port is ``an object which can accept characters.'' +Because this definition is so loose, it is easy to write functions +that simulate ports in software. @dfn{Soft ports} and @dfn{string +ports} are two interesting and powerful examples of this technique. + +@c docstring begin (texi-doc-string "guile" "input-port?") +@deffn primitive input-port? x +Returns @code{#t} if @var{x} is an input port, otherwise returns +@code{#f}. Any object satisfying this predicate also satisfies +@code{port?}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "output-port?") +@deffn primitive output-port? x +Returns @code{#t} if @var{x} is an output port, otherwise returns +@code{#f}. Any object satisfying this predicate also satisfies +@code{port?}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "port?") +@deffn primitive port? x +Returns a boolean indicating whether @var{x} is a port. +Equivalent to @code{(or (input-port? X) (output-port? X))}. +@end deffn + + +@node Reading +@section Reading + +[Generic procedures for reading from ports.] + +@c docstring begin (texi-doc-string "guile" "eof-object?") +@deffn primitive eof-object? x +Returns @code{#t} if @var{x} is an end-of-file object; otherwise +returns @code{#f}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "char-ready?") +@deffn primitive char-ready? [port] +Returns @code{#t} if a character is ready on input @var{port} and +returns @code{#f} otherwise. If @code{char-ready?} returns @code{#t} +then the next @code{read-char} operation on @var{port} is +guaranteed not to hang. If @var{port} is a file port at end of +file then @code{char-ready?} returns @code{#t}. +@footnote{@code{char-ready?} exists to make it possible for a +program to accept characters from interactive ports without getting +stuck waiting for input. Any input editors associated with such ports +must make sure that characters whose existence has been asserted by +@code{char-ready?} cannot be rubbed out. If @code{char-ready?} were to +return @code{#f} at end of file, a port at end of file would be +indistinguishable from an interactive port that has no ready +characters.} +@end deffn + +@c docstring begin (texi-doc-string "guile" "read-char") +@deffn primitive read-char [port] +Returns the next character available from @var{port}, updating +@var{port} to point to the following character. If no more +characters are available, an end-of-file object is returned. +@end deffn + +@c docstring begin (texi-doc-string "guile" "peek-char") +@deffn primitive peek-char [port] +Returns the next character available from @var{port}, +@emph{without} updating @var{port} to point to the following +character. If no more characters are available, an end-of-file object +is returned.@footnote{The value returned by a call to @code{peek-char} +is the same as the value that would have been returned by a call to +@code{read-char} on the same port. The only difference is that the very +next call to @code{read-char} or @code{peek-char} on that +@var{port} will return the value returned by the preceding call to +@code{peek-char}. In particular, a call to @code{peek-char} on an +interactive port will hang waiting for input whenever a call to +@code{read-char} would have hung.} +@end deffn + +@c docstring begin (texi-doc-string "guile" "unread-char") +@deffn primitive unread-char cobj port +Place @var{char} in @var{port} so that it will be read by the +next read operation. If called multiple times, the unread characters +will be read again in last-in first-out order. If @var{port} is +not supplied, the current input port is used. +@end deffn + +@c docstring begin (texi-doc-string "guile" "unread-string") +@deffn primitive unread-string str port +Place the string @var{str} in @var{port} so that its characters will be +read in subsequent read operations. If called multiple times, the +unread characters will be read again in last-in first-out order. If +@var{port} is not supplied, the current-input-port is used. +@end deffn + +@c docstring begin (texi-doc-string "guile" "drain-input") +@deffn primitive drain-input port +Drain @var{port}'s read buffers (including any pushed-back +characters) and returns the content as a single string. +@end deffn + +@c ARGFIXME port/input-port +@c docstring begin (texi-doc-string "guile" "port-column") +@c docstring begin (texi-doc-string "guile" "port-line") +@deffn primitive port-column port +@deffnx primitive port-line [input-port] +Return the current column number or line number of @var{input-port}, +using the current input port if none is specified. 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 +message, we recommand you add 1 to get 1-origin integers. This is +because lines and column numbers traditionally start with 1, and that is +what non-programmers will find most natural.) +@end deffn + +@c ARGFIXME port/input-port +@c docstring begin (texi-doc-string "guile" "set-port-column!") +@c docstring begin (texi-doc-string "guile" "set-port-line!") +@deffn primitive set-port-column! port column +@deffnx primitive set-port-line! port line +Set the current column or line number of @var{port}, using the +current input port if none is specified. +@end deffn + +@deffn primitive read-string!/partial str [port_or_fdes [start [end]]] +Read characters from an fport or file descriptor into a +string @var{str}. This procedure is scsh-compatible +and can efficiently read large strings. It will: + +@itemize +@item +attempt to fill the entire string, unless the @var{start} +and/or @var{end} arguments are supplied. i.e., @var{start} +defaults to 0 and @var{end} defaults to +@code{(string-length str)} +@item +use the current input port if @var{port_or_fdes} is not +supplied. +@item +read any characters that are currently available, +without waiting for the rest (short reads are possible). + +@item +wait for as long as it needs to for the first character to +become available, unless the port is in non-blocking mode +@item +return @code{#f} if end-of-file is encountered before reading +any characters, otherwise return the number of characters +read. +@item +return 0 if the port is in non-blocking mode and no characters +are immediately available. +@item +return 0 if the request is for 0 bytes, with no +end-of-file check +@end itemize +@end deffn + + +@node Writing +@section Writing + +[Generic procedures for writing to ports.] + +@c docstring begin (texi-doc-string "guile" "get-print-state") +@deffn primitive get-print-state port +Return the print state of the port @var{port}. If @var{port} +has no associated print state, @code{#f} is returned. +@end deffn + +@c docstring begin (texi-doc-string "guile" "newline") +@deffn primitive newline [port] +Send a newline to @var{port}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "port-with-print-state") +@deffn primitive port-with-print-state port pstate +Create a new port which behaves like @var{port}, but with an +included print state @var{pstate}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "print-options-interface") +@deffn primitive print-options-interface [setting] +Option interface for the print options. Instead of using +this procedure directly, use the procedures @code{print-enable}, +@code{print-disable}, @code{print-set!} and @var{print-options}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "simple-format") +@deffn primitive simple-format destination message . args +Write @var{message} to @var{destination}, defaulting to +the current output port. +@var{message} can contain @code{~A} (was @code{%s}) and +@code{~S} (was @code{%S}) escapes. When printed, +the escapes are replaced with corresponding members of +@var{ARGS}: +@code{~A} formats using @code{display} and @code{~S} formats +using @code{write}. +If @var{destination} is @code{#t}, then use the current output +port, if @var{destination} is @code{#f}, then return a string +containing the formatted text. Does not add a trailing newline. +@end deffn + +@c docstring begin (texi-doc-string "guile" "write-char") +@deffn primitive write-char chr [port] +Send character @var{chr} to @var{port}. +@end deffn + +@findex fflush +@c docstring begin (texi-doc-string "guile" "force-output") +@deffn primitive force-output [port] +Flush the specified output port, or the current output port if @var{port} +is omitted. The current output buffer contents are passed to the +underlying port implementation (e.g., in the case of fports, the +data will be written to the file and the output buffer will be cleared.) +It has no effect on an unbuffered port. + +The return value is unspecified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "flush-all-ports") +@deffn primitive flush-all-ports +Equivalent to calling @code{force-output} on +all open output ports. The return value is unspecified. +@end deffn + + +@node Closing +@section Closing + +@c docstring begin (texi-doc-string "guile" "close-port") +@deffn primitive close-port port +Close the specified port object. Returns @code{#t} if it successfully +closes a port or @code{#f} if it was already +closed. An exception may be raised if an error occurs, for example +when flushing buffered output. +See also @ref{Ports and File Descriptors, close}, for a procedure +which can close file descriptors. +@end deffn + +@c docstring begin (texi-doc-string "guile" "close-input-port") +@deffn primitive close-input-port port +Close the specified input port object. The routine has no effect if +the file has already been closed. An exception may be raised if an +error occurs. The value returned is unspecified. + +See also @ref{Ports and File Descriptors, close}, for a procedure +which can close file descriptors. +@end deffn + +@c docstring begin (texi-doc-string "guile" "close-output-port") +@deffn primitive close-output-port port +Close the specified output port object. The routine has no effect if +the file has already been closed. An exception may be raised if an +error occurs. The value returned is unspecified. + +See also @ref{Ports and File Descriptors, close}, for a procedure +which can close file descriptors. +@end deffn + +@c docstring begin (texi-doc-string "guile" "port-closed?") +@deffn primitive port-closed? port +Returns @code{#t} if @var{port} is closed or @code{#f} if it is open. +@end deffn + + +@node Random Access +@section Random Access + +@c ARGFIXME object/fd/port +@c docstring begin (texi-doc-string "guile" "seek") +@deffn primitive seek object offset whence +Sets the current position of @var{fd/port} to the integer @var{offset}, +which is interpreted according to the value of @var{whence}. + +One of the following variables should be supplied +for @var{whence}: +@defvar SEEK_SET +Seek from the beginning of the file. +@end defvar +@defvar SEEK_CUR +Seek from the current position. +@end defvar +@defvar SEEK_END +Seek from the end of the file. +@end defvar + +If @var{fd/port} is a file descriptor, the underlying system call is +@code{lseek}. @var{port} may be a string port. + +The value returned is the new position in the file. This means that +the current position of a port can be obtained using: +@smalllisp +(seek port 0 SEEK_CUR) +@end smalllisp +@end deffn + +@c ARGFIXME object/fd/port +@c docstring begin (texi-doc-string "guile" "fseek") +@deffn primitive fseek object offset whence +Obsolete. Almost the same as seek, above, but the return value is +unspecified. +@end deffn + +@c ARGFIXME object/fd/port +@c docstring begin (texi-doc-string "guile" "ftell") +@deffn primitive ftell object +Returns an integer representing the current position of @var{fd/port}, +measured from the beginning. Equivalent to: +@smalllisp +(seek port 0 SEEK_CUR) +@end smalllisp +@end deffn + +@findex truncate +@findex ftruncate +@c ARGFIXME obj/object size/length +@c docstring begin (texi-doc-string "guile" "truncate-file") +@deffn primitive truncate-file object [length] +Truncates the object referred to by @var{obj} to at most @var{size} bytes. +@var{obj} can be a string containing a file name or an integer file +descriptor or a port. @var{size} may be omitted if @var{obj} is not +a file name, in which case the truncation occurs at the current port. +position. + +The return value is unspecified. +@end deffn + + +@node Line/Delimited +@section Handling Line Oriented and Delimited Text + +[Line-oriented and delimited IO. Or should this be merged into the +previous two sections?] + +Extended I/O procedures are available which read or write lines of text +or read text delimited by a specified set of characters. + +@findex fwrite +@findex fread +Interfaces to @code{read}/@code{fread} and @code{write}/@code{fwrite} are +also available, as @code{uniform-array-read!} and @code{uniform-array-write!}, +@ref{Uniform Arrays}. + +@c begin (scm-doc-string "boot-9.scm" "read-line") +@deffn procedure read-line [port] [handle-delim] +Return a line of text from @var{port} if specified, otherwise from the +value returned by @code{(current-input-port)}. Under Unix, a line of text +is terminated by the first end-of-line character or by end-of-file. + +If @var{handle-delim} is specified, it should be one of the following +symbols: +@table @code +@item trim +Discard the terminating delimiter. This is the default, but it will +be impossible to tell whether the read terminated with a delimiter or +end-of-file. +@item concat +Append the terminating delimiter (if any) to the returned string. +@item peek +Push the terminating delimiter (if any) back on to the port. +@item split +Return a pair containing the string read from the port and the +terminating delimiter or end-of-file object. + +NOTE: if the scsh module is loaded then +multiple values are returned instead of a pair. +@end table +@end deffn + +@c begin (scm-doc-string "boot-9.scm" "read-line!") +@deffn procedure read-line! buf [port] +Read a line of text into the supplied string @var{buf} and return the +number of characters added to @var{buf}. If @var{buf} is filled, then +@code{#f} is returned. +Read from @var{port} if +specified, otherwise from the value returned by @code{(current-input-port)}. +@end deffn + +@c begin (scm-doc-string "boot-9.scm" "read-delimited") +@deffn procedure read-delimited delims [port] [handle-delim] +Read text until one of the characters in the string @var{delims} is found +or end-of-file is reached. Read from @var{port} if supplied, otherwise +from the value returned by @code{(current-input-port)}. +@var{handle-delim} takes the same values as described for @code{read-line}. + +NOTE: if the scsh module is loaded then @var{delims} must be an scsh +char-set, not a string. +@end deffn + +@c begin (scm-doc-string "boot-9.scm" "read-delimited!") +@deffn procedure read-delimited! delims buf [port] [handle-delim] [start] [end] +Read text into the supplied string @var{buf} and return the number of +characters added to @var{buf} (subject to @var{handle-delim}, which takes +the same values specified for @code{read-line}. If @var{buf} is filled, +@code{#f} is returned for both the number of characters read and the +delimiter. Also terminates if one of the characters in the string +@var{delims} is found +or end-of-file is reached. Read from @var{port} if supplied, otherwise +from the value returned by @code{(current-input-port)}. + +NOTE: if the scsh module is loaded then @var{delims} must be an scsh +char-set, not a string. +@end deffn + +@c docstring begin (texi-doc-string "guile" "write-line") +@deffn primitive write-line obj [port] +Display @var{obj} and a newline character to @var{port}. If @var{port} +is not specified, @code{(current-output-port)} is used. This function +is equivalent to: + +@smalllisp +(display obj [port]) +(newline [port]) +@end smalllisp +@end deffn + +Some of the abovementioned I/O functions rely on the following C +primitives. These will mainly be of interest to people hacking Guile +internals. + +@c ARGFIXME gobble/gobble? +@c docstring begin (texi-doc-string "guile" "%read-delimited!") +@deffn primitive %read-delimited! delims str gobble [port [start [end]]] +Read characters from @var{port} into @var{str} until one of the +characters in the @var{delims} string is encountered. If @var{gobble} +is true, discard the delimiter character; otherwise, leave it +in the input stream for the next read. +If @var{port} is not specified, use the value of +@code{(current-input-port)}. If @var{start} or @var{end} are specified, +store data only into the substring of @var{str} bounded by @var{start} +and @var{end} (which default to the beginning and end of the string, +respectively). + +Return a pair consisting of the delimiter that terminated the string and +the number of characters read. If reading stopped at the end of file, +the delimiter returned is the @var{eof-object}; if the string was filled +without encountering a delimiter, this value is @var{#f}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "%read-line") +@deffn primitive %read-line [port] +Read a newline-terminated line from @var{port}, allocating storage as +necessary. The newline terminator (if any) is removed from the string, +and a pair consisting of the line and its delimiter is returned. The +delimiter may be either a newline or the @var{eof-object}; if +@code{%read-line} is called at the end of file, it returns the pair +@code{(# . #)}. +@end deffn + +@node Binary IO +@section Saving and Restoring Scheme Objects + +@deffn primitive binary-read [port] +Read and return an object from @var{port} in a binary format. +If omitted, @var{port} defaults to the current output port. +@end deffn + +@deffn primitive binary-write obj [port] +Write @var{obj} to @var{port} in a binary format. +If omitted, @var{port} defaults to the current output port. +@end deffn + + +@node Default Ports +@section Default Ports for Input, Output and Errors + +@c docstring begin (texi-doc-string "guile" "current-input-port") +@deffn primitive current-input-port +Return the current input port. This is the default port used +by many input procedures. Initially, @code{current-input-port} +returns the @dfn{standard input} in Unix and C terminology. +@end deffn + +@c docstring begin (texi-doc-string "guile" "current-output-port") +@deffn primitive current-output-port +Return the current output port. This is the default port used +by many output procedures. Initially, +@code{current-output-port} returns the @dfn{standard output} in +Unix and C terminology. +@end deffn + +@c docstring begin (texi-doc-string "guile" "current-error-port") +@deffn primitive current-error-port +Return the port to which errors and warnings should be sent (the +@dfn{standard error} in Unix and C terminology). +@end deffn + +@c docstring begin (texi-doc-string "guile" "set-current-input-port") +@deffn primitive set-current-input-port port +@deffnx primitive set-current-output-port port +@deffnx primitive set-current-error-port port +Change the ports returned by @code{current-input-port}, +@code{current-output-port} and @code{current-error-port}, respectively, +so that they use the supplied @var{port} for input or output. +@end deffn + +@c docstring begin (texi-doc-string "guile" "set-current-output-port") +@deffn primitive set-current-output-port port +Set the current default output port to PORT. +@end deffn + +@c docstring begin (texi-doc-string "guile" "set-current-error-port") +@deffn primitive set-current-error-port port +Set the current default error port to PORT. +@end deffn + + +@node Port Types +@section Types of Port + +[Types of port; how to make them.] + +@menu +* File Ports:: Ports on an operating system file. +* String Ports:: Ports on a Scheme string. +* Soft Ports:: Ports on arbitrary Scheme procedures. +* Void Ports:: Ports on nothing at all. +@end menu + + +@node File Ports +@subsection File Ports + +The following procedures are used to open file ports. +See also @ref{Ports and File Descriptors, open}, for an interface +to the Unix @code{open} system call. + +@c ARGFIXME string/filename mode/modes +@c docstring begin (texi-doc-string "guile" "open-file") +@deffn primitive open-file filename modes +Open the file whose name is @var{string}, and return a port +representing that file. The attributes of the port are +determined by the @var{mode} string. The way in +which this is interpreted is similar to C stdio: + +The first character must be one of the following: + +@table @samp +@item r +Open an existing file for input. +@item w +Open a file for output, creating it if it doesn't already exist +or removing its contents if it does. +@item a +Open a file for output, creating it if it doesn't already exist. +All writes to the port will go to the end of the file. +The "append mode" can be turned off while the port is in use +@pxref{Ports and File Descriptors, fcntl} +@end table + +The following additional characters can be appended: + +@table @samp +@item + +Open the port for both input and output. E.g., @code{r+}: open +an existing file for both input and output. +@item 0 +Create an "unbuffered" port. In this case input and output operations +are passed directly to the underlying port implementation without +additional buffering. This is likely to slow down I/O operations. +The buffering mode can be changed while a port is in use +@pxref{Ports and File Descriptors, setvbuf} +@item l +Add line-buffering to the port. The port output buffer will be +automatically flushed whenever a newline character is written. +@end table + +In theory we could create read/write ports which were buffered in one +direction only. However this isn't included in the current interfaces. + +If a file cannot be opened with the access requested, +@code{open-file} throws an exception. +@end deffn + +@c begin (scm-doc-string "r4rs.scm" "open-input-file") +@deffn procedure open-input-file filename +Open @var{filename} for input. Equivalent to +@smalllisp +(open-file @var{filename} "r") +@end smalllisp +@end deffn + +@c begin (scm-doc-string "r4rs.scm" "open-output-file") +@deffn procedure open-output-file filename +Open @var{filename} for output. Equivalent to +@smalllisp +(open-file @var{filename} "w") +@end smalllisp +@end deffn + +@c docstring begin (texi-doc-string "guile" "port-mode") +@deffn primitive port-mode port +Returns the port modes associated with the open port @var{port}. These +will not necessarily be identical to the modes used when the port was +opened, since modes such as "append" which are used only during +port creation are not retained. +@end deffn + +@c docstring begin (texi-doc-string "guile" "port-filename") +@deffn primitive port-filename port +Return the filename associated with @var{port}. This function returns +the strings "standard input", "standard output" and "standard error" +when called on the current input, output and error ports respectively. +@end deffn + +@c docstring begin (texi-doc-string "guile" "set-port-filename!") +@deffn primitive set-port-filename! port filename +Change the filename associated with @var{port}, using the current input +port if none is specified. Note that this does not change the port's +source of data, but only the value that is returned by +@code{port-filename} and reported in diagnostic output. +@end deffn + +@deffn primitive file-port? obj +Determine whether @var{obj} is a port that is related to a file. +@end deffn + + +@node String Ports +@subsection String Ports + +The following allow string ports to be opened by analogy to R4R* +file port facilities: + +@c docstring begin (texi-doc-string "guile" "call-with-output-string") +@deffn primitive call-with-output-string proc +Calls the one-argument procedure @var{proc} with a newly created output +port. When the function returns, the string composed of the characters +written into the port is returned. +@end deffn + +@c ARGFIXME str/string +@c docstring begin (texi-doc-string "guile" "call-with-input-string") +@deffn primitive call-with-input-string str proc +Calls the one-argument procedure @var{proc} with a newly created input +port from which @var{string}'s contents may be read. The value yielded +by the @var{proc} is returned. +@end deffn + +@c begin (scm-doc-string "r4rs.scm" "with-output-to-string") +@deffn procedure with-output-to-string thunk +Calls the zero-argument procedure @var{thunk} with the current output +port set temporarily to a new string port. It returns a string +composed of the characters written to the current output. +@end deffn + +@c begin (scm-doc-string "r4rs.scm" "with-input-from-string") +@deffn procedure with-input-from-string string thunk +Calls the zero-argument procedure @var{thunk} with the current input +port set temporarily to a string port opened on the specified +@var{string}. The value yielded by @var{thunk} is returned. +@end deffn + +A string port can be used in many procedures which accept a port +but which are not dependent on implementation details of fports. +E.g., seeking and truncating will work on a string port, +but trying to extract the file descriptor number will fail. + +At present there isn't a procedure that simply returns a new string +port. There's also no way of opening read/write string ports from +Scheme even though it's possible from C. SRFI 6 could be implemented +without much difficulty. + + +@node Soft Ports +@subsection Soft Ports + +A @dfn{soft-port} is a port based on a vector of procedures capable of +accepting or delivering characters. It allows emulation of I/O ports. + +@c ARGFIXME pv/vector +@c docstring begin (texi-doc-string "guile" "make-soft-port") +@deffn primitive make-soft-port pv modes +Returns a port capable of receiving or delivering characters as +specified by the @var{modes} string (@pxref{File Ports, +open-file}). @var{vector} must be a vector of length 6. Its components +are as follows: + +@enumerate 0 +@item +procedure accepting one character for output +@item +procedure accepting a string for output +@item +thunk for flushing output +@item +thunk for getting one character +@item +thunk for closing port (not by garbage collection) +@end enumerate + +For an output-only port only elements 0, 1, 2, and 4 need be +procedures. For an input-only port only elements 3 and 4 need be +procedures. Thunks 2 and 4 can instead be @code{#f} if there is no useful +operation for them to perform. + +If thunk 3 returns @code{#f} or an @code{eof-object} (@pxref{Input, +eof-object?, ,r4rs, The Revised^4 Report on Scheme}) it indicates that +the port has reached end-of-file. For example: + +@example +(define stdout (current-output-port)) +(define p (make-soft-port + (vector + (lambda (c) (write c stdout)) + (lambda (s) (display s stdout)) + (lambda () (display "." stdout)) + (lambda () (char-upcase (read-char))) + (lambda () (display "@@" stdout))) + "rw")) + +(write p p) @result{} # +@end example +@end deffn + + +@node Void Ports +@subsection Void Ports + +This kind of port just causes errors if you try to use it in +a normal way. + +@c docstring begin (texi-doc-string "guile" "%make-void-port") +@deffn primitive %make-void-port mode +Create and return a new void port. A void port acts like +/dev/null. The @var{mode} argument +specifies the input/output modes for this port: see the +documentation for @code{open-file} in @ref{File Ports}. +@end deffn + + +@c Local Variables: +@c TeX-master: "guile.texi" +@c End: diff --git a/doc/scheme-memory.texi b/doc/scheme-memory.texi new file mode 100644 index 000000000..54ee5dfec --- /dev/null +++ b/doc/scheme-memory.texi @@ -0,0 +1,244 @@ +@page +@node Memory Management +@chapter Memory Management and Garbage Collection + +@menu +* Garbage Collection:: +* Weak References:: +* Guardians:: +@end menu + + +@node Garbage Collection +@section Garbage Collection + +[FIXME: this is pasted in from Tom Lord's original guile.texi and should +be reviewed] + +@c docstring begin (texi-doc-string "guile" "gc") +@deffn primitive gc +Scans all of SCM objects and reclaims for further use those that are +no longer accessible. +@end deffn + +@c docstring begin (texi-doc-string "guile" "gc-stats") +@deffn primitive gc-stats +Returns an association list of statistics about Guile's current use of storage. +@end deffn + +@c docstring begin (texi-doc-string "guile" "object-address") +@deffn primitive object-address obj +Return an integer that for the lifetime of @var{obj} is uniquely +returned by this function for @var{obj} +@end deffn + +@c docstring begin (texi-doc-string "guile" "unhash-name") +@deffn primitive unhash-name name +Flushes the glocs for @var{name}, or all glocs if @var{name} +is @code{#t}. +@end deffn + + +@node Weak References +@section Weak References + +[FIXME: This chapter is based on Mikael Djurfeldt's answer to a question +by Michael Livshin. Any mistakes are not theirs, of course. ] + +Weak references let you attach bookkeeping information to data so that +the additional information automatically disappears when the original +data is no longer in use and gets garbage collected. In a weak key hash, +the hash entry for that key disappears as soon as the key is no longer +referneced from anywhere else. For weak value hashes, the same happens +as soon as the value is no longer in use. Entries in a doubly weak hash +disappear when either the key or the value are not used anywhere else +anymore. + +Property lists offer the same kind of functionality as weak key hashes +in many situations. (@pxref{Property Lists}) + +Here's an example (a little bit strained perhaps, but one of the +examples is actually used in Guile): + +Assume that you're implementing a debugging system where you want to +associate information about filename and position of source code +expressions with the expressions themselves. + +Hashtables can be used for that, but if you use ordinary hash tables +it will be impossible for the scheme interpreter to "forget" old +source when, for example, a file is reloaded. + +To implement the mapping from source code expressions to positional +information it is necessary to use weak-key tables since we don't want +the expressions to be remembered just because they are in our table. + +To implement a mapping from source file line numbers to source code +expressions you would use a weak-value table. + +To implement a mapping from source code expressions to the procedures +they constitute a doubly-weak table has to be used. + +@menu +* Weak key hashes:: +* Weak vectors:: +@end menu + + +@node Weak key hashes +@subsection Weak key hashes + +@c ARGFIXME k/size +@c docstring begin (texi-doc-string "guile" "make-weak-key-hash-table") +@deffn primitive make-weak-key-hash-table k +@deffnx primitive make-weak-value-hash-table size +@deffnx primitive make-doubly-weak-hash-table size +Return a weak hash table with @var{size} buckets. As with any hash +table, choosing a good size for the table requires some caution. + +You can modify weak hash tables in exactly the same way you would modify +regular hash tables. (@pxref{Hash Tables}) +@end deffn + +@c ARGFIXME x/obj +@c docstring begin (texi-doc-string "guile" "weak-key-hash-table?") +@deffn primitive weak-key-hash-table? x +@deffnx primitive weak-value-hash-table? obj +@deffnx primitive doubly-weak-hash-table? obj +Return @var{#t} if @var{obj} is the specified weak hash table. Note +that a doubly weak hash table is neither a weak key nor a weak value +hash table. +@end deffn + +@c docstring begin (texi-doc-string "guile" "make-weak-value-hash-table") +@deffn primitive make-weak-value-hash-table k +@end deffn + +@c docstring begin (texi-doc-string "guile" "weak-value-hash-table?") +@deffn primitive weak-value-hash-table? x +@end deffn + +@c docstring begin (texi-doc-string "guile" "make-doubly-weak-hash-table") +@deffn primitive make-doubly-weak-hash-table k +@end deffn + +@c docstring begin (texi-doc-string "guile" "doubly-weak-hash-table?") +@deffn primitive doubly-weak-hash-table? x +@end deffn + + +@node Weak vectors +@subsection Weak vectors + +Weak vectors are mainly useful in Guile's implementation of weak hash +tables. + +@c ARGFIXME k/size +@c docstring begin (texi-doc-string "guile" "make-weak-vector") +@deffn primitive make-weak-vector k [fill] +Return a weak vector with @var{size} elements. If the optional +argument @var{fill} is given, all entries in the vector will be set to +@var{fill}. The default value for @var{fill} is the empty list. +@end deffn + +@c NJFIXME should vector->list here be list->vector ? +@c docstring begin (texi-doc-string "guile" "weak-vector") +@c docstring begin (texi-doc-string "guile" "list->weak-vector") +@deffn primitive weak-vector . l +@deffnx primitive list->weak-vector l +Construct a weak vector from a list: @code{weak-vector} uses the list of +its arguments while @code{list->weak-vector} uses its only argument +@var{l} (a list) to construct a weak vector the same way +@code{vector->list} would. +@end deffn + +@c ARGFIXME x/obj +@c docstring begin (texi-doc-string "guile" "weak-vector?") +@deffn primitive weak-vector? x +Return @var{#t} if @var{obj} is a weak vector. Note that all weak +hashes are also weak vectors. +@end deffn + + +@node Guardians +@section Guardians + +@c docstring begin (texi-doc-string "guile" "make-guardian") +@deffn primitive make-guardian [greedy?] +Create a new guardian. +A guardian protects a set of objects from garbage collection, +allowing a program to apply cleanup or other actions. + +@code{make-guardian} returns a procedure representing the guardian. +Calling the guardian procedure with an argument adds the +argument to the guardian's set of protected objects. +Calling the guardian procedure without an argument returns +one of the protected objects which are ready for garbage +collection, or @code{#f} if no such object is available. +Objects which are returned in this way are removed from +the guardian. + +@code{make-guardian} takes one optional argument that says whether the +new guardian should be greedy or sharing. If there is any chance +that any object protected by the guardian may be resurrected, +then you should make the guardian greedy (this is the default). + +See R. Kent Dybvig, Carl Bruggeman, and David Eby (1993) +"Guardians in a Generation-Based Garbage Collector". +ACM SIGPLAN Conference on Programming Language Design +and Implementation, June 1993. + +(the semantics are slightly different at this point, but the +paper still (mostly) accurately describes the interface). +@end deffn + +@deffn primitive destroy-guardian! guardian +Destroys @var{guardian}, by making it impossible to put any more +objects in it or get any objects from it. It also unguards any +objects guarded by @var{guardian}. +@end deffn + +@deffn primitive guardian-greedy? guardian +Return @code{#t} if @var{guardian} is a greedy guardian, otherwise @code{#f}. +@end deffn + +@deffn primitive guardian-destroyed? guardian +Return @code{#t} if @var{guardian} has been destroyed, otherwise @code{#f}. +@end deffn + + +@page +@node Objects +@chapter Objects + +@c docstring begin (texi-doc-string "guile" "entity?") +@deffn primitive entity? obj +Return @code{#t} if @var{obj} is an entity. +@end deffn + +@c docstring begin (texi-doc-string "guile" "operator?") +@deffn primitive operator? obj +Return @code{#t} if @var{obj} is an operator. +@end deffn + +@c docstring begin (texi-doc-string "guile" "set-object-procedure!") +@deffn primitive set-object-procedure! obj proc +Return the object procedure of @var{obj} to @var{proc}. +@var{obj} must be either an entity or an operator. +@end deffn + +@c docstring begin (texi-doc-string "guile" "make-class-object") +@deffn primitive make-class-object metaclass layout +Create a new class object of class @var{metaclass}, with the +slot layout specified by @var{layout}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "make-subclass-object") +@deffn primitive make-subclass-object class layout +Create a subclass object of @var{class}, with the slot layout +specified by @var{layout}. +@end deffn + + +@c Local Variables: +@c TeX-master: "guile.texi" +@c End: diff --git a/doc/scheme-modules.texi b/doc/scheme-modules.texi new file mode 100644 index 000000000..32b700cc0 --- /dev/null +++ b/doc/scheme-modules.texi @@ -0,0 +1,675 @@ +@page +@node Modules +@chapter Modules +@cindex modules + +[FIXME: somewhat babbling; should be reviewed by someone who understands +modules, once the new module system is in place] + +When programs become large, naming conflicts can occur when a function +or global variable defined in one file has the same name as a function +or global variable in another file. Even just a @emph{similarity} +between function names can cause hard-to-find bugs, since a programmer +might type the wrong function name. + +The approach used to tackle this problem is called @emph{information +encapsulation}, which consists of packaging functional units into a +given name space that is clearly separated from other name spaces. +@cindex encapsulation +@cindex information encapsulation +@cindex name space + +The language features that allow this are usually called @emph{the +module system} because programs are broken up into modules that are +compiled separately (or loaded separately in an interpreter). + +Older languages, like C, have limited support for name space +manipulation and protection. In C a variable or function is public by +default, and can be made local to a module with the @code{static} +keyword. But you cannot reference public variables and functions from +another module with different names. + +More advanced module systems have become a common feature in recently +designed languages: ML, Python, Perl, and Modula 3 all allow the +@emph{renaming} of objects from a foreign module, so they will not +clutter the global name space. +@cindex name space - private + +@menu +* Scheme and modules:: +* The Guile module system:: +* Dynamic Libraries:: Loading libraries of compiled code at run time. +* Dynamic Linking from Marius:: +@end menu + + +@node Scheme and modules +@section Scheme and modules + +Scheme, as defined in R4RS, does @emph{not} have a module system at all. + +Aubrey Jaffer, mostly to support his portable Scheme library SLIB, +implemented a provide/require mechanism for many Scheme implementations. +Library files in SLIB @emph{provide} a feature, and when user programs +@emph{require} that feature, the library file is loaded in. + +For example, the file @file{random.scm} in the SLIB package contains the +line +@smalllisp +(provide 'random) +@end smalllisp +so to use its procedures, a user would type +@smalllisp +(require 'random) +@end smalllisp +and they would magically become available, @emph{but still have the same +names!} So this method is nice, but not as good as a full-featured +module system. + + +@node The Guile module system +@section The Guile module system + +In 1996 Tom Lord implemented a full-featured module system for Guile +which allows loading Scheme source files into a private name space. + +This module system is regarded as being rather idiosyncratic, and will +probably change to something more like the ML module system, so for now +I will simply describe how it works for a couple of simple cases. + +First of all, the Guile module system sets up a hierarchical name space, +and that name space can be represented like Unix pathnames preceded by a +@key{#} character. The root name space for all Guile-supplied modules +is called @code{ice-9}. + +So for example, the SLIB interface, contained in +@file{$srcdir/ice-9/slib.scm}, starts out with +@smalllisp +(define-module (ice-9 slib)) +@end smalllisp +and a user program can use +@smalllisp +(use-modules (ice-9 slib)) +@end smalllisp +to have access to all procedures and variables defined within the slib +module with @code{(define-public ...)}. + +So here are the functions involved: +@c begin (scm-doc-string "boot-9.scm" "define-module") +@deffn syntax define-module module-specification +@var{module-specification} is of the form @code{(hierarchy file)}. One +example of this is +@smalllisp +(use-modules (ice-9 slib)) +@end smalllisp +define-module makes this module available to Guile programs under the +given @var{module-specification}. +@end deffn +@c end + +@c begin (scm-doc-string "boot-9.scm" "define-public") +@deffn syntax define-public @dots{} +Makes a procedure or variable available to programs that use the current +module. +@end deffn +@c end + +@c begin (scm-doc-string "boot-9.scm" "use-modules") +@deffn syntax use-modules module-specification +@var{module-specification} is of the form @code{(hierarchy file)}. One +example of this is +@smalllisp +(use-modules (ice-9 slib)) +@end smalllisp +use-modules allows the current Guile program to use all publicly defined +procedures and variables in the module denoted by +@var{module-specification}. +@end deffn +@c end + +[FIXME: must say more, and explain, and also demonstrate a private name +space use, and demonstrate how one would do Python's "from Tkinter +import *" versus "import Tkinter". Must also add something about paths +and standards for contributed modules.] + +@c docstring begin (texi-doc-string "guile" "standard-eval-closure") +@deffn primitive standard-eval-closure module +Return an eval closure for the module @var{module}. +@end deffn + +Some modules are included in the Guile distribution; here are references +to the entries in this manual which describe them in more detail: +@table @strong +@item boot-9 +boot-9 is Guile's initialization module, and it is always loaded when +Guile starts up. +@item (ice-9 debug) +Mikael Djurfeldt's source-level debugging support for Guile +(@pxref{Debugger User Interface}). +@item (ice-9 threads) +Guile's support for multi threaded execution (@pxref{Scheduling}). +@item (ice-9 slib) +This module contains hooks for using Aubrey Jaffer's portable Scheme +library SLIB from Guile (@pxref{SLIB}). +@item (ice-9 jacal) +This module contains hooks for using Aubrey Jaffer's symbolic math +packge Jacal from Guile (@pxref{JACAL}). +@end table + + +@node Dynamic Libraries +@section Dynamic Libraries + +Often you will want to extend Guile by linking it with some existing +system library. For example, linking Guile with a @code{curses} or +@code{termcap} library would be useful if you want to implement a +full-screen user interface for a Guile application. However, if you +were to link Guile with these libraries at compile time, it would bloat +the interpreter considerably, affecting everyone on the system even if +the new libraries are useful only to you. Also, every time a new +library is installed, you would have to reconfigure, recompile and +relink Guile merely in order to provide a new interface. + +Many Unix systems permit you to get around this problem by using +@dfn{dynamic loading}. When a new library is linked, it can be made a +@dfn{dynamic library} by passing certain switches to the linker. A +dynamic library does not need to be linked with an executable image at +link time; instead, the executable may choose to load it dynamically at +run time. This is a powerful concept that permits an executable to link +itself with almost any library without reconfiguration, if it has been +written properly. + +Guile's dynamic linking functions make it relatively easy to write a +module that incorporates code from third-party object code libraries. + +@c ARGFIXME fname/library-file +@c docstring begin (texi-doc-string "guile" "dynamic-link") +@deffn primitive dynamic-link fname +Open the dynamic library @var{library-file}. A library handle +representing the opened library is returned; this handle should be used +as the @var{lib} argument to the following functions. +@end deffn + +@c docstring begin (texi-doc-string "guile" "dynamic-object?") +@deffn primitive dynamic-object? obj +Return @code{#t} if @var{obj} is a dynamic library handle, or @code{#f} +otherwise. +@end deffn + +@c ARGFIXME dobj/dynobj/library-handle +@c docstring begin (texi-doc-string "guile" "dynamic-unlink") +@deffn primitive dynamic-unlink dobj +Unlink the library represented by @var{library-handle}, +and remove any imported symbols from the address space. +GJB:FIXME:DOC: 2nd version below: +Unlink the indicated object file from the application. The +argument @var{dynobj} must have been obtained by a call to +@code{dynamic-link}. After @code{dynamic-unlink} has been +called on @var{dynobj}, its content is no longer accessible. +@end deffn + +@c ARGFIXME symb/func/function dobj/lib/dynobj +@c docstring begin (texi-doc-string "guile" "dynamic-func") +@deffn primitive dynamic-func name dobj +Search the dynamic object @var{dobj} for the C function +indicated by the string @var{name} and return some Scheme +handle that can later be used with @code{dynamic-call} to +actually call the function. + +Regardless whether your C compiler prepends an underscore @samp{_} to +the global names in a program, you should @strong{not} include this +underscore in @var{function}. Guile knows whether the underscore is +needed or not and will add it when necessary. +@end deffn + +@c ARGFIXME lib-thunk/func/function lib/dobj/dynobj +@c docstring begin (texi-doc-string "guile" "dynamic-call") +@deffn primitive dynamic-call func dobj +Call @var{lib-thunk}, a procedure of no arguments. If @var{lib-thunk} +is a string, it is assumed to be a symbol found in the dynamic library +@var{lib} and is fetched with @code{dynamic-func}. Otherwise, it should +be a function handle returned by a previous call to @code{dynamic-func}. +The return value is unspecified. +GJB:FIXME:DOC 2nd version below +Call the C function indicated by @var{function} and @var{dynobj}. The +function is passed no arguments and its return value is ignored. When +@var{function} is something returned by @code{dynamic-func}, call that +function and ignore @var{dynobj}. When @var{function} is a string (or +symbol, etc.), look it up in @var{dynobj}; this is equivalent to + +@smallexample +(dynamic-call (dynamic-func @var{function} @var{dynobj} #f)) +@end smallexample + +Interrupts are deferred while the C function is executing (with +@code{SCM_DEFER_INTS}/@code{SCM_ALLOW_INTS}). +@end deffn + +@c ARGFIXME func/proc/function dobj/dynobj +@c docstring begin (texi-doc-string "guile" "dynamic-args-call") +@deffn primitive dynamic-args-call func dobj args +Call @var{proc}, a dynamically loaded function, passing it the argument +list @var{args} (a list of strings). As with @code{dynamic-call}, +@var{proc} should be either a function handle or a string, in which case +it is first fetched from @var{lib} with @code{dynamic-func}. + +@var{proc} is assumed to return an integer, which is used as the return +value from @code{dynamic-args-call}. + +GJB:FIXME:DOC 2nd version below +Call the C function indicated by @var{function} and @var{dynobj}, just +like @code{dynamic-call}, but pass it some arguments and return its +return value. The C function is expected to take two arguments and +return an @code{int}, just like @code{main}: + +@smallexample +int c_func (int argc, char **argv); +@end smallexample + +The parameter @var{args} must be a list of strings and is converted into +an array of @code{char *}. The array is passed in @var{argv} and its +size in @var{argc}. The return value is converted to a Scheme number +and returned from the call to @code{dynamic-args-call}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "c-registered-modules") +@deffn primitive c-registered-modules +Return a list of the object code modules that have been imported into +the current Guile process. Each element of the list is a pair whose +car is the name of the module, and whose cdr is the function handle +for that module's initializer function. The name is the string that +has been passed to scm_register_module_xxx. +@end deffn + +@c docstring begin (texi-doc-string "guile" "c-clear-registered-modules") +@deffn primitive c-clear-registered-modules +Destroy the list of modules registered with the current Guile process. +The return value is unspecified. @strong{Warning:} this function does +not actually unlink or deallocate these modules, but only destroys the +records of which modules have been loaded. It should therefore be used +only by module bookkeeping operations. +@end deffn + +[FIXME: provide a brief example here of writing the C hooks for an +object code module, and using dynamic-link and dynamic-call to load the +module.] + + +@node Dynamic Linking from Marius +@section Dynamic Linking from Marius + +@c NJFIXME primitive documentation here duplicates (and is generally +@c better than) documentation for the same primitives earlier on. + +Most modern Unices have something called @dfn{shared libraries}. This +ordinarily means that they have the capability to share the executable +image of a library between several running programs to save memory and +disk space. But generally, shared libraries give a lot of additional +flexibility compared to the traditional static libraries. In fact, +calling them `dynamic' libraries is as correct as calling them `shared'. + +Shared libraries really give you a lot of flexibility in addition to the +memory and disk space savings. When you link a program against a shared +library, that library is not closely incorporated into the final +executable. Instead, the executable of your program only contains +enough information to find the needed shared libraries when the program +is actually run. Only then, when the program is starting, is the final +step of the linking process performed. This means that you need not +recompile all programs when you install a new, only slightly modified +version of a shared library. The programs will pick up the changes +automatically the next time they are run. + +Now, when all the necessary machinery is there to perform part of the +linking at run-time, why not take the next step and allow the programmer +to explicitly take advantage of it from within his program? Of course, +many operating systems that support shared libraries do just that, and +chances are that Guile will allow you to access this feature from within +your Scheme programs. As you might have guessed already, this feature +is called @dfn{dynamic linking}@footnote{Some people also refer to the +final linking stage at program startup as `dynamic linking', so if you +want to make yourself perfectly clear, it is probably best to use the +more technical term @dfn{dlopening}, as suggested by Gordon Matzigkeit +in his libtool documentation.} + +As with many aspects of Guile, there is a low-level way to access the +dynamic linking apparatus, and a more high-level interface that +integrates dynamically linked libraries into the module system. + +@menu +* Low level dynamic linking:: +* Compiled Code Modules:: +* Dynamic Linking and Compiled Code Modules:: +@end menu + +@node Low level dynamic linking +@subsection Low level dynamic linking + +When using the low level procedures to do your dynamic linking, you have +complete control over which library is loaded when and what get's done +with it. + +@deffn primitive dynamic-link library +Find the shared library denoted by @var{library} (a string) and link it +into the running Guile application. When everything works out, return a +Scheme object suitable for representing the linked object file. +Otherwise an error is thrown. How object files are searched is system +dependent. + +Normally, @var{library} is just the name of some shared library file +that will be searched for in the places where shared libraries usually +reside, such as in @file{/usr/lib} and @file{/usr/local/lib}. +@end deffn + +@deffn primitive dynamic-object? val +Determine whether @var{val} represents a dynamically linked object file. +@end deffn + +@deffn primitive dynamic-unlink dynobj +Unlink the indicated object file from the application. The argument +@var{dynobj} should be one of the values returned by +@code{dynamic-link}. When @code{dynamic-unlink} has been called on +@var{dynobj}, it is no longer usable as an argument to the functions +below and you will get type mismatch errors when you try to. +@end deffn + +@deffn primitive dynamic-func function dynobj +Search the C function indicated by @var{function} (a string or symbol) +in @var{dynobj} and return some Scheme object that can later be used +with @code{dynamic-call} to actually call this function. Right now, +these Scheme objects are formed by casting the address of the function +to @code{long} and converting this number to its Scheme representation. + +Regardless whether your C compiler prepends an underscore @samp{_} to +the global names in a program, you should @strong{not} include this +underscore in @var{function}. Guile knows whether the underscore is +needed or not and will add it when necessary. +@end deffn + +@deffn primitive dynamic-call function dynobj +Call the C function indicated by @var{function} and @var{dynobj}. The +function is passed no arguments and its return value is ignored. When +@var{function} is something returned by @code{dynamic-func}, call that +function and ignore @var{dynobj}. When @var{function} is a string (or +symbol, etc.), look it up in @var{dynobj}; this is equivalent to + +@smallexample +(dynamic-call (dynamic-func @var{function} @var{dynobj} #f)) +@end smallexample + +Interrupts are deferred while the C function is executing (with +@code{SCM_DEFER_INTS}/@code{SCM_ALLOW_INTS}). +@end deffn + +@deffn primitive dynamic-args-call function dynobj args +Call the C function indicated by @var{function} and @var{dynobj}, just +like @code{dynamic-call}, but pass it some arguments and return its +return value. The C function is expected to take two arguments and +return an @code{int}, just like @code{main}: + +@smallexample +int c_func (int argc, char **argv); +@end smallexample + +The parameter @var{args} must be a list of strings and is converted into +an array of @code{char *}. The array is passed in @var{argv} and its +size in @var{argc}. The return value is converted to a Scheme number +and returned from the call to @code{dynamic-args-call}. +@end deffn + +When dynamic linking is disabled or not supported on your system, +the above functions throw errors, but they are still available. + +Here is a small example that works on GNU/Linux: + +@smallexample +(define libc-obj (dynamic-link "libc.so")) +libc-obj +@result{} # +(dynamic-args-call 'rand libc-obj '()) +@result{} 269167349 +(dynamic-unlink libc-obj) +libc-obj +@result{} # +@end smallexample + +As you can see, after calling @code{dynamic-unlink} on a dynamically +linked library, it is marked as @samp{(unlinked)} and you are no longer +able to use it with @code{dynamic-call}, etc. Whether the library is +really removed from you program is system-dependent and will generally +not happen when some other parts of your program still use it. In the +example above, @code{libc} is almost certainly not removed from your +program because it is badly needed by almost everything. + +The functions to call a function from a dynamically linked library, +@code{dynamic-call} and @code{dynamic-args-call}, are not very powerful. +They are mostly intended to be used for calling specially written +initialization functions that will then add new primitives to Guile. +For example, we do not expect that you will dynamically link +@file{libX11} with @code{dynamic-link} and then construct a beautiful +graphical user interface just by using @code{dynamic-call} and +@code{dynamic-args-call}. Instead, the usual way would be to write a +special Guile<->X11 glue library that has intimate knowledge about both +Guile and X11 and does whatever is necessary to make them inter-operate +smoothly. This glue library could then be dynamically linked into a +vanilla Guile interpreter and activated by calling its initialization +function. That function would add all the new types and primitives to +the Guile interpreter that it has to offer. + +From this setup the next logical step is to integrate these glue +libraries into the module system of Guile so that you can load new +primitives into a running system just as you can load new Scheme code. + +There is, however, another possibility to get a more thorough access to +the functions contained in a dynamically linked library. Anthony Green +has written @file{libffi}, a library that implements a @dfn{foreign +function interface} for a number of different platforms. With it, you +can extend the Spartan functionality of @code{dynamic-call} and +@code{dynamic-args-call} considerably. There is glue code available in +the Guile contrib archive to make @file{libffi} accessible from Guile. + +@node Compiled Code Modules +@subsection Putting Compiled Code into Modules + +The new primitives that you add to Guile with @code{gh_new_procedure} or +with any of the other mechanisms are normally placed into the same +module as all the other builtin procedures (like @code{display}). +However, it is also possible to put new primitives into their own +module. + +The mechanism for doing so is not very well thought out and is likely to +change when the module system of Guile itself is revised, but it is +simple and useful enough to document it as it stands. + +What @code{gh_new_procedure} and the functions used by the snarfer +really do is to add the new primitives to whatever module is the +@emph{current module} when they are called. This is analogous to the +way Scheme code is put into modules: the @code{define-module} expression +at the top of a Scheme source file creates a new module and makes it the +current module while the rest of the file is evaluated. The +@code{define} expressions in that file then add their new definitions to +this current module. + +Therefore, all we need to do is to make sure that the right module is +current when calling @code{gh_new_procedure} for our new primitives. +Unfortunately, there is not yet an easy way to access the module system +from C, so we are better off with a more indirect approach. Instead of +adding our primitives at initialization time we merely register with +Guile that we are ready to provide the contents of a certain module, +should it ever be needed. + +@deftypefun void scm_register_module_xxx (char *@var{name}, void (*@var{initfunc})(void)) +Register with Guile that @var{initfunc} will provide the contents of the +module @var{name}. + +The function @var{initfunc} should perform the usual initialization +actions for your new primitives, like calling @code{gh_new_procedure} or +including the file produced by the snarfer. When @var{initfunc} is +called, the current module is a newly created module with a name as +indicated by @var{name}. Each definition that is added to it will be +automatically exported. + +The string @var{name} indicates the hierachical name of the new module. +It should consist of the individual components of the module name +separated by single spaces. That is, the Scheme module name @code{(foo +bar)}, which is a list, should be written as @code{"foo bar"} for the +@var{name} parameter. + +You can call @code{scm_register_module_xxx} at any time, even before +Guile has been initialized. This might be useful when you want to put +the call to it in some initialization code that is magically called +before main, like constructors for global C++ objects. + +An example for @code{scm_register_module_xxx} appears in the next section. +@end deftypefun + +Now, instead of calling the initialization function at program startup, +you should simply call @code{scm_register_module_xxx} and pass it the +initialization function. When the named module is later requested by +Scheme code with @code{use-modules} for example, Guile will notice that +it knows how to create this module and will call the initialization +function at the right time in the right context. + +@node Dynamic Linking and Compiled Code Modules +@subsection Dynamic Linking and Compiled Code Modules + +The most interesting application of dynamically linked libraries is +probably to use them for providing @emph{compiled code modules} to +Scheme programs. As much fun as programming in Scheme is, every now and +then comes the need to write some low-level C stuff to make Scheme even +more fun. + +Not only can you put these new primitives into their own module (see the +previous section), you can even put them into a shared library that is +only then linked to your running Guile image when it is actually +needed. + +An example will hopefully make everything clear. Suppose we want to +make the Bessel functions of the C library available to Scheme in the +module @samp{(math bessel)}. First we need to write the appropriate +glue code to convert the arguments and return values of the functions +from Scheme to C and back. Additionally, we need a function that will +add them to the set of Guile primitives. Because this is just an +example, we will only implement this for the @code{j0} function, tho. + +@smallexample +#include +#include + +SCM +j0_wrapper (SCM x) +@{ + return gh_double2scm (j0 (gh_scm2double (x))); +@} + +void +init_math_bessel () +@{ + gh_new_procedure1_0 ("j0", j0_wrapper); +@} +@end smallexample + +We can already try to bring this into action by manually calling the low +level functions for performing dynamic linking. The C source file needs +to be compiled into a shared library. Here is how to do it on +GNU/Linux, please refer to the @code{libtool} documentation for how to +create dynamically linkable libraries portably. + +@smallexample +gcc -shared -o libbessel.so -fPIC bessel.c +@end smallexample + +Now fire up Guile: + +@smalllisp +(define bessel-lib (dynamic-link "./libbessel.so")) +(dynamic-call "init_math_bessel" bessel-lib) +(j0 2) +@result{} 0.223890779141236 +@end smalllisp + +The filename @file{./libbessel.so} should be pointing to the shared +library produced with the @code{gcc} command above, of course. The +second line of the Guile interaction will call the +@code{init_math_bessel} function which in turn will register the C +function @code{j0_wrapper} with the Guile interpreter under the name +@code{j0}. This function becomes immediately available and we can call +it from Scheme. + +Fun, isn't it? But we are only half way there. This is what +@code{apropos} has to say about @code{j0}: + +@smallexample +(apropos 'j0) +@print{} the-root-module: j0 # +@end smallexample + +As you can see, @code{j0} is contained in the root module, where all +the other Guile primitives like @code{display}, etc live. In general, +a primitive is put into whatever module is the @dfn{current module} at +the time @code{gh_new_procedure} is called. To put @code{j0} into its +own module named @samp{(math bessel)}, we need to make a call to +@code{scm_register_module_xxx}. Additionally, to have Guile perform +the dynamic linking automatically, we need to put @file{libbessel.so} +into a place where Guile can find it. The call to +@code{scm_register_module_xxx} should be contained in a specially +named @dfn{module init function}. Guile knows about this special name +and will call that function automatically after having linked in the +shared library. For our example, we add the following code to +@file{bessel.c}: + +@smallexample +void scm_init_math_bessel_module () +@{ + scm_register_module_xxx ("math bessel", init_math_bessel); +@} +@end smallexample + +The general pattern for the name of a module init function is: +@samp{scm_init_}, followed by the name of the module where the +individual hierarchical components are concatenated with underscores, +followed by @samp{_module}. It should call +@code{scm_register_module_xxx} with the correct module name and the +appropriate initialization function. When that initialization function +will be called, a newly created module with the right name will be the +@emph{current module} so that all definitions that the initialization +functions makes will end up in the correct module. + +After @file{libbessel.so} has been rebuild, we need to place the shared +library into the right place. When Guile tries to autoload the +@samp{(math bessel)} module, it looks not only for a file called +@file{math/bessel.scm} in its @code{%load-path}, but also for +@file{math/libbessel.so}. So all we need to do is to create a directory +called @file{math} somewhere in Guile's @code{%load-path} and place +@file{libbessel.so} there. Normally, the current directory @file{.} is +in the @code{%load-path}, so we just use that for this example. + +@smallexample +% mkdir maths +% cd maths +% ln -s ../libbessel.so . +% cd .. +% guile +guile> (use-modules (math bessel)) +guile> (j0 2) +0.223890779141236 +guile> (apropos 'j0) +@print{} bessel: j0 # +@end smallexample + +That's it! + +Note that we used a symlink to make @file{libbessel.so} appear in the +right spot. This is probably not a bad idea in general. The +directories that the @file{%load-path} normally contains are supposed to +contain only architecture independent files. They are not really the +right place for a shared library. You might want to install the +libraries somewhere below @samp{exec_prefix} and then symlink to them +from the architecture independent directory. This will at least work on +heterogenous systems where the architecture dependent stuff resides in +the same place on all machines (which seems like a good idea to me +anyway). + + +@c Local Variables: +@c TeX-master: "guile.texi" +@c End: diff --git a/doc/scheme-options.texi b/doc/scheme-options.texi new file mode 100644 index 000000000..c8ef7b35b --- /dev/null +++ b/doc/scheme-options.texi @@ -0,0 +1,337 @@ +@page +@node Options and Config +@chapter Runtime Options and Configuration + +Guile's behaviour can be modified by setting options. For example, is +the language that Guile accepts case sensitive, or should the debugger +automatically show a backtrace on error? + +Guile has two levels of interface for managing options: a low-level +control interface, and a user-level interface which allows the enabling +or disabling of options. + +Moreover, the options are classified in groups according to whether they +configure @emph{reading}, @emph{printing}, @emph{debugging} or +@emph{evaluating}. + +@menu +* General option interface:: +* Reader options:: +* Printing options:: +* Debugger options:: +* Evaluator options:: +* Examples of option use:: +* Install Config:: Installation and configuration data. +@end menu + +@node General option interface +@section General option interface + +We will use the expression @code{} to represent @code{read}, +@code{print}, @code{debug} or @code{evaluator}. + +@subheading Low level + +@c NJFIXME +@deffn primitive -options-interface +@deffnx primitive read-options-interface [SOME-INT] +@deffnx primitive print-options-interface [SOME-INT] +@deffnx primitive evaluator-traps-interface [SOME-INT] +@deffnx primitive read-options-interface [SOME-INT] +[FIXME: I have just taken the comments for C routine scm_options that +implements all of these. It needs to be presented better.] + +If scm_options is called without arguments, the current option setting +is returned. If the argument is an option setting, options are altered +and the old setting is returned. If the argument isn't a list, a list +of sublists is returned, where each sublist contains option name, value +and documentation string. +@end deffn + + +@subheading User level + +@c @deftp {Data type} scm_option +@c @code{scm_option} is used to represent run time options. It can be a +@c @emph{boolean} type, in which case the option will be set by the strings +@c @code{"yes"} and @code{"no"}. It can be a +@c @end deftp + +@c NJFIXME +@deffn procedure -options [arg] +@deffnx procedure read-options [arg] +@deffnx procedure print-options [arg] +@deffnx procedure debug-options [arg] +@deffnx procedure traps [arg] +These functions list the options in their group. The optional argument +@var{arg} is a symbol which modifies the form in which the options are +presented. + +With no arguments, @code{-options} returns the values of the +options in that particular group. If @var{arg} is @code{'help}, a +description of each option is given. If @var{arg} is @code{'full}, +programmers' options are also shown. + +@var{arg} can also be a list representing the state of all options. In +this case, the list contains single symbols (for enabled boolean +options) and symbols followed by values. +@end deffn +[FIXME: I don't think 'full is ever any different from 'help. What's +up?] + +@c NJFIXME +@deffn procedure -enable option-symbol +@deffnx procedure read-enable option-symbol +@deffnx procedure print-enable option-symbol +@deffnx procedure debug-enable option-symbol +@deffnx procedure trap-enable option-symbol +These functions set the specified @var{option-symbol} in their options +group. They only work if the option is boolean, and throw an error +otherwise. +@end deffn + +@c NJFIXME +@deffn procedure -disable option-symbol +@deffnx procedure read-disable option-symbol +@deffnx procedure print-disable option-symbol +@deffnx procedure debug-disable option-symbol +@deffnx procedure trap-disable option-symbol +These functions turn off the specified @var{option-symbol} in their +options group. They only work if the option is boolean, and throw an +error otherwise. +@end deffn + +@c NJFIXME +@deffn syntax -set! option-symbol value +@deffnx syntax read-set! option-symbol value +@deffnx syntax print-set! option-symbol value +@deffnx syntax debug-set! option-symbol value +@deffnx syntax trap-set! option-symbol value +These functions set a non-boolean @var{option-symbol} to the specified +@var{value}. +@end deffn + + +@node Reader options +@section Reader options +@cindex options - read +@cindex read options + +Here is the list of reader options generated by typing +@code{(read-options 'full)} in Guile. You can also see the default +values. +@smalllisp +keywords #f Style of keyword recognition: #f or 'prefix +case-insensitive no Convert symbols to lower case. +positions yes Record positions of source code expressions. +copy no Copy source code expressions. +@end smalllisp + +Notice that while Standard Scheme is case insensitive, to ease +translation of other Lisp dialects, notably Emacs Lisp, into Guile, +Guile is case-sensitive by default. + +To make Guile case insensitive, you can type +@smalllisp +(read-enable 'case-insensitive) +@end smalllisp + +@node Printing options +@section Printing options + +Here is the list of print options generated by typing +@code{(print-options 'full)} in Guile. You can also see the default +values. +@smallexample +source no Print closures with source. +closure-hook #f Hook for printing closures. +@end smallexample + + +@node Evaluator options +@section Evaluator options + +Here is the list of print options generated by typing +@code{(traps 'full)} in Guile. You can also see the default +values. +@smallexample +exit-frame no Trap when exiting eval or apply. +apply-frame no Trap when entering apply. +enter-frame no Trap when eval enters new frame. +@end smallexample + + +@node Debugger options +@section Debugger options + +Here is the list of print options generated by typing +@code{(debug-options 'full)} in Guile. You can also see the default +values. +@smallexample +stack 20000 Stack size limit (0 = no check). +debug yes Use the debugging evaluator. +backtrace no Show backtrace on error. +depth 20 Maximal length of printed backtrace. +maxdepth 1000 Maximal number of stored backtrace frames. +frames 3 Maximum number of tail-recursive frames in backtrace. +indent 10 Maximal indentation in backtrace. +backwards no Display backtrace in anti-chronological order. +procnames yes Record procedure names at definition. +trace no *Trace mode. +breakpoints no *Check for breakpoints. +cheap yes *Flyweight representation of the stack at traps. +@end smallexample + + +@node Examples of option use +@section Examples of option use + +Here is an example of a session in which some read and debug option +handling procedures are used. In this example, the user + +@enumerate +@item +Notices that the symbols @code{abc} and @code{aBc} are not the same +@item +Examines the @code{read-options}, and sees that @code{case-insensitive} +is set to ``no''. +@item +Enables @code{case-insensitive} +@item +Verifies that now @code{aBc} and @code{abc} are the same +@item +Disables @code{case-insensitive} and enables debugging @code{backtrace} +@item +Reproduces the error of displaying @code{aBc} with backtracing enabled +[FIXME: this last example is lame because there is no depth in the +backtrace. Need to give a better example, possibly putting debugging +option examples in a separate session.] +@end enumerate + + +@smalllisp +guile> (define abc "hello") +guile> abc +"hello" +guile> aBc +ERROR: In expression aBc: +ERROR: Unbound variable: aBc +ABORT: (misc-error) + +Type "(backtrace)" to get more information. +guile> (read-options 'help) +keywords #f Style of keyword recognition: #f or 'prefix +case-insensitive no Convert symbols to lower case. +positions yes Record positions of source code expressions. +copy no Copy source code expressions. +guile> (debug-options 'help) +stack 20000 Stack size limit (0 = no check). +debug yes Use the debugging evaluator. +backtrace no Show backtrace on error. +depth 20 Maximal length of printed backtrace. +maxdepth 1000 Maximal number of stored backtrace frames. +frames 3 Maximum number of tail-recursive frames in backtrace. +indent 10 Maximal indentation in backtrace. +backwards no Display backtrace in anti-chronological order. +procnames yes Record procedure names at definition. +trace no *Trace mode. +breakpoints no *Check for breakpoints. +cheap yes *Flyweight representation of the stack at traps. +guile> (read-enable 'case-insensitive) +(keywords #f case-insensitive positions) +guile> aBc +"hello" +guile> (read-disable 'case-insensitive) +(keywords #f positions) +guile> (debug-enable 'backtrace) +(stack 20000 debug backtrace depth 20 maxdepth 1000 frames 3 indent 10 procnames cheap) +guile> aBc + +Backtrace: +0* aBc + +ERROR: In expression aBc: +ERROR: Unbound variable: aBc +ABORT: (misc-error) +guile> +@end smalllisp + + +@node Install Config +@section Installation and Configuration Data + +It is often useful to have site-specific information about the current +Guile installation. This chapter describes how to find out about +Guile's configuration at run time. + +@c docstring begin (texi-doc-string "guile" "version") +@c docstring begin (texi-doc-string "guile" "major-version") +@c docstring begin (texi-doc-string "guile" "minor-version") +@deffn primitive version +@deffnx primitive major-version +@deffnx primitive minor-version +Return a string describing Guile's version number, or its major or minor +version numbers, respectively. + +@example +(version) @result{} "1.3a" +(major-version) @result{} "1" +(minor-version) @result{} "3a" +@end example +@end deffn + +@c NJFIXME not in libguile! +@deffn primitive libguile-config-stamp +Return a string describing the date on which @code{libguile} was +configured. This is used to determine whether the Guile core +interpreter and the ice-9 runtime have grown out of date with one +another. +@end deffn + +@c docstring begin (texi-doc-string "guile" "%package-data-dir") +@deffn primitive %package-data-dir +Return the name of the directory where Scheme packages, modules and +libraries are kept. On most Unix systems, this will be +@samp{/usr/local/share/guile}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "%library-dir") +@deffn primitive %library-dir +Return the directory where the Guile Scheme library files are installed. +E.g., may return "/usr/share/guile/1.3.5". +@end deffn + +@c docstring begin (texi-doc-string "guile" "%site-dir") +@deffn primitive %site-dir +Return the directory where the Guile site files are installed. +E.g., may return "/usr/share/guile/site". +@end deffn + +@c docstring begin (texi-doc-string "guile" "parse-path") +@deffn primitive parse-path path [tail] +Parse @var{path}, which is expected to be a colon-separated +string, into a list and return the resulting list with +@var{tail} appended. If @var{path} is @code{#f}, @var{tail} +is returned. +@end deffn + +@c docstring begin (texi-doc-string "guile" "search-path") +@deffn primitive search-path path filename [extensions] +Search @var{path} for a directory containing a file named +@var{filename}. The file must be readable, and not a directory. +If we find one, return its full filename; otherwise, return +@code{#f}. If @var{filename} is absolute, return it unchanged. +If given, @var{extensions} is a list of strings; for each +directory in @var{path}, we search for @var{filename} +concatenated with each @var{extension}. +@end deffn + +@defvar %load-path +Return the list of directories which should be searched for Scheme +modules and libraries. +@end defvar + + +@c Local Variables: +@c TeX-master: "guile.texi" +@c End: diff --git a/doc/scheme-procedures.texi b/doc/scheme-procedures.texi new file mode 100644 index 000000000..64ba417e6 --- /dev/null +++ b/doc/scheme-procedures.texi @@ -0,0 +1,206 @@ +@page +@node Procedures and Macros +@chapter Procedures and Macros + +@menu +* Lambda:: Basic procedure creation using lambda. +* Optional Arguments:: Handling keyword, optional and rest arguments. +* Procedure Properties:: Procedure properties and metainformation. +* Procedures with Setters:: Procedures with setters. +* Macros:: Macros. +@end menu + + +@node Lambda +@section Lambda: Basic Procedure Creation + + +@node Optional Arguments +@section Optional Arguments + + +@node Procedure Properties +@section Procedure Properties and Metainformation + +@c docstring begin (texi-doc-string "guile" "procedure-properties") +@deffn primitive procedure-properties proc +Return @var{obj}'s property list. +@end deffn + +@c docstring begin (texi-doc-string "guile" "procedure-property") +@deffn primitive procedure-property p k +Return the property of @var{obj} with name @var{key}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "set-procedure-properties!") +@deffn primitive set-procedure-properties! proc new_val +Set @var{obj}'s property list to @var{alist}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "set-procedure-property!") +@deffn primitive set-procedure-property! p k v +In @var{obj}'s property list, set the property named @var{key} to +@var{value}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "procedure-documentation") +@deffn primitive procedure-documentation proc +Return the documentation string associated with @code{proc}. By +convention, if a procedure contains more than one expression and the +first expression is a string constant, that string is assumed to contain +documentation for that procedure. +@end deffn + +@c docstring begin (texi-doc-string "guile" "closure?") +@deffn primitive closure? obj +Return @code{#t} if @var{obj} is a closure. +@end deffn + +@c docstring begin (texi-doc-string "guile" "procedure?") +@deffn primitive procedure? obj +Return @code{#t} if @var{obj} is a procedure. +@end deffn + +@c docstring begin (texi-doc-string "guile" "thunk?") +@deffn primitive thunk? obj +Return @code{#t} if @var{obj} is a thunk. +@end deffn + +@c docstring begin (texi-doc-string "guile" "set-source-properties!") +@deffn primitive set-source-properties! obj plist +Install the association list @var{plist} as the source property +list for @var{obj}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "set-source-property!") +@deffn primitive set-source-property! obj key datum +Set the source property of object @var{obj}, which is specified by +@var{key} to @var{datum}. Normally, the key will be a symbol. +@end deffn + +@c docstring begin (texi-doc-string "guile" "source-properties") +@deffn primitive source-properties obj +Return the source property association list of @var{obj}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "source-property") + +@deffn primitive source-property obj key +Return the source property specified by @var{key} from +@var{obj}'s source property list. +@end deffn + + +@node Procedures with Setters +@section Procedures with Setters + +@c docstring begin (texi-doc-string "guile" "make-procedure-with-setter") +@deffn primitive make-procedure-with-setter procedure setter +Create a new procedure which behaves like @var{procedure}, but +with the associated setter @var{setter}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "procedure-with-setter?") +@deffn primitive procedure-with-setter? obj +Return @code{#t} if @var{obj} is a procedure with an +associated setter procedure. +@end deffn + +@c docstring begin (texi-doc-string "guile" "procedure") +@deffn primitive procedure proc +Return the procedure of @var{proc}, which must be either a +procedure with setter, or an operator struct. +@end deffn + +@c docstring begin (texi-doc-string "guile" "setter") +@deffn primitive setter proc +@end deffn + + +@node Macros +@section Macros + +[FIXME: This needs some more text on the difference between procedures, +macros and memoizing macros. Also, any definitions listed here should +be double-checked by someone who knows what's going on. Ask Mikael, Jim +or Aubrey for help. -twp] + +@c docstring begin (texi-doc-string "guile" "procedure->syntax") +@deffn primitive procedure->syntax code +Returns a @dfn{macro} which, when a symbol defined to this value +appears as the first symbol in an expression, returns the result +of applying @var{code} to the expression and the environment. +@end deffn + +@c docstring begin (texi-doc-string "guile" "procedure->macro") +@deffn primitive procedure->macro code +Returns a @dfn{macro} which, when a symbol defined to this value +appears as the first symbol in an expression, evaluates the result +of applying @var{code} to the expression and the environment. +The value returned from @var{code} which has been passed to +@code{procedure->memoizing-macro} replaces the form passed to +@var{code}. For example: + +@example +(define trace + (procedure->macro + (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x)))))) + +(trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})). +@end example +@end deffn + +@c docstring begin (texi-doc-string "guile" "procedure->memoizing-macro") +@deffn primitive procedure->memoizing-macro code +Returns a @dfn{macro} which, when a symbol defined to this value +appears as the first symbol in an expression, evaluates the result +of applying @var{proc} to the expression and the environment. +The value returned from @var{proc} which has been passed to +@code{procedure->memoizing-macro} replaces the form passed to +@var{proc}. For example: + +@example +(define trace + (procedure->macro + (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x)))))) + +(trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})). +@end example +@end deffn + +@c docstring begin (texi-doc-string "guile" "macro?") +@deffn primitive macro? obj +Return @code{#t} if @var{obj} is a regular macro, a memoizing macro or a +syntax transformer. +@end deffn + +@c ARGFIXME m/obj +@c docstring begin (texi-doc-string "guile" "macro-type") +@deffn primitive macro-type m +Return one of the symbols @code{syntax}, @code{macro} or @code{macro!}, +depending on whether @var{obj} is a syntax tranformer, a regular macro, +or a memoizing macro, respectively. If @var{obj} is not a macro, +@code{#f} is returned. +@end deffn + +@c docstring begin (texi-doc-string "guile" "macro-name") +@deffn primitive macro-name m +Return the name of the macro @var{m}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "macro-transformer") +@deffn primitive macro-transformer m +Return the transformer of the macro @var{m}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "cons-source") +@deffn primitive cons-source xorig x y +Create and return a new pair whose car and cdr are @var{x} and @var{y}. +Any source properties associated with @var{xorig} are also associated +with the new pair. +@end deffn + + +@c Local Variables: +@c TeX-master: "guile.texi" +@c End: diff --git a/doc/scheme-reading.texi b/doc/scheme-reading.texi new file mode 100644 index 000000000..690a01f43 --- /dev/null +++ b/doc/scheme-reading.texi @@ -0,0 +1,27 @@ +@page +@node Further Reading +@chapter Further Reading + +@itemize +@item +Dorai Sitaram's online Scheme tutorial, @dfn{Teach Yourself Scheme in +Fixnum Days}, at +http://www.cs.rice.edu/~dorai/t-y-scheme/t-y-scheme.html. Includes a +nice explanation of continuations. + +@item +http://wombat.doc.ic.ac.uk/foldoc/. + +@item +The complete text of @dfn{Structure and Interpretation of Computer +Programs}, the classic introduction to computer science and Scheme by +Hal Abelson, Jerry Sussman and Julie Sussman, is now available online at +http://mitpress.mit.edu/sicp/sicp.html. This site also provides +teaching materials related to the book, and all the source code used in +the book, in a form suitable for loading and running. +@end itemize + + +@c Local Variables: +@c TeX-master: "guile.texi" +@c End: diff --git a/doc/scheme-scheduling.texi b/doc/scheme-scheduling.texi new file mode 100644 index 000000000..89ce8a4f7 --- /dev/null +++ b/doc/scheme-scheduling.texi @@ -0,0 +1,381 @@ +@page +@node Scheduling +@chapter Threads, Mutexes, Asyncs and Dynamic Roots + +[FIXME: This is pasted in from Tom Lord's original guile.texi chapter +plus the Cygnus programmer's manual; it should be *very* carefully +reviewed and largely reorganized.] + +@menu +* Arbiters:: +* Asyncs:: +* Dynamic Roots:: +* Threads:: +* Fluids:: +@end menu + + +@node Arbiters +@section Arbiters + +@c docstring begin (texi-doc-string "guile" "make-arbiter") +@deffn primitive make-arbiter name +Return an object of type arbiter and name @var{name}. Its +state is initially unlocked. Arbiters are a way to achieve +process synchronization. +@end deffn + +@c docstring begin (texi-doc-string "guile" "try-arbiter") +@deffn primitive try-arbiter arb +Return @code{#t} and lock the arbiter @var{arb} if the arbiter +was unlocked. Otherwise, return @code{#f}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "release-arbiter") +@deffn primitive release-arbiter arb +Return @code{#t} and unlock the arbiter @var{arb} if the +arbiter was locked. Otherwise, return @code{#f}. +@end deffn + + +@node Asyncs +@section Asyncs + +@c docstring begin (texi-doc-string "guile" "async") +@deffn primitive async thunk +Create a new async for the procedure @var{thunk}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "system-async") +@deffn primitive system-async thunk +Create a new async for the procedure @var{thunk}. Also +add it to the system's list of active async objects. +@end deffn + +@c docstring begin (texi-doc-string "guile" "async-mark") +@deffn primitive async-mark a +Mark the async @var{a} for future execution. +@end deffn + +@c docstring begin (texi-doc-string "guile" "system-async-mark") +@deffn primitive system-async-mark a +Mark the async @var{a} for future execution. +@end deffn + +@c docstring begin (texi-doc-string "guile" "run-asyncs") +@deffn primitive run-asyncs list_of_a +Execute all thunks from the asyncs of the list @var{list_of_a}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "noop") +@deffn primitive noop . args +Do nothing. When called without arguments, return @code{#f}, +otherwise return the first argument. +@end deffn + +@c docstring begin (texi-doc-string "guile" "unmask-signals") +@deffn primitive unmask-signals +Unmask signals. The returned value is not specified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "mask-signals") +@deffn primitive mask-signals +Mask signals. The returned value is not specified. +@end deffn + + +@node Dynamic Roots +@section Dynamic Roots +@cindex dynamic roots + +A @dfn{dynamic root} is a root frame of Scheme evaluation. +The top-level repl, for example, is an instance of a dynamic root. + +Each dynamic root has its own chain of dynamic-wind information. Each +has its own set of continuations, jump-buffers, and pending CATCH +statements which are inaccessible from the dynamic scope of any +other dynamic root. + +In a thread-based system, each thread has its own dynamic root. Therefore, +continuations created by one thread may not be invoked by another. + +Even in a single-threaded system, it is sometimes useful to create a new +dynamic root. For example, if you want to apply a procedure, but to +not allow that procedure to capture the current continuation, calling +the procedure under a new dynamic root will do the job. + +@c docstring begin (texi-doc-string "guile" "call-with-dynamic-root") +@deffn primitive call-with-dynamic-root thunk handler +Evaluate @code{(thunk)} in a new dynamic context, returning its value. + +If an error occurs during evaluation, apply @var{handler} to the +arguments to the throw, just as @code{throw} would. If this happens, +@var{handler} is called outside the scope of the new root -- it is +called in the same dynamic context in which +@code{call-with-dynamic-root} was evaluated. + +If @var{thunk} captures a continuation, the continuation is rooted at +the call to @var{thunk}. In particular, the call to +@code{call-with-dynamic-root} is not captured. Therefore, +@code{call-with-dynamic-root} always returns at most one time. + +Before calling @var{thunk}, the dynamic-wind chain is un-wound back to +the root and a new chain started for @var{thunk}. Therefore, this call +may not do what you expect: + +@example +;; Almost certainly a bug: +(with-output-to-port + some-port + + (lambda () + (call-with-dynamic-root + (lambda () + (display 'fnord) + (newline)) + (lambda (errcode) errcode)))) +@end example + +The problem is, on what port will @samp{fnord} be displayed? You +might expect that because of the @code{with-output-to-port} that +it will be displayed on the port bound to @code{some-port}. But it +probably won't -- before evaluating the thunk, dynamic winds are +unwound, including those created by @code{with-output-to-port}. +So, the standard output port will have been re-set to its default value +before @code{display} is evaluated. + +(This function was added to Guile mostly to help calls to functions in C +libraries that can not tolerate non-local exits or calls that return +multiple times. If such functions call back to the interpreter, it should +be under a new dynamic root.) +@end deffn + + +@c docstring begin (texi-doc-string "guile" "dynamic-root") +@deffn primitive dynamic-root +Return an object representing the current dynamic root. + +These objects are only useful for comparison using @code{eq?}. +They are currently represented as numbers, but your code should +in no way depend on this. +@end deffn + +@c begin (scm-doc-string "boot-9.scm" "quit") +@deffn procedure quit [exit_val] +Throw back to the error handler of the current dynamic root. + +If integer @var{exit_val} is specified and if Guile is being used +stand-alone and if quit is called from the initial dynamic-root, +@var{exit_val} becomes the exit status of the Guile process and the +process exits. +@end deffn + +When Guile is run interactively, errors are caught from within the +read-eval-print loop. An error message will be printed and @code{abort} +called. A default set of signal handlers is installed, e.g., to allow +user interrupt of the interpreter. + +It is possible to switch to a "batch mode", in which the interpreter +will terminate after an error and in which all signals cause their +default actions. Switching to batch mode causes any handlers installed +from Scheme code to be removed. An example of where this is useful is +after forking a new process intended to run non-interactively. + +@c begin (scm-doc-string "boot-9.scm" "batch-mode?") +@deffn procedure batch-mode? +Returns a boolean indicating whether the interpreter is in batch mode. +@end deffn + +@c begin (scm-doc-string "boot-9.scm" "set-batch-mode?!") +@deffn procedure set-batch-mode?! arg +If @var{arg} is true, switches the interpreter to batch mode. +The @code{#f} case has not been implemented. +@end deffn + +@node Threads +@section Threads +@cindex threads +@cindex Guile threads + +@strong{[NOTE: this chapter was written for Cygnus Guile and has not yet +been updated for the Guile 1.x release.]} + +Here is a the reference for Guile's threads. In this chapter I simply +quote verbatim Tom Lord's description of the low-level primitives +written in C (basically an interface to the POSIX threads library) and +Anthony Green's description of the higher-level thread procedures +written in scheme. +@cindex posix threads +@cindex Lord, Tom +@cindex Green, Anthony + +When using Guile threads, keep in mind that each guile thread is +executed in a new dynamic root. + +@menu +* Low level thread primitives:: +* Higher level thread procedures:: +@end menu + + +@node Low level thread primitives +@subsection Low level thread primitives + +@c NJFIXME no current mechanism for making sure that these docstrings +@c are in sync. + +@c begin (texi-doc-string "guile" "call-with-new-thread") +@deffn primitive call-with-new-thread thunk error-thunk +Evaluate @code{(thunk)} in a new thread, and new dynamic context, +returning a new thread object representing the thread. + +If an error occurs during evaluation, call error-thunk, passing it an +error code describing the condition. [Error codes are currently +meaningless integers. In the future, real values will be specified.] +If this happens, the error-thunk is called outside the scope of the new +root -- it is called in the same dynamic context in which +with-new-thread was evaluated, but not in the callers thread. + +All the evaluation rules for dynamic roots apply to threads. +@end deffn + +@c begin (texi-doc-string "guile" "join-thread") +@deffn primitive join-thread thread +Suspend execution of the calling thread until the target @var{thread} +terminates, unless the target @var{thread} has already terminated. +@end deffn + +@c begin (texi-doc-string "guile" "yield") +@deffn primitive yield +If one or more threads are waiting to execute, calling yield forces an +immediate context switch to one of them. Otherwise, yield has no effect. +@end deffn + +@c begin (texi-doc-string "guile" "make-mutex") +@deffn primitive make-mutex +Create a new mutex object. +@end deffn + +@c begin (texi-doc-string "guile" "lock-mutex") +@deffn primitive lock-mutex mutex +Lock @var{mutex}. If the mutex is already locked, the calling thread +blocks until the mutex becomes available. The function returns when +the calling thread owns the lock on @var{mutex}. +@end deffn + +@c begin (texi-doc-string "guile" "unlock-mutex") +@deffn primitive unlock-mutex mutex +Unlocks @var{mutex} if the calling thread owns the lock on @var{mutex}. +Calling unlock-mutex on a mutex not owned by the current thread results +in undefined behaviour. Once a mutex has been unlocked, one thread +blocked on @var{mutex} is awakened and grabs the mutex lock. +@end deffn + +@c begin (texi-doc-string "guile" "make-condition-variable") +@deffn primitive make-condition-variable +@end deffn + +@c begin (texi-doc-string "guile" "wait-condition-variable") +@deffn primitive wait-condition-variable cond-var mutex +@end deffn + +@c begin (texi-doc-string "guile" "signal-condition-variable") +@deffn primitive signal-condition-variable cond-var +@end deffn + + +@node Higher level thread procedures +@subsection Higher level thread procedures + +@c NJFIXME the following doc is a repeat of the previous node! + +@c begin (texi-doc-string "guile" "call-with-new-thread") +@deffn primitive call-with-new-thread thunk error-thunk +Evaluate @code{(thunk)} in a new thread, and new dynamic context, +returning a new thread object representing the thread. + +If an error occurs during evaluation, call error-thunk, passing it an +error code describing the condition. [Error codes are currently +meaningless integers. In the future, real values will be specified.] +If this happens, the error-thunk is called outside the scope of the new +root -- it is called in the same dynamic context in which +with-new-thread was evaluated, but not in the callers thread. + +All the evaluation rules for dynamic roots apply to threads. +@end deffn + +@c begin (texi-doc-string "guile" "join-thread") +@deffn primitive join-thread thread +Suspend execution of the calling thread until the target @var{thread} +terminates, unless the target @var{thread} has already terminated. +@end deffn + +@c begin (texi-doc-string "guile" "yield") +@deffn primitive yield +If one or more threads are waiting to execute, calling yield forces an +immediate context switch to one of them. Otherwise, yield has no effect. +@end deffn + +@c begin (texi-doc-string "guile" "make-mutex") +@deffn primitive make-mutex +Create a new mutex object. +@end deffn + +@c begin (texi-doc-string "guile" "lock-mutex") +@deffn primitive lock-mutex mutex +Lock @var{mutex}. If the mutex is already locked, the calling thread +blocks until the mutex becomes available. The function returns when +the calling thread owns the lock on @var{mutex}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "unlock-mutex") +@deffn primitive unlock-mutex mutex +Unlocks @var{mutex} if the calling thread owns the lock on @var{mutex}. +Calling unlock-mutex on a mutex not owned by the current thread results +in undefined behaviour. Once a mutex has been unlocked, one thread +blocked on @var{mutex} is awakened and grabs the mutex lock. +@end deffn + + +@node Fluids +@section Fluids + +@c docstring begin (texi-doc-string "guile" "make-fluid") +@deffn primitive make-fluid +Return a newly created fluid. +Fluids are objects of a certain type (a smob) that can hold one SCM +value per dynamic root. That is, modifications to this value are +only visible to code that executes within the same dynamic root as +the modifying code. When a new dynamic root is constructed, it +inherits the values from its parent. Because each thread executes +in its own dynamic root, you can use fluids for thread local storage. +@end deffn + +@c docstring begin (texi-doc-string "guile" "fluid?") +@deffn primitive fluid? obj +Return #t iff @var{obj} is a fluid; otherwise, return #f. +@end deffn + +@c docstring begin (texi-doc-string "guile" "fluid-ref") +@deffn primitive fluid-ref fluid +Return the value associated with @var{fluid} in the current dynamic root. +If @var{fluid} has not been set, then this returns #f. +@end deffn + +@c docstring begin (texi-doc-string "guile" "fluid-set!") +@deffn primitive fluid-set! fluid value +Set the value associated with @var{fluid} in the current dynamic root. +@end deffn + +@c docstring begin (texi-doc-string "guile" "with-fluids*") +@deffn primitive with-fluids* fluids values thunk +Set @var{fluids} to @var{values} temporary, and call @var{thunk}. +@var{fluids} must be a list of fluids and @var{values} must be the same +number of their values to be applied. Each substitution is done +one after another. @var{thunk} must be a procedure with no argument. +@end deffn + + +@c Local Variables: +@c TeX-master: "guile.texi" +@c End: diff --git a/doc/scheme-translation.texi b/doc/scheme-translation.texi new file mode 100644 index 000000000..dfbbdd0b4 --- /dev/null +++ b/doc/scheme-translation.texi @@ -0,0 +1,49 @@ +@page +@node Translation +@chapter Support for Translating Other Languages + +[Describe translation framework.] + +@menu +* Emacs Lisp Support:: Helper primitives for Emacs Lisp. +@end menu + + +@node Emacs Lisp Support +@section Emacs Lisp Support + +@c docstring begin (texi-doc-string "guile" "nil-car") +@deffn primitive nil-car x +Return the car of @var{x}, but convert it to LISP nil if it +is Scheme's end-of-list. +@end deffn + +@c docstring begin (texi-doc-string "guile" "nil-cdr") +@deffn primitive nil-cdr x +Return the cdr of @var{x}, but convert it to LISP nil if it +is Scheme's end-of-list. +@end deffn + +@c docstring begin (texi-doc-string "guile" "nil-cons") +@deffn primitive nil-cons x y +Create a new cons cell with @var{x} as the car and @var{y} as +the cdr, but convert @var{y} to Scheme's end-of-list if it is +a LISP nil. +@end deffn + +@c docstring begin (texi-doc-string "guile" "nil-eq") +@deffn primitive nil-eq x y +Compare @var{x} and @var{y} and return LISP's t if they are +@code{eq?}, return LISP's nil otherwise. +@end deffn + +@c docstring begin (texi-doc-string "guile" "null") +@deffn primitive null x +Return LISP's @code{t} if @var{x} is nil in the LISP sense, +return LISP's nil otherwise. +@end deffn + + +@c Local Variables: +@c TeX-master: "guile.texi" +@c End: diff --git a/doc/scheme-utility.texi b/doc/scheme-utility.texi new file mode 100644 index 000000000..c57a63aac --- /dev/null +++ b/doc/scheme-utility.texi @@ -0,0 +1,219 @@ +@page +@node Utility Functions +@chapter General Utility Functions + +@menu +* Equality:: When are two values `the same'? +* Property Lists:: Managing metainformation about Scheme objects. +* Primitive Properties:: A modern low-level interface to object properties. +* Sorting:: Sort utility procedures. +* Copying:: Copying deep structures. +@end menu + + +@node Equality +@section Equality + +@c docstring begin (texi-doc-string "guile" "eq?") +@deffn primitive eq? x y +Return @code{#t} iff @var{x} references the same object as @var{y}. +@code{eq?} is similar to @code{eqv?} except that in some cases it is +capable of discerning distinctions finer than those detectable by +@code{eqv?}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "eqv?") +@deffn primitive eqv? x y +The @code{eqv?} procedure defines a useful equivalence relation on objects. +Briefly, it returns @code{#t} if @var{x} and @var{y} should normally be +regarded as the same object. This relation is left slightly open to +interpretation, but works for comparing immediate integers, characters, +and inexact numbers. +@end deffn + +@c docstring begin (texi-doc-string "guile" "equal?") +@deffn primitive equal? x y +Return @code{#t} iff @var{x} and @var{y} are recursively @code{eqv?} equivalent. +@code{equal?} recursively compares the contents of pairs, +vectors, and strings, applying @code{eqv?} on other objects such as +numbers and symbols. A rule of thumb is that objects are generally +@code{equal?} if they print the same. @code{equal?} may fail to +terminate if its arguments are circular data structures. +@end deffn + + +@node Property Lists +@section Property Lists + +Every object in the system can have a @dfn{property list} that may +be used for information about that object. For example, a +function may have a property list that includes information about +the source file in which it is defined. + +Property lists are implemented as assq lists (@pxref{Association Lists}). + +Currently, property lists are implemented differently for procedures and +closures than for other kinds of objects. Therefore, when manipulating +a property list associated with a procedure object, use the +@code{procedure} functions; otherwise, use the @code{object} functions. + +@c docstring begin (texi-doc-string "guile" "object-properties") +@deffn primitive object-properties obj +@deffnx primitive procedure-properties obj +Return @var{obj}'s property list. +@end deffn + +@c ARGFIXME alist/plist +@c docstring begin (texi-doc-string "guile" "set-object-properties!") +@deffn primitive set-object-properties! obj plist +@deffnx primitive set-procedure-properties! obj alist +Set @var{obj}'s property list to @var{alist}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "object-property") +@deffn primitive object-property obj key +@deffnx primitive procedure-property obj key +Return the property of @var{obj} with name @var{key}. +@end deffn + +@c ARGFIXME val/value +@c docstring begin (texi-doc-string "guile" "set-object-property!") +@deffn primitive set-object-property! obj key val +@deffnx primitive set-procedure-property! obj key value +In @var{obj}'s property list, set the property named @var{key} to +@var{value}. +@end deffn + +[Interface bug: there should be a second level of interface in which +the user provides a "property table" that is possibly private.] + + +@node Primitive Properties +@section Primitive Properties + +@c docstring begin (texi-doc-string "guile" "primitive-make-property") +@deffn primitive primitive-make-property not_found_proc +Create a @dfn{property token} that can be used with +@code{primitive-property-ref} and @code{primitive-property-set!}. +See @code{primitive-property-ref} for the significance of +@var{not_found_proc}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "primitive-property-ref") +@deffn primitive primitive-property-ref prop obj +Return the property @var{prop} of @var{obj}. When no value +has yet been associated with @var{prop} and @var{obj}, call +@var{not-found-proc} instead (see @code{primitive-make-property}) +and use its return value. That value is also associated with +@var{obj} via @code{primitive-property-set!}. When +@var{not-found-proc} is @code{#f}, use @code{#f} as the +default value of @var{prop}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "primitive-property-set!") +@deffn primitive primitive-property-set! prop obj val +Associate @var{code} with @var{prop} and @var{obj}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "primitive-property-del!") +@deffn primitive primitive-property-del! prop obj +Remove any value associated with @var{prop} and @var{obj}. +@end deffn + + +@node Sorting +@section Sorting + +@c docstring begin (texi-doc-string "guile" "merge!") +@deffn primitive merge! alist blist less +Takes two lists @var{alist} and @var{blist} such that +@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and +returns a new list in which the elements of @var{alist} and +@var{blist} have been stably interleaved so that + @code{(sorted? (merge alist blist less?) less?)}. +This is the destructive variant of @code{merge} +Note: this does _not_ accept vectors. +@end deffn + +@c docstring begin (texi-doc-string "guile" "merge") +@deffn primitive merge alist blist less +@end deffn + +@c docstring begin (texi-doc-string "guile" "restricted-vector-sort!") +@deffn primitive restricted-vector-sort! vec less startpos endpos +Sort the vector @var{vec}, using @var{less} for comparing +the vector elements. @var{startpos} and @var{endpos} delimit +the range of the vector which gets sorted. The return value +is not specified. +@end deffn + +@c docstring begin (texi-doc-string "guile" "sort!") +@deffn primitive sort! items less +Sort the sequence @var{items}, which may be a list or a +vector. @var{less} is used for comparing the sequence +elements. The sorting is destructive, that means that the +input sequence is modified to produce the sorted result. +This is not a stable sort. +@end deffn + +@c docstring begin (texi-doc-string "guile" "sort") +@deffn primitive sort items less +Sort the sequence @var{items}, which may be a list or a +vector. @var{less} is used for comparing the sequence +elements. This is not a stable sort. +@end deffn + +@c docstring begin (texi-doc-string "guile" "sort-list!") +@deffn primitive sort-list! items less +Sort the list @var{items}, using @var{less} for comparing the +list elements. The sorting is destructive, that means that the +input list is modified to produce the sorted result. +This is a stable sort. +@end deffn + +@c docstring begin (texi-doc-string "guile" "sort-list") +@deffn primitive sort-list items less +Sort the list @var{items}, using @var{less} for comparing the +list elements. This is a stable sort. +@end deffn + +@c docstring begin (texi-doc-string "guile" "sorted?") +@deffn primitive sorted? items less +Return @code{#t} iff @var{items} is a list or a vector such that +for all 1 <= i <= m, the predicate @var{less} returns true when +applied to all elements i - 1 and i +@end deffn + +@c docstring begin (texi-doc-string "guile" "stable-sort!") +@deffn primitive stable-sort! items less +Sort the sequence @var{items}, which may be a list or a +vector. @var{less} is used for comparing the sequence elements. +The sorting is destructive, that means that the input sequence +is modified to produce the sorted result. +This is a stable sort. +@end deffn + +@c docstring begin (texi-doc-string "guile" "stable-sort") +@deffn primitive stable-sort items less +Sort the sequence @var{items}, which may be a list or a +vector. @var{less} is used for comparing the sequence elements. +This is a stable sort. +@end deffn + + +@node Copying +@section Copying Deep Structures + +@c docstring begin (texi-doc-string "guile" "copy-tree") +@deffn primitive copy-tree obj +Recursively copy the data tree that is bound to @var{obj}, and return a +pointer to the new data structure. @code{copy-tree} recurses down the +contents of both pairs and vectors (since both cons cells and vector +cells may point to arbitrary objects), and stops recursing when it hits +any other object. +@end deffn + + +@c Local Variables: +@c TeX-master: "guile.texi" +@c End: diff --git a/doc/scm.texi b/doc/scm.texi new file mode 100644 index 000000000..68e515933 --- /dev/null +++ b/doc/scm.texi @@ -0,0 +1,453 @@ +@page +@node Scheme Primitives +@c @chapter Writing Scheme primitives in C +@c - according to the menu in guile.texi - NJ 2001/1/26 +@chapter Relationship between Scheme and C functions + +@c Chapter contents contributed by Thien-Thi Nguyen . + +Scheme procedures marked "primitive functions" have a regular interface +when calling from C, reflected in two areas: the name of a C function, and +the convention for passing non-required arguments to this function. + +@c Although the vast majority of functions support these relationships, +@c there are some exceptions. + +@menu +* Transforming Scheme name to C name:: +* Structuring argument lists for C functions:: +@c * Exceptions to the regularity:: +@end menu + +@node Transforming Scheme name to C name +@section Transforming Scheme name to C name + +Normally, the name of a C function can be derived given its Scheme name, +using some simple textual transformations: + +@itemize @bullet + +@item +Replace @code{-} (hyphen) with @code{_} (underscore). + +@item +Replace @code{?} (question mark) with "_p". + +@item +Replace @code{!} (exclamation point) with "_x". + +@item +Replace internal @code{->} with "_to_". + +@item +Replace @code{<=} (less than or equal) with "_leq". + +@item +Replace @code{>=} (greater than or equal) with "_geq". + +@item +Replace @code{<} (less than) with "_less". + +@item +Replace @code{>} (greater than) with "_gr". + +@item +Replace @code{@@} with "at". [Omit?] + +@item +Prefix with "gh_" (or "scm_" if you are ignoring the gh interface). + +@item +[Anything else? --ttn, 2000/01/16 15:17:28] + +@end itemize + +Here is an Emacs Lisp command that prompts for a Scheme function name and +inserts the corresponding C function name into the buffer. + +@example +(defun insert-scheme-to-C (name &optional use-gh) + "Transforms Scheme NAME, a string, to its C counterpart, and inserts it. +Prefix arg non-nil means use \"gh_\" prefix, otherwise use \"scm_\" prefix." + (interactive "sScheme name: \nP") + (let ((transforms '(("-" . "_") + ("?" . "_p") + ("!" . "_x") + ("->" . "_to_") + ("<=" . "_leq") + (">=" . "_geq") + ("<" . "_less") + (">" . "_gr") + ("@" . "at")))) + (while transforms + (let ((trigger (concat "\\(.*\\)" + (regexp-quote (caar transforms)) + "\\(.*\\)")) + (sub (cdar transforms)) + (m nil)) + (while (setq m (string-match trigger name)) + (setq name (concat (match-string 1 name) + sub + (match-string 2 name))))) + (setq transforms (cdr transforms)))) + (insert (if use-gh "gh_" "scm_") name)) +@end example + +@node Structuring argument lists for C functions +@section Structuring argument lists for C functions + +The C function's arguments will be all of the Scheme procedure's +argumements, both required and optional; if the Scheme procedure takes a +``rest'' argument, that will be a final argument to the C function. The +C function's arguments, as well as its return type, will be @code{SCM}. + +@c @node Exceptions to the regularity +@c @section Exceptions to the regularity +@c +@c There are some exceptions to the regular structure described above. + + +@page +@node I/O Extensions +@chapter Using and Extending Ports in C + +@menu +* C Port Interface:: Using ports from C. +* Port Implementation:: How to implement a new port type in C. +@end menu + + +@node C Port Interface +@section C Port Interface + +This section describes how to use Scheme ports from C. + +@subsection Port basics + +There are two main data structures. A port type object (ptob) is of +type @code{scm_ptob_descriptor}. A port instance is of type +@code{scm_port}. Given an @code{SCM} variable which points to a port, +the corresponding C port object can be obtained using the +@code{SCM_PTAB_ENTRY} macro. The ptob can be obtained by using +@code{SCM_PTOBNUM} to give an index into the @code{scm_ptobs} +global array. + +@subsection Port buffers + +An input port always has a read buffer and an output port always has a +write buffer. However the size of these buffers is not guaranteed to be +more than one byte (e.g., the @code{shortbuf} field in @code{scm_port} +which is used when no other buffer is allocated). The way in which the +buffers are allocated depends on the implementation of the ptob. For +example in the case of an fport, buffers may be allocated with malloc +when the port is created, but in the case of an strport the underlying +string is used as the buffer. + +@subsection The @code{rw_random} flag + +Special treatment is required for ports which can be seeked at random. +Before various operations, such as seeking the port or changing from +input to output on a bidirectional port or vice versa, the port +implemention must be given a chance to update its state. The write +buffer is updated by calling the @code{flush} ptob procedure and the +input buffer is updated by calling the @code{end_input} ptob procedure. +In the case of an fport, @code{flush} causes buffered output to be +written to the file descriptor, while @code{end_input} causes the +descriptor position to be adjusted to account for buffered input which +was never read. + +The special treatment must be performed if the @code{rw_random} flag in +the port is non-zero. + +@subsection The @code{rw_active} variable + +The @code{rw_active} variable in the port is only used if +@code{rw_random} is set. It's defined as an enum with the following +values: + +@table @code +@item SCM_PORT_READ +the read buffer may have unread data. + +@item SCM_PORT_WRITE +the write buffer may have unwritten data. + +@item SCM_PORT_NEITHER +neither the write nor the read buffer has data. +@end table + +@subsection Reading from a port. + +To read from a port, it's possible to either call existing libguile +procedures such as @code{scm_getc} and @code{scm_read_line} or to read +data from the read buffer directly. Reading from the buffer involves +the following steps: + +@enumerate +@item +Flush output on the port, if @code{rw_active} is @code{SCM_PORT_WRITE}. + +@item +Fill the read buffer, if it's empty, using @code{scm_fill_input}. + +@item Read the data from the buffer and update the read position in +the buffer. Steps 2) and 3) may be repeated as many times as required. + +@item Set rw_active to @code{SCM_PORT_READ} if @code{rw_random} is set. + +@item update the port's line and column counts. +@end enumerate + +@subsection Writing to a port. + +To write data to a port, calling @code{scm_lfwrite} should be sufficient for +most purposes. This takes care of the following steps: + +@enumerate +@item +End input on the port, if @code{rw_active} is @code{SCM_PORT_READ}. + +@item +Pass the data to the ptob implementation using the @code{write} ptob +procedure. The advantage of using the ptob @code{write} instead of +manipulating the write buffer directly is that it allows the data to be +written in one operation even if the port is using the single-byte +@code{shortbuf}. + +@item +Set @code{rw_active} to @code{SCM_PORT_WRITE} if @code{rw_random} +is set. +@end enumerate + + +@node Port Implementation +@section Port Implementation + +This section describes how to implement a new port type in C. + +As described in the previous section, a port type object (ptob) is +a structure of type @code{scm_ptob_descriptor}. A ptob is created by +calling @code{scm_make_port_type}. + +All of the elements of the ptob, apart from @code{name}, are procedures +which collectively implement the port behaviour. Creating a new port +type mostly involves writing these procedures. + +@code{scm_make_port_type} initialises three elements of the structure +(@code{name}, @code{fill_input} and @code{write}) from its arguments. +The remaining elements are initialised with default values and can be +set later if required. + +@table @code +@item name +A pointer to a NUL terminated string: the name of the port type. This +is the only element of @code{scm_ptob_descriptor} which is not +a procedure. Set via the first argument to @code{scm_make_port_type}. + +@item mark +Called during garbage collection to mark any SCM objects that a port +object may contain. It doesn't need to be set unless the port has +@code{SCM} components. Set using @code{scm_set_port_mark}. + +@item free +Called when the port is collected during gc. It +should free any resources used by the port. +Set using @code{scm_set_port_free}. + +@item print +Called when @code{write} is called on the port object, to print a +port description. e.g., for an fport it may produce something like: +@code{#}. Set using @code{scm_set_port_print}. + +@item equalp +Not used at present. Set using @code{scm_set_port_equalp}. + +@item close +Called when the port is closed, unless it was collected during gc. It +should free any resources used by the port. +Set using @code{scm_set_port_close}. + +@item write +Accept data which is to be written using the port. The port implementation +may choose to buffer the data instead of processing it directly. +Set via the third argument to @code{scm_make_port_type}. + +@item flush +Complete the processing of buffered output data. Reset the value of +@code{rw_active} to @code{SCM_PORT_NEITHER}. +Set using @code{scm_set_port_flush}. + +@item end_input +Perform any synchronisation required when switching from input to output +on the port. Reset the value of @code{rw_active} to @code{SCM_PORT_NEITHER}. +Set using @code{scm_set_port_end_input}. + +@item fill_input +Read new data into the read buffer and return the first character. It +can be assumed that the read buffer is empty when this procedure is called. +Set via the second argument to @code{scm_make_port_type}. + +@item input_waiting +Return a lower bound on the number of bytes that could be read from the +port without blocking. It can be assumed that the current state of +@code{rw_active} is @code{SCM_PORT_NEITHER}. +Set using @code{scm_set_port_input_waiting}. + +@item seek +Set the current position of the port. The procedure can not make +any assumptions about the value of @code{rw_active} when it's +called. It can reset the buffers first if desired by using something +like: + +@example + if (pt->rw_active == SCM_PORT_READ) + scm_end_input (object); + else if (pt->rw_active == SCM_PORT_WRITE) + ptob->flush (object); +@end example + +However note that this will have the side effect of discarding any data +in the unread-char buffer, in addition to any side effects from the +@code{end_input} and @code{flush} ptob procedures. This is undesirable +when seek is called to measure the current position of the port, i.e., +@code{(seek p 0 SEEK_CUR)}. The libguile fport and string port +implementations take care to avoid this problem. + +The procedure is set using @code{scm_set_port_seek}. + +@item truncate +Truncate the port data to be specified length. It can be assumed that the +current state of @code{rw_active} is @code{SCM_PORT_NEITHER}. +Set using @code{scm_set_port_truncate}. + +@end table + + +@node Handling Errors +@chapter How to Handle Errors in C Code + +Error handling is based on catch and throw. Errors are always thrown with +a key and four arguments: + +@itemize @bullet +@item +key: a symbol which indicates the type of error. The symbols used +by libguile are listed below. + +@item +subr: the name of the procedure from which the error is thrown, or #f. + +@item +message: a string (possibly language and system dependent) describing the +error. The tokens %s and %S can be embedded within the message: they +will be replaced with members of the args list when the message is +printed. %s indicates an argument printed using "display", while %S +indicates an argument printed using "write". message can also be #f, +to allow it to be derived from the key by the error handler (may be +useful if the key is to be thrown from both C and Scheme). + +@item +args: a list of arguments to be used to expand %s and %S tokens in message. +Can also be #f if no arguments are required. + +@item +rest: a list of any additional objects required. e.g., when the key is +'system-error, this contains the C errno value. Can also be #f if no +additional objects are required. +@end itemize + +In addition to catch and throw, the following Scheme facilities are +available: + +@itemize @bullet +@item +(scm-error key subr message args rest): throw an error, with arguments +as described above. + +@item +(error msg arg ...) Throw an error using the key 'misc-error. The error +message is created by displaying msg and writing the args. +@end itemize + +The following are the error keys defined by libguile and the situations +in which they are used: + +@itemize @bullet +@item +error-signal: thrown after receiving an unhandled fatal signal such as +SIGSEV, SIGBUS, SIGFPE etc. The "rest" argument in the throw contains +the coded signal number (at present this is not the same as the usual +Unix signal number). + +@item +system-error: thrown after the operating system indicates an error +condition. The "rest" argument in the throw contains the errno value. + +@item +numerical-overflow: numerical overflow. + +@item +out-of-range: the arguments to a procedure do not fall within the +accepted domain. + +@item +wrong-type-arg: an argument to a procedure has the wrong thpe. + +@item +wrong-number-of-args: a procedure was called with the wrong number of +arguments. + +@item +memory-allocation-error: memory allocation error. + +@item +stack-overflow: stack overflow error. + +@item +regex-error: errors generated by the regular expression library. + +@item +misc-error: other errors. +@end itemize + + +@section C Support + +SCM scm_error (SCM key, char *subr, char *message, SCM args, SCM rest) + +Throws an error, after converting the char * arguments to Scheme strings. +subr is the Scheme name of the procedure, NULL is converted to #f. +Likewise a NULL message is converted to #f. + +The following procedures invoke scm_error with various error keys and +arguments. The first three call scm_error with the system-error key +and automatically supply errno in the "rest" argument: scm_syserror +generates messages using strerror, scm_sysmissing is used when +facilities are not available. Care should be taken that the errno +value is not reset (e.g. due to an interrupt). + +@itemize @bullet +@item +void scm_syserror (char *subr); +@item +void scm_syserror_msg (char *subr, char *message, SCM args); +@item +void scm_sysmissing (char *subr); +@item +void scm_num_overflow (char *subr); +@item +void scm_out_of_range (char *subr, SCM bad_value); +@item +void scm_wrong_num_args (SCM proc); +@item +void scm_wrong_type_arg (char *subr, int pos, SCM bad_value); +@item +void scm_memory_error (char *subr); +@item +static void scm_regex_error (char *subr, int code); (only used in rgx.c). +@end itemize + +Exception handlers can also be installed from C, using +scm_internal_catch, scm_lazy_catch, or scm_stack_catch from +libguile/throw.c. These have not yet been documented, however the +source contains some useful comments. diff --git a/doc/scripts.texi b/doc/scripts.texi new file mode 100644 index 000000000..25d4cf2ae --- /dev/null +++ b/doc/scripts.texi @@ -0,0 +1,202 @@ + +@node Guile Scripting +@chapter Guile Scripting + +Like AWK, Perl, or any shell, Guile can interpret script files. A Guile +script is simply a file of Scheme code with some extra information at +the beginning which tells the operating system how to invoke Guile, and +then tells Guile how to handle the Scheme code. + +@menu +* Invoking Guile:: How to start a Guile script. +* The Meta Switch:: Passing complex argument lists to Guile + from shell scripts. +@end menu + +@node Invoking Guile +@section Invoking Guile + +Here we describe Guile's command-line processing in detail. Guile +processes its arguments from left to right, recognizing the switches +described below. For examples, see @ref{Scripting Examples}. + +@table @code + +@item -s @var{script} @var{arg...} +Read and evaluate Scheme source code from the file @var{script}, as the +@code{load} function would. After loading @var{script}, exit. Any +command-line arguments @var{arg...} following @var{script} become the +script's arguments; the @code{command-line} function returns a list of +strings of the form @code{(@var{script} @var{arg...})}. + +@item -c @var{expr} @var{arg...} +Evaluate @var{expr} as Scheme code, and then exit. Any command-line +arguments @var{arg...} following @var{expr} become command-line arguments; the +@code{command-line} function returns a list of strings of the form +@code{(@var{guile} @var{arg...})}, where @var{guile} is the path of the +Guile executable. + +@item -- @var{arg...} +Run interactively, prompting the user for expressions and evaluating +them. Any command-line arguments @var{arg...} following the @code{--} +become command-line arguments for the interactive session; the +@code{command-line} function returns a list of strings of the form +@code{(@var{guile} @var{arg...})}, where @var{guile} is the path of the +Guile executable. + +@item -l @var{file} +Load Scheme source code from @var{file}, and continue processing the +command line. + +@item -e @var{function} +Make @var{function} the @dfn{entry point} of the script. After loading +the script file (with @code{-s}) or evaluating the expression (with +@code{-c}), apply @var{function} to a list containing the program name +and the command-line arguments --- the list provided by the +@code{command-line} function. + +A @code{-e} switch can appear anywhere in the argument list, but Guile +always invokes the @var{function} as the @emph{last} action it performs. +This is weird, but because of the way script invocation works under +POSIX, the @code{-s} option must always come last in the list. + +@xref{Scripting Examples}. + +@item -ds +Treat a final @code{-s} option as if it occurred at this point in the +command line; load the script here. + +This switch is necessary because, although the POSIX script invocation +mechanism effectively requires the @code{-s} option to appear last, the +programmer may well want to run the script before other actions +requested on the command line. For examples, see @ref{Scripting +Examples}. + +@item \ +Read more command-line arguments, starting from the second line of the +script file. @xref{The Meta Switch}. + +@item --emacs +Assume Guile is running as an inferior process of Emacs, and use a +special protocol to communicate with Emacs's Guile interaction mode. +This switch sets the global variable use-emacs-interface to @code{#t}. + +This switch is still experimental. + +@item -h@r{, }--help +Display help on invoking Guile, and then exit. + +@item -v@r{, }--version +Display the current version of Guile, and then exit. + +@end table + + +@node The Meta Switch +@section The Meta Switch + +Guile's command-line switches allow the programmer to describe +reasonably complicated actions in scripts. Unfortunately, the POSIX +script invocation mechanism only allows one argument to appear on the +@samp{#!} line after the path to the Guile executable, and imposes +arbitrary limits on that argument's length. Suppose you wrote a script +starting like this: +@example +#!/usr/local/bin/guile -e main -s +!# +(define (main args) + (map (lambda (arg) (display arg) (display " ")) + (cdr args)) + (newline)) +@end example +The intended meaning is clear: load the file, and then call @code{main} +on the command-line arguments. However, the system will treat +everything after the Guile path as a single argument --- the string +@code{"-e main -s"} --- which is not what we want. + +As a workaround, the meta switch @code{\} allows the Guile programmer to +specify an arbitrary number of options without patching the kernel. If +the first argument to Guile is @code{\}, Guile will open the script file +whose name follows the @code{\}, parse arguments starting from the +file's second line (according to rules described below), and substitute +them for the @code{\} switch. + +Working in concert with the meta switch, Guile treats the characters +@samp{#!} as the beginning of a comment which extends through the next +line containing only the characters @samp{!#}. This sort of comment may +appear anywhere in a Guile program, but it is most useful at the top of +a file, meshing magically with the POSIX script invocation mechanism. + +Thus, consider a script named @file{/u/jimb/ekko} which starts like this: +@example +#!/usr/local/bin/guile \ +-e main -s +!# +(define (main args) + (map (lambda (arg) (display arg) (display " ")) + (cdr args)) + (newline)) +@end example + +Suppose a user invokes this script as follows: +@example +$ /u/jimb/ekko a b c +@end example + +Here's what happens: +@itemize @bullet + +@item +the operating system recognizes the @samp{#!} token at the top of the +file, and rewrites the command line to: +@example +/usr/local/bin/guile \ /u/jimb/ekko a b c +@end example +This is the usual behavior, prescribed by POSIX. + +@item +When Guile sees the first two arguments, @code{\ /u/jimb/ekko}, it opens +@file{/u/jimb/ekko}, parses the three arguments @code{-e}, @code{main}, +and @code{-s} from it, and substitutes them for the @code{\} switch. +Thus, Guile's command line now reads: +@example +/usr/local/bin/guile -e main -s /u/jimb/ekko a b c +@end example + +@item +Guile then processes these switches: it loads @file{/u/jimb/ekko} as a +file of Scheme code (treating the first three lines as a comment), and +then performs the application @code{(main "/u/jimb/ekko" "a" "b" "c")}. + +@end itemize + + +When Guile sees the meta switch @code{\}, it parses command-line +argument from the script file according to the following rules: +@itemize @bullet + +@item +Each space character terminates an argument. This means that two +spaces in a row introduce an argument @code{""}. + +@item +The tab character is not permitted (unless you quote it with the +backslash character, as described below), to avoid confusion. + +@item +The newline character terminates the sequence of arguments, and will +also terminate a final non-empty argument. (However, a newline +following a space will not introduce a final empty-string argument; +it only terminates the argument list.) + +@item +The backslash character is the escape character. It escapes backslash, +space, tab, and newline. The ANSI C escape sequences like @code{\n} and +@code{\t} are also supported. These produce argument constituents; the +two-character combination @code{\n} doesn't act like a terminating +newline. The escape sequence @code{\@var{NNN}} for exactly three octal +digits reads as the character whose ASCII code is @var{NNN}. As above, +characters produced this way are argument constituents. Backslash +followed by other characters is not allowed. + +@end itemize diff --git a/doc/scsh.texi b/doc/scsh.texi new file mode 100644 index 000000000..e69de29bb diff --git a/doc/slib.texi b/doc/slib.texi new file mode 100644 index 000000000..e69de29bb diff --git a/doc/tcltk.texi b/doc/tcltk.texi new file mode 100644 index 000000000..e69de29bb diff --git a/doc/texinfo.tex b/doc/texinfo.tex new file mode 100644 index 000000000..e69de29bb From 4aa8647c0a9ac4c1a72d259ab9e9c07fe5094f69 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 9 Mar 2001 08:28:57 +0000 Subject: [PATCH 0674/2047] Move doc files into guile-core distribution (2) --- doc/ChangeLog | 15 +++++++++++++++ doc/ChangeLog-guile-doc-ref | 0 2 files changed, 15 insertions(+) create mode 100644 doc/ChangeLog-guile-doc-ref diff --git a/doc/ChangeLog b/doc/ChangeLog index 2ccefcd44..aa49e690b 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,5 +1,20 @@ 2001-03-09 Neil Jerram + Moving texinfo files from guile-doc/ref into guile-core/doc: + + * env.texi, indices.texi, mbapi.texi, mltext.texi, scripts.texi, + scsh.texi, tcltk.texi, hierarchy.txt, scheme-indices.texi, + slib.texi, deprecated.texi, scheme-binding.texi, appendices.texi, + scheme-intro.texi, goops.texi, extend.texi, gh.texi, intro.texi, + preface.texi, scm.texi, goops-tutorial.texi, hierarchy.eps, + r4rs.texi, r5rs.texi, texinfo.tex, scheme-reading.texi, + data-rep.texi, scheme-utility.texi, posix.texi, + scheme-control.texi, scheme-debug.texi, scheme-evaluation.texi, + scheme-io.texi, scheme-memory.texi, scheme-modules.texi, + scheme-options.texi, scheme-procedures.texi, + scheme-scheduling.texi, scheme-translation.texi, guile.texi, + scheme-data.texi, scheme-ideas.texi, expect.texi: New files. + Both the following files are about to be replaced by files from guile-doc/ref. diff --git a/doc/ChangeLog-guile-doc-ref b/doc/ChangeLog-guile-doc-ref new file mode 100644 index 000000000..e69de29bb From 009e2b304476992bc9352ac8c3aab6ba6a7482ff Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 9 Mar 2001 08:42:37 +0000 Subject: [PATCH 0675/2047] Move doc files into guile-core distribution (3) --- doc/sources/.cvsignore | 19 + doc/sources/Makefile.am | 7 + doc/sources/contributors.texi | 80 ++++ doc/sources/debug-c.texi | 2 + doc/sources/debug-scheme.texi | 2 + doc/sources/guile-slib.texi | 2 + doc/sources/jimb-org.texi | 131 ++++++ doc/sources/libguile-overview.texi | 30 ++ doc/sources/libguile-tools.texi | 191 +++++++++ doc/sources/new-types.texi | 2 + doc/sources/old-intro.texi | 290 ++++++++++++++ doc/sources/sample-APIs.texi | 6 + doc/sources/scheme-concepts.texi | 249 ++++++++++++ doc/sources/scm-ref.texi | 4 + doc/sources/snarf.texi | 0 doc/sources/strings.texi | 45 +++ doc/sources/tk.texi | 5 + doc/sources/unix-other.texi | 132 ++++++ doc/sources/unix.texi | 622 +++++++++++++++++++++++++++++ 19 files changed, 1819 insertions(+) create mode 100644 doc/sources/.cvsignore create mode 100644 doc/sources/Makefile.am create mode 100644 doc/sources/contributors.texi create mode 100644 doc/sources/debug-c.texi create mode 100644 doc/sources/debug-scheme.texi create mode 100644 doc/sources/guile-slib.texi create mode 100644 doc/sources/jimb-org.texi create mode 100644 doc/sources/libguile-overview.texi create mode 100644 doc/sources/libguile-tools.texi create mode 100644 doc/sources/new-types.texi create mode 100644 doc/sources/old-intro.texi create mode 100644 doc/sources/sample-APIs.texi create mode 100644 doc/sources/scheme-concepts.texi create mode 100644 doc/sources/scm-ref.texi create mode 100644 doc/sources/snarf.texi create mode 100644 doc/sources/strings.texi create mode 100644 doc/sources/tk.texi create mode 100644 doc/sources/unix-other.texi create mode 100644 doc/sources/unix.texi diff --git a/doc/sources/.cvsignore b/doc/sources/.cvsignore new file mode 100644 index 000000000..dc9df74a2 --- /dev/null +++ b/doc/sources/.cvsignore @@ -0,0 +1,19 @@ +Makefile +stamp-vti +*.log +*.dvi +*.aux +*.toc +*.cp +*.fn +*.vr +*.tp +*.ky +*.pg +*.cps +*.fns +*.tps +*.vrs +*.ps +*.info* +version.texi diff --git a/doc/sources/Makefile.am b/doc/sources/Makefile.am new file mode 100644 index 000000000..d201637e4 --- /dev/null +++ b/doc/sources/Makefile.am @@ -0,0 +1,7 @@ +# -*- Makefile -*- + +EXTRA_DIST = libguile-overview.texi snarf.texi contributors.texi \ + libguile-tools.texi strings.texi data-rep.texi new-types.texi tk.texi \ + debug-c.texi old-intro.texi unix-other.texi debug-scheme.texi \ + sample-APIs.texi unix.texi guile-slib.texi scheme-concepts.texi \ + jimb-org.texi scm-ref.texi diff --git a/doc/sources/contributors.texi b/doc/sources/contributors.texi new file mode 100644 index 000000000..578c358f7 --- /dev/null +++ b/doc/sources/contributors.texi @@ -0,0 +1,80 @@ +@node Contributors to Guile +@appendix Contributors to Guile + +This Guile Manual was written by Mark Galassi, Jim Blandy and Gary +Houston. + +Guile was developed over many years by the following people: + +@table @strong +@item George Carrette +Wrote files present in Siod version 2.3, released in December of 1989. + +@item Aubrey Jaffer +Wrote substantial portions of guile.texi, and surely others. +Changes to: eval.c, ioext.c, posix.c, gscm.c, scm.h, socket.c, +gsubr.c, sys.c, test.scm, stime.c, and unif.c. + +@item Gary Houston +changes to many files in libguile. + +wrote: libguile/socket.c, ice-9/expect.scm + +@item Tom Lord +Many changes throughout. +In the subdirectory ctax, wrote: + Makefile.in configure.in hashtabs.scm macros.scm scm-ops.scm + c-ops.scm grammar.scm lexer.scm reader.scm +In the subdirectory gtcltk-lib, wrote: + Makefile.in guile-tcl.c guile-tk.c + configure.in guile-tcl.h guile-tk.h +In the subdirectory guile, wrote: + Makefile.in getopt.c getopt1.c + configure.in getopt.h guile.c +In the subdirectory ice-9, wrote: + Makefile.in configure.in lineio.scm poe.scm + boot-9.scm hcons.scm mapping.scm +In the subdirectory lang, wrote: + Makefile.in grammar.scm lr0.scm pp.scm + configure.in lex.scm lr1.scm +In the subdirectory rx, wrote: + Makefile.in runtests.c rxbitset.h rxnfa.c rxspencer.c + TESTS rx.c rxcontext.h rxnfa.h rxspencer.h + TESTS2C.sed rx.h rxcset.c rxnode.c rxstr.c + _rx.h rxall.h rxcset.h rxnode.h rxstr.h + configure.in rxanal.c rxdbug.c rxposix.c rxsuper.c + hashrexp.c rxanal.h rxgnucomp.c rxposix.h rxsuper.h + inst-rxposix.h rxbasic.c rxgnucomp.h rxproto.h rxunfa.c + rgx.c rxbasic.h rxhash.c rxsimp.c rxunfa.h + rgx.h rxbitset.c rxhash.h rxsimp.h testcases.h +In the subdirectory doc, wrote: + ctax.texi gtcltk.texi in.texi lang.texi +and portions of guile.texi. + +@item Anthony Green +wrote the original code in the 'threads' directory, and +ice-9/threads.scm. + +@item Mikael Djurfeldt +@example +In the subdirectory libguile, wrote: + backtrace.c debug.c options.c root.c srcprop.c stacks.c + backtrace.h debug.h options.h root.h srcprop.h stacks.h +In the subdirectory threads, rewrote: + coop-threads.c coop.c mit-pthreads.c threads.c + coop-threads.h fsu-pthreads.h mit-pthreads.h threads.h +Many other changes throughout. +@end example + +@item Mark Galassi +@example +Designed and implemented the high-level libguile API (the @code{gh_} +interface), based largely on the defunct @code{gscm_} interface. In the +subdirectory gh, wrote: +gh.c gh_eval.c gh_io.c gh_test_c.c +gh.h gh_funcs.c gh_list.c gh_test_repl.c +gh_data.c gh_init.c gh_predicates.c +@end example + + +@end table diff --git a/doc/sources/debug-c.texi b/doc/sources/debug-c.texi new file mode 100644 index 000000000..77d02f440 --- /dev/null +++ b/doc/sources/debug-c.texi @@ -0,0 +1,2 @@ +@node Debugging libguile +@chapter Debugging libguile diff --git a/doc/sources/debug-scheme.texi b/doc/sources/debug-scheme.texi new file mode 100644 index 000000000..35340f943 --- /dev/null +++ b/doc/sources/debug-scheme.texi @@ -0,0 +1,2 @@ +@node Debugging Scheme programs +@chapter Debugging Scheme programs diff --git a/doc/sources/guile-slib.texi b/doc/sources/guile-slib.texi new file mode 100644 index 000000000..c8f07d1b2 --- /dev/null +++ b/doc/sources/guile-slib.texi @@ -0,0 +1,2 @@ +@node Guile and SLIB +@chapter Guile and SLIB diff --git a/doc/sources/jimb-org.texi b/doc/sources/jimb-org.texi new file mode 100644 index 000000000..5ec4216db --- /dev/null +++ b/doc/sources/jimb-org.texi @@ -0,0 +1,131 @@ +@menu +Preliminary + +* Introduction:: +* Using Guile:: + + + +@bye + +>You can actually put any English text to break up the menu, so you +>could put the "Part n" headings in it. + + + +Introduction + --- Explains Guile's goals, and gives brief examples of how to use + Guile interactively (show off repl), as a script interpreter, + and as an embedded interpreter. + +Part I: Guile Scheme + R4RS Scheme as a Starting Point + --- Here we refer to R4RS, and explain that we're only + describing differences. + Block comments and interpreter triggers + Symbol case + Keywords + Exceptions + Modules + --- the preceeding three come first, because we need them + in order to explain the behavior of some things later + Exception Handling + --- mention that repls usually establish default exception handlers + Dynamic Wind + Records + Structures + Arrays + Binary Numeric Operations + Shared and Read-Only Strings + Object Properties + Association Lists and Hash Tables + (Dictionaries In General) + association lists + hash tables (Hash Values) + Input/Output ports + file ports + soft ports + string ports + extended I/O (fseek; line read/write) + Garbage Collection + Threads and Dynamic Roots + Reflection + eval + Tag Values + Weak references + Regular Expressions + SLIB + POSIX system calls and networking + --- I think people will generally know whether they're looking + for a system call or not, so this should be an okay category. + conventions (includes error handling) + ports vs. file descriptors + file system (mknod goes here, no?) + user database + time (includes gettimeofday or whatever, strftime, strptime) + processes + terminals and pseudo-terminals + pipes + networking (includes databases, address conversion, and sockets) + system identification (uname) + locales (setlocale) + --- Note that there is no more 'misc'. It's better to have + small sections than unhelpful names. + SCSH + --- includes info on how to get SCSH features (open this + module), but mostly just a pointer to the SCSH manual. + This should not be under POSIX. SCSH includes plenty of + high-level stuff for starting processes and string + processing. SCSH is not a subset of POSIX, nor the + reverse. + Tcl/Tk interface + Module internals + first-class variables + first-class modules + internal debugging interface + --- The name of this chapter needs to clearly distinguish it + from the appendix describing the debugger UI. The intro + should have a pointer to the UI appendix. + +Part II: Using Scheme with C --- a Portable Interface + --- We cover gh in a completely separate section. Why? I admit + I'm on shaky ground, but here's my reasoning: People who want + to write portable C code need to restrict themselves to only + using GH, and GH's semantics are (necessarily) well-defined + without reference to Guile's particulars. This makes life + more difficult for folks who just prefer to use the GH + interface when they can, but I really think the SCM interface + is not so bad, once you're used to it. A *lot* of GH + functions are just wrappers for SCM functions. + --- We cover repls here too, since GH has repl functions. + +Part III: Using Scheme with C --- Guile's Interface + Scheme data representation + Relationship between Scheme and C functions + --- this is where we explain that all the functions marked as + "Primitive Functions" are also accessible from C, and how + to derive the C interface given the Scheme interface, when + we don't spell it out. + ... I think there's other stuff needed here ... + I/O internals + linking Guile with your code + --- Mark's "Tools to automate adding libraries" is not a + well-defined concept. I think this is closer to what we + want to cover for now. + snarfing + +Appendices: + Obtaining and Installing Guile + Invoking Guile + --- mentions read-eval-print loops + --- both the SCSH and GAWK manuals relegate invocation details + to an appendix. We can give examples in the introduction. + debugger user interface + --- The title and introduction of this appendix need to + distinguish this clearly from the chapter on the internal + debugging interface. + +Indices: + --- At the top of the function/variable index, remind people + to look for functions under their Scheme names as well as + their C names. diff --git a/doc/sources/libguile-overview.texi b/doc/sources/libguile-overview.texi new file mode 100644 index 000000000..96a4a76ce --- /dev/null +++ b/doc/sources/libguile-overview.texi @@ -0,0 +1,30 @@ +@node Libguile overview +@chapter Libguile overview +@cindex libguile - overview + +Extension languages, like Guile, Python and Tcl, can be embedded into a +C program, @footnote{Or a C++ or Fortran or Pascal program if you want.} +and thus allow the user to @emph{extend} the C program. + +The way this is done is by providing a C language library with a well +defined interface. The interface consists of a set of public and +documented C-callable routines that offer the full interpreter +functionality, and allow the conversion of data between C and the +extension language. + +@menu +* An example of libguile functionality:: +* What can be done with libguile:: +* Schizofrenia -- two APIs:: +@end menu + +@node An example of libguile functionality +@section An example of libguile functionality + +[Two examples: using strings and using data conversion.] + +@node What can be done with libguile +@section What can be done with libguile + +@node Schizofrenia -- two APIs +@section Schizofrenia -- two APIs diff --git a/doc/sources/libguile-tools.texi b/doc/sources/libguile-tools.texi new file mode 100644 index 000000000..d434406e9 --- /dev/null +++ b/doc/sources/libguile-tools.texi @@ -0,0 +1,191 @@ +@node Tools to automate adding libraries +@chapter Tools to automate adding libraries + +You want to ... + +The chapters @ref{Libguile -- high level interface} and @ref{Libguile -- +SCM interface} showed how to make C libraries available from Scheme. +Here I will describe some automated tools that the Guile team has made +available. Some have been written especially for Guile (the Guile Magic +Snarfer), and some are also in use with other languages (Python, Perl, +...) + +@menu +* By hand with gh_:: +* By hand with Guile Magic Snarfer:: +* Automatically using libtool:: +* Automatically using SWIG:: +@end menu + +@node By hand with gh_ +@section By hand with gh_ + +@node By hand with Guile Magic Snarfer +@section By hand with Guile Magic Snarfer + +When writing C code for use with Guile, you typically define a set of C +functions, and then make some of them visible to the Scheme world by +calling the @code{scm_make_gsubr} function; a C functions published in +this way is called a @dfn{subr}. If you have many subrs to publish, it +can sometimes be annoying to keep the list of calls to +@code{scm_make_gsubr} in sync with the list of function definitions. +Frequently, a programmer will define a new subr in C, recompile his +application, and then discover that the Scheme interpreter cannot see +the subr, because he forgot to call @code{scm_make_gsubr}. + +Guile provides the @code{guile-snarf} command to manage this problem. +Using this tool, you can keep all the information needed to define the +subr alongside the function definition itself; @code{guile-snarf} will +extract this information from your source code, and automatically +generate a file of calls to @code{scm_make_gsubr} which you can +@code{#include} into an initialization function. (The command name +comes from the verb ``to snarf'', here meaning ``to unceremoniously +extract information from a somewhat unwilling source.'') + +@menu +* How guile-snarf works:: Using the @code{guile-snarf} command. +* Macros guile-snarf recognizes:: How to mark up code for @code{guile-snarf}. +@end menu + +@node How guile-snarf works +@subsection How @code{guile-snarf} works + +For example, here is how you might define a new subr called +@code{clear-image}, implemented by the C function @code{clear_image}: + +@example +@group +#include + +@dots{} + +SCM_PROC (s_clear_image, "clear-image", 1, 0, 0, clear_image); + +SCM +clear_image (SCM image_smob) +@{ + @dots{} +@} + +@dots{} + +void +init_image_type () +@{ +#include "image-type.x" +@} +@end group +@end example + +The @code{SCM_PROC} declaration says that the C function +@code{clear_image} implements a Scheme subr called @code{clear-image}, +which takes one required argument, no optional arguments, and no tail +argument. @code{SCM_PROC} also declares a static array of characters +named @code{s_clear_image}, initialized to the string +@code{"clear-image"}. The body of @code{clear_image} may use the array +in error messages, instead of writing out the literal string; this may +save string space on some systems. + +Assuming the text above lives in a file named @file{image-type.c}, you will +need to execute the following command to compile this file: +@example +guile-snarf image-type.c > image-type.x +@end example +@noindent This scans @file{image-type.c} for @code{SCM_PROC} +declarations, and sends the following output to the file +@file{image-type.x}: +@example +scm_make_gsubr (s_clear_image, 1, 0, 0, clear_image); +@end example +When compiled normally, @code{SCM_PROC} is a macro which expands to a +declaration of the @code{s_clear_image} string. + +In other words, @code{guile-snarf} scans source code looking for uses of +the @code{SCM_PROC} macro, and generates C code to define the +appropriate subrs. You need to provide all the same information you +would if you were using @code{scm_make_gsubr} yourself, but you can +place the information near the function definition itself, so it is less +likely to become incorrect or out-of-date. + +If you have many files that @code{guile-snarf} must process, you should +consider using a rule like the following in your Makefile: +@example +.SUFFIXES: .x +.c.x: + ./guile-snarf $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ +@end example +This tells make to run @code{guile-snarf} to produce each needed +@file{.x} file from the corresponding @file{.c} file. + +@code{guile-snarf} passes all its command-line arguments directly to the +C preprocessor, which it uses to extract the information it needs from +the source code. this means you can pass normal compilation flags to +@code{guile-snarf} to define preprocessor symbols, add header file +directories, and so on. + + + +@node Macros guile-snarf recognizes +@subsection Macros @code{guile-snarf} recognizes + +Here are the macros you can use in your source code from which +@code{guile-snarf} can construct initialization code: + + +@defmac SCM_PROC (@var{namestr}, @var{name}, @var{req}, @var{opt}, @var{tail}, @var{c_func}) +Declare a new Scheme primitive function, or @dfn{subr}. The new subr +will be named @var{name} in Scheme code, and be implemented by the C +function @var{c_func}. The subr will take @var{req} required arguments +and @var{opt} optional arguments. If @var{tail} is non-zero, the +function will accept any remaining arguments as a list. + +Use this macro outside all function bodies, preferably above the +definition of @var{c_func} itself. When compiled, the @code{SCM_PROC} +declaration will expand to a definition for the @var{namestr} array, +initialized to @var{name}. The @code{guile-snarf} command uses this +declaration to automatically generate initialization code to create the +subr and bind it in the top-level environment. @xref{How guile-snarf +works}, for more info. + +@xref{Subrs}, for details on argument passing and how to write +@var{c_func}. +@end defmac + + +@defmac SCM_GLOBAL (@var{var}, @var{scheme_name}) +Declare a global Scheme variable named @var{scheme_name}, and a static C +variable named @var{var} to point to it. The value of the Scheme +variable lives in the @sc{cdr} of the cell @var{var} points to. +Initialize the variable to @code{#f}. + +Use this macro outside all function bodies. When compiled, the +@code{SCM_GLOBAL} macro will expand to a definition for the variable +@var{var}, initialized to an innocuous value. The @code{guile-snarf} +command will use this declaration to automatically generate code to +create a global variable named @var{scheme_name}, and store a pointer to +its cell in @var{var}. +@end defmac + + +@defmac SCM_CONST_LONG (@var{var}, @var{scheme_name}, @var{value}) +Like @code{SCM_GLOBAL}, but initialize the variable to @var{value}, +which must be an integer. +@end defmac + + +@defmac SCM_SYMBOL (@var{var}, @var{name}) +Declare a C variable of type @code{SCM} named @var{var}, and initialize +it to the Scheme symbol object whose name is @var{name}. + +Use this macro outside all function bodies. When compiled, the +@code{SCM_SYMBOL} macro will expand to a definition for the variable +@var{var}, initialized to an innocuous value. The @code{guile-snarf} +command will use this declaration to automatically generate code to +create a symbol named @var{name}, and store it in @var{var}. +@end defmac + +@node Automatically using libtool +@section Automatically using libtool + +@node Automatically using SWIG +@section Automatically using SWIG diff --git a/doc/sources/new-types.texi b/doc/sources/new-types.texi new file mode 100644 index 000000000..1840b214f --- /dev/null +++ b/doc/sources/new-types.texi @@ -0,0 +1,2 @@ +@node Adding types to Guile +@chapter Adding types to Guile diff --git a/doc/sources/old-intro.texi b/doc/sources/old-intro.texi new file mode 100644 index 000000000..0774f64d4 --- /dev/null +++ b/doc/sources/old-intro.texi @@ -0,0 +1,290 @@ +@node Introduction +@chapter Introduction + +Guile is an interpreter for Scheme, a clean, economical programming +language in the Lisp family. You can invoke Guile from the shell to +evaluate Scheme expressions interactively, or use it as an interpreter +for script files. However, Guile is also packaged as a library, to be +embedded as an extension language into other applications. The +application can supplement the base language with special-purpose +functions and datatypes, allowing the user to customize and extend it by +writing Scheme code. + +In its simplest form, Guile is an ordinary interpreter. The +@code{guile} program can read and evaluate Scheme expressions entered +from the terminal. Here is a sample interaction between Guile and a +user; the user's input appears after the @code{$} and @code{guile>} +prompts: + +@example +$ guile +guile> (+ 1 2 3) ; add some numbers +6 +guile> (define (factorial n) ; define a function + (if (zero? n) 1 (* n (factorial (- n 1))))) +guile> (factorial 20) +2432902008176640000 +guile> (getpwnam "jimb") ; find my entry in /etc/passwd +#("jimb" ".0krIpK2VqNbU" 4008 10 "Jim Blandy" "/u/jimb" + "/usr/local/bin/bash") +guile> @kbd{C-d} +$ +@end example + +Guile can also interpret script files. For example, here is a Guile script +containing a script which displays the + + +application can +supplement the base language with its own functions, datatypes and +syntax, allowing the user to extend and + + + Guile interpret + +. An +application the Guile interpreter to allow + + +, allowing +applications to incorporate the Scheme interpreter for customization + +[[interactive]] +[[script interpreter]] +[[embedded]] + +[[other languages]] +The concept of an extension language library does not originate with +Guile. However, Guile is the first to offer users a choice of languages +to program in. + + +Guile currently supports Scheme and Ctax , and we expect to support Emacs Lisp in the near future. + + +Scheme is powerful enough that other languages can be +conveniently translated into it, + +However, unlike other extension packages, Guile gives users a choice of +languages to program in. Guile can + + +In this sense, Guile resembles the Tcl and Python packages, providing +both an ordinary interpreter and an extension language library. +However, unlike those packages, Guile supports more than one programming +language. + +; users can +write Scheme code to control and customize applications which +incorporate Guile + +, adding their own functions, +datatypes, and syntax, to allow the user to programm + + +link it into your own programs to make them + + + +Guile is a library containing an interpreter for Scheme, a complete but +economical programming language, which the developer can customize to +suit the application at hand by adding new functions, data types, and +control structures. These may be implemented in C, and then +``exported'' for use by the interpreted code. Because Guile already +provides a full-featured interpreter, the developer need not neglect the +language's design in order to concentrate on code relevant to the task. +In this way, Guile provides a framework for the construction of +domain-specific languages. + +Guile provides first-class functions, a rich set of data types, +exception handling, a module system, and a powerful macro facility. +Guile also supports dynamic linking and direct access to Unix system +calls. Releases in the near future will support a source-level +debugger and bindings for the Tk user interface toolkit. + + + +Guile is a framework for writing applications controlled by specialized +languages. In its simplest form, Guile is an interpreter for Scheme, a +clean, economical programming language in the Lisp family. However, +Guile is packaged as a library, allowing applications to link against it +and use Scheme as their extension language. The application can add +primitive functions to the language, implement new data types, and even +adjust the language's syntax. + + + +[the introduction is probably not what Jim has in mind; I just took the +one I had in earlier, since the file had the same name intro.texi] + +Guile is an implementation of the Scheme programming language, but, like +other modern implementations of Scheme, it adds many features that the +community of Scheme programmers considers necessary for an ``industrial +strength'' language. + +Examples of extensions to Scheme are the module system +(@pxref{Modules}), the Unix system programming tools (@pxref{POSIX +system calls and networking} and @pxref{The Scheme shell (scsh)}), an +interface to @emph{libtool} to make it easier to add C libraries as +primitives (@pxref{Linking Guile with your code}), and (FIXME add more). + +On top of these extensions, which many other Scheme implementations +provide, Guile also offers the possibility of writing routines in other +languages and running them simultaneously with Scheme. The desire to +implement other languages (in particular Emacs Lisp) on top of Scheme is +responsible for Guile's only deviation from the R4RS @footnote{R4RS is +the Revised^4 Report on the Algorithmic Language Scheme, the closest +thing to a standard Scheme specification today} Scheme standard +(@cite{r4rs}): Guile is case sensitive, whereas ``standard'' Scheme is +not. + +But even more fundamentally, Guile is meant to be an @emph{embeddable} +Scheme interpreter. This means that a lot of work has gone into +packaging the interpreter as a C library (@pxref{A Portable C to Scheme Interface} and @pxref{Scheme data representation}). + +This reference manual is mainly driven by the need to document all the +features that go beyond standard Scheme. + +@menu +* Getting started:: +* Guile feature list:: +* What you need to use Guile:: +* Roadmap to the Manual:: +* Motivation for Guile:: +* History of Guile:: +@end menu + +@node Getting started +@section Getting started + +We assume that you know how to program in Scheme, although we do not +assume advanced knowledge. If you don't know Scheme, there are many +good books on Scheme at all levels, and the Guile Tutorial might give +you a good enough feel for the language. We also assume that you know +how to program in C, since there will be many examples of how to program +in C using Guile as a library. + +Many diverse topics from the world of Unix hacking will be covered here, +such as shared libraries, socket programming, garbage collection, and so +forth. If at any time you feel you don't have enough background on a +given topic, just go up a level or two in the manual, and you will find +that the chapter begins with a few paragraphs that introduce the topic. +If you are still lost, read through the Guile tutorial and then come +back to this reference manual. + +To run the core Guile interpreter and extension library you need no more +than a basically configured GNU/Unix system and the Guile sources. You +should download and install the Guile sources (@pxref{Obtaining and +Installing Guile}). + + +@node Guile feature list +@section Guile feature list + +In a reductionist view, Guile could be regarded as: +@itemize @bullet +@item +An R4RS-compliant Scheme interpreter. + +@item +Some Scheme features that go beyond the R4RS standard, notably a module +system, exception handling primitives and an interface to Aubrey +Jaffer's SLIB. + +@item +A symbolic debugger for Scheme, and gdb extensions to facilitate +debugging libguile programs. + +@item +An embeddable version of the same interpreter, called @emph{libguile}. + +@item +A portable high level API on top of libguile (the @code{gh_} interface). + +@item +A collection of bundled C libraries with a Guile API. As we write, this +list includes: + +@table @strong +@item Rx +a regular expression library. + +@item Unix +a low-level interface to the POSIX system calls, socket library +and other Unix system services. + +@item Tk +an interface to John Ousterhout's Tk toolkit. + +@end table + +@item +A set of tools for implementing other languages @emph{on top of Scheme}, +and an example implementation of a language called @emph{Ctax}. + + +@end itemize + + +@node What you need to use Guile +@section What you need to use Guile + + +@node Roadmap to the Manual +@section Roadmap to the Manual + +@node Motivation for Guile +@section Motivation for Guile + +@node History of Guile +@section History of Guile + +@page +@node Using Guile +@chapter Using Guile + +[I think that this might go in the appendix in Jim's view of the manual] + +@page +@node Invoking Guile +@appendix Invoking Guile + --- mentions read-eval-print loops + --- both the SCSH and GAWK manuals relegate invocation details + to an appendix. We can give examples in the introduction. + +@table @samp +@item -h +@itemx --help +Display a helpful message. +@item -v +@item --version +Display the current version. +@item --emacs +To be used for emacs editing support. +@item -s @var{file} +Process @var{file} as a script then quit. This is a terminating option: +any further command line arguments can be accessed by the script using +the @code{(program-arguments)} procedure. + +An executable script can start with the following: + +@smallexample +#!/usr/bin/guile -s +!# +@end smallexample + +Note the @code{!#} token on the second line. It is very important +to include this token when writing Guile scripts. Guile and SCSH, +the Scheme shell, share the convention that @code{#!} and +@code{!#} may be used to mark block comments (@pxref{Block +comments and interpreter triggers}). If the closing @code{!#} +token is not included, then Guile will consider the block comment +to be unclosed, and the script will probably not compile +correctly. + +It is also important to include the @samp{-s} option at the +beginning of the Guile script, so that Guile knows not to behave +in an interactive fashion. + +@end table + diff --git a/doc/sources/sample-APIs.texi b/doc/sources/sample-APIs.texi new file mode 100644 index 000000000..c8c4b8e72 --- /dev/null +++ b/doc/sources/sample-APIs.texi @@ -0,0 +1,6 @@ +@node Examples of adding libraries +@chapter Examples of adding libraries + +Should contain examples of brute-force gh_, Guile magic snarfer, +libtool, SWIG on a dummy API, followed by some real examples of how +libraries are added. diff --git a/doc/sources/scheme-concepts.texi b/doc/sources/scheme-concepts.texi new file mode 100644 index 000000000..e8e78f14d --- /dev/null +++ b/doc/sources/scheme-concepts.texi @@ -0,0 +1,249 @@ +@node Guile Scheme concepts +@chapter Guile Scheme concepts + +Most Scheme implementations go beyond what is specified in the R4RS +document @footnote{Remember? R4RS is the Revised^4 report on the +Algorithmic Language Scheme}, mostly because R4RS does not give +specifications (or even recommendations) regarding some issues that are +quite important in practical programming. + +Here is a list of how Guile implements some of these much-needed Scheme +extensions; other Scheme implementations do so quite similarly. + +@menu +* Scheme slang:: +* Read-eval-print loops:: +* Extra data types:: +* Miscellaneous features:: +@end menu + +@node Scheme slang +@section Scheme slang +@cindex slang + +Even if you read some of the nice books on Scheme, or the R4RS report, +you might not find some of the terms frequently used by Scheme hackers, +both in the manual and in the @url{news:comp.lang.scheme} newsgroup. + +Here is a glossary of some of the terms that make Scheme beginners and +intermediate users say ``huh?'' + +@table @strong +@item thunk +@cindex thunk +A Scheme procedure that takes no arguments. In this example, +@code{thunk} and @code{another-thunk} are both thunks: +@lisp +(define (thunk) + (display "Dude, I'm a thunk!") + (newline)) +(define another-thunk + (lambda () + (display "Me too!\n") + (newline))) +@end lisp + +@item closure +@cindex closure +A closure is a procedure. However, the term emphasizes the fact that a +Scheme procedure remembers (or @dfn{closes over}) the variables that +were visible when the @code{lambda} expression was +evaluated. + +In the example below, we might refer to @code{q} as a closure, because +it has closed over the value of @code{x}: +@lisp +(define p + (lambda (x) + (lambda (y) + (+ x y)))) +(define q (p 5.7)) + +(q 10) +@result{} 15.7 +@end lisp + +However, strictly speaking, every Scheme procedure is really a closure, +since it closes over the top-level environment. + +@item alist +@itemx association list + +@item plist +@itemx property list + +@end table + + +@node Read-eval-print loops +@section Read-eval-print loops +@cindex Read-eval-print loop +@cindex REPL + +To explicitly mention the Scheme read-eval-print loop (REPL) seems weird +because we are all accustomed to firing up an interpreter and having it +read and execute commands. + +But the REPL is not specified in R4RS; rather, it is proposed by the +Scheme Bible @cite{Structure and Interpretation of Computer Programs} +(also known as @emph{SICP}), and implemented in some form in all Scheme +interpreters. +@cindex Structure and Interpretation of Computer Programs +@cindex SICP + +[FIXME: Someone needs to tell me what needs to be said about Guile's +REPL.] + +@node Extra data types +@section Extra data types + +The fundamental Scheme data types specified in R4RS are @emph{numbers} +(both exact and inexact), @emph{characters}, @emph{strings}, +@emph{symbols}, @emph{vectors}, @emph{pairs} and @emph{lists} [FIXME: is +this complete?]. + +Many Scheme interpreters offer more types, and Guile is no exception. +Guile is based on Aubrey Jaffer's SCM interpreter, and thus inherits +@emph{uniform arrays}, [FIXME: any others? How about records?]. + +On top of that, Guile allows you to add extra types, but that is covered +in @ref{Adding types to Guile}. Here I will simply document all the +extra Scheme types shipped with Guile. + +@menu +* Conventional arrays:: +* Uniform arrays:: +* Bit vectors:: +* Complex numbers:: +@end menu + +@node Conventional arrays +@subsection Conventional arrays + +@node Uniform arrays +@subsection Uniform arrays +@cindex arrays - uniform + +The motivation for uniform arrays in Scheme is performance. A vector +provides a performance increase over lists when you want a fixed-size +indexable list. But the elements in a vector can be of different types, +and this makes for larger storage requirements and slightly lower +performance. + +A uniform array is similar to a vector, but all elements have to be of +the same type. + +arrays, uniform arrays, bit vectors: + +@deffn procedure array-fill ra fill +@end deffn +@deffn procedure serial-array-copy! src dst +@end deffn +@deffn procedure serial-array-map ra0 proc [lra] +@end deffn +@deffn procedure array-map ra0 proc [lra] +@end deffn +@deffn procedure array-for-each proc ra0 [lra] +@end deffn +@deffn procedure array-index-map! ra proc +@end deffn +@deffn procedure array-copy! src dst +@end deffn +@deffn procedure array-copy! src dst +@end deffn +@deffn procedure array-copy! src dst +@end deffn +@deffn procedure array-copy! src dst +@end deffn +@deffn procedure array-copy! src dst +@end deffn +@deffn procedure array? ra [prot] +@end deffn +@deffn procedure array-rank ra +@end deffn +@deffn procedure array-dimensions ra +@end deffn +@deffn procedure dimensions->uniform-array dims prot fill ... +@end deffn +@deffn procedure make-shared-array ra mapfunc dims ... +@end deffn +@deffn procedure transpose-array arg ... +@end deffn +@deffn procedure enclose-array axes ... +@end deffn +@deffn procedure array-in-bounds? arg ... +@end deffn +@deffn procedure array-ref ra arg .. +@end deffn +@deffn procedure uniform-vector-ref vec pos +@end deffn +@deffn procedure array-set! ra obj arg ... +@end deffn +@deffn procedure uniform-array-set1! ua obj arg +@end deffn +@deffn procedure array-contents ra [strict] +@end deffn +@deffn procedure uniform-array-read! ra [port-or-fd] [start] [end] +@end deffn +@deffn procedure uniform-array-write! ra [port-or-fd] [start] [end] +@end deffn +@deffn procedure bit-count item seq +@end deffn +@deffn procedure bit-position item v k +@end deffn +@deffn procedure bit-set! v kv obj +@end deffn +@deffn procedure bit-count* v kv obj +@end deffn +@deffn procedure bit-invert v +@end deffn +@deffn procedure array->list ra +@end deffn +@deffn procedure list->uniform-array ndim prot list +@end deffn +@deffn procedure array-prototype ra +@end deffn + +Unform arrays can be written and read, but @code{read} won't recognize +them unless the optional @code{read-sharp} parameter is supplied, +e.g, +@smalllisp +(read port #t read-sharp) +@end smalllisp + +where @code{read-sharp} is the default procedure for parsing extended +sharp notations. + +Reading an array is not very efficient at present, since it's implemented +by reading a list and converting the list to an array. + +@c FIXME: must use @deftp, but its generation of TeX code is buggy. +@c Must fix it when TeXinfo gets fixed. +@deftp {Scheme type} {uniform array} + +@end deftp + +@node Bit vectors +@subsection Bit vectors + +@node Complex numbers +@subsection Complex numbers + +@c FIXME: must use @deftp, but its generation of TeX code is buggy. +@c Must fix it when TeXinfo gets fixed. +@deftp {Scheme type} complex +Standard complex numbers. +@end deftp + +@node Miscellaneous features +@section Miscellaneous features + +@defun defined? symbol +Returns @code{#t} if a symbol is bound to a value, @code{#f} otherwise. +This kind of procedure is not specified in R4RS because @c FIXME: finish +this thought +@end defun + +@defun object-properties OBJ +and so forth +@end defun diff --git a/doc/sources/scm-ref.texi b/doc/sources/scm-ref.texi new file mode 100644 index 000000000..eca672580 --- /dev/null +++ b/doc/sources/scm-ref.texi @@ -0,0 +1,4 @@ +@node Libguile -- SCM interface +@chapter Libguile -- SCM interface + + diff --git a/doc/sources/snarf.texi b/doc/sources/snarf.texi new file mode 100644 index 000000000..e69de29bb diff --git a/doc/sources/strings.texi b/doc/sources/strings.texi new file mode 100644 index 000000000..9a1ddc952 --- /dev/null +++ b/doc/sources/strings.texi @@ -0,0 +1,45 @@ +@node Strings +@chapter Facilities for string manipulation + +@deffn procedure string? string +@end deffn +@deffn procedure read-only-string? string +@end deffn +@deffn procedure list->string list +@end deffn +@deffn procedure make-string length [char] +@end deffn +@deffn procedure string-length string +@end deffn +@deffn procedure string-ref string [index] +@end deffn +@deffn procedure string-set! string index char +@end deffn +@deffn procedure substring string start [end] +@end deffn +@deffn procedure string-append arg ... +@end deffn +@deffn procedure make-shared-substring string [from] [to] +@end deffn +@deffn procedure string-set! string index char +@end deffn +@deffn procedure string-index string char [from] [to] +@end deffn +@deffn procedure string-rindex string char [from] [to] +@end deffn +@deffn procedure substring-move-left! string1 start1 [end1] [string2] [start2] +@end deffn +@deffn procedure substring-move-right! string1 start1 [end1] [string2] [start2] +@end deffn +@deffn procedure substring-fill! string start [end] [fill] +@end deffn +@deffn procedure string-null? string +@end deffn +@deffn procedure string->list string +@end deffn +@deffn procedure string-copy string +@end deffn +@deffn procedure string-upcase! string +@end deffn +@deffn procedure string-downcase! string +@end deffn diff --git a/doc/sources/tk.texi b/doc/sources/tk.texi new file mode 100644 index 000000000..176c8c7b8 --- /dev/null +++ b/doc/sources/tk.texi @@ -0,0 +1,5 @@ +@node Tk interface +@chapter Tk interface + +For now Guile has no well-specified Tk interface. It is an important part +of Guile, though, and will be documented here when it is written. diff --git a/doc/sources/unix-other.texi b/doc/sources/unix-other.texi new file mode 100644 index 000000000..7b810d5d6 --- /dev/null +++ b/doc/sources/unix-other.texi @@ -0,0 +1,132 @@ +@node Other Unix +@chapter Other Unix-specific facilities + +@menu +* Expect:: Expect, for pattern matching from a port. +@end menu + +@node Expect +@section Expect: Pattern Matching from a Port + +@code{expect} is a macro for selecting actions based on the output from +a port. The name comes from a tool of similar functionality by Don Libes. +Actions can be taken when a particular string is matched, when a timeout +occurs, or when end-of-file is seen on the port. The @code{expect} macro +is described below; @code{expect-strings} is a front-end to @code{expect} +based on regexec @xref{Regular expressions}. + +Using these macros requires for now: +@smalllisp +(load-from-path "ice-9/expect") +@end smalllisp + +@defun expect-strings clause @dots{} +By default, @code{expect-strings} will read from the current input port. +The first term in each clause consists of an expression evaluating to +a string pattern (regular expression). As characters +are read one-by-one from the port, they are accumulated in a buffer string +which is matched against each of the patterns. When a +pattern matches, the remaining expression(s) in +the clause are evaluated and the value of the last is returned. For example: + +@smalllisp +(with-input-from-file "/etc/passwd" + (lambda () + (expect-strings + ("^nobody" (display "Got a nobody user.\n") + (display "That's no problem.\n")) + ("^daemon" (display "Got a daemon user.\n"))))) +@end smalllisp + +The regular expression is compiled with the @code{REG_NEWLINE} flag, so +that the @code{^} and @code{$} anchors will match at any newline, not +just at the start +and end of the string. + +There are two other ways to write a clause: + +The expression(s) to evaluate on a match +can be omitted, in which case the result of the match +(converted to strings, as obtained from regexec with @var{match-pick} +set to @code{""}) will be returned if the pattern matches. + +The symbol @code{=>} can be used to indicate that there is a single +expression to evaluate on a match, which must be a +procedure which will accept the result of a successful match (converted +to strings, as obtained from regexec with @var{match-pick} set to +@code{""}). E.g., + +@smalllisp +("^daemon" => write) +("^d\\(aemon\\)" => (lambda args (map write args))) +("^da\\(em\\)on" => (lambda (all sub) + (write all) + (write sub))) +@end smalllisp + +The order of the substrings corresponds to the order in which the +opening brackets occur in the regular expression. + +A number of variables can be used to control the behaviour +of @code{expect} (and @code{expect-strings}). +By default they are all bound at the top level to +the value @code{#f}, which produces the default behaviour. +They can be redefined at the +top level or locally bound in a form enclosing the @code{expect} expression. + +@table @code +@item expect-port +A port to read characters from, instead of the current input port. +@item expect-timeout +@code{expect} will terminate after this number of +seconds, returning @code{#f} or the value returned by +@code{expect-timeout-proc}. +@item expect-timeout-proc +A procedure called if timeout occurs. The procedure takes a single argument: +the accumulated string. +@item expect-eof-proc +A procedure called if end-of-file is detected on the input port. The +procedure takes a single argument: the accumulated string. +@item expect-char-proc +A procedure to be called every time a character is read from the +port. The procedure takes a single argument: the character which was read. +@end table + +Here's an example using all of the variables: + +@smalllisp +(let ((expect-port (open-input-file "/etc/passwd")) + (expect-timeout 1) + (expect-timeout-proc + (lambda (s) (display "Times up!\n"))) + (expect-eof-proc + (lambda (s) (display "Reached the end of the file!\n"))) + (expect-char-proc display)) + (expect-strings + ("^nobody" (display "Got a nobody user\n")))) +@end smalllisp +@end defun + +@defun expect clause @dots{} +@code{expect} is used in the same way as @code{expect-strings}, +but tests are specified not as patterns, but as procedures. The +procedures are called in turn after each character is read from the +port, with the value of the accumulated string as the argument. The +test is successful if the procedure returns a non-false value. + +If the @code{=>} syntax is used, then if the test succeeds it must return +a list containing the arguments to be provided to the corresponding +expression. + +In the following example, a string will only be matched at the beginning +of the file: +@smalllisp +(let ((expect-port (open-input-file "/etc/passwd"))) + (expect + ((lambda (s) (string=? s "fnord!")) + (display "Got a nobody user!\n")))) +@end smalllisp + +The control variables described for @code{expect-strings} can also +be used with @code{expect}. +@end defun diff --git a/doc/sources/unix.texi b/doc/sources/unix.texi new file mode 100644 index 000000000..e8a189c5b --- /dev/null +++ b/doc/sources/unix.texi @@ -0,0 +1,622 @@ +@node Low level Unix +@chapter Low level Unix interfaces + +The low level Unix interfaces are currently available by +default in the Guile top level. However in the future they will probably +be placed in a module and @code{use-modules} or something similar will +be required to make them available. + +@menu +* Unix conventions:: Conventions followed by the low level Unix + interfaces. +* Ports and descriptors:: Ports, file descriptors and how they + interact. +* Extended I/O:: Reading and writing to ports. +* File system:: Working in a hierarchical filesystem. +* User database:: Information about users from system databases. +* Processes:: Information and control of Unix processes. +* Terminals:: Terminals and pseudo-terminals. +* Network databases:: Network address conversion and information + from system databases. +* Network sockets:: An interface to the BSD socket library. +* Miscellaneous Unix:: Miscellaneous Unix interfaces. +@end menu + +@node Unix conventions +@section Low level Unix conventions + +The low-level interfaces are designed to give Scheme programs +access to as much functionality as possible from the underlying +Unix system. They can be used to implement higher level +intefaces such as the Scheme shell @ref{scsh}. + +Generally there is a single procedure for each corresponding Unix +facility. However some of the procedures are implemented for +speed and convenience in Scheme and have no Unix equivalent +(e.g., @code{read-delimited}, @code{copy-file}.) + +This interface is intended as far as possible to be portable across +different versions of Unix, so that Scheme programmers don't need to be +concerned with implementation differences. In some cases procedures +which can't be implemented (or reimplemented) on particular systems may +become no-ops, or perform limited actions. In other cases they may +throw errors. It should be possible to use the feature system to +determine what functionality is available. + +General naming conventions are as follows: + +@itemize @bullet +@item +The Scheme name is often identical to the name of the underlying Unix +facility. +@item +Underscores in Unix names are converted to hyphens. +@item +Procedures which destructively modify Scheme data gain postpended +exclaimation marks, e.g., @code{recv!}. +@item +Predicates are postpended with question marks, e.g., @code{access?}. +@item +Some names are changed to avoid conflict with dissimilar interfaces +defined by scsh. +@item +Unix preprocessor names such as @code{EPERM} or @code{R_OK} are converted +to Scheme variables of the same name (underscores are not replaced +with hyphens) +@end itemize + +Most of the Unix interface procedures can be relied on to return a +well-specified value. Unexpected conditions are handled by raising +exceptions. + +There are a few procedures which return a special +value if they don't succeed, e.g., @code{getenv} returns @code{#f} +if it the requested string is not found in the environment. These +cases will be noted in the documentation. + +For ways to deal with exceptions, @ref{Exceptions}. + +Errors which the C-library would report by returning a NULL +pointer or through some other means cause a @code{system-error} exception +to be raised. The value of the Unix @code{errno} variable is available +in the data passed by the exception, so there is no need to access the +global errno value (doing so would be unreliable in the presence of +continuations or multiple threads). + +@deffn procedure errno [n] +@end deffn +@deffn procedure perror string +@end deffn + +@node Ports and descriptors +@section Ports and file descriptors + +@deffn procedure move->fdes port fd +@end deffn +@deffn procedure release-port-handle port +@end deffn +@deffn procedure set-port-revealed! @var{port} count +@end deffn +@deffn procedure fdes->ports fdes +@end deffn +@deffn procedure fileno port +@end deffn +@deffn procedure fdopen fdes modes +@end deffn +@deffn procedure duplicate-port port modes +@end deffn +@deffn procedure redirect-port into-port from-port +@end deffn +@deffn procedure freopen filename modes port +@end deffn + +@node Extended I/O +@section Extended I/O + +Extended I/O procedures are available which read or write lines of text, +read text delimited by a specified set of characters, or report or +set the current position of a port. + +@findex fwrite +@findex fread +Interfaces to @code{read}/@code{fread} and @code{write}/@code{fwrite} are +also available, as @code{uniform-array-read!} and @code{uniform-array-write!}, +@ref{Uniform arrays}. + +@deffn procedure read-line [port] [handle-delim] +Return a line of text from @var{port} if specified, otherwise from the +value returned by @code{(current-input-port)}. Under Unix, a line of text +is terminated by the first end-of-line character or by end-of-file. + +If @var{handle-delim} is specified, it should be one of the following +symbols: +@table @code +@item trim +Discard the terminating delimiter. This is the default, but it will +be impossible to tell whether the read terminated with a delimiter or +end-of-file. +@item concat +Append the terminating delimiter (if any) to the returned string. +@item peek +Push the terminating delimiter (if any) back on to the port. +@item split +Return a pair containing the string read from the port and the +terminating delimiter or end-of-file object. + +NOTE: if the scsh module is loaded then +multiple values are returned instead of a pair. +@end table +@end deffn +@deffn procedure read-line! buf [port] +Read a line of text into the supplied string @var{buf} and return the +number of characters added to @var{buf}. If @var{buf} is filled, then +@code{#f} is returned. +Read from @var{port} if +specified, otherwise from the value returned by @code{(current-input-port)}. +@end deffn +@deffn procedure read-delimited delims [port] [handle-delim] +Read text until one of the characters in the string @var{delims} is found +or end-of-file is reached. Read from @var{port} if supplied, otherwise +from the value returned by @code{(current-input-port)}. +@var{handle-delim} takes the same values as described for @code{read-line}. + +NOTE: if the scsh module is loaded then @var{delims} must be an scsh +char-set, not a string. +@end deffn +@deffn procedure read-delimited! delims buf [port] [handle-delim] [start] [end] +Read text into the supplied string @var{buf} and return the number of +characters added to @var{buf} (subject to @var{handle-delim}, which takes +the same values specified for @code{read-line}. If @var{buf} is filled, +@code{#f} is returned for both the number of characters read and the +delimiter. Also terminates if one of the characters in the string +@var{delims} is found +or end-of-file is reached. Read from @var{port} if supplied, otherwise +from the value returned by @code{(current-input-port)}. + +NOTE: if the scsh module is loaded then @var{delims} must be an scsh +char-set, not a string. +@end deffn +@deffn procedure write-line obj [port] +Display @var{obj} and a new-line character to @var{port} if specified, +otherwise to the +value returned by @code{(current-output-port)}; equivalent to: + +@smalllisp +(display obj [port]) +(newline [port]) +@end smalllisp +@end deffn +@deffn procedure ftell port +Returns an integer representing the current position of @var{port}, +measured from the beginning. +@end deffn +@deffn procedure fseek port offset whence +Sets the current position of @var{port} to the integer @var{offset}, +which is interpreted according to the value of @var{whence}. + +One of the following variables should be supplied +for @var{whence}: +@defvar SEEK_SET +Seek from the beginning of the file. +@end defvar +@defvar SEEK_CUR +Seek from the current position. +@end defvar +@defvar SEEK_END +Seek from the end of the file. +@end defvar +@end deffn + +@node File system +@section File system + +These procedures query and set file system attributes (such as owner, +permissions, sizes and types of files); deleting, copying, renaming and +linking files; creating and removing directories and querying their +contents; and the @code{sync} interface. + +@deffn procedure access? path how +Evaluates to @code{#t} if @var{path} corresponds to an existing +file and the current process +has the type of access specified by @var{how}, otherwise +@code{#f}. +@var{how} should be specified +using the values of the variables listed below. Multiple values can +be combined using a bitwise or, in which case @code{#t} will only +be returned if all accesses are granted. + +Permissions are checked using the real id of the current process, +not the effective id, although it's the effective id which determines +whether the access would actually be granted. + +@defvar R_OK +test for read permission. +@end defvar +@defvar W_OK +test for write permission. +@end defvar +@defvar X_OK +test for execute permission. +@end defvar +@defvar F_OK +test for existence of the file. +@end defvar +@end deffn +@findex fstat +@deffn procedure stat obj +Evaluates to an object containing various information +about the file determined by @var{obj}. +@var{obj} can be a string containing a file name or a port or file +descriptor which is open on a file (in which case @code{fstat} is used +as the underlying system call). + +The object returned by @code{stat} can be passed as a single parameter +to the following procedures, all of which return integers: + +@table @r +@item stat:dev +The device containing the file. +@item stat:ino +The file serial number, which distinguishes this file from all other +files on the same device. +@item stat:mode +The mode of the file. This includes file type information +and the file permission bits. See @code{stat:type} and @code{stat:perms} +below. +@item stat:nlink +The number of hard links to the file. +@item stat:uid +The user ID of the file's owner. +@item stat:gid +The group ID of the file. +@item stat:rdev +Device ID; this entry is defined only for character or block +special files. +@item stat:size +The size of a regular file in bytes. +@item stat:atime +The last access time for the file. +@item stat:mtime +The last modification time for the file. +@item stat:ctime +The last modification time for the attributes of the file. +@item stat:blksize +The optimal block size for reading or writing the file, in bytes. +@item stat:blocks +The amount of disk space that the file occupies measured in units of +512 byte blocks. +@end table + +In addition, the following procedures return the information +from stat:mode in a more convenient form: + +@table @r +@item stat:type +A symbol representing the type of file. Possible values are +currently: regular, directory, symlink, block-special, char-special, +fifo, socket, unknown +@item stat:perms +An integer representing the access permission bits. +@end table +@end deffn +@deffn procedure lstat path +Similar to @code{stat}, but does not follow symbolic links, i.e., +it will return information about a symbolic link itself, not the +file it points to. @var{path} must be a string. +@end deffn +@deffn procedure readlink path +@end deffn +@deffn procedure chown path owner group +@end deffn +@deffn procedure chmod port-or-path mode +@end deffn +@deffn procedure utime path [actime] [modtime] +@end deffn +@deffn procedure delete-file path +@end deffn +@deffn procedure copy-file path-from path-to +@end deffn +@deffn procedure rename-file path-from path-to +@end deffn +@deffn procedure link path-from path-to +@end deffn +@deffn procedure symlink path-from path-to +@end deffn +@deffn procedure mkdir path [mode] +@end deffn +@deffn procedure rmdir path +@end deffn +@deffn procedure opendir path +@end deffn +@deffn procedure readdir port +@end deffn +@deffn procedure rewinddir port +@end deffn +@deffn procedure closedir port +@end deffn +@deffn procedure sync +@end deffn + +@node User database +@section User database + +@deffn procedure getpwuid uid +@end deffn +@deffn procedure getpwnam name +@end deffn +@deffn procedure getpwent +@end deffn +@deffn procedure setpwent port +@end deffn +@deffn procedure endpwent +@end deffn +@deffn procedure getgrgid uid +@end deffn +@deffn procedure getgrnam name +@end deffn +@deffn procedure getgrent +@end deffn +@deffn procedure setgrent port +@end deffn +@deffn procedure endgrent +@end deffn + +@node Processes +@section Processes + +@deffn procedure chdir path +@end deffn +@deffn procedure getcwd +@end deffn +@deffn procedure umask [mode] +@end deffn +@deffn procedure getpid +@end deffn +@deffn procedure getgroups +@end deffn +@deffn procedure kill pid sig + +@var{sig} should be specified using a variable corresponding to +the Unix symbolic name, e.g, +@defvar SIGHUP +Hang-up signal. +@end defvar +@defvar SIGINT +Interrupt signal. +@end defvar +@end deffn +@deffn procedure waitpid pid options +@defvar WAIT_ANY +@end defvar +@defvar WAIT_MYPGRP +@end defvar +@defvar WNOHANG +@end defvar +@defvar WUNTRACED +@end defvar +@end deffn +@deffn procedure getppid +@end deffn +@deffn procedure getuid +@end deffn +@deffn procedure getgid +@end deffn +@deffn procedure geteuid +@end deffn +@deffn procedure getegid +@end deffn +@deffn procedure setuid id +@end deffn +@deffn procedure setgid id +@end deffn +@deffn procedure seteuid id +@end deffn +@deffn procedure setegid id +@end deffn +@deffn procedure getpgrp +@end deffn +@deffn procedure setpgid pid pgid +@end deffn +@deffn procedure setsid +@end deffn +@deffn procedure execl arg ... +@end deffn +@deffn procedure execlp arg ... +@end deffn +@deffn procedure primitive-fork +@end deffn +@deffn procedure environ [env] +@end deffn +@deffn procedure putenv string +@end deffn +@deffn procedure nice incr +@end deffn + +@node Terminals +@section Terminals and pseudo-terminals + +@deffn procedure isatty? port +@end deffn +@deffn procedure ttyname port +@end deffn +@deffn procedure ctermid +@end deffn +@deffn procedure tcgetpgrp port +@end deffn +@deffn procedure tcsetpgrp port pgid +@end deffn + +@node Network databases +@section Network address conversion and system databases + +@deffn procedure inet-aton address +@end deffn +@deffn procedure inet-ntoa number +@end deffn +@deffn procedure inet-netof address +@end deffn +@deffn procedure inet-lnaof address +@end deffn +@deffn procedure inet-makeaddr net lna +@end deffn +@deffn procedure gethostbyname name +@end deffn +@deffn procedure gethostbyaddr address +@end deffn +@deffn procedure gethostent +@end deffn +@deffn procedure sethostent port +@end deffn +@deffn procedure endhostent +@end deffn +@deffn procedure getnetbyname name +@end deffn +@deffn procedure getnetbyaddr address +@end deffn +@deffn procedure getnetent +@end deffn +@deffn procedure setnetent port +@end deffn +@deffn procedure endnetent +@end deffn +@deffn procedure getprotobyname name +@end deffn +@deffn procedure getprotobynumber number +@end deffn +@deffn procedure getprotoent +@end deffn +@deffn procedure setprotoent port +@end deffn +@deffn procedure endprotoent +@end deffn +@deffn procedure getservbyname name protocol +@end deffn +@deffn procedure getservbyport port protocol +@end deffn +@deffn procedure getservent +@end deffn +@deffn procedure setservent port +@end deffn +@deffn procedure endservent +@end deffn + +@node Network sockets +@section BSD socket library interface + +@deffn procedure socket family style protocol +@end deffn +@deffn procedure socketpair family style protocol +@end deffn +@deffn procedure getsockopt socket level optname +@end deffn +@deffn procedure setsockopt socket level optname value +@end deffn +@deffn procedure shutdown socket how +@end deffn +@deffn procedure connect socket family address arg ... +@end deffn +@deffn procedure bind socket family address arg ... +@end deffn +@deffn procedure listen socket backlog +@end deffn +@deffn procedure accept socket +@end deffn +@deffn procedure getsockname socket +@end deffn +@deffn procedure getpeername socket +@end deffn +@deffn procedure recv! socket buf [flags] +@end deffn +@deffn procedure send socket message [flags] +@end deffn +@deffn procedure recvfrom! socket buf [flags] [start] [end] +@end deffn +@deffn procedure sendto socket message family address args ... [flags] +@end deffn + +@node Miscellaneous Unix +@section Miscellaneous Unix interfaces + +Things which haven't been classified elsewhere (yet?). + +@deffn procedure open path flags [mode] +@defvar O_RDONLY +@end defvar +@defvar O_WRONLY +@end defvar +@defvar O_RDWR +@end defvar +@defvar O_CREAT +@end defvar +@defvar O_EXCL +@end defvar +@defvar O_NOCTTY +@end defvar +@defvar O_TRUNC +@end defvar +@defvar O_APPEND +@end defvar +@defvar O_NONBLOCK +@end defvar +@defvar O_NDELAY +@end defvar +@defvar O_SYNC +@end defvar +@end deffn +@deffn procedure select reads writes excepts secs msecs +@end deffn +@deffn procedure uname +@end deffn +@deffn procedure pipe +@end deffn +@deffn procedure open-pipe command modes +@end deffn +@deffn procedure open-input-pipe command +@end deffn +@deffn procedure open-output-pipe command +@end deffn +@deffn procedure setlocale category [locale] +@defvar LC_COLLATE +@end defvar +@defvar LC_CTYPE +@end defvar +@defvar LC_MONETARY +@end defvar +@defvar LC_NUMERIC +@end defvar +@defvar LC_TIME +@end defvar +@defvar LC_MESSAGES +@end defvar +@defvar LC_ALL +@end defvar +@end deffn +@deffn procedure strftime format stime +@end deffn +@deffn procedure strptime format string +@end deffn +@deffn procedure mknod +@end deffn + +@node scsh +@chapter The Scheme shell (scsh) + +Guile includes an incomplete port of the Scheme shell (scsh) 0.4.4. + +For information about scsh on the Web see +@url{http://www-swiss.ai.mit.edu/scsh/scsh.html}. +The original scsh is available by ftp from +@url{ftp://swiss-ftp.ai.mit.edu:/pub/su}. + +This port of scsh does not currently use the Guile module system, but +can be initialized using: +@smalllisp +(load-from-path "scsh/init") +@end smalllisp + +Note that SLIB must be installed before scsh can be initialized, see +@ref{SLIB} for details. + +@node Threads +@chapter Programming Threads. + From 9cca936fb8aba74bafd87012eaf5adaac19de1fd Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 9 Mar 2001 08:53:15 +0000 Subject: [PATCH 0676/2047] Move doc files into guile-core distribution (4) --- doc/.cvsignore | 20 +++++++++++++++++++- doc/ChangeLog | 9 +++++++-- doc/Makefile.am | 42 +++++++++++++++++++++++++++++++++++++----- 3 files changed, 63 insertions(+), 8 deletions(-) diff --git a/doc/.cvsignore b/doc/.cvsignore index 535633bde..4a29810e7 100644 --- a/doc/.cvsignore +++ b/doc/.cvsignore @@ -1,3 +1,21 @@ Makefile Makefile.in -data-rep.info +stamp-vti +*.log +*.dvi +*.aux +*.toc +*.cp +*.fn +*.vr +*.tp +*.ky +*.pg +*.cps +*.fns +*.tps +*.vrs +*.ps +*.info* +*.html +version.texi diff --git a/doc/ChangeLog b/doc/ChangeLog index aa49e690b..23155dbea 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,6 +1,7 @@ 2001-03-09 Neil Jerram - Moving texinfo files from guile-doc/ref into guile-core/doc: + Moving texinfo files from guile-doc/ref and guile-doc/tutorial + into guile-core/doc: * env.texi, indices.texi, mbapi.texi, mltext.texi, scripts.texi, scsh.texi, tcltk.texi, hierarchy.txt, scheme-indices.texi, @@ -13,7 +14,11 @@ scheme-io.texi, scheme-memory.texi, scheme-modules.texi, scheme-options.texi, scheme-procedures.texi, scheme-scheduling.texi, scheme-translation.texi, guile.texi, - scheme-data.texi, scheme-ideas.texi, expect.texi: New files. + scheme-data.texi, scheme-ideas.texi, expect.texi, + ChangeLog-guile-doc-ref, guile-tut.texi, + ChangeLog-guile-doc-tutorial: New files. + + * .cvsignore, Makefile.am: Merged. Both the following files are about to be replaced by files from guile-doc/ref. diff --git a/doc/Makefile.am b/doc/Makefile.am index aecb266f2..8641100cc 100644 --- a/doc/Makefile.am +++ b/doc/Makefile.am @@ -19,11 +19,37 @@ ## to the Free Software Foundation, Inc., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA -# This rule overrides automake's rule for version.texi. It causes -# version.texi to be created even in non-maintainer-mode. -# -$(srcdir)/version.texi: stamp-vti - @: +AUTOMAKE_OPTIONS = foreign + +info_TEXINFOS = guile.texi r4rs.texi r5rs.texi goops.texi guile-tut.texi + +guile_TEXINFOS = preface.texi intro.texi scheme-intro.texi \ + scheme-ideas.texi scheme-data.texi scheme-procedures.texi \ + scheme-utility.texi scheme-binding.texi scheme-control.texi \ + scheme-io.texi scheme-evaluation.texi scheme-memory.texi \ + scheme-modules.texi scheme-scheduling.texi scheme-options.texi \ + scheme-translation.texi scheme-debug.texi deprecated.texi \ + scheme-reading.texi scheme-indices.texi slib.texi posix.texi \ + expect.texi scsh.texi tcltk.texi scripts.texi gh.texi scm.texi \ + appendices.texi indices.texi + +goops_TEXINFOS = goops-tutorial.texi hierarchy.eps hierarchy.txt + +# Optionally support building an HTML version of the reference manual. + +if HTML + +htmldir = $(prefix)/html/guile-$(VERSION) + +html_DATA = guile_toc.html $(shell ls guile_*.html 2>/dev/null) guile-tut_toc.html $(shell ls guile-tut_*.html 2>/dev/null) + +guile_toc.html: guile.texi $(guile_TEXINFOS) + $(TEXI2HTML) -split_chapter guile.texi + +guile-tut_toc.html: guile-tut.texi + $(TEXI2HTML) -split_chapter guile-tut.texi + +endif EXAMPLE_SMOB_FILES = \ ChangeLog Makefile README COPYING image-type.c image-type.h myguile.c @@ -37,3 +63,9 @@ dist-hook: dest="`cd $(distdir)/example-smob; pwd`"; \ cd example-smob; \ cp $(EXAMPLE_SMOB_FILES) $$dest) + +# This rule overrides automake's rule for version.texi. It causes +# version.texi to be created even in non-maintainer-mode. +# +$(srcdir)/version.texi: stamp-vti + @: From c2dc2842b6dcbc163a1082eb0698d70761a9ceab Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 9 Mar 2001 09:20:46 +0000 Subject: [PATCH 0677/2047] Move doc files into guile-core distribution (6) --- doc/AUTHORS | 12 +++++++++++ doc/BUGS | 13 +++++++++++ doc/ChangeLog | 11 ++++++---- doc/ChangeLog-guile-doc | 48 +++++++++++++++++++++++++++++++++++++++++ doc/NEWS | 44 +++++++++++++++++++++++++++++++++++++ doc/README | 35 +++++++++++++++++++----------- doc/THANKS | 16 ++++++++++++++ 7 files changed, 163 insertions(+), 16 deletions(-) create mode 100644 doc/AUTHORS create mode 100644 doc/BUGS create mode 100644 doc/ChangeLog-guile-doc create mode 100644 doc/NEWS create mode 100644 doc/THANKS diff --git a/doc/AUTHORS b/doc/AUTHORS new file mode 100644 index 000000000..b5fb6a66d --- /dev/null +++ b/doc/AUTHORS @@ -0,0 +1,12 @@ +The Guile reference and tutorial manuals were written and edited +largely by Mark Galassi and Jim Blandy. Significant portions were +contributed by Gary Houston and Tim Pierce. + +Tom Lord contributed a great deal of material with early Guile +snapshots; although most of this text has been rewritten, all of it +was important, and much of the structure remains. + +Aubrey Jaffer wrote the SCM Scheme implementation and manual upon +which the Guile program and manual are based. Some portions of the +SCM and SLIB manuals have been included here verbatim. + diff --git a/doc/BUGS b/doc/BUGS new file mode 100644 index 000000000..736edaace --- /dev/null +++ b/doc/BUGS @@ -0,0 +1,13 @@ + +Known Guile documentation bugs -*- outline -*- + +* The building of HTML docs is dependent on GNU Make + +This is because the Makefile.am's for the Guile reference manual and +tutorial use a $(shell ...) command to list the set of HTML files to +install. + +Probably this will not be fixed until Automake gains proper HTML doc +support. On the other hand, if we've overlooked a more +version-independent way of achieving the same thing, please let us +know. diff --git a/doc/ChangeLog b/doc/ChangeLog index 23155dbea..315fa2f36 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,7 +1,7 @@ 2001-03-09 Neil Jerram - Moving texinfo files from guile-doc/ref and guile-doc/tutorial - into guile-core/doc: + Moving documentation files from guile-doc and guile-doc into + guile-core/doc: * env.texi, indices.texi, mbapi.texi, mltext.texi, scripts.texi, scsh.texi, tcltk.texi, hierarchy.txt, scheme-indices.texi, @@ -16,10 +16,13 @@ scheme-scheduling.texi, scheme-translation.texi, guile.texi, scheme-data.texi, scheme-ideas.texi, expect.texi, ChangeLog-guile-doc-ref, guile-tut.texi, - ChangeLog-guile-doc-tutorial: New files. + ChangeLog-guile-doc-tutorial, AUTHORS, BUGS, NEWS, THANKS: New + files. - * .cvsignore, Makefile.am: Merged. + * .cvsignore, Makefile.am, README: Merged. + * sources: New subdirectory. + Both the following files are about to be replaced by files from guile-doc/ref. diff --git a/doc/ChangeLog-guile-doc b/doc/ChangeLog-guile-doc new file mode 100644 index 000000000..74ce49b55 --- /dev/null +++ b/doc/ChangeLog-guile-doc @@ -0,0 +1,48 @@ +2001-02-15 Neil Jerram + + * sources/data-rep.texi: Removed. (ref/data-rep.texi is now the + current version of this essay.) + +2001-01-26 Neil Jerram + + * configure.in: Only check for `texi2html' program if HTML is + enabled, and explain where to get `texi2html' from if the check + fails. + + * configure.in, Makefile.am, ref/Makefile.am, + tutorial/Makefile.am: Clean up Makefile.am's and support + (configurable) building of HTML documentation in addition to + Info. Thanks to Steve Tell for the patch on which these changes + were based. + +2000-10-14 Neil Jerram + + * sources/data-rep.texi: Merged a lot of changes from + guile-core/doc/data-rep.texi. + +2000-08-07 Neil Jerram + + * configure.in, configure: Advance version number to 1.4. + +2000-07-28 Neil Jerram + + * sources/data-rep.texi (Garbage Collection): Fix "accomodate" + spelling mistake. + +1998-07-27 Mark Galassi + + * simple test + +1998-04-13 Marius Vollmer + + Have "make dist" include the sources directory: + * Makefile.am: Added "sources" directory to SUBDIRS. + * sources/Makefile.am: New file. + * configure.in: Added "sources/Makefile" to AC_OUTPUT. + +Sun Jun 22 18:38:28 1997 Tim Pierce + + New documentation module. + + + diff --git a/doc/NEWS b/doc/NEWS new file mode 100644 index 000000000..2624f28d3 --- /dev/null +++ b/doc/NEWS @@ -0,0 +1,44 @@ +Guile-doc NEWS --- history of user-visible changes. -*- text -*- +Copyright (C) 1997, 2001 Free Software Foundation, Inc. +See the end for copying conditions. + + +Changes since Guile 1.3.4: + +* It's now possible to build HTML documentation as well as Info + +The guile-doc distribution now supports building HTML versions of the +Guile tutorial and reference manual, in addition to the standard Info +documentation. To enable this, include the `--enable-html' option +when you run `./configure': + + ./configure --enable-html + +HTML documentation is installed in $(prefix)/html/guile-$(VERSION). + + +Changes since Guile 1.0 (Sun 5 Jan 1997): + +* The current documentation approach, recommended by Jim Blandy, is to +have: (*) a tutorial with the pedagogical style of guile-user, and a +non-dry reference manual in the style of the most excellent GNU libc +reference manual: the reference manual should be complete, but at the +same time it should have an introductory screen for each major topic, +which can be referenced if the user goes "up" a level in the info +documentation. + + +Copyright information: + +Copyright (C) 1996,1997 Free Software Foundation, Inc. + + Permission is granted to anyone to make or distribute verbatim copies + of this document as received, in any medium, provided that the + copyright notice and this permission notice are preserved, + thus giving the recipient permission to redistribute in turn. + + Permission is granted to distribute modified versions + of this document, or of portions of it, + under the above conditions, provided also that they + carry prominent notices stating who last changed them. + diff --git a/doc/README b/doc/README index 47f120c4e..2f4ec3432 100644 --- a/doc/README +++ b/doc/README @@ -1,18 +1,29 @@ -This directory contains documentation on the Guile core. +This directory contains documentation on the Guile core. -*-text-*- -At the moment, we don't have a full manual on Guile; that's at the -head of our task list. You can see a snapshot of the new Guile -reference manual by checking out the `guile-doc' CVS module. +The documentation consists of the following manuals. + +- The Guile Tutorial (guile-tut.texi) contains a tutorial introduction + to using Guile. + +- The Guile Reference Manual (guile.texi) contains (or is intended to + contain) reference documentation on all aspects of Guile. + +- The GOOPS Manual (goops.texi) contains both tutorial-style and + reference documentation for using GOOPS, Guile's Object Oriented + Programming System. + +- The Revised^4 and Revised^5 Reports on the Algorithmic Language + Scheme (r4rs.texi and r5rs.texi). + +Please be aware that this is all very much work in progress (apart +from the Revised Reports). Bug reports and contributions are +welcome! The file `oldfmt.c' contains a function which can be used by application writers to support both old-style and new-style error format strings. -The file `data-rep.texi', which used to be in this directory, is now -integrated into the Guile reference manual: the integrated version of -this essay is the `Data Representation' chapter. (This chapter is an -essay on how to write C code that uses Guile values. If you're -interested in writing a application which is extensible via Guile, -this is a good place to start.) To update the Texinfo source for this -essay - for example, when the smob interface changes - please update -the file `guile-doc/ref/data-rep.texi' in the guile-doc module. +The `sources' directory includes some stuff relevant to the Guile +reference manual, and which may eventually be folded in to it. It's +not immediately relevant, however, which is why it's not in this +directory. diff --git a/doc/THANKS b/doc/THANKS new file mode 100644 index 000000000..8c55c8284 --- /dev/null +++ b/doc/THANKS @@ -0,0 +1,16 @@ +The Guile reference manual: +- Mark Galassi, for general stewardship +- Tim Pierce, for writing sections on script interpreter triggers, alists, + function tracing, and splitting the manual into its own module. +Proofreading and bug fixes from: +Marcus Daniels + Lee Thomas + Joel Weber + Keith Wright + Chris Bitmead + +New entries from: + Per Bothner + +Build patches from: + Steve Tell From fff043abc0d3433a7ab22da4f3bdeb4b75b719dc Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 9 Mar 2001 09:35:13 +0000 Subject: [PATCH 0678/2047] Move doc files into guile-core distribution (7) --- ChangeLog | 5 +++++ configure.in | 22 ++++++++++++++++++++++ doc/ChangeLog | 3 +++ doc/Makefile.am | 2 +- 4 files changed, 31 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 7a9c75957..933031164 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2001-03-09 Neil Jerram + + * configure.in (htmldoc): Merge handling of `--enable-htmldoc' + option from guile-doc/configure.in. + 2001-03-06 Dirk Herrmann * libguile.h: Removed #include "libguile/dump.h". diff --git a/configure.in b/configure.in index 5705f5b01..da45ecb20 100644 --- a/configure.in +++ b/configure.in @@ -74,6 +74,28 @@ AC_ARG_ENABLE(regex, [ --disable-regex omit regular expression interfaces],, enable_regex=yes) +AC_ARG_ENABLE(htmldoc, + [ --enable-htmldoc build HTML documentation as well as Info], + [if test "$enable_htmldoc" = "" || test "$enable_htmldoc" = y || test "$enable_htmldoc" = yes; then + htmldoc_enabled=yes + AC_PATH_PROG(TEXI2HTML, texi2html, not found) + if test "$TEXI2HTML" = "not found"; then + echo + echo Building HTML documentation requires the \`texi2html\' program, + echo which appears not to be present on your machine. + echo + echo \`texi2html\' is available from + echo 'http://www.mathematik.uni-kl.de/~obachman/Texi2html/.' + echo + echo In the meantime, to build the guile-doc distribution + echo without HTML enabled, please rerun \`./configure\' without + echo the \`--enable-htmldoc\' option. + exit -1 + fi + fi]) + +AM_CONDITIONAL(HTMLDOC, test x$htmldoc_enabled = xyes) + dnl The --disable-debug used to control these two. But now they are dnl a required part of the distribution. AC_DEFINE(DEBUG_EXTENSIONS) diff --git a/doc/ChangeLog b/doc/ChangeLog index 315fa2f36..c06be02fa 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,5 +1,8 @@ 2001-03-09 Neil Jerram + * Makefile.am: Change HTML to HTMLDOC, now that we're part of a + wider distribution. + Moving documentation files from guile-doc and guile-doc into guile-core/doc: diff --git a/doc/Makefile.am b/doc/Makefile.am index 8641100cc..738fe2b60 100644 --- a/doc/Makefile.am +++ b/doc/Makefile.am @@ -37,7 +37,7 @@ goops_TEXINFOS = goops-tutorial.texi hierarchy.eps hierarchy.txt # Optionally support building an HTML version of the reference manual. -if HTML +if HTMLDOC htmldir = $(prefix)/html/guile-$(VERSION) From 880c28588298864092e1b35f5d60eaebba1b4bff Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 9 Mar 2001 09:44:26 +0000 Subject: [PATCH 0679/2047] * tests/syntax.test ("let*"): Changed the `duplicate bindings' test, dups are allowed in `let*' and are now expected to pass. --- test-suite/ChangeLog | 5 +++++ test-suite/tests/syntax.test | 5 ++--- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 9a0037ff7..92b08fbd1 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2001-03-09 Martin Grabmueller + + * tests/syntax.test ("let*"): Changed the `duplicate bindings' + test, dups are allowed in `let*' and are now expected to pass. + 2001-03-05 Dirk Herrmann * lib.scm (run-test-exception): Preserve the original error's diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index a1d3c6269..7463d880b 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -219,9 +219,8 @@ (with-test-prefix "duplicate bindings" - (pass-if-exception "(let* ((x 1) (x 2)) x)" - exception:duplicate-bindings - (let* ((x 1) (x 2)) x)))) + (pass-if "(let* ((x 1) (x 2)) x)" + (let* ((x 1) (x 2)) #t)))) (with-test-prefix "letrec" From 94e6d79391fa36c5993d6301cac0949b7572333b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 9 Mar 2001 10:03:47 +0000 Subject: [PATCH 0680/2047] Added some new posix functions: (scm_crypt, scm_chroot, scm_getlogin, scm_cuserid), (scm_getpriority, scm_setpriority, scm_getpass, scm_flock), (scm_sethostname, scm_gethostname): New procedures. --- ChangeLog | 7 ++ NEWS | 32 +++++ configure.in | 4 + libguile/ChangeLog | 14 +++ libguile/posix.c | 291 +++++++++++++++++++++++++++++++++++++++++++++ libguile/posix.h | 10 ++ 6 files changed, 358 insertions(+) diff --git a/ChangeLog b/ChangeLog index 933031164..fdb9ee98d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2001-03-09 Martin Grabmueller + + * configure.in: Added header checks for crypt.h, sys/resource.h + and sys/file.h, function checks for chroot, flock, getlogin, + cuserid, getpriority, setpriority, getpass, sethostname, + gethostname, and for crypt() in libcrypt. + 2001-03-09 Neil Jerram * configure.in (htmldoc): Merge handling of `--enable-htmldoc' diff --git a/NEWS b/NEWS index 61604043b..e865cce85 100644 --- a/NEWS +++ b/NEWS @@ -365,6 +365,38 @@ close: Ports and File Descriptors.), the file descriptor will be closed even if a port is using it. The return value is unspecified. +** New function: crypt password salt + +Encrypts `password' using the standard unix password encryption +algorithm. + +** New function: chroot path + +Change the root directory of the running process to `path'. + +** New functions: getlogin, cuserid + +Return the login name or the user name of the current effective user +id, respectively. + +** New functions: getpriority which who, setpriority which who prio + +Get or set the priority of the running process. + +** New function: getpass prompt + +Read a password from the terminal, first displaying `prompt' and +disabling echoing. + +** New function: flock file operation + +Set/remove an advisory shared or exclusive lock on `file'. + +** New functions: sethostname name, gethostname + +Set or get the hostname of the machine the current process is running +on. + ** Deprecated: close-all-ports-except. This was intended for closing ports in a child process after a fork, but it has the undesirable side effect of flushing buffers. port-for-each is more flexible. diff --git a/configure.in b/configure.in index da45ecb20..91ba5f8cf 100644 --- a/configure.in +++ b/configure.in @@ -197,6 +197,10 @@ AC_SUBST(DLPREOPEN) AC_CHECK_FUNCS(ctermid ftime fchown getcwd geteuid gettimeofday lstat mkdir mknod nice readlink rename rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt strftime strptime symlink sync tcgetpgrp tcsetpgrp times uname waitpid bzero strdup system usleep atexit on_exit) +AC_CHECK_HEADERS(crypt.h sys/resource.h sys/file.h) +AC_CHECK_FUNCS(chroot flock getlogin cuserid getpriority setpriority getpass sethostname gethostname) +AC_CHECK_LIB(crypt, crypt) + ### Some systems don't declare some functions. On such systems, we ### need to at least provide our own K&R-style declarations. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 23b5369d7..84b05bebb 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,17 @@ +2001-03-09 Martin Grabmueller + + * posix.h (scm_crypt, scm_chroot, scm_getlogin, scm_cuserid), + (scm_getpriority, scm_setpriority, scm_getpass, scm_flock), + (scm_sethostname, scm_gethostname): New prototypes. + + * posix.c: Added inclusion of , and + , if present. + (scm_init_posix): [PRIO_PROCESS, PRIO_PGRP, PRIO_USER, LOCK_SH, + LOCK_EX, LOCK_UN, LOCK_NB]: New variables. + (scm_crypt, scm_chroot, scm_getlogin, scm_cuserid), + (scm_getpriority, scm_setpriority, scm_getpass, scm_flock), + (scm_sethostname, scm_gethostname): New procedures. + 2001-03-08 Neil Jerram * ports.c (scm_port_column): Docstring fixes: (i) port-line arg is diff --git a/libguile/posix.c b/libguile/posix.c index c85ec6c28..6f4bad800 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -71,6 +71,8 @@ #endif #ifdef HAVE_UNISTD_H +/* GNU/Linux libc requires __USE_XOPEN or cuserid() is not defined. */ +#define __USE_XOPEN #include #else #ifndef ttyname @@ -126,6 +128,18 @@ extern char ** environ; #include #endif +#if HAVE_LIBCRYPT && HAVE_CRYPT_H +# include +#endif + +#if HAVE_SYS_RESOURCE_H +# include +#endif + +#if HAVE_SYS_FILE_H +# include +#endif + /* Some Unix systems don't define these. CPP hair is dangerous, but this seems safe enough... */ #ifndef R_OK @@ -1261,6 +1275,260 @@ SCM_DEFINE (scm_sync, "sync", 0, 0, 0, #undef FUNC_NAME #endif /* HAVE_SYNC */ +#if HAVE_LIBCRYPT && HAVE_CRYPT_H +SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0, + (SCM key, SCM salt), + "Encrypt @var{key} using @var{salt} as the salt value to the\n" + "crypt(3) library call\n") +#define FUNC_NAME s_scm_crypt +{ + char * p; + + SCM_VALIDATE_STRING (1, key); + SCM_VALIDATE_STRING (2, salt); + SCM_STRING_COERCE_0TERMINATION_X (key); + SCM_STRING_COERCE_0TERMINATION_X (salt); + + p = crypt (SCM_STRING_CHARS (key), SCM_STRING_CHARS (salt)); + return scm_makfrom0str (p); +} +#undef FUNC_NAME +#endif /* HAVE_LIBCRYPT && HAVE_CRYPT_H */ + +#if HAVE_CHROOT +SCM_DEFINE (scm_chroot, "chroot", 1, 0, 0, + (SCM path), + "Change the root directory to that specified in @var{path}.\n" + "This directory will be used for path names beginning with\n" + "@file{/}. The root directory is inherited by all children\n" + "of the current process. Only the superuser may change the\n" + "root directory.") +#define FUNC_NAME s_scm_chroot +{ + SCM_VALIDATE_STRING (1, path); + SCM_STRING_COERCE_0TERMINATION_X (path); + + if (chroot (SCM_STRING_CHARS (path)) == -1) + SCM_SYSERROR; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME +#endif /* HAVE_CHROOT */ + +#if HAVE_GETLOGIN +SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0, + (void), + "Return a string containing the name of the user logged in on\n" + "the controlling terminal of the process, or @code{#f} if this\n" + "information cannot be obtained.") +#define FUNC_NAME s_scm_getlogin +{ + char * p; + + p = getlogin (); + if (!p || !*p) + return SCM_BOOL_F; + return scm_makfrom0str (p); +} +#undef FUNC_NAME +#endif /* HAVE_GETLOGIN */ + +#if HAVE_CUSERID +SCM_DEFINE (scm_cuserid, "cuserid", 0, 0, 0, + (void), + "Return a string containing a user name associated with the\n" + "effective user id of the process. Return @code{#f} if this\n" + "information cannot be obtained.") +#define FUNC_NAME s_scm_cuserid +{ + char * p; + + p = cuserid (NULL); + if (!p || !*p) + return SCM_BOOL_F; + return scm_makfrom0str (p); +} +#undef FUNC_NAME +#endif /* HAVE_CUSERID */ + +#if HAVE_GETPRIORITY +SCM_DEFINE (scm_getpriority, "getpriority", 2, 0, 0, + (SCM which, SCM who), + "Return the scheduling priority of the process, process group\n" + "or user, as indicated by @var{which} and @var{who}. @var{which}\n" + "is one of the variables @code{PRIO_PROCESS}, @code{PRIO_PGRP}\n" + "or @code{PRIO_USER}, and @var{who} is interpreted relative to\n" + "@var{which} (a process identifier for @code{PRIO_PROCESS},\n" + "process group identifier for @code{PRIO_PGRP}, and a user\n" + "identifier for @code{PRIO_USER}. A zero value of @var{who}\n" + "denotes the current process, process group, or user. Return\n" + "the highest priority (lowest numerical value) of any of the\n" + "specified processes.") +#define FUNC_NAME s_scm_getpriority +{ + int cwhich, cwho, ret; + + SCM_VALIDATE_INUM_COPY (1, which, cwhich); + SCM_VALIDATE_INUM_COPY (2, who, cwho); + + /* We have to clear errno and examine it later, because -1 is a + legal return value for getpriority(). */ + errno = 0; + ret = getpriority (cwhich, cwho); + if (errno != 0) + SCM_SYSERROR; + return SCM_MAKINUM (ret); +} +#undef FUNC_NAME +#endif /* HAVE_GETPRIORITY */ + +#if HAVE_SETPRIORITY +SCM_DEFINE (scm_setpriority, "setpriority", 3, 0, 0, + (SCM which, SCM who, SCM prio), + "Set the scheduling priority of the process, process group\n" + "or user, as indicated by @var{which} and @var{who}. @var{which}\n" + "is one of the variables @code{PRIO_PROCESS}, @code{PRIO_PGRP}\n" + "or @code{PRIO_USER}, and @var{who} is interpreted relative to\n" + "@var{which} (a process identifier for @code{PRIO_PROCESS},\n" + "process group identifier for @code{PRIO_PGRP}, and a user\n" + "identifier for @code{PRIO_USER}. A zero value of @var{who}\n" + "denotes the current process, process group, or user.\n" + "@var{prio} is a value in the range -20 and 20, the default\n" + "priority is 0; lower priorities cause more favorable\n" + "scheduling. Sets the priority of all of the specified\n" + "processes. Only the super-user may lower priorities.\n" + "The return value is not specified.") +#define FUNC_NAME s_scm_setpriority +{ + int cwhich, cwho, cprio; + + SCM_VALIDATE_INUM_COPY (1, which, cwhich); + SCM_VALIDATE_INUM_COPY (2, who, cwho); + SCM_VALIDATE_INUM_COPY (3, prio, cprio); + + if (setpriority (cwhich, cwho, cprio) == -1) + SCM_SYSERROR; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME +#endif /* HAVE_SETPRIORITY */ + +#if HAVE_GETPASS +SCM_DEFINE (scm_getpass, "getpass", 1, 0, 0, + (SCM prompt), + "Display @var{prompt} to the standard error output and read\n" + "a password from @file{/dev/tty}. If this file is not\n" + "accessible, it reads from standard input. The password may be\n" + "up to 127 characters in length. Additional characters and the\n" + "terminating newline character are discarded. While reading\n" + "the password, echoing and the generation of signals by special\n" + "characters is disabled.") +#define FUNC_NAME s_scm_getpass +{ + char * p; + SCM passwd; + + SCM_VALIDATE_STRING (1, prompt); + SCM_STRING_COERCE_0TERMINATION_X (prompt); + + p = getpass(SCM_STRING_CHARS (prompt)); + passwd = scm_makfrom0str (p); + + /* Clear out the password in the static buffer. */ + memset (p, 0, strlen (p)); + + return passwd; +} +#undef FUNC_NAME +#endif /* HAVE_GETPASS */ + +#if HAVE_FLOCK +SCM_DEFINE (scm_flock, "flock", 2, 0, 0, + (SCM file, SCM operation), + "Apply or remove an advisory lock on an open file.\n" + "@var{operation} specifies the action to be done:\n" + "@table @code\n" + "@item LOCK_SH\n" + "Shared lock. More than one process may hold a shared lock\n" + "for a given file at a given time.\n" + "@item LOCK_EX\n" + "Exclusive lock. Only one process may hold an exclusive lock\n" + "for a given file at a given time.\n" + "@item LOCK_UN\n" + "Unlock the file.\n" + "@item LOCK_NB\n" + "Don't block when locking. May be specified by bitwise OR'ing\n" + "it to one of the other operations.\n" + "@end table\n" + "The return value is not specified. @var{file} may be an open\n" + "file descriptor or an open file descriptior port.") +#define FUNC_NAME s_scm_flock +{ + int coperation, fdes; + + if (SCM_INUMP (file)) + fdes = SCM_INUM (file); + else + { + SCM_VALIDATE_OPFPORT (2, file); + + fdes = SCM_FPORT_FDES (file); + } + SCM_VALIDATE_INUM_COPY (2, operation, coperation); + if (flock (fdes, coperation) == -1) + SCM_SYSERROR; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME +#endif /* HAVE_FLOCK */ + +#if HAVE_SETHOSTNAME +SCM_DEFINE (scm_sethostname, "sethostname", 1, 0, 0, + (SCM name), + "Set the host name of the current processor to @var{name}. May\n" + "only be used by the superuser. The return value is not\n" + "specified.") +#define FUNC_NAME s_scm_sethostname +{ + SCM_VALIDATE_STRING (1, name); + SCM_STRING_COERCE_0TERMINATION_X (name); + + if (sethostname (SCM_STRING_CHARS (name), SCM_STRING_LENGTH (name)) == -1) + SCM_SYSERROR; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME +#endif /* HAVE_SETHOSTNAME */ + +#if HAVE_GETHOSTNAME +SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0, + (void), + "Return the host name of the current processor.") +#define FUNC_NAME s_scm_gethostname +{ + int len = 2, res; + char *p = scm_must_malloc (len, "gethostname"); + SCM name; + + res = gethostname (p, len); + while (res == -1 && errno == ENAMETOOLONG) + { + p = scm_must_realloc (p, len, len * 2, "gethostname"); + len *= 2; + res = gethostname (p, len); + } + if (res == -1) + { + scm_must_free (p); + SCM_SYSERROR; + } + name = scm_makfrom0str (p); + scm_must_free (p); + return name; +} +#undef FUNC_NAME +#endif /* HAVE_GETHOSTNAME */ + void scm_init_posix () { @@ -1312,6 +1580,29 @@ scm_init_posix () scm_sysintern ("PIPE_BUF", scm_long2num (PIPE_BUF)); #endif +#ifdef PRIO_PROCESS + scm_sysintern ("PRIO_PROCESS", SCM_MAKINUM (PRIO_PROCESS)); +#endif +#ifdef PRIO_PGRP + scm_sysintern ("PRIO_PGRP", SCM_MAKINUM (PRIO_PGRP)); +#endif +#ifdef PRIO_USER + scm_sysintern ("PRIO_USER", SCM_MAKINUM (PRIO_USER)); +#endif + +#ifdef LOCK_SH + scm_sysintern ("LOCK_SH", SCM_MAKINUM (LOCK_SH)); +#endif +#ifdef LOCK_EX + scm_sysintern ("LOCK_EX", SCM_MAKINUM (LOCK_EX)); +#endif +#ifdef LOCK_UN + scm_sysintern ("LOCK_UN", SCM_MAKINUM (LOCK_UN)); +#endif +#ifdef LOCK_NB + scm_sysintern ("LOCK_NB", SCM_MAKINUM (LOCK_NB)); +#endif + #include "libguile/cpp_sig_symbols.c" #ifndef SCM_MAGIC_SNARFER #include "libguile/posix.x" diff --git a/libguile/posix.h b/libguile/posix.h index a39930846..2b96f94e8 100644 --- a/libguile/posix.h +++ b/libguile/posix.h @@ -95,6 +95,16 @@ extern SCM scm_setlocale (SCM category, SCM locale); extern SCM scm_mknod (SCM path, SCM type, SCM perms, SCM dev); extern SCM scm_nice (SCM incr); extern SCM scm_sync (void); +extern SCM scm_crypt (SCM key, SCM salt); +extern SCM scm_chroot (SCM path); +extern SCM scm_getlogin (void); +extern SCM scm_cuserid (void); +extern SCM scm_getpriority (SCM which, SCM who); +extern SCM scm_setpriority (SCM which, SCM who, SCM prio); +extern SCM scm_getpass (SCM prompt); +extern SCM scm_flock (SCM file, SCM operation); +extern SCM scm_sethostname (SCM name); +extern SCM scm_gethostname (void); extern void scm_init_posix (void); #endif /* POSIXH */ From 9a677c37c85fb03466feccfb4bcf9674884da393 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 9 Mar 2001 12:08:43 +0000 Subject: [PATCH 0681/2047] * posix.c (scm_gethostname): Set initial name length to 256 for Solaris. --- libguile/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 84b05bebb..31cee4d36 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-03-09 Martin Grabmueller + + * posix.c (scm_gethostname): Set initial name length to 256 for + Solaris. + 2001-03-09 Martin Grabmueller * posix.h (scm_crypt, scm_chroot, scm_getlogin, scm_cuserid), From a0f9c651b1fbd70d6841669c04e58c1f00d067d4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 9 Mar 2001 12:09:17 +0000 Subject: [PATCH 0682/2047] (scm_gethostname): Set initial name length to 256 for Solaris. --- libguile/posix.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/libguile/posix.c b/libguile/posix.c index 6f4bad800..861791864 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1506,7 +1506,9 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0, "Return the host name of the current processor.") #define FUNC_NAME s_scm_gethostname { - int len = 2, res; + /* 256 is for Solaris, under Linux ENAMETOOLONG is returned if not + large enough. */ + int len = 256, res; char *p = scm_must_malloc (len, "gethostname"); SCM name; From 0c6f960254cabda5e1cf090f4c2a9775cdf2884d Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 9 Mar 2001 21:47:52 +0000 Subject: [PATCH 0683/2047] * Makefile.am (psyntax.pp): Added rule for producing psyntax.pp. --- ice-9/ChangeLog | 4 ++++ ice-9/Makefile.am | 3 +++ 2 files changed, 7 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 67b350f40..149e6b4f7 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2001-03-09 Mikael Djurfeldt + + * Makefile.am (psyntax.pp): Added rule for producing psyntax.pp. + 2001-03-09 Keisuke Nishida * match.scm: export defstruct. diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index 5bfe317e8..b3c276242 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -43,3 +43,6 @@ install-data-local: ## test.scm is not currently installed. EXTRA_DIST = $(ice9_sources) test.scm and-let-star-compat.scm + +psyntax.pp: + cd $(srcdir) && guile -c '(load-from-path "ice-9/syncase") (psyncomp)' From ffdeebc3a96aff450b61b436a355d69a1c2733f0 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 9 Mar 2001 23:31:55 +0000 Subject: [PATCH 0684/2047] * readline.c: Add #include --- guile-readline/ChangeLog | 4 ++++ guile-readline/readline.c | 1 + 2 files changed, 5 insertions(+) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 1c587252d..e677ada41 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,7 @@ +2001-03-09 Keisuke Nishida + + * readline.c: Add #include + 2001-03-05 Neil Jerram * readline.scm (make-readline-port): Rewrite using diff --git a/guile-readline/readline.c b/guile-readline/readline.c index 037bcf7a2..068c453e6 100644 --- a/guile-readline/readline.c +++ b/guile-readline/readline.c @@ -30,6 +30,7 @@ #include "libguile/gh.h" #include "libguile/iselect.h" +#include #ifdef HAVE_UNISTD_H #include #endif From 783e77747821c3b79d5ea47fa6be4beb1a758253 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 9 Mar 2001 23:33:41 +0000 Subject: [PATCH 0685/2047] Remove #include . Add #include . --- libguile/ChangeLog | 17 +++++++++++++++++ libguile/alist.c | 1 - libguile/arbiters.c | 1 - libguile/async.c | 1 - libguile/backtrace.c | 1 - libguile/boolean.c | 1 - libguile/chars.c | 1 - libguile/continuations.c | 1 - libguile/debug-malloc.c | 1 - libguile/debug.c | 1 - libguile/dynwind.c | 1 - libguile/eq.c | 1 - libguile/eval.c | 1 - libguile/feature.c | 1 - libguile/filesys.h | 1 - libguile/gc.c | 1 + libguile/gc_os_dep.c | 1 - libguile/gdbint.c | 1 + libguile/gh_data.c | 2 -- libguile/gh_eval.c | 2 -- libguile/gh_funcs.c | 2 -- libguile/gh_io.c | 2 -- libguile/gh_list.c | 2 -- libguile/gh_predicates.c | 2 -- libguile/hash.c | 1 - libguile/hashtab.c | 1 - libguile/iselect.c | 1 - libguile/keywords.c | 1 - libguile/list.c | 1 - libguile/load.c | 1 - libguile/mallocs.c | 1 - libguile/net_db.c | 1 - libguile/numbers.c | 1 - libguile/objprop.c | 1 - libguile/objprop.h | 1 - libguile/options.c | 1 - libguile/pairs.c | 1 - libguile/print.c | 1 - libguile/procprop.c | 1 - libguile/procs.c | 2 +- libguile/properties.c | 1 - libguile/ramap.c | 1 - libguile/regex-posix.c | 1 - libguile/root.c | 2 +- libguile/scmsigs.c | 1 - libguile/simpos.c | 1 - libguile/socket.c | 2 -- libguile/sort.c | 1 + libguile/srcprop.c | 1 - libguile/stackchk.c | 1 - libguile/stacks.c | 1 - libguile/strings.c | 1 - libguile/strop.c | 1 - libguile/strorder.c | 1 - libguile/struct.c | 1 - libguile/symbols.c | 1 - libguile/tag.c | 1 - libguile/threads.c | 1 - libguile/unif.c | 1 + libguile/variable.c | 1 - libguile/vectors.c | 1 - libguile/weaks.c | 1 - 62 files changed, 23 insertions(+), 64 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 31cee4d36..cb5b40732 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,20 @@ +2001-03-09 Keisuke Nishida + + * alist.c, arbiters.c, async.c, backtrace.c, boolean.c, chars.c, + continuations.c, debug-malloc.c, debug.c, dynwind.c, eq.c, eval.c, + feature.c, filesys.h, gc_os_dep.c, gh_data.c, gh_eval.c, + gh_funcs.c, gh_io.c, gh_list.c, gh_predicates.c, hash.c, + hashtab.c, iselect.c, keywords.c, list.c, load.c, mallocs.c, + net_db.c, numbers.c, objprop.c, objprop.h, options.c, pairs.c, + print.c, procprop.c, procs.c, properties.c, ramap.c, + regex-posix.c, root.c, scmsigs.c, simpos.c, socket.c, srcprop.c, + stackchk.c, stacks.c, strings.c, strop.c, strorder.c, struct.c, + symbols.c, tag.c, threads.c, variable.c, vectors.c, weaks.c: + Remove #include + * gc.c, gdbint.c, root.c, sort.c, unif.c: Add #include . + + * procs.c (scm_make_subr_opt): Init symcell to avoid warning. + 2001-03-09 Martin Grabmueller * posix.c (scm_gethostname): Set initial name length to 256 for diff --git a/libguile/alist.c b/libguile/alist.c index cd4f182ff..5e75c8e95 100644 --- a/libguile/alist.c +++ b/libguile/alist.c @@ -43,7 +43,6 @@ gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ -#include #include "libguile/_scm.h" #include "libguile/eq.h" #include "libguile/list.h" diff --git a/libguile/arbiters.c b/libguile/arbiters.c index c388dfaf0..faa0f4613 100644 --- a/libguile/arbiters.c +++ b/libguile/arbiters.c @@ -44,7 +44,6 @@ -#include #include "libguile/_scm.h" #include "libguile/ports.h" #include "libguile/smob.h" diff --git a/libguile/async.c b/libguile/async.c index d1f834df0..e57b821ae 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -44,7 +44,6 @@ -#include #include #include "libguile/_scm.h" #include "libguile/eval.h" diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 7661c19d6..d0f4820ba 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -47,7 +47,6 @@ gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ -#include #include #include "libguile/_scm.h" diff --git a/libguile/boolean.c b/libguile/boolean.c index 9fd89a611..7bda2139f 100644 --- a/libguile/boolean.c +++ b/libguile/boolean.c @@ -44,7 +44,6 @@ -#include #include "libguile/_scm.h" #include "libguile/validate.h" diff --git a/libguile/chars.c b/libguile/chars.c index 9ca1fac6b..c47705645 100644 --- a/libguile/chars.c +++ b/libguile/chars.c @@ -44,7 +44,6 @@ -#include #include #include "libguile/_scm.h" #include "libguile/validate.h" diff --git a/libguile/continuations.c b/libguile/continuations.c index 3b07e1f06..28985e060 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -44,7 +44,6 @@ -#include #include #include "libguile/_scm.h" diff --git a/libguile/debug-malloc.c b/libguile/debug-malloc.c index 8b2a08ceb..4240f7d8b 100644 --- a/libguile/debug-malloc.c +++ b/libguile/debug-malloc.c @@ -40,7 +40,6 @@ * If you do not wish that, delete this exception notice. */ #include -#include #include "libguile/_scm.h" #include "libguile/alist.h" diff --git a/libguile/debug.c b/libguile/debug.c index 275c05bc4..354ddd6e6 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -47,7 +47,6 @@ gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ -#include #include "libguile/_scm.h" #include "libguile/eval.h" #include "libguile/stackchk.h" diff --git a/libguile/dynwind.c b/libguile/dynwind.c index 647c044ab..101107c70 100644 --- a/libguile/dynwind.c +++ b/libguile/dynwind.c @@ -44,7 +44,6 @@ -#include #include "libguile/_scm.h" #include "libguile/eval.h" #include "libguile/alist.h" diff --git a/libguile/eq.c b/libguile/eq.c index 275fa717f..8eda34047 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -43,7 +43,6 @@ gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ -#include #include "libguile/_scm.h" #include "libguile/ramap.h" #include "libguile/stackchk.h" diff --git a/libguile/eval.c b/libguile/eval.c index 93a4a166a..4c58a54df 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -78,7 +78,6 @@ char *alloca (); # endif #endif -#include #include "libguile/_scm.h" #include "libguile/debug.h" #include "libguile/dynwind.h" diff --git a/libguile/feature.c b/libguile/feature.c index 4b4320901..d37b83ce9 100644 --- a/libguile/feature.c +++ b/libguile/feature.c @@ -44,7 +44,6 @@ -#include #ifdef HAVE_STRING_H #include #endif diff --git a/libguile/filesys.h b/libguile/filesys.h index c71d844f2..549d71a05 100644 --- a/libguile/filesys.h +++ b/libguile/filesys.h @@ -47,7 +47,6 @@ gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ -#include #include "libguile/__scm.h" diff --git a/libguile/gc.c b/libguile/gc.c index 038822a50..bf554aa05 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -51,6 +51,7 @@ #include +#include #include "libguile/_scm.h" #include "libguile/eval.h" #include "libguile/stime.h" diff --git a/libguile/gc_os_dep.c b/libguile/gc_os_dep.c index 0001cf824..d05105a63 100644 --- a/libguile/gc_os_dep.c +++ b/libguile/gc_os_dep.c @@ -1419,7 +1419,6 @@ word x; # endif # endif -# include # include /* Blatantly OS dependent routines, except for those that are related */ diff --git a/libguile/gdbint.c b/libguile/gdbint.c index 2f6a036aa..e18fea8a8 100644 --- a/libguile/gdbint.c +++ b/libguile/gdbint.c @@ -50,6 +50,7 @@ #include "libguile/_scm.h" #include +#include #ifdef HAVE_UNISTD_H #include #endif diff --git a/libguile/gh_data.c b/libguile/gh_data.c index 6e7eab19c..21510c4e9 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -41,8 +41,6 @@ /* data initialization and C<->Scheme data conversion */ -#include - #include "libguile/gh.h" #ifdef HAVE_STRING_H #include diff --git a/libguile/gh_eval.c b/libguile/gh_eval.c index 46f6f97ac..71c8f9350 100644 --- a/libguile/gh_eval.c +++ b/libguile/gh_eval.c @@ -42,8 +42,6 @@ /* routines to evaluate Scheme code */ -#include - #include "libguile/gh.h" typedef SCM (*gh_eval_t) (void *data, SCM jmpbuf); diff --git a/libguile/gh_funcs.c b/libguile/gh_funcs.c index 5374a0143..6f43cf734 100644 --- a/libguile/gh_funcs.c +++ b/libguile/gh_funcs.c @@ -43,8 +43,6 @@ /* Defining Scheme functions implemented by C functions --- subrs. */ -#include - #include "libguile/gh.h" /* allows you to define new scheme primitives written in C */ diff --git a/libguile/gh_io.c b/libguile/gh_io.c index c60032ee2..41ca3a724 100644 --- a/libguile/gh_io.c +++ b/libguile/gh_io.c @@ -40,8 +40,6 @@ * If you do not wish that, delete this exception notice. */ -#include - #include "libguile/gh.h" void diff --git a/libguile/gh_list.c b/libguile/gh_list.c index 4054dc5d9..7bdd9440d 100644 --- a/libguile/gh_list.c +++ b/libguile/gh_list.c @@ -42,8 +42,6 @@ /* list manipulation */ -#include - #include "libguile/gh.h" /* returns the length of a list */ diff --git a/libguile/gh_predicates.c b/libguile/gh_predicates.c index fe5fc140a..1bd234b50 100644 --- a/libguile/gh_predicates.c +++ b/libguile/gh_predicates.c @@ -42,8 +42,6 @@ /* type predicates and equality predicates */ -#include - #include "libguile/gh.h" /* type predicates: tell you if an SCM object has a given type */ diff --git a/libguile/hash.c b/libguile/hash.c index 8f8dfbb7a..f2bb819ec 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -44,7 +44,6 @@ -#include #include "libguile/_scm.h" #include "libguile/chars.h" #include "libguile/ports.h" diff --git a/libguile/hashtab.c b/libguile/hashtab.c index 1f001f236..23fba77fe 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -44,7 +44,6 @@ -#include #include "libguile/_scm.h" #include "libguile/alist.h" #include "libguile/hash.h" diff --git a/libguile/iselect.c b/libguile/iselect.c index d18213c4c..d7bda8812 100644 --- a/libguile/iselect.c +++ b/libguile/iselect.c @@ -39,7 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -#include #include #include diff --git a/libguile/keywords.c b/libguile/keywords.c index 8af562ec5..84d942dfa 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -44,7 +44,6 @@ -#include #include #include "libguile/_scm.h" diff --git a/libguile/list.c b/libguile/list.c index 6493df8de..141d48a99 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -43,7 +43,6 @@ gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ -#include #include "libguile/_scm.h" #include "libguile/eq.h" diff --git a/libguile/load.c b/libguile/load.c index 8be776db7..496f2b8a5 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -44,7 +44,6 @@ -#include #include #include "libguile/_scm.h" diff --git a/libguile/mallocs.c b/libguile/mallocs.c index f0f9606c6..035539f9b 100644 --- a/libguile/mallocs.c +++ b/libguile/mallocs.c @@ -22,7 +22,6 @@ -#include #include "libguile/_scm.h" #include "libguile/ports.h" #include "libguile/smob.h" diff --git a/libguile/net_db.c b/libguile/net_db.c index 408400f58..ba9599671 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -51,7 +51,6 @@ */ -#include #include "libguile/_scm.h" #include "libguile/feature.h" #include "libguile/strings.h" diff --git a/libguile/numbers.c b/libguile/numbers.c index 2b2cedbff..8841dbd50 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -44,7 +44,6 @@ -#include #include #include "libguile/_scm.h" #include "libguile/feature.h" diff --git a/libguile/objprop.c b/libguile/objprop.c index 04b3106d8..17f935e94 100644 --- a/libguile/objprop.c +++ b/libguile/objprop.c @@ -44,7 +44,6 @@ -#include #include "libguile/_scm.h" #include "libguile/hashtab.h" #include "libguile/alist.h" diff --git a/libguile/objprop.h b/libguile/objprop.h index 4d94bbcd2..376991017 100644 --- a/libguile/objprop.h +++ b/libguile/objprop.h @@ -44,7 +44,6 @@ * If you do not wish that, delete this exception notice. */ -#include #include "libguile/__scm.h" diff --git a/libguile/options.c b/libguile/options.c index 5bd622d30..c5260e669 100644 --- a/libguile/options.c +++ b/libguile/options.c @@ -47,7 +47,6 @@ -#include #include "libguile/_scm.h" #include "libguile/strings.h" diff --git a/libguile/pairs.c b/libguile/pairs.c index 26ab6330f..070d08da2 100644 --- a/libguile/pairs.c +++ b/libguile/pairs.c @@ -44,7 +44,6 @@ -#include #include "libguile/_scm.h" #include "libguile/validate.h" diff --git a/libguile/print.c b/libguile/print.c index 1e86d854d..0d822c58b 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -44,7 +44,6 @@ -#include #include "libguile/_scm.h" #include "libguile/chars.h" #include "libguile/continuations.h" diff --git a/libguile/procprop.c b/libguile/procprop.c index f0ec8dd2e..791dce74b 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -44,7 +44,6 @@ -#include #include "libguile/_scm.h" #include "libguile/alist.h" diff --git a/libguile/procs.c b/libguile/procs.c index 44a869bfb..0e59df8ad 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -44,7 +44,6 @@ -#include #include "libguile/_scm.h" #include "libguile/objects.h" @@ -95,6 +94,7 @@ scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set) } else { + symcell = SCM_BOOL_F; /* to avoid warning */ symbol = scm_str2symbol (name); } diff --git a/libguile/properties.c b/libguile/properties.c index 5da889138..b33343862 100644 --- a/libguile/properties.c +++ b/libguile/properties.c @@ -44,7 +44,6 @@ -#include #include "libguile/_scm.h" #include "libguile/hashtab.h" #include "libguile/alist.h" diff --git a/libguile/ramap.c b/libguile/ramap.c index 92aa19681..21e222c5b 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -51,7 +51,6 @@ -#include #include "libguile/_scm.h" #include "libguile/strings.h" #include "libguile/unif.h" diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index da18e9119..5fafba687 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -53,7 +53,6 @@ libraries which do not agree with the Spencer implementation may produce varying behavior. Sigh. */ -#include #include #include "libguile/_scm.h" diff --git a/libguile/root.c b/libguile/root.c index 88ae8b0ca..6779f6779 100644 --- a/libguile/root.c +++ b/libguile/root.c @@ -44,7 +44,7 @@ -#include +#include #include "libguile/_scm.h" #include "libguile/stackchk.h" #include "libguile/dynwind.h" diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index 415169915..baa597e31 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -44,7 +44,6 @@ -#include #include #include "libguile/_scm.h" diff --git a/libguile/simpos.c b/libguile/simpos.c index 041fe70d1..db0c04beb 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -44,7 +44,6 @@ -#include #include "libguile/_scm.h" #include "libguile/scmsigs.h" diff --git a/libguile/socket.c b/libguile/socket.c index a637aa7ea..52e0fff57 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -44,8 +44,6 @@ -#include - #include "libguile/_scm.h" #include "libguile/unif.h" #include "libguile/feature.h" diff --git a/libguile/sort.c b/libguile/sort.c index 659c901bd..2d3ca3c1f 100644 --- a/libguile/sort.c +++ b/libguile/sort.c @@ -78,6 +78,7 @@ char *alloca (); # endif #endif +#include #include "libguile/_scm.h" #include "libguile/eval.h" diff --git a/libguile/srcprop.c b/libguile/srcprop.c index 341c9a670..41cd36cc2 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -47,7 +47,6 @@ -#include #include "libguile/_scm.h" #include "libguile/smob.h" #include "libguile/alist.h" diff --git a/libguile/stackchk.c b/libguile/stackchk.c index 3b31ff263..bede70e86 100644 --- a/libguile/stackchk.c +++ b/libguile/stackchk.c @@ -44,7 +44,6 @@ -#include #include "libguile/_scm.h" #include "libguile/ports.h" #include "libguile/root.h" diff --git a/libguile/stacks.c b/libguile/stacks.c index e223d4ff1..92873a469 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -48,7 +48,6 @@ -#include #include "libguile/_scm.h" #include "libguile/eval.h" #include "libguile/debug.h" diff --git a/libguile/strings.c b/libguile/strings.c index 3874b4a05..e2277fe39 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -44,7 +44,6 @@ -#include #include #include "libguile/_scm.h" diff --git a/libguile/strop.c b/libguile/strop.c index 1ad572283..01665dd97 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -23,7 +23,6 @@ Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA -#include #include "libguile/_scm.h" #include "libguile/chars.h" #include "libguile/strings.h" diff --git a/libguile/strorder.c b/libguile/strorder.c index 22f60db49..2dee2b800 100644 --- a/libguile/strorder.c +++ b/libguile/strorder.c @@ -43,7 +43,6 @@ gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ -#include #include "libguile/_scm.h" #include "libguile/chars.h" #include "libguile/strings.h" diff --git a/libguile/struct.c b/libguile/struct.c index 52af06f2e..3c15deb53 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -44,7 +44,6 @@ -#include #include "libguile/_scm.h" #include "libguile/chars.h" #include "libguile/eval.h" diff --git a/libguile/symbols.c b/libguile/symbols.c index 76e15cb8a..2d6d081ea 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -44,7 +44,6 @@ -#include #include "libguile/_scm.h" #include "libguile/chars.h" #include "libguile/eval.h" diff --git a/libguile/tag.c b/libguile/tag.c index db385905f..095572d1a 100644 --- a/libguile/tag.c +++ b/libguile/tag.c @@ -43,7 +43,6 @@ gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ -#include #include "libguile/_scm.h" #include "libguile/chars.h" #include "libguile/struct.h" diff --git a/libguile/threads.c b/libguile/threads.c index 85f38ca96..2bf5180f6 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -62,7 +62,6 @@ * second #inclusion */ -#include #include "libguile/_scm.h" #include "libguile/dynwind.h" #include "libguile/smob.h" diff --git a/libguile/unif.c b/libguile/unif.c index 1a801317b..7e4e1a8bc 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -52,6 +52,7 @@ #include +#include #include "libguile/_scm.h" #include "libguile/chars.h" #include "libguile/eval.h" diff --git a/libguile/variable.c b/libguile/variable.c index a088be209..4ce7d6110 100644 --- a/libguile/variable.c +++ b/libguile/variable.c @@ -44,7 +44,6 @@ -#include #include "libguile/_scm.h" #include "libguile/eq.h" #include "libguile/ports.h" diff --git a/libguile/vectors.c b/libguile/vectors.c index 25c7c8a36..bd1b7ba85 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -44,7 +44,6 @@ -#include #include "libguile/_scm.h" #include "libguile/eq.h" #include "libguile/root.h" diff --git a/libguile/weaks.c b/libguile/weaks.c index f340922fe..91167d230 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -43,7 +43,6 @@ gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ -#include #include "libguile/_scm.h" #include "libguile/vectors.h" From 8b50fe8ed3f3cbce754fa62e6c5f49bb4a6667cb Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 10 Mar 2001 01:07:06 +0000 Subject: [PATCH 0686/2047] * posix.c: Replaced `#define' of __USE_XOPEN right before including unistd.h with a define of _GNU_SOURCE at the very top of the file. --- libguile/posix.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/libguile/posix.c b/libguile/posix.c index 861791864..c8f969ac6 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -44,6 +44,9 @@ +/* Make GNU/Linux libc declare everything it has. */ +#define _GNU_SOURCE + #include #include "libguile/_scm.h" #include "libguile/fports.h" @@ -71,8 +74,6 @@ #endif #ifdef HAVE_UNISTD_H -/* GNU/Linux libc requires __USE_XOPEN or cuserid() is not defined. */ -#define __USE_XOPEN #include #else #ifndef ttyname From 74355186f0c9509c599018af3720ae6e01f468a7 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 10 Mar 2001 01:07:44 +0000 Subject: [PATCH 0687/2047] *** empty log message *** --- libguile/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index cb5b40732..c918c1084 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2001-03-10 Marius Vollmer + + * posix.c: Replaced `#define' of __USE_XOPEN right before + including unistd.h with a define of _GNU_SOURCE at the very top of + the file. + 2001-03-09 Keisuke Nishida * alist.c, arbiters.c, async.c, backtrace.c, boolean.c, chars.c, From 406d8344265f2e826fe82ef1341fa74e7481fad4 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sat, 10 Mar 2001 02:16:12 +0000 Subject: [PATCH 0688/2047] * match.scm: Don't export defstruct. Use (unquote defstruct) instead. --- ice-9/ChangeLog | 4 ++++ ice-9/match.scm | 6 +++--- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 149e6b4f7..d414850dc 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2001-03-09 Keisuke Nishida + + * match.scm: Don't export defstruct. Use (unquote defstruct) instead. + 2001-03-09 Mikael Djurfeldt * Makefile.am (psyntax.pp): Added rule for producing psyntax.pp. diff --git a/ice-9/match.scm b/ice-9/match.scm index 3a83aeac8..2c08dc54c 100644 --- a/ice-9/match.scm +++ b/ice-9/match.scm @@ -22,7 +22,7 @@ :use-module (ice-9 slib) :export (match match-lambda match-lambda* match-define match-let match-let* match-letrec - defstruct define-structure define-const-structure + define-structure define-const-structure match:error match:set-error match:error-control match:set-error-control match:structure-control match:set-structure-control @@ -197,6 +197,6 @@ (define match:runtime-structures #f) (define match:set-runtime-structures (lambda (v) (set! match:runtime-structures v))) (define match:primitive-vector? vector?) -(defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda () #t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda (x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x))))) (mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x)) (match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let ((g296 (lambda () (match:syntax-err (quasiquote (defstruct (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (symbol? (car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args)) (symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args)) (g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate fields) (let* ((selectors (map selector-name fields)) (mutators (map mutator-name fields)) (tag (if match:runtime-structures (gentemp) (quasiquote (quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq? match:structure-control (quote disjoint)) (quote match:primitive-vector?)) ((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq? match:structure-control (quote disjoint)) (if (eq? vector? match:primitive-vector?) (set! vector? (lambda (v) (and (match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol? (vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not (memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates (cons predicate match:disjoint-predicates)))) ((eq? match:structure-control (quote vector)) (if (not (memq predicate match:vector-structures)) (set! match:vector-structures (cons predicate match:vector-structures)))) (else (match:syntax-err (quote (vector disjoint)) "invalid value for match:structure-control, legal values are"))) (quasiquote (begin (unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define (unquote constructor) (lambda (unquote selectors) (vector (unquote tag) (unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and ((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing (filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda (obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing (filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n) (lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators)))))) (car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299)) (g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296))))) +(defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda () #t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda (x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x))))) (mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x)) (match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let ((g296 (lambda () (match:syntax-err (quasiquote ((unquote defstruct) (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (symbol? (car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args)) (symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args)) (g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate fields) (let* ((selectors (map selector-name fields)) (mutators (map mutator-name fields)) (tag (if match:runtime-structures (gentemp) (quasiquote (quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq? match:structure-control (quote disjoint)) (quote match:primitive-vector?)) ((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq? match:structure-control (quote disjoint)) (if (eq? vector? match:primitive-vector?) (set! vector? (lambda (v) (and (match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol? (vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not (memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates (cons predicate match:disjoint-predicates)))) ((eq? match:structure-control (quote vector)) (if (not (memq predicate match:vector-structures)) (set! match:vector-structures (cons predicate match:vector-structures)))) (else (match:syntax-err (quote (vector disjoint)) "invalid value for match:structure-control, legal values are"))) (quasiquote (begin (unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define (unquote constructor) (lambda (unquote selectors) (vector (unquote tag) (unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and ((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing (filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda (obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing (filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n) (lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators)))))) (car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299)) (g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296))))) (defmacro define-structure args (let ((g311 (lambda () (match:syntax-err (quasiquote (define-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g308 ((g309 (cadr args)) (g307 (quote ())) (g306 (quote ()))) (if (null? g309) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let ((mk-id (lambda (id) (if (and (pair? id) (equal? (car id) (quote @)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda (x) x) (cadr id)) ((lambda () (quasiquote (! (unquote id))))))))) (quasiquote (define-const-structure ((unquote name) (unquote-splicing (map mk-id id1))) (unquote (map (lambda (id v) (quasiquote ((unquote (mk-id id)) (unquote v)))) id2 val)))))) (caar args) (cdar args) (reverse g306) (reverse g307)) (g311)) (if (and (pair? (car g309)) (pair? (cdar g309)) (null? (cddar g309))) (g308 (cdr g309) (cons (cadar g309) g307) (cons (caar g309) g306)) (g311)))) (g311))) (g311)))) -(defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol? id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda () #f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator? (lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote (define-const-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if (and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args)) (g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor (symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin (defstruct (unquote name) (unquote raw-constructor) (unquote predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if (has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i)) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))) (symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2) (quasiquote (define (unquote constructor) (unquote raw-constructor))) (let* ((make-fresh (lambda (x) (if (eq? (quote _) x) (gentemp) x))) (names1 (map make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1) (let* (unquote (map list names2 val)) ((unquote raw-constructor) (unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing (filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _)) #f (quasiquote (define (unquote (symbol-append name (quote -) (field-name field))) (unquote (symbol-append name (quote -) i)))))) id1id2)) (unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq? (field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote (define (unquote (symbol-append (quote set-) name (quote -) (field-name field) (quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331)) (g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333)) (null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons (car g329) g327)) (g335)))) (g335))) (g335))))) +(defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol? id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda () #f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator? (lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote (define-const-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if (and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args)) (g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor (symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin ((unquote defstruct) (unquote name) (unquote raw-constructor) (unquote predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if (has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i)) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))) (symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2) (quasiquote (define (unquote constructor) (unquote raw-constructor))) (let* ((make-fresh (lambda (x) (if (eq? (quote _) x) (gentemp) x))) (names1 (map make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1) (let* (unquote (map list names2 val)) ((unquote raw-constructor) (unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing (filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _)) #f (quasiquote (define (unquote (symbol-append name (quote -) (field-name field))) (unquote (symbol-append name (quote -) i)))))) id1id2)) (unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq? (field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote (define (unquote (symbol-append (quote set-) name (quote -) (field-name field) (quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331)) (g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333)) (null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons (car g329) g327)) (g335)))) (g335))) (g335))))) From 04426527154e1f5dba4c0dddee5fc49cdb4264d4 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sat, 10 Mar 2001 03:08:28 +0000 Subject: [PATCH 0689/2047] * goops.texi (VERSION): Bumped to version 0.3. * goops-tutorial.texi, goops.texi: Updated to reflext new define-method syntax. --- doc/ChangeLog | 7 + doc/goops-tutorial.texi | 809 ---------------------------------------- doc/goops.texi | 46 ++- 3 files changed, 28 insertions(+), 834 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index c06be02fa..324a86d6c 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,10 @@ +2001-03-09 Mikael Djurfeldt + + * goops.texi (VERSION): Bumped to version 0.3. + + * goops-tutorial.texi, goops.texi: Updated to reflext new + define-method syntax. + 2001-03-09 Neil Jerram * Makefile.am: Change HTML to HTMLDOC, now that we're part of a diff --git a/doc/goops-tutorial.texi b/doc/goops-tutorial.texi index 7897b9f40..e69de29bb 100644 --- a/doc/goops-tutorial.texi +++ b/doc/goops-tutorial.texi @@ -1,809 +0,0 @@ -@c Original attribution: - -@c -@c STk Reference manual (Appendix: An Introduction to STklos) -@c -@c Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI -@c Permission to use, copy, modify, distribute,and license this -@c software and its documentation for any purpose is hereby granted, -@c provided that existing copyright notices are retained in all -@c copies and that this notice is included verbatim in any -@c distributions. No written agreement, license, or royalty fee is -@c required for any of the authorized uses. -@c This software is provided ``AS IS'' without express or implied -@c warranty. -@c - -@c Adapted for use in Guile with the authors permission - -@c @macro goops @c was {\stklos} -@c GOOPS -@c @end macro - -@c @macro guile @c was {\stk} -@c Guile -@c @end macro - -This is chapter was originally written by Erick Gallesio as an appendix -for the STk reference manual, and subsequently adapted to @goops{}. - -@menu -* Copyright:: -* Intro:: -* Class definition and instantiation:: -* Inheritance:: -* Generic functions:: -@end menu - -@node Copyright, Intro, Tutorial, Tutorial -@section Copyright - -Original attribution: - -STk Reference manual (Appendix: An Introduction to STklos) - -Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI -Permission to use, copy, modify, distribute,and license this -software and its documentation for any purpose is hereby granted, -provided that existing copyright notices are retained in all -copies and that this notice is included verbatim in any -distributions. No written agreement, license, or royalty fee is -required for any of the authorized uses. -This software is provided ``AS IS'' without express or implied -warranty. - -Adapted for use in Guile with the authors permission - -@node Intro, Class definition and instantiation, Copyright, Tutorial -@section Introduction - -@goops{} is the object oriented extension to @guile{}. Its -implementation is derived from @w{STk-3.99.3} by Erick Gallesio and -version 1.3 of the Gregor Kiczales @cite{Tiny-Clos}. It is very close -to CLOS, the Common Lisp Object System (@cite{CLtL2}) but is adapted for -the Scheme language. - -Briefly stated, the @goops{} extension gives the user a full object -oriented system with multiple inheritance and generic functions with -multi-method dispatch. Furthermore, the implementation relies on a true -meta object protocol, in the spirit of the one defined for CLOS -(@cite{Gregor Kiczales: A Metaobject Protocol}). - -The purpose of this tutorial is to introduce briefly the @goops{} -package and in no case will it replace the @goops{} reference manual -(which needs to be urgently written now@ @dots{}). - -Note that the operations described in this tutorial resides in modules -that may need to be imported before being available. The main module is -imported by evaluating: - -@lisp -(use-modules (oop goops)) -@end lisp -@findex (oop goops) -@cindex main module -@cindex loading -@cindex preparing - -@node Class definition and instantiation, Inheritance, Intro, Tutorial -@section Class definition and instantiation - -@menu -* Class definition:: -@end menu - -@node Class definition, , Class definition and instantiation, Class definition and instantiation -@subsection Class definition - -A new class is defined with the @code{define-class}@footnote{Don't -forget to import the @code{(oop goops)} module} macro. The syntax of -@code{define-class} is close to CLOS @code{defclass}: - -@findex define-class -@cindex class -@lisp -(define-class @var{class} (@var{superclass} @dots{}) - @var{slot-description} @dots{} - @var{class-option} @dots{}) -@end lisp - -Class options will not be discussed in this tutorial. The list of -@var{superclass}es specifies which classes to inherit properties from -@var{class} (see @ref{Inheritance} for more details). A -@var{slot-description} gives the name of a slot and, eventually, some -``properties'' of this slot (such as its initial value, the function -which permit to access its value, @dots{}). Slot descriptions will be -discussed in @ref{Slot description}. -@cindex slot - -As an example, let us define a type for representation of complex -numbers in terms of real numbers. This can be done with the following -class definition: - -@lisp -(define-class () - r i) -@end lisp - -This binds the variable @code{}@footnote{@code{} is in -fact a builtin class in GOOPS. Because of this, GOOPS will create a new -class. The old class will still serve as the type for Guile's native -complex numbers.} to a new class whose instances contain two -slots. These slots are called @code{r} an @code{i} and we suppose here -that they contain respectively the real part and the imaginary part of a -complex number. Note that this class inherits from @code{} which -is a pre-defined class. (@code{} is the direct super class of -the pre-defined class @code{} which, in turn, is the super -class of @code{} which is the super of -@code{}.)@footnote{With the new definition of @code{}, -a @code{} is not a @code{} since @code{} inherits -from @code{ } rather than @code{}. In practice, -inheritance could be modified @emph{a posteriori}, if needed. However, -this necessitates some knowledge of the meta object protocol and it will -not be shown in this document}. - -@node Inheritance, Generic functions, Class definition and instantiation, Tutorial -@section Inheritance -@c \label{inheritance} - -@menu -* Class hierarchy and inheritance of slots:: -* Instance creation and slot access:: -* Slot description:: -* Class precedence list:: -@end menu - -@node Class hierarchy and inheritance of slots, Instance creation and slot access, Inheritance, Inheritance -@subsection Class hierarchy and inheritance of slots -Inheritance is specified upon class definition. As said in the -introduction, @goops{} supports multiple inheritance. Here are some -class definitions: - -@lisp -(define-class A () a) -(define-class B () b) -(define-class C () c) -(define-class D (A B) d a) -(define-class E (A C) e c) -(define-class F (D E) f) -@end lisp - -@code{A}, @code{B}, @code{C} have a null list of super classes. In this -case, the system will replace it by the list which only contains -@code{}, the root of all the classes defined by -@code{define-class}. @code{D}, @code{E}, @code{F} use multiple -inheritance: each class inherits from two previously defined classes. -Those class definitions define a hierarchy which is shown in Figure@ 1. -In this figure, the class @code{} is also shown; this class is the -super class of all Scheme objects. In particular, @code{} is the -super class of all standard Scheme types. - -@example -@group -@image{hierarchy} -@center @emph{Fig 1: A class hierarchy} -@iftex -@emph{(@code{} which is the direct subclass of @code{} -and the direct superclass of @code{} has been omitted in this -figure.)} -@end iftex -@end group -@end example - -The set of slots of a given class is calculated by taking the union of the -slots of all its super class. For instance, each instance of the class -D, defined before will have three slots (@code{a}, @code{b} and -@code{d}). The slots of a class can be obtained by the @code{class-slots} -primitive. For instance, - -@lisp -(class-slots A) @result{} ((a)) -(class-slots E) @result{} ((a) (e) (c)) -(class-slots F) @result{} ((e) (c) (b) (d) (a) (f)) -@c used to be ((d) (a) (b) (c) (f)) -@end lisp - -@emph{Note: } The order of slots is not significant. - -@node Instance creation and slot access, Slot description, Class hierarchy and inheritance of slots, Inheritance -@subsection Instance creation and slot access - -Creation of an instance of a previously defined -class can be done with the @code{make} procedure. This -procedure takes one mandatory parameter which is the class of the -instance which must be created and a list of optional -arguments. Optional arguments are generally used to initialize some -slots of the newly created instance. For instance, the following form - -@findex make -@cindex instance -@lisp -(define c (make )) -@end lisp - -will create a new @code{} object and will bind it to the @code{c} -Scheme variable. - -Accessing the slots of the new complex number can be done with the -@code{slot-ref} and the @code{slot-set!} primitives. @code{Slot-set!} -primitive permits to set the value of an object slot and @code{slot-ref} -permits to get its value. - -@findex slot-set! -@findex slot-ref -@lisp -@group -(slot-set! c 'r 10) -(slot-set! c 'i 3) -(slot-ref c 'r) @result{} 10 -(slot-ref c 'i) @result{} 3 -@end group -@end lisp - -Using the @code{describe} function is a simple way to see all the -slots of an object at one time: this function prints all the slots of an -object on the standard output. - -First load the module @code{(oop goops describe)}: - -@example -@code{(use-modules (oop goops describe))} -@end example - -The expression - -@smalllisp -(describe c) -@end smalllisp - -will now print the following information on the standard output: - -@lisp -#< 401d8638> is an instance of class -Slots are: - r = 10 - i = 3 -@end lisp - -@node Slot description, Class precedence list, Instance creation and slot access, Inheritance -@subsection Slot description -@c \label{slot-description} - -When specifying a slot, a set of options can be given to the -system. Each option is specified with a keyword. The list of authorized -keywords is given below: - -@cindex keyword -@itemize @bullet -@item -@code{#:init-value} permits to supply a default value for the slot. This -default value is obtained by evaluating the form given after the -@code{#:init-form} in the global environment, at class definition time. -@cindex default slot value -@findex #:init-value -@cindex top level environment - -@item -@code{#:init-thunk} permits to supply a thunk that will provide a -default value for the slot. The value is obtained by evaluating the -thunk a instance creation time. -@c CHECKME: in the global environment? -@findex default slot value -@findex #:init-thunk -@cindex top level environment - -@item -@code{#:init-keyword} permits to specify the keyword for initializing a -slot. The init-keyword may be provided during instance creation (i.e. in -the @code{make} optional parameter list). Specifying such a keyword -during instance initialization will supersede the default slot -initialization possibly given with @code{#:init-form}. -@findex #:init-keyword - -@item -@code{#:getter} permits to supply the name for the -slot getter. The name binding is done in the -environment of the @code{define-class} macro. -@findex #:getter -@cindex top level environment -@cindex getter - -@item -@code{#:setter} permits to supply the name for the -slot setter. The name binding is done in the -environment of the @code{define-class} macro. -@findex #:setter -@cindex top level environment -@cindex setter - -@item -@code{#:accessor} permits to supply the name for the -slot accessor. The name binding is done in the global -environment. An accessor permits to get and -set the value of a slot. Setting the value of a slot is done with the extended -version of @code{set!}. -@findex set! -@findex #:accessor -@cindex top level environment -@cindex accessor - -@item -@code{#:allocation} permits to specify how storage for -the slot is allocated. Three kinds of allocation are provided. -They are described below: - -@itemize @minus -@item -@code{#:instance} indicates that each instance gets its own storage for -the slot. This is the default. -@item -@code{#:class} indicates that there is one storage location used by all -the direct and indirect instances of the class. This permits to define a -kind of global variable which can be accessed only by (in)direct -instances of the class which defines this slot. -@item -@code{#:each-subclass} indicates that there is one storage location used -by all the direct instances of the class. In other words, if two classes -are not siblings in the class hierarchy, they will not see the same -value. -@item -@code{#:virtual} indicates that no storage will be allocated for this -slot. It is up to the user to define a getter and a setter function for -this slot. Those functions must be defined with the @code{#:slot-ref} -and @code{#:slot-set!} options. See the example below. -@findex #:slot-set! -@findex #:slot-ref -@findex #:virtual -@findex #:class -@findex #:each-subclass -@findex #:instance -@findex #:allocation -@end itemize -@end itemize - -To illustrate slot description, we shall redefine the @code{} class -seen before. A definition could be: - -@lisp -(define-class () - (r #:init-value 0 #:getter get-r #:setter set-r! #:init-keyword #:r) - (i #:init-value 0 #:getter get-i #:setter set-i! #:init-keyword #:i)) -@end lisp - -With this definition, the @code{r} and @code{i} slot are set to 0 by -default. Value of a slot can also be specified by calling @code{make} -with the @code{#:r} and @code{#:i} keywords. Furthermore, the generic -functions @code{get-r} and @code{set-r!} (resp. @code{get-i} and -@code{set-i!}) are automatically defined by the system to read and write -the @code{r} (resp. @code{i}) slot. - -@lisp -(define c1 (make #:r 1 #:i 2)) -(get-r c1) @result{} 1 -(set-r! c1 12) -(get-r c1) @result{} 12 -(define c2 (make #:r 2)) -(get-r c2) @result{} 2 -(get-i c2) @result{} 0 -@end lisp - -Accessors provide an uniform access for reading and writing an object -slot. Writing a slot is done with an extended form of @code{set!} -which is close to the Common Lisp @code{setf} macro. So, another -definition of the previous @code{} class, using the -@code{#:accessor} option, could be: - -@findex set! -@lisp -(define-class () - (r #:init-value 0 #:accessor real-part #:init-keyword #:r) - (i #:init-value 0 #:accessor imag-part #:init-keyword #:i)) -@end lisp - -Using this class definition, reading the real part of the @code{c} -complex can be done with: -@lisp -(real-part c) -@end lisp -and setting it to the value contained in the @code{new-value} variable -can be done using the extended form of @code{set!}. -@lisp -(set! (real-part c) new-value) -@end lisp - -Suppose now that we have to manipulate complex numbers with rectangular -coordinates as well as with polar coordinates. One solution could be to -have a definition of complex numbers which uses one particular -representation and some conversion functions to pass from one -representation to the other. A better solution uses virtual slots. A -complete definition of the @code{} class using virtual slots is -given in Figure@ 2. - -@example -@group -@lisp -(define-class () - ;; True slots use rectangular coordinates - (r #:init-value 0 #:accessor real-part #:init-keyword #:r) - (i #:init-value 0 #:accessor imag-part #:init-keyword #:i) - ;; Virtual slots access do the conversion - (m #:accessor magnitude #:init-keyword #:magn - #:allocation #:virtual - #:slot-ref (lambda (o) - (let ((r (slot-ref o 'r)) (i (slot-ref o 'i))) - (sqrt (+ (* r r) (* i i))))) - #:slot-set! (lambda (o m) - (let ((a (slot-ref o 'a))) - (slot-set! o 'r (* m (cos a))) - (slot-set! o 'i (* m (sin a)))))) - (a #:accessor angle #:init-keyword #:angle - #:allocation #:virtual - #:slot-ref (lambda (o) - (atan (slot-ref o 'i) (slot-ref o 'r))) - #:slot-set! (lambda(o a) - (let ((m (slot-ref o 'm))) - (slot-set! o 'r (* m (cos a))) - (slot-set! o 'i (* m (sin a))))))) - -@end lisp -@center @emph{Fig 2: A @code{} number class definition using virtual slots} -@end group -@end example - -@sp 3 -This class definition implements two real slots (@code{r} and -@code{i}). Values of the @code{m} and @code{a} virtual slots are -calculated from real slot values. Reading a virtual slot leads to the -application of the function defined in the @code{#:slot-ref} -option. Writing such a slot leads to the application of the function -defined in the @code{#:slot-set!} option. For instance, the following -expression - -@findex #:slot-set! -@findex #:slot-ref -@lisp -(slot-set! c 'a 3) -@end lisp - -permits to set the angle of the @code{c} complex number. This expression -conducts, in fact, to the evaluation of the following expression - -@lisp -((lambda o m) - (let ((m (slot-ref o 'm))) - (slot-set! o 'r (* m (cos a))) - (slot-set! o 'i (* m (sin a)))) - c 3) -@end lisp - -A more complete example is given below: - -@example -@group -@lisp -(define c (make #:r 12 #:i 20)) -(real-part c) @result{} 12 -(angle c) @result{} 1.03037682652431 -(slot-set! c 'i 10) -(set! (real-part c) 1) -(describe c) @result{} - #< 401e9b58> is an instance of class - Slots are: - r = 1 - i = 10 - m = 10.0498756211209 - a = 1.47112767430373 -@end lisp -@end group -@end example - -Since initialization keywords have been defined for the four slots, we -can now define the @code{make-rectangular} and @code{make-polar} standard -Scheme primitives. - -@lisp -(define make-rectangular - (lambda (x y) (make #:r x #:i y))) - -(define make-polar - (lambda (x y) (make #:magn x #:angle y))) -@end lisp - -@node Class precedence list, , Slot description, Inheritance -@subsection Class precedence list - -A class may have more than one superclass. @footnote{This section is an -adaptation of Jeff Dalton's (J.Dalton@@ed.ac.uk) @cite{Brief -introduction to CLOS}} With single inheritance (one superclass), it is -easy to order the super classes from most to least specific. This is the -rule: - -@display -@cartouche -Rule 1: Each class is more specific than its superclasses.@c was \bf -@end cartouche -@end display - -With multiple inheritance, ordering is harder. Suppose we have - -@lisp -(define-class X () - (x #:init-value 1)) - -(define-class Y () - (x #:init-value 2)) - -(define-class Z (X Y) - (@dots{})) -@end lisp - -In this case, the @code{Z} class is more specific than the @code{X} or -@code{Y} class for instances of @code{Z}. However, the @code{#:init-value} -specified in @code{X} and @code{Y} leads to a problem: which one -overrides the other? The rule in @goops{}, as in CLOS, is that the -superclasses listed earlier are more specific than those listed later. -So: - -@display -@cartouche -Rule 2: For a given class, superclasses listed earlier are more - specific than those listed later. -@end cartouche -@end display - -These rules are used to compute a linear order for a class and all its -superclasses, from most specific to least specific. This order is -called the ``class precedence list'' of the class. Given these two -rules, we can claim that the initial form for the @code{x} slot of -previous example is 1 since the class @code{X} is placed before @code{Y} -in class precedence list of @code{Z}. - -These two rules are not always enough to determine a unique order, -however, but they give an idea of how things work. Taking the @code{F} -class shown in Figure@ 1, the class precedence list is - -@example -(f d e a c b ) -@end example - -However, it is usually considered a bad idea for programmers to rely on -exactly what the order is. If the order for some superclasses is important, -it can be expressed directly in the class definition. - -The precedence list of a class can be obtained by the function -@code{class-precedence-list}. This function returns a ordered -list whose first element is the most specific class. For instance, - -@lisp -(class-precedence-list B) @result{} (#< B 401b97c8> - #< 401e4a10> - #< 4026a9d8>) -@end lisp - -However, this result is not too much readable; using the function -@code{class-name} yields a clearer result: - -@lisp -(map class-name (class-precedence-list B)) @result{} (B ) -@end lisp - -@node Generic functions, , Inheritance, Tutorial -@section Generic functions - -@menu -* Generic functions and methods:: -* Next-method:: -* Example:: -@end menu - -@node Generic functions and methods, Next-method, Generic functions, Generic functions -@subsection Generic functions and methods - -@c \label{gf-n-methods} -Neither @goops{} nor CLOS use the message mechanism for methods as most -Object Oriented language do. Instead, they use the notion of -@dfn{generic functions}. A generic function can be seen as a methods -``tanker''. When the evaluator requested the application of a generic -function, all the methods of this generic function will be grabbed and -the most specific among them will be applied. We say that a method -@var{M} is @emph{more specific} than a method @var{M'} if the class of -its parameters are more specific than the @var{M'} ones. To be more -precise, when a generic function must be ``called'' the system will: - -@cindex generic function -@enumerate -@item -search among all the generic function those which are applicable -@item -sort the list of applicable methods in the ``most specific'' order -@item -call the most specific method of this list (i.e. the first method of -the sorted methods list). -@end enumerate - -The definition of a generic function is done with the -@code{define-generic} macro. Definition of a new method is done with the -@code{define-method} macro. Note that @code{define-method} automatically -defines the generic function if it has not been defined -before. Consequently, most of the time, the @code{define-generic} needs -not be used. -@findex define-generic -@findex define-method -Consider the following definitions: - -@lisp -(define-generic G) -(define-method G ((a ) b) 'integer) -(define-method G ((a ) b) 'real) -(define-method G (a b) 'top) -@end lisp - -The @code{define-generic} call defines @var{G} as a generic -function. Note that the signature of the generic function is not given -upon definition, contrarily to CLOS. This will permit methods with -different signatures for a given generic function, as we shall see -later. The three next lines define methods for the @var{G} generic -function. Each method uses a sequence of @dfn{parameter specializers} -that specify when the given method is applicable. A specializer permits -to indicate the class a parameter must belong to (directly or -indirectly) to be applicable. If no specializer is given, the system -defaults it to @code{}. Thus, the first method definition is -equivalent to - -@cindex parameter specializers -@lisp -(define-method G ((a ) (b )) 'integer) -@end lisp - -Now, let us look at some possible calls to generic function @var{G}: - -@lisp -(G 2 3) @result{} integer -(G 2 #t) @result{} integer -(G 1.2 'a) @result{} real -@c (G #3 'a) @result{} real @c was {\sharpsign} -(G #t #f) @result{} top -(G 1 2 3) @result{} error (since no method exists for 3 parameters) -@end lisp - -The preceding methods use only one specializer per parameter list. Of -course, each parameter can use a specializer. In this case, the -parameter list is scanned from left to right to determine the -applicability of a method. Suppose we declare now - -@lisp -(define-method G ((a ) (b )) 'integer-number) -(define-method G ((a ) (b )) 'integer-real) -(define-method G ((a ) (b )) 'integer-integer) -(define-method G (a (b )) 'top-number) -@end lisp - -In this case, - -@lisp -(G 1 2) @result{} integer-integer -(G 1 1.0) @result{} integer-real -(G 1 #t) @result{} integer -(G 'a 1) @result{} top-number -@end lisp - -@node Next-method, Example, Generic functions and methods, Generic functions -@subsection Next-method - -When a generic function is called, the list of applicable methods is -built. As mentioned before, the most specific method of this list is -applied (see@ @ref{Generic functions and methods}). This method may call -the next method in the list of applicable methods. This is done by using -the special form @code{next-method}. Consider the following definitions - -@lisp -(define-method Test ((a )) (cons 'integer (next-method))) -(define-method Test ((a )) (cons 'number (next-method))) -(define-method Test (a) (list 'top)) -@end lisp - -With those definitions, - -@lisp -(Test 1) @result{} (integer number top) -(Test 1.0) @result{} (number top) -(Test #t) @result{} (top) -@end lisp - -@node Example, , Next-method, Generic functions -@subsection Example - -In this section we shall continue to define operations on the @code{} -class defined in Figure@ 2. Suppose that we want to use it to implement -complex numbers completely. For instance a definition for the addition of -two complexes could be - -@lisp -(define-method new-+ ((a ) (b )) - (make-rectangular (+ (real-part a) (real-part b)) - (+ (imag-part a) (imag-part b)))) -@end lisp - -To be sure that the @code{+} used in the method @code{new-+} is the standard -addition we can do: - -@lisp -(define-generic new-+) - -(let ((+ +)) - (define-method new-+ ((a ) (b )) - (make-rectangular (+ (real-part a) (real-part b)) - (+ (imag-part a) (imag-part b))))) -@end lisp - -The @code{define-generic} ensures here that @code{new-+} will be defined -in the global environment. Once this is done, we can add methods to the -generic function @code{new-+} which make a closure on the @code{+} -symbol. A complete writing of the @code{new-+} methods is shown in -Figure@ 3. - -@example -@group -@lisp -(define-generic new-+) - -(let ((+ +)) - - (define-method new-+ ((a ) (b )) (+ a b)) - - (define-method new-+ ((a ) (b )) - (make-rectangular (+ a (real-part b)) (imag-part b))) - - (define-method new-+ ((a ) (b )) - (make-rectangular (+ (real-part a) b) (imag-part a))) - - (define-method new-+ ((a ) (b )) - (make-rectangular (+ (real-part a) (real-part b)) - (+ (imag-part a) (imag-part b)))) - - (define-method new-+ ((a )) a) - - (define-method new-+ () 0) - - (define-method new-+ args (new-+ (car args) - (apply new-+ (cdr args))))) - -(set! + new-+) -@end lisp - -@center @emph{Fig 3: Extending @code{+} for dealing with complex numbers} -@end group -@end example - -@sp 3 -We use here the fact that generic function are not obliged to have the -same number of parameters, contrarily to CLOS. The four first methods -implement the dyadic addition. The fifth method says that the addition -of a single element is this element itself. The sixth method says that -using the addition with no parameter always return 0. The last method -takes an arbitrary number of parameters@footnote{The third parameter of -a @code{define-method} is a parameter list which follow the conventions -used for lambda expressions. In particular it can use the dot notation -or a symbol to denote an arbitrary number of parameters}. This method -acts as a kind of @code{reduce}: it calls the dyadic addition on the -@emph{car} of the list and on the result of applying it on its rest. To -finish, the @code{set!} permits to redefine the @code{+} symbol to our -extended addition. - -@sp 3 -To terminate our implementation (integration?) of complex numbers, we can -redefine standard Scheme predicates in the following manner: - -@lisp -(define-method complex? (c ) #t) -(define-method complex? (c) #f) - -(define-method number? (n ) #t) -(define-method number? (n) #f) -@dots{} -@dots{} -@end lisp - -Standard primitives in which complex numbers are involved could also be -redefined in the same manner. - diff --git a/doc/goops.texi b/doc/goops.texi index 918b4697a..981a7a77d 100644 --- a/doc/goops.texi +++ b/doc/goops.texi @@ -7,7 +7,7 @@ @paragraphindent 0 @c %**end of header -@set VERSION 0.2 +@set VERSION 0.3 @dircategory The Algorithmic Language Scheme @direntry @@ -25,7 +25,7 @@ Guile @ifinfo This file documents GOOPS, an object oriented extension for Guile. -Copyright (C) 1999, 2000 Free Software Foundation +Copyright (C) 1999, 2000, 2001 Free Software Foundation Permission is granted to make and distribute verbatim copies of this manual provided the copyright notice and this permission notice @@ -157,7 +157,7 @@ We're now ready to try some basic GOOPS functionality. @smalllisp @group -(define-method + ((x ) (y )) +(define-method (+ (x ) (y )) (string-append x y)) (+ 1 2) --> 3 @@ -176,7 +176,7 @@ We're now ready to try some basic GOOPS functionality. @group (use-modules (ice-9 format)) -(define-method write ((obj <2D-vector>) port) +(define-method (write (obj <2D-vector>) port) (display (format #f "<~S, ~S>" (x-component obj) (y-component obj)) port)) @@ -186,7 +186,7 @@ v --> <3, 4> @end group @group -(define-method + ((x <2D-vector>) (y <2D-vector>)) +(define-method (+ (x <2D-vector>) (y <2D-vector>)) (make <2D-vector> #:x (+ (x-component x) (x-component y)) #:y (+ (y-component x) (y-component y)))) @@ -557,7 +557,7 @@ Reference methods for an accessor are defined in the same way as generic function methods. @example -(define-method perimeter ((s )) +(define-method (perimeter (s )) (* 4 (side-length s))) @end example @@ -566,7 +566,7 @@ Setter methods for an accessor are defined by specifying ``(setter call. @example -(define-method (setter perimeter) ((s ) (n )) +(define-method ((setter perimeter) (s ) (n )) (set! (side-length s) (/ n 4))) @end example @@ -864,7 +864,7 @@ specialized method of the generic function @code{initialize}, whose signature is @example -(define-method initialize ((object ) initargs) ...) +(define-method (initialize (object ) initargs) ...) @end example The initialization of instances of any given class can be customized by @@ -1086,7 +1086,7 @@ allocation to do this. (let ((batch-allocation-count 0) (batch-get-n-set #f)) - (define-method compute-get-n-set ((class ) s) + (define-method (compute-get-n-set (class ) s) (case (slot-definition-allocation s) ((#:batched) ;; If we've already used the same slot storage for 10 instances, @@ -1665,21 +1665,17 @@ procedures described in this section may disappear as well. To add a method to a generic function, use the @code{define-method} form. -@deffn syntax define-method symbol (parameter @dots{}) . body -Define a method for the generic function or accessor @var{symbol} with +@deffn syntax define-method (generic parameter @dots{}) . body +Define a method for the generic function or accessor @var{generic} with parameters @var{parameter}s and body @var{body}. -@var{symbol} must be either a symbol for a variable bound to a generic -function or accessor, or @code{(setter @var{accessor-symbol})}, where -@var{accessor-symbol} is a symbol for a variable bound to an accessor. -If the former, @code{define-method} defines a reference method for the -specified generic function or accessor; if the latter, -@code{define-method} defines a setter method for the specified accessor. -The @var{symbol} parameter is subject to these restrictions (rather than -being allowed to be anything that evaluates to a generic function) so -that @code{define-method} can construct a call to @code{define-generic} -or @code{define-accessor} if @var{symbol} is not already defined as a -generic function. +@var{generic} is a generic function. If @var{generic} is a variable +which is not yet bound to a generic function object, the expansion of +@code{define-method} will include a call to @code{define-generic}. If +@var{generic} is @code{(setter @var{generic-with-setter})}, where +@var{generic-with-setter} is a variable which is not yet bound to a +generic-with-setter object, the expansion will include a call to +@code{define-accessor}. Each @var{parameter} must be either a symbol or a two-element list @code{(@var{symbol} @var{class})}. The symbols refer to variables in @@ -1695,7 +1691,7 @@ can be applied. procedure definitions of the form @example -(define name (lambda (formals @dots{}) . body)) +(define (name formals @dots{}) . body) @end example The most important difference is that each formal parameter, apart from the @@ -1997,7 +1993,7 @@ is specialized for this metaclass: @example (define-class ()) -(define-method class-redefinition ((old ) (new )) +(define-method (class-redefinition (old ) (new )) new) @end example @@ -2304,7 +2300,7 @@ Return an expression that prints to show the definition of method @example (define-generic cube) -(define-method cube ((n )) +(define-method (cube (n )) (* n n n)) (map method-source (generic-function-methods cube)) From e75341b38d65736421ace4b75f405b0bcdaacf9c Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sat, 10 Mar 2001 03:09:07 +0000 Subject: [PATCH 0690/2047] * coop.c: Inserted #include . * iselect.c: Reinserted #include . --- libguile/ChangeLog | 6 ++++++ libguile/coop.c | 6 ++++-- libguile/iselect.c | 3 ++- 3 files changed, 12 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index c918c1084..4552f73ee 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2001-03-09 Mikael Djurfeldt + + * coop.c: Inserted #include . + + * iselect.c: Reinserted #include . + 2001-03-10 Marius Vollmer * posix.c: Replaced `#define' of __USE_XOPEN right before diff --git a/libguile/coop.c b/libguile/coop.c index 339acc95e..a6ef33ed2 100644 --- a/libguile/coop.c +++ b/libguile/coop.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001 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 @@ -40,10 +40,12 @@ * If you do not wish that, delete this exception notice. */ -/* $Id: coop.c,v 1.26 2000-11-30 10:26:44 dirk Exp $ */ +/* $Id: coop.c,v 1.27 2001-03-10 03:09:07 mdj Exp $ */ /* Cooperative thread library, based on QuickThreads */ +#include + #ifdef HAVE_UNISTD_H #include #endif diff --git a/libguile/iselect.c b/libguile/iselect.c index d7bda8812..50ea3dc11 100644 --- a/libguile/iselect.c +++ b/libguile/iselect.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1997, 1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1997, 1998, 2000, 2001 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 @@ -39,6 +39,7 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ +#include #include #include From 71d540f734534c3a783d9b65fd84a3a299402b86 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sat, 10 Mar 2001 03:09:50 +0000 Subject: [PATCH 0691/2047] * goops.scm (define-method): Only accept new syntax. * goops/old-define-method.scm: New file. * goops.scm, goops/save.scm, goops/composite-slot.scm, goops/active-slot.scm: Use new method syntax. --- oop/ChangeLog | 11 ++ oop/goops.scm | 181 +++++++++++++++++--------------- oop/goops/Makefile.am | 5 +- oop/goops/active-slot.scm | 4 +- oop/goops/composite-slot.scm | 4 +- oop/goops/describe.scm | 14 +-- oop/goops/old-define-method.scm | 62 +++++++++++ oop/goops/save.scm | 58 +++++----- 8 files changed, 213 insertions(+), 126 deletions(-) create mode 100644 oop/goops/old-define-method.scm diff --git a/oop/ChangeLog b/oop/ChangeLog index cf3f52287..56c117c72 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -1,3 +1,14 @@ +2001-03-09 Mikael Djurfeldt + + * goops.scm (define-method): Only accept new syntax. + + * Makefile.am: Added old-define-method.scm. + + * goops/old-define-method.scm: New file. + + * goops.scm, goops/save.scm, goops/composite-slot.scm, + goops/active-slot.scm: Use new method syntax. + 2001-03-04 Mikael Djurfeldt * goops/compile.scm (compile-method): Tag method closure for body diff --git a/oop/goops.scm b/oop/goops.scm index ca5c85dec..32b86108e 100644 --- a/oop/goops.scm +++ b/oop/goops.scm @@ -425,40 +425,53 @@ (define define-method (procedure->memoizing-macro (lambda (exp env) - (let ((name (cadr exp))) - (if (and (pair? name) - (eq? (car name) 'setter) - (pair? (cdr name)) - (symbol? (cadr name)) - (null? (cddr name))) - (let ((name (cadr name))) - (cond ((not (symbol? name)) - (goops-error "bad method name: ~S" name)) - ((defined? name env) + (let ((head (cadr exp))) + (if (not (pair? head)) + (goops-error "bad method head: ~S" head) + (let ((gf (car head))) + (cond ((and (pair? gf) + (eq? (car gf) 'setter) + (pair? (cdr gf)) + (symbol? (cadr gf)) + (null? (cddr gf))) + ;; named setter method + (let ((name (cadr gf))) + (cond ((not (symbol? name)) + `(add-method! (setter ,name) + (method ,(cdadr exp) + ,@(cddr exp)))) + ((defined? name env) + `(begin + ;; *fixme* Temporary hack for the current + ;; module system + (if (not ,name) + (define-accessor ,name)) + (add-method! (setter ,name) + (method ,(cdadr exp) + ,@(cddr exp))))) + (else + `(begin + (define-accessor ,name) + (add-method! (setter ,name) + (method ,(cdadr exp) + ,@(cddr exp)))))))) + ((not (symbol? gf)) + `(add-method! ,gf (method ,(cdadr exp) ,@(cddr exp)))) + ((defined? gf env) `(begin - ;; *fixme* Temporary hack for the current module system - (if (not ,name) - (define-generic ,name)) - (add-method! (setter ,name) (method ,@(cddr exp))))) + ;; *fixme* Temporary hack for the current + ;; module system + (if (not ,gf) + (define-generic ,gf)) + (add-method! ,gf + (method ,(cdadr exp) + ,@(cddr exp))))) (else `(begin - (define-accessor ,name) - (add-method! (setter ,name) (method ,@(cddr exp))))))) - (cond ((pair? name) - ;; Convert new syntax to old - `(define-method ,(car name) ,(cdr name) ,@(cddr exp))) - ((not (symbol? name)) - (goops-error "bad method name: ~S" name)) - ((defined? name env) - `(begin - ;; *fixme* Temporary hack for the current module system - (if (not ,name) - (define-generic ,name)) - (add-method! ,name (method ,@(cddr exp))))) - (else - `(begin - (define-generic ,name) - (add-method! ,name (method ,@(cddr exp))))))))))) + (define-generic ,gf) + (add-method! ,gf + (method ,(cdadr exp) + ,@(cddr exp)))))))))))) (define (make-method specializers procedure) (make @@ -543,17 +556,17 @@ #:specializers (list ) #:procedure internal-add-method!)) -(define-method add-method! ((proc ) (m )) +(define-method (add-method! (proc ) (m )) (if (generic-capability? proc) (begin (enable-primitive-generic! proc) (add-method! proc m)) (next-method))) -(define-method add-method! ((pg ) (m )) +(define-method (add-method! (pg ) (m )) (add-method! (primitive-generic-generic pg) m)) -(define-method add-method! (obj (m )) +(define-method (add-method! obj (m )) (goops-error "~S is not a valid generic function" obj)) ;;; @@ -563,7 +576,7 @@ ;;; ;;; Methods ;;; -(define-method method-source ((m )) +(define-method (method-source (m )) (let* ((spec (map* class-name (slot-ref m 'specializers))) (proc (procedure-source (slot-ref m 'procedure))) (args (cadr proc)) @@ -618,8 +631,8 @@ ;;; Methods to compare objects ;;; -(define-method object-eqv? (x y) #f) -(define-method object-equal? (x y) (eqv? x y)) +(define-method (object-eqv? x y) #f) +(define-method (object-equal? x y) (eqv? x y)) ;;; ;;; methods to display/write an object @@ -633,14 +646,14 @@ (define (display-address o file) (display (number->string (object-address o) 16) file)) -(define-method write (o file) +(define-method (write o file) (display "# file)) (define write-object (primitive-generic-generic write)) -(define-method write ((o ) file) +(define-method (write (o ) file) (let ((class (class-of o))) (if (slot-bound? class 'name) (begin @@ -651,7 +664,7 @@ (display #\> file)) (next-method)))) -(define-method write ((o ) file) +(define-method (write (o ) file) (let ((class (class-of o))) (if (slot-bound? class 'name) (begin @@ -662,7 +675,7 @@ (display #\> file)) (next-method)))) -(define-method write ((class ) file) +(define-method (write (class ) file) (let ((meta (class-of class))) (if (and (slot-bound? class 'name) (slot-bound? meta 'name)) @@ -676,7 +689,7 @@ (display #\> file)) (next-method)))) -(define-method write ((gf ) file) +(define-method (write (gf ) file) (let ((meta (class-of gf))) (if (and (slot-bound? meta 'name) (slot-bound? gf 'methods)) @@ -693,7 +706,7 @@ (display ")>" file)) (next-method)))) -(define-method write ((o ) file) +(define-method (write (o ) file) (let ((meta (class-of o))) (if (and (slot-bound? meta 'name) (slot-bound? o 'specializers)) @@ -713,7 +726,7 @@ (next-method)))) ;; Display (do the same thing as write by default) -(define-method display (o file) +(define-method (display o file) (write-object o file)) ;;; @@ -738,42 +751,42 @@ (define (class-slot-set! class slot value) ((cadr (class-slot-g-n-s class slot)) #f value)) -(define-method slot-unbound ((c ) (o ) s) +(define-method (slot-unbound (c ) (o ) s) (goops-error "Slot `~S' is unbound in object ~S" s o)) -(define-method slot-unbound ((c ) s) +(define-method (slot-unbound (c ) s) (goops-error "Slot `~S' is unbound in class ~S" s c)) -(define-method slot-unbound ((o )) +(define-method (slot-unbound (o )) (goops-error "Unbound slot in object ~S" o)) -(define-method slot-missing ((c ) (o ) s) +(define-method (slot-missing (c ) (o ) s) (goops-error "No slot with name `~S' in object ~S" s o)) -(define-method slot-missing ((c ) s) +(define-method (slot-missing (c ) s) (goops-error "No class slot with name `~S' in class ~S" s c)) -(define-method slot-missing ((c ) (o ) s value) +(define-method (slot-missing (c ) (o ) s value) (slot-missing c o s)) ;;; Methods for the possible error we can encounter when calling a gf -(define-method no-next-method ((gf ) args) +(define-method (no-next-method (gf ) args) (goops-error "No next method when calling ~S\nwith arguments ~S" gf args)) -(define-method no-applicable-method ((gf ) args) +(define-method (no-applicable-method (gf ) args) (goops-error "No applicable method for ~S in call ~S" gf (cons (generic-function-name gf) args))) -(define-method no-method ((gf ) args) +(define-method (no-method (gf ) args) (goops-error "No method defined for ~S" gf)) ;;; ;;; {Cloning functions (from rdeline@CS.CMU.EDU)} ;;; -(define-method shallow-clone ((self )) +(define-method (shallow-clone (self )) (let ((clone (%allocate-instance (class-of self) '())) (slots (map slot-definition-name (class-slots (class-of self))))) @@ -783,7 +796,7 @@ slots) clone)) -(define-method deep-clone ((self )) +(define-method (deep-clone (self )) (let ((clone (%allocate-instance (class-of self) '())) (slots (map slot-definition-name (class-slots (class-of self))))) @@ -816,7 +829,7 @@ ;;; 2. Old class header exists on old super classes direct-subclass lists ;;; 3. New class header exists on new super classes direct-subclass lists -(define-method class-redefinition ((old ) (new )) +(define-method (class-redefinition (old ) (new )) ;; Work on direct methods: ;; 1. Remove accessor methods from the old class ;; 2. Patch the occurences of new in the specializers by old @@ -866,7 +879,7 @@ ;;; remove-class-accessors! ;;; -(define-method remove-class-accessors! ((c )) +(define-method (remove-class-accessors! (c )) (for-each (lambda (m) (if (is-a? m ) (remove-method-in-classes! m))) @@ -876,7 +889,7 @@ ;;; update-direct-method! ;;; -(define-method update-direct-method! ((m ) +(define-method (update-direct-method! (m ) (old ) (new )) (let loop ((l (method-specializers m))) @@ -892,7 +905,7 @@ ;;; update-direct-subclass! ;;; -(define-method update-direct-subclass! ((c ) +(define-method (update-direct-subclass! (c ) (old ) (new )) (class-redefinition c @@ -929,7 +942,7 @@ (compute-setter-method class g-n-s)))))) slots (slot-ref class 'getters-n-setters))) -(define-method compute-getter-method ((class ) slotdef) +(define-method (compute-getter-method (class ) slotdef) (let ((init-thunk (cadr slotdef)) (g-n-s (cddr slotdef))) (make @@ -945,7 +958,7 @@ (bound-check-get g-n-s))) #:slot-definition slotdef))) -(define-method compute-setter-method ((class ) slotdef) +(define-method (compute-setter-method (class ) slotdef) (let ((g-n-s (cddr slotdef))) (make #:specializers (list class ) @@ -1047,7 +1060,7 @@ ;;; => cpl (a) = a b d c e f object top ;;; -(define-method compute-cpl ((class )) +(define-method (compute-cpl (class )) (compute-std-cpl class class-direct-supers)) ;; Support @@ -1174,7 +1187,7 @@ ;;; compute-get-n-set ;;; -(define-method compute-get-n-set ((class ) s) +(define-method (compute-get-n-set (class ) s) (case (slot-definition-allocation s) ((#:instance) ;; Instance slot ;; get-n-set is just its offset @@ -1217,20 +1230,20 @@ (list (lambda (o) shared-variable) (lambda (o v) (set! shared-variable v))))) -(define-method compute-get-n-set ((o ) s) +(define-method (compute-get-n-set (o ) s) (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s))) -(define-method compute-slots ((class )) +(define-method (compute-slots (class )) (%compute-slots class)) ;;; ;;; {Initialize} ;;; -(define-method initialize ((object ) initargs) +(define-method (initialize (object ) initargs) (%initialize-object object initargs)) -(define-method initialize ((class ) initargs) +(define-method (initialize (class ) initargs) (next-method) (let ((dslots (get-keyword #:slots initargs '())) (supers (get-keyword #:dsupers initargs '())) @@ -1282,23 +1295,23 @@ (set-object-procedure! object (lambda args (apply proc args))))))) -(define-method initialize ((class ) initargs) +(define-method (initialize (class ) initargs) (next-method) (initialize-object-procedure class initargs)) -(define-method initialize ((owsc ) initargs) +(define-method (initialize (owsc ) initargs) (next-method) (%set-object-setter! owsc (get-keyword #:setter initargs #f))) -(define-method initialize ((entity ) initargs) +(define-method (initialize (entity ) initargs) (next-method) (initialize-object-procedure entity initargs)) -(define-method initialize ((ews ) initargs) +(define-method (initialize (ews ) initargs) (next-method) (%set-object-setter! ews (get-keyword #:setter initargs #f))) -(define-method initialize ((generic ) initargs) +(define-method (initialize (generic ) initargs) (let ((previous-definition (get-keyword #:default initargs #f)) (name (get-keyword #:name initargs #f))) (next-method) @@ -1316,7 +1329,7 @@ (define dummy-procedure (lambda args *unspecified*)) -(define-method initialize ((method ) initargs) +(define-method (initialize (method ) initargs) (next-method) (slot-set! method 'generic-function (get-keyword #:generic-function initargs #f)) (slot-set! method 'specializers (get-keyword #:specializers initargs '())) @@ -1324,7 +1337,7 @@ (get-keyword #:procedure initargs dummy-procedure)) (slot-set! method 'code-table '())) -(define-method initialize ((obj ) initargs)) +(define-method (initialize (obj ) initargs)) ;;; ;;; {Change-class} @@ -1361,13 +1374,13 @@ old-instance)) -(define-method update-instance-for-different-class ((old-instance ) +(define-method (update-instance-for-different-class (old-instance ) (new-instance )) ;;not really important what we do, we just need a default method new-instance) -(define-method change-class ((old-instance ) (new-class )) +(define-method (change-class (old-instance ) (new-class )) (change-object-class old-instance (class-of old-instance) new-class)) ;;; @@ -1376,10 +1389,10 @@ ;;; A new definition which overwrites the previous one which was built-in ;;; -(define-method allocate-instance ((class ) initargs) +(define-method (allocate-instance (class ) initargs) (%allocate-instance class initargs)) -(define-method make-instance ((class ) . initargs) +(define-method (make-instance (class ) . initargs) (let ((instance (allocate-instance class initargs))) (initialize instance initargs) instance)) @@ -1400,7 +1413,7 @@ ;;; - the currified protocol would be imho inefficient in C. ;;; -(define-method apply-generic ((gf ) args) +(define-method (apply-generic (gf ) args) (if (null? (slot-ref gf 'methods)) (no-method gf args)) (let ((methods (compute-applicable-methods gf args))) @@ -1413,24 +1426,24 @@ (define %%compute-applicable-methods (make #:name 'compute-applicable-methods)) -(define-method %%compute-applicable-methods ((gf ) args) +(define-method (%%compute-applicable-methods (gf ) args) (%compute-applicable-methods gf args)) (set! compute-applicable-methods %%compute-applicable-methods) -(define-method sort-applicable-methods ((gf ) methods args) +(define-method (sort-applicable-methods (gf ) methods args) (let ((targs (map class-of args))) (sort methods (lambda (m1 m2) (method-more-specific? m1 m2 targs))))) -(define-method method-more-specific? ((m1 ) (m2 ) targs) +(define-method (method-more-specific? (m1 ) (m2 ) targs) (%method-more-specific? m1 m2 targs)) -(define-method apply-method ((gf ) methods build-next args) +(define-method (apply-method (gf ) methods build-next args) (apply (method-procedure (car methods)) (build-next (cdr methods) args) args)) -(define-method apply-methods ((gf ) (l ) args) +(define-method (apply-methods (gf ) (l ) args) (letrec ((next (lambda (procs args) (lambda new-args (let ((a (if (null? new-args) args new-args))) diff --git a/oop/goops/Makefile.am b/oop/goops/Makefile.am index 73a77e474..b80216bbc 100644 --- a/oop/goops/Makefile.am +++ b/oop/goops/Makefile.am @@ -1,6 +1,6 @@ ## Process this file with automake to produce Makefile.in. ## -## Copyright (C) 2000 Free Software Foundation, Inc. +## Copyright (C) 2000, 2001 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -24,7 +24,8 @@ AUTOMAKE_OPTIONS = foreign # These should be installed and distributed. goops_sources = \ active-slot.scm compile.scm composite-slot.scm describe.scm \ - dispatch.scm internal.scm save.scm stklos.scm util.scm + dispatch.scm internal.scm save.scm stklos.scm util.scm \ + old-define-method.scm subpkgdatadir = $(pkgdatadir)/$(VERSION)/oop/goops subpkgdata_DATA = $(goops_sources) diff --git a/oop/goops/active-slot.scm b/oop/goops/active-slot.scm index ca9424d0f..46e6aa921 100644 --- a/oop/goops/active-slot.scm +++ b/oop/goops/active-slot.scm @@ -1,6 +1,6 @@ ;;; installed-scm-file -;;;; Copyright (C) 1999 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001 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 @@ -33,7 +33,7 @@ (define-class ()) -(define-method compute-get-n-set ((class ) slot) +(define-method (compute-get-n-set (class ) slot) (if (eq? (slot-definition-allocation slot) #:active) (let* ((index (slot-ref class 'nfields)) (name (car slot)) diff --git a/oop/goops/composite-slot.scm b/oop/goops/composite-slot.scm index 4f44f0619..32e8d9eaf 100644 --- a/oop/goops/composite-slot.scm +++ b/oop/goops/composite-slot.scm @@ -1,6 +1,6 @@ ;;; installed-scm-file -;;;; Copyright (C) 1999, 2000 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2000, 2001 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 @@ -50,7 +50,7 @@ (define-class ()) -(define-method compute-get-n-set ((class ) slot) +(define-method (compute-get-n-set (class ) slot) (if (eq? (slot-definition-allocation slot) #:propagated) (compute-propagated-get-n-set slot) (next-method))) diff --git a/oop/goops/describe.scm b/oop/goops/describe.scm index c6e51084e..e268fb877 100644 --- a/oop/goops/describe.scm +++ b/oop/goops/describe.scm @@ -1,6 +1,6 @@ ;;; installed-scm-file -;;;; Copyright (C) 1998, 1999 Free Software Foundation, Inc. +;;;; Copyright (C) 1998, 1999, 2001 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 @@ -36,7 +36,7 @@ ;;; ;;; describe for simple objects ;;; -(define-method describe ((x )) +(define-method (describe (x )) (format #t "~s is " x) (cond ((integer? x) (format #t "an integer")) @@ -62,7 +62,7 @@ (format #t ".~%") *unspecified*) -(define-method describe ((x )) +(define-method (describe (x )) (let ((name (procedure-name x))) (if name (format #t "`~s'" name) @@ -84,7 +84,7 @@ (class-name class) class)) -(define-method describe ((x )) +(define-method (describe (x )) (format #t "~S is an instance of class ~A~%" x (safe-class-name (class-of x))) @@ -103,7 +103,7 @@ ;;; ;;; Describe for classes ;;; -(define-method describe ((x )) +(define-method (describe (x )) (format #t "~S is a class. It's an instance of ~A~%" (safe-class-name x) (safe-class-name (class-of x))) @@ -156,7 +156,7 @@ ;;; ;;; Describe for generic functions ;;; -(define-method describe ((x )) +(define-method (describe (x )) (let ((name (generic-function-name x)) (methods (generic-function-methods x))) ;; Title @@ -172,7 +172,7 @@ ;;; ;;; Describe for methods ;;; -(define-method describe ((x ) . omit-generic) +(define-method (describe (x ) . omit-generic) (letrec ((print-args (lambda (args) ;; take care of dotted arg lists (cond ((null? args) (newline)) diff --git a/oop/goops/old-define-method.scm b/oop/goops/old-define-method.scm new file mode 100644 index 000000000..915b5b25c --- /dev/null +++ b/oop/goops/old-define-method.scm @@ -0,0 +1,62 @@ +;;; installed-scm-file + +;;;; Copyright (C) 2001 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; + + +(define-module (oop goops old-define-method) + :use-module (oop goops) + :no-backtrace + ) + +(export define-method) + +(define define-method + (procedure->memoizing-macro + (lambda (exp env) + (let ((name (cadr exp))) + (if (and (pair? name) + (eq? (car name) 'setter) + (pair? (cdr name)) + (symbol? (cadr name)) + (null? (cddr name))) + (let ((name (cadr name))) + (cond ((not (symbol? name)) + (goops-error "bad method name: ~S" name)) + ((defined? name env) + `(begin + ;; *fixme* Temporary hack for the current module system + (if (not ,name) + (define-accessor ,name)) + (add-method! (setter ,name) (method ,@(cddr exp))))) + (else + `(begin + (define-accessor ,name) + (add-method! (setter ,name) (method ,@(cddr exp))))))) + (cond ((not (symbol? name)) + (goops-error "bad method name: ~S" name)) + ((defined? name env) + `(begin + ;; *fixme* Temporary hack for the current module system + (if (not ,name) + (define-generic ,name)) + (add-method! ,name (method ,@(cddr exp))))) + (else + `(begin + (define-generic ,name) + (add-method! ,name (method ,@(cddr exp))))))))))) diff --git a/oop/goops/save.scm b/oop/goops/save.scm index e2a9e54d7..fa13778bd 100644 --- a/oop/goops/save.scm +++ b/oop/goops/save.scm @@ -1,6 +1,6 @@ ;;; installed-scm-file -;;;; Copyright (C) 2000 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001 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 @@ -88,22 +88,22 @@ ;;; literal? COMPONENT ENV ;;; -(define-method immediate? ((o )) #f) +(define-method (immediate? (o )) #f) -(define-method immediate? ((o )) #t) -(define-method immediate? ((o )) #t) -(define-method immediate? ((o )) #t) -(define-method immediate? ((o )) #t) -(define-method immediate? ((o )) #t) -(define-method immediate? ((o )) #t) +(define-method (immediate? (o )) #t) +(define-method (immediate? (o )) #t) +(define-method (immediate? (o )) #t) +(define-method (immediate? (o )) #t) +(define-method (immediate? (o )) #t) +(define-method (immediate? (o )) #t) ;;; enumerate! OBJECT ENVIRONMENT ;;; ;;; Return #t if object is a literal. ;;; -(define-method enumerate! ((o ) env) #t) +(define-method (enumerate! (o ) env) #t) -(define-method write-readably ((o ) file env) +(define-method (write-readably (o ) file env) ;;(goops-error "No read-syntax defined for object `~S'" o) (write o file) ;doesn't catch bugs, but is much more flexible ) @@ -135,13 +135,13 @@ ;;; Strings ;;; -(define-method enumerate! ((o ) env) #f) +(define-method (enumerate! (o ) env) #f) ;;; ;;; Vectors ;;; -(define-method enumerate! ((o ) env) +(define-method (enumerate! (o ) env) (or (not (vector? o)) (let ((literal? #t)) (array-for-each (lambda (o) @@ -150,7 +150,7 @@ o) literal?))) -(define-method write-readably ((o ) file env) +(define-method (write-readably (o ) file env) (if (not (vector? o)) (write o file) (let ((n (vector-length o))) @@ -185,7 +185,7 @@ ;;; Arrays ;;; -(define-method enumerate! ((o ) env) +(define-method (enumerate! (o ) env) (enumerate-component! (shared-array-root o) env)) (define (make-mapper array) @@ -249,7 +249,7 @@ (display #\) file)))))) (display #\) file))) -(define-method write-readably ((o ) file env) +(define-method (write-readably (o ) file env) (let ((root (shared-array-root o))) (cond ((literal? o env) (if (not (vector? root)) @@ -288,12 +288,12 @@ ;;; `write-component'. ;;; -(define-method enumerate! ((o ) env) +(define-method (enumerate! (o ) env) (let ((literal? (enumerate-component! (car o) env))) (and (enumerate-component! (cdr o) env) literal?))) -(define-method write-readably ((o ) file env) +(define-method (write-readably (o ) file env) (let ((proper? (let loop ((ls o)) (or (null? ls) (and (pair? ls) @@ -390,7 +390,7 @@ (list ,@(cdddr exp))) o)))) -(define-method enumerate! ((o ) env) +(define-method (enumerate! (o ) env) (get-set-for-each (lambda (get set) (let ((val (get o))) (if (not (unbound? val)) @@ -398,7 +398,7 @@ (class-of o)) #f) -(define-method write-readably ((o ) file env) +(define-method (write-readably (o ) file env) (let ((class (class-of o))) (display "(restore " file) (display (class-name class) file) @@ -444,9 +444,9 @@ ;;; Currently, we don't support reading in class objects ;;; -(define-method enumerate! ((o ) env) #f) +(define-method (enumerate! (o ) env) #f) -(define-method write-readably ((o ) file env) +(define-method (write-readably (o ) file env) (display (class-name o) file)) ;;; @@ -456,9 +456,9 @@ ;;; Currently, we don't support reading in generic functions ;;; -(define-method enumerate! ((o ) env) #f) +(define-method (enumerate! (o ) env) #f) -(define-method write-readably ((o ) file env) +(define-method (write-readably (o ) file env) (display (generic-function-name o) file)) ;;; @@ -468,9 +468,9 @@ ;;; Currently, we don't support reading in methods ;;; -(define-method enumerate! ((o ) env) #f) +(define-method (enumerate! (o ) env) #f) -(define-method write-readably ((o ) file env) +(define-method (write-readably (o ) file env) (goops-error "No read-syntax for defined")) ;;; @@ -820,13 +820,13 @@ written))))) alist))) -(define-method save-objects ((alist ) (file ) . rest) +(define-method (save-objects (alist ) (file ) . rest) (let ((port (open-output-file file))) (apply save-objects alist port rest) (close-port port) *unspecified*)) -(define-method save-objects ((alist ) (file ) . rest) +(define-method (save-objects (alist ) (file ) . rest) (let ((excluded (if (>= (length rest) 1) (car rest) '())) (uses (if (>= (length rest) 2) (cadr rest) '()))) (let ((env (make #:excluded excluded))) @@ -853,13 +853,13 @@ (write-readables! alist file env) (write-rebindings! "(define " (reverse (multiple-bound env)) file env)))) -(define-method load-objects ((file )) +(define-method (load-objects (file )) (let* ((port (open-input-file file)) (objects (load-objects port))) (close-port port) objects)) -(define-method load-objects ((file )) +(define-method (load-objects (file )) (let ((m (make-module))) (module-use! m the-scm-module) (module-use! m %module-public-interface) From 7d4351201ff2388871319ba3b4b5878ea6888648 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sat, 10 Mar 2001 03:13:12 +0000 Subject: [PATCH 0692/2047] *** empty log message *** --- NEWS | 15 +++++++++++++++ doc/ChangeLog | 2 +- 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index e865cce85..15ab4c9ee 100644 --- a/NEWS +++ b/NEWS @@ -411,6 +411,21 @@ There is no such concept as a weak binding any more. ** Removed constants: bignum-radix, scm-line-incrementors +** define-method: New syntax mandatory. + +The new method syntax is now mandatory: + +(define-method (NAME ARG-SPEC ...) BODY ...) +(define-method (NAME ARG-SPEC ... . REST-ARG) BODY ...) + + ARG-SPEC ::= ARG-NAME | (ARG-NAME TYPE) + REST-ARG ::= ARG-NAME + +If you have old code using the old syntax, import +(oop goops old-define-method) before (oop goops) as in: + + (use-modules (oop goops old-define-method) (oop goops)) + * Changes to the gh_ interface * Changes to the scm_ interface diff --git a/doc/ChangeLog b/doc/ChangeLog index 324a86d6c..d638bfc2a 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -2,7 +2,7 @@ * goops.texi (VERSION): Bumped to version 0.3. - * goops-tutorial.texi, goops.texi: Updated to reflext new + * goops-tutorial.texi, goops.texi: Updated to reflect new define-method syntax. 2001-03-09 Neil Jerram From 97d0e20b2e19ac8e8b7310ce2a72a69f02ee6a60 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sat, 10 Mar 2001 10:30:16 +0000 Subject: [PATCH 0693/2047] * socket.c: add a definition of SUN_LEN (from glibc) for when it's not already defined. --- libguile/ChangeLog | 5 +++++ libguile/socket.c | 10 +++++++--- 2 files changed, 12 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 4552f73ee..18e0ac098 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-03-10 Gary Houston + + * socket.c: add a definition of SUN_LEN (from glibc) for when it's + not already defined. + 2001-03-09 Mikael Djurfeldt * coop.c: Inserted #include . diff --git a/libguile/socket.c b/libguile/socket.c index 52e0fff57..0f90e6416 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -69,6 +69,11 @@ #include #include +#if defined (HAVE_UNIX_DOMAIN_SOCKETS) && !defined (SUN_LEN) +#define SUN_LEN(ptr) ((size_t) (((struct sockaddr_un *) 0)->sun_path) \ + + strlen ((ptr)->sun_path)) +#endif + /* we are not currently using socklen_t. it's not defined on all systems, so would need to be checked by configure. in the meantime, plain int is the best alternative. */ @@ -810,9 +815,8 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0, else SCM_VALIDATE_ULONG_COPY (3, flags, flg); - /* recvfrom will not necessarily return an address. e.g., linux - 2.4.2 doesn't change addr or addr_size if socket is - AF_INET/SOCK_STREAM. */ + /* recvfrom will not necessarily return an address. usually nothing + is returned for stream sockets. */ addr->sa_family = AF_UNSPEC; SCM_SYSCALL (rv = recvfrom (fd, buf + offset, cend - offset, flg, From 451d273ac98c0b7f0e5e2c9e267ff14170babf23 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 10 Mar 2001 14:07:19 +0000 Subject: [PATCH 0694/2047] Make (ice-9 buffered-input) more general --- ice-9/ChangeLog | 9 +++++++ ice-9/buffered-input.scm | 52 +++++++++++++++++++++++++++------------- 2 files changed, 44 insertions(+), 17 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index d414850dc..0d43f134d 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,12 @@ +2001-03-10 Neil Jerram + + * buffered-input.scm (make-buffered-input-port): New, more general + buffered input procedure. Does not assume that a newline + character should be interpolated between chunks of input returned + by the reader proc. + (make-line-buffered-input-port): Redefine in terms of + make-buffered-input-port. + 2001-03-09 Keisuke Nishida * match.scm: Don't export defstruct. Use (unquote defstruct) instead. diff --git a/ice-9/buffered-input.scm b/ice-9/buffered-input.scm index df42cd533..c289a58a3 100644 --- a/ice-9/buffered-input.scm +++ b/ice-9/buffered-input.scm @@ -18,7 +18,8 @@ ;;;; Boston, MA 02111-1307 USA (define-module (ice-9 buffered-input) - #:export (make-line-buffered-input-port + #:export (make-buffered-input-port + make-line-buffered-input-port set-buffered-input-continuation?!)) ;; @code{buffered-input-continuation?} is a property of the ports @@ -29,20 +30,18 @@ (define (set-buffered-input-continuation?! port val) "Set the read continuation flag for @var{port} to @var{val}. -See @code{make-line-buffered-input-port} for the meaning and use of -this flag." +See @code{make-buffered-input-port} for the meaning and use of this +flag." (set! (buffered-input-continuation? port) val)) -(define (make-line-buffered-input-port reader) +(define (make-buffered-input-port reader) "Construct a line-buffered input port from the specified @var{reader}. @var{reader} should be a procedure of one argument that somehow reads -a line of input and returns it as a string @emph{without} the -terminating newline character. +a chunk of input and returns it as a string. -The port created by @code{make-line-buffered-input-port} automatically -adds a newline character after each string returned by @var{reader}; -this makes these ports useful for reading strings that extend across -more than one input line. +The port created by @code{make-buffered-input-port} does @emph{not} +interpolate any additional characters between the strings returned by +@var{reader}. @var{reader} should take a boolean @var{continuation?} argument. @var{continuation?} indicates whether @var{reader} is being called to @@ -54,12 +53,12 @@ use the @var{continuation?} argument to determine what prompt to display to the user. The new/continuation distinction is largely an application-level -concept, and @code{set-buffered-input-continuation?!} allows an -application some control over when a read operation is considered to -be new. But note that if there is data already buffered in the port -when a new read operation starts, this data will be read before the -first call to @var{reader}, and so @var{reader} will be called with -@var{continuation?} set to @code{#t}." +concept: @code{set-buffered-input-continuation?!} allows an +application to specify when a read operation is considered to be new. +But note that if there is non-whitespace data already buffered in the +port when a new read operation starts, this data will be read before +the first call to @var{reader}, and so @var{reader} will be called +with @var{continuation?} set to @code{#t}." (let ((read-string "") (string-index -1)) (letrec ((get-character @@ -69,7 +68,7 @@ first call to @var{reader}, and so @var{reader} will be called with read-string) ((>= string-index (string-length read-string)) (set! string-index -1) - #\nl) + (get-character)) ((= string-index -1) (set! read-string (reader (buffered-input-continuation? port))) (set! string-index 0) @@ -87,4 +86,23 @@ first call to @var{reader}, and so @var{reader} will be called with (set! (buffered-input-continuation? port) #f) port))) +(define (make-line-buffered-input-port reader) + "Construct a line-buffered input port from the specified @var{reader}. +@var{reader} should be a procedure of one argument that somehow reads +a line of input and returns it as a string @emph{without} the +terminating newline character. + +The port created by @code{make-line-buffered-input-port} automatically +interpolates a newline character after each string returned by +@var{reader}. + +@var{reader} should take a boolean @var{continuation?} argument. For +the meaning and use of this argument, see +@code{make-buffered-input-port}." + (make-buffered-input-port (lambda (continuation?) + (let ((str (reader continuation?))) + (if (eof-object? str) + str + (string-append str "\n")))))) + ;;; buffered-input.scm ends here From e6e2e95aa53f876e25bee2b0f867350c4a2ddf7a Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sat, 10 Mar 2001 16:56:09 +0000 Subject: [PATCH 0695/2047] * _scm.h: Removed #include . * error.c, net_db.c, putenv.c, stime.c: Removed declaration of errno variable (can be a macro on some systems, for example when using linux libc with threads). * error.c, filesys.c, gc.c, ioext.c, iselect.c, net_db.c, ports.c, posix.c, print.c, putenv.c, scmsigs.c, script.c, simpos.c, smob.c, socket.c, srcprop.c, stime.c, strop.c, unif.c, vports.c: Added #include in these 20 out of 100 files. --- libguile/ChangeLog | 13 +++++++++++++ libguile/_scm.h | 7 +------ libguile/error.c | 5 ++--- libguile/filesys.c | 4 +++- libguile/gc.c | 4 +++- libguile/ioext.c | 2 ++ libguile/iselect.c | 1 + libguile/net_db.c | 8 +++----- libguile/ports.c | 2 ++ libguile/posix.c | 4 +++- libguile/print.c | 4 +++- libguile/putenv.c | 5 +---- libguile/scmsigs.c | 4 +++- libguile/script.c | 4 +++- libguile/simpos.c | 4 +++- libguile/smob.c | 2 ++ libguile/socket.c | 4 +++- libguile/srcprop.c | 4 +++- libguile/stime.c | 6 +++--- libguile/strop.c | 4 +++- libguile/unif.c | 2 ++ libguile/vports.c | 4 +++- 22 files changed, 65 insertions(+), 32 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 18e0ac098..b4025606c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,16 @@ +2001-03-10 Mikael Djurfeldt + + * _scm.h: Removed #include . + + * error.c, net_db.c, putenv.c, stime.c: Removed declaration of + errno variable (can be a macro on some systems, for example when + using linux libc with threads). + + * error.c, filesys.c, gc.c, ioext.c, iselect.c, net_db.c, ports.c, + posix.c, print.c, putenv.c, scmsigs.c, script.c, simpos.c, smob.c, + socket.c, srcprop.c, stime.c, strop.c, unif.c, vports.c: Added + #include in these 20 out of 100 files. + 2001-03-10 Gary Houston * socket.c: add a definition of SUN_LEN (from glibc) for when it's diff --git a/libguile/_scm.h b/libguile/_scm.h index f87a303e7..3ffdc64c4 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -2,7 +2,7 @@ #ifndef _SCMH #define _SCMH -/* Copyright (C) 1995,1996, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996, 2000, 2001 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 @@ -76,11 +76,6 @@ #endif #include "libguile/snarf.h" /* Everyone snarfs. */ -/* On VMS, GNU C's errno.h contains a special hack to get link attributes - * for errno correct for linking to the C RTL. - */ -#include - /* SCM_SYSCALL retries system calls that have been interrupted (EINTR). However this can be avoided if the operating system can restart system calls automatically. We assume this is the case if diff --git a/libguile/error.c b/libguile/error.c index 56454c844..ee8ef2f10 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998, 2000, 2001 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 @@ -45,6 +45,7 @@ #include +#include #include "libguile/_scm.h" #include "libguile/pairs.h" @@ -67,8 +68,6 @@ */ -extern int errno; - /* All errors should pass through here. */ void scm_error (SCM key, const char *subr, const char *message, SCM args, SCM rest) diff --git a/libguile/filesys.c b/libguile/filesys.c index a2042c314..737695b3c 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -44,6 +44,8 @@ #include +#include + #include "libguile/_scm.h" #include "libguile/smob.h" #include "libguile/feature.h" diff --git a/libguile/gc.c b/libguile/gc.c index bf554aa05..c414c7552 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 96, 97, 98, 99, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -51,7 +51,9 @@ #include +#include #include + #include "libguile/_scm.h" #include "libguile/eval.h" #include "libguile/stime.h" diff --git a/libguile/ioext.c b/libguile/ioext.c index c3d976964..31f874c58 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -44,6 +44,8 @@ +#include + #include "libguile/_scm.h" #include "libguile/ioext.h" #include "libguile/fports.h" diff --git a/libguile/iselect.c b/libguile/iselect.c index 50ea3dc11..867863594 100644 --- a/libguile/iselect.c +++ b/libguile/iselect.c @@ -40,6 +40,7 @@ * If you do not wish that, delete this exception notice. */ #include +#include #include #include diff --git a/libguile/net_db.c b/libguile/net_db.c index ba9599671..a450c3c05 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -1,5 +1,5 @@ /* "net_db.c" network database support - * Copyright (C) 1995, 96, 97, 98, 99, 2000 Free Software Foundation, Inc. + * Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -51,6 +51,8 @@ */ +#include + #include "libguile/_scm.h" #include "libguile/feature.h" #include "libguile/strings.h" @@ -69,10 +71,6 @@ #include #include -#if !defined (HAVE_H_ERRNO) -extern int h_errno; -#endif - #ifndef STDC_HEADERS diff --git a/libguile/ports.c b/libguile/ports.c index 313dea63e..e8c739b30 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -46,6 +46,8 @@ /* Headers. */ #include +#include + #include "libguile/_scm.h" #include "libguile/eval.h" #include "libguile/objects.h" diff --git a/libguile/posix.c b/libguile/posix.c index c8f969ac6..efc3f4635 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 96, 97, 98, 99, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001 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 @@ -48,6 +48,8 @@ #define _GNU_SOURCE #include +#include + #include "libguile/_scm.h" #include "libguile/fports.h" #include "libguile/scmsigs.h" diff --git a/libguile/print.c b/libguile/print.c index 0d822c58b..0fdb24862 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995-1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995-1999, 2000, 2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -44,6 +44,8 @@ +#include + #include "libguile/_scm.h" #include "libguile/chars.h" #include "libguile/continuations.h" diff --git a/libguile/putenv.c b/libguile/putenv.c index 1c185502a..bc59233dd 100644 --- a/libguile/putenv.c +++ b/libguile/putenv.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1991, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1991, 2000, 2001 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 @@ -24,9 +24,6 @@ #include #include -#ifndef errno -extern int errno; -#endif /* Don't include stdlib.h for non-GNU C libraries because some of them contain conflicting prototypes for getopt. diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index baa597e31..ce5280146 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001 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 @@ -45,6 +45,8 @@ #include +#include + #include "libguile/_scm.h" #include "libguile/async.h" diff --git a/libguile/script.c b/libguile/script.c index 5e56c03b3..0db21e994 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000, 2001 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 * the Free Software Foundation; either version 2, or (at your option) @@ -45,7 +45,9 @@ gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include +#include #include + #include "libguile/_scm.h" #include "libguile/gh.h" #include "libguile/load.h" diff --git a/libguile/simpos.c b/libguile/simpos.c index db0c04beb..e847ce0d5 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998, 2000, 2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -44,6 +44,8 @@ +#include + #include "libguile/_scm.h" #include "libguile/scmsigs.h" diff --git a/libguile/smob.c b/libguile/smob.c index 87f721207..f7d00e910 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -45,6 +45,8 @@ #include +#include + #include "libguile/_scm.h" #include "libguile/objects.h" diff --git a/libguile/socket.c b/libguile/socket.c index 0f90e6416..784096484 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1996,1997,1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1996,1997,1998, 2000, 2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -44,6 +44,8 @@ +#include + #include "libguile/_scm.h" #include "libguile/unif.h" #include "libguile/feature.h" diff --git a/libguile/srcprop.c b/libguile/srcprop.c index 41cd36cc2..1b9aa2bbe 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 Free Software Foundation +/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001 Free Software Foundation * * 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 @@ -47,6 +47,8 @@ +#include + #include "libguile/_scm.h" #include "libguile/smob.h" #include "libguile/alist.h" diff --git a/libguile/stime.c b/libguile/stime.c index d797bf6c3..d723da8d0 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998, 1999, 2000, 2001 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 @@ -45,6 +45,8 @@ #include +#include + #include "libguile/_scm.h" #include "libguile/feature.h" #include "libguile/strings.h" @@ -128,8 +130,6 @@ timet mytime() # endif #endif -extern int errno; - #ifdef HAVE_FTIME struct timeb scm_your_base = {0}; #else diff --git a/libguile/strop.c b/libguile/strop.c index 01665dd97..3ff1726c8 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -1,6 +1,6 @@ /* classes: src_files */ -/* Copyright (C) 1994, 1996, 1997, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1994, 1996, 1997, 1999, 2000, 2001 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 @@ -23,6 +23,8 @@ Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +#include + #include "libguile/_scm.h" #include "libguile/chars.h" #include "libguile/strings.h" diff --git a/libguile/unif.c b/libguile/unif.c index 7e4e1a8bc..f45236078 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -52,7 +52,9 @@ #include +#include #include + #include "libguile/_scm.h" #include "libguile/chars.h" #include "libguile/eval.h" diff --git a/libguile/vports.c b/libguile/vports.c index cdb43598d..962759b23 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999, 2000, 2001 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 @@ -45,6 +45,8 @@ #include +#include + #include "libguile/_scm.h" #include "libguile/eval.h" #include "libguile/chars.h" From e0c08f17b19a4379f9ef4d2188ecaf6154e12759 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 11 Mar 2001 09:44:08 +0000 Subject: [PATCH 0696/2047] Use SCM_LISTn instead of scm_listify. --- libguile/ChangeLog | 6 ++++++ libguile/environments.c | 2 +- libguile/error.c | 9 ++++----- libguile/eval.c | 4 +--- libguile/filesys.c | 19 +++++++------------ libguile/hashtab.c | 6 +++--- libguile/load.c | 16 +++++++--------- libguile/net_db.c | 9 +++------ libguile/procprop.c | 6 ++---- libguile/read.c | 2 +- libguile/scmsigs.c | 2 +- libguile/socket.c | 2 +- libguile/struct.c | 4 +--- 13 files changed, 38 insertions(+), 49 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b4025606c..9aff894eb 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2001-03-11 Keisuke Nishida + + * environments.c, error.c, eval.c, filesys.c, hashtab.c, load.c, + net_db.c, procprop.c, read.c, scmsigs.c, socket.c, struct.c: + Use SCM_LISTn instead of scm_listify. + 2001-03-10 Mikael Djurfeldt * _scm.h: Removed #include . diff --git a/libguile/environments.c b/libguile/environments.c index 500943327..aa14c3e0f 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -816,7 +816,7 @@ update_catch_handler (void *ptr, SCM tag, SCM args) SCM observer = data->observer; SCM message = scm_makfrom0str ("Observer `~A' signals `~A' error: ~S"); - return scm_cons (message, scm_listify (observer, tag, args, SCM_UNDEFINED)); + return scm_cons (message, SCM_LIST3 (observer, tag, args)); } diff --git a/libguile/error.c b/libguile/error.c index ee8ef2f10..5d441df3f 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -81,11 +81,10 @@ scm_error (SCM key, const char *subr, const char *message, SCM args, SCM rest) message ? message : ""); abort (); } - arg_list = scm_listify (subr ? scm_makfrom0str (subr) : SCM_BOOL_F, - message ? scm_makfrom0str (message) : SCM_BOOL_F, - args, - rest, - SCM_UNDEFINED); + arg_list = SCM_LIST4 (subr ? scm_makfrom0str (subr) : SCM_BOOL_F, + message ? scm_makfrom0str (message) : SCM_BOOL_F, + args, + rest); scm_ithrow (key, arg_list, 1); /* No return, but just in case: */ diff --git a/libguile/eval.c b/libguile/eval.c index 4c58a54df..e48398466 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2475,9 +2475,7 @@ dispatch: proc = x; badfun: /* scm_everr (x, env,...) */ - scm_misc_error (NULL, - "Wrong type to apply: ~S", - scm_listify (proc, SCM_UNDEFINED)); + scm_misc_error (NULL, "Wrong type to apply: ~S", SCM_LIST1 (proc)); case scm_tc7_vector: case scm_tc7_wvect: #ifdef HAVE_ARRAYS diff --git a/libguile/filesys.c b/libguile/filesys.c index 737695b3c..e034f1fb2 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -545,9 +545,8 @@ SCM_DEFINE (scm_stat, "stat", 1, 0, 0, int en = errno; SCM_SYSERROR_MSG ("~A: ~S", - scm_listify (scm_makfrom0str (strerror (errno)), - object, - SCM_UNDEFINED), en); + SCM_LIST2 (scm_makfrom0str (strerror (errno)), object), + en); } return scm_stat2scm (&stat_temp); } @@ -1132,12 +1131,9 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0, if (rv < 0) SCM_SYSERROR; } - return scm_listify (retrieve_select_type (&read_set, read_ports_ready, - reads), - retrieve_select_type (&write_set, write_ports_ready, - writes), - retrieve_select_type (&except_set, SCM_EOL, excepts), - SCM_UNDEFINED); + return SCM_LIST3 (retrieve_select_type (&read_set, read_ports_ready, reads), + retrieve_select_type (&write_set, write_ports_ready, writes), + retrieve_select_type (&except_set, SCM_EOL, excepts)); } #undef FUNC_NAME #endif /* HAVE_SELECT */ @@ -1297,9 +1293,8 @@ SCM_DEFINE (scm_lstat, "lstat", 1, 0, 0, int en = errno; SCM_SYSERROR_MSG ("~A: ~S", - scm_listify (scm_makfrom0str (strerror (errno)), - str, - SCM_UNDEFINED), en); + SCM_LIST2 (scm_makfrom0str (strerror (errno)), str), + en); } return scm_stat2scm(&stat_temp); } diff --git a/libguile/hashtab.c b/libguile/hashtab.c index 23fba77fe..302b1761b 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -381,7 +381,7 @@ scm_ihashx (SCM obj,unsigned int n,struct scm_ihashx_closure * closure) SCM answer; SCM_DEFER_INTS; answer = scm_apply (closure->hash, - scm_listify (obj, scm_ulong2num ((unsigned long)n), SCM_UNDEFINED), + SCM_LIST2 (obj, scm_ulong2num ((unsigned long)n)), SCM_EOL); SCM_ALLOW_INTS; return SCM_INUM (answer); @@ -395,7 +395,7 @@ scm_sloppy_assx (SCM obj,SCM alist,struct scm_ihashx_closure * closure) SCM answer; SCM_DEFER_INTS; answer = scm_apply (closure->assoc, - scm_listify (obj, alist, SCM_UNDEFINED), + SCM_LIST2 (obj, alist), SCM_EOL); SCM_ALLOW_INTS; return answer; @@ -410,7 +410,7 @@ scm_delx_x (SCM obj,SCM alist,struct scm_ihashx_closure * closure) SCM answer; SCM_DEFER_INTS; answer = scm_apply (closure->delete, - scm_listify (obj, alist, SCM_UNDEFINED), + SCM_LIST2 (obj, alist), SCM_EOL); SCM_ALLOW_INTS; return answer; diff --git a/libguile/load.c b/libguile/load.c index 496f2b8a5..a3d28a95a 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -118,7 +118,7 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0, SCM_EOL); if (! SCM_FALSEP (hook)) - scm_apply (hook, scm_listify (filename, SCM_UNDEFINED), SCM_EOL); + scm_apply (hook, SCM_LIST1 (filename), SCM_EOL); { /* scope */ SCM port, save_port; @@ -243,10 +243,9 @@ scm_init_load_path () SCM path = SCM_EOL; #ifdef SCM_LIBRARY_DIR - path = scm_listify (scm_makfrom0str (SCM_SITE_DIR), - scm_makfrom0str (SCM_LIBRARY_DIR), - scm_makfrom0str (SCM_PKGDATA_DIR), - SCM_UNDEFINED); + path = SCM_LIST3 (scm_makfrom0str (SCM_SITE_DIR), + scm_makfrom0str (SCM_LIBRARY_DIR), + scm_makfrom0str (SCM_PKGDATA_DIR)); #endif /* SCM_LIBRARY_DIR */ path = scm_internal_parse_path (getenv ("GUILE_LOAD_PATH"), path); @@ -452,7 +451,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0, SCM_MISC_ERROR ((absolute ? "Unable to load file ~S" : "Unable to find file ~S in load path"), - scm_listify (filename, SCM_UNDEFINED)); + SCM_LIST1 (filename)); } return scm_primitive_load (full_filename); @@ -510,9 +509,8 @@ scm_init_load () scm_loc_load_path = SCM_CDRLOC (scm_sysintern ("%load-path", SCM_EOL)); scm_loc_load_extensions = SCM_CDRLOC (scm_sysintern ("%load-extensions", - scm_listify (scm_makfrom0str (".scm"), - scm_makfrom0str (""), - SCM_UNDEFINED))); + SCM_LIST2 (scm_makfrom0str (".scm"), + scm_makfrom0str ("")))); scm_loc_load_hook = SCM_CDRLOC (scm_sysintern ("%load-hook", SCM_BOOL_F)); init_build_info (); diff --git a/libguile/net_db.c b/libguile/net_db.c index a450c3c05..b2ed97818 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -358,8 +358,7 @@ SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0, entry = getnetbyaddr (netnum, AF_INET); } if (!entry) - SCM_SYSERROR_MSG ("no such network ~A", - scm_listify (net, SCM_UNDEFINED), errno); + SCM_SYSERROR_MSG ("no such network ~A", SCM_LIST1 (net), errno); ve[0] = scm_makfromstr (entry->n_name, (scm_sizet) strlen (entry->n_name), 0); ve[1] = scm_makfromstrs (-1, entry->n_aliases); ve[2] = SCM_MAKINUM (entry->n_addrtype + 0L); @@ -409,8 +408,7 @@ SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0, entry = getprotobynumber (protonum); } if (!entry) - SCM_SYSERROR_MSG ("no such protocol ~A", - scm_listify (protocol, SCM_UNDEFINED), errno); + SCM_SYSERROR_MSG ("no such protocol ~A", SCM_LIST1 (protocol), errno); ve[0] = scm_makfromstr (entry->p_name, (scm_sizet) strlen (entry->p_name), 0); ve[1] = scm_makfromstrs (-1, entry->p_aliases); ve[2] = SCM_MAKINUM (entry->p_proto + 0L); @@ -474,8 +472,7 @@ SCM_DEFINE (scm_getserv, "getserv", 0, 2, 0, entry = getservbyport (htons (SCM_INUM (name)), SCM_STRING_CHARS (protocol)); } if (!entry) - SCM_SYSERROR_MSG("no such service ~A", - scm_listify (name, SCM_UNDEFINED), errno); + SCM_SYSERROR_MSG("no such service ~A", SCM_LIST1 (name), errno); return scm_return_entry (entry); } #undef FUNC_NAME diff --git a/libguile/procprop.c b/libguile/procprop.c index 791dce74b..bcd80c25a 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -167,10 +167,8 @@ scm_stand_in_scm_proc(SCM proc) answer = scm_assoc (proc, scm_stand_in_procs); if (SCM_FALSEP (answer)) { - answer = scm_closure (scm_listify (SCM_EOL, SCM_BOOL_F, SCM_UNDEFINED), - SCM_EOL); - scm_stand_in_procs = scm_cons (scm_cons (proc, answer), - scm_stand_in_procs); + answer = scm_closure (SCM_LIST2 (SCM_EOL, SCM_BOOL_F), SCM_EOL); + scm_stand_in_procs = scm_acons (proc, answer, scm_stand_in_procs); } else answer = SCM_CDR (answer); diff --git a/libguile/read.c b/libguile/read.c index 473562a35..a3ad5daea 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -438,7 +438,7 @@ tryagain_no_flush_ws: } unkshrp: scm_misc_error (s_scm_read, "Unknown # object: ~S", - scm_listify (SCM_MAKE_CHAR (c), SCM_UNDEFINED)); + SCM_LIST1 (SCM_MAKE_CHAR (c))); } case '"': diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index ce5280146..9799dfc14 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -167,7 +167,7 @@ sys_deliver_signals (void) signal (i, take_signal); #endif scm_apply (SCM_VELTS (*signal_handlers)[i], - scm_listify (SCM_MAKINUM (i), SCM_UNDEFINED), + SCM_LIST1 (SCM_MAKINUM (i)), SCM_EOL); } } diff --git a/libguile/socket.c b/libguile/socket.c index 784096484..e923b1b18 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -605,7 +605,7 @@ scm_addr_vector (struct sockaddr *address, const char *proc) } else scm_misc_error (proc, "Unrecognised address family: ~A", - scm_listify (SCM_MAKINUM (fam), SCM_UNDEFINED)); + SCM_LIST1 (SCM_MAKINUM (fam))); return result; } diff --git a/libguile/struct.c b/libguile/struct.c index 3c15deb53..b57d1996f 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -534,9 +534,7 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, SCM_VALIDATE_INUM (2, tail_array_size); SCM_VALIDATE_REST_ARGUMENT (init); - fields = scm_string_append (scm_listify (required_vtable_fields, - user_fields, - SCM_UNDEFINED)); + fields = scm_string_append (SCM_LIST2 (required_vtable_fields, user_fields)); layout = scm_make_struct_layout (fields); basic_size = SCM_SYMBOL_LENGTH (layout) / 2; tail_elts = SCM_INUM (tail_array_size); From de41117ec79012bb902ae7b8e9f409bd91dfccf7 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 11 Mar 2001 19:59:10 +0000 Subject: [PATCH 0697/2047] New file. --- emacs/guile-c.el | 156 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 156 insertions(+) create mode 100644 emacs/guile-c.el diff --git a/emacs/guile-c.el b/emacs/guile-c.el new file mode 100644 index 000000000..bbf75e9a1 --- /dev/null +++ b/emacs/guile-c.el @@ -0,0 +1,156 @@ +;;; guile-c.el --- Guile C editing commands + +;; Copyright (C) 2001 Keisuke Nishida + +;; 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, 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 this program; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; (add-hook 'c-mode-hook +;; (lambda () +;; (require 'guile-c) +;; (define-key c-mode-map "\C-c\C-g\C-e" 'guile-c-edit-docstring) +;; (define-key c-mode-map "\C-c\C-g\C-p" 'guile-c-insert-define) +;; )) + +;;; Code: + +(require 'cc-mode) + +(defvar guile-c-prefix "scm_") + +;;; +;;; Insert templates +;;; + +(defun guile-c-insert-define () + "Insert a template of a Scheme procedure. + + M-x guile-c-insert-define RET foo arg , opt . rest => + + SCM_DEFINE (scm_foo, \"foo\", 1, 1, 1, + (SCM arg, SCM opt, SCM rest), + \"\") + #define FUNC_NAME s_scm_foo + { + + } + #undef FUNC_NAME" + (interactive) + (let ((tokens (split-string (read-string "Procedure: "))) + name args opts rest) + ;; Get procedure name + (if (not tokens) (error "No procedure name")) + (setq name (car tokens) tokens (cdr tokens)) + ;; Get requisite arguments + (while (and tokens (not (member (car tokens) '("," ".")))) + (setq args (cons (car tokens) args) tokens (cdr tokens))) + (setq args (nreverse args)) + ;; Get optional arguments + (when (string= (car tokens) ",") + (setq tokens (cdr tokens)) + (while (and tokens (not (string= (car tokens) "."))) + (setq opts (cons (car tokens) opts) tokens (cdr tokens))) + (setq opts (nreverse opts))) + ;; Get rest argument + (when (string= (car tokens) ".") + (setq rest (list (cadr tokens)))) + ;; Insert template + (let ((c-name (guile-c-name-from-scheme-name name))) + (insert (format "SCM_DEFINE (%s, \"%s\", %d, %d, %d,\n" + c-name name (length args) (length opts) (length rest)) + "\t (" + (mapconcat (lambda (a) (concat "SCM " a)) + (append args opts rest) ", ") + "),\n" + "\t \"\")\n" + "#define FUNC_NAME s_" c-name "\n" + "{\n\n}\n" + "#undef FUNC_NAME\n\n") + (previous-line 4) + (indent-for-tab-command)))) + +(defun guile-c-name-from-scheme-name (name) + (while (string-match "\\?$" name) (setq name (replace-match "_p" t t name))) + (while (string-match "!$" name) (setq name (replace-match "_x" t t name))) + (while (string-match "^%" name) (setq name (replace-match "sys_" t t name))) + (while (string-match "->" name) (setq name (replace-match "_to_" t t name))) + (while (string-match "[-:]" name) (setq name (replace-match "_" t t name))) + (concat guile-c-prefix name)) + +;;; +;;; Edit docstrings +;;; + +(defun guile-c-edit-docstring () + (interactive) + (let* ((region (guile-c-find-docstring)) + (doc (if region (buffer-substring (car region) (cdr region))))) + (if (not doc) + (error "No docstring!") + (with-current-buffer (get-buffer-create "*Guile Docstring*") + (erase-buffer) + (insert doc) + (goto-char (point-min)) + (while (not (eobp)) + (if (looking-at "[ \t]*\"") + (delete-region (match-beginning 0) (match-end 0))) + (end-of-line) + (if (eq (char-before (point)) ?\") + (delete-backward-char 1)) + (if (and (eq (char-before (point)) ?n) + (eq (char-before (1- (point))) ?\\)) + (delete-backward-char 2)) + (forward-line)) + (goto-char (point-min)) + (texinfo-mode) + (if global-font-lock-mode + (font-lock-fontify-buffer)) + (local-set-key "\C-c\C-c" 'guile-c-edit-finish) + (switch-to-buffer-other-window (current-buffer)) + (message "Type `C-c C-c' to finish"))))) + +(defun guile-c-edit-finish () + (interactive) + (goto-char (point-max)) + (while (eq (char-before) ?\n) (backward-delete-char 1)) + (goto-char (point-min)) + (if (eobp) + (insert "\"\"") + (while (not (eobp)) + (insert "\t \"") + (end-of-line) + (insert (if (eobp) "\"" "\\n\"")) + (forward-line 1))) + (let ((doc (buffer-string))) + (kill-buffer (current-buffer)) + (delete-window (selected-window)) + (let ((region (guile-c-find-docstring))) + (goto-char (car region)) + (delete-region (car region) (cdr region))) + (insert doc))) + +(defun guile-c-find-docstring () + (save-excursion + (if (re-search-backward "^SCM_DEFINE" nil t) + (let ((start (progn (forward-line 2) (point)))) + (while (looking-at "[ \t]*\"") + (forward-line 1)) + (cons start (- (point) 2)))))) + +(provide 'guile-c) + +;; guile-c.el ends here From 91c0d9a3e060cc5fc08c1a101698c3ca1d86839f Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 11 Mar 2001 19:59:42 +0000 Subject: [PATCH 0698/2047] * guile-c.el: New file. --- emacs/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/emacs/ChangeLog b/emacs/ChangeLog index dc8d75fad..1243b61f4 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,3 +1,7 @@ +2001-03-11 Keisuke Nishida + + * guile-c.el: New file. + 2000-05-28 Mikael Djurfeldt * ppexpand.el: New file. From e1a7b2cea71a34b75b34e1fd745a6a7409c4b5c9 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sun, 11 Mar 2001 23:31:58 +0000 Subject: [PATCH 0699/2047] * Added a new test case plus minor improvements. --- test-suite/ChangeLog | 5 +++++ test-suite/tests/syntax.test | 17 +++++++++++------ 2 files changed, 16 insertions(+), 6 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 92b08fbd1..f7a6d9076 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2001-03-12 Dirk Herrmann + + * tests/syntax.test: Added a test for let* bindings and + re-arranged and slightly improved the existing one. + 2001-03-09 Martin Grabmueller * tests/syntax.test ("let*"): Changed the `duplicate bindings' diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 7463d880b..53370c9dd 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -163,6 +163,16 @@ (with-test-prefix "let*" + (with-test-prefix "bindings" + + (pass-if "(let* ((x 1) (x 2)) ...)" + (let* ((x 1) (x 2)) + (= x 2))) + + (pass-if "(let* ((x 1) (x x)) ...)" + (let* ((x 1) (x x)) + (= x 1)))) + (with-test-prefix "bad body" (pass-if-exception "(let* ())" @@ -215,12 +225,7 @@ (pass-if-exception "(let* ((1 2)) 3)" exception:bad-var - (let* ((1 2)) 3))) - - (with-test-prefix "duplicate bindings" - - (pass-if "(let* ((x 1) (x 2)) x)" - (let* ((x 1) (x 2)) #t)))) + (let* ((1 2)) 3)))) (with-test-prefix "letrec" From e39c3de4797795d6d58066b2690880338715a028 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 11 Mar 2001 23:47:16 +0000 Subject: [PATCH 0700/2047] * list.c (s_scm_reverse_x): Use SCM_VALIDATE_LIST. --- libguile/ChangeLog | 2 ++ libguile/list.c | 4 ++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 9aff894eb..03179920e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,7 @@ 2001-03-11 Keisuke Nishida + * list.c (s_scm_reverse_x): Use SCM_VALIDATE_LIST. + * environments.c, error.c, eval.c, filesys.c, hashtab.c, load.c, net_db.c, procprop.c, read.c, scmsigs.c, socket.c, struct.c: Use SCM_LISTn instead of scm_listify. diff --git a/libguile/list.c b/libguile/list.c index 141d48a99..7655b53e3 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -329,11 +329,11 @@ SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0, "@code{reverse!}") #define FUNC_NAME s_scm_reverse_x { - SCM_ASSERT (scm_ilength (lst) >= 0, lst, SCM_ARG1, FUNC_NAME); + SCM_VALIDATE_LIST (1, lst); if (SCM_UNBNDP (new_tail)) new_tail = SCM_EOL; else - SCM_ASSERT (scm_ilength (new_tail) >= 0, new_tail, SCM_ARG2, FUNC_NAME); + SCM_VALIDATE_LIST (2, new_tail); while (SCM_NNULLP (lst)) { From a51fe2479ee73a147d750c34ddf9b6e7554e717c Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 11 Mar 2001 23:57:16 +0000 Subject: [PATCH 0701/2047] Split up. --- libguile/ChangeLog | 5556 +-------------------------------------- libguile/ChangeLog-2000 | 5555 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 5556 insertions(+), 5555 deletions(-) create mode 100644 libguile/ChangeLog-2000 diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 03179920e..7371eb5fa 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -921,5558 +921,4 @@ the number of write/flush calls. (write_all): new helper procedure. -2000-12-30 Michael Livshin - - * guardians.c (guardian_print): for sharing guardians, print that - they are sharing. - (scm_guard, scm_get_one_zombie): place the critical section - barriers more correctly. - - * weaks.c (scm_scan_weak_vectors): move the calculation of the - `weak_keys' and `weak_values' flags out of the inner loop. - -2000-12-29 Michael Livshin - - * guardians.c: (greedily_guarded_prop): deleted. - (greedily_guarded_whash): new variable. a doubly-weak hash table - used to keep the "greedily guarded" object property. the previous - implementation (via primitive object properties) was incorrect due - to its only-the-key-is-weak semantics. - (scm_guard, get_one_zombie, scm_init_guardians): use/init - `greedily_guarded_whash'. - -2000-12-28 Dirk Herrmann - - * eval.c (check_map_args), gh_data.c (gh_set_substr, - gh_scm2newstr, gh_get_substr, gh_symbol2newstr), print.c - (scm_iprin1): Use scm_remember_upto_here_1 instead of - scm_remember. - - * gc.[ch] (scm_remember_upto_here_1, scm_remember_upto_here_2, - scm_remember_upto_here): New functions. - - (scm_remember): Deprecated. - -2000-12-28 Dirk Herrmann - - * continuations.c (scm_make_continuation): Make variable cont - volatile to let the compiler know that it won't be clobbered by - longjmp. (It wouldn't be anyway, but for some reason the compiler - is not able to see that.) - -2000-12-28 Dirk Herrmann - - This patch re-introduces the unused member "properties" of - struct scm_subr_entry as requested by Mikael Djurfeldt. - - * procs.h (scm_subr_entry): Re-introduced member "properties". - - (SCM_SUBR_PROPS): Un-deprecated. - - * procs.c (scm_make_subr_opt, scm_mark_subr_table): Struct - scm_subr_entry has a member "properties" again. - -2000-12-28 Michael Livshin - - * guardians.c (mark_dependencies_in_tconc): new function. - (mark_dependencies): bug fix. mark the dependencies of the known - zombies, too. duh. - -2000-12-24 Michael Livshin - - * gc.c: (scm_gc_mark_dependencies): use SCM_EQ_P for SCMs, not - '=='. also, return after calling `scm_gc_mark'. - -2000-12-24 Michael Livshin - - * gc.c: (scm_gc_mark_dependencies): new function. like - `scm_gc_mark', but doesn't mark the argument itself. defined - using an arrangement similar to that in eval.c: `scm_gc_mark' and - `scm_gc_mark_dependencies' are derived from the same "template" - by ugly preprocessor magic. - - * gc.h: added prototype for `scm_gc_mark_dependencies'. - - * init.c (scm_init_guile_1): call the renamed - `scm_init_guardians'. - - * guardians.h: changed prototypes for `scm_make_guardian' and - `scm_init_guardians'. - - * guardians.c (guardian_t): added new fields `greedy_p' and - `listed_p'. - (GUARDIAN_P): predicate that says whether its argument is a - guardian. - (GUARDIAN_GREEDY_P, GUARDIAN_LISTED_P): new predicates. - (greedy_guardians, sharing_guardians): new variables. hold the - greedy and sharing live guardian lists, respectively. - (first_live_guardian, current_link_field): removed. - (greedily_guarded_prop): new variable. holds the "is greedily - guarded" object property. - (self_centered_zombies): new variable. stores guarded objects - that are parts of cycles. - (add_to_live_list): new function, introduced to decouple marking a - guardian and adding it to the live list. - (guardian_mark): call `add_to_live_list'. - (guardian_print): print whether the guardian is greedy or not. - also change "live" and "zombie" to "reachable" and "unreachable" - respectively, to be less confusing. - (scm_guard): if the guardian is greedy, test whether the object is - already greedily marked. throw an error if so. - (scm_get_one_zombie): if the guardian is greedy, remove the - "greedily guarded" property from the object. - (scm_make_guardian): add a new optional boolean argument which - says whether the guardian is greedy or sharing. - (guardian_gc_init): init the new live lists. - (mark_dependencies): new function. - (mark_and_zombify): new function. - (guardian_zombify): reworked to support the new guardian - semantics. move some logic to `mark_dependencies' and - `mark_and_zombify'. - (whine_about_self_centered_zombies): new function. installed in - the `after-gc-hook' to complain about guarded objects which are - parts of cycles. - (scm_init_guardians): init the new stuff. renamed from - `scm_init_guardian'. - -2000-12-23 Dirk Herrmann - - * procs.h (scm_subr_entry): Removed unused struct member - "properties". - - (SCM_SUBR_PROPS): Deprecated. - - * procs.c (scm_make_subr_opt, scm_mark_subr_table): Struct - scm_subr_entry does not have a member "properties" any more. - -2000-12-22 Dirk Herrmann - - * procs.h (scm_subr_entry): Removed unused struct member - "documentation". - - (SCM_SUBR_DOC): Deprecated. - - * procs.c (scm_make_subr_opt): Eliminate use of scm_intern0 in - favor of scm_str2symbol. Similarly, prefer scm_sysintern over - scm_sysintern0. - - (scm_make_subr_opt, scm_mark_subr_table): Struct scm_subr_entry - does not have a member "documentation" any more. - -2000-12-21 Dirk Herrmann - - * eval.c (restore_environment): Make sure that changes to the - current environment will take effect when re-entering the dynamic - scope. - -2000-12-21 Dirk Herrmann - - * goops.h (SCM_PUREGENERICP): Include the SCM_STRUCTP test. - - * goops.c (scm_sys_invalidate_method_cache_x, scm_m_atdispatch, - scm_pure_generic_p): The SCM_STRUCTP test is implied. - -2000-12-20 Gary Houston - - * continuations.c (continuation_apply): subtract the length of - continuation->dynenv, not the dynenv itself. I broke it last - time I changed this file. thanks to Bernard Urban. - -2000-12-16 Dirk Herrmann - - * goops.c (remove_duplicate_slots, maplist, - scm_sys_initialize_object, scm_sys_prep_layout_x, - scm_sys_inherit_magic_x, scm_instance_p, - scm_sys_set_object_setter_x, scm_sys_invalidate_method_cache_x, - scm_compute_applicable_methods, scm_m_atdispatch, - scm_pure_generic_p): Remove redundant SCM_N?IMP tests. - -2000-12-16 Keisuke Nishida - - * validate.h (SCM_WRONG_NUM_ARGS): New macro. - * goops.h: #include "libguile/validate.h" - (SCM_CLASSP, SCM_GENERICP, SCM_METHODP): Moved from goops.c with - prefix "SCM_". - (SCM_VALIDATE_INSTANCE, SCM_VALIDATE_ACCESSOR, SCM_VALIDATE_CLASS, - SCM_VALIDATE_GENERIC, SCM_VALIDATE_METHOD): New macros. - * goops.c (CLASSP, GENERICP, METHODP): Moved to goops.h with - prefix "SCM_". - (scm_sys_compute_slots, scm_sys_initialize_object, - scm_sys_prep_layout_x, s_sys_inherit_magic_x, scm_instance_p, - scm_class_name, scm_class_direct_supers, scm_class_direct_slots, - scm_class_direct_subclasses, scm_class_direct_methods, - scm_class_precedence_list, scm_class_slots, scm_class_environment, - scm_generic_function_name, scm_generic_function_methods, - scm_method_generic_function, scm_method_specializers, - scm_method_procedure, scm_accessor_method_slot_definition, - scm_make_unbound, scm_unbound_p, scm_assert_bound, - scm_at_assert_bound_ref, scm_sys_fast_slot_ref, - scm_sys_fast_slot_set_x, scm_slot_ref_using_class, - scm_slot_set_using_class_x, scm_slot_bound_using_class_p, - scm_slot_exists_using_class_p, scm_slot_ref, scm_slot_set_x, - scm_slot_bound_p, scm_slots_exists_p, scm_sys_allocate_instance, - scm_sys_set_object_setter_x, scm_sys_modify_instance, - scm_sys_modify_class, scm_sys_invalidate_class, - scm_sys_invalidate_method_cache_x, scm_generic_capability_p, - scm_enable_primitive_generic_x, scm_primitive_generic_generic, - scm_make, scm_find_method, scm_sys_method_more_specific_p, - scm_pure_generic_p, scm_sys_goops_loaded): Replaced SCM_PROC by - SCM_DEFINE. Use validate macros defined above. - (scm_assert_bound, scm_at_assert_bound_ref, scm_sys_goops_loaded): - Declared as static functions. - (s_class_of, scm_class_of): Replaced SCM_PROC by SCM_DEFINE - in object.c. - * object.c (scm_class_of): Use SCM_DEFINE. - -2000-12-16 Keisuke Nishida - - * symbols.h (scm_symbols_prehistory): Added prototype. - -2000-12-16 Dirk Herrmann - - * environments.[ch] (scm_system_environment): New variable, will - replace scm_symhash soon. We may decide for a better name and - also to split this up into a set of environments later. - - (scm_environments_prehistory): Initialize scm_system_environment. - - * init.c (scm_init_guile_1): scm_environments_prehistory requires - storage to be initialized. - -2000-12-15 Dirk Herrmann - - * eval.c (change_environment, inner_eval, restore_environment): - New functions. - - (scm_eval): Bring the global variable that holds the current - environment up to date when entering or leaving the scope of the - evaluated code. Thanks to Matthias Koeppe for the bug report. - -2000-12-13 Dirk Herrmann - - * numbers.c (scm_init_numbers): Re-introduced bindings for - most-positive-fixnum and most-negative-fixnum as requested by - Mikael Djurfeldt. - -2000-12-12 Dirk Herrmann - - The variable scm_symbols is made static within symbols.c and - renamed to symbols. The initialization of the symbols hash table - is done in function scm_symbols_prehistory. - - * gc.c (scm_init_storage): Don't initialize scm_symbols. Don't - define most-positive-fixnum, most-negative-fixnum and - bignum-radix. - - * init.c (scm_init_guile_1): Call scm_symbols_prehistory. - - * root.h (scm_symbols): Not in scm_sys_protects any more. - - * symbols.c (symbols): Renamed from scm_symbols and made static. - - (scm_mem2symbol): scm_symbols is renamed to symbols. - - * symbols.[ch] (scm_symbols_prehistory): Added. - -2000-12-12 Dirk Herrmann - - * gc.c (scm_init_storage), root.h (scm_weak_symhash, scm_symbols): - Removed the former scm_weak_symhash hash table. Added scm_symbols - hash table. - - * stacks.c (get_applybody): scm_sym2vcell may return #f. - - * symbols.c (scm_mem2symbol): This function is now responsible - for creating symbol objects and storing them in the global - scm_symbols hash table. - - (scm_str2symbol): Rewritten in terms of scm_mem2symbol. - - (scm_sym2vcell): For system bindings, there is now only one - obarray - scm_symhash. If scm_sym2vcell is called to look up a - symbol that can't be found and shall not be created, #f is - returned. Most callers of scm_sym2vcell have expected this - behaviour anyway. - - (scm_intern_obarray_soft): Removed reference to scm_weak_symhash - from comment. - - (scm_intern_obarray_soft, scm_sysintern0_no_module_lookup): These - functions are not responsible for symbol creation any more, only - for creation of bindings. - - (scm_symbol_value0): Don't use scm_intern_obarray_soft to create - a symbol object. - - (scm_symbol_interned_p): scm_weak_symhash is removed. - - * symbols.[ch] (scm_builtin_weak_bindings): Removed. There are - no weak bindings any more. - -2000-12-12 Dirk Herrmann - - * hooks.c (scm_create_hook), script.c - (scm_compile_shell_switches), snarf.h (SCM_VCELL, - SCM_GLOBAL_VCELL, SCM_VCELL_INIT, SCM_GLOBAL_VCELL_INIT): Create - a binding in one go (instead of first creating a vcell and then - setting its cdr). - -2000-12-12 Dirk Herrmann - - * hash.[ch] (scm_string_hash), symbols.[ch] (scm_string_hash): - Moved function scm_string_hash to hash.c. - -2000-12-11 Marius Vollmer - - * gc_os_dep.c (scm_get_stack_base) [MSWIN32]: Added detection of - page size on the w32 architecture. Updated from Boehms gc5.2. - Thanks to Lars J. Aas! - -2000-12-11 Dirk Herrmann - - * debug.c (scm_sym_procname, scm_sym_dots, scm_sym_source, - scm_init_debug), eval.c (scm_sym_dot, scm_sym_arrow, scm_sym_else, - scm_sym_unquote, scm_sym_uq_splicing, scm_sym_enter_frame, - scm_sym_apply_frame, scm_sym_exit_frame, scm_sym_trace, - scm_init_eval), gsubr.c (scm_sym_name, scm_init_gsubr), srcprop.c - (scm_sym_filename, scm_sym_copy, scm_sym_line, scm_sym_column, - scm_sym_breakpoint), variable.c (anonymous_variable_sym): - Initialize symbols by using SCM_(GLOBAL_)?SYMBOL. - - * gc.c (scm_i_getenv_int): Moved here from init.c. - - * gc.[ch] (scm_init_storage): Read gc configuration environment - variables here, not in init.c. - - * init.c (scm_i_getenv_int): Moved to gc.c. - - (scm_init_guile_1): Move configuration code to scm_init_storage. - Make sure procprops get initialized early. - - * keywords.c (scm_c_make_keyword): Report amount of memory freed - by scm_must_free. Use scm_str2symbol instead of scm_sysintern0. - - * options.c (scm_init_opts): Use scm_str2symbol instead of - scm_sysintern0. - -2000-12-10 Mikael Djurfeldt - - * threads.h (SCM_MUTEXP): Typo: removed extra parenthesis. - -2000-12-08 Keisuke Nishida - - * tags.h (SCM_TYP16_PREDICATE): New macro. - * arbiters.c (scm_tc16_arbiter): Typed as scm_bits_t. - (arbiter_print): Renamed from prinarb. - (scm_init_arbiters): Don't use scm_make_smob_type_mfpe. - * async.c (tc16_async): Typed as scm_bits_t. - (SCM_ASYNCP): Use SCM_TYP16_PREDICATE. - (async_mark): Renamed from mark_async. - (scm_init_async): Updated. - * continuations.h (SCM_CONTINUATIONP): Use SCM_TYP16_PREDICATE. - * debug.c (scm_tc16_memoized, scm_tc16_debugobj): Typed as scm_bits_t. - (memoized_print): Renamed from prinmemoized. - (debugobj_print): Renamed from prindebugobj. - (scm_init_debug): Don't use scm_make_smob_type_mfpe. - * debug.h (scm_tc16_memoized, scm_tc16_debugobj): Typed as scm_bits_t. - (SCM_DEBUGOBJP, SCM_MEMOIZEDP): Use SCM_TYP16_PREDICATE. - * dynl.c (scm_tc16_dynamic_obj): Typed as scm_bits_t. - (dynl_obj_mark): Renamed from mark_dynl_obj. - (dynl_obj_print): Renamed from print_dynl_obj. - (scm_dynamic_object_p): Use SCM_TYP16_PREDICATE. - (scm_init_dynamic_linking): Updated. - * dynwind.c (SCM_GUARDSP): Use SCM_TYP16_PREDICATE. - (tc16_guards): Typed as scm_bits_t. - (guards_print): Renamed from printguards. - (scm_init_dynwind): Don't use scm_make_smob_type_mfpe. - * environments.c (scm_tc16_environment, scm_tc16_observer): - Typed as scm_bits_t. - (environment_mark, environment_free, environment_print, - observer_mark, observer_print, leaf_environment_mark, - leaf_environment_free, leaf_environment_print, - eval_environment_mark, eval_environment_free, - eval_environment_print, import_environment_mark, - import_environment_free, import_environment_print, - export_environment_mark, export_environment_free, - export_environment_print): Renamed from mark_environment, - free_environment, print_environment, mark_observer, - print_observer, mark_leaf_environment, free_leaf_environment, - print_leaf_environment, mark_eval_environment, - free_eval_environment, print_eval_environment, - mark_import_environment, free_import_environment, - print_import_environment, mark_export_environment, - free_export_environment, and print_export_environment, respectively. - (free_observer): Removed. - (leaf_environment_funcs, eval_environment_funcs, - import_environment_funcs, export_environment_funcs, - scm_environments_prehistory): Updated. - * environments.h (scm_tc16_environment, scm_tc16_observer): - Typed as scm_bits_t. - * eval.c (scm_tc16_promise): Typed as scm_bits_t. - (promise_print): Renamed from prinprom. - (scm_promise_p): Use SCM_TYP16_PREDICATE. - (scm_init_eval): Updated. - * eval.h (scm_tc16_promise): Typed as scm_bits_t. - * filesys.c (scm_tc16_dir): Typed as scm_bits_t. - (scm_init_filesys): Don't use scm_make_smob_type_mfpe. - * filesys.h (scm_tc16_dir): Typed as scm_bits_t. - * fluids.c (scm_tc16_fluid): Typed as scm_bits_t. - (fluid_print): Renamed from print_fluid. - (scm_init_fluids): Don't use scm_make_smob_type_mfpe. - * fluids.h (scm_tc16_fluid): Typed as scm_bits_t. - * fports.c (fport_print): Renamed from prinfport. - (scm_make_fptob): Updated. - * guardians.c (tc16_guardian): Typed as scm_bits_t. - * hooks.c (scm_tc16_hook): Typed as scm_bits_t. - (hook_print): Renamed from print_hook. - (scm_init_hooks): Updated. - * hooks.h (scm_tc16_hook): Typed as scm_bits_t. - (SCM_HOOKP): Use SCM_TYP16_PREDICATE. - * keywords.c (scm_tc16_keyword): Typed as scm_bits_t. - (keyword_print): Renamed from prin_keyword. - (scm_init_keywords): Don't use scm_make_smob_type_mfpe. - * keywords.h (scm_tc16_keyword): Typed as scm_bits_t. - * macros.c (scm_tc16_macro): Typed as scm_bits_t. - (scm_macro_p, scm_macro_type): Use SCM_TYP16_PREDICATE. - (scm_init_macros): Don't use scm_make_smob_type_mfpe. - * macros.h (scm_tc16_macro): Typed as scm_bits_t. - * mallocs.c (scm_tc16_malloc): Typed as scm_bits_t. - (malloc_free): Renamed from fmalloc. - (malloc_print): Renamed from prinmalloc. - (scm_init_mallocs): Don't use scm_make_smob_type_mfpe. - * mallocs.h (scm_tc16_malloc): Typed as scm_bits_t. - * modules.h (SCM_EVAL_CLOSURE_P): Use SCM_TYP16_PREDICATE. - (scm_tc16_eval_closure): Renamed from scm_eval_closure_tag. - (scm_standard_eval_closure, scm_init_modules): Updated. - * ports.c (scm_tc16_void_port): Typed as scm_bits_t. - * print.c (scm_tc16_port_with_ps): Typed as scm_bits_t. - (port_with_ps_print): Renamed from print_port_with_ps. - (scm_init_print): Updated. - * print.h (scm_tc16_port_with_ps): Typed as scm_bits_t. - (SCM_PORT_WITH_PS_P): Use SCM_TYP16_PREDICATE. - * random.c (scm_tc16_rstate): Typed as scm_bits_t. - (rstate_free): Renamed from free_rstate. - (scm_init_random): Don't use scm_make_smob_type_mfpe. - * random.h (scm_tc16_rstate): Typed as scm_bits_t. - (SCM_RSTATEP): Use SCM_TYP16_PREDICATE. - * regex-posix.c (scm_tc16_regex): Typed as scm_bits_t. - (regex_free): Renamed from free_regex. - (scm_init_regex_posix): Don't use scm_make_smob_type_mfpe. - * regex-posix.h (scm_tc16_regex): Typed as scm_bits_t. - * root.c (scm_tc16_root): Typed as scm_bits_t. - (root_mark): Renamed from mark_root. - (root_print): Renamed from print_root. - (scm_init_root): Updated. - * root.h (scm_tc16_root): Typed as scm_bits_t. - (SCM_ROOTP): Use SCM_TYP16_PREDICATE. - * smob.c (free_print): Renamed from freeprint. - (scm_smob_prehistory): Don't use scm_make_smob_type_mfpe. - * smob.h (SCM_SMOB_PREDICATE): Use SCM_TYP16_PREDICATE. - * srcprop.c (scm_tc16_srcprops): Typed as scm_bits_t. - (srcprops_mark): Renamed from marksrcprops. - (srcprops_free): Renamed from freesrcprops. - (srcprops_print): Renamed from prinsrcprops. - (scm_init_srcprop): Don't use scm_make_smob_type_mfpe. - * srcprop.h (scm_tc16_srcprops): Typed as scm_bits_t. - (SRCPROPSP): Use SCM_TYP16_PREDICATE. - * threads.c (scm_tc16_thread, scm_tc16_mutex, scm_tc16_condvar): - Typed as scm_bits_t. - * threads.h (scm_tc16_thread, scm_tc16_mutex, scm_tc16_condvar): - Typed as scm_bits_t. - (SCM_THREADP, SCM_MUTEXP, SCM_CONDVARP): Use SCM_TYP16_PREDICATE. - * throw.c (tc16_jmpbuffer): Renamed from scm_tc16_jmpbuffer. - (make_jmpbuf): Updated. - (tc16_lazy_catch): Typed as scm_bits_t. - (SCM_JMPBUFP, SCM_LAZY_CATCH_P): Use SCM_TYP16_PREDICATE. - (jmpbuffer_print): Renamed from printjb. - (lazy_catch_print): Renamed from print_lazy_catch. - (scm_init_throw): Don't use scm_make_smob_type_mfpe. - * unif.c (scm_tc16_array): Typed as scm_bits_t. - (array_mark): Renamed from markra. - (array_free): Renamed from freera. - (scm_init_unif): Don't use scm_make_smob_type_mfpe. - * unif.h (scm_tc16_array): Typed as scm_bits_t. - (SCM_ARRAYP): Use SCM_TYP16_PREDICATE. - * validate.h (SCM_VALIDATE_SMOB): Use SCM_TYP16_PREDICATE. - * variable.c (scm_tc16_variable): Typed as scm_bits_t. - (variable_print): Renamed from prin_var. - (variable_equalp): Renamed from var_equal. - (scm_markvar): Removed. - (scm_init_variable): Don't use scm_make_smob_type_mfpe. - * variable.h (scm_tc16_variable): Typed as scm_bits_t. - -2000-12-08 Dirk Herrmann - - * feature.c (scm_add_feature), gh_data.c (gh_symbol2scm), goops.c - (scm_sys_prep_layout_x, scm_make_class, scm_add_slot, - scm_init_goops), load.c (init_build_info), print.c - (scm_init_print), read.c (scm_lreadr), snarf.h (SCM_SYMBOL, - SCM_GLOBAL_SYMBOL), stacks.c (scm_init_stacks), struct.c - (scm_make_struct_layout), symbols.c (scm_sysintern0, - scm_string_to_symbol, scm_gensym), throw.c - (scm_handle_by_message): Use scm_mem2symbol or scm_str2symbol - instead of scm_intern_* to create a symbol object. - - * goops.c (Intern): Removed. - - (CALL_GF1, CALL_GF2, CALL_GF3, CALL_GF4, build_class_class_slots, - create_basic_classes, scm_class_name, scm_class_direct_supers, - scm_class_direct_slots, scm_class_direct_subclasses, - scm_class_direct_methods, scm_class_precedence_list, - scm_class_slots, scm_class_environment, - scm_generic_function_methods, scm_method_generic_function, - scm_method_specializers, scm_method_procedure, - scm_accessor_method_slot_definition, purgatory, scm_make, - make_stdcls, create_standard_classes, make_class_from_template, - scm_make_class): Replaced calls to Intern with calls to - scm_str2symbol. - - * ramap.c (init_raprocs): Use scm_symbol_binding instead of - scm_intern. - - * symbols.c (scm_sym2vcell): Add a bogus return to avoid compiler - warnings. - - * unif.c (scm_array_prototype): Fix prototype return value for - svects and llvects. - -2000-12-08 Dirk Herrmann - - * symbols.[ch] (scm_mem2symbol, scm_str2symbol): New functions. - These shall replace all those calls to scm_intern... which are - only required to create a scheme symbol from a C string or a field - of chars. - -2000-12-08 Dirk Herrmann - - * environments.c (DEFAULT_OBARRAY_SIZE), gc.c - (DEFAULT_SYMHASH_SIZE): Added to locally determine arbitrary - default values for obarrays, thus removing the dependency from - scm_symhash_dim. - - * environments.c (scm_make_leaf_environment, - scm_make_eval_environment), gc.c (scm_init_storage): Don't use - scm_symhash_dim. - - * symbols.c (NUM_HASH_BUCKETS), symbols.[ch] (scm_symhash_dim): - Removed. - - * symbols.c (scm_sym2vcell, scm_sysintern0_no_module_lookup): - Eliminate a redundant SCM_IMP test. - - (scm_sym2vcell, scm_sysintern0_no_module_lookup): - Don't assume a fixed obarray size any more. - -2000-12-07 Dirk Herrmann - - * gc.c (scm_init_gc): gc_async is already protected from gc, - namely via scm_asyncs. Thanks to Keisuke Nishida for pointing - this out. - -2000-12-07 Keisuke Nishida - - * smob.h (scm_smob_apply_0, scm_smob_apply_1, scm_smob_apply_2, - scm_smob_apply_3): Removed declarations. - (scm_set_smob_apply): Takes unsigned integers. - (scm_make_smob_type_mfpe, scm_set_smob_mfpe): Deprecated. - * smob.c (scm_smob_apply_0_000, scm_smob_apply_1_010, - scm_smob_apply_2_020): Removed. - (scm_set_smob_apply): Takes unsigned integers + some optimization. - (Thanks to Dirk Herrmann) - (scm_make_smob_type_mfpe, scm_set_smob_mfpe): Deprecated. - -2000-12-07 Keisuke Nishida - - * smob.h (SCM_SMOB_APPLICABLE_P, SCM_SMOB_APPLY_0, - SCM_SMOB_APPLY_1, SCM_SMOB_APPLY_2, SCM_SMOB_APPLY_3): New macros. - * eval.c (SCM_CEVAL, SCM_APPLY): Use macros above. - * procprop.c (scm_i_procedure_arity): Ditto. - * smob.c (scm_make_smob_type): Initialize gsubr_type. - -2000-12-06 Keisuke Nishida - - * smob.h (scm_smob_descriptor): New fields `apply_0', `apply_1', - `apply_2', and `apply_3'. - * smob.c (scm_make_smob_type): Init new fields. - (SCM_SMOB_APPLY0, SCM_SMOB_APPLY1, SCM_SMOB_APPLY2, SCM_SMOB_APPLY3): - New macros. - (scm_smob_apply_0_000, scm_smob_apply_0_010, scm_smob_apply_0_020, - scm_smob_apply_0_030, scm_smob_apply_0_001, scm_smob_apply_0_011, - scm_smob_apply_0_021, scm_smob_apply_0_error, - scm_smob_apply_1_010, scm_smob_apply_1_020, scm_smob_apply_1_030, - scm_smob_apply_1_001, scm_smob_apply_1_011, scm_smob_apply_1_021, - scm_smob_apply_1_error, - scm_smob_apply_2_020, scm_smob_apply_2_030, scm_smob_apply_2_001, - scm_smob_apply_2_011, scm_smob_apply_2_021, scm_smob_apply_2_error, - scm_smob_apply_3_030, scm_smob_apply_3_001, scm_smob_apply_3_011, - scm_smob_apply_3_021, scm_smob_apply_3_error): New functions. - (scm_set_smob_apply): Set new fields to the above functions. - (scm_smob_apply_0, scm_smob_apply_1, scm_smob_apply_2, - scm_smob_apply_3): Removed. - * eval.c (SCM_CEVAL, SCM_APPLY): Rewrote smob calls. - -2000-12-06 Dirk Herrmann - - * gc.c (scm_init_gc): gc_async must be protected from gc. I - wonder why we never ran into problems up to now... - -2000-12-06 Dirk Herrmann - - * gc.c (scm_init_gc): Don't create a binding for %gc-thunk. - -2000-12-06 Dirk Herrmann - - * gsubr.c: No need to include vector.h. - - (scm_gsubr_apply): Use SCM_GSUBR_MAX instead of hard-coded value. - Added FUNC_NAME wrapping. Improved (temporarily?) disabled - debugging code. Replaced SCM_IMP with SCM_NULLP. Eliminated call - to ASRTGO. - - (scm_init_gsubr): Eliminated outdated comment. - -2000-12-06 Dirk Herrmann - - * async.c (SCM_ASYNCP): Use SCM_TYP16 instead of SCM_GCTYP16. - - * eval.c (scm_m_vref, scm_m_vset, scm_m_define, SCM_CEVAL, - SCM_APPLY, scm_copy_tree): Remove commented code. - - (SCM_CEVAL, SCM_APPLY): Remove #ifdef CCLO conditionals. Without - CCLO being defined, guile would not compile at all anyway. - - * gc.h (SCM_GC8MARKP, SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, - SCM_GCCDR): Deprecated. - - * gdbint.c (unmark_port, remark_port, gdb_read), procs.c - (scm_mark_subr_table): Use SCM_(SET|CLR)?GCMARK(P)? instead of - SCM_(SET|CLR)?GC8MARK(P)?. - - * gh_data.c (gh_scm2char): Remove bogus ';'. - - * tags.h: Removed comment about GCTYP16 macro. - - * weaks.c (scm_mark_weak_vector_spines): Use SCM_CDR instead of - SCM_GCCDR. - -2000-12-05 Dirk Herrmann - - * print.c (scm_iprin1): Use scm_tc3_* codes instead of hardcoded - values. Added comment about tc3 codes that may appear in - immediates. Got rid of one goto command. - -2000-12-05 Dirk Herrmann - - * dynl.c (sysdep_dynl_link): Improved error reporting. - - * guardians.c: Changed the representation from a compiled closure - to an applicable smob. - - (guard1, CCLO_G): Removed. - - (guard, g_mark, g_print, scm_tc16_guardian, scm_guardian_gc_init, - scm_guardian_zombify): Renamed to guardian_apply, guardian_mark, - guardian_print, tc16_guardian, guardian_gc_init and - guardian_zombify, respectively. - - (guardian_free): Added, fixes a memory leak. - - (guardian_print): Don't use sprintf hack. - - (guardian_apply, scm_guard, scm_get_one_zombie, - scm_make_guardian): Don't use a compiled closure. - - (guardian_zombify): Prefer !SCM_NULLP over SCM_NIMP. No need to - use SCM_GCCDR any more. Simplified loop condition. - - (scm_init_guardian): Don't use scm_make_smob_type_mfpe for smob - initialization. Initialize applicable smob. - -2000-12-04 Dirk Herrmann - - * chars.c (scm_char_eq_p): Minor cleanup/optimization. - - * gc.c (scm_gc_mark): Don't use SCM_VELTS for CCLOs. - - * procprop.c (scm_i_procedure_arity): Separate handling of smobs - and CCLOs. - -2000-12-04 Dirk Herrmann - - * tags.h (scm_tc_free_cell, scm_tc16_big, scm_tc16_real, - scm_tc16_complex): Eliminate hard-coded value of scm_tc7_smob. - -2000-12-01 Dirk Herrmann - - * list.[ch] (scm_c_memq): Added as a fast C level alternative for - scm_memq for the case that the list parameter is known to be a - proper list. - - * goops.c (filter_cpl, remove_duplicate_slots, applicablep), - goops.h (SCM_SUBCLASSP): Use scm_c_memq if we are sure that we - pass proper lists. - -2000-12-01 Dirk Herrmann - - * goops.c (scm_sys_compute_slots, scm_i_get_keyword, - scm_get_keyword, scm_slot_ref_using_class, - scm_slot_set_using_class_x): Update the code to match guile's - current style (e. g. using SCM_DEFINE, adding comments, removing - unnecessary SCM_NIMP tests etc.). - -2000-11-30 Dirk Herrmann - - Thanks to Julian Satchell for the bug report: - - * coop-threads.c (scm_join_thread): Check whether a thread is - finished before trying to join it. - - * coop.c (coop_aborthelp, coop_join): When a thread finishes, its - stack base is not set to NULL any more. - -2000-11-28 Dirk Herrmann - - * strop.c (scm_i_index): Removed outdated comment. - -2000-11-28 Dirk Herrmann - - * struct.c (scm_struct_ref, scm_struct_set_x), symbols.c - (scm_intern_obarray_soft), symbols.h (SCM_ROUCHARS): Eliminate - use of SCM_SYMBOL_UCHARS by using chars instead of unsigned - chars. - - (SCM_SYMBOL_UCHARS): Removed. - -2000-11-26 Gary Houston - - * reimplementation of values, call-with-values as primitives: - - * values.c, values.h: new files. use a struct to contain multiple - values, similar to the previous Scheme-level implementation. - * Makefile.am: add values.c, values.h, values.x. - * continuations.c (continuation_apply): support R5RS multiple value - continuations. - * init.c: call scm_init_values. - * struct.h: define SCM_SET_STRUCT_PRINTER. - -2000-11-25 Gary Houston - - * use an applicable SMOB to represent continuations, instead of a - custom tc7 type. This will make it easier to support R5RS - multiple value continuations, without the use of a Scheme-level - wrapper. - - * continuations.c (scm_tc16_continuation, continuation_mark, - continuation_free, continuation_print, continuation_apply): - new SMOB support. - (scm_make_continuation): new procedure, replaces scm_make_cont - with a different interface. - (copy_stack_and_call, scm_dynthrow, scm_init_continuations): rewritten. - (CHEAP_CONTINUATIONS): removed non-working code completely. - (scm_call_continuation): removed. - * continuations.h (struct scm_contregs): add num_stack_items and - stack fields. previously stack was stored following this struct: - use a tail array instead. - (SCM_CONTINUATIONP): new macro. - (SCM_CONTINUATION_LENGTH, SCM_SET_CONTINUATION_LENGTH): - rewritten. - (SCM_SET_CONTREGS): removed. - * tags.h: removed scm_tc7_contin (was tag 61). - * debug.c, gc.c, hash.c, print.c, procprop.c, procs.c: - removed scm_tc7_contin support. - * eval.c: use scm_make_continuation instead of scm_make_cont. - don't set jump buffers here. remove scm_tc7_contin support. - * init.c, root.c: create SMOB continuation for rootcont instead - of scm_tc7_contin. call scm_init_continuations before - scm_init_root. - * root.c: remove support for static jmpbuf. It's not used by - default and I broke it. create SMOB continuation for rootcont. - * stacks.c: use SCM_CONTINUATIONP. - -2000-11-24 Matthias Koeppe - - * goops.c (filter_cpl, remove_duplicate_slots), goops.h - (SCM_SUBCLASSP): Fix previous change: In contrast to - scm_sloppy_memq the function scm_memq returns #f if the - object was not contained in the list. - -2000-11-24 Dirk Herrmann - - * goops.c: Include validate.h. - - (DEFVAR, scm_add_method): Don't use deprecated scm_eval2. - - (scm_sys_fast_slot_ref, scm_sys_fast_slot_set_x, - scm_m_atdispatch): Provide FUNC_NAME definition. Don't use - deprecated SCM_OUTOFRANGE macro. - - (scm_sloppy_num2ulong, scm_sys_logand): Removed. Guile's logand - function now provides the desired behaviour. - - * goops.c (filter_cpl, remove_duplicate_slots), goops.h - (SCM_SUBCLASSP): Don't use deprecated scm_sloppy_memq. - -2000-11-23 Dirk Herrmann - - * symbols.h (SCM_LENGTH_MAX): Deprecated. - - * unif.c (scm_make_uve): Use SCM_BITVECTOR_MAX_LENGTH and - SCM_UVECTOR_MAX_LENGTH instead of SCM_LENGTH_MAX. Postpone length - checks for strings and vectors to their constructors. Eliminate - redundant SCM_IMP test. - - (scm_dimensions_to_uniform_array): Postpone length checks to - scm_make_uve. - - * unif.h (SCM_BITVECTOR_MAX_LENGTH, SCM_UVECTOR_MAX_LENGTH): - Added. - -2000-11-23 Dirk Herrmann - - * gh_data.c (makvect), numbers.c (scm_mkbig, scm_adjbig), - strings.c (scm_makstr, scm_take_str), symbols.c - (scm_intern_obarray_soft, scm_sysintern0_no_module_lookup), unif.c - (scm_make_uve), vectors.c (scm_make_vector): Use appropriate - SCM_SET__(CHARS|BASE) macro instead of SCM_SETCHARS. - - * numbers.h (SCM_SET_BIGNUM_BASE), strings.h - (SCM_SET_STRING_CHARS), symbols.h (SCM_SET_SYMBOL_CHARS), unif.h - (SCM_SET_UVECTOR_BASE, SCM_SET_BITVECTOR_BASE), vectors.h - (SCM_SET_VECTOR_BASE): Added. - - * symbols.c (SCM_SETCHARS): Deprecated. - -2000-11-22 Dirk Herrmann - - * gc.c (scm_gc_sweep), unif.c (scm_make_uve): Don't allocate or - free memory for empty bitvectors. - - * gh_data.c (makvect), strings.c (scm_makstr, scm_take_str), - symbols.c (scm_intern_obarray_soft, - scm_sysintern0_no_module_lookup), unif.c (scm_make_uve): Use - appropriate SCM_SET__LENGTH macro instead of SCM_SETLENGTH. - - * strings.h (SCM_SET_STRING_LENGTH), symbols.h - (SCM_SET_SYMBOL_LENGTH), unif.h (SCM_SET_UVECTOR_LENGTH, - SCM_SET_BITVECTOR_LENGTH): Added. - - * symbols.h (SCM_SETLENGTH): Deprecated. - -2000-11-22 Dirk Herrmann - - * continuations.c (scm_make_cont): Use - SCM_SET_CONTINUATION_LENGTH instead of SCM_SETLENGTH. - - * continuations.h (SCM_SET_CONTINUATION_LENGTH): Added. - -2000-11-22 Dirk Herrmann - - * vectors.c (scm_make_vector), weaks.c (scm_make_weak_vector): - Use SCM_SET_VECTOR_LENGTH instead of SCM_SETLENGTH. - - * vectors.h (SCM_SET_VECTOR_LENGTH): Added. - -2000-11-22 Dirk Herrmann - - * dynl.c (scm_make_argv_from_stringlist), filesys.c (scm_dirname, - scm_basename), gh_data.c (gh_scm2newstr, gh_get_substr), hash.c - (scm_hasher), load.c (scm_parse_path, scm_search_path, - scm_primitive_load_path), numbers.c (scm_string_to_number), - ports.c (scm_unread_string), posix.c (scm_convert_exec_args, - environ_list_to_c, scm_putenv), print.c (scm_iprin1, - scm_simple_format), random.c (scm_seed_to_random_state), socket.c - (scm_fill_sockaddr, scm_send, scm_sendto), strings.c - (scm_string_ref, scm_substring, scm_string_append), strings.h - (SCM_STRING_COERCE_0TERMINATION_X), strop.c (scm_i_index, - scm_string_to_list, scm_string_copy), strorder.c - (scm_string_equal_p, scm_string_ci_equal_p, scm_string_less_p, - scm_string_ci_less_p), strports.c (scm_mkstrport), struct.c - (scm_make_struct_layout), symbols.c (scm_string_to_symbol, - scm_string_to_obarray_symbol, scm_gensym, scm_gentemp): Replace - calls to SCM_ROU?CHARS with the corresponding call to - SCM_STRING_U?CHARS. - - * symbols.h (SCM_ROCHARS, SCM_ROUCHARS): Deprecated. - -2000-11-21 Dirk Herrmann - - * ports.c: Include eval.h. - - * strings.c (scm_string_set_x), strings.h (SCM_RWSTRINGP), - validate.h (SCM_VALIDATE_RWSTRING): Deprecate SCM_RWSTRINGP and - SCM_VALIDATE_RWSTRING. - - * strings.h (SCM_STRING_UCHARS, SCM_STRING_CHARS): Handle strings - and substrings uniformly. However, substring handling is - deprecated. - - (SCM_RWSTRINGP): Deprecated. - -2000-11-18 Gary Houston - - * Makefile.am (.c.x): don't prefix ".:" to $PATH when running - guile-doc-snarf. it doesn't seem to do anything useful, but would - fail if $PATH contained whitespace. Thanks to Lars J. Aas. - -2000-11-17 Marius Vollmer - - * alist.c, arbiters.c, async.c, backtrace.c, boolean.c, chars.c, - continuations.c, debug-malloc.c, debug.c, dynl.c, dynwind.c, - environments.c, eq.c, error.c, eval.c, evalext.c, feature.c, - filesys.c, fluids.c, fports.c, gc.c, goops.c, guardians.c, hash.c, - hashtab.c, hooks.c, ioext.c, iselect.c, keywords.c, lang.c, - list.c, load.c, macros.c, modules.c, net_db.c, numbers.c, - objects.c, objprop.c, options.c, pairs.c, ports.c, posix.c, - print.c, procprop.c, procs.c, properties.c, ramap.c, random.c, - read.c, regex-posix.c, root.c, scmsigs.c, script.c, simpos.c, - socket.c, sort.c, srcprop.c, stackchk.c, stacks.c, stime.c, - strings.c, strop.c, strorder.c, strports.c, struct.c, symbols.c, - tag.c, threads.c, throw.c, unif.c, variable.c, vectors.c, - version.c, vports.c, weaks.c: Makes sure the snarfer output - inclusion is disabled when the snarfer is run on the file. Thanks - to Lars J. Aas! - - * Makefile.am: Install guile-procedures.txt in version-specific - directory to enable multiple installed guile versions. Suggested - by Karl M. Hegbloom - - * fports.c: include gc.h. - (fport_flush, fport_close): silently ignore I/O errors when - closing a port during gc. it's better than aborting in scm_error. - - * throw.c (scm_handle_by_message): remove obsolete comment. - -2000-11-12 Gary Houston - - * fports.c (scm_open_file): fix the 'b' option. Thanks - to George Caswell. - -2000-11-09 Gary Houston - - * ports.c, ports.h (scm_close_all_ports_except): deprecated. - use port-for-each. Updated its docstring. - -2000-11-07 Gary Houston - - * ports.c (scm_port_for_each): new proc. implements port-for-each, - which applies a procedure to each port in the port table. - ports.h: declare scm_port_for_each. - - * ioext.c (scm_dup2): new proc. implements "dup2" which is a simple - wrapper for the dup2 system call (unlike dup->fdes or - primitive-move->fdes). - * ioext.h: declare scm_dup2. - - * filesys.c (scm_close_fdes): new proc. implements "close-fdes" - which is a simple wrapper for close system call (unlike scm_close). - * filesys.h: declare for scm_close_fdes. - -2000-11-06 Mikael Djurfeldt - - * eval.c (SCM_IM_DISPATCH), objects.c (scm_mcache_lookup_cmethod): - Count n_specialized + 1 turns before letting a match through. - - * goops.c (scm_sys_invalidate_method_cache_x): Don't convert - scm_si_n_specialized from fixnum and don't take absolute value. - (Thanks to Lars J. Aas.) - -2000-11-04 Gary Houston - - * ports.c (scm_port_p): new function, implements "port?" which - is mentioned in R5RS. - * ports.h: declare scm_port_p. - -2000-11-01 Dirk Herrmann - - * backtrace.c (display_expression, display_error_body), fports.c - (prinfport), print.c (scm_iprin1): Test for symbols and strings - explicitly instead of using SCM_ROSTRINGP. - - * backtrace.c (scm_display_error_message): Don't pass a symbol to - scm_simple_format. Prefer high-level output functions. - - (display_error_body): When displaying procedure names, give - preference to the name passed as a parameter. Only if none is - given extract a name from the stack information. - - * fports.c (scm_fdes_to_port, prinfport), gc.c (scm_gc_mark), - ports.c (scm_port_filename, scm_set_port_filename_x): Use - SCM_(SET_)?FILENAME. - - * gh_data.c (gh_set_substr, gh_scm2newstr, gh_get_substr, - gh_symbol2newstr): Use scm_remember instead of a pair of calls to - scm_protect/unprotect_object. - - * goops.c (make_struct_class), objects.c (scm_class_of): Struct - table names are symbols. - - * ports.h (SCM_SET_FILENAME): Added. - - * print.c (scm_iprin1): Don't use scm_puts to write symbols or - strings in order to treat substrings right. Reposition call to - scm_remember after the last use of object's data. - - (scm_simple_format): Treat messages that are substrings right. - - * symbols.h (SCM_ROSTRINGP): Deprecated. - -2000-11-01 Dirk Herrmann - - * environments.c (obarray_replace, obarray_retrieve, - obarray_remove): Don't use '==' to compare SCM objects. - - * posix.c (scm_getgroups): Don't create a redundant string. - -2000-11-01 Dirk Herrmann - - * symbols.c (scm_sym2vcell, scm_sym2ovcell_soft, - scm_intern_symbol, scm_unintern_symbol): Symbol objects already - hold their hash values, no need to recompute them. - - (scm_intern_obarray_soft): Speed up search for a matching symbol - by comparing the hash values first. - -2000-10-30 Dirk Herrmann - - * unif.c (scm_make_uve, scm_dimensions_to_uniform_array): Don't - allow vectors longer than SCM_LENGTH_MAX. This removes the - SCM_HUGE_LENGTH trick, i. e. storing a vector length greater than - SCM_LENGTH_MAX at the beginning of the vector's memory. Since not - all of guile's code was implemented to be aware of this trick, it - is unlikely that it was used anyway. We can implement such a - feature more cleanly by using double cells for uniform vector - types. - - (scm_shap2ra): Replace SCM_IMP and SCM_NIMP tests by more - straightforward predicates. - - (scm_dimensions_to_uniform_array): Require that for dimensions - given as lower-bound/upper-bound pairs the upper-bound is never - less than the lower bound. - -2000-10-27 Dirk Herrmann - - * dynl.c (scm_dynamic_link, scm_dynamic_func, scm_dynamic_call, - scm_dynamic_args_call), filesys.c (scm_chown, scm_chmod, - scm_open_fdes, scm_stat, scm_link, scm_rename, scm_delete_file, - scm_mkdir, scm_rmdir, scm_opendir, scm_chdir, scm_symlink, - scm_readlink, scm_lstat, scm_copy_file), fports.c (scm_open_file), - ioext.c (scm_read_delimited_x, scm_fdopen), load.c - (scm_primitive_load, scm_parse_path, scm_search_path, - scm_sys_search_load_path, scm_primitive_load_path), net_db.c - (scm_inet_aton, scm_gethost, scm_getnet, scm_getproto, - scm_getserv), numbers.c (scm_string_to_number), ports.c - (scm_truncate_file, scm_sys_make_void_port), posix.c - (scm_getpwuid, scm_getgrgid, scm_execl, scm_execlp, - environ_list_to_c, scm_execle, scm_utime, scm_access, - scm_setlocale, scm_mknod), regex-posix.c (scm_make_regexp), - simpos.c (scm_system, scm_getenv), socket.c (scm_fill_sockaddr, - scm_send, scm_sendto), stime.c (scm_strftime, scm_strptime), - strop.c (scm_i_index, scm_string_null_p, scm_string_to_list), - strports.c (scm_mkstrport), symbols.c - (scm_string_to_obarray_symbol), vports.c (scm_make_soft_port): - Don't accept symbols as input parameters. Use SCM_STRING_LENGTH - instead of SCM_ROLENGTH. - - * dynl.c (scm_dynamic_link, scm_dynamic_func), error.c - (scm_error_scm), filesys.c (scm_chown, scm_chmod, scm_open_fdes, - scm_stat, scm_link, scm_rename, scm_delete_file, scm_mkdir, - scm_rmdir, scm_opendir, scm_chdir, scm_symlink, scm_readlink, - scm_lstat, scm_copy_file), fports.c (scm_open_file), ioext.c - (scm_fdopen), net_db.c (scm_inet_aton, scm_gethost, scm_getnet, - scm_getproto, scm_getserv), ports.c (scm_truncate_file, - scm_sys_make_void_port), posix.c (scm_getpwuid, scm_getgrgid, - scm_execl, scm_execlp, scm_execle, scm_utime, scm_access, - scm_setlocale, scm_mknod), regex-posix.c (scm_make_regexp, - scm_regexp_exec), simpos.c (scm_system, scm_getenv), stime.c - (setzone, scm_strftime, scm_strptime), vports.c - (scm_make_soft_port): Use SCM_STRING_COERCE_0TERMINATION_X to - make sure the characters of a string are followed by a \0. - Further, use SCM_STRING_CHARS instead of SCM_ROCHARS on the - resulting string. - - * dynl.c (scm_make_argv_from_stringlist), posix.c - (scm_convert_exec_args): Aligned to match each other. - - * dynl.c (scm_coerce_rostring): Removed. - - (scm_dynamic_func): Changed the comment to reflect that the - function name has to be a string. Further, hide implementation - details from the scheme comment. - - * error (scm_error_scm): Don't accept a symbol as message - parameter. Fix substring handling. - - * posix.c (environ_list_to_c): Use memcpy to copy environment - strings. Handle substrings which don't have a trailing \0. - - * symbols.h (SCM_LENGTH, SCM_ROLENGTH, SCM_SUBSTRP, - SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR): - Deprecated. - - * unif.h (SCM_HUGE_LENGTH): Deprecated. - - * validate.h (SCM_VALIDATE_ROSTRING, SCM_VALIDATE_ROSTRING_COPY, - SCM_VALIDATE_NULLORROSTRING_COPY): Deprecated. - -2000-10-26 Dirk Herrmann - - * random.c: Include unif.h. - - * strings.h (SCM_STRING_COERCE_0TERMINATION_X): Added. This is - intended to replace the macro SCM_COERCE_SUBSTR. Such a macro - will be necessary, even after copy-on-write strings will be added - to guile, but the current naming is inappropriate. - - * strorder.c (scm_string_equal_p, scm_string_ci_equal_p, - scm_string_less_p, scm_string_ci_less_p): Don't accept symbols as - input parameters. Further, the functions that test for equality - are rewritten to compare from back to front, the others are also a - little bit more polished. - -2000-10-25 Mikael Djurfeldt - - This change merges the GOOPS code into Guile. However, GOOPS - is still not initialized until someone asks for the module. - We need to optimize GOOPS initialization time before initializing - it together with the rest of libguile. We also need to add the - C API + primitive methods. Then we can start using it to - modularize Guile, implement a real exception system etc. - - * goops.c, objects.c, objects.h, eval.c (scm_make_extended_class, - scm_make_port_classes, scm_change_object_class, - scm_memoize_method): Changed to ordinary functions (was plugin - slots). - - * goops.c (wrap_init, scm_wrap_object): Unconditionally use - SCM_STRUCT_GC_CHAIN. - (scm_goops_version): Removed. - (scm_oldfmt): and all uses of it: Removed. - (scm_shared_array_root, scm_shared_array_offset, - scm_shared_array_increments): Removed. - (scm_init_goops): No need to support two arg mutex init. - Removed #include "versiondat.h", #include "goops.h". - - * goops.h: Removed various superfluous conditions. - Renamed class --> cls, new --> newinst in order to accomodate - C++. - - * init.c (scm_init_guile_1): Call the goops module registration - function. - Added #include "libguile/goops.h". - - * Makefile.am (libguile_la_SOURCES): Added goops.c - (DOT_X_FILES): Added goops.x - (DOT_DOC_FILES): Added goops.doc - (modinclude_HEADERS): Added goops.h - -2000-10-25 Dirk Herrmann - - * gc.c (scm_igc): Remove references to scm_vector_set_length_x. - - (scm_gc_sweep): SCM_CONTREGS is never NULL. - - * gc.c (scm_gc_sweep), vectors.c (scm_make_vector): Don't - allocate/free memory for zero length vectors. - - * vectors.[ch] (scm_vector_set_length_x): Deprecated. - -2000-10-25 Dirk Herrmann - - * alist.c (scm_assq_ref): Add a suggestion about how to deal with - this function when the API gets reviewed. - - * async.c (SET_ASYNC_GOT_IT): Use SCM_TYP16 instead of doing bit - operations directly. - - * dynl.c (scm_coerce_rostring), filesys.c (scm_link, - scm_copy_file), fports (scm_open_file), hash.c (scm_hasher), - posix.c (scm_getpwuid), print.c (scm_iprin1), simpos.c - (scm_system), strings.c (scm_string_ref, scm_substring, - scm_string_append), strop.c (scm_string_copy), struct.c - (scm_make_struct_layout), symbols.c (scm_gensym, scm_gentemp), - symbols.h (SCM_COERCE_SUBSTR): Use SCM_STRING_LENGTH instead of - SCM_ROLENGTH if the object is known to be a string or substring. - - * eval.c (scm_lookupcar): Use SCM_ITAG7 instead of doing bit - operations directly. - - * filesys.c (scm_dirname, scm_basename): Don't create shared - substrings as these are going to disappear from guile. - - * gc.c (scm_gc_sweep): Use SCM_UVECTOR_LENGTH instead of - SCM_HUGE_LENGTH. (The SCM_HUGE_LENGTH mechanism does not work - correctly anyway.) - - * gc.h (SCM_FREEP, SCM_NFREEP): Deprecated. - - * read.c (scm_flush_ws): Don't compare SCM values directly. - - * root.c (scm_make_root), root.h (scm_root_state): Removed - system_transformer and top_level_lookup_closure_var from struct. - (Since eval is now R5RS, binary compatibility is not granted - anyway.) - - * simpos.c (scm_system): Fix condition. - - * strings.c (scm_string_length, scm_string_ref, scm_substring, - scm_string_append), strop.c (scm_string_copy), struct.c - (scm_make_struct_layout, scm_make_vtable_vtable), symbols.c - (scm_gensym, scm_gentemp): Replace SCM_VALIDATE_STRINGORSUBSTR - with SCM_VALIDATE_STRING, since they do the same thing. - - * strings.h (scm_make_shared_substring): Deprecated. - - * tags.h (SCM_ITAG7): Added. - - * validated.h (SCM_VALIDATE_STRINGORSUBSTR): Deprecated. - -2000-10-20 Marius Vollmer - - * init.c (scm_init_guile_1, invoke_main_func): Call - scm_load_startup_files in scm_init_guile_1, not in - invoke_main_func. - -2000-10-18 Marius Vollmer - - * print.c (grow_ref_stack): Pass a INUM to scm_make_vector as the - size, not a naked int. Thanks to Brad Knotwell! - - * gc_os_dep.c (GC_noop1, GC_bool, TRUE, FALSE, VOLATILE): - Definitions copied from Boehm collector. - -2000-10-13 Dirk Herrmann - - * list.[ch] (scm_sloppy_memq, scm_sloppy_memv, scm_sloppy_member): - Deprecated. - - (scm_memq, scm_memv, scm_member): Inline the sloppy code. - -2000-10-11 Dirk Herrmann - - * alloca.c: Fixed include file path. Thanks to Bruce Korb for - the bug report. - -2000-10-11 Marius Vollmer - - * gc_os_dep.c: Added real implementation based on code from Boehms - collector. This is not well tested yet. - - * gc.h (scm_get_stack_base): Added prototype. - * init.c (scm_get_stack_base): Removed prototype. - -2000-10-11 Dirk Herrmann - - * random.c (scm_seed_to_random_state): Replace SCM_LENGTH with - the appropriate SCM__LENGTH macro. - - (vector_scale, vector_sum_squares, scm_random_solid_sphere_x, - scm_random_normal_vector_x): Use scm_uniform_vector_length to - determine the length of a vector object generically. - -2000-10-11 Dirk Herrmann - - * ramap.c (scm_array_fill_int, scm_array_index_map_x): Replace - SCM_LENGTH with the appropriate SCM__LENGTH macro. - - (scm_ra_matchp, scm_ramapc, ramap, rafe, scm_array_index_map_x, - raeql_1, raeql): Use scm_uniform_vector_length to determine the - length of a vector object generically. - -2000-10-11 Dirk Herrmann - - * unif.c (scm_make_uve, scm_uniform_vector_length, scm_array_p, - scm_transpose_array, scm_array_contents, scm_ra2contig, - scm_uniform_array_read_x, scm_uniform_array_write, scm_bit_count, - scm_bit_position, scm_bit_set_star_x, scm_bit_count_star, - scm_bit_invert_x, scm_array_to_list, scm_raprin1): Replace - SCM_LENGTH with the appropriate SCM__LENGTH macro. - - (scm_array_dimensions, scm_make_shared_array, scm_enclose_array, - scm_array_in_bounds_p, scm_uniform_vector_ref, scm_array_set_x, - scm_array_contents, scm_uniform_array_read_x, - scm_uniform_array_write, scm_list_to_uniform_array, rapr1): Use - scm_uniform_vector_length to determine the length of a vector - object generically. - - (scm_bit_count, scm_bit_set_star_x, scm_bit_count_star, - scm_bit_invert_x): Eliminated dummy type dispatch. - - (scm_ra2contig): Fixed array vector access. - -2000-10-10 Dirk Herrmann - - * unif.h (SCM_BITVECTOR_P, SCM_BITVECTOR_BASE): Added. - - * eval.c (iqq, SCM_CEVAL, SCM_APPLY, check_map_args, scm_map, - scm_for_each, scm_copy_tree), gc.c (scm_igc, scm_gc_mark, - scm_gc_sweep), gh_data.c (gh_scm2chars), sort.c - (scm_restricted_vector_sort_x, scm_sorted_p, scm_sort_x, - scm_sort, scm_stable_sort_x, scm_stable_sort), vectors.c - (scm_vector_length, scm_vector_ref, scm_vector_set_x, - scm_vector_to_list, scm_vector_fill_x, scm_vector_equal_p, - scm_vector_move_left_x, scm_vector_move_right_x, ): Replace - SCM_LENGTH with the appropriate SCM__LENGTH macro. - - * gc.c (scm_gc_sweep): Use SCM_BITVECTOR_BASE for bitvectors. - - * sort.c (scm_restricted_vector_sort_x, scm_sorted_p): Eliminated - dummy type dispatch. - - (scm_sort_x, scm_sort, scm_stable_sort_x, scm_stable_sort): - Eliminated redundant NIM test. - -2000-10-09 Dirk Herrmann - - * filesys.c (fill_select_type, retrieve_select_type, scm_select), - gh_data.c (gh_set_substr, gh_scm2chars, gh_scm2shorts, - gh_scm2longs, gh_scm2floats, gh_scm2doubles, gh_symbol2newstr), - stime.c (bdtime2c), symbols.c (scm_sym2vcell, scm_sym2ovcell_soft, - scm_intern_obarray_soft, scm_symbol_to_string, scm_intern_symbol, - scm_unintern_symbol, copy_and_prune_obarray, scm_builtin_bindings, - scm_builtin_weak_bindings), validate.h (SCM_VALIDATE_VECTOR_LEN): - Replace SCM_LENGTH with the appropriate SCM__LENGTH macro. - - * filesys.c (scm_dirname, scm_basename), gh_data.c (gh_scm2newstr, - gh_get_substr), posix.c (scm_putenv), regex-posix.c - (scm_regexp_exec), stime.c (setzone), symbols.c - (scm_string_to_symbol): Don't accept symbols as input parameters - any more. - -2000-10-09 Dirk Herrmann - - * continuations.c (scm_make_cont, copy_stack_and_call, - scm_dynthrow), environments.c (obarray_enter, obarray_replace, - obarray_retrieve, obarray_remove, obarray_remove_all, - leaf_environment_fold), fluids.c (grow_fluids, scm_copy_fluids, - scm_fluid_ref, scm_fluid_set_x), hash.c (scm_hasher), hashtab.c - (scm_hash_fn_get_handle, scm_hash_fn_create_handle_x, - scm_hash_fn_remove_x, scm_internal_hash_fold), ioext.c - (scm_read_delimited_x), objects.c (scm_mcache_lookup_cmethod, - scm_make_subclass_object), ports.c (scm_unread_string), socket.c - (scm_recv, scm_recvfrom), stacks.c (scm_make_stack, scm_stack_id, - scm_last_stack_frame), strings.c (scm_string_length, - scm_string_set_x), strop.c (scm_substring_move_x, - scm_substring_fill_x, scm_string_fill_x, scm_string_upcase_x, - scm_string_downcase_x, scm_string_capitalize_x), struct.c - (scm_struct_init, scm_struct_vtable_p, scm_make_struct, - scm_make_vtable_vtable, scm_struct_ref, scm_struct_set_x), weaks.c - (scm_mark_weak_vector_spines, scm_scan_weak_vectors): Replace - SCM_LENGTH with the appropriate SCM__LENGTH macro. - -2000-10-09 Dirk Herrmann - - * print.c (make_print_state, scm_iprin1): Replace SCM_LENGTH with - the appropriate SCM__LENGTH macro. - - (grow_ref_stack): Don't call scm_vector_set_length_x to resize - the print stack. - -2000-10-09 Dirk Herrmann - - * numbers.c (big2str): Avoid redundant copying. - - (scm_bigprint): Use SCM_STRING_LENGTH instead of SCM_LENGTH. - -2000-10-06 Dirk Herrmann - - * numbers.c (big2str), read.c (scm_grow_tok_buf), strports.c - (st_resize_port): Don't call scm_vector_set_length_x to resize - strings. - - * read.c (scm_lreadr, scm_read_token): Use SCM_STRING_LENGTH for - string arguments (instead of SCM_LENGTH). - -2000-10-06 Dirk Herrmann - - * continuations.h (SCM_CONTINUATION_LENGTH), strings.h - (SCM_STRING_LENGTH), symbols.h (SCM_SYMBOL_LENGTH), unif.h - (SCM_UVECTOR_LENGTH, SCM_BITVECTOR_LENGTH), vectors.h - (SCM_VECTOR_LENGTH): Added as replacements for SCM_LENGTH. - -2000-10-02 Marius Vollmer - - * coop-defs.h (coop_key_create): Don't use the C++ keyword - `destructor' in prototype. Thanks to Martin Baulig! - -2000-10-02 Michael Livshin - - * guile-func-name-check.in: now should not confuse SCO nawk - anymore. thanks to Bruce Korb for the fix! - -2000-10-01 Gary Houston - - * net_db.c: declare inet_aton only if HAVE_INET_ATON is not - defined. thanks to Han-Wen Nienhuys. - -2000-09-30 Gary Houston - - * filesys.c (scm_stat2scm), posix.c (s_scm_mknod): don't use - S_ISSOCK or S_IFSOCK if not defined. thanks to Bruce Korb. - -2000-09-29 Neil Jerram - - * Makefile.am (guile-procedures.txt): Insert a new rule such that - the output from guile-snarf.awk is processed by makeinfo to - produce guile-procedures.txt. - - * guile-snarf.awk.in: Modify the way we snarf docstrings such that - the output is Texinfo-compliant and suitable for post-processing - with makeinfo. (Trim leading "./" from C file name if - present; reformat procedure prototype line in @deffn format; - improve representation of args to show optional and rest args; - explicitly quote quotation marks where they are used inside an AWK - regexp.) - - * net_db.c (scm_inet_ntoa): Docstring fix: missing newline - inserted. - - * hashtab.c (scm_hashx_create_handle_x, scm_hashx_ref): Insert - spaces between C parameters so that the snarfer doesn't coalesce - them all into a single very long-named parameter. - -2000-09-27 Neil Jerram - - * list.c (scm_append): Use @example texinfo markup in docstring. - -2000-09-26 Dirk Herrmann - - * strings.c (scm_string, scm_make_string, scm_string_set_x, - scm_string_append), strop.c (scm_string_upcase_x, - scm_string_downcase_x), strports.c (st_resize_port), symbols.c - (scm_sym2vcell, scm_sym2ovcell_soft, scm_intern_obarray_soft, - scm_intern_symbol, scm_unintern_symbol), unif.c (scm_cvref, - scm_uniform_vector_ref, scm_array_set_x, rapr1): Replace calls to - SCM_UCHARS with SCM_STRING_UCHARS or SCM_SYMBOL_UCHARS. - - * symbols.h (SCM_UCHARS): Deprecated. - -2000-09-26 Dirk Herrmann - - * gc.c (scm_gc_sweep): Replace SCM_CHARS by SCM_COMPLEX_MEM. - - * numbers.h (SCM_COMPLEX_MEM): Added as a replacement for - SCM_CHARS. - - (SCM_COMPLEX_REAL, SCM_COMPLEX_IMAG): Use it. - - * ramap.c (scm_array_fill_int, racp, raeql_1): Replace SCM_CHARS - with SCM_STRING_CHARS or SCM_UVECTOR_BASE. - - (racp): Fix: Make sure that src and dst types match. - - * read.c (scm_grow_tok_buf, scm_lreadr, scm_read_token): Replace - SCM_CHARS with SCM_STRING_CHARS. - - * symbols.h (SCM_CHARS): Deprecated. - - * unif.c (scm_enclose_array, scm_uniform_vector_ref, scm_cvref, - scm_array_set_x, scm_uniform_array_read_x, rapr1, freera, - scm_uniform_array_write): Replace SCM_CHARS with - SCM_STRING_CHARS, SCM_UVECTOR_BASE or SCM_ARRAY_MEM. - - * unif.h (SCM_ARRAY_MEM): Added as a replacement for SCM_CHARS. - - (SCM_ARRAY_V, SCM_ARRAY_BASE, SCM_ARRAY_DIMS): Use it. - - * validate.h (SCM_COERCE_ROSTRING): Removed. - -2000-09-26 Dirk Herrmann - - * gc.c (scm_igc): : Eliminate references to SCM_LENGTH and - SCM_CHARS from comment. - - (scm_gc_mark, scm_gc_sweep): Replace SCM_CHARS with - SCM_SYMBOL_CHARS or SCM_CCLO_BASE or SCM_UVECTOR_BASE or - SCM_BDIGITS, and replace SCM_VELTS with SCM_VECTOR_BASE or - SCM_CONTREGS, according to the corresponding types. - - (scm_gc_sweep): Simplify sweeping of uniform vectors. - -2000-09-26 Dirk Herrmann - - * procs.h (SCM_CCLO_LENGTH, SCM_SET_CCLO_LENGTH, SCM_CCLO_BASE, - SCM_SET_CCLO_BASE, SCM_CCLO_REF, SCM_CCLO_SET, SCM_CCLO_SUBR, - SCM_SET_CCLO_SUBR): Added resp. changed such that none of the - macros SCM_CHARS, SCM_SETCHARS, SCM_VELTS and SCM_LENGTH have to - be used with compiled closures any more. - - * procs.c (scm_makcclo), gsubr.h (SCM_GSUBR_TYPE, SCM_GSUBR_PROC): - Replace uses of SCM_CHARS, SCM_SETCHARS and SCM_VELTS with regards - to compiled closures. - - * gsubr.h (SCM_SET_GSUBR_TYPE, SCM_SET_GSUBR_PROC): Added. - - * gsubr.c (scm_make_gsubr): Use them. - -2000-09-26 Dirk Herrmann - - * numbers.c (scm_adjbig): Use SCM_BDIGITS instead of SCM_CHARS. - - (big2str, scm_bigprint): Use SCM_STRING_CHARS instead of - SCM_CHARS. - - * vectors.c (scm_vector_set_length_x): Distinguish between - strings, scheme vectors and uniform vectors, thus getting rid of - references to SCM_CHARS. (The code still needs improvement.) - -2000-09-26 Dirk Herrmann - - * eval.c (scm_m_letrec1, SCM_CEVAL, SCM_APPLY): Use - SCM_STRING_U?CHARS or SCM_SYMBOL_U?CHARS instead of SCM_U?CHARS. - - * unif.h (SCM_UVECTOR_BASE), vectors.h (SCM_VECTOR_BASE): Added - as replacements for SCM_CHARS and SCM_VELTS. - -2000-09-26 Dirk Herrmann - - * continuations.c (scm_make_cont, scm_dynthrow), print.c - (scm_iprin1), stacks.c (scm_make_stack, scm_stack_id, - scm_last_stack_frame): For continuations, use SCM_CONTREGS - instead of SCM_CHARS. - - * coop-threads.c (scm_threads_mark_stacks): Eliminate references - to SCM_LENGTH and SCM_CHARS from comments. - - * dynl.c (scm_dynamic_link, scm_dynamic_func), symbols.h - (SCM_ROCHARS, SCM_ROUCHARS): Cleanly distinguish between string - and symbol arguments. - - * hash.c (scm_hasher), keywords.c (prin_keyword), objects.c - (scm_make_subclass_object), print.c (scm_iprin1), regex-posix.c - (scm_regexp_error_msg), stime.c (bdtime2c, scm_strftime), struct.c - (scm_struct_init, scm_struct_vtable_p, scm_struct_ref, - scm_struct_set_x): Use SCM_STRING_U?CHARS or SCM_SYMBOL_U?CHARS - instead of SCM_U?CHARS. - - * strings.h (SCM_STRING_UCHARS): Added as a replacement for - SCM_UCHARS for string arguments. - - * strorder.c: Include strings.h and symbols.h. - - * symbols.h: Replaced SCM_CHARS in comment. - - (SCM_SYMBOL_UCHARS): Added as a replacement for SCM_UCHARS for - symbol arguments. - - (SCM_SLOPPY_SUBSTRP): Deprecated. - - * tags.h: Fixed comments not to reference SCM_LENGTH or - SCM_CHARS. - -2000-09-22 Dirk Herrmann - - * gc.c (scm_gc_mark, scm_gc_sweep), tags.h: Removed the - scm_tc7_lvector type tag. - -2000-09-22 Dirk Herrmann - - * eval.c (scm_m_define), evalext.c (scm_m_undefine): Removed dead - code. - - * gc.c (scm_gc_sweep): Use SCM_STRING_CHARS or SCM_SYMBOL_CHARS - instead of SCM_CHARS. - -2000-09-22 Dirk Herrmann - - * backtrace.c (display_frame_expr), environments.c - (print_observer, print_leaf_environment, print_eval_environment, - print_import_environment, print_export_environment), gh_data.c - (gh_set_substr, gh_symbol2newstr), keywords.c - (scm_make_keyword_from_dash_symbol), ports.c (scm_drain_input), - posix.c (scm_mknod), print.c (scm_iprin1), regexp-posix.c - (scm_regexp_error_msg), script.c (scm_compile_shell_switches), - simpos.c (scm_getenv), socket.c (scm_recv, scm_recvfrom), - strings.c (scm_makfromstr), strop.c (scm_substring_move_x, - scm_substring_fill_x, scm_string_capitalize_x), symbols.c - (scm_symbol_to_string), unif.c (scm_make_uve, scm_array_p), - validate.h (SCM_VALIDATE_STRING_COPY): Use SCM_STRING_CHARS or - SCM_SYMBOL_CHARS instead of SCM_CHARS. - -2000-09-22 Dirk Herrmann - - * strings.h (SCM_STRING_CHARS): Added, should be used instead of - SCM_CHARS whenever the argument is known to be a string. - - (SCM_SLOPPY_STRINGP): Deprecated. - - * symbols.h (SCM_SYMBOL_CHARS): Added, should be used instead of - SCM_CHARS whenever the argument is known to be a symbol. - -2000-09-22 Neil Jerram - - * struct.c (scm_make_struct): Fix texinfo warning in docstring by - using @pxref rather than @xref. - - * root.c (scm_call_with_dynamic_root): Fix texinfo warning in - docstring by using @code for (thunk) rather than @var. - -2000-09-20 Marius Vollmer - - * numbers.c (scm_istr2flo): Throw an `out of range' error when - exponent is too large instead of returning `#f'. The rationale is - that in this case the string represents a valid number but we - can't deal with it. - -2000-09-20 Dirk Herrmann - - * symbols.c (scm_intern_obarray_soft, - scm_sysintern0_no_module_lookup): Make sure that symbol - properties initially form an empty list. Thanks to Keisuke - Nishida for pointing this out. - -2000-09-19 Dirk Herrmann - - * throw.c (scm_handle_by_message): Added a FIXME comment. - - (scm_ithrow): Removed some redundant tests. When compiling on - gcc, always add the GCSE bug workaround. - -2000-09-14 Gary Houston - - * print.c (scm_iprin1): write the ascii delete character as #\del - instead of '#\', so it can be read back. like in SCM. - -2000-09-12 Mikael Djurfeldt - - * symbols.c (duplicate_string): Don't try to copy the byte after - the string. This might not be `\0' and might even not be - allocated memory. - -2000-09-12 Dirk Herrmann - - * symbols.c (scm_symbol_p): Eliminate redundant SCM_IMP test. - -2000-09-12 Dirk Herrmann - - This patch unifies the formerly distinct ssymbol and msymbol types - to a common symbol type scm_tc7_symbol. The representation of the - new symbol type uses a double cell with the following layout: - , where the car of - prop-pair holds the symbol's function property and the cdr of - prop-pair holds the symbol's other properties. In the long run, - these properties will be removed. Then, the generic property - functions will be uses. - - * eval.c (SCM_CEVAL), objects.c (scm_class_of), print.c - (scm_iprin1), tag.c (scm_tag): Use scm_tc7_symbol instead of - scm_tc7_ssymbol, scm_tc7_msymbol or scm_tcs_symbols. - - * gc.c (scm_gc_mark): Mark the symbols property pair. - - (scm_gc_sweep): There are no symbol slots any more. - - * hash.c (scm_hasher): Instead of re-calculating the hash value - of a symbol, use the raw_hash value stored in the symbol itself. - - * properties.h: Fix typo. - - * strings.[ch] (scm_makstr, scm_makfromstr): The slot parameter - is not used any more. - - * symbols.[ch] (scm_strhash): Deprecated, replaced by a macro. - - (scm_intern_obarray_soft): Made softness parameter unsigned. - - (scm_string_hash): New function with the same functionality as - scm_strhash had before, except that the hash value is not adjusted - to a hash table size. Instead, the 'raw' hash value is returned. - - * symbols.c (duplicate_string): New static convenience function. - - (scm_sym2vcell, scm_sym2ovcell_soft, scm_intern_obarray_soft): - Renamed local variable from scm_hash to hash. - - (scm_intern_obarray_soft): Don't check for a negative softness - any more. When generating symbol cells, use the new layout and - store the raw hash value in the symbol's cell. - - (scm_symbol_to_string): Removed unnecessary cast. - - (scm_intern_symbol, scm_unintern_symbol): Use scm_string_hash to - determine the hash values. - - (msymbolize): Removed. - - (scm_symbol_fref, scm_symbol_pref, scm_symbol_fset_x, - scm_symbol_pset_x, scm_symbol_hash): No need to distinguish - between different symbol types any more. - - (scm_symbol_hash): Comment fixed. - - * symbols.h: Comment about the distinction between ssymbols and - msymbols removed. - - (SCM_SYMBOLP, SCM_ROSTRINGP): No need to distinguish between - different symbol types any more. - - (SCM_PROP_SLOTS, SCM_SET_PROP_SLOTS): Added. - - (SCM_SYMBOL_FUNC, SCM_SET_SYMBOL_FUNC, SCM_SYMBOL_PROPS, - SCM_SET_SYMBOL_PROPS, SCM_SYMBOL_HASH, SCM_SET_SYMBOL_HASH): Use - the new symbol cell layout. - - * tags.h (scm_tc7_ssymbol, scm_tc7_msymbol, scm_tcs_symbols): - Deprecated. - -2000-09-12 Mikael Djurfeldt - - * symbols.h (scm_gentemp): Declared. - - * symbols.c (scm_gensym): Reimplemented. Now only takes one - optional argument which should be a *string*. - (scm_gentemp): Reimplemented and moved from boot-9.scm. - -2000-09-10 Keisuke Nishida - - * modules.c: Use applicable smobs for eval closures instead of - compiled closures. Include "libguile/smob.h". - (f_eval_closure): Removed. - (scm_eval_closure_tag): New variable. - (scm_eval_closure_lookup): Renamed from eval_closure. - This function now takes a smob instead of a compiled closure. - (scm_standard_eval_closure): Create a smob instead of a compiled - closure. - (scm_init_modules): Initialize the eval closure type as a smob. - * modules.h (SCM_EVAL_CLOSURE_P): New macro. - (scm_eval_closure_tag, scm_eval_closure_lookup): Declare. - * symbols.c: Include "libguile/smob.h". - (scm_sym2vcell): Call scm_eval_closure_lookup directly if THUNK - is an eval closure. - -2000-09-10 Mikael Djurfeldt - - * Makefile.am (.x.doc): Bugfix: Added $(srcdir) to path in order - to allow for builds in separate tree. - - * symbols.c (scm_gensym): Bugfixed my previous bugfix. (Thanks to - Dale P. Smith.) - -2000-09-10 Keisuke Nishida - - * eval.c (SCM_APPLY): Fixed bugs in the applicable-smob calls. - -2000-09-07 Dirk Herrmann - - * environments.c (obarray_enter, obarray_retrieve, - obarray_remove): Make sure the hash value is a valid obarray - index. - - (obarray_enter, obarray_remove): Documentation improved. - - (obarray_replace): Added. - - (leaf_environment_define, leaf_environment_undefine): Cleaned up - and optimized. - -2000-09-05 Mikael Djurfeldt - - * symbols.c (scm_gensym): Check that argument is a symbol, not a - string. (Thanks to Ralf Mattes.) - -2000-09-05 Marius Vollmer - - * init.c: Include "libguile/properties.h". - - * gh_data.c (gh_scm2char): Validate that argument is a character. - -2000-08-25 Dirk Herrmann - - * environments.h (SCM_IMPORT_ENVIRONMENT_P, - SCM_EXPORT_ENVIRONMENT_P): Before fetching the environment - functions, make sure that we really got an environment. - -2000-09-03 Mikael Djurfeldt - - * validate.h (SCM_VALIDATE_NUMBER_DEF_COPY): New macro. - -2000-09-03 Marius Vollmer - - * Makefile.am (.x.doc): Pretend to create .doc files from .x files - and give explicit dependencies for .x files that depend on - generated files. This allows parallel builds. Thanks to Matthias - Koeppe! - -2000-08-27 Marius Vollmer - - * Makefile.am: Added gc_os_dep.c, properties.c, properties.x, - properties.h and properties.doc in the suitable places. - - * init.h (scm_init_guile): New prototype. - - * init.c (scm_init_guile, scm_init_guile_1): New interface for - initializing Guile that does return to the caller. - (scm_boot_guile_1): Use scm_init_guile_1 to initialize Guile. - Do not establish a catch-all, this is no longer needed. - - * root.h (scm_properties_whash): New `sys_protect', used in - properties.c. - - * throw.c (scm_ithrow): Perform catch-all handling here when no - suitable handler has been found. That way, we don't have to rely - on the user establishing a catch-all, which might be difficult for - him if he is using scm_init_guile instead of scm_boot_guile. - -2000-09-03 Neil Jerram - - * vectors.c (scm_vector): Docstring: add @deffnx line for - list->vector. - - * unif.c (scm_uniform_vector_ref): Docstring: add @deffnx line for - array-ref. - (scm_array_set_x): Docstring: add @deffnx line for - uniform-array-set!. - - * symbols.c (scm_symbol_to_string): Docstring: complete an - incomplete Texinfo reference to a node in r4rs.texi. - (scm_symbol_to_string): Escape double quotes correctly within - docstring. - - * struct.c (scm_make_struct, scm_make_vtable_vtable): Docstring - fixes: `@dots' changed to `@dots{}'. - - * strop.c (scm_substring_move_x): Docstring: add @deffnx lines for - substring-move-left! and substring-move-right!. - - * strings.c (scm_string): Docstring: add @deffnx line for - list->string. - - * stime.c (scm_strptime): Fix spelling mistake in docstring. - (scm_current_time): Docstring fix: insert missing newline. - - * socket.c (scm_recvfrom): Docstring format fix: missing newline - inserted. - - * ramap.c (scm_array_copy_x): Docstring: add @deffnx line for - array-copy-in-order!. - (scm_array_map_x): Docstring: add @deffnx line for - array-map-in-order!. - - * posix.c (scm_mknod): Docstring format fix: missing newlines - inserted. - - * modules.c (scm_interaction_environment): Docstring fix: add - newlines. - - * eval.c (scm_cons_source): Added newly written docstring. - -2000-09-03 Michael Livshin - - the following changes let Guile get rid of the `allocated' cell - state. - - * smob.c (scm_smob_prehistory): don't init the "allocated" smob - type. - - * tags.h (scm_tc16_allocated): removed. - - * gc.h: removed now-obsolete comments about the `allocated' cell - state. - (SCM_NEWCELL): don't change cell type to `allocated'. - (SCM_NEWCELL2): ditto. - - * gc.c (scm_mark_locations): mark freecells too, and don't worry - about any possible false positives. - (scm_debug_newcell): don't change cell type to `allocated'. - (scm_debug_newcell2): ditto. - (scm_gc_for_newcell): ditto. - (scm_gc_mark): remove the tc16_allocated case. - -2000-08-26 Mikael Djurfeldt - - * gdbint.c (gdb_print): Removed superfluous macro definition. - - * objects.c (scm_init_objects), print.c (scm_init_print), struct.c - (scm_init_struct): First arg to scm_make_vtable_vtable should be a - string, not a symbol. (`make-vtable-vtable' needs to append this - string to another string and then pass it through - `make-struct-layout'.) - - * stacks.c (scm_init_stacks): Pass a string, not a layout object, - to scm_make_vtable_vtable. (Thanks to Dale P. Smith.) - - * struct.c (scm_make_struct_layout): Removed reference to - "read-only string" in comment; Check that argument is a string. - (scm_make_vtable_vtable): Check that argument is a string. - - * environments.c (scm_init_environments): All internal includes in - libguile must use the prefix "libguile/" in path names since inly - the top-level source directory is on the include list. (That, in - turn, is because we want to distinguish between system header - files and hedares files internal to libguile.) - - * strings.c (scm_make_shared_substring, scm_read_only_string_p): - Deprecated. - (scm_string_length, scm_string_ref, scm_substring, - scm_string_append): Don't accept symbols as arguments (R5RS). - -2000-08-25 Neil Jerram - - * ports.c (scm_set_port_column_x): Fix docstring so that it - mentions set-port-line! rather than set-port-column! twice. - - * guardians.c (scm_make_guardian): Remove spurious . from doc string. - -2000-08-25 Dirk Herrmann - - * Makefile.am: Added all necessary environments.* files. - - * init.c: Include environments.h. - - (scm_boot_guile_1): Initialize the environments. - - * environments.[ch]: Added. Most of the credit for these files - goes to Jost Boekemeier. - -2000-08-25 Mikael Djurfeldt - - * procprop.c: #include "libguile/smob.h"; handle applicable smobs. - -2000-08-24 Keisuke Nishida - - * smob.h (scm_smob_descriptor): Added `apply' and `gsubr_type'. - * smob.c (scm_make_smob_type): Initialize `apply' and `gsubr_type'. - (scm_set_smob_apply): New function. - (scm_smob_apply_0, scm_smob_apply_1, scm_smob_apply_2, - scm_smob_apply_3): New functions. - * eval.c (SCM_CEVAL, SCM_APPLY): Added dispatch for applicable smobs. - * procs.c (scm_procedure_p): Check applicable smobs. - -2000-08-24 Mikael Djurfeldt - - * Makefile.am (BUILT_SOURCES): Experimentally added scmconfig.h - also here. (This is supposed to make sure that scmconfig.h is - built before all sources in order to prevent that everything has - to be rebuilt again. Hope it works---I'm just guessing. :) - - * fluids.c (scm_fluid_set_x): Return SCM_UNSPECIFIED. - -2000-08-23 Mikael Djurfeldt - - * gc.c (scm_gc_mark): Don't use GUILE_DEBUG flag to compile in - extra tests. (GUILE_DEBUG is only supposed to make extra - debugging functions available.) - -2000-08-21 Michael Livshin - - * gc.h (SCM_GC_CARD_N_CELLS): change to be a nice non-confusing - constant. - -2000-08-19 Michael Livshin - - * gc.c (scm_gc_sweep): added a `continue' statement that have - fallen through the cracks in the merge. thanks to Shuji Narazaki! - - * gc.h: removed some stuff that broke compilation for people and - wasn't actually needed anyway. - -2000-08-18 Neil Jerram - - * filesys.c (scm_fcntl): Docstring fix - missing newlines inserted. - - * net_db.c (scm_gethost, scm_getnet, scm_getproto, scm_sethost, - scm_setnet, setproto, setserv): Argument names changed to match - doc string. - - * feature.c (scm_program_arguments): New docstring. - - * simpos.c (scm_getenv): Reflow docstring. - - * eq.c (scm_eq_p, scm_eqv_p, scm_equal_p): Add texinfo markup to - docstrings. - - * chars.c (scm_char*): Docstring fixes - texinfo markup. - -2000-08-18 Neil Jerram - - * boolean.c (scm_not, scm_boolean_p): Docstring fixes - add - texinfo markup and remove trailing newlines. - -2000-08-17 Michael Livshin - - this changes the Guile GC to use cards (aka "chunklets"). - (most of the ideas and some of the code are by Greg Harvey, though - the code is probably unrecognizable now. the original chunklet - proposal, way back, is by Dale Jordan). - - * tags.h: (SCM_GCTYPE16, SCM_GCCDR, SCM_GC[8]MARKP, - SCM_SETGC[8]MARK, SCM_CLRGC[8]MARK): moved from here into gc.h. - some (most) of these are probably going to be deprecated. - - * gc.h (SCM_MARKEDP): simplified, there are no different mark bit - locations anymore. - (SCM_GC_CARD_*, SCM_C_BVEC_*): lots of new macros to deal with - cards and bvecs (bit-vectors). - - * gc.c: (scm_default_init_heap_size_*): defined to take cards into - account, but keeping more or less the same values as previously. - added some simple helper macros. - (CLUSTER_SIZE_IN_BYTES, ALIGNMENT_SLACK): defined to take cards - into account. - (BVEC_*, scm_mark_space_t, current_mark_space, mark_space_ptr, - current_mark_space_offset, mark_space_head, get_bvec, - clear_mark_space): new functions and supporting variables, types - and macros that implement mark space management. - (scm_igc): clear the mark space (all of it) before beginning the - mark phase. - (scm_gc_mark): changed the tests for rogue cells, much simplified - throughout (no different mark bit locations to worry about now). - (scm_mark_locations): don't consider card header cells. - (scm_cellp): ditto. - (scm_gc_sweep): simplified. - (init_heap_seg): changed to take cards into account. - -2000-08-16 Michael Livshin - - * stime.c (scm_c_get_internal_run_time): new function, same as - scm_get_internal_run_time but returns a long. it's used by the GC - for timekeeping, since with scm_get_internal_run_time there is a - (extremely theoretical) possibility of consing. - (scm_get_internal_run_time): redefined in terms of - scm_c_get_internal_run_time. - - * stime.h: added prototype for scm_c_get_internal_run_time. - - * gc.c (scm_gc_stats): add more obscure stats, such as: mark time, - sweep time, total marked cells, total swept cells, and number of - times GC was invoked. - (gc_start_stats): renamed from scm_gc_start, made static, taught - to init the new stats. - (gc_end_stats): renamed from scm_gc_end, made static, taught to - calculate the new stats. - (scm_igc): don't call gc_start_stats unless we are sure that we - are indeed going to collect. also, added some timekeeping between - the mark and sweep phases. - (scm_gc_sweep): count number of cells we sweep as we go. - - * gc.h: removed prototypes for scm_gc_{start,end}. - -2000-08-13 Mikael Djurfeldt - - * alist.c (scm_assq, scm_assv, scm_assoc): Report argument type - error for the alist rather than the sublist where the type - mismatch is discovered. - -2000-08-13 Neil Jerram - - * root.c (s_scm_call_with_dynamic_root): Docstring fix - rogue - newline. - -2000-08-12 Neil Jerram - - * numbers.c (scm_ash): Docstring fix - missing newlines. - - * ports.c (scm_port_filename): Docstring fix - missing newline. - - * strports.c (scm_eval_string): Docstring fix - missing newline. - - * vports.c (s_scm_make_soft_port): Docstring updated so that - example is correct. - - * strop.c: Docstring fixes - quotation marks and backslashes - needed quoting. - - * numbers.c (s_scm_logand): Docstring fix - "@end lisp" inserted. - -2000-08-11 Neil Jerram - - * macros.c: Remove surplus newlines from end of docstrings. - - * list.c (scm_list_tail): Add @deffnx line to docstring for - list-cdr-ref. - - * keywords.c: Docstring improvements in conjunction with new - reference manual doc on keywords. - - * error.c (scm_error_scm): Fix texinfo syntax error in - docstring. (@code(~S) should be @code{~S}.) - - * dynl.c: Remove surplus newlines from end of docstrings. - -2000-08-11 Mikael Djurfeldt - - * eval.c (scm_eval): Backward incompatible change: Now takes an - environment specifier as second arg. `eval' hereby becomes R5RS - compatible. - (scm_i_eval_x, scm_i_eval): New functions (replace - scm_eval_3). - (scm_eval2, scm_eval_3): Deprecated. - (scm_top_level_lookup_closure_var): Deprecated. - - * eval.h: #include "struct.h". - - * evalext.c (scm_definedp): Have to work before module system is - booted. - - * modules.h (SCM_MODULEP, SCM_VALIDATE_MODULE, - SCM_MODULE_OBARRAY, SCM_MODULE_USES, SCM_MODULE_BINDER, - SCM_MODULE_EVAL_CLOSURE): New macros. - (scm_module_index_obarray, scm_module_index_uses, - scm_module_index_binder, scm_module_index_eval_closure): New - constants; #include "validate.h". - - * modules.c (scm_module_tag, scm_module_system_booted_p): New - globals. - (scm_post_boot_init_modules): Initialize scm_module_tag. - (scm_interaction_environment): New primitive. - - * symbols.c (scm_can_use_top_level_lookup_closure_var): Removed. - #include "modules.h". - - * strports.c (scm_eval_string): Evaluate in - scm_interaction_environment (). - - * script.c (scm_shell): Pass scm_the_root_module () as second arg - to new scm_eval_x. - - * load.c (load): Use `scm_selected_module' to compute second arg - to new scm_i_eval_x; Don't call it if module system hasn't booted. - (scm_read_and_eval_x): Deprecated. - #include "modules.h". - - * debug.c (scm_local_eval): Use scm_i_eval and scm_i_eval_x. - (scm_start_stack): Use scm_i_eval. - - * strports.c: #include "modules.h". - - * print.c (scm_simple_format): Be case-insensitive for ~A and ~S - directives. - -2000-08-09 Mikael Djurfeldt - - The following changes are intended to ensure that struct instances - are freed before their vtables. It's optimized for the most - common case, which is freeing of struct instances. - - * gc.c (scm_gc_mark, scm_gc_sweep): Remove vcell = 1 magic. - (scm_structs_to_free): New variable. - (scm_gc_sweep): Hook up structs to free on the scm_structs_to_free - chain. - - * struct.h (SCM_STRUCT_GC_CHAIN, SCM_SET_STRUCT_GC_CHAIN): New - macros. - (scm_structs_to_free, scm_struct_prehistory): Declare. - - * struct.c (scm_make_struct, scm_make_vtable_vtable): Structs - handles are now double cells; Initialize SCM_STRUCT_GC_CHAIN to - 0. - (scm_struct_gc_init, scm_free_structs): New GC C hooks. - (scm_struct_prehistory): Install them. - - * init.c (scm_boot_guile_1): Call scm_struct_prehistory. - -2000-08-06 Marius Vollmer - - * read.c (scm_flush_ws): Include filename in error message when it - is not `#f'. - -2000-08-05 Marius Vollmer - - * iselect.c: Include . Thanks to Bertrand Petit! - -2000-08-02 Mikael Djurfeldt - - * struct.c (scm_make_struct_layout, scm_make_struct, - scm_make_vtable_vtable): Updated documentation. - - * print.c (scm_simple_format): Bugfix: Coerce port before using - it. - -2000-07-31 Gary Houston - - * net_db.c: declare h_errno only if HAVE_H_ERRNO is not defined - (thanks to Richard Kim for the bug report). - -2000-07-30 Marius Vollmer - - * alist.c (scm_assq_remove_x, scm_assv_remove_x, - scm_assoc_remove_x): Use scm_delq1_x instead of scm_delq_x, since - using the latter is pointless. - -2000-07-26 Dirk Herrmann - - * gc.c (scm_gc_sweep): Renamed local variable from 'free' to - 'free_struct_data' to avoid confusion with stdlib's 'free'. - -2000-07-26 Dirk Herrmann - - * vectors.c (scm_make_vector): Fix the initialization order of - the vector such that the type cell is initialized last. - -2000-07-26 Dirk Herrmann - - * struct.[ch] (scm_struct_init): Made static. Fixed not to rely - on the struct cell to be fully initialized. - - * struct.c (scm_make_struct, scm_make_vtable_vtable): Fix the - initialization order of the struct such that the type cell is - initialized last. - -2000-07-25 Marius Vollmer - - * alist.c (scm_assq_remove_x, scm_assv_remove_x, - scm_assoc_remove_x): Remove only the first cell with a matching - key, not all. - -2000-07-24 Marius Vollmer - - * stime.c (scm_strftime): Recognize a return value of zero from - strftime as buffer overflow and take care to detect a valid zero - length result regardless. Thanks to David Barts! - -2000-07-23 Marius Vollmer - - * alist.c (scm_assq_remove_x, scm_assv_remove_x, - scm_assoc_remove_x): Remove all cells whose key is eq, eqv, or - equal (respectively) to the argument key, not all cells that are - eq, eqv, or equal to the first cell with the argument key. Thanks - to Neil Jerram! - -2000-07-18 Dirk Herrmann - - * gc.h (SCM_FREE_CELL_CDR, SCM_SET_FREE_CELL_CDR), hooks.c - (make_hook), modules.c (OBARRAY, USES, BINDER): Pack and unpack - SCM values appropriately. - - * modules.c (scm_standard_eval_closure): Don't pass an inum to - scm_makcclo, but rather a long value. - -2000-07-18 Dirk Herrmann - - read.c (scm_lreadrecparen), srcprop.c (scm_set_source_property_x): - SCM_SETCDR and SCM_WHASHSET macros don't deliver a return value. - Thanks to Han-Wen Nienhuys for the bug report. - -2000-07-18 Dirk Herrmann - - * root.[ch] (scm_call_catching_errors): Deprecated. - - * root.c (scm_init_root): Initialize the root smob type using the - standard initialization functions. - -2000-07-17 Marius Vollmer - - * eval.c (unmemocopy): Don't rely on V being a list of at least - one element. Thanks to Bill Schottstaedt! - -2000-07-15 Michael Livshin - - * gc.c (scm_done_free): new. - expanded comments about scm_done_malloc. - - * gc.h: added prototype for scm_done_free - -2000-07-13 Dirk Herrmann - - * gc.h (scm_take_stdin): Removed. - - * gc.h (SCM_VALIDATE_CELL): Delegate cell checks to function - scm_assert_cell_valid to allow extensions to the checking - functionality without need to recompile everything. - - * gc.[ch] (scm_assert_cell_valid, scm_set_debug_cell_accesses_x): - Added as conditionally compiled functions for the case that - SCM_DEBUG_CELL_ACCESSES is enabled. - - * gc.c (debug_cells_p): Added to indicate whether compile-time - included cell access debugging is run-time enabled. - - * gc.[ch] (scm_gc_running_p): Added to indicate that scm_igc is - being executed. Intended to be used instead of scm_gc_heap_lock - at most places. - - * error.c (scm_error), gdbint.c (SCM_GC_P): Use scm_gc_running_p - instead of scm_gc_heap_lock. - - * gc.c (scm_igc): Set scm_gc_running_p to true while running. - - * gc.c (scm_mark_locations): Don't mark free cells. - - * weaks.c (scm_scan_weak_vectors): Use SCM_FREE_CELL_P instead of - SCM_FREEP. - -2000-07-13 Dirk Herrmann - - * gc.c (scm_mark_locations): Minimized some variable scopes and - simplified the code a bit. - -2000-07-10 Dirk Herrmann - - * gc.h (SCM_SET_FREE_CELL_TYPE, SCM_SET_FREE_CELL_CDR, - SCM_FREE_CELL_P, SCM_FREE_CELL_CDR): Added since free cells - should not be accessed via SCM_C[AD]R. Further, using dedicated - macros to access free cells allows all other cell accessing macros - to treat acesses to free cells as errors, thus enabling better - error checks for cell accesses. SCM_FREE_CELL_P is supposed to - replace SCM_FREEP some time. - - * gc.h (SCM_NEWCELL, SCM_NEWCELL2), gc.c (map_free_list, - free_list_length, scm_check_freelist, scm_debug_newcell, - scm_debug_newcell2, freelist_length, scm_gc_for_newcell, - scm_gc_mark, scm_gc_sweep, init_heap_seg): Only use the dedicated - cell accessors when accessing free cells. - -2000-07-10 Dirk Herrmann - - * gc.h (SCM_CELL_WORD, SCM_CELL_OBJECT): Treat the referenced - object as const in order to make the compiler warn about code like - SCM_CELL_WORD (x, n) = y. Instead, SCM_SET_CELL_WORD (x, n, y) - should be used. - - (SCM_CELL_WORD_LOC, SCM_CARLOC, SCM_CDRLOC): Return the address - as an address to a non-const object, since these macros are used - to allow direct write access to objects. - -2000-07-07 Dirk Herrmann - - * hashtab.c (scm_hash_fn_create_handle_x): Signal an error if the - given hash table has no slots. - -2000-07-06 Dirk Herrmann - - * gc.c (policy_on_error): Added in order to allow alloc_some_heap - to react to malloc failures in a context dependent way. - - (scm_check_freelist): No need to flush streams before abort(). - - (scm_gc_for_newcell): Try to allocate new memory in three phases: - grow heap if preferred, if still no memory available collect - garbage, if still no memory available grow heap. - - (heap_segment_table_size): Added to always reflect the actual - size of the heap segment table, because scm_n_heap_segs may differ - from the heap segment table size. - - (alloc_some_heap): In case of malloc failure, react according to - the new policy_on_error parameter (either return to caller or - abort immediately). Further, keep heap_segment_table_size up to - date. - - (scm_init_storage): Initialize heap_segment_table_size. - -2000-07-06 Dirk Herrmann - - * gh.h: Don't include . Thanks to Han-Wen Nienhuys for - the hint. - -2000-06-30 Dirk Herrmann - - * __scm.h (SCM_OUTOFRANGE, SCM_NALLOC, SCM_HUP_SIGNAL, - SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, - SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD, - SCM_ORD_SIG, SCM_NUM_SIGS): Re-introduce these as deprecated - symbols. - - * error.c (scm_wta): Re-introduce dispatching for SCM_OUTOFRANGE - and SCM_NALLOC, but as a deprecated feature. - -2000-06-30 Mikael Djurfeldt - - * debug.c: Added #include fluids.h. - - * numbers.c (scm_gr_p, scm_leq_p, scm_geq_p): Turned into - primitive generics. (Thanks to Nicolas Neuss.) - -2000-06-30 Dirk Herrmann - - * gc.c (alloc_some_heap): Use scm_memory_error to indicate a - failed attempt to get additional memory from the system. - - (scm_gc_for_newcell): Changed the control structure to make the - behaviour explicit for the case that gc is not able to free any - cells. - -2000-06-30 Dirk Herrmann - - * __scm.h (SCM_OUTOFRANGE): Removed. - - * error.c (scm_wta): Removed sick dispatch code for range - errors. (More sick dispatches still to be removed.) - - * hashtab.c (scm_hash_fn_get_handle, scm_hash_fn_create_handle_x, - scm_hash_fn_remove_x): Eliminate redundant test for if unsigned - value is non-negative. Use scm_out_of_range to signal range - errors. - - * hooks.c (make_hook), unif.c (scm_aind): Use scm_out_of_range to - signal range errors. - - * list.c (scm_list_ref, scm_list_set_x, scm_list_cdr_set_x): Fix - error reporting (now uses original input parameter to report wrong - type argument errors). Use SCM_OUT_OF_RANGE to report range - errors and SCM_WRONG_TYPE_ARG to report type errors. - - * strings.c (scm_substring): Make range checks for negative - values explicit (former behaviour relied on an implicit - conversion from signed to unsigned). Don't use SCM_ASSERT for - range checks. - - * unif.c (scm_aind, scm_transpose_array, scm_bit_set_star_x, - scm_bit_count_star): Use scm_out_of_range to signal range - errors. - - * unif.c (scm_transpose_array, scm_bit_position), vectors.c - (scm_vector_ref, scm_vector_set_x, scm_vector_move_left_x, - scm_vector_move_right_x): Use SCM_ASSERT_RANGE to check ranges. - -2000-06-30 Dirk Herrmann - - * validate.h (SCM_VALIDATE_INUM_MIN_COPY, - SCM_VALIDATE_INUM_MIN_DEF_COPY, SCM_VALIDATE_INUM_RANGE_COPY): - Perform all range checks based on the input value. The former way - of using the value that is assigned to the target variable fails - if the assignment to the target variable itself can change the - value because of type conversion. - - (SCM_ASSERT_RANGE): Use scm_out_of_range to signal range errors. - -2000-06-30 Mikael Djurfeldt - - * gc.c (scm_gc_for_newcell): Behave gracefully also if scm_igc - doesn't yield any new cells. In theory this could happen if all - cells allocated with NEWCELL are either in use or conservatively - marked and all cluster spine cells are conservatively marked. - (Thanks to Dirk.) - -2000-06-29 Dirk Herrmann - - * __scm.h (SCM_NALLOC): Removed. - - * error.c (scm_wta): Removed sick dispatch code for memory - errors. (More sick dispatches still to be removed.) - - * numbers.c (scm_mkbig, scm_adjbig), ports.c (scm_make_port_type), - random.c (scm_i_copy_rstate, scm_c_make_rstate), smob.c - (scm_make_smob_type), srcprop.c (scm_make_srcprops), vectors.c - (scm_vector_set_length_x): Now using scm_memory_error to signal - memory errors. - -2000-06-29 Dirk Herrmann - - * __scm.h: Removed some commented code and fixed some comments. - - (SCM_HUP_SIGNAL, SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, - SCM_SEGV_SIGNAL, SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, - SCM_SIG_ORD, SCM_ORD_SIG, SCM_NUM_SIGS): Removed. - - * async.c: Removed some commented code. - -2000-06-29 Dirk Herrmann - - * gc.c (scm_gc_mark, scm_gc_sweep, scm_must_malloc, - scm_must_realloc, scm_must_free, alloc_some_heap): Use the - appropriate error signalling function. - -2000-06-29 Dirk Herrmann - - * root.h (scm_first_type): Removed. - -2000-06-29 Dirk Herrmann - - * gc.c (MIN_GC_YIELD): Removed. - -2000-06-28 Michael Livshin - - * gc.c (scm_gc_for_newcell): don't try to do GC if it's blocked, - allocate instead. - -2000-06-28 Dirk Herrmann - - * async.c (scm_gc_async, scm_gc_vcell, scm_sys_gc_async_thunk): - Moved to gc.c. - - (scm_init_async): Moved initialization for scm_gc_async and - scm_gc_vcell to gc.c. Moved initialization of scm_asyncs here - from gc.c. - - * async.h (scm_gc_async): Not globally visible any more. - - * gc.c (scm_gc_stats): Made callable even from within regions - where gc is blocked. - - (scm_gc_end): Eliminate the hardcoding of the marking of the - scm_gc_async from the gc core. - - (scm_init_storage): Don't initialize the scm_asyncs list here. - This is now done in asyncs.c. - - (scm_gc_vcell): Moved here from async.c. - - (gc_async): Renamed from scm_gc_async, moved here from async.c - and made static. - - (gc_async_thunk): Renamed from scm_sys_gc_async_thunk and moved - here from async.c. - - (mark_gc_async): New hook function for scm_after_gc_c_hook. - - (scm_init_gc): Added initialization of scm_gc_vcell and - gc_async. Further, add mark_gc_async to scm_after_gc_c_hook. - - * init.c (scm_boot_guile_1): scm_init_gc requires asyncs to be - initialized. - -2000-06-28 Dirk Herrmann - - * gc.c (scm_igc): Removed commented code that once was intended - to unprotect struct types with no instances. - - * root.h (scm_type_obj_list): Removed. - -2000-06-27 Dirk Herrmann - - * async.c (scm_init_async): Switch to standard way of smob - initialization. - -2000-06-21 Michael Livshin - - * guile-doc-snarf.in: use cut instead of sed, that's much much - faster. also, don't call basename more than needed. and, to gain - a couple of microseconds more, don't call cat needlessly. (thanks - to Brad Knotwell). - -2000-06-21 Dirk Herrmann - - * guile-snarf.awk.in, guile-snarf.in, snarf.h: Rename SCM__I to - SCM_SNARF_INIT_START, SCM__D to SCM_SNARF_DOC_START, SCM__S to - SCM_SNARF_DOCSTRING_START and SCM__E to SCM_SNARF_DOCSTRING_END. - -2000-06-21 Mikael Djurfeldt - - * eval.c, eval.h (scm_top_level_lookup_closure_var): Added. - #include "libguile/fluids.h". - - * eval.h (SCM_TOP_LEVEL_LOOKUP_CLOSURE): New macro which replaces - SCM_CDR (scm_top_level_lookup_closure_var) everywhere. - - * root.h (scm_top_level_lookup_closure_var, - scm_system_transformer): Removed. (It's no sense in having the - *variable* be a "fluid".) - - * root.c (mark_root): Removed marking of - s->top_level_lookup_closure_var and s->system_transformer. - - * modules.c (scm_selected_module): the_module is now a fluid. - -2000-06-20 Mikael Djurfeldt - - * gc.h, tags.h: Be kind to compilers which must see hash signs in - column 0. (Thanks to Ian Grant.) - - * numbers.h: Put #ifdef HAVE_LONG_LONGS around declarations using - the long_long type. (Thanks to Bernard Urban.) - -2000-06-20 Mikael Djurfeldt - - * gc.c, gc.h (scm_default_init_heap_size_1, - scm_default_min_yield_1, scm_default_init_heap_size_2, - scm_default_min_yield_2, scm_default_max_segment_size): New global - variables. Can be customized by the application before booting - Guile. (We might want to be able to control these parameters - dynamically through the "options interface" in the future, but - note that that is additional functionality. Here we're giving - default values which the environment variables can override.) - - * list.c (scm_cons_star): Updated comment. - - * smob.h: Changed comments for scm_make_smob_type and - scm_make_smob_type_mfpe, warning that the latter might be - deprecated in a future release. - -2000-06-19 Dirk Herrmann - - * list.[ch] (scm_cons_star/cons*): Renamed from - scm_list_star/list*. - - * list.[ch] (scm_list_star/list*): Provided as a deprecated alias - for scm_cons_star/cons*. - - * gc.c (scm_protect_object): Updated comment. - - * numbers.h (SCM_NEWREAL, SCM_NEWCOMPLEX): Removed. - - * tags.h (SCM_UNPACK_CAR, SCM_NDOUBLE_CELLP): Removed. - -2000-06-19 Mikael Djurfeldt - - * init.c, init.h (scm_initialized_p): Renamed from `initialized' - and made global. - - * gdbint.c (gdb_print): Print warning instead of calling scm_write - if Guile isn't yet initialized. - - * print.c (scm_current_pstate, scm_make_print_state): Simplified - tests, using the assumption that Guile has been initialized. - -Sun Jun 18 14:45:21 2000 Greg J. Badros - - * print.c (s_scm_current_pstate): Do not segfault when the - print_state_pool is unitialized in `current-pstate', and better - verify its state before altering it in scm_make_print_state(). - -2000-06-18 Michael Livshin - - * scmsigs.c (s_scm_sigaction): guard the SIGIOT case with an - #ifdef -- it's missing on at least one platform. (thanks to - Jan Nieuwenhuizen). - -2000-06-16 Dirk Herrmann - - * list.c (list*): Added documentation from common-list.scm. - -2000-06-15 Dirk Herrmann - - * gc.c (scm_unprotect_object): The reference count is guaranteed - to be a positive number. - -2000-06-15 Mikael Djurfeldt - - * eval.c: Updated comment above scm_map. - -2000-06-14 Mikael Djurfeldt - - * gc.c (scm_protect_object): Avoid looking up the object handle - twice. - (scm_unprotect_object): Abort if scm_unprotect_object is called on - an unprotected object. - -2000-06-14 Michael Livshin - - * gc.c (scm_unprotect_object): fix a nasty typo bug (thanks to - Dirk Herrmann). - -2000-06-14 Mikael Djurfeldt - - * socket.c (scm_getsockopt): Changed type for `optlen' from int to - size_t. - (scm_accept, scm_getsockname, scm_getpeername, scm_recvfrom): - Ditto for `tmp_size'. - (scm_addr_buffer_size): Changed type from int to size_t. - - * random.c: #include . (Needed by memcpy.) - - * guile-snarf.awk.in: Replace the dot_doc_file arg with "-", - indicating stdin, instead of "" and don't reset ARGC. This is a - workaround for `nawk' in AIX 4.3 on RS6000 but, as far as I know, - it is correct, and perhaps even better. - -2000-06-14 Gary Houston - - * scmsigs.c (scm_init_scmsigs): if HAVE_SIGINTERRUPT is not - defined, add SA_RESTART to the sigaction flags correctly - (thanks to Dale P. Smith). - -2000-06-13 Mikael Djurfeldt - - * strings.c: #include . (Thanks to Bill Schottstaedt.) - - * net_db.c (scm_resolv_error): Only use macro NETDB_INTERNAL if - defined. It isn't on sgi irix 5.3. (Thanks to Bill Schottstaedt.) - - * Makefile.am (.c.doc): Pipe output (the .x contents) to /dev/null. - -2000-06-13 Mikael Djurfeldt - - * fports.c (scm_setvbuf): Use `free' instead of `scm_must_free' - since read and write buffers are allocated by `malloc'. - - * Makefile.am: Removed old test code. - - * gh_test_c.c, gh_test_repl.c: Removed. - -2000-06-12 Mikael Djurfeldt - - * iselect.c (SCM_NLONGBITS): Add workaround for the Sun 4.2 - compiler. - - * inet_aton.c (inet_aton): Cast init value for `cp'. - - * ramap.c (s_scm_array_fill_x): Cast `ve' properly in case - `scm_tc7_uvect'. - - * symbols.c (scm_intern_obarray_soft, - scm_sysintern0_no_module_lookup): Cast `name' to unsigned char ptr - in calls to scm_strhash. - - * strports.c (st_resize_port): Substituted SCM_UCHARS for - SCM_CHARS. - (st_write): Cast argument to strncpy to char ptr. - (scm_mkstrport): Substituted SCM_ROUCHARS for SCM_ROCHARS. - (scm_strport_to_string): Cast argument to scm_makfromstr to char - ptr. - - * ports.c (scm_ungetc): Cast value to unsigned char ptr before - storing in putback_buf. - (scm_unread_string): Substituted SCM_ROCHARS for SCM_ROUCHARS. - - * ioext.c (s_scm_read_line): Cast result of call to - scm_do_read_line to unsigned char ptr. - - * gdbint.c (SEND_STRING): Cast argument to char pointer. - - * fports.c (fport_flush): Declare `ptr' as unsigned char (was - char). - - * Makefile.am (DOT_DOC_FILES): List doc-files explicitly. (We - shouldn't use Make rules which aren't supported by most Make - programs.) - (OMIT_DEPENDENCIES): Defined to "libguile.h ltdl.h". (We don't - want these dependencies recorded, since they would get bogus - relative paths; libguile.h is only used in gh.h and guile.c.) - (EXTRA_DOT_X_FILES, EXTRA_DOT_DOC_FILES): New variables. - (guile-procedures.txt): Depend on EXTRA_DOT_DOC_FILES. - (modinclude_HEADERS): Removed kw.h. - - * guile-snarf.in: Change regexp "^SCM__I" --> "^ *SCM__I". - (The preprocessor might insert spaces before the identifier.) - - * snarf.h (SCM_SNARF_HERE, SCM_SNARF_INIT, SCM_SNARF_DOCS): - Renamed from SCM_HERE, SCM_INIT, SCM_DOCS. - - * smob.h (scm_smobfuns): Removed deprecated type. - - * smob.c, smob.h (scm_newsmob): Removed deprecated function. - (Replaced by `scm_make_smob_type'.) - - * keywords.c (scm_tc16_kw): Removed deprecated type. - (Replaced by scm_tc16_keyword.) - - * kw.h: Removed deprecated header file. - - * evalext.c (serial-map): Removed deprected alias for scm_map. - (Has been replaced by `map-in-order'.) - - * ramap.c (serial-array-copy!, serial-array-map!): Removed - depracted aliases. (Replaced by `array-copy-in-order!' and - `array-map-in-order'.) - -2000-06-11 Mikael Djurfeldt - - * gc.h (SCM_VALIDATE_CELL): Rewritten. - (SCM_CELL_WORD, SCM_CELL_OBJECT, SCM_SET_CELL_WORD, - SCM_SET_CELL_OBJECT): Use new version of SCM_VALIDATE_CELL. - (Thanks to Han-Wen Nienhuys.) - -2000-06-10 Michael Livshin - - * guile-doc-snarf.in: don't pipe the CPP output right into sed -- - write it to the temp file first and check the CPP return code. - (I introduced this bug earlier, and this probably caused people - with non-GNU C preprocessors to get empty *.x files and not to - have the build fail right away...). - - * scmsigs.c (s_scm_sigaction): guard the SIGSYS case with an ifdef - -- at least my libc5-based Linux system doesn't define SIGSYS. - -2000-06-08 Mikael Djurfeldt - - * snarf.h, guile-snarf.awk.in, guile-snarf.in: Replaced snarf - markers with identifiers (SCM__I, SCM__D, SCM__S, SCM__E). - (Thanks to Bernard Urban.) - -2000-06-06 Mikael Djurfeldt - - * modules.c (scm_system_module_env_p): Fixed detection of system - modules. - -2000-06-06 Marius Vollmer - - * scmsigs.c (scm_sigaction): Silently ignore setting handlers for - `program error signals' because they can't currently be handled by - Scheme code. - -2000-06-05 Dirk Herrmann - - * procs.h (SCM_SET_SUBRF): Added. - - * procs.c (scm_make_subr_opt): Don't assign to SCM_SUBRF, use - SCM_SET_SUBRF instead. Thanks to Bernard Urban for the bug - report. - -2000-06-05 Dirk Herrmann - - * gc.h (SCM_CARLOC, SCM_CDRLOC): Don't take the address of a SCM - value. - - * sort.c (scm_sorted_p, scm_merge, scm_merge_list_x, - scm_merge_list_step): Don't take the address of SCM_CAR. Use - SCM_CARLOC instead. Thanks to Bernard Urban for the bug report. - -2000-06-05 Dirk Herrmann - - * boolean.h (SCM_TRUE_P): Removed, as people might use it as a - replacement for !SCM_FALSEP. - - * backtrace.c (display_error_body), boolean.h (SCM_BOOLP), gc.c - (scm_unhash_name), gh_data.c (gh_module_lookup), load.c - (scm_primitive_load), print.c (scm_simple_format), procs.c - (scm_procedure_documentation), procs.h (SCM_TOP_LEVEL), ramap.c - (scm_array_fill_int), scmsigs.c (scm_sigaction), stacks.c - (narrow_stack, scm_make_stack, scm_stack_id), symbols.c - (scm_string_to_obarray_symbol), throw.c (scm_catch, - scm_lazy_catch, scm_ithrow), unif.c (scm_make_uve, scm_array_p, - scm_array_set_x, scm_bit_set_star_x, scm_bit_count_star), - validate.h (SCM_VALIDATE_BOOL_COPY, SCM_VALIDATE_PROC): Replace - uses of SCM_TRUE_P (x) with SCM_EQ_P (x, SCM_BOOL_T). - -2000-06-04 Mikael Djurfeldt - - * eval.c (scm_badformalsp): New static function. - (SCM_CEVAL): Check arguments for procedure-with-setter closures. - (Thanks to Keisuke Nishida.) - - The major reason for Guile's slow loading speed has been the fact - that a chain of Scheme level procedures has been evaluated for - every top-level symbol lookup during the first pass through the - code. - - The following is a kludge which I suggested four years ago, and - which I've repeatedly suggested since. Personally, I've never - been bothered by Guile's slow loading speed, so I thought I would - let someone else do it... - - But since the new environments will be included first in - Guile-1.5, I thought it would make people happy to get the kludge - into 1.4. - - * modules.c: Added #include "libguile/vectors.h"; - Added #include "libguile/hashtab.h"; - Added #include "libguile/struct.h"; - Added #include "libguile/variable.h"; - Capture Scheme level `module-make-local-var!' to be used in the - standard eval closure. - (scm_standard_eval_closure): New primitive. - - * modules.h (scm_standard_eval_closure): Declare. - - * eval.c (scm_lookupcar): Test for !SCM_CONSP (SCM_CAR (env)) - instead of SCM_TRUE (scm_procedurep (SCM_CAR (env))). - - * symbols.c (scm_sym2vcell): Bypass dispatch in the evaluator for - standard eval closures. - - * variable.c: Code layout fixes. - -2000-06-03 Mikael Djurfeldt - - * Makefile.am: Added LIBS line to libpath which accidentally - disappeared in the change of 2000-06-01. - (Thanks to Dale P. Smith.) - -2000-06-03 Mikael Djurfeldt - - * scmsigs.c (scm_segfault): Removed. (Was probably added by - mistake since it is not mentioned in ChangeLog.) - - * gc.h (SCM_VALIDATE_CELL): Cast result to (void) in order to - avoid compiler warnings in gcc. (Does this work for other - compilers?) - -2000-06-03 Mikael Djurfeldt - - * gc.h (SCM_VALIDATE_CELL): Don't "use" the value returned by - abort (). - (SCM_CARLOC, SCM_CDRLOC): Define directly instead of using - SCM_CELL_OBJECT_0 and SCM_CELL_OBJECT_1. It's not correct to take - the address of these expressions since they use SCM_VALIDATE_CELL. - (Thanks to Bernard Urban.) - - * dynl.c: Changed #include --> #include - "libltdl/ltdl.h". (Thanks to Bill Schottstaedt.) - -2000-06-01 Craig Brozefsky - - * Makefile.am: libguile_la_LDFLAGS gets -version-info args - from GUILE-VERSION definition of LIBGUILE version. Added to - libpath.h definitions for guileversion and libguileversion which - both get their values from GUILE-VERSION definition. - -2000-05-30 Dirk Herrmann - - * numbers.h (SCM_BIGP): Don't use SCM_SMOB_PREDICATE in header - file: Code using numbers should not be required to include - smob.h. - -2000-05-30 Dirk Herrmann - - * coop-threads.c.cygnus, coop-threads.h.cygnus, fsu-pthreads.h, - mit-pthreads.c, mit-pthreads.h: Deleted. - - * Makefile.am (EXTRA_DIST), scmsigs.c, threads.[ch]: Drop - references to deleted files and fsu/mit thread support in - general. - -2000-05-29 Dirk Herrmann - - * hooks.c (symbol_name, scm_create_hook): Restored the original - behaviour of scm_create_hook. Changing it was bad as Carl - R. Witty has pointed out. - - * gc.c (scm_init_gc): We can still rely on scm_create_hook to - protect the object. - -2000-05-26 Dirk Herrmann - - * gc.c (scm_init_gc): Protect scm_after_gc_hook, since this will - soon not be done by scm_create_hook any longer. - - * hooks.c (make_hook, print_hook, scm_create_hook, - scm_make_hook_with_name, scm_make_hook), hooks.h (SCM_HOOK_NAME, - SCM_HOOK_PROCEDURES, SCM_SET_HOOK_PROCEDURES, - scm_make_hook_with_name), init.c (scm_boot_guile_1): Hooks no - longer have names. As an intermediate solution, the name - predicate is emulated via object properties, but use of this - feature is deprecated. - - * hooks.h (scm_free_hook): Removed, as it is never defined. - -2000-05-25 Dirk Herrmann - - * numbers.[ch] (SCM_POSFIXABLE, SCM_NEGFIXABLE, SCM_FIXABLE): - Un-deprecated since otherwise user code can't determine whether a - number fits into an inum any longer. The names should be changed - some time, though. - - * numbers.c (scm_big2inum): Eliminated use of SCM_UNEGFIXABLE. - - * tags.h (SCM_UNPACK_CAR): Deprecated. - -2000-05-25 Dirk Herrmann - - * filesys.h (SCM_OPDIRP), fluids.h (SCM_FLUIDP, SCM_FLUID_NUM), - fports.h (SCM_OPFPORTP, SCM_OPINFPORTP, SCM_OPOUTFPORTP), hooks.h - (SCM_HOOK_ARITY), keywords.h (SCM_KEYWORDP, SCM_KEYWORDSYM), - numbers.h (SCM_NUMP, SCM_BIGSIGN, SCM_BDIGITS, SCM_NUMDIGS): - Replace SCM_UNPACK_CAR appropriately. Don't access cells via - SCM_{SET}?C[AD]R unless they are known to be cons cells. - - * gc.c (scm_heap_seg_data_t, scm_mark_locations, scm_cellp, - init_heap_seg): Remove unused struct member variable 'valid'. - -2000-05-24 Dirk Herrmann - - * fports.c (fport_write), ports.c (scm_markstream, scm_port_mode, - scm_print_port_mode), ports.h (SCM_OPPORTP, SCM_OPINPORTP, - SCM_OPOUTPORTP, SCM_INPUT_PORT_P, SCM_OUTPUT_PORT_P, SCM_OPENP), - procs.h (SCM_CLOSCAR), unif.h (SCM_ARRAY_NDIM, SCM_ARRAY_CONTP), - variable.h (SCM_VARIABLEP): Replace SCM_UNPACK_CAR - appropriately. - -2000-05-23 Dirk Herrmann - - * gc.c (free_list_length), hash.c (scm_hasher), macros.c - (scm_macro_type), objects.c (scm_class_of), options.c - (scm_options), print.c (scm_iprin1), strports.c (st_seek), throw.c - (SCM_LAZY_CATCH_P): Replace SCM_UNPACK_CAR appropriately. - -2000-05-23 Dirk Herrmann - - * eval.c (scm_macroexp, SCM_CEVAL, scm_force), tags.h: Replace - SCM_UNPACK_CAR with SCM_CELL_TYPE or SCM_CELL_WORD_0. - - * eval.c (scm_force): Add documentation. - - * eval.c (scm_force, scm_cons_source): Don't access cells via - SCM_{SET}?C[AD]R unless they are known to be cons cells. - -2000-05-23 Dirk Herrmann - - * strings.h (SCM_NSTRINGP, SCM_NRWSTRINGP), tags.h - (SCM_NDOUBLE_CELLP), vectors.h (SCM_NVECTORP): Deprecated. - - * gc.c (scm_igc), gc.h (SCM_PTR_MASK, SCM_PTR_LT): Removed #ifdef - nosve #endif conditionally compiled code. - -2000-05-23 Michael Livshin - - * gc.c (scm_heap_seg_data_t): fixed comment for the `span' member. - -2000-05-22 Michael Livshin - - * guile-doc-snarf.in: put the preprocessed file through sed to - trim all lines to 1024 chars. I hope it doesn't break anybody's - sed. we'll see. (note: this is lossy trimming, i.e. the spill - isn't wrapped around but actually chopped off. this seemed to me - safe because the current snarfer doesn't understand multi-line - cookies anyway. in the long term, it would be nice not to depend - on AWK for anything.) - - * gc.h (SCM_[SET_]CELL_{WORD,OBJECT}, SCM_VALIDATE_CELL): reverted - the previous change to this macros, after deciding to torture the - snarfer instead. - -2000-05-21 Michael Livshin - - * gc.h (SCM_[SET_]CELL_{WORD,OBJECT}, SCM_VALIDATE_CELL): brought - the yucky, ugly and nasty conditional compilation back. sorry, - but it was either that or requiring GAWK to build Guile. - (lots of places): removed the code that implemented the old GC - scheme. - - * init.c (scm_boot_guile_1): removed the code conditioned on - !GUILE_NEW_GC_SCHEME. - - * __scm.h: (GUILE_NEW_GC_SCHEME): removed. - - * gc.c (scm_protect_object, scm_unprotect_object): change the - implementation to more efficient (at least in the time complexity - sense). the calls should now also be thread-safe -- I suspect - that people expect them to be. (thanks to Han-Wen Nienhuys) - (lots of places): removed the code that implemented the old GC - scheme. - - * hashtab.c (scm_hash_fn_create_handle_x): add missing - SCM_REALLOW_INTS before return. I really wonder about the - possible interactions between hashtables, threads & GC. it - doesn't look healthy at all. - -2000-05-20 Dirk Herrmann - - * unif.c (scm_bit_count): Fixed the parameter checks. Thanks to - Dale P. Smith. - -2000-05-19 Dirk Herrmann - - * __scm.h (SCM_DEBUG_CELL_ACCESSES), gc.h (SCM_): Added as a new - debug option to verify all accesses to cells actually access - objects on the heap. - - * gc.h (SCM_VALIDATE_CELL): Added. Only performs validation if - SCM_DEBUG_CELL_ACCESSES is set to 1. - - (SCM_CELL_WORD, SCM_CELL_OBJECT, SCM_SET_CELL_WORD, - SCM_SET_CELL_OBJECT): Use SCM_VALIDATE_CELL to check every cell - that is accessed. - -2000-05-19 Dirk Herrmann - - * gh_data.c (gh_scm2chars, gh_scm2shorts, gh_scm2longs, - gh_scm2floats, gh_scm2doubles): Change !SCM_NIMP to SCM_IMP. - - * gc.c (scm_cellp): Fixed and simplified. - - * throw.c (JBJMPBUF, SETJBJMPBUF, SCM_JBDFRAME, SCM_SETJBDFRAME, - make_jmpbuf, scm_init_throw): Now using double cells to represent - jump buffers when using debug extensions. - - (freejb): Removed. - -2000-05-18 Dirk Herrmann - - * gh.h gh_data.c gh_funcs.c (gh_new_procedure*, gh_chars2byvect, - gh_shorts2svect, gh_longs2ivect, gh_ulongs2uvect, gh_floats2fvect, - gh_doubles2dvect, gh_doubles2scm, gh_define, gh_lookup, - gh_module_lookup): Accept const pointers as parameters. - - * gh.h gh_data.c (gh_int2scmb): Deprecated. - -2000-05-18 Dirk Herrmann - - * __scm.h (SCM_DEBUG_REST_ARGUMENT): Renamed from - SCM_DEBUG_REST_ARGUMENTS in order to clarify that we don't test - the actual arguments in the list, but rather the rest argument as - a list of arguments. - - * validate.h (SCM_VALIDATE_REST_ARGUMENT): Added. - - * async.c (scm_noop), eval.c (scm_map, scm_for_each), list.c - (scm_list_star, scm_append, scm_append_x), ports.c - (scm_close_all_ports_except), ramap.c (scm_array_map_x, - scm_array_for_each), regex-posix.c (scm_make_regexp), stacks.c - (scm_make_stack), strings.c (scm_string_append), struct.c - (scm_make_struct, scm_make_vtable_vtable): Validate rest arguments. - - * dynl.c (DYNL_GLOBAL, sysdep_dynl_link, kw_global, sym_global, - scm_dynamic_link, scm_init_dynamic_linking), dynl.h - (scm_dynamic_link): Removed possibility to pass flags to - scm_dynamic_link, as it had no effect anyway. - - * filesys.c (scm_fcntl): Made single optional rest argument into - a standard optional argument. - - * hooks.c (scm_run_hook): A list of rest arguments is never - SCM_UNBNDP. - - * list.c (scm_append, scm_append_x), stacks.c (scm_make_stack), - strings.c (scm_string_append): Don't perform half-hearted checks - to see whether the rest argument forms a proper list any more, use - SCM_VALIDATE_REST_ARGUMENTS instead. - - * ports.c (scm_close_all_ports_except): Accept empty list of rest - arguments. - - * posix.c (scm_convert_exec_args), print.c (scm_simple_format): - Simplify verification of rest argument. - - * stacks.c (scm_make_stack), stacks.h (scm_make_stack), throw.c - (ss_handler, handler_message): Make first mandatory rest argument - of scm_make_stack into a standard mandatory argument. - - * unif.c (scm_transpose_array, scm_enclose_array, - scm_array_in_bounds_p), unif.h (scm_transpose_array, - scm_enclose_array, scm_array_in_bounds_p): Make first mandatory - rest argument into a standard mandatory argument. - -2000-05-17 Dirk Herrmann - - * __scm.h: Added SCM_DEBUG as default debug option. (Thanks to - Keisuke Nishida for the suggestion.) Added debug option - SCM_DEBUG_REST_ARGUMENTS. - - * eval.c (scm_map, scm_for_each): Make sure all lists have the - same length. Also, removed redundant parameter checks. - -2000-05-16 Dirk Herrmann - - * Makefile.am: Let 'make clean' remove *.x and *.doc files. - - * __scm.h: Improved explanation of giving options to make. - - * __scm.h (SCM_DEBUG_TYPING_STRICTNESS), tags.h - (SCM_STRICT_TYPING, SCM_DEBUG_TYPING_STRICTNESS): Renamed - SCM_STRICT_TYPING to SCM_DEBUG_TYPING_STRICTNESS and moved the - corresponding declaration and comment to __scm.h. - - * _scm.h (errno), gc.h (SCM_CELLPTR, SCM_PTR_LT), numbers.c - (scm_remainder, scm_modulo), numbers.h (SCM_SRS, SCM_MAKINUM, - SCM_INUM): Removed conditionally compiled code for Turbo C. - - * gdbint.c (gdb_maybe_valid_type_p): Eliminated call to scm_tag. - That check can be assumed to be redundant except for very rare - conditions that actually indicate broken heap data. - -2000-05-16 Dirk Herrmann - - * numbers.c (scm_logcount, scm_integer_length): Reordered - dispatch sequence. - -2000-05-15 Gary Houston - - * stime.c (scm_strftime): don't reset TZ if zone is an empty - string. append a "0" to the zone for TZ. - -2000-05-15 Dirk Herrmann - - * numbers.c (scm_logbit_p, scm_bit_extract): Reordered dispatch - sequence. - - (scm_bit_extract): Fixed handling of bignums. - -2000-05-15 Dirk Herrmann - - * async.c (scm_sys_gc_async_thunk), chars.h (SCM_ICHRP, SCM_ICHR, - SCM_MAKICHR), continuations.h (SCM_SETJMPBUF), error.c - (scm_sysmissing), error.h (scm_sysmissing), evalext.c - ('serial-map), ioext.c (scm_fseek), ioext.h (scm_fseek), - keywords.c (scm_tc16_kw, scm_init_keywords), ports.h (SCM_CRDY, - SCM_INPORTP, SCM_OUTPORTP), ramap.c ('serial-array-copy!, - 'serial-array-map!), smob.c (scm_newsmob), smob.h (scm_smobfuns, - scm_newsmob), tag.c (scm_tag), tag.h (scm_tag), tags.h - (scm_tc16_flo, scm_tc_flo, scm_tc_dblr, scm_tc_dblc): Wrapped - deprecated code between #if (SCM_DEBUG_DEPRECATED == 0) #endif. - - * fports.c (scm_fport_buffer_add), ports.c (scm_input_port_p, - scm_output_port_p), print.c (scm_get_print_state), validate.h - (SCM_VALIDATE_CHAR): Replace use of deprecated macros - SCM_INPORTP, SCM_OUTPORTP, SCM_ICHRP by SCM_INPUT_PORT_P, - SCM_OUTPUT_PORT_P, SCM_CHARP, respectively. - -2000-05-14 Gary Houston - - * stime.c (scm_strftime): if HAVE_TM_ZONE is not defined, hack the - TZ environment variable so that the %Z format returns the zone - from the input vector instead of the system default. - - from Keisuke Nishida: - * fports.c (scm_setvbuf): minor docstring fix. - * ports.h (scm_generic_fgets): obsolete prototype deleted. - -2000-05-11 Dirk Herrmann - - * __scm.h: Added new section for debugging options. - - (SCM_DEBUG_DEPRECATED): If 1, no deprecated code is included to - help developers to get rid of references to deprecated code. - - * numbers.[ch] (SCM_POSFIXABLE, SCM_NEGFIXABLE, SCM_UNEGFIXABLE, - SCM_FIXABLE, SCM_FLOBUFLEN): These macros are no longer provided - as part of the interface and are marked as deprecated in the - header file. - - * numbers.c (scm_make_real, scm_make_complex): Inlined the - corresponding macros SCM_NEWREAL and SCM_NEWCOMPLEX, - respectively. - - * numbers.h (SCM_NEWREAL, SCM_NEWCOMPLEX, SCM_INEXP, SCM_CPLXP, - SCM_REAL, SCM_IMAG, SCM_REALPART, scm_makdbl, SCM_SINGP, - SCM_NO_BIGDIG, SCM_NUM2DBL, scm_dblproc): Deprecated. - -2000-05-10 Dirk Herrmann - - * gc.h (scm_cell, SCM_CELL_WORD, SCM_CELL_OBJECT, - SCM_SET_CELL_WORD, SCM_SET_CELL_OBJECT): Scheme cells now consist - of two scm_bits_t values instead of two SCM values, because it is - legal for cell entries to hold values that are not scheme objects. - - (SCM_SETAND_CAR, SCM_SETAND_CDR, SCM_SETOR_CAR, SCM_SETOR_CDR): - Use SCM_SETC[AD]R to modify contents of pairs. - -2000-05-10 Dirk Herrmann - - * numbers.c (IS_INF, isfinite): Added FIXME comment. - - (scm_abs, scm_magnitude): Make these two independent of each - other. scm_abs now reports an error if given a complex argument. - - (scm_istr2flo, scm_integer_p). Use SCM_REAL_VALUE instead of - SCM_REALPART if the object is known to be real. - - (scm_init_numbers): No need to use SCM_NEWREAL macro for speed - here. - - * numbers.h (SCM_SINGP): Set to 0 instead of SCM_BOOL_F. - -2000-05-10 Dirk Herrmann - - * eq.c (scm_eqv_p): Separate handling of real and complex - values. Remove #ifdef SCM_BIGDIG #endif test. - - * eval.c (SCM_CEVAL, SCM_APPLY), gh_data.c (gh_scm2floats, - gh_scm2doubles), hash.c (scm_hasher), ramap.c (scm_array_fill_int, - ramap_rp, scm_array_map_x), random.c (vector_scale, - vector_sum_squares), unif.c (scm_make_uve, scm_array_p, - scm_array_set_x): Use SCM_REAL_VALUE instead of SCM_REALPART if - the object is known to be real. Use SCM_COMPLEXP instead of - deprecated SCM_CPLXP. Use SCM_INEXACTP instead of deprecated - SCM_INEXP. - -2000-05-10 Dirk Herrmann - - * numbers.c: No need to include unif.h. - - (IS_INF): Returned to old test for now: x == x + 1 will not work - for large numbers due to rounding errors. - Thanks to Kalle Olavi Niemitalo. - -2000-05-09 Dirk Herrmann - - * numbers.c (scm_divbigdig): Removed outdated comment. - - (scm_number_to_string, scm_string_to_number, scm_number_p, - scm_real_p, scm_integer_p, scm_inexact_p, scm_gr_p, scm_leq_p, - scm_geq_p, scm_make_rectangular, scm_make_polar, - scm_inexact_to_exact): Added comments. - - (add1, scm_init_numbers): Removed add1. - -2000-05-09 Dirk Herrmann - - * numbers.c (IS_INF): The new test is x == x + 1. The old test - x == x/2 did not work for zero values. Thanks to Han-Wen Nienhuys - and Ivan Toshkov. - - (scm_number_to_string, scm_sum, scm_difference, scm_two_doubles, - scm_num2long, scm_num2long_long, scm_num2ulong): Reordered - dispatch sequence. - -2000-05-09 Marius Vollmer - - * scmsigs.c (take_signal): Execute SCM_ASYNC_TICK for SIGSEGV, - SIGILL and SIGBUS signals. These signals are not continuable and - must be handled for real right away. - -2000-05-08 Dirk Herrmann - - * numbers.c (scm_zero_p, scm_positive_p, scm_negative_p, - scm_real_part, scm_imag_part, scm_magnitude, - scm_inexact_to_exact): Reordered dispatch sequence. - -2000-05-08 Dirk Herrmann - - * feature.c: No need to include "libguile/smob.h" - - (scm_loc_features, features, scm_add_feature, scm_init_feature): - Removed variable 'scm_loc_features' as a pointer to the SCM value - holding the features list. Using variable 'features' instead, - which holds the interned pair. Thus, SCM_SETCDR can be used - instead of pointer trickery. - -2000-05-08 Dirk Herrmann - - * alist.c (scm_acons): Use SCM{_SET}?_CELL_OBJECT as long as a - cell is not known to be a valid pair. - -2000-05-08 Dirk Herrmann - - * eval.c (ASRTSYNTAX, scm_m_body, scm_m_letrec1): Removed - ASRTSYNTAX. Using SCM_ASSYNT instead. - - (scm_m_body): Don't create a redundant cons cell. - - (scm_m_do): Removed redundant test 'bodycheck'. - - (bodycheck): Removed. - - * stacks.c (stack_depth, read_frame, read_frames): Removed - redundant calculation of size, minimized some variable scopes. - -2000-05-05 Dirk Herrmann - - * pairs.c (scm_cons, scm_cons2): Use SCM{_SET}?_CELL_OBJECT as - long as a cell is not known to be a valid pair. - - (scm_pair_p): Eliminated redundant SCM_IMP test. - -2000-05-05 Dirk Herrmann - - * eval.c (scm_m_body, scm_macroexp, unmemocopy, scm_eval_args, - scm_deval_args): Eliminated redundant SCM_IMP tests. - - * hashtab.c (scm_ihashx, scm_sloppy_assx, scm_delx_x), weaks.c - (scm_make_weak_key_hash_table, scm_make_weak_value_hash_table, - scm_make_doubly_weak_hash_table): Fixed critical sections. - Thanks to Keisuke Nishida. - -2000-05-05 Dirk Herrmann - - * numbers.c (scm_logand, scm_logior, scm_logxor, scm_logtest): - Fixed some goto-related initialization bugs (introduced by me). - -2000-05-04 Dirk Herrmann - - * numbers.h (SCM_INUM0): Uses SCM_MAKINUM instead of SCM_PACK. - - * dynl.c (dynl_obj, DYNL_OBJ, get_dynl_obj): Removed. - - (DYNL_FILENAME, DYNL_HANDLE): Use SCM_CELL... macros instead of - pointer trickery. - - (SET_DYNL_HANDLE): Added. - - (scm_dynamic_object_p): Simplified. - - (scm_dynamic_unlink, scm_dynamic_func): Changed comment. Deliver - better error message when accessing unlinked dynamic objects. - Eliminated call to get_dynl_obj. - -2000-05-03 Marius Vollmer - - * scmsigs.c (orig_handlers) [!HAVE_SIGACTION]: Fix declaration to - be an array of function pointers instead of being a pointer to an - array returning function. Thanks to Kalle Olavi Niemitalo! - -2000-05-03 Dirk Herrmann - - * numbers.c (scm_divbigbig, scm_divbigint), numbers.h - (scm_divbigbig, scm_divbigint): Don't return zero any more to - indicate that a division has a remainder, return SCM_UNDEFINED - instead. It is improbable that anyone actually used these - functions outside of numbers.c. For this reason and due to the - change in behaviour the functions are static now. Thus, if - surprisingly there are users of these functions they will at least - get alarmed. - - * numbers.c: Removed #ifdef SCM_BIGDIG #endif in those functions, - that already have a clean dispatch order. Note: SCM_BIGDIG is - always defined. - - * numbers.c (scm_inexact_p): Simplified. - - * numbers.c (scm_num_eq_p, scm_less_p, scm_max, scm_min, - scm_product, scm_num2dbl, scm_angle): Reordered dispatch - sequence, thereby fixing some comparisons of SCM values with - integer constants. - - * numbers.c (scm_divide): Division by zero of inums leads to an - error now. (Formerly, an infinite number was returned.) - - Respect the fact, that scm_divbigbig does now return SCM_UNDEFINED - if a division has a remainder. - -2000-05-02 Gary Houston - - * Makefile.am (INCLUDES): add ${INCLTDL} (thanks to Tim Mooney). - -2000-05-02 Dirk Herrmann - - * numbers.c (scm_logtest, scm_division): Reordered dispatch - sequence, thereby fixing some comparisons of SCM values with - integer constants. - - * numbers.h (scm_makdbl): Mark as deprecated at the point of - declaration. - - * eval.c (SCM_CEVAL, SCM_APPLY), gh_data.c (gh_double2scm, - gh_doubles2scm), numbers.c (scm_istr2flo, scm_max, scm_min, - scm_sum, scm_difference, scm_product, scm_divide, scm_sys_expt, - scm_sys_atan2, scm_make_rectangular, scm_make_polar, - scm_real_part, scm_imag_part, scm_magnitude, scm_angle, - scm_long2num, scm_long_long2num, scm_ulong2num), ramap.c - (ramap_rp, scm_array_map_x), random.c (scm_random, - scm_random_uniform, scm_random_normal_vector_x, scm_random_exp), - struct.c (scm_struct_ref), unif.c (scm_array_to_list): Replace - call to scm_makdbl with a call to scm_make_real or - scm_make_complex, depending on whether the imaginary part is known - to be zero. - -2000-05-01 Gary Houston - - * scmsigs.c: fix the definition of orig_handlers for the case - that HAVE_SIGACTION is not defined (thanks to - Kalle Olavi Niemitalo). - - * Makefile.am: remove include_HEADERS (was libguile.h) - libguile.h: moved to top level directory. - -2000-04-28 Dirk Herrmann - - * numbers.c (SCM_SWAP): Moved to the top of the file to allow for - a wider use. - - * numbers.c (scm_modulo, scm_gcd, scm_lcm, scm_logand, scm_logior, - scm_logxor): Reordered dispatch sequence, thereby fixing some - comparisons of SCM values with integer constants. - - * number.c (scm_logtest): Removed some redundant SCM_{N}?IMP - tests. - -2000-04-28 Dirk Herrmann - - * numbers.c (scm_quotient, scm_remainder): Removed code that was - conditionally compiled based on BADIVSGNS. BADIVSGNS does not - occur anywhere else throughout guile. - - * numbers.c (scm_quotient): Fixed parameter number in error - message. - - * numbers.c (scm_remainder): Reordered dispatch sequence. - -2000-04-25 Gary Houston - - * posix.c (scm_execlp): docstring fix (thanks to Martin - Grabmueller). - -2000-04-25 Dirk Herrmann - - * eval.c (undef_object): Made into a local static variable - (suggested by Jost Boekemeier). - -2000-04-25 Dirk Herrmann - - * pairs.c (cxrs, scm_init_pairs): Simplify initialization of - c[ad]+r functions. - - * procs.c (scm_init_iprocs), procs.h (scm_subr, scm_iproc, - scm_dsubr, scm_init_iprocs): Removed. - - * procs.h (SCM_SUBRF, SCM_DSUBRF): Access the cell words - directly instead of casting a cell to a C struct. - -2000-04-22 Mikael Djurfeldt - - Better modularization of GC extensions through new C level GC - hooks: - - * weaks.c (scm_weaks_prehistory): New function: Add - scm_weak_vector_gc_init to scm_before_mark_c_hook; Add - scm_mark_weak_vector_spines to scm_before_sweep_c_hook. - (scm_scan_weak_vectors): New function; added to - scm_after_sweep_c_hook. - - * weaks.h (scm_weak_vectors, scm_weaks_prehistory): Added - declarations. - - * guardians.h (scm_guardian_gc_init, scm_guardian_zombify): Are - now static. - - * guardians.c (scm_guardian_gc_init): Turned into a hook function - and added to scm_before_mark_c_hook. - (scm_guardian_zombify): Turned into a hook function and added to - scm_before_sweep_c_hook. - - * async.c (scm_sys_gc_async_thunk): Run after-gc-hook. - Added #include "libguile/gc.h". - - * gc.h: Added #include "libguile/hooks.h". - - * gc.c: Removed #include "libguile/guardians.h". - (scm_before_gc_c_hook, scm_before_mark_c_hook, - scm_before_sweep_c_hook, scm_after_sweep_c_hook, - scm_after_gc_c_hook): New C level hooks. - (scm_after_gc_hook): New Scheme level hook. - (scm_gc_sweep): Moved scanning of weak vectors to weaks.c. - (scm_igc): Moved initialization of scm_weak_vectors and the call - to scm_guardian_gc_init to respective module. - (scm_mark_weak_vector_spines): Moved to weaks.c; - Call to scm_guardian_zombify moved to guardians.c; - Run scm_before_gc_c_hook, scm_before_sweep_c_hook, - scm_after_gc_c_hook at appropriate places. - (scm_init_gc): Initialize scm_after_gc_hook. - - * hooks.c, hooks.h (scm_make_hook_with_name): Removed deprecated - function. - - * init.c (scm_boot_guile_1): Added `scm_init_hooks'. - - * Makefile.am: Added hooks.c, hooks.h, hooks.x. - - * feature.c, feature.h: Broke out hook code into separate files. - - * hooks.c, hooks.h: New files. - - * *.*: Change includes so that they always use the "prefixes" - libguile/, qt/, guile-readline/, or libltdl/. - (Thanks to Tim Mooney.) - - * Makefile.am (INCLUDES): Removed THREAD_CPPFLAGS and INCLTDL. - (DEFS): Added. automake adds -I options to DEFS, and we don't - want that. - Removed all -I options except for the root source directory and - the root build directory. - - * numbers.c (scm_odd_p, scm_even_p): Use SCM_WRONG_TYPE_ARG - instead of SCM_ASSERT (0, ...). (Some compilers will complain - about control reaching end of function otherwise, and, besides, - the new code is not less clear.) - - * gc.c (scm_must_malloc, scm_must_realloc, scm_must_free): Added - calls to malloc debugging functions. - - * init.c (scm_boot_guile_1): Added calls to debug-malloc init - functions. - - * Makefile.am: Added debug-malloc.c, debug-malloc.h, - debug-malloc.x. - - * debug-malloc.c, debug-malloc.h: New files. - -2000-04-20 Dirk Herrmann - - * numbers.c (scm_exact_p, scm_odd_p, scm_even_p): Added - documentation strings. - - * numbers.c (scm_exact_p, scm_odd_p, scm_even_p, scm_abs, - scm_quotient): Reordered dispatch sequence to first handle - immediates, second handle bignums and finally handle generic - functions respectively signal wrong type arguments. Hopefully - this will allow for easier separation when goops is integrated. - -2000-04-19 Dirk Herrmann - - * gc.c (which_seg): Use SCM2PTR to convert a non immediate SCM - variable into a pointer to a heap cell. - - * gc.c (scm_mark_locations, scm_cellp, init_heap_seg, - scm_unhash_name): Remove redundant cast to SCM_CELLPTR. - -2000-04-19 Dirk Herrmann - - * print.c (scm_iprin1): Don't assign zero to SCM values, use - SCM_UNDEFINED instead. - - * weaks.c (scm_make_weak_vector): Fix assignment of zero to a - vector element. (Still to be improved) - -2000-04-19 Dirk Herrmann - - * eval.c (undef_cell): Removed, replaced by: - - (undef_object): Added to replace undef_cell. - - (scm_lookupcar, scm_lookupcar1): Use undef_object. - - * eval.c (scm_lookupcar, scm_lookupcar1, scm_m_atfop, - scm_m_atbind, CHECK_EQVISH, SCM_CEVAL), procs.h (SCM_SETCODE): - Don't perform arithmetic operations with SCM values. - - * eval.c (scm_lookupcar, scm_lookupcar1, scm_m_atfop, - scm_m_atbind, scm_eval_args, scm_deval_args, SCM_CEVAL): Use - symbolic names for the tc3 type codes. - - * eval.c (scm_m_define, SCM_CEVAL, SCM_APPLY): Remove redundant - cast to SCM. - - * eval.c (scm_eval_args, scm_deval_args, SCM_CEVAL): Made the - access of the struct vcell element explicit. - -2000-04-19 Mikael Djurfeldt - - * struct.c (scm_struct_free_light, scm_struct_free_standard, - scm_struct_free_entity): Use `scm_must_free' instead of `free'. - - * procs.c (scm_make_subr_opt): Tell scm_must_realloc that we're - realloc:ing scm_subr_table ("what" instead of "who"). - - * numbers.c (scm_adjbig): Ditto. - -Tue Apr 18 08:22:41 2000 Greg J. Badros - - * validate.h: Do not cast to (unsigned) in SCM_VALIDATE_INUM_RANGE - when testing high-end of the range. Mikael Djurfeldt noticed this - anomaly -- thanks Mikael! - -2000-04-18 Dirk Herrmann - - * unif.c (l2ra): Don't eliminate the call to scm_array_set_x - itself, as was done in the previous 'patch'. (Thanks to Radey - Shouman) - -2000-04-18 Dirk Herrmann - - * options.c (scm_options), read.c (recsexpr): Remove redundant - SCM_IMP test. - - * print.c (scm_iprin1): Made the access of the struct vcell - element explicit. - - * print.h (SCM_PRINT_CLOSURE): Added call to SCM_PACK. - - * ramap.c (scm_ra_eqp, ra_compare), unif.c - (scm_uniform_vector_ref, scm_cvref, rapr1): Separated accesses to - unsigned long and signed long arrays and clarified the way the - access is performed. - - * ramap.c (scm_array_map_x, raeql), read.c (scm_lreadr), stacks.c - (narrow_stack), unif.c (scm_cvref, scm_uniform_array_read_x, - scm_raprin1): Use SCM_EQ_P to compare SCM values. - - * strings.c (scm_makstr): Treat the msymbol slots as a field of - scm_bits_t values. - - * struct.h (SCM_SET_VTABLE_DESTRUCTOR): Treat the struct data as - a field of scm_bits_t values. - - * unif.c (l2ra): Don't test result of scm_array_set_x against - zero: It is always SCM_UNSPECIFIED. - -2000-04-18 Mikael Djurfeldt - - * script.c (scm_compile_shell_switches): Also enable - record-positions when given the --debug option. (Thanks to Diego - Dainese.) - -2000-04-18 Dirk Herrmann - - * print.c (ENTER_NESTED_DATA, print_circref, scm_iprlist): - Compare SCM's with SCM_EQ_P. - - * print.c (scm_make_print_state), srcprop.c - (scm_source_properties): Use valid scheme object to initialize - SCM variable. - - * print.c (scm_iprin1): Remove redundant calls to SCM_UNPACK. - -2000-04-17 Dirk Herrmann - - * struct.c (scm_alloc_struct, scm_struct_free_0, - scm_struct_free_light, scm_struct_free_standard, - scm_struct_free_entity, scm_make_struct, scm_make_vtable_vtable), - struct.h (scm_struct_free_t, scm_alloc_struct, scm_struct_free_0, - scm_struct_free_light, scm_struct_free_standard, - scm_struct_free_entity): Struct data regions (and thus also - vtable data regions) are now C arrays of scm_bits_t elements. - - * gc.c (scm_gc_mark, scm_gc_sweep, scm_unhash_name): Made the - mixup of glocs and structs explicit. - - * gc.c (scm_unprotect_object): Compare SCM's with SCM_EQ_P. - -2000-04-17 Dirk Herrmann - - * eval.c (scm_unmemocar): Use macros to test for gloc cell. - Minimize scope of variable 'ir'. - - * eval.h (SCM_IFRAME, SCM_IDIST), weaks.h (SCM_IS_WHVEC_ANY): - Added missing call to SCM_UNPACK. - -2000-04-17 Mikael Djurfeldt - - * validate.h (SCM_VALIDATE_INUM_RANGE_COPY, - SCM_VALIDATE_NUMBER_COPY): New macros. - -2000-04-16 Mikael Djurfeldt - - * script.c (scm_compile_shell_switches): Added --debug option. - -2000-04-16 Mikael Djurfeldt - - * vectors.c (scm_vector_set_x): Return SCM_UNSPECIFIED (as - specified by R5RS). - -2000-04-15 Mikael Djurfeldt - - * ports.h (SCM_INPUT_PORT_P, SCM_OUTPUT_PORT_P): New macros. - (SCM_INPORTP, SCM_OUTPORTP): Marked as deprecated. - - * validate.h (SCM_VALIDATE_INPUT_PORT, SCM_VALIDATE_OUTPUT_PORT): - New macros. - Cleanup of code layout. - - * ports.c, ports.h (close-input-port, close-output-port): New R5RS - procedures. - -2000-04-13 Dirk Herrmann - - * continuations.c (scm_make_cont, scm_dynthrow): Completely - separated implementations for defined (CHEAP_CONTINUATIONS) and - !defined (CHEAP_CONTINUATIONS). Also, now using memcpy for stack - copying. - - * continuations.c (grow_stack): Renamed from grow_throw. - - * continuations.c (copy_stack_and_call): New static function. - - * continuations.c (scm_dynthrow): Simplified and made static. - - * continuations.h (scm_dynthrow): Made static. - -2000-04-13 Mikael Djurfeldt - - * unif.c, unif.h (shared-array-root, shared-array-offset, - shared-array-increments): New primitives. - -2000-04-12 Dirk Herrmann - - * gc.c (scm_gc_sweep): Simplify the computation of freed memory - size for msymbols. - - * symbols.h (SCM_SLOTS, SCM_SYMBOL_FUNC, SCM_SYMBOL_PROPS, - SCM_SYMBOL_HASH): The msymbol slots are now a field of scm_bits_t - values. - - * symbols.h (SCM_SET_SYMBOL_FUNC, SCM_SET_SYMBOL_PROPS): New - macros. - - symbols.c (scm_intern_obarray_soft, msymbolize, scm_symbol_fset_x, - scm_symbol_pset_x): Use them. - - * symbols.c (scm_symbol_hash): Unpack to access SCM raw data. - -2000-04-12 Dirk Herrmann - - * ports.c (scm_port_print): The port data is read as raw data. - - * ports.h (SCM_TC2PTOBNUM, SCM_PTOBNUM): Fix SCM/scm_bits_t - mismatch. - -2000-04-11 Dirk Herrmann - - * eval.c (SCM_CEVAL), objects.c (scm_mcache_lookup_cmethod, - scm_make_subclass_object), objects.h (SCM_CLASS_FLAGS, - SCM_ENTITY_PROCEDURE, SCM_ENTITY_SETTER), struct.c - (scm_struct_init, scm_struct_vtable_p, scm_make_struct, - scm_struct_ref, scm_struct_set_x), struct.h (SCM_STRUCT_DATA): - The struct data is now an array of scm_bits_t variables. - - * objects.h (SCM_SET_ENTITY_PROCEDURE): New macro. - - objects.c (scm_set_object_procedure_x): Use it. - - * struct.c (scm_struct_init): Unused variable 'data' removed. - - (scm_struct_vtable_p): Redundant SCM_IMP tests removed. - -2000-04-11 Dirk Herrmann - - * objects.h (SCM_OBJ_CLASS_FLAGS, SCM_OBJ_CLASS_REDEF), struct.h - (SCM_STRUCT_VTABLE_DATA, SCM_STRUCT_LAYOUT, SCM_STRUCT_VTABLE, - SCM_STRUCT_PRINTER): The struct vtable data is now an array of - scm_bits_t variables. - - * struct.h (SCM_SET_STRUCT_LAYOUT): New macro. - - struct.c (scm_make_vtable_vtable): Use it. - -2000-04-11 Dirk Herrmann - - * symbols.c (scm_sym2vcell, scm_sym2ovcell_soft, scm_sym2ovcell, - scm_intern_obarray_soft, scm_sysintern0, - scm_string_to_obarray_symbol, scm_intern_symbol, - scm_unintern_symbol, scm_symbol_binding, scm_symbol_interned_p, - scm_symbol_bound_p, scm_symbol_set_x): Don't use C operators to - compare SCM values. - -2000-04-11 Dirk Herrmann - - * numbers.c (scm_quotient, scm_modulo): Reordered to handle the - case of immediate numbers parameters first. Also, only use - decoded numbers for numerical comparison. - -2000-04-10 Mikael Djurfeldt - - * objects.h: Don't redeclare scm_call_generic_0 and - scm_apply_generic. (Thanks to Tal Tversky.) - -2000-04-10 Dirk Herrmann - - * hash.c (scm_hasher): Use symbolic names for the tc3 constants. - Unpack SCM value to use it as a switch parameter. Don't cast SCM - values to int values. - -2000-04-10 Mikael Djurfeldt - - * coop.c (mother): Handled EINTR (the wait has been interrupted by - a signal). - -2000-04-07 Dirk Herrmann - - * __scm.h (SCM_WTA_DISPATCH_[012n]): To test whether a SCM value - contains a raw zero value it has to be unpacked. - - * debug.c (with_traps_inner, scm_with_traps): Passing SCM values - via void * requires unpacking / packing. - - * stacks.h (SCM_STACKP): Remove unnecessary SCM_NIMP test and use - SCM_EQ_P to compare SCM values. - - * stacks.h (SCM_FRAME_VOID_P, SCM_FRAME_REAL_P, SCM_FRAME_PROC_P, - SCM_FRAME_EVAL_ARGS_P, SCM_FRAME_OVERFLOW_P): Remove unnecessary - call to SCM_UNPACK. - - * tags.h (SCM_NECONSP): Define in terms of SCM_ECONSP - - * tags.h (SCM_ECONSP): Clarify the test for glocs. This is still - quite ugly. - -2000-04-05 Michael Livshin - - * async.[ch]: unexpose low-level async access macros (thanks to - Dirk Herrmann). - - * validate.h: move async validation macros to async.c (nobody else - needs them anyway), and rename them. - -2000-04-04 Michael Livshin - - * async.h: kill the scm_async_t struct. having a heap cell - pretending to be a C struct is not helthy, and is not needed here - anyway, as asyncs happily fit in one heap cell. - - * async.c: reflect the fact that asyncs are now represented by - single heap cell each. - -2000-04-04 Gary Houston - - * error.c (scm_syserror): save errno before doing anything else, - since it's used in two expressions and may get mutated (thanks to - Dirk Herrmann). - -2000-04-04 Dirk Herrmann - - * debug.c (scm_procedure_source, scm_procedure_environment), - gsubr.c (scm_make_gsubr_with_generic, scm_gsubr_apply), procs.c - (scm_procedure, scm_setter): Return valid scheme value as dummy. - - * filesys.c (scm_readdir, scm_rewinddir, scm_closedir, - scm_dir_print, scm_dir_free), numbers.h (SCM_COMPLEX_REAL, - SCM_COMPLEX_IMAG), regex-posix.h (SCM_RGX), throw.c (JBJMPBUF, - SETJBJMPBUF, JBJMPBUF, SETJBJMPBUF, freejb, print_lazy_catch, - scm_ithrow), unif.c (scm_uniform_vector_ref, scm_cvref, - scm_array_set_x, rapr1), unif.h (SCM_ARRAY_V, SCM_ARRAY_BASE), - vectors.h (SCM_VELTS, SCM_VELTS_AS_STACKITEMS, SCM_SETVELTS): Use - SCM_{SET_}?CELL_WORD* to access cell entries with raw data. - - * filesys.c (scm_closedir), numbers.c (scm_addbig), numbers.h - (SCM_SETNUMDIGS), throw.c (JBACTIVE, SCM_JBDFRAME, - SCM_SETJBDFRAME): Read and modify data bits in cell entry #0 using - SCM_{SET_}?CELL_WORD_0. - - * filesys.c (fill_select_type, retrieve_select_type, scm_select), - numbers.c (scm_gcd, scm_lcm, scm_integer_expt, scm_zero_p, - scm_product, scm_divide), posix.c (scm_getgrgid), ramap.c - (scm_array_fill_int, racp), throw.c (scm_catch, scm_lazy_catch, - scm_ithrow), unif.c (scm_make_uve, scm_array_p, - scm_transpose_array, scm_array_set_x, scm_bit_set_star_x, - scm_bit_count_star, l2ra), variable.c (prin_var, - scm_make_variable, scm_make_undefined_variable, - scm_builtin_variable), vectors.c (scm_vector_set_length_x), - vports.c (sf_flush, sf_close): Don't use C operators to compare - SCM values. - - * numbers.c (scm_odd_p, scm_even_p), variable.c (prin_var): Must - unpack SCM values to access their raw contents. - - * numbers.c (big2str): Eliminate unnecessary casts to SCM. - - * numbers.h (SCM_NEWREAL), regex-posix.h (SCM_RGXP), vports.c - (scm_make_soft_port): Use SCM_{SET_}?CELL_TYPE to access the cell - type information. - - * throw.c (printjb): Eliminated unnecessary unpack. - - * variable.c (make_vcell_variable): Smob data is of type - scm_bits_t. - -2000-04-04 Mikael Djurfeldt - - * print.c: Removed promise to rewrite printer code before next - release. :) - -2000-04-03 Mikael Djurfeldt - - * iselect.c (add_fd_sets): Insert empty statement after label. - (Thanks to Tim Mooney.) - -2000-04-03 Michael Livshin - - * guardians.c (scm_guardian_zombify): mark all zombies in a - separate loop after processing all the currently known live - guardians, so as to not introduce order dependencies (thanks to - Gary Houston). note that the order problems are still there if - some guardians are themselves zombies, but that's a sick case that - I'm not going to worry about. - also, make another outer loop to process zombified - guardians (which are uncovered while marking zombies). - -2000-04-03 Dirk Herrmann - - * evalext.c (scm_definedp, scm_m_undefine), gc.c - (scm_mark_weak_vector_spines, scm_gc_sweep), hashtab.c - (scm_hashq_ref, scm_hashv_ref, scm_hash_ref, scm_hashx_ref), - keywords.c (scm_make_keyword_from_dash_symbol), lang.c - (scm_nil_eq), lang.h (SCM_NILP, SCM_NIL2EOL), load.c - (scm_primitive_load), modules.c (scm_module_full_name), objects.c - (scm_class_of, scm_mcache_lookup_cmethod, scm_make_class_object), - ports.c (scm_close_all_ports_except), ports.h (SCM_EOF_OBJECT_P), - print.c (scm_iprin1, scm_prin1, scm_iprlist, scm_simple_format), - print.h (SCM_PRINT_STATE_P), procprop.c (scm_i_procedure_arity, - scm_stand_in_scm_proc, scm_procedure_property, - scm_set_procedure_property_x), procs.c - (scm_procedure_documentation), read.c (scm_lreadr, scm_lreadparen, - scm_lreadrecparen, scm_read_hash_extend), script.c - (scm_compile_shell_switches), srcprop.c (scm_source_property, - scm_set_source_property_x), srcprop.h (SCM_WHASHFOUNDP), stacks.c - (read_frame, NEXT_FRAME, read_frames, narrow_stack, - scm_make_stack, scm_stack_id), strop.c (scm_i_index, - scm_string_index, scm_string_rindex), struct.c (scm_struct_init), - validate.h (SCM_VALIDATE_BOOL_COPY, SCM_VALIDATE_INUM_DEF, - SCM_VALIDATE_INUM_DEF_COPY, SCM_VALIDATE_PROC, - SCM_VALIDATE_ARRAY): Don't use C operators to compare SCM values. - - * feature.c (make_hook), keywords.c - (scm_make_keyword_from_dash_symbol), macros.c (scm_makacro, - scm_makmacro, scm_makmmacro), print.c (scm_iprin1, - scm_printer_apply, scm_port_with_print_state): Smob data is of type - scm_bits_t. - - * feature.c (print_hook), gc.c (scm_object_address), hash.c - (scm_ihashq, scm_ihashv), print.c (scm_iprin1, scm_ipruk), smob.c - (freeprint), struct.c (scm_print_struct): Must unpack - SCM values to access their raw contents. - - * fluids.c (apply_thunk, scm_with_fluids), hashtab.c (fold_proc, - scm_hash_fold), load.c (load, scm_primitive_load): Passing SCM - values via void * requires unpacking / packing. - - * fports.c (scm_fport_buffer_add, scm_setvbuf), procs.h - (SCM_SUBRNUM, SCM_SET_SUBRNUM), srcprop.h (SRCPROPBRK, SRCBRKP): - Read and modify data bits in cell entry #0 using - SCM_{SET_}?CELL_WORD_0. - - * fports.c (scm_fdes_to_port), gc.c (scm_gc_for_newcell, - scm_gc_sweep, init_heap_seg), init.c (start_stack), ports.c - (scm_void_port), procs.c (scm_make_subr_opt, - scm_make_procedure_with_setter), root.c (scm_internal_cwdr), - smob.c (scm_make_smob), strports.c (scm_mkstrport): Use - SCM_SET_CELL_TYPE to write the cell type information. - - * gc.c (scm_gc_mark): Use SCM_CELL_OBJECT* to access SCM values - from cells that are no scheme pairs. - - * gc.c (scm_gc_sweep), mallocs.c (prinmalloc), mallocs.h - (SCM_MALLOCDATA, SCM_SETMALLOCDATA), print.c (scm_ipruk), random.h - (SCM_RSTATE), root.h (SCM_ROOT_STATE), smob.c (scm_smob_free), - srcprop.c (freesrcprops), srcprop.h (SRCPROPPOS, SRCPROPFNAME, - SRCPROPCOPY, SRCPROPPLIST), struct.c (scm_make_struct, - scm_make_vtable_vtable): Use SCM_{SET_}?CELL_WORD* to access cell - entries with raw data. - - * gc.c (scm_init_storage), sort.c (applyless), strop.c - (scm_string_to_list): Eliminate unnecessary casts to SCM. - - * mallocs.c (scm_malloc_obj): Store result of malloc as raw - data. - - * ports.c (scm_close_all_ports_except): Duplicate documentation - text removed. - - * print.c (scm_iprin1): Use SCM_ITAG3. - - * procs.h (SCM_SET_SUBRNUM): Fix shift direction. - - * snarf.h (SCM_GPROC, SCM_GPROC1, SCM_SYMBOL, SCM_GLOBAL_SYMBOL, - SCM_KEYWORD, SCM_GLOBAL_KEYWORD, SCM_VCELL, SCM_GLOBAL_VCELL, - SCM_VCELL_INIT, SCM_GLOBAL_VCELL_INIT): Don't initialize globals - and static variables at their point of declaration, but rather in - the init function. - - * tags.h (SCM_PACK): Automatically cast to scm_bits_t. - -2000-04-02 Gary Houston - - * guardians.c (TCONC_IN, scm_make_guardian): set the CDR of the - empty tconc pair to SCM_EOL instead of SCM_BOOL_F, avoiding the - use of an improper list (which breaks g_print. g_print isn't - used). - guardians.c: Added more comments and modified the make-guardian - docstring. Reordered a few procedures. - -2000-04-01 Dirk Herrmann - - * eval.c (scm_lookupcar1, scm_lookupcar, scm_m_case, scm_m_cond, - scm_m_lambda, iqq, scm_m_define, scm_m_expand_body, unmemocopy, - SCM_CEVAL), procs.h (SCM_TOP_LEVEL): Don't use C operators to - compare SCM values. - - (scm_makprom): Smob data is of type scm_bits_t. - -2000-03-31 Dirk Herrmann - - * backtrace.c (display_error_body), debug.c (scm_procedure_source, - scm_reverse_lookup), dynl.c (scm_dynamic_link): Don't use C - operators to compare SCM values. - - * debug.c (scm_make_debugobj), debug.h (SCM_DEBUGOBJ_FRAME, - SCM_SET_DEBUGOBJ_FRAME): Update SCM_{SET_}?DEBUGOBJ_FRAME to - access raw cell data with SCM_{SET_}?CELL_WORD_1. - - * debug.c (scm_make_debugobj): Don't use SCM_SETCAR to set types. - - * debug.c (scm_make_memoized), dynl.c (scm_dynamic_link): Smob - data is of type scm_bits_t. - -2000-03-31 Dirk Herrmann - - * gdbint.c (gdb_maybe_valid_type_p), guardians.c (TCONC_EMPTYP, - scm_guardian_zombify): Use SCM_EQ_P to compare SCM values. - - * guardians.c (GUARDIAN): Use SCM_CELL_WORD_1 for raw data. - -2000-03-31 Dirk Herrmann - - * ports.h (scm_port): Change type of stream member to scm_bits_t. - - * gdbint.c (unmark_port, remark_port), ports.c (scm_markstream), - strports.c (st_resize_port, scm_mkstrport), vports (sf_flush, - sf_write, sf_fill_input, sf_close, scm_make_soft_port): Since - streams are now of type scm_bits_t, SCM streams have to be - unpacked/packed. - - * ports.h (SCM_SETPTAB_ENTRY, SCM_SETSTREAM): Cast input to - scm_bits_t. - -2000-03-31 Mikael Djurfeldt - - * coop-defs.h (struct coop_t): Added `sto'-field again because of - binary compatibility---let's remove it next time we alter some - major structure. - - * coop.c (coop_quitting_p, coop_cond_create, coop_mutex_create, - coop_mother, coop_child): New variables. - (mother): New function. - (coop_create): New thread spawning mechanism which uses a "mother - thread". The "dummy" pthreads aren't healthy enough to give birth - to new threads since Linux threads thinks they are asleep. - - * coop-defs.h (struct coop_t): Removed dummy_mutex. - - * coop-defs.h, coop-threads.c (struct coop_t): Eliminate - `sto'-field when GUILE_PTHREAD_COMPAT is enabled. - -2000-03-30 Dirk Herrmann - - * arbiters.c (scm_make_arbiter), async.c (scm_async), dynwind.c - (scm_internal_dynamic_wind): Smob data is always of type - scm_bits_t. - - * arbiters.c (SCM_ARB_LOCKED, SCM_LOCK_ARB, SCM_UNLOCK_ARB): - Access the locking information in cell entry 0 with - SCM_{SET_}?CELL_WORD_0 instead of SCM_*CAR. - - * async.c (scm_run_asyncs): Use SCM_NULLP to test for the empty - list. - - * dynwind.c (scm_dowinds): Use SCM_EQ_P to compare SCM values. - - * ports.h (SCM_PTAB_ENTRY, SCM_SETPTAB_ENTRY): Access the ptab - entry data using SCM_{SET_}?CELL_WORD_1 instead of SCM_{SET}?CDR. - -2000-03-29 Dirk Herrmann - - * alist.c (scm_sloppy_assq, scm_assq), eq.c (scm_eq_p, scm_eqv_p, - scm_equal_p), list.c (scm_ilength, scm_last_pair, scm_reverse, - scm_sloppy_memq, scm_delq_x, scm_delq1_x), tags.h (SCM_UNBNDP): - Don't use C operators == and != to compare SCM values, use - SCM_EQ_P instead. - - * boolean.c (scm_boolean_p): Use SCM_BOOLP to determine whether a - SCM value is equal to #t or #f. - - * eq.c (scm_eqv_p, scm_equal_p): Don't use SCM_CAR to access the - cell type entry of non immediate objects of unknown type. Use - SCM_CELL_TYPE instead. - - * gh_data.c (gh_scm2bool, gh_module_lookup), list.c - (scm_sloppy_memv, scm_sloppy_member, scm_delv_x, scm_delete_x, - scm_delv1_x, scm_delete1_x), scmsigs.c (scm_sigaction): Use - SCM_FALSEP and SCM_TRUE_P to compare SCM values against #f and - #t. - - * list.c (scm_listify): Use SCM_UNBNDP to test for an unbound - scheme value. - -2000-03-29 Mikael Djurfeldt - - * coop-threads.c (scm_call_with_new_thread, scm_spawn_thread, - scm_make_mutex, scm_make_condition_variable): Cast data to - scm_bits_t in SCM_SET_CELL_WORD and SCM_NEWSMOB macros. - - * coop.c (coop_create): Set `specific' field, not `data' to NULL. - -2000-03-29 Dirk Herrmann - - * smob.h (SCM_NEWSMOB, SCM_NEWSMOB2, SCM_NEWSMOB3, SCM_SMOB_DATA, - SCM_SET_SMOB_DATA, SCM_TC2SMOBNUM, SCM_SMOBNUM): To access smob - data, use SCM_{SET_}?CELL_TYPE or SCM_{SET_}?WORD_[1-3]. - - Note that this implies that smob data has always to be passed as - values of type scm_bits_t. - -2000-03-29 Mikael Djurfeldt - - * threads.c (scm_init_threads): Pass 0 size to scm_make_smob_type - for scm_tc16_thread. As the current COOP threads are written, GC - is not supposed to manage storage for threads. - - * error.c (scm_error): Don't try to throw an error if - scm_gc_heap_lock is true. - - * coop.c (coop_finish): New function. Called at exit. - (coop_aborthelp): Free thread structures when threads die. - Finished LinuxThreads compatibility support => COOP threads now - mesh with LinuxThreads. - - * coop-threads.c (scm_call_with_new_thread, scm_spawn_thread): - Changed SETCDR --> SET_CELL_WORD_1. - - * coop-threads.c (scheme_launch_thread): Set word 1 of handle to 0 - when thread dies. - -2000-03-29 Dirk Herrmann - - * boolean.h (SCM_TRUE_P): New macro. - - * boolean.h (SCM_FALSEP, SCM_NFALSEP, SCM_BOOLP), pairs.h - (SCM_NULLP, SCM_NNULLP): Use SCM_EQ_P to compare SCM values. - -2000-03-28 Dirk Herrmann - - * continuations.h (SCM_CONTREGS, SCM_SET_CONTREGS): New macros to - access continuation data. - - (SCM_SETJMPBUF): Deprecated. Use SCM_SET_CONTREGS instead. - - (SCM_JMPBUF, SCM_DYNENV, SCM_THROW_VALUE, SCM_BASE, SCM_SEQ, - SCM_DFRAME): Use SCM_CONTREGS instead of SCM_CHARS to access - continuation data. - - * continuations.c (scm_make_cont), init.c (start_stack), - root.c (scm_internal_cwdr): Use SCM_SET_CONTREGS instead of - SCM_SETJMPBUF. - -2000-03-28 Dirk Herrmann - - * symbols.h (SCM_LENGTH, SCM_SETLENGTH): Access the length field - of strings and symbols by using SCM_{SET_}?CELL_WORD_0. - - (SCM_CHARS, SCM_UCHARS, SCM_SETCHARS): Use SCM_{SET_}?CELL_WORD_1 - to access the char * field of strings and symbols. - -2000-03-27 Dirk Herrmann - - * gc.h (SCM_NEWCELL, SCM_NEWCELL2): Use SCM_SET_CELL_TYPE to set - the type entry of a new cell. Added a comment about things to - remember when updating the list of free cells. - - (SCM_FREEP, SCM_MARKEDP): Use SCM_CELL_TYPE to access the type - entry of a cell. - -2000-03-27 Dirk Herrmann - - * pairs.h (SCM_CAR, SCM_CDR, SCM_SETCAR, SCM_SETCDR): Use - SCM_CELL_OBJECT and SCM_SET_CELL_OBJECT. This change implies that - with strict type checking enabled these macros will only work if - given valid SCM parameters. - - (SCM_GCCDR): Moved to tags.h. - - * tags.h (SCM_GCCDR): Moved here from pairs.h. - -2000-03-26 Dirk Herrmann - - * tags.h (SCM2PTR, PTR2SCM): Moved to gc.h. - - * pairs.h (scm_cell, SCM_CELLPTR, SCM_CELL_WORD*, SCM_CELL_OBJECT*, - SCM_SET_CELL_WORD*, SCM_SET_CELL_OBJECT*, SCM_CELL_TYPE, - SCM_SET_CELL_TYPE, SCM_PTR_LT, SCM_PTR_MASK, SCM_PTR_GT, - SCM_PTR_LE, SCM_PTR_GE, SCM_CELL_WORD_LOC, SCM_NEWCELL, - SCM_NEWCELL2): Moved to gc.h. - - (SCM_CARLOC, SCM_CDRLOC, SCM_SETAND_CAR, SCM_SETAND_CDR, - SCM_SETOR_CAR, SCM_SETOR_CDR): Moved to gc.h. These names should - be changed, though, since the macros are not only pair related. - - (SCMPTR): Deleted. - - * gc.h (SCM2PTR, PTR2SCM, scm_cell, SCM_CELLPTR, SCM_CELL_WORD*, - SCM_CELL_OBJECT*, SCM_SET_CELL_WORD*, SCM_SET_CELL_OBJECT*, - SCM_CELL_TYPE, SCM_SET_CELL_TYPE, SCM_PTR_LT, SCM_PTR_MASK, - SCM_PTR_GT, SCM_PTR_LE, SCM_PTR_GE, SCM_CELL_WORD_LOC, - SCM_NEWCELL, SCM_NEWCELL2, SCM_CARLOC, SCM_CDRLOC, SCM_SETAND_CAR, - SCM_SETAND_CDR, SCM_SETOR_CAR, SCM_SETOR_CDR): Moved here from - tags.h and pairs.h. - -2000-03-25 Dirk Herrmann - - * tags.h (SCM_STRICT_TYPING): New macro that, if defined, - activates strict compile time type checking for variables of - type SCM. - (SCM, SCM_PACK, SCM_UNPACK): Define according to whether - SCM_STRICT_TYPING or SCM_VOIDP_TEST are defined. - (SCM_EQ_P): Defined as a macro equivalent for eq?. - -2000-03-25 Dirk Herrmann - - * tags.h (SCM_POINTERS_MUNGED): Removed. - - * gc.c (scm_gc_sweep, init_heap_seg): Removed use of - SCM_POINTERS_MUNGED, thus fixing some illegal casts to SCM. - -2000-03-24 Dirk Herrmann - - * pairs.h (SCM_CELL_OBJECT, SCM_CELL_OBJECT_[0-3], - SCM_SET_CELL_OBJECT, SCM_SET_CELL_OBJECT_[0-3], SCM_CELL_TYPE, - SCM_SET_CELL_TYPE): Added a set of low level macros for accessing - cell entries. - (SCM_CELL_WORD_[0-3]): Renamed from the SCM_CELL_WORD[0-3]. - - * procs.h, procs.c: Instead of SCM_{SET_}?CELL_WORD[12], use the - newly introduced SCM_{SET_}?CELL_OBJECT_[12] macros. - -2000-03-23 Mikael Djurfeldt - - * tags.h: Disabled definition of SCM_VOIDP_TEST. - - Defining SCM as void * introduces problems which haven't been - handled yet. Developers who work with these issues can enable it - in their working copies. - - Disabling this definition exposes a set of newly introduced and - older misuses of types which causes warning messages during - compilation. We'll fix this successively. - - * gc.c (scm_mark_locations): Changed * (SCM **) X --> * (SCM *) X - in order to obtain a value of type SCM. - (scm_cellp): Updated with new changes to scm_mark_locations. - - * continuations.h (SCM_SETJMPBUF): Cast second arg into SCM. - - * continuations.c (scm_make_cont): Removed cast of size_t into - long. - - * symbols.h (SCM_SETCHARS): Cast second arg into SCM. - -2000-03-22 Dirk Herrmann - - * numbers.h (SCM_SETNUMDIGS): Use SCM_BIGSIZEFIELD macro for - shifting, not constant. Thanks to Dale P. Smith. - - * numbers.c (scm_sum, scm_difference): Don't test a SCM value - for being less than zero. Decode it to a C value first. Again, - thank you Dale. - -2000-03-22 Dirk Herrmann - - * numbers.h, ramap.c, struct.h, vectors.h: Don't use SCM2PTR for - non scheme values. If raw data is stored in SCM variables, it has - to be accessed using SCM_UNPACK until a better solution is found. - -2000-03-22 Mikael Djurfeldt - - * tags.h (SCM_ECONSP, SCM_NECONSP): More corrections of - pointer-arithmetic induced by the SCM_PACK/UNPACK change. - - * print.c (scm_iprin1): SCM_PACK/UNPACK corrections. - - * gc.c (scm_gc_sweep): SCM_PACK/UNPACK corrections. - - * eval.c (SCM_CEVAL, scm_unmemocar): SCM_PACK/UNPACK corrections. - - * dynwind.c (scm_swap_bindings): SCM_PACK/UNPACK corrections. - - * async.c, __scm.h: Removed lots of the old async click logic. It - is possible to reinsert it by defining GUILE_OLD_ASYNC_CLICK in - __scm.h. Let's try this out and dump the old code after the - threads reorganization. - (set-tick-rate, set-switch-rate): Conditionally removed. - -2000-03-21 Mikael Djurfeldt - - * gc.c (scm_gc_mark): Bugfix 1: The recent SCM_PACK/UNPACK change - made SCM values into pointers. This turned an arithmetic - computation of the address of the vcell into a pointer-arithmetic - one, thereby screwing up marking of structs. - Bugfix 2: Removed incompletely introduced loop variable `j' used - when protecting the tail array of a struct. - -2000-03-21 Dirk Herrmann - - * struct.h (SCM_STRUCT_DATA): Don't cast SCM values to pointers. - -2000-03-21 Dirk Herrmann - - * symbols.h, symbols.c (scm_strhash): Declare the string - parameter as constant, since it is not modified. - - * symbols.c (scm_intern_obarray_soft, - scm_sysintern0_no_module_lookup): Can now pass constant strings - to scm_strhash without need for casting. - -2000-03-21 Dirk Herrmann - - * vectors.h (SCM_VELTS, SCM_VELTS_AS_STACKITEMS): Don't cast SCM - values to pointers. Use SCM2PTR instead. - -2000-03-21 Dirk Herrmann - - * async.c (scm_set_tick_rate, scm_set_switch_rate): Don't unpack - results of SCM_INUM. - -2000-03-21 Mikael Djurfeldt - - * init.c (scm_boot_guile_1): Renamed GUILE_GC_TRIGGER_1 --> - GUILE_MIN_YIELD_1, GUILE_GC_TRIGGER_2 --> GUILE_MIN_YIELD_2. - GUILE_MIN_YIELD_X now take *positive* fractions of heap size. - - * gc.c, gc.h (SCM_MIN_YIELD_1, SCM_MIN_YIELD_2, - min_yield_fraction, min_yield, adjust_min_yield): Renamed from - SCM_GC_TRIGGER_1, SCM_GC_TRIGGER_2, gc_trigger_fraction, - gc_trigger, adjust_gc_trigger. - - * gc.c (alloc_some_heap): Further improvement of minimal heap size - prediction. - (SCM_MAX): New macro. - (scm_freelist_t): New field: collected_1. Previous amount of - collected cells. - (gc_sweep_freelist_finish): Trigger based on two last values of - freelist->collected to avoid unnecessary allocation due to - temporary peaks. - (SCM_INIT_HEAP_SIZE_1, SCM_GC_TRIGGER_1, SCM_GC_TRIGGER_2): - Adjusted to 45000 cells, 40% and 40%. Gives quick startup - without extra heap allocation. - -2000-03-20 Dirk Herrmann - - * numbers.h (SCM_MAKINUM): The parameter to SCM_MAKINUM should - already be a C value. No need to unpack it. - - * numbers.c (scm_long_long2num): Cast the parameter to scm_bits_t - if we know it fits into an inum. - - * ramap.c (ramap_rp): An scm_tc7_[ui]vect object does point to a - field of long values. In contrast, SCM_VELTS accesses a field of - SCM values. - -2000-03-20 Mikael Djurfeldt - - * gc.c (scm_gc_stats): Inserted explanation of local_scm_mtrigger - etc. - (scm_gc_yield_1): New variable: Holds previous yield. Used to - make better judgements. - (gc_sweep_freelist_finish): Inserted explanation of use of - gc_trigger. - - * print.h, stacks.h, options.c, options.h: Changed C++ - commentaries to C. - -2000-03-20 Dirk Herrmann - - * tags.h (SCM2PTR, PTR2SCM): Use SCM_PACK / SCM_UNPACK correctly. - - * numbers.h (SCM_INUMP, SCM_MAKINUM, SCM_INUM0, SCM_COMPLEX_REAL, - SCM_COMPLEX_IMAG, SCM_NUMP, SCM_BDIGITS): Use SCM_PACK / - SCM_UNPACK / SCM2PTR correctly. - -2000-03-20 Mikael Djurfeldt - - * gc.c (adjust_gc_trigger): Improved documentation. - (alloc_some_heap): Since gc_trigger is used against - freelist->collected, this is the value which should be used to - predict minimum growth. - -2000-03-20 Dirk Herrmann - - * eval.h: Fix mixup of packed/unpacked SCM values. (Thanks - Thien-Thi Nguyen for the patch.) - -2000-03-20 Dirk Herrmann - - * numbers.c (scm_ash): Fixed typing problems with the second - parameter and added some documentation. (Thanks Thien-Thi Nguyen - for indicating the problem.) - -2000-03-19 Mikael Djurfeldt - - * gc.c, gc.h (scm_gc_yield): New variable. - (adjust_gc_trigger): Use scm_gc_yield. - (alloc_some_heap): Use scm_gc_yield instead of - scm_gc_cells_collected. - - * coop-threads.c: Addd #include "root.h", #include "strings.h". - - * debug.c: Added #include "root.h". (Thanks to Thien-Thi Nguyen.) - - * gc.c (scm_gc_for_newcell, adjust_gc_trigger): Improved GC - trigger adjustmeant: Take yield (freed cells) for all freelists - into account. - (SCM_INIT_HEAP_SIZE_1, SCM_GC_TRIGGER_1, SCM_GC_TRIGGER_2): Tuned - to 50000 cell heap with 45% trigger. - (scm_gc_cells_collected): Reintroduced. - (SCM_HEAP_SIZE): New macro. - (scm_gc_sweep): Reintroduced correct computation of - scm_cells_allocated. - (scm_freelist_t): Corrected commentary for field `cluster_size': - Clustersize counts objects, not cells; New member - `clusters_allocated'. - -2000-03-19 Michael Livshin - - * *.[hc]: add Emacs magic at the end of file, to ensure GNU - indentation style. - -2000-03-19 Mikael Djurfeldt - - * threads.h: Added #include "libguile/throw.h". (Thanks to - Thien-Thi Nguyen.) - -2000-03-18 Michael Livshin - - * tags.h: (SCM_DOUBLE_CELLP, SCM_NDOUBLE_CELLP): new macros (bad - names, anyone got any better ones?) - - * gc.h: (typedef struct scm_freelist_t) remove from here. - - * gc.c: (CELL_UP, CELL_DN) made these macros take additional - parameter (the span). - (CLUSTER_SIZE_IN_BYTES, ALIGNMENT_SLACK) new macros. - (typedef struct scm_freelist_t) moved here from gc.h, it had no - business being externally visible. - (typedef struct scm_heap_seg_data_t) renamed from - scm_heap_seg_data, to be style-compliant. - (scm_mark_locations) if the possible pointer points to a - double-cell, check that it's properly aligned. - (init_heap_seg) align double-cells properly, work with the - assumption that the segment size divides cleanly by cluster size. - (round_to_cluster_size) new function. - (alloc_some_heap, make_initial_segment) use round_to_cluster_size - to satisfy the new init_heap_seg invariant. - -2000-03-18 Dirk Herrmann - - * _scm.h: Don't include async.h everywhere... - - * eq.c eval.c iselect.c: ... only include it here. - -2000-03-18 Dirk Herrmann - - * _scm.h: Don't include root.h everywhere... - - * async.c continuations.c eq.c eval.c evalext.c feature.c gc.c - gdbint.c gsubr.c ioext.c keywords.c lang.c load.c macros.c - numbers.c objprop.c ports.c print.c procprop.c ramap.c read.c - srcprop.c stackchk.c stacks.c strports.c symbols.c unif.c - variable.c vectors.c vports.c: ... only include it here. - -2000-03-17 Dirk Herrmann - - * _scm.h: Don't include strings.h everywhere... - - * backtrace.c dynl.c error.c feature.c filesys.c fports.c gc.c - gdbint.c ioext.c load.c net_db.c numbers.c objects.c options.c - ports.c posix.c print.c procs.c random.c read.c regex-posix.c - simpos.c socket.c stacks.c stime.c strop.c strports.c struct.c - symbols.c unif.c vectors.c version.c vports.c: ... only include it - here. - -2000-03-17 Dirk Herrmann - - * _scm.h: Don't include ports.h everywhere... - - * arbiters.c backtrace.c debug.c dynl.c dynwind.c eval.c feature.c - fluids.c gc.c gdbint.c guardians.c hash.c keywords.c mallocs.c - numbers.c objects.c print.c read.c root.c smob.c srcprop.c - stackchk.c strports.c struct.c throw.c variable.c: ... only - include it here. - -2000-03-17 Dirk Herrmann - - * _scm.h: Don't include vectors.h everywhere... - - * eq.c eval.c filesys.c gc.c gsubr.c guardians.c hash.c hashtab.c - keywords.c net_db.c numbers.c objects.c posix.c print.c procprop.c - procs.c ramap.c random.c read.c scmsigs.c socket.c sort.c stime.c - strports.c symbols.c unif.c vports.c weaks.c: ... only include it - here. - -2000-03-17 Dirk Herrmann - - * genio.h: removed. (Only content was '/* delete me */'.) - - * Makefile.am arbiters.c backtrace.c debug.c dynl.c dynwind.c - error.c filesys.c fluids.c gc.c gsubr.c guardians.c keywords.c - libguile.h mallocs.c numbers.c print.c random.c read.c root.c - srcprop.c stackchk.c struct.c threads.c throw.c variable.c: - Removed reference to genio.h - -2000-03-17 Mikael Djurfeldt - - * gc.c, gc.h: Cleanup of the change of 2000-03-15. - Cluster sizes are now independent of GC trigger values. - GUILE_GC_TRIGGER_n can now specify a relative trigger value: - A negative integer gives fraction of total heap size in percent. - (SCM_GC_TRIGGER_1, SCM_GC_TRIGGER_2): Default values set to -40. - - * init.c (scm_boot_guile_1): Introduced new variable - GUILE_MAX_SEGMENT_SIZE; New environment variable names: - GUILE_INIT_SEGMENT_SIZE_1, GUILE_GC_TRIGGER_1, - GUILE_INIT_SEGMENT_SIZE_2, GUILE_GC_TRIGGER_2 - -2000-03-16 Mikael Djurfeldt - - * __scm.h (GC_FREE_SEGMENTS): Disable this until we have made - freeing of segment work with the new GC scheme. (Thanks to - Michael Livshin.) Oops, also happened to make GUILE_NEW_GC_SCHEME - the default, but I'll let this change stay in CVS Guile since this - code is not expected to contain serious bugs. - -2000-03-16 Mikael Djurfeldt - - * gc.c, gc.h (scm_map_free_list): Define also if GUILE_DEBUG is - defined. - (scm_free_list_length): New procedure (GUILE_DEBUG). - Fixed a small but serious bug introduced by the previous change. - - * gc.c (scm_gc_sweep): Moved variable n_objects to inner sweep - loop and declare as register. - - * gc.c (scm_gc_sweep): Sigh... forgot to clear private freelists - after GC. - -Wed Mar 15 08:27:04 2000 Greg J. Badros - - * fluids.c: Docstring patch from Keisuke Nishida. Some - reindentation, too, and a couple formals renamed. Should - fluid-set! return UNSPECIFIED instead of a value? - -Wed Mar 15 08:24:58 2000 Greg J. Badros - - * Makefile.am: Separate out DOT_X_FILES and DOT_DOC_FILES, and - generate the latter from the concrete listing of the former. Then - make guile-procedures.txt depend on DOT_DOC_FILES instead of - *.doc, so that rebuilding it works. - -Wed Mar 15 08:12:14 2000 Greg J. Badros - - * libguile.h: Include libguile/validate.h. Thanks Keisuke Nishida! - - * guile-snarf.awk.in: Replace docstring line-ending \n" and \n\n" - with nothing and \n, respectively. Thanks Keisuke Nishida for - noticing this problem. - -2000-03-15 Mikael Djurfeldt - - * __scm.h (GUILE_NEW_GC_SCHEME): Define this if you want to test a - new way of allocating heap. It makes Guile fast, but still - contains bugs. - - * gc.c, gc.h, pairs.h, init.c: Implementation of a new way of - allocating heap. The basic idea is to trigger GC every Nth - allocated cell and grow heap when free list runs out. The scheme - has been extended so that GC isn't triggered until all remaining - cells are used. The implementation is also prepared for - development in the direction of POSIX threads. - - * gc.c (SCM_EXPHEAP): In order to grow by a factor of 1.5, - SCM_EXPHEAP should return half of the heap size. - -2000-03-14 Mikael Djurfeldt - - The following change to init.c is only enabled if Guile was - configured with --enable-guile-debug. - - * init.c (scm_i_getenv_int): New function. - (scm_boot_guile_1): Use the environment variables - GUILE_INIT_HEAP_SIZE, GUILE_INIT_HEAP_SIZE2 to select heap size if - they exist. (This may be replaced by a Scheme level mechanism in - the future.) - - * objprop.c (s_scm_set_object_property_x): Use scm_assq instead of - scm_assoc. (Thanks to Keisuke Nishida.) - -2000-03-14 Mikael Djurfeldt - - * eval.c, lang.c, lang.h (scm_lisp_nil, scm_lisp_t): Renamed from - scm_nil, scm_t. (Thanks to Keisuke Nishida.) - -2000-03-14 Mikael Djurfeldt - - * init.c (scm_boot_guile_1): Use same initial segment size for - 1-word and 2-word segments. Having the smaller size causes Guile - to GC too often. Obviously something needs to be done to allow - for a smaller 2-word segment without this to happen. (The amount - of heap for each type should be automatically adapted to the - application somehow.) - - [Almost all of these changes should be documented in the NEWS - file.] - - * gc.h (scm_freelist_t): New type. - - * pairs.h (SCM_NEWCELL, SCM_NEWCELL2): Use new style freelists. - - * gc.c (SCM_INIT_HEAP_SIZE): Changed from 32768 --> 40000 so that - all of Guile basics fits into one segment and there suitable room - for work. - (SCM_EXPHEAP): Now takes an argument. Grow by a factor of 1.5 - instead of 2. - (scm_freelist, scm_freelist2): Now of type scm_freelist_t. - Freelists now contains information about object span, cells - collected and amount of cells in heap segments belonging to the - list. - (scm_heap_size, scm_gc_cells_collected): Removed. - - * init.c (scm_boot_guile_1): Make 2-word segment 8K (512 cells). - - * Makefile.am (libguile_la_LDFLAGS): Bumped library version - number. - - * __scm.h eq.c, eval.c, gc.c, gc.h, gh_data, hash.c, numbers.c, - numbers.h, objects.c, ramap.c, random.c, unif.c, unif.h: Extensive - rewrite of handling of real and complex numbers. - (SCM_FLOATS, SCM_SINGLES): These #ifdef conditionals have been - removed along with the support for floats. (Float vectors are - still supported.) - - * tags.h (scm_tcs_bignums): Removed. - (scm_tc16_bigpos, scm_tc16_bigneg): Replaced by scm_tc16_big. - Use SCM_BIGSIGN(x) to test for sign! - (scm_tc16_big): The new bignum type. - (SCM_REAL_PART, SCM_IMAG_PART): Removed. - - * numbers.h (SCM_BIGSIGN): Sign moved to bit 16. - (scm_makdbl): Deprecated. - (SCM_NEWREAL, SCM_NEWCOMPLEX): New macros. - (SCM_SINGP): Deprecated. - (SCM_FLO): Removed. - (SCM_INEXP, SCM_CPLXP): Deprecated. - (SCM_INEXACTP, SCM_COMPLEXP): New macros. - (SCM_COMPLEX_REAL, SCM_COMPLEX_IMAG): Renamed from - SCM_REAL, SCM_IMAG (and now only valid for complex numbers). - (SCM_REAL, SCM_IMAG): New, *deprecated*, selectors which work both - for doubles and complex numbers. - (SCM_REAL_VALUE): New selector for doubles. - (scm_double_t, scm_complex_t): New types. - (scm_dbl): Removed. - - * numbers.c (scm_floprint, scm_floequal): Removed. - (scm_print_real, scm_print_complex, scm_real_equalp, - scm_complex_equalp): New functions. - - * unif.c (scm_makflo): Removed. - - * smob.h (SCM_SMOB_PREDICATE): New macro. - (SCM_NEWSMOB2, SCM_RETURN_NEWSMOB2, SCM_NEWSMOB3, - SCM_RETURN_NEWSMOB3): New macros. - -1999-11-21 Michael Livshin - - The following changes implement primitive support for double cells - (i.e. four-word cells) and change the representation of some - things to multi-cells instead of cons+malloc. (Applied and - modified by mdj.) - - * pairs.h (SCM_NEWCELL2): double-cell variants of SCM_NEWCELL. - (SCM_CELL_WORD, SCM_CELL_WORDLOC, SCM_SET_CELL_WORD): primitive - multi-cell access macros (used by the ones below). - (SCM_CELL_WORD[0-3], SCM_SET_CELL_WORD[0-3]): multi-cell access - macros. - - * gc.c (scm_freelist2): multi-cell freelists. - (inner_map_free_list): map_free_list, parameterized on ncells. - "nn cells in segment mm" was misleading for ncells > 1; changed to - "objects". still print cells too, though. - (scm_map_free_list): rewritten using inner_map_free_list. - (scm_check_freelist): get freelist as parameter, since now we have - more than one. - (scm_debug_newcell2): multi-cell variants of - scm_debug_newcell. - (scm_gc_for_newcell): take ncells and freelist pointer as - parameters. - (scm_gc_mark): add case for tc7_pws (procedures with setters are - now double cells). - (scm_gc_sweep): don't free the float data, since it's not malloced - anymore. - (init_heap_seg): didn't understand what n_new_objects stood for, - so changed to n_new_cells. - (make_initial_segment): new function, makes an initial segment - according to given ncells. - (scm_init_storage): call make_initial_segment, for ncells={1,2,3}. - - * numbers.c (scm_makdbl): no malloc'ing needed, so the - {DEFER,ALLOW}_INTS thing removed. - - * numbers.h (struct scm_dbl): changed to represent a double cell, - with the number in the second half. - - * dynwind.c: changed the wind-guards representation to double - cell. - - * procs.c, procs.h: changed the procedure-with-setter representation - to double cell. - - * async.c, async.h: made async representation a double cell. - - * dynl.c: made dynamic_obj representation a double cell. - -2000-03-13 Gary Houston - - * ports.c (flush_void_port): renamed to flush_port_default. - (end_input_void_port): renamed to end_input_default. - - * init.c (scm_standard_stream_to_port): create a void port instead - of opening /dev/null if the standard file descriptors are bad. - advantages: no portability problems, doesn't waste a file descriptor, - simplifies the code (thanks to Marius for the idea). - - * vports.c (s_scm_make_soft_port): call scm_port_non_buffer. - - * void ports: make reading from a void port give EOF instead of - segv: - * ports.c (s_scm_sys_make_void_port): modified docstring. - (fill_input_void_port): new proc. - (scm_init_ports): set up fill_input_void_port. - * ports.c (scm_port_non_buffer): new proc. - (scm_void_port): call scm_port_non_buffer. - - * fports.c (scm_setvbuf): docstring: remove the fcntl documentation - which was incorrectly appended. - -2000-03-13 Mikael Djurfeldt - - * guile-doc-snarf.in: Don't use absolute path for `sed'. (Note - that we can't use autoconf for this. Autoconf itself relies on - the existence of `sed' somewhere on your path.) (Thanks to Dirk - Herrman.) - -2000-03-13 Mikael Djurfeldt - - * Makefile.am (libguile_la_SOURCES): Moved iselect.c here from - EXTRA_libguile_la_SOURCES. - - * iselect.h: Always declare scm_internal_select. - - * iselect.c (scm_internal_select): Added SCM_ASYNC_TICK at the - end. Also let scm_internal_select be a real function also when - not using threads. - - * __scm.h (SCM_TICK): Oops! Forgot to put SCM_ASYNC_TICK here... - -2000-03-13 Mikael Djurfeldt - - * __scm.h (SCM_ALLOW_INTS, SCM_REALLOW_INTS): Removed call to - SCM_ASYNC_TICK. (This is a preparation for POSIX threads support, - and kind of an experiment: Will this cause problems?) - -Sun Mar 12 13:26:30 2000 Greg J. Badros - - * Makefile.am: Added *.doc to DISTCLEANFILES. - -2000-03-12 Gary Houston - - * fports.c (scm_fdes_to_port): call fcntl F_GETFL to test that - the fdes is valid before doing anything else. check that - the file descriptor supports the modes required. - (scm_fport_buffer_add): don't throw an error if fstat doesn't - work: just use the default buffer size. - - * throw.c: change an outdated comment about scm_internal_catch - BODY: it doesn't take a jumpbuf arg. - - * init.c (scm_standard_stream_to_port): install a handler in case - scm_fdes_to_port throws an error. don't check here whether the - file descriptor is valid, since scm_fdes_to_port will do that. - set the revealed count depending on whether the port got the - standard file descriptor. - (stream_body_data): new type. - (stream_body, stream_handler): new procs. - -2000-03-12 Mikael Djurfeldt - - * stacks.c, stacks.h, struct.c, tags.h, unif.c (scm_bits_t): - Renamed from SCMWORD. - - * tags.h (SCM_NCELLP): Removed (SCMWORD). - - * arbiters.c (SCM_ARB_LOCKED): Use SCM_UNPACK_CAR. - - * async.c, boolean.h, debug.c, dynl.c, dynwind.c, eval.c, eval.h, - feature.h, filesys.h, fluids.h, fports.c, fports.h, gc.c, gc.h, - hash.c, keywords.h, macros.c, numbers.c, numbers.h, objects.c, - objects.h, options.c, pairs.h, ports.c, ports.h, print.c, - procs.h, ramap.c, read.c, smob.c, smob.h, srcprop.h, stacks.c, - stacks.h, strports.c, struct.c, struct.h, tag.c, tags.h, - throw.c, unif.c, unif.h, variable.h, vectors.h, weaks.c, - weaks.h (SCM_PACK, SCM_UNPACK, SCM_UNPACK_CAR): Renamed from - SCM_ASSCM, SCM_ASWORD, SCM_CARW). - - * numbers.h (SCM_SRS, SCM_INUM): Corrected SCM_ASSCM/ASWORD fixes. - - * alist.c, eval.c, net_db.c, posix.c, print.c, snarf.h, struct.c, - tags.h: Fixed copyright notices. - - * struct.c, coop-threads.c: SCM_ASSCM/ASWORD fixes. - -2000-03-12 Marius Vollmer - - * init.c (scm_standard_stream_to_port): Check whether the file - descriptor is valid and substitute "/dev/null" when not. - -2000-03-12 Mikael Djurfeldt - - * coop-defs.h (struct timespec): Conditionally defined. - - * coop.c (coop_condition_variable_timed_wait_mutex): Use ETIMEDOUT - instead of ETIME. - - * readline.c (match_paren): Bugfix: First arg to select is not - number of descriptors but the number of the highest descriptor + - 1. - - This is a preliminary attempt at a cleanup of the threads support - code. It moves things to better places, makes arguments more - consistent with the POSIX API (which is used in GNOME's glib), and - adds new functionality. - - * readline.c (scm_init_readline): Added new arg to scm_init_mutex. - - * coop-defs.h (scm_mutex_trylock): New macro: alias for - coop_mutex_trylock. - (scm_cond_init): Changed definition to - coop_new_condition_variable_init. - - * coop.c: #include - (coop_timeout_qinsert): Moved here from iselect.c - (coop_new_mutex_init, coop_new_condition_variable_init): New - functions. The strange names are temporary. Use scm_mutex_init - and scm_cond_init instead. - (coop_mutex_trylock): New function. Uses errno.h:EBUSY. errno.h - is ANSI C, but should we check for individual error codes in - configure.in? - (coop_condition_variable_timed_wait_mutex): New function. - (coop_key_create, coop_setspecific, coop_getspecific, - coop_key_delete): New functions. - - * iselect.c (coop_timout_qinsert): Moved to coop.c - -2000-03-11 Mikael Djurfeldt - - * pairs.h (SCM_SETAND_CAR, SCM_SETAND_CDR, SCM_SETOR_CAR, - SCM_SETOR_CDR): Corrected SCM_ASSCM/WORD fixes. - - * tags.h (SCM_VOIDP_TEST): Renamed from VOIDP_TEST. - Layout cleanups. - - * objects.h (SCM_CLASS_FLAGS, SCM_OBJ_CLASS_FLAGS, - SCM_SET_CLASS_INSTANCE_SIZE), struct.h (SCM_STRUCT_VTABLE_DATA), - proc.h (SCM_CLOSCAR): SCM_ASSCM/WORD fixes. - - * eval.c (scm_lookupcar1): Inserted SCM_ASWORD in expressions - dealing with ilocs. - -2000-03-11 Dale P. Smith , applied by Greg J. Badros, - - * numbers.c (scm_copy_big_dec, scm_copy_smaller, scm_big_ior, - scm_big_xor, scm_big_and, scm_big_test): Added new lowlevel bignum - logical functions from SCM. - - (logand, logior, logxor, logtest, logbit?): Extended scheme - logical functions to use bignums from SCM. - - (lognot): Removed call to `SCM_VALIDATE_INUM' that prevented - lognot from using bignums. - -Thu Mar 9 11:33:25 2000 Greg J. Badros - - * vectors.h (SCM_VELTS_AS_STACKITEMS): Added this macro to help in - eliminating some warnings. - - * unif.c, strports.c, print.c, options.c: Fix some warnings on - mis-use of SCM/long - - * gc.c, gc.h: Added scm_return_first_int(), and added comment re: - what the scm_return_first* functions do. - -2000-03-09 Han-Wen Nienhuys , applied by Greg J. Badros, - - * libguile/*.[ch]: make a distinction between SCM as a generic - name for a Scheme object (now a void*), and SCM as 32 bit word for - storing tags and immediates (now a long int). Introduced - SCM_ASWORD and SCM_ASSCM for conversion. Fixed various dubious - code in the process: arbiter.c (use macros), unif.c (scm_array_p), - -Wed Mar 8 10:15:59 2000 Greg J. Badros - - * numbers.c: Use SCM_VALIDATE_LONG_COPY, and longs, not ints, in - various logXXX primitives. Thanks Eric Moore! - -Tue Mar 7 08:05:22 2000 Greg J. Badros - - * run-test, remaining-docs-needed: Added these scripts. The - second one is only temporary until the docstring additions are - complete. run-test may best live on, but is here mostly for - convenience and awareness for now. - - * hash.c: Docs, minor cleanup patch from Dirk Herrman. - -Thu Mar 2 16:06:58 2000 Greg J. Badros - - * error.h, error.c: Added `scm_wrong_type_arg_msg' to support - displaying the expected type. Use SCM_LISTn in a couple places - instead of scm_cons-ing by hand. - - * __scm.h: Added SCM_ASSERT_TYPE macro. - - * validate.h, scm_validate.h: Added the former, as a renamed - version of the latter with SCM_ASSERT_TYPE used in - SCM_MAKE_VALIDATE (instead of just SCM_ASSERT) - - * Makefile.am: Rename scm_validate.h to validate.h. - - * *.c, *.h: Include validate.h, not scm_validate.h (old name's - prefix was superfluous). - -Thu Mar 2 15:33:12 2000 Greg J. Badros - - * hashtab.c: Improved documentation for lots of functions. Added - handwritten docs for `hash-fold'. - -Thu Mar 2 15:13:25 2000 Greg J. Badros - - * list.c: Added hand-written docs for `del{q,v,ete}1!'. - -Thu Mar 2 12:38:30 2000 Greg J. Badros - - * list.c: Moved append docs to append! Thanks Dirk Hermann. Also, - added append docs from R4RS. - - * strings.c: Docstring typo fix, + eliminate unneeded IMP tests. - Thanks Dirk Hermann! - - * chars.h: Provide SCM_CHARP, SCM_CHAR, SCM_MAKE_CHAR and - deprecate SCM_ICHRP, SCM_ICHR, SCM_MAKICHR. Thanks Dirk Hermann! - - * *.h, *.c: Use SCM_CHARP, SCM_CHAR, SCM_MAKE_CHAR throughout. - Drop use of SCM_P for function prototypes... assume an ANSI C - compiler. Thanks Dirk Hermann! - -Sat Feb 19 12:20:12 2000 Greg J. Badros - - * ports.c: Made `set-port-column!' and `set-port-line!' each - return SCM_UNSPECIFIED instead of a (not-scheme-object) integer - that caused a seg fault. Also fixed `set-port-column!'s - docstring. Thanks Han-Wen Nienhuys for finding the bug! - -Sun Feb 13 19:11:42 2000 Greg J. Badros - - * arbiters.c, eq.c, gc.c, guardians.c, list.c, ports.c, print.c, - regex-posix.c, scmsigs.c, stime.c, strings.c, variable.c, stime.c, - strings.c, variable.c: Added lots of documentation, cleaned up - some existing documentation. Occasionally changed formal params - to match docs. Also folded an #ifdef into the inners of a - primitive instead of having two copies of the primitive - (`get-internal-real-time', from stime.c) - -Sun Feb 13 18:12:19 2000 Greg J. Badros - - * ports.c: Added docs for primitives missing them. Written by - hand. - -Sun Feb 13 09:40:36 2000 Greg J. Badros - - * guile-doc-snarf.in: Use ${AWK} -f guile-func-name-check, not - just execing guile-func-name-check. Thanks Michael Livshin! - -Thu Feb 10 11:43:23 2000 Greg J. Badros - - * guile-snarf.awk.in: Tweak to work with Sun/HP awk, removed some - dead code. Patch from Michael Livshin. - - * guile-doc-snarf.in: Tweak to work with Sun/HP sh. Patch from - Michael Livshin. - -2000-02-09 Gary Houston - - * init.c (scm_init_standard_ports): when stdout is a tty, make the - current-output-port unbuffered by default. this is less confusing - for interactive use. it was line-buffered because of a - performance problem with unbuffered ports, but I think it will be - OK now. - -2000-02-08 Gary Houston - - * __scm.h: don't define long_long or ulong_long if HAVE_LONG_LONGS - is not defined. - - * stime.c (scm_localtime, scm_mktime): if neither HAVE_TM_ZONE nor - HAVE_TZNAME are defined, use an empty string instead of giving two - spurious compile-time errors. - -Tue Feb 8 13:57:46 2000 Greg J. Badros - - * ports.c: Doc patches from Richard Kim. Pasted from MIT Scheme. - Thanks Richard! - -Mon Feb 7 09:07:31 2000 Greg J. Badros - - * macros.c: Doc patches from Richard Kim. Pasted from scm.texi. - -Sun Feb 6 20:26:21 2000 Greg J. Badros - - * pairs.c: Doc patches from Richard Kim. Pasted from MIT Scheme - (which is GNU GPL'd). - -2000-01-31 Gary Houston - - * strings.h: don't use SCM_P. don't include . - * error.c, gh_data.c, ports.c, script.c, strop.c: include . - - * strings.c (scm_string_ref): make the 2nd argument compulsory. - previously it defaulted to zero for no good reason that I can see. - use a local variable for SCM_INUM (k). replace - SCM_VALIDATE_INUM_DEF with SCM_VALIDATE_INUM_COPY. - - (scm_makfromstr): cosmetic changes. - - (scm_string): Accept only chars in the list, not strings, for - conformance to R5RS (particularly for list->string, which is - supposed to be the inverse of string->list.) remove - SCM_DEFER_INTS/SCM_ALLOW_INTS, which is unnecessary since - scm_makstr handles the cell allocation. when reporting wrong-type - arg, don't report the position as 1. - - * posix.c (scm_init_posix): intern PIPE_BUF if it's defined. - -2000-01-29 Gary Houston - - * posix.c (scm_pipe): rewrote the docstring. - - * filesys.c (scm_select, retrieve_select_type, get_element, - fill_select_type, set_element): modified so that Scheme - "select" tests port buffers for the ability to provide input - or accept output. Previously only the underlying file descriptors - were checked. Rewrote the docstring. - -Thu Jan 27 10:14:25 2000 Greg J. Badros - - * vectors.c, symbols.c, strorder.c: Documentation cut and pasted - from Gregg Reynolds. Thanks Gregg! - -Thu Jan 27 09:59:38 2000 Greg J. Badros - - * strop.c (scm_i_index): Obfuscated commented-out SCM_DEFINE by - adding "x" prefix to the line so that guile-func-name-check - doesn't complain unnecessarily. - -Wed Jan 26 17:33:52 2000 Greg J. Badros - - * throw.c: Factor out an #ifdef/#else/#endif choice more finely - for maintainability. - - * strop.c: Documentation added by Gregg A. Reynolds. Pasted in - from qdocs, RnRs. - -Wed Jan 26 10:02:11 2000 Greg J. Badros - - * tag.c: Added doc for `tag', but mark as deprecated since Mikael - suggests removing tag.c altogether (and using a new `class-of' - instead). - - * strings.c: Added documentation from Gregg A. Reynolds. Edited - a bit by me to use FOO instead of @var{foo} and to have the - summary come before preconditions on input. Also dropped trailing - (rnrs) note. - - * gsubr.c: Do not use SCM_DEFINE for `gsubr-apply'. Register the - function with scm_make_subr_opt w/ last arg of 0 so it is not - visible at the Scheme level. Mikael says that this is the right - thing because the first arg to the proc is the guts of a compiled - closure and shouldn't be exposed to the Scheme level. - -Tue Jan 25 17:15:47 2000 Greg J. Badros - - * sort.c: typo in comment fixed. - - * keywords.c: Added documentation. - - * guardians.c: Added documentation (could be better). - - * gc.c: Added docs for gc-set-debug-check-freelist. - - * eq.c: Added docs for eq?, eqv? equal? abridged from R4RS. - - * boolean.c: Added docs for `not', `boolean?' (by hand). - -Tue Jan 25 13:28:56 2000 Greg J. Badros - - * random.c: Added documentation, from SLIB page: - http://angela.ctrl-c.liu.se/~calle/scheme/slib_toc.html - -Mon Jan 24 17:50:20 2000 Greg J. Badros - - * variable.c, version.c: Added documentation, written by hand - since I could not find anything already written that was - relevant. - -2000-01-23 Gary Houston - - * filesys.c (scm_chown): omit port/fdes support if HAVE_FCHOWN is - not defined (thanks to Richard Y. Kim). - -Thu Jan 20 13:00:38 2000 Greg J. Badros - - * Makefile.in: Removed, this is auto-generated. - -Thu Jan 20 11:33:47 2000 Dirk Hermann --applied 01/20/00 gjb - - * list.c: Put some variable initialization code at the point of - declaration; Added a comment for list*; Formatting changes. - - * load.c: use SCM_NNULLP to make sure the end of a list is not - reached yet. - -2000-01-18 Mikael Djurfeldt - - * backtrace.c (scm_display_error_message): Bugfix: Don't use - result of scm_list_p as C boolean. - (scm_display_error_message, scm_set_print_params_x): Use new - validation macros. (Thanks to Dirk Herrmann.) - - * net_db.c (scm_resolv_error): Cast result from hstrerror. - - * strports.c (st_end_input): Inserted parenthesis to get operator - grouping correct. - - * list.h (scm_init_list): Removed SCM_P around prototypes. - - * fports.c, list.c, numbers.c, ports.c, stime.c, symbols.c, - filesys.c, posix.c: Converted docstrings to ANSI C format and - escaped " occurring inside string literals. - -Tue Jan 18 13:21:08 2000 Mikael Djurfeldt - - * posix.c (scm_mknod): Escape " occuring inside docstring. - -2000-01-18 Mikael Djurfeldt - - * alist.c, chars.c, debug.c, dynl.c, dynwind.c, error.c, eval.c, - evalext.c, filesys.c, gc.c, hash.c, hashtab.c, ioext.c, - keywords.c, list.c, load.c, macros.c, net_db.c, numbers.c, - objprop.c, ports.c, posix.c, print.c, procprop.c, procs.c, - ramap.c, regex-posix.c, root.c, scmsigs.c, simpos.c, socket.c, - stacks.c, stime.c, strings.c, strop.c, strports.c, struct.c, - symbols.c, throw.c, unif.c, vectors.c, version.c, vports.c, - weaks.c: Converted docstrings to ANSI C format. - - * filesys.c (scm_chmod), simpos.c (scm_system), version - (scm_version), vports (scm_make_soft_port): Escape " occuring - inside docstring. - -Mon Jan 17 11:41:22 2000 Greg J. Badros - - * scm_validate.h: Added SCM_VALIDATE_ULONG_COPY, - SCM_VALIDATE_LONG_COPY - - * numbers.c: Use SCM_VALIDATE_ULONG_COPY, instead of - SCM_VALIDATE_INUM_COPY to let bigger numbers be used. Rename a - couple of formal arguments (and fix their uses) to make arguments - match the documentation. - -2000-01-14 - - * Makefile.am: Augment path when running guile-doc-snarf so - guile-func-name-check is found. - -Fri Jan 14 09:34:55 2000 Greg J. Badros - - * scm_validate.h (SCM_NUM2LONG_DEF): Fix this macro to just use - def, not SCM_MAKINUM(def); thanks Janis Bzerins! - -Wed Jan 12 00:06:53 2000 Greg J. Badros - - * net_db.c (s_scm_inet_makeaddr): Use SCM_NUM2ULONG since that's - the way guile-1.3.4 worked, but #if 0 out the version using - SCM_VALIDATE_INUM_COPY for stricter testing. - -Tue Jan 11 18:24:18 2000 Greg J. Badros - - * guile-doc-snarf.in: Use new $fullfilename for running - guile-func-name-check, and put "$fullfilename" and "$filename" in - quotes at uses to make sure re-splitting on whitespace does not - occur (so filenames w/ embedded whitespace would work okay, though - I sure hope we never have to deal with that! :-) ). Thanks to - Mikael for pointing out the source_dir != build_dir was broken. - -Tue Jan 11 17:42:40 2000 Greg J. Badros - - * scm_validate.h: Added SCM_NUM2LONG_DEF macro. Make - SCM_OUT_OF_RANGE use SCM_MAKINUM, not scm_long2num. Added - SCM_COERCE_ROSTRING macro. Added SCM_VALIDATE_NONEMPTYLIST - macro. Fix SCM_VALIDATE_STRINGORSUBSTR macro to not use SLOPPY - variants. - - * ports.c (scm_port_closed_p): Validate that the arg is a PORT, - then return whether it's an open port (was validating that it was - an open port -- this was a bug I introduced back in December, but - my careful reading of diffs caught it). - - * numbers.c: Recombine the two conditional-compilation paths for - all the log* primitives -- they were split based on #ifndef - scm_long2num; factored out a SCM_LOGOP_RETURN macro, and fixed - some bugs and inconsistencies in the two sets of implementations. - (scm_lognot) Fixed *atrocious* re-use of a SCM as an integer! - - * ioext.c: Use SCM_ASSERT_RANGE in a couple places, and - SCM_VALIDATE_INUM_COPY once where it should've been used. - - * fluids.c (scm_internal_with_fluids): Use - SCM_VALIDATE_LIST_COPYLEN. - - * filesys.c: Use SCM_NUM2LONG instead of SCM_VALIDATE_INUM_COPY; - this is questionable as it relaxes type safety, but other changes - were useful and all SCM_NUM2LONG's should probably be - revisited. Use SCM_OUT_OF_RANGE, SCM_WRONG_TYPE_ARG. - - * evalext.c: line-break change on 1 line. - - * eval.c (nconc2last): Takes a non-empty list as its first - argument, not just a list. - - * dynl.c: Use new SCM_COERCE_ROSTRING macro. - -Tue Jan 11 15:44:23 2000 Greg J. Badros - - * dynl.c, feature.c, filesys.c, fports.c, list.c, load.c, - net_db.c, sort.c, stacks.c, unif.c: Use SCM_WTA, SCM_MISC_ERROR - where possible. - - * symbols.c (scm_sysintern0): Fixed the function name in a - scm_misc_error invocation. - - * print.c (scm_simple_format): Do not need SCM_COERCE_SUBSTR, and - use scm_return_first to ward off latent GC bug that Mikael caught. - - * async.c: Use SCM_VALIDATE_ASYNC_COPY one place where it wasn't - used before but should've been. - -2000-01-12 Mikael Djurfeldt - - * snarf.h (SCM_PROC1): Replaced SCM (*) (...) with - SCM_FUNC_CAST_ARBITRARY_ARGS. - -Tue Jan 11 13:44:07 2000 Greg J. Badros - - * guile-func-name-check.in: Added this script to statically check - #define FUNC_NAME, #undef FUNC_NAME in the source. - - * sort.c, posix.c: Fix #undef FUNC_NAME lines to not have trailing - redundant comment, semicolon; caught by new guile-func-name-check - script. - - * debug.c: Fix mistaken #define FUNC_NAME for scm_make_iloc. - Caught by new guile-func-name-check-script. - - * Makefile.am: Added guile-func-name-check to bin_SCRIPTS - - * ramap.c: Fix #if 0'd out code to be syntactically acceptable to - guile-func-name-check. - - * guile-doc-snarf.in: Run guile-func-name-check on the file before - doing the snarf. - -Tue Jan 11 11:31:10 2000 Greg J. Badros - - * fports.c, ports.c, ports.h, strports.c, vports.c: Make write - port function take const void*, not void*. - -Tue Jan 11 11:18:07 2000 Greg J. Badros - - * scm_validate.h, chars.c, ports.c, print.c, read.c, strings.c, - strop.c: Use SCM_VALIDATE_ICHR, SCM_VALIDATE_ICHR_COPY instead of - SCM_VALIDATE_CHAR, SCM_VALIDATE_CHAR_COPY. Change made for - consistency with the other macros dealing with immediate - characters. (Similar to INT -> INUM change a week or so ago). - -Tue Jan 11 10:41:46 2000 Greg J. Badros - - * dynl.c, error.c, eval.c, feature.c, filesys.c, fports.c, list.c, load.c, - net_db.c, read.c, socket.c: Update error messages to use ~A for - %s, ~S for %S to work with new `simple-format' format and be - standardized better. - - * print.h, print.c (scm_simple_format): Added `simple-format' - primitive. It's the old scm_display_error, with ARGS now a rest - parameter, and the destination first instead of last (and a couple - new capabilities inspired by `format' -- #t as destination means - current-output-port, #f means return the formatted text as a - string. - - * gh.h, gh_data.c, ports.h, ports.c: Added some missing const specifications. - - * backtrace.c (scm_display_error_message): Rewrote to use - scm_simple_format() procedure. - - * __scm.h: Added commented-out #define of GUILE_DEBUG_FREELIST - -2000-01-09 Marius Vollmer - - Finally applied the libltdl patch from Thomas Tanner, with slight - modifications. - - * DYNAMIC-LINKING: Removed because it is obsolete. - * dynl.c: Use ANSI prototypes. - (sysdep_dynl_link): Use lt_dlopenext instead of lt_dlopen. - * scmconfig.h.in: Do not change, as it is automatically generated. - - 1999-07-25 Thomas Tanner - - * dynl-dl.c, dynl-dld.c, dynl-shl.c, dynl-vms.c: deleted - (obsolete) - * Makefile.am: likewise, add INCLTDL (libltdl headers) to - INCLUDES, set dlpreopened files in LDFLAGS, link libguile - against libltdl - * dynl.c: use libltdl if DYNAMIC_LINKING is enabled, - * guile.c: register preloaded modules - * scmconfig.h.in: remove obsolete symbols - -2000-01-09 Gary Houston - - * These changes should make it unnecessary to call tzset from - Scheme after modifying the TZ environment variable, even if the - system date facilities cache the value. - * stime.c (setzone, scm_localtime): added comments. - (tzset): don't define a noop tzset macro if HAVE_TZSET not defined. - (setzone): don't call tzset. - (restorezone): call tzset only if HAVE_TZSET is defined. - (scm_tzset): don't define if HAVE_TZSET not defined. Change the - doc string to indicate that this procedure isn't likely to do - anything useful. - (scm_localtime, scm_strftime, scm_mktime): call tzset if - LOCALTIME_CACHE is defined. - -2000-01-09 Mikael Djurfeldt - - * posix.c (scm_sync): Return SCM_UNSPECIFIED. - -2000-01-09 Gary Houston - - * eval.c: define scm_unbound_variable_key ('unbound-variable). - scm_lookupcar1: throw an error with key 'unbound-variable instead - of 'misc-error when an unbound variable is encountered. - - * filesys.c (scm_mkdir, scm_rmdir, scm_getcwd, scm_select, - scm_symlink, scm_readlink, scm_lstat), - posix.c (scm_setpgid, scm_setsid, scm_ctermid, scm_tcgetpgrp, - scm_tcsetpgrp, scm_uname, scm_setlocale, scm_mknod, scm_nice, - scm_sync), - simpos.c (scm_system), - stime.c (scm_times, scm_strptime): - move the HAVE_XXX feature tests out of the procedure bodies. - don't use SCM_SYSMISSING. - scm_validate.h (SCM_SYSMISSING): removed. - error.h, error.c (scm_sysmissing): comment that this is deprecated. - see ChangeLog entry for 1999-12-28. - -Sat Jan 8 19:52:04 2000 Greg J. Badros - - * scm_validate.h (SCM_VALIDATE_BOOL_COPY): Fix typo. - -Sat Jan 8 17:06:46 2000 Greg J. Badros - - * backtrace.c: Fix spelling typo in a comment. - - * snarf.h: Use new SCM_DOCS macro to encapsulate the non SCM_INIT - text. Reformatted some of the expansions. - -Fri Jan 7 15:50:46 2000 Greg J. Badros - - * scm_validate.h (SCM_OUT_OF_RANGE): Use scm_out_of_range_pos to - report the position of the argument. - - * error.h, error.c (scm_out_of_range_pos): Added this function to - take extra "pos" argument, the position number of the errant - argument. - - * debug.c: Use SCM_OUT_OF_RANGE instead of scm_out_of_range. - - * snarf.h: Use SCM_HERE and SCM_INIT as names, not SCM_NOTSNARF - and SCM_SNARFING. Also put the %%% in the SCM_INIT since Mikael - prefers that and I'm reasonably indifferent. - -Fri Jan 7 15:03:32 2000 Greg J. Badros - - * snarf.h: Factor out differences between C++ and non-C++ into - SCM_FUNC_CAST_ARBITRARY_ARGS macro. Modify all the snarf macro - definitions to use SCM_NOTSNARF and SCM_SNARFING macros (like - Mikael's macros, below, but changed names and SCM_SNARFING no - longer expands to include %%% -- that must appear in the argument - so that the token appears at the call-site as a reminder). - -2000-01-07 Mikael Djurfeldt - - * snarf.h (SCM_INSITU, SCM_INIT): New snarf macros for use in user - snarf macro definitions. - -2000-01-06 Mikael Djurfeldt - - * chars.c (scm_integer_to_char): Use Greg's nice - SCM_VALIDATE_INUM_RANGE macro for argument checking for closer - adherence to R5RS. - -Thu Jan 6 11:48:49 2000 Greg J. Badros - - * *.c, snarf.h: Replace GUILE_PROC1 with SCM_DEFINE1 throughout. - -Thu Jan 6 11:22:53 2000 Greg J. Badros - - * Makefile.am (ETAGS_ARGS): Switch to SCM_DEFINE, SCM_DEFINE1 - instead of GUILE_PROC. - -Thu Jan 6 11:21:49 2000 Greg J. Badros - - * alist.c: Do not report mismatch errors on some uses of `tmp' (do - this by using SCM_ARG2 instead of `2' in the SCM_VALIDATE_CONS - macro call. - -Thu Jan 6 09:54:33 2000 Dirk Herrmann --gjb applied - - * scm_validate.h: Remove some redundant NIMP tests. - - * alist.c: minimize scope of the tmp variables, and initialize - them when declared. The strange SCM_NIMP tests are replaced by - SCM_CONSP tests that more closely reflect the intended semantics. - However, we don't get a performance penalty here, because the - SCM_CONSP test was performed by the ALISTCELL test anyway. * The - extremely ugly use of ASRTGO macros was removed: The calls to - ASRTGO were not encapsulated by "#ifndef SCM_RECKLESS", but got a - label parameter that only exists when SCM_RECKLESS is not defined. - This works, because ASRTGO itself is defined in a way that it only - makes use of the label parameter if SCM_RECKLESS is not defined - (shudder!). Does guile make at all use of the possibility to - define SCM_RECKLESS? * Codesize is likely to be reduced, since - instead of two calls to SCM_ASSERT performed by the ALISTCELL test - we now only get one test. - - * list.c: Use SCM_NNULLP, not SCM_NIMP as appropriate. Also use - SCM_NULLP instead of SCM_IMP. Drop use of "register" keyword on - some variables in `list?'. Fix `reverse' and `reverse!' - primitives to handle improper lists better. - -Wed Jan 5 11:24:53 2000 Greg J. Badros - - * *.[ch]: Whitespace changes -- added space after SCM_VALIDATE_* - macros and SCM_DEFINE macros to match GNU coding standards. - -Wed Jan 5 11:04:24 2000 Greg J. Badros - - * *.[ch]: Replace GUILE_PROC w/ SCM_DEFINE. - -Wed Jan 5 10:59:06 2000 Greg J. Badros - - * *.[ch]: Replace SCM_VALIDATE_INT w/ SCM_VALIDATE_INUM for - better consistency with the names of other SCM_VALIDATE_ macros - and better conformance to guile naming policy. - -Wed Jan 5 10:50:39 2000 Greg J. Badros - - * ports.c (s_scm_close_all_ports_except): Use SCM_ARG1 in a - SCM_VALIDATE instead of 1 to avoid a check on the argument (since - it's not the actual name of the formal). - - * guile-snarf.awk.in: Do argument/number mismatch checking and - print warnings in an Emacs compile-mode parseable format. - - * struct.c: Use SCM_ASSERT_RANGE instead of SCM_ASSERT w/ - SCM_OUTOFRANGE as 3rd argument. - - * random.c: Fix argument/number mismatch (that I introduced :-( ). - - * __scm.h: Do not #define SCM_ARG* when snarfing; - lets us distinguish between 1 and SCM_ARG1 when snarfing as only - the former (using the number) requires the argument to match the - formal in the current argument snarfing check. - - * snarf.h: Give new definition of SCM_ASSERT when in - snarfing mode to output a lexically-identifiable sequence that the - guile-snarf.awk script uses to verify argument/position matching. - - * ramap.c: Remove extraneous #undef FUNC_NAME. - -Wed Jan 5 08:36:38 2000 Greg J. Badros - - * guile-doc-snarf.awk.in: Removed -- guile-snarf.awk.in is the - current version of the same functionality; it writes the .x output - to stdout instead of directly into the file. - -Wed Jan 5 08:15:04 2000 Greg J. Badros - - * unif.c, symbols.c, strings.c, stacks.c, random.c, print.c, - posix.c: Eliminated a bunch of SCM_NIMP(..)s that are now - redundant with the safer macros. Patch from Dirk Hermann applied - by hand. Thanks Dirk! - - * scm_validate.h: Added SCM_VALIDATE_VECTOR_OR_DVECTOR for some - uses in random.c. - - * ramap.c: whitespace change. - -Tue Jan 4 14:21:35 2000 Greg J. Badros - - * options.c, objects.c, keywords.c, gc.c: Some redundant SCM_NIMP - removals from Dirk Hermann. - - * alist.c: Rename formals to match the parameter names in the - documentation, updates to documentation. Thanks Dirk Hermann! - -2000-01-04 Mikael Djurfeldt - - * eval.c (SCM_CEVAL): Reverse order of - scm_stack_checking_enabled_p and SCM_STACK_OVERFLOW_P - (Thanks to Brad Knotwell.) - -Mon Jan 3 08:30:02 2000 Greg Harvey (applied --01/03/00 gjb) - - * gc.c (scm_debug_newcell): Added SCM_SETCAR of the newly - allocated cell. - - * pairs.h: Added a comment about the need for the SCM_SETCAR in - SCM_NEWCELL macro. - -Mon Jan 3 08:25:19 2000 Greg J. Badros - - * dynl-vms.c, debug.c, coop-threads.c, backtrace.c, eval.c: More - SCM_NIMP tests that were redundant are now eliminated. Patches - from Dirk Hermann applied by hand. - -The ChangeLog continues in the file: "ChangeLog-1996-1999" +The ChangeLog continues in the file: "ChangeLog-2000" diff --git a/libguile/ChangeLog-2000 b/libguile/ChangeLog-2000 new file mode 100644 index 000000000..dcd7e0f16 --- /dev/null +++ b/libguile/ChangeLog-2000 @@ -0,0 +1,5555 @@ +2000-12-30 Michael Livshin + + * guardians.c (guardian_print): for sharing guardians, print that + they are sharing. + (scm_guard, scm_get_one_zombie): place the critical section + barriers more correctly. + + * weaks.c (scm_scan_weak_vectors): move the calculation of the + `weak_keys' and `weak_values' flags out of the inner loop. + +2000-12-29 Michael Livshin + + * guardians.c: (greedily_guarded_prop): deleted. + (greedily_guarded_whash): new variable. a doubly-weak hash table + used to keep the "greedily guarded" object property. the previous + implementation (via primitive object properties) was incorrect due + to its only-the-key-is-weak semantics. + (scm_guard, get_one_zombie, scm_init_guardians): use/init + `greedily_guarded_whash'. + +2000-12-28 Dirk Herrmann + + * eval.c (check_map_args), gh_data.c (gh_set_substr, + gh_scm2newstr, gh_get_substr, gh_symbol2newstr), print.c + (scm_iprin1): Use scm_remember_upto_here_1 instead of + scm_remember. + + * gc.[ch] (scm_remember_upto_here_1, scm_remember_upto_here_2, + scm_remember_upto_here): New functions. + + (scm_remember): Deprecated. + +2000-12-28 Dirk Herrmann + + * continuations.c (scm_make_continuation): Make variable cont + volatile to let the compiler know that it won't be clobbered by + longjmp. (It wouldn't be anyway, but for some reason the compiler + is not able to see that.) + +2000-12-28 Dirk Herrmann + + This patch re-introduces the unused member "properties" of + struct scm_subr_entry as requested by Mikael Djurfeldt. + + * procs.h (scm_subr_entry): Re-introduced member "properties". + + (SCM_SUBR_PROPS): Un-deprecated. + + * procs.c (scm_make_subr_opt, scm_mark_subr_table): Struct + scm_subr_entry has a member "properties" again. + +2000-12-28 Michael Livshin + + * guardians.c (mark_dependencies_in_tconc): new function. + (mark_dependencies): bug fix. mark the dependencies of the known + zombies, too. duh. + +2000-12-24 Michael Livshin + + * gc.c: (scm_gc_mark_dependencies): use SCM_EQ_P for SCMs, not + '=='. also, return after calling `scm_gc_mark'. + +2000-12-24 Michael Livshin + + * gc.c: (scm_gc_mark_dependencies): new function. like + `scm_gc_mark', but doesn't mark the argument itself. defined + using an arrangement similar to that in eval.c: `scm_gc_mark' and + `scm_gc_mark_dependencies' are derived from the same "template" + by ugly preprocessor magic. + + * gc.h: added prototype for `scm_gc_mark_dependencies'. + + * init.c (scm_init_guile_1): call the renamed + `scm_init_guardians'. + + * guardians.h: changed prototypes for `scm_make_guardian' and + `scm_init_guardians'. + + * guardians.c (guardian_t): added new fields `greedy_p' and + `listed_p'. + (GUARDIAN_P): predicate that says whether its argument is a + guardian. + (GUARDIAN_GREEDY_P, GUARDIAN_LISTED_P): new predicates. + (greedy_guardians, sharing_guardians): new variables. hold the + greedy and sharing live guardian lists, respectively. + (first_live_guardian, current_link_field): removed. + (greedily_guarded_prop): new variable. holds the "is greedily + guarded" object property. + (self_centered_zombies): new variable. stores guarded objects + that are parts of cycles. + (add_to_live_list): new function, introduced to decouple marking a + guardian and adding it to the live list. + (guardian_mark): call `add_to_live_list'. + (guardian_print): print whether the guardian is greedy or not. + also change "live" and "zombie" to "reachable" and "unreachable" + respectively, to be less confusing. + (scm_guard): if the guardian is greedy, test whether the object is + already greedily marked. throw an error if so. + (scm_get_one_zombie): if the guardian is greedy, remove the + "greedily guarded" property from the object. + (scm_make_guardian): add a new optional boolean argument which + says whether the guardian is greedy or sharing. + (guardian_gc_init): init the new live lists. + (mark_dependencies): new function. + (mark_and_zombify): new function. + (guardian_zombify): reworked to support the new guardian + semantics. move some logic to `mark_dependencies' and + `mark_and_zombify'. + (whine_about_self_centered_zombies): new function. installed in + the `after-gc-hook' to complain about guarded objects which are + parts of cycles. + (scm_init_guardians): init the new stuff. renamed from + `scm_init_guardian'. + +2000-12-23 Dirk Herrmann + + * procs.h (scm_subr_entry): Removed unused struct member + "properties". + + (SCM_SUBR_PROPS): Deprecated. + + * procs.c (scm_make_subr_opt, scm_mark_subr_table): Struct + scm_subr_entry does not have a member "properties" any more. + +2000-12-22 Dirk Herrmann + + * procs.h (scm_subr_entry): Removed unused struct member + "documentation". + + (SCM_SUBR_DOC): Deprecated. + + * procs.c (scm_make_subr_opt): Eliminate use of scm_intern0 in + favor of scm_str2symbol. Similarly, prefer scm_sysintern over + scm_sysintern0. + + (scm_make_subr_opt, scm_mark_subr_table): Struct scm_subr_entry + does not have a member "documentation" any more. + +2000-12-21 Dirk Herrmann + + * eval.c (restore_environment): Make sure that changes to the + current environment will take effect when re-entering the dynamic + scope. + +2000-12-21 Dirk Herrmann + + * goops.h (SCM_PUREGENERICP): Include the SCM_STRUCTP test. + + * goops.c (scm_sys_invalidate_method_cache_x, scm_m_atdispatch, + scm_pure_generic_p): The SCM_STRUCTP test is implied. + +2000-12-20 Gary Houston + + * continuations.c (continuation_apply): subtract the length of + continuation->dynenv, not the dynenv itself. I broke it last + time I changed this file. thanks to Bernard Urban. + +2000-12-16 Dirk Herrmann + + * goops.c (remove_duplicate_slots, maplist, + scm_sys_initialize_object, scm_sys_prep_layout_x, + scm_sys_inherit_magic_x, scm_instance_p, + scm_sys_set_object_setter_x, scm_sys_invalidate_method_cache_x, + scm_compute_applicable_methods, scm_m_atdispatch, + scm_pure_generic_p): Remove redundant SCM_N?IMP tests. + +2000-12-16 Keisuke Nishida + + * validate.h (SCM_WRONG_NUM_ARGS): New macro. + * goops.h: #include "libguile/validate.h" + (SCM_CLASSP, SCM_GENERICP, SCM_METHODP): Moved from goops.c with + prefix "SCM_". + (SCM_VALIDATE_INSTANCE, SCM_VALIDATE_ACCESSOR, SCM_VALIDATE_CLASS, + SCM_VALIDATE_GENERIC, SCM_VALIDATE_METHOD): New macros. + * goops.c (CLASSP, GENERICP, METHODP): Moved to goops.h with + prefix "SCM_". + (scm_sys_compute_slots, scm_sys_initialize_object, + scm_sys_prep_layout_x, s_sys_inherit_magic_x, scm_instance_p, + scm_class_name, scm_class_direct_supers, scm_class_direct_slots, + scm_class_direct_subclasses, scm_class_direct_methods, + scm_class_precedence_list, scm_class_slots, scm_class_environment, + scm_generic_function_name, scm_generic_function_methods, + scm_method_generic_function, scm_method_specializers, + scm_method_procedure, scm_accessor_method_slot_definition, + scm_make_unbound, scm_unbound_p, scm_assert_bound, + scm_at_assert_bound_ref, scm_sys_fast_slot_ref, + scm_sys_fast_slot_set_x, scm_slot_ref_using_class, + scm_slot_set_using_class_x, scm_slot_bound_using_class_p, + scm_slot_exists_using_class_p, scm_slot_ref, scm_slot_set_x, + scm_slot_bound_p, scm_slots_exists_p, scm_sys_allocate_instance, + scm_sys_set_object_setter_x, scm_sys_modify_instance, + scm_sys_modify_class, scm_sys_invalidate_class, + scm_sys_invalidate_method_cache_x, scm_generic_capability_p, + scm_enable_primitive_generic_x, scm_primitive_generic_generic, + scm_make, scm_find_method, scm_sys_method_more_specific_p, + scm_pure_generic_p, scm_sys_goops_loaded): Replaced SCM_PROC by + SCM_DEFINE. Use validate macros defined above. + (scm_assert_bound, scm_at_assert_bound_ref, scm_sys_goops_loaded): + Declared as static functions. + (s_class_of, scm_class_of): Replaced SCM_PROC by SCM_DEFINE + in object.c. + * object.c (scm_class_of): Use SCM_DEFINE. + +2000-12-16 Keisuke Nishida + + * symbols.h (scm_symbols_prehistory): Added prototype. + +2000-12-16 Dirk Herrmann + + * environments.[ch] (scm_system_environment): New variable, will + replace scm_symhash soon. We may decide for a better name and + also to split this up into a set of environments later. + + (scm_environments_prehistory): Initialize scm_system_environment. + + * init.c (scm_init_guile_1): scm_environments_prehistory requires + storage to be initialized. + +2000-12-15 Dirk Herrmann + + * eval.c (change_environment, inner_eval, restore_environment): + New functions. + + (scm_eval): Bring the global variable that holds the current + environment up to date when entering or leaving the scope of the + evaluated code. Thanks to Matthias Koeppe for the bug report. + +2000-12-13 Dirk Herrmann + + * numbers.c (scm_init_numbers): Re-introduced bindings for + most-positive-fixnum and most-negative-fixnum as requested by + Mikael Djurfeldt. + +2000-12-12 Dirk Herrmann + + The variable scm_symbols is made static within symbols.c and + renamed to symbols. The initialization of the symbols hash table + is done in function scm_symbols_prehistory. + + * gc.c (scm_init_storage): Don't initialize scm_symbols. Don't + define most-positive-fixnum, most-negative-fixnum and + bignum-radix. + + * init.c (scm_init_guile_1): Call scm_symbols_prehistory. + + * root.h (scm_symbols): Not in scm_sys_protects any more. + + * symbols.c (symbols): Renamed from scm_symbols and made static. + + (scm_mem2symbol): scm_symbols is renamed to symbols. + + * symbols.[ch] (scm_symbols_prehistory): Added. + +2000-12-12 Dirk Herrmann + + * gc.c (scm_init_storage), root.h (scm_weak_symhash, scm_symbols): + Removed the former scm_weak_symhash hash table. Added scm_symbols + hash table. + + * stacks.c (get_applybody): scm_sym2vcell may return #f. + + * symbols.c (scm_mem2symbol): This function is now responsible + for creating symbol objects and storing them in the global + scm_symbols hash table. + + (scm_str2symbol): Rewritten in terms of scm_mem2symbol. + + (scm_sym2vcell): For system bindings, there is now only one + obarray - scm_symhash. If scm_sym2vcell is called to look up a + symbol that can't be found and shall not be created, #f is + returned. Most callers of scm_sym2vcell have expected this + behaviour anyway. + + (scm_intern_obarray_soft): Removed reference to scm_weak_symhash + from comment. + + (scm_intern_obarray_soft, scm_sysintern0_no_module_lookup): These + functions are not responsible for symbol creation any more, only + for creation of bindings. + + (scm_symbol_value0): Don't use scm_intern_obarray_soft to create + a symbol object. + + (scm_symbol_interned_p): scm_weak_symhash is removed. + + * symbols.[ch] (scm_builtin_weak_bindings): Removed. There are + no weak bindings any more. + +2000-12-12 Dirk Herrmann + + * hooks.c (scm_create_hook), script.c + (scm_compile_shell_switches), snarf.h (SCM_VCELL, + SCM_GLOBAL_VCELL, SCM_VCELL_INIT, SCM_GLOBAL_VCELL_INIT): Create + a binding in one go (instead of first creating a vcell and then + setting its cdr). + +2000-12-12 Dirk Herrmann + + * hash.[ch] (scm_string_hash), symbols.[ch] (scm_string_hash): + Moved function scm_string_hash to hash.c. + +2000-12-11 Marius Vollmer + + * gc_os_dep.c (scm_get_stack_base) [MSWIN32]: Added detection of + page size on the w32 architecture. Updated from Boehms gc5.2. + Thanks to Lars J. Aas! + +2000-12-11 Dirk Herrmann + + * debug.c (scm_sym_procname, scm_sym_dots, scm_sym_source, + scm_init_debug), eval.c (scm_sym_dot, scm_sym_arrow, scm_sym_else, + scm_sym_unquote, scm_sym_uq_splicing, scm_sym_enter_frame, + scm_sym_apply_frame, scm_sym_exit_frame, scm_sym_trace, + scm_init_eval), gsubr.c (scm_sym_name, scm_init_gsubr), srcprop.c + (scm_sym_filename, scm_sym_copy, scm_sym_line, scm_sym_column, + scm_sym_breakpoint), variable.c (anonymous_variable_sym): + Initialize symbols by using SCM_(GLOBAL_)?SYMBOL. + + * gc.c (scm_i_getenv_int): Moved here from init.c. + + * gc.[ch] (scm_init_storage): Read gc configuration environment + variables here, not in init.c. + + * init.c (scm_i_getenv_int): Moved to gc.c. + + (scm_init_guile_1): Move configuration code to scm_init_storage. + Make sure procprops get initialized early. + + * keywords.c (scm_c_make_keyword): Report amount of memory freed + by scm_must_free. Use scm_str2symbol instead of scm_sysintern0. + + * options.c (scm_init_opts): Use scm_str2symbol instead of + scm_sysintern0. + +2000-12-10 Mikael Djurfeldt + + * threads.h (SCM_MUTEXP): Typo: removed extra parenthesis. + +2000-12-08 Keisuke Nishida + + * tags.h (SCM_TYP16_PREDICATE): New macro. + * arbiters.c (scm_tc16_arbiter): Typed as scm_bits_t. + (arbiter_print): Renamed from prinarb. + (scm_init_arbiters): Don't use scm_make_smob_type_mfpe. + * async.c (tc16_async): Typed as scm_bits_t. + (SCM_ASYNCP): Use SCM_TYP16_PREDICATE. + (async_mark): Renamed from mark_async. + (scm_init_async): Updated. + * continuations.h (SCM_CONTINUATIONP): Use SCM_TYP16_PREDICATE. + * debug.c (scm_tc16_memoized, scm_tc16_debugobj): Typed as scm_bits_t. + (memoized_print): Renamed from prinmemoized. + (debugobj_print): Renamed from prindebugobj. + (scm_init_debug): Don't use scm_make_smob_type_mfpe. + * debug.h (scm_tc16_memoized, scm_tc16_debugobj): Typed as scm_bits_t. + (SCM_DEBUGOBJP, SCM_MEMOIZEDP): Use SCM_TYP16_PREDICATE. + * dynl.c (scm_tc16_dynamic_obj): Typed as scm_bits_t. + (dynl_obj_mark): Renamed from mark_dynl_obj. + (dynl_obj_print): Renamed from print_dynl_obj. + (scm_dynamic_object_p): Use SCM_TYP16_PREDICATE. + (scm_init_dynamic_linking): Updated. + * dynwind.c (SCM_GUARDSP): Use SCM_TYP16_PREDICATE. + (tc16_guards): Typed as scm_bits_t. + (guards_print): Renamed from printguards. + (scm_init_dynwind): Don't use scm_make_smob_type_mfpe. + * environments.c (scm_tc16_environment, scm_tc16_observer): + Typed as scm_bits_t. + (environment_mark, environment_free, environment_print, + observer_mark, observer_print, leaf_environment_mark, + leaf_environment_free, leaf_environment_print, + eval_environment_mark, eval_environment_free, + eval_environment_print, import_environment_mark, + import_environment_free, import_environment_print, + export_environment_mark, export_environment_free, + export_environment_print): Renamed from mark_environment, + free_environment, print_environment, mark_observer, + print_observer, mark_leaf_environment, free_leaf_environment, + print_leaf_environment, mark_eval_environment, + free_eval_environment, print_eval_environment, + mark_import_environment, free_import_environment, + print_import_environment, mark_export_environment, + free_export_environment, and print_export_environment, respectively. + (free_observer): Removed. + (leaf_environment_funcs, eval_environment_funcs, + import_environment_funcs, export_environment_funcs, + scm_environments_prehistory): Updated. + * environments.h (scm_tc16_environment, scm_tc16_observer): + Typed as scm_bits_t. + * eval.c (scm_tc16_promise): Typed as scm_bits_t. + (promise_print): Renamed from prinprom. + (scm_promise_p): Use SCM_TYP16_PREDICATE. + (scm_init_eval): Updated. + * eval.h (scm_tc16_promise): Typed as scm_bits_t. + * filesys.c (scm_tc16_dir): Typed as scm_bits_t. + (scm_init_filesys): Don't use scm_make_smob_type_mfpe. + * filesys.h (scm_tc16_dir): Typed as scm_bits_t. + * fluids.c (scm_tc16_fluid): Typed as scm_bits_t. + (fluid_print): Renamed from print_fluid. + (scm_init_fluids): Don't use scm_make_smob_type_mfpe. + * fluids.h (scm_tc16_fluid): Typed as scm_bits_t. + * fports.c (fport_print): Renamed from prinfport. + (scm_make_fptob): Updated. + * guardians.c (tc16_guardian): Typed as scm_bits_t. + * hooks.c (scm_tc16_hook): Typed as scm_bits_t. + (hook_print): Renamed from print_hook. + (scm_init_hooks): Updated. + * hooks.h (scm_tc16_hook): Typed as scm_bits_t. + (SCM_HOOKP): Use SCM_TYP16_PREDICATE. + * keywords.c (scm_tc16_keyword): Typed as scm_bits_t. + (keyword_print): Renamed from prin_keyword. + (scm_init_keywords): Don't use scm_make_smob_type_mfpe. + * keywords.h (scm_tc16_keyword): Typed as scm_bits_t. + * macros.c (scm_tc16_macro): Typed as scm_bits_t. + (scm_macro_p, scm_macro_type): Use SCM_TYP16_PREDICATE. + (scm_init_macros): Don't use scm_make_smob_type_mfpe. + * macros.h (scm_tc16_macro): Typed as scm_bits_t. + * mallocs.c (scm_tc16_malloc): Typed as scm_bits_t. + (malloc_free): Renamed from fmalloc. + (malloc_print): Renamed from prinmalloc. + (scm_init_mallocs): Don't use scm_make_smob_type_mfpe. + * mallocs.h (scm_tc16_malloc): Typed as scm_bits_t. + * modules.h (SCM_EVAL_CLOSURE_P): Use SCM_TYP16_PREDICATE. + (scm_tc16_eval_closure): Renamed from scm_eval_closure_tag. + (scm_standard_eval_closure, scm_init_modules): Updated. + * ports.c (scm_tc16_void_port): Typed as scm_bits_t. + * print.c (scm_tc16_port_with_ps): Typed as scm_bits_t. + (port_with_ps_print): Renamed from print_port_with_ps. + (scm_init_print): Updated. + * print.h (scm_tc16_port_with_ps): Typed as scm_bits_t. + (SCM_PORT_WITH_PS_P): Use SCM_TYP16_PREDICATE. + * random.c (scm_tc16_rstate): Typed as scm_bits_t. + (rstate_free): Renamed from free_rstate. + (scm_init_random): Don't use scm_make_smob_type_mfpe. + * random.h (scm_tc16_rstate): Typed as scm_bits_t. + (SCM_RSTATEP): Use SCM_TYP16_PREDICATE. + * regex-posix.c (scm_tc16_regex): Typed as scm_bits_t. + (regex_free): Renamed from free_regex. + (scm_init_regex_posix): Don't use scm_make_smob_type_mfpe. + * regex-posix.h (scm_tc16_regex): Typed as scm_bits_t. + * root.c (scm_tc16_root): Typed as scm_bits_t. + (root_mark): Renamed from mark_root. + (root_print): Renamed from print_root. + (scm_init_root): Updated. + * root.h (scm_tc16_root): Typed as scm_bits_t. + (SCM_ROOTP): Use SCM_TYP16_PREDICATE. + * smob.c (free_print): Renamed from freeprint. + (scm_smob_prehistory): Don't use scm_make_smob_type_mfpe. + * smob.h (SCM_SMOB_PREDICATE): Use SCM_TYP16_PREDICATE. + * srcprop.c (scm_tc16_srcprops): Typed as scm_bits_t. + (srcprops_mark): Renamed from marksrcprops. + (srcprops_free): Renamed from freesrcprops. + (srcprops_print): Renamed from prinsrcprops. + (scm_init_srcprop): Don't use scm_make_smob_type_mfpe. + * srcprop.h (scm_tc16_srcprops): Typed as scm_bits_t. + (SRCPROPSP): Use SCM_TYP16_PREDICATE. + * threads.c (scm_tc16_thread, scm_tc16_mutex, scm_tc16_condvar): + Typed as scm_bits_t. + * threads.h (scm_tc16_thread, scm_tc16_mutex, scm_tc16_condvar): + Typed as scm_bits_t. + (SCM_THREADP, SCM_MUTEXP, SCM_CONDVARP): Use SCM_TYP16_PREDICATE. + * throw.c (tc16_jmpbuffer): Renamed from scm_tc16_jmpbuffer. + (make_jmpbuf): Updated. + (tc16_lazy_catch): Typed as scm_bits_t. + (SCM_JMPBUFP, SCM_LAZY_CATCH_P): Use SCM_TYP16_PREDICATE. + (jmpbuffer_print): Renamed from printjb. + (lazy_catch_print): Renamed from print_lazy_catch. + (scm_init_throw): Don't use scm_make_smob_type_mfpe. + * unif.c (scm_tc16_array): Typed as scm_bits_t. + (array_mark): Renamed from markra. + (array_free): Renamed from freera. + (scm_init_unif): Don't use scm_make_smob_type_mfpe. + * unif.h (scm_tc16_array): Typed as scm_bits_t. + (SCM_ARRAYP): Use SCM_TYP16_PREDICATE. + * validate.h (SCM_VALIDATE_SMOB): Use SCM_TYP16_PREDICATE. + * variable.c (scm_tc16_variable): Typed as scm_bits_t. + (variable_print): Renamed from prin_var. + (variable_equalp): Renamed from var_equal. + (scm_markvar): Removed. + (scm_init_variable): Don't use scm_make_smob_type_mfpe. + * variable.h (scm_tc16_variable): Typed as scm_bits_t. + +2000-12-08 Dirk Herrmann + + * feature.c (scm_add_feature), gh_data.c (gh_symbol2scm), goops.c + (scm_sys_prep_layout_x, scm_make_class, scm_add_slot, + scm_init_goops), load.c (init_build_info), print.c + (scm_init_print), read.c (scm_lreadr), snarf.h (SCM_SYMBOL, + SCM_GLOBAL_SYMBOL), stacks.c (scm_init_stacks), struct.c + (scm_make_struct_layout), symbols.c (scm_sysintern0, + scm_string_to_symbol, scm_gensym), throw.c + (scm_handle_by_message): Use scm_mem2symbol or scm_str2symbol + instead of scm_intern_* to create a symbol object. + + * goops.c (Intern): Removed. + + (CALL_GF1, CALL_GF2, CALL_GF3, CALL_GF4, build_class_class_slots, + create_basic_classes, scm_class_name, scm_class_direct_supers, + scm_class_direct_slots, scm_class_direct_subclasses, + scm_class_direct_methods, scm_class_precedence_list, + scm_class_slots, scm_class_environment, + scm_generic_function_methods, scm_method_generic_function, + scm_method_specializers, scm_method_procedure, + scm_accessor_method_slot_definition, purgatory, scm_make, + make_stdcls, create_standard_classes, make_class_from_template, + scm_make_class): Replaced calls to Intern with calls to + scm_str2symbol. + + * ramap.c (init_raprocs): Use scm_symbol_binding instead of + scm_intern. + + * symbols.c (scm_sym2vcell): Add a bogus return to avoid compiler + warnings. + + * unif.c (scm_array_prototype): Fix prototype return value for + svects and llvects. + +2000-12-08 Dirk Herrmann + + * symbols.[ch] (scm_mem2symbol, scm_str2symbol): New functions. + These shall replace all those calls to scm_intern... which are + only required to create a scheme symbol from a C string or a field + of chars. + +2000-12-08 Dirk Herrmann + + * environments.c (DEFAULT_OBARRAY_SIZE), gc.c + (DEFAULT_SYMHASH_SIZE): Added to locally determine arbitrary + default values for obarrays, thus removing the dependency from + scm_symhash_dim. + + * environments.c (scm_make_leaf_environment, + scm_make_eval_environment), gc.c (scm_init_storage): Don't use + scm_symhash_dim. + + * symbols.c (NUM_HASH_BUCKETS), symbols.[ch] (scm_symhash_dim): + Removed. + + * symbols.c (scm_sym2vcell, scm_sysintern0_no_module_lookup): + Eliminate a redundant SCM_IMP test. + + (scm_sym2vcell, scm_sysintern0_no_module_lookup): + Don't assume a fixed obarray size any more. + +2000-12-07 Dirk Herrmann + + * gc.c (scm_init_gc): gc_async is already protected from gc, + namely via scm_asyncs. Thanks to Keisuke Nishida for pointing + this out. + +2000-12-07 Keisuke Nishida + + * smob.h (scm_smob_apply_0, scm_smob_apply_1, scm_smob_apply_2, + scm_smob_apply_3): Removed declarations. + (scm_set_smob_apply): Takes unsigned integers. + (scm_make_smob_type_mfpe, scm_set_smob_mfpe): Deprecated. + * smob.c (scm_smob_apply_0_000, scm_smob_apply_1_010, + scm_smob_apply_2_020): Removed. + (scm_set_smob_apply): Takes unsigned integers + some optimization. + (Thanks to Dirk Herrmann) + (scm_make_smob_type_mfpe, scm_set_smob_mfpe): Deprecated. + +2000-12-07 Keisuke Nishida + + * smob.h (SCM_SMOB_APPLICABLE_P, SCM_SMOB_APPLY_0, + SCM_SMOB_APPLY_1, SCM_SMOB_APPLY_2, SCM_SMOB_APPLY_3): New macros. + * eval.c (SCM_CEVAL, SCM_APPLY): Use macros above. + * procprop.c (scm_i_procedure_arity): Ditto. + * smob.c (scm_make_smob_type): Initialize gsubr_type. + +2000-12-06 Keisuke Nishida + + * smob.h (scm_smob_descriptor): New fields `apply_0', `apply_1', + `apply_2', and `apply_3'. + * smob.c (scm_make_smob_type): Init new fields. + (SCM_SMOB_APPLY0, SCM_SMOB_APPLY1, SCM_SMOB_APPLY2, SCM_SMOB_APPLY3): + New macros. + (scm_smob_apply_0_000, scm_smob_apply_0_010, scm_smob_apply_0_020, + scm_smob_apply_0_030, scm_smob_apply_0_001, scm_smob_apply_0_011, + scm_smob_apply_0_021, scm_smob_apply_0_error, + scm_smob_apply_1_010, scm_smob_apply_1_020, scm_smob_apply_1_030, + scm_smob_apply_1_001, scm_smob_apply_1_011, scm_smob_apply_1_021, + scm_smob_apply_1_error, + scm_smob_apply_2_020, scm_smob_apply_2_030, scm_smob_apply_2_001, + scm_smob_apply_2_011, scm_smob_apply_2_021, scm_smob_apply_2_error, + scm_smob_apply_3_030, scm_smob_apply_3_001, scm_smob_apply_3_011, + scm_smob_apply_3_021, scm_smob_apply_3_error): New functions. + (scm_set_smob_apply): Set new fields to the above functions. + (scm_smob_apply_0, scm_smob_apply_1, scm_smob_apply_2, + scm_smob_apply_3): Removed. + * eval.c (SCM_CEVAL, SCM_APPLY): Rewrote smob calls. + +2000-12-06 Dirk Herrmann + + * gc.c (scm_init_gc): gc_async must be protected from gc. I + wonder why we never ran into problems up to now... + +2000-12-06 Dirk Herrmann + + * gc.c (scm_init_gc): Don't create a binding for %gc-thunk. + +2000-12-06 Dirk Herrmann + + * gsubr.c: No need to include vector.h. + + (scm_gsubr_apply): Use SCM_GSUBR_MAX instead of hard-coded value. + Added FUNC_NAME wrapping. Improved (temporarily?) disabled + debugging code. Replaced SCM_IMP with SCM_NULLP. Eliminated call + to ASRTGO. + + (scm_init_gsubr): Eliminated outdated comment. + +2000-12-06 Dirk Herrmann + + * async.c (SCM_ASYNCP): Use SCM_TYP16 instead of SCM_GCTYP16. + + * eval.c (scm_m_vref, scm_m_vset, scm_m_define, SCM_CEVAL, + SCM_APPLY, scm_copy_tree): Remove commented code. + + (SCM_CEVAL, SCM_APPLY): Remove #ifdef CCLO conditionals. Without + CCLO being defined, guile would not compile at all anyway. + + * gc.h (SCM_GC8MARKP, SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, + SCM_GCCDR): Deprecated. + + * gdbint.c (unmark_port, remark_port, gdb_read), procs.c + (scm_mark_subr_table): Use SCM_(SET|CLR)?GCMARK(P)? instead of + SCM_(SET|CLR)?GC8MARK(P)?. + + * gh_data.c (gh_scm2char): Remove bogus ';'. + + * tags.h: Removed comment about GCTYP16 macro. + + * weaks.c (scm_mark_weak_vector_spines): Use SCM_CDR instead of + SCM_GCCDR. + +2000-12-05 Dirk Herrmann + + * print.c (scm_iprin1): Use scm_tc3_* codes instead of hardcoded + values. Added comment about tc3 codes that may appear in + immediates. Got rid of one goto command. + +2000-12-05 Dirk Herrmann + + * dynl.c (sysdep_dynl_link): Improved error reporting. + + * guardians.c: Changed the representation from a compiled closure + to an applicable smob. + + (guard1, CCLO_G): Removed. + + (guard, g_mark, g_print, scm_tc16_guardian, scm_guardian_gc_init, + scm_guardian_zombify): Renamed to guardian_apply, guardian_mark, + guardian_print, tc16_guardian, guardian_gc_init and + guardian_zombify, respectively. + + (guardian_free): Added, fixes a memory leak. + + (guardian_print): Don't use sprintf hack. + + (guardian_apply, scm_guard, scm_get_one_zombie, + scm_make_guardian): Don't use a compiled closure. + + (guardian_zombify): Prefer !SCM_NULLP over SCM_NIMP. No need to + use SCM_GCCDR any more. Simplified loop condition. + + (scm_init_guardian): Don't use scm_make_smob_type_mfpe for smob + initialization. Initialize applicable smob. + +2000-12-04 Dirk Herrmann + + * chars.c (scm_char_eq_p): Minor cleanup/optimization. + + * gc.c (scm_gc_mark): Don't use SCM_VELTS for CCLOs. + + * procprop.c (scm_i_procedure_arity): Separate handling of smobs + and CCLOs. + +2000-12-04 Dirk Herrmann + + * tags.h (scm_tc_free_cell, scm_tc16_big, scm_tc16_real, + scm_tc16_complex): Eliminate hard-coded value of scm_tc7_smob. + +2000-12-01 Dirk Herrmann + + * list.[ch] (scm_c_memq): Added as a fast C level alternative for + scm_memq for the case that the list parameter is known to be a + proper list. + + * goops.c (filter_cpl, remove_duplicate_slots, applicablep), + goops.h (SCM_SUBCLASSP): Use scm_c_memq if we are sure that we + pass proper lists. + +2000-12-01 Dirk Herrmann + + * goops.c (scm_sys_compute_slots, scm_i_get_keyword, + scm_get_keyword, scm_slot_ref_using_class, + scm_slot_set_using_class_x): Update the code to match guile's + current style (e. g. using SCM_DEFINE, adding comments, removing + unnecessary SCM_NIMP tests etc.). + +2000-11-30 Dirk Herrmann + + Thanks to Julian Satchell for the bug report: + + * coop-threads.c (scm_join_thread): Check whether a thread is + finished before trying to join it. + + * coop.c (coop_aborthelp, coop_join): When a thread finishes, its + stack base is not set to NULL any more. + +2000-11-28 Dirk Herrmann + + * strop.c (scm_i_index): Removed outdated comment. + +2000-11-28 Dirk Herrmann + + * struct.c (scm_struct_ref, scm_struct_set_x), symbols.c + (scm_intern_obarray_soft), symbols.h (SCM_ROUCHARS): Eliminate + use of SCM_SYMBOL_UCHARS by using chars instead of unsigned + chars. + + (SCM_SYMBOL_UCHARS): Removed. + +2000-11-26 Gary Houston + + * reimplementation of values, call-with-values as primitives: + + * values.c, values.h: new files. use a struct to contain multiple + values, similar to the previous Scheme-level implementation. + * Makefile.am: add values.c, values.h, values.x. + * continuations.c (continuation_apply): support R5RS multiple value + continuations. + * init.c: call scm_init_values. + * struct.h: define SCM_SET_STRUCT_PRINTER. + +2000-11-25 Gary Houston + + * use an applicable SMOB to represent continuations, instead of a + custom tc7 type. This will make it easier to support R5RS + multiple value continuations, without the use of a Scheme-level + wrapper. + + * continuations.c (scm_tc16_continuation, continuation_mark, + continuation_free, continuation_print, continuation_apply): + new SMOB support. + (scm_make_continuation): new procedure, replaces scm_make_cont + with a different interface. + (copy_stack_and_call, scm_dynthrow, scm_init_continuations): rewritten. + (CHEAP_CONTINUATIONS): removed non-working code completely. + (scm_call_continuation): removed. + * continuations.h (struct scm_contregs): add num_stack_items and + stack fields. previously stack was stored following this struct: + use a tail array instead. + (SCM_CONTINUATIONP): new macro. + (SCM_CONTINUATION_LENGTH, SCM_SET_CONTINUATION_LENGTH): + rewritten. + (SCM_SET_CONTREGS): removed. + * tags.h: removed scm_tc7_contin (was tag 61). + * debug.c, gc.c, hash.c, print.c, procprop.c, procs.c: + removed scm_tc7_contin support. + * eval.c: use scm_make_continuation instead of scm_make_cont. + don't set jump buffers here. remove scm_tc7_contin support. + * init.c, root.c: create SMOB continuation for rootcont instead + of scm_tc7_contin. call scm_init_continuations before + scm_init_root. + * root.c: remove support for static jmpbuf. It's not used by + default and I broke it. create SMOB continuation for rootcont. + * stacks.c: use SCM_CONTINUATIONP. + +2000-11-24 Matthias Koeppe + + * goops.c (filter_cpl, remove_duplicate_slots), goops.h + (SCM_SUBCLASSP): Fix previous change: In contrast to + scm_sloppy_memq the function scm_memq returns #f if the + object was not contained in the list. + +2000-11-24 Dirk Herrmann + + * goops.c: Include validate.h. + + (DEFVAR, scm_add_method): Don't use deprecated scm_eval2. + + (scm_sys_fast_slot_ref, scm_sys_fast_slot_set_x, + scm_m_atdispatch): Provide FUNC_NAME definition. Don't use + deprecated SCM_OUTOFRANGE macro. + + (scm_sloppy_num2ulong, scm_sys_logand): Removed. Guile's logand + function now provides the desired behaviour. + + * goops.c (filter_cpl, remove_duplicate_slots), goops.h + (SCM_SUBCLASSP): Don't use deprecated scm_sloppy_memq. + +2000-11-23 Dirk Herrmann + + * symbols.h (SCM_LENGTH_MAX): Deprecated. + + * unif.c (scm_make_uve): Use SCM_BITVECTOR_MAX_LENGTH and + SCM_UVECTOR_MAX_LENGTH instead of SCM_LENGTH_MAX. Postpone length + checks for strings and vectors to their constructors. Eliminate + redundant SCM_IMP test. + + (scm_dimensions_to_uniform_array): Postpone length checks to + scm_make_uve. + + * unif.h (SCM_BITVECTOR_MAX_LENGTH, SCM_UVECTOR_MAX_LENGTH): + Added. + +2000-11-23 Dirk Herrmann + + * gh_data.c (makvect), numbers.c (scm_mkbig, scm_adjbig), + strings.c (scm_makstr, scm_take_str), symbols.c + (scm_intern_obarray_soft, scm_sysintern0_no_module_lookup), unif.c + (scm_make_uve), vectors.c (scm_make_vector): Use appropriate + SCM_SET__(CHARS|BASE) macro instead of SCM_SETCHARS. + + * numbers.h (SCM_SET_BIGNUM_BASE), strings.h + (SCM_SET_STRING_CHARS), symbols.h (SCM_SET_SYMBOL_CHARS), unif.h + (SCM_SET_UVECTOR_BASE, SCM_SET_BITVECTOR_BASE), vectors.h + (SCM_SET_VECTOR_BASE): Added. + + * symbols.c (SCM_SETCHARS): Deprecated. + +2000-11-22 Dirk Herrmann + + * gc.c (scm_gc_sweep), unif.c (scm_make_uve): Don't allocate or + free memory for empty bitvectors. + + * gh_data.c (makvect), strings.c (scm_makstr, scm_take_str), + symbols.c (scm_intern_obarray_soft, + scm_sysintern0_no_module_lookup), unif.c (scm_make_uve): Use + appropriate SCM_SET__LENGTH macro instead of SCM_SETLENGTH. + + * strings.h (SCM_SET_STRING_LENGTH), symbols.h + (SCM_SET_SYMBOL_LENGTH), unif.h (SCM_SET_UVECTOR_LENGTH, + SCM_SET_BITVECTOR_LENGTH): Added. + + * symbols.h (SCM_SETLENGTH): Deprecated. + +2000-11-22 Dirk Herrmann + + * continuations.c (scm_make_cont): Use + SCM_SET_CONTINUATION_LENGTH instead of SCM_SETLENGTH. + + * continuations.h (SCM_SET_CONTINUATION_LENGTH): Added. + +2000-11-22 Dirk Herrmann + + * vectors.c (scm_make_vector), weaks.c (scm_make_weak_vector): + Use SCM_SET_VECTOR_LENGTH instead of SCM_SETLENGTH. + + * vectors.h (SCM_SET_VECTOR_LENGTH): Added. + +2000-11-22 Dirk Herrmann + + * dynl.c (scm_make_argv_from_stringlist), filesys.c (scm_dirname, + scm_basename), gh_data.c (gh_scm2newstr, gh_get_substr), hash.c + (scm_hasher), load.c (scm_parse_path, scm_search_path, + scm_primitive_load_path), numbers.c (scm_string_to_number), + ports.c (scm_unread_string), posix.c (scm_convert_exec_args, + environ_list_to_c, scm_putenv), print.c (scm_iprin1, + scm_simple_format), random.c (scm_seed_to_random_state), socket.c + (scm_fill_sockaddr, scm_send, scm_sendto), strings.c + (scm_string_ref, scm_substring, scm_string_append), strings.h + (SCM_STRING_COERCE_0TERMINATION_X), strop.c (scm_i_index, + scm_string_to_list, scm_string_copy), strorder.c + (scm_string_equal_p, scm_string_ci_equal_p, scm_string_less_p, + scm_string_ci_less_p), strports.c (scm_mkstrport), struct.c + (scm_make_struct_layout), symbols.c (scm_string_to_symbol, + scm_string_to_obarray_symbol, scm_gensym, scm_gentemp): Replace + calls to SCM_ROU?CHARS with the corresponding call to + SCM_STRING_U?CHARS. + + * symbols.h (SCM_ROCHARS, SCM_ROUCHARS): Deprecated. + +2000-11-21 Dirk Herrmann + + * ports.c: Include eval.h. + + * strings.c (scm_string_set_x), strings.h (SCM_RWSTRINGP), + validate.h (SCM_VALIDATE_RWSTRING): Deprecate SCM_RWSTRINGP and + SCM_VALIDATE_RWSTRING. + + * strings.h (SCM_STRING_UCHARS, SCM_STRING_CHARS): Handle strings + and substrings uniformly. However, substring handling is + deprecated. + + (SCM_RWSTRINGP): Deprecated. + +2000-11-18 Gary Houston + + * Makefile.am (.c.x): don't prefix ".:" to $PATH when running + guile-doc-snarf. it doesn't seem to do anything useful, but would + fail if $PATH contained whitespace. Thanks to Lars J. Aas. + +2000-11-17 Marius Vollmer + + * alist.c, arbiters.c, async.c, backtrace.c, boolean.c, chars.c, + continuations.c, debug-malloc.c, debug.c, dynl.c, dynwind.c, + environments.c, eq.c, error.c, eval.c, evalext.c, feature.c, + filesys.c, fluids.c, fports.c, gc.c, goops.c, guardians.c, hash.c, + hashtab.c, hooks.c, ioext.c, iselect.c, keywords.c, lang.c, + list.c, load.c, macros.c, modules.c, net_db.c, numbers.c, + objects.c, objprop.c, options.c, pairs.c, ports.c, posix.c, + print.c, procprop.c, procs.c, properties.c, ramap.c, random.c, + read.c, regex-posix.c, root.c, scmsigs.c, script.c, simpos.c, + socket.c, sort.c, srcprop.c, stackchk.c, stacks.c, stime.c, + strings.c, strop.c, strorder.c, strports.c, struct.c, symbols.c, + tag.c, threads.c, throw.c, unif.c, variable.c, vectors.c, + version.c, vports.c, weaks.c: Makes sure the snarfer output + inclusion is disabled when the snarfer is run on the file. Thanks + to Lars J. Aas! + + * Makefile.am: Install guile-procedures.txt in version-specific + directory to enable multiple installed guile versions. Suggested + by Karl M. Hegbloom + + * fports.c: include gc.h. + (fport_flush, fport_close): silently ignore I/O errors when + closing a port during gc. it's better than aborting in scm_error. + + * throw.c (scm_handle_by_message): remove obsolete comment. + +2000-11-12 Gary Houston + + * fports.c (scm_open_file): fix the 'b' option. Thanks + to George Caswell. + +2000-11-09 Gary Houston + + * ports.c, ports.h (scm_close_all_ports_except): deprecated. + use port-for-each. Updated its docstring. + +2000-11-07 Gary Houston + + * ports.c (scm_port_for_each): new proc. implements port-for-each, + which applies a procedure to each port in the port table. + ports.h: declare scm_port_for_each. + + * ioext.c (scm_dup2): new proc. implements "dup2" which is a simple + wrapper for the dup2 system call (unlike dup->fdes or + primitive-move->fdes). + * ioext.h: declare scm_dup2. + + * filesys.c (scm_close_fdes): new proc. implements "close-fdes" + which is a simple wrapper for close system call (unlike scm_close). + * filesys.h: declare for scm_close_fdes. + +2000-11-06 Mikael Djurfeldt + + * eval.c (SCM_IM_DISPATCH), objects.c (scm_mcache_lookup_cmethod): + Count n_specialized + 1 turns before letting a match through. + + * goops.c (scm_sys_invalidate_method_cache_x): Don't convert + scm_si_n_specialized from fixnum and don't take absolute value. + (Thanks to Lars J. Aas.) + +2000-11-04 Gary Houston + + * ports.c (scm_port_p): new function, implements "port?" which + is mentioned in R5RS. + * ports.h: declare scm_port_p. + +2000-11-01 Dirk Herrmann + + * backtrace.c (display_expression, display_error_body), fports.c + (prinfport), print.c (scm_iprin1): Test for symbols and strings + explicitly instead of using SCM_ROSTRINGP. + + * backtrace.c (scm_display_error_message): Don't pass a symbol to + scm_simple_format. Prefer high-level output functions. + + (display_error_body): When displaying procedure names, give + preference to the name passed as a parameter. Only if none is + given extract a name from the stack information. + + * fports.c (scm_fdes_to_port, prinfport), gc.c (scm_gc_mark), + ports.c (scm_port_filename, scm_set_port_filename_x): Use + SCM_(SET_)?FILENAME. + + * gh_data.c (gh_set_substr, gh_scm2newstr, gh_get_substr, + gh_symbol2newstr): Use scm_remember instead of a pair of calls to + scm_protect/unprotect_object. + + * goops.c (make_struct_class), objects.c (scm_class_of): Struct + table names are symbols. + + * ports.h (SCM_SET_FILENAME): Added. + + * print.c (scm_iprin1): Don't use scm_puts to write symbols or + strings in order to treat substrings right. Reposition call to + scm_remember after the last use of object's data. + + (scm_simple_format): Treat messages that are substrings right. + + * symbols.h (SCM_ROSTRINGP): Deprecated. + +2000-11-01 Dirk Herrmann + + * environments.c (obarray_replace, obarray_retrieve, + obarray_remove): Don't use '==' to compare SCM objects. + + * posix.c (scm_getgroups): Don't create a redundant string. + +2000-11-01 Dirk Herrmann + + * symbols.c (scm_sym2vcell, scm_sym2ovcell_soft, + scm_intern_symbol, scm_unintern_symbol): Symbol objects already + hold their hash values, no need to recompute them. + + (scm_intern_obarray_soft): Speed up search for a matching symbol + by comparing the hash values first. + +2000-10-30 Dirk Herrmann + + * unif.c (scm_make_uve, scm_dimensions_to_uniform_array): Don't + allow vectors longer than SCM_LENGTH_MAX. This removes the + SCM_HUGE_LENGTH trick, i. e. storing a vector length greater than + SCM_LENGTH_MAX at the beginning of the vector's memory. Since not + all of guile's code was implemented to be aware of this trick, it + is unlikely that it was used anyway. We can implement such a + feature more cleanly by using double cells for uniform vector + types. + + (scm_shap2ra): Replace SCM_IMP and SCM_NIMP tests by more + straightforward predicates. + + (scm_dimensions_to_uniform_array): Require that for dimensions + given as lower-bound/upper-bound pairs the upper-bound is never + less than the lower bound. + +2000-10-27 Dirk Herrmann + + * dynl.c (scm_dynamic_link, scm_dynamic_func, scm_dynamic_call, + scm_dynamic_args_call), filesys.c (scm_chown, scm_chmod, + scm_open_fdes, scm_stat, scm_link, scm_rename, scm_delete_file, + scm_mkdir, scm_rmdir, scm_opendir, scm_chdir, scm_symlink, + scm_readlink, scm_lstat, scm_copy_file), fports.c (scm_open_file), + ioext.c (scm_read_delimited_x, scm_fdopen), load.c + (scm_primitive_load, scm_parse_path, scm_search_path, + scm_sys_search_load_path, scm_primitive_load_path), net_db.c + (scm_inet_aton, scm_gethost, scm_getnet, scm_getproto, + scm_getserv), numbers.c (scm_string_to_number), ports.c + (scm_truncate_file, scm_sys_make_void_port), posix.c + (scm_getpwuid, scm_getgrgid, scm_execl, scm_execlp, + environ_list_to_c, scm_execle, scm_utime, scm_access, + scm_setlocale, scm_mknod), regex-posix.c (scm_make_regexp), + simpos.c (scm_system, scm_getenv), socket.c (scm_fill_sockaddr, + scm_send, scm_sendto), stime.c (scm_strftime, scm_strptime), + strop.c (scm_i_index, scm_string_null_p, scm_string_to_list), + strports.c (scm_mkstrport), symbols.c + (scm_string_to_obarray_symbol), vports.c (scm_make_soft_port): + Don't accept symbols as input parameters. Use SCM_STRING_LENGTH + instead of SCM_ROLENGTH. + + * dynl.c (scm_dynamic_link, scm_dynamic_func), error.c + (scm_error_scm), filesys.c (scm_chown, scm_chmod, scm_open_fdes, + scm_stat, scm_link, scm_rename, scm_delete_file, scm_mkdir, + scm_rmdir, scm_opendir, scm_chdir, scm_symlink, scm_readlink, + scm_lstat, scm_copy_file), fports.c (scm_open_file), ioext.c + (scm_fdopen), net_db.c (scm_inet_aton, scm_gethost, scm_getnet, + scm_getproto, scm_getserv), ports.c (scm_truncate_file, + scm_sys_make_void_port), posix.c (scm_getpwuid, scm_getgrgid, + scm_execl, scm_execlp, scm_execle, scm_utime, scm_access, + scm_setlocale, scm_mknod), regex-posix.c (scm_make_regexp, + scm_regexp_exec), simpos.c (scm_system, scm_getenv), stime.c + (setzone, scm_strftime, scm_strptime), vports.c + (scm_make_soft_port): Use SCM_STRING_COERCE_0TERMINATION_X to + make sure the characters of a string are followed by a \0. + Further, use SCM_STRING_CHARS instead of SCM_ROCHARS on the + resulting string. + + * dynl.c (scm_make_argv_from_stringlist), posix.c + (scm_convert_exec_args): Aligned to match each other. + + * dynl.c (scm_coerce_rostring): Removed. + + (scm_dynamic_func): Changed the comment to reflect that the + function name has to be a string. Further, hide implementation + details from the scheme comment. + + * error (scm_error_scm): Don't accept a symbol as message + parameter. Fix substring handling. + + * posix.c (environ_list_to_c): Use memcpy to copy environment + strings. Handle substrings which don't have a trailing \0. + + * symbols.h (SCM_LENGTH, SCM_ROLENGTH, SCM_SUBSTRP, + SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR): + Deprecated. + + * unif.h (SCM_HUGE_LENGTH): Deprecated. + + * validate.h (SCM_VALIDATE_ROSTRING, SCM_VALIDATE_ROSTRING_COPY, + SCM_VALIDATE_NULLORROSTRING_COPY): Deprecated. + +2000-10-26 Dirk Herrmann + + * random.c: Include unif.h. + + * strings.h (SCM_STRING_COERCE_0TERMINATION_X): Added. This is + intended to replace the macro SCM_COERCE_SUBSTR. Such a macro + will be necessary, even after copy-on-write strings will be added + to guile, but the current naming is inappropriate. + + * strorder.c (scm_string_equal_p, scm_string_ci_equal_p, + scm_string_less_p, scm_string_ci_less_p): Don't accept symbols as + input parameters. Further, the functions that test for equality + are rewritten to compare from back to front, the others are also a + little bit more polished. + +2000-10-25 Mikael Djurfeldt + + This change merges the GOOPS code into Guile. However, GOOPS + is still not initialized until someone asks for the module. + We need to optimize GOOPS initialization time before initializing + it together with the rest of libguile. We also need to add the + C API + primitive methods. Then we can start using it to + modularize Guile, implement a real exception system etc. + + * goops.c, objects.c, objects.h, eval.c (scm_make_extended_class, + scm_make_port_classes, scm_change_object_class, + scm_memoize_method): Changed to ordinary functions (was plugin + slots). + + * goops.c (wrap_init, scm_wrap_object): Unconditionally use + SCM_STRUCT_GC_CHAIN. + (scm_goops_version): Removed. + (scm_oldfmt): and all uses of it: Removed. + (scm_shared_array_root, scm_shared_array_offset, + scm_shared_array_increments): Removed. + (scm_init_goops): No need to support two arg mutex init. + Removed #include "versiondat.h", #include "goops.h". + + * goops.h: Removed various superfluous conditions. + Renamed class --> cls, new --> newinst in order to accomodate + C++. + + * init.c (scm_init_guile_1): Call the goops module registration + function. + Added #include "libguile/goops.h". + + * Makefile.am (libguile_la_SOURCES): Added goops.c + (DOT_X_FILES): Added goops.x + (DOT_DOC_FILES): Added goops.doc + (modinclude_HEADERS): Added goops.h + +2000-10-25 Dirk Herrmann + + * gc.c (scm_igc): Remove references to scm_vector_set_length_x. + + (scm_gc_sweep): SCM_CONTREGS is never NULL. + + * gc.c (scm_gc_sweep), vectors.c (scm_make_vector): Don't + allocate/free memory for zero length vectors. + + * vectors.[ch] (scm_vector_set_length_x): Deprecated. + +2000-10-25 Dirk Herrmann + + * alist.c (scm_assq_ref): Add a suggestion about how to deal with + this function when the API gets reviewed. + + * async.c (SET_ASYNC_GOT_IT): Use SCM_TYP16 instead of doing bit + operations directly. + + * dynl.c (scm_coerce_rostring), filesys.c (scm_link, + scm_copy_file), fports (scm_open_file), hash.c (scm_hasher), + posix.c (scm_getpwuid), print.c (scm_iprin1), simpos.c + (scm_system), strings.c (scm_string_ref, scm_substring, + scm_string_append), strop.c (scm_string_copy), struct.c + (scm_make_struct_layout), symbols.c (scm_gensym, scm_gentemp), + symbols.h (SCM_COERCE_SUBSTR): Use SCM_STRING_LENGTH instead of + SCM_ROLENGTH if the object is known to be a string or substring. + + * eval.c (scm_lookupcar): Use SCM_ITAG7 instead of doing bit + operations directly. + + * filesys.c (scm_dirname, scm_basename): Don't create shared + substrings as these are going to disappear from guile. + + * gc.c (scm_gc_sweep): Use SCM_UVECTOR_LENGTH instead of + SCM_HUGE_LENGTH. (The SCM_HUGE_LENGTH mechanism does not work + correctly anyway.) + + * gc.h (SCM_FREEP, SCM_NFREEP): Deprecated. + + * read.c (scm_flush_ws): Don't compare SCM values directly. + + * root.c (scm_make_root), root.h (scm_root_state): Removed + system_transformer and top_level_lookup_closure_var from struct. + (Since eval is now R5RS, binary compatibility is not granted + anyway.) + + * simpos.c (scm_system): Fix condition. + + * strings.c (scm_string_length, scm_string_ref, scm_substring, + scm_string_append), strop.c (scm_string_copy), struct.c + (scm_make_struct_layout, scm_make_vtable_vtable), symbols.c + (scm_gensym, scm_gentemp): Replace SCM_VALIDATE_STRINGORSUBSTR + with SCM_VALIDATE_STRING, since they do the same thing. + + * strings.h (scm_make_shared_substring): Deprecated. + + * tags.h (SCM_ITAG7): Added. + + * validated.h (SCM_VALIDATE_STRINGORSUBSTR): Deprecated. + +2000-10-20 Marius Vollmer + + * init.c (scm_init_guile_1, invoke_main_func): Call + scm_load_startup_files in scm_init_guile_1, not in + invoke_main_func. + +2000-10-18 Marius Vollmer + + * print.c (grow_ref_stack): Pass a INUM to scm_make_vector as the + size, not a naked int. Thanks to Brad Knotwell! + + * gc_os_dep.c (GC_noop1, GC_bool, TRUE, FALSE, VOLATILE): + Definitions copied from Boehm collector. + +2000-10-13 Dirk Herrmann + + * list.[ch] (scm_sloppy_memq, scm_sloppy_memv, scm_sloppy_member): + Deprecated. + + (scm_memq, scm_memv, scm_member): Inline the sloppy code. + +2000-10-11 Dirk Herrmann + + * alloca.c: Fixed include file path. Thanks to Bruce Korb for + the bug report. + +2000-10-11 Marius Vollmer + + * gc_os_dep.c: Added real implementation based on code from Boehms + collector. This is not well tested yet. + + * gc.h (scm_get_stack_base): Added prototype. + * init.c (scm_get_stack_base): Removed prototype. + +2000-10-11 Dirk Herrmann + + * random.c (scm_seed_to_random_state): Replace SCM_LENGTH with + the appropriate SCM__LENGTH macro. + + (vector_scale, vector_sum_squares, scm_random_solid_sphere_x, + scm_random_normal_vector_x): Use scm_uniform_vector_length to + determine the length of a vector object generically. + +2000-10-11 Dirk Herrmann + + * ramap.c (scm_array_fill_int, scm_array_index_map_x): Replace + SCM_LENGTH with the appropriate SCM__LENGTH macro. + + (scm_ra_matchp, scm_ramapc, ramap, rafe, scm_array_index_map_x, + raeql_1, raeql): Use scm_uniform_vector_length to determine the + length of a vector object generically. + +2000-10-11 Dirk Herrmann + + * unif.c (scm_make_uve, scm_uniform_vector_length, scm_array_p, + scm_transpose_array, scm_array_contents, scm_ra2contig, + scm_uniform_array_read_x, scm_uniform_array_write, scm_bit_count, + scm_bit_position, scm_bit_set_star_x, scm_bit_count_star, + scm_bit_invert_x, scm_array_to_list, scm_raprin1): Replace + SCM_LENGTH with the appropriate SCM__LENGTH macro. + + (scm_array_dimensions, scm_make_shared_array, scm_enclose_array, + scm_array_in_bounds_p, scm_uniform_vector_ref, scm_array_set_x, + scm_array_contents, scm_uniform_array_read_x, + scm_uniform_array_write, scm_list_to_uniform_array, rapr1): Use + scm_uniform_vector_length to determine the length of a vector + object generically. + + (scm_bit_count, scm_bit_set_star_x, scm_bit_count_star, + scm_bit_invert_x): Eliminated dummy type dispatch. + + (scm_ra2contig): Fixed array vector access. + +2000-10-10 Dirk Herrmann + + * unif.h (SCM_BITVECTOR_P, SCM_BITVECTOR_BASE): Added. + + * eval.c (iqq, SCM_CEVAL, SCM_APPLY, check_map_args, scm_map, + scm_for_each, scm_copy_tree), gc.c (scm_igc, scm_gc_mark, + scm_gc_sweep), gh_data.c (gh_scm2chars), sort.c + (scm_restricted_vector_sort_x, scm_sorted_p, scm_sort_x, + scm_sort, scm_stable_sort_x, scm_stable_sort), vectors.c + (scm_vector_length, scm_vector_ref, scm_vector_set_x, + scm_vector_to_list, scm_vector_fill_x, scm_vector_equal_p, + scm_vector_move_left_x, scm_vector_move_right_x, ): Replace + SCM_LENGTH with the appropriate SCM__LENGTH macro. + + * gc.c (scm_gc_sweep): Use SCM_BITVECTOR_BASE for bitvectors. + + * sort.c (scm_restricted_vector_sort_x, scm_sorted_p): Eliminated + dummy type dispatch. + + (scm_sort_x, scm_sort, scm_stable_sort_x, scm_stable_sort): + Eliminated redundant NIM test. + +2000-10-09 Dirk Herrmann + + * filesys.c (fill_select_type, retrieve_select_type, scm_select), + gh_data.c (gh_set_substr, gh_scm2chars, gh_scm2shorts, + gh_scm2longs, gh_scm2floats, gh_scm2doubles, gh_symbol2newstr), + stime.c (bdtime2c), symbols.c (scm_sym2vcell, scm_sym2ovcell_soft, + scm_intern_obarray_soft, scm_symbol_to_string, scm_intern_symbol, + scm_unintern_symbol, copy_and_prune_obarray, scm_builtin_bindings, + scm_builtin_weak_bindings), validate.h (SCM_VALIDATE_VECTOR_LEN): + Replace SCM_LENGTH with the appropriate SCM__LENGTH macro. + + * filesys.c (scm_dirname, scm_basename), gh_data.c (gh_scm2newstr, + gh_get_substr), posix.c (scm_putenv), regex-posix.c + (scm_regexp_exec), stime.c (setzone), symbols.c + (scm_string_to_symbol): Don't accept symbols as input parameters + any more. + +2000-10-09 Dirk Herrmann + + * continuations.c (scm_make_cont, copy_stack_and_call, + scm_dynthrow), environments.c (obarray_enter, obarray_replace, + obarray_retrieve, obarray_remove, obarray_remove_all, + leaf_environment_fold), fluids.c (grow_fluids, scm_copy_fluids, + scm_fluid_ref, scm_fluid_set_x), hash.c (scm_hasher), hashtab.c + (scm_hash_fn_get_handle, scm_hash_fn_create_handle_x, + scm_hash_fn_remove_x, scm_internal_hash_fold), ioext.c + (scm_read_delimited_x), objects.c (scm_mcache_lookup_cmethod, + scm_make_subclass_object), ports.c (scm_unread_string), socket.c + (scm_recv, scm_recvfrom), stacks.c (scm_make_stack, scm_stack_id, + scm_last_stack_frame), strings.c (scm_string_length, + scm_string_set_x), strop.c (scm_substring_move_x, + scm_substring_fill_x, scm_string_fill_x, scm_string_upcase_x, + scm_string_downcase_x, scm_string_capitalize_x), struct.c + (scm_struct_init, scm_struct_vtable_p, scm_make_struct, + scm_make_vtable_vtable, scm_struct_ref, scm_struct_set_x), weaks.c + (scm_mark_weak_vector_spines, scm_scan_weak_vectors): Replace + SCM_LENGTH with the appropriate SCM__LENGTH macro. + +2000-10-09 Dirk Herrmann + + * print.c (make_print_state, scm_iprin1): Replace SCM_LENGTH with + the appropriate SCM__LENGTH macro. + + (grow_ref_stack): Don't call scm_vector_set_length_x to resize + the print stack. + +2000-10-09 Dirk Herrmann + + * numbers.c (big2str): Avoid redundant copying. + + (scm_bigprint): Use SCM_STRING_LENGTH instead of SCM_LENGTH. + +2000-10-06 Dirk Herrmann + + * numbers.c (big2str), read.c (scm_grow_tok_buf), strports.c + (st_resize_port): Don't call scm_vector_set_length_x to resize + strings. + + * read.c (scm_lreadr, scm_read_token): Use SCM_STRING_LENGTH for + string arguments (instead of SCM_LENGTH). + +2000-10-06 Dirk Herrmann + + * continuations.h (SCM_CONTINUATION_LENGTH), strings.h + (SCM_STRING_LENGTH), symbols.h (SCM_SYMBOL_LENGTH), unif.h + (SCM_UVECTOR_LENGTH, SCM_BITVECTOR_LENGTH), vectors.h + (SCM_VECTOR_LENGTH): Added as replacements for SCM_LENGTH. + +2000-10-02 Marius Vollmer + + * coop-defs.h (coop_key_create): Don't use the C++ keyword + `destructor' in prototype. Thanks to Martin Baulig! + +2000-10-02 Michael Livshin + + * guile-func-name-check.in: now should not confuse SCO nawk + anymore. thanks to Bruce Korb for the fix! + +2000-10-01 Gary Houston + + * net_db.c: declare inet_aton only if HAVE_INET_ATON is not + defined. thanks to Han-Wen Nienhuys. + +2000-09-30 Gary Houston + + * filesys.c (scm_stat2scm), posix.c (s_scm_mknod): don't use + S_ISSOCK or S_IFSOCK if not defined. thanks to Bruce Korb. + +2000-09-29 Neil Jerram + + * Makefile.am (guile-procedures.txt): Insert a new rule such that + the output from guile-snarf.awk is processed by makeinfo to + produce guile-procedures.txt. + + * guile-snarf.awk.in: Modify the way we snarf docstrings such that + the output is Texinfo-compliant and suitable for post-processing + with makeinfo. (Trim leading "./" from C file name if + present; reformat procedure prototype line in @deffn format; + improve representation of args to show optional and rest args; + explicitly quote quotation marks where they are used inside an AWK + regexp.) + + * net_db.c (scm_inet_ntoa): Docstring fix: missing newline + inserted. + + * hashtab.c (scm_hashx_create_handle_x, scm_hashx_ref): Insert + spaces between C parameters so that the snarfer doesn't coalesce + them all into a single very long-named parameter. + +2000-09-27 Neil Jerram + + * list.c (scm_append): Use @example texinfo markup in docstring. + +2000-09-26 Dirk Herrmann + + * strings.c (scm_string, scm_make_string, scm_string_set_x, + scm_string_append), strop.c (scm_string_upcase_x, + scm_string_downcase_x), strports.c (st_resize_port), symbols.c + (scm_sym2vcell, scm_sym2ovcell_soft, scm_intern_obarray_soft, + scm_intern_symbol, scm_unintern_symbol), unif.c (scm_cvref, + scm_uniform_vector_ref, scm_array_set_x, rapr1): Replace calls to + SCM_UCHARS with SCM_STRING_UCHARS or SCM_SYMBOL_UCHARS. + + * symbols.h (SCM_UCHARS): Deprecated. + +2000-09-26 Dirk Herrmann + + * gc.c (scm_gc_sweep): Replace SCM_CHARS by SCM_COMPLEX_MEM. + + * numbers.h (SCM_COMPLEX_MEM): Added as a replacement for + SCM_CHARS. + + (SCM_COMPLEX_REAL, SCM_COMPLEX_IMAG): Use it. + + * ramap.c (scm_array_fill_int, racp, raeql_1): Replace SCM_CHARS + with SCM_STRING_CHARS or SCM_UVECTOR_BASE. + + (racp): Fix: Make sure that src and dst types match. + + * read.c (scm_grow_tok_buf, scm_lreadr, scm_read_token): Replace + SCM_CHARS with SCM_STRING_CHARS. + + * symbols.h (SCM_CHARS): Deprecated. + + * unif.c (scm_enclose_array, scm_uniform_vector_ref, scm_cvref, + scm_array_set_x, scm_uniform_array_read_x, rapr1, freera, + scm_uniform_array_write): Replace SCM_CHARS with + SCM_STRING_CHARS, SCM_UVECTOR_BASE or SCM_ARRAY_MEM. + + * unif.h (SCM_ARRAY_MEM): Added as a replacement for SCM_CHARS. + + (SCM_ARRAY_V, SCM_ARRAY_BASE, SCM_ARRAY_DIMS): Use it. + + * validate.h (SCM_COERCE_ROSTRING): Removed. + +2000-09-26 Dirk Herrmann + + * gc.c (scm_igc): : Eliminate references to SCM_LENGTH and + SCM_CHARS from comment. + + (scm_gc_mark, scm_gc_sweep): Replace SCM_CHARS with + SCM_SYMBOL_CHARS or SCM_CCLO_BASE or SCM_UVECTOR_BASE or + SCM_BDIGITS, and replace SCM_VELTS with SCM_VECTOR_BASE or + SCM_CONTREGS, according to the corresponding types. + + (scm_gc_sweep): Simplify sweeping of uniform vectors. + +2000-09-26 Dirk Herrmann + + * procs.h (SCM_CCLO_LENGTH, SCM_SET_CCLO_LENGTH, SCM_CCLO_BASE, + SCM_SET_CCLO_BASE, SCM_CCLO_REF, SCM_CCLO_SET, SCM_CCLO_SUBR, + SCM_SET_CCLO_SUBR): Added resp. changed such that none of the + macros SCM_CHARS, SCM_SETCHARS, SCM_VELTS and SCM_LENGTH have to + be used with compiled closures any more. + + * procs.c (scm_makcclo), gsubr.h (SCM_GSUBR_TYPE, SCM_GSUBR_PROC): + Replace uses of SCM_CHARS, SCM_SETCHARS and SCM_VELTS with regards + to compiled closures. + + * gsubr.h (SCM_SET_GSUBR_TYPE, SCM_SET_GSUBR_PROC): Added. + + * gsubr.c (scm_make_gsubr): Use them. + +2000-09-26 Dirk Herrmann + + * numbers.c (scm_adjbig): Use SCM_BDIGITS instead of SCM_CHARS. + + (big2str, scm_bigprint): Use SCM_STRING_CHARS instead of + SCM_CHARS. + + * vectors.c (scm_vector_set_length_x): Distinguish between + strings, scheme vectors and uniform vectors, thus getting rid of + references to SCM_CHARS. (The code still needs improvement.) + +2000-09-26 Dirk Herrmann + + * eval.c (scm_m_letrec1, SCM_CEVAL, SCM_APPLY): Use + SCM_STRING_U?CHARS or SCM_SYMBOL_U?CHARS instead of SCM_U?CHARS. + + * unif.h (SCM_UVECTOR_BASE), vectors.h (SCM_VECTOR_BASE): Added + as replacements for SCM_CHARS and SCM_VELTS. + +2000-09-26 Dirk Herrmann + + * continuations.c (scm_make_cont, scm_dynthrow), print.c + (scm_iprin1), stacks.c (scm_make_stack, scm_stack_id, + scm_last_stack_frame): For continuations, use SCM_CONTREGS + instead of SCM_CHARS. + + * coop-threads.c (scm_threads_mark_stacks): Eliminate references + to SCM_LENGTH and SCM_CHARS from comments. + + * dynl.c (scm_dynamic_link, scm_dynamic_func), symbols.h + (SCM_ROCHARS, SCM_ROUCHARS): Cleanly distinguish between string + and symbol arguments. + + * hash.c (scm_hasher), keywords.c (prin_keyword), objects.c + (scm_make_subclass_object), print.c (scm_iprin1), regex-posix.c + (scm_regexp_error_msg), stime.c (bdtime2c, scm_strftime), struct.c + (scm_struct_init, scm_struct_vtable_p, scm_struct_ref, + scm_struct_set_x): Use SCM_STRING_U?CHARS or SCM_SYMBOL_U?CHARS + instead of SCM_U?CHARS. + + * strings.h (SCM_STRING_UCHARS): Added as a replacement for + SCM_UCHARS for string arguments. + + * strorder.c: Include strings.h and symbols.h. + + * symbols.h: Replaced SCM_CHARS in comment. + + (SCM_SYMBOL_UCHARS): Added as a replacement for SCM_UCHARS for + symbol arguments. + + (SCM_SLOPPY_SUBSTRP): Deprecated. + + * tags.h: Fixed comments not to reference SCM_LENGTH or + SCM_CHARS. + +2000-09-22 Dirk Herrmann + + * gc.c (scm_gc_mark, scm_gc_sweep), tags.h: Removed the + scm_tc7_lvector type tag. + +2000-09-22 Dirk Herrmann + + * eval.c (scm_m_define), evalext.c (scm_m_undefine): Removed dead + code. + + * gc.c (scm_gc_sweep): Use SCM_STRING_CHARS or SCM_SYMBOL_CHARS + instead of SCM_CHARS. + +2000-09-22 Dirk Herrmann + + * backtrace.c (display_frame_expr), environments.c + (print_observer, print_leaf_environment, print_eval_environment, + print_import_environment, print_export_environment), gh_data.c + (gh_set_substr, gh_symbol2newstr), keywords.c + (scm_make_keyword_from_dash_symbol), ports.c (scm_drain_input), + posix.c (scm_mknod), print.c (scm_iprin1), regexp-posix.c + (scm_regexp_error_msg), script.c (scm_compile_shell_switches), + simpos.c (scm_getenv), socket.c (scm_recv, scm_recvfrom), + strings.c (scm_makfromstr), strop.c (scm_substring_move_x, + scm_substring_fill_x, scm_string_capitalize_x), symbols.c + (scm_symbol_to_string), unif.c (scm_make_uve, scm_array_p), + validate.h (SCM_VALIDATE_STRING_COPY): Use SCM_STRING_CHARS or + SCM_SYMBOL_CHARS instead of SCM_CHARS. + +2000-09-22 Dirk Herrmann + + * strings.h (SCM_STRING_CHARS): Added, should be used instead of + SCM_CHARS whenever the argument is known to be a string. + + (SCM_SLOPPY_STRINGP): Deprecated. + + * symbols.h (SCM_SYMBOL_CHARS): Added, should be used instead of + SCM_CHARS whenever the argument is known to be a symbol. + +2000-09-22 Neil Jerram + + * struct.c (scm_make_struct): Fix texinfo warning in docstring by + using @pxref rather than @xref. + + * root.c (scm_call_with_dynamic_root): Fix texinfo warning in + docstring by using @code for (thunk) rather than @var. + +2000-09-20 Marius Vollmer + + * numbers.c (scm_istr2flo): Throw an `out of range' error when + exponent is too large instead of returning `#f'. The rationale is + that in this case the string represents a valid number but we + can't deal with it. + +2000-09-20 Dirk Herrmann + + * symbols.c (scm_intern_obarray_soft, + scm_sysintern0_no_module_lookup): Make sure that symbol + properties initially form an empty list. Thanks to Keisuke + Nishida for pointing this out. + +2000-09-19 Dirk Herrmann + + * throw.c (scm_handle_by_message): Added a FIXME comment. + + (scm_ithrow): Removed some redundant tests. When compiling on + gcc, always add the GCSE bug workaround. + +2000-09-14 Gary Houston + + * print.c (scm_iprin1): write the ascii delete character as #\del + instead of '#\', so it can be read back. like in SCM. + +2000-09-12 Mikael Djurfeldt + + * symbols.c (duplicate_string): Don't try to copy the byte after + the string. This might not be `\0' and might even not be + allocated memory. + +2000-09-12 Dirk Herrmann + + * symbols.c (scm_symbol_p): Eliminate redundant SCM_IMP test. + +2000-09-12 Dirk Herrmann + + This patch unifies the formerly distinct ssymbol and msymbol types + to a common symbol type scm_tc7_symbol. The representation of the + new symbol type uses a double cell with the following layout: + , where the car of + prop-pair holds the symbol's function property and the cdr of + prop-pair holds the symbol's other properties. In the long run, + these properties will be removed. Then, the generic property + functions will be uses. + + * eval.c (SCM_CEVAL), objects.c (scm_class_of), print.c + (scm_iprin1), tag.c (scm_tag): Use scm_tc7_symbol instead of + scm_tc7_ssymbol, scm_tc7_msymbol or scm_tcs_symbols. + + * gc.c (scm_gc_mark): Mark the symbols property pair. + + (scm_gc_sweep): There are no symbol slots any more. + + * hash.c (scm_hasher): Instead of re-calculating the hash value + of a symbol, use the raw_hash value stored in the symbol itself. + + * properties.h: Fix typo. + + * strings.[ch] (scm_makstr, scm_makfromstr): The slot parameter + is not used any more. + + * symbols.[ch] (scm_strhash): Deprecated, replaced by a macro. + + (scm_intern_obarray_soft): Made softness parameter unsigned. + + (scm_string_hash): New function with the same functionality as + scm_strhash had before, except that the hash value is not adjusted + to a hash table size. Instead, the 'raw' hash value is returned. + + * symbols.c (duplicate_string): New static convenience function. + + (scm_sym2vcell, scm_sym2ovcell_soft, scm_intern_obarray_soft): + Renamed local variable from scm_hash to hash. + + (scm_intern_obarray_soft): Don't check for a negative softness + any more. When generating symbol cells, use the new layout and + store the raw hash value in the symbol's cell. + + (scm_symbol_to_string): Removed unnecessary cast. + + (scm_intern_symbol, scm_unintern_symbol): Use scm_string_hash to + determine the hash values. + + (msymbolize): Removed. + + (scm_symbol_fref, scm_symbol_pref, scm_symbol_fset_x, + scm_symbol_pset_x, scm_symbol_hash): No need to distinguish + between different symbol types any more. + + (scm_symbol_hash): Comment fixed. + + * symbols.h: Comment about the distinction between ssymbols and + msymbols removed. + + (SCM_SYMBOLP, SCM_ROSTRINGP): No need to distinguish between + different symbol types any more. + + (SCM_PROP_SLOTS, SCM_SET_PROP_SLOTS): Added. + + (SCM_SYMBOL_FUNC, SCM_SET_SYMBOL_FUNC, SCM_SYMBOL_PROPS, + SCM_SET_SYMBOL_PROPS, SCM_SYMBOL_HASH, SCM_SET_SYMBOL_HASH): Use + the new symbol cell layout. + + * tags.h (scm_tc7_ssymbol, scm_tc7_msymbol, scm_tcs_symbols): + Deprecated. + +2000-09-12 Mikael Djurfeldt + + * symbols.h (scm_gentemp): Declared. + + * symbols.c (scm_gensym): Reimplemented. Now only takes one + optional argument which should be a *string*. + (scm_gentemp): Reimplemented and moved from boot-9.scm. + +2000-09-10 Keisuke Nishida + + * modules.c: Use applicable smobs for eval closures instead of + compiled closures. Include "libguile/smob.h". + (f_eval_closure): Removed. + (scm_eval_closure_tag): New variable. + (scm_eval_closure_lookup): Renamed from eval_closure. + This function now takes a smob instead of a compiled closure. + (scm_standard_eval_closure): Create a smob instead of a compiled + closure. + (scm_init_modules): Initialize the eval closure type as a smob. + * modules.h (SCM_EVAL_CLOSURE_P): New macro. + (scm_eval_closure_tag, scm_eval_closure_lookup): Declare. + * symbols.c: Include "libguile/smob.h". + (scm_sym2vcell): Call scm_eval_closure_lookup directly if THUNK + is an eval closure. + +2000-09-10 Mikael Djurfeldt + + * Makefile.am (.x.doc): Bugfix: Added $(srcdir) to path in order + to allow for builds in separate tree. + + * symbols.c (scm_gensym): Bugfixed my previous bugfix. (Thanks to + Dale P. Smith.) + +2000-09-10 Keisuke Nishida + + * eval.c (SCM_APPLY): Fixed bugs in the applicable-smob calls. + +2000-09-07 Dirk Herrmann + + * environments.c (obarray_enter, obarray_retrieve, + obarray_remove): Make sure the hash value is a valid obarray + index. + + (obarray_enter, obarray_remove): Documentation improved. + + (obarray_replace): Added. + + (leaf_environment_define, leaf_environment_undefine): Cleaned up + and optimized. + +2000-09-05 Mikael Djurfeldt + + * symbols.c (scm_gensym): Check that argument is a symbol, not a + string. (Thanks to Ralf Mattes.) + +2000-09-05 Marius Vollmer + + * init.c: Include "libguile/properties.h". + + * gh_data.c (gh_scm2char): Validate that argument is a character. + +2000-08-25 Dirk Herrmann + + * environments.h (SCM_IMPORT_ENVIRONMENT_P, + SCM_EXPORT_ENVIRONMENT_P): Before fetching the environment + functions, make sure that we really got an environment. + +2000-09-03 Mikael Djurfeldt + + * validate.h (SCM_VALIDATE_NUMBER_DEF_COPY): New macro. + +2000-09-03 Marius Vollmer + + * Makefile.am (.x.doc): Pretend to create .doc files from .x files + and give explicit dependencies for .x files that depend on + generated files. This allows parallel builds. Thanks to Matthias + Koeppe! + +2000-08-27 Marius Vollmer + + * Makefile.am: Added gc_os_dep.c, properties.c, properties.x, + properties.h and properties.doc in the suitable places. + + * init.h (scm_init_guile): New prototype. + + * init.c (scm_init_guile, scm_init_guile_1): New interface for + initializing Guile that does return to the caller. + (scm_boot_guile_1): Use scm_init_guile_1 to initialize Guile. + Do not establish a catch-all, this is no longer needed. + + * root.h (scm_properties_whash): New `sys_protect', used in + properties.c. + + * throw.c (scm_ithrow): Perform catch-all handling here when no + suitable handler has been found. That way, we don't have to rely + on the user establishing a catch-all, which might be difficult for + him if he is using scm_init_guile instead of scm_boot_guile. + +2000-09-03 Neil Jerram + + * vectors.c (scm_vector): Docstring: add @deffnx line for + list->vector. + + * unif.c (scm_uniform_vector_ref): Docstring: add @deffnx line for + array-ref. + (scm_array_set_x): Docstring: add @deffnx line for + uniform-array-set!. + + * symbols.c (scm_symbol_to_string): Docstring: complete an + incomplete Texinfo reference to a node in r4rs.texi. + (scm_symbol_to_string): Escape double quotes correctly within + docstring. + + * struct.c (scm_make_struct, scm_make_vtable_vtable): Docstring + fixes: `@dots' changed to `@dots{}'. + + * strop.c (scm_substring_move_x): Docstring: add @deffnx lines for + substring-move-left! and substring-move-right!. + + * strings.c (scm_string): Docstring: add @deffnx line for + list->string. + + * stime.c (scm_strptime): Fix spelling mistake in docstring. + (scm_current_time): Docstring fix: insert missing newline. + + * socket.c (scm_recvfrom): Docstring format fix: missing newline + inserted. + + * ramap.c (scm_array_copy_x): Docstring: add @deffnx line for + array-copy-in-order!. + (scm_array_map_x): Docstring: add @deffnx line for + array-map-in-order!. + + * posix.c (scm_mknod): Docstring format fix: missing newlines + inserted. + + * modules.c (scm_interaction_environment): Docstring fix: add + newlines. + + * eval.c (scm_cons_source): Added newly written docstring. + +2000-09-03 Michael Livshin + + the following changes let Guile get rid of the `allocated' cell + state. + + * smob.c (scm_smob_prehistory): don't init the "allocated" smob + type. + + * tags.h (scm_tc16_allocated): removed. + + * gc.h: removed now-obsolete comments about the `allocated' cell + state. + (SCM_NEWCELL): don't change cell type to `allocated'. + (SCM_NEWCELL2): ditto. + + * gc.c (scm_mark_locations): mark freecells too, and don't worry + about any possible false positives. + (scm_debug_newcell): don't change cell type to `allocated'. + (scm_debug_newcell2): ditto. + (scm_gc_for_newcell): ditto. + (scm_gc_mark): remove the tc16_allocated case. + +2000-08-26 Mikael Djurfeldt + + * gdbint.c (gdb_print): Removed superfluous macro definition. + + * objects.c (scm_init_objects), print.c (scm_init_print), struct.c + (scm_init_struct): First arg to scm_make_vtable_vtable should be a + string, not a symbol. (`make-vtable-vtable' needs to append this + string to another string and then pass it through + `make-struct-layout'.) + + * stacks.c (scm_init_stacks): Pass a string, not a layout object, + to scm_make_vtable_vtable. (Thanks to Dale P. Smith.) + + * struct.c (scm_make_struct_layout): Removed reference to + "read-only string" in comment; Check that argument is a string. + (scm_make_vtable_vtable): Check that argument is a string. + + * environments.c (scm_init_environments): All internal includes in + libguile must use the prefix "libguile/" in path names since inly + the top-level source directory is on the include list. (That, in + turn, is because we want to distinguish between system header + files and hedares files internal to libguile.) + + * strings.c (scm_make_shared_substring, scm_read_only_string_p): + Deprecated. + (scm_string_length, scm_string_ref, scm_substring, + scm_string_append): Don't accept symbols as arguments (R5RS). + +2000-08-25 Neil Jerram + + * ports.c (scm_set_port_column_x): Fix docstring so that it + mentions set-port-line! rather than set-port-column! twice. + + * guardians.c (scm_make_guardian): Remove spurious . from doc string. + +2000-08-25 Dirk Herrmann + + * Makefile.am: Added all necessary environments.* files. + + * init.c: Include environments.h. + + (scm_boot_guile_1): Initialize the environments. + + * environments.[ch]: Added. Most of the credit for these files + goes to Jost Boekemeier. + +2000-08-25 Mikael Djurfeldt + + * procprop.c: #include "libguile/smob.h"; handle applicable smobs. + +2000-08-24 Keisuke Nishida + + * smob.h (scm_smob_descriptor): Added `apply' and `gsubr_type'. + * smob.c (scm_make_smob_type): Initialize `apply' and `gsubr_type'. + (scm_set_smob_apply): New function. + (scm_smob_apply_0, scm_smob_apply_1, scm_smob_apply_2, + scm_smob_apply_3): New functions. + * eval.c (SCM_CEVAL, SCM_APPLY): Added dispatch for applicable smobs. + * procs.c (scm_procedure_p): Check applicable smobs. + +2000-08-24 Mikael Djurfeldt + + * Makefile.am (BUILT_SOURCES): Experimentally added scmconfig.h + also here. (This is supposed to make sure that scmconfig.h is + built before all sources in order to prevent that everything has + to be rebuilt again. Hope it works---I'm just guessing. :) + + * fluids.c (scm_fluid_set_x): Return SCM_UNSPECIFIED. + +2000-08-23 Mikael Djurfeldt + + * gc.c (scm_gc_mark): Don't use GUILE_DEBUG flag to compile in + extra tests. (GUILE_DEBUG is only supposed to make extra + debugging functions available.) + +2000-08-21 Michael Livshin + + * gc.h (SCM_GC_CARD_N_CELLS): change to be a nice non-confusing + constant. + +2000-08-19 Michael Livshin + + * gc.c (scm_gc_sweep): added a `continue' statement that have + fallen through the cracks in the merge. thanks to Shuji Narazaki! + + * gc.h: removed some stuff that broke compilation for people and + wasn't actually needed anyway. + +2000-08-18 Neil Jerram + + * filesys.c (scm_fcntl): Docstring fix - missing newlines inserted. + + * net_db.c (scm_gethost, scm_getnet, scm_getproto, scm_sethost, + scm_setnet, setproto, setserv): Argument names changed to match + doc string. + + * feature.c (scm_program_arguments): New docstring. + + * simpos.c (scm_getenv): Reflow docstring. + + * eq.c (scm_eq_p, scm_eqv_p, scm_equal_p): Add texinfo markup to + docstrings. + + * chars.c (scm_char*): Docstring fixes - texinfo markup. + +2000-08-18 Neil Jerram + + * boolean.c (scm_not, scm_boolean_p): Docstring fixes - add + texinfo markup and remove trailing newlines. + +2000-08-17 Michael Livshin + + this changes the Guile GC to use cards (aka "chunklets"). + (most of the ideas and some of the code are by Greg Harvey, though + the code is probably unrecognizable now. the original chunklet + proposal, way back, is by Dale Jordan). + + * tags.h: (SCM_GCTYPE16, SCM_GCCDR, SCM_GC[8]MARKP, + SCM_SETGC[8]MARK, SCM_CLRGC[8]MARK): moved from here into gc.h. + some (most) of these are probably going to be deprecated. + + * gc.h (SCM_MARKEDP): simplified, there are no different mark bit + locations anymore. + (SCM_GC_CARD_*, SCM_C_BVEC_*): lots of new macros to deal with + cards and bvecs (bit-vectors). + + * gc.c: (scm_default_init_heap_size_*): defined to take cards into + account, but keeping more or less the same values as previously. + added some simple helper macros. + (CLUSTER_SIZE_IN_BYTES, ALIGNMENT_SLACK): defined to take cards + into account. + (BVEC_*, scm_mark_space_t, current_mark_space, mark_space_ptr, + current_mark_space_offset, mark_space_head, get_bvec, + clear_mark_space): new functions and supporting variables, types + and macros that implement mark space management. + (scm_igc): clear the mark space (all of it) before beginning the + mark phase. + (scm_gc_mark): changed the tests for rogue cells, much simplified + throughout (no different mark bit locations to worry about now). + (scm_mark_locations): don't consider card header cells. + (scm_cellp): ditto. + (scm_gc_sweep): simplified. + (init_heap_seg): changed to take cards into account. + +2000-08-16 Michael Livshin + + * stime.c (scm_c_get_internal_run_time): new function, same as + scm_get_internal_run_time but returns a long. it's used by the GC + for timekeeping, since with scm_get_internal_run_time there is a + (extremely theoretical) possibility of consing. + (scm_get_internal_run_time): redefined in terms of + scm_c_get_internal_run_time. + + * stime.h: added prototype for scm_c_get_internal_run_time. + + * gc.c (scm_gc_stats): add more obscure stats, such as: mark time, + sweep time, total marked cells, total swept cells, and number of + times GC was invoked. + (gc_start_stats): renamed from scm_gc_start, made static, taught + to init the new stats. + (gc_end_stats): renamed from scm_gc_end, made static, taught to + calculate the new stats. + (scm_igc): don't call gc_start_stats unless we are sure that we + are indeed going to collect. also, added some timekeeping between + the mark and sweep phases. + (scm_gc_sweep): count number of cells we sweep as we go. + + * gc.h: removed prototypes for scm_gc_{start,end}. + +2000-08-13 Mikael Djurfeldt + + * alist.c (scm_assq, scm_assv, scm_assoc): Report argument type + error for the alist rather than the sublist where the type + mismatch is discovered. + +2000-08-13 Neil Jerram + + * root.c (s_scm_call_with_dynamic_root): Docstring fix - rogue + newline. + +2000-08-12 Neil Jerram + + * numbers.c (scm_ash): Docstring fix - missing newlines. + + * ports.c (scm_port_filename): Docstring fix - missing newline. + + * strports.c (scm_eval_string): Docstring fix - missing newline. + + * vports.c (s_scm_make_soft_port): Docstring updated so that + example is correct. + + * strop.c: Docstring fixes - quotation marks and backslashes + needed quoting. + + * numbers.c (s_scm_logand): Docstring fix - "@end lisp" inserted. + +2000-08-11 Neil Jerram + + * macros.c: Remove surplus newlines from end of docstrings. + + * list.c (scm_list_tail): Add @deffnx line to docstring for + list-cdr-ref. + + * keywords.c: Docstring improvements in conjunction with new + reference manual doc on keywords. + + * error.c (scm_error_scm): Fix texinfo syntax error in + docstring. (@code(~S) should be @code{~S}.) + + * dynl.c: Remove surplus newlines from end of docstrings. + +2000-08-11 Mikael Djurfeldt + + * eval.c (scm_eval): Backward incompatible change: Now takes an + environment specifier as second arg. `eval' hereby becomes R5RS + compatible. + (scm_i_eval_x, scm_i_eval): New functions (replace + scm_eval_3). + (scm_eval2, scm_eval_3): Deprecated. + (scm_top_level_lookup_closure_var): Deprecated. + + * eval.h: #include "struct.h". + + * evalext.c (scm_definedp): Have to work before module system is + booted. + + * modules.h (SCM_MODULEP, SCM_VALIDATE_MODULE, + SCM_MODULE_OBARRAY, SCM_MODULE_USES, SCM_MODULE_BINDER, + SCM_MODULE_EVAL_CLOSURE): New macros. + (scm_module_index_obarray, scm_module_index_uses, + scm_module_index_binder, scm_module_index_eval_closure): New + constants; #include "validate.h". + + * modules.c (scm_module_tag, scm_module_system_booted_p): New + globals. + (scm_post_boot_init_modules): Initialize scm_module_tag. + (scm_interaction_environment): New primitive. + + * symbols.c (scm_can_use_top_level_lookup_closure_var): Removed. + #include "modules.h". + + * strports.c (scm_eval_string): Evaluate in + scm_interaction_environment (). + + * script.c (scm_shell): Pass scm_the_root_module () as second arg + to new scm_eval_x. + + * load.c (load): Use `scm_selected_module' to compute second arg + to new scm_i_eval_x; Don't call it if module system hasn't booted. + (scm_read_and_eval_x): Deprecated. + #include "modules.h". + + * debug.c (scm_local_eval): Use scm_i_eval and scm_i_eval_x. + (scm_start_stack): Use scm_i_eval. + + * strports.c: #include "modules.h". + + * print.c (scm_simple_format): Be case-insensitive for ~A and ~S + directives. + +2000-08-09 Mikael Djurfeldt + + The following changes are intended to ensure that struct instances + are freed before their vtables. It's optimized for the most + common case, which is freeing of struct instances. + + * gc.c (scm_gc_mark, scm_gc_sweep): Remove vcell = 1 magic. + (scm_structs_to_free): New variable. + (scm_gc_sweep): Hook up structs to free on the scm_structs_to_free + chain. + + * struct.h (SCM_STRUCT_GC_CHAIN, SCM_SET_STRUCT_GC_CHAIN): New + macros. + (scm_structs_to_free, scm_struct_prehistory): Declare. + + * struct.c (scm_make_struct, scm_make_vtable_vtable): Structs + handles are now double cells; Initialize SCM_STRUCT_GC_CHAIN to + 0. + (scm_struct_gc_init, scm_free_structs): New GC C hooks. + (scm_struct_prehistory): Install them. + + * init.c (scm_boot_guile_1): Call scm_struct_prehistory. + +2000-08-06 Marius Vollmer + + * read.c (scm_flush_ws): Include filename in error message when it + is not `#f'. + +2000-08-05 Marius Vollmer + + * iselect.c: Include . Thanks to Bertrand Petit! + +2000-08-02 Mikael Djurfeldt + + * struct.c (scm_make_struct_layout, scm_make_struct, + scm_make_vtable_vtable): Updated documentation. + + * print.c (scm_simple_format): Bugfix: Coerce port before using + it. + +2000-07-31 Gary Houston + + * net_db.c: declare h_errno only if HAVE_H_ERRNO is not defined + (thanks to Richard Kim for the bug report). + +2000-07-30 Marius Vollmer + + * alist.c (scm_assq_remove_x, scm_assv_remove_x, + scm_assoc_remove_x): Use scm_delq1_x instead of scm_delq_x, since + using the latter is pointless. + +2000-07-26 Dirk Herrmann + + * gc.c (scm_gc_sweep): Renamed local variable from 'free' to + 'free_struct_data' to avoid confusion with stdlib's 'free'. + +2000-07-26 Dirk Herrmann + + * vectors.c (scm_make_vector): Fix the initialization order of + the vector such that the type cell is initialized last. + +2000-07-26 Dirk Herrmann + + * struct.[ch] (scm_struct_init): Made static. Fixed not to rely + on the struct cell to be fully initialized. + + * struct.c (scm_make_struct, scm_make_vtable_vtable): Fix the + initialization order of the struct such that the type cell is + initialized last. + +2000-07-25 Marius Vollmer + + * alist.c (scm_assq_remove_x, scm_assv_remove_x, + scm_assoc_remove_x): Remove only the first cell with a matching + key, not all. + +2000-07-24 Marius Vollmer + + * stime.c (scm_strftime): Recognize a return value of zero from + strftime as buffer overflow and take care to detect a valid zero + length result regardless. Thanks to David Barts! + +2000-07-23 Marius Vollmer + + * alist.c (scm_assq_remove_x, scm_assv_remove_x, + scm_assoc_remove_x): Remove all cells whose key is eq, eqv, or + equal (respectively) to the argument key, not all cells that are + eq, eqv, or equal to the first cell with the argument key. Thanks + to Neil Jerram! + +2000-07-18 Dirk Herrmann + + * gc.h (SCM_FREE_CELL_CDR, SCM_SET_FREE_CELL_CDR), hooks.c + (make_hook), modules.c (OBARRAY, USES, BINDER): Pack and unpack + SCM values appropriately. + + * modules.c (scm_standard_eval_closure): Don't pass an inum to + scm_makcclo, but rather a long value. + +2000-07-18 Dirk Herrmann + + read.c (scm_lreadrecparen), srcprop.c (scm_set_source_property_x): + SCM_SETCDR and SCM_WHASHSET macros don't deliver a return value. + Thanks to Han-Wen Nienhuys for the bug report. + +2000-07-18 Dirk Herrmann + + * root.[ch] (scm_call_catching_errors): Deprecated. + + * root.c (scm_init_root): Initialize the root smob type using the + standard initialization functions. + +2000-07-17 Marius Vollmer + + * eval.c (unmemocopy): Don't rely on V being a list of at least + one element. Thanks to Bill Schottstaedt! + +2000-07-15 Michael Livshin + + * gc.c (scm_done_free): new. + expanded comments about scm_done_malloc. + + * gc.h: added prototype for scm_done_free + +2000-07-13 Dirk Herrmann + + * gc.h (scm_take_stdin): Removed. + + * gc.h (SCM_VALIDATE_CELL): Delegate cell checks to function + scm_assert_cell_valid to allow extensions to the checking + functionality without need to recompile everything. + + * gc.[ch] (scm_assert_cell_valid, scm_set_debug_cell_accesses_x): + Added as conditionally compiled functions for the case that + SCM_DEBUG_CELL_ACCESSES is enabled. + + * gc.c (debug_cells_p): Added to indicate whether compile-time + included cell access debugging is run-time enabled. + + * gc.[ch] (scm_gc_running_p): Added to indicate that scm_igc is + being executed. Intended to be used instead of scm_gc_heap_lock + at most places. + + * error.c (scm_error), gdbint.c (SCM_GC_P): Use scm_gc_running_p + instead of scm_gc_heap_lock. + + * gc.c (scm_igc): Set scm_gc_running_p to true while running. + + * gc.c (scm_mark_locations): Don't mark free cells. + + * weaks.c (scm_scan_weak_vectors): Use SCM_FREE_CELL_P instead of + SCM_FREEP. + +2000-07-13 Dirk Herrmann + + * gc.c (scm_mark_locations): Minimized some variable scopes and + simplified the code a bit. + +2000-07-10 Dirk Herrmann + + * gc.h (SCM_SET_FREE_CELL_TYPE, SCM_SET_FREE_CELL_CDR, + SCM_FREE_CELL_P, SCM_FREE_CELL_CDR): Added since free cells + should not be accessed via SCM_C[AD]R. Further, using dedicated + macros to access free cells allows all other cell accessing macros + to treat acesses to free cells as errors, thus enabling better + error checks for cell accesses. SCM_FREE_CELL_P is supposed to + replace SCM_FREEP some time. + + * gc.h (SCM_NEWCELL, SCM_NEWCELL2), gc.c (map_free_list, + free_list_length, scm_check_freelist, scm_debug_newcell, + scm_debug_newcell2, freelist_length, scm_gc_for_newcell, + scm_gc_mark, scm_gc_sweep, init_heap_seg): Only use the dedicated + cell accessors when accessing free cells. + +2000-07-10 Dirk Herrmann + + * gc.h (SCM_CELL_WORD, SCM_CELL_OBJECT): Treat the referenced + object as const in order to make the compiler warn about code like + SCM_CELL_WORD (x, n) = y. Instead, SCM_SET_CELL_WORD (x, n, y) + should be used. + + (SCM_CELL_WORD_LOC, SCM_CARLOC, SCM_CDRLOC): Return the address + as an address to a non-const object, since these macros are used + to allow direct write access to objects. + +2000-07-07 Dirk Herrmann + + * hashtab.c (scm_hash_fn_create_handle_x): Signal an error if the + given hash table has no slots. + +2000-07-06 Dirk Herrmann + + * gc.c (policy_on_error): Added in order to allow alloc_some_heap + to react to malloc failures in a context dependent way. + + (scm_check_freelist): No need to flush streams before abort(). + + (scm_gc_for_newcell): Try to allocate new memory in three phases: + grow heap if preferred, if still no memory available collect + garbage, if still no memory available grow heap. + + (heap_segment_table_size): Added to always reflect the actual + size of the heap segment table, because scm_n_heap_segs may differ + from the heap segment table size. + + (alloc_some_heap): In case of malloc failure, react according to + the new policy_on_error parameter (either return to caller or + abort immediately). Further, keep heap_segment_table_size up to + date. + + (scm_init_storage): Initialize heap_segment_table_size. + +2000-07-06 Dirk Herrmann + + * gh.h: Don't include . Thanks to Han-Wen Nienhuys for + the hint. + +2000-06-30 Dirk Herrmann + + * __scm.h (SCM_OUTOFRANGE, SCM_NALLOC, SCM_HUP_SIGNAL, + SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, + SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD, + SCM_ORD_SIG, SCM_NUM_SIGS): Re-introduce these as deprecated + symbols. + + * error.c (scm_wta): Re-introduce dispatching for SCM_OUTOFRANGE + and SCM_NALLOC, but as a deprecated feature. + +2000-06-30 Mikael Djurfeldt + + * debug.c: Added #include fluids.h. + + * numbers.c (scm_gr_p, scm_leq_p, scm_geq_p): Turned into + primitive generics. (Thanks to Nicolas Neuss.) + +2000-06-30 Dirk Herrmann + + * gc.c (alloc_some_heap): Use scm_memory_error to indicate a + failed attempt to get additional memory from the system. + + (scm_gc_for_newcell): Changed the control structure to make the + behaviour explicit for the case that gc is not able to free any + cells. + +2000-06-30 Dirk Herrmann + + * __scm.h (SCM_OUTOFRANGE): Removed. + + * error.c (scm_wta): Removed sick dispatch code for range + errors. (More sick dispatches still to be removed.) + + * hashtab.c (scm_hash_fn_get_handle, scm_hash_fn_create_handle_x, + scm_hash_fn_remove_x): Eliminate redundant test for if unsigned + value is non-negative. Use scm_out_of_range to signal range + errors. + + * hooks.c (make_hook), unif.c (scm_aind): Use scm_out_of_range to + signal range errors. + + * list.c (scm_list_ref, scm_list_set_x, scm_list_cdr_set_x): Fix + error reporting (now uses original input parameter to report wrong + type argument errors). Use SCM_OUT_OF_RANGE to report range + errors and SCM_WRONG_TYPE_ARG to report type errors. + + * strings.c (scm_substring): Make range checks for negative + values explicit (former behaviour relied on an implicit + conversion from signed to unsigned). Don't use SCM_ASSERT for + range checks. + + * unif.c (scm_aind, scm_transpose_array, scm_bit_set_star_x, + scm_bit_count_star): Use scm_out_of_range to signal range + errors. + + * unif.c (scm_transpose_array, scm_bit_position), vectors.c + (scm_vector_ref, scm_vector_set_x, scm_vector_move_left_x, + scm_vector_move_right_x): Use SCM_ASSERT_RANGE to check ranges. + +2000-06-30 Dirk Herrmann + + * validate.h (SCM_VALIDATE_INUM_MIN_COPY, + SCM_VALIDATE_INUM_MIN_DEF_COPY, SCM_VALIDATE_INUM_RANGE_COPY): + Perform all range checks based on the input value. The former way + of using the value that is assigned to the target variable fails + if the assignment to the target variable itself can change the + value because of type conversion. + + (SCM_ASSERT_RANGE): Use scm_out_of_range to signal range errors. + +2000-06-30 Mikael Djurfeldt + + * gc.c (scm_gc_for_newcell): Behave gracefully also if scm_igc + doesn't yield any new cells. In theory this could happen if all + cells allocated with NEWCELL are either in use or conservatively + marked and all cluster spine cells are conservatively marked. + (Thanks to Dirk.) + +2000-06-29 Dirk Herrmann + + * __scm.h (SCM_NALLOC): Removed. + + * error.c (scm_wta): Removed sick dispatch code for memory + errors. (More sick dispatches still to be removed.) + + * numbers.c (scm_mkbig, scm_adjbig), ports.c (scm_make_port_type), + random.c (scm_i_copy_rstate, scm_c_make_rstate), smob.c + (scm_make_smob_type), srcprop.c (scm_make_srcprops), vectors.c + (scm_vector_set_length_x): Now using scm_memory_error to signal + memory errors. + +2000-06-29 Dirk Herrmann + + * __scm.h: Removed some commented code and fixed some comments. + + (SCM_HUP_SIGNAL, SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, + SCM_SEGV_SIGNAL, SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, + SCM_SIG_ORD, SCM_ORD_SIG, SCM_NUM_SIGS): Removed. + + * async.c: Removed some commented code. + +2000-06-29 Dirk Herrmann + + * gc.c (scm_gc_mark, scm_gc_sweep, scm_must_malloc, + scm_must_realloc, scm_must_free, alloc_some_heap): Use the + appropriate error signalling function. + +2000-06-29 Dirk Herrmann + + * root.h (scm_first_type): Removed. + +2000-06-29 Dirk Herrmann + + * gc.c (MIN_GC_YIELD): Removed. + +2000-06-28 Michael Livshin + + * gc.c (scm_gc_for_newcell): don't try to do GC if it's blocked, + allocate instead. + +2000-06-28 Dirk Herrmann + + * async.c (scm_gc_async, scm_gc_vcell, scm_sys_gc_async_thunk): + Moved to gc.c. + + (scm_init_async): Moved initialization for scm_gc_async and + scm_gc_vcell to gc.c. Moved initialization of scm_asyncs here + from gc.c. + + * async.h (scm_gc_async): Not globally visible any more. + + * gc.c (scm_gc_stats): Made callable even from within regions + where gc is blocked. + + (scm_gc_end): Eliminate the hardcoding of the marking of the + scm_gc_async from the gc core. + + (scm_init_storage): Don't initialize the scm_asyncs list here. + This is now done in asyncs.c. + + (scm_gc_vcell): Moved here from async.c. + + (gc_async): Renamed from scm_gc_async, moved here from async.c + and made static. + + (gc_async_thunk): Renamed from scm_sys_gc_async_thunk and moved + here from async.c. + + (mark_gc_async): New hook function for scm_after_gc_c_hook. + + (scm_init_gc): Added initialization of scm_gc_vcell and + gc_async. Further, add mark_gc_async to scm_after_gc_c_hook. + + * init.c (scm_boot_guile_1): scm_init_gc requires asyncs to be + initialized. + +2000-06-28 Dirk Herrmann + + * gc.c (scm_igc): Removed commented code that once was intended + to unprotect struct types with no instances. + + * root.h (scm_type_obj_list): Removed. + +2000-06-27 Dirk Herrmann + + * async.c (scm_init_async): Switch to standard way of smob + initialization. + +2000-06-21 Michael Livshin + + * guile-doc-snarf.in: use cut instead of sed, that's much much + faster. also, don't call basename more than needed. and, to gain + a couple of microseconds more, don't call cat needlessly. (thanks + to Brad Knotwell). + +2000-06-21 Dirk Herrmann + + * guile-snarf.awk.in, guile-snarf.in, snarf.h: Rename SCM__I to + SCM_SNARF_INIT_START, SCM__D to SCM_SNARF_DOC_START, SCM__S to + SCM_SNARF_DOCSTRING_START and SCM__E to SCM_SNARF_DOCSTRING_END. + +2000-06-21 Mikael Djurfeldt + + * eval.c, eval.h (scm_top_level_lookup_closure_var): Added. + #include "libguile/fluids.h". + + * eval.h (SCM_TOP_LEVEL_LOOKUP_CLOSURE): New macro which replaces + SCM_CDR (scm_top_level_lookup_closure_var) everywhere. + + * root.h (scm_top_level_lookup_closure_var, + scm_system_transformer): Removed. (It's no sense in having the + *variable* be a "fluid".) + + * root.c (mark_root): Removed marking of + s->top_level_lookup_closure_var and s->system_transformer. + + * modules.c (scm_selected_module): the_module is now a fluid. + +2000-06-20 Mikael Djurfeldt + + * gc.h, tags.h: Be kind to compilers which must see hash signs in + column 0. (Thanks to Ian Grant.) + + * numbers.h: Put #ifdef HAVE_LONG_LONGS around declarations using + the long_long type. (Thanks to Bernard Urban.) + +2000-06-20 Mikael Djurfeldt + + * gc.c, gc.h (scm_default_init_heap_size_1, + scm_default_min_yield_1, scm_default_init_heap_size_2, + scm_default_min_yield_2, scm_default_max_segment_size): New global + variables. Can be customized by the application before booting + Guile. (We might want to be able to control these parameters + dynamically through the "options interface" in the future, but + note that that is additional functionality. Here we're giving + default values which the environment variables can override.) + + * list.c (scm_cons_star): Updated comment. + + * smob.h: Changed comments for scm_make_smob_type and + scm_make_smob_type_mfpe, warning that the latter might be + deprecated in a future release. + +2000-06-19 Dirk Herrmann + + * list.[ch] (scm_cons_star/cons*): Renamed from + scm_list_star/list*. + + * list.[ch] (scm_list_star/list*): Provided as a deprecated alias + for scm_cons_star/cons*. + + * gc.c (scm_protect_object): Updated comment. + + * numbers.h (SCM_NEWREAL, SCM_NEWCOMPLEX): Removed. + + * tags.h (SCM_UNPACK_CAR, SCM_NDOUBLE_CELLP): Removed. + +2000-06-19 Mikael Djurfeldt + + * init.c, init.h (scm_initialized_p): Renamed from `initialized' + and made global. + + * gdbint.c (gdb_print): Print warning instead of calling scm_write + if Guile isn't yet initialized. + + * print.c (scm_current_pstate, scm_make_print_state): Simplified + tests, using the assumption that Guile has been initialized. + +Sun Jun 18 14:45:21 2000 Greg J. Badros + + * print.c (s_scm_current_pstate): Do not segfault when the + print_state_pool is unitialized in `current-pstate', and better + verify its state before altering it in scm_make_print_state(). + +2000-06-18 Michael Livshin + + * scmsigs.c (s_scm_sigaction): guard the SIGIOT case with an + #ifdef -- it's missing on at least one platform. (thanks to + Jan Nieuwenhuizen). + +2000-06-16 Dirk Herrmann + + * list.c (list*): Added documentation from common-list.scm. + +2000-06-15 Dirk Herrmann + + * gc.c (scm_unprotect_object): The reference count is guaranteed + to be a positive number. + +2000-06-15 Mikael Djurfeldt + + * eval.c: Updated comment above scm_map. + +2000-06-14 Mikael Djurfeldt + + * gc.c (scm_protect_object): Avoid looking up the object handle + twice. + (scm_unprotect_object): Abort if scm_unprotect_object is called on + an unprotected object. + +2000-06-14 Michael Livshin + + * gc.c (scm_unprotect_object): fix a nasty typo bug (thanks to + Dirk Herrmann). + +2000-06-14 Mikael Djurfeldt + + * socket.c (scm_getsockopt): Changed type for `optlen' from int to + size_t. + (scm_accept, scm_getsockname, scm_getpeername, scm_recvfrom): + Ditto for `tmp_size'. + (scm_addr_buffer_size): Changed type from int to size_t. + + * random.c: #include . (Needed by memcpy.) + + * guile-snarf.awk.in: Replace the dot_doc_file arg with "-", + indicating stdin, instead of "" and don't reset ARGC. This is a + workaround for `nawk' in AIX 4.3 on RS6000 but, as far as I know, + it is correct, and perhaps even better. + +2000-06-14 Gary Houston + + * scmsigs.c (scm_init_scmsigs): if HAVE_SIGINTERRUPT is not + defined, add SA_RESTART to the sigaction flags correctly + (thanks to Dale P. Smith). + +2000-06-13 Mikael Djurfeldt + + * strings.c: #include . (Thanks to Bill Schottstaedt.) + + * net_db.c (scm_resolv_error): Only use macro NETDB_INTERNAL if + defined. It isn't on sgi irix 5.3. (Thanks to Bill Schottstaedt.) + + * Makefile.am (.c.doc): Pipe output (the .x contents) to /dev/null. + +2000-06-13 Mikael Djurfeldt + + * fports.c (scm_setvbuf): Use `free' instead of `scm_must_free' + since read and write buffers are allocated by `malloc'. + + * Makefile.am: Removed old test code. + + * gh_test_c.c, gh_test_repl.c: Removed. + +2000-06-12 Mikael Djurfeldt + + * iselect.c (SCM_NLONGBITS): Add workaround for the Sun 4.2 + compiler. + + * inet_aton.c (inet_aton): Cast init value for `cp'. + + * ramap.c (s_scm_array_fill_x): Cast `ve' properly in case + `scm_tc7_uvect'. + + * symbols.c (scm_intern_obarray_soft, + scm_sysintern0_no_module_lookup): Cast `name' to unsigned char ptr + in calls to scm_strhash. + + * strports.c (st_resize_port): Substituted SCM_UCHARS for + SCM_CHARS. + (st_write): Cast argument to strncpy to char ptr. + (scm_mkstrport): Substituted SCM_ROUCHARS for SCM_ROCHARS. + (scm_strport_to_string): Cast argument to scm_makfromstr to char + ptr. + + * ports.c (scm_ungetc): Cast value to unsigned char ptr before + storing in putback_buf. + (scm_unread_string): Substituted SCM_ROCHARS for SCM_ROUCHARS. + + * ioext.c (s_scm_read_line): Cast result of call to + scm_do_read_line to unsigned char ptr. + + * gdbint.c (SEND_STRING): Cast argument to char pointer. + + * fports.c (fport_flush): Declare `ptr' as unsigned char (was + char). + + * Makefile.am (DOT_DOC_FILES): List doc-files explicitly. (We + shouldn't use Make rules which aren't supported by most Make + programs.) + (OMIT_DEPENDENCIES): Defined to "libguile.h ltdl.h". (We don't + want these dependencies recorded, since they would get bogus + relative paths; libguile.h is only used in gh.h and guile.c.) + (EXTRA_DOT_X_FILES, EXTRA_DOT_DOC_FILES): New variables. + (guile-procedures.txt): Depend on EXTRA_DOT_DOC_FILES. + (modinclude_HEADERS): Removed kw.h. + + * guile-snarf.in: Change regexp "^SCM__I" --> "^ *SCM__I". + (The preprocessor might insert spaces before the identifier.) + + * snarf.h (SCM_SNARF_HERE, SCM_SNARF_INIT, SCM_SNARF_DOCS): + Renamed from SCM_HERE, SCM_INIT, SCM_DOCS. + + * smob.h (scm_smobfuns): Removed deprecated type. + + * smob.c, smob.h (scm_newsmob): Removed deprecated function. + (Replaced by `scm_make_smob_type'.) + + * keywords.c (scm_tc16_kw): Removed deprecated type. + (Replaced by scm_tc16_keyword.) + + * kw.h: Removed deprecated header file. + + * evalext.c (serial-map): Removed deprected alias for scm_map. + (Has been replaced by `map-in-order'.) + + * ramap.c (serial-array-copy!, serial-array-map!): Removed + depracted aliases. (Replaced by `array-copy-in-order!' and + `array-map-in-order'.) + +2000-06-11 Mikael Djurfeldt + + * gc.h (SCM_VALIDATE_CELL): Rewritten. + (SCM_CELL_WORD, SCM_CELL_OBJECT, SCM_SET_CELL_WORD, + SCM_SET_CELL_OBJECT): Use new version of SCM_VALIDATE_CELL. + (Thanks to Han-Wen Nienhuys.) + +2000-06-10 Michael Livshin + + * guile-doc-snarf.in: don't pipe the CPP output right into sed -- + write it to the temp file first and check the CPP return code. + (I introduced this bug earlier, and this probably caused people + with non-GNU C preprocessors to get empty *.x files and not to + have the build fail right away...). + + * scmsigs.c (s_scm_sigaction): guard the SIGSYS case with an ifdef + -- at least my libc5-based Linux system doesn't define SIGSYS. + +2000-06-08 Mikael Djurfeldt + + * snarf.h, guile-snarf.awk.in, guile-snarf.in: Replaced snarf + markers with identifiers (SCM__I, SCM__D, SCM__S, SCM__E). + (Thanks to Bernard Urban.) + +2000-06-06 Mikael Djurfeldt + + * modules.c (scm_system_module_env_p): Fixed detection of system + modules. + +2000-06-06 Marius Vollmer + + * scmsigs.c (scm_sigaction): Silently ignore setting handlers for + `program error signals' because they can't currently be handled by + Scheme code. + +2000-06-05 Dirk Herrmann + + * procs.h (SCM_SET_SUBRF): Added. + + * procs.c (scm_make_subr_opt): Don't assign to SCM_SUBRF, use + SCM_SET_SUBRF instead. Thanks to Bernard Urban for the bug + report. + +2000-06-05 Dirk Herrmann + + * gc.h (SCM_CARLOC, SCM_CDRLOC): Don't take the address of a SCM + value. + + * sort.c (scm_sorted_p, scm_merge, scm_merge_list_x, + scm_merge_list_step): Don't take the address of SCM_CAR. Use + SCM_CARLOC instead. Thanks to Bernard Urban for the bug report. + +2000-06-05 Dirk Herrmann + + * boolean.h (SCM_TRUE_P): Removed, as people might use it as a + replacement for !SCM_FALSEP. + + * backtrace.c (display_error_body), boolean.h (SCM_BOOLP), gc.c + (scm_unhash_name), gh_data.c (gh_module_lookup), load.c + (scm_primitive_load), print.c (scm_simple_format), procs.c + (scm_procedure_documentation), procs.h (SCM_TOP_LEVEL), ramap.c + (scm_array_fill_int), scmsigs.c (scm_sigaction), stacks.c + (narrow_stack, scm_make_stack, scm_stack_id), symbols.c + (scm_string_to_obarray_symbol), throw.c (scm_catch, + scm_lazy_catch, scm_ithrow), unif.c (scm_make_uve, scm_array_p, + scm_array_set_x, scm_bit_set_star_x, scm_bit_count_star), + validate.h (SCM_VALIDATE_BOOL_COPY, SCM_VALIDATE_PROC): Replace + uses of SCM_TRUE_P (x) with SCM_EQ_P (x, SCM_BOOL_T). + +2000-06-04 Mikael Djurfeldt + + * eval.c (scm_badformalsp): New static function. + (SCM_CEVAL): Check arguments for procedure-with-setter closures. + (Thanks to Keisuke Nishida.) + + The major reason for Guile's slow loading speed has been the fact + that a chain of Scheme level procedures has been evaluated for + every top-level symbol lookup during the first pass through the + code. + + The following is a kludge which I suggested four years ago, and + which I've repeatedly suggested since. Personally, I've never + been bothered by Guile's slow loading speed, so I thought I would + let someone else do it... + + But since the new environments will be included first in + Guile-1.5, I thought it would make people happy to get the kludge + into 1.4. + + * modules.c: Added #include "libguile/vectors.h"; + Added #include "libguile/hashtab.h"; + Added #include "libguile/struct.h"; + Added #include "libguile/variable.h"; + Capture Scheme level `module-make-local-var!' to be used in the + standard eval closure. + (scm_standard_eval_closure): New primitive. + + * modules.h (scm_standard_eval_closure): Declare. + + * eval.c (scm_lookupcar): Test for !SCM_CONSP (SCM_CAR (env)) + instead of SCM_TRUE (scm_procedurep (SCM_CAR (env))). + + * symbols.c (scm_sym2vcell): Bypass dispatch in the evaluator for + standard eval closures. + + * variable.c: Code layout fixes. + +2000-06-03 Mikael Djurfeldt + + * Makefile.am: Added LIBS line to libpath which accidentally + disappeared in the change of 2000-06-01. + (Thanks to Dale P. Smith.) + +2000-06-03 Mikael Djurfeldt + + * scmsigs.c (scm_segfault): Removed. (Was probably added by + mistake since it is not mentioned in ChangeLog.) + + * gc.h (SCM_VALIDATE_CELL): Cast result to (void) in order to + avoid compiler warnings in gcc. (Does this work for other + compilers?) + +2000-06-03 Mikael Djurfeldt + + * gc.h (SCM_VALIDATE_CELL): Don't "use" the value returned by + abort (). + (SCM_CARLOC, SCM_CDRLOC): Define directly instead of using + SCM_CELL_OBJECT_0 and SCM_CELL_OBJECT_1. It's not correct to take + the address of these expressions since they use SCM_VALIDATE_CELL. + (Thanks to Bernard Urban.) + + * dynl.c: Changed #include --> #include + "libltdl/ltdl.h". (Thanks to Bill Schottstaedt.) + +2000-06-01 Craig Brozefsky + + * Makefile.am: libguile_la_LDFLAGS gets -version-info args + from GUILE-VERSION definition of LIBGUILE version. Added to + libpath.h definitions for guileversion and libguileversion which + both get their values from GUILE-VERSION definition. + +2000-05-30 Dirk Herrmann + + * numbers.h (SCM_BIGP): Don't use SCM_SMOB_PREDICATE in header + file: Code using numbers should not be required to include + smob.h. + +2000-05-30 Dirk Herrmann + + * coop-threads.c.cygnus, coop-threads.h.cygnus, fsu-pthreads.h, + mit-pthreads.c, mit-pthreads.h: Deleted. + + * Makefile.am (EXTRA_DIST), scmsigs.c, threads.[ch]: Drop + references to deleted files and fsu/mit thread support in + general. + +2000-05-29 Dirk Herrmann + + * hooks.c (symbol_name, scm_create_hook): Restored the original + behaviour of scm_create_hook. Changing it was bad as Carl + R. Witty has pointed out. + + * gc.c (scm_init_gc): We can still rely on scm_create_hook to + protect the object. + +2000-05-26 Dirk Herrmann + + * gc.c (scm_init_gc): Protect scm_after_gc_hook, since this will + soon not be done by scm_create_hook any longer. + + * hooks.c (make_hook, print_hook, scm_create_hook, + scm_make_hook_with_name, scm_make_hook), hooks.h (SCM_HOOK_NAME, + SCM_HOOK_PROCEDURES, SCM_SET_HOOK_PROCEDURES, + scm_make_hook_with_name), init.c (scm_boot_guile_1): Hooks no + longer have names. As an intermediate solution, the name + predicate is emulated via object properties, but use of this + feature is deprecated. + + * hooks.h (scm_free_hook): Removed, as it is never defined. + +2000-05-25 Dirk Herrmann + + * numbers.[ch] (SCM_POSFIXABLE, SCM_NEGFIXABLE, SCM_FIXABLE): + Un-deprecated since otherwise user code can't determine whether a + number fits into an inum any longer. The names should be changed + some time, though. + + * numbers.c (scm_big2inum): Eliminated use of SCM_UNEGFIXABLE. + + * tags.h (SCM_UNPACK_CAR): Deprecated. + +2000-05-25 Dirk Herrmann + + * filesys.h (SCM_OPDIRP), fluids.h (SCM_FLUIDP, SCM_FLUID_NUM), + fports.h (SCM_OPFPORTP, SCM_OPINFPORTP, SCM_OPOUTFPORTP), hooks.h + (SCM_HOOK_ARITY), keywords.h (SCM_KEYWORDP, SCM_KEYWORDSYM), + numbers.h (SCM_NUMP, SCM_BIGSIGN, SCM_BDIGITS, SCM_NUMDIGS): + Replace SCM_UNPACK_CAR appropriately. Don't access cells via + SCM_{SET}?C[AD]R unless they are known to be cons cells. + + * gc.c (scm_heap_seg_data_t, scm_mark_locations, scm_cellp, + init_heap_seg): Remove unused struct member variable 'valid'. + +2000-05-24 Dirk Herrmann + + * fports.c (fport_write), ports.c (scm_markstream, scm_port_mode, + scm_print_port_mode), ports.h (SCM_OPPORTP, SCM_OPINPORTP, + SCM_OPOUTPORTP, SCM_INPUT_PORT_P, SCM_OUTPUT_PORT_P, SCM_OPENP), + procs.h (SCM_CLOSCAR), unif.h (SCM_ARRAY_NDIM, SCM_ARRAY_CONTP), + variable.h (SCM_VARIABLEP): Replace SCM_UNPACK_CAR + appropriately. + +2000-05-23 Dirk Herrmann + + * gc.c (free_list_length), hash.c (scm_hasher), macros.c + (scm_macro_type), objects.c (scm_class_of), options.c + (scm_options), print.c (scm_iprin1), strports.c (st_seek), throw.c + (SCM_LAZY_CATCH_P): Replace SCM_UNPACK_CAR appropriately. + +2000-05-23 Dirk Herrmann + + * eval.c (scm_macroexp, SCM_CEVAL, scm_force), tags.h: Replace + SCM_UNPACK_CAR with SCM_CELL_TYPE or SCM_CELL_WORD_0. + + * eval.c (scm_force): Add documentation. + + * eval.c (scm_force, scm_cons_source): Don't access cells via + SCM_{SET}?C[AD]R unless they are known to be cons cells. + +2000-05-23 Dirk Herrmann + + * strings.h (SCM_NSTRINGP, SCM_NRWSTRINGP), tags.h + (SCM_NDOUBLE_CELLP), vectors.h (SCM_NVECTORP): Deprecated. + + * gc.c (scm_igc), gc.h (SCM_PTR_MASK, SCM_PTR_LT): Removed #ifdef + nosve #endif conditionally compiled code. + +2000-05-23 Michael Livshin + + * gc.c (scm_heap_seg_data_t): fixed comment for the `span' member. + +2000-05-22 Michael Livshin + + * guile-doc-snarf.in: put the preprocessed file through sed to + trim all lines to 1024 chars. I hope it doesn't break anybody's + sed. we'll see. (note: this is lossy trimming, i.e. the spill + isn't wrapped around but actually chopped off. this seemed to me + safe because the current snarfer doesn't understand multi-line + cookies anyway. in the long term, it would be nice not to depend + on AWK for anything.) + + * gc.h (SCM_[SET_]CELL_{WORD,OBJECT}, SCM_VALIDATE_CELL): reverted + the previous change to this macros, after deciding to torture the + snarfer instead. + +2000-05-21 Michael Livshin + + * gc.h (SCM_[SET_]CELL_{WORD,OBJECT}, SCM_VALIDATE_CELL): brought + the yucky, ugly and nasty conditional compilation back. sorry, + but it was either that or requiring GAWK to build Guile. + (lots of places): removed the code that implemented the old GC + scheme. + + * init.c (scm_boot_guile_1): removed the code conditioned on + !GUILE_NEW_GC_SCHEME. + + * __scm.h: (GUILE_NEW_GC_SCHEME): removed. + + * gc.c (scm_protect_object, scm_unprotect_object): change the + implementation to more efficient (at least in the time complexity + sense). the calls should now also be thread-safe -- I suspect + that people expect them to be. (thanks to Han-Wen Nienhuys) + (lots of places): removed the code that implemented the old GC + scheme. + + * hashtab.c (scm_hash_fn_create_handle_x): add missing + SCM_REALLOW_INTS before return. I really wonder about the + possible interactions between hashtables, threads & GC. it + doesn't look healthy at all. + +2000-05-20 Dirk Herrmann + + * unif.c (scm_bit_count): Fixed the parameter checks. Thanks to + Dale P. Smith. + +2000-05-19 Dirk Herrmann + + * __scm.h (SCM_DEBUG_CELL_ACCESSES), gc.h (SCM_): Added as a new + debug option to verify all accesses to cells actually access + objects on the heap. + + * gc.h (SCM_VALIDATE_CELL): Added. Only performs validation if + SCM_DEBUG_CELL_ACCESSES is set to 1. + + (SCM_CELL_WORD, SCM_CELL_OBJECT, SCM_SET_CELL_WORD, + SCM_SET_CELL_OBJECT): Use SCM_VALIDATE_CELL to check every cell + that is accessed. + +2000-05-19 Dirk Herrmann + + * gh_data.c (gh_scm2chars, gh_scm2shorts, gh_scm2longs, + gh_scm2floats, gh_scm2doubles): Change !SCM_NIMP to SCM_IMP. + + * gc.c (scm_cellp): Fixed and simplified. + + * throw.c (JBJMPBUF, SETJBJMPBUF, SCM_JBDFRAME, SCM_SETJBDFRAME, + make_jmpbuf, scm_init_throw): Now using double cells to represent + jump buffers when using debug extensions. + + (freejb): Removed. + +2000-05-18 Dirk Herrmann + + * gh.h gh_data.c gh_funcs.c (gh_new_procedure*, gh_chars2byvect, + gh_shorts2svect, gh_longs2ivect, gh_ulongs2uvect, gh_floats2fvect, + gh_doubles2dvect, gh_doubles2scm, gh_define, gh_lookup, + gh_module_lookup): Accept const pointers as parameters. + + * gh.h gh_data.c (gh_int2scmb): Deprecated. + +2000-05-18 Dirk Herrmann + + * __scm.h (SCM_DEBUG_REST_ARGUMENT): Renamed from + SCM_DEBUG_REST_ARGUMENTS in order to clarify that we don't test + the actual arguments in the list, but rather the rest argument as + a list of arguments. + + * validate.h (SCM_VALIDATE_REST_ARGUMENT): Added. + + * async.c (scm_noop), eval.c (scm_map, scm_for_each), list.c + (scm_list_star, scm_append, scm_append_x), ports.c + (scm_close_all_ports_except), ramap.c (scm_array_map_x, + scm_array_for_each), regex-posix.c (scm_make_regexp), stacks.c + (scm_make_stack), strings.c (scm_string_append), struct.c + (scm_make_struct, scm_make_vtable_vtable): Validate rest arguments. + + * dynl.c (DYNL_GLOBAL, sysdep_dynl_link, kw_global, sym_global, + scm_dynamic_link, scm_init_dynamic_linking), dynl.h + (scm_dynamic_link): Removed possibility to pass flags to + scm_dynamic_link, as it had no effect anyway. + + * filesys.c (scm_fcntl): Made single optional rest argument into + a standard optional argument. + + * hooks.c (scm_run_hook): A list of rest arguments is never + SCM_UNBNDP. + + * list.c (scm_append, scm_append_x), stacks.c (scm_make_stack), + strings.c (scm_string_append): Don't perform half-hearted checks + to see whether the rest argument forms a proper list any more, use + SCM_VALIDATE_REST_ARGUMENTS instead. + + * ports.c (scm_close_all_ports_except): Accept empty list of rest + arguments. + + * posix.c (scm_convert_exec_args), print.c (scm_simple_format): + Simplify verification of rest argument. + + * stacks.c (scm_make_stack), stacks.h (scm_make_stack), throw.c + (ss_handler, handler_message): Make first mandatory rest argument + of scm_make_stack into a standard mandatory argument. + + * unif.c (scm_transpose_array, scm_enclose_array, + scm_array_in_bounds_p), unif.h (scm_transpose_array, + scm_enclose_array, scm_array_in_bounds_p): Make first mandatory + rest argument into a standard mandatory argument. + +2000-05-17 Dirk Herrmann + + * __scm.h: Added SCM_DEBUG as default debug option. (Thanks to + Keisuke Nishida for the suggestion.) Added debug option + SCM_DEBUG_REST_ARGUMENTS. + + * eval.c (scm_map, scm_for_each): Make sure all lists have the + same length. Also, removed redundant parameter checks. + +2000-05-16 Dirk Herrmann + + * Makefile.am: Let 'make clean' remove *.x and *.doc files. + + * __scm.h: Improved explanation of giving options to make. + + * __scm.h (SCM_DEBUG_TYPING_STRICTNESS), tags.h + (SCM_STRICT_TYPING, SCM_DEBUG_TYPING_STRICTNESS): Renamed + SCM_STRICT_TYPING to SCM_DEBUG_TYPING_STRICTNESS and moved the + corresponding declaration and comment to __scm.h. + + * _scm.h (errno), gc.h (SCM_CELLPTR, SCM_PTR_LT), numbers.c + (scm_remainder, scm_modulo), numbers.h (SCM_SRS, SCM_MAKINUM, + SCM_INUM): Removed conditionally compiled code for Turbo C. + + * gdbint.c (gdb_maybe_valid_type_p): Eliminated call to scm_tag. + That check can be assumed to be redundant except for very rare + conditions that actually indicate broken heap data. + +2000-05-16 Dirk Herrmann + + * numbers.c (scm_logcount, scm_integer_length): Reordered + dispatch sequence. + +2000-05-15 Gary Houston + + * stime.c (scm_strftime): don't reset TZ if zone is an empty + string. append a "0" to the zone for TZ. + +2000-05-15 Dirk Herrmann + + * numbers.c (scm_logbit_p, scm_bit_extract): Reordered dispatch + sequence. + + (scm_bit_extract): Fixed handling of bignums. + +2000-05-15 Dirk Herrmann + + * async.c (scm_sys_gc_async_thunk), chars.h (SCM_ICHRP, SCM_ICHR, + SCM_MAKICHR), continuations.h (SCM_SETJMPBUF), error.c + (scm_sysmissing), error.h (scm_sysmissing), evalext.c + ('serial-map), ioext.c (scm_fseek), ioext.h (scm_fseek), + keywords.c (scm_tc16_kw, scm_init_keywords), ports.h (SCM_CRDY, + SCM_INPORTP, SCM_OUTPORTP), ramap.c ('serial-array-copy!, + 'serial-array-map!), smob.c (scm_newsmob), smob.h (scm_smobfuns, + scm_newsmob), tag.c (scm_tag), tag.h (scm_tag), tags.h + (scm_tc16_flo, scm_tc_flo, scm_tc_dblr, scm_tc_dblc): Wrapped + deprecated code between #if (SCM_DEBUG_DEPRECATED == 0) #endif. + + * fports.c (scm_fport_buffer_add), ports.c (scm_input_port_p, + scm_output_port_p), print.c (scm_get_print_state), validate.h + (SCM_VALIDATE_CHAR): Replace use of deprecated macros + SCM_INPORTP, SCM_OUTPORTP, SCM_ICHRP by SCM_INPUT_PORT_P, + SCM_OUTPUT_PORT_P, SCM_CHARP, respectively. + +2000-05-14 Gary Houston + + * stime.c (scm_strftime): if HAVE_TM_ZONE is not defined, hack the + TZ environment variable so that the %Z format returns the zone + from the input vector instead of the system default. + + from Keisuke Nishida: + * fports.c (scm_setvbuf): minor docstring fix. + * ports.h (scm_generic_fgets): obsolete prototype deleted. + +2000-05-11 Dirk Herrmann + + * __scm.h: Added new section for debugging options. + + (SCM_DEBUG_DEPRECATED): If 1, no deprecated code is included to + help developers to get rid of references to deprecated code. + + * numbers.[ch] (SCM_POSFIXABLE, SCM_NEGFIXABLE, SCM_UNEGFIXABLE, + SCM_FIXABLE, SCM_FLOBUFLEN): These macros are no longer provided + as part of the interface and are marked as deprecated in the + header file. + + * numbers.c (scm_make_real, scm_make_complex): Inlined the + corresponding macros SCM_NEWREAL and SCM_NEWCOMPLEX, + respectively. + + * numbers.h (SCM_NEWREAL, SCM_NEWCOMPLEX, SCM_INEXP, SCM_CPLXP, + SCM_REAL, SCM_IMAG, SCM_REALPART, scm_makdbl, SCM_SINGP, + SCM_NO_BIGDIG, SCM_NUM2DBL, scm_dblproc): Deprecated. + +2000-05-10 Dirk Herrmann + + * gc.h (scm_cell, SCM_CELL_WORD, SCM_CELL_OBJECT, + SCM_SET_CELL_WORD, SCM_SET_CELL_OBJECT): Scheme cells now consist + of two scm_bits_t values instead of two SCM values, because it is + legal for cell entries to hold values that are not scheme objects. + + (SCM_SETAND_CAR, SCM_SETAND_CDR, SCM_SETOR_CAR, SCM_SETOR_CDR): + Use SCM_SETC[AD]R to modify contents of pairs. + +2000-05-10 Dirk Herrmann + + * numbers.c (IS_INF, isfinite): Added FIXME comment. + + (scm_abs, scm_magnitude): Make these two independent of each + other. scm_abs now reports an error if given a complex argument. + + (scm_istr2flo, scm_integer_p). Use SCM_REAL_VALUE instead of + SCM_REALPART if the object is known to be real. + + (scm_init_numbers): No need to use SCM_NEWREAL macro for speed + here. + + * numbers.h (SCM_SINGP): Set to 0 instead of SCM_BOOL_F. + +2000-05-10 Dirk Herrmann + + * eq.c (scm_eqv_p): Separate handling of real and complex + values. Remove #ifdef SCM_BIGDIG #endif test. + + * eval.c (SCM_CEVAL, SCM_APPLY), gh_data.c (gh_scm2floats, + gh_scm2doubles), hash.c (scm_hasher), ramap.c (scm_array_fill_int, + ramap_rp, scm_array_map_x), random.c (vector_scale, + vector_sum_squares), unif.c (scm_make_uve, scm_array_p, + scm_array_set_x): Use SCM_REAL_VALUE instead of SCM_REALPART if + the object is known to be real. Use SCM_COMPLEXP instead of + deprecated SCM_CPLXP. Use SCM_INEXACTP instead of deprecated + SCM_INEXP. + +2000-05-10 Dirk Herrmann + + * numbers.c: No need to include unif.h. + + (IS_INF): Returned to old test for now: x == x + 1 will not work + for large numbers due to rounding errors. + Thanks to Kalle Olavi Niemitalo. + +2000-05-09 Dirk Herrmann + + * numbers.c (scm_divbigdig): Removed outdated comment. + + (scm_number_to_string, scm_string_to_number, scm_number_p, + scm_real_p, scm_integer_p, scm_inexact_p, scm_gr_p, scm_leq_p, + scm_geq_p, scm_make_rectangular, scm_make_polar, + scm_inexact_to_exact): Added comments. + + (add1, scm_init_numbers): Removed add1. + +2000-05-09 Dirk Herrmann + + * numbers.c (IS_INF): The new test is x == x + 1. The old test + x == x/2 did not work for zero values. Thanks to Han-Wen Nienhuys + and Ivan Toshkov. + + (scm_number_to_string, scm_sum, scm_difference, scm_two_doubles, + scm_num2long, scm_num2long_long, scm_num2ulong): Reordered + dispatch sequence. + +2000-05-09 Marius Vollmer + + * scmsigs.c (take_signal): Execute SCM_ASYNC_TICK for SIGSEGV, + SIGILL and SIGBUS signals. These signals are not continuable and + must be handled for real right away. + +2000-05-08 Dirk Herrmann + + * numbers.c (scm_zero_p, scm_positive_p, scm_negative_p, + scm_real_part, scm_imag_part, scm_magnitude, + scm_inexact_to_exact): Reordered dispatch sequence. + +2000-05-08 Dirk Herrmann + + * feature.c: No need to include "libguile/smob.h" + + (scm_loc_features, features, scm_add_feature, scm_init_feature): + Removed variable 'scm_loc_features' as a pointer to the SCM value + holding the features list. Using variable 'features' instead, + which holds the interned pair. Thus, SCM_SETCDR can be used + instead of pointer trickery. + +2000-05-08 Dirk Herrmann + + * alist.c (scm_acons): Use SCM{_SET}?_CELL_OBJECT as long as a + cell is not known to be a valid pair. + +2000-05-08 Dirk Herrmann + + * eval.c (ASRTSYNTAX, scm_m_body, scm_m_letrec1): Removed + ASRTSYNTAX. Using SCM_ASSYNT instead. + + (scm_m_body): Don't create a redundant cons cell. + + (scm_m_do): Removed redundant test 'bodycheck'. + + (bodycheck): Removed. + + * stacks.c (stack_depth, read_frame, read_frames): Removed + redundant calculation of size, minimized some variable scopes. + +2000-05-05 Dirk Herrmann + + * pairs.c (scm_cons, scm_cons2): Use SCM{_SET}?_CELL_OBJECT as + long as a cell is not known to be a valid pair. + + (scm_pair_p): Eliminated redundant SCM_IMP test. + +2000-05-05 Dirk Herrmann + + * eval.c (scm_m_body, scm_macroexp, unmemocopy, scm_eval_args, + scm_deval_args): Eliminated redundant SCM_IMP tests. + + * hashtab.c (scm_ihashx, scm_sloppy_assx, scm_delx_x), weaks.c + (scm_make_weak_key_hash_table, scm_make_weak_value_hash_table, + scm_make_doubly_weak_hash_table): Fixed critical sections. + Thanks to Keisuke Nishida. + +2000-05-05 Dirk Herrmann + + * numbers.c (scm_logand, scm_logior, scm_logxor, scm_logtest): + Fixed some goto-related initialization bugs (introduced by me). + +2000-05-04 Dirk Herrmann + + * numbers.h (SCM_INUM0): Uses SCM_MAKINUM instead of SCM_PACK. + + * dynl.c (dynl_obj, DYNL_OBJ, get_dynl_obj): Removed. + + (DYNL_FILENAME, DYNL_HANDLE): Use SCM_CELL... macros instead of + pointer trickery. + + (SET_DYNL_HANDLE): Added. + + (scm_dynamic_object_p): Simplified. + + (scm_dynamic_unlink, scm_dynamic_func): Changed comment. Deliver + better error message when accessing unlinked dynamic objects. + Eliminated call to get_dynl_obj. + +2000-05-03 Marius Vollmer + + * scmsigs.c (orig_handlers) [!HAVE_SIGACTION]: Fix declaration to + be an array of function pointers instead of being a pointer to an + array returning function. Thanks to Kalle Olavi Niemitalo! + +2000-05-03 Dirk Herrmann + + * numbers.c (scm_divbigbig, scm_divbigint), numbers.h + (scm_divbigbig, scm_divbigint): Don't return zero any more to + indicate that a division has a remainder, return SCM_UNDEFINED + instead. It is improbable that anyone actually used these + functions outside of numbers.c. For this reason and due to the + change in behaviour the functions are static now. Thus, if + surprisingly there are users of these functions they will at least + get alarmed. + + * numbers.c: Removed #ifdef SCM_BIGDIG #endif in those functions, + that already have a clean dispatch order. Note: SCM_BIGDIG is + always defined. + + * numbers.c (scm_inexact_p): Simplified. + + * numbers.c (scm_num_eq_p, scm_less_p, scm_max, scm_min, + scm_product, scm_num2dbl, scm_angle): Reordered dispatch + sequence, thereby fixing some comparisons of SCM values with + integer constants. + + * numbers.c (scm_divide): Division by zero of inums leads to an + error now. (Formerly, an infinite number was returned.) + + Respect the fact, that scm_divbigbig does now return SCM_UNDEFINED + if a division has a remainder. + +2000-05-02 Gary Houston + + * Makefile.am (INCLUDES): add ${INCLTDL} (thanks to Tim Mooney). + +2000-05-02 Dirk Herrmann + + * numbers.c (scm_logtest, scm_division): Reordered dispatch + sequence, thereby fixing some comparisons of SCM values with + integer constants. + + * numbers.h (scm_makdbl): Mark as deprecated at the point of + declaration. + + * eval.c (SCM_CEVAL, SCM_APPLY), gh_data.c (gh_double2scm, + gh_doubles2scm), numbers.c (scm_istr2flo, scm_max, scm_min, + scm_sum, scm_difference, scm_product, scm_divide, scm_sys_expt, + scm_sys_atan2, scm_make_rectangular, scm_make_polar, + scm_real_part, scm_imag_part, scm_magnitude, scm_angle, + scm_long2num, scm_long_long2num, scm_ulong2num), ramap.c + (ramap_rp, scm_array_map_x), random.c (scm_random, + scm_random_uniform, scm_random_normal_vector_x, scm_random_exp), + struct.c (scm_struct_ref), unif.c (scm_array_to_list): Replace + call to scm_makdbl with a call to scm_make_real or + scm_make_complex, depending on whether the imaginary part is known + to be zero. + +2000-05-01 Gary Houston + + * scmsigs.c: fix the definition of orig_handlers for the case + that HAVE_SIGACTION is not defined (thanks to + Kalle Olavi Niemitalo). + + * Makefile.am: remove include_HEADERS (was libguile.h) + libguile.h: moved to top level directory. + +2000-04-28 Dirk Herrmann + + * numbers.c (SCM_SWAP): Moved to the top of the file to allow for + a wider use. + + * numbers.c (scm_modulo, scm_gcd, scm_lcm, scm_logand, scm_logior, + scm_logxor): Reordered dispatch sequence, thereby fixing some + comparisons of SCM values with integer constants. + + * number.c (scm_logtest): Removed some redundant SCM_{N}?IMP + tests. + +2000-04-28 Dirk Herrmann + + * numbers.c (scm_quotient, scm_remainder): Removed code that was + conditionally compiled based on BADIVSGNS. BADIVSGNS does not + occur anywhere else throughout guile. + + * numbers.c (scm_quotient): Fixed parameter number in error + message. + + * numbers.c (scm_remainder): Reordered dispatch sequence. + +2000-04-25 Gary Houston + + * posix.c (scm_execlp): docstring fix (thanks to Martin + Grabmueller). + +2000-04-25 Dirk Herrmann + + * eval.c (undef_object): Made into a local static variable + (suggested by Jost Boekemeier). + +2000-04-25 Dirk Herrmann + + * pairs.c (cxrs, scm_init_pairs): Simplify initialization of + c[ad]+r functions. + + * procs.c (scm_init_iprocs), procs.h (scm_subr, scm_iproc, + scm_dsubr, scm_init_iprocs): Removed. + + * procs.h (SCM_SUBRF, SCM_DSUBRF): Access the cell words + directly instead of casting a cell to a C struct. + +2000-04-22 Mikael Djurfeldt + + Better modularization of GC extensions through new C level GC + hooks: + + * weaks.c (scm_weaks_prehistory): New function: Add + scm_weak_vector_gc_init to scm_before_mark_c_hook; Add + scm_mark_weak_vector_spines to scm_before_sweep_c_hook. + (scm_scan_weak_vectors): New function; added to + scm_after_sweep_c_hook. + + * weaks.h (scm_weak_vectors, scm_weaks_prehistory): Added + declarations. + + * guardians.h (scm_guardian_gc_init, scm_guardian_zombify): Are + now static. + + * guardians.c (scm_guardian_gc_init): Turned into a hook function + and added to scm_before_mark_c_hook. + (scm_guardian_zombify): Turned into a hook function and added to + scm_before_sweep_c_hook. + + * async.c (scm_sys_gc_async_thunk): Run after-gc-hook. + Added #include "libguile/gc.h". + + * gc.h: Added #include "libguile/hooks.h". + + * gc.c: Removed #include "libguile/guardians.h". + (scm_before_gc_c_hook, scm_before_mark_c_hook, + scm_before_sweep_c_hook, scm_after_sweep_c_hook, + scm_after_gc_c_hook): New C level hooks. + (scm_after_gc_hook): New Scheme level hook. + (scm_gc_sweep): Moved scanning of weak vectors to weaks.c. + (scm_igc): Moved initialization of scm_weak_vectors and the call + to scm_guardian_gc_init to respective module. + (scm_mark_weak_vector_spines): Moved to weaks.c; + Call to scm_guardian_zombify moved to guardians.c; + Run scm_before_gc_c_hook, scm_before_sweep_c_hook, + scm_after_gc_c_hook at appropriate places. + (scm_init_gc): Initialize scm_after_gc_hook. + + * hooks.c, hooks.h (scm_make_hook_with_name): Removed deprecated + function. + + * init.c (scm_boot_guile_1): Added `scm_init_hooks'. + + * Makefile.am: Added hooks.c, hooks.h, hooks.x. + + * feature.c, feature.h: Broke out hook code into separate files. + + * hooks.c, hooks.h: New files. + + * *.*: Change includes so that they always use the "prefixes" + libguile/, qt/, guile-readline/, or libltdl/. + (Thanks to Tim Mooney.) + + * Makefile.am (INCLUDES): Removed THREAD_CPPFLAGS and INCLTDL. + (DEFS): Added. automake adds -I options to DEFS, and we don't + want that. + Removed all -I options except for the root source directory and + the root build directory. + + * numbers.c (scm_odd_p, scm_even_p): Use SCM_WRONG_TYPE_ARG + instead of SCM_ASSERT (0, ...). (Some compilers will complain + about control reaching end of function otherwise, and, besides, + the new code is not less clear.) + + * gc.c (scm_must_malloc, scm_must_realloc, scm_must_free): Added + calls to malloc debugging functions. + + * init.c (scm_boot_guile_1): Added calls to debug-malloc init + functions. + + * Makefile.am: Added debug-malloc.c, debug-malloc.h, + debug-malloc.x. + + * debug-malloc.c, debug-malloc.h: New files. + +2000-04-20 Dirk Herrmann + + * numbers.c (scm_exact_p, scm_odd_p, scm_even_p): Added + documentation strings. + + * numbers.c (scm_exact_p, scm_odd_p, scm_even_p, scm_abs, + scm_quotient): Reordered dispatch sequence to first handle + immediates, second handle bignums and finally handle generic + functions respectively signal wrong type arguments. Hopefully + this will allow for easier separation when goops is integrated. + +2000-04-19 Dirk Herrmann + + * gc.c (which_seg): Use SCM2PTR to convert a non immediate SCM + variable into a pointer to a heap cell. + + * gc.c (scm_mark_locations, scm_cellp, init_heap_seg, + scm_unhash_name): Remove redundant cast to SCM_CELLPTR. + +2000-04-19 Dirk Herrmann + + * print.c (scm_iprin1): Don't assign zero to SCM values, use + SCM_UNDEFINED instead. + + * weaks.c (scm_make_weak_vector): Fix assignment of zero to a + vector element. (Still to be improved) + +2000-04-19 Dirk Herrmann + + * eval.c (undef_cell): Removed, replaced by: + + (undef_object): Added to replace undef_cell. + + (scm_lookupcar, scm_lookupcar1): Use undef_object. + + * eval.c (scm_lookupcar, scm_lookupcar1, scm_m_atfop, + scm_m_atbind, CHECK_EQVISH, SCM_CEVAL), procs.h (SCM_SETCODE): + Don't perform arithmetic operations with SCM values. + + * eval.c (scm_lookupcar, scm_lookupcar1, scm_m_atfop, + scm_m_atbind, scm_eval_args, scm_deval_args, SCM_CEVAL): Use + symbolic names for the tc3 type codes. + + * eval.c (scm_m_define, SCM_CEVAL, SCM_APPLY): Remove redundant + cast to SCM. + + * eval.c (scm_eval_args, scm_deval_args, SCM_CEVAL): Made the + access of the struct vcell element explicit. + +2000-04-19 Mikael Djurfeldt + + * struct.c (scm_struct_free_light, scm_struct_free_standard, + scm_struct_free_entity): Use `scm_must_free' instead of `free'. + + * procs.c (scm_make_subr_opt): Tell scm_must_realloc that we're + realloc:ing scm_subr_table ("what" instead of "who"). + + * numbers.c (scm_adjbig): Ditto. + +Tue Apr 18 08:22:41 2000 Greg J. Badros + + * validate.h: Do not cast to (unsigned) in SCM_VALIDATE_INUM_RANGE + when testing high-end of the range. Mikael Djurfeldt noticed this + anomaly -- thanks Mikael! + +2000-04-18 Dirk Herrmann + + * unif.c (l2ra): Don't eliminate the call to scm_array_set_x + itself, as was done in the previous 'patch'. (Thanks to Radey + Shouman) + +2000-04-18 Dirk Herrmann + + * options.c (scm_options), read.c (recsexpr): Remove redundant + SCM_IMP test. + + * print.c (scm_iprin1): Made the access of the struct vcell + element explicit. + + * print.h (SCM_PRINT_CLOSURE): Added call to SCM_PACK. + + * ramap.c (scm_ra_eqp, ra_compare), unif.c + (scm_uniform_vector_ref, scm_cvref, rapr1): Separated accesses to + unsigned long and signed long arrays and clarified the way the + access is performed. + + * ramap.c (scm_array_map_x, raeql), read.c (scm_lreadr), stacks.c + (narrow_stack), unif.c (scm_cvref, scm_uniform_array_read_x, + scm_raprin1): Use SCM_EQ_P to compare SCM values. + + * strings.c (scm_makstr): Treat the msymbol slots as a field of + scm_bits_t values. + + * struct.h (SCM_SET_VTABLE_DESTRUCTOR): Treat the struct data as + a field of scm_bits_t values. + + * unif.c (l2ra): Don't test result of scm_array_set_x against + zero: It is always SCM_UNSPECIFIED. + +2000-04-18 Mikael Djurfeldt + + * script.c (scm_compile_shell_switches): Also enable + record-positions when given the --debug option. (Thanks to Diego + Dainese.) + +2000-04-18 Dirk Herrmann + + * print.c (ENTER_NESTED_DATA, print_circref, scm_iprlist): + Compare SCM's with SCM_EQ_P. + + * print.c (scm_make_print_state), srcprop.c + (scm_source_properties): Use valid scheme object to initialize + SCM variable. + + * print.c (scm_iprin1): Remove redundant calls to SCM_UNPACK. + +2000-04-17 Dirk Herrmann + + * struct.c (scm_alloc_struct, scm_struct_free_0, + scm_struct_free_light, scm_struct_free_standard, + scm_struct_free_entity, scm_make_struct, scm_make_vtable_vtable), + struct.h (scm_struct_free_t, scm_alloc_struct, scm_struct_free_0, + scm_struct_free_light, scm_struct_free_standard, + scm_struct_free_entity): Struct data regions (and thus also + vtable data regions) are now C arrays of scm_bits_t elements. + + * gc.c (scm_gc_mark, scm_gc_sweep, scm_unhash_name): Made the + mixup of glocs and structs explicit. + + * gc.c (scm_unprotect_object): Compare SCM's with SCM_EQ_P. + +2000-04-17 Dirk Herrmann + + * eval.c (scm_unmemocar): Use macros to test for gloc cell. + Minimize scope of variable 'ir'. + + * eval.h (SCM_IFRAME, SCM_IDIST), weaks.h (SCM_IS_WHVEC_ANY): + Added missing call to SCM_UNPACK. + +2000-04-17 Mikael Djurfeldt + + * validate.h (SCM_VALIDATE_INUM_RANGE_COPY, + SCM_VALIDATE_NUMBER_COPY): New macros. + +2000-04-16 Mikael Djurfeldt + + * script.c (scm_compile_shell_switches): Added --debug option. + +2000-04-16 Mikael Djurfeldt + + * vectors.c (scm_vector_set_x): Return SCM_UNSPECIFIED (as + specified by R5RS). + +2000-04-15 Mikael Djurfeldt + + * ports.h (SCM_INPUT_PORT_P, SCM_OUTPUT_PORT_P): New macros. + (SCM_INPORTP, SCM_OUTPORTP): Marked as deprecated. + + * validate.h (SCM_VALIDATE_INPUT_PORT, SCM_VALIDATE_OUTPUT_PORT): + New macros. + Cleanup of code layout. + + * ports.c, ports.h (close-input-port, close-output-port): New R5RS + procedures. + +2000-04-13 Dirk Herrmann + + * continuations.c (scm_make_cont, scm_dynthrow): Completely + separated implementations for defined (CHEAP_CONTINUATIONS) and + !defined (CHEAP_CONTINUATIONS). Also, now using memcpy for stack + copying. + + * continuations.c (grow_stack): Renamed from grow_throw. + + * continuations.c (copy_stack_and_call): New static function. + + * continuations.c (scm_dynthrow): Simplified and made static. + + * continuations.h (scm_dynthrow): Made static. + +2000-04-13 Mikael Djurfeldt + + * unif.c, unif.h (shared-array-root, shared-array-offset, + shared-array-increments): New primitives. + +2000-04-12 Dirk Herrmann + + * gc.c (scm_gc_sweep): Simplify the computation of freed memory + size for msymbols. + + * symbols.h (SCM_SLOTS, SCM_SYMBOL_FUNC, SCM_SYMBOL_PROPS, + SCM_SYMBOL_HASH): The msymbol slots are now a field of scm_bits_t + values. + + * symbols.h (SCM_SET_SYMBOL_FUNC, SCM_SET_SYMBOL_PROPS): New + macros. + + symbols.c (scm_intern_obarray_soft, msymbolize, scm_symbol_fset_x, + scm_symbol_pset_x): Use them. + + * symbols.c (scm_symbol_hash): Unpack to access SCM raw data. + +2000-04-12 Dirk Herrmann + + * ports.c (scm_port_print): The port data is read as raw data. + + * ports.h (SCM_TC2PTOBNUM, SCM_PTOBNUM): Fix SCM/scm_bits_t + mismatch. + +2000-04-11 Dirk Herrmann + + * eval.c (SCM_CEVAL), objects.c (scm_mcache_lookup_cmethod, + scm_make_subclass_object), objects.h (SCM_CLASS_FLAGS, + SCM_ENTITY_PROCEDURE, SCM_ENTITY_SETTER), struct.c + (scm_struct_init, scm_struct_vtable_p, scm_make_struct, + scm_struct_ref, scm_struct_set_x), struct.h (SCM_STRUCT_DATA): + The struct data is now an array of scm_bits_t variables. + + * objects.h (SCM_SET_ENTITY_PROCEDURE): New macro. + + objects.c (scm_set_object_procedure_x): Use it. + + * struct.c (scm_struct_init): Unused variable 'data' removed. + + (scm_struct_vtable_p): Redundant SCM_IMP tests removed. + +2000-04-11 Dirk Herrmann + + * objects.h (SCM_OBJ_CLASS_FLAGS, SCM_OBJ_CLASS_REDEF), struct.h + (SCM_STRUCT_VTABLE_DATA, SCM_STRUCT_LAYOUT, SCM_STRUCT_VTABLE, + SCM_STRUCT_PRINTER): The struct vtable data is now an array of + scm_bits_t variables. + + * struct.h (SCM_SET_STRUCT_LAYOUT): New macro. + + struct.c (scm_make_vtable_vtable): Use it. + +2000-04-11 Dirk Herrmann + + * symbols.c (scm_sym2vcell, scm_sym2ovcell_soft, scm_sym2ovcell, + scm_intern_obarray_soft, scm_sysintern0, + scm_string_to_obarray_symbol, scm_intern_symbol, + scm_unintern_symbol, scm_symbol_binding, scm_symbol_interned_p, + scm_symbol_bound_p, scm_symbol_set_x): Don't use C operators to + compare SCM values. + +2000-04-11 Dirk Herrmann + + * numbers.c (scm_quotient, scm_modulo): Reordered to handle the + case of immediate numbers parameters first. Also, only use + decoded numbers for numerical comparison. + +2000-04-10 Mikael Djurfeldt + + * objects.h: Don't redeclare scm_call_generic_0 and + scm_apply_generic. (Thanks to Tal Tversky.) + +2000-04-10 Dirk Herrmann + + * hash.c (scm_hasher): Use symbolic names for the tc3 constants. + Unpack SCM value to use it as a switch parameter. Don't cast SCM + values to int values. + +2000-04-10 Mikael Djurfeldt + + * coop.c (mother): Handled EINTR (the wait has been interrupted by + a signal). + +2000-04-07 Dirk Herrmann + + * __scm.h (SCM_WTA_DISPATCH_[012n]): To test whether a SCM value + contains a raw zero value it has to be unpacked. + + * debug.c (with_traps_inner, scm_with_traps): Passing SCM values + via void * requires unpacking / packing. + + * stacks.h (SCM_STACKP): Remove unnecessary SCM_NIMP test and use + SCM_EQ_P to compare SCM values. + + * stacks.h (SCM_FRAME_VOID_P, SCM_FRAME_REAL_P, SCM_FRAME_PROC_P, + SCM_FRAME_EVAL_ARGS_P, SCM_FRAME_OVERFLOW_P): Remove unnecessary + call to SCM_UNPACK. + + * tags.h (SCM_NECONSP): Define in terms of SCM_ECONSP + + * tags.h (SCM_ECONSP): Clarify the test for glocs. This is still + quite ugly. + +2000-04-05 Michael Livshin + + * async.[ch]: unexpose low-level async access macros (thanks to + Dirk Herrmann). + + * validate.h: move async validation macros to async.c (nobody else + needs them anyway), and rename them. + +2000-04-04 Michael Livshin + + * async.h: kill the scm_async_t struct. having a heap cell + pretending to be a C struct is not helthy, and is not needed here + anyway, as asyncs happily fit in one heap cell. + + * async.c: reflect the fact that asyncs are now represented by + single heap cell each. + +2000-04-04 Gary Houston + + * error.c (scm_syserror): save errno before doing anything else, + since it's used in two expressions and may get mutated (thanks to + Dirk Herrmann). + +2000-04-04 Dirk Herrmann + + * debug.c (scm_procedure_source, scm_procedure_environment), + gsubr.c (scm_make_gsubr_with_generic, scm_gsubr_apply), procs.c + (scm_procedure, scm_setter): Return valid scheme value as dummy. + + * filesys.c (scm_readdir, scm_rewinddir, scm_closedir, + scm_dir_print, scm_dir_free), numbers.h (SCM_COMPLEX_REAL, + SCM_COMPLEX_IMAG), regex-posix.h (SCM_RGX), throw.c (JBJMPBUF, + SETJBJMPBUF, JBJMPBUF, SETJBJMPBUF, freejb, print_lazy_catch, + scm_ithrow), unif.c (scm_uniform_vector_ref, scm_cvref, + scm_array_set_x, rapr1), unif.h (SCM_ARRAY_V, SCM_ARRAY_BASE), + vectors.h (SCM_VELTS, SCM_VELTS_AS_STACKITEMS, SCM_SETVELTS): Use + SCM_{SET_}?CELL_WORD* to access cell entries with raw data. + + * filesys.c (scm_closedir), numbers.c (scm_addbig), numbers.h + (SCM_SETNUMDIGS), throw.c (JBACTIVE, SCM_JBDFRAME, + SCM_SETJBDFRAME): Read and modify data bits in cell entry #0 using + SCM_{SET_}?CELL_WORD_0. + + * filesys.c (fill_select_type, retrieve_select_type, scm_select), + numbers.c (scm_gcd, scm_lcm, scm_integer_expt, scm_zero_p, + scm_product, scm_divide), posix.c (scm_getgrgid), ramap.c + (scm_array_fill_int, racp), throw.c (scm_catch, scm_lazy_catch, + scm_ithrow), unif.c (scm_make_uve, scm_array_p, + scm_transpose_array, scm_array_set_x, scm_bit_set_star_x, + scm_bit_count_star, l2ra), variable.c (prin_var, + scm_make_variable, scm_make_undefined_variable, + scm_builtin_variable), vectors.c (scm_vector_set_length_x), + vports.c (sf_flush, sf_close): Don't use C operators to compare + SCM values. + + * numbers.c (scm_odd_p, scm_even_p), variable.c (prin_var): Must + unpack SCM values to access their raw contents. + + * numbers.c (big2str): Eliminate unnecessary casts to SCM. + + * numbers.h (SCM_NEWREAL), regex-posix.h (SCM_RGXP), vports.c + (scm_make_soft_port): Use SCM_{SET_}?CELL_TYPE to access the cell + type information. + + * throw.c (printjb): Eliminated unnecessary unpack. + + * variable.c (make_vcell_variable): Smob data is of type + scm_bits_t. + +2000-04-04 Mikael Djurfeldt + + * print.c: Removed promise to rewrite printer code before next + release. :) + +2000-04-03 Mikael Djurfeldt + + * iselect.c (add_fd_sets): Insert empty statement after label. + (Thanks to Tim Mooney.) + +2000-04-03 Michael Livshin + + * guardians.c (scm_guardian_zombify): mark all zombies in a + separate loop after processing all the currently known live + guardians, so as to not introduce order dependencies (thanks to + Gary Houston). note that the order problems are still there if + some guardians are themselves zombies, but that's a sick case that + I'm not going to worry about. + also, make another outer loop to process zombified + guardians (which are uncovered while marking zombies). + +2000-04-03 Dirk Herrmann + + * evalext.c (scm_definedp, scm_m_undefine), gc.c + (scm_mark_weak_vector_spines, scm_gc_sweep), hashtab.c + (scm_hashq_ref, scm_hashv_ref, scm_hash_ref, scm_hashx_ref), + keywords.c (scm_make_keyword_from_dash_symbol), lang.c + (scm_nil_eq), lang.h (SCM_NILP, SCM_NIL2EOL), load.c + (scm_primitive_load), modules.c (scm_module_full_name), objects.c + (scm_class_of, scm_mcache_lookup_cmethod, scm_make_class_object), + ports.c (scm_close_all_ports_except), ports.h (SCM_EOF_OBJECT_P), + print.c (scm_iprin1, scm_prin1, scm_iprlist, scm_simple_format), + print.h (SCM_PRINT_STATE_P), procprop.c (scm_i_procedure_arity, + scm_stand_in_scm_proc, scm_procedure_property, + scm_set_procedure_property_x), procs.c + (scm_procedure_documentation), read.c (scm_lreadr, scm_lreadparen, + scm_lreadrecparen, scm_read_hash_extend), script.c + (scm_compile_shell_switches), srcprop.c (scm_source_property, + scm_set_source_property_x), srcprop.h (SCM_WHASHFOUNDP), stacks.c + (read_frame, NEXT_FRAME, read_frames, narrow_stack, + scm_make_stack, scm_stack_id), strop.c (scm_i_index, + scm_string_index, scm_string_rindex), struct.c (scm_struct_init), + validate.h (SCM_VALIDATE_BOOL_COPY, SCM_VALIDATE_INUM_DEF, + SCM_VALIDATE_INUM_DEF_COPY, SCM_VALIDATE_PROC, + SCM_VALIDATE_ARRAY): Don't use C operators to compare SCM values. + + * feature.c (make_hook), keywords.c + (scm_make_keyword_from_dash_symbol), macros.c (scm_makacro, + scm_makmacro, scm_makmmacro), print.c (scm_iprin1, + scm_printer_apply, scm_port_with_print_state): Smob data is of type + scm_bits_t. + + * feature.c (print_hook), gc.c (scm_object_address), hash.c + (scm_ihashq, scm_ihashv), print.c (scm_iprin1, scm_ipruk), smob.c + (freeprint), struct.c (scm_print_struct): Must unpack + SCM values to access their raw contents. + + * fluids.c (apply_thunk, scm_with_fluids), hashtab.c (fold_proc, + scm_hash_fold), load.c (load, scm_primitive_load): Passing SCM + values via void * requires unpacking / packing. + + * fports.c (scm_fport_buffer_add, scm_setvbuf), procs.h + (SCM_SUBRNUM, SCM_SET_SUBRNUM), srcprop.h (SRCPROPBRK, SRCBRKP): + Read and modify data bits in cell entry #0 using + SCM_{SET_}?CELL_WORD_0. + + * fports.c (scm_fdes_to_port), gc.c (scm_gc_for_newcell, + scm_gc_sweep, init_heap_seg), init.c (start_stack), ports.c + (scm_void_port), procs.c (scm_make_subr_opt, + scm_make_procedure_with_setter), root.c (scm_internal_cwdr), + smob.c (scm_make_smob), strports.c (scm_mkstrport): Use + SCM_SET_CELL_TYPE to write the cell type information. + + * gc.c (scm_gc_mark): Use SCM_CELL_OBJECT* to access SCM values + from cells that are no scheme pairs. + + * gc.c (scm_gc_sweep), mallocs.c (prinmalloc), mallocs.h + (SCM_MALLOCDATA, SCM_SETMALLOCDATA), print.c (scm_ipruk), random.h + (SCM_RSTATE), root.h (SCM_ROOT_STATE), smob.c (scm_smob_free), + srcprop.c (freesrcprops), srcprop.h (SRCPROPPOS, SRCPROPFNAME, + SRCPROPCOPY, SRCPROPPLIST), struct.c (scm_make_struct, + scm_make_vtable_vtable): Use SCM_{SET_}?CELL_WORD* to access cell + entries with raw data. + + * gc.c (scm_init_storage), sort.c (applyless), strop.c + (scm_string_to_list): Eliminate unnecessary casts to SCM. + + * mallocs.c (scm_malloc_obj): Store result of malloc as raw + data. + + * ports.c (scm_close_all_ports_except): Duplicate documentation + text removed. + + * print.c (scm_iprin1): Use SCM_ITAG3. + + * procs.h (SCM_SET_SUBRNUM): Fix shift direction. + + * snarf.h (SCM_GPROC, SCM_GPROC1, SCM_SYMBOL, SCM_GLOBAL_SYMBOL, + SCM_KEYWORD, SCM_GLOBAL_KEYWORD, SCM_VCELL, SCM_GLOBAL_VCELL, + SCM_VCELL_INIT, SCM_GLOBAL_VCELL_INIT): Don't initialize globals + and static variables at their point of declaration, but rather in + the init function. + + * tags.h (SCM_PACK): Automatically cast to scm_bits_t. + +2000-04-02 Gary Houston + + * guardians.c (TCONC_IN, scm_make_guardian): set the CDR of the + empty tconc pair to SCM_EOL instead of SCM_BOOL_F, avoiding the + use of an improper list (which breaks g_print. g_print isn't + used). + guardians.c: Added more comments and modified the make-guardian + docstring. Reordered a few procedures. + +2000-04-01 Dirk Herrmann + + * eval.c (scm_lookupcar1, scm_lookupcar, scm_m_case, scm_m_cond, + scm_m_lambda, iqq, scm_m_define, scm_m_expand_body, unmemocopy, + SCM_CEVAL), procs.h (SCM_TOP_LEVEL): Don't use C operators to + compare SCM values. + + (scm_makprom): Smob data is of type scm_bits_t. + +2000-03-31 Dirk Herrmann + + * backtrace.c (display_error_body), debug.c (scm_procedure_source, + scm_reverse_lookup), dynl.c (scm_dynamic_link): Don't use C + operators to compare SCM values. + + * debug.c (scm_make_debugobj), debug.h (SCM_DEBUGOBJ_FRAME, + SCM_SET_DEBUGOBJ_FRAME): Update SCM_{SET_}?DEBUGOBJ_FRAME to + access raw cell data with SCM_{SET_}?CELL_WORD_1. + + * debug.c (scm_make_debugobj): Don't use SCM_SETCAR to set types. + + * debug.c (scm_make_memoized), dynl.c (scm_dynamic_link): Smob + data is of type scm_bits_t. + +2000-03-31 Dirk Herrmann + + * gdbint.c (gdb_maybe_valid_type_p), guardians.c (TCONC_EMPTYP, + scm_guardian_zombify): Use SCM_EQ_P to compare SCM values. + + * guardians.c (GUARDIAN): Use SCM_CELL_WORD_1 for raw data. + +2000-03-31 Dirk Herrmann + + * ports.h (scm_port): Change type of stream member to scm_bits_t. + + * gdbint.c (unmark_port, remark_port), ports.c (scm_markstream), + strports.c (st_resize_port, scm_mkstrport), vports (sf_flush, + sf_write, sf_fill_input, sf_close, scm_make_soft_port): Since + streams are now of type scm_bits_t, SCM streams have to be + unpacked/packed. + + * ports.h (SCM_SETPTAB_ENTRY, SCM_SETSTREAM): Cast input to + scm_bits_t. + +2000-03-31 Mikael Djurfeldt + + * coop-defs.h (struct coop_t): Added `sto'-field again because of + binary compatibility---let's remove it next time we alter some + major structure. + + * coop.c (coop_quitting_p, coop_cond_create, coop_mutex_create, + coop_mother, coop_child): New variables. + (mother): New function. + (coop_create): New thread spawning mechanism which uses a "mother + thread". The "dummy" pthreads aren't healthy enough to give birth + to new threads since Linux threads thinks they are asleep. + + * coop-defs.h (struct coop_t): Removed dummy_mutex. + + * coop-defs.h, coop-threads.c (struct coop_t): Eliminate + `sto'-field when GUILE_PTHREAD_COMPAT is enabled. + +2000-03-30 Dirk Herrmann + + * arbiters.c (scm_make_arbiter), async.c (scm_async), dynwind.c + (scm_internal_dynamic_wind): Smob data is always of type + scm_bits_t. + + * arbiters.c (SCM_ARB_LOCKED, SCM_LOCK_ARB, SCM_UNLOCK_ARB): + Access the locking information in cell entry 0 with + SCM_{SET_}?CELL_WORD_0 instead of SCM_*CAR. + + * async.c (scm_run_asyncs): Use SCM_NULLP to test for the empty + list. + + * dynwind.c (scm_dowinds): Use SCM_EQ_P to compare SCM values. + + * ports.h (SCM_PTAB_ENTRY, SCM_SETPTAB_ENTRY): Access the ptab + entry data using SCM_{SET_}?CELL_WORD_1 instead of SCM_{SET}?CDR. + +2000-03-29 Dirk Herrmann + + * alist.c (scm_sloppy_assq, scm_assq), eq.c (scm_eq_p, scm_eqv_p, + scm_equal_p), list.c (scm_ilength, scm_last_pair, scm_reverse, + scm_sloppy_memq, scm_delq_x, scm_delq1_x), tags.h (SCM_UNBNDP): + Don't use C operators == and != to compare SCM values, use + SCM_EQ_P instead. + + * boolean.c (scm_boolean_p): Use SCM_BOOLP to determine whether a + SCM value is equal to #t or #f. + + * eq.c (scm_eqv_p, scm_equal_p): Don't use SCM_CAR to access the + cell type entry of non immediate objects of unknown type. Use + SCM_CELL_TYPE instead. + + * gh_data.c (gh_scm2bool, gh_module_lookup), list.c + (scm_sloppy_memv, scm_sloppy_member, scm_delv_x, scm_delete_x, + scm_delv1_x, scm_delete1_x), scmsigs.c (scm_sigaction): Use + SCM_FALSEP and SCM_TRUE_P to compare SCM values against #f and + #t. + + * list.c (scm_listify): Use SCM_UNBNDP to test for an unbound + scheme value. + +2000-03-29 Mikael Djurfeldt + + * coop-threads.c (scm_call_with_new_thread, scm_spawn_thread, + scm_make_mutex, scm_make_condition_variable): Cast data to + scm_bits_t in SCM_SET_CELL_WORD and SCM_NEWSMOB macros. + + * coop.c (coop_create): Set `specific' field, not `data' to NULL. + +2000-03-29 Dirk Herrmann + + * smob.h (SCM_NEWSMOB, SCM_NEWSMOB2, SCM_NEWSMOB3, SCM_SMOB_DATA, + SCM_SET_SMOB_DATA, SCM_TC2SMOBNUM, SCM_SMOBNUM): To access smob + data, use SCM_{SET_}?CELL_TYPE or SCM_{SET_}?WORD_[1-3]. + + Note that this implies that smob data has always to be passed as + values of type scm_bits_t. + +2000-03-29 Mikael Djurfeldt + + * threads.c (scm_init_threads): Pass 0 size to scm_make_smob_type + for scm_tc16_thread. As the current COOP threads are written, GC + is not supposed to manage storage for threads. + + * error.c (scm_error): Don't try to throw an error if + scm_gc_heap_lock is true. + + * coop.c (coop_finish): New function. Called at exit. + (coop_aborthelp): Free thread structures when threads die. + Finished LinuxThreads compatibility support => COOP threads now + mesh with LinuxThreads. + + * coop-threads.c (scm_call_with_new_thread, scm_spawn_thread): + Changed SETCDR --> SET_CELL_WORD_1. + + * coop-threads.c (scheme_launch_thread): Set word 1 of handle to 0 + when thread dies. + +2000-03-29 Dirk Herrmann + + * boolean.h (SCM_TRUE_P): New macro. + + * boolean.h (SCM_FALSEP, SCM_NFALSEP, SCM_BOOLP), pairs.h + (SCM_NULLP, SCM_NNULLP): Use SCM_EQ_P to compare SCM values. + +2000-03-28 Dirk Herrmann + + * continuations.h (SCM_CONTREGS, SCM_SET_CONTREGS): New macros to + access continuation data. + + (SCM_SETJMPBUF): Deprecated. Use SCM_SET_CONTREGS instead. + + (SCM_JMPBUF, SCM_DYNENV, SCM_THROW_VALUE, SCM_BASE, SCM_SEQ, + SCM_DFRAME): Use SCM_CONTREGS instead of SCM_CHARS to access + continuation data. + + * continuations.c (scm_make_cont), init.c (start_stack), + root.c (scm_internal_cwdr): Use SCM_SET_CONTREGS instead of + SCM_SETJMPBUF. + +2000-03-28 Dirk Herrmann + + * symbols.h (SCM_LENGTH, SCM_SETLENGTH): Access the length field + of strings and symbols by using SCM_{SET_}?CELL_WORD_0. + + (SCM_CHARS, SCM_UCHARS, SCM_SETCHARS): Use SCM_{SET_}?CELL_WORD_1 + to access the char * field of strings and symbols. + +2000-03-27 Dirk Herrmann + + * gc.h (SCM_NEWCELL, SCM_NEWCELL2): Use SCM_SET_CELL_TYPE to set + the type entry of a new cell. Added a comment about things to + remember when updating the list of free cells. + + (SCM_FREEP, SCM_MARKEDP): Use SCM_CELL_TYPE to access the type + entry of a cell. + +2000-03-27 Dirk Herrmann + + * pairs.h (SCM_CAR, SCM_CDR, SCM_SETCAR, SCM_SETCDR): Use + SCM_CELL_OBJECT and SCM_SET_CELL_OBJECT. This change implies that + with strict type checking enabled these macros will only work if + given valid SCM parameters. + + (SCM_GCCDR): Moved to tags.h. + + * tags.h (SCM_GCCDR): Moved here from pairs.h. + +2000-03-26 Dirk Herrmann + + * tags.h (SCM2PTR, PTR2SCM): Moved to gc.h. + + * pairs.h (scm_cell, SCM_CELLPTR, SCM_CELL_WORD*, SCM_CELL_OBJECT*, + SCM_SET_CELL_WORD*, SCM_SET_CELL_OBJECT*, SCM_CELL_TYPE, + SCM_SET_CELL_TYPE, SCM_PTR_LT, SCM_PTR_MASK, SCM_PTR_GT, + SCM_PTR_LE, SCM_PTR_GE, SCM_CELL_WORD_LOC, SCM_NEWCELL, + SCM_NEWCELL2): Moved to gc.h. + + (SCM_CARLOC, SCM_CDRLOC, SCM_SETAND_CAR, SCM_SETAND_CDR, + SCM_SETOR_CAR, SCM_SETOR_CDR): Moved to gc.h. These names should + be changed, though, since the macros are not only pair related. + + (SCMPTR): Deleted. + + * gc.h (SCM2PTR, PTR2SCM, scm_cell, SCM_CELLPTR, SCM_CELL_WORD*, + SCM_CELL_OBJECT*, SCM_SET_CELL_WORD*, SCM_SET_CELL_OBJECT*, + SCM_CELL_TYPE, SCM_SET_CELL_TYPE, SCM_PTR_LT, SCM_PTR_MASK, + SCM_PTR_GT, SCM_PTR_LE, SCM_PTR_GE, SCM_CELL_WORD_LOC, + SCM_NEWCELL, SCM_NEWCELL2, SCM_CARLOC, SCM_CDRLOC, SCM_SETAND_CAR, + SCM_SETAND_CDR, SCM_SETOR_CAR, SCM_SETOR_CDR): Moved here from + tags.h and pairs.h. + +2000-03-25 Dirk Herrmann + + * tags.h (SCM_STRICT_TYPING): New macro that, if defined, + activates strict compile time type checking for variables of + type SCM. + (SCM, SCM_PACK, SCM_UNPACK): Define according to whether + SCM_STRICT_TYPING or SCM_VOIDP_TEST are defined. + (SCM_EQ_P): Defined as a macro equivalent for eq?. + +2000-03-25 Dirk Herrmann + + * tags.h (SCM_POINTERS_MUNGED): Removed. + + * gc.c (scm_gc_sweep, init_heap_seg): Removed use of + SCM_POINTERS_MUNGED, thus fixing some illegal casts to SCM. + +2000-03-24 Dirk Herrmann + + * pairs.h (SCM_CELL_OBJECT, SCM_CELL_OBJECT_[0-3], + SCM_SET_CELL_OBJECT, SCM_SET_CELL_OBJECT_[0-3], SCM_CELL_TYPE, + SCM_SET_CELL_TYPE): Added a set of low level macros for accessing + cell entries. + (SCM_CELL_WORD_[0-3]): Renamed from the SCM_CELL_WORD[0-3]. + + * procs.h, procs.c: Instead of SCM_{SET_}?CELL_WORD[12], use the + newly introduced SCM_{SET_}?CELL_OBJECT_[12] macros. + +2000-03-23 Mikael Djurfeldt + + * tags.h: Disabled definition of SCM_VOIDP_TEST. + + Defining SCM as void * introduces problems which haven't been + handled yet. Developers who work with these issues can enable it + in their working copies. + + Disabling this definition exposes a set of newly introduced and + older misuses of types which causes warning messages during + compilation. We'll fix this successively. + + * gc.c (scm_mark_locations): Changed * (SCM **) X --> * (SCM *) X + in order to obtain a value of type SCM. + (scm_cellp): Updated with new changes to scm_mark_locations. + + * continuations.h (SCM_SETJMPBUF): Cast second arg into SCM. + + * continuations.c (scm_make_cont): Removed cast of size_t into + long. + + * symbols.h (SCM_SETCHARS): Cast second arg into SCM. + +2000-03-22 Dirk Herrmann + + * numbers.h (SCM_SETNUMDIGS): Use SCM_BIGSIZEFIELD macro for + shifting, not constant. Thanks to Dale P. Smith. + + * numbers.c (scm_sum, scm_difference): Don't test a SCM value + for being less than zero. Decode it to a C value first. Again, + thank you Dale. + +2000-03-22 Dirk Herrmann + + * numbers.h, ramap.c, struct.h, vectors.h: Don't use SCM2PTR for + non scheme values. If raw data is stored in SCM variables, it has + to be accessed using SCM_UNPACK until a better solution is found. + +2000-03-22 Mikael Djurfeldt + + * tags.h (SCM_ECONSP, SCM_NECONSP): More corrections of + pointer-arithmetic induced by the SCM_PACK/UNPACK change. + + * print.c (scm_iprin1): SCM_PACK/UNPACK corrections. + + * gc.c (scm_gc_sweep): SCM_PACK/UNPACK corrections. + + * eval.c (SCM_CEVAL, scm_unmemocar): SCM_PACK/UNPACK corrections. + + * dynwind.c (scm_swap_bindings): SCM_PACK/UNPACK corrections. + + * async.c, __scm.h: Removed lots of the old async click logic. It + is possible to reinsert it by defining GUILE_OLD_ASYNC_CLICK in + __scm.h. Let's try this out and dump the old code after the + threads reorganization. + (set-tick-rate, set-switch-rate): Conditionally removed. + +2000-03-21 Mikael Djurfeldt + + * gc.c (scm_gc_mark): Bugfix 1: The recent SCM_PACK/UNPACK change + made SCM values into pointers. This turned an arithmetic + computation of the address of the vcell into a pointer-arithmetic + one, thereby screwing up marking of structs. + Bugfix 2: Removed incompletely introduced loop variable `j' used + when protecting the tail array of a struct. + +2000-03-21 Dirk Herrmann + + * struct.h (SCM_STRUCT_DATA): Don't cast SCM values to pointers. + +2000-03-21 Dirk Herrmann + + * symbols.h, symbols.c (scm_strhash): Declare the string + parameter as constant, since it is not modified. + + * symbols.c (scm_intern_obarray_soft, + scm_sysintern0_no_module_lookup): Can now pass constant strings + to scm_strhash without need for casting. + +2000-03-21 Dirk Herrmann + + * vectors.h (SCM_VELTS, SCM_VELTS_AS_STACKITEMS): Don't cast SCM + values to pointers. Use SCM2PTR instead. + +2000-03-21 Dirk Herrmann + + * async.c (scm_set_tick_rate, scm_set_switch_rate): Don't unpack + results of SCM_INUM. + +2000-03-21 Mikael Djurfeldt + + * init.c (scm_boot_guile_1): Renamed GUILE_GC_TRIGGER_1 --> + GUILE_MIN_YIELD_1, GUILE_GC_TRIGGER_2 --> GUILE_MIN_YIELD_2. + GUILE_MIN_YIELD_X now take *positive* fractions of heap size. + + * gc.c, gc.h (SCM_MIN_YIELD_1, SCM_MIN_YIELD_2, + min_yield_fraction, min_yield, adjust_min_yield): Renamed from + SCM_GC_TRIGGER_1, SCM_GC_TRIGGER_2, gc_trigger_fraction, + gc_trigger, adjust_gc_trigger. + + * gc.c (alloc_some_heap): Further improvement of minimal heap size + prediction. + (SCM_MAX): New macro. + (scm_freelist_t): New field: collected_1. Previous amount of + collected cells. + (gc_sweep_freelist_finish): Trigger based on two last values of + freelist->collected to avoid unnecessary allocation due to + temporary peaks. + (SCM_INIT_HEAP_SIZE_1, SCM_GC_TRIGGER_1, SCM_GC_TRIGGER_2): + Adjusted to 45000 cells, 40% and 40%. Gives quick startup + without extra heap allocation. + +2000-03-20 Dirk Herrmann + + * numbers.h (SCM_MAKINUM): The parameter to SCM_MAKINUM should + already be a C value. No need to unpack it. + + * numbers.c (scm_long_long2num): Cast the parameter to scm_bits_t + if we know it fits into an inum. + + * ramap.c (ramap_rp): An scm_tc7_[ui]vect object does point to a + field of long values. In contrast, SCM_VELTS accesses a field of + SCM values. + +2000-03-20 Mikael Djurfeldt + + * gc.c (scm_gc_stats): Inserted explanation of local_scm_mtrigger + etc. + (scm_gc_yield_1): New variable: Holds previous yield. Used to + make better judgements. + (gc_sweep_freelist_finish): Inserted explanation of use of + gc_trigger. + + * print.h, stacks.h, options.c, options.h: Changed C++ + commentaries to C. + +2000-03-20 Dirk Herrmann + + * tags.h (SCM2PTR, PTR2SCM): Use SCM_PACK / SCM_UNPACK correctly. + + * numbers.h (SCM_INUMP, SCM_MAKINUM, SCM_INUM0, SCM_COMPLEX_REAL, + SCM_COMPLEX_IMAG, SCM_NUMP, SCM_BDIGITS): Use SCM_PACK / + SCM_UNPACK / SCM2PTR correctly. + +2000-03-20 Mikael Djurfeldt + + * gc.c (adjust_gc_trigger): Improved documentation. + (alloc_some_heap): Since gc_trigger is used against + freelist->collected, this is the value which should be used to + predict minimum growth. + +2000-03-20 Dirk Herrmann + + * eval.h: Fix mixup of packed/unpacked SCM values. (Thanks + Thien-Thi Nguyen for the patch.) + +2000-03-20 Dirk Herrmann + + * numbers.c (scm_ash): Fixed typing problems with the second + parameter and added some documentation. (Thanks Thien-Thi Nguyen + for indicating the problem.) + +2000-03-19 Mikael Djurfeldt + + * gc.c, gc.h (scm_gc_yield): New variable. + (adjust_gc_trigger): Use scm_gc_yield. + (alloc_some_heap): Use scm_gc_yield instead of + scm_gc_cells_collected. + + * coop-threads.c: Addd #include "root.h", #include "strings.h". + + * debug.c: Added #include "root.h". (Thanks to Thien-Thi Nguyen.) + + * gc.c (scm_gc_for_newcell, adjust_gc_trigger): Improved GC + trigger adjustmeant: Take yield (freed cells) for all freelists + into account. + (SCM_INIT_HEAP_SIZE_1, SCM_GC_TRIGGER_1, SCM_GC_TRIGGER_2): Tuned + to 50000 cell heap with 45% trigger. + (scm_gc_cells_collected): Reintroduced. + (SCM_HEAP_SIZE): New macro. + (scm_gc_sweep): Reintroduced correct computation of + scm_cells_allocated. + (scm_freelist_t): Corrected commentary for field `cluster_size': + Clustersize counts objects, not cells; New member + `clusters_allocated'. + +2000-03-19 Michael Livshin + + * *.[hc]: add Emacs magic at the end of file, to ensure GNU + indentation style. + +2000-03-19 Mikael Djurfeldt + + * threads.h: Added #include "libguile/throw.h". (Thanks to + Thien-Thi Nguyen.) + +2000-03-18 Michael Livshin + + * tags.h: (SCM_DOUBLE_CELLP, SCM_NDOUBLE_CELLP): new macros (bad + names, anyone got any better ones?) + + * gc.h: (typedef struct scm_freelist_t) remove from here. + + * gc.c: (CELL_UP, CELL_DN) made these macros take additional + parameter (the span). + (CLUSTER_SIZE_IN_BYTES, ALIGNMENT_SLACK) new macros. + (typedef struct scm_freelist_t) moved here from gc.h, it had no + business being externally visible. + (typedef struct scm_heap_seg_data_t) renamed from + scm_heap_seg_data, to be style-compliant. + (scm_mark_locations) if the possible pointer points to a + double-cell, check that it's properly aligned. + (init_heap_seg) align double-cells properly, work with the + assumption that the segment size divides cleanly by cluster size. + (round_to_cluster_size) new function. + (alloc_some_heap, make_initial_segment) use round_to_cluster_size + to satisfy the new init_heap_seg invariant. + +2000-03-18 Dirk Herrmann + + * _scm.h: Don't include async.h everywhere... + + * eq.c eval.c iselect.c: ... only include it here. + +2000-03-18 Dirk Herrmann + + * _scm.h: Don't include root.h everywhere... + + * async.c continuations.c eq.c eval.c evalext.c feature.c gc.c + gdbint.c gsubr.c ioext.c keywords.c lang.c load.c macros.c + numbers.c objprop.c ports.c print.c procprop.c ramap.c read.c + srcprop.c stackchk.c stacks.c strports.c symbols.c unif.c + variable.c vectors.c vports.c: ... only include it here. + +2000-03-17 Dirk Herrmann + + * _scm.h: Don't include strings.h everywhere... + + * backtrace.c dynl.c error.c feature.c filesys.c fports.c gc.c + gdbint.c ioext.c load.c net_db.c numbers.c objects.c options.c + ports.c posix.c print.c procs.c random.c read.c regex-posix.c + simpos.c socket.c stacks.c stime.c strop.c strports.c struct.c + symbols.c unif.c vectors.c version.c vports.c: ... only include it + here. + +2000-03-17 Dirk Herrmann + + * _scm.h: Don't include ports.h everywhere... + + * arbiters.c backtrace.c debug.c dynl.c dynwind.c eval.c feature.c + fluids.c gc.c gdbint.c guardians.c hash.c keywords.c mallocs.c + numbers.c objects.c print.c read.c root.c smob.c srcprop.c + stackchk.c strports.c struct.c throw.c variable.c: ... only + include it here. + +2000-03-17 Dirk Herrmann + + * _scm.h: Don't include vectors.h everywhere... + + * eq.c eval.c filesys.c gc.c gsubr.c guardians.c hash.c hashtab.c + keywords.c net_db.c numbers.c objects.c posix.c print.c procprop.c + procs.c ramap.c random.c read.c scmsigs.c socket.c sort.c stime.c + strports.c symbols.c unif.c vports.c weaks.c: ... only include it + here. + +2000-03-17 Dirk Herrmann + + * genio.h: removed. (Only content was '/* delete me */'.) + + * Makefile.am arbiters.c backtrace.c debug.c dynl.c dynwind.c + error.c filesys.c fluids.c gc.c gsubr.c guardians.c keywords.c + libguile.h mallocs.c numbers.c print.c random.c read.c root.c + srcprop.c stackchk.c struct.c threads.c throw.c variable.c: + Removed reference to genio.h + +2000-03-17 Mikael Djurfeldt + + * gc.c, gc.h: Cleanup of the change of 2000-03-15. + Cluster sizes are now independent of GC trigger values. + GUILE_GC_TRIGGER_n can now specify a relative trigger value: + A negative integer gives fraction of total heap size in percent. + (SCM_GC_TRIGGER_1, SCM_GC_TRIGGER_2): Default values set to -40. + + * init.c (scm_boot_guile_1): Introduced new variable + GUILE_MAX_SEGMENT_SIZE; New environment variable names: + GUILE_INIT_SEGMENT_SIZE_1, GUILE_GC_TRIGGER_1, + GUILE_INIT_SEGMENT_SIZE_2, GUILE_GC_TRIGGER_2 + +2000-03-16 Mikael Djurfeldt + + * __scm.h (GC_FREE_SEGMENTS): Disable this until we have made + freeing of segment work with the new GC scheme. (Thanks to + Michael Livshin.) Oops, also happened to make GUILE_NEW_GC_SCHEME + the default, but I'll let this change stay in CVS Guile since this + code is not expected to contain serious bugs. + +2000-03-16 Mikael Djurfeldt + + * gc.c, gc.h (scm_map_free_list): Define also if GUILE_DEBUG is + defined. + (scm_free_list_length): New procedure (GUILE_DEBUG). + Fixed a small but serious bug introduced by the previous change. + + * gc.c (scm_gc_sweep): Moved variable n_objects to inner sweep + loop and declare as register. + + * gc.c (scm_gc_sweep): Sigh... forgot to clear private freelists + after GC. + +Wed Mar 15 08:27:04 2000 Greg J. Badros + + * fluids.c: Docstring patch from Keisuke Nishida. Some + reindentation, too, and a couple formals renamed. Should + fluid-set! return UNSPECIFIED instead of a value? + +Wed Mar 15 08:24:58 2000 Greg J. Badros + + * Makefile.am: Separate out DOT_X_FILES and DOT_DOC_FILES, and + generate the latter from the concrete listing of the former. Then + make guile-procedures.txt depend on DOT_DOC_FILES instead of + *.doc, so that rebuilding it works. + +Wed Mar 15 08:12:14 2000 Greg J. Badros + + * libguile.h: Include libguile/validate.h. Thanks Keisuke Nishida! + + * guile-snarf.awk.in: Replace docstring line-ending \n" and \n\n" + with nothing and \n, respectively. Thanks Keisuke Nishida for + noticing this problem. + +2000-03-15 Mikael Djurfeldt + + * __scm.h (GUILE_NEW_GC_SCHEME): Define this if you want to test a + new way of allocating heap. It makes Guile fast, but still + contains bugs. + + * gc.c, gc.h, pairs.h, init.c: Implementation of a new way of + allocating heap. The basic idea is to trigger GC every Nth + allocated cell and grow heap when free list runs out. The scheme + has been extended so that GC isn't triggered until all remaining + cells are used. The implementation is also prepared for + development in the direction of POSIX threads. + + * gc.c (SCM_EXPHEAP): In order to grow by a factor of 1.5, + SCM_EXPHEAP should return half of the heap size. + +2000-03-14 Mikael Djurfeldt + + The following change to init.c is only enabled if Guile was + configured with --enable-guile-debug. + + * init.c (scm_i_getenv_int): New function. + (scm_boot_guile_1): Use the environment variables + GUILE_INIT_HEAP_SIZE, GUILE_INIT_HEAP_SIZE2 to select heap size if + they exist. (This may be replaced by a Scheme level mechanism in + the future.) + + * objprop.c (s_scm_set_object_property_x): Use scm_assq instead of + scm_assoc. (Thanks to Keisuke Nishida.) + +2000-03-14 Mikael Djurfeldt + + * eval.c, lang.c, lang.h (scm_lisp_nil, scm_lisp_t): Renamed from + scm_nil, scm_t. (Thanks to Keisuke Nishida.) + +2000-03-14 Mikael Djurfeldt + + * init.c (scm_boot_guile_1): Use same initial segment size for + 1-word and 2-word segments. Having the smaller size causes Guile + to GC too often. Obviously something needs to be done to allow + for a smaller 2-word segment without this to happen. (The amount + of heap for each type should be automatically adapted to the + application somehow.) + + [Almost all of these changes should be documented in the NEWS + file.] + + * gc.h (scm_freelist_t): New type. + + * pairs.h (SCM_NEWCELL, SCM_NEWCELL2): Use new style freelists. + + * gc.c (SCM_INIT_HEAP_SIZE): Changed from 32768 --> 40000 so that + all of Guile basics fits into one segment and there suitable room + for work. + (SCM_EXPHEAP): Now takes an argument. Grow by a factor of 1.5 + instead of 2. + (scm_freelist, scm_freelist2): Now of type scm_freelist_t. + Freelists now contains information about object span, cells + collected and amount of cells in heap segments belonging to the + list. + (scm_heap_size, scm_gc_cells_collected): Removed. + + * init.c (scm_boot_guile_1): Make 2-word segment 8K (512 cells). + + * Makefile.am (libguile_la_LDFLAGS): Bumped library version + number. + + * __scm.h eq.c, eval.c, gc.c, gc.h, gh_data, hash.c, numbers.c, + numbers.h, objects.c, ramap.c, random.c, unif.c, unif.h: Extensive + rewrite of handling of real and complex numbers. + (SCM_FLOATS, SCM_SINGLES): These #ifdef conditionals have been + removed along with the support for floats. (Float vectors are + still supported.) + + * tags.h (scm_tcs_bignums): Removed. + (scm_tc16_bigpos, scm_tc16_bigneg): Replaced by scm_tc16_big. + Use SCM_BIGSIGN(x) to test for sign! + (scm_tc16_big): The new bignum type. + (SCM_REAL_PART, SCM_IMAG_PART): Removed. + + * numbers.h (SCM_BIGSIGN): Sign moved to bit 16. + (scm_makdbl): Deprecated. + (SCM_NEWREAL, SCM_NEWCOMPLEX): New macros. + (SCM_SINGP): Deprecated. + (SCM_FLO): Removed. + (SCM_INEXP, SCM_CPLXP): Deprecated. + (SCM_INEXACTP, SCM_COMPLEXP): New macros. + (SCM_COMPLEX_REAL, SCM_COMPLEX_IMAG): Renamed from + SCM_REAL, SCM_IMAG (and now only valid for complex numbers). + (SCM_REAL, SCM_IMAG): New, *deprecated*, selectors which work both + for doubles and complex numbers. + (SCM_REAL_VALUE): New selector for doubles. + (scm_double_t, scm_complex_t): New types. + (scm_dbl): Removed. + + * numbers.c (scm_floprint, scm_floequal): Removed. + (scm_print_real, scm_print_complex, scm_real_equalp, + scm_complex_equalp): New functions. + + * unif.c (scm_makflo): Removed. + + * smob.h (SCM_SMOB_PREDICATE): New macro. + (SCM_NEWSMOB2, SCM_RETURN_NEWSMOB2, SCM_NEWSMOB3, + SCM_RETURN_NEWSMOB3): New macros. + +1999-11-21 Michael Livshin + + The following changes implement primitive support for double cells + (i.e. four-word cells) and change the representation of some + things to multi-cells instead of cons+malloc. (Applied and + modified by mdj.) + + * pairs.h (SCM_NEWCELL2): double-cell variants of SCM_NEWCELL. + (SCM_CELL_WORD, SCM_CELL_WORDLOC, SCM_SET_CELL_WORD): primitive + multi-cell access macros (used by the ones below). + (SCM_CELL_WORD[0-3], SCM_SET_CELL_WORD[0-3]): multi-cell access + macros. + + * gc.c (scm_freelist2): multi-cell freelists. + (inner_map_free_list): map_free_list, parameterized on ncells. + "nn cells in segment mm" was misleading for ncells > 1; changed to + "objects". still print cells too, though. + (scm_map_free_list): rewritten using inner_map_free_list. + (scm_check_freelist): get freelist as parameter, since now we have + more than one. + (scm_debug_newcell2): multi-cell variants of + scm_debug_newcell. + (scm_gc_for_newcell): take ncells and freelist pointer as + parameters. + (scm_gc_mark): add case for tc7_pws (procedures with setters are + now double cells). + (scm_gc_sweep): don't free the float data, since it's not malloced + anymore. + (init_heap_seg): didn't understand what n_new_objects stood for, + so changed to n_new_cells. + (make_initial_segment): new function, makes an initial segment + according to given ncells. + (scm_init_storage): call make_initial_segment, for ncells={1,2,3}. + + * numbers.c (scm_makdbl): no malloc'ing needed, so the + {DEFER,ALLOW}_INTS thing removed. + + * numbers.h (struct scm_dbl): changed to represent a double cell, + with the number in the second half. + + * dynwind.c: changed the wind-guards representation to double + cell. + + * procs.c, procs.h: changed the procedure-with-setter representation + to double cell. + + * async.c, async.h: made async representation a double cell. + + * dynl.c: made dynamic_obj representation a double cell. + +2000-03-13 Gary Houston + + * ports.c (flush_void_port): renamed to flush_port_default. + (end_input_void_port): renamed to end_input_default. + + * init.c (scm_standard_stream_to_port): create a void port instead + of opening /dev/null if the standard file descriptors are bad. + advantages: no portability problems, doesn't waste a file descriptor, + simplifies the code (thanks to Marius for the idea). + + * vports.c (s_scm_make_soft_port): call scm_port_non_buffer. + + * void ports: make reading from a void port give EOF instead of + segv: + * ports.c (s_scm_sys_make_void_port): modified docstring. + (fill_input_void_port): new proc. + (scm_init_ports): set up fill_input_void_port. + * ports.c (scm_port_non_buffer): new proc. + (scm_void_port): call scm_port_non_buffer. + + * fports.c (scm_setvbuf): docstring: remove the fcntl documentation + which was incorrectly appended. + +2000-03-13 Mikael Djurfeldt + + * guile-doc-snarf.in: Don't use absolute path for `sed'. (Note + that we can't use autoconf for this. Autoconf itself relies on + the existence of `sed' somewhere on your path.) (Thanks to Dirk + Herrman.) + +2000-03-13 Mikael Djurfeldt + + * Makefile.am (libguile_la_SOURCES): Moved iselect.c here from + EXTRA_libguile_la_SOURCES. + + * iselect.h: Always declare scm_internal_select. + + * iselect.c (scm_internal_select): Added SCM_ASYNC_TICK at the + end. Also let scm_internal_select be a real function also when + not using threads. + + * __scm.h (SCM_TICK): Oops! Forgot to put SCM_ASYNC_TICK here... + +2000-03-13 Mikael Djurfeldt + + * __scm.h (SCM_ALLOW_INTS, SCM_REALLOW_INTS): Removed call to + SCM_ASYNC_TICK. (This is a preparation for POSIX threads support, + and kind of an experiment: Will this cause problems?) + +Sun Mar 12 13:26:30 2000 Greg J. Badros + + * Makefile.am: Added *.doc to DISTCLEANFILES. + +2000-03-12 Gary Houston + + * fports.c (scm_fdes_to_port): call fcntl F_GETFL to test that + the fdes is valid before doing anything else. check that + the file descriptor supports the modes required. + (scm_fport_buffer_add): don't throw an error if fstat doesn't + work: just use the default buffer size. + + * throw.c: change an outdated comment about scm_internal_catch + BODY: it doesn't take a jumpbuf arg. + + * init.c (scm_standard_stream_to_port): install a handler in case + scm_fdes_to_port throws an error. don't check here whether the + file descriptor is valid, since scm_fdes_to_port will do that. + set the revealed count depending on whether the port got the + standard file descriptor. + (stream_body_data): new type. + (stream_body, stream_handler): new procs. + +2000-03-12 Mikael Djurfeldt + + * stacks.c, stacks.h, struct.c, tags.h, unif.c (scm_bits_t): + Renamed from SCMWORD. + + * tags.h (SCM_NCELLP): Removed (SCMWORD). + + * arbiters.c (SCM_ARB_LOCKED): Use SCM_UNPACK_CAR. + + * async.c, boolean.h, debug.c, dynl.c, dynwind.c, eval.c, eval.h, + feature.h, filesys.h, fluids.h, fports.c, fports.h, gc.c, gc.h, + hash.c, keywords.h, macros.c, numbers.c, numbers.h, objects.c, + objects.h, options.c, pairs.h, ports.c, ports.h, print.c, + procs.h, ramap.c, read.c, smob.c, smob.h, srcprop.h, stacks.c, + stacks.h, strports.c, struct.c, struct.h, tag.c, tags.h, + throw.c, unif.c, unif.h, variable.h, vectors.h, weaks.c, + weaks.h (SCM_PACK, SCM_UNPACK, SCM_UNPACK_CAR): Renamed from + SCM_ASSCM, SCM_ASWORD, SCM_CARW). + + * numbers.h (SCM_SRS, SCM_INUM): Corrected SCM_ASSCM/ASWORD fixes. + + * alist.c, eval.c, net_db.c, posix.c, print.c, snarf.h, struct.c, + tags.h: Fixed copyright notices. + + * struct.c, coop-threads.c: SCM_ASSCM/ASWORD fixes. + +2000-03-12 Marius Vollmer + + * init.c (scm_standard_stream_to_port): Check whether the file + descriptor is valid and substitute "/dev/null" when not. + +2000-03-12 Mikael Djurfeldt + + * coop-defs.h (struct timespec): Conditionally defined. + + * coop.c (coop_condition_variable_timed_wait_mutex): Use ETIMEDOUT + instead of ETIME. + + * readline.c (match_paren): Bugfix: First arg to select is not + number of descriptors but the number of the highest descriptor + + 1. + + This is a preliminary attempt at a cleanup of the threads support + code. It moves things to better places, makes arguments more + consistent with the POSIX API (which is used in GNOME's glib), and + adds new functionality. + + * readline.c (scm_init_readline): Added new arg to scm_init_mutex. + + * coop-defs.h (scm_mutex_trylock): New macro: alias for + coop_mutex_trylock. + (scm_cond_init): Changed definition to + coop_new_condition_variable_init. + + * coop.c: #include + (coop_timeout_qinsert): Moved here from iselect.c + (coop_new_mutex_init, coop_new_condition_variable_init): New + functions. The strange names are temporary. Use scm_mutex_init + and scm_cond_init instead. + (coop_mutex_trylock): New function. Uses errno.h:EBUSY. errno.h + is ANSI C, but should we check for individual error codes in + configure.in? + (coop_condition_variable_timed_wait_mutex): New function. + (coop_key_create, coop_setspecific, coop_getspecific, + coop_key_delete): New functions. + + * iselect.c (coop_timout_qinsert): Moved to coop.c + +2000-03-11 Mikael Djurfeldt + + * pairs.h (SCM_SETAND_CAR, SCM_SETAND_CDR, SCM_SETOR_CAR, + SCM_SETOR_CDR): Corrected SCM_ASSCM/WORD fixes. + + * tags.h (SCM_VOIDP_TEST): Renamed from VOIDP_TEST. + Layout cleanups. + + * objects.h (SCM_CLASS_FLAGS, SCM_OBJ_CLASS_FLAGS, + SCM_SET_CLASS_INSTANCE_SIZE), struct.h (SCM_STRUCT_VTABLE_DATA), + proc.h (SCM_CLOSCAR): SCM_ASSCM/WORD fixes. + + * eval.c (scm_lookupcar1): Inserted SCM_ASWORD in expressions + dealing with ilocs. + +2000-03-11 Dale P. Smith , applied by Greg J. Badros, + + * numbers.c (scm_copy_big_dec, scm_copy_smaller, scm_big_ior, + scm_big_xor, scm_big_and, scm_big_test): Added new lowlevel bignum + logical functions from SCM. + + (logand, logior, logxor, logtest, logbit?): Extended scheme + logical functions to use bignums from SCM. + + (lognot): Removed call to `SCM_VALIDATE_INUM' that prevented + lognot from using bignums. + +Thu Mar 9 11:33:25 2000 Greg J. Badros + + * vectors.h (SCM_VELTS_AS_STACKITEMS): Added this macro to help in + eliminating some warnings. + + * unif.c, strports.c, print.c, options.c: Fix some warnings on + mis-use of SCM/long + + * gc.c, gc.h: Added scm_return_first_int(), and added comment re: + what the scm_return_first* functions do. + +2000-03-09 Han-Wen Nienhuys , applied by Greg J. Badros, + + * libguile/*.[ch]: make a distinction between SCM as a generic + name for a Scheme object (now a void*), and SCM as 32 bit word for + storing tags and immediates (now a long int). Introduced + SCM_ASWORD and SCM_ASSCM for conversion. Fixed various dubious + code in the process: arbiter.c (use macros), unif.c (scm_array_p), + +Wed Mar 8 10:15:59 2000 Greg J. Badros + + * numbers.c: Use SCM_VALIDATE_LONG_COPY, and longs, not ints, in + various logXXX primitives. Thanks Eric Moore! + +Tue Mar 7 08:05:22 2000 Greg J. Badros + + * run-test, remaining-docs-needed: Added these scripts. The + second one is only temporary until the docstring additions are + complete. run-test may best live on, but is here mostly for + convenience and awareness for now. + + * hash.c: Docs, minor cleanup patch from Dirk Herrman. + +Thu Mar 2 16:06:58 2000 Greg J. Badros + + * error.h, error.c: Added `scm_wrong_type_arg_msg' to support + displaying the expected type. Use SCM_LISTn in a couple places + instead of scm_cons-ing by hand. + + * __scm.h: Added SCM_ASSERT_TYPE macro. + + * validate.h, scm_validate.h: Added the former, as a renamed + version of the latter with SCM_ASSERT_TYPE used in + SCM_MAKE_VALIDATE (instead of just SCM_ASSERT) + + * Makefile.am: Rename scm_validate.h to validate.h. + + * *.c, *.h: Include validate.h, not scm_validate.h (old name's + prefix was superfluous). + +Thu Mar 2 15:33:12 2000 Greg J. Badros + + * hashtab.c: Improved documentation for lots of functions. Added + handwritten docs for `hash-fold'. + +Thu Mar 2 15:13:25 2000 Greg J. Badros + + * list.c: Added hand-written docs for `del{q,v,ete}1!'. + +Thu Mar 2 12:38:30 2000 Greg J. Badros + + * list.c: Moved append docs to append! Thanks Dirk Hermann. Also, + added append docs from R4RS. + + * strings.c: Docstring typo fix, + eliminate unneeded IMP tests. + Thanks Dirk Hermann! + + * chars.h: Provide SCM_CHARP, SCM_CHAR, SCM_MAKE_CHAR and + deprecate SCM_ICHRP, SCM_ICHR, SCM_MAKICHR. Thanks Dirk Hermann! + + * *.h, *.c: Use SCM_CHARP, SCM_CHAR, SCM_MAKE_CHAR throughout. + Drop use of SCM_P for function prototypes... assume an ANSI C + compiler. Thanks Dirk Hermann! + +Sat Feb 19 12:20:12 2000 Greg J. Badros + + * ports.c: Made `set-port-column!' and `set-port-line!' each + return SCM_UNSPECIFIED instead of a (not-scheme-object) integer + that caused a seg fault. Also fixed `set-port-column!'s + docstring. Thanks Han-Wen Nienhuys for finding the bug! + +Sun Feb 13 19:11:42 2000 Greg J. Badros + + * arbiters.c, eq.c, gc.c, guardians.c, list.c, ports.c, print.c, + regex-posix.c, scmsigs.c, stime.c, strings.c, variable.c, stime.c, + strings.c, variable.c: Added lots of documentation, cleaned up + some existing documentation. Occasionally changed formal params + to match docs. Also folded an #ifdef into the inners of a + primitive instead of having two copies of the primitive + (`get-internal-real-time', from stime.c) + +Sun Feb 13 18:12:19 2000 Greg J. Badros + + * ports.c: Added docs for primitives missing them. Written by + hand. + +Sun Feb 13 09:40:36 2000 Greg J. Badros + + * guile-doc-snarf.in: Use ${AWK} -f guile-func-name-check, not + just execing guile-func-name-check. Thanks Michael Livshin! + +Thu Feb 10 11:43:23 2000 Greg J. Badros + + * guile-snarf.awk.in: Tweak to work with Sun/HP awk, removed some + dead code. Patch from Michael Livshin. + + * guile-doc-snarf.in: Tweak to work with Sun/HP sh. Patch from + Michael Livshin. + +2000-02-09 Gary Houston + + * init.c (scm_init_standard_ports): when stdout is a tty, make the + current-output-port unbuffered by default. this is less confusing + for interactive use. it was line-buffered because of a + performance problem with unbuffered ports, but I think it will be + OK now. + +2000-02-08 Gary Houston + + * __scm.h: don't define long_long or ulong_long if HAVE_LONG_LONGS + is not defined. + + * stime.c (scm_localtime, scm_mktime): if neither HAVE_TM_ZONE nor + HAVE_TZNAME are defined, use an empty string instead of giving two + spurious compile-time errors. + +Tue Feb 8 13:57:46 2000 Greg J. Badros + + * ports.c: Doc patches from Richard Kim. Pasted from MIT Scheme. + Thanks Richard! + +Mon Feb 7 09:07:31 2000 Greg J. Badros + + * macros.c: Doc patches from Richard Kim. Pasted from scm.texi. + +Sun Feb 6 20:26:21 2000 Greg J. Badros + + * pairs.c: Doc patches from Richard Kim. Pasted from MIT Scheme + (which is GNU GPL'd). + +2000-01-31 Gary Houston + + * strings.h: don't use SCM_P. don't include . + * error.c, gh_data.c, ports.c, script.c, strop.c: include . + + * strings.c (scm_string_ref): make the 2nd argument compulsory. + previously it defaulted to zero for no good reason that I can see. + use a local variable for SCM_INUM (k). replace + SCM_VALIDATE_INUM_DEF with SCM_VALIDATE_INUM_COPY. + + (scm_makfromstr): cosmetic changes. + + (scm_string): Accept only chars in the list, not strings, for + conformance to R5RS (particularly for list->string, which is + supposed to be the inverse of string->list.) remove + SCM_DEFER_INTS/SCM_ALLOW_INTS, which is unnecessary since + scm_makstr handles the cell allocation. when reporting wrong-type + arg, don't report the position as 1. + + * posix.c (scm_init_posix): intern PIPE_BUF if it's defined. + +2000-01-29 Gary Houston + + * posix.c (scm_pipe): rewrote the docstring. + + * filesys.c (scm_select, retrieve_select_type, get_element, + fill_select_type, set_element): modified so that Scheme + "select" tests port buffers for the ability to provide input + or accept output. Previously only the underlying file descriptors + were checked. Rewrote the docstring. + +Thu Jan 27 10:14:25 2000 Greg J. Badros + + * vectors.c, symbols.c, strorder.c: Documentation cut and pasted + from Gregg Reynolds. Thanks Gregg! + +Thu Jan 27 09:59:38 2000 Greg J. Badros + + * strop.c (scm_i_index): Obfuscated commented-out SCM_DEFINE by + adding "x" prefix to the line so that guile-func-name-check + doesn't complain unnecessarily. + +Wed Jan 26 17:33:52 2000 Greg J. Badros + + * throw.c: Factor out an #ifdef/#else/#endif choice more finely + for maintainability. + + * strop.c: Documentation added by Gregg A. Reynolds. Pasted in + from qdocs, RnRs. + +Wed Jan 26 10:02:11 2000 Greg J. Badros + + * tag.c: Added doc for `tag', but mark as deprecated since Mikael + suggests removing tag.c altogether (and using a new `class-of' + instead). + + * strings.c: Added documentation from Gregg A. Reynolds. Edited + a bit by me to use FOO instead of @var{foo} and to have the + summary come before preconditions on input. Also dropped trailing + (rnrs) note. + + * gsubr.c: Do not use SCM_DEFINE for `gsubr-apply'. Register the + function with scm_make_subr_opt w/ last arg of 0 so it is not + visible at the Scheme level. Mikael says that this is the right + thing because the first arg to the proc is the guts of a compiled + closure and shouldn't be exposed to the Scheme level. + +Tue Jan 25 17:15:47 2000 Greg J. Badros + + * sort.c: typo in comment fixed. + + * keywords.c: Added documentation. + + * guardians.c: Added documentation (could be better). + + * gc.c: Added docs for gc-set-debug-check-freelist. + + * eq.c: Added docs for eq?, eqv? equal? abridged from R4RS. + + * boolean.c: Added docs for `not', `boolean?' (by hand). + +Tue Jan 25 13:28:56 2000 Greg J. Badros + + * random.c: Added documentation, from SLIB page: + http://angela.ctrl-c.liu.se/~calle/scheme/slib_toc.html + +Mon Jan 24 17:50:20 2000 Greg J. Badros + + * variable.c, version.c: Added documentation, written by hand + since I could not find anything already written that was + relevant. + +2000-01-23 Gary Houston + + * filesys.c (scm_chown): omit port/fdes support if HAVE_FCHOWN is + not defined (thanks to Richard Y. Kim). + +Thu Jan 20 13:00:38 2000 Greg J. Badros + + * Makefile.in: Removed, this is auto-generated. + +Thu Jan 20 11:33:47 2000 Dirk Hermann --applied 01/20/00 gjb + + * list.c: Put some variable initialization code at the point of + declaration; Added a comment for list*; Formatting changes. + + * load.c: use SCM_NNULLP to make sure the end of a list is not + reached yet. + +2000-01-18 Mikael Djurfeldt + + * backtrace.c (scm_display_error_message): Bugfix: Don't use + result of scm_list_p as C boolean. + (scm_display_error_message, scm_set_print_params_x): Use new + validation macros. (Thanks to Dirk Herrmann.) + + * net_db.c (scm_resolv_error): Cast result from hstrerror. + + * strports.c (st_end_input): Inserted parenthesis to get operator + grouping correct. + + * list.h (scm_init_list): Removed SCM_P around prototypes. + + * fports.c, list.c, numbers.c, ports.c, stime.c, symbols.c, + filesys.c, posix.c: Converted docstrings to ANSI C format and + escaped " occurring inside string literals. + +Tue Jan 18 13:21:08 2000 Mikael Djurfeldt + + * posix.c (scm_mknod): Escape " occuring inside docstring. + +2000-01-18 Mikael Djurfeldt + + * alist.c, chars.c, debug.c, dynl.c, dynwind.c, error.c, eval.c, + evalext.c, filesys.c, gc.c, hash.c, hashtab.c, ioext.c, + keywords.c, list.c, load.c, macros.c, net_db.c, numbers.c, + objprop.c, ports.c, posix.c, print.c, procprop.c, procs.c, + ramap.c, regex-posix.c, root.c, scmsigs.c, simpos.c, socket.c, + stacks.c, stime.c, strings.c, strop.c, strports.c, struct.c, + symbols.c, throw.c, unif.c, vectors.c, version.c, vports.c, + weaks.c: Converted docstrings to ANSI C format. + + * filesys.c (scm_chmod), simpos.c (scm_system), version + (scm_version), vports (scm_make_soft_port): Escape " occuring + inside docstring. + +Mon Jan 17 11:41:22 2000 Greg J. Badros + + * scm_validate.h: Added SCM_VALIDATE_ULONG_COPY, + SCM_VALIDATE_LONG_COPY + + * numbers.c: Use SCM_VALIDATE_ULONG_COPY, instead of + SCM_VALIDATE_INUM_COPY to let bigger numbers be used. Rename a + couple of formal arguments (and fix their uses) to make arguments + match the documentation. + +2000-01-14 + + * Makefile.am: Augment path when running guile-doc-snarf so + guile-func-name-check is found. + +Fri Jan 14 09:34:55 2000 Greg J. Badros + + * scm_validate.h (SCM_NUM2LONG_DEF): Fix this macro to just use + def, not SCM_MAKINUM(def); thanks Janis Bzerins! + +Wed Jan 12 00:06:53 2000 Greg J. Badros + + * net_db.c (s_scm_inet_makeaddr): Use SCM_NUM2ULONG since that's + the way guile-1.3.4 worked, but #if 0 out the version using + SCM_VALIDATE_INUM_COPY for stricter testing. + +Tue Jan 11 18:24:18 2000 Greg J. Badros + + * guile-doc-snarf.in: Use new $fullfilename for running + guile-func-name-check, and put "$fullfilename" and "$filename" in + quotes at uses to make sure re-splitting on whitespace does not + occur (so filenames w/ embedded whitespace would work okay, though + I sure hope we never have to deal with that! :-) ). Thanks to + Mikael for pointing out the source_dir != build_dir was broken. + +Tue Jan 11 17:42:40 2000 Greg J. Badros + + * scm_validate.h: Added SCM_NUM2LONG_DEF macro. Make + SCM_OUT_OF_RANGE use SCM_MAKINUM, not scm_long2num. Added + SCM_COERCE_ROSTRING macro. Added SCM_VALIDATE_NONEMPTYLIST + macro. Fix SCM_VALIDATE_STRINGORSUBSTR macro to not use SLOPPY + variants. + + * ports.c (scm_port_closed_p): Validate that the arg is a PORT, + then return whether it's an open port (was validating that it was + an open port -- this was a bug I introduced back in December, but + my careful reading of diffs caught it). + + * numbers.c: Recombine the two conditional-compilation paths for + all the log* primitives -- they were split based on #ifndef + scm_long2num; factored out a SCM_LOGOP_RETURN macro, and fixed + some bugs and inconsistencies in the two sets of implementations. + (scm_lognot) Fixed *atrocious* re-use of a SCM as an integer! + + * ioext.c: Use SCM_ASSERT_RANGE in a couple places, and + SCM_VALIDATE_INUM_COPY once where it should've been used. + + * fluids.c (scm_internal_with_fluids): Use + SCM_VALIDATE_LIST_COPYLEN. + + * filesys.c: Use SCM_NUM2LONG instead of SCM_VALIDATE_INUM_COPY; + this is questionable as it relaxes type safety, but other changes + were useful and all SCM_NUM2LONG's should probably be + revisited. Use SCM_OUT_OF_RANGE, SCM_WRONG_TYPE_ARG. + + * evalext.c: line-break change on 1 line. + + * eval.c (nconc2last): Takes a non-empty list as its first + argument, not just a list. + + * dynl.c: Use new SCM_COERCE_ROSTRING macro. + +Tue Jan 11 15:44:23 2000 Greg J. Badros + + * dynl.c, feature.c, filesys.c, fports.c, list.c, load.c, + net_db.c, sort.c, stacks.c, unif.c: Use SCM_WTA, SCM_MISC_ERROR + where possible. + + * symbols.c (scm_sysintern0): Fixed the function name in a + scm_misc_error invocation. + + * print.c (scm_simple_format): Do not need SCM_COERCE_SUBSTR, and + use scm_return_first to ward off latent GC bug that Mikael caught. + + * async.c: Use SCM_VALIDATE_ASYNC_COPY one place where it wasn't + used before but should've been. + +2000-01-12 Mikael Djurfeldt + + * snarf.h (SCM_PROC1): Replaced SCM (*) (...) with + SCM_FUNC_CAST_ARBITRARY_ARGS. + +Tue Jan 11 13:44:07 2000 Greg J. Badros + + * guile-func-name-check.in: Added this script to statically check + #define FUNC_NAME, #undef FUNC_NAME in the source. + + * sort.c, posix.c: Fix #undef FUNC_NAME lines to not have trailing + redundant comment, semicolon; caught by new guile-func-name-check + script. + + * debug.c: Fix mistaken #define FUNC_NAME for scm_make_iloc. + Caught by new guile-func-name-check-script. + + * Makefile.am: Added guile-func-name-check to bin_SCRIPTS + + * ramap.c: Fix #if 0'd out code to be syntactically acceptable to + guile-func-name-check. + + * guile-doc-snarf.in: Run guile-func-name-check on the file before + doing the snarf. + +Tue Jan 11 11:31:10 2000 Greg J. Badros + + * fports.c, ports.c, ports.h, strports.c, vports.c: Make write + port function take const void*, not void*. + +Tue Jan 11 11:18:07 2000 Greg J. Badros + + * scm_validate.h, chars.c, ports.c, print.c, read.c, strings.c, + strop.c: Use SCM_VALIDATE_ICHR, SCM_VALIDATE_ICHR_COPY instead of + SCM_VALIDATE_CHAR, SCM_VALIDATE_CHAR_COPY. Change made for + consistency with the other macros dealing with immediate + characters. (Similar to INT -> INUM change a week or so ago). + +Tue Jan 11 10:41:46 2000 Greg J. Badros + + * dynl.c, error.c, eval.c, feature.c, filesys.c, fports.c, list.c, load.c, + net_db.c, read.c, socket.c: Update error messages to use ~A for + %s, ~S for %S to work with new `simple-format' format and be + standardized better. + + * print.h, print.c (scm_simple_format): Added `simple-format' + primitive. It's the old scm_display_error, with ARGS now a rest + parameter, and the destination first instead of last (and a couple + new capabilities inspired by `format' -- #t as destination means + current-output-port, #f means return the formatted text as a + string. + + * gh.h, gh_data.c, ports.h, ports.c: Added some missing const specifications. + + * backtrace.c (scm_display_error_message): Rewrote to use + scm_simple_format() procedure. + + * __scm.h: Added commented-out #define of GUILE_DEBUG_FREELIST + +2000-01-09 Marius Vollmer + + Finally applied the libltdl patch from Thomas Tanner, with slight + modifications. + + * DYNAMIC-LINKING: Removed because it is obsolete. + * dynl.c: Use ANSI prototypes. + (sysdep_dynl_link): Use lt_dlopenext instead of lt_dlopen. + * scmconfig.h.in: Do not change, as it is automatically generated. + + 1999-07-25 Thomas Tanner + + * dynl-dl.c, dynl-dld.c, dynl-shl.c, dynl-vms.c: deleted + (obsolete) + * Makefile.am: likewise, add INCLTDL (libltdl headers) to + INCLUDES, set dlpreopened files in LDFLAGS, link libguile + against libltdl + * dynl.c: use libltdl if DYNAMIC_LINKING is enabled, + * guile.c: register preloaded modules + * scmconfig.h.in: remove obsolete symbols + +2000-01-09 Gary Houston + + * These changes should make it unnecessary to call tzset from + Scheme after modifying the TZ environment variable, even if the + system date facilities cache the value. + * stime.c (setzone, scm_localtime): added comments. + (tzset): don't define a noop tzset macro if HAVE_TZSET not defined. + (setzone): don't call tzset. + (restorezone): call tzset only if HAVE_TZSET is defined. + (scm_tzset): don't define if HAVE_TZSET not defined. Change the + doc string to indicate that this procedure isn't likely to do + anything useful. + (scm_localtime, scm_strftime, scm_mktime): call tzset if + LOCALTIME_CACHE is defined. + +2000-01-09 Mikael Djurfeldt + + * posix.c (scm_sync): Return SCM_UNSPECIFIED. + +2000-01-09 Gary Houston + + * eval.c: define scm_unbound_variable_key ('unbound-variable). + scm_lookupcar1: throw an error with key 'unbound-variable instead + of 'misc-error when an unbound variable is encountered. + + * filesys.c (scm_mkdir, scm_rmdir, scm_getcwd, scm_select, + scm_symlink, scm_readlink, scm_lstat), + posix.c (scm_setpgid, scm_setsid, scm_ctermid, scm_tcgetpgrp, + scm_tcsetpgrp, scm_uname, scm_setlocale, scm_mknod, scm_nice, + scm_sync), + simpos.c (scm_system), + stime.c (scm_times, scm_strptime): + move the HAVE_XXX feature tests out of the procedure bodies. + don't use SCM_SYSMISSING. + scm_validate.h (SCM_SYSMISSING): removed. + error.h, error.c (scm_sysmissing): comment that this is deprecated. + see ChangeLog entry for 1999-12-28. + +Sat Jan 8 19:52:04 2000 Greg J. Badros + + * scm_validate.h (SCM_VALIDATE_BOOL_COPY): Fix typo. + +Sat Jan 8 17:06:46 2000 Greg J. Badros + + * backtrace.c: Fix spelling typo in a comment. + + * snarf.h: Use new SCM_DOCS macro to encapsulate the non SCM_INIT + text. Reformatted some of the expansions. + +Fri Jan 7 15:50:46 2000 Greg J. Badros + + * scm_validate.h (SCM_OUT_OF_RANGE): Use scm_out_of_range_pos to + report the position of the argument. + + * error.h, error.c (scm_out_of_range_pos): Added this function to + take extra "pos" argument, the position number of the errant + argument. + + * debug.c: Use SCM_OUT_OF_RANGE instead of scm_out_of_range. + + * snarf.h: Use SCM_HERE and SCM_INIT as names, not SCM_NOTSNARF + and SCM_SNARFING. Also put the %%% in the SCM_INIT since Mikael + prefers that and I'm reasonably indifferent. + +Fri Jan 7 15:03:32 2000 Greg J. Badros + + * snarf.h: Factor out differences between C++ and non-C++ into + SCM_FUNC_CAST_ARBITRARY_ARGS macro. Modify all the snarf macro + definitions to use SCM_NOTSNARF and SCM_SNARFING macros (like + Mikael's macros, below, but changed names and SCM_SNARFING no + longer expands to include %%% -- that must appear in the argument + so that the token appears at the call-site as a reminder). + +2000-01-07 Mikael Djurfeldt + + * snarf.h (SCM_INSITU, SCM_INIT): New snarf macros for use in user + snarf macro definitions. + +2000-01-06 Mikael Djurfeldt + + * chars.c (scm_integer_to_char): Use Greg's nice + SCM_VALIDATE_INUM_RANGE macro for argument checking for closer + adherence to R5RS. + +Thu Jan 6 11:48:49 2000 Greg J. Badros + + * *.c, snarf.h: Replace GUILE_PROC1 with SCM_DEFINE1 throughout. + +Thu Jan 6 11:22:53 2000 Greg J. Badros + + * Makefile.am (ETAGS_ARGS): Switch to SCM_DEFINE, SCM_DEFINE1 + instead of GUILE_PROC. + +Thu Jan 6 11:21:49 2000 Greg J. Badros + + * alist.c: Do not report mismatch errors on some uses of `tmp' (do + this by using SCM_ARG2 instead of `2' in the SCM_VALIDATE_CONS + macro call. + +Thu Jan 6 09:54:33 2000 Dirk Herrmann --gjb applied + + * scm_validate.h: Remove some redundant NIMP tests. + + * alist.c: minimize scope of the tmp variables, and initialize + them when declared. The strange SCM_NIMP tests are replaced by + SCM_CONSP tests that more closely reflect the intended semantics. + However, we don't get a performance penalty here, because the + SCM_CONSP test was performed by the ALISTCELL test anyway. * The + extremely ugly use of ASRTGO macros was removed: The calls to + ASRTGO were not encapsulated by "#ifndef SCM_RECKLESS", but got a + label parameter that only exists when SCM_RECKLESS is not defined. + This works, because ASRTGO itself is defined in a way that it only + makes use of the label parameter if SCM_RECKLESS is not defined + (shudder!). Does guile make at all use of the possibility to + define SCM_RECKLESS? * Codesize is likely to be reduced, since + instead of two calls to SCM_ASSERT performed by the ALISTCELL test + we now only get one test. + + * list.c: Use SCM_NNULLP, not SCM_NIMP as appropriate. Also use + SCM_NULLP instead of SCM_IMP. Drop use of "register" keyword on + some variables in `list?'. Fix `reverse' and `reverse!' + primitives to handle improper lists better. + +Wed Jan 5 11:24:53 2000 Greg J. Badros + + * *.[ch]: Whitespace changes -- added space after SCM_VALIDATE_* + macros and SCM_DEFINE macros to match GNU coding standards. + +Wed Jan 5 11:04:24 2000 Greg J. Badros + + * *.[ch]: Replace GUILE_PROC w/ SCM_DEFINE. + +Wed Jan 5 10:59:06 2000 Greg J. Badros + + * *.[ch]: Replace SCM_VALIDATE_INT w/ SCM_VALIDATE_INUM for + better consistency with the names of other SCM_VALIDATE_ macros + and better conformance to guile naming policy. + +Wed Jan 5 10:50:39 2000 Greg J. Badros + + * ports.c (s_scm_close_all_ports_except): Use SCM_ARG1 in a + SCM_VALIDATE instead of 1 to avoid a check on the argument (since + it's not the actual name of the formal). + + * guile-snarf.awk.in: Do argument/number mismatch checking and + print warnings in an Emacs compile-mode parseable format. + + * struct.c: Use SCM_ASSERT_RANGE instead of SCM_ASSERT w/ + SCM_OUTOFRANGE as 3rd argument. + + * random.c: Fix argument/number mismatch (that I introduced :-( ). + + * __scm.h: Do not #define SCM_ARG* when snarfing; + lets us distinguish between 1 and SCM_ARG1 when snarfing as only + the former (using the number) requires the argument to match the + formal in the current argument snarfing check. + + * snarf.h: Give new definition of SCM_ASSERT when in + snarfing mode to output a lexically-identifiable sequence that the + guile-snarf.awk script uses to verify argument/position matching. + + * ramap.c: Remove extraneous #undef FUNC_NAME. + +Wed Jan 5 08:36:38 2000 Greg J. Badros + + * guile-doc-snarf.awk.in: Removed -- guile-snarf.awk.in is the + current version of the same functionality; it writes the .x output + to stdout instead of directly into the file. + +Wed Jan 5 08:15:04 2000 Greg J. Badros + + * unif.c, symbols.c, strings.c, stacks.c, random.c, print.c, + posix.c: Eliminated a bunch of SCM_NIMP(..)s that are now + redundant with the safer macros. Patch from Dirk Hermann applied + by hand. Thanks Dirk! + + * scm_validate.h: Added SCM_VALIDATE_VECTOR_OR_DVECTOR for some + uses in random.c. + + * ramap.c: whitespace change. + +Tue Jan 4 14:21:35 2000 Greg J. Badros + + * options.c, objects.c, keywords.c, gc.c: Some redundant SCM_NIMP + removals from Dirk Hermann. + + * alist.c: Rename formals to match the parameter names in the + documentation, updates to documentation. Thanks Dirk Hermann! + +2000-01-04 Mikael Djurfeldt + + * eval.c (SCM_CEVAL): Reverse order of + scm_stack_checking_enabled_p and SCM_STACK_OVERFLOW_P + (Thanks to Brad Knotwell.) + +Mon Jan 3 08:30:02 2000 Greg Harvey (applied --01/03/00 gjb) + + * gc.c (scm_debug_newcell): Added SCM_SETCAR of the newly + allocated cell. + + * pairs.h: Added a comment about the need for the SCM_SETCAR in + SCM_NEWCELL macro. + +Mon Jan 3 08:25:19 2000 Greg J. Badros + + * dynl-vms.c, debug.c, coop-threads.c, backtrace.c, eval.c: More + SCM_NIMP tests that were redundant are now eliminated. Patches + from Dirk Hermann applied by hand. + +The ChangeLog continues in the file: "ChangeLog-1996-1999" From ac3e3f5b7b25841949fbebe8785687c16429ef81 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 12 Mar 2001 00:50:08 +0000 Subject: [PATCH 0702/2047] * intro.texi: Changed to reflect current practice better. Added stuff about writing Guile Extensions (aka dynamically loaded shared libraries). --- doc/intro.texi | 250 ++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 195 insertions(+), 55 deletions(-) diff --git a/doc/intro.texi b/doc/intro.texi index e126fbcf8..ffd2346c5 100644 --- a/doc/intro.texi +++ b/doc/intro.texi @@ -1,4 +1,4 @@ -@c $Id: intro.texi,v 1.1 2001-03-09 08:21:59 ossau Exp $ +@c $Id: intro.texi,v 1.2 2001-03-12 00:50:08 mvo Exp $ @page @node What is Guile? @@ -62,6 +62,7 @@ used. * Running Guile Interactively:: * Guile Scripts:: * Linking Programs With Guile:: +* Writing Extensions for Guile:: * Writing Guile Modules:: @end menu @@ -355,15 +356,18 @@ Furthermore, any Scheme function described in this manual as a The header file @code{} provides declarations for all of Guile's functions and constants. You should @code{#include} it at the head of any C source file that uses identifiers described in this -manual. +manual. Once you've compiled your source files, you need to link them +against the Guile object code library, @code{libguile}. -Once you've compiled your source files, you can link them against Guile -by passing the flag @code{-lguile} to your linker. If you installed -Guile with multi-thread support (by passing @code{--enable-threads} to -the @code{configure} script), you may also need to link against the -QuickThreads library, @code{-lqt}. Guile refers to various mathematical -functions, so you will probably need to link against the mathematical -library, @code{-lm}, as well. +On most systems, you should not need to do tell the compiler and linker +explicitely where they can find @file{libguile.h} and @file{libguile}. +When Guile has been installed in a peculiar way, or when you are on a +peculiar system, things might not be so easy and you might need to pass +additional @code{-I} or @code{-L} options to the compiler. Guile +provides the utility program @code{guile-config} to help you find the +right values for these options. You would typically run +@code{guile-config} during the configuration phase of your program and +use the obtained information in the Makefile. @menu * Guile Initialization Functions:: What to call first. @@ -374,7 +378,19 @@ library, @code{-lm}, as well. @node Guile Initialization Functions @subsection Guile Initialization Functions -To initialize Guile, use this function: +To initialize Guile, you can use one of two functions. The first, +@code{scm_boot_guile}, is the most portable way to initialize Guile. It +should be used whenever you have control over the main function of your +program because it never returns. The second function, +@code{scm_init_guile}, does return and can thus be used in more +situations. However, @code{scm_init_guile} is not as widely available +as @code{scm_boot_guile} because it needs to rely on non-portable code +to find the stack bounds. When Guile does not know how to find these +bounds on your system, it will not provide @code{scm_init_guile}. + +When you can tolerate the limits of @code{scm_boot_guile}, you should +use it in favor of @code{scm_init_guile} since that will make your +program more portable. @deftypefun void scm_boot_guile (int @var{argc}, char **@var{argv}, void (*@var{main_func}) (), void *@var{closure}) Initialize the Guile Scheme interpreter. Then call @var{main_func}, @@ -391,20 +407,34 @@ function to return the strings given by @var{argc} and @var{argv}. If @code{scm_set_program_arguments} with the final list, so Scheme code will know which arguments have been processed. -@code{scm_boot_guile} establishes a catch-all error handler which prints -an error message and exits the process. This means that Guile exits in -a coherent way if a system error occurs and the user isn't prepared to -handle it. If the user doesn't like this behavior, they can establish -their own universal catcher in @var{main_func} to shadow this one. - Why must the caller do all the real work from @var{main_func}? Guile's -garbage collector assumes that all local variables which reference -Scheme objects will be above @code{scm_boot_guile}'s stack frame on the -stack. If you try to manipulate Scheme objects after this function -returns, it's the luck of the draw whether Guile's storage manager will -be able to find the objects you allocate. So, @code{scm_boot_guile} -function exits, rather than returning, to discourage you from making -that mistake. +garbage collector scans the stack to find all local variables that +reference Scheme objects. To do this, it needs to know the bounds of +the stack that might contain such references. Because there is no +protable way in C to find the base of the stack, @code{scm_boot_guile} +assumes that all references are above its own stack frame. If you try +to manipulate Scheme objects after this function returns, it's the luck +of the draw whether Guile's storage manager will be able to find the +objects you allocate. So, @code{scm_boot_guile} function exits, rather +than returning, to discourage you from making that mistake. + +See @code{scm_init_guile}, below, for a function that can find the real +base of the stack, but not in a portable way. +@end deftypefun + +@deftypefun void scm_init_guile () +Initialize the Guile Scheme interpreter. + +In contrast to @code{scm_boot_guile}, this function knows how to find +the true base of the stack and thus does not need to usurp the control +flow of your program. However, since finding the stack base can not be +done portably, this function might not be available in all installations +of Guile. If you can, you should use @code{scm_boot_guile} instead. + +Note that @code{scm_init_guile} does not inform Guile about the command +line arguments that should be returned by the Scheme function +@code{comamnd-line}. You can use @code{scm_set_program_arguments} to do +this. @end deftypefun One common way to use Guile is to write a set of C functions which @@ -427,10 +457,6 @@ specified by @code{-s} or @code{-e} options, and then exiting. Since this function does not return, you must do all application-specific initialization before calling this function. - -If you do not use this function to start Guile, you are responsible for -making sure Guile's usual initialization files, @file{init.scm} and -@file{ice-9/boot-9.scm}, get loaded. This will change soon. @end deftypefun @@ -468,19 +494,22 @@ Guile, passing it @code{inner_main}. Once @code{scm_boot_guile} is ready, it invokes @code{inner_main}, which calls @code{scm_shell} to process the command-line arguments in the usual way. -Here is a Makefile which you can use to compile the above program. +Here is a Makefile which you can use to compile the above program. It +uses @code{guile-config} to learn about the necessary compiler and +linker flags. @example # Use GCC, if you have it installed. CC=gcc -# Tell the C compiler where to find and -lguile. -CFLAGS=-I/usr/local/include -L/usr/local/lib +# Tell the C compiler where to find +CFLAGS=`guile-config compile` -# Include -lqt and -lrx if they are present on your system. -LIBS=-lguile -lqt -lrx -lm +# Tell the linker what libraries to use and where to find them. +LIBS=`guile-config link` simple-guile: simple-guile.o - $@{CC@} $@{CFLAGS@} simple-guile.o $@{LIBS@} -o simple-guile + $@{CC@} simple-guile.o $@{LIBS@} -o simple-guile + simple-guile.o: simple-guile.c $@{CC@} -c $@{CFLAGS@} simple-guile.c @end example @@ -488,20 +517,22 @@ simple-guile.o: simple-guile.c If you are using the GNU Autoconf package to make your application more portable, Autoconf will settle many of the details in the Makefile above automatically, making it much simpler and more portable; we recommend -using Autoconf with Guile. Here is a @file{configure.in} file for -@code{simple-guile}, which Autoconf can use as a template to generate a -@code{configure} script: +using Autoconf with Guile. Guile also provides the @code{GUILE_FLAGS} +macro for autoconf that performs all necessary checks. Here is a +@file{configure.in} file for @code{simple-guile} that uses this macro. +Autoconf can use as this file as template to generate a @code{configure} +script. In order for Autoconf to find the @code{GUILE_FLAGS} macro, you +will need to run @code{aclocal} first. This is not really Guile +specific, so you should refer to the Autoconf documentation REFFIXME +when in doubt. @example AC_INIT(simple-guile.c) # Find a C compiler. AC_PROG_CC -# Check for libraries. -AC_CHECK_LIB(m, sin) -AC_CHECK_LIB(rx, regcomp) -AC_CHECK_LIB(qt, main) -AC_CHECK_LIB(guile, scm_boot_guile) +# Check for Guile +GUILE_FLAGS # Generate a Makefile, based on the results. AC_OUTPUT(Makefile) @@ -512,11 +543,11 @@ script produces a Makefile customized for the host system: @example # The configure script fills in these values. CC=@@CC@@ -CFLAGS=@@CFLAGS@@ -LIBS=@@LIBS@@ +CFLAGS=@@GUILE_CFLAGS@@ +LIBS=@@GUILE_LDFLAGS@@ simple-guile: simple-guile.o - $@{CC@} $@{CFLAGS@} simple-guile.o $@{LIBS@} -o simple-guile + $@{CC@} simple-guile.o $@{LIBS@} -o simple-guile simple-guile.o: simple-guile.c $@{CC@} -c $@{CFLAGS@} simple-guile.c @end example @@ -531,21 +562,17 @@ $ ls Makefile.in configure* configure.in simple-guile.c $ ./configure creating cache ./config.cache -checking for gcc... gcc +checking for gcc... (cached) gcc checking whether the C compiler (gcc ) works... yes checking whether the C compiler (gcc ) is a cross-compiler... no -checking whether we are using GNU C... yes -checking whether gcc accepts -g... yes -checking for sin in -lm... yes -checking for regcomp in -lrx... yes -checking for main in -lqt... yes -checking for scm_boot_guile in -lguile... yes -updating cache ./config.cache +checking whether we are using GNU C... (cached) yes +checking whether gcc accepts -g... (cached) yes +checking for Guile... yes creating ./config.status creating Makefile $ make -gcc -c -g -O2 simple-guile.c -gcc -g -O2 simple-guile.o -lguile -lqt -lrx -lm -o simple-guile +gcc -c -I/usr/local/include simple-guile.c +gcc simple-guile.o -L/usr/local/lib -lguile -lqthreads -lpthread -lm -o simple-guile $ ./simple-guile guile> (+ 1 2 3) 6 @@ -556,12 +583,125 @@ guile> (exit) $ @end example +@node Writing Extensions for Guile +@section Writing Extensions for Guile + +The previous sections have briefly explained how to write programs that +make use of an embedded Guile interpreter. But sometimes, all you want +to do is make new primitive procedures and data types available to the +Scheme programmer. Writing a new version of @code{guile} is +inconvenient in this case and it would in fact make the life of the +users of your new fetaures needlessly hard. + +@c [[ the following is probably a bit longwinded ]] + +For example, suppose that there is a program @code{guile-db} that is a +version of Guile with additional features for accessing a database. +People who want to write Scheme programs that use these features would +have to use @code{guile-db} instead of the usual @code{guile} program. +Now suppose that there is also a program @code{guile-gtk} that extends +Guile with access to the popular Gtk+ toolkit for graphical user +interfaces. People who want to write GUIs in Scheme would have to use +@code{guile-gtk}. Now, what happens when you want to write a Scheme +application that uses a GUI to let the user accessa a database? You +would have to write a @emph{third} program that incorporates both the +database stuff and the GUI stuff. This might not be easy (because +@code{guile-gtk} might be a quite obscure program, say) and taking this +example further makes it easy to see that this approach can not work in +practice. + +It would have been much better if both the database features and the GUI +feature had been provided as libraries that can just be linked with +@code{guile}. Guile makes it easy to do just this, and we encourage you +to make your extensions to Guile available as libraries whenever +possible. + +You write the new primitive procedures and data types in the normal +fashion, and link them into a shared library instead of into a +standalone program. The shared library can then be loaded dynamically +by Guile. + +@menu +* A Sample Guile Extension:: +@end menu + +@node A Sample Guile Extension +@subsection A Sample Guile Extension + +This section explains how to make the Bessel functions of the C library +available to Scheme. First we need to write the appropriate glue code +to convert the arguments and return values of the functions from Scheme +to C and back. Additionally, we need a function that will add them to +the set of Guile primitives. Because this is just an example, we will +only implement this for the @code{j0} function, tho. + +Consider the following file @file{bessel.c}. + +@smallexample +#include +#include + +SCM +j0_wrapper (SCM x) +@{ + return scm_make_real (j0 (scm_num2dbl (x, "j0"))); +@} + +void +init_bessel () +@{ + scm_make_gsubr ("j0", 1, 0, 0, j0_wrapper); +@} +@end smallexample + +This C source file needs to be compiled into a shared library. Here is +how to do it on GNU/Linux: + +@smallexample +gcc -shared -o libguile-bessel.so -fPIC bessel.c +@end smallexample + +For creating shared libraries portably, we recommend the use of +@code{GNU Libtool}. + +A shared library can be loaded into a running Guile process with +@code{dynamic-link}. After it has been linked you can call its exported +functions via @code{dynamic-call}. For our example, we are going to +call the function @code{init_bessel} which will make @code{j0_wrapper} +available to Scheme programs with the name @code{j0}. Note that we do +not specify a filename extension such as @file{.so} when invoking +@code{dynamic-link}. The right extension for the host platform will be +provided automatically. + +@smalllisp +(define bessel-lib (dynamic-link "libguile-bessel")) +(dynamic-call "init_bessel" bessel-lib) +(j0 2) +@result{} 0.223890779141236 +@end smalllisp + +For this to work, @code{dynamic-link} must be able to find +@file{libguile-bessel}, of course. It will look in the places that are +usual for your operating system, and it will additionally look into the +directories listed in the @code{LTDL_LIBRRAY_PATH} environment variable. + +To see how these Guile extensions via shared libraries relate to the +module system, see below REFFIXME. @node Writing Guile Modules @section Writing Guile Modules -[to be written] +Guile has support for dividing a program into @dfn{modules}. By using +modules, you can group related code together and manage the composition +of complete programs from their largely independent parts. +(The module system is in flux, and will likely look very different in +the future. Feel free to use the existing system anyway. Guile will +provide reasonable backwards compatability.) + +[[ more stuff to follow: how to load third-party modules, how to write +new modules, how to arrange for autoloading, how to load shared +libraries as modules. ]] @page @node Reporting Bugs From c4f810a46641c403bfc821961226d9282ee3ba3a Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 12 Mar 2001 00:52:43 +0000 Subject: [PATCH 0703/2047] *** empty log message *** --- doc/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/doc/ChangeLog b/doc/ChangeLog index d638bfc2a..b377533dd 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,9 @@ +2001-03-12 Marius Vollmer + + * intro.texi: Changed to reflect current practice better. Added + stuff about writing Guile Extensions (aka dynamically loaded + shared libraries). + 2001-03-09 Mikael Djurfeldt * goops.texi (VERSION): Bumped to version 0.3. From e41561b49031c43dcfeecc93130f9a357857acef Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Mon, 12 Mar 2001 02:46:13 +0000 Subject: [PATCH 0704/2047] *** empty log message *** --- emacs/guile-c.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/emacs/guile-c.el b/emacs/guile-c.el index bbf75e9a1..8d1b9f59c 100644 --- a/emacs/guile-c.el +++ b/emacs/guile-c.el @@ -1,6 +1,6 @@ ;;; guile-c.el --- Guile C editing commands -;; Copyright (C) 2001 Keisuke Nishida +;; Copyright (C) 2001 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 67e8151b65659fdfb803fe2b9bb1b60f65638b85 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 12 Mar 2001 07:08:46 +0000 Subject: [PATCH 0705/2047] * load.c (scm_primitive_load, scm_primitive_load_path), (scm_sys_search_load_path): Corrected docstrings (file -> filename). * eval.c (scm_force): Added texinfo markup to docstring. (scm_promise_p): Renamed parameter to `obj' to match docstring. * debug-malloc.c: Reinserted #include . --- libguile/ChangeLog | 11 +++++++++++ libguile/debug-malloc.c | 1 + libguile/eval.c | 11 ++++++----- libguile/load.c | 37 ++++++++++++++++++++----------------- 4 files changed, 38 insertions(+), 22 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 7371eb5fa..7fc9c4d40 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2001-03-12 Martin Grabmueller + + * load.c (scm_primitive_load, scm_primitive_load_path), + (scm_sys_search_load_path): Corrected docstrings (file -> + filename). + + * eval.c (scm_force): Added texinfo markup to docstring. + (scm_promise_p): Renamed parameter to `obj' to match docstring. + + * debug-malloc.c: Reinserted #include . + 2001-03-11 Keisuke Nishida * list.c (s_scm_reverse_x): Use SCM_VALIDATE_LIST. diff --git a/libguile/debug-malloc.c b/libguile/debug-malloc.c index 4240f7d8b..8b2a08ceb 100644 --- a/libguile/debug-malloc.c +++ b/libguile/debug-malloc.c @@ -40,6 +40,7 @@ * If you do not wish that, delete this exception notice. */ #include +#include #include "libguile/_scm.h" #include "libguile/alist.h" diff --git a/libguile/eval.c b/libguile/eval.c index e48398466..56019c552 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3760,9 +3760,10 @@ promise_print (SCM exp, SCM port, scm_print_state *pstate) SCM_DEFINE (scm_force, "force", 1, 0, 0, - (SCM x), - "If the promise X has not been computed yet, compute and return\n" - "X, otherwise just return the previously computed value.") + (SCM x), + "If the promise @var{x} has not been computed yet, compute and\n" + "return @var{x}, otherwise just return the previously computed\n" + "value.") #define FUNC_NAME s_scm_force { SCM_VALIDATE_SMOB (1, x, promise); @@ -3783,12 +3784,12 @@ SCM_DEFINE (scm_force, "force", 1, 0, 0, SCM_DEFINE (scm_promise_p, "promise?", 1, 0, 0, - (SCM x), + (SCM obj), "Return true if @var{obj} is a promise, i.e. a delayed computation\n" "(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}).") #define FUNC_NAME s_scm_promise_p { - return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise, x)); + return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise, obj)); } #undef FUNC_NAME diff --git a/libguile/load.c b/libguile/load.c index a3d28a95a..d6612b12c 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -103,12 +103,13 @@ load (void *data) SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0, (SCM filename), - "Load @var{file} and evaluate its contents in the top-level environment.\n" - "The load paths are not searched; @var{file} must either be a full\n" - "pathname or be a pathname relative to the current directory. If the\n" - "variable @code{%load-hook} is defined, it should be bound to a procedure\n" - "that will be called before any code is loaded. See documentation for\n" - "@code{%load-hook} later in this section.") + "Load the file named @var{filename} and evaluate its contents in\n" + "the top-level environment. The load paths are not searched;\n" + "@var{filename} must either be a full pathname or be a pathname\n" + "relative to the current directory. If the variable\n" + "@code{%load-hook} is defined, it should be bound to a procedure\n" + "that will be called before any code is loaded. See the\n" + "documentation for @code{%load-hook} later in this section.") #define FUNC_NAME s_scm_primitive_load { SCM hook = *scm_loc_load_hook; @@ -409,13 +410,14 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, If we find one, return its full filename; otherwise, return #f. If FILENAME is absolute, return it unchanged. */ SCM_DEFINE (scm_sys_search_load_path, "%search-load-path", 1, 0, 0, - (SCM filename), - "Search @var{%load-path} for @var{file}, which must be readable by the\n" - "current user. If @var{file} is found in the list of paths to search or\n" - "is an absolute pathname, return its full pathname. Otherwise, return\n" - "@code{#f}. Filenames may have any of the optional extensions in the\n" - "@code{%load-extensions} list; @code{%search-load-path} will try each\n" - "extension automatically.") + (SCM filename), + "Search @var{%load-path} for the file named @var{filename},\n" + "which must be readable by the current user. If @var{filename}\n" + "is found in the list of paths to search or is an absolute\n" + "pathname, return its full pathname. Otherwise, return\n" + "@code{#f}. Filenames may have any of the optional extensions\n" + "in the @code{%load-extensions} list; @code{%search-load-path}\n" + "will try each extension automatically.") #define FUNC_NAME s_scm_sys_search_load_path { SCM path = *scm_loc_load_path; @@ -432,10 +434,11 @@ SCM_DEFINE (scm_sys_search_load_path, "%search-load-path", 1, 0, 0, SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0, - (SCM filename), - "Search @var{%load-path} for @var{file} and load it into the top-level\n" - "environment. If @var{file} is a relative pathname and is not found in\n" - "the list of search paths, an error is signalled.") + (SCM filename), + "Search @var{%load-path} for the file named @var{filename} and\n" + "load it into the top-level environment. If @var{filename} is a\n" + "relative pathname and is not found in the list of search paths,\n" + "an error is signalled.") #define FUNC_NAME s_scm_primitive_load_path { SCM full_filename; From d69947f7446701918df01f216e258705acf04cd4 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Mon, 12 Mar 2001 12:23:55 +0000 Subject: [PATCH 0706/2047] * common-list.scm (count-if): New procedure. --- ice-9/ChangeLog | 4 ++++ ice-9/common-list.scm | 8 ++++++++ 2 files changed, 12 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 0d43f134d..4ce20506a 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2001-03-12 Keisuke Nishida + + * common-list.scm (count-if): New procedure. + 2001-03-10 Neil Jerram * buffered-input.scm (make-buffered-input-port): New, more general diff --git a/ice-9/common-list.scm b/ice-9/common-list.scm index ebb13fe5b..c5c8c0609 100644 --- a/ice-9/common-list.scm +++ b/ice-9/common-list.scm @@ -124,6 +124,14 @@ Analogous to some but returns #t as soon as an application of PRED returns #f, or #f otherwise." (not (apply every pred ls))) +(define-public (count-if pred l) + "Returns the number of elements in L such that (PRED element) +returns true." + (let loop ((n 0) (l l)) + (cond ((null? l) n) + ((pred (car l)) (loop (+ n 1) (cdr l))) + (else (loop n (cdr l)))))) + (define-public (find-if pred l) "Searches for the first element in L such that (PRED element) returns true. If it finds any such element in L, element is From e11208ca72463ef39e25e81d0245637b2e586f60 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 12 Mar 2001 14:34:44 +0000 Subject: [PATCH 0707/2047] * Cleaned up uses and definition of SCM_ASSYNT. --- libguile/ChangeLog | 15 +++++++++++++++ libguile/goops.c | 34 ++++++++++++++++++++++------------ libguile/goops.h | 2 ++ libguile/macros.h | 3 ++- 4 files changed, 41 insertions(+), 13 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 7fc9c4d40..320af3503 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,18 @@ +2001-03-12 Dirk Herrmann + + * goops.h (SCM_VALIDATE_PUREGENERIC): New macro. + + * goops.c (scm_m_atslot_ref, scm_m_atslot_set_x, + scm_m_atdispatch): Provide definitions for FUNC_NAME. Don't use + SCM_ASSYNT to check for correct argument types. Either use some + SCM_VALIDATE_* macro or an explicit test. + + (scm_make_foreign_object): Don't use SCM_ASSERT to check for + misc-errors. + + * macros.h (SCM_ASSYNT): On assertion failure, issue a misc-error + instead of calling scm_wta. + 2001-03-12 Martin Grabmueller * load.c (scm_primitive_load, scm_primitive_load_path), diff --git a/libguile/goops.c b/libguile/goops.c index f3250c210..a79c13fb6 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1866,23 +1866,29 @@ SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_makmmacro, scm_m_atslot_ref); SCM scm_m_atslot_ref (SCM xorig, SCM env) +#define FUNC_NAME s_atslot_ref { SCM x = SCM_CDR (xorig); - SCM_ASSYNT (scm_ilength (x) == 2, xorig, scm_s_expression, s_atslot_ref); - SCM_ASSYNT (SCM_INUMP (SCM_CADR (x)), SCM_CADR (x), SCM_ARG2, s_atslot_ref); + SCM_ASSYNT (scm_ilength (x) == 2, xorig, scm_s_expression, FUNC_NAME); + SCM_VALIDATE_INUM (SCM_ARG2, SCM_CADR (x)); return scm_cons (SCM_IM_SLOT_REF, x); } +#undef FUNC_NAME + SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_makmmacro, scm_m_atslot_set_x); SCM scm_m_atslot_set_x (SCM xorig, SCM env) +#define FUNC_NAME s_atslot_set_x { SCM x = SCM_CDR (xorig); - SCM_ASSYNT (scm_ilength (x) == 3, xorig, scm_s_expression, s_atslot_set_x); - SCM_ASSYNT (SCM_INUMP (SCM_CADR (x)), SCM_CADR (x), SCM_ARG2, s_atslot_set_x); + SCM_ASSYNT (scm_ilength (x) == 3, xorig, scm_s_expression, FUNC_NAME); + SCM_VALIDATE_INUM (SCM_ARG2, SCM_CADR (x)); return scm_cons (SCM_IM_SLOT_SET_X, x); } +#undef FUNC_NAME + SCM_SYNTAX (s_atdispatch, "@dispatch", scm_makmmacro, scm_m_atdispatch); @@ -1893,20 +1899,20 @@ scm_m_atdispatch (SCM xorig, SCM env) #define FUNC_NAME s_atdispatch { SCM args, n, v, gf, x = SCM_CDR (xorig); - SCM_ASSYNT (scm_ilength (x) == 4, xorig, scm_s_expression, s_atdispatch); + SCM_ASSYNT (scm_ilength (x) == 4, xorig, scm_s_expression, FUNC_NAME); args = SCM_CAR (x); - SCM_ASSYNT (SCM_CONSP (args) || SCM_SYMBOLP (args), - args, SCM_ARG1, s_atdispatch); + if (!SCM_CONSP (args) && !SCM_SYMBOLP (args)) + SCM_WRONG_TYPE_ARG (SCM_ARG1, args); x = SCM_CDR (x); n = SCM_XEVALCAR (x, env); - SCM_ASSYNT (SCM_INUMP (n), n, SCM_ARG2, s_atdispatch); + SCM_VALIDATE_INUM (SCM_ARG2, n); SCM_ASSERT_RANGE (0, n, SCM_INUM (n) >= 1); x = SCM_CDR (x); v = SCM_XEVALCAR (x, env); - SCM_ASSYNT (SCM_VECTORP (v), v, SCM_ARG3, s_atdispatch); + SCM_VALIDATE_VECTOR (SCM_ARG3, v); x = SCM_CDR (x); gf = SCM_XEVALCAR (x, env); - SCM_ASSYNT (SCM_PUREGENERICP (gf), gf, SCM_ARG4, s_atdispatch); + SCM_VALIDATE_PUREGENERIC (SCM_ARG4, gf); return SCM_LIST5 (SCM_IM_DISPATCH, args, n, v, gf); } #undef FUNC_NAME @@ -2432,15 +2438,19 @@ scm_load_goops () scm_resolve_module (scm_read_0str ("(oop goops)")); } + SCM scm_make_foreign_object (SCM class, SCM initargs) +#define FUNC_NAME s_scm_make { void * (*constructor) (SCM) = (void * (*) (SCM)) SCM_SLOT (class, scm_si_constructor); - SCM_ASSERT (constructor != 0, class, "Can't make instances of this class", - s_scm_make); + if (constructor == 0) + SCM_MISC_ERROR ("Can't make instances of class ~S", SCM_LIST1 (class)); return scm_wrap_object (class, constructor (initargs)); } +#undef FUNC_NAME + static size_t scm_free_foreign_object (SCM *class, SCM *data) diff --git a/libguile/goops.h b/libguile/goops.h index 069fbfb38..624ca3075 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -131,6 +131,8 @@ typedef struct scm_method_t { #define SCM_PUREGENERICP(x) \ (SCM_STRUCTP (x) && (SCM_INST_TYPE(x) & SCM_CLASSF_PURE_GENERIC)) +#define SCM_VALIDATE_PUREGENERIC(pos, x) SCM_MAKE_VALIDATE (pos, x, PUREGENERICP) + #define SCM_SIMPLEMETHODP(x) (SCM_INST_TYPE(x) & SCM_CLASSF_SIMPLE_METHOD) #define SCM_ACCESSORP(x) (SCM_INST_TYPE(x) & SCM_CLASSF_ACCESSOR_METHOD) #define SCM_VALIDATE_ACCESSOR(pos, x) SCM_MAKE_VALIDATE (pos, x, ACCESSORP) diff --git a/libguile/macros.h b/libguile/macros.h index af7ee7014..bd22a7b38 100644 --- a/libguile/macros.h +++ b/libguile/macros.h @@ -48,7 +48,8 @@ -#define SCM_ASSYNT(_cond, _arg, _pos, _subr) if(!(_cond))scm_wta(_arg, (char *)_pos, _subr); +#define SCM_ASSYNT(_cond, _arg, _msg, _subr) \ + if (!(_cond)) scm_misc_error (_subr, _msg, SCM_EOL); extern scm_bits_t scm_tc16_macro; From 8cdeee7d7875111169f65a26ca72d05ac2aa321f Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Mon, 12 Mar 2001 15:03:17 +0000 Subject: [PATCH 0708/2047] * arrays.scm (make-array): Added quote in front of (). --- ice-9/ChangeLog | 4 ++++ ice-9/arrays.scm | 4 ++-- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 4ce20506a..6dbd2a55c 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2001-03-12 Mikael Djurfeldt + + * arrays.scm (make-array): Added quote in front of (). + 2001-03-12 Keisuke Nishida * common-list.scm (count-if): New procedure. diff --git a/ice-9/arrays.scm b/ice-9/arrays.scm index 51be69210..7d249795e 100644 --- a/ice-9/arrays.scm +++ b/ice-9/arrays.scm @@ -1,6 +1,6 @@ ;;; installed-scm-file -;;;; Copyright (C) 1999 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001 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 @@ -30,7 +30,7 @@ (define uniform-vector-write uniform-array-write) (define (make-array fill . args) - (dimensions->uniform-array args () fill)) + (dimensions->uniform-array args '() fill)) (define (make-uniform-array prot . args) (dimensions->uniform-array args prot)) (define (list->array ndim lst) From 468bd77ef5266ca744a27d83750cb8836f9a2652 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Tue, 13 Mar 2001 01:56:47 +0000 Subject: [PATCH 0709/2047] * guile-c.el (guile-c-deprecate-region): New command. --- emacs/ChangeLog | 4 ++++ emacs/guile-c.el | 18 ++++++++++++++++++ 2 files changed, 22 insertions(+) diff --git a/emacs/ChangeLog b/emacs/ChangeLog index 1243b61f4..a816ff5df 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,3 +1,7 @@ +2001-03-12 Keisuke Nishida + + * guile-c.el (guile-c-deprecate-region): New command. + 2001-03-11 Keisuke Nishida * guile-c.el: New file. diff --git a/emacs/guile-c.el b/emacs/guile-c.el index 8d1b9f59c..3c7344985 100644 --- a/emacs/guile-c.el +++ b/emacs/guile-c.el @@ -24,6 +24,7 @@ ;; (require 'guile-c) ;; (define-key c-mode-map "\C-c\C-g\C-e" 'guile-c-edit-docstring) ;; (define-key c-mode-map "\C-c\C-g\C-p" 'guile-c-insert-define) +;; (define-key c-mode-map "\C-c\C-g\C-d" 'guile-c-deprecate-region) ;; )) ;;; Code: @@ -32,6 +33,7 @@ (defvar guile-c-prefix "scm_") + ;;; ;;; Insert templates ;;; @@ -91,6 +93,7 @@ (while (string-match "[-:]" name) (setq name (replace-match "_" t t name))) (concat guile-c-prefix name)) + ;;; ;;; Edit docstrings ;;; @@ -151,6 +154,21 @@ (forward-line 1)) (cons start (- (point) 2)))))) + +;;; +;;; Others +;;; + +(defun guile-c-deprecate-region (start end) + (interactive "r") + (save-excursion + (let ((marker (make-marker))) + (set-marker marker end) + (goto-char start) + (insert "#if (SCM_DEBUG_DEPRECATED == 0)\n\n") + (goto-char marker) + (insert "\n#endif /* (SCM_DEBUG_DEPRECATED == 0) */\n")))) + (provide 'guile-c) ;; guile-c.el ends here From 1f3908c46ad172c7bf024942f728726f59b6c2ef Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Tue, 13 Mar 2001 02:09:57 +0000 Subject: [PATCH 0710/2047] * strports.c (scm_object_to_string): New procedure. (scm_strprint_obj): Deprecated. --- NEWS | 8 ++++++++ RELEASE | 1 + libguile/ChangeLog | 6 ++++++ libguile/strports.c | 48 +++++++++++++++++++++++---------------------- libguile/strports.h | 8 +++++++- 5 files changed, 47 insertions(+), 24 deletions(-) diff --git a/NEWS b/NEWS index 15ab4c9ee..cc6190050 100644 --- a/NEWS +++ b/NEWS @@ -334,6 +334,10 @@ Instead, use scm_c_memq or scm_memq, scm_memv, scm_member. * return 0 if the request is for 0 bytes, with no end-of-file check +** New function: object->string OBJ + +Return a Scheme string obtained by printing a given object. + ** New function: port? X Returns a boolean indicating whether X is a port. Equivalent to @@ -622,6 +626,10 @@ Use scm_make_smob_type and scm_set_smob_XXX instead. This can be used to set an apply function to a smob type. +** Deprecated function: scm_strprint_obj + +Use scm_object_to_string instead. + Changes since Guile 1.3.4: diff --git a/RELEASE b/RELEASE index 54471fc05..8e797adf0 100644 --- a/RELEASE +++ b/RELEASE @@ -78,6 +78,7 @@ In release 1.6: strictly scsh-compatible version which uses multiple values. For interactive use it would be easy to load the module in ~/.guile. - remove scm_close_all_ports_except +- remove scm_strprint_obj Modules sort.c and random.c should be factored out into separate modules (but still be distributed with guile-core) when we get a new diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 320af3503..8371560ff 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2001-03-12 Keisuke Nishida + + * strports.c (scm_object_to_string): New procedure. + (scm_strprint_obj): Deprecated. + * strports.h: Reflect the changes. + 2001-03-12 Dirk Herrmann * goops.h (SCM_VALIDATE_PUREGENERIC): New macro. diff --git a/libguile/strports.c b/libguile/strports.c index 8a99e618b..5dad27063 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -311,6 +311,31 @@ SCM scm_strport_to_string (SCM port) return scm_makfromstr ((char *) pt->read_buf, pt->read_buf_size, 0); } +SCM_DEFINE (scm_object_to_string, "object->string", 1, 0, 0, + (SCM obj), + "Return a Scheme string obtained by printing a given object.") +#define FUNC_NAME s_scm_object_to_string +{ + SCM str; + SCM port; + + str = scm_makstr (0, 0); + port = scm_mkstrport (SCM_INUM0, str, SCM_OPN | SCM_WRTNG, "scm_strprint_obj"); + scm_prin1 (obj, port, 1); + return scm_strport_to_string (port); +} +#undef FUNC_NAME + +#if (SCM_DEBUG_DEPRECATED == 0) + +SCM +scm_strprint_obj (SCM obj) +{ + return scm_object_to_string (obj); +} + +#endif /* (SCM_DEBUG_DEPRECATED == 0) */ + SCM_DEFINE (scm_call_with_output_string, "call-with-output-string", 1, 0, 0, (SCM proc), "Calls the one-argument procedure @var{proc} with a newly created output\n" @@ -330,29 +355,6 @@ SCM_DEFINE (scm_call_with_output_string, "call-with-output-string", 1, 0, 0, } #undef FUNC_NAME - - -/* Return a Scheme string obtained by printing a given object. - */ - - -SCM -scm_strprint_obj (SCM obj) -{ - SCM str; - SCM port; - - str = scm_makstr (0, 0); - port = scm_mkstrport (SCM_INUM0, str, SCM_OPN | SCM_WRTNG, "scm_strprint_obj"); - scm_prin1 (obj, port, 1); - { - return scm_strport_to_string (port); - } -} - - - - SCM_DEFINE (scm_call_with_input_string, "call-with-input-string", 2, 0, 0, (SCM str, SCM proc), "Calls the one-argument procedure @var{proc} with a newly created input\n" diff --git a/libguile/strports.h b/libguile/strports.h index 28bae69b4..917b73f60 100644 --- a/libguile/strports.h +++ b/libguile/strports.h @@ -50,14 +50,20 @@ extern SCM scm_mkstrport (SCM pos, SCM str, long modes, const char * caller); extern SCM scm_strport_to_string (SCM port); +extern SCM scm_object_to_string (SCM obj); extern SCM scm_call_with_output_string (SCM proc); -extern SCM scm_strprint_obj (SCM obj); extern SCM scm_call_with_input_string (SCM str, SCM proc); extern SCM scm_read_0str (char *expr); extern SCM scm_eval_0str (const char *expr); extern SCM scm_eval_string (SCM string); extern void scm_init_strports (void); +#if (SCM_DEBUG_DEPRECATED == 0) + +extern SCM scm_strprint_obj (SCM obj); + +#endif /* SCM_DEBUG_DEPRECATED == 0 */ + #endif /* STRPORTSH */ /* From b97c6762de581fb157b712099495ec4e96910c3e Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Tue, 13 Mar 2001 02:11:20 +0000 Subject: [PATCH 0711/2047] Add check-guile. --- .cvsignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.cvsignore b/.cvsignore index 074a0cc72..f023b667e 100644 --- a/.cvsignore +++ b/.cvsignore @@ -13,3 +13,4 @@ guile-*.tar.gz libtool ltconfig ltmain.sh +check-guile From 1a92274c8e2b588f917231586deb93f4b85c7c53 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Tue, 13 Mar 2001 02:14:12 +0000 Subject: [PATCH 0712/2047] Use FUNC_NAME. --- libguile/strports.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/strports.c b/libguile/strports.c index 5dad27063..53e26237f 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -320,7 +320,7 @@ SCM_DEFINE (scm_object_to_string, "object->string", 1, 0, 0, SCM port; str = scm_makstr (0, 0); - port = scm_mkstrport (SCM_INUM0, str, SCM_OPN | SCM_WRTNG, "scm_strprint_obj"); + port = scm_mkstrport (SCM_INUM0, str, SCM_OPN | SCM_WRTNG, FUNC_NAME); scm_prin1 (obj, port, 1); return scm_strport_to_string (port); } From f7fd6a73897f915c5079c9e7877e5a19b03948ba Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Tue, 13 Mar 2001 05:49:19 +0000 Subject: [PATCH 0713/2047] * guile-c.el (guile-c-window-configuration): New variable. (guile-c-edit-docstring, guile-c-edit-finish): Save/restore window-configuration. --- emacs/ChangeLog | 6 ++++++ emacs/guile-c.el | 5 ++++- 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/emacs/ChangeLog b/emacs/ChangeLog index a816ff5df..deb07922b 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,3 +1,9 @@ +2001-03-13 Keisuke Nishida + + * guile-c.el (guile-c-window-configuration): New variable. + (guile-c-edit-docstring, guile-c-edit-finish): + Save/restore window-configuration. + 2001-03-12 Keisuke Nishida * guile-c.el (guile-c-deprecate-region): New command. diff --git a/emacs/guile-c.el b/emacs/guile-c.el index 3c7344985..ada1dedf5 100644 --- a/emacs/guile-c.el +++ b/emacs/guile-c.el @@ -98,12 +98,15 @@ ;;; Edit docstrings ;;; +(defvar guile-c-window-configuration nil) + (defun guile-c-edit-docstring () (interactive) (let* ((region (guile-c-find-docstring)) (doc (if region (buffer-substring (car region) (cdr region))))) (if (not doc) (error "No docstring!") + (setq guile-c-window-configuration (current-window-configuration)) (with-current-buffer (get-buffer-create "*Guile Docstring*") (erase-buffer) (insert doc) @@ -140,7 +143,7 @@ (forward-line 1))) (let ((doc (buffer-string))) (kill-buffer (current-buffer)) - (delete-window (selected-window)) + (set-window-configuration guile-c-window-configuration) (let ((region (guile-c-find-docstring))) (goto-char (car region)) (delete-region (car region) (cdr region))) From fe78b6c09680352332481f26502b5a30d3dbf0ca Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Tue, 13 Mar 2001 05:59:42 +0000 Subject: [PATCH 0714/2047] (scm_object_to_string): Takes an optional argument. --- libguile/strports.c | 24 +++++++++++++++++------- libguile/strports.h | 2 +- 2 files changed, 18 insertions(+), 8 deletions(-) diff --git a/libguile/strports.c b/libguile/strports.c index 53e26237f..b72130ec7 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -58,6 +58,7 @@ #include "libguile/root.h" #include "libguile/strings.h" #include "libguile/modules.h" +#include "libguile/validate.h" #include "libguile/strports.h" @@ -311,17 +312,26 @@ SCM scm_strport_to_string (SCM port) return scm_makfromstr ((char *) pt->read_buf, pt->read_buf_size, 0); } -SCM_DEFINE (scm_object_to_string, "object->string", 1, 0, 0, - (SCM obj), - "Return a Scheme string obtained by printing a given object.") +SCM_DEFINE (scm_object_to_string, "object->string", 1, 1, 0, + (SCM obj, SCM printer), + "Return a Scheme string obtained by printing @var{obj}.\n" + "Printing function can be specified by the optional second\n" + "argument @var{printer} (default: @code{write}).") #define FUNC_NAME s_scm_object_to_string { - SCM str; - SCM port; + SCM str, port; + + if (!SCM_UNBNDP (printer)) + SCM_VALIDATE_PROC (2, printer); str = scm_makstr (0, 0); port = scm_mkstrport (SCM_INUM0, str, SCM_OPN | SCM_WRTNG, FUNC_NAME); - scm_prin1 (obj, port, 1); + + if (SCM_UNBNDP (printer)) + scm_write (obj, port); + else + scm_apply (printer, SCM_LIST2 (obj, port), SCM_EOL); + return scm_strport_to_string (port); } #undef FUNC_NAME @@ -331,7 +341,7 @@ SCM_DEFINE (scm_object_to_string, "object->string", 1, 0, 0, SCM scm_strprint_obj (SCM obj) { - return scm_object_to_string (obj); + return scm_object_to_string (obj, SCM_UNDEFINED); } #endif /* (SCM_DEBUG_DEPRECATED == 0) */ diff --git a/libguile/strports.h b/libguile/strports.h index 917b73f60..6767bd2b7 100644 --- a/libguile/strports.h +++ b/libguile/strports.h @@ -50,7 +50,7 @@ extern SCM scm_mkstrport (SCM pos, SCM str, long modes, const char * caller); extern SCM scm_strport_to_string (SCM port); -extern SCM scm_object_to_string (SCM obj); +extern SCM scm_object_to_string (SCM obj, SCM printer); extern SCM scm_call_with_output_string (SCM proc); extern SCM scm_call_with_input_string (SCM str, SCM proc); extern SCM scm_read_0str (char *expr); From 26a3038db8ebebcb6e1c97e2293e73b6bfebfa90 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Tue, 13 Mar 2001 08:02:02 +0000 Subject: [PATCH 0715/2047] * ports.c (scm_port_mode): Changed `mode' array size to 4, avoiding buffer overflow. --- libguile/ChangeLog | 4 ++++ libguile/ports.c | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 8371560ff..fac10cb77 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2001-03-13 Martin Grabmueller + + * ports.c (scm_port_mode): Changed `mode' array size to 4. + 2001-03-12 Keisuke Nishida * strports.c (scm_object_to_string): New procedure. diff --git a/libguile/ports.c b/libguile/ports.c index e8c739b30..e18dff08f 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -609,7 +609,7 @@ SCM_DEFINE (scm_port_mode, "port-mode", 1, 0, 0, "port creation are not retained.") #define FUNC_NAME s_scm_port_mode { - char modes[3]; + char modes[4]; modes[0] = '\0'; port = SCM_COERCE_OUTPORT (port); From d3dd80ab5b01c4726b774942b45902e73a877a3c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 14 Mar 2001 10:02:12 +0000 Subject: [PATCH 0716/2047] * gh_data.c (gh_scm2chars, gh_scm2shorts, gh_scm2longs), (gh_scm2floats, gh_scm2doubles): Check for malloc() returning NULL in various places. (gh_scm2newstr, gh_symbol2newstr): Change call to scm_must_malloc() to malloc(), because user-free()able memory is allocated. * gc.c: Added declaration of `scm_debug_check_freelist'. --- libguile/ChangeLog | 11 +++++++++ libguile/gc.c | 4 ++++ libguile/gh_data.c | 57 ++++++++++++++++++++++++++++++++++++---------- 3 files changed, 60 insertions(+), 12 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index fac10cb77..6b04ca3ee 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2001-03-14 Martin Grabmueller + + * gh_data.c (gh_scm2chars, gh_scm2shorts, gh_scm2longs), + (gh_scm2floats, gh_scm2doubles): Check for malloc() returning NULL + in various places. + (gh_scm2newstr, gh_symbol2newstr): Change call to + scm_must_malloc() to malloc(), because user-free()able memory is + allocated. + + * gc.c: Added declaration of `scm_debug_check_freelist'. + 2001-03-13 Martin Grabmueller * ports.c (scm_port_mode): Changed `mode' array size to 4. diff --git a/libguile/gc.c b/libguile/gc.c index c414c7552..9fe4e0a8a 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -609,6 +609,10 @@ SCM_DEFINE (scm_free_list_length, "free-list-length", 0, 0, 0, #ifdef GUILE_DEBUG_FREELIST +/* Non-zero if freelist debugging is in effect. Set this via + `gc-set-debug-check-freelist!'. */ +static int scm_debug_check_freelist = 0; + /* Number of calls to SCM_NEWCELL since startup. */ static unsigned long scm_newcell_count; static unsigned long scm_newcell2_count; diff --git a/libguile/gh_data.c b/libguile/gh_data.c index 21510c4e9..013ba27d9 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -258,7 +258,7 @@ gh_scm2char (SCM obj) /* Convert a vector, weak vector, string, substring or uniform vector into an array of chars. If result array in arg 2 is NULL, malloc a - new one. */ + new one. If out of memory, return NULL. */ char * gh_scm2chars (SCM obj, char *m) { @@ -286,6 +286,8 @@ gh_scm2chars (SCM obj, char *m) } if (m == 0) m = (char *) malloc (n * sizeof (char)); + if (m == NULL) + return NULL; for (i = 0; i < n; ++i) m[i] = SCM_INUM (SCM_VELTS (obj)[i]); break; @@ -294,6 +296,8 @@ gh_scm2chars (SCM obj, char *m) n = SCM_UVECTOR_LENGTH (obj); if (m == 0) m = (char *) malloc (n * sizeof (char)); + if (m == NULL) + return NULL; memcpy (m, SCM_VELTS (obj), n * sizeof (char)); break; #endif @@ -302,6 +306,8 @@ gh_scm2chars (SCM obj, char *m) n = SCM_STRING_LENGTH (obj); if (m == 0) m = (char *) malloc (n * sizeof (char)); + if (m == NULL) + return NULL; memcpy (m, SCM_VELTS (obj), n * sizeof (char)); break; default: @@ -311,7 +317,8 @@ gh_scm2chars (SCM obj, char *m) } /* Convert a vector, weak vector or uniform vector into an array of - shorts. If result array in arg 2 is NULL, malloc a new one. */ + shorts. If result array in arg 2 is NULL, malloc a new one. If + out of memory, return NULL. */ short * gh_scm2shorts (SCM obj, short *m) { @@ -339,6 +346,8 @@ gh_scm2shorts (SCM obj, short *m) } if (m == 0) m = (short *) malloc (n * sizeof (short)); + if (m == NULL) + return NULL; for (i = 0; i < n; ++i) m[i] = SCM_INUM (SCM_VELTS (obj)[i]); break; @@ -347,6 +356,8 @@ gh_scm2shorts (SCM obj, short *m) n = SCM_UVECTOR_LENGTH (obj); if (m == 0) m = (short *) malloc (n * sizeof (short)); + if (m == NULL) + return NULL; memcpy (m, SCM_VELTS (obj), n * sizeof (short)); break; #endif @@ -357,7 +368,8 @@ gh_scm2shorts (SCM obj, short *m) } /* Convert a vector, weak vector or uniform vector into an array of - longs. If result array in arg 2 is NULL, malloc a new one. */ + longs. If result array in arg 2 is NULL, malloc a new one. If out + of memory, return NULL. */ long * gh_scm2longs (SCM obj, long *m) { @@ -378,6 +390,8 @@ gh_scm2longs (SCM obj, long *m) } if (m == 0) m = (long *) malloc (n * sizeof (long)); + if (m == NULL) + return NULL; for (i = 0; i < n; ++i) { val = SCM_VELTS (obj)[i]; @@ -390,6 +404,8 @@ gh_scm2longs (SCM obj, long *m) n = SCM_UVECTOR_LENGTH (obj); if (m == 0) m = (long *) malloc (n * sizeof (long)); + if (m == NULL) + return NULL; memcpy (m, SCM_VELTS (obj), n * sizeof (long)); break; #endif @@ -400,7 +416,8 @@ gh_scm2longs (SCM obj, long *m) } /* Convert a vector, weak vector or uniform vector into an array of - floats. If result array in arg 2 is NULL, malloc a new one. */ + floats. If result array in arg 2 is NULL, malloc a new one. If + out of memory, return NULL. */ float * gh_scm2floats (SCM obj, float *m) { @@ -422,6 +439,8 @@ gh_scm2floats (SCM obj, float *m) } if (m == 0) m = (float *) malloc (n * sizeof (float)); + if (m == NULL) + return NULL; for (i = 0; i < n; ++i) { val = SCM_VELTS (obj)[i]; @@ -438,6 +457,8 @@ gh_scm2floats (SCM obj, float *m) n = SCM_UVECTOR_LENGTH (obj); if (m == 0) m = (float *) malloc (n * sizeof (float)); + if (m == NULL) + return NULL; memcpy (m, (float *) SCM_VELTS (obj), n * sizeof (float)); break; @@ -445,6 +466,8 @@ gh_scm2floats (SCM obj, float *m) n = SCM_UVECTOR_LENGTH (obj); if (m == 0) m = (float*) malloc (n * sizeof (float)); + if (m == NULL) + return NULL; for (i = 0; i < n; ++i) m[i] = ((double *) SCM_VELTS (obj))[i]; break; @@ -456,7 +479,8 @@ gh_scm2floats (SCM obj, float *m) } /* Convert a vector, weak vector or uniform vector into an array of - doubles. If result array in arg 2 is NULL, malloc a new one. */ + doubles. If result array in arg 2 is NULL, malloc a new one. If + out of memory, return NULL. */ double * gh_scm2doubles (SCM obj, double *m) { @@ -478,6 +502,8 @@ gh_scm2doubles (SCM obj, double *m) } if (m == 0) m = (double *) malloc (n * sizeof (double)); + if (m == NULL) + return NULL; for (i = 0; i < n; ++i) { val = SCM_VELTS (obj)[i]; @@ -494,6 +520,8 @@ gh_scm2doubles (SCM obj, double *m) n = SCM_UVECTOR_LENGTH (obj); if (m == 0) m = (double *) malloc (n * sizeof (double)); + if (m == NULL) + return NULL; for (i = 0; i < n; ++i) m[i] = ((float *) SCM_VELTS (obj))[i]; break; @@ -502,6 +530,8 @@ gh_scm2doubles (SCM obj, double *m) n = SCM_UVECTOR_LENGTH (obj); if (m == 0) m = (double*) malloc (n * sizeof (double)); + if (m == NULL) + return NULL; memcpy (m, SCM_VELTS (obj), n * sizeof (double)); break; #endif @@ -518,7 +548,8 @@ gh_scm2doubles (SCM obj, double *m) non-null, set *lenp to the string's length. This function uses malloc to obtain storage for the copy; the - caller is responsible for freeing it. + caller is responsible for freeing it. If out of memory, NULL is + returned. Note that Scheme strings may contain arbitrary data, including null characters. This means that null termination is not a reliable way @@ -535,15 +566,15 @@ gh_scm2newstr (SCM str, int *lenp) len = SCM_STRING_LENGTH (str); - ret_str = (char *) scm_must_malloc ((len + 1) * sizeof (char), - "gh_scm2newstr"); + ret_str = (char *) malloc ((len + 1) * sizeof (char)); + if (ret_str == NULL) + return NULL; /* so we copy tmp_str to ret_str, which is what we will allocate */ memcpy (ret_str, SCM_STRING_CHARS (str), len); scm_remember_upto_here_1 (str); /* now make sure we null-terminate it */ ret_str[len] = '\0'; - if (lenp != NULL) { *lenp = len; @@ -580,7 +611,8 @@ gh_get_substr (SCM src, char *dst, int start, int len) string's length. This function uses malloc to obtain storage for the copy; the - caller is responsible for freeing it. */ + caller is responsible for freeing it. If out of memory, NULL is + returned.*/ char * gh_symbol2newstr (SCM sym, int *lenp) { @@ -591,8 +623,9 @@ gh_symbol2newstr (SCM sym, int *lenp) len = SCM_SYMBOL_LENGTH (sym); - ret_str = (char *) scm_must_malloc ((len + 1) * sizeof (char), - "gh_symbol2newstr"); + ret_str = (char *) malloc ((len + 1) * sizeof (char)); + if (ret_str == NULL) + return NULL; /* so we copy sym to ret_str, which is what we will allocate */ memcpy (ret_str, SCM_SYMBOL_CHARS (sym), len); scm_remember_upto_here_1 (sym); From 80dee77b864c3b98bc17f4c130445a47c3e65e54 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 15 Mar 2001 00:42:10 +0000 Subject: [PATCH 0717/2047] * Use const specifier in function signature of gh_ints2scm. --- THANKS | 3 ++- libguile/ChangeLog | 6 ++++++ libguile/gh.h | 4 ++-- libguile/gh_data.c | 4 ++-- 4 files changed, 12 insertions(+), 5 deletions(-) diff --git a/THANKS b/THANKS index 16d4d78ff..142814adc 100644 --- a/THANKS +++ b/THANKS @@ -34,6 +34,7 @@ For fixes or providing information which led to a fix: Bill Schottstaedt Miroslav Silovic Dale P. Smith - Jacques A. Vidrine. + Jacques A. Vidrine + Brett Viren William Webber Keith Wright diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6b04ca3ee..9705001d2 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2001-03-15 Dirk Herrmann + + * gh.h/gh_data.c (gh_ints2scm): Changed the signature to use a + const int* to reflect that the input array of integers remains + unchanged. Thanks to Brett Viren for the hint. + 2001-03-14 Martin Grabmueller * gh_data.c (gh_scm2chars, gh_scm2shorts, gh_scm2longs), diff --git a/libguile/gh.h b/libguile/gh.h index 447c43867..c7c88907c 100644 --- a/libguile/gh.h +++ b/libguile/gh.h @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001 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 @@ -104,7 +104,7 @@ SCM gh_str2scm(const char *s, int len); SCM gh_str02scm(const char *s); void gh_set_substr(char *src, SCM dst, int start, int len); SCM gh_symbol2scm(const char *symbol_str); -SCM gh_ints2scm(int *d, int n); +SCM gh_ints2scm(const int *d, int n); #ifdef HAVE_ARRAYS SCM gh_chars2byvect(const char *d, int n); diff --git a/libguile/gh_data.c b/libguile/gh_data.c index 013ba27d9..3d6483fcb 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 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 * the Free Software Foundation; either version 2, or (at your option) @@ -131,7 +131,7 @@ gh_symbol2scm (const char *symbol_str) } SCM -gh_ints2scm (int *d, int n) +gh_ints2scm (const int *d, int n) { int i; SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED); From 160bb34a53c1d775bc0cb71b45c9a2eb289749cf Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 15 Mar 2001 09:50:20 +0000 Subject: [PATCH 0718/2047] * Removed unused object parameter from SCM_ASSYNT. --- libguile/ChangeLog | 16 +++++++ libguile/eval.c | 114 ++++++++++++++++++++------------------------- libguile/evalext.c | 10 ++-- libguile/goops.c | 6 +-- libguile/macros.h | 2 +- 5 files changed, 76 insertions(+), 72 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 9705001d2..1577fbb2f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,19 @@ +2001-03-15 Dirk Herrmann + + * macros.h (SCM_ASSYNT): Removed unused object argument from + signature. + + * eval.c (scm_m_body, scm_m_quote, scm_m_begin, scm_m_if, + scm_m_set_x, scm_m_and, scm_m_or, scm_m_case, scm_m_cond, + scm_m_letstar, scm_m_do, scm_m_quasiquote, scm_m_delay, + scm_m_define, scm_m_letrec1, scm_m_letrec, scm_m_let, scm_m_apply, + scm_m_cont, scm_m_nil_cond, scm_m_nil_ify, scm_m_t_ify, + scm_m_0_cond, scm_m_0_ify, scm_m_1_ify, scm_m_atfop, scm_m_atbind, + scm_m_expand_body), evalext.c (scm_m_generalized_set_x, + scm_m_undefine), goops.c (scm_m_atslot_ref, scm_m_atslot_set_x, + scm_m_atdispatch): Removed unused object argument from call to + SCM_ASSYNT. + 2001-03-15 Dirk Herrmann * gh.h/gh_data.c (gh_ints2scm): Changed the signature to use a diff --git a/libguile/eval.c b/libguile/eval.c index 56019c552..7c444d239 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -482,7 +482,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace"); static SCM scm_m_body (SCM op, SCM xorig, const char *what) { - SCM_ASSYNT (scm_ilength (xorig) >= 1, xorig, scm_s_expression, what); + SCM_ASSYNT (scm_ilength (xorig) >= 1, scm_s_expression, what); /* Don't add another ISYM if one is present already. */ if (SCM_ISYMP (SCM_CAR (xorig))) @@ -508,8 +508,7 @@ scm_m_quote (SCM xorig, SCM env) { SCM x = scm_copy_tree (SCM_CDR (xorig)); - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, - xorig, scm_s_expression, s_quote); + SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, s_quote); return scm_cons (SCM_IM_QUOTE, x); } @@ -521,8 +520,7 @@ SCM_GLOBAL_SYMBOL(scm_sym_begin, s_begin); SCM scm_m_begin (SCM xorig, SCM env) { - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 1, - xorig, scm_s_expression, s_begin); + SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 1, scm_s_expression, s_begin); return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig)); } @@ -533,7 +531,7 @@ SCM scm_m_if (SCM xorig, SCM env) { int len = scm_ilength (SCM_CDR (xorig)); - SCM_ASSYNT (len >= 2 && len <= 3, xorig, scm_s_expression, "if"); + SCM_ASSYNT (len >= 2 && len <= 3, scm_s_expression, "if"); return scm_cons (SCM_IM_IF, SCM_CDR (xorig)); } @@ -547,9 +545,8 @@ SCM scm_m_set_x (SCM xorig, SCM env) { SCM x = SCM_CDR (xorig); - SCM_ASSYNT (2 == scm_ilength (x), xorig, scm_s_expression, scm_s_set_x); - SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x)), - xorig, scm_s_variable, scm_s_set_x); + SCM_ASSYNT (2 == scm_ilength (x), scm_s_expression, scm_s_set_x); + SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x)), scm_s_variable, scm_s_set_x); return scm_cons (SCM_IM_SET_X, x); } @@ -561,7 +558,7 @@ SCM scm_m_and (SCM xorig, SCM env) { int len = scm_ilength (SCM_CDR (xorig)); - SCM_ASSYNT (len >= 0, xorig, scm_s_test, s_and); + SCM_ASSYNT (len >= 0, scm_s_test, s_and); if (len >= 1) return scm_cons (SCM_IM_AND, SCM_CDR (xorig)); else @@ -575,7 +572,7 @@ SCM scm_m_or (SCM xorig, SCM env) { int len = scm_ilength (SCM_CDR (xorig)); - SCM_ASSYNT (len >= 0, xorig, scm_s_test, s_or); + SCM_ASSYNT (len >= 0, scm_s_test, s_or); if (len >= 1) return scm_cons (SCM_IM_OR, SCM_CDR (xorig)); else @@ -590,15 +587,15 @@ SCM scm_m_case (SCM xorig, SCM env) { SCM proc, cdrx = scm_list_copy (SCM_CDR (xorig)), x = cdrx; - SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_clauses, s_case); + SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_clauses, s_case); while (SCM_NIMP (x = SCM_CDR (x))) { proc = SCM_CAR (x); - SCM_ASSYNT (scm_ilength (proc) >= 2, xorig, scm_s_clauses, s_case); + SCM_ASSYNT (scm_ilength (proc) >= 2, scm_s_clauses, s_case); SCM_ASSYNT (scm_ilength (SCM_CAR (proc)) >= 0 || (SCM_EQ_P (scm_sym_else, SCM_CAR (proc)) && SCM_NULLP (SCM_CDR (x))), - xorig, scm_s_clauses, s_case); + scm_s_clauses, s_case); } return scm_cons (SCM_IM_CASE, cdrx); } @@ -613,21 +610,21 @@ scm_m_cond (SCM xorig, SCM env) { SCM arg1, cdrx = scm_list_copy (SCM_CDR (xorig)), x = cdrx; int len = scm_ilength (x); - SCM_ASSYNT (len >= 1, xorig, scm_s_clauses, s_cond); + SCM_ASSYNT (len >= 1, scm_s_clauses, s_cond); while (SCM_NIMP (x)) { arg1 = SCM_CAR (x); len = scm_ilength (arg1); - SCM_ASSYNT (len >= 1, xorig, scm_s_clauses, s_cond); + SCM_ASSYNT (len >= 1, scm_s_clauses, s_cond); if (SCM_EQ_P (scm_sym_else, SCM_CAR (arg1))) { SCM_ASSYNT (SCM_NULLP (SCM_CDR (x)) && len >= 2, - xorig, "bad ELSE clause", s_cond); + "bad ELSE clause", s_cond); SCM_SETCAR (arg1, SCM_BOOL_T); } if (len >= 2 && SCM_EQ_P (scm_sym_arrow, SCM_CAR (SCM_CDR (arg1)))) SCM_ASSYNT (3 == len && SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1)))), - xorig, "bad recipient", s_cond); + "bad recipient", s_cond); x = SCM_CDR (x); } return scm_cons (SCM_IM_COND, cdrx); @@ -703,14 +700,14 @@ scm_m_letstar (SCM xorig, SCM env) { SCM x = SCM_CDR (xorig), arg1, proc, vars = SCM_EOL, *varloc = &vars; int len = scm_ilength (x); - SCM_ASSYNT (len >= 2, xorig, scm_s_body, s_letstar); + SCM_ASSYNT (len >= 2, scm_s_body, s_letstar); proc = SCM_CAR (x); - SCM_ASSYNT (scm_ilength (proc) >= 0, xorig, scm_s_bindings, s_letstar); + SCM_ASSYNT (scm_ilength (proc) >= 0, scm_s_bindings, s_letstar); while (SCM_NIMP (proc)) { arg1 = SCM_CAR (proc); - SCM_ASSYNT (2 == scm_ilength (arg1), xorig, scm_s_bindings, s_letstar); - SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), xorig, scm_s_variable, s_letstar); + SCM_ASSYNT (2 == scm_ilength (arg1), scm_s_bindings, s_letstar); + SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), scm_s_variable, s_letstar); *varloc = scm_cons2 (SCM_CAR (arg1), SCM_CAR (SCM_CDR (arg1)), SCM_EOL); varloc = SCM_CDRLOC (SCM_CDR (*varloc)); proc = SCM_CDR (proc); @@ -745,15 +742,15 @@ scm_m_do (SCM xorig, SCM env) SCM vars = SCM_EOL, inits = SCM_EOL, steps = SCM_EOL; SCM *initloc = &inits, *steploc = &steps; int len = scm_ilength (x); - SCM_ASSYNT (len >= 2, xorig, scm_s_test, "do"); + SCM_ASSYNT (len >= 2, scm_s_test, "do"); proc = SCM_CAR (x); - SCM_ASSYNT (scm_ilength (proc) >= 0, xorig, scm_s_bindings, "do"); + SCM_ASSYNT (scm_ilength (proc) >= 0, scm_s_bindings, "do"); while (SCM_NIMP(proc)) { arg1 = SCM_CAR (proc); len = scm_ilength (arg1); - SCM_ASSYNT (2 == len || 3 == len, xorig, scm_s_bindings, "do"); - SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), xorig, scm_s_variable, "do"); + SCM_ASSYNT (2 == len || 3 == len, scm_s_bindings, "do"); + SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), scm_s_variable, "do"); /* vars reversed here, inits and steps reversed at evaluation */ vars = scm_cons (SCM_CAR (arg1), vars); /* variable */ arg1 = SCM_CDR (arg1); @@ -765,7 +762,7 @@ scm_m_do (SCM xorig, SCM env) proc = SCM_CDR (proc); } x = SCM_CDR (x); - SCM_ASSYNT (scm_ilength (SCM_CAR (x)) >= 1, xorig, scm_s_test, "do"); + SCM_ASSYNT (scm_ilength (SCM_CAR (x)) >= 1, scm_s_test, "do"); x = scm_cons2 (SCM_CAR (x), SCM_CDR (x), steps); x = scm_cons2 (vars, inits, x); return scm_cons (SCM_IM_DO, x); @@ -786,7 +783,7 @@ SCM scm_m_quasiquote (SCM xorig, SCM env) { SCM x = SCM_CDR (xorig); - SCM_ASSYNT (scm_ilength (x) == 1, xorig, scm_s_expression, s_quasiquote); + SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_quasiquote); return iqq (SCM_CAR (x), env, 1); } @@ -843,7 +840,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay); SCM scm_m_delay (SCM xorig, SCM env) { - SCM_ASSYNT (scm_ilength (xorig) == 2, xorig, scm_s_expression, s_delay); + SCM_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_delay); return scm_cons2 (SCM_IM_DELAY, SCM_EOL, SCM_CDR (xorig)); } @@ -856,7 +853,7 @@ scm_m_define (SCM x, SCM env) { SCM proc, arg1 = x; x = SCM_CDR (x); - SCM_ASSYNT (scm_ilength (x) >= 2, arg1, scm_s_expression, s_define); + SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_expression, s_define); proc = SCM_CAR (x); x = SCM_CDR (x); while (SCM_CONSP (proc)) @@ -864,9 +861,8 @@ scm_m_define (SCM x, SCM env) x = scm_cons (scm_cons2 (scm_sym_lambda, SCM_CDR (proc), x), SCM_EOL); proc = SCM_CAR (proc); } - SCM_ASSYNT (SCM_SYMBOLP (proc), - arg1, scm_s_variable, s_define); - SCM_ASSYNT (1 == scm_ilength (x), arg1, scm_s_expression, s_define); + SCM_ASSYNT (SCM_SYMBOLP (proc), scm_s_variable, s_define); + SCM_ASSYNT (1 == scm_ilength (x), scm_s_expression, s_define); if (SCM_TOP_LEVEL (env)) { x = evalcar (x, env); @@ -909,13 +905,13 @@ scm_m_letrec1 (SCM op, SCM imm, SCM xorig, SCM env) SCM vars = SCM_EOL, inits = SCM_EOL, *initloc = &inits; proc = SCM_CAR (x); - SCM_ASSYNT (scm_ilength (proc) >= 1, xorig, scm_s_bindings, what); + SCM_ASSYNT (scm_ilength (proc) >= 1, scm_s_bindings, what); do { /* vars scm_list reversed here, inits reversed at evaluation */ arg1 = SCM_CAR (proc); - SCM_ASSYNT (2 == scm_ilength (arg1), xorig, scm_s_bindings, what); - SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), xorig, scm_s_variable, what); + SCM_ASSYNT (2 == scm_ilength (arg1), scm_s_bindings, what); + SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), scm_s_variable, what); if (scm_c_improper_memq (SCM_CAR (arg1), vars)) scm_misc_error (what, scm_s_duplicate_bindings, SCM_EOL); vars = scm_cons (SCM_CAR (arg1), vars); @@ -935,7 +931,7 @@ SCM scm_m_letrec (SCM xorig, SCM env) { SCM x = SCM_CDR (xorig); - SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_body, s_letrec); + SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_body, s_letrec); if (SCM_NULLP (SCM_CAR (x))) /* null binding, let* faster */ return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), SCM_EOL, @@ -957,7 +953,7 @@ scm_m_let (SCM xorig, SCM env) SCM x = cdrx, proc, arg1, name; /* structure traversers */ SCM vars = SCM_EOL, inits = SCM_EOL, *varloc = &vars, *initloc = &inits; - SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_body, s_let); + SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_body, s_let); proc = SCM_CAR (x); if (SCM_NULLP (proc) || (SCM_CONSP (proc) @@ -971,7 +967,7 @@ scm_m_let (SCM xorig, SCM env) env); } - SCM_ASSYNT (SCM_NIMP (proc), xorig, scm_s_bindings, s_let); + SCM_ASSYNT (SCM_NIMP (proc), scm_s_bindings, s_let); if (SCM_CONSP (proc)) { /* plain let, proc is */ @@ -982,15 +978,14 @@ scm_m_let (SCM xorig, SCM env) scm_misc_error (s_let, scm_s_bindings, SCM_EOL); /* bad let */ name = proc; /* named let, build equiv letrec */ x = SCM_CDR (x); - SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_body, s_let); + SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_body, s_let); proc = SCM_CAR (x); /* bindings list */ - SCM_ASSYNT (scm_ilength (proc) >= 0, xorig, scm_s_bindings, s_let); + SCM_ASSYNT (scm_ilength (proc) >= 0, scm_s_bindings, s_let); while (SCM_NIMP (proc)) { /* vars and inits both in order */ arg1 = SCM_CAR (proc); - SCM_ASSYNT (2 == scm_ilength (arg1), xorig, scm_s_bindings, s_let); - SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), - xorig, scm_s_variable, s_let); + SCM_ASSYNT (2 == scm_ilength (arg1), scm_s_bindings, s_let); + SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), scm_s_variable, s_let); *varloc = scm_cons (SCM_CAR (arg1), SCM_EOL); varloc = SCM_CDRLOC (*varloc); *initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL); @@ -1014,8 +1009,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1); SCM scm_m_apply (SCM xorig, SCM env) { - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, - xorig, scm_s_expression, s_atapply); + SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, scm_s_expression, s_atapply); return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig)); } @@ -1028,7 +1022,7 @@ SCM scm_m_cont (SCM xorig, SCM env) { SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, - xorig, scm_s_expression, s_atcall_cc); + scm_s_expression, s_atcall_cc); return scm_cons (SCM_IM_CONT, SCM_CDR (xorig)); } @@ -1043,8 +1037,7 @@ SCM scm_m_nil_cond (SCM xorig, SCM env) { int len = scm_ilength (SCM_CDR (xorig)); - SCM_ASSYNT (len >= 1 && (len & 1) == 1, xorig, - scm_s_expression, "nil-cond"); + SCM_ASSYNT (len >= 1 && (len & 1) == 1, scm_s_expression, "nil-cond"); return scm_cons (SCM_IM_NIL_COND, SCM_CDR (xorig)); } @@ -1053,8 +1046,7 @@ SCM_SYNTAX (s_nil_ify, "nil-ify", scm_makmmacro, scm_m_nil_ify); SCM scm_m_nil_ify (SCM xorig, SCM env) { - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, - xorig, scm_s_expression, "nil-ify"); + SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "nil-ify"); return scm_cons (SCM_IM_NIL_IFY, SCM_CDR (xorig)); } @@ -1063,8 +1055,7 @@ SCM_SYNTAX (s_t_ify, "t-ify", scm_makmmacro, scm_m_t_ify); SCM scm_m_t_ify (SCM xorig, SCM env) { - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, - xorig, scm_s_expression, "t-ify"); + SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "t-ify"); return scm_cons (SCM_IM_T_IFY, SCM_CDR (xorig)); } @@ -1074,8 +1065,7 @@ SCM scm_m_0_cond (SCM xorig, SCM env) { int len = scm_ilength (SCM_CDR (xorig)); - SCM_ASSYNT (len >= 1 && (len & 1) == 1, xorig, - scm_s_expression, "0-cond"); + SCM_ASSYNT (len >= 1 && (len & 1) == 1, scm_s_expression, "0-cond"); return scm_cons (SCM_IM_0_COND, SCM_CDR (xorig)); } @@ -1084,8 +1074,7 @@ SCM_SYNTAX (s_0_ify, "0-ify", scm_makmmacro, scm_m_0_ify); SCM scm_m_0_ify (SCM xorig, SCM env) { - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, - xorig, scm_s_expression, "0-ify"); + SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "0-ify"); return scm_cons (SCM_IM_0_IFY, SCM_CDR (xorig)); } @@ -1094,8 +1083,7 @@ SCM_SYNTAX (s_1_ify, "1-ify", scm_makmmacro, scm_m_1_ify); SCM scm_m_1_ify (SCM xorig, SCM env) { - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, - xorig, scm_s_expression, "1-ify"); + SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "1-ify"); return scm_cons (SCM_IM_1_IFY, SCM_CDR (xorig)); } @@ -1105,9 +1093,9 @@ SCM scm_m_atfop (SCM xorig, SCM env) { SCM x = SCM_CDR (xorig), vcell; - SCM_ASSYNT (scm_ilength (x) >= 1, xorig, scm_s_expression, "@fop"); + SCM_ASSYNT (scm_ilength (x) >= 1, scm_s_expression, "@fop"); vcell = scm_symbol_fref (SCM_CAR (x)); - SCM_ASSYNT (SCM_CONSP (vcell), x, + SCM_ASSYNT (SCM_CONSP (vcell), "Symbol's function definition is void", NULL); SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (vcell) + scm_tc3_cons_gloc); return x; @@ -1119,7 +1107,7 @@ SCM scm_m_atbind (SCM xorig, SCM env) { SCM x = SCM_CDR (xorig); - SCM_ASSYNT (scm_ilength (x) > 1, xorig, scm_s_expression, "@bind"); + SCM_ASSYNT (scm_ilength (x) > 1, scm_s_expression, "@bind"); if (SCM_IMP (env)) env = SCM_BOOL_F; @@ -1182,7 +1170,7 @@ scm_m_expand_body (SCM xorig, SCM env) } } - SCM_ASSYNT (SCM_NIMP (x), SCM_CDR (xorig), scm_s_body, what); + SCM_ASSYNT (SCM_NIMP (x), scm_s_body, what); if (SCM_NIMP (defs)) { x = scm_cons (scm_m_letrec1 (SCM_IM_LETREC, diff --git a/libguile/evalext.c b/libguile/evalext.c index d24a543be..22e0c2f36 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -59,7 +59,7 @@ SCM scm_m_generalized_set_x (SCM xorig, SCM env) { SCM x = SCM_CDR (xorig); - SCM_ASSYNT (2 == scm_ilength (x), xorig, scm_s_expression, scm_s_set_x); + SCM_ASSYNT (2 == scm_ilength (x), scm_s_expression, scm_s_set_x); if (SCM_SYMBOLP (SCM_CAR (x))) return scm_cons (SCM_IM_SET_X, x); else if (SCM_CONSP (SCM_CAR (x))) @@ -127,14 +127,14 @@ scm_m_undefine (SCM x, SCM env) { SCM arg1 = x; x = SCM_CDR (x); - SCM_ASSYNT (SCM_TOP_LEVEL (env), arg1, "bad placement ", s_undefine); + SCM_ASSYNT (SCM_TOP_LEVEL (env), "bad placement ", s_undefine); SCM_ASSYNT (SCM_CONSP (x) && SCM_NULLP (SCM_CDR (x)), - arg1, scm_s_expression, s_undefine); + scm_s_expression, s_undefine); x = SCM_CAR (x); - SCM_ASSYNT (SCM_SYMBOLP (x), arg1, scm_s_variable, s_undefine); + SCM_ASSYNT (SCM_SYMBOLP (x), scm_s_variable, s_undefine); arg1 = scm_sym2vcell (x, scm_env_top_level (env), SCM_BOOL_F); SCM_ASSYNT (SCM_NFALSEP (arg1) && !SCM_UNBNDP (SCM_CDR (arg1)), - x, "variable already unbound ", s_undefine); + "variable already unbound ", s_undefine); SCM_SETCDR (arg1, SCM_UNDEFINED); #ifdef SICP return SCM_CAR (arg1); diff --git a/libguile/goops.c b/libguile/goops.c index a79c13fb6..ff75a6395 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1869,7 +1869,7 @@ scm_m_atslot_ref (SCM xorig, SCM env) #define FUNC_NAME s_atslot_ref { SCM x = SCM_CDR (xorig); - SCM_ASSYNT (scm_ilength (x) == 2, xorig, scm_s_expression, FUNC_NAME); + SCM_ASSYNT (scm_ilength (x) == 2, scm_s_expression, FUNC_NAME); SCM_VALIDATE_INUM (SCM_ARG2, SCM_CADR (x)); return scm_cons (SCM_IM_SLOT_REF, x); } @@ -1883,7 +1883,7 @@ scm_m_atslot_set_x (SCM xorig, SCM env) #define FUNC_NAME s_atslot_set_x { SCM x = SCM_CDR (xorig); - SCM_ASSYNT (scm_ilength (x) == 3, xorig, scm_s_expression, FUNC_NAME); + SCM_ASSYNT (scm_ilength (x) == 3, scm_s_expression, FUNC_NAME); SCM_VALIDATE_INUM (SCM_ARG2, SCM_CADR (x)); return scm_cons (SCM_IM_SLOT_SET_X, x); } @@ -1899,7 +1899,7 @@ scm_m_atdispatch (SCM xorig, SCM env) #define FUNC_NAME s_atdispatch { SCM args, n, v, gf, x = SCM_CDR (xorig); - SCM_ASSYNT (scm_ilength (x) == 4, xorig, scm_s_expression, FUNC_NAME); + SCM_ASSYNT (scm_ilength (x) == 4, scm_s_expression, FUNC_NAME); args = SCM_CAR (x); if (!SCM_CONSP (args) && !SCM_SYMBOLP (args)) SCM_WRONG_TYPE_ARG (SCM_ARG1, args); diff --git a/libguile/macros.h b/libguile/macros.h index bd22a7b38..92436fe95 100644 --- a/libguile/macros.h +++ b/libguile/macros.h @@ -48,7 +48,7 @@ -#define SCM_ASSYNT(_cond, _arg, _msg, _subr) \ +#define SCM_ASSYNT(_cond, _msg, _subr) \ if (!(_cond)) scm_misc_error (_subr, _msg, SCM_EOL); extern scm_bits_t scm_tc16_macro; From e87a03fce7820f2146704b7ce5aa2c2a3f395b85 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 15 Mar 2001 11:24:45 +0000 Subject: [PATCH 0719/2047] * validate.h (SCM_VALIDATE_OPOUTSTRPORT): New macro. * strports.h (SCM_STRPORTP, SCM_OPSTRPORTP, SCM_OPINSTRPORTP), (SCM_OPOUTSTRPORTP): New predicate macros. (scm_open_input_string, scm_open_output_string), (scm_get_output_string): New prototypes. * strports.c (scm_open_input_string, scm_open_output_string), (scm_get_output_string): New procedures (SRFI-6 compliant). Made scm_tc16_strport non-static. --- libguile/ChangeLog | 13 +++++++++++++ libguile/strports.c | 46 +++++++++++++++++++++++++++++++++++++++++++-- libguile/strports.h | 19 +++++++++++++++++++ libguile/validate.h | 5 ++++- 4 files changed, 80 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 1577fbb2f..5e3a9b644 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,16 @@ +2001-03-15 Martin Grabmueller + + * validate.h (SCM_VALIDATE_OPOUTSTRPORT): New macro. + + * strports.h (SCM_STRPORTP, SCM_OPSTRPORTP, SCM_OPINSTRPORTP), + (SCM_OPOUTSTRPORTP): New predicate macros. + (scm_open_input_string, scm_open_output_string), + (scm_get_output_string): New prototypes. + + * strports.c (scm_open_input_string, scm_open_output_string), + (scm_get_output_string): New procedures (SRFI-6 compliant). + Made scm_tc16_strport non-static. + 2001-03-15 Dirk Herrmann * macros.h (SCM_ASSYNT): Removed unused object argument from diff --git a/libguile/strports.c b/libguile/strports.c index b72130ec7..299337d97 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -80,8 +80,7 @@ when rw_active is SCM_PORT_NEITHER. */ - -static scm_bits_t scm_tc16_strport; +scm_bits_t scm_tc16_strport; static int @@ -377,6 +376,49 @@ SCM_DEFINE (scm_call_with_input_string, "call-with-input-string", 2, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_open_input_string, "open-input-string", 1, 0, 0, + (SCM str), + "Takes a string and returns an input port that delivers\n" + "characters from the string. The port can be closed by\n" + "@code{close-input-port}, though its storage will be reclaimed\n" + "by the garbage collector if it becomes inaccessible.") +#define FUNC_NAME s_scm_open_input_string +{ + SCM p = scm_mkstrport(SCM_INUM0, str, SCM_OPN | SCM_RDNG, FUNC_NAME); + return p; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_open_output_string, "open-output-string", 0, 0, 0, + (void), + "Returns an output port that will accumulate characters for\n" + "retrieval by @code{get-output-string}. The port can be closed\n" + "by the procedure @code{close-output-port}, though its storage\n" + "will be reclaimed by the garbage collector if it becomes\n" + "inaccessible.") +#define FUNC_NAME s_scm_open_output_string +{ + SCM p; + + p = scm_mkstrport (SCM_INUM0, + scm_make_string (SCM_INUM0, SCM_UNDEFINED), + SCM_OPN | SCM_WRTNG, + FUNC_NAME); + return p; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_get_output_string, "get-output-string", 1, 0, 0, + (SCM port), + "Given an output port created by @code{open-output-string},\n" + "returns a string consisting of the characters that have been\n" + "output to the port so far.") +#define FUNC_NAME s_scm_get_output_string +{ + SCM_VALIDATE_OPOUTSTRPORT (1, port); + return scm_strport_to_string (port); +} +#undef FUNC_NAME /* Given a null-terminated string EXPR containing a Scheme expression diff --git a/libguile/strports.h b/libguile/strports.h index 6767bd2b7..9388c2dcd 100644 --- a/libguile/strports.h +++ b/libguile/strports.h @@ -48,11 +48,30 @@ + +#define SCM_STRPORTP(x) (!SCM_IMP (x) && \ + (SCM_TYP16 (x) == scm_tc16_strport)) +#define SCM_OPSTRPORTP(x) (SCM_STRPORTP (x) && \ + (SCM_CELL_WORD_0 (x) & SCM_OPN)) +#define SCM_OPINSTRPORTP(x) (SCM_OPSTRPORTP (x) && \ + (SCM_CELL_WORD_0 (x) & SCM_RDNG)) +#define SCM_OPOUTSTRPORTP(x) (SCM_OPSTRPORTP (x) && \ + (SCM_CELL_WORD_0 (x) & SCM_WRTNG)) + + + +extern scm_bits_t scm_tc16_strport; + + + extern SCM scm_mkstrport (SCM pos, SCM str, long modes, const char * caller); extern SCM scm_strport_to_string (SCM port); extern SCM scm_object_to_string (SCM obj, SCM printer); extern SCM scm_call_with_output_string (SCM proc); extern SCM scm_call_with_input_string (SCM str, SCM proc); +extern SCM scm_open_input_string (SCM str); +extern SCM scm_open_output_string (void); +extern SCM scm_get_output_string (SCM port); extern SCM scm_read_0str (char *expr); extern SCM scm_eval_0str (const char *expr); extern SCM scm_eval_string (SCM string); diff --git a/libguile/validate.h b/libguile/validate.h index 87fdb716b..969b412ad 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -1,4 +1,4 @@ -/* $Id: validate.h,v 1.27 2001-03-04 22:48:13 dirk Exp $ */ +/* $Id: validate.h,v 1.28 2001-03-15 11:24:45 mgrabmue Exp $ */ /* Copyright (C) 1999, 2000 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify @@ -359,6 +359,9 @@ #define SCM_VALIDATE_OPOUTPORT(pos, port) \ SCM_MAKE_VALIDATE (pos, port, OPOUTPORTP) +#define SCM_VALIDATE_OPOUTSTRPORT(pos, port) \ + SCM_MAKE_VALIDATE (pos, port, OPOUTSTRPORTP) + #define SCM_VALIDATE_FLUID(pos, fluid) SCM_MAKE_VALIDATE (pos, fluid, FLUIDP) #define SCM_VALIDATE_KEYWORD(pos, v) SCM_MAKE_VALIDATE (pos, v, KEYWORDP) From 62e63ba927fd98bd9ffa1acd6677ddc5bc7a7b3c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 15 Mar 2001 11:39:01 +0000 Subject: [PATCH 0720/2047] Document new procedures open-input-string open-output-string get-output-string --- NEWS | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/NEWS b/NEWS index cc6190050..0a7b8eac8 100644 --- a/NEWS +++ b/NEWS @@ -401,6 +401,21 @@ Set/remove an advisory shared or exclusive lock on `file'. Set or get the hostname of the machine the current process is running on. +** New function: open-input-string string + +Return an input string port which delivers the characters from +`string'. This procedure, together with `open-input-string' and +`get-output-string' implements SRFI-6. + +** New function: open-output-string + +Return an output string port which collects all data written to it. +The data can then be retrieved by `get-output-string'. + +** New function: get-output-string + +Return the contents of an output string port. + ** Deprecated: close-all-ports-except. This was intended for closing ports in a child process after a fork, but it has the undesirable side effect of flushing buffers. port-for-each is more flexible. From 5345cf7caed5bb1c2ce0772e35df5cf75b61dee1 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 15 Mar 2001 19:21:51 +0000 Subject: [PATCH 0721/2047] * numbers.c (scm_num2ulong): Check that a bignum is positive before looking at the magnitude. Correctly check for overflow during conversion. --- libguile/numbers.c | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 8841dbd50..65d7898cc 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -4472,16 +4472,15 @@ scm_num2ulong (SCM num, char *pos, const char *s_caller) } } else if (SCM_BIGP (num)) { unsigned long int res = 0; - unsigned long int old_res = 0; scm_sizet l; + if (SCM_BIGSIGN (num)) + scm_out_of_range (s_caller, num); + for (l = SCM_NUMDIGS (num); l--;) { - res = SCM_BIGUP (res) + SCM_BDIGITS (num)[l]; - if (res >= old_res) { - old_res = res; - } else { + if (res > SCM_BIGDN(ULONG_MAX)) scm_out_of_range (s_caller, num); - } + res = SCM_BIGUP (res) + SCM_BDIGITS (num)[l]; } return res; } else if (SCM_REALP (num)) { From caf08e652ee9bbb201d2152632d11d1f8ac0e1b3 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 15 Mar 2001 20:04:41 +0000 Subject: [PATCH 0722/2047] * numbers.c (scm_num2ulong): Check that a bignum is positive before looking at the magnitude. Correctly check for overflow during conversion. (scm_num2long_long): Likewise. (scm_num2ulong_long): New. (ULONG_LONG_MAX): Define if not already defined. * numbers.h: (scm_num2ulong_long): New prototype. --- libguile/numbers.c | 52 +++++++++++++++++++++++++++++++++++++++------- libguile/numbers.h | 2 ++ 2 files changed, 47 insertions(+), 7 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 65d7898cc..644249ea9 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -4408,6 +4408,10 @@ scm_num2long (SCM num, char *pos, const char *s_caller) #ifdef HAVE_LONG_LONGS +#ifndef ULONG_LONG_MAX +#define ULONG_LONG_MAX (~0ULL) +#endif + long_long scm_num2long_long (SCM num, char *pos, const char *s_caller) { @@ -4417,17 +4421,12 @@ scm_num2long_long (SCM num, char *pos, const char *s_caller) long long res; /* can't use res directly in case num is -2^63. */ unsigned long long int pos_res = 0; - unsigned long long int old_res = 0; scm_sizet l; for (l = SCM_NUMDIGS (num); l--;) { - pos_res = SCM_LONGLONGBIGUP (pos_res) + SCM_BDIGITS (num)[l]; - if (pos_res >= old_res) { - old_res = pos_res; - } else { - /* overflow. */ + if (pos_res > SCM_BIGDN(ULONG_LONG_MAX)) scm_out_of_range (s_caller, num); - } + pos_res = SCM_LONGLONGBIGUP (pos_res) + SCM_BDIGITS (num)[l]; } if (SCM_BIGSIGN (num)) { res = -pos_res; @@ -4457,6 +4456,45 @@ scm_num2long_long (SCM num, char *pos, const char *s_caller) } } +ulong_long +scm_num2ulong_long (SCM num, char *pos, const char *s_caller) +{ + if (SCM_INUMP (num)) + { + long long nnum = SCM_INUM (num); + if (nnum >= 0) + return nnum; + else + scm_out_of_range (s_caller, num); + } + else if (SCM_BIGP (num)) + { + unsigned long long res = 0; + scm_sizet l; + + if (SCM_BIGSIGN (num)) + scm_out_of_range (s_caller, num); + + for (l = SCM_NUMDIGS (num); l--;) { + if (res > SCM_BIGDN(ULONG_LONG_MAX)) + scm_out_of_range (s_caller, num); + res = SCM_LONGLONGBIGUP (res) + SCM_BDIGITS (num)[l]; + } + return res; + } + else if (SCM_REALP (num)) + { + double u = SCM_REAL_VALUE (num); + unsigned long long int res = u; + if ((double) res == u) + return res; + else + scm_out_of_range (s_caller, num); + } + else + scm_wrong_type_arg (s_caller, (int) pos, num); +} + #endif /* HAVE_LONG_LONGS */ diff --git a/libguile/numbers.h b/libguile/numbers.h index d5b2809e7..076768e33 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -295,6 +295,8 @@ extern long scm_num2long (SCM num, char *pos, const char *s_caller); extern SCM scm_long_long2num (long_long sl); extern long_long scm_num2long_long (SCM num, char *pos, const char *s_caller); +extern ulong_long scm_num2ulong_long (SCM num, char *pos, + const char *s_caller); #endif extern unsigned long scm_num2ulong (SCM num, char *pos, const char *s_caller); From 6d583887bb271c1c2f45bd95f00fb800dc12b47f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 15 Mar 2001 20:04:56 +0000 Subject: [PATCH 0723/2047] *** empty log message *** --- libguile/ChangeLog | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 5e3a9b644..d16c901d1 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,13 @@ +2001-03-15 Marius Vollmer + + * numbers.c (scm_num2ulong): Check that a bignum is positive + before looking at the magnitude. Correctly check for overflow + during conversion. + (scm_num2long_long): Likewise. + (scm_num2ulong_long): New. + (ULONG_LONG_MAX): Define if not already defined. + * numbers.h: (scm_num2ulong_long): New prototype. + 2001-03-15 Martin Grabmueller * validate.h (SCM_VALIDATE_OPOUTSTRPORT): New macro. From a9205f0774ca610a10c7e3d04af53b8270b12db6 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 16 Mar 2001 05:11:34 +0000 Subject: [PATCH 0724/2047] * snarf.h (SCM_CONST_LONG): Deprecated. * tag.c (CONST_INUM): New macro. Use it to define scm_utag_*. --- libguile/ChangeLog | 5 ++++ libguile/snarf.h | 4 +++ libguile/tag.c | 67 ++++++++++++++++++++++++---------------------- 3 files changed, 44 insertions(+), 32 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d16c901d1..dcda0213f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-03-16 Keisuke Nishida + + * snarf.h (SCM_CONST_LONG): Deprecated. + * tag.c (CONST_INUM): New macro. Use it to define scm_utag_*. + 2001-03-15 Marius Vollmer * numbers.c (scm_num2ulong): Check that a bignum is positive diff --git a/libguile/snarf.h b/libguile/snarf.h index 436454427..d6bcaa2be 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -183,9 +183,13 @@ SCM_SNARF_INIT(c_name = scm_permanent_object (scm_sysintern (scheme_name, init_v SCM_SNARF_HERE(SCM c_name) \ SCM_SNARF_INIT(c_name = scm_permanent_object (scm_sysintern (scheme_name, init_val));) +#if (SCM_DEBUG_DEPRECATED == 0) + #define SCM_CONST_LONG(c_name, scheme_name,value) \ SCM_VCELL_INIT(c_name, scheme_name, scm_long2num(value)) +#endif /* (SCM_DEBUG_DEPRECATED == 0) */ + #ifdef SCM_MAGIC_SNARFER #undef SCM_ASSERT #define SCM_ASSERT(_cond, _arg, _pos, _subr) *&*&*&*SCM_ARG_BETTER_BE_IN_POSITION(_arg,_pos,__LINE__) diff --git a/libguile/tag.c b/libguile/tag.c index 095572d1a..f82731977 100644 --- a/libguile/tag.c +++ b/libguile/tag.c @@ -50,42 +50,45 @@ #include "libguile/tag.h" -SCM_CONST_LONG (scm_utag_immediate_integer, "utag_immediate_integer", 0); -SCM_CONST_LONG (scm_utag_immediate_char, "utag_immediate_char", 1); -SCM_CONST_LONG (scm_utag_pair, "utag_pair", 2); -SCM_CONST_LONG (scm_utag_closure, "utag_closure", 3); -SCM_CONST_LONG (scm_utag_symbol, "utag_symbol", 4); -SCM_CONST_LONG (scm_utag_vector, "utag_vector", 5); -SCM_CONST_LONG (scm_utag_wvect, "utag_wvect", 6); +#define CONST_INUM(c_name, scheme_name, value) \ +SCM_VCELL_INIT(c_name, scheme_name, SCM_MAKINUM (value)) + +CONST_INUM (scm_utag_immediate_integer, "utag_immediate_integer", 0); +CONST_INUM (scm_utag_immediate_char, "utag_immediate_char", 1); +CONST_INUM (scm_utag_pair, "utag_pair", 2); +CONST_INUM (scm_utag_closure, "utag_closure", 3); +CONST_INUM (scm_utag_symbol, "utag_symbol", 4); +CONST_INUM (scm_utag_vector, "utag_vector", 5); +CONST_INUM (scm_utag_wvect, "utag_wvect", 6); #ifdef HAVE_ARRAYS -SCM_CONST_LONG (scm_utag_bvect, "utag_bvect", 7); -SCM_CONST_LONG (scm_utag_byvect, "utag_byvect", 8); -SCM_CONST_LONG (scm_utag_svect, "utag_svect", 9); -SCM_CONST_LONG (scm_utag_ivect, "utag_ivect", 10); -SCM_CONST_LONG (scm_utag_uvect, "utag_uvect", 11); -SCM_CONST_LONG (scm_utag_fvect, "utag_fvect", 12); -SCM_CONST_LONG (scm_utag_dvect, "utag_dvect", 13); -SCM_CONST_LONG (scm_utag_cvect, "utag_cvect", 14); +CONST_INUM (scm_utag_bvect, "utag_bvect", 7); +CONST_INUM (scm_utag_byvect, "utag_byvect", 8); +CONST_INUM (scm_utag_svect, "utag_svect", 9); +CONST_INUM (scm_utag_ivect, "utag_ivect", 10); +CONST_INUM (scm_utag_uvect, "utag_uvect", 11); +CONST_INUM (scm_utag_fvect, "utag_fvect", 12); +CONST_INUM (scm_utag_dvect, "utag_dvect", 13); +CONST_INUM (scm_utag_cvect, "utag_cvect", 14); #endif -SCM_CONST_LONG (scm_utag_string, "utag_string", 15); -SCM_CONST_LONG (scm_utag_substring, "utag_substring", 17); -SCM_CONST_LONG (scm_utag_asubr, "utag_asubr", 19); -SCM_CONST_LONG (scm_utag_subr_0, "utag_subr_0", 20); -SCM_CONST_LONG (scm_utag_subr_1, "utag_subr_1", 21); -SCM_CONST_LONG (scm_utag_cxr, "utag_cxr", 22); -SCM_CONST_LONG (scm_utag_subr_3, "utag_subr_3", 23); -SCM_CONST_LONG (scm_utag_subr_2, "utag_subr_2", 24); -SCM_CONST_LONG (scm_utag_rpsubr, "utag_rpsubr", 25); -SCM_CONST_LONG (scm_utag_subr_1o, "utag_subr_1o", 26); -SCM_CONST_LONG (scm_utag_subr_2o, "utag_subr_2o", 27); -SCM_CONST_LONG (scm_utag_lsubr_2, "utag_lsubr_2", 28); -SCM_CONST_LONG (scm_utag_lsubr, "utag_lsubr", 29); -SCM_CONST_LONG (scm_utag_smob_base, "utag_smob_base", 252); -SCM_CONST_LONG (scm_utag_port_base, "utag_port_base", 253); -SCM_CONST_LONG (scm_utag_flag_base, "utag_flag_base", 254); -SCM_CONST_LONG (scm_utag_struct_base, "utag_struct_base", 255); +CONST_INUM (scm_utag_string, "utag_string", 15); +CONST_INUM (scm_utag_substring, "utag_substring", 17); +CONST_INUM (scm_utag_asubr, "utag_asubr", 19); +CONST_INUM (scm_utag_subr_0, "utag_subr_0", 20); +CONST_INUM (scm_utag_subr_1, "utag_subr_1", 21); +CONST_INUM (scm_utag_cxr, "utag_cxr", 22); +CONST_INUM (scm_utag_subr_3, "utag_subr_3", 23); +CONST_INUM (scm_utag_subr_2, "utag_subr_2", 24); +CONST_INUM (scm_utag_rpsubr, "utag_rpsubr", 25); +CONST_INUM (scm_utag_subr_1o, "utag_subr_1o", 26); +CONST_INUM (scm_utag_subr_2o, "utag_subr_2o", 27); +CONST_INUM (scm_utag_lsubr_2, "utag_lsubr_2", 28); +CONST_INUM (scm_utag_lsubr, "utag_lsubr", 29); +CONST_INUM (scm_utag_smob_base, "utag_smob_base", 252); +CONST_INUM (scm_utag_port_base, "utag_port_base", 253); +CONST_INUM (scm_utag_flag_base, "utag_flag_base", 254); +CONST_INUM (scm_utag_struct_base, "utag_struct_base", 255); #if (SCM_DEBUG_DEPRECATED == 0) From 8dea8611e33a7a074a00158d90746967e8c23e4e Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 16 Mar 2001 05:12:02 +0000 Subject: [PATCH 0725/2047] Deprecated macro SCM_CONST_LONG. --- NEWS | 3 ++- RELEASE | 1 + 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index 0a7b8eac8..f6e2e1da1 100644 --- a/NEWS +++ b/NEWS @@ -572,7 +572,7 @@ SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR, SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING, SCM_ROCHARS, SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS, SCM_LENGTH_MAX, SCM_GC8MARKP, SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR, SCM_SUBR_DOC, -SCM_OPDIRP, SCM_VALIDATE_OPDIR, SCM_WTA, RETURN_SCM_WTA +SCM_OPDIRP, SCM_VALIDATE_OPDIR, SCM_WTA, RETURN_SCM_WTA, SCM_CONST_LONG Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of SCM_OUTOFRANGE. Use scm_memory_error instead of SCM_NALLOC. @@ -599,6 +599,7 @@ Use SCM_CDR instead of SCM_GCCDR. Use SCM_DIR_OPEN_P instead of SCM_OPDIRP. Use SCM_MISC_ERROR or SCM_WRONG_TYPE_ARG instead of SCM_WTA. Use SCM_MISC_ERROR or SCM_WRONG_TYPE_ARG instead of RETURN_SCM_WTA. +Use SCM_VCELL_INIT instead of SCM_CONST_LONG. ** Removed function: scm_struct_init diff --git a/RELEASE b/RELEASE index 8e797adf0..70c1f8f28 100644 --- a/RELEASE +++ b/RELEASE @@ -79,6 +79,7 @@ In release 1.6: interactive use it would be easy to load the module in ~/.guile. - remove scm_close_all_ports_except - remove scm_strprint_obj +- remove SCM_CONST_LONG Modules sort.c and random.c should be factored out into separate modules (but still be distributed with guile-core) when we get a new From 1543613f4bb8576a9630c724b0c896355171322b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 16 Mar 2001 08:37:37 +0000 Subject: [PATCH 0726/2047] * modules: New directory. * modules/module-layout.text: New file. --- devel/ChangeLog | 6 + devel/modules/module-layout.text | 288 +++++++++++++++++++++++++++++++ 2 files changed, 294 insertions(+) create mode 100644 devel/modules/module-layout.text diff --git a/devel/ChangeLog b/devel/ChangeLog index 96e17f8ee..4760a3aa8 100644 --- a/devel/ChangeLog +++ b/devel/ChangeLog @@ -1,3 +1,9 @@ +2001-03-16 Martin Grabmueller + + * modules: New directory. + + * modules/module-layout.text: New file. + 2000-08-26 Mikael Djurfeldt * strings: New directory. diff --git a/devel/modules/module-layout.text b/devel/modules/module-layout.text new file mode 100644 index 000000000..c088ad822 --- /dev/null +++ b/devel/modules/module-layout.text @@ -0,0 +1,288 @@ +Module Layout Proposal +====================== + +Martin Grabmueller + +Draft: 2001-03-11 + +Version: $Id: module-layout.text,v 1.1 2001-03-16 08:37:37 mgrabmue Exp $ + +* Table of contents + +** Abstract +** Overview +*** What do we have now? +*** What should we change? +** Policy of module separation +*** Functionality +*** Standards +*** Importance +*** Compatibility +** Module naming +*** Scheme +*** Object oriented programming +*** Systems programming +*** Database programming +*** Text processing +*** Math programming +*** Network programming +*** Graphics +*** GTK+ programming +*** X programming +*** Games +*** Multiple names +*** Application modules +** Future ideas + + +* Abstract + +This is a proposal for a new layout of the module name space. The +goal is to reduce (or even eliminate) the clutter in the current ice-9 +module directory, and to provide a clean framework for splitting +libguile into subsystems, grouped by functionality, standards +compliance and maybe other characteristics. + +This is not a completed policy document, but rather a collection of +ideas and proposals which still have to be decided. I will mention by +personal preference, where appropriate, but the final decisions are of +course up to the maintainers. + + +* Overview + +Currently, new modules are added in an ad-hoc manner to the ice-9 +module name space when the need for them arises. I think that was +mainly because no other directory for installed Scheme modules was +created. With the integration of GOOPS, the new top-level module +directory oop was introduced, and we should follow this practice for +other subsystems which share functionality. + +DISCLAIMER: Please note that I am no expert on Guile's module system, +so be patient with me and correct me where I got anything wrong. + +** What do we have now? + +The module (oop goops) contains all functionality needed for +object-oriented programming with Guile (with a few exceptions in the +evaluator, which is clearly needed for performance). + +Except for the procedures in the module (ice-9 rdelim), all Guile +primitives are currently located in the root module (I think it is the +module (guile)), and some procedures defined in `boot-9.scm' are +installed in the module (guile-user). + +** What should we change? + +In the core, there are a lot of primitive procedures which can cleanly +be grouped into subsystems, and then grouped into modules. That would +make the core library more maintainable, would ease seperate testing +of subsystems and clean up dependencies between subsystems. + + +* Policy of module separation + +There are several possibilities to group procedures into modules. + +- They could be grouped by functionality. +- They could be grouped by standards compliance. +- They could be grouped by level of importance. + +One important group of modules should of course be provided +additionally: + +- Compatibility modules. + +So the first thing to decide is: Which of these policies should we +adopt? Personally, I think that it is not possible to cleanly use +exactly one of the possibilities, we will probably use a mixture of +them. I propose to group by functionality, and maybe use some +`bridge-modules', which make functionality available when the user +requests the modules for a given standard. + +** Functionality + +Candidates for the first possibility are groups of procedures, which +already are grouped in source files, such as + +- Regular expression procedures. +- Network procedures. +- Systems programming procedures. +- Random number procedures. +- Math/numeric procedures. +- String-processing procedures. +- List-processing procedures. +- Character handling procedures. +- Object-oriented programming support. + +** Standards + +Guile now complies to R5RS, and I think that the procedures required +by this standards should always be available to the programmer. +People who do not want them, could always create :pure modules when +they need it. + +On the other hand, the SRFI procedures fit nicely into a `group by +standards' scheme. An example which is already provided, is the +SRFI-8 syntax `receive'. Following that, we could provide two modules +for each SRFI, one named after the SRFI (like `srfi-8') and one named +after the main functionality (`receive'). + +** Importance + +By importance, I mean `how important are procedures for the average +Guile user'. That means that procedures which are only useful to a +small group of users (the Guile developers, for example) should not be +immediately available at the REPL, so that they not confuse the user +when thay appear in the `apropos' output or the tab completion. + +A good example would be debugging procedures (which also could be +added with a special command-line option), or low-level system calls. + +** Compatibility + +This group is for modules providing compatibility procedures. An +example would be a module for old string-processing procedures, which +could someday get overridden by incompatible SRFI procedures of the +same name. + + +* Module naming + +Provided we choose to take the `group by functionality' approach, I +propose the following naming hierarchy (some of them were actually +suggested by Mikael Djurfeldt). + +- Schame language related in (scheme) +- Object oriented programming in (oop) +- Systems programming in (system) +- Database programming in (database) +- Text processing in (text) +- Math/numeric programming in (math) +- Network programming in (network) +- Graphics programming in (graphics) +- GTK+ programming in (gtk) +- X programming in (xlib) +- Games in (games) + +The layout of sub-hierarchies is up to the writers of modules, we +should not enforce a strict policy here, because we can not imagine +what will happen in this area. + +** Scheme + +(scheme r5rs) Complete R5RS procedures set. +(scheme safe) Safe modules. +(scheme srfi-1) List processing. +(scheme srfi-8) Multiple valuas via `receive'. +(scheme receive) dito. +(scheme and-let-star) and-let* +(scheme syncase) syntax-case hygienic macros (maybe included in + (scheme r5rs?). +(scheme slib) SLIB, for historic reasons in (scheme). + +** Object oriented programming + +Examples in this section are +(oop goops) For GOOPS. +(oop goops ...) For lower-level GOOPS functionality and utilities. + +** Systems programming + +(system shell) Shell utilities (glob, system etc). +(system process) Process handling. +(system file-system) Low-level filesystem support. +(system user) getuid, setpgrp, etc. + +_or_ + +(system posix) All posix procedures. + +** Database programming + +In the database section, there should be sub-module hierarchies for +each supported database which contains the low-level code, and a +common database layer, which should unify access to SQL databases via a single interface a la Perl's DBMI. + +(database postgres ...) Low-level database functionality. +(database oracle ...) ... +(database mysql ...) ... +(database msql ...) ... +(database sql) Common SQL accessors. +(database gdbm ...) ... +(database hashed) Common hashed database accessors (like gdbm). +(database util) Leftovers. + +** Text processing + +(text rdelim) Line oriented in-/output. +(text util) Mangling text files. + +** Math programming + +(math random) Random numbers. +(math primes) Prime numbers. +(math vector) Vector math. +(math algebra) Algebra. +(math analysis) Analysis. +(math util) Leftovers. + +** Network programming + +(network inet) Internet procedures. +(network socket) Socket interface. +(network db) Network database accessors. +(network util) ntohl, htons and friends. + +** Graphics + +(graphics vector) Generalized vector graphics handling. +(graphics vector vrml) VRML parsers etc. +(graphisc bitmap) Generalized bitmap handling. +(graphics bitmap ...) Bitmap format handling (TIFF, PNG, etc.). + +** GTK+ programming + +(gtk gtk) GTK+ procedures. +(gtk gdk) GDK procedures. +(gtk threads) gtktreads. + +** X programming + +(xlib xlib) Low-level XLib programming. + +** Games + +(games robots) GNU robots. + +** Multiple names + +As already mentioned above, I think that some modules should have +several names, to make it easier for the user to get the functionality +she needs. For example, a user could say: `hey, I need the receive +macro', or she could say: `I want to stick to SRFI syntax, so where +the hell is the module for SRFI-8?!?'. + +** Application modules + +We should not enforce policy on applications. So I propose that +application writers should be advised to place modules either in +application-specific directories $PREFIX/share/$APP/guile/... and name +that however they like, or to use the application's name as the first +part of the module name, e.g (gnucash import), (scwm background), +(rcalc ui). + +* Future ideas + +I have not yet come up with a good idea for grouping modules, which +deal for example with XML processing. They would fit into the (text) +module space, because most XML files contain text data, but they would +also fit into (database), because XML files are essentially databases. + +On the other hand, XML processing is such a large field that it +probably is worth it's own top-level name space (xml). + + +Local Variables: +mode: outline +End: From 5352393c556ff4e4be85cacf4b6dd32e93b24bce Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 16 Mar 2001 10:00:17 +0000 Subject: [PATCH 0727/2047] * list.c (scm_list, scm_cons_star, scm_null_p, scm_list_p), (scm_length, scm_append, scm_reverse, scm_list_ref), (scm_memq, scm_memv, scm_member, scm_delv_x, scm_delete_x), (scm_delq, scm_delv, scm_delete, scm_delq1_x, scm_delv1_x), (scm_delete1_x), gc.c (scm_map_free_list), (scm_free_list_length), hash.c (scm_hashq, scm_hashv), (scm_hash), hashtab.c (scm_hashq_ref, scm_hashq_set_x), (scm_hashq_remove_x, scm_hashv_ref, scm_hashv_set_x), (scm_hashv_remove_x, scm_hash_ref, scm_hash_set_x), (scm_hash_remove_x), ports.c (scm_pt_size, scm_pt_member), print.c (scm_current_pstate), scmsigs.c (scm_usleep), goops.c (scm_get_keyword, scm_sys_compute_slots): Added texinfo markup. * weaks.c (scm_weak_vector_p, scm_weak_key_hash_table_p), (scm_weak_value_hash_table_p, scm_doubly_weak_hash_table_p), rdelim.c (scm_read_delimited_x), strop.c (scm_string_index), symbols.c (scm_symbol_interned_p), numbers.c (scm_string_to_number), ports.c (scm_port_p): Corrected texinfo markup. --- libguile/ChangeLog | 22 ++++++++ libguile/gc.c | 10 ++-- libguile/goops.c | 17 +++--- libguile/hash.c | 46 ++++++++-------- libguile/hashtab.c | 37 ++++++------- libguile/list.c | 131 ++++++++++++++++++++++++--------------------- libguile/numbers.c | 12 ++--- libguile/ports.c | 14 ++--- libguile/print.c | 5 +- libguile/rdelim.c | 26 ++++----- libguile/scmsigs.c | 4 +- libguile/strop.c | 18 ++++--- libguile/symbols.c | 17 +++--- libguile/weaks.c | 14 ++--- 14 files changed, 210 insertions(+), 163 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index dcda0213f..27198224f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,25 @@ +2001-03-16 Martin Grabmueller + + * list.c (scm_list, scm_cons_star, scm_null_p, scm_list_p), + (scm_length, scm_append, scm_reverse, scm_list_ref), + (scm_memq, scm_memv, scm_member, scm_delv_x, scm_delete_x), + (scm_delq, scm_delv, scm_delete, scm_delq1_x, scm_delv1_x), + (scm_delete1_x), gc.c (scm_map_free_list), + (scm_free_list_length), hash.c (scm_hashq, scm_hashv), + (scm_hash), hashtab.c (scm_hashq_ref, scm_hashq_set_x), + (scm_hashq_remove_x, scm_hashv_ref, scm_hashv_set_x), + (scm_hashv_remove_x, scm_hash_ref, scm_hash_set_x), + (scm_hash_remove_x), ports.c (scm_pt_size, scm_pt_member), print.c + (scm_current_pstate), scmsigs.c (scm_usleep), goops.c + (scm_get_keyword, scm_sys_compute_slots): Added texinfo markup. + + * weaks.c (scm_weak_vector_p, scm_weak_key_hash_table_p), + (scm_weak_value_hash_table_p, scm_doubly_weak_hash_table_p), + rdelim.c (scm_read_delimited_x), strop.c (scm_string_index), + symbols.c (scm_symbol_interned_p), numbers.c + (scm_string_to_number), ports.c (scm_port_p): Corrected texinfo + markup. + 2001-03-16 Keisuke Nishida * snarf.h (SCM_CONST_LONG): Deprecated. diff --git a/libguile/gc.c b/libguile/gc.c index 9fe4e0a8a..264b9f3be 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -515,8 +515,9 @@ map_free_list (scm_freelist_t *master, SCM freelist) SCM_DEFINE (scm_map_free_list, "map-free-list", 0, 0, 0, (), - "Print debugging information about the free-list.\n" - "`map-free-list' is only included in --enable-guile-debug builds of Guile.") + "Print debugging information about the free-list.\n" + "@code{map-free-list} is only included in\n" + "@code{--enable-guile-debug} builds of Guile.") #define FUNC_NAME s_scm_map_free_list { int i; @@ -595,8 +596,9 @@ free_list_lengths (char *title, scm_freelist_t *master, SCM freelist) SCM_DEFINE (scm_free_list_length, "free-list-length", 0, 0, 0, (), - "Print debugging information about the free-list.\n" - "`free-list-length' is only included in --enable-guile-debug builds of Guile.") + "Print debugging information about the free-list.\n" + "@code{free-list-length} is only included in\n" + "@code{--enable-guile-debug} builds of Guile.") #define FUNC_NAME s_scm_free_list_length { free_list_lengths ("1-cells", &scm_master_freelist, scm_freelist); diff --git a/libguile/goops.c b/libguile/goops.c index ff75a6395..f63a4a42f 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -285,9 +285,9 @@ maplist (SCM ls) SCM_DEFINE (scm_sys_compute_slots, "%compute-slots", 1, 0, 0, (SCM class), - "Return a list consisting of the names of all slots belonging\n" - "to class CLASS, i. e. the slots of CLASS and of all of its\n" - "superclasses.") + "Return a list consisting of the names of all slots belonging to\n" + "class @var{class}, i. e. the slots of @var{class} and of all of\n" + "its superclasses.") #define FUNC_NAME s_scm_sys_compute_slots { SCM_VALIDATE_CLASS (1, class); @@ -367,11 +367,12 @@ scm_i_get_keyword (SCM key, SCM l, int len, SCM default_value, const char *subr) SCM_DEFINE (scm_get_keyword, "get-keyword", 3, 0, 0, (SCM key, SCM l, SCM default_value), - "Determine an associated value for the keyword KEY from the\n" - "list L. The list L has to consist of an even number of\n" - "elements, where, starting with the first, every second element\n" - "is a keyword, followed by its associated value. If L does not\n" - "hold a value for KEY, the value DEFAULT_VALUE is returned.") + "Determine an associated value for the keyword @var{key} from\n" + "the list @var{l}. The list @var{l} has to consist of an even\n" + "number of elements, where, starting with the first, every\n" + "second element is a keyword, followed by its associated value.\n" + "If @var{l} does not hold a value for @var{key}, the value\n" + "@var{default_value} is returned.") #define FUNC_NAME s_scm_get_keyword { int len; diff --git a/libguile/hash.c b/libguile/hash.c index f2bb819ec..4bc40d291 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -190,15 +190,16 @@ scm_ihashq (SCM obj, unsigned int n) SCM_DEFINE (scm_hashq, "hashq", 2, 0, 0, (SCM key, SCM size), - "Determine a hash value for KEY that is suitable for lookups in\n" - "a hashtable of size SIZE, where eq? is used as the equality\n" - "predicate. The function returns an integer in the range 0 to\n" - "SIZE - 1. NOTE that `hashq' may use internal addresses.\n" - "Thus two calls to hashq where the keys are eq? are not\n" - "guaranteed to deliver the same value if the key object gets\n" - "garbage collected in between. This can happen, for example\n" - "with symbols: (hashq 'foo n) (gc) (hashq 'foo n) may produce two\n" - "different values, since 'foo will be garbage collected.") + "Determine a hash value for @var{key} that is suitable for\n" + "lookups in a hashtable of size @var{size}, where @code{eq?} is\n" + "used as the equality predicate. The function returns an\n" + "integer in the range 0 to @var{size} - 1. Note that\n" + "@code{hashq} may use internal addresses. Thus two calls to\n" + "hashq where the keys are @code{eq?} are not guaranteed to\n" + "deliver the same value if the key object gets garbage collected\n" + "in between. This can happen, for example with symbols:\n" + "@code{(hashq 'foo n) (gc) (hashq 'foo n)} may produce two\n" + "different values, since @code{foo} will be garbage collected.") #define FUNC_NAME s_scm_hashq { SCM_VALIDATE_INUM_MIN (2, size, 0); @@ -225,15 +226,16 @@ scm_ihashv (SCM obj, unsigned int n) SCM_DEFINE (scm_hashv, "hashv", 2, 0, 0, (SCM key, SCM size), - "Determine a hash value for KEY that is suitable for lookups in\n" - "a hashtable of size SIZE, where eqv? is used as the equality\n" - "predicate. The function returns an integer in the range 0 to\n" - "SIZE - 1. NOTE that (hashv key) may use internal addresses.\n" - "Thus two calls to hashv where the keys are eqv? are not\n" - "guaranteed to deliver the same value if the key object gets\n" - "garbage collected in between. This can happen, for example\n" - "with symbols: (hashv 'foo n) (gc) (hashv 'foo n) may produce two\n" - "different values, since 'foo will be garbage collected.") + "Determine a hash value for @var{key} that is suitable for\n" + "lookups in a hashtable of size @var{size}, where @code{eqv?} is\n" + "used as the equality predicate. The function returns an\n" + "integer in the range 0 to @var{size} - 1. Note that\n" + "@code{(hashv key)} may use internal addresses. Thus two calls\n" + "to hashv where the keys are @code{eqv?} are not guaranteed to\n" + "deliver the same value if the key object gets garbage collected\n" + "in between. This can happen, for example with symbols:\n" + "@code{(hashv 'foo n) (gc) (hashv 'foo n)} may produce two\n" + "different values, since @code{foo} will be garbage collected.") #define FUNC_NAME s_scm_hashv { SCM_VALIDATE_INUM_MIN (2, size, 0); @@ -253,10 +255,10 @@ scm_ihash (SCM obj, unsigned int n) SCM_DEFINE (scm_hash, "hash", 2, 0, 0, (SCM key, SCM size), - "Determine a hash value for KEY that is suitable for lookups in\n" - "a hashtable of size SIZE, where equal? is used as the equality\n" - "predicate. The function returns an integer in the range 0 to\n" - "SIZE - 1.") + "Determine a hash value for @var{key} that is suitable for\n" + "lookups in a hashtable of size @var{size}, where @code{equal?}\n" + "is used as the equality predicate. The function returns an\n" + "integer in the range 0 to @var{size} - 1.") #define FUNC_NAME s_scm_hash { SCM_VALIDATE_INUM_MIN (2, size, 0); diff --git a/libguile/hashtab.c b/libguile/hashtab.c index 302b1761b..54500fdfe 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -195,8 +195,8 @@ SCM_DEFINE (scm_hashq_ref, "hashq-ref", 2, 1, 0, (SCM table, SCM obj, SCM dflt), "Look up @var{key} in the hash table @var{table}, and return the\n" "value (if any) associated with it. If @var{key} is not found,\n" - "return @var{default} (or @code{#f} if no @var{default} argument is\n" - "supplied). Uses `eq?' for equality testing.") + "return @var{default} (or @code{#f} if no @var{default} argument\n" + "is supplied). Uses @code{eq?} for equality testing.") #define FUNC_NAME s_scm_hashq_ref { if (SCM_UNBNDP (dflt)) @@ -209,8 +209,8 @@ SCM_DEFINE (scm_hashq_ref, "hashq-ref", 2, 1, 0, SCM_DEFINE (scm_hashq_set_x, "hashq-set!", 3, 0, 0, (SCM table, SCM obj, SCM val), - "Find the entry in @var{table} associated with @var{key}, and store\n" - "@var{value} there. Uses `eq?' for equality testing.") + "Find the entry in @var{table} associated with @var{key}, and\n" + "store @var{value} there. Uses @code{eq?} for equality testing.") #define FUNC_NAME s_scm_hashq_set_x { return scm_hash_fn_set_x (table, obj, val, scm_ihashq, scm_sloppy_assq, 0); @@ -221,8 +221,8 @@ SCM_DEFINE (scm_hashq_set_x, "hashq-set!", 3, 0, 0, SCM_DEFINE (scm_hashq_remove_x, "hashq-remove!", 2, 0, 0, (SCM table, SCM obj), - "Remove @var{key} (and any value associated with it) from @var{table}.\n" - "Uses `eq?' for equality tests.") + "Remove @var{key} (and any value associated with it) from\n" + "@var{table}. Uses @code{eq?} for equality tests.") #define FUNC_NAME s_scm_hashq_remove_x { return scm_hash_fn_remove_x (table, obj, scm_ihashq, scm_sloppy_assq, scm_delq_x, 0); @@ -263,8 +263,8 @@ SCM_DEFINE (scm_hashv_ref, "hashv-ref", 2, 1, 0, (SCM table, SCM obj, SCM dflt), "Look up @var{key} in the hash table @var{table}, and return the\n" "value (if any) associated with it. If @var{key} is not found,\n" - "return @var{default} (or @code{#f} if no @var{default} argument is\n" - "supplied). Uses `eqv?' for equality testing.") + "return @var{default} (or @code{#f} if no @var{default} argument\n" + "is supplied). Uses @code{eqv?} for equality testing.") #define FUNC_NAME s_scm_hashv_ref { if (SCM_UNBNDP (dflt)) @@ -277,8 +277,8 @@ SCM_DEFINE (scm_hashv_ref, "hashv-ref", 2, 1, 0, SCM_DEFINE (scm_hashv_set_x, "hashv-set!", 3, 0, 0, (SCM table, SCM obj, SCM val), - "Find the entry in @var{table} associated with @var{key}, and store\n" - "@var{value} there. Uses `eqv?' for equality testing.") + "Find the entry in @var{table} associated with @var{key}, and\n" + "store @var{value} there. Uses @code{eqv?} for equality testing.") #define FUNC_NAME s_scm_hashv_set_x { return scm_hash_fn_set_x (table, obj, val, scm_ihashv, scm_sloppy_assv, 0); @@ -288,8 +288,8 @@ SCM_DEFINE (scm_hashv_set_x, "hashv-set!", 3, 0, 0, SCM_DEFINE (scm_hashv_remove_x, "hashv-remove!", 2, 0, 0, (SCM table, SCM obj), - "Remove @var{key} (and any value associated with it) from @var{table}.\n" - "Uses `eqv?' for equality tests.") + "Remove @var{key} (and any value associated with it) from\n" + "@var{table}. Uses @code{eqv?} for equality tests.") #define FUNC_NAME s_scm_hashv_remove_x { return scm_hash_fn_remove_x (table, obj, scm_ihashv, scm_sloppy_assv, scm_delv_x, 0); @@ -329,8 +329,8 @@ SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0, (SCM table, SCM obj, SCM dflt), "Look up @var{key} in the hash table @var{table}, and return the\n" "value (if any) associated with it. If @var{key} is not found,\n" - "return @var{default} (or @code{#f} if no @var{default} argument is\n" - "supplied). Uses `equal?' for equality testing.") + "return @var{default} (or @code{#f} if no @var{default} argument\n" + "is supplied). Uses @code{equal?} for equality testing.") #define FUNC_NAME s_scm_hash_ref { if (SCM_UNBNDP (dflt)) @@ -343,8 +343,9 @@ SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0, SCM_DEFINE (scm_hash_set_x, "hash-set!", 3, 0, 0, (SCM table, SCM obj, SCM val), - "Find the entry in @var{table} associated with @var{key}, and store\n" - "@var{value} there. Uses `equal?' for equality testing.") + "Find the entry in @var{table} associated with @var{key}, and\n" + "store @var{value} there. Uses @code{equal?} for equality\n" + "testing.") #define FUNC_NAME s_scm_hash_set_x { return scm_hash_fn_set_x (table, obj, val, scm_ihash, scm_sloppy_assoc, 0); @@ -355,8 +356,8 @@ SCM_DEFINE (scm_hash_set_x, "hash-set!", 3, 0, 0, SCM_DEFINE (scm_hash_remove_x, "hash-remove!", 2, 0, 0, (SCM table, SCM obj), - "Remove @var{key} (and any value associated with it) from @var{table}.\n" - "Uses `equal?' for equality tests.") + "Remove @var{key} (and any value associated with it) from\n" + "@var{table}. Uses @code{equal?} for equality tests.") #define FUNC_NAME s_scm_hash_remove_x { return scm_hash_fn_remove_x (table, obj, scm_ihash, scm_sloppy_assoc, scm_delete_x, 0); diff --git a/libguile/list.c b/libguile/list.c index 7655b53e3..5f809035d 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -80,7 +80,8 @@ scm_listify (SCM elt, ...) SCM_DEFINE (scm_list, "list", 0, 0, 1, (SCM objs), - "Return a list containing OBJS, the arguments to `list'.") + "Return a list containing @var{objs}, the arguments to\n" + "@code{list}.") #define FUNC_NAME s_scm_list { return objs; @@ -96,11 +97,12 @@ SCM_REGISTER_PROC (s_list_star, "list*", 1, 0, 1, scm_cons_star); SCM_DEFINE (scm_cons_star, "cons*", 1, 0, 1, (SCM arg, SCM rest), - "Like `list', but the last arg provides the tail of the constructed list,\n" - "returning (cons ARG1 (cons ARG2 (cons ... ARGn))).\n" - "Requires at least one argument. If given one argument, that argument\n" - "is returned as result.\n" - "This function is called `list*' in some other Schemes and in Common LISP.") + "Like @code{list}, but the last arg provides the tail of the\n" + "constructed list, returning @code{(cons @var{arg1} (cons\n" + "@var{arg2} (cons @dots{} @var{argn}))). Requires at least one\n" + "argument. If given one argument, that argument is returned as\n" + "result. This function is called @code{list*} in some other\n" + "Schemes and in Common LISP.") #define FUNC_NAME s_scm_cons_star { SCM_VALIDATE_REST_ARGUMENT (rest); @@ -124,7 +126,7 @@ SCM_DEFINE (scm_cons_star, "cons*", 1, 0, 1, SCM_DEFINE (scm_null_p, "null?", 1, 0, 0, (SCM x), - "Return #t iff X is the empty list, else #f.") + "Return @code{#t} iff @var{x} is the empty list, else @code{#f}.") #define FUNC_NAME s_scm_null_p { return SCM_BOOL (SCM_NULLP (x)); @@ -134,7 +136,7 @@ SCM_DEFINE (scm_null_p, "null?", 1, 0, 0, SCM_DEFINE (scm_list_p, "list?", 1, 0, 0, (SCM x), - "Return #t iff X is a proper list, else #f.") + "Return @code{#t} iff @var{x} is a proper list, else @code{#f}.") #define FUNC_NAME s_scm_list_p { return SCM_BOOL (scm_ilength (x) >= 0); @@ -175,7 +177,7 @@ scm_ilength(SCM sx) SCM_DEFINE (scm_length, "length", 1, 0, 0, (SCM lst), - "Return the number of elements in list LST.") + "Return the number of elements in list @var{lst}.") #define FUNC_NAME s_scm_length { int i; @@ -190,20 +192,20 @@ SCM_DEFINE (scm_length, "length", 1, 0, 0, SCM_DEFINE (scm_append, "append", 0, 0, 1, (SCM args), - "Returns a list consisting of the elements of the first LIST\n" - "followed by the elements of the other LISTs.\n\n" + "Return a list consisting of the elements the lists passed as\n" + "arguments.\n" "@example\n" - " (append '(x) '(y)) => (x y)\n" - " (append '(a) '(b c d)) => (a b c d)\n" - " (append '(a (b)) '((c))) => (a (b) (c))\n" - "@end example\n\n" - "The resulting list is always newly allocated, except that it shares\n" - "structure with the last LIST argument. The last argument may\n" - "actually be any object; an improper list results if the last\n" - "argument is not a proper list.\n\n" + "(append '(x) '(y)) @result{} (x y)\n" + "(append '(a) '(b c d)) @result{} (a b c d)\n" + "(append '(a (b)) '((c))) @result{} (a (b) (c))\n" + "@end example\n" + "The resulting list is always newly allocated, except that it\n" + "shares structure with the last list argument. The last\n" + "argument may actually be any object; an improper list results\n" + "if the last argument is not a proper list.\n" "@example\n" - " (append '(a b) '(c . d)) => (a b c . d)\n" - " (append '() 'a) => a\n" + "(append '(a b) '(c . d)) @result{} (a b c . d)\n" + "(append '() 'a) @result{} a\n" "@end example") #define FUNC_NAME s_scm_append { @@ -292,7 +294,8 @@ SCM_DEFINE (scm_last_pair, "last-pair", 1, 0, 0, SCM_DEFINE (scm_reverse, "reverse", 1, 0, 0, (SCM lst), - "Return a new list that contains the elements of LST but in reverse order.") + "Return a new list that contains the elements of @var{lst} but\n" + "in reverse order.") #define FUNC_NAME s_scm_reverse { SCM result = SCM_EOL; @@ -352,7 +355,7 @@ SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0, SCM_DEFINE (scm_list_ref, "list-ref", 2, 0, 0, (SCM list, SCM k), - "Return the Kth element from LIST.") + "Return the @var{k}th element from @var{list}.") #define FUNC_NAME s_scm_list_ref { SCM lst = list; @@ -580,11 +583,12 @@ scm_c_memq (SCM obj, SCM list) SCM_DEFINE (scm_memq, "memq", 2, 0, 0, (SCM x, SCM lst), - "Return the first sublist of LST whose car is `eq?' to X\n" - "where the sublists of LST are the non-empty lists returned\n" - "by `(list-tail LST K)' for K less than the length of LST. If\n" - "X does not occur in LST, then `#f' (not the empty list) is\n" - "returned.") + "Return the first sublist of @var{lst} whose car is @code{eq?}\n" + "to @var{x} where the sublists of @var{lst} are the non-empty\n" + "lists returned by @code{(list-tail @var{lst} @var{k})} for\n" + "@var{k} less than the length of @var{lst}. If @var{x} does not\n" + "occur in @var{lst}, then @code{#f} (not the empty list) is\n" + "returned.") #define FUNC_NAME s_scm_memq { SCM_VALIDATE_LIST (2, lst); @@ -596,11 +600,12 @@ SCM_DEFINE (scm_memq, "memq", 2, 0, 0, SCM_DEFINE (scm_memv, "memv", 2, 0, 0, (SCM x, SCM lst), - "Return the first sublist of LST whose car is `eqv?' to X\n" - "where the sublists of LST are the non-empty lists returned\n" - "by `(list-tail LST K)' for K less than the length of LST. If\n" - "X does not occur in LST, then `#f' (not the empty list) is\n" - "returned.") + "Return the first sublist of @var{lst} whose car is @code{eqv?}\n" + "to @var{x} where the sublists of @var{lst} are the non-empty\n" + "lists returned by @code{(list-tail @var{lst} @var{k})} for\n" + "@var{k} less than the length of @var{lst}. If @var{x} does not\n" + "occur in @var{lst}, then @code{#f} (not the empty list) is\n" + "returned.") #define FUNC_NAME s_scm_memv { SCM_VALIDATE_LIST (2, lst); @@ -616,11 +621,12 @@ SCM_DEFINE (scm_memv, "memv", 2, 0, 0, SCM_DEFINE (scm_member, "member", 2, 0, 0, (SCM x, SCM lst), - "Return the first sublist of LST whose car is `equal?' to X\n" - "where the sublists of LST are the non-empty lists returned\n" - "by `(list-tail LST K)' for K less than the length of LST. If\n" - "X does not occur in LST, then `#f' (not the empty list) is\n" - "returned.") + "Return the first sublist of @var{lst} whose car is\n" + "@code{equal?} to @var{x} where the sublists of @var{lst} are\n" + "the non-empty lists returned by @code{(list-tail @var{lst}\n" + "@var{k})} for @var{k} less than the length of @var{lst}. If\n" + "@var{x} does not occur in @var{lst}, then @code{#f} (not the\n" + "empty list) is returned.") #define FUNC_NAME s_scm_member { SCM_VALIDATE_LIST (2, lst); @@ -668,8 +674,9 @@ SCM_DEFINE (scm_delq_x, "delq!", 2, 0, 0, SCM_DEFINE (scm_delv_x, "delv!", 2, 0, 0, - (SCM item, SCM lst), - "Destructively remove all elements from LST that are `eqv?' to ITEM.") + (SCM item, SCM lst), + "Destructively remove all elements from @var{lst} that are\n" + "@code{eqv?} to @var{item}.") #define FUNC_NAME s_scm_delv_x { SCM walk; @@ -692,8 +699,9 @@ SCM_DEFINE (scm_delv_x, "delv!", 2, 0, 0, SCM_DEFINE (scm_delete_x, "delete!", 2, 0, 0, - (SCM item, SCM lst), - "Destructively remove all elements from LST that are `equal?' to ITEM.") + (SCM item, SCM lst), + "Destructively remove all elements from @var{lst} that are\n" + "@code{equal?} to @var{item}.") #define FUNC_NAME s_scm_delete_x { SCM walk; @@ -719,10 +727,10 @@ SCM_DEFINE (scm_delete_x, "delete!", 2, 0, 0, SCM_DEFINE (scm_delq, "delq", 2, 0, 0, (SCM item, SCM lst), - "Return a newly-created copy of @var{lst} with elements `eq?' to @var{item} removed.\n" - "This procedure mirrors @code{memq}:\n" - "@code{delq} compares elements of @var{lst} against @var{item} with\n" - "@code{eq?}.") + "Return a newly-created copy of @var{lst} with elements\n" + "@code{eq?} to @var{item} removed. This procedure mirrors\n" + "@code{memq}: @code{delq} compares elements of @var{lst} against\n" + "@var{item} with @code{eq?}.") #define FUNC_NAME s_scm_delq { SCM copy = scm_list_copy (lst); @@ -732,10 +740,10 @@ SCM_DEFINE (scm_delq, "delq", 2, 0, 0, SCM_DEFINE (scm_delv, "delv", 2, 0, 0, (SCM item, SCM lst), - "Return a newly-created copy of @var{lst} with elements `eqv?' to @var{item} removed.\n" - "This procedure mirrors @code{memv}:\n" - "@code{delv} compares elements of @var{lst} against @var{item} with\n" - "@code{eqv?}.") + "Return a newly-created copy of @var{lst} with elements\n" + "@code{eqv?} to @var{item} removed. This procedure mirrors\n" + "@code{memv}: @code{delv} compares elements of @var{lst} against\n" + "@var{item} with @code{eqv?}.") #define FUNC_NAME s_scm_delv { SCM copy = scm_list_copy (lst); @@ -745,10 +753,10 @@ SCM_DEFINE (scm_delv, "delv", 2, 0, 0, SCM_DEFINE (scm_delete, "delete", 2, 0, 0, (SCM item, SCM lst), - "Return a newly-created copy of @var{lst} with elements `equal?' to @var{item} removed.\n" - "This procedure mirrors @code{member}:\n" - "@code{delete} compares elements of @var{lst} against @var{item} with\n" - "@code{equal?}.") + "Return a newly-created copy of @var{lst} with elements\n" + "@code{equal?} to @var{item} removed. This procedure mirrors\n" + "@code{member}: @code{delete} compares elements of @var{lst}\n" + "against @var{item} with @code{equal?}.") #define FUNC_NAME s_scm_delete { SCM copy = scm_list_copy (lst); @@ -759,8 +767,9 @@ SCM_DEFINE (scm_delete, "delete", 2, 0, 0, SCM_DEFINE (scm_delq1_x, "delq1!", 2, 0, 0, (SCM item, SCM lst), - "Like `delq!', but only deletes the first occurrence of ITEM from LST.\n" - "Tests for equality using `eq?'. See also `delv1!' and `delete1!'.") + "Like @code{delq!}, but only deletes the first occurrence of\n" + "@var{item} from @var{lst}. Tests for equality using\n" + "@code{eq?}. See also @code{delv1!} and @code{delete1!}.") #define FUNC_NAME s_scm_delq1_x { SCM walk; @@ -786,8 +795,9 @@ SCM_DEFINE (scm_delq1_x, "delq1!", 2, 0, 0, SCM_DEFINE (scm_delv1_x, "delv1!", 2, 0, 0, (SCM item, SCM lst), - "Like `delv!', but only deletes the first occurrence of ITEM from LST.\n" - "Tests for equality using `eqv?'. See also `delq1!' and `delete1!'.") + "Like @code{delv!}, but only deletes the first occurrence of\n" + "@var{item} from @var{lst}. Tests for equality using\n" + "@code{eqv?}. See also @code{delq1!} and @code{delete1!}.") #define FUNC_NAME s_scm_delv1_x { SCM walk; @@ -813,8 +823,9 @@ SCM_DEFINE (scm_delv1_x, "delv1!", 2, 0, 0, SCM_DEFINE (scm_delete1_x, "delete1!", 2, 0, 0, (SCM item, SCM lst), - "Like `delete!', but only deletes the first occurrence of ITEM from LST.\n" - "Tests for equality using `equal?'. See also `delq1!' and `delv1!'.") + "Like @code{delete!}, but only deletes the first occurrence of\n" + "@var{item} from @var{lst}. Tests for equality using\n" + "@code{equal?}. See also @code{delq1!} and @code{delv1!}.") #define FUNC_NAME s_scm_delete1_x { SCM walk; diff --git a/libguile/numbers.c b/libguile/numbers.c index 644249ea9..335c5c233 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -2865,12 +2865,12 @@ SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0, (SCM string, SCM radix), "Returns a number of the maximally precise representation\n" "expressed by the given @var{string}. @var{radix} must be an\n" - "exact integer, either 2, 8, 10, or 16. If supplied, @var{RADIX}\n" - "is a default radix that may be overridden by an explicit\n" - "radix prefix in @var{string} (e.g. \"#o177\"). If @var{radix}\n" - "is not supplied, then the default radix is 10. If string is\n" - "not a syntactically valid notation for a number, then\n" - "@code{string->number} returns @code{#f}. (r5rs)") + "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n" + "is a default radix that may be overridden by an explicit radix\n" + "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n" + "supplied, then the default radix is 10. If string is not a\n" + "syntactically valid notation for a number, then\n" + "@code{string->number} returns @code{#f}.") #define FUNC_NAME s_scm_string_to_number { SCM answer; diff --git a/libguile/ports.c b/libguile/ports.c index e18dff08f..898de999e 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -498,8 +498,8 @@ scm_remove_from_port_table (SCM port) SCM_DEFINE (scm_pt_size, "pt-size", 0, 0, 0, (), - "Returns the number of ports in the port table.\n" - "`pt-size' is only included in GUILE_DEBUG builds.") + "Returns the number of ports in the port table. @code{pt-size}\n" + "is only included in @code{--enable-guile-debug} builds.") #define FUNC_NAME s_scm_pt_size { return SCM_MAKINUM (scm_port_table_size); @@ -508,8 +508,9 @@ SCM_DEFINE (scm_pt_size, "pt-size", 0, 0, 0, SCM_DEFINE (scm_pt_member, "pt-member", 1, 0, 0, (SCM index), - "Returns the port at INDEX in the port table.\n" - "`pt-member' is only included in GUILE_DEBUG builds.") + "Returns the port at @var{index} in the port table.\n" + "@code{pt-member} is only included in\n" + "@code{--enable-guile-debug} builds.") #define FUNC_NAME s_scm_pt_member { int i; @@ -811,8 +812,9 @@ SCM_DEFINE (scm_output_port_p, "output-port?", 1, 0, 0, SCM_DEFINE (scm_port_p, "port?", 1, 0, 0, (SCM x), - "Returns a boolean indicating whether @var{x} is a port.\n" - "Equivalent to @code{(or (input-port? X) (output-port? X))}.") + "Returns a boolean indicating whether @var{x} is a port.\n" + "Equivalent to @code{(or (input-port? @var{x}) (output-port?\n" + "@var{x}))}.") #define FUNC_NAME s_scm_port_p { return SCM_BOOL (SCM_PORTP (x)); diff --git a/libguile/print.c b/libguile/print.c index 0fdb24862..0c2adba12 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -194,8 +194,9 @@ static SCM print_state_pool; SCM_DEFINE (scm_current_pstate, "current-pstate", 0, 0, 0, (), - "Return the current-pstate--the `cadr' of the print_state_pool.\n" - "`current-pstate' is only included in GUILE_DEBUG builds.") + "Return the current-pstate -- the cadr of the\n" + "@code{print_state_pool}. @code{current-pstate} is only\n" + "included in @code{--enable-guile-debug} builds.") #define FUNC_NAME s_scm_current_pstate { if (SCM_NNULLP (SCM_CDR (print_state_pool))) diff --git a/libguile/rdelim.c b/libguile/rdelim.c index 20fe8150c..40f65b938 100644 --- a/libguile/rdelim.c +++ b/libguile/rdelim.c @@ -62,18 +62,20 @@ SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0, (SCM delims, SCM str, SCM gobble, SCM port, SCM start, SCM end), "Read characters from @var{port} into @var{str} until one of the\n" - "characters in the @var{delims} string is encountered. If @var{gobble}\n" - "is true, discard the delimiter character; otherwise, leave it\n" - "in the input stream for the next read.\n" - "If @var{port} is not specified, use the value of\n" - "@code{(current-input-port)}. If @var{start} or @var{end} are specified,\n" - "store data only into the substring of @var{str} bounded by @var{start}\n" - "and @var{end} (which default to the beginning and end of the string,\n" - "respectively).\n\n" - "Return a pair consisting of the delimiter that terminated the string and\n" - "the number of characters read. If reading stopped at the end of file,\n" - "the delimiter returned is the @var{eof-object}; if the string was filled\n" - "without encountering a delimiter, this value is @var{#f}.") + "characters in the @var{delims} string is encountered. If\n" + "@var{gobble} is true, discard the delimiter character;\n" + "otherwise, leave it in the input stream for the next read. If\n" + "@var{port} is not specified, use the value of\n" + "@code{(current-input-port)}. If @var{start} or @var{end} are\n" + "specified, store data only into the substring of @var{str}\n" + "bounded by @var{start} and @var{end} (which default to the\n" + "beginning and end of the string, respectively).\n" + "\n" + " Return a pair consisting of the delimiter that terminated the\n" + "string and the number of characters read. If reading stopped\n" + "at the end of file, the delimiter returned is the\n" + "@var{eof-object}; if the string was filled without encountering\n" + "a delimiter, this value is @code{#f}.") #define FUNC_NAME s_scm_read_delimited_x { long j; diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index 9799dfc14..b05b858a4 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -441,8 +441,8 @@ SCM_DEFINE (scm_sleep, "sleep", 1, 0, 0, #if defined(USE_THREADS) || defined(HAVE_USLEEP) SCM_DEFINE (scm_usleep, "usleep", 1, 0, 0, (SCM i), - "Sleep for I microseconds.\n" - "`usleep' is not available on all platforms.") + "Sleep for I microseconds. @code{usleep} is not available on\n" + "all platforms.") #define FUNC_NAME s_scm_usleep { SCM_VALIDATE_INUM_MIN (1,i,0); diff --git a/libguile/strop.c b/libguile/strop.c index 3ff1726c8..a7f2911ba 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -100,14 +100,16 @@ scm_i_index (SCM *str, SCM chr, int direction, SCM sub_start, SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0, (SCM str, SCM chr, SCM frm, SCM to), - "Return the index of the first occurrence of @var{chr} in @var{str}. The\n" - "optional integer arguments @var{frm} and @var{to} limit the search to\n" - "a portion of the string. This procedure essentially implements the\n" - "@code{index} or @code{strchr} functions from the C library.\n\n" - "(qdocs:) Returns the index of @var{char} in @var{str}, or @code{#f} if the\n" - "@var{char} isn't in @var{str}. If @var{frm} is given and not @code{#f},\n" - "it is used as the starting index; if @var{to} is given and not @var{#f},\n" - "it is used as the ending index (exclusive).\n\n" + "Return the index of the first occurrence of @var{chr} in\n" + "@var{str}. The optional integer arguments @var{frm} and\n" + "@var{to} limit the search to a portion of the string. This\n" + "procedure essentially implements the @code{index} or\n" + "@code{strchr} functions from the C library.\n (qdocs:) Returns\n" + "the index of @var{char} in @var{str}, or @code{#f} if the\n" + "@var{char} isn't in @var{str}. If @var{frm} is given and not\n" + "@code{#f}, it is used as the starting index; if @var{to} is\n" + "given and not @code{#f}, it is used as the ending index\n" + "(exclusive).\n\n" "@example\n" "(string-index \"weiner\" #\\e)\n" "@result{} 1\n\n" diff --git a/libguile/symbols.c b/libguile/symbols.c index 2d6d081ea..061e91811 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -621,9 +621,9 @@ SCM_DEFINE (scm_symbol_binding, "symbol-binding", 2, 0, 0, SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 2, 0, 0, - (SCM o, SCM s), - "Return @var{#t} if @var{obarray} contains a symbol with name\n" - "@var{string}, and @var{#f} otherwise.") + (SCM o, SCM s), + "Return @code{#t} if @var{obarray} contains a symbol with name\n" + "@var{string}, and @code{#f} otherwise.") #define FUNC_NAME s_scm_symbol_interned_p { SCM vcell; @@ -640,12 +640,13 @@ SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 2, 0, 0, SCM_DEFINE (scm_symbol_bound_p, "symbol-bound?", 2, 0, 0, - (SCM o, SCM s), - "Return @var{#t} if @var{obarray} contains a symbol with name\n" + (SCM o, SCM s), + "Return @code{#t} if @var{obarray} contains a symbol with name\n" "@var{string} bound to a defined value. This differs from\n" - "@var{symbol-interned?} in that the mere mention of a symbol usually causes\n" - "it to be interned; @code{symbol-bound?} determines whether a symbol has\n" - "been given any meaningful value.") + "@var{symbol-interned?} in that the mere mention of a symbol\n" + "usually causes it to be interned; @code{symbol-bound?}\n" + "determines whether a symbol has been given any meaningful\n" + "value.") #define FUNC_NAME s_scm_symbol_bound_p { SCM vcell; diff --git a/libguile/weaks.c b/libguile/weaks.c index 91167d230..c01da2c61 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -106,8 +106,8 @@ SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1, SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0, (SCM x), - "Return @var{#t} if @var{obj} is a weak vector. Note that all weak\n" - "hashes are also weak vectors.") + "Return @code{#t} if @var{obj} is a weak vector. Note that all\n" + "weak hashes are also weak vectors.") #define FUNC_NAME s_scm_weak_vector_p { return SCM_BOOL(SCM_WVECTP (x) && !SCM_IS_WHVEC (x)); @@ -179,9 +179,9 @@ SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0, (SCM x), "@deffnx primitive weak-value-hash-table? obj\n" "@deffnx primitive doubly-weak-hash-table? obj\n" - "Return @var{#t} if @var{obj} is the specified weak hash table. Note\n" - "that a doubly weak hash table is neither a weak key nor a weak value\n" - "hash table.") + "Return @code{#t} if @var{obj} is the specified weak hash\n" + "table. Note that a doubly weak hash table is neither a weak key\n" + "nor a weak value hash table.") #define FUNC_NAME s_scm_weak_key_hash_table_p { return SCM_BOOL(SCM_WVECTP (x) && SCM_IS_WHVEC(x)); @@ -191,7 +191,7 @@ SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0, SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0, (SCM x), - "Return @var{#t} if @var{x} is a weak value hash table.") + "Return @code{#t} if @var{x} is a weak value hash table.") #define FUNC_NAME s_scm_weak_value_hash_table_p { return SCM_BOOL(SCM_WVECTP (x) && SCM_IS_WHVEC_V(x)); @@ -201,7 +201,7 @@ SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0, SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0, (SCM x), - "Return @var{#t} if @var{x} is a doubly weak hash table.") + "Return @code{#t} if @var{x} is a doubly weak hash table.") #define FUNC_NAME s_scm_doubly_weak_hash_table_p { return SCM_BOOL(SCM_WVECTP (x) && SCM_IS_WHVEC_B (x)); From fcaedf993699c59a2127c92e331ec7a363c17882 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 16 Mar 2001 17:00:21 +0000 Subject: [PATCH 0728/2047] * scheme-data.texi (Arithmetic): Documented the arithmetic procedures. (Integer Operations): Added documentation. (Comparison): Added documentation. (Complex): Added documentation. (Symbols and Variables): Comment out `builtin-bindings', which is removed according to NEWS. (Pairs): Added documentation. * scheme-io.texi: Added R5RS index entries for all R5RS procedures. (File Ports): New docs for `call-with-input-file', `call-with-output-file', `with-input-from-file', `with-output-to-file', `with-error-to-file'. * scheme-control.texi, scheme-utility.texi, * scheme-procedures.texi: Added R5RS index entries for all R5RS procedures. * scheme-evaluation.texi (Fly Evaluation): Added documentation for `apply'. Added R5RS index entries for all R5RS procedures. * scheme-data.texi: Added R5RS index entries for all R5RS procedures. Removed R5RS index entries for `ass{q,v,occ}-set!'. Removed explicit entries into the function entries. They are automagic. (Vectors): Added documentation for `make-vector', `vector-ref' and `vector-set!'. --- doc/ChangeLog | 31 +++++ doc/scheme-control.texi | 7 + doc/scheme-data.texi | 276 +++++++++++++++++++++++++++++++------ doc/scheme-evaluation.texi | 20 +++ doc/scheme-io.texi | 83 +++++++++++ doc/scheme-procedures.texi | 1 + doc/scheme-utility.texi | 3 + 7 files changed, 382 insertions(+), 39 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index b377533dd..64761ee80 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,34 @@ +2001-03-16 Martin Grabmueller + + * scheme-data.texi (Arithmetic): Documented the arithmetic + procedures. + (Integer Operations): Added documentation. + (Comparison): Added documentation. + (Complex): Added documentation. + (Symbols and Variables): Comment out `builtin-bindings', which is + removed according to NEWS. + (Pairs): Added documentation. + + * scheme-io.texi: Added R5RS index entries for all R5RS + procedures. + (File Ports): New docs for `call-with-input-file', + `call-with-output-file', `with-input-from-file', + `with-output-to-file', `with-error-to-file'. + + * scheme-control.texi, scheme-utility.texi, + * scheme-procedures.texi: Added R5RS index entries for all R5RS + procedures. + + * scheme-evaluation.texi (Fly Evaluation): Added documentation for + `apply'. Added R5RS index entries for all R5RS procedures. + + * scheme-data.texi: Added R5RS index entries for all R5RS + procedures. Removed R5RS index entries for `ass{q,v,occ}-set!'. + Removed explicit entries into the function entries. They are + automagic. + (Vectors): Added documentation for `make-vector', `vector-ref' and + `vector-set!'. + 2001-03-12 Marius Vollmer * intro.texi: Changed to reflect current practice better. Added diff --git a/doc/scheme-control.texi b/doc/scheme-control.texi index cd3cbc1bd..5098fe4cd 100644 --- a/doc/scheme-control.texi +++ b/doc/scheme-control.texi @@ -34,10 +34,15 @@ @node Continuations @section Continuations +@r5index call-with-current-continuation +@c FIXME::martin: Document me! +@deffn primitive call-with-current-continuation +@end deffn @node Multiple Values @section Returning and Accepting Multiple Values +@r5index values @deffn primitive values . args Delivers all of its arguments to its continuation. Except for continuations created by the @code{call-with-values} procedure, @@ -46,6 +51,7 @@ passing no value or more than one value to continuations that were not created by @code{call-with-values} is unspecified. @end deffn +@r5index call-with-values @deffn primitive call-with-values producer consumer Calls its @var{producer} argument with no values and a continuation that, when passed some values, calls the @@ -174,6 +180,7 @@ if an exception occurs then @code{#f} is returned instead. [FIXME: this is pasted in from Tom Lord's original guile.texi and should be reviewed] +@r5index dynamic-wind @c ARGFIXME in-guard/thunk1 thunk/thunk2 out-guard/thunk3 @c docstring begin (texi-doc-string "guile" "dynamic-wind") @deffn primitive dynamic-wind thunk1 thunk2 thunk3 diff --git a/doc/scheme-data.texi b/doc/scheme-data.texi index 0d5ea363c..c69a5431c 100755 --- a/doc/scheme-data.texi +++ b/doc/scheme-data.texi @@ -63,6 +63,8 @@ sections of this manual that cover them. @node Booleans @section Booleans +@r5index not +@r5index boolean? The two boolean values are @code{#t} for true and @code{#f} for false. @@ -167,6 +169,7 @@ in Scheme, which is particularly clear and accessible: see @node Numerical Tower @subsection Scheme's Numerical ``Tower'' +@r5index number? Scheme's numerical ``tower'' consists of the following categories of numbers: @@ -229,6 +232,7 @@ in detail. @node Integers @subsection Integers +@r5index integer? Integers are whole numbers, that is numbers with no fractional part, such as 2, 83 and -3789. @@ -287,6 +291,8 @@ Return @code{#t} if @var{obj} is an integer number, @code{#f} else. @node Reals and Rationals @subsection Real and Rational Numbers +@r5index real? +@r5index rational? Mathematically, the real numbers are the set of numbers that describe all possible points along a continuous, infinite, one-dimensional line. @@ -347,6 +353,7 @@ is an integer number. @node Complex Numbers @subsection Complex Numbers +@r5index complex? Complex numbers are the set of numbers that describe all possible points in a two-dimensional space. The two coordinates of a particular point @@ -382,6 +389,10 @@ the set of complex numbers, so the predicate will also be fulfilled if @node Exactness @subsection Exact and Inexact Numbers +@r5index exact? +@r5index inexact? +@r5index exact->inexact +@r5index inexact->exact R5RS requires that a calculation involving inexact numbers always produces an inexact result. To meet this requirement, Guile @@ -403,11 +414,12 @@ Return #t if X is an inexact number, #f else. @c docstring begin (texi-doc-string "guile" "inexact->exact") @deffn primitive inexact->exact z -Returns an exact number that is numerically closest to Z. +Returns an exact number that is numerically closest to @var{z}. @end deffn @c begin (texi-doc-string "guile" "exact->inexact") -@deffn primitive exact->inexact +@deffn primitive exact->inexact z +Convert the number @var{z} to its inexact representation. @end deffn @@ -480,6 +492,13 @@ multiplying by 10^N. @node Integer Operations @subsection Operations on Integer Values +@r5index odd? +@r5index even? +@r5index quotient +@r5index remainder +@r5index modulo +@r5index gcd +@r5index lcm @c docstring begin (texi-doc-string "guile" "odd?") @deffn primitive odd? n @@ -493,63 +512,98 @@ Return #t if N is an even number, #f otherwise. @c begin (texi-doc-string "guile" "quotient") @deffn primitive quotient +Return the quotient of the numbers @var{x} and @var{y}. @end deffn @c begin (texi-doc-string "guile" "remainder") @deffn primitive remainder +Return the remainder of the numbers @var{x} and @var{y}. +@lisp +(remainder 13 4) @result{} 1 +(remainder -13 4) @result{} -1 +@end lisp @end deffn @c begin (texi-doc-string "guile" "modulo") @deffn primitive modulo +Return the modulo of the numbers @var{x} and @var{y}. +@lisp +(modulo 13 4) @result{} 1 +(modulo -13 4) @result{} 3 +@end lisp @end deffn @c begin (texi-doc-string "guile" "gcd") @deffn primitive gcd +Return the greatest common divisor of all arguments. +If called without arguments, 0 is returned. @end deffn @c begin (texi-doc-string "guile" "lcm") @deffn primitive lcm +Return the least common multiple of the arguments. +If called without arguments, 1 is returned. @end deffn @node Comparison @subsection Comparison Predicates +@r5index zero? +@r5index positive? +@r5index negative? @c begin (texi-doc-string "guile" "=") @deffn primitive = +Return @code{#t} if all parameters are numerically equal. @end deffn @c begin (texi-doc-string "guile" "<") @deffn primitive < +Return @code{#t} if the list of parameters is monotonically +increasing. @end deffn @c begin (texi-doc-string "guile" ">") @deffn primitive > +Return @code{#t} if the list of parameters is monotonically +decreasing. @end deffn @c begin (texi-doc-string "guile" "<=") @deffn primitive <= +Return @code{#t} if the list of parameters is monotonically +non-decreasing. @end deffn @c begin (texi-doc-string "guile" ">=") @deffn primitive >= +Return @code{#t} if the list of parameters is monotonically +non-increasing. @end deffn @c begin (texi-doc-string "guile" "zero?") @deffn primitive zero? +Return @code{#t} if @var{z} is an exact or inexact number equal to +zero. @end deffn @c begin (texi-doc-string "guile" "positive?") @deffn primitive positive? +Return @code{#t} if @var{x} is an exact or inexact number greater than +zero. @end deffn @c begin (texi-doc-string "guile" "negative?") @deffn primitive negative? +Return @code{#t} if @var{x} is an exact or inexact number less than +zero. @end deffn @node Conversion @subsection Converting Numbers To and From Strings +@r5index number->string +@r5index string->number @c docstring begin (texi-doc-string "guile" "number->string") @deffn primitive number->string n [radix] @@ -572,6 +626,12 @@ for a number, then `string->number' returns #f. (r5rs) @node Complex @subsection Complex Number Operations +@r5index make-rectangular +@r5index make-polar +@r5index real-part +@r5index imag-part +@r5index magnitude +@r5index angle @c docstring begin (texi-doc-string "guile" "make-rectangular") @deffn primitive make-rectangular real imaginary @@ -586,71 +646,111 @@ Return the complex number X * e^(i * Y). @c begin (texi-doc-string "guile" "real-part") @deffn primitive real-part +Return the real part of the number @var{z}. @end deffn @c begin (texi-doc-string "guile" "imag-part") @deffn primitive imag-part +Return the imaginary part of the number @var{z}. @end deffn @c begin (texi-doc-string "guile" "magnitude") @deffn primitive magnitude +Return the magnitude of the number @var{z}. This is the same as +@code{abs} for real arguments, but also allows complex numbers. @end deffn @c begin (texi-doc-string "guile" "angle") @deffn primitive angle +Return the angle of the complex number @var{z}. @end deffn @node Arithmetic @subsection Arithmetic Functions +@r5index max +@r5index min +@r5index + +@r5index * +@r5index - +@r5index / +@r5index abs +@r5index floor +@r5index ceiling +@r5index truncate +@r5index round @c begin (texi-doc-string "guile" "+") -@deffn primitive + +@deffn primitive + z1 @dots{} +Return the sum of all parameter values. Return 0 if called without any +parameters. @end deffn @c begin (texi-doc-string "guile" "-") -@deffn primitive - +@deffn primitive - z1 z2 @dots{} +If called without arguments, 0 is returned. Otherwise the sum of all but +the first argument are subtracted from the first argument. @end deffn @c begin (texi-doc-string "guile" "*") -@deffn primitive * +@deffn primitive * z1 @dots{} +Return the product of all arguments. If called without arguments, 1 is +returned. @end deffn @c begin (texi-doc-string "guile" "/") -@deffn primitive / +@deffn primitive / z1 z2 @dots{} +Divide the first argument by the product of the remaining arguments. @end deffn @c begin (texi-doc-string "guile" "abs") -@deffn primitive abs +@deffn primitive abs x +Return the absolute value of @var{x}. @end deffn @c begin (texi-doc-string "guile" "max") -@deffn primitive max +@deffn primitive max x1 x2 @dots{} +Return the maximum of all parameter values. @end deffn @c begin (texi-doc-string "guile" "min") -@deffn primitive min +@deffn primitive min x1 x2 @dots{} +Return the minium of all parameter values. @end deffn @c begin (texi-doc-string "guile" "truncate") @deffn primitive truncate +Round the inexact number @var{x} towards zero. @end deffn @c begin (texi-doc-string "guile" "round") -@deffn primitive round +@deffn primitive round x +Round the inexact number @var{x} towards zero. @end deffn @c begin (texi-doc-string "guile" "floor") -@deffn primitive floor +@deffn primitive floor x +Round the number @var{x} towards minus infinity. @end deffn @c begin (texi-doc-string "guile" "ceiling") -@deffn primitive ceiling +@deffn primitive ceiling x +Round the number @var{x} towards infinity. @end deffn @node Scientific @subsection Scientific Functions +@r5index exp +@r5index log +@r5index sin +@r5index cos +@r5index tan +@r5index asin +@r5index acos +@r5index atan +@r5index sqrt +@r5index expt The following procedures accept any kind of number as arguments, including complex numbers. @@ -1083,6 +1183,22 @@ Return a new random state using @var{seed}. @node Characters @section Characters +@r5index char? +@r5index char=? +@r5index char? +@r5index char<=? +@r5index char>=? +@r5index char-alphabetic? +@r5index char-numeric? +@r5index char-whitespace? +@r5index char-upper-case? +@r5index char-lower-case? +@r5index char->integer +@r5index integer->char +@r5index char-upcase +@r5index char-downcase + Most of the characters in the ASCII character set may be referred to by name: for example, @code{#\tab}, @code{#\esc}, @code{#\stx}, and so on. @@ -1290,6 +1406,8 @@ eventually, and it will be helpful to know how they work. @node String Fun @subsection String Fun +@r5index string +@r5index list->string @c docstring begin (texi-doc-string "guile" "string") @c docstring begin (texi-doc-string "guile" "list->string") @deffn primitive string . chrs @@ -1298,6 +1416,7 @@ Returns a newly allocated string composed of the arguments, @var{chrs}. @end deffn +@r5index make-string @c docstring begin (texi-doc-string "guile" "make-string") @deffn primitive make-string k [chr] Return a newly allocated string of @@ -1306,23 +1425,27 @@ the string are initialized to @var{chr}, otherwise the contents of the @var{string} are unspecified. @end deffn +@r5index string-append @c docstring begin (texi-doc-string "guile" "string-append") @deffn primitive string-append . args Return a newly allocated string whose characters form the concatenation of the given strings, @var{args}. @end deffn +@r5index string-length @c docstring begin (texi-doc-string "guile" "string-length") @deffn primitive string-length string Return the number of characters in @var{string}. @end deffn +@r5index string-ref @c docstring begin (texi-doc-string "guile" "string-ref") @deffn primitive string-ref str k Return character @var{k} of @var{str} using zero-origin indexing. @var{k} must be a valid index of @var{str}. @end deffn +@r5index string-set! @c docstring begin (texi-doc-string "guile" "string-set!") @deffn primitive string-set! str k chr Store @var{chr} in element @var{k} of @var{str} and return @@ -1330,12 +1453,14 @@ an unspecified value. @var{k} must be a valid index of @var{str}. @end deffn +@r5index string? @c docstring begin (texi-doc-string "guile" "string?") @deffn primitive string? obj Returns @code{#t} iff @var{obj} is a string, else returns @code{#f}. @end deffn +@r5index substring @c docstring begin (texi-doc-string "guile" "substring") @deffn primitive substring str start [end] Return a newly allocated string formed from the characters @@ -1566,6 +1691,7 @@ Destructively capitalize every character in @code{str}. Capitalize every character in @code{str}. @end deffn +@r5index string<=? @c docstring begin (texi-doc-string "guile" "string-ci<=?") @deffn primitive string-ci<=? s1 s2 Case insensitive lexicographic ordering predicate; @@ -1573,6 +1699,7 @@ returns @t{#t} if @var{s1} is lexicographically less than or equal to @var{s2} regardless of case. (r5rs) @end deffn +@r5index string-ci< @c docstring begin (texi-doc-string "guile" "string-ci=? @c docstring begin (texi-doc-string "guile" "string-ci>=?") @deffn primitive string-ci>=? s1 s2 Case insensitive lexicographic ordering predicate; @@ -1594,6 +1723,7 @@ returns @t{#t} if @var{s1} is lexicographically greater than or equal to @var{s2} regardless of case. (r5rs) @end deffn +@r5index string-ci>? @c docstring begin (texi-doc-string "guile" "string-ci>?") @deffn primitive string-ci>? s1 s2 Case insensitive lexicographic ordering predicate; @@ -1601,18 +1731,21 @@ returns @t{#t} if @var{s1} is lexicographically greater than @var{s2} regardless of case. (r5rs) @end deffn +@r5index string<=? @c docstring begin (texi-doc-string "guile" "string<=?") @deffn primitive string<=? s1 s2 Lexicographic ordering predicate; returns @t{#t} if @var{s1} is lexicographically less than or equal to @var{s2}. (r5rs) @end deffn +@r5index string=? @c docstring begin (texi-doc-string "guile" "string>=?") @deffn primitive string>=? s1 s2 Lexicographic ordering predicate; returns @t{#t} if @var{s1} is lexicographically greater than or equal to @var{s2}. (r5rs) @end deffn +@r5index string>? @c docstring begin (texi-doc-string "guile" "string>?") @deffn primitive string>? s1 s2 Lexicographic ordering predicate; returns @t{#t} if @var{s1} is lexicographically greater than @var{s2}. (r5rs) @end deffn +@r5index string->list @c docstring begin (texi-doc-string "guile" "string->list") @deffn primitive string->list str @samp{String->list} returns a newly allocated list of the @@ -1651,11 +1787,13 @@ inverses so far as @samp{equal?} is concerned. (r5rs) Return the symbol whose name is @var{str}, downcased in necessary(???). @end deffn +@r5index string-copy @c docstring begin (texi-doc-string "guile" "string-copy") @deffn primitive string-copy str Returns a newly allocated copy of the given @var{string}. (r5rs) @end deffn +@r5index string-fill! @c docstring begin (texi-doc-string "guile" "string-fill!") @deffn primitive string-fill! str chr Stores @var{char} in every element of the given @var{string} and returns an @@ -2244,6 +2382,10 @@ Test whether obj is a compiled regular expression. @node Symbols and Variables @section Symbols and Variables +@r5index symbol? +@r5index symbol->string +@r5index string->symbol + Guile symbol tables are hash tables. Each hash table, also called an @dfn{obarray} (for `object array'), is a vector of association lists. @@ -2252,11 +2394,13 @@ Each entry in the alists is a pair (@var{SYMBOL} . @var{VALUE}). To (@var{SYMBOL} . @var{VALUE}) pair, adding a new entry to the symbol table (with an undefined value) if none is yet present. -@c docstring begin (texi-doc-string "guile" "builtin-bindings") -@deffn primitive builtin-bindings -Create and return a copy of the global symbol table, removing all -unbound symbols. -@end deffn +@c FIXME::martin: According to NEWS, removed. Remove here too, or +@c leave for compatibility? +@c @c docstring begin (texi-doc-string "guile" "builtin-bindings") +@c @deffn primitive builtin-bindings +@c Create and return a copy of the global symbol table, removing all +@c unbound symbols. +@c @end deffn @c docstring begin (texi-doc-string "guile" "gensym") @deffn primitive gensym [prefix] @@ -2695,6 +2839,10 @@ This is the inverse of @code{make-keyword-from-dash-symbol}. @node Pairs @section Pairs +@r5index pair? +@r5index cons +@r5index set-car! +@r5index set-cdr! @c docstring begin (texi-doc-string "guile" "cons") @deffn primitive cons x y @@ -2708,6 +2856,25 @@ Returns a newly allocated pair whose car is @var{x} and whose cdr is Returns @code{#t} if @var{x} is a pair; otherwise returns @code{#f}. @end deffn +@r5index car +@r5index cdr +@deffn primitive car pair +@deffnx primitive cdr pair +Return the car or the cdr of @var{pair}, respectively. +@end deffn + +@deffn primitive caar pair +@deffnx primitive cadr pair @dots{} +@deffnx primitive cdddar pair +@deffnx primitive cddddr pair +These procedures are compositions of @code{car} and @code{cdr}, where +for example @code{caddr} could be defined by + +@lisp +(define caddr (lambda (x) (car (cdr (cdr x))))) +@end lisp +@end deffn + @c docstring begin (texi-doc-string "guile" "set-car!") @deffn primitive set-car! pair value Stores @var{value} in the car field of @var{pair}. The value returned @@ -2723,6 +2890,18 @@ by @code{set-cdr!} is unspecified. @node Lists @section Lists +@r5index null? +@r5index list? +@r5index list +@r5index length +@r5index append +@r5index reverse +@r5index list-tail +@r5index list-ref +@r5index memq +@r5index memv +@r5index member + @c docstring begin (texi-doc-string "guile" "list") @deffn primitive list . objs @@ -2958,12 +3137,14 @@ Its use is recommended only in writing Guile internals, not for high-level Scheme programs. @end deffn +@r5index map @c begin (texi-doc-string "guile" "map") @c docstring begin (texi-doc-string "guile" "map-in-order") @deffn primitive map proc arg1 . args @deffnx primitive map-in-order proc arg1 . args @end deffn +@r5index for-each @c begin (texi-doc-string "guile" "for-each") @deffn primitive for-each proc arg1 . args @end deffn @@ -3990,13 +4171,6 @@ lists which do not require their entries' keys to be unique. @node Adding or Setting Alist Entries @subsubsection Adding or Setting Alist Entries -@findex acons -@findex assq-set! -@findex assv-set! -@findex assoc-set! -@r5index assq-set! -@r5index assv-set! -@r5index assoc-set! @code{acons} adds a new entry to an association list and returns the combined association list. The combined alist is formed by consing the @@ -4124,18 +4298,9 @@ association list. @node Retrieving Alist Entries @subsubsection Retrieving Alist Entries -@findex assq -@findex assv -@findex assoc -@findex assq-ref -@findex assv-ref -@findex assoc-ref @r5index assq @r5index assv @r5index assoc -@r5index assq-ref -@r5index assv-ref -@r5index assoc-ref @code{assq}, @code{assv} and @code{assoc} take an alist and a key as arguments and return the entry for that key if an entry exists, or @@ -4190,9 +4355,6 @@ where @var{associator} is one of @code{assq}, @code{assv} or @code{assoc}. @node Removing Alist Entries @subsubsection Removing Alist Entries -@findex assq-remove! -@findex assv-remove! -@findex assoc-remove! To remove the element from an association list whose key matches a specified key, use @code{assq-remove!}, @code{assv-remove!} or @@ -4261,9 +4423,6 @@ the resulting alist. @node Sloppy Alist Functions @subsubsection Sloppy Alist Functions -@findex sloppy-assq -@findex sloppy-assv -@findex sloppy-assoc @code{sloppy-assq}, @code{sloppy-assv} and @code{sloppy-assoc} behave like the corresponding non-@code{sloppy-} procedures, except that they @@ -4611,6 +4770,7 @@ table into an a-list of key-value pairs. @node Vectors @section Vectors +@r5index make-vector @c docstring begin (texi-doc-string "guile" "make-vector") @deffn primitive make-vector k [fill] Returns a newly allocated vector of @var{k} elements. If a second @@ -4618,6 +4778,8 @@ argument is given, then each element is initialized to @var{fill}. Otherwise the initial contents of each element is unspecified. (r5rs) @end deffn +@r5index vector +@r5index list->vector @c docstring begin (texi-doc-string "guile" "vector") @c docstring begin (texi-doc-string "guile" "list->vector") @deffn primitive vector . l @@ -4630,6 +4792,7 @@ arguments. Analogous to @samp{list}. (r5rs) @end format @end deffn +@r5index vector->list @c docstring begin (texi-doc-string "guile" "vector->list") @deffn primitive vector->list v @samp{Vector->list} returns a newly allocated list of the objects contained @@ -4644,17 +4807,52 @@ list->vector '(dididit dah)) @end format @end deffn +@r5index vector-fill! +@c FIXME::martin: Argument names @c docstring begin (texi-doc-string "guile" "vector-fill!") @deffn primitive vector-fill! v fill_x Stores @var{fill} in every element of @var{vector}. The value returned by @samp{vector-fill!} is unspecified. (r5rs) @end deffn +@r5index vector? @c docstring begin (texi-doc-string "guile" "vector?") @deffn primitive vector? obj Returns @t{#t} if @var{obj} is a vector, otherwise returns @t{#f}. (r5rs) @end deffn +@r5index vector-length +@deffn primitive vector-length vector +Returns the number of elements in @var{vector} as an exact integer. +@end deffn + +@r5index vector-ref +@deffn primitive vector-ref vector k +@var{k} must be a valid index of @var{vector}. +@samp{Vector-ref} returns the contents of element @var{k} of +@var{vector}. +@lisp +(vector-ref '#(1 1 2 3 5 8 13 21) 5) @result{} 8 +(vector-ref '#(1 1 2 3 5 8 13 21) + (let ((i (round (* 2 (acos -1))))) + (if (inexact? i) + (inexact->exact i) + i))) @result{} 13 +@end lisp +@end deffn + +@r5index vector-set! +@deffn primitive vector-set! vector k obj +@var{k} must be a valid index of @var{vector}. +@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}. +The value returned by @samp{vector-set!} is unspecified. +@lisp +(let ((vec (vector 0 '(2 2 2 2) "Anna"))) + (vector-set! vec 1 '("Sue" "Sue")) + vec) @result{} #(0 ("Sue" "Sue") "Anna") +(vector-set! '#(0 1 2) 1 "doe") @result{} @emph{error} ; constant vector +@end lisp +@end deffn @node Hooks @section Hooks diff --git a/doc/scheme-evaluation.texi b/doc/scheme-evaluation.texi index 95c4910f8..31e99ad7a 100644 --- a/doc/scheme-evaluation.texi +++ b/doc/scheme-evaluation.texi @@ -72,6 +72,7 @@ this procedure directly, use the procedures @code{read-enable}, @code{read-disable}, @code{read-set!} and @var{read-options}. @end deffn +@r5index read @c docstring begin (texi-doc-string "guile" "read") @deffn primitive read [port] Read an s-expression from the input port @var{port}, or from @@ -83,6 +84,7 @@ Any whitespace before the next token is discarded. @node Fly Evaluation @section Procedures for On the Fly Evaluation +@r5index eval @c ARGFIXME environment/environment specifier @c docstring begin (texi-doc-string "guile" "eval") @deffn primitive eval exp environment @@ -90,6 +92,7 @@ Evaluate @var{exp}, a list representing a Scheme expression, in the environment given by @var{environment specifier}. @end deffn +@r5index interaction-environment @c docstring begin (texi-doc-string "guile" "interaction-environment") @deffn primitive interaction-environment This procedure returns a specifier for the environment that contains @@ -117,6 +120,13 @@ Note: Rather than do new consing, @code{apply:nconc2last} destroys its argument, so use with care. @end deffn +@r5index apply +@deffn primitive apply proc arg1 @dots{} args +@var{proc} must be a procedure and @var{args} must be a list. Call +@var{proc} with the elements of the list @code{(append (list @var{arg1} +@dots{}) @var{args})} as the actual arguments. +@end deffn + @deffn primitive primitive-eval exp Evaluate @var{exp} in the top-level environment specified by the current module. @@ -141,6 +151,15 @@ signalled. @node Loading @section Loading Scheme Code from File +@r5index load +@deffn procedure load filename +Load @var{file} and evaluate its contents in the top-level environment. +The load paths are searched. If the variable @code{%load-hook} is +defined, it should be bound to a procedure that will be called before +any code is loaded. See documentation for @code{%load-hook} later in +this section. +@end deffn + @c ARGFIXME file/filename @c docstring begin (texi-doc-string "guile" "primitive-load") @deffn primitive primitive-load filename @@ -213,6 +232,7 @@ Return true if @var{obj} is a promise, i.e. a delayed computation (@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}). @end deffn +@r5index force @c docstring begin (texi-doc-string "guile" "force") @deffn primitive force x If the promise X has not been computed yet, compute and return diff --git a/doc/scheme-io.texi b/doc/scheme-io.texi index a3de2f1a8..a98e96eb7 100644 --- a/doc/scheme-io.texi +++ b/doc/scheme-io.texi @@ -32,6 +32,7 @@ Because this definition is so loose, it is easy to write functions that simulate ports in software. @dfn{Soft ports} and @dfn{string ports} are two interesting and powerful examples of this technique. +@r5index input-port? @c docstring begin (texi-doc-string "guile" "input-port?") @deffn primitive input-port? x Returns @code{#t} if @var{x} is an input port, otherwise returns @@ -39,6 +40,7 @@ Returns @code{#t} if @var{x} is an input port, otherwise returns @code{port?}. @end deffn +@r5index output-port? @c docstring begin (texi-doc-string "guile" "output-port?") @deffn primitive output-port? x Returns @code{#t} if @var{x} is an output port, otherwise returns @@ -58,12 +60,14 @@ Equivalent to @code{(or (input-port? X) (output-port? X))}. [Generic procedures for reading from ports.] +@r5index eof-object? @c docstring begin (texi-doc-string "guile" "eof-object?") @deffn primitive eof-object? x Returns @code{#t} if @var{x} is an end-of-file object; otherwise returns @code{#f}. @end deffn +@r5index char-ready? @c docstring begin (texi-doc-string "guile" "char-ready?") @deffn primitive char-ready? [port] Returns @code{#t} if a character is ready on input @var{port} and @@ -81,6 +85,7 @@ indistinguishable from an interactive port that has no ready characters.} @end deffn +@r5index read-char? @c docstring begin (texi-doc-string "guile" "read-char") @deffn primitive read-char [port] Returns the next character available from @var{port}, updating @@ -88,6 +93,7 @@ Returns the next character available from @var{port}, updating characters are available, an end-of-file object is returned. @end deffn +@r5index peek-char? @c docstring begin (texi-doc-string "guile" "peek-char") @deffn primitive peek-char [port] Returns the next character available from @var{port}, @@ -195,6 +201,7 @@ Return the print state of the port @var{port}. If @var{port} has no associated print state, @code{#f} is returned. @end deffn +@r5index newline @c docstring begin (texi-doc-string "guile" "newline") @deffn primitive newline [port] Send a newline to @var{port}. @@ -228,6 +235,7 @@ port, if @var{destination} is @code{#f}, then return a string containing the formatted text. Does not add a trailing newline. @end deffn +@r5index write-char @c docstring begin (texi-doc-string "guile" "write-char") @deffn primitive write-char chr [port] Send character @var{chr} to @var{port}. @@ -265,6 +273,7 @@ See also @ref{Ports and File Descriptors, close}, for a procedure which can close file descriptors. @end deffn +@r5index close-input-port @c docstring begin (texi-doc-string "guile" "close-input-port") @deffn primitive close-input-port port Close the specified input port object. The routine has no effect if @@ -275,6 +284,7 @@ See also @ref{Ports and File Descriptors, close}, for a procedure which can close file descriptors. @end deffn +@r5index close-output-port @c docstring begin (texi-doc-string "guile" "close-output-port") @deffn primitive close-output-port port Close the specified output port object. The routine has no effect if @@ -492,6 +502,7 @@ If omitted, @var{port} defaults to the current output port. @node Default Ports @section Default Ports for Input, Output and Errors +@r5index current-input-port @c docstring begin (texi-doc-string "guile" "current-input-port") @deffn primitive current-input-port Return the current input port. This is the default port used @@ -499,6 +510,7 @@ by many input procedures. Initially, @code{current-input-port} returns the @dfn{standard input} in Unix and C terminology. @end deffn +@r5index current-output-port @c docstring begin (texi-doc-string "guile" "current-output-port") @deffn primitive current-output-port Return the current output port. This is the default port used @@ -600,6 +612,7 @@ If a file cannot be opened with the access requested, @code{open-file} throws an exception. @end deffn +@r5index open-input-file @c begin (scm-doc-string "r4rs.scm" "open-input-file") @deffn procedure open-input-file filename Open @var{filename} for input. Equivalent to @@ -608,6 +621,7 @@ Open @var{filename} for input. Equivalent to @end smalllisp @end deffn +@r5index open-output-file @c begin (scm-doc-string "r4rs.scm" "open-output-file") @deffn procedure open-output-file filename Open @var{filename} for output. Equivalent to @@ -616,6 +630,75 @@ Open @var{filename} for output. Equivalent to @end smalllisp @end deffn +@r5index call-with-input-file +@c begin (scm-doc-string "r4rs.scm" "call-with-input-file") +@deffn procedure call-with-input-file file proc +@var{proc} should be a procedure of one argument, and @var{file} should +be a string naming a file. The file must already exist. These +procedures call @var{proc} with one argument: the port obtained by +opening the named file for input or output. If the file cannot be +opened, an error is signalled. If the procedure returns, then the port +is closed automatically and the value yielded by the procedure is +returned. If the procedure does not return, then the port will not be +closed automatically unless it is possible to prove that the port will +never again be used for a read or write operation. +@end deffn + +@r5index call-with-output-file +@c begin (scm-doc-string "r4rs.scm" "call-with-output-file") +@deffn procedure call-with-output-file file proc +@var{proc} should be a procedure of one argument, and @var{file} should +be a string naming a file. The behaviour is unspecified if the file +already exists. These procedures call @var{proc} with one argument: the +port obtained by opening the named file for input or output. If the +file cannot be opened, an error is signalled. If the procedure returns, +then the port is closed automatically and the value yielded by the +procedure is returned. If the procedure does not return, then the port +will not be closed automatically unless it is possible to prove that the +port will never again be used for a read or write operation. +@end deffn + +@r5index with-input-from-file +@c begin (scm-doc-string "r4rs.scm" "with-input-from-file") +@deffn procedure with-input-from-file file thunk +@var{thunk} must be a procedure of no arguments, and @var{file} must be +a string naming a file. The file must already exist. The file is opened +for input, an input port connected to it is made the default value +returned by @code{current-input-port}, and the @var{thunk} is called +with no arguments. When the @var{thunk} returns, the port is closed and +the previous default is restored. Returns the value yielded by +@var{thunk}. If an escape procedure is used to escape from the +continuation of these procedures, their behavior is implementation +dependent. +@end deffn + +@r5index with-output-to-file +@c begin (scm-doc-string "r4rs.scm" "with-output-to-file") +@deffn procedure with-output-to-file file thunk +@var{thunk} must be a procedure of no arguments, and @var{file} must be +a string naming a file. The effect is unspecified if the file already +exists. The file is opened for output, an output port connected to it +is made the default value returned by @code{current-output-port}, and +the @var{thunk} is called with no arguments. When the @var{thunk} +returns, the port is closed and the previous default is restored. +Returns the value yielded by @var{thunk}. If an escape procedure is +used to escape from the continuation of these procedures, their behavior +is implementation dependent. +@end deffn + +@c begin (scm-doc-string "r4rs.scm" "with-error-to-file") +@deffn procedure with-error-to-file file thunk +@var{thunk} must be a procedure of no arguments, and @var{file} must be +a string naming a file. The effect is unspecified if the file already +exists. The file is opened for output, an output port connected to it +is made the default value returned by @code{current-error-port}, and the +@var{thunk} is called with no arguments. When the @var{thunk} returns, +the port is closed and the previous default is restored. Returns the +value yielded by @var{thunk}. If an escape procedure is used to escape +from the continuation of these procedures, their behavior is +implementation dependent. +@end deffn + @c docstring begin (texi-doc-string "guile" "port-mode") @deffn primitive port-mode port Returns the port modes associated with the open port @var{port}. These diff --git a/doc/scheme-procedures.texi b/doc/scheme-procedures.texi index 64ba417e6..38ef59256 100644 --- a/doc/scheme-procedures.texi +++ b/doc/scheme-procedures.texi @@ -56,6 +56,7 @@ documentation for that procedure. Return @code{#t} if @var{obj} is a closure. @end deffn +@r5index procedure? @c docstring begin (texi-doc-string "guile" "procedure?") @deffn primitive procedure? obj Return @code{#t} if @var{obj} is a procedure. diff --git a/doc/scheme-utility.texi b/doc/scheme-utility.texi index c57a63aac..2bf1dfd0d 100644 --- a/doc/scheme-utility.texi +++ b/doc/scheme-utility.texi @@ -13,6 +13,9 @@ @node Equality @section Equality +@r5index eq? +@r5index eqv? +@r5index equal? @c docstring begin (texi-doc-string "guile" "eq?") @deffn primitive eq? x y From 656dfde1bc44990437fe814c6645a839ab5b2647 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 17 Mar 2001 02:53:09 +0000 Subject: [PATCH 0729/2047] * Removed old (unused and uninstalled) file oldprint.scm. --- ice-9/ChangeLog | 4 ++++ ice-9/oldprint.scm | 0 2 files changed, 4 insertions(+) delete mode 100644 ice-9/oldprint.scm diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 6dbd2a55c..769429847 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2001-03-17 Dirk Herrmann + + * oldprint.scm: Removed. + 2001-03-12 Mikael Djurfeldt * arrays.scm (make-array): Added quote in front of (). diff --git a/ice-9/oldprint.scm b/ice-9/oldprint.scm deleted file mode 100644 index e69de29bb..000000000 From 5e38caf19696cb23b6b7054811d7d4e896c9f5ff Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sat, 17 Mar 2001 10:01:01 +0000 Subject: [PATCH 0730/2047] * time.scm: New file. --- ice-9/ChangeLog | 4 ++++ ice-9/time.scm | 40 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 44 insertions(+) create mode 100644 ice-9/time.scm diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 769429847..4b63a538d 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2001-03-17 Keisuke Nishida + + * time.scm: New file. + 2001-03-17 Dirk Herrmann * oldprint.scm: Removed. diff --git a/ice-9/time.scm b/ice-9/time.scm new file mode 100644 index 000000000..0be666cd5 --- /dev/null +++ b/ice-9/time.scm @@ -0,0 +1,40 @@ +;;;; Copyright (C) 2001 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; + + +(define-module (ice-9 time) + :use-module (ice-9 format) + :export (time)) + +(define-macro (time form) + (let* ((gc-start (gc-run-time)) + (tms-start (times)) + (result (eval form (interaction-environment))) + (tms-end (times)) + (gc-end (gc-run-time))) + (define (get proc start end) + (/ (- (proc end) (proc start)) internal-time-units-per-second)) + (display "clock utime stime cutime cstime gctime\n") + (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n" + (get tms:clock tms-start tms-end) + (get tms:utime tms-start tms-end) + (get tms:stime tms-start tms-end) + (get tms:cutime tms-start tms-end) + (get tms:cstime tms-start tms-end) + (get id gc-start gc-end)) + result)) From 0c0ffe090ae9c83c1aeb12e507c6cd199bc4efd5 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sat, 17 Mar 2001 10:04:23 +0000 Subject: [PATCH 0731/2047] ** New module (ice-9 time) --- NEWS | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/NEWS b/NEWS index f6e2e1da1..0dbc9cd12 100644 --- a/NEWS +++ b/NEWS @@ -736,6 +736,10 @@ space" for Guile headers. This means that the compiler only is given Implements the interface to documentation strings associated with objects. +** New module (ice-9 time) + +Provides a macro `time', which displays execution time of a given form. + * Changes to the stand-alone interpreter ** New command line option --debug From 9f40cd879d951cdaa3409aef31340b2b1472921d Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 17 Mar 2001 11:32:56 +0000 Subject: [PATCH 0732/2047] * Added function scm_error_num_args_subr. --- libguile/ChangeLog | 4 ++++ libguile/error.c | 14 +++++++++++++- libguile/error.h | 1 + 3 files changed, 18 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 27198224f..a367901c9 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2001-03-17 Dirk Herrmann + + * error.[ch] (scm_error_num_args_subr): New function. + 2001-03-16 Martin Grabmueller * list.c (scm_list, scm_cons_star, scm_null_p, scm_list_p), diff --git a/libguile/error.c b/libguile/error.c index 5d441df3f..7d8b30900 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998, 2000, 2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001 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 @@ -252,6 +252,18 @@ scm_wrong_num_args (SCM proc) SCM_BOOL_F); } + +void +scm_error_num_args_subr (const char *subr) +{ + scm_error (scm_args_number_key, + NULL, + "Wrong number of arguments to ~A", + SCM_LIST1 (scm_makfrom0str (subr)), + SCM_BOOL_F); +} + + SCM_SYMBOL (scm_arg_type_key, "wrong-type-arg"); void scm_wrong_type_arg (const char *subr, int pos, SCM bad_value) diff --git a/libguile/error.h b/libguile/error.h index 1c10fd8c3..180e70d3f 100644 --- a/libguile/error.h +++ b/libguile/error.h @@ -73,6 +73,7 @@ extern void scm_out_of_range (const char *subr, SCM bad_value) extern void scm_out_of_range_pos (const char *subr, SCM bad_value, SCM pos) SCM_NORETURN; extern void scm_wrong_num_args (SCM proc) SCM_NORETURN; +extern void scm_error_num_args_subr (const char* subr) SCM_NORETURN; extern void scm_wrong_type_arg (const char *subr, int pos, SCM bad_value) SCM_NORETURN; extern void scm_wrong_type_arg_msg (const char *subr, int pos, From 68baa7e7f8088e21eaa3d0b568a985528314ada5 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 17 Mar 2001 12:20:36 +0000 Subject: [PATCH 0733/2047] * validate.h (SCM_WRONG_NUM_ARGS): Call scm_error_num_args_subr instead of scm_wrong_num_args. * coop-threads.c: Don't include libguile/strings.h. (Was only needed for former implementation of SCM_WRONG_NUM_ARGS.) * debug.c (scm_m_start_stack): Don't use SCM_ASSERT to check for wrong-num-args errors. --- libguile/ChangeLog | 11 +++++++++++ libguile/coop-threads.c | 1 - libguile/debug.c | 17 +++++++++-------- libguile/validate.h | 4 ++-- 4 files changed, 22 insertions(+), 11 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index a367901c9..bbf67e72e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2001-03-17 Dirk Herrmann + + * validate.h (SCM_WRONG_NUM_ARGS): Call scm_error_num_args_subr + instead of scm_wrong_num_args. + + * coop-threads.c: Don't include libguile/strings.h. (Was only + needed for former implementation of SCM_WRONG_NUM_ARGS.) + + * debug.c (scm_m_start_stack): Don't use SCM_ASSERT to check for + wrong-num-args errors. + 2001-03-17 Dirk Herrmann * error.[ch] (scm_error_num_args_subr): New function. diff --git a/libguile/coop-threads.c b/libguile/coop-threads.c index b8e52ef5f..e76f9179c 100644 --- a/libguile/coop-threads.c +++ b/libguile/coop-threads.c @@ -47,7 +47,6 @@ #include "libguile/validate.h" #include "libguile/coop-threads.h" #include "libguile/root.h" -#include "libguile/strings.h" /* A counter of the current number of threads */ size_t scm_thread_count = 0; diff --git a/libguile/debug.c b/libguile/debug.c index 354ddd6e6..7c1cf8bc4 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -1,5 +1,5 @@ - /* Debugging extensions for Guile - * Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 Free Software Foundation +/* Debugging extensions for Guile + * Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation * * 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 @@ -543,16 +543,17 @@ SCM_SYNTAX(s_start_stack, "start-stack", scm_makacro, scm_m_start_stack); static SCM scm_m_start_stack (SCM exp, SCM env) +#define FUNC_NAME s_start_stack { exp = SCM_CDR (exp); - SCM_ASSERT (SCM_ECONSP (exp) - && SCM_ECONSP (SCM_CDR (exp)) - && SCM_NULLP (SCM_CDDR (exp)), - exp, - SCM_WNA, - s_start_stack); + if (!SCM_ECONSP (exp) + || !SCM_ECONSP (SCM_CDR (exp)) + || !SCM_NULLP (SCM_CDDR (exp))) + SCM_WRONG_NUM_ARGS (); return scm_start_stack (scm_eval_car (exp, env), SCM_CADR (exp), env); } +#undef FUNC_NAME + /* {Debug Objects} * diff --git a/libguile/validate.h b/libguile/validate.h index 969b412ad..a75e7eea2 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -1,4 +1,4 @@ -/* $Id: validate.h,v 1.28 2001-03-15 11:24:45 mgrabmue Exp $ */ +/* $Id: validate.h,v 1.29 2001-03-17 12:20:36 dirk Exp $ */ /* Copyright (C) 1999, 2000 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify @@ -58,7 +58,7 @@ do { scm_misc_error (FUNC_NAME, str, args); } while (0) #define SCM_WRONG_NUM_ARGS() \ - do { scm_wrong_num_args (scm_makfrom0str (FUNC_NAME)); } while (0) + do { scm_error_num_args_subr (FUNC_NAME); } while (0) #define SCM_WRONG_TYPE_ARG(pos, obj) \ do { scm_wrong_type_arg (FUNC_NAME, pos, obj); } while (0) From b3fcac341bca85278d1694d09e2d3207edb5ab94 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 17 Mar 2001 13:34:21 +0000 Subject: [PATCH 0734/2047] * __scm.h (SCM_ASSERT, SCM_WTA_DISPATCH_0, SCM_WTA_DISPATCH_1, SCM_WTA_DISPATCH_2, SCM_WTA_DISPATCH_n): Don't call scm_wta, call scm_wrong_type_arg instead. (SCM_WNA): Deprecated. * error.[ch] (scm_wta): Deprecated. * numbers.c (s_i_log): Minor comment fix. * read.c (scm_lreadr), unif.c (scm_aind, scm_shap2ra, scm_make_shared_array, scm_transpose_array, scm_enclose_array, scm_array_in_bounds_p): Don't use SCM_ASSERT to check for wrong-num-args or misc errors. * unif.c (scm_make_shared_array, scm_transpose_array, scm_enclose_array, scm_array_in_bounds_p, scm_array_set_x): Validate the rest argument (note: this is only done when guile is built with SCM_DEBUG_REST_ARGUMENT=1) (scm_array_in_bounds_p, scm_uniform_vector_ref, scm_array_set_x): Replace calls to scm_wrong_num_args by SCM_WRONG_NUM_ARGS. * validate.h (SCM_FUNC_NAME, SCM_VALIDATE_NUMBER_COPY, SCM_VALIDATE_NUMBER_DEF_COPY): Deprecated. --- NEWS | 10 +++++- RELEASE | 5 ++- libguile/ChangeLog | 28 +++++++++++++++ libguile/__scm.h | 24 ++++++------- libguile/error.c | 11 +++--- libguile/error.h | 2 +- libguile/numbers.c | 2 +- libguile/read.c | 3 +- libguile/unif.c | 88 +++++++++++++++++++++++++++------------------ libguile/validate.h | 52 +++++++++++++-------------- 10 files changed, 140 insertions(+), 85 deletions(-) diff --git a/NEWS b/NEWS index 0dbc9cd12..ed4a97378 100644 --- a/NEWS +++ b/NEWS @@ -572,7 +572,9 @@ SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR, SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING, SCM_ROCHARS, SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS, SCM_LENGTH_MAX, SCM_GC8MARKP, SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR, SCM_SUBR_DOC, -SCM_OPDIRP, SCM_VALIDATE_OPDIR, SCM_WTA, RETURN_SCM_WTA, SCM_CONST_LONG +SCM_OPDIRP, SCM_VALIDATE_OPDIR, SCM_WTA, RETURN_SCM_WTA, SCM_CONST_LONG, +SCM_WNA, SCM_FUNC_NAME, SCM_VALIDATE_NUMBER_COPY, +SCM_VALIDATE_NUMBER_DEF_COPY Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of SCM_OUTOFRANGE. Use scm_memory_error instead of SCM_NALLOC. @@ -600,6 +602,7 @@ Use SCM_DIR_OPEN_P instead of SCM_OPDIRP. Use SCM_MISC_ERROR or SCM_WRONG_TYPE_ARG instead of SCM_WTA. Use SCM_MISC_ERROR or SCM_WRONG_TYPE_ARG instead of RETURN_SCM_WTA. Use SCM_VCELL_INIT instead of SCM_CONST_LONG. +Use SCM_WRONG_NUM_ARGS instead of SCM_WNA. ** Removed function: scm_struct_init @@ -646,6 +649,11 @@ This can be used to set an apply function to a smob type. Use scm_object_to_string instead. +** Deprecated function: scm_wta + +Use scm_wrong_type_arg, or another appropriate error signalling function +instead. + Changes since Guile 1.3.4: diff --git a/RELEASE b/RELEASE index 70c1f8f28..d7bd44236 100644 --- a/RELEASE +++ b/RELEASE @@ -59,7 +59,9 @@ In release 1.6: SCM_COERCE_SUBSTR, SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING, SCM_ROCHARS, SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS, SCM_LENGTH_MAX, SCM_GC8MARKP, SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR, - SCM_SUBR_DOC, SCM_OPDIRP, SCM_VALIDATE_OPDIR, SCM_WTA, RETURN_SCM_WTA + SCM_SUBR_DOC, SCM_OPDIRP, SCM_VALIDATE_OPDIR, SCM_WTA, RETURN_SCM_WTA, + SCM_WNA, SCM_FUNC_NAME, SCM_VALIDATE_NUMBER_COPY, + SCM_VALIDATE_NUMBER_DEF_COPY - remove scm_vector_set_length_x - remove function scm_call_catching_errors (replaced by catch functions from throw.[ch]) @@ -80,6 +82,7 @@ In release 1.6: - remove scm_close_all_ports_except - remove scm_strprint_obj - remove SCM_CONST_LONG +- remove scm_wta Modules sort.c and random.c should be factored out into separate modules (but still be distributed with guile-core) when we get a new diff --git a/libguile/ChangeLog b/libguile/ChangeLog index bbf67e72e..b6e4a09fc 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,31 @@ +2001-03-17 Dirk Herrmann + + * __scm.h (SCM_ASSERT, SCM_WTA_DISPATCH_0, SCM_WTA_DISPATCH_1, + SCM_WTA_DISPATCH_2, SCM_WTA_DISPATCH_n): Don't call scm_wta, call + scm_wrong_type_arg instead. + + (SCM_WNA): Deprecated. + + * error.[ch] (scm_wta): Deprecated. + + * numbers.c (s_i_log): Minor comment fix. + + * read.c (scm_lreadr), unif.c (scm_aind, scm_shap2ra, + scm_make_shared_array, scm_transpose_array, scm_enclose_array, + scm_array_in_bounds_p): Don't use SCM_ASSERT to check for + wrong-num-args or misc errors. + + * unif.c (scm_make_shared_array, scm_transpose_array, + scm_enclose_array, scm_array_in_bounds_p, scm_array_set_x): + Validate the rest argument (note: this is only done when guile is + built with SCM_DEBUG_REST_ARGUMENT=1) + + (scm_array_in_bounds_p, scm_uniform_vector_ref, scm_array_set_x): + Replace calls to scm_wrong_num_args by SCM_WRONG_NUM_ARGS. + + * validate.h (SCM_FUNC_NAME, SCM_VALIDATE_NUMBER_COPY, + SCM_VALIDATE_NUMBER_DEF_COPY): Deprecated. + 2001-03-17 Dirk Herrmann * validate.h (SCM_WRONG_NUM_ARGS): Call scm_error_num_args_subr diff --git a/libguile/__scm.h b/libguile/__scm.h index d48ae66d6..97d0a903a 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -2,7 +2,7 @@ #ifndef __SCMH #define __SCMH -/* Copyright (C) 1995, 1996, 1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001 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 @@ -488,7 +488,7 @@ do { \ #else #define SCM_ASSERT(_cond, _arg, _pos, _subr) \ if (!(_cond)) \ - scm_wta(_arg, (char *)(_pos), _subr) + scm_wrong_type_arg (_subr, _pos, _arg) #define SCM_ASSERT_TYPE(_cond, _arg, _pos, _subr, _msg) \ if (!(_cond)) \ scm_wrong_type_arg_msg(_subr, _pos, _arg, _msg) @@ -511,7 +511,7 @@ extern SCM scm_call_generic_0 (SCM gf); #define SCM_WTA_DISPATCH_0(gf, arg, pos, subr) \ return (SCM_UNPACK (gf) \ ? scm_call_generic_0 ((gf)) \ - : scm_wta ((arg), (char *) (pos), (subr))) + : scm_wrong_type_arg ((subr), (pos), (arg)), 0) #define SCM_GASSERT0(cond, gf, arg, pos, subr) \ if (!(cond)) SCM_WTA_DISPATCH_0((gf), (arg), (pos), (subr)) @@ -520,7 +520,7 @@ extern SCM scm_call_generic_1 (SCM gf, SCM a1); #define SCM_WTA_DISPATCH_1(gf, a1, pos, subr) \ return (SCM_UNPACK (gf) \ ? scm_call_generic_1 ((gf), (a1)) \ - : scm_wta ((a1), (char *) (pos), (subr))) + : scm_wrong_type_arg ((subr), (pos), (a1)), 0) #define SCM_GASSERT1(cond, gf, a1, pos, subr) \ if (!(cond)) SCM_WTA_DISPATCH_1((gf), (a1), (pos), (subr)) @@ -529,7 +529,8 @@ extern SCM scm_call_generic_2 (SCM gf, SCM a1, SCM a2); #define SCM_WTA_DISPATCH_2(gf, a1, a2, pos, subr) \ return (SCM_UNPACK (gf) \ ? scm_call_generic_2 ((gf), (a1), (a2)) \ - : scm_wta ((pos) == SCM_ARG1 ? (a1) : (a2), (char *) (pos), (subr))) + : scm_wrong_type_arg ((subr), (pos), \ + (pos) == SCM_ARG1 ? (a1) : (a2)), 0) #define SCM_GASSERT2(cond, gf, a1, a2, pos, subr) \ if (!(cond)) SCM_WTA_DISPATCH_2((gf), (a1), (a2), (pos), (subr)) @@ -538,9 +539,9 @@ extern SCM scm_apply_generic (SCM gf, SCM args); #define SCM_WTA_DISPATCH_n(gf, args, pos, subr) \ return (SCM_UNPACK (gf) \ ? scm_apply_generic ((gf), (args)) \ - : scm_wta (scm_list_ref ((args), SCM_MAKINUM ((pos) - 1)), \ - (char *) (pos), \ - (subr))) + : scm_wrong_type_arg ((subr), (pos), \ + scm_list_ref ((args), \ + SCM_MAKINUM ((pos) - 1))), 0) #define SCM_GASSERTn(cond, gf, args, pos, subr) \ if (!(cond)) SCM_WTA_DISPATCH_n((gf), (args), (pos), (subr)) @@ -562,12 +563,11 @@ extern SCM scm_apply_generic (SCM gf, SCM args); #define SCM_ARG6 6 #define SCM_ARG7 7 -/* SCM_WNA must follow the last SCM_ARGn in sequence. - */ -#define SCM_WNA 8 - #if (SCM_DEBUG_DEPRECATED == 0) +/* Use SCM_WRONG_NUM_ARGS instead of: */ +#define SCM_WNA 8 + /* Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of: */ #define SCM_OUTOFRANGE 10 diff --git a/libguile/error.c b/libguile/error.c index 7d8b30900..9073e2afe 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -314,7 +314,8 @@ scm_misc_error (const char *subr, const char *message, SCM args) scm_error (scm_misc_error_key, subr, message, args, SCM_BOOL_F); } -/* implements the SCM_ASSERT interface. */ +#if (SCM_DEBUG_DEPRECATED == 0) + SCM scm_wta (SCM arg, const char *pos, const char *s_subr) { @@ -350,16 +351,10 @@ scm_wta (SCM arg, const char *pos, const char *s_subr) scm_wrong_type_arg (s_subr, 7, arg); case SCM_WNA: scm_wrong_num_args (arg); - -#if (SCM_DEBUG_DEPRECATED == 0) - case SCM_OUTOFRANGE: scm_out_of_range (s_subr, arg); case SCM_NALLOC: scm_memory_error (s_subr); - -#endif /* SCM_DEBUG_DEPRECATED == 0 */ - default: /* this shouldn't happen. */ scm_misc_error (s_subr, "Unknown error", SCM_EOL); @@ -368,6 +363,8 @@ scm_wta (SCM arg, const char *pos, const char *s_subr) return SCM_UNSPECIFIED; } +#endif /* SCM_DEBUG_DEPRECATED == 0 */ + void scm_init_error () { diff --git a/libguile/error.h b/libguile/error.h index 180e70d3f..ea7d8d2fc 100644 --- a/libguile/error.h +++ b/libguile/error.h @@ -81,7 +81,6 @@ extern void scm_wrong_type_arg_msg (const char *subr, int pos, extern void scm_memory_error (const char *subr) SCM_NORETURN; extern void scm_misc_error (const char *subr, const char *message, SCM args) SCM_NORETURN; -extern SCM scm_wta (SCM arg, const char *pos, const char *s_subr); extern void scm_init_error (void); @@ -89,6 +88,7 @@ extern void scm_init_error (void); #if (SCM_DEBUG_DEPRECATED == 0) extern void scm_sysmissing (const char *subr) SCM_NORETURN; +extern SCM scm_wta (SCM arg, const char *pos, const char *s_subr); #endif /* SCM_DEBUG_DEPRECATED == 0 */ diff --git a/libguile/numbers.c b/libguile/numbers.c index 335c5c233..37dcb106e 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -4000,7 +4000,7 @@ SCM_GPROC1 (s_i_exp, "$exp", scm_tc7_cxr, (SCM (*)()) exp, g_i_exp); /* "Return the @var{x}th power of e." */ SCM_GPROC1 (s_i_log, "$log", scm_tc7_cxr, (SCM (*)()) log, g_i_log); -/* "Return the natural logarithm of the real number@var{x}." +/* "Return the natural logarithm of the real number @var{x}." */ SCM_GPROC1 (s_i_sin, "$sin", scm_tc7_cxr, (SCM (*)()) sin, g_i_sin); /* "Return the sine of the real number @var{x}." diff --git a/libguile/read.c b/libguile/read.c index a3ad5daea..578e35330 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -445,7 +445,8 @@ tryagain_no_flush_ws: j = 0; while ('"' != (c = scm_getc (port))) { - SCM_ASSERT (EOF != c, SCM_UNDEFINED, "end of file in ", "string"); + if (c == EOF) + SCM_MISC_ERROR ("end of file in string constant", SCM_EOL); while (j + 2 >= SCM_STRING_LENGTH (*tok_buf)) scm_grow_tok_buf (tok_buf); diff --git a/libguile/unif.c b/libguile/unif.c index f45236078..eb2fcb409 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998, 2000, 2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001 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 @@ -485,6 +485,7 @@ static char s_bad_ind[] = "Bad scm_array index"; long scm_aind (SCM ra, SCM args, const char *what) +#define FUNC_NAME what { SCM ind; register long j; @@ -493,14 +494,16 @@ scm_aind (SCM ra, SCM args, const char *what) scm_array_dim *s = SCM_ARRAY_DIMS (ra); if (SCM_INUMP (args)) { - SCM_ASSERT (1 == k, scm_makfrom0str (what), SCM_WNA, NULL); + if (k != 1) + scm_error_num_args_subr (what); return pos + (SCM_INUM (args) - s->lbnd) * (s->inc); } while (k && SCM_NIMP (args)) { ind = SCM_CAR (args); args = SCM_CDR (args); - SCM_ASSERT (SCM_INUMP (ind), ind, s_bad_ind, what); + if (!SCM_INUMP (ind)) + scm_misc_error (what, s_bad_ind, SCM_EOL); j = SCM_INUM (ind); if (j < s->lbnd || j > s->ubnd) scm_out_of_range (what, ind); @@ -508,11 +511,12 @@ scm_aind (SCM ra, SCM args, const char *what) k--; s++; } - SCM_ASSERT (0 == k && SCM_NULLP (args), scm_makfrom0str (what), SCM_WNA, - NULL); + if (k != 0 || !SCM_NULLP (args)) + scm_error_num_args_subr (what); + return pos; } - +#undef FUNC_NAME SCM @@ -539,7 +543,9 @@ scm_shap2ra (SCM args, const char *what) scm_array_dim *s; SCM ra, spec, sp; int ndim = scm_ilength (args); - SCM_ASSERT (0 <= ndim, args, s_bad_spec, what); + if (ndim < 0) + scm_misc_error (what, s_bad_spec, SCM_EOL); + ra = scm_make_ra (ndim); SCM_ARRAY_BASE (ra) = 0; s = SCM_ARRAY_DIMS (ra); @@ -548,20 +554,22 @@ scm_shap2ra (SCM args, const char *what) spec = SCM_CAR (args); if (SCM_INUMP (spec)) { - SCM_ASSERT (SCM_INUM (spec) >= 0, spec, s_bad_spec, what); + if (SCM_INUM (spec) < 0) + scm_misc_error (what, s_bad_spec, SCM_EOL); s->lbnd = 0; s->ubnd = SCM_INUM (spec) - 1; s->inc = 1; } else { - SCM_ASSERT (SCM_CONSP (spec) && SCM_INUMP (SCM_CAR (spec)), spec, - s_bad_spec, what); + if (!SCM_CONSP (spec) || !SCM_INUMP (SCM_CAR (spec))) + scm_misc_error (what, s_bad_spec, SCM_EOL); s->lbnd = SCM_INUM (SCM_CAR (spec)); sp = SCM_CDR (spec); - SCM_ASSERT (SCM_CONSP (sp) - && SCM_INUMP (SCM_CAR (sp)) && SCM_NULLP (SCM_CDR (sp)), - spec, s_bad_spec, what); + if (!SCM_CONSP (sp) + || !SCM_INUMP (SCM_CAR (sp)) + || !SCM_NULLP (SCM_CDR (sp))) + scm_misc_error (what, s_bad_spec, SCM_EOL); s->ubnd = SCM_INUM (SCM_CAR (sp)); s->inc = 1; } @@ -670,6 +678,8 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, scm_sizet i, k; long old_min, new_min, old_max, new_max; scm_array_dim *s; + + SCM_VALIDATE_REST_ARGUMENT (dims); SCM_VALIDATE_ARRAY (1,oldra); SCM_VALIDATE_PROC (2,mapfunc); ra = scm_shap2ra (dims, FUNC_NAME); @@ -715,8 +725,8 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, if (SCM_NINUMP (imap)) { - SCM_ASSERT (1 == scm_ilength (imap) && SCM_INUMP (SCM_CAR (imap)), - imap, s_bad_ind, FUNC_NAME); + if (scm_ilength (imap) != 1 || !SCM_INUMP (SCM_CAR (imap))) + SCM_MISC_ERROR (s_bad_ind, SCM_EOL); imap = SCM_CAR (imap); } i = SCM_INUM (imap); @@ -736,10 +746,9 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, else { if (SCM_NINUMP (imap)) - { - SCM_ASSERT (1 == scm_ilength (imap) && SCM_INUMP (SCM_CAR (imap)), - imap, s_bad_ind, FUNC_NAME); + if (scm_ilength (imap) != 1 || !SCM_INUMP (SCM_CAR (imap))) + SCM_MISC_ERROR (s_bad_ind, SCM_EOL); imap = SCM_CAR (imap); } s[k].inc = (long) SCM_INUM (imap) - i; @@ -754,8 +763,8 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, s[k].inc = new_max - new_min + 1; /* contiguous by default */ indptr = SCM_CDR (indptr); } - SCM_ASSERT (old_min <= new_min && old_max >= new_max, SCM_UNDEFINED, - "mapping out of range", FUNC_NAME); + if (old_min > new_min || old_max < new_max) + SCM_MISC_ERROR ("mapping out of range", SCM_EOL); if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra)) { SCM v = SCM_ARRAY_V (ra); @@ -797,6 +806,7 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, scm_array_dim *s, *r; int ndim, i, k; + SCM_VALIDATE_REST_ARGUMENT (args); SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME); switch (SCM_TYP7 (ra)) { @@ -814,19 +824,18 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: #endif - SCM_ASSERT (!SCM_NULLP (args) && SCM_NULLP (SCM_CDR (args)), - scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); - SCM_ASSERT (SCM_INUMP (SCM_CAR (args)), SCM_CAR (args), SCM_ARG2, - FUNC_NAME); + if (SCM_NULLP (args) || !SCM_NULLP (SCM_CDR (args))) + SCM_WRONG_NUM_ARGS (); + SCM_VALIDATE_INUM (SCM_ARG2, SCM_CAR (args)); SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), SCM_EQ_P (SCM_INUM0, SCM_CAR (args))); return ra; case scm_tc7_smob: SCM_ASRTGO (SCM_ARRAYP (ra), badarg); vargs = scm_vector (args); - SCM_ASSERT (SCM_VECTOR_LENGTH (vargs) == SCM_ARRAY_NDIM (ra), - scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); - ve = SCM_VELTS (vargs); + if (SCM_VECTOR_LENGTH (vargs) != SCM_ARRAY_NDIM (ra)) + SCM_WRONG_NUM_ARGS (); + ve = SCM_VELTS (vargs); ndim = 0; for (k = 0; k < SCM_ARRAY_NDIM (ra); k++) { @@ -871,7 +880,8 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, r->inc += s->inc; } } - SCM_ASSERT (ndim <= 0, args, "bad argument list", FUNC_NAME); + if (ndim > 0) + SCM_MISC_ERROR ("bad argument list", SCM_EOL); scm_ra_set_contp (res); return res; } @@ -905,10 +915,12 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, scm_array_dim vdim, *s = &vdim; int ndim, j, k, ninr, noutr; + SCM_VALIDATE_REST_ARGUMENT (axes); if (SCM_NULLP (axes)) axes = scm_cons ((SCM_ARRAYP (ra) ? SCM_MAKINUM (SCM_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL); ninr = scm_ilength (axes); - SCM_ASSERT (0 <= ninr, scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); + if (ninr < 0) + SCM_WRONG_NUM_ARGS (); ra_inr = scm_make_ra (ninr); SCM_ASRTGO (SCM_NIMP (ra), badarg1); switch SCM_TYP7 (ra) @@ -945,14 +957,16 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, break; } noutr = ndim - ninr; + if (noutr < 0) + SCM_WRONG_NUM_ARGS (); axv = scm_make_string (SCM_MAKINUM (ndim), SCM_MAKE_CHAR (0)); - SCM_ASSERT (0 <= noutr, scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); res = scm_make_ra (noutr); SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra_inr); SCM_ARRAY_V (res) = ra_inr; for (k = 0; k < ninr; k++, axes = SCM_CDR (axes)) { - SCM_ASSERT (SCM_INUMP (SCM_CAR (axes)), SCM_CAR (axes), "bad axis", FUNC_NAME); + if (!SCM_INUMP (SCM_CAR (axes))) + SCM_MISC_ERROR ("bad axis", SCM_EOL); j = SCM_INUM (SCM_CAR (axes)); SCM_ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd; SCM_ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd; @@ -986,6 +1000,7 @@ SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1, register long j; scm_array_dim *s; + SCM_VALIDATE_REST_ARGUMENT (args); SCM_ASRTGO (SCM_NIMP (v), badarg1); if (SCM_NIMP (args)) @@ -1000,7 +1015,7 @@ tail: { default: badarg1:SCM_WRONG_TYPE_ARG (1, v); - wna: scm_wrong_num_args (scm_makfrom0str (FUNC_NAME)); + wna: SCM_WRONG_NUM_ARGS (); case scm_tc7_smob: k = SCM_ARRAY_NDIM (v); s = SCM_ARRAY_DIMS (v); @@ -1025,7 +1040,8 @@ tail: ind = SCM_CAR (args); args = SCM_CDR (args); s++; - SCM_ASSERT (SCM_INUMP (ind), ind, s_bad_ind, FUNC_NAME); + if (!SCM_INUMP (ind)) + SCM_MISC_ERROR (s_bad_ind, SCM_EOL); } SCM_ASRTGO (0 == k, wna); v = SCM_ARRAY_V (v); @@ -1104,7 +1120,7 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, outrng: scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos)); wna: - scm_wrong_num_args (SCM_FUNC_NAME); + SCM_WRONG_NUM_ARGS (); case scm_tc7_smob: { /* enclosed */ int k = SCM_ARRAY_NDIM (v); @@ -1242,6 +1258,8 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, #define FUNC_NAME s_scm_array_set_x { long pos = 0; + + SCM_VALIDATE_REST_ARGUMENT (args); SCM_ASRTGO (SCM_NIMP (v), badarg1); if (SCM_ARRAYP (v)) { @@ -1273,7 +1291,7 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, outrng: scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos)); wna: - scm_wrong_num_args (SCM_FUNC_NAME); + SCM_WRONG_NUM_ARGS (); case scm_tc7_smob: /* enclosed */ goto badarg1; case scm_tc7_bvect: diff --git a/libguile/validate.h b/libguile/validate.h index a75e7eea2..0a147df49 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -1,4 +1,4 @@ -/* $Id: validate.h,v 1.29 2001-03-17 12:20:36 dirk Exp $ */ +/* $Id: validate.h,v 1.30 2001-03-17 13:34:21 dirk Exp $ */ /* Copyright (C) 1999, 2000 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify @@ -45,8 +45,6 @@ #ifndef SCM_VALIDATE_H__ #define SCM_VALIDATE_H__ -#define SCM_FUNC_NAME (scm_makfrom0str (FUNC_NAME)) - #define SCM_SYSERROR do { scm_syserror (FUNC_NAME); } while (0) #define SCM_MEMORY_ERROR do { scm_memory_error (FUNC_NAME); } while (0) @@ -149,29 +147,6 @@ #define SCM_VALIDATE_NUMBER(pos, z) SCM_MAKE_VALIDATE (pos, z, NUMBERP) -#define SCM_VALIDATE_NUMBER_COPY(pos, z, cvar) \ - do { \ - if (SCM_INUMP (z)) \ - cvar = (double) SCM_INUM (z); \ - else if (SCM_REALP (z)) \ - cvar = SCM_REAL_VALUE (z); \ - else if (SCM_BIGP (z)) \ - cvar = scm_big2dbl (z); \ - else \ - { \ - cvar = 0.0; \ - SCM_WRONG_TYPE_ARG (pos, z); \ - } \ - } while (0) - -#define SCM_VALIDATE_NUMBER_DEF_COPY(pos, number, def, cvar) \ - do { \ - if (SCM_UNBNDP (number)) \ - cvar = def; \ - else \ - SCM_VALIDATE_NUMBER_COPY(pos, number, cvar); \ - } while (0) - #define SCM_VALIDATE_INUM(pos, k) SCM_MAKE_VALIDATE (pos, k, INUMP) #define SCM_VALIDATE_INUM_COPY(pos, k, cvar) \ @@ -405,12 +380,37 @@ #if (SCM_DEBUG_DEPRECATED == 0) +#define SCM_FUNC_NAME (scm_makfrom0str (FUNC_NAME)) + #define SCM_WTA(pos, scm) \ do { scm_wta (scm, (char *) pos, FUNC_NAME); } while (0) #define RETURN_SCM_WTA(pos, scm) \ do { return scm_wta (scm, (char *) pos, FUNC_NAME); } while (0) +#define SCM_VALIDATE_NUMBER_COPY(pos, z, cvar) \ + do { \ + if (SCM_INUMP (z)) \ + cvar = (double) SCM_INUM (z); \ + else if (SCM_REALP (z)) \ + cvar = SCM_REAL_VALUE (z); \ + else if (SCM_BIGP (z)) \ + cvar = scm_big2dbl (z); \ + else \ + { \ + cvar = 0.0; \ + SCM_WRONG_TYPE_ARG (pos, z); \ + } \ + } while (0) + +#define SCM_VALIDATE_NUMBER_DEF_COPY(pos, number, def, cvar) \ + do { \ + if (SCM_UNBNDP (number)) \ + cvar = def; \ + else \ + SCM_VALIDATE_NUMBER_COPY(pos, number, cvar); \ + } while (0) + #define SCM_VALIDATE_STRINGORSUBSTR SCM_VALIDATE_STRING #define SCM_VALIDATE_ROSTRING(pos, str) SCM_MAKE_VALIDATE (pos, str, ROSTRINGP) From 870777d7c7ec87ddbe0853dfa46f628bd39b3aa9 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sat, 17 Mar 2001 15:32:17 +0000 Subject: [PATCH 0735/2047] Simple value history support. --- ice-9/ChangeLog | 8 ++++++++ ice-9/boot-9.scm | 24 +++++++++++++++++------- ice-9/history.scm | 39 +++++++++++++++++++++++++++++++++++++++ 3 files changed, 64 insertions(+), 7 deletions(-) create mode 100644 ice-9/history.scm diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 4b63a538d..7f0bac07f 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,11 @@ +2001-03-17 Keisuke Nishida + + * boot-9.scm (before-eval-hook, after-eval-hook, + before-print-hook, after-print-hook): New hooks. + (scm-style-repl): Call these hooks. + + * history.scm: New file. + 2001-03-17 Keisuke Nishida * time.scm: New file. diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 2ba387843..a1ac4d140 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -2326,6 +2326,10 @@ (define before-read-hook (make-hook)) (define after-read-hook (make-hook)) +(define before-eval-hook (make-hook 1)) +(define after-eval-hook (make-hook 1)) +(define before-print-hook (make-hook 1)) +(define after-print-hook (make-hook 1)) ;;; The default repl-reader function. We may override this if we've ;;; the readline library. @@ -2402,13 +2406,17 @@ (-eval (lambda (sourc) (repl-report-start-timing) - (start-stack 'repl-stack - ;; If you change this procedure - ;; (primitive-eval), please also - ;; modify the repl-stack case in - ;; save-stack so that stack cutting - ;; continues to work. - (primitive-eval sourc)))) + (run-hook before-eval-hook sourc) + (let ((val (start-stack 'repl-stack + ;; If you change this procedure + ;; (primitive-eval), please also + ;; modify the repl-stack case in + ;; save-stack so that stack cutting + ;; continues to work. + (primitive-eval sourc)))) + (run-hook after-eval-hook sourc) + val))) + (-print (let ((maybe-print (lambda (result) (if (or scm-repl-print-unspecified @@ -2419,7 +2427,9 @@ (lambda (result) (if (not scm-repl-silent) (begin + (run-hook before-print-hook result) (maybe-print result) + (run-hook after-print-hook result) (if scm-repl-verbose (repl-report)) (force-output)))))) diff --git a/ice-9/history.scm b/ice-9/history.scm new file mode 100644 index 000000000..2eafccc8f --- /dev/null +++ b/ice-9/history.scm @@ -0,0 +1,39 @@ +;;;; Copyright (C) 2000 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; + +;;;; A simple value history support + +(define-module (ice-9 history)) + +(define (use-value-history x) + (module-use! (current-module) + (resolve-module '(value-history)))) + +(define save-value-history + (let ((count 0) + (history (resolve-module '(value-history)))) + (lambda (v) + (if (not (unspecified? v)) + (let* ((c (1+ count)) + (s (string->symbol (simple-format #f "$~A" c)))) + (simple-format #t "~A = " s) + (module-define! history s v) + (set! count c)))))) + +(add-hook! before-eval-hook use-value-history) +(add-hook! before-print-hook save-value-history) From cf7a5ee536013bbaa26b8781b33a0e3f6cee5f7e Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sat, 17 Mar 2001 15:34:46 +0000 Subject: [PATCH 0736/2047] ** New module (ice-9 history) --- NEWS | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/NEWS b/NEWS index ed4a97378..484e31ea4 100644 --- a/NEWS +++ b/NEWS @@ -748,6 +748,10 @@ objects. Provides a macro `time', which displays execution time of a given form. +** New module (ice-9 history) + +Loading this module enables value history in the repl. + * Changes to the stand-alone interpreter ** New command line option --debug From c6c79933b54d5f480b1eabbb65054706ddc3166a Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sat, 17 Mar 2001 16:59:48 +0000 Subject: [PATCH 0737/2047] * gc.c (scm_must_malloc): changed the comment explaining when scm_must variants of malloc/free etc., should be used, based on explanation from Dirk Herrmann. * fports.c (scm_fport_buffer_add): use FUNC_NAME instead of a local string with procedure name. use scm_must_malloc instead of malloc. (scm_setvbuf, scm_fdes_to_port, fport_close): use scm_must variants of malloc/free. * ports.c (scm_add_to_port_table, scm_remove_from_port_table, scm_ungetc): use scm_must variants of malloc/realloc/free. (scm_add_to_port_table, scm_ungetc): define FUNC_NAME. --- libguile/ChangeLog | 13 +++++++++++++ libguile/fports.c | 29 +++++++++++++---------------- libguile/gc.c | 9 +++++---- libguile/ports.c | 26 ++++++++++++++------------ 4 files changed, 45 insertions(+), 32 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b6e4a09fc..502325dbf 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,16 @@ +2001-03-17 Gary Houston + + * gc.c (scm_must_malloc): changed the comment explaining when + scm_must variants of malloc/free etc., should be used, based on + explanation from Dirk Herrmann. + * fports.c (scm_fport_buffer_add): use FUNC_NAME instead of a local + string with procedure name. use scm_must_malloc instead of malloc. + (scm_setvbuf, scm_fdes_to_port, fport_close): use scm_must variants + of malloc/free. + * ports.c (scm_add_to_port_table, scm_remove_from_port_table, + scm_ungetc): use scm_must variants of malloc/realloc/free. + (scm_add_to_port_table, scm_ungetc): define FUNC_NAME. + 2001-03-17 Dirk Herrmann * __scm.h (SCM_ASSERT, SCM_WTA_DISPATCH_0, SCM_WTA_DISPATCH_1, diff --git a/libguile/fports.c b/libguile/fports.c index 06dae4e6c..c062525f9 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 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 @@ -80,10 +80,10 @@ static const int default_buffer_size = 1024; 0 for no buffer. */ static void scm_fport_buffer_add (SCM port, int read_size, int write_size) +#define FUNC_NAME "scm_fport_buffer_add" { struct scm_fport *fp = SCM_FSTREAM (port); scm_port *pt = SCM_PTAB_ENTRY (port); - char *s_scm_fport_buffer_add = "scm_fport_buffer_add"; if (read_size == -1 || write_size == -1) { @@ -104,9 +104,7 @@ scm_fport_buffer_add (SCM port, int read_size, int write_size) if (SCM_INPUT_PORT_P (port) && read_size > 0) { - pt->read_buf = malloc (read_size); - if (pt->read_buf == NULL) - scm_memory_error (s_scm_fport_buffer_add); + pt->read_buf = scm_must_malloc (read_size, FUNC_NAME); pt->read_pos = pt->read_end = pt->read_buf; pt->read_buf_size = read_size; } @@ -118,9 +116,7 @@ scm_fport_buffer_add (SCM port, int read_size, int write_size) if (SCM_OUTPUT_PORT_P (port) && write_size > 0) { - pt->write_buf = malloc (write_size); - if (pt->write_buf == NULL) - scm_memory_error (s_scm_fport_buffer_add); + pt->write_buf = scm_must_malloc (write_size, FUNC_NAME); pt->write_pos = pt->write_buf; pt->write_buf_size = write_size; } @@ -136,6 +132,7 @@ scm_fport_buffer_add (SCM port, int read_size, int write_size) else SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) | SCM_BUF0); } +#undef FUNC_NAME SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, (SCM port, SCM mode, SCM size), @@ -189,9 +186,9 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, /* silently discards buffered chars. */ if (pt->read_buf != &pt->shortbuf) - free (pt->read_buf); + scm_must_free (pt->read_buf); if (pt->write_buf != &pt->shortbuf) - free (pt->write_buf); + scm_must_free (pt->write_buf); scm_fport_buffer_add (port, csize, csize); return SCM_UNSPECIFIED; @@ -386,9 +383,9 @@ scm_fdes_to_port (int fdes, char *mode, SCM name) { struct scm_fport *fp - = (struct scm_fport *) malloc (sizeof (struct scm_fport)); - if (fp == NULL) - SCM_MEMORY_ERROR; + = (struct scm_fport *) scm_must_malloc (sizeof (struct scm_fport), + FUNC_NAME); + fp->fdes = fdes; pt->rw_random = SCM_FDES_RANDOM_P (fdes); SCM_SETSTREAM (port, fp); @@ -768,10 +765,10 @@ fport_close (SCM port) if (pt->read_buf == pt->putback_buf) pt->read_buf = pt->saved_read_buf; if (pt->read_buf != &pt->shortbuf) - free (pt->read_buf); + scm_must_free (pt->read_buf); if (pt->write_buf != &pt->shortbuf) - free (pt->write_buf); - free ((char *) fp); + scm_must_free (pt->write_buf); + scm_must_free ((char *) fp); return rv; } diff --git a/libguile/gc.c b/libguile/gc.c index 264b9f3be..c99e3f0d4 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1839,10 +1839,11 @@ scm_gc_sweep () * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc, * scm_done_free * - * These functions provide services comperable to malloc, realloc, and - * free. They are for allocating malloced parts of scheme objects. - * The primary purpose of the front end is to impose calls to gc. */ - + * These functions provide services comparable to malloc, realloc, and + * free. They should be used when allocating memory that will be under + * control of the garbage collector, i.e., if the memory may be freed + * during garbage collection. + */ /* scm_must_malloc * Return newly malloced storage or throw an error. diff --git a/libguile/ports.c b/libguile/ports.c index 898de999e..04725b87e 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -431,11 +431,14 @@ int scm_port_table_room = 20; /* Size of the array. */ scm_port * scm_add_to_port_table (SCM port) +#define FUNC_NAME "scm_add_to_port_table" { scm_port *entry; if (scm_port_table_size == scm_port_table_room) { + /* initial malloc is in gc.c. this doesn't use scm_must_malloc etc., + since it can never be freed during gc. */ void *newt = realloc ((char *) scm_port_table, (scm_sizet) (sizeof (scm_port *) * scm_port_table_room * 2)); @@ -444,9 +447,7 @@ scm_add_to_port_table (SCM port) scm_port_table = (scm_port **) newt; scm_port_table_room *= 2; } - entry = (scm_port *) malloc (sizeof (scm_port)); - if (entry == NULL) - scm_memory_error ("scm_add_to_port_table"); + entry = (scm_port *) scm_must_malloc (sizeof (scm_port), FUNC_NAME); entry->port = port; entry->entry = scm_port_table_size; @@ -465,6 +466,7 @@ scm_add_to_port_table (SCM port) return entry; } +#undef FUNC_NAME /* Remove a port from the table and destroy it. */ @@ -478,8 +480,8 @@ scm_remove_from_port_table (SCM port) if (i >= scm_port_table_size) SCM_MISC_ERROR ("Port not in table: ~S", SCM_LIST1 (port)); if (p->putback_buf) - free (p->putback_buf); - free (p); + scm_must_free (p->putback_buf); + scm_must_free (p); /* Since we have just freed slot i we can shrink the table by moving the last entry to that slot... */ if (i < scm_port_table_size - 1) @@ -1101,6 +1103,7 @@ scm_end_input (SCM port) void scm_ungetc (int c, SCM port) +#define FUNC_NAME "scm_ungetc" { scm_port *pt = SCM_PTAB_ENTRY (port); @@ -1112,11 +1115,10 @@ scm_ungetc (int c, SCM port) && pt->read_buf == pt->read_pos) { int new_size = pt->read_buf_size * 2; - unsigned char *tmp = - (unsigned char *) realloc (pt->putback_buf, new_size); + unsigned char *tmp = (unsigned char *) + scm_must_realloc (pt->putback_buf, pt->read_buf_size, new_size, + FUNC_NAME); - if (tmp == NULL) - scm_memory_error ("scm_ungetc"); pt->read_pos = pt->read_buf = pt->putback_buf = tmp; pt->read_end = pt->read_buf + pt->read_buf_size; pt->read_buf_size = pt->putback_buf_size = new_size; @@ -1141,9 +1143,8 @@ scm_ungetc (int c, SCM port) if (pt->putback_buf == NULL) { pt->putback_buf - = (unsigned char *) malloc (SCM_INITIAL_PUTBACK_BUF_SIZE); - if (pt->putback_buf == NULL) - scm_memory_error ("scm_ungetc"); + = (unsigned char *) scm_must_malloc (SCM_INITIAL_PUTBACK_BUF_SIZE, + FUNC_NAME); pt->putback_buf_size = SCM_INITIAL_PUTBACK_BUF_SIZE; } @@ -1172,6 +1173,7 @@ scm_ungetc (int c, SCM port) else SCM_COL(port) -= 1; } +#undef FUNC_NAME void From e9e225e5aca12b3286d38d7da10ccf5e99057068 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sat, 17 Mar 2001 21:20:20 +0000 Subject: [PATCH 0738/2047] * configure.in: don't append threads.doc to EXTRA_DOT_DOC_FILES, since EXTRA_DOT_DOC_FILES is redefined later. define EXTRA_DOT_X_FILES and hand it to AC_SUBST. * sort.c (scm_sort): move sortvec variable to avoid a compiler warning when HAVE_ARRAYS is not defined. move len too. * Makefile.am (DOT_X_FILES): remove net_db.x, posix.x, socket.x. (EXTRA_DOT_X_FILES): let configure set the value. (DOT_DOC_FILES): remove net_db.doc, posix.doc, socket.doc. --- ChangeLog | 6 ++++++ configure.in | 5 +++-- libguile/ChangeLog | 7 +++++++ libguile/Makefile.am | 15 +++++++-------- libguile/sort.c | 9 +++++---- 5 files changed, 28 insertions(+), 14 deletions(-) diff --git a/ChangeLog b/ChangeLog index fdb9ee98d..4e183084c 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2001-03-17 Gary Houston + + * configure.in: don't append threads.doc to EXTRA_DOT_DOC_FILES, + since EXTRA_DOT_DOC_FILES is redefined later. define + EXTRA_DOT_X_FILES and hand it to AC_SUBST. + 2001-03-09 Martin Grabmueller * configure.in: Added header checks for crypt.h, sys/resource.h diff --git a/configure.in b/configure.in index 91ba5f8cf..628109d74 100644 --- a/configure.in +++ b/configure.in @@ -471,7 +471,6 @@ if test "${THREAD_PACKAGE}" != "" ; then ## Include the Guile thread interface in the library... LIBOBJS="$LIBOBJS threads.o" - EXTRA_DOT_DOC_FILES="$EXTRA_DOT_DOC_FILES threads.doc" ## ... and tell it which package to talk to. case "${THREAD_PACKAGE}" in @@ -514,8 +513,9 @@ AC_PROG_AWK ## given in LIBOBJS. We'll call it LIBLOBJS. LIBLOBJS="`echo ${LIBOBJS} | sed 's/\.o/.lo/g'`" -## We also need to create corresponding .doc files +## We also need to create corresponding .doc and .x files EXTRA_DOT_DOC_FILES="`echo ${LIBOBJS} | sed 's/\.o/.doc/g'`" +EXTRA_DOT_X_FILES="`echo ${LIBOBJS} | sed 's/\.o/.x/g'`" AC_SUBST(GUILE_MAJOR_VERSION) AC_SUBST(GUILE_MINOR_VERSION) @@ -532,6 +532,7 @@ AC_SUBST(GUILE_LIBS) AC_SUBST(AWK) AC_SUBST(LIBLOBJS) AC_SUBST(EXTRA_DOT_DOC_FILES) +AC_SUBST(EXTRA_DOT_X_FILES) # Support for "make check" test_suite_dir="`(cd $srcdir ; pwd)`/test-suite" diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 502325dbf..42abbb1f5 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,12 @@ 2001-03-17 Gary Houston + * sort.c (scm_sort): move sortvec variable to avoid a compiler + warning when HAVE_ARRAYS is not defined. move len too. + + * Makefile.am (DOT_X_FILES): remove net_db.x, posix.x, socket.x. + (EXTRA_DOT_X_FILES): let configure set the value. + (DOT_DOC_FILES): remove net_db.doc, posix.doc, socket.doc. + * gc.c (scm_must_malloc): changed the comment explaining when scm_must variants of malloc/free etc., should be used, based on explanation from Dirk Herrmann. diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 648cfdbe2..145413368 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -55,16 +55,15 @@ DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ continuations.x debug.x dynl.x dynwind.x environments.x eq.x \ error.x eval.x evalext.x feature.x fluids.x fports.x gc.x goops.x \ gsubr.x guardians.x hash.x hashtab.x hooks.x init.x ioext.x iselect.x \ - keywords.x lang.x list.x load.x macros.x mallocs.x modules.x net_db.x \ - numbers.x objects.x objprop.x options.x pairs.x ports.x posix.x print.x \ + keywords.x lang.x list.x load.x macros.x mallocs.x modules.x \ + numbers.x objects.x objprop.x options.x pairs.x ports.x print.x \ procprop.x procs.x properties.x random.x rdelim.x read.x root.x \ - scmsigs.x script.x simpos.x smob.x socket.x sort.x srcprop.x \ + scmsigs.x script.x simpos.x smob.x sort.x srcprop.x \ stackchk.x stacks.x stime.x strings.x strop.x strorder.x strports.x \ struct.x symbols.x tag.x throw.x values.x variable.x vectors.x \ version.x vports.x weaks.x -EXTRA_DOT_X_FILES = debug-malloc.x filesys.x net_db.x posix.x ramap.x \ - regex-posix.x socket.x threads.x unif.x +EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \ boolean.doc chars.doc continuations.doc debug.doc dynl.doc \ @@ -72,10 +71,10 @@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \ feature.doc fluids.doc fports.doc gc.doc goops.doc gsubr.doc \ guardians.doc hash.doc hashtab.doc hooks.doc init.doc ioext.doc \ iselect.doc keywords.doc lang.doc list.doc load.doc macros.doc \ - mallocs.doc modules.doc net_db.doc numbers.doc objects.doc objprop.doc \ - options.doc pairs.doc ports.doc posix.doc print.doc procprop.doc \ + mallocs.doc modules.doc numbers.doc objects.doc objprop.doc \ + options.doc pairs.doc ports.doc print.doc procprop.doc \ procs.doc properties.doc random.doc rdelim.doc read.doc root.doc \ - scmsigs.doc script.doc simpos.doc smob.doc socket.doc sort.doc \ + scmsigs.doc script.doc simpos.doc smob.doc sort.doc \ srcprop.doc stackchk.doc stacks.doc stime.doc strings.doc strop.doc \ strorder.doc strports.doc struct.doc symbols.doc tag.doc throw.doc \ values.doc variable.doc vectors.doc version.doc vports.doc weaks.doc diff --git a/libguile/sort.c b/libguile/sort.c index 2d3ca3c1f..2d2941aa4 100644 --- a/libguile/sort.c +++ b/libguile/sort.c @@ -751,14 +751,14 @@ SCM_DEFINE (scm_sort, "sort", 2, 0, 0, "elements. This is not a stable sort.") #define FUNC_NAME s_scm_sort { - SCM sortvec; /* the vector we actually sort */ - long len; /* list/vector length */ if (SCM_NULLP(items)) return SCM_EOL; SCM_VALIDATE_NIM (2,less); if (SCM_CONSP (items)) { + long len; + SCM_VALIDATE_LIST_COPYLEN (1,items,len); items = scm_list_copy (items); return scm_merge_list_step (&items, scm_cmp_function (less), less, len); @@ -767,8 +767,9 @@ SCM_DEFINE (scm_sort, "sort", 2, 0, 0, /* support ordinary vectors even if arrays not available? */ else if (SCM_VECTORP (items)) { - len = SCM_VECTOR_LENGTH (items); - sortvec = scm_make_uve (len, scm_array_prototype (items)); + long len = SCM_VECTOR_LENGTH (items); + SCM sortvec = scm_make_uve (len, scm_array_prototype (items)); + scm_array_copy_x (items, sortvec); scm_restricted_vector_sort_x (sortvec, less, From 789ecc0581dbb8ac75abe56f5efaf26b4bcb568e Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 18 Mar 2001 11:54:25 +0000 Subject: [PATCH 0739/2047] * net_db.c: define h_errno if configure didn't define HAVE_H_ERRNO. normally it would be found in netdb.h. --- libguile/ChangeLog | 5 +++++ libguile/net_db.c | 6 ++++++ 2 files changed, 11 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 42abbb1f5..49708a9d9 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-03-18 Gary Houston + + * net_db.c: declare h_errno if configure didn't define HAVE_H_ERRNO. + normally it would be found in netdb.h. + 2001-03-17 Gary Houston * sort.c (scm_sort): move sortvec variable to avoid a compiler diff --git a/libguile/net_db.c b/libguile/net_db.c index b2ed97818..27721ffc0 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -78,9 +78,15 @@ int close (); #endif /* STDC_HEADERS */ #ifndef HAVE_INET_ATON +/* for our definition in inet_aton.c, not usually needed. */ extern int inet_aton (); #endif +#ifndef HAVE_H_ERRNO +/* h_errno not found in netdb.h, maybe this will help. */ +extern int h_errno; +#endif + SCM_DEFINE (scm_inet_aton, "inet-aton", 1, 0, 0, (SCM address), "Converts a string containing an Internet host address in the traditional\n" From 6d163216bdf5f7067bdb53c1beaa78e1c48fb8f9 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 18 Mar 2001 20:29:58 +0000 Subject: [PATCH 0740/2047] * posix.c (scm_tmpnam): check that return value from tmpnam is not NULL. rewrote the docstring. (scm_mkstemp): new procedure implementing "mkstemp!". * posix.h: declare scm_mkstemp. * net_db.c: declare h_errno if configure didn't define HAVE_H_ERRNO. normally it would be found in netdb.h. --- NEWS | 7 +++++++ libguile/ChangeLog | 5 +++++ libguile/posix.c | 37 +++++++++++++++++++++++++++++++++---- libguile/posix.h | 3 ++- 4 files changed, 47 insertions(+), 5 deletions(-) diff --git a/NEWS b/NEWS index 484e31ea4..39b4fc05d 100644 --- a/NEWS +++ b/NEWS @@ -401,6 +401,13 @@ Set/remove an advisory shared or exclusive lock on `file'. Set or get the hostname of the machine the current process is running on. +** New function: mkstemp! tmpl +mkstemp creates a new unique file in the file system and returns a +new buffered port open for reading and writing to the file. TMPL +is a string specifying where the file should be created: it must +end with `XXXXXX' and will be changed in place to return the name +of the temporary file. + ** New function: open-input-string string Return an input string port which delivers the characters from diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 49708a9d9..847dbc5b4 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,10 @@ 2001-03-18 Gary Houston + * posix.c (scm_tmpnam): check that return value from tmpnam is not + NULL. rewrote the docstring. + (scm_mkstemp): new procedure implementing "mkstemp!". + * posix.h: declare scm_mkstemp. + * net_db.c: declare h_errno if configure didn't define HAVE_H_ERRNO. normally it would be found in netdb.h. diff --git a/libguile/posix.c b/libguile/posix.c index efc3f4635..d1d54b42b 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1028,19 +1028,48 @@ SCM_DEFINE (scm_environ, "environ", 0, 1, 0, SCM_DEFINE (scm_tmpnam, "tmpnam", 0, 0, 0, (), - "Create a new file in the file system with a unique name. The return\n" - "value is the name of the new file. This function is implemented with\n" - "the @code{tmpnam} function in the system libraries.") + "tmpnam returns a name in the file system that does not match\n" + "any existing file. However there is no guarantee that\n" + "another process will not create the file after tmpnam\n" + "is called. Care should be taken if opening the file,\n" + "e.g., use the O_EXCL open flag or use @code{mkstemp!} instead.") #define FUNC_NAME s_scm_tmpnam { char name[L_tmpnam]; - SCM_SYSCALL (tmpnam (name);); + char *rv; + + SCM_SYSCALL (rv = tmpnam (name)); + if (rv == NULL) + /* not SCM_SYSERROR since errno probably not set. */ + SCM_MISC_ERROR ("tmpnam failed", SCM_EOL); return scm_makfrom0str (name); } #undef FUNC_NAME #endif +SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0, + (SCM tmpl), + "mkstemp creates a new unique file in the file system and\n" + "returns a new buffered port open for reading and writing to\n" + "the file. @var{tmpl} is a string specifying where the\n" + "file should be created: it must end with @code{XXXXXX}\n" + "and will be changed in place to return the name of the\n" + "temporary file.\n") +#define FUNC_NAME s_scm_mkstemp +{ + char *c_tmpl; + int rv; + + SCM_STRING_COERCE_0TERMINATION_X (tmpl); + SCM_VALIDATE_STRING_COPY (1, tmpl, c_tmpl); + SCM_SYSCALL (rv = mkstemp (c_tmpl)); + if (rv == -1) + SCM_SYSERROR; + return scm_fdes_to_port (rv, "w+", tmpl); +} +#undef FUNC_NAME + SCM_DEFINE (scm_utime, "utime", 1, 2, 0, (SCM pathname, SCM actime, SCM modtime), "@code{utime} sets the access and modification times for\n" diff --git a/libguile/posix.h b/libguile/posix.h index 2b96f94e8..7d6d65743 100644 --- a/libguile/posix.h +++ b/libguile/posix.h @@ -2,7 +2,7 @@ #ifndef POSIXH #define POSIXH -/* Copyright (C) 1995, 1996, 1997, 1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001 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 @@ -85,6 +85,7 @@ extern SCM scm_fork (void); extern SCM scm_uname (void); extern SCM scm_environ (SCM env); extern SCM scm_tmpnam (void); +extern SCM scm_mkstemp (SCM tmpl); extern SCM scm_open_pipe (SCM pipestr, SCM modes); extern SCM scm_close_pipe (SCM port); extern SCM scm_utime (SCM pathname, SCM actime, SCM modtime); From 51cfd7da2c4839d0c96fdef34eef0ccb1f86c0a3 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 18 Mar 2001 23:17:32 +0000 Subject: [PATCH 0741/2047] * check-guile.in: use @srcdir@ instead of @test_suite_dir@. use the current directory (build dir) not srcdir to find guile executable. otherwise "make check" doesn't work with a separate build directory. create the test log in $build_dir/check-guile.log instead of in srcdir/test-suite directory. * configure.in: don't define or substitute test_suite_dir. * guile-test: use #!/bogus-path/..., not #!/home/dirk/... in the first line. --- ChangeLog | 10 ++++++++++ check-guile.in | 10 ++++++---- configure.in | 4 ---- test-suite/ChangeLog | 5 +++++ test-suite/guile-test | 2 +- 5 files changed, 22 insertions(+), 9 deletions(-) diff --git a/ChangeLog b/ChangeLog index 4e183084c..21239b02e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,13 @@ +2001-03-18 Gary Houston + + * check-guile.in: use @srcdir@ instead of @test_suite_dir@. use + the current directory (build dir) not srcdir to find guile + executable. otherwise "make check" doesn't work with a separate + build directory. create the test log in + $build_dir/check-guile.log instead of in srcdir/test-suite + directory. + * configure.in: don't define or substitute test_suite_dir. + 2001-03-17 Gary Houston * configure.in: don't append threads.doc to EXTRA_DOT_DOC_FILES, diff --git a/check-guile.in b/check-guile.in index 89410eae0..edc808eac 100644 --- a/check-guile.in +++ b/check-guile.in @@ -11,15 +11,17 @@ # # Dependencies: dirname sed -TEST_SUITE_DIR=@test_suite_dir@ -parent=`dirname $TEST_SUITE_DIR` +TEST_SUITE_DIR=@srcdir@/test-suite +parent=@srcdir@ +build_dir=`pwd` if [ x"$1" = x-i ] ; then guile=$2 shift shift + glp= else - guile=$parent/libguile/guile + guile=$build_dir/libguile/guile glp=$parent fi @@ -38,6 +40,6 @@ else fi cd $TEST_SUITE_DIR -exec $guile -e main -s guile-test --test-suite $TEST_SUITE_DIR/tests "$@" +exec $guile -e main -s guile-test --test-suite $TEST_SUITE_DIR/tests --log-file $build_dir/check-guile.log "$@" # check-guile ends here diff --git a/configure.in b/configure.in index 628109d74..7dcd92053 100644 --- a/configure.in +++ b/configure.in @@ -534,10 +534,6 @@ AC_SUBST(LIBLOBJS) AC_SUBST(EXTRA_DOT_DOC_FILES) AC_SUBST(EXTRA_DOT_X_FILES) -# Support for "make check" -test_suite_dir="`(cd $srcdir ; pwd)`/test-suite" -AC_SUBST(test_suite_dir) - AC_OUTPUT([Makefile libguile/Makefile libguile/guile-snarf libguile/guile-doc-snarf libguile/guile-func-name-check libguile/guile-snarf.awk libguile/versiondat.h ice-9/Makefile oop/Makefile oop/goops/Makefile qt/Makefile qt/qt.h qt/md/Makefile qt/time/Makefile guile-config/Makefile doc/Makefile check-guile], [chmod +x libguile/guile-snarf libguile/guile-doc-snarf libguile/guile-func-name-check check-guile]) dnl Local Variables: diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index f7a6d9076..e1b177b53 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2001-03-18 Gary Houston + + * guile-test: use #!/bogus-path/..., not #!/home/dirk/... in the + first line. + 2001-03-12 Dirk Herrmann * tests/syntax.test: Added a test for let* bindings and diff --git a/test-suite/guile-test b/test-suite/guile-test index e234322d4..be51fdb60 100755 --- a/test-suite/guile-test +++ b/test-suite/guile-test @@ -1,4 +1,4 @@ -#!/home/dirk/bin/guile \ +#!/bogus-path/guile \ -e main -s !# From fb11ef91dc867391dbd8ed38ac58f05e17028a0a Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Mon, 19 Mar 2001 12:38:40 +0000 Subject: [PATCH 0742/2047] * check-guile.in: rename $parent to $srcdir. if it's equal to "." set it to `pwd`. --- check-guile.in | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/check-guile.in b/check-guile.in index edc808eac..137cb9c3e 100644 --- a/check-guile.in +++ b/check-guile.in @@ -11,9 +11,12 @@ # # Dependencies: dirname sed -TEST_SUITE_DIR=@srcdir@/test-suite -parent=@srcdir@ build_dir=`pwd` +srcdir=@srcdir@ +if [ x"$srcdir" = x. ]; then + srcdir=$build_dir +fi +TEST_SUITE_DIR=$srcdir/test-suite if [ x"$1" = x-i ] ; then guile=$2 @@ -22,14 +25,14 @@ if [ x"$1" = x-i ] ; then glp= else guile=$build_dir/libguile/guile - glp=$parent + glp=$srcdir fi if [ -f "$guile" -a -x "$guile" ] ; then echo Testing $guile ... "$@" if [ x"$glp" = x ] ; then glp=`$guile -c "(for-each write-line %load-path)"` - glp=`echo $glp | sed 's/ /:/g'`:$parent + glp=`echo $glp | sed 's/ /:/g'`:$srcdir fi GUILE_LOAD_PATH=$glp export GUILE_LOAD_PATH From a4928305140f7f9d9f7a833d8163cf60f95572c5 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Mon, 19 Mar 2001 12:39:36 +0000 Subject: [PATCH 0743/2047] *** empty log message *** --- ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ChangeLog b/ChangeLog index 21239b02e..aea24ed79 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2001-03-19 Gary Houston + + * check-guile.in: rename $parent to $srcdir. if it's equal to "." + set it to `pwd`. + 2001-03-18 Gary Houston * check-guile.in: use @srcdir@ instead of @test_suite_dir@. use From 66301f9ab8e0392e0ffcc014edaf0b7fb7a71449 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Mon, 19 Mar 2001 22:46:21 +0000 Subject: [PATCH 0744/2047] * check-guile.in: 16 documentation tests were failing if "make check" was run before Guile had been installed with the current --prefix. made various changes to the script so that it runs without a cd to the test-suite directory. For the -i option, don't point GUILE_LOAD_PATH to the current directory, but let it use it's own scheme library. * tests/r4rs.test: use test-file-name to locate r4rs.test, not data-file-name. * guile-test: define tmp-dir, the location where r4rs.test will create it's temporary files. (data-file-name): use tmp-dir. this must be under build-dir, not src-dir. --- ChangeLog | 7 +++++++ check-guile.in | 30 ++++++++++++------------------ test-suite/ChangeLog | 10 ++++++++++ test-suite/guile-test | 14 ++++++++++---- test-suite/tests/r4rs.test | 4 ++-- 5 files changed, 41 insertions(+), 24 deletions(-) diff --git a/ChangeLog b/ChangeLog index aea24ed79..15342b76b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -3,6 +3,13 @@ * check-guile.in: rename $parent to $srcdir. if it's equal to "." set it to `pwd`. + * check-guile.in: 16 documentation tests were failing if "make + check" was run before Guile had been installed with the current + --prefix. made various changes to the script so that it runs + without a cd to the test-suite directory. For the -i option, + don't point GUILE_LOAD_PATH to the current directory, but let it + use it's own scheme library. + 2001-03-18 Gary Houston * check-guile.in: use @srcdir@ instead of @test_suite_dir@. use diff --git a/check-guile.in b/check-guile.in index 137cb9c3e..645755665 100644 --- a/check-guile.in +++ b/check-guile.in @@ -8,41 +8,35 @@ # ./check-guile numbers.test # ./check-guile -i /usr/local/bin/guile # ./check-guile -i /usr/local/bin/guile numbers.test -# -# Dependencies: dirname sed -build_dir=`pwd` +# this script runs in the top-level build-dir. srcdir=@srcdir@ -if [ x"$srcdir" = x. ]; then - srcdir=$build_dir -fi TEST_SUITE_DIR=$srcdir/test-suite if [ x"$1" = x-i ] ; then guile=$2 shift shift - glp= + GUILE_LOAD_PATH=$TEST_SUITE_DIR else - guile=$build_dir/libguile/guile - glp=$srcdir + guile=libguile/guile + GUILE_LOAD_PATH=$srcdir:$TEST_SUITE_DIR fi +export GUILE_LOAD_PATH if [ -f "$guile" -a -x "$guile" ] ; then echo Testing $guile ... "$@" - if [ x"$glp" = x ] ; then - glp=`$guile -c "(for-each write-line %load-path)"` - glp=`echo $glp | sed 's/ /:/g'`:$srcdir - fi - GUILE_LOAD_PATH=$glp - export GUILE_LOAD_PATH - echo with GUILE_LOAD_PATH: $GUILE_LOAD_PATH + echo with GUILE_LOAD_PATH=$GUILE_LOAD_PATH else echo ERROR: Cannot execute $guile exit 1 fi -cd $TEST_SUITE_DIR -exec $guile -e main -s guile-test --test-suite $TEST_SUITE_DIR/tests --log-file $build_dir/check-guile.log "$@" +# documentation searching ignores GUILE_LOAD_PATH. +if [ ! -e guile-procedures.txt ]; then + ln -s libguile/guile-procedures.txt . +fi + +exec "$guile" -e main -s "$TEST_SUITE_DIR/guile-test" --test-suite "$TEST_SUITE_DIR/tests" --log-file check-guile.log "$@" # check-guile ends here diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index e1b177b53..c48e67f4d 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,13 @@ +2001-03-19 Gary Houston + + * tests/r4rs.test: use test-file-name to locate r4rs.test, + not data-file-name. + + * guile-test: define tmp-dir, the location where r4rs.test will + create it's temporary files. + (data-file-name): use tmp-dir. this must be under build-dir, + not src-dir. + 2001-03-18 Gary Houston * guile-test: use #!/bogus-path/..., not #!/home/dirk/... in the diff --git a/test-suite/guile-test b/test-suite/guile-test index be51fdb60..fa2b714f8 100755 --- a/test-suite/guile-test +++ b/test-suite/guile-test @@ -76,7 +76,7 @@ ;;; User configurable settings: (define default-test-suite - (string-append (getenv "HOME") "/guile-core/test-suite")) + (string-append (getenv "HOME") "/bogus-path/test-suite")) (use-modules (test-suite lib) @@ -87,6 +87,8 @@ ;;; Variables that will receive their actual values later. (define test-suite default-test-suite) +(define tmp-dir #f) + ;;; General utilities, that probably should be in a library somewhere. @@ -126,11 +128,10 @@ ;;; The test driver. -;;; Localizing test files and temporary data files relative to the -;;; test suite directory. +;;; Localizing test files and temporary data files. (define (data-file-name filename) - (in-vicinity test-suite filename)) + (in-vicinity tmp-dir filename)) (define (test-file-name test) (in-vicinity test-suite test)) @@ -175,6 +176,11 @@ (getenv "TEST_SUITE_DIR") default-test-suite)) + ;; directory where temporary files are created. + ;; when run from "make check", this must be under the build-dir, + ;; not the src-dir. + (set! tmp-dir (getcwd)) + (let* ((tests (let ((foo (opt '() '()))) (if (null? foo) diff --git a/test-suite/tests/r4rs.test b/test-suite/tests/r4rs.test index d6deef1db..f8bba3079 100644 --- a/test-suite/tests/r4rs.test +++ b/test-suite/tests/r4rs.test @@ -935,8 +935,8 @@ (SECTION 6 10 1) (test #t input-port? (current-input-port)) (test #t output-port? (current-output-port)) -(test #t call-with-input-file (data-file-name "r4rs.test") input-port?) -(define this-file (open-input-file (data-file-name "r4rs.test"))) +(test #t call-with-input-file (test-file-name "r4rs.test") input-port?) +(define this-file (open-input-file (test-file-name "r4rs.test"))) (test #t input-port? this-file) (SECTION 6 10 2) (test #\; peek-char this-file) From 13c2013d001b3a62bb3ec278fab6e7a0dd6b0b40 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Tue, 20 Mar 2001 11:51:26 +0000 Subject: [PATCH 0745/2047] * scheme-options.texi (Evaluator options): Added evaluator options, corrected docs for evaluator trap options. * scheme-evaluation.texi (Scheme Read): New docs for read-options, read-enable, read-disable and read-set! and cross references to option nodes. (Evaluator Options): New docs for eval-options, eval-enable, eval-disable and eval-set!, traps, trap-enable, trap-disable and trap-set! and cross references to option nodes. (Evaluator Behaviour): Renamed node from `Evaluator options' to avoid name clash. * scheme-io.texi (String Ports): Added docs for SRFI-6 procedures. (Void Ports): Corrected introductory comment. --- doc/ChangeLog | 17 ++++++ doc/scheme-evaluation.texi | 106 +++++++++++++++++++++++++++++++++---- doc/scheme-io.texi | 33 +++++++++--- doc/scheme-options.texi | 17 ++++-- 4 files changed, 152 insertions(+), 21 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 64761ee80..26154476b 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,20 @@ +2001-03-20 Martin Grabmueller + + * scheme-options.texi (Evaluator options): Added evaluator + options, corrected docs for evaluator trap options. + + * scheme-evaluation.texi (Scheme Read): New docs for read-options, + read-enable, read-disable and read-set! and cross references to + option nodes. + (Evaluator Options): New docs for eval-options, eval-enable, + eval-disable and eval-set!, traps, trap-enable, trap-disable and + trap-set! and cross references to option nodes. + (Evaluator Behaviour): Renamed node from `Evaluator options' to + avoid name clash. + + * scheme-io.texi (String Ports): Added docs for SRFI-6 procedures. + (Void Ports): Corrected introductory comment. + 2001-03-16 Martin Grabmueller * scheme-data.texi (Arithmetic): Documented the arithmetic diff --git a/doc/scheme-evaluation.texi b/doc/scheme-evaluation.texi index 31e99ad7a..8211aa37a 100644 --- a/doc/scheme-evaluation.texi +++ b/doc/scheme-evaluation.texi @@ -12,7 +12,7 @@ loading and evaluating Scheme code at run time. * Loading:: Loading Scheme code from file. * Delayed Evaluation:: Postponing evaluation until it is needed. * Local Evaluation:: Evaluation in a local environment. -* Evaluator Options:: +* Evaluator Behaviour:: Modifying Guile's evaluator. @end menu @@ -65,13 +65,6 @@ returned will be the return value of @code{read}. @node Scheme Read @section Reading Scheme Code -@c docstring begin (texi-doc-string "guile" "read-options-interface") -@deffn primitive read-options-interface [setting] -Option interface for the read options. Instead of using -this procedure directly, use the procedures @code{read-enable}, -@code{read-disable}, @code{read-set!} and @var{read-options}. -@end deffn - @r5index read @c docstring begin (texi-doc-string "guile" "read") @deffn primitive read [port] @@ -80,6 +73,41 @@ the current input port if @var{port} is not specified. Any whitespace before the next token is discarded. @end deffn +The behaviour of Guile's Scheme reader can be modified by manipulating +its read options. For more information about options, @xref{General +option interface}. If you want to know which reader options are +available, @xref{Reader options}. + +@c FIXME::martin: This is taken from libguile/options.c. Is there +@c actually a difference between 'help and 'full? + +@deffn procedure read-options [setting] +Display the current settings of the read options. If @var{setting} is +omitted, only a short form of the current read options is printed. +Otherwise, @var{setting} should be one of the following symbols: +@table @code +@item help +Display the complete option settings. +@item full +Like @code{help}, but also print programmer options. +@end table +@end deffn + +@deffn procedure read-enable option-name +@deffnx procedure read-disable option-name +@deffnx procedure read-set! option-name value +Modify the read options. @code{read-enable} should be used with boolean +options and switches them on, @code{read-disable} switches them off. +@code{read-set!} can be used to set an option to a specific value. +@end deffn + +@c docstring begin (texi-doc-string "guile" "read-options-interface") +@deffn primitive read-options-interface [setting] +Option interface for the read options. Instead of using +this procedure directly, use the procedures @code{read-enable}, +@code{read-disable}, @code{read-set!} and @code{read-options}. +@end deffn + @node Fly Evaluation @section Procedures for On the Fly Evaluation @@ -254,14 +282,70 @@ is implicit). @end deffn -@node Evaluator Options -@section Evaluator Options +@node Evaluator Behaviour +@section Evaluator Behaviour + +@c FIXME::martin: Maybe this node name is bad, but the old name clashed with +@c `Evaluator options' under `Options and Config'. + +The behaviour of Guile's evaluator can be modified by manipulating the +evaluator options. For more information about options, @xref{General +option interface}. If you want to know which reader options are +available, @xref{Evaluator options}. + +@c FIXME::martin: This is taken from libguile/options.c. Is there +@c actually a difference between 'help and 'full? + +@deffn procedure eval-options [setting] +Display the current settings of the evaluator options. If @var{setting} +is omitted, only a short form of the current evaluator options is +printed. Otherwise, @var{setting} should be one of the following +symbols: +@table @code +@item help +Display the complete option settings. +@item full +Like @code{help}, but also print programmer options. +@end table +@end deffn + +@deffn procedure eval-enable option-name +@deffnx procedure eval-disable option-name +@deffnx procedure eval-set! option-name value +Modify the evaluator options. @code{eval-enable} should be used with boolean +options and switches them on, @code{eval-disable} switches them off. +@code{eval-set!} can be used to set an option to a specific value. +@end deffn @c docstring begin (texi-doc-string "guile" "eval-options-interface") @deffn primitive eval-options-interface [setting] Option interface for the evaluation options. Instead of using this procedure directly, use the procedures @code{eval-enable}, -@code{eval-disable}, @code{eval-set!} and @var{eval-options}. +@code{eval-disable}, @code{eval-set!} and @code{eval-options}. +@end deffn + +@c FIXME::martin: Why aren't these procedure named like the other options +@c procedures? + +@deffn procedure traps [setting] +Display the current settings of the evaluator traps options. If +@var{setting} is omitted, only a short form of the current evaluator +traps options is printed. Otherwise, @var{setting} should be one of the +following symbols: +@table @code +@item help +Display the complete option settings. +@item full +Like @code{help}, but also print programmer options. +@end table +@end deffn + +@deffn procedure trap-enable option-name +@deffnx procedure trap-disable option-name +@deffnx procedure trap-set! option-name value +Modify the evaluator options. @code{trap-enable} should be used with boolean +options and switches them on, @code{trap-disable} switches them off. +@code{trap-set!} can be used to set an option to a specific value. @end deffn @c docstring begin (texi-doc-string "guile" "evaluator-traps-interface") diff --git a/doc/scheme-io.texi b/doc/scheme-io.texi index a98e96eb7..f3a6a9001 100644 --- a/doc/scheme-io.texi +++ b/doc/scheme-io.texi @@ -762,16 +762,35 @@ port set temporarily to a string port opened on the specified @var{string}. The value yielded by @var{thunk} is returned. @end deffn +@c docstring begin (texi-doc-string "guile" "open-input-string") +@deffn primitive open-input-string str +Takes a string and returns an input port that delivers +characters from the string. The port can be closed by +@code{close-input-port}, though its storage will be reclaimed +by the garbage collector if it becomes inaccessible. +@end deffn + +@c docstring begin (texi-doc-string "guile" "open-output-string") +@deffn primitive open-output-string +Returns an output port that will accumulate characters for +retrieval by @code{get-output-string}. The port can be closed +by the procedure @code{close-output-port}, though its storage +will be reclaimed by the garbage collector if it becomes +inaccessible. +@end deffn + +@c docstring begin (texi-doc-string "guile" "get-output-string") +@deffn primitive get-output-string port +Given an output port created by @code{open-output-string}, +returns a string consisting of the characters that have been +output to the port so far. +@end deffn + A string port can be used in many procedures which accept a port but which are not dependent on implementation details of fports. E.g., seeking and truncating will work on a string port, but trying to extract the file descriptor number will fail. -At present there isn't a procedure that simply returns a new string -port. There's also no way of opening read/write string ports from -Scheme even though it's possible from C. SRFI 6 could be implemented -without much difficulty. - @node Soft Ports @subsection Soft Ports @@ -828,8 +847,8 @@ the port has reached end-of-file. For example: @node Void Ports @subsection Void Ports -This kind of port just causes errors if you try to use it in -a normal way. +This kind of port causes any data to be discarded when written to, and +always returns the end-of-file object when read from. @c docstring begin (texi-doc-string "guile" "%make-void-port") @deffn primitive %make-void-port mode diff --git a/doc/scheme-options.texi b/doc/scheme-options.texi index c8ef7b35b..65e85ba61 100644 --- a/doc/scheme-options.texi +++ b/doc/scheme-options.texi @@ -120,6 +120,7 @@ These functions set a non-boolean @var{option-symbol} to the specified Here is the list of reader options generated by typing @code{(read-options 'full)} in Guile. You can also see the default values. + @smalllisp keywords #f Style of keyword recognition: #f or 'prefix case-insensitive no Convert symbols to lower case. @@ -132,6 +133,7 @@ translation of other Lisp dialects, notably Emacs Lisp, into Guile, Guile is case-sensitive by default. To make Guile case insensitive, you can type + @smalllisp (read-enable 'case-insensitive) @end smalllisp @@ -142,6 +144,7 @@ To make Guile case insensitive, you can type Here is the list of print options generated by typing @code{(print-options 'full)} in Guile. You can also see the default values. + @smallexample source no Print closures with source. closure-hook #f Hook for printing closures. @@ -151,9 +154,16 @@ closure-hook #f Hook for printing closures. @node Evaluator options @section Evaluator options -Here is the list of print options generated by typing -@code{(traps 'full)} in Guile. You can also see the default -values. +These are the evaluator options with their default values, as they are +printed by typing @code{(eval-options 'full)} in Guile. + +@smallexample +stack 22000 Size of thread stacks (in machine words). +@end smallexample + +Here is the list of evaluator trap options generated by typing +@code{(traps 'full)} in Guile. You can also see the default values. + @smallexample exit-frame no Trap when exiting eval or apply. apply-frame no Trap when entering apply. @@ -167,6 +177,7 @@ enter-frame no Trap when eval enters new frame. Here is the list of print options generated by typing @code{(debug-options 'full)} in Guile. You can also see the default values. + @smallexample stack 20000 Stack size limit (0 = no check). debug yes Use the debugging evaluator. From c40eb5944b567d015e3921dfa2f96d2b89995e03 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 21 Mar 2001 02:10:51 +0000 Subject: [PATCH 0746/2047] * safe-r5rs.scm (list): Export. --- ice-9/ChangeLog | 4 ++++ ice-9/safe-r5rs.scm | 1 + 2 files changed, 5 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 7f0bac07f..634277778 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2001-03-20 Keisuke Nishida + + * safe-r5rs.scm (list): Export. + 2001-03-17 Keisuke Nishida * boot-9.scm (before-eval-hook, after-eval-hook, diff --git a/ice-9/safe-r5rs.scm b/ice-9/safe-r5rs.scm index 6de652cd1..9f36feb35 100644 --- a/ice-9/safe-r5rs.scm +++ b/ice-9/safe-r5rs.scm @@ -57,6 +57,7 @@ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr null? list? + list length append reverse From 3b9e23a7b6ab9d3628759c3fbaf625f10803e911 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 21 Mar 2001 02:25:48 +0000 Subject: [PATCH 0747/2047] * time.scm (time): Reimplemented as a procedure call. (Thanks to Marius Vollmer) --- ice-9/ChangeLog | 5 +++++ ice-9/time.scm | 25 ++++++++++++++----------- 2 files changed, 19 insertions(+), 11 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 634277778..1625cf35b 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2001-03-20 Keisuke Nishida + + * time.scm (time): Reimplemented as a procedure call. + (Thanks to Marius Vollmer) + 2001-03-20 Keisuke Nishida * safe-r5rs.scm (list): Export. diff --git a/ice-9/time.scm b/ice-9/time.scm index 0be666cd5..828b2d5c1 100644 --- a/ice-9/time.scm +++ b/ice-9/time.scm @@ -21,20 +21,23 @@ :use-module (ice-9 format) :export (time)) -(define-macro (time form) +(define (time-proc proc) (let* ((gc-start (gc-run-time)) - (tms-start (times)) - (result (eval form (interaction-environment))) - (tms-end (times)) - (gc-end (gc-run-time))) + (tms-start (times)) + (result (proc)) + (tms-end (times)) + (gc-end (gc-run-time))) (define (get proc start end) (/ (- (proc end) (proc start)) internal-time-units-per-second)) (display "clock utime stime cutime cstime gctime\n") (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n" - (get tms:clock tms-start tms-end) - (get tms:utime tms-start tms-end) - (get tms:stime tms-start tms-end) - (get tms:cutime tms-start tms-end) - (get tms:cstime tms-start tms-end) - (get id gc-start gc-end)) + (get tms:clock tms-start tms-end) + (get tms:utime tms-start tms-end) + (get tms:stime tms-start tms-end) + (get tms:cutime tms-start tms-end) + (get tms:cstime tms-start tms-end) + (get id gc-start gc-end)) result)) + +(define-macro (time exp) + `(,time-proc (lambda () ,exp))) From be54b15d85632c1da64f36cc68623b76efc7239e Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 22 Mar 2001 12:52:03 +0000 Subject: [PATCH 0748/2047] * Replace function scm_makstr with new function scm_allocate_string. --- NEWS | 8 ++++++++ RELEASE | 1 + libguile/ChangeLog | 13 +++++++++++++ libguile/gc.c | 2 +- libguile/gdbint.c | 4 ++-- libguile/numbers.c | 4 ++-- libguile/ports.c | 4 ++-- libguile/read.c | 6 +++--- libguile/strings.c | 33 ++++++++++++++++++++++++++++----- libguile/strings.h | 3 ++- libguile/strports.c | 6 +++--- libguile/unif.c | 2 +- 12 files changed, 66 insertions(+), 20 deletions(-) diff --git a/NEWS b/NEWS index 39b4fc05d..7569dbe08 100644 --- a/NEWS +++ b/NEWS @@ -520,6 +520,14 @@ These functions replace the function scm_remember. Use one of the new functions scm_remember_upto_here_1, scm_remember_upto_here_2 or scm_remember_upto_here instead. +** New function: scm_allocate_string + +This function replaces the function scm_makstr. + +** Deprecated function: scm_makstr + +Use the new function scm_allocate_string instead. + ** New global variable scm_gc_running_p introduced. Use this variable to find out if garbage collection is being executed. Up to diff --git a/RELEASE b/RELEASE index d7bd44236..f4c521119 100644 --- a/RELEASE +++ b/RELEASE @@ -47,6 +47,7 @@ In release 1.6: load.c: scm_read_and_eval_x smob.c: scm_make_smob_type_mfpe, scm_set_smob_mfpe gc.c: scm_remember + string.c: scm_makstr - remove deprecated procedures: boot-9.scm:eval-in-module - remove deprecated macros: SCM_OUTOFRANGE, SCM_NALLOC, SCM_HUP_SIGNAL, diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 847dbc5b4..6ca3b0526 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,16 @@ +2001-03-22 Dirk Herrmann + + * gc.c (scm_init_storage), gdbint.c (scm_init_gdbint), numbers.c + (big2str), ports.c (scm_drain_input), read.c (scm_read, + scm_grow_tok_buf), strings.c (scm_string, scm_makfromstr, + scm_make_string, scm_string_append), strports.c (st_resize_port, + scm_object_to_string), unif.c (scm_make_uve): Replace calls to + scm_makstr with calls to scm_allocate_string. + + * strings.[ch] (scm_allocate_string): New function. + + * strings.[ch] (scm_makstr): Deprecated. + 2001-03-18 Gary Houston * posix.c (scm_tmpnam): check that return value from tmpnam is not diff --git a/libguile/gc.c b/libguile/gc.c index c99e3f0d4..ebcddca09 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -2630,7 +2630,7 @@ scm_init_storage () SCM_SETCDR (scm_undefineds, scm_undefineds); scm_listofnull = scm_cons (SCM_EOL, SCM_EOL); - scm_nullstr = scm_makstr (0L, 0); + scm_nullstr = scm_allocate_string (0); scm_nullvect = scm_c_make_vector (0, SCM_UNDEFINED); #define DEFAULT_SYMHASH_SIZE 277 diff --git a/libguile/gdbint.c b/libguile/gdbint.c index e18fea8a8..8511365d3 100644 --- a/libguile/gdbint.c +++ b/libguile/gdbint.c @@ -1,5 +1,5 @@ /* GDB interface for Guile - * Copyright (C) 1996, 1997, 1999, 2000 Free Software Foundation + * Copyright (C) 1996,1997,1999,2000,2001 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 @@ -329,7 +329,7 @@ scm_init_gdbint () s); gdb_input_port = scm_permanent_object (port); - tok_buf = scm_permanent_object (scm_makstr (30L, 0)); + tok_buf = scm_permanent_object (scm_allocate_string (30)); } /* diff --git a/libguile/numbers.c b/libguile/numbers.c index 37dcb106e..17fa9fda1 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 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 @@ -2244,7 +2244,7 @@ big2str (SCM b, unsigned int radix) scm_sizet k = 0; scm_sizet radct = 0; SCM_BIGDIG radpow = 1, radmod = 0; - SCM ss = scm_makstr ((long) j, 0); + SCM ss = scm_allocate_string (j); char *s = SCM_STRING_CHARS (ss), c; while ((long) radpow * radix < SCM_BIGRAD) { diff --git a/libguile/ports.c b/libguile/ports.c index 04725b87e..6884811d1 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999, 2000, 2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 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 @@ -322,7 +322,7 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, if (pt->read_buf == pt->putback_buf) count += pt->saved_read_end - pt->saved_read_pos; - result = scm_makstr (count, 0); + result = scm_allocate_string (count); scm_take_from_input_buffers (port, SCM_STRING_CHARS (result), count); return result; diff --git a/libguile/read.c b/libguile/read.c index 578e35330..221035ff1 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1999,2000,2001 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 @@ -116,7 +116,7 @@ SCM_DEFINE (scm_read, "read", 0, 1, 0, return SCM_EOF_VAL; scm_ungetc (c, port); - tok_buf = scm_makstr (30L, 0); + tok_buf = scm_allocate_string (30); return scm_lreadr (&tok_buf, port, ©); } #undef FUNC_NAME @@ -127,7 +127,7 @@ char * scm_grow_tok_buf (SCM *tok_buf) { unsigned long int oldlen = SCM_STRING_LENGTH (*tok_buf); - SCM newstr = scm_makstr (2 * oldlen, 0); + SCM newstr = scm_allocate_string (2 * oldlen); unsigned long int i; for (i = 0; i != oldlen; ++i) diff --git a/libguile/strings.c b/libguile/strings.c index e2277fe39..cf8ddca28 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,2000,2001 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 @@ -106,7 +106,7 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1, long i = scm_ilength (chrs); SCM_ASSERT (i >= 0, chrs, SCM_ARGn, FUNC_NAME); - result = scm_makstr (i, 0); + result = scm_allocate_string (i); } { @@ -125,6 +125,7 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1, } #undef FUNC_NAME +#if (SCM_DEBUG_DEPRECATED == 0) SCM scm_makstr (long len, int dummy) @@ -146,6 +147,7 @@ scm_makstr (long len, int dummy) } #undef FUNC_NAME +#endif /* SCM_DEBUG_DEPRECATED == 0 */ /* converts C scm_array of strings to SCM scm_list of strings. */ /* If argc < 0, a null terminated scm_array is assumed. */ @@ -199,7 +201,7 @@ scm_take0str (char *s) SCM scm_makfromstr (const char *src, scm_sizet len, int dummy) { - SCM s = scm_makstr (len, 0); + SCM s = scm_allocate_string (len); char *dst = SCM_STRING_CHARS (s); while (len--) @@ -222,6 +224,27 @@ scm_makfrom0str_opt (const char *src) } +SCM +scm_allocate_string (scm_sizet len) +#define FUNC_NAME "scm_allocate_string" +{ + char *mem; + SCM s; + + SCM_ASSERT_RANGE (1, scm_long2num (len), len <= SCM_STRING_MAX_LENGTH); + + mem = (char *) scm_must_malloc (len + 1, FUNC_NAME); + mem[len] = 0; + + SCM_NEWCELL (s); + SCM_SET_STRING_CHARS (s, mem); + SCM_SET_STRING_LENGTH (s, len); + + return s; +} +#undef FUNC_NAME + + SCM_DEFINE (scm_make_string, "make-string", 1, 1, 0, (SCM k, SCM chr), "Return a newly allocated string of\n" @@ -237,7 +260,7 @@ SCM_DEFINE (scm_make_string, "make-string", 1, 1, 0, SCM_ASSERT_RANGE (1, k, i >= 0); - res = scm_makstr (i, 0); + res = scm_allocate_string (i); if (!SCM_UNBNDP (chr)) { unsigned char *dst; @@ -348,7 +371,7 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, SCM_VALIDATE_STRING (SCM_ARGn,s); i += SCM_STRING_LENGTH (s); } - res = scm_makstr (i, 0); + res = scm_allocate_string (i); data = SCM_STRING_UCHARS (res); for (l = args;SCM_NIMP (l);l = SCM_CDR (l)) { s = SCM_CAR (l); diff --git a/libguile/strings.h b/libguile/strings.h index cc3b54669..76919d7c5 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -70,13 +70,13 @@ extern SCM scm_string_p (SCM x); extern SCM scm_read_only_string_p (SCM x); extern SCM scm_string (SCM chrs); -extern SCM scm_makstr (long len, int); extern SCM scm_makfromstrs (int argc, char **argv); extern SCM scm_take_str (char *s, int len); extern SCM scm_take0str (char *s); extern SCM scm_makfromstr (const char *src, scm_sizet len, int); extern SCM scm_makfrom0str (const char *src); extern SCM scm_makfrom0str_opt (const char *src); +extern SCM scm_allocate_string (scm_sizet len); extern SCM scm_make_string (SCM k, SCM chr); extern SCM scm_string_length (SCM str); extern SCM scm_string_ref (SCM str, SCM k); @@ -102,6 +102,7 @@ extern void scm_init_strings (void); ? (char *) SCM_CELL_WORD_1 (SCM_CDDR (x)) + SCM_INUM (SCM_CADR (x)) \ : (char *) SCM_CELL_WORD_1 (x)) extern SCM scm_make_shared_substring (SCM str, SCM frm, SCM to); +extern SCM scm_makstr (long len, int); #endif /* SCM_DEBUG_DEPRECATED == 0 */ diff --git a/libguile/strports.c b/libguile/strports.c index 299337d97..c1a20e60b 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001 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 @@ -100,7 +100,7 @@ static void st_resize_port (scm_port *pt, off_t new_size) { SCM old_stream = SCM_PACK (pt->stream); - SCM new_stream = scm_makstr (new_size, 0); + SCM new_stream = scm_allocate_string (new_size); unsigned long int old_size = SCM_STRING_LENGTH (old_stream); unsigned long int min_size = min (old_size, new_size); unsigned long int i; @@ -323,7 +323,7 @@ SCM_DEFINE (scm_object_to_string, "object->string", 1, 1, 0, if (!SCM_UNBNDP (printer)) SCM_VALIDATE_PROC (2, printer); - str = scm_makstr (0, 0); + str = scm_allocate_string (0); port = scm_mkstrport (SCM_INUM0, str, SCM_OPN | SCM_WRTNG, FUNC_NAME); if (SCM_UNBNDP (printer)) diff --git a/libguile/unif.c b/libguile/unif.c index eb2fcb409..9255abb37 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -186,7 +186,7 @@ scm_make_uve (long k, SCM prot) else if (SCM_CHARP (prot)) { i = sizeof (char) * k; - return scm_makstr (i, 0); + return scm_allocate_string (i); } else if (SCM_INUMP (prot)) { From 780ee65e3b04d6253598f4af5e66f6f04d6e893d Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 23 Mar 2001 15:05:40 +0000 Subject: [PATCH 0749/2047] * Automatic docstring updates. * Commit utilities and tracking files for automatic docstring updates. --- doc/ChangeLog | 8 + doc/maint/ChangeLog | 4 + doc/maint/README | 16 + doc/maint/docstring.el | 563 +++ doc/maint/guile.texi | 7087 ++++++++++++++++++++++++++++++++++++ doc/new-docstrings.texi | 599 +++ doc/posix.texi | 12 +- doc/scheme-data.texi | 454 +-- doc/scheme-evaluation.texi | 47 +- doc/scheme-io.texi | 40 +- doc/scheme-memory.texi | 10 +- 11 files changed, 8570 insertions(+), 270 deletions(-) create mode 100644 doc/maint/ChangeLog create mode 100644 doc/maint/README create mode 100644 doc/maint/docstring.el create mode 100644 doc/maint/guile.texi create mode 100644 doc/new-docstrings.texi diff --git a/doc/ChangeLog b/doc/ChangeLog index 26154476b..dfa0f66c3 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,11 @@ +2001-03-23 Neil Jerram + + * posix.texi, scheme-data.texi, scheme-evaluation.texi, + scheme-io.texi, scheme-memory.texi: Automatic docstring updates. + + * new-docstrings.texi: New file. Holds snarfed docstrings that + have not yet been incorporated into the reference manual. + 2001-03-20 Martin Grabmueller * scheme-options.texi (Evaluator options): Added evaluator diff --git a/doc/maint/ChangeLog b/doc/maint/ChangeLog new file mode 100644 index 000000000..c8c549ea1 --- /dev/null +++ b/doc/maint/ChangeLog @@ -0,0 +1,4 @@ +2001-03-23 Neil Jerram + + * ChangeLog, README, docstring.el, guile.texi: New files. + diff --git a/doc/maint/README b/doc/maint/README new file mode 100644 index 000000000..0a46418bc --- /dev/null +++ b/doc/maint/README @@ -0,0 +1,16 @@ +README for guile-core/doc/maint -*- text -*- + +The files in this directory are used by the maintainers to automate +the process of updating the Guile reference manual when the docstrings +in the libguile C source change. + +- ChangeLog is the change log for files in this directory. + +- README is this file. + +- docstring.el is a helpful Emacs Lisp library. The usual entry point + is `docstring-process-current-buffer'. + +- guile.texi is a snapshot of the built file + guile-core/libguile/guile.texi, copied last time the reference + manual was determined to be in sync with the libguile source. diff --git a/doc/maint/docstring.el b/doc/maint/docstring.el new file mode 100644 index 000000000..b346b96bd --- /dev/null +++ b/doc/maint/docstring.el @@ -0,0 +1,563 @@ +;;; docstring.el --- utilities for Guile docstring maintenance +;;; +;;; Copyright (C) 2001 Neil Jerram +;;; +;;; This file is not part of GNU Emacs, but the same permissions apply. +;;; +;;; GNU Emacs 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, or (at your option) +;;; any later version. +;;; +;;; GNU Emacs 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; see the file COPYING. If not, write to the +;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; The basic premise of these utilities is that - at least in the +;; short term - we can get a lot of reference manual mileage by +;; co-opting the docstrings that are snarfed automatically from +;; Guile's C and Scheme source code. But this leads to problems of +;; synchronization... How do you track when a docstring has been +;; updated in the source and so needs updating in the reference +;; manual. What if a procedure is removed from the Guile source? And +;; so on. To complicate matters, the exact snarfed docstring text +;; will probably need to be modified so that it fits into the flow of +;; the manual section in which it appears. Can we design solutions to +;; synchronization problems that continue to work even when the manual +;; text has been enhanced in this way? +;; +;; This file implements an approach to this problem that I have found +;; useful. It involves keeping track of three copies of each +;; docstring: +;; +;; "MANUAL" = the docstring as it appears in the reference manual. +;; +;; "SNARFED" = the docstring as snarfed from the current C or Scheme +;; source. +;; +;; "TRACKING" = the docstring as it appears in a tracking file whose +;; purpose is to record the most recent snarfed docstrings +;; that are known to be in sync with the reference manual. +;; +;; The approaches are as follows. +;; +;; 1. Comparison of MANUAL-DOC, SOURCE-DOC and TRACK-DOC, to produce a +;; summary output buffer in which keystrokes are defined to bring up +;; detailed comparisons. +;; +;; 2. Comparison of MANUAL-DOC, SOURCE-DOC and TRACK-DOC using Ediff. + +;;; Code: + +(defvar docstring-manual-directory (expand-file-name "~/Guile/cvs/guile-core/doc") + "*The directory containing the Texinfo source for the Guile reference manual.") + +(defvar docstring-tracking-root (expand-file-name "~/Guile/cvs/guile-core/doc/maint") + "*Root directory for docstring tracking files. The tracking file +for module (a b c) is expected to be in the file +/a/b/c.texi.") + +(defvar docstring-snarfed-roots (list (expand-file-name "~/Guile/cvs/guile-core/libguile") + (expand-file-name "~/Guile/cvs/guile-core/ice-9") + (expand-file-name "~/Guile/cvs/guile-core/oop")) + "*List of possible root directories for snarfed docstring files. +For each entry in this list, the snarfed docstring file for module (a +b c) is looked for in the file /a/b/c.texi.") + +(defvar docstring-manual-files '("appendices.texi" + "deprecated.texi" + "expect.texi" + "gh.texi" + "goops.texi" + "guile.texi" + "indices.texi" + "intro.texi" + "posix.texi" + "scheme-binding.texi" + "scheme-control.texi" + "scheme-data.texi" + "scheme-debug.texi" + "scheme-evaluation.texi" + "scheme-ideas.texi" + "scheme-indices.texi" + "scheme-intro.texi" + "scheme-io.texi" + "scheme-memory.texi" + "scheme-modules.texi" + "scheme-options.texi" + "scheme-procedures.texi" + "scheme-reading.texi" + "scheme-scheduling.texi" + "scheme-translation.texi" + "scheme-utility.texi" + "scm.texi" + "scripts.texi" + "scsh.texi" + "slib.texi" + "tcltk.texi") + "List of Texinfo source files that comprise the Guile reference manual.") + +(defvar docstring-new-docstrings-file "new-docstrings.texi" + "The name of a file in the Guile reference manual source directory +to which new docstrings should be added.") + +;; Apply FN in turn to each element in the list CANDIDATES until the +;; first application that returns non-nil. +(defun or-map (fn candidates args) + (let ((result nil)) + (while candidates + (setq result (apply fn (car candidates) args)) + (if result + (setq result (cons (car candidates) result) + candidates nil) + (setq candidates (cdr candidates)))) + result)) + +;; Return t if the current buffer position is in the scope of the +;; specified MODULE, as determined by "@c module ..." comments in the +;; buffer. DEFAULT-OK specifies the return value in the case that +;; there are no preceding module comments at all. +(defun docstring-in-module (module default-ok) + (save-excursion + (if (re-search-backward "^@c module " nil t) + (progn + (search-forward "@c module ") + (equal module (read (current-buffer)))) + default-ok))) + +;; Find a docstring in the specified FILE-NAME for the item in module +;; MODULE and with description DESCRIPTION. MODULE should be a list +;; of symbols, Guile-style, for example: '(ice-9 session). +;; DESCRIPTION should be the string that is expected after the @deffn, +;; for example "primitive acons" or "syntax let*". +(defun find-docstring (file-name module description) + (and (file-exists-p file-name) + (let ((buf (find-file-noselect file-name)) + (deffn-regexp (concat "^@deffnx? " + (regexp-quote description) + "[ \n\t]")) + found + result) + (save-excursion + (set-buffer buf) + (goto-char (point-min)) + (while (and (not found) + (re-search-forward deffn-regexp nil t)) + (save-excursion + (goto-char (match-beginning 0)) + (beginning-of-line) + (if (docstring-in-module module t) + (setq found t)))) + (if found + (setq result + (list (current-buffer) + (progn + (re-search-backward "^@deffn ") + (beginning-of-line) + (point)) + (progn + (re-search-forward "^@end deffn") + (forward-line 1) + (point)))))) + result))) + +;; Find the reference manual version of the specified docstring. +;; MODULE and DESCRIPTION specify the docstring as per +;; `find-docstring'. The set of files that `find-manual-docstring' +;; searches is determined by the value of the `docstring-manual-files' +;; variable. +(defun find-manual-docstring (module description) + (let* ((result + (or-map 'find-docstring + (mapcar (function (lambda (file-name) + (concat docstring-manual-directory + "/" + file-name))) + (cons docstring-new-docstrings-file + docstring-manual-files)) + (list module + description))) + (matched-file-name (and (cdr result) + (file-name-nondirectory (car result))))) + (if matched-file-name + (setq docstring-manual-files + (cons matched-file-name + (delete matched-file-name docstring-manual-files)))) + (cdr result))) + +;; Convert MODULE to a directory subpath. +(defun module-to-path (module) + (mapconcat (function (lambda (component) + (symbol-name component))) + module + "/")) + +;; Find the current snarfed version of the specified docstring. +;; MODULE and DESCRIPTION specify the docstring as per +;; `find-docstring'. The file that `find-snarfed-docstring' looks in +;; is automatically generated from MODULE. +(defun find-snarfed-docstring (module description) + (let ((modpath (module-to-path module))) + (cdr (or-map (function (lambda (root) + (find-docstring (concat root + "/" + modpath + ".texi") + module + description))) + docstring-snarfed-roots + nil)))) + +;; Find the tracking version of the specified docstring. MODULE and +;; DESCRIPTION specify the docstring as per `find-docstring'. The +;; file that `find-tracking-docstring' looks in is automatically +;; generated from MODULE. +(defun find-tracking-docstring (module description) + (find-docstring (concat docstring-tracking-root + "/" + (module-to-path module) + ".texi") + module + description)) + +;; Extract an alist of modules and descriptions from the current +;; buffer. +(defun make-module-description-list () + (let ((alist nil) + (module '(guile))) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^\\(@c module \\|@deffnx? \\({[^}]+}\\|[^ ]+\\) \\([^ \n]+\\)\\)" + nil + t) + (let ((matched (buffer-substring (match-beginning 1) + (match-end 1)))) + (if (string-equal matched "@c module ") + (setq module (read (current-buffer))) + (setq matched + (concat (buffer-substring (match-beginning 2) + (match-end 2)) + " " + (buffer-substring (match-beginning 3) + (match-end 3)))) + (message "Found docstring: %S: %s" module matched) + (let ((descriptions (assoc module alist))) + (setq alist + (cons (cons module (cons matched (cdr-safe descriptions))) + (if descriptions + (delete descriptions alist) + alist)))))))) + alist)) + +;; Return the docstring from the specified LOCATION. LOCATION is a +;; list of three elements: buffer, start position and end position. +(defun location-to-docstring (location) + (and location + (save-excursion + (set-buffer (car location)) + (buffer-substring (cadr location) (caddr location))))) + +;; Perform a comparison of the specified docstring. MODULE and +;; DESCRIPTION are as per usual. +(defun docstring-compare (module description) + (let* ((manual-location (find-manual-docstring module description)) + (snarf-location (find-snarfed-docstring module description)) + (track-location (find-tracking-docstring module description)) + + (manual-docstring (location-to-docstring manual-location)) + (snarf-docstring (location-to-docstring snarf-location)) + (track-docstring (location-to-docstring track-location)) + + action + issue) + + ;; Decide what to do. + (cond ((null snarf-location) + (setq action nil + issue (if manual-location + 'consider-removal + nil))) + + ((null manual-location) + (setq action 'add-to-manual issue nil)) + + ((null track-location) + (setq action nil + issue (if (string-equal manual-docstring snarf-docstring) + nil + 'check-needed))) + + ((string-equal track-docstring snarf-docstring) + (setq action nil issue nil)) + + ((string-equal track-docstring manual-docstring) + (setq action 'auto-update-manual issue nil)) + + (t + (setq action nil issue 'update-needed))) + + ;; Return a pair indicating any automatic action that can be + ;; taken, and any issue for resolution. + (cons action issue))) + +;; Add the specified docstring to the manual. +(defun docstring-add-to-manual (module description) + (let ((buf (find-file-noselect (concat docstring-manual-directory + "/" + docstring-new-docstrings-file)))) + (save-excursion + (set-buffer buf) + (goto-char (point-max)) + (or (docstring-in-module module nil) + (insert "\n@c module " (prin1-to-string module) "\n")) + (insert "\n" (location-to-docstring (find-snarfed-docstring module + description)))))) + +;; Auto-update the specified docstring in the manual. +(defun docstring-auto-update-manual (module description) + (let ((manual-location (find-manual-docstring module description)) + (track-location (find-tracking-docstring module description))) + (save-excursion + (set-buffer (car manual-location)) + (goto-char (cadr manual-location)) + (delete-region (cadr manual-location) (caddr manual-location)) + (insert (location-to-docstring (find-snarfed-docstring module + description)))))) + +;; Process an alist of modules and descriptions, and produce a summary +;; buffer describing actions taken and issues to be resolved. +(defun docstring-process-alist (alist) + (let (check-needed-list + update-needed-list + consider-removal-list + added-to-manual-list + auto-updated-manual-list) + + (mapcar + (function (lambda (module-list) + (let ((module (car module-list))) + (message "Module: %S" module) + (mapcar + (function (lambda (description) + (message "Comparing docstring: %S: %s" module description) + (let* ((ai (docstring-compare module description)) + (action (car ai)) + (issue (cdr ai))) + + (cond ((eq action 'add-to-manual) + (docstring-add-to-manual module description) + (setq added-to-manual-list + (cons (cons module description) + added-to-manual-list))) + + ((eq action 'auto-update-manual) + (docstring-auto-update-manual module description) + (setq auto-updated-manual-list + (cons (cons module description) + auto-updated-manual-list)))) + + (cond ((eq issue 'check-needed) + (setq check-needed-list + (cons (cons module description) + check-needed-list))) + + ((eq issue 'update-needed) + (setq update-needed-list + (cons (cons module description) + update-needed-list))) + + ((eq issue 'consider-removal) + (setq consider-removal-list + (cons (cons module description) + consider-removal-list))))))) + (cdr module-list))))) + alist) + + ;; Prepare a buffer describing the results. + (set-buffer (get-buffer-create "*Docstring Results*")) + (erase-buffer) + + (insert " +The following items have been automatically added to the manual in +file `" docstring-manual-directory "/" docstring-new-docstrings-file "'.\n\n") + (if added-to-manual-list + (mapcar (function (lambda (moddesc) + (insert (prin1-to-string (car moddesc)) + ": " + (cdr moddesc) + "\n"))) + added-to-manual-list) + (insert "(none)\n")) + + (insert " +The following items have been automatically updated in the manual.\n\n") + (if auto-updated-manual-list + (mapcar (function (lambda (moddesc) + (insert (prin1-to-string (car moddesc)) + ": " + (cdr moddesc) + "\n"))) + auto-updated-manual-list) + (insert "(none)\n")) + + (insert " +The following items are already documented in the manual but are not +mentioned in the reference copy of the snarfed docstrings file. +You should check that the manual documentation matches the docstring +in the current snarfed docstrings file.\n\n") + (if check-needed-list + (mapcar (function (lambda (moddesc) + (insert (prin1-to-string (car moddesc)) + ": " + (cdr moddesc) + "\n"))) + check-needed-list) + (insert "(none)\n")) + + (insert " +The following items have manual documentation that is different from +the docstring in the reference copy of the snarfed docstrings file, +and the snarfed docstring has changed. You need to update the manual +documentation by hand with reference to the snarfed docstring changes.\n\n") + (if update-needed-list + (mapcar (function (lambda (moddesc) + (insert (prin1-to-string (car moddesc)) + ": " + (cdr moddesc) + "\n"))) + update-needed-list) + (insert "(none)\n")) + + (insert " +The following items are documented in the manual but are no longer +present in the snarfed docstrings file. You should consider whether +the existing manual documentation is still pertinent. If it is, its +docstring module comment may need updating, to connect it with a +new snarfed docstring file.\n\n") + (if consider-removal-list + (mapcar (function (lambda (moddesc) + (insert (prin1-to-string (car moddesc)) + ": " + (cdr moddesc) + "\n"))) + consider-removal-list) + (insert "(none)\n")) + (insert "\n") + + (goto-char (point-min)) + + ;; Popup the issues buffer. + (let ((pop-up-frames t)) + (set-window-point (display-buffer (current-buffer)) + (point-min))))) + +(defun docstring-process-current-buffer () + (interactive) + (docstring-process-alist (make-module-description-list))) + +(defun docstring-process-current-region (beg end) + (interactive "r") + (narrow-to-region beg end) + (unwind-protect + (save-excursion + (docstring-process-alist (make-module-description-list))) + (widen))) + +(defun docstring-process-module (module) + (interactive "xModule: ") + (let ((modpath (module-to-path module)) + (mdlist nil)) + (mapcar (function (lambda (root) + (let ((fn (concat root + "/" + modpath + ".texi"))) + (if (file-exists-p fn) + (save-excursion + (find-file fn) + (message "Getting docstring list from %s" fn) + (setq mdlist + (append mdlist + (make-module-description-list)))))))) + docstring-snarfed-roots) + (docstring-process-alist mdlist))) + +(defun docstring-ediff-this-line () + (interactive) + (let (module + description) + (save-excursion + (beginning-of-line) + (setq module (read (current-buffer))) + (forward-char 2) + (setq description (buffer-substring (point) + (progn + (end-of-line) + (point))))) + + (message "Ediff docstring: %S: %s" module description) + + (let ((track-location (or (find-tracking-docstring module description) + (docstring-temp-location "No docstring in tracking file"))) + (snarf-location (or (find-snarfed-docstring module description) + (docstring-temp-location "No docstring in snarfed file"))) + (manual-location (or (find-manual-docstring module description) + (docstring-temp-location "No docstring in manual")))) + + (setq docstring-ediff-buffers + (list (car track-location) + (car snarf-location) + (car manual-location))) + + (docstring-narrow-to-location track-location) + (docstring-narrow-to-location snarf-location) + (docstring-narrow-to-location manual-location) + + (add-hook 'ediff-quit-hook 'docstring-widen-ediff-buffers) + + (ediff-buffers3 (nth 0 docstring-ediff-buffers) + (nth 1 docstring-ediff-buffers) + (nth 2 docstring-ediff-buffers))))) + +(defun docstring-narrow-to-location (location) + (save-excursion + (set-buffer (car location)) + (narrow-to-region (cadr location) (caddr location)))) + +(defun docstring-temp-location (str) + (let ((buf (generate-new-buffer "*Docstring Temp*"))) + (save-excursion + (set-buffer buf) + (erase-buffer) + (insert str "\n") + (list buf (point-min) (point-max))))) + +(require 'ediff) + +(defvar docstring-ediff-buffers '()) + +(defun docstring-widen-ediff-buffers () + (remove-hook 'ediff-quit-hook 'docstring-widen-ediff-buffers) + (save-excursion + (mapcar (function (lambda (buffer) + (set-buffer buffer) + (widen))) + docstring-ediff-buffers))) + + +;;; Tests: + +;(find-docstring "/home/neil/Guile/cvs/guile-core/doc/maint/guile.texi" nil "primitive sloppy-assq") +;(find-manual-docstring '(guile) "primitive sloppy-assq") +;(find-tracking-docstring '(guile) "primitive sloppy-assq") +;(find-snarfed-docstring '(guile) "primitive sloppy-assq") + +(provide 'docstring) diff --git a/doc/maint/guile.texi b/doc/maint/guile.texi new file mode 100644 index 000000000..bb7dd4522 --- /dev/null +++ b/doc/maint/guile.texi @@ -0,0 +1,7087 @@ +@paragraphindent 0 + + acons +@c snarfed from alist.c:60 +@deffn primitive acons key value alist +Adds a new key-value pair to @var{alist}. A new pair is +created whose car is @var{key} and whose cdr is @var{value}, and the +pair is consed onto @var{alist}, and the new list is returned. This +function is @emph{not} destructive; @var{alist} is not modified. +@end deffn + + sloppy-assq +@c snarfed from alist.c:83 +@deffn primitive sloppy-assq key alist +Behaves like @code{assq} but does not do any error checking. +Recommended only for use in Guile internals. +@end deffn + + sloppy-assv +@c snarfed from alist.c:101 +@deffn primitive sloppy-assv key alist +Behaves like @code{assv} but does not do any error checking. +Recommended only for use in Guile internals. +@end deffn + + sloppy-assoc +@c snarfed from alist.c:119 +@deffn primitive sloppy-assoc key alist +Behaves like @code{assoc} but does not do any error checking. +Recommended only for use in Guile internals. +@end deffn + + assq +@c snarfed from alist.c:146 +@deffn primitive assq key alist +@deffnx primitive assv key alist +@deffnx primitive assoc key alist +Fetches the entry in @var{alist} that is associated with @var{key}. To +decide whether the argument @var{key} matches a particular entry in +@var{alist}, @code{assq} compares keys with @code{eq?}, @code{assv} +uses @code{eqv?} and @code{assoc} uses @code{equal?}. If @var{key} +cannot be found in @var{alist} (according to whichever equality +predicate is in use), then @code{#f} is returned. These functions +return the entire alist entry found (i.e. both the key and the value). +@end deffn + + assv +@c snarfed from alist.c:167 +@deffn primitive assv key alist +Behaves like @code{assq} but uses @code{eqv?} for key comparison. +@end deffn + + assoc +@c snarfed from alist.c:188 +@deffn primitive assoc key alist +Behaves like @code{assq} but uses @code{equal?} for key comparison. +@end deffn + + assq-ref +@c snarfed from alist.c:232 +@deffn primitive assq-ref alist key +@deffnx primitive assv-ref alist key +@deffnx primitive assoc-ref alist key +Like @code{assq}, @code{assv} and @code{assoc}, except that only the +value associated with @var{key} in @var{alist} is returned. These +functions are equivalent to + +@lisp +(let ((ent (@var{associator} @var{key} @var{alist}))) + (and ent (cdr ent))) +@end lisp + +where @var{associator} is one of @code{assq}, @code{assv} or @code{assoc}. +@end deffn + + assv-ref +@c snarfed from alist.c:249 +@deffn primitive assv-ref alist key +Behaves like @code{assq-ref} but uses @code{eqv?} for key comparison. +@end deffn + + assoc-ref +@c snarfed from alist.c:266 +@deffn primitive assoc-ref alist key +Behaves like @code{assq-ref} but uses @code{equal?} for key comparison. +@end deffn + + assq-set! +@c snarfed from alist.c:295 +@deffn primitive assq-set! alist key val +@deffnx primitive assv-set! alist key value +@deffnx primitive assoc-set! alist key value +Reassociate @var{key} in @var{alist} with @var{value}: find any existing +@var{alist} entry for @var{key} and associate it with the new +@var{value}. If @var{alist} does not contain an entry for @var{key}, +add a new one. Return the (possibly new) alist. + +These functions do not attempt to verify the structure of @var{alist}, +and so may cause unusual results if passed an object that is not an +association list. +@end deffn + + assv-set! +@c snarfed from alist.c:313 +@deffn primitive assv-set! alist key val +Behaves like @code{assq-set!} but uses @code{eqv?} for key comparison. +@end deffn + + assoc-set! +@c snarfed from alist.c:331 +@deffn primitive assoc-set! alist key val +Behaves like @code{assq-set!} but uses @code{equal?} for key comparison. +@end deffn + + assq-remove! +@c snarfed from alist.c:355 +@deffn primitive assq-remove! alist key +@deffnx primitive assv-remove! alist key +@deffnx primitive assoc-remove! alist key +Delete the first entry in @var{alist} associated with @var{key}, and return +the resulting alist. +@end deffn + + assv-remove! +@c snarfed from alist.c:371 +@deffn primitive assv-remove! alist key +Behaves like @code{assq-remove!} but uses @code{eqv?} for key comparison. +@end deffn + + assoc-remove! +@c snarfed from alist.c:387 +@deffn primitive assoc-remove! alist key +Behaves like @code{assq-remove!} but uses @code{equal?} for key comparison. +@end deffn + + make-arbiter +@c snarfed from arbiters.c:84 +@deffn primitive make-arbiter name +Return an object of type arbiter and name @var{name}. Its +state is initially unlocked. Arbiters are a way to achieve +process synchronization. +@end deffn + + try-arbiter +@c snarfed from arbiters.c:94 +@deffn primitive try-arbiter arb +Return @code{#t} and lock the arbiter @var{arb} if the arbiter +was unlocked. Otherwise, return @code{#f}. +@end deffn + + release-arbiter +@c snarfed from arbiters.c:115 +@deffn primitive release-arbiter arb +Return @code{#t} and unlock the arbiter @var{arb} if the +arbiter was locked. Otherwise, return @code{#f}. +@end deffn + + async +@c snarfed from async.c:290 +@deffn primitive async thunk +Create a new async for the procedure @var{thunk}. +@end deffn + + system-async +@c snarfed from async.c:300 +@deffn primitive system-async thunk +Create a new async for the procedure @var{thunk}. Also +add it to the system's list of active async objects. +@end deffn + + async-mark +@c snarfed from async.c:317 +@deffn primitive async-mark a +Mark the async @var{a} for future execution. +@end deffn + + system-async-mark +@c snarfed from async.c:333 +@deffn primitive system-async-mark a +Mark the async @var{a} for future execution. +@end deffn + + run-asyncs +@c snarfed from async.c:353 +@deffn primitive run-asyncs list_of_a +Execute all thunks from the asyncs of the list @var{list_of_a}. +@end deffn + + noop +@c snarfed from async.c:387 +@deffn primitive noop . args +Do nothing. When called without arguments, return @code{#f}, +otherwise return the first argument. +@end deffn + + unmask-signals +@c snarfed from async.c:439 +@deffn primitive unmask-signals +Unmask signals. The returned value is not specified. +@end deffn + + mask-signals +@c snarfed from async.c:450 +@deffn primitive mask-signals +Mask signals. The returned value is not specified. +@end deffn + + display-error +@c snarfed from backtrace.c:262 +@deffn primitive display-error stack port subr message args rest +Display an error message to the output port @var{port}. +@var{stack} is the saved stack for the error, @var{subr} is +the name of the procedure in which the error occured and +@var{message} is the actual error message, which may contain +formatting instructions. These will format the arguments in +the list @var{args} accordingly. @var{rest} is currently +ignored. +@end deffn + + display-application +@c snarfed from backtrace.c:399 +@deffn primitive display-application frame [port [indent]] +Display a procedure application @var{frame} to the output port +@var{port}. @var{indent} specifies the indentation of the +output. +@end deffn + + display-backtrace +@c snarfed from backtrace.c:617 +@deffn primitive display-backtrace stack port [first [depth]] +Display a backtrace to the output port @var{port}. @var{stack} +is the stack to take the backtrace from, @var{first} specifies +where in the stack to start and @var{depth} how much frames +to display. Both @var{first} and @var{depth} can be @code{#f}, +which means that default values will be used. +@end deffn + + backtrace +@c snarfed from backtrace.c:640 +@deffn primitive backtrace +Display a backtrace of the stack saved by the last error +to the current output port. +@end deffn + + not +@c snarfed from boolean.c:56 +@deffn primitive not x +Return @code{#t} iff @var{x} is @code{#f}, else return @code{#f}. +@end deffn + + boolean? +@c snarfed from boolean.c:66 +@deffn primitive boolean? obj +Return @code{#t} iff @var{obj} is either @code{#t} or @code{#f}. +@end deffn + + char? +@c snarfed from chars.c:56 +@deffn primitive char? x +Return @code{#t} iff @var{x} is a character, else @code{#f}. +@end deffn + + char=? +@c snarfed from chars.c:65 +@deffn primitive char=? x y +Return @code{#t} iff @var{x} is the same character as @var{y}, else @code{#f}. +@end deffn + + char? +@c snarfed from chars.c:102 +@deffn primitive char>? x y +Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII +sequence, else @code{#f}. +@end deffn + + char>=? +@c snarfed from chars.c:114 +@deffn primitive char>=? x y +Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the +ASCII sequence, else @code{#f}. +@end deffn + + char-ci=? +@c snarfed from chars.c:126 +@deffn primitive char-ci=? x y +Return @code{#t} iff @var{x} is the same character as @var{y} ignoring +case, else @code{#f}. +@end deffn + + char-ci? +@c snarfed from chars.c:162 +@deffn primitive char-ci>? x y +Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII +sequence ignoring case, else @code{#f}. +@end deffn + + char-ci>=? +@c snarfed from chars.c:174 +@deffn primitive char-ci>=? x y +Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the +ASCII sequence ignoring case, else @code{#f}. +@end deffn + + char-alphabetic? +@c snarfed from chars.c:187 +@deffn primitive char-alphabetic? chr +Return @code{#t} iff @var{chr} is alphabetic, else @code{#f}. +Alphabetic means the same thing as the isalpha C library function. +@end deffn + + char-numeric? +@c snarfed from chars.c:198 +@deffn primitive char-numeric? chr +Return @code{#t} iff @var{chr} is numeric, else @code{#f}. +Numeric means the same thing as the isdigit C library function. +@end deffn + + char-whitespace? +@c snarfed from chars.c:209 +@deffn primitive char-whitespace? chr +Return @code{#t} iff @var{chr} is whitespace, else @code{#f}. +Whitespace means the same thing as the isspace C library function. +@end deffn + + char-upper-case? +@c snarfed from chars.c:222 +@deffn primitive char-upper-case? chr +Return @code{#t} iff @var{chr} is uppercase, else @code{#f}. +Uppercase means the same thing as the isupper C library function. +@end deffn + + char-lower-case? +@c snarfed from chars.c:234 +@deffn primitive char-lower-case? chr +Return @code{#t} iff @var{chr} is lowercase, else @code{#f}. +Lowercase means the same thing as the islower C library function. +@end deffn + + char-is-both? +@c snarfed from chars.c:248 +@deffn primitive char-is-both? chr +Return @code{#t} iff @var{chr} is either uppercase or lowercase, else @code{#f}. +Uppercase and lowercase are as defined by the isupper and islower +C library functions. +@end deffn + + char->integer +@c snarfed from chars.c:262 +@deffn primitive char->integer chr +Return the number corresponding to ordinal position of @var{chr} in the +ASCII sequence. +@end deffn + + integer->char +@c snarfed from chars.c:274 +@deffn primitive integer->char n +Return the character at position @var{n} in the ASCII sequence. +@end deffn + + char-upcase +@c snarfed from chars.c:285 +@deffn primitive char-upcase chr +Return the uppercase character version of @var{chr}. +@end deffn + + char-downcase +@c snarfed from chars.c:296 +@deffn primitive char-downcase chr +Return the lowercase character version of @var{chr}. +@end deffn + + debug-options-interface +@c snarfed from debug.c:80 +@deffn primitive debug-options-interface [setting] +Option interface for the debug options. Instead of using +this procedure directly, use the procedures @code{debug-enable}, +@code{debug-disable}, @code{debug-set!} and @var{debug-options}. +@end deffn + + with-traps +@c snarfed from debug.c:128 +@deffn primitive with-traps thunk +Call @var{thunk} with traps enabled. +@end deffn + + memoized? +@c snarfed from debug.c:170 +@deffn primitive memoized? obj +Return @code{#t} if @var{obj} is memoized. +@end deffn + + unmemoize +@c snarfed from debug.c:376 +@deffn primitive unmemoize m +Unmemoize the memoized expression @var{m}, +@end deffn + + memoized-environment +@c snarfed from debug.c:386 +@deffn primitive memoized-environment m +Return the environment of the memoized expression @var{m}. +@end deffn + + procedure-name +@c snarfed from debug.c:396 +@deffn primitive procedure-name proc +Return the name of the procedure @var{proc} +@end deffn + + procedure-source +@c snarfed from debug.c:422 +@deffn primitive procedure-source proc +Return the source of the procedure @var{proc}. +@end deffn + + procedure-environment +@c snarfed from debug.c:456 +@deffn primitive procedure-environment proc +Return the environment of the procedure @var{proc}. +@end deffn + + local-eval +@c snarfed from debug.c:488 +@deffn primitive local-eval exp [env] +Evaluate @var{exp} in its environment. If @var{env} is supplied, +it is the environment in which to evaluate @var{exp}. Otherwise, +@var{exp} must be a memoized code object (in which case, its environment +is implicit). +@end deffn + + debug-object? +@c snarfed from debug.c:576 +@deffn primitive debug-object? obj +Return @code{#t} if @var{obj} is a debug object. +@end deffn + + c-registered-modules +@c snarfed from dynl.c:183 +@deffn primitive c-registered-modules +Return a list of the object code modules that have been imported into +the current Guile process. Each element of the list is a pair whose +car is the name of the module, and whose cdr is the function handle +for that module's initializer function. The name is the string that +has been passed to scm_register_module_xxx. +@end deffn + + c-clear-registered-modules +@c snarfed from dynl.c:204 +@deffn primitive c-clear-registered-modules +Destroy the list of modules registered with the current Guile process. +The return value is unspecified. @strong{Warning:} this function does +not actually unlink or deallocate these modules, but only destroys the +records of which modules have been loaded. It should therefore be used +only by module bookkeeping operations. +@end deffn + + dynamic-link +@c snarfed from dynl.c:356 +@deffn primitive dynamic-link fname +Open the dynamic library @var{library-file}. A library handle +representing the opened library is returned; this handle should be used +as the @var{lib} argument to the following functions. +@end deffn + + dynamic-object? +@c snarfed from dynl.c:372 +@deffn primitive dynamic-object? obj +Return @code{#t} if @var{obj} is a dynamic library handle, or @code{#f} +otherwise. +@end deffn + + dynamic-unlink +@c snarfed from dynl.c:388 +@deffn primitive dynamic-unlink dobj +Unlink the library represented by @var{library-handle}, +and remove any imported symbols from the address space. +GJB:FIXME:DOC: 2nd version below: +Unlink the indicated object file from the application. The +argument @var{dynobj} must have been obtained by a call to +@code{dynamic-link}. After @code{dynamic-unlink} has been +called on @var{dynobj}, its content is no longer accessible. +@end deffn + + dynamic-func +@c snarfed from dynl.c:415 +@deffn primitive dynamic-func name dobj +Search the dynamic object @var{dobj} for the C function +indicated by the string @var{name} and return some Scheme +handle that can later be used with @code{dynamic-call} to +actually call the function. + +Regardless whether your C compiler prepends an underscore @samp{_} to +the global names in a program, you should @strong{not} include this +underscore in @var{function}. Guile knows whether the underscore is +needed or not and will add it when necessary. +@end deffn + + dynamic-call +@c snarfed from dynl.c:460 +@deffn primitive dynamic-call func dobj +Call @var{lib-thunk}, a procedure of no arguments. If @var{lib-thunk} +is a string, it is assumed to be a symbol found in the dynamic library +@var{lib} and is fetched with @code{dynamic-func}. Otherwise, it should +be a function handle returned by a previous call to @code{dynamic-func}. +The return value is unspecified. +GJB:FIXME:DOC 2nd version below +Call the C function indicated by @var{function} and @var{dynobj}. The +function is passed no arguments and its return value is ignored. When +@var{function} is something returned by @code{dynamic-func}, call that +function and ignore @var{dynobj}. When @var{function} is a string (or +symbol, etc.), look it up in @var{dynobj}; this is equivalent to + +@smallexample +(dynamic-call (dynamic-func @var{function} @var{dynobj} #f)) +@end smallexample + +Interrupts are deferred while the C function is executing (with +@code{SCM_DEFER_INTS}/@code{SCM_ALLOW_INTS}). +@end deffn + + dynamic-args-call +@c snarfed from dynl.c:494 +@deffn primitive dynamic-args-call func dobj args +Call @var{proc}, a dynamically loaded function, passing it the argument +list @var{args} (a list of strings). As with @code{dynamic-call}, +@var{proc} should be either a function handle or a string, in which case +it is first fetched from @var{lib} with @code{dynamic-func}. + +@var{proc} is assumed to return an integer, which is used as the return +value from @code{dynamic-args-call}. + +GJB:FIXME:DOC 2nd version below +Call the C function indicated by @var{function} and @var{dynobj}, just +like @code{dynamic-call}, but pass it some arguments and return its +return value. The C function is expected to take two arguments and +return an @code{int}, just like @code{main}: + +@smallexample +int c_func (int argc, char **argv); +@end smallexample + +The parameter @var{args} must be a list of strings and is converted into +an array of @code{char *}. The array is passed in @var{argv} and its +size in @var{argc}. The return value is converted to a Scheme number +and returned from the call to @code{dynamic-args-call}. +@end deffn + + dynamic-wind +@c snarfed from dynwind.c:115 +@deffn primitive dynamic-wind thunk1 thunk2 thunk3 +All three arguments must be 0-argument procedures. + +@var{in-guard} is called, then @var{thunk}, then @var{out-guard}. + +If, any time during the execution of @var{thunk}, the continuation +of the @code{dynamic-wind} expression is escaped non-locally, @var{out-guard} +is called. If the continuation of the dynamic-wind is re-entered, +@var{in-guard} is called. Thus @var{in-guard} and @var{out-guard} may +be called any number of times. + +@example +(define x 'normal-binding) +@result{} x + +(define a-cont (call-with-current-continuation + (lambda (escape) + (let ((old-x x)) + (dynamic-wind + ;; in-guard: + ;; + (lambda () (set! x 'special-binding)) + + ;; thunk + ;; + (lambda () (display x) (newline) + (call-with-current-continuation escape) + (display x) (newline) + x) + + ;; out-guard: + ;; + (lambda () (set! x old-x))))))) + +;; Prints: +special-binding +;; Evaluates to: +@result{} a-cont + +x +@result{} normal-binding + +(a-cont #f) +;; Prints: +special-binding +;; Evaluates to: +@result{} a-cont ;; the value of the (define a-cont...) + +x +@result{} normal-binding + +a-cont +@result{} special-binding +@end example +@end deffn + + environment? +@c snarfed from environments.c:135 +@deffn primitive environment? obj +Return @code{#t} if @var{obj} is an environment, or @code{#f} +otherwise. +@end deffn + + environment-bound? +@c snarfed from environments.c:146 +@deffn primitive environment-bound? env sym +Return @code{#t} if @var{sym} is bound in @var{env}, or +@code{#f} otherwise. +@end deffn + + environment-ref +@c snarfed from environments.c:161 +@deffn primitive environment-ref env sym +Return the value of the location bound to @var{sym} in +@var{env}. If @var{sym} is unbound in @var{env}, signal an +@code{environment:unbound} error. +@end deffn + + environment-fold +@c snarfed from environments.c:231 +@deffn primitive environment-fold env proc init +Iterate over all the bindings in @var{env}, accumulating some +value. +For each binding in @var{env}, apply @var{proc} to the symbol +bound, its value, and the result from the previous application +of @var{proc}. +Use @var{init} as @var{proc}'s third argument the first time +@var{proc} is applied. +If @var{env} contains no bindings, this function simply returns +@var{init}. +If @var{env} binds the symbol sym1 to the value val1, sym2 to +val2, and so on, then this procedure computes: +@example + (proc sym1 val1 + (proc sym2 val2 + ... + (proc symn valn + init))) +@end example +Each binding in @var{env} will be processed exactly once. +@code{environment-fold} makes no guarantees about the order in +which the bindings are processed. +Here is a function which, given an environment, constructs an +association list representing that environment's bindings, +using environment-fold: +@example + (define (environment->alist env) + (environment-fold env + (lambda (sym val tail) + (cons (cons sym val) tail)) + '())) +@end example +@end deffn + + environment-define +@c snarfed from environments.c:266 +@deffn primitive environment-define env sym val +Bind @var{sym} to a new location containing @var{val} in +@var{env}. If @var{sym} is already bound to another location +in @var{env} and the binding is mutable, that binding is +replaced. The new binding and location are both mutable. The +return value is unspecified. +If @var{sym} is already bound in @var{env}, and the binding is +immutable, signal an @code{environment:immutable-binding} error. +@end deffn + + environment-undefine +@c snarfed from environments.c:292 +@deffn primitive environment-undefine env sym +Remove any binding for @var{sym} from @var{env}. If @var{sym} +is unbound in @var{env}, do nothing. The return value is +unspecified. +If @var{sym} is already bound in @var{env}, and the binding is +immutable, signal an @code{environment:immutable-binding} error. +@end deffn + + environment-set! +@c snarfed from environments.c:320 +@deffn primitive environment-set! env sym val +If @var{env} binds @var{sym} to some location, change that +location's value to @var{val}. The return value is +unspecified. +If @var{sym} is not bound in @var{env}, signal an +@code{environment:unbound} error. If @var{env} binds @var{sym} +to an immutable location, signal an +@code{environment:immutable-location} error. +@end deffn + + environment-cell +@c snarfed from environments.c:355 +@deffn primitive environment-cell env sym for_write +Return the value cell which @var{env} binds to @var{sym}, or +@code{#f} if the binding does not live in a value cell. +The argument @var{for-write} indicates whether the caller +intends to modify the variable's value by mutating the value +cell. If the variable is immutable, then +@code{environment-cell} signals an +@code{environment:immutable-location} error. +If @var{sym} is unbound in @var{env}, signal an +@code{environment:unbound} error. +If you use this function, you should consider using +@code{environment-observe}, to be notified when @var{sym} gets +re-bound to a new value cell, or becomes undefined. +@end deffn + + environment-observe +@c snarfed from environments.c:407 +@deffn primitive environment-observe env proc +Whenever @var{env}'s bindings change, apply @var{proc} to +@var{env}. +This function returns an object, token, which you can pass to +@code{environment-unobserve} to remove @var{proc} from the set +of procedures observing @var{env}. The type and value of +token is unspecified. +@end deffn + + environment-observe-weak +@c snarfed from environments.c:424 +@deffn primitive environment-observe-weak env proc +This function is the same as environment-observe, except that +the reference @var{env} retains to @var{proc} is a weak +reference. This means that, if there are no other live, +non-weak references to @var{proc}, it will be +garbage-collected, and dropped from @var{env}'s +list of observing procedures. +@end deffn + + environment-unobserve +@c snarfed from environments.c:460 +@deffn primitive environment-unobserve token +Cancel the observation request which returned the value +@var{token}. The return value is unspecified. +If a call @code{(environment-observe env proc)} returns +@var{token}, then the call @code{(environment-unobserve token)} +will cause @var{proc} to no longer be called when @var{env}'s +bindings change. +@end deffn + + make-leaf-environment +@c snarfed from environments.c:1040 +@deffn primitive make-leaf-environment +Create a new leaf environment, containing no bindings. +All bindings and locations created in the new environment +will be mutable. +@end deffn + + leaf-environment? +@c snarfed from environments.c:1063 +@deffn primitive leaf-environment? object +Return @code{#t} if object is a leaf environment, or @code{#f} +otherwise. +@end deffn + + make-eval-environment +@c snarfed from environments.c:1429 +@deffn primitive make-eval-environment local imported +Return a new environment object eval whose bindings are the +union of the bindings in the environments @var{local} and +@var{imported}, with bindings from @var{local} taking +precedence. Definitions made in eval are placed in @var{local}. +Applying @code{environment-define} or +@code{environment-undefine} to eval has the same effect as +applying the procedure to @var{local}. +Note that eval incorporates @var{local} and @var{imported} by +reference: +If, after creating eval, the program changes the bindings of +@var{local} or @var{imported}, those changes will be visible +in eval. +Since most Scheme evaluation takes place in eval environments, +they transparently cache the bindings received from @var{local} +and @var{imported}. Thus, the first time the program looks up +a symbol in eval, eval may make calls to @var{local} or +@var{imported} to find their bindings, but subsequent +references to that symbol will be as fast as references to +bindings in finite environments. +In typical use, @var{local} will be a finite environment, and +@var{imported} will be an import environment +@end deffn + + eval-environment? +@c snarfed from environments.c:1466 +@deffn primitive eval-environment? object +Return @code{#t} if object is an eval environment, or @code{#f} +otherwise. +@end deffn + + eval-environment-local +@c snarfed from environments.c:1476 +@deffn primitive eval-environment-local env +Return the local environment of eval environment @var{env}. +@end deffn + + eval-environment-set-local! +@c snarfed from environments.c:1488 +@deffn primitive eval-environment-set-local! env local +Change @var{env}'s local environment to @var{local}. +@end deffn + + eval-environment-imported +@c snarfed from environments.c:1514 +@deffn primitive eval-environment-imported env +Return the imported environment of eval environment @var{env}. +@end deffn + + eval-environment-set-imported! +@c snarfed from environments.c:1526 +@deffn primitive eval-environment-set-imported! env imported +Change @var{env}'s imported environment to @var{imported}. +@end deffn + + make-import-environment +@c snarfed from environments.c:1846 +@deffn primitive make-import-environment imports conflict_proc +Return a new environment @var{imp} whose bindings are the union +of the bindings from the environments in @var{imports}; +@var{imports} must be a list of environments. That is, +@var{imp} binds a symbol to a location when some element of +@var{imports} does. +If two different elements of @var{imports} have a binding for +the same symbol, the @var{conflict-proc} is called with the +following parameters: the import environment, the symbol and +the list of the imported environments that bind the symbol. +If the @var{conflict-proc} returns an environment @var{env}, +the conflict is considered as resolved and the binding from +@var{env} is used. If the @var{conflict-proc} returns some +non-environment object, the conflict is considered unresolved +and the symbol is treated as unspecified in the import +environment. +The checking for conflicts may be performed lazily, i. e. at +the moment when a value or binding for a certain symbol is +requested instead of the moment when the environment is +created or the bindings of the imports change. +All bindings in @var{imp} are immutable. If you apply +@code{environment-define} or @code{environment-undefine} to +@var{imp}, Guile will signal an + @code{environment:immutable-binding} error. However, +notice that the set of bindings in @var{imp} may still change, +if one of its imported environments changes. +@end deffn + + import-environment? +@c snarfed from environments.c:1875 +@deffn primitive import-environment? object +Return @code{#t} if object is an import environment, or +@code{#f} otherwise. +@end deffn + + import-environment-imports +@c snarfed from environments.c:1886 +@deffn primitive import-environment-imports env +Return the list of environments imported by the import +environment @var{env}. +@end deffn + + import-environment-set-imports! +@c snarfed from environments.c:1899 +@deffn primitive import-environment-set-imports! env imports +Change @var{env}'s list of imported environments to +@var{imports}, and check for conflicts. +@end deffn + + make-export-environment +@c snarfed from environments.c:2164 +@deffn primitive make-export-environment private signature +Return a new environment @var{exp} containing only those +bindings in private whose symbols are present in +@var{signature}. The @var{private} argument must be an +environment. + +The environment @var{exp} binds symbol to location when +@var{env} does, and symbol is exported by @var{signature}. + +@var{signature} is a list specifying which of the bindings in +@var{private} should be visible in @var{exp}. Each element of +@var{signature} should be a list of the form: + (symbol attribute ...) +where each attribute is one of the following: +@table @asis +@item the symbol @code{mutable-location} + @var{exp} should treat the + location bound to symbol as mutable. That is, @var{exp} + will pass calls to @code{environment-set!} or + @code{environment-cell} directly through to private. +@item the symbol @code{immutable-location} + @var{exp} should treat + the location bound to symbol as immutable. If the program + applies @code{environment-set!} to @var{exp} and symbol, or + calls @code{environment-cell} to obtain a writable value + cell, @code{environment-set!} will signal an + @code{environment:immutable-location} error. Note that, even + if an export environment treats a location as immutable, the + underlying environment may treat it as mutable, so its + value may change. +@end table +It is an error for an element of signature to specify both +@code{mutable-location} and @code{immutable-location}. If +neither is specified, @code{immutable-location} is assumed. + +As a special case, if an element of signature is a lone +symbol @var{sym}, it is equivalent to an element of the form +@code{(sym)}. + +All bindings in @var{exp} are immutable. If you apply +@code{environment-define} or @code{environment-undefine} to +@var{exp}, Guile will signal an +@code{environment:immutable-binding} error. However, +notice that the set of bindings in @var{exp} may still change, +if the bindings in private change. +@end deffn + + export-environment? +@c snarfed from environments.c:2199 +@deffn primitive export-environment? object +Return @code{#t} if object is an export environment, or +@code{#f} otherwise. +@end deffn + + export-environment-private +@c snarfed from environments.c:2209 +@deffn primitive export-environment-private env +Return the private environment of export environment @var{env}. +@end deffn + + export-environment-set-private! +@c snarfed from environments.c:2221 +@deffn primitive export-environment-set-private! env private +Change the private environment of export environment @var{env}. +@end deffn + + export-environment-signature +@c snarfed from environments.c:2243 +@deffn primitive export-environment-signature env +Return the signature of export environment @var{env}. +@end deffn + + export-environment-set-signature! +@c snarfed from environments.c:2317 +@deffn primitive export-environment-set-signature! env signature +Change the signature of export environment @var{env}. +@end deffn + + eq? +@c snarfed from eq.c:64 +@deffn primitive eq? x y +Return @code{#t} iff @var{x} references the same object as @var{y}. +@code{eq?} is similar to @code{eqv?} except that in some cases it is +capable of discerning distinctions finer than those detectable by +@code{eqv?}. +@end deffn + + eqv? +@c snarfed from eq.c:78 +@deffn primitive eqv? x y +The @code{eqv?} procedure defines a useful equivalence relation on objects. +Briefly, it returns @code{#t} if @var{x} and @var{y} should normally be +regarded as the same object. This relation is left slightly open to +interpretation, but works for comparing immediate integers, characters, +and inexact numbers. +@end deffn + + equal? +@c snarfed from eq.c:127 +@deffn primitive equal? x y +Return @code{#t} iff @var{x} and @var{y} are recursively @code{eqv?} equivalent. +@code{equal?} recursively compares the contents of pairs, +vectors, and strings, applying @code{eqv?} on other objects such as +numbers and symbols. A rule of thumb is that objects are generally +@code{equal?} if they print the same. @code{equal?} may fail to +terminate if its arguments are circular data structures. +@end deffn + + scm-error +@c snarfed from error.c:112 +@deffn primitive scm-error key subr message args rest +Raise an error with key @var{key}. @var{subr} can be a string naming +the procedure associated with the error, or @code{#f}. @var{message} +is the error message string, possibly containing @code{~S} and @code{~A} +escapes. When an error is reported, these are replaced by formating the +corresponding members of @var{args}: @code{~A} (was @code{%s}) formats using @code{display} +and @code{~S} (was @code{%S}) formats using @code{write}. @var{data} is a +list or @code{#f} depending on @var{key}: if @var{key} is +@code{system-error} then it should be a list +containing the Unix @code{errno} value; If @var{key} is @code{signal} then +it should be a list containing the Unix signal number; otherwise it +will usually be @code{#f}. +@end deffn + + strerror +@c snarfed from error.c:153 +@deffn primitive strerror err +Returns the Unix error message corresponding to @var{err}, an integer. +@end deffn + + apply:nconc2last +@c snarfed from eval.c:3221 +@deffn primitive apply:nconc2last lst +Given a list (@var{arg1} @dots{} @var{args}), this function +conses the @var{arg1} @dots{} arguments onto the front of +@var{args}, and returns the resulting list. Note that +@var{args} is a list; thus, the argument to this function is +a list whose last element is a list. +Note: Rather than do new consing, @code{apply:nconc2last} +destroys its argument, so use with care. +@end deffn + + force +@c snarfed from eval.c:3754 +@deffn primitive force x +If the promise @var{x} has not been computed yet, compute and +return @var{x}, otherwise just return the previously computed +value. +@end deffn + + promise? +@c snarfed from eval.c:3777 +@deffn primitive promise? obj +Return true if @var{obj} is a promise, i.e. a delayed computation +(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}). +@end deffn + + cons-source +@c snarfed from eval.c:3789 +@deffn primitive cons-source xorig x y +Create and return a new pair whose car and cdr are @var{x} and @var{y}. +Any source properties associated with @var{xorig} are also associated +with the new pair. +@end deffn + + copy-tree +@c snarfed from eval.c:3811 +@deffn primitive copy-tree obj +Recursively copy the data tree that is bound to @var{obj}, and return a +pointer to the new data structure. @code{copy-tree} recurses down the +contents of both pairs and vectors (since both cons cells and vector +cells may point to arbitrary objects), and stops recursing when it hits +any other object. +@end deffn + + primitive-eval +@c snarfed from eval.c:3912 +@deffn primitive primitive-eval exp +Evaluate @var{exp} in the top-level environment specified by +the current module. +@end deffn + + eval +@c snarfed from eval.c:3977 +@deffn primitive eval exp module +Evaluate @var{exp}, a list representing a Scheme expression, +in the top-level environment specified by @var{module}. +While @var{exp} is evaluated (using @var{primitive-eval}), +@var{module} is made the current module. The current module +is reset to its previous value when @var{eval} returns. +@end deffn + + eval2 +@c snarfed from eval.c:4020 +@deffn primitive eval2 obj env_thunk +Evaluate @var{exp}, a Scheme expression, in the environment +designated by @var{lookup}, a symbol-lookup function." +Do not use this version of eval, it does not play well +with the module system. Use @code{eval} or +@code{primitive-eval} instead. +@end deffn + + eval-options-interface +@c snarfed from eval.c:1685 +@deffn primitive eval-options-interface [setting] +Option interface for the evaluation options. Instead of using +this procedure directly, use the procedures @code{eval-enable}, +@code{eval-disable}, @code{eval-set!} and @var{eval-options}. +@end deffn + + evaluator-traps-interface +@c snarfed from eval.c:1702 +@deffn primitive evaluator-traps-interface [setting] +Option interface for the evaluator trap options. +@end deffn + + defined? +@c snarfed from evalext.c:74 +@deffn primitive defined? sym [env] +Return @code{#t} if @var{sym} is defined in the top-level environment. +@end deffn + + map-in-order +@c snarfed from evalext.c:146 +@deffn primitive map-in-order +scm_map +@end deffn + + program-arguments +@c snarfed from feature.c:79 +@deffn primitive program-arguments +@deffnx procedure command-line +Return the list of command line arguments passed to Guile, as a list of +strings. The list includes the invoked program name, which is usually +@code{"guile"}, but excludes switches and parameters for command line +options like @code{-e} and @code{-l}. +@end deffn + + chown +@c snarfed from filesys.c:140 +@deffn primitive chown object owner group +Change the ownership and group of the file referred to by @var{object} to +the integer values @var{owner} and @var{group}. @var{object} can be +a string containing a file name or, if the platform +supports fchown, a port or integer file descriptor +which is open on the file. The return value +is unspecified. + +If @var{object} is a symbolic link, either the +ownership of the link or the ownership of the referenced file will be +changed depending on the operating system (lchown is +unsupported at present). If @var{owner} or @var{group} is specified +as @code{-1}, then that ID is not changed. +@end deffn + + chmod +@c snarfed from filesys.c:180 +@deffn primitive chmod object mode +Changes the permissions of the file referred to by @var{obj}. +@var{obj} can be a string containing a file name or a port or integer file +descriptor which is open on a file (in which case @code{fchmod} is used +as the underlying system call). +@var{mode} specifies +the new permissions as a decimal number, e.g., @code{(chmod "foo" #o755)}. +The return value is unspecified. +@end deffn + + umask +@c snarfed from filesys.c:214 +@deffn primitive umask [mode] +If @var{mode} is omitted, retuns a decimal number representing the current +file creation mask. Otherwise the file creation mask is set to +@var{mode} and the previous value is returned. + +E.g., @code{(umask #o022)} sets the mask to octal 22, decimal 18. +@end deffn + + open-fdes +@c snarfed from filesys.c:237 +@deffn primitive open-fdes path flags [mode] +Similar to @code{open} but returns a file descriptor instead of a +port. +@end deffn + + open +@c snarfed from filesys.c:280 +@deffn primitive open path flags [mode] +Open the file named by @var{path} for reading and/or writing. +@var{flags} is an integer specifying how the file should be opened. +@var{mode} is an integer specifying the permission bits of the file, if +it needs to be created, before the umask is applied. The default is 666 +(Unix itself has no default). + +@var{flags} can be constructed by combining variables using @code{logior}. +Basic flags are: + +@defvar O_RDONLY +Open the file read-only. +@end defvar +@defvar O_WRONLY +Open the file write-only. +@end defvar +@defvar O_RDWR +Open the file read/write. +@end defvar +@defvar O_APPEND +Append to the file instead of truncating. +@end defvar +@defvar O_CREAT +Create the file if it does not already exist. +@end defvar + +See the Unix documentation of the @code{open} system call +for additional flags. +@end deffn + + close +@c snarfed from filesys.c:318 +@deffn primitive close fd_or_port +Similar to close-port (@pxref{Generic Port Operations, close-port}), +but also works on file descriptors. A side +effect of closing a file descriptor is that any ports using that file +descriptor are moved to a different file descriptor and have +their revealed counts set to zero. +@end deffn + + close-fdes +@c snarfed from filesys.c:346 +@deffn primitive close-fdes fd +A simple wrapper for the @code{close} system call. +Close file descriptor @var{fd}, which must be an integer. +Unlike close (@pxref{Ports and File Descriptors, close}), +the file descriptor will be closed even if a port is using it. +The return value is unspecified. +@end deffn + + stat +@c snarfed from filesys.c:518 +@deffn primitive stat object +Returns an object containing various information +about the file determined by @var{obj}. +@var{obj} can be a string containing a file name or a port or integer file +descriptor which is open on a file (in which case @code{fstat} is used +as the underlying system call). + +The object returned by @code{stat} can be passed as a single parameter +to the following procedures, all of which return integers: + +@table @code +@item stat:dev +The device containing the file. +@item stat:ino +The file serial number, which distinguishes this file from all other +files on the same device. +@item stat:mode +The mode of the file. This includes file type information +and the file permission bits. See @code{stat:type} and @code{stat:perms} +below. +@item stat:nlink +The number of hard links to the file. +@item stat:uid +The user ID of the file's owner. +@item stat:gid +The group ID of the file. +@item stat:rdev +Device ID; this entry is defined only for character or block +special files. +@item stat:size +The size of a regular file in bytes. +@item stat:atime +The last access time for the file. +@item stat:mtime +The last modification time for the file. +@item stat:ctime +The last modification time for the attributes of the file. +@item stat:blksize +The optimal block size for reading or writing the file, in bytes. +@item stat:blocks +The amount of disk space that the file occupies measured in units of +512 byte blocks. +@end table + +In addition, the following procedures return the information +from stat:mode in a more convenient form: + +@table @code +@item stat:type +A symbol representing the type of file. Possible values are +regular, directory, symlink, block-special, char-special, +fifo, socket and unknown +@item stat:perms +An integer representing the access permission bits. +@end table +@end deffn + + link +@c snarfed from filesys.c:564 +@deffn primitive link oldpath newpath +Creates a new name @var{newpath} in the file system for the +file named by @var{oldpath}. If @var{oldpath} is a symbolic +link, the link may or may not be followed depending on the +system. +@end deffn + + rename-file +@c snarfed from filesys.c:586 +@deffn primitive rename-file oldname newname +Renames the file specified by @var{oldname} to @var{newname}. +The return value is unspecified. +@end deffn + + delete-file +@c snarfed from filesys.c:615 +@deffn primitive delete-file str +Deletes (or "unlinks") the file specified by @var{path}. +@end deffn + + mkdir +@c snarfed from filesys.c:634 +@deffn primitive mkdir path [mode] +Create a new directory named by @var{path}. If @var{mode} is omitted +then the permissions of the directory file are set using the current +umask. Otherwise they are set to the decimal value specified with +@var{mode}. The return value is unspecified. +@end deffn + + rmdir +@c snarfed from filesys.c:663 +@deffn primitive rmdir path +Remove the existing directory named by @var{path}. The directory must +be empty for this to succeed. The return value is unspecified. +@end deffn + + directory-stream? +@c snarfed from filesys.c:689 +@deffn primitive directory-stream? obj +Returns a boolean indicating whether @var{object} is a directory stream +as returned by @code{opendir}. +@end deffn + + opendir +@c snarfed from filesys.c:700 +@deffn primitive opendir dirname +Open the directory specified by @var{path} and return a directory +stream. +@end deffn + + readdir +@c snarfed from filesys.c:718 +@deffn primitive readdir port +Return (as a string) the next directory entry from the directory stream +@var{stream}. If there is no remaining entry to be read then the +end of file object is returned. +@end deffn + + rewinddir +@c snarfed from filesys.c:741 +@deffn primitive rewinddir port +Reset the directory port @var{stream} so that the next call to +@code{readdir} will return the first directory entry. +@end deffn + + closedir +@c snarfed from filesys.c:758 +@deffn primitive closedir port +Close the directory stream @var{stream}. +The return value is unspecified. +@end deffn + + chdir +@c snarfed from filesys.c:808 +@deffn primitive chdir str +Change the current working directory to @var{path}. +The return value is unspecified. +@end deffn + + getcwd +@c snarfed from filesys.c:825 +@deffn primitive getcwd +Returns the name of the current working directory. +@end deffn + + select +@c snarfed from filesys.c:1022 +@deffn primitive select reads writes excepts [secs [usecs]] +This procedure has a variety of uses: waiting for the ability +to provide input, accept output, or the existance of +exceptional conditions on a collection of ports or file +descriptors, or waiting for a timeout to occur. +It also returns if interrupted by a signal. + +@var{reads}, @var{writes} and @var{excepts} can be lists or +vectors, with each member a port or a file descriptor. +The value returned is a list of three corresponding +lists or vectors containing only the members which meet the +specified requirement. The ability of port buffers to +provide input or accept output is taken into account. +Ordering of the input lists or vectors is not preserved. + +The optional arguments @var{secs} and @var{usecs} specify the +timeout. Either @var{secs} can be specified alone, as +either an integer or a real number, or both @var{secs} and +@var{usecs} can be specified as integers, in which case +@var{usecs} is an additional timeout expressed in +microseconds. If @var{secs} is omitted or is @code{#f} then +select will wait for as long as it takes for one of the other +conditions to be satisfied. + +The scsh version of @code{select} differs as follows: +Only vectors are accepted for the first three arguments. +The @var{usecs} argument is not supported. +Multiple values are returned instead of a list. +Duplicates in the input vectors appear only once in output. +An additional @code{select!} interface is provided. +@end deffn + + fcntl +@c snarfed from filesys.c:1167 +@deffn primitive fcntl object cmd [value] +Apply @var{command} to the specified file descriptor or the underlying +file descriptor of the specified port. @var{value} is an optional +integer argument. + +Values for @var{command} are: + +@table @code +@item F_DUPFD +Duplicate a file descriptor +@item F_GETFD +Get flags associated with the file descriptor. +@item F_SETFD +Set flags associated with the file descriptor to @var{value}. +@item F_GETFL +Get flags associated with the open file. +@item F_SETFL +Set flags associated with the open file to @var{value} +@item F_GETOWN +Get the process ID of a socket's owner, for @code{SIGIO} signals. +@item F_SETOWN +Set the process that owns a socket to @var{value}, for @code{SIGIO} signals. +@item FD_CLOEXEC +The value used to indicate the "close on exec" flag with @code{F_GETFL} or +@code{F_SETFL}. +@end table +@end deffn + + fsync +@c snarfed from filesys.c:1203 +@deffn primitive fsync object +Copies any unwritten data for the specified output file descriptor to disk. +If @var{port/fd} is a port, its buffer is flushed before the underlying +file descriptor is fsync'd. +The return value is unspecified. +@end deffn + + symlink +@c snarfed from filesys.c:1230 +@deffn primitive symlink oldpath newpath +Create a symbolic link named @var{path-to} with the value (i.e., pointing to) +@var{path-from}. The return value is unspecified. +@end deffn + + readlink +@c snarfed from filesys.c:1252 +@deffn primitive readlink path +Returns the value of the symbolic link named by +@var{path} (a string), i.e., the +file that the link points to. +@end deffn + + lstat +@c snarfed from filesys.c:1282 +@deffn primitive lstat str +Similar to @code{stat}, but does not follow symbolic links, i.e., +it will return information about a symbolic link itself, not the +file it points to. @var{path} must be a string. +@end deffn + + copy-file +@c snarfed from filesys.c:1307 +@deffn primitive copy-file oldfile newfile +Copy the file specified by @var{path-from} to @var{path-to}. +The return value is unspecified. +@end deffn + + dirname +@c snarfed from filesys.c:1354 +@deffn primitive dirname filename +Return the directory name component of the file name +@var{filename}. If @var{filename} does not contain a directory +component, @code{.} is returned. +@end deffn + + basename +@c snarfed from filesys.c:1387 +@deffn primitive basename filename [suffix] +Return the base name of the file name @var{filename}. The +base name is the file name without any directory components. +If @var{suffix} is privided, and is equal to the end of +@var{basename}, it is removed also. +@end deffn + + make-fluid +@c snarfed from fluids.c:128 +@deffn primitive make-fluid +Return a newly created fluid. +Fluids are objects of a certain type (a smob) that can hold one SCM +value per dynamic root. That is, modifications to this value are +only visible to code that executes within the same dynamic root as +the modifying code. When a new dynamic root is constructed, it +inherits the values from its parent. Because each thread executes +in its own dynamic root, you can use fluids for thread local storage. +@end deffn + + fluid? +@c snarfed from fluids.c:141 +@deffn primitive fluid? obj +Return #t iff @var{obj} is a fluid; otherwise, return #f. +@end deffn + + fluid-ref +@c snarfed from fluids.c:151 +@deffn primitive fluid-ref fluid +Return the value associated with @var{fluid} in the current dynamic root. +If @var{fluid} has not been set, then this returns #f. +@end deffn + + fluid-set! +@c snarfed from fluids.c:168 +@deffn primitive fluid-set! fluid value +Set the value associated with @var{fluid} in the current dynamic root. +@end deffn + + with-fluids* +@c snarfed from fluids.c:227 +@deffn primitive with-fluids* fluids values thunk +Set @var{fluids} to @var{values} temporary, and call @var{thunk}. +@var{fluids} must be a list of fluids and @var{values} must be the same +number of their values to be applied. Each substitution is done +one after another. @var{thunk} must be a procedure with no argument. +@end deffn + + setvbuf +@c snarfed from fports.c:148 +@deffn primitive setvbuf port mode [size] +Set the buffering mode for @var{port}. @var{mode} can be: +@table @code +@item _IONBF +non-buffered +@item _IOLBF +line buffered +@item _IOFBF +block buffered, using a newly allocated buffer of @var{size} bytes. +If @var{size} is omitted, a default size will be used. +@end table +@end deffn + + file-port? +@c snarfed from fports.c:229 +@deffn primitive file-port? obj +Determine whether @var{obj} is a port that is related to a file. +@end deffn + + open-file +@c snarfed from fports.c:282 +@deffn primitive open-file filename modes +Open the file whose name is @var{string}, and return a port +representing that file. The attributes of the port are +determined by the @var{mode} string. The way in +which this is interpreted is similar to C stdio: + +The first character must be one of the following: + +@table @samp +@item r +Open an existing file for input. +@item w +Open a file for output, creating it if it doesn't already exist +or removing its contents if it does. +@item a +Open a file for output, creating it if it doesn't already exist. +All writes to the port will go to the end of the file. +The "append mode" can be turned off while the port is in use +@pxref{Ports and File Descriptors, fcntl} +@end table + +The following additional characters can be appended: + +@table @samp +@item + +Open the port for both input and output. E.g., @code{r+}: open +an existing file for both input and output. +@item 0 +Create an "unbuffered" port. In this case input and output operations +are passed directly to the underlying port implementation without +additional buffering. This is likely to slow down I/O operations. +The buffering mode can be changed while a port is in use +@pxref{Ports and File Descriptors, setvbuf} +@item l +Add line-buffering to the port. The port output buffer will be +automatically flushed whenever a newline character is written. +@end table + +In theory we could create read/write ports which were buffered in one +direction only. However this isn't included in the current interfaces. + +If a file cannot be opened with the access requested, +@code{open-file} throws an exception. +@end deffn + + gc-stats +@c snarfed from gc.c:742 +@deffn primitive gc-stats +Returns an association list of statistics about Guile's current use of storage. +@end deffn + + object-address +@c snarfed from gc.c:839 +@deffn primitive object-address obj +Return an integer that for the lifetime of @var{obj} is uniquely +returned by this function for @var{obj} +@end deffn + + gc +@c snarfed from gc.c:850 +@deffn primitive gc +Scans all of SCM objects and reclaims for further use those that are +no longer accessible. +@end deffn + + unhash-name +@c snarfed from gc.c:2291 +@deffn primitive unhash-name name +Flushes the glocs for @var{name}, or all glocs if @var{name} +is @code{#t}. +@end deffn + + %compute-slots +@c snarfed from goops.c:290 +@deffn primitive %compute-slots class +Return a list consisting of the names of all slots belonging to +class @var{class}, i. e. the slots of @var{class} and of all of +its superclasses. +@end deffn + + get-keyword +@c snarfed from goops.c:375 +@deffn primitive get-keyword key l default_value +Determine an associated value for the keyword @var{key} from +the list @var{l}. The list @var{l} has to consist of an even +number of elements, where, starting with the first, every +second element is a keyword, followed by its associated value. +If @var{l} does not hold a value for @var{key}, the value +@var{default_value} is returned. +@end deffn + + %initialize-object +@c snarfed from goops.c:398 +@deffn primitive %initialize-object obj initargs +Initialize the object @var{obj} with the given arguments +@var{initargs}. +@end deffn + + %prep-layout! +@c snarfed from goops.c:479 +@deffn primitive %prep-layout! class +@end deffn + + %inherit-magic! +@c snarfed from goops.c:542 +@deffn primitive %inherit-magic! class dsupers +@end deffn + + instance? +@c snarfed from goops.c:783 +@deffn primitive instance? obj +Return @code{#t} if @var{obj} is an instance. +@end deffn + + class-name +@c snarfed from goops.c:798 +@deffn primitive class-name obj +Return the class name of @var{obj}. +@end deffn + + class-direct-supers +@c snarfed from goops.c:808 +@deffn primitive class-direct-supers obj +Return the direct superclasses of the class @var{obj}. +@end deffn + + class-direct-slots +@c snarfed from goops.c:818 +@deffn primitive class-direct-slots obj +Return the direct slots of the class @var{obj}. +@end deffn + + class-direct-subclasses +@c snarfed from goops.c:828 +@deffn primitive class-direct-subclasses obj +Return the direct subclasses of the class @var{obj}. +@end deffn + + class-direct-methods +@c snarfed from goops.c:838 +@deffn primitive class-direct-methods obj +Return the direct methods of the class @var{obj} +@end deffn + + class-precedence-list +@c snarfed from goops.c:848 +@deffn primitive class-precedence-list obj +Return the class precedence list of the class @var{obj}. +@end deffn + + class-slots +@c snarfed from goops.c:858 +@deffn primitive class-slots obj +Return the slot list of the class @var{obj}. +@end deffn + + class-environment +@c snarfed from goops.c:868 +@deffn primitive class-environment obj +Return the environment of the class @var{obj}. +@end deffn + + generic-function-name +@c snarfed from goops.c:879 +@deffn primitive generic-function-name obj +Return the name of the generic function @var{obj}. +@end deffn + + generic-function-methods +@c snarfed from goops.c:889 +@deffn primitive generic-function-methods obj +Return the methods of the generic function @var{obj}. +@end deffn + + method-generic-function +@c snarfed from goops.c:900 +@deffn primitive method-generic-function obj +Return the generic function fot the method @var{obj}. +@end deffn + + method-specializers +@c snarfed from goops.c:910 +@deffn primitive method-specializers obj +Return specializers of the method @var{obj}. +@end deffn + + method-procedure +@c snarfed from goops.c:920 +@deffn primitive method-procedure obj +Return the procedure of the method @var{obj}. +@end deffn + + accessor-method-slot-definition +@c snarfed from goops.c:930 +@deffn primitive accessor-method-slot-definition obj +Return the slot definition of the accessor @var{obj}. +@end deffn + + %tag-body +@c snarfed from goops.c:940 +@deffn primitive %tag-body body +Internal GOOPS magic---don't use this function! +@end deffn + + make-unbound +@c snarfed from goops.c:955 +@deffn primitive make-unbound +Return the unbound value. +@end deffn + + unbound? +@c snarfed from goops.c:964 +@deffn primitive unbound? obj +Return @code{#t} if @var{obj} is unbound. +@end deffn + + assert-bound +@c snarfed from goops.c:974 +@deffn primitive assert-bound value obj +Return @var{value} if it is bound, and invoke the +@var{slot-unbound} method of @var{obj} if it is not. +@end deffn + + @@assert-bound-ref +@c snarfed from goops.c:986 +@deffn primitive @@assert-bound-ref obj index +Like @code{assert-bound}, but use @var{index} for accessing +the value from @var{obj}. +@end deffn + + %fast-slot-ref +@c snarfed from goops.c:998 +@deffn primitive %fast-slot-ref obj index +Return the slot value with index @var{index} from @var{obj}. +@end deffn + + %fast-slot-set! +@c snarfed from goops.c:1015 +@deffn primitive %fast-slot-set! obj index value +Set the slot with index @var{index} in @var{obj} to +@var{value}. +@end deffn + + slot-ref-using-class +@c snarfed from goops.c:1143 +@deffn primitive slot-ref-using-class class obj slot_name +@end deffn + + slot-set-using-class! +@c snarfed from goops.c:1162 +@deffn primitive slot-set-using-class! class obj slot_name value +@end deffn + + slot-bound-using-class? +@c snarfed from goops.c:1176 +@deffn primitive slot-bound-using-class? class obj slot_name +@end deffn + + slot-exists-using-class? +@c snarfed from goops.c:1191 +@deffn primitive slot-exists-using-class? class obj slot_name +@end deffn + + slot-ref +@c snarfed from goops.c:1207 +@deffn primitive slot-ref obj slot_name +Return the value from @var{obj}'s slot with the name +@var{slot_name}. +@end deffn + + slot-set! +@c snarfed from goops.c:1224 +@deffn primitive slot-set! obj slot_name value +Set the slot named @var{slot_name} of @var{obj} to @var{value}. +@end deffn + + slot-bound? +@c snarfed from goops.c:1241 +@deffn primitive slot-bound? obj slot_name +Return @code{#t} if the slot named @var{slot_name} of @var{obj} +is bound. +@end deffn + + slot-exists? +@c snarfed from goops.c:1259 +@deffn primitive slot-exists? obj slot_name +Return @code{#t} if @var{obj} has a slot named @var{slot_name}. +@end deffn + + %allocate-instance +@c snarfed from goops.c:1302 +@deffn primitive %allocate-instance class initargs +Create a new instance of class @var{class} and initialize it +from the arguments @var{initargs}. +@end deffn + + %set-object-setter! +@c snarfed from goops.c:1375 +@deffn primitive %set-object-setter! obj setter +@end deffn + + %modify-instance +@c snarfed from goops.c:1400 +@deffn primitive %modify-instance old new +@end deffn + + %modify-class +@c snarfed from goops.c:1426 +@deffn primitive %modify-class old new +@end deffn + + %invalidate-class +@c snarfed from goops.c:1450 +@deffn primitive %invalidate-class class +@end deffn + + %invalidate-method-cache! +@c snarfed from goops.c:1571 +@deffn primitive %invalidate-method-cache! gf +@end deffn + + generic-capability? +@c snarfed from goops.c:1597 +@deffn primitive generic-capability? proc +@end deffn + + enable-primitive-generic! +@c snarfed from goops.c:1610 +@deffn primitive enable-primitive-generic! . subrs +@end deffn + + primitive-generic-generic +@c snarfed from goops.c:1630 +@deffn primitive primitive-generic-generic subr +@end deffn + + make +@c snarfed from goops.c:1989 +@deffn primitive make . args +Make a new object. @var{args} must contain the class and +all necessary initialization information. +@end deffn + + find-method +@c snarfed from goops.c:2082 +@deffn primitive find-method . l +@end deffn + + %method-more-specific? +@c snarfed from goops.c:2102 +@deffn primitive %method-more-specific? m1 m2 targs +@end deffn + + %goops-loaded +@c snarfed from goops.c:2634 +@deffn primitive %goops-loaded +Announce that GOOPS is loaded and perform initialization +on the C level which depends on the loaded GOOPS modules. +@end deffn + + make-guardian +@c snarfed from guardians.c:336 +@deffn primitive make-guardian [greedy_p] +Create a new guardian. +A guardian protects a set of objects from garbage collection, +allowing a program to apply cleanup or other actions. + +@code{make-guardian} returns a procedure representing the guardian. +Calling the guardian procedure with an argument adds the +argument to the guardian's set of protected objects. +Calling the guardian procedure without an argument returns +one of the protected objects which are ready for garbage +collection, or @code{#f} if no such object is available. +Objects which are returned in this way are removed from +the guardian. + +@code{make-guardian} takes one optional argument that says whether the +new guardian should be greedy or sharing. If there is any chance +that any object protected by the guardian may be resurrected, +then you should make the guardian greedy (this is the default). + +See R. Kent Dybvig, Carl Bruggeman, and David Eby (1993) +"Guardians in a Generation-Based Garbage Collector". +ACM SIGPLAN Conference on Programming Language Design +and Implementation, June 1993. + +(the semantics are slightly different at this point, but the +paper still (mostly) accurately describes the interface). +@end deffn + + guardian-destroyed? +@c snarfed from guardians.c:364 +@deffn primitive guardian-destroyed? guardian +Return @code{#t} if @var{guardian} has been destroyed, otherwise @code{#f}. +@end deffn + + guardian-greedy? +@c snarfed from guardians.c:382 +@deffn primitive guardian-greedy? guardian +Return @code{#t} if @var{guardian} is a greedy guardian, otherwise @code{#f}. +@end deffn + + destroy-guardian! +@c snarfed from guardians.c:393 +@deffn primitive destroy-guardian! guardian +Destroys @var{guardian}, by making it impossible to put any more +objects in it or get any objects from it. It also unguards any +objects guarded by @var{guardian}. +@end deffn + + hashq +@c snarfed from hash.c:202 +@deffn primitive hashq key size +Determine a hash value for @var{key} that is suitable for +lookups in a hashtable 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 + + hashv +@c snarfed from hash.c:238 +@deffn primitive hashv key size +Determine a hash value for @var{key} that is suitable for +lookups in a hashtable 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. +@end deffn + + hash +@c snarfed from hash.c:261 +@deffn primitive hash key size +Determine a hash value for @var{key} that is suitable for +lookups in a hashtable 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 + + hashq-get-handle +@c snarfed from hashtab.c:174 +@deffn primitive hashq-get-handle table obj +This procedure is similar to its @code{-ref} cousin, but returns a +@dfn{handle} from the hash table rather than the value associated with +@var{key}. By convention, a handle in a hash table is the pair which +associates a key with a value. Where @code{hashq-ref table key} returns +only a @code{value}, @code{hashq-get-handle table key} returns the pair +@code{(key . value)}. +@end deffn + + hashq-create-handle! +@c snarfed from hashtab.c:186 +@deffn primitive hashq-create-handle! 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 + + hashq-ref +@c snarfed from hashtab.c:199 +@deffn primitive hashq-ref table obj [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 + + hashq-set! +@c snarfed from hashtab.c:213 +@deffn primitive hashq-set! table obj val +Find the entry in @var{table} associated with @var{key}, and +store @var{value} there. Uses @code{eq?} for equality testing. +@end deffn + + hashq-remove! +@c snarfed from hashtab.c:225 +@deffn primitive hashq-remove! table obj +Remove @var{key} (and any value associated with it) from +@var{table}. Uses @code{eq?} for equality tests. +@end deffn + + hashv-get-handle +@c snarfed from hashtab.c:242 +@deffn primitive hashv-get-handle table obj +This procedure is similar to its @code{-ref} cousin, but returns a +@dfn{handle} from the hash table rather than the value associated with +@var{key}. By convention, a handle in a hash table is the pair which +associates a key with a value. Where @code{hashv-ref table key} returns +only a @code{value}, @code{hashv-get-handle table key} returns the pair +@code{(key . value)}. +@end deffn + + hashv-create-handle! +@c snarfed from hashtab.c:254 +@deffn primitive hashv-create-handle! 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 + + hashv-ref +@c snarfed from hashtab.c:267 +@deffn primitive hashv-ref table obj [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. +@end deffn + + hashv-set! +@c snarfed from hashtab.c:281 +@deffn primitive hashv-set! table obj val +Find the entry in @var{table} associated with @var{key}, and +store @var{value} there. Uses @code{eqv?} for equality testing. +@end deffn + + hashv-remove! +@c snarfed from hashtab.c:292 +@deffn primitive hashv-remove! table obj +Remove @var{key} (and any value associated with it) from +@var{table}. Uses @code{eqv?} for equality tests. +@end deffn + + hash-get-handle +@c snarfed from hashtab.c:308 +@deffn primitive hash-get-handle table obj +This procedure is similar to its @code{-ref} cousin, but returns a +@dfn{handle} from the hash table rather than the value associated with +@var{key}. By convention, a handle in a hash table is the pair which +associates a key with a value. Where @code{hash-ref table key} returns +only a @code{value}, @code{hash-get-handle table key} returns the pair +@code{(key . value)}. +@end deffn + + hash-create-handle! +@c snarfed from hashtab.c:320 +@deffn primitive hash-create-handle! 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 + + hash-ref +@c snarfed from hashtab.c:333 +@deffn primitive hash-ref table obj [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 + + hash-set! +@c snarfed from hashtab.c:348 +@deffn primitive hash-set! table obj val +Find the entry in @var{table} associated with @var{key}, and +store @var{value} there. Uses @code{equal?} for equality +testing. +@end deffn + + hash-remove! +@c snarfed from hashtab.c:360 +@deffn primitive hash-remove! table obj +Remove @var{key} (and any value associated with it) from +@var{table}. Uses @code{equal?} for equality tests. +@end deffn + + hashx-get-handle +@c snarfed from hashtab.c:429 +@deffn primitive hashx-get-handle hash assoc table obj +This behaves the same way as the corresponding @code{-get-handle} +function, but uses @var{hasher} as a +hash function and @var{assoc} to compare keys. @code{hasher} 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 + + hashx-create-handle! +@c snarfed from hashtab.c:447 +@deffn primitive hashx-create-handle! hash assoc table obj init +This behaves the same way as the corresponding @code{-create-handle} +function, but uses @var{hasher} as a +hash function and @var{assoc} to compare keys. @code{hasher} 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 + + hashx-ref +@c snarfed from hashtab.c:468 +@deffn primitive hashx-ref hash assoc table obj [dflt] +This behaves the same way as the corresponding @code{ref} +function, but uses @var{hasher} as a +hash function and @var{assoc} to compare keys. @code{hasher} 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-ref table key} is equivalent +to @code{hashx-ref hashq assq table key}. +@end deffn + + hashx-set! +@c snarfed from hashtab.c:492 +@deffn primitive hashx-set! hash assoc table obj val +This behaves the same way as the corresponding @code{set!} +function, but uses @var{hasher} as a +hash function and @var{assoc} to compare keys. @code{hasher} 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 + + hash-fold +@c snarfed from hashtab.c:529 +@deffn primitive 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. +@end deffn + + make-hook-with-name +@c snarfed from hooks.c:216 +@deffn primitive make-hook-with-name name [n_args] +Create a named hook with the name @var{name} for storing +procedures of arity @var{n_args}. +@end deffn + + make-hook +@c snarfed from hooks.c:230 +@deffn primitive make-hook [n_args] +Create a hook for storing procedure of arity @var{n_args}. +@end deffn + + hook? +@c snarfed from hooks.c:240 +@deffn primitive hook? x +Return @code{#t} if @var{x} is a hook. +@end deffn + + hook-empty? +@c snarfed from hooks.c:250 +@deffn primitive hook-empty? hook +Return @code{#t} if @var{hook} is an empty hook. +@end deffn + + add-hook! +@c snarfed from hooks.c:263 +@deffn primitive add-hook! hook proc [append_p] +Add the procedure @var{proc} to the hook @var{hook}. The +procedure is added to the end if @var{append_p} is true, +otherwise it is added to the front. +@end deffn + + remove-hook! +@c snarfed from hooks.c:289 +@deffn primitive remove-hook! hook proc +Remove the procedure @var{proc} from the hook @var{hook}. +@end deffn + + reset-hook! +@c snarfed from hooks.c:302 +@deffn primitive reset-hook! hook +Remove all procedures from the hook @var{hook}. +@end deffn + + run-hook +@c snarfed from hooks.c:315 +@deffn primitive run-hook hook . args +Apply all procedures from the hook @var{hook} to the arguments +@var{args}. +@end deffn + + hook->list +@c snarfed from hooks.c:342 +@deffn primitive hook->list hook +Convert the procedure list of @var{hook} to a list. +@end deffn + + read-string!/partial +@c snarfed from ioext.c:114 +@deffn primitive read-string!/partial str [port_or_fdes [start [end]]] +Read characters from an fport or file descriptor into a +string @var{str}. This procedure is scsh-compatible +and can efficiently read large strings. It will: + +@itemize +@item +attempt to fill the entire string, unless the @var{start} +and/or @var{end} arguments are supplied. i.e., @var{start} +defaults to 0 and @var{end} defaults to +@code{(string-length str)} +@item +use the current input port if @var{port_or_fdes} is not +supplied. +@item +read any characters that are currently available, +without waiting for the rest (short reads are possible). + +@item +wait for as long as it needs to for the first character to +become available, unless the port is in non-blocking mode +@item +return @code{#f} if end-of-file is encountered before reading +any characters, otherwise return the number of characters +read. +@item +return 0 if the port is in non-blocking mode and no characters +are immediately available. +@item +return 0 if the request is for 0 bytes, with no +end-of-file check +@end itemize +@end deffn + + ftell +@c snarfed from ioext.c:173 +@deffn primitive ftell object +Returns an integer representing the current position of @var{fd/port}, +measured from the beginning. Equivalent to: +@smalllisp +(seek port 0 SEEK_CUR) +@end smalllisp +@end deffn + + fseek +@c snarfed from ioext.c:186 +@deffn primitive fseek object offset whence +Obsolete. Almost the same as seek, above, but the return value is +unspecified. +@end deffn + + redirect-port +@c snarfed from ioext.c:208 +@deffn primitive redirect-port old new +This procedure takes two ports and duplicates the underlying file +descriptor from @var{old-port} into @var{new-port}. The +current file descriptor in @var{new-port} will be closed. +After the redirection the two ports will share a file position +and file status flags. + +The return value is unspecified. + +Unexpected behaviour can result if both ports are subsequently used +and the original and/or duplicate ports are buffered. + +This procedure does not have any side effects on other ports or +revealed counts. +@end deffn + + dup->fdes +@c snarfed from ioext.c:245 +@deffn primitive dup->fdes fd_or_port [fd] +Returns an integer file descriptor. +@end deffn + + dup2 +@c snarfed from ioext.c:292 +@deffn primitive dup2 oldfd newfd +A simple wrapper for the @code{dup2} system call. +Copies the file descriptor @var{oldfd} to descriptor +number @var{newfd}, replacing the previous meaning +of @var{newfd}. Both @var{oldfd} and @var{newfd} must +be integers. +Unlike for dup->fdes or primitive-move->fdes, no attempt +is made to move away ports which are using @var{newfd}. +The return value is unspecified. +@end deffn + + fileno +@c snarfed from ioext.c:311 +@deffn primitive fileno port +Returns the integer file descriptor underlying @var{port}. +Does not change its revealed count. +@end deffn + + isatty? +@c snarfed from ioext.c:327 +@deffn primitive isatty? port +Returns @code{#t} if @var{port} is using a serial +non-file device, otherwise @code{#f}. +@end deffn + + fdopen +@c snarfed from ioext.c:349 +@deffn primitive fdopen fdes modes +Returns a new port based on the file descriptor @var{fdes}. +Modes are given by the string @var{modes}. The revealed count of the port +is initialized to zero. The modes string is the same as that accepted +by @ref{File Ports, open-file}. +@end deffn + + primitive-move->fdes +@c snarfed from ioext.c:374 +@deffn primitive primitive-move->fdes port fd +Moves the underlying file descriptor for @var{port} to the integer +value @var{fdes} without changing the revealed count of @var{port}. +Any other ports already using this descriptor will be automatically +shifted to new descriptors and their revealed counts reset to zero. +The return value is @code{#f} if the file descriptor already had the +required value or @code{#t} if it was moved. +@end deffn + + fdes->ports +@c snarfed from ioext.c:407 +@deffn primitive fdes->ports fd +Returns a list of existing ports which have @var{fdes} as an +underlying file descriptor, without changing their revealed counts. +@end deffn + + make-keyword-from-dash-symbol +@c snarfed from keywords.c:71 +@deffn primitive make-keyword-from-dash-symbol symbol +Make a keyword object from a @var{symbol} that starts with a dash. +@end deffn + + keyword? +@c snarfed from keywords.c:112 +@deffn primitive keyword? obj +Returns @code{#t} if the argument @var{obj} is a keyword, else @code{#f}. +@end deffn + + keyword-dash-symbol +@c snarfed from keywords.c:123 +@deffn primitive keyword-dash-symbol keyword +Return the dash symbol for @var{keyword}. +This is the inverse of @code{make-keyword-from-dash-symbol}. +@end deffn + + nil-cons +@c snarfed from lang.c:71 +@deffn primitive nil-cons x y +Create a new cons cell with @var{x} as the car and @var{y} as +the cdr, but convert @var{y} to Scheme's end-of-list if it is +a LISP nil. +@end deffn + + nil-car +@c snarfed from lang.c:86 +@deffn primitive nil-car x +Return the car of @var{x}, but convert it to LISP nil if it +is Scheme's end-of-list. +@end deffn + + nil-cdr +@c snarfed from lang.c:99 +@deffn primitive nil-cdr x +Return the cdr of @var{x}, but convert it to LISP nil if it +is Scheme's end-of-list. +@end deffn + + null +@c snarfed from lang.c:114 +@deffn primitive null x +Return LISP's @code{t} if @var{x} is nil in the LISP sense, +return LISP's nil otherwise. +@end deffn + + nil-eq +@c snarfed from lang.c:143 +@deffn primitive nil-eq x y +Compare @var{x} and @var{y} and return LISP's t if they are +@code{eq?}, return LISP's nil otherwise. +@end deffn + + list +@c snarfed from list.c:84 +@deffn primitive list . objs +Return a list containing @var{objs}, the arguments to +@code{list}. +@end deffn + + list* +@c snarfed from list.c:94 +@deffn primitive list* +scm_cons_star +@end deffn + + cons* +@c snarfed from list.c:105 +@deffn primitive cons* arg . rest +Like @code{list}, but the last arg provides the tail of the +constructed list, returning @code{(cons @var{arg1} (cons +@var{arg2} (cons @dots{} @var{argn}))). Requires at least one +argument. If given one argument, that argument is returned as +result. This function is called @code{list*} in some other +Schemes and in Common LISP. +@end deffn + + null? +@c snarfed from list.c:129 +@deffn primitive null? x +Return @code{#t} iff @var{x} is the empty list, else @code{#f}. +@end deffn + + list? +@c snarfed from list.c:139 +@deffn primitive list? x +Return @code{#t} iff @var{x} is a proper list, else @code{#f}. +@end deffn + + length +@c snarfed from list.c:180 +@deffn primitive length lst +Return the number of elements in list @var{lst}. +@end deffn + + append +@c snarfed from list.c:209 +@deffn primitive append . args +Return a list consisting of the elements the lists passed as +arguments. +@example +(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 example +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. +@example +(append '(a b) '(c . d)) @result{} (a b c . d) +(append '() 'a) @result{} a +@end example +@end deffn + + append! +@c snarfed from list.c:242 +@deffn primitive append! . args +A destructive version of @code{append} (@pxref{Pairs and Lists,,,r4rs, +The Revised^4 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. +@end deffn + + last-pair +@c snarfed from list.c:268 +@deffn primitive last-pair lst +Return a pointer to the last pair in @var{lst}, signalling an error if +@var{lst} is circular. +@end deffn + + reverse +@c snarfed from list.c:298 +@deffn primitive reverse lst +Return a new list that contains the elements of @var{lst} but +in reverse order. +@end deffn + + reverse! +@c snarfed from list.c:332 +@deffn primitive reverse! lst [new_tail] +A destructive version of @code{reverse} (@pxref{Pairs and Lists,,,r4rs, +The Revised^4 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. + +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!} +@end deffn + + list-ref +@c snarfed from list.c:358 +@deffn primitive list-ref list k +Return the @var{k}th element from @var{list}. +@end deffn + + list-set! +@c snarfed from list.c:382 +@deffn primitive list-set! list k val +Set the @var{k}th element of @var{list} to @var{val}. +@end deffn + + list-cdr-ref +@c snarfed from list.c:405 +@deffn primitive list-cdr-ref +scm_list_tail +@end deffn + + list-tail +@c snarfed from list.c:414 +@deffn primitive list-tail lst k +@deffnx primitive list-cdr-ref lst k +Return the "tail" of @var{lst} beginning with its @var{k}th element. +The first element of the list is considered to be element 0. + +@code{list-tail} and @code{list-cdr-ref} are identical. It may help to +think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list, +or returning the results of cdring @var{k} times down @var{lst}. +@end deffn + + list-cdr-set! +@c snarfed from list.c:430 +@deffn primitive list-cdr-set! list k val +Set the @var{k}th cdr of @var{list} to @var{val}. +@end deffn + + list-head +@c snarfed from list.c:459 +@deffn primitive list-head lst k +Copy the first @var{k} elements from @var{lst} into a new list, and +return it. +@end deffn + + list-copy +@c snarfed from list.c:483 +@deffn primitive list-copy lst +Return a (newly-created) copy of @var{lst}. +@end deffn + + sloppy-memq +@c snarfed from list.c:517 +@deffn primitive sloppy-memq x lst +This procedure behaves like @code{memq}, but does no type or error checking. +Its use is recommended only in writing Guile internals, +not for high-level Scheme programs. +@end deffn + + sloppy-memv +@c snarfed from list.c:534 +@deffn primitive sloppy-memv x lst +This procedure behaves like @code{memv}, but does no type or error checking. +Its use is recommended only in writing Guile internals, +not for high-level Scheme programs. +@end deffn + + sloppy-member +@c snarfed from list.c:551 +@deffn primitive sloppy-member x lst +This procedure behaves like @code{member}, but does no type or error checking. +Its use is recommended only in writing Guile internals, +not for high-level Scheme programs. +@end deffn + + memq +@c snarfed from list.c:591 +@deffn primitive memq x lst +Return the first sublist of @var{lst} whose car is @code{eq?} +to @var{x} where the sublists of @var{lst} are the non-empty +lists returned by @code{(list-tail @var{lst} @var{k})} for +@var{k} less than the length of @var{lst}. If @var{x} does not +occur in @var{lst}, then @code{#f} (not the empty list) is +returned. +@end deffn + + memv +@c snarfed from list.c:608 +@deffn primitive memv x lst +Return the first sublist of @var{lst} whose car is @code{eqv?} +to @var{x} where the sublists of @var{lst} are the non-empty +lists returned by @code{(list-tail @var{lst} @var{k})} for +@var{k} less than the length of @var{lst}. If @var{x} does not +occur in @var{lst}, then @code{#f} (not the empty list) is +returned. +@end deffn + + member +@c snarfed from list.c:629 +@deffn primitive member x lst +Return the first sublist of @var{lst} whose car is +@code{equal?} to @var{x} where the sublists of @var{lst} are +the non-empty lists returned by @code{(list-tail @var{lst} +@var{k})} for @var{k} less than the length of @var{lst}. If +@var{x} does not occur in @var{lst}, then @code{#f} (not the +empty list) is returned. +@end deffn + + delq! +@c snarfed from list.c:655 +@deffn primitive delq! item lst +@deffnx primitive delv! item lst +@deffnx primitive delete! item lst +These procedures are destructive versions of @code{delq}, @code{delv} +and @code{delete}: they modify the pointers in the existing @var{lst} +rather than creating a new list. Caveat evaluator: Like other +destructive list functions, these functions cannot modify the binding of +@var{lst}, and so cannot be used to delete the first element of +@var{lst} destructively. +@end deffn + + delv! +@c snarfed from list.c:679 +@deffn primitive delv! item lst +Destructively remove all elements from @var{lst} that are +@code{eqv?} to @var{item}. +@end deffn + + delete! +@c snarfed from list.c:704 +@deffn primitive delete! item lst +Destructively remove all elements from @var{lst} that are +@code{equal?} to @var{item}. +@end deffn + + delq +@c snarfed from list.c:733 +@deffn primitive delq item lst +Return a newly-created copy of @var{lst} with elements +@code{eq?} to @var{item} removed. This procedure mirrors +@code{memq}: @code{delq} compares elements of @var{lst} against +@var{item} with @code{eq?}. +@end deffn + + delv +@c snarfed from list.c:746 +@deffn primitive delv item lst +Return a newly-created copy of @var{lst} with elements +@code{eqv?} to @var{item} removed. This procedure mirrors +@code{memv}: @code{delv} compares elements of @var{lst} against +@var{item} with @code{eqv?}. +@end deffn + + delete +@c snarfed from list.c:759 +@deffn primitive delete item lst +Return a newly-created copy of @var{lst} with elements +@code{equal?} to @var{item} removed. This procedure mirrors +@code{member}: @code{delete} compares elements of @var{lst} +against @var{item} with @code{equal?}. +@end deffn + + delq1! +@c snarfed from list.c:772 +@deffn primitive delq1! item lst +Like @code{delq!}, but only deletes the first occurrence of +@var{item} from @var{lst}. Tests for equality using +@code{eq?}. See also @code{delv1!} and @code{delete1!}. +@end deffn + + delv1! +@c snarfed from list.c:800 +@deffn primitive delv1! item lst +Like @code{delv!}, but only deletes the first occurrence of +@var{item} from @var{lst}. Tests for equality using +@code{eqv?}. See also @code{delq1!} and @code{delete1!}. +@end deffn + + delete1! +@c snarfed from list.c:828 +@deffn primitive delete1! item lst +Like @code{delete!}, but only deletes the first occurrence of +@var{item} from @var{lst}. Tests for equality using +@code{equal?}. See also @code{delq1!} and @code{delv1!}. +@end deffn + + primitive-load +@c snarfed from load.c:112 +@deffn primitive primitive-load filename +Load the file named @var{filename} and evaluate its contents in +the top-level environment. The load paths are not searched; +@var{filename} must either be a full pathname or be a pathname +relative to the current directory. If the variable +@code{%load-hook} is defined, it should be bound to a procedure +that will be called before any code is loaded. See the +documentation for @code{%load-hook} later in this section. +@end deffn + + %package-data-dir +@c snarfed from load.c:147 +@deffn primitive %package-data-dir +Return the name of the directory where Scheme packages, modules and +libraries are kept. On most Unix systems, this will be +@samp{/usr/local/share/guile}. +@end deffn + + %library-dir +@c snarfed from load.c:159 +@deffn primitive %library-dir +Return the directory where the Guile Scheme library files are installed. +E.g., may return "/usr/share/guile/1.3.5". +@end deffn + + %site-dir +@c snarfed from load.c:171 +@deffn primitive %site-dir +Return the directory where the Guile site files are installed. +E.g., may return "/usr/share/guile/site". +@end deffn + + parse-path +@c snarfed from load.c:223 +@deffn primitive parse-path path [tail] +Parse @var{path}, which is expected to be a colon-separated +string, into a list and return the resulting list with +@var{tail} appended. If @var{path} is @code{#f}, @var{tail} +is returned. +@end deffn + + search-path +@c snarfed from load.c:273 +@deffn primitive search-path path filename [extensions] +Search @var{path} for a directory containing a file named +@var{filename}. The file must be readable, and not a directory. +If we find one, return its full filename; otherwise, return +@code{#f}. If @var{filename} is absolute, return it unchanged. +If given, @var{extensions} is a list of strings; for each +directory in @var{path}, we search for @var{filename} +concatenated with each @var{extension}. +@end deffn + + %search-load-path +@c snarfed from load.c:420 +@deffn primitive %search-load-path filename +Search @var{%load-path} for the file named @var{filename}, +which must be readable by the current user. If @var{filename} +is found in the list of paths to search or is an absolute +pathname, return its full pathname. Otherwise, return +@code{#f}. Filenames may have any of the optional extensions +in the @code{%load-extensions} list; @code{%search-load-path} +will try each extension automatically. +@end deffn + + primitive-load-path +@c snarfed from load.c:441 +@deffn primitive primitive-load-path filename +Search @var{%load-path} for the file named @var{filename} and +load it into the top-level environment. If @var{filename} is a +relative pathname and is not found in the list of search paths, +an error is signalled. +@end deffn + + read-and-eval! +@c snarfed from load.c:476 +@deffn primitive read-and-eval! [port] +Read a form from @var{port} (standard input by default), and evaluate it +(memoizing it in the process) in the top-level environment. If no data +is left to be read from @var{port}, an @code{end-of-file} error is +signalled. +@end deffn + + procedure->syntax +@c snarfed from macros.c:60 +@deffn primitive procedure->syntax code +Returns a @dfn{macro} which, when a symbol defined to this value +appears as the first symbol in an expression, returns the result +of applying @var{code} to the expression and the environment. +@end deffn + + procedure->macro +@c snarfed from macros.c:82 +@deffn primitive procedure->macro code +Returns a @dfn{macro} which, when a symbol defined to this value +appears as the first symbol in an expression, evaluates the result +of applying @var{code} to the expression and the environment. +The value returned from @var{code} which has been passed to +@code{procedure->memoizing-macro} replaces the form passed to +@var{code}. For example: + +@example +(define trace + (procedure->macro + (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x)))))) + +(trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})). +@end example +@end deffn + + procedure->memoizing-macro +@c snarfed from macros.c:104 +@deffn primitive procedure->memoizing-macro code +Returns a @dfn{macro} which, when a symbol defined to this value +appears as the first symbol in an expression, evaluates the result +of applying @var{proc} to the expression and the environment. +The value returned from @var{proc} which has been passed to +@code{procedure->memoizing-macro} replaces the form passed to +@var{proc}. For example: + +@example +(define trace + (procedure->macro + (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x)))))) + +(trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})). +@end example +@end deffn + + macro? +@c snarfed from macros.c:116 +@deffn primitive macro? obj +Return @code{#t} if @var{obj} is a regular macro, a memoizing macro or a +syntax transformer. +@end deffn + + macro-type +@c snarfed from macros.c:133 +@deffn primitive macro-type m +Return one of the symbols @code{syntax}, @code{macro} or @code{macro!}, +depending on whether @var{obj} is a syntax tranformer, a regular macro, +or a memoizing macro, respectively. If @var{obj} is not a macro, +@code{#f} is returned. +@end deffn + + macro-name +@c snarfed from macros.c:151 +@deffn primitive macro-name m +Return the name of the macro @var{m}. +@end deffn + + macro-transformer +@c snarfed from macros.c:162 +@deffn primitive macro-transformer m +Return the transformer of the macro @var{m}. +@end deffn + + interaction-environment +@c snarfed from modules.c:102 +@deffn primitive interaction-environment +This procedure returns a specifier for the environment that contains +implementation-defined bindings, typically a superset of those listed in +the report. The intent is that this procedure will return the +environment in which the implementation would evaluate expressions +dynamically typed by the user. +@end deffn + + standard-eval-closure +@c snarfed from modules.c:271 +@deffn primitive standard-eval-closure module +Return an eval closure for the module @var{module}. +@end deffn + + inet-aton +@c snarfed from net_db.c:96 +@deffn primitive inet-aton address +Converts a string containing an Internet host address in the traditional +dotted decimal notation into an integer. + +@smalllisp +(inet-aton "127.0.0.1") @result{} 2130706433 + +@end smalllisp +@end deffn + + inet-ntoa +@c snarfed from net_db.c:116 +@deffn primitive inet-ntoa inetid +Converts an integer Internet host address into a string with the +traditional dotted decimal representation. + +@smalllisp +(inet-ntoa 2130706433) @result{} "127.0.0.1" +@end smalllisp +@end deffn + + inet-netof +@c snarfed from net_db.c:135 +@deffn primitive inet-netof address +Returns the network number part of the given integer Internet address. + +@smalllisp +(inet-netof 2130706433) @result{} 127 +@end smalllisp +@end deffn + + inet-lnaof +@c snarfed from net_db.c:152 +@deffn primitive inet-lnaof address +Returns the local-address-with-network part of the given Internet +address. + +@smalllisp +(inet-lnaof 2130706433) @result{} 1 +@end smalllisp +@end deffn + + inet-makeaddr +@c snarfed from net_db.c:169 +@deffn primitive inet-makeaddr net lna +Makes an Internet host address by combining the network number @var{net} +with the local-address-within-network number @var{lna}. + +@smalllisp +(inet-makeaddr 127 1) @result{} 2130706433 +@end smalllisp +@end deffn + + gethost +@c snarfed from net_db.c:254 +@deffn primitive gethost [host] +@deffnx procedure gethostbyname hostname +@deffnx procedure gethostbyaddr address +Look up a host by name or address, returning a host object. The +@code{gethost} procedure will accept either a string name or an integer +address; if given no arguments, it behaves like @code{gethostent} (see +below). If a name or address is supplied but the address can not be +found, an error will be thrown to one of the keys: +@code{host-not-found}, @code{try-again}, @code{no-recovery} or +@code{no-data}, corresponding to the equivalent @code{h_error} values. +Unusual conditions may result in errors thrown to the +@code{system-error} or @code{misc_error} keys. +@end deffn + + getnet +@c snarfed from net_db.c:335 +@deffn primitive getnet [net] +@deffnx procedure getnetbyname net-name +@deffnx procedure getnetbyaddr net-number +Look up a network by name or net number in the network database. The +@var{net-name} argument must be a string, and the @var{net-number} +argument must be an integer. @code{getnet} will accept either type of +argument, behaving like @code{getnetent} (see below) if no arguments are +given. +@end deffn + + getproto +@c snarfed from net_db.c:385 +@deffn primitive getproto [protocol] +@deffnx procedure getprotobyname name +@deffnx procedure getprotobynumber number +Look up a network protocol by name or by number. @code{getprotobyname} +takes a string argument, and @code{getprotobynumber} takes an integer +argument. @code{getproto} will accept either type, behaving like +@code{getprotoent} (see below) if no arguments are supplied. +@end deffn + + getserv +@c snarfed from net_db.c:452 +@deffn primitive getserv [name [protocol]] +@deffnx procedure getservbyname name protocol +@deffnx procedure getservbyport port protocol +Look up a network service by name or by service number, and return a +network service object. The @var{protocol} argument specifies the name +of the desired protocol; if the protocol found in the network service +database does not match this name, a system error is signalled. + +The @code{getserv} procedure will take either a service name or number +as its first argument; if given no arguments, it behaves like +@code{getservent} (see below). +@end deffn + + sethost +@c snarfed from net_db.c:491 +@deffn primitive sethost [stayopen] +If @var{stayopen} is omitted, this is equivalent to @code{endhostent}. +Otherwise it is equivalent to @code{sethostent stayopen}. +@end deffn + + setnet +@c snarfed from net_db.c:507 +@deffn primitive setnet [stayopen] +If @var{stayopen} is omitted, this is equivalent to @code{endnetent}. +Otherwise it is equivalent to @code{setnetent stayopen}. +@end deffn + + setproto +@c snarfed from net_db.c:523 +@deffn primitive setproto [stayopen] +If @var{stayopen} is omitted, this is equivalent to @code{endprotoent}. +Otherwise it is equivalent to @code{setprotoent stayopen}. +@end deffn + + setserv +@c snarfed from net_db.c:539 +@deffn primitive setserv [stayopen] +If @var{stayopen} is omitted, this is equivalent to @code{endservent}. +Otherwise it is equivalent to @code{setservent stayopen}. +@end deffn + + exact? +@c snarfed from numbers.c:106 +@deffn primitive exact? x +Return @code{#t} if @var{x} is an exact number, @code{#f} +otherwise. +@end deffn + + odd? +@c snarfed from numbers.c:123 +@deffn primitive odd? n +Return @code{#t} if @var{n} is an odd number, @code{#f} +otherwise. +@end deffn + + even? +@c snarfed from numbers.c:140 +@deffn primitive even? n +Return @code{#t} if @var{n} is an even number, @code{#f} +otherwise. +@end deffn + + logand +@c snarfed from numbers.c:755 +@deffn primitive logand n1 n2 +Returns the integer which is the bit-wise AND of the two integer +arguments. + +Example: +@lisp +(number->string (logand #b1100 #b1010) 2) + @result{} "1000" +@end lisp +@end deffn + + logior +@c snarfed from numbers.c:842 +@deffn primitive logior n1 n2 +Returns the integer which is the bit-wise OR of the two integer +arguments. + +Example: +@lisp +(number->string (logior #b1100 #b1010) 2) + @result{} "1110" +@end lisp +@end deffn + + logxor +@c snarfed from numbers.c:928 +@deffn primitive logxor n1 n2 +Returns the integer which is the bit-wise XOR of the two integer +arguments. + +Example: +@lisp +(number->string (logxor #b1100 #b1010) 2) + @result{} "110" +@end lisp +@end deffn + + logtest +@c snarfed from numbers.c:997 +@deffn primitive logtest n1 n2 +@example +(logtest j k) @equiv{} (not (zero? (logand j k))) + +(logtest #b0100 #b1011) @result{} #f +(logtest #b0100 #b0111) @result{} #t +@end example +@end deffn + + logbit? +@c snarfed from numbers.c:1054 +@deffn primitive logbit? index j +@example +(logbit? index j) @equiv{} (logtest (integer-expt 2 index) j) + +(logbit? 0 #b1101) @result{} #t +(logbit? 1 #b1101) @result{} #f +(logbit? 2 #b1101) @result{} #t +(logbit? 3 #b1101) @result{} #t +(logbit? 4 #b1101) @result{} #f +@end example +@end deffn + + lognot +@c snarfed from numbers.c:1102 +@deffn primitive lognot n +Returns the integer which is the 2s-complement of the integer argument. + +Example: +@lisp +(number->string (lognot #b10000000) 2) + @result{} "-10000001" +(number->string (lognot #b0) 2) + @result{} "-1" +@end lisp +@end deffn + + integer-expt +@c snarfed from numbers.c:1118 +@deffn primitive integer-expt n k +Returns @var{n} raised to the non-negative integer exponent @var{k}. + +Example: +@lisp +(integer-expt 2 5) + @result{} 32 +(integer-expt -3 3) + @result{} -27 +@end lisp +@end deffn + + ash +@c snarfed from numbers.c:1166 +@deffn primitive ash n cnt +The function ash performs an arithmetic shift left by @var{CNT} +bits (or shift right, if @var{cnt} is negative). +'Arithmetic' means, that the function does not guarantee to +keep the bit structure of @var{n}, but rather guarantees that +the result will always be rounded towards minus infinity. +Therefore, the results of ash and a corresponding bitwise +shift will differ if N is negative. + +Formally, the function returns an integer equivalent to +@code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}. + +Example: +@lisp +(number->string (ash #b1 3) 2) + @result{} "1000" +(number->string (ash #b1010 -1) 2) + @result{} "101" +@end lisp +@end deffn + + bit-extract +@c snarfed from numbers.c:1219 +@deffn primitive bit-extract n start end +Returns the integer composed of the @var{start} (inclusive) through +@var{end} (exclusive) bits of @var{n}. The @var{start}th bit becomes +the 0-th bit in the result.@refill + +Example: +@lisp +(number->string (bit-extract #b1101101010 0 4) 2) + @result{} "1010" +(number->string (bit-extract #b1101101010 4 9) 2) + @result{} "10110" +@end lisp +@end deffn + + logcount +@c snarfed from numbers.c:1291 +@deffn primitive logcount n +Returns the number of bits in integer @var{n}. If integer is positive, +the 1-bits in its binary representation are counted. If negative, the +0-bits in its two's-complement binary representation are counted. If 0, +0 is returned. + +Example: +@lisp +(logcount #b10101010) + @result{} 4 +(logcount 0) + @result{} 0 +(logcount -2) + @result{} 1 +@end lisp +@end deffn + + integer-length +@c snarfed from numbers.c:1342 +@deffn primitive integer-length n +Returns the number of bits neccessary to represent @var{n}. + +Example: +@lisp +(integer-length #b10101010) + @result{} 8 +(integer-length 0) + @result{} 0 +(integer-length #b1111) + @result{} 4 +@end lisp +@end deffn + + number->string +@c snarfed from numbers.c:2288 +@deffn primitive number->string n [radix] +Return a string holding the external representation of the +number @var{n} in the given @var{radix}. If @var{n} is +inexact, a radix of 10 will be used. +@end deffn + + string->number +@c snarfed from numbers.c:2873 +@deffn primitive string->number string [radix] +Returns a number of the maximally precise representation +expressed by the given @var{string}. @var{radix} must be an +exact integer, either 2, 8, 10, or 16. If supplied, @var{radix} +is a default radix that may be overridden by an explicit radix +prefix in @var{string} (e.g. "#o177"). If @var{radix} is not +supplied, then the default radix is 10. If string is not a +syntactically valid notation for a number, then +@code{string->number} returns @code{#f}. +@end deffn + + number? +@c snarfed from numbers.c:2940 +@deffn primitive number? +scm_number_p +@end deffn + + complex? +@c snarfed from numbers.c:2952 +@deffn primitive complex? x +Return @code{#t} if @var{x} is a complex number, @code{#f} +else. Note that the sets of real, rational and integer +values form subsets of the set of complex numbers, i. e. the +predicate will also be fulfilled if @var{x} is a real, +rational or integer number. +@end deffn + + real? +@c snarfed from numbers.c:2960 +@deffn primitive real? +scm_real_p +@end deffn + + rational? +@c snarfed from numbers.c:2973 +@deffn primitive rational? x +Return @code{#t} if @var{x} is a rational number, @code{#f} +else. Note that the set of integer values forms a subset of +the set of rational numbers, i. e. the predicate will also be +fulfilled if @var{x} is an integer number. Real numbers +will also satisfy this predicate, because of their limited +precision. +@end deffn + + integer? +@c snarfed from numbers.c:2994 +@deffn primitive integer? x +Return @code{#t} if @var{x} is an integer number, @code{#f} +else. +@end deffn + + inexact? +@c snarfed from numbers.c:3019 +@deffn primitive inexact? x +Return @code{#t} if @var{x} is an inexact number, @code{#f} +else. +@end deffn + + $expt +@c snarfed from numbers.c:4071 +@deffn primitive $expt x y +Return @var{x} raised to the power of @var{y}. This +procedure does not accept complex arguments. +@end deffn + + $atan2 +@c snarfed from numbers.c:4087 +@deffn primitive $atan2 x y +Return the arc tangent of the two arguments @var{x} and +@var{y}. This is similar to calculating the arc tangent of +@var{x} / @var{y}, except that the signs of both arguments +are used to determine the quadrant of the result. This +procedure does not accept complex arguments. +@end deffn + + make-rectangular +@c snarfed from numbers.c:4100 +@deffn primitive make-rectangular real imaginary +Return a complex number constructed of the given @var{real} and +@var{imaginary} parts. +@end deffn + + make-polar +@c snarfed from numbers.c:4113 +@deffn primitive make-polar x y +Return the complex number @var{x} * e^(i * @var{y}). +@end deffn + + inexact->exact +@c snarfed from numbers.c:4231 +@deffn primitive inexact->exact z +Returns an exact number that is numerically closest to @var{z}. +@end deffn + + class-of +@c snarfed from objects.c:88 +@deffn primitive class-of x +Return the class of @var{x}. +@end deffn + + entity? +@c snarfed from objects.c:359 +@deffn primitive entity? obj +Return @code{#t} if @var{obj} is an entity. +@end deffn + + operator? +@c snarfed from objects.c:368 +@deffn primitive operator? obj +Return @code{#t} if @var{obj} is an operator. +@end deffn + + set-object-procedure! +@c snarfed from objects.c:380 +@deffn primitive set-object-procedure! obj proc +Return the object procedure of @var{obj} to @var{proc}. +@var{obj} must be either an entity or an operator. +@end deffn + + make-class-object +@c snarfed from objects.c:440 +@deffn primitive make-class-object metaclass layout +Create a new class object of class @var{metaclass}, with the +slot layout specified by @var{layout}. +@end deffn + + make-subclass-object +@c snarfed from objects.c:455 +@deffn primitive make-subclass-object class layout +Create a subclass object of @var{class}, with the slot layout +specified by @var{layout}. +@end deffn + + object-properties +@c snarfed from objprop.c:62 +@deffn primitive object-properties obj +@deffnx primitive procedure-properties obj +Return @var{obj}'s property list. +@end deffn + + set-object-properties! +@c snarfed from objprop.c:73 +@deffn primitive set-object-properties! obj plist +@deffnx primitive set-procedure-properties! obj alist +Set @var{obj}'s property list to @var{alist}. +@end deffn + + object-property +@c snarfed from objprop.c:85 +@deffn primitive object-property obj key +@deffnx primitive procedure-property obj key +Return the property of @var{obj} with name @var{key}. +@end deffn + + set-object-property! +@c snarfed from objprop.c:98 +@deffn primitive set-object-property! obj key val +@deffnx primitive set-procedure-property! obj key value +In @var{obj}'s property list, set the property named @var{key} to +@var{value}. +@end deffn + + cons +@c snarfed from pairs.c:61 +@deffn primitive cons x y +Returns a newly allocated pair whose car is @var{x} and whose cdr is +@var{y}. The pair is guaranteed to be different (in the sense of +@code{eqv?}) from every previously existing object. +@end deffn + + pair? +@c snarfed from pairs.c:93 +@deffn primitive pair? x +Returns @code{#t} if @var{x} is a pair; otherwise returns @code{#f}. +@end deffn + + set-car! +@c snarfed from pairs.c:104 +@deffn primitive set-car! pair value +Stores @var{value} in the car field of @var{pair}. The value returned +by @code{set-car!} is unspecified. +@end deffn + + set-cdr! +@c snarfed from pairs.c:117 +@deffn primitive set-cdr! pair value +Stores @var{value} in the cdr field of @var{pair}. The value returned +by @code{set-cdr!} is unspecified. +@end deffn + + char-ready? +@c snarfed from ports.c:246 +@deffn primitive char-ready? [port] +Returns @code{#t} if a character is ready on input @var{port} and +returns @code{#f} otherwise. If @code{char-ready?} returns @code{#t} +then the next @code{read-char} operation on @var{port} is +guaranteed not to hang. If @var{port} is a file port at end of +file then @code{char-ready?} returns @code{#t}. +@footnote{@code{char-ready?} exists to make it possible for a +program to accept characters from interactive ports without getting +stuck waiting for input. Any input editors associated with such ports +must make sure that characters whose existence has been asserted by +@code{char-ready?} cannot be rubbed out. If @code{char-ready?} were to +return @code{#f} at end of file, a port at end of file would be +indistinguishable from an interactive port that has no ready +characters.} +@end deffn + + drain-input +@c snarfed from ports.c:312 +@deffn primitive drain-input port +Drain @var{port}'s read buffers (including any pushed-back +characters) and returns the content as a single string. +@end deffn + + current-input-port +@c snarfed from ports.c:339 +@deffn primitive current-input-port +Return the current input port. This is the default port used +by many input procedures. Initially, @code{current-input-port} +returns the @dfn{standard input} in Unix and C terminology. +@end deffn + + current-output-port +@c snarfed from ports.c:351 +@deffn primitive current-output-port +Return the current output port. This is the default port used +by many output procedures. Initially, +@code{current-output-port} returns the @dfn{standard output} in +Unix and C terminology. +@end deffn + + current-error-port +@c snarfed from ports.c:361 +@deffn primitive current-error-port +Return the port to which errors and warnings should be sent (the +@dfn{standard error} in Unix and C terminology). +@end deffn + + current-load-port +@c snarfed from ports.c:371 +@deffn primitive current-load-port +Return the current-load-port. +The load port is used internally by @code{primitive-load}. +@end deffn + + set-current-input-port +@c snarfed from ports.c:384 +@deffn primitive set-current-input-port port +@deffnx primitive set-current-output-port port +@deffnx primitive set-current-error-port port +Change the ports returned by @code{current-input-port}, +@code{current-output-port} and @code{current-error-port}, respectively, +so that they use the supplied @var{port} for input or output. +@end deffn + + set-current-output-port +@c snarfed from ports.c:397 +@deffn primitive set-current-output-port port +Set the current default output port to @var{port}. +@end deffn + + set-current-error-port +@c snarfed from ports.c:411 +@deffn primitive set-current-error-port port +Set the current default error port to @var{port}. +@end deffn + + port-revealed +@c snarfed from ports.c:556 +@deffn primitive port-revealed port +Returns the revealed count for @var{port}. +@end deffn + + set-port-revealed! +@c snarfed from ports.c:569 +@deffn primitive set-port-revealed! port rcount +Sets the revealed count for a port to a given value. +The return value is unspecified. +@end deffn + + port-mode +@c snarfed from ports.c:612 +@deffn primitive port-mode port +Returns the port modes associated with the open port @var{port}. These +will not necessarily be identical to the modes used when the port was +opened, since modes such as "append" which are used only during +port creation are not retained. +@end deffn + + close-port +@c snarfed from ports.c:649 +@deffn primitive close-port port +Close the specified port object. Returns @code{#t} if it successfully +closes a port or @code{#f} if it was already +closed. An exception may be raised if an error occurs, for example +when flushing buffered output. +See also @ref{Ports and File Descriptors, close}, for a procedure +which can close file descriptors. +@end deffn + + close-input-port +@c snarfed from ports.c:677 +@deffn primitive close-input-port port +Close the specified input port object. The routine has no effect if +the file has already been closed. An exception may be raised if an +error occurs. The value returned is unspecified. + +See also @ref{Ports and File Descriptors, close}, for a procedure +which can close file descriptors. +@end deffn + + close-output-port +@c snarfed from ports.c:692 +@deffn primitive close-output-port port +Close the specified output port object. The routine has no effect if +the file has already been closed. An exception may be raised if an +error occurs. The value returned is unspecified. + +See also @ref{Ports and File Descriptors, close}, for a procedure +which can close file descriptors. +@end deffn + + port-for-each +@c snarfed from ports.c:709 +@deffn primitive port-for-each proc +Apply @var{proc} to each port in the Guile port table +in turn. The return value is unspecified. More specifically, +@var{proc} is applied exactly once to every port that exists +in the system at the time @var{port-for-each} is invoked. +Changes to the port table while @var{port-for-each} is running +have no effect as far as @var{port-for-each} is concerned. +@end deffn + + close-all-ports-except +@c snarfed from ports.c:752 +@deffn primitive close-all-ports-except . ports +[DEPRECATED] Close all open file ports used by the interpreter +except for those supplied as arguments. This procedure +was intended to be used before an exec call to close file descriptors +which are not needed in the new process. However it has the +undesirable side-effect of flushing buffes, so it's deprecated. +Use port-for-each instead. +@end deffn + + input-port? +@c snarfed from ports.c:791 +@deffn primitive input-port? x +Returns @code{#t} if @var{x} is an input port, otherwise returns +@code{#f}. Any object satisfying this predicate also satisfies +@code{port?}. +@end deffn + + output-port? +@c snarfed from ports.c:804 +@deffn primitive output-port? x +Returns @code{#t} if @var{x} is an output port, otherwise returns +@code{#f}. Any object satisfying this predicate also satisfies +@code{port?}. +@end deffn + + port? +@c snarfed from ports.c:819 +@deffn primitive port? x +Returns a boolean indicating whether @var{x} is a port. +Equivalent to @code{(or (input-port? @var{x}) (output-port? +@var{x}))}. +@end deffn + + port-closed? +@c snarfed from ports.c:828 +@deffn primitive port-closed? port +Returns @code{#t} if @var{port} is closed or @code{#f} if it is open. +@end deffn + + eof-object? +@c snarfed from ports.c:839 +@deffn primitive eof-object? x +Returns @code{#t} if @var{x} is an end-of-file object; otherwise +returns @code{#f}. +@end deffn + + force-output +@c snarfed from ports.c:853 +@deffn primitive force-output [port] +Flush the specified output port, or the current output port if @var{port} +is omitted. The current output buffer contents are passed to the +underlying port implementation (e.g., in the case of fports, the +data will be written to the file and the output buffer will be cleared.) +It has no effect on an unbuffered port. + +The return value is unspecified. +@end deffn + + flush-all-ports +@c snarfed from ports.c:871 +@deffn primitive flush-all-ports +Equivalent to calling @code{force-output} on +all open output ports. The return value is unspecified. +@end deffn + + read-char +@c snarfed from ports.c:889 +@deffn primitive read-char [port] +Returns the next character available from @var{port}, updating +@var{port} to point to the following character. If no more +characters are available, an end-of-file object is returned. +@end deffn + + peek-char +@c snarfed from ports.c:1205 +@deffn primitive peek-char [port] +Returns the next character available from @var{port}, +@emph{without} updating @var{port} to point to the following +character. If no more characters are available, an end-of-file object +is returned.@footnote{The value returned by a call to @code{peek-char} +is the same as the value that would have been returned by a call to +@code{read-char} on the same port. The only difference is that the very +next call to @code{read-char} or @code{peek-char} on that +@var{port} will return the value returned by the preceding call to +@code{peek-char}. In particular, a call to @code{peek-char} on an +interactive port will hang waiting for input whenever a call to +@code{read-char} would have hung.} +@end deffn + + unread-char +@c snarfed from ports.c:1226 +@deffn primitive unread-char cobj [port] +Place @var{char} in @var{port} so that it will be read by the +next read operation. If called multiple times, the unread characters +will be read again in last-in first-out order. If @var{port} is +not supplied, the current input port is used. +@end deffn + + unread-string +@c snarfed from ports.c:1249 +@deffn primitive unread-string str port +Place the string @var{str} in @var{port} so that its characters will be +read in subsequent read operations. If called multiple times, the +unread characters will be read again in last-in first-out order. If +@var{port} is not supplied, the current-input-port is used. +@end deffn + + seek +@c snarfed from ports.c:1285 +@deffn primitive seek object offset whence +Sets the current position of @var{fd/port} to the integer @var{offset}, +which is interpreted according to the value of @var{whence}. + +One of the following variables should be supplied +for @var{whence}: +@defvar SEEK_SET +Seek from the beginning of the file. +@end defvar +@defvar SEEK_CUR +Seek from the current position. +@end defvar +@defvar SEEK_END +Seek from the end of the file. +@end defvar + +If @var{fd/port} is a file descriptor, the underlying system call is +@code{lseek}. @var{port} may be a string port. + +The value returned is the new position in the file. This means that +the current position of a port can be obtained using: +@smalllisp +(seek port 0 SEEK_CUR) +@end smalllisp +@end deffn + + truncate-file +@c snarfed from ports.c:1326 +@deffn primitive truncate-file object [length] +Truncates the object referred to by @var{obj} to at most @var{size} bytes. +@var{obj} can be a string containing a file name or an integer file +descriptor or a port. @var{size} may be omitted if @var{obj} is not +a file name, in which case the truncation occurs at the current port. +position. + +The return value is unspecified. +@end deffn + + port-line +@c snarfed from ports.c:1380 +@deffn primitive port-line port +Return the current line number for @var{port}. +@end deffn + + set-port-line! +@c snarfed from ports.c:1391 +@deffn primitive set-port-line! port line +Set the current line number for @var{port} to @var{line}. +@end deffn + + port-column +@c snarfed from ports.c:1412 +@deffn primitive port-column port +@deffnx primitive 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 +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 +message, we recommend you add 1 to get 1-origin integers. This is +because lines and column numbers traditionally start with 1, and that is +what non-programmers will find most natural.) +@end deffn + + set-port-column! +@c snarfed from ports.c:1425 +@deffn primitive set-port-column! port column +@deffnx primitive set-port-line! port line +Set the current column or line number of @var{port}, using the +current input port if none is specified. +@end deffn + + port-filename +@c snarfed from ports.c:1440 +@deffn primitive port-filename port +Return the filename associated with @var{port}. This function returns +the strings "standard input", "standard output" and "standard error" +when called on the current input, output and error ports respectively. +@end deffn + + set-port-filename! +@c snarfed from ports.c:1454 +@deffn primitive set-port-filename! port filename +Change the filename associated with @var{port}, using the current input +port if none is specified. Note that this does not change the port's +source of data, but only the value that is returned by +@code{port-filename} and reported in diagnostic output. +@end deffn + + %make-void-port +@c snarfed from ports.c:1546 +@deffn primitive %make-void-port mode +Create and return a new void port. A void port acts like +/dev/null. The @var{mode} argument +specifies the input/output modes for this port: see the +documentation for @code{open-file} in @ref{File Ports}. +@end deffn + + pipe +@c snarfed from posix.c:201 +@deffn primitive pipe +Returns a newly created pipe: a pair of ports which are linked +together on the local machine. The CAR is the input port and +the CDR is the output port. Data written (and flushed) to the +output port can be read from the input port. +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}. + +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 +@end deffn + + getgroups +@c snarfed from posix.c:221 +@deffn primitive getgroups +Returns a vector of integers representing the current supplimentary group IDs. +@end deffn + + getpw +@c snarfed from posix.c:254 +@deffn primitive getpw [user] +Look up an entry in the user database. @var{obj} can be an integer, +a string, or omitted, giving the behaviour of getpwuid, getpwnam +or getpwent respectively. +@end deffn + + setpw +@c snarfed from posix.c:307 +@deffn primitive setpw [arg] +If called with a true argument, initialize or reset the password data +stream. Otherwise, close the stream. The @code{setpwent} and +@code{endpwent} procedures are implemented on top of this. +@end deffn + + getgr +@c snarfed from posix.c:326 +@deffn primitive getgr [name] +Look up an entry in the group database. @var{obj} can be an integer, +a string, or omitted, giving the behaviour of getgrgid, getgrnam +or getgrent respectively. +@end deffn + + setgr +@c snarfed from posix.c:367 +@deffn primitive setgr [arg] +If called with a true argument, initialize or reset the group data +stream. Otherwise, close the stream. The @code{setgrent} and +@code{endgrent} procedures are implemented on top of this. +@end deffn + + kill +@c snarfed from posix.c:403 +@deffn primitive kill pid sig +Sends a signal to the specified process or group of processes. + +@var{pid} specifies the processes to which the signal is sent: + +@table @r +@item @var{pid} greater than 0 +The process whose identifier is @var{pid}. +@item @var{pid} equal to 0 +All processes in the current process group. +@item @var{pid} less than -1 +The process group whose identifier is -@var{pid} +@item @var{pid} equal to -1 +If the process is privileged, all processes except for some special +system processes. Otherwise, all processes with the current effective +user ID. +@end table + +@var{sig} should be specified using a variable corresponding to +the Unix symbolic name, e.g., + +@defvar SIGHUP +Hang-up signal. +@end defvar + +@defvar SIGINT +Interrupt signal. +@end defvar +@end deffn + + waitpid +@c snarfed from posix.c:451 +@deffn primitive waitpid pid [options] +This procedure collects status information from a child process which +has terminated or (optionally) stopped. Normally it will +suspend the calling process until this can be done. If more than one +child process is eligible then one will be chosen by the operating system. + +The value of @var{pid} determines the behaviour: + +@table @r +@item @var{pid} greater than 0 +Request status information from the specified child process. +@item @var{pid} equal to -1 or WAIT_ANY +Request status information for any child process. +@item @var{pid} equal to 0 or WAIT_MYPGRP +Request status information for any child process in the current process +group. +@item @var{pid} less than -1 +Request status information for any child process whose process group ID +is -@var{PID}. +@end table + +The @var{options} argument, if supplied, should be the bitwise OR of the +values of zero or more of the following variables: + +@defvar WNOHANG +Return immediately even if there are no child processes to be collected. +@end defvar + +@defvar WUNTRACED +Report status information for stopped processes as well as terminated +processes. +@end defvar + +The return value is a pair containing: + +@enumerate +@item +The process ID of the child process, or 0 if @code{WNOHANG} was +specified and no process was collected. +@item +The integer status value. +@end enumerate +@end deffn + + status:exit-val +@c snarfed from posix.c:478 +@deffn primitive status:exit-val status +Returns the exit status value, as would be +set if a process ended normally through a +call to @code{exit} or @code{_exit}, if any, otherwise @code{#f}. +@end deffn + + status:term-sig +@c snarfed from posix.c:498 +@deffn primitive status:term-sig status +Returns the signal number which terminated the +process, if any, otherwise @code{#f}. +@end deffn + + status:stop-sig +@c snarfed from posix.c:516 +@deffn primitive status:stop-sig status +Returns the signal number which stopped the +process, if any, otherwise @code{#f}. +@end deffn + + getppid +@c snarfed from posix.c:533 +@deffn primitive getppid +Returns an integer representing the process ID of the parent process. +@end deffn + + getuid +@c snarfed from posix.c:544 +@deffn primitive getuid +Returns an integer representing the current real user ID. +@end deffn + + getgid +@c snarfed from posix.c:555 +@deffn primitive getgid +Returns an integer representing the current real group ID. +@end deffn + + geteuid +@c snarfed from posix.c:569 +@deffn primitive geteuid +Returns an integer representing the current effective user ID. +If the system does not support effective IDs, then the real ID +is returned. @code{(feature? 'EIDs)} reports whether the system +supports effective IDs. +@end deffn + + getegid +@c snarfed from posix.c:587 +@deffn primitive getegid +Returns an integer representing the current effective group ID. +If the system does not support effective IDs, then the real ID +is returned. @code{(feature? 'EIDs)} reports whether the system +supports effective IDs. +@end deffn + + setuid +@c snarfed from posix.c:603 +@deffn primitive setuid id +Sets both the real and effective user IDs to the integer @var{id}, provided +the process has appropriate privileges. +The return value is unspecified. +@end deffn + + setgid +@c snarfed from posix.c:617 +@deffn primitive setgid id +Sets both the real and effective group IDs to the integer @var{id}, provided +the process has appropriate privileges. +The return value is unspecified. +@end deffn + + seteuid +@c snarfed from posix.c:633 +@deffn primitive seteuid id +Sets the effective user ID to the integer @var{id}, provided the process +has appropriate privileges. If effective IDs are not supported, the +real ID is set instead -- @code{(feature? 'EIDs)} reports whether the +system supports effective IDs. +The return value is unspecified. +@end deffn + + setegid +@c snarfed from posix.c:657 +@deffn primitive setegid id +Sets the effective group ID to the integer @var{id}, provided the process +has appropriate privileges. If effective IDs are not supported, the +real ID is set instead -- @code{(feature? 'EIDs)} reports whether the +system supports effective IDs. +The return value is unspecified. +@end deffn + + getpgrp +@c snarfed from posix.c:679 +@deffn primitive getpgrp +Returns an integer representing the current process group ID. +This is the POSIX definition, not BSD. +@end deffn + + setpgid +@c snarfed from posix.c:695 +@deffn primitive setpgid pid pgid +Move the process @var{pid} into the process group @var{pgid}. @var{pid} or +@var{pgid} must be integers: they can be zero to indicate the ID of the +current process. +Fails on systems that do not support job control. +The return value is unspecified. +@end deffn + + setsid +@c snarfed from posix.c:714 +@deffn primitive setsid +Creates a new session. The current process becomes the session leader +and is put in a new process group. The process will be detached +from its controlling terminal if it has one. +The return value is an integer representing the new process group ID. +@end deffn + + ttyname +@c snarfed from posix.c:728 +@deffn primitive ttyname port +Returns a string with the name of the serial terminal device underlying +@var{port}. +@end deffn + + ctermid +@c snarfed from posix.c:751 +@deffn primitive ctermid +Returns a string containing the file name of the controlling terminal +for the current process. +@end deffn + + tcgetpgrp +@c snarfed from posix.c:773 +@deffn primitive tcgetpgrp port +Returns the process group ID of the foreground +process group associated with the terminal open on the file descriptor +underlying @var{port}. + +If there is no foreground process group, the return value is a +number greater than 1 that does not match the process group ID +of any existing process group. This can happen if all of the +processes in the job that was formerly the foreground job have +terminated, and no other job has yet been moved into the +foreground. +@end deffn + + tcsetpgrp +@c snarfed from posix.c:797 +@deffn primitive tcsetpgrp port pgid +Set the foreground process group ID for the terminal used by the file +descriptor underlying @var{port} to the integer @var{pgid}. +The calling process +must be a member of the same session as @var{pgid} and must have the same +controlling terminal. The return value is unspecified. +@end deffn + + execl +@c snarfed from posix.c:857 +@deffn primitive execl filename . args +Executes the file named by @var{path} as a new process image. +The remaining arguments are supplied to the process; from a C program +they are accessable as the @code{argv} argument to @code{main}. +Conventionally the first @var{arg} is the same as @var{path}. +All arguments must be strings. + +If @var{arg} is missing, @var{path} is executed with a null +argument list, which may have system-dependent side-effects. + +This procedure is currently implemented using the @code{execv} system +call, but we call it @code{execl} because of its Scheme calling interface. +@end deffn + + execlp +@c snarfed from posix.c:878 +@deffn primitive execlp filename . args +Similar to @code{execl}, however if +@var{filename} does not contain a slash +then the file to execute will be located by searching the +directories listed in the @code{PATH} environment variable. + +This procedure is currently implemented using the @code{execvp} system +call, but we call it @code{execlp} because of its Scheme calling interface. +@end deffn + + execle +@c snarfed from posix.c:929 +@deffn primitive execle filename env . args +Similar to @code{execl}, but the environment of the new process is +specified by @var{env}, which must be a list of strings as returned by the +@code{environ} procedure. + +This procedure is currently implemented using the @code{execve} system +call, but we call it @code{execle} because of its Scheme calling interface. +@end deffn + + primitive-fork +@c snarfed from posix.c:953 +@deffn primitive primitive-fork +Creates a new "child" process by duplicating the current "parent" process. +In the child the return value is 0. In the parent the return value is +the integer process ID of the child. + +This procedure has been renamed from @code{fork} to avoid a naming conflict +with the scsh fork. +@end deffn + + uname +@c snarfed from posix.c:968 +@deffn primitive uname +Returns an object with some information about the computer system the +program is running on. +@end deffn + + environ +@c snarfed from posix.c:997 +@deffn primitive environ [env] +If @var{env} is omitted, returns the current environment as a list of strings. +Otherwise it sets the current environment, which is also the +default environment for child processes, to the supplied list of strings. +Each member of @var{env} should be of the form +@code{NAME=VALUE} and values of @code{NAME} should not be duplicated. +If @var{env} is supplied then the return value is unspecified. +@end deffn + + tmpnam +@c snarfed from posix.c:1035 +@deffn primitive tmpnam +tmpnam returns a name in the file system that does not match +any existing file. However there is no guarantee that +another process will not create the file after tmpnam +is called. Care should be taken if opening the file, +e.g., use the O_EXCL open flag or use @code{mkstemp!} instead. +@end deffn + + mkstemp! +@c snarfed from posix.c:1058 +@deffn primitive mkstemp! tmpl +mkstemp creates a new unique file in the file system and +returns a new buffered port open for reading and writing to +the file. @var{tmpl} is a string specifying where the +file should be created: it must end with @code{XXXXXX} +and will be changed in place to return the name of the +temporary file. +@end deffn + + utime +@c snarfed from posix.c:1086 +@deffn primitive utime pathname [actime [modtime]] +@code{utime} sets the access and modification times for +the file named by @var{path}. If @var{actime} or @var{modtime} +is not supplied, then the current time is used. +@var{actime} and @var{modtime} +must be integer time values as returned by the @code{current-time} +procedure. + +E.g., + +@smalllisp +(utime "foo" (- (current-time) 3600)) +@end smalllisp + +will set the access time to one hour in the past and the modification +time to the current time. +@end deffn + + access? +@c snarfed from posix.c:1135 +@deffn primitive access? path how +Returns @code{#t} if @var{path} corresponds to an existing +file and the current process +has the type of access specified by @var{how}, otherwise +@code{#f}. +@var{how} should be specified +using the values of the variables listed below. Multiple values can +be combined using a bitwise or, in which case @code{#t} will only +be returned if all accesses are granted. + +Permissions are checked using the real id of the current process, +not the effective id, although it's the effective id which determines +whether the access would actually be granted. + +@defvar R_OK +test for read permission. +@end defvar +@defvar W_OK +test for write permission. +@end defvar +@defvar X_OK +test for execute permission. +@end defvar +@defvar F_OK +test for existence of the file. +@end defvar +@end deffn + + getpid +@c snarfed from posix.c:1150 +@deffn primitive getpid +Returns an integer representing the current process ID. +@end deffn + + putenv +@c snarfed from posix.c:1167 +@deffn primitive putenv str +Modifies the environment of the current process, which is +also the default environment inherited by child processes. + +If @var{string} is of the form @code{NAME=VALUE} then it will be written +directly into the environment, replacing any existing environment string +with +name matching @code{NAME}. If @var{string} does not contain an equal +sign, then any existing string with name matching @var{string} will +be removed. + +The return value is unspecified. +@end deffn + + setlocale +@c snarfed from posix.c:1198 +@deffn primitive setlocale category [locale] +If @var{locale} is omitted, returns the current value of the specified +locale category +as a system-dependent string. +@var{category} should be specified using the values @code{LC_COLLATE}, +@code{LC_ALL} etc. + +Otherwise the specified locale category is set to +the string @var{locale} +and the new value is returned as a system-dependent string. If @var{locale} +is an empty string, the locale will be set using envirionment variables. +@end deffn + + mknod +@c snarfed from posix.c:1239 +@deffn primitive mknod path type perms dev +Creates a new special file, such as a file corresponding to a device. +@var{path} specifies the name of the file. @var{type} should +be one of the following symbols: +regular, directory, symlink, block-special, char-special, +fifo, or socket. @var{perms} (an integer) specifies the file permissions. +@var{dev} (an integer) specifies which device the special file refers +to. Its exact interpretation depends on the kind of special file +being created. + +E.g., +@example +(mknod "/dev/fd0" 'block-special #o660 (+ (* 2 256) 2)) +@end example + +The return value is unspecified. +@end deffn + + nice +@c snarfed from posix.c:1286 +@deffn primitive nice incr +Increment the priority of the current process by @var{incr}. A higher +priority value means that the process runs less often. +The return value is unspecified. +@end deffn + + sync +@c snarfed from posix.c:1301 +@deffn primitive sync +Flush the operating system disk buffers. +The return value is unspecified. +@end deffn + + crypt +@c snarfed from posix.c:1314 +@deffn primitive crypt key salt +Encrypt @var{key} using @var{salt} as the salt value to the +crypt(3) library call +@end deffn + + chroot +@c snarfed from posix.c:1337 +@deffn primitive chroot path +Change the root directory to that specified in @var{path}. +This directory will be used for path names beginning with +@file{/}. The root directory is inherited by all children +of the current process. Only the superuser may change the +root directory. +@end deffn + + getlogin +@c snarfed from posix.c:1355 +@deffn primitive getlogin +Return a string containing the name of the user logged in on +the controlling terminal of the process, or @code{#f} if this +information cannot be obtained. +@end deffn + + cuserid +@c snarfed from posix.c:1373 +@deffn primitive cuserid +Return a string containing a user name associated with the +effective user id of the process. Return @code{#f} if this +information cannot be obtained. +@end deffn + + getpriority +@c snarfed from posix.c:1398 +@deffn primitive getpriority which who +Return the scheduling priority of the process, process group +or user, as indicated by @var{which} and @var{who}. @var{which} +is one of the variables @code{PRIO_PROCESS}, @code{PRIO_PGRP} +or @code{PRIO_USER}, and @var{who} is interpreted relative to +@var{which} (a process identifier for @code{PRIO_PROCESS}, +process group identifier for @code{PRIO_PGRP}, and a user +identifier for @code{PRIO_USER}. A zero value of @var{who} +denotes the current process, process group, or user. Return +the highest priority (lowest numerical value) of any of the +specified processes. +@end deffn + + setpriority +@c snarfed from posix.c:1432 +@deffn primitive setpriority which who prio +Set the scheduling priority of the process, process group +or user, as indicated by @var{which} and @var{who}. @var{which} +is one of the variables @code{PRIO_PROCESS}, @code{PRIO_PGRP} +or @code{PRIO_USER}, and @var{who} is interpreted relative to +@var{which} (a process identifier for @code{PRIO_PROCESS}, +process group identifier for @code{PRIO_PGRP}, and a user +identifier for @code{PRIO_USER}. A zero value of @var{who} +denotes the current process, process group, or user. +@var{prio} is a value in the range -20 and 20, the default +priority is 0; lower priorities cause more favorable +scheduling. Sets the priority of all of the specified +processes. Only the super-user may lower priorities. +The return value is not specified. +@end deffn + + getpass +@c snarfed from posix.c:1457 +@deffn primitive getpass prompt +Display @var{prompt} to the standard error output and read +a password from @file{/dev/tty}. If this file is not +accessible, it reads from standard input. The password may be +up to 127 characters in length. Additional characters and the +terminating newline character are discarded. While reading +the password, echoing and the generation of signals by special +characters is disabled. +@end deffn + + flock +@c snarfed from posix.c:1496 +@deffn primitive flock file operation +Apply or remove an advisory lock on an open file. +@var{operation} specifies the action to be done: +@table @code +@item LOCK_SH +Shared lock. More than one process may hold a shared lock +for a given file at a given time. +@item LOCK_EX +Exclusive lock. Only one process may hold an exclusive lock +for a given file at a given time. +@item LOCK_UN +Unlock the file. +@item LOCK_NB +Don't block when locking. May be specified by bitwise OR'ing +it to one of the other operations. +@end table +The return value is not specified. @var{file} may be an open +file descriptor or an open file descriptior port. +@end deffn + + sethostname +@c snarfed from posix.c:1522 +@deffn primitive sethostname name +Set the host name of the current processor to @var{name}. May +only be used by the superuser. The return value is not +specified. +@end deffn + + gethostname +@c snarfed from posix.c:1538 +@deffn primitive gethostname +Return the host name of the current processor. +@end deffn + + print-options-interface +@c snarfed from print.c:142 +@deffn primitive print-options-interface [setting] +Option interface for the print options. Instead of using +this procedure directly, use the procedures +@code{print-enable}, @code{print-disable}, @code{print-set!} +and @code{print-options}. +@end deffn + + simple-format +@c snarfed from print.c:980 +@deffn primitive simple-format destination message . args +Write @var{message} to @var{destination}, defaulting to +the current output port. +@var{message} can contain @code{~A} (was @code{%s}) and +@code{~S} (was @code{%S}) escapes. When printed, +the escapes are replaced with corresponding members of +@var{ARGS}: +@code{~A} formats using @code{display} and @code{~S} formats +using @code{write}. +If @var{destination} is @code{#t}, then use the current output +port, if @var{destination} is @code{#f}, then return a string +containing the formatted text. Does not add a trailing newline. +@end deffn + + newline +@c snarfed from print.c:1045 +@deffn primitive newline [port] +Send a newline to @var{port}. +@end deffn + + write-char +@c snarfed from print.c:1060 +@deffn primitive write-char chr [port] +Send character @var{chr} to @var{port}. +@end deffn + + port-with-print-state +@c snarfed from print.c:1114 +@deffn primitive port-with-print-state port pstate +Create a new port which behaves like @var{port}, but with an +included print state @var{pstate}. +@end deffn + + get-print-state +@c snarfed from print.c:1129 +@deffn primitive get-print-state port +Return the print state of the port @var{port}. If @var{port} +has no associated print state, @code{#f} is returned. +@end deffn + + procedure-properties +@c snarfed from procprop.c:180 +@deffn primitive procedure-properties proc +Return @var{obj}'s property list. +@end deffn + + set-procedure-properties! +@c snarfed from procprop.c:193 +@deffn primitive set-procedure-properties! proc new_val +Set @var{obj}'s property list to @var{alist}. +@end deffn + + procedure-property +@c snarfed from procprop.c:206 +@deffn primitive procedure-property p k +Return the property of @var{obj} with name @var{key}. +@end deffn + + set-procedure-property! +@c snarfed from procprop.c:229 +@deffn primitive set-procedure-property! p k v +In @var{obj}'s property list, set the property named @var{key} to +@var{value}. +@end deffn + + procedure? +@c snarfed from procs.c:196 +@deffn primitive procedure? obj +Return @code{#t} if @var{obj} is a procedure. +@end deffn + + closure? +@c snarfed from procs.c:223 +@deffn primitive closure? obj +Return @code{#t} if @var{obj} is a closure. +@end deffn + + thunk? +@c snarfed from procs.c:232 +@deffn primitive thunk? obj +Return @code{#t} if @var{obj} is a thunk. +@end deffn + + procedure-documentation +@c snarfed from procs.c:283 +@deffn primitive procedure-documentation proc +Return the documentation string associated with @code{proc}. By +convention, if a procedure contains more than one expression and the +first expression is a string constant, that string is assumed to contain +documentation for that procedure. +@end deffn + + procedure-with-setter? +@c snarfed from procs.c:319 +@deffn primitive procedure-with-setter? obj +Return @code{#t} if @var{obj} is a procedure with an +associated setter procedure. +@end deffn + + make-procedure-with-setter +@c snarfed from procs.c:329 +@deffn primitive make-procedure-with-setter procedure setter +Create a new procedure which behaves like @var{procedure}, but +with the associated setter @var{setter}. +@end deffn + + procedure +@c snarfed from procs.c:348 +@deffn primitive procedure proc +Return the procedure of @var{proc}, which must be either a +procedure with setter, or an operator struct. +@end deffn + + primitive-make-property +@c snarfed from properties.c:66 +@deffn primitive primitive-make-property not_found_proc +Create a @dfn{property token} that can be used with +@code{primitive-property-ref} and @code{primitive-property-set!}. +See @code{primitive-property-ref} for the significance of +@var{not_found_proc}. +@end deffn + + primitive-property-ref +@c snarfed from properties.c:83 +@deffn primitive primitive-property-ref prop obj +Return the property @var{prop} of @var{obj}. When no value +has yet been associated with @var{prop} and @var{obj}, call +@var{not-found-proc} instead (see @code{primitive-make-property}) +and use its return value. That value is also associated with +@var{obj} via @code{primitive-property-set!}. When +@var{not-found-proc} is @code{#f}, use @code{#f} as the +default value of @var{prop}. +@end deffn + + primitive-property-set! +@c snarfed from properties.c:111 +@deffn primitive primitive-property-set! prop obj val +Associate @var{code} with @var{prop} and @var{obj}. +@end deffn + + primitive-property-del! +@c snarfed from properties.c:131 +@deffn primitive primitive-property-del! prop obj +Remove any value associated with @var{prop} and @var{obj}. +@end deffn + + array-fill! +@c snarfed from ramap.c:467 +@deffn primitive array-fill! ra fill +Stores @var{fill} in every element of @var{array}. The value returned +is unspecified. +@end deffn + + array-copy-in-order! +@c snarfed from ramap.c:832 +@deffn primitive array-copy-in-order! +scm_array_copy_x +@end deffn + + array-copy! +@c snarfed from ramap.c:841 +@deffn primitive array-copy! src dst +@deffnx primitive array-copy-in-order! src dst +Copies every element from vector or array @var{source} to the +corresponding element of @var{destination}. @var{destination} must have +the same rank as @var{source}, and be at least as large in each +dimension. The order is unspecified. +@end deffn + + array-map-in-order! +@c snarfed from ramap.c:1515 +@deffn primitive array-map-in-order! +scm_array_map_x +@end deffn + + array-map! +@c snarfed from ramap.c:1526 +@deffn primitive array-map! ra0 proc . lra +@deffnx primitive array-map-in-order! ra0 proc . lra +@var{array1}, @dots{} must have the same number of dimensions as +@var{array0} and have a range for each index which includes the range +for the corresponding index in @var{array0}. @var{proc} is applied to +each tuple of elements of @var{array1} @dots{} and the result is stored +as the corresponding element in @var{array0}. The value returned is +unspecified. The order of application is unspecified. +@end deffn + + array-for-each +@c snarfed from ramap.c:1673 +@deffn primitive array-for-each proc ra0 . lra +@var{proc} is applied to each tuple of elements of @var{array0} @dots{} +in row-major order. The value returned is unspecified. +@end deffn + + array-index-map! +@c snarfed from ramap.c:1701 +@deffn primitive array-index-map! ra proc +applies @var{proc} to the indices of each element of @var{array} in +turn, storing the result in the corresponding element. The value +returned and the order of application are unspecified. + +One can implement @var{array-indexes} as +@example +(define (array-indexes array) + (let ((ra (apply make-array #f (array-shape array)))) + (array-index-map! ra (lambda x x)) + ra)) +@end example +Another example: +@example +(define (apl:index-generator n) + (let ((v (make-uniform-vector n 1))) + (array-index-map! v (lambda (i) i)) + v)) +@end example +@end deffn + + random +@c snarfed from random.c:370 +@deffn primitive random n [state] +Return a number in [0,N). +Accepts a positive integer or real n and returns a +number of the same type between zero (inclusive) and +N (exclusive). The values returned have a uniform +distribution. +The optional argument @var{state} must be of the type produced +by @code{seed->random-state}. It defaults to the value of the +variable @var{*random-state*}. This object is used to maintain +the state of the pseudo-random-number generator and is altered +as a side effect of the random operation. +@end deffn + + copy-random-state +@c snarfed from random.c:393 +@deffn primitive copy-random-state [state] +Return a copy of the random state @var{state}. +@end deffn + + seed->random-state +@c snarfed from random.c:405 +@deffn primitive seed->random-state seed +Return a new random state using @var{seed}. +@end deffn + + random:uniform +@c snarfed from random.c:418 +@deffn primitive random:uniform [state] +Returns a uniformly distributed inexact real random number in [0,1). +@end deffn + + random:normal +@c snarfed from random.c:433 +@deffn primitive random:normal [state] +Returns an inexact real in a normal distribution. +The distribution used has mean 0 and standard deviation 1. +For a normal distribution with mean m and standard deviation +d use @code{(+ m (* d (random:normal)))}. +@end deffn + + random:solid-sphere! +@c snarfed from random.c:489 +@deffn primitive random:solid-sphere! v [state] +Fills vect with inexact real random numbers +the sum of whose squares is less than 1.0. +Thinking of vect as coordinates in space of +dimension n = (vector-length vect), the coordinates +are uniformly distributed within the unit n-shere. +The sum of the squares of the numbers is returned. +@end deffn + + random:hollow-sphere! +@c snarfed from random.c:512 +@deffn primitive random:hollow-sphere! v [state] +Fills vect with inexact real random numbers +the sum of whose squares is equal to 1.0. +Thinking of vect as coordinates in space of +dimension n = (vector-length vect), the coordinates +are uniformly distributed over the surface of the +unit n-shere. +@end deffn + + random:normal-vector! +@c snarfed from random.c:530 +@deffn primitive random:normal-vector! v [state] +Fills vect with inexact real random numbers that are +independent and standard normally distributed +(i.e., with mean 0 and variance 1). +@end deffn + + random:exp +@c snarfed from random.c:554 +@deffn primitive random:exp [state] +Returns an inexact real in an exponential distribution with mean 1. +For an exponential distribution with mean u use (* u (random:exp)). +@end deffn + + %read-delimited! +@c snarfed from rdelim.c:78 +@deffn primitive %read-delimited! delims str gobble [port [start [end]]] +Read characters from @var{port} into @var{str} until one of the +characters in the @var{delims} string is encountered. If +@var{gobble} is true, discard the delimiter character; +otherwise, leave it in the input stream for the next read. If +@var{port} is not specified, use the value of +@code{(current-input-port)}. If @var{start} or @var{end} are +specified, store data only into the substring of @var{str} +bounded by @var{start} and @var{end} (which default to the +beginning and end of the string, respectively). + Return a pair consisting of the delimiter that terminated the +string and the number of characters read. If reading stopped +at the end of file, the delimiter returned is the +@var{eof-object}; if the string was filled without encountering +a delimiter, this value is @code{#f}. +@end deffn + + %read-line +@c snarfed from rdelim.c:223 +@deffn primitive %read-line [port] +Read a newline-terminated line from @var{port}, allocating storage as +necessary. The newline terminator (if any) is removed from the string, +and a pair consisting of the line and its delimiter is returned. The +delimiter may be either a newline or the @var{eof-object}; if +@code{%read-line} is called at the end of file, it returns the pair +@code{(# . #)}. +@end deffn + + write-line +@c snarfed from rdelim.c:277 +@deffn primitive write-line obj [port] +Display @var{obj} and a newline character to @var{port}. If @var{port} +is not specified, @code{(current-output-port)} is used. This function +is equivalent to: + +@smalllisp +(display obj [port]) +(newline [port]) +@end smalllisp +@end deffn + + read-options-interface +@c snarfed from read.c:84 +@deffn primitive read-options-interface [setting] +Option interface for the read options. Instead of using +this procedure directly, use the procedures @code{read-enable}, +@code{read-disable}, @code{read-set!} and @var{read-options}. +@end deffn + + read +@c snarfed from read.c:104 +@deffn primitive read [port] +Read an s-expression from the input port @var{port}, or from +the current input port if @var{port} is not specified. +Any whitespace before the next token is discarded. +@end deffn + + read-hash-extend +@c snarfed from read.c:746 +@deffn primitive read-hash-extend chr proc +Install the procedure @var{proc} for reading expressions +starting with the character sequence @code{#} and @var{chr}. +@var{proc} will be called with two arguments: the character +@var{chr} and the port to read further data from. The object +returned will be the return value of @code{read}. +@end deffn + + regexp? +@c snarfed from regex-posix.c:139 +@deffn primitive regexp? x +Return @code{#t} if @var{obj} is a compiled regular expression, or +@code{#f} otherwise. +@end deffn + + make-regexp +@c snarfed from regex-posix.c:179 +@deffn primitive make-regexp pat . flags +Compile the regular expression described by @var{str}, and return the +compiled regexp structure. If @var{str} does not describe a legal +regular expression, @code{make-regexp} throws a +@code{regular-expression-syntax} error. + +The @var{flag} arguments change the behavior of the compiled regexp. +The following flags may be supplied: + +@table @code +@item regexp/icase +Consider uppercase and lowercase letters to be the same when matching. + +@item regexp/newline +If a newline appears in the target string, then permit the @samp{^} and +@samp{$} operators to match immediately after or immediately before the +newline, respectively. Also, the @samp{.} and @samp{[^...]} operators +will never match a newline character. The intent of this flag is to +treat the target string as a buffer containing many lines of text, and +the regular expression as a pattern that may match a single one of those +lines. + +@item regexp/basic +Compile a basic (``obsolete'') regexp instead of the extended +(``modern'') regexps that are the default. Basic regexps do not +consider @samp{|}, @samp{+} or @samp{?} to be special characters, and +require the @samp{@{...@}} and @samp{(...)} metacharacters to be +backslash-escaped (@pxref{Backslash Escapes}). There are several other +differences between basic and extended regular expressions, but these +are the most significant. + +@item regexp/extended +Compile an extended regular expression rather than a basic regexp. This +is the default behavior; this flag will not usually be needed. If a +call to @code{make-regexp} includes both @code{regexp/basic} and +@code{regexp/extended} flags, the one which comes last will override +the earlier one. +@end table +@end deffn + + regexp-exec +@c snarfed from regex-posix.c:226 +@deffn primitive regexp-exec rx str [start [flags]] +Match the compiled regular expression @var{regexp} against @code{str}. +If the optional integer @var{start} argument is provided, begin matching +from that position in the string. Return a match structure describing +the results of the match, or @code{#f} if no match could be found. +@end deffn + + call-with-dynamic-root +@c snarfed from root.c:358 +@deffn primitive call-with-dynamic-root thunk handler +Evaluate @code{(thunk)} in a new dynamic context, returning its value. + +If an error occurs during evaluation, apply @var{handler} to the +arguments to the throw, just as @code{throw} would. If this happens, +@var{handler} is called outside the scope of the new root -- it is +called in the same dynamic context in which +@code{call-with-dynamic-root} was evaluated. + +If @var{thunk} captures a continuation, the continuation is rooted at +the call to @var{thunk}. In particular, the call to +@code{call-with-dynamic-root} is not captured. Therefore, +@code{call-with-dynamic-root} always returns at most one time. + +Before calling @var{thunk}, the dynamic-wind chain is un-wound back to +the root and a new chain started for @var{thunk}. Therefore, this call +may not do what you expect: + +@example +;; Almost certainly a bug: +(with-output-to-port + some-port + + (lambda () + (call-with-dynamic-root + (lambda () + (display 'fnord) + (newline)) + (lambda (errcode) errcode)))) +@end example + +The problem is, on what port will @samp{fnord} be displayed? You +might expect that because of the @code{with-output-to-port} that +it will be displayed on the port bound to @code{some-port}. But it +probably won't -- before evaluating the thunk, dynamic winds are +unwound, including those created by @code{with-output-to-port}. +So, the standard output port will have been re-set to its default value +before @code{display} is evaluated. + +(This function was added to Guile mostly to help calls to functions in C +libraries that can not tolerate non-local exits or calls that return +multiple times. If such functions call back to the interpreter, it should +be under a new dynamic root.) +@end deffn + + dynamic-root +@c snarfed from root.c:371 +@deffn primitive dynamic-root +Return an object representing the current dynamic root. + +These objects are only useful for comparison using @code{eq?}. +They are currently represented as numbers, but your code should +in no way depend on this. +@end deffn + + sigaction +@c snarfed from scmsigs.c:201 +@deffn primitive sigaction signum [handler [flags]] +Install or report the signal handler for a specified signal. + +@var{signum} is the signal number, which can be specified using the value +of variables such as @code{SIGINT}. + +If @var{action} is omitted, @code{sigaction} returns a pair: the +CAR is the current +signal hander, which will be either an integer with the value @code{SIG_DFL} +(default action) or @code{SIG_IGN} (ignore), or the Scheme procedure which +handles the signal, or @code{#f} if a non-Scheme procedure handles the +signal. The CDR contains the current @code{sigaction} flags for the handler. + +If @var{action} is provided, it is installed as the new handler for +@var{signum}. @var{action} can be a Scheme procedure taking one +argument, or the value of @code{SIG_DFL} (default action) or +@code{SIG_IGN} (ignore), or @code{#f} to restore whatever signal handler +was installed before @code{sigaction} was first used. Flags can +optionally be specified for the new handler (@code{SA_RESTART} will +always be added if it's available and the system is using restartable +system calls.) The return value is a pair with information about the +old handler as described above. + +This interface does not provide access to the "signal blocking" +facility. Maybe this is not needed, since the thread support may +provide solutions to the problem of consistent access to data +structures. +@end deffn + + restore-signals +@c snarfed from scmsigs.c:360 +@deffn primitive restore-signals +Return all signal handlers to the values they had before any call to +@code{sigaction} was made. The return value is unspecified. +@end deffn + + alarm +@c snarfed from scmsigs.c:399 +@deffn primitive alarm i +Set a timer to raise a @code{SIGALRM} signal after the specified +number of seconds (an integer). It's advisable to install a signal +handler for +@code{SIGALRM} beforehand, since the default action is to terminate +the process. + +The return value indicates the time remaining for the previous alarm, +if any. The new value replaces the previous alarm. If there was +no previous alarm, the return value is zero. +@end deffn + + pause +@c snarfed from scmsigs.c:414 +@deffn primitive pause +Pause the current process (thread?) until a signal arrives whose +action is to either terminate the current process or invoke a +handler procedure. The return value is unspecified. +@end deffn + + sleep +@c snarfed from scmsigs.c:427 +@deffn primitive sleep i +Wait for the given number of seconds (an integer) or until a signal +arrives. The return value is zero if the time elapses or the number +of seconds remaining otherwise. +@end deffn + + usleep +@c snarfed from scmsigs.c:445 +@deffn primitive usleep i +Sleep for I microseconds. @code{usleep} is not available on +all platforms. +@end deffn + + raise +@c snarfed from scmsigs.c:475 +@deffn primitive raise sig +Sends a specified signal @var{sig} to the current process, where +@var{sig} is as described for the kill procedure. +@end deffn + + system +@c snarfed from simpos.c:76 +@deffn primitive system [cmd] +Executes @var{cmd} using the operating system's "command processor". +Under Unix this is usually the default shell @code{sh}. The value +returned is @var{cmd}'s exit status as returned by @code{waitpid}, which +can be interpreted using the functions above. + +If @code{system} is called without arguments, it returns a boolean +indicating whether the command processor is available. +@end deffn + + getenv +@c snarfed from simpos.c:104 +@deffn primitive getenv nam +Looks up the string @var{name} in the current environment. The return +value is @code{#f} unless a string of the form @code{NAME=VALUE} is +found, in which case the string @code{VALUE} is returned. +@end deffn + + primitive-exit +@c snarfed from simpos.c:120 +@deffn primitive primitive-exit [status] +Terminate the current process without unwinding the Scheme stack. +This is would typically be useful after a fork. The exit status +is @var{status} if supplied, otherwise zero. +@end deffn + + htons +@c snarfed from socket.c:89 +@deffn primitive htons in +Returns a new integer from @var{value} by converting from host to +network order. @var{value} must be within the range of a C unsigned +short integer. +@end deffn + + ntohs +@c snarfed from socket.c:106 +@deffn primitive ntohs in +Returns a new integer from @var{value} by converting from network to +host order. @var{value} must be within the range of a C unsigned short +integer. +@end deffn + + htonl +@c snarfed from socket.c:123 +@deffn primitive htonl in +Returns a new integer from @var{value} by converting from host to +network order. @var{value} must be within the range of a C unsigned +long integer. +@end deffn + + ntohl +@c snarfed from socket.c:135 +@deffn primitive ntohl in +Returns a new integer from @var{value} by converting from network to +host order. @var{value} must be within the range of a C unsigned +long integer. +@end deffn + + socket +@c snarfed from socket.c:158 +@deffn primitive socket family style proto +Returns a new socket port of the type specified by @var{family}, @var{style} +and @var{protocol}. All three parameters are integers. Typical values +for @var{family} are the values of @code{AF_UNIX} +and @code{AF_INET}. Typical values for @var{style} are +the values of @code{SOCK_STREAM}, @code{SOCK_DGRAM} and @code{SOCK_RAW}. + +@var{protocol} can be obtained from a protocol name using +@code{getprotobyname}. A value of +zero specifies the default protocol, which is usually right. + +A single socket port cannot by used for communication until +it has been connected to another socket. +@end deffn + + socketpair +@c snarfed from socket.c:180 +@deffn primitive socketpair family style proto +Returns a pair of connected (but unnamed) socket ports of the type specified +by @var{family}, @var{style} and @var{protocol}. +Many systems support only +socket pairs of the @code{AF_UNIX} family. Zero is likely to be +the only meaningful value for @var{protocol}. +@end deffn + + getsockopt +@c snarfed from socket.c:209 +@deffn primitive getsockopt sock level optname +Returns the value of a particular socket option for the socket +port @var{socket}. @var{level} is an integer code for type of option +being requested, e.g., @code{SOL_SOCKET} for socket-level options. +@var{optname} is an +integer code for the option required and should be specified using one of +the symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc. + +The returned value is typically an integer but @code{SO_LINGER} returns a +pair of integers. +@end deffn + + setsockopt +@c snarfed from socket.c:277 +@deffn primitive setsockopt sock level optname value +Sets the value of a particular socket option for the socket +port @var{socket}. @var{level} is an integer code for type of option +being set, e.g., @code{SOL_SOCKET} for socket-level options. +@var{optname} is an +integer code for the option to set and should be specified using one of +the symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc. +@var{value} is the value to which the option should be set. For +most options this must be an integer, but for @code{SO_LINGER} it must +be a pair. + +The return value is unspecified. +@end deffn + + shutdown +@c snarfed from socket.c:381 +@deffn primitive shutdown sock how +Sockets can be closed simply by using @code{close-port}. The +@code{shutdown} procedure allows reception or tranmission on a +connection to be shut down individually, according to the parameter +@var{how}: + +@table @asis +@item 0 +Stop receiving data for this socket. If further data arrives, reject it. +@item 1 +Stop trying to transmit data from this socket. Discard any +data waiting to be sent. Stop looking for acknowledgement of +data already sent; don't retransmit it if it is lost. +@item 2 +Stop both reception and transmission. +@end table + +The return value is unspecified. +@end deffn + + connect +@c snarfed from socket.c:474 +@deffn primitive connect sock fam address . args +Initiates a connection from @var{socket} to the address +specified by @var{address} and possibly @var{arg @dots{}}. The format +required for @var{address} +and @var{arg} @dots{} depends on the family of the socket. + +For a socket of family @code{AF_UNIX}, +only @code{address} is specified and must be a string with the +filename where the socket is to be created. + +For a socket of family @code{AF_INET}, +@code{address} must be an integer Internet host address and @var{arg} @dots{} +must be a single integer port number. + +The return value is unspecified. +@end deffn + + bind +@c snarfed from socket.c:528 +@deffn primitive bind sock fam address . args +Assigns an address to the socket port @var{socket}. +Generally this only needs to be done for server sockets, +so they know where to look for incoming connections. A socket +without an address will be assigned one automatically when it +starts communicating. + +The format of @var{address} and @var{ARG} @dots{} depends on the family +of the socket. + +For a socket of family @code{AF_UNIX}, only @var{address} +is specified and must +be a string with the filename where the socket is to be created. + +For a socket of family @code{AF_INET}, @var{address} must be an integer +Internet host address and @var{arg} @dots{} must be a single integer +port number. + +The values of the following variables can also be used for @var{address}: + +@defvar INADDR_ANY +Allow connections from any address. +@end defvar + +@defvar INADDR_LOOPBACK +The address of the local host using the loopback device. +@end defvar + +@defvar INADDR_BROADCAST +The broadcast address on the local network. +@end defvar + +@defvar INADDR_NONE +No address. +@end defvar + +The return value is unspecified. +@end deffn + + listen +@c snarfed from socket.c:561 +@deffn primitive listen sock backlog +This procedure enables @var{socket} to accept connection +requests. @var{backlog} is an integer specifying +the maximum length of the queue for pending connections. +If the queue fills, new clients will fail to connect until the +server calls @code{accept} to accept a connection from the queue. + +The return value is unspecified. +@end deffn + + accept +@c snarfed from socket.c:637 +@deffn primitive accept sock +Accepts a connection on a bound, listening socket @var{socket}. If there +are no pending connections in the queue, it waits until +one is available unless the non-blocking option has been set on the +socket. + +The return value is a +pair in which the CAR is a new socket port for the connection and +the CDR is an object with address information about the client which +initiated the connection. + +If the address is not available then the CDR will be an empty vector. + +@var{socket} does not become part of the +connection and will continue to accept new requests. +@end deffn + + getsockname +@c snarfed from socket.c:668 +@deffn primitive getsockname sock +Returns the address of @var{socket}, in the same form as the object +returned by @code{accept}. On many systems the address of a socket +in the @code{AF_FILE} namespace cannot be read. +@end deffn + + getpeername +@c snarfed from socket.c:695 +@deffn primitive getpeername sock +Returns the address of the socket that the socket @var{socket} is connected to, +in the same form as the object +returned by @code{accept}. On many systems the address of a socket +in the @code{AF_FILE} namespace cannot be read. +@end deffn + + recv! +@c snarfed from socket.c:730 +@deffn primitive recv! sock buf [flags] +Receives data from the socket port @var{socket}. @var{socket} must already +be bound to the address from which data is to be received. +@var{buf} is a string into which +the data will be written. The size of @var{buf} limits the amount of +data which can be received: in the case of packet +protocols, if a packet larger than this limit is encountered then some data +will be irrevocably lost. + +The optional @var{flags} argument is a value or +bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc. + +The value returned is the number of bytes read from the socket. + +Note that the data is read directly from the socket file descriptor: +any unread buffered port data is ignored. +@end deffn + + send +@c snarfed from socket.c:759 +@deffn primitive send sock message [flags] +Transmits the string @var{message} on the socket port @var{socket}. +@var{socket} must already be bound to a destination address. The +value returned is the number of bytes transmitted -- it's possible for +this to be less than the length of @var{message} if the socket is +set to be non-blocking. The optional @var{flags} argument is a value or +bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc. + +Note that the data is written directly to the socket file descriptor: +any unflushed buffered port data is ignored. +@end deffn + + recvfrom! +@c snarfed from socket.c:797 +@deffn primitive recvfrom! sock str [flags [start [end]]] +Returns data from the socket port @var{socket} and also information about +where the data was received from. @var{socket} must already +be bound to the address from which data is to be received. +@code{str}, is a string into which +the data will be written. The size of @var{str} limits the amount of +data which can be received: in the case of packet +protocols, if a packet larger than this limit is encountered then some data +will be irrevocably lost. + +The optional @var{flags} argument is a value or +bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc. + +The value returned is a pair: the CAR is the number of bytes read from +the socket and the CDR an address object in the same form as returned by +@code{accept}. + +The @var{start} and @var{end} arguments specify a substring of @var{str} +to which the data should be written. + +Note that the data is read directly from the socket file descriptor: +any unread buffered port data is ignored. +@end deffn + + sendto +@c snarfed from socket.c:848 +@deffn primitive sendto sock message fam address . args_and_flags +Transmits the string @var{message} on the socket port @var{socket}. The +destination address is specified using the @var{family}, @var{address} and +@var{arg} arguments, in a similar way to the @code{connect} +procedure. The +value returned is the number of bytes transmitted -- it's possible for +this to be less than the length of @var{message} if the socket is +set to be non-blocking. The optional @var{flags} argument is a value or +bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc. + +Note that the data is written directly to the socket file descriptor: +any unflushed buffered port data is ignored. +@end deffn + + restricted-vector-sort! +@c snarfed from sort.c:425 +@deffn primitive restricted-vector-sort! vec less startpos endpos +Sort the vector @var{vec}, using @var{less} for comparing +the vector elements. @var{startpos} and @var{endpos} delimit +the range of the vector which gets sorted. The return value +is not specified. +@end deffn + + sorted? +@c snarfed from sort.c:456 +@deffn primitive sorted? items less +Return @code{#t} iff @var{items} is a list or a vector such that +for all 1 <= i <= m, the predicate @var{less} returns true when +applied to all elements i - 1 and i +@end deffn + + merge +@c snarfed from sort.c:528 +@deffn primitive merge alist blist less +Takes two lists @var{alist} and @var{blist} such that +@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and +returns a new list in which the elements of @var{alist} and +@var{blist} have been stably interleaved so that +@code{(sorted? (merge alist blist less?) less?)}. +Note: this does _not_ accept vectors. +@end deffn + + merge! +@c snarfed from sort.c:641 +@deffn primitive merge! alist blist less +Takes two lists @var{alist} and @var{blist} such that +@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and +returns a new list in which the elements of @var{alist} and +@var{blist} have been stably interleaved so that + @code{(sorted? (merge alist blist less?) less?)}. +This is the destructive variant of @code{merge} +Note: this does _not_ accept vectors. +@end deffn + + sort! +@c snarfed from sort.c:717 +@deffn primitive sort! items less +Sort the sequence @var{items}, which may be a list or a +vector. @var{less} is used for comparing the sequence +elements. The sorting is destructive, that means that the +input sequence is modified to produce the sorted result. +This is not a stable sort. +@end deffn + + sort +@c snarfed from sort.c:751 +@deffn primitive sort items less +Sort the sequence @var{items}, which may be a list or a +vector. @var{less} is used for comparing the sequence +elements. This is not a stable sort. +@end deffn + + stable-sort! +@c snarfed from sort.c:847 +@deffn primitive stable-sort! items less +Sort the sequence @var{items}, which may be a list or a +vector. @var{less} is used for comparing the sequence elements. +The sorting is destructive, that means that the input sequence +is modified to produce the sorted result. +This is a stable sort. +@end deffn + + stable-sort +@c snarfed from sort.c:887 +@deffn primitive stable-sort items less +Sort the sequence @var{items}, which may be a list or a +vector. @var{less} is used for comparing the sequence elements. +This is a stable sort. +@end deffn + + sort-list! +@c snarfed from sort.c:933 +@deffn primitive sort-list! items less +Sort the list @var{items}, using @var{less} for comparing the +list elements. The sorting is destructive, that means that the +input list is modified to produce the sorted result. +This is a stable sort. +@end deffn + + sort-list +@c snarfed from sort.c:947 +@deffn primitive sort-list items less +Sort the list @var{items}, using @var{less} for comparing the +list elements. This is a stable sort. +@end deffn + + source-properties +@c snarfed from srcprop.c:171 +@deffn primitive source-properties obj +Return the source property association list of @var{obj}. +@end deffn + + set-source-properties! +@c snarfed from srcprop.c:194 +@deffn primitive set-source-properties! obj plist +Install the association list @var{plist} as the source property +list for @var{obj}. +@end deffn + + source-property +@c snarfed from srcprop.c:214 +@deffn primitive source-property obj key +Return the source property specified by @var{key} from +@var{obj}'s source property list. +@end deffn + + set-source-property! +@c snarfed from srcprop.c:247 +@deffn primitive set-source-property! obj key datum +Set the source property of object @var{obj}, which is specified by +@var{key} to @var{datum}. Normally, the key will be a symbol. +@end deffn + + stack? +@c snarfed from stacks.c:407 +@deffn primitive stack? obj +Return @code{#t} if @var{obj} is a calling stack. +@end deffn + + make-stack +@c snarfed from stacks.c:421 +@deffn primitive make-stack obj . args +Create a new stack. If @var{obj} is @code{#t}, the current +evaluation stack is used for creating the stack frames, +otherwise the frames are taken from @var{obj} (which must be +either a debug object or a continuation). +@var{args} must be a list if integers and specifies how the +resulting stack will be narrowed. +@end deffn + + stack-id +@c snarfed from stacks.c:512 +@deffn primitive stack-id stack +Return the identifier given to @var{stack} by @code{start-stack}. +@end deffn + + stack-ref +@c snarfed from stacks.c:548 +@deffn primitive stack-ref stack i +Return the @var{i}'th frame from @var{stack}. +@end deffn + + stack-length +@c snarfed from stacks.c:562 +@deffn primitive stack-length stack +Return the length of @var{stack}. +@end deffn + + frame? +@c snarfed from stacks.c:575 +@deffn primitive frame? obj +Return @code{#t} if @var{obj} is a stack frame. +@end deffn + + last-stack-frame +@c snarfed from stacks.c:586 +@deffn primitive last-stack-frame obj +Return a stack which consists of a single frame, which is the +last stack frame for @var{obj}. @var{obj} must be either a +debug object or a continuation. +@end deffn + + frame-number +@c snarfed from stacks.c:627 +@deffn primitive frame-number frame +Return the frame number of @var{frame}. +@end deffn + + frame-source +@c snarfed from stacks.c:637 +@deffn primitive frame-source frame +Return the source of @var{frame}. +@end deffn + + frame-procedure +@c snarfed from stacks.c:648 +@deffn primitive frame-procedure frame +Return the procedure for @var{frame}, or @code{#f} if no +procedure is associated with @var{frame}. +@end deffn + + frame-arguments +@c snarfed from stacks.c:660 +@deffn primitive frame-arguments frame +Return the arguments of @var{frame}. +@end deffn + + frame-previous +@c snarfed from stacks.c:671 +@deffn primitive frame-previous frame +Return the previous frame of @var{frame}, or @code{#f} if +@var{frame} is the first frame in its stack. +@end deffn + + frame-next +@c snarfed from stacks.c:687 +@deffn primitive frame-next frame +Return the next frame of @var{frame}, or @code{#f} if +@var{frame} is the last frame in its stack. +@end deffn + + frame-real? +@c snarfed from stacks.c:702 +@deffn primitive frame-real? frame +Return @code{#t} if @var{frame} is a real frame. +@end deffn + + frame-procedure? +@c snarfed from stacks.c:712 +@deffn primitive frame-procedure? frame +Return @code{#t} if a procedure is associated with @var{frame}. +@end deffn + + frame-evaluating-args? +@c snarfed from stacks.c:722 +@deffn primitive frame-evaluating-args? frame +Return @code{#t} if @var{frame} contains evaluated arguments. +@end deffn + + frame-overflow? +@c snarfed from stacks.c:732 +@deffn primitive frame-overflow? frame +Return @code{#t} if @var{frame} is an overflow frame. +@end deffn + + get-internal-real-time +@c snarfed from stime.c:141 +@deffn primitive get-internal-real-time +Returns the number of time units since the interpreter was started. +@end deffn + + times +@c snarfed from stime.c:183 +@deffn primitive times +Returns an object with information about real and processor time. +The following procedures accept such an object as an argument and +return a selected component: + +@table @code +@item tms:clock +The current real time, expressed as time units relative to an +arbitrary base. +@item tms:utime +The CPU time units used by the calling process. +@item tms:stime +The CPU time units used by the system on behalf of the calling process. +@item tms:cutime +The CPU time units used by terminated child processes of the calling +process, whose status has been collected (e.g., using @code{waitpid}). +@item tms:cstime +Similarly, the CPU times units used by the system on behalf of +terminated child processes. +@end table +@end deffn + + get-internal-run-time +@c snarfed from stime.c:214 +@deffn primitive get-internal-run-time +Returns the number of time units of processor time used by the interpreter. +Both "system" and "user" time are included but subprocesses are not. +@end deffn + + current-time +@c snarfed from stime.c:224 +@deffn primitive current-time +Returns the number of seconds since 1970-01-01 00:00:00 UTC, excluding +leap seconds. +@end deffn + + gettimeofday +@c snarfed from stime.c:241 +@deffn primitive gettimeofday +Returns a pair containing the number of seconds and microseconds since +1970-01-01 00:00:00 UTC, excluding leap seconds. Note: whether true +microsecond resolution is available depends on the operating system. +@end deffn + + localtime +@c snarfed from stime.c:341 +@deffn primitive localtime time [zone] +Returns an object representing the broken down components of @var{time}, +an integer like the one returned by @code{current-time}. The time zone +for the calculation is optionally specified by @var{zone} (a string), +otherwise the @code{TZ} environment variable or the system default is +used. +@end deffn + + gmtime +@c snarfed from stime.c:413 +@deffn primitive gmtime time +Returns an object representing the broken down components of @var{time}, +an integer like the one returned by @code{current-time}. The values +are calculated for UTC. +@end deffn + + mktime +@c snarfed from stime.c:475 +@deffn primitive mktime sbd_time [zone] +@var{bd-time} is an object representing broken down time and @code{zone} +is an optional time zone specifier (otherwise the TZ environment variable +or the system default is used). + +Returns a pair: the car is a corresponding +integer time value like that returned +by @code{current-time}; the cdr is a broken down time object, similar to +as @var{bd-time} but with normalized values. +@end deffn + + tzset +@c snarfed from stime.c:548 +@deffn primitive tzset +Initialize the timezone from the TZ environment variable +or the system default. It's not usually necessary to call this procedure +since it's done automatically by other procedures that depend on the +timezone. +@end deffn + + strftime +@c snarfed from stime.c:565 +@deffn primitive strftime format stime +Formats a time specification @var{time} using @var{template}. @var{time} +is an object with time components in the form returned by @code{localtime} +or @code{gmtime}. @var{template} is a string which can include formatting +specifications introduced by a @code{%} character. The formatting of +month and day names is dependent on the current locale. The value returned +is the formatted string. +@xref{Formatting Date and Time, , , libc, The GNU C Library Reference Manual}.) +@end deffn + + strptime +@c snarfed from stime.c:663 +@deffn primitive strptime format string +Performs the reverse action to @code{strftime}, parsing +@var{string} according to the specification supplied in +@var{template}. The interpretation of month and day names is +dependent on the current locale. The value returned is a pair. +The car has an object with time components +in the form returned by @code{localtime} or @code{gmtime}, +but the time zone components +are not usefully set. +The cdr reports the number of characters from @var{string} +which were used for the conversion. +@end deffn + + string? +@c snarfed from strings.c:62 +@deffn primitive string? obj +Returns @code{#t} iff @var{obj} is a string, else returns +@code{#f}. +@end deffn + + read-only-string? +@c snarfed from strings.c:85 +@deffn primitive read-only-string? obj +Return true if @var{obj} can be read as a string, + +This illustrates the difference between @code{string?} and +@code{read-only-string?}: + +@example +(string? "a string") @result{} #t +(string? 'a-symbol) @result{} #f + +(read-only-string? "a string") @result{} #t +(read-only-string? 'a-symbol) @result{} #t +@end example +@end deffn + + list->string +@c snarfed from strings.c:94 +@deffn primitive list->string +scm_string +@end deffn + + string +@c snarfed from strings.c:100 +@deffn primitive string . chrs +@deffnx primitive list->string chrs +Returns a newly allocated string composed of the arguments, +@var{chrs}. +@end deffn + + make-string +@c snarfed from strings.c:253 +@deffn primitive make-string k [chr] +Return a newly allocated string of +length @var{k}. If @var{chr} is given, then all elements of +the string are initialized to @var{chr}, otherwise the contents +of the @var{string} are unspecified. +@end deffn + + string-length +@c snarfed from strings.c:286 +@deffn primitive string-length string +Return the number of characters in @var{string}. +@end deffn + + string-ref +@c snarfed from strings.c:297 +@deffn primitive string-ref str k +Return character @var{k} of @var{str} using zero-origin +indexing. @var{k} must be a valid index of @var{str}. +@end deffn + + string-set! +@c snarfed from strings.c:314 +@deffn primitive string-set! str k chr +Store @var{chr} in element @var{k} of @var{str} and return +an unspecified value. @var{k} must be a valid index of +@var{str}. +@end deffn + + substring +@c snarfed from strings.c:337 +@deffn primitive substring str start [end] +Return a newly allocated string formed from the characters +of @var{str} beginning with index @var{start} (inclusive) and +ending with index @var{end} (exclusive). +@var{str} must be a string, @var{start} and @var{end} must be +exact integers satisfying: + +0 <= @var{start} <= @var{end} <= (string-length @var{str}). +@end deffn + + string-append +@c snarfed from strings.c:360 +@deffn primitive string-append . args +Return a newly allocated string whose characters form the +concatenation of the given strings, @var{args}. +@end deffn + + make-shared-substring +@c snarfed from strings.c:400 +@deffn primitive make-shared-substring str [frm [to]] +Return a shared substring of @var{str}. The semantics are the same as +for the @code{substring} function: the shared substring returned +includes all of the text from @var{str} between indexes @var{start} +(inclusive) and @var{end} (exclusive). If @var{end} is omitted, it +defaults to the end of @var{str}. The shared substring returned by +@code{make-shared-substring} occupies the same storage space as +@var{str}. +@end deffn + + string-index +@c snarfed from strop.c:120 +@deffn primitive string-index str chr [frm [to]] +Return the index of the first occurrence of @var{chr} in +@var{str}. The optional integer arguments @var{frm} and +@var{to} limit the search to a portion of the string. This +procedure essentially implements the @code{index} or +@code{strchr} functions from the C library.\n (qdocs:) Returns +the index of @var{char} in @var{str}, or @code{#f} if the +@var{char} isn't in @var{str}. If @var{frm} is given and not +@code{#f}, it is used as the starting index; if @var{to} is +given and not @code{#f}, it is used as the ending index +(exclusive). + +@example +(string-index "weiner" #\\e) +@result{} 1 + +(string-index "weiner" #\\e 2) +@result{} 4 + +(string-index "weiner" #\\e 2 4) +@result{} #f +@end example +@end deffn + + string-rindex +@c snarfed from strop.c:151 +@deffn primitive string-rindex str chr [frm [to]] +Like @code{string-index}, but search from the right of the string rather +than from the left. This procedure essentially implements the +@code{rindex} or @code{strrchr} functions from the C library. + +(qdocs:) The same as @code{string-index}, except it gives the rightmost occurance +of @var{char} in the range [@var{frm}, @var{to}-1], which defaults to +the entire string. + +@example +(string-rindex "weiner" #\\e) +@result{} 4 + +(string-rindex "weiner" #\\e 2 4) +@result{} #f + +(string-rindex "weiner" #\\e 2 5) +@result{} 4 +@end example +@end deffn + + substring-move-left! +@c snarfed from strop.c:168 +@deffn primitive substring-move-left! +scm_substring_move_x +@end deffn + + substring-move-right! +@c snarfed from strop.c:169 +@deffn primitive substring-move-right! +scm_substring_move_x +@end deffn + + substring-move! +@c snarfed from strop.c:243 +@deffn primitive substring-move! str1 start1 end1 str2 start2 +@deffnx primitive substring-move-left! str1 start1 end1 str2 start2 +@deffnx primitive substring-move-right! str1 start1 end1 str2 start2 +Copy the substring of @var{str1} bounded by @var{start1} and @var{end1} +into @var{str2} beginning at position @var{end2}. +@code{substring-move-right!} begins copying from the rightmost character +and moves left, and @code{substring-move-left!} copies from the leftmost +character moving right. + +It is useful to have two functions that copy in different directions so +that substrings can be copied back and forth within a single string. If +you wish to copy text from the left-hand side of a string to the +right-hand side of the same string, and the source and destination +overlap, you must be careful to copy the rightmost characters of the +text first, to avoid clobbering your data. Hence, when @var{str1} and +@var{str2} are the same string, you should use +@code{substring-move-right!} when moving text from left to right, and +@code{substring-move-left!} otherwise. If @code{str1} and @samp{str2} +are different strings, it does not matter which function you use. +@end deffn + + substring-fill! +@c snarfed from strop.c:279 +@deffn primitive substring-fill! str start end fill +Change every character in @var{str} between @var{start} and @var{end} to +@var{fill-char}. + +(qdocs:) Destructively fills @var{str}, from @var{start} to @var{end}, with @var{fill}. + +@example +(define y "abcdefg") +(substring-fill! y 1 3 #\\r) +y +@result{} "arrdefg" +@end example +@end deffn + + string-null? +@c snarfed from strop.c:306 +@deffn primitive string-null? str +Return @code{#t} if @var{str}'s length is nonzero, and @code{#f} +otherwise. + +(qdocs:) Returns @code{#t} if @var{str} is empty, else returns @code{#f}. + +@example +(string-null? "") +@result{} #t + +(string-null? y) +@result{} #f +@end example +@end deffn + + string->list +@c snarfed from strop.c:322 +@deffn primitive string->list str +@samp{String->list} returns a newly allocated list of the +characters that make up the given string. @samp{List->string} +returns a newly allocated string formed from the characters in the list +@var{list}, which must be a list of characters. @samp{String->list} +and @samp{list->string} are +inverses so far as @samp{equal?} is concerned. (r5rs) +@end deffn + + string-copy +@c snarfed from strop.c:347 +@deffn primitive string-copy str +Returns a newly allocated copy of the given @var{string}. (r5rs) +@end deffn + + string-fill! +@c snarfed from strop.c:360 +@deffn primitive string-fill! str chr +Stores @var{char} in every element of the given @var{string} and returns an +unspecified value. (r5rs) +@end deffn + + string-upcase! +@c snarfed from strop.c:396 +@deffn primitive string-upcase! str +Destructively upcase every character in @code{str}. + +(qdocs:) Converts each element in @var{str} to upper case. + +@example +(string-upcase! y) +@result{} "ARRDEFG" + +y +@result{} "ARRDEFG" +@end example +@end deffn + + string-upcase +@c snarfed from strop.c:408 +@deffn primitive string-upcase str +Upcase every character in @code{str}. +@end deffn + + string-downcase! +@c snarfed from strop.c:443 +@deffn primitive string-downcase! str +Destructively downcase every character in @code{str}. + +(qdocs:) Converts each element in @var{str} to lower case. + +@example +y +@result{} "ARRDEFG" + +(string-downcase! y) +@result{} "arrdefg" + +y +@result{} "arrdefg" +@end example +@end deffn + + string-downcase +@c snarfed from strop.c:455 +@deffn primitive string-downcase str +Downcase every character in @code{str}. +@end deffn + + string-capitalize! +@c snarfed from strop.c:492 +@deffn primitive string-capitalize! str +Destructively capitalize every character in @code{str}. +@end deffn + + string-capitalize +@c snarfed from strop.c:504 +@deffn primitive string-capitalize str +Capitalize every character in @code{str}. +@end deffn + + string-ci->symbol +@c snarfed from strop.c:516 +@deffn primitive string-ci->symbol str +Return the symbol whose name is @var{str}, downcased in necessary(???). +@end deffn + + string=? +@c snarfed from strorder.c:64 +@deffn primitive string=? s1 s2 +Lexicographic equality predicate; +Returns @code{#t} if the two strings are the same length and +contain the same characters in the same positions, otherwise +returns @code{#f}. (r5rs) + +The procedure @code{string-ci=?} treats upper and lower case +letters as though they were the same character, but +@code{string=?} treats upper and lower case as distinct +characters. +@end deffn + + string-ci=? +@c snarfed from strorder.c:99 +@deffn primitive string-ci=? s1 s2 +Case-insensitive string equality predicate; returns @code{#t} +if the two strings are the same length and their component +characters match (ignoring case) at each position; otherwise +returns @code{#f}. (r5rs) +@end deffn + + string? +@c snarfed from strorder.c:185 +@deffn primitive string>? s1 s2 +Lexicographic ordering predicate; returns @code{#t} if +@var{s1} is lexicographically greater than @var{s2}. (r5rs) +@end deffn + + string>=? +@c snarfed from strorder.c:200 +@deffn primitive string>=? s1 s2 +Lexicographic ordering predicate; returns @code{#t} if +@var{s1} is lexicographically greater than or equal to +@var{s2}. (r5rs) +@end deffn + + string-ci? +@c snarfed from strorder.c:269 +@deffn primitive string-ci>? s1 s2 +Case insensitive lexicographic ordering predicate; +returns @code{#t} if @var{s1} is lexicographically greater +than @var{s2} regardless of case. (r5rs) +@end deffn + + string-ci>=? +@c snarfed from strorder.c:284 +@deffn primitive string-ci>=? s1 s2 +Case insensitive lexicographic ordering predicate; +returns @code{#t} if @var{s1} is lexicographically greater +than or equal to @var{s2} regardless of case. (r5rs) +@end deffn + + object->string +@c snarfed from strports.c:318 +@deffn primitive object->string obj [printer] +Return a Scheme string obtained by printing @var{obj}. +Printing function can be specified by the optional second +argument @var{printer} (default: @code{write}). +@end deffn + + call-with-output-string +@c snarfed from strports.c:352 +@deffn primitive call-with-output-string proc +Calls the one-argument procedure @var{proc} with a newly created output +port. When the function returns, the string composed of the characters +written into the port is returned. +@end deffn + + call-with-input-string +@c snarfed from strports.c:371 +@deffn primitive call-with-input-string str proc +Calls the one-argument procedure @var{proc} with a newly created input +port from which @var{string}'s contents may be read. The value yielded +by the @var{proc} is returned. +@end deffn + + open-input-string +@c snarfed from strports.c:384 +@deffn primitive open-input-string str +Takes a string and returns an input port that delivers +characters from the string. The port can be closed by +@code{close-input-port}, though its storage will be reclaimed +by the garbage collector if it becomes inaccessible. +@end deffn + + open-output-string +@c snarfed from strports.c:398 +@deffn primitive open-output-string +Returns an output port that will accumulate characters for +retrieval by @code{get-output-string}. The port can be closed +by the procedure @code{close-output-port}, though its storage +will be reclaimed by the garbage collector if it becomes +inaccessible. +@end deffn + + get-output-string +@c snarfed from strports.c:415 +@deffn primitive get-output-string port +Given an output port created by @code{open-output-string}, +returns a string consisting of the characters that have been +output to the port so far. +@end deffn + + eval-string +@c snarfed from strports.c:456 +@deffn primitive eval-string string +Evaluate @var{string} as the text representation of a Scheme +form or forms, and return whatever value they produce. +Evaluation takes place in the environment returned by the +procedure @code{interaction-environment}. +@end deffn + + make-struct-layout +@c snarfed from struct.c:79 +@deffn primitive make-struct-layout fields +Return a new structure layout object. + +@var{fields} must be a string made up of pairs of characters +strung together. The first character of each pair describes a field +type, the second a field protection. Allowed types are 'p' for +GC-protected Scheme data, 'u' for unprotected binary data, and 's' for +a field that points to the structure itself. Allowed protections +are 'w' for mutable fields, 'r' for read-only fields, and 'o' for opaque +fields. The last field protection specification may be capitalized to +indicate that the field is a tail-array. +@end deffn + + struct? +@c snarfed from struct.c:246 +@deffn primitive struct? x +Return @code{#t} iff @var{obj} is a structure object, else +@code{#f}. +@end deffn + + struct-vtable? +@c snarfed from struct.c:255 +@deffn primitive struct-vtable? x +Return @code{#t} iff obj is a vtable structure. +@end deffn + + make-struct +@c snarfed from struct.c:437 +@deffn primitive make-struct vtable tail_array_size . init +Create a new structure. + +@var{type} must be a vtable structure (@pxref{Vtables}). + +@var{tail-elts} must be a non-negative integer. If the layout +specification indicated by @var{type} includes a tail-array, +this is the number of elements allocated to that array. + +The @var{init1}, @dots{} are optional arguments describing how +successive fields of the structure should be initialized. Only fields +with protection 'r' or 'w' can be initialized, except for fields of +type 's', which are automatically initialized to point to the new +structure itself; fields with protection 'o' can not be initialized by +Scheme programs. + +If fewer optional arguments than initializable fields are supplied, +fields of type 'p' get default value #f while fields of type 'u' are +initialized to 0. + +Structs are currently the basic representation for record-like data +structures in Guile. The plan is to eventually replace them with a +new representation which will at the same time be easier to use and +more powerful. + +For more information, see the documentation for @code{make-vtable-vtable}. +@end deffn + + make-vtable-vtable +@c snarfed from struct.c:523 +@deffn primitive make-vtable-vtable user_fields tail_array_size . init +Return a new, self-describing vtable structure. + +@var{user-fields} is a string describing user defined fields of the +vtable beginning at index @code{vtable-offset-user} +(see @code{make-struct-layout}). + +@var{tail-size} specifies the size of the tail-array (if any) of +this vtable. + +@var{init1}, @dots{} are the optional initializers for the fields of +the vtable. + +Vtables have one initializable system field---the struct printer. +This field comes before the user fields in the initializers passed +to @code{make-vtable-vtable} and @code{make-struct}, and thus works as +a third optional argument to @code{make-vtable-vtable} and a fourth to +@code{make-struct} when creating vtables: + +If the value is a procedure, it will be called instead of the standard +printer whenever a struct described by this vtable is printed. +The procedure will be called with arguments STRUCT and PORT. + +The structure of a struct is described by a vtable, so the vtable is +in essence the type of the struct. The vtable is itself a struct with +a vtable. This could go on forever if it weren't for the +vtable-vtables which are self-describing vtables, and thus terminate +the chain. + +There are several potential ways of using structs, but the standard +one is to use three kinds of structs, together building up a type +sub-system: one vtable-vtable working as the root and one or several +"types", each with a set of "instances". (The vtable-vtable should be +compared to the class which is the class of itself.) + +@example +(define ball-root (make-vtable-vtable "pr" 0)) + +(define (make-ball-type ball-color) + (make-struct ball-root 0 + (make-struct-layout "pw") + (lambda (ball port) + (format port "#" + (color ball) + (owner ball))) + ball-color)) +(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user)) +(define (owner ball) (struct-ref ball 0)) + +(define red (make-ball-type 'red)) +(define green (make-ball-type 'green)) + +(define (make-ball type owner) (make-struct type 0 owner)) + +(define ball (make-ball green 'Nisse)) +ball @result{} # +@end example +@end deffn + + struct-ref +@c snarfed from struct.c:565 +@deffn primitive struct-ref handle pos +@deffnx primitive struct-set! struct n value +Access (or modify) the @var{n}th field of @var{struct}. + +If the field is of type 'p', then it can be set to an arbitrary value. + +If the field is of type 'u', then it can only be set to a non-negative +integer value small enough to fit in one machine word. +@end deffn + + struct-set! +@c snarfed from struct.c:643 +@deffn primitive struct-set! handle pos val +Set the slot of the structure @var{handle} with index @var{pos} +to @var{val}. Signal an error if the slot can not be written +to. +@end deffn + + struct-vtable +@c snarfed from struct.c:713 +@deffn primitive struct-vtable handle +Return the vtable structure that describes the type of @var{struct}. +@end deffn + + struct-vtable-tag +@c snarfed from struct.c:724 +@deffn primitive struct-vtable-tag handle +Return the vtable tag of the structure @var{handle}. +@end deffn + + struct-vtable-name +@c snarfed from struct.c:763 +@deffn primitive struct-vtable-name vtable +Return the name of the vtable @var{vtable}. +@end deffn + + set-struct-vtable-name! +@c snarfed from struct.c:773 +@deffn primitive set-struct-vtable-name! vtable name +Set the name of the vtable @var{vtable} to @var{name}. +@end deffn + + symbol? +@c snarfed from symbols.c:422 +@deffn primitive symbol? obj +Returns @code{#t} if @var{obj} is a symbol, otherwise returns +@code{#f}. (r5rs) +@end deffn + + symbol->string +@c snarfed from symbols.c:451 +@deffn primitive symbol->string s +Returns the name of @var{symbol} as a string. If the symbol +was part of an object returned as the value of a literal +expression (section @pxref{Literal expressions,,,r4rs, The +Revised^4 Report on Scheme}) or by a call to the @code{read} +procedure, and its name contains alphabetic characters, then +the string returned will contain characters in the +implementation's preferred standard case---some implementations +will prefer upper case, others lower case. If the symbol was +returned by @code{string->symbol}, the case of characters in +the string returned will be the same as the case in the string +that was passed to @code{string->symbol}. It is an error to +apply mutation procedures like @code{string-set!} to strings +returned by this procedure. (r5rs) + +The following examples assume that the implementation's +standard case is lower case: + +@lisp +(symbol->string 'flying-fish) @result{} "flying-fish" +(symbol->string 'Martin) @result{} "martin" +(symbol->string + (string->symbol "Malvina")) @result{} "Malvina" +@end lisp +@end deffn + + string->symbol +@c snarfed from symbols.c:478 +@deffn primitive string->symbol s +Returns the symbol whose name is @var{string}. This procedure +can create symbols with names containing special characters or +letters in the non-standard case, but it is usually a bad idea +to create such because in some implementations of Scheme they +cannot be read as themselves. See @code{symbol->string}. + +The following examples assume that the implementation's +standard case is lower case: + +@lisp +(eq? 'mISSISSIppi 'mississippi) @result{} #t +(string->symbol "mISSISSIppi") @result{} @r{the symbol with name "mISSISSIppi"} +(eq? 'bitBlt (string->symbol "bitBlt")) @result{} #f +(eq? 'JollyWog + (string->symbol (symbol->string 'JollyWog))) @result{} #t +(string=? "K. Harper, M.D." + (symbol->string + (string->symbol "K. Harper, M.D."))) @result{}#t +@end lisp +@end deffn + + string->obarray-symbol +@c snarfed from symbols.c:499 +@deffn primitive string->obarray-symbol o s [softp] +Intern a new symbol in @var{obarray}, a symbol table, with name +@var{string}. + +If @var{obarray} is @code{#f}, use the default system symbol table. If +@var{obarray} is @code{#t}, the symbol should not be interned in any +symbol table; merely return the pair (@var{symbol} +. @var{#}). + +The @var{soft?} argument determines whether new symbol table entries +should be created when the specified symbol is not already present in +@var{obarray}. If @var{soft?} is specified and is a true value, then +new entries should not be added for symbols not already present in the +table; instead, simply return @code{#f}. +@end deffn + + intern-symbol +@c snarfed from symbols.c:531 +@deffn primitive intern-symbol o s +Add a new symbol to @var{obarray} with name @var{string}, bound to an +unspecified initial value. The symbol table is not modified if a symbol +with this name is already present. +@end deffn + + unintern-symbol +@c snarfed from symbols.c:568 +@deffn primitive unintern-symbol o s +Remove the symbol with name @var{string} from @var{obarray}. This +function returns @code{#t} if the symbol was present and @code{#f} +otherwise. +@end deffn + + symbol-binding +@c snarfed from symbols.c:609 +@deffn primitive symbol-binding o s +Look up in @var{obarray} the symbol whose name is @var{string}, and +return the value to which it is bound. If @var{obarray} is @code{#f}, +use the global symbol table. If @var{string} is not interned in +@var{obarray}, an error is signalled. +@end deffn + + symbol-interned? +@c snarfed from symbols.c:626 +@deffn primitive symbol-interned? o s +Return @code{#t} if @var{obarray} contains a symbol with name +@var{string}, and @code{#f} otherwise. +@end deffn + + symbol-bound? +@c snarfed from symbols.c:649 +@deffn primitive symbol-bound? o s +Return @code{#t} if @var{obarray} contains a symbol with name +@var{string} bound to a defined value. This differs from +@var{symbol-interned?} in that the mere mention of a symbol +usually causes it to be interned; @code{symbol-bound?} +determines whether a symbol has been given any meaningful +value. +@end deffn + + symbol-set! +@c snarfed from symbols.c:667 +@deffn primitive symbol-set! o s v +Find the symbol in @var{obarray} whose name is @var{string}, and rebind +it to @var{value}. An error is signalled if @var{string} is not present +in @var{obarray}. +@end deffn + + symbol-fref +@c snarfed from symbols.c:684 +@deffn primitive symbol-fref s +Return the contents of @var{symbol}'s @dfn{function slot}. +@end deffn + + symbol-pref +@c snarfed from symbols.c:695 +@deffn primitive symbol-pref s +Return the @dfn{property list} currently associated with @var{symbol}. +@end deffn + + symbol-fset! +@c snarfed from symbols.c:706 +@deffn primitive symbol-fset! s val +Change the binding of @var{symbol}'s function slot. +@end deffn + + symbol-pset! +@c snarfed from symbols.c:718 +@deffn primitive symbol-pset! s val +Change the binding of @var{symbol}'s property slot. +@end deffn + + symbol-hash +@c snarfed from symbols.c:732 +@deffn primitive symbol-hash symbol +Return a hash value for @var{symbol}. +@end deffn + + builtin-bindings +@c snarfed from symbols.c:769 +@deffn primitive builtin-bindings +Create and return a copy of the global symbol table, removing all +unbound symbols. +@end deffn + + gensym +@c snarfed from symbols.c:790 +@deffn primitive 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 @code{g}. The counter +is increased by 1 at each call. There is no provision for +resetting the counter. +@end deffn + + gentemp +@c snarfed from symbols.c:829 +@deffn primitive gentemp [prefix [obarray]] +Create a new symbol with a name unique in an obarray. +The name is constructed from an optional string @var{prefix} +and a counter value. The default prefix is @code{t}. The +@var{obarray} is specified as a second optional argument. +Default is the system obarray where all normal symbols are +interned. The counter is increased by 1 at each +call. There is no provision for resetting the counter. +@end deffn + + tag +@c snarfed from tag.c:98 +@deffn primitive tag x +Return an integer corresponding to the type of X. Deprecated. +@end deffn + + catch +@c snarfed from throw.c:529 +@deffn primitive catch tag thunk handler +Invoke @var{thunk} in the dynamic context of @var{handler} for +exceptions matching @var{key}. If thunk throws to the symbol @var{key}, +then @var{handler} is invoked this way: + +@example +(handler key args ...) +@end example + +@var{key} is a symbol or #t. + +@var{thunk} takes no arguments. If @var{thunk} returns normally, that +is the return value of @code{catch}. + +Handler is invoked outside the scope of its own @code{catch}. If +@var{handler} again throws to the same key, a new handler from further +up the call chain is invoked. + +If the key is @code{#t}, then a throw to @emph{any} symbol will match +this call to @code{catch}. +@end deffn + + lazy-catch +@c snarfed from throw.c:556 +@deffn primitive lazy-catch tag thunk handler +This behaves exactly like @code{catch}, except that it does +not unwind the stack (this is the major difference), and if +handler returns, its value is returned from the throw. +@end deffn + + throw +@c snarfed from throw.c:589 +@deffn primitive throw key . args +Invoke the catch form matching @var{key}, passing @var{args} to the +@var{handler}. + +@var{key} is a symbol. It will match catches of the same symbol or of +#t. + +If there is no handler at all, an error is signaled. +@end deffn + + uniform-vector-length +@c snarfed from unif.c:255 +@deffn primitive uniform-vector-length v +Returns the number of elements in @var{uve}. +@end deffn + + array? +@c snarfed from unif.c:289 +@deffn primitive array? v [prot] +Returns @code{#t} if the @var{obj} is an array, and @code{#f} if not. + +The @var{prototype} argument is used with uniform arrays and is described +elsewhere. +@end deffn + + array-rank +@c snarfed from unif.c:360 +@deffn primitive array-rank ra +Returns the number of dimensions of @var{obj}. If @var{obj} is not an +array, @code{0} is returned. +@end deffn + + array-dimensions +@c snarfed from unif.c:398 +@deffn primitive array-dimensions ra +@code{Array-dimensions} is similar to @code{array-shape} but replaces +elements with a @code{0} minimum with one greater than the maximum. So: +@example +(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5) +@end example +@end deffn + + shared-array-root +@c snarfed from unif.c:445 +@deffn primitive shared-array-root ra +Return the root vector of a shared array. +@end deffn + + shared-array-offset +@c snarfed from unif.c:456 +@deffn primitive shared-array-offset ra +Return the root vector index of the first element in the array. +@end deffn + + shared-array-increments +@c snarfed from unif.c:467 +@deffn primitive shared-array-increments ra +For each dimension, return the distance between elements in the root vector. +@end deffn + + dimensions->uniform-array +@c snarfed from unif.c:586 +@deffn primitive dimensions->uniform-array dims prot [fill] +@deffnx primitive make-uniform-vector length prototype [fill] +Creates and returns a uniform array or vector of type corresponding to +@var{prototype} with dimensions @var{dims} or length @var{length}. If +@var{fill} is supplied, it's used to fill the array, otherwise +@var{prototype} is used. +@end deffn + + make-shared-array +@c snarfed from unif.c:672 +@deffn primitive make-shared-array oldra mapfunc . dims +@code{make-shared-array} can be used to create shared subarrays of other +arrays. The @var{mapper} is a function that translates coordinates in +the new array into coordinates in the old array. A @var{mapper} must be +linear, and its range must stay within the bounds of the old array, but +it can be otherwise arbitrary. A simple example: +@example +(define fred (make-array #f 8 8)) +(define freds-diagonal + (make-shared-array fred (lambda (i) (list i i)) 8)) +(array-set! freds-diagonal 'foo 3) +(array-ref fred 3 3) @result{} foo +(define freds-center + (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2)) +(array-ref freds-center 0 0) @result{} foo +@end example +@end deffn + + transpose-array +@c snarfed from unif.c:802 +@deffn primitive transpose-array ra . args +Returns an array sharing contents with @var{array}, but with dimensions +arranged in a different order. There must be one @var{dim} argument for +each dimension of @var{array}. @var{dim0}, @var{dim1}, @dots{} should +be integers between 0 and the rank of the array to be returned. Each +integer in that range must appear at least once in the argument list. + +The values of @var{dim0}, @var{dim1}, @dots{} correspond to dimensions +in the array to be returned, their positions in the argument list to +dimensions of @var{array}. Several @var{dim}s may have the same value, +in which case the returned array will have smaller rank than +@var{array}. + +examples: +@example +(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d)) +(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d) +(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{} + #2((a 4) (b 5) (c 6)) +@end example +@end deffn + + enclose-array +@c snarfed from unif.c:911 +@deffn primitive enclose-array ra . axes +@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than +the rank of @var{array}. @var{enclose-array} returns an array +resembling an array of shared arrays. The dimensions of each shared +array are the same as the @var{dim}th dimensions of the original array, +the dimensions of the outer array are the same as those of the original +array that did not match a @var{dim}. + +An enclosed array is not a general Scheme array. Its elements may not +be set using @code{array-set!}. Two references to the same element of +an enclosed array will be @code{equal?} but will not in general be +@code{eq?}. The value returned by @var{array-prototype} when given an +enclosed array is unspecified. + +examples: +@example +(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{} + # + +(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{} + # +@end example +@end deffn + + array-in-bounds? +@c snarfed from unif.c:994 +@deffn primitive array-in-bounds? v . args +Returns @code{#t} if its arguments would be acceptable to array-ref. +@end deffn + + array-ref +@c snarfed from unif.c:1073 +@deffn primitive array-ref +scm_uniform_vector_ref +@end deffn + + uniform-vector-ref +@c snarfed from unif.c:1079 +@deffn primitive uniform-vector-ref v args +@deffnx primitive array-ref v . args +Returns the element at the @code{(index1, index2)} element in @var{array}. +@end deffn + + uniform-array-set1! +@c snarfed from unif.c:1248 +@deffn primitive uniform-array-set1! +scm_array_set_x +@end deffn + + array-set! +@c snarfed from unif.c:1257 +@deffn primitive array-set! v obj . args +@deffnx primitive uniform-array-set1! v obj args +Sets the element at the @code{(index1, index2)} element in @var{array} to +@var{new-value}. The value returned by array-set! is unspecified. +@end deffn + + array-contents +@c snarfed from unif.c:1372 +@deffn primitive array-contents ra [strict] +@deffnx primitive array-contents array strict +If @var{array} may be @dfn{unrolled} into a one dimensional shared array +without changing their order (last subscript changing fastest), then +@code{array-contents} returns that shared array, otherwise it returns +@code{#f}. All arrays made by @var{make-array} and +@var{make-uniform-array} may be unrolled, some arrays made by +@var{make-shared-array} may not be. + +If the optional argument @var{strict} is provided, a shared array will +be returned only if its elements are stored internally contiguous in +memory. +@end deffn + + uniform-array-read! +@c snarfed from unif.c:1486 +@deffn primitive uniform-array-read! ra [port_or_fd [start [end]]] +@deffnx primitive uniform-vector-read! uve [port-or-fdes] [start] [end] +Attempts to read all elements of @var{ura}, in lexicographic order, as +binary objects from @var{port-or-fdes}. +If an end of file is encountered during +uniform-array-read! the objects up to that point only are put into @var{ura} +(starting at the beginning) and the remainder of the array is +unchanged. + +The optional arguments @var{start} and @var{end} allow +a specified region of a vector (or linearized array) to be read, +leaving the remainder of the vector unchanged. + +@code{uniform-array-read!} returns the number of objects read. +@var{port-or-fdes} may be omitted, in which case it defaults to the value +returned by @code{(current-input-port)}. +@end deffn + + uniform-array-write +@c snarfed from unif.c:1649 +@deffn primitive uniform-array-write v [port_or_fd [start [end]]] +@deffnx primitive uniform-vector-write uve [port-or-fdes] [start] [end] +Writes all elements of @var{ura} as binary objects to +@var{port-or-fdes}. + +The optional arguments @var{start} +and @var{end} allow +a specified region of a vector (or linearized array) to be written. + +The number of objects actually written is returned. +@var{port-or-fdes} may be +omitted, in which case it defaults to the value returned by +@code{(current-output-port)}. +@end deffn + + bit-count +@c snarfed from unif.c:1774 +@deffn primitive bit-count b bitvector +Returns the number of occurrences of the boolean @var{b} in +@var{bitvector}. +@end deffn + + bit-position +@c snarfed from unif.c:1813 +@deffn primitive bit-position item v k +Returns the minimum index of an occurrence of @var{bool} in @var{bv} +which is at least @var{k}. If no @var{bool} occurs within the specified +range @code{#f} is returned. +@end deffn + + bit-set*! +@c snarfed from unif.c:1881 +@deffn primitive bit-set*! v kv obj +If uve is a bit-vector @var{bv} and uve must be of the same +length. If @var{bool} is @code{#t}, uve is OR'ed into +@var{bv}; If @var{bool} is @code{#f}, the inversion of uve is +AND'ed into @var{bv}. + +If uve is a unsigned integer vector all the elements of uve +must be between 0 and the @code{length} of @var{bv}. The bits +of @var{bv} corresponding to the indexes in uve are set to +@var{bool}. The return value is unspecified. +@end deffn + + bit-count* +@c snarfed from unif.c:1935 +@deffn primitive bit-count* v kv obj +Returns +@example +(bit-count (bit-set*! (if bool bv (bit-invert! bv)) uve #t) #t). +@end example +@var{bv} is not modified. +@end deffn + + bit-invert! +@c snarfed from unif.c:1999 +@deffn primitive bit-invert! v +Modifies @var{bv} by replacing each element with its negation. +@end deffn + + array->list +@c snarfed from unif.c:2077 +@deffn primitive array->list v +Returns a list consisting of all the elements, in order, of @var{array}. +@end deffn + + list->uniform-array +@c snarfed from unif.c:2169 +@deffn primitive list->uniform-array ndim prot lst +@deffnx procedure list->uniform-vector prot lst +Returns a uniform array of the type indicated by prototype @var{prot} +with elements the same as those of @var{lst}. Elements must be of the +appropriate type, no coercions are done. +@end deffn + + array-prototype +@c snarfed from unif.c:2520 +@deffn primitive array-prototype ra +Returns an object that would produce an array of the same type as +@var{array}, if used as the @var{prototype} for +@code{make-uniform-array}. +@end deffn + + values +@c snarfed from values.c:83 +@deffn primitive 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. +@end deffn + + call-with-values +@c snarfed from values.c:116 +@deffn primitive call-with-values producer consumer +Calls its @var{producer} argument with no values and a +continuation that, when passed some values, calls the +@var{consumer} procedure with those values as arguments. The +continuation for the call to @var{consumer} is the continuation +of the call to @code{call-with-values}. + +@example +(call-with-values (lambda () (values 4 5)) + (lambda (a b) b)) + ==> 5 + +@end example +@example +(call-with-values * -) ==> -1 +@end example +@end deffn + + make-variable +@c snarfed from variable.c:100 +@deffn primitive make-variable init [name_hint] +Return a variable object initialized to value @var{init}. +If given, uses @var{name-hint} as its internal (debugging) +name, otherwise just treat it as an anonymous variable. +Remember, of course, that multiple bindings to the same +variable may exist, so @var{name-hint} is just that---a hint. +@end deffn + + make-undefined-variable +@c snarfed from variable.c:124 +@deffn primitive make-undefined-variable [name_hint] +Return a variable object initialized to an undefined value. +If given, uses @var{name-hint} as its internal (debugging) +name, otherwise just treat it as an anonymous variable. +Remember, of course, that multiple bindings to the same +variable may exist, so @var{name-hint} is just that---a hint. +@end deffn + + variable? +@c snarfed from variable.c:145 +@deffn primitive variable? obj +Return @code{#t} iff @var{obj} is a variable object, else +return @code{#f} +@end deffn + + variable-ref +@c snarfed from variable.c:157 +@deffn primitive variable-ref var +Dereference @var{var} and return its value. +@var{var} must be a variable object; see @code{make-variable} +and @code{make-undefined-variable}. +@end deffn + + variable-set! +@c snarfed from variable.c:171 +@deffn primitive variable-set! var val +Set the value of the variable @var{var} to @var{val}. +@var{var} must be a variable object, @var{val} can be any +value. Return an unspecified value. +@end deffn + + builtin-variable +@c snarfed from variable.c:185 +@deffn primitive builtin-variable name +Return the built-in variable with the name @var{name}. +@var{name} must be a symbol (not a string). +Then use @code{variable-ref} to access its value. +@end deffn + + variable-bound? +@c snarfed from variable.c:213 +@deffn primitive variable-bound? var +Return @code{#t} iff @var{var} is bound to a value. +Throws an error if @var{var} is not a variable object. +@end deffn + + vector? +@c snarfed from vectors.c:142 +@deffn primitive vector? obj +Returns @code{#t} if @var{obj} is a vector, otherwise returns +@code{#f}. (r5rs) +@end deffn + + list->vector +@c snarfed from vectors.c:161 +@deffn primitive list->vector +scm_vector +@end deffn + + vector +@c snarfed from vectors.c:177 +@deffn primitive vector . l +@deffnx primitive list->vector l +Returns a newly allocated vector whose elements contain the +given arguments. Analogous to @code{list}. (r5rs) + +@lisp +(vector 'a 'b 'c) @result{} #(a b c) +@end lisp +@end deffn + + make-vector +@c snarfed from vectors.c:255 +@deffn primitive make-vector k [fill] +Returns a newly allocated vector of @var{k} elements. If a second +argument is given, then each element is initialized to @var{fill}. +Otherwise the initial contents of each element is unspecified. (r5rs) +@end deffn + + vector->list +@c snarfed from vectors.c:311 +@deffn primitive vector->list v +@samp{Vector->list} returns a newly allocated list of the +objects contained in the elements of @var{vector}. (r5rs) + +@lisp +(vector->list '#(dah dah didah)) @result{} (dah dah didah) +(list->vector '(dididit dah)) @result{} #(dididit dah) +@end lisp +@end deffn + + vector-fill! +@c snarfed from vectors.c:328 +@deffn primitive vector-fill! v fill_x +Stores @var{fill} in every element of @var{vector}. +The value returned by @code{vector-fill!} is unspecified. (r5rs) +@end deffn + + vector-move-left! +@c snarfed from vectors.c:355 +@deffn primitive vector-move-left! vec1 start1 end1 vec2 start2 +Vector version of @code{substring-move-left!}. +@end deffn + + vector-move-right! +@c snarfed from vectors.c:378 +@deffn primitive vector-move-right! vec1 start1 end1 vec2 start2 +Vector version of @code{substring-move-right!}. +@end deffn + + major-version +@c snarfed from version.c:59 +@deffn primitive major-version +Return a string containing Guile's major version number. +E.g., "1". +@end deffn + + minor-version +@c snarfed from version.c:71 +@deffn primitive minor-version +Return a string containing Guile's minor version number. +E.g., "3.5". +@end deffn + + version +@c snarfed from version.c:90 +@deffn primitive version +@deffnx primitive major-version +@deffnx primitive minor-version +Return a string describing Guile's version number, or its major or minor +version numbers, respectively. + +@example +(version) @result{} "1.3a" +(major-version) @result{} "1" +(minor-version) @result{} "3a" +@end example +@end deffn + + make-soft-port +@c snarfed from vports.c:184 +@deffn primitive make-soft-port pv modes +Returns a port capable of receiving or delivering characters as +specified by the @var{modes} string (@pxref{File Ports, +open-file}). @var{vector} must be a vector of length 6. Its components +are as follows: + +@enumerate 0 +@item +procedure accepting one character for output +@item +procedure accepting a string for output +@item +thunk for flushing output +@item +thunk for getting one character +@item +thunk for closing port (not by garbage collection) +@end enumerate + +For an output-only port only elements 0, 1, 2, and 4 need be +procedures. For an input-only port only elements 3 and 4 need be +procedures. Thunks 2 and 4 can instead be @code{#f} if there is no useful +operation for them to perform. + +If thunk 3 returns @code{#f} or an @code{eof-object} (@pxref{Input, +eof-object?, ,r4rs, The Revised^4 Report on Scheme}) it indicates that +the port has reached end-of-file. For example: + +@example +(define stdout (current-output-port)) +(define p (make-soft-port + (vector + (lambda (c) (write c stdout)) + (lambda (s) (display s stdout)) + (lambda () (display "." stdout)) + (lambda () (char-upcase (read-char))) + (lambda () (display "@@" stdout))) + "rw")) + +(write p p) @result{} # +@end example +@end deffn + + make-weak-vector +@c snarfed from weaks.c:62 +@deffn primitive make-weak-vector k [fill] +Return a weak vector with @var{size} elements. If the optional +argument @var{fill} is given, all entries in the vector will be set to +@var{fill}. The default value for @var{fill} is the empty list. +@end deffn + + list->weak-vector +@c snarfed from weaks.c:79 +@deffn primitive list->weak-vector +scm_weak_vector +@end deffn + + weak-vector +@c snarfed from weaks.c:87 +@deffn primitive weak-vector . l +@deffnx primitive list->weak-vector l +Construct a weak vector from a list: @code{weak-vector} uses the list of +its arguments while @code{list->weak-vector} uses its only argument +@var{l} (a list) to construct a weak vector the same way +@code{vector->list} would. +@end deffn + + weak-vector? +@c snarfed from weaks.c:110 +@deffn primitive weak-vector? x +Return @code{#t} if @var{obj} is a weak vector. Note that all +weak hashes are also weak vectors. +@end deffn + + make-weak-key-hash-table +@c snarfed from weaks.c:130 +@deffn primitive make-weak-key-hash-table k +@deffnx primitive make-weak-value-hash-table size +@deffnx primitive make-doubly-weak-hash-table size +Return a weak hash table with @var{size} buckets. As with any hash +table, choosing a good size for the table requires some caution. + +You can modify weak hash tables in exactly the same way you would modify +regular hash tables. (@pxref{Hash Tables}) +@end deffn + + make-weak-value-hash-table +@c snarfed from weaks.c:147 +@deffn primitive make-weak-value-hash-table k +Return a hash table with weak values with @var{size} buckets. +(@pxref{Hash Tables}) +@end deffn + + make-doubly-weak-hash-table +@c snarfed from weaks.c:165 +@deffn primitive make-doubly-weak-hash-table k +Return a hash table with weak keys and values with @var{size} +buckets. (@pxref{Hash Tables}) +@end deffn + + weak-key-hash-table? +@c snarfed from weaks.c:184 +@deffn primitive weak-key-hash-table? x +@deffnx primitive weak-value-hash-table? obj +@deffnx primitive doubly-weak-hash-table? obj +Return @code{#t} if @var{obj} is the specified weak hash +table. Note that a doubly weak hash table is neither a weak key +nor a weak value hash table. +@end deffn + + weak-value-hash-table? +@c snarfed from weaks.c:194 +@deffn primitive weak-value-hash-table? x +Return @code{#t} if @var{x} is a weak value hash table. +@end deffn + + doubly-weak-hash-table? +@c snarfed from weaks.c:204 +@deffn primitive doubly-weak-hash-table? x +Return @code{#t} if @var{x} is a doubly weak hash table. +@end deffn diff --git a/doc/new-docstrings.texi b/doc/new-docstrings.texi new file mode 100644 index 000000000..1626e9e6a --- /dev/null +++ b/doc/new-docstrings.texi @@ -0,0 +1,599 @@ + +@c module (guile) + +@deffn primitive environment? obj +Return @code{#t} if @var{obj} is an environment, or @code{#f} +otherwise. +@end deffn + +@deffn primitive environment-bound? env sym +Return @code{#t} if @var{sym} is bound in @var{env}, or +@code{#f} otherwise. +@end deffn + +@deffn primitive environment-ref env sym +Return the value of the location bound to @var{sym} in +@var{env}. If @var{sym} is unbound in @var{env}, signal an +@code{environment:unbound} error. +@end deffn + +@deffn primitive environment-fold env proc init +Iterate over all the bindings in @var{env}, accumulating some +value. +For each binding in @var{env}, apply @var{proc} to the symbol +bound, its value, and the result from the previous application +of @var{proc}. +Use @var{init} as @var{proc}'s third argument the first time +@var{proc} is applied. +If @var{env} contains no bindings, this function simply returns +@var{init}. +If @var{env} binds the symbol sym1 to the value val1, sym2 to +val2, and so on, then this procedure computes: +@example + (proc sym1 val1 + (proc sym2 val2 + ... + (proc symn valn + init))) +@end example +Each binding in @var{env} will be processed exactly once. +@code{environment-fold} makes no guarantees about the order in +which the bindings are processed. +Here is a function which, given an environment, constructs an +association list representing that environment's bindings, +using environment-fold: +@example + (define (environment->alist env) + (environment-fold env + (lambda (sym val tail) + (cons (cons sym val) tail)) + '())) +@end example +@end deffn + +@deffn primitive environment-define env sym val +Bind @var{sym} to a new location containing @var{val} in +@var{env}. If @var{sym} is already bound to another location +in @var{env} and the binding is mutable, that binding is +replaced. The new binding and location are both mutable. The +return value is unspecified. +If @var{sym} is already bound in @var{env}, and the binding is +immutable, signal an @code{environment:immutable-binding} error. +@end deffn + +@deffn primitive environment-undefine env sym +Remove any binding for @var{sym} from @var{env}. If @var{sym} +is unbound in @var{env}, do nothing. The return value is +unspecified. +If @var{sym} is already bound in @var{env}, and the binding is +immutable, signal an @code{environment:immutable-binding} error. +@end deffn + +@deffn primitive environment-set! env sym val +If @var{env} binds @var{sym} to some location, change that +location's value to @var{val}. The return value is +unspecified. +If @var{sym} is not bound in @var{env}, signal an +@code{environment:unbound} error. If @var{env} binds @var{sym} +to an immutable location, signal an +@code{environment:immutable-location} error. +@end deffn + +@deffn primitive environment-cell env sym for_write +Return the value cell which @var{env} binds to @var{sym}, or +@code{#f} if the binding does not live in a value cell. +The argument @var{for-write} indicates whether the caller +intends to modify the variable's value by mutating the value +cell. If the variable is immutable, then +@code{environment-cell} signals an +@code{environment:immutable-location} error. +If @var{sym} is unbound in @var{env}, signal an +@code{environment:unbound} error. +If you use this function, you should consider using +@code{environment-observe}, to be notified when @var{sym} gets +re-bound to a new value cell, or becomes undefined. +@end deffn + +@deffn primitive environment-observe env proc +Whenever @var{env}'s bindings change, apply @var{proc} to +@var{env}. +This function returns an object, token, which you can pass to +@code{environment-unobserve} to remove @var{proc} from the set +of procedures observing @var{env}. The type and value of +token is unspecified. +@end deffn + +@deffn primitive environment-observe-weak env proc +This function is the same as environment-observe, except that +the reference @var{env} retains to @var{proc} is a weak +reference. This means that, if there are no other live, +non-weak references to @var{proc}, it will be +garbage-collected, and dropped from @var{env}'s +list of observing procedures. +@end deffn + +@deffn primitive environment-unobserve token +Cancel the observation request which returned the value +@var{token}. The return value is unspecified. +If a call @code{(environment-observe env proc)} returns +@var{token}, then the call @code{(environment-unobserve token)} +will cause @var{proc} to no longer be called when @var{env}'s +bindings change. +@end deffn + +@deffn primitive make-leaf-environment +Create a new leaf environment, containing no bindings. +All bindings and locations created in the new environment +will be mutable. +@end deffn + +@deffn primitive leaf-environment? object +Return @code{#t} if object is a leaf environment, or @code{#f} +otherwise. +@end deffn + +@deffn primitive make-eval-environment local imported +Return a new environment object eval whose bindings are the +union of the bindings in the environments @var{local} and +@var{imported}, with bindings from @var{local} taking +precedence. Definitions made in eval are placed in @var{local}. +Applying @code{environment-define} or +@code{environment-undefine} to eval has the same effect as +applying the procedure to @var{local}. +Note that eval incorporates @var{local} and @var{imported} by +reference: +If, after creating eval, the program changes the bindings of +@var{local} or @var{imported}, those changes will be visible +in eval. +Since most Scheme evaluation takes place in eval environments, +they transparently cache the bindings received from @var{local} +and @var{imported}. Thus, the first time the program looks up +a symbol in eval, eval may make calls to @var{local} or +@var{imported} to find their bindings, but subsequent +references to that symbol will be as fast as references to +bindings in finite environments. +In typical use, @var{local} will be a finite environment, and +@var{imported} will be an import environment +@end deffn + +@deffn primitive eval-environment? object +Return @code{#t} if object is an eval environment, or @code{#f} +otherwise. +@end deffn + +@deffn primitive eval-environment-local env +Return the local environment of eval environment @var{env}. +@end deffn + +@deffn primitive eval-environment-set-local! env local +Change @var{env}'s local environment to @var{local}. +@end deffn + +@deffn primitive eval-environment-imported env +Return the imported environment of eval environment @var{env}. +@end deffn + +@deffn primitive eval-environment-set-imported! env imported +Change @var{env}'s imported environment to @var{imported}. +@end deffn + +@deffn primitive make-import-environment imports conflict_proc +Return a new environment @var{imp} whose bindings are the union +of the bindings from the environments in @var{imports}; +@var{imports} must be a list of environments. That is, +@var{imp} binds a symbol to a location when some element of +@var{imports} does. +If two different elements of @var{imports} have a binding for +the same symbol, the @var{conflict-proc} is called with the +following parameters: the import environment, the symbol and +the list of the imported environments that bind the symbol. +If the @var{conflict-proc} returns an environment @var{env}, +the conflict is considered as resolved and the binding from +@var{env} is used. If the @var{conflict-proc} returns some +non-environment object, the conflict is considered unresolved +and the symbol is treated as unspecified in the import +environment. +The checking for conflicts may be performed lazily, i. e. at +the moment when a value or binding for a certain symbol is +requested instead of the moment when the environment is +created or the bindings of the imports change. +All bindings in @var{imp} are immutable. If you apply +@code{environment-define} or @code{environment-undefine} to +@var{imp}, Guile will signal an + @code{environment:immutable-binding} error. However, +notice that the set of bindings in @var{imp} may still change, +if one of its imported environments changes. +@end deffn + +@deffn primitive import-environment? object +Return @code{#t} if object is an import environment, or +@code{#f} otherwise. +@end deffn + +@deffn primitive import-environment-imports env +Return the list of environments imported by the import +environment @var{env}. +@end deffn + +@deffn primitive import-environment-set-imports! env imports +Change @var{env}'s list of imported environments to +@var{imports}, and check for conflicts. +@end deffn + +@deffn primitive make-export-environment private signature +Return a new environment @var{exp} containing only those +bindings in private whose symbols are present in +@var{signature}. The @var{private} argument must be an +environment. + +The environment @var{exp} binds symbol to location when +@var{env} does, and symbol is exported by @var{signature}. + +@var{signature} is a list specifying which of the bindings in +@var{private} should be visible in @var{exp}. Each element of +@var{signature} should be a list of the form: + (symbol attribute ...) +where each attribute is one of the following: +@table @asis +@item the symbol @code{mutable-location} + @var{exp} should treat the + location bound to symbol as mutable. That is, @var{exp} + will pass calls to @code{environment-set!} or + @code{environment-cell} directly through to private. +@item the symbol @code{immutable-location} + @var{exp} should treat + the location bound to symbol as immutable. If the program + applies @code{environment-set!} to @var{exp} and symbol, or + calls @code{environment-cell} to obtain a writable value + cell, @code{environment-set!} will signal an + @code{environment:immutable-location} error. Note that, even + if an export environment treats a location as immutable, the + underlying environment may treat it as mutable, so its + value may change. +@end table +It is an error for an element of signature to specify both +@code{mutable-location} and @code{immutable-location}. If +neither is specified, @code{immutable-location} is assumed. + +As a special case, if an element of signature is a lone +symbol @var{sym}, it is equivalent to an element of the form +@code{(sym)}. + +All bindings in @var{exp} are immutable. If you apply +@code{environment-define} or @code{environment-undefine} to +@var{exp}, Guile will signal an +@code{environment:immutable-binding} error. However, +notice that the set of bindings in @var{exp} may still change, +if the bindings in private change. +@end deffn + +@deffn primitive export-environment? object +Return @code{#t} if object is an export environment, or +@code{#f} otherwise. +@end deffn + +@deffn primitive export-environment-private env +Return the private environment of export environment @var{env}. +@end deffn + +@deffn primitive export-environment-set-private! env private +Change the private environment of export environment @var{env}. +@end deffn + +@deffn primitive export-environment-signature env +Return the signature of export environment @var{env}. +@end deffn + +@deffn primitive export-environment-set-signature! env signature +Change the signature of export environment @var{env}. +@end deffn + +@deffn primitive %compute-slots class +Return a list consisting of the names of all slots belonging to +class @var{class}, i. e. the slots of @var{class} and of all of +its superclasses. +@end deffn + +@deffn primitive get-keyword key l default_value +Determine an associated value for the keyword @var{key} from +the list @var{l}. The list @var{l} has to consist of an even +number of elements, where, starting with the first, every +second element is a keyword, followed by its associated value. +If @var{l} does not hold a value for @var{key}, the value +@var{default_value} is returned. +@end deffn + +@deffn primitive slot-ref-using-class class obj slot_name +@end deffn + +@deffn primitive slot-set-using-class! class obj slot_name value +@end deffn + +@deffn primitive class-of x +Return the class of @var{x}. +@end deffn + +@deffn primitive %goops-loaded +Announce that GOOPS is loaded and perform initialization +on the C level which depends on the loaded GOOPS modules. +@end deffn + +@deffn primitive %method-more-specific? m1 m2 targs +@end deffn + +@deffn primitive find-method . l +@end deffn + +@deffn primitive primitive-generic-generic subr +@end deffn + +@deffn primitive enable-primitive-generic! . subrs +@end deffn + +@deffn primitive generic-capability? proc +@end deffn + +@deffn primitive %invalidate-method-cache! gf +@end deffn + +@deffn primitive %invalidate-class class +@end deffn + +@deffn primitive %modify-class old new +@end deffn + +@deffn primitive %modify-instance old new +@end deffn + +@deffn primitive %set-object-setter! obj setter +@end deffn + +@deffn primitive %allocate-instance class initargs +Create a new instance of class @var{class} and initialize it +from the arguments @var{initargs}. +@end deffn + +@deffn primitive slot-exists? obj slot_name +Return @code{#t} if @var{obj} has a slot named @var{slot_name}. +@end deffn + +@deffn primitive slot-bound? obj slot_name +Return @code{#t} if the slot named @var{slot_name} of @var{obj} +is bound. +@end deffn + +@deffn primitive slot-set! obj slot_name value +Set the slot named @var{slot_name} of @var{obj} to @var{value}. +@end deffn + +@deffn primitive slot-exists-using-class? class obj slot_name +@end deffn + +@deffn primitive slot-bound-using-class? class obj slot_name +@end deffn + +@deffn primitive %fast-slot-set! obj index value +Set the slot with index @var{index} in @var{obj} to +@var{value}. +@end deffn + +@deffn primitive %fast-slot-ref obj index +Return the slot value with index @var{index} from @var{obj}. +@end deffn + +@deffn primitive @@assert-bound-ref obj index +Like @code{assert-bound}, but use @var{index} for accessing +the value from @var{obj}. +@end deffn + +@deffn primitive assert-bound value obj +Return @var{value} if it is bound, and invoke the +@var{slot-unbound} method of @var{obj} if it is not. +@end deffn + +@deffn primitive unbound? obj +Return @code{#t} if @var{obj} is unbound. +@end deffn + +@deffn primitive make-unbound +Return the unbound value. +@end deffn + +@deffn primitive accessor-method-slot-definition obj +Return the slot definition of the accessor @var{obj}. +@end deffn + +@deffn primitive method-procedure obj +Return the procedure of the method @var{obj}. +@end deffn + +@deffn primitive method-specializers obj +Return specializers of the method @var{obj}. +@end deffn + +@deffn primitive method-generic-function obj +Return the generic function fot the method @var{obj}. +@end deffn + +@deffn primitive generic-function-methods obj +Return the methods of the generic function @var{obj}. +@end deffn + +@deffn primitive generic-function-name obj +Return the name of the generic function @var{obj}. +@end deffn + +@deffn primitive class-environment obj +Return the environment of the class @var{obj}. +@end deffn + +@deffn primitive class-slots obj +Return the slot list of the class @var{obj}. +@end deffn + +@deffn primitive class-precedence-list obj +Return the class precedence list of the class @var{obj}. +@end deffn + +@deffn primitive class-direct-methods obj +Return the direct methods of the class @var{obj} +@end deffn + +@deffn primitive class-direct-subclasses obj +Return the direct subclasses of the class @var{obj}. +@end deffn + +@deffn primitive class-direct-slots obj +Return the direct slots of the class @var{obj}. +@end deffn + +@deffn primitive class-direct-supers obj +Return the direct superclasses of the class @var{obj}. +@end deffn + +@deffn primitive class-name obj +Return the class name of @var{obj}. +@end deffn + +@deffn primitive instance? obj +Return @code{#t} if @var{obj} is an instance. +@end deffn + +@deffn primitive %inherit-magic! class dsupers +@end deffn + +@deffn primitive %prep-layout! class +@end deffn + +@deffn primitive %initialize-object obj initargs +Initialize the object @var{obj} with the given arguments +@var{initargs}. +@end deffn + +@deffn primitive make . args +Make a new object. @var{args} must contain the class and +all necessary initialization information. +@end deffn + +@deffn primitive slot-ref obj slot_name +Return the value from @var{obj}'s slot with the name +@var{slot_name}. +@end deffn + +@deffn primitive builtin-bindings +Create and return a copy of the global symbol table, removing all +unbound symbols. +@end deffn + +@deffn primitive object->string obj [printer] +Return a Scheme string obtained by printing @var{obj}. +Printing function can be specified by the optional second +argument @var{printer} (default: @code{write}). +@end deffn + +@deffn primitive gethostname +Return the host name of the current processor. +@end deffn + +@deffn primitive sethostname name +Set the host name of the current processor to @var{name}. May +only be used by the superuser. The return value is not +specified. +@end deffn + +@deffn primitive flock file operation +Apply or remove an advisory lock on an open file. +@var{operation} specifies the action to be done: +@table @code +@item LOCK_SH +Shared lock. More than one process may hold a shared lock +for a given file at a given time. +@item LOCK_EX +Exclusive lock. Only one process may hold an exclusive lock +for a given file at a given time. +@item LOCK_UN +Unlock the file. +@item LOCK_NB +Don't block when locking. May be specified by bitwise OR'ing +it to one of the other operations. +@end table +The return value is not specified. @var{file} may be an open +file descriptor or an open file descriptior port. +@end deffn + +@deffn primitive getpass prompt +Display @var{prompt} to the standard error output and read +a password from @file{/dev/tty}. If this file is not +accessible, it reads from standard input. The password may be +up to 127 characters in length. Additional characters and the +terminating newline character are discarded. While reading +the password, echoing and the generation of signals by special +characters is disabled. +@end deffn + +@deffn primitive setpriority which who prio +Set the scheduling priority of the process, process group +or user, as indicated by @var{which} and @var{who}. @var{which} +is one of the variables @code{PRIO_PROCESS}, @code{PRIO_PGRP} +or @code{PRIO_USER}, and @var{who} is interpreted relative to +@var{which} (a process identifier for @code{PRIO_PROCESS}, +process group identifier for @code{PRIO_PGRP}, and a user +identifier for @code{PRIO_USER}. A zero value of @var{who} +denotes the current process, process group, or user. +@var{prio} is a value in the range -20 and 20, the default +priority is 0; lower priorities cause more favorable +scheduling. Sets the priority of all of the specified +processes. Only the super-user may lower priorities. +The return value is not specified. +@end deffn + +@deffn primitive getpriority which who +Return the scheduling priority of the process, process group +or user, as indicated by @var{which} and @var{who}. @var{which} +is one of the variables @code{PRIO_PROCESS}, @code{PRIO_PGRP} +or @code{PRIO_USER}, and @var{who} is interpreted relative to +@var{which} (a process identifier for @code{PRIO_PROCESS}, +process group identifier for @code{PRIO_PGRP}, and a user +identifier for @code{PRIO_USER}. A zero value of @var{who} +denotes the current process, process group, or user. Return +the highest priority (lowest numerical value) of any of the +specified processes. +@end deffn + +@deffn primitive cuserid +Return a string containing a user name associated with the +effective user id of the process. Return @code{#f} if this +information cannot be obtained. +@end deffn + +@deffn primitive getlogin +Return a string containing the name of the user logged in on +the controlling terminal of the process, or @code{#f} if this +information cannot be obtained. +@end deffn + +@deffn primitive chroot path +Change the root directory to that specified in @var{path}. +This directory will be used for path names beginning with +@file{/}. The root directory is inherited by all children +of the current process. Only the superuser may change the +root directory. +@end deffn + +@deffn primitive crypt key salt +Encrypt @var{key} using @var{salt} as the salt value to the +crypt(3) library call +@end deffn + +@deffn primitive mkstemp! tmpl +mkstemp creates a new unique file in the file system and +returns a new buffered port open for reading and writing to +the file. @var{tmpl} is a string specifying where the +file should be created: it must end with @code{XXXXXX} +and will be changed in place to return the name of the +temporary file. +@end deffn + +@deffn primitive %tag-body body +Internal GOOPS magic---don't use this function! +@end deffn diff --git a/doc/posix.texi b/doc/posix.texi index 7a4cc8e40..fea735015 100644 --- a/doc/posix.texi +++ b/doc/posix.texi @@ -760,9 +760,11 @@ The return value is unspecified. @c docstring begin (texi-doc-string "guile" "tmpnam") @deffn primitive tmpnam -Create a new file in the file system with a unique name. The return -value is the name of the new file. This function is implemented with -the @code{tmpnam} function in the system libraries. +tmpnam returns a name in the file system that does not match +any existing file. However there is no guarantee that +another process will not create the file after tmpnam +is called. Care should be taken if opening the file, +e.g., use the O_EXCL open flag or use @code{mkstemp!} instead. @end deffn @c docstring begin (texi-doc-string "guile" "dirname") @@ -1469,8 +1471,8 @@ of seconds remaining otherwise. @c docstring begin (texi-doc-string "guile" "usleep") @deffn primitive usleep i -Sleep for I microseconds. -`usleep' is not available on all platforms. +Sleep for I microseconds. @code{usleep} is not available on +all platforms. @end deffn @node Terminals and Ptys diff --git a/doc/scheme-data.texi b/doc/scheme-data.texi index c69a5431c..7bbf89760 100755 --- a/doc/scheme-data.texi +++ b/doc/scheme-data.texi @@ -274,8 +274,8 @@ completely invisible to the Scheme level programmer. @c on the C level, where the conversion is not so automatic - NJ @c docstring begin (texi-doc-string "guile" "integer?") -@deffn primitive integer? obj -Return @code{#t} if @var{obj} is an integer number, @code{#f} else. +@deffn primitive integer? x +Return @code{#t} if @var{x} is an integer number, @code{#f} else. @lisp (integer? 487) @@ -343,11 +343,13 @@ if @var{obj} is an integer number or a rational number. @end deffn @c docstring begin (texi-doc-string "guile" "rational?") -@deffn primitive rational? obj -Return @code{#t} if @var{obj} is a rational number, @code{#f} else. -Note that the set of integer values forms a subset of the set of -rational numbers, so the predicate will also be fulfilled if @var{obj} -is an integer number. +@deffn primitive rational? x +Return @code{#t} if @var{x} is a rational number, @code{#f} +else. Note that the set of integer values forms a subset of +the set of rational numbers, i. e. the predicate will also be +fulfilled if @var{x} is an integer number. Real numbers +will also satisfy this predicate, because of their limited +precision. @end deffn @@ -379,11 +381,12 @@ real, so the real and imaginary parts of a complex number have the same properties of inexactness and limited precision as single real numbers. @c docstring begin (texi-doc-string "guile" "complex?") -@deffn primitive complex? obj -Return @code{#t} if @var{obj} is a complex number, @code{#f} else. -Note that the sets of real, rational and integer values form subsets of -the set of complex numbers, so the predicate will also be fulfilled if -@var{obj} is a real, rational or integer number. +@deffn primitive complex? x +Return @code{#t} if @var{x} is a complex number, @code{#f} +else. Note that the sets of real, rational and integer +values form subsets of the set of complex numbers, i. e. the +predicate will also be fulfilled if @var{x} is a real, +rational or integer number. @end deffn @@ -404,12 +407,14 @@ an invocation of the @code{inexact->exact} procedure. @c docstring begin (texi-doc-string "guile" "exact?") @deffn primitive exact? x -Return #t if X is an exact number, #f otherwise. +Return @code{#t} if @var{x} is an exact number, @code{#f} +otherwise. @end deffn @c docstring begin (texi-doc-string "guile" "inexact?") @deffn primitive inexact? x -Return #t if X is an inexact number, #f else. +Return @code{#t} if @var{x} is an inexact number, @code{#f} +else. @end deffn @c docstring begin (texi-doc-string "guile" "inexact->exact") @@ -502,12 +507,14 @@ multiplying by 10^N. @c docstring begin (texi-doc-string "guile" "odd?") @deffn primitive odd? n -Return #t if N is an odd number, #f otherwise. +Return @code{#t} if @var{n} is an odd number, @code{#f} +otherwise. @end deffn @c docstring begin (texi-doc-string "guile" "even?") @deffn primitive even? n -Return #t if N is an even number, #f otherwise. +Return @code{#t} if @var{n} is an even number, @code{#f} +otherwise. @end deffn @c begin (texi-doc-string "guile" "quotient") @@ -608,19 +615,20 @@ zero. @c docstring begin (texi-doc-string "guile" "number->string") @deffn primitive number->string n [radix] Return a string holding the external representation of the -number N in the given RADIX. If N is inexact, a radix of 10 -will be used. +number @var{n} in the given @var{radix}. If @var{n} is +inexact, a radix of 10 will be used. @end deffn @c docstring begin (texi-doc-string "guile" "string->number") @deffn primitive string->number string [radix] Returns a number of the maximally precise representation -expressed by the given STRING. RADIX must be an exact integer, -either 2, 8, 10, or 16. If supplied, RADIX is a default radix -that may be overridden by an explicit radix prefix in STRING -(e.g. "#o177"). If RADIX is not supplied, then the default -radix is 10. If string is not a syntactically valid notation -for a number, then `string->number' returns #f. (r5rs) +expressed by the given @var{string}. @var{radix} must be an +exact integer, either 2, 8, 10, or 16. If supplied, @var{radix} +is a default radix that may be overridden by an explicit radix +prefix in @var{string} (e.g. "#o177"). If @var{radix} is not +supplied, then the default radix is 10. If string is not a +syntactically valid notation for a number, then +@code{string->number} returns @code{#f}. @end deffn @@ -635,13 +643,13 @@ for a number, then `string->number' returns #f. (r5rs) @c docstring begin (texi-doc-string "guile" "make-rectangular") @deffn primitive make-rectangular real imaginary -Return a complex number constructed of the given REAL and -IMAGINARY parts. +Return a complex number constructed of the given @var{real} and +@var{imaginary} parts. @end deffn @c docstring begin (texi-doc-string "guile" "make-polar") @deffn primitive make-polar x y -Return the complex number X * e^(i * Y). +Return the complex number @var{x} * e^(i * @var{y}). @end deffn @c begin (texi-doc-string "guile" "real-part") @@ -1026,15 +1034,16 @@ Example: @c ARGFIXME n/int cnt/count @c docstring begin (texi-doc-string "guile" "ash") @deffn primitive ash n cnt -The function ash performs an arithmetic shift left by CNT bits -(or shift right, if CNT is negative). 'Arithmetic' means, that -the function does not guarantee to keep the bit structure of N, -but rather guarantees that the result will always be rounded -towards minus infinity. Therefore, the results of ash and a -corresponding bitwise shift will differ if N is negative. +The function ash performs an arithmetic shift left by @var{CNT} +bits (or shift right, if @var{cnt} is negative). +'Arithmetic' means, that the function does not guarantee to +keep the bit structure of @var{n}, but rather guarantees that +the result will always be rounded towards minus infinity. +Therefore, the results of ash and a corresponding bitwise +shift will differ if N is negative. Formally, the function returns an integer equivalent to -@code{(inexact->exact (floor (* N (expt 2 CNT))))}.@refill +@code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}. Example: @lisp @@ -1481,7 +1490,7 @@ a portion of the string. This procedure essentially implements the (qdocs:) Returns the index of @var{char} in @var{str}, or @code{#f} if the @var{char} isn't in @var{str}. If @var{frm} is given and not @code{#f}, -it is used as the starting index; if @var{to} is given and not @var{#f}, +it is used as the starting index; if @var{to} is given and not @code{#f}, it is used as the ending index (exclusive). @example @@ -1695,7 +1704,7 @@ Capitalize every character in @code{str}. @c docstring begin (texi-doc-string "guile" "string-ci<=?") @deffn primitive string-ci<=? s1 s2 Case insensitive lexicographic ordering predicate; -returns @t{#t} if @var{s1} is lexicographically less than +returns @code{#t} if @var{s1} is lexicographically less than or equal to @var{s2} regardless of case. (r5rs) @end deffn @@ -1703,72 +1712,77 @@ or equal to @var{s2} regardless of case. (r5rs) @c docstring begin (texi-doc-string "guile" "string-ci=? @c docstring begin (texi-doc-string "guile" "string-ci>=?") @deffn primitive string-ci>=? s1 s2 Case insensitive lexicographic ordering predicate; -returns @t{#t} if @var{s1} is lexicographically greater than -or equal to @var{s2} regardless of case. (r5rs) +returns @code{#t} if @var{s1} is lexicographically greater +than or equal to @var{s2} regardless of case. (r5rs) @end deffn @r5index string-ci>? @c docstring begin (texi-doc-string "guile" "string-ci>?") @deffn primitive string-ci>? s1 s2 Case insensitive lexicographic ordering predicate; -returns @t{#t} if @var{s1} is lexicographically greater than -@var{s2} regardless of case. (r5rs) +returns @code{#t} if @var{s1} is lexicographically greater +than @var{s2} regardless of case. (r5rs) @end deffn @r5index string<=? @c docstring begin (texi-doc-string "guile" "string<=?") @deffn primitive string<=? s1 s2 -Lexicographic ordering predicate; returns @t{#t} if @var{s1} -is lexicographically less than or equal to @var{s2}. (r5rs) +Lexicographic ordering predicate; returns @code{#t} if +@var{s1} is lexicographically less than or equal to @var{s2}. +(r5rs) @end deffn @r5index string=? @c docstring begin (texi-doc-string "guile" "string>=?") @deffn primitive string>=? s1 s2 -Lexicographic ordering predicate; returns @t{#t} if @var{s1} -is lexicographically greater than or equal to @var{s2}. (r5rs) +Lexicographic ordering predicate; returns @code{#t} if +@var{s1} is lexicographically greater than or equal to +@var{s2}. (r5rs) @end deffn @r5index string>? @c docstring begin (texi-doc-string "guile" "string>?") @deffn primitive string>? s1 s2 -Lexicographic ordering predicate; returns @t{#t} if @var{s1} -is lexicographically greater than @var{s2}. (r5rs) +Lexicographic ordering predicate; returns @code{#t} if +@var{s1} is lexicographically greater than @var{s2}. (r5rs) @end deffn @r5index string->list @@ -2452,57 +2466,48 @@ Returns the symbol whose name is @var{string}. This procedure can create symbols with names containing special characters or letters in the non-standard case, but it is usually a bad idea to create such symbols because in some implementations of Scheme they cannot be read as -themselves. See @samp{symbol->string}. +themselves. See @code{symbol->string}. -The following examples assume that the implementation's standard case is -lower case: +The following examples assume that the implementation's +standard case is lower case: -@format -@t{(eq? 'mISSISSIppi 'mississippi) - ==> #t -(string->symbol "mISSISSIppi") - ==> - @r{}the symbol with name "mISSISSIppi" -(eq? 'bitBlt (string->symbol "bitBlt")) - ==> #f +@lisp +(eq? 'mISSISSIppi 'mississippi) @result{} #t +(string->symbol "mISSISSIppi") @result{} @r{the symbol with name "mISSISSIppi"} +(eq? 'bitBlt (string->symbol "bitBlt")) @result{} #f (eq? 'JollyWog - (string->symbol - (symbol->string 'JollyWog))) - ==> #t + (string->symbol (symbol->string 'JollyWog))) @result{} #t (string=? "K. Harper, M.D." - (symbol->string - (string->symbol "K. Harper, M.D."))) - ==> #t -} -@end format + (symbol->string + (string->symbol "K. Harper, M.D."))) @result{}#t +@end lisp @end deffn @c docstring begin (texi-doc-string "guile" "symbol->string") -@deffn primitive symbol->string symbol -Returns the name of @var{symbol} as a string. If the symbol was part of -an object returned as the value of a literal expression (section -@pxref{Literal expressions,,,r4rs, The Revised^4 Report on Scheme}) or -by a call to the @samp{read} procedure, and its name contains alphabetic -characters, then the string returned will contain characters in the -implementation's preferred standard case---some implementations will -prefer upper case, others lower case. If the symbol was returned by -@samp{string->symbol}, the case of characters in the string returned -will be the same as the case in the string that was passed to -@samp{string->symbol}. It is an error to apply mutation procedures like -@code{string-set!} to strings returned by this procedure. (r5rs) +@deffn primitive symbol->string s +Returns the name of @var{symbol} as a string. If the symbol +was part of an object returned as the value of a literal +expression (section @pxref{Literal expressions,,,r4rs, The +Revised^4 Report on Scheme}) or by a call to the @code{read} +procedure, and its name contains alphabetic characters, then +the string returned will contain characters in the +implementation's preferred standard case---some implementations +will prefer upper case, others lower case. If the symbol was +returned by @code{string->symbol}, the case of characters in +the string returned will be the same as the case in the string +that was passed to @code{string->symbol}. It is an error to +apply mutation procedures like @code{string-set!} to strings +returned by this procedure. (r5rs) -The following examples assume that the implementation's standard case is -lower case: +The following examples assume that the implementation's +standard case is lower case: -@format -@t{(symbol->string 'flying-fish) - ==> "flying-fish" -(symbol->string 'Martin) ==> "martin" +@lisp +(symbol->string 'flying-fish) @result{} "flying-fish" +(symbol->string 'Martin) @result{} "martin" (symbol->string - (string->symbol "Malvina")) - ==> "Malvina" -} -@end format + (string->symbol "Malvina")) @result{} "Malvina" +@end lisp @end deffn @c docstring begin (texi-doc-string "guile" "symbol-binding") @@ -2515,11 +2520,12 @@ use the global symbol table. If @var{string} is not interned in @c docstring begin (texi-doc-string "guile" "symbol-bound?") @deffn primitive symbol-bound? obarray string -Return @var{#t} if @var{obarray} contains a symbol with name +Return @code{#t} if @var{obarray} contains a symbol with name @var{string} bound to a defined value. This differs from -@var{symbol-interned?} in that the mere mention of a symbol usually causes -it to be interned; @code{symbol-bound?} determines whether a symbol has -been given any meaningful value. +@var{symbol-interned?} in that the mere mention of a symbol +usually causes it to be interned; @code{symbol-bound?} +determines whether a symbol has been given any meaningful +value. @end deffn @c docstring begin (texi-doc-string "guile" "symbol-fref") @@ -2539,8 +2545,8 @@ Return a hash value for @var{symbol}. @c docstring begin (texi-doc-string "guile" "symbol-interned?") @deffn primitive symbol-interned? obarray string -Return @var{#t} if @var{obarray} contains a symbol with name -@var{string}, and @var{#f} otherwise. +Return @code{#t} if @var{obarray} contains a symbol with name +@var{string}, and @code{#f} otherwise. @end deffn @c docstring begin (texi-doc-string "guile" "symbol-pref") @@ -2562,7 +2568,8 @@ in @var{obarray}. @c docstring begin (texi-doc-string "guile" "symbol?") @deffn primitive symbol? obj -Returns @t{#t} if @var{obj} is a symbol, otherwise returns @t{#f}. (r5rs) +Returns @code{#t} if @var{obj} is a symbol, otherwise returns +@code{#f}. (r5rs) @end deffn @c docstring begin (texi-doc-string "guile" "unintern-symbol") @@ -2905,53 +2912,51 @@ by @code{set-cdr!} is unspecified. @c docstring begin (texi-doc-string "guile" "list") @deffn primitive list . objs -Return a list containing OBJS, the arguments to `list'. +Return a list containing @var{objs}, the arguments to +@code{list}. @end deffn @c docstring begin (texi-doc-string "guile" "cons*") @deffn primitive cons* arg . rest -@deffnx primitive list* arg . rest -Like `list', but the last arg provides the tail of the constructed list, -returning (cons ARG1 (cons ARG2 (cons ... ARGn))). -Requires at least one argument. If given one argument, that argument -is returned as result. -This function is called `list*' in some other Schemes and in Common LISP. +Like @code{list}, but the last arg provides the tail of the +constructed list, returning @code{(cons @var{arg1} (cons +@var{arg2} (cons @dots{} @var{argn}))). Requires at least one +argument. If given one argument, that argument is returned as +result. This function is called @code{list*} in some other +Schemes and in Common LISP. @end deffn @c docstring begin (texi-doc-string "guile" "list?") @deffn primitive list? x -Return #t iff X is a proper list, else #f. +Return @code{#t} iff @var{x} is a proper list, else @code{#f}. @end deffn @c docstring begin (texi-doc-string "guile" "null?") @deffn primitive null? x -Return #t iff X is the empty list, else #f. +Return @code{#t} iff @var{x} is the empty list, else @code{#f}. @end deffn @c docstring begin (texi-doc-string "guile" "length") @deffn primitive length lst -Return the number of elements in list LST. +Return the number of elements in list @var{lst}. @end deffn @c docstring begin (texi-doc-string "guile" "append") @deffn primitive append . args -Returns a list consisting of the elements of the first LIST -followed by the elements of the other LISTs. - +Return a list consisting of the elements the lists passed as +arguments. @example - (append '(x) '(y)) => (x y) - (append '(a) '(b c d)) => (a b c d) - (append '(a (b)) '((c))) => (a (b) (c)) +(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 example - -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 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. @example - (append '(a b) '(c . d)) => (a b c . d) - (append '() 'a) => a +(append '(a b) '(c . d)) @result{} (a b c . d) +(append '() 'a) @result{} a @end example @end deffn @@ -2972,7 +2977,8 @@ Return a pointer to the last pair in @var{lst}, signalling an error if @c docstring begin (texi-doc-string "guile" "reverse") @deffn primitive reverse lst -Return a new list that contains the elements of LST but in reverse order. +Return a new list that contains the elements of @var{lst} but +in reverse order. @end deffn @c NJFIXME explain new_tail @@ -2993,7 +2999,7 @@ of the modified list is not lost, it is wise to save the return value of @c docstring begin (texi-doc-string "guile" "list-ref") @deffn primitive list-ref list k -Return the Kth element from LIST. +Return the @var{k}th element from @var{list}. @end deffn @c docstring begin (texi-doc-string "guile" "list-set!") @@ -3031,53 +3037,56 @@ Return a (newly-created) copy of @var{lst}. @c docstring begin (texi-doc-string "guile" "memq") @deffn primitive memq x lst -Return the first sublist of LST whose car is `eq?' to X -where the sublists of LST are the non-empty lists returned -by `(list-tail LST K)' for K less than the length of LST. If -X does not occur in LST, then `#f' (not the empty list) is +Return the first sublist of @var{lst} whose car is @code{eq?} +to @var{x} where the sublists of @var{lst} are the non-empty +lists returned by @code{(list-tail @var{lst} @var{k})} for +@var{k} less than the length of @var{lst}. If @var{x} does not +occur in @var{lst}, then @code{#f} (not the empty list) is returned. @end deffn @c docstring begin (texi-doc-string "guile" "memv") @deffn primitive memv x lst -Return the first sublist of LST whose car is `eqv?' to X -where the sublists of LST are the non-empty lists returned -by `(list-tail LST K)' for K less than the length of LST. If -X does not occur in LST, then `#f' (not the empty list) is +Return the first sublist of @var{lst} whose car is @code{eqv?} +to @var{x} where the sublists of @var{lst} are the non-empty +lists returned by @code{(list-tail @var{lst} @var{k})} for +@var{k} less than the length of @var{lst}. If @var{x} does not +occur in @var{lst}, then @code{#f} (not the empty list) is returned. @end deffn @c docstring begin (texi-doc-string "guile" "member") @deffn primitive member x lst -Return the first sublist of LST whose car is `equal?' to X -where the sublists of LST are the non-empty lists returned -by `(list-tail LST K)' for K less than the length of LST. If -X does not occur in LST, then `#f' (not the empty list) is -returned. +Return the first sublist of @var{lst} whose car is +@code{equal?} to @var{x} where the sublists of @var{lst} are +the non-empty lists returned by @code{(list-tail @var{lst} +@var{k})} for @var{k} less than the length of @var{lst}. If +@var{x} does not occur in @var{lst}, then @code{#f} (not the +empty list) is returned. @end deffn @c docstring begin (texi-doc-string "guile" "delq") @deffn primitive delq item lst -Return a newly-created copy of @var{lst} with elements `eq?' to @var{item} removed. -This procedure mirrors @code{memq}: -@code{delq} compares elements of @var{lst} against @var{item} with -@code{eq?}. +Return a newly-created copy of @var{lst} with elements +@code{eq?} to @var{item} removed. This procedure mirrors +@code{memq}: @code{delq} compares elements of @var{lst} against +@var{item} with @code{eq?}. @end deffn @c docstring begin (texi-doc-string "guile" "delv") @deffn primitive delv item lst -Return a newly-created copy of @var{lst} with elements `eqv?' to @var{item} removed. -This procedure mirrors @code{memv}: -@code{delv} compares elements of @var{lst} against @var{item} with -@code{eqv?}. +Return a newly-created copy of @var{lst} with elements +@code{eqv?} to @var{item} removed. This procedure mirrors +@code{memv}: @code{delv} compares elements of @var{lst} against +@var{item} with @code{eqv?}. @end deffn @c docstring begin (texi-doc-string "guile" "delete") @deffn primitive delete item lst -Return a newly-created copy of @var{lst} with elements `equal?' to @var{item} removed. -This procedure mirrors @code{member}: -@code{delete} compares elements of @var{lst} against @var{item} with -@code{equal?}. +Return a newly-created copy of @var{lst} with elements +@code{equal?} to @var{item} removed. This procedure mirrors +@code{member}: @code{delete} compares elements of @var{lst} +against @var{item} with @code{equal?}. @end deffn @c docstring begin (texi-doc-string "guile" "delq!") @@ -3096,20 +3105,23 @@ destructive list functions, these functions cannot modify the binding of @c docstring begin (texi-doc-string "guile" "delq1!") @deffn primitive delq1! item lst -Like `delq!', but only deletes the first occurrence of ITEM from LST. -Tests for equality using `eq?'. See also `delv1!' and `delete1!'. +Like @code{delq!}, but only deletes the first occurrence of +@var{item} from @var{lst}. Tests for equality using +@code{eq?}. See also @code{delv1!} and @code{delete1!}. @end deffn @c docstring begin (texi-doc-string "guile" "delv1!") @deffn primitive delv1! item lst -Like `delv!', but only deletes the first occurrence of ITEM from LST. -Tests for equality using `eqv?'. See also `delq1!' and `delete1!'. +Like @code{delv!}, but only deletes the first occurrence of +@var{item} from @var{lst}. Tests for equality using +@code{eqv?}. See also @code{delq1!} and @code{delete1!}. @end deffn @c docstring begin (texi-doc-string "guile" "delete1!") @deffn primitive delete1! item lst -Like `delete!', but only deletes the first occurrence of ITEM from LST. -Tests for equality using `equal?'. See also `delq1!' and `delv1!'. +Like @code{delete!}, but only deletes the first occurrence of +@var{item} from @var{lst}. Tests for equality using +@code{equal?}. See also @code{delq1!} and @code{delv1!}. @end deffn [FIXME: is there any reason to have the `sloppy' functions available at @@ -3450,7 +3462,8 @@ For more information, see the documentation for @code{make-vtable-vtable}. @c docstring begin (texi-doc-string "guile" "struct?") @deffn primitive struct? x -Return #t iff @var{obj} is a structure object, else #f. +Return @code{#t} iff @var{obj} is a structure object, else +@code{#f}. @end deffn @@ -3486,7 +3499,7 @@ Return the vtable structure that describes the type of @var{struct}. @c docstring begin (texi-doc-string "guile" "struct-vtable?") @deffn primitive struct-vtable? x -Return #t iff obj is a vtable structure. +Return @code{#t} iff obj is a vtable structure. @end deffn If you have a vtable structure, @code{V}, you can create an instance of @@ -4543,8 +4556,8 @@ any Scheme object. @deffn primitive hashq-ref table obj [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 `eq?' for equality testing. +return @var{default} (or @code{#f} if no @var{default} argument +is supplied). Uses @code{eq?} for equality testing. @end deffn @c ARGFIXME obj/key @@ -4552,8 +4565,8 @@ supplied). Uses `eq?' for equality testing. @deffn primitive hashv-ref table obj [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 `eqv?' for equality testing. +return @var{default} (or @code{#f} if no @var{default} argument +is supplied). Uses @code{eqv?} for equality testing. @end deffn @c ARGFIXME obj/key @@ -4561,50 +4574,51 @@ supplied). Uses `eqv?' for equality testing. @deffn primitive hash-ref table obj [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 `equal?' for equality testing. +return @var{default} (or @code{#f} if no @var{default} argument +is supplied). Uses @code{equal?} for equality testing. @end deffn @c ARGFIXME obj/key @c docstring begin (texi-doc-string "guile" "hashq-set!") @deffn primitive hashq-set! table obj val -Find the entry in @var{table} associated with @var{key}, and store -@var{value} there. Uses `eq?' for equality testing. +Find the entry in @var{table} associated with @var{key}, and +store @var{value} there. Uses @code{eq?} for equality testing. @end deffn @c ARGFIXME obj/key @c docstring begin (texi-doc-string "guile" "hashv-set!") @deffn primitive hashv-set! table obj val -Find the entry in @var{table} associated with @var{key}, and store -@var{value} there. Uses `eqv?' for equality testing. +Find the entry in @var{table} associated with @var{key}, and +store @var{value} there. Uses @code{eqv?} for equality testing. @end deffn @c ARGFIXME obj/key @c docstring begin (texi-doc-string "guile" "hash-set!") @deffn primitive hash-set! table obj val -Find the entry in @var{table} associated with @var{key}, and store -@var{value} there. Uses `equal?' for equality testing. +Find the entry in @var{table} associated with @var{key}, and +store @var{value} there. Uses @code{equal?} for equality +testing. @end deffn @c ARGFIXME obj/key @c docstring begin (texi-doc-string "guile" "hashq-remove!") @deffn primitive hashq-remove! table obj -Remove @var{key} (and any value associated with it) from @var{table}. -Uses `eq?' for equality tests. +Remove @var{key} (and any value associated with it) from +@var{table}. Uses @code{eq?} for equality tests. @end deffn @c ARGFIXME obj/key @c docstring begin (texi-doc-string "guile" "hashv-remove!") @deffn primitive hashv-remove! table obj -Remove @var{key} (and any value associated with it) from @var{table}. -Uses `eqv?' for equality tests. +Remove @var{key} (and any value associated with it) from +@var{table}. Uses @code{eqv?} for equality tests. @end deffn @c ARGFIXME obj/key @c docstring begin (texi-doc-string "guile" "hash-remove!") @deffn primitive hash-remove! table obj -Remove @var{key} (and any value associated with it) from @var{table}. -Uses `equal?' for equality tests. +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 @@ -4624,36 +4638,38 @@ explanation of how hash tables are implemented. @c docstring begin (texi-doc-string "guile" "hashq") @deffn primitive hashq key size -Determine a hash value for KEY that is suitable for lookups in -a hashtable of size SIZE, where eq? is used as the equality -predicate. The function returns an integer in the range 0 to -SIZE - 1. NOTE that `hashq' may use internal addresses. -Thus two calls to hashq where the keys are 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: (hashq 'foo n) (gc) (hashq 'foo n) may produce two -different values, since 'foo will be garbage collected. +Determine a hash value for @var{key} that is suitable for +lookups in a hashtable 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 @c docstring begin (texi-doc-string "guile" "hashv") @deffn primitive hashv key size -Determine a hash value for KEY that is suitable for lookups in -a hashtable of size SIZE, where eqv? is used as the equality -predicate. The function returns an integer in the range 0 to -SIZE - 1. NOTE that (hashv key) may use internal addresses. -Thus two calls to hashv where the keys are 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: (hashv 'foo n) (gc) (hashv 'foo n) may produce two -different values, since 'foo will be garbage collected. +Determine a hash value for @var{key} that is suitable for +lookups in a hashtable 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. @end deffn @c docstring begin (texi-doc-string "guile" "hash") @deffn primitive hash key size -Determine a hash value for KEY that is suitable for lookups in -a hashtable of size SIZE, where equal? is used as the equality -predicate. The function returns an integer in the range 0 to -SIZE - 1. +Determine a hash value for @var{key} that is suitable for +lookups in a hashtable 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 @c ARGFIXME hash/hasher @@ -4784,27 +4800,24 @@ Otherwise the initial contents of each element is unspecified. (r5rs) @c docstring begin (texi-doc-string "guile" "list->vector") @deffn primitive vector . l @deffnx primitive list->vector l -Returns a newly allocated vector whose elements contain the given -arguments. Analogous to @samp{list}. (r5rs) +Returns a newly allocated vector whose elements contain the +given arguments. Analogous to @code{list}. (r5rs) -@format -@t{(vector 'a 'b 'c) ==> #(a b c) } -@end format +@lisp +(vector 'a 'b 'c) @result{} #(a b c) +@end lisp @end deffn @r5index vector->list @c docstring begin (texi-doc-string "guile" "vector->list") @deffn primitive vector->list v -@samp{Vector->list} returns a newly allocated list of the objects contained -in the elements of @var{vector}. (r5rs) +@samp{Vector->list} returns a newly allocated list of the +objects contained in the elements of @var{vector}. (r5rs) -@format -@t{(vector->list '#(dah dah didah)) -=> (dah dah didah) -list->vector '(dididit dah)) -=> #(dididit dah) -} -@end format +@lisp +(vector->list '#(dah dah didah)) @result{} (dah dah didah) +(list->vector '(dididit dah)) @result{} #(dididit dah) +@end lisp @end deffn @r5index vector-fill! @@ -4812,13 +4825,14 @@ list->vector '(dididit dah)) @c docstring begin (texi-doc-string "guile" "vector-fill!") @deffn primitive vector-fill! v fill_x Stores @var{fill} in every element of @var{vector}. -The value returned by @samp{vector-fill!} is unspecified. (r5rs) +The value returned by @code{vector-fill!} is unspecified. (r5rs) @end deffn @r5index vector? @c docstring begin (texi-doc-string "guile" "vector?") @deffn primitive vector? obj -Returns @t{#t} if @var{obj} is a vector, otherwise returns @t{#f}. (r5rs) +Returns @code{#t} if @var{obj} is a vector, otherwise returns +@code{#f}. (r5rs) @end deffn @r5index vector-length diff --git a/doc/scheme-evaluation.texi b/doc/scheme-evaluation.texi index 8211aa37a..26a3c3238 100644 --- a/doc/scheme-evaluation.texi +++ b/doc/scheme-evaluation.texi @@ -132,9 +132,10 @@ dynamically typed by the user. @c docstring begin (texi-doc-string "guile" "eval-string") @deffn primitive eval-string string -Evaluate @var{string} as the text representation of a Scheme form -or forms, and return whatever value they produce. -Evaluation takes place in (interaction-environment). +Evaluate @var{string} as the text representation of a Scheme +form or forms, and return whatever value they produce. +Evaluation takes place in the environment returned by the +procedure @code{interaction-environment}. @end deffn @c docstring begin (texi-doc-string "guile" "apply:nconc2last") @@ -191,31 +192,34 @@ this section. @c ARGFIXME file/filename @c docstring begin (texi-doc-string "guile" "primitive-load") @deffn primitive primitive-load filename -Load @var{file} and evaluate its contents in the top-level environment. -The load paths are not searched; @var{file} must either be a full -pathname or be a pathname relative to the current directory. If the -variable @code{%load-hook} is defined, it should be bound to a procedure -that will be called before any code is loaded. See documentation for -@code{%load-hook} later in this section. +Load the file named @var{filename} and evaluate its contents in +the top-level environment. The load paths are not searched; +@var{filename} must either be a full pathname or be a pathname +relative to the current directory. If the variable +@code{%load-hook} is defined, it should be bound to a procedure +that will be called before any code is loaded. See the +documentation for @code{%load-hook} later in this section. @end deffn @c ARGFIXME file/filename @c docstring begin (texi-doc-string "guile" "primitive-load-path") @deffn primitive primitive-load-path filename -Search @var{%load-path} for @var{file} and load it into the top-level -environment. If @var{file} is a relative pathname and is not found in -the list of search paths, an error is signalled. +Search @var{%load-path} for the file named @var{filename} and +load it into the top-level environment. If @var{filename} is a +relative pathname and is not found in the list of search paths, +an error is signalled. @end deffn @c ARGFIXME file/filename @c docstring begin (texi-doc-string "guile" "%search-load-path") @deffn primitive %search-load-path filename -Search @var{%load-path} for @var{file}, which must be readable by the -current user. If @var{file} is found in the list of paths to search or -is an absolute pathname, return its full pathname. Otherwise, return -@code{#f}. Filenames may have any of the optional extensions in the -@code{%load-extensions} list; @code{%search-load-path} will try each -extension automatically. +Search @var{%load-path} for the file named @var{filename}, +which must be readable by the current user. If @var{filename} +is found in the list of paths to search or is an absolute +pathname, return its full pathname. Otherwise, return +@code{#f}. Filenames may have any of the optional extensions +in the @code{%load-extensions} list; @code{%search-load-path} +will try each extension automatically. @end deffn @defvar %load-hook @@ -255,7 +259,7 @@ list @code{("" ".scm")}. @c ARGFIXME x/obj @c docstring begin (texi-doc-string "guile" "promise?") -@deffn primitive promise? x +@deffn primitive promise? obj Return true if @var{obj} is a promise, i.e. a delayed computation (@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}). @end deffn @@ -263,8 +267,9 @@ Return true if @var{obj} is a promise, i.e. a delayed computation @r5index force @c docstring begin (texi-doc-string "guile" "force") @deffn primitive force x -If the promise X has not been computed yet, compute and return -X, otherwise just return the previously computed value. +If the promise @var{x} has not been computed yet, compute and +return @var{x}, otherwise just return the previously computed +value. @end deffn diff --git a/doc/scheme-io.texi b/doc/scheme-io.texi index f3a6a9001..0a64c52c7 100644 --- a/doc/scheme-io.texi +++ b/doc/scheme-io.texi @@ -51,7 +51,8 @@ Returns @code{#t} if @var{x} is an output port, otherwise returns @c docstring begin (texi-doc-string "guile" "port?") @deffn primitive port? x Returns a boolean indicating whether @var{x} is a port. -Equivalent to @code{(or (input-port? X) (output-port? X))}. +Equivalent to @code{(or (input-port? @var{x}) (output-port? +@var{x}))}. @end deffn @@ -135,13 +136,13 @@ characters) and returns the content as a single string. @c docstring begin (texi-doc-string "guile" "port-column") @c docstring begin (texi-doc-string "guile" "port-line") @deffn primitive port-column port -@deffnx primitive port-line [input-port] -Return the current column number or line number of @var{input-port}, +@deffnx primitive 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 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 -message, we recommand you add 1 to get 1-origin integers. This is +message, we recommend you add 1 to get 1-origin integers. This is because lines and column numbers traditionally start with 1, and that is what non-programmers will find most natural.) @end deffn @@ -216,8 +217,9 @@ included print state @var{pstate}. @c docstring begin (texi-doc-string "guile" "print-options-interface") @deffn primitive print-options-interface [setting] Option interface for the print options. Instead of using -this procedure directly, use the procedures @code{print-enable}, -@code{print-disable}, @code{print-set!} and @var{print-options}. +this procedure directly, use the procedures +@code{print-enable}, @code{print-disable}, @code{print-set!} +and @code{print-options}. @end deffn @c docstring begin (texi-doc-string "guile" "simple-format") @@ -460,19 +462,19 @@ internals. @c docstring begin (texi-doc-string "guile" "%read-delimited!") @deffn primitive %read-delimited! delims str gobble [port [start [end]]] Read characters from @var{port} into @var{str} until one of the -characters in the @var{delims} string is encountered. If @var{gobble} -is true, discard the delimiter character; otherwise, leave it -in the input stream for the next read. -If @var{port} is not specified, use the value of -@code{(current-input-port)}. If @var{start} or @var{end} are specified, -store data only into the substring of @var{str} bounded by @var{start} -and @var{end} (which default to the beginning and end of the string, -respectively). - -Return a pair consisting of the delimiter that terminated the string and -the number of characters read. If reading stopped at the end of file, -the delimiter returned is the @var{eof-object}; if the string was filled -without encountering a delimiter, this value is @var{#f}. +characters in the @var{delims} string is encountered. If +@var{gobble} is true, discard the delimiter character; +otherwise, leave it in the input stream for the next read. If +@var{port} is not specified, use the value of +@code{(current-input-port)}. If @var{start} or @var{end} are +specified, store data only into the substring of @var{str} +bounded by @var{start} and @var{end} (which default to the +beginning and end of the string, respectively). + Return a pair consisting of the delimiter that terminated the +string and the number of characters read. If reading stopped +at the end of file, the delimiter returned is the +@var{eof-object}; if the string was filled without encountering +a delimiter, this value is @code{#f}. @end deffn @c docstring begin (texi-doc-string "guile" "%read-line") diff --git a/doc/scheme-memory.texi b/doc/scheme-memory.texi index 54ee5dfec..b01d7915d 100644 --- a/doc/scheme-memory.texi +++ b/doc/scheme-memory.texi @@ -104,9 +104,9 @@ regular hash tables. (@pxref{Hash Tables}) @deffn primitive weak-key-hash-table? x @deffnx primitive weak-value-hash-table? obj @deffnx primitive doubly-weak-hash-table? obj -Return @var{#t} if @var{obj} is the specified weak hash table. Note -that a doubly weak hash table is neither a weak key nor a weak value -hash table. +Return @code{#t} if @var{obj} is the specified weak hash +table. Note that a doubly weak hash table is neither a weak key +nor a weak value hash table. @end deffn @c docstring begin (texi-doc-string "guile" "make-weak-value-hash-table") @@ -154,8 +154,8 @@ its arguments while @code{list->weak-vector} uses its only argument @c ARGFIXME x/obj @c docstring begin (texi-doc-string "guile" "weak-vector?") @deffn primitive weak-vector? x -Return @var{#t} if @var{obj} is a weak vector. Note that all weak -hashes are also weak vectors. +Return @code{#t} if @var{obj} is a weak vector. Note that all +weak hashes are also weak vectors. @end deffn From 028321d47378ba8a1765acc4395cf5e9bb7d6155 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 23 Mar 2001 15:24:38 +0000 Subject: [PATCH 0750/2047] * Add two files that I seem to have omitted in the move from guile-doc to guile-core. (guile-tut.texi and ChangeLog-guile-doc-tutorial) --- doc/ChangeLog | 4 + doc/ChangeLog-guile-doc-tutorial | 0 doc/guile-tut.texi | 1336 ++++++++++++++++++++++++++++++ 3 files changed, 1340 insertions(+) create mode 100644 doc/ChangeLog-guile-doc-tutorial create mode 100644 doc/guile-tut.texi diff --git a/doc/ChangeLog b/doc/ChangeLog index dfa0f66c3..a8fa6345e 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,5 +1,9 @@ 2001-03-23 Neil Jerram + * guile-tut.texi, ChangeLog-guile-doc-tutorial: Added to CVS. It + seems that I somehow missed these out when I moved everything from + guile-doc to guile-core. + * posix.texi, scheme-data.texi, scheme-evaluation.texi, scheme-io.texi, scheme-memory.texi: Automatic docstring updates. diff --git a/doc/ChangeLog-guile-doc-tutorial b/doc/ChangeLog-guile-doc-tutorial new file mode 100644 index 000000000..e69de29bb diff --git a/doc/guile-tut.texi b/doc/guile-tut.texi new file mode 100644 index 000000000..7f3d28f0a --- /dev/null +++ b/doc/guile-tut.texi @@ -0,0 +1,1336 @@ +\input texinfo @c -*-texinfo-*- +@c %**start of header +@setfilename guile-tut.info +@settitle Guile Tutorial + +@include version.texi + +@dircategory The Algorithmic Language Scheme +@direntry +* Guile Tutorial: (guile-tut). The Guile tutorial. +@end direntry + +@setchapternewpage off +@c Choices for setchapternewpage are {on,off,odd}. +@paragraphindent 2 +@c %**end of header + +@iftex +@finalout +@c DL: lose the egregious vertical whitespace, esp. around examples +@c but paras in @defun-like things don't have parindent +@parskip 4pt plus 1pt +@end iftex + +@titlepage +@title Guile Tutorial +@subtitle For use with Guile @value{VERSION} +@subtitle Last updated @value{UPDATED} +@author Mark Galassi +@author Cygnus Solutions and +@author Los Alamos National Laboratory +@author @email{rosalia@@nis.lanl.gov} + +@page +@vskip 0pt plus 1filll +Copyright @copyright{} 1997, 1998 Free Software Foundation + +Permission is granted to make and distribute verbatim copies of +this manual provided the copyright notice and this permission notice +are preserved on all copies. + +Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided that the entire +resulting derived work is distributed under the terms of a permission +notice identical to this one. + +Permission is granted to copy and distribute translations of this manual +into another language, under the above conditions for modified versions, +except that this permission notice may be stated in a translation approved +by the author. +@end titlepage + + +@ifinfo +@node Top +@top Guile Tutorial +@end ifinfo + +@ifinfo +This file gives a tutorial introductionto Guile. + +Copyright (C) 1997 Free Software Foundation + +Permission is granted to make and distribute verbatim copies of +this manual provided the copyright notice and this permission notice +are preserved on all copies. + +@ignore +Permission is granted to process this file through TeX and print the +results, provided the printed document carries copying permission +notice identical to this one except for the removal of this paragraph +(this paragraph not being relevant to the printed manual). + +@end ignore +Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided that the entire +resulting derived work is distributed under the terms of a permission +notice identical to this one. + +Permission is granted to copy and distribute translations of this manual +into another language, under the above conditions for modified versions, +except that this permission notice may be stated in a translation approved +by the author. +@end ifinfo + + +@menu +* Jump Start:: +* Introduction:: +* Using Guile to program in Scheme:: +* Guile in a Library:: +* Regular Expression Support:: +* UNIX System Programming:: +* Where to find more Guile/Scheme resources:: +* Concept Index:: +* Procedure and Macro Index:: +* Variable Index:: +* Type Index:: +@end menu + +@node Jump Start +@chapter Jump Start + +@noindent +Before giving an overview of Guile, I present some simple commands and +programs that you can type to get going immediately. + +Start by invoking the Guile interpreter (usually you do this by just +typing @code{guile}). Then type (or paste) the following expressions at +the prompt; the interpreter's response is preceded (in this manual) by +@result{}. + +@example + guile +@end example +@lisp +(+ 20 35) +@result{} 55 +(define (recursive-factorial n) + (if (= n 0) + 1 + (* n (recursive-factorial (- n 1))))) +(recursive-factorial 5) +@result{} 120 +(recursive-factorial 500) +@result{} 1220136825991110068701238785423046926253574342803192842192413588 + 3858453731538819976054964475022032818630136164771482035841633787 + 2207817720048078520515932928547790757193933060377296085908627042 + 9174547882424912726344305670173270769461062802310452644218878789 + 4657547771498634943677810376442740338273653974713864778784954384 + 8959553753799042324106127132698432774571554630997720278101456108 + 1188373709531016356324432987029563896628911658974769572087926928 + 8712817800702651745077684107196243903943225364226052349458501299 + 1857150124870696156814162535905669342381300885624924689156412677 + 5654481886506593847951775360894005745238940335798476363944905313 + 0623237490664450488246650759467358620746379251842004593696929810 + 2226397195259719094521782333175693458150855233282076282002340262 + 6907898342451712006207714640979456116127629145951237229913340169 + 5523638509428855920187274337951730145863575708283557801587354327 + 6888868012039988238470215146760544540766353598417443048012893831 + 3896881639487469658817504506926365338175055478128640000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000000 + +@end lisp + +In this example we did some simple arithmetic @code{(+ 20 35)} and got +the answer @code{55}. Then we coded the classic (and rather wasteful) +factorial algorithm, and got a glimpse of Scheme's nice +@emph{bignumbers} by asking for the factorial of 1000. Then we quit +with @code{(quit)}. +@cindex bignumbers + +This is the most basic use of Guile: a simple Scheme interpreter. In +the rest of this tutorial I will show you how Guile has many facets: it +is also an @emph{extensible} interpreter (to which many features can be +easilly added) and an @emph{embeddable} interpreter (which can be +invoked from your C programs). + + +@node Introduction +@chapter Introduction + +@noindent +@dfn{Guile} (which can stand for @emph{GNU Ubiquitous Intelligent +Language Extension}) is the GNU extension language. It started out as +an embeddable Scheme interpreter, and has rapidly evolved into a +kitchen-sink package including a standalone Scheme interpreter, an +embeddable Scheme interpreter, several graphics options, other languages +that can be used along with Scheme (for now just @emph{ctax} and +@emph{Tcl}), and hooks for much more. + + +@menu +* What are scripting and extension languages:: +* History of Guile and its motivations:: +* How to characterize Guile:: +@end menu + +@node What are scripting and extension languages +@section What are scripting and extension languages +@cindex scripting languages +@cindex extension languages + +A @dfn{scripting language} is a programming language which serves as +glue between other system programs. In the UNIX world, the traditional +scripting language is the @emph{Bourne shell}, which allows many UNIX +commands to be executed in sequence, or in a pipeline. Traditional UNIX +commands are cleverly written to work well when put together in a +script. + +Other examples of UNIX scripting languages are AWK, Perl, Scsh (the +Scheme Shell: a Scheme interpreter enhanced to do good scripting), +Python, Tcl, Java @dots{} +@cindex scripting languages - examples + +UNIX programmers noticed, more than 25 years ago, that scripting +languages can do serious work, so the Bourne shell was written to have +variables, operators and control structures, just like a full-featured +programming language. +@cindex Bourne shell + +What scripting languages have, that traditional programming languages do +not, is the ability to easily run an external program (or a pipeline of +external programs) and use the returned values and output from that +program in useful ways. + +An @dfn{extension language} is a programming language interpreter +offered by an application program, so that users can write macros or +even full-fledged programs to extend the original application. +Extension languages have a C interface (it is usually C, but it could be +any other compiled language), and can be given access to the C data +structures. Likewise, there are C routines to access the extension +language data structures. + +Extension languages abound in the software world, even though the name +@emph{extension language} is seldom used. Examples are: +@cindex extension languages - examples + +@itemize @bullet +@item +Emacs Lisp, the language used to program and customize GNU Emacs. +@cindex Emacs Lisp + +@item +Tcl, John Ousterhout's general-purpose scripting and extension language. +@cindex Tcl + +@item +The Lotus 1-2-3 macro language (any spreadsheet macro language, +really). I mention this one first because it is a classic, even though +it is seldom used any more. +@cindex Lotus 1-2-3 + +@item +Other spreadsheet and database macro languages. + +@item +The Dominion empire-style game's @emph{exec} files. +@cindex Dominion + +@item +Any syntax for a ".*rc" file you might have used. Almost all programs +end up parsing some kind of startup or configuration file. The syntax +for those can get pretty involved, thus justifying calling them +"extension languages". The @emph{fvwm} window manager, for example, +parses a rather elaborate @file{.fvwmrc} file. + +@item +Brent Benson's libscheme.a, an embeddable Scheme interpreter. +@cindex Benson, Brent +@cindex libscheme + +@item +Guile, the GNU extension language, which is the subject of this +tutorial. + +@end itemize + +One lesson we can learn from looking at classical large software +applications is that "writers of large programs" always end up throwing +in some kind of parser for configuration or scripting. + +Of the examples listed above, Emacs Lisp, Tcl, Libscheme and Guile have +an important property: they are not added as an afterthought for a +specific application. They are general-purpose languages which a user +can learn (even in college courses) and then use to customize the +application program. + +This is a recent and (in my opinion) very exciting direction in +large-program software engineering: program designers can link in the +Guile or Tcl library from the very beginning, and tell their users "You +want to customize this program? Just use Scheme (or Tcl, or whatever +language), which you already know!" +@cindex large programs + + +@node History of Guile and its motivations +@section History of Guile and its motivations + +A few separate threads of events led to the development of Guile. + +In the fall of 1994, Richard Stallman, director of the GNU project, +posted an article with the subject "Why you should not use Tcl", in +which he argued that Tcl is inadequate as an extension language. This +generated a flurry of flames (available in the hypermail archive +(@url{http://www.utdallas.edu/acc/glv/Tcl/war/}) @strong{The Tcl War}). +@cindex Stallman, Richard +@cindex GNU project +@cindex Tcl + +The result was that Stallman then proposed his design for the GNU +Extension Language, first called GEL and then renamed Guile. The +discussion triggered by that article is also available in a hypermail +archive, @url{http://www.utdallas.edu/acc/glv/Tcl/war2/}. + +One interesting feature of this GNU Extension Language plan was that +users should have a @emph{choice} of languages to use in extending their +program. The basic language would be a slightly modified Scheme, and +translators would be written to convert other languages (like Tcl, +Python, Perl, C-like languages @dots{}) into Scheme. + +Tom Lord started working on this project immediately, taking Aubrey +Jaffer's small and portable implementation of Scheme, SCM, and making it +into an embeddable interpreter: callable from C and allowing new Scheme +procedures to be written in C. +@cindex Lord, Tom +@cindex Jaffer, Aubrey + +In the spring of 1995, the guile-ii snapshot was released. This made it +possible to start writing code in C and Scheme using the guile +facilities. + +The guile-iii snapshot was released the summer of 1995, and it had fixed +enough problems so that the access to Scheme data structures from C was +almost complete. + +After this, Cygnus Support added many features to Guile and finished +implementing others, so that Guile acquired thread support, a regular +expression matcher, a Tk interface, an interface to the SGI OpenGL +graphics system, an @emph{applet} formalism, and some other packages. +This was all in the Cygnus Guile r0.3 and r0.4 releases. +@cindex Cygnus Support + +Meanwhile, Tom Lord left the project after having produced a divergent +version of Guile: 1.0b2. The Free Software Foundation hired Jim Blandy +to coordinate Guile development. The FSF released its first version of +Guile in January 1997. In the future, many of the Cygnus packages will +be re-integrated into Guile. +@cindex Blandy, Jim +@cindex Free Software Foundation + + + +@node How to characterize Guile +@section How to characterize Guile + +I have already mentioned that Guile has become a kitchen sink package; +here you can see how Guile freely takes new commands and constructs from +the portable Scheme library @emph{slib}, the @emph{Tk} widget set, a +posix library (useful for UNIX systems programming), the regular +expression library @emph{rx}, and many more @dots{} +@cindex slib +@cindex Tk +@cindex POSIX +@c @cindex OpenGL +@cindex rx + +So Guile has many more primitive procedures available to it than those +specified in @ref{Standard Procedures, Revised(4) Report on the +Algorithmic Language Scheme, , r4rs, Revised(4) Report on the +Algorithmic Language Scheme}. On top of that, Guile will interpret +almost all standard Scheme programs. The only incompatible difference +between the basic Guile language and R4RS Scheme is that Guile is case +sensitive, whereas R4RS is case insensitive. We hope that few people +have written Scheme programs that depend on case insensitivity. +@cindex case sensitivity +@cindex Revised(4) Report on the Algorithmic Language Scheme +@cindex report on Scheme +@cindex Scheme language - report +@cindex Scheme language - definition + +Here is a possible view of the @emph{sum of the parts} in Guile: +@cindex extensions to standard Scheme +@cindex extensions to R4RS +@cindex Scheme extensions +@example +guile = standard Scheme (R4RS) + PLUS extensions to R4RS offered by SCM + PLUS some extra primitives offered by Guile (catch/throw) + PLUS portable Scheme library (SLIB) + PLUS embeddable Scheme interpreter library (libguile) + PLUS Tk toolkit + PLUS threads + PLUS Posix library +@c PLUS OpenGL library (mesa) +@c PLUS OpenGL toolkit (glut) + PLUS Regular expression library (rx) +@c PLUS Applet formalism + PLUS Tcl library +@end example + + +@node Using Guile to program in Scheme +@chapter Using Guile to program in Scheme +@cindex Scheme programming tutorial +@cindex tutorial on Scheme programming + +In this section I give a tutorial introduction to programming in Scheme, +with a slant toward the interesting things that can be done in Guile. + +@c Applets are so @emph{chic} that they get their own section, but this +This section will try to touch on many of the interesting and cool +aspects of Guile, showing you how new types of problems can be solved +with Guile. Note that using Guile as a library with @code{libguile.a} +is described in its own chapter (@pxref{Guile in a Library}). Also note +that some small examples are given in @ref{Jump Start}. + +To get started you need to know how to program in @dfn{Scheme} (a +dialect of LISP). Fortunately Scheme is a small, clean language and is +not hard to learn. It is also used in many undergraduate courses to +introduce computer programming. +@cindex lisp dialects + +I will not try to teach you Scheme here (although you might end up +learning by example), since there are many good books on the subject, +listed in @ref{Where to find more Guile/Scheme resources}. @footnote{To +get started, look at the books @cite{Simply Scheme} and @cite{The Little +Schemer} from that list.} + + +@subsection Hello World +@cindex hello world + +Our first program is the typical Scheme "hello world" program. Put the +following code in a file called @code{hello.scm} (this can be find in +@file{examples/scheme/hello.scm}). + +@smalllisp +#!/usr/local/bin/guile -s +!# + +(display "hello world") +(newline) +@end smalllisp + +Then run guile on it. One way to do so is to start up guile and load +this file: + +@smallexample + @kbd{guile} +guile> @kbd{(load "hello")} +@end smallexample + +Another way is to make the file executable and execute it directly. +Notice how Guile recognizes a @code{-s} option which tells it to run a +script and then exit. Guile also has a new type of block comment +enclosed by @code{#!} and @code{!#}, so that you can make executable +Scheme scripts with the standard UNIX @code{#!} mechanism. + +In the given example, the first line is used to invoke the Guile +interpreter (make sure you correct the path if you installed Guile in +something other than /usr/local/bin). Once Guile is invoked on this +file, it will understand that the first line is a comment. The comment +is then terminated with @code{!#} on the second line so as to not +interfere with the execution mechanism. + + +@subsection A bunch of operations in Scheme + +Here is some code you can type at the @code{guile>} prompt to see some +of the Scheme data types at work (mostly lists and vectors). I have +inserted brief comments @emph{before} each line of code explaining what +happens. + +@smalllisp +;; @r{make a list and bind it to the symbol @code{ls}} +guile> @kbd{(define ls (list 1 2 3 4 5 6 7))} + @result{} +;; @r{display the list} +guile> @kbd{ls} + @result{(1 2 3 4 5 6 7)} +;; @r{ask if @code{ls} is a vector; @code{#f} means it is not} +guile> @kbd{(vector? ls)} + @result{#f} +;; @r{ask if @code{ls} is a list; @code{#t} means it is} +guile> @kbd{(list? ls)} + @result{#t} +;; @r{ask for the length of @code{ls}} +guile> @kbd{(length ls)} + @result{7} +;; @r{pick out the first element of the list} +guile> @kbd{(car ls)} + @result{1} +;; @r{pick the rest of the list without the first element} +guile> @kbd{(cdr ls)} + @result{(2 3 4 5 6 7} +;; @r{this should pick out the 3rd element of the list} +guile> @kbd{(car (cdr (cdr ls)))} + @result{3} +;; @r{a shorthand for doing the same thing} +guile> @kbd{(caddr ls)} + @result{3} +;; @r{append the given list onto @code{ls}, print the result} +;; @r{@strong{NOTE:} the original list @code{ls} is @emph{not} modified} +guile> @kbd{(append ls (list 8 9 10))} + @result{(1 2 3 4 5 6 7 8 9 10)} +guile> @kbd{(reverse ls)} + @result{(10 9 8 7 6 5 4 3 2 1)} +;; @r{ask if 12 is in the list --- it obviously is not} +guile> @kbd{(memq 12 ls)} + @result{#f} +;; @r{ask if 4 is in the list --- returns the list from 4 on.} +;; @r{Notice that the result will behave as true in conditionals} +guile> @kbd{(memq 4 ls)} + @result{(4 5 6 7)} +;; @r{an @code{if} statement using the aforementioned result} +guile> @kbd{(if (memq 4 ls) + (display "hey, it's true!\n") + (display "dude, it's false\n"))} + @print{hey, it's true!} + @result{} +guile> @kbd{(if (memq 12 ls) + (display "hey, it's true!\n") + (display "dude, it's false\n"))} + @print{dude, it's false} + @result{} +guile> @kbd{(memq 4 (reverse ls))} + @result{(4 3 2 1)} +;; @r{make a smaller list @code{ls2} to work with} +guile> @kbd{(define ls2 (list 2 3 4))} +;; @r{make a list in which the function @code{sin} has been} +;; @r{applied to all elements of @code{ls2}} +guile> @kbd{(map sin ls2)} + @result{(0.909297426825682 0.141120008059867 -0.756802495307928)} +;; @r{make a list in which the squaring function has been} +;; @r{applied to all elements of @code{ls}} +guile> @kbd{(map (lambda (n) (expt n n)) ls)} + @result{(1 4 27 256 3125 46656 823543)} +@end smalllisp + +@smalllisp +;; @r{make a vector and bind it to the symbol @code{v}} +guile> @kbd{(define v #(1 2 3 4 5 6 7))} +guile> @kbd{v} + @result{#(1 2 3 4 5 6 7)} +guile> @kbd{(vector? v)} + @result{#t} +guile> @kbd{(list? v)} + @result{#f} +guile> @kbd{(vector-length v)} + @result{7} +;; @r{vector-ref allows you to pick out elements by index} +guile> @kbd{(vector-ref v 2)} + @result{3} +;; @r{play around with the vector: make it into a list, reverse} +;; @r{the list, go back to a vector and take the second element} +guile> @kbd{(vector-ref (list->vector (reverse (vector->list v))) 2)} + @result{5} +;; @r{this demonstrates that the entries in a vector do not have} +;; @r{to be of uniform type} +guile> @kbd{(vector-set! v 4 "hi there")} + @result{"hi there"} +guile> @kbd{v} + @result{#(1 2 3 4 "hi there" 6 7)} +@end smalllisp + + +@subsection Using recursion to process lists +@cindex recursion +@cindex list processing + +Here are some typical examples of using recursion to process a list. + +@smalllisp +;; @r{this is a rather trivial way of reversing a list} +(define (my-reverse l) + (if (null? l) + l + (append (my-reverse (cdr l)) (list (car l))))) +(my-reverse '(27 32 33 40)) +@result{(40 33 32 27)} +@end smalllisp + + +@subsection Processing matrices + +Suppose you have a matrix represented as a list of lists: + +@smalllisp +(define m + (list + (list 7 2 1 3 2 8 5 3 6) + (list 4 1 1 1 3 8 9 8 1) + (list 5 5 4 8 1 8 2 2 4))) +@end smalllisp + +Then you could apply a certain function to each element of the matrix in +the following manner: +@smalllisp +;; @r{apply the function func to the matrix m element-by-element;} +;; @r{return a matrix with the result.} +(define (process-matrix m func) + (map (lambda (l) + (map func l)) + m)) +@end smalllisp +Notice that I have used the Scheme @code{map} procedure because I am +interested in the matrix that results from the application of +@code{func}, rather than in the side effects associated with applying +@code{func}. + +This could be invoked with @code{(process-matrix m sin)} or +@code{(process-matrix m (lambda (x) (* x x)))}; for example: + +@smalllisp +(process-matrix m (lambda (x) (* x x))) +@result{((49 4 1 9 4 64 25 9 36) (16 1 1 1 9 64 81 64 1) (25 25 16 64 1 64 4 4 16))} +@end smalllisp + +To print a representation of the matrix, we could define a generalized +routine: +@smalllisp +;; @r{proc is a procedure to represent the single element,} +;; @r{row-proc is a procedure that is invoked after each row.} +;; @r{Example: proc could be (lambda (x) (begin (display x) (display " ")))} +;; @r{and row-proc could be (lambda (l) (display "\n"))} +(define (represent-matrix m proc row-proc) + (for-each (lambda (l) + (begin + (for-each proc l) + (row-proc l))) + m)) +@end smalllisp +@findex represent-matrix + +And then invoke it with +@smalllisp +(represent-matrix m + (lambda (x) (begin (display x) (display " "))) + (lambda (l) (begin (display "\n")))) +@print{7 2 1 3 2 8 5 3 6} +@print{4 1 1 1 3 8 9 8 1} +@print{5 5 4 8 1 8 2 2 4} +@end smalllisp + +@cindex objects + +Now we write a helper routine that uses Scheme @dfn{closures} to make +objects with state that then receive messages to draw little squares. +@cindex closures +@cindex syntactic closures + +But let us take it one step at a time. I will start by showing you a +simple example of object in Scheme. The object I make here represents a +cell, which could be a cell in a matrix. The cell responds to commands +to draw itself, to return the next cell, and so forth. @emph{Guile does +not currently have a Tk interface, so I will leave the hooks for +graphical rendering. In a future release of Guile I will add graphical +rendering messages to the cell object.} + +@smallexample +;; @r{cell-object.scm: routines for creating and manipulating cell objects} + +;; @r{(the-x, the-y) is the initial position of the cell.} +;; @r{the-color is a string representing a color; must be something Tk can grok.} +;; @r{square-size is the size of the square that gets drawn.} +;; @r{(sizex, sizey) is the size of the matrix.} +(define (MAKE-CELL the-x the-y the-color square-size sizex sizey) + (define (get-x) the-x) + (define (get-y) the-y) + + (define (set-x! new-x) + (set! the-x new-x) + the-x) + (define (set-y! new-y) + (set! the-y new-y) + the-y) + (define (get-color) the-color) + (define (set-color! new-color) + (set! the-color new-color) + the-color) + (define (next!) + (set! the-x (+ the-x 1)) + (if (>= the-x sizex) + (begin + (set! the-x 0) + (set! the-y (+ the-y 1)))) + (if (>= the-y sizey) + (begin + (display "CELL next!: value of y is too big; not changing it\n") + (set! the-y (- the-y 1)))) + (cons the-x the-y)) + (define (draw) + (let* ((x0 (* the-x square-size)) + (y0 (* the-y square-size)) + (x1 (+ x0 square-size)) + (y1 (+ y0 square-size))) + (display "I should draw a ") + (display the-color) + (display " rectangle with corners at ") + (display x0) (display y0) (display x1) (display y1) + )) + + ;; self is the dispatch procedure + (define (self message) + (case message + ((x) get-x) + ((y) get-y) + ((set-x!) set-x!) + ((set-y!) set-y!) + ((color) get-color) + ((set-color!) set-color!) + ((next!) next!) + ((draw) draw) + (else (error "CELL: Unknown message -> " message)))) + ;; and now return the dispatch procedure + self + ) +@end smallexample +@cindex cell-object +@findex MAKE-CELL + +What does this procedure do? It returns another procedure +(@code{self}) which receives a message (x, y, set-x!, set-y!, @dots{}) +and takes an action to return or modify its state. The state consists +of the values of variables @code{the-x}, @code{the-y}, @code{the-color} +and so forth. + +Here are some examples of how to use MAKE-CELL and the cell object it +creates: +@smallexample +(define c (MAKE-CELL 0 0 "red" 10 7 9)) + +;; @r{retrieve the x and y coordinates} +((c 'x)) +@result{0} +((c 'y)) +@result{0} +;; @r{change the x coordinate} +((c 'set-x!) 5) +@result{5} +((c 'x)) +@result{5} +;; @r{change the color} +((c 'color)) +@result{"red"} +((c 'set-color!) "green") +@result{"green"} +((c 'color)) +@result{"green"} +;; @r{now use the next! message to move to the next cell} +((c 'next!)) +@result{(6 . 0)} +((c 'x)) +@result{6} +((c 'y)) +@result{0} +;; @r{now make things wrap around} +((c 'next!)) +@result{(0 . 1)} +((c 'next!)) +@result{(1 . 1)} +((c 'next!)) +@result{(2 . 1)} +((c 'x)) +@result{2} +((c 'y)) +@result{1} +@end smallexample + +You will notice that expressions like @code{(c 'next)} return procedures +that do the job, so we have to use extra parentheses to make the job +happen. This syntax is rather awkward; one way around it is to define a +@code{send} procedure: + +@smallexample +;; @r{send makes object syntax a bit easier; instead of saying} +;; @r{ ((my-cell 'set-x!) 4)} +;; @r{you can say} +;; @r{ (send my-cell 'set-x! 4)} +(define (send obj . args) + (let ((first-eval (apply obj (list (car args))))) + (if (null? (cdr args)) + (first-eval) + (apply first-eval (cdr args))))) +@end smallexample +@findex send + +You can see that @code{send} passes the message to the object, making +sure that things are evaluated the proper number of times. You can now +type: + +@smallexample +(define c2 (MAKE-CELL 0 0 "red" 10 7 9)) +(send c2 'x) +@result{0} +(send c2 'set-x! 5) +@result{5} +(send c2 'color) +@result{"red"} +(send c2 'set-color! "green") +@result{"green"} +(send c2 'next!) +@result{(1 . 0)} +(send c2 'x) +@result{1} +(send c2 'y) +@result{0} +@end smallexample + +@cindex object-based programming +@cindex object-oriented programming + +This is the simplest way of implementing objects in Scheme, but it does +not really allow for full @emph{object-oriented programming} (for +example, there is no inheritance). But it is useful for +@emph{object-based programming}. + +Guile comes with a couple more complete object-oriented extensions to +Scheme: these are part of slib (@pxref{Object, , , slib, SLIB: the +portable Scheme library} and @pxref{Yasos, , , slib, SLIB: the portable +Scheme library}). + +@node Guile in a Library +@chapter Guile in a Library + +@iftex +@nobreak +@end iftex +In the previous chapters Guile was used to write programs entirely in +Scheme, and no C code was seen; but I have been claiming @emph{ad +nauseam} that Guile is an @emph{extension} language. Here we see how +that is done, and how that can be useful. +@cindex libguile +@cindex extending C programs + + +@menu +* Two world views:: +* What is libguile:: +* How to get started with libguile:: +* More interesting programming with libguile:: +* Further examples:: +@end menu + +@node Two world views +@section Two world views +@cindex master world + +In this manual, I usually jump into examples and explain them as you +type in the code; here I will digress and ramble for a few paragraphs to +set some concepts straight, and then let you type (or paste) in fun +examples. + +In 1995, I implemented a large program, @dfn{Gnudl}, using Guile quite +extensively. In the design phase of Gnudl, I found I had to make a +choice: should the fundamental data structures be C or Scheme data +structures? +@cindex gnudl +@cindex GNU Data Language +@cindex Galassi, Mark + +Guile allows C to see its data structures (scalar types, lists, vectors, +strings @dots{}). C also allows Guile to see its data structures. As a +large program designer, you have to decide which of those capabilities +to use. You have two main choices: + +@enumerate 1 +@item +You can write your software mostly in Scheme. In this case, your C +software will mostly parse the Scheme code with Guile calls, and provide +some new primitive procedures to be used by Scheme. This is what Gnudl +does. + +@item +You can write your software mostly in C, occasionally allowing Scheme +code to be parsed by Guile, either to allow the user to modify data +structures, or to parse a configuration file, @dots{} +@end enumerate + +Mixing the two approaches seems unwise: the overall layout would be +confusing. But who knows? There might be problems that are best solved +by a hybrid approach. Please let me know if you think of such a +problem. + +If you use the former approach, we will say that the @dfn{master world} +is Scheme, and the C routines serve Scheme and access Scheme data +structures. In the latter case, the master world is C, and Scheme +routines serve the C code and access C data structures. + +In both approaches the @code{libguile.a} library is the same, but a +predominantly different set of routines will be used. When we go +through examples of libguile use, we will point out which is the master +world in order to clarify these two approaches. + + +@node What is libguile +@section What is libguile +@cindex libguile +@cindex gh interface +@cindex scm interface + +@dfn{Libguile} is the library which allows C programs to start a Scheme +interpreter and execute Scheme code. There are also facilities in +libguile to make C data structures available to Scheme, and vice versa. + +The interface provided by the libguile C library is somewhat specific to +the implementation of the Scheme interpreter. This low-level libguile +interface is usually referred to as the @code{scm_} interface, since its +public calls (API) all have the @code{scm_} prefix. + +There is also a higher-level libguile interface, which is usually +referred to as the @code{gh_} interface (libGuile High). Its public +calls all have the @code{gh_} prefix. The @code{gh_} library interface +is designed to hide the implementation details, thus making it easier to +assimilate and portable to other underlying Scheme implementations. + +People extending Guile by adding bindings to C libraries (like OpenGL or +Rx) are encouraged to use the @code{gh_} interface, so their work will +be portable to other Scheme systems. The @code{gh_} interface should be +more stable, because it is simpler. + +The @code{scm_} interface is necessary if you want to poke into the +innards of Scheme data structures, or do anything else that is not +offered by the @code{gh_} interface. It is not covered in this +tutorial, but is covered extensively in @ref{Scheme data representation, +Guile Reference Manual, guile-ref, Guile Reference Manual}. + +This chapter gives a gentle introduction to the @code{gh_} interface, +presenting some @emph{hello world}-style programs which I wrote while +teaching myself to use libguile. +@cindex hello world + +The @cite{Guile Programmer's Manual} gives more examples of programs +written using libguile, illustrating diverse applications. You can also +consult my @emph{Gnudl} documentation at +@url{http://nis-www.lanl.gov/~rosalia/mydocs/} to see a large scale +project that uses C and Scheme code together. + + +@node How to get started with libguile +@section How to get started with libguile +@cindex learn0 + +Here is an elementary first program, @code{learn0}, to get going with +libguile. The program (which uses Scheme as a master world) is in a +single source file, @code{learn0.c}: + +@smallexample +/* @r{test the new libgh.a (Guile High-level library) with a trivial + program} */ + +#include + +#include + +void main_prog(int argc, char *argv[]); + +main(int argc, char *argv[]) +@{ + gh_enter(argc, argv, main_prog); +@} + +void main_prog(int argc, char *argv[]) +@{ + int done; + char input_str[200]; + + gh_eval_str("(display \"hello Guile\")"); + gh_eval_str("(newline)"); + + /* @r{for fun, evaluate some simple Scheme expressions here} */ + gh_eval_str("(define (square x) (* x x))"); + gh_eval_str("(define (fact n) (if (= n 1) 1 (* n (fact (- n 1)))))"); + gh_eval_str("(square 9)"); + + /* @r{now sit in a Scheme eval loop: I input the expressions, have + Guile evaluate them, and then get another expression.} */ + done = 0; + fputs("learn0> ", stdout); + while (fgets(input_str, 199, stdin) != NULL) @{ + gh_eval_str(input_str); + fputs("\nlearn0> ", stdout); + @} + + exit(0); +@} +@end smallexample + +If you name this program @code{learn0.c}, it can now be compiled with: +@smallexample +gcc -g -c learn0.c -o learn0.o +gcc -o learn0 learn0.o -lguile -lm +@end smallexample + +@c @emph{NOTE: If you are in the Guile development tree, you can simply do +@c ``cd doc/examples/c; make; ./learn0''.} + +The program is simple: it creates a Scheme interpreter, passes a couple +of strings to it that define new Scheme functions @code{square} and +@code{factorial}, and then a couple of strings that invoke those +functions. + +It then goes into a read-eval-print-loop (REPL), so you could type +one-line Scheme expressions to it and have them evaluated. For example: +@smallexample + ./learn0 +hello Guile +learn0> (display (sin 1.3)) +963.558185417193e-3 +learn0> (display (fact 10)) +3628800 +learn0> (quit) + +@end smallexample + +You should notice the key steps involved in this @code{learn0} program: + +@cartouche +@enumerate +@item +@code{#include } +@item +You need to invoke the initialization routine @code{gh_enter()}. This +starts up a Scheme interpreter, handling many implementation-specific +details. +@item +Your main() function should be almost empty: the real main program goes +in a separate function main_prog() which is passed to gh_enter(). This +rather arcane convention is due to the way Guile's garbage collector +works: the whole program has to run in the dynamic context of +@code{gh_enter()}. +@item +You pass strings to the Scheme interpreter with the @code{gh_eval_str()} +routine. +@item +You link your program with @code{-lguile}. +@end enumerate +@end cartouche + + +@node More interesting programming with libguile +@section More interesting programming with libguile +@cindex learn1 +@cindex callback +@cindex builtin functions + +The @code{learn0} program shows how you can invoke Scheme commands from +a C program. This is not such a great achievement: the same could have +been done by opening a pipe to SCM or any other Scheme interpreter. + +A true extension language must allow @dfn{callbacks}. Callbacks allow +you to write C routines that can be invoked as Scheme procedures, thus +adding new primitive procedures to Scheme. This also means that a +Scheme procedure can modify a C data structure. + +Guile allows you to define new Scheme procedures in C, and provides a +mechanism to go back and forth between C and Scheme data types. + +Here is a second program, @code{learn1}, which demonstrates these +features. It is split into three source files: @code{learn1.c}, +@code{c_builtins.h} and @code{c_builtins.c}. I am including the code +here. +@c , but you might just want to look at the online source code and the +@c Makefile.am that come with Guile in the +@c @file{doc/examples/c} directory. + +Notice that @code{learn1} uses a Scheme master world, and the C routines +in @code{c_builtins.c} are simply adding new primitives to Scheme. + +@menu +* learn1.c:: +* c_builtins.h:: +* c_builtins.c:: +* What learn1 is doing:: +* Compiling and running learn1:: +@end menu + +@node learn1.c +@subsection learn1.c + +Here is @file{learn1.c}: +@smallexample +#include + +#include + +#include "c_builtins.h" + +void main_prog(int argc, char *argv[]); + +main(int argc, char *argv[]) +@{ + gh_enter(argc, argv, main_prog); +@} + +void main_prog(int argc, char *argv[]) +@{ + char input_str[200]; /* @r{ugly hack: assume strlen(line) < 200} */ + int done; + + /* @r{for fun, evaluate some simple Scheme expressions here} */ + gh_eval_str("(define (square x) (* x x))"); + gh_eval_str("(define (fact n) (if (= n 1) 1 (* n (fact (- n 1)))))"); + gh_eval_str("(square 9)"); + gh_eval_str("(fact 100)"); + + /* @r{now try to define some new builtins, coded in C, so that they are + available in Scheme.} */ + gh_new_procedure1_0("c-factorial", c_factorial); + gh_new_procedure1_0("c-sin", c_sin); + gh_new_procedure1_0("v-t", vector_test); + + /* @r{now sit in a Scheme eval loop: I input the expressions, have + Guile evaluate them, and then get another expression.} */ + done = 0; + fputs("learn1> ", stdout); + while (!done) @{ + if (gets(input_str) == NULL) @{ + done = 1; + @} else @{ + gh_eval_str(input_str); + fputs("learn1> ", stdout); + @} + @} + + exit(0); +@} +@end smallexample + +@node c_builtins.h +@subsection c_builtins.h + +Here is @file{c_builtins.h}: +@smallexample +/* @r{builtin function prototypes} */ + +#include + +SCM c_factorial(SCM n); +SCM c_sin(SCM n); +SCM vector_test(SCM s_length); +@end smallexample + +@node c_builtins.c +@subsection c_builtins.c + +Here is @file{c_builtins.c}: +@smallexample +#include +#include + +#include + +#include "c_builtins.h" + +/* @r{this is a factorial routine in C, made to be callable by Scheme} */ +SCM c_factorial(SCM s_n) +@{ + int i; + unsigned long result = 1, n; + + n = gh_scm2ulong(s_n); + + gh_defer_ints(); + for (i = 1; i <= n; ++i) @{ + result = result*i; + @} + gh_allow_ints(); + return gh_ulong2scm(result); +@} + +/* @r{a sin routine in C, callable from Scheme. it is named c_sin() to + distinguish it from the default Scheme sin function} */ +SCM c_sin(SCM s_x) +@{ + double x = gh_scm2double(s_x); + + return gh_double2scm(sin(x)); +@} + +/* @r{play around with vectors in Guile: this routine creates a vector of + the given length, initializes it all to zero except element 2 which + is set to 1.9.} */ +SCM vector_test(SCM s_length) +@{ + SCM xvec; + + c_length = gh_scm2ulong(s_length); + printf("requested length for vector: %ld\n", gh_scm2ulong(s_length)); + + /* create a vector */ + xvec = gh_make_vector(s_length, gh_double2scm(0.0)); + /* set the second element in it */ + gh_vector_set_x(xvec, gh_int2scm(2), gh_double2scm(1.9)); + + return xvec; +@} +@end smallexample + +@node What learn1 is doing +@subsection What learn1 is doing +@cindex registering callbacks +@cindex registering C functions +@cindex primitive procedures + +If you compare learn1 to learn0, you will find that learn1 uses a new +Guile construct: the function @code{gh_new_procedure()}, and its +siblings: + +@smallexample + /* @r{now try to define some new builtins, coded in C, so that they are + available in Scheme.} */ + gh_new_procedure1_0("c-factorial", c_factorial); + gh_new_procedure1_0("c-sin", c_sin); + gh_new_procedure1_0("v-t", vector_test); +@end smallexample + +It is clear that @code{gh_new_procedure()} adds a new builtin +routine written in C which can be invoked from Scheme. We can now +revise our checklist for programming with libguile, so it includes +adding callbacks. +@cindex libguile - step by step + +@cartouche +@enumerate +@item +@code{#include } +@item +You need to invoke the initialization routine @code{gh_enter()}. This +starts up a Scheme interpreter, handling many details. +@item +Your main() function should be almost empty: the real main program goes +in a separate function main_prog() which is passed to gh_enter(). This +rather arcane convention is due to the way Guile's garbage collector +works: the whole program has to run in the dynamic context of +@code{gh_enter()}. +@item +You pass strings to the Scheme interpreter with the @code{gh_eval_str()} +routine. +@item +@strong{[new]} You can now define new builtin Scheme functions; +i.e. define new builtin Scheme functions, with the +@code{gh_new_procedure()} routine. +@item +You pass strings to the Scheme interpreter with the +@code{gh_eval_str()} routine. +@item +You link your program with @code{-lguile}. +@end enumerate +@end cartouche + +I breezed by the issue of how to write your C routines that are +registered to be called from Scheme. This is non-trivial, and is +discussed at length in the @cite{Guile Programmer's Manual}. + + +@node Compiling and running learn1 +@subsection Compiling and running learn1 + +@smallexample +gcc -g -c learn1.c -o learn1.o +gcc -g -c c_builtins.c -o c_builtins.o +gcc -o learn1 learn1.o c_builtins.o -lguile -lm +@end smallexample + +If you run @code{learn1}, it will prompt you for a one-line Scheme +expression, just as @code{learn0} did. The difference is that you can +use the new C builtin procedures (@code{c-factorial}, @code{c-sin}, +@code{v-t}). + +@smallexample + ./learn1 +welcome to Guile +hello Guile +learn1> (display (c-factorial 6)) +720 +learn1> (display (c-factorial 20)) +2192834560 +learn1> (display (c-factorial 100)) +0 +learn1> (display (c-sin 1.5)) +0.997494986604054 +learn1> (display (v-t 10)) +requested length for vector: 10 +#(0.0 0.0 1.9 0.0 0.0 0.0 0.0 0.0 0.0 0.0) +learn1> (display (v-t 15)) +requested length for vector: 15 +#(0.0 0.0 1.9 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0) +learn1> (quit) + +@end smallexample + +As you see, taking @code{(c-factorial 100)} does not use bignumbers and +returns a bogus answer. + +@node Further examples +@section Further examples + +Further ``idealized'' examples are included in the @code{doc/examples/c} +distribution. They include programs to: + +@c [FIXME: still have to write some of these; then I will revise the list.] + +@itemize @bullet +@item +Parse a startup file (C is the master world). +@item +Set up initial conditions for an n-body simulation (C is the master +world). +@item +Implement a Scheme interpreter with all of Guile's goodies, @emph{plus} +the readline library @emph{and} a fast Fourier transform routine +provided in C (Scheme is the master world). +@end itemize + +@node Regular Expression Support +@chapter Regular Expression Support + +@node UNIX System Programming +@chapter UNIX System Programming + +@node Where to find more Guile/Scheme resources +@chapter Where to find more Guile/Scheme resources + + +@node Concept Index +@unnumbered Concept Index + +@printindex cp + +@node Procedure and Macro Index +@unnumbered Procedure and Macro Index + +This is an alphabetical list of all the procedures and macros in Dominion. + +@printindex fn + +@node Variable Index +@unnumbered Variable Index + +This is an alphabetical list of the major global variables in Dominion. + +@printindex vr + +@node Type Index +@unnumbered Type Index + +This is an alphabetical list of the major data structures in Dominion. + +@printindex tp + +@contents + +@bye From a17bb5fdc22fae3b19c08ebd1becdf63fc929f17 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 23 Mar 2001 16:14:47 +0000 Subject: [PATCH 0751/2047] * Fix docstring typos. --- libguile/ChangeLog | 7 +++++++ libguile/list.c | 2 +- libguile/strop.c | 3 ++- 3 files changed, 10 insertions(+), 2 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6ca3b0526..42d81ecfe 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2001-03-23 Neil Jerram + + * strop.c (scm_string_index): Fix docstring line break + regression. + + * list.c (scm_cons_star): Fix docstring typo. + 2001-03-22 Dirk Herrmann * gc.c (scm_init_storage), gdbint.c (scm_init_gdbint), numbers.c diff --git a/libguile/list.c b/libguile/list.c index 5f809035d..d5b486bdf 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -99,7 +99,7 @@ SCM_DEFINE (scm_cons_star, "cons*", 1, 0, 1, (SCM arg, SCM rest), "Like @code{list}, but the last arg provides the tail of the\n" "constructed list, returning @code{(cons @var{arg1} (cons\n" - "@var{arg2} (cons @dots{} @var{argn}))). Requires at least one\n" + "@var{arg2} (cons @dots{} @var{argn})))}. Requires at least one\n" "argument. If given one argument, that argument is returned as\n" "result. This function is called @code{list*} in some other\n" "Schemes and in Common LISP.") diff --git a/libguile/strop.c b/libguile/strop.c index a7f2911ba..756478f08 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -104,7 +104,8 @@ SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0, "@var{str}. The optional integer arguments @var{frm} and\n" "@var{to} limit the search to a portion of the string. This\n" "procedure essentially implements the @code{index} or\n" - "@code{strchr} functions from the C library.\n (qdocs:) Returns\n" + "@code{strchr} functions from the C library.\n\n" + "(qdocs:) Returns\n" "the index of @var{char} in @var{str}, or @code{#f} if the\n" "@var{char} isn't in @var{str}. If @var{frm} is given and not\n" "@code{#f}, it is used as the starting index; if @var{to} is\n" From 8d009ee4a25b1f429186872198b969ca2a13436d Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 23 Mar 2001 16:16:15 +0000 Subject: [PATCH 0752/2047] * Fix typos. --- doc/ChangeLog | 3 +++ doc/intro.texi | 4 ++-- doc/scheme-data.texi | 2 +- 3 files changed, 6 insertions(+), 3 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index a8fa6345e..86d5ad418 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,5 +1,8 @@ 2001-03-23 Neil Jerram + * intro.texi (Writing Extensions for Guile), scheme-data.texi + (Lists): Fix typos. + * guile-tut.texi, ChangeLog-guile-doc-tutorial: Added to CVS. It seems that I somehow missed these out when I moved everything from guile-doc to guile-core. diff --git a/doc/intro.texi b/doc/intro.texi index ffd2346c5..933fefa40 100644 --- a/doc/intro.texi +++ b/doc/intro.texi @@ -1,4 +1,4 @@ -@c $Id: intro.texi,v 1.2 2001-03-12 00:50:08 mvo Exp $ +@c $Id: intro.texi,v 1.3 2001-03-23 16:16:15 ossau Exp $ @page @node What is Guile? @@ -591,7 +591,7 @@ make use of an embedded Guile interpreter. But sometimes, all you want to do is make new primitive procedures and data types available to the Scheme programmer. Writing a new version of @code{guile} is inconvenient in this case and it would in fact make the life of the -users of your new fetaures needlessly hard. +users of your new features needlessly hard. @c [[ the following is probably a bit longwinded ]] diff --git a/doc/scheme-data.texi b/doc/scheme-data.texi index 7bbf89760..22cdf2888 100755 --- a/doc/scheme-data.texi +++ b/doc/scheme-data.texi @@ -2920,7 +2920,7 @@ Return a list containing @var{objs}, the arguments to @deffn primitive cons* arg . rest Like @code{list}, but the last arg provides the tail of the constructed list, returning @code{(cons @var{arg1} (cons -@var{arg2} (cons @dots{} @var{argn}))). Requires at least one +@var{arg2} (cons @dots{} @var{argn})))}. Requires at least one argument. If given one argument, that argument is returned as result. This function is called @code{list*} in some other Schemes and in Common LISP. From a6be01a45e3467725e225720cd99619128444e69 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 23 Mar 2001 17:24:28 +0000 Subject: [PATCH 0753/2047] * Minor docstring updates. --- doc/maint/README | 5 ++-- doc/maint/guile.texi | 54 +++++++++++++++++++------------------ doc/new-docstrings.texi | 4 +++ libguile/ChangeLog | 2 ++ libguile/guile-snarf.awk.in | 1 + 5 files changed, 38 insertions(+), 28 deletions(-) diff --git a/doc/maint/README b/doc/maint/README index 0a46418bc..d88589325 100644 --- a/doc/maint/README +++ b/doc/maint/README @@ -8,8 +8,9 @@ in the libguile C source change. - README is this file. -- docstring.el is a helpful Emacs Lisp library. The usual entry point - is `docstring-process-current-buffer'. +- docstring.el is a helpful Emacs Lisp library. The two key entry + points are `docstring-process-module' and + `docstring-ediff-this-line'. - guile.texi is a snapshot of the built file guile-core/libguile/guile.texi, copied last time the reference diff --git a/doc/maint/guile.texi b/doc/maint/guile.texi index bb7dd4522..d51d06804 100644 --- a/doc/maint/guile.texi +++ b/doc/maint/guile.texi @@ -2464,7 +2464,7 @@ scm_cons_star @deffn primitive cons* arg . rest Like @code{list}, but the last arg provides the tail of the constructed list, returning @code{(cons @var{arg1} (cons -@var{arg2} (cons @dots{} @var{argn}))). Requires at least one +@var{arg2} (cons @dots{} @var{argn})))}. Requires at least one argument. If given one argument, that argument is returned as result. This function is called @code{list*} in some other Schemes and in Common LISP. @@ -5747,13 +5747,15 @@ defaults to the end of @var{str}. The shared substring returned by @end deffn string-index -@c snarfed from strop.c:120 +@c snarfed from strop.c:121 @deffn primitive string-index str chr [frm [to]] Return the index of the first occurrence of @var{chr} in @var{str}. The optional integer arguments @var{frm} and @var{to} limit the search to a portion of the string. This procedure essentially implements the @code{index} or -@code{strchr} functions from the C library.\n (qdocs:) Returns +@code{strchr} functions from the C library. + +(qdocs:) Returns the index of @var{char} in @var{str}, or @code{#f} if the @var{char} isn't in @var{str}. If @var{frm} is given and not @code{#f}, it is used as the starting index; if @var{to} is @@ -5761,19 +5763,19 @@ given and not @code{#f}, it is used as the ending index (exclusive). @example -(string-index "weiner" #\\e) +(string-index "weiner" #\e) @result{} 1 -(string-index "weiner" #\\e 2) +(string-index "weiner" #\e 2) @result{} 4 -(string-index "weiner" #\\e 2 4) +(string-index "weiner" #\e 2 4) @result{} #f @end example @end deffn string-rindex -@c snarfed from strop.c:151 +@c snarfed from strop.c:152 @deffn primitive string-rindex str chr [frm [to]] Like @code{string-index}, but search from the right of the string rather than from the left. This procedure essentially implements the @@ -5784,31 +5786,31 @@ of @var{char} in the range [@var{frm}, @var{to}-1], which defaults to the entire string. @example -(string-rindex "weiner" #\\e) +(string-rindex "weiner" #\e) @result{} 4 -(string-rindex "weiner" #\\e 2 4) +(string-rindex "weiner" #\e 2 4) @result{} #f -(string-rindex "weiner" #\\e 2 5) +(string-rindex "weiner" #\e 2 5) @result{} 4 @end example @end deffn substring-move-left! -@c snarfed from strop.c:168 +@c snarfed from strop.c:169 @deffn primitive substring-move-left! scm_substring_move_x @end deffn substring-move-right! -@c snarfed from strop.c:169 +@c snarfed from strop.c:170 @deffn primitive substring-move-right! scm_substring_move_x @end deffn substring-move! -@c snarfed from strop.c:243 +@c snarfed from strop.c:244 @deffn primitive substring-move! str1 start1 end1 str2 start2 @deffnx primitive substring-move-left! str1 start1 end1 str2 start2 @deffnx primitive substring-move-right! str1 start1 end1 str2 start2 @@ -5831,7 +5833,7 @@ are different strings, it does not matter which function you use. @end deffn substring-fill! -@c snarfed from strop.c:279 +@c snarfed from strop.c:280 @deffn primitive substring-fill! str start end fill Change every character in @var{str} between @var{start} and @var{end} to @var{fill-char}. @@ -5840,14 +5842,14 @@ Change every character in @var{str} between @var{start} and @var{end} to @example (define y "abcdefg") -(substring-fill! y 1 3 #\\r) +(substring-fill! y 1 3 #\r) y @result{} "arrdefg" @end example @end deffn string-null? -@c snarfed from strop.c:306 +@c snarfed from strop.c:307 @deffn primitive string-null? str Return @code{#t} if @var{str}'s length is nonzero, and @code{#f} otherwise. @@ -5864,7 +5866,7 @@ otherwise. @end deffn string->list -@c snarfed from strop.c:322 +@c snarfed from strop.c:323 @deffn primitive string->list str @samp{String->list} returns a newly allocated list of the characters that make up the given string. @samp{List->string} @@ -5875,20 +5877,20 @@ inverses so far as @samp{equal?} is concerned. (r5rs) @end deffn string-copy -@c snarfed from strop.c:347 +@c snarfed from strop.c:348 @deffn primitive string-copy str Returns a newly allocated copy of the given @var{string}. (r5rs) @end deffn string-fill! -@c snarfed from strop.c:360 +@c snarfed from strop.c:361 @deffn primitive string-fill! str chr Stores @var{char} in every element of the given @var{string} and returns an unspecified value. (r5rs) @end deffn string-upcase! -@c snarfed from strop.c:396 +@c snarfed from strop.c:397 @deffn primitive string-upcase! str Destructively upcase every character in @code{str}. @@ -5904,13 +5906,13 @@ y @end deffn string-upcase -@c snarfed from strop.c:408 +@c snarfed from strop.c:409 @deffn primitive string-upcase str Upcase every character in @code{str}. @end deffn string-downcase! -@c snarfed from strop.c:443 +@c snarfed from strop.c:444 @deffn primitive string-downcase! str Destructively downcase every character in @code{str}. @@ -5929,25 +5931,25 @@ y @end deffn string-downcase -@c snarfed from strop.c:455 +@c snarfed from strop.c:456 @deffn primitive string-downcase str Downcase every character in @code{str}. @end deffn string-capitalize! -@c snarfed from strop.c:492 +@c snarfed from strop.c:493 @deffn primitive string-capitalize! str Destructively capitalize every character in @code{str}. @end deffn string-capitalize -@c snarfed from strop.c:504 +@c snarfed from strop.c:505 @deffn primitive string-capitalize str Capitalize every character in @code{str}. @end deffn string-ci->symbol -@c snarfed from strop.c:516 +@c snarfed from strop.c:517 @deffn primitive string-ci->symbol str Return the symbol whose name is @var{str}, downcased in necessary(???). @end deffn diff --git a/doc/new-docstrings.texi b/doc/new-docstrings.texi index 1626e9e6a..2487d354b 100644 --- a/doc/new-docstrings.texi +++ b/doc/new-docstrings.texi @@ -597,3 +597,7 @@ temporary file. @deffn primitive %tag-body body Internal GOOPS magic---don't use this function! @end deffn + +@deffn primitive list* +scm_cons_star +@end deffn diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 42d81ecfe..6856da998 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,7 @@ 2001-03-23 Neil Jerram + * guile-snarf.awk.in: Substitute "\\" with "\" in .doc output. + * strop.c (scm_string_index): Fix docstring line break regression. diff --git a/libguile/guile-snarf.awk.in b/libguile/guile-snarf.awk.in index 034aa9e6c..64641efad 100644 --- a/libguile/guile-snarf.awk.in +++ b/libguile/guile-snarf.awk.in @@ -104,6 +104,7 @@ BEGIN { FS="|"; gsub(/\\n\\n\"?/,"\n",copy); gsub(/\\n\"?[ \t]*$/,"",copy); gsub(/\\\"/,"\"",copy); + gsub(/\\\\/,"\\",copy); gsub(/[ \t]*$/,"", copy); if (copy != "") { print copy > dot_doc_file } } From 95a62aedd83fe32f18e29bc39fba7226a8740696 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 25 Mar 2001 00:31:10 +0000 Subject: [PATCH 0754/2047] * intro.texi (Modules and Extensions): Some short text about dynamic libraries and modules. --- doc/intro.texi | 54 +++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 45 insertions(+), 9 deletions(-) diff --git a/doc/intro.texi b/doc/intro.texi index 933fefa40..48bc59e07 100644 --- a/doc/intro.texi +++ b/doc/intro.texi @@ -1,4 +1,4 @@ -@c $Id: intro.texi,v 1.3 2001-03-23 16:16:15 ossau Exp $ +@c $Id: intro.texi,v 1.4 2001-03-25 00:31:10 mvo Exp $ @page @node What is Guile? @@ -63,7 +63,7 @@ used. * Guile Scripts:: * Linking Programs With Guile:: * Writing Extensions for Guile:: -* Writing Guile Modules:: +* Guile Modules:: @end menu @@ -688,20 +688,56 @@ directories listed in the @code{LTDL_LIBRRAY_PATH} environment variable. To see how these Guile extensions via shared libraries relate to the module system, see below REFFIXME. -@node Writing Guile Modules -@section Writing Guile Modules +@node Guile Modules +@section Guile Modules Guile has support for dividing a program into @dfn{modules}. By using -modules, you can group related code together and manage the composition -of complete programs from their largely independent parts. +modules, you can group related code together and manage the +composition of complete programs from largely independent parts. (The module system is in flux, and will likely look very different in the future. Feel free to use the existing system anyway. Guile will provide reasonable backwards compatability.) -[[ more stuff to follow: how to load third-party modules, how to write -new modules, how to arrange for autoloading, how to load shared -libraries as modules. ]] +@menu +* Using Guile Modules:: +* Writing New Modules:: +* Modules and Extensions:: +@end menu + +@node Using Guile Modules +@subsection Using Existing Modules + +To be written. + +@node Writing New Modules +@subsection Writing New Modules + +To be written. + +@node Modules and Extensions +@subsection Modules and Extensions + +In addition to Scheme code you can also put new procedures and other +named features that are provided by an extension into a module. + +You do this by writing a small Scheme file that defines the module. +That Scheme file in turn invokes @code{dynamic-link} and +@code{dynamic-call} as explained above to make the extension +available. + +Suppose we want to put the Bessel function @code{j0} from the example +extension into a module called @code{(math bessel)}. We would have to +write a Scheme file with this contents + +@smallexample +(define-module (math bessel)) + +(dynamic-call "init_bessel" (dynamic-link "libguile-bessel")) +@end smallexample + +The file should of course be saved in the right place for autolading, +for example as @file{/usr/local/share/guile/math/bessel.scm}. @page @node Reporting Bugs From fb73809f98ad244f063792641adf6d1645f32262 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 25 Mar 2001 00:32:07 +0000 Subject: [PATCH 0755/2047] * Makefile.am (ice9_sources): Added "time.scm". --- ice-9/Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index b3c276242..cd68f6ca9 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -31,7 +31,7 @@ ice9_sources = \ rdelim.scm receive.scm srfi-8.scm regex.scm runq.scm \ safe-r5rs.scm safe.scm session.scm slib.scm stack-catch.scm \ streams.scm string-fun.scm syncase.scm tags.scm threads.scm \ - buffered-input.scm + buffered-input.scm time.scm subpkgdatadir = $(pkgdatadir)/$(VERSION)/ice-9 subpkgdata_DATA = $(ice9_sources) From 62532db38d14cdf3d9c99d495a7a28126755808a Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 25 Mar 2001 00:34:33 +0000 Subject: [PATCH 0756/2047] *** empty log message *** --- doc/ChangeLog | 5 +++++ ice-9/ChangeLog | 4 ++++ 2 files changed, 9 insertions(+) diff --git a/doc/ChangeLog b/doc/ChangeLog index 86d5ad418..374039888 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,8 @@ +2001-03-25 Marius Vollmer + + * intro.texi (Modules and Extensions): Some short text about + dynamic libraries and modules. + 2001-03-23 Neil Jerram * intro.texi (Writing Extensions for Guile), scheme-data.texi diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 1625cf35b..c755af6c9 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2001-03-25 Marius Vollmer + + * Makefile.am (ice9_sources): Added "time.scm". + 2001-03-20 Keisuke Nishida * time.scm (time): Reimplemented as a procedure call. From c52b482324ddf1e7b5ac458ad3cbdf4ce28e1a4b Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 25 Mar 2001 18:40:28 +0000 Subject: [PATCH 0757/2047] Fix sh standard conformance bug: Replace "test -e" with "test -f". Thanks to Alexander Klimov. --- check-guile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/check-guile.in b/check-guile.in index 645755665..14cd94421 100644 --- a/check-guile.in +++ b/check-guile.in @@ -33,7 +33,7 @@ else fi # documentation searching ignores GUILE_LOAD_PATH. -if [ ! -e guile-procedures.txt ]; then +if [ ! -f guile-procedures.txt ] ; then ln -s libguile/guile-procedures.txt . fi From 72f1168d6331d4433247c4d1813110bf7f722f56 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 25 Mar 2001 18:49:08 +0000 Subject: [PATCH 0758/2047] *** empty log message *** --- ChangeLog | 55 ++++++++++++++++++++++++++++++------------------------- 1 file changed, 30 insertions(+), 25 deletions(-) diff --git a/ChangeLog b/ChangeLog index 15342b76b..a6a3e710f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2001-03-25 Thien-Thi Nguyen + + * check-guile.in: Fix sh standard conformance bug: Replace + "test -e" with "test -f". Thanks to Alexander Klimov. + 2001-03-19 Gary Houston * check-guile.in: rename $parent to $srcdir. if it's equal to "." @@ -131,11 +136,11 @@ * configure.in: added AC_SUBST lines for the new LIBGUILE version variables. - + 2000-06-01 Michael Livshin * autogen.sh: call ./guile-aclocal.sh instead of aclocal. - + * guile-aclocal.sh: new file, works around aclocal problems. 2000-05-30 Dirk Herrmann @@ -234,7 +239,7 @@ Tue Jan 11 13:42:35 2000 Greg J. Badros * autogen.sh: Added messages as we run autogen in subdirectories. * configure.in: Output libugile/guile-func-name-check script, and - chmod +x it. + chmod +x it. 2000-01-11 Marius Vollmer @@ -249,7 +254,7 @@ Tue Jan 11 13:42:35 2000 Greg J. Badros * configure.in: Make "--with-modules=yes" the default. Do not clear INCLTDL, LIBLTDL prior to processing "--with-modules". - + 1999-07-25 Thomas Tanner * Makefile.am: add libltdl to SUBDIRS, automake automatically @@ -282,7 +287,7 @@ Tue Dec 14 09:12:22 1999 Greg J. Badros 1999-12-12 Greg J. Badros - * configure.in: Create guile-doc-snarf, chmod +x that script after + * configure.in: Create guile-doc-snarf, chmod +x that script after AC_OUTPUTted. 1999-12-10 Greg J. Badros @@ -312,7 +317,7 @@ Tue Dec 14 09:12:22 1999 Greg J. Badros guile-readline's autogen.sh script. Straighten up the situation regarding guile.m4 and qthreads.m4. - + We can't have .m4 files which are installed where aclocal can see them, but also used by guile's own configure.in, because aclocal will read both copies, complain about duplicate macro @@ -393,7 +398,7 @@ Tue Dec 14 09:12:22 1999 Greg J. Badros * configure.in (GUILE_STAMP): Don't set this variable, or substitute it into anything. Full explanation in ice-9/ChangeLog. * configure, Makefile.in: Regenerated. - + 1999-09-06 James Blandy Propagate the changes of 2 Sept the rest of the way through. @@ -453,7 +458,7 @@ Tue Dec 14 09:12:22 1999 Greg J. Badros * Makefile.am: Likewise for make. * NEWS: Explain how to activate the readline support. * configure, Makefile.in: Regenerated. - + 1999-07-19 Jim Blandy Fixes for EMX from Mikael Ståldal. @@ -493,7 +498,7 @@ Tue Dec 14 09:12:22 1999 Greg J. Badros 1.4, libtool 1.2f (1.385 1999/03/15 17:24:54). I've upgraded to all the right tools, according to README, but I'm still getting different results than Mikael is. Hmm. - + 1999-03-22 Mikael Djurfeldt * New libtool: 1.2f @@ -612,7 +617,7 @@ Tue Dec 14 09:12:22 1999 Greg J. Badros 1998-10-12 Jim Blandy * configure: Regenerated. - + * configure.in (GUILE_FUNC_DECLARED): Name the cache variables starting with guile_cv_; ac_cv_ is autoconf's namespace. @@ -637,11 +642,11 @@ Tue Dec 14 09:12:22 1999 Greg J. Badros regression from 1.3a, but everyone knows that the next release is 1.3, I want to switch to a more coherent version numbering system, and now is the time. - + 1998-10-09 Jim Blandy * configure.in: Call AC_C_INLINE, so we can use inline happily in - libguile. + libguile. * configure: Regenerated. 1998-10-07 Jim Blandy @@ -672,7 +677,7 @@ Tue Dec 14 09:12:22 1999 Greg J. Badros * configure.in (FD_SETTER, FILE_CNT_GPTR): New cases for SCO's stdio implementation. (Thanks to David Tillman.) * configure: Rebuilt. - + * guile-config: Renamed from `build'. * Makefile.am (SUBDIRS): Mention `guile-config', not `build'. * configure.in: Create `guile-config/Makefile.in', not @@ -726,11 +731,11 @@ Tue Dec 14 09:12:22 1999 Greg J. Badros public version of automake, not the hacked Cygnus version. * config.guess, config.sub, ltconfig, ltmain.sh: New versions from libtool. - + * configure.in, qthreads.m4: Display a message about how the threads configuration went. * aclocal.m4, configure: Regenerated. - + 1998-07-28 Jim Blandy Remove the TOTORO kludge. We're not doing snapshots any more, so @@ -860,7 +865,7 @@ Sun Dec 7 06:11:24 1997 Gary Houston * configure.in: Use it. * configure: Regenerated. * acconfig.h (DLSYM_ADDS_USCORE): New #define. - + 1997-10-26 Mikael Djurfeldt * README (libtool): Tell people to use version 1.0e. @@ -987,7 +992,7 @@ Sat Jun 28 16:13:43 1997 Tim Pierce Thu Jun 26 20:43:31 1997 Jim Blandy * Guile 1.2 released. - + * configure.in: Check for librx after libm; fundamentals need to come first. * configure: Regenerated. @@ -1005,7 +1010,7 @@ Sun Jun 22 15:43:07 1997 Jim Blandy sending in bug reports. * configure.in: Provide libguile its version information through a separate header file generated by the Makefile, not through - scmconfig.h. + scmconfig.h. (GUILE_MAJOR_VERSION, GUILE_MINOR_VERSION, GUILE_VERSION): AC_SUBST these, instead of AC_DEFINE'ing them. (GUILE_STAMP): New AC_SUBST: the time we configured the tree. @@ -1114,7 +1119,7 @@ Mon May 12 18:29:45 1997 Jim Blandy Thu May 8 11:48:40 1997 Anthony Green - * aclocal.m4: Fixes for building with coop threads in a + * aclocal.m4: Fixes for building with coop threads in a seperate compilation directory. * configure: Rebuilt. @@ -1127,7 +1132,7 @@ Fri May 2 16:24:15 1997 Jim Blandy * configure.in: When configuring qt, sunos needs the underscore files; Solaris and Linux both need the normal files. * configure: Reebilt. - + Thu May 1 15:35:49 1997 Jim Blandy * configure.in: Get the paths for qt's md files right, so it can @@ -1175,7 +1180,7 @@ Fri Apr 11 15:43:07 1997 Jim Blandy * ltconfig, ltmain.sh: Upgraded libtool files to 0.9d. * README: Say where to find libtool 0.9d. - + Wed Apr 9 17:51:13 1997 Jim Blandy Changes to work with automake-1.1n, which has better libtool @@ -1202,7 +1207,7 @@ Sat Mar 15 01:11:44 1997 Mikael Djurfeldt Mon Feb 24 21:43:26 1997 Mikael Djurfeldt * ltconfig, ltmain.sh: New versions from libtool-0.9. - + * configure.in: Added AM_MAINTAINER_MODE Fri Feb 7 17:57:46 1997 Jim Blandy @@ -1230,7 +1235,7 @@ Sun Jan 5 16:57:10 1997 Jim Blandy * Guile 1.0 released. This is the first release by the Free Software Foundation; Cygnus has also released earlier versions of Guile. - + * GUILE-VERSION: Updated version number. * NEWS: Added comments for all the user-visible changes marked in the ChangeLogs. @@ -1261,7 +1266,7 @@ Wed Oct 16 07:32:14 1996 Mark Galassi Thu Oct 10 14:37:43 1996 Jim Blandy - * Makefile.in (TAGS tags): Find the source files in $srcdir. + * Makefile.in (TAGS tags): Find the source files in $srcdir. Wed Oct 9 19:37:14 1996 Jim Blandy @@ -1274,7 +1279,7 @@ Tue Oct 1 00:13:55 1996 Mikael Djurfeldt * aclocal.m4: New file. For now used for thread support configuration. - + Fri Sep 13 14:39:30 1996 Mark Galassi * Makefile.in (DISTFILES): added mkinstalldirs to the DISTFILES From a4e7b79a5ea74e1ca162cb4b67ef797b6ccee133 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 26 Mar 2001 22:31:47 +0000 Subject: [PATCH 0759/2047] * boot-9.scm (warn-autoload-deprecation): New function. (init-dynamic-module): Use it here to print warning. Only give warning when a module has actually been found. --- ice-9/boot-9.scm | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index a1ac4d140..e96defa1f 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1811,12 +1811,23 @@ (append! (convert-c-registered-modules dynobj) registered-modules))) +(define (warn-autoload-deprecation modname) + (display + ";;; Autoloading of compiled code modules is deprecated.\n" + (current-error-port)) + (display + ";;; Write a Scheme file instead that uses `dynamic-link' directly.\n" + (current-error-port)) + (format (current-error-port) + ";;; (You just tried to autoload module ~S.\n" modname)) + (define (init-dynamic-module modname) ;; Register any linked modules which has been registered on the C level (register-modules #f) (or-map (lambda (modinfo) (if (equal? (car modinfo) modname) (begin + (warn-autload-deprecation modname) (set! registered-modules (delq! modinfo registered-modules)) (let ((mod (resolve-module modname #f))) (save-module-excursion From 218da2b99209ee0aef289409b8ab91e89ecea4cb Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 26 Mar 2001 22:32:39 +0000 Subject: [PATCH 0760/2047] * r4rs.scm (call-with-values): New definition, defers to @call-with-values. --- ice-9/r4rs.scm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ice-9/r4rs.scm b/ice-9/r4rs.scm index c820ffbc0..6dff2a616 100644 --- a/ice-9/r4rs.scm +++ b/ice-9/r4rs.scm @@ -28,6 +28,8 @@ (set-procedure-property! apply 'name 'apply) (define (call-with-current-continuation proc) (@call-with-current-continuation proc)) +(define (call-with-values producer consumer) + (@call-with-values producer consumer)) ;;;; Basic Port Code From 8c2c9967f8eced3d47ae754356866f81544056cf Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 26 Mar 2001 22:32:57 +0000 Subject: [PATCH 0761/2047] *** empty log message *** --- NEWS | 31 +++++++++++++++++++++++++++++++ RELEASE | 6 ++++++ ice-9/ChangeLog | 14 ++++++++++++++ 3 files changed, 51 insertions(+) diff --git a/NEWS b/NEWS index 7569dbe08..5c5fae78e 100644 --- a/NEWS +++ b/NEWS @@ -136,6 +136,37 @@ Example: * Changes to Scheme functions and syntax +** The empty combination is no longer valid syntax. + +Previously, the expression "()" evaluated to the empty list. This has +been changed to signal a "missing expression" error. The correct way +to write the empty list as a literal constant is to use quote: "'()". + +** Auto-loading of compiled-code modules is deprecated. + +Guile used to be able to automatically find and link a shared +libraries to satisfy requests for a module. For example, the module +`(foo bar)' could be implemented by placing a shared library named +"foo/libbar.so" (or with a different extension) in a directory on the +load path of Guile. + +This has been found to be too tricky, and is no longer supported. +What you should do instead now is to write a small Scheme file that +explicitly calls `dynamic-link' to load the shared library and +`dynamic-call' to initialize it. + +The shared libraries themselves should be installed in the usual +places for shared libraries, with names like "libguile-foo-bar". + +For example, place this into a file "foo/bar.scm" + + (define-module (foo bar)) + + (dynamic-call "foobar_init" (dynamic-link "libguile-foo-bar")) + +The file name passed to `dynamic-link' should not contain an +extension. It will be provided automatically. + ** The module system has been made more disciplined. The function `eval' will now save and restore the current module diff --git a/RELEASE b/RELEASE index f4c521119..37dd67785 100644 --- a/RELEASE +++ b/RELEASE @@ -40,6 +40,12 @@ In release 1.5: - remove deprecated macro from tags.h: SCM_DOUBLE_CELLP In release 1.6: +- remove support for autoloading compiled-code modules: + try-module-linked + try-module-dynamic-link + init-dynamic-module + scm_register_module_xxx + etc. - remove deprecated variables: scm_top_level_lookup_closure_var - remove deprecated functions: diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index c755af6c9..d722a60df 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,5 +1,19 @@ +2001-03-27 Marius Vollmer + + * r4rs.scm (call-with-values): New definition, defers to + @call-with-values. + +2001-03-26 Marius Vollmer + + * boot-9.scm (warn-autoload-deprecation): New function. + (init-dynamic-module): Use it here to print warning. Only give + warning when a module has actually been found. + 2001-03-25 Marius Vollmer + * boot-9.scm (init-dynamic-module): Issue warning about + auto-loading of compiled code modules being deprecated. + * Makefile.am (ice9_sources): Added "time.scm". 2001-03-20 Keisuke Nishida From baeda600235299b9ed90f849dfefbd4ca8ad926f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 26 Mar 2001 22:36:56 +0000 Subject: [PATCH 0762/2047] * tags.h (SCM_IM_CALL_WITH_VALUES): New isym. * eval.c (scm_m_at_call_with_values, scm_sym_at_call_with_values): New. (unmemocopy, scm_ceval, scm_deval): Handle new isym. * eval.h (scm_sym_at_call_with_values, scm_m_at_call_with_values): New delcarations to support above change. --- libguile/eval.h | 2 ++ libguile/tags.h | 1 + 2 files changed, 3 insertions(+) diff --git a/libguile/eval.h b/libguile/eval.h index 0db28526f..ec387a4dd 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -170,6 +170,7 @@ extern SCM scm_sym_uq_splicing; extern SCM scm_sym_dot; extern SCM scm_sym_atapply; extern SCM scm_sym_atcall_cc; +extern SCM scm_sym_at_call_with_values; extern SCM scm_sym_delay; extern SCM scm_sym_arrow; extern SCM scm_sym_else; @@ -228,6 +229,7 @@ extern SCM scm_m_0_ify (SCM xorig, SCM env); extern SCM scm_m_1_ify (SCM xorig, SCM env); extern SCM scm_m_atfop (SCM xorig, SCM env); extern SCM scm_m_atbind (SCM xorig, SCM env); +extern SCM scm_m_at_call_with_values (SCM xorig, SCM env); extern int scm_badargsp (SCM formals, SCM args); extern SCM scm_ceval (SCM x, SCM env); extern SCM scm_deval (SCM x, SCM env); diff --git a/libguile/tags.h b/libguile/tags.h index f69031d81..846d27000 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -477,6 +477,7 @@ extern char *scm_isymnames[]; /* defined in print.c */ #define SCM_IM_BIND SCM_MAKISYM (31) #define SCM_IM_DELAY SCM_MAKISYM (32) +#define SCM_IM_CALL_WITH_VALUES SCM_MAKISYM (33) /* When a variable is unbound this is marked by the SCM_UNDEFINED * value. The following is an unbound value which can be handled on From a513ead3086142281b0a8de31b6794f181c64a7a Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 26 Mar 2001 22:39:35 +0000 Subject: [PATCH 0763/2047] * tags.h (SCM_IM_CALL_WITH_VALUES): New isym. * eval.c: Include "libguile/values.h" (scm_m_at_call_with_values, scm_sym_at_call_with_values): New. (unmemocopy, scm_ceval, scm_deval): Handle new isym. * eval.h (scm_sym_at_call_with_values, scm_m_at_call_with_values): New delcarations to support above change. * eval.c (scm_primitive_eval_x, scm_primitive_eval): Fix syntax errors with last change. * eval.c (scm_primitive_eval_x, scm_primitive_eval, scm_i_eval_x, scm_i_eval): Moved the application of the system transformer from scm_i_eval to scm_primitive_eval. --- libguile/eval.c | 67 +++++++++++++++++++++++++++++++++++++------------ 1 file changed, 51 insertions(+), 16 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index 7c444d239..d57ca1ac7 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -100,6 +100,7 @@ char *alloca (); #include "libguile/root.h" #include "libguile/vectors.h" #include "libguile/fluids.h" +#include "libguile/values.h" #include "libguile/validate.h" #include "libguile/eval.h" @@ -1129,6 +1130,17 @@ scm_m_atbind (SCM xorig, SCM env) return scm_cons (SCM_IM_BIND, SCM_CDR (xorig)); } +SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_makmmacro, scm_m_at_call_with_values); +SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values); + +SCM +scm_m_at_call_with_values (SCM xorig, SCM env) +{ + SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, + scm_s_expression, s_at_call_with_values); + return scm_cons (SCM_IM_CALL_WITH_VALUES, SCM_CDR (xorig)); +} + SCM scm_m_expand_body (SCM xorig, SCM env) { @@ -1416,6 +1428,9 @@ unmemocopy (SCM x, SCM env) ls = z = scm_cons (scm_sym_delay, SCM_UNSPECIFIED); x = SCM_CDR (x); goto loop; + case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)): + ls = z = scm_cons (scm_sym_at_call_with_values, SCM_UNSPECIFIED); + goto loop; default: /* appease the Sun compiler god: */ ; } @@ -2198,6 +2213,10 @@ dispatch: PREP_APPLY (proc, SCM_EOL); t.arg1 = SCM_CDR (SCM_CDR (x)); t.arg1 = EVALCAR (t.arg1, env); + apply_closure: + /* Go here to tail-call a closure. PROC is the closure + and T.ARG1 is the list of arguments. Do not forget to + call PREP_APPLY. */ #ifdef DEVAL debug.info->a.args = t.arg1; #endif @@ -2453,8 +2472,27 @@ dispatch: arg2 = SCM_CDR (arg2); } - RETURN (proc) + RETURN (proc); + case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)): + { + proc = SCM_CDR (x); + x = EVALCAR (proc, env); + proc = SCM_CDR (proc); + proc = EVALCAR (proc, env); + t.arg1 = SCM_APPLY (x, SCM_EOL, SCM_EOL); + if (SCM_VALUESP (t.arg1)) + t.arg1 = scm_struct_ref (t.arg1, SCM_INUM0); + else + t.arg1 = scm_cons (t.arg1, SCM_EOL); + if (SCM_CLOSUREP (proc)) + { + PREP_APPLY (proc, t.arg1); + goto apply_closure; + } + return SCM_APPLY (proc, t.arg1, SCM_EOL); + } + default: goto badfun; } @@ -3846,7 +3884,7 @@ SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0, evaluates EXP in environment ENV. ENV is a lexical environment structure as used by the actual tree code evaluator. When ENV is a top-level environment, then changes to the current module are - tracked by modifying ENV so that it continues to be in sync with + tracked by updating ENV so that it continues to be in sync with the current module. - scm_primitive_eval (exp) @@ -3858,7 +3896,7 @@ SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0, - scm_eval (exp, mod) - evaluates EXP while MOD is the current module. Thius is done by + evaluates EXP while MOD is the current module. This is done by setting the current module to MOD, invoking scm_primitive_eval on EXP, and then restoring the current module to the value it had previously. That is, while EXP is evaluated, changes to the @@ -3876,33 +3914,26 @@ SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0, SCM scm_system_transformer; -/* XXX - scm_i_eval is meant to be useable for evaluation in - non-toplevel environments, for example when used by the debugger. - Can the system transform deal with this? */ - SCM scm_i_eval_x (SCM exp, SCM env) { - SCM transformer = scm_fluid_ref (SCM_CDR (scm_system_transformer)); - if (SCM_NIMP (transformer)) - exp = scm_apply (transformer, exp, scm_listofnull); return SCM_XEVAL (exp, env); } SCM scm_i_eval (SCM exp, SCM env) { - SCM transformer = scm_fluid_ref (SCM_CDR (scm_system_transformer)); - if (SCM_NIMP (transformer)) - exp = scm_apply (transformer, exp, scm_listofnull); - exp = scm_copy_tree (exp); return SCM_XEVAL (exp, env); } SCM scm_primitive_eval_x (SCM exp) { - SCM env = scm_top_level_env (scm_current_module_lookup_closure ()); + SCM env; + SCM transformer = scm_fluid_ref (SCM_CDR (scm_system_transformer)); + if (SCM_NIMP (transformer)) + exp = scm_apply (transformer, exp, scm_listofnull); + env = scm_top_level_env (scm_current_module_lookup_closure ()); return scm_i_eval_x (exp, env); } @@ -3912,7 +3943,11 @@ SCM_DEFINE (scm_primitive_eval, "primitive-eval", 1, 0, 0, "the current module.") #define FUNC_NAME s_scm_primitive_eval { - SCM env = scm_top_level_env (scm_current_module_lookup_closure ()); + SCM env; + SCM transformer = scm_fluid_ref (SCM_CDR (scm_system_transformer)); + if (SCM_NIMP (transformer)) + exp = scm_apply (transformer, exp, scm_listofnull); + env = scm_top_level_env (scm_current_module_lookup_closure ()); return scm_i_eval (exp, env); } #undef FUNC_NAME From 752af22794313ace532fb3db638424ff2f9bfa72 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 26 Mar 2001 22:43:23 +0000 Subject: [PATCH 0764/2047] * values.h (scm_values_vtable, SCM_VALUESP): Moved here so that eval.c can use it. (scm_call_with_values): Removed. * values.c (values_vtable, scm_values_vtable): Added "scm_" prefix so that it can be exported. (scm_call_with_values): Removed. --- libguile/values.c | 42 ++++-------------------------------------- libguile/values.h | 6 +++++- 2 files changed, 9 insertions(+), 39 deletions(-) diff --git a/libguile/values.c b/libguile/values.c index 59638174b..a5377e690 100644 --- a/libguile/values.c +++ b/libguile/values.c @@ -52,10 +52,7 @@ #include "libguile/values.h" -static SCM values_vtable; - -#define SCM_VALUESP(x) (SCM_STRUCTP (x)\ - && SCM_EQ_P (scm_struct_vtable (x), values_vtable)) +SCM scm_values_vtable; static SCM print_values (SCM obj, SCM pwps) @@ -91,7 +88,7 @@ SCM_DEFINE (scm_values, "values", 0, 0, 1, result = SCM_CAR (args); else { - result = scm_make_struct (values_vtable, SCM_INUM0, + result = scm_make_struct (scm_values_vtable, SCM_INUM0, scm_cons (args, SCM_EOL)); } @@ -99,46 +96,15 @@ SCM_DEFINE (scm_values, "values", 0, 0, 1, } #undef FUNC_NAME -SCM_DEFINE (scm_call_with_values, "call-with-values", 2, 0, 0, - (SCM producer, SCM consumer), - "Calls its @var{producer} argument with no values and a\n" - "continuation that, when passed some values, calls the\n" - "@var{consumer} procedure with those values as arguments. The\n" - "continuation for the call to @var{consumer} is the continuation\n" - "of the call to @code{call-with-values}.\n\n" - "@example\n" - "(call-with-values (lambda () (values 4 5))\n" - " (lambda (a b) b))\n" - " ==> 5\n\n" - "@end example\n" - "@example\n" - "(call-with-values * -) ==> -1\n" - "@end example") -#define FUNC_NAME s_scm_call_with_values -{ - SCM product; - - SCM_VALIDATE_PROC (1, producer); - SCM_VALIDATE_PROC (2, consumer); - - product = scm_apply (producer, SCM_EOL, SCM_EOL); - if (SCM_VALUESP (product)) - product = scm_struct_ref (product, SCM_INUM0); - else - product = scm_cons (product, SCM_EOL); - return scm_apply (consumer, product, SCM_EOL); -} -#undef FUNC_NAME - void scm_init_values (void) { SCM print = scm_make_subr ("%print-values", scm_tc7_subr_2, print_values); - values_vtable + scm_values_vtable = scm_permanent_object (scm_make_vtable_vtable (scm_makfrom0str ("pr"), SCM_INUM0, SCM_EOL)); - SCM_SET_STRUCT_PRINTER (values_vtable, print); + SCM_SET_STRUCT_PRINTER (scm_values_vtable, print); scm_add_feature ("values"); diff --git a/libguile/values.h b/libguile/values.h index 79cdcf6fb..20777153d 100644 --- a/libguile/values.h +++ b/libguile/values.h @@ -47,8 +47,12 @@ #include "libguile/__scm.h" +extern SCM scm_values_vtable; + +#define SCM_VALUESP(x) (SCM_STRUCTP (x)\ + && SCM_EQ_P (scm_struct_vtable (x), scm_values_vtable)) + extern SCM scm_values (SCM args); -extern SCM scm_call_with_values (SCM producer, SCM consumer); extern void scm_init_values (void); #endif /* SCM_VALUES_H */ From 0757681299c8240f223b5cb47b42703efa0d5d9a Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 26 Mar 2001 22:43:50 +0000 Subject: [PATCH 0765/2047] *** empty log message *** --- libguile/ChangeLog | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6856da998..a3da5db42 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,29 @@ +2001-03-27 Marius Vollmer + + * values.h (scm_values_vtable, SCM_VALUESP): Moved here so that + eval.c can use it. + (scm_call_with_values): Removed. + * values.c (values_vtable, scm_values_vtable): Added "scm_" prefix + so that it can be exported. + (scm_call_with_values): Removed. + + * tags.h (SCM_IM_CALL_WITH_VALUES): New isym. + * eval.c: Include "libguile/values.h" + (scm_m_at_call_with_values, scm_sym_at_call_with_values): + New. + (unmemocopy, scm_ceval, scm_deval): Handle new isym. + * eval.h (scm_sym_at_call_with_values, scm_m_at_call_with_values): + New delcarations to support above change. + + * eval.c (scm_primitive_eval_x, scm_primitive_eval): Fix syntax + errors with last change. + +2001-03-25 Marius Vollmer + + * eval.c (scm_primitive_eval_x, scm_primitive_eval, scm_i_eval_x, + scm_i_eval): Moved the application of the system transformer from + scm_i_eval to scm_primitive_eval. + 2001-03-23 Neil Jerram * guile-snarf.awk.in: Substitute "\\" with "\" in .doc output. From 91344cebe01d17757bb527f1bbbb0bc1e197c4b1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Tue, 27 Mar 2001 15:40:18 +0000 Subject: [PATCH 0766/2047] * strop.c (scm_string_to_list): Fixed docstring markup. (scm_string_upcase_x, scm_string_upcase, scm_string_downcase_x), (scm_string_downcase, scm_string_capitalize_x), (scm_string_capitalize): Rewrote and corrected docstrings. (scm_string_ci_to_symbol): Made docstring more explicit. --- libguile/ChangeLog | 8 ++++++ libguile/strop.c | 67 +++++++++++++++++++++++++--------------------- 2 files changed, 45 insertions(+), 30 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index a3da5db42..9fd396f53 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2001-03-27 Martin Grabmueller + + * strop.c (scm_string_to_list): Fixed docstring markup. + (scm_string_upcase_x, scm_string_upcase, scm_string_downcase_x), + (scm_string_downcase, scm_string_capitalize_x), + (scm_string_capitalize): Rewrote and corrected docstrings. + (scm_string_ci_to_symbol): Made docstring more explicit. + 2001-03-27 Marius Vollmer * values.h (scm_values_vtable, SCM_VALUESP): Moved here so that diff --git a/libguile/strop.c b/libguile/strop.c index 756478f08..9740986d2 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -315,12 +315,10 @@ SCM_DEFINE (scm_string_null_p, "string-null?", 1, 0, 0, SCM_DEFINE (scm_string_to_list, "string->list", 1, 0, 0, (SCM str), - "@samp{String->list} returns a newly allocated list of the\n" - "characters that make up the given string. @samp{List->string}\n" - "returns a newly allocated string formed from the characters in the list\n" - "@var{list}, which must be a list of characters. @samp{String->list}\n" - "and @samp{list->string} are\n" - "inverses so far as @samp{equal?} is concerned. (r5rs)") + "Return a newly allocated list of the characters that make up\n" + "the given string @var{str}. @code{string->list} and\n" + "@code{list->string} are inverses as far as @samp{equal?} is\n" + "concerned.") #define FUNC_NAME s_scm_string_to_list { long i; @@ -387,14 +385,13 @@ string_upcase_x (SCM v) SCM_DEFINE (scm_string_upcase_x, "string-upcase!", 1, 0, 0, (SCM str), - "Destructively upcase every character in @code{str}.\n\n" - "(qdocs:) Converts each element in @var{str} to upper case.\n\n" - "@example\n" - "(string-upcase! y)\n" - "@result{} \"ARRDEFG\"\n\n" - "y\n" - "@result{} \"ARRDEFG\"\n" - "@end example") + "Destructively upcase every character in @var{str} and return\n" + "@var{str}.\n" + "@lisp\n" + "y @result{} \"arrdefg\"\n" + "(string-upcase! y) @result{} \"ARRDEFG\"\n" + "y @result{} \"ARRDEFG\"\n" + "@end lisp") #define FUNC_NAME s_scm_string_upcase_x { SCM_VALIDATE_STRING (1, str); @@ -406,7 +403,8 @@ SCM_DEFINE (scm_string_upcase_x, "string-upcase!", 1, 0, 0, SCM_DEFINE (scm_string_upcase, "string-upcase", 1, 0, 0, (SCM str), - "Upcase every character in @code{str}.") + "Return a freshly allocated string containing the characters of\n" + "@var{str} in upper case.") #define FUNC_NAME s_scm_string_upcase { SCM_VALIDATE_STRING (1, str); @@ -432,16 +430,13 @@ string_downcase_x (SCM v) SCM_DEFINE (scm_string_downcase_x, "string-downcase!", 1, 0, 0, (SCM str), - "Destructively downcase every character in @code{str}.\n\n" - "(qdocs:) Converts each element in @var{str} to lower case.\n\n" - "@example\n" - "y\n" - "@result{} \"ARRDEFG\"\n\n" - "(string-downcase! y)\n" - "@result{} \"arrdefg\"\n\n" - "y\n" - "@result{} \"arrdefg\"\n" - "@end example") + "Destructively downcase every character in @var{str} and return\n" + "@var{str}.\n" + "@lisp\n" + "y @result{} \"ARRDEFG\"\n" + "(string-downcase! y) @result{} \"arrdefg\"\n" + "y @result{} \"arrdefg\"\n" + "@end lisp") #define FUNC_NAME s_scm_string_downcase_x { SCM_VALIDATE_STRING (1, str); @@ -453,7 +448,8 @@ SCM_DEFINE (scm_string_downcase_x, "string-downcase!", 1, 0, 0, SCM_DEFINE (scm_string_downcase, "string-downcase", 1, 0, 0, (SCM str), - "Downcase every character in @code{str}.") + "Return a freshly allocation string containing the characters in\n" + "@var{str} in lower case.") #define FUNC_NAME s_scm_string_downcase { SCM_VALIDATE_STRING (1, str); @@ -490,7 +486,14 @@ string_capitalize_x (SCM str) SCM_DEFINE (scm_string_capitalize_x, "string-capitalize!", 1, 0, 0, (SCM str), - "Destructively capitalize every character in @code{str}.") + "Upcase the first character of every word in @var{str}\n" + "destructively and return @var{str}.\n" + "\n" + "@lisp\n" + "y @result{} "hello world"\n" + "(string-capitalize! y) @result{} "Hello World"\n" + "y @result{} "Hello World"\n" + "@end lisp") #define FUNC_NAME s_scm_string_capitalize_x { SCM_VALIDATE_STRING (1, str); @@ -502,7 +505,9 @@ SCM_DEFINE (scm_string_capitalize_x, "string-capitalize!", 1, 0, 0, SCM_DEFINE (scm_string_capitalize, "string-capitalize", 1, 0, 0, (SCM str), - "Capitalize every character in @code{str}.") + "Return a freshly allocated string with the characters in\n" + "@var{str}, where the first character of every word is\n" + "capitalized.") #define FUNC_NAME s_scm_string_capitalize { SCM_VALIDATE_STRING (1, str); @@ -513,8 +518,10 @@ SCM_DEFINE (scm_string_capitalize, "string-capitalize", 1, 0, 0, SCM_DEFINE (scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0, - (SCM str), - "Return the symbol whose name is @var{str}, downcased in necessary(???).") + (SCM str), + "Return the symbol whose name is @var{str}. @var{str} is\n" + "converted to lowercase before the conversion is done, if Guile\n" + "is currently reading symbols case--insensitively.") #define FUNC_NAME s_scm_string_ci_to_symbol { return scm_string_to_symbol (SCM_CASE_INSENSITIVE_P From b576faf1c0929a8b42a355060af705c5ebe0b310 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Tue, 27 Mar 2001 15:42:12 +0000 Subject: [PATCH 0767/2047] * scheme-data.texi (Strings): Reorganized the whole `Strings' section and wrote introductory material for each new subsection. --- doc/ChangeLog | 5 + doc/scheme-data.texi | 501 ++++++++++++++++++++++++++----------------- 2 files changed, 304 insertions(+), 202 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 374039888..a731a1d8d 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,8 @@ +2001-03-27 Martin Grabmueller + + * scheme-data.texi (Strings): Reorganized the whole `Strings' + section and wrote introductory material for each new subsection. + 2001-03-25 Marius Vollmer * intro.texi (Modules and Extensions): Some short text about diff --git a/doc/scheme-data.texi b/doc/scheme-data.texi index 22cdf2888..06f1a7da9 100755 --- a/doc/scheme-data.texi +++ b/doc/scheme-data.texi @@ -51,11 +51,11 @@ sections of this manual that cover them. * Keywords:: Self-quoting, customizable display keywords. * Pairs:: Scheme's basic building block. * Lists:: Special list functions supported by Guile. -* Records:: -* Structures:: -* Arrays:: -* Association Lists and Hash Tables:: -* Vectors:: +* Records:: +* Structures:: +* Arrays:: +* Association Lists and Hash Tables:: +* Vectors:: * Hooks:: User-customizable event lists. * Other Data Types:: Data types that are documented elsewhere. @end menu @@ -154,7 +154,7 @@ in Scheme, which is particularly clear and accessible: see * Reals and Rationals:: Real and rational numbers. * Complex Numbers:: Complex numbers. * Exactness:: Exactness and inexactness. -* Number Syntax:: Read syntax for numerical data. +* Number Syntax:: Read syntax for numerical data. * Integer Operations:: Operations on integer values. * Comparison:: Comparison predicates. * Conversion:: Converting numbers to and from strings. @@ -1397,23 +1397,76 @@ Return the lowercase character version of @var{chr}. @node Strings @section Strings -[FIXME: this is pasted in from Tom Lord's original guile.texi and should -be reviewed] +Strings are fixed--length sequences of characters. They can be created +by calling constructor procedures, but they can also literally get +entered at the REPL or in Scheme source files. -For the sake of efficiency, two special kinds of strings are available -in Guile: shared substrings and the misleadingly named ``read-only'' -strings. It is not necessary to know about these to program in Guile, -but you are likely to run into one or both of these special string types -eventually, and it will be helpful to know how they work. +The read syntax for strings is an arbitrarily long sequence of characters +enclosed in double quotes (@code{"}). @footnote{Actually, the current +implementation restricts strings to a length of 2&24 characters.} If +you want to insert a double quote character into a string literal, it +must be prefixed with a backslash @code{\} character (called an +@emph{escape character}). + +The following are examples of string literals: + +@lisp +"foo" +"bar plonk" +"Hello World" +"\"Hi\", he said." +@end lisp + +Guile provides a rich set of string processing procedures, because text +handling is very important when Guile is used as a scripting language. @menu -* String Fun:: New functions for manipulating strings. +* String Predicates:: Testing strings for certain properties. +* String Constructors:: Creating new string objects. +* List/String Conversion:: Converting from/to lists of characters. +* String Selection:: Select portions from strings. +* String Modification:: Modify parts or whole strings. +* String Comparison:: Lexicographic ordering predicates. +* String Searching:: Searching in strings. +* Alphabetic Case Mapping:: Convert the alphabetic case of strings. +* Appending Strings:: Appending strings to form a new string. +* String Miscellanea:: Miscellaneous string procedures. * Shared Substrings:: Strings which share memory with each other. * Read Only Strings:: Treating certain non-strings as strings. @end menu -@node String Fun -@subsection String Fun +@node String Predicates +@subsection String Predicates + +The following procedures can be used to check whether a given string +fulfills some specified property. + +@r5index string? +@c docstring begin (texi-doc-string "guile" "string?") +@deffn primitive string? obj +Returns @code{#t} iff @var{obj} is a string, else returns +@code{#f}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "string-null?") +@deffn primitive string-null? str +Return @code{#t} if @var{str}'s length is nonzero, and @code{#f} +otherwise. + +@example +(string-null? "") @result{} #t +y @result{} "foo" +(string-null? y) @result{} #f +@end example +@end deffn + +@node String Constructors +@subsection String Constructors + +The string constructor procedures create new string objects, possibly +initializing them with some specified character data. + +@c FIXME::martin: list->string belongs into `List/String Conversion' @r5index string @r5index list->string @@ -1434,13 +1487,32 @@ the string are initialized to @var{chr}, otherwise the contents of the @var{string} are unspecified. @end deffn -@r5index string-append -@c docstring begin (texi-doc-string "guile" "string-append") -@deffn primitive string-append . args -Return a newly allocated string whose characters form the -concatenation of the given strings, @var{args}. +@node List/String Conversion +@subsection List/String conversion + +When processing strings, it is often convenient to first convert them +into a list representation by using the procedure @code{string->list}, +work with the resulting list, and then convert it back into a string. +These procedures are useful for similar tasks. + +@r5index string->list +@c docstring begin (texi-doc-string "guile" "string->list") +@deffn primitive string->list str +@samp{String->list} returns a newly allocated list of the +characters that make up the given string. @samp{List->string} +returns a newly allocated string formed from the characters in the list +@var{list}, which must be a list of characters. @samp{String->list} +and @samp{list->string} are +inverses so far as @samp{equal?} is concerned. (r5rs) @end deffn +@node String Selection +@subsection String Selection + +Portions of strings can be extracted by these procedures. +@code{string-ref} delivers individual characters whereas +@code{substring} can be used to extract substrings from longer strings. + @r5index string-length @c docstring begin (texi-doc-string "guile" "string-length") @deffn primitive string-length string @@ -1454,19 +1526,10 @@ Return character @var{k} of @var{str} using zero-origin indexing. @var{k} must be a valid index of @var{str}. @end deffn -@r5index string-set! -@c docstring begin (texi-doc-string "guile" "string-set!") -@deffn primitive string-set! str k chr -Store @var{chr} in element @var{k} of @var{str} and return -an unspecified value. @var{k} must be a valid index of -@var{str}. -@end deffn - -@r5index string? -@c docstring begin (texi-doc-string "guile" "string?") -@deffn primitive string? obj -Returns @code{#t} iff @var{obj} is a string, else returns -@code{#f}. +@r5index string-copy +@c docstring begin (texi-doc-string "guile" "string-copy") +@deffn primitive string-copy str +Returns a newly allocated copy of the given @var{string}. (r5rs) @end deffn @r5index substring @@ -1481,49 +1544,41 @@ exact integers satisfying: 0 <= @var{start} <= @var{end} <= (string-length @var{str}). @end deffn -@c docstring begin (texi-doc-string "guile" "string-index") -@deffn primitive string-index str chr [frm [to]] -Return the index of the first occurrence of @var{chr} in @var{str}. The -optional integer arguments @var{frm} and @var{to} limit the search to -a portion of the string. This procedure essentially implements the -@code{index} or @code{strchr} functions from the C library. +@node String Modification +@subsection String Modification -(qdocs:) Returns the index of @var{char} in @var{str}, or @code{#f} if the -@var{char} isn't in @var{str}. If @var{frm} is given and not @code{#f}, -it is used as the starting index; if @var{to} is given and not @code{#f}, -it is used as the ending index (exclusive). +These procedures are for modifying strings in--place. That means, that +not a new string is the result of a string operation, but that the +actual memory representation of a string is modified. -@example -(string-index "weiner" #\e) -@result{} 1 - -(string-index "weiner" #\e 2) -@result{} 4 - -(string-index "weiner" #\e 2 4) -@result{} #f -@end example +@r5index string-set! +@c docstring begin (texi-doc-string "guile" "string-set!") +@deffn primitive string-set! str k chr +Store @var{chr} in element @var{k} of @var{str} and return +an unspecified value. @var{k} must be a valid index of +@var{str}. @end deffn -@c docstring begin (texi-doc-string "guile" "string-rindex") -@deffn primitive string-rindex str chr [frm [to]] -Like @code{string-index}, but search from the right of the string rather -than from the left. This procedure essentially implements the -@code{rindex} or @code{strrchr} functions from the C library. +@r5index string-fill! +@c docstring begin (texi-doc-string "guile" "string-fill!") +@deffn primitive string-fill! str chr +Stores @var{char} in every element of the given @var{string} and returns an +unspecified value. (r5rs) +@end deffn -(qdocs:) The same as @code{string-index}, except it gives the rightmost occurance -of @var{char} in the range [@var{frm}, @var{to}-1], which defaults to -the entire string. +@c ARGFIXME fill/fill-char +@c docstring begin (texi-doc-string "guile" "substring-fill!") +@deffn primitive substring-fill! str start end fill +Change every character in @var{str} between @var{start} and @var{end} to +@var{fill-char}. + +(qdocs:) Destructively fills @var{str}, from @var{start} to @var{end}, with @var{fill}. @example -(string-rindex "weiner" #\e) -@result{} 4 - -(string-rindex "weiner" #\e 2 4) -@result{} #f - -(string-rindex "weiner" #\e 2 5) -@result{} 4 +(define y "abcdefg") +(substring-fill! y 1 3 #\r) +y +@result{} "arrdefg" @end example @end deffn @@ -1603,102 +1658,14 @@ y @end example @end deftypefn -@c docstring begin (texi-doc-string "guile" "vector-move-left!") -@deffn primitive vector-move-left! vec1 start1 end1 vec2 start2 -Vector version of @code{substring-move-left!}. -@end deffn -@c docstring begin (texi-doc-string "guile" "vector-move-right!") -@deffn primitive vector-move-right! vec1 start1 end1 vec2 start2 -Vector version of @code{substring-move-right!}. -@end deffn +@node String Comparison +@subsection String Comparison -@c ARGFIXME fill/fill-char -@c docstring begin (texi-doc-string "guile" "substring-fill!") -@deffn primitive substring-fill! str start end fill -Change every character in @var{str} between @var{start} and @var{end} to -@var{fill-char}. - -(qdocs:) Destructively fills @var{str}, from @var{start} to @var{end}, with @var{fill}. - -@example -(define y "abcdefg") -(substring-fill! y 1 3 #\r) -y -@result{} "arrdefg" -@end example -@end deffn - -@c docstring begin (texi-doc-string "guile" "string-null?") -@deffn primitive string-null? str -Return @code{#t} if @var{str}'s length is nonzero, and @code{#f} -otherwise. - -(qdocs:) Returns @code{#t} if @var{str} is empty, else returns @code{#f}. - -@example -(string-null? "") -@result{} #t - -(string-null? y) -@result{} #f -@end example -@end deffn - -@c ARGFIXME v/str -@c docstring begin (texi-doc-string "guile" "string-upcase!") -@deffn primitive string-upcase! str -Destructively upcase every character in @code{str}. - -(qdocs:) Converts each element in @var{str} to upper case. - -@example -(string-upcase! y) -@result{} "ARRDEFG" - -y -@result{} "ARRDEFG" -@end example -@end deffn - -@c docstring begin (texi-doc-string "guile" "string-upcase") -@deffn primitive string-upcase str -Upcase every character in @code{str}. -@end deffn - -@c ARGFIXME v/str -@c docstring begin (texi-doc-string "guile" "string-downcase!") -@deffn primitive string-downcase! str -Destructively downcase every character in @code{str}. - -(qdocs:) Converts each element in @var{str} to lower case. - -@example -y -@result{} "ARRDEFG" - -(string-downcase! y) -@result{} "arrdefg" - -y -@result{} "arrdefg" -@end example -@end deffn - -@c docstring begin (texi-doc-string "guile" "string-downcase") -@deffn primitive string-downcase str -Downcase every character in @code{str}. -@end deffn - -@c docstring begin (texi-doc-string "guile" "string-capitalize!") -@deffn primitive string-capitalize! str -Destructively capitalize every character in @code{str}. -@end deffn - -@c docstring begin (texi-doc-string "guile" "string-capitalize") -@deffn primitive string-capitalize str -Capitalize every character in @code{str}. -@end deffn +The procedures in this section are similar to the character ordering +predicates (REFFIXME), but are defined on character sequences. They all +return @code{#t} on success and @code{#f} on failure. The predicates +ending in @code{-ci} ignore the character case when comparing strings. @r5index string<=? @c docstring begin (texi-doc-string "guile" "string-ci<=?") @@ -1785,15 +1752,150 @@ Lexicographic ordering predicate; returns @code{#t} if @var{s1} is lexicographically greater than @var{s2}. (r5rs) @end deffn -@r5index string->list -@c docstring begin (texi-doc-string "guile" "string->list") -@deffn primitive string->list str -@samp{String->list} returns a newly allocated list of the -characters that make up the given string. @samp{List->string} -returns a newly allocated string formed from the characters in the list -@var{list}, which must be a list of characters. @samp{String->list} -and @samp{list->string} are -inverses so far as @samp{equal?} is concerned. (r5rs) +@node String Searching +@subsection String Searching + +When searching the index of a character in a string, these procedures +can be used. + +@c docstring begin (texi-doc-string "guile" "string-index") +@deffn primitive string-index str chr [frm [to]] +Return the index of the first occurrence of @var{chr} in @var{str}. The +optional integer arguments @var{frm} and @var{to} limit the search to +a portion of the string. This procedure essentially implements the +@code{index} or @code{strchr} functions from the C library. + +(qdocs:) Returns the index of @var{char} in @var{str}, or @code{#f} if the +@var{char} isn't in @var{str}. If @var{frm} is given and not @code{#f}, +it is used as the starting index; if @var{to} is given and not @code{#f}, +it is used as the ending index (exclusive). + +@example +(string-index "weiner" #\e) +@result{} 1 + +(string-index "weiner" #\e 2) +@result{} 4 + +(string-index "weiner" #\e 2 4) +@result{} #f +@end example +@end deffn + +@c docstring begin (texi-doc-string "guile" "string-rindex") +@deffn primitive string-rindex str chr [frm [to]] +Like @code{string-index}, but search from the right of the string rather +than from the left. This procedure essentially implements the +@code{rindex} or @code{strrchr} functions from the C library. + +(qdocs:) The same as @code{string-index}, except it gives the rightmost occurance +of @var{char} in the range [@var{frm}, @var{to}-1], which defaults to +the entire string. + +@example +(string-rindex "weiner" #\e) +@result{} 4 + +(string-rindex "weiner" #\e 2 4) +@result{} #f + +(string-rindex "weiner" #\e 2 5) +@result{} 4 +@end example +@end deffn + +@node Alphabetic Case Mapping +@subsection Alphabetic Case Mapping + +These are procedures for mapping strings to their upper-- or lower--case +equivalents, respectively, or for capitalizing strings. + +@c ARGFIXME v/str +@c docstring begin (texi-doc-string "guile" "string-upcase!") +@deffn primitive string-upcase! str +Destructively upcase every character in @code{str}. + +(qdocs:) Converts each element in @var{str} to upper case. + +@example +(string-upcase! y) +@result{} "ARRDEFG" + +y +@result{} "ARRDEFG" +@end example +@end deffn + +@c docstring begin (texi-doc-string "guile" "string-upcase") +@deffn primitive string-upcase str +Upcase every character in @code{str}. +@end deffn + +@c ARGFIXME v/str +@c docstring begin (texi-doc-string "guile" "string-downcase!") +@deffn primitive string-downcase! str +Destructively downcase every character in @code{str}. + +(qdocs:) Converts each element in @var{str} to lower case. + +@example +y +@result{} "ARRDEFG" + +(string-downcase! y) +@result{} "arrdefg" + +y +@result{} "arrdefg" +@end example +@end deffn + +@c docstring begin (texi-doc-string "guile" "string-downcase") +@deffn primitive string-downcase str +Downcase every character in @code{str}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "string-capitalize!") +@deffn primitive string-capitalize! str +Destructively capitalize every character in @code{str}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "string-capitalize") +@deffn primitive string-capitalize str +Capitalize every character in @code{str}. +@end deffn + +@node Appending Strings +@subsection Appending Strings + +The procedure @code{string-append} appends several strings together to +form a longer result string. + +@r5index string-append +@c docstring begin (texi-doc-string "guile" "string-append") +@deffn primitive string-append . args +Return a newly allocated string whose characters form the +concatenation of the given strings, @var{args}. +@end deffn + + +@node String Miscellanea +@subsection String Miscellanea + +This section contains several remaining string procedures. + +@c FIXME::martin: Should go into vector section. + +@c docstring begin (texi-doc-string "guile" "vector-move-left!") +@deffn primitive vector-move-left! vec1 start1 end1 vec2 start2 +Vector version of @code{substring-move-left!}. +@end deffn + +@c FIXME::martin: Should go into vector section. + +@c docstring begin (texi-doc-string "guile" "vector-move-right!") +@deffn primitive vector-move-right! vec1 start1 end1 vec2 start2 +Vector version of @code{substring-move-right!}. @end deffn @c docstring begin (texi-doc-string "guile" "string-ci->symbol") @@ -1801,23 +1903,15 @@ inverses so far as @samp{equal?} is concerned. (r5rs) Return the symbol whose name is @var{str}, downcased in necessary(???). @end deffn -@r5index string-copy -@c docstring begin (texi-doc-string "guile" "string-copy") -@deffn primitive string-copy str -Returns a newly allocated copy of the given @var{string}. (r5rs) -@end deffn - -@r5index string-fill! -@c docstring begin (texi-doc-string "guile" "string-fill!") -@deffn primitive string-fill! str chr -Stores @var{char} in every element of the given @var{string} and returns an -unspecified value. (r5rs) -@end deffn - @node Shared Substrings @subsection Shared Substrings +[FIXME: this is pasted in from Tom Lord's original guile.texi and should +be reviewed] + +@c FIXME::martin: Shared substrings are gone, so this section should die. + Whenever you extract a substring using @code{substring}, the Scheme interpreter allocates a new string and copies data from the old string. This is expensive, but @code{substring} is so convenient for @@ -1891,6 +1985,9 @@ expect to change the contents of any of the strings involved. @node Read Only Strings @subsection Read Only Strings +@c FIXME::martin: Read-only strings are gone, too, so this section should +@c also die. + Type-checking in Guile primitives distinguishes between mutable strings and read only strings. Mutable strings answer @code{#t} to @code{string?} while read only strings may or may not. All kinds of @@ -2642,10 +2739,10 @@ syntax extension to permit keywords to begin with @code{:} as well as @code{#:}. @menu -* Why Use Keywords?:: -* Coding With Keywords:: -* Keyword Read Syntax:: -* Keyword Primitives:: +* Why Use Keywords?:: +* Coding With Keywords:: +* Keyword Read Syntax:: +* Keyword Primitives:: @end menu @node Why Use Keywords? @@ -3590,10 +3687,10 @@ Return the vtable tag of the structure @var{handle}. @section Arrays @menu -* Conventional Arrays:: Arrays with arbitrary data. -* Array Mapping:: Applying a procedure to the contents of an array. -* Uniform Arrays:: Arrays with data of a single type. -* Bit Vectors:: Vectors of bits. +* Conventional Arrays:: Arrays with arbitrary data. +* Array Mapping:: Applying a procedure to the contents of an array. +* Uniform Arrays:: Arrays with data of a single type. +* Bit Vectors:: Vectors of bits. @end menu @node Conventional Arrays @@ -4076,8 +4173,8 @@ useful for organizing and indexing large bodies of information. @menu * Dictionary Types:: About dictionary types; what they're good for. -* Association Lists:: -* Hash Tables:: +* Association Lists:: +* Hash Tables:: @end menu @node Dictionary Types @@ -4148,12 +4245,12 @@ because association lists are so useful, Guile also provides specific procedures for manipulating them. @menu -* Alist Key Equality:: -* Adding or Setting Alist Entries:: -* Retrieving Alist Entries:: -* Removing Alist Entries:: -* Sloppy Alist Functions:: -* Alist Example:: +* Alist Key Equality:: +* Adding or Setting Alist Entries:: +* Retrieving Alist Entries:: +* Removing Alist Entries:: +* Sloppy Alist Functions:: +* Alist Example:: @end menu @node Alist Key Equality From 999010b63d5dcc36a1b85f58b0b22f4f09c4b5cc Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 29 Mar 2001 22:36:06 +0000 Subject: [PATCH 0768/2047] * boot-9.scm (init-dynamic-module): Fix typo in call to warn-autoload-deprecation. I feel silly. --- ice-9/boot-9.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index e96defa1f..57f8a3e8e 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1827,7 +1827,7 @@ (or-map (lambda (modinfo) (if (equal? (car modinfo) modname) (begin - (warn-autload-deprecation modname) + (warn-autoload-deprecation modname) (set! registered-modules (delq! modinfo registered-modules)) (let ((mod (resolve-module modname #f))) (save-module-excursion From 90cd76d9d80346988e2d334e54839edadb201594 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 29 Mar 2001 22:38:00 +0000 Subject: [PATCH 0769/2047] * eval.c (SCM_APPLY): Check that arg1 is bound for scm_tc7_cxr. --- libguile/eval.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/eval.c b/libguile/eval.c index d57ca1ac7..0d3c620fc 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3399,7 +3399,7 @@ tail: SCM_ASRTGO (SCM_NULLP (args), wrongnumargs); RETURN (SCM_SUBRF (proc) (arg1)) case scm_tc7_cxr: - SCM_ASRTGO (SCM_NULLP (args), wrongnumargs); + SCM_ASRTGO (!SCM_UNBNDP (arg1) && SCM_NULLP (args), wrongnumargs); if (SCM_SUBRF (proc)) { if (SCM_INUMP (arg1)) From 16c634ec156fa9bf0beddfe0b8e0177c329a4a16 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 29 Mar 2001 22:38:16 +0000 Subject: [PATCH 0770/2047] *** empty log message *** --- ice-9/ChangeLog | 5 +++++ libguile/ChangeLog | 4 ++++ 2 files changed, 9 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index d722a60df..c315174b8 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2001-03-29 Marius Vollmer + + * boot-9.scm (init-dynamic-module): Fix typo in call to + warn-autoload-deprecation. I feel silly. + 2001-03-27 Marius Vollmer * r4rs.scm (call-with-values): New definition, defers to diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 9fd396f53..10ac5c622 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2001-03-27 Marius Vollmer + + * eval.c (SCM_APPLY): Check that arg1 is bound for scm_tc7_cxr. + 2001-03-27 Martin Grabmueller * strop.c (scm_string_to_list): Fixed docstring markup. From 1b27e91a9b190050c23fb609b5463c2e12ca8913 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 30 Mar 2001 02:50:38 +0000 Subject: [PATCH 0771/2047] * goops.c, goops.h (scm_init_oop_goops_goopscore_module): Deprecated. * init.c (scm_init_guile_1): Don't init goopscore module. --- libguile/ChangeLog | 5 +++++ libguile/goops.c | 4 ++++ libguile/goops.h | 2 ++ libguile/init.c | 3 --- 4 files changed, 11 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 10ac5c622..6efe5d9a4 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-03-29 Keisuke Nishida + + * goops.c, goops.h (scm_init_oop_goops_goopscore_module): Deprecated. + * init.c (scm_init_guile_1): Don't init goopscore module. + 2001-03-27 Marius Vollmer * eval.c (SCM_APPLY): Check that arg1 is bound for scm_tc7_cxr. diff --git a/libguile/goops.c b/libguile/goops.c index f63a4a42f..beddf7dc9 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -2694,12 +2694,16 @@ scm_init_goops (void) scm_set_current_module (old_module); } +#if (SCM_DEBUG_DEPRECATED == 0) + void scm_init_oop_goops_goopscore_module () { scm_register_module_xxx ("oop goops goopscore", (void *) scm_init_goops); } +#endif /* (SCM_DEBUG_DEPRECATED == 0) */ + /* Local Variables: c-file-style: "gnu" diff --git a/libguile/goops.h b/libguile/goops.h index 624ca3075..c7de43bf4 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -237,7 +237,9 @@ SCM scm_m_atdispatch (SCM xorig, SCM env); #ifdef GUILE_DEBUG SCM scm_pure_generic_p (SCM obj); #endif +#if (SCM_DEBUG_DEPRECATED == 0) extern void scm_init_oop_goops_goopscore_module (void); +#endif /* (SCM_DEBUG_DEPRECATED == 0) */ SCM scm_sys_compute_slots (SCM c); SCM scm_i_get_keyword (SCM key, SCM l, int len, SCM default_value, const char *subr); diff --git a/libguile/init.c b/libguile/init.c index 8d3ca5f28..92ac9eaea 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -79,7 +79,6 @@ #include "libguile/fports.h" #include "libguile/gc.h" #include "libguile/gdbint.h" -#include "libguile/goops.h" #include "libguile/gsubr.h" #include "libguile/hash.h" #include "libguile/hashtab.h" @@ -575,8 +574,6 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_init_lang (); scm_init_script (); - scm_init_oop_goops_goopscore_module (); - scm_initialized_p = 1; scm_block_gc = 0; /* permit the gc to run */ From a255cf13ba382b967388db7ad5697cfb6ef77d31 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 30 Mar 2001 02:51:50 +0000 Subject: [PATCH 0772/2047] * goops/goopscore.scm: New file. --- oop/ChangeLog | 4 ++++ oop/goops/goopscore.scm | 0 2 files changed, 4 insertions(+) create mode 100644 oop/goops/goopscore.scm diff --git a/oop/ChangeLog b/oop/ChangeLog index 56c117c72..86d18d1ed 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -1,3 +1,7 @@ +2001-03-29 Keisuke Nishida + + * goops/goopscore.scm: New file. + 2001-03-09 Mikael Djurfeldt * goops.scm (define-method): Only accept new syntax. diff --git a/oop/goops/goopscore.scm b/oop/goops/goopscore.scm new file mode 100644 index 000000000..e69de29bb From 8715ff170378801396575750c54f32fba3a0b624 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 30 Mar 2001 02:53:53 +0000 Subject: [PATCH 0773/2047] Add scm_init_oop_goops_goopscore_module. --- RELEASE | 1 + 1 file changed, 1 insertion(+) diff --git a/RELEASE b/RELEASE index 37dd67785..87fab34b2 100644 --- a/RELEASE +++ b/RELEASE @@ -45,6 +45,7 @@ In release 1.6: try-module-dynamic-link init-dynamic-module scm_register_module_xxx + scm_init_oop_goops_goopscore_module etc. - remove deprecated variables: scm_top_level_lookup_closure_var From 22a52da14dd86801cc3a36837601929effde1904 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 30 Mar 2001 15:03:23 +0000 Subject: [PATCH 0774/2047] * Replaced a lot of calls to SCM_C[AD]R with more appropriate macros. * Minor cleanups to hashtable implementation. * Minor code beautifications. --- libguile/async.c | 14 ++----- libguile/debug.c | 9 ++--- libguile/eq.c | 4 +- libguile/eval.c | 89 +++++++++++++++++++++---------------------- libguile/eval.h | 10 ++--- libguile/fluids.c | 6 +-- libguile/gc.c | 22 +++++------ libguile/guardians.c | 8 ++-- libguile/hashtab.c | 63 ++++++++++++++---------------- libguile/keywords.c | 8 ++-- libguile/macros.h | 12 ++++-- libguile/ports.c | 2 +- libguile/ports.h | 12 +++--- libguile/print.c | 26 ++++++------- libguile/procs.h | 12 +++--- libguile/properties.c | 24 +++++++----- libguile/smob.c | 4 +- libguile/tags.h | 18 ++++----- libguile/throw.c | 8 ++-- libguile/variable.c | 41 ++++++++------------ libguile/variable.h | 10 ++--- libguile/vectors.c | 19 ++++++--- libguile/weaks.c | 17 ++++++--- 23 files changed, 218 insertions(+), 220 deletions(-) diff --git a/libguile/async.c b/libguile/async.c index e57b821ae..ae3f5dcaf 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 96, 97, 98, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001 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 @@ -130,7 +130,7 @@ scm_asyncs_pending () { SCM pos; pos = scm_asyncs; - while (pos != SCM_EOL) + while (!SCM_NULLP (pos)) { SCM a = SCM_CAR (pos); if (ASYNC_GOT_IT (a)) @@ -300,14 +300,8 @@ SCM_DEFINE (scm_system_async, "system-async", 1, 0, 0, "add it to the system's list of active async objects.") #define FUNC_NAME s_scm_system_async { - SCM it; - SCM list; - - it = scm_async (thunk); - SCM_NEWCELL (list); - SCM_SETCAR (list, it); - SCM_SETCDR (list, scm_asyncs); - scm_asyncs = list; + SCM it = scm_async (thunk); + scm_asyncs = scm_cons (it, scm_asyncs); return it; } #undef FUNC_NAME diff --git a/libguile/debug.c b/libguile/debug.c index 7c1cf8bc4..3b4f77fa9 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -504,11 +504,10 @@ SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_look SCM scm_reverse_lookup (SCM env, SCM data) { - SCM names, values; - while (SCM_NIMP (env) && SCM_SLOPPY_CONSP (SCM_CAR (env))) + while (SCM_CONSP (env) && SCM_CONSP (SCM_CAR (env))) { - names = SCM_CAAR (env); - values = SCM_CDAR (env); + SCM names = SCM_CAAR (env); + SCM values = SCM_CDAR (env); while (SCM_CONSP (names)) { if (SCM_EQ_P (SCM_CAR (values), data)) @@ -516,7 +515,7 @@ scm_reverse_lookup (SCM env, SCM data) names = SCM_CDR (names); values = SCM_CDR (values); } - if (! SCM_NULLP (names) && SCM_EQ_P (values, data)) + if (!SCM_NULLP (names) && SCM_EQ_P (values, data)) return names; env = SCM_CDR (env); } diff --git a/libguile/eq.c b/libguile/eq.c index 8eda34047..0bb7f0840 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001 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 @@ -136,7 +136,7 @@ SCM_DEFINE1 (scm_equal_p, "equal?", scm_tc7_rpsubr, return SCM_BOOL_F; if (SCM_IMP (y)) return SCM_BOOL_F; - if (SCM_SLOPPY_CONSP (x) && SCM_SLOPPY_CONSP (y)) + if (SCM_CONSP (x) && SCM_CONSP (y)) { if (SCM_FALSEP (scm_equal_p (SCM_CAR (x), SCM_CAR (y)))) return SCM_BOOL_F; diff --git a/libguile/eval.c b/libguile/eval.c index 0d3c620fc..67d90345f 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 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,7 @@ char *alloca (); ? *scm_lookupcar (x, env, 1) \ : SCM_CEVAL (SCM_CAR (x), env)) -#define EVALCAR(x, env) (SCM_NCELLP (SCM_CAR (x)) \ +#define EVALCAR(x, env) (!SCM_CELLP (SCM_CAR (x)) \ ? (SCM_IMP (SCM_CAR (x)) \ ? SCM_EVALIM (SCM_CAR (x), env) \ : SCM_GLOC_VAL (SCM_CAR (x))) \ @@ -790,11 +790,11 @@ scm_m_quasiquote (SCM xorig, SCM env) static SCM -iqq (SCM form,SCM env,int depth) +iqq (SCM form, SCM env, int depth) { SCM tmp; int edepth = depth; - if (SCM_IMP(form)) + if (SCM_IMP (form)) return form; if (SCM_VECTORP (form)) { @@ -805,7 +805,7 @@ iqq (SCM form,SCM env,int depth) tmp = scm_cons (data[i], tmp); return scm_vector (iqq (tmp, env, depth)); } - if (SCM_NCONSP(form)) + if (!SCM_CONSP (form)) return form; tmp = SCM_CAR (form); if (SCM_EQ_P (scm_sym_quasiquote, tmp)) @@ -824,7 +824,7 @@ iqq (SCM form,SCM env,int depth) return evalcar (form, env); return scm_cons2 (tmp, iqq (SCM_CAR (form), env, depth), SCM_EOL); } - if (SCM_NIMP (tmp) && (SCM_EQ_P (scm_sym_uq_splicing, SCM_CAR (tmp)))) + if (SCM_CONSP (tmp) && (SCM_EQ_P (scm_sym_uq_splicing, SCM_CAR (tmp)))) { tmp = SCM_CDR (tmp); if (0 == --edepth) @@ -876,10 +876,11 @@ scm_m_define (SCM x, SCM env) /* Only the first definition determines the name. */ && SCM_FALSEP (scm_procedure_property (arg1, scm_sym_name))) scm_set_procedure_property_x (arg1, scm_sym_name, proc); - else if (SCM_TYP16 (arg1) == scm_tc16_macro - && !SCM_EQ_P (SCM_CDR (arg1), arg1)) + else if (SCM_MACROP (arg1) + /* Dirk::FIXME: Does the following test make sense? */ + && !SCM_EQ_P (SCM_MACRO_CODE (arg1), arg1)) { - arg1 = SCM_CDR (arg1); + arg1 = SCM_MACRO_CODE (arg1); goto proc; } } @@ -1144,19 +1145,17 @@ scm_m_at_call_with_values (SCM xorig, SCM env) SCM scm_m_expand_body (SCM xorig, SCM env) { - SCM form, x = SCM_CDR (xorig), defs = SCM_EOL; + SCM x = SCM_CDR (xorig), defs = SCM_EOL; char *what = SCM_ISYMCHARS (SCM_CAR (xorig)) + 2; while (SCM_NIMP (x)) { - form = SCM_CAR (x); - if (SCM_IMP (form) || SCM_NCONSP (form)) - break; - if (SCM_IMP (SCM_CAR (form))) + SCM form = SCM_CAR (x); + if (!SCM_CONSP (form)) break; if (!SCM_SYMBOLP (SCM_CAR (form))) break; - + form = scm_macroexp (scm_cons_source (form, SCM_CAR (form), SCM_CDR (form)), @@ -1165,9 +1164,9 @@ scm_m_expand_body (SCM xorig, SCM env) if (SCM_EQ_P (SCM_IM_DEFINE, SCM_CAR (form))) { defs = scm_cons (SCM_CDR (form), defs); - x = SCM_CDR(x); + x = SCM_CDR (x); } - else if (SCM_NIMP(defs)) + else if (!SCM_IMP (defs)) { break; } @@ -1177,7 +1176,7 @@ scm_m_expand_body (SCM xorig, SCM env) } else { - x = scm_cons (form, SCM_CDR(x)); + x = scm_cons (form, SCM_CDR (x)); break; } } @@ -1229,13 +1228,11 @@ scm_macroexp (SCM x, SCM env) /* Only handle memoizing macros. `Acros' and `macros' are really special forms and should not be evaluated here. */ - if (SCM_IMP (proc) - || scm_tc16_macro != SCM_TYP16 (proc) - || (SCM_CELL_WORD_0 (proc) >> 16) != 2) + if (!SCM_MACROP (proc) || SCM_MACRO_TYPE (proc) != 2) return x; unmemocar (x, env); - res = scm_apply (SCM_CDR (proc), x, scm_cons (env, scm_listofnull)); + res = scm_apply (SCM_MACRO_CODE (proc), x, scm_cons (env, scm_listofnull)); if (scm_ilength (res) <= 0) res = scm_cons2 (SCM_IM_BEGIN, res, SCM_EOL); @@ -1510,7 +1507,7 @@ SCM scm_eval_args (SCM l, SCM env, SCM proc) { SCM results = SCM_EOL, *lloc = &results, res; - while (SCM_NIMP (l)) + while (!SCM_IMP (l)) { #ifdef SCM_CAUTIOUS if (SCM_CONSP (l)) @@ -1538,7 +1535,7 @@ scm_eval_args (SCM l, SCM env, SCM proc) l = SCM_CDR (l); } #ifdef SCM_CAUTIOUS - if (SCM_NNULLP (l)) + if (!SCM_NULLP (l)) { wrongnumargs: scm_wrong_num_args (proc); @@ -1733,7 +1730,7 @@ SCM scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc) { SCM *results = lloc, res; - while (SCM_NIMP (l)) + while (!SCM_IMP (l)) { #ifdef SCM_CAUTIOUS if (SCM_CONSP (l)) @@ -1761,7 +1758,7 @@ scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc) l = SCM_CDR (l); } #ifdef SCM_CAUTIOUS - if (SCM_NNULLP (l)) + if (!SCM_NULLP (l)) { wrongnumargs: scm_wrong_num_args (proc); @@ -1943,11 +1940,11 @@ dispatch: begin: /* If we are on toplevel with a lookup closure, we need to sync with the current module. */ - if (SCM_CONSP(env) && !SCM_CONSP(SCM_CAR(env))) + if (SCM_CONSP (env) && !SCM_CONSP (SCM_CAR (env))) { t.arg1 = x; UPDATE_TOPLEVEL_ENV (env); - while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) + while (!SCM_NULLP (t.arg1 = SCM_CDR (t.arg1))) { EVALCAR (x, env); x = t.arg1; @@ -1964,7 +1961,7 @@ dispatch: x = SCM_CDR (x); nontoplevel_begin: t.arg1 = x; - while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) + while (!SCM_NULLP (t.arg1 = SCM_CDR (t.arg1))) { if (SCM_IMP (SCM_CAR (x))) { @@ -1974,7 +1971,7 @@ dispatch: goto nontoplevel_begin; } else - SCM_EVALIM2 (SCM_CAR(x)); + SCM_EVALIM2 (SCM_CAR (x)); } else SCM_CEVAL (SCM_CAR (x), env); @@ -1982,7 +1979,7 @@ dispatch: } carloop: /* scm_eval car of last form in list */ - if (SCM_NCELLP (SCM_CAR (x))) + if (!SCM_CELLP (SCM_CAR (x))) { x = SCM_CAR (x); RETURN (SCM_IMP (x) ? SCM_EVALIM (x, env) : SCM_GLOC_VAL (x)) @@ -2026,18 +2023,18 @@ dispatch: case SCM_BIT8(SCM_IM_COND): - while (SCM_NIMP (x = SCM_CDR (x))) + while (!SCM_IMP (x = SCM_CDR (x))) { proc = SCM_CAR (x); t.arg1 = EVALCAR (proc, env); if (SCM_NFALSEP (t.arg1)) { x = SCM_CDR (proc); - if SCM_NULLP (x) + if (SCM_NULLP (x)) { RETURN (t.arg1) } - if (! SCM_EQ_P (scm_sym_arrow, SCM_CAR (x))) + if (!SCM_EQ_P (scm_sym_arrow, SCM_CAR (x))) { PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto begin; @@ -2147,10 +2144,10 @@ dispatch: case SCM_BIT8(SCM_IM_OR): x = SCM_CDR (x); t.arg1 = x; - while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) + while (!SCM_NULLP (t.arg1 = SCM_CDR (t.arg1))) { x = EVALCAR (x, env); - if (SCM_NFALSEP (x)) + if (!SCM_FALSEP (x)) { RETURN (x); } @@ -2576,7 +2573,7 @@ dispatch: unmemocar (x, env); goto badfun; } - if (scm_tc16_macro == SCM_TYP16 (proc)) + if (SCM_MACROP (proc)) { unmemocar (x, env); @@ -2586,19 +2583,19 @@ dispatch: application frames can be deleted from the backtrace. */ SCM_SET_MACROEXP (debug); #endif - t.arg1 = SCM_APPLY (SCM_CDR (proc), x, + t.arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x, scm_cons (env, scm_listofnull)); #ifdef DEVAL SCM_CLEAR_MACROEXP (debug); #endif - switch (SCM_CELL_WORD_0 (proc) >> 16) + switch (SCM_MACRO_TYPE (proc)) { case 2: if (scm_ilength (t.arg1) <= 0) t.arg1 = scm_cons2 (SCM_IM_BEGIN, t.arg1, SCM_EOL); #ifdef DEVAL - if (!SCM_CLOSUREP (SCM_CDR (proc))) + if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc))) { SCM_DEFER_INTS; SCM_SETCAR (x, SCM_CAR (t.arg1)); @@ -2626,7 +2623,7 @@ dispatch: } else proc = SCM_CEVAL (SCM_CAR (x), env); - SCM_ASRTGO (SCM_NIMP (proc), badfun); + SCM_ASRTGO (!SCM_IMP (proc), badfun); #ifndef SCM_RECKLESS #ifdef SCM_CAUTIOUS checkargs: @@ -2635,19 +2632,19 @@ dispatch: { arg2 = SCM_CAR (SCM_CODE (proc)); t.arg1 = SCM_CDR (x); - while (SCM_NIMP (arg2)) + while (!SCM_IMP (arg2)) { - if (SCM_NCONSP (arg2)) + if (!SCM_CONSP (arg2)) goto evapply; if (SCM_IMP (t.arg1)) goto umwrongnumargs; arg2 = SCM_CDR (arg2); t.arg1 = SCM_CDR (t.arg1); } - if (SCM_NNULLP (t.arg1)) + if (!SCM_NULLP (t.arg1)) goto umwrongnumargs; } - else if (scm_tc16_macro == SCM_TYP16 (proc)) + else if (SCM_MACROP (proc)) goto handle_a_macro; #endif } @@ -3778,7 +3775,7 @@ promise_print (SCM exp, SCM port, scm_print_state *pstate) int writingp = SCM_WRITINGP (pstate); scm_puts ("#', port); return !0; diff --git a/libguile/eval.h b/libguile/eval.h index ec387a4dd..60c5d737a 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef EVALH -#define EVALH -/* Copyright (C) 1995, 1996 ,1998, 1999, 2000 Free Software Foundation, Inc. +#ifndef SCM_EVAL_H +#define SCM_EVAL_H +/* Copyright (C) 1995,1996,1998,1999,2000,2001 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 @@ -180,8 +180,6 @@ extern SCM scm_sym_args; extern SCM scm_f_apply; -extern scm_bits_t scm_tc16_macro; - /* A resolved global variable reference in the CAR position * of a list is stored (in code only) as a pointer to a pair with a * tag of 1. This is called a "gloc". @@ -259,7 +257,7 @@ extern SCM scm_eval_x (SCM exp, SCM module); extern void scm_init_eval (void); -#endif /* EVALH */ +#endif /* SCM_EVAL_H */ /* Local Variables: diff --git a/libguile/fluids.c b/libguile/fluids.c index a52b2c8df..a76b05c76 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1996, 1997, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1996,1997,2000,2001 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 @@ -183,7 +183,7 @@ SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0, void scm_swap_fluids (SCM fluids, SCM vals) { - while (SCM_NIMP (fluids)) + while (!SCM_NULLP (fluids)) { SCM fl = SCM_CAR (fluids); SCM old_val = scm_fluid_ref (fl); @@ -200,7 +200,7 @@ same fluid appears multiple times in the fluids list. */ void scm_swap_fluids_reverse (SCM fluids, SCM vals) { - if (SCM_NIMP (fluids)) + if (!SCM_NULLP (fluids)) { SCM fl, old_val; diff --git a/libguile/gc.c b/libguile/gc.c index ebcddca09..a4336789f 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 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 @@ -1183,8 +1183,8 @@ gc_mark_loop_first_time: ptr = SCM_CDR (ptr); goto gc_mark_loop; case scm_tc7_pws: - RECURSE (SCM_CELL_OBJECT_2 (ptr)); - ptr = SCM_CDR (ptr); + RECURSE (SCM_SETTER (ptr)); + ptr = SCM_PROCEDURE (ptr); goto gc_mark_loop; case scm_tcs_cons_gloc: { @@ -1241,13 +1241,13 @@ gc_mark_loop_first_time: } break; case scm_tcs_closures: - if (SCM_IMP (SCM_CDR (ptr))) + if (SCM_IMP (SCM_ENV (ptr))) { ptr = SCM_CLOSCAR (ptr); goto gc_mark_nimp; } RECURSE (SCM_CLOSCAR (ptr)); - ptr = SCM_CDR (ptr); + ptr = SCM_ENV (ptr); goto gc_mark_nimp; case scm_tc7_vector: i = SCM_VECTOR_LENGTH (ptr); @@ -1541,8 +1541,8 @@ gc_sweep_freelist_finish (scm_freelist_t *freelist) if (!SCM_NULLP (freelist->cells)) { SCM c = freelist->cells; - SCM_SETCAR (c, SCM_CDR (c)); - SCM_SETCDR (c, SCM_EOL); + SCM_SET_CELL_WORD_0 (c, SCM_FREE_CELL_CDR (c)); + SCM_SET_CELL_WORD_1 (c, SCM_EOL); freelist->collected += freelist->span * (freelist->cluster_size - freelist->left_to_collect); } @@ -1733,7 +1733,7 @@ scm_gc_sweep () SCM_SETSTREAM (scmptr, 0); scm_remove_from_port_table (scmptr); scm_gc_ports_collected++; - SCM_SETAND_CAR (scmptr, ~SCM_OPN); + SCM_CLR_PORT_OPEN_FLAG (scmptr); } break; case scm_tc7_smob: @@ -1770,7 +1770,7 @@ scm_gc_sweep () if (!--left_to_collect) { - SCM_SETCAR (scmptr, nfreelist); + SCM_SET_CELL_WORD_0 (scmptr, nfreelist); *freelist->clustertail = scmptr; freelist->clustertail = SCM_CDRLOC (scmptr); @@ -2130,7 +2130,7 @@ init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, scm_freelist_t *freelist) } SCM_SET_CELL_TYPE (scmptr, scm_tc_free_cell); - SCM_SETCDR (scmptr, PTR2SCM (nxt)); + SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (nxt)); ptr = nxt; } @@ -2463,7 +2463,7 @@ scm_unprotect_object (SCM obj) handle = scm_hashq_get_handle (scm_protects, obj); - if (SCM_IMP (handle)) + if (SCM_FALSEP (handle)) { fprintf (stderr, "scm_unprotect_object called on unprotected object\n"); abort (); diff --git a/libguile/guardians.c b/libguile/guardians.c index fbecd9d9c..f7eac2817 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1998,1999,2000,2001 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 @@ -89,8 +89,8 @@ typedef struct tconc_t #define TCONC_IN(tc, obj, pair) \ do { \ SCM_SETCAR ((tc).tail, obj); \ - SCM_SETCAR (pair, SCM_BOOL_F); \ - SCM_SETCDR (pair, SCM_EOL); \ + SCM_SET_CELL_WORD_0 (pair, SCM_BOOL_F); \ + SCM_SET_CELL_WORD_1 (pair, SCM_EOL); \ SCM_SETCDR ((tc).tail, pair); \ (tc).tail = pair; \ } while (0) @@ -258,7 +258,7 @@ scm_guard (SCM guardian, SCM obj, int throw_p) if (GREEDY_P (g)) { - if (SCM_NFALSEP (scm_hashq_get_handle + if (!SCM_FALSEP (scm_hashq_get_handle (greedily_guarded_whash, obj))) { SCM_ALLOW_INTS; diff --git a/libguile/hashtab.c b/libguile/hashtab.c index 54500fdfe..9bcc16826 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001 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 @@ -60,21 +60,24 @@ scm_c_make_hash_table (unsigned long k) return scm_c_make_vector (k, SCM_EOL); } + SCM scm_hash_fn_get_handle (SCM table,SCM obj,unsigned int (*hash_fn)(),SCM (*assoc_fn)(),void * closure) +#define FUNC_NAME "scm_hash_fn_get_handle" { unsigned int k; SCM h; - SCM_ASSERT (SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_get_handle"); + SCM_VALIDATE_VECTOR (1, table); if (SCM_VECTOR_LENGTH (table) == 0) - return SCM_EOL; + return SCM_BOOL_F; k = hash_fn (obj, SCM_VECTOR_LENGTH (table), closure); if (k >= SCM_VECTOR_LENGTH (table)) scm_out_of_range ("hash_fn_get_handle", scm_ulong2num (k)); h = assoc_fn (obj, SCM_VELTS (table)[k], closure); return h; } +#undef FUNC_NAME SCM @@ -116,13 +119,11 @@ SCM scm_hash_fn_ref (SCM table,SCM obj,SCM dflt,unsigned int (*hash_fn)(), SCM (*assoc_fn)(),void * closure) { - SCM it; - - it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure); - if (SCM_IMP (it)) - return dflt; - else + SCM it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure); + if (SCM_CONSP (it)) return SCM_CDR (it); + else + return dflt; } @@ -165,16 +166,14 @@ scm_hash_fn_remove_x (SCM table,SCM obj,unsigned int (*hash_fn)(),SCM (*assoc_fn SCM_DEFINE (scm_hashq_get_handle, "hashq-get-handle", 2, 0, 0, - (SCM table, SCM obj), - "This procedure is similar to its @code{-ref} cousin, but returns a\n" - "@dfn{handle} from the hash table rather than the value associated with\n" - "@var{key}. By convention, a handle in a hash table is the pair which\n" - "associates a key with a value. Where @code{hashq-ref table key} returns\n" - "only a @code{value}, @code{hashq-get-handle table key} returns the pair\n" - "@code{(key . value)}.") + (SCM table, SCM key), + "This procedure returns the @code{(key . value)} pair from the\n" + "hash table @var{table}. If @var{table} does not hold an\n" + "associated value for @var{key}, @code{#f} is returned.\n" + "Uses @code{eq?} for equality testing.") #define FUNC_NAME s_scm_hashq_get_handle { - return scm_hash_fn_get_handle (table, obj, scm_ihashq, scm_sloppy_assq, 0); + return scm_hash_fn_get_handle (table, key, scm_ihashq, scm_sloppy_assq, 0); } #undef FUNC_NAME @@ -233,16 +232,14 @@ SCM_DEFINE (scm_hashq_remove_x, "hashq-remove!", 2, 0, 0, SCM_DEFINE (scm_hashv_get_handle, "hashv-get-handle", 2, 0, 0, - (SCM table, SCM obj), - "This procedure is similar to its @code{-ref} cousin, but returns a\n" - "@dfn{handle} from the hash table rather than the value associated with\n" - "@var{key}. By convention, a handle in a hash table is the pair which\n" - "associates a key with a value. Where @code{hashv-ref table key} returns\n" - "only a @code{value}, @code{hashv-get-handle table key} returns the pair\n" - "@code{(key . value)}.") + (SCM table, SCM key), + "This procedure returns the @code{(key . value)} pair from the\n" + "hash table @var{table}. If @var{table} does not hold an\n" + "associated value for @var{key}, @code{#f} is returned.\n" + "Uses @code{eqv?} for equality testing.") #define FUNC_NAME s_scm_hashv_get_handle { - return scm_hash_fn_get_handle (table, obj, scm_ihashv, scm_sloppy_assv, 0); + return scm_hash_fn_get_handle (table, key, scm_ihashv, scm_sloppy_assv, 0); } #undef FUNC_NAME @@ -299,16 +296,14 @@ SCM_DEFINE (scm_hashv_remove_x, "hashv-remove!", 2, 0, 0, SCM_DEFINE (scm_hash_get_handle, "hash-get-handle", 2, 0, 0, - (SCM table, SCM obj), - "This procedure is similar to its @code{-ref} cousin, but returns a\n" - "@dfn{handle} from the hash table rather than the value associated with\n" - "@var{key}. By convention, a handle in a hash table is the pair which\n" - "associates a key with a value. Where @code{hash-ref table key} returns\n" - "only a @code{value}, @code{hash-get-handle table key} returns the pair\n" - "@code{(key . value)}.") + (SCM table, SCM key), + "This procedure returns the @code{(key . value)} pair from the\n" + "hash table @var{table}. If @var{table} does not hold an\n" + "associated value for @var{key}, @code{#f} is returned.\n" + "Uses @code{equal?} for equality testing.") #define FUNC_NAME s_scm_hash_get_handle { - return scm_hash_fn_get_handle (table, obj, scm_ihash, scm_sloppy_assoc, 0); + return scm_hash_fn_get_handle (table, key, scm_ihash, scm_sloppy_assoc, 0); } #undef FUNC_NAME @@ -543,7 +538,7 @@ scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table) for (i = 0; i < n; ++i) { SCM ls = SCM_VELTS (table)[i], handle; - while (SCM_NNULLP (ls)) + while (!SCM_NULLP (ls)) { SCM_ASSERT (SCM_CONSP (ls), table, SCM_ARG1, s_scm_hash_fold); diff --git a/libguile/keywords.c b/libguile/keywords.c index 84d942dfa..3509314ea 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 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 @@ -112,7 +112,7 @@ SCM_DEFINE (scm_keyword_p, "keyword?", 1, 0, 0, "Returns @code{#t} if the argument @var{obj} is a keyword, else @code{#f}.") #define FUNC_NAME s_scm_keyword_p { - return SCM_BOOL(SCM_KEYWORDP (obj)); + return SCM_BOOL (SCM_KEYWORDP (obj)); } #undef FUNC_NAME @@ -123,8 +123,8 @@ SCM_DEFINE (scm_keyword_dash_symbol, "keyword-dash-symbol", 1, 0, 0, "This is the inverse of @code{make-keyword-from-dash-symbol}.") #define FUNC_NAME s_scm_keyword_dash_symbol { - SCM_VALIDATE_KEYWORD (1,keyword); - return SCM_CDR (keyword); + SCM_VALIDATE_KEYWORD (1, keyword); + return SCM_KEYWORDSYM (keyword); } #undef FUNC_NAME diff --git a/libguile/macros.h b/libguile/macros.h index 92436fe95..ccc80dffd 100644 --- a/libguile/macros.h +++ b/libguile/macros.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef MACROSH -#define MACROSH -/* Copyright (C) 1998, 2000 Free Software Foundation, Inc. +#ifndef SCM_MACROS_H +#define SCM_MACROS_H +/* Copyright (C) 1998,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -51,6 +51,10 @@ #define SCM_ASSYNT(_cond, _msg, _subr) \ if (!(_cond)) scm_misc_error (_subr, _msg, SCM_EOL); +#define SCM_MACROP(x) SCM_TYP16_PREDICATE (scm_tc16_macro, (x)) +#define SCM_MACRO_TYPE(m) (SCM_CELL_WORD_0 (m) >> 16) +#define SCM_MACRO_CODE(m) SCM_CELL_OBJECT_1 (m) + extern scm_bits_t scm_tc16_macro; extern SCM scm_makacro (SCM code); @@ -65,7 +69,7 @@ extern SCM scm_make_synt (const char *name, SCM (*fcn) ()); extern void scm_init_macros (void); -#endif /* MACROSH */ +#endif /* SCM_MACROS_H */ /* Local Variables: diff --git a/libguile/ports.c b/libguile/ports.c index 6884811d1..c480b7fc8 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -663,7 +663,7 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0, else rv = 0; scm_remove_from_port_table (port); - SCM_SETAND_CAR (port, ~SCM_OPN); + SCM_CLR_PORT_OPEN_FLAG (port); return SCM_NEGATE_BOOL (rv < 0); } #undef FUNC_NAME diff --git a/libguile/ports.h b/libguile/ports.h index fabf744eb..c8c96aa5b 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef PORTSH -#define PORTSH -/* Copyright (C) 1995,1996,1997,1998,1999, 2000, 2001 Free Software Foundation, Inc. +#ifndef SCM_PORTS_H +#define SCM_PORTS_H +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 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 @@ -152,7 +152,7 @@ extern int scm_port_table_size; /* Number of ports in scm_port_table. */ #define SCM_BUF0 (8L<<16) /* Is it unbuffered? */ #define SCM_BUFLINE (64L<<16) /* Is it line-buffered? */ -#define SCM_PORTP(x) (SCM_NIMP(x) && (SCM_TYP7(x)==scm_tc7_port)) +#define SCM_PORTP(x) (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_port)) #define SCM_OPPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_OPN) & SCM_CELL_WORD_0(x))==(scm_tc7_port | SCM_OPN))) #define SCM_OPINPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_OPN | SCM_RDNG) & SCM_CELL_WORD_0(x))==(scm_tc7_port | SCM_OPN | SCM_RDNG))) #define SCM_OPOUTPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_OPN | SCM_WRTNG) & SCM_CELL_WORD_0(x))==(scm_tc7_port | SCM_OPN | SCM_WRTNG))) @@ -164,6 +164,8 @@ extern int scm_port_table_size; /* Number of ports in scm_port_table. */ && (((0x7f | SCM_WRTNG) & SCM_CELL_WORD_0(x))==(scm_tc7_port | SCM_WRTNG))) #define SCM_OPENP(x) (SCM_NIMP(x) && (SCM_OPN & SCM_CELL_WORD_0 (x))) #define SCM_CLOSEDP(x) (!SCM_OPENP(x)) +#define SCM_CLR_PORT_OPEN_FLAG(p) \ + SCM_SET_CELL_WORD_0 ((p), SCM_CELL_WORD_0 (p) & ~SCM_OPN) #define SCM_PTAB_ENTRY(x) ((scm_port *) SCM_CELL_WORD_1 (x)) #define SCM_SETPTAB_ENTRY(x,ent) (SCM_SET_CELL_WORD_1 ((x), (scm_bits_t) (ent))) @@ -324,7 +326,7 @@ extern SCM scm_close_all_ports_except (SCM ports); #endif /* SCM_DEBUG_DEPRECATED == 0 */ -#endif /* PORTSH */ +#endif /* SCM_PORTS_H */ /* Local Variables: diff --git a/libguile/print.c b/libguile/print.c index 0c2adba12..b1f59d249 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995-1999, 2000, 2001 Free Software Foundation, Inc. +/* Copyright (C) 1995-1999,2000,2001 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 @@ -254,8 +254,8 @@ scm_free_print_state (SCM print_state) pstate->revealed = 0; SCM_NEWCELL (handle); SCM_DEFER_INTS; - SCM_SETCAR (handle, print_state); - SCM_SETCDR (handle, SCM_CDR (print_state_pool)); + SCM_SET_CELL_WORD_0 (handle, print_state); + SCM_SET_CELL_WORD_1 (handle, SCM_CDR (print_state_pool)); SCM_SETCDR (print_state_pool, handle); SCM_ALLOW_INTS; } @@ -419,7 +419,7 @@ taloop: exp, port, pstate))) { SCM name, code, env; - if (SCM_TYP16 (exp) == scm_tc16_macro) + if (SCM_MACROP (exp)) { /* Printing a macro. */ prinmacro: @@ -806,10 +806,11 @@ scm_ipruk (char *hdr, SCM ptr, SCM port) scm_putc ('>', port); } -/* Print a list. + +/* Print a list. The list may be either a list of ordinary data, or it may be + a list that represents code. Lists that represent code may contain gloc + cells. */ - - void scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate) { @@ -837,13 +838,10 @@ scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate) /* No cdr cycles intrinsic to this list */ scm_iprin1 (SCM_CAR (exp), port, pstate); - exp = SCM_CDR (exp); - for (; SCM_NIMP (exp); exp = SCM_CDR (exp)) + for (exp = SCM_CDR (exp); SCM_ECONSP (exp); exp = SCM_CDR (exp)) { register int i; - if (SCM_NECONSP (exp)) - break; for (i = floor; i >= 0; --i) if (SCM_EQ_P (pstate->ref_stack[i], exp)) goto circref; @@ -852,7 +850,7 @@ scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate) /* CHECK_INTS; */ scm_iprin1 (SCM_CAR (exp), port, pstate); } - if (SCM_NNULLP (exp)) + if (!SCM_NULLP (exp)) { scm_puts (" . ", port); scm_iprin1 (exp, port, pstate); @@ -869,12 +867,10 @@ fancy_printing: scm_iprin1 (SCM_CAR (exp), port, pstate); exp = SCM_CDR (exp); --n; - for (; SCM_NIMP (exp); exp = SCM_CDR (exp)) + for (; SCM_ECONSP (exp); exp = SCM_CDR (exp)) { register unsigned long i; - if (SCM_NECONSP (exp)) - break; for (i = 0; i < pstate->top; ++i) if (SCM_EQ_P (pstate->ref_stack[i], exp)) goto fancy_circref; diff --git a/libguile/procs.h b/libguile/procs.h index 3e332f0ab..7007b3d2b 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef PROCSH -#define PROCSH -/* Copyright (C) 1995, 1996, 1998, 1999, 2000 Free Software Foundation, Inc. +#ifndef SCM_PROCS_H +#define SCM_PROCS_H +/* Copyright (C) 1995,1996,1998,1999,2000,2001 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 @@ -97,8 +97,8 @@ typedef struct #define SCM_SETPROCPROPS(x, p) SCM_SETCDR (SCM_CLOSCAR (x), p) #define SCM_SETCODE(x, e) (SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (scm_cons ((e), SCM_EOL)) \ + scm_tc3_closure)) -#define SCM_ENV(x) SCM_CDR(x) -#define SCM_SETENV(x, e) SCM_SETCDR (x, e) +#define SCM_ENV(x) SCM_CELL_OBJECT_1 (x) +#define SCM_SETENV(x, e) SCM_SET_CELL_OBJECT_1 ((x), (e)) #define SCM_TOP_LEVEL(ENV) (SCM_NULLP (ENV) || (SCM_EQ_P (scm_procedure_p (SCM_CAR (ENV)), SCM_BOOL_T))) /* Procedure-with-setter @@ -194,7 +194,7 @@ extern SCM scm_make_cclo (SCM proc, SCM len); #endif /* SCM_DEBUG_DEPRECATED == 0 */ -#endif /* PROCSH */ +#endif /* SCM_PROCS_H */ /* Local Variables: diff --git a/libguile/properties.c b/libguile/properties.c index b33343862..6d9d8031b 100644 --- a/libguile/properties.c +++ b/libguile/properties.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,2000,2001 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 @@ -72,6 +72,7 @@ SCM_DEFINE (scm_primitive_make_property, "primitive-make-property", 1, 0, 0, } #undef FUNC_NAME + SCM_DEFINE (scm_primitive_property_ref, "primitive-property-ref", 2, 0, 0, (SCM prop, SCM obj), "Return the property @var{prop} of @var{obj}. When no value\n" @@ -83,22 +84,24 @@ SCM_DEFINE (scm_primitive_property_ref, "primitive-property-ref", 2, 0, 0, "default value of @var{prop}.") #define FUNC_NAME s_scm_primitive_property_ref { - SCM h, assoc; + SCM h; SCM_VALIDATE_CONS (SCM_ARG1, prop); h = scm_hashq_get_handle (scm_properties_whash, obj); - assoc = (SCM_NIMP (h) ? scm_assq (prop, SCM_CDR (h)) : SCM_BOOL_F); - if (SCM_NIMP (assoc)) - return SCM_CDR (assoc); + if (!SCM_FALSEP (h)) + { + SCM assoc = scm_assq (prop, SCM_CDR (h)); + if (!SCM_FALSEP (assoc)) + return SCM_CDR (assoc); + } if (SCM_FALSEP (SCM_CAR (prop))) return SCM_BOOL_F; else { - SCM val = scm_apply (SCM_CAR (prop), - SCM_LIST2 (prop, obj), SCM_EOL); - if (SCM_IMP (h)) + SCM val = scm_apply (SCM_CAR (prop), SCM_LIST2 (prop, obj), SCM_EOL); + if (SCM_FALSEP (h)) h = scm_hashq_create_handle_x (scm_properties_whash, obj, SCM_EOL); SCM_SETCDR (h, scm_acons (prop, val, SCM_CDR (h))); return val; @@ -106,6 +109,7 @@ SCM_DEFINE (scm_primitive_property_ref, "primitive-property-ref", 2, 0, 0, } #undef FUNC_NAME + SCM_DEFINE (scm_primitive_property_set_x, "primitive-property-set!", 3, 0, 0, (SCM prop, SCM obj, SCM val), "Associate @var{code} with @var{prop} and @var{obj}.") @@ -126,6 +130,7 @@ SCM_DEFINE (scm_primitive_property_set_x, "primitive-property-set!", 3, 0, 0, } #undef FUNC_NAME + SCM_DEFINE (scm_primitive_property_del_x, "primitive-property-del!", 2, 0, 0, (SCM prop, SCM obj), "Remove any value associated with @var{prop} and @var{obj}.") @@ -134,12 +139,13 @@ SCM_DEFINE (scm_primitive_property_del_x, "primitive-property-del!", 2, 0, 0, SCM h; SCM_VALIDATE_CONS (SCM_ARG1, prop); h = scm_hashq_get_handle (scm_properties_whash, obj); - if (SCM_NIMP (h)) + if (!SCM_FALSEP (h)) SCM_SETCDR (h, scm_assq_remove_x (SCM_CDR (h), prop)); return SCM_UNSPECIFIED; } #undef FUNC_NAME + void scm_init_properties () { diff --git a/libguile/smob.c b/libguile/smob.c index f7d00e910..6cd557cc7 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -88,9 +88,11 @@ scm_mark0 (SCM ptr) } SCM +/* Dirk::FIXME: The name markcdr is misleading, since the term cdr should only + be used for real pairs. */ scm_markcdr (SCM ptr) { - return SCM_CDR (ptr); + return SCM_CELL_OBJECT_1 (ptr); } /* {Free} diff --git a/libguile/tags.h b/libguile/tags.h index 846d27000..0670c16f7 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef TAGSH -#define TAGSH -/* Copyright (C) 1995, 96, 97, 98, 99, 2000 Free Software Foundation, Inc. +#ifndef SCM_TAGS_H +#define SCM_TAGS_H +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 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 @@ -271,10 +271,7 @@ typedef long scm_bits_t; * stored in the SCM_CAR of a non-immediate object have a 1 in bit 1: */ -#define SCM_SLOPPY_CONSP(x) ((1 & SCM_CELL_TYPE (x)) == 0) -#define SCM_SLOPPY_NCONSP(x) (!SCM_SLOPPY_CONSP(x)) - -#define SCM_CONSP(x) (!SCM_IMP (x) && SCM_SLOPPY_CONSP (x)) +#define SCM_CONSP(x) (!SCM_IMP (x) && ((1 & SCM_CELL_TYPE (x)) == 0)) #define SCM_NCONSP(x) (!SCM_CONSP (x)) @@ -283,7 +280,7 @@ typedef long scm_bits_t; */ #define SCM_ECONSP(x) \ (!SCM_IMP (x) \ - && (SCM_SLOPPY_CONSP (x) \ + && (SCM_CONSP (x) \ || (SCM_TYP3 (x) == 1 \ && (SCM_STRUCT_VTABLE_DATA (x)[scm_vtable_index_vcell] != 0)))) #define SCM_NECONSP(x) (!SCM_ECONSP (x)) @@ -542,6 +539,9 @@ extern char *scm_isymnames[]; /* defined in print.c */ #if (SCM_DEBUG_DEPRECATED == 0) +#define SCM_SLOPPY_CONSP(x) ((1 & SCM_CELL_TYPE (x)) == 0) +#define SCM_SLOPPY_NCONSP(x) (!SCM_SLOPPY_CONSP(x)) + #define scm_tc7_ssymbol scm_tc7_symbol #define scm_tc7_msymbol scm_tc7_symbol #define scm_tcs_symbols scm_tc7_symbol @@ -553,7 +553,7 @@ extern char *scm_isymnames[]; /* defined in print.c */ #endif /* SCM_DEBUG_DEPRECATED == 0 */ -#endif /* TAGSH */ +#endif /* SCM_TAGS_H */ /* Local Variables: diff --git a/libguile/throw.c b/libguile/throw.c index a1060595c..e0e921dcd 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1997, 1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001 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 @@ -71,8 +71,10 @@ static scm_bits_t tc16_jmpbuffer; #define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ) #define JBACTIVE(OBJ) (SCM_CELL_WORD_0 (OBJ) & (1L << 16L)) -#define ACTIVATEJB(OBJ) (SCM_SETOR_CAR (OBJ, (1L << 16L))) -#define DEACTIVATEJB(OBJ) (SCM_SETAND_CAR (OBJ, ~(1L << 16L))) +#define ACTIVATEJB(x) \ + (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) | (1L << 16L)))) +#define DEACTIVATEJB(x) \ + (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) & ~(1L << 16L)))) #define JBJMPBUF(OBJ) ((jmp_buf *) SCM_CELL_WORD_1 (OBJ)) #define SETJBJMPBUF(x,v) (SCM_SET_CELL_WORD_1 ((x), (v))) diff --git a/libguile/variable.c b/libguile/variable.c index 4ce7d6110..064744f73 100644 --- a/libguile/variable.c +++ b/libguile/variable.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1997, 1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001 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 @@ -59,17 +59,16 @@ static int variable_print (SCM exp, SCM port, scm_print_state *pstate) { scm_puts ("#', port); return 1; @@ -78,7 +77,7 @@ variable_print (SCM exp, SCM port, scm_print_state *pstate) static SCM variable_equalp (SCM var1, SCM var2) { - return scm_equal_p (SCM_CDR (var1), SCM_CDR (var2)); + return scm_equal_p (SCM_VARVCELL (var1), SCM_VARVCELL (var2)); } @@ -100,17 +99,13 @@ SCM_DEFINE (scm_make_variable, "make-variable", 1, 1, 0, "variable may exist, so @var{name-hint} is just that---a hint.\n") #define FUNC_NAME s_scm_make_variable { - SCM val_cell; + SCM vcell; if (SCM_UNBNDP (name_hint)) name_hint = anonymous_variable_sym; - SCM_NEWCELL(val_cell); - SCM_DEFER_INTS; - SCM_SETCAR (val_cell, name_hint); - SCM_SETCDR (val_cell, init); - SCM_ALLOW_INTS; - return make_vcell_variable (val_cell); + vcell = scm_cons (name_hint, init); + return make_vcell_variable (vcell); } #undef FUNC_NAME @@ -129,11 +124,7 @@ SCM_DEFINE (scm_make_undefined_variable, "make-undefined-variable", 0, 1, 0, if (SCM_UNBNDP (name_hint)) name_hint = anonymous_variable_sym; - SCM_NEWCELL (vcell); - SCM_DEFER_INTS; - SCM_SETCAR (vcell, name_hint); - SCM_SETCDR (vcell, SCM_UNDEFINED); - SCM_ALLOW_INTS; + vcell = scm_cons (name_hint, SCM_UNDEFINED); return make_vcell_variable (vcell); } #undef FUNC_NAME @@ -158,7 +149,7 @@ SCM_DEFINE (scm_variable_ref, "variable-ref", 1, 0, 0, #define FUNC_NAME s_scm_variable_ref { SCM_VALIDATE_VARIABLE (1, var); - return SCM_CDR (SCM_CDR (var)); + return SCM_CDR (SCM_VARVCELL (var)); } #undef FUNC_NAME @@ -171,8 +162,8 @@ SCM_DEFINE (scm_variable_set_x, "variable-set!", 2, 0, 0, "value. Return an unspecified value.\n") #define FUNC_NAME s_scm_variable_set_x { - SCM_VALIDATE_VARIABLE (1,var); - SCM_SETCDR (SCM_CDR (var), val); + SCM_VALIDATE_VARIABLE (1, var); + SCM_SETCDR (SCM_VARVCELL (var), val); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -213,8 +204,8 @@ SCM_DEFINE (scm_variable_bound_p, "variable-bound?", 1, 0, 0, "Throws an error if @var{var} is not a variable object.\n") #define FUNC_NAME s_scm_variable_bound_p { - SCM_VALIDATE_VARIABLE (1,var); - return SCM_NEGATE_BOOL(SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (var)))); + SCM_VALIDATE_VARIABLE (1, var); + return SCM_BOOL (!SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (var)))); } #undef FUNC_NAME diff --git a/libguile/variable.h b/libguile/variable.h index 22a2e0438..f5fc686ed 100644 --- a/libguile/variable.h +++ b/libguile/variable.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef VARIABLEH -#define VARIABLEH -/* Copyright (C) 1995,1996, 2000 Free Software Foundation, Inc. +#ifndef SCM_VARIABLE_H +#define SCM_VARIABLE_H +/* Copyright (C) 1995,1996,2000,2001 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 @@ -55,7 +55,7 @@ */ extern scm_bits_t scm_tc16_variable; -#define SCM_VARVCELL(V) SCM_CDR(V) +#define SCM_VARVCELL(V) SCM_CELL_OBJECT_1 (V) #define SCM_VARIABLEP(X) (!SCM_IMP (X) && SCM_CELL_TYPE (X) == scm_tc16_variable) #define SCM_UDVARIABLEP(X) (SCM_VARIABLEP(X) && SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X)))) #define SCM_DEFVARIABLEP(X) (SCM_VARIABLEP(X) && !SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X)))) @@ -71,7 +71,7 @@ extern SCM scm_builtin_variable (SCM name); extern SCM scm_variable_bound_p (SCM var); extern void scm_init_variable (void); -#endif /* VARIABLEH */ +#endif /* SCM_VARIABLE_H */ /* Local Variables: diff --git a/libguile/vectors.c b/libguile/vectors.c index bd1b7ba85..280b2eedf 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001 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 @@ -178,13 +178,20 @@ SCM_DEFINE (scm_vector, "vector", 0, 0, 1, #define FUNC_NAME s_scm_vector { SCM res; - register SCM *data; - int i; - SCM_VALIDATE_LIST_COPYLEN (1,l,i); + SCM *data; + long i; + + /* Dirk:FIXME:: In case of multiple threads, the list might get corrupted + while the vector is being created. */ + SCM_VALIDATE_LIST_COPYLEN (1, l, i); res = scm_c_make_vector (i, SCM_UNSPECIFIED); data = SCM_VELTS (res); - for(; i && SCM_NIMP(l); --i, l = SCM_CDR (l)) - *data++ = SCM_CAR (l); + while (!SCM_NULLP (l)) + { + *data++ = SCM_CAR (l); + l = SCM_CDR (l); + } + return res; } #undef FUNC_NAME diff --git a/libguile/weaks.c b/libguile/weaks.c index c01da2c61..c6cf591bb 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,2000,2001 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 @@ -88,17 +88,22 @@ SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1, #define FUNC_NAME s_scm_weak_vector { SCM res; - register SCM *data; + SCM *data; long i; + /* Dirk:FIXME:: In case of multiple threads, the list might get corrupted + while the vector is being created. */ i = scm_ilength (l); SCM_ASSERT (i >= 0, l, SCM_ARG1, FUNC_NAME); res = scm_make_weak_vector (SCM_MAKINUM (i), SCM_UNSPECIFIED); data = SCM_VELTS (res); - for (; - i && SCM_CONSP (l); - --i, l = SCM_CDR (l)) - *data++ = SCM_CAR (l); + + while (!SCM_NULLP (l)) + { + *data++ = SCM_CAR (l); + l = SCM_CDR (l); + } + return res; } #undef FUNC_NAME From ced99e9278fca333a2cd0e801c0fdbd7b5b03f61 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 30 Mar 2001 15:05:10 +0000 Subject: [PATCH 0775/2047] * The NEWS and RELEASE updates for the last submission. --- NEWS | 4 +++- RELEASE | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index 5c5fae78e..c96a4fd56 100644 --- a/NEWS +++ b/NEWS @@ -620,7 +620,7 @@ SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS, SCM_LENGTH_MAX, SCM_GC8MARKP, SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR, SCM_SUBR_DOC, SCM_OPDIRP, SCM_VALIDATE_OPDIR, SCM_WTA, RETURN_SCM_WTA, SCM_CONST_LONG, SCM_WNA, SCM_FUNC_NAME, SCM_VALIDATE_NUMBER_COPY, -SCM_VALIDATE_NUMBER_DEF_COPY +SCM_VALIDATE_NUMBER_DEF_COPY, SCM_SLOPPY_CONSP, SCM_SLOPPY_NCONSP Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of SCM_OUTOFRANGE. Use scm_memory_error instead of SCM_NALLOC. @@ -649,6 +649,8 @@ Use SCM_MISC_ERROR or SCM_WRONG_TYPE_ARG instead of SCM_WTA. Use SCM_MISC_ERROR or SCM_WRONG_TYPE_ARG instead of RETURN_SCM_WTA. Use SCM_VCELL_INIT instead of SCM_CONST_LONG. Use SCM_WRONG_NUM_ARGS instead of SCM_WNA. +Use SCM_CONSP instead of SCM_SLOPPY_CONSP. +Use !SCM_CONSP instead of SCM_SLOPPY_NCONSP. ** Removed function: scm_struct_init diff --git a/RELEASE b/RELEASE index 87fab34b2..574da00d6 100644 --- a/RELEASE +++ b/RELEASE @@ -69,7 +69,7 @@ In release 1.6: SCM_GC8MARKP, SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR, SCM_SUBR_DOC, SCM_OPDIRP, SCM_VALIDATE_OPDIR, SCM_WTA, RETURN_SCM_WTA, SCM_WNA, SCM_FUNC_NAME, SCM_VALIDATE_NUMBER_COPY, - SCM_VALIDATE_NUMBER_DEF_COPY + SCM_VALIDATE_NUMBER_DEF_COPY, SCM_SLOPPY_CONSP, SCM_SLOPPY_NCONSP - remove scm_vector_set_length_x - remove function scm_call_catching_errors (replaced by catch functions from throw.[ch]) From 85d6df6aa3191f3fc10a76824f7fd0f1658eecb4 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 30 Mar 2001 15:08:22 +0000 Subject: [PATCH 0776/2047] * Ehrm... The Changelog entry for the last submission... --- libguile/ChangeLog | 101 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 101 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6efe5d9a4..62c7bb80d 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,104 @@ +2001-03-30 Dirk Herrmann + + * async.c (scm_asyncs_pending): Don't use != to compare SCM + values. + + * async.c (scm_system_async), variable.c (scm_make_variable, + scm_make_undefined_variable): Use scm_cons to create a pair. + + * debug.c (scm_reverse_lookup): Perform proper type checking. + Remove suspicious use of SCM_SLOPPY_CONSP. + + * eq.c (scm_equal_p), tags.h (SCM_ECONSP): Use SCM_CONSP instead + of SCM_SLOPPY_CONSP. A sane compiler should be able to perform + the corresponding optimization. + + * eval.c (iqq): Use proper type check. + + (scm_m_expand_body): Remove redundant type checks. + + (promise_print): Don't access promise cells as pairs. + + * eval.c (EVALCAR, iqq, scm_m_expand_body, scm_eval_args, + scm_deval_args SCM_CEVAL), guardians.c (scm_guard), hashtab.c + (scm_internal_hash_fold), print.c (scm_iprlist): Use !SCM_CELLP + for SCM_NCELLP, !SCM_CONSP for SCM_NCONSP, !SCM_IMP for SCM_NIMP, + !SCM_FALSEP for SCM_NFALSEP, !SCM_NULLP for SCM_NNULLP + + * eval.c (scm_m_define, scm_macroexp, SCM_CEVAL), print.c + (scm_iprin1): Use new macro predicate and accessors. + + * eval.h (scm_tc16_macro): Removed declaration. It is declared + in macros.h. + + * eval.h (EVALH), macros.h (MACROSH), ports.h (PORTSH), procs.h + (PROCSH), tags.h (TAGSH), variable.h (VARIABLEH): Renamed to + SCM_EVAL_H, SCM_MACROS_H, SCM_PORTS_H, SCM_PROCS_H, SCM_TAGS_H and + SCM_VARIABLE_H. Even the macros that are used to inhibit + including a header file twice should be in the SCM_ namespace. + + * fluids.c (scm_swap_fluids, scm_swap_fluids_reverse), + properties.c (scm_primitive_property_ref, + scm_primitive_property_del_x): Prefer stronger predicates like + SCM_NULLP or SCM_FALSEP over SCM_IMP. + + * gc.c (MARK): Use proper macros to access procedure-with-setter + cell elements and closure cell elements. + + (gc_sweep_freelist_finish, scm_gc_sweep, init_heap_seg): Don't + access free cells as pairs. + + (scm_unprotect_object): scm_hashq_get_handle returns #f if + no hashtab entry is found. + + * gc.c (scm_gc_sweep), ports.c (scm_close_port): Use new macro + SCM_CLR_PORT_OPEN_FLAG. + + * guardians.c (TCONC_IN), print.c (scm_free_print_state): Don't + use SCM_SET_C[AD]R for uninitialized cells. + + * hashtab.c (scm_hash_fn_get_handle): Use SCM_VALIDATE_VECTOR. + If the hashtable has no slots, return #f instead of '(). This + unifies the return value with most assoc-functions. + + (scm_hash_fn_ref): Use proper type check. + + (scm_hashq_get_handle, scm_hashv_get_handle, scm_hash_get_handle): + Removed references to non-existing functions from documentation. + + * keywords.c (scm_keyword_dash_symbol): Use proper macros to + access keyword cell elements. + + * macros.h (SCM_MACROP, SCM_MACRO_TYPE, SCM_MACRO_CODE): New + macros. + + * ports.h (SCM_CLR_PORT_OPEN_FLAG): New macro. + + * print.c (scm_iprlist): Added comment. Improved loop + conditions. + + * procs.h (SCM_ENV, SCM_SETENV): Don't access closure cells as + pairs. + + * smob.c (scm_markcdr): Don't access smob cells as pairs. + + * tags.h (SCM_SLOPPY_CONSP, SCM_SLOPPY_NCONSP): Deprecated. + + * throw.c (ACTIVATEJB, DEACTIVATEJB): Don't access jump buffer + cells as pairs. + + * variable.c (variable_print, variable_equalp, scm_variable_ref, + scm_variable_set_x): Use proper macros to access variable cell + elements. + + (scm_variable_bound_p): Don't use SCM_NEGATE_BOOL. + + * variable.h (SCM_VARVCELL): Don't access variable cells as + pairs. + + * vectors.c (scm_vector), weaks.c (scm_weak_vector): Simplified, + added FIXME comment, removed register specifier. + 2001-03-29 Keisuke Nishida * goops.c, goops.h (scm_init_oop_goops_goopscore_module): Deprecated. From 4f60cc33ac4ad30de6edcdffb84fcc7c61262d77 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 30 Mar 2001 16:36:48 +0000 Subject: [PATCH 0777/2047] * NEWS updates and typo fixes. --- NEWS | 49 ++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 42 insertions(+), 7 deletions(-) diff --git a/NEWS b/NEWS index c96a4fd56..93f9d247e 100644 --- a/NEWS +++ b/NEWS @@ -20,7 +20,7 @@ This has been done to prevent problems on lesser operating systems that can't tolerate `*'s in file names. The exported macro continues to be named `and-let*', of course. -On systems that support it, there is also a compatability module named +On systems that support it, there is also a compatibility module named (ice-9 and-let*). It will go away in the next release. ** New modules (oop goops) etc.: @@ -79,8 +79,8 @@ Asking for the type of an object (is-a? v <2D-vector>) --> #t -See further in the GOOPS tutorial available in the guile-doc -distribution in info (goops.info) and texinfo formats. +See further in the GOOPS manual and tutorial in the `doc' directory, +in info (goops.info) and texinfo formats. ** New module (ice-9 rdelim). @@ -117,6 +117,38 @@ http://www.star-lab.com/wright/code.html for complete documentation. This module requires SLIB to be installed and available from Guile. +** New module (ice-9 buffered-input) + +This module provides procedures to construct an input port from an +underlying source of input that reads and returns its input in chunks. +The underlying input source is a Scheme procedure, specified by the +caller, which the port invokes whenever it needs more input. + +This is useful when building an input port whose back end is Readline +or a UI element such as the GtkEntry widget. + +** Documentation + +The reference and tutorial documentation that was previously +distributed separately, as `guile-doc', is now included in the core +Guile distribution. The documentation consists of the following +manuals. + +- The Guile Tutorial (guile-tut.texi) contains a tutorial introduction + to using Guile. + +- The Guile Reference Manual (guile.texi) contains (or is intended to + contain) reference documentation on all aspects of Guile. + +- The GOOPS Manual (goops.texi) contains both tutorial-style and + reference documentation for using GOOPS, Guile's Object Oriented + Programming System. + +- The Revised^4 and Revised^5 Reports on the Algorithmic Language + Scheme (r4rs.texi and r5rs.texi). + +See the README file in the `doc' directory for more details. + * Changes to the stand-alone interpreter ** Evaluation of "()", the empty list, is now an error. @@ -433,6 +465,7 @@ Set or get the hostname of the machine the current process is running on. ** New function: mkstemp! tmpl + mkstemp creates a new unique file in the file system and returns a new buffered port open for reading and writing to the file. TMPL is a string specifying where the file should be created: it must @@ -442,7 +475,7 @@ of the temporary file. ** New function: open-input-string string Return an input string port which delivers the characters from -`string'. This procedure, together with `open-input-string' and +`string'. This procedure, together with `open-output-string' and `get-output-string' implements SRFI-6. ** New function: open-output-string @@ -454,9 +487,11 @@ The data can then be retrieved by `get-output-string'. Return the contents of an output string port. -** Deprecated: close-all-ports-except. This was intended for closing -ports in a child process after a fork, but it has the undesirable side -effect of flushing buffers. port-for-each is more flexible. +** Deprecated: close-all-ports-except. + +This was intended for closing ports in a child process after a fork, +but it has the undesirable side effect of flushing buffers. +port-for-each is more flexible. ** The (ice-9 popen) module now attempts to set up file descriptors in the child process from the current Scheme ports, instead of using the From a4318577ec6560d1edc2b1baff8cb5baf3fa1b62 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 30 Mar 2001 16:37:51 +0000 Subject: [PATCH 0778/2047] * Typo fix. --- doc/ChangeLog | 4 ++++ doc/intro.texi | 4 ++-- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index a731a1d8d..3cabef271 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,7 @@ +2001-03-30 Neil Jerram + + * intro.texi (Modules and Extensions): Fix typo. + 2001-03-27 Martin Grabmueller * scheme-data.texi (Strings): Reorganized the whole `Strings' diff --git a/doc/intro.texi b/doc/intro.texi index 48bc59e07..2d60ef59d 100644 --- a/doc/intro.texi +++ b/doc/intro.texi @@ -1,4 +1,4 @@ -@c $Id: intro.texi,v 1.4 2001-03-25 00:31:10 mvo Exp $ +@c $Id: intro.texi,v 1.5 2001-03-30 16:37:51 ossau Exp $ @page @node What is Guile? @@ -736,7 +736,7 @@ write a Scheme file with this contents (dynamic-call "init_bessel" (dynamic-link "libguile-bessel")) @end smallexample -The file should of course be saved in the right place for autolading, +The file should of course be saved in the right place for autoloading, for example as @file{/usr/local/share/guile/math/bessel.scm}. @page From 6104519023c2b58e742a85b42270954c32584ad5 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 30 Mar 2001 17:01:28 +0000 Subject: [PATCH 0779/2047] * Made SCM_DEBUG_CELL_ACCESSES working again. --- NEWS | 3 ++- RELEASE | 3 ++- libguile/ChangeLog | 44 ++++++++++++++++++++++++++++++++ libguile/gc.c | 34 ++++++++++++++++--------- libguile/gc.h | 62 +++++++++++++++++++++++++++++++++------------- 5 files changed, 115 insertions(+), 31 deletions(-) diff --git a/NEWS b/NEWS index 93f9d247e..2db1398a1 100644 --- a/NEWS +++ b/NEWS @@ -655,7 +655,8 @@ SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS, SCM_LENGTH_MAX, SCM_GC8MARKP, SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR, SCM_SUBR_DOC, SCM_OPDIRP, SCM_VALIDATE_OPDIR, SCM_WTA, RETURN_SCM_WTA, SCM_CONST_LONG, SCM_WNA, SCM_FUNC_NAME, SCM_VALIDATE_NUMBER_COPY, -SCM_VALIDATE_NUMBER_DEF_COPY, SCM_SLOPPY_CONSP, SCM_SLOPPY_NCONSP +SCM_VALIDATE_NUMBER_DEF_COPY, SCM_SLOPPY_CONSP, SCM_SLOPPY_NCONSP, +SCM_SETAND_CDR, SCM_SETOR_CDR Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of SCM_OUTOFRANGE. Use scm_memory_error instead of SCM_NALLOC. diff --git a/RELEASE b/RELEASE index 574da00d6..b24a13d2e 100644 --- a/RELEASE +++ b/RELEASE @@ -69,7 +69,8 @@ In release 1.6: SCM_GC8MARKP, SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR, SCM_SUBR_DOC, SCM_OPDIRP, SCM_VALIDATE_OPDIR, SCM_WTA, RETURN_SCM_WTA, SCM_WNA, SCM_FUNC_NAME, SCM_VALIDATE_NUMBER_COPY, - SCM_VALIDATE_NUMBER_DEF_COPY, SCM_SLOPPY_CONSP, SCM_SLOPPY_NCONSP + SCM_VALIDATE_NUMBER_DEF_COPY, SCM_SLOPPY_CONSP, SCM_SLOPPY_NCONSP, + SCM_SETAND_CDR, SCM_SETOR_CDR - remove scm_vector_set_length_x - remove function scm_call_catching_errors (replaced by catch functions from throw.[ch]) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 62c7bb80d..2788964c5 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,47 @@ +2001-03-30 Dirk Herrmann + + * gc.[ch] (scm_tc16_allocated): New type tag for allocated cells. + It is only defined and used if guile is compiled with + SCM_DEBUG_CELL_ACCESSES set to true. It's purpose is, to never + let cells with a free_cell type tag be visible outside of the + garbage collector when in debug mode. + + * gc.c (scm_debug_cell_accesses_p): Set to true as default. + + (scm_assert_cell_valid): Use a local static variable to avoid + recursion. + + (MARK): Only check for rogue cell pointers in debug mode. Use + scm_cellp for this purpose and place all checks for rogue pointers + into that function. Further, since due to conservative scanning + we may encounter free cells during marking, don't use the standard + cell type accessor macro to determine the cell type. + + (scm_cellp): Check if the cell pointer actually points into a + card header. + + (scm_init_gc): Initalize scm_tc16_allocated. + + * gc.h (GCH): Renamed to SCM_GC_H. + + (SCM_VALIDATE_CELL): Enclose the expression in brackets. This + might be unnecessary, but I feel better this way :-) + + (SCM_GC_CELL_TYPE): New macro. + + (SCM_SETAND_CDR, SCM_SETOR_CDR): Deprecated. These are not used + in guile, and it is unlikely that they will be applied to real + pairs anyway. + + (SCM_SET_FREE_CELL_TYPE): Removed. It was not used. + + (SCM_GC_SET_ALLOCATED): New macro. Only non-empty if guile is + compiled with SCM_DEBUG_CELL_ACCESSES set to true. + + (SCM_NEWCELL, SCM_NEWCELL2): Use of SCM_GC_SET_ALLOCATED will + make sure that in debug mode no free cell will ever be visible + outside of the garbage collector. + 2001-03-30 Dirk Herrmann * async.c (scm_asyncs_pending): Don't use != to compare SCM diff --git a/libguile/gc.c b/libguile/gc.c index a4336789f..2b0888612 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -101,7 +101,11 @@ unsigned int scm_gc_running_p = 0; #if (SCM_DEBUG_CELL_ACCESSES == 1) -unsigned int scm_debug_cell_accesses_p = 0; +scm_bits_t scm_tc16_allocated; + +/* Set this to != 0 if every cell that is accessed shall be checked: + */ +unsigned int scm_debug_cell_accesses_p = 1; /* Assert that the given object is a valid reference to a valid cell. This @@ -112,9 +116,11 @@ unsigned int scm_debug_cell_accesses_p = 0; void scm_assert_cell_valid (SCM cell) { - if (scm_debug_cell_accesses_p) + static unsigned int already_running = 0; + + if (scm_debug_cell_accesses_p && !already_running) { - scm_debug_cell_accesses_p = 0; /* disable to avoid recursion */ + already_running = 1; /* set to avoid recursion */ if (!scm_cellp (cell)) { @@ -138,7 +144,7 @@ scm_assert_cell_valid (SCM cell) abort (); } } - scm_debug_cell_accesses_p = 1; /* re-enable */ + already_running = 0; /* re-enable */ } } @@ -1120,6 +1126,7 @@ MARK (SCM p) { register long i; register SCM ptr; + scm_bits_t cell_type; #ifndef MARK_DEPENDENCIES # define RECURSE scm_gc_mark @@ -1149,14 +1156,9 @@ gc_mark_nimp: gc_mark_loop_first_time: #endif - if (!SCM_CELLP (ptr)) +#if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST)) + if (!scm_cellp (ptr)) SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL); - -#if (defined (GUILE_DEBUG_FREELIST)) - - if (SCM_GC_IN_CARD_HEADERP (SCM2PTR (ptr))) - SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL); - #endif #ifndef MARK_DEPENDENCIES @@ -1168,7 +1170,8 @@ gc_mark_loop_first_time: #endif - switch (SCM_TYP7 (ptr)) + cell_type = SCM_GC_CELL_TYPE (ptr); + switch (SCM_ITAG7 (cell_type)) { case scm_tcs_cons_nimcar: if (SCM_IMP (SCM_CDR (ptr))) @@ -1499,6 +1502,9 @@ scm_cellp (SCM value) unsigned int i = 0; unsigned int j = scm_n_heap_segs - 1; + if (SCM_GC_IN_CARD_HEADERP (ptr)) + return 0; + while (i < j) { int k = (i + j) / 2; if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr)) { @@ -2698,6 +2704,10 @@ scm_init_gc () { SCM after_gc_thunk; +#if (SCM_DEBUG_CELL_ACCESSES == 1) + scm_tc16_allocated = scm_make_smob_type ("allocated cell", 0); +#endif /* SCM_DEBUG_CELL_ACCESSES == 1 */ + scm_after_gc_hook = scm_create_hook ("after-gc-hook", 0); #if (SCM_DEBUG_DEPRECATED == 0) diff --git a/libguile/gc.h b/libguile/gc.h index 18852624a..b833dc763 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef GCH -#define GCH -/* Copyright (C) 1995, 96, 98, 99, 2000 Free Software Foundation, Inc. +#ifndef SCM_GC_H +#define SCM_GC_H +/* Copyright (C) 1995,1996,1998,1999,2000,2001 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 @@ -173,7 +173,7 @@ typedef unsigned long scm_c_bvec_limb_t; #if (SCM_DEBUG_CELL_ACCESSES == 1) # define SCM_VALIDATE_CELL(cell, expr) (scm_assert_cell_valid (cell), (expr)) #else -# define SCM_VALIDATE_CELL(cell, expr) expr +# define SCM_VALIDATE_CELL(cell, expr) (expr) #endif #define SCM_CELL_WORD(x, n) \ @@ -207,14 +207,21 @@ typedef unsigned long scm_c_bvec_limb_t; #define SCM_CELL_TYPE(x) SCM_CELL_WORD_0 (x) #define SCM_SET_CELL_TYPE(x, t) SCM_SET_CELL_WORD_0 (x, t) + +/* Except for the garbage collector, no part of guile should ever run over a + * free cell. Thus, in debug mode the above macros report an error if they + * are applied to a free cell. Since the garbage collector is allowed to + * access free cells, it needs its own way to access cells which will not + * result in errors when in debug mode. */ + +#define SCM_GC_CELL_TYPE(x) \ + (((const scm_bits_t *) SCM2PTR (x)) [0]) + + #define SCM_SETAND_CAR(x, y) \ (SCM_SETCAR ((x), SCM_PACK (SCM_UNPACK (SCM_CAR (x)) & (y)))) -#define SCM_SETAND_CDR(x, y)\ - (SCM_SETCDR ((x), SCM_PACK (SCM_UNPACK (SCM_CDR (x)) & (y)))) #define SCM_SETOR_CAR(x, y)\ (SCM_SETCAR ((x), SCM_PACK (SCM_UNPACK (SCM_CAR (x)) | (y)))) -#define SCM_SETOR_CDR(x, y)\ - (SCM_SETCDR ((x), SCM_PACK (SCM_UNPACK (SCM_CDR (x)) | (y)))) #define SCM_CELL_WORD_LOC(x, n) ((scm_bits_t *) & SCM_CELL_WORD (x, n)) #define SCM_CARLOC(x) ((SCM *) SCM_CELL_WORD_LOC ((x), 0)) @@ -240,11 +247,17 @@ typedef unsigned long scm_c_bvec_limb_t; (!SCM_IMP (x) && (* (const scm_bits_t *) SCM2PTR (x) == scm_tc_free_cell)) #define SCM_FREE_CELL_CDR(x) \ (SCM_PACK (((const scm_bits_t *) SCM2PTR (x)) [1])) -#define SCM_SET_FREE_CELL_TYPE(x, v) \ - (((scm_bits_t *) SCM2PTR (x)) [0] = (v)) #define SCM_SET_FREE_CELL_CDR(x, v) \ (((scm_bits_t *) SCM2PTR (x)) [1] = SCM_UNPACK (v)) + +#if (SCM_DEBUG_CELL_ACCESSES == 1) +# define SCM_GC_SET_ALLOCATED(x) \ + (((scm_bits_t *) SCM2PTR (x)) [0] = scm_tc16_allocated) +#else +# define SCM_GC_SET_ALLOCATED(x) +#endif + #ifdef GUILE_DEBUG_FREELIST #define SCM_NEWCELL(_into) do { _into = scm_debug_newcell (); } while (0) #define SCM_NEWCELL2(_into) do { _into = scm_debug_newcell2 (); } while (0) @@ -254,23 +267,31 @@ typedef unsigned long scm_c_bvec_limb_t; #define SCM_NEWCELL(_into) \ do { \ if (SCM_IMP (scm_freelist)) \ + { \ _into = scm_gc_for_newcell (&scm_master_freelist, \ &scm_freelist); \ + SCM_GC_SET_ALLOCATED (_into); \ + } \ else \ { \ _into = scm_freelist; \ scm_freelist = SCM_FREE_CELL_CDR (scm_freelist); \ + SCM_GC_SET_ALLOCATED (_into); \ } \ } while(0) #define SCM_NEWCELL2(_into) \ do { \ if (SCM_IMP (scm_freelist2)) \ + { \ _into = scm_gc_for_newcell (&scm_master_freelist2, \ &scm_freelist2); \ + SCM_GC_SET_ALLOCATED (_into); \ + } \ else \ { \ _into = scm_freelist2; \ scm_freelist2 = SCM_FREE_CELL_CDR (scm_freelist2); \ + SCM_GC_SET_ALLOCATED (_into); \ } \ } while(0) #endif @@ -279,6 +300,11 @@ typedef unsigned long scm_c_bvec_limb_t; #define SCM_MARKEDP SCM_GCMARKP #define SCM_NMARKEDP(x) (!SCM_MARKEDP (x)) +#if (SCM_DEBUG_CELL_ACCESSES == 1) +extern scm_bits_t scm_tc16_allocated; +extern unsigned int scm_debug_cell_accesses_p; +#endif + extern struct scm_heap_seg_data_t *scm_heap_table; extern int scm_n_heap_segs; extern int scm_block_gc; @@ -314,12 +340,6 @@ extern scm_c_hook_t scm_before_sweep_c_hook; extern scm_c_hook_t scm_after_sweep_c_hook; extern scm_c_hook_t scm_after_gc_c_hook; -#if (SCM_DEBUG_CELL_ACCESSES == 1) -extern void scm_assert_cell_valid (SCM); -extern unsigned int scm_debug_cell_accesses_p; -extern SCM scm_set_debug_cell_accesses_x (SCM flag); -#endif - #if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST) extern SCM scm_map_free_list (void); extern SCM scm_free_list_length (void); @@ -332,6 +352,10 @@ extern SCM scm_gc_set_debug_check_freelist_x (SCM flag); +#if (SCM_DEBUG_CELL_ACCESSES == 1) +extern void scm_assert_cell_valid (SCM); +extern SCM scm_set_debug_cell_accesses_x (SCM flag); +#endif extern SCM scm_object_address (SCM obj); extern SCM scm_unhash_name (SCM name); extern SCM scm_gc_stats (void); @@ -370,6 +394,10 @@ extern void scm_init_gc (void); #if (SCM_DEBUG_DEPRECATED == 0) +#define SCM_SETAND_CDR(x, y)\ + (SCM_SETCDR ((x), SCM_PACK (SCM_UNPACK (SCM_CDR (x)) & (y)))) +#define SCM_SETOR_CDR(x, y)\ + (SCM_SETCDR ((x), SCM_PACK (SCM_UNPACK (SCM_CDR (x)) | (y)))) #define SCM_FREEP(x) (SCM_FREE_CELL_P (x)) #define SCM_NFREEP(x) (!SCM_FREE_CELL_P (x)) #define SCM_GC8MARKP(x) SCM_GCMARKP (x) @@ -381,7 +409,7 @@ extern void scm_remember (SCM * ptr); #endif /* SCM_DEBUG_DEPRECATED == 0 */ -#endif /* GCH */ +#endif /* SCM_GC_H */ /* Local Variables: From b0839672afe3274ff4db7a65842a55122f177607 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 30 Mar 2001 22:16:20 +0000 Subject: [PATCH 0780/2047] * scheme-reading.texi (Further Reading): Add bullets to further reading list. * gh.texi: Insert page break before chapter. Remove page breaks within the chapter. * Makefile.am: Add script-getopt.texi. * guile.texi (Top): Include and link to new script-getopt.texi chapter. * script-getopt.texi: New chapter on command line handling. (Written and contributed by Martin Grabmueller, revised by me.) --- doc/ChangeLog | 14 ++++++++++++++ doc/Makefile.am | 2 +- doc/gh.texi | 16 +++------------- doc/guile.texi | 6 ++++-- doc/scheme-reading.texi | 2 +- doc/script-getopt.texi | 0 6 files changed, 23 insertions(+), 17 deletions(-) create mode 100644 doc/script-getopt.texi diff --git a/doc/ChangeLog b/doc/ChangeLog index 3cabef271..fc9f7141f 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,5 +1,19 @@ 2001-03-30 Neil Jerram + * scheme-reading.texi (Further Reading): Add bullets to further + reading list. + + * gh.texi: Insert page break before chapter. Remove page breaks + within the chapter. + + * Makefile.am: Add script-getopt.texi. + + * guile.texi (Top): Include and link to new script-getopt.texi + chapter. + + * script-getopt.texi: New chapter on command line handling. + (Written and contributed by Martin Grabmueller, revised by me.) + * intro.texi (Modules and Extensions): Fix typo. 2001-03-27 Martin Grabmueller diff --git a/doc/Makefile.am b/doc/Makefile.am index 738fe2b60..9687ed8bd 100644 --- a/doc/Makefile.am +++ b/doc/Makefile.am @@ -31,7 +31,7 @@ guile_TEXINFOS = preface.texi intro.texi scheme-intro.texi \ scheme-translation.texi scheme-debug.texi deprecated.texi \ scheme-reading.texi scheme-indices.texi slib.texi posix.texi \ expect.texi scsh.texi tcltk.texi scripts.texi gh.texi scm.texi \ - appendices.texi indices.texi + appendices.texi indices.texi script-getopt.texi goops_TEXINFOS = goops-tutorial.texi hierarchy.eps hierarchy.txt diff --git a/doc/gh.texi b/doc/gh.texi index 6c18dd98a..691fd5515 100644 --- a/doc/gh.texi +++ b/doc/gh.texi @@ -1,3 +1,4 @@ +@page @node GH @chapter GH: A Portable C to Scheme Interface @cindex libguile - gh @@ -52,7 +53,7 @@ developed. * Mixing gh and scm APIs:: @end menu -@page + @node gh preliminaries @section gh preliminaries @@ -69,7 +70,6 @@ interpreter, you will have to add more libraries. @cindex gh - linking -@page @node Data types and constants defined by gh @section Data types and constants defined by gh @cindex libguile - data types @@ -103,7 +103,7 @@ value. It can be used in C to terminate functions with variable numbers of arguments, such as @code{gh_list()}. @end defvr -@page + @node Starting and controlling the interpreter @section Starting and controlling the interpreter @cindex libguile - start interpreter @@ -215,7 +215,6 @@ The resulting program @file{guile-gsl} would have new primitive procedures @code{gsl-ran-random}, @code{gsl-ran-gaussian} and so forth. -@page @node Error messages @section Error messages @cindex libguile - error messages @@ -224,7 +223,6 @@ procedures @code{gsl-ran-random}, @code{gsl-ran-gaussian} and so forth. [FIXME: need to fill this based on Jim's new mechanism] -@page @node Executing Scheme code @section Executing Scheme code @cindex libguile - executing Scheme @@ -256,8 +254,6 @@ closely. @end deftypefun - -@page @node Defining new Scheme procedures in C @section Defining new Scheme procedures in C @cindex libguile - new procedures @@ -329,7 +325,6 @@ These macros disable and reenable Scheme's flow control. They @c combinations of required and optional args...] -@page @node Converting data between C and Scheme @section Converting data between C and Scheme @cindex libguile - converting data @@ -468,7 +463,6 @@ that is, data will be copied as if the destination array was unsigned. @end deftypefun -@page @node Type predicates @section Type predicates @@ -518,7 +512,6 @@ Returns 1 if @var{val} is an exact number, 0 otherwise. @end deftypefun -@page @node Equality predicates @section Equality predicates @@ -555,7 +548,6 @@ Returns 1 if @var{l} is an empty list or pair; 0 otherwise. @end deftypefun -@page @node Memory allocation and garbage collection @section Memory allocation and garbage collection @@ -568,7 +560,6 @@ Returns 1 if @var{l} is an empty list or pair; 0 otherwise. @c @end deftypefun -@page @node Calling Scheme procedures from C @section Calling Scheme procedures from C @@ -810,6 +801,5 @@ here. @end smallexample -@page @node Mixing gh and scm APIs @section Mixing gh and scm APIs diff --git a/doc/guile.texi b/doc/guile.texi index 09519b3f3..fa2b78cad 100644 --- a/doc/guile.texi +++ b/doc/guile.texi @@ -144,7 +144,7 @@ by the Free Software Foundation. @sp 10 @comment The title is printed in a large font. @title Guile Reference Manual -@subtitle $Id: guile.texi,v 1.1 2001-03-09 08:21:59 ossau Exp $ +@subtitle $Id: guile.texi,v 1.2 2001-03-30 22:16:20 ossau Exp $ @subtitle For use with Guile @value{VERSION} @author Mark Galassi @author Cygnus Solution and Los Alamos National Laboratory @@ -256,7 +256,8 @@ Part III: Guile Modules Part IV: Guile Scripting * Guile Scripting:: How to write Guile scripts. - +* Command Line Handling:: Command line options and arguments. + Part V: Extending Applications Using Guile * Libguile Intro:: Using Guile as an extension language. @@ -335,6 +336,7 @@ Indices @end iftex @include scripts.texi +@include script-getopt.texi @c Guile as an extension language @iftex diff --git a/doc/scheme-reading.texi b/doc/scheme-reading.texi index 690a01f43..fab90ff72 100644 --- a/doc/scheme-reading.texi +++ b/doc/scheme-reading.texi @@ -2,7 +2,7 @@ @node Further Reading @chapter Further Reading -@itemize +@itemize @bullet @item Dorai Sitaram's online Scheme tutorial, @dfn{Teach Yourself Scheme in Fixnum Days}, at diff --git a/doc/script-getopt.texi b/doc/script-getopt.texi new file mode 100644 index 000000000..e69de29bb From 463b2219df03352a7e5c74e5755c6bd88988125c Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Sat, 31 Mar 2001 21:19:50 +0000 Subject: [PATCH 0781/2047] * backtrace.c (display_backtrace_body): since the `print_state' variable is not used (instead its data field is used directly as `pstate'), protect it from the hungry compiler optimizations. thanks to Bill Schottstaedt for the report. --- libguile/ChangeLog | 7 +++++++ libguile/backtrace.c | 2 ++ 2 files changed, 9 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 2788964c5..9ad37a584 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2001-03-31 Michael Livshin + + * backtrace.c (display_backtrace_body): since the `print_state' + variable is not used (instead its data field is used directly as + `pstate'), protect it from the hungry compiler optimizations. + thanks to Bill Schottstaedt for the report. + 2001-03-30 Dirk Herrmann * gc.[ch] (scm_tc16_allocated): New type tag for allocated cells. diff --git a/libguile/backtrace.c b/libguile/backtrace.c index d0f4820ba..4d2534ad3 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -604,6 +604,8 @@ display_backtrace_body(struct display_backtrace_args *a) display_frame (frame, nfield, indentation, sport, a->port, pstate); } + scm_remember_upto_here_1 (print_state); + return SCM_UNSPECIFIED; } #undef FUNC_NAME From 9a6976cd27118ae22a5514346437202668318c60 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 31 Mar 2001 22:55:27 +0000 Subject: [PATCH 0782/2047] * Re-introduce a cheap sanity test for non debug mode. --- libguile/ChangeLog | 5 +++++ libguile/gc.c | 7 ++++++- 2 files changed, 11 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 9ad37a584..2be583b3f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-04-01 Dirk Herrmann + + * gc.c (MARK): Re-introduce a cheap sanity test for non debug + mode, as suggested by Michael Livshin. + 2001-03-31 Michael Livshin * backtrace.c (display_backtrace_body): since the `print_state' diff --git a/libguile/gc.c b/libguile/gc.c index 2b0888612..020ee1ce7 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1155,10 +1155,15 @@ gc_mark_nimp: gc_mark_loop_first_time: #endif - + #if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST)) + /* We are in debug mode. Check the ptr exhaustively. */ if (!scm_cellp (ptr)) SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL); +#else + /* In non-debug mode, do at least some cheap testing. */ + if (!SCM_CELLP (ptr)) + SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL); #endif #ifndef MARK_DEPENDENCIES From f5e645584aa767be59cd22bf2152e8c9f1d63e59 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 2 Apr 2001 13:40:03 +0000 Subject: [PATCH 0783/2047] * Added some tests. --- test-suite/ChangeLog | 4 +++ test-suite/tests/symbols.test | 52 +++++++++++++++++++++++++++++++++++ 2 files changed, 56 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index c48e67f4d..57bfa51a4 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2001-04-02 Dirk Herrmann + + * tests/symbols.c: Added some tests. + 2001-03-19 Gary Houston * tests/r4rs.test: use test-file-name to locate r4rs.test, diff --git a/test-suite/tests/symbols.test b/test-suite/tests/symbols.test index 8483aa689..3524b492b 100644 --- a/test-suite/tests/symbols.test +++ b/test-suite/tests/symbols.test @@ -17,15 +17,67 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +(use-modules (ice-9 documentation)) + + +;;; +;;; miscellaneous +;;; ;; FIXME: As soon as guile supports immutable strings, this has to be ;; replaced with the appropriate error type and message. (define exception:immutable-string (cons 'some-error-type "^trying to modify an immutable string")) +(define (documented? object) + (not (not (object-documentation object)))) + + +;;; +;;; symbol? +;;; + +(with-test-prefix "symbol?" + + (pass-if "documented?" + (documented? symbol?)) + + (pass-if "string" + (not (symbol? "foo"))) + + (pass-if "symbol" + (symbol? 'foo))) + + +;;; +;;; symbol->string +;;; (with-test-prefix "symbol->string" (expect-fail-exception "result is an immutable string" exception:immutable-string (string-set! (symbol->string 'abc) 1 #\space))) + + +;;; +;;; gensym +;;; + +(with-test-prefix "gensym" + + (pass-if "documented?" + (documented? gensym)) + + (pass-if "produces a symbol" + (symbol? (gensym))) + + (pass-if "produces a fresh symbol" + (not (eq? (gensym) (gensym)))) + + (pass-if "accepts a string prefix" + (symbol? (gensym "foo"))) + + (pass-if-exception "does not accept a symbol prefix" + exception:wrong-type-arg + (gensym 'foo))) From abaec75d1d092f5bf648faa34be0e303879579ba Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Mon, 2 Apr 2001 21:53:20 +0000 Subject: [PATCH 0784/2047] * data-rep.texi (Immediates vs. Non-immediates): Update out-of-date documentation. (Thanks to Dirk Herrmann for the report!) (Immediates vs Non-immediates): Renamed without the dot, since the dot causes `info' not to be able to display this node! * Makefile.am (guile_TEXINFOS): Add in a few more source files that had got left out. --- doc/ChangeLog | 11 +++++++++++ doc/Makefile.am | 3 ++- doc/data-rep.texi | 35 ++++++++++++----------------------- 3 files changed, 25 insertions(+), 24 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index fc9f7141f..ffe4d2379 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,14 @@ +2001-04-02 Neil Jerram + + * data-rep.texi (Immediates vs. Non-immediates): Update + out-of-date documentation. (Thanks to Dirk Herrmann for the + report!) + (Immediates vs Non-immediates): Renamed without the dot, since the + dot causes `info' not to be able to display this node! + + * Makefile.am (guile_TEXINFOS): Add in a few more source files + that had got left out. + 2001-03-30 Neil Jerram * scheme-reading.texi (Further Reading): Add bullets to further diff --git a/doc/Makefile.am b/doc/Makefile.am index 9687ed8bd..f3a6cdbf9 100644 --- a/doc/Makefile.am +++ b/doc/Makefile.am @@ -31,7 +31,8 @@ guile_TEXINFOS = preface.texi intro.texi scheme-intro.texi \ scheme-translation.texi scheme-debug.texi deprecated.texi \ scheme-reading.texi scheme-indices.texi slib.texi posix.texi \ expect.texi scsh.texi tcltk.texi scripts.texi gh.texi scm.texi \ - appendices.texi indices.texi script-getopt.texi + appendices.texi indices.texi script-getopt.texi data-rep.texi \ + extend.texi goops_TEXINFOS = goops-tutorial.texi hierarchy.eps hierarchy.txt diff --git a/doc/data-rep.texi b/doc/data-rep.texi index 9b7b87977..81fbe8593 100644 --- a/doc/data-rep.texi +++ b/doc/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.17 2001-03-09 08:21:59 ossau Exp $ +@c essay @subtitle $Id: data-rep.texi,v 1.18 2001-04-02 21:53:20 ossau Exp $ @c essay @subtitle For use with Guile @value{VERSION} @c essay @author Jim Blandy @c essay @author Free Software Foundation @@ -433,7 +433,7 @@ everything one need know to use Guile's data. @menu * General Rules:: * Conservative GC:: -* Immediates vs. Non-immediates:: +* Immediates vs Non-immediates:: * Immediate Datatypes:: * Non-immediate Datatypes:: * Signalling Type Errors:: @@ -554,8 +554,8 @@ many pieces of code, it is enough for the collector to find the cell, and then use the cell's type to find more pointers to trace. -@node Immediates vs. Non-immediates -@subsection Immediates vs. Non-immediates +@node Immediates vs Non-immediates +@subsection Immediates vs Non-immediates Guile classifies Scheme objects into two kinds: those that fit entirely within an @code{SCM}, and those that require heap storage. @@ -575,25 +575,14 @@ Return non-zero iff @var{x} is an immediate object. @deftypefn Macro int SCM_NIMP (SCM @var{x}) Return non-zero iff @var{x} is a non-immediate object. This is the exact complement of @code{SCM_IMP}, above. - -You must use this macro before calling a finer-grained predicate to -determine @var{x}'s type. For example, to see if @var{x} is a pair, you -must write: -@example -SCM_NIMP (@var{x}) && SCM_CONSP (@var{x}) -@end example -This is because Guile stores typing information for non-immediate values -in their cells, rather than in the @code{SCM} value itself; thus, you -must determine whether @var{x} refers to a cell before looking inside -it. - -This is somewhat of a pity, because it means that the programmer needs -to know which types Guile implements as immediates vs. non-immediates. -There are (possibly better) representations in which @code{SCM_CONSP} -can be self-sufficient. The immediate type predicates do not suffer -from this weakness. @end deftypefn +Note that, as of Guile 1.4, it is no longer necessary to use the +@code{SCM_NIMP} macro before calling a finer-grained predicate to +determine @var{x}'s type, such as @code{SCM_CONSP} or +@code{SCM_VECTORP}. The definitions of all Guile type predicates +now include a call to @code{SCM_NIMP} where necessary. + @node Immediate Datatypes @subsection Immediate Datatypes @@ -601,7 +590,7 @@ from this weakness. The following datatypes are immediate values; that is, they fit entirely within an @code{SCM} value. The @code{SCM_IMP} and @code{SCM_NIMP} macros will distinguish these from non-immediates; see @ref{Immediates -vs. Non-immediates} for an explanation of the distinction. +vs Non-immediates} for an explanation of the distinction. Note that the type predicates for immediate values work correctly on any @code{SCM} value; you do not need to call @code{SCM_IMP} first, to @@ -748,7 +737,7 @@ specific storage location (in the nomenclature of the Revised^4 Report on Scheme). The @code{SCM_IMP} and @code{SCM_NIMP} macros will distinguish these -from immediates; see @ref{Immediates vs. Non-immediates}. +from immediates; see @ref{Immediates vs Non-immediates}. Given a cell, Guile distinguishes between pairs and other non-immediate types by storing special @dfn{tag} values in a non-pair cell's car, that From ae9f3a15826847d280f69b179c2e09776892a9c6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Tue, 3 Apr 2001 13:11:14 +0000 Subject: [PATCH 0785/2047] * scheme-options.texi, scheme-procedures.texi, scheme-modules.texi, scheme-memory.texi, scheme-control.texi, scheme-utility.texi, scheme-io.texi, scheme-evaluation.texi, scheme-data.texi: Removed a lot of ARGFIXME's after tweaking docstrings and C source. * new-docstrings.texi, scheme-io.texi, scheme-data.texi, posix.texi, scheme-control.texi, scheme-evaluation.texi, scheme-memory.texi, scheme-procedures.texi, scheme-modules.texi, scheme-scheduling.texi: Automated docstring merging. --- doc/ChangeLog | 13 + doc/maint/ChangeLog | 4 + doc/maint/guile.texi | 1719 +++++++++++++++++------------------- doc/new-docstrings.texi | 19 +- doc/posix.texi | 493 +++++------ doc/scheme-control.texi | 96 +- doc/scheme-data.texi | 739 +++++++--------- doc/scheme-evaluation.texi | 14 +- doc/scheme-io.texi | 235 +++-- doc/scheme-memory.texi | 39 +- doc/scheme-modules.texi | 68 +- doc/scheme-options.texi | 4 +- doc/scheme-procedures.texi | 51 +- doc/scheme-scheduling.texi | 12 +- doc/scheme-utility.texi | 10 +- 15 files changed, 1641 insertions(+), 1875 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index ffe4d2379..b589abad3 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,16 @@ +2001-04-03 Martin Grabmueller + + * scheme-options.texi, scheme-procedures.texi, + scheme-modules.texi, scheme-memory.texi, scheme-control.texi, + scheme-utility.texi, scheme-io.texi, scheme-evaluation.texi, + scheme-data.texi: Removed a lot of ARGFIXME's after tweaking + docstrings and C source. + + * new-docstrings.texi, scheme-io.texi, scheme-data.texi, + posix.texi, scheme-control.texi, scheme-evaluation.texi, + scheme-memory.texi, scheme-procedures.texi, scheme-modules.texi, + scheme-scheduling.texi: Automated docstring merging. + 2001-04-02 Neil Jerram * data-rep.texi (Immediates vs. Non-immediates): Update diff --git a/doc/maint/ChangeLog b/doc/maint/ChangeLog index c8c549ea1..0572b38f3 100644 --- a/doc/maint/ChangeLog +++ b/doc/maint/ChangeLog @@ -1,3 +1,7 @@ +2001-04-03 Martin Grabmueller + + * guile.texi: Automated docstring merging. + 2001-03-23 Neil Jerram * ChangeLog, README, docstring.el, guile.texi: New files. diff --git a/doc/maint/guile.texi b/doc/maint/guile.texi index d51d06804..139946c90 100644 --- a/doc/maint/guile.texi +++ b/doc/maint/guile.texi @@ -484,10 +484,11 @@ only by module bookkeeping operations. dynamic-link @c snarfed from dynl.c:356 -@deffn primitive dynamic-link fname -Open the dynamic library @var{library-file}. A library handle -representing the opened library is returned; this handle should be used -as the @var{lib} argument to the following functions. +@deffn primitive dynamic-link filename +Open the dynamic library called @var{filename}. A library +handle representing the opened library is returned; this handle +should be used as the @var{dobj} argument to the following +functions. @end deffn dynamic-object? @@ -500,13 +501,10 @@ otherwise. dynamic-unlink @c snarfed from dynl.c:388 @deffn primitive dynamic-unlink dobj -Unlink the library represented by @var{library-handle}, -and remove any imported symbols from the address space. -GJB:FIXME:DOC: 2nd version below: Unlink the indicated object file from the application. The -argument @var{dynobj} must have been obtained by a call to +argument @var{dobj} must have been obtained by a call to @code{dynamic-link}. After @code{dynamic-unlink} has been -called on @var{dynobj}, its content is no longer accessible. +called on @var{dobj}, its content is no longer accessible. @end deffn dynamic-func @@ -526,20 +524,14 @@ needed or not and will add it when necessary. dynamic-call @c snarfed from dynl.c:460 @deffn primitive dynamic-call func dobj -Call @var{lib-thunk}, a procedure of no arguments. If @var{lib-thunk} -is a string, it is assumed to be a symbol found in the dynamic library -@var{lib} and is fetched with @code{dynamic-func}. Otherwise, it should -be a function handle returned by a previous call to @code{dynamic-func}. -The return value is unspecified. -GJB:FIXME:DOC 2nd version below -Call the C function indicated by @var{function} and @var{dynobj}. The -function is passed no arguments and its return value is ignored. When -@var{function} is something returned by @code{dynamic-func}, call that -function and ignore @var{dynobj}. When @var{function} is a string (or -symbol, etc.), look it up in @var{dynobj}; this is equivalent to - +Call the C function indicated by @var{func} and @var{dobj}. +The function is passed no arguments and its return value is +ignored. When @var{function} is something returned by +@code{dynamic-func}, call that function and ignore @var{dobj}. +When @var{func} is a string , look it up in @var{dynobj}; this +is equivalent to @smallexample -(dynamic-call (dynamic-func @var{function} @var{dynobj} #f)) +(dynamic-call (dynamic-func @var{func} @var{dobj} #f)) @end smallexample Interrupts are deferred while the C function is executing (with @@ -549,47 +541,36 @@ Interrupts are deferred while the C function is executing (with dynamic-args-call @c snarfed from dynl.c:494 @deffn primitive dynamic-args-call func dobj args -Call @var{proc}, a dynamically loaded function, passing it the argument -list @var{args} (a list of strings). As with @code{dynamic-call}, -@var{proc} should be either a function handle or a string, in which case -it is first fetched from @var{lib} with @code{dynamic-func}. - -@var{proc} is assumed to return an integer, which is used as the return -value from @code{dynamic-args-call}. - -GJB:FIXME:DOC 2nd version below -Call the C function indicated by @var{function} and @var{dynobj}, just -like @code{dynamic-call}, but pass it some arguments and return its -return value. The C function is expected to take two arguments and -return an @code{int}, just like @code{main}: - +Call the C function indicated by @var{func} and @var{dobj}, +just like @code{dynamic-call}, but pass it some arguments and +return its return value. The C function is expected to take +two arguments and return an @code{int}, just like @code{main}: @smallexample int c_func (int argc, char **argv); @end smallexample -The parameter @var{args} must be a list of strings and is converted into -an array of @code{char *}. The array is passed in @var{argv} and its -size in @var{argc}. The return value is converted to a Scheme number -and returned from the call to @code{dynamic-args-call}. +The parameter @var{args} must be a list of strings and is +converted into an array of @code{char *}. The array is passed +in @var{argv} and its size in @var{argc}. The return value is +converted to a Scheme number and returned from the call to +@code{dynamic-args-call}. @end deffn dynamic-wind @c snarfed from dynwind.c:115 -@deffn primitive dynamic-wind thunk1 thunk2 thunk3 +@deffn primitive dynamic-wind in_guard thunk out_guard All three arguments must be 0-argument procedures. - -@var{in-guard} is called, then @var{thunk}, then @var{out-guard}. - -If, any time during the execution of @var{thunk}, the continuation -of the @code{dynamic-wind} expression is escaped non-locally, @var{out-guard} -is called. If the continuation of the dynamic-wind is re-entered, -@var{in-guard} is called. Thus @var{in-guard} and @var{out-guard} may -be called any number of times. - -@example +@var{in_guard} is called, then @var{thunk}, then +@var{out_guard}. +If, any time during the execution of @var{thunk}, the +continuation of the @code{dynamic_wind} expression is escaped +non-locally, @var{out_guard} is called. If the continuation of +the dynamic-wind is re-entered, @var{in_guard} is called. Thus +@var{in_guard} and @var{out_guard} may be called any number of +times. +@lisp (define x 'normal-binding) @result{} x - (define a-cont (call-with-current-continuation (lambda (escape) (let ((old-x x)) @@ -597,38 +578,31 @@ be called any number of times. ;; in-guard: ;; (lambda () (set! x 'special-binding)) - ;; thunk ;; (lambda () (display x) (newline) (call-with-current-continuation escape) (display x) (newline) x) - ;; out-guard: ;; (lambda () (set! x old-x))))))) - ;; Prints: special-binding ;; Evaluates to: @result{} a-cont - x @result{} normal-binding - (a-cont #f) ;; Prints: special-binding ;; Evaluates to: @result{} a-cont ;; the value of the (define a-cont...) - x @result{} normal-binding - a-cont @result{} special-binding -@end example +@end lisp @end deffn environment? @@ -667,26 +641,26 @@ If @var{env} contains no bindings, this function simply returns @var{init}. If @var{env} binds the symbol sym1 to the value val1, sym2 to val2, and so on, then this procedure computes: -@example +@lisp (proc sym1 val1 (proc sym2 val2 ... (proc symn valn init))) -@end example +@end lisp Each binding in @var{env} will be processed exactly once. @code{environment-fold} makes no guarantees about the order in which the bindings are processed. Here is a function which, given an environment, constructs an association list representing that environment's bindings, using environment-fold: -@example +@lisp (define (environment->alist env) (environment-fold env (lambda (sym val tail) (cons (cons sym val) tail)) '())) -@end example +@end lisp @end deffn environment-define @@ -1008,24 +982,27 @@ terminate if its arguments are circular data structures. scm-error @c snarfed from error.c:112 -@deffn primitive scm-error key subr message args rest -Raise an error with key @var{key}. @var{subr} can be a string naming -the procedure associated with the error, or @code{#f}. @var{message} -is the error message string, possibly containing @code{~S} and @code{~A} -escapes. When an error is reported, these are replaced by formating the -corresponding members of @var{args}: @code{~A} (was @code{%s}) formats using @code{display} -and @code{~S} (was @code{%S}) formats using @code{write}. @var{data} is a -list or @code{#f} depending on @var{key}: if @var{key} is -@code{system-error} then it should be a list -containing the Unix @code{errno} value; If @var{key} is @code{signal} then -it should be a list containing the Unix signal number; otherwise it -will usually be @code{#f}. +@deffn primitive scm-error key subr message args data +Raise an error with key @var{key}. @var{subr} can be a string +naming the procedure associated with the error, or @code{#f}. +@var{message} is the error message string, possibly containing +@code{~S} and @code{~A} escapes. When an error is reported, +these are replaced by formatting the corresponding members of +@var{args}: @code{~A} (was @code{%s} in older versions of +Guile) formats using @code{display} and @code{~S} (was +@code{%S}) formats using @code{write}. @var{data} is a list or +@code{#f} depending on @var{key}: if @var{key} is +@code{system-error} then it should be a list containing the +Unix @code{errno} value; If @var{key} is @code{signal} then it +should be a list containing the Unix signal number; otherwise +it will usually be @code{#f}. @end deffn strerror @c snarfed from error.c:153 @deffn primitive strerror err -Returns the Unix error message corresponding to @var{err}, an integer. +Return the Unix error message corresponding to @var{err}, which +must be an integer value. @end deffn apply:nconc2last @@ -1178,8 +1155,8 @@ E.g., @code{(umask #o022)} sets the mask to octal 22, decimal 18. open-fdes @c snarfed from filesys.c:237 @deffn primitive open-fdes path flags [mode] -Similar to @code{open} but returns a file descriptor instead of a -port. +Similar to @code{open} but return a file descriptor instead of +a port. @end deffn open @@ -1237,25 +1214,24 @@ The return value is unspecified. stat @c snarfed from filesys.c:518 @deffn primitive stat object -Returns an object containing various information -about the file determined by @var{obj}. -@var{obj} can be a string containing a file name or a port or integer file -descriptor which is open on a file (in which case @code{fstat} is used -as the underlying system call). - -The object returned by @code{stat} can be passed as a single parameter -to the following procedures, all of which return integers: - +Return an object containing various information about the file +determined by @var{obj}. @var{obj} can be a string containing +a file name or a port or integer file descriptor which is open +on a file (in which case @code{fstat} is used as the underlying +system call). +The object returned by @code{stat} can be passed as a single +parameter to the following procedures, all of which return +integers: @table @code @item stat:dev The device containing the file. @item stat:ino -The file serial number, which distinguishes this file from all other -files on the same device. +The file serial number, which distinguishes this file from all +other files on the same device. @item stat:mode -The mode of the file. This includes file type information -and the file permission bits. See @code{stat:type} and @code{stat:perms} -below. +The mode of the file. This includes file type information and +the file permission bits. See @code{stat:type} and +@code{stat:perms} below. @item stat:nlink The number of hard links to the file. @item stat:uid @@ -1274,20 +1250,19 @@ The last modification time for the file. @item stat:ctime The last modification time for the attributes of the file. @item stat:blksize -The optimal block size for reading or writing the file, in bytes. +The optimal block size for reading or writing the file, in +bytes. @item stat:blocks -The amount of disk space that the file occupies measured in units of -512 byte blocks. +The amount of disk space that the file occupies measured in +units of 512 byte blocks. @end table - In addition, the following procedures return the information from stat:mode in a more convenient form: - @table @code @item stat:type A symbol representing the type of file. Possible values are -regular, directory, symlink, block-special, char-special, -fifo, socket and unknown +regular, directory, symlink, block-special, char-special, fifo, +socket and unknown @item stat:perms An integer representing the access permission bits. @end table @@ -1334,8 +1309,8 @@ be empty for this to succeed. The return value is unspecified. directory-stream? @c snarfed from filesys.c:689 @deffn primitive directory-stream? obj -Returns a boolean indicating whether @var{object} is a directory stream -as returned by @code{opendir}. +Return a boolean indicating whether @var{object} is a directory +stream as returned by @code{opendir}. @end deffn opendir @@ -1377,7 +1352,7 @@ The return value is unspecified. getcwd @c snarfed from filesys.c:825 @deffn primitive getcwd -Returns the name of the current working directory. +Return the name of the current working directory. @end deffn select @@ -1463,9 +1438,8 @@ Create a symbolic link named @var{path-to} with the value (i.e., pointing to) readlink @c snarfed from filesys.c:1252 @deffn primitive readlink path -Returns the value of the symbolic link named by -@var{path} (a string), i.e., the -file that the link points to. +Return the value of the symbolic link named by @var{path} (a +string), i.e., the file that the link points to. @end deffn lstat @@ -1515,14 +1489,16 @@ in its own dynamic root, you can use fluids for thread local storage. fluid? @c snarfed from fluids.c:141 @deffn primitive fluid? obj -Return #t iff @var{obj} is a fluid; otherwise, return #f. +Return @code{#t} iff @var{obj} is a fluid; otherwise, return +@code{#f}. @end deffn fluid-ref @c snarfed from fluids.c:151 @deffn primitive fluid-ref fluid -Return the value associated with @var{fluid} in the current dynamic root. -If @var{fluid} has not been set, then this returns #f. +Return the value associated with @var{fluid} in the current +dynamic root. If @var{fluid} has not been set, then return +@code{#f}. @end deffn fluid-set! @@ -1563,14 +1539,12 @@ Determine whether @var{obj} is a port that is related to a file. open-file @c snarfed from fports.c:282 -@deffn primitive open-file filename modes -Open the file whose name is @var{string}, and return a port +@deffn primitive open-file filename mode +Open the file whose name is @var{filename}, and return a port representing that file. The attributes of the port are -determined by the @var{mode} string. The way in -which this is interpreted is similar to C stdio: - -The first character must be one of the following: - +determined by the @var{mode} string. The way in which this is +interpreted is similar to C stdio. The first character must be +one of the following: @table @samp @item r Open an existing file for input. @@ -1578,40 +1552,38 @@ Open an existing file for input. Open a file for output, creating it if it doesn't already exist or removing its contents if it does. @item a -Open a file for output, creating it if it doesn't already exist. -All writes to the port will go to the end of the file. +Open a file for output, creating it if it doesn't already +exist. All writes to the port will go to the end of the file. The "append mode" can be turned off while the port is in use @pxref{Ports and File Descriptors, fcntl} @end table - The following additional characters can be appended: - @table @samp @item + Open the port for both input and output. E.g., @code{r+}: open an existing file for both input and output. @item 0 -Create an "unbuffered" port. In this case input and output operations -are passed directly to the underlying port implementation without -additional buffering. This is likely to slow down I/O operations. -The buffering mode can be changed while a port is in use -@pxref{Ports and File Descriptors, setvbuf} +Create an "unbuffered" port. In this case input and output +operations are passed directly to the underlying port +implementation without additional buffering. This is likely to +slow down I/O operations. The buffering mode can be changed +while a port is in use @pxref{Ports and File Descriptors, +setvbuf} @item l Add line-buffering to the port. The port output buffer will be automatically flushed whenever a newline character is written. @end table - -In theory we could create read/write ports which were buffered in one -direction only. However this isn't included in the current interfaces. - -If a file cannot be opened with the access requested, -@code{open-file} throws an exception. +In theory we could create read/write ports which were buffered +in one direction only. However this isn't included in the +current interfaces. If a file cannot be opened with the access +requested, @code{open-file} throws an exception. @end deffn gc-stats @c snarfed from gc.c:742 @deffn primitive gc-stats -Returns an association list of statistics about Guile's current use of storage. +Return an association list of statistics about Guile's current +use of storage. @end deffn object-address @@ -2014,13 +1986,11 @@ integer in the range 0 to @var{size} - 1. hashq-get-handle @c snarfed from hashtab.c:174 -@deffn primitive hashq-get-handle table obj -This procedure is similar to its @code{-ref} cousin, but returns a -@dfn{handle} from the hash table rather than the value associated with -@var{key}. By convention, a handle in a hash table is the pair which -associates a key with a value. Where @code{hashq-ref table key} returns -only a @code{value}, @code{hashq-get-handle table key} returns the pair -@code{(key . value)}. +@deffn primitive 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 hashq-create-handle! @@ -2033,7 +2003,7 @@ associates @var{key} with @var{init}. hashq-ref @c snarfed from hashtab.c:199 -@deffn primitive hashq-ref table obj [dflt] +@deffn primitive 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 @@ -2042,27 +2012,25 @@ is supplied). Uses @code{eq?} for equality testing. hashq-set! @c snarfed from hashtab.c:213 -@deffn primitive hashq-set! table obj val +@deffn primitive hashq-set! 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 hashq-remove! @c snarfed from hashtab.c:225 -@deffn primitive hashq-remove! table obj +@deffn primitive hashq-remove! table key Remove @var{key} (and any value associated with it) from @var{table}. Uses @code{eq?} for equality tests. @end deffn hashv-get-handle @c snarfed from hashtab.c:242 -@deffn primitive hashv-get-handle table obj -This procedure is similar to its @code{-ref} cousin, but returns a -@dfn{handle} from the hash table rather than the value associated with -@var{key}. By convention, a handle in a hash table is the pair which -associates a key with a value. Where @code{hashv-ref table key} returns -only a @code{value}, @code{hashv-get-handle table key} returns the pair -@code{(key . value)}. +@deffn primitive 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. @end deffn hashv-create-handle! @@ -2075,7 +2043,7 @@ associates @var{key} with @var{init}. hashv-ref @c snarfed from hashtab.c:267 -@deffn primitive hashv-ref table obj [dflt] +@deffn primitive 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 @@ -2084,27 +2052,25 @@ is supplied). Uses @code{eqv?} for equality testing. hashv-set! @c snarfed from hashtab.c:281 -@deffn primitive hashv-set! table obj val +@deffn primitive hashv-set! table key val Find the entry in @var{table} associated with @var{key}, and store @var{value} there. Uses @code{eqv?} for equality testing. @end deffn hashv-remove! @c snarfed from hashtab.c:292 -@deffn primitive hashv-remove! table obj +@deffn primitive hashv-remove! table key Remove @var{key} (and any value associated with it) from @var{table}. Uses @code{eqv?} for equality tests. @end deffn hash-get-handle @c snarfed from hashtab.c:308 -@deffn primitive hash-get-handle table obj -This procedure is similar to its @code{-ref} cousin, but returns a -@dfn{handle} from the hash table rather than the value associated with -@var{key}. By convention, a handle in a hash table is the pair which -associates a key with a value. Where @code{hash-ref table key} returns -only a @code{value}, @code{hash-get-handle table key} returns the pair -@code{(key . value)}. +@deffn primitive 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 hash-create-handle! @@ -2117,7 +2083,7 @@ associates @var{key} with @var{init}. hash-ref @c snarfed from hashtab.c:333 -@deffn primitive hash-ref table obj [dflt] +@deffn primitive 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 @@ -2126,7 +2092,7 @@ is supplied). Uses @code{equal?} for equality testing. hash-set! @c snarfed from hashtab.c:348 -@deffn primitive hash-set! table obj val +@deffn primitive hash-set! table key val Find the entry in @var{table} associated with @var{key}, and store @var{value} there. Uses @code{equal?} for equality testing. @@ -2134,59 +2100,57 @@ testing. hash-remove! @c snarfed from hashtab.c:360 -@deffn primitive hash-remove! table obj +@deffn primitive hash-remove! table key Remove @var{key} (and any value associated with it) from @var{table}. Uses @code{equal?} for equality tests. @end deffn hashx-get-handle @c snarfed from hashtab.c:429 -@deffn primitive hashx-get-handle hash assoc table obj -This behaves the same way as the corresponding @code{-get-handle} -function, but uses @var{hasher} as a -hash function and @var{assoc} to compare keys. @code{hasher} must -be a function that takes two arguments, a key to be hashed and a +@deffn primitive 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 hashx-create-handle! @c snarfed from hashtab.c:447 -@deffn primitive hashx-create-handle! hash assoc table obj init -This behaves the same way as the corresponding @code{-create-handle} -function, but uses @var{hasher} as a -hash function and @var{assoc} to compare keys. @code{hasher} must -be a function that takes two arguments, a key to be hashed and a +@deffn primitive hashx-create-handle! 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}. @end deffn hashx-ref @c snarfed from hashtab.c:468 -@deffn primitive hashx-ref hash assoc table obj [dflt] +@deffn primitive hashx-ref hash assoc table key [dflt] This behaves the same way as the corresponding @code{ref} -function, but uses @var{hasher} as a -hash function and @var{assoc} to compare keys. @code{hasher} 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-ref table key} is equivalent -to @code{hashx-ref hashq assq table key}. +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-ref table key} is +equivalent to @code{hashx-ref hashq assq table key}. @end deffn hashx-set! @c snarfed from hashtab.c:492 -@deffn primitive hashx-set! hash assoc table obj val +@deffn primitive hashx-set! hash assoc table key val This behaves the same way as the corresponding @code{set!} -function, but uses @var{hasher} as a -hash function and @var{assoc} to compare keys. @code{hasher} 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}. +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 hash-fold @@ -2298,19 +2262,19 @@ end-of-file check ftell @c snarfed from ioext.c:173 -@deffn primitive ftell object -Returns an integer representing the current position of @var{fd/port}, -measured from the beginning. Equivalent to: -@smalllisp +@deffn primitive ftell fd_port +Return an integer representing the current position of +@var{fd/port}, measured from the beginning. Equivalent to: +@lisp (seek port 0 SEEK_CUR) -@end smalllisp +@end lisp @end deffn fseek @c snarfed from ioext.c:186 -@deffn primitive fseek object offset whence -Obsolete. Almost the same as seek, above, but the return value is -unspecified. +@deffn primitive fseek fd_port offset whence +Obsolete. Almost the same as @code{seek}, but the return value +is unspecified. @end deffn redirect-port @@ -2334,7 +2298,9 @@ revealed counts. dup->fdes @c snarfed from ioext.c:245 @deffn primitive dup->fdes fd_or_port [fd] -Returns an integer file descriptor. +Return a new integer file descriptor referring to the open file +designated by @var{fd_or_port}, which must be either an open +file port or a file descriptor. @end deffn dup2 @@ -2353,24 +2319,24 @@ The return value is unspecified. fileno @c snarfed from ioext.c:311 @deffn primitive fileno port -Returns the integer file descriptor underlying @var{port}. -Does not change its revealed count. +Return the integer file descriptor underlying @var{port}. Does +not change its revealed count. @end deffn isatty? @c snarfed from ioext.c:327 @deffn primitive isatty? port -Returns @code{#t} if @var{port} is using a serial -non-file device, otherwise @code{#f}. +Return @code{#t} if @var{port} is using a serial non--file +device, otherwise @code{#f}. @end deffn fdopen @c snarfed from ioext.c:349 @deffn primitive fdopen fdes modes -Returns a new port based on the file descriptor @var{fdes}. -Modes are given by the string @var{modes}. The revealed count of the port -is initialized to zero. The modes string is the same as that accepted -by @ref{File Ports, open-file}. +Return a new port based on the file descriptor @var{fdes}. +Modes are given by the string @var{modes}. The revealed count +of the port is initialized to zero. The modes string is the +same as that accepted by @ref{File Ports, open-file}. @end deffn primitive-move->fdes @@ -2387,8 +2353,9 @@ required value or @code{#t} if it was moved. fdes->ports @c snarfed from ioext.c:407 @deffn primitive fdes->ports fd -Returns a list of existing ports which have @var{fdes} as an -underlying file descriptor, without changing their revealed counts. +Return a list of existing ports which have @var{fdes} as an +underlying file descriptor, without changing their revealed +counts. @end deffn make-keyword-from-dash-symbol @@ -2400,7 +2367,8 @@ Make a keyword object from a @var{symbol} that starts with a dash. keyword? @c snarfed from keywords.c:112 @deffn primitive keyword? obj -Returns @code{#t} if the argument @var{obj} is a keyword, else @code{#f}. +Return @code{#t} if the argument @var{obj} is a keyword, else +@code{#f}. @end deffn keyword-dash-symbol @@ -2493,28 +2461,29 @@ Return the number of elements in list @var{lst}. @deffn primitive append . args Return a list consisting of the elements the lists passed as arguments. -@example +@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 example +@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. -@example +@lisp (append '(a b) '(c . d)) @result{} (a b c . d) (append '() 'a) @result{} a -@end example +@end lisp @end deffn append! @c snarfed from list.c:242 -@deffn primitive append! . args -A destructive version of @code{append} (@pxref{Pairs and Lists,,,r4rs, -The Revised^4 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. +@deffn primitive append! . lists +A destructive version of @code{append} (@pxref{Pairs and +Lists,,,r4rs, The Revised^4 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. @end deffn last-pair @@ -2819,47 +2788,46 @@ signalled. procedure->syntax @c snarfed from macros.c:60 @deffn primitive procedure->syntax code -Returns a @dfn{macro} which, when a symbol defined to this value -appears as the first symbol in an expression, returns the result -of applying @var{code} to the expression and the environment. +Return a @dfn{macro} which, when a symbol defined to this value +appears as the first symbol in an expression, returns the +result of applying @var{code} to the expression and the +environment. @end deffn procedure->macro @c snarfed from macros.c:82 @deffn primitive procedure->macro code -Returns a @dfn{macro} which, when a symbol defined to this value -appears as the first symbol in an expression, evaluates the result -of applying @var{code} to the expression and the environment. -The value returned from @var{code} which has been passed to -@code{procedure->memoizing-macro} replaces the form passed to -@var{code}. For example: - -@example +Return a @dfn{macro} which, when a symbol defined to this value +appears as the first symbol in an expression, evaluates the +result of applying @var{code} to the expression and the +environment. The value returned from @var{code} which has been +passed to @code{procedure->memoizing-macro} replaces the form +passed to @var{code}. For example: +@lisp (define trace (procedure->macro (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x)))))) (trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})). -@end example +@end lisp @end deffn procedure->memoizing-macro @c snarfed from macros.c:104 @deffn primitive procedure->memoizing-macro code -Returns a @dfn{macro} which, when a symbol defined to this value -appears as the first symbol in an expression, evaluates the result -of applying @var{proc} to the expression and the environment. -The value returned from @var{proc} which has been passed to -@code{procedure->memoizing-macro} replaces the form passed to -@var{proc}. For example: - -@example +Return a @dfn{macro} which, when a symbol defined to this value +appears as the first symbol in an expression, evaluates the +result of applying @var{proc} to the expression and the +environment. The value returned from @var{proc} which has been +passed to @code{procedure->memoizing-macro} replaces the form +passed to @var{proc}. For example: +@lisp (define trace (procedure->macro (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x)))))) (trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})). -@end example +@end lisp @end deffn macro? @@ -2872,10 +2840,11 @@ syntax transformer. macro-type @c snarfed from macros.c:133 @deffn primitive macro-type m -Return one of the symbols @code{syntax}, @code{macro} or @code{macro!}, -depending on whether @var{obj} is a syntax tranformer, a regular macro, -or a memoizing macro, respectively. If @var{obj} is not a macro, -@code{#f} is returned. +Return one of the symbols @code{syntax}, @code{macro} or +@code{macro!}, depending on whether @var{m} is a syntax +tranformer, a regular macro, or a memoizing macro, +respectively. If @var{m} is not a macro, @code{#f} is +returned. @end deffn macro-name @@ -2893,11 +2862,11 @@ Return the transformer of the macro @var{m}. interaction-environment @c snarfed from modules.c:102 @deffn primitive interaction-environment -This procedure returns a specifier for the environment that contains -implementation-defined bindings, typically a superset of those listed in -the report. The intent is that this procedure will return the -environment in which the implementation would evaluate expressions -dynamically typed by the user. +Return a specifier for the environment that contains +implementation--defined bindings, typically a superset of those +listed in the report. The intent is that this procedure will +return the environment in which the implementation would +evaluate expressions dynamically typed by the user. @end deffn standard-eval-closure @@ -2909,56 +2878,52 @@ Return an eval closure for the module @var{module}. inet-aton @c snarfed from net_db.c:96 @deffn primitive inet-aton address -Converts a string containing an Internet host address in the traditional -dotted decimal notation into an integer. - -@smalllisp +Converts a string containing an Internet host address in the +traditional dotted decimal notation into an integer. +@lisp (inet-aton "127.0.0.1") @result{} 2130706433 - -@end smalllisp +@end lisp @end deffn inet-ntoa @c snarfed from net_db.c:116 @deffn primitive inet-ntoa inetid -Converts an integer Internet host address into a string with the -traditional dotted decimal representation. - -@smalllisp +Converts an integer Internet host address into a string with +the traditional dotted decimal representation. +@lisp (inet-ntoa 2130706433) @result{} "127.0.0.1" -@end smalllisp +@end lisp @end deffn inet-netof @c snarfed from net_db.c:135 @deffn primitive inet-netof address -Returns the network number part of the given integer Internet address. - -@smalllisp +Return the network number part of the given integer Internet +address. +@lisp (inet-netof 2130706433) @result{} 127 -@end smalllisp +@end lisp @end deffn inet-lnaof @c snarfed from net_db.c:152 @deffn primitive inet-lnaof address -Returns the local-address-with-network part of the given Internet -address. - -@smalllisp +Return the local-address-with-network part of the given +Internet address. +@lisp (inet-lnaof 2130706433) @result{} 1 -@end smalllisp +@end lisp @end deffn inet-makeaddr @c snarfed from net_db.c:169 @deffn primitive inet-makeaddr net lna -Makes an Internet host address by combining the network number @var{net} -with the local-address-within-network number @var{lna}. - -@smalllisp +Makes an Internet host address by combining the network number +@var{net} with the local-address-within-network number +@var{lna}. +@lisp (inet-makeaddr 127 1) @result{} 2130706433 -@end smalllisp +@end lisp @end deffn gethost @@ -3067,10 +3032,8 @@ otherwise. logand @c snarfed from numbers.c:755 @deffn primitive logand n1 n2 -Returns the integer which is the bit-wise AND of the two integer +Return the integer which is the bit-wise AND of the two integer arguments. - -Example: @lisp (number->string (logand #b1100 #b1010) 2) @result{} "1000" @@ -3080,10 +3043,8 @@ Example: logior @c snarfed from numbers.c:842 @deffn primitive logior n1 n2 -Returns the integer which is the bit-wise OR of the two integer +Return the integer which is the bit-wise OR of the two integer arguments. - -Example: @lisp (number->string (logior #b1100 #b1010) 2) @result{} "1110" @@ -3093,10 +3054,8 @@ Example: logxor @c snarfed from numbers.c:928 @deffn primitive logxor n1 n2 -Returns the integer which is the bit-wise XOR of the two integer +Return the integer which is the bit-wise XOR of the two integer arguments. - -Example: @lisp (number->string (logxor #b1100 #b1010) 2) @result{} "110" @@ -3105,19 +3064,19 @@ Example: logtest @c snarfed from numbers.c:997 -@deffn primitive logtest n1 n2 -@example +@deffn primitive logtest j k +@lisp (logtest j k) @equiv{} (not (zero? (logand j k))) (logtest #b0100 #b1011) @result{} #f (logtest #b0100 #b0111) @result{} #t -@end example +@end lisp @end deffn logbit? @c snarfed from numbers.c:1054 @deffn primitive logbit? index j -@example +@lisp (logbit? index j) @equiv{} (logtest (integer-expt 2 index) j) (logbit? 0 #b1101) @result{} #t @@ -3125,15 +3084,14 @@ Example: (logbit? 2 #b1101) @result{} #t (logbit? 3 #b1101) @result{} #t (logbit? 4 #b1101) @result{} #f -@end example +@end lisp @end deffn lognot @c snarfed from numbers.c:1102 @deffn primitive lognot n -Returns the integer which is the 2s-complement of the integer argument. - -Example: +Return the integer which is the 2s-complement of the integer +argument. @lisp (number->string (lognot #b10000000) 2) @result{} "-10000001" @@ -3145,9 +3103,8 @@ Example: integer-expt @c snarfed from numbers.c:1118 @deffn primitive integer-expt n k -Returns @var{n} raised to the non-negative integer exponent @var{k}. - -Example: +Return @var{n} raised to the non-negative integer exponent +@var{k}. @lisp (integer-expt 2 5) @result{} 32 @@ -3159,34 +3116,27 @@ Example: ash @c snarfed from numbers.c:1166 @deffn primitive ash n cnt -The function ash performs an arithmetic shift left by @var{CNT} -bits (or shift right, if @var{cnt} is negative). -'Arithmetic' means, that the function does not guarantee to -keep the bit structure of @var{n}, but rather guarantees that -the result will always be rounded towards minus infinity. -Therefore, the results of ash and a corresponding bitwise -shift will differ if N is negative. - +The function ash performs an arithmetic shift left by @var{cnt} +bits (or shift right, if @var{cnt} is negative). 'Arithmetic' +means, that the function does not guarantee to keep the bit +structure of @var{n}, but rather guarantees that the result +will always be rounded towards minus infinity. Therefore, the +results of ash and a corresponding bitwise shift will differ if +@var{n} is negative. Formally, the function returns an integer equivalent to @code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}. - -Example: @lisp -(number->string (ash #b1 3) 2) - @result{} "1000" -(number->string (ash #b1010 -1) 2) - @result{} "101" +(number->string (ash #b1 3) 2) @result{} "1000" +(number->string (ash #b1010 -1) 2) @result{} "101" @end lisp @end deffn bit-extract @c snarfed from numbers.c:1219 @deffn primitive bit-extract n start end -Returns the integer composed of the @var{start} (inclusive) through -@var{end} (exclusive) bits of @var{n}. The @var{start}th bit becomes -the 0-th bit in the result.@refill - -Example: +Return the integer composed of the @var{start} (inclusive) +through @var{end} (exclusive) bits of @var{n}. The +@var{start}th bit becomes the 0-th bit in the result. @lisp (number->string (bit-extract #b1101101010 0 4) 2) @result{} "1010" @@ -3198,12 +3148,10 @@ Example: logcount @c snarfed from numbers.c:1291 @deffn primitive logcount n -Returns the number of bits in integer @var{n}. If integer is positive, -the 1-bits in its binary representation are counted. If negative, the -0-bits in its two's-complement binary representation are counted. If 0, -0 is returned. - -Example: +Return the number of bits in integer @var{n}. If integer is +positive, the 1-bits in its binary representation are counted. +If negative, the 0-bits in its two's-complement binary +representation are counted. If 0, 0 is returned. @lisp (logcount #b10101010) @result{} 4 @@ -3217,9 +3165,7 @@ Example: integer-length @c snarfed from numbers.c:1342 @deffn primitive integer-length n -Returns the number of bits neccessary to represent @var{n}. - -Example: +Return the number of bits neccessary to represent @var{n}. @lisp (integer-length #b10101010) @result{} 8 @@ -3241,7 +3187,7 @@ inexact, a radix of 10 will be used. string->number @c snarfed from numbers.c:2873 @deffn primitive string->number string [radix] -Returns a number of the maximally precise representation +Return a number of the maximally precise representation expressed by the given @var{string}. @var{radix} must be an exact integer, either 2, 8, 10, or 16. If supplied, @var{radix} is a default radix that may be overridden by an explicit radix @@ -3331,7 +3277,7 @@ Return the complex number @var{x} * e^(i * @var{y}). inexact->exact @c snarfed from numbers.c:4231 @deffn primitive inexact->exact z -Returns an exact number that is numerically closest to @var{z}. +Return an exact number that is numerically closest to @var{z}. @end deffn class-of @@ -3382,7 +3328,7 @@ Return @var{obj}'s property list. set-object-properties! @c snarfed from objprop.c:73 -@deffn primitive set-object-properties! obj plist +@deffn primitive set-object-properties! obj alist @deffnx primitive set-procedure-properties! obj alist Set @var{obj}'s property list to @var{alist}. @end deffn @@ -3396,24 +3342,25 @@ Return the property of @var{obj} with name @var{key}. set-object-property! @c snarfed from objprop.c:98 -@deffn primitive set-object-property! obj key val +@deffn primitive set-object-property! obj key value @deffnx primitive set-procedure-property! obj key value -In @var{obj}'s property list, set the property named @var{key} to -@var{value}. +In @var{obj}'s property list, set the property named @var{key} +to @var{value}. @end deffn cons @c snarfed from pairs.c:61 @deffn primitive cons x y -Returns a newly allocated pair whose car is @var{x} and whose cdr is -@var{y}. The pair is guaranteed to be different (in the sense of -@code{eqv?}) from every previously existing object. +Return a newly allocated pair whose car is @var{x} and whose +cdr is @var{y}. The pair is guaranteed to be different (in the +sense of @code{eq?}) from every previously existing object. @end deffn pair? @c snarfed from pairs.c:93 @deffn primitive pair? x -Returns @code{#t} if @var{x} is a pair; otherwise returns @code{#f}. +Return @code{#t} if @var{x} is a pair; otherwise return +@code{#f}. @end deffn set-car! @@ -3433,26 +3380,26 @@ by @code{set-cdr!} is unspecified. char-ready? @c snarfed from ports.c:246 @deffn primitive char-ready? [port] -Returns @code{#t} if a character is ready on input @var{port} and -returns @code{#f} otherwise. If @code{char-ready?} returns @code{#t} -then the next @code{read-char} operation on @var{port} is -guaranteed not to hang. If @var{port} is a file port at end of -file then @code{char-ready?} returns @code{#t}. +Return @code{#t} if a character is ready on input @var{port} +and return @code{#f} otherwise. If @code{char-ready?} returns +@code{#t} then the next @code{read-char} operation on +@var{port} is guaranteed not to hang. If @var{port} is a file +port at end of file then @code{char-ready?} returns @code{#t}. @footnote{@code{char-ready?} exists to make it possible for a -program to accept characters from interactive ports without getting -stuck waiting for input. Any input editors associated with such ports -must make sure that characters whose existence has been asserted by -@code{char-ready?} cannot be rubbed out. If @code{char-ready?} were to -return @code{#f} at end of file, a port at end of file would be -indistinguishable from an interactive port that has no ready -characters.} +program to accept characters from interactive ports without +getting stuck waiting for input. Any input editors associated +with such ports must make sure that characters whose existence +has been asserted by @code{char-ready?} cannot be rubbed out. +If @code{char-ready?} were to return @code{#f} at end of file, +a port at end of file would be indistinguishable from an +interactive port that has no ready characters.} @end deffn drain-input @c snarfed from ports.c:312 @deffn primitive drain-input port Drain @var{port}'s read buffers (including any pushed-back -characters) and returns the content as a single string. +characters) and return the content as a single string. @end deffn current-input-port @@ -3511,7 +3458,7 @@ Set the current default error port to @var{port}. port-revealed @c snarfed from ports.c:556 @deffn primitive port-revealed port -Returns the revealed count for @var{port}. +Return the revealed count for @var{port}. @end deffn set-port-revealed! @@ -3524,21 +3471,21 @@ The return value is unspecified. port-mode @c snarfed from ports.c:612 @deffn primitive port-mode port -Returns the port modes associated with the open port @var{port}. These -will not necessarily be identical to the modes used when the port was -opened, since modes such as "append" which are used only during -port creation are not retained. +Return the port modes associated with the open port @var{port}. +These will not necessarily be identical to the modes used when +the port was opened, since modes such as "append" which are +used only during port creation are not retained. @end deffn close-port @c snarfed from ports.c:649 @deffn primitive close-port port -Close the specified port object. Returns @code{#t} if it successfully -closes a port or @code{#f} if it was already -closed. An exception may be raised if an error occurs, for example -when flushing buffered output. -See also @ref{Ports and File Descriptors, close}, for a procedure -which can close file descriptors. +Close the specified port object. Return @code{#t} if it +successfully closes a port or @code{#f} if it was already +closed. An exception may be raised if an error occurs, for +example when flushing buffered output. See also @ref{Ports and +File Descriptors, close}, for a procedure which can close file +descriptors. @end deffn close-input-port @@ -3588,7 +3535,7 @@ Use port-for-each instead. input-port? @c snarfed from ports.c:791 @deffn primitive input-port? x -Returns @code{#t} if @var{x} is an input port, otherwise returns +Return @code{#t} if @var{x} is an input port, otherwise return @code{#f}. Any object satisfying this predicate also satisfies @code{port?}. @end deffn @@ -3596,7 +3543,7 @@ Returns @code{#t} if @var{x} is an input port, otherwise returns output-port? @c snarfed from ports.c:804 @deffn primitive output-port? x -Returns @code{#t} if @var{x} is an output port, otherwise returns +Return @code{#t} if @var{x} is an output port, otherwise return @code{#f}. Any object satisfying this predicate also satisfies @code{port?}. @end deffn @@ -3604,7 +3551,7 @@ Returns @code{#t} if @var{x} is an output port, otherwise returns port? @c snarfed from ports.c:819 @deffn primitive port? x -Returns a boolean indicating whether @var{x} is a port. +Return a boolean indicating whether @var{x} is a port. Equivalent to @code{(or (input-port? @var{x}) (output-port? @var{x}))}. @end deffn @@ -3612,14 +3559,15 @@ Equivalent to @code{(or (input-port? @var{x}) (output-port? port-closed? @c snarfed from ports.c:828 @deffn primitive port-closed? port -Returns @code{#t} if @var{port} is closed or @code{#f} if it is open. +Return @code{#t} if @var{port} is closed or @code{#f} if it is +open. @end deffn eof-object? @c snarfed from ports.c:839 @deffn primitive eof-object? x -Returns @code{#t} if @var{x} is an end-of-file object; otherwise -returns @code{#f}. +Return @code{#t} if @var{x} is an end-of-file object; otherwise +return @code{#f}. @end deffn force-output @@ -3644,25 +3592,26 @@ all open output ports. The return value is unspecified. read-char @c snarfed from ports.c:889 @deffn primitive read-char [port] -Returns the next character available from @var{port}, updating +Return the next character available from @var{port}, updating @var{port} to point to the following character. If no more -characters are available, an end-of-file object is returned. +characters are available, the end-of-file object is returned. @end deffn peek-char @c snarfed from ports.c:1205 @deffn primitive peek-char [port] -Returns the next character available from @var{port}, +Return the next character available from @var{port}, @emph{without} updating @var{port} to point to the following -character. If no more characters are available, an end-of-file object -is returned.@footnote{The value returned by a call to @code{peek-char} -is the same as the value that would have been returned by a call to -@code{read-char} on the same port. The only difference is that the very -next call to @code{read-char} or @code{peek-char} on that -@var{port} will return the value returned by the preceding call to -@code{peek-char}. In particular, a call to @code{peek-char} on an -interactive port will hang waiting for input whenever a call to -@code{read-char} would have hung.} +character. If no more characters are available, the +end-of-file object is returned.@footnote{The value returned by +a call to @code{peek-char} is the same as the value that would +have been returned by a call to @code{read-char} on the same +port. The only difference is that the very next call to +@code{read-char} or @code{peek-char} on that @var{port} will +return the value returned by the preceding call to +@code{peek-char}. In particular, a call to @code{peek-char} on +an interactive port will hang waiting for input whenever a call +to @code{read-char} would have hung.} @end deffn unread-char @@ -3685,12 +3634,12 @@ unread characters will be read again in last-in first-out order. If seek @c snarfed from ports.c:1285 -@deffn primitive seek object offset whence -Sets the current position of @var{fd/port} to the integer @var{offset}, -which is interpreted according to the value of @var{whence}. - -One of the following variables should be supplied -for @var{whence}: +@deffn primitive seek fd_port offset whence +Sets the current position of @var{fd/port} to the integer +@var{offset}, which is interpreted according to the value of +@var{whence}. +One of the following variables should be supplied for +@var{whence}: @defvar SEEK_SET Seek from the beginning of the file. @end defvar @@ -3700,27 +3649,24 @@ Seek from the current position. @defvar SEEK_END Seek from the end of the file. @end defvar - -If @var{fd/port} is a file descriptor, the underlying system call is -@code{lseek}. @var{port} may be a string port. - -The value returned is the new position in the file. This means that -the current position of a port can be obtained using: -@smalllisp +If @var{fd/port} is a file descriptor, the underlying system +call is @code{lseek}. @var{port} may be a string port. +The value returned is the new position in the file. This means +that the current position of a port can be obtained using: +@lisp (seek port 0 SEEK_CUR) -@end smalllisp +@end lisp @end deffn truncate-file @c snarfed from ports.c:1326 @deffn primitive truncate-file object [length] -Truncates the object referred to by @var{obj} to at most @var{size} bytes. -@var{obj} can be a string containing a file name or an integer file -descriptor or a port. @var{size} may be omitted if @var{obj} is not -a file name, in which case the truncation occurs at the current port. -position. - -The return value is unspecified. +Truncates the object referred to by @var{object} to at most +@var{length} bytes. @var{object} can be a string containing a +file name or an integer file descriptor or a port. +@var{length} may be omitted if @var{object} is not a file name, +in which case the truncation occurs at the current port. +position. The return value is unspecified. @end deffn port-line @@ -3786,25 +3732,25 @@ documentation for @code{open-file} in @ref{File Ports}. pipe @c snarfed from posix.c:201 @deffn primitive pipe -Returns a newly created pipe: a pair of ports which are linked -together on the local machine. The CAR is the input port and -the CDR is the output port. Data written (and flushed) to the -output port can be read from the input port. -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}. - -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 +Return a newly created pipe: a pair of ports which are linked +together on the local machine. The @emph{car} is the input +port and the @emph{cdr} is the output port. Data written (and +flushed) to the output port can be read from the input port. +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}. +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. @end deffn getgroups @c snarfed from posix.c:221 @deffn primitive getgroups -Returns a vector of integers representing the current supplimentary group IDs. +Return a vector of integers representing the current +supplimentary group IDs. @end deffn getpw @@ -3920,59 +3866,60 @@ The integer status value. status:exit-val @c snarfed from posix.c:478 @deffn primitive status:exit-val status -Returns the exit status value, as would be -set if a process ended normally through a -call to @code{exit} or @code{_exit}, if any, otherwise @code{#f}. +Return the exit status value, as would be set if a process +ended normally through a call to @code{exit} or @code{_exit}, +if any, otherwise @code{#f}. @end deffn status:term-sig @c snarfed from posix.c:498 @deffn primitive status:term-sig status -Returns the signal number which terminated the -process, if any, otherwise @code{#f}. +Return the signal number which terminated the process, if any, +otherwise @code{#f}. @end deffn status:stop-sig @c snarfed from posix.c:516 @deffn primitive status:stop-sig status -Returns the signal number which stopped the -process, if any, otherwise @code{#f}. +Return the signal number which stopped the process, if any, +otherwise @code{#f}. @end deffn getppid @c snarfed from posix.c:533 @deffn primitive getppid -Returns an integer representing the process ID of the parent process. +Return an integer representing the process ID of the parent +process. @end deffn getuid @c snarfed from posix.c:544 @deffn primitive getuid -Returns an integer representing the current real user ID. +Return an integer representing the current real user ID. @end deffn getgid @c snarfed from posix.c:555 @deffn primitive getgid -Returns an integer representing the current real group ID. +Return an integer representing the current real group ID. @end deffn geteuid @c snarfed from posix.c:569 @deffn primitive geteuid -Returns an integer representing the current effective user ID. +Return an integer representing the current effective user ID. If the system does not support effective IDs, then the real ID -is returned. @code{(feature? 'EIDs)} reports whether the system -supports effective IDs. +is returned. @code{(feature? 'EIDs)} reports whether the +system supports effective IDs. @end deffn getegid @c snarfed from posix.c:587 @deffn primitive getegid -Returns an integer representing the current effective group ID. +Return an integer representing the current effective group ID. If the system does not support effective IDs, then the real ID -is returned. @code{(feature? 'EIDs)} reports whether the system -supports effective IDs. +is returned. @code{(feature? 'EIDs)} reports whether the +system supports effective IDs. @end deffn setuid @@ -4014,7 +3961,7 @@ The return value is unspecified. getpgrp @c snarfed from posix.c:679 @deffn primitive getpgrp -Returns an integer representing the current process group ID. +Return an integer representing the current process group ID. This is the POSIX definition, not BSD. @end deffn @@ -4040,24 +3987,23 @@ The return value is an integer representing the new process group ID. ttyname @c snarfed from posix.c:728 @deffn primitive ttyname port -Returns a string with the name of the serial terminal device underlying -@var{port}. +Return a string with the name of the serial terminal device +underlying @var{port}. @end deffn ctermid @c snarfed from posix.c:751 @deffn primitive ctermid -Returns a string containing the file name of the controlling terminal -for the current process. +Return a string containing the file name of the controlling +terminal for the current process. @end deffn tcgetpgrp @c snarfed from posix.c:773 @deffn primitive tcgetpgrp port -Returns the process group ID of the foreground -process group associated with the terminal open on the file descriptor +Return the process group ID of the foreground process group +associated with the terminal open on the file descriptor underlying @var{port}. - If there is no foreground process group, the return value is a number greater than 1 that does not match the process group ID of any existing process group. This can happen if all of the @@ -4129,78 +4075,69 @@ with the scsh fork. uname @c snarfed from posix.c:968 @deffn primitive uname -Returns an object with some information about the computer system the -program is running on. +Return an object with some information about the computer +system the program is running on. @end deffn environ @c snarfed from posix.c:997 @deffn primitive environ [env] -If @var{env} is omitted, returns the current environment as a list of strings. -Otherwise it sets the current environment, which is also the -default environment for child processes, to the supplied list of strings. -Each member of @var{env} should be of the form -@code{NAME=VALUE} and values of @code{NAME} should not be duplicated. -If @var{env} is supplied then the return value is unspecified. +If @var{env} is omitted, return the current environment (in the +Unix sense) as a list of strings. Otherwise set the current +environment, which is also the default environment for child +processes, to the supplied list of strings. Each member of +@var{env} should be of the form @code{NAME=VALUE} and values of +@code{NAME} should not be duplicated. If @var{env} is supplied +then the return value is unspecified. @end deffn tmpnam @c snarfed from posix.c:1035 @deffn primitive tmpnam -tmpnam returns a name in the file system that does not match -any existing file. However there is no guarantee that -another process will not create the file after tmpnam -is called. Care should be taken if opening the file, -e.g., use the O_EXCL open flag or use @code{mkstemp!} instead. +Return a name in the file system that does not match any +existing file. However there is no guarantee that another +process will not create the file after @code{tmpnam} is called. +Care should be taken if opening the file, e.g., use the +@code{O_EXCL} open flag or use @code{mkstemp!} instead. @end deffn mkstemp! @c snarfed from posix.c:1058 @deffn primitive mkstemp! tmpl -mkstemp creates a new unique file in the file system and -returns a new buffered port open for reading and writing to -the file. @var{tmpl} is a string specifying where the -file should be created: it must end with @code{XXXXXX} -and will be changed in place to return the name of the -temporary file. +Create a new unique file in the file system and returns a new +buffered port open for reading and writing to the file. +@var{tmpl} is a string specifying where the file should be +created: it must end with @code{XXXXXX} and will be changed in +place to return the name of the temporary file. @end deffn utime @c snarfed from posix.c:1086 @deffn primitive utime pathname [actime [modtime]] -@code{utime} sets the access and modification times for -the file named by @var{path}. If @var{actime} or @var{modtime} -is not supplied, then the current time is used. -@var{actime} and @var{modtime} -must be integer time values as returned by the @code{current-time} -procedure. - -E.g., - -@smalllisp +@code{utime} sets the access and modification times for the +file named by @var{path}. If @var{actime} or @var{modtime} is +not supplied, then the current time is used. @var{actime} and +@var{modtime} must be integer time values as returned by the +@code{current-time} procedure. +@lisp (utime "foo" (- (current-time) 3600)) -@end smalllisp - -will set the access time to one hour in the past and the modification -time to the current time. +@end lisp +will set the access time to one hour in the past and the +modification time to the current time. @end deffn access? @c snarfed from posix.c:1135 @deffn primitive access? path how -Returns @code{#t} if @var{path} corresponds to an existing -file and the current process -has the type of access specified by @var{how}, otherwise -@code{#f}. -@var{how} should be specified -using the values of the variables listed below. Multiple values can -be combined using a bitwise or, in which case @code{#t} will only -be returned if all accesses are granted. - -Permissions are checked using the real id of the current process, -not the effective id, although it's the effective id which determines -whether the access would actually be granted. - +Return @code{#t} if @var{path} corresponds to an existing file +and the current process has the type of access specified by +@var{how}, otherwise @code{#f}. @var{how} should be specified +using the values of the variables listed below. Multiple +values can be combined using a bitwise or, in which case +@code{#t} will only be returned if all accesses are granted. +Permissions are checked using the real id of the current +process, not the effective id, although it's the effective id +which determines whether the access would actually be granted. @defvar R_OK test for read permission. @end defvar @@ -4218,7 +4155,7 @@ test for existence of the file. getpid @c snarfed from posix.c:1150 @deffn primitive getpid -Returns an integer representing the current process ID. +Return an integer representing the current process ID. @end deffn putenv @@ -4240,16 +4177,14 @@ The return value is unspecified. setlocale @c snarfed from posix.c:1198 @deffn primitive setlocale category [locale] -If @var{locale} is omitted, returns the current value of the specified -locale category -as a system-dependent string. -@var{category} should be specified using the values @code{LC_COLLATE}, -@code{LC_ALL} etc. - -Otherwise the specified locale category is set to -the string @var{locale} -and the new value is returned as a system-dependent string. If @var{locale} -is an empty string, the locale will be set using envirionment variables. +If @var{locale} is omitted, return the current value of the +specified locale category as a system-dependent string. +@var{category} should be specified using the values +@code{LC_COLLATE}, @code{LC_ALL} etc. +Otherwise the specified locale category is set to the string +@var{locale} and the new value is returned as a +system-dependent string. If @var{locale} is an empty string, +the locale will be set using envirionment variables. @end deffn mknod @@ -4265,9 +4200,9 @@ to. Its exact interpretation depends on the kind of special file being created. E.g., -@example +@lisp (mknod "/dev/fd0" 'block-special #o660 (+ (* 2 256) 2)) -@end example +@end lisp The return value is unspecified. @end deffn @@ -4614,19 +4549,19 @@ turn, storing the result in the corresponding element. The value returned and the order of application are unspecified. One can implement @var{array-indexes} as -@example +@lisp (define (array-indexes array) (let ((ra (apply make-array #f (array-shape array)))) (array-index-map! ra (lambda x x)) ra)) -@end example +@end lisp Another example: -@example +@lisp (define (apl:index-generator n) (let ((v (make-uniform-vector n 1))) (array-index-map! v (lambda (i) i)) v)) -@end example +@end lisp @end deffn random @@ -4659,16 +4594,17 @@ Return a new random state using @var{seed}. random:uniform @c snarfed from random.c:418 @deffn primitive random:uniform [state] -Returns a uniformly distributed inexact real random number in [0,1). +Return a uniformly distributed inexact real random number in +[0,1). @end deffn random:normal @c snarfed from random.c:433 @deffn primitive random:normal [state] -Returns an inexact real in a normal distribution. -The distribution used has mean 0 and standard deviation 1. -For a normal distribution with mean m and standard deviation -d use @code{(+ m (* d (random:normal)))}. +Return an inexact real in a normal distribution. The +distribution used has mean 0 and standard deviation 1. For a +normal distribution with mean m and standard deviation d use +@code{(+ m (* d (random:normal)))}. @end deffn random:solid-sphere! @@ -4704,8 +4640,9 @@ independent and standard normally distributed random:exp @c snarfed from random.c:554 @deffn primitive random:exp [state] -Returns an inexact real in an exponential distribution with mean 1. -For an exponential distribution with mean u use (* u (random:exp)). +Return an inexact real in an exponential distribution with mean +1. For an exponential distribution with mean u use (* u +(random:exp)). @end deffn %read-delimited! @@ -4741,14 +4678,13 @@ delimiter may be either a newline or the @var{eof-object}; if write-line @c snarfed from rdelim.c:277 @deffn primitive write-line obj [port] -Display @var{obj} and a newline character to @var{port}. If @var{port} -is not specified, @code{(current-output-port)} is used. This function -is equivalent to: - -@smalllisp +Display @var{obj} and a newline character to @var{port}. If +@var{port} is not specified, @code{(current-output-port)} is +used. This function is equivalent to: +@lisp (display obj [port]) (newline [port]) -@end smalllisp +@end lisp @end deffn read-options-interface @@ -4779,60 +4715,59 @@ returned will be the return value of @code{read}. regexp? @c snarfed from regex-posix.c:139 -@deffn primitive regexp? x -Return @code{#t} if @var{obj} is a compiled regular expression, or -@code{#f} otherwise. +@deffn primitive regexp? obj +Return @code{#t} if @var{obj} is a compiled regular expression, +or @code{#f} otherwise. @end deffn make-regexp @c snarfed from regex-posix.c:179 @deffn primitive make-regexp pat . flags -Compile the regular expression described by @var{str}, and return the -compiled regexp structure. If @var{str} does not describe a legal -regular expression, @code{make-regexp} throws a -@code{regular-expression-syntax} error. - -The @var{flag} arguments change the behavior of the compiled regexp. -The following flags may be supplied: - +Compile the regular expression described by @var{pat}, and +return the compiled regexp structure. If @var{pat} does not +describe a legal regular expression, @code{make-regexp} throws +a @code{regular-expression-syntax} error. +The @var{flags} arguments change the behavior of the compiled +regular expression. The following flags may be supplied: @table @code @item regexp/icase -Consider uppercase and lowercase letters to be the same when matching. - +Consider uppercase and lowercase letters to be the same when +matching. @item regexp/newline -If a newline appears in the target string, then permit the @samp{^} and -@samp{$} operators to match immediately after or immediately before the -newline, respectively. Also, the @samp{.} and @samp{[^...]} operators -will never match a newline character. The intent of this flag is to -treat the target string as a buffer containing many lines of text, and -the regular expression as a pattern that may match a single one of those -lines. - +If a newline appears in the target string, then permit the +@samp{^} and @samp{$} operators to match immediately after or +immediately before the newline, respectively. Also, the +@samp{.} and @samp{[^...]} operators will never match a newline +character. The intent of this flag is to treat the target +string as a buffer containing many lines of text, and the +regular expression as a pattern that may match a single one of +those lines. @item regexp/basic Compile a basic (``obsolete'') regexp instead of the extended -(``modern'') regexps that are the default. Basic regexps do not -consider @samp{|}, @samp{+} or @samp{?} to be special characters, and -require the @samp{@{...@}} and @samp{(...)} metacharacters to be -backslash-escaped (@pxref{Backslash Escapes}). There are several other -differences between basic and extended regular expressions, but these -are the most significant. - +(``modern'') regexps that are the default. Basic regexps do +not consider @samp{|}, @samp{+} or @samp{?} to be special +characters, and require the @samp{@{...@}} and @samp{(...)} +metacharacters to be backslash-escaped (@pxref{Backslash +Escapes}). There are several other differences between basic +and extended regular expressions, but these are the most +significant. @item regexp/extended -Compile an extended regular expression rather than a basic regexp. This -is the default behavior; this flag will not usually be needed. If a -call to @code{make-regexp} includes both @code{regexp/basic} and -@code{regexp/extended} flags, the one which comes last will override -the earlier one. +Compile an extended regular expression rather than a basic +regexp. This is the default behavior; this flag will not +usually be needed. If a call to @code{make-regexp} includes +both @code{regexp/basic} and @code{regexp/extended} flags, the +one which comes last will override the earlier one. @end table @end deffn regexp-exec @c snarfed from regex-posix.c:226 @deffn primitive regexp-exec rx str [start [flags]] -Match the compiled regular expression @var{regexp} against @code{str}. -If the optional integer @var{start} argument is provided, begin matching -from that position in the string. Return a match structure describing -the results of the match, or @code{#f} if no match could be found. +Match the compiled regular expression @var{rx} against +@code{str}. If the optional integer @var{start} argument is +provided, begin matching from that position in the string. +Return a match structure describing the results of the match, +or @code{#f} if no match could be found. @end deffn call-with-dynamic-root @@ -4855,7 +4790,7 @@ Before calling @var{thunk}, the dynamic-wind chain is un-wound back to the root and a new chain started for @var{thunk}. Therefore, this call may not do what you expect: -@example +@lisp ;; Almost certainly a bug: (with-output-to-port some-port @@ -4866,7 +4801,7 @@ may not do what you expect: (display 'fnord) (newline)) (lambda (errcode) errcode)))) -@end example +@end lisp The problem is, on what port will @samp{fnord} be displayed? You might expect that because of the @code{with-output-to-port} that @@ -4977,12 +4912,12 @@ Sends a specified signal @var{sig} to the current process, where system @c snarfed from simpos.c:76 @deffn primitive system [cmd] -Executes @var{cmd} using the operating system's "command processor". -Under Unix this is usually the default shell @code{sh}. The value -returned is @var{cmd}'s exit status as returned by @code{waitpid}, which -can be interpreted using the functions above. - -If @code{system} is called without arguments, it returns a boolean +Execute @var{cmd} using the operating system's "command +processor". Under Unix this is usually the default shell +@code{sh}. The value returned is @var{cmd}'s exit status as +returned by @code{waitpid}, which can be interpreted using the +functions above. +If @code{system} is called without arguments, return a boolean indicating whether the command processor is available. @end deffn @@ -5005,74 +4940,72 @@ is @var{status} if supplied, otherwise zero. htons @c snarfed from socket.c:89 @deffn primitive htons in -Returns a new integer from @var{value} by converting from host to -network order. @var{value} must be within the range of a C unsigned -short integer. +Return a new integer from @var{value} by converting from host +to network order. @var{value} must be within the range of a C +unsigned short integer. @end deffn ntohs @c snarfed from socket.c:106 @deffn primitive ntohs in -Returns a new integer from @var{value} by converting from network to -host order. @var{value} must be within the range of a C unsigned short -integer. +Return a new integer from @var{value} by converting from +network to host order. @var{value} must be within the range of +a C unsigned short integer. @end deffn htonl @c snarfed from socket.c:123 @deffn primitive htonl in -Returns a new integer from @var{value} by converting from host to -network order. @var{value} must be within the range of a C unsigned -long integer. +Return a new integer from @var{value} by converting from host +to network order. @var{value} must be within the range of a C +unsigned long integer. @end deffn ntohl @c snarfed from socket.c:135 @deffn primitive ntohl in -Returns a new integer from @var{value} by converting from network to -host order. @var{value} must be within the range of a C unsigned -long integer. +Return a new integer from @var{value} by converting from +network to host order. @var{value} must be within the range of +a C unsigned long integer. @end deffn socket @c snarfed from socket.c:158 @deffn primitive socket family style proto -Returns a new socket port of the type specified by @var{family}, @var{style} -and @var{protocol}. All three parameters are integers. Typical values -for @var{family} are the values of @code{AF_UNIX} -and @code{AF_INET}. Typical values for @var{style} are -the values of @code{SOCK_STREAM}, @code{SOCK_DGRAM} and @code{SOCK_RAW}. - +Return a new socket port of the type specified by @var{family}, +@var{style} and @var{protocol}. All three parameters are +integers. Typical values for @var{family} are the values of +@code{AF_UNIX} and @code{AF_INET}. Typical values for +@var{style} are the values of @code{SOCK_STREAM}, +@code{SOCK_DGRAM} and @code{SOCK_RAW}. @var{protocol} can be obtained from a protocol name using -@code{getprotobyname}. A value of -zero specifies the default protocol, which is usually right. - -A single socket port cannot by used for communication until -it has been connected to another socket. +@code{getprotobyname}. A value of zero specifies the default +protocol, which is usually right. +A single socket port cannot by used for communication until it +has been connected to another socket. @end deffn socketpair @c snarfed from socket.c:180 @deffn primitive socketpair family style proto -Returns a pair of connected (but unnamed) socket ports of the type specified -by @var{family}, @var{style} and @var{protocol}. -Many systems support only -socket pairs of the @code{AF_UNIX} family. Zero is likely to be -the only meaningful value for @var{protocol}. +Return a pair of connected (but unnamed) socket ports of the +type specified by @var{family}, @var{style} and @var{protocol}. +Many systems support only socket pairs of the @code{AF_UNIX} +family. Zero is likely to be the only meaningful value for +@var{protocol}. @end deffn getsockopt @c snarfed from socket.c:209 @deffn primitive getsockopt sock level optname -Returns the value of a particular socket option for the socket -port @var{socket}. @var{level} is an integer code for type of option -being requested, e.g., @code{SOL_SOCKET} for socket-level options. -@var{optname} is an -integer code for the option required and should be specified using one of -the symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc. - -The returned value is typically an integer but @code{SO_LINGER} returns a -pair of integers. +Return the value of a particular socket option for the socket +port @var{socket}. @var{level} is an integer code for type of +option being requested, e.g., @code{SOL_SOCKET} for +socket-level options. @var{optname} is an integer code for the +option required and should be specified using one of the +symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc. +The returned value is typically an integer but @code{SO_LINGER} +returns a pair of integers. @end deffn setsockopt @@ -5207,18 +5140,18 @@ connection and will continue to accept new requests. getsockname @c snarfed from socket.c:668 @deffn primitive getsockname sock -Returns the address of @var{socket}, in the same form as the object -returned by @code{accept}. On many systems the address of a socket -in the @code{AF_FILE} namespace cannot be read. +Return the address of @var{socket}, in the same form as the +object returned by @code{accept}. On many systems the address +of a socket in the @code{AF_FILE} namespace cannot be read. @end deffn getpeername @c snarfed from socket.c:695 @deffn primitive getpeername sock -Returns the address of the socket that the socket @var{socket} is connected to, -in the same form as the object -returned by @code{accept}. On many systems the address of a socket -in the @code{AF_FILE} namespace cannot be read. +Return the address of the socket that the socket @var{socket} +is connected to, in the same form as the object returned by +@code{accept}. On many systems the address of a socket in the +@code{AF_FILE} namespace cannot be read. @end deffn recv! @@ -5258,27 +5191,23 @@ any unflushed buffered port data is ignored. recvfrom! @c snarfed from socket.c:797 @deffn primitive recvfrom! sock str [flags [start [end]]] -Returns data from the socket port @var{socket} and also information about -where the data was received from. @var{socket} must already -be bound to the address from which data is to be received. -@code{str}, is a string into which -the data will be written. The size of @var{str} limits the amount of -data which can be received: in the case of packet -protocols, if a packet larger than this limit is encountered then some data -will be irrevocably lost. - -The optional @var{flags} argument is a value or -bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc. - -The value returned is a pair: the CAR is the number of bytes read from -the socket and the CDR an address object in the same form as returned by -@code{accept}. - -The @var{start} and @var{end} arguments specify a substring of @var{str} -to which the data should be written. - -Note that the data is read directly from the socket file descriptor: -any unread buffered port data is ignored. +Return data from the socket port @var{socket} and also +information about where the data was received from. +@var{socket} must already be bound to the address from which +data is to be received. @code{str}, is a string into which the +data will be written. The size of @var{str} limits the amount +of data which can be received: in the case of packet protocols, +if a packet larger than this limit is encountered then some +data will be irrevocably lost. +The optional @var{flags} argument is a value or bitwise OR of +@code{MSG_OOB}, @code{MSG_PEEK}, @code{MSG_DONTROUTE} etc. +The value returned is a pair: the @emph{car} is the number of +bytes read from the socket and the @emph{cdr} an address object +in the same form as returned by @code{accept}. +The @var{start} and @var{end} arguments specify a substring of +@var{str} to which the data should be written. +Note that the data is read directly from the socket file +descriptor: any unread buffered port data is ignored. @end deffn sendto @@ -5531,16 +5460,16 @@ Return @code{#t} if @var{frame} is an overflow frame. get-internal-real-time @c snarfed from stime.c:141 @deffn primitive get-internal-real-time -Returns the number of time units since the interpreter was started. +Return the number of time units since the interpreter was +started. @end deffn times @c snarfed from stime.c:183 @deffn primitive times -Returns an object with information about real and processor time. -The following procedures accept such an object as an argument and -return a selected component: - +Return an object with information about real and processor +time. The following procedures accept such an object as an +argument and return a selected component: @table @code @item tms:clock The current real time, expressed as time units relative to an @@ -5548,10 +5477,12 @@ arbitrary base. @item tms:utime The CPU time units used by the calling process. @item tms:stime -The CPU time units used by the system on behalf of the calling process. +The CPU time units used by the system on behalf of the calling +process. @item tms:cutime -The CPU time units used by terminated child processes of the calling -process, whose status has been collected (e.g., using @code{waitpid}). +The CPU time units used by terminated child processes of the +calling process, whose status has been collected (e.g., using +@code{waitpid}). @item tms:cstime Similarly, the CPU times units used by the system on behalf of terminated child processes. @@ -5561,41 +5492,43 @@ terminated child processes. get-internal-run-time @c snarfed from stime.c:214 @deffn primitive get-internal-run-time -Returns the number of time units of processor time used by the interpreter. -Both "system" and "user" time are included but subprocesses are not. +Return the number of time units of processor time used by the +interpreter. Both @emph{system} and @emph{user} time are +included but subprocesses are not. @end deffn current-time @c snarfed from stime.c:224 @deffn primitive current-time -Returns the number of seconds since 1970-01-01 00:00:00 UTC, excluding -leap seconds. +Return the number of seconds since 1970-01-01 00:00:00 UTC, +excluding leap seconds. @end deffn gettimeofday @c snarfed from stime.c:241 @deffn primitive gettimeofday -Returns a pair containing the number of seconds and microseconds since -1970-01-01 00:00:00 UTC, excluding leap seconds. Note: whether true -microsecond resolution is available depends on the operating system. +Return a pair containing the number of seconds and microseconds +since 1970-01-01 00:00:00 UTC, excluding leap seconds. Note: +whether true microsecond resolution is available depends on the +operating system. @end deffn localtime @c snarfed from stime.c:341 @deffn primitive localtime time [zone] -Returns an object representing the broken down components of @var{time}, -an integer like the one returned by @code{current-time}. The time zone -for the calculation is optionally specified by @var{zone} (a string), -otherwise the @code{TZ} environment variable or the system default is -used. +Return an object representing the broken down components of +@var{time}, an integer like the one returned by +@code{current-time}. The time zone for the calculation is +optionally specified by @var{zone} (a string), otherwise the +@code{TZ} environment variable or the system default is used. @end deffn gmtime @c snarfed from stime.c:413 @deffn primitive gmtime time -Returns an object representing the broken down components of @var{time}, -an integer like the one returned by @code{current-time}. The values -are calculated for UTC. +Return an object representing the broken down components of +@var{time}, an integer like the one returned by +@code{current-time}. The values are calculated for UTC. @end deffn mktime @@ -5650,7 +5583,7 @@ which were used for the conversion. string? @c snarfed from strings.c:62 @deffn primitive string? obj -Returns @code{#t} iff @var{obj} is a string, else returns +Return @code{#t} iff @var{obj} is a string, else returns @code{#f}. @end deffn @@ -5662,13 +5595,13 @@ Return true if @var{obj} can be read as a string, This illustrates the difference between @code{string?} and @code{read-only-string?}: -@example +@lisp (string? "a string") @result{} #t (string? 'a-symbol) @result{} #f (read-only-string? "a string") @result{} #t (read-only-string? 'a-symbol) @result{} #t -@end example +@end lisp @end deffn list->string @@ -5681,7 +5614,7 @@ scm_string @c snarfed from strings.c:100 @deffn primitive string . chrs @deffnx primitive list->string chrs -Returns a newly allocated string composed of the arguments, +Return a newly allocated string composed of the arguments, @var{chrs}. @end deffn @@ -5736,14 +5669,14 @@ concatenation of the given strings, @var{args}. make-shared-substring @c snarfed from strings.c:400 -@deffn primitive make-shared-substring str [frm [to]] -Return a shared substring of @var{str}. The semantics are the same as -for the @code{substring} function: the shared substring returned -includes all of the text from @var{str} between indexes @var{start} -(inclusive) and @var{end} (exclusive). If @var{end} is omitted, it -defaults to the end of @var{str}. The shared substring returned by -@code{make-shared-substring} occupies the same storage space as -@var{str}. +@deffn primitive make-shared-substring str [start [end]] +Return a shared substring of @var{str}. The semantics are the +same as for the @code{substring} function: the shared substring +returned includes all of the text from @var{str} between +indexes @var{start} (inclusive) and @var{end} (exclusive). If +@var{end} is omitted, it defaults to the end of @var{str}. The +shared substring returned by @code{make-shared-substring} +occupies the same storage space as @var{str}. @end deffn string-index @@ -5754,15 +5687,7 @@ Return the index of the first occurrence of @var{chr} in @var{to} limit the search to a portion of the string. This procedure essentially implements the @code{index} or @code{strchr} functions from the C library. - -(qdocs:) Returns -the index of @var{char} in @var{str}, or @code{#f} if the -@var{char} isn't in @var{str}. If @var{frm} is given and not -@code{#f}, it is used as the starting index; if @var{to} is -given and not @code{#f}, it is used as the ending index -(exclusive). - -@example +@lisp (string-index "weiner" #\e) @result{} 1 @@ -5771,21 +5696,17 @@ given and not @code{#f}, it is used as the ending index (string-index "weiner" #\e 2 4) @result{} #f -@end example +@end lisp @end deffn string-rindex @c snarfed from strop.c:152 @deffn primitive string-rindex str chr [frm [to]] -Like @code{string-index}, but search from the right of the string rather -than from the left. This procedure essentially implements the -@code{rindex} or @code{strrchr} functions from the C library. - -(qdocs:) The same as @code{string-index}, except it gives the rightmost occurance -of @var{char} in the range [@var{frm}, @var{to}-1], which defaults to -the entire string. - -@example +Like @code{string-index}, but search from the right of the +string rather than from the left. This procedure essentially +implements the @code{rindex} or @code{strrchr} functions from +the C library. +@lisp (string-rindex "weiner" #\e) @result{} 4 @@ -5794,7 +5715,7 @@ the entire string. (string-rindex "weiner" #\e 2 5) @result{} 4 -@end example +@end lisp @end deffn substring-move-left! @@ -5835,133 +5756,122 @@ are different strings, it does not matter which function you use. substring-fill! @c snarfed from strop.c:280 @deffn primitive substring-fill! str start end fill -Change every character in @var{str} between @var{start} and @var{end} to -@var{fill-char}. - -(qdocs:) Destructively fills @var{str}, from @var{start} to @var{end}, with @var{fill}. - -@example +Change every character in @var{str} between @var{start} and +@var{end} to @var{fill}. +@lisp (define y "abcdefg") (substring-fill! y 1 3 #\r) y @result{} "arrdefg" -@end example +@end lisp @end deffn string-null? @c snarfed from strop.c:307 @deffn primitive string-null? str -Return @code{#t} if @var{str}'s length is nonzero, and @code{#f} -otherwise. - -(qdocs:) Returns @code{#t} if @var{str} is empty, else returns @code{#f}. - -@example -(string-null? "") -@result{} #t - -(string-null? y) -@result{} #f -@end example +Return @code{#t} if @var{str}'s length is nonzero, and +@code{#f} otherwise. +@lisp +(string-null? "") @result{} #t +y @result{} "foo" +(string-null? y) @result{} #f +@end lisp @end deffn string->list @c snarfed from strop.c:323 @deffn primitive string->list str -@samp{String->list} returns a newly allocated list of the -characters that make up the given string. @samp{List->string} -returns a newly allocated string formed from the characters in the list -@var{list}, which must be a list of characters. @samp{String->list} -and @samp{list->string} are -inverses so far as @samp{equal?} is concerned. (r5rs) +Return a newly allocated list of the characters that make up +the given string @var{str}. @code{string->list} and +@code{list->string} are inverses as far as @samp{equal?} is +concerned. @end deffn string-copy @c snarfed from strop.c:348 @deffn primitive string-copy str -Returns a newly allocated copy of the given @var{string}. (r5rs) +Return a newly allocated copy of the given @var{string}. @end deffn string-fill! @c snarfed from strop.c:361 @deffn primitive string-fill! str chr -Stores @var{char} in every element of the given @var{string} and returns an -unspecified value. (r5rs) +Store @var{char} in every element of the given @var{string} and +return an unspecified value. @end deffn string-upcase! @c snarfed from strop.c:397 @deffn primitive string-upcase! str -Destructively upcase every character in @code{str}. - -(qdocs:) Converts each element in @var{str} to upper case. - -@example -(string-upcase! y) -@result{} "ARRDEFG" - -y -@result{} "ARRDEFG" -@end example +Destructively upcase every character in @var{str} and return +@var{str}. +@lisp +y @result{} "arrdefg" +(string-upcase! y) @result{} "ARRDEFG" +y @result{} "ARRDEFG" +@end lisp @end deffn string-upcase @c snarfed from strop.c:409 @deffn primitive string-upcase str -Upcase every character in @code{str}. +Return a freshly allocated string containing the characters of +@var{str} in upper case. @end deffn string-downcase! @c snarfed from strop.c:444 @deffn primitive string-downcase! str -Destructively downcase every character in @code{str}. - -(qdocs:) Converts each element in @var{str} to lower case. - -@example -y -@result{} "ARRDEFG" - -(string-downcase! y) -@result{} "arrdefg" - -y -@result{} "arrdefg" -@end example +Destructively downcase every character in @var{str} and return +@var{str}. +@lisp +y @result{} "ARRDEFG" +(string-downcase! y) @result{} "arrdefg" +y @result{} "arrdefg" +@end lisp @end deffn string-downcase @c snarfed from strop.c:456 @deffn primitive string-downcase str -Downcase every character in @code{str}. +Return a freshly allocation string containing the characters in +@var{str} in lower case. @end deffn string-capitalize! @c snarfed from strop.c:493 @deffn primitive string-capitalize! str -Destructively capitalize every character in @code{str}. +Upcase the first character of every word in @var{str} +destructively and return @var{str}. +@lisp +y @result{} "hello world" +(string-capitalize! y) @result{} "Hello World" +y @result{} "Hello World" +@end lisp @end deffn string-capitalize @c snarfed from strop.c:505 @deffn primitive string-capitalize str -Capitalize every character in @code{str}. +Return a freshly allocated string with the characters in +@var{str}, where the first character of every word is +capitalized. @end deffn string-ci->symbol @c snarfed from strop.c:517 @deffn primitive string-ci->symbol str -Return the symbol whose name is @var{str}, downcased in necessary(???). +Return the symbol whose name is @var{str}. @var{str} is +converted to lowercase before the conversion is done, if Guile +is currently reading symbols case--insensitively. @end deffn string=? @c snarfed from strorder.c:64 @deffn primitive string=? s1 s2 -Lexicographic equality predicate; -Returns @code{#t} if the two strings are the same length and -contain the same characters in the same positions, otherwise -returns @code{#f}. (r5rs) - +Lexicographic equality predicate; return @code{#t} if the two +strings are the same length and contain the same characters in +the same positions, otherwise return @code{#f}. The procedure @code{string-ci=?} treats upper and lower case letters as though they were the same character, but @code{string=?} treats upper and lower case as distinct @@ -5971,72 +5881,70 @@ characters. string-ci=? @c snarfed from strorder.c:99 @deffn primitive string-ci=? s1 s2 -Case-insensitive string equality predicate; returns @code{#t} -if the two strings are the same length and their component +Case-insensitive string equality predicate; return @code{#t} if +the two strings are the same length and their component characters match (ignoring case) at each position; otherwise -returns @code{#f}. (r5rs) +return @code{#f}. @end deffn string? @c snarfed from strorder.c:185 @deffn primitive string>? s1 s2 -Lexicographic ordering predicate; returns @code{#t} if -@var{s1} is lexicographically greater than @var{s2}. (r5rs) +Lexicographic ordering predicate; return @code{#t} if @var{s1} +is lexicographically greater than @var{s2}. @end deffn string>=? @c snarfed from strorder.c:200 @deffn primitive string>=? s1 s2 -Lexicographic ordering predicate; returns @code{#t} if -@var{s1} is lexicographically greater than or equal to -@var{s2}. (r5rs) +Lexicographic ordering predicate; return @code{#t} if @var{s1} +is lexicographically greater than or equal to @var{s2}. @end deffn string-ci? @c snarfed from strorder.c:269 @deffn primitive string-ci>? s1 s2 -Case insensitive lexicographic ordering predicate; -returns @code{#t} if @var{s1} is lexicographically greater -than @var{s2} regardless of case. (r5rs) +Case insensitive lexicographic ordering predicate; return +@code{#t} if @var{s1} is lexicographically greater than +@var{s2} regardless of case. @end deffn string-ci>=? @c snarfed from strorder.c:284 @deffn primitive string-ci>=? s1 s2 -Case insensitive lexicographic ordering predicate; -returns @code{#t} if @var{s1} is lexicographically greater -than or equal to @var{s2} regardless of case. (r5rs) +Case insensitive lexicographic ordering predicate; return +@code{#t} if @var{s1} is lexicographically greater than or +equal to @var{s2} regardless of case. @end deffn object->string @@ -6057,17 +5965,17 @@ written into the port is returned. call-with-input-string @c snarfed from strports.c:371 -@deffn primitive call-with-input-string str proc -Calls the one-argument procedure @var{proc} with a newly created input -port from which @var{string}'s contents may be read. The value yielded -by the @var{proc} is returned. +@deffn primitive call-with-input-string string proc +Calls the one-argument procedure @var{proc} with a newly +created input port from which @var{string}'s contents may be +read. The value yielded by the @var{proc} is returned. @end deffn open-input-string @c snarfed from strports.c:384 @deffn primitive open-input-string str -Takes a string and returns an input port that delivers -characters from the string. The port can be closed by +Take a string and return an input port that delivers characters +from the string. The port can be closed by @code{close-input-port}, though its storage will be reclaimed by the garbage collector if it becomes inaccessible. @end deffn @@ -6075,7 +5983,7 @@ by the garbage collector if it becomes inaccessible. open-output-string @c snarfed from strports.c:398 @deffn primitive open-output-string -Returns an output port that will accumulate characters for +Return an output port that will accumulate characters for retrieval by @code{get-output-string}. The port can be closed by the procedure @code{close-output-port}, though its storage will be reclaimed by the garbage collector if it becomes @@ -6086,7 +5994,7 @@ inaccessible. @c snarfed from strports.c:415 @deffn primitive get-output-string port Given an output port created by @code{open-output-string}, -returns a string consisting of the characters that have been +return a string consisting of the characters that have been output to the port so far. @end deffn @@ -6194,7 +6102,7 @@ sub-system: one vtable-vtable working as the root and one or several "types", each with a set of "instances". (The vtable-vtable should be compared to the class which is the class of itself.) -@example +@lisp (define ball-root (make-vtable-vtable "pr" 0)) (define (make-ball-type ball-color) @@ -6215,7 +6123,7 @@ compared to the class which is the class of itself.) (define ball (make-ball green 'Nisse)) ball @result{} # -@end example +@end lisp @end deffn struct-ref @@ -6265,33 +6173,31 @@ Set the name of the vtable @var{vtable} to @var{name}. symbol? @c snarfed from symbols.c:422 @deffn primitive symbol? obj -Returns @code{#t} if @var{obj} is a symbol, otherwise returns -@code{#f}. (r5rs) +Return @code{#t} if @var{obj} is a symbol, otherwise return +@code{#f}. @end deffn symbol->string @c snarfed from symbols.c:451 @deffn primitive symbol->string s -Returns the name of @var{symbol} as a string. If the symbol -was part of an object returned as the value of a literal -expression (section @pxref{Literal expressions,,,r4rs, The -Revised^4 Report on Scheme}) or by a call to the @code{read} -procedure, and its name contains alphabetic characters, then -the string returned will contain characters in the -implementation's preferred standard case---some implementations -will prefer upper case, others lower case. If the symbol was -returned by @code{string->symbol}, the case of characters in -the string returned will be the same as the case in the string -that was passed to @code{string->symbol}. It is an error to -apply mutation procedures like @code{string-set!} to strings -returned by this procedure. (r5rs) - +Return the name of @var{symbol} as a string. If the symbol was +part of an object returned as the value of a literal expression +(section @pxref{Literal expressions,,,r4rs, The Revised^4 +Report on Scheme}) or by a call to the @code{read} procedure, +and its name contains alphabetic characters, then the string +returned will contain characters in the implementation's +preferred standard case---some implementations will prefer +upper case, others lower case. If the symbol was returned by +@code{string->symbol}, the case of characters in the string +returned will be the same as the case in the string that was +passed to @code{string->symbol}. It is an error to apply +mutation procedures like @code{string-set!} to strings returned +by this procedure. The following examples assume that the implementation's standard case is lower case: - @lisp -(symbol->string 'flying-fish) @result{} "flying-fish" -(symbol->string 'Martin) @result{} "martin" +(symbol->string 'flying-fish) @result{} "flying-fish" +(symbol->string 'Martin) @result{} "martin" (symbol->string (string->symbol "Malvina")) @result{} "Malvina" @end lisp @@ -6299,16 +6205,15 @@ standard case is lower case: string->symbol @c snarfed from symbols.c:478 -@deffn primitive string->symbol s -Returns the symbol whose name is @var{string}. This procedure +@deffn primitive string->symbol string +Return the symbol whose name is @var{string}. This procedure can create symbols with names containing special characters or letters in the non-standard case, but it is usually a bad idea -to create such because in some implementations of Scheme they -cannot be read as themselves. See @code{symbol->string}. - +to create such symbols because in some implementations of +Scheme they cannot be read as themselves. See +@code{symbol->string}. The following examples assume that the implementation's standard case is lower case: - @lisp (eq? 'mISSISSIppi 'mississippi) @result{} #t (string->symbol "mISSISSIppi") @result{} @r{the symbol with name "mISSISSIppi"} @@ -6457,31 +6362,26 @@ Return an integer corresponding to the type of X. Deprecated. catch @c snarfed from throw.c:529 -@deffn primitive catch tag thunk handler +@deffn primitive catch key thunk handler Invoke @var{thunk} in the dynamic context of @var{handler} for -exceptions matching @var{key}. If thunk throws to the symbol @var{key}, -then @var{handler} is invoked this way: - -@example +exceptions matching @var{key}. If thunk throws to the symbol +@var{key}, then @var{handler} is invoked this way: +@lisp (handler key args ...) -@end example - -@var{key} is a symbol or #t. - -@var{thunk} takes no arguments. If @var{thunk} returns normally, that -is the return value of @code{catch}. - -Handler is invoked outside the scope of its own @code{catch}. If -@var{handler} again throws to the same key, a new handler from further -up the call chain is invoked. - -If the key is @code{#t}, then a throw to @emph{any} symbol will match -this call to @code{catch}. +@end lisp +@var{key} is a symbol or @code{#t}. +@var{thunk} takes no arguments. If @var{thunk} returns +normally, that is the return value of @code{catch}. +Handler is invoked outside the scope of its own @code{catch}. +If @var{handler} again throws to the same key, a new handler +from further up the call chain is invoked. +If the key is @code{#t}, then a throw to @emph{any} symbol will +match this call to @code{catch}. @end deffn lazy-catch @c snarfed from throw.c:556 -@deffn primitive lazy-catch tag thunk handler +@deffn primitive lazy-catch key thunk handler This behaves exactly like @code{catch}, except that it does not unwind the stack (this is the major difference), and if handler returns, its value is returned from the throw. @@ -6502,23 +6402,22 @@ If there is no handler at all, an error is signaled. uniform-vector-length @c snarfed from unif.c:255 @deffn primitive uniform-vector-length v -Returns the number of elements in @var{uve}. +Return the number of elements in @var{uve}. @end deffn array? @c snarfed from unif.c:289 @deffn primitive array? v [prot] -Returns @code{#t} if the @var{obj} is an array, and @code{#f} if not. - -The @var{prototype} argument is used with uniform arrays and is described -elsewhere. +Return @code{#t} if the @var{obj} is an array, and @code{#f} if +not. The @var{prototype} argument is used with uniform arrays +and is described elsewhere. @end deffn array-rank @c snarfed from unif.c:360 @deffn primitive array-rank ra -Returns the number of dimensions of @var{obj}. If @var{obj} is not an -array, @code{0} is returned. +Return the number of dimensions of @var{obj}. If @var{obj} is +not an array, @code{0} is returned. @end deffn array-dimensions @@ -6526,9 +6425,9 @@ array, @code{0} is returned. @deffn primitive array-dimensions ra @code{Array-dimensions} is similar to @code{array-shape} but replaces elements with a @code{0} minimum with one greater than the maximum. So: -@example +@lisp (array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5) -@end example +@end lisp @end deffn shared-array-root @@ -6553,10 +6452,10 @@ For each dimension, return the distance between elements in the root vector. @c snarfed from unif.c:586 @deffn primitive dimensions->uniform-array dims prot [fill] @deffnx primitive make-uniform-vector length prototype [fill] -Creates and returns a uniform array or vector of type corresponding to -@var{prototype} with dimensions @var{dims} or length @var{length}. If -@var{fill} is supplied, it's used to fill the array, otherwise -@var{prototype} is used. +Create and return a uniform array or vector of type +corresponding to @var{prototype} with dimensions @var{dims} or +length @var{length}. If @var{fill} is supplied, it's used to +fill the array, otherwise @var{prototype} is used. @end deffn make-shared-array @@ -6567,7 +6466,7 @@ arrays. The @var{mapper} is a function that translates coordinates in the new array into coordinates in the old array. A @var{mapper} must be linear, and its range must stay within the bounds of the old array, but it can be otherwise arbitrary. A simple example: -@example +@lisp (define fred (make-array #f 8 8)) (define freds-diagonal (make-shared-array fred (lambda (i) (list i i)) 8)) @@ -6576,31 +6475,29 @@ it can be otherwise arbitrary. A simple example: (define freds-center (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2)) (array-ref freds-center 0 0) @result{} foo -@end example +@end lisp @end deffn transpose-array @c snarfed from unif.c:802 @deffn primitive transpose-array ra . args -Returns an array sharing contents with @var{array}, but with dimensions -arranged in a different order. There must be one @var{dim} argument for -each dimension of @var{array}. @var{dim0}, @var{dim1}, @dots{} should -be integers between 0 and the rank of the array to be returned. Each -integer in that range must appear at least once in the argument list. - -The values of @var{dim0}, @var{dim1}, @dots{} correspond to dimensions -in the array to be returned, their positions in the argument list to -dimensions of @var{array}. Several @var{dim}s may have the same value, -in which case the returned array will have smaller rank than -@var{array}. - -examples: -@example +Return an array sharing contents with @var{array}, but with +dimensions arranged in a different order. There must be one +@var{dim} argument for each dimension of @var{array}. +@var{dim0}, @var{dim1}, @dots{} should be integers between 0 +and the rank of the array to be returned. Each integer in that +range must appear at least once in the argument list. +The values of @var{dim0}, @var{dim1}, @dots{} correspond to +dimensions in the array to be returned, their positions in the +argument list to dimensions of @var{array}. Several @var{dim}s +may have the same value, in which case the returned array will +have smaller rank than @var{array}. +@lisp (transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d)) (transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d) (transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{} #2((a 4) (b 5) (c 6)) -@end example +@end lisp @end deffn enclose-array @@ -6620,19 +6517,20 @@ an enclosed array will be @code{equal?} but will not in general be enclosed array is unspecified. examples: -@example +@lisp (enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{} # (enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{} # -@end example +@end lisp @end deffn array-in-bounds? @c snarfed from unif.c:994 @deffn primitive array-in-bounds? v . args -Returns @code{#t} if its arguments would be acceptable to array-ref. +Return @code{#t} if its arguments would be acceptable to +@code{array-ref}. @end deffn array-ref @@ -6645,7 +6543,8 @@ scm_uniform_vector_ref @c snarfed from unif.c:1079 @deffn primitive uniform-vector-ref v args @deffnx primitive array-ref v . args -Returns the element at the @code{(index1, index2)} element in @var{array}. +Return the element at the @code{(index1, index2)} element in +@var{array}. @end deffn uniform-array-set1! @@ -6718,16 +6617,16 @@ omitted, in which case it defaults to the value returned by bit-count @c snarfed from unif.c:1774 @deffn primitive bit-count b bitvector -Returns the number of occurrences of the boolean @var{b} in +Return the number of occurrences of the boolean @var{b} in @var{bitvector}. @end deffn bit-position @c snarfed from unif.c:1813 @deffn primitive bit-position item v k -Returns the minimum index of an occurrence of @var{bool} in @var{bv} -which is at least @var{k}. If no @var{bool} occurs within the specified -range @code{#f} is returned. +Return the minimum index of an occurrence of @var{bool} in +@var{bv} which is at least @var{k}. If no @var{bool} occurs +within the specified range @code{#f} is returned. @end deffn bit-set*! @@ -6747,10 +6646,10 @@ of @var{bv} corresponding to the indexes in uve are set to bit-count* @c snarfed from unif.c:1935 @deffn primitive bit-count* v kv obj -Returns -@example +Return +@lisp (bit-count (bit-set*! (if bool bv (bit-invert! bv)) uve #t) #t). -@end example +@end lisp @var{bv} is not modified. @end deffn @@ -6763,23 +6662,25 @@ Modifies @var{bv} by replacing each element with its negation. array->list @c snarfed from unif.c:2077 @deffn primitive array->list v -Returns a list consisting of all the elements, in order, of @var{array}. +Return a list consisting of all the elements, in order, of +@var{array}. @end deffn list->uniform-array @c snarfed from unif.c:2169 @deffn primitive list->uniform-array ndim prot lst @deffnx procedure list->uniform-vector prot lst -Returns a uniform array of the type indicated by prototype @var{prot} -with elements the same as those of @var{lst}. Elements must be of the -appropriate type, no coercions are done. +Return a uniform array of the type indicated by prototype +@var{prot} with elements the same as those of @var{lst}. +Elements must be of the appropriate type, no coercions are +done. @end deffn array-prototype @c snarfed from unif.c:2520 @deffn primitive array-prototype ra -Returns an object that would produce an array of the same type as -@var{array}, if used as the @var{prototype} for +Return an object that would produce an array of the same type +as @var{array}, if used as the @var{prototype} for @code{make-uniform-array}. @end deffn @@ -6874,8 +6775,8 @@ Throws an error if @var{var} is not a variable object. vector? @c snarfed from vectors.c:142 @deffn primitive vector? obj -Returns @code{#t} if @var{obj} is a vector, otherwise returns -@code{#f}. (r5rs) +Return @code{#t} if @var{obj} is a vector, otherwise return +@code{#f}. @end deffn list->vector @@ -6888,28 +6789,27 @@ scm_vector @c snarfed from vectors.c:177 @deffn primitive vector . l @deffnx primitive list->vector l -Returns a newly allocated vector whose elements contain the -given arguments. Analogous to @code{list}. (r5rs) - +Return a newly allocated vector whose elements contain the +given arguments. Analogous to @code{list}. @lisp -(vector 'a 'b 'c) @result{} #(a b c) +(vector 'a 'b 'c) @result{} #(a b c) @end lisp @end deffn make-vector @c snarfed from vectors.c:255 @deffn primitive make-vector k [fill] -Returns a newly allocated vector of @var{k} elements. If a second -argument is given, then each element is initialized to @var{fill}. -Otherwise the initial contents of each element is unspecified. (r5rs) +Return a newly allocated vector of @var{k} elements. If a +second argument is given, then each element is initialized to +@var{fill}. Otherwise the initial contents of each element is +unspecified. @end deffn vector->list @c snarfed from vectors.c:311 @deffn primitive vector->list v -@samp{Vector->list} returns a newly allocated list of the -objects contained in the elements of @var{vector}. (r5rs) - +Return a newly allocated list of the objects contained in the +elements of @var{vector}. @lisp (vector->list '#(dah dah didah)) @result{} (dah dah didah) (list->vector '(dididit dah)) @result{} #(dididit dah) @@ -6918,9 +6818,9 @@ objects contained in the elements of @var{vector}. (r5rs) vector-fill! @c snarfed from vectors.c:328 -@deffn primitive vector-fill! v fill_x -Stores @var{fill} in every element of @var{vector}. -The value returned by @code{vector-fill!} is unspecified. (r5rs) +@deffn primitive vector-fill! v fill +Store @var{fill} in every element of @var{vector}. The value +returned by @code{vector-fill!} is unspecified. @end deffn vector-move-left! @@ -6957,21 +6857,20 @@ E.g., "3.5". Return a string describing Guile's version number, or its major or minor version numbers, respectively. -@example +@lisp (version) @result{} "1.3a" (major-version) @result{} "1" (minor-version) @result{} "3a" -@end example +@end lisp @end deffn make-soft-port @c snarfed from vports.c:184 @deffn primitive make-soft-port pv modes -Returns a port capable of receiving or delivering characters as +Return a port capable of receiving or delivering characters as specified by the @var{modes} string (@pxref{File Ports, -open-file}). @var{vector} must be a vector of length 6. Its components -are as follows: - +open-file}). @var{pv} must be a vector of length 5. Its +components are as follows: @enumerate 0 @item procedure accepting one character for output @@ -6984,17 +6883,15 @@ thunk for getting one character @item thunk for closing port (not by garbage collection) @end enumerate - For an output-only port only elements 0, 1, 2, and 4 need be -procedures. For an input-only port only elements 3 and 4 need be -procedures. Thunks 2 and 4 can instead be @code{#f} if there is no useful -operation for them to perform. - -If thunk 3 returns @code{#f} or an @code{eof-object} (@pxref{Input, -eof-object?, ,r4rs, The Revised^4 Report on Scheme}) it indicates that -the port has reached end-of-file. For example: - -@example +procedures. For an input-only port only elements 3 and 4 need +be procedures. Thunks 2 and 4 can instead be @code{#f} if +there is no useful operation for them to perform. +If thunk 3 returns @code{#f} or an @code{eof-object} +(@pxref{Input, eof-object?, ,r4rs, The Revised^4 Report on +Scheme}) it indicates that the port has reached end-of-file. +For example: +@lisp (define stdout (current-output-port)) (define p (make-soft-port (vector @@ -7004,17 +6901,17 @@ the port has reached end-of-file. For example: (lambda () (char-upcase (read-char))) (lambda () (display "@@" stdout))) "rw")) - (write p p) @result{} # -@end example +@end lisp @end deffn make-weak-vector @c snarfed from weaks.c:62 -@deffn primitive make-weak-vector k [fill] +@deffn primitive make-weak-vector size [fill] Return a weak vector with @var{size} elements. If the optional -argument @var{fill} is given, all entries in the vector will be set to -@var{fill}. The default value for @var{fill} is the empty list. +argument @var{fill} is given, all entries in the vector will be +set to @var{fill}. The default value for @var{fill} is the +empty list. @end deffn list->weak-vector @@ -7027,29 +6924,29 @@ scm_weak_vector @c snarfed from weaks.c:87 @deffn primitive weak-vector . l @deffnx primitive list->weak-vector l -Construct a weak vector from a list: @code{weak-vector} uses the list of -its arguments while @code{list->weak-vector} uses its only argument -@var{l} (a list) to construct a weak vector the same way -@code{vector->list} would. +Construct a weak vector from a list: @code{weak-vector} uses +the list of its arguments while @code{list->weak-vector} uses +its only argument @var{l} (a list) to construct a weak vector +the same way @code{list->vector} would. @end deffn weak-vector? @c snarfed from weaks.c:110 -@deffn primitive weak-vector? x +@deffn primitive weak-vector? obj Return @code{#t} if @var{obj} is a weak vector. Note that all weak hashes are also weak vectors. @end deffn make-weak-key-hash-table @c snarfed from weaks.c:130 -@deffn primitive make-weak-key-hash-table k +@deffn primitive make-weak-key-hash-table size @deffnx primitive make-weak-value-hash-table size @deffnx primitive make-doubly-weak-hash-table size -Return a weak hash table with @var{size} buckets. As with any hash -table, choosing a good size for the table requires some caution. - -You can modify weak hash tables in exactly the same way you would modify -regular hash tables. (@pxref{Hash Tables}) +Return a weak hash table with @var{size} buckets. As with any +hash table, choosing a good size for the table requires some +caution. +You can modify weak hash tables in exactly the same way you +would modify regular hash tables. (@pxref{Hash Tables}) @end deffn make-weak-value-hash-table @@ -7068,7 +6965,7 @@ buckets. (@pxref{Hash Tables}) weak-key-hash-table? @c snarfed from weaks.c:184 -@deffn primitive weak-key-hash-table? x +@deffn primitive weak-key-hash-table? obj @deffnx primitive weak-value-hash-table? obj @deffnx primitive doubly-weak-hash-table? obj Return @code{#t} if @var{obj} is the specified weak hash diff --git a/doc/new-docstrings.texi b/doc/new-docstrings.texi index 2487d354b..778b3b45d 100644 --- a/doc/new-docstrings.texi +++ b/doc/new-docstrings.texi @@ -29,26 +29,26 @@ If @var{env} contains no bindings, this function simply returns @var{init}. If @var{env} binds the symbol sym1 to the value val1, sym2 to val2, and so on, then this procedure computes: -@example +@lisp (proc sym1 val1 (proc sym2 val2 ... (proc symn valn init))) -@end example +@end lisp Each binding in @var{env} will be processed exactly once. @code{environment-fold} makes no guarantees about the order in which the bindings are processed. Here is a function which, given an environment, constructs an association list representing that environment's bindings, using environment-fold: -@example +@lisp (define (environment->alist env) (environment-fold env (lambda (sym val tail) (cons (cons sym val) tail)) '())) -@end example +@end lisp @end deffn @deffn primitive environment-define env sym val @@ -586,12 +586,11 @@ crypt(3) library call @end deffn @deffn primitive mkstemp! tmpl -mkstemp creates a new unique file in the file system and -returns a new buffered port open for reading and writing to -the file. @var{tmpl} is a string specifying where the -file should be created: it must end with @code{XXXXXX} -and will be changed in place to return the name of the -temporary file. +Create a new unique file in the file system and returns a new +buffered port open for reading and writing to the file. +@var{tmpl} is a string specifying where the file should be +created: it must end with @code{XXXXXX} and will be changed in +place to return the name of the temporary file. @end deffn @deffn primitive %tag-body body diff --git a/doc/posix.texi b/doc/posix.texi index fea735015..6b5943d59 100644 --- a/doc/posix.texi +++ b/doc/posix.texi @@ -152,7 +152,7 @@ fdes->ports. @c docstring begin (texi-doc-string "guile" "port-revealed") @deffn primitive port-revealed port -Returns the revealed count for @var{port}. +Return the revealed count for @var{port}. @end deffn @c docstring begin (texi-doc-string "guile" "set-port-revealed!") @@ -163,8 +163,8 @@ The return value is unspecified. @c docstring begin (texi-doc-string "guile" "fileno") @deffn primitive fileno port -Returns the integer file descriptor underlying @var{port}. -Does not change its revealed count. +Return the integer file descriptor underlying @var{port}. Does +not change its revealed count. @end deffn @deffn procedure port->fdes port @@ -174,16 +174,17 @@ side effect the revealed count of @var{port} is incremented. @c docstring begin (texi-doc-string "guile" "fdopen") @deffn primitive fdopen fdes modes -Returns a new port based on the file descriptor @var{fdes}. -Modes are given by the string @var{modes}. The revealed count of the port -is initialized to zero. The modes string is the same as that accepted -by @ref{File Ports, open-file}. +Return a new port based on the file descriptor @var{fdes}. +Modes are given by the string @var{modes}. The revealed count +of the port is initialized to zero. The modes string is the +same as that accepted by @ref{File Ports, open-file}. @end deffn @c docstring begin (texi-doc-string "guile" "fdes->ports") @deffn primitive fdes->ports fd -Returns a list of existing ports which have @var{fdes} as an -underlying file descriptor, without changing their revealed counts. +Return a list of existing ports which have @var{fdes} as an +underlying file descriptor, without changing their revealed +counts. @end deffn @deffn procedure fdes->inport fdes @@ -261,8 +262,8 @@ for additional flags. @c docstring begin (texi-doc-string "guile" "open-fdes") @deffn primitive open-fdes path flags [mode] -Similar to @code{open} but returns a file descriptor instead of a -port. +Similar to @code{open} but return a file descriptor instead of +a port. @end deffn @c docstring begin (texi-doc-string "guile" "close") @@ -300,19 +301,18 @@ unread characters will be read again in last-in first-out order. If @c docstring begin (texi-doc-string "guile" "pipe") @deffn primitive pipe -Returns a newly created pipe: a pair of ports which are linked -together on the local machine. The CAR is the input port and -the CDR is the output port. Data written (and flushed) to the -output port can be read from the input port. -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}. - -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. +Return a newly created pipe: a pair of ports which are linked +together on the local machine. The @emph{car} is the input +port and the @emph{cdr} is the output port. Data written (and +flushed) to the output port can be read from the input port. +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}. +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. @end deffn The next group of procedures perform a @code{dup2} @@ -327,7 +327,9 @@ their revealed counts set to zero. @c docstring begin (texi-doc-string "guile" "dup->fdes") @deffn primitive dup->fdes fd_or_port [fd] -Returns an integer file descriptor. +Return a new integer file descriptor referring to the open file +designated by @var{fd_or_port}, which must be either an open +file port or a file descriptor. @end deffn @deffn procedure dup->inport port/fd [newfd] @@ -393,10 +395,10 @@ The return value is unspecified. @c docstring begin (texi-doc-string "guile" "port-mode") @deffn primitive port-mode port -Returns the port modes associated with the open port @var{port}. These -will not necessarily be identical to the modes used when the port was -opened, since modes such as "append" which are used only during -port creation are not retained. +Return the port modes associated with the open port @var{port}. +These will not necessarily be identical to the modes used when +the port was opened, since modes such as "append" which are +used only during port creation are not retained. @end deffn @c docstring begin (texi-doc-string "guile" "close-all-ports-except") @@ -506,19 +508,15 @@ contents; syncing the file system and creating special files. @c docstring begin (texi-doc-string "guile" "access?") @deffn primitive access? path how -Returns @code{#t} if @var{path} corresponds to an existing -file and the current process -has the type of access specified by @var{how}, otherwise -@code{#f}. -@var{how} should be specified -using the values of the variables listed below. Multiple values can -be combined using a bitwise or, in which case @code{#t} will only -be returned if all accesses are granted. - -Permissions are checked using the real id of the current process, -not the effective id, although it's the effective id which determines -whether the access would actually be granted. - +Return @code{#t} if @var{path} corresponds to an existing file +and the current process has the type of access specified by +@var{how}, otherwise @code{#f}. @var{how} should be specified +using the values of the variables listed below. Multiple +values can be combined using a bitwise or, in which case +@code{#t} will only be returned if all accesses are granted. +Permissions are checked using the real id of the current +process, not the effective id, although it's the effective id +which determines whether the access would actually be granted. @defvar R_OK test for read permission. @end defvar @@ -536,25 +534,24 @@ test for existence of the file. @findex fstat @c docstring begin (texi-doc-string "guile" "stat") @deffn primitive stat object -Returns an object containing various information -about the file determined by @var{obj}. -@var{obj} can be a string containing a file name or a port or integer file -descriptor which is open on a file (in which case @code{fstat} is used -as the underlying system call). - -The object returned by @code{stat} can be passed as a single parameter -to the following procedures, all of which return integers: - +Return an object containing various information about the file +determined by @var{obj}. @var{obj} can be a string containing +a file name or a port or integer file descriptor which is open +on a file (in which case @code{fstat} is used as the underlying +system call). +The object returned by @code{stat} can be passed as a single +parameter to the following procedures, all of which return +integers: @table @code @item stat:dev The device containing the file. @item stat:ino -The file serial number, which distinguishes this file from all other -files on the same device. +The file serial number, which distinguishes this file from all +other files on the same device. @item stat:mode -The mode of the file. This includes file type information -and the file permission bits. See @code{stat:type} and @code{stat:perms} -below. +The mode of the file. This includes file type information and +the file permission bits. See @code{stat:type} and +@code{stat:perms} below. @item stat:nlink The number of hard links to the file. @item stat:uid @@ -573,20 +570,19 @@ The last modification time for the file. @item stat:ctime The last modification time for the attributes of the file. @item stat:blksize -The optimal block size for reading or writing the file, in bytes. +The optimal block size for reading or writing the file, in +bytes. @item stat:blocks -The amount of disk space that the file occupies measured in units of -512 byte blocks. +The amount of disk space that the file occupies measured in +units of 512 byte blocks. @end table - In addition, the following procedures return the information from stat:mode in a more convenient form: - @table @code @item stat:type A symbol representing the type of file. Possible values are -regular, directory, symlink, block-special, char-special, -fifo, socket and unknown +regular, directory, symlink, block-special, char-special, fifo, +socket and unknown @item stat:perms An integer representing the access permission bits. @end table @@ -601,9 +597,8 @@ file it points to. @var{path} must be a string. @c docstring begin (texi-doc-string "guile" "readlink") @deffn primitive readlink path -Returns the value of the symbolic link named by -@var{path} (a string), i.e., the -file that the link points to. +Return the value of the symbolic link named by @var{path} (a +string), i.e., the file that the link points to. @end deffn @findex fchown @@ -638,21 +633,16 @@ The return value is unspecified. @c docstring begin (texi-doc-string "guile" "utime") @deffn primitive utime pathname [actime [modtime]] -@code{utime} sets the access and modification times for -the file named by @var{path}. If @var{actime} or @var{modtime} -is not supplied, then the current time is used. -@var{actime} and @var{modtime} -must be integer time values as returned by the @code{current-time} -procedure. - -E.g., - -@smalllisp +@code{utime} sets the access and modification times for the +file named by @var{path}. If @var{actime} or @var{modtime} is +not supplied, then the current time is used. @var{actime} and +@var{modtime} must be integer time values as returned by the +@code{current-time} procedure. +@lisp (utime "foo" (- (current-time) 3600)) -@end smalllisp - -will set the access time to one hour in the past and the modification -time to the current time. +@end lisp +will set the access time to one hour in the past and the +modification time to the current time. @end deffn @findex unlink @@ -710,8 +700,8 @@ stream. @c docstring begin (texi-doc-string "guile" "directory-stream?") @deffn primitive directory-stream? obj -Returns a boolean indicating whether @var{object} is a directory stream -as returned by @code{opendir}. +Return a boolean indicating whether @var{object} is a directory +stream as returned by @code{opendir}. @end deffn @c docstring begin (texi-doc-string "guile" "readdir") @@ -751,20 +741,20 @@ to. Its exact interpretation depends on the kind of special file being created. E.g., -@example +@lisp (mknod "/dev/fd0" 'block-special #o660 (+ (* 2 256) 2)) -@end example +@end lisp The return value is unspecified. @end deffn @c docstring begin (texi-doc-string "guile" "tmpnam") @deffn primitive tmpnam -tmpnam returns a name in the file system that does not match -any existing file. However there is no guarantee that -another process will not create the file after tmpnam -is called. Care should be taken if opening the file, -e.g., use the O_EXCL open flag or use @code{mkstemp!} instead. +Return a name in the file system that does not match any +existing file. However there is no guarantee that another +process will not create the file after @code{tmpnam} is called. +Care should be taken if opening the file, e.g., use the +@code{O_EXCL} open flag or use @code{mkstemp!} instead. @end deffn @c docstring begin (texi-doc-string "guile" "dirname") @@ -904,15 +894,16 @@ or getgrent respectively. @c docstring begin (texi-doc-string "guile" "current-time") @deffn primitive current-time -Returns the number of seconds since 1970-01-01 00:00:00 UTC, excluding -leap seconds. +Return the number of seconds since 1970-01-01 00:00:00 UTC, +excluding leap seconds. @end deffn @c docstring begin (texi-doc-string "guile" "gettimeofday") @deffn primitive gettimeofday -Returns a pair containing the number of seconds and microseconds since -1970-01-01 00:00:00 UTC, excluding leap seconds. Note: whether true -microsecond resolution is available depends on the operating system. +Return a pair containing the number of seconds and microseconds +since 1970-01-01 00:00:00 UTC, excluding leap seconds. Note: +whether true microsecond resolution is available depends on the +operating system. @end deffn The following procedures either accept an object representing a broken down @@ -948,18 +939,18 @@ Time zone label (a string), not necessarily unique. @c docstring begin (texi-doc-string "guile" "localtime") @deffn primitive localtime time [zone] -Returns an object representing the broken down components of @var{time}, -an integer like the one returned by @code{current-time}. The time zone -for the calculation is optionally specified by @var{zone} (a string), -otherwise the @code{TZ} environment variable or the system default is -used. +Return an object representing the broken down components of +@var{time}, an integer like the one returned by +@code{current-time}. The time zone for the calculation is +optionally specified by @var{zone} (a string), otherwise the +@code{TZ} environment variable or the system default is used. @end deffn @c docstring begin (texi-doc-string "guile" "gmtime") @deffn primitive gmtime time -Returns an object representing the broken down components of @var{time}, -an integer like the one returned by @code{current-time}. The values -are calculated for UTC. +Return an object representing the broken down components of +@var{time}, an integer like the one returned by +@code{current-time}. The values are calculated for UTC. @end deffn @c docstring begin (texi-doc-string "guile" "mktime") @@ -1014,10 +1005,9 @@ reported by the following procedures. @c docstring begin (texi-doc-string "guile" "times") @deffn primitive times -Returns an object with information about real and processor time. -The following procedures accept such an object as an argument and -return a selected component: - +Return an object with information about real and processor +time. The following procedures accept such an object as an +argument and return a selected component: @table @code @item tms:clock The current real time, expressed as time units relative to an @@ -1025,10 +1015,12 @@ arbitrary base. @item tms:utime The CPU time units used by the calling process. @item tms:stime -The CPU time units used by the system on behalf of the calling process. +The CPU time units used by the system on behalf of the calling +process. @item tms:cutime -The CPU time units used by terminated child processes of the calling -process, whose status has been collected (e.g., using @code{waitpid}). +The CPU time units used by terminated child processes of the +calling process, whose status has been collected (e.g., using +@code{waitpid}). @item tms:cstime Similarly, the CPU times units used by the system on behalf of terminated child processes. @@ -1037,13 +1029,15 @@ terminated child processes. @c docstring begin (texi-doc-string "guile" "get-internal-real-time") @deffn primitive get-internal-real-time -Returns the number of time units since the interpreter was started. +Return the number of time units since the interpreter was +started. @end deffn @c docstring begin (texi-doc-string "guile" "get-internal-run-time") @deffn primitive get-internal-run-time -Returns the number of time units of processor time used by the interpreter. -Both "system" and "user" time are included but subprocesses are not. +Return the number of time units of processor time used by the +interpreter. Both @emph{system} and @emph{user} time are +included but subprocesses are not. @end deffn @node Runtime Environment @@ -1080,12 +1074,13 @@ The return value is unspecified. @c docstring begin (texi-doc-string "guile" "environ") @deffn primitive environ [env] -If @var{env} is omitted, returns the current environment as a list of strings. -Otherwise it sets the current environment, which is also the -default environment for child processes, to the supplied list of strings. -Each member of @var{env} should be of the form -@code{NAME=VALUE} and values of @code{NAME} should not be duplicated. -If @var{env} is supplied then the return value is unspecified. +If @var{env} is omitted, return the current environment (in the +Unix sense) as a list of strings. Otherwise set the current +environment, which is also the default environment for child +processes, to the supplied list of strings. Each member of +@var{env} should be of the form @code{NAME=VALUE} and values of +@code{NAME} should not be duplicated. If @var{env} is supplied +then the return value is unspecified. @end deffn @c docstring begin (texi-doc-string "guile" "putenv") @@ -1117,7 +1112,7 @@ The return value is unspecified. @findex pwd @c docstring begin (texi-doc-string "guile" "getcwd") @deffn primitive getcwd -Returns the name of the current working directory. +Return the name of the current working directory. @end deffn @c docstring begin (texi-doc-string "guile" "umask") @@ -1131,43 +1126,45 @@ E.g., @code{(umask #o022)} sets the mask to octal 22, decimal 18. @c docstring begin (texi-doc-string "guile" "getpid") @deffn primitive getpid -Returns an integer representing the current process ID. +Return an integer representing the current process ID. @end deffn @c docstring begin (texi-doc-string "guile" "getgroups") @deffn primitive getgroups -Returns a vector of integers representing the current supplimentary group IDs. +Return a vector of integers representing the current +supplimentary group IDs. @end deffn @c docstring begin (texi-doc-string "guile" "getppid") @deffn primitive getppid -Returns an integer representing the process ID of the parent process. +Return an integer representing the process ID of the parent +process. @end deffn @c docstring begin (texi-doc-string "guile" "getuid") @deffn primitive getuid -Returns an integer representing the current real user ID. +Return an integer representing the current real user ID. @end deffn @c docstring begin (texi-doc-string "guile" "getgid") @deffn primitive getgid -Returns an integer representing the current real group ID. +Return an integer representing the current real group ID. @end deffn @c docstring begin (texi-doc-string "guile" "geteuid") @deffn primitive geteuid -Returns an integer representing the current effective user ID. +Return an integer representing the current effective user ID. If the system does not support effective IDs, then the real ID -is returned. @code{(feature? 'EIDs)} reports whether the system -supports effective IDs. +is returned. @code{(feature? 'EIDs)} reports whether the +system supports effective IDs. @end deffn @c docstring begin (texi-doc-string "guile" "getegid") @deffn primitive getegid -Returns an integer representing the current effective group ID. +Return an integer representing the current effective group ID. If the system does not support effective IDs, then the real ID -is returned. @code{(feature? 'EIDs)} reports whether the system -supports effective IDs. +is returned. @code{(feature? 'EIDs)} reports whether the +system supports effective IDs. @end deffn @c docstring begin (texi-doc-string "guile" "setuid") @@ -1204,7 +1201,7 @@ The return value is unspecified. @c docstring begin (texi-doc-string "guile" "getpgrp") @deffn primitive getpgrp -Returns an integer representing the current process group ID. +Return an integer representing the current process group ID. This is the POSIX definition, not BSD. @end deffn @@ -1276,31 +1273,31 @@ by @code{waitpid}. @c docstring begin (texi-doc-string "guile" "status:exit-val") @deffn primitive status:exit-val status -Returns the exit status value, as would be -set if a process ended normally through a -call to @code{exit} or @code{_exit}, if any, otherwise @code{#f}. +Return the exit status value, as would be set if a process +ended normally through a call to @code{exit} or @code{_exit}, +if any, otherwise @code{#f}. @end deffn @c docstring begin (texi-doc-string "guile" "status:term-sig") @deffn primitive status:term-sig status -Returns the signal number which terminated the -process, if any, otherwise @code{#f}. +Return the signal number which terminated the process, if any, +otherwise @code{#f}. @end deffn @c docstring begin (texi-doc-string "guile" "status:stop-sig") @deffn primitive status:stop-sig status -Returns the signal number which stopped the -process, if any, otherwise @code{#f}. +Return the signal number which stopped the process, if any, +otherwise @code{#f}. @end deffn @c docstring begin (texi-doc-string "guile" "system") @deffn primitive system [cmd] -Executes @var{cmd} using the operating system's "command processor". -Under Unix this is usually the default shell @code{sh}. The value -returned is @var{cmd}'s exit status as returned by @code{waitpid}, which -can be interpreted using the functions above. - -If @code{system} is called without arguments, it returns a boolean +Execute @var{cmd} using the operating system's "command +processor". Under Unix this is usually the default shell +@code{sh}. The value returned is @var{cmd}'s exit status as +returned by @code{waitpid}, which can be interpreted using the +functions above. +If @code{system} is called without arguments, return a boolean indicating whether the command processor is available. @end deffn @@ -1480,28 +1477,27 @@ all platforms. @c docstring begin (texi-doc-string "guile" "isatty?") @deffn primitive isatty? port -Returns @code{#t} if @var{port} is using a serial -non-file device, otherwise @code{#f}. +Return @code{#t} if @var{port} is using a serial non--file +device, otherwise @code{#f}. @end deffn @c docstring begin (texi-doc-string "guile" "ttyname") @deffn primitive ttyname port -Returns a string with the name of the serial terminal device underlying -@var{port}. +Return a string with the name of the serial terminal device +underlying @var{port}. @end deffn @c docstring begin (texi-doc-string "guile" "ctermid") @deffn primitive ctermid -Returns a string containing the file name of the controlling terminal -for the current process. +Return a string containing the file name of the controlling +terminal for the current process. @end deffn @c docstring begin (texi-doc-string "guile" "tcgetpgrp") @deffn primitive tcgetpgrp port -Returns the process group ID of the foreground -process group associated with the terminal open on the file descriptor +Return the process group ID of the foreground process group +associated with the terminal open on the file descriptor underlying @var{port}. - If there is no foreground process group, the return value is a number greater than 1 that does not match the process group ID of any existing process group. This can happen if all of the @@ -1575,52 +1571,48 @@ the database routines since they are not reentrant. @c docstring begin (texi-doc-string "guile" "inet-aton") @deffn primitive inet-aton address -Converts a string containing an Internet host address in the traditional -dotted decimal notation into an integer. - -@smalllisp +Converts a string containing an Internet host address in the +traditional dotted decimal notation into an integer. +@lisp (inet-aton "127.0.0.1") @result{} 2130706433 - -@end smalllisp +@end lisp @end deffn @c docstring begin (texi-doc-string "guile" "inet-ntoa") @deffn primitive inet-ntoa inetid -Converts an integer Internet host address into a string with the -traditional dotted decimal representation. - -@smalllisp +Converts an integer Internet host address into a string with +the traditional dotted decimal representation. +@lisp (inet-ntoa 2130706433) @result{} "127.0.0.1" -@end smalllisp +@end lisp @end deffn @c docstring begin (texi-doc-string "guile" "inet-netof") @deffn primitive inet-netof address -Returns the network number part of the given integer Internet address. - -@smalllisp +Return the network number part of the given integer Internet +address. +@lisp (inet-netof 2130706433) @result{} 127 -@end smalllisp +@end lisp @end deffn @c docstring begin (texi-doc-string "guile" "inet-lnaof") @deffn primitive inet-lnaof address -Returns the local-address-with-network part of the given Internet -address. - -@smalllisp +Return the local-address-with-network part of the given +Internet address. +@lisp (inet-lnaof 2130706433) @result{} 1 -@end smalllisp +@end lisp @end deffn @c docstring begin (texi-doc-string "guile" "inet-makeaddr") @deffn primitive inet-makeaddr net lna -Makes an Internet host address by combining the network number @var{net} -with the local-address-within-network number @var{lna}. - -@smalllisp +Makes an Internet host address by combining the network number +@var{net} with the local-address-within-network number +@var{lna}. +@lisp (inet-makeaddr 127 1) @result{} 2130706433 -@end smalllisp +@end lisp @end deffn @subsubsection The Host Database @@ -1881,40 +1873,38 @@ required. The arguments and return values are thus in host order. @c docstring begin (texi-doc-string "guile" "socket") @deffn primitive socket family style proto -Returns a new socket port of the type specified by @var{family}, @var{style} -and @var{protocol}. All three parameters are integers. Typical values -for @var{family} are the values of @code{AF_UNIX} -and @code{AF_INET}. Typical values for @var{style} are -the values of @code{SOCK_STREAM}, @code{SOCK_DGRAM} and @code{SOCK_RAW}. - +Return a new socket port of the type specified by @var{family}, +@var{style} and @var{protocol}. All three parameters are +integers. Typical values for @var{family} are the values of +@code{AF_UNIX} and @code{AF_INET}. Typical values for +@var{style} are the values of @code{SOCK_STREAM}, +@code{SOCK_DGRAM} and @code{SOCK_RAW}. @var{protocol} can be obtained from a protocol name using -@code{getprotobyname}. A value of -zero specifies the default protocol, which is usually right. - -A single socket port cannot by used for communication until -it has been connected to another socket. +@code{getprotobyname}. A value of zero specifies the default +protocol, which is usually right. +A single socket port cannot by used for communication until it +has been connected to another socket. @end deffn @c docstring begin (texi-doc-string "guile" "socketpair") @deffn primitive socketpair family style proto -Returns a pair of connected (but unnamed) socket ports of the type specified -by @var{family}, @var{style} and @var{protocol}. -Many systems support only -socket pairs of the @code{AF_UNIX} family. Zero is likely to be -the only meaningful value for @var{protocol}. +Return a pair of connected (but unnamed) socket ports of the +type specified by @var{family}, @var{style} and @var{protocol}. +Many systems support only socket pairs of the @code{AF_UNIX} +family. Zero is likely to be the only meaningful value for +@var{protocol}. @end deffn @c docstring begin (texi-doc-string "guile" "getsockopt") @deffn primitive getsockopt sock level optname -Returns the value of a particular socket option for the socket -port @var{socket}. @var{level} is an integer code for type of option -being requested, e.g., @code{SOL_SOCKET} for socket-level options. -@var{optname} is an -integer code for the option required and should be specified using one of -the symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc. - -The returned value is typically an integer but @code{SO_LINGER} returns a -pair of integers. +Return the value of a particular socket option for the socket +port @var{socket}. @var{level} is an integer code for type of +option being requested, e.g., @code{SOL_SOCKET} for +socket-level options. @var{optname} is an integer code for the +option required and should be specified using one of the +symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc. +The returned value is typically an integer but @code{SO_LINGER} +returns a pair of integers. @end deffn @c docstring begin (texi-doc-string "guile" "setsockopt") @@ -2060,17 +2050,17 @@ number. @c docstring begin (texi-doc-string "guile" "getsockname") @deffn primitive getsockname sock -Returns the address of @var{socket}, in the same form as the object -returned by @code{accept}. On many systems the address of a socket -in the @code{AF_FILE} namespace cannot be read. +Return the address of @var{socket}, in the same form as the +object returned by @code{accept}. On many systems the address +of a socket in the @code{AF_FILE} namespace cannot be read. @end deffn @c docstring begin (texi-doc-string "guile" "getpeername") @deffn primitive getpeername sock -Returns the address of the socket that the socket @var{socket} is connected to, -in the same form as the object -returned by @code{accept}. On many systems the address of a socket -in the @code{AF_FILE} namespace cannot be read. +Return the address of the socket that the socket @var{socket} +is connected to, in the same form as the object returned by +@code{accept}. On many systems the address of a socket in the +@code{AF_FILE} namespace cannot be read. @end deffn @c docstring begin (texi-doc-string "guile" "recv!") @@ -2107,27 +2097,23 @@ any unflushed buffered port data is ignored. @c docstring begin (texi-doc-string "guile" "recvfrom!") @deffn primitive recvfrom! sock str [flags [start [end]]] -Returns data from the socket port @var{socket} and also information about -where the data was received from. @var{socket} must already -be bound to the address from which data is to be received. -@code{str}, is a string into which -the data will be written. The size of @var{str} limits the amount of -data which can be received: in the case of packet -protocols, if a packet larger than this limit is encountered then some data -will be irrevocably lost. - -The optional @var{flags} argument is a value or -bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc. - -The value returned is a pair: the CAR is the number of bytes read from -the socket and the CDR an address object in the same form as returned by -@code{accept}. - -The @var{start} and @var{end} arguments specify a substring of @var{str} -to which the data should be written. - -Note that the data is read directly from the socket file descriptor: -any unread buffered port data is ignored. +Return data from the socket port @var{socket} and also +information about where the data was received from. +@var{socket} must already be bound to the address from which +data is to be received. @code{str}, is a string into which the +data will be written. The size of @var{str} limits the amount +of data which can be received: in the case of packet protocols, +if a packet larger than this limit is encountered then some +data will be irrevocably lost. +The optional @var{flags} argument is a value or bitwise OR of +@code{MSG_OOB}, @code{MSG_PEEK}, @code{MSG_DONTROUTE} etc. +The value returned is a pair: the @emph{car} is the number of +bytes read from the socket and the @emph{cdr} an address object +in the same form as returned by @code{accept}. +The @var{start} and @var{end} arguments specify a substring of +@var{str} to which the data should be written. +Note that the data is read directly from the socket file +descriptor: any unread buffered port data is ignored. @end deffn @c docstring begin (texi-doc-string "guile" "sendto") @@ -2152,30 +2138,30 @@ be done when sending or receiving encoded integer data from the network. @c docstring begin (texi-doc-string "guile" "htons") @deffn primitive htons in -Returns a new integer from @var{value} by converting from host to -network order. @var{value} must be within the range of a C unsigned -short integer. +Return a new integer from @var{value} by converting from host +to network order. @var{value} must be within the range of a C +unsigned short integer. @end deffn @c docstring begin (texi-doc-string "guile" "ntohs") @deffn primitive ntohs in -Returns a new integer from @var{value} by converting from network to -host order. @var{value} must be within the range of a C unsigned short -integer. +Return a new integer from @var{value} by converting from +network to host order. @var{value} must be within the range of +a C unsigned short integer. @end deffn @c docstring begin (texi-doc-string "guile" "htonl") @deffn primitive htonl in -Returns a new integer from @var{value} by converting from host to -network order. @var{value} must be within the range of a C unsigned -long integer. +Return a new integer from @var{value} by converting from host +to network order. @var{value} must be within the range of a C +unsigned long integer. @end deffn @c docstring begin (texi-doc-string "guile" "ntohl") @deffn primitive ntohl in -Returns a new integer from @var{value} by converting from network to -host order. @var{value} must be within the range of a C unsigned -long integer. +Return a new integer from @var{value} by converting from +network to host order. @var{value} must be within the range of +a C unsigned long integer. @end deffn These procedures are inconvenient to use at present, but consider: @@ -2199,8 +2185,8 @@ These procedures are inconvenient to use at present, but consider: @c docstring begin (texi-doc-string "guile" "uname") @deffn primitive uname -Returns an object with some information about the computer system the -program is running on. +Return an object with some information about the computer +system the program is running on. @end deffn The following procedures accept an object as returned by @code{uname} @@ -2237,13 +2223,12 @@ no other easy or unambiguous way of detecting such features. @c docstring begin (texi-doc-string "guile" "setlocale") @deffn primitive setlocale category [locale] -If @var{locale} is omitted, returns the current value of the specified -locale category as a system-dependent string. -@var{category} should be specified using the values @code{LC_COLLATE}, -@code{LC_ALL} etc. - -Otherwise the specified locale category is set to -the string @var{locale} -and the new value is returned as a system-dependent string. If @var{locale} -is an empty string, the locale will be set using envirionment variables. +If @var{locale} is omitted, return the current value of the +specified locale category as a system-dependent string. +@var{category} should be specified using the values +@code{LC_COLLATE}, @code{LC_ALL} etc. +Otherwise the specified locale category is set to the string +@var{locale} and the new value is returned as a +system-dependent string. If @var{locale} is an empty string, +the locale will be set using envirionment variables. @end deffn diff --git a/doc/scheme-control.texi b/doc/scheme-control.texi index 5098fe4cd..c7517175e 100644 --- a/doc/scheme-control.texi +++ b/doc/scheme-control.texi @@ -88,28 +88,22 @@ Instead of using @code{call-with-current-continuation}, the exception primitives documented here are implemented as built-ins that take advantage of the @emph{upward only} nature of exceptions. -@c ARGFIXME tag/key @c docstring begin (texi-doc-string "guile" "catch") -@deffn primitive catch tag thunk handler +@deffn primitive catch key thunk handler Invoke @var{thunk} in the dynamic context of @var{handler} for -exceptions matching @var{key}. If thunk throws to the symbol @var{key}, -then @var{handler} is invoked this way: - -@example +exceptions matching @var{key}. If thunk throws to the symbol +@var{key}, then @var{handler} is invoked this way: +@lisp (handler key args ...) -@end example - -@var{key} is a symbol or #t. - -@var{thunk} takes no arguments. If @var{thunk} returns normally, that -is the return value of @code{catch}. - -Handler is invoked outside the scope of its own @code{catch}. If -@var{handler} again throws to the same key, a new handler from further -up the call chain is invoked. - -If the key is @code{#t}, then a throw to @emph{any} symbol will match -this call to @code{catch}. +@end lisp +@var{key} is a symbol or @code{#t}. +@var{thunk} takes no arguments. If @var{thunk} returns +normally, that is the return value of @code{catch}. +Handler is invoked outside the scope of its own @code{catch}. +If @var{handler} again throws to the same key, a new handler +from further up the call chain is invoked. +If the key is @code{#t}, then a throw to @emph{any} symbol will +match this call to @code{catch}. @end deffn @c docstring begin (texi-doc-string "guile" "throw") @@ -124,7 +118,7 @@ If there is no handler at all, an error is signaled. @end deffn @c docstring begin (texi-doc-string "guile" "lazy-catch") -@deffn primitive lazy-catch tag thunk handler +@deffn primitive lazy-catch key thunk handler This behaves exactly like @code{catch}, except that it does not unwind the stack (this is the major difference), and if handler returns, its value is returned from the throw. @@ -145,25 +139,27 @@ displaying @var{msg} and writing @var{args}. @end deffn @c end -@c ARGFIXME rest/data @c docstring begin (texi-doc-string "guile" "scm-error") -@deffn primitive scm-error key subr message args rest -Raise an error with key @var{key}. @var{subr} can be a string naming -the procedure associated with the error, or @code{#f}. @var{message} -is the error message string, possibly containing @code{~S} and @code{~A} -escapes. When an error is reported, these are replaced by formating the -corresponding members of @var{args}: @code{~A} (was @code{%s}) formats using @code{display} -and @code{~S} (was @code{%S}) formats using @code{write}. @var{data} is a -list or @code{#f} depending on @var{key}: if @var{key} is -@code{system-error} then it should be a list -containing the Unix @code{errno} value; If @var{key} is @code{signal} then -it should be a list containing the Unix signal number; otherwise it -will usually be @code{#f}. +@deffn primitive scm-error key subr message args data +Raise an error with key @var{key}. @var{subr} can be a string +naming the procedure associated with the error, or @code{#f}. +@var{message} is the error message string, possibly containing +@code{~S} and @code{~A} escapes. When an error is reported, +these are replaced by formatting the corresponding members of +@var{args}: @code{~A} (was @code{%s} in older versions of +Guile) formats using @code{display} and @code{~S} (was +@code{%S}) formats using @code{write}. @var{data} is a list or +@code{#f} depending on @var{key}: if @var{key} is +@code{system-error} then it should be a list containing the +Unix @code{errno} value; If @var{key} is @code{signal} then it +should be a list containing the Unix signal number; otherwise +it will usually be @code{#f}. @end deffn @c docstring begin (texi-doc-string "guile" "strerror") @deffn primitive strerror err -Returns the Unix error message corresponding to @var{err}, an integer. +Return the Unix error message corresponding to @var{err}, which +must be an integer value. @end deffn @c begin (scm-doc-string "boot-9.scm" "false-if-exception") @@ -181,23 +177,20 @@ if an exception occurs then @code{#f} is returned instead. be reviewed] @r5index dynamic-wind -@c ARGFIXME in-guard/thunk1 thunk/thunk2 out-guard/thunk3 @c docstring begin (texi-doc-string "guile" "dynamic-wind") -@deffn primitive dynamic-wind thunk1 thunk2 thunk3 +@deffn primitive dynamic-wind in_guard thunk out_guard All three arguments must be 0-argument procedures. - -@var{in-guard} is called, then @var{thunk}, then @var{out-guard}. - -If, any time during the execution of @var{thunk}, the continuation -of the @code{dynamic-wind} expression is escaped non-locally, @var{out-guard} -is called. If the continuation of the dynamic-wind is re-entered, -@var{in-guard} is called. Thus @var{in-guard} and @var{out-guard} may -be called any number of times. - -@example +@var{in_guard} is called, then @var{thunk}, then +@var{out_guard}. +If, any time during the execution of @var{thunk}, the +continuation of the @code{dynamic_wind} expression is escaped +non-locally, @var{out_guard} is called. If the continuation of +the dynamic-wind is re-entered, @var{in_guard} is called. Thus +@var{in_guard} and @var{out_guard} may be called any number of +times. +@lisp (define x 'normal-binding) @result{} x - (define a-cont (call-with-current-continuation (lambda (escape) (let ((old-x x)) @@ -205,38 +198,31 @@ be called any number of times. ;; in-guard: ;; (lambda () (set! x 'special-binding)) - ;; thunk ;; (lambda () (display x) (newline) (call-with-current-continuation escape) (display x) (newline) x) - ;; out-guard: ;; (lambda () (set! x old-x))))))) - ;; Prints: special-binding ;; Evaluates to: @result{} a-cont - x @result{} normal-binding - (a-cont #f) ;; Prints: special-binding ;; Evaluates to: @result{} a-cont ;; the value of the (define a-cont...) - x @result{} normal-binding - a-cont @result{} special-binding -@end example +@end lisp @end deffn @c Local Variables: @c TeX-master: "guile.texi" diff --git a/doc/scheme-data.texi b/doc/scheme-data.texi index 06f1a7da9..c8897266b 100755 --- a/doc/scheme-data.texi +++ b/doc/scheme-data.texi @@ -419,7 +419,7 @@ else. @c docstring begin (texi-doc-string "guile" "inexact->exact") @deffn primitive inexact->exact z -Returns an exact number that is numerically closest to @var{z}. +Return an exact number that is numerically closest to @var{z}. @end deffn @c begin (texi-doc-string "guile" "exact->inexact") @@ -621,7 +621,7 @@ inexact, a radix of 10 will be used. @c docstring begin (texi-doc-string "guile" "string->number") @deffn primitive string->number string [radix] -Returns a number of the maximally precise representation +Return a number of the maximally precise representation expressed by the given @var{string}. @var{radix} must be an exact integer, either 2, 8, 10, or 16. If supplied, @var{radix} is a default radix that may be overridden by an explicit radix @@ -960,10 +960,8 @@ Return the hyperbolic arctangent of @var{x}. @c docstring begin (texi-doc-string "guile" "logand") @deffn primitive logand n1 n2 -Returns the integer which is the bit-wise AND of the two integer +Return the integer which is the bit-wise AND of the two integer arguments. - -Example: @lisp (number->string (logand #b1100 #b1010) 2) @result{} "1000" @@ -972,10 +970,8 @@ Example: @c docstring begin (texi-doc-string "guile" "logior") @deffn primitive logior n1 n2 -Returns the integer which is the bit-wise OR of the two integer +Return the integer which is the bit-wise OR of the two integer arguments. - -Example: @lisp (number->string (logior #b1100 #b1010) 2) @result{} "1110" @@ -984,10 +980,8 @@ Example: @c docstring begin (texi-doc-string "guile" "logxor") @deffn primitive logxor n1 n2 -Returns the integer which is the bit-wise XOR of the two integer +Return the integer which is the bit-wise XOR of the two integer arguments. - -Example: @lisp (number->string (logxor #b1100 #b1010) 2) @result{} "110" @@ -996,9 +990,8 @@ Example: @c docstring begin (texi-doc-string "guile" "lognot") @deffn primitive lognot n -Returns the integer which is the 2s-complement of the integer argument. - -Example: +Return the integer which is the 2s-complement of the integer +argument. @lisp (number->string (lognot #b10000000) 2) @result{} "-10000001" @@ -1007,20 +1000,19 @@ Example: @end lisp @end deffn -@c ARGFIXME j/n1 k/n2 @c docstring begin (texi-doc-string "guile" "logtest") -@deffn primitive logtest n1 n2 -@example +@deffn primitive logtest j k +@lisp (logtest j k) @equiv{} (not (zero? (logand j k))) (logtest #b0100 #b1011) @result{} #f (logtest #b0100 #b0111) @result{} #t -@end example +@end lisp @end deffn @c docstring begin (texi-doc-string "guile" "logbit?") @deffn primitive logbit? index j -@example +@lisp (logbit? index j) @equiv{} (logtest (integer-expt 2 index) j) (logbit? 0 #b1101) @result{} #t @@ -1028,40 +1020,32 @@ Example: (logbit? 2 #b1101) @result{} #t (logbit? 3 #b1101) @result{} #t (logbit? 4 #b1101) @result{} #f -@end example +@end lisp @end deffn -@c ARGFIXME n/int cnt/count @c docstring begin (texi-doc-string "guile" "ash") @deffn primitive ash n cnt -The function ash performs an arithmetic shift left by @var{CNT} -bits (or shift right, if @var{cnt} is negative). -'Arithmetic' means, that the function does not guarantee to -keep the bit structure of @var{n}, but rather guarantees that -the result will always be rounded towards minus infinity. -Therefore, the results of ash and a corresponding bitwise -shift will differ if N is negative. - +The function ash performs an arithmetic shift left by @var{cnt} +bits (or shift right, if @var{cnt} is negative). 'Arithmetic' +means, that the function does not guarantee to keep the bit +structure of @var{n}, but rather guarantees that the result +will always be rounded towards minus infinity. Therefore, the +results of ash and a corresponding bitwise shift will differ if +@var{n} is negative. Formally, the function returns an integer equivalent to @code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}. - -Example: @lisp -(number->string (ash #b1 3) 2) - @result{} "1000" -(number->string (ash #b1010 -1) 2) - @result{} "101" +(number->string (ash #b1 3) 2) @result{} "1000" +(number->string (ash #b1010 -1) 2) @result{} "101" @end lisp @end deffn @c docstring begin (texi-doc-string "guile" "logcount") @deffn primitive logcount n -Returns the number of bits in integer @var{n}. If integer is positive, -the 1-bits in its binary representation are counted. If negative, the -0-bits in its two's-complement binary representation are counted. If 0, -0 is returned. - -Example: +Return the number of bits in integer @var{n}. If integer is +positive, the 1-bits in its binary representation are counted. +If negative, the 0-bits in its two's-complement binary +representation are counted. If 0, 0 is returned. @lisp (logcount #b10101010) @result{} 4 @@ -1074,9 +1058,7 @@ Example: @c docstring begin (texi-doc-string "guile" "integer-length") @deffn primitive integer-length n -Returns the number of bits neccessary to represent @var{n}. - -Example: +Return the number of bits neccessary to represent @var{n}. @lisp (integer-length #b10101010) @result{} 8 @@ -1089,9 +1071,8 @@ Example: @c docstring begin (texi-doc-string "guile" "integer-expt") @deffn primitive integer-expt n k -Returns @var{n} raised to the non-negative integer exponent @var{k}. - -Example: +Return @var{n} raised to the non-negative integer exponent +@var{k}. @lisp (integer-expt 2 5) @result{} 32 @@ -1102,11 +1083,9 @@ Example: @c docstring begin (texi-doc-string "guile" "bit-extract") @deffn primitive bit-extract n start end -Returns the integer composed of the @var{start} (inclusive) through -@var{end} (exclusive) bits of @var{n}. The @var{start}th bit becomes -the 0-th bit in the result.@refill - -Example: +Return the integer composed of the @var{start} (inclusive) +through @var{end} (exclusive) bits of @var{n}. The +@var{start}th bit becomes the 0-th bit in the result. @lisp (number->string (bit-extract #b1101101010 0 4) 2) @result{} "1010" @@ -1140,8 +1119,9 @@ as a side effect of the random operation. @c docstring begin (texi-doc-string "guile" "random:exp") @deffn primitive random:exp [state] -Returns an inexact real in an exponential distribution with mean 1. -For an exponential distribution with mean u use (* u (random:exp)). +Return an inexact real in an exponential distribution with mean +1. For an exponential distribution with mean u use (* u +(random:exp)). @end deffn @c docstring begin (texi-doc-string "guile" "random:hollow-sphere!") @@ -1156,10 +1136,10 @@ unit n-shere. @c docstring begin (texi-doc-string "guile" "random:normal") @deffn primitive random:normal [state] -Returns an inexact real in a normal distribution. -The distribution used has mean 0 and standard deviation 1. -For a normal distribution with mean m and standard deviation -d use @code{(+ m (* d (random:normal)))}. +Return an inexact real in a normal distribution. The +distribution used has mean 0 and standard deviation 1. For a +normal distribution with mean m and standard deviation d use +@code{(+ m (* d (random:normal)))}. @end deffn @c docstring begin (texi-doc-string "guile" "random:normal-vector!") @@ -1181,7 +1161,8 @@ The sum of the squares of the numbers is returned. @c docstring begin (texi-doc-string "guile" "random:uniform") @deffn primitive random:uniform [state] -Returns a uniformly distributed inexact real random number in [0,1). +Return a uniformly distributed inexact real random number in +[0,1). @end deffn @c docstring begin (texi-doc-string "guile" "seed->random-state") @@ -1444,20 +1425,19 @@ fulfills some specified property. @r5index string? @c docstring begin (texi-doc-string "guile" "string?") @deffn primitive string? obj -Returns @code{#t} iff @var{obj} is a string, else returns +Return @code{#t} iff @var{obj} is a string, else returns @code{#f}. @end deffn @c docstring begin (texi-doc-string "guile" "string-null?") @deffn primitive string-null? str -Return @code{#t} if @var{str}'s length is nonzero, and @code{#f} -otherwise. - -@example +Return @code{#t} if @var{str}'s length is nonzero, and +@code{#f} otherwise. +@lisp (string-null? "") @result{} #t -y @result{} "foo" -(string-null? y) @result{} #f -@end example +y @result{} "foo" +(string-null? y) @result{} #f +@end lisp @end deffn @node String Constructors @@ -1474,7 +1454,7 @@ initializing them with some specified character data. @c docstring begin (texi-doc-string "guile" "list->string") @deffn primitive string . chrs @deffnx primitive list->string chrs -Returns a newly allocated string composed of the arguments, +Return a newly allocated string composed of the arguments, @var{chrs}. @end deffn @@ -1498,12 +1478,10 @@ These procedures are useful for similar tasks. @r5index string->list @c docstring begin (texi-doc-string "guile" "string->list") @deffn primitive string->list str -@samp{String->list} returns a newly allocated list of the -characters that make up the given string. @samp{List->string} -returns a newly allocated string formed from the characters in the list -@var{list}, which must be a list of characters. @samp{String->list} -and @samp{list->string} are -inverses so far as @samp{equal?} is concerned. (r5rs) +Return a newly allocated list of the characters that make up +the given string @var{str}. @code{string->list} and +@code{list->string} are inverses as far as @samp{equal?} is +concerned. @end deffn @node String Selection @@ -1529,7 +1507,7 @@ indexing. @var{k} must be a valid index of @var{str}. @r5index string-copy @c docstring begin (texi-doc-string "guile" "string-copy") @deffn primitive string-copy str -Returns a newly allocated copy of the given @var{string}. (r5rs) +Return a newly allocated copy of the given @var{string}. @end deffn @r5index substring @@ -1562,24 +1540,20 @@ an unspecified value. @var{k} must be a valid index of @r5index string-fill! @c docstring begin (texi-doc-string "guile" "string-fill!") @deffn primitive string-fill! str chr -Stores @var{char} in every element of the given @var{string} and returns an -unspecified value. (r5rs) +Store @var{char} in every element of the given @var{string} and +return an unspecified value. @end deffn -@c ARGFIXME fill/fill-char @c docstring begin (texi-doc-string "guile" "substring-fill!") @deffn primitive substring-fill! str start end fill -Change every character in @var{str} between @var{start} and @var{end} to -@var{fill-char}. - -(qdocs:) Destructively fills @var{str}, from @var{start} to @var{end}, with @var{fill}. - -@example +Change every character in @var{str} between @var{start} and +@var{end} to @var{fill}. +@lisp (define y "abcdefg") (substring-fill! y 1 3 #\r) y @result{} "arrdefg" -@end example +@end lisp @end deffn @c docstring begin (texi-doc-string "guile" "substring-move!") @@ -1670,67 +1644,64 @@ ending in @code{-ci} ignore the character case when comparing strings. @r5index string<=? @c docstring begin (texi-doc-string "guile" "string-ci<=?") @deffn primitive string-ci<=? s1 s2 -Case insensitive lexicographic ordering predicate; -returns @code{#t} if @var{s1} is lexicographically less than -or equal to @var{s2} regardless of case. (r5rs) +Case insensitive lexicographic ordering predicate; return +@code{#t} if @var{s1} is lexicographically less than or equal +to @var{s2} regardless of case. @end deffn @r5index string-ci< @c docstring begin (texi-doc-string "guile" "string-ci=? @c docstring begin (texi-doc-string "guile" "string-ci>=?") @deffn primitive string-ci>=? s1 s2 -Case insensitive lexicographic ordering predicate; -returns @code{#t} if @var{s1} is lexicographically greater -than or equal to @var{s2} regardless of case. (r5rs) +Case insensitive lexicographic ordering predicate; return +@code{#t} if @var{s1} is lexicographically greater than or +equal to @var{s2} regardless of case. @end deffn @r5index string-ci>? @c docstring begin (texi-doc-string "guile" "string-ci>?") @deffn primitive string-ci>? s1 s2 -Case insensitive lexicographic ordering predicate; -returns @code{#t} if @var{s1} is lexicographically greater -than @var{s2} regardless of case. (r5rs) +Case insensitive lexicographic ordering predicate; return +@code{#t} if @var{s1} is lexicographically greater than +@var{s2} regardless of case. @end deffn @r5index string<=? @c docstring begin (texi-doc-string "guile" "string<=?") @deffn primitive string<=? s1 s2 -Lexicographic ordering predicate; returns @code{#t} if -@var{s1} is lexicographically less than or equal to @var{s2}. -(r5rs) +Lexicographic ordering predicate; return @code{#t} if @var{s1} +is lexicographically less than or equal to @var{s2}. @end deffn @r5index string=? @c docstring begin (texi-doc-string "guile" "string>=?") @deffn primitive string>=? s1 s2 -Lexicographic ordering predicate; returns @code{#t} if -@var{s1} is lexicographically greater than or equal to -@var{s2}. (r5rs) +Lexicographic ordering predicate; return @code{#t} if @var{s1} +is lexicographically greater than or equal to @var{s2}. @end deffn @r5index string>? @c docstring begin (texi-doc-string "guile" "string>?") @deffn primitive string>? s1 s2 -Lexicographic ordering predicate; returns @code{#t} if -@var{s1} is lexicographically greater than @var{s2}. (r5rs) +Lexicographic ordering predicate; return @code{#t} if @var{s1} +is lexicographically greater than @var{s2}. @end deffn @node String Searching @@ -1760,17 +1730,12 @@ can be used. @c docstring begin (texi-doc-string "guile" "string-index") @deffn primitive string-index str chr [frm [to]] -Return the index of the first occurrence of @var{chr} in @var{str}. The -optional integer arguments @var{frm} and @var{to} limit the search to -a portion of the string. This procedure essentially implements the -@code{index} or @code{strchr} functions from the C library. - -(qdocs:) Returns the index of @var{char} in @var{str}, or @code{#f} if the -@var{char} isn't in @var{str}. If @var{frm} is given and not @code{#f}, -it is used as the starting index; if @var{to} is given and not @code{#f}, -it is used as the ending index (exclusive). - -@example +Return the index of the first occurrence of @var{chr} in +@var{str}. The optional integer arguments @var{frm} and +@var{to} limit the search to a portion of the string. This +procedure essentially implements the @code{index} or +@code{strchr} functions from the C library. +@lisp (string-index "weiner" #\e) @result{} 1 @@ -1779,20 +1744,16 @@ it is used as the ending index (exclusive). (string-index "weiner" #\e 2 4) @result{} #f -@end example +@end lisp @end deffn @c docstring begin (texi-doc-string "guile" "string-rindex") @deffn primitive string-rindex str chr [frm [to]] -Like @code{string-index}, but search from the right of the string rather -than from the left. This procedure essentially implements the -@code{rindex} or @code{strrchr} functions from the C library. - -(qdocs:) The same as @code{string-index}, except it gives the rightmost occurance -of @var{char} in the range [@var{frm}, @var{to}-1], which defaults to -the entire string. - -@example +Like @code{string-index}, but search from the right of the +string rather than from the left. This procedure essentially +implements the @code{rindex} or @code{strrchr} functions from +the C library. +@lisp (string-rindex "weiner" #\e) @result{} 4 @@ -1801,7 +1762,7 @@ the entire string. (string-rindex "weiner" #\e 2 5) @result{} 4 -@end example +@end lisp @end deffn @node Alphabetic Case Mapping @@ -1810,59 +1771,56 @@ the entire string. These are procedures for mapping strings to their upper-- or lower--case equivalents, respectively, or for capitalizing strings. -@c ARGFIXME v/str @c docstring begin (texi-doc-string "guile" "string-upcase!") @deffn primitive string-upcase! str -Destructively upcase every character in @code{str}. - -(qdocs:) Converts each element in @var{str} to upper case. - -@example -(string-upcase! y) -@result{} "ARRDEFG" - -y -@result{} "ARRDEFG" -@end example +Destructively upcase every character in @var{str} and return +@var{str}. +@lisp +y @result{} "arrdefg" +(string-upcase! y) @result{} "ARRDEFG" +y @result{} "ARRDEFG" +@end lisp @end deffn @c docstring begin (texi-doc-string "guile" "string-upcase") @deffn primitive string-upcase str -Upcase every character in @code{str}. +Return a freshly allocated string containing the characters of +@var{str} in upper case. @end deffn -@c ARGFIXME v/str @c docstring begin (texi-doc-string "guile" "string-downcase!") @deffn primitive string-downcase! str -Destructively downcase every character in @code{str}. - -(qdocs:) Converts each element in @var{str} to lower case. - -@example -y -@result{} "ARRDEFG" - -(string-downcase! y) -@result{} "arrdefg" - -y -@result{} "arrdefg" -@end example +Destructively downcase every character in @var{str} and return +@var{str}. +@lisp +y @result{} "ARRDEFG" +(string-downcase! y) @result{} "arrdefg" +y @result{} "arrdefg" +@end lisp @end deffn @c docstring begin (texi-doc-string "guile" "string-downcase") @deffn primitive string-downcase str -Downcase every character in @code{str}. +Return a freshly allocation string containing the characters in +@var{str} in lower case. @end deffn @c docstring begin (texi-doc-string "guile" "string-capitalize!") @deffn primitive string-capitalize! str -Destructively capitalize every character in @code{str}. +Upcase the first character of every word in @var{str} +destructively and return @var{str}. +@lisp +y @result{} "hello world" +(string-capitalize! y) @result{} "Hello World" +y @result{} "Hello World" +@end lisp @end deffn @c docstring begin (texi-doc-string "guile" "string-capitalize") @deffn primitive string-capitalize str -Capitalize every character in @code{str}. +Return a freshly allocated string with the characters in +@var{str}, where the first character of every word is +capitalized. @end deffn @node Appending Strings @@ -1900,7 +1858,9 @@ Vector version of @code{substring-move-right!}. @c docstring begin (texi-doc-string "guile" "string-ci->symbol") @deffn primitive string-ci->symbol str -Return the symbol whose name is @var{str}, downcased in necessary(???). +Return the symbol whose name is @var{str}. @var{str} is +converted to lowercase before the conversion is done, if Guile +is currently reading symbols case--insensitively. @end deffn @@ -1923,16 +1883,15 @@ substring is an object that mostly behaves just like an ordinary substring, except that it actually shares storage space with its parent string. -@c ARGFIXME frm/start to/end @c docstring begin (texi-doc-string "guile" "make-shared-substring") -@deffn primitive make-shared-substring str [frm [to]] -Return a shared substring of @var{str}. The semantics are the same as -for the @code{substring} function: the shared substring returned -includes all of the text from @var{str} between indexes @var{start} -(inclusive) and @var{end} (exclusive). If @var{end} is omitted, it -defaults to the end of @var{str}. The shared substring returned by -@code{make-shared-substring} occupies the same storage space as -@var{str}. +@deffn primitive make-shared-substring str [start [end]] +Return a shared substring of @var{str}. The semantics are the +same as for the @code{substring} function: the shared substring +returned includes all of the text from @var{str} between +indexes @var{start} (inclusive) and @var{end} (exclusive). If +@var{end} is omitted, it defaults to the end of @var{str}. The +shared substring returned by @code{make-shared-substring} +occupies the same storage space as @var{str}. @end deffn Example: @@ -1993,7 +1952,6 @@ and read only strings. Mutable strings answer @code{#t} to @code{string?} while read only strings may or may not. All kinds of strings, whether or not they are mutable return #t to this: -@c ARGFIXME x/obj @c docstring begin (texi-doc-string "guile" "read-only-string?") @deffn primitive read-only-string? obj Return true if @var{obj} can be read as a string, @@ -2001,13 +1959,13 @@ Return true if @var{obj} can be read as a string, This illustrates the difference between @code{string?} and @code{read-only-string?}: -@example +@lisp (string? "a string") @result{} #t (string? 'a-symbol) @result{} #f (read-only-string? "a string") @result{} #t (read-only-string? 'a-symbol) @result{} #t -@end example +@end lisp @end deffn "Read-only" refers to how the string will be used, not how the string is @@ -2085,62 +2043,58 @@ the same regular expression is used several times (for example, in a loop). For better performance, you can compile a regular expression in advance and then match strings against the compiled regexp. -@c ARGFIXME pat/str flags/flag @c docstring begin (texi-doc-string "guile" "make-regexp") @deffn primitive make-regexp pat . flags -Compile the regular expression described by @var{str}, and return the -compiled regexp structure. If @var{str} does not describe a legal -regular expression, @code{make-regexp} throws a -@code{regular-expression-syntax} error. - -The @var{flag} arguments change the behavior of the compiled regexp. -The following flags may be supplied: - +Compile the regular expression described by @var{pat}, and +return the compiled regexp structure. If @var{pat} does not +describe a legal regular expression, @code{make-regexp} throws +a @code{regular-expression-syntax} error. +The @var{flags} arguments change the behavior of the compiled +regular expression. The following flags may be supplied: @table @code @item regexp/icase -Consider uppercase and lowercase letters to be the same when matching. - +Consider uppercase and lowercase letters to be the same when +matching. @item regexp/newline -If a newline appears in the target string, then permit the @samp{^} and -@samp{$} operators to match immediately after or immediately before the -newline, respectively. Also, the @samp{.} and @samp{[^...]} operators -will never match a newline character. The intent of this flag is to -treat the target string as a buffer containing many lines of text, and -the regular expression as a pattern that may match a single one of those -lines. - +If a newline appears in the target string, then permit the +@samp{^} and @samp{$} operators to match immediately after or +immediately before the newline, respectively. Also, the +@samp{.} and @samp{[^...]} operators will never match a newline +character. The intent of this flag is to treat the target +string as a buffer containing many lines of text, and the +regular expression as a pattern that may match a single one of +those lines. @item regexp/basic Compile a basic (``obsolete'') regexp instead of the extended -(``modern'') regexps that are the default. Basic regexps do not -consider @samp{|}, @samp{+} or @samp{?} to be special characters, and -require the @samp{@{...@}} and @samp{(...)} metacharacters to be -backslash-escaped (@pxref{Backslash Escapes}). There are several other -differences between basic and extended regular expressions, but these -are the most significant. - +(``modern'') regexps that are the default. Basic regexps do +not consider @samp{|}, @samp{+} or @samp{?} to be special +characters, and require the @samp{@{...@}} and @samp{(...)} +metacharacters to be backslash-escaped (@pxref{Backslash +Escapes}). There are several other differences between basic +and extended regular expressions, but these are the most +significant. @item regexp/extended -Compile an extended regular expression rather than a basic regexp. This -is the default behavior; this flag will not usually be needed. If a -call to @code{make-regexp} includes both @code{regexp/basic} and -@code{regexp/extended} flags, the one which comes last will override -the earlier one. +Compile an extended regular expression rather than a basic +regexp. This is the default behavior; this flag will not +usually be needed. If a call to @code{make-regexp} includes +both @code{regexp/basic} and @code{regexp/extended} flags, the +one which comes last will override the earlier one. @end table @end deffn -@c ARGFIXME rx/regexp @c docstring begin (texi-doc-string "guile" "regexp-exec") @deffn primitive regexp-exec rx str [start [flags]] -Match the compiled regular expression @var{regexp} against @code{str}. -If the optional integer @var{start} argument is provided, begin matching -from that position in the string. Return a match structure describing -the results of the match, or @code{#f} if no match could be found. +Match the compiled regular expression @var{rx} against +@code{str}. If the optional integer @var{start} argument is +provided, begin matching from that position in the string. +Return a match structure describing the results of the match, +or @code{#f} if no match could be found. @end deffn -@c ARGFIXME x/obj @c docstring begin (texi-doc-string "guile" "regexp?") -@deffn primitive regexp? x -Return @code{#t} if @var{obj} is a compiled regular expression, or -@code{#f} otherwise. +@deffn primitive regexp? obj +Return @code{#t} if @var{obj} is a compiled regular expression, +or @code{#f} otherwise. @end deffn Regular expressions are commonly used to find patterns in one string and @@ -2559,15 +2513,14 @@ table; instead, simply return @code{#f}. @c docstring begin (texi-doc-string "guile" "string->symbol") @deffn primitive string->symbol string -Returns the symbol whose name is @var{string}. This procedure can -create symbols with names containing special characters or letters in -the non-standard case, but it is usually a bad idea to create such -symbols because in some implementations of Scheme they cannot be read as -themselves. See @code{symbol->string}. - +Return the symbol whose name is @var{string}. This procedure +can create symbols with names containing special characters or +letters in the non-standard case, but it is usually a bad idea +to create such symbols because in some implementations of +Scheme they cannot be read as themselves. See +@code{symbol->string}. The following examples assume that the implementation's standard case is lower case: - @lisp (eq? 'mISSISSIppi 'mississippi) @result{} #t (string->symbol "mISSISSIppi") @result{} @r{the symbol with name "mISSISSIppi"} @@ -2582,26 +2535,24 @@ standard case is lower case: @c docstring begin (texi-doc-string "guile" "symbol->string") @deffn primitive symbol->string s -Returns the name of @var{symbol} as a string. If the symbol -was part of an object returned as the value of a literal -expression (section @pxref{Literal expressions,,,r4rs, The -Revised^4 Report on Scheme}) or by a call to the @code{read} -procedure, and its name contains alphabetic characters, then -the string returned will contain characters in the -implementation's preferred standard case---some implementations -will prefer upper case, others lower case. If the symbol was -returned by @code{string->symbol}, the case of characters in -the string returned will be the same as the case in the string -that was passed to @code{string->symbol}. It is an error to -apply mutation procedures like @code{string-set!} to strings -returned by this procedure. (r5rs) - +Return the name of @var{symbol} as a string. If the symbol was +part of an object returned as the value of a literal expression +(section @pxref{Literal expressions,,,r4rs, The Revised^4 +Report on Scheme}) or by a call to the @code{read} procedure, +and its name contains alphabetic characters, then the string +returned will contain characters in the implementation's +preferred standard case---some implementations will prefer +upper case, others lower case. If the symbol was returned by +@code{string->symbol}, the case of characters in the string +returned will be the same as the case in the string that was +passed to @code{string->symbol}. It is an error to apply +mutation procedures like @code{string-set!} to strings returned +by this procedure. The following examples assume that the implementation's standard case is lower case: - @lisp -(symbol->string 'flying-fish) @result{} "flying-fish" -(symbol->string 'Martin) @result{} "martin" +(symbol->string 'flying-fish) @result{} "flying-fish" +(symbol->string 'Martin) @result{} "martin" (symbol->string (string->symbol "Malvina")) @result{} "Malvina" @end lisp @@ -2665,8 +2616,8 @@ in @var{obarray}. @c docstring begin (texi-doc-string "guile" "symbol?") @deffn primitive symbol? obj -Returns @code{#t} if @var{obj} is a symbol, otherwise returns -@code{#f}. (r5rs) +Return @code{#t} if @var{obj} is a symbol, otherwise return +@code{#f}. @end deffn @c docstring begin (texi-doc-string "guile" "unintern-symbol") @@ -2931,7 +2882,8 @@ Make a keyword object from a @var{symbol} that starts with a dash. @c docstring begin (texi-doc-string "guile" "keyword?") @deffn primitive keyword? obj -Returns @code{#t} if the argument @var{obj} is a keyword, else @code{#f}. +Return @code{#t} if the argument @var{obj} is a keyword, else +@code{#f}. @end deffn @c docstring begin (texi-doc-string "guile" "keyword-dash-symbol") @@ -2943,21 +2895,19 @@ This is the inverse of @code{make-keyword-from-dash-symbol}. @node Pairs @section Pairs -@r5index pair? @r5index cons -@r5index set-car! -@r5index set-cdr! - @c docstring begin (texi-doc-string "guile" "cons") @deffn primitive cons x y -Returns a newly allocated pair whose car is @var{x} and whose cdr is -@var{y}. The pair is guaranteed to be different (in the sense of -@code{eqv?}) from every previously existing object. +Return a newly allocated pair whose car is @var{x} and whose +cdr is @var{y}. The pair is guaranteed to be different (in the +sense of @code{eq?}) from every previously existing object. @end deffn +@r5index pair? @c docstring begin (texi-doc-string "guile" "pair?") @deffn primitive pair? x -Returns @code{#t} if @var{x} is a pair; otherwise returns @code{#f}. +Return @code{#t} if @var{x} is a pair; otherwise return +@code{#f}. @end deffn @r5index car @@ -2979,12 +2929,14 @@ for example @code{caddr} could be defined by @end lisp @end deffn +@r5index set-car! @c docstring begin (texi-doc-string "guile" "set-car!") @deffn primitive set-car! pair value Stores @var{value} in the car field of @var{pair}. The value returned by @code{set-car!} is unspecified. @end deffn +@r5index set-cdr! @c docstring begin (texi-doc-string "guile" "set-cdr!") @deffn primitive set-cdr! pair value Stores @var{value} in the cdr field of @var{pair}. The value returned @@ -3042,28 +2994,28 @@ Return the number of elements in list @var{lst}. @deffn primitive append . args Return a list consisting of the elements the lists passed as arguments. -@example +@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 example +@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. -@example +@lisp (append '(a b) '(c . d)) @result{} (a b c . d) (append '() 'a) @result{} a -@end example +@end lisp @end deffn -@c ARGFIXME args ? @c docstring begin (texi-doc-string "guile" "append!") -@deffn primitive append! . args -A destructive version of @code{append} (@pxref{Pairs and Lists,,,r4rs, -The Revised^4 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. +@deffn primitive append! . lists +A destructive version of @code{append} (@pxref{Pairs and +Lists,,,r4rs, The Revised^4 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. @end deffn @c docstring begin (texi-doc-string "guile" "last-pair") @@ -3643,7 +3595,7 @@ sub-system: one vtable-vtable working as the root and one or several "types", each with a set of "instances". (The vtable-vtable should be compared to the class which is the class of itself.) -@example +@lisp (define ball-root (make-vtable-vtable "pr" 0)) (define (make-ball-type ball-color) @@ -3664,7 +3616,7 @@ compared to the class which is the class of itself.) (define ball (make-ball green 'Nisse)) ball @result{} # -@end example +@end lisp @end deffn @c docstring begin (texi-doc-string "guile" "struct-vtable-name") @@ -3738,10 +3690,9 @@ The following procedures can be used with conventional arrays (or vectors). @c docstring begin (texi-doc-string "guile" "array?") @deffn primitive array? v [prot] -Returns @code{#t} if the @var{obj} is an array, and @code{#f} if not. - -The @var{prototype} argument is used with uniform arrays and is described -elsewhere. +Return @code{#t} if the @var{obj} is an array, and @code{#f} if +not. The @var{prototype} argument is used with uniform arrays +and is described elsewhere. @end deffn @deffn procedure make-array initial-value bound1 bound2 @dots{} @@ -3756,12 +3707,14 @@ Creates and returns an array that has as many dimensions as there are @c docstring begin (texi-doc-string "guile" "array-ref") @deffn primitive uniform-vector-ref v args @deffnx primitive array-ref v . args -Returns the element at the @code{(index1, index2)} element in @var{array}. +Return the element at the @code{(index1, index2)} element in +@var{array}. @end deffn @c docstring begin (texi-doc-string "guile" "array-in-bounds?") @deffn primitive array-in-bounds? v . args -Returns @code{#t} if its arguments would be acceptable to array-ref. +Return @code{#t} if its arguments would be acceptable to +@code{array-ref}. @end deffn @c docstring begin (texi-doc-string "guile" "array-set!") @@ -3779,7 +3732,7 @@ arrays. The @var{mapper} is a function that translates coordinates in the new array into coordinates in the old array. A @var{mapper} must be linear, and its range must stay within the bounds of the old array, but it can be otherwise arbitrary. A simple example: -@example +@lisp (define fred (make-array #f 8 8)) (define freds-diagonal (make-shared-array fred (lambda (i) (list i i)) 8)) @@ -3788,7 +3741,7 @@ it can be otherwise arbitrary. A simple example: (define freds-center (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2)) (array-ref freds-center 0 0) @result{} foo -@end example +@end lisp @end deffn @c docstring begin (texi-doc-string "guile" "shared-array-increments") @@ -3808,25 +3761,23 @@ Return the root vector of a shared array. @c docstring begin (texi-doc-string "guile" "transpose-array") @deffn primitive transpose-array ra . args -Returns an array sharing contents with @var{array}, but with dimensions -arranged in a different order. There must be one @var{dim} argument for -each dimension of @var{array}. @var{dim0}, @var{dim1}, @dots{} should -be integers between 0 and the rank of the array to be returned. Each -integer in that range must appear at least once in the argument list. - -The values of @var{dim0}, @var{dim1}, @dots{} correspond to dimensions -in the array to be returned, their positions in the argument list to -dimensions of @var{array}. Several @var{dim}s may have the same value, -in which case the returned array will have smaller rank than -@var{array}. - -examples: -@example +Return an array sharing contents with @var{array}, but with +dimensions arranged in a different order. There must be one +@var{dim} argument for each dimension of @var{array}. +@var{dim0}, @var{dim1}, @dots{} should be integers between 0 +and the rank of the array to be returned. Each integer in that +range must appear at least once in the argument list. +The values of @var{dim0}, @var{dim1}, @dots{} correspond to +dimensions in the array to be returned, their positions in the +argument list to dimensions of @var{array}. Several @var{dim}s +may have the same value, in which case the returned array will +have smaller rank than @var{array}. +@lisp (transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d)) (transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d) (transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{} #2((a 4) (b 5) (c 6)) -@end example +@end lisp @end deffn @c docstring begin (texi-doc-string "guile" "enclose-array") @@ -3845,13 +3796,13 @@ an enclosed array will be @code{equal?} but will not in general be enclosed array is unspecified. examples: -@example +@lisp (enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{} # (enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{} # -@end example +@end lisp @end deffn @deffn procedure array-shape array @@ -3865,20 +3816,21 @@ Returns a list of inclusive bounds of integers. @deffn primitive array-dimensions ra @code{Array-dimensions} is similar to @code{array-shape} but replaces elements with a @code{0} minimum with one greater than the maximum. So: -@example +@lisp (array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5) -@end example +@end lisp @end deffn @c docstring begin (texi-doc-string "guile" "array-rank") @deffn primitive array-rank ra -Returns the number of dimensions of @var{obj}. If @var{obj} is not an -array, @code{0} is returned. +Return the number of dimensions of @var{obj}. If @var{obj} is +not an array, @code{0} is returned. @end deffn @c docstring begin (texi-doc-string "guile" "array->list") @deffn primitive array->list v -Returns a list consisting of all the elements, in order, of @var{array}. +Return a list consisting of all the elements, in order, of +@var{array}. @end deffn @c docstring begin (texi-doc-string "guile" "array-copy!") @@ -3949,19 +3901,19 @@ turn, storing the result in the corresponding element. The value returned and the order of application are unspecified. One can implement @var{array-indexes} as -@example +@lisp (define (array-indexes array) (let ((ra (apply make-array #f (array-shape array)))) (array-index-map! ra (lambda x x)) ra)) -@end example +@end lisp Another example: -@example +@lisp (define (apl:index-generator n) (let ((v (make-uniform-vector n 1))) (array-index-map! v (lambda (i) i)) v)) -@end example +@end lisp @end deffn @node Uniform Arrays @@ -4036,17 +3988,18 @@ and fills it with @var{prototype}. @c docstring begin (texi-doc-string "guile" "array-prototype") @deffn primitive array-prototype ra -Returns an object that would produce an array of the same type as -@var{array}, if used as the @var{prototype} for +Return an object that would produce an array of the same type +as @var{array}, if used as the @var{prototype} for @code{make-uniform-array}. @end deffn @c docstring begin (texi-doc-string "guile" "list->uniform-array") @deffn primitive list->uniform-array ndim prot lst @deffnx procedure list->uniform-vector prot lst -Returns a uniform array of the type indicated by prototype @var{prot} -with elements the same as those of @var{lst}. Elements must be of the -appropriate type, no coercions are done. +Return a uniform array of the type indicated by prototype +@var{prot} with elements the same as those of @var{lst}. +Elements must be of the appropriate type, no coercions are +done. @end deffn @deffn primitive uniform-vector-fill! uve fill @@ -4056,16 +4009,16 @@ unspecified. @c docstring begin (texi-doc-string "guile" "uniform-vector-length") @deffn primitive uniform-vector-length v -Returns the number of elements in @var{uve}. +Return the number of elements in @var{uve}. @end deffn @c docstring begin (texi-doc-string "guile" "dimensions->uniform-array") @deffn primitive dimensions->uniform-array dims prot [fill] @deffnx primitive make-uniform-vector length prototype [fill] -Creates and returns a uniform array or vector of type corresponding to -@var{prototype} with dimensions @var{dims} or length @var{length}. If -@var{fill} is supplied, it's used to fill the array, otherwise -@var{prototype} is used. +Create and return a uniform array or vector of type +corresponding to @var{prototype} with dimensions @var{dims} or +length @var{length}. If @var{fill} is supplied, it's used to +fill the array, otherwise @var{prototype} is used. @end deffn @c Another compiled-closure. -twp @@ -4126,15 +4079,15 @@ They are displayed as a sequence of @code{0}s and @c docstring begin (texi-doc-string "guile" "bit-count") @deffn primitive bit-count b bitvector -Returns the number of occurrences of the boolean @var{b} in +Return the number of occurrences of the boolean @var{b} in @var{bitvector}. @end deffn @c docstring begin (texi-doc-string "guile" "bit-position") @deffn primitive bit-position item v k -Returns the minimum index of an occurrence of @var{bool} in @var{bv} -which is at least @var{k}. If no @var{bool} occurs within the specified -range @code{#f} is returned. +Return the minimum index of an occurrence of @var{bool} in +@var{bv} which is at least @var{k}. If no @var{bool} occurs +within the specified range @code{#f} is returned. @end deffn @c docstring begin (texi-doc-string "guile" "bit-invert!") @@ -4157,10 +4110,10 @@ of @var{bv} corresponding to the indexes in uve are set to @c docstring begin (texi-doc-string "guile" "bit-count*") @deffn primitive bit-count* v kv obj -Returns -@example +Return +@lisp (bit-count (bit-set*! (if bool bv (bit-invert! bv)) uve #t) #t). -@end example +@end lisp @var{bv} is not modified. @end deffn @@ -4648,72 +4601,63 @@ 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. -@c ARGFIXME obj/key @c docstring begin (texi-doc-string "guile" "hashq-ref") -@deffn primitive hashq-ref table obj [dflt] +@deffn primitive 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 -@c ARGFIXME obj/key @c docstring begin (texi-doc-string "guile" "hashv-ref") -@deffn primitive hashv-ref table obj [dflt] +@deffn primitive 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. @end deffn -@c ARGFIXME obj/key @c docstring begin (texi-doc-string "guile" "hash-ref") -@deffn primitive hash-ref table obj [dflt] +@deffn primitive 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 -@c ARGFIXME obj/key @c docstring begin (texi-doc-string "guile" "hashq-set!") -@deffn primitive hashq-set! table obj val +@deffn primitive hashq-set! 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 -@c ARGFIXME obj/key @c docstring begin (texi-doc-string "guile" "hashv-set!") -@deffn primitive hashv-set! table obj val +@deffn primitive hashv-set! table key val Find the entry in @var{table} associated with @var{key}, and store @var{value} there. Uses @code{eqv?} for equality testing. @end deffn -@c ARGFIXME obj/key @c docstring begin (texi-doc-string "guile" "hash-set!") -@deffn primitive hash-set! table obj val +@deffn primitive hash-set! 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 -@c ARGFIXME obj/key @c docstring begin (texi-doc-string "guile" "hashq-remove!") -@deffn primitive hashq-remove! table obj +@deffn primitive hashq-remove! table key Remove @var{key} (and any value associated with it) from @var{table}. Uses @code{eq?} for equality tests. @end deffn -@c ARGFIXME obj/key @c docstring begin (texi-doc-string "guile" "hashv-remove!") -@deffn primitive hashv-remove! table obj +@deffn primitive hashv-remove! table key Remove @var{key} (and any value associated with it) from @var{table}. Uses @code{eqv?} for equality tests. @end deffn -@c ARGFIXME obj/key @c docstring begin (texi-doc-string "guile" "hash-remove!") -@deffn primitive hash-remove! table obj +@deffn primitive hash-remove! table key Remove @var{key} (and any value associated with it) from @var{table}. Uses @code{equal?} for equality tests. @end deffn @@ -4769,69 +4713,60 @@ is used as the equality predicate. The function returns an integer in the range 0 to @var{size} - 1. @end deffn -@c ARGFIXME hash/hasher @c docstring begin (texi-doc-string "guile" "hashx-ref") -@deffn primitive hashx-ref hash assoc table obj [dflt] +@deffn primitive hashx-ref hash assoc table key [dflt] This behaves the same way as the corresponding @code{ref} -function, but uses @var{hasher} as a -hash function and @var{assoc} to compare keys. @code{hasher} 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-ref table key} is equivalent -to @code{hashx-ref hashq assq table key}. +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-ref table key} is +equivalent to @code{hashx-ref hashq assq table key}. @end deffn @c docstring begin (texi-doc-string "guile" "hashx-set!") -@deffn primitive hashx-set! hash assoc table obj val +@deffn primitive hashx-set! hash assoc table key val This behaves the same way as the corresponding @code{set!} -function, but uses @var{hasher} as a -hash function and @var{assoc} to compare keys. @code{hasher} 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}. +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 @c docstring begin (texi-doc-string "guile" "hashq-get-handle") -@deffn primitive hashq-get-handle table obj -This procedure is similar to its @code{-ref} cousin, but returns a -@dfn{handle} from the hash table rather than the value associated with -@var{key}. By convention, a handle in a hash table is the pair which -associates a key with a value. Where @code{hashq-ref table key} returns -only a @code{value}, @code{hashq-get-handle table key} returns the pair -@code{(key . value)}. +@deffn primitive 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 @c docstring begin (texi-doc-string "guile" "hashv-get-handle") -@deffn primitive hashv-get-handle table obj -This procedure is similar to its @code{-ref} cousin, but returns a -@dfn{handle} from the hash table rather than the value associated with -@var{key}. By convention, a handle in a hash table is the pair which -associates a key with a value. Where @code{hashv-ref table key} returns -only a @code{value}, @code{hashv-get-handle table key} returns the pair -@code{(key . value)}. +@deffn primitive 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. @end deffn @c docstring begin (texi-doc-string "guile" "hash-get-handle") -@deffn primitive hash-get-handle table obj -This procedure is similar to its @code{-ref} cousin, but returns a -@dfn{handle} from the hash table rather than the value associated with -@var{key}. By convention, a handle in a hash table is the pair which -associates a key with a value. Where @code{hash-ref table key} returns -only a @code{value}, @code{hash-get-handle table key} returns the pair -@code{(key . value)}. +@deffn primitive 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 @c docstring begin (texi-doc-string "guile" "hashx-get-handle") -@deffn primitive hashx-get-handle hash assoc table obj -This behaves the same way as the corresponding @code{-get-handle} -function, but uses @var{hasher} as a -hash function and @var{assoc} to compare keys. @code{hasher} must -be a function that takes two arguments, a key to be hashed and a +@deffn primitive 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 @@ -4858,11 +4793,11 @@ associates @var{key} with @var{init}. @end deffn @c docstring begin (texi-doc-string "guile" "hashx-create-handle!") -@deffn primitive hashx-create-handle! hash assoc table obj init -This behaves the same way as the corresponding @code{-create-handle} -function, but uses @var{hasher} as a -hash function and @var{assoc} to compare keys. @code{hasher} must -be a function that takes two arguments, a key to be hashed and a +@deffn primitive hashx-create-handle! 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}. @end deffn @@ -4886,9 +4821,10 @@ table into an a-list of key-value pairs. @r5index make-vector @c docstring begin (texi-doc-string "guile" "make-vector") @deffn primitive make-vector k [fill] -Returns a newly allocated vector of @var{k} elements. If a second -argument is given, then each element is initialized to @var{fill}. -Otherwise the initial contents of each element is unspecified. (r5rs) +Return a newly allocated vector of @var{k} elements. If a +second argument is given, then each element is initialized to +@var{fill}. Otherwise the initial contents of each element is +unspecified. @end deffn @r5index vector @@ -4897,20 +4833,18 @@ Otherwise the initial contents of each element is unspecified. (r5rs) @c docstring begin (texi-doc-string "guile" "list->vector") @deffn primitive vector . l @deffnx primitive list->vector l -Returns a newly allocated vector whose elements contain the -given arguments. Analogous to @code{list}. (r5rs) - +Return a newly allocated vector whose elements contain the +given arguments. Analogous to @code{list}. @lisp -(vector 'a 'b 'c) @result{} #(a b c) +(vector 'a 'b 'c) @result{} #(a b c) @end lisp @end deffn @r5index vector->list @c docstring begin (texi-doc-string "guile" "vector->list") @deffn primitive vector->list v -@samp{Vector->list} returns a newly allocated list of the -objects contained in the elements of @var{vector}. (r5rs) - +Return a newly allocated list of the objects contained in the +elements of @var{vector}. @lisp (vector->list '#(dah dah didah)) @result{} (dah dah didah) (list->vector '(dididit dah)) @result{} #(dididit dah) @@ -4918,18 +4852,17 @@ objects contained in the elements of @var{vector}. (r5rs) @end deffn @r5index vector-fill! -@c FIXME::martin: Argument names @c docstring begin (texi-doc-string "guile" "vector-fill!") -@deffn primitive vector-fill! v fill_x -Stores @var{fill} in every element of @var{vector}. -The value returned by @code{vector-fill!} is unspecified. (r5rs) +@deffn primitive vector-fill! v fill +Store @var{fill} in every element of @var{vector}. The value +returned by @code{vector-fill!} is unspecified. @end deffn @r5index vector? @c docstring begin (texi-doc-string "guile" "vector?") @deffn primitive vector? obj -Returns @code{#t} if @var{obj} is a vector, otherwise returns -@code{#f}. (r5rs) +Return @code{#t} if @var{obj} is a vector, otherwise return +@code{#f}. @end deffn @r5index vector-length diff --git a/doc/scheme-evaluation.texi b/doc/scheme-evaluation.texi index 26a3c3238..3509a2ceb 100644 --- a/doc/scheme-evaluation.texi +++ b/doc/scheme-evaluation.texi @@ -123,11 +123,11 @@ environment given by @var{environment specifier}. @r5index interaction-environment @c docstring begin (texi-doc-string "guile" "interaction-environment") @deffn primitive interaction-environment -This procedure returns a specifier for the environment that contains -implementation-defined bindings, typically a superset of those listed in -the report. The intent is that this procedure will return the -environment in which the implementation would evaluate expressions -dynamically typed by the user. +Return a specifier for the environment that contains +implementation--defined bindings, typically a superset of those +listed in the report. The intent is that this procedure will +return the environment in which the implementation would +evaluate expressions dynamically typed by the user. @end deffn @c docstring begin (texi-doc-string "guile" "eval-string") @@ -189,7 +189,6 @@ any code is loaded. See documentation for @code{%load-hook} later in this section. @end deffn -@c ARGFIXME file/filename @c docstring begin (texi-doc-string "guile" "primitive-load") @deffn primitive primitive-load filename Load the file named @var{filename} and evaluate its contents in @@ -201,7 +200,6 @@ that will be called before any code is loaded. See the documentation for @code{%load-hook} later in this section. @end deffn -@c ARGFIXME file/filename @c docstring begin (texi-doc-string "guile" "primitive-load-path") @deffn primitive primitive-load-path filename Search @var{%load-path} for the file named @var{filename} and @@ -210,7 +208,6 @@ relative pathname and is not found in the list of search paths, an error is signalled. @end deffn -@c ARGFIXME file/filename @c docstring begin (texi-doc-string "guile" "%search-load-path") @deffn primitive %search-load-path filename Search @var{%load-path} for the file named @var{filename}, @@ -257,7 +254,6 @@ list @code{("" ".scm")}. [delay] -@c ARGFIXME x/obj @c docstring begin (texi-doc-string "guile" "promise?") @deffn primitive promise? obj Return true if @var{obj} is a promise, i.e. a delayed computation diff --git a/doc/scheme-io.texi b/doc/scheme-io.texi index 0a64c52c7..1da049bcc 100644 --- a/doc/scheme-io.texi +++ b/doc/scheme-io.texi @@ -35,7 +35,7 @@ ports} are two interesting and powerful examples of this technique. @r5index input-port? @c docstring begin (texi-doc-string "guile" "input-port?") @deffn primitive input-port? x -Returns @code{#t} if @var{x} is an input port, otherwise returns +Return @code{#t} if @var{x} is an input port, otherwise return @code{#f}. Any object satisfying this predicate also satisfies @code{port?}. @end deffn @@ -43,14 +43,14 @@ Returns @code{#t} if @var{x} is an input port, otherwise returns @r5index output-port? @c docstring begin (texi-doc-string "guile" "output-port?") @deffn primitive output-port? x -Returns @code{#t} if @var{x} is an output port, otherwise returns +Return @code{#t} if @var{x} is an output port, otherwise return @code{#f}. Any object satisfying this predicate also satisfies @code{port?}. @end deffn @c docstring begin (texi-doc-string "guile" "port?") @deffn primitive port? x -Returns a boolean indicating whether @var{x} is a port. +Return a boolean indicating whether @var{x} is a port. Equivalent to @code{(or (input-port? @var{x}) (output-port? @var{x}))}. @end deffn @@ -64,50 +64,51 @@ Equivalent to @code{(or (input-port? @var{x}) (output-port? @r5index eof-object? @c docstring begin (texi-doc-string "guile" "eof-object?") @deffn primitive eof-object? x -Returns @code{#t} if @var{x} is an end-of-file object; otherwise -returns @code{#f}. +Return @code{#t} if @var{x} is an end-of-file object; otherwise +return @code{#f}. @end deffn @r5index char-ready? @c docstring begin (texi-doc-string "guile" "char-ready?") @deffn primitive char-ready? [port] -Returns @code{#t} if a character is ready on input @var{port} and -returns @code{#f} otherwise. If @code{char-ready?} returns @code{#t} -then the next @code{read-char} operation on @var{port} is -guaranteed not to hang. If @var{port} is a file port at end of -file then @code{char-ready?} returns @code{#t}. +Return @code{#t} if a character is ready on input @var{port} +and return @code{#f} otherwise. If @code{char-ready?} returns +@code{#t} then the next @code{read-char} operation on +@var{port} is guaranteed not to hang. If @var{port} is a file +port at end of file then @code{char-ready?} returns @code{#t}. @footnote{@code{char-ready?} exists to make it possible for a -program to accept characters from interactive ports without getting -stuck waiting for input. Any input editors associated with such ports -must make sure that characters whose existence has been asserted by -@code{char-ready?} cannot be rubbed out. If @code{char-ready?} were to -return @code{#f} at end of file, a port at end of file would be -indistinguishable from an interactive port that has no ready -characters.} +program to accept characters from interactive ports without +getting stuck waiting for input. Any input editors associated +with such ports must make sure that characters whose existence +has been asserted by @code{char-ready?} cannot be rubbed out. +If @code{char-ready?} were to return @code{#f} at end of file, +a port at end of file would be indistinguishable from an +interactive port that has no ready characters.} @end deffn @r5index read-char? @c docstring begin (texi-doc-string "guile" "read-char") @deffn primitive read-char [port] -Returns the next character available from @var{port}, updating +Return the next character available from @var{port}, updating @var{port} to point to the following character. If no more -characters are available, an end-of-file object is returned. +characters are available, the end-of-file object is returned. @end deffn @r5index peek-char? @c docstring begin (texi-doc-string "guile" "peek-char") @deffn primitive peek-char [port] -Returns the next character available from @var{port}, +Return the next character available from @var{port}, @emph{without} updating @var{port} to point to the following -character. If no more characters are available, an end-of-file object -is returned.@footnote{The value returned by a call to @code{peek-char} -is the same as the value that would have been returned by a call to -@code{read-char} on the same port. The only difference is that the very -next call to @code{read-char} or @code{peek-char} on that -@var{port} will return the value returned by the preceding call to -@code{peek-char}. In particular, a call to @code{peek-char} on an -interactive port will hang waiting for input whenever a call to -@code{read-char} would have hung.} +character. If no more characters are available, the +end-of-file object is returned.@footnote{The value returned by +a call to @code{peek-char} is the same as the value that would +have been returned by a call to @code{read-char} on the same +port. The only difference is that the very next call to +@code{read-char} or @code{peek-char} on that @var{port} will +return the value returned by the preceding call to +@code{peek-char}. In particular, a call to @code{peek-char} on +an interactive port will hang waiting for input whenever a call +to @code{read-char} would have hung.} @end deffn @c docstring begin (texi-doc-string "guile" "unread-char") @@ -129,10 +130,9 @@ unread characters will be read again in last-in first-out order. If @c docstring begin (texi-doc-string "guile" "drain-input") @deffn primitive drain-input port Drain @var{port}'s read buffers (including any pushed-back -characters) and returns the content as a single string. +characters) and return the content as a single string. @end deffn -@c ARGFIXME port/input-port @c docstring begin (texi-doc-string "guile" "port-column") @c docstring begin (texi-doc-string "guile" "port-line") @deffn primitive port-column port @@ -147,7 +147,6 @@ because lines and column numbers traditionally start with 1, and that is what non-programmers will find most natural.) @end deffn -@c ARGFIXME port/input-port @c docstring begin (texi-doc-string "guile" "set-port-column!") @c docstring begin (texi-doc-string "guile" "set-port-line!") @deffn primitive set-port-column! port column @@ -267,12 +266,12 @@ all open output ports. The return value is unspecified. @c docstring begin (texi-doc-string "guile" "close-port") @deffn primitive close-port port -Close the specified port object. Returns @code{#t} if it successfully -closes a port or @code{#f} if it was already -closed. An exception may be raised if an error occurs, for example -when flushing buffered output. -See also @ref{Ports and File Descriptors, close}, for a procedure -which can close file descriptors. +Close the specified port object. Return @code{#t} if it +successfully closes a port or @code{#f} if it was already +closed. An exception may be raised if an error occurs, for +example when flushing buffered output. See also @ref{Ports and +File Descriptors, close}, for a procedure which can close file +descriptors. @end deffn @r5index close-input-port @@ -299,21 +298,21 @@ which can close file descriptors. @c docstring begin (texi-doc-string "guile" "port-closed?") @deffn primitive port-closed? port -Returns @code{#t} if @var{port} is closed or @code{#f} if it is open. +Return @code{#t} if @var{port} is closed or @code{#f} if it is +open. @end deffn @node Random Access @section Random Access -@c ARGFIXME object/fd/port @c docstring begin (texi-doc-string "guile" "seek") -@deffn primitive seek object offset whence -Sets the current position of @var{fd/port} to the integer @var{offset}, -which is interpreted according to the value of @var{whence}. - -One of the following variables should be supplied -for @var{whence}: +@deffn primitive seek fd_port offset whence +Sets the current position of @var{fd/port} to the integer +@var{offset}, which is interpreted according to the value of +@var{whence}. +One of the following variables should be supplied for +@var{whence}: @defvar SEEK_SET Seek from the beginning of the file. @end defvar @@ -323,46 +322,40 @@ Seek from the current position. @defvar SEEK_END Seek from the end of the file. @end defvar - -If @var{fd/port} is a file descriptor, the underlying system call is -@code{lseek}. @var{port} may be a string port. - -The value returned is the new position in the file. This means that -the current position of a port can be obtained using: -@smalllisp +If @var{fd/port} is a file descriptor, the underlying system +call is @code{lseek}. @var{port} may be a string port. +The value returned is the new position in the file. This means +that the current position of a port can be obtained using: +@lisp (seek port 0 SEEK_CUR) -@end smalllisp +@end lisp @end deffn -@c ARGFIXME object/fd/port @c docstring begin (texi-doc-string "guile" "fseek") -@deffn primitive fseek object offset whence -Obsolete. Almost the same as seek, above, but the return value is -unspecified. +@deffn primitive fseek fd_port offset whence +Obsolete. Almost the same as @code{seek}, but the return value +is unspecified. @end deffn -@c ARGFIXME object/fd/port @c docstring begin (texi-doc-string "guile" "ftell") -@deffn primitive ftell object -Returns an integer representing the current position of @var{fd/port}, -measured from the beginning. Equivalent to: -@smalllisp +@deffn primitive ftell fd_port +Return an integer representing the current position of +@var{fd/port}, measured from the beginning. Equivalent to: +@lisp (seek port 0 SEEK_CUR) -@end smalllisp +@end lisp @end deffn @findex truncate @findex ftruncate -@c ARGFIXME obj/object size/length @c docstring begin (texi-doc-string "guile" "truncate-file") @deffn primitive truncate-file object [length] -Truncates the object referred to by @var{obj} to at most @var{size} bytes. -@var{obj} can be a string containing a file name or an integer file -descriptor or a port. @var{size} may be omitted if @var{obj} is not -a file name, in which case the truncation occurs at the current port. -position. - -The return value is unspecified. +Truncates the object referred to by @var{object} to at most +@var{length} bytes. @var{object} can be a string containing a +file name or an integer file descriptor or a port. +@var{length} may be omitted if @var{object} is not a file name, +in which case the truncation occurs at the current port. +position. The return value is unspecified. @end deffn @@ -444,21 +437,19 @@ char-set, not a string. @c docstring begin (texi-doc-string "guile" "write-line") @deffn primitive write-line obj [port] -Display @var{obj} and a newline character to @var{port}. If @var{port} -is not specified, @code{(current-output-port)} is used. This function -is equivalent to: - -@smalllisp +Display @var{obj} and a newline character to @var{port}. If +@var{port} is not specified, @code{(current-output-port)} is +used. This function is equivalent to: +@lisp (display obj [port]) (newline [port]) -@end smalllisp +@end lisp @end deffn Some of the abovementioned I/O functions rely on the following C primitives. These will mainly be of interest to people hacking Guile internals. -@c ARGFIXME gobble/gobble? @c docstring begin (texi-doc-string "guile" "%read-delimited!") @deffn primitive %read-delimited! delims str gobble [port [start [end]]] Read characters from @var{port} into @var{str} until one of the @@ -567,16 +558,13 @@ The following procedures are used to open file ports. See also @ref{Ports and File Descriptors, open}, for an interface to the Unix @code{open} system call. -@c ARGFIXME string/filename mode/modes @c docstring begin (texi-doc-string "guile" "open-file") -@deffn primitive open-file filename modes -Open the file whose name is @var{string}, and return a port +@deffn primitive open-file filename mode +Open the file whose name is @var{filename}, and return a port representing that file. The attributes of the port are -determined by the @var{mode} string. The way in -which this is interpreted is similar to C stdio: - -The first character must be one of the following: - +determined by the @var{mode} string. The way in which this is +interpreted is similar to C stdio. The first character must be +one of the following: @table @samp @item r Open an existing file for input. @@ -584,34 +572,31 @@ Open an existing file for input. Open a file for output, creating it if it doesn't already exist or removing its contents if it does. @item a -Open a file for output, creating it if it doesn't already exist. -All writes to the port will go to the end of the file. +Open a file for output, creating it if it doesn't already +exist. All writes to the port will go to the end of the file. The "append mode" can be turned off while the port is in use @pxref{Ports and File Descriptors, fcntl} @end table - The following additional characters can be appended: - @table @samp @item + Open the port for both input and output. E.g., @code{r+}: open an existing file for both input and output. @item 0 -Create an "unbuffered" port. In this case input and output operations -are passed directly to the underlying port implementation without -additional buffering. This is likely to slow down I/O operations. -The buffering mode can be changed while a port is in use -@pxref{Ports and File Descriptors, setvbuf} +Create an "unbuffered" port. In this case input and output +operations are passed directly to the underlying port +implementation without additional buffering. This is likely to +slow down I/O operations. The buffering mode can be changed +while a port is in use @pxref{Ports and File Descriptors, +setvbuf} @item l Add line-buffering to the port. The port output buffer will be automatically flushed whenever a newline character is written. @end table - -In theory we could create read/write ports which were buffered in one -direction only. However this isn't included in the current interfaces. - -If a file cannot be opened with the access requested, -@code{open-file} throws an exception. +In theory we could create read/write ports which were buffered +in one direction only. However this isn't included in the +current interfaces. If a file cannot be opened with the access +requested, @code{open-file} throws an exception. @end deffn @r5index open-input-file @@ -742,12 +727,11 @@ port. When the function returns, the string composed of the characters written into the port is returned. @end deffn -@c ARGFIXME str/string @c docstring begin (texi-doc-string "guile" "call-with-input-string") -@deffn primitive call-with-input-string str proc -Calls the one-argument procedure @var{proc} with a newly created input -port from which @var{string}'s contents may be read. The value yielded -by the @var{proc} is returned. +@deffn primitive call-with-input-string string proc +Calls the one-argument procedure @var{proc} with a newly +created input port from which @var{string}'s contents may be +read. The value yielded by the @var{proc} is returned. @end deffn @c begin (scm-doc-string "r4rs.scm" "with-output-to-string") @@ -766,15 +750,15 @@ port set temporarily to a string port opened on the specified @c docstring begin (texi-doc-string "guile" "open-input-string") @deffn primitive open-input-string str -Takes a string and returns an input port that delivers -characters from the string. The port can be closed by +Take a string and return an input port that delivers characters +from the string. The port can be closed by @code{close-input-port}, though its storage will be reclaimed by the garbage collector if it becomes inaccessible. @end deffn @c docstring begin (texi-doc-string "guile" "open-output-string") @deffn primitive open-output-string -Returns an output port that will accumulate characters for +Return an output port that will accumulate characters for retrieval by @code{get-output-string}. The port can be closed by the procedure @code{close-output-port}, though its storage will be reclaimed by the garbage collector if it becomes @@ -784,7 +768,7 @@ inaccessible. @c docstring begin (texi-doc-string "guile" "get-output-string") @deffn primitive get-output-string port Given an output port created by @code{open-output-string}, -returns a string consisting of the characters that have been +return a string consisting of the characters that have been output to the port so far. @end deffn @@ -800,14 +784,12 @@ but trying to extract the file descriptor number will fail. A @dfn{soft-port} is a port based on a vector of procedures capable of accepting or delivering characters. It allows emulation of I/O ports. -@c ARGFIXME pv/vector @c docstring begin (texi-doc-string "guile" "make-soft-port") @deffn primitive make-soft-port pv modes -Returns a port capable of receiving or delivering characters as +Return a port capable of receiving or delivering characters as specified by the @var{modes} string (@pxref{File Ports, -open-file}). @var{vector} must be a vector of length 6. Its components -are as follows: - +open-file}). @var{pv} must be a vector of length 5. Its +components are as follows: @enumerate 0 @item procedure accepting one character for output @@ -820,17 +802,15 @@ thunk for getting one character @item thunk for closing port (not by garbage collection) @end enumerate - For an output-only port only elements 0, 1, 2, and 4 need be -procedures. For an input-only port only elements 3 and 4 need be -procedures. Thunks 2 and 4 can instead be @code{#f} if there is no useful -operation for them to perform. - -If thunk 3 returns @code{#f} or an @code{eof-object} (@pxref{Input, -eof-object?, ,r4rs, The Revised^4 Report on Scheme}) it indicates that -the port has reached end-of-file. For example: - -@example +procedures. For an input-only port only elements 3 and 4 need +be procedures. Thunks 2 and 4 can instead be @code{#f} if +there is no useful operation for them to perform. +If thunk 3 returns @code{#f} or an @code{eof-object} +(@pxref{Input, eof-object?, ,r4rs, The Revised^4 Report on +Scheme}) it indicates that the port has reached end-of-file. +For example: +@lisp (define stdout (current-output-port)) (define p (make-soft-port (vector @@ -840,9 +820,8 @@ the port has reached end-of-file. For example: (lambda () (char-upcase (read-char))) (lambda () (display "@@" stdout))) "rw")) - (write p p) @result{} # -@end example +@end lisp @end deffn diff --git a/doc/scheme-memory.texi b/doc/scheme-memory.texi index b01d7915d..71b3f23e4 100644 --- a/doc/scheme-memory.texi +++ b/doc/scheme-memory.texi @@ -23,7 +23,8 @@ no longer accessible. @c docstring begin (texi-doc-string "guile" "gc-stats") @deffn primitive gc-stats -Returns an association list of statistics about Guile's current use of storage. +Return an association list of statistics about Guile's current +use of storage. @end deffn @c docstring begin (texi-doc-string "guile" "object-address") @@ -87,21 +88,19 @@ they constitute a doubly-weak table has to be used. @node Weak key hashes @subsection Weak key hashes -@c ARGFIXME k/size @c docstring begin (texi-doc-string "guile" "make-weak-key-hash-table") -@deffn primitive make-weak-key-hash-table k +@deffn primitive make-weak-key-hash-table size @deffnx primitive make-weak-value-hash-table size @deffnx primitive make-doubly-weak-hash-table size -Return a weak hash table with @var{size} buckets. As with any hash -table, choosing a good size for the table requires some caution. - -You can modify weak hash tables in exactly the same way you would modify -regular hash tables. (@pxref{Hash Tables}) +Return a weak hash table with @var{size} buckets. As with any +hash table, choosing a good size for the table requires some +caution. +You can modify weak hash tables in exactly the same way you +would modify regular hash tables. (@pxref{Hash Tables}) @end deffn -@c ARGFIXME x/obj @c docstring begin (texi-doc-string "guile" "weak-key-hash-table?") -@deffn primitive weak-key-hash-table? x +@deffn primitive weak-key-hash-table? obj @deffnx primitive weak-value-hash-table? obj @deffnx primitive doubly-weak-hash-table? obj Return @code{#t} if @var{obj} is the specified weak hash @@ -132,28 +131,26 @@ nor a weak value hash table. Weak vectors are mainly useful in Guile's implementation of weak hash tables. -@c ARGFIXME k/size @c docstring begin (texi-doc-string "guile" "make-weak-vector") -@deffn primitive make-weak-vector k [fill] +@deffn primitive make-weak-vector size [fill] Return a weak vector with @var{size} elements. If the optional -argument @var{fill} is given, all entries in the vector will be set to -@var{fill}. The default value for @var{fill} is the empty list. +argument @var{fill} is given, all entries in the vector will be +set to @var{fill}. The default value for @var{fill} is the +empty list. @end deffn -@c NJFIXME should vector->list here be list->vector ? @c docstring begin (texi-doc-string "guile" "weak-vector") @c docstring begin (texi-doc-string "guile" "list->weak-vector") @deffn primitive weak-vector . l @deffnx primitive list->weak-vector l -Construct a weak vector from a list: @code{weak-vector} uses the list of -its arguments while @code{list->weak-vector} uses its only argument -@var{l} (a list) to construct a weak vector the same way -@code{vector->list} would. +Construct a weak vector from a list: @code{weak-vector} uses +the list of its arguments while @code{list->weak-vector} uses +its only argument @var{l} (a list) to construct a weak vector +the same way @code{list->vector} would. @end deffn -@c ARGFIXME x/obj @c docstring begin (texi-doc-string "guile" "weak-vector?") -@deffn primitive weak-vector? x +@deffn primitive weak-vector? obj Return @code{#t} if @var{obj} is a weak vector. Note that all weak hashes are also weak vectors. @end deffn diff --git a/doc/scheme-modules.texi b/doc/scheme-modules.texi index 32b700cc0..3a2374329 100644 --- a/doc/scheme-modules.texi +++ b/doc/scheme-modules.texi @@ -182,12 +182,12 @@ written properly. Guile's dynamic linking functions make it relatively easy to write a module that incorporates code from third-party object code libraries. -@c ARGFIXME fname/library-file @c docstring begin (texi-doc-string "guile" "dynamic-link") -@deffn primitive dynamic-link fname -Open the dynamic library @var{library-file}. A library handle -representing the opened library is returned; this handle should be used -as the @var{lib} argument to the following functions. +@deffn primitive dynamic-link filename +Open the dynamic library called @var{filename}. A library +handle representing the opened library is returned; this handle +should be used as the @var{dobj} argument to the following +functions. @end deffn @c docstring begin (texi-doc-string "guile" "dynamic-object?") @@ -196,19 +196,14 @@ Return @code{#t} if @var{obj} is a dynamic library handle, or @code{#f} otherwise. @end deffn -@c ARGFIXME dobj/dynobj/library-handle @c docstring begin (texi-doc-string "guile" "dynamic-unlink") @deffn primitive dynamic-unlink dobj -Unlink the library represented by @var{library-handle}, -and remove any imported symbols from the address space. -GJB:FIXME:DOC: 2nd version below: Unlink the indicated object file from the application. The -argument @var{dynobj} must have been obtained by a call to +argument @var{dobj} must have been obtained by a call to @code{dynamic-link}. After @code{dynamic-unlink} has been -called on @var{dynobj}, its content is no longer accessible. +called on @var{dobj}, its content is no longer accessible. @end deffn -@c ARGFIXME symb/func/function dobj/lib/dynobj @c docstring begin (texi-doc-string "guile" "dynamic-func") @deffn primitive dynamic-func name dobj Search the dynamic object @var{dobj} for the C function @@ -222,54 +217,37 @@ underscore in @var{function}. Guile knows whether the underscore is needed or not and will add it when necessary. @end deffn -@c ARGFIXME lib-thunk/func/function lib/dobj/dynobj @c docstring begin (texi-doc-string "guile" "dynamic-call") @deffn primitive dynamic-call func dobj -Call @var{lib-thunk}, a procedure of no arguments. If @var{lib-thunk} -is a string, it is assumed to be a symbol found in the dynamic library -@var{lib} and is fetched with @code{dynamic-func}. Otherwise, it should -be a function handle returned by a previous call to @code{dynamic-func}. -The return value is unspecified. -GJB:FIXME:DOC 2nd version below -Call the C function indicated by @var{function} and @var{dynobj}. The -function is passed no arguments and its return value is ignored. When -@var{function} is something returned by @code{dynamic-func}, call that -function and ignore @var{dynobj}. When @var{function} is a string (or -symbol, etc.), look it up in @var{dynobj}; this is equivalent to - +Call the C function indicated by @var{func} and @var{dobj}. +The function is passed no arguments and its return value is +ignored. When @var{function} is something returned by +@code{dynamic-func}, call that function and ignore @var{dobj}. +When @var{func} is a string , look it up in @var{dynobj}; this +is equivalent to @smallexample -(dynamic-call (dynamic-func @var{function} @var{dynobj} #f)) +(dynamic-call (dynamic-func @var{func} @var{dobj} #f)) @end smallexample Interrupts are deferred while the C function is executing (with @code{SCM_DEFER_INTS}/@code{SCM_ALLOW_INTS}). @end deffn -@c ARGFIXME func/proc/function dobj/dynobj @c docstring begin (texi-doc-string "guile" "dynamic-args-call") @deffn primitive dynamic-args-call func dobj args -Call @var{proc}, a dynamically loaded function, passing it the argument -list @var{args} (a list of strings). As with @code{dynamic-call}, -@var{proc} should be either a function handle or a string, in which case -it is first fetched from @var{lib} with @code{dynamic-func}. - -@var{proc} is assumed to return an integer, which is used as the return -value from @code{dynamic-args-call}. - -GJB:FIXME:DOC 2nd version below -Call the C function indicated by @var{function} and @var{dynobj}, just -like @code{dynamic-call}, but pass it some arguments and return its -return value. The C function is expected to take two arguments and -return an @code{int}, just like @code{main}: - +Call the C function indicated by @var{func} and @var{dobj}, +just like @code{dynamic-call}, but pass it some arguments and +return its return value. The C function is expected to take +two arguments and return an @code{int}, just like @code{main}: @smallexample int c_func (int argc, char **argv); @end smallexample -The parameter @var{args} must be a list of strings and is converted into -an array of @code{char *}. The array is passed in @var{argv} and its -size in @var{argc}. The return value is converted to a Scheme number -and returned from the call to @code{dynamic-args-call}. +The parameter @var{args} must be a list of strings and is +converted into an array of @code{char *}. The array is passed +in @var{argv} and its size in @var{argc}. The return value is +converted to a Scheme number and returned from the call to +@code{dynamic-args-call}. @end deffn @c docstring begin (texi-doc-string "guile" "c-registered-modules") diff --git a/doc/scheme-options.texi b/doc/scheme-options.texi index 65e85ba61..439b8c452 100644 --- a/doc/scheme-options.texi +++ b/doc/scheme-options.texi @@ -284,11 +284,11 @@ Guile's configuration at run time. Return a string describing Guile's version number, or its major or minor version numbers, respectively. -@example +@lisp (version) @result{} "1.3a" (major-version) @result{} "1" (minor-version) @result{} "3a" -@end example +@end lisp @end deffn @c NJFIXME not in libguile! diff --git a/doc/scheme-procedures.texi b/doc/scheme-procedures.texi index 38ef59256..885d2f966 100644 --- a/doc/scheme-procedures.texi +++ b/doc/scheme-procedures.texi @@ -128,45 +128,44 @@ or Aubrey for help. -twp] @c docstring begin (texi-doc-string "guile" "procedure->syntax") @deffn primitive procedure->syntax code -Returns a @dfn{macro} which, when a symbol defined to this value -appears as the first symbol in an expression, returns the result -of applying @var{code} to the expression and the environment. +Return a @dfn{macro} which, when a symbol defined to this value +appears as the first symbol in an expression, returns the +result of applying @var{code} to the expression and the +environment. @end deffn @c docstring begin (texi-doc-string "guile" "procedure->macro") @deffn primitive procedure->macro code -Returns a @dfn{macro} which, when a symbol defined to this value -appears as the first symbol in an expression, evaluates the result -of applying @var{code} to the expression and the environment. -The value returned from @var{code} which has been passed to -@code{procedure->memoizing-macro} replaces the form passed to -@var{code}. For example: - -@example +Return a @dfn{macro} which, when a symbol defined to this value +appears as the first symbol in an expression, evaluates the +result of applying @var{code} to the expression and the +environment. The value returned from @var{code} which has been +passed to @code{procedure->memoizing-macro} replaces the form +passed to @var{code}. For example: +@lisp (define trace (procedure->macro (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x)))))) (trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})). -@end example +@end lisp @end deffn @c docstring begin (texi-doc-string "guile" "procedure->memoizing-macro") @deffn primitive procedure->memoizing-macro code -Returns a @dfn{macro} which, when a symbol defined to this value -appears as the first symbol in an expression, evaluates the result -of applying @var{proc} to the expression and the environment. -The value returned from @var{proc} which has been passed to -@code{procedure->memoizing-macro} replaces the form passed to -@var{proc}. For example: - -@example +Return a @dfn{macro} which, when a symbol defined to this value +appears as the first symbol in an expression, evaluates the +result of applying @var{proc} to the expression and the +environment. The value returned from @var{proc} which has been +passed to @code{procedure->memoizing-macro} replaces the form +passed to @var{proc}. For example: +@lisp (define trace (procedure->macro (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x)))))) (trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})). -@end example +@end lisp @end deffn @c docstring begin (texi-doc-string "guile" "macro?") @@ -175,13 +174,13 @@ Return @code{#t} if @var{obj} is a regular macro, a memoizing macro or a syntax transformer. @end deffn -@c ARGFIXME m/obj @c docstring begin (texi-doc-string "guile" "macro-type") @deffn primitive macro-type m -Return one of the symbols @code{syntax}, @code{macro} or @code{macro!}, -depending on whether @var{obj} is a syntax tranformer, a regular macro, -or a memoizing macro, respectively. If @var{obj} is not a macro, -@code{#f} is returned. +Return one of the symbols @code{syntax}, @code{macro} or +@code{macro!}, depending on whether @var{m} is a syntax +tranformer, a regular macro, or a memoizing macro, +respectively. If @var{m} is not a macro, @code{#f} is +returned. @end deffn @c docstring begin (texi-doc-string "guile" "macro-name") diff --git a/doc/scheme-scheduling.texi b/doc/scheme-scheduling.texi index 89ce8a4f7..c9756eb33 100644 --- a/doc/scheme-scheduling.texi +++ b/doc/scheme-scheduling.texi @@ -123,7 +123,7 @@ Before calling @var{thunk}, the dynamic-wind chain is un-wound back to the root and a new chain started for @var{thunk}. Therefore, this call may not do what you expect: -@example +@lisp ;; Almost certainly a bug: (with-output-to-port some-port @@ -134,7 +134,7 @@ may not do what you expect: (display 'fnord) (newline)) (lambda (errcode) errcode)))) -@end example +@end lisp The problem is, on what port will @samp{fnord} be displayed? You might expect that because of the @code{with-output-to-port} that @@ -353,13 +353,15 @@ in its own dynamic root, you can use fluids for thread local storage. @c docstring begin (texi-doc-string "guile" "fluid?") @deffn primitive fluid? obj -Return #t iff @var{obj} is a fluid; otherwise, return #f. +Return @code{#t} iff @var{obj} is a fluid; otherwise, return +@code{#f}. @end deffn @c docstring begin (texi-doc-string "guile" "fluid-ref") @deffn primitive fluid-ref fluid -Return the value associated with @var{fluid} in the current dynamic root. -If @var{fluid} has not been set, then this returns #f. +Return the value associated with @var{fluid} in the current +dynamic root. If @var{fluid} has not been set, then return +@code{#f}. @end deffn @c docstring begin (texi-doc-string "guile" "fluid-set!") diff --git a/doc/scheme-utility.texi b/doc/scheme-utility.texi index 2bf1dfd0d..df2da008a 100644 --- a/doc/scheme-utility.texi +++ b/doc/scheme-utility.texi @@ -66,9 +66,8 @@ a property list associated with a procedure object, use the Return @var{obj}'s property list. @end deffn -@c ARGFIXME alist/plist @c docstring begin (texi-doc-string "guile" "set-object-properties!") -@deffn primitive set-object-properties! obj plist +@deffn primitive set-object-properties! obj alist @deffnx primitive set-procedure-properties! obj alist Set @var{obj}'s property list to @var{alist}. @end deffn @@ -79,12 +78,11 @@ Set @var{obj}'s property list to @var{alist}. Return the property of @var{obj} with name @var{key}. @end deffn -@c ARGFIXME val/value @c docstring begin (texi-doc-string "guile" "set-object-property!") -@deffn primitive set-object-property! obj key val +@deffn primitive set-object-property! obj key value @deffnx primitive set-procedure-property! obj key value -In @var{obj}'s property list, set the property named @var{key} to -@var{value}. +In @var{obj}'s property list, set the property named @var{key} +to @var{value}. @end deffn [Interface bug: there should be a second level of interface in which From 1e6808ea204cef454e41af1e2f309100ab99e9e1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Tue, 3 Apr 2001 13:19:05 +0000 Subject: [PATCH 0786/2047] Correct, update, improve and clean up a lot of docstrings in order to make the documentation much more consistent. --- libguile/ChangeLog | 106 +++++++++++++++++++++++ libguile/dynl.c | 67 ++++++--------- libguile/dynwind.c | 54 ++++++------ libguile/environments.c | 8 +- libguile/error.c | 31 ++++--- libguile/filesys.c | 59 +++++++------ libguile/fluids.c | 8 +- libguile/fports.c | 57 +++++++------ libguile/gc.c | 17 ++-- libguile/hashtab.c | 108 +++++++++++++----------- libguile/ioext.c | 46 +++++----- libguile/keywords.c | 3 +- libguile/list.c | 33 ++++---- libguile/macros.c | 58 +++++++------ libguile/modules.c | 10 +-- libguile/net_db.c | 42 ++++----- libguile/numbers.c | 161 +++++++++++++++++------------------ libguile/objprop.c | 20 ++--- libguile/pairs.c | 9 +- libguile/ports.c | 159 +++++++++++++++++----------------- libguile/posix.c | 183 ++++++++++++++++++++-------------------- libguile/ramap.c | 19 +++-- libguile/random.c | 16 ++-- libguile/rdelim.c | 10 +-- libguile/regex-posix.c | 74 ++++++++-------- libguile/root.c | 4 +- libguile/simpos.c | 12 +-- libguile/socket.c | 124 ++++++++++++++------------- libguile/stime.c | 52 +++++++----- libguile/strings.c | 32 +++---- libguile/strop.c | 68 +++++++-------- libguile/strorder.c | 66 +++++++-------- libguile/strports.c | 18 ++-- libguile/struct.c | 4 +- libguile/symbols.c | 56 ++++++------ libguile/throw.c | 52 ++++++------ libguile/unif.c | 98 +++++++++++---------- libguile/vectors.c | 35 ++++---- libguile/version.c | 4 +- libguile/vports.c | 32 ++++--- libguile/weaks.c | 67 ++++++++------- 41 files changed, 1133 insertions(+), 949 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 2be583b3f..912745364 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,109 @@ +2001-04-03 Martin Grabmueller + + The following changes make the documentation more consistent. + + * rdelim.c (scm_write_line), posix.c (scm_utime), ports.c + (scm_seek), net_db.c (scm_inet_aton, scm_inet_ntoa), + (scm_inet_netof, scm_lnaof, scm_inet_makeaddr), ioext.c + (scm_ftell): Changed @smalllisp ... @end smalllisp to @lisp + ... @end lisp. + + * vports.c (scm_make_soft_port), version.c (scm_version), unif.c + (scm_array_dimensions, scm_make_shared_array), + (scm_transpose_array, scm_enclose_array, scm_bit_count_star), + throw.c (scm_catch), struct.c (scm_make_vtable_vtable), strop.c + (scm_string_rindex, scm_string_index, scm_substring_fill_x), + (scm_string_null_p), strings.c (scm_read_only_string_p), root.c + (scm_call_with_dynamic_root), ramap.c (scm_array_index_map_x), + posix.c (scm_mknod), numbers.c (scm_logtest, scm_logbit_p), + macros.c (scm_makmmacro), list.c (scm_append), environments.c + (scm_environment_fold), dynwind.c (s_scm_dynamic_wind): Changed + @example ... @end example to @lisp ... @end lisp. + + * weaks.c (scm_weak_vector): Corrected docstring. + + * hashtab.c (scm_hashq_ref, scm_hashq_set_x, scm_hashq_remove_x), + (scm_hashv_ref, scm_hashv_set_x, scm_hashv_remove_x), + (scm_hash_ref, scm_hash_set_x, scm_hash_remove_x, scm_hashx_ref), + (scm_hashx_set_x, scm_hashx_get_handle), + (scm_hashx_create_handle_x), regex-posix.c (scm_make_regexp), + (scm_regexp_exec, scm_regexp_p), numbers.c (scm_logtest), + vectors.c (scm_vector_fill_x), strings.c + (scm_make_shared_substring), symbols.c (scm_string_to_symbol), + objprop.c (scm_set_object_properties_x): + (scm_set_object_property_x), throw.c (scm_catch, scm_lazy_catch), + strports.c (scm_call_with_input_string), ports.c + (scm_truncate_file), ioext.c (scm_ftell), ports.c (scm_seek), + list.c (scm_append_x), dynwind.c (scm_dynamic_wind), error.c + (scm_error_scm), vports.c (scm_make_soft_port), weaks.c + (scm_make_weak_vector,scm_weak_vector_p), + (scm_make_weak_key_hash_table, scm_make_weak_value_hash_table), + (scm_make_doubly_weak_hash_table, scm_weak_key_hash_table_p), + (scm_weak_value_hash_table_p, scm_doubly_weak_hash_table_p), + macros.c (scm_macro_type), dynl.c (scm_dynamic_link), + (scm_dynamic_unlink, scm_dynamic_call, scm_dynamic_args_call): + Made parameter names match documentation by renaming parameters + and/or fixing docstrings. + + * numbers.c (scm_ash): Corrected Texinfo markup. + + * strop.c (scm_string_index, scm_string_rindex), + (scm_substring_fill_x, scm_string_null_p): Removed `qdocs'. + + * vports.c (scm_make_soft_port), unif.c + (scm_uniform_vector_length, scm_array_p, scm_array_rank), + (scm_dimensions_to_uniform_array, scm_transpose_array), + (scm_array_in_bounds_p, scm_uniform_vector_ref), + (scm_bit_count, scm_bit_position, scm_bit_count_star), + (scm_array_to_list, scm_list_to_uniform_array), + (scm_array_prototype, symbols.c (scm_string_to_symbol), strports.c + (scm_open_input_string, scm_open_output_string), + (scm_get_output_string), strop.c (scm_string_copy), + (scm_string_fill_x), strings.c (scm_string_p, scm_string), stime.c + (scm_get_internal_real_time, scm_times), + (scm_get_internal_run_time, scm_current_time, scm_gettimeofday), + (scm_localtime, scm_gmtime), socket.c (scm_htons, scm_ntohs), + (scm_htonl, scm_ntohl, scm_socket, scm_socketpair), + (scm_getsockopt, scm_getsockname, scm_getpeername, scm_recvfrom), + simpos.c (scm_system), random.c (scm_random_uniform), + (scm_random_normal, scm_random_exp), ramap.c + (scm_array_equal_p), posix.c (scm_pipe, scm_getgroups), + (scm_status_exit_val, scm_status_term_sig, scm_status_stop_sig), + (scm_getppid, scm_getuid, scm_getgid, scm_geteuid, scm_getegid), + (scm_getpgrp, scm_ttyname, scm_ctermid, scm_tcgetpgrp, scm_uname), + (scm_environ, scm_tmpnam, scm_mkstemp, scm_access, scm_getpid), + (scm_setlocale), ports.c (scm_char_ready_p, scm_drain_input), + (scm_pt_size, scm_pt_member, scm_port_revealed, scm_port_mode), + (scm_close_port, scm_input_port_p, scm_output_port_p, scm_port_p), + (scm_port_closed_p, scm_eof_object_p, scm_read_char), + (scm_peek_char), pairs.c (scm_pair_p, scm_cons), numbers.c + (scm_logand, scm_logior, scm_logxor, scm_lognot), + (scm_integer_expt, scm_bit_extract, scm_logcount), + (scm_integer_length, scm_string_to_number, scm_inexact_to_exact), + net_db.c (scm_inet_netof, scm_lnaof), modules.c + (scm_interaction_environment), macros.c (scm_makacro), + (scm_makmacro, scm_makmmacro), keywords.c (scm_keyword_p), ioext.c + (scm_ftell, scm_dup_to_fdes, scm_fileno, scm_isatty_p), + (scm_fdopen, scm_fdes_to_ports), gc.c (scm_gc_stats), fluids.c + (scm_fluid_ref), filesys.c (scm_open_fdes), + (scm_stat, scm_directory_stream_p, scm_getcwd, scm_readlink): + Docstring correction: `Returns' -> `Return' + + * gc.c (scm_set_debug_cell_accesses_x): + (s_scm_gc_set_debug_check_freelist_x): + * fluids.c (scm_fluid_p): Added texinfo markup. + + * error.c (scm_strerror): Made docstring more precise. + + * vectors.c (scm_vector_p, scm_vector, scm_make_vector), + (scm_vector_to_list, _scm_vector_fill_x), symbols.c + (scm_symbol_p, scm_symbol_to_string), strorder.c + (scm_string_equal_p, scm_string_ci_equal_p, scm_string_less_p), + (scm_string_leq_p, scm_string_gr_p, scm_string_geq_p), + (scm_string_ci_less_p, scm_string_ci_leq_p, scm_string_ci_gr_p): + (scm_string_ci_geq_p), strop.c (scm_string_copy), + (scm_string_fill_x): Removed `(r5rs)' from docstrings. + 2001-04-01 Dirk Herrmann * gc.c (MARK): Re-introduce a cheap sanity test for non debug diff --git a/libguile/dynl.c b/libguile/dynl.c index 1fa856cc6..e46866beb 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -350,18 +350,19 @@ dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate) SCM_DEFINE (scm_dynamic_link, "dynamic-link", 1, 0, 0, - (SCM fname), - "Open the dynamic library @var{library-file}. A library handle\n" - "representing the opened library is returned; this handle should be used\n" - "as the @var{lib} argument to the following functions.") + (SCM filename), + "Open the dynamic library called @var{filename}. A library\n" + "handle representing the opened library is returned; this handle\n" + "should be used as the @var{dobj} argument to the following\n" + "functions.") #define FUNC_NAME s_scm_dynamic_link { void *handle; - SCM_VALIDATE_STRING (1, fname); - SCM_STRING_COERCE_0TERMINATION_X (fname); - handle = sysdep_dynl_link (SCM_STRING_CHARS (fname), FUNC_NAME); - SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj, SCM_UNPACK (fname), handle); + SCM_VALIDATE_STRING (1, filename); + SCM_STRING_COERCE_0TERMINATION_X (filename); + handle = sysdep_dynl_link (SCM_STRING_CHARS (filename), FUNC_NAME); + SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj, SCM_UNPACK (filename), handle); } #undef FUNC_NAME @@ -379,13 +380,10 @@ SCM_DEFINE (scm_dynamic_object_p, "dynamic-object?", 1, 0, 0, SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0, (SCM dobj), - "Unlink the library represented by @var{library-handle},\n" - "and remove any imported symbols from the address space.\n" - "GJB:FIXME:DOC: 2nd version below:\n" "Unlink the indicated object file from the application. The\n" - "argument @var{dynobj} must have been obtained by a call to\n" + "argument @var{dobj} must have been obtained by a call to\n" "@code{dynamic-link}. After @code{dynamic-unlink} has been\n" - "called on @var{dynobj}, its content is no longer accessible.") + "called on @var{dobj}, its content is no longer accessible.") #define FUNC_NAME s_scm_dynamic_unlink { /*fixme* GC-problem */ @@ -442,19 +440,14 @@ SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0, SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0, (SCM func, SCM dobj), - "Call @var{lib-thunk}, a procedure of no arguments. If @var{lib-thunk}\n" - "is a string, it is assumed to be a symbol found in the dynamic library\n" - "@var{lib} and is fetched with @code{dynamic-func}. Otherwise, it should\n" - "be a function handle returned by a previous call to @code{dynamic-func}.\n" - "The return value is unspecified.\n" - "GJB:FIXME:DOC 2nd version below\n" - "Call the C function indicated by @var{function} and @var{dynobj}. The\n" - "function is passed no arguments and its return value is ignored. When\n" - "@var{function} is something returned by @code{dynamic-func}, call that\n" - "function and ignore @var{dynobj}. When @var{function} is a string (or\n" - "symbol, etc.), look it up in @var{dynobj}; this is equivalent to\n\n" + "Call the C function indicated by @var{func} and @var{dobj}.\n" + "The function is passed no arguments and its return value is\n" + "ignored. When @var{function} is something returned by\n" + "@code{dynamic-func}, call that function and ignore @var{dobj}.\n" + "When @var{func} is a string , look it up in @var{dynobj}; this\n" + "is equivalent to\n" "@smallexample\n" - "(dynamic-call (dynamic-func @var{function} @var{dynobj} #f))\n" + "(dynamic-call (dynamic-func @var{func} @var{dobj} #f))\n" "@end smallexample\n\n" "Interrupts are deferred while the C function is executing (with\n" "@code{SCM_DEFER_INTS}/@code{SCM_ALLOW_INTS}).") @@ -474,24 +467,18 @@ SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0, SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0, (SCM func, SCM dobj, SCM args), - "Call @var{proc}, a dynamically loaded function, passing it the argument\n" - "list @var{args} (a list of strings). As with @code{dynamic-call},\n" - "@var{proc} should be either a function handle or a string, in which case\n" - "it is first fetched from @var{lib} with @code{dynamic-func}.\n\n" - "@var{proc} is assumed to return an integer, which is used as the return\n" - "value from @code{dynamic-args-call}.\n\n" - "GJB:FIXME:DOC 2nd version below\n" - "Call the C function indicated by @var{function} and @var{dynobj}, just\n" - "like @code{dynamic-call}, but pass it some arguments and return its\n" - "return value. The C function is expected to take two arguments and\n" - "return an @code{int}, just like @code{main}:\n\n" + "Call the C function indicated by @var{func} and @var{dobj},\n" + "just like @code{dynamic-call}, but pass it some arguments and\n" + "return its return value. The C function is expected to take\n" + "two arguments and return an @code{int}, just like @code{main}:\n" "@smallexample\n" "int c_func (int argc, char **argv);\n" "@end smallexample\n\n" - "The parameter @var{args} must be a list of strings and is converted into\n" - "an array of @code{char *}. The array is passed in @var{argv} and its\n" - "size in @var{argc}. The return value is converted to a Scheme number\n" - "and returned from the call to @code{dynamic-args-call}.") + "The parameter @var{args} must be a list of strings and is\n" + "converted into an array of @code{char *}. The array is passed\n" + "in @var{argv} and its size in @var{argc}. The return value is\n" + "converted to a Scheme number and returned from the call to\n" + "@code{dynamic-args-call}.") #define FUNC_NAME s_scm_dynamic_args_call { int (*fptr) (int argc, char **argv); diff --git a/libguile/dynwind.c b/libguile/dynwind.c index 101107c70..c79097b61 100644 --- a/libguile/dynwind.c +++ b/libguile/dynwind.c @@ -70,60 +70,66 @@ SCM_DEFINE (scm_dynamic_wind, "dynamic-wind", 3, 0, 0, - (SCM thunk1, SCM thunk2, SCM thunk3), - "All three arguments must be 0-argument procedures.\n\n" - "@var{in-guard} is called, then @var{thunk}, then @var{out-guard}.\n\n" - "If, any time during the execution of @var{thunk}, the continuation\n" - "of the @code{dynamic-wind} expression is escaped non-locally, @var{out-guard}\n" - "is called. If the continuation of the dynamic-wind is re-entered,\n" - "@var{in-guard} is called. Thus @var{in-guard} and @var{out-guard} may\n" - "be called any number of times.\n\n" - "@example\n" + (SCM in_guard, SCM thunk, SCM out_guard), + "All three arguments must be 0-argument procedures.\n" + "@var{in_guard} is called, then @var{thunk}, then\n" + "@var{out_guard}.\n" + "\n" + "If, any time during the execution of @var{thunk}, the\n" + "continuation of the @code{dynamic_wind} expression is escaped\n" + "non-locally, @var{out_guard} is called. If the continuation of\n" + "the dynamic-wind is re-entered, @var{in_guard} is called. Thus\n" + "@var{in_guard} and @var{out_guard} may be called any number of\n" + "times.\n" + "@lisp\n" "(define x 'normal-binding)\n" - "@result{} x\n\n" + "@result{} x\n" "(define a-cont (call-with-current-continuation \n" " (lambda (escape)\n" " (let ((old-x x))\n" " (dynamic-wind\n" " ;; in-guard:\n" " ;;\n" - " (lambda () (set! x 'special-binding))\n\n" + " (lambda () (set! x 'special-binding))\n" + "\n" " ;; thunk\n" " ;;\n" " (lambda () (display x) (newline)\n" " (call-with-current-continuation escape)\n" " (display x) (newline)\n" - " x)\n\n" + " x)\n" + "\n" " ;; out-guard:\n" " ;;\n" - " (lambda () (set! x old-x)))))))\n\n" + " (lambda () (set! x old-x)))))))\n" + "\n" ";; Prints: \n" "special-binding\n" ";; Evaluates to:\n" - "@result{} a-cont\n\n" + "@result{} a-cont\n" "x\n" - "@result{} normal-binding\n\n" + "@result{} normal-binding\n" "(a-cont #f)\n" ";; Prints:\n" "special-binding\n" ";; Evaluates to:\n" - "@result{} a-cont ;; the value of the (define a-cont...)\n\n" + "@result{} a-cont ;; the value of the (define a-cont...)\n" "x\n" - "@result{} normal-binding\n\n" + "@result{} normal-binding\n" "a-cont\n" "@result{} special-binding\n" - "@end example\n") + "@end lisp") #define FUNC_NAME s_scm_dynamic_wind { SCM ans; - SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk3)), - thunk3, + SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (out_guard)), + out_guard, SCM_ARG3, FUNC_NAME); - scm_apply (thunk1, SCM_EOL, SCM_EOL); - scm_dynwinds = scm_acons (thunk1, thunk3, scm_dynwinds); - ans = scm_apply (thunk2, SCM_EOL, SCM_EOL); + scm_apply (in_guard, SCM_EOL, SCM_EOL); + scm_dynwinds = scm_acons (in_guard, out_guard, scm_dynwinds); + ans = scm_apply (thunk, SCM_EOL, SCM_EOL); scm_dynwinds = SCM_CDR (scm_dynwinds); - scm_apply (thunk3, SCM_EOL, SCM_EOL); + scm_apply (out_guard, SCM_EOL, SCM_EOL); return ans; } #undef FUNC_NAME diff --git a/libguile/environments.c b/libguile/environments.c index aa14c3e0f..4facb164b 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -209,26 +209,26 @@ SCM_DEFINE (scm_environment_fold, "environment-fold", 3, 0, 0, "@var{init}.\n" "If @var{env} binds the symbol sym1 to the value val1, sym2 to\n" "val2, and so on, then this procedure computes:\n" - "@example\n" + "@lisp\n" " (proc sym1 val1\n" " (proc sym2 val2\n" " ...\n" " (proc symn valn\n" " init)))\n" - "@end example\n" + "@end lisp\n" "Each binding in @var{env} will be processed exactly once.\n" "@code{environment-fold} makes no guarantees about the order in\n" "which the bindings are processed.\n" "Here is a function which, given an environment, constructs an\n" "association list representing that environment's bindings,\n" "using environment-fold:\n" - "@example\n" + "@lisp\n" " (define (environment->alist env)\n" " (environment-fold env\n" " (lambda (sym val tail)\n" " (cons (cons sym val) tail))\n" " '()))\n" - "@end example") + "@end lisp") #define FUNC_NAME s_scm_environment_fold { SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); diff --git a/libguile/error.c b/libguile/error.c index 9073e2afe..d8fcc7aa8 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -98,18 +98,20 @@ scm_error (SCM key, const char *subr, const char *message, SCM args, SCM rest) /* Scheme interface to scm_error. */ SCM_DEFINE (scm_error_scm, "scm-error", 5, 0, 0, - (SCM key, SCM subr, SCM message, SCM args, SCM rest), - "Raise an error with key @var{key}. @var{subr} can be a string naming\n" - "the procedure associated with the error, or @code{#f}. @var{message}\n" - "is the error message string, possibly containing @code{~S} and @code{~A}\n" - "escapes. When an error is reported, these are replaced by formating the\n" - "corresponding members of @var{args}: @code{~A} (was @code{%s}) formats using @code{display}\n" - "and @code{~S} (was @code{%S}) formats using @code{write}. @var{data} is a\n" - "list or @code{#f} depending on @var{key}: if @var{key} is\n" - "@code{system-error} then it should be a list\n" - "containing the Unix @code{errno} value; If @var{key} is @code{signal} then\n" - "it should be a list containing the Unix signal number; otherwise it\n" - "will usually be @code{#f}.") + (SCM key, SCM subr, SCM message, SCM args, SCM data), + "Raise an error with key @var{key}. @var{subr} can be a string\n" + "naming the procedure associated with the error, or @code{#f}.\n" + "@var{message} is the error message string, possibly containing\n" + "@code{~S} and @code{~A} escapes. When an error is reported,\n" + "these are replaced by formatting the corresponding members of\n" + "@var{args}: @code{~A} (was @code{%s} in older versions of\n" + "Guile) formats using @code{display} and @code{~S} (was\n" + "@code{%S}) formats using @code{write}. @var{data} is a list or\n" + "@code{#f} depending on @var{key}: if @var{key} is\n" + "@code{system-error} then it should be a list containing the\n" + "Unix @code{errno} value; If @var{key} is @code{signal} then it\n" + "should be a list containing the Unix signal number; otherwise\n" + "it will usually be @code{#f}.") #define FUNC_NAME s_scm_error_scm { char *szSubr; @@ -143,14 +145,15 @@ SCM_DEFINE (scm_error_scm, "scm-error", 5, 0, 0, szMessage = SCM_STRING_CHARS (message); } - scm_error (key, szSubr, szMessage, args, rest); + scm_error (key, szSubr, szMessage, args, data); /* not reached. */ } #undef FUNC_NAME SCM_DEFINE (scm_strerror, "strerror", 1, 0, 0, (SCM err), - "Returns the Unix error message corresponding to @var{err}, an integer.") + "Return the Unix error message corresponding to @var{err}, which\n" + "must be an integer value.") #define FUNC_NAME s_scm_strerror { SCM_VALIDATE_INUM (1,err); diff --git a/libguile/filesys.c b/libguile/filesys.c index e034f1fb2..48f8dfa67 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -233,8 +233,8 @@ SCM_DEFINE (scm_umask, "umask", 0, 1, 0, SCM_DEFINE (scm_open_fdes, "open-fdes", 2, 1, 0, (SCM path, SCM flags, SCM mode), - "Similar to @code{open} but returns a file descriptor instead of a\n" - "port.") + "Similar to @code{open} but return a file descriptor instead of\n" + "a port.") #define FUNC_NAME s_scm_open_fdes { int fd; @@ -466,23 +466,26 @@ scm_stat2scm (struct stat *stat_temp) SCM_DEFINE (scm_stat, "stat", 1, 0, 0, (SCM object), - "Returns an object containing various information\n" - "about the file determined by @var{obj}.\n" - "@var{obj} can be a string containing a file name or a port or integer file\n" - "descriptor which is open on a file (in which case @code{fstat} is used\n" - "as the underlying system call).\n\n" - "The object returned by @code{stat} can be passed as a single parameter\n" - "to the following procedures, all of which return integers:\n\n" + "Return an object containing various information about the file\n" + "determined by @var{obj}. @var{obj} can be a string containing\n" + "a file name or a port or integer file descriptor which is open\n" + "on a file (in which case @code{fstat} is used as the underlying\n" + "system call).\n" + "\n" + "The object returned by @code{stat} can be passed as a single\n" + "parameter to the following procedures, all of which return\n" + "integers:\n" + "\n" "@table @code\n" "@item stat:dev\n" "The device containing the file.\n" "@item stat:ino\n" - "The file serial number, which distinguishes this file from all other\n" - "files on the same device.\n" + "The file serial number, which distinguishes this file from all\n" + "other files on the same device.\n" "@item stat:mode\n" - "The mode of the file. This includes file type information\n" - "and the file permission bits. See @code{stat:type} and @code{stat:perms}\n" - "below.\n" + "The mode of the file. This includes file type information and\n" + "the file permission bits. See @code{stat:type} and\n" + "@code{stat:perms} below.\n" "@item stat:nlink\n" "The number of hard links to the file.\n" "@item stat:uid\n" @@ -501,18 +504,21 @@ SCM_DEFINE (scm_stat, "stat", 1, 0, 0, "@item stat:ctime\n" "The last modification time for the attributes of the file.\n" "@item stat:blksize\n" - "The optimal block size for reading or writing the file, in bytes.\n" + "The optimal block size for reading or writing the file, in\n" + "bytes.\n" "@item stat:blocks\n" - "The amount of disk space that the file occupies measured in units of\n" - "512 byte blocks.\n" - "@end table\n\n" + "The amount of disk space that the file occupies measured in\n" + "units of 512 byte blocks.\n" + "@end table\n" + "\n" "In addition, the following procedures return the information\n" - "from stat:mode in a more convenient form:\n\n" + "from stat:mode in a more convenient form:\n" + "\n" "@table @code\n" "@item stat:type\n" "A symbol representing the type of file. Possible values are\n" - "regular, directory, symlink, block-special, char-special,\n" - "fifo, socket and unknown\n" + "regular, directory, symlink, block-special, char-special, fifo,\n" + "socket and unknown\n" "@item stat:perms\n" "An integer representing the access permission bits.\n" "@end table") @@ -685,8 +691,8 @@ scm_bits_t scm_tc16_dir; SCM_DEFINE (scm_directory_stream_p, "directory-stream?", 1, 0, 0, (SCM obj), - "Returns a boolean indicating whether @var{object} is a directory stream\n" - "as returned by @code{opendir}.") + "Return a boolean indicating whether @var{object} is a directory\n" + "stream as returned by @code{opendir}.") #define FUNC_NAME s_scm_directory_stream_p { return SCM_BOOL (SCM_DIRP (obj)); @@ -822,7 +828,7 @@ SCM_DEFINE (scm_chdir, "chdir", 1, 0, 0, #ifdef HAVE_GETCWD SCM_DEFINE (scm_getcwd, "getcwd", 0, 0, 0, (), - "Returns the name of the current working directory.") + "Return the name of the current working directory.") #define FUNC_NAME s_scm_getcwd { char *rv; @@ -1247,9 +1253,8 @@ SCM_DEFINE (scm_symlink, "symlink", 2, 0, 0, #ifdef HAVE_READLINK SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0, (SCM path), - "Returns the value of the symbolic link named by\n" - "@var{path} (a string), i.e., the\n" - "file that the link points to.") + "Return the value of the symbolic link named by @var{path} (a\n" + "string), i.e., the file that the link points to.") #define FUNC_NAME s_scm_readlink { int rv; diff --git a/libguile/fluids.c b/libguile/fluids.c index a76b05c76..a24709828 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -138,7 +138,8 @@ SCM_DEFINE (scm_make_fluid, "make-fluid", 0, 0, 0, SCM_DEFINE (scm_fluid_p, "fluid?", 1, 0, 0, (SCM obj), - "Return #t iff @var{obj} is a fluid; otherwise, return #f.") + "Return @code{#t} iff @var{obj} is a fluid; otherwise, return\n" + "@code{#f}.") #define FUNC_NAME s_scm_fluid_p { return SCM_BOOL(SCM_FLUIDP (obj)); @@ -147,8 +148,9 @@ SCM_DEFINE (scm_fluid_p, "fluid?", 1, 0, 0, SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0, (SCM fluid), - "Return the value associated with @var{fluid} in the current dynamic root.\n" - "If @var{fluid} has not been set, then this returns #f.") + "Return the value associated with @var{fluid} in the current\n" + "dynamic root. If @var{fluid} has not been set, then return\n" + "@code{#f}.") #define FUNC_NAME s_scm_fluid_ref { int n; diff --git a/libguile/fports.c b/libguile/fports.c index c062525f9..422d7d938 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -243,12 +243,12 @@ SCM_DEFINE (scm_file_port_p, "file-port?", 1, 0, 0, * Return the new port. */ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0, - (SCM filename, SCM modes), - "Open the file whose name is @var{string}, and return a port\n" + (SCM filename, SCM mode), + "Open the file whose name is @var{filename}, and return a port\n" "representing that file. The attributes of the port are\n" - "determined by the @var{mode} string. The way in \n" - "which this is interpreted is similar to C stdio:\n\n" - "The first character must be one of the following:\n\n" + "determined by the @var{mode} string. The way in which this is\n" + "interpreted is similar to C stdio. The first character must be\n" + "one of the following:\n" "@table @samp\n" "@item r\n" "Open an existing file for input.\n" @@ -256,48 +256,49 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0, "Open a file for output, creating it if it doesn't already exist\n" "or removing its contents if it does.\n" "@item a\n" - "Open a file for output, creating it if it doesn't already exist.\n" - "All writes to the port will go to the end of the file.\n" + "Open a file for output, creating it if it doesn't already\n" + "exist. All writes to the port will go to the end of the file.\n" "The \"append mode\" can be turned off while the port is in use\n" "@pxref{Ports and File Descriptors, fcntl}\n" - "@end table\n\n" - "The following additional characters can be appended:\n\n" + "@end table\n" + "The following additional characters can be appended:\n" "@table @samp\n" "@item +\n" "Open the port for both input and output. E.g., @code{r+}: open\n" "an existing file for both input and output.\n" "@item 0\n" - "Create an \"unbuffered\" port. In this case input and output operations\n" - "are passed directly to the underlying port implementation without\n" - "additional buffering. This is likely to slow down I/O operations.\n" - "The buffering mode can be changed while a port is in use\n" - "@pxref{Ports and File Descriptors, setvbuf}\n" + "Create an \"unbuffered\" port. In this case input and output\n" + "operations are passed directly to the underlying port\n" + "implementation without additional buffering. This is likely to\n" + "slow down I/O operations. The buffering mode can be changed\n" + "while a port is in use @pxref{Ports and File Descriptors,\n" + "setvbuf}\n" "@item l\n" "Add line-buffering to the port. The port output buffer will be\n" "automatically flushed whenever a newline character is written.\n" - "@end table\n\n" - "In theory we could create read/write ports which were buffered in one\n" - "direction only. However this isn't included in the current interfaces.\n\n" - "If a file cannot be opened with the access requested,\n" - "@code{open-file} throws an exception.") + "@end table\n" + "In theory we could create read/write ports which were buffered\n" + "in one direction only. However this isn't included in the\n" + "current interfaces. If a file cannot be opened with the access\n" + "requested, @code{open-file} throws an exception.") #define FUNC_NAME s_scm_open_file { SCM port; int fdes; int flags = 0; char *file; - char *mode; + char *md; char *ptr; SCM_VALIDATE_STRING (1, filename); - SCM_VALIDATE_STRING (2, modes); + SCM_VALIDATE_STRING (2, mode); SCM_STRING_COERCE_0TERMINATION_X (filename); - SCM_STRING_COERCE_0TERMINATION_X (modes); + SCM_STRING_COERCE_0TERMINATION_X (mode); file = SCM_STRING_CHARS (filename); - mode = SCM_STRING_CHARS (modes); + md = SCM_STRING_CHARS (mode); - switch (*mode) + switch (*md) { case 'r': flags |= O_RDONLY; @@ -309,9 +310,9 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0, flags |= O_WRONLY | O_CREAT | O_APPEND; break; default: - scm_out_of_range (FUNC_NAME, modes); + scm_out_of_range (FUNC_NAME, mode); } - ptr = mode + 1; + ptr = md + 1; while (*ptr != '\0') { switch (*ptr) @@ -328,7 +329,7 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0, case 'l': /* line buffered: handled during output. */ break; default: - scm_out_of_range (FUNC_NAME, modes); + scm_out_of_range (FUNC_NAME, mode); } ptr++; } @@ -341,7 +342,7 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0, scm_cons (scm_makfrom0str (strerror (en)), scm_cons (filename, SCM_EOL)), en); } - port = scm_fdes_to_port (fdes, mode, filename); + port = scm_fdes_to_port (fdes, md, filename); return port; } #undef FUNC_NAME diff --git a/libguile/gc.c b/libguile/gc.c index 020ee1ce7..972faa5d0 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -151,10 +151,10 @@ scm_assert_cell_valid (SCM cell) SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0, (SCM flag), - "If FLAG is #f, cell access checking is disabled.\n" - "If FLAG is #t, cell access checking is enabled.\n" - "This procedure only exists because the compile-time flag\n" - "SCM_DEBUG_CELL_ACCESSES was set to 1.\n") + "If @var{flag} is @code{#f}, cell access checking is disabled.\n" + "If @var{flag} is @code{#t}, cell access checking is enabled.\n" + "This procedure only exists when the compile-time flag\n" + "@code{SCM_DEBUG_CELL_ACCESSES} was set to 1.") #define FUNC_NAME s_scm_set_debug_cell_accesses_x { if (SCM_FALSEP (flag)) { @@ -644,9 +644,9 @@ scm_check_freelist (SCM freelist) SCM_DEFINE (scm_gc_set_debug_check_freelist_x, "gc-set-debug-check-freelist!", 1, 0, 0, (SCM flag), - "If FLAG is #t, check the freelist for consistency on each cell allocation.\n" - "This procedure only exists because the GUILE_DEBUG_FREELIST \n" - "compile-time flag was selected.\n") + "If @var{flag} is @code{#t}, check the freelist for consistency\n" + "on each cell allocation. This procedure only exists when the\n" + "@code{GUILE_DEBUG_FREELIST} compile-time flag was selected.") #define FUNC_NAME s_scm_gc_set_debug_check_freelist_x { /* [cmm] I did a double-take when I read this code the first time. @@ -745,7 +745,8 @@ compute_cells_allocated () SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, (), - "Returns an association list of statistics about Guile's current use of storage. ") + "Return an association list of statistics about Guile's current\n" + "use of storage.") #define FUNC_NAME s_scm_gc_stats { int i; diff --git a/libguile/hashtab.c b/libguile/hashtab.c index 9bcc16826..50eac4ce8 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -191,7 +191,7 @@ SCM_DEFINE (scm_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0, SCM_DEFINE (scm_hashq_ref, "hashq-ref", 2, 1, 0, - (SCM table, SCM obj, SCM dflt), + (SCM table, SCM key, SCM dflt), "Look up @var{key} in the hash table @var{table}, and return the\n" "value (if any) associated with it. If @var{key} is not found,\n" "return @var{default} (or @code{#f} if no @var{default} argument\n" @@ -200,31 +200,32 @@ SCM_DEFINE (scm_hashq_ref, "hashq-ref", 2, 1, 0, { if (SCM_UNBNDP (dflt)) dflt = SCM_BOOL_F; - return scm_hash_fn_ref (table, obj, dflt, scm_ihashq, scm_sloppy_assq, 0); + return scm_hash_fn_ref (table, key, dflt, scm_ihashq, scm_sloppy_assq, 0); } #undef FUNC_NAME SCM_DEFINE (scm_hashq_set_x, "hashq-set!", 3, 0, 0, - (SCM table, SCM obj, SCM val), + (SCM table, SCM key, SCM val), "Find the entry in @var{table} associated with @var{key}, and\n" "store @var{value} there. Uses @code{eq?} for equality testing.") #define FUNC_NAME s_scm_hashq_set_x { - return scm_hash_fn_set_x (table, obj, val, scm_ihashq, scm_sloppy_assq, 0); + return scm_hash_fn_set_x (table, key, val, scm_ihashq, scm_sloppy_assq, 0); } #undef FUNC_NAME SCM_DEFINE (scm_hashq_remove_x, "hashq-remove!", 2, 0, 0, - (SCM table, SCM obj), + (SCM table, SCM key), "Remove @var{key} (and any value associated with it) from\n" "@var{table}. Uses @code{eq?} for equality tests.") #define FUNC_NAME s_scm_hashq_remove_x { - return scm_hash_fn_remove_x (table, obj, scm_ihashq, scm_sloppy_assq, scm_delq_x, 0); + return scm_hash_fn_remove_x (table, key, scm_ihashq, scm_sloppy_assq, + scm_delq_x, 0); } #undef FUNC_NAME @@ -251,13 +252,14 @@ SCM_DEFINE (scm_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0, "associates @var{key} with @var{init}.") #define FUNC_NAME s_scm_hashv_create_handle_x { - return scm_hash_fn_create_handle_x (table, key, init, scm_ihashv, scm_sloppy_assv, 0); + return scm_hash_fn_create_handle_x (table, key, init, scm_ihashv, + scm_sloppy_assv, 0); } #undef FUNC_NAME SCM_DEFINE (scm_hashv_ref, "hashv-ref", 2, 1, 0, - (SCM table, SCM obj, SCM dflt), + (SCM table, SCM key, SCM dflt), "Look up @var{key} in the hash table @var{table}, and return the\n" "value (if any) associated with it. If @var{key} is not found,\n" "return @var{default} (or @code{#f} if no @var{default} argument\n" @@ -266,30 +268,31 @@ SCM_DEFINE (scm_hashv_ref, "hashv-ref", 2, 1, 0, { if (SCM_UNBNDP (dflt)) dflt = SCM_BOOL_F; - return scm_hash_fn_ref (table, obj, dflt, scm_ihashv, scm_sloppy_assv, 0); + return scm_hash_fn_ref (table, key, dflt, scm_ihashv, scm_sloppy_assv, 0); } #undef FUNC_NAME SCM_DEFINE (scm_hashv_set_x, "hashv-set!", 3, 0, 0, - (SCM table, SCM obj, SCM val), + (SCM table, SCM key, SCM val), "Find the entry in @var{table} associated with @var{key}, and\n" "store @var{value} there. Uses @code{eqv?} for equality testing.") #define FUNC_NAME s_scm_hashv_set_x { - return scm_hash_fn_set_x (table, obj, val, scm_ihashv, scm_sloppy_assv, 0); + return scm_hash_fn_set_x (table, key, val, scm_ihashv, scm_sloppy_assv, 0); } #undef FUNC_NAME SCM_DEFINE (scm_hashv_remove_x, "hashv-remove!", 2, 0, 0, - (SCM table, SCM obj), + (SCM table, SCM key), "Remove @var{key} (and any value associated with it) from\n" "@var{table}. Uses @code{eqv?} for equality tests.") #define FUNC_NAME s_scm_hashv_remove_x { - return scm_hash_fn_remove_x (table, obj, scm_ihashv, scm_sloppy_assv, scm_delv_x, 0); + return scm_hash_fn_remove_x (table, key, scm_ihashv, scm_sloppy_assv, + scm_delv_x, 0); } #undef FUNC_NAME @@ -321,7 +324,7 @@ SCM_DEFINE (scm_hash_create_handle_x, "hash-create-handle!", 3, 0, 0, SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0, - (SCM table, SCM obj, SCM dflt), + (SCM table, SCM key, SCM dflt), "Look up @var{key} in the hash table @var{table}, and return the\n" "value (if any) associated with it. If @var{key} is not found,\n" "return @var{default} (or @code{#f} if no @var{default} argument\n" @@ -330,32 +333,33 @@ SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0, { if (SCM_UNBNDP (dflt)) dflt = SCM_BOOL_F; - return scm_hash_fn_ref (table, obj, dflt, scm_ihash, scm_sloppy_assoc, 0); + return scm_hash_fn_ref (table, key, dflt, scm_ihash, scm_sloppy_assoc, 0); } #undef FUNC_NAME SCM_DEFINE (scm_hash_set_x, "hash-set!", 3, 0, 0, - (SCM table, SCM obj, SCM val), + (SCM table, SCM key, SCM val), "Find the entry in @var{table} associated with @var{key}, and\n" "store @var{value} there. Uses @code{equal?} for equality\n" "testing.") #define FUNC_NAME s_scm_hash_set_x { - return scm_hash_fn_set_x (table, obj, val, scm_ihash, scm_sloppy_assoc, 0); + return scm_hash_fn_set_x (table, key, val, scm_ihash, scm_sloppy_assoc, 0); } #undef FUNC_NAME SCM_DEFINE (scm_hash_remove_x, "hash-remove!", 2, 0, 0, - (SCM table, SCM obj), + (SCM table, SCM key), "Remove @var{key} (and any value associated with it) from\n" "@var{table}. Uses @code{equal?} for equality tests.") #define FUNC_NAME s_scm_hash_remove_x { - return scm_hash_fn_remove_x (table, obj, scm_ihash, scm_sloppy_assoc, scm_delete_x, 0); + return scm_hash_fn_remove_x (table, key, scm_ihash, scm_sloppy_assoc, + scm_delete_x, 0); } #undef FUNC_NAME @@ -415,11 +419,11 @@ scm_delx_x (SCM obj,SCM alist,struct scm_ihashx_closure * closure) SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0, - (SCM hash, SCM assoc, SCM table, SCM obj), - "This behaves the same way as the corresponding @code{-get-handle}\n" - "function, but uses @var{hasher} as a\n" - "hash function and @var{assoc} to compare keys. @code{hasher} must\n" - "be a function that takes two arguments, a key to be hashed and a\n" + (SCM hash, SCM assoc, SCM table, SCM key), + "This behaves the same way as the corresponding\n" + "@code{-get-handle} function, but uses @var{hash} as a hash\n" + "function and @var{assoc} to compare keys. @code{hash} must be\n" + "a function that takes two arguments, a key to be hashed and a\n" "table size. @code{assoc} must be an associator function, like\n" "@code{assoc}, @code{assq} or @code{assv}.") #define FUNC_NAME s_scm_hashx_get_handle @@ -427,17 +431,18 @@ SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0, struct scm_ihashx_closure closure; closure.hash = hash; closure.assoc = assoc; - return scm_hash_fn_get_handle (table, obj, scm_ihashx, scm_sloppy_assx, (void *)&closure); + return scm_hash_fn_get_handle (table, key, scm_ihashx, scm_sloppy_assx, + (void *)&closure); } #undef FUNC_NAME SCM_DEFINE (scm_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0, - (SCM hash, SCM assoc, SCM table, SCM obj, SCM init), - "This behaves the same way as the corresponding @code{-create-handle}\n" - "function, but uses @var{hasher} as a\n" - "hash function and @var{assoc} to compare keys. @code{hasher} must\n" - "be a function that takes two arguments, a key to be hashed and a\n" + (SCM hash, SCM assoc, SCM table, SCM key, SCM init), + "This behaves the same way as the corresponding\n" + "@code{-create-handle} function, but uses @var{hash} as a hash\n" + "function and @var{assoc} to compare keys. @code{hash} must be\n" + "a function that takes two arguments, a key to be hashed and a\n" "table size. @code{assoc} must be an associator function, like\n" "@code{assoc}, @code{assq} or @code{assv}.") #define FUNC_NAME s_scm_hashx_create_handle_x @@ -445,22 +450,24 @@ SCM_DEFINE (scm_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0, struct scm_ihashx_closure closure; closure.hash = hash; closure.assoc = assoc; - return scm_hash_fn_create_handle_x (table, obj, init, scm_ihashx, scm_sloppy_assx, (void *)&closure); + return scm_hash_fn_create_handle_x (table, key, init, scm_ihashx, + scm_sloppy_assx, (void *)&closure); } #undef FUNC_NAME SCM_DEFINE (scm_hashx_ref, "hashx-ref", 4, 1, 0, - (SCM hash, SCM assoc, SCM table, SCM obj, SCM dflt), + (SCM hash, SCM assoc, SCM table, SCM key, SCM dflt), "This behaves the same way as the corresponding @code{ref}\n" - "function, but uses @var{hasher} as a\n" - "hash function and @var{assoc} to compare keys. @code{hasher} must\n" - "be a function that takes two arguments, a key to be hashed and a\n" - "table size. @code{assoc} must be an associator function, like\n" - "@code{assoc}, @code{assq} or @code{assv}.\n\n" - "By way of illustration, @code{hashq-ref table key} is equivalent\n" - "to @code{hashx-ref hashq assq table key}.") + "function, but uses @var{hash} as a hash function and\n" + "@var{assoc} to compare keys. @code{hash} must be a function\n" + "that takes two arguments, a key to be hashed and a table size.\n" + "@code{assoc} must be an associator function, like @code{assoc},\n" + "@code{assq} or @code{assv}.\n" + "\n" + "By way of illustration, @code{hashq-ref table key} is\n" + "equivalent to @code{hashx-ref hashq assq table key}.") #define FUNC_NAME s_scm_hashx_ref { struct scm_ihashx_closure closure; @@ -468,7 +475,8 @@ SCM_DEFINE (scm_hashx_ref, "hashx-ref", 4, 1, 0, dflt = SCM_BOOL_F; closure.hash = hash; closure.assoc = assoc; - return scm_hash_fn_ref (table, obj, dflt, scm_ihashx, scm_sloppy_assx, (void *)&closure); + return scm_hash_fn_ref (table, key, dflt, scm_ihashx, scm_sloppy_assx, + (void *)&closure); } #undef FUNC_NAME @@ -476,21 +484,23 @@ SCM_DEFINE (scm_hashx_ref, "hashx-ref", 4, 1, 0, SCM_DEFINE (scm_hashx_set_x, "hashx-set!", 5, 0, 0, - (SCM hash, SCM assoc, SCM table, SCM obj, SCM val), + (SCM hash, SCM assoc, SCM table, SCM key, SCM val), "This behaves the same way as the corresponding @code{set!}\n" - "function, but uses @var{hasher} as a\n" - "hash function and @var{assoc} to compare keys. @code{hasher} must\n" - "be a function that takes two arguments, a key to be hashed and a\n" - "table size. @code{assoc} must be an associator function, like\n" - "@code{assoc}, @code{assq} or @code{assv}.\n\n" - "By way of illustration, @code{hashq-set! table key} is equivalent\n" - "to @code{hashx-set! hashq assq table key}.") + "function, but uses @var{hash} as a hash function and\n" + "@var{assoc} to compare keys. @code{hash} must be a function\n" + "that takes two arguments, a key to be hashed and a table size.\n" + "@code{assoc} must be an associator function, like @code{assoc},\n" + "@code{assq} or @code{assv}.\n" + "\n" + " By way of illustration, @code{hashq-set! table key} is\n" + "equivalent to @code{hashx-set! hashq assq table key}.") #define FUNC_NAME s_scm_hashx_set_x { struct scm_ihashx_closure closure; closure.hash = hash; closure.assoc = assoc; - return scm_hash_fn_set_x (table, obj, val, scm_ihashx, scm_sloppy_assx, (void *)&closure); + return scm_hash_fn_set_x (table, key, val, scm_ihashx, scm_sloppy_assx, + (void *)&closure); } #undef FUNC_NAME diff --git a/libguile/ioext.c b/libguile/ioext.c index 31f874c58..c69be4d42 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -165,15 +165,16 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0, #undef FUNC_NAME SCM_DEFINE (scm_ftell, "ftell", 1, 0, 0, - (SCM object), - "Returns an integer representing the current position of @var{fd/port},\n" - "measured from the beginning. Equivalent to:\n" - "@smalllisp\n" + (SCM fd_port), + "Return an integer representing the current position of\n" + "@var{fd/port}, measured from the beginning. Equivalent to:\n" + "\n" + "@lisp\n" "(seek port 0 SEEK_CUR)\n" - "@end smalllisp") + "@end lisp") #define FUNC_NAME s_scm_ftell { - return scm_seek (object, SCM_INUM0, SCM_MAKINUM (SEEK_CUR)); + return scm_seek (fd_port, SCM_INUM0, SCM_MAKINUM (SEEK_CUR)); } #undef FUNC_NAME @@ -181,12 +182,12 @@ SCM_DEFINE (scm_ftell, "ftell", 1, 0, 0, #if (SCM_DEBUG_DEPRECATED == 0) SCM_DEFINE (scm_fseek, "fseek", 3, 0, 0, - (SCM object, SCM offset, SCM whence), - "Obsolete. Almost the same as seek, above, but the return value is\n" - "unspecified.") + (SCM fd_port, SCM offset, SCM whence), + "Obsolete. Almost the same as @code{seek}, but the return value\n" + "is unspecified.") #define FUNC_NAME s_scm_fseek { - scm_seek (object, offset, whence); + scm_seek (fd_port, offset, whence); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -242,7 +243,9 @@ SCM_DEFINE (scm_redirect_port, "redirect-port", 2, 0, 0, SCM_DEFINE (scm_dup_to_fdes, "dup->fdes", 1, 1, 0, (SCM fd_or_port, SCM fd), - "Returns an integer file descriptor.") + "Return a new integer file descriptor referring to the open file\n" + "designated by @var{fd_or_port}, which must be either an open\n" + "file port or a file descriptor.") #define FUNC_NAME s_scm_dup_to_fdes { int oldfd, newfd, rv; @@ -307,8 +310,8 @@ SCM_DEFINE (scm_dup2, "dup2", 2, 0, 0, SCM_DEFINE (scm_fileno, "fileno", 1, 0, 0, (SCM port), - "Returns the integer file descriptor underlying @var{port}.\n" - "Does not change its revealed count.") + "Return the integer file descriptor underlying @var{port}. Does\n" + "not change its revealed count.") #define FUNC_NAME s_scm_fileno { port = SCM_COERCE_OUTPORT (port); @@ -323,8 +326,8 @@ SCM_DEFINE (scm_fileno, "fileno", 1, 0, 0, if it is not going to assume that the arg is a port */ SCM_DEFINE (scm_isatty_p, "isatty?", 1, 0, 0, (SCM port), - "Returns @code{#t} if @var{port} is using a serial\n" - "non-file device, otherwise @code{#f}.") + "Return @code{#t} if @var{port} is using a serial non--file\n" + "device, otherwise @code{#f}.") #define FUNC_NAME s_scm_isatty_p { int rv; @@ -343,10 +346,10 @@ SCM_DEFINE (scm_isatty_p, "isatty?", 1, 0, 0, SCM_DEFINE (scm_fdopen, "fdopen", 2, 0, 0, (SCM fdes, SCM modes), - "Returns a new port based on the file descriptor @var{fdes}.\n" - "Modes are given by the string @var{modes}. The revealed count of the port\n" - "is initialized to zero. The modes string is the same as that accepted\n" - "by @ref{File Ports, open-file}.") + "Return a new port based on the file descriptor @var{fdes}.\n" + "Modes are given by the string @var{modes}. The revealed count\n" + "of the port is initialized to zero. The modes string is the\n" + "same as that accepted by @ref{File Ports, open-file}.") #define FUNC_NAME s_scm_fdopen { SCM_VALIDATE_INUM (1,fdes); @@ -403,8 +406,9 @@ SCM_DEFINE (scm_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0, /* Return a list of ports using a given file descriptor. */ SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0, (SCM fd), - "Returns a list of existing ports which have @var{fdes} as an\n" - "underlying file descriptor, without changing their revealed counts.") + "Return a list of existing ports which have @var{fdes} as an\n" + "underlying file descriptor, without changing their revealed\n" + "counts.") #define FUNC_NAME s_scm_fdes_to_ports { SCM result = SCM_EOL; diff --git a/libguile/keywords.c b/libguile/keywords.c index 3509314ea..ff86b582f 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -109,7 +109,8 @@ scm_c_make_keyword (char *s) SCM_DEFINE (scm_keyword_p, "keyword?", 1, 0, 0, (SCM obj), - "Returns @code{#t} if the argument @var{obj} is a keyword, else @code{#f}.") + "Return @code{#t} if the argument @var{obj} is a keyword, else\n" + "@code{#f}.") #define FUNC_NAME s_scm_keyword_p { return SCM_BOOL (SCM_KEYWORDP (obj)); diff --git a/libguile/list.c b/libguile/list.c index d5b486bdf..bf1a1725c 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -194,19 +194,19 @@ SCM_DEFINE (scm_append, "append", 0, 0, 1, (SCM args), "Return a list consisting of the elements the lists passed as\n" "arguments.\n" - "@example\n" + "@lisp\n" "(append '(x) '(y)) @result{} (x y)\n" "(append '(a) '(b c d)) @result{} (a b c d)\n" "(append '(a (b)) '((c))) @result{} (a (b) (c))\n" - "@end example\n" + "@end lisp\n" "The resulting list is always newly allocated, except that it\n" "shares structure with the last list argument. The last\n" "argument may actually be any object; an improper list results\n" "if the last argument is not a proper list.\n" - "@example\n" + "@lisp\n" "(append '(a b) '(c . d)) @result{} (a b c . d)\n" "(append '() 'a) @result{} a\n" - "@end example") + "@end lisp") #define FUNC_NAME s_scm_append { SCM_VALIDATE_REST_ARGUMENT (args); @@ -235,25 +235,26 @@ SCM_DEFINE (scm_append, "append", 0, 0, 1, SCM_DEFINE (scm_append_x, "append!", 0, 0, 1, - (SCM args), - "A destructive version of @code{append} (@pxref{Pairs and Lists,,,r4rs,\n" - "The Revised^4 Report on Scheme}). The cdr field of each list's final\n" - "pair is changed to point to the head of the next list, so no consing is\n" - "performed. Return a pointer to the mutated list.") + (SCM lists), + "A destructive version of @code{append} (@pxref{Pairs and\n" + "Lists,,,r4rs, The Revised^4 Report on Scheme}). The cdr field\n" + "of each list's final pair is changed to point to the head of\n" + "the next list, so no consing is performed. Return a pointer to\n" + "the mutated list.") #define FUNC_NAME s_scm_append_x { - SCM_VALIDATE_REST_ARGUMENT (args); + SCM_VALIDATE_REST_ARGUMENT (lists); while (1) { - if (SCM_NULLP (args)) { + if (SCM_NULLP (lists)) { return SCM_EOL; } else { - SCM arg = SCM_CAR (args); - args = SCM_CDR (args); - if (SCM_NULLP (args)) { + SCM arg = SCM_CAR (lists); + lists = SCM_CDR (lists); + if (SCM_NULLP (lists)) { return arg; } else if (!SCM_NULLP (arg)) { SCM_VALIDATE_CONS (SCM_ARG1, arg); - SCM_SETCDR (scm_last_pair (arg), scm_append_x (args)); + SCM_SETCDR (scm_last_pair (arg), scm_append_x (lists)); return arg; } } @@ -565,7 +566,7 @@ SCM_DEFINE (scm_sloppy_member, "sloppy-member", 2, 0, 0, /* The function scm_c_memq returns the first sublist of list whose car is * 'eq?' obj, where the sublists of list are the non-empty lists returned by * (list-tail list k) for k less than the length of list. If obj does not - * occur in list, then #f (not the empty list) is returned. (r5rs) + * occur in list, then #f (not the empty list) is returned. * List must be a proper list, otherwise scm_c_memq may crash or loop * endlessly. */ diff --git a/libguile/macros.c b/libguile/macros.c index 1d5aadd18..44eac33d8 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -55,9 +55,10 @@ scm_bits_t scm_tc16_macro; SCM_DEFINE (scm_makacro, "procedure->syntax", 1, 0, 0, (SCM code), - "Returns a @dfn{macro} which, when a symbol defined to this value\n" - "appears as the first symbol in an expression, returns the result\n" - "of applying @var{code} to the expression and the environment.") + "Return a @dfn{macro} which, when a symbol defined to this value\n" + "appears as the first symbol in an expression, returns the\n" + "result of applying @var{code} to the expression and the\n" + "environment.") #define FUNC_NAME s_scm_makacro { SCM_VALIDATE_PROC (1,code); @@ -68,18 +69,19 @@ SCM_DEFINE (scm_makacro, "procedure->syntax", 1, 0, 0, SCM_DEFINE (scm_makmacro, "procedure->macro", 1, 0, 0, (SCM code), - "Returns a @dfn{macro} which, when a symbol defined to this value\n" - "appears as the first symbol in an expression, evaluates the result\n" - "of applying @var{code} to the expression and the environment.\n" - "The value returned from @var{code} which has been passed to\n" - "@code{procedure->memoizing-macro} replaces the form passed to\n" - "@var{code}. For example:\n\n" - "@example\n" + "Return a @dfn{macro} which, when a symbol defined to this value\n" + "appears as the first symbol in an expression, evaluates the\n" + "result of applying @var{code} to the expression and the\n" + "environment. The value returned from @var{code} which has been\n" + "passed to @code{procedure->memoizing-macro} replaces the form\n" + "passed to @var{code}. For example:\n" + "\n" + "@lisp\n" "(define trace\n" " (procedure->macro\n" " (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x))))))\n\n" "(trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})).\n" - "@end example") + "@end lisp") #define FUNC_NAME s_scm_makmacro { SCM_VALIDATE_PROC (1,code); @@ -90,18 +92,19 @@ SCM_DEFINE (scm_makmacro, "procedure->macro", 1, 0, 0, SCM_DEFINE (scm_makmmacro, "procedure->memoizing-macro", 1, 0, 0, (SCM code), - "Returns a @dfn{macro} which, when a symbol defined to this value\n" - "appears as the first symbol in an expression, evaluates the result\n" - "of applying @var{proc} to the expression and the environment.\n" - "The value returned from @var{proc} which has been passed to\n" - "@code{procedure->memoizing-macro} replaces the form passed to\n" - "@var{proc}. For example:\n\n" - "@example\n" - "(define trace\n" - " (procedure->macro\n" - " (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x))))))\n\n" - "(trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})).\n" - "@end example") + "Return a @dfn{macro} which, when a symbol defined to this value\n" + "appears as the first symbol in an expression, evaluates the\n" + "result of applying @var{proc} to the expression and the\n" + "environment. The value returned from @var{proc} which has been\n" + "passed to @code{procedure->memoizing-macro} replaces the form\n" + "passed to @var{proc}. For example:\n" + "\n" + "@lisp\n" + "(define trace\n" + " (procedure->macro\n" + " (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x))))))\n\n" + "(trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})).\n" + "@end lisp") #define FUNC_NAME s_scm_makmmacro { SCM_VALIDATE_PROC (1,code); @@ -127,10 +130,11 @@ SCM_SYMBOL (scm_sym_mmacro, "macro!"); SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0, (SCM m), - "Return one of the symbols @code{syntax}, @code{macro} or @code{macro!},\n" - "depending on whether @var{obj} is a syntax tranformer, a regular macro,\n" - "or a memoizing macro, respectively. If @var{obj} is not a macro,\n" - "@code{#f} is returned.") + "Return one of the symbols @code{syntax}, @code{macro} or\n" + "@code{macro!}, depending on whether @var{m} is a syntax\n" + "tranformer, a regular macro, or a memoizing macro,\n" + "respectively. If @var{m} is not a macro, @code{#f} is\n" + "returned.") #define FUNC_NAME s_scm_macro_type { if (!SCM_TYP16_PREDICATE (scm_tc16_macro, m)) diff --git a/libguile/modules.c b/libguile/modules.c index 8e2edb1e3..4259b05f0 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -95,11 +95,11 @@ scm_set_current_module (SCM module) SCM_DEFINE (scm_interaction_environment, "interaction-environment", 0, 0, 0, (), - "This procedure returns a specifier for the environment that contains\n" - "implementation-defined bindings, typically a superset of those listed in\n" - "the report. The intent is that this procedure will return the\n" - "environment in which the implementation would evaluate expressions\n" - "dynamically typed by the user.") + "Return a specifier for the environment that contains\n" + "implementation--defined bindings, typically a superset of those\n" + "listed in the report. The intent is that this procedure will\n" + "return the environment in which the implementation would\n" + "evaluate expressions dynamically typed by the user.") #define FUNC_NAME s_scm_interaction_environment { return scm_current_module (); diff --git a/libguile/net_db.c b/libguile/net_db.c index 27721ffc0..2ef227f48 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -89,11 +89,11 @@ extern int h_errno; SCM_DEFINE (scm_inet_aton, "inet-aton", 1, 0, 0, (SCM address), - "Converts a string containing an Internet host address in the traditional\n" - "dotted decimal notation into an integer.\n\n" - "@smalllisp\n" - "(inet-aton \"127.0.0.1\") @result{} 2130706433\n\n" - "@end smalllisp") + "Converts a string containing an Internet host address in the\n" + "traditional dotted decimal notation into an integer.\n" + "@lisp\n" + "(inet-aton \"127.0.0.1\") @result{} 2130706433\n" + "@end lisp") #define FUNC_NAME s_scm_inet_aton { struct in_addr soka; @@ -109,11 +109,11 @@ SCM_DEFINE (scm_inet_aton, "inet-aton", 1, 0, 0, SCM_DEFINE (scm_inet_ntoa, "inet-ntoa", 1, 0, 0, (SCM inetid), - "Converts an integer Internet host address into a string with the\n" - "traditional dotted decimal representation.\n\n" - "@smalllisp\n" + "Converts an integer Internet host address into a string with\n" + "the traditional dotted decimal representation.\n" + "@lisp\n" "(inet-ntoa 2130706433) @result{} \"127.0.0.1\"\n" - "@end smalllisp") + "@end lisp") #define FUNC_NAME s_scm_inet_ntoa { struct in_addr addr; @@ -129,10 +129,11 @@ SCM_DEFINE (scm_inet_ntoa, "inet-ntoa", 1, 0, 0, #ifdef HAVE_INET_NETOF SCM_DEFINE (scm_inet_netof, "inet-netof", 1, 0, 0, (SCM address), - "Returns the network number part of the given integer Internet address.\n\n" - "@smalllisp\n" + "Return the network number part of the given integer Internet\n" + "address.\n" + "@lisp\n" "(inet-netof 2130706433) @result{} 127\n" - "@end smalllisp") + "@end lisp") #define FUNC_NAME s_scm_inet_netof { struct in_addr addr; @@ -145,11 +146,11 @@ SCM_DEFINE (scm_inet_netof, "inet-netof", 1, 0, 0, #ifdef HAVE_INET_LNAOF SCM_DEFINE (scm_lnaof, "inet-lnaof", 1, 0, 0, (SCM address), - "Returns the local-address-with-network part of the given Internet\n" - "address.\n\n" - "@smalllisp\n" + "Return the local-address-with-network part of the given\n" + "Internet address.\n" + "@lisp\n" "(inet-lnaof 2130706433) @result{} 1\n" - "@end smalllisp") + "@end lisp") #define FUNC_NAME s_scm_lnaof { struct in_addr addr; @@ -162,11 +163,12 @@ SCM_DEFINE (scm_lnaof, "inet-lnaof", 1, 0, 0, #ifdef HAVE_INET_MAKEADDR SCM_DEFINE (scm_inet_makeaddr, "inet-makeaddr", 2, 0, 0, (SCM net, SCM lna), - "Makes an Internet host address by combining the network number @var{net}\n" - "with the local-address-within-network number @var{lna}.\n\n" - "@smalllisp\n" + "Makes an Internet host address by combining the network number\n" + "@var{net} with the local-address-within-network number\n" + "@var{lna}.\n" + "@lisp\n" "(inet-makeaddr 127 1) @result{} 2130706433\n" - "@end smalllisp") + "@end lisp") #define FUNC_NAME s_scm_inet_makeaddr { struct in_addr addr; diff --git a/libguile/numbers.c b/libguile/numbers.c index 17fa9fda1..c712b6544 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -746,13 +746,13 @@ SCM scm_big_test(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy) SCM_DEFINE1 (scm_logand, "logand", scm_tc7_asubr, (SCM n1, SCM n2), - "Returns the integer which is the bit-wise AND of the two integer\n" - "arguments.\n\n" - "Example:\n" - "@lisp\n" - "(number->string (logand #b1100 #b1010) 2)\n" - " @result{} \"1000\"\n" - "@end lisp") + "Return the integer which is the bit-wise AND of the two integer\n" + "arguments.\n" + "\n" + "@lisp\n" + "(number->string (logand #b1100 #b1010) 2)\n" + " @result{} \"1000\"\n" + "@end lisp") #define FUNC_NAME s_scm_logand { long int nn1; @@ -833,13 +833,13 @@ SCM_DEFINE1 (scm_logand, "logand", scm_tc7_asubr, SCM_DEFINE1 (scm_logior, "logior", scm_tc7_asubr, (SCM n1, SCM n2), - "Returns the integer which is the bit-wise OR of the two integer\n" - "arguments.\n\n" - "Example:\n" - "@lisp\n" - "(number->string (logior #b1100 #b1010) 2)\n" - " @result{} \"1110\"\n" - "@end lisp") + "Return the integer which is the bit-wise OR of the two integer\n" + "arguments.\n" + "\n" + "@lisp\n" + "(number->string (logior #b1100 #b1010) 2)\n" + " @result{} \"1110\"\n" + "@end lisp") #define FUNC_NAME s_scm_logior { long int nn1; @@ -919,13 +919,13 @@ SCM_DEFINE1 (scm_logior, "logior", scm_tc7_asubr, SCM_DEFINE1 (scm_logxor, "logxor", scm_tc7_asubr, (SCM n1, SCM n2), - "Returns the integer which is the bit-wise XOR of the two integer\n" - "arguments.\n\n" - "Example:\n" - "@lisp\n" - "(number->string (logxor #b1100 #b1010) 2)\n" - " @result{} \"110\"\n" - "@end lisp") + "Return the integer which is the bit-wise XOR of the two integer\n" + "arguments.\n" + "\n" + "@lisp\n" + "(number->string (logxor #b1100 #b1010) 2)\n" + " @result{} \"110\"\n" + "@end lisp") #define FUNC_NAME s_scm_logxor { long int nn1; @@ -989,54 +989,54 @@ SCM_DEFINE1 (scm_logxor, "logxor", scm_tc7_asubr, SCM_DEFINE (scm_logtest, "logtest", 2, 0, 0, - (SCM n1, SCM n2), - "@example\n" + (SCM j, SCM k), + "@lisp\n" "(logtest j k) @equiv{} (not (zero? (logand j k)))\n\n" "(logtest #b0100 #b1011) @result{} #f\n" "(logtest #b0100 #b0111) @result{} #t\n" - "@end example") + "@end lisp") #define FUNC_NAME s_scm_logtest { - long int nn1; + long int nj; - if (SCM_INUMP (n1)) { - nn1 = SCM_INUM (n1); - if (SCM_INUMP (n2)) { - long nn2 = SCM_INUM (n2); - return SCM_BOOL (nn1 & nn2); - } else if (SCM_BIGP (n2)) { + if (SCM_INUMP (j)) { + nj = SCM_INUM (j); + if (SCM_INUMP (k)) { + long nk = SCM_INUM (k); + return SCM_BOOL (nj & nk); + } else if (SCM_BIGP (k)) { intbig: { # ifndef SCM_DIGSTOOBIG - long z = scm_pseudolong (nn1); + long z = scm_pseudolong (nj); return scm_big_test ((SCM_BIGDIG *)&z, SCM_DIGSPERLONG, - (nn1 < 0) ? SCM_BIGSIGNFLAG : 0, n2); + (nj < 0) ? SCM_BIGSIGNFLAG : 0, k); # else SCM_BIGDIG zdigs [SCM_DIGSPERLONG]; - scm_longdigs (nn1, zdigs); + scm_longdigs (nj, zdigs); return scm_big_test (zdigs, SCM_DIGSPERLONG, - (nn1 < 0) ? SCM_BIGSIGNFLAG : 0, n2); + (nj < 0) ? SCM_BIGSIGNFLAG : 0, k); # endif } } else { - SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); + SCM_WRONG_TYPE_ARG (SCM_ARG2, k); } - } else if (SCM_BIGP (n1)) { - if (SCM_INUMP (n2)) { - SCM_SWAP (n1, n2); - nn1 = SCM_INUM (n1); + } else if (SCM_BIGP (j)) { + if (SCM_INUMP (k)) { + SCM_SWAP (j, k); + nj = SCM_INUM (j); goto intbig; - } else if (SCM_BIGP (n2)) { - if (SCM_NUMDIGS (n1) > SCM_NUMDIGS (n2)) { - SCM_SWAP (n1, n2); + } else if (SCM_BIGP (k)) { + if (SCM_NUMDIGS (j) > SCM_NUMDIGS (k)) { + SCM_SWAP (j, k); } - return scm_big_test (SCM_BDIGITS (n1), SCM_NUMDIGS (n1), - SCM_BIGSIGN (n1), n2); + return scm_big_test (SCM_BDIGITS (j), SCM_NUMDIGS (j), + SCM_BIGSIGN (j), k); } else { - SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); + SCM_WRONG_TYPE_ARG (SCM_ARG2, k); } } else { - SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); + SCM_WRONG_TYPE_ARG (SCM_ARG1, j); } } #undef FUNC_NAME @@ -1044,14 +1044,14 @@ SCM_DEFINE (scm_logtest, "logtest", 2, 0, 0, SCM_DEFINE (scm_logbit_p, "logbit?", 2, 0, 0, (SCM index, SCM j), - "@example\n" + "@lisp\n" "(logbit? index j) @equiv{} (logtest (integer-expt 2 index) j)\n\n" "(logbit? 0 #b1101) @result{} #t\n" "(logbit? 1 #b1101) @result{} #f\n" "(logbit? 2 #b1101) @result{} #t\n" "(logbit? 3 #b1101) @result{} #t\n" "(logbit? 4 #b1101) @result{} #f\n" - "@end example") + "@end lisp") #define FUNC_NAME s_scm_logbit_p { unsigned long int iindex; @@ -1092,14 +1092,15 @@ SCM_DEFINE (scm_logbit_p, "logbit?", 2, 0, 0, SCM_DEFINE (scm_lognot, "lognot", 1, 0, 0, (SCM n), - "Returns the integer which is the 2s-complement of the integer argument.\n\n" - "Example:\n" + "Return the integer which is the 2s-complement of the integer\n" + "argument.\n" + "\n" "@lisp\n" "(number->string (lognot #b10000000) 2)\n" " @result{} \"-10000001\"\n" "(number->string (lognot #b0) 2)\n" " @result{} \"-1\"\n" - "@end lisp\n") + "@end lisp") #define FUNC_NAME s_scm_lognot { return scm_difference (SCM_MAKINUM (-1L), n); @@ -1108,8 +1109,9 @@ SCM_DEFINE (scm_lognot, "lognot", 1, 0, 0, SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0, (SCM n, SCM k), - "Returns @var{n} raised to the non-negative integer exponent @var{k}.\n\n" - "Example:\n" + "Return @var{n} raised to the non-negative integer exponent\n" + "@var{k}.\n" + "\n" "@lisp\n" "(integer-expt 2 5)\n" " @result{} 32\n" @@ -1148,21 +1150,20 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0, SCM_DEFINE (scm_ash, "ash", 2, 0, 0, (SCM n, SCM cnt), - "The function ash performs an arithmetic shift left by @var{CNT}\n" - "bits (or shift right, if @var{cnt} is negative).\n" - "'Arithmetic' means, that the function does not guarantee to\n" - "keep the bit structure of @var{n}, but rather guarantees that\n" - "the result will always be rounded towards minus infinity.\n" - "Therefore, the results of ash and a corresponding bitwise\n" - "shift will differ if N is negative.\n\n" + "The function ash performs an arithmetic shift left by @var{cnt}\n" + "bits (or shift right, if @var{cnt} is negative). 'Arithmetic'\n" + "means, that the function does not guarantee to keep the bit\n" + "structure of @var{n}, but rather guarantees that the result\n" + "will always be rounded towards minus infinity. Therefore, the\n" + "results of ash and a corresponding bitwise shift will differ if\n" + "@var{n} is negative.\n" + "\n" "Formally, the function returns an integer equivalent to\n" - "@code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}.\n\n" - "Example:\n" + "@code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}.\n" + "\n" "@lisp\n" - "(number->string (ash #b1 3) 2)\n" - " @result{} \"1000\"\n" - "(number->string (ash #b1010 -1) 2)\n" - " @result{} \"101\"\n" + "(number->string (ash #b1 3) 2) @result{} \"1000\"\n" + "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n" "@end lisp") #define FUNC_NAME s_scm_ash { @@ -1207,10 +1208,10 @@ SCM_DEFINE (scm_ash, "ash", 2, 0, 0, SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0, (SCM n, SCM start, SCM end), - "Returns the integer composed of the @var{start} (inclusive) through\n" - "@var{end} (exclusive) bits of @var{n}. The @var{start}th bit becomes\n" - "the 0-th bit in the result.@refill\n\n" - "Example:\n" + "Return the integer composed of the @var{start} (inclusive)\n" + "through @var{end} (exclusive) bits of @var{n}. The\n" + "@var{start}th bit becomes the 0-th bit in the result.\n" + "\n" "@lisp\n" "(number->string (bit-extract #b1101101010 0 4) 2)\n" " @result{} \"1010\"\n" @@ -1276,11 +1277,11 @@ static const char scm_logtab[] = { SCM_DEFINE (scm_logcount, "logcount", 1, 0, 0, (SCM n), - "Returns the number of bits in integer @var{n}. If integer is positive,\n" - "the 1-bits in its binary representation are counted. If negative, the\n" - "0-bits in its two's-complement binary representation are counted. If 0,\n" - "0 is returned.\n\n" - "Example:\n" + "Return the number of bits in integer @var{n}. If integer is\n" + "positive, the 1-bits in its binary representation are counted.\n" + "If negative, the 0-bits in its two's-complement binary\n" + "representation are counted. If 0, 0 is returned.\n" + "\n" "@lisp\n" "(logcount #b10101010)\n" " @result{} 4\n" @@ -1330,8 +1331,8 @@ static const char scm_ilentab[] = { SCM_DEFINE (scm_integer_length, "integer-length", 1, 0, 0, (SCM n), - "Returns the number of bits neccessary to represent @var{n}.\n\n" - "Example:\n" + "Return the number of bits neccessary to represent @var{n}.\n" + "\n" "@lisp\n" "(integer-length #b10101010)\n" " @result{} 8\n" @@ -2863,7 +2864,7 @@ scm_istring2number (char *str, long len, long radix) SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0, (SCM string, SCM radix), - "Returns a number of the maximally precise representation\n" + "Return a number of the maximally precise representation\n" "expressed by the given @var{string}. @var{radix} must be an\n" "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n" "is a default radix that may be overridden by an explicit radix\n" @@ -4228,7 +4229,7 @@ scm_angle (SCM z) SCM_DEFINE (scm_inexact_to_exact, "inexact->exact", 1, 0, 0, (SCM z), - "Returns an exact number that is numerically closest to @var{z}.") + "Return an exact number that is numerically closest to @var{z}.") #define FUNC_NAME s_scm_inexact_to_exact { if (SCM_INUMP (z)) { diff --git a/libguile/objprop.c b/libguile/objprop.c index 17f935e94..41a766c1a 100644 --- a/libguile/objprop.c +++ b/libguile/objprop.c @@ -68,14 +68,14 @@ SCM_DEFINE (scm_object_properties, "object-properties", 1, 0, 0, SCM_DEFINE (scm_set_object_properties_x, "set-object-properties!", 2, 0, 0, - (SCM obj, SCM plist), + (SCM obj, SCM alist), "@deffnx primitive set-procedure-properties! obj alist\n" "Set @var{obj}'s property list to @var{alist}.") #define FUNC_NAME s_scm_set_object_properties_x { - SCM handle = scm_hashq_create_handle_x (scm_object_whash, obj, plist); - SCM_SETCDR (handle, plist); - return plist; + SCM handle = scm_hashq_create_handle_x (scm_object_whash, obj, alist); + SCM_SETCDR (handle, alist); + return alist; } #undef FUNC_NAME @@ -92,10 +92,10 @@ SCM_DEFINE (scm_object_property, "object-property", 2, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_set_object_property_x, "set-object-property!", 3, 0, 0, - (SCM obj, SCM key, SCM val), + (SCM obj, SCM key, SCM value), "@deffnx primitive set-procedure-property! obj key value\n" - "In @var{obj}'s property list, set the property named @var{key} to\n" - "@var{value}.") + "In @var{obj}'s property list, set the property named @var{key}\n" + "to @var{value}.") #define FUNC_NAME s_scm_set_object_property_x { SCM h; @@ -104,14 +104,14 @@ SCM_DEFINE (scm_set_object_property_x, "set-object-property!", 3, 0, 0, SCM_DEFER_INTS; assoc = scm_assq (key, SCM_CDR (h)); if (SCM_NIMP (assoc)) - SCM_SETCDR (assoc, val); + SCM_SETCDR (assoc, value); else { - assoc = scm_acons (key, val, SCM_CDR (h)); + assoc = scm_acons (key, value, SCM_CDR (h)); SCM_SETCDR (h, assoc); } SCM_ALLOW_INTS; - return val; + return value; } #undef FUNC_NAME diff --git a/libguile/pairs.c b/libguile/pairs.c index 070d08da2..0dee9b6f6 100644 --- a/libguile/pairs.c +++ b/libguile/pairs.c @@ -56,9 +56,9 @@ SCM_DEFINE (scm_cons, "cons", 2, 0, 0, (SCM x, SCM y), - "Returns a newly allocated pair whose car is @var{x} and whose cdr is\n" - "@var{y}. The pair is guaranteed to be different (in the sense of\n" - "@code{eqv?}) from every previously existing object.") + "Return a newly allocated pair whose car is @var{x} and whose\n" + "cdr is @var{y}. The pair is guaranteed to be different (in the\n" + "sense of @code{eq?}) from every previously existing object.") #define FUNC_NAME s_scm_cons { SCM z; @@ -90,7 +90,8 @@ scm_cons2 (SCM w, SCM x, SCM y) SCM_DEFINE (scm_pair_p, "pair?", 1, 0, 0, (SCM x), - "Returns @code{#t} if @var{x} is a pair; otherwise returns @code{#f}.") + "Return @code{#t} if @var{x} is a pair; otherwise return\n" + "@code{#f}.") #define FUNC_NAME s_scm_pair_p { return SCM_BOOL (SCM_CONSP (x)); diff --git a/libguile/ports.c b/libguile/ports.c index c480b7fc8..0762733f4 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -230,20 +230,20 @@ scm_set_port_input_waiting (long tc, int (*input_waiting) (SCM)) SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0, - (SCM port), - "Returns @code{#t} if a character is ready on input @var{port} and\n" - "returns @code{#f} otherwise. If @code{char-ready?} returns @code{#t}\n" - "then the next @code{read-char} operation on @var{port} is\n" - "guaranteed not to hang. If @var{port} is a file port at end of\n" - "file then @code{char-ready?} returns @code{#t}.\n" - "@footnote{@code{char-ready?} exists to make it possible for a\n" - "program to accept characters from interactive ports without getting\n" - "stuck waiting for input. Any input editors associated with such ports\n" - "must make sure that characters whose existence has been asserted by\n" - "@code{char-ready?} cannot be rubbed out. If @code{char-ready?} were to\n" - "return @code{#f} at end of file, a port at end of file would be\n" - "indistinguishable from an interactive port that has no ready\n" - "characters.}") + (SCM port), + "Return @code{#t} if a character is ready on input @var{port}\n" + "and return @code{#f} otherwise. If @code{char-ready?} returns\n" + "@code{#t} then the next @code{read-char} operation on\n" + "@var{port} is guaranteed not to hang. If @var{port} is a file\n" + "port at end of file then @code{char-ready?} returns @code{#t}.\n" + "@footnote{@code{char-ready?} exists to make it possible for a\n" + "program to accept characters from interactive ports without\n" + "getting stuck waiting for input. Any input editors associated\n" + "with such ports must make sure that characters whose existence\n" + "has been asserted by @code{char-ready?} cannot be rubbed out.\n" + "If @code{char-ready?} were to return @code{#f} at end of file,\n" + "a port at end of file would be indistinguishable from an\n" + "interactive port that has no ready characters.}") #define FUNC_NAME s_scm_char_ready_p { scm_port *pt; @@ -309,7 +309,7 @@ size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len) SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, (SCM port), "Drain @var{port}'s read buffers (including any pushed-back\n" - "characters) and returns the content as a single string.") + "characters) and return the content as a single string.") #define FUNC_NAME s_scm_drain_input { SCM result; @@ -500,7 +500,7 @@ scm_remove_from_port_table (SCM port) SCM_DEFINE (scm_pt_size, "pt-size", 0, 0, 0, (), - "Returns the number of ports in the port table. @code{pt-size}\n" + "Return the number of ports in the port table. @code{pt-size}\n" "is only included in @code{--enable-guile-debug} builds.") #define FUNC_NAME s_scm_pt_size { @@ -510,7 +510,7 @@ SCM_DEFINE (scm_pt_size, "pt-size", 0, 0, 0, SCM_DEFINE (scm_pt_member, "pt-member", 1, 0, 0, (SCM index), - "Returns the port at @var{index} in the port table.\n" + "Return the port at @var{index} in the port table.\n" "@code{pt-member} is only included in\n" "@code{--enable-guile-debug} builds.") #define FUNC_NAME s_scm_pt_member @@ -553,7 +553,7 @@ scm_revealed_count (SCM port) SCM_DEFINE (scm_port_revealed, "port-revealed", 1, 0, 0, (SCM port), - "Returns the revealed count for @var{port}.") + "Return the revealed count for @var{port}.") #define FUNC_NAME s_scm_port_revealed { port = SCM_COERCE_OUTPORT (port); @@ -606,10 +606,10 @@ scm_mode_bits (char *modes) SCM_DEFINE (scm_port_mode, "port-mode", 1, 0, 0, (SCM port), - "Returns the port modes associated with the open port @var{port}. These\n" - "will not necessarily be identical to the modes used when the port was\n" - "opened, since modes such as \"append\" which are used only during\n" - "port creation are not retained.") + "Return the port modes associated with the open port @var{port}.\n" + "These will not necessarily be identical to the modes used when\n" + "the port was opened, since modes such as \"append\" which are\n" + "used only during port creation are not retained.") #define FUNC_NAME s_scm_port_mode { char modes[4]; @@ -641,12 +641,12 @@ SCM_DEFINE (scm_port_mode, "port-mode", 1, 0, 0, */ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0, (SCM port), - "Close the specified port object. Returns @code{#t} if it successfully\n" - "closes a port or @code{#f} if it was already\n" - "closed. An exception may be raised if an error occurs, for example\n" - "when flushing buffered output.\n" - "See also @ref{Ports and File Descriptors, close}, for a procedure\n" - "which can close file descriptors.") + "Close the specified port object. Return @code{#t} if it\n" + "successfully closes a port or @code{#f} if it was already\n" + "closed. An exception may be raised if an error occurs, for\n" + "example when flushing buffered output. See also @ref{Ports and\n" + "File Descriptors, close}, for a procedure which can close file\n" + "descriptors.") #define FUNC_NAME s_scm_close_port { scm_sizet i; @@ -786,9 +786,9 @@ SCM_DEFINE (scm_close_all_ports_except, "close-all-ports-except", 0, 0, 1, SCM_DEFINE (scm_input_port_p, "input-port?", 1, 0, 0, (SCM x), - "Returns @code{#t} if @var{x} is an input port, otherwise returns\n" - "@code{#f}. Any object satisfying this predicate also satisfies\n" - "@code{port?}.") + "Return @code{#t} if @var{x} is an input port, otherwise return\n" + "@code{#f}. Any object satisfying this predicate also satisfies\n" + "@code{port?}.") #define FUNC_NAME s_scm_input_port_p { if (SCM_IMP (x)) @@ -799,9 +799,9 @@ SCM_DEFINE (scm_input_port_p, "input-port?", 1, 0, 0, SCM_DEFINE (scm_output_port_p, "output-port?", 1, 0, 0, (SCM x), - "Returns @code{#t} if @var{x} is an output port, otherwise returns\n" - "@code{#f}. Any object satisfying this predicate also satisfies\n" - "@code{port?}.") + "Return @code{#t} if @var{x} is an output port, otherwise return\n" + "@code{#f}. Any object satisfying this predicate also satisfies\n" + "@code{port?}.") #define FUNC_NAME s_scm_output_port_p { if (SCM_IMP (x)) @@ -814,7 +814,7 @@ SCM_DEFINE (scm_output_port_p, "output-port?", 1, 0, 0, SCM_DEFINE (scm_port_p, "port?", 1, 0, 0, (SCM x), - "Returns a boolean indicating whether @var{x} is a port.\n" + "Return a boolean indicating whether @var{x} is a port.\n" "Equivalent to @code{(or (input-port? @var{x}) (output-port?\n" "@var{x}))}.") #define FUNC_NAME s_scm_port_p @@ -825,7 +825,8 @@ SCM_DEFINE (scm_port_p, "port?", 1, 0, 0, SCM_DEFINE (scm_port_closed_p, "port-closed?", 1, 0, 0, (SCM port), - "Returns @code{#t} if @var{port} is closed or @code{#f} if it is open.") + "Return @code{#t} if @var{port} is closed or @code{#f} if it is\n" + "open.") #define FUNC_NAME s_scm_port_closed_p { SCM_VALIDATE_PORT (1,port); @@ -835,8 +836,8 @@ SCM_DEFINE (scm_port_closed_p, "port-closed?", 1, 0, 0, SCM_DEFINE (scm_eof_object_p, "eof-object?", 1, 0, 0, (SCM x), - "Returns @code{#t} if @var{x} is an end-of-file object; otherwise\n" - "returns @code{#f}.") + "Return @code{#t} if @var{x} is an end-of-file object; otherwise\n" + "return @code{#f}.") #define FUNC_NAME s_scm_eof_object_p { return SCM_BOOL(SCM_EOF_OBJECT_P (x)); @@ -884,9 +885,9 @@ SCM_DEFINE (scm_flush_all_ports, "flush-all-ports", 0, 0, 0, SCM_DEFINE (scm_read_char, "read-char", 0, 1, 0, (SCM port), - "Returns the next character available from @var{port}, updating\n" - "@var{port} to point to the following character. If no more\n" - "characters are available, an end-of-file object is returned.") + "Return the next character available from @var{port}, updating\n" + "@var{port} to point to the following character. If no more\n" + "characters are available, the end-of-file object is returned.") #define FUNC_NAME s_scm_read_char { int c; @@ -1192,17 +1193,18 @@ scm_ungets (const char *s, int n, SCM port) SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0, (SCM port), - "Returns the next character available from @var{port},\n" - "@emph{without} updating @var{port} to point to the following\n" - "character. If no more characters are available, an end-of-file object\n" - "is returned.@footnote{The value returned by a call to @code{peek-char}\n" - "is the same as the value that would have been returned by a call to\n" - "@code{read-char} on the same port. The only difference is that the very\n" - "next call to @code{read-char} or @code{peek-char} on that\n" - "@var{port} will return the value returned by the preceding call to\n" - "@code{peek-char}. In particular, a call to @code{peek-char} on an\n" - "interactive port will hang waiting for input whenever a call to\n" - "@code{read-char} would have hung.}") + "Return the next character available from @var{port},\n" + "@emph{without} updating @var{port} to point to the following\n" + "character. If no more characters are available, the\n" + "end-of-file object is returned.@footnote{The value returned by\n" + "a call to @code{peek-char} is the same as the value that would\n" + "have been returned by a call to @code{read-char} on the same\n" + "port. The only difference is that the very next call to\n" + "@code{read-char} or @code{peek-char} on that @var{port} will\n" + "return the value returned by the preceding call to\n" + "@code{peek-char}. In particular, a call to @code{peek-char} on\n" + "an interactive port will hang waiting for input whenever a call\n" + "to @code{read-char} would have hung.}") #define FUNC_NAME s_scm_peek_char { int c; @@ -1262,11 +1264,13 @@ SCM_DEFINE (scm_unread_string, "unread-string", 2, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_seek, "seek", 3, 0, 0, - (SCM object, SCM offset, SCM whence), - "Sets the current position of @var{fd/port} to the integer @var{offset},\n" - "which is interpreted according to the value of @var{whence}.\n\n" - "One of the following variables should be supplied\n" - "for @var{whence}:\n" + (SCM fd_port, SCM offset, SCM whence), + "Sets the current position of @var{fd/port} to the integer\n" + "@var{offset}, which is interpreted according to the value of\n" + "@var{whence}.\n" + "\n" + "One of the following variables should be supplied for\n" + "@var{whence}:\n" "@defvar SEEK_SET\n" "Seek from the beginning of the file.\n" "@end defvar\n" @@ -1275,40 +1279,41 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, "@end defvar\n" "@defvar SEEK_END\n" "Seek from the end of the file.\n" - "@end defvar\n\n" - "If @var{fd/port} is a file descriptor, the underlying system call is\n" - "@code{lseek}. @var{port} may be a string port.\n\n" - "The value returned is the new position in the file. This means that\n" - "the current position of a port can be obtained using:\n" - "@smalllisp\n" + "@end defvar\n" + "If @var{fd/port} is a file descriptor, the underlying system\n" + "call is @code{lseek}. @var{port} may be a string port.\n" + "\n" + "The value returned is the new position in the file. This means\n" + "that the current position of a port can be obtained using:\n" + "@lisp\n" "(seek port 0 SEEK_CUR)\n" - "@end smalllisp") + "@end lisp") #define FUNC_NAME s_scm_seek { off_t off; off_t rv; int how; - object = SCM_COERCE_OUTPORT (object); + fd_port = SCM_COERCE_OUTPORT (fd_port); off = SCM_NUM2LONG (2, offset); SCM_VALIDATE_INUM_COPY (3, whence, how); if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END) SCM_OUT_OF_RANGE (3, whence); - if (SCM_OPPORTP (object)) + if (SCM_OPPORTP (fd_port)) { - scm_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (object); + scm_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (fd_port); if (!ptob->seek) SCM_MISC_ERROR ("port is not seekable", - scm_cons (object, SCM_EOL)); + scm_cons (fd_port, SCM_EOL)); else - rv = ptob->seek (object, off, how); + rv = ptob->seek (fd_port, off, how); } else /* file descriptor?. */ { - SCM_VALIDATE_INUM (1,object); - rv = lseek (SCM_INUM (object), off, how); + SCM_VALIDATE_INUM (1,fd_port); + rv = lseek (SCM_INUM (fd_port), off, how); if (rv == -1) SCM_SYSERROR; } @@ -1318,12 +1323,12 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, (SCM object, SCM length), - "Truncates the object referred to by @var{obj} to at most @var{size} bytes.\n" - "@var{obj} can be a string containing a file name or an integer file\n" - "descriptor or a port. @var{size} may be omitted if @var{obj} is not\n" - "a file name, in which case the truncation occurs at the current port.\n" - "position.\n\n" - "The return value is unspecified.") + "Truncates the object referred to by @var{object} to at most\n" + "@var{length} bytes. @var{object} can be a string containing a\n" + "file name or an integer file descriptor or a port.\n" + "@var{length} may be omitted if @var{object} is not a file name,\n" + "in which case the truncation occurs at the current port.\n" + "position. The return value is unspecified.") #define FUNC_NAME s_scm_truncate_file { int rv; diff --git a/libguile/posix.c b/libguile/posix.c index d1d54b42b..a3f034e71 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -186,19 +186,19 @@ SCM_SYMBOL (sym_write_pipe, "write pipe"); SCM_DEFINE (scm_pipe, "pipe", 0, 0, 0, (), - "Returns a newly created pipe: a pair of ports which are linked\n" - "together on the local machine. The CAR is the input port and\n" - "the CDR is the output port. Data written (and flushed) to the\n" - "output port can be read from the input port.\n" - "Pipes are commonly used for communication with a newly\n" - "forked child process. The need to flush the output port\n" - "can be avoided by making it unbuffered using @code{setvbuf}.\n\n" - "Writes occur atomically provided the size of the data in\n" - "bytes is not greater than the value of @code{PIPE_BUF}\n" - "Note that the output port is likely to block if too much data\n" - "(typically equal to @code{PIPE_BUF}) has been written but not\n" - "yet read from the input port\n" - ) + "Return a newly created pipe: a pair of ports which are linked\n" + "together on the local machine. The @emph{car} is the input\n" + "port and the @emph{cdr} is the output port. Data written (and\n" + "flushed) to the output port can be read from the input port.\n" + "Pipes are commonly used for communication with a newly forked\n" + "child process. The need to flush the output port can be\n" + "avoided by making it unbuffered using @code{setvbuf}.\n" + "\n" + "Writes occur atomically provided the size of the data in bytes\n" + "is not greater than the value of @code{PIPE_BUF}. Note that\n" + "the output port is likely to block if too much data (typically\n" + "equal to @code{PIPE_BUF}) has been written but not yet read\n" + "from the input port.") #define FUNC_NAME s_scm_pipe { int fd[2], rv; @@ -218,7 +218,8 @@ SCM_DEFINE (scm_pipe, "pipe", 0, 0, 0, #ifdef HAVE_GETGROUPS SCM_DEFINE (scm_getgroups, "getgroups", 0, 0, 0, (), - "Returns a vector of integers representing the current supplimentary group IDs.") + "Return a vector of integers representing the current\n" + "supplimentary group IDs.") #define FUNC_NAME s_scm_getgroups { SCM ans; @@ -473,9 +474,9 @@ SCM_DEFINE (scm_waitpid, "waitpid", 1, 1, 0, SCM_DEFINE (scm_status_exit_val, "status:exit-val", 1, 0, 0, (SCM status), - "Returns the exit status value, as would be\n" - "set if a process ended normally through a\n" - "call to @code{exit} or @code{_exit}, if any, otherwise @code{#f}.") + "Return the exit status value, as would be set if a process\n" + "ended normally through a call to @code{exit} or @code{_exit},\n" + "if any, otherwise @code{#f}.") #define FUNC_NAME s_scm_status_exit_val { int lstatus; @@ -494,8 +495,8 @@ SCM_DEFINE (scm_status_exit_val, "status:exit-val", 1, 0, 0, SCM_DEFINE (scm_status_term_sig, "status:term-sig", 1, 0, 0, (SCM status), - "Returns the signal number which terminated the\n" - "process, if any, otherwise @code{#f}.") + "Return the signal number which terminated the process, if any,\n" + "otherwise @code{#f}.") #define FUNC_NAME s_scm_status_term_sig { int lstatus; @@ -512,8 +513,8 @@ SCM_DEFINE (scm_status_term_sig, "status:term-sig", 1, 0, 0, SCM_DEFINE (scm_status_stop_sig, "status:stop-sig", 1, 0, 0, (SCM status), - "Returns the signal number which stopped the\n" - "process, if any, otherwise @code{#f}.") + "Return the signal number which stopped the process, if any,\n" + "otherwise @code{#f}.") #define FUNC_NAME s_scm_status_stop_sig { int lstatus; @@ -530,7 +531,8 @@ SCM_DEFINE (scm_status_stop_sig, "status:stop-sig", 1, 0, 0, SCM_DEFINE (scm_getppid, "getppid", 0, 0, 0, (), - "Returns an integer representing the process ID of the parent process.") + "Return an integer representing the process ID of the parent\n" + "process.") #define FUNC_NAME s_scm_getppid { return SCM_MAKINUM (0L + getppid ()); @@ -541,7 +543,7 @@ SCM_DEFINE (scm_getppid, "getppid", 0, 0, 0, SCM_DEFINE (scm_getuid, "getuid", 0, 0, 0, (), - "Returns an integer representing the current real user ID.") + "Return an integer representing the current real user ID.") #define FUNC_NAME s_scm_getuid { return SCM_MAKINUM (0L + getuid ()); @@ -552,7 +554,7 @@ SCM_DEFINE (scm_getuid, "getuid", 0, 0, 0, SCM_DEFINE (scm_getgid, "getgid", 0, 0, 0, (), - "Returns an integer representing the current real group ID.") + "Return an integer representing the current real group ID.") #define FUNC_NAME s_scm_getgid { return SCM_MAKINUM (0L + getgid ()); @@ -563,10 +565,10 @@ SCM_DEFINE (scm_getgid, "getgid", 0, 0, 0, SCM_DEFINE (scm_geteuid, "geteuid", 0, 0, 0, (), - "Returns an integer representing the current effective user ID.\n" + "Return an integer representing the current effective user ID.\n" "If the system does not support effective IDs, then the real ID\n" - "is returned. @code{(feature? 'EIDs)} reports whether the system\n" - "supports effective IDs.") + "is returned. @code{(feature? 'EIDs)} reports whether the\n" + "system supports effective IDs.") #define FUNC_NAME s_scm_geteuid { #ifdef HAVE_GETEUID @@ -581,10 +583,10 @@ SCM_DEFINE (scm_geteuid, "geteuid", 0, 0, 0, SCM_DEFINE (scm_getegid, "getegid", 0, 0, 0, (), - "Returns an integer representing the current effective group ID.\n" + "Return an integer representing the current effective group ID.\n" "If the system does not support effective IDs, then the real ID\n" - "is returned. @code{(feature? 'EIDs)} reports whether the system\n" - "supports effective IDs.") + "is returned. @code{(feature? 'EIDs)} reports whether the\n" + "system supports effective IDs.") #define FUNC_NAME s_scm_getegid { #ifdef HAVE_GETEUID @@ -675,7 +677,7 @@ SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0, SCM_DEFINE (scm_getpgrp, "getpgrp", 0, 0, 0, (), - "Returns an integer representing the current process group ID.\n" + "Return an integer representing the current process group ID.\n" "This is the POSIX definition, not BSD.") #define FUNC_NAME s_scm_getpgrp { @@ -724,8 +726,8 @@ SCM_DEFINE (scm_setsid, "setsid", 0, 0, 0, SCM_DEFINE (scm_ttyname, "ttyname", 1, 0, 0, (SCM port), - "Returns a string with the name of the serial terminal device underlying\n" - "@var{port}.") + "Return a string with the name of the serial terminal device\n" + "underlying @var{port}.") #define FUNC_NAME s_scm_ttyname { char *ans; @@ -747,8 +749,8 @@ SCM_DEFINE (scm_ttyname, "ttyname", 1, 0, 0, #ifdef HAVE_CTERMID SCM_DEFINE (scm_ctermid, "ctermid", 0, 0, 0, (), - "Returns a string containing the file name of the controlling terminal\n" - "for the current process.") + "Return a string containing the file name of the controlling\n" + "terminal for the current process.") #define FUNC_NAME s_scm_ctermid { char *result = ctermid (NULL); @@ -762,9 +764,10 @@ SCM_DEFINE (scm_ctermid, "ctermid", 0, 0, 0, #ifdef HAVE_TCGETPGRP SCM_DEFINE (scm_tcgetpgrp, "tcgetpgrp", 1, 0, 0, (SCM port), - "Returns the process group ID of the foreground\n" - "process group associated with the terminal open on the file descriptor\n" - "underlying @var{port}.\n\n" + "Return the process group ID of the foreground process group\n" + "associated with the terminal open on the file descriptor\n" + "underlying @var{port}.\n" + "\n" "If there is no foreground process group, the return value is a\n" "number greater than 1 that does not match the process group ID\n" "of any existing process group. This can happen if all of the\n" @@ -964,8 +967,8 @@ SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0, #ifdef HAVE_UNAME SCM_DEFINE (scm_uname, "uname", 0, 0, 0, (), - "Returns an object with some information about the computer system the\n" - "program is running on.") + "Return an object with some information about the computer\n" + "system the program is running on.") #define FUNC_NAME s_scm_uname { struct utsname buf; @@ -989,12 +992,13 @@ SCM_DEFINE (scm_uname, "uname", 0, 0, 0, SCM_DEFINE (scm_environ, "environ", 0, 1, 0, (SCM env), - "If @var{env} is omitted, returns the current environment as a list of strings.\n" - "Otherwise it sets the current environment, which is also the\n" - "default environment for child processes, to the supplied list of strings.\n" - "Each member of @var{env} should be of the form\n" - "@code{NAME=VALUE} and values of @code{NAME} should not be duplicated.\n" - "If @var{env} is supplied then the return value is unspecified.") + "If @var{env} is omitted, return the current environment (in the\n" + "Unix sense) as a list of strings. Otherwise set the current\n" + "environment, which is also the default environment for child\n" + "processes, to the supplied list of strings. Each member of\n" + "@var{env} should be of the form @code{NAME=VALUE} and values of\n" + "@code{NAME} should not be duplicated. If @var{env} is supplied\n" + "then the return value is unspecified.") #define FUNC_NAME s_scm_environ { if (SCM_UNBNDP (env)) @@ -1028,11 +1032,11 @@ SCM_DEFINE (scm_environ, "environ", 0, 1, 0, SCM_DEFINE (scm_tmpnam, "tmpnam", 0, 0, 0, (), - "tmpnam returns a name in the file system that does not match\n" - "any existing file. However there is no guarantee that\n" - "another process will not create the file after tmpnam\n" - "is called. Care should be taken if opening the file,\n" - "e.g., use the O_EXCL open flag or use @code{mkstemp!} instead.") + "Return a name in the file system that does not match any\n" + "existing file. However there is no guarantee that another\n" + "process will not create the file after @code{tmpnam} is called.\n" + "Care should be taken if opening the file, e.g., use the\n" + "@code{O_EXCL} open flag or use @code{mkstemp!} instead.") #define FUNC_NAME s_scm_tmpnam { char name[L_tmpnam]; @@ -1050,12 +1054,11 @@ SCM_DEFINE (scm_tmpnam, "tmpnam", 0, 0, 0, SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0, (SCM tmpl), - "mkstemp creates a new unique file in the file system and\n" - "returns a new buffered port open for reading and writing to\n" - "the file. @var{tmpl} is a string specifying where the\n" - "file should be created: it must end with @code{XXXXXX}\n" - "and will be changed in place to return the name of the\n" - "temporary file.\n") + "Create a new unique file in the file system and returns a new\n" + "buffered port open for reading and writing to the file.\n" + "@var{tmpl} is a string specifying where the file should be\n" + "created: it must end with @code{XXXXXX} and will be changed in\n" + "place to return the name of the temporary file.") #define FUNC_NAME s_scm_mkstemp { char *c_tmpl; @@ -1072,18 +1075,16 @@ SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0, SCM_DEFINE (scm_utime, "utime", 1, 2, 0, (SCM pathname, SCM actime, SCM modtime), - "@code{utime} sets the access and modification times for\n" - "the file named by @var{path}. If @var{actime} or @var{modtime}\n" - "is not supplied, then the current time is used.\n" - "@var{actime} and @var{modtime}\n" - "must be integer time values as returned by the @code{current-time}\n" - "procedure.\n\n" - "E.g.,\n\n" - "@smalllisp\n" + "@code{utime} sets the access and modification times for the\n" + "file named by @var{path}. If @var{actime} or @var{modtime} is\n" + "not supplied, then the current time is used. @var{actime} and\n" + "@var{modtime} must be integer time values as returned by the\n" + "@code{current-time} procedure.\n" + "@lisp\n" "(utime \"foo\" (- (current-time) 3600))\n" - "@end smalllisp\n\n" - "will set the access time to one hour in the past and the modification\n" - "time to the current time.") + "@end lisp\n" + "will set the access time to one hour in the past and the\n" + "modification time to the current time.") #define FUNC_NAME s_scm_utime { int rv; @@ -1110,17 +1111,17 @@ SCM_DEFINE (scm_utime, "utime", 1, 2, 0, SCM_DEFINE (scm_access, "access?", 2, 0, 0, (SCM path, SCM how), - "Returns @code{#t} if @var{path} corresponds to an existing\n" - "file and the current process\n" - "has the type of access specified by @var{how}, otherwise \n" - "@code{#f}.\n" - "@var{how} should be specified\n" - "using the values of the variables listed below. Multiple values can\n" - "be combined using a bitwise or, in which case @code{#t} will only\n" - "be returned if all accesses are granted.\n\n" - "Permissions are checked using the real id of the current process,\n" - "not the effective id, although it's the effective id which determines\n" - "whether the access would actually be granted.\n\n" + "Return @code{#t} if @var{path} corresponds to an existing file\n" + "and the current process has the type of access specified by\n" + "@var{how}, otherwise @code{#f}. @var{how} should be specified\n" + "using the values of the variables listed below. Multiple\n" + "values can be combined using a bitwise or, in which case\n" + "@code{#t} will only be returned if all accesses are granted.\n" + "\n" + "Permissions are checked using the real id of the current\n" + "process, not the effective id, although it's the effective id\n" + "which determines whether the access would actually be granted.\n" + "\n" "@defvar R_OK\n" "test for read permission.\n" "@end defvar\n" @@ -1147,7 +1148,7 @@ SCM_DEFINE (scm_access, "access?", 2, 0, 0, SCM_DEFINE (scm_getpid, "getpid", 0, 0, 0, (), - "Returns an integer representing the current process ID.") + "Return an integer representing the current process ID.") #define FUNC_NAME s_scm_getpid { return SCM_MAKINUM ((unsigned long) getpid ()); @@ -1187,15 +1188,15 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0, #ifdef HAVE_SETLOCALE SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0, (SCM category, SCM locale), - "If @var{locale} is omitted, returns the current value of the specified\n" - "locale category \n" - "as a system-dependent string.\n" - "@var{category} should be specified using the values @code{LC_COLLATE},\n" - "@code{LC_ALL} etc.\n\n" - "Otherwise the specified locale category is set to\n" - "the string @var{locale}\n" - "and the new value is returned as a system-dependent string. If @var{locale}\n" - "is an empty string, the locale will be set using envirionment variables.") + "If @var{locale} is omitted, return the current value of the\n" + "specified locale category as a system-dependent string.\n" + "@var{category} should be specified using the values\n" + "@code{LC_COLLATE}, @code{LC_ALL} etc.\n" + "\n" + "Otherwise the specified locale category is set to the string\n" + "@var{locale} and the new value is returned as a\n" + "system-dependent string. If @var{locale} is an empty string,\n" + "the locale will be set using envirionment variables.") #define FUNC_NAME s_scm_setlocale { char *clocale; @@ -1233,9 +1234,9 @@ SCM_DEFINE (scm_mknod, "mknod", 4, 0, 0, "to. Its exact interpretation depends on the kind of special file\n" "being created.\n\n" "E.g.,\n" - "@example\n" + "@lisp\n" "(mknod \"/dev/fd0\" 'block-special #o660 (+ (* 2 256) 2))\n" - "@end example\n\n" + "@end lisp\n\n" "The return value is unspecified.") #define FUNC_NAME s_scm_mknod { diff --git a/libguile/ramap.c b/libguile/ramap.c index 21e222c5b..5b50323fb 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -1686,19 +1686,19 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0, "turn, storing the result in the corresponding element. The value\n" "returned and the order of application are unspecified.\n\n" "One can implement @var{array-indexes} as\n" - "@example\n" + "@lisp\n" "(define (array-indexes array)\n" " (let ((ra (apply make-array #f (array-shape array))))\n" " (array-index-map! ra (lambda x x))\n" " ra))\n" - "@end example\n" + "@end lisp\n" "Another example:\n" - "@example\n" + "@lisp\n" "(define (apl:index-generator n)\n" " (let ((v (make-uniform-vector n 1)))\n" " (array-index-map! v (lambda (i) i))\n" " v))\n" - "@end example") + "@end lisp") #define FUNC_NAME s_scm_array_index_map_x { scm_sizet i; @@ -1979,11 +1979,12 @@ scm_raequal (SCM ra0, SCM ra1) /* GJB:FIXME:: Why not use SCM_DEFINE1 for array-equal? */ SCM_DEFINE1 (scm_array_equal_p, "array-equal?", scm_tc7_rpsubr, (SCM ra0, SCM ra1), - "Returns @code{#t} iff all arguments are arrays with the same shape, the\n" - "same type, and have corresponding elements which are either\n" - "@code{equal?} or @code{array-equal?}. This function differs from\n" - "@code{equal?} in that a one dimensional shared array may be\n" - "@var{array-equal?} but not @var{equal?} to a vector or uniform vector.") + "Return @code{#t} iff all arguments are arrays with the same\n" + "shape, the same type, and have corresponding elements which are\n" + "either @code{equal?} or @code{array-equal?}. This function\n" + "differs from @code{equal?} in that a one dimensional shared\n" + "array may be @var{array-equal?} but not @var{equal?} to a\n" + "vector or uniform vector.") #define FUNC_NAME s_scm_array_equal_p { } diff --git a/libguile/random.c b/libguile/random.c index f06d984f2..384731478 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -415,7 +415,8 @@ SCM_DEFINE (scm_seed_to_random_state, "seed->random-state", 1, 0, 0, SCM_DEFINE (scm_random_uniform, "random:uniform", 0, 1, 0, (SCM state), - "Returns a uniformly distributed inexact real random number in [0,1).") + "Return a uniformly distributed inexact real random number in\n" + "[0,1).") #define FUNC_NAME s_scm_random_uniform { if (SCM_UNBNDP (state)) @@ -427,10 +428,10 @@ SCM_DEFINE (scm_random_uniform, "random:uniform", 0, 1, 0, SCM_DEFINE (scm_random_normal, "random:normal", 0, 1, 0, (SCM state), - "Returns an inexact real in a normal distribution.\n" - "The distribution used has mean 0 and standard deviation 1.\n" - "For a normal distribution with mean m and standard deviation\n" - "d use @code{(+ m (* d (random:normal)))}.") + "Return an inexact real in a normal distribution. The\n" + "distribution used has mean 0 and standard deviation 1. For a\n" + "normal distribution with mean m and standard deviation d use\n" + "@code{(+ m (* d (random:normal)))}.") #define FUNC_NAME s_scm_random_normal { if (SCM_UNBNDP (state)) @@ -550,8 +551,9 @@ SCM_DEFINE (scm_random_normal_vector_x, "random:normal-vector!", 1, 1, 0, SCM_DEFINE (scm_random_exp, "random:exp", 0, 1, 0, (SCM state), - "Returns an inexact real in an exponential distribution with mean 1.\n" - "For an exponential distribution with mean u use (* u (random:exp)).") + "Return an inexact real in an exponential distribution with mean\n" + "1. For an exponential distribution with mean u use (* u\n" + "(random:exp)).") #define FUNC_NAME s_scm_random_exp { if (SCM_UNBNDP (state)) diff --git a/libguile/rdelim.c b/libguile/rdelim.c index 40f65b938..3ebd39955 100644 --- a/libguile/rdelim.c +++ b/libguile/rdelim.c @@ -268,13 +268,13 @@ SCM_DEFINE (scm_read_line, "%read-line", 0, 1, 0, SCM_DEFINE (scm_write_line, "write-line", 1, 1, 0, (SCM obj, SCM port), - "Display @var{obj} and a newline character to @var{port}. If @var{port}\n" - "is not specified, @code{(current-output-port)} is used. This function\n" - "is equivalent to:\n\n" - "@smalllisp\n" + "Display @var{obj} and a newline character to @var{port}. If\n" + "@var{port} is not specified, @code{(current-output-port)} is\n" + "used. This function is equivalent to:\n" + "@lisp\n" "(display obj [port])\n" "(newline [port])\n" - "@end smalllisp") + "@end lisp") #define FUNC_NAME s_scm_write_line { scm_display (obj, port); diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index 5fafba687..8174217a7 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -134,49 +134,54 @@ scm_regexp_error_msg (int regerrno, regex_t *rx) } SCM_DEFINE (scm_regexp_p, "regexp?", 1, 0, 0, - (SCM x), - "Return @code{#t} if @var{obj} is a compiled regular expression, or\n" - "@code{#f} otherwise.") + (SCM obj), + "Return @code{#t} if @var{obj} is a compiled regular expression,\n" + "or @code{#f} otherwise.") #define FUNC_NAME s_scm_regexp_p { - return SCM_BOOL(SCM_RGXP (x)); + return SCM_BOOL(SCM_RGXP (obj)); } #undef FUNC_NAME SCM_DEFINE (scm_make_regexp, "make-regexp", 1, 0, 1, (SCM pat, SCM flags), - "Compile the regular expression described by @var{str}, and return the\n" - "compiled regexp structure. If @var{str} does not describe a legal\n" - "regular expression, @code{make-regexp} throws a\n" - "@code{regular-expression-syntax} error.\n\n" - "The @var{flag} arguments change the behavior of the compiled regexp.\n" - "The following flags may be supplied:\n\n" + "Compile the regular expression described by @var{pat}, and\n" + "return the compiled regexp structure. If @var{pat} does not\n" + "describe a legal regular expression, @code{make-regexp} throws\n" + "a @code{regular-expression-syntax} error.\n" + "\n" + "The @var{flags} arguments change the behavior of the compiled\n" + "regular expression. The following flags may be supplied:\n" + "\n" "@table @code\n" "@item regexp/icase\n" - "Consider uppercase and lowercase letters to be the same when matching.\n\n" + "Consider uppercase and lowercase letters to be the same when\n" + "matching.\n" "@item regexp/newline\n" - "If a newline appears in the target string, then permit the @samp{^} and\n" - "@samp{$} operators to match immediately after or immediately before the\n" - "newline, respectively. Also, the @samp{.} and @samp{[^...]} operators\n" - "will never match a newline character. The intent of this flag is to\n" - "treat the target string as a buffer containing many lines of text, and\n" - "the regular expression as a pattern that may match a single one of those\n" - "lines.\n\n" + "If a newline appears in the target string, then permit the\n" + "@samp{^} and @samp{$} operators to match immediately after or\n" + "immediately before the newline, respectively. Also, the\n" + "@samp{.} and @samp{[^...]} operators will never match a newline\n" + "character. The intent of this flag is to treat the target\n" + "string as a buffer containing many lines of text, and the\n" + "regular expression as a pattern that may match a single one of\n" + "those lines.\n" "@item regexp/basic\n" "Compile a basic (``obsolete'') regexp instead of the extended\n" - "(``modern'') regexps that are the default. Basic regexps do not\n" - "consider @samp{|}, @samp{+} or @samp{?} to be special characters, and\n" - "require the @samp{@{...@}} and @samp{(...)} metacharacters to be\n" - "backslash-escaped (@pxref{Backslash Escapes}). There are several other\n" - "differences between basic and extended regular expressions, but these\n" - "are the most significant.\n\n" + "(``modern'') regexps that are the default. Basic regexps do\n" + "not consider @samp{|}, @samp{+} or @samp{?} to be special\n" + "characters, and require the @samp{@{...@}} and @samp{(...)}\n" + "metacharacters to be backslash-escaped (@pxref{Backslash\n" + "Escapes}). There are several other differences between basic\n" + "and extended regular expressions, but these are the most\n" + "significant.\n" "@item regexp/extended\n" - "Compile an extended regular expression rather than a basic regexp. This\n" - "is the default behavior; this flag will not usually be needed. If a\n" - "call to @code{make-regexp} includes both @code{regexp/basic} and\n" - "@code{regexp/extended} flags, the one which comes last will override\n" - "the earlier one.\n" - "@end table\n") + "Compile an extended regular expression rather than a basic\n" + "regexp. This is the default behavior; this flag will not\n" + "usually be needed. If a call to @code{make-regexp} includes\n" + "both @code{regexp/basic} and @code{regexp/extended} flags, the\n" + "one which comes last will override the earlier one.\n" + "@end table") #define FUNC_NAME s_scm_make_regexp { SCM flag; @@ -220,10 +225,11 @@ SCM_DEFINE (scm_make_regexp, "make-regexp", 1, 0, 1, SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, (SCM rx, SCM str, SCM start, SCM flags), - "Match the compiled regular expression @var{regexp} against @code{str}.\n" - "If the optional integer @var{start} argument is provided, begin matching\n" - "from that position in the string. Return a match structure describing\n" - "the results of the match, or @code{#f} if no match could be found.") + "Match the compiled regular expression @var{rx} against\n" + "@code{str}. If the optional integer @var{start} argument is\n" + "provided, begin matching from that position in the string.\n" + "Return a match structure describing the results of the match,\n" + "or @code{#f} if no match could be found.") #define FUNC_NAME s_scm_regexp_exec { int status, nmatches, offset; diff --git a/libguile/root.c b/libguile/root.c index 6779f6779..a0d092030 100644 --- a/libguile/root.c +++ b/libguile/root.c @@ -334,7 +334,7 @@ SCM_DEFINE (scm_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0, "Before calling @var{thunk}, the dynamic-wind chain is un-wound back to\n" "the root and a new chain started for @var{thunk}. Therefore, this call\n" "may not do what you expect:\n\n" - "@example\n" + "@lisp\n" ";; Almost certainly a bug:\n" "(with-output-to-port\n" " some-port\n\n" @@ -344,7 +344,7 @@ SCM_DEFINE (scm_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0, " (display 'fnord)\n" " (newline))\n" " (lambda (errcode) errcode))))\n" - "@end example\n\n" + "@end lisp\n\n" "The problem is, on what port will @samp{fnord} be displayed? You\n" "might expect that because of the @code{with-output-to-port} that\n" "it will be displayed on the port bound to @code{some-port}. But it\n" diff --git a/libguile/simpos.c b/libguile/simpos.c index e847ce0d5..a03ec6c30 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -68,11 +68,13 @@ extern int system(); #ifdef HAVE_SYSTEM SCM_DEFINE (scm_system, "system", 0, 1, 0, (SCM cmd), - "Executes @var{cmd} using the operating system's \"command processor\".\n" - "Under Unix this is usually the default shell @code{sh}. The value\n" - "returned is @var{cmd}'s exit status as returned by @code{waitpid}, which\n" - "can be interpreted using the functions above.\n\n" - "If @code{system} is called without arguments, it returns a boolean\n" + "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" + "\n" + "If @code{system} is called without arguments, return a boolean\n" "indicating whether the command processor is available.") #define FUNC_NAME s_scm_system { diff --git a/libguile/socket.c b/libguile/socket.c index e923b1b18..f6b404bd3 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -84,9 +84,9 @@ SCM_DEFINE (scm_htons, "htons", 1, 0, 0, (SCM in), - "Returns a new integer from @var{value} by converting from host to\n" - "network order. @var{value} must be within the range of a C unsigned\n" - "short integer.") + "Return a new integer from @var{value} by converting from host\n" + "to network order. @var{value} must be within the range of a C\n" + "unsigned short integer.") #define FUNC_NAME s_scm_htons { unsigned short c_in; @@ -101,9 +101,9 @@ SCM_DEFINE (scm_htons, "htons", 1, 0, 0, SCM_DEFINE (scm_ntohs, "ntohs", 1, 0, 0, (SCM in), - "Returns a new integer from @var{value} by converting from network to\n" - "host order. @var{value} must be within the range of a C unsigned short\n" - "integer.") + "Return a new integer from @var{value} by converting from\n" + "network to host order. @var{value} must be within the range of\n" + "a C unsigned short integer.") #define FUNC_NAME s_scm_ntohs { unsigned short c_in; @@ -118,9 +118,9 @@ SCM_DEFINE (scm_ntohs, "ntohs", 1, 0, 0, SCM_DEFINE (scm_htonl, "htonl", 1, 0, 0, (SCM in), - "Returns a new integer from @var{value} by converting from host to\n" - "network order. @var{value} must be within the range of a C unsigned\n" - "long integer.") + "Return a new integer from @var{value} by converting from host\n" + "to network order. @var{value} must be within the range of a C\n" + "unsigned long integer.") #define FUNC_NAME s_scm_htonl { unsigned long c_in = SCM_NUM2ULONG (1,in); @@ -130,9 +130,9 @@ SCM_DEFINE (scm_htonl, "htonl", 1, 0, 0, SCM_DEFINE (scm_ntohl, "ntohl", 1, 0, 0, (SCM in), - "Returns a new integer from @var{value} by converting from network to\n" - "host order. @var{value} must be within the range of a C unsigned\n" - "long integer.") + "Return a new integer from @var{value} by converting from\n" + "network to host order. @var{value} must be within the range of\n" + "a C unsigned long integer.") #define FUNC_NAME s_scm_ntohl { unsigned long c_in = SCM_NUM2ULONG (1,in); @@ -146,16 +146,19 @@ SCM_SYMBOL (sym_socket, "socket"); SCM_DEFINE (scm_socket, "socket", 3, 0, 0, (SCM family, SCM style, SCM proto), - "Returns a new socket port of the type specified by @var{family}, @var{style}\n" - "and @var{protocol}. All three parameters are integers. Typical values\n" - "for @var{family} are the values of @code{AF_UNIX}\n" - "and @code{AF_INET}. Typical values for @var{style} are\n" - "the values of @code{SOCK_STREAM}, @code{SOCK_DGRAM} and @code{SOCK_RAW}.\n\n" + "Return a new socket port of the type specified by @var{family},\n" + "@var{style} and @var{protocol}. All three parameters are\n" + "integers. Typical values for @var{family} are the values of\n" + "@code{AF_UNIX} and @code{AF_INET}. Typical values for\n" + "@var{style} are the values of @code{SOCK_STREAM},\n" + "@code{SOCK_DGRAM} and @code{SOCK_RAW}.\n" + "\n" "@var{protocol} can be obtained from a protocol name using\n" - "@code{getprotobyname}. A value of\n" - "zero specifies the default protocol, which is usually right.\n\n" - "A single socket port cannot by used for communication until\n" - "it has been connected to another socket.") + "@code{getprotobyname}. A value of zero specifies the default\n" + "protocol, which is usually right.\n" + "\n" + "A single socket port cannot by used for communication until it\n" + "has been connected to another socket.") #define FUNC_NAME s_scm_socket { int fd; @@ -173,11 +176,11 @@ SCM_DEFINE (scm_socket, "socket", 3, 0, 0, #ifdef HAVE_SOCKETPAIR SCM_DEFINE (scm_socketpair, "socketpair", 3, 0, 0, (SCM family, SCM style, SCM proto), - "Returns a pair of connected (but unnamed) socket ports of the type specified\n" - "by @var{family}, @var{style} and @var{protocol}.\n" - "Many systems support only\n" - "socket pairs of the @code{AF_UNIX} family. Zero is likely to be\n" - "the only meaningful value for @var{protocol}.") + "Return a pair of connected (but unnamed) socket ports of the\n" + "type specified by @var{family}, @var{style} and @var{protocol}.\n" + "Many systems support only socket pairs of the @code{AF_UNIX}\n" + "family. Zero is likely to be the only meaningful value for\n" + "@var{protocol}.") #define FUNC_NAME s_scm_socketpair { int fam; @@ -199,14 +202,15 @@ SCM_DEFINE (scm_socketpair, "socketpair", 3, 0, 0, SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0, (SCM sock, SCM level, SCM optname), - "Returns the value of a particular socket option for the socket\n" - "port @var{socket}. @var{level} is an integer code for type of option\n" - "being requested, e.g., @code{SOL_SOCKET} for socket-level options.\n" - "@var{optname} is an\n" - "integer code for the option required and should be specified using one of\n" - "the symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc.\n\n" - "The returned value is typically an integer but @code{SO_LINGER} returns a\n" - "pair of integers.") + "Return the value of a particular socket option for the socket\n" + "port @var{socket}. @var{level} is an integer code for type of\n" + "option being requested, e.g., @code{SOL_SOCKET} for\n" + "socket-level options. @var{optname} is an integer code for the\n" + "option required and should be specified using one of the\n" + "symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc.\n" + "\n" + "The returned value is typically an integer but @code{SO_LINGER}\n" + "returns a pair of integers.") #define FUNC_NAME s_scm_getsockopt { int fd; @@ -663,9 +667,9 @@ SCM_DEFINE (scm_accept, "accept", 1, 0, 0, SCM_DEFINE (scm_getsockname, "getsockname", 1, 0, 0, (SCM sock), - "Returns the address of @var{socket}, in the same form as the object\n" - "returned by @code{accept}. On many systems the address of a socket\n" - "in the @code{AF_FILE} namespace cannot be read.") + "Return the address of @var{socket}, in the same form as the\n" + "object returned by @code{accept}. On many systems the address\n" + "of a socket in the @code{AF_FILE} namespace cannot be read.") #define FUNC_NAME s_scm_getsockname { int fd; @@ -689,10 +693,10 @@ SCM_DEFINE (scm_getsockname, "getsockname", 1, 0, 0, SCM_DEFINE (scm_getpeername, "getpeername", 1, 0, 0, (SCM sock), - "Returns the address of the socket that the socket @var{socket} is connected to,\n" - "in the same form as the object\n" - "returned by @code{accept}. On many systems the address of a socket\n" - "in the @code{AF_FILE} namespace cannot be read.") + "Return the address of the socket that the socket @var{socket}\n" + "is connected to, in the same form as the object returned by\n" + "@code{accept}. On many systems the address of a socket in the\n" + "@code{AF_FILE} namespace cannot be read.") #define FUNC_NAME s_scm_getpeername { int fd; @@ -778,23 +782,27 @@ SCM_DEFINE (scm_send, "send", 2, 1, 0, SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0, (SCM sock, SCM str, SCM flags, SCM start, SCM end), - "Returns data from the socket port @var{socket} and also information about\n" - "where the data was received from. @var{socket} must already\n" - "be bound to the address from which data is to be received.\n" - "@code{str}, is a string into which\n" - "the data will be written. The size of @var{str} limits the amount of\n" - "data which can be received: in the case of packet\n" - "protocols, if a packet larger than this limit is encountered then some data\n" - "will be irrevocably lost.\n\n" - "The optional @var{flags} argument is a value or\n" - "bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n" - "The value returned is a pair: the CAR is the number of bytes read from\n" - "the socket and the CDR an address object in the same form as returned by\n" - "@code{accept}.\n\n" - "The @var{start} and @var{end} arguments specify a substring of @var{str}\n" - "to which the data should be written.\n\n" - "Note that the data is read directly from the socket file descriptor:\n" - "any unread buffered port data is ignored.") + "Return data from the socket port @var{socket} and also\n" + "information about where the data was received from.\n" + "@var{socket} must already be bound to the address from which\n" + "data is to be received. @code{str}, is a string into which the\n" + "data will be written. The size of @var{str} limits the amount\n" + "of data which can be received: in the case of packet protocols,\n" + "if a packet larger than this limit is encountered then some\n" + "data will be irrevocably lost.\n" + "\n" + "The optional @var{flags} argument is a value or bitwise OR of\n" + "@code{MSG_OOB}, @code{MSG_PEEK}, @code{MSG_DONTROUTE} etc.\n" + "\n" + "The value returned is a pair: the @emph{car} is the number of\n" + "bytes read from the socket and the @emph{cdr} an address object\n" + "in the same form as returned by @code{accept}.\n" + "\n" + "The @var{start} and @var{end} arguments specify a substring of\n" + "@var{str} to which the data should be written.\n" + "\n" + "Note that the data is read directly from the socket file\n" + "descriptor: any unread buffered port data is ignored.") #define FUNC_NAME s_scm_recvfrom { int rv; diff --git a/libguile/stime.c b/libguile/stime.c index d723da8d0..ce1e6006e 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -138,7 +138,8 @@ timet scm_your_base = 0; SCM_DEFINE (scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0, (), - "Returns the number of time units since the interpreter was started.") + "Return the number of time units since the interpreter was\n" + "started.") #define FUNC_NAME s_scm_get_internal_real_time { #ifdef HAVE_FTIME @@ -163,9 +164,10 @@ SCM_DEFINE (scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0, #ifdef HAVE_TIMES SCM_DEFINE (scm_times, "times", 0, 0, 0, (void), - "Returns an object with information about real and processor time.\n" - "The following procedures accept such an object as an argument and\n" - "return a selected component:\n\n" + "Return an object with information about real and processor\n" + "time. The following procedures accept such an object as an\n" + "argument and return a selected component:\n" + "\n" "@table @code\n" "@item tms:clock\n" "The current real time, expressed as time units relative to an\n" @@ -173,12 +175,14 @@ SCM_DEFINE (scm_times, "times", 0, 0, 0, "@item tms:utime\n" "The CPU time units used by the calling process.\n" "@item tms:stime\n" - "The CPU time units used by the system on behalf of the calling process.\n" + "The CPU time units used by the system on behalf of the calling\n" + "process.\n" "@item tms:cutime\n" - "The CPU time units used by terminated child processes of the calling\n" - "process, whose status has been collected (e.g., using @code{waitpid}).\n" + "The CPU time units used by terminated child processes of the\n" + "calling process, whose status has been collected (e.g., using\n" + "@code{waitpid}).\n" "@item tms:cstime\n" - "Similarly, the CPU times units used by the system on behalf of \n" + "Similarly, the CPU times units used by the system on behalf of\n" "terminated child processes.\n" "@end table") #define FUNC_NAME s_scm_times @@ -210,8 +214,9 @@ scm_c_get_internal_run_time () SCM_DEFINE (scm_get_internal_run_time, "get-internal-run-time", 0, 0, 0, (void), - "Returns the number of time units of processor time used by the interpreter.\n" - "Both \"system\" and \"user\" time are included but subprocesses are not.") + "Return the number of time units of processor time used by the\n" + "interpreter. Both @emph{system} and @emph{user} time are\n" + "included but subprocesses are not.") #define FUNC_NAME s_scm_get_internal_run_time { return scm_long2num (scm_c_get_internal_run_time ()); @@ -220,8 +225,8 @@ SCM_DEFINE (scm_get_internal_run_time, "get-internal-run-time", 0, 0, 0, SCM_DEFINE (scm_current_time, "current-time", 0, 0, 0, (void), - "Returns the number of seconds since 1970-01-01 00:00:00 UTC, excluding\n" - "leap seconds.") + "Return the number of seconds since 1970-01-01 00:00:00 UTC,\n" + "excluding leap seconds.") #define FUNC_NAME s_scm_current_time { timet timv; @@ -236,9 +241,10 @@ SCM_DEFINE (scm_current_time, "current-time", 0, 0, 0, SCM_DEFINE (scm_gettimeofday, "gettimeofday", 0, 0, 0, (void), - "Returns a pair containing the number of seconds and microseconds since\n" - "1970-01-01 00:00:00 UTC, excluding leap seconds. Note: whether true\n" - "microsecond resolution is available depends on the operating system.") + "Return a pair containing the number of seconds and microseconds\n" + "since 1970-01-01 00:00:00 UTC, excluding leap seconds. Note:\n" + "whether true microsecond resolution is available depends on the\n" + "operating system.") #define FUNC_NAME s_scm_gettimeofday { #ifdef HAVE_GETTIMEOFDAY @@ -334,11 +340,11 @@ restorezone (SCM zone, char **oldenv, const char *subr) SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0, (SCM time, SCM zone), - "Returns an object representing the broken down components of @var{time},\n" - "an integer like the one returned by @code{current-time}. The time zone\n" - "for the calculation is optionally specified by @var{zone} (a string),\n" - "otherwise the @code{TZ} environment variable or the system default is\n" - "used.") + "Return an object representing the broken down components of\n" + "@var{time}, an integer like the one returned by\n" + "@code{current-time}. The time zone for the calculation is\n" + "optionally specified by @var{zone} (a string), otherwise the\n" + "@code{TZ} environment variable or the system default is used.") #define FUNC_NAME s_scm_localtime { timet itime; @@ -408,9 +414,9 @@ SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0, SCM_DEFINE (scm_gmtime, "gmtime", 1, 0, 0, (SCM time), - "Returns an object representing the broken down components of @var{time},\n" - "an integer like the one returned by @code{current-time}. The values\n" - "are calculated for UTC.") + "Return an object representing the broken down components of\n" + "@var{time}, an integer like the one returned by\n" + "@code{current-time}. The values are calculated for UTC.") #define FUNC_NAME s_scm_gmtime { timet itime; diff --git a/libguile/strings.c b/libguile/strings.c index cf8ddca28..70d831907 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -58,7 +58,7 @@ SCM_DEFINE (scm_string_p, "string?", 1, 0, 0, (SCM obj), - "Returns @code{#t} iff @var{obj} is a string, else returns\n" + "Return @code{#t} iff @var{obj} is a string, else returns\n" "@code{#f}.") #define FUNC_NAME s_scm_string_p { @@ -77,12 +77,12 @@ SCM_DEFINE (scm_read_only_string_p, "read-only-string?", 1, 0, 0, "Return true if @var{obj} can be read as a string,\n\n" "This illustrates the difference between @code{string?} and\n" "@code{read-only-string?}:\n\n" - "@example\n" + "@lisp\n" "(string? \"a string\") @result{} #t\n" "(string? 'a-symbol) @result{} #f\n\n" "(read-only-string? \"a string\") @result{} #t\n" "(read-only-string? 'a-symbol) @result{} #t\n" - "@end example") + "@end lisp") #define FUNC_NAME s_scm_read_only_string_p { return SCM_BOOL(SCM_ROSTRINGP (obj)); @@ -96,7 +96,7 @@ SCM_REGISTER_PROC (s_scm_list_to_string, "list->string", 1, 0, 0, scm_string); SCM_DEFINE (scm_string, "string", 0, 0, 1, (SCM chrs), "@deffnx primitive list->string chrs\n" - "Returns a newly allocated string composed of the arguments,\n" + "Return a newly allocated string composed of the arguments,\n" "@var{chrs}.") #define FUNC_NAME s_scm_string { @@ -390,14 +390,14 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, */ SCM_DEFINE (scm_make_shared_substring, "make-shared-substring", 1, 2, 0, - (SCM str, SCM frm, SCM to), - "Return a shared substring of @var{str}. The semantics are the same as\n" - "for the @code{substring} function: the shared substring returned\n" - "includes all of the text from @var{str} between indexes @var{start}\n" - "(inclusive) and @var{end} (exclusive). If @var{end} is omitted, it\n" - "defaults to the end of @var{str}. The shared substring returned by\n" - "@code{make-shared-substring} occupies the same storage space as\n" - "@var{str}.") + (SCM str, SCM start, SCM end), + "Return a shared substring of @var{str}. The semantics are the\n" + "same as for the @code{substring} function: the shared substring\n" + "returned includes all of the text from @var{str} between\n" + "indexes @var{start} (inclusive) and @var{end} (exclusive). If\n" + "@var{end} is omitted, it defaults to the end of @var{str}. The\n" + "shared substring returned by @code{make-shared-substring}\n" + "occupies the same storage space as @var{str}.") #define FUNC_NAME s_scm_make_shared_substring { long f; @@ -406,11 +406,11 @@ SCM_DEFINE (scm_make_shared_substring, "make-shared-substring", 1, 2, 0, SCM len_str; SCM_VALIDATE_ROSTRING (1,str); - SCM_VALIDATE_INUM_DEF_COPY (2,frm,0,f); - SCM_VALIDATE_INUM_DEF_COPY (3,to,SCM_ROLENGTH(str),t); + SCM_VALIDATE_INUM_DEF_COPY (2,start,0,f); + SCM_VALIDATE_INUM_DEF_COPY (3,end,SCM_ROLENGTH(str),t); - SCM_ASSERT_RANGE (2,frm,(f >= 0)); - SCM_ASSERT_RANGE (3,to, (f <= t) && (t <= SCM_ROLENGTH (str))); + SCM_ASSERT_RANGE (2,start,(f >= 0)); + SCM_ASSERT_RANGE (3,end, (f <= t) && (t <= SCM_ROLENGTH (str))); SCM_NEWCELL (answer); SCM_NEWCELL (len_str); diff --git a/libguile/strop.c b/libguile/strop.c index 9740986d2..48f3c33b6 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -104,21 +104,16 @@ SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0, "@var{str}. The optional integer arguments @var{frm} and\n" "@var{to} limit the search to a portion of the string. This\n" "procedure essentially implements the @code{index} or\n" - "@code{strchr} functions from the C library.\n\n" - "(qdocs:) Returns\n" - "the index of @var{char} in @var{str}, or @code{#f} if the\n" - "@var{char} isn't in @var{str}. If @var{frm} is given and not\n" - "@code{#f}, it is used as the starting index; if @var{to} is\n" - "given and not @code{#f}, it is used as the ending index\n" - "(exclusive).\n\n" - "@example\n" + "@code{strchr} functions from the C library.\n" + "\n" + "@lisp\n" "(string-index \"weiner\" #\\e)\n" "@result{} 1\n\n" "(string-index \"weiner\" #\\e 2)\n" "@result{} 4\n\n" "(string-index \"weiner\" #\\e 2 4)\n" "@result{} #f\n" - "@end example") + "@end lisp") #define FUNC_NAME s_scm_string_index { int pos; @@ -136,20 +131,19 @@ SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0, SCM_DEFINE (scm_string_rindex, "string-rindex", 2, 2, 0, (SCM str, SCM chr, SCM frm, SCM to), - "Like @code{string-index}, but search from the right of the string rather\n" - "than from the left. This procedure essentially implements the\n" - "@code{rindex} or @code{strrchr} functions from the C library.\n\n" - "(qdocs:) The same as @code{string-index}, except it gives the rightmost occurance\n" - "of @var{char} in the range [@var{frm}, @var{to}-1], which defaults to\n" - "the entire string.\n\n" - "@example\n" + "Like @code{string-index}, but search from the right of the\n" + "string rather than from the left. This procedure essentially\n" + "implements the @code{rindex} or @code{strrchr} functions from\n" + "the C library.\n" + "\n" + "@lisp\n" "(string-rindex \"weiner\" #\\e)\n" "@result{} 4\n\n" "(string-rindex \"weiner\" #\\e 2 4)\n" "@result{} #f\n\n" "(string-rindex \"weiner\" #\\e 2 5)\n" "@result{} 4\n" - "@end example") + "@end lisp") #define FUNC_NAME s_scm_string_rindex { int pos; @@ -179,7 +173,7 @@ Moves a substring of @var{str1}, from @var{start1} to @var{end1} (@var{end1} is exclusive), into @var{str2}, starting at @var{start2}. Allows overlapping strings. -@example +@lisp (define x (make-string 10 #\a)) (define y "bcd") (substring-move-left! x 2 5 y 0) @@ -198,7 +192,7 @@ y (substring-move-left! y 2 5 y 3) y @result{} "abccccg" -@end example +@end lisp */ /* @@ -210,7 +204,7 @@ it hasn't made it into the guile tree]. Does much the same thing as @code{substring-move-left!}, except it starts moving at the end of the sequence, rather than the beginning. -@example +@lisp (define y "abcdefg") (substring-move-right! y 2 5 y 0) y @@ -220,7 +214,7 @@ y (substring-move-right! y 2 5 y 3) y @result{} "abccdeg" -@end example +@end lisp */ SCM_DEFINE (scm_substring_move_x, "substring-move!", 5, 0, 0, @@ -269,15 +263,15 @@ SCM_DEFINE (scm_substring_move_x, "substring-move!", 5, 0, 0, SCM_DEFINE (scm_substring_fill_x, "substring-fill!", 4, 0, 0, (SCM str, SCM start, SCM end, SCM fill), - "Change every character in @var{str} between @var{start} and @var{end} to\n" - "@var{fill-char}.\n\n" - "(qdocs:) Destructively fills @var{str}, from @var{start} to @var{end}, with @var{fill}.\n\n" - "@example\n" + "Change every character in @var{str} between @var{start} and\n" + "@var{end} to @var{fill}.\n" + "\n" + "@lisp\n" "(define y \"abcdefg\")\n" "(substring-fill! y 1 3 #\\r)\n" "y\n" "@result{} \"arrdefg\"\n" - "@end example") + "@end lisp") #define FUNC_NAME s_scm_substring_fill_x { long i, e; @@ -296,15 +290,13 @@ SCM_DEFINE (scm_substring_fill_x, "substring-fill!", 4, 0, 0, SCM_DEFINE (scm_string_null_p, "string-null?", 1, 0, 0, (SCM str), - "Return @code{#t} if @var{str}'s length is nonzero, and @code{#f}\n" - "otherwise.\n\n" - "(qdocs:) Returns @code{#t} if @var{str} is empty, else returns @code{#f}.\n\n" - "@example\n" - "(string-null? \"\")\n" - "@result{} #t\n\n" - "(string-null? y)\n" - "@result{} #f\n" - "@end example") + "Return @code{#t} if @var{str}'s length is nonzero, and\n" + "@code{#f} otherwise.\n" + "@lisp\n" + "(string-null? \"\") @result{} #t\n" + "y @result{} \"foo\"\n" + "(string-null? y) @result{} #f\n" + "@end lisp") #define FUNC_NAME s_scm_string_null_p { SCM_VALIDATE_STRING (1,str); @@ -343,7 +335,7 @@ string_copy (SCM str) SCM_DEFINE (scm_string_copy, "string-copy", 1, 0, 0, (SCM str), - "Returns a newly allocated copy of the given @var{string}. (r5rs)") + "Return a newly allocated copy of the given @var{string}.") #define FUNC_NAME s_scm_string_copy { SCM_VALIDATE_STRING (1, str); @@ -355,8 +347,8 @@ SCM_DEFINE (scm_string_copy, "string-copy", 1, 0, 0, SCM_DEFINE (scm_string_fill_x, "string-fill!", 2, 0, 0, (SCM str, SCM chr), - "Stores @var{char} in every element of the given @var{string} and returns an\n" - "unspecified value. (r5rs)") + "Store @var{char} in every element of the given @var{string} and\n" + "return an unspecified value.") #define FUNC_NAME s_scm_string_fill_x { register char *dst, c; diff --git a/libguile/strorder.c b/libguile/strorder.c index 2dee2b800..bbf4ba30f 100644 --- a/libguile/strorder.c +++ b/libguile/strorder.c @@ -54,14 +54,14 @@ SCM_DEFINE1 (scm_string_equal_p, "string=?", scm_tc7_rpsubr, (SCM s1, SCM s2), - "Lexicographic equality predicate; \n" - "Returns @code{#t} if the two strings are the same length and\n" - "contain the same characters in the same positions, otherwise\n" - "returns @code{#f}. (r5rs)\n\n" - "The procedure @code{string-ci=?} treats upper and lower case\n" - "letters as though they were the same character, but\n" - "@code{string=?} treats upper and lower case as distinct\n" - "characters.") + "Lexicographic equality predicate; return @code{#t} if the two\n" + "strings are the same length and contain the same characters in\n" + "the same positions, otherwise return @code{#f}.\n" + "\n" + "The procedure @code{string-ci=?} treats upper and lower case\n" + "letters as though they were the same character, but\n" + "@code{string=?} treats upper and lower case as distinct\n" + "characters.") #define FUNC_NAME s_scm_string_equal_p { scm_sizet length; @@ -93,10 +93,10 @@ SCM_DEFINE1 (scm_string_equal_p, "string=?", scm_tc7_rpsubr, SCM_DEFINE1 (scm_string_ci_equal_p, "string-ci=?", scm_tc7_rpsubr, (SCM s1, SCM s2), - "Case-insensitive string equality predicate; returns @code{#t}\n" - "if the two strings are the same length and their component\n" - "characters match (ignoring case) at each position; otherwise\n" - "returns @code{#f}. (r5rs)") + "Case-insensitive string equality predicate; return @code{#t} if\n" + "the two strings are the same length and their component\n" + "characters match (ignoring case) at each position; otherwise\n" + "return @code{#f}.") #define FUNC_NAME s_scm_string_ci_equal_p { scm_sizet length; @@ -152,8 +152,8 @@ string_less_p (SCM s1, SCM s2) SCM_DEFINE1 (scm_string_less_p, "string?", scm_tc7_rpsubr, (SCM s1, SCM s2), - "Lexicographic ordering predicate; returns @code{#t} if\n" - "@var{s1} is lexicographically greater than @var{s2}. (r5rs)") + "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n" + "is lexicographically greater than @var{s2}.") #define FUNC_NAME s_scm_string_gr_p { SCM_VALIDATE_STRING (1, s1); @@ -195,9 +194,8 @@ SCM_DEFINE1 (scm_string_gr_p, "string>?", scm_tc7_rpsubr, SCM_DEFINE1 (scm_string_geq_p, "string>=?", scm_tc7_rpsubr, (SCM s1, SCM s2), - "Lexicographic ordering predicate; returns @code{#t} if\n" - "@var{s1} is lexicographically greater than or equal to\n" - "@var{s2}. (r5rs)") + "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n" + "is lexicographically greater than or equal to @var{s2}.") #define FUNC_NAME s_scm_string_geq_p { SCM_VALIDATE_STRING (1, s1); @@ -234,9 +232,9 @@ string_ci_less_p (SCM s1, SCM s2) SCM_DEFINE1 (scm_string_ci_less_p, "string-ci?", scm_tc7_rpsubr, (SCM s1, SCM s2), - "Case insensitive lexicographic ordering predicate;\n" - "returns @code{#t} if @var{s1} is lexicographically greater\n" - "than @var{s2} regardless of case. (r5rs)") + "Case insensitive lexicographic ordering predicate; return\n" + "@code{#t} if @var{s1} is lexicographically greater than\n" + "@var{s2} regardless of case.") #define FUNC_NAME s_scm_string_ci_gr_p { SCM_VALIDATE_STRING (1, s1); @@ -279,9 +277,9 @@ SCM_DEFINE1 (scm_string_ci_gr_p, "string-ci>?", scm_tc7_rpsubr, SCM_DEFINE1 (scm_string_ci_geq_p, "string-ci>=?", scm_tc7_rpsubr, (SCM s1, SCM s2), - "Case insensitive lexicographic ordering predicate;\n" - "returns @code{#t} if @var{s1} is lexicographically greater\n" - "than or equal to @var{s2} regardless of case. (r5rs)") + "Case insensitive lexicographic ordering predicate; return\n" + "@code{#t} if @var{s1} is lexicographically greater than or\n" + "equal to @var{s2} regardless of case.") #define FUNC_NAME s_scm_string_ci_geq_p { SCM_VALIDATE_STRING (1, s1); diff --git a/libguile/strports.c b/libguile/strports.c index c1a20e60b..3a8faaa51 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -365,21 +365,21 @@ SCM_DEFINE (scm_call_with_output_string, "call-with-output-string", 1, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_call_with_input_string, "call-with-input-string", 2, 0, 0, - (SCM str, SCM proc), - "Calls the one-argument procedure @var{proc} with a newly created input\n" - "port from which @var{string}'s contents may be read. The value yielded\n" - "by the @var{proc} is returned.") + (SCM string, SCM proc), + "Calls the one-argument procedure @var{proc} with a newly\n" + "created input port from which @var{string}'s contents may be\n" + "read. The value yielded by the @var{proc} is returned.") #define FUNC_NAME s_scm_call_with_input_string { - SCM p = scm_mkstrport(SCM_INUM0, str, SCM_OPN | SCM_RDNG, FUNC_NAME); + SCM p = scm_mkstrport(SCM_INUM0, string, SCM_OPN | SCM_RDNG, FUNC_NAME); return scm_apply (proc, p, scm_listofnull); } #undef FUNC_NAME SCM_DEFINE (scm_open_input_string, "open-input-string", 1, 0, 0, (SCM str), - "Takes a string and returns an input port that delivers\n" - "characters from the string. The port can be closed by\n" + "Take a string and return an input port that delivers characters\n" + "from the string. The port can be closed by\n" "@code{close-input-port}, though its storage will be reclaimed\n" "by the garbage collector if it becomes inaccessible.") #define FUNC_NAME s_scm_open_input_string @@ -391,7 +391,7 @@ SCM_DEFINE (scm_open_input_string, "open-input-string", 1, 0, 0, SCM_DEFINE (scm_open_output_string, "open-output-string", 0, 0, 0, (void), - "Returns an output port that will accumulate characters for\n" + "Return an output port that will accumulate characters for\n" "retrieval by @code{get-output-string}. The port can be closed\n" "by the procedure @code{close-output-port}, though its storage\n" "will be reclaimed by the garbage collector if it becomes\n" @@ -411,7 +411,7 @@ SCM_DEFINE (scm_open_output_string, "open-output-string", 0, 0, 0, SCM_DEFINE (scm_get_output_string, "get-output-string", 1, 0, 0, (SCM port), "Given an output port created by @code{open-output-string},\n" - "returns a string consisting of the characters that have been\n" + "return a string consisting of the characters that have been\n" "output to the port so far.") #define FUNC_NAME s_scm_get_output_string { diff --git a/libguile/struct.c b/libguile/struct.c index b57d1996f..3f86c22cf 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -503,7 +503,7 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, "sub-system: one vtable-vtable working as the root and one or several\n" "\"types\", each with a set of \"instances\". (The vtable-vtable should be\n" "compared to the class which is the class of itself.)\n\n" - "@example\n" + "@lisp\n" "(define ball-root (make-vtable-vtable \"pr\" 0))\n\n" "(define (make-ball-type ball-color)\n" " (make-struct ball-root 0\n" @@ -520,7 +520,7 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, "(define (make-ball type owner) (make-struct type 0 owner))\n\n" "(define ball (make-ball green 'Nisse))\n" "ball @result{} #\n" - "@end example\n") + "@end lisp\n") #define FUNC_NAME s_scm_make_vtable_vtable { SCM fields; diff --git a/libguile/symbols.c b/libguile/symbols.c index 061e91811..0f47fa3be 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -418,8 +418,8 @@ scm_symbol_value0 (const char *name) SCM_DEFINE (scm_symbol_p, "symbol?", 1, 0, 0, (SCM obj), - "Returns @code{#t} if @var{obj} is a symbol, otherwise returns\n" - "@code{#f}. (r5rs)") + "Return @code{#t} if @var{obj} is a symbol, otherwise return\n" + "@code{#f}.") #define FUNC_NAME s_scm_symbol_p { return SCM_BOOL (SCM_SYMBOLP (obj)); @@ -428,24 +428,26 @@ SCM_DEFINE (scm_symbol_p, "symbol?", 1, 0, 0, SCM_DEFINE (scm_symbol_to_string, "symbol->string", 1, 0, 0, (SCM s), - "Returns the name of @var{symbol} as a string. If the symbol\n" - "was part of an object returned as the value of a literal\n" - "expression (section @pxref{Literal expressions,,,r4rs, The\n" - "Revised^4 Report on Scheme}) or by a call to the @code{read}\n" - "procedure, and its name contains alphabetic characters, then\n" - "the string returned will contain characters in the\n" - "implementation's preferred standard case---some implementations\n" - "will prefer upper case, others lower case. If the symbol was\n" - "returned by @code{string->symbol}, the case of characters in\n" - "the string returned will be the same as the case in the string\n" - "that was passed to @code{string->symbol}. It is an error to\n" - "apply mutation procedures like @code{string-set!} to strings\n" - "returned by this procedure. (r5rs)\n\n" + "Return the name of @var{symbol} as a string. If the symbol was\n" + "part of an object returned as the value of a literal expression\n" + "(section @pxref{Literal expressions,,,r4rs, The Revised^4\n" + "Report on Scheme}) or by a call to the @code{read} procedure,\n" + "and its name contains alphabetic characters, then the string\n" + "returned will contain characters in the implementation's\n" + "preferred standard case---some implementations will prefer\n" + "upper case, others lower case. If the symbol was returned by\n" + "@code{string->symbol}, the case of characters in the string\n" + "returned will be the same as the case in the string that was\n" + "passed to @code{string->symbol}. It is an error to apply\n" + "mutation procedures like @code{string-set!} to strings returned\n" + "by this procedure.\n" + "\n" "The following examples assume that the implementation's\n" - "standard case is lower case:\n\n" + "standard case is lower case:\n" + "\n" "@lisp\n" - "(symbol->string 'flying-fish) @result{} \"flying-fish\"\n" - "(symbol->string 'Martin) @result{} \"martin\"\n" + "(symbol->string 'flying-fish) @result{} \"flying-fish\"\n" + "(symbol->string 'Martin) @result{} \"martin\"\n" "(symbol->string\n" " (string->symbol \"Malvina\")) @result{} \"Malvina\"\n" "@end lisp") @@ -458,14 +460,17 @@ SCM_DEFINE (scm_symbol_to_string, "symbol->string", 1, 0, 0, SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0, - (SCM s), - "Returns the symbol whose name is @var{string}. This procedure\n" + (SCM string), + "Return the symbol whose name is @var{string}. This procedure\n" "can create symbols with names containing special characters or\n" "letters in the non-standard case, but it is usually a bad idea\n" - "to create such because in some implementations of Scheme they\n" - "cannot be read as themselves. See @code{symbol->string}.\n\n" + "to create such symbols because in some implementations of\n" + "Scheme they cannot be read as themselves. See\n" + "@code{symbol->string}.\n" + "\n" "The following examples assume that the implementation's\n" - "standard case is lower case:\n\n" + "standard case is lower case:\n" + "\n" "@lisp\n" "(eq? 'mISSISSIppi 'mississippi) @result{} #t\n" "(string->symbol \"mISSISSIppi\") @result{} @r{the symbol with name \"mISSISSIppi\"}\n" @@ -478,8 +483,9 @@ SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0, "@end lisp") #define FUNC_NAME s_scm_string_to_symbol { - SCM_VALIDATE_STRING (1, s); - return scm_mem2symbol (SCM_STRING_CHARS (s), SCM_STRING_LENGTH (s)); + SCM_VALIDATE_STRING (1, string); + return scm_mem2symbol (SCM_STRING_CHARS (string), + SCM_STRING_LENGTH (string)); } #undef FUNC_NAME diff --git a/libguile/throw.c b/libguile/throw.c index e0e921dcd..fce8d8e0f 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -514,37 +514,41 @@ scm_handle_by_throw (void *handler_data, SCM tag, SCM args) /* the Scheme-visible CATCH and LAZY-CATCH functions */ SCM_DEFINE (scm_catch, "catch", 3, 0, 0, - (SCM tag, SCM thunk, SCM handler), + (SCM key, SCM thunk, SCM handler), "Invoke @var{thunk} in the dynamic context of @var{handler} for\n" - "exceptions matching @var{key}. If thunk throws to the symbol @var{key},\n" - "then @var{handler} is invoked this way:\n\n" - "@example\n" + "exceptions matching @var{key}. If thunk throws to the symbol\n" + "@var{key}, then @var{handler} is invoked this way:\n" + "@lisp\n" "(handler key args ...)\n" - "@end example\n\n" - "@var{key} is a symbol or #t.\n\n" - "@var{thunk} takes no arguments. If @var{thunk} returns normally, that\n" - "is the return value of @code{catch}.\n\n" - "Handler is invoked outside the scope of its own @code{catch}. If\n" - "@var{handler} again throws to the same key, a new handler from further\n" - "up the call chain is invoked.\n\n" - "If the key is @code{#t}, then a throw to @emph{any} symbol will match\n" - "this call to @code{catch}.") + "@end lisp\n" + "\n" + "@var{key} is a symbol or @code{#t}.\n" + "\n" + "@var{thunk} takes no arguments. If @var{thunk} returns\n" + "normally, that is the return value of @code{catch}.\n" + "\n" + "Handler is invoked outside the scope of its own @code{catch}.\n" + "If @var{handler} again throws to the same key, a new handler\n" + "from further up the call chain is invoked.\n" + "\n" + "If the key is @code{#t}, then a throw to @emph{any} symbol will\n" + "match this call to @code{catch}.") #define FUNC_NAME s_scm_catch { struct scm_body_thunk_data c; - SCM_ASSERT (SCM_SYMBOLP (tag) || SCM_EQ_P (tag, SCM_BOOL_T), - tag, SCM_ARG1, FUNC_NAME); + SCM_ASSERT (SCM_SYMBOLP (key) || SCM_EQ_P (key, SCM_BOOL_T), + key, SCM_ARG1, FUNC_NAME); - c.tag = tag; + c.tag = key; c.body_proc = thunk; /* scm_internal_catch takes care of all the mechanics of setting up - a catch tag; we tell it to call scm_body_thunk to run the body, + a catch key; we tell it to call scm_body_thunk to run the body, and scm_handle_by_proc to deal with any throws to this catch. The former receives a pointer to c, telling it how to behave. The latter receives a pointer to HANDLER, so it knows who to call. */ - return scm_internal_catch (tag, + return scm_internal_catch (key, scm_body_thunk, &c, scm_handle_by_proc, &handler); } @@ -552,7 +556,7 @@ SCM_DEFINE (scm_catch, "catch", 3, 0, 0, SCM_DEFINE (scm_lazy_catch, "lazy-catch", 3, 0, 0, - (SCM tag, SCM thunk, SCM handler), + (SCM key, SCM thunk, SCM handler), "This behaves exactly like @code{catch}, except that it does\n" "not unwind the stack (this is the major difference), and if\n" "handler returns, its value is returned from the throw.") @@ -560,19 +564,19 @@ SCM_DEFINE (scm_lazy_catch, "lazy-catch", 3, 0, 0, { struct scm_body_thunk_data c; - SCM_ASSERT (SCM_SYMBOLP (tag) || SCM_EQ_P (tag, SCM_BOOL_T), - tag, SCM_ARG1, FUNC_NAME); + SCM_ASSERT (SCM_SYMBOLP (key) || SCM_EQ_P (key, SCM_BOOL_T), + key, SCM_ARG1, FUNC_NAME); - c.tag = tag; + c.tag = key; c.body_proc = thunk; /* scm_internal_lazy_catch takes care of all the mechanics of - setting up a lazy catch tag; we tell it to call scm_body_thunk to + setting up a lazy catch key; we tell it to call scm_body_thunk to run the body, and scm_handle_by_proc to deal with any throws to this catch. The former receives a pointer to c, telling it how to behave. The latter receives a pointer to HANDLER, so it knows who to call. */ - return scm_internal_lazy_catch (tag, + return scm_internal_lazy_catch (key, scm_body_thunk, &c, scm_handle_by_proc, &handler); } diff --git a/libguile/unif.c b/libguile/unif.c index 9255abb37..62e75bf49 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -251,8 +251,8 @@ scm_make_uve (long k, SCM prot) SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0, - (SCM v), - "Returns the number of elements in @var{uve}.") + (SCM v), + "Return the number of elements in @var{uve}.") #define FUNC_NAME s_scm_uniform_vector_length { SCM_ASRTGO (SCM_NIMP (v), badarg1); @@ -284,9 +284,9 @@ SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0, SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, (SCM v, SCM prot), - "Returns @code{#t} if the @var{obj} is an array, and @code{#f} if not.\n\n" - "The @var{prototype} argument is used with uniform arrays and is described\n" - "elsewhere.") + "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n" + "not. The @var{prototype} argument is used with uniform arrays\n" + "and is described elsewhere.") #define FUNC_NAME s_scm_array_p { int nprot; @@ -356,8 +356,8 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0, (SCM ra), - "Returns the number of dimensions of @var{obj}. If @var{obj} is not an\n" - "array, @code{0} is returned.") + "Return the number of dimensions of @var{obj}. If @var{obj} is\n" + "not an array, @code{0} is returned.") #define FUNC_NAME s_scm_array_rank { if (SCM_IMP (ra)) @@ -393,9 +393,9 @@ SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0, (SCM ra), "@code{Array-dimensions} is similar to @code{array-shape} but replaces\n" "elements with a @code{0} minimum with one greater than the maximum. So:\n" - "@example\n" + "@lisp\n" "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n" - "@end example") + "@end lisp") #define FUNC_NAME s_scm_array_dimensions { SCM res = SCM_EOL; @@ -578,12 +578,12 @@ scm_shap2ra (SCM args, const char *what) } SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, 0, - (SCM dims, SCM prot, SCM fill), + (SCM dims, SCM prot, SCM fill), "@deffnx primitive make-uniform-vector length prototype [fill]\n" - "Creates and returns a uniform array or vector of type corresponding to\n" - "@var{prototype} with dimensions @var{dims} or length @var{length}. If\n" - "@var{fill} is supplied, it's used to fill the array, otherwise \n" - "@var{prototype} is used.") + "Create and return a uniform array or vector of type\n" + "corresponding to @var{prototype} with dimensions @var{dims} or\n" + "length @var{length}. If @var{fill} is supplied, it's used to\n" + "fill the array, otherwise @var{prototype} is used.") #define FUNC_NAME s_scm_dimensions_to_uniform_array { scm_sizet k; @@ -660,7 +660,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, "the new array into coordinates in the old array. A @var{mapper} must be\n" "linear, and its range must stay within the bounds of the old array, but\n" "it can be otherwise arbitrary. A simple example:\n" - "@example\n" + "@lisp\n" "(define fred (make-array #f 8 8))\n" "(define freds-diagonal\n" " (make-shared-array fred (lambda (i) (list i i)) 8))\n" @@ -669,7 +669,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, "(define freds-center\n" " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n" "(array-ref freds-center 0 0) @result{} foo\n" - "@end example") + "@end lisp") #define FUNC_NAME s_scm_make_shared_array { SCM ra; @@ -783,23 +783,25 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, /* args are RA . DIMS */ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, (SCM ra, SCM args), - "Returns an array sharing contents with @var{array}, but with dimensions\n" - "arranged in a different order. There must be one @var{dim} argument for\n" - "each dimension of @var{array}. @var{dim0}, @var{dim1}, @dots{} should\n" - "be integers between 0 and the rank of the array to be returned. Each\n" - "integer in that range must appear at least once in the argument list.\n\n" - "The values of @var{dim0}, @var{dim1}, @dots{} correspond to dimensions\n" - "in the array to be returned, their positions in the argument list to\n" - "dimensions of @var{array}. Several @var{dim}s may have the same value,\n" - "in which case the returned array will have smaller rank than\n" - "@var{array}.\n\n" - "examples:\n" - "@example\n" + "Return an array sharing contents with @var{array}, but with\n" + "dimensions arranged in a different order. There must be one\n" + "@var{dim} argument for each dimension of @var{array}.\n" + "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n" + "and the rank of the array to be returned. Each integer in that\n" + "range must appear at least once in the argument list.\n" + "\n" + "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n" + "dimensions in the array to be returned, their positions in the\n" + "argument list to dimensions of @var{array}. Several @var{dim}s\n" + "may have the same value, in which case the returned array will\n" + "have smaller rank than @var{array}.\n" + "\n" + "@lisp\n" "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n" "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n" "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n" " #2((a 4) (b 5) (c 6))\n" - "@end example") + "@end lisp") #define FUNC_NAME s_scm_transpose_array { SCM res, vargs, *ve = &vargs; @@ -903,12 +905,12 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, "@code{eq?}. The value returned by @var{array-prototype} when given an\n" "enclosed array is unspecified.\n\n" "examples:\n" - "@example\n" + "@lisp\n" "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n" " #\n\n" "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n" " #\n" - "@end example") + "@end lisp") #define FUNC_NAME s_scm_enclose_array { SCM axv, res, ra_inr; @@ -991,7 +993,8 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1, (SCM v, SCM args), - "Returns @code{#t} if its arguments would be acceptable to array-ref.") + "Return @code{#t} if its arguments would be acceptable to\n" + "@code{array-ref}.") #define FUNC_NAME s_scm_array_in_bounds_p { SCM ind = SCM_EOL; @@ -1076,7 +1079,8 @@ SCM_REGISTER_PROC(s_array_ref, "array-ref", 1, 0, 1, scm_uniform_vector_ref); SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, (SCM v, SCM args), "@deffnx primitive array-ref v . args\n" - "Returns the element at the @code{(index1, index2)} element in @var{array}.") + "Return the element at the @code{(index1, index2)} element in\n" + "@var{array}.") #define FUNC_NAME s_scm_uniform_vector_ref { long pos; @@ -1770,7 +1774,7 @@ static char cnt_tab[16] = SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0, (SCM b, SCM bitvector), - "Returns the number of occurrences of the boolean @var{b} in\n" + "Return the number of occurrences of the boolean @var{b} in\n" "@var{bitvector}.") #define FUNC_NAME s_scm_bit_count { @@ -1808,9 +1812,9 @@ SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0, SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, (SCM item, SCM v, SCM k), - "Returns the minimum index of an occurrence of @var{bool} in @var{bv}\n" - "which is at least @var{k}. If no @var{bool} occurs within the specified\n" - "range @code{#f} is returned.") + "Return the minimum index of an occurrence of @var{bool} in\n" + "@var{bv} which is at least @var{k}. If no @var{bool} occurs\n" + "within the specified range @code{#f} is returned.") #define FUNC_NAME s_scm_bit_position { long i, lenw, xbits, pos; @@ -1928,10 +1932,10 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, (SCM v, SCM kv, SCM obj), - "Returns\n" - "@example\n" + "Return\n" + "@lisp\n" "(bit-count (bit-set*! (if bool bv (bit-invert! bv)) uve #t) #t).\n" - "@end example\n" + "@end lisp\n" "@var{bv} is not modified.") #define FUNC_NAME s_scm_bit_count_star { @@ -2074,7 +2078,8 @@ ra2l (SCM ra,scm_sizet base,scm_sizet k) SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, (SCM v), - "Returns a list consisting of all the elements, in order, of @var{array}.") + "Return a list consisting of all the elements, in order, of\n" + "@var{array}.") #define FUNC_NAME s_scm_array_to_list { SCM res = SCM_EOL; @@ -2164,9 +2169,10 @@ static int l2ra(SCM lst, SCM ra, scm_sizet base, scm_sizet k); SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, (SCM ndim, SCM prot, SCM lst), "@deffnx procedure list->uniform-vector prot lst\n" - "Returns a uniform array of the type indicated by prototype @var{prot}\n" - "with elements the same as those of @var{lst}. Elements must be of the\n" - "appropriate type, no coercions are done.") + "Return a uniform array of the type indicated by prototype\n" + "@var{prot} with elements the same as those of @var{lst}.\n" + "Elements must be of the appropriate type, no coercions are\n" + "done.") #define FUNC_NAME s_scm_list_to_uniform_array { SCM shp = SCM_EOL; @@ -2515,8 +2521,8 @@ tail: SCM_DEFINE (scm_array_prototype, "array-prototype", 1, 0, 0, (SCM ra), - "Returns an object that would produce an array of the same type as\n" - "@var{array}, if used as the @var{prototype} for\n" + "Return an object that would produce an array of the same type\n" + "as @var{array}, if used as the @var{prototype} for\n" "@code{make-uniform-array}.") #define FUNC_NAME s_scm_array_prototype { diff --git a/libguile/vectors.c b/libguile/vectors.c index 280b2eedf..e21c5b0aa 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -138,8 +138,8 @@ scm_vector_set_length_x (SCM vect, SCM len) SCM_DEFINE (scm_vector_p, "vector?", 1, 0, 0, (SCM obj), - "Returns @code{#t} if @var{obj} is a vector, otherwise returns\n" - "@code{#f}. (r5rs)") + "Return @code{#t} if @var{obj} is a vector, otherwise return\n" + "@code{#f}.") #define FUNC_NAME s_scm_vector_p { if (SCM_IMP (obj)) @@ -149,7 +149,7 @@ SCM_DEFINE (scm_vector_p, "vector?", 1, 0, 0, #undef FUNC_NAME SCM_GPROC (s_vector_length, "vector-length", 1, 0, 0, scm_vector_length, g_vector_length); -/* Returns the number of elements in @var{vector} as an exact integer. (r5rs) */ +/* Returns the number of elements in @var{vector} as an exact integer. */ SCM scm_vector_length (SCM v) { @@ -170,10 +170,11 @@ SCM_REGISTER_PROC (s_list_to_vector, "list->vector", 1, 0, 0, scm_vector); SCM_DEFINE (scm_vector, "vector", 0, 0, 1, (SCM l), "@deffnx primitive list->vector l\n" - "Returns a newly allocated vector whose elements contain the\n" - "given arguments. Analogous to @code{list}. (r5rs)\n\n" + "Return a newly allocated vector whose elements contain the\n" + "given arguments. Analogous to @code{list}.\n" + "\n" "@lisp\n" - "(vector 'a 'b 'c) @result{} #(a b c)\n" + "(vector 'a 'b 'c) @result{} #(a b c)\n" "@end lisp") #define FUNC_NAME s_scm_vector { @@ -257,9 +258,10 @@ scm_vector_set_x (SCM v, SCM k, SCM obj) SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0, (SCM k, SCM fill), - "Returns a newly allocated vector of @var{k} elements. If a second\n" - "argument is given, then each element is initialized to @var{fill}.\n" - "Otherwise the initial contents of each element is unspecified. (r5rs)") + "Return a newly allocated vector of @var{k} elements. If a\n" + "second argument is given, then each element is initialized to\n" + "@var{fill}. Otherwise the initial contents of each element is\n" + "unspecified.") #define FUNC_NAME s_scm_make_vector { if (SCM_UNBNDP (fill)) @@ -309,9 +311,10 @@ scm_c_make_vector (unsigned long int k, SCM fill) SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0, - (SCM v), - "@samp{Vector->list} returns a newly allocated list of the\n" - "objects contained in the elements of @var{vector}. (r5rs)\n\n" + (SCM v), + "Return a newly allocated list of the objects contained in the\n" + "elements of @var{vector}.\n" + "\n" "@lisp\n" "(vector->list '#(dah dah didah)) @result{} (dah dah didah)\n" "(list->vector '(dididit dah)) @result{} #(dididit dah)\n" @@ -330,9 +333,9 @@ SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0, SCM_DEFINE (scm_vector_fill_x, "vector-fill!", 2, 0, 0, - (SCM v, SCM fill_x), - "Stores @var{fill} in every element of @var{vector}.\n" - "The value returned by @code{vector-fill!} is unspecified. (r5rs)") + (SCM v, SCM fill), + "Store @var{fill} in every element of @var{vector}. The value\n" + "returned by @code{vector-fill!} is unspecified.") #define FUNC_NAME s_scm_vector_fill_x { register long i; @@ -340,7 +343,7 @@ SCM_DEFINE (scm_vector_fill_x, "vector-fill!", 2, 0, 0, SCM_VALIDATE_VECTOR (1,v); data = SCM_VELTS(v); for(i = SCM_VECTOR_LENGTH(v) - 1; i >= 0; i--) - data[i] = fill_x; + data[i] = fill; return SCM_UNSPECIFIED; } #undef FUNC_NAME diff --git a/libguile/version.c b/libguile/version.c index 98c8691e9..85cc484aa 100644 --- a/libguile/version.c +++ b/libguile/version.c @@ -83,11 +83,11 @@ SCM_DEFINE (scm_version, "version", 0, 0, 0, "@deffnx primitive minor-version\n" "Return a string describing Guile's version number, or its major or minor\n" "version numbers, respectively.\n\n" - "@example\n" + "@lisp\n" "(version) @result{} \"1.3a\"\n" "(major-version) @result{} \"1\"\n" "(minor-version) @result{} \"3a\"\n" - "@end example") + "@end lisp") #define FUNC_NAME s_scm_version { return scm_makfrom0str (GUILE_VERSION); diff --git a/libguile/vports.c b/libguile/vports.c index 962759b23..9a4975aff 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -147,10 +147,11 @@ sf_close (SCM port) SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0, (SCM pv, SCM modes), - "Returns a port capable of receiving or delivering characters as\n" + "Return a port capable of receiving or delivering characters as\n" "specified by the @var{modes} string (@pxref{File Ports,\n" - "open-file}). @var{vector} must be a vector of length 6. Its components\n" - "are as follows:\n\n" + "open-file}). @var{pv} must be a vector of length 5. Its\n" + "components are as follows:\n" + "\n" "@enumerate 0\n" "@item\n" "procedure accepting one character for output\n" @@ -162,15 +163,19 @@ SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0, "thunk for getting one character\n" "@item\n" "thunk for closing port (not by garbage collection)\n" - "@end enumerate\n\n" + "@end enumerate\n" + "\n" "For an output-only port only elements 0, 1, 2, and 4 need be\n" - "procedures. For an input-only port only elements 3 and 4 need be\n" - "procedures. Thunks 2 and 4 can instead be @code{#f} if there is no useful\n" - "operation for them to perform.\n\n" - "If thunk 3 returns @code{#f} or an @code{eof-object} (@pxref{Input,\n" - "eof-object?, ,r4rs, The Revised^4 Report on Scheme}) it indicates that\n" - "the port has reached end-of-file. For example:\n\n" - "@example\n" + "procedures. For an input-only port only elements 3 and 4 need\n" + "be procedures. Thunks 2 and 4 can instead be @code{#f} if\n" + "there is no useful operation for them to perform.\n" + "\n" + "If thunk 3 returns @code{#f} or an @code{eof-object}\n" + "(@pxref{Input, eof-object?, ,r4rs, The Revised^4 Report on\n" + "Scheme}) it indicates that the port has reached end-of-file.\n" + "For example:\n" + "\n" + "@lisp\n" "(define stdout (current-output-port))\n" "(define p (make-soft-port\n" " (vector\n" @@ -179,9 +184,10 @@ SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0, " (lambda () (display \".\" stdout))\n" " (lambda () (char-upcase (read-char)))\n" " (lambda () (display \"@@\" stdout)))\n" - " \"rw\"))\n\n" + " \"rw\"))\n" + "\n" "(write p p) @result{} #\n" - "@end example") + "@end lisp") #define FUNC_NAME s_scm_make_soft_port { scm_port *pt; diff --git a/libguile/weaks.c b/libguile/weaks.c index c6cf591bb..81a4b879f 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -56,17 +56,18 @@ SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0, - (SCM k, SCM fill), + (SCM size, SCM fill), "Return a weak vector with @var{size} elements. If the optional\n" - "argument @var{fill} is given, all entries in the vector will be set to\n" - "@var{fill}. The default value for @var{fill} is the empty list.") + "argument @var{fill} is given, all entries in the vector will be\n" + "set to @var{fill}. The default value for @var{fill} is the\n" + "empty list.") #define FUNC_NAME s_scm_make_weak_vector { /* Dirk:FIXME:: We should probably rather use a double cell for weak vectors. */ SCM v; - v = scm_make_vector (scm_sum (k, SCM_MAKINUM (2)), fill); + v = scm_make_vector (scm_sum (size, SCM_MAKINUM (2)), fill); SCM_DEFER_INTS; - SCM_SET_VECTOR_LENGTH (v, SCM_INUM (k), scm_tc7_wvect); + SCM_SET_VECTOR_LENGTH (v, SCM_INUM (size), scm_tc7_wvect); SCM_SETVELTS(v, SCM_VELTS(v) + 2); SCM_VELTS(v)[-2] = SCM_EOL; SCM_UNPACK (SCM_VELTS (v)[-1]) = 0; @@ -81,10 +82,10 @@ SCM_REGISTER_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_ SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1, (SCM l), "@deffnx primitive list->weak-vector l\n" - "Construct a weak vector from a list: @code{weak-vector} uses the list of\n" - "its arguments while @code{list->weak-vector} uses its only argument\n" - "@var{l} (a list) to construct a weak vector the same way\n" - "@code{vector->list} would.") + "Construct a weak vector from a list: @code{weak-vector} uses\n" + "the list of its arguments while @code{list->weak-vector} uses\n" + "its only argument @var{l} (a list) to construct a weak vector\n" + "the same way @code{list->vector} would.") #define FUNC_NAME s_scm_weak_vector { SCM res; @@ -110,12 +111,12 @@ SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1, SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0, - (SCM x), + (SCM obj), "Return @code{#t} if @var{obj} is a weak vector. Note that all\n" "weak hashes are also weak vectors.") #define FUNC_NAME s_scm_weak_vector_p { - return SCM_BOOL(SCM_WVECTP (x) && !SCM_IS_WHVEC (x)); + return SCM_BOOL(SCM_WVECTP (obj) && !SCM_IS_WHVEC (obj)); } #undef FUNC_NAME @@ -126,18 +127,20 @@ SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0, SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 1, 0, 0, - (SCM k), + (SCM size), "@deffnx primitive make-weak-value-hash-table size\n" "@deffnx primitive make-doubly-weak-hash-table size\n" - "Return a weak hash table with @var{size} buckets. As with any hash\n" - "table, choosing a good size for the table requires some caution.\n\n" - "You can modify weak hash tables in exactly the same way you would modify\n" - "regular hash tables. (@pxref{Hash Tables})") + "Return a weak hash table with @var{size} buckets. As with any\n" + "hash table, choosing a good size for the table requires some\n" + "caution.\n" + "\n" + "You can modify weak hash tables in exactly the same way you\n" + "would modify regular hash tables. (@pxref{Hash Tables})") #define FUNC_NAME s_scm_make_weak_key_hash_table { SCM v; - SCM_VALIDATE_INUM (1,k); - v = scm_make_weak_vector (k, SCM_EOL); + SCM_VALIDATE_INUM (1, size); + v = scm_make_weak_vector (size, SCM_EOL); SCM_DEFER_INTS; SCM_UNPACK (SCM_VELTS (v)[-1]) = 1; SCM_ALLOW_INTS; @@ -147,14 +150,14 @@ SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 1, 0, 0, SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 1, 0, 0, - (SCM k), + (SCM size), "Return a hash table with weak values with @var{size} buckets.\n" "(@pxref{Hash Tables})") #define FUNC_NAME s_scm_make_weak_value_hash_table { SCM v; - SCM_VALIDATE_INUM (1,k); - v = scm_make_weak_vector (k, SCM_EOL); + SCM_VALIDATE_INUM (1, size); + v = scm_make_weak_vector (size, SCM_EOL); SCM_DEFER_INTS; SCM_UNPACK (SCM_VELTS (v)[-1]) = 2; SCM_ALLOW_INTS; @@ -165,14 +168,14 @@ SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 1, 0, SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0, - (SCM k), + (SCM size), "Return a hash table with weak keys and values with @var{size}\n" "buckets. (@pxref{Hash Tables})") #define FUNC_NAME s_scm_make_doubly_weak_hash_table { SCM v; - SCM_VALIDATE_INUM (1,k); - v = scm_make_weak_vector (k, SCM_EOL); + SCM_VALIDATE_INUM (1, size); + v = scm_make_weak_vector (size, SCM_EOL); SCM_DEFER_INTS; SCM_UNPACK (SCM_VELTS (v)[-1]) = 3; SCM_ALLOW_INTS; @@ -181,7 +184,7 @@ SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0 #undef FUNC_NAME SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0, - (SCM x), + (SCM obj), "@deffnx primitive weak-value-hash-table? obj\n" "@deffnx primitive doubly-weak-hash-table? obj\n" "Return @code{#t} if @var{obj} is the specified weak hash\n" @@ -189,27 +192,27 @@ SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0, "nor a weak value hash table.") #define FUNC_NAME s_scm_weak_key_hash_table_p { - return SCM_BOOL(SCM_WVECTP (x) && SCM_IS_WHVEC(x)); + return SCM_BOOL(SCM_WVECTP (obj) && SCM_IS_WHVEC(obj)); } #undef FUNC_NAME SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0, - (SCM x), - "Return @code{#t} if @var{x} is a weak value hash table.") + (SCM obj), + "Return @code{#t} if @var{obj} is a weak value hash table.") #define FUNC_NAME s_scm_weak_value_hash_table_p { - return SCM_BOOL(SCM_WVECTP (x) && SCM_IS_WHVEC_V(x)); + return SCM_BOOL(SCM_WVECTP (obj) && SCM_IS_WHVEC_V(obj)); } #undef FUNC_NAME SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0, - (SCM x), - "Return @code{#t} if @var{x} is a doubly weak hash table.") + (SCM obj), + "Return @code{#t} if @var{obj} is a doubly weak hash table.") #define FUNC_NAME s_scm_doubly_weak_hash_table_p { - return SCM_BOOL(SCM_WVECTP (x) && SCM_IS_WHVEC_B (x)); + return SCM_BOOL(SCM_WVECTP (obj) && SCM_IS_WHVEC_B (obj)); } #undef FUNC_NAME From a082616648188391369a41a1cb2395f06400b51e Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Tue, 3 Apr 2001 20:48:20 +0000 Subject: [PATCH 0787/2047] * goops/Makefile.am (goops_sources): Include goopscore.scm. --- oop/ChangeLog | 5 +++++ oop/goops/Makefile.am | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/oop/ChangeLog b/oop/ChangeLog index 86d18d1ed..fdbd9a627 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -1,3 +1,8 @@ +2001-04-03 Keisuke Nishida + + * goops/Makefile.am (goops_sources): Include goopscore.scm. + Thanks to Dale P. Smith. + 2001-03-29 Keisuke Nishida * goops/goopscore.scm: New file. diff --git a/oop/goops/Makefile.am b/oop/goops/Makefile.am index b80216bbc..fbc0c1224 100644 --- a/oop/goops/Makefile.am +++ b/oop/goops/Makefile.am @@ -25,7 +25,7 @@ AUTOMAKE_OPTIONS = foreign goops_sources = \ active-slot.scm compile.scm composite-slot.scm describe.scm \ dispatch.scm internal.scm save.scm stklos.scm util.scm \ - old-define-method.scm + old-define-method.scm goopscore.scm subpkgdatadir = $(pkgdatadir)/$(VERSION)/oop/goops subpkgdata_DATA = $(goops_sources) From 2954ad93a0debbac1e000a90d0460a4a8df85b30 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 4 Apr 2001 15:20:03 +0000 Subject: [PATCH 0788/2047] * scheme-data.texi (Alphabetic Case Mapping), (String Comparison): Rearranged function order. (Vectors): Reorganized, new introductory text, docs about read syntax. --- doc/ChangeLog | 7 ++ doc/scheme-data.texi | 277 +++++++++++++++++++++++++------------------ 2 files changed, 168 insertions(+), 116 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index b589abad3..ec42f87e9 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,10 @@ +2001-04-04 Martin Grabmueller + + * scheme-data.texi (Alphabetic Case Mapping), + (String Comparison): Rearranged function order. + (Vectors): Reorganized, new introductory text, docs about read + syntax. + 2001-04-03 Martin Grabmueller * scheme-options.texi, scheme-procedures.texi, diff --git a/doc/scheme-data.texi b/doc/scheme-data.texi index c8897266b..48d816303 100755 --- a/doc/scheme-data.texi +++ b/doc/scheme-data.texi @@ -1641,60 +1641,6 @@ predicates (REFFIXME), but are defined on character sequences. They all return @code{#t} on success and @code{#f} on failure. The predicates ending in @code{-ci} ignore the character case when comparing strings. -@r5index string<=? -@c docstring begin (texi-doc-string "guile" "string-ci<=?") -@deffn primitive string-ci<=? s1 s2 -Case insensitive lexicographic ordering predicate; return -@code{#t} if @var{s1} is lexicographically less than or equal -to @var{s2} regardless of case. -@end deffn - -@r5index string-ci< -@c docstring begin (texi-doc-string "guile" "string-ci=? -@c docstring begin (texi-doc-string "guile" "string-ci>=?") -@deffn primitive string-ci>=? s1 s2 -Case insensitive lexicographic ordering predicate; return -@code{#t} if @var{s1} is lexicographically greater than or -equal to @var{s2} regardless of case. -@end deffn - -@r5index string-ci>? -@c docstring begin (texi-doc-string "guile" "string-ci>?") -@deffn primitive string-ci>? s1 s2 -Case insensitive lexicographic ordering predicate; return -@code{#t} if @var{s1} is lexicographically greater than -@var{s2} regardless of case. -@end deffn - -@r5index string<=? -@c docstring begin (texi-doc-string "guile" "string<=?") -@deffn primitive string<=? s1 s2 -Lexicographic ordering predicate; return @code{#t} if @var{s1} -is lexicographically less than or equal to @var{s2}. -@end deffn - -@r5index string=? -@c docstring begin (texi-doc-string "guile" "string>=?") -@deffn primitive string>=? s1 s2 +@r5index string? @@ -1722,6 +1675,55 @@ Lexicographic ordering predicate; return @code{#t} if @var{s1} is lexicographically greater than @var{s2}. @end deffn +@r5index string>=? +@c docstring begin (texi-doc-string "guile" "string>=?") +@deffn primitive string>=? s1 s2 +Lexicographic ordering predicate; return @code{#t} if @var{s1} +is lexicographically greater than or equal to @var{s2}. +@end deffn + +@r5index string-ci=? +@c docstring begin (texi-doc-string "guile" "string-ci=?") +@deffn primitive string-ci=? s1 s2 +Case-insensitive string equality predicate; return @code{#t} if +the two strings are the same length and their component +characters match (ignoring case) at each position; otherwise +return @code{#f}. +@end deffn + +@r5index string-ci< +@c docstring begin (texi-doc-string "guile" "string-ci? +@c docstring begin (texi-doc-string "guile" "string-ci>?") +@deffn primitive string-ci>? s1 s2 +Case insensitive lexicographic ordering predicate; return +@code{#t} if @var{s1} is lexicographically greater than +@var{s2} regardless of case. +@end deffn + +@r5index string-ci>=? +@c docstring begin (texi-doc-string "guile" "string-ci>=?") +@deffn primitive string-ci>=? s1 s2 +Case insensitive lexicographic ordering predicate; return +@code{#t} if @var{s1} is lexicographically greater than or +equal to @var{s2} regardless of case. +@end deffn + + @node String Searching @subsection String Searching @@ -1771,6 +1773,12 @@ the C library. These are procedures for mapping strings to their upper-- or lower--case equivalents, respectively, or for capitalizing strings. +@c docstring begin (texi-doc-string "guile" "string-upcase") +@deffn primitive string-upcase str +Return a freshly allocated string containing the characters of +@var{str} in upper case. +@end deffn + @c docstring begin (texi-doc-string "guile" "string-upcase!") @deffn primitive string-upcase! str Destructively upcase every character in @var{str} and return @@ -1782,10 +1790,10 @@ y @result{} "ARRDEFG" @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "string-upcase") -@deffn primitive string-upcase str -Return a freshly allocated string containing the characters of -@var{str} in upper case. +@c docstring begin (texi-doc-string "guile" "string-downcase") +@deffn primitive string-downcase str +Return a freshly allocation string containing the characters in +@var{str} in lower case. @end deffn @c docstring begin (texi-doc-string "guile" "string-downcase!") @@ -1799,10 +1807,11 @@ y @result{} "arrdefg" @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "string-downcase") -@deffn primitive string-downcase str -Return a freshly allocation string containing the characters in -@var{str} in lower case. +@c docstring begin (texi-doc-string "guile" "string-capitalize") +@deffn primitive string-capitalize str +Return a freshly allocated string with the characters in +@var{str}, where the first character of every word is +capitalized. @end deffn @c docstring begin (texi-doc-string "guile" "string-capitalize!") @@ -1816,12 +1825,6 @@ y @result{} "Hello World" @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "string-capitalize") -@deffn primitive string-capitalize str -Return a freshly allocated string with the characters in -@var{str}, where the first character of every word is -capitalized. -@end deffn @node Appending Strings @subsection Appending Strings @@ -1842,20 +1845,6 @@ concatenation of the given strings, @var{args}. This section contains several remaining string procedures. -@c FIXME::martin: Should go into vector section. - -@c docstring begin (texi-doc-string "guile" "vector-move-left!") -@deffn primitive vector-move-left! vec1 start1 end1 vec2 start2 -Vector version of @code{substring-move-left!}. -@end deffn - -@c FIXME::martin: Should go into vector section. - -@c docstring begin (texi-doc-string "guile" "vector-move-right!") -@deffn primitive vector-move-right! vec1 start1 end1 vec2 start2 -Vector version of @code{substring-move-right!}. -@end deffn - @c docstring begin (texi-doc-string "guile" "string-ci->symbol") @deffn primitive string-ci->symbol str Return the symbol whose name is @var{str}. @var{str} is @@ -2946,19 +2935,9 @@ by @code{set-cdr!} is unspecified. @node Lists @section Lists -@r5index null? -@r5index list? + + @r5index list -@r5index length -@r5index append -@r5index reverse -@r5index list-tail -@r5index list-ref -@r5index memq -@r5index memv -@r5index member - - @c docstring begin (texi-doc-string "guile" "list") @deffn primitive list . objs Return a list containing @var{objs}, the arguments to @@ -2975,21 +2954,25 @@ result. This function is called @code{list*} in some other Schemes and in Common LISP. @end deffn +@r5index list? @c docstring begin (texi-doc-string "guile" "list?") @deffn primitive list? x Return @code{#t} iff @var{x} is a proper list, else @code{#f}. @end deffn +@r5index null? @c docstring begin (texi-doc-string "guile" "null?") @deffn primitive null? x Return @code{#t} iff @var{x} is the empty list, else @code{#f}. @end deffn +@r5index length @c docstring begin (texi-doc-string "guile" "length") @deffn primitive length lst Return the number of elements in list @var{lst}. @end deffn +@r5index append @c docstring begin (texi-doc-string "guile" "append") @deffn primitive append . args Return a list consisting of the elements the lists passed as @@ -3024,6 +3007,7 @@ Return a pointer to the last pair in @var{lst}, signalling an error if @var{lst} is circular. @end deffn +@r5index reverse @c docstring begin (texi-doc-string "guile" "reverse") @deffn primitive reverse lst Return a new list that contains the elements of @var{lst} but @@ -3046,6 +3030,7 @@ of the modified list is not lost, it is wise to save the return value of @code{reverse!} @end deffn +@r5index list-ref @c docstring begin (texi-doc-string "guile" "list-ref") @deffn primitive list-ref list k Return the @var{k}th element from @var{list}. @@ -3056,6 +3041,7 @@ Return the @var{k}th element from @var{list}. Set the @var{k}th element of @var{list} to @var{val}. @end deffn +@r5index list-tail @c docstring begin (texi-doc-string "guile" "list-tail") @c docstring begin (texi-doc-string "guile" "list-cdr-ref") @deffn primitive list-tail lst k @@ -3084,6 +3070,7 @@ return it. Return a (newly-created) copy of @var{lst}. @end deffn +@r5index memq @c docstring begin (texi-doc-string "guile" "memq") @deffn primitive memq x lst Return the first sublist of @var{lst} whose car is @code{eq?} @@ -3094,6 +3081,7 @@ occur in @var{lst}, then @code{#f} (not the empty list) is returned. @end deffn +@r5index memv @c docstring begin (texi-doc-string "guile" "memv") @deffn primitive memv x lst Return the first sublist of @var{lst} whose car is @code{eqv?} @@ -3104,6 +3092,7 @@ occur in @var{lst}, then @code{#f} (not the empty list) is returned. @end deffn +@r5index member @c docstring begin (texi-doc-string "guile" "member") @deffn primitive member x lst Return the first sublist of @var{lst} whose car is @@ -4818,6 +4807,45 @@ table into an a-list of key-value pairs. @node Vectors @section Vectors +@c FIXME::martin: This node should come before the non-standard data types. + +Vectors are sequences of Scheme objects. Unlike lists, the length of a +vector, once the vector is created, cannot be changed. The advantage of +vectors over lists is that the time required to access one element of a +vector is constant, whereas lists have an access time linear to the +index of the accessed element in the list. + +Note that the vectors documented in this section can contain any kind of +Scheme object, it is even possible to have different types of objects in +the same vector. + +@subsection Vector Read Syntax + +Vectors can literally be entered in source code, just like strings, +characters or some of the other data types. The read syntax for vectors +is as follows: A sharp sign (@code{#}), followed by an opening +parentheses, all elements of the vector in their respective read syntax, +and finally a closing parentheses. The following are examples of the +read syntax for vectors; where the first vector only contains numbers +and the second three different object types: a string, a symbol and a +number in hexidecimal notation. + +@lisp +#(1 2 3) +#("Hello" foo #xdeadbeef) +@end lisp + +@subsection Vector Predicates + +@r5index vector? +@c docstring begin (texi-doc-string "guile" "vector?") +@deffn primitive vector? obj +Return @code{#t} if @var{obj} is a vector, otherwise return +@code{#f}. +@end deffn + +@subsection Vector Constructors + @r5index make-vector @c docstring begin (texi-doc-string "guile" "make-vector") @deffn primitive make-vector k [fill] @@ -4851,6 +4879,28 @@ elements of @var{vector}. @end lisp @end deffn +@subsection Vector Modification + +A vector created by any of the vector constructor procedures (REFFIXME) +documented above can be modified using the following procedures. + +According to R5RS, using any of these procedures on literally entered +vectors is an error, because these vectors are considered to be +constant, although Guile currently does not detect this error. + +@r5index vector-set! +@deffn primitive vector-set! vector k obj +@var{k} must be a valid index of @var{vector}. +@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}. +The value returned by @samp{vector-set!} is unspecified. +@lisp +(let ((vec (vector 0 '(2 2 2 2) "Anna"))) + (vector-set! vec 1 '("Sue" "Sue")) + vec) @result{} #(0 ("Sue" "Sue") "Anna") +(vector-set! '#(0 1 2) 1 "doe") @result{} @emph{error} ; constant vector +@end lisp +@end deffn + @r5index vector-fill! @c docstring begin (texi-doc-string "guile" "vector-fill!") @deffn primitive vector-fill! v fill @@ -4858,13 +4908,21 @@ Store @var{fill} in every element of @var{vector}. The value returned by @code{vector-fill!} is unspecified. @end deffn -@r5index vector? -@c docstring begin (texi-doc-string "guile" "vector?") -@deffn primitive vector? obj -Return @code{#t} if @var{obj} is a vector, otherwise return -@code{#f}. +@c docstring begin (texi-doc-string "guile" "vector-move-left!") +@deffn primitive vector-move-left! vec1 start1 end1 vec2 start2 +Vector version of @code{substring-move-left!}. @end deffn +@c docstring begin (texi-doc-string "guile" "vector-move-right!") +@deffn primitive vector-move-right! vec1 start1 end1 vec2 start2 +Vector version of @code{substring-move-right!}. +@end deffn + +@subsection Vector Selection + +These procedures return information about a given vector, such as the +size or what elements are contained in the vector. + @r5index vector-length @deffn primitive vector-length vector Returns the number of elements in @var{vector} as an exact integer. @@ -4885,19 +4943,6 @@ Returns the number of elements in @var{vector} as an exact integer. @end lisp @end deffn -@r5index vector-set! -@deffn primitive vector-set! vector k obj -@var{k} must be a valid index of @var{vector}. -@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}. -The value returned by @samp{vector-set!} is unspecified. -@lisp -(let ((vec (vector 0 '(2 2 2 2) "Anna"))) - (vector-set! vec 1 '("Sue" "Sue")) - vec) @result{} #(0 ("Sue" "Sue") "Anna") -(vector-set! '#(0 1 2) 1 "doe") @result{} @emph{error} ; constant vector -@end lisp -@end deffn - @node Hooks @section Hooks From 5273f7c94721ad13430fa68e024a326f3fb47196 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Thu, 5 Apr 2001 21:09:04 +0000 Subject: [PATCH 0789/2047] * Makefile.am (ice9_sources): Add history.scm. --- ice-9/ChangeLog | 4 ++++ ice-9/Makefile.am | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index c315174b8..afeceac0e 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2001-04-05 Keisuke Nishida + + * Makefile.am (ice9_sources): Add history.scm. + 2001-03-29 Marius Vollmer * boot-9.scm (init-dynamic-module): Fix typo in call to diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index cd68f6ca9..1a07748ce 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -31,7 +31,7 @@ ice9_sources = \ rdelim.scm receive.scm srfi-8.scm regex.scm runq.scm \ safe-r5rs.scm safe.scm session.scm slib.scm stack-catch.scm \ streams.scm string-fun.scm syncase.scm tags.scm threads.scm \ - buffered-input.scm time.scm + buffered-input.scm time.scm history.scm subpkgdatadir = $(pkgdatadir)/$(VERSION)/ice-9 subpkgdata_DATA = $(ice9_sources) From b727d0bde16050e03386cd8bae4661f2d52b3218 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Thu, 5 Apr 2001 21:12:17 +0000 Subject: [PATCH 0790/2047] * history.scm: Create the module (value-history) at the beginning. --- ice-9/ChangeLog | 1 + ice-9/history.scm | 2 ++ 2 files changed, 3 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index afeceac0e..f512f2a11 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,6 +1,7 @@ 2001-04-05 Keisuke Nishida * Makefile.am (ice9_sources): Add history.scm. + * history.scm: Create the module (value-history) at the beginning. 2001-03-29 Marius Vollmer diff --git a/ice-9/history.scm b/ice-9/history.scm index 2eafccc8f..e32bd5d15 100644 --- a/ice-9/history.scm +++ b/ice-9/history.scm @@ -20,6 +20,8 @@ (define-module (ice-9 history)) +(process-define-module '((value-history))) + (define (use-value-history x) (module-use! (current-module) (resolve-module '(value-history)))) From c7a813af8940173d1dbe0426c554aa6cf7af80c0 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 6 Apr 2001 09:51:25 +0000 Subject: [PATCH 0791/2047] Update copyright. Use `export' and `export-syntax' instead of `define-public' and `defmacro-public'. (make-thread): Rename first arg to `proc'; nfc. (begin-thread, monitor): Rename second arg to `rest'; nfc. (with-mutex): Rename second arg to `body'; nfc. --- ice-9/threads.scm | 82 +++++++++++++++++++++++++++-------------------- 1 file changed, 47 insertions(+), 35 deletions(-) diff --git a/ice-9/threads.scm b/ice-9/threads.scm index a2ca23449..b5d0cf9ce 100644 --- a/ice-9/threads.scm +++ b/ice-9/threads.scm @@ -1,15 +1,15 @@ -;;;; Copyright (C) 1996, 1998 Free Software Foundation, Inc. -;;;; +;;;; Copyright (C) 1996, 1998, 2001 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 ;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, @@ -19,6 +19,7 @@ ;;;; threads.scm -- User-level interface to Guile's thread system ;;;; 4 March 1996, Anthony Green ;;;; Modified 5 October 1996, MDJ +;;;; Modified 6 April 2001, ttn ;;;; ---------------------------------------------------------------- ;;;; @@ -27,51 +28,62 @@ -; --- MACROS ------------------------------------------------------- - -(define-public (%thread-handler tag . args) +(define (%thread-handler tag . args) (fluid-set! the-last-stack #f) (unmask-signals) (let ((n (length args)) (p (current-error-port))) - (display "In thread:" p) - (newline p) - (if (>= n 3) - (display-error #f - p - (car args) - (cadr args) - (caddr args) - (if (= n 4) - (cadddr args) - '())) - (begin - (display "uncaught throw to " p) - (display tag p) - (display ": " p) - (display args p) - (newline p))))) + (display "In thread:" p) + (newline p) + (if (>= n 3) + (display-error #f + p + (car args) + (cadr args) + (caddr args) + (if (= n 4) + (cadddr args) + '())) + (begin + (display "uncaught throw to " p) + (display tag p) + (display ": " p) + (display args p) + (newline p))))) -(defmacro-public make-thread (fn . args) +; --- MACROS ------------------------------------------------------- + +(defmacro make-thread (proc . args) `(call-with-new-thread (lambda () - (,fn ,@args)) + (,proc ,@args)) %thread-handler)) -(defmacro-public begin-thread (first . thunk) +(defmacro begin-thread (first . rest) `(call-with-new-thread (lambda () (begin - ,first ,@thunk)) + ,first ,@rest)) %thread-handler)) -(defmacro-public with-mutex (m . thunk) +(defmacro with-mutex (m . body) `(dynamic-wind - (lambda () (lock-mutex ,m)) - (lambda () (begin ,@thunk)) - (lambda () (unlock-mutex ,m)))) + (lambda () (lock-mutex ,m)) + (lambda () (begin ,@body)) + (lambda () (unlock-mutex ,m)))) -(defmacro-public monitor (first . thunk) +(defmacro monitor (first . rest) `(with-mutex ,(make-mutex) - (begin - ,first ,@thunk))) + (begin + ,first ,@rest))) + +;; export + +(export %thread-handler) + +(export-syntax make-thread + begin-thread + with-mutex + monitor) + +;;; threads.scm ends here From f302fb90bfc9f7bab521173de26c942ce3c8e0bd Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 6 Apr 2001 09:52:45 +0000 Subject: [PATCH 0792/2047] (Higher level thread procedures): Rewrite. --- doc/scheme-scheduling.texi | 78 +++++++++++++++++++------------------- 1 file changed, 39 insertions(+), 39 deletions(-) diff --git a/doc/scheme-scheduling.texi b/doc/scheme-scheduling.texi index c9756eb33..af10144af 100644 --- a/doc/scheme-scheduling.texi +++ b/doc/scheme-scheduling.texi @@ -225,16 +225,16 @@ executed in a new dynamic root. @c are in sync. @c begin (texi-doc-string "guile" "call-with-new-thread") -@deffn primitive call-with-new-thread thunk error-thunk +@deffn primitive call-with-new-thread thunk error-handler Evaluate @code{(thunk)} in a new thread, and new dynamic context, returning a new thread object representing the thread. -If an error occurs during evaluation, call error-thunk, passing it an +If an error occurs during evaluation, call error-handler, passing it an error code describing the condition. [Error codes are currently meaningless integers. In the future, real values will be specified.] -If this happens, the error-thunk is called outside the scope of the new +If this happens, the error-handler is called outside the scope of the new root -- it is called in the same dynamic context in which -with-new-thread was evaluated, but not in the callers thread. +with-new-thread was evaluated, but not in the caller's thread. All the evaluation rules for dynamic roots apply to threads. @end deffn @@ -287,53 +287,53 @@ blocked on @var{mutex} is awakened and grabs the mutex lock. @node Higher level thread procedures @subsection Higher level thread procedures -@c NJFIXME the following doc is a repeat of the previous node! +@c new by ttn, needs review -@c begin (texi-doc-string "guile" "call-with-new-thread") -@deffn primitive call-with-new-thread thunk error-thunk -Evaluate @code{(thunk)} in a new thread, and new dynamic context, -returning a new thread object representing the thread. +Higher level thread procedures are available by loading the +@code{(ice-9 threads)} module. These provide standardized +thread creation and mutex interaction. -If an error occurs during evaluation, call error-thunk, passing it an -error code describing the condition. [Error codes are currently -meaningless integers. In the future, real values will be specified.] -If this happens, the error-thunk is called outside the scope of the new -root -- it is called in the same dynamic context in which -with-new-thread was evaluated, but not in the callers thread. +@c docstring begin (texi-doc-string "guile" "%thread-handler") +@deffn primitive %thread-handler tag args@dots{} -All the evaluation rules for dynamic roots apply to threads. +This procedure is specified as the standard error-handler for +@code{make-thread} and @code{begin-thread}. If the number of @var{args} +is three or more, use @code{display-error}, otherwise display a message +"uncaught throw to @var{tag}". All output is sent to the port specified +by @code{current-error-port}. + +Before display, global var @code{the-last-stack} is set to @code{#f} +and signals are unmasked with @code{unmask-signals}. + +[FIXME: Why distinguish based on number of args?! Cue voodoo music here.] @end deffn -@c begin (texi-doc-string "guile" "join-thread") -@deffn primitive join-thread thread -Suspend execution of the calling thread until the target @var{thread} -terminates, unless the target @var{thread} has already terminated. +@c docstring begin (texi-doc-string "guile" "make-thread") +@deffn macro make-thread fn [args@dots{}] +Apply @var{fn} to @var{args} in a new thread formed by +@code{call-with-new-thread} using @var{%thread-handler} as the error +handler. @end deffn -@c begin (texi-doc-string "guile" "yield") -@deffn primitive yield -If one or more threads are waiting to execute, calling yield forces an -immediate context switch to one of them. Otherwise, yield has no effect. +@c docstring begin (texi-doc-string "guile" "begin-thread") +@deffn macro begin-thread first [rest@dots{}] +Evaluate forms @var{first} and @var{rest} in a new thread formed by +@code{call-with-new-thread} using @var{%thread-handler} as the error +handler. @end deffn -@c begin (texi-doc-string "guile" "make-mutex") -@deffn primitive make-mutex -Create a new mutex object. +@c docstring begin (texi-doc-string "guile" "with-mutex") +@deffn macro with-mutex m [body@dots{}] +Lock mutex @var{m}, evaluate @var{body}, and then unlock @var{m}. +These sub-operations form the branches of a @var{dynamic-wind}. @end deffn -@c begin (texi-doc-string "guile" "lock-mutex") -@deffn primitive lock-mutex mutex -Lock @var{mutex}. If the mutex is already locked, the calling thread -blocks until the mutex becomes available. The function returns when -the calling thread owns the lock on @var{mutex}. -@end deffn +@c docstring begin (texi-doc-string "guile" "monitor") +@deffn macro monitor first [rest@dots{}] +Evaluate forms @var{first} and @var{rest} under a newly created +anonymous mutex, using @var{with-mutex}. -@c docstring begin (texi-doc-string "guile" "unlock-mutex") -@deffn primitive unlock-mutex mutex -Unlocks @var{mutex} if the calling thread owns the lock on @var{mutex}. -Calling unlock-mutex on a mutex not owned by the current thread results -in undefined behaviour. Once a mutex has been unlocked, one thread -blocked on @var{mutex} is awakened and grabs the mutex lock. +[FIXME: Is there any way to access the mutex?] @end deffn From 83b646f27f0cec98c4b056436b794aba2de3de22 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 6 Apr 2001 10:00:35 +0000 Subject: [PATCH 0793/2047] (Higher level thread procedures): Replace some instances of `@var' with `@code'. --- doc/scheme-scheduling.texi | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/doc/scheme-scheduling.texi b/doc/scheme-scheduling.texi index af10144af..4b717faf9 100644 --- a/doc/scheme-scheduling.texi +++ b/doc/scheme-scheduling.texi @@ -309,29 +309,29 @@ and signals are unmasked with @code{unmask-signals}. @end deffn @c docstring begin (texi-doc-string "guile" "make-thread") -@deffn macro make-thread fn [args@dots{}] -Apply @var{fn} to @var{args} in a new thread formed by -@code{call-with-new-thread} using @var{%thread-handler} as the error +@deffn macro make-thread proc [args@dots{}] +Apply @var{proc} to @var{args} in a new thread formed by +@code{call-with-new-thread} using @code{%thread-handler} as the error handler. @end deffn @c docstring begin (texi-doc-string "guile" "begin-thread") @deffn macro begin-thread first [rest@dots{}] Evaluate forms @var{first} and @var{rest} in a new thread formed by -@code{call-with-new-thread} using @var{%thread-handler} as the error +@code{call-with-new-thread} using @code{%thread-handler} as the error handler. @end deffn @c docstring begin (texi-doc-string "guile" "with-mutex") @deffn macro with-mutex m [body@dots{}] Lock mutex @var{m}, evaluate @var{body}, and then unlock @var{m}. -These sub-operations form the branches of a @var{dynamic-wind}. +These sub-operations form the branches of a @code{dynamic-wind}. @end deffn @c docstring begin (texi-doc-string "guile" "monitor") @deffn macro monitor first [rest@dots{}] Evaluate forms @var{first} and @var{rest} under a newly created -anonymous mutex, using @var{with-mutex}. +anonymous mutex, using @code{with-mutex}. [FIXME: Is there any way to access the mutex?] @end deffn From 6414341421f48ce3c7df71943926dfc1108f39b6 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 6 Apr 2001 14:45:34 +0000 Subject: [PATCH 0794/2047] * boot-9.scm (warn-autoload-deprecation): Close parenthesis in "You just tried to autoload ..." message. --- ice-9/ChangeLog | 5 +++++ ice-9/boot-9.scm | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index f512f2a11..72a83c462 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2001-04-06 Neil Jerram + + * boot-9.scm (warn-autoload-deprecation): Close parenthesis in + "You just tried to autoload ..." message. + 2001-04-05 Keisuke Nishida * Makefile.am (ice9_sources): Add history.scm. diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 57f8a3e8e..f2482b821 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1819,7 +1819,7 @@ ";;; Write a Scheme file instead that uses `dynamic-link' directly.\n" (current-error-port)) (format (current-error-port) - ";;; (You just tried to autoload module ~S.\n" modname)) + ";;; (You just tried to autoload module ~S.)\n" modname)) (define (init-dynamic-module modname) ;; Register any linked modules which has been registered on the C level From a8944ae1c77a7273d44ab91ffb7c3b7d7cdecbd6 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 6 Apr 2001 19:07:51 +0000 Subject: [PATCH 0795/2047] *** empty log message *** --- doc/ChangeLog | 18 +++++-- ice-9/ChangeLog | 137 ++++++++++++++++++++++++++---------------------- 2 files changed, 87 insertions(+), 68 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index ec42f87e9..50eae1226 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,11 @@ +2001-04-06 Thien-Thi Nguyen + + * scheme-scheduling.texi (Higher level thread + procedures): Replace some instances of `@var' with `@code'. + + * scheme-scheduling.texi (Higher level thread + procedures): Rewrite. + 2001-04-04 Martin Grabmueller * scheme-data.texi (Alphabetic Case Mapping), @@ -160,10 +168,10 @@ * .cvsignore, Makefile.am, README: Merged. * sources: New subdirectory. - + Both the following files are about to be replaced by files from guile-doc/ref. - + * texinfo.tex: Removed. * data-rep.texi: Removed. @@ -193,7 +201,7 @@ * data-rep.texi (Garbage Collection): Fix "accomodate" spelling mistake. - + 2000-06-30 Dirk Herrmann * data-rep.tex: Removed documentation for SCM_OUTOFRANGE. @@ -253,7 +261,7 @@ Fri Jun 25 22:21:43 1999 Greg Badros * data-rep.texi: Updated SMOB docs to talk about scm_make_smob_type_mfpe, SCM_RETURN_NEWSMOB, SCM_NEWSMOB function and macros. - + 1999-04-17 Jim Blandy * Makefile.in: Regenerated. @@ -283,7 +291,7 @@ Fri Jun 25 22:21:43 1999 Greg Badros * Makefile.am (EXAMPLE_SMOB_FILES, dist-hook): New variable and target, to get the example-smob directory into the distribution. * Makefile.in: Regenerated. - + 1998-10-08 Jim Blandy * .cvsignore: New file, containing data-rep.info. I'm not sure diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 72a83c462..bd4b6095b 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,14 @@ +2001-04-06 Thien-Thi Nguyen + + * threads.scm: Update copyright. + + Use `export' and `export-syntax' instead of + `define-public' and `defmacro-public'. + + (make-thread): Rename first arg to `proc'; nfc. + (begin-thread, monitor): Rename second arg to `rest'; nfc. + (with-mutex): Rename second arg to `body'; nfc. + 2001-04-06 Neil Jerram * boot-9.scm (warn-autoload-deprecation): Close parenthesis in @@ -151,7 +162,7 @@ (named-module-use!): New function. (top-repl): Do not use `define-module'. Use equivalent low-level means instead. - + 2001-02-11 Marius Vollmer * boot-9.scm (scm-style-repl): Use `primitive-eval' instead of @@ -162,12 +173,12 @@ * and-let-star-compat.scm: Display the warning to the `current-error-port'. - + 2001-02-04 Marius Vollmer Avoid the use of "*" in file names for the benefit of lesser operating systems. - + * and-let-star.scm, and-let*.scm: Renamed `and-let*.scm' to `and-let-star.scm'. Updated module name as well. * and-let-star-compat.scm: New file, installed as `and-let*.scm'. @@ -176,7 +187,7 @@ (install-data-local): Install "and-let-star-compat.scm" as "and-let*.scm", ignoring errors. (EXTRA_DIST): Distribute `and-let-star-compat.scm'. - + 2001-01-26 Dirk Herrmann This patch fixes a problem reported by Martin Grabmueller about @@ -274,7 +285,7 @@ Pirotte for the bug report). standard file descriptors 0, 1, 2 in the child process are now set up from current-input-port etc., where possible. - + 2000-10-10 Dirk Herrmann * syncase.scm (eval): string=? requires a string argument. @@ -400,7 +411,7 @@ * safe-r5rs.scm (eval): Removed definition. - * emacs.scm (emacs-eval-request): + * emacs.scm (emacs-eval-request): (emacs-symdoc): (This procedure needs updating!) 2000-08-10 Mikael Djurfeldt @@ -461,7 +472,7 @@ (process-define-module): New define-module options: pure, export. See NEWS. (scm-style-repl): Added optional module argument. - + * null.scm, r5rs.scm, safe-r5rs.scm, safe.scm: New modules. 2000-06-20 Mikael Djurfeldt @@ -599,7 +610,7 @@ Tue Jun 6 09:21:28 2000 Greg J. Badros 2000-04-03 Michael Livshin - * streams.scm (stream-fold, stream-for-each): don't use named let, + * streams.scm (stream-fold, stream-for-each): don't use named let, because it prevents the gc from junking the stream argument. Thu Mar 9 08:05:08 2000 Greg J. Badros @@ -619,7 +630,7 @@ Wed Mar 1 12:21:02 2000 Greg J. Badros Sun Feb 13 18:03:19 2000 Greg J. Badros - * slib.scm: Rename software-type to slib:software-type and make it + * slib.scm: Rename software-type to slib:software-type and make it public. * r4rs.scm: Added documentation; largely cut and pasted from R4RS @@ -669,7 +680,7 @@ Tue Jan 11 10:49:22 2000 Greg J. Badros 1999-12-15 Gary Houston - * slib.scm (library-vicinity, home-vicinity, + * slib.scm (library-vicinity, home-vicinity, scheme-implementation-type, scheme-implemenation-version): use define-public to export from the module. @@ -687,7 +698,7 @@ Sun Dec 12 19:18:52 1999 Greg J. Badros * popen.scm, slib.scm: Added some docstrings for procedures that were primitives that I encountered in posix.texi. - + 1999-11-19 Gary Houston * Makefile.am (ice9_sources): add arrays.scm. @@ -716,7 +727,7 @@ Sun Dec 12 19:18:52 1999 Greg J. Badros * boot-9.scm (load-user-init): check that the posix feature is available before using getpw and getuid. (top-repl): don't install handlers for SIGINT etc., without posix. - (file-is-directory?): use 'posix instead of i/o-extensions to + (file-is-directory?): use 'posix instead of i/o-extensions to check for stat. (load-user-init): use file-exists? and file-is-directory? to check for .guile, instead of stat. @@ -728,7 +739,7 @@ Sun Dec 12 19:18:52 1999 Greg J. Badros posix.scm, networking.scm: new files. Move definitions from boot-9.scm if they are only useful with posix/networking available. - + * Makefile.am (ice9_sources): add posix.scm, networking.scm. 1999-09-17 Mikael Djurfeldt @@ -792,7 +803,7 @@ Sun Dec 12 19:18:52 1999 Greg J. Badros readline is used by the repl run by this thread. (handle-system-error): Print "Backtrace:" before backtrace since this is no longer done by display-backtrace. - + * debug.scm (frame-number->index): Optionally take stack as argument. @@ -804,7 +815,7 @@ Sun Dec 12 19:18:52 1999 Greg J. Badros ("backtrace"): Use builtin backtrace printing. Use (ice-9 debug). Use readline conditionally. - + 1999-09-11 Jim Blandy * regex.scm (fold-matches, list-matches): New functions. @@ -824,7 +835,7 @@ Sun Dec 12 19:18:52 1999 Greg J. Badros * Makefile.am: Removed mention of readline.scm. * Makefile.in: Regenerated. - + 1999-09-11 Jim Blandy Delete the test which compares the configuration date of libguile @@ -859,7 +870,7 @@ Sun Dec 12 19:18:52 1999 Greg J. Badros 1999-08-29 Keisuke Nishida * boot-9.scm (try-module-autoload): Use %search-load-path. - + 1999-08-24 Mikael Djurfeldt * boot-9.scm: Removed old style hooks. @@ -930,7 +941,7 @@ Sun Dec 12 19:18:52 1999 Greg J. Badros that was introduced to fix the $ problem: * expect.scm (expect): call the match proc an extra time at end - of file and set the eof? argument appropriately. call + of file and set the eof? argument appropriately. call expect-eof-proc only if the last call didn't match. * expect.scm (expect-strings): change port to eof? in match proc. * expect.scm (expect-regexec): take an eof indicator as an argument @@ -954,9 +965,9 @@ Sun Dec 12 19:18:52 1999 Greg J. Badros * popen.scm: applied fixes from Greg Harvey. use a guardian and a gc-thunk so that cleanup is done if a pipe is garbage - collected or closed with close-port. use a weak hash-table instead of + collected or closed with close-port. use a weak hash-table instead of an alist. - + 1999-03-20 Gary Houston * expect.scm (expect): call the match proc with the port instead. @@ -966,7 +977,7 @@ Sun Dec 12 19:18:52 1999 Greg J. Badros from the port when it may not be needed. hence: (expect-strings-exec-flags): new variable/parameter, supplies flags for regexp-exec. if this includes regexp/noteol, then - automatic regexp/noteol handling (requiring an extra peeked char) + automatic regexp/noteol handling (requiring an extra peeked char) is enabled. default is regexp/noteol. (expect-strings-compile-flags): new variable/parameter, supplies flags for make-regexp. default is regexp/newline. @@ -996,8 +1007,8 @@ Sun Dec 12 19:18:52 1999 Greg J. Badros error catching loop after quit received. (top-repl): flush all ports when the repl terminates. - * boot-9.scm (error-catching-loop): flush all ports before - primitive exit if non-interactive. + * boot-9.scm (error-catching-loop): flush all ports before + primitive exit if non-interactive. force-output on current-error-port if interactive. * boot-9.scm (reopen-file): deleted. @@ -1029,7 +1040,7 @@ Sun Dec 12 19:18:52 1999 Greg J. Badros * Makefile.am: Add string-case.scm and format.scm to ice9_sources. * Makefile.in: Regenerated. - + * string-case.scm: New file, brought in from SLIB, and adapted to Guile's module system. @@ -1044,7 +1055,7 @@ Sun Dec 12 19:18:52 1999 Greg J. Badros modern CL behavior. (format:num->cardinal): Don't assume that an elseless if returns '() when the condition is false. - + 1999-04-17 Jim Blandy * Makefile.in: Regenerated. @@ -1075,7 +1086,7 @@ Sun Dec 12 19:18:52 1999 Greg J. Badros load a module (e.g. with `use-modules') work until source is actually found for the module (e.g. because the correct catalog has been added to the load path). - + Use try-load-module. 1999-03-18 Mikael Djurfeldt @@ -1124,7 +1135,7 @@ Sun Dec 12 19:18:52 1999 Greg J. Badros Modules which doesn't have the :no-backtrace specifier are user modules. - + A stack frame is classified as a user frame if it has source code associated with it and if this source code can be proven to come from a user module. If it can be proven to come from a system @@ -1184,7 +1195,7 @@ Sun Dec 12 19:18:52 1999 Greg J. Badros 1999-02-09 Maciej Stachowiak - * optargs.scm: New file. + * optargs.scm: New file. * Makefile.am (ice9_sources): Add optargs.scm here. Makefile.in not regenerated because I don't have the right version of Automake. @@ -1287,7 +1298,7 @@ Sun Dec 12 19:18:52 1999 Greg J. Badros * boot-9.scm (init-dynamic-module): Remove module from registered-modules as soon as possible in case we are recursively invoked; Set public interface before doing the dynamic-call. - + * boot-9.scm (map-in-order): Removed (replaced by scm_serial_map). (abort-hook, before-error-hook, after-error-hook, before-backtrace-hook, after-backtrace-hook, before-read-hook, @@ -1545,7 +1556,7 @@ Fri Oct 30 15:15:37 1998 Mikael Djurfeldt * boot-9.scm: Antirevert Jim's readline code which he reverted 19971027 and adapt it to the current readline interface. - + * boot-9.scm (top-repl): Only enable readline if not using the Emacs interface; Only use repl prompt when using the readline port from repl-read. (We don't want to see it when calling `read'.) @@ -1567,12 +1578,12 @@ Fri Oct 30 15:15:37 1998 Mikael Djurfeldt * nonblocking.scm: Removed. libguile is now inherently nonblocking through the use of scm_internal_select. - + * emacs.scm: Removed use of nonblocking.scm. * gwish.scm, gtcl.scm: Removed. tcltk.scm has made these obsolete. - + 1998-04-15 Mikael Djurfeldt * runq.scm (runq-control): Corrected spelling of enqueue!. @@ -1686,7 +1697,7 @@ Wed Oct 8 03:16:01 1997 Gary Houston * (error-catching-loop): new local variable "interactive". if #f, abort terminates the process. - (set-batch-mode?!, batch-mode?): new closures, defined in + (set-batch-mode?!, batch-mode?): new closures, defined in error-catching-loop. the names are from scsh. 1997-10-06 Marius Vollmer @@ -1817,7 +1828,7 @@ Wed Sep 10 20:12:45 1997 Mikael Djurfeldt Added hack to transfer syntactic information from the builtin variable `define' to the slib version if module (ice-9 slib) has been loaded. - + Fri Sep 5 05:47:36 1997 Mikael Djurfeldt * syncase.scm (sc-interface, sc-expand): Removed hook setup. @@ -2030,7 +2041,7 @@ Mon Jun 23 16:13:38 1997 Jim Blandy Plug in read-path-list-notation as the parser for #/ lists, instead of the anonymous lambda form calling parse-path-symbol. (Thanks to Maurizio Vitale.) - + * boot-9.scm (make-list): Remove the definition of this function from the (ice-9 common-list) module; make the `init' argument optional in the scm module's definition, to match the deleted @@ -2099,7 +2110,7 @@ Wed Jun 4 23:27:16 1997 Marius Vollmer commented out printing code. (record-type-name, record-type-fields): Adjusted slot offsets. (%print-module): Reduce argument list to "mod" and "port". - + Tue Jun 3 17:04:18 1997 Jim Blandy * slib.scm (identity): New function, used by SLIB. @@ -2110,7 +2121,7 @@ Sat May 31 18:57:12 1997 Gary Houston don't define ticks-interrupt etc. top-repl: install signal handlers for SIGINT, SIGFPE, SIGSEGV, SIGBUS during call to scm-style-repl. - + Fri May 30 18:08:10 1997 Jim Blandy * slib.scm (slib:load): Use primitive-load-path instead of @@ -2186,14 +2197,14 @@ Wed Apr 30 15:25:15 1997 Marius Vollmer * boot-9.scm (link-dynamic-module): Do not catch errors from dynamic-link and dynamic-call. When the shared library exists it is now assumed to be suitable for a dynamic C module. - + Fri Apr 25 21:21:35 1997 Marius Vollmer * boot-9.scm (process-use-modules): New function to support the use-modules macro (use-modules): throw an error iff one of the requested modules can't be found. - + Tue Apr 29 06:54:46 1997 Gary Houston * boot-9.scm: don't define timer-thunk or gc-thunk. @@ -2230,7 +2241,7 @@ Tue Apr 1 17:46:49 1997 Gary Houston * expect.scm (expect-select): correct the millisecond timeout arithmetic (from Marko.Kohtala@ntc.nokia.com). - + Mon Mar 31 03:23:19 1997 Gary Houston * boot-9.scm (open-input-pipe, open-output-pipe): defined here @@ -2354,7 +2365,7 @@ Sat Mar 1 00:10:38 1997 Mikael Djurfeldt * boot-9.scm (error-catching-loop): Added handling of apply-frame and exit-frame exceptions. - + * boot-9.scm (assert-repl-prompt, the-prompt-string): Removed. (set-repl-prompt!): Setter for repl prompt. (scm-style-repl): If prompt is #f, don't prompt; if prompt is a @@ -2482,14 +2493,14 @@ Wed Nov 27 14:16:14 1996 Marius Vollmer * boot-9.scm (macroexpand-1, macroexpand), slib.scm (slib:features), r4rs.scm (%load-verbosely): "defined?" is now a function, use it accordingly. - + Thu Nov 21 11:12:10 1996 Jim Blandy It's an "eval closure", not an "eval thunk." A thunk is a function of no arguments. * boot-9.scm (module-type): Rename module field. (make-module, eval-in-module, make-root-module, - set-current-module): Uses changed. + set-current-module): Uses changed. (module-eval-closure, set-module-eval-closure!, root-module-closure): Renamed from module-eval-thunk, set-module-eval-thunk!, root-module-thunk. @@ -2508,37 +2519,37 @@ Sat Nov 2 20:00:42 1996 Mikael Djurfeldt debug.scm). But during development we want to have them also *inside* boot-9.scm. Therefore, two lines are added at the beginning of boot-9.scm to enable these. - + Call `provide' so that `records' are included among the `*features*'. - + The scheme for saving the stack has been adjusted: save-stack is now commonly available for saving the stack. Calling `save-stack' sets a flag `stack-saved?' which prevents overwriting the stack. `stack-saved?' is reset at `abort'. - + Spelling correction: seperate --> separate. - + Removed `:'s that had creeped into some comments. - + The repl now doesn't print # results any longer If the user wants to see this, he can do (assert-repl-print-unspecified #t) in his startup file. - + The user now gets a friendly message instead of a backtrace at error. - + Added `before-read-hook'. - + Load module (ice-9 emacs) if option `-e' was specified. - + (provide): New function. - + (error): Save stack at entry, so that Guile entrails won't show up in backtraces. - + (backtrace): New function. - + (save-stack): Can now take arbitrary number of stack narrowing specifier pairs. The first specifier in a pair controls inner border, the second the outer border. A number means cut that @@ -2551,15 +2562,15 @@ Sat Nov 2 20:00:42 1996 Mikael Djurfeldt * slib.scm (slib:load): Adapt to the new behavior of primitive-load: It doesn't any longer try both with and without ".scm" extension. (We don't want to use %search-load-path here.) - + (implementation-vicinity): New function. slib requires it - + (library-vicinity): Updated. - + Load "require.scm" in the library-vicinity. - + (install-require-vicinity, install-require-module): New functions. - + Mon Oct 28 17:56:29 1996 Jim Blandy * boot-9.scm (load-from-path): New function. @@ -2675,7 +2686,7 @@ Mon Oct 14 22:20:30 1996 Mikael Djurfeldt Mon Oct 14 06:05:42 1996 Mikael Djurfeldt * Makefile.in: Added threads.scm. - + Mon Oct 14 04:21:51 1996 Mikael Djurfeldt * debug.scm (make-enable, make-disable): Simplified. @@ -2706,7 +2717,7 @@ Sun Oct 6 03:54:59 1996 Gary Houston (%load-announce): minor formatting change. (file-exists?): use access? if posix is featured. (file-is-directory?): use stat if i/o-extensions is featured. - (try-module-autoload module-name): use file-exists? before + (try-module-autoload module-name): use file-exists? before file-is-directory? Sat Oct 5 18:54:03 1996 Mikael Djurfeldt @@ -2895,7 +2906,7 @@ Tue Aug 20 07:31:39 1996 Mikael Djurfeldt * poe.scm (funcq-memo): Renamed weak-hash-table --> weak-key-hash-table. - + Sat Aug 3 06:16:35 1996 Gary Houston * boot-9.scm (*null-device*): global constant from goonix. From 4d66be545655ae67a167ce279b3524f0fae8e02b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 9 Apr 2001 16:07:15 +0000 Subject: [PATCH 0796/2047] * hooks.c (scm_make_hook, scm_make_hook_with_name), (scm_hook_p, scm_hook_empty_p, scm_run_hook): Docstring improvements. --- libguile/ChangeLog | 6 ++++++ libguile/hooks.c | 14 +++++++++----- 2 files changed, 15 insertions(+), 5 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 912745364..28dcdc262 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2001-04-06 Martin Grabmueller + + * hooks.c (scm_make_hook, scm_make_hook_with_name), + (scm_hook_p, scm_hook_empty_p, scm_run_hook): Docstring + improvements. + 2001-04-03 Martin Grabmueller The following changes make the documentation more consistent. diff --git a/libguile/hooks.c b/libguile/hooks.c index 6fb1e63f8..3ad60ce85 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -213,7 +213,8 @@ scm_create_hook (const char* name, int n_args) SCM_DEFINE (scm_make_hook_with_name, "make-hook-with-name", 1, 1, 0, (SCM name, SCM n_args), "Create a named hook with the name @var{name} for storing\n" - "procedures of arity @var{n_args}.") + "procedures of arity @var{n_args}. @var{n_args} defaults to\n" + "zero.") #define FUNC_NAME s_scm_make_hook_with_name { SCM hook = make_hook (n_args, FUNC_NAME); @@ -227,7 +228,8 @@ SCM_DEFINE (scm_make_hook_with_name, "make-hook-with-name", 1, 1, 0, SCM_DEFINE (scm_make_hook, "make-hook", 0, 1, 0, (SCM n_args), - "Create a hook for storing procedure of arity @var{n_args}.") + "Create a hook for storing procedure of arity\n" + "@var{n_args}. @var{n_args} defaults to zero.") #define FUNC_NAME s_scm_make_hook { return make_hook (n_args, FUNC_NAME); @@ -237,7 +239,7 @@ SCM_DEFINE (scm_make_hook, "make-hook", 0, 1, 0, SCM_DEFINE (scm_hook_p, "hook?", 1, 0, 0, (SCM x), - "Return @code{#t} if @var{x} is a hook.") + "Return @code{#t} if @var{x} is a hook, @code{#f} otherwise.") #define FUNC_NAME s_scm_hook_p { return SCM_BOOL (SCM_HOOKP (x)); @@ -247,7 +249,8 @@ SCM_DEFINE (scm_hook_p, "hook?", 1, 0, 0, SCM_DEFINE (scm_hook_empty_p, "hook-empty?", 1, 0, 0, (SCM hook), - "Return @code{#t} if @var{hook} is an empty hook.") + "Return @code{#t} if @var{hook} is an empty hook, @code{#f}\n" + "otherwise.") #define FUNC_NAME s_scm_hook_empty_p { SCM_VALIDATE_HOOK (1, hook); @@ -312,7 +315,8 @@ SCM_DEFINE (scm_reset_hook_x, "reset-hook!", 1, 0, 0, SCM_DEFINE (scm_run_hook, "run-hook", 1, 0, 1, (SCM hook, SCM args), "Apply all procedures from the hook @var{hook} to the arguments\n" - "@var{args}.") + "@var{args}. The order of the procedure application is first to\n" + "last.") #define FUNC_NAME s_scm_run_hook { SCM_VALIDATE_HOOK (1,hook); From 5c4b24e10f8154a21b698313fcbfe6666195ac34 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 9 Apr 2001 16:16:09 +0000 Subject: [PATCH 0797/2047] 2001-04-09 Martin Grabmueller * scheme-data.texi (Pairs): New data type and procedure description. (Lists): Added new subsections for grouping the list procedures. (Hooks): Added new nodes for hook subsections. (String Syntax): New node, factoring out read syntax. (Strings): Some blurb about allowed characters, zero-termination etc. (Keywords): Added menu descriptions. 2001-04-08 Martin Grabmueller * scheme-indices.texi (R5RS Index): Print index `rn', not `r5'. * guile.texi: The index formerly known as `r5' is now called `rn'. * scheme-utility.texi, scheme-procedures.texi, scheme-io.texi, scheme-evaluation.texi, scheme-control.texi, scheme-data.texi: Changed all @r5index entries to @rnindex. 2001-04-06 Martin Grabmueller * scheme-data.texi (Hooks): Added hook description and constraints. 2001-04-04 Martin Grabmueller * scheme-data.texi (Alphabetic Case Mapping), (String Comparison): Rearranged function order. (Vectors): Reorganized, new introductory text, docs about read syntax. --- doc/ChangeLog | 26 ++ doc/guile.texi | 4 +- doc/maint/guile.texi | 14 +- doc/scheme-control.texi | 8 +- doc/scheme-data.texi | 752 ++++++++++++++++++++++++++----------- doc/scheme-evaluation.texi | 12 +- doc/scheme-indices.texi | 17 - doc/scheme-io.texi | 36 +- doc/scheme-procedures.texi | 2 +- doc/scheme-utility.texi | 6 +- 10 files changed, 600 insertions(+), 277 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 50eae1226..46a0ca91c 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,29 @@ +2001-04-09 Martin Grabmueller + + * scheme-data.texi (Pairs): New data type and procedure + description. + (Lists): Added new subsections for grouping the list procedures. + (Hooks): Added new nodes for hook subsections. + (String Syntax): New node, factoring out read syntax. + (Strings): Some blurb about allowed characters, zero-termination + etc. + (Keywords): Added menu descriptions. + +2001-04-08 Martin Grabmueller + + * scheme-indices.texi (R5RS Index): Print index `rn', not `r5'. + + * guile.texi: The index formerly known as `r5' is now called `rn'. + + * scheme-utility.texi, scheme-procedures.texi, scheme-io.texi, + scheme-evaluation.texi, scheme-control.texi, scheme-data.texi: + Changed all @r5index entries to @rnindex. + +2001-04-06 Martin Grabmueller + + * scheme-data.texi (Hooks): Added hook description and + constraints. + 2001-04-06 Thien-Thi Nguyen * scheme-scheduling.texi (Higher level thread diff --git a/doc/guile.texi b/doc/guile.texi index fa2b78cad..ab493753a 100644 --- a/doc/guile.texi +++ b/doc/guile.texi @@ -95,7 +95,7 @@ @c Define indices that are used in the Guile Scheme part of the @c reference manual to group stuff according to whether it is R5RS or a @c Guile extension. -@defcodeindex r5 +@defcodeindex rn @defcodeindex ge @include version.texi @@ -144,7 +144,7 @@ by the Free Software Foundation. @sp 10 @comment The title is printed in a large font. @title Guile Reference Manual -@subtitle $Id: guile.texi,v 1.2 2001-03-30 22:16:20 ossau Exp $ +@subtitle $Id: guile.texi,v 1.3 2001-04-09 16:16:09 mgrabmue Exp $ @subtitle For use with Guile @value{VERSION} @author Mark Galassi @author Cygnus Solution and Los Alamos National Laboratory diff --git a/doc/maint/guile.texi b/doc/maint/guile.texi index 139946c90..823e84f41 100644 --- a/doc/maint/guile.texi +++ b/doc/maint/guile.texi @@ -2170,25 +2170,28 @@ table into an a-list of key-value pairs. @c snarfed from hooks.c:216 @deffn primitive make-hook-with-name name [n_args] Create a named hook with the name @var{name} for storing -procedures of arity @var{n_args}. +procedures of arity @var{n_args}. @var{n_args} defaults to +zero. @end deffn make-hook @c snarfed from hooks.c:230 @deffn primitive make-hook [n_args] -Create a hook for storing procedure of arity @var{n_args}. +Create a hook for storing procedure of arity +@var{n_args}. @var{n_args} defaults to zero. @end deffn hook? @c snarfed from hooks.c:240 @deffn primitive hook? x -Return @code{#t} if @var{x} is a hook. +Return @code{#t} if @var{x} is a hook, @code{#f} otherwise. @end deffn hook-empty? @c snarfed from hooks.c:250 @deffn primitive hook-empty? hook -Return @code{#t} if @var{hook} is an empty hook. +Return @code{#t} if @var{hook} is an empty hook, @code{#f} +otherwise. @end deffn add-hook! @@ -2215,7 +2218,8 @@ Remove all procedures from the hook @var{hook}. @c snarfed from hooks.c:315 @deffn primitive run-hook hook . args Apply all procedures from the hook @var{hook} to the arguments -@var{args}. +@var{args}. The order of the procedure application is first to +last. @end deffn hook->list diff --git a/doc/scheme-control.texi b/doc/scheme-control.texi index c7517175e..31a20681f 100644 --- a/doc/scheme-control.texi +++ b/doc/scheme-control.texi @@ -34,7 +34,7 @@ @node Continuations @section Continuations -@r5index call-with-current-continuation +@rnindex call-with-current-continuation @c FIXME::martin: Document me! @deffn primitive call-with-current-continuation @end deffn @@ -42,7 +42,7 @@ @node Multiple Values @section Returning and Accepting Multiple Values -@r5index values +@rnindex values @deffn primitive values . args Delivers all of its arguments to its continuation. Except for continuations created by the @code{call-with-values} procedure, @@ -51,7 +51,7 @@ passing no value or more than one value to continuations that were not created by @code{call-with-values} is unspecified. @end deffn -@r5index call-with-values +@rnindex call-with-values @deffn primitive call-with-values producer consumer Calls its @var{producer} argument with no values and a continuation that, when passed some values, calls the @@ -176,7 +176,7 @@ if an exception occurs then @code{#f} is returned instead. [FIXME: this is pasted in from Tom Lord's original guile.texi and should be reviewed] -@r5index dynamic-wind +@rnindex dynamic-wind @c docstring begin (texi-doc-string "guile" "dynamic-wind") @deffn primitive dynamic-wind in_guard thunk out_guard All three arguments must be 0-argument procedures. diff --git a/doc/scheme-data.texi b/doc/scheme-data.texi index 48d816303..af6a17d76 100755 --- a/doc/scheme-data.texi +++ b/doc/scheme-data.texi @@ -63,8 +63,6 @@ sections of this manual that cover them. @node Booleans @section Booleans -@r5index not -@r5index boolean? The two boolean values are @code{#t} for true and @code{#f} for false. @@ -122,6 +120,7 @@ number 0 (like in C and C++), and not the same as the ``empty list'' The @code{not} procedure returns the boolean inverse of its argument: +@rnindex not @c docstring begin (texi-doc-string "guile" "not") @deffn primitive not x Return @code{#t} iff @var{x} is @code{#f}, else return @code{#f}. @@ -130,6 +129,7 @@ Return @code{#t} iff @var{x} is @code{#f}, else return @code{#f}. The @code{boolean?} procedure is a predicate that returns @code{#t} if its argument is one of the boolean values, otherwise @code{#f}. +@rnindex boolean? @c docstring begin (texi-doc-string "guile" "boolean?") @deffn primitive boolean? obj Return @code{#t} iff @var{obj} is either @code{#t} or @code{#f}. @@ -169,7 +169,7 @@ in Scheme, which is particularly clear and accessible: see @node Numerical Tower @subsection Scheme's Numerical ``Tower'' -@r5index number? +@rnindex number? Scheme's numerical ``tower'' consists of the following categories of numbers: @@ -232,7 +232,7 @@ in detail. @node Integers @subsection Integers -@r5index integer? +@rnindex integer? Integers are whole numbers, that is numbers with no fractional part, such as 2, 83 and -3789. @@ -291,8 +291,8 @@ Return @code{#t} if @var{x} is an integer number, @code{#f} else. @node Reals and Rationals @subsection Real and Rational Numbers -@r5index real? -@r5index rational? +@rnindex real? +@rnindex rational? Mathematically, the real numbers are the set of numbers that describe all possible points along a continuous, infinite, one-dimensional line. @@ -355,7 +355,7 @@ precision. @node Complex Numbers @subsection Complex Numbers -@r5index complex? +@rnindex complex? Complex numbers are the set of numbers that describe all possible points in a two-dimensional space. The two coordinates of a particular point @@ -392,10 +392,10 @@ rational or integer number. @node Exactness @subsection Exact and Inexact Numbers -@r5index exact? -@r5index inexact? -@r5index exact->inexact -@r5index inexact->exact +@rnindex exact? +@rnindex inexact? +@rnindex exact->inexact +@rnindex inexact->exact R5RS requires that a calculation involving inexact numbers always produces an inexact result. To meet this requirement, Guile @@ -497,13 +497,13 @@ multiplying by 10^N. @node Integer Operations @subsection Operations on Integer Values -@r5index odd? -@r5index even? -@r5index quotient -@r5index remainder -@r5index modulo -@r5index gcd -@r5index lcm +@rnindex odd? +@rnindex even? +@rnindex quotient +@rnindex remainder +@rnindex modulo +@rnindex gcd +@rnindex lcm @c docstring begin (texi-doc-string "guile" "odd?") @deffn primitive odd? n @@ -555,9 +555,9 @@ If called without arguments, 1 is returned. @node Comparison @subsection Comparison Predicates -@r5index zero? -@r5index positive? -@r5index negative? +@rnindex zero? +@rnindex positive? +@rnindex negative? @c begin (texi-doc-string "guile" "=") @deffn primitive = @@ -609,8 +609,8 @@ zero. @node Conversion @subsection Converting Numbers To and From Strings -@r5index number->string -@r5index string->number +@rnindex number->string +@rnindex string->number @c docstring begin (texi-doc-string "guile" "number->string") @deffn primitive number->string n [radix] @@ -634,12 +634,12 @@ syntactically valid notation for a number, then @node Complex @subsection Complex Number Operations -@r5index make-rectangular -@r5index make-polar -@r5index real-part -@r5index imag-part -@r5index magnitude -@r5index angle +@rnindex make-rectangular +@rnindex make-polar +@rnindex real-part +@rnindex imag-part +@rnindex magnitude +@rnindex angle @c docstring begin (texi-doc-string "guile" "make-rectangular") @deffn primitive make-rectangular real imaginary @@ -676,17 +676,17 @@ Return the angle of the complex number @var{z}. @node Arithmetic @subsection Arithmetic Functions -@r5index max -@r5index min -@r5index + -@r5index * -@r5index - -@r5index / -@r5index abs -@r5index floor -@r5index ceiling -@r5index truncate -@r5index round +@rnindex max +@rnindex min +@rnindex + +@rnindex * +@rnindex - +@rnindex / +@rnindex abs +@rnindex floor +@rnindex ceiling +@rnindex truncate +@rnindex round @c begin (texi-doc-string "guile" "+") @deffn primitive + z1 @dots{} @@ -749,16 +749,16 @@ Round the number @var{x} towards infinity. @node Scientific @subsection Scientific Functions -@r5index exp -@r5index log -@r5index sin -@r5index cos -@r5index tan -@r5index asin -@r5index acos -@r5index atan -@r5index sqrt -@r5index expt +@rnindex exp +@rnindex log +@rnindex sin +@rnindex cos +@rnindex tan +@rnindex asin +@rnindex acos +@rnindex atan +@rnindex sqrt +@rnindex expt The following procedures accept any kind of number as arguments, including complex numbers. @@ -1173,21 +1173,21 @@ Return a new random state using @var{seed}. @node Characters @section Characters -@r5index char? -@r5index char=? -@r5index char? -@r5index char<=? -@r5index char>=? -@r5index char-alphabetic? -@r5index char-numeric? -@r5index char-whitespace? -@r5index char-upper-case? -@r5index char-lower-case? -@r5index char->integer -@r5index integer->char -@r5index char-upcase -@r5index char-downcase +@rnindex char? +@rnindex char=? +@rnindex char? +@rnindex char<=? +@rnindex char>=? +@rnindex char-alphabetic? +@rnindex char-numeric? +@rnindex char-whitespace? +@rnindex char-upper-case? +@rnindex char-lower-case? +@rnindex char->integer +@rnindex integer->char +@rnindex char-upcase +@rnindex char-downcase Most of the characters in the ASCII character set may be referred to by @@ -1382,26 +1382,19 @@ Strings are fixed--length sequences of characters. They can be created by calling constructor procedures, but they can also literally get entered at the REPL or in Scheme source files. -The read syntax for strings is an arbitrarily long sequence of characters -enclosed in double quotes (@code{"}). @footnote{Actually, the current -implementation restricts strings to a length of 2&24 characters.} If -you want to insert a double quote character into a string literal, it -must be prefixed with a backslash @code{\} character (called an -@emph{escape character}). - -The following are examples of string literals: - -@lisp -"foo" -"bar plonk" -"Hello World" -"\"Hi\", he said." -@end lisp - Guile provides a rich set of string processing procedures, because text handling is very important when Guile is used as a scripting language. +Strings always carry the information about how many characters they are +composed of with them, so there is no special end--of--string character, +like in C. That means that Scheme strings can contain any character, +even the NUL character @code{'\0'}. But note: Since most operating +system calls dealing with strings (such as for file operations) expect +strings to be zero--terminated, they might do unexpected things when +called with string containing unusal characters. + @menu +* String Syntax:: Read syntax for strings. * String Predicates:: Testing strings for certain properties. * String Constructors:: Creating new string objects. * List/String Conversion:: Converting from/to lists of characters. @@ -1416,13 +1409,34 @@ handling is very important when Guile is used as a scripting language. * Read Only Strings:: Treating certain non-strings as strings. @end menu +@node String Syntax +@subsection String Read Syntax + +The read syntax for strings is an arbitrarily long sequence of characters +enclosed in double quotes (@code{"}). @footnote{Actually, the current +implementation restricts strings to a length of 2^24 characters.} If +you want to insert a double quote character into a string literal, it +must be prefixed with a backslash @code{\} character (called an +@emph{escape character}). + +The following are examples of string literals: + +@lisp +"foo" +"bar plonk" +"Hello World" +"\"Hi\", he said." +@end lisp + +@c FIXME::martin: What about escape sequences like \r, \n etc.? + @node String Predicates @subsection String Predicates The following procedures can be used to check whether a given string fulfills some specified property. -@r5index string? +@rnindex string? @c docstring begin (texi-doc-string "guile" "string?") @deffn primitive string? obj Return @code{#t} iff @var{obj} is a string, else returns @@ -1448,8 +1462,8 @@ initializing them with some specified character data. @c FIXME::martin: list->string belongs into `List/String Conversion' -@r5index string -@r5index list->string +@rnindex string +@rnindex list->string @c docstring begin (texi-doc-string "guile" "string") @c docstring begin (texi-doc-string "guile" "list->string") @deffn primitive string . chrs @@ -1458,7 +1472,7 @@ Return a newly allocated string composed of the arguments, @var{chrs}. @end deffn -@r5index make-string +@rnindex make-string @c docstring begin (texi-doc-string "guile" "make-string") @deffn primitive make-string k [chr] Return a newly allocated string of @@ -1475,7 +1489,7 @@ into a list representation by using the procedure @code{string->list}, work with the resulting list, and then convert it back into a string. These procedures are useful for similar tasks. -@r5index string->list +@rnindex string->list @c docstring begin (texi-doc-string "guile" "string->list") @deffn primitive string->list str Return a newly allocated list of the characters that make up @@ -1491,26 +1505,26 @@ Portions of strings can be extracted by these procedures. @code{string-ref} delivers individual characters whereas @code{substring} can be used to extract substrings from longer strings. -@r5index string-length +@rnindex string-length @c docstring begin (texi-doc-string "guile" "string-length") @deffn primitive string-length string Return the number of characters in @var{string}. @end deffn -@r5index string-ref +@rnindex string-ref @c docstring begin (texi-doc-string "guile" "string-ref") @deffn primitive string-ref str k Return character @var{k} of @var{str} using zero-origin indexing. @var{k} must be a valid index of @var{str}. @end deffn -@r5index string-copy +@rnindex string-copy @c docstring begin (texi-doc-string "guile" "string-copy") @deffn primitive string-copy str Return a newly allocated copy of the given @var{string}. @end deffn -@r5index substring +@rnindex substring @c docstring begin (texi-doc-string "guile" "substring") @deffn primitive substring str start [end] Return a newly allocated string formed from the characters @@ -1529,7 +1543,7 @@ These procedures are for modifying strings in--place. That means, that not a new string is the result of a string operation, but that the actual memory representation of a string is modified. -@r5index string-set! +@rnindex string-set! @c docstring begin (texi-doc-string "guile" "string-set!") @deffn primitive string-set! str k chr Store @var{chr} in element @var{k} of @var{str} and return @@ -1537,7 +1551,7 @@ an unspecified value. @var{k} must be a valid index of @var{str}. @end deffn -@r5index string-fill! +@rnindex string-fill! @c docstring begin (texi-doc-string "guile" "string-fill!") @deffn primitive string-fill! str chr Store @var{char} in every element of the given @var{string} and @@ -1642,7 +1656,7 @@ return @code{#t} on success and @code{#f} on failure. The predicates ending in @code{-ci} ignore the character case when comparing strings. -@r5index string=? +@rnindex string=? @c docstring begin (texi-doc-string "guile" "string=?") @deffn primitive string=? s1 s2 Lexicographic equality predicate; return @code{#t} if the two @@ -1654,35 +1668,35 @@ letters as though they were the same character, but characters. @end deffn -@r5index string? +@rnindex string>? @c docstring begin (texi-doc-string "guile" "string>?") @deffn primitive string>? s1 s2 Lexicographic ordering predicate; return @code{#t} if @var{s1} is lexicographically greater than @var{s2}. @end deffn -@r5index string>=? +@rnindex string>=? @c docstring begin (texi-doc-string "guile" "string>=?") @deffn primitive string>=? s1 s2 Lexicographic ordering predicate; return @code{#t} if @var{s1} is lexicographically greater than or equal to @var{s2}. @end deffn -@r5index string-ci=? +@rnindex string-ci=? @c docstring begin (texi-doc-string "guile" "string-ci=?") @deffn primitive string-ci=? s1 s2 Case-insensitive string equality predicate; return @code{#t} if @@ -1691,7 +1705,7 @@ characters match (ignoring case) at each position; otherwise return @code{#f}. @end deffn -@r5index string-ci< +@rnindex string-ci< @c docstring begin (texi-doc-string "guile" "string-ci? +@rnindex string-ci>? @c docstring begin (texi-doc-string "guile" "string-ci>?") @deffn primitive string-ci>? s1 s2 Case insensitive lexicographic ordering predicate; return @@ -1715,7 +1729,7 @@ Case insensitive lexicographic ordering predicate; return @var{s2} regardless of case. @end deffn -@r5index string-ci>=? +@rnindex string-ci>=? @c docstring begin (texi-doc-string "guile" "string-ci>=?") @deffn primitive string-ci>=? s1 s2 Case insensitive lexicographic ordering predicate; return @@ -1832,7 +1846,7 @@ y @result{} "Hello World" The procedure @code{string-append} appends several strings together to form a longer result string. -@r5index string-append +@rnindex string-append @c docstring begin (texi-doc-string "guile" "string-append") @deffn primitive string-append . args Return a newly allocated string whose characters form the @@ -2436,9 +2450,6 @@ Test whether obj is a compiled regular expression. @node Symbols and Variables @section Symbols and Variables -@r5index symbol? -@r5index symbol->string -@r5index string->symbol Guile symbol tables are hash tables. Each hash table, also called an @@ -2500,6 +2511,7 @@ new entries should not be added for symbols not already present in the table; instead, simply return @code{#f}. @end deffn +@rnindex string->symbol @c docstring begin (texi-doc-string "guile" "string->symbol") @deffn primitive string->symbol string Return the symbol whose name is @var{string}. This procedure @@ -2522,6 +2534,7 @@ standard case is lower case: @end lisp @end deffn +@rnindex symbol->string @c docstring begin (texi-doc-string "guile" "symbol->string") @deffn primitive symbol->string s Return the name of @var{symbol} as a string. If the symbol was @@ -2603,6 +2616,7 @@ it to @var{value}. An error is signalled if @var{string} is not present in @var{obarray}. @end deffn +@rnindex symbol? @c docstring begin (texi-doc-string "guile" "symbol?") @deffn primitive symbol? obj Return @code{#t} if @var{obj} is a symbol, otherwise return @@ -2679,10 +2693,10 @@ syntax extension to permit keywords to begin with @code{:} as well as @code{#:}. @menu -* Why Use Keywords?:: -* Coding With Keywords:: -* Keyword Read Syntax:: -* Keyword Primitives:: +* Why Use Keywords?:: Motivation for keyword usage. +* Coding With Keywords:: How to use keywords. +* Keyword Read Syntax:: Read syntax for keywords. +* Keyword Primitives:: Procedures for dealing with keywords. @end menu @node Why Use Keywords? @@ -2884,7 +2898,53 @@ This is the inverse of @code{make-keyword-from-dash-symbol}. @node Pairs @section Pairs -@r5index cons + +@c FIXME::martin: Review me! + +Pairs are used to combine two Scheme objects into one compound object. +Hence the name: A pair stores a pair of objects. + +The data type @emph{pair} is extremely important in Scheme, just like in +any other Lisp dialect. The reason is that pairs are not only used to +make two values available as one object, but that pairs are used for +constructing lists of values. Because lists are so important in Scheme, +they are described in a section of their own (@pxref{Lists}). + +Pairs can literally get entered in source code or at the REPL, in the +so-called @dfn{dotted list} syntax. This syntax consists of an opening +parentheses, the first element of the pair, a dot, the second element +and a closing parentheses. The following example shows how a pair +consisting of the two numbers 1 and 2, and a pair containing the symbols +@code{foo} and @code{bar} can be entered. It is very important to write +the whitespace before and after the dot, because otherwise the Scheme +parser whould not be able to figure out where to split the tokens. + +@lisp +(1 . 2) +(foo . bar) +@end lisp + +But beware, if you want to try out these examples, you have to +@dfn{quote} the expressions. More information about quotation is +available in the section (REFFIXME). The correct way to try these +examples is as follows. + +@lisp +'(1 . 2) +@result{} +(1 . 2) +'(foo . bar) +@result{} +(foo . bar) +@end lisp + +A new pair is made by calling the procedure @code{cons} with two +arguments. Then the argument values are stored into a newly allocated +pair, and the pair is returned. The name @code{cons} stands for +@emph{construct}. Use the procedure @code{pair?} to test whether a +given Scheme object is a pair or not. + +@rnindex cons @c docstring begin (texi-doc-string "guile" "cons") @deffn primitive cons x y Return a newly allocated pair whose car is @var{x} and whose @@ -2892,15 +2952,23 @@ cdr is @var{y}. The pair is guaranteed to be different (in the sense of @code{eq?}) from every previously existing object. @end deffn -@r5index pair? +@rnindex pair? @c docstring begin (texi-doc-string "guile" "pair?") @deffn primitive pair? x Return @code{#t} if @var{x} is a pair; otherwise return @code{#f}. @end deffn -@r5index car -@r5index cdr +The two parts of a pair are traditionally called @emph{car} and +@emph{cdr}. They can be retrieved with procedures of the same name +(@code{car} and @code{cdr}), and can be modified with the procedures +@code{set-car!} and @code{set-cdr!}. Since a very common operation in +Scheme programs is to access the car of a pair, or the car of the cdr of +a pair, etc., the procedures called @code{caar}, @code{cadr} and so on +are also predefined. + +@rnindex car +@rnindex cdr @deffn primitive car pair @deffnx primitive cdr pair Return the car or the cdr of @var{pair}, respectively. @@ -2918,14 +2986,14 @@ for example @code{caddr} could be defined by @end lisp @end deffn -@r5index set-car! +@rnindex set-car! @c docstring begin (texi-doc-string "guile" "set-car!") @deffn primitive set-car! pair value Stores @var{value} in the car field of @var{pair}. The value returned by @code{set-car!} is unspecified. @end deffn -@r5index set-cdr! +@rnindex set-cdr! @c docstring begin (texi-doc-string "guile" "set-cdr!") @deffn primitive set-cdr! pair value Stores @var{value} in the cdr field of @var{pair}. The value returned @@ -2936,16 +3004,113 @@ by @code{set-cdr!} is unspecified. @node Lists @section Lists +A very important datatype in Scheme---as well as in all other Lisp +dialects---is the data type @dfn{list}.@footnote{Strictly speaking, +Scheme does not have a real datatype @emph{list}. Lists are made up of +chained @emph{pairs}, and only exist by definition --- A list is a chain +of pairs which looks like a list.} -@r5index list +This is the short definition of what a list is: + +@itemize @bullet +@item Either the empty list @code{()}, +@item or a pair which has a list in its cdr. +@end itemize + +@c FIXME::martin: Describe the pair chaining in more detail. + +@c FIXME::martin: What is a proper, what an improper list? +@c What is a circular list? + +@c FIXME::martin: Maybe steal some graphics from the Elisp reference +@c manual? + +@menu +* List Syntax:: Writing literal lists. +* List Predicates:: Testing lists. +* List Constructors:: Creating new lists. +* List Selection:: Selecting from lists, getting their length. +* Append/Reverse:: Appending and reversing lists. +* List Modifification:: Modifying list structure. +* List Searching:: Searching for list elements +* List Mapping:: Applying procedures to lists. +@end menu + +@node List Syntax +@subsection List Read Syntax + +The syntax for lists is an opening parentheses, then all the elements of +the list (separated by whitespace) and finally a closing +parentheses.@footnote{Note that there is no separation character between +the list elements, like a comma or a semicolon.}. + +@lisp +(1 2 3) ; @r{a list of the numbers 1, 2 and 3} +("foo" bar 3.1415) ; @r{a string, a symbol and a real number} +() ; @r{the empty list} +@end lisp + +The last example needs a bit more explanation. A list with no elements, +called the @dfn{empty list}, is special in some ways. It is used for +terminating lists by storing it into the cdr of the last pair that makes +up a list. An example will clear that up: + +@lisp +(car '(1)) +@result{} +1 +(cdr '(1)) +@result{} +() +@end lisp + +This example also shows that lists have to be quoted (REFFIXME) when +written, because they would otherwise be mistakingly taken as procedure +applications (REFFIXME). + + +@node List Predicates +@subsection List Predicates + +Often it is useful to test whether a given Scheme object is a list or +not. List--processing procedures could use this information to test +whether their input is valid, or they could do different things +depending on the datatype of their arguments. + +@rnindex list? +@c docstring begin (texi-doc-string "guile" "list?") +@deffn primitive list? x +Return @code{#t} iff @var{x} is a proper list, else @code{#f}. +@end deffn + +The predicate @code{null?} is often used in list--processing code to +tell whether a given list has run out of elements. That is, a loop +somehow deals with the elements of a list until the list satisfies +@code{null?}. Then, teh algorithm terminates. + +@rnindex null? +@c docstring begin (texi-doc-string "guile" "null?") +@deffn primitive null? x +Return @code{#t} iff @var{x} is the empty list, else @code{#f}. +@end deffn + +@node List Constructors +@subsection List Constructors + +This section describes the procedures for constructing new lists. +@code{list} simply returns a list where the elements are the arguments, +@code{cons*} is similar, but the last argument is stored in the cdr of +the last pair of the list. + +@rnindex list @c docstring begin (texi-doc-string "guile" "list") -@deffn primitive list . objs +@deffn primitive list arg1 @dots{} Return a list containing @var{objs}, the arguments to @code{list}. @end deffn @c docstring begin (texi-doc-string "guile" "cons*") -@deffn primitive cons* arg . rest +@deffn primitive cons* arg1 arg2 @dots{} Like @code{list}, but the last arg provides the tail of the constructed list, returning @code{(cons @var{arg1} (cons @var{arg2} (cons @dots{} @var{argn})))}. Requires at least one @@ -2954,25 +3119,74 @@ result. This function is called @code{list*} in some other Schemes and in Common LISP. @end deffn -@r5index list? -@c docstring begin (texi-doc-string "guile" "list?") -@deffn primitive list? x -Return @code{#t} iff @var{x} is a proper list, else @code{#f}. +@c docstring begin (texi-doc-string "guile" "list-copy") +@deffn primitive list-copy lst +Return a (newly-created) copy of @var{lst}. @end deffn -@r5index null? -@c docstring begin (texi-doc-string "guile" "null?") -@deffn primitive null? x -Return @code{#t} iff @var{x} is the empty list, else @code{#f}. -@end deffn +Note that @code{list-copy} only makes a copy of the pairs which make up +the spine of the lists. The list elements are not copied, which means +that modifying the elements of the new list also modyfies the elements +of the old list. On the other hand, applying procedures like +@code{set-cdr!} or @code{delv!} to the new list will not alter the old +list. If you also need to copy the list elements (making a deep copy), +use the procedure @code{copy-tree} (REFFIXME). -@r5index length +@node List Selection +@subsection List Selection + +These procedures are used to get some information about a list, or to +retrieve one or more elements of a list. + +@rnindex length @c docstring begin (texi-doc-string "guile" "length") @deffn primitive length lst Return the number of elements in list @var{lst}. @end deffn -@r5index append +@c docstring begin (texi-doc-string "guile" "last-pair") +@deffn primitive last-pair lst +Return a pointer to the last pair in @var{lst}, signalling an error if +@var{lst} is circular. +@end deffn + +@rnindex list-ref +@c docstring begin (texi-doc-string "guile" "list-ref") +@deffn primitive list-ref list k +Return the @var{k}th element from @var{list}. +@end deffn + +@rnindex list-tail +@c docstring begin (texi-doc-string "guile" "list-tail") +@c docstring begin (texi-doc-string "guile" "list-cdr-ref") +@deffn primitive list-tail lst k +@deffnx primitive list-cdr-ref lst k +Return the "tail" of @var{lst} beginning with its @var{k}th element. +The first element of the list is considered to be element 0. + +@code{list-tail} and @code{list-cdr-ref} are identical. It may help to +think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list, +or returning the results of cdring @var{k} times down @var{lst}. +@end deffn + +@c docstring begin (texi-doc-string "guile" "list-head") +@deffn primitive list-head lst k +Copy the first @var{k} elements from @var{lst} into a new list, and +return it. +@end deffn + +@node Append/Reverse +@subsection Append and Reverse + +@code{append} and @code{append!} are used to concatenate two or more +lists in order to form a new list. @code{reverse} and @code{reverse!} +return lists with the same elements as their arguments, but in reverse +order. The procedure variants with an @code{!} directly modify the +pairs which form the list, whereas the other procedures create new +pairs. This is why you should be careful when using the side--effecting +variants. + +@rnindex append @c docstring begin (texi-doc-string "guile" "append") @deffn primitive append . args Return a list consisting of the elements the lists passed as @@ -3001,13 +3215,7 @@ the next list, so no consing is performed. Return a pointer to the mutated list. @end deffn -@c docstring begin (texi-doc-string "guile" "last-pair") -@deffn primitive last-pair lst -Return a pointer to the last pair in @var{lst}, signalling an error if -@var{lst} is circular. -@end deffn - -@r5index reverse +@rnindex reverse @c docstring begin (texi-doc-string "guile" "reverse") @deffn primitive reverse lst Return a new list that contains the elements of @var{lst} but @@ -3030,79 +3238,23 @@ of the modified list is not lost, it is wise to save the return value of @code{reverse!} @end deffn -@r5index list-ref -@c docstring begin (texi-doc-string "guile" "list-ref") -@deffn primitive list-ref list k -Return the @var{k}th element from @var{list}. -@end deffn +@node List Modifification +@subsection List Modification + +The following procedures modify existing list. @code{list-set!} and +@code{list-cdr-set!} change which elements a list contains, the various +deletion procedures @code{delq}, @code{delv} etc. @c docstring begin (texi-doc-string "guile" "list-set!") @deffn primitive list-set! list k val Set the @var{k}th element of @var{list} to @var{val}. @end deffn -@r5index list-tail -@c docstring begin (texi-doc-string "guile" "list-tail") -@c docstring begin (texi-doc-string "guile" "list-cdr-ref") -@deffn primitive list-tail lst k -@deffnx primitive list-cdr-ref lst k -Return the "tail" of @var{lst} beginning with its @var{k}th element. -The first element of the list is considered to be element 0. - -@code{list-tail} and @code{list-cdr-ref} are identical. It may help to -think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list, -or returning the results of cdring @var{k} times down @var{lst}. -@end deffn - @c docstring begin (texi-doc-string "guile" "list-cdr-set!") @deffn primitive list-cdr-set! list k val Set the @var{k}th cdr of @var{list} to @var{val}. @end deffn -@c docstring begin (texi-doc-string "guile" "list-head") -@deffn primitive list-head lst k -Copy the first @var{k} elements from @var{lst} into a new list, and -return it. -@end deffn - -@c docstring begin (texi-doc-string "guile" "list-copy") -@deffn primitive list-copy lst -Return a (newly-created) copy of @var{lst}. -@end deffn - -@r5index memq -@c docstring begin (texi-doc-string "guile" "memq") -@deffn primitive memq x lst -Return the first sublist of @var{lst} whose car is @code{eq?} -to @var{x} where the sublists of @var{lst} are the non-empty -lists returned by @code{(list-tail @var{lst} @var{k})} for -@var{k} less than the length of @var{lst}. If @var{x} does not -occur in @var{lst}, then @code{#f} (not the empty list) is -returned. -@end deffn - -@r5index memv -@c docstring begin (texi-doc-string "guile" "memv") -@deffn primitive memv x lst -Return the first sublist of @var{lst} whose car is @code{eqv?} -to @var{x} where the sublists of @var{lst} are the non-empty -lists returned by @code{(list-tail @var{lst} @var{k})} for -@var{k} less than the length of @var{lst}. If @var{x} does not -occur in @var{lst}, then @code{#f} (not the empty list) is -returned. -@end deffn - -@r5index member -@c docstring begin (texi-doc-string "guile" "member") -@deffn primitive member x lst -Return the first sublist of @var{lst} whose car is -@code{equal?} to @var{x} where the sublists of @var{lst} are -the non-empty lists returned by @code{(list-tail @var{lst} -@var{k})} for @var{k} less than the length of @var{lst}. If -@var{x} does not occur in @var{lst}, then @code{#f} (not the -empty list) is returned. -@end deffn - @c docstring begin (texi-doc-string "guile" "delq") @deffn primitive delq item lst Return a newly-created copy of @var{lst} with elements @@ -3162,6 +3314,48 @@ Like @code{delete!}, but only deletes the first occurrence of @code{equal?}. See also @code{delq1!} and @code{delv1!}. @end deffn +@node List Searching +@subsection List Searching + +The following procedures search lists for particular elements. They use +different comparison predicates for comparing list elements with the +object to be seached. When they fail, they return @code{#f}, otherwise +they return the sublist whose car is equal to the search object, where +equality depends on the equality predicate used. + +@rnindex memq +@c docstring begin (texi-doc-string "guile" "memq") +@deffn primitive memq x lst +Return the first sublist of @var{lst} whose car is @code{eq?} +to @var{x} where the sublists of @var{lst} are the non-empty +lists returned by @code{(list-tail @var{lst} @var{k})} for +@var{k} less than the length of @var{lst}. If @var{x} does not +occur in @var{lst}, then @code{#f} (not the empty list) is +returned. +@end deffn + +@rnindex memv +@c docstring begin (texi-doc-string "guile" "memv") +@deffn primitive memv x lst +Return the first sublist of @var{lst} whose car is @code{eqv?} +to @var{x} where the sublists of @var{lst} are the non-empty +lists returned by @code{(list-tail @var{lst} @var{k})} for +@var{k} less than the length of @var{lst}. If @var{x} does not +occur in @var{lst}, then @code{#f} (not the empty list) is +returned. +@end deffn + +@rnindex member +@c docstring begin (texi-doc-string "guile" "member") +@deffn primitive member x lst +Return the first sublist of @var{lst} whose car is +@code{equal?} to @var{x} where the sublists of @var{lst} are +the non-empty lists returned by @code{(list-tail @var{lst} +@var{k})} for @var{k} less than the length of @var{lst}. If +@var{x} does not occur in @var{lst}, then @code{#f} (not the +empty list) is returned. +@end deffn + [FIXME: is there any reason to have the `sloppy' functions available at high level at all? Maybe these docs should be relegated to a "Guile Internals" node or something. -twp] @@ -3187,16 +3381,36 @@ Its use is recommended only in writing Guile internals, not for high-level Scheme programs. @end deffn -@r5index map +@node List Mapping +@subsection List Mapping + +List processing is very convenient in Scheme because the process of +iterating over the elements of a list can be highly abstracted. The +procedures in this section are the most basic iterating procedures for +lists. They take a procedure and one or more lists as arguments, and +apply the procedure to each element of the list. They differ in what +the result of the invocation is. + +@rnindex map @c begin (texi-doc-string "guile" "map") @c docstring begin (texi-doc-string "guile" "map-in-order") -@deffn primitive map proc arg1 . args -@deffnx primitive map-in-order proc arg1 . args +@deffn primitive map proc arg1 arg2 @dots{} +@deffnx primitive map-in-order proc arg1 arg2 @dots{} +Apply @var{proc} to each element of the list @var{arg1} (if only two +arguments are given), or to the corresponding elements of the argument +lists (if more than two arguments are given). The result(s) of the +procedure applications are saved and returned in a list. For +@code{map}, the order of procedure applications is not specified, +@code{map-in-order} applies the procedure from left to right to the list +elements. @end deffn -@r5index for-each +@rnindex for-each @c begin (texi-doc-string "guile" "for-each") -@deffn primitive for-each proc arg1 . args +@deffn primitive for-each proc arg1 arg2 @dots{} +Like @code{map}, but the procedure is always applied from left to right, +and the result(s) of the procedure applications are thrown away. The +return value is not specified. @end deffn @@ -4350,9 +4564,9 @@ association list. @node Retrieving Alist Entries @subsubsection Retrieving Alist Entries -@r5index assq -@r5index assv -@r5index assoc +@rnindex assq +@rnindex assv +@rnindex assoc @code{assq}, @code{assv} and @code{assoc} take an alist and a key as arguments and return the entry for that key if an entry exists, or @@ -4807,8 +5021,13 @@ table into an a-list of key-value pairs. @node Vectors @section Vectors +@c FIXME::martin: Review me! + @c FIXME::martin: This node should come before the non-standard data types. +@c FIXME::martin: Should the subsections of this section be nodes +@c of their own, or are the resulting nodes too short, then? + Vectors are sequences of Scheme objects. Unlike lists, the length of a vector, once the vector is created, cannot be changed. The advantage of vectors over lists is that the time required to access one element of a @@ -4837,7 +5056,7 @@ number in hexidecimal notation. @subsection Vector Predicates -@r5index vector? +@rnindex vector? @c docstring begin (texi-doc-string "guile" "vector?") @deffn primitive vector? obj Return @code{#t} if @var{obj} is a vector, otherwise return @@ -4846,7 +5065,7 @@ Return @code{#t} if @var{obj} is a vector, otherwise return @subsection Vector Constructors -@r5index make-vector +@rnindex make-vector @c docstring begin (texi-doc-string "guile" "make-vector") @deffn primitive make-vector k [fill] Return a newly allocated vector of @var{k} elements. If a @@ -4855,8 +5074,8 @@ second argument is given, then each element is initialized to unspecified. @end deffn -@r5index vector -@r5index list->vector +@rnindex vector +@rnindex list->vector @c docstring begin (texi-doc-string "guile" "vector") @c docstring begin (texi-doc-string "guile" "list->vector") @deffn primitive vector . l @@ -4868,7 +5087,7 @@ given arguments. Analogous to @code{list}. @end lisp @end deffn -@r5index vector->list +@rnindex vector->list @c docstring begin (texi-doc-string "guile" "vector->list") @deffn primitive vector->list v Return a newly allocated list of the objects contained in the @@ -4888,7 +5107,7 @@ According to R5RS, using any of these procedures on literally entered vectors is an error, because these vectors are considered to be constant, although Guile currently does not detect this error. -@r5index vector-set! +@rnindex vector-set! @deffn primitive vector-set! vector k obj @var{k} must be a valid index of @var{vector}. @code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}. @@ -4901,7 +5120,7 @@ The value returned by @samp{vector-set!} is unspecified. @end lisp @end deffn -@r5index vector-fill! +@rnindex vector-fill! @c docstring begin (texi-doc-string "guile" "vector-fill!") @deffn primitive vector-fill! v fill Store @var{fill} in every element of @var{vector}. The value @@ -4923,12 +5142,12 @@ Vector version of @code{substring-move-right!}. These procedures return information about a given vector, such as the size or what elements are contained in the vector. -@r5index vector-length +@rnindex vector-length @deffn primitive vector-length vector Returns the number of elements in @var{vector} as an exact integer. @end deffn -@r5index vector-ref +@rnindex vector-ref @deffn primitive vector-ref vector k @var{k} must be a valid index of @var{vector}. @samp{Vector-ref} returns the contents of element @var{k} of @@ -4946,25 +5165,115 @@ Returns the number of elements in @var{vector} as an exact integer. @node Hooks @section Hooks +@c FIXME::martin: Review me! + +A hook is basically a list of procedures to be called at well defined +points in time. Hooks are used internally for several debugging +facilities, but they can be used in user code, too. + +Hooks are created with @code{make-hook}, then procedures can be added to +a hook with @code{add-hook!} or removed with @code{remove-hook!} or +@code{reset-hook!}. The procedures stored in a hook can be invoked with +@code{run-hook}. + +@menu +* Hook Examples:: Hook usage by example. +* Hook Reference:: Reference of all hook procedures. +@end menu + +@node Hook Examples +@subsection Hook Examples + +Hook usage is shown by some examples in this section. First, we will +define a hook of arity 2---that is, the procedures stored in the hook +will have to accept two arguments. + +@lisp +(define hook (make-hook 2)) +hook +@result{} # +@end lisp + +Now we are ready to add some procedures to the newly created hook with +@code{add-hook!}. In the following example, two procedures are added, +which print different messages and do different things with their +arguments. When the procedures have been added, we can invoke them +using @code{run-hook}. + +@lisp +(add-hook! hook (lambda (x y) + (display "Foo: ") + (display (+ x y)) + (newline))) +(add-hook! hook (lambda (x y) + (display "Bar: ") + (display (* x y)) + (newline))) +(run-hook hook 3 4) +Bar: 12 +Foo: 7 +@end lisp + +Note that the procedures are called in reverse order than they were +added. This can be changed by providing the optional third argument +on the second call to @code{add-hook!}. + +@lisp +(add-hook! hook (lambda (x y) + (display "Foo: ") + (display (+ x y)) + (newline))) +(add-hook! hook (lambda (x y) + (display "Bar: ") + (display (* x y)) + (newline)) + #t) ; <- Change here! +(run-hook hook 3 4) +Foo: 7 +Bar: 12 +@end lisp + +@node Hook Reference +@subsection Hook Reference + +When a hook is created with @code{make-hook}, you can supply the arity +of the procedures which can be added to the hook. The arity defaults to +zero. All procedures of a hook must have the same arity, and when the +procedures are invoked using @code{run-hook}, the number of arguments +must match the arity of the procedures. + +The order in which procedures are added to a hook matters. If the third +parameter to @var{add-hook!} is omitted or is equal to @code{#f}, the +procedure is added in front of the procedures which might already be on +that hook, otherwise the procedure is added at the end. The procedures +are always called from first to last when they are invoked via +@code{run-hook}. + +When calling @code{hook->list}, the procedures in the resulting list are +in the same order as they would have been called by @code{run-hook}. + @c docstring begin (texi-doc-string "guile" "make-hook-with-name") @deffn primitive make-hook-with-name name [n_args] Create a named hook with the name @var{name} for storing -procedures of arity @var{n_args}. +procedures of arity @var{n_args}. @var{n_args} defaults to +zero. @end deffn @c docstring begin (texi-doc-string "guile" "make-hook") @deffn primitive make-hook [n_args] -Create a hook for storing procedure of arity @var{n_args}. +Create a hook for storing procedure of arity +@var{n_args}. @var{n_args} defaults to zero. @end deffn @c docstring begin (texi-doc-string "guile" "hook?") @deffn primitive hook? x -Return @code{#t} if @var{x} is a hook. +Return @code{#t} if @var{x} is a hook, @code{#f} otherwise. @end deffn @c docstring begin (texi-doc-string "guile" "hook-empty?") @deffn primitive hook-empty? hook -Return @code{#t} if @var{hook} is an empty hook. +Return @code{#t} if @var{hook} is an empty hook, @code{#f} +otherwise. @end deffn @c docstring begin (texi-doc-string "guile" "add-hook!") @@ -4987,7 +5296,8 @@ Remove all procedures from the hook @var{hook}. @c docstring begin (texi-doc-string "guile" "run-hook") @deffn primitive run-hook hook . args Apply all procedures from the hook @var{hook} to the arguments -@var{args}. +@var{args}. The order of the procedure application is first to +last. @end deffn @c docstring begin (texi-doc-string "guile" "hook->list") diff --git a/doc/scheme-evaluation.texi b/doc/scheme-evaluation.texi index 3509a2ceb..4472645a8 100644 --- a/doc/scheme-evaluation.texi +++ b/doc/scheme-evaluation.texi @@ -65,7 +65,7 @@ returned will be the return value of @code{read}. @node Scheme Read @section Reading Scheme Code -@r5index read +@rnindex read @c docstring begin (texi-doc-string "guile" "read") @deffn primitive read [port] Read an s-expression from the input port @var{port}, or from @@ -112,7 +112,7 @@ this procedure directly, use the procedures @code{read-enable}, @node Fly Evaluation @section Procedures for On the Fly Evaluation -@r5index eval +@rnindex eval @c ARGFIXME environment/environment specifier @c docstring begin (texi-doc-string "guile" "eval") @deffn primitive eval exp environment @@ -120,7 +120,7 @@ Evaluate @var{exp}, a list representing a Scheme expression, in the environment given by @var{environment specifier}. @end deffn -@r5index interaction-environment +@rnindex interaction-environment @c docstring begin (texi-doc-string "guile" "interaction-environment") @deffn primitive interaction-environment Return a specifier for the environment that contains @@ -149,7 +149,7 @@ Note: Rather than do new consing, @code{apply:nconc2last} destroys its argument, so use with care. @end deffn -@r5index apply +@rnindex apply @deffn primitive apply proc arg1 @dots{} args @var{proc} must be a procedure and @var{args} must be a list. Call @var{proc} with the elements of the list @code{(append (list @var{arg1} @@ -180,7 +180,7 @@ signalled. @node Loading @section Loading Scheme Code from File -@r5index load +@rnindex load @deffn procedure load filename Load @var{file} and evaluate its contents in the top-level environment. The load paths are searched. If the variable @code{%load-hook} is @@ -260,7 +260,7 @@ Return true if @var{obj} is a promise, i.e. a delayed computation (@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}). @end deffn -@r5index force +@rnindex force @c docstring begin (texi-doc-string "guile" "force") @deffn primitive force x If the promise @var{x} has not been computed yet, compute and diff --git a/doc/scheme-indices.texi b/doc/scheme-indices.texi index 6e676143b..e69de29bb 100644 --- a/doc/scheme-indices.texi +++ b/doc/scheme-indices.texi @@ -1,17 +0,0 @@ -@page -@node R5RS Index -@chapter R5RS Index - -@printindex r5 - - -@page -@node Guile Extensions Index -@chapter Guile Extensions Index - -@printindex ge - - -@c Local Variables: -@c TeX-master: "guile.texi" -@c End: diff --git a/doc/scheme-io.texi b/doc/scheme-io.texi index 1da049bcc..1a28badff 100644 --- a/doc/scheme-io.texi +++ b/doc/scheme-io.texi @@ -32,7 +32,7 @@ Because this definition is so loose, it is easy to write functions that simulate ports in software. @dfn{Soft ports} and @dfn{string ports} are two interesting and powerful examples of this technique. -@r5index input-port? +@rnindex input-port? @c docstring begin (texi-doc-string "guile" "input-port?") @deffn primitive input-port? x Return @code{#t} if @var{x} is an input port, otherwise return @@ -40,7 +40,7 @@ Return @code{#t} if @var{x} is an input port, otherwise return @code{port?}. @end deffn -@r5index output-port? +@rnindex output-port? @c docstring begin (texi-doc-string "guile" "output-port?") @deffn primitive output-port? x Return @code{#t} if @var{x} is an output port, otherwise return @@ -61,14 +61,14 @@ Equivalent to @code{(or (input-port? @var{x}) (output-port? [Generic procedures for reading from ports.] -@r5index eof-object? +@rnindex eof-object? @c docstring begin (texi-doc-string "guile" "eof-object?") @deffn primitive eof-object? x Return @code{#t} if @var{x} is an end-of-file object; otherwise return @code{#f}. @end deffn -@r5index char-ready? +@rnindex char-ready? @c docstring begin (texi-doc-string "guile" "char-ready?") @deffn primitive char-ready? [port] Return @code{#t} if a character is ready on input @var{port} @@ -86,7 +86,7 @@ a port at end of file would be indistinguishable from an interactive port that has no ready characters.} @end deffn -@r5index read-char? +@rnindex read-char? @c docstring begin (texi-doc-string "guile" "read-char") @deffn primitive read-char [port] Return the next character available from @var{port}, updating @@ -94,7 +94,7 @@ Return the next character available from @var{port}, updating characters are available, the end-of-file object is returned. @end deffn -@r5index peek-char? +@rnindex peek-char? @c docstring begin (texi-doc-string "guile" "peek-char") @deffn primitive peek-char [port] Return the next character available from @var{port}, @@ -201,7 +201,7 @@ Return the print state of the port @var{port}. If @var{port} has no associated print state, @code{#f} is returned. @end deffn -@r5index newline +@rnindex newline @c docstring begin (texi-doc-string "guile" "newline") @deffn primitive newline [port] Send a newline to @var{port}. @@ -236,7 +236,7 @@ port, if @var{destination} is @code{#f}, then return a string containing the formatted text. Does not add a trailing newline. @end deffn -@r5index write-char +@rnindex write-char @c docstring begin (texi-doc-string "guile" "write-char") @deffn primitive write-char chr [port] Send character @var{chr} to @var{port}. @@ -274,7 +274,7 @@ File Descriptors, close}, for a procedure which can close file descriptors. @end deffn -@r5index close-input-port +@rnindex close-input-port @c docstring begin (texi-doc-string "guile" "close-input-port") @deffn primitive close-input-port port Close the specified input port object. The routine has no effect if @@ -285,7 +285,7 @@ See also @ref{Ports and File Descriptors, close}, for a procedure which can close file descriptors. @end deffn -@r5index close-output-port +@rnindex close-output-port @c docstring begin (texi-doc-string "guile" "close-output-port") @deffn primitive close-output-port port Close the specified output port object. The routine has no effect if @@ -495,7 +495,7 @@ If omitted, @var{port} defaults to the current output port. @node Default Ports @section Default Ports for Input, Output and Errors -@r5index current-input-port +@rnindex current-input-port @c docstring begin (texi-doc-string "guile" "current-input-port") @deffn primitive current-input-port Return the current input port. This is the default port used @@ -503,7 +503,7 @@ by many input procedures. Initially, @code{current-input-port} returns the @dfn{standard input} in Unix and C terminology. @end deffn -@r5index current-output-port +@rnindex current-output-port @c docstring begin (texi-doc-string "guile" "current-output-port") @deffn primitive current-output-port Return the current output port. This is the default port used @@ -599,7 +599,7 @@ current interfaces. If a file cannot be opened with the access requested, @code{open-file} throws an exception. @end deffn -@r5index open-input-file +@rnindex open-input-file @c begin (scm-doc-string "r4rs.scm" "open-input-file") @deffn procedure open-input-file filename Open @var{filename} for input. Equivalent to @@ -608,7 +608,7 @@ Open @var{filename} for input. Equivalent to @end smalllisp @end deffn -@r5index open-output-file +@rnindex open-output-file @c begin (scm-doc-string "r4rs.scm" "open-output-file") @deffn procedure open-output-file filename Open @var{filename} for output. Equivalent to @@ -617,7 +617,7 @@ Open @var{filename} for output. Equivalent to @end smalllisp @end deffn -@r5index call-with-input-file +@rnindex call-with-input-file @c begin (scm-doc-string "r4rs.scm" "call-with-input-file") @deffn procedure call-with-input-file file proc @var{proc} should be a procedure of one argument, and @var{file} should @@ -631,7 +631,7 @@ closed automatically unless it is possible to prove that the port will never again be used for a read or write operation. @end deffn -@r5index call-with-output-file +@rnindex call-with-output-file @c begin (scm-doc-string "r4rs.scm" "call-with-output-file") @deffn procedure call-with-output-file file proc @var{proc} should be a procedure of one argument, and @var{file} should @@ -645,7 +645,7 @@ will not be closed automatically unless it is possible to prove that the port will never again be used for a read or write operation. @end deffn -@r5index with-input-from-file +@rnindex with-input-from-file @c begin (scm-doc-string "r4rs.scm" "with-input-from-file") @deffn procedure with-input-from-file file thunk @var{thunk} must be a procedure of no arguments, and @var{file} must be @@ -659,7 +659,7 @@ continuation of these procedures, their behavior is implementation dependent. @end deffn -@r5index with-output-to-file +@rnindex with-output-to-file @c begin (scm-doc-string "r4rs.scm" "with-output-to-file") @deffn procedure with-output-to-file file thunk @var{thunk} must be a procedure of no arguments, and @var{file} must be diff --git a/doc/scheme-procedures.texi b/doc/scheme-procedures.texi index 885d2f966..e1cf83e1a 100644 --- a/doc/scheme-procedures.texi +++ b/doc/scheme-procedures.texi @@ -56,7 +56,7 @@ documentation for that procedure. Return @code{#t} if @var{obj} is a closure. @end deffn -@r5index procedure? +@rnindex procedure? @c docstring begin (texi-doc-string "guile" "procedure?") @deffn primitive procedure? obj Return @code{#t} if @var{obj} is a procedure. diff --git a/doc/scheme-utility.texi b/doc/scheme-utility.texi index df2da008a..3163bf3a5 100644 --- a/doc/scheme-utility.texi +++ b/doc/scheme-utility.texi @@ -13,10 +13,8 @@ @node Equality @section Equality -@r5index eq? -@r5index eqv? -@r5index equal? +@rnindex eq? @c docstring begin (texi-doc-string "guile" "eq?") @deffn primitive eq? x y Return @code{#t} iff @var{x} references the same object as @var{y}. @@ -25,6 +23,7 @@ capable of discerning distinctions finer than those detectable by @code{eqv?}. @end deffn +@rnindex eqv? @c docstring begin (texi-doc-string "guile" "eqv?") @deffn primitive eqv? x y The @code{eqv?} procedure defines a useful equivalence relation on objects. @@ -34,6 +33,7 @@ interpretation, but works for comparing immediate integers, characters, and inexact numbers. @end deffn +@rnindex equal? @c docstring begin (texi-doc-string "guile" "equal?") @deffn primitive equal? x y Return @code{#t} iff @var{x} and @var{y} are recursively @code{eqv?} equivalent. From 5411d8825034ded7e03be8dd979fbb3ca3dbe3cb Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Mon, 9 Apr 2001 18:36:40 +0000 Subject: [PATCH 0798/2047] * Remove obsolete `@c docstring' comments. --- doc/ChangeLog | 10 ++ doc/deprecated.texi | 1 - doc/posix.texi | 141 ------------------- doc/scheme-binding.texi | 1 - doc/scheme-control.texi | 6 - doc/scheme-data.texi | 266 ------------------------------------ doc/scheme-debug.texi | 31 ----- doc/scheme-evaluation.texi | 16 --- doc/scheme-io.texi | 50 ------- doc/scheme-memory.texi | 20 --- doc/scheme-modules.texi | 9 -- doc/scheme-options.texi | 8 -- doc/scheme-procedures.texi | 24 ---- doc/scheme-scheduling.texi | 23 ---- doc/scheme-translation.texi | 49 ------- doc/scheme-utility.texi | 22 --- 16 files changed, 10 insertions(+), 667 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 46a0ca91c..7530a8d5b 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,13 @@ +2001-04-09 Neil Jerram + + * deprecated.texi, posix.texi, scheme-binding.texi, + scheme-control.texi, scheme-data.texi, scheme-debug.texi, + scheme-evaluation.texi, scheme-io.texi, scheme-memory.texi, + scheme-modules.texi, scheme-options.texi, scheme-procedures.texi, + scheme-scheduling.texi, scheme-translation.texi, + scheme-utility.texi: Remove `@c docstring' comments, since they + aren't used any more by the docstring tracking utilities. + 2001-04-09 Martin Grabmueller * scheme-data.texi (Pairs): New data type and procedure diff --git a/doc/deprecated.texi b/doc/deprecated.texi index 6eab2b584..e7f5277db 100644 --- a/doc/deprecated.texi +++ b/doc/deprecated.texi @@ -1,7 +1,6 @@ @node Deprecated @chapter Deprecated -@c docstring begin (texi-doc-string "guile" "tag") @deffn primitive tag x Return an integer corresponding to the type of X. Deprecated. @end deffn diff --git a/doc/posix.texi b/doc/posix.texi index 6b5943d59..b6c72d22f 100644 --- a/doc/posix.texi +++ b/doc/posix.texi @@ -150,18 +150,15 @@ one, so that dropping references to one of these ports will not result in its garbage collection: it could be retrieved with fdopen or fdes->ports. -@c docstring begin (texi-doc-string "guile" "port-revealed") @deffn primitive port-revealed port Return the revealed count for @var{port}. @end deffn -@c docstring begin (texi-doc-string "guile" "set-port-revealed!") @deffn primitive set-port-revealed! port rcount Sets the revealed count for a port to a given value. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "fileno") @deffn primitive fileno port Return the integer file descriptor underlying @var{port}. Does not change its revealed count. @@ -172,7 +169,6 @@ Returns the integer file descriptor underlying @var{port}. As a side effect the revealed count of @var{port} is incremented. @end deffn -@c docstring begin (texi-doc-string "guile" "fdopen") @deffn primitive fdopen fdes modes Return a new port based on the file descriptor @var{fdes}. Modes are given by the string @var{modes}. The revealed count @@ -180,7 +176,6 @@ of the port is initialized to zero. The modes string is the same as that accepted by @ref{File Ports, open-file}. @end deffn -@c docstring begin (texi-doc-string "guile" "fdes->ports") @deffn primitive fdes->ports fd Return a list of existing ports which have @var{fdes} as an underlying file descriptor, without changing their revealed @@ -199,7 +194,6 @@ descriptor, if one exists, and increments its revealed count. Otherwise, returns a new output port with a revealed count of 1. @end deffn -@c docstring begin (texi-doc-string "guile" "primitive-move->fdes") @deffn primitive primitive-move->fdes port fd Moves the underlying file descriptor for @var{port} to the integer value @var{fdes} without changing the revealed count of @var{port}. @@ -221,7 +215,6 @@ The return value is unspecified. Decrements the revealed count for a port. @end deffn -@c docstring begin (texi-doc-string "guile" "fsync") @deffn primitive fsync object Copies any unwritten data for the specified output file descriptor to disk. If @var{port/fd} is a port, its buffer is flushed before the underlying @@ -229,7 +222,6 @@ file descriptor is fsync'd. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "open") @deffn primitive open path flags [mode] Open the file named by @var{path} for reading and/or writing. @var{flags} is an integer specifying how the file should be opened. @@ -260,13 +252,11 @@ See the Unix documentation of the @code{open} system call for additional flags. @end deffn -@c docstring begin (texi-doc-string "guile" "open-fdes") @deffn primitive open-fdes path flags [mode] Similar to @code{open} but return a file descriptor instead of a port. @end deffn -@c docstring begin (texi-doc-string "guile" "close") @deffn primitive close fd_or_port Similar to close-port (@pxref{Closing, close-port}), but also works on file descriptors. A side effect of closing a file descriptor is that @@ -274,7 +264,6 @@ any ports using that file descriptor are moved to a different file descriptor and have their revealed counts set to zero. @end deffn -@c docstring begin (texi-doc-string "guile" "close-fdes") @deffn primitive close-fdes fd A simple wrapper for the @code{close} system call. Close file descriptor @var{fd}, which must be an integer. @@ -283,7 +272,6 @@ the file descriptor will be closed even if a port is using it. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "unread-char") @deffn primitive unread-char char [port] Place @var{char} in @var{port} so that it will be read by the next read operation. If called multiple times, the unread characters @@ -291,7 +279,6 @@ will be read again in last-in first-out order. If @var{port} is not supplied, the current input port is used. @end deffn -@c docstring begin (texi-doc-string "guile" "unread-string") @deffn primitive unread-string str port Place the string @var{str} in @var{port} so that its characters will be read in subsequent read operations. If called multiple times, the @@ -299,7 +286,6 @@ unread characters will be read again in last-in first-out order. If @var{port} is not supplied, the current-input-port is used. @end deffn -@c docstring begin (texi-doc-string "guile" "pipe") @deffn primitive pipe Return a newly created pipe: a pair of ports which are linked together on the local machine. The @emph{car} is the input @@ -325,7 +311,6 @@ All procedures also have the side effect when performing @code{dup2} that any ports using @var{newfd} are moved to a different file descriptor and have their revealed counts set to zero. -@c docstring begin (texi-doc-string "guile" "dup->fdes") @deffn primitive dup->fdes fd_or_port [fd] Return a new integer file descriptor referring to the open file designated by @var{fd_or_port}, which must be either an open @@ -364,7 +349,6 @@ port. This procedure is equivalent to @code{(dup->port @var{port} @var{modes})}. @end deffn -@c docstring begin (texi-doc-string "guile" "redirect-port") @deffn primitive redirect-port old new This procedure takes two ports and duplicates the underlying file descriptor from @var{old-port} into @var{new-port}. The @@ -381,7 +365,6 @@ This procedure does not have any side effects on other ports or revealed counts. @end deffn -@c docstring begin (texi-doc-string "guile" "dup2") @deffn primitive dup2 oldfd newfd A simple wrapper for the @code{dup2} system call. Copies the file descriptor @var{oldfd} to descriptor @@ -393,7 +376,6 @@ is made to move away ports which are using @var{newfd}. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "port-mode") @deffn primitive port-mode port Return the port modes associated with the open port @var{port}. These will not necessarily be identical to the modes used when @@ -401,7 +383,6 @@ the port was opened, since modes such as "append" which are used only during port creation are not retained. @end deffn -@c docstring begin (texi-doc-string "guile" "close-all-ports-except") @deffn primitive close-all-ports-except . ports [DEPRECATED] Close all open file ports used by the interpreter except for those supplied as arguments. This procedure @@ -411,7 +392,6 @@ undesirable side-effect of flushing buffes, so it's deprecated. Use port-for-each instead. @end deffn -@c docstring begin (texi-doc-string "guile" "port-for-each") @deffn primitive port-for-each proc Apply @var{proc} to each port in the Guile port table in turn. The return value is unspecified. More specifically, @@ -421,7 +401,6 @@ Changes to the port table while @var{port-for-each} is running have no effect as far as @var{port-for-each} is concerned. @end deffn -@c docstring begin (texi-doc-string "guile" "setvbuf") @deffn primitive setvbuf port mode [size] Set the buffering mode for @var{port}. @var{mode} can be: @table @code @@ -435,7 +414,6 @@ If @var{size} is omitted, a default size will be used. @end table @end deffn -@c docstring begin (texi-doc-string "guile" "fcntl") @deffn primitive fcntl object cmd [value] Apply @var{command} to the specified file descriptor or the underlying file descriptor of the specified port. @var{value} is an optional @@ -464,7 +442,6 @@ The value used to indicate the "close on exec" flag with @code{F_GETFL} or @end table @end deffn -@c docstring begin (texi-doc-string "guile" "select") @deffn primitive select reads writes excepts [secs [usecs]] This procedure has a variety of uses: waiting for the ability to provide input, accept output, or the existance of @@ -506,7 +483,6 @@ permissions, sizes and types of files); deleting, copying, renaming and linking files; creating and removing directories and querying their contents; syncing the file system and creating special files. -@c docstring begin (texi-doc-string "guile" "access?") @deffn primitive access? path how Return @code{#t} if @var{path} corresponds to an existing file and the current process has the type of access specified by @@ -532,7 +508,6 @@ test for existence of the file. @end deffn @findex fstat -@c docstring begin (texi-doc-string "guile" "stat") @deffn primitive stat object Return an object containing various information about the file determined by @var{obj}. @var{obj} can be a string containing @@ -588,14 +563,12 @@ An integer representing the access permission bits. @end table @end deffn -@c docstring begin (texi-doc-string "guile" "lstat") @deffn primitive lstat str Similar to @code{stat}, but does not follow symbolic links, i.e., it will return information about a symbolic link itself, not the file it points to. @var{path} must be a string. @end deffn -@c docstring begin (texi-doc-string "guile" "readlink") @deffn primitive readlink path Return the value of the symbolic link named by @var{path} (a string), i.e., the file that the link points to. @@ -603,7 +576,6 @@ string), i.e., the file that the link points to. @findex fchown @findex lchown -@c docstring begin (texi-doc-string "guile" "chown") @deffn primitive chown object owner group Change the ownership and group of the file referred to by @var{object} to the integer values @var{owner} and @var{group}. @var{object} can be @@ -620,7 +592,6 @@ as @code{-1}, then that ID is not changed. @end deffn @findex fchmod -@c docstring begin (texi-doc-string "guile" "chmod") @deffn primitive chmod object mode Changes the permissions of the file referred to by @var{obj}. @var{obj} can be a string containing a file name or a port or integer file @@ -631,7 +602,6 @@ the new permissions as a decimal number, e.g., @code{(chmod "foo" #o755)}. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "utime") @deffn primitive utime pathname [actime [modtime]] @code{utime} sets the access and modification times for the file named by @var{path}. If @var{actime} or @var{modtime} is @@ -646,25 +616,21 @@ modification time to the current time. @end deffn @findex unlink -@c docstring begin (texi-doc-string "guile" "delete-file") @deffn primitive delete-file str Deletes (or "unlinks") the file specified by @var{path}. @end deffn -@c docstring begin (texi-doc-string "guile" "copy-file") @deffn primitive copy-file oldfile newfile Copy the file specified by @var{path-from} to @var{path-to}. The return value is unspecified. @end deffn @findex rename -@c docstring begin (texi-doc-string "guile" "rename-file") @deffn primitive rename-file oldname newname Renames the file specified by @var{oldname} to @var{newname}. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "link") @deffn primitive link oldpath newpath Creates a new name @var{newpath} in the file system for the file named by @var{oldpath}. If @var{oldpath} is a symbolic @@ -672,13 +638,11 @@ link, the link may or may not be followed depending on the system. @end deffn -@c docstring begin (texi-doc-string "guile" "symlink") @deffn primitive symlink oldpath newpath Create a symbolic link named @var{path-to} with the value (i.e., pointing to) @var{path-from}. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "mkdir") @deffn primitive mkdir path [mode] Create a new directory named by @var{path}. If @var{mode} is omitted then the permissions of the directory file are set using the current @@ -686,50 +650,42 @@ umask. Otherwise they are set to the decimal value specified with @var{mode}. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "rmdir") @deffn primitive rmdir path Remove the existing directory named by @var{path}. The directory must be empty for this to succeed. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "opendir") @deffn primitive opendir dirname Open the directory specified by @var{path} and return a directory stream. @end deffn -@c docstring begin (texi-doc-string "guile" "directory-stream?") @deffn primitive directory-stream? obj Return a boolean indicating whether @var{object} is a directory stream as returned by @code{opendir}. @end deffn -@c docstring begin (texi-doc-string "guile" "readdir") @deffn primitive readdir port Return (as a string) the next directory entry from the directory stream @var{stream}. If there is no remaining entry to be read then the end of file object is returned. @end deffn -@c docstring begin (texi-doc-string "guile" "rewinddir") @deffn primitive rewinddir port Reset the directory port @var{stream} so that the next call to @code{readdir} will return the first directory entry. @end deffn -@c docstring begin (texi-doc-string "guile" "closedir") @deffn primitive closedir port Close the directory stream @var{stream}. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "sync") @deffn primitive sync Flush the operating system disk buffers. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "mknod") @deffn primitive mknod path type perms dev Creates a new special file, such as a file corresponding to a device. @var{path} specifies the name of the file. @var{type} should @@ -748,7 +704,6 @@ E.g., The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "tmpnam") @deffn primitive tmpnam Return a name in the file system that does not match any existing file. However there is no guarantee that another @@ -757,14 +712,12 @@ Care should be taken if opening the file, e.g., use the @code{O_EXCL} open flag or use @code{mkstemp!} instead. @end deffn -@c docstring begin (texi-doc-string "guile" "dirname") @deffn primitive dirname filename Return the directory name component of the file name @var{filename}. If @var{filename} does not contain a directory component, @code{.} is returned. @end deffn -@c docstring begin (texi-doc-string "guile" "basename") @deffn primitive basename filename [suffix] Return the base name of the file name @var{filename}. The base name is the file name without any directory components. @@ -823,14 +776,12 @@ Return the next entry in the user database, using the stream set by Closes the stream used by @code{getpwent}. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "setpw") @deffn primitive setpw [arg] If called with a true argument, initialize or reset the password data stream. Otherwise, close the stream. The @code{setpwent} and @code{endpwent} procedures are implemented on top of this. @end deffn -@c docstring begin (texi-doc-string "guile" "getpw") @deffn primitive getpw [user] Look up an entry in the user database. @var{obj} can be an integer, a string, or omitted, giving the behaviour of getpwuid, getpwnam @@ -875,14 +826,12 @@ Closes the stream used by @code{getgrent}. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "setgr") @deffn primitive setgr [arg] If called with a true argument, initialize or reset the group data stream. Otherwise, close the stream. The @code{setgrent} and @code{endgrent} procedures are implemented on top of this. @end deffn -@c docstring begin (texi-doc-string "guile" "getgr") @deffn primitive getgr [name] Look up an entry in the group database. @var{obj} can be an integer, a string, or omitted, giving the behaviour of getgrgid, getgrnam @@ -892,13 +841,11 @@ or getgrent respectively. @node Time @section Time -@c docstring begin (texi-doc-string "guile" "current-time") @deffn primitive current-time Return the number of seconds since 1970-01-01 00:00:00 UTC, excluding leap seconds. @end deffn -@c docstring begin (texi-doc-string "guile" "gettimeofday") @deffn primitive gettimeofday Return a pair containing the number of seconds and microseconds since 1970-01-01 00:00:00 UTC, excluding leap seconds. Note: @@ -937,7 +884,6 @@ Time zone offset in seconds west of UTC (-46800 to 43200). Time zone label (a string), not necessarily unique. @end table -@c docstring begin (texi-doc-string "guile" "localtime") @deffn primitive localtime time [zone] Return an object representing the broken down components of @var{time}, an integer like the one returned by @@ -946,14 +892,12 @@ optionally specified by @var{zone} (a string), otherwise the @code{TZ} environment variable or the system default is used. @end deffn -@c docstring begin (texi-doc-string "guile" "gmtime") @deffn primitive gmtime time Return an object representing the broken down components of @var{time}, an integer like the one returned by @code{current-time}. The values are calculated for UTC. @end deffn -@c docstring begin (texi-doc-string "guile" "mktime") @deffn primitive mktime sbd_time [zone] @var{bd-time} is an object representing broken down time and @code{zone} is an optional time zone specifier (otherwise the TZ environment variable @@ -965,7 +909,6 @@ by @code{current-time}; the cdr is a broken down time object, similar to as @var{bd-time} but with normalized values. @end deffn -@c docstring begin (texi-doc-string "guile" "tzset") @deffn primitive tzset Initialize the timezone from the TZ environment variable or the system default. It's not usually necessary to call this procedure @@ -973,7 +916,6 @@ since it's done automatically by other procedures that depend on the timezone. @end deffn -@c docstring begin (texi-doc-string "guile" "strftime") @deffn primitive strftime format stime Formats a time specification @var{time} using @var{template}. @var{time} is an object with time components in the form returned by @code{localtime} @@ -984,7 +926,6 @@ is the formatted string. @xref{Formatting Date and Time, , , libc, The GNU C Library Reference Manual}.) @end deffn -@c docstring begin (texi-doc-string "guile" "strptime") @deffn primitive strptime format string Performs the reverse action to @code{strftime}, parsing @var{string} according to the specification supplied in @@ -1003,7 +944,6 @@ The value of this variable is the number of time units per second reported by the following procedures. @end defvar -@c docstring begin (texi-doc-string "guile" "times") @deffn primitive times Return an object with information about real and processor time. The following procedures accept such an object as an @@ -1027,13 +967,11 @@ terminated child processes. @end table @end deffn -@c docstring begin (texi-doc-string "guile" "get-internal-real-time") @deffn primitive get-internal-real-time Return the number of time units since the interpreter was started. @end deffn -@c docstring begin (texi-doc-string "guile" "get-internal-run-time") @deffn primitive get-internal-run-time Return the number of time units of processor time used by the interpreter. Both @emph{system} and @emph{user} time are @@ -1043,7 +981,6 @@ included but subprocesses are not. @node Runtime Environment @section Runtime Environment -@c docstring begin (texi-doc-string "guile" "program-arguments") @deffn primitive program-arguments @deffnx procedure command-line Return the list of command line arguments passed to Guile, as a list of @@ -1052,7 +989,6 @@ strings. The list includes the invoked program name, which is usually options like @code{-e} and @code{-l}. @end deffn -@c docstring begin (texi-doc-string "guile" "getenv") @deffn primitive getenv nam Looks up the string @var{name} in the current environment. The return value is @code{#f} unless a string of the form @code{NAME=VALUE} is @@ -1072,7 +1008,6 @@ to the environment, replacing any existing string with name matching The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "environ") @deffn primitive environ [env] If @var{env} is omitted, return the current environment (in the Unix sense) as a list of strings. Otherwise set the current @@ -1083,7 +1018,6 @@ processes, to the supplied list of strings. Each member of then the return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "putenv") @deffn primitive putenv str Modifies the environment of the current process, which is also the default environment inherited by child processes. @@ -1103,19 +1037,16 @@ The return value is unspecified. @section Processes @findex cd -@c docstring begin (texi-doc-string "guile" "chdir") @deffn primitive chdir str Change the current working directory to @var{path}. The return value is unspecified. @end deffn @findex pwd -@c docstring begin (texi-doc-string "guile" "getcwd") @deffn primitive getcwd Return the name of the current working directory. @end deffn -@c docstring begin (texi-doc-string "guile" "umask") @deffn primitive umask [mode] If @var{mode} is omitted, retuns a decimal number representing the current file creation mask. Otherwise the file creation mask is set to @@ -1124,34 +1055,28 @@ file creation mask. Otherwise the file creation mask is set to E.g., @code{(umask #o022)} sets the mask to octal 22, decimal 18. @end deffn -@c docstring begin (texi-doc-string "guile" "getpid") @deffn primitive getpid Return an integer representing the current process ID. @end deffn -@c docstring begin (texi-doc-string "guile" "getgroups") @deffn primitive getgroups Return a vector of integers representing the current supplimentary group IDs. @end deffn -@c docstring begin (texi-doc-string "guile" "getppid") @deffn primitive getppid Return an integer representing the process ID of the parent process. @end deffn -@c docstring begin (texi-doc-string "guile" "getuid") @deffn primitive getuid Return an integer representing the current real user ID. @end deffn -@c docstring begin (texi-doc-string "guile" "getgid") @deffn primitive getgid Return an integer representing the current real group ID. @end deffn -@c docstring begin (texi-doc-string "guile" "geteuid") @deffn primitive geteuid Return an integer representing the current effective user ID. If the system does not support effective IDs, then the real ID @@ -1159,7 +1084,6 @@ is returned. @code{(feature? 'EIDs)} reports whether the system supports effective IDs. @end deffn -@c docstring begin (texi-doc-string "guile" "getegid") @deffn primitive getegid Return an integer representing the current effective group ID. If the system does not support effective IDs, then the real ID @@ -1167,21 +1091,18 @@ is returned. @code{(feature? 'EIDs)} reports whether the system supports effective IDs. @end deffn -@c docstring begin (texi-doc-string "guile" "setuid") @deffn primitive setuid id Sets both the real and effective user IDs to the integer @var{id}, provided the process has appropriate privileges. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "setgid") @deffn primitive setgid id Sets both the real and effective group IDs to the integer @var{id}, provided the process has appropriate privileges. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "seteuid") @deffn primitive seteuid id Sets the effective user ID to the integer @var{id}, provided the process has appropriate privileges. If effective IDs are not supported, the @@ -1190,7 +1111,6 @@ system supports effective IDs. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "setegid") @deffn primitive setegid id Sets the effective group ID to the integer @var{id}, provided the process has appropriate privileges. If effective IDs are not supported, the @@ -1199,13 +1119,11 @@ system supports effective IDs. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "getpgrp") @deffn primitive getpgrp Return an integer representing the current process group ID. This is the POSIX definition, not BSD. @end deffn -@c docstring begin (texi-doc-string "guile" "setpgid") @deffn primitive setpgid pid pgid Move the process @var{pid} into the process group @var{pgid}. @var{pid} or @var{pgid} must be integers: they can be zero to indicate the ID of the @@ -1214,7 +1132,6 @@ Fails on systems that do not support job control. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "setsid") @deffn primitive setsid Creates a new session. The current process becomes the session leader and is put in a new process group. The process will be detached @@ -1222,7 +1139,6 @@ from its controlling terminal if it has one. The return value is an integer representing the new process group ID. @end deffn -@c docstring begin (texi-doc-string "guile" "waitpid") @deffn primitive waitpid pid [options] This procedure collects status information from a child process which has terminated or (optionally) stopped. Normally it will @@ -1271,26 +1187,22 @@ The following three functions can be used to decode the process status code returned by @code{waitpid}. -@c docstring begin (texi-doc-string "guile" "status:exit-val") @deffn primitive status:exit-val status Return the exit status value, as would be set if a process ended normally through a call to @code{exit} or @code{_exit}, if any, otherwise @code{#f}. @end deffn -@c docstring begin (texi-doc-string "guile" "status:term-sig") @deffn primitive status:term-sig status Return the signal number which terminated the process, if any, otherwise @code{#f}. @end deffn -@c docstring begin (texi-doc-string "guile" "status:stop-sig") @deffn primitive status:stop-sig status Return the signal number which stopped the process, if any, otherwise @code{#f}. @end deffn -@c docstring begin (texi-doc-string "guile" "system") @deffn primitive system [cmd] Execute @var{cmd} using the operating system's "command processor". Under Unix this is usually the default shell @@ -1301,14 +1213,12 @@ If @code{system} is called without arguments, return a boolean indicating whether the command processor is available. @end deffn -@c docstring begin (texi-doc-string "guile" "primitive-exit") @deffn primitive primitive-exit [status] Terminate the current process without unwinding the Scheme stack. This is would typically be useful after a fork. The exit status is @var{status} if supplied, otherwise zero. @end deffn -@c docstring begin (texi-doc-string "guile" "execl") @deffn primitive execl filename . args Executes the file named by @var{path} as a new process image. The remaining arguments are supplied to the process; from a C program @@ -1323,7 +1233,6 @@ This procedure is currently implemented using the @code{execv} system call, but we call it @code{execl} because of its Scheme calling interface. @end deffn -@c docstring begin (texi-doc-string "guile" "execlp") @deffn primitive execlp filename . args Similar to @code{execl}, however if @var{filename} does not contain a slash @@ -1334,7 +1243,6 @@ This procedure is currently implemented using the @code{execvp} system call, but we call it @code{execlp} because of its Scheme calling interface. @end deffn -@c docstring begin (texi-doc-string "guile" "execle") @deffn primitive execle filename env . args Similar to @code{execl}, but the environment of the new process is specified by @var{env}, which must be a list of strings as returned by the @@ -1344,7 +1252,6 @@ This procedure is currently implemented using the @code{execve} system call, but we call it @code{execle} because of its Scheme calling interface. @end deffn -@c docstring begin (texi-doc-string "guile" "primitive-fork") @deffn primitive primitive-fork Creates a new "child" process by duplicating the current "parent" process. In the child the return value is 0. In the parent the return value is @@ -1354,7 +1261,6 @@ This procedure has been renamed from @code{fork} to avoid a naming conflict with the scsh fork. @end deffn -@c docstring begin (texi-doc-string "guile" "nice") @deffn primitive nice incr Increment the priority of the current process by @var{incr}. A higher priority value means that the process runs less often. @@ -1366,7 +1272,6 @@ The return value is unspecified. Procedures to raise, handle and wait for signals. -@c docstring begin (texi-doc-string "guile" "kill") @deffn primitive kill pid sig Sends a signal to the specified process or group of processes. @@ -1397,13 +1302,11 @@ Interrupt signal. @end defvar @end deffn -@c docstring begin (texi-doc-string "guile" "raise") @deffn primitive raise sig Sends a specified signal @var{sig} to the current process, where @var{sig} is as described for the kill procedure. @end deffn -@c docstring begin (texi-doc-string "guile" "sigaction") @deffn primitive sigaction signum [handler [flags]] Install or report the signal handler for a specified signal. @@ -1433,13 +1336,11 @@ provide solutions to the problem of consistent access to data structures. @end deffn -@c docstring begin (texi-doc-string "guile" "restore-signals") @deffn primitive restore-signals Return all signal handlers to the values they had before any call to @code{sigaction} was made. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "alarm") @deffn primitive alarm i Set a timer to raise a @code{SIGALRM} signal after the specified number of seconds (an integer). It's advisable to install a signal @@ -1452,21 +1353,18 @@ if any. The new value replaces the previous alarm. If there was no previous alarm, the return value is zero. @end deffn -@c docstring begin (texi-doc-string "guile" "pause") @deffn primitive pause Pause the current process (thread?) until a signal arrives whose action is to either terminate the current process or invoke a handler procedure. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "sleep") @deffn primitive sleep i Wait for the given number of seconds (an integer) or until a signal arrives. The return value is zero if the time elapses or the number of seconds remaining otherwise. @end deffn -@c docstring begin (texi-doc-string "guile" "usleep") @deffn primitive usleep i Sleep for I microseconds. @code{usleep} is not available on all platforms. @@ -1475,25 +1373,21 @@ all platforms. @node Terminals and Ptys @section Terminals and Ptys -@c docstring begin (texi-doc-string "guile" "isatty?") @deffn primitive isatty? port Return @code{#t} if @var{port} is using a serial non--file device, otherwise @code{#f}. @end deffn -@c docstring begin (texi-doc-string "guile" "ttyname") @deffn primitive ttyname port Return a string with the name of the serial terminal device underlying @var{port}. @end deffn -@c docstring begin (texi-doc-string "guile" "ctermid") @deffn primitive ctermid Return a string containing the file name of the controlling terminal for the current process. @end deffn -@c docstring begin (texi-doc-string "guile" "tcgetpgrp") @deffn primitive tcgetpgrp port Return the process group ID of the foreground process group associated with the terminal open on the file descriptor @@ -1506,7 +1400,6 @@ terminated, and no other job has yet been moved into the foreground. @end deffn -@c docstring begin (texi-doc-string "guile" "tcsetpgrp") @deffn primitive tcsetpgrp port pgid Set the foreground process group ID for the terminal used by the file descriptor underlying @var{port} to the integer @var{pgid}. @@ -1569,7 +1462,6 @@ the database routines since they are not reentrant. @subsubsection Address Conversion -@c docstring begin (texi-doc-string "guile" "inet-aton") @deffn primitive inet-aton address Converts a string containing an Internet host address in the traditional dotted decimal notation into an integer. @@ -1578,7 +1470,6 @@ traditional dotted decimal notation into an integer. @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "inet-ntoa") @deffn primitive inet-ntoa inetid Converts an integer Internet host address into a string with the traditional dotted decimal representation. @@ -1587,7 +1478,6 @@ the traditional dotted decimal representation. @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "inet-netof") @deffn primitive inet-netof address Return the network number part of the given integer Internet address. @@ -1596,7 +1486,6 @@ address. @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "inet-lnaof") @deffn primitive inet-lnaof address Return the local-address-with-network part of the given Internet address. @@ -1605,7 +1494,6 @@ Internet address. @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "inet-makeaddr") @deffn primitive inet-makeaddr net lna Makes an Internet host address by combining the network number @var{net} with the local-address-within-network number @@ -1643,7 +1531,6 @@ The list of network addresses associated with @var{host}. The following procedures are used to search the host database: -@c docstring begin (texi-doc-string "guile" "gethost") @deffn primitive gethost [host] @deffnx procedure gethostbyname hostname @deffnx procedure gethostbyaddr address @@ -1680,7 +1567,6 @@ This procedure may not be used before @code{sethostent} has been called. Close the stream used by @code{gethostent}. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "sethost") @deffn primitive sethost [stayopen] If @var{stayopen} is omitted, this is equivalent to @code{endhostent}. Otherwise it is equivalent to @code{sethostent stayopen}. @@ -1706,7 +1592,6 @@ The network number. The following procedures are used to search the network database: -@c docstring begin (texi-doc-string "guile" "getnet") @deffn primitive getnet [net] @deffnx procedure getnetbyname net-name @deffnx procedure getnetbyaddr net-number @@ -1737,7 +1622,6 @@ Return the next entry from the network database. Close the stream used by @code{getnetent}. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "setnet") @deffn primitive setnet [stayopen] If @var{stayopen} is omitted, this is equivalent to @code{endnetent}. Otherwise it is equivalent to @code{setnetent stayopen}. @@ -1760,7 +1644,6 @@ The protocol number. The following procedures are used to search the protocol database: -@c docstring begin (texi-doc-string "guile" "getproto") @deffn primitive getproto [protocol] @deffnx procedure getprotobyname name @deffnx procedure getprotobynumber number @@ -1790,7 +1673,6 @@ Return the next entry from the protocol database. Close the stream used by @code{getprotoent}. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "setproto") @deffn primitive setproto [stayopen] If @var{stayopen} is omitted, this is equivalent to @code{endprotoent}. Otherwise it is equivalent to @code{setprotoent stayopen}. @@ -1817,7 +1699,6 @@ in the database under different protocol names. The following procedures are used to search the service database: -@c docstring begin (texi-doc-string "guile" "getserv") @deffn primitive getserv [name [protocol]] @deffnx procedure getservbyname name protocol @deffnx procedure getservbyport port protocol @@ -1851,7 +1732,6 @@ Return the next entry from the services database. Close the stream used by @code{getservent}. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "setserv") @deffn primitive setserv [stayopen] If @var{stayopen} is omitted, this is equivalent to @code{endservent}. Otherwise it is equivalent to @code{setservent stayopen}. @@ -1871,7 +1751,6 @@ are always held in host order at the Scheme level. The procedures in this section automatically convert between host and network order when required. The arguments and return values are thus in host order. -@c docstring begin (texi-doc-string "guile" "socket") @deffn primitive socket family style proto Return a new socket port of the type specified by @var{family}, @var{style} and @var{protocol}. All three parameters are @@ -1886,7 +1765,6 @@ A single socket port cannot by used for communication until it has been connected to another socket. @end deffn -@c docstring begin (texi-doc-string "guile" "socketpair") @deffn primitive socketpair family style proto Return a pair of connected (but unnamed) socket ports of the type specified by @var{family}, @var{style} and @var{protocol}. @@ -1895,7 +1773,6 @@ family. Zero is likely to be the only meaningful value for @var{protocol}. @end deffn -@c docstring begin (texi-doc-string "guile" "getsockopt") @deffn primitive getsockopt sock level optname Return the value of a particular socket option for the socket port @var{socket}. @var{level} is an integer code for type of @@ -1907,7 +1784,6 @@ The returned value is typically an integer but @code{SO_LINGER} returns a pair of integers. @end deffn -@c docstring begin (texi-doc-string "guile" "setsockopt") @deffn primitive setsockopt sock level optname value Sets the value of a particular socket option for the socket port @var{socket}. @var{level} is an integer code for type of option @@ -1922,7 +1798,6 @@ be a pair. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "shutdown") @deffn primitive shutdown sock how Sockets can be closed simply by using @code{close-port}. The @code{shutdown} procedure allows reception or tranmission on a @@ -1943,7 +1818,6 @@ Stop both reception and transmission. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "connect") @deffn primitive connect sock fam address . args Initiates a connection from @var{socket} to the address specified by @var{address} and possibly @var{arg @dots{}}. The format @@ -1961,7 +1835,6 @@ must be a single integer port number. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "bind") @deffn primitive bind sock fam address . args Assigns an address to the socket port @var{socket}. Generally this only needs to be done for server sockets, @@ -2001,7 +1874,6 @@ No address. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "listen") @deffn primitive listen sock backlog This procedure enables @var{socket} to accept connection requests. @var{backlog} is an integer specifying @@ -2012,7 +1884,6 @@ server calls @code{accept} to accept a connection from the queue. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "accept") @deffn primitive accept sock Accepts a connection on a bound, listening socket @var{socket}. If there are no pending connections in the queue, it waits until @@ -2048,14 +1919,12 @@ If the socket family is @code{AF_INET}, returns the Internet port number. @end table -@c docstring begin (texi-doc-string "guile" "getsockname") @deffn primitive getsockname sock Return the address of @var{socket}, in the same form as the object returned by @code{accept}. On many systems the address of a socket in the @code{AF_FILE} namespace cannot be read. @end deffn -@c docstring begin (texi-doc-string "guile" "getpeername") @deffn primitive getpeername sock Return the address of the socket that the socket @var{socket} is connected to, in the same form as the object returned by @@ -2063,7 +1932,6 @@ is connected to, in the same form as the object returned by @code{AF_FILE} namespace cannot be read. @end deffn -@c docstring begin (texi-doc-string "guile" "recv!") @deffn primitive recv! sock buf [flags] Receives data from the socket port @var{socket}. @var{socket} must already be bound to the address from which data is to be received. @@ -2082,7 +1950,6 @@ Note that the data is read directly from the socket file descriptor: any unread buffered port data is ignored. @end deffn -@c docstring begin (texi-doc-string "guile" "send") @deffn primitive send sock message [flags] Transmits the string @var{message} on the socket port @var{socket}. @var{socket} must already be bound to a destination address. The @@ -2095,7 +1962,6 @@ Note that the data is written directly to the socket file descriptor: any unflushed buffered port data is ignored. @end deffn -@c docstring begin (texi-doc-string "guile" "recvfrom!") @deffn primitive recvfrom! sock str [flags [start [end]]] Return data from the socket port @var{socket} and also information about where the data was received from. @@ -2116,7 +1982,6 @@ Note that the data is read directly from the socket file descriptor: any unread buffered port data is ignored. @end deffn -@c docstring begin (texi-doc-string "guile" "sendto") @deffn primitive sendto sock message fam address . args_and_flags Transmits the string @var{message} on the socket port @var{socket}. The destination address is specified using the @var{family}, @var{address} and @@ -2136,28 +2001,24 @@ between "host" and "network" order. Although the procedures above do this automatically for addresses, the conversion will still need to be done when sending or receiving encoded integer data from the network. -@c docstring begin (texi-doc-string "guile" "htons") @deffn primitive htons in Return a new integer from @var{value} by converting from host to network order. @var{value} must be within the range of a C unsigned short integer. @end deffn -@c docstring begin (texi-doc-string "guile" "ntohs") @deffn primitive ntohs in Return a new integer from @var{value} by converting from network to host order. @var{value} must be within the range of a C unsigned short integer. @end deffn -@c docstring begin (texi-doc-string "guile" "htonl") @deffn primitive htonl in Return a new integer from @var{value} by converting from host to network order. @var{value} must be within the range of a C unsigned long integer. @end deffn -@c docstring begin (texi-doc-string "guile" "ntohl") @deffn primitive ntohl in Return a new integer from @var{value} by converting from network to host order. @var{value} must be within the range of @@ -2183,7 +2044,6 @@ These procedures are inconvenient to use at present, but consider: @node System Identification @section System Identification -@c docstring begin (texi-doc-string "guile" "uname") @deffn primitive uname Return an object with some information about the computer system the program is running on. @@ -2221,7 +2081,6 @@ no other easy or unambiguous way of detecting such features. @node Locales @section Locales -@c docstring begin (texi-doc-string "guile" "setlocale") @deffn primitive setlocale category [locale] If @var{locale} is omitted, return the current value of the specified locale category as a system-dependent string. diff --git a/doc/scheme-binding.texi b/doc/scheme-binding.texi index d23ff2fb5..b6bbe7447 100644 --- a/doc/scheme-binding.texi +++ b/doc/scheme-binding.texi @@ -26,7 +26,6 @@ @section Querying variable bindings @c NJFIXME explain [env] -@c docstring begin (texi-doc-string "guile" "defined?") @deffn primitive defined? sym [env] Return @code{#t} if @var{sym} is defined in the top-level environment. @end deffn diff --git a/doc/scheme-control.texi b/doc/scheme-control.texi index 31a20681f..6922f5b9d 100644 --- a/doc/scheme-control.texi +++ b/doc/scheme-control.texi @@ -88,7 +88,6 @@ Instead of using @code{call-with-current-continuation}, the exception primitives documented here are implemented as built-ins that take advantage of the @emph{upward only} nature of exceptions. -@c docstring begin (texi-doc-string "guile" "catch") @deffn primitive catch key thunk handler Invoke @var{thunk} in the dynamic context of @var{handler} for exceptions matching @var{key}. If thunk throws to the symbol @@ -106,7 +105,6 @@ If the key is @code{#t}, then a throw to @emph{any} symbol will match this call to @code{catch}. @end deffn -@c docstring begin (texi-doc-string "guile" "throw") @deffn primitive throw key . args Invoke the catch form matching @var{key}, passing @var{args} to the @var{handler}. @@ -117,7 +115,6 @@ Invoke the catch form matching @var{key}, passing @var{args} to the If there is no handler at all, an error is signaled. @end deffn -@c docstring begin (texi-doc-string "guile" "lazy-catch") @deffn primitive lazy-catch key thunk handler This behaves exactly like @code{catch}, except that it does not unwind the stack (this is the major difference), and if @@ -139,7 +136,6 @@ displaying @var{msg} and writing @var{args}. @end deffn @c end -@c docstring begin (texi-doc-string "guile" "scm-error") @deffn primitive scm-error key subr message args data Raise an error with key @var{key}. @var{subr} can be a string naming the procedure associated with the error, or @code{#f}. @@ -156,7 +152,6 @@ should be a list containing the Unix signal number; otherwise it will usually be @code{#f}. @end deffn -@c docstring begin (texi-doc-string "guile" "strerror") @deffn primitive strerror err Return the Unix error message corresponding to @var{err}, which must be an integer value. @@ -177,7 +172,6 @@ if an exception occurs then @code{#f} is returned instead. be reviewed] @rnindex dynamic-wind -@c docstring begin (texi-doc-string "guile" "dynamic-wind") @deffn primitive dynamic-wind in_guard thunk out_guard All three arguments must be 0-argument procedures. @var{in_guard} is called, then @var{thunk}, then diff --git a/doc/scheme-data.texi b/doc/scheme-data.texi index af6a17d76..d317ba5a7 100755 --- a/doc/scheme-data.texi +++ b/doc/scheme-data.texi @@ -121,7 +121,6 @@ number 0 (like in C and C++), and not the same as the ``empty list'' The @code{not} procedure returns the boolean inverse of its argument: @rnindex not -@c docstring begin (texi-doc-string "guile" "not") @deffn primitive not x Return @code{#t} iff @var{x} is @code{#f}, else return @code{#f}. @end deffn @@ -130,7 +129,6 @@ The @code{boolean?} procedure is a predicate that returns @code{#t} if its argument is one of the boolean values, otherwise @code{#f}. @rnindex boolean? -@c docstring begin (texi-doc-string "guile" "boolean?") @deffn primitive boolean? obj Return @code{#t} iff @var{obj} is either @code{#t} or @code{#f}. @end deffn @@ -204,7 +202,6 @@ converted by Guile to the corresponding real number. The @code{number?} predicate may be applied to any Scheme value to discover whether the value is any of the supported numerical types. -@c docstring begin (texi-doc-string "guile" "number?") @deffn primitive number? obj Return @code{#t} if @var{obj} is any kind of number, @code{#f} else. @end deffn @@ -273,7 +270,6 @@ completely invisible to the Scheme level programmer. @c REFFIXME Maybe point here to discussion of handling immediates/bignums @c on the C level, where the conversion is not so automatic - NJ -@c docstring begin (texi-doc-string "guile" "integer?") @deffn primitive integer? x Return @code{#t} if @var{x} is an integer number, @code{#f} else. @@ -334,7 +330,6 @@ rational numbers and real irrational numbers such as square roots, and in such a way that the new kinds of number integrate seamlessly with those that are already implemented. -@c docstring begin (texi-doc-string "guile" "real?") @deffn primitive real? obj Return @code{#t} if @var{obj} is a real number, @code{#f} else. Note that the sets of integer and rational values form subsets @@ -342,7 +337,6 @@ of the set of real numbers, so the predicate will also be fulfilled if @var{obj} is an integer number or a rational number. @end deffn -@c docstring begin (texi-doc-string "guile" "rational?") @deffn primitive rational? x Return @code{#t} if @var{x} is a rational number, @code{#f} else. Note that the set of integer values forms a subset of @@ -380,7 +374,6 @@ Guile represents a complex number as a pair of numbers both of which are real, so the real and imaginary parts of a complex number have the same properties of inexactness and limited precision as single real numbers. -@c docstring begin (texi-doc-string "guile" "complex?") @deffn primitive complex? x Return @code{#t} if @var{x} is a complex number, @code{#f} else. Note that the sets of real, rational and integer @@ -405,19 +398,16 @@ available, has no fractional part, and is printed as @code{5.0}. Guile will only convert the latter value to the former when forced to do so by an invocation of the @code{inexact->exact} procedure. -@c docstring begin (texi-doc-string "guile" "exact?") @deffn primitive exact? x Return @code{#t} if @var{x} is an exact number, @code{#f} otherwise. @end deffn -@c docstring begin (texi-doc-string "guile" "inexact?") @deffn primitive inexact? x Return @code{#t} if @var{x} is an inexact number, @code{#f} else. @end deffn -@c docstring begin (texi-doc-string "guile" "inexact->exact") @deffn primitive inexact->exact z Return an exact number that is numerically closest to @var{z}. @end deffn @@ -505,13 +495,11 @@ multiplying by 10^N. @rnindex gcd @rnindex lcm -@c docstring begin (texi-doc-string "guile" "odd?") @deffn primitive odd? n Return @code{#t} if @var{n} is an odd number, @code{#f} otherwise. @end deffn -@c docstring begin (texi-doc-string "guile" "even?") @deffn primitive even? n Return @code{#t} if @var{n} is an even number, @code{#f} otherwise. @@ -612,14 +600,12 @@ zero. @rnindex number->string @rnindex string->number -@c docstring begin (texi-doc-string "guile" "number->string") @deffn primitive number->string n [radix] Return a string holding the external representation of the number @var{n} in the given @var{radix}. If @var{n} is inexact, a radix of 10 will be used. @end deffn -@c docstring begin (texi-doc-string "guile" "string->number") @deffn primitive string->number string [radix] Return a number of the maximally precise representation expressed by the given @var{string}. @var{radix} must be an @@ -641,13 +627,11 @@ syntactically valid notation for a number, then @rnindex magnitude @rnindex angle -@c docstring begin (texi-doc-string "guile" "make-rectangular") @deffn primitive make-rectangular real imaginary Return a complex number constructed of the given @var{real} and @var{imaginary} parts. @end deffn -@c docstring begin (texi-doc-string "guile" "make-polar") @deffn primitive make-polar x y Return the complex number @var{x} * e^(i * @var{y}). @end deffn @@ -868,7 +852,6 @@ Return the absolute value of @var{x}. Return the square root of @var{x}. @end deffn -@c docstring begin (texi-doc-string "guile" "$expt") @deffn primitive $expt x y Return @var{x} raised to the power of @var{y}. This procedure does not accept complex arguments. @@ -904,7 +887,6 @@ Return the arccosine of @var{x}. Return the arctangent of @var{x} in the range -PI/2 to PI/2. @end deffn -@c docstring begin (texi-doc-string "guile" "$atan2") @deffn primitive $atan2 x y Return the arc tangent of the two arguments @var{x} and @var{y}. This is similar to calculating the arc tangent of @@ -958,7 +940,6 @@ Return the hyperbolic arctangent of @var{x}. @node Bitwise Operations @subsection Bitwise Operations -@c docstring begin (texi-doc-string "guile" "logand") @deffn primitive logand n1 n2 Return the integer which is the bit-wise AND of the two integer arguments. @@ -968,7 +949,6 @@ arguments. @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "logior") @deffn primitive logior n1 n2 Return the integer which is the bit-wise OR of the two integer arguments. @@ -978,7 +958,6 @@ arguments. @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "logxor") @deffn primitive logxor n1 n2 Return the integer which is the bit-wise XOR of the two integer arguments. @@ -988,7 +967,6 @@ arguments. @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "lognot") @deffn primitive lognot n Return the integer which is the 2s-complement of the integer argument. @@ -1000,7 +978,6 @@ argument. @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "logtest") @deffn primitive logtest j k @lisp (logtest j k) @equiv{} (not (zero? (logand j k))) @@ -1010,7 +987,6 @@ argument. @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "logbit?") @deffn primitive logbit? index j @lisp (logbit? index j) @equiv{} (logtest (integer-expt 2 index) j) @@ -1023,7 +999,6 @@ argument. @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "ash") @deffn primitive ash n cnt The function ash performs an arithmetic shift left by @var{cnt} bits (or shift right, if @var{cnt} is negative). 'Arithmetic' @@ -1040,7 +1015,6 @@ Formally, the function returns an integer equivalent to @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "logcount") @deffn primitive logcount n Return the number of bits in integer @var{n}. If integer is positive, the 1-bits in its binary representation are counted. @@ -1056,7 +1030,6 @@ representation are counted. If 0, 0 is returned. @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "integer-length") @deffn primitive integer-length n Return the number of bits neccessary to represent @var{n}. @lisp @@ -1069,7 +1042,6 @@ Return the number of bits neccessary to represent @var{n}. @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "integer-expt") @deffn primitive integer-expt n k Return @var{n} raised to the non-negative integer exponent @var{k}. @@ -1081,7 +1053,6 @@ Return @var{n} raised to the non-negative integer exponent @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "bit-extract") @deffn primitive bit-extract n start end Return the integer composed of the @var{start} (inclusive) through @var{end} (exclusive) bits of @var{n}. The @@ -1098,12 +1069,10 @@ through @var{end} (exclusive) bits of @var{n}. The @node Random @subsection Random Number Generation -@c docstring begin (texi-doc-string "guile" "copy-random-state") @deffn primitive copy-random-state [state] Return a copy of the random state @var{state}. @end deffn -@c docstring begin (texi-doc-string "guile" "random") @deffn primitive random n [state] Return a number in [0,N). Accepts a positive integer or real n and returns a @@ -1117,14 +1086,12 @@ the state of the pseudo-random-number generator and is altered as a side effect of the random operation. @end deffn -@c docstring begin (texi-doc-string "guile" "random:exp") @deffn primitive random:exp [state] Return an inexact real in an exponential distribution with mean 1. For an exponential distribution with mean u use (* u (random:exp)). @end deffn -@c docstring begin (texi-doc-string "guile" "random:hollow-sphere!") @deffn primitive random:hollow-sphere! v [state] Fills vect with inexact real random numbers the sum of whose squares is equal to 1.0. @@ -1134,7 +1101,6 @@ are uniformly distributed over the surface of the unit n-shere. @end deffn -@c docstring begin (texi-doc-string "guile" "random:normal") @deffn primitive random:normal [state] Return an inexact real in a normal distribution. The distribution used has mean 0 and standard deviation 1. For a @@ -1142,14 +1108,12 @@ normal distribution with mean m and standard deviation d use @code{(+ m (* d (random:normal)))}. @end deffn -@c docstring begin (texi-doc-string "guile" "random:normal-vector!") @deffn primitive random:normal-vector! v [state] Fills vect with inexact real random numbers that are independent and standard normally distributed (i.e., with mean 0 and variance 1). @end deffn -@c docstring begin (texi-doc-string "guile" "random:solid-sphere!") @deffn primitive random:solid-sphere! v [state] Fills vect with inexact real random numbers the sum of whose squares is less than 1.0. @@ -1159,13 +1123,11 @@ are uniformly distributed within the unit n-shere. The sum of the squares of the numbers is returned. @end deffn -@c docstring begin (texi-doc-string "guile" "random:uniform") @deffn primitive random:uniform [state] Return a uniformly distributed inexact real random number in [0,1). @end deffn -@c docstring begin (texi-doc-string "guile" "seed->random-state") @deffn primitive seed->random-state seed Return a new random state using @var{seed}. @end deffn @@ -1252,124 +1214,103 @@ Several characters have more than one name: #\null, #\nul @end itemize -@c docstring begin (texi-doc-string "guile" "char?") @deffn primitive char? x Return @code{#t} iff @var{x} is a character, else @code{#f}. @end deffn -@c docstring begin (texi-doc-string "guile" "char=?") @deffn primitive char=? x y Return @code{#t} iff @var{x} is the same character as @var{y}, else @code{#f}. @end deffn -@c docstring begin (texi-doc-string "guile" "char?") @deffn primitive char>? x y Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII sequence, else @code{#f}. @end deffn -@c docstring begin (texi-doc-string "guile" "char>=?") @deffn primitive char>=? x y Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the ASCII sequence, else @code{#f}. @end deffn -@c docstring begin (texi-doc-string "guile" "char-ci=?") @deffn primitive char-ci=? x y Return @code{#t} iff @var{x} is the same character as @var{y} ignoring case, else @code{#f}. @end deffn -@c docstring begin (texi-doc-string "guile" "char-ci?") @deffn primitive char-ci>? x y Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII sequence ignoring case, else @code{#f}. @end deffn -@c docstring begin (texi-doc-string "guile" "char-ci>=?") @deffn primitive char-ci>=? x y Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the ASCII sequence ignoring case, else @code{#f}. @end deffn -@c docstring begin (texi-doc-string "guile" "char-alphabetic?") @deffn primitive char-alphabetic? chr Return @code{#t} iff @var{chr} is alphabetic, else @code{#f}. Alphabetic means the same thing as the isalpha C library function. @end deffn -@c docstring begin (texi-doc-string "guile" "char-numeric?") @deffn primitive char-numeric? chr Return @code{#t} iff @var{chr} is numeric, else @code{#f}. Numeric means the same thing as the isdigit C library function. @end deffn -@c docstring begin (texi-doc-string "guile" "char-whitespace?") @deffn primitive char-whitespace? chr Return @code{#t} iff @var{chr} is whitespace, else @code{#f}. Whitespace means the same thing as the isspace C library function. @end deffn -@c docstring begin (texi-doc-string "guile" "char-upper-case?") @deffn primitive char-upper-case? chr Return @code{#t} iff @var{chr} is uppercase, else @code{#f}. Uppercase means the same thing as the isupper C library function. @end deffn -@c docstring begin (texi-doc-string "guile" "char-lower-case?") @deffn primitive char-lower-case? chr Return @code{#t} iff @var{chr} is lowercase, else @code{#f}. Lowercase means the same thing as the islower C library function. @end deffn -@c docstring begin (texi-doc-string "guile" "char-is-both?") @deffn primitive char-is-both? chr Return @code{#t} iff @var{chr} is either uppercase or lowercase, else @code{#f}. Uppercase and lowercase are as defined by the isupper and islower C library functions. @end deffn -@c docstring begin (texi-doc-string "guile" "char->integer") @deffn primitive char->integer chr Return the number corresponding to ordinal position of @var{chr} in the ASCII sequence. @end deffn -@c docstring begin (texi-doc-string "guile" "integer->char") @deffn primitive integer->char n Return the character at position @var{n} in the ASCII sequence. @end deffn -@c docstring begin (texi-doc-string "guile" "char-upcase") @deffn primitive char-upcase chr Return the uppercase character version of @var{chr}. @end deffn -@c docstring begin (texi-doc-string "guile" "char-downcase") @deffn primitive char-downcase chr Return the lowercase character version of @var{chr}. @end deffn @@ -1437,13 +1378,11 @@ The following procedures can be used to check whether a given string fulfills some specified property. @rnindex string? -@c docstring begin (texi-doc-string "guile" "string?") @deffn primitive string? obj Return @code{#t} iff @var{obj} is a string, else returns @code{#f}. @end deffn -@c docstring begin (texi-doc-string "guile" "string-null?") @deffn primitive string-null? str Return @code{#t} if @var{str}'s length is nonzero, and @code{#f} otherwise. @@ -1464,8 +1403,6 @@ initializing them with some specified character data. @rnindex string @rnindex list->string -@c docstring begin (texi-doc-string "guile" "string") -@c docstring begin (texi-doc-string "guile" "list->string") @deffn primitive string . chrs @deffnx primitive list->string chrs Return a newly allocated string composed of the arguments, @@ -1473,7 +1410,6 @@ Return a newly allocated string composed of the arguments, @end deffn @rnindex make-string -@c docstring begin (texi-doc-string "guile" "make-string") @deffn primitive make-string k [chr] Return a newly allocated string of length @var{k}. If @var{chr} is given, then all elements of @@ -1490,7 +1426,6 @@ work with the resulting list, and then convert it back into a string. These procedures are useful for similar tasks. @rnindex string->list -@c docstring begin (texi-doc-string "guile" "string->list") @deffn primitive string->list str Return a newly allocated list of the characters that make up the given string @var{str}. @code{string->list} and @@ -1506,26 +1441,22 @@ Portions of strings can be extracted by these procedures. @code{substring} can be used to extract substrings from longer strings. @rnindex string-length -@c docstring begin (texi-doc-string "guile" "string-length") @deffn primitive string-length string Return the number of characters in @var{string}. @end deffn @rnindex string-ref -@c docstring begin (texi-doc-string "guile" "string-ref") @deffn primitive string-ref str k Return character @var{k} of @var{str} using zero-origin indexing. @var{k} must be a valid index of @var{str}. @end deffn @rnindex string-copy -@c docstring begin (texi-doc-string "guile" "string-copy") @deffn primitive string-copy str Return a newly allocated copy of the given @var{string}. @end deffn @rnindex substring -@c docstring begin (texi-doc-string "guile" "substring") @deffn primitive substring str start [end] Return a newly allocated string formed from the characters of @var{str} beginning with index @var{start} (inclusive) and @@ -1544,7 +1475,6 @@ not a new string is the result of a string operation, but that the actual memory representation of a string is modified. @rnindex string-set! -@c docstring begin (texi-doc-string "guile" "string-set!") @deffn primitive string-set! str k chr Store @var{chr} in element @var{k} of @var{str} and return an unspecified value. @var{k} must be a valid index of @@ -1552,13 +1482,11 @@ an unspecified value. @var{k} must be a valid index of @end deffn @rnindex string-fill! -@c docstring begin (texi-doc-string "guile" "string-fill!") @deffn primitive string-fill! str chr Store @var{char} in every element of the given @var{string} and return an unspecified value. @end deffn -@c docstring begin (texi-doc-string "guile" "substring-fill!") @deffn primitive substring-fill! str start end fill Change every character in @var{str} between @var{start} and @var{end} to @var{fill}. @@ -1570,9 +1498,6 @@ y @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "substring-move!") -@c docstring begin (texi-doc-string "guile" "substring-move-left!") -@c docstring begin (texi-doc-string "guile" "substring-move-right!") @deffn primitive substring-move! str1 start1 end1 str2 start2 @deffnx primitive substring-move-left! str1 start1 end1 str2 start2 @deffnx primitive substring-move-right! str1 start1 end1 str2 start2 @@ -1657,7 +1582,6 @@ ending in @code{-ci} ignore the character case when comparing strings. @rnindex string=? -@c docstring begin (texi-doc-string "guile" "string=?") @deffn primitive string=? s1 s2 Lexicographic equality predicate; return @code{#t} if the two strings are the same length and contain the same characters in @@ -1669,35 +1593,30 @@ characters. @end deffn @rnindex string? -@c docstring begin (texi-doc-string "guile" "string>?") @deffn primitive string>? s1 s2 Lexicographic ordering predicate; return @code{#t} if @var{s1} is lexicographically greater than @var{s2}. @end deffn @rnindex string>=? -@c docstring begin (texi-doc-string "guile" "string>=?") @deffn primitive string>=? s1 s2 Lexicographic ordering predicate; return @code{#t} if @var{s1} is lexicographically greater than or equal to @var{s2}. @end deffn @rnindex string-ci=? -@c docstring begin (texi-doc-string "guile" "string-ci=?") @deffn primitive string-ci=? s1 s2 Case-insensitive string equality predicate; return @code{#t} if the two strings are the same length and their component @@ -1706,7 +1625,6 @@ return @code{#f}. @end deffn @rnindex string-ci< -@c docstring begin (texi-doc-string "guile" "string-ci? -@c docstring begin (texi-doc-string "guile" "string-ci>?") @deffn primitive string-ci>? s1 s2 Case insensitive lexicographic ordering predicate; return @code{#t} if @var{s1} is lexicographically greater than @@ -1730,7 +1646,6 @@ Case insensitive lexicographic ordering predicate; return @end deffn @rnindex string-ci>=? -@c docstring begin (texi-doc-string "guile" "string-ci>=?") @deffn primitive string-ci>=? s1 s2 Case insensitive lexicographic ordering predicate; return @code{#t} if @var{s1} is lexicographically greater than or @@ -1744,7 +1659,6 @@ equal to @var{s2} regardless of case. When searching the index of a character in a string, these procedures can be used. -@c docstring begin (texi-doc-string "guile" "string-index") @deffn primitive string-index str chr [frm [to]] Return the index of the first occurrence of @var{chr} in @var{str}. The optional integer arguments @var{frm} and @@ -1763,7 +1677,6 @@ procedure essentially implements the @code{index} or @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "string-rindex") @deffn primitive string-rindex str chr [frm [to]] Like @code{string-index}, but search from the right of the string rather than from the left. This procedure essentially @@ -1787,13 +1700,11 @@ the C library. These are procedures for mapping strings to their upper-- or lower--case equivalents, respectively, or for capitalizing strings. -@c docstring begin (texi-doc-string "guile" "string-upcase") @deffn primitive string-upcase str Return a freshly allocated string containing the characters of @var{str} in upper case. @end deffn -@c docstring begin (texi-doc-string "guile" "string-upcase!") @deffn primitive string-upcase! str Destructively upcase every character in @var{str} and return @var{str}. @@ -1804,13 +1715,11 @@ y @result{} "ARRDEFG" @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "string-downcase") @deffn primitive string-downcase str Return a freshly allocation string containing the characters in @var{str} in lower case. @end deffn -@c docstring begin (texi-doc-string "guile" "string-downcase!") @deffn primitive string-downcase! str Destructively downcase every character in @var{str} and return @var{str}. @@ -1821,14 +1730,12 @@ y @result{} "arrdefg" @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "string-capitalize") @deffn primitive string-capitalize str Return a freshly allocated string with the characters in @var{str}, where the first character of every word is capitalized. @end deffn -@c docstring begin (texi-doc-string "guile" "string-capitalize!") @deffn primitive string-capitalize! str Upcase the first character of every word in @var{str} destructively and return @var{str}. @@ -1847,7 +1754,6 @@ The procedure @code{string-append} appends several strings together to form a longer result string. @rnindex string-append -@c docstring begin (texi-doc-string "guile" "string-append") @deffn primitive string-append . args Return a newly allocated string whose characters form the concatenation of the given strings, @var{args}. @@ -1859,7 +1765,6 @@ concatenation of the given strings, @var{args}. This section contains several remaining string procedures. -@c docstring begin (texi-doc-string "guile" "string-ci->symbol") @deffn primitive string-ci->symbol str Return the symbol whose name is @var{str}. @var{str} is converted to lowercase before the conversion is done, if Guile @@ -1886,7 +1791,6 @@ substring is an object that mostly behaves just like an ordinary substring, except that it actually shares storage space with its parent string. -@c docstring begin (texi-doc-string "guile" "make-shared-substring") @deffn primitive make-shared-substring str [start [end]] Return a shared substring of @var{str}. The semantics are the same as for the @code{substring} function: the shared substring @@ -1955,7 +1859,6 @@ and read only strings. Mutable strings answer @code{#t} to @code{string?} while read only strings may or may not. All kinds of strings, whether or not they are mutable return #t to this: -@c docstring begin (texi-doc-string "guile" "read-only-string?") @deffn primitive read-only-string? obj Return true if @var{obj} can be read as a string, @@ -2046,7 +1949,6 @@ the same regular expression is used several times (for example, in a loop). For better performance, you can compile a regular expression in advance and then match strings against the compiled regexp. -@c docstring begin (texi-doc-string "guile" "make-regexp") @deffn primitive make-regexp pat . flags Compile the regular expression described by @var{pat}, and return the compiled regexp structure. If @var{pat} does not @@ -2085,7 +1987,6 @@ one which comes last will override the earlier one. @end table @end deffn -@c docstring begin (texi-doc-string "guile" "regexp-exec") @deffn primitive regexp-exec rx str [start [flags]] Match the compiled regular expression @var{rx} against @code{str}. If the optional integer @var{start} argument is @@ -2094,7 +1995,6 @@ Return a match structure describing the results of the match, or @code{#f} if no match could be found. @end deffn -@c docstring begin (texi-doc-string "guile" "regexp?") @deffn primitive regexp? obj Return @code{#t} if @var{obj} is a compiled regular expression, or @code{#f} otherwise. @@ -2467,7 +2367,6 @@ table (with an undefined value) if none is yet present. @c unbound symbols. @c @end deffn -@c docstring begin (texi-doc-string "guile" "gensym") @deffn primitive 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 @@ -2476,7 +2375,6 @@ is increased by 1 at each call. There is no provision for resetting the counter. @end deffn -@c docstring begin (texi-doc-string "guile" "gentemp") @deffn primitive gentemp [prefix [obarray]] Create a new symbol with a name unique in an obarray. The name is constructed from an optional string @var{prefix} @@ -2487,14 +2385,12 @@ interned. The counter is increased by 1 at each call. There is no provision for resetting the counter. @end deffn -@c docstring begin (texi-doc-string "guile" "intern-symbol") @deffn primitive intern-symbol obarray string Add a new symbol to @var{obarray} with name @var{string}, bound to an unspecified initial value. The symbol table is not modified if a symbol with this name is already present. @end deffn -@c docstring begin (texi-doc-string "guile" "string->obarray-symbol") @deffn primitive string->obarray-symbol obarray string [soft?] Intern a new symbol in @var{obarray}, a symbol table, with name @var{string}. @@ -2512,7 +2408,6 @@ table; instead, simply return @code{#f}. @end deffn @rnindex string->symbol -@c docstring begin (texi-doc-string "guile" "string->symbol") @deffn primitive string->symbol string Return the symbol whose name is @var{string}. This procedure can create symbols with names containing special characters or @@ -2535,7 +2430,6 @@ standard case is lower case: @end deffn @rnindex symbol->string -@c docstring begin (texi-doc-string "guile" "symbol->string") @deffn primitive symbol->string s Return the name of @var{symbol} as a string. If the symbol was part of an object returned as the value of a literal expression @@ -2560,7 +2454,6 @@ standard case is lower case: @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "symbol-binding") @deffn primitive symbol-binding obarray string Look up in @var{obarray} the symbol whose name is @var{string}, and return the value to which it is bound. If @var{obarray} is @code{#f}, @@ -2568,7 +2461,6 @@ use the global symbol table. If @var{string} is not interned in @var{obarray}, an error is signalled. @end deffn -@c docstring begin (texi-doc-string "guile" "symbol-bound?") @deffn primitive symbol-bound? obarray string Return @code{#t} if @var{obarray} contains a symbol with name @var{string} bound to a defined value. This differs from @@ -2578,38 +2470,31 @@ determines whether a symbol has been given any meaningful value. @end deffn -@c docstring begin (texi-doc-string "guile" "symbol-fref") @deffn primitive symbol-fref symbol Return the contents of @var{symbol}'s @dfn{function slot}. @end deffn -@c docstring begin (texi-doc-string "guile" "symbol-fset!") @deffn primitive symbol-fset! symbol value Change the binding of @var{symbol}'s function slot. @end deffn -@c docstring begin (texi-doc-string "guile" "symbol-hash") @deffn primitive symbol-hash symbol Return a hash value for @var{symbol}. @end deffn -@c docstring begin (texi-doc-string "guile" "symbol-interned?") @deffn primitive symbol-interned? obarray string Return @code{#t} if @var{obarray} contains a symbol with name @var{string}, and @code{#f} otherwise. @end deffn -@c docstring begin (texi-doc-string "guile" "symbol-pref") @deffn primitive symbol-pref symbol Return the @dfn{property list} currently associated with @var{symbol}. @end deffn -@c docstring begin (texi-doc-string "guile" "symbol-pset!") @deffn primitive symbol-pset! symbol value Change the binding of @var{symbol}'s property slot. @end deffn -@c docstring begin (texi-doc-string "guile" "symbol-set!") @deffn primitive symbol-set! obarray string value Find the symbol in @var{obarray} whose name is @var{string}, and rebind it to @var{value}. An error is signalled if @var{string} is not present @@ -2617,27 +2502,23 @@ in @var{obarray}. @end deffn @rnindex symbol? -@c docstring begin (texi-doc-string "guile" "symbol?") @deffn primitive symbol? obj Return @code{#t} if @var{obj} is a symbol, otherwise return @code{#f}. @end deffn -@c docstring begin (texi-doc-string "guile" "unintern-symbol") @deffn primitive unintern-symbol obarray string Remove the symbol with name @var{string} from @var{obarray}. This function returns @code{#t} if the symbol was present and @code{#f} otherwise. @end deffn -@c docstring begin (texi-doc-string "guile" "builtin-variable") @deffn primitive builtin-variable name Return the built-in variable with the name @var{name}. @var{name} must be a symbol (not a string). Then use @code{variable-ref} to access its value. @end deffn -@c docstring begin (texi-doc-string "guile" "make-undefined-variable") @deffn primitive make-undefined-variable [name-hint] Return a variable object initialized to an undefined value. If given, uses @var{name-hint} as its internal (debugging) @@ -2646,7 +2527,6 @@ Remember, of course, that multiple bindings to the same variable may exist, so @var{name-hint} is just that---a hint. @end deffn -@c docstring begin (texi-doc-string "guile" "make-variable") @deffn primitive make-variable init [name-hint] Return a variable object initialized to value @var{init}. If given, uses @var{name-hint} as its internal (debugging) @@ -2655,27 +2535,23 @@ Remember, of course, that multiple bindings to the same variable may exist, so @var{name-hint} is just that---a hint. @end deffn -@c docstring begin (texi-doc-string "guile" "variable-bound?") @deffn primitive variable-bound? var Return @code{#t} iff @var{var} is bound to a value. Throws an error if @var{var} is not a variable object. @end deffn -@c docstring begin (texi-doc-string "guile" "variable-ref") @deffn primitive variable-ref var Dereference @var{var} and return its value. @var{var} must be a variable object; see @code{make-variable} and @code{make-undefined-variable}. @end deffn -@c docstring begin (texi-doc-string "guile" "variable-set!") @deffn primitive variable-set! var val Set the value of the variable @var{var} to @var{val}. @var{var} must be a variable object, @var{val} can be any value. Return an unspecified value. @end deffn -@c docstring begin (texi-doc-string "guile" "variable?") @deffn primitive variable? obj Return @code{#t} iff @var{obj} is a variable object, else return @code{#f} @@ -2878,18 +2754,15 @@ construct a keyword object programmatically, you can do so by calling (as the reader does). The dash symbol for a keyword object can be retrieved using the @code{keyword-dash-symbol} procedure. -@c docstring begin (texi-doc-string "guile" "make-keyword-from-dash-symbol") @deffn primitive make-keyword-from-dash-symbol symbol Make a keyword object from a @var{symbol} that starts with a dash. @end deffn -@c docstring begin (texi-doc-string "guile" "keyword?") @deffn primitive keyword? obj Return @code{#t} if the argument @var{obj} is a keyword, else @code{#f}. @end deffn -@c docstring begin (texi-doc-string "guile" "keyword-dash-symbol") @deffn primitive keyword-dash-symbol keyword Return the dash symbol for @var{keyword}. This is the inverse of @code{make-keyword-from-dash-symbol}. @@ -2945,7 +2818,6 @@ pair, and the pair is returned. The name @code{cons} stands for given Scheme object is a pair or not. @rnindex cons -@c docstring begin (texi-doc-string "guile" "cons") @deffn primitive cons x y Return a newly allocated pair whose car is @var{x} and whose cdr is @var{y}. The pair is guaranteed to be different (in the @@ -2953,7 +2825,6 @@ sense of @code{eq?}) from every previously existing object. @end deffn @rnindex pair? -@c docstring begin (texi-doc-string "guile" "pair?") @deffn primitive pair? x Return @code{#t} if @var{x} is a pair; otherwise return @code{#f}. @@ -2987,14 +2858,12 @@ for example @code{caddr} could be defined by @end deffn @rnindex set-car! -@c docstring begin (texi-doc-string "guile" "set-car!") @deffn primitive set-car! pair value Stores @var{value} in the car field of @var{pair}. The value returned by @code{set-car!} is unspecified. @end deffn @rnindex set-cdr! -@c docstring begin (texi-doc-string "guile" "set-cdr!") @deffn primitive set-cdr! pair value Stores @var{value} in the cdr field of @var{pair}. The value returned by @code{set-cdr!} is unspecified. @@ -3078,7 +2947,6 @@ whether their input is valid, or they could do different things depending on the datatype of their arguments. @rnindex list? -@c docstring begin (texi-doc-string "guile" "list?") @deffn primitive list? x Return @code{#t} iff @var{x} is a proper list, else @code{#f}. @end deffn @@ -3089,7 +2957,6 @@ somehow deals with the elements of a list until the list satisfies @code{null?}. Then, teh algorithm terminates. @rnindex null? -@c docstring begin (texi-doc-string "guile" "null?") @deffn primitive null? x Return @code{#t} iff @var{x} is the empty list, else @code{#f}. @end deffn @@ -3103,13 +2970,11 @@ This section describes the procedures for constructing new lists. the last pair of the list. @rnindex list -@c docstring begin (texi-doc-string "guile" "list") @deffn primitive list arg1 @dots{} Return a list containing @var{objs}, the arguments to @code{list}. @end deffn -@c docstring begin (texi-doc-string "guile" "cons*") @deffn primitive cons* arg1 arg2 @dots{} Like @code{list}, but the last arg provides the tail of the constructed list, returning @code{(cons @var{arg1} (cons @@ -3119,7 +2984,6 @@ result. This function is called @code{list*} in some other Schemes and in Common LISP. @end deffn -@c docstring begin (texi-doc-string "guile" "list-copy") @deffn primitive list-copy lst Return a (newly-created) copy of @var{lst}. @end deffn @@ -3139,26 +3003,21 @@ These procedures are used to get some information about a list, or to retrieve one or more elements of a list. @rnindex length -@c docstring begin (texi-doc-string "guile" "length") @deffn primitive length lst Return the number of elements in list @var{lst}. @end deffn -@c docstring begin (texi-doc-string "guile" "last-pair") @deffn primitive last-pair lst Return a pointer to the last pair in @var{lst}, signalling an error if @var{lst} is circular. @end deffn @rnindex list-ref -@c docstring begin (texi-doc-string "guile" "list-ref") @deffn primitive list-ref list k Return the @var{k}th element from @var{list}. @end deffn @rnindex list-tail -@c docstring begin (texi-doc-string "guile" "list-tail") -@c docstring begin (texi-doc-string "guile" "list-cdr-ref") @deffn primitive list-tail lst k @deffnx primitive list-cdr-ref lst k Return the "tail" of @var{lst} beginning with its @var{k}th element. @@ -3169,7 +3028,6 @@ think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list, or returning the results of cdring @var{k} times down @var{lst}. @end deffn -@c docstring begin (texi-doc-string "guile" "list-head") @deffn primitive list-head lst k Copy the first @var{k} elements from @var{lst} into a new list, and return it. @@ -3187,7 +3045,6 @@ pairs. This is why you should be careful when using the side--effecting variants. @rnindex append -@c docstring begin (texi-doc-string "guile" "append") @deffn primitive append . args Return a list consisting of the elements the lists passed as arguments. @@ -3206,7 +3063,6 @@ if the last argument is not a proper list. @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "append!") @deffn primitive append! . lists A destructive version of @code{append} (@pxref{Pairs and Lists,,,r4rs, The Revised^4 Report on Scheme}). The cdr field @@ -3216,14 +3072,12 @@ the mutated list. @end deffn @rnindex reverse -@c docstring begin (texi-doc-string "guile" "reverse") @deffn primitive reverse lst Return a new list that contains the elements of @var{lst} but in reverse order. @end deffn @c NJFIXME explain new_tail -@c docstring begin (texi-doc-string "guile" "reverse!") @deffn primitive reverse! lst [new_tail] A destructive version of @code{reverse} (@pxref{Pairs and Lists,,,r4rs, The Revised^4 Report on Scheme}). The cdr of each cell in @var{lst} is @@ -3245,17 +3099,14 @@ The following procedures modify existing list. @code{list-set!} and @code{list-cdr-set!} change which elements a list contains, the various deletion procedures @code{delq}, @code{delv} etc. -@c docstring begin (texi-doc-string "guile" "list-set!") @deffn primitive list-set! list k val Set the @var{k}th element of @var{list} to @var{val}. @end deffn -@c docstring begin (texi-doc-string "guile" "list-cdr-set!") @deffn primitive list-cdr-set! list k val Set the @var{k}th cdr of @var{list} to @var{val}. @end deffn -@c docstring begin (texi-doc-string "guile" "delq") @deffn primitive delq item lst Return a newly-created copy of @var{lst} with elements @code{eq?} to @var{item} removed. This procedure mirrors @@ -3263,7 +3114,6 @@ Return a newly-created copy of @var{lst} with elements @var{item} with @code{eq?}. @end deffn -@c docstring begin (texi-doc-string "guile" "delv") @deffn primitive delv item lst Return a newly-created copy of @var{lst} with elements @code{eqv?} to @var{item} removed. This procedure mirrors @@ -3271,7 +3121,6 @@ Return a newly-created copy of @var{lst} with elements @var{item} with @code{eqv?}. @end deffn -@c docstring begin (texi-doc-string "guile" "delete") @deffn primitive delete item lst Return a newly-created copy of @var{lst} with elements @code{equal?} to @var{item} removed. This procedure mirrors @@ -3279,9 +3128,6 @@ Return a newly-created copy of @var{lst} with elements against @var{item} with @code{equal?}. @end deffn -@c docstring begin (texi-doc-string "guile" "delq!") -@c docstring begin (texi-doc-string "guile" "delv!") -@c docstring begin (texi-doc-string "guile" "delete!") @deffn primitive delq! item lst @deffnx primitive delv! item lst @deffnx primitive delete! item lst @@ -3293,21 +3139,18 @@ destructive list functions, these functions cannot modify the binding of @var{lst} destructively. @end deffn -@c docstring begin (texi-doc-string "guile" "delq1!") @deffn primitive delq1! item lst Like @code{delq!}, but only deletes the first occurrence of @var{item} from @var{lst}. Tests for equality using @code{eq?}. See also @code{delv1!} and @code{delete1!}. @end deffn -@c docstring begin (texi-doc-string "guile" "delv1!") @deffn primitive delv1! item lst Like @code{delv!}, but only deletes the first occurrence of @var{item} from @var{lst}. Tests for equality using @code{eqv?}. See also @code{delq1!} and @code{delete1!}. @end deffn -@c docstring begin (texi-doc-string "guile" "delete1!") @deffn primitive delete1! item lst Like @code{delete!}, but only deletes the first occurrence of @var{item} from @var{lst}. Tests for equality using @@ -3324,7 +3167,6 @@ they return the sublist whose car is equal to the search object, where equality depends on the equality predicate used. @rnindex memq -@c docstring begin (texi-doc-string "guile" "memq") @deffn primitive memq x lst Return the first sublist of @var{lst} whose car is @code{eq?} to @var{x} where the sublists of @var{lst} are the non-empty @@ -3335,7 +3177,6 @@ returned. @end deffn @rnindex memv -@c docstring begin (texi-doc-string "guile" "memv") @deffn primitive memv x lst Return the first sublist of @var{lst} whose car is @code{eqv?} to @var{x} where the sublists of @var{lst} are the non-empty @@ -3346,7 +3187,6 @@ returned. @end deffn @rnindex member -@c docstring begin (texi-doc-string "guile" "member") @deffn primitive member x lst Return the first sublist of @var{lst} whose car is @code{equal?} to @var{x} where the sublists of @var{lst} are @@ -3360,21 +3200,18 @@ empty list) is returned. high level at all? Maybe these docs should be relegated to a "Guile Internals" node or something. -twp] -@c docstring begin (texi-doc-string "guile" "sloppy-memq") @deffn primitive sloppy-memq x lst This procedure behaves like @code{memq}, but does no type or error checking. Its use is recommended only in writing Guile internals, not for high-level Scheme programs. @end deffn -@c docstring begin (texi-doc-string "guile" "sloppy-memv") @deffn primitive sloppy-memv x lst This procedure behaves like @code{memv}, but does no type or error checking. Its use is recommended only in writing Guile internals, not for high-level Scheme programs. @end deffn -@c docstring begin (texi-doc-string "guile" "sloppy-member") @deffn primitive sloppy-member x lst This procedure behaves like @code{member}, but does no type or error checking. Its use is recommended only in writing Guile internals, @@ -3393,7 +3230,6 @@ the result of the invocation is. @rnindex map @c begin (texi-doc-string "guile" "map") -@c docstring begin (texi-doc-string "guile" "map-in-order") @deffn primitive map proc arg1 arg2 @dots{} @deffnx primitive map-in-order proc arg1 arg2 @dots{} Apply @var{proc} to each element of the list @var{arg1} (if only two @@ -3661,7 +3497,6 @@ Structure layouts are represented by specially interned symbols whose name is a string of type and protection codes. To create a new structure layout, use this procedure: -@c docstring begin (texi-doc-string "guile" "make-struct-layout") @deffn primitive make-struct-layout fields Return a new structure layout object. @@ -3683,7 +3518,6 @@ indicate that the field is a tail-array. This section describes the basic procedures for creating and accessing structures. -@c docstring begin (texi-doc-string "guile" "make-struct") @deffn primitive make-struct vtable tail_array_size . init Create a new structure. @@ -3712,15 +3546,12 @@ more powerful. For more information, see the documentation for @code{make-vtable-vtable}. @end deffn -@c docstring begin (texi-doc-string "guile" "struct?") @deffn primitive struct? x Return @code{#t} iff @var{obj} is a structure object, else @code{#f}. @end deffn -@c docstring begin (texi-doc-string "guile" "struct-ref") -@c docstring begin (texi-doc-string "guile" "struct-set!") @deffn primitive struct-ref handle pos @deffnx primitive struct-set! struct n value Access (or modify) the @var{n}th field of @var{struct}. @@ -3744,12 +3575,10 @@ which are used only internally to libguile. The variable @code{vtable-offset-user} is bound to a field number. Vtable fields at that position or greater are user definable. -@c docstring begin (texi-doc-string "guile" "struct-vtable") @deffn primitive struct-vtable handle Return the vtable structure that describes the type of @var{struct}. @end deffn -@c docstring begin (texi-doc-string "guile" "struct-vtable?") @deffn primitive struct-vtable? x Return @code{#t} iff obj is a vtable structure. @end deffn @@ -3762,7 +3591,6 @@ created by using @code{(make-struct V' ...)}. Another possibility is that @code{V} is an instance of the type it itself describes. Vtable structures of the second sort are created by this procedure: -@c docstring begin (texi-doc-string "guile" "make-vtable-vtable") @deffn primitive make-vtable-vtable user_fields tail_array_size . init Return a new, self-describing vtable structure. @@ -3822,17 +3650,14 @@ ball @result{} # @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "struct-vtable-name") @deffn primitive struct-vtable-name vtable Return the name of the vtable @var{vtable}. @end deffn -@c docstring begin (texi-doc-string "guile" "set-struct-vtable-name!") @deffn primitive set-struct-vtable-name! vtable name Set the name of the vtable @var{vtable} to @var{name}. @end deffn -@c docstring begin (texi-doc-string "guile" "struct-vtable-tag") @deffn primitive struct-vtable-tag handle Return the vtable tag of the structure @var{handle}. @end deffn @@ -3891,7 +3716,6 @@ a vector: The following procedures can be used with conventional arrays (or vectors). -@c docstring begin (texi-doc-string "guile" "array?") @deffn primitive array? v [prot] Return @code{#t} if the @var{obj} is an array, and @code{#f} if not. The @var{prototype} argument is used with uniform arrays @@ -3906,29 +3730,23 @@ Creates and returns an array that has as many dimensions as there are @c array-ref's type is `compiled-closure'. There's some weird stuff @c going on in array.c, too. Let's call it a primitive. -twp -@c docstring begin (texi-doc-string "guile" "uniform-vector-ref") -@c docstring begin (texi-doc-string "guile" "array-ref") @deffn primitive uniform-vector-ref v args @deffnx primitive array-ref v . args Return the element at the @code{(index1, index2)} element in @var{array}. @end deffn -@c docstring begin (texi-doc-string "guile" "array-in-bounds?") @deffn primitive array-in-bounds? v . args Return @code{#t} if its arguments would be acceptable to @code{array-ref}. @end deffn -@c docstring begin (texi-doc-string "guile" "array-set!") -@c docstring begin (texi-doc-string "guile" "uniform-array-set1!") @deffn primitive array-set! v obj . args @deffnx primitive uniform-array-set1! v obj args Sets the element at the @code{(index1, index2)} element in @var{array} to @var{new-value}. The value returned by array-set! is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "make-shared-array") @deffn primitive make-shared-array oldra mapfunc . dims @code{make-shared-array} can be used to create shared subarrays of other arrays. The @var{mapper} is a function that translates coordinates in @@ -3947,22 +3765,18 @@ it can be otherwise arbitrary. A simple example: @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "shared-array-increments") @deffn primitive shared-array-increments ra For each dimension, return the distance between elements in the root vector. @end deffn -@c docstring begin (texi-doc-string "guile" "shared-array-offset") @deffn primitive shared-array-offset ra Return the root vector index of the first element in the array. @end deffn -@c docstring begin (texi-doc-string "guile" "shared-array-root") @deffn primitive shared-array-root ra Return the root vector of a shared array. @end deffn -@c docstring begin (texi-doc-string "guile" "transpose-array") @deffn primitive transpose-array ra . args Return an array sharing contents with @var{array}, but with dimensions arranged in a different order. There must be one @@ -3983,7 +3797,6 @@ have smaller rank than @var{array}. @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "enclose-array") @deffn primitive enclose-array ra . axes @var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than the rank of @var{array}. @var{enclose-array} returns an array @@ -4015,7 +3828,6 @@ Returns a list of inclusive bounds of integers. @end example @end deffn -@c docstring begin (texi-doc-string "guile" "array-dimensions") @deffn primitive array-dimensions ra @code{Array-dimensions} is similar to @code{array-shape} but replaces elements with a @code{0} minimum with one greater than the maximum. So: @@ -4024,20 +3836,16 @@ elements with a @code{0} minimum with one greater than the maximum. So: @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "array-rank") @deffn primitive array-rank ra Return the number of dimensions of @var{obj}. If @var{obj} is not an array, @code{0} is returned. @end deffn -@c docstring begin (texi-doc-string "guile" "array->list") @deffn primitive array->list v Return a list consisting of all the elements, in order, of @var{array}. @end deffn -@c docstring begin (texi-doc-string "guile" "array-copy!") -@c docstring begin (texi-doc-string "guile" "array-copy-in-order!") @deffn primitive array-copy! src dst @deffnx primitive array-copy-in-order! src dst Copies every element from vector or array @var{source} to the @@ -4046,7 +3854,6 @@ the same rank as @var{source}, and be at least as large in each dimension. The order is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "array-fill!") @deffn primitive array-fill! ra fill Stores @var{fill} in every element of @var{array}. The value returned is unspecified. @@ -4061,7 +3868,6 @@ same type, and have corresponding elements which are either @var{array-equal?} but not @var{equal?} to a vector or uniform vector. @end deffn -@c docstring begin (texi-doc-string "guile" "array-contents") @deffn primitive array-contents ra [strict] @deffnx primitive array-contents array strict If @var{array} may be @dfn{unrolled} into a one dimensional shared array @@ -4079,8 +3885,6 @@ memory. @node Array Mapping @subsection Array Mapping -@c docstring begin (texi-doc-string "guile" "array-map!") -@c docstring begin (texi-doc-string "guile" "array-map-in-order!") @deffn primitive array-map! ra0 proc . lra @deffnx primitive array-map-in-order! ra0 proc . lra @var{array1}, @dots{} must have the same number of dimensions as @@ -4091,13 +3895,11 @@ as the corresponding element in @var{array0}. The value returned is unspecified. The order of application is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "array-for-each") @deffn primitive array-for-each proc ra0 . lra @var{proc} is applied to each tuple of elements of @var{array0} @dots{} in row-major order. The value returned is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "array-index-map!") @deffn primitive array-index-map! ra proc applies @var{proc} to the indices of each element of @var{array} in turn, storing the result in the corresponding element. The value @@ -4175,7 +3977,6 @@ except that a single character from the above table is put between @code{#} and @code{(}. For example, a uniform vector of signed long integers is displayed in the form @code{'#e(3 5 9)}. -@c docstring begin (texi-doc-string "guile" "array?") @deffn primitive array? v [prot] Returns @code{#t} if the @var{obj} is an array, and @code{#f} if not. @@ -4189,14 +3990,12 @@ Creates and returns a uniform array of type corresponding to and fills it with @var{prototype}. @end deffn -@c docstring begin (texi-doc-string "guile" "array-prototype") @deffn primitive array-prototype ra Return an object that would produce an array of the same type as @var{array}, if used as the @var{prototype} for @code{make-uniform-array}. @end deffn -@c docstring begin (texi-doc-string "guile" "list->uniform-array") @deffn primitive list->uniform-array ndim prot lst @deffnx procedure list->uniform-vector prot lst Return a uniform array of the type indicated by prototype @@ -4210,12 +4009,10 @@ Stores @var{fill} in every element of @var{uve}. The value returned is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "uniform-vector-length") @deffn primitive uniform-vector-length v Return the number of elements in @var{uve}. @end deffn -@c docstring begin (texi-doc-string "guile" "dimensions->uniform-array") @deffn primitive dimensions->uniform-array dims prot [fill] @deffnx primitive make-uniform-vector length prototype [fill] Create and return a uniform array or vector of type @@ -4226,7 +4023,6 @@ fill the array, otherwise @var{prototype} is used. @c Another compiled-closure. -twp -@c docstring begin (texi-doc-string "guile" "uniform-array-read!") @deffn primitive uniform-array-read! ra [port_or_fd [start [end]]] @deffnx primitive uniform-vector-read! uve [port-or-fdes] [start] [end] Attempts to read all elements of @var{ura}, in lexicographic order, as @@ -4245,7 +4041,6 @@ leaving the remainder of the vector unchanged. returned by @code{(current-input-port)}. @end deffn -@c docstring begin (texi-doc-string "guile" "uniform-array-write") @deffn primitive uniform-array-write v [port_or_fd [start [end]]] @deffnx primitive uniform-vector-write uve [port-or-fdes] [start] [end] Writes all elements of @var{ura} as binary objects to @@ -4280,25 +4075,21 @@ They are displayed as a sequence of @code{0}s and #*101 @end example -@c docstring begin (texi-doc-string "guile" "bit-count") @deffn primitive bit-count b bitvector Return the number of occurrences of the boolean @var{b} in @var{bitvector}. @end deffn -@c docstring begin (texi-doc-string "guile" "bit-position") @deffn primitive bit-position item v k Return the minimum index of an occurrence of @var{bool} in @var{bv} which is at least @var{k}. If no @var{bool} occurs within the specified range @code{#f} is returned. @end deffn -@c docstring begin (texi-doc-string "guile" "bit-invert!") @deffn primitive bit-invert! v Modifies @var{bv} by replacing each element with its negation. @end deffn -@c docstring begin (texi-doc-string "guile" "bit-set*!") @deffn primitive bit-set*! v kv obj If uve is a bit-vector @var{bv} and uve must be of the same length. If @var{bool} is @code{#t}, uve is OR'ed into @@ -4311,7 +4102,6 @@ of @var{bv} corresponding to the indexes in uve are set to @var{bool}. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "bit-count*") @deffn primitive bit-count* v kv obj Return @lisp @@ -4538,7 +4328,6 @@ independent from the list that results from modification by use @code{list-copy} to copy the old association list before modifying it. -@c docstring begin (texi-doc-string "guile" "acons") @deffn primitive acons key value alist Adds a new key-value pair to @var{alist}. A new pair is created whose car is @var{key} and whose cdr is @var{value}, and the @@ -4546,9 +4335,6 @@ pair is consed onto @var{alist}, and the new list is returned. This function is @emph{not} destructive; @var{alist} is not modified. @end deffn -@c docstring begin (texi-doc-string "guile" "assq-set!") -@c docstring begin (texi-doc-string "guile" "assv-set!") -@c docstring begin (texi-doc-string "guile" "assoc-set!") @deffn primitive assq-set! alist key val @deffnx primitive assv-set! alist key value @deffnx primitive assoc-set! alist key value @@ -4574,9 +4360,6 @@ arguments and return the entry for that key if an entry exists, or where an entry exists, these procedures return the complete entry, that is @code{(KEY . VALUE)}, not just the value. -@c docstring begin (texi-doc-string "guile" "assq") -@c docstring begin (texi-doc-string "guile" "assv") -@c docstring begin (texi-doc-string "guile" "assoc") @deffn primitive assq key alist @deffnx primitive assv key alist @deffnx primitive assoc key alist @@ -4601,9 +4384,6 @@ Consequently, @code{assq-ref} and friends should only be used where it is known that an entry exists, or where the ambiguity doesn't matter for some other reason. -@c docstring begin (texi-doc-string "guile" "assq-ref") -@c docstring begin (texi-doc-string "guile" "assv-ref") -@c docstring begin (texi-doc-string "guile" "assoc-ref") @deffn primitive assq-ref alist key @deffnx primitive assv-ref alist key @deffnx primitive assoc-ref alist key @@ -4677,9 +4457,6 @@ two distinct entries to @code{address-list}. When compared using after removing the first matching entry that it finds, and so one of the "mary" entries is left in place. -@c docstring begin (texi-doc-string "guile" "assq-remove!") -@c docstring begin (texi-doc-string "guile" "assv-remove!") -@c docstring begin (texi-doc-string "guile" "assoc-remove!") @deffn primitive assq-remove! alist key @deffnx primitive assv-remove! alist key @deffnx primitive assoc-remove! alist key @@ -4732,19 +4509,16 @@ it is much safer to use the non-@code{sloppy-} procedures, because they help to highlight coding and data errors that the @code{sloppy-} versions would silently cover up. -@c docstring begin (texi-doc-string "guile" "sloppy-assq") @deffn primitive sloppy-assq key alist Behaves like @code{assq} but does not do any error checking. Recommended only for use in Guile internals. @end deffn -@c docstring begin (texi-doc-string "guile" "sloppy-assv") @deffn primitive sloppy-assv key alist Behaves like @code{assv} but does not do any error checking. Recommended only for use in Guile internals. @end deffn -@c docstring begin (texi-doc-string "guile" "sloppy-assoc") @deffn primitive sloppy-assoc key alist Behaves like @code{assoc} but does not do any error checking. Recommended only for use in Guile internals. @@ -4804,7 +4578,6 @@ 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. -@c docstring begin (texi-doc-string "guile" "hashq-ref") @deffn primitive 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, @@ -4812,7 +4585,6 @@ return @var{default} (or @code{#f} if no @var{default} argument is supplied). Uses @code{eq?} for equality testing. @end deffn -@c docstring begin (texi-doc-string "guile" "hashv-ref") @deffn primitive 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, @@ -4820,7 +4592,6 @@ return @var{default} (or @code{#f} if no @var{default} argument is supplied). Uses @code{eqv?} for equality testing. @end deffn -@c docstring begin (texi-doc-string "guile" "hash-ref") @deffn primitive 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, @@ -4828,38 +4599,32 @@ return @var{default} (or @code{#f} if no @var{default} argument is supplied). Uses @code{equal?} for equality testing. @end deffn -@c docstring begin (texi-doc-string "guile" "hashq-set!") @deffn primitive hashq-set! 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 -@c docstring begin (texi-doc-string "guile" "hashv-set!") @deffn primitive hashv-set! table key val Find the entry in @var{table} associated with @var{key}, and store @var{value} there. Uses @code{eqv?} for equality testing. @end deffn -@c docstring begin (texi-doc-string "guile" "hash-set!") @deffn primitive hash-set! 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 -@c docstring begin (texi-doc-string "guile" "hashq-remove!") @deffn primitive hashq-remove! table key Remove @var{key} (and any value associated with it) from @var{table}. Uses @code{eq?} for equality tests. @end deffn -@c docstring begin (texi-doc-string "guile" "hashv-remove!") @deffn primitive hashv-remove! table key Remove @var{key} (and any value associated with it) from @var{table}. Uses @code{eqv?} for equality tests. @end deffn -@c docstring begin (texi-doc-string "guile" "hash-remove!") @deffn primitive hash-remove! table key Remove @var{key} (and any value associated with it) from @var{table}. Uses @code{equal?} for equality tests. @@ -4880,7 +4645,6 @@ 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. -@c docstring begin (texi-doc-string "guile" "hashq") @deffn primitive hashq key size Determine a hash value for @var{key} that is suitable for lookups in a hashtable of size @var{size}, where @code{eq?} is @@ -4894,7 +4658,6 @@ in between. This can happen, for example with symbols: different values, since @code{foo} will be garbage collected. @end deffn -@c docstring begin (texi-doc-string "guile" "hashv") @deffn primitive hashv key size Determine a hash value for @var{key} that is suitable for lookups in a hashtable of size @var{size}, where @code{eqv?} is @@ -4908,7 +4671,6 @@ in between. This can happen, for example with symbols: different values, since @code{foo} will be garbage collected. @end deffn -@c docstring begin (texi-doc-string "guile" "hash") @deffn primitive hash key size Determine a hash value for @var{key} that is suitable for lookups in a hashtable of size @var{size}, where @code{equal?} @@ -4916,7 +4678,6 @@ is used as the equality predicate. The function returns an integer in the range 0 to @var{size} - 1. @end deffn -@c docstring begin (texi-doc-string "guile" "hashx-ref") @deffn primitive 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 @@ -4928,7 +4689,6 @@ By way of illustration, @code{hashq-ref table key} is equivalent to @code{hashx-ref hashq assq table key}. @end deffn -@c docstring begin (texi-doc-string "guile" "hashx-set!") @deffn primitive hashx-set! 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 @@ -4940,7 +4700,6 @@ that takes two arguments, a key to be hashed and a table size. equivalent to @code{hashx-set! hashq assq table key}. @end deffn -@c docstring begin (texi-doc-string "guile" "hashq-get-handle") @deffn primitive 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 @@ -4948,7 +4707,6 @@ associated value for @var{key}, @code{#f} is returned. Uses @code{eq?} for equality testing. @end deffn -@c docstring begin (texi-doc-string "guile" "hashv-get-handle") @deffn primitive 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 @@ -4956,7 +4714,6 @@ associated value for @var{key}, @code{#f} is returned. Uses @code{eqv?} for equality testing. @end deffn -@c docstring begin (texi-doc-string "guile" "hash-get-handle") @deffn primitive 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 @@ -4964,7 +4721,6 @@ associated value for @var{key}, @code{#f} is returned. Uses @code{equal?} for equality testing. @end deffn -@c docstring begin (texi-doc-string "guile" "hashx-get-handle") @deffn primitive 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 @@ -4974,28 +4730,24 @@ table size. @code{assoc} must be an associator function, like @code{assoc}, @code{assq} or @code{assv}. @end deffn -@c docstring begin (texi-doc-string "guile" "hashq-create-handle!") @deffn primitive hashq-create-handle! 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 -@c docstring begin (texi-doc-string "guile" "hashv-create-handle!") @deffn primitive hashv-create-handle! 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 -@c docstring begin (texi-doc-string "guile" "hash-create-handle!") @deffn primitive hash-create-handle! 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 -@c docstring begin (texi-doc-string "guile" "hashx-create-handle!") @deffn primitive hashx-create-handle! hash assoc table key init This behaves the same way as the corresponding @code{-create-handle} function, but uses @var{hash} as a hash @@ -5005,7 +4757,6 @@ table size. @code{assoc} must be an associator function, like @code{assoc}, @code{assq} or @code{assv}. @end deffn -@c docstring begin (texi-doc-string "guile" "hash-fold") @deffn primitive hash-fold proc init table An iterator over hash-table elements. Accumulates and returns a result by applying PROC successively. @@ -5057,7 +4808,6 @@ number in hexidecimal notation. @subsection Vector Predicates @rnindex vector? -@c docstring begin (texi-doc-string "guile" "vector?") @deffn primitive vector? obj Return @code{#t} if @var{obj} is a vector, otherwise return @code{#f}. @@ -5066,7 +4816,6 @@ Return @code{#t} if @var{obj} is a vector, otherwise return @subsection Vector Constructors @rnindex make-vector -@c docstring begin (texi-doc-string "guile" "make-vector") @deffn primitive make-vector k [fill] Return a newly allocated vector of @var{k} elements. If a second argument is given, then each element is initialized to @@ -5076,8 +4825,6 @@ unspecified. @rnindex vector @rnindex list->vector -@c docstring begin (texi-doc-string "guile" "vector") -@c docstring begin (texi-doc-string "guile" "list->vector") @deffn primitive vector . l @deffnx primitive list->vector l Return a newly allocated vector whose elements contain the @@ -5088,7 +4835,6 @@ given arguments. Analogous to @code{list}. @end deffn @rnindex vector->list -@c docstring begin (texi-doc-string "guile" "vector->list") @deffn primitive vector->list v Return a newly allocated list of the objects contained in the elements of @var{vector}. @@ -5121,18 +4867,15 @@ The value returned by @samp{vector-set!} is unspecified. @end deffn @rnindex vector-fill! -@c docstring begin (texi-doc-string "guile" "vector-fill!") @deffn primitive vector-fill! v fill Store @var{fill} in every element of @var{vector}. The value returned by @code{vector-fill!} is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "vector-move-left!") @deffn primitive vector-move-left! vec1 start1 end1 vec2 start2 Vector version of @code{substring-move-left!}. @end deffn -@c docstring begin (texi-doc-string "guile" "vector-move-right!") @deffn primitive vector-move-right! vec1 start1 end1 vec2 start2 Vector version of @code{substring-move-right!}. @end deffn @@ -5252,55 +4995,46 @@ are always called from first to last when they are invoked via When calling @code{hook->list}, the procedures in the resulting list are in the same order as they would have been called by @code{run-hook}. -@c docstring begin (texi-doc-string "guile" "make-hook-with-name") @deffn primitive make-hook-with-name name [n_args] Create a named hook with the name @var{name} for storing procedures of arity @var{n_args}. @var{n_args} defaults to zero. @end deffn -@c docstring begin (texi-doc-string "guile" "make-hook") @deffn primitive make-hook [n_args] Create a hook for storing procedure of arity @var{n_args}. @var{n_args} defaults to zero. @end deffn -@c docstring begin (texi-doc-string "guile" "hook?") @deffn primitive hook? x Return @code{#t} if @var{x} is a hook, @code{#f} otherwise. @end deffn -@c docstring begin (texi-doc-string "guile" "hook-empty?") @deffn primitive hook-empty? hook Return @code{#t} if @var{hook} is an empty hook, @code{#f} otherwise. @end deffn -@c docstring begin (texi-doc-string "guile" "add-hook!") @deffn primitive add-hook! hook proc [append_p] Add the procedure @var{proc} to the hook @var{hook}. The procedure is added to the end if @var{append_p} is true, otherwise it is added to the front. @end deffn -@c docstring begin (texi-doc-string "guile" "remove-hook!") @deffn primitive remove-hook! hook proc Remove the procedure @var{proc} from the hook @var{hook}. @end deffn -@c docstring begin (texi-doc-string "guile" "reset-hook!") @deffn primitive reset-hook! hook Remove all procedures from the hook @var{hook}. @end deffn -@c docstring begin (texi-doc-string "guile" "run-hook") @deffn primitive run-hook hook . args Apply all procedures from the hook @var{hook} to the arguments @var{args}. The order of the procedure application is first to last. @end deffn -@c docstring begin (texi-doc-string "guile" "hook->list") @deffn primitive hook->list hook Convert the procedure list of @var{hook} to a list. @end deffn diff --git a/doc/scheme-debug.texi b/doc/scheme-debug.texi index da7d599cf..d8876cba8 100644 --- a/doc/scheme-debug.texi +++ b/doc/scheme-debug.texi @@ -6,7 +6,6 @@ from the appendix describing the debugger UI. The intro should have a pointer to the UI appendix. -@c docstring begin (texi-doc-string "guile" "display-error") @deffn primitive display-error stack port subr message args rest Display an error message to the output port @var{port}. @var{stack} is the saved stack for the error, @var{subr} is @@ -17,14 +16,12 @@ the list @var{args} accordingly. @var{rest} is currently ignored. @end deffn -@c docstring begin (texi-doc-string "guile" "display-application") @deffn primitive display-application frame [port [indent]] Display a procedure application @var{frame} to the output port @var{port}. @var{indent} specifies the indentation of the output. @end deffn -@c docstring begin (texi-doc-string "guile" "display-backtrace") @deffn primitive display-backtrace stack port [first [depth]] Display a backtrace to the output port @var{port}. @var{stack} is the stack to take the backtrace from, @var{first} specifies @@ -33,13 +30,11 @@ to display. Both @var{first} and @var{depth} can be @code{#f}, which means that default values will be used. @end deffn -@c docstring begin (texi-doc-string "guile" "backtrace") @deffn primitive backtrace Display a backtrace of the stack saved by the last error to the current output port. @end deffn -@c docstring begin (texi-doc-string "guile" "malloc-stats") @deffn primitive malloc-stats Return an alist ((@var{what} . @var{n}) ...) describing number of malloced objects. @@ -48,119 +43,97 @@ of malloced objects. allocated. @end deffn -@c docstring begin (texi-doc-string "guile" "debug-options-interface") @deffn primitive debug-options-interface [setting] Option interface for the debug options. Instead of using this procedure directly, use the procedures @code{debug-enable}, @code{debug-disable}, @code{debug-set!} and @var{debug-options}. @end deffn -@c docstring begin (texi-doc-string "guile" "with-traps") @deffn primitive with-traps thunk Call @var{thunk} with traps enabled. @end deffn -@c docstring begin (texi-doc-string "guile" "memoized?") @deffn primitive memoized? obj Return @code{#t} if @var{obj} is memoized. @end deffn -@c docstring begin (texi-doc-string "guile" "unmemoize") @deffn primitive unmemoize m Unmemoize the memoized expression @var{m}, @end deffn -@c docstring begin (texi-doc-string "guile" "memoized-environment") @deffn primitive memoized-environment m Return the environment of the memoized expression @var{m}. @end deffn -@c docstring begin (texi-doc-string "guile" "procedure-name") @deffn primitive procedure-name proc Return the name of the procedure @var{proc} @end deffn -@c docstring begin (texi-doc-string "guile" "procedure-source") @deffn primitive procedure-source proc Return the source of the procedure @var{proc}. @end deffn -@c docstring begin (texi-doc-string "guile" "procedure-environment") @deffn primitive procedure-environment proc Return the environment of the procedure @var{proc}. @end deffn -@c docstring begin (texi-doc-string "guile" "debug-object?") @deffn primitive debug-object? obj Return @code{#t} if @var{obj} is a debug object. @end deffn -@c docstring begin (texi-doc-string "guile" "frame-arguments") @deffn primitive frame-arguments frame Return the arguments of @var{frame}. @end deffn -@c docstring begin (texi-doc-string "guile" "frame-evaluating-args?") @deffn primitive frame-evaluating-args? frame Return @code{#t} if @var{frame} contains evaluated arguments. @end deffn -@c docstring begin (texi-doc-string "guile" "frame-next") @deffn primitive frame-next frame Return the next frame of @var{frame}, or @code{#f} if @var{frame} is the last frame in its stack. @end deffn -@c docstring begin (texi-doc-string "guile" "frame-number") @deffn primitive frame-number frame Return the frame number of @var{frame}. @end deffn -@c docstring begin (texi-doc-string "guile" "frame-overflow?") @deffn primitive frame-overflow? frame Return @code{#t} if @var{frame} is an overflow frame. @end deffn -@c docstring begin (texi-doc-string "guile" "frame-previous") @deffn primitive frame-previous frame Return the previous frame of @var{frame}, or @code{#f} if @var{frame} is the first frame in its stack. @end deffn -@c docstring begin (texi-doc-string "guile" "frame-procedure") @deffn primitive frame-procedure frame Return the procedure for @var{frame}, or @code{#f} if no procedure is associated with @var{frame}. @end deffn -@c docstring begin (texi-doc-string "guile" "frame-procedure?") @deffn primitive frame-procedure? frame Return @code{#t} if a procedure is associated with @var{frame}. @end deffn -@c docstring begin (texi-doc-string "guile" "frame-real?") @deffn primitive frame-real? frame Return @code{#t} if @var{frame} is a real frame. @end deffn -@c docstring begin (texi-doc-string "guile" "frame-source") @deffn primitive frame-source frame Return the source of @var{frame}. @end deffn -@c docstring begin (texi-doc-string "guile" "frame?") @deffn primitive frame? obj Return @code{#t} if @var{obj} is a stack frame. @end deffn -@c docstring begin (texi-doc-string "guile" "last-stack-frame") @deffn primitive last-stack-frame obj Return a stack which consists of a single frame, which is the last stack frame for @var{obj}. @var{obj} must be either a debug object or a continuation. @end deffn -@c docstring begin (texi-doc-string "guile" "make-stack") @deffn primitive make-stack obj . args Create a new stack. If @var{obj} is @code{#t}, the current evaluation stack is used for creating the stack frames, @@ -170,22 +143,18 @@ either a debug object or a continuation). resulting stack will be narrowed. @end deffn -@c docstring begin (texi-doc-string "guile" "stack-id") @deffn primitive stack-id stack Return the identifier given to @var{stack} by @code{start-stack}. @end deffn -@c docstring begin (texi-doc-string "guile" "stack-length") @deffn primitive stack-length stack Return the length of @var{stack}. @end deffn -@c docstring begin (texi-doc-string "guile" "stack-ref") @deffn primitive stack-ref stack i Return the @var{i}'th frame from @var{stack}. @end deffn -@c docstring begin (texi-doc-string "guile" "stack?") @deffn primitive stack? obj Return @code{#t} if @var{obj} is a calling stack. @end deffn diff --git a/doc/scheme-evaluation.texi b/doc/scheme-evaluation.texi index 4472645a8..55079d5a2 100644 --- a/doc/scheme-evaluation.texi +++ b/doc/scheme-evaluation.texi @@ -52,7 +52,6 @@ loading and evaluating Scheme code at run time. @node Reader Extensions @subsection Reader Extensions -@c docstring begin (texi-doc-string "guile" "read-hash-extend") @deffn primitive read-hash-extend chr proc Install the procedure @var{proc} for reading expressions starting with the character sequence @code{#} and @var{chr}. @@ -66,7 +65,6 @@ returned will be the return value of @code{read}. @section Reading Scheme Code @rnindex read -@c docstring begin (texi-doc-string "guile" "read") @deffn primitive read [port] Read an s-expression from the input port @var{port}, or from the current input port if @var{port} is not specified. @@ -101,7 +99,6 @@ options and switches them on, @code{read-disable} switches them off. @code{read-set!} can be used to set an option to a specific value. @end deffn -@c docstring begin (texi-doc-string "guile" "read-options-interface") @deffn primitive read-options-interface [setting] Option interface for the read options. Instead of using this procedure directly, use the procedures @code{read-enable}, @@ -114,14 +111,12 @@ this procedure directly, use the procedures @code{read-enable}, @rnindex eval @c ARGFIXME environment/environment specifier -@c docstring begin (texi-doc-string "guile" "eval") @deffn primitive eval exp environment Evaluate @var{exp}, a list representing a Scheme expression, in the environment given by @var{environment specifier}. @end deffn @rnindex interaction-environment -@c docstring begin (texi-doc-string "guile" "interaction-environment") @deffn primitive interaction-environment Return a specifier for the environment that contains implementation--defined bindings, typically a superset of those @@ -130,7 +125,6 @@ return the environment in which the implementation would evaluate expressions dynamically typed by the user. @end deffn -@c docstring begin (texi-doc-string "guile" "eval-string") @deffn primitive eval-string string Evaluate @var{string} as the text representation of a Scheme form or forms, and return whatever value they produce. @@ -138,7 +132,6 @@ Evaluation takes place in the environment returned by the procedure @code{interaction-environment}. @end deffn -@c docstring begin (texi-doc-string "guile" "apply:nconc2last") @deffn primitive apply:nconc2last lst Given a list (@var{arg1} @dots{} @var{args}), this function conses the @var{arg1} @dots{} arguments onto the front of @@ -189,7 +182,6 @@ any code is loaded. See documentation for @code{%load-hook} later in this section. @end deffn -@c docstring begin (texi-doc-string "guile" "primitive-load") @deffn primitive primitive-load filename Load the file named @var{filename} and evaluate its contents in the top-level environment. The load paths are not searched; @@ -200,7 +192,6 @@ that will be called before any code is loaded. See the documentation for @code{%load-hook} later in this section. @end deffn -@c docstring begin (texi-doc-string "guile" "primitive-load-path") @deffn primitive primitive-load-path filename Search @var{%load-path} for the file named @var{filename} and load it into the top-level environment. If @var{filename} is a @@ -208,7 +199,6 @@ relative pathname and is not found in the list of search paths, an error is signalled. @end deffn -@c docstring begin (texi-doc-string "guile" "%search-load-path") @deffn primitive %search-load-path filename Search @var{%load-path} for the file named @var{filename}, which must be readable by the current user. If @var{filename} @@ -235,7 +225,6 @@ was passed to @code{primitive-load}. @end defvar -@c docstring begin (texi-doc-string "guile" "current-load-port") @deffn primitive current-load-port Return the current-load-port. The load port is used internally by @code{primitive-load}. @@ -254,14 +243,12 @@ list @code{("" ".scm")}. [delay] -@c docstring begin (texi-doc-string "guile" "promise?") @deffn primitive promise? obj Return true if @var{obj} is a promise, i.e. a delayed computation (@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}). @end deffn @rnindex force -@c docstring begin (texi-doc-string "guile" "force") @deffn primitive force x If the promise @var{x} has not been computed yet, compute and return @var{x}, otherwise just return the previously computed @@ -274,7 +261,6 @@ value. [the-environment] -@c docstring begin (texi-doc-string "guile" "local-eval") @deffn primitive local-eval exp [env] Evaluate @var{exp} in its environment. If @var{env} is supplied, it is the environment in which to evaluate @var{exp}. Otherwise, @@ -318,7 +304,6 @@ options and switches them on, @code{eval-disable} switches them off. @code{eval-set!} can be used to set an option to a specific value. @end deffn -@c docstring begin (texi-doc-string "guile" "eval-options-interface") @deffn primitive eval-options-interface [setting] Option interface for the evaluation options. Instead of using this procedure directly, use the procedures @code{eval-enable}, @@ -349,7 +334,6 @@ options and switches them on, @code{trap-disable} switches them off. @code{trap-set!} can be used to set an option to a specific value. @end deffn -@c docstring begin (texi-doc-string "guile" "evaluator-traps-interface") @deffn primitive evaluator-traps-interface [setting] Option interface for the evaluator trap options. @end deffn diff --git a/doc/scheme-io.texi b/doc/scheme-io.texi index 1a28badff..547ee9816 100644 --- a/doc/scheme-io.texi +++ b/doc/scheme-io.texi @@ -33,7 +33,6 @@ that simulate ports in software. @dfn{Soft ports} and @dfn{string ports} are two interesting and powerful examples of this technique. @rnindex input-port? -@c docstring begin (texi-doc-string "guile" "input-port?") @deffn primitive input-port? x Return @code{#t} if @var{x} is an input port, otherwise return @code{#f}. Any object satisfying this predicate also satisfies @@ -41,14 +40,12 @@ Return @code{#t} if @var{x} is an input port, otherwise return @end deffn @rnindex output-port? -@c docstring begin (texi-doc-string "guile" "output-port?") @deffn primitive output-port? x Return @code{#t} if @var{x} is an output port, otherwise return @code{#f}. Any object satisfying this predicate also satisfies @code{port?}. @end deffn -@c docstring begin (texi-doc-string "guile" "port?") @deffn primitive port? x Return a boolean indicating whether @var{x} is a port. Equivalent to @code{(or (input-port? @var{x}) (output-port? @@ -62,14 +59,12 @@ Equivalent to @code{(or (input-port? @var{x}) (output-port? [Generic procedures for reading from ports.] @rnindex eof-object? -@c docstring begin (texi-doc-string "guile" "eof-object?") @deffn primitive eof-object? x Return @code{#t} if @var{x} is an end-of-file object; otherwise return @code{#f}. @end deffn @rnindex char-ready? -@c docstring begin (texi-doc-string "guile" "char-ready?") @deffn primitive char-ready? [port] Return @code{#t} if a character is ready on input @var{port} and return @code{#f} otherwise. If @code{char-ready?} returns @@ -87,7 +82,6 @@ interactive port that has no ready characters.} @end deffn @rnindex read-char? -@c docstring begin (texi-doc-string "guile" "read-char") @deffn primitive read-char [port] Return the next character available from @var{port}, updating @var{port} to point to the following character. If no more @@ -95,7 +89,6 @@ characters are available, the end-of-file object is returned. @end deffn @rnindex peek-char? -@c docstring begin (texi-doc-string "guile" "peek-char") @deffn primitive peek-char [port] Return the next character available from @var{port}, @emph{without} updating @var{port} to point to the following @@ -111,7 +104,6 @@ an interactive port will hang waiting for input whenever a call to @code{read-char} would have hung.} @end deffn -@c docstring begin (texi-doc-string "guile" "unread-char") @deffn primitive unread-char cobj port Place @var{char} in @var{port} so that it will be read by the next read operation. If called multiple times, the unread characters @@ -119,7 +111,6 @@ will be read again in last-in first-out order. If @var{port} is not supplied, the current input port is used. @end deffn -@c docstring begin (texi-doc-string "guile" "unread-string") @deffn primitive unread-string str port Place the string @var{str} in @var{port} so that its characters will be read in subsequent read operations. If called multiple times, the @@ -127,14 +118,11 @@ unread characters will be read again in last-in first-out order. If @var{port} is not supplied, the current-input-port is used. @end deffn -@c docstring begin (texi-doc-string "guile" "drain-input") @deffn primitive drain-input port Drain @var{port}'s read buffers (including any pushed-back characters) and return the content as a single string. @end deffn -@c docstring begin (texi-doc-string "guile" "port-column") -@c docstring begin (texi-doc-string "guile" "port-line") @deffn primitive port-column port @deffnx primitive port-line port Return the current column number or line number of @var{port}, @@ -147,8 +135,6 @@ because lines and column numbers traditionally start with 1, and that is what non-programmers will find most natural.) @end deffn -@c docstring begin (texi-doc-string "guile" "set-port-column!") -@c docstring begin (texi-doc-string "guile" "set-port-line!") @deffn primitive set-port-column! port column @deffnx primitive set-port-line! port line Set the current column or line number of @var{port}, using the @@ -195,25 +181,21 @@ end-of-file check [Generic procedures for writing to ports.] -@c docstring begin (texi-doc-string "guile" "get-print-state") @deffn primitive get-print-state port Return the print state of the port @var{port}. If @var{port} has no associated print state, @code{#f} is returned. @end deffn @rnindex newline -@c docstring begin (texi-doc-string "guile" "newline") @deffn primitive newline [port] Send a newline to @var{port}. @end deffn -@c docstring begin (texi-doc-string "guile" "port-with-print-state") @deffn primitive port-with-print-state port pstate Create a new port which behaves like @var{port}, but with an included print state @var{pstate}. @end deffn -@c docstring begin (texi-doc-string "guile" "print-options-interface") @deffn primitive print-options-interface [setting] Option interface for the print options. Instead of using this procedure directly, use the procedures @@ -221,7 +203,6 @@ this procedure directly, use the procedures and @code{print-options}. @end deffn -@c docstring begin (texi-doc-string "guile" "simple-format") @deffn primitive simple-format destination message . args Write @var{message} to @var{destination}, defaulting to the current output port. @@ -237,13 +218,11 @@ containing the formatted text. Does not add a trailing newline. @end deffn @rnindex write-char -@c docstring begin (texi-doc-string "guile" "write-char") @deffn primitive write-char chr [port] Send character @var{chr} to @var{port}. @end deffn @findex fflush -@c docstring begin (texi-doc-string "guile" "force-output") @deffn primitive force-output [port] Flush the specified output port, or the current output port if @var{port} is omitted. The current output buffer contents are passed to the @@ -254,7 +233,6 @@ It has no effect on an unbuffered port. The return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "flush-all-ports") @deffn primitive flush-all-ports Equivalent to calling @code{force-output} on all open output ports. The return value is unspecified. @@ -264,7 +242,6 @@ all open output ports. The return value is unspecified. @node Closing @section Closing -@c docstring begin (texi-doc-string "guile" "close-port") @deffn primitive close-port port Close the specified port object. Return @code{#t} if it successfully closes a port or @code{#f} if it was already @@ -275,7 +252,6 @@ descriptors. @end deffn @rnindex close-input-port -@c docstring begin (texi-doc-string "guile" "close-input-port") @deffn primitive close-input-port port Close the specified input port object. The routine has no effect if the file has already been closed. An exception may be raised if an @@ -286,7 +262,6 @@ which can close file descriptors. @end deffn @rnindex close-output-port -@c docstring begin (texi-doc-string "guile" "close-output-port") @deffn primitive close-output-port port Close the specified output port object. The routine has no effect if the file has already been closed. An exception may be raised if an @@ -296,7 +271,6 @@ See also @ref{Ports and File Descriptors, close}, for a procedure which can close file descriptors. @end deffn -@c docstring begin (texi-doc-string "guile" "port-closed?") @deffn primitive port-closed? port Return @code{#t} if @var{port} is closed or @code{#f} if it is open. @@ -306,7 +280,6 @@ open. @node Random Access @section Random Access -@c docstring begin (texi-doc-string "guile" "seek") @deffn primitive seek fd_port offset whence Sets the current position of @var{fd/port} to the integer @var{offset}, which is interpreted according to the value of @@ -331,13 +304,11 @@ that the current position of a port can be obtained using: @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "fseek") @deffn primitive fseek fd_port offset whence Obsolete. Almost the same as @code{seek}, but the return value is unspecified. @end deffn -@c docstring begin (texi-doc-string "guile" "ftell") @deffn primitive ftell fd_port Return an integer representing the current position of @var{fd/port}, measured from the beginning. Equivalent to: @@ -348,7 +319,6 @@ Return an integer representing the current position of @findex truncate @findex ftruncate -@c docstring begin (texi-doc-string "guile" "truncate-file") @deffn primitive truncate-file object [length] Truncates the object referred to by @var{object} to at most @var{length} bytes. @var{object} can be a string containing a @@ -435,7 +405,6 @@ NOTE: if the scsh module is loaded then @var{delims} must be an scsh char-set, not a string. @end deffn -@c docstring begin (texi-doc-string "guile" "write-line") @deffn primitive write-line obj [port] Display @var{obj} and a newline character to @var{port}. If @var{port} is not specified, @code{(current-output-port)} is @@ -450,7 +419,6 @@ Some of the abovementioned I/O functions rely on the following C primitives. These will mainly be of interest to people hacking Guile internals. -@c docstring begin (texi-doc-string "guile" "%read-delimited!") @deffn primitive %read-delimited! delims str gobble [port [start [end]]] Read characters from @var{port} into @var{str} until one of the characters in the @var{delims} string is encountered. If @@ -468,7 +436,6 @@ at the end of file, the delimiter returned is the a delimiter, this value is @code{#f}. @end deffn -@c docstring begin (texi-doc-string "guile" "%read-line") @deffn primitive %read-line [port] Read a newline-terminated line from @var{port}, allocating storage as necessary. The newline terminator (if any) is removed from the string, @@ -496,7 +463,6 @@ If omitted, @var{port} defaults to the current output port. @section Default Ports for Input, Output and Errors @rnindex current-input-port -@c docstring begin (texi-doc-string "guile" "current-input-port") @deffn primitive current-input-port Return the current input port. This is the default port used by many input procedures. Initially, @code{current-input-port} @@ -504,7 +470,6 @@ returns the @dfn{standard input} in Unix and C terminology. @end deffn @rnindex current-output-port -@c docstring begin (texi-doc-string "guile" "current-output-port") @deffn primitive current-output-port Return the current output port. This is the default port used by many output procedures. Initially, @@ -512,13 +477,11 @@ by many output procedures. Initially, Unix and C terminology. @end deffn -@c docstring begin (texi-doc-string "guile" "current-error-port") @deffn primitive current-error-port Return the port to which errors and warnings should be sent (the @dfn{standard error} in Unix and C terminology). @end deffn -@c docstring begin (texi-doc-string "guile" "set-current-input-port") @deffn primitive set-current-input-port port @deffnx primitive set-current-output-port port @deffnx primitive set-current-error-port port @@ -527,12 +490,10 @@ Change the ports returned by @code{current-input-port}, so that they use the supplied @var{port} for input or output. @end deffn -@c docstring begin (texi-doc-string "guile" "set-current-output-port") @deffn primitive set-current-output-port port Set the current default output port to PORT. @end deffn -@c docstring begin (texi-doc-string "guile" "set-current-error-port") @deffn primitive set-current-error-port port Set the current default error port to PORT. @end deffn @@ -558,7 +519,6 @@ The following procedures are used to open file ports. See also @ref{Ports and File Descriptors, open}, for an interface to the Unix @code{open} system call. -@c docstring begin (texi-doc-string "guile" "open-file") @deffn primitive open-file filename mode Open the file whose name is @var{filename}, and return a port representing that file. The attributes of the port are @@ -686,7 +646,6 @@ from the continuation of these procedures, their behavior is implementation dependent. @end deffn -@c docstring begin (texi-doc-string "guile" "port-mode") @deffn primitive port-mode port Returns the port modes associated with the open port @var{port}. These will not necessarily be identical to the modes used when the port was @@ -694,14 +653,12 @@ opened, since modes such as "append" which are used only during port creation are not retained. @end deffn -@c docstring begin (texi-doc-string "guile" "port-filename") @deffn primitive port-filename port Return the filename associated with @var{port}. This function returns the strings "standard input", "standard output" and "standard error" when called on the current input, output and error ports respectively. @end deffn -@c docstring begin (texi-doc-string "guile" "set-port-filename!") @deffn primitive set-port-filename! port filename Change the filename associated with @var{port}, using the current input port if none is specified. Note that this does not change the port's @@ -720,14 +677,12 @@ Determine whether @var{obj} is a port that is related to a file. The following allow string ports to be opened by analogy to R4R* file port facilities: -@c docstring begin (texi-doc-string "guile" "call-with-output-string") @deffn primitive call-with-output-string proc Calls the one-argument procedure @var{proc} with a newly created output port. When the function returns, the string composed of the characters written into the port is returned. @end deffn -@c docstring begin (texi-doc-string "guile" "call-with-input-string") @deffn primitive call-with-input-string string proc Calls the one-argument procedure @var{proc} with a newly created input port from which @var{string}'s contents may be @@ -748,7 +703,6 @@ port set temporarily to a string port opened on the specified @var{string}. The value yielded by @var{thunk} is returned. @end deffn -@c docstring begin (texi-doc-string "guile" "open-input-string") @deffn primitive open-input-string str Take a string and return an input port that delivers characters from the string. The port can be closed by @@ -756,7 +710,6 @@ from the string. The port can be closed by by the garbage collector if it becomes inaccessible. @end deffn -@c docstring begin (texi-doc-string "guile" "open-output-string") @deffn primitive open-output-string Return an output port that will accumulate characters for retrieval by @code{get-output-string}. The port can be closed @@ -765,7 +718,6 @@ will be reclaimed by the garbage collector if it becomes inaccessible. @end deffn -@c docstring begin (texi-doc-string "guile" "get-output-string") @deffn primitive get-output-string port Given an output port created by @code{open-output-string}, return a string consisting of the characters that have been @@ -784,7 +736,6 @@ but trying to extract the file descriptor number will fail. A @dfn{soft-port} is a port based on a vector of procedures capable of accepting or delivering characters. It allows emulation of I/O ports. -@c docstring begin (texi-doc-string "guile" "make-soft-port") @deffn primitive make-soft-port pv modes Return a port capable of receiving or delivering characters as specified by the @var{modes} string (@pxref{File Ports, @@ -831,7 +782,6 @@ For example: This kind of port causes any data to be discarded when written to, and always returns the end-of-file object when read from. -@c docstring begin (texi-doc-string "guile" "%make-void-port") @deffn primitive %make-void-port mode Create and return a new void port. A void port acts like /dev/null. The @var{mode} argument diff --git a/doc/scheme-memory.texi b/doc/scheme-memory.texi index 71b3f23e4..196ba5318 100644 --- a/doc/scheme-memory.texi +++ b/doc/scheme-memory.texi @@ -15,25 +15,21 @@ [FIXME: this is pasted in from Tom Lord's original guile.texi and should be reviewed] -@c docstring begin (texi-doc-string "guile" "gc") @deffn primitive gc Scans all of SCM objects and reclaims for further use those that are no longer accessible. @end deffn -@c docstring begin (texi-doc-string "guile" "gc-stats") @deffn primitive gc-stats Return an association list of statistics about Guile's current use of storage. @end deffn -@c docstring begin (texi-doc-string "guile" "object-address") @deffn primitive object-address obj Return an integer that for the lifetime of @var{obj} is uniquely returned by this function for @var{obj} @end deffn -@c docstring begin (texi-doc-string "guile" "unhash-name") @deffn primitive unhash-name name Flushes the glocs for @var{name}, or all glocs if @var{name} is @code{#t}. @@ -88,7 +84,6 @@ they constitute a doubly-weak table has to be used. @node Weak key hashes @subsection Weak key hashes -@c docstring begin (texi-doc-string "guile" "make-weak-key-hash-table") @deffn primitive make-weak-key-hash-table size @deffnx primitive make-weak-value-hash-table size @deffnx primitive make-doubly-weak-hash-table size @@ -99,7 +94,6 @@ You can modify weak hash tables in exactly the same way you would modify regular hash tables. (@pxref{Hash Tables}) @end deffn -@c docstring begin (texi-doc-string "guile" "weak-key-hash-table?") @deffn primitive weak-key-hash-table? obj @deffnx primitive weak-value-hash-table? obj @deffnx primitive doubly-weak-hash-table? obj @@ -108,19 +102,15 @@ table. Note that a doubly weak hash table is neither a weak key nor a weak value hash table. @end deffn -@c docstring begin (texi-doc-string "guile" "make-weak-value-hash-table") @deffn primitive make-weak-value-hash-table k @end deffn -@c docstring begin (texi-doc-string "guile" "weak-value-hash-table?") @deffn primitive weak-value-hash-table? x @end deffn -@c docstring begin (texi-doc-string "guile" "make-doubly-weak-hash-table") @deffn primitive make-doubly-weak-hash-table k @end deffn -@c docstring begin (texi-doc-string "guile" "doubly-weak-hash-table?") @deffn primitive doubly-weak-hash-table? x @end deffn @@ -131,7 +121,6 @@ nor a weak value hash table. Weak vectors are mainly useful in Guile's implementation of weak hash tables. -@c docstring begin (texi-doc-string "guile" "make-weak-vector") @deffn primitive make-weak-vector size [fill] Return a weak vector with @var{size} elements. If the optional argument @var{fill} is given, all entries in the vector will be @@ -139,8 +128,6 @@ set to @var{fill}. The default value for @var{fill} is the empty list. @end deffn -@c docstring begin (texi-doc-string "guile" "weak-vector") -@c docstring begin (texi-doc-string "guile" "list->weak-vector") @deffn primitive weak-vector . l @deffnx primitive list->weak-vector l Construct a weak vector from a list: @code{weak-vector} uses @@ -149,7 +136,6 @@ its only argument @var{l} (a list) to construct a weak vector the same way @code{list->vector} would. @end deffn -@c docstring begin (texi-doc-string "guile" "weak-vector?") @deffn primitive weak-vector? obj Return @code{#t} if @var{obj} is a weak vector. Note that all weak hashes are also weak vectors. @@ -159,7 +145,6 @@ weak hashes are also weak vectors. @node Guardians @section Guardians -@c docstring begin (texi-doc-string "guile" "make-guardian") @deffn primitive make-guardian [greedy?] Create a new guardian. A guardian protects a set of objects from garbage collection, @@ -207,29 +192,24 @@ Return @code{#t} if @var{guardian} has been destroyed, otherwise @code{#f}. @node Objects @chapter Objects -@c docstring begin (texi-doc-string "guile" "entity?") @deffn primitive entity? obj Return @code{#t} if @var{obj} is an entity. @end deffn -@c docstring begin (texi-doc-string "guile" "operator?") @deffn primitive operator? obj Return @code{#t} if @var{obj} is an operator. @end deffn -@c docstring begin (texi-doc-string "guile" "set-object-procedure!") @deffn primitive set-object-procedure! obj proc Return the object procedure of @var{obj} to @var{proc}. @var{obj} must be either an entity or an operator. @end deffn -@c docstring begin (texi-doc-string "guile" "make-class-object") @deffn primitive make-class-object metaclass layout Create a new class object of class @var{metaclass}, with the slot layout specified by @var{layout}. @end deffn -@c docstring begin (texi-doc-string "guile" "make-subclass-object") @deffn primitive make-subclass-object class layout Create a subclass object of @var{class}, with the slot layout specified by @var{layout}. diff --git a/doc/scheme-modules.texi b/doc/scheme-modules.texi index 3a2374329..a02229bfb 100644 --- a/doc/scheme-modules.texi +++ b/doc/scheme-modules.texi @@ -132,7 +132,6 @@ space use, and demonstrate how one would do Python's "from Tkinter import *" versus "import Tkinter". Must also add something about paths and standards for contributed modules.] -@c docstring begin (texi-doc-string "guile" "standard-eval-closure") @deffn primitive standard-eval-closure module Return an eval closure for the module @var{module}. @end deffn @@ -182,7 +181,6 @@ written properly. Guile's dynamic linking functions make it relatively easy to write a module that incorporates code from third-party object code libraries. -@c docstring begin (texi-doc-string "guile" "dynamic-link") @deffn primitive dynamic-link filename Open the dynamic library called @var{filename}. A library handle representing the opened library is returned; this handle @@ -190,13 +188,11 @@ should be used as the @var{dobj} argument to the following functions. @end deffn -@c docstring begin (texi-doc-string "guile" "dynamic-object?") @deffn primitive dynamic-object? obj Return @code{#t} if @var{obj} is a dynamic library handle, or @code{#f} otherwise. @end deffn -@c docstring begin (texi-doc-string "guile" "dynamic-unlink") @deffn primitive dynamic-unlink dobj Unlink the indicated object file from the application. The argument @var{dobj} must have been obtained by a call to @@ -204,7 +200,6 @@ argument @var{dobj} must have been obtained by a call to called on @var{dobj}, its content is no longer accessible. @end deffn -@c docstring begin (texi-doc-string "guile" "dynamic-func") @deffn primitive dynamic-func name dobj Search the dynamic object @var{dobj} for the C function indicated by the string @var{name} and return some Scheme @@ -217,7 +212,6 @@ underscore in @var{function}. Guile knows whether the underscore is needed or not and will add it when necessary. @end deffn -@c docstring begin (texi-doc-string "guile" "dynamic-call") @deffn primitive dynamic-call func dobj Call the C function indicated by @var{func} and @var{dobj}. The function is passed no arguments and its return value is @@ -233,7 +227,6 @@ Interrupts are deferred while the C function is executing (with @code{SCM_DEFER_INTS}/@code{SCM_ALLOW_INTS}). @end deffn -@c docstring begin (texi-doc-string "guile" "dynamic-args-call") @deffn primitive dynamic-args-call func dobj args Call the C function indicated by @var{func} and @var{dobj}, just like @code{dynamic-call}, but pass it some arguments and @@ -250,7 +243,6 @@ converted to a Scheme number and returned from the call to @code{dynamic-args-call}. @end deffn -@c docstring begin (texi-doc-string "guile" "c-registered-modules") @deffn primitive c-registered-modules Return a list of the object code modules that have been imported into the current Guile process. Each element of the list is a pair whose @@ -259,7 +251,6 @@ for that module's initializer function. The name is the string that has been passed to scm_register_module_xxx. @end deffn -@c docstring begin (texi-doc-string "guile" "c-clear-registered-modules") @deffn primitive c-clear-registered-modules Destroy the list of modules registered with the current Guile process. The return value is unspecified. @strong{Warning:} this function does diff --git a/doc/scheme-options.texi b/doc/scheme-options.texi index 439b8c452..472f4807c 100644 --- a/doc/scheme-options.texi +++ b/doc/scheme-options.texi @@ -275,9 +275,6 @@ It is often useful to have site-specific information about the current Guile installation. This chapter describes how to find out about Guile's configuration at run time. -@c docstring begin (texi-doc-string "guile" "version") -@c docstring begin (texi-doc-string "guile" "major-version") -@c docstring begin (texi-doc-string "guile" "minor-version") @deffn primitive version @deffnx primitive major-version @deffnx primitive minor-version @@ -299,26 +296,22 @@ interpreter and the ice-9 runtime have grown out of date with one another. @end deffn -@c docstring begin (texi-doc-string "guile" "%package-data-dir") @deffn primitive %package-data-dir Return the name of the directory where Scheme packages, modules and libraries are kept. On most Unix systems, this will be @samp{/usr/local/share/guile}. @end deffn -@c docstring begin (texi-doc-string "guile" "%library-dir") @deffn primitive %library-dir Return the directory where the Guile Scheme library files are installed. E.g., may return "/usr/share/guile/1.3.5". @end deffn -@c docstring begin (texi-doc-string "guile" "%site-dir") @deffn primitive %site-dir Return the directory where the Guile site files are installed. E.g., may return "/usr/share/guile/site". @end deffn -@c docstring begin (texi-doc-string "guile" "parse-path") @deffn primitive parse-path path [tail] Parse @var{path}, which is expected to be a colon-separated string, into a list and return the resulting list with @@ -326,7 +319,6 @@ string, into a list and return the resulting list with is returned. @end deffn -@c docstring begin (texi-doc-string "guile" "search-path") @deffn primitive search-path path filename [extensions] Search @var{path} for a directory containing a file named @var{filename}. The file must be readable, and not a directory. diff --git a/doc/scheme-procedures.texi b/doc/scheme-procedures.texi index e1cf83e1a..cbb405fde 100644 --- a/doc/scheme-procedures.texi +++ b/doc/scheme-procedures.texi @@ -22,28 +22,23 @@ @node Procedure Properties @section Procedure Properties and Metainformation -@c docstring begin (texi-doc-string "guile" "procedure-properties") @deffn primitive procedure-properties proc Return @var{obj}'s property list. @end deffn -@c docstring begin (texi-doc-string "guile" "procedure-property") @deffn primitive procedure-property p k Return the property of @var{obj} with name @var{key}. @end deffn -@c docstring begin (texi-doc-string "guile" "set-procedure-properties!") @deffn primitive set-procedure-properties! proc new_val Set @var{obj}'s property list to @var{alist}. @end deffn -@c docstring begin (texi-doc-string "guile" "set-procedure-property!") @deffn primitive set-procedure-property! p k v In @var{obj}'s property list, set the property named @var{key} to @var{value}. @end deffn -@c docstring begin (texi-doc-string "guile" "procedure-documentation") @deffn primitive procedure-documentation proc Return the documentation string associated with @code{proc}. By convention, if a procedure contains more than one expression and the @@ -51,40 +46,33 @@ first expression is a string constant, that string is assumed to contain documentation for that procedure. @end deffn -@c docstring begin (texi-doc-string "guile" "closure?") @deffn primitive closure? obj Return @code{#t} if @var{obj} is a closure. @end deffn @rnindex procedure? -@c docstring begin (texi-doc-string "guile" "procedure?") @deffn primitive procedure? obj Return @code{#t} if @var{obj} is a procedure. @end deffn -@c docstring begin (texi-doc-string "guile" "thunk?") @deffn primitive thunk? obj Return @code{#t} if @var{obj} is a thunk. @end deffn -@c docstring begin (texi-doc-string "guile" "set-source-properties!") @deffn primitive set-source-properties! obj plist Install the association list @var{plist} as the source property list for @var{obj}. @end deffn -@c docstring begin (texi-doc-string "guile" "set-source-property!") @deffn primitive set-source-property! obj key datum Set the source property of object @var{obj}, which is specified by @var{key} to @var{datum}. Normally, the key will be a symbol. @end deffn -@c docstring begin (texi-doc-string "guile" "source-properties") @deffn primitive source-properties obj Return the source property association list of @var{obj}. @end deffn -@c docstring begin (texi-doc-string "guile" "source-property") @deffn primitive source-property obj key Return the source property specified by @var{key} from @@ -95,25 +83,21 @@ Return the source property specified by @var{key} from @node Procedures with Setters @section Procedures with Setters -@c docstring begin (texi-doc-string "guile" "make-procedure-with-setter") @deffn primitive make-procedure-with-setter procedure setter Create a new procedure which behaves like @var{procedure}, but with the associated setter @var{setter}. @end deffn -@c docstring begin (texi-doc-string "guile" "procedure-with-setter?") @deffn primitive procedure-with-setter? obj Return @code{#t} if @var{obj} is a procedure with an associated setter procedure. @end deffn -@c docstring begin (texi-doc-string "guile" "procedure") @deffn primitive procedure proc Return the procedure of @var{proc}, which must be either a procedure with setter, or an operator struct. @end deffn -@c docstring begin (texi-doc-string "guile" "setter") @deffn primitive setter proc @end deffn @@ -126,7 +110,6 @@ macros and memoizing macros. Also, any definitions listed here should be double-checked by someone who knows what's going on. Ask Mikael, Jim or Aubrey for help. -twp] -@c docstring begin (texi-doc-string "guile" "procedure->syntax") @deffn primitive procedure->syntax code Return a @dfn{macro} which, when a symbol defined to this value appears as the first symbol in an expression, returns the @@ -134,7 +117,6 @@ result of applying @var{code} to the expression and the environment. @end deffn -@c docstring begin (texi-doc-string "guile" "procedure->macro") @deffn primitive procedure->macro code Return a @dfn{macro} which, when a symbol defined to this value appears as the first symbol in an expression, evaluates the @@ -151,7 +133,6 @@ passed to @var{code}. For example: @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "procedure->memoizing-macro") @deffn primitive procedure->memoizing-macro code Return a @dfn{macro} which, when a symbol defined to this value appears as the first symbol in an expression, evaluates the @@ -168,13 +149,11 @@ passed to @var{proc}. For example: @end lisp @end deffn -@c docstring begin (texi-doc-string "guile" "macro?") @deffn primitive macro? obj Return @code{#t} if @var{obj} is a regular macro, a memoizing macro or a syntax transformer. @end deffn -@c docstring begin (texi-doc-string "guile" "macro-type") @deffn primitive macro-type m Return one of the symbols @code{syntax}, @code{macro} or @code{macro!}, depending on whether @var{m} is a syntax @@ -183,17 +162,14 @@ respectively. If @var{m} is not a macro, @code{#f} is returned. @end deffn -@c docstring begin (texi-doc-string "guile" "macro-name") @deffn primitive macro-name m Return the name of the macro @var{m}. @end deffn -@c docstring begin (texi-doc-string "guile" "macro-transformer") @deffn primitive macro-transformer m Return the transformer of the macro @var{m}. @end deffn -@c docstring begin (texi-doc-string "guile" "cons-source") @deffn primitive cons-source xorig x y Create and return a new pair whose car and cdr are @var{x} and @var{y}. Any source properties associated with @var{xorig} are also associated diff --git a/doc/scheme-scheduling.texi b/doc/scheme-scheduling.texi index 4b717faf9..bddb17dde 100644 --- a/doc/scheme-scheduling.texi +++ b/doc/scheme-scheduling.texi @@ -18,20 +18,17 @@ reviewed and largely reorganized.] @node Arbiters @section Arbiters -@c docstring begin (texi-doc-string "guile" "make-arbiter") @deffn primitive make-arbiter name Return an object of type arbiter and name @var{name}. Its state is initially unlocked. Arbiters are a way to achieve process synchronization. @end deffn -@c docstring begin (texi-doc-string "guile" "try-arbiter") @deffn primitive try-arbiter arb Return @code{#t} and lock the arbiter @var{arb} if the arbiter was unlocked. Otherwise, return @code{#f}. @end deffn -@c docstring begin (texi-doc-string "guile" "release-arbiter") @deffn primitive release-arbiter arb Return @code{#t} and unlock the arbiter @var{arb} if the arbiter was locked. Otherwise, return @code{#f}. @@ -41,44 +38,36 @@ arbiter was locked. Otherwise, return @code{#f}. @node Asyncs @section Asyncs -@c docstring begin (texi-doc-string "guile" "async") @deffn primitive async thunk Create a new async for the procedure @var{thunk}. @end deffn -@c docstring begin (texi-doc-string "guile" "system-async") @deffn primitive system-async thunk Create a new async for the procedure @var{thunk}. Also add it to the system's list of active async objects. @end deffn -@c docstring begin (texi-doc-string "guile" "async-mark") @deffn primitive async-mark a Mark the async @var{a} for future execution. @end deffn -@c docstring begin (texi-doc-string "guile" "system-async-mark") @deffn primitive system-async-mark a Mark the async @var{a} for future execution. @end deffn -@c docstring begin (texi-doc-string "guile" "run-asyncs") @deffn primitive run-asyncs list_of_a Execute all thunks from the asyncs of the list @var{list_of_a}. @end deffn -@c docstring begin (texi-doc-string "guile" "noop") @deffn primitive noop . args Do nothing. When called without arguments, return @code{#f}, otherwise return the first argument. @end deffn -@c docstring begin (texi-doc-string "guile" "unmask-signals") @deffn primitive unmask-signals Unmask signals. The returned value is not specified. @end deffn -@c docstring begin (texi-doc-string "guile" "mask-signals") @deffn primitive mask-signals Mask signals. The returned value is not specified. @end deffn @@ -104,7 +93,6 @@ dynamic root. For example, if you want to apply a procedure, but to not allow that procedure to capture the current continuation, calling the procedure under a new dynamic root will do the job. -@c docstring begin (texi-doc-string "guile" "call-with-dynamic-root") @deffn primitive call-with-dynamic-root thunk handler Evaluate @code{(thunk)} in a new dynamic context, returning its value. @@ -151,7 +139,6 @@ be under a new dynamic root.) @end deffn -@c docstring begin (texi-doc-string "guile" "dynamic-root") @deffn primitive dynamic-root Return an object representing the current dynamic root. @@ -293,7 +280,6 @@ Higher level thread procedures are available by loading the @code{(ice-9 threads)} module. These provide standardized thread creation and mutex interaction. -@c docstring begin (texi-doc-string "guile" "%thread-handler") @deffn primitive %thread-handler tag args@dots{} This procedure is specified as the standard error-handler for @@ -308,27 +294,23 @@ and signals are unmasked with @code{unmask-signals}. [FIXME: Why distinguish based on number of args?! Cue voodoo music here.] @end deffn -@c docstring begin (texi-doc-string "guile" "make-thread") @deffn macro make-thread proc [args@dots{}] Apply @var{proc} to @var{args} in a new thread formed by @code{call-with-new-thread} using @code{%thread-handler} as the error handler. @end deffn -@c docstring begin (texi-doc-string "guile" "begin-thread") @deffn macro begin-thread first [rest@dots{}] Evaluate forms @var{first} and @var{rest} in a new thread formed by @code{call-with-new-thread} using @code{%thread-handler} as the error handler. @end deffn -@c docstring begin (texi-doc-string "guile" "with-mutex") @deffn macro with-mutex m [body@dots{}] Lock mutex @var{m}, evaluate @var{body}, and then unlock @var{m}. These sub-operations form the branches of a @code{dynamic-wind}. @end deffn -@c docstring begin (texi-doc-string "guile" "monitor") @deffn macro monitor first [rest@dots{}] Evaluate forms @var{first} and @var{rest} under a newly created anonymous mutex, using @code{with-mutex}. @@ -340,7 +322,6 @@ anonymous mutex, using @code{with-mutex}. @node Fluids @section Fluids -@c docstring begin (texi-doc-string "guile" "make-fluid") @deffn primitive make-fluid Return a newly created fluid. Fluids are objects of a certain type (a smob) that can hold one SCM @@ -351,25 +332,21 @@ inherits the values from its parent. Because each thread executes in its own dynamic root, you can use fluids for thread local storage. @end deffn -@c docstring begin (texi-doc-string "guile" "fluid?") @deffn primitive fluid? obj Return @code{#t} iff @var{obj} is a fluid; otherwise, return @code{#f}. @end deffn -@c docstring begin (texi-doc-string "guile" "fluid-ref") @deffn primitive fluid-ref fluid Return the value associated with @var{fluid} in the current dynamic root. If @var{fluid} has not been set, then return @code{#f}. @end deffn -@c docstring begin (texi-doc-string "guile" "fluid-set!") @deffn primitive fluid-set! fluid value Set the value associated with @var{fluid} in the current dynamic root. @end deffn -@c docstring begin (texi-doc-string "guile" "with-fluids*") @deffn primitive with-fluids* fluids values thunk Set @var{fluids} to @var{values} temporary, and call @var{thunk}. @var{fluids} must be a list of fluids and @var{values} must be the same diff --git a/doc/scheme-translation.texi b/doc/scheme-translation.texi index dfbbdd0b4..e69de29bb 100644 --- a/doc/scheme-translation.texi +++ b/doc/scheme-translation.texi @@ -1,49 +0,0 @@ -@page -@node Translation -@chapter Support for Translating Other Languages - -[Describe translation framework.] - -@menu -* Emacs Lisp Support:: Helper primitives for Emacs Lisp. -@end menu - - -@node Emacs Lisp Support -@section Emacs Lisp Support - -@c docstring begin (texi-doc-string "guile" "nil-car") -@deffn primitive nil-car x -Return the car of @var{x}, but convert it to LISP nil if it -is Scheme's end-of-list. -@end deffn - -@c docstring begin (texi-doc-string "guile" "nil-cdr") -@deffn primitive nil-cdr x -Return the cdr of @var{x}, but convert it to LISP nil if it -is Scheme's end-of-list. -@end deffn - -@c docstring begin (texi-doc-string "guile" "nil-cons") -@deffn primitive nil-cons x y -Create a new cons cell with @var{x} as the car and @var{y} as -the cdr, but convert @var{y} to Scheme's end-of-list if it is -a LISP nil. -@end deffn - -@c docstring begin (texi-doc-string "guile" "nil-eq") -@deffn primitive nil-eq x y -Compare @var{x} and @var{y} and return LISP's t if they are -@code{eq?}, return LISP's nil otherwise. -@end deffn - -@c docstring begin (texi-doc-string "guile" "null") -@deffn primitive null x -Return LISP's @code{t} if @var{x} is nil in the LISP sense, -return LISP's nil otherwise. -@end deffn - - -@c Local Variables: -@c TeX-master: "guile.texi" -@c End: diff --git a/doc/scheme-utility.texi b/doc/scheme-utility.texi index 3163bf3a5..543a14569 100644 --- a/doc/scheme-utility.texi +++ b/doc/scheme-utility.texi @@ -15,7 +15,6 @@ @section Equality @rnindex eq? -@c docstring begin (texi-doc-string "guile" "eq?") @deffn primitive eq? x y Return @code{#t} iff @var{x} references the same object as @var{y}. @code{eq?} is similar to @code{eqv?} except that in some cases it is @@ -24,7 +23,6 @@ capable of discerning distinctions finer than those detectable by @end deffn @rnindex eqv? -@c docstring begin (texi-doc-string "guile" "eqv?") @deffn primitive eqv? x y The @code{eqv?} procedure defines a useful equivalence relation on objects. Briefly, it returns @code{#t} if @var{x} and @var{y} should normally be @@ -34,7 +32,6 @@ and inexact numbers. @end deffn @rnindex equal? -@c docstring begin (texi-doc-string "guile" "equal?") @deffn primitive equal? x y Return @code{#t} iff @var{x} and @var{y} are recursively @code{eqv?} equivalent. @code{equal?} recursively compares the contents of pairs, @@ -60,25 +57,21 @@ closures than for other kinds of objects. Therefore, when manipulating a property list associated with a procedure object, use the @code{procedure} functions; otherwise, use the @code{object} functions. -@c docstring begin (texi-doc-string "guile" "object-properties") @deffn primitive object-properties obj @deffnx primitive procedure-properties obj Return @var{obj}'s property list. @end deffn -@c docstring begin (texi-doc-string "guile" "set-object-properties!") @deffn primitive set-object-properties! obj alist @deffnx primitive set-procedure-properties! obj alist Set @var{obj}'s property list to @var{alist}. @end deffn -@c docstring begin (texi-doc-string "guile" "object-property") @deffn primitive object-property obj key @deffnx primitive procedure-property obj key Return the property of @var{obj} with name @var{key}. @end deffn -@c docstring begin (texi-doc-string "guile" "set-object-property!") @deffn primitive set-object-property! obj key value @deffnx primitive set-procedure-property! obj key value In @var{obj}'s property list, set the property named @var{key} @@ -92,7 +85,6 @@ the user provides a "property table" that is possibly private.] @node Primitive Properties @section Primitive Properties -@c docstring begin (texi-doc-string "guile" "primitive-make-property") @deffn primitive primitive-make-property not_found_proc Create a @dfn{property token} that can be used with @code{primitive-property-ref} and @code{primitive-property-set!}. @@ -100,7 +92,6 @@ See @code{primitive-property-ref} for the significance of @var{not_found_proc}. @end deffn -@c docstring begin (texi-doc-string "guile" "primitive-property-ref") @deffn primitive primitive-property-ref prop obj Return the property @var{prop} of @var{obj}. When no value has yet been associated with @var{prop} and @var{obj}, call @@ -111,12 +102,10 @@ and use its return value. That value is also associated with default value of @var{prop}. @end deffn -@c docstring begin (texi-doc-string "guile" "primitive-property-set!") @deffn primitive primitive-property-set! prop obj val Associate @var{code} with @var{prop} and @var{obj}. @end deffn -@c docstring begin (texi-doc-string "guile" "primitive-property-del!") @deffn primitive primitive-property-del! prop obj Remove any value associated with @var{prop} and @var{obj}. @end deffn @@ -125,7 +114,6 @@ Remove any value associated with @var{prop} and @var{obj}. @node Sorting @section Sorting -@c docstring begin (texi-doc-string "guile" "merge!") @deffn primitive merge! alist blist less Takes two lists @var{alist} and @var{blist} such that @code{(sorted? alist less?)} and @code{(sorted? blist less?)} and @@ -136,11 +124,9 @@ This is the destructive variant of @code{merge} Note: this does _not_ accept vectors. @end deffn -@c docstring begin (texi-doc-string "guile" "merge") @deffn primitive merge alist blist less @end deffn -@c docstring begin (texi-doc-string "guile" "restricted-vector-sort!") @deffn primitive restricted-vector-sort! vec less startpos endpos Sort the vector @var{vec}, using @var{less} for comparing the vector elements. @var{startpos} and @var{endpos} delimit @@ -148,7 +134,6 @@ the range of the vector which gets sorted. The return value is not specified. @end deffn -@c docstring begin (texi-doc-string "guile" "sort!") @deffn primitive sort! items less Sort the sequence @var{items}, which may be a list or a vector. @var{less} is used for comparing the sequence @@ -157,14 +142,12 @@ input sequence is modified to produce the sorted result. This is not a stable sort. @end deffn -@c docstring begin (texi-doc-string "guile" "sort") @deffn primitive sort items less Sort the sequence @var{items}, which may be a list or a vector. @var{less} is used for comparing the sequence elements. This is not a stable sort. @end deffn -@c docstring begin (texi-doc-string "guile" "sort-list!") @deffn primitive sort-list! items less Sort the list @var{items}, using @var{less} for comparing the list elements. The sorting is destructive, that means that the @@ -172,20 +155,17 @@ input list is modified to produce the sorted result. This is a stable sort. @end deffn -@c docstring begin (texi-doc-string "guile" "sort-list") @deffn primitive sort-list items less Sort the list @var{items}, using @var{less} for comparing the list elements. This is a stable sort. @end deffn -@c docstring begin (texi-doc-string "guile" "sorted?") @deffn primitive sorted? items less Return @code{#t} iff @var{items} is a list or a vector such that for all 1 <= i <= m, the predicate @var{less} returns true when applied to all elements i - 1 and i @end deffn -@c docstring begin (texi-doc-string "guile" "stable-sort!") @deffn primitive stable-sort! items less Sort the sequence @var{items}, which may be a list or a vector. @var{less} is used for comparing the sequence elements. @@ -194,7 +174,6 @@ is modified to produce the sorted result. This is a stable sort. @end deffn -@c docstring begin (texi-doc-string "guile" "stable-sort") @deffn primitive stable-sort items less Sort the sequence @var{items}, which may be a list or a vector. @var{less} is used for comparing the sequence elements. @@ -205,7 +184,6 @@ This is a stable sort. @node Copying @section Copying Deep Structures -@c docstring begin (texi-doc-string "guile" "copy-tree") @deffn primitive copy-tree obj Recursively copy the data tree that is bound to @var{obj}, and return a pointer to the new data structure. @code{copy-tree} recurses down the From 89d04205b416699a9abdb8c2bebff5ca0fbff8f3 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Mon, 9 Apr 2001 21:44:06 +0000 Subject: [PATCH 0799/2047] * Clean up doc and docstring for shared substrings and read only strings. --- doc/ChangeLog | 7 + doc/deprecated.texi | 143 +++++++- doc/maint/guile.texi | 798 +++++++++++++++++++++---------------------- doc/scheme-data.texi | 118 ------- libguile/ChangeLog | 5 + libguile/strings.c | 11 +- 6 files changed, 539 insertions(+), 543 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 7530a8d5b..2cf27d9ea 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,5 +1,12 @@ 2001-04-09 Neil Jerram + * deprecated.texi (Shared And Read Only Strings): New section for + deprecated string stuff. I've also updated the text a bit to + reflect current usage of "read only" strings. + + * scheme-data.texi (Shared Substrings, Read Only Strings): Moved + to deprecated.texi. + * deprecated.texi, posix.texi, scheme-binding.texi, scheme-control.texi, scheme-data.texi, scheme-debug.texi, scheme-evaluation.texi, scheme-io.texi, scheme-memory.texi, diff --git a/doc/deprecated.texi b/doc/deprecated.texi index e7f5277db..0b2fdd30a 100644 --- a/doc/deprecated.texi +++ b/doc/deprecated.texi @@ -1,7 +1,146 @@ @node Deprecated @chapter Deprecated -@deffn primitive tag x -Return an integer corresponding to the type of X. Deprecated. +@menu +* Shared And Read Only Strings:: +* Tags:: +@end menu + + +@node Shared And Read Only Strings +@section Shared And Read Only Strings + +The procedures described in this section are deprecated because explicit +shared substrings are planned to disappear from Guile. + +Instead, all strings will be implemented using sharing internally, +combined with a copy-on-write strategy. Once internal string sharing +and copy-on-write have been implemented, it will be unnecessary to +preserve the concept of read only strings. + +@menu +* Shared Substrings:: Strings which share memory with each other. +* Read Only Strings:: Treating certain non-strings as strings. +@end menu + + +@node Shared Substrings +@subsection Shared Substrings + +Whenever you extract a substring using @code{substring}, the Scheme +interpreter allocates a new string and copies data from the old string. +This is expensive, but @code{substring} is so convenient for +manipulating text that programmers use it often. + +Guile Scheme provides the concept of the @dfn{shared substring} to +improve performance of many substring-related operations. A shared +substring is an object that mostly behaves just like an ordinary +substring, except that it actually shares storage space with its parent +string. + +@deffn primitive make-shared-substring str [start [end]] +Return a shared substring of @var{str}. The arguments are the +same as for the @code{substring} function: the shared substring +returned includes all of the text from @var{str} between +indexes @var{start} (inclusive) and @var{end} (exclusive). If +@var{end} is omitted, it defaults to the end of @var{str}. The +shared substring returned by @code{make-shared-substring} +occupies the same storage space as @var{str}. @end deffn +Example: + +@example +(define foo "the quick brown fox") +(define bar (make-shared-substring some-string 4 9)) + +foo => "t h e q u i c k b r o w n f o x" +bar =========> |---------| +@end example + +The shared substring @var{bar} is not given its own storage space. +Instead, the Guile interpreter notes internally that @var{bar} points to +a portion of the memory allocated to @var{foo}. However, @var{bar} +behaves like an ordinary string in most respects: it may be used with +string primitives like @code{string-length}, @code{string-ref}, +@code{string=?}. Guile makes the necessary translation between indices +of @var{bar} and indices of @var{foo} automatically. + +@example +(string-length? bar) @result{} 5 ; bar only extends from indices 4 to 9 +(string-ref bar 3) @result{} #\c ; same as (string-ref foo 7) +(make-shared-substring bar 2) + @result{} "ick" ; can even make a shared substring! +@end example + +Because creating a shared substring does not require allocating new +storage from the heap, it is a very fast operation. However, because it +shares memory with its parent string, a change to the contents of the +parent string will implicitly change the contents of its shared +substrings. + +@example +(string-set! foo 7 #\r) +bar @result{} "quirk" +@end example + +Guile considers shared substrings to be immutable. This is because +programmers might not always be aware that a given string is really a +shared substring, and might innocently try to mutate it without +realizing that the change would affect its parent string. (We are +currently considering a "copy-on-write" strategy that would permit +modifying shared substrings without affecting the parent string.) + +In general, shared substrings are useful in circumstances where it is +important to divide a string into smaller portions, but you do not +expect to change the contents of any of the strings involved. + + +@node Read Only Strings +@subsection Read Only Strings + +In previous versions of Guile, there was the idea that some string-based +primitives such as @code{string-append} could equally accept symbols as +arguments. For example, one could write + +@lisp +(string-append '/home/ 'vigilia) +@end lisp + +@noindent +and get @code{"/home/vigilia"} as the result. The term @dfn{read only +string} was adopted to describe the argument type expected by such +primitives. + +This idea has now been removed. The predicate @code{read-only-string?} +still exists, but deprecated, and is equivalent to + +@lisp +(lambda (x) (or (string? x) (symbol? x))) +@end lisp + +@noindent +But no Guile primitives now use @code{read-only-string?} to validate +their arguments. + +String-based primitives such as @code{string-append} +now require strings: + +@lisp +(string-append '/home/ 'vigilia) +@result{} +ERROR: Wrong type argument (expecting STRINGP): /home/ +@end lisp + +@deffn primitive read-only-string? obj +Return @code{#t} if @var{obj} is either a string or a symbol, +otherwise return @code{#f}. +@end deffn + + +@node Tags +@section Tags + +@deffn primitive tag x +Return an integer corresponding to the type of @var{x}. Deprecated. +@end deffn diff --git a/doc/maint/guile.texi b/doc/maint/guile.texi index 823e84f41..d0f54e487 100644 --- a/doc/maint/guile.texi +++ b/doc/maint/guile.texi @@ -169,38 +169,38 @@ add it to the system's list of active async objects. @end deffn async-mark -@c snarfed from async.c:317 +@c snarfed from async.c:311 @deffn primitive async-mark a Mark the async @var{a} for future execution. @end deffn system-async-mark -@c snarfed from async.c:333 +@c snarfed from async.c:327 @deffn primitive system-async-mark a Mark the async @var{a} for future execution. @end deffn run-asyncs -@c snarfed from async.c:353 +@c snarfed from async.c:347 @deffn primitive run-asyncs list_of_a Execute all thunks from the asyncs of the list @var{list_of_a}. @end deffn noop -@c snarfed from async.c:387 +@c snarfed from async.c:381 @deffn primitive noop . args Do nothing. When called without arguments, return @code{#f}, otherwise return the first argument. @end deffn unmask-signals -@c snarfed from async.c:439 +@c snarfed from async.c:433 @deffn primitive unmask-signals Unmask signals. The returned value is not specified. @end deffn mask-signals -@c snarfed from async.c:450 +@c snarfed from async.c:444 @deffn primitive mask-signals Mask signals. The returned value is not specified. @end deffn @@ -226,7 +226,7 @@ output. @end deffn display-backtrace -@c snarfed from backtrace.c:617 +@c snarfed from backtrace.c:619 @deffn primitive display-backtrace stack port [first [depth]] Display a backtrace to the output port @var{port}. @var{stack} is the stack to take the backtrace from, @var{first} specifies @@ -236,7 +236,7 @@ which means that default values will be used. @end deffn backtrace -@c snarfed from backtrace.c:640 +@c snarfed from backtrace.c:642 @deffn primitive backtrace Display a backtrace of the stack saved by the last error to the current output port. @@ -457,7 +457,7 @@ is implicit). @end deffn debug-object? -@c snarfed from debug.c:576 +@c snarfed from debug.c:575 @deffn primitive debug-object? obj Return @code{#t} if @var{obj} is a debug object. @end deffn @@ -483,7 +483,7 @@ only by module bookkeeping operations. @end deffn dynamic-link -@c snarfed from dynl.c:356 +@c snarfed from dynl.c:357 @deffn primitive dynamic-link filename Open the dynamic library called @var{filename}. A library handle representing the opened library is returned; this handle @@ -492,14 +492,14 @@ functions. @end deffn dynamic-object? -@c snarfed from dynl.c:372 +@c snarfed from dynl.c:373 @deffn primitive dynamic-object? obj Return @code{#t} if @var{obj} is a dynamic library handle, or @code{#f} otherwise. @end deffn dynamic-unlink -@c snarfed from dynl.c:388 +@c snarfed from dynl.c:386 @deffn primitive dynamic-unlink dobj Unlink the indicated object file from the application. The argument @var{dobj} must have been obtained by a call to @@ -508,7 +508,7 @@ called on @var{dobj}, its content is no longer accessible. @end deffn dynamic-func -@c snarfed from dynl.c:415 +@c snarfed from dynl.c:413 @deffn primitive dynamic-func name dobj Search the dynamic object @var{dobj} for the C function indicated by the string @var{name} and return some Scheme @@ -522,7 +522,7 @@ needed or not and will add it when necessary. @end deffn dynamic-call -@c snarfed from dynl.c:460 +@c snarfed from dynl.c:453 @deffn primitive dynamic-call func dobj Call the C function indicated by @var{func} and @var{dobj}. The function is passed no arguments and its return value is @@ -539,7 +539,7 @@ Interrupts are deferred while the C function is executing (with @end deffn dynamic-args-call -@c snarfed from dynl.c:494 +@c snarfed from dynl.c:481 @deffn primitive dynamic-args-call func dobj args Call the C function indicated by @var{func} and @var{dobj}, just like @code{dynamic-call}, but pass it some arguments and @@ -557,7 +557,7 @@ converted to a Scheme number and returned from the call to @end deffn dynamic-wind -@c snarfed from dynwind.c:115 +@c snarfed from dynwind.c:121 @deffn primitive dynamic-wind in_guard thunk out_guard All three arguments must be 0-argument procedures. @var{in_guard} is called, then @var{thunk}, then @@ -981,7 +981,7 @@ terminate if its arguments are circular data structures. @end deffn scm-error -@c snarfed from error.c:112 +@c snarfed from error.c:114 @deffn primitive scm-error key subr message args data Raise an error with key @var{key}. @var{subr} can be a string naming the procedure associated with the error, or @code{#f}. @@ -999,14 +999,14 @@ it will usually be @code{#f}. @end deffn strerror -@c snarfed from error.c:153 +@c snarfed from error.c:156 @deffn primitive strerror err Return the Unix error message corresponding to @var{err}, which must be an integer value. @end deffn apply:nconc2last -@c snarfed from eval.c:3221 +@c snarfed from eval.c:3256 @deffn primitive apply:nconc2last lst Given a list (@var{arg1} @dots{} @var{args}), this function conses the @var{arg1} @dots{} arguments onto the front of @@ -1018,7 +1018,7 @@ destroys its argument, so use with care. @end deffn force -@c snarfed from eval.c:3754 +@c snarfed from eval.c:3789 @deffn primitive force x If the promise @var{x} has not been computed yet, compute and return @var{x}, otherwise just return the previously computed @@ -1026,14 +1026,14 @@ value. @end deffn promise? -@c snarfed from eval.c:3777 +@c snarfed from eval.c:3812 @deffn primitive promise? obj Return true if @var{obj} is a promise, i.e. a delayed computation (@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}). @end deffn cons-source -@c snarfed from eval.c:3789 +@c snarfed from eval.c:3824 @deffn primitive cons-source xorig x y Create and return a new pair whose car and cdr are @var{x} and @var{y}. Any source properties associated with @var{xorig} are also associated @@ -1041,7 +1041,7 @@ with the new pair. @end deffn copy-tree -@c snarfed from eval.c:3811 +@c snarfed from eval.c:3846 @deffn primitive copy-tree obj Recursively copy the data tree that is bound to @var{obj}, and return a pointer to the new data structure. @code{copy-tree} recurses down the @@ -1051,14 +1051,14 @@ any other object. @end deffn primitive-eval -@c snarfed from eval.c:3912 +@c snarfed from eval.c:3940 @deffn primitive primitive-eval exp Evaluate @var{exp} in the top-level environment specified by the current module. @end deffn eval -@c snarfed from eval.c:3977 +@c snarfed from eval.c:4009 @deffn primitive eval exp module Evaluate @var{exp}, a list representing a Scheme expression, in the top-level environment specified by @var{module}. @@ -1068,7 +1068,7 @@ is reset to its previous value when @var{eval} returns. @end deffn eval2 -@c snarfed from eval.c:4020 +@c snarfed from eval.c:4052 @deffn primitive eval2 obj env_thunk Evaluate @var{exp}, a Scheme expression, in the environment designated by @var{lookup}, a symbol-lookup function." @@ -1078,7 +1078,7 @@ with the module system. Use @code{eval} or @end deffn eval-options-interface -@c snarfed from eval.c:1685 +@c snarfed from eval.c:1697 @deffn primitive eval-options-interface [setting] Option interface for the evaluation options. Instead of using this procedure directly, use the procedures @code{eval-enable}, @@ -1086,7 +1086,7 @@ this procedure directly, use the procedures @code{eval-enable}, @end deffn evaluator-traps-interface -@c snarfed from eval.c:1702 +@c snarfed from eval.c:1714 @deffn primitive evaluator-traps-interface [setting] Option interface for the evaluator trap options. @end deffn @@ -1212,7 +1212,7 @@ The return value is unspecified. @end deffn stat -@c snarfed from filesys.c:518 +@c snarfed from filesys.c:524 @deffn primitive stat object Return an object containing various information about the file determined by @var{obj}. @var{obj} can be a string containing @@ -1269,7 +1269,7 @@ An integer representing the access permission bits. @end deffn link -@c snarfed from filesys.c:564 +@c snarfed from filesys.c:570 @deffn primitive link oldpath newpath Creates a new name @var{newpath} in the file system for the file named by @var{oldpath}. If @var{oldpath} is a symbolic @@ -1278,20 +1278,20 @@ system. @end deffn rename-file -@c snarfed from filesys.c:586 +@c snarfed from filesys.c:592 @deffn primitive rename-file oldname newname Renames the file specified by @var{oldname} to @var{newname}. The return value is unspecified. @end deffn delete-file -@c snarfed from filesys.c:615 +@c snarfed from filesys.c:621 @deffn primitive delete-file str Deletes (or "unlinks") the file specified by @var{path}. @end deffn mkdir -@c snarfed from filesys.c:634 +@c snarfed from filesys.c:640 @deffn primitive mkdir path [mode] Create a new directory named by @var{path}. If @var{mode} is omitted then the permissions of the directory file are set using the current @@ -1300,28 +1300,28 @@ umask. Otherwise they are set to the decimal value specified with @end deffn rmdir -@c snarfed from filesys.c:663 +@c snarfed from filesys.c:669 @deffn primitive rmdir path Remove the existing directory named by @var{path}. The directory must be empty for this to succeed. The return value is unspecified. @end deffn directory-stream? -@c snarfed from filesys.c:689 +@c snarfed from filesys.c:695 @deffn primitive directory-stream? obj Return a boolean indicating whether @var{object} is a directory stream as returned by @code{opendir}. @end deffn opendir -@c snarfed from filesys.c:700 +@c snarfed from filesys.c:706 @deffn primitive opendir dirname Open the directory specified by @var{path} and return a directory stream. @end deffn readdir -@c snarfed from filesys.c:718 +@c snarfed from filesys.c:724 @deffn primitive readdir port Return (as a string) the next directory entry from the directory stream @var{stream}. If there is no remaining entry to be read then the @@ -1329,34 +1329,34 @@ end of file object is returned. @end deffn rewinddir -@c snarfed from filesys.c:741 +@c snarfed from filesys.c:747 @deffn primitive rewinddir port Reset the directory port @var{stream} so that the next call to @code{readdir} will return the first directory entry. @end deffn closedir -@c snarfed from filesys.c:758 +@c snarfed from filesys.c:764 @deffn primitive closedir port Close the directory stream @var{stream}. The return value is unspecified. @end deffn chdir -@c snarfed from filesys.c:808 +@c snarfed from filesys.c:814 @deffn primitive chdir str Change the current working directory to @var{path}. The return value is unspecified. @end deffn getcwd -@c snarfed from filesys.c:825 +@c snarfed from filesys.c:831 @deffn primitive getcwd Return the name of the current working directory. @end deffn select -@c snarfed from filesys.c:1022 +@c snarfed from filesys.c:1028 @deffn primitive select reads writes excepts [secs [usecs]] This procedure has a variety of uses: waiting for the ability to provide input, accept output, or the existance of @@ -1390,7 +1390,7 @@ An additional @code{select!} interface is provided. @end deffn fcntl -@c snarfed from filesys.c:1167 +@c snarfed from filesys.c:1173 @deffn primitive fcntl object cmd [value] Apply @var{command} to the specified file descriptor or the underlying file descriptor of the specified port. @var{value} is an optional @@ -1420,7 +1420,7 @@ The value used to indicate the "close on exec" flag with @code{F_GETFL} or @end deffn fsync -@c snarfed from filesys.c:1203 +@c snarfed from filesys.c:1209 @deffn primitive fsync object Copies any unwritten data for the specified output file descriptor to disk. If @var{port/fd} is a port, its buffer is flushed before the underlying @@ -1429,21 +1429,21 @@ The return value is unspecified. @end deffn symlink -@c snarfed from filesys.c:1230 +@c snarfed from filesys.c:1236 @deffn primitive symlink oldpath newpath Create a symbolic link named @var{path-to} with the value (i.e., pointing to) @var{path-from}. The return value is unspecified. @end deffn readlink -@c snarfed from filesys.c:1252 +@c snarfed from filesys.c:1257 @deffn primitive readlink path Return the value of the symbolic link named by @var{path} (a string), i.e., the file that the link points to. @end deffn lstat -@c snarfed from filesys.c:1282 +@c snarfed from filesys.c:1287 @deffn primitive lstat str Similar to @code{stat}, but does not follow symbolic links, i.e., it will return information about a symbolic link itself, not the @@ -1451,14 +1451,14 @@ file it points to. @var{path} must be a string. @end deffn copy-file -@c snarfed from filesys.c:1307 +@c snarfed from filesys.c:1312 @deffn primitive copy-file oldfile newfile Copy the file specified by @var{path-from} to @var{path-to}. The return value is unspecified. @end deffn dirname -@c snarfed from filesys.c:1354 +@c snarfed from filesys.c:1359 @deffn primitive dirname filename Return the directory name component of the file name @var{filename}. If @var{filename} does not contain a directory @@ -1466,7 +1466,7 @@ component, @code{.} is returned. @end deffn basename -@c snarfed from filesys.c:1387 +@c snarfed from filesys.c:1392 @deffn primitive basename filename [suffix] Return the base name of the file name @var{filename}. The base name is the file name without any directory components. @@ -1487,14 +1487,14 @@ in its own dynamic root, you can use fluids for thread local storage. @end deffn fluid? -@c snarfed from fluids.c:141 +@c snarfed from fluids.c:142 @deffn primitive fluid? obj Return @code{#t} iff @var{obj} is a fluid; otherwise, return @code{#f}. @end deffn fluid-ref -@c snarfed from fluids.c:151 +@c snarfed from fluids.c:153 @deffn primitive fluid-ref fluid Return the value associated with @var{fluid} in the current dynamic root. If @var{fluid} has not been set, then return @@ -1502,13 +1502,13 @@ dynamic root. If @var{fluid} has not been set, then return @end deffn fluid-set! -@c snarfed from fluids.c:168 +@c snarfed from fluids.c:170 @deffn primitive fluid-set! fluid value Set the value associated with @var{fluid} in the current dynamic root. @end deffn with-fluids* -@c snarfed from fluids.c:227 +@c snarfed from fluids.c:229 @deffn primitive with-fluids* fluids values thunk Set @var{fluids} to @var{values} temporary, and call @var{thunk}. @var{fluids} must be a list of fluids and @var{values} must be the same @@ -1538,7 +1538,7 @@ Determine whether @var{obj} is a port that is related to a file. @end deffn open-file -@c snarfed from fports.c:282 +@c snarfed from fports.c:283 @deffn primitive open-file filename mode Open the file whose name is @var{filename}, and return a port representing that file. The attributes of the port are @@ -1580,28 +1580,28 @@ requested, @code{open-file} throws an exception. @end deffn gc-stats -@c snarfed from gc.c:742 +@c snarfed from gc.c:749 @deffn primitive gc-stats Return an association list of statistics about Guile's current use of storage. @end deffn object-address -@c snarfed from gc.c:839 +@c snarfed from gc.c:846 @deffn primitive object-address obj Return an integer that for the lifetime of @var{obj} is uniquely returned by this function for @var{obj} @end deffn gc -@c snarfed from gc.c:850 +@c snarfed from gc.c:857 @deffn primitive gc Scans all of SCM objects and reclaims for further use those that are no longer accessible. @end deffn unhash-name -@c snarfed from gc.c:2291 +@c snarfed from gc.c:2303 @deffn primitive unhash-name name Flushes the glocs for @var{name}, or all glocs if @var{name} is @code{#t}. @@ -1985,7 +1985,7 @@ integer in the range 0 to @var{size} - 1. @end deffn hashq-get-handle -@c snarfed from hashtab.c:174 +@c snarfed from hashtab.c:173 @deffn primitive 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 @@ -1994,7 +1994,7 @@ Uses @code{eq?} for equality testing. @end deffn hashq-create-handle! -@c snarfed from hashtab.c:186 +@c snarfed from hashtab.c:185 @deffn primitive hashq-create-handle! 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 @@ -2002,7 +2002,7 @@ associates @var{key} with @var{init}. @end deffn hashq-ref -@c snarfed from hashtab.c:199 +@c snarfed from hashtab.c:198 @deffn primitive 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, @@ -2011,21 +2011,21 @@ is supplied). Uses @code{eq?} for equality testing. @end deffn hashq-set! -@c snarfed from hashtab.c:213 +@c snarfed from hashtab.c:212 @deffn primitive hashq-set! 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 hashq-remove! -@c snarfed from hashtab.c:225 +@c snarfed from hashtab.c:224 @deffn primitive hashq-remove! table key Remove @var{key} (and any value associated with it) from @var{table}. Uses @code{eq?} for equality tests. @end deffn hashv-get-handle -@c snarfed from hashtab.c:242 +@c snarfed from hashtab.c:240 @deffn primitive 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 @@ -2034,7 +2034,7 @@ Uses @code{eqv?} for equality testing. @end deffn hashv-create-handle! -@c snarfed from hashtab.c:254 +@c snarfed from hashtab.c:252 @deffn primitive hashv-create-handle! 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 @@ -2042,7 +2042,7 @@ associates @var{key} with @var{init}. @end deffn hashv-ref -@c snarfed from hashtab.c:267 +@c snarfed from hashtab.c:266 @deffn primitive 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, @@ -2051,21 +2051,21 @@ is supplied). Uses @code{eqv?} for equality testing. @end deffn hashv-set! -@c snarfed from hashtab.c:281 +@c snarfed from hashtab.c:280 @deffn primitive hashv-set! table key val Find the entry in @var{table} associated with @var{key}, and store @var{value} there. Uses @code{eqv?} for equality testing. @end deffn hashv-remove! -@c snarfed from hashtab.c:292 +@c snarfed from hashtab.c:291 @deffn primitive hashv-remove! table key Remove @var{key} (and any value associated with it) from @var{table}. Uses @code{eqv?} for equality tests. @end deffn hash-get-handle -@c snarfed from hashtab.c:308 +@c snarfed from hashtab.c:306 @deffn primitive 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 @@ -2074,7 +2074,7 @@ Uses @code{equal?} for equality testing. @end deffn hash-create-handle! -@c snarfed from hashtab.c:320 +@c snarfed from hashtab.c:318 @deffn primitive hash-create-handle! 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 @@ -2082,7 +2082,7 @@ associates @var{key} with @var{init}. @end deffn hash-ref -@c snarfed from hashtab.c:333 +@c snarfed from hashtab.c:331 @deffn primitive 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, @@ -2091,7 +2091,7 @@ is supplied). Uses @code{equal?} for equality testing. @end deffn hash-set! -@c snarfed from hashtab.c:348 +@c snarfed from hashtab.c:346 @deffn primitive hash-set! table key val Find the entry in @var{table} associated with @var{key}, and store @var{value} there. Uses @code{equal?} for equality @@ -2099,14 +2099,14 @@ testing. @end deffn hash-remove! -@c snarfed from hashtab.c:360 +@c snarfed from hashtab.c:358 @deffn primitive hash-remove! table key Remove @var{key} (and any value associated with it) from @var{table}. Uses @code{equal?} for equality tests. @end deffn hashx-get-handle -@c snarfed from hashtab.c:429 +@c snarfed from hashtab.c:428 @deffn primitive 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 @@ -2128,7 +2128,7 @@ table size. @code{assoc} must be an associator function, like @end deffn hashx-ref -@c snarfed from hashtab.c:468 +@c snarfed from hashtab.c:470 @deffn primitive 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 @@ -2141,7 +2141,7 @@ equivalent to @code{hashx-ref hashq assq table key}. @end deffn hashx-set! -@c snarfed from hashtab.c:492 +@c snarfed from hashtab.c:496 @deffn primitive hashx-set! 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 @@ -2154,7 +2154,7 @@ equivalent to @code{hashx-set! hashq assq table key}. @end deffn hash-fold -@c snarfed from hashtab.c:529 +@c snarfed from hashtab.c:534 @deffn primitive hash-fold proc init table An iterator over hash-table elements. Accumulates and returns a result by applying PROC successively. @@ -2167,7 +2167,7 @@ table into an a-list of key-value pairs. @end deffn make-hook-with-name -@c snarfed from hooks.c:216 +@c snarfed from hooks.c:217 @deffn primitive make-hook-with-name name [n_args] Create a named hook with the name @var{name} for storing procedures of arity @var{n_args}. @var{n_args} defaults to @@ -2175,27 +2175,27 @@ zero. @end deffn make-hook -@c snarfed from hooks.c:230 +@c snarfed from hooks.c:232 @deffn primitive make-hook [n_args] Create a hook for storing procedure of arity @var{n_args}. @var{n_args} defaults to zero. @end deffn hook? -@c snarfed from hooks.c:240 +@c snarfed from hooks.c:242 @deffn primitive hook? x Return @code{#t} if @var{x} is a hook, @code{#f} otherwise. @end deffn hook-empty? -@c snarfed from hooks.c:250 +@c snarfed from hooks.c:253 @deffn primitive hook-empty? hook Return @code{#t} if @var{hook} is an empty hook, @code{#f} otherwise. @end deffn add-hook! -@c snarfed from hooks.c:263 +@c snarfed from hooks.c:266 @deffn primitive add-hook! hook proc [append_p] Add the procedure @var{proc} to the hook @var{hook}. The procedure is added to the end if @var{append_p} is true, @@ -2203,19 +2203,19 @@ otherwise it is added to the front. @end deffn remove-hook! -@c snarfed from hooks.c:289 +@c snarfed from hooks.c:292 @deffn primitive remove-hook! hook proc Remove the procedure @var{proc} from the hook @var{hook}. @end deffn reset-hook! -@c snarfed from hooks.c:302 +@c snarfed from hooks.c:305 @deffn primitive reset-hook! hook Remove all procedures from the hook @var{hook}. @end deffn run-hook -@c snarfed from hooks.c:315 +@c snarfed from hooks.c:319 @deffn primitive run-hook hook . args Apply all procedures from the hook @var{hook} to the arguments @var{args}. The order of the procedure application is first to @@ -2223,7 +2223,7 @@ last. @end deffn hook->list -@c snarfed from hooks.c:342 +@c snarfed from hooks.c:346 @deffn primitive hook->list hook Convert the procedure list of @var{hook} to a list. @end deffn @@ -2265,7 +2265,7 @@ end-of-file check @end deffn ftell -@c snarfed from ioext.c:173 +@c snarfed from ioext.c:174 @deffn primitive ftell fd_port Return an integer representing the current position of @var{fd/port}, measured from the beginning. Equivalent to: @@ -2275,14 +2275,14 @@ Return an integer representing the current position of @end deffn fseek -@c snarfed from ioext.c:186 +@c snarfed from ioext.c:187 @deffn primitive fseek fd_port offset whence Obsolete. Almost the same as @code{seek}, but the return value is unspecified. @end deffn redirect-port -@c snarfed from ioext.c:208 +@c snarfed from ioext.c:209 @deffn primitive redirect-port old new This procedure takes two ports and duplicates the underlying file descriptor from @var{old-port} into @var{new-port}. The @@ -2300,7 +2300,7 @@ revealed counts. @end deffn dup->fdes -@c snarfed from ioext.c:245 +@c snarfed from ioext.c:248 @deffn primitive dup->fdes fd_or_port [fd] Return a new integer file descriptor referring to the open file designated by @var{fd_or_port}, which must be either an open @@ -2308,7 +2308,7 @@ file port or a file descriptor. @end deffn dup2 -@c snarfed from ioext.c:292 +@c snarfed from ioext.c:295 @deffn primitive dup2 oldfd newfd A simple wrapper for the @code{dup2} system call. Copies the file descriptor @var{oldfd} to descriptor @@ -2321,21 +2321,21 @@ The return value is unspecified. @end deffn fileno -@c snarfed from ioext.c:311 +@c snarfed from ioext.c:314 @deffn primitive fileno port Return the integer file descriptor underlying @var{port}. Does not change its revealed count. @end deffn isatty? -@c snarfed from ioext.c:327 +@c snarfed from ioext.c:330 @deffn primitive isatty? port Return @code{#t} if @var{port} is using a serial non--file device, otherwise @code{#f}. @end deffn fdopen -@c snarfed from ioext.c:349 +@c snarfed from ioext.c:352 @deffn primitive fdopen fdes modes Return a new port based on the file descriptor @var{fdes}. Modes are given by the string @var{modes}. The revealed count @@ -2344,7 +2344,7 @@ same as that accepted by @ref{File Ports, open-file}. @end deffn primitive-move->fdes -@c snarfed from ioext.c:374 +@c snarfed from ioext.c:377 @deffn primitive primitive-move->fdes port fd Moves the underlying file descriptor for @var{port} to the integer value @var{fdes} without changing the revealed count of @var{port}. @@ -2355,7 +2355,7 @@ required value or @code{#t} if it was moved. @end deffn fdes->ports -@c snarfed from ioext.c:407 +@c snarfed from ioext.c:411 @deffn primitive fdes->ports fd Return a list of existing ports which have @var{fdes} as an underlying file descriptor, without changing their revealed @@ -2369,14 +2369,14 @@ Make a keyword object from a @var{symbol} that starts with a dash. @end deffn keyword? -@c snarfed from keywords.c:112 +@c snarfed from keywords.c:113 @deffn primitive keyword? obj Return @code{#t} if the argument @var{obj} is a keyword, else @code{#f}. @end deffn keyword-dash-symbol -@c snarfed from keywords.c:123 +@c snarfed from keywords.c:124 @deffn primitive keyword-dash-symbol keyword Return the dash symbol for @var{keyword}. This is the inverse of @code{make-keyword-from-dash-symbol}. @@ -2481,7 +2481,7 @@ if the last argument is not a proper list. @end deffn append! -@c snarfed from list.c:242 +@c snarfed from list.c:243 @deffn primitive append! . lists A destructive version of @code{append} (@pxref{Pairs and Lists,,,r4rs, The Revised^4 Report on Scheme}). The cdr field @@ -2491,21 +2491,21 @@ the mutated list. @end deffn last-pair -@c snarfed from list.c:268 +@c snarfed from list.c:269 @deffn primitive last-pair lst Return a pointer to the last pair in @var{lst}, signalling an error if @var{lst} is circular. @end deffn reverse -@c snarfed from list.c:298 +@c snarfed from list.c:299 @deffn primitive reverse lst Return a new list that contains the elements of @var{lst} but in reverse order. @end deffn reverse! -@c snarfed from list.c:332 +@c snarfed from list.c:333 @deffn primitive reverse! lst [new_tail] A destructive version of @code{reverse} (@pxref{Pairs and Lists,,,r4rs, The Revised^4 Report on Scheme}). The cdr of each cell in @var{lst} is @@ -2521,25 +2521,25 @@ of the modified list is not lost, it is wise to save the return value of @end deffn list-ref -@c snarfed from list.c:358 +@c snarfed from list.c:359 @deffn primitive list-ref list k Return the @var{k}th element from @var{list}. @end deffn list-set! -@c snarfed from list.c:382 +@c snarfed from list.c:383 @deffn primitive list-set! list k val Set the @var{k}th element of @var{list} to @var{val}. @end deffn list-cdr-ref -@c snarfed from list.c:405 +@c snarfed from list.c:406 @deffn primitive list-cdr-ref scm_list_tail @end deffn list-tail -@c snarfed from list.c:414 +@c snarfed from list.c:415 @deffn primitive list-tail lst k @deffnx primitive list-cdr-ref lst k Return the "tail" of @var{lst} beginning with its @var{k}th element. @@ -2551,26 +2551,26 @@ or returning the results of cdring @var{k} times down @var{lst}. @end deffn list-cdr-set! -@c snarfed from list.c:430 +@c snarfed from list.c:431 @deffn primitive list-cdr-set! list k val Set the @var{k}th cdr of @var{list} to @var{val}. @end deffn list-head -@c snarfed from list.c:459 +@c snarfed from list.c:460 @deffn primitive list-head lst k Copy the first @var{k} elements from @var{lst} into a new list, and return it. @end deffn list-copy -@c snarfed from list.c:483 +@c snarfed from list.c:484 @deffn primitive list-copy lst Return a (newly-created) copy of @var{lst}. @end deffn sloppy-memq -@c snarfed from list.c:517 +@c snarfed from list.c:518 @deffn primitive sloppy-memq x lst This procedure behaves like @code{memq}, but does no type or error checking. Its use is recommended only in writing Guile internals, @@ -2578,7 +2578,7 @@ not for high-level Scheme programs. @end deffn sloppy-memv -@c snarfed from list.c:534 +@c snarfed from list.c:535 @deffn primitive sloppy-memv x lst This procedure behaves like @code{memv}, but does no type or error checking. Its use is recommended only in writing Guile internals, @@ -2586,7 +2586,7 @@ not for high-level Scheme programs. @end deffn sloppy-member -@c snarfed from list.c:551 +@c snarfed from list.c:552 @deffn primitive sloppy-member x lst This procedure behaves like @code{member}, but does no type or error checking. Its use is recommended only in writing Guile internals, @@ -2594,7 +2594,7 @@ not for high-level Scheme programs. @end deffn memq -@c snarfed from list.c:591 +@c snarfed from list.c:592 @deffn primitive memq x lst Return the first sublist of @var{lst} whose car is @code{eq?} to @var{x} where the sublists of @var{lst} are the non-empty @@ -2605,7 +2605,7 @@ returned. @end deffn memv -@c snarfed from list.c:608 +@c snarfed from list.c:609 @deffn primitive memv x lst Return the first sublist of @var{lst} whose car is @code{eqv?} to @var{x} where the sublists of @var{lst} are the non-empty @@ -2616,7 +2616,7 @@ returned. @end deffn member -@c snarfed from list.c:629 +@c snarfed from list.c:630 @deffn primitive member x lst Return the first sublist of @var{lst} whose car is @code{equal?} to @var{x} where the sublists of @var{lst} are @@ -2627,7 +2627,7 @@ empty list) is returned. @end deffn delq! -@c snarfed from list.c:655 +@c snarfed from list.c:656 @deffn primitive delq! item lst @deffnx primitive delv! item lst @deffnx primitive delete! item lst @@ -2640,21 +2640,21 @@ destructive list functions, these functions cannot modify the binding of @end deffn delv! -@c snarfed from list.c:679 +@c snarfed from list.c:680 @deffn primitive delv! item lst Destructively remove all elements from @var{lst} that are @code{eqv?} to @var{item}. @end deffn delete! -@c snarfed from list.c:704 +@c snarfed from list.c:705 @deffn primitive delete! item lst Destructively remove all elements from @var{lst} that are @code{equal?} to @var{item}. @end deffn delq -@c snarfed from list.c:733 +@c snarfed from list.c:734 @deffn primitive delq item lst Return a newly-created copy of @var{lst} with elements @code{eq?} to @var{item} removed. This procedure mirrors @@ -2663,7 +2663,7 @@ Return a newly-created copy of @var{lst} with elements @end deffn delv -@c snarfed from list.c:746 +@c snarfed from list.c:747 @deffn primitive delv item lst Return a newly-created copy of @var{lst} with elements @code{eqv?} to @var{item} removed. This procedure mirrors @@ -2672,7 +2672,7 @@ Return a newly-created copy of @var{lst} with elements @end deffn delete -@c snarfed from list.c:759 +@c snarfed from list.c:760 @deffn primitive delete item lst Return a newly-created copy of @var{lst} with elements @code{equal?} to @var{item} removed. This procedure mirrors @@ -2681,7 +2681,7 @@ against @var{item} with @code{equal?}. @end deffn delq1! -@c snarfed from list.c:772 +@c snarfed from list.c:773 @deffn primitive delq1! item lst Like @code{delq!}, but only deletes the first occurrence of @var{item} from @var{lst}. Tests for equality using @@ -2689,7 +2689,7 @@ Like @code{delq!}, but only deletes the first occurrence of @end deffn delv1! -@c snarfed from list.c:800 +@c snarfed from list.c:801 @deffn primitive delv1! item lst Like @code{delv!}, but only deletes the first occurrence of @var{item} from @var{lst}. Tests for equality using @@ -2697,7 +2697,7 @@ Like @code{delv!}, but only deletes the first occurrence of @end deffn delete1! -@c snarfed from list.c:828 +@c snarfed from list.c:829 @deffn primitive delete1! item lst Like @code{delete!}, but only deletes the first occurrence of @var{item} from @var{lst}. Tests for equality using @@ -2790,7 +2790,7 @@ signalled. @end deffn procedure->syntax -@c snarfed from macros.c:60 +@c snarfed from macros.c:61 @deffn primitive procedure->syntax code Return a @dfn{macro} which, when a symbol defined to this value appears as the first symbol in an expression, returns the @@ -2799,7 +2799,7 @@ environment. @end deffn procedure->macro -@c snarfed from macros.c:82 +@c snarfed from macros.c:84 @deffn primitive procedure->macro code Return a @dfn{macro} which, when a symbol defined to this value appears as the first symbol in an expression, evaluates the @@ -2817,7 +2817,7 @@ passed to @var{code}. For example: @end deffn procedure->memoizing-macro -@c snarfed from macros.c:104 +@c snarfed from macros.c:107 @deffn primitive procedure->memoizing-macro code Return a @dfn{macro} which, when a symbol defined to this value appears as the first symbol in an expression, evaluates the @@ -2835,14 +2835,14 @@ passed to @var{proc}. For example: @end deffn macro? -@c snarfed from macros.c:116 +@c snarfed from macros.c:119 @deffn primitive macro? obj Return @code{#t} if @var{obj} is a regular macro, a memoizing macro or a syntax transformer. @end deffn macro-type -@c snarfed from macros.c:133 +@c snarfed from macros.c:137 @deffn primitive macro-type m Return one of the symbols @code{syntax}, @code{macro} or @code{macro!}, depending on whether @var{m} is a syntax @@ -2852,13 +2852,13 @@ returned. @end deffn macro-name -@c snarfed from macros.c:151 +@c snarfed from macros.c:155 @deffn primitive macro-name m Return the name of the macro @var{m}. @end deffn macro-transformer -@c snarfed from macros.c:162 +@c snarfed from macros.c:166 @deffn primitive macro-transformer m Return the transformer of the macro @var{m}. @end deffn @@ -2900,7 +2900,7 @@ the traditional dotted decimal representation. @end deffn inet-netof -@c snarfed from net_db.c:135 +@c snarfed from net_db.c:136 @deffn primitive inet-netof address Return the network number part of the given integer Internet address. @@ -2910,7 +2910,7 @@ address. @end deffn inet-lnaof -@c snarfed from net_db.c:152 +@c snarfed from net_db.c:153 @deffn primitive inet-lnaof address Return the local-address-with-network part of the given Internet address. @@ -2920,7 +2920,7 @@ Internet address. @end deffn inet-makeaddr -@c snarfed from net_db.c:169 +@c snarfed from net_db.c:171 @deffn primitive inet-makeaddr net lna Makes an Internet host address by combining the network number @var{net} with the local-address-within-network number @@ -2931,7 +2931,7 @@ Makes an Internet host address by combining the network number @end deffn gethost -@c snarfed from net_db.c:254 +@c snarfed from net_db.c:256 @deffn primitive gethost [host] @deffnx procedure gethostbyname hostname @deffnx procedure gethostbyaddr address @@ -2947,7 +2947,7 @@ Unusual conditions may result in errors thrown to the @end deffn getnet -@c snarfed from net_db.c:335 +@c snarfed from net_db.c:337 @deffn primitive getnet [net] @deffnx procedure getnetbyname net-name @deffnx procedure getnetbyaddr net-number @@ -2959,7 +2959,7 @@ given. @end deffn getproto -@c snarfed from net_db.c:385 +@c snarfed from net_db.c:387 @deffn primitive getproto [protocol] @deffnx procedure getprotobyname name @deffnx procedure getprotobynumber number @@ -2970,7 +2970,7 @@ argument. @code{getproto} will accept either type, behaving like @end deffn getserv -@c snarfed from net_db.c:452 +@c snarfed from net_db.c:454 @deffn primitive getserv [name [protocol]] @deffnx procedure getservbyname name protocol @deffnx procedure getservbyport port protocol @@ -2985,28 +2985,28 @@ as its first argument; if given no arguments, it behaves like @end deffn sethost -@c snarfed from net_db.c:491 +@c snarfed from net_db.c:493 @deffn primitive sethost [stayopen] If @var{stayopen} is omitted, this is equivalent to @code{endhostent}. Otherwise it is equivalent to @code{sethostent stayopen}. @end deffn setnet -@c snarfed from net_db.c:507 +@c snarfed from net_db.c:509 @deffn primitive setnet [stayopen] If @var{stayopen} is omitted, this is equivalent to @code{endnetent}. Otherwise it is equivalent to @code{setnetent stayopen}. @end deffn setproto -@c snarfed from net_db.c:523 +@c snarfed from net_db.c:525 @deffn primitive setproto [stayopen] If @var{stayopen} is omitted, this is equivalent to @code{endprotoent}. Otherwise it is equivalent to @code{setprotoent stayopen}. @end deffn setserv -@c snarfed from net_db.c:539 +@c snarfed from net_db.c:541 @deffn primitive setserv [stayopen] If @var{stayopen} is omitted, this is equivalent to @code{endservent}. Otherwise it is equivalent to @code{setservent stayopen}. @@ -3092,7 +3092,7 @@ arguments. @end deffn lognot -@c snarfed from numbers.c:1102 +@c snarfed from numbers.c:1103 @deffn primitive lognot n Return the integer which is the 2s-complement of the integer argument. @@ -3105,7 +3105,7 @@ argument. @end deffn integer-expt -@c snarfed from numbers.c:1118 +@c snarfed from numbers.c:1120 @deffn primitive integer-expt n k Return @var{n} raised to the non-negative integer exponent @var{k}. @@ -3118,7 +3118,7 @@ Return @var{n} raised to the non-negative integer exponent @end deffn ash -@c snarfed from numbers.c:1166 +@c snarfed from numbers.c:1167 @deffn primitive ash n cnt The function ash performs an arithmetic shift left by @var{cnt} bits (or shift right, if @var{cnt} is negative). 'Arithmetic' @@ -3136,7 +3136,7 @@ Formally, the function returns an integer equivalent to @end deffn bit-extract -@c snarfed from numbers.c:1219 +@c snarfed from numbers.c:1220 @deffn primitive bit-extract n start end Return the integer composed of the @var{start} (inclusive) through @var{end} (exclusive) bits of @var{n}. The @@ -3150,7 +3150,7 @@ through @var{end} (exclusive) bits of @var{n}. The @end deffn logcount -@c snarfed from numbers.c:1291 +@c snarfed from numbers.c:1292 @deffn primitive logcount n Return the number of bits in integer @var{n}. If integer is positive, the 1-bits in its binary representation are counted. @@ -3167,7 +3167,7 @@ representation are counted. If 0, 0 is returned. @end deffn integer-length -@c snarfed from numbers.c:1342 +@c snarfed from numbers.c:1343 @deffn primitive integer-length n Return the number of bits neccessary to represent @var{n}. @lisp @@ -3181,7 +3181,7 @@ Return the number of bits neccessary to represent @var{n}. @end deffn number->string -@c snarfed from numbers.c:2288 +@c snarfed from numbers.c:2289 @deffn primitive number->string n [radix] Return a string holding the external representation of the number @var{n} in the given @var{radix}. If @var{n} is @@ -3189,7 +3189,7 @@ inexact, a radix of 10 will be used. @end deffn string->number -@c snarfed from numbers.c:2873 +@c snarfed from numbers.c:2874 @deffn primitive string->number string [radix] Return a number of the maximally precise representation expressed by the given @var{string}. @var{radix} must be an @@ -3202,13 +3202,13 @@ syntactically valid notation for a number, then @end deffn number? -@c snarfed from numbers.c:2940 +@c snarfed from numbers.c:2941 @deffn primitive number? scm_number_p @end deffn complex? -@c snarfed from numbers.c:2952 +@c snarfed from numbers.c:2953 @deffn primitive complex? x Return @code{#t} if @var{x} is a complex number, @code{#f} else. Note that the sets of real, rational and integer @@ -3218,13 +3218,13 @@ rational or integer number. @end deffn real? -@c snarfed from numbers.c:2960 +@c snarfed from numbers.c:2961 @deffn primitive real? scm_real_p @end deffn rational? -@c snarfed from numbers.c:2973 +@c snarfed from numbers.c:2974 @deffn primitive rational? x Return @code{#t} if @var{x} is a rational number, @code{#f} else. Note that the set of integer values forms a subset of @@ -3235,28 +3235,28 @@ precision. @end deffn integer? -@c snarfed from numbers.c:2994 +@c snarfed from numbers.c:2995 @deffn primitive integer? x Return @code{#t} if @var{x} is an integer number, @code{#f} else. @end deffn inexact? -@c snarfed from numbers.c:3019 +@c snarfed from numbers.c:3020 @deffn primitive inexact? x Return @code{#t} if @var{x} is an inexact number, @code{#f} else. @end deffn $expt -@c snarfed from numbers.c:4071 +@c snarfed from numbers.c:4072 @deffn primitive $expt x y Return @var{x} raised to the power of @var{y}. This procedure does not accept complex arguments. @end deffn $atan2 -@c snarfed from numbers.c:4087 +@c snarfed from numbers.c:4088 @deffn primitive $atan2 x y Return the arc tangent of the two arguments @var{x} and @var{y}. This is similar to calculating the arc tangent of @@ -3266,20 +3266,20 @@ procedure does not accept complex arguments. @end deffn make-rectangular -@c snarfed from numbers.c:4100 +@c snarfed from numbers.c:4101 @deffn primitive make-rectangular real imaginary Return a complex number constructed of the given @var{real} and @var{imaginary} parts. @end deffn make-polar -@c snarfed from numbers.c:4113 +@c snarfed from numbers.c:4114 @deffn primitive make-polar x y Return the complex number @var{x} * e^(i * @var{y}). @end deffn inexact->exact -@c snarfed from numbers.c:4231 +@c snarfed from numbers.c:4232 @deffn primitive inexact->exact z Return an exact number that is numerically closest to @var{z}. @end deffn @@ -3361,21 +3361,21 @@ sense of @code{eq?}) from every previously existing object. @end deffn pair? -@c snarfed from pairs.c:93 +@c snarfed from pairs.c:94 @deffn primitive pair? x Return @code{#t} if @var{x} is a pair; otherwise return @code{#f}. @end deffn set-car! -@c snarfed from pairs.c:104 +@c snarfed from pairs.c:105 @deffn primitive set-car! pair value Stores @var{value} in the car field of @var{pair}. The value returned by @code{set-car!} is unspecified. @end deffn set-cdr! -@c snarfed from pairs.c:117 +@c snarfed from pairs.c:118 @deffn primitive set-cdr! pair value Stores @var{value} in the cdr field of @var{pair}. The value returned by @code{set-cdr!} is unspecified. @@ -3561,21 +3561,21 @@ Equivalent to @code{(or (input-port? @var{x}) (output-port? @end deffn port-closed? -@c snarfed from ports.c:828 +@c snarfed from ports.c:829 @deffn primitive port-closed? port Return @code{#t} if @var{port} is closed or @code{#f} if it is open. @end deffn eof-object? -@c snarfed from ports.c:839 +@c snarfed from ports.c:840 @deffn primitive eof-object? x Return @code{#t} if @var{x} is an end-of-file object; otherwise return @code{#f}. @end deffn force-output -@c snarfed from ports.c:853 +@c snarfed from ports.c:854 @deffn primitive force-output [port] Flush the specified output port, or the current output port if @var{port} is omitted. The current output buffer contents are passed to the @@ -3587,14 +3587,14 @@ The return value is unspecified. @end deffn flush-all-ports -@c snarfed from ports.c:871 +@c snarfed from ports.c:872 @deffn primitive flush-all-ports Equivalent to calling @code{force-output} on all open output ports. The return value is unspecified. @end deffn read-char -@c snarfed from ports.c:889 +@c snarfed from ports.c:890 @deffn primitive read-char [port] Return the next character available from @var{port}, updating @var{port} to point to the following character. If no more @@ -3602,7 +3602,7 @@ characters are available, the end-of-file object is returned. @end deffn peek-char -@c snarfed from ports.c:1205 +@c snarfed from ports.c:1207 @deffn primitive peek-char [port] Return the next character available from @var{port}, @emph{without} updating @var{port} to point to the following @@ -3619,7 +3619,7 @@ to @code{read-char} would have hung.} @end deffn unread-char -@c snarfed from ports.c:1226 +@c snarfed from ports.c:1228 @deffn primitive unread-char cobj [port] Place @var{char} in @var{port} so that it will be read by the next read operation. If called multiple times, the unread characters @@ -3628,7 +3628,7 @@ not supplied, the current input port is used. @end deffn unread-string -@c snarfed from ports.c:1249 +@c snarfed from ports.c:1251 @deffn primitive unread-string str port Place the string @var{str} in @var{port} so that its characters will be read in subsequent read operations. If called multiple times, the @@ -3637,7 +3637,7 @@ unread characters will be read again in last-in first-out order. If @end deffn seek -@c snarfed from ports.c:1285 +@c snarfed from ports.c:1290 @deffn primitive seek fd_port offset whence Sets the current position of @var{fd/port} to the integer @var{offset}, which is interpreted according to the value of @@ -3663,7 +3663,7 @@ that the current position of a port can be obtained using: @end deffn truncate-file -@c snarfed from ports.c:1326 +@c snarfed from ports.c:1331 @deffn primitive truncate-file object [length] Truncates the object referred to by @var{object} to at most @var{length} bytes. @var{object} can be a string containing a @@ -3674,19 +3674,19 @@ position. The return value is unspecified. @end deffn port-line -@c snarfed from ports.c:1380 +@c snarfed from ports.c:1385 @deffn primitive port-line port Return the current line number for @var{port}. @end deffn set-port-line! -@c snarfed from ports.c:1391 +@c snarfed from ports.c:1396 @deffn primitive set-port-line! port line Set the current line number for @var{port} to @var{line}. @end deffn port-column -@c snarfed from ports.c:1412 +@c snarfed from ports.c:1417 @deffn primitive port-column port @deffnx primitive port-line port Return the current column number or line number of @var{port}, @@ -3700,7 +3700,7 @@ what non-programmers will find most natural.) @end deffn set-port-column! -@c snarfed from ports.c:1425 +@c snarfed from ports.c:1430 @deffn primitive set-port-column! port column @deffnx primitive set-port-line! port line Set the current column or line number of @var{port}, using the @@ -3708,7 +3708,7 @@ current input port if none is specified. @end deffn port-filename -@c snarfed from ports.c:1440 +@c snarfed from ports.c:1445 @deffn primitive port-filename port Return the filename associated with @var{port}. This function returns the strings "standard input", "standard output" and "standard error" @@ -3716,7 +3716,7 @@ when called on the current input, output and error ports respectively. @end deffn set-port-filename! -@c snarfed from ports.c:1454 +@c snarfed from ports.c:1459 @deffn primitive set-port-filename! port filename Change the filename associated with @var{port}, using the current input port if none is specified. Note that this does not change the port's @@ -3725,7 +3725,7 @@ source of data, but only the value that is returned by @end deffn %make-void-port -@c snarfed from ports.c:1546 +@c snarfed from ports.c:1551 @deffn primitive %make-void-port mode Create and return a new void port. A void port acts like /dev/null. The @var{mode} argument @@ -3751,14 +3751,14 @@ from the input port. @end deffn getgroups -@c snarfed from posix.c:221 +@c snarfed from posix.c:222 @deffn primitive getgroups Return a vector of integers representing the current supplimentary group IDs. @end deffn getpw -@c snarfed from posix.c:254 +@c snarfed from posix.c:255 @deffn primitive getpw [user] Look up an entry in the user database. @var{obj} can be an integer, a string, or omitted, giving the behaviour of getpwuid, getpwnam @@ -3766,7 +3766,7 @@ or getpwent respectively. @end deffn setpw -@c snarfed from posix.c:307 +@c snarfed from posix.c:308 @deffn primitive setpw [arg] If called with a true argument, initialize or reset the password data stream. Otherwise, close the stream. The @code{setpwent} and @@ -3774,7 +3774,7 @@ stream. Otherwise, close the stream. The @code{setpwent} and @end deffn getgr -@c snarfed from posix.c:326 +@c snarfed from posix.c:327 @deffn primitive getgr [name] Look up an entry in the group database. @var{obj} can be an integer, a string, or omitted, giving the behaviour of getgrgid, getgrnam @@ -3782,7 +3782,7 @@ or getgrent respectively. @end deffn setgr -@c snarfed from posix.c:367 +@c snarfed from posix.c:368 @deffn primitive setgr [arg] If called with a true argument, initialize or reset the group data stream. Otherwise, close the stream. The @code{setgrent} and @@ -3790,7 +3790,7 @@ stream. Otherwise, close the stream. The @code{setgrent} and @end deffn kill -@c snarfed from posix.c:403 +@c snarfed from posix.c:404 @deffn primitive kill pid sig Sends a signal to the specified process or group of processes. @@ -3822,7 +3822,7 @@ Interrupt signal. @end deffn waitpid -@c snarfed from posix.c:451 +@c snarfed from posix.c:452 @deffn primitive waitpid pid [options] This procedure collects status information from a child process which has terminated or (optionally) stopped. Normally it will @@ -3868,7 +3868,7 @@ The integer status value. @end deffn status:exit-val -@c snarfed from posix.c:478 +@c snarfed from posix.c:479 @deffn primitive status:exit-val status Return the exit status value, as would be set if a process ended normally through a call to @code{exit} or @code{_exit}, @@ -3876,40 +3876,40 @@ if any, otherwise @code{#f}. @end deffn status:term-sig -@c snarfed from posix.c:498 +@c snarfed from posix.c:499 @deffn primitive status:term-sig status Return the signal number which terminated the process, if any, otherwise @code{#f}. @end deffn status:stop-sig -@c snarfed from posix.c:516 +@c snarfed from posix.c:517 @deffn primitive status:stop-sig status Return the signal number which stopped the process, if any, otherwise @code{#f}. @end deffn getppid -@c snarfed from posix.c:533 +@c snarfed from posix.c:535 @deffn primitive getppid Return an integer representing the process ID of the parent process. @end deffn getuid -@c snarfed from posix.c:544 +@c snarfed from posix.c:546 @deffn primitive getuid Return an integer representing the current real user ID. @end deffn getgid -@c snarfed from posix.c:555 +@c snarfed from posix.c:557 @deffn primitive getgid Return an integer representing the current real group ID. @end deffn geteuid -@c snarfed from posix.c:569 +@c snarfed from posix.c:571 @deffn primitive geteuid Return an integer representing the current effective user ID. If the system does not support effective IDs, then the real ID @@ -3918,7 +3918,7 @@ system supports effective IDs. @end deffn getegid -@c snarfed from posix.c:587 +@c snarfed from posix.c:589 @deffn primitive getegid Return an integer representing the current effective group ID. If the system does not support effective IDs, then the real ID @@ -3927,7 +3927,7 @@ system supports effective IDs. @end deffn setuid -@c snarfed from posix.c:603 +@c snarfed from posix.c:605 @deffn primitive setuid id Sets both the real and effective user IDs to the integer @var{id}, provided the process has appropriate privileges. @@ -3935,7 +3935,7 @@ The return value is unspecified. @end deffn setgid -@c snarfed from posix.c:617 +@c snarfed from posix.c:619 @deffn primitive setgid id Sets both the real and effective group IDs to the integer @var{id}, provided the process has appropriate privileges. @@ -3943,7 +3943,7 @@ The return value is unspecified. @end deffn seteuid -@c snarfed from posix.c:633 +@c snarfed from posix.c:635 @deffn primitive seteuid id Sets the effective user ID to the integer @var{id}, provided the process has appropriate privileges. If effective IDs are not supported, the @@ -3953,7 +3953,7 @@ The return value is unspecified. @end deffn setegid -@c snarfed from posix.c:657 +@c snarfed from posix.c:659 @deffn primitive setegid id Sets the effective group ID to the integer @var{id}, provided the process has appropriate privileges. If effective IDs are not supported, the @@ -3963,14 +3963,14 @@ The return value is unspecified. @end deffn getpgrp -@c snarfed from posix.c:679 +@c snarfed from posix.c:681 @deffn primitive getpgrp Return an integer representing the current process group ID. This is the POSIX definition, not BSD. @end deffn setpgid -@c snarfed from posix.c:695 +@c snarfed from posix.c:697 @deffn primitive setpgid pid pgid Move the process @var{pid} into the process group @var{pgid}. @var{pid} or @var{pgid} must be integers: they can be zero to indicate the ID of the @@ -3980,7 +3980,7 @@ The return value is unspecified. @end deffn setsid -@c snarfed from posix.c:714 +@c snarfed from posix.c:716 @deffn primitive setsid Creates a new session. The current process becomes the session leader and is put in a new process group. The process will be detached @@ -3989,21 +3989,21 @@ The return value is an integer representing the new process group ID. @end deffn ttyname -@c snarfed from posix.c:728 +@c snarfed from posix.c:730 @deffn primitive ttyname port Return a string with the name of the serial terminal device underlying @var{port}. @end deffn ctermid -@c snarfed from posix.c:751 +@c snarfed from posix.c:753 @deffn primitive ctermid Return a string containing the file name of the controlling terminal for the current process. @end deffn tcgetpgrp -@c snarfed from posix.c:773 +@c snarfed from posix.c:776 @deffn primitive tcgetpgrp port Return the process group ID of the foreground process group associated with the terminal open on the file descriptor @@ -4017,7 +4017,7 @@ foreground. @end deffn tcsetpgrp -@c snarfed from posix.c:797 +@c snarfed from posix.c:800 @deffn primitive tcsetpgrp port pgid Set the foreground process group ID for the terminal used by the file descriptor underlying @var{port} to the integer @var{pgid}. @@ -4027,7 +4027,7 @@ controlling terminal. The return value is unspecified. @end deffn execl -@c snarfed from posix.c:857 +@c snarfed from posix.c:860 @deffn primitive execl filename . args Executes the file named by @var{path} as a new process image. The remaining arguments are supplied to the process; from a C program @@ -4043,7 +4043,7 @@ call, but we call it @code{execl} because of its Scheme calling interface. @end deffn execlp -@c snarfed from posix.c:878 +@c snarfed from posix.c:881 @deffn primitive execlp filename . args Similar to @code{execl}, however if @var{filename} does not contain a slash @@ -4055,7 +4055,7 @@ call, but we call it @code{execlp} because of its Scheme calling interface. @end deffn execle -@c snarfed from posix.c:929 +@c snarfed from posix.c:932 @deffn primitive execle filename env . args Similar to @code{execl}, but the environment of the new process is specified by @var{env}, which must be a list of strings as returned by the @@ -4066,7 +4066,7 @@ call, but we call it @code{execle} because of its Scheme calling interface. @end deffn primitive-fork -@c snarfed from posix.c:953 +@c snarfed from posix.c:956 @deffn primitive primitive-fork Creates a new "child" process by duplicating the current "parent" process. In the child the return value is 0. In the parent the return value is @@ -4077,14 +4077,14 @@ with the scsh fork. @end deffn uname -@c snarfed from posix.c:968 +@c snarfed from posix.c:971 @deffn primitive uname Return an object with some information about the computer system the program is running on. @end deffn environ -@c snarfed from posix.c:997 +@c snarfed from posix.c:1001 @deffn primitive environ [env] If @var{env} is omitted, return the current environment (in the Unix sense) as a list of strings. Otherwise set the current @@ -4096,7 +4096,7 @@ then the return value is unspecified. @end deffn tmpnam -@c snarfed from posix.c:1035 +@c snarfed from posix.c:1039 @deffn primitive tmpnam Return a name in the file system that does not match any existing file. However there is no guarantee that another @@ -4106,7 +4106,7 @@ Care should be taken if opening the file, e.g., use the @end deffn mkstemp! -@c snarfed from posix.c:1058 +@c snarfed from posix.c:1061 @deffn primitive mkstemp! tmpl Create a new unique file in the file system and returns a new buffered port open for reading and writing to the file. @@ -4116,7 +4116,7 @@ place to return the name of the temporary file. @end deffn utime -@c snarfed from posix.c:1086 +@c snarfed from posix.c:1087 @deffn primitive utime pathname [actime [modtime]] @code{utime} sets the access and modification times for the file named by @var{path}. If @var{actime} or @var{modtime} is @@ -4131,7 +4131,7 @@ modification time to the current time. @end deffn access? -@c snarfed from posix.c:1135 +@c snarfed from posix.c:1136 @deffn primitive access? path how Return @code{#t} if @var{path} corresponds to an existing file and the current process has the type of access specified by @@ -4157,13 +4157,13 @@ test for existence of the file. @end deffn getpid -@c snarfed from posix.c:1150 +@c snarfed from posix.c:1151 @deffn primitive getpid Return an integer representing the current process ID. @end deffn putenv -@c snarfed from posix.c:1167 +@c snarfed from posix.c:1168 @deffn primitive putenv str Modifies the environment of the current process, which is also the default environment inherited by child processes. @@ -4179,7 +4179,7 @@ The return value is unspecified. @end deffn setlocale -@c snarfed from posix.c:1198 +@c snarfed from posix.c:1199 @deffn primitive setlocale category [locale] If @var{locale} is omitted, return the current value of the specified locale category as a system-dependent string. @@ -4192,7 +4192,7 @@ the locale will be set using envirionment variables. @end deffn mknod -@c snarfed from posix.c:1239 +@c snarfed from posix.c:1240 @deffn primitive mknod path type perms dev Creates a new special file, such as a file corresponding to a device. @var{path} specifies the name of the file. @var{type} should @@ -4212,7 +4212,7 @@ The return value is unspecified. @end deffn nice -@c snarfed from posix.c:1286 +@c snarfed from posix.c:1287 @deffn primitive nice incr Increment the priority of the current process by @var{incr}. A higher priority value means that the process runs less often. @@ -4220,21 +4220,21 @@ The return value is unspecified. @end deffn sync -@c snarfed from posix.c:1301 +@c snarfed from posix.c:1302 @deffn primitive sync Flush the operating system disk buffers. The return value is unspecified. @end deffn crypt -@c snarfed from posix.c:1314 +@c snarfed from posix.c:1315 @deffn primitive crypt key salt Encrypt @var{key} using @var{salt} as the salt value to the crypt(3) library call @end deffn chroot -@c snarfed from posix.c:1337 +@c snarfed from posix.c:1338 @deffn primitive chroot path Change the root directory to that specified in @var{path}. This directory will be used for path names beginning with @@ -4244,7 +4244,7 @@ root directory. @end deffn getlogin -@c snarfed from posix.c:1355 +@c snarfed from posix.c:1356 @deffn primitive getlogin Return a string containing the name of the user logged in on the controlling terminal of the process, or @code{#f} if this @@ -4252,7 +4252,7 @@ information cannot be obtained. @end deffn cuserid -@c snarfed from posix.c:1373 +@c snarfed from posix.c:1374 @deffn primitive cuserid Return a string containing a user name associated with the effective user id of the process. Return @code{#f} if this @@ -4260,7 +4260,7 @@ information cannot be obtained. @end deffn getpriority -@c snarfed from posix.c:1398 +@c snarfed from posix.c:1399 @deffn primitive getpriority which who Return the scheduling priority of the process, process group or user, as indicated by @var{which} and @var{who}. @var{which} @@ -4275,7 +4275,7 @@ specified processes. @end deffn setpriority -@c snarfed from posix.c:1432 +@c snarfed from posix.c:1433 @deffn primitive setpriority which who prio Set the scheduling priority of the process, process group or user, as indicated by @var{which} and @var{who}. @var{which} @@ -4293,7 +4293,7 @@ The return value is not specified. @end deffn getpass -@c snarfed from posix.c:1457 +@c snarfed from posix.c:1458 @deffn primitive getpass prompt Display @var{prompt} to the standard error output and read a password from @file{/dev/tty}. If this file is not @@ -4305,7 +4305,7 @@ characters is disabled. @end deffn flock -@c snarfed from posix.c:1496 +@c snarfed from posix.c:1497 @deffn primitive flock file operation Apply or remove an advisory lock on an open file. @var{operation} specifies the action to be done: @@ -4327,7 +4327,7 @@ file descriptor or an open file descriptior port. @end deffn sethostname -@c snarfed from posix.c:1522 +@c snarfed from posix.c:1523 @deffn primitive sethostname name Set the host name of the current processor to @var{name}. May only be used by the superuser. The return value is not @@ -4335,7 +4335,7 @@ specified. @end deffn gethostname -@c snarfed from posix.c:1538 +@c snarfed from posix.c:1539 @deffn primitive gethostname Return the host name of the current processor. @end deffn @@ -4350,7 +4350,7 @@ and @code{print-options}. @end deffn simple-format -@c snarfed from print.c:980 +@c snarfed from print.c:976 @deffn primitive simple-format destination message . args Write @var{message} to @var{destination}, defaulting to the current output port. @@ -4366,26 +4366,26 @@ containing the formatted text. Does not add a trailing newline. @end deffn newline -@c snarfed from print.c:1045 +@c snarfed from print.c:1041 @deffn primitive newline [port] Send a newline to @var{port}. @end deffn write-char -@c snarfed from print.c:1060 +@c snarfed from print.c:1056 @deffn primitive write-char chr [port] Send character @var{chr} to @var{port}. @end deffn port-with-print-state -@c snarfed from print.c:1114 +@c snarfed from print.c:1110 @deffn primitive port-with-print-state port pstate Create a new port which behaves like @var{port}, but with an included print state @var{pstate}. @end deffn get-print-state -@c snarfed from print.c:1129 +@c snarfed from print.c:1125 @deffn primitive get-print-state port Return the print state of the port @var{port}. If @var{port} has no associated print state, @code{#f} is returned. @@ -4474,7 +4474,7 @@ See @code{primitive-property-ref} for the significance of @end deffn primitive-property-ref -@c snarfed from properties.c:83 +@c snarfed from properties.c:84 @deffn primitive primitive-property-ref prop obj Return the property @var{prop} of @var{obj}. When no value has yet been associated with @var{prop} and @var{obj}, call @@ -4486,13 +4486,13 @@ default value of @var{prop}. @end deffn primitive-property-set! -@c snarfed from properties.c:111 +@c snarfed from properties.c:115 @deffn primitive primitive-property-set! prop obj val Associate @var{code} with @var{prop} and @var{obj}. @end deffn primitive-property-del! -@c snarfed from properties.c:131 +@c snarfed from properties.c:136 @deffn primitive primitive-property-del! prop obj Remove any value associated with @var{prop} and @var{obj}. @end deffn @@ -4596,14 +4596,14 @@ Return a new random state using @var{seed}. @end deffn random:uniform -@c snarfed from random.c:418 +@c snarfed from random.c:419 @deffn primitive random:uniform [state] Return a uniformly distributed inexact real random number in [0,1). @end deffn random:normal -@c snarfed from random.c:433 +@c snarfed from random.c:434 @deffn primitive random:normal [state] Return an inexact real in a normal distribution. The distribution used has mean 0 and standard deviation 1. For a @@ -4612,7 +4612,7 @@ normal distribution with mean m and standard deviation d use @end deffn random:solid-sphere! -@c snarfed from random.c:489 +@c snarfed from random.c:490 @deffn primitive random:solid-sphere! v [state] Fills vect with inexact real random numbers the sum of whose squares is less than 1.0. @@ -4623,7 +4623,7 @@ The sum of the squares of the numbers is returned. @end deffn random:hollow-sphere! -@c snarfed from random.c:512 +@c snarfed from random.c:513 @deffn primitive random:hollow-sphere! v [state] Fills vect with inexact real random numbers the sum of whose squares is equal to 1.0. @@ -4634,7 +4634,7 @@ unit n-shere. @end deffn random:normal-vector! -@c snarfed from random.c:530 +@c snarfed from random.c:531 @deffn primitive random:normal-vector! v [state] Fills vect with inexact real random numbers that are independent and standard normally distributed @@ -4642,7 +4642,7 @@ independent and standard normally distributed @end deffn random:exp -@c snarfed from random.c:554 +@c snarfed from random.c:556 @deffn primitive random:exp [state] Return an inexact real in an exponential distribution with mean 1. For an exponential distribution with mean u use (* u @@ -4725,7 +4725,7 @@ or @code{#f} otherwise. @end deffn make-regexp -@c snarfed from regex-posix.c:179 +@c snarfed from regex-posix.c:184 @deffn primitive make-regexp pat . flags Compile the regular expression described by @var{pat}, and return the compiled regexp structure. If @var{pat} does not @@ -4765,7 +4765,7 @@ one which comes last will override the earlier one. @end deffn regexp-exec -@c snarfed from regex-posix.c:226 +@c snarfed from regex-posix.c:232 @deffn primitive regexp-exec rx str [start [flags]] Match the compiled regular expression @var{rx} against @code{str}. If the optional integer @var{start} argument is @@ -4914,7 +4914,7 @@ Sends a specified signal @var{sig} to the current process, where @end deffn system -@c snarfed from simpos.c:76 +@c snarfed from simpos.c:78 @deffn primitive system [cmd] Execute @var{cmd} using the operating system's "command processor". Under Unix this is usually the default shell @@ -4926,7 +4926,7 @@ indicating whether the command processor is available. @end deffn getenv -@c snarfed from simpos.c:104 +@c snarfed from simpos.c:106 @deffn primitive getenv nam Looks up the string @var{name} in the current environment. The return value is @code{#f} unless a string of the form @code{NAME=VALUE} is @@ -4934,7 +4934,7 @@ found, in which case the string @code{VALUE} is returned. @end deffn primitive-exit -@c snarfed from simpos.c:120 +@c snarfed from simpos.c:122 @deffn primitive primitive-exit [status] Terminate the current process without unwinding the Scheme stack. This is would typically be useful after a fork. The exit status @@ -4974,7 +4974,7 @@ a C unsigned long integer. @end deffn socket -@c snarfed from socket.c:158 +@c snarfed from socket.c:161 @deffn primitive socket family style proto Return a new socket port of the type specified by @var{family}, @var{style} and @var{protocol}. All three parameters are @@ -4990,7 +4990,7 @@ has been connected to another socket. @end deffn socketpair -@c snarfed from socket.c:180 +@c snarfed from socket.c:183 @deffn primitive socketpair family style proto Return a pair of connected (but unnamed) socket ports of the type specified by @var{family}, @var{style} and @var{protocol}. @@ -5000,7 +5000,7 @@ family. Zero is likely to be the only meaningful value for @end deffn getsockopt -@c snarfed from socket.c:209 +@c snarfed from socket.c:213 @deffn primitive getsockopt sock level optname Return the value of a particular socket option for the socket port @var{socket}. @var{level} is an integer code for type of @@ -5013,7 +5013,7 @@ returns a pair of integers. @end deffn setsockopt -@c snarfed from socket.c:277 +@c snarfed from socket.c:281 @deffn primitive setsockopt sock level optname value Sets the value of a particular socket option for the socket port @var{socket}. @var{level} is an integer code for type of option @@ -5029,7 +5029,7 @@ The return value is unspecified. @end deffn shutdown -@c snarfed from socket.c:381 +@c snarfed from socket.c:385 @deffn primitive shutdown sock how Sockets can be closed simply by using @code{close-port}. The @code{shutdown} procedure allows reception or tranmission on a @@ -5051,7 +5051,7 @@ The return value is unspecified. @end deffn connect -@c snarfed from socket.c:474 +@c snarfed from socket.c:478 @deffn primitive connect sock fam address . args Initiates a connection from @var{socket} to the address specified by @var{address} and possibly @var{arg @dots{}}. The format @@ -5070,7 +5070,7 @@ The return value is unspecified. @end deffn bind -@c snarfed from socket.c:528 +@c snarfed from socket.c:532 @deffn primitive bind sock fam address . args Assigns an address to the socket port @var{socket}. Generally this only needs to be done for server sockets, @@ -5111,7 +5111,7 @@ The return value is unspecified. @end deffn listen -@c snarfed from socket.c:561 +@c snarfed from socket.c:565 @deffn primitive listen sock backlog This procedure enables @var{socket} to accept connection requests. @var{backlog} is an integer specifying @@ -5123,7 +5123,7 @@ The return value is unspecified. @end deffn accept -@c snarfed from socket.c:637 +@c snarfed from socket.c:641 @deffn primitive accept sock Accepts a connection on a bound, listening socket @var{socket}. If there are no pending connections in the queue, it waits until @@ -5142,7 +5142,7 @@ connection and will continue to accept new requests. @end deffn getsockname -@c snarfed from socket.c:668 +@c snarfed from socket.c:672 @deffn primitive getsockname sock Return the address of @var{socket}, in the same form as the object returned by @code{accept}. On many systems the address @@ -5150,7 +5150,7 @@ of a socket in the @code{AF_FILE} namespace cannot be read. @end deffn getpeername -@c snarfed from socket.c:695 +@c snarfed from socket.c:699 @deffn primitive getpeername sock Return the address of the socket that the socket @var{socket} is connected to, in the same form as the object returned by @@ -5159,7 +5159,7 @@ is connected to, in the same form as the object returned by @end deffn recv! -@c snarfed from socket.c:730 +@c snarfed from socket.c:734 @deffn primitive recv! sock buf [flags] Receives data from the socket port @var{socket}. @var{socket} must already be bound to the address from which data is to be received. @@ -5179,7 +5179,7 @@ any unread buffered port data is ignored. @end deffn send -@c snarfed from socket.c:759 +@c snarfed from socket.c:763 @deffn primitive send sock message [flags] Transmits the string @var{message} on the socket port @var{socket}. @var{socket} must already be bound to a destination address. The @@ -5193,7 +5193,7 @@ any unflushed buffered port data is ignored. @end deffn recvfrom! -@c snarfed from socket.c:797 +@c snarfed from socket.c:805 @deffn primitive recvfrom! sock str [flags [start [end]]] Return data from the socket port @var{socket} and also information about where the data was received from. @@ -5215,7 +5215,7 @@ descriptor: any unread buffered port data is ignored. @end deffn sendto -@c snarfed from socket.c:848 +@c snarfed from socket.c:856 @deffn primitive sendto sock message fam address . args_and_flags Transmits the string @var{message} on the socket port @var{socket}. The destination address is specified using the @var{family}, @var{address} and @@ -5462,14 +5462,14 @@ Return @code{#t} if @var{frame} is an overflow frame. @end deffn get-internal-real-time -@c snarfed from stime.c:141 +@c snarfed from stime.c:142 @deffn primitive get-internal-real-time Return the number of time units since the interpreter was started. @end deffn times -@c snarfed from stime.c:183 +@c snarfed from stime.c:187 @deffn primitive times Return an object with information about real and processor time. The following procedures accept such an object as an @@ -5494,7 +5494,7 @@ terminated child processes. @end deffn get-internal-run-time -@c snarfed from stime.c:214 +@c snarfed from stime.c:219 @deffn primitive get-internal-run-time Return the number of time units of processor time used by the interpreter. Both @emph{system} and @emph{user} time are @@ -5502,14 +5502,14 @@ included but subprocesses are not. @end deffn current-time -@c snarfed from stime.c:224 +@c snarfed from stime.c:229 @deffn primitive current-time Return the number of seconds since 1970-01-01 00:00:00 UTC, excluding leap seconds. @end deffn gettimeofday -@c snarfed from stime.c:241 +@c snarfed from stime.c:247 @deffn primitive gettimeofday Return a pair containing the number of seconds and microseconds since 1970-01-01 00:00:00 UTC, excluding leap seconds. Note: @@ -5518,7 +5518,7 @@ operating system. @end deffn localtime -@c snarfed from stime.c:341 +@c snarfed from stime.c:347 @deffn primitive localtime time [zone] Return an object representing the broken down components of @var{time}, an integer like the one returned by @@ -5528,7 +5528,7 @@ optionally specified by @var{zone} (a string), otherwise the @end deffn gmtime -@c snarfed from stime.c:413 +@c snarfed from stime.c:419 @deffn primitive gmtime time Return an object representing the broken down components of @var{time}, an integer like the one returned by @@ -5536,7 +5536,7 @@ Return an object representing the broken down components of @end deffn mktime -@c snarfed from stime.c:475 +@c snarfed from stime.c:481 @deffn primitive mktime sbd_time [zone] @var{bd-time} is an object representing broken down time and @code{zone} is an optional time zone specifier (otherwise the TZ environment variable @@ -5549,7 +5549,7 @@ as @var{bd-time} but with normalized values. @end deffn tzset -@c snarfed from stime.c:548 +@c snarfed from stime.c:554 @deffn primitive tzset Initialize the timezone from the TZ environment variable or the system default. It's not usually necessary to call this procedure @@ -5558,7 +5558,7 @@ timezone. @end deffn strftime -@c snarfed from stime.c:565 +@c snarfed from stime.c:571 @deffn primitive strftime format stime Formats a time specification @var{time} using @var{template}. @var{time} is an object with time components in the form returned by @code{localtime} @@ -5570,7 +5570,7 @@ is the formatted string. @end deffn strptime -@c snarfed from stime.c:663 +@c snarfed from stime.c:669 @deffn primitive strptime format string Performs the reverse action to @code{strftime}, parsing @var{string} according to the specification supplied in @@ -5592,30 +5592,20 @@ Return @code{#t} iff @var{obj} is a string, else returns @end deffn read-only-string? -@c snarfed from strings.c:85 +@c snarfed from strings.c:78 @deffn primitive read-only-string? obj -Return true if @var{obj} can be read as a string, - -This illustrates the difference between @code{string?} and -@code{read-only-string?}: - -@lisp -(string? "a string") @result{} #t -(string? 'a-symbol) @result{} #f - -(read-only-string? "a string") @result{} #t -(read-only-string? 'a-symbol) @result{} #t -@end lisp +Return @code{#t} if @var{obj} is either a string or a symbol, +otherwise return @code{#f}. @end deffn list->string -@c snarfed from strings.c:94 +@c snarfed from strings.c:87 @deffn primitive list->string scm_string @end deffn string -@c snarfed from strings.c:100 +@c snarfed from strings.c:93 @deffn primitive string . chrs @deffnx primitive list->string chrs Return a newly allocated string composed of the arguments, @@ -5623,7 +5613,7 @@ Return a newly allocated string composed of the arguments, @end deffn make-string -@c snarfed from strings.c:253 +@c snarfed from strings.c:246 @deffn primitive make-string k [chr] Return a newly allocated string of length @var{k}. If @var{chr} is given, then all elements of @@ -5632,20 +5622,20 @@ of the @var{string} are unspecified. @end deffn string-length -@c snarfed from strings.c:286 +@c snarfed from strings.c:279 @deffn primitive string-length string Return the number of characters in @var{string}. @end deffn string-ref -@c snarfed from strings.c:297 +@c snarfed from strings.c:290 @deffn primitive string-ref str k Return character @var{k} of @var{str} using zero-origin indexing. @var{k} must be a valid index of @var{str}. @end deffn string-set! -@c snarfed from strings.c:314 +@c snarfed from strings.c:307 @deffn primitive string-set! str k chr Store @var{chr} in element @var{k} of @var{str} and return an unspecified value. @var{k} must be a valid index of @@ -5653,7 +5643,7 @@ an unspecified value. @var{k} must be a valid index of @end deffn substring -@c snarfed from strings.c:337 +@c snarfed from strings.c:330 @deffn primitive substring str start [end] Return a newly allocated string formed from the characters of @var{str} beginning with index @var{start} (inclusive) and @@ -5665,14 +5655,14 @@ exact integers satisfying: @end deffn string-append -@c snarfed from strings.c:360 +@c snarfed from strings.c:353 @deffn primitive string-append . args Return a newly allocated string whose characters form the concatenation of the given strings, @var{args}. @end deffn make-shared-substring -@c snarfed from strings.c:400 +@c snarfed from strings.c:393 @deffn primitive make-shared-substring str [start [end]] Return a shared substring of @var{str}. The semantics are the same as for the @code{substring} function: the shared substring @@ -5684,7 +5674,7 @@ occupies the same storage space as @var{str}. @end deffn string-index -@c snarfed from strop.c:121 +@c snarfed from strop.c:116 @deffn primitive string-index str chr [frm [to]] Return the index of the first occurrence of @var{chr} in @var{str}. The optional integer arguments @var{frm} and @@ -5704,7 +5694,7 @@ procedure essentially implements the @code{index} or @end deffn string-rindex -@c snarfed from strop.c:152 +@c snarfed from strop.c:146 @deffn primitive string-rindex str chr [frm [to]] Like @code{string-index}, but search from the right of the string rather than from the left. This procedure essentially @@ -5723,19 +5713,19 @@ the C library. @end deffn substring-move-left! -@c snarfed from strop.c:169 +@c snarfed from strop.c:163 @deffn primitive substring-move-left! scm_substring_move_x @end deffn substring-move-right! -@c snarfed from strop.c:170 +@c snarfed from strop.c:164 @deffn primitive substring-move-right! scm_substring_move_x @end deffn substring-move! -@c snarfed from strop.c:244 +@c snarfed from strop.c:238 @deffn primitive substring-move! str1 start1 end1 str2 start2 @deffnx primitive substring-move-left! str1 start1 end1 str2 start2 @deffnx primitive substring-move-right! str1 start1 end1 str2 start2 @@ -5758,7 +5748,7 @@ are different strings, it does not matter which function you use. @end deffn substring-fill! -@c snarfed from strop.c:280 +@c snarfed from strop.c:274 @deffn primitive substring-fill! str start end fill Change every character in @var{str} between @var{start} and @var{end} to @var{fill}. @@ -5771,7 +5761,7 @@ y @end deffn string-null? -@c snarfed from strop.c:307 +@c snarfed from strop.c:299 @deffn primitive string-null? str Return @code{#t} if @var{str}'s length is nonzero, and @code{#f} otherwise. @@ -5783,7 +5773,7 @@ y @result{} "foo" @end deffn string->list -@c snarfed from strop.c:323 +@c snarfed from strop.c:313 @deffn primitive string->list str Return a newly allocated list of the characters that make up the given string @var{str}. @code{string->list} and @@ -5792,20 +5782,20 @@ concerned. @end deffn string-copy -@c snarfed from strop.c:348 +@c snarfed from strop.c:338 @deffn primitive string-copy str Return a newly allocated copy of the given @var{string}. @end deffn string-fill! -@c snarfed from strop.c:361 +@c snarfed from strop.c:351 @deffn primitive string-fill! str chr Store @var{char} in every element of the given @var{string} and return an unspecified value. @end deffn string-upcase! -@c snarfed from strop.c:397 +@c snarfed from strop.c:386 @deffn primitive string-upcase! str Destructively upcase every character in @var{str} and return @var{str}. @@ -5817,14 +5807,14 @@ y @result{} "ARRDEFG" @end deffn string-upcase -@c snarfed from strop.c:409 +@c snarfed from strop.c:399 @deffn primitive string-upcase str Return a freshly allocated string containing the characters of @var{str} in upper case. @end deffn string-downcase! -@c snarfed from strop.c:444 +@c snarfed from strop.c:431 @deffn primitive string-downcase! str Destructively downcase every character in @var{str} and return @var{str}. @@ -5836,14 +5826,14 @@ y @result{} "arrdefg" @end deffn string-downcase -@c snarfed from strop.c:456 +@c snarfed from strop.c:444 @deffn primitive string-downcase str Return a freshly allocation string containing the characters in @var{str} in lower case. @end deffn string-capitalize! -@c snarfed from strop.c:493 +@c snarfed from strop.c:488 @deffn primitive string-capitalize! str Upcase the first character of every word in @var{str} destructively and return @var{str}. @@ -5855,7 +5845,7 @@ y @result{} "Hello World" @end deffn string-capitalize -@c snarfed from strop.c:505 +@c snarfed from strop.c:502 @deffn primitive string-capitalize str Return a freshly allocated string with the characters in @var{str}, where the first character of every word is @@ -5863,7 +5853,7 @@ capitalized. @end deffn string-ci->symbol -@c snarfed from strop.c:517 +@c snarfed from strop.c:516 @deffn primitive string-ci->symbol str Return the symbol whose name is @var{str}. @var{str} is converted to lowercase before the conversion is done, if Guile @@ -5899,28 +5889,28 @@ is lexicographically less than @var{s2}. @end deffn string<=? -@c snarfed from strorder.c:171 +@c snarfed from strorder.c:170 @deffn primitive string<=? s1 s2 Lexicographic ordering predicate; return @code{#t} if @var{s1} is lexicographically less than or equal to @var{s2}. @end deffn string>? -@c snarfed from strorder.c:185 +@c snarfed from strorder.c:184 @deffn primitive string>? s1 s2 Lexicographic ordering predicate; return @code{#t} if @var{s1} is lexicographically greater than @var{s2}. @end deffn string>=? -@c snarfed from strorder.c:200 +@c snarfed from strorder.c:198 @deffn primitive string>=? s1 s2 Lexicographic ordering predicate; return @code{#t} if @var{s1} is lexicographically greater than or equal to @var{s2}. @end deffn string-ci? -@c snarfed from strorder.c:269 +@c snarfed from strorder.c:267 @deffn primitive string-ci>? s1 s2 Case insensitive lexicographic ordering predicate; return @code{#t} if @var{s1} is lexicographically greater than @@ -5944,7 +5934,7 @@ Case insensitive lexicographic ordering predicate; return @end deffn string-ci>=? -@c snarfed from strorder.c:284 +@c snarfed from strorder.c:282 @deffn primitive string-ci>=? s1 s2 Case insensitive lexicographic ordering predicate; return @code{#t} if @var{s1} is lexicographically greater than or @@ -6182,7 +6172,7 @@ Return @code{#t} if @var{obj} is a symbol, otherwise return @end deffn symbol->string -@c snarfed from symbols.c:451 +@c snarfed from symbols.c:453 @deffn primitive symbol->string s Return the name of @var{symbol} as a string. If the symbol was part of an object returned as the value of a literal expression @@ -6208,7 +6198,7 @@ standard case is lower case: @end deffn string->symbol -@c snarfed from symbols.c:478 +@c snarfed from symbols.c:483 @deffn primitive string->symbol string Return the symbol whose name is @var{string}. This procedure can create symbols with names containing special characters or @@ -6231,7 +6221,7 @@ standard case is lower case: @end deffn string->obarray-symbol -@c snarfed from symbols.c:499 +@c snarfed from symbols.c:505 @deffn primitive string->obarray-symbol o s [softp] Intern a new symbol in @var{obarray}, a symbol table, with name @var{string}. @@ -6249,7 +6239,7 @@ table; instead, simply return @code{#f}. @end deffn intern-symbol -@c snarfed from symbols.c:531 +@c snarfed from symbols.c:537 @deffn primitive intern-symbol o s Add a new symbol to @var{obarray} with name @var{string}, bound to an unspecified initial value. The symbol table is not modified if a symbol @@ -6257,7 +6247,7 @@ with this name is already present. @end deffn unintern-symbol -@c snarfed from symbols.c:568 +@c snarfed from symbols.c:574 @deffn primitive unintern-symbol o s Remove the symbol with name @var{string} from @var{obarray}. This function returns @code{#t} if the symbol was present and @code{#f} @@ -6265,7 +6255,7 @@ otherwise. @end deffn symbol-binding -@c snarfed from symbols.c:609 +@c snarfed from symbols.c:615 @deffn primitive symbol-binding o s Look up in @var{obarray} the symbol whose name is @var{string}, and return the value to which it is bound. If @var{obarray} is @code{#f}, @@ -6274,14 +6264,14 @@ use the global symbol table. If @var{string} is not interned in @end deffn symbol-interned? -@c snarfed from symbols.c:626 +@c snarfed from symbols.c:632 @deffn primitive symbol-interned? o s Return @code{#t} if @var{obarray} contains a symbol with name @var{string}, and @code{#f} otherwise. @end deffn symbol-bound? -@c snarfed from symbols.c:649 +@c snarfed from symbols.c:655 @deffn primitive symbol-bound? o s Return @code{#t} if @var{obarray} contains a symbol with name @var{string} bound to a defined value. This differs from @@ -6292,7 +6282,7 @@ value. @end deffn symbol-set! -@c snarfed from symbols.c:667 +@c snarfed from symbols.c:673 @deffn primitive symbol-set! o s v Find the symbol in @var{obarray} whose name is @var{string}, and rebind it to @var{value}. An error is signalled if @var{string} is not present @@ -6300,44 +6290,44 @@ in @var{obarray}. @end deffn symbol-fref -@c snarfed from symbols.c:684 +@c snarfed from symbols.c:690 @deffn primitive symbol-fref s Return the contents of @var{symbol}'s @dfn{function slot}. @end deffn symbol-pref -@c snarfed from symbols.c:695 +@c snarfed from symbols.c:701 @deffn primitive symbol-pref s Return the @dfn{property list} currently associated with @var{symbol}. @end deffn symbol-fset! -@c snarfed from symbols.c:706 +@c snarfed from symbols.c:712 @deffn primitive symbol-fset! s val Change the binding of @var{symbol}'s function slot. @end deffn symbol-pset! -@c snarfed from symbols.c:718 +@c snarfed from symbols.c:724 @deffn primitive symbol-pset! s val Change the binding of @var{symbol}'s property slot. @end deffn symbol-hash -@c snarfed from symbols.c:732 +@c snarfed from symbols.c:738 @deffn primitive symbol-hash symbol Return a hash value for @var{symbol}. @end deffn builtin-bindings -@c snarfed from symbols.c:769 +@c snarfed from symbols.c:775 @deffn primitive builtin-bindings Create and return a copy of the global symbol table, removing all unbound symbols. @end deffn gensym -@c snarfed from symbols.c:790 +@c snarfed from symbols.c:796 @deffn primitive 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 @@ -6347,7 +6337,7 @@ resetting the counter. @end deffn gentemp -@c snarfed from symbols.c:829 +@c snarfed from symbols.c:835 @deffn primitive gentemp [prefix [obarray]] Create a new symbol with a name unique in an obarray. The name is constructed from an optional string @var{prefix} @@ -6365,7 +6355,7 @@ Return an integer corresponding to the type of X. Deprecated. @end deffn catch -@c snarfed from throw.c:529 +@c snarfed from throw.c:535 @deffn primitive catch key thunk handler Invoke @var{thunk} in the dynamic context of @var{handler} for exceptions matching @var{key}. If thunk throws to the symbol @@ -6384,7 +6374,7 @@ match this call to @code{catch}. @end deffn lazy-catch -@c snarfed from throw.c:556 +@c snarfed from throw.c:562 @deffn primitive lazy-catch key thunk handler This behaves exactly like @code{catch}, except that it does not unwind the stack (this is the major difference), and if @@ -6392,7 +6382,7 @@ handler returns, its value is returned from the throw. @end deffn throw -@c snarfed from throw.c:589 +@c snarfed from throw.c:595 @deffn primitive throw key . args Invoke the catch form matching @var{key}, passing @var{args} to the @var{handler}. @@ -6483,7 +6473,7 @@ it can be otherwise arbitrary. A simple example: @end deffn transpose-array -@c snarfed from unif.c:802 +@c snarfed from unif.c:804 @deffn primitive transpose-array ra . args Return an array sharing contents with @var{array}, but with dimensions arranged in a different order. There must be one @@ -6505,7 +6495,7 @@ have smaller rank than @var{array}. @end deffn enclose-array -@c snarfed from unif.c:911 +@c snarfed from unif.c:913 @deffn primitive enclose-array ra . axes @var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than the rank of @var{array}. @var{enclose-array} returns an array @@ -6531,20 +6521,20 @@ examples: @end deffn array-in-bounds? -@c snarfed from unif.c:994 +@c snarfed from unif.c:997 @deffn primitive array-in-bounds? v . args Return @code{#t} if its arguments would be acceptable to @code{array-ref}. @end deffn array-ref -@c snarfed from unif.c:1073 +@c snarfed from unif.c:1076 @deffn primitive array-ref scm_uniform_vector_ref @end deffn uniform-vector-ref -@c snarfed from unif.c:1079 +@c snarfed from unif.c:1083 @deffn primitive uniform-vector-ref v args @deffnx primitive array-ref v . args Return the element at the @code{(index1, index2)} element in @@ -6552,13 +6542,13 @@ Return the element at the @code{(index1, index2)} element in @end deffn uniform-array-set1! -@c snarfed from unif.c:1248 +@c snarfed from unif.c:1252 @deffn primitive uniform-array-set1! scm_array_set_x @end deffn array-set! -@c snarfed from unif.c:1257 +@c snarfed from unif.c:1261 @deffn primitive array-set! v obj . args @deffnx primitive uniform-array-set1! v obj args Sets the element at the @code{(index1, index2)} element in @var{array} to @@ -6566,7 +6556,7 @@ Sets the element at the @code{(index1, index2)} element in @var{array} to @end deffn array-contents -@c snarfed from unif.c:1372 +@c snarfed from unif.c:1376 @deffn primitive array-contents ra [strict] @deffnx primitive array-contents array strict If @var{array} may be @dfn{unrolled} into a one dimensional shared array @@ -6582,7 +6572,7 @@ memory. @end deffn uniform-array-read! -@c snarfed from unif.c:1486 +@c snarfed from unif.c:1490 @deffn primitive uniform-array-read! ra [port_or_fd [start [end]]] @deffnx primitive uniform-vector-read! uve [port-or-fdes] [start] [end] Attempts to read all elements of @var{ura}, in lexicographic order, as @@ -6602,7 +6592,7 @@ returned by @code{(current-input-port)}. @end deffn uniform-array-write -@c snarfed from unif.c:1649 +@c snarfed from unif.c:1653 @deffn primitive uniform-array-write v [port_or_fd [start [end]]] @deffnx primitive uniform-vector-write uve [port-or-fdes] [start] [end] Writes all elements of @var{ura} as binary objects to @@ -6619,14 +6609,14 @@ omitted, in which case it defaults to the value returned by @end deffn bit-count -@c snarfed from unif.c:1774 +@c snarfed from unif.c:1778 @deffn primitive bit-count b bitvector Return the number of occurrences of the boolean @var{b} in @var{bitvector}. @end deffn bit-position -@c snarfed from unif.c:1813 +@c snarfed from unif.c:1817 @deffn primitive bit-position item v k Return the minimum index of an occurrence of @var{bool} in @var{bv} which is at least @var{k}. If no @var{bool} occurs @@ -6634,7 +6624,7 @@ within the specified range @code{#f} is returned. @end deffn bit-set*! -@c snarfed from unif.c:1881 +@c snarfed from unif.c:1885 @deffn primitive bit-set*! v kv obj If uve is a bit-vector @var{bv} and uve must be of the same length. If @var{bool} is @code{#t}, uve is OR'ed into @@ -6648,7 +6638,7 @@ of @var{bv} corresponding to the indexes in uve are set to @end deffn bit-count* -@c snarfed from unif.c:1935 +@c snarfed from unif.c:1939 @deffn primitive bit-count* v kv obj Return @lisp @@ -6658,20 +6648,20 @@ Return @end deffn bit-invert! -@c snarfed from unif.c:1999 +@c snarfed from unif.c:2003 @deffn primitive bit-invert! v Modifies @var{bv} by replacing each element with its negation. @end deffn array->list -@c snarfed from unif.c:2077 +@c snarfed from unif.c:2082 @deffn primitive array->list v Return a list consisting of all the elements, in order, of @var{array}. @end deffn list->uniform-array -@c snarfed from unif.c:2169 +@c snarfed from unif.c:2175 @deffn primitive list->uniform-array ndim prot lst @deffnx procedure list->uniform-vector prot lst Return a uniform array of the type indicated by prototype @@ -6681,7 +6671,7 @@ done. @end deffn array-prototype -@c snarfed from unif.c:2520 +@c snarfed from unif.c:2526 @deffn primitive array-prototype ra Return an object that would produce an array of the same type as @var{array}, if used as the @var{prototype} for @@ -6689,7 +6679,7 @@ as @var{array}, if used as the @var{prototype} for @end deffn values -@c snarfed from values.c:83 +@c snarfed from values.c:80 @deffn primitive values . args Delivers all of its arguments to its continuation. Except for continuations created by the @code{call-with-values} procedure, @@ -6698,28 +6688,8 @@ passing no value or more than one value to continuations that were not created by @code{call-with-values} is unspecified. @end deffn - call-with-values -@c snarfed from values.c:116 -@deffn primitive call-with-values producer consumer -Calls its @var{producer} argument with no values and a -continuation that, when passed some values, calls the -@var{consumer} procedure with those values as arguments. The -continuation for the call to @var{consumer} is the continuation -of the call to @code{call-with-values}. - -@example -(call-with-values (lambda () (values 4 5)) - (lambda (a b) b)) - ==> 5 - -@end example -@example -(call-with-values * -) ==> -1 -@end example -@end deffn - make-variable -@c snarfed from variable.c:100 +@c snarfed from variable.c:99 @deffn primitive make-variable init [name_hint] Return a variable object initialized to value @var{init}. If given, uses @var{name-hint} as its internal (debugging) @@ -6729,7 +6699,7 @@ variable may exist, so @var{name-hint} is just that---a hint. @end deffn make-undefined-variable -@c snarfed from variable.c:124 +@c snarfed from variable.c:119 @deffn primitive make-undefined-variable [name_hint] Return a variable object initialized to an undefined value. If given, uses @var{name-hint} as its internal (debugging) @@ -6739,14 +6709,14 @@ variable may exist, so @var{name-hint} is just that---a hint. @end deffn variable? -@c snarfed from variable.c:145 +@c snarfed from variable.c:136 @deffn primitive variable? obj Return @code{#t} iff @var{obj} is a variable object, else return @code{#f} @end deffn variable-ref -@c snarfed from variable.c:157 +@c snarfed from variable.c:148 @deffn primitive variable-ref var Dereference @var{var} and return its value. @var{var} must be a variable object; see @code{make-variable} @@ -6754,7 +6724,7 @@ and @code{make-undefined-variable}. @end deffn variable-set! -@c snarfed from variable.c:171 +@c snarfed from variable.c:162 @deffn primitive variable-set! var val Set the value of the variable @var{var} to @var{val}. @var{var} must be a variable object, @var{val} can be any @@ -6762,7 +6732,7 @@ value. Return an unspecified value. @end deffn builtin-variable -@c snarfed from variable.c:185 +@c snarfed from variable.c:176 @deffn primitive builtin-variable name Return the built-in variable with the name @var{name}. @var{name} must be a symbol (not a string). @@ -6770,7 +6740,7 @@ Then use @code{variable-ref} to access its value. @end deffn variable-bound? -@c snarfed from variable.c:213 +@c snarfed from variable.c:204 @deffn primitive variable-bound? var Return @code{#t} iff @var{var} is bound to a value. Throws an error if @var{var} is not a variable object. @@ -6790,7 +6760,7 @@ scm_vector @end deffn vector -@c snarfed from vectors.c:177 +@c snarfed from vectors.c:178 @deffn primitive vector . l @deffnx primitive list->vector l Return a newly allocated vector whose elements contain the @@ -6801,7 +6771,7 @@ given arguments. Analogous to @code{list}. @end deffn make-vector -@c snarfed from vectors.c:255 +@c snarfed from vectors.c:264 @deffn primitive make-vector k [fill] Return a newly allocated vector of @var{k} elements. If a second argument is given, then each element is initialized to @@ -6810,7 +6780,7 @@ unspecified. @end deffn vector->list -@c snarfed from vectors.c:311 +@c snarfed from vectors.c:321 @deffn primitive vector->list v Return a newly allocated list of the objects contained in the elements of @var{vector}. @@ -6821,20 +6791,20 @@ elements of @var{vector}. @end deffn vector-fill! -@c snarfed from vectors.c:328 +@c snarfed from vectors.c:338 @deffn primitive vector-fill! v fill Store @var{fill} in every element of @var{vector}. The value returned by @code{vector-fill!} is unspecified. @end deffn vector-move-left! -@c snarfed from vectors.c:355 +@c snarfed from vectors.c:365 @deffn primitive vector-move-left! vec1 start1 end1 vec2 start2 Vector version of @code{substring-move-left!}. @end deffn vector-move-right! -@c snarfed from vectors.c:378 +@c snarfed from vectors.c:388 @deffn primitive vector-move-right! vec1 start1 end1 vec2 start2 Vector version of @code{substring-move-right!}. @end deffn @@ -6869,7 +6839,7 @@ version numbers, respectively. @end deffn make-soft-port -@c snarfed from vports.c:184 +@c snarfed from vports.c:190 @deffn primitive make-soft-port pv modes Return a port capable of receiving or delivering characters as specified by the @var{modes} string (@pxref{File Ports, @@ -6910,7 +6880,7 @@ For example: @end deffn make-weak-vector -@c snarfed from weaks.c:62 +@c snarfed from weaks.c:63 @deffn primitive make-weak-vector size [fill] Return a weak vector with @var{size} elements. If the optional argument @var{fill} is given, all entries in the vector will be @@ -6919,13 +6889,13 @@ empty list. @end deffn list->weak-vector -@c snarfed from weaks.c:79 +@c snarfed from weaks.c:80 @deffn primitive list->weak-vector scm_weak_vector @end deffn weak-vector -@c snarfed from weaks.c:87 +@c snarfed from weaks.c:88 @deffn primitive weak-vector . l @deffnx primitive list->weak-vector l Construct a weak vector from a list: @code{weak-vector} uses @@ -6935,14 +6905,14 @@ the same way @code{list->vector} would. @end deffn weak-vector? -@c snarfed from weaks.c:110 +@c snarfed from weaks.c:116 @deffn primitive weak-vector? obj Return @code{#t} if @var{obj} is a weak vector. Note that all weak hashes are also weak vectors. @end deffn make-weak-key-hash-table -@c snarfed from weaks.c:130 +@c snarfed from weaks.c:138 @deffn primitive make-weak-key-hash-table size @deffnx primitive make-weak-value-hash-table size @deffnx primitive make-doubly-weak-hash-table size @@ -6954,21 +6924,21 @@ would modify regular hash tables. (@pxref{Hash Tables}) @end deffn make-weak-value-hash-table -@c snarfed from weaks.c:147 -@deffn primitive make-weak-value-hash-table k +@c snarfed from weaks.c:155 +@deffn primitive make-weak-value-hash-table size Return a hash table with weak values with @var{size} buckets. (@pxref{Hash Tables}) @end deffn make-doubly-weak-hash-table -@c snarfed from weaks.c:165 -@deffn primitive make-doubly-weak-hash-table k +@c snarfed from weaks.c:173 +@deffn primitive make-doubly-weak-hash-table size Return a hash table with weak keys and values with @var{size} buckets. (@pxref{Hash Tables}) @end deffn weak-key-hash-table? -@c snarfed from weaks.c:184 +@c snarfed from weaks.c:192 @deffn primitive weak-key-hash-table? obj @deffnx primitive weak-value-hash-table? obj @deffnx primitive doubly-weak-hash-table? obj @@ -6978,13 +6948,13 @@ nor a weak value hash table. @end deffn weak-value-hash-table? -@c snarfed from weaks.c:194 -@deffn primitive weak-value-hash-table? x -Return @code{#t} if @var{x} is a weak value hash table. +@c snarfed from weaks.c:202 +@deffn primitive weak-value-hash-table? obj +Return @code{#t} if @var{obj} is a weak value hash table. @end deffn doubly-weak-hash-table? -@c snarfed from weaks.c:204 -@deffn primitive doubly-weak-hash-table? x -Return @code{#t} if @var{x} is a doubly weak hash table. +@c snarfed from weaks.c:212 +@deffn primitive doubly-weak-hash-table? obj +Return @code{#t} if @var{obj} is a doubly weak hash table. @end deffn diff --git a/doc/scheme-data.texi b/doc/scheme-data.texi index d317ba5a7..cd982ab34 100755 --- a/doc/scheme-data.texi +++ b/doc/scheme-data.texi @@ -1346,8 +1346,6 @@ called with string containing unusal characters. * Alphabetic Case Mapping:: Convert the alphabetic case of strings. * Appending Strings:: Appending strings to form a new string. * String Miscellanea:: Miscellaneous string procedures. -* Shared Substrings:: Strings which share memory with each other. -* Read Only Strings:: Treating certain non-strings as strings. @end menu @node String Syntax @@ -1772,122 +1770,6 @@ is currently reading symbols case--insensitively. @end deffn -@node Shared Substrings -@subsection Shared Substrings - -[FIXME: this is pasted in from Tom Lord's original guile.texi and should -be reviewed] - -@c FIXME::martin: Shared substrings are gone, so this section should die. - -Whenever you extract a substring using @code{substring}, the Scheme -interpreter allocates a new string and copies data from the old string. -This is expensive, but @code{substring} is so convenient for -manipulating text that programmers use it often. - -Guile Scheme provides the concept of the @dfn{shared substring} to -improve performance of many substring-related operations. A shared -substring is an object that mostly behaves just like an ordinary -substring, except that it actually shares storage space with its parent -string. - -@deffn primitive make-shared-substring str [start [end]] -Return a shared substring of @var{str}. The semantics are the -same as for the @code{substring} function: the shared substring -returned includes all of the text from @var{str} between -indexes @var{start} (inclusive) and @var{end} (exclusive). If -@var{end} is omitted, it defaults to the end of @var{str}. The -shared substring returned by @code{make-shared-substring} -occupies the same storage space as @var{str}. -@end deffn - -Example: - -@example -(define foo "the quick brown fox") -(define bar (make-shared-substring some-string 4 9)) - -foo => "t h e q u i c k b r o w n f o x" -bar =========> |---------| -@end example - -The shared substring @var{bar} is not given its own storage space. -Instead, the Guile interpreter notes internally that @var{bar} points to -a portion of the memory allocated to @var{foo}. However, @var{bar} -behaves like an ordinary string in most respects: it may be used with -string primitives like @code{string-length}, @code{string-ref}, -@code{string=?}. Guile makes the necessary translation between indices -of @var{bar} and indices of @var{foo} automatically. - -@example -(string-length? bar) @result{} 5 ; bar only extends from indices 4 to 9 -(string-ref bar 3) @result{} #\c ; same as (string-ref foo 7) -(make-shared-substring bar 2) - @result{} "ick" ; can even make a shared substring! -@end example - -Because creating a shared substring does not require allocating new -storage from the heap, it is a very fast operation. However, because it -shares memory with its parent string, a change to the contents of the -parent string will implicitly change the contents of its shared -substrings. - -@example -(string-set! foo 7 #\r) -bar @result{} "quirk" -@end example - -Guile considers shared substrings to be immutable. This is because -programmers might not always be aware that a given string is really a -shared substring, and might innocently try to mutate it without -realizing that the change would affect its parent string. (We are -currently considering a "copy-on-write" strategy that would permit -modifying shared substrings without affecting the parent string.) - -In general, shared substrings are useful in circumstances where it is -important to divide a string into smaller portions, but you do not -expect to change the contents of any of the strings involved. - -@node Read Only Strings -@subsection Read Only Strings - -@c FIXME::martin: Read-only strings are gone, too, so this section should -@c also die. - -Type-checking in Guile primitives distinguishes between mutable strings -and read only strings. Mutable strings answer @code{#t} to -@code{string?} while read only strings may or may not. All kinds of -strings, whether or not they are mutable return #t to this: - -@deffn primitive read-only-string? obj -Return true if @var{obj} can be read as a string, - -This illustrates the difference between @code{string?} and -@code{read-only-string?}: - -@lisp -(string? "a string") @result{} #t -(string? 'a-symbol) @result{} #f - -(read-only-string? "a string") @result{} #t -(read-only-string? 'a-symbol) @result{} #t -@end lisp -@end deffn - -"Read-only" refers to how the string will be used, not how the string is -permitted to be used. In particular, all strings are "read-only -strings" even if they are mutable, because a function that only reads -from a string can certainly operate on even a mutable string. - -Symbols are an example of read-only strings. Many string functions, -such as @code{string-append} are happy to operate on symbols. Many -functions that expect a string argument, such as @code{open-file}, will -accept a symbol as well. - -Shared substrings, discussed in the previous chapter, also happen to be -read-only strings. - - @node Regular Expressions @section Regular Expressions diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 28dcdc262..cdcae34d7 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-04-09 Neil Jerram + + * strings.c (scm_read_only_string_p): Update docstring to reflect + current (non-)usage of "read only" strings. + 2001-04-06 Martin Grabmueller * hooks.c (scm_make_hook, scm_make_hook_with_name), diff --git a/libguile/strings.c b/libguile/strings.c index 70d831907..476493eef 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -74,15 +74,8 @@ SCM_DEFINE (scm_string_p, "string?", 1, 0, 0, SCM_DEFINE (scm_read_only_string_p, "read-only-string?", 1, 0, 0, (SCM obj), - "Return true if @var{obj} can be read as a string,\n\n" - "This illustrates the difference between @code{string?} and\n" - "@code{read-only-string?}:\n\n" - "@lisp\n" - "(string? \"a string\") @result{} #t\n" - "(string? 'a-symbol) @result{} #f\n\n" - "(read-only-string? \"a string\") @result{} #t\n" - "(read-only-string? 'a-symbol) @result{} #t\n" - "@end lisp") + "Return @code{#t} if @var{obj} is either a string or a symbol,\n" + "otherwise return @code{#f}.") #define FUNC_NAME s_scm_read_only_string_p { return SCM_BOOL(SCM_ROSTRINGP (obj)); From 40f83c3e1b5cb1d440f785d857981417c5fa6f85 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Mon, 9 Apr 2001 21:46:44 +0000 Subject: [PATCH 0800/2047] * Clarify docstring for scm_make_shared_substring. --- libguile/ChangeLog | 2 ++ libguile/strings.c | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index cdcae34d7..652ea6b2e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -2,6 +2,8 @@ * strings.c (scm_read_only_string_p): Update docstring to reflect current (non-)usage of "read only" strings. + (scm_make_shared_substring): Clarify docstring by changing + "semantics" to "arguments". 2001-04-06 Martin Grabmueller diff --git a/libguile/strings.c b/libguile/strings.c index 476493eef..c4843ebf5 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -384,7 +384,7 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, SCM_DEFINE (scm_make_shared_substring, "make-shared-substring", 1, 2, 0, (SCM str, SCM start, SCM end), - "Return a shared substring of @var{str}. The semantics are the\n" + "Return a shared substring of @var{str}. The arguments are the\n" "same as for the @code{substring} function: the shared substring\n" "returned includes all of the text from @var{str} between\n" "indexes @var{start} (inclusive) and @var{end} (exclusive). If\n" From e4b265d817c6758441bbfc66730cae98eabde9b5 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 10 Apr 2001 07:57:05 +0000 Subject: [PATCH 0801/2047] * Avoid redundant casting of argument numbers to char* and vice versa. --- libguile/ChangeLog | 23 +++++++++++++++++++++++ libguile/environments.c | 6 +++--- libguile/filesys.c | 8 ++++---- libguile/gh_data.c | 14 ++++++++------ libguile/net_db.c | 12 ++++++------ libguile/numbers.c | 16 ++++++++-------- libguile/numbers.h | 11 ++++++----- libguile/posix.c | 6 +++--- libguile/ramap.c | 8 ++++---- libguile/scmsigs.c | 6 +++--- libguile/socket.c | 10 +++++----- libguile/stime.c | 6 +++--- libguile/struct.c | 2 +- libguile/unif.c | 6 +++--- libguile/validate.h | 14 +++++++------- 15 files changed, 87 insertions(+), 61 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 652ea6b2e..48474f24f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,26 @@ +2001-04-10 Dirk Herrmann + + * numbers.[ch] (scm_num2long, scm_num2long_long, + scm_num2ulong_long, scm_num2ulong): Argument position is an + unsigned integer. + + * environments.c (eval_environment_folder, + import_environment_folder), gh_data.c (gh_scm2longs, + gh_scm2floats, gh_scm2doubles): Distinguish between 0 and NULL + for integers and pointers, respectively. + + * gh_data.c (gh_scm2ulong, gh_scm2long, gh_scm2int), socket.c + (scm_fill_sockaddr), unif.c (scm_array_set_x), validate.h + (SCM_NUM2ULONG, SCM_NUM2LONG, SCM_NUM2LONG_DEF, + SCM_NUM2LONG_LONG): Don't pass argument positions as pointers. + + * filesys.c (scm_open_fdes, scm_open), net_db (scm_inet_ntoa, + scm_inet_netof, scm_lnaof, scm_gethost, scm_getproto), posix.c + (scm_utime), ramap.c (scm_array_fill_int), scmsigs.c + (scm_sigaction), socket.c (scm_htonl, scm_ntohl, scm_sendto), + stime.c (scm_localtime, scm_gmtime), struct.c (scm_struct_set_x), + validate.h (SCM_VALIDATE_LONG_COPY): Whitespace fixes. + 2001-04-09 Neil Jerram * strings.c (scm_read_only_string_p): Update docstring to reflect diff --git a/libguile/environments.c b/libguile/environments.c index 4facb164b..c7b9f2d85 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1999,2000,2001 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 @@ -1246,7 +1246,7 @@ eval_environment_folder (SCM extended_data, SCM symbol, SCM value, SCM tail) if (!SCM_ENVIRONMENT_BOUND_P (local, symbol)) { SCM proc_as_nr = SCM_CADR (extended_data); - unsigned long int proc_as_ul = scm_num2ulong (proc_as_nr, NULL, NULL); + unsigned long int proc_as_ul = scm_num2ulong (proc_as_nr, 0, NULL); scm_environment_folder proc = (scm_environment_folder) proc_as_ul; SCM data = SCM_CDDR (extended_data); @@ -1652,7 +1652,7 @@ import_environment_folder (SCM extended_data, SCM symbol, SCM value, SCM tail) SCM imported_env = SCM_CADR (extended_data); SCM owner = import_environment_lookup (import_env, symbol); SCM proc_as_nr = SCM_CADDR (extended_data); - unsigned long int proc_as_ul = scm_num2ulong (proc_as_nr, NULL, NULL); + unsigned long int proc_as_ul = scm_num2ulong (proc_as_nr, 0, NULL); scm_environment_folder proc = (scm_environment_folder) proc_as_ul; SCM data = SCM_CDDDR (extended_data); diff --git a/libguile/filesys.c b/libguile/filesys.c index 48f8dfa67..81b7522a7 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 Free Software Foundation, Inc. +/* Copyright (C) 1996,1997,1998,1999,2000,2001 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 @@ -243,8 +243,8 @@ SCM_DEFINE (scm_open_fdes, "open-fdes", 2, 1, 0, SCM_VALIDATE_STRING (1, path); SCM_STRING_COERCE_0TERMINATION_X (path); - iflags = SCM_NUM2LONG(2,flags); - imode = SCM_NUM2LONG_DEF(3,mode,0666); + iflags = SCM_NUM2LONG (2, flags); + imode = SCM_NUM2LONG_DEF (3, mode, 0666); SCM_SYSCALL (fd = open (SCM_STRING_CHARS (path), iflags, imode)); if (fd == -1) SCM_SYSERROR; @@ -286,7 +286,7 @@ SCM_DEFINE (scm_open, "open", 2, 1, 0, int iflags; fd = SCM_INUM (scm_open_fdes (path, flags, mode)); - iflags = SCM_NUM2LONG (2,flags); + iflags = SCM_NUM2LONG (2, flags); if (iflags & O_RDWR) { if (iflags & O_APPEND) diff --git a/libguile/gh_data.c b/libguile/gh_data.c index 3d6483fcb..e431208b3 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -229,18 +229,18 @@ gh_scm2bool (SCM obj) unsigned long gh_scm2ulong (SCM obj) { - return scm_num2ulong (obj, (char *) SCM_ARG1, "gh_scm2ulong"); + return scm_num2ulong (obj, SCM_ARG1, "gh_scm2ulong"); } long gh_scm2long (SCM obj) { - return scm_num2long (obj, (char *) SCM_ARG1, "gh_scm2long"); + return scm_num2long (obj, SCM_ARG1, "gh_scm2long"); } int gh_scm2int (SCM obj) { /* NOTE: possible loss of precision here */ - return (int) scm_num2long (obj, (char *) SCM_ARG1, "gh_scm2int"); + return (int) scm_num2long (obj, SCM_ARG1, "gh_scm2int"); } double gh_scm2double (SCM obj) @@ -395,7 +395,9 @@ gh_scm2longs (SCM obj, long *m) for (i = 0; i < n; ++i) { val = SCM_VELTS (obj)[i]; - m[i] = SCM_INUMP (val) ? SCM_INUM (val) : scm_num2long (val, 0, 0); + m[i] = SCM_INUMP (val) + ? SCM_INUM (val) + : scm_num2long (val, 0, NULL); } break; #ifdef HAVE_ARRAYS @@ -447,7 +449,7 @@ gh_scm2floats (SCM obj, float *m) if (SCM_INUMP (val)) m[i] = SCM_INUM (val); else if (SCM_BIGP (val)) - m[i] = scm_num2long (val, 0, 0); + m[i] = scm_num2long (val, 0, NULL); else m[i] = SCM_REAL_VALUE (val); } @@ -510,7 +512,7 @@ gh_scm2doubles (SCM obj, double *m) if (SCM_INUMP (val)) m[i] = SCM_INUM (val); else if (SCM_BIGP (val)) - m[i] = scm_num2long (val, 0, 0); + m[i] = scm_num2long (val, 0, NULL); else m[i] = SCM_REAL_VALUE (val); } diff --git a/libguile/net_db.c b/libguile/net_db.c index 2ef227f48..183a01f76 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -1,5 +1,5 @@ /* "net_db.c" network database support - * Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001 Free Software Foundation, Inc. + * Copyright (C) 1995,1996,1997,1998,1999,2000,2001 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 @@ -119,7 +119,7 @@ SCM_DEFINE (scm_inet_ntoa, "inet-ntoa", 1, 0, 0, struct in_addr addr; char *s; SCM answer; - addr.s_addr = htonl (SCM_NUM2ULONG (1,inetid)); + addr.s_addr = htonl (SCM_NUM2ULONG (1, inetid)); s = inet_ntoa (addr); answer = scm_makfromstr (s, strlen (s), 0); return answer; @@ -137,7 +137,7 @@ SCM_DEFINE (scm_inet_netof, "inet-netof", 1, 0, 0, #define FUNC_NAME s_scm_inet_netof { struct in_addr addr; - addr.s_addr = htonl (SCM_NUM2ULONG (1,address)); + addr.s_addr = htonl (SCM_NUM2ULONG (1, address)); return scm_ulong2num ((unsigned long) inet_netof (addr)); } #undef FUNC_NAME @@ -154,7 +154,7 @@ SCM_DEFINE (scm_lnaof, "inet-lnaof", 1, 0, 0, #define FUNC_NAME s_scm_lnaof { struct in_addr addr; - addr.s_addr = htonl (SCM_NUM2ULONG (1,address)); + addr.s_addr = htonl (SCM_NUM2ULONG (1, address)); return scm_ulong2num ((unsigned long) inet_lnaof (addr)); } #undef FUNC_NAME @@ -288,7 +288,7 @@ SCM_DEFINE (scm_gethost, "gethost", 0, 1, 0, } else { - inad.s_addr = htonl (SCM_NUM2ULONG (1,host)); + inad.s_addr = htonl (SCM_NUM2ULONG (1, host)); entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET); } if (!entry) @@ -412,7 +412,7 @@ SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0, else { unsigned long protonum; - protonum = SCM_NUM2ULONG (1,protocol); + protonum = SCM_NUM2ULONG (1, protocol); entry = getprotobynumber (protonum); } if (!entry) diff --git a/libguile/numbers.c b/libguile/numbers.c index c712b6544..9cac82d45 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -4358,7 +4358,7 @@ scm_ulong2num (unsigned long sl) long -scm_num2long (SCM num, char *pos, const char *s_caller) +scm_num2long (SCM num, unsigned long int pos, const char *s_caller) { if (SCM_INUMP (num)) { return SCM_INUM (num); @@ -4402,7 +4402,7 @@ scm_num2long (SCM num, char *pos, const char *s_caller) scm_out_of_range (s_caller, num); } } else { - scm_wrong_type_arg (s_caller, (int) pos, num); + scm_wrong_type_arg (s_caller, pos, num); } } @@ -4414,7 +4414,7 @@ scm_num2long (SCM num, char *pos, const char *s_caller) #endif long_long -scm_num2long_long (SCM num, char *pos, const char *s_caller) +scm_num2long_long (SCM num, unsigned long int pos, const char *s_caller) { if (SCM_INUMP (num)) { return SCM_INUM (num); @@ -4453,12 +4453,12 @@ scm_num2long_long (SCM num, char *pos, const char *s_caller) scm_out_of_range (s_caller, num); } } else { - scm_wrong_type_arg (s_caller, (int) pos, num); + scm_wrong_type_arg (s_caller, pos, num); } } ulong_long -scm_num2ulong_long (SCM num, char *pos, const char *s_caller) +scm_num2ulong_long (SCM num, unsigned long int pos, const char *s_caller) { if (SCM_INUMP (num)) { @@ -4493,14 +4493,14 @@ scm_num2ulong_long (SCM num, char *pos, const char *s_caller) scm_out_of_range (s_caller, num); } else - scm_wrong_type_arg (s_caller, (int) pos, num); + scm_wrong_type_arg (s_caller, pos, num); } #endif /* HAVE_LONG_LONGS */ unsigned long -scm_num2ulong (SCM num, char *pos, const char *s_caller) +scm_num2ulong (SCM num, unsigned long int pos, const char *s_caller) { if (SCM_INUMP (num)) { long nnum = SCM_INUM (num); @@ -4531,7 +4531,7 @@ scm_num2ulong (SCM num, char *pos, const char *s_caller) scm_out_of_range (s_caller, num); } } else { - scm_wrong_type_arg (s_caller, (int) pos, num); + scm_wrong_type_arg (s_caller, pos, num); } } diff --git a/libguile/numbers.h b/libguile/numbers.h index 076768e33..c8e00b480 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -2,7 +2,7 @@ #ifndef NUMBERSH #define NUMBERSH -/* Copyright (C) 1995, 1996, 1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,2000,2001 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 @@ -290,15 +290,16 @@ extern SCM scm_dbl2big (double d); extern double scm_big2dbl (SCM b); extern SCM scm_long2num (long sl); extern SCM scm_ulong2num (unsigned long sl); -extern long scm_num2long (SCM num, char *pos, const char *s_caller); +extern long scm_num2long (SCM num, unsigned long int pos, + const char *s_caller); #ifdef HAVE_LONG_LONGS extern SCM scm_long_long2num (long_long sl); -extern long_long scm_num2long_long (SCM num, char *pos, +extern long_long scm_num2long_long (SCM num, unsigned long int pos, const char *s_caller); -extern ulong_long scm_num2ulong_long (SCM num, char *pos, +extern ulong_long scm_num2ulong_long (SCM num, unsigned long int pos, const char *s_caller); #endif -extern unsigned long scm_num2ulong (SCM num, char *pos, +extern unsigned long scm_num2ulong (SCM num, unsigned long int pos, const char *s_caller); extern void scm_init_numbers (void); diff --git a/libguile/posix.c b/libguile/posix.c index a3f034e71..4c4ee235d 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 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 @@ -1095,12 +1095,12 @@ SCM_DEFINE (scm_utime, "utime", 1, 2, 0, if (SCM_UNBNDP (actime)) SCM_SYSCALL (time (&utm_tmp.actime)); else - utm_tmp.actime = SCM_NUM2ULONG (2,actime); + utm_tmp.actime = SCM_NUM2ULONG (2, actime); if (SCM_UNBNDP (modtime)) SCM_SYSCALL (time (&utm_tmp.modtime)); else - utm_tmp.modtime = SCM_NUM2ULONG (3,modtime); + utm_tmp.modtime = SCM_NUM2ULONG (3, modtime); SCM_SYSCALL (rv = utime (SCM_STRING_CHARS (pathname), &utm_tmp)); if (rv != 0) diff --git a/libguile/ramap.c b/libguile/ramap.c index 5b50323fb..b808d6e87 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1996, 1998, 2000, 2001 Free Software Foundation, Inc. +/* Copyright (C) 1996,1998,2000,2001 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 @@ -551,7 +551,7 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore) } case scm_tc7_uvect: { /* scope */ - unsigned long f = SCM_NUM2ULONG (2,fill); + unsigned long f = SCM_NUM2ULONG (2, fill); unsigned long *ve = (unsigned long *) SCM_VELTS (ra); for (i = base; n--; i += inc) @@ -560,7 +560,7 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore) } case scm_tc7_ivect: { /* scope */ - long f = SCM_NUM2LONG (2,fill); + long f = SCM_NUM2LONG (2, fill); long *ve = (long *) SCM_VELTS (ra); for (i = base; n--; i += inc) @@ -582,7 +582,7 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore) #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: { /* scope */ - long long f = SCM_NUM2LONG_LONG (2,fill); + long long f = SCM_NUM2LONG_LONG (2, fill); long long *ve = (long long *) SCM_VELTS (ra); for (i = base; n--; i += inc) diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index b05b858a4..1625c3a87 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 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 @@ -237,8 +237,8 @@ SCM_DEFINE (scm_sigaction, "sigaction", 1, 2, 0, query_only = 1; else if (SCM_EQ_P (scm_integer_p (handler), SCM_BOOL_T)) { - if (SCM_NUM2LONG (2,handler) == (long) SIG_DFL - || SCM_NUM2LONG (2,handler) == (long) SIG_IGN) + if (SCM_NUM2LONG (2, handler) == (long) SIG_DFL + || SCM_NUM2LONG (2, handler) == (long) SIG_IGN) { #ifdef HAVE_SIGACTION action.sa_handler = (SIGRETTYPE (*) (int)) SCM_INUM (handler); diff --git a/libguile/socket.c b/libguile/socket.c index f6b404bd3..199e2497a 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1996,1997,1998, 2000, 2001 Free Software Foundation, Inc. +/* Copyright (C) 1996,1997,1998,2000,2001 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 @@ -123,7 +123,7 @@ SCM_DEFINE (scm_htonl, "htonl", 1, 0, 0, "unsigned long integer.") #define FUNC_NAME s_scm_htonl { - unsigned long c_in = SCM_NUM2ULONG (1,in); + unsigned long c_in = SCM_NUM2ULONG (1, in); return scm_ulong2num (htonl (c_in)); } #undef FUNC_NAME @@ -135,7 +135,7 @@ SCM_DEFINE (scm_ntohl, "ntohl", 1, 0, 0, "a C unsigned long integer.") #define FUNC_NAME s_scm_ntohl { - unsigned long c_in = SCM_NUM2ULONG (1,in); + unsigned long c_in = SCM_NUM2ULONG (1, in); return scm_ulong2num (ntohl (c_in)); } #undef FUNC_NAME @@ -426,7 +426,7 @@ scm_fill_sockaddr (int fam, SCM address, SCM *args, int which_arg, memset (soka, 0, sizeof (struct sockaddr_in)); soka->sin_family = AF_INET; soka->sin_addr.s_addr = - htonl (scm_num2ulong (address, (char *) which_arg, proc)); + htonl (scm_num2ulong (address, which_arg, proc)); *args = SCM_CDR (*args); soka->sin_port = htons (SCM_INUM (isport)); *size = sizeof (struct sockaddr_in); @@ -874,7 +874,7 @@ SCM_DEFINE (scm_sendto, "sendto", 4, 0, 1, else { SCM_VALIDATE_CONS (5,args_and_flags); - flg = SCM_NUM2ULONG (5,SCM_CAR (args_and_flags)); + flg = SCM_NUM2ULONG (5, SCM_CAR (args_and_flags)); } SCM_SYSCALL (rv = sendto (fd, SCM_STRING_CHARS (message), SCM_STRING_LENGTH (message), diff --git a/libguile/stime.c b/libguile/stime.c index ce1e6006e..d63ad85d3 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998, 1999, 2000, 2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 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 @@ -355,7 +355,7 @@ SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0, char **oldenv; int err; - itime = SCM_NUM2LONG (1,time); + itime = SCM_NUM2LONG (1, time); /* deferring interupts is essential since a) setzone may install a temporary environment b) localtime uses a static buffer. */ @@ -423,7 +423,7 @@ SCM_DEFINE (scm_gmtime, "gmtime", 1, 0, 0, struct tm *bd_time; SCM result; - itime = SCM_NUM2LONG (1,time); + itime = SCM_NUM2LONG (1, time); SCM_DEFER_INTS; bd_time = gmtime (&itime); if (bd_time == NULL) diff --git a/libguile/struct.c b/libguile/struct.c index 3f86c22cf..d972ba526 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -683,7 +683,7 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0, #if 0 case 'i': - data[p] = SCM_NUM2LONG (3,val); + data[p] = SCM_NUM2LONG (3, val); break; case 'd': diff --git a/libguile/unif.c b/libguile/unif.c index 62e75bf49..70fda42b9 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1317,10 +1317,10 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, ((char *) SCM_UVECTOR_BASE (v))[pos] = SCM_INUM (obj); break; case scm_tc7_uvect: - SCM_VELTS(v)[pos] = SCM_PACK (scm_num2ulong(obj, (char *)SCM_ARG2, FUNC_NAME)); + SCM_VELTS(v)[pos] = SCM_PACK (scm_num2ulong(obj, SCM_ARG2, FUNC_NAME)); break; case scm_tc7_ivect: - SCM_VELTS(v)[pos] = SCM_PACK (scm_num2long(obj, (char *)SCM_ARG2, FUNC_NAME)); + SCM_VELTS(v)[pos] = SCM_PACK (scm_num2long (obj, SCM_ARG2, FUNC_NAME)); break; case scm_tc7_svect: SCM_ASRTGO (SCM_INUMP (obj), badobj); @@ -1328,7 +1328,7 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, break; #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: - ((long_long *) SCM_CELL_WORD_1 (v))[pos] = scm_num2long_long (obj, (char *)SCM_ARG2, FUNC_NAME); + ((long_long *) SCM_CELL_WORD_1 (v))[pos] = scm_num2long_long (obj, SCM_ARG2, FUNC_NAME); break; #endif diff --git a/libguile/validate.h b/libguile/validate.h index 0a147df49..e2699b255 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -1,5 +1,5 @@ -/* $Id: validate.h,v 1.30 2001-03-17 13:34:21 dirk Exp $ */ -/* Copyright (C) 1999, 2000 Free Software Foundation, Inc. +/* $Id: validate.h,v 1.31 2001-04-10 07:57:05 dirk Exp $ */ +/* Copyright (C) 1999,2000,2001 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 @@ -61,15 +61,15 @@ #define SCM_WRONG_TYPE_ARG(pos, obj) \ do { scm_wrong_type_arg (FUNC_NAME, pos, obj); } while (0) -#define SCM_NUM2ULONG(pos, arg) (scm_num2ulong (arg, (char *) pos, FUNC_NAME)) +#define SCM_NUM2ULONG(pos, arg) (scm_num2ulong (arg, pos, FUNC_NAME)) -#define SCM_NUM2LONG(pos, arg) (scm_num2long (arg, (char *) pos, FUNC_NAME)) +#define SCM_NUM2LONG(pos, arg) (scm_num2long (arg, pos, FUNC_NAME)) #define SCM_NUM2LONG_DEF(pos, arg, def) \ - (SCM_UNBNDP (arg) ? def : scm_num2long (arg, (char *) pos, FUNC_NAME)) + (SCM_UNBNDP (arg) ? def : scm_num2long (arg, pos, FUNC_NAME)) #define SCM_NUM2LONG_LONG(pos, arg) \ - (scm_num2long_long (arg, (char *) pos, FUNC_NAME)) + (scm_num2long_long (arg, pos, FUNC_NAME)) #define SCM_OUT_OF_RANGE(pos, arg) \ do { scm_out_of_range_pos (FUNC_NAME, arg, SCM_MAKINUM (pos)); } while (0) @@ -162,7 +162,7 @@ #define SCM_VALIDATE_LONG_COPY(pos, k, cvar) \ do { \ - cvar = SCM_NUM2LONG(pos, k); \ + cvar = SCM_NUM2LONG (pos, k); \ } while (0) #define SCM_VALIDATE_BIGINT(pos, k) SCM_MAKE_VALIDATE (pos, k, BIGP) From 2b6aab94e17c16ef202a3a7fc68657965e8b6046 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 10 Apr 2001 18:41:09 +0000 Subject: [PATCH 0802/2047] * Fix typo. --- doc/ChangeLog | 4 ++ doc/api.txt | 185 -------------------------------------------------- 2 files changed, 4 insertions(+), 185 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 2cf27d9ea..c80b04822 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,7 @@ +2001-04-10 Neil Jerram + + * api.txt (Accessing Cell Entries): Fix typo. + 2001-04-09 Neil Jerram * deprecated.texi (Shared And Read Only Strings): New section for diff --git a/doc/api.txt b/doc/api.txt index 394c68d12..e69de29bb 100644 --- a/doc/api.txt +++ b/doc/api.txt @@ -1,185 +0,0 @@ -Scheme objects -============== - -There are two basic C data types to represent objects in guile: - -- SCM: SCM is the user level abstract C type that is used to represent all of -guile's scheme objects, no matter what the scheme object type is. No C -operation except assignment is guaranteed to work with variables of type SCM. -Only use macros and functions to work with SCM values. Values are converted -between C data types and the SCM type with utility functions and macros. - -- scm_bits_t: An integral data type that is guaranteed to be large enough to -hold all information that is required to represent any scheme object. While -this data type is used to implement guile internals, the use of this type is -also necessary to write certain kinds of extensions to guile. - - -Relationship between SCM and scm_bits_t -======================================= - -A variable of type SCM is guaranteed to hold a valid scheme object. A -variable of type scm_bits_t, however, may either hold a representation of a -SCM value as a C integral type, but may also hold any C value, even if it does -not correspond to a valid scheme object. - -For a variable x of type SCM, the scheme object's type information is stored -in a form that is not directly usable. To be able to work on the type -encoding of the scheme value, the SCM variable has to be transformed into the -corresponding representation as a scm_bits_t variable y by using the -SCM_UNPACK macro. After this has been done, the type of the scheme object x -can be derived from the content of the bits of the scm_bits_t value y, as is -described in -->data-rep. A valid bit encoding of a scheme value as a -scm_bits_t variable can be transformed into the corresponding SCM value by -using the SCM_PACK macro. - -- scm_bits_t SCM_UNPACK (SCM x): Transforms the SCM value x into it's -representation as an integral type. Only after applying SCM_UNPACK it is -possible to access the bits and contents of the SCM value. - -- SCM SCM_PACK (scm_bits_t x): Takes a valid integral representation of a -scheme object and transforms it into its representation as a SCM value. - - -Immediate objects -================= - -A scheme object may either be an immediate, i. e. carrying all necessary -information by itself, or it may contain a reference to a 'cell' with -additional information on the heap. While the fact, whether an object is an -immediate or not should be irrelevant for user code, within guile's own code -the distinction is sometimes of importance. Thus, the following low level -macro is provided: - -- int SCM_IMP (SCM x): A scheme object is an immediate if it fullfills the -SCM_IMP predicate, otherwise it holds an encoded reference to a heap cell. -The result of the predicate is delivered as a C style boolean value. User -code and code that extends guile should normally not be required to use this -macro. - -Summary: -* For a scheme object x of unknown type, check first with SCM_IMP (x) if it is -an immediate object. If so, all of the type and value information can be -determined from the scm_bits_t value that is delivered by SCM_UNPACK (x). - - -Non immediate objects -===================== - -- (scm_cell *) SCM2PTR (SCM x) (FIXME:: this name should be changed) -- SCM PTR2SCM (scm_cell * x) (FIXME:: this name should be changed) - -A scheme object of type SCM that does not fullfill the SCM_IMP predicate holds -an encoded reference to a heap cell. This reference can be decoded to a C -pointer to a heap cell using the SCM2PTR macro. The encoding of a pointer to -a heap cell into a SCM value is done using the PTR2SCM macro. - -Note that it is also possible to transform a non immediate SCM value by using -SCM_UNPACK into a scm_bits_t variable. Hower, the result of SCM_UNPACK may -not be used as a pointer to a scm_cell: Only SCM2PTR is guaranteed to -transform a SCM object into a valid pointer to a heap cell. Also, it is not -allowed to apply PTR2SCM to anything that is not a valid pointer to a heap -cell. - -Summary: -* Only use SCM2PTR for SCM values for which SCM_IMP is false! -* Don't use '(scm_cell*) SCM_UNPACK (x)'! Use 'SCM2PTR (x)' instead! -* Don't use PTR2SCM for anything but a cell pointer! - - -Heap Cell Type Information -========================== - -Heap cells contain a number of entries, each of which is either a scheme -object of type SCM or a raw C value of type scm_bits_t. Which of the cell -entries contain scheme objects and which contain raw C values is determined by -the first entry of the cell, which holds the cell type information. - -- scm_bits_t SCM_CELL_TYPE (SCM x): For a non immediate scheme object x, -deliver the content of the first entry of the heap cell referenced by x. This -value holds the information about the cell type as described in -->data-rep. - -- void SCM_SET_CELL_TYPE (SCM x, scm_bits_t t): For a non immediate scheme -object x, write the value t into the first entry of the heap cell referenced -by x. The value t must hold a valid cell type as described in -->data-rep. - - -Accessing Cell Entries -====================== - -For a non immediate scheme object x, the object type can be determined by -reading the cell type entry using the SCM_CELL_TYPE macro. For the different -types of cells it is know which cell entry holds scheme objects and which cell -entry holds raw C data. To access the different cell entries appropriately, -the following macros are provided: - -- scm_bits_t SCM_CELL_WORD (SCM x, unsigned int n): Deliver the cell entry n -of the heap cell referenced by the non immediate scheme object x as raw data. -It is illegal, to access cell entries that hold scheme objects by using these -macros. For convenience, the following macros are also provided: - SCM_CELL_WORD_0 (x) --> SCM_CELL_WORD (x, 0) - SCM_CELL_WORD_1 (x) --> SCM_CELL_WORD (x, 1) - ... - SCM_CELL_WORD_n (x) --> SCM_CELL_WORD (x, n) - -- SCM SCM_CELL_OBJECT (SCM x, unsigned int n): Deliver the cell entry n of -the heap cell referenced by the non immediate scheme object x as a scheme -object. It is illegal, to access cell entries that do not hold scheme objects -by using these macros. For convenience, the following macros are also -provided: - SCM_CELL_OBJECT_0 (x) --> SCM_CELL_OBJECT (x, 0) - SCM_CELL_OBJECT_1 (x) --> SCM_CELL_OBJECT (x, 1) - ... - SCM_CELL_OBJECT_n (x) --> SCM_CELL_OBJECT (x, n) - -- void SCM_SET_CELL_WORD (SCM x, unsigned int n, scm_bits_t w): Write the raw -C value w into entry number n of the heap cell referenced by the non immediate -scheme value x. Values that are written into cells this way may only be read -from the cells using the SCM_CELL_WORD macros or, in case cell entry 0 is -written, using the SCM_CELL_TYPE macro. For the special case of cell entry 0 -it has to be made sure that w contains a cell type information (see --->data-rep) which does not describe a scheme object. For convenience, the -following macros are also provided: - SCM_SET_CELL_WORD_0 (x, w) --> SCM_SET_CELL_WORD (x, 0, w) - SCM_SET_CELL_WORD_1 (x, w) --> SCM_SET_CELL_WORD (x, 1, w) - ... - SCM_SET_CELL_WORD_n (x, w) --> SCM_SET_CELL_WORD (x, n, w) - -- void SCM_SET_CELL_OBJECT (SCM x, unsigned int n, SCM o): Write the scheme -object o into entry number n of the heap cell referenced by the non immediate -scheme value x. Values that are written into cells this way may only be read -from the cells using the SCM_CELL_OBJECT macros or, in case cell entry 0 is -written, using the SCM_CELL_TYPE macro. For the special case of cell entry 0 -the writing of a scheme object into this cell is only allowed, if the cell -forms a scheme pair. For convenience, the following macros are also provided: - SCM_SET_CELL_OBJECT_0 (x, o) --> SCM_SET_CELL_OBJECT (x, 0, o) - SCM_SET_CELL_OBJECT_1 (x, o) --> SCM_SET_CELL_OBJECT (x, 1, o) - ... - SCM_SET_CELL_OBJECT_n (x, o) --> SCM_SET_CELL_OBJECT (x, n, o) - -Summary: -* For a non immediate scheme object x of unknown type, get the type - information by using SCM_CELL_TYPE (x). -* As soon as the cell type information is available, only use the appropriate - access methods to read and write data to the different cell entries. - - -Basic Rules for Accessing Cell Entries -====================================== - -For each cell type it is generally up to the implementation of that type which -of the corresponding cell entries hold scheme objects and which hold raw C -values. However, there is one basic rules that has to be followed: Scheme -pairs consist of exactly two cell entries, which both contain scheme objects. -Further, a cell which contains a scheme object in it first entry has to be a -scheme pair. In other words, it is not allowed to store a scheme object in -the first cell entry and a non scheme object in the second cell entry. - -Fixme:shouldn't this rather be SCM_PAIRP / SCM_PAIR_P ? -- int SCM_CONSP (SCM x): Determine, whether the scheme object x is a scheme -pair, i. e. whether x references a heap cell consisting of exactly two -entries, where both entries contain a scheme object. In this case, both -entries will have to be accessed using the SCM_CELL_OBJECT macros. On the -contrary, if the SCM_CONSP predicate is not fulfilled, the first entry of the -scheme cell is guaranteed not to be a scheme value and thus the first cell -entry must be accessed using the SCM_CELL_WORD_0 macro. From 19aad96c76ca85e32109266100ccf052a4ec44b8 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 10 Apr 2001 19:49:29 +0000 Subject: [PATCH 0803/2047] * Apply improved Texinfo markup patch from Dale P. Smith. --- doc/ChangeLog | 3 + doc/THANKS | 18 +- doc/scm.texi | 453 -------------------------------------------------- 3 files changed, 13 insertions(+), 461 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index c80b04822..7efd2b31e 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,5 +1,8 @@ 2001-04-10 Neil Jerram + * scm.texi (Handling Errors): Improve Texinfo markup. Thanks to + Dale P. Smith for the patch! + * api.txt (Accessing Cell Entries): Fix typo. 2001-04-09 Neil Jerram diff --git a/doc/THANKS b/doc/THANKS index 8c55c8284..e5b63ccad 100644 --- a/doc/THANKS +++ b/doc/THANKS @@ -2,15 +2,17 @@ The Guile reference manual: - Mark Galassi, for general stewardship - Tim Pierce, for writing sections on script interpreter triggers, alists, function tracing, and splitting the manual into its own module. -Proofreading and bug fixes from: -Marcus Daniels - Lee Thomas - Joel Weber - Keith Wright - Chris Bitmead + +Proofreading, bug reports and bug fixes from: + Marcus Daniels + Lee Thomas + Joel Weber + Keith Wright + Chris Bitmead + Dale P. Smith New entries from: - Per Bothner + Per Bothner Build patches from: - Steve Tell + Steve Tell diff --git a/doc/scm.texi b/doc/scm.texi index 68e515933..e69de29bb 100644 --- a/doc/scm.texi +++ b/doc/scm.texi @@ -1,453 +0,0 @@ -@page -@node Scheme Primitives -@c @chapter Writing Scheme primitives in C -@c - according to the menu in guile.texi - NJ 2001/1/26 -@chapter Relationship between Scheme and C functions - -@c Chapter contents contributed by Thien-Thi Nguyen . - -Scheme procedures marked "primitive functions" have a regular interface -when calling from C, reflected in two areas: the name of a C function, and -the convention for passing non-required arguments to this function. - -@c Although the vast majority of functions support these relationships, -@c there are some exceptions. - -@menu -* Transforming Scheme name to C name:: -* Structuring argument lists for C functions:: -@c * Exceptions to the regularity:: -@end menu - -@node Transforming Scheme name to C name -@section Transforming Scheme name to C name - -Normally, the name of a C function can be derived given its Scheme name, -using some simple textual transformations: - -@itemize @bullet - -@item -Replace @code{-} (hyphen) with @code{_} (underscore). - -@item -Replace @code{?} (question mark) with "_p". - -@item -Replace @code{!} (exclamation point) with "_x". - -@item -Replace internal @code{->} with "_to_". - -@item -Replace @code{<=} (less than or equal) with "_leq". - -@item -Replace @code{>=} (greater than or equal) with "_geq". - -@item -Replace @code{<} (less than) with "_less". - -@item -Replace @code{>} (greater than) with "_gr". - -@item -Replace @code{@@} with "at". [Omit?] - -@item -Prefix with "gh_" (or "scm_" if you are ignoring the gh interface). - -@item -[Anything else? --ttn, 2000/01/16 15:17:28] - -@end itemize - -Here is an Emacs Lisp command that prompts for a Scheme function name and -inserts the corresponding C function name into the buffer. - -@example -(defun insert-scheme-to-C (name &optional use-gh) - "Transforms Scheme NAME, a string, to its C counterpart, and inserts it. -Prefix arg non-nil means use \"gh_\" prefix, otherwise use \"scm_\" prefix." - (interactive "sScheme name: \nP") - (let ((transforms '(("-" . "_") - ("?" . "_p") - ("!" . "_x") - ("->" . "_to_") - ("<=" . "_leq") - (">=" . "_geq") - ("<" . "_less") - (">" . "_gr") - ("@" . "at")))) - (while transforms - (let ((trigger (concat "\\(.*\\)" - (regexp-quote (caar transforms)) - "\\(.*\\)")) - (sub (cdar transforms)) - (m nil)) - (while (setq m (string-match trigger name)) - (setq name (concat (match-string 1 name) - sub - (match-string 2 name))))) - (setq transforms (cdr transforms)))) - (insert (if use-gh "gh_" "scm_") name)) -@end example - -@node Structuring argument lists for C functions -@section Structuring argument lists for C functions - -The C function's arguments will be all of the Scheme procedure's -argumements, both required and optional; if the Scheme procedure takes a -``rest'' argument, that will be a final argument to the C function. The -C function's arguments, as well as its return type, will be @code{SCM}. - -@c @node Exceptions to the regularity -@c @section Exceptions to the regularity -@c -@c There are some exceptions to the regular structure described above. - - -@page -@node I/O Extensions -@chapter Using and Extending Ports in C - -@menu -* C Port Interface:: Using ports from C. -* Port Implementation:: How to implement a new port type in C. -@end menu - - -@node C Port Interface -@section C Port Interface - -This section describes how to use Scheme ports from C. - -@subsection Port basics - -There are two main data structures. A port type object (ptob) is of -type @code{scm_ptob_descriptor}. A port instance is of type -@code{scm_port}. Given an @code{SCM} variable which points to a port, -the corresponding C port object can be obtained using the -@code{SCM_PTAB_ENTRY} macro. The ptob can be obtained by using -@code{SCM_PTOBNUM} to give an index into the @code{scm_ptobs} -global array. - -@subsection Port buffers - -An input port always has a read buffer and an output port always has a -write buffer. However the size of these buffers is not guaranteed to be -more than one byte (e.g., the @code{shortbuf} field in @code{scm_port} -which is used when no other buffer is allocated). The way in which the -buffers are allocated depends on the implementation of the ptob. For -example in the case of an fport, buffers may be allocated with malloc -when the port is created, but in the case of an strport the underlying -string is used as the buffer. - -@subsection The @code{rw_random} flag - -Special treatment is required for ports which can be seeked at random. -Before various operations, such as seeking the port or changing from -input to output on a bidirectional port or vice versa, the port -implemention must be given a chance to update its state. The write -buffer is updated by calling the @code{flush} ptob procedure and the -input buffer is updated by calling the @code{end_input} ptob procedure. -In the case of an fport, @code{flush} causes buffered output to be -written to the file descriptor, while @code{end_input} causes the -descriptor position to be adjusted to account for buffered input which -was never read. - -The special treatment must be performed if the @code{rw_random} flag in -the port is non-zero. - -@subsection The @code{rw_active} variable - -The @code{rw_active} variable in the port is only used if -@code{rw_random} is set. It's defined as an enum with the following -values: - -@table @code -@item SCM_PORT_READ -the read buffer may have unread data. - -@item SCM_PORT_WRITE -the write buffer may have unwritten data. - -@item SCM_PORT_NEITHER -neither the write nor the read buffer has data. -@end table - -@subsection Reading from a port. - -To read from a port, it's possible to either call existing libguile -procedures such as @code{scm_getc} and @code{scm_read_line} or to read -data from the read buffer directly. Reading from the buffer involves -the following steps: - -@enumerate -@item -Flush output on the port, if @code{rw_active} is @code{SCM_PORT_WRITE}. - -@item -Fill the read buffer, if it's empty, using @code{scm_fill_input}. - -@item Read the data from the buffer and update the read position in -the buffer. Steps 2) and 3) may be repeated as many times as required. - -@item Set rw_active to @code{SCM_PORT_READ} if @code{rw_random} is set. - -@item update the port's line and column counts. -@end enumerate - -@subsection Writing to a port. - -To write data to a port, calling @code{scm_lfwrite} should be sufficient for -most purposes. This takes care of the following steps: - -@enumerate -@item -End input on the port, if @code{rw_active} is @code{SCM_PORT_READ}. - -@item -Pass the data to the ptob implementation using the @code{write} ptob -procedure. The advantage of using the ptob @code{write} instead of -manipulating the write buffer directly is that it allows the data to be -written in one operation even if the port is using the single-byte -@code{shortbuf}. - -@item -Set @code{rw_active} to @code{SCM_PORT_WRITE} if @code{rw_random} -is set. -@end enumerate - - -@node Port Implementation -@section Port Implementation - -This section describes how to implement a new port type in C. - -As described in the previous section, a port type object (ptob) is -a structure of type @code{scm_ptob_descriptor}. A ptob is created by -calling @code{scm_make_port_type}. - -All of the elements of the ptob, apart from @code{name}, are procedures -which collectively implement the port behaviour. Creating a new port -type mostly involves writing these procedures. - -@code{scm_make_port_type} initialises three elements of the structure -(@code{name}, @code{fill_input} and @code{write}) from its arguments. -The remaining elements are initialised with default values and can be -set later if required. - -@table @code -@item name -A pointer to a NUL terminated string: the name of the port type. This -is the only element of @code{scm_ptob_descriptor} which is not -a procedure. Set via the first argument to @code{scm_make_port_type}. - -@item mark -Called during garbage collection to mark any SCM objects that a port -object may contain. It doesn't need to be set unless the port has -@code{SCM} components. Set using @code{scm_set_port_mark}. - -@item free -Called when the port is collected during gc. It -should free any resources used by the port. -Set using @code{scm_set_port_free}. - -@item print -Called when @code{write} is called on the port object, to print a -port description. e.g., for an fport it may produce something like: -@code{#}. Set using @code{scm_set_port_print}. - -@item equalp -Not used at present. Set using @code{scm_set_port_equalp}. - -@item close -Called when the port is closed, unless it was collected during gc. It -should free any resources used by the port. -Set using @code{scm_set_port_close}. - -@item write -Accept data which is to be written using the port. The port implementation -may choose to buffer the data instead of processing it directly. -Set via the third argument to @code{scm_make_port_type}. - -@item flush -Complete the processing of buffered output data. Reset the value of -@code{rw_active} to @code{SCM_PORT_NEITHER}. -Set using @code{scm_set_port_flush}. - -@item end_input -Perform any synchronisation required when switching from input to output -on the port. Reset the value of @code{rw_active} to @code{SCM_PORT_NEITHER}. -Set using @code{scm_set_port_end_input}. - -@item fill_input -Read new data into the read buffer and return the first character. It -can be assumed that the read buffer is empty when this procedure is called. -Set via the second argument to @code{scm_make_port_type}. - -@item input_waiting -Return a lower bound on the number of bytes that could be read from the -port without blocking. It can be assumed that the current state of -@code{rw_active} is @code{SCM_PORT_NEITHER}. -Set using @code{scm_set_port_input_waiting}. - -@item seek -Set the current position of the port. The procedure can not make -any assumptions about the value of @code{rw_active} when it's -called. It can reset the buffers first if desired by using something -like: - -@example - if (pt->rw_active == SCM_PORT_READ) - scm_end_input (object); - else if (pt->rw_active == SCM_PORT_WRITE) - ptob->flush (object); -@end example - -However note that this will have the side effect of discarding any data -in the unread-char buffer, in addition to any side effects from the -@code{end_input} and @code{flush} ptob procedures. This is undesirable -when seek is called to measure the current position of the port, i.e., -@code{(seek p 0 SEEK_CUR)}. The libguile fport and string port -implementations take care to avoid this problem. - -The procedure is set using @code{scm_set_port_seek}. - -@item truncate -Truncate the port data to be specified length. It can be assumed that the -current state of @code{rw_active} is @code{SCM_PORT_NEITHER}. -Set using @code{scm_set_port_truncate}. - -@end table - - -@node Handling Errors -@chapter How to Handle Errors in C Code - -Error handling is based on catch and throw. Errors are always thrown with -a key and four arguments: - -@itemize @bullet -@item -key: a symbol which indicates the type of error. The symbols used -by libguile are listed below. - -@item -subr: the name of the procedure from which the error is thrown, or #f. - -@item -message: a string (possibly language and system dependent) describing the -error. The tokens %s and %S can be embedded within the message: they -will be replaced with members of the args list when the message is -printed. %s indicates an argument printed using "display", while %S -indicates an argument printed using "write". message can also be #f, -to allow it to be derived from the key by the error handler (may be -useful if the key is to be thrown from both C and Scheme). - -@item -args: a list of arguments to be used to expand %s and %S tokens in message. -Can also be #f if no arguments are required. - -@item -rest: a list of any additional objects required. e.g., when the key is -'system-error, this contains the C errno value. Can also be #f if no -additional objects are required. -@end itemize - -In addition to catch and throw, the following Scheme facilities are -available: - -@itemize @bullet -@item -(scm-error key subr message args rest): throw an error, with arguments -as described above. - -@item -(error msg arg ...) Throw an error using the key 'misc-error. The error -message is created by displaying msg and writing the args. -@end itemize - -The following are the error keys defined by libguile and the situations -in which they are used: - -@itemize @bullet -@item -error-signal: thrown after receiving an unhandled fatal signal such as -SIGSEV, SIGBUS, SIGFPE etc. The "rest" argument in the throw contains -the coded signal number (at present this is not the same as the usual -Unix signal number). - -@item -system-error: thrown after the operating system indicates an error -condition. The "rest" argument in the throw contains the errno value. - -@item -numerical-overflow: numerical overflow. - -@item -out-of-range: the arguments to a procedure do not fall within the -accepted domain. - -@item -wrong-type-arg: an argument to a procedure has the wrong thpe. - -@item -wrong-number-of-args: a procedure was called with the wrong number of -arguments. - -@item -memory-allocation-error: memory allocation error. - -@item -stack-overflow: stack overflow error. - -@item -regex-error: errors generated by the regular expression library. - -@item -misc-error: other errors. -@end itemize - - -@section C Support - -SCM scm_error (SCM key, char *subr, char *message, SCM args, SCM rest) - -Throws an error, after converting the char * arguments to Scheme strings. -subr is the Scheme name of the procedure, NULL is converted to #f. -Likewise a NULL message is converted to #f. - -The following procedures invoke scm_error with various error keys and -arguments. The first three call scm_error with the system-error key -and automatically supply errno in the "rest" argument: scm_syserror -generates messages using strerror, scm_sysmissing is used when -facilities are not available. Care should be taken that the errno -value is not reset (e.g. due to an interrupt). - -@itemize @bullet -@item -void scm_syserror (char *subr); -@item -void scm_syserror_msg (char *subr, char *message, SCM args); -@item -void scm_sysmissing (char *subr); -@item -void scm_num_overflow (char *subr); -@item -void scm_out_of_range (char *subr, SCM bad_value); -@item -void scm_wrong_num_args (SCM proc); -@item -void scm_wrong_type_arg (char *subr, int pos, SCM bad_value); -@item -void scm_memory_error (char *subr); -@item -static void scm_regex_error (char *subr, int code); (only used in rgx.c). -@end itemize - -Exception handlers can also be installed from C, using -scm_internal_catch, scm_lazy_catch, or scm_stack_catch from -libguile/throw.c. These have not yet been documented, however the -source contains some useful comments. From 8ed35a15e890d0317361815c9be45e0480270517 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 10 Apr 2001 23:48:27 +0000 Subject: [PATCH 0804/2047] * readline.c (scm_clear_history): New function. * readline.scm (readline-port): Call clear-history on exit. Thanks to Utz-Uwe Haus. --- guile-readline/readline.c | 10 ++++++++++ guile-readline/readline.scm | 4 +++- 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/guile-readline/readline.c b/guile-readline/readline.c index 068c453e6..565c264ad 100644 --- a/guile-readline/readline.c +++ b/guile-readline/readline.c @@ -360,6 +360,16 @@ SCM_DEFINE (scm_write_history, "write-history", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_clear_history, "clear-history", 0, 0, 0, + (), + "Clear the history buffer of the readline machinery.") +#define FUNC_NAME s_scm_clear_history +{ + clear_history(); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + SCM_DEFINE (scm_filename_completion_function, "filename-completion-function", 2, 0, 0, (SCM text, SCM continuep), diff --git a/guile-readline/readline.scm b/guile-readline/readline.scm index c76e51a39..f2960fac6 100644 --- a/guile-readline/readline.scm +++ b/guile-readline/readline.scm @@ -110,7 +110,9 @@ (begin (do read-history) (set! the-readline-port (make-readline-port)) - (add-hook! exit-hook (lambda () (do write-history))))) + (add-hook! exit-hook (lambda () + (do write-history) + (clear-history))))) the-readline-port))) ;;; The user might try to use readline in his programs. It then From 1e177a8f627210598faec4be8b0002d444c9c16b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 10 Apr 2001 23:51:13 +0000 Subject: [PATCH 0805/2047] *** empty log message *** --- guile-readline/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index e677ada41..f0c8108ae 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,9 @@ +2001-04-09 Marius Vollmer + + * readline.c (scm_clear_history): New function. + * readline.scm (readline-port): Call clear-history on exit. + Thanks to Utz-Uwe Haus. + 2001-03-09 Keisuke Nishida * readline.c: Add #include From f2e61fc1c5b2a3bf397cc6310a6b4eab49473b89 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 11 Apr 2001 02:08:59 +0000 Subject: [PATCH 0806/2047] *** empty log message *** --- ChangeLog | 4 ++++ RELEASE | 1 - 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index a6a3e710f..6703eb8b8 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2001-04-10 Mikael Djurfeldt + + * Undeprecated scm_init_oop_goopscore_module. + 2001-03-25 Thien-Thi Nguyen * check-guile.in: Fix sh standard conformance bug: Replace diff --git a/RELEASE b/RELEASE index b24a13d2e..2ffa89fca 100644 --- a/RELEASE +++ b/RELEASE @@ -45,7 +45,6 @@ In release 1.6: try-module-dynamic-link init-dynamic-module scm_register_module_xxx - scm_init_oop_goops_goopscore_module etc. - remove deprecated variables: scm_top_level_lookup_closure_var From 508ded1cdbf2605bdb9bf5f9922561b7f2ec202d Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 11 Apr 2001 02:09:35 +0000 Subject: [PATCH 0807/2047] * init.c, goops.c: Reverted change of 2001-03-29. (The goops module should be registered in order to work for an application which uses libguile statically linked.) --- libguile/ChangeLog | 6 ++++++ libguile/goops.c | 4 ---- libguile/init.c | 5 ++++- 3 files changed, 10 insertions(+), 5 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 48474f24f..9e4bd80ff 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2001-04-10 Mikael Djurfeldt + + * init.c, goops.c: Reverted change of 2001-03-29. (The goops + module should be registered in order to work for an application + which uses libguile statically linked.) + 2001-04-10 Dirk Herrmann * numbers.[ch] (scm_num2long, scm_num2long_long, diff --git a/libguile/goops.c b/libguile/goops.c index beddf7dc9..f63a4a42f 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -2694,16 +2694,12 @@ scm_init_goops (void) scm_set_current_module (old_module); } -#if (SCM_DEBUG_DEPRECATED == 0) - void scm_init_oop_goops_goopscore_module () { scm_register_module_xxx ("oop goops goopscore", (void *) scm_init_goops); } -#endif /* (SCM_DEBUG_DEPRECATED == 0) */ - /* Local Variables: c-file-style: "gnu" diff --git a/libguile/init.c b/libguile/init.c index 92ac9eaea..f7b023ffb 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999, 2000, 2001 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 @@ -79,6 +79,7 @@ #include "libguile/fports.h" #include "libguile/gc.h" #include "libguile/gdbint.h" +#include "libguile/goops.h" #include "libguile/gsubr.h" #include "libguile/hash.h" #include "libguile/hashtab.h" @@ -573,6 +574,8 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_init_dynamic_linking (); scm_init_lang (); scm_init_script (); + + scm_init_oop_goops_goopscore_module (); scm_initialized_p = 1; From a087ba812eaa248e7e192924919fbb2df5be2d44 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 11 Apr 2001 02:12:35 +0000 Subject: [PATCH 0808/2047] * init.c, goops.c, goops.h: Reverted change of 2001-03-29. (The goops module should be registered in order to work for an application which uses libguile statically linked.) --- libguile/ChangeLog | 6 +++--- libguile/goops.h | 2 -- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 9e4bd80ff..757697e83 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,8 +1,8 @@ 2001-04-10 Mikael Djurfeldt - * init.c, goops.c: Reverted change of 2001-03-29. (The goops - module should be registered in order to work for an application - which uses libguile statically linked.) + * init.c, goops.c, goops.h: Reverted change of 2001-03-29. (The + goops module should be registered in order to work for an + application which uses libguile statically linked.) 2001-04-10 Dirk Herrmann diff --git a/libguile/goops.h b/libguile/goops.h index c7de43bf4..624ca3075 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -237,9 +237,7 @@ SCM scm_m_atdispatch (SCM xorig, SCM env); #ifdef GUILE_DEBUG SCM scm_pure_generic_p (SCM obj); #endif -#if (SCM_DEBUG_DEPRECATED == 0) extern void scm_init_oop_goops_goopscore_module (void); -#endif /* (SCM_DEBUG_DEPRECATED == 0) */ SCM scm_sys_compute_slots (SCM c); SCM scm_i_get_keyword (SCM key, SCM l, int len, SCM default_value, const char *subr); From b592004c726108b36862b0e2a667fbb2e87acc29 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 11 Apr 2001 02:13:14 +0000 Subject: [PATCH 0809/2047] * goops/Makefile.am, goops/goopscore.scm: Reverted changes of 2001-04-03, 2001-03-09. --- oop/ChangeLog | 5 +++++ oop/goops/Makefile.am | 2 +- oop/goops/goopscore.scm | 0 3 files changed, 6 insertions(+), 1 deletion(-) delete mode 100644 oop/goops/goopscore.scm diff --git a/oop/ChangeLog b/oop/ChangeLog index fdbd9a627..170902166 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -1,3 +1,8 @@ +2001-04-10 Mikael Djurfeldt + + * goops/Makefile.am, goops/goopscore.scm: Reverted changes of + 2001-04-03, 2001-03-09. + 2001-04-03 Keisuke Nishida * goops/Makefile.am (goops_sources): Include goopscore.scm. diff --git a/oop/goops/Makefile.am b/oop/goops/Makefile.am index fbc0c1224..b80216bbc 100644 --- a/oop/goops/Makefile.am +++ b/oop/goops/Makefile.am @@ -25,7 +25,7 @@ AUTOMAKE_OPTIONS = foreign goops_sources = \ active-slot.scm compile.scm composite-slot.scm describe.scm \ dispatch.scm internal.scm save.scm stklos.scm util.scm \ - old-define-method.scm goopscore.scm + old-define-method.scm subpkgdatadir = $(pkgdatadir)/$(VERSION)/oop/goops subpkgdata_DATA = $(goops_sources) diff --git a/oop/goops/goopscore.scm b/oop/goops/goopscore.scm deleted file mode 100644 index e69de29bb..000000000 From f4f2b29a5faad7c7996860996f712fcabfa68cc9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 11 Apr 2001 14:56:30 +0000 Subject: [PATCH 0810/2047] * scheme-procedures.texi (Lambda): Documented the lambda form. (Procedure Properties): Concept and usage explanation added. (Procedures with Setters): Explain by example, introduce definitions. * scheme-data.texi (Symbols and Variables): Split and reorganized this section. (Symbols): New introductory text. (Characters): Added char-ci* procedures to rn index. --- doc/ChangeLog | 12 ++ doc/scheme-data.texi | 263 ++++++++++++++++++++++++++----------- doc/scheme-procedures.texi | 178 +++++++++++++++++++++++-- 3 files changed, 364 insertions(+), 89 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 7efd2b31e..3f4fe3d83 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,15 @@ +2001-04-11 Martin Grabmueller + + * scheme-procedures.texi (Lambda): Documented the lambda form. + (Procedure Properties): Concept and usage explanation added. + (Procedures with Setters): Explain by example, introduce + definitions. + + * scheme-data.texi (Symbols and Variables): Split and reorganized + this section. + (Symbols): New introductory text. + (Characters): Added char-ci* procedures to rn index. + 2001-04-10 Neil Jerram * scm.texi (Handling Errors): Improve Texinfo markup. Thanks to diff --git a/doc/scheme-data.texi b/doc/scheme-data.texi index cd982ab34..a332dace7 100755 --- a/doc/scheme-data.texi +++ b/doc/scheme-data.texi @@ -53,9 +53,9 @@ sections of this manual that cover them. * Lists:: Special list functions supported by Guile. * Records:: * Structures:: -* Arrays:: -* Association Lists and Hash Tables:: -* Vectors:: +* Arrays:: Arrays of values. +* Association Lists and Hash Tables:: Dictionary data types. +* Vectors:: One-dimensional arrays of Scheme objects. * Hooks:: User-customizable event lists. * Other Data Types:: Data types that are documented elsewhere. @end menu @@ -1135,21 +1135,6 @@ Return a new random state using @var{seed}. @node Characters @section Characters -@rnindex char? -@rnindex char=? -@rnindex char? -@rnindex char<=? -@rnindex char>=? -@rnindex char-alphabetic? -@rnindex char-numeric? -@rnindex char-whitespace? -@rnindex char-upper-case? -@rnindex char-lower-case? -@rnindex char->integer -@rnindex integer->char -@rnindex char-upcase -@rnindex char-downcase Most of the characters in the ASCII character set may be referred to by @@ -1214,79 +1199,95 @@ Several characters have more than one name: #\null, #\nul @end itemize +@rnindex char? @deffn primitive char? x Return @code{#t} iff @var{x} is a character, else @code{#f}. @end deffn +@rnindex char=? @deffn primitive char=? x y Return @code{#t} iff @var{x} is the same character as @var{y}, else @code{#f}. @end deffn +@rnindex char? @deffn primitive char>? x y Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII sequence, else @code{#f}. @end deffn +@rnindex char>=? @deffn primitive char>=? x y Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the ASCII sequence, else @code{#f}. @end deffn +@rnindex char-ci=? @deffn primitive char-ci=? x y Return @code{#t} iff @var{x} is the same character as @var{y} ignoring case, else @code{#f}. @end deffn +@rnindex char-ci? @deffn primitive char-ci>? x y Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII sequence ignoring case, else @code{#f}. @end deffn +@rnindex char-ci>=? @deffn primitive char-ci>=? x y Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the ASCII sequence ignoring case, else @code{#f}. @end deffn +@rnindex char-alphabetic? @deffn primitive char-alphabetic? chr Return @code{#t} iff @var{chr} is alphabetic, else @code{#f}. Alphabetic means the same thing as the isalpha C library function. @end deffn +@rnindex char-numeric? @deffn primitive char-numeric? chr Return @code{#t} iff @var{chr} is numeric, else @code{#f}. Numeric means the same thing as the isdigit C library function. @end deffn +@rnindex char-whitespace? @deffn primitive char-whitespace? chr Return @code{#t} iff @var{chr} is whitespace, else @code{#f}. Whitespace means the same thing as the isspace C library function. @end deffn +@rnindex char-upper-case? @deffn primitive char-upper-case? chr Return @code{#t} iff @var{chr} is uppercase, else @code{#f}. Uppercase means the same thing as the isupper C library function. @end deffn +@rnindex char-lower-case? @deffn primitive char-lower-case? chr Return @code{#t} iff @var{chr} is lowercase, else @code{#f}. Lowercase means the same thing as the islower C library function. @@ -1298,19 +1299,23 @@ Uppercase and lowercase are as defined by the isupper and islower C library functions. @end deffn +@rnindex char->integer @deffn primitive char->integer chr Return the number corresponding to ordinal position of @var{chr} in the ASCII sequence. @end deffn +@rnindex integer->char @deffn primitive integer->char n Return the character at position @var{n} in the ASCII sequence. @end deffn +@rnindex char-upcase @deffn primitive char-upcase chr Return the uppercase character version of @var{chr}. @end deffn +@rnindex char-downcase @deffn primitive char-downcase chr Return the lowercase character version of @var{chr}. @end deffn @@ -2090,6 +2095,10 @@ to this cumbersome escape syntax. @node Rx Interface @subsection Rx Interface +@c FIXME::martin: Shouldn't this be removed or moved to the +@c ``Guile Modules'' chapter? The functions are not available in +@c plain Guile... + [FIXME: this is taken from Gary and Mark's quick summaries and should be reviewed and expanded. Rx is pretty stable, so could already be done!] @@ -2233,60 +2242,82 @@ Test whether obj is a compiled regular expression. @node Symbols and Variables @section Symbols and Variables +@c FIXME::martin: Review me! -Guile symbol tables are hash tables. Each hash table, also called an -@dfn{obarray} (for `object array'), is a vector of association lists. -Each entry in the alists is a pair (@var{SYMBOL} . @var{VALUE}). To -@dfn{intern} a symbol in a symbol table means to return its -(@var{SYMBOL} . @var{VALUE}) pair, adding a new entry to the symbol -table (with an undefined value) if none is yet present. +Symbols are a data type with a special property. On the one hand, +symbols are used for denoting variables in a Scheme program, on the +other they can be used as literal data as well. -@c FIXME::martin: According to NEWS, removed. Remove here too, or -@c leave for compatibility? -@c @c docstring begin (texi-doc-string "guile" "builtin-bindings") -@c @deffn primitive builtin-bindings -@c Create and return a copy of the global symbol table, removing all -@c unbound symbols. -@c @end deffn +The association between symbols and values is maintained in special data +structures, the symbol tables. -@deffn primitive 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 @code{g}. The counter -is increased by 1 at each call. There is no provision for -resetting the counter. -@end deffn +In addition, Guile offers variables as first--class objects. They can +be used for interacting with the module system. -@deffn primitive gentemp [prefix [obarray]] -Create a new symbol with a name unique in an obarray. -The name is constructed from an optional string @var{prefix} -and a counter value. The default prefix is @code{t}. The -@var{obarray} is specified as a second optional argument. -Default is the system obarray where all normal symbols are -interned. The counter is increased by 1 at each -call. There is no provision for resetting the counter. -@end deffn +@menu +* Symbols:: All about symbols as a data type. +* Symbol Tables:: Tables for mapping symbols to values. +* Variables:: First--class variables. +@end menu -@deffn primitive intern-symbol obarray string -Add a new symbol to @var{obarray} with name @var{string}, bound to an -unspecified initial value. The symbol table is not modified if a symbol -with this name is already present. -@end deffn +@node Symbols +@subsection Symbols -@deffn primitive string->obarray-symbol obarray string [soft?] -Intern a new symbol in @var{obarray}, a symbol table, with name -@var{string}. +@c FIXME::martin: Review me! -If @var{obarray} is @code{#f}, use the default system symbol table. If -@var{obarray} is @code{#t}, the symbol should not be interned in any -symbol table; merely return the pair (@var{symbol} -. @var{#}). +Symbols are especially useful because two symbols which are spelled the +same way are equivalent in the sense of @code{eq?}. That means that +they are actually the same Scheme object. The advantage is that symbols +can be compared extremely efficiently, although they carry more +information for the human reader than, say, numbers. -The @var{soft?} argument determines whether new symbol table entries -should be created when the specified symbol is not already present in -@var{obarray}. If @var{soft?} is specified and is a true value, then -new entries should not be added for symbols not already present in the -table; instead, simply return @code{#f}. +It is very common in Scheme programs to use symbols as keys in +association lists (REFFIXME) or hash tables (REFFIXME), because this +usage improves the readability a lot, and does not cause any performance +loss. + +The read syntax for symbols is a sequence of letters, digits, and +@emph{extended alphabetic characters} that begins with a character that +cannot begin a number is an identifier. In addition, @code{+}, +@code{-}, and @code{...} are identifiers. + +Extended alphabetic characters may be used within identifiers as if +they were letters. The following are extended alphabetic characters: + +@example +! $ % & * + - . / : < = > ? @@ ^ _ ~ +@end example + +In addition to the read syntax defined above (which is taken from R5RS +(REFFIXME)), Guile provides a method for writing symbols with unusual +characters, such as space characters. If you (for whatever reason) need +to write a symbol containing characters not mentioned above, you write +symbols as follows: + +@itemize @bullet +@item Begin the symbol with the two character @code{#@{}, +@item write the characters of the symbol and +@item finish the symbol with the characters @code{@}#}. +@end itemize + +Here are a few examples of this form of read syntax; the first +containing a space character, the second containing a line break and the +last one looks like a number. + +@lisp +#@{foo bar@}# +#@{what +ever@}# +#@{4242@}# +@end lisp + +Usage of this form of read syntax is discouraged, because it is not +portable at all, and is not very readable. + +@rnindex symbol? +@deffn primitive symbol? obj +Return @code{#t} if @var{obj} is a symbol, otherwise return +@code{#f}. @end deffn @rnindex string->symbol @@ -2336,6 +2367,57 @@ standard case is lower case: @end lisp @end deffn +@node Symbol Tables +@subsection Symbol Tables + +@c FIXME::martin: Review me! + +@c FIXME::martin: Are all these procedures still relevant? + +Guile symbol tables are hash tables. Each hash table, also called an +@dfn{obarray} (for `object array'), is a vector of association lists. +Each entry in the alists is a pair (@var{SYMBOL} . @var{VALUE}). To +@dfn{intern} a symbol in a symbol table means to return its +(@var{SYMBOL} . @var{VALUE}) pair, adding a new entry to the symbol +table (with an undefined value) if none is yet present. + +@c FIXME::martin: According to NEWS, removed. Remove here too, or +@c leave for compatibility? +@c @c docstring begin (texi-doc-string "guile" "builtin-bindings") +@c @deffn primitive builtin-bindings +@c Create and return a copy of the global symbol table, removing all +@c unbound symbols. +@c @end deffn + +@deffn primitive 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 @code{g}. The counter +is increased by 1 at each call. There is no provision for +resetting the counter. +@end deffn + +@deffn primitive gentemp [prefix [obarray]] +Create a new symbol with a name unique in an obarray. +The name is constructed from an optional string @var{prefix} +and a counter value. The default prefix is @code{t}. The +@var{obarray} is specified as a second optional argument. +Default is the system obarray where all normal symbols are +interned. The counter is increased by 1 at each +call. There is no provision for resetting the counter. +@end deffn + +@deffn primitive intern-symbol obarray string +Add a new symbol to @var{obarray} with name @var{string}, bound to an +unspecified initial value. The symbol table is not modified if a symbol +with this name is already present. +@end deffn + +@deffn primitive string->obarray-symbol obarray string [soft?] +Intern a new symbol in @var{obarray}, a symbol table, with name +@var{string}. +@end deffn + @deffn primitive symbol-binding obarray string Look up in @var{obarray} the symbol whose name is @var{string}, and return the value to which it is bound. If @var{obarray} is @code{#f}, @@ -2383,18 +2465,29 @@ it to @var{value}. An error is signalled if @var{string} is not present in @var{obarray}. @end deffn -@rnindex symbol? -@deffn primitive symbol? obj -Return @code{#t} if @var{obj} is a symbol, otherwise return -@code{#f}. -@end deffn - @deffn primitive unintern-symbol obarray string Remove the symbol with name @var{string} from @var{obarray}. This function returns @code{#t} if the symbol was present and @code{#f} otherwise. @end deffn +@node Variables +@subsection Variables + +@c FIXME::martin: Review me! + +Variables are objects with two fields. They contain a value and they +can contain a symbol, which is the name of the variable. A variable is +said to be bound if it does not contain the object denoting unbound +variables in the value slot. + +Variables do not have a read syntax, they have to be created by calling +one of the constructor procedures @code{make-variable} or +@code{make-undefined-variable} or retrieved by @code{builtin-variable}. + +First--class variables are especially useful for interacting with the +current module system (REFFIXME). + @deffn primitive builtin-variable name Return the built-in variable with the name @var{name}. @var{name} must be a symbol (not a string). @@ -2755,10 +2848,12 @@ by @code{set-cdr!} is unspecified. @node Lists @section Lists -A very important datatype in Scheme---as well as in all other Lisp +@c FIXME::martin: Review me! + +A very important data type in Scheme---as well as in all other Lisp dialects---is the data type @dfn{list}.@footnote{Strictly speaking, Scheme does not have a real datatype @emph{list}. Lists are made up of -chained @emph{pairs}, and only exist by definition --- A list is a chain +chained @emph{pairs}, and only exist by definition---a list is a chain of pairs which looks like a list.} This is the short definition of what a list is: @@ -2790,6 +2885,8 @@ This is the short definition of what a list is: @node List Syntax @subsection List Read Syntax +@c FIXME::martin: Review me! + The syntax for lists is an opening parentheses, then all the elements of the list (separated by whitespace) and finally a closing parentheses.@footnote{Note that there is no separation character between @@ -2823,6 +2920,8 @@ applications (REFFIXME). @node List Predicates @subsection List Predicates +@c FIXME::martin: Review me! + Often it is useful to test whether a given Scheme object is a list or not. List--processing procedures could use this information to test whether their input is valid, or they could do different things @@ -2881,6 +2980,8 @@ use the procedure @code{copy-tree} (REFFIXME). @node List Selection @subsection List Selection +@c FIXME::martin: Review me! + These procedures are used to get some information about a list, or to retrieve one or more elements of a list. @@ -2918,6 +3019,8 @@ return it. @node Append/Reverse @subsection Append and Reverse +@c FIXME::martin: Review me! + @code{append} and @code{append!} are used to concatenate two or more lists in order to form a new list. @code{reverse} and @code{reverse!} return lists with the same elements as their arguments, but in reverse @@ -2977,6 +3080,8 @@ of the modified list is not lost, it is wise to save the return value of @node List Modifification @subsection List Modification +@c FIXME::martin: Review me! + The following procedures modify existing list. @code{list-set!} and @code{list-cdr-set!} change which elements a list contains, the various deletion procedures @code{delq}, @code{delv} etc. @@ -3042,6 +3147,8 @@ Like @code{delete!}, but only deletes the first occurrence of @node List Searching @subsection List Searching +@c FIXME::martin: Review me! + The following procedures search lists for particular elements. They use different comparison predicates for comparing list elements with the object to be seached. When they fail, they return @code{#f}, otherwise @@ -3103,6 +3210,8 @@ not for high-level Scheme programs. @node List Mapping @subsection List Mapping +@c FIXME::martin: Review me! + List processing is very convenient in Scheme because the process of iterating over the elements of a list can be highly abstracted. The procedures in this section are the most basic iterating procedures for @@ -4835,8 +4944,8 @@ using @code{run-hook}. (display (* x y)) (newline))) (run-hook hook 3 4) -Bar: 12 -Foo: 7 +@print{} Bar: 12 +@print{} Foo: 7 @end lisp Note that the procedures are called in reverse order than they were @@ -4852,10 +4961,10 @@ on the second call to @code{add-hook!}. (display "Bar: ") (display (* x y)) (newline)) - #t) ; <- Change here! + #t) ; @r{<- Change here!} (run-hook hook 3 4) -Foo: 7 -Bar: 12 +@print{} Foo: 7 +@print{} Bar: 12 @end lisp @node Hook Reference diff --git a/doc/scheme-procedures.texi b/doc/scheme-procedures.texi index cbb405fde..c67f4556c 100644 --- a/doc/scheme-procedures.texi +++ b/doc/scheme-procedures.texi @@ -14,6 +14,69 @@ @node Lambda @section Lambda: Basic Procedure Creation +@c FIXME::martin: Review me! + +A @code{lambda} expression evaluates to a procedure. The environment +which is in effect when a @code{lambda} expression is evaluated is +enclosed in the newly created procedure, this is referred to as a +@dfn{closure} (@pxref{About Closure}). + +When a procedure created by @code{lambda} is called with some actual +arguments, the environment enclosed in the procedure is extended by +binding the variables named in the formal argument list to new locations +and storing the actual arguments into these locations. Then the body of +the @code{lambda} expression is evaluation sequentially. The result of +the last expression in the procedure body is then the result of the +procedure invocation. + +The following examples will show how procedures can be created using +@code{lambda}, and what you can do with these procedures. + +@lisp +(lambda (x) (+ x x)) @result{} @r{a procedure} +((lambda (x) (+ x x)) 4) @result{} 8 +@end lisp + +The fact that the environment in effect when creating a procedure is +enclosed in the procedure is shown with this example: + +@lisp +(define add4 + (let ((x 4)) + (lambda (y) (+ x y)))) +(add4 6) @result{} 10 +@end lisp + + +@deffn syntax lambda formals body +@var{formals} should be a formal argument list as described in the +following table. + +@table @code +@item (@var{variable1} @dots{}) +The procedure takes a fixed number of arguments; when the procedure is +called, the arguments will be stored into the newly created location for +the formal variables. +@item @var{variable} +The procedure takes any number of arguments; when the procedure is +called, the sequence of actual arguments will converted into a list and +stored into the newly created location for the formal variable. +@item (@var{variable1} @dots{} @var{variablen} . @var{variablen+1}) +If a space--delimited period precedes the last variable, then the +procedure takes @var{n} or more variablesm where @var{n} is the number +of formal arguments before the period. There must be at least one +argument before the period. The first @var{n} actual arguments will be +stored into the newly allocated locations for the first @var{n} formal +arguments and the sequence of the remaining actual arguments is +converted into a list and the stored into the location for the last +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 + +@var{body} is a sequence of Scheme expressions which are evaluated in +order when the procedure is invoked. +@end deffn + @node Optional Arguments @section Optional Arguments @@ -22,6 +85,42 @@ @node Procedure Properties @section Procedure Properties and Metainformation +@c FIXME::martin: Review me! + +Procedures always have attached the environment in which they were +created and information about how to apply them to actual arguments. In +addition to that, properties and metainformation can be stored with +procedures. The procedures in this section can be used to test whether +a given procedure satisfies a condition; and to access and set a +procedure's property. + +The first group of procedures are predicates to test whether a Scheme +object is a procedure, or a special procedure, respectively. +@code{procedure?} is the most general predicates, it returns @code{#t} +for any kind of procedure. @code{closure?} does not return @code{#t} +for primitive procedures, and @code{thunk?} only returns @code{#t} for +procedures which do not accept any arguments. +@c FIXME::martin: thunk? returns true for `id'. What's wrong here? + +@rnindex procedure? +@deffn primitive procedure? obj +Return @code{#t} if @var{obj} is a procedure. +@end deffn + +@deffn primitive closure? obj +Return @code{#t} if @var{obj} is a closure. +@end deffn + +@deffn primitive thunk? obj +Return @code{#t} if @var{obj} is a thunk. +@end deffn + +@c FIXME::martin: Is that true? +@cindex procedure properties +Procedure properties are general properties to be attached to +procedures. These can be the name of a procedure or other relevant +information, such as debug hints. + @deffn primitive procedure-properties proc Return @var{obj}'s property list. @end deffn @@ -39,6 +138,10 @@ In @var{obj}'s property list, set the property named @var{key} to @var{value}. @end deffn +@cindex procedure documentation +Documentation for a procedure can be accessed with the procedure +@code{procedure-documentation}. + @deffn primitive procedure-documentation proc Return the documentation string associated with @code{proc}. By convention, if a procedure contains more than one expression and the @@ -46,18 +149,10 @@ first expression is a string constant, that string is assumed to contain documentation for that procedure. @end deffn -@deffn primitive closure? obj -Return @code{#t} if @var{obj} is a closure. -@end deffn - -@rnindex procedure? -@deffn primitive procedure? obj -Return @code{#t} if @var{obj} is a procedure. -@end deffn - -@deffn primitive thunk? obj -Return @code{#t} if @var{obj} is a thunk. -@end deffn +@cindex source properties +@c FIXME::martin: Is the following true? +Source properties are properties which are related to the source code of +a procedure, such as the line and column numbers, the file name etc. @deffn primitive set-source-properties! obj plist Install the association list @var{plist} as the source property @@ -83,6 +178,63 @@ Return the source property specified by @var{key} from @node Procedures with Setters @section Procedures with Setters +@c FIXME::martin: Review me! + +@c FIXME::martin: Document `operator struct'. + +@cindex procedure with setter +@cindex setter +A @dfn{procedure with setter} is a special kind of procedure which +normally behaves like any accesor procedure, that is a procedure which +accesses a data structure. The difference is that this kind of +procedure has a so--called @dfn{setter} attached, which is a procedure +for storing something into a data structure. + +Procedures with setters are treated specially when the procedure appears +in the special form @code{set!} (REFFIXME). How it works is best shown +by example. + +Suppose we have a procedure called @code{foo-ref}, which accepts two +arguments, a value of type @code{foo} and an integer. The procedure +returns the value stored at the given index in the @code{foo} object. +Let @code{f} be a variable containing such a @code{foo} data +structure.@footnote{Working definitions would be: +@lisp +(define foo-ref vector-ref) +(define foo-set! vector-set!) +(define f (make-vector 2 #f)) +@end lisp} + +@lisp +(foo-ref f 0) @result{} bar +(foo-ref f 1) @result{} braz +@end lisp + +Also suppose that a corresponding setter procedure called +@code{foo-set!} does exist. + +@lisp +(foo-set! f 0 'bla) +(foo-ref f 0) @result{} bla +@end lisp + +Now we could create a new procedure called @code{foo}, which is a +procedure with setter, by calling @code{make-procedure-with-setter} with +the accessor and setter procedures @code{foo-ref} and @code{foo-set!}. +Let us call this new procedure @code{foo}. + +@lisp +(define foo (make-procedure-with-setter foo-ref foo-set!)) +@end lisp + +@code{foo} can from now an be used to either read from the data +structure stored in @code{f}, or to write into the structure. + +@lisp +(set! (foo f 0) 'dum) +(foo f 0) @result{} dum +@end lisp + @deffn primitive make-procedure-with-setter procedure setter Create a new procedure which behaves like @var{procedure}, but with the associated setter @var{setter}. @@ -99,6 +251,8 @@ procedure with setter, or an operator struct. @end deffn @deffn primitive setter proc +Return the setter of @var{proc}, which must be either a procedure with +setter or an operator struct. @end deffn From ac0b7ebd29c8f722e28e91d1a8198084211bca00 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 11 Apr 2001 16:41:46 +0000 Subject: [PATCH 0811/2047] * scheme-scheduling.texi (Arbiters): New explanatory text. (Asyncs): New explanations and documentation. (Scheduling): Added menu entry descriptions. (Fluids): New documentation. --- doc/ChangeLog | 7 + doc/scheme-scheduling.texi | 360 ------------------------------------- 2 files changed, 7 insertions(+), 360 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 3f4fe3d83..c9022841d 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,10 @@ +2001-04-11 Martin Grabmueller + + * scheme-scheduling.texi (Arbiters): New explanatory text. + (Asyncs): New explanations and documentation. + (Scheduling): Added menu entry descriptions. + (Fluids): New documentation. + 2001-04-11 Martin Grabmueller * scheme-procedures.texi (Lambda): Documented the lambda form. diff --git a/doc/scheme-scheduling.texi b/doc/scheme-scheduling.texi index bddb17dde..e69de29bb 100644 --- a/doc/scheme-scheduling.texi +++ b/doc/scheme-scheduling.texi @@ -1,360 +0,0 @@ -@page -@node Scheduling -@chapter Threads, Mutexes, Asyncs and Dynamic Roots - -[FIXME: This is pasted in from Tom Lord's original guile.texi chapter -plus the Cygnus programmer's manual; it should be *very* carefully -reviewed and largely reorganized.] - -@menu -* Arbiters:: -* Asyncs:: -* Dynamic Roots:: -* Threads:: -* Fluids:: -@end menu - - -@node Arbiters -@section Arbiters - -@deffn primitive make-arbiter name -Return an object of type arbiter and name @var{name}. Its -state is initially unlocked. Arbiters are a way to achieve -process synchronization. -@end deffn - -@deffn primitive try-arbiter arb -Return @code{#t} and lock the arbiter @var{arb} if the arbiter -was unlocked. Otherwise, return @code{#f}. -@end deffn - -@deffn primitive release-arbiter arb -Return @code{#t} and unlock the arbiter @var{arb} if the -arbiter was locked. Otherwise, return @code{#f}. -@end deffn - - -@node Asyncs -@section Asyncs - -@deffn primitive async thunk -Create a new async for the procedure @var{thunk}. -@end deffn - -@deffn primitive system-async thunk -Create a new async for the procedure @var{thunk}. Also -add it to the system's list of active async objects. -@end deffn - -@deffn primitive async-mark a -Mark the async @var{a} for future execution. -@end deffn - -@deffn primitive system-async-mark a -Mark the async @var{a} for future execution. -@end deffn - -@deffn primitive run-asyncs list_of_a -Execute all thunks from the asyncs of the list @var{list_of_a}. -@end deffn - -@deffn primitive noop . args -Do nothing. When called without arguments, return @code{#f}, -otherwise return the first argument. -@end deffn - -@deffn primitive unmask-signals -Unmask signals. The returned value is not specified. -@end deffn - -@deffn primitive mask-signals -Mask signals. The returned value is not specified. -@end deffn - - -@node Dynamic Roots -@section Dynamic Roots -@cindex dynamic roots - -A @dfn{dynamic root} is a root frame of Scheme evaluation. -The top-level repl, for example, is an instance of a dynamic root. - -Each dynamic root has its own chain of dynamic-wind information. Each -has its own set of continuations, jump-buffers, and pending CATCH -statements which are inaccessible from the dynamic scope of any -other dynamic root. - -In a thread-based system, each thread has its own dynamic root. Therefore, -continuations created by one thread may not be invoked by another. - -Even in a single-threaded system, it is sometimes useful to create a new -dynamic root. For example, if you want to apply a procedure, but to -not allow that procedure to capture the current continuation, calling -the procedure under a new dynamic root will do the job. - -@deffn primitive call-with-dynamic-root thunk handler -Evaluate @code{(thunk)} in a new dynamic context, returning its value. - -If an error occurs during evaluation, apply @var{handler} to the -arguments to the throw, just as @code{throw} would. If this happens, -@var{handler} is called outside the scope of the new root -- it is -called in the same dynamic context in which -@code{call-with-dynamic-root} was evaluated. - -If @var{thunk} captures a continuation, the continuation is rooted at -the call to @var{thunk}. In particular, the call to -@code{call-with-dynamic-root} is not captured. Therefore, -@code{call-with-dynamic-root} always returns at most one time. - -Before calling @var{thunk}, the dynamic-wind chain is un-wound back to -the root and a new chain started for @var{thunk}. Therefore, this call -may not do what you expect: - -@lisp -;; Almost certainly a bug: -(with-output-to-port - some-port - - (lambda () - (call-with-dynamic-root - (lambda () - (display 'fnord) - (newline)) - (lambda (errcode) errcode)))) -@end lisp - -The problem is, on what port will @samp{fnord} be displayed? You -might expect that because of the @code{with-output-to-port} that -it will be displayed on the port bound to @code{some-port}. But it -probably won't -- before evaluating the thunk, dynamic winds are -unwound, including those created by @code{with-output-to-port}. -So, the standard output port will have been re-set to its default value -before @code{display} is evaluated. - -(This function was added to Guile mostly to help calls to functions in C -libraries that can not tolerate non-local exits or calls that return -multiple times. If such functions call back to the interpreter, it should -be under a new dynamic root.) -@end deffn - - -@deffn primitive dynamic-root -Return an object representing the current dynamic root. - -These objects are only useful for comparison using @code{eq?}. -They are currently represented as numbers, but your code should -in no way depend on this. -@end deffn - -@c begin (scm-doc-string "boot-9.scm" "quit") -@deffn procedure quit [exit_val] -Throw back to the error handler of the current dynamic root. - -If integer @var{exit_val} is specified and if Guile is being used -stand-alone and if quit is called from the initial dynamic-root, -@var{exit_val} becomes the exit status of the Guile process and the -process exits. -@end deffn - -When Guile is run interactively, errors are caught from within the -read-eval-print loop. An error message will be printed and @code{abort} -called. A default set of signal handlers is installed, e.g., to allow -user interrupt of the interpreter. - -It is possible to switch to a "batch mode", in which the interpreter -will terminate after an error and in which all signals cause their -default actions. Switching to batch mode causes any handlers installed -from Scheme code to be removed. An example of where this is useful is -after forking a new process intended to run non-interactively. - -@c begin (scm-doc-string "boot-9.scm" "batch-mode?") -@deffn procedure batch-mode? -Returns a boolean indicating whether the interpreter is in batch mode. -@end deffn - -@c begin (scm-doc-string "boot-9.scm" "set-batch-mode?!") -@deffn procedure set-batch-mode?! arg -If @var{arg} is true, switches the interpreter to batch mode. -The @code{#f} case has not been implemented. -@end deffn - -@node Threads -@section Threads -@cindex threads -@cindex Guile threads - -@strong{[NOTE: this chapter was written for Cygnus Guile and has not yet -been updated for the Guile 1.x release.]} - -Here is a the reference for Guile's threads. In this chapter I simply -quote verbatim Tom Lord's description of the low-level primitives -written in C (basically an interface to the POSIX threads library) and -Anthony Green's description of the higher-level thread procedures -written in scheme. -@cindex posix threads -@cindex Lord, Tom -@cindex Green, Anthony - -When using Guile threads, keep in mind that each guile thread is -executed in a new dynamic root. - -@menu -* Low level thread primitives:: -* Higher level thread procedures:: -@end menu - - -@node Low level thread primitives -@subsection Low level thread primitives - -@c NJFIXME no current mechanism for making sure that these docstrings -@c are in sync. - -@c begin (texi-doc-string "guile" "call-with-new-thread") -@deffn primitive call-with-new-thread thunk error-handler -Evaluate @code{(thunk)} in a new thread, and new dynamic context, -returning a new thread object representing the thread. - -If an error occurs during evaluation, call error-handler, passing it an -error code describing the condition. [Error codes are currently -meaningless integers. In the future, real values will be specified.] -If this happens, the error-handler is called outside the scope of the new -root -- it is called in the same dynamic context in which -with-new-thread was evaluated, but not in the caller's thread. - -All the evaluation rules for dynamic roots apply to threads. -@end deffn - -@c begin (texi-doc-string "guile" "join-thread") -@deffn primitive join-thread thread -Suspend execution of the calling thread until the target @var{thread} -terminates, unless the target @var{thread} has already terminated. -@end deffn - -@c begin (texi-doc-string "guile" "yield") -@deffn primitive yield -If one or more threads are waiting to execute, calling yield forces an -immediate context switch to one of them. Otherwise, yield has no effect. -@end deffn - -@c begin (texi-doc-string "guile" "make-mutex") -@deffn primitive make-mutex -Create a new mutex object. -@end deffn - -@c begin (texi-doc-string "guile" "lock-mutex") -@deffn primitive lock-mutex mutex -Lock @var{mutex}. If the mutex is already locked, the calling thread -blocks until the mutex becomes available. The function returns when -the calling thread owns the lock on @var{mutex}. -@end deffn - -@c begin (texi-doc-string "guile" "unlock-mutex") -@deffn primitive unlock-mutex mutex -Unlocks @var{mutex} if the calling thread owns the lock on @var{mutex}. -Calling unlock-mutex on a mutex not owned by the current thread results -in undefined behaviour. Once a mutex has been unlocked, one thread -blocked on @var{mutex} is awakened and grabs the mutex lock. -@end deffn - -@c begin (texi-doc-string "guile" "make-condition-variable") -@deffn primitive make-condition-variable -@end deffn - -@c begin (texi-doc-string "guile" "wait-condition-variable") -@deffn primitive wait-condition-variable cond-var mutex -@end deffn - -@c begin (texi-doc-string "guile" "signal-condition-variable") -@deffn primitive signal-condition-variable cond-var -@end deffn - - -@node Higher level thread procedures -@subsection Higher level thread procedures - -@c new by ttn, needs review - -Higher level thread procedures are available by loading the -@code{(ice-9 threads)} module. These provide standardized -thread creation and mutex interaction. - -@deffn primitive %thread-handler tag args@dots{} - -This procedure is specified as the standard error-handler for -@code{make-thread} and @code{begin-thread}. If the number of @var{args} -is three or more, use @code{display-error}, otherwise display a message -"uncaught throw to @var{tag}". All output is sent to the port specified -by @code{current-error-port}. - -Before display, global var @code{the-last-stack} is set to @code{#f} -and signals are unmasked with @code{unmask-signals}. - -[FIXME: Why distinguish based on number of args?! Cue voodoo music here.] -@end deffn - -@deffn macro make-thread proc [args@dots{}] -Apply @var{proc} to @var{args} in a new thread formed by -@code{call-with-new-thread} using @code{%thread-handler} as the error -handler. -@end deffn - -@deffn macro begin-thread first [rest@dots{}] -Evaluate forms @var{first} and @var{rest} in a new thread formed by -@code{call-with-new-thread} using @code{%thread-handler} as the error -handler. -@end deffn - -@deffn macro with-mutex m [body@dots{}] -Lock mutex @var{m}, evaluate @var{body}, and then unlock @var{m}. -These sub-operations form the branches of a @code{dynamic-wind}. -@end deffn - -@deffn macro monitor first [rest@dots{}] -Evaluate forms @var{first} and @var{rest} under a newly created -anonymous mutex, using @code{with-mutex}. - -[FIXME: Is there any way to access the mutex?] -@end deffn - - -@node Fluids -@section Fluids - -@deffn primitive make-fluid -Return a newly created fluid. -Fluids are objects of a certain type (a smob) that can hold one SCM -value per dynamic root. That is, modifications to this value are -only visible to code that executes within the same dynamic root as -the modifying code. When a new dynamic root is constructed, it -inherits the values from its parent. Because each thread executes -in its own dynamic root, you can use fluids for thread local storage. -@end deffn - -@deffn primitive fluid? obj -Return @code{#t} iff @var{obj} is a fluid; otherwise, return -@code{#f}. -@end deffn - -@deffn primitive fluid-ref fluid -Return the value associated with @var{fluid} in the current -dynamic root. If @var{fluid} has not been set, then return -@code{#f}. -@end deffn - -@deffn primitive fluid-set! fluid value -Set the value associated with @var{fluid} in the current dynamic root. -@end deffn - -@deffn primitive with-fluids* fluids values thunk -Set @var{fluids} to @var{values} temporary, and call @var{thunk}. -@var{fluids} must be a list of fluids and @var{values} must be the same -number of their values to be applied. Each substitution is done -one after another. @var{thunk} must be a procedure with no argument. -@end deffn - - -@c Local Variables: -@c TeX-master: "guile.texi" -@c End: From a58c0d5f51a5c4418cb200e384cfd698a0025abb Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Wed, 11 Apr 2001 22:04:30 +0000 Subject: [PATCH 0812/2047] * Fix dvi build problem. --- doc/ChangeLog | 6 ++++++ doc/scheme-procedures.texi | 3 ++- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index c9022841d..237809d6f 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,9 @@ +2001-04-11 Neil Jerram + + * scheme-procedures.texi (Procedures with Setters): Fix dvi + building syntax error. Thanks to Dale P. Smith for the report and + patch. + 2001-04-11 Martin Grabmueller * scheme-scheduling.texi (Arbiters): New explanatory text. diff --git a/doc/scheme-procedures.texi b/doc/scheme-procedures.texi index c67f4556c..95f7d64aa 100644 --- a/doc/scheme-procedures.texi +++ b/doc/scheme-procedures.texi @@ -203,7 +203,8 @@ structure.@footnote{Working definitions would be: (define foo-ref vector-ref) (define foo-set! vector-set!) (define f (make-vector 2 #f)) -@end lisp} +@end lisp +} @lisp (foo-ref f 0) @result{} bar From f22ed5a028272f64f26f306701e1ecb470597862 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Thu, 12 Apr 2001 01:40:21 +0000 Subject: [PATCH 0813/2047] Use memset instead of bzero. --- ChangeLog | 6 ++++++ configure.in | 3 +-- libguile/ChangeLog | 10 ++++++++++ libguile/debug-malloc.c | 10 +++------- libguile/iselect.c | 8 -------- 5 files changed, 20 insertions(+), 17 deletions(-) diff --git a/ChangeLog b/ChangeLog index 6703eb8b8..30e0ad95c 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2001-04-11 Keisuke Nishida + + * configure.in (AC_CHECK_FUNCS): Don't check bzero. + (GUILE_FUNC_DECLARED): Removed checking of bzero. + Thanks to NIIBE Yutaka. + 2001-04-10 Mikael Djurfeldt * Undeprecated scm_init_oop_goopscore_module. diff --git a/configure.in b/configure.in index 7dcd92053..0b7242880 100644 --- a/configure.in +++ b/configure.in @@ -195,7 +195,7 @@ AC_SUBST(INCLTDL) AC_SUBST(LIBLTDL) AC_SUBST(DLPREOPEN) -AC_CHECK_FUNCS(ctermid ftime fchown getcwd geteuid gettimeofday lstat mkdir mknod nice readlink rename rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt strftime strptime symlink sync tcgetpgrp tcsetpgrp times uname waitpid bzero strdup system usleep atexit on_exit) +AC_CHECK_FUNCS(ctermid ftime fchown getcwd geteuid gettimeofday lstat mkdir mknod nice readlink rename rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt strftime strptime symlink sync tcgetpgrp tcsetpgrp times uname waitpid strdup system usleep atexit on_exit) AC_CHECK_HEADERS(crypt.h sys/resource.h sys/file.h) AC_CHECK_FUNCS(chroot flock getlogin cuserid getpriority setpriority getpass sethostname gethostname) @@ -219,7 +219,6 @@ AC_DEFUN(GUILE_FUNC_DECLARED, [ ]) GUILE_FUNC_DECLARED(strptime, time.h) -GUILE_FUNC_DECLARED(bzero, string.h) GUILE_FUNC_DECLARED(sleep, unistd.h) GUILE_FUNC_DECLARED(usleep, unistd.h) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 757697e83..0b0d3cf09 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,13 @@ +2001-04-11 Keisuke Nishida + + * debug-malloc.c (grow, scm_debug_malloc_prehistory): Use memset + instead of bzero. + + * coop.c, iselect.c (FD_ZERO_N): Unconditionally use memset. + (MISSING_BZERO_DECL): Remove the declaration. + + Thanks to NIIBE Yutaka. + 2001-04-10 Mikael Djurfeldt * init.c, goops.c, goops.h: Reverted change of 2001-03-29. (The diff --git a/libguile/debug-malloc.c b/libguile/debug-malloc.c index 8b2a08ceb..b3c5133d0 100644 --- a/libguile/debug-malloc.c +++ b/libguile/debug-malloc.c @@ -116,10 +116,6 @@ static hash_entry_t *malloc_object = 0; } \ while (0) -#ifdef MISSING_BZERO_DECL -extern void bzero (void *, size_t); -#endif - static void grow (hash_entry_t **table, int *size) { @@ -132,7 +128,7 @@ grow (hash_entry_t **table, int *size) again: TABLE (new) = realloc (TABLE (new), sizeof (hash_entry_t) * (SIZE (new) + N_SEEK)); - bzero (TABLE (new), sizeof (hash_entry_t) * (SIZE (new) + N_SEEK)); + memset (TABLE (new), 0, sizeof (hash_entry_t) * (SIZE (new) + N_SEEK)); for (i = 0; i < oldsize; ++i) if (oldtable[i].key) { @@ -249,10 +245,10 @@ scm_debug_malloc_prehistory () { malloc_type = malloc (sizeof (hash_entry_t) * (malloc_type_size + N_SEEK)); - bzero (malloc_type, sizeof (hash_entry_t) * (malloc_type_size + N_SEEK)); + memset (malloc_type, 0, sizeof (hash_entry_t) * (malloc_type_size + N_SEEK)); malloc_object = malloc (sizeof (hash_entry_t) * (malloc_object_size + N_SEEK)); - bzero (malloc_object, sizeof (hash_entry_t) * (malloc_object_size + N_SEEK)); + memset (malloc_object, 0, sizeof (hash_entry_t) * (malloc_object_size + N_SEEK)); } void diff --git a/libguile/iselect.c b/libguile/iselect.c index 867863594..2024f15f3 100644 --- a/libguile/iselect.c +++ b/libguile/iselect.c @@ -57,10 +57,6 @@ #include "libguile/coop-threads.h" -#ifdef MISSING_BZERO_DECL -extern void bzero (void *, size_t); -#endif - /* COOP queue macros */ @@ -92,11 +88,7 @@ extern void bzero (void *, size_t); #error Could not determine suitable definition for SCM_NLONGBITS #endif -#ifdef HAVE_BZERO -#define FD_ZERO_N(pos, n) bzero ((pos), (n)) -#else #define FD_ZERO_N(pos, n) memset ((void *) (pos), 0, (n)) -#endif typedef unsigned long *ulongptr; From 0da6608d93949a128a7479dbe09e13eb4ba5a388 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 12 Apr 2001 10:00:08 +0000 Subject: [PATCH 0814/2047] * Applied Niibe Yutaka's patch to add libguileqthreads version info. --- ChangeLog | 8 ++++++++ GUILE-VERSION | 6 ++++++ THANKS | 1 + configure.in | 4 ++++ 4 files changed, 19 insertions(+) diff --git a/ChangeLog b/ChangeLog index 30e0ad95c..694d6f415 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2001-04-12 Niibe Yutaka + + * GUILE-VERSION (LIBGUILEQTHREADS_MAJOR_VERSION, + LIBGUILEQTHREADS_MINOR_VERSION, LIBGUILEQTHREADS_REVISION_VERSION, + LIBGUILEQTHREADS_VERSION): Added libguileqthreads version info. + + * configure.in: Likewise. + 2001-04-11 Keisuke Nishida * configure.in (AC_CHECK_FUNCS): Don't check bzero. diff --git a/GUILE-VERSION b/GUILE-VERSION index 0d61f1b50..1058c0aca 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -11,3 +11,9 @@ LIBGUILE_MAJOR_VERSION=10 LIBGUILE_MINOR_VERSION=0 LIBGUILE_REVISION_VERSION=0 LIBGUILE_VERSION=${LIBGUILE_MAJOR_VERSION}.${LIBGUILE_MINOR_VERSION}.${LIBGUILE_REVISION_VERSION} + +# libguileqthreads.so versioning info +LIBGUILEQTHREADS_MAJOR_VERSION=0 +LIBGUILEQTHREADS_MINOR_VERSION=0 +LIBGUILEQTHREADS_REVISION_VERSION=0 +LIBGUILEQTHREADS_VERSION=${LIBGUILEQTHREADS_MAJOR_VERSION}.${LIBGUILEQTHREADS_MINOR_VERSION}.${LIBGUILEQTHREADS_REVISION_VERSION} diff --git a/THANKS b/THANKS index 142814adc..9b98b45a7 100644 --- a/THANKS +++ b/THANKS @@ -38,3 +38,4 @@ For fixes or providing information which led to a fix: Brett Viren William Webber Keith Wright + Niibe Yutaka diff --git a/configure.in b/configure.in index 0b7242880..dc44f96cc 100644 --- a/configure.in +++ b/configure.in @@ -493,6 +493,10 @@ if test "${THREAD_PACKAGE}" != "" ; then AC_CHECK_LIB(pthread, main) fi fi +AC_SUBST(LIBGUILEQTHREADS_MAJOR_VERSION) +AC_SUBST(LIBGUILEQTHREADS_MINOR_VERSION) +AC_SUBST(LIBGUILEQTHREADS_REVISION_VERSION) +AC_SUBST(LIBGUILEQTHREADS_VERSION) ## If we're using GCC, ask for aggressive warnings. case "$GCC" in From 505392ae32153528d312943c4ef6a6bc9d3e52ae Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 13 Apr 2001 09:56:37 +0000 Subject: [PATCH 0815/2047] * Incorporate Dirk's description of SCM and scm_bits_t. * Remove obsolete notes about needing to use SCM_NIMP. --- doc/ChangeLog | 7 + doc/data-rep.texi | 364 ++++++++++++++++++++++++++++++++++++++++------ 2 files changed, 328 insertions(+), 43 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 237809d6f..aabe3166f 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,10 @@ +2001-04-13 Neil Jerram + + * data-rep.texi (Unpacking the SCM type): New section, taken from + Dirk Herrmann's description of SCM and scm_bits_t in api.txt. + (Immediate Datatypes, Non-immediate Datatypes): Remove obsolete + notes about needing to call SCM_NIMP. + 2001-04-11 Neil Jerram * scheme-procedures.texi (Procedures with Setters): Fix dvi diff --git a/doc/data-rep.texi b/doc/data-rep.texi index 81fbe8593..9b0544741 100644 --- a/doc/data-rep.texi +++ b/doc/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.18 2001-04-02 21:53:20 ossau Exp $ +@c essay @subtitle $Id: data-rep.texi,v 1.19 2001-04-13 09:56:37 ossau Exp $ @c essay @subtitle For use with Guile @value{VERSION} @c essay @author Jim Blandy @c essay @author Free Software Foundation @@ -437,6 +437,7 @@ everything one need know to use Guile's data. * Immediate Datatypes:: * Non-immediate Datatypes:: * Signalling Type Errors:: +* Unpacking the SCM type:: @end menu @node General Rules @@ -520,8 +521,8 @@ error. To accommodate this technique, data must be represented so that the collector can accurately determine whether a given stack word is a pointer or not. Guile does this as follows: -@itemize @bullet +@itemize @bullet @item Every heap object has a two-word header, called a @dfn{cell}. Some objects, like pairs, fit entirely in a cell's two words; others may @@ -538,7 +539,6 @@ initialized, whether or not they are currently in use. @item Guile maintains a sorted table of heap segments. - @end itemize Thus, given any random word @var{w} fetched from the stack, Guile's @@ -594,11 +594,7 @@ vs Non-immediates} for an explanation of the distinction. Note that the type predicates for immediate values work correctly on any @code{SCM} value; you do not need to call @code{SCM_IMP} first, to -establish that a value is immediate. This differs from the -non-immediate type predicates, which work correctly only on -non-immediate values; you must be sure the value is @code{SCM_NIMP} -before applying them. - +establish that a value is immediate. @menu * Integer Data:: @@ -747,10 +743,18 @@ on the tag; the non-immediate type predicates test this value. If a tag value appears elsewhere (in a vector, for example), the heap may become corrupted. +Note how the type information for a non-immediate object is split +between the @code{SCM} word and the cell that the @code{SCM} word points +to. The @code{SCM} word itself only indicates that the object is +non-immediate --- in other words stored in a heap cell. The tag stored +in the first word of the heap cell indicates more precisely the type of +that object. + +As of Guile 1.4, the type predicates for non-immediate values work +correctly on any @code{SCM} value; you do not need to call +@code{SCM_NIMP} first, to establish that a value is non-immediate. @menu -* Non-immediate Type Predicates:: Special rules for using the type - predicates described here. * Pair Data:: * Vector Data:: * Procedures:: @@ -759,26 +763,6 @@ corrupted. * Port Data:: @end menu -@node Non-immediate Type Predicates -@subsubsection Non-immediate Type Predicates - -As mentioned in @ref{Conservative GC}, all non-immediate objects -start with a @dfn{cell}, or a pair of words. Furthermore, all type -information that distinguishes one kind of non-immediate from another is -stored in the cell. The type information in the @code{SCM} value -indicates only that the object is a non-immediate; all finer -distinctions require one to examine the cell itself, usually with the -appropriate type predicate macro. - -The type predicates for non-immediate objects generally assume that -their argument is a non-immediate value. Thus, you must be sure that a -value is @code{SCM_NIMP} first before passing it to a non-immediate type -predicate. Thus, the idiom for testing whether a value is a cell or not -is: -@example -SCM_NIMP (@var{x}) && SCM_CONSP (@var{x}) -@end example - @node Pair Data @subsubsection Pairs @@ -801,7 +785,6 @@ directly into the two words of the cell. @deftypefn Macro int SCM_CONSP (SCM @var{x}) Return non-zero iff @var{x} is a Scheme pair object. -The results are undefined if @var{x} is an immediate value. @end deftypefn @deftypefn Macro int SCM_NCONSP (SCM @var{x}) @@ -832,7 +815,6 @@ Allocate (``CONStruct'') a new pair, with @var{car} and @var{cdr} as its contents. @end deftypefun - The macros below perform no typechecking. The results are undefined if @var{cell} is an immediate. However, since all non-immediate Guile objects are constructed from cells, and these macros simply return the @@ -880,32 +862,29 @@ are (somewhat) meaningful when applied to these datatypes. @deftypefn Macro int SCM_VECTORP (SCM @var{x}) Return non-zero iff @var{x} is a vector. -The results are undefined if @var{x} is an immediate value. @end deftypefn @deftypefn Macro int SCM_STRINGP (SCM @var{x}) Return non-zero iff @var{x} is a string. -The results are undefined if @var{x} is an immediate value. @end deftypefn @deftypefn Macro int SCM_SYMBOLP (SCM @var{x}) Return non-zero iff @var{x} is a symbol. -The results are undefined if @var{x} is an immediate value. @end deftypefn @deftypefn Macro int SCM_LENGTH (SCM @var{x}) Return the length of the object @var{x}. -The results are undefined if @var{x} is not a vector, string, or symbol. +The result is undefined if @var{x} is not a vector, string, or symbol. @end deftypefn @deftypefn Macro {SCM *} SCM_VELTS (SCM @var{x}) Return a pointer to the array of elements of the vector @var{x}. -The results are undefined if @var{x} is not a vector. +The result is undefined if @var{x} is not a vector. @end deftypefn @deftypefn Macro {char *} SCM_CHARS (SCM @var{x}) Return a pointer to the characters of @var{x}. -The results are undefined if @var{x} is not a symbol or a string. +The result is undefined if @var{x} is not a symbol or a string. @end deftypefn There are also a few magic values stuffed into memory before a symbol's @@ -945,8 +924,7 @@ store information about the closure. I'm not sure what this is used for at the moment --- the debugger, maybe? @deftypefn Macro int SCM_CLOSUREP (SCM @var{x}) -Return non-zero iff @var{x} is a closure. The results are -undefined if @var{x} is an immediate value. +Return non-zero iff @var{x} is a closure. @end deftypefn @deftypefn Macro SCM SCM_PROCPROPS (SCM @var{x}) @@ -960,7 +938,7 @@ are undefined if @var{x} is not a closure. @end deftypefn @deftypefn Macro SCM SCM_CODE (SCM @var{x}) -Return the code of the closure @var{x}. The results are undefined if +Return the code of the closure @var{x}. The result is undefined if @var{x} is not a closure. This function should probably only be used internally by the @@ -970,7 +948,7 @@ connected with the interpreter's implementation. @deftypefn Macro SCM SCM_ENV (SCM @var{x}) Return the environment enclosed by @var{x}. -The results are undefined if @var{x} is not a closure. +The result is undefined if @var{x} is not a closure. This function should probably only be used internally by the interpreter, since the representation of the environment is intimately @@ -994,7 +972,7 @@ distinct from other kinds of procedures. The closest thing is @code{scm_procedure_p}; see @ref{Procedures}. @deftypefn Macro {char *} SCM_SNAME (@var{x}) -Return the name of the subr @var{x}. The results are undefined if +Return the name of the subr @var{x}. The result is undefined if @var{x} is not a subr. @end deftypefn @@ -1091,6 +1069,306 @@ invoking the subr, so we don't run into these problems. @end deftypefn +@node Unpacking the SCM type +@subsection Unpacking the SCM Type + +The previous sections have explained how @code{SCM} values can refer to +immediate and non-immediate Scheme objects. For immediate objects, the +complete object value is stored in the @code{SCM} word itself, while for +non-immediates, the @code{SCM} word contains a pointer to a heap cell, +and further information about the object in question is stored in that +cell. This section describes how the @code{SCM} type is actually +represented and used at the C level. + +In fact, there are two basic C data types to represent objects in Guile: + +@itemize @bullet +@item +@code{SCM} is the user level abstract C type that is used to represent +all of Guile's Scheme objects, no matter what the Scheme object type is. +No C operation except assignment is guaranteed to work with variables of +type @code{SCM}, so you should only use macros and functions to work +with @code{SCM} values. Values are converted between C data types and +the @code{SCM} type with utility functions and macros. + +@item +@code{scm_bits_t} is an integral data type that is guaranteed to be +large enough to hold all information that is required to represent any +Scheme object. While this data type is mostly used to implement Guile's +internals, the use of this type is also necessary to write certain kinds +of extensions to Guile. +@end itemize + +@menu +* Relationship between SCM and scm_bits_t:: +* Immediate objects:: +* Non-immediate objects:: +* Heap Cell Type Information:: +* Accessing Cell Entries:: +* Basic Rules for Accessing Cell Entries:: +@end menu + + +@node Relationship between SCM and scm_bits_t +@subsubsection Relationship between @code{SCM} and @code{scm_bits_t} + +A variable of type @code{SCM} is guaranteed to hold a valid Scheme +object. A variable of type @code{scm_bits_t}, on the other hand, may +hold a representation of a @code{SCM} value as a C integral type, but +may also hold any C value, even if it does not correspond to a valid +Scheme object. + +For a variable @var{x} of type @code{SCM}, the Scheme object's type +information is stored in a form that is not directly usable. To be able +to work on the type encoding of the scheme value, the @code{SCM} +variable has to be transformed into the corresponding representation as +a @code{scm_bits_t} variable @var{y} by using the @code{SCM_UNPACK} +macro. Once this has been done, the type of the scheme object @var{x} +can be derived from the content of the bits of the @code{scm_bits_t} +value @var{y}, in the way illustrated by the example earlier in this +chapter (@pxref{Cheaper Pairs}). Conversely, a valid bit encoding of a +Scheme value as a @code{scm_bits_t} variable can be transformed into the +corresponding @code{SCM} value using the @code{SCM_PACK} macro. + +@deftypefn Macro scm_bits_t SCM_UNPACK (SCM @var{x}) +Transforms the @code{SCM} value @var{x} into its representation as an +integral type. Only after applying @code{SCM_UNPACK} it is possible to +access the bits and contents of the @code{SCM} value. +@end deftypefn + +@deftypefn SCM SCM_PACK (scm_bits_t @var{x}) +Takes a valid integral representation of a Scheme object and transforms +it into its representation as a @code{SCM} value. +@end deftypefn + + +@node Immediate objects +@subsubsection Immediate objects + +A Scheme object may either be an immediate, i.e. carrying all necessary +information by itself, or it may contain a reference to a @dfn{cell} +with additional information on the heap. Although in general it should +be irrelevant for user code whether an object is an immediate or not, +within Guile's own code the distinction is sometimes of importance. +Thus, the following low level macro is provided: + +@deftypefn Macro int SCM_IMP (SCM @var{x}) +A Scheme object is an immediate if it fulfills the @code{SCM_IMP} +predicate, otherwise it holds an encoded reference to a heap cell. The +result of the predicate is delivered as a C style boolean value. User +code and code that extends Guile should normally not be required to use +this macro. +@end deftypefn + +@noindent +Summary: +@itemize @bullet +@item +Given a Scheme object @var{x} of unknown type, check first +with @code{SCM_IMP (@var{x})} if it is an immediate object. +@item +If so, all of the type and value information can be determined from the +@code{scm_bits_t} value that is delivered by @code{SCM_UNPACK +(@var{x})}. +@end itemize + + +@node Non-immediate objects +@subsubsection Non-immediate objects + +A Scheme object of type @code{SCM} that does not fullfill the +@code{SCM_IMP} predicate holds an encoded reference to a heap cell. +This reference can be decoded to a C pointer to a heap cell using the +@code{SCM2PTR} macro. The encoding of a pointer to a heap cell into a +@code{SCM} value is done using the @code{PTR2SCM} macro. + +@c (FIXME:: this name should be changed) +@deftypefn Macro (scm_cell *) SCM2PTR (SCM @var{x}) +Extract and return the heap cell pointer from a non-immediate @code{SCM} +object @var{x}. +@end deftypefn + +@c (FIXME:: this name should be changed) +@deftypefn Macro SCM PTR2SCM (scm_cell * @var{x}) +Return a @code{SCM} value that encodes a reference to the heap cell +pointer @var{x}. +@end deftypefn + +Note that it is also possible to transform a non-immediate @code{SCM} +value by using @code{SCM_UNPACK} into a @code{scm_bits_t} variable. +However, the result of @code{SCM_UNPACK} may not be used as a pointer to +a @code{scm_cell}: only @code{SCM2PTR} is guaranteed to transform a +@code{SCM} object into a valid pointer to a heap cell. Also, it is not +allowed to apply @code{PTR2SCM} to anything that is not a valid pointer +to a heap cell. + +@noindent +Summary: +@itemize @bullet +@item +Only use @code{SCM2PTR} on @code{SCM} values for which @code{SCM_IMP} is +false! +@item +Don't use @code{(scm_cell *) SCM_UNPACK (@var{x})}! Use @code{SCM2PTR +(@var{x})} instead! +@item +Don't use @code{PTR2SCM} for anything but a cell pointer! +@end itemize + + +@node Heap Cell Type Information +@subsubsection Heap Cell Type Information + +Heap cells contain a number of entries, each of which is either a scheme +object of type @code{SCM} or a raw C value of type @code{scm_bits_t}. +Which of the cell entries contain Scheme objects and which contain raw C +values is determined by the first entry of the cell, which holds the +cell type information. + +@deftypefn Macro scm_bits_t SCM_CELL_TYPE (SCM @var{x}) +For a non-immediate Scheme object @var{x}, deliver the content of the +first entry of the heap cell referenced by @var{x}. This value holds +the information about the cell type. +@end deftypefn + +@deftypefn Macro void SCM_SET_CELL_TYPE (SCM @var{x}, scm_bits_t @var{t}) +For a non-immediate Scheme object @var{x}, write the value @var{t} into +the first entry of the heap cell referenced by @var{x}. The value +@var{t} must hold a valid cell type. +@end deftypefn + + +@node Accessing Cell Entries +@subsubsection Accessing Cell Entries + +For a non-immediate Scheme object @var{x}, the object type can be +determined by reading the cell type entry using the @code{SCM_CELL_TYPE} +macro. For each different type of cell it is known which cell entries +hold Scheme objects and which cell entries hold raw C data. To access +the different cell entries appropriately, the following macros are +provided. + +@deftypefn Macro scm_bits_t SCM_CELL_WORD (SCM @var{x}, unsigned int @var{n}) +Deliver the cell entry @var{n} of the heap cell referenced by the +non-immediate Scheme object @var{x} as raw data. It is illegal, to +access cell entries that hold Scheme objects by using these macros. For +convenience, the following macros are also provided. +@itemize +@item +SCM_CELL_WORD_0 (@var{x}) @result{} SCM_CELL_WORD (@var{x}, 0) +@item +SCM_CELL_WORD_1 (@var{x}) @result{} SCM_CELL_WORD (@var{x}, 1) +@item +@dots{} +@item +SCM_CELL_WORD_@var{n} (@var{x}) @result{} SCM_CELL_WORD (@var{x}, @var{n}) +@end itemize +@end deftypefn + +@deftypefn Macro SCM SCM_CELL_OBJECT (SCM @var{x}, unsigned int @var{n}) +Deliver the cell entry @var{n} of the heap cell referenced by the +non-immediate Scheme object @var{x} as a Scheme object. It is illegal, +to access cell entries that do not hold Scheme objects by using these +macros. For convenience, the following macros are also provided. +@itemize +@item +SCM_CELL_OBJECT_0 (@var{x}) @result{} SCM_CELL_OBJECT (@var{x}, 0) +@item +SCM_CELL_OBJECT_1 (@var{x}) @result{} SCM_CELL_OBJECT (@var{x}, 1) +@item +@dots{} +@item +SCM_CELL_OBJECT_@var{n} (@var{x}) @result{} SCM_CELL_OBJECT (@var{x}, +@var{n}) +@end itemize +@end deftypefn + +@deftypefn Macro void SCM_SET_CELL_WORD (SCM @var{x}, unsigned int @var{n}, scm_bits_t @var{w}) +Write the raw C value @var{w} into entry number @var{n} of the heap cell +referenced by the non-immediate Scheme value @var{x}. Values that are +written into cells this way may only be read from the cells using the +@code{SCM_CELL_WORD} macros or, in case cell entry 0 is written, using +the @code{SCM_CELL_TYPE} macro. For the special case of cell entry 0 it +has to be made sure that @var{w} contains a cell type information which +does not describe a Scheme object. For convenience, the following +macros are also provided. +@itemize +@item +SCM_SET_CELL_WORD_0 (@var{x}, @var{w}) @result{} SCM_SET_CELL_WORD +(@var{x}, 0, @var{w}) +@item +SCM_SET_CELL_WORD_1 (@var{x}, @var{w}) @result{} SCM_SET_CELL_WORD +(@var{x}, 1, @var{w}) +@item +@dots{} +@item +SCM_SET_CELL_WORD_@var{n} (@var{x}, @var{w}) @result{} SCM_SET_CELL_WORD +(@var{x}, @var{n}, @var{w}) +@end itemize +@end deftypefn + +@deftypefn Macro void SCM_SET_CELL_OBJECT (SCM @var{x}, unsigned int @var{n}, SCM @var{o}) +Write the Scheme object @var{o} into entry number @var{n} of the heap +cell referenced by the non-immediate Scheme value @var{x}. Values that +are written into cells this way may only be read from the cells using +the @code{SCM_CELL_OBJECT} macros or, in case cell entry 0 is written, +using the @code{SCM_CELL_TYPE} macro. For the special case of cell +entry 0 the writing of a Scheme object into this cell is only allowed +if the cell forms a Scheme pair. For convenience, the following macros +are also provided. +@itemize +@item +SCM_SET_CELL_OBJECT_0 (@var{x}, @var{o}) @result{} SCM_SET_CELL_OBJECT +(@var{x}, 0, @var{o}) +@item +SCM_SET_CELL_OBJECT_1 (@var{x}, @var{o}) @result{} SCM_SET_CELL_OBJECT +(@var{x}, 1, @var{o}) +@item +@dots{} +@item +SCM_SET_CELL_OBJECT_@var{n} (@var{x}, @var{o}) @result{} +SCM_SET_CELL_OBJECT (@var{x}, @var{n}, @var{o}) +@end itemize +@end deftypefn + +@noindent +Summary: +@itemize @bullet +@item +For a non-immediate Scheme object @var{x} of unknown type, get the type +information by using @code{SCM_CELL_TYPE (@var{x})}. +@item +As soon as the cell type information is available, only use the +appropriate access methods to read and write data to the different cell +entries. +@end itemize + + +@node Basic Rules for Accessing Cell Entries +@subsubsection Basic Rules for Accessing Cell Entries + +For each cell type it is generally up to the implementation of that type +which of the corresponding cell entries hold Scheme objects and which +hold raw C values. However, there is one basic rule that has to be +followed: Scheme pairs consist of exactly two cell entries, which both +contain Scheme objects. Further, a cell which contains a Scheme object +in it first entry has to be a Scheme pair. In other words, it is not +allowed to store a Scheme object in the first cell entry and a non +Scheme object in the second cell entry. + +@c Fixme:shouldn't this rather be SCM_PAIRP / SCM_PAIR_P ? +@deftypefn Macro int SCM_CONSP (SCM @var{x}) +Determine, whether the Scheme object @var{x} is a Scheme pair, +i.e. whether @var{x} references a heap cell consisting of exactly two +entries, where both entries contain a Scheme object. In this case, both +entries will have to be accessed using the @code{SCM_CELL_OBJECT} +macros. On the contrary, if the SCM_CONSP predicate is not fulfilled, +the first entry of the Scheme cell is guaranteed not to be a Scheme +value and thus the first cell entry must be accessed using the +@code{SCM_CELL_WORD_0} macro. +@end deftypefn + + @node Defining New Types (Smobs) @section Defining New Types (Smobs) From c4d0cddd4cbd3ac58ffb569ef310711cd2f596c3 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 13 Apr 2001 11:12:01 +0000 Subject: [PATCH 0816/2047] * Texinfo markup fixes. --- doc/data-rep.texi | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/doc/data-rep.texi b/doc/data-rep.texi index 9b0544741..afeaafa1d 100644 --- a/doc/data-rep.texi +++ b/doc/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.19 2001-04-13 09:56:37 ossau Exp $ +@c essay @subtitle $Id: data-rep.texi,v 1.20 2001-04-13 11:12:01 ossau Exp $ @c essay @subtitle For use with Guile @value{VERSION} @c essay @author Jim Blandy @c essay @author Free Software Foundation @@ -1136,7 +1136,7 @@ integral type. Only after applying @code{SCM_UNPACK} it is possible to access the bits and contents of the @code{SCM} value. @end deftypefn -@deftypefn SCM SCM_PACK (scm_bits_t @var{x}) +@deftypefn Macro SCM SCM_PACK (scm_bits_t @var{x}) Takes a valid integral representation of a Scheme object and transforms it into its representation as a @code{SCM} value. @end deftypefn @@ -1362,9 +1362,9 @@ Determine, whether the Scheme object @var{x} is a Scheme pair, i.e. whether @var{x} references a heap cell consisting of exactly two entries, where both entries contain a Scheme object. In this case, both entries will have to be accessed using the @code{SCM_CELL_OBJECT} -macros. On the contrary, if the SCM_CONSP predicate is not fulfilled, -the first entry of the Scheme cell is guaranteed not to be a Scheme -value and thus the first cell entry must be accessed using the +macros. On the contrary, if the @code{SCM_CONSP} predicate is not +fulfilled, the first entry of the Scheme cell is guaranteed not to be a +Scheme value and thus the first cell entry must be accessed using the @code{SCM_CELL_WORD_0} macro. @end deftypefn From a54e6fa3264e110a0dd9292fab3d4cffbf863eae Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sat, 14 Apr 2001 12:29:54 +0000 Subject: [PATCH 0817/2047] Moved up the eval-case section. --- ice-9/boot-9.scm | 68 ++++++++++++++++++++++++------------------------ 1 file changed, 34 insertions(+), 34 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index f2482b821..22a1fe051 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1954,6 +1954,40 @@ + +;; {EVAL-CASE} +;; +;; (eval-case ((situation*) forms)* (else forms)?) +;; +;; Evaluate certain code based on the situation that eval-case is used +;; in. The only defined situation right now is `load-toplevel' which +;; triggers for code evaluated at the top-level, for example from the +;; REPL or when loading a file. + +(define eval-case + (procedure->memoizing-macro + (lambda (exp env) + (define (toplevel-env? env) + (or (not (pair? env)) (not (pair? (car env))))) + (define (syntax) + (error "syntax error in eval-case")) + (let loop ((clauses (cdr exp))) + (cond + ((null? clauses) + #f) + ((not (list? (car clauses))) + (syntax)) + ((eq? 'else (caar clauses)) + (or (null? (cdr clauses)) + (syntax)) + (cons 'begin (cdar clauses))) + ((not (list? (caar clauses))) + (syntax)) + ((and (toplevel-env? env) + (memq 'load-toplevel (caar clauses))) + (cons 'begin (cdar clauses))) + (else + (loop (cdr clauses)))))))) ;;; {Macros} @@ -2537,40 +2571,6 @@ `(lambda ,(cdr first) ,@rest)))) `(define ,name (defmacro:syntax-transformer ,transformer)))) -;; EVAL-CASE -;; -;; (eval-case ((situation*) forms)* (else forms)?) -;; -;; Evaluate certain code based on the situation that eval-case is used -;; in. The only defined situation right now is `load-toplevel' which -;; triggers for code evaluated at the top-level, for example from the -;; REPL or when loading a file. - -(define eval-case - (procedure->memoizing-macro - (lambda (exp env) - (define (toplevel-env? env) - (or (not (pair? env)) (not (pair? (car env))))) - (define (syntax) - (error "syntax error in eval-case")) - (let loop ((clauses (cdr exp))) - (cond - ((null? clauses) - #f) - ((not (list? (car clauses))) - (syntax)) - ((eq? 'else (caar clauses)) - (or (null? (cdr clauses)) - (syntax)) - (cons 'begin (cdar clauses))) - ((not (list? (caar clauses))) - (syntax)) - ((and (toplevel-env? env) - (memq 'load-toplevel (caar clauses))) - (cons 'begin (cdar clauses))) - (else - (loop (cdr clauses)))))))) - ;;; {Module System Macros} ;;; From 8add1522aededbc973055d2ee60e4ae2cedb9c81 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 15 Apr 2001 15:20:28 +0000 Subject: [PATCH 0818/2047] * boot-9.scm (defmacro, define-macro, define-syntax-macro): Define only at the top level. --- ice-9/ChangeLog | 5 +++++ ice-9/boot-9.scm | 21 +++++++++++++++------ 2 files changed, 20 insertions(+), 6 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index bd4b6095b..2a49030ee 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2001-04-15 Keisuke Nishida + + * boot-9.scm (defmacro, define-macro, define-syntax-macro): + Define only at the top level. + 2001-04-06 Thien-Thi Nguyen * threads.scm: Update copyright. diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 22a1fe051..17bdf5c38 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -2021,10 +2021,11 @@ (let ((defmacro-transformer (lambda (name parms . body) (let ((transformer `(lambda ,parms ,@body))) - `(define ,name - (,(lambda (transformer) - (defmacro:transformer transformer)) - ,transformer)))))) + `(eval-case + ((load-toplevel) + (define ,name (defmacro:transformer ,transformer))) + (else + (error "defmacro can only be used at the top level"))))))) (defmacro:transformer defmacro-transformer))) (define defmacro:syntax-transformer @@ -2560,7 +2561,11 @@ (if (symbol? first) (car rest) `(lambda ,(cdr first) ,@rest)))) - `(define ,name (defmacro:transformer ,transformer)))) + `(eval-case + ((load-toplevel) + (define ,name (defmacro:transformer ,transformer))) + (else + (error "define-macro can only be used at the top level"))))) (defmacro define-syntax-macro (first . rest) @@ -2569,7 +2574,11 @@ (if (symbol? first) (car rest) `(lambda ,(cdr first) ,@rest)))) - `(define ,name (defmacro:syntax-transformer ,transformer)))) + `(eval-case + ((load-toplevel) + (define ,name (defmacro:syntax-transformer ,transformer))) + (else + (error "define-syntax-macro can only be used at the top level"))))) ;;; {Module System Macros} From 6b08d75b56b1464b36abd9d50ccde69d6e4e56f0 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 15 Apr 2001 22:47:25 +0000 Subject: [PATCH 0819/2047] * boot-9.scm (call-with-deprecation): New procedure. (identity): New procedure. (id): Deprecated. --- ice-9/ChangeLog | 6 ++++++ ice-9/boot-9.scm | 21 ++++++++++++++++++++- 2 files changed, 26 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 2a49030ee..20e054d25 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,9 @@ +2001-04-15 Keisuke Nishida + + * boot-9.scm (call-with-deprecation): New procedure. + (identity): New procedure. + (id): Deprecated. + 2001-04-15 Keisuke Nishida * boot-9.scm (defmacro, define-macro, define-syntax-macro): diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 17bdf5c38..afca0435a 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -87,7 +87,7 @@ ;;; {Trivial Functions} ;;; -(define (id x) x) +(define (identity x) x) (define (1+ n) (+ n 1)) (define (-1+ n) (+ n -1)) (define 1- -1+) @@ -109,6 +109,25 @@ (define (apply-to-args args fn) (apply fn args)) + +;;; {Deprecation} +;;; + +(define call-with-deprecation + (let ((issued-warnings (make-hash-table 13))) + (lambda (msg thunk) + (cond ((not (hashv-ref issued-warnings msg #f)) + (display ";;; " (current-error-port)) + (display msg (current-error-port)) + (newline (current-error-port)) + (hashv-set! issued-warnings msg #t))) + (thunk)))) + +(define (id x) + (call-with-deprecation "`id' is deprecated. Use `identity' instead." + (lambda () + (identity x)))) + ;;; {Integer Math} ;;; From 56426fdbaf3ed75f9a52bcb32f99d8801b881243 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 15 Apr 2001 22:55:49 +0000 Subject: [PATCH 0820/2047] Deprecate `id'. --- NEWS | 23 +++++++++++++++++++++++ RELEASE | 2 +- 2 files changed, 24 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index 2db1398a1..292872726 100644 --- a/NEWS +++ b/NEWS @@ -288,6 +288,21 @@ objects are usually permanent. ** Escape procedures created by call-with-current-continuation now accept any number of arguments, as required by R5RS. +** New function `call-with-deprecation' + +Call a thunk, displaying a deprecation message at the first call: + + (define (id x) + (call-with-deprecation "`id' is deprecated. Use `identity' instead." + (lambda () + (identity x)))) + + guile> (id 1) + ;; `id' is deprecated. Use `identity' instead. + 1 + guile> (id 1) + 1 + ** New function `make-object-property' This function returns a new `procedure with setter' P that can be used @@ -487,6 +502,14 @@ The data can then be retrieved by `get-output-string'. Return the contents of an output string port. +** New function: identity + +Return the argument. + +** Deprecated: id + +Use `identity' instead. + ** Deprecated: close-all-ports-except. This was intended for closing ports in a child process after a fork, diff --git a/RELEASE b/RELEASE index 2ffa89fca..1d67c6dc2 100644 --- a/RELEASE +++ b/RELEASE @@ -55,7 +55,7 @@ In release 1.6: gc.c: scm_remember string.c: scm_makstr - remove deprecated procedures: - boot-9.scm:eval-in-module + boot-9.scm: eval-in-module, id - remove deprecated macros: SCM_OUTOFRANGE, SCM_NALLOC, SCM_HUP_SIGNAL, SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD, From ff5546f5c6898ae47f72a8edbb3c6f13be60ce7e Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Mon, 16 Apr 2001 03:42:36 +0000 Subject: [PATCH 0821/2047] * boot-9.scm (load-compiled): New variable, initialized in the VM. (try-module-autoload): Try loading compiled modules if applicable. --- ice-9/ChangeLog | 5 +++++ ice-9/boot-9.scm | 20 +++++++++++++++----- 2 files changed, 20 insertions(+), 5 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 20e054d25..48333bd72 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2001-04-15 Keisuke Nishida + + * boot-9.scm (load-compiled): New variable, initialized in the VM. + (try-module-autoload): Try loading compiled modules if applicable. + 2001-04-15 Keisuke Nishida * boot-9.scm (call-with-deprecation): New procedure. diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index afca0435a..4cdfab4c2 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1727,6 +1727,10 @@ (module-constructor #() '() b #f #f name 'autoload '() (make-weak-value-hash-table 31) 0))) +;;; {Compiled module} + +(define load-compiled #f) + ;;; {Autoloading modules} @@ -1743,14 +1747,20 @@ (resolve-module dir-hint-module-name #f) (and (not (autoload-done-or-in-progress? dir-hint name)) (let ((didit #f)) + (define (load-file proc file) + (save-module-excursion (lambda () (proc file))) + (set! didit #t)) (dynamic-wind (lambda () (autoload-in-progress! dir-hint name)) (lambda () - (let ((full (%search-load-path (in-vicinity dir-hint name)))) - (if full - (begin - (save-module-excursion (lambda () (primitive-load full))) - (set! didit #t))))) + (let ((file (in-vicinity dir-hint name))) + (cond ((and load-compiled + (%search-load-path (string-append file ".go"))) + => (lambda (full) + (load-file load-compiled full))) + ((%search-load-path file) + => (lambda (full) + (load-file primitive-load full)))))) (lambda () (set-autoloaded! dir-hint name didit))) didit)))) From 813c57db520698f8aa648f779ade8586298be2c4 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Mon, 16 Apr 2001 09:38:32 +0000 Subject: [PATCH 0822/2047] * Updated doc for SCM_ASSERT. --- doc/ChangeLog | 6 ++++++ doc/data-rep.texi | 53 +++++++++++++++-------------------------------- 2 files changed, 23 insertions(+), 36 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index aabe3166f..2ff22399d 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,9 @@ +2001-04-16 Neil Jerram + + * data-rep.texi (Signalling Type Errors): Update SCM_ASSERT doc + for recent changes to disallow passing a string parameter as the + `pos'. Thanks to Dirk Herrmann for the patch! + 2001-04-13 Neil Jerram * data-rep.texi (Unpacking the SCM type): New section, taken from diff --git a/doc/data-rep.texi b/doc/data-rep.texi index afeaafa1d..f758df3f8 100644 --- a/doc/data-rep.texi +++ b/doc/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.20 2001-04-13 11:12:01 ossau Exp $ +@c essay @subtitle $Id: data-rep.texi,v 1.21 2001-04-16 09:38:32 ossau Exp $ @c essay @subtitle For use with Guile @value{VERSION} @c essay @author Jim Blandy @c essay @author Free Software Foundation @@ -1021,15 +1021,10 @@ types of its arguments, to avoid misinterpreting a value, and perhaps causing a segmentation fault. Guile provides some macros to make this easier. -@deftypefn Macro void SCM_ASSERT (int @var{test}, SCM @var{obj}, int @var{position}, char *@var{subr}) -If @var{test} is zero, signal an error, attributed to the subroutine -named @var{subr}, operating on the value @var{obj}. The @var{position} -value determines exactly what sort of error to signal. - -If @var{position} is a string, @code{SCM_ASSERT} raises a -``miscellaneous'' error whose message is that string. - -Otherwise, @var{position} should be one of the values defined below. +@deftypefn Macro void SCM_ASSERT (int @var{test}, SCM @var{obj}, unsigned int @var{position}, const char *@var{subr}) +If @var{test} is zero, signal a ``wrong type argument'' error, +attributed to the subroutine named @var{subr}, operating on the value +@var{obj}, which is the @var{position}'th argument of @var{subr}. @end deftypefn @deftypefn Macro int SCM_ARG1 @@ -1037,35 +1032,21 @@ Otherwise, @var{position} should be one of the values defined below. @deftypefnx Macro int SCM_ARG3 @deftypefnx Macro int SCM_ARG4 @deftypefnx Macro int SCM_ARG5 -Signal a ``wrong type argument'' error. When used as the @var{position} -argument of @code{SCM_ASSERT}, @code{SCM_ARG@var{n}} claims that -@var{obj} has the wrong type for the @var{n}'th argument of @var{subr}. - -The only way to complain about the type of an argument after the fifth -is to use @code{SCM_ARGn}, defined below, which doesn't specify which -argument is wrong. You could pass your own error message to -@code{SCM_ASSERT} as the @var{position}, but then the error signalled is -a ``miscellaneous'' error, not a ``wrong type argument'' error. This -seems kludgy to me. -@comment Any function with more than two arguments is wrong --- Perlis -@comment Despite Perlis, I agree. Why not have two Macros, one with -@comment a string error message, and the other with an integer position -@comment that only claims a type error in an argument? -@comment --- Keith Wright +@deftypefnx Macro int SCM_ARG6 +@deftypefnx Macro int SCM_ARG7 +One of the above values can be used for @var{position} to indicate the +number of the argument of @var{subr} which is being checked. +Alternatively, a positive integer number can be used, which allows to +check arguments after the seventh. However, for parameter numbers up to +seven it is preferable to use @code{SCM_ARGN} instead of the +corresponding raw number, since it will make the code easier to +understand. @end deftypefn @deftypefn Macro int SCM_ARGn -As above, but does not specify which argument's type is incorrect. -@end deftypefn - -@deftypefn Macro int SCM_WNA -Signal an error complaining that the function received the wrong number -of arguments. - -Interestingly, the message is attributed to the function named by -@var{obj}, not @var{subr}, so @var{obj} must be a Scheme string object -naming the function. Usually, Guile catches these errors before ever -invoking the subr, so we don't run into these problems. +Passing a value of zero or @code{SCM_ARGn} for @var{position} allows to +leave it unspecified which argument's type is incorrect. Again, +@code{SCM_ARGn} should be preferred over a raw zero constant. @end deftypefn From ac16426b15644eed9948b38b0e06824096d7b3d4 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 17 Apr 2001 00:43:18 +0000 Subject: [PATCH 0823/2047] Removed out-of-date comment. --- libguile/script.c | 11 +---------- 1 file changed, 1 insertion(+), 10 deletions(-) diff --git a/libguile/script.c b/libguile/script.c index 0db21e994..ae2a738e0 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -411,16 +411,7 @@ SCM_SYMBOL (sym_quit, "quit"); probably agree. I'd say I didn't feel comfortable doing that in the present system. You'd say, well, fix the system so you are comfortable doing that. I'd agree again. *shrug* - - We load the ice-9 system from here. It might be nicer if the - libraries initialized from the inner_main function in guile.c (which - will be auto-generated eventually) could assume ice-9 were already - loaded. Then again, it might be nice if ice-9 could assume that - certain libraries were already loaded. The solution is to break up - ice-9 into modules which can be frozen and statically linked like any - other module. Then all the modules can describe their dependencies in - the usual way, and the auto-generated inner_main will do the right - thing. */ + */ static char guile[] = "guile"; From 216eedfcae5e85c8bad8b1138d6e947ab1c67fa1 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 17 Apr 2001 09:15:39 +0000 Subject: [PATCH 0824/2047] * Incorporated fixes to interrupt deferring/allowing from Niibe. * Added SCM_DEBUG_INTERRUPTS as a debugging option. --- libguile/ChangeLog | 50 ++++++++++++++++++++++++++++++++++++++++ libguile/__scm.h | 54 ++++++++++++++++++++++++-------------------- libguile/coop-defs.h | 12 +++------- libguile/fluids.c | 9 ++------ libguile/gc.c | 8 ++----- libguile/mallocs.c | 7 ++---- libguile/srcprop.c | 3 ++- 7 files changed, 91 insertions(+), 52 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 0b0d3cf09..27160dbec 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,53 @@ +2001-04-17 Niibe Yutaka + + * srcprop.c (scm_make_srcprops): Added SCM_ALLOW_INTS which + matches SCM_DEFER_INTS at the beginning of the function. + + * mallocs.c (scm_malloc_obj): Remove un-matched SCM_ALLOW_INTS. + + * gc.c (scm_igc): Unconditionally call + SCM_CRITICAL_SECTION_START/END. + + * fluids.c (next_fluid_num): Unconditionally call + SCM_CRITICAL_SECTION_START/END. + (s_scm_make_fluid): Remove un-matched SCM_DEFER_INTS. + + * coop-defs.h (SCM_THREAD_DEFER, SCM_THREAD_ALLOW, + SCM_THREAD_REDEFER, SCM_THREAD_REALLOW_1, SCM_THREAD_REALLOW_2): + Removed. + + * __scm.h (SCM_CRITICAL_SECTION_START, SCM_CRITICAL_SECTION_END): + Defined as nothing for the case of !defined(USE_THREADS). + (SCM_THREAD_DEFER, SCM_THREAD_ALLOW, SCM_THREAD_REDEFER): + Removed. + (): Include when (SCM_DEBUG_INTERRUPTS == 1). + (SCM_CHECK_NOT_DISABLED, SCM_CHECK_NOT_ENABLED): Print FILE and + LINE. + (SCM_DEFER_INTS, SCM_ALLOW_INTS_ONLY, SCM_ALLOW_INTS, + SCM_REDEFER_INTS, SCM_REALLOW_INTS): Don't use + SCM_THREAD_DEFER/SCM_THREAD_ALLOW. Instead, use + SCM_CRITICAL_SECTION_START/END. + (SCM_REALLOW_INTS: Bug fix. Don't call + SCM_THREAD_SWITCHING_CODE. + (SCM_TICK): Don't use SCM_DEFER_INTS/SCM_ALLOW_INTS. Instead, use + SCM_THREAD_SWITCHING_CODE directly. + (SCM_ENTER_A_SECTION): Unconditionally use + SCM_CRITICAL_SECTION_START/END. (was: + SCM_DEFER_INTS/SCM_ALLOW_INTS when SCM_POSIX_THREADS defined). + +2001-04-17 Dirk Herrmann + + * __scm.h (SCM_CAREFUL_INTS, SCM_DEBUG_INTERRUPTS): Replaced the + macro SCM_CAREFUL_INTS by the macro SCM_DEBUG_INTERRUPTS and + allowed to explicitly set this macro via the CFLAGS variable + during make. + + * fluids.c (next_fluid_num), gc.c (scm_igc), coop-defs.h + (SCM_THREAD_CRITICAL_SECTION_START, + SCM_THREAD_CRITICAL_SECTION_END): Renamed + SCM_THREAD_CRITICAL_SECTION_START/END to + SCM_CRITICAL_SECTION_START/END. + 2001-04-11 Keisuke Nishida * debug-malloc.c (grow, scm_debug_malloc_prehistory): Use memset diff --git a/libguile/__scm.h b/libguile/__scm.h index 97d0a903a..75cfe39e1 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -100,7 +100,6 @@ */ #undef ENGNOT -#undef SCM_CAREFUL_INTS /* {Unsupported Options} * @@ -171,6 +170,13 @@ #define SCM_DEBUG_DEPRECATED SCM_DEBUG #endif +/* If SCM_DEBUG_INTERRUPTS is set to 1, with every deferring and allowing of + * interrupts a consistency check will be performed. + */ +#ifndef SCM_DEBUG_INTERRUPTS +#define SCM_DEBUG_INTERRUPTS SCM_DEBUG +#endif + /* If SCM_DEBUG_REST_ARGUMENT is set to 1, functions that take rest arguments * will check whether the rest arguments are actually passed as a proper list. * Otherwise, if SCM_DEBUG_REST_ARGUMENT is 0, functions that take rest @@ -319,9 +325,8 @@ typedef long SCM_STACKITEM; #ifndef USE_THREADS -#define SCM_THREAD_DEFER -#define SCM_THREAD_ALLOW -#define SCM_THREAD_REDEFER +#define SCM_CRITICAL_SECTION_START +#define SCM_CRITICAL_SECTION_END #define SCM_THREAD_SWITCHING_CODE #endif @@ -343,14 +348,21 @@ do { \ } while (0) #endif -#ifdef SCM_CAREFUL_INTS +#if (SCM_DEBUG_INTERRUPTS == 1) +#include #define SCM_CHECK_NOT_DISABLED \ - if (scm_ints_disabled) \ - fputs("ints already disabled\n", stderr); \ + do { \ + if (scm_ints_disabled) \ + fprintf(stderr, "ints already disabled (at %s:%d)\n", \ + __FILE__, __LINE__); \ + } while (0) #define SCM_CHECK_NOT_ENABLED \ - if (!scm_ints_disabled) \ - fputs("ints already enabled\n", stderr); \ + do { \ + if (!scm_ints_disabled) \ + fprintf(stderr, "ints already enabled (at %s:%d)\n", \ + __FILE__, __LINE__); \ + } while (0) #else #define SCM_CHECK_NOT_DISABLED @@ -383,7 +395,7 @@ do { \ do { \ SCM_FENCE; \ SCM_CHECK_NOT_DISABLED; \ - SCM_THREAD_DEFER; \ + SCM_CRITICAL_SECTION_START; \ SCM_FENCE; \ scm_ints_disabled = 1; \ SCM_FENCE; \ @@ -392,7 +404,7 @@ do { \ #define SCM_ALLOW_INTS_ONLY \ do { \ - SCM_THREAD_ALLOW; \ + SCM_CRITICAL_SECTION_END; \ scm_ints_disabled = 0; \ } while (0) @@ -401,11 +413,11 @@ do { \ do { \ SCM_FENCE; \ SCM_CHECK_NOT_ENABLED; \ - SCM_THREAD_SWITCHING_CODE; \ + SCM_CRITICAL_SECTION_END; \ SCM_FENCE; \ scm_ints_disabled = 0; \ SCM_FENCE; \ - SCM_THREAD_ALLOW; \ + SCM_THREAD_SWITCHING_CODE; \ SCM_FENCE; \ } while (0) @@ -413,7 +425,7 @@ do { \ #define SCM_REDEFER_INTS \ do { \ SCM_FENCE; \ - SCM_THREAD_REDEFER; \ + SCM_CRITICAL_SECTION_START; \ ++scm_ints_disabled; \ SCM_FENCE; \ } while (0) @@ -422,7 +434,7 @@ do { \ #define SCM_REALLOW_INTS \ do { \ SCM_FENCE; \ - SCM_THREAD_SWITCHING_CODE; \ + SCM_CRITICAL_SECTION_END; \ SCM_FENCE; \ --scm_ints_disabled; \ SCM_FENCE; \ @@ -431,9 +443,8 @@ do { \ #define SCM_TICK \ do { \ - SCM_DEFER_INTS; \ - SCM_ALLOW_INTS; \ SCM_ASYNC_TICK; \ + SCM_THREAD_SWITCHING_CODE; \ } while (0) @@ -466,13 +477,8 @@ do { \ * at all times. */ -#ifdef SCM_POSIX_THREADS -#define SCM_ENTER_A_SECTION -#define SCM_EXIT_A_SECTION -#else -#define SCM_ENTER_A_SECTION SCM_DEFER_INTS -#define SCM_EXIT_A_SECTION SCM_ALLOW_INTS -#endif +#define SCM_ENTER_A_SECTION SCM_CRITICAL_SECTION_START +#define SCM_EXIT_A_SECTION SCM_CRITICAL_SECTION_END diff --git a/libguile/coop-defs.h b/libguile/coop-defs.h index c3bab1423..6502b6480 100644 --- a/libguile/coop-defs.h +++ b/libguile/coop-defs.h @@ -3,7 +3,7 @@ #ifndef COOP_DEFSH #define COOP_DEFSH -/* Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1996,1997,1998,1999,2000,2001 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 @@ -235,8 +235,8 @@ extern coop_t *coop_wait_for_runnable_thread (void); /* Cooperative threads don't need to have these defined */ -#define SCM_THREAD_CRITICAL_SECTION_START -#define SCM_THREAD_CRITICAL_SECTION_END +#define SCM_CRITICAL_SECTION_START +#define SCM_CRITICAL_SECTION_END @@ -245,12 +245,6 @@ extern coop_t *coop_wait_for_runnable_thread (void); -#define SCM_THREAD_DEFER -#define SCM_THREAD_ALLOW -#define SCM_THREAD_REDEFER -#define SCM_THREAD_REALLOW_1 -#define SCM_THREAD_REALLOW_2 - #if 0 #define SCM_THREAD_SWITCHING_CODE \ do { \ diff --git a/libguile/fluids.c b/libguile/fluids.c index a24709828..a5bc280af 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -107,13 +107,9 @@ static int next_fluid_num () { int n; -#ifdef USE_THREADS - SCM_THREAD_CRITICAL_SECTION_START; -#endif + SCM_CRITICAL_SECTION_START; n = n_fluids++; -#ifdef USE_THREADS - SCM_THREAD_CRITICAL_SECTION_END; -#endif + SCM_CRITICAL_SECTION_END; return n; } @@ -130,7 +126,6 @@ SCM_DEFINE (scm_make_fluid, "make-fluid", 0, 0, 0, { int n; - SCM_DEFER_INTS; n = next_fluid_num (); SCM_RETURN_NEWSMOB (scm_tc16_fluid, n); } diff --git a/libguile/gc.c b/libguile/gc.c index 972faa5d0..677d695e0 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1001,10 +1001,8 @@ scm_igc (const char *what) ? "*" : (SCM_NULLP (scm_freelist2) ? "o" : "m")); #endif -#ifdef USE_THREADS /* During the critical section, only the current thread may run. */ - SCM_THREAD_CRITICAL_SECTION_START; -#endif + SCM_CRITICAL_SECTION_START; /* fprintf (stderr, "gc: %s\n", what); */ @@ -1102,9 +1100,7 @@ scm_igc (const char *what) --scm_gc_heap_lock; gc_end_stats (); -#ifdef USE_THREADS - SCM_THREAD_CRITICAL_SECTION_END; -#endif + SCM_CRITICAL_SECTION_END; scm_c_hook_run (&scm_after_gc_c_hook, 0); --scm_gc_running_p; } diff --git a/libguile/mallocs.c b/libguile/mallocs.c index 035539f9b..1874f3bde 100644 --- a/libguile/mallocs.c +++ b/libguile/mallocs.c @@ -1,5 +1,5 @@ /* classes: src_files - * Copyright (C) 1995, 1997, 1998, 2000 Free Software Foundation, Inc. + * Copyright (C) 1995,1997,1998,2000,2001 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 @@ -64,10 +64,7 @@ scm_malloc_obj (scm_sizet n) { scm_bits_t mem = n ? (scm_bits_t) malloc (n) : 0; if (n && !mem) - { - SCM_ALLOW_INTS; - return SCM_BOOL_F; - } + return SCM_BOOL_F; SCM_RETURN_NEWSMOB (scm_tc16_malloc, mem); } diff --git a/libguile/srcprop.c b/libguile/srcprop.c index 1b9aa2bbe..606a62392 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001 Free Software Foundation +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation * * 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 @@ -148,6 +148,7 @@ scm_make_srcprops (int line, int col, SCM filename, SCM copy, SCM plist) ptr->fname = filename; ptr->copy = copy; ptr->plist = plist; + SCM_ALLOW_INTS; SCM_RETURN_NEWSMOB (scm_tc16_srcprops, ptr); } From 239d2912a28f924a6b03463c4307bc3125705e7d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Tue, 17 Apr 2001 15:34:33 +0000 Subject: [PATCH 0825/2047] * scheme-utility.texi (General Conversion): New node, added `object->string'. (Equality): Added definition and explanation of `sameness'. * posix.texi (System Identification): Added `gethostname' and `sethostname'. (Processes): Added `setpriority' and `getpriority'. (User Information): Added `cuserid' and `getlogin'. (Ports and File Descriptors): Added `flock'. (Processes): Added `chroot'. (File System): Added `mkstemp!'. (Encryption): New node, added `crypt' and `getpass'. * new-docstrings.texi: Moved several docstrings over to the reference manual (see above which). * scheme-data.texi (Data Types), (Numerical Tower): Add explicit @bullet to @itemize to satisfy older `makeinfo'. --- doc/ChangeLog | 21 ++++++ doc/new-docstrings.texi | 108 ---------------------------- doc/posix.texi | 147 ++++++++++++++++++++++++++++++++++--- doc/scheme-data.texi | 22 ++++-- doc/scheme-utility.texi | 155 ++++++++++++++++++++++++++++++++-------- 5 files changed, 298 insertions(+), 155 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 2ff22399d..c9efb339c 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,24 @@ +2001-04-17 Martin Grabmueller + + * scheme-utility.texi (General Conversion): New node, added + `object->string'. + (Equality): Added definition and explanation of `sameness'. + + * posix.texi (System Identification): Added `gethostname' and + `sethostname'. + (Processes): Added `setpriority' and `getpriority'. + (User Information): Added `cuserid' and `getlogin'. + (Ports and File Descriptors): Added `flock'. + (Processes): Added `chroot'. + (File System): Added `mkstemp!'. + (Encryption): New node, added `crypt' and `getpass'. + + * new-docstrings.texi: Moved several docstrings over to the + reference manual (see above which). + + * scheme-data.texi (Data Types), (Numerical Tower): Add explicit + @bullet to @itemize to satisfy older `makeinfo'. + 2001-04-16 Neil Jerram * data-rep.texi (Signalling Type Errors): Update SCM_ASSERT doc diff --git a/doc/new-docstrings.texi b/doc/new-docstrings.texi index 778b3b45d..21e979221 100644 --- a/doc/new-docstrings.texi +++ b/doc/new-docstrings.texi @@ -485,114 +485,6 @@ Create and return a copy of the global symbol table, removing all unbound symbols. @end deffn -@deffn primitive object->string obj [printer] -Return a Scheme string obtained by printing @var{obj}. -Printing function can be specified by the optional second -argument @var{printer} (default: @code{write}). -@end deffn - -@deffn primitive gethostname -Return the host name of the current processor. -@end deffn - -@deffn primitive sethostname name -Set the host name of the current processor to @var{name}. May -only be used by the superuser. The return value is not -specified. -@end deffn - -@deffn primitive flock file operation -Apply or remove an advisory lock on an open file. -@var{operation} specifies the action to be done: -@table @code -@item LOCK_SH -Shared lock. More than one process may hold a shared lock -for a given file at a given time. -@item LOCK_EX -Exclusive lock. Only one process may hold an exclusive lock -for a given file at a given time. -@item LOCK_UN -Unlock the file. -@item LOCK_NB -Don't block when locking. May be specified by bitwise OR'ing -it to one of the other operations. -@end table -The return value is not specified. @var{file} may be an open -file descriptor or an open file descriptior port. -@end deffn - -@deffn primitive getpass prompt -Display @var{prompt} to the standard error output and read -a password from @file{/dev/tty}. If this file is not -accessible, it reads from standard input. The password may be -up to 127 characters in length. Additional characters and the -terminating newline character are discarded. While reading -the password, echoing and the generation of signals by special -characters is disabled. -@end deffn - -@deffn primitive setpriority which who prio -Set the scheduling priority of the process, process group -or user, as indicated by @var{which} and @var{who}. @var{which} -is one of the variables @code{PRIO_PROCESS}, @code{PRIO_PGRP} -or @code{PRIO_USER}, and @var{who} is interpreted relative to -@var{which} (a process identifier for @code{PRIO_PROCESS}, -process group identifier for @code{PRIO_PGRP}, and a user -identifier for @code{PRIO_USER}. A zero value of @var{who} -denotes the current process, process group, or user. -@var{prio} is a value in the range -20 and 20, the default -priority is 0; lower priorities cause more favorable -scheduling. Sets the priority of all of the specified -processes. Only the super-user may lower priorities. -The return value is not specified. -@end deffn - -@deffn primitive getpriority which who -Return the scheduling priority of the process, process group -or user, as indicated by @var{which} and @var{who}. @var{which} -is one of the variables @code{PRIO_PROCESS}, @code{PRIO_PGRP} -or @code{PRIO_USER}, and @var{who} is interpreted relative to -@var{which} (a process identifier for @code{PRIO_PROCESS}, -process group identifier for @code{PRIO_PGRP}, and a user -identifier for @code{PRIO_USER}. A zero value of @var{who} -denotes the current process, process group, or user. Return -the highest priority (lowest numerical value) of any of the -specified processes. -@end deffn - -@deffn primitive cuserid -Return a string containing a user name associated with the -effective user id of the process. Return @code{#f} if this -information cannot be obtained. -@end deffn - -@deffn primitive getlogin -Return a string containing the name of the user logged in on -the controlling terminal of the process, or @code{#f} if this -information cannot be obtained. -@end deffn - -@deffn primitive chroot path -Change the root directory to that specified in @var{path}. -This directory will be used for path names beginning with -@file{/}. The root directory is inherited by all children -of the current process. Only the superuser may change the -root directory. -@end deffn - -@deffn primitive crypt key salt -Encrypt @var{key} using @var{salt} as the salt value to the -crypt(3) library call -@end deffn - -@deffn primitive mkstemp! tmpl -Create a new unique file in the file system and returns a new -buffered port open for reading and writing to the file. -@var{tmpl} is a string specifying where the file should be -created: it must end with @code{XXXXXX} and will be changed in -place to return the name of the temporary file. -@end deffn - @deffn primitive %tag-body body Internal GOOPS magic---don't use this function! @end deffn diff --git a/doc/posix.texi b/doc/posix.texi index b6c72d22f..f6fbc0994 100644 --- a/doc/posix.texi +++ b/doc/posix.texi @@ -3,19 +3,20 @@ @menu * Conventions:: Conventions employed by the POSIX interface. -* Ports and File Descriptors:: Scheme ``ports'' and Unix file descriptors +* Ports and File Descriptors:: Scheme ``ports'' and Unix file descriptors have different representations. -* File System:: stat, chown, chmod, etc. -* User Information:: Retrieving a user's GECOS (/etc/passwd) entry. -* Time:: gettimeofday, localtime, strftime, etc. +* File System:: stat, chown, chmod, etc. +* User Information:: Retrieving a user's GECOS (/etc/passwd) entry. +* Time:: gettimeofday, localtime, strftime, etc. * Runtime Environment:: Accessing and modifying Guile's environment. -* Processes:: getuid, getpid, etc. +* Processes:: getuid, getpid, etc. * Signals:: sigaction, kill, pause, alarm, etc. -* Terminals and Ptys:: ttyname, tcsetpgrp, etc. -* Pipes:: Communicating data between processes. -* Networking:: gethostbyaddr, getnetent, socket, bind, listen. -* System Identification:: `uname' and getting info about this machine. +* Terminals and Ptys:: ttyname, tcsetpgrp, etc. +* Pipes:: Communicating data between processes. +* Networking:: gethostbyaddr, getnetent, socket, bind, listen. +* System Identification:: Obtaining information about the system. * Locales:: setlocale, etc. +* Encryption:: @end menu @node Conventions @@ -442,6 +443,26 @@ The value used to indicate the "close on exec" flag with @code{F_GETFL} or @end table @end deffn +@deffn primitive flock file operation +Apply or remove an advisory lock on an open file. +@var{operation} specifies the action to be done: +@table @code +@item LOCK_SH +Shared lock. More than one process may hold a shared lock +for a given file at a given time. +@item LOCK_EX +Exclusive lock. Only one process may hold an exclusive lock +for a given file at a given time. +@item LOCK_UN +Unlock the file. +@item LOCK_NB +Don't block when locking. May be specified by bitwise OR'ing +it to one of the other operations. +@end table +The return value is not specified. @var{file} may be an open +file descriptor or an open file descriptior port. +@end deffn + @deffn primitive select reads writes excepts [secs [usecs]] This procedure has a variety of uses: waiting for the ability to provide input, accept output, or the existance of @@ -712,6 +733,14 @@ Care should be taken if opening the file, e.g., use the @code{O_EXCL} open flag or use @code{mkstemp!} instead. @end deffn +@deffn primitive mkstemp! tmpl +Create a new unique file in the file system and returns a new +buffered port open for reading and writing to the file. +@var{tmpl} is a string specifying where the file should be +created: it must end with @code{XXXXXX} and will be changed in +place to return the name of the temporary file. +@end deffn + @deffn primitive dirname filename Return the directory name component of the file name @var{filename}. If @var{filename} does not contain a directory @@ -838,6 +867,22 @@ a string, or omitted, giving the behaviour of getgrgid, getgrnam or getgrent respectively. @end deffn +In addition to the accessor procedures for the user database, the +following shortcut procedures are also available. + +@deffn primitive cuserid +Return a string containing a user name associated with the +effective user id of the process. Return @code{#f} if this +information cannot be obtained. +@end deffn + +@deffn primitive getlogin +Return a string containing the name of the user logged in on +the controlling terminal of the process, or @code{#f} if this +information cannot be obtained. +@end deffn + + @node Time @section Time @@ -1055,6 +1100,14 @@ file creation mask. Otherwise the file creation mask is set to E.g., @code{(umask #o022)} sets the mask to octal 22, decimal 18. @end deffn +@deffn primitive chroot path +Change the root directory to that specified in @var{path}. +This directory will be used for path names beginning with +@file{/}. The root directory is inherited by all children +of the current process. Only the superuser may change the +root directory. +@end deffn + @deffn primitive getpid Return an integer representing the current process ID. @end deffn @@ -1267,6 +1320,36 @@ priority value means that the process runs less often. The return value is unspecified. @end deffn +@deffn primitive setpriority which who prio +Set the scheduling priority of the process, process group +or user, as indicated by @var{which} and @var{who}. @var{which} +is one of the variables @code{PRIO_PROCESS}, @code{PRIO_PGRP} +or @code{PRIO_USER}, and @var{who} is interpreted relative to +@var{which} (a process identifier for @code{PRIO_PROCESS}, +process group identifier for @code{PRIO_PGRP}, and a user +identifier for @code{PRIO_USER}. A zero value of @var{who} +denotes the current process, process group, or user. +@var{prio} is a value in the range -20 and 20, the default +priority is 0; lower priorities cause more favorable +scheduling. Sets the priority of all of the specified +processes. Only the super-user may lower priorities. +The return value is not specified. +@end deffn + +@deffn primitive getpriority which who +Return the scheduling priority of the process, process group +or user, as indicated by @var{which} and @var{who}. @var{which} +is one of the variables @code{PRIO_PROCESS}, @code{PRIO_PGRP} +or @code{PRIO_USER}, and @var{who} is interpreted relative to +@var{which} (a process identifier for @code{PRIO_PROCESS}, +process group identifier for @code{PRIO_PGRP}, and a user +identifier for @code{PRIO_USER}. A zero value of @var{who} +denotes the current process, process group, or user. Return +the highest priority (lowest numerical value) of any of the +specified processes. +@end deffn + + @node Signals @section Signals @@ -1449,8 +1532,8 @@ close a pipe, but doesn't return the status. @section Networking @menu -* Network Databases and Address Conversion:: -* Network Sockets and Communication:: +* Network Databases and Address Conversion:: +* Network Sockets and Communication:: @end menu @node Network Databases and Address Conversion @@ -2044,6 +2127,9 @@ These procedures are inconvenient to use at present, but consider: @node System Identification @section System Identification +This section lists the various procedures Guile provides for accessing +information about the system it runs on. + @deffn primitive uname Return an object with some information about the computer system the program is running on. @@ -2065,6 +2151,17 @@ The current version level within the release of the operating system. A description of the hardware. @end table +@deffn primitive gethostname +Return the host name of the current processor. +@end deffn + +@deffn primitive sethostname name +Set the host name of the current processor to @var{name}. May +only be used by the superuser. The return value is not +specified. +@end deffn + +@c FIXME::martin: Not in libguile! @deffn primitive software-type Return a symbol describing the current platform's operating system. This may be one of AIX, VMS, UNIX, COHERENT, WINDOWS, MS-DOS, OS/2, @@ -2091,3 +2188,31 @@ Otherwise the specified locale category is set to the string system-dependent string. If @var{locale} is an empty string, the locale will be set using envirionment variables. @end deffn + +@node Encryption +@section Encryption + +Please note that the procedures in this section are not suited for +strong encryption, they are only interfaces to the well--known and +common system library functions of the same name. They are just as good +(or bad) as the underlying functions, so you should refer to your system +documentation before using them. + +@deffn primitive crypt key salt +Encrypt @var{key} using @var{salt} as the salt value to the +crypt(3) library call +@end deffn + +@code{getpass} is no encryption procedure at all, but it is often used +in compination with @code{crypt}, that is why it appears in this +section. + +@deffn primitive getpass prompt +Display @var{prompt} to the standard error output and read +a password from @file{/dev/tty}. If this file is not +accessible, it reads from standard input. The password may be +up to 127 characters in length. Additional characters and the +terminating newline character are discarded. While reading +the password, echoing and the generation of signals by special +characters is disabled. +@end deffn diff --git a/doc/scheme-data.texi b/doc/scheme-data.texi index a332dace7..92f333c59 100755 --- a/doc/scheme-data.texi +++ b/doc/scheme-data.texi @@ -9,7 +9,7 @@ One of the great strengths of Scheme is that there is no straightforward distinction between ``data'' and ``functionality''. For example, Guile's support for dynamic linking could be described -@itemize +@itemize @bullet @item either in a ``data-centric'' way, as the behaviour and properties of the ``dynamically linked object'' data type, and the operations that may be @@ -172,7 +172,7 @@ in Scheme, which is particularly clear and accessible: see Scheme's numerical ``tower'' consists of the following categories of numbers: -@itemize +@itemize @bullet @item integers (whole numbers) @@ -2295,9 +2295,14 @@ to write a symbol containing characters not mentioned above, you write symbols as follows: @itemize @bullet -@item Begin the symbol with the two character @code{#@{}, -@item write the characters of the symbol and -@item finish the symbol with the characters @code{@}#}. +@item +Begin the symbol with the two character @code{#@{}, + +@item +write the characters of the symbol and + +@item +finish the symbol with the characters @code{@}#}. @end itemize Here are a few examples of this form of read syntax; the first @@ -2859,8 +2864,11 @@ of pairs which looks like a list.} This is the short definition of what a list is: @itemize @bullet -@item Either the empty list @code{()}, -@item or a pair which has a list in its cdr. +@item +Either the empty list @code{()}, + +@item +or a pair which has a list in its cdr. @end itemize @c FIXME::martin: Describe the pair chaining in more detail. diff --git a/doc/scheme-utility.texi b/doc/scheme-utility.texi index 543a14569..9254ec449 100644 --- a/doc/scheme-utility.texi +++ b/doc/scheme-utility.texi @@ -2,18 +2,50 @@ @node Utility Functions @chapter General Utility Functions +@c FIXME::martin: Review me! + +This chapter contains information about procedures which are not cleanly +tied to a specific data type. Because of their wide range of +applications, they are collected in a @dfn{utlity} chapter. + @menu * Equality:: When are two values `the same'? * Property Lists:: Managing metainformation about Scheme objects. * Primitive Properties:: A modern low-level interface to object properties. * Sorting:: Sort utility procedures. * Copying:: Copying deep structures. +* General Conversion:: Converting objects to strings. @end menu @node Equality @section Equality +@c FIXME::martin: Review me! + +@cindex sameness +@cindex equality + +Three different kinds of @dfn{sameness} are defined in Scheme. + +@itemize @bullet +@item +Two values can refer to exactly the same object. + +@item +Two objects can have the same @dfn{value}. + +@item +Two objects can be structurally equivalent. +@end itemize + +The differentiation between these three kinds is important, because +determining whether two values are the same objects is very efficient, +while determining structural equivalence can be quite expensive +(consider comparing two very long lists). Therefore, three different +procedures for testing for equality are provided, which correspond to +the three kinds of @dfn{sameness} defined above. + @rnindex eq? @deffn primitive eq? x y Return @code{#t} iff @var{x} references the same object as @var{y}. @@ -114,6 +146,29 @@ Remove any value associated with @var{prop} and @var{obj}. @node Sorting @section Sorting +@c FIXME::martin: Review me! + +@cindex sorting +@cindex sorting lists +@cindex sorting vectors + +Sorting is very important in computer programs. Therefore, Guile comes +with several sorting procedures built--in. As always, procedures with +names ending in @code{!} are side--effecting, that means that they may +modify their parameters in order to produce their results. + +The first group of procedures can be used to merge two lists (which must +be already sorted on their own) and produce sorted lists containing +all elements of the input lists. + +@deffn primitive merge alist blist less +Take two lists @var{alist} and @var{blist} such that +@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and +returns a new list in which the elements of @var{alist} and +@var{blist} have been stably interleaved so that +@code{(sorted? (merge alist blist less?) less?)}. +@end deffn + @deffn primitive merge! alist blist less Takes two lists @var{alist} and @var{blist} such that @code{(sorted? alist less?)} and @code{(sorted? blist less?)} and @@ -124,14 +179,26 @@ This is the destructive variant of @code{merge} Note: this does _not_ accept vectors. @end deffn -@deffn primitive merge alist blist less +The following procedures can operate on sequences which are either +vectors or list. According to the given arguments, they return sorted +vectors or lists, respectively. The first of the following procedures +determines whether a sequence is already sorted, the other sort a given +sequence. The variants with names starting with @code{stable-} are +special in that they maintain a special property of the input sequences: +If two or more elements are the same according to the comparison +predicate, they are left in the same order as they appeared in the +input. + +@deffn primitive sorted? items less +Return @code{#t} iff @var{items} is a list or a vector such that +for all 1 <= i <= m, the predicate @var{less} returns true when +applied to all elements i - 1 and i @end deffn -@deffn primitive restricted-vector-sort! vec less startpos endpos -Sort the vector @var{vec}, using @var{less} for comparing -the vector elements. @var{startpos} and @var{endpos} delimit -the range of the vector which gets sorted. The return value -is not specified. +@deffn primitive sort items less +Sort the sequence @var{items}, which may be a list or a +vector. @var{less} is used for comparing the sequence +elements. This is not a stable sort. @end deffn @deffn primitive sort! items less @@ -142,30 +209,12 @@ input sequence is modified to produce the sorted result. This is not a stable sort. @end deffn -@deffn primitive sort items less +@deffn primitive stable-sort items less Sort the sequence @var{items}, which may be a list or a -vector. @var{less} is used for comparing the sequence -elements. This is not a stable sort. -@end deffn - -@deffn primitive sort-list! items less -Sort the list @var{items}, using @var{less} for comparing the -list elements. The sorting is destructive, that means that the -input list is modified to produce the sorted result. +vector. @var{less} is used for comparing the sequence elements. This is a stable sort. @end deffn -@deffn primitive sort-list items less -Sort the list @var{items}, using @var{less} for comparing the -list elements. This is a stable sort. -@end deffn - -@deffn primitive sorted? items less -Return @code{#t} iff @var{items} is a list or a vector such that -for all 1 <= i <= m, the predicate @var{less} returns true when -applied to all elements i - 1 and i -@end deffn - @deffn primitive stable-sort! items less Sort the sequence @var{items}, which may be a list or a vector. @var{less} is used for comparing the sequence elements. @@ -174,16 +223,40 @@ is modified to produce the sorted result. This is a stable sort. @end deffn -@deffn primitive stable-sort items less -Sort the sequence @var{items}, which may be a list or a -vector. @var{less} is used for comparing the sequence elements. +The procedures in the last group only accept lists or vectors as input, +as their names indicate. + +@deffn primitive sort-list items less +Sort the list @var{items}, using @var{less} for comparing the +list elements. This is a stable sort. +@end deffn + +@deffn primitive sort-list! items less +Sort the list @var{items}, using @var{less} for comparing the +list elements. The sorting is destructive, that means that the +input list is modified to produce the sorted result. This is a stable sort. @end deffn +@deffn primitive restricted-vector-sort! vec less startpos endpos +Sort the vector @var{vec}, using @var{less} for comparing +the vector elements. @var{startpos} and @var{endpos} delimit +the range of the vector which gets sorted. The return value +is not specified. +@end deffn + @node Copying @section Copying Deep Structures +@c FIXME::martin: Review me! + +The procedures for copying lists (@pxref{Lists}) only produce a flat +copy of the input list, and currently Guile does not even contain +procedures for copying vectors. @code{copy-tree} can be used for these +application, as it does not only copy the spine of a list, but also +copies any pairs in the cars of the input lists. + @deffn primitive copy-tree obj Recursively copy the data tree that is bound to @var{obj}, and return a pointer to the new data structure. @code{copy-tree} recurses down the @@ -193,6 +266,30 @@ any other object. @end deffn +@node General Conversion +@section General String Conversion + +@c FIXME::martin: Review me! + +When debugging Scheme programs, but also for providing a human--friendly +interface, a procedure for converting any Scheme object into string +format is very useful. Conversion from/to strings can of course be done +with specialized procedures when the data type of the object to convert +is known, but with this procedure, it is often more comfortable. + +@code{object->string} converts an object by using a print procedure for +writing to a string port, and then returning the resulting string. +Converting an object back from the string is only possible if the object +type has a read syntax and the read syntax is preserved by the printing +procedure. + +@deffn primitive object->string obj [printer] +Return a Scheme string obtained by printing @var{obj}. +Printing function can be specified by the optional second +argument @var{printer} (default: @code{write}). +@end deffn + + @c Local Variables: @c TeX-master: "guile.texi" @c End: From da54ce854a39d33c5a5c04843372922895e5b880 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Tue, 17 Apr 2001 19:29:52 +0000 Subject: [PATCH 0826/2047] * scheme-control.texi (Multiple Values): Documented concept of multiple values, added docs for `receive'. (begin): Documented `begin'. (if cond case): Documented `if', `cond' and `case'. (and or): Documented `and' and `or'. (while do): Documented `do' and `while'. * scheme-procedures.texi (Optional Arguments): Split the node, added introductory text, added menu for subsections. (let-optional Reference, let-keywords Reference), (lambda* Reference, define* Reference): Added syntax documentation for all exported procedures from (ice-9 optargs). --- doc/ChangeLog | 15 +++ doc/scheme-control.texi | 209 +++++++++++++++++++++++++++++++- doc/scheme-data.texi | 12 +- doc/scheme-procedures.texi | 242 +++++++++++++++++++++++++++++++++++++ 4 files changed, 471 insertions(+), 7 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index c9efb339c..a3e0f1a4a 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,18 @@ +2001-04-17 Martin Grabmueller + + * scheme-control.texi (Multiple Values): Documented concept of + multiple values, added docs for `receive'. + (begin): Documented `begin'. + (if cond case): Documented `if', `cond' and `case'. + (and or): Documented `and' and `or'. + (while do): Documented `do' and `while'. + + * scheme-procedures.texi (Optional Arguments): Split the node, + added introductory text, added menu for subsections. + (let-optional Reference, let-keywords Reference), + (lambda* Reference, define* Reference): Added syntax documentation + for all exported procedures from (ice-9 optargs). + 2001-04-17 Martin Grabmueller * scheme-utility.texi (General Conversion): New node, added diff --git a/doc/scheme-control.texi b/doc/scheme-control.texi index 6922f5b9d..129a1143d 100644 --- a/doc/scheme-control.texi +++ b/doc/scheme-control.texi @@ -18,18 +18,189 @@ @node begin @section Evaluating a Sequence of Expressions +@c FIXME::martin: Review me! + +@c FIXME::martin: Maybe add examples? + +@cindex begin +@cindex sequencing +@cindex expression sequencing + +@code{begin} is used for grouping several expression together so that +they syntactically are treated as if they were one expression. This is +particularly important when syntactic expressions are used which only +allow one expression, but the programmer wants to use more than one +expression in that place. As an example, consider the conditional +expression below: + +@lisp +(if (> x 0) + (begin (display "greater") (newline))) +@end lisp + +If the two calls to @code{display} and @code{newline} were not embedded +in a @code{begin}--statement, the call to @code{newline} would get +misinterpreted as the else--branch of the @code{if}--expression. + +@deffn syntax begin expr1 expr2 @dots{} +The expression(s) are evaluated in left--to--right order and the value +of the last expression is returned as the value of the +@code{begin}--expression. This expression type is used when the +expressions before the last one are evaluated for their side effects. +@end deffn @node if cond case @section Simple Conditional Evaluation +@c FIXME::martin: Review me! + +@c FIXME::martin: Maybe add examples? + +@cindex conditional evaluation +@cindex if +@cindex case +@cindex cond + +Guile provides three syntactic constructs for conditional evaluation. +@code{if} is the normal if--then--else expression (with an optional else +branch), @code{cond} is a conditional expression with multiple branches +and @code{case} branches if an expression has one of a set of constant +values. + +@deffn syntax if test consequent [alternate] +All arguments may be arbitrary expressions. First, @var{test} is +evaluated. If it returns a true value, the expression @var{consequent} +is evaluated and @var{alternate} is ignoret. If @var{test} evaluates to +@code{#f}, @var{alternate} is evaluated instead. The value of the +evaluated branch (@var{consequent} or @var{alternate}) is returned as +the value of the @code{if} expression. + +When @var{alternate} is omitted and the @var{test} evaluates to +@code{#f}, the value of the expression is not specified. +@end deffn + +@deffn syntax cond clause1 clause2 @dots{} +Each @code{cond}-clause must look like this: + +@lisp +(@var{test} @var{expression} @dots{}) +@end lisp + +where @var{test} and @var{expression} are arbitrary expression, or like +this + +@lisp +(@var{test} => @var{expression} +@end lisp + +where @var{expression} must evaluate to a procedure. + +The @var{test}s of the clauses are evaluated in order and as soon as one +of them evaluates to a true values, the corresponding @var{expression}s +are evaluated in order and the last value is returned as the value of +the @code{cond}--expression. For the @code{=>} clause type, +@var{expression} is evaluated and the resulting procedure is applied to +the value of @var{test}. The result of this procedure application is +then the result of the @code{cond}--expression. + +The @var{test} of the last @var{clause} may be the keyword @code{else}. +Then, if none of the preceding @var{test}s is true, the @var{expression}s following the @code{else} are evaluated to produce the result of the @code{cond}--expression. +@end deffn + +@deffn syntax case key clause1 clause2 @dots{} +@var{key} may be any expression, the @var{clause}s must have the form + +@lisp +((@var{datum1} @dots{}) @var{expr1} @var{expr2} @dots{}) +@end lisp + +and the last @var{clause} may have the form + +@lisp +(else @var{expr1} @var{expr2} @dots{}) +@end lisp + +All @var{datum}s must be distinct. First, @var{key} is evaluated. The +the result of this evaluation is compared against all @var{datum}s using +@code{eqv?}. When this comparison succeeds, the epression(s) following +the @var{datum} are evaluated from left to right, returning the value of +the last expression as the result of the @code{case} expression. + +If the @var{key} matches no @var{datum} and there is an +@code{else}--clause, the expressions following the @code{else} are +evaluated. If there is no such clause, the result of the expression is +unspecified. +@end deffn + @node and or @section Conditional Evaluation of a Sequence of Expressions +@c FIXME::martin: Review me! + +@c FIXME::martin: Maybe add examples? + +@code{and} and @code{or} evaluate all their arguments, similar to +@code{begin}, but evaluation stops as soon as one of the expressions +evaluates to false or true, respectively. + +@deffn syntax and expr @dots{} +Evaluate the @var{expr}s from left to right and stop evaluation as soon +as one expression evaluates to @code{#f}; the remaining expressions are +not evaluated. The value of the last evaluated expression is returned. +If no expression evaluates to @code{#f}, the value of the last +expression is returned. + +If used without expressions, @code{#t} is returned. +@end deffn + +@deffn syntax or expr @dots{} +Evaluate the @var{expr}s from left to right and stop evaluation as soon +as one expression evaluates to a true value (that is, a value different +from @code{#f}); the remaining expressions are not evaluated. The value +of the last evaluated expression is returned. If all expressions +evaluate to @code{#f}, @code{#f} is returned. + +If used without expressions, @code{#f} is returned. +@end deffn + @node while do @section Iteration mechanisms +@c FIXME::martin: Review me! + +@c FIXME::martin: Maybe add examples? + +@cindex iteration +@cindex looping + +Scheme has only few iteration mechanisms, mainly because iteration in +Scheme programs is normally expressed using recursion. Nevertheless, +R5RS defines a construct for programming loops, calling @code{do}. In +addition, Guile has an explicit looping syntax called @code{while}. + +@deffn syntax do ((variable1 init1 step1) @dots{}) (test expr @dots{}) command @dots{} +The @var{init} expressions are evaluated and the @var{variables} are +bound to their values. Then looping starts with testing the @var{test} +expression. If @var{test} evaluates to a true value, the @var{expr} +following the @var{test} are evaluated and the value of the last +@var{expr} is returned as the value of the @code{do} expression. If +@var{test} evaluates to false, the @var{command}s are evaluated in +order, the @var{step}s are evaluated and stored into the @var{variables} +and the next iteration starts. + +Any of the @var{step} expressions may be omitted, so that the +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. +@end deffn + @node Continuations @section Continuations @@ -42,8 +213,27 @@ @node Multiple Values @section Returning and Accepting Multiple Values +@c FIXME::martin: Review me! +@cindex multiple values +@cindex receive + +Scheme allows a procedure to return more than one value to its caller. +This is quite different to other languages which only allow +single--value returns. Returning multiple values is different from +returning a list (or pair or vector) of values to the caller, because +conceptionally not @emph{one} compound object is returned, but several +distinct values. + +The primitive procedures for handling multiple values are @code{values} +and @code{call-with-values}. @code{values} is used for returning +multiple values from a procedure. This is done by placing a call to +@code{values} with zero or more arguments in tail position in a +procedure body. @code{call-with-values} combines a procedure returning +multiple values with a procedure which accepts these values as +parameters. + @rnindex values -@deffn primitive values . args +@deffn primitive values expr @dots{} 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 @@ -70,6 +260,23 @@ of the call to @code{call-with-values}. @end example @end deffn +In addition to the fundamental procedures described above, Guile has a +module which exports a syntax called @code{receive}, which is much more +convenient. If you want to use it in your programs, you have to load +the module @code{(ice-9 receive)} with the statement + +@lisp +(use-modules (ice-9 receive)) +@end lisp + +@deffn {library syntax} receive formals expr body @dots{} +Evaluate the expression @var{expr}, and bind the result values (zero or +more) to the formal arguments in the formal argument list @var{formals}. +@var{formals} must have the same syntax like the formal argument list +used in @code{lambda} (@pxref{Lambda}). After binding the variables, +the expressions in @var{body} @dots{} are evaluated in order. +@end deffn + @node Exceptions @section Exceptions diff --git a/doc/scheme-data.texi b/doc/scheme-data.texi index 92f333c59..70a7614a3 100755 --- a/doc/scheme-data.texi +++ b/doc/scheme-data.texi @@ -1356,12 +1356,12 @@ called with string containing unusal characters. @node String Syntax @subsection String Read Syntax -The read syntax for strings is an arbitrarily long sequence of characters -enclosed in double quotes (@code{"}). @footnote{Actually, the current -implementation restricts strings to a length of 2^24 characters.} If -you want to insert a double quote character into a string literal, it -must be prefixed with a backslash @code{\} character (called an -@emph{escape character}). +The read syntax for strings is an arbitrarily long sequence of +characters enclosed in double quotes (@code{"}). @footnote{Actually, the +current implementation restricts strings to a length of 2^24 +characters.} If you want to insert a double quote character into a +string literal, it must be prefixed with a backslash @code{\} character +(called an @emph{escape character}). The following are examples of string literals: diff --git a/doc/scheme-procedures.texi b/doc/scheme-procedures.texi index 95f7d64aa..800e230f6 100644 --- a/doc/scheme-procedures.texi +++ b/doc/scheme-procedures.texi @@ -81,6 +81,248 @@ order when the procedure is invoked. @node Optional Arguments @section Optional Arguments +@c FIXME::martin: Review me! + +Scheme procedures, as defined in R5RS, can wither handle a fixed number +of actual arguments, or a fixed number of actual arguments followed by +arbitrarily many additional arguments. Writing procedures of variable +arity can be useful, but unfortunately, the syntactic means for handling +argument lists of varying length is a bit inconvenient. It is possible +to give names to the fixed number of argument, but the remaining +(optional) arguments can be only referenced as a list of values +(@pxref{Lambda}). + +Guile comes with the module @code{(ice-9 optargs)}, which makes using +optional arguments much more convenient. In addition, this module +provides syntax for handling keywords in argument lists +(@pxref{Keywords}). + +Before using any of the procedures or macros defined in this section, +you have to load the module @code{(ice-9 optargs)} with the statement: + +@lisp +(use-modules (ice-9 optargs)) +@end lisp + +@menu +* let-optional Reference:: Locally binding optional arguments. +* let-keywords Reference:: Locally binding keywords arguments. +* lambda* Reference:: Creating advanced argument handling procedures. +* define* Reference:: Defining procedures and macros. +@end menu + + +@node let-optional Reference +@subsection let-optional Reference + +@c FIXME::martin: Review me! + +The syntax @code{let-optional} and @code{let-optional*} are for +destructuring rest argument lists and giving names to the various list +elements. @code{let-optional} binds all variables simultaneously, while +@code{let-optional*} binds them sequentially, consistent with @code{let} +and @code{let*} (REFFIXME). + +@deffn {libary syntax} let-optional rest-arg (binding @dots{}) expr @dots{} +@deffnx {library syntax} let-optional* rest-arg (binding @dots{}) expr @dots{} +These two macros give you an optional argument interface that is very +@dfn{Schemey} and introduces no fancy syntax. They are compatible with +the scsh macros of the same name, but are slightly extended. Each of +@var{binding} may be of one of the forms @var{var} or @code{(@var{var} +@var{default-value})}. @var{rest-arg} should be the rest-argument of the +procedures these are used from. The items in @var{rest-arg} are +sequentially bound to the variable names are given. When @var{rest-arg} +runs out, the remaining vars are bound either to the default values or +left unbound if no default value was specified. @var{rest-arg} remains +bound to whatever may have been left of @var{rest-arg}. + +After binding the variables, the expressions @var{expr} @dots{} are +evaluated in order. +@end deffn + + +@node let-keywords Reference +@subsection let-keywords Reference + +@c FIXME::martin: Review me! + +@code{let-keywords} and @code{let-keywords*} are used for extracting +values from argument lists which use keywords instead of argument +position for binding local variables to argument values. + +@code{let-keywords} binds all variables simultaneously, while +@code{let-keywords*} binds them sequentially, consistent with @code{let} +and @code{let*} (REFFIXME). + +@deffn {library syntax} let-keywords rest-arg allow-other-keys? (binding @dots{}) expr @dots{} +@deffnx {library syntax} let-keywords rest-arg allow-other-keys? (binding @dots{}) expr @dots{} +These macros pick out keyword arguments from @var{rest-arg}, but do not +modify it. This is consistent at least with Common Lisp, which +duplicates keyword arguments in the rest argument. More explanation of what +keyword arguments in a lambda list look like can be found below in +the documentation for @code{lambda*} + (@pxref{lambda* Reference}). @var{binding}s can have the same form as +for @code{let-optional}. If @var{allow-other-keys?} is false, an error +will be thrown if anything that looks like a keyword argument but does +not match a known keyword parameter will result in an error. + +After binding the variables, the expressions @var{expr} @dots{} are +evaluated in order. +@end deffn + + +@node lambda* Reference +@subsection lambda* Reference + +@c FIXME::martin: Review me! + +When using optional and keyword argument lists, using @code{lambda} for +creating procedures and using @code{let-optional} or @code{let-keywords} +is a bit lengthy. Therefore, @code{lambda*} is provided, which combines +the features of those macros into a single convenient syntax. + +For quick reference, here is the syntax of the formal argument list for +@code{lambda*} (brackets are used to indicate grouping only): + +@example +ext-param-list ::= [identifier]* [#:optional [ext-var-decl]+]? + [#:key [ext-var-decl]+ [#:allow-other-keys]?]? + [[#:rest identifier]|[. identifier]]? + +ext-var-decl ::= identifier | ( identifier expression ) +@end example + +The characters `*', `+' and `?' are not to be taken literally; they mean +respectively, zero or more occurences, one or more occurences, and one +or zero occurences. + +@deffn {library syntax} lambda* formals body +@code{lambda*} creates a procedure that takes optional arguments. These +are specified by putting them inside brackets at the end of the +paramater list, but before any dotted rest argument. For example, + +@lisp +(lambda* (a b #:optional c d . e) '()) +@end lisp + +creates a procedure with fixed arguments @var{a} and @var{b}, optional +arguments @var{c} and @var{d}, and rest argument @var{e}. If the +optional arguments are omitted in a call, the variables for them are +unbound in the procedure. This can be checked with the @code{bound?} +macro (documented below). + +@code{lambda*} can also take keyword arguments. For example, a procedure +defined like this: + +@lisp +(lambda* (#:key xyzzy larch) '()) +@end lisp + +can be called with any of the argument lists @code{(#:xyzzy 11)} +@code{(#:larch 13)} @code{(#:larch 42 #:xyzzy 19)} @code{()}. Whichever +arguments are given as keywords are bound to values. + +Optional and keyword arguments can also be given default values +which they take on when they are not present in a call, by giving a +two-item list in place of an optional argument, for example in: + +@lisp +(lambda* (foo #:optional (bar 42) #:key (baz 73)) + (list foo bar baz)) +@end lisp + +@var{foo} is a fixed argument, @var{bar} is an optional argument with +default value 42, and baz is a keyword argument with default value 73. +Default value expressions are not evaluated unless they are needed and +until the procedure is called. + +@code{lambda*} also supports two more special parameter list keywords. + +@code{lambda*}-defined procedures now throw an error by default if a +keyword other than one of those specified is found in the actual +passed arguments. However, specifying @code{#:allow-other-keys} +immediately after the keyword argument declarations restores the +previous behavior of ignoring unknown keywords. @code{lambda*} also now +guarantees that if the same keyword is passed more than once, the +last one passed is the one that takes effect. For example, + +@lisp +((lambda* (#:key (heads 0) (tails 0)) (display (list heads tails))) + #:heads 37 #:tails 42 #:heads 99) +@end lisp + +would result in (99 47) being displayed. + +@code{#:rest} is also now provided as a synonym for the dotted syntax +rest argument. The argument lists @code{(a . b)} and @code{(a #:rest b)} +are equivalent in all respects to @code{lambda*}. This is provided for +more similarity to DSSSL, MIT-Scheme and Kawa among others, as well as +for refugees from other Lisp dialects. +@end deffn + +@deffn {library syntax} bound? variable +Check if a variable is bound in the current environment. + +The procedure @code{defined?} doesn't quite cut it as it stands, since +it only checks bindings in the top-level environment, not those in local +scope only. +@end deffn + + +@node define* Reference +@subsection define* Reference + +@c FIXME::martin: Review me! + +Just like @code{define} has a shorthand notation for defining procedures +(@pxref{Lambda Alternatives}), @code{define*} is provided as an +abbreviation of the combination of @code{define} and @code{lambda*}. + +@code{define*-public} is the @code{lambda*} version of +@code{define-public}; @code{defmacro*} and @code{defmacro*-public} exist +for defining macros with the improved argument list handling +possibilities. The @code{-public} versions not only define the +procedures/macros, but also export them from the current module. + +@deffn {library syntax} define* formals body +@deffnx {library syntax} define*-public formals body +@code{define*} and @code{define*-public} support optional arguments with +a similar syntax to @code{lambda*}. They also support arbitrary-depth +currying, just like Guile's define. Some examples: + +@lisp +(define* (x y #:optional a (z 3) #:key w . u) + (display (list y z u))) +@end lisp +defines a procedure @code{x} with a fixed argument @var{y}, an optional +agument @var{a}, another optional argument @var{z} with default value 3, +a keyword argument @var{w}, and a rest argument @var{u}. + +@lisp +(define-public* ((foo #:optional bar) #:optional baz) '()) +@end lisp + +This illustrates currying. A procedure @code{foo} is defined, which, +when called with an optional argument @var{bar}, returns a procedure +that takes an optional argument @var{baz}. + +Of course, @code{define*[-public]} also supports @code{#:rest} and +@code{#:allow-other-keys} in the same way as @code{lambda*}. +@end deffn + +@deffn {library syntax} defmacro* name formals body +@deffnx {library syntax} defmacro*-public name formals body +These are just like @code{defmacro} and @code{defmacro-public} except that they +take @code{lambda*}-style extended paramter lists, where @code{#:optional}, +@code{#:key}, @code{#:allow-other-keys} and @code{#:rest} are allowed with the usual +semantics. Here is an example of a macro with an optional argument: + +@lisp +(defmacro* transmorgify (a #:optional b) + (a 1)) +@end lisp +@end deffn + @node Procedure Properties @section Procedure Properties and Metainformation From 5b079b46d2afcf2c4f5b059244290bd7cb829067 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Tue, 17 Apr 2001 22:35:35 +0000 Subject: [PATCH 0827/2047] * configure.in: run the autoconf BIGENDIAN check. --- configure.in | 2 ++ 1 file changed, 2 insertions(+) diff --git a/configure.in b/configure.in index dc44f96cc..ff584e4da 100644 --- a/configure.in +++ b/configure.in @@ -140,6 +140,8 @@ AM_PROG_LIBTOOL AC_C_CONST AC_C_INLINE +AC_C_BIGENDIAN + AC_CHECK_SIZEOF(int) AC_CHECK_SIZEOF(long) AC_CACHE_CHECK([for long longs], scm_cv_long_longs, From 3453619bd33031cd608b79b42cddd0375200e1bc Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Tue, 17 Apr 2001 23:03:07 +0000 Subject: [PATCH 0828/2047] * some initial support for IPv6: * socket.c (scm_fill_sockaddr): improve the argument validation. don't allocate memory until all args are checked. instead of unconditional memset of soka, try setting sin_len to 0 if SIN_LEN is defined. add support for AF_INET6. define FUNC_NAME. (scm_socket, scm_connect): extend docstrings for IPv6. (scm_init_socket): intern AF_INET6 and PF_INET6. --- libguile/ChangeLog | 11 ++++ libguile/socket.c | 130 +++++++++++++++++++++++++++++++++++++-------- 2 files changed, 120 insertions(+), 21 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 27160dbec..f8c4b3ef1 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2001-04-17 Gary Houston + + * some initial support for IPv6: + + * socket.c (scm_fill_sockaddr): improve the argument validation. + don't allocate memory until all args are checked. instead of + unconditional memset of soka, try setting sin_len to 0 if + SIN_LEN is defined. add support for AF_INET6. define FUNC_NAME. + (scm_socket, scm_connect): extend docstrings for IPv6. + (scm_init_socket): intern AF_INET6 and PF_INET6. + 2001-04-17 Niibe Yutaka * srcprop.c (scm_make_srcprops): Added SCM_ALLOW_INTS which diff --git a/libguile/socket.c b/libguile/socket.c index 199e2497a..211f2d023 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -148,9 +148,9 @@ SCM_DEFINE (scm_socket, "socket", 3, 0, 0, (SCM family, SCM style, SCM proto), "Return a new socket port of the type specified by @var{family},\n" "@var{style} and @var{protocol}. All three parameters are\n" - "integers. Typical values for @var{family} are the values of\n" - "@code{AF_UNIX} and @code{AF_INET}. Typical values for\n" - "@var{style} are the values of @code{SOCK_STREAM},\n" + "integers. Supported values for @var{family} are\n" + "@code{AF_UNIX}, @code{AF_INET} and @code{AF_INET6}.\n" + "Typical values for @var{style} are @code{SOCK_STREAM},\n" "@code{SOCK_DGRAM} and @code{SOCK_RAW}.\n" "\n" "@var{protocol} can be obtained from a protocol name using\n" @@ -407,31 +407,106 @@ SCM_DEFINE (scm_shutdown, "shutdown", 2, 0, 0, static struct sockaddr * scm_fill_sockaddr (int fam, SCM address, SCM *args, int which_arg, const char *proc, int *size) +#define FUNC_NAME proc { switch (fam) { case AF_INET: { - SCM isport; struct sockaddr_in *soka; + unsigned long addr; + int port; - SCM_ASSERT (SCM_CONSP (*args), *args, - which_arg + 1, proc); - isport = SCM_CAR (*args); - SCM_ASSERT (SCM_INUMP (isport), isport, which_arg + 1, proc); + SCM_VALIDATE_ULONG_COPY (which_arg, address, addr); + SCM_VALIDATE_CONS (which_arg + 1, *args); + SCM_VALIDATE_INUM_COPY (which_arg + 1, SCM_CAR (*args), port); + *args = SCM_CDR (*args); soka = (struct sockaddr_in *) malloc (sizeof (struct sockaddr_in)); if (!soka) scm_memory_error (proc); - /* e.g., for BSDs which don't like invalid sin_len. */ - memset (soka, 0, sizeof (struct sockaddr_in)); + /* 4.4BSD-style interface includes sin_len member and defines SIN_LEN, + 4.3BSD does not. */ +#ifdef SIN_LEN + soka->sin_len = sizeof (struct sockaddr_in); +#endif soka->sin_family = AF_INET; - soka->sin_addr.s_addr = - htonl (scm_num2ulong (address, which_arg, proc)); - *args = SCM_CDR (*args); - soka->sin_port = htons (SCM_INUM (isport)); + soka->sin_addr.s_addr = htonl (addr); + soka->sin_port = htons (port); *size = sizeof (struct sockaddr_in); return (struct sockaddr *) soka; } +#ifdef AF_INET6 + case AF_INET6: + { + /* see RFC2553. */ + int port; + struct sockaddr_in6 *soka; + unsigned long flowinfo = 0; + unsigned long scope_id = 0; + + if (SCM_INUMP (address)) + SCM_ASSERT_RANGE (which_arg, address, SCM_INUM (address) >= 0); + else + { + SCM_VALIDATE_BIGINT (which_arg, address); + SCM_ASSERT_RANGE (which_arg, address, + !SCM_BIGSIGN (address) + && (SCM_BITSPERDIG + * SCM_NUMDIGS (address) <= 128)); + } + SCM_VALIDATE_CONS (which_arg + 1, *args); + SCM_VALIDATE_INUM_COPY (which_arg + 1, SCM_CAR (*args), port); + *args = SCM_CDR (*args); + if (SCM_CONSP (*args)) + { + SCM_VALIDATE_ULONG_COPY (which_arg + 2, SCM_CAR (*args), flowinfo); + *args = SCM_CDR (*args); + if (SCM_CONSP (*args)) + { + SCM_VALIDATE_ULONG_COPY (which_arg + 3, SCM_CAR (*args), + scope_id); + *args = SCM_CDR (*args); + } + } + soka = (struct sockaddr_in6 *) malloc (sizeof (struct sockaddr_in6)); + if (!soka) + scm_memory_error (proc); +#ifdef SIN_LEN6 + soka->sin6_len = sizeof (struct sockaddr_in6); +#endif + soka->sin6_family = AF_INET6; + if (SCM_INUMP (address)) + { + uint32_t addr = htonl (SCM_INUM (address)); + + memset (soka->sin6_addr.s6_addr, 0, 12); + memcpy (soka->sin6_addr.s6_addr + 12, &addr, 4); + } + else + { + scm_sizet i; + + memset (soka->sin6_addr.s6_addr, 0, 16); + memcpy (soka->sin6_addr.s6_addr, SCM_BDIGITS (address), + SCM_NUMDIGS (address) * (SCM_BITSPERDIG / 8)); +#ifndef WORDS_BIGENDIAN + /* flip to network order. */ + for (i = 0; i < 8; i++) + { + char c = soka->sin6_addr.s6_addr[i]; + + soka->sin6_addr.s6_addr[i] = soka->sin6_addr.s6_addr[15 - i]; + soka->sin6_addr.s6_addr[15 - i] = c; + } +#endif + } + soka->sin6_port = port; + soka->sin6_flowinfo = flowinfo; + soka->sin6_scope_id = scope_id; + *size = sizeof (struct sockaddr_in6); + return (struct sockaddr *) soka; + } +#endif #ifdef HAVE_UNIX_DOMAIN_SOCKETS case AF_UNIX: { @@ -462,19 +537,26 @@ scm_fill_sockaddr (int fam, SCM address, SCM *args, int which_arg, scm_out_of_range (proc, SCM_MAKINUM (fam)); } } +#undef FUNC_NAME SCM_DEFINE (scm_connect, "connect", 3, 0, 1, (SCM sock, SCM fam, SCM address, SCM args), - "Initiates a connection from @var{socket} to the address\n" - "specified by @var{address} and possibly @var{arg @dots{}}. The format\n" - "required for @var{address}\n" - "and @var{arg} @dots{} depends on the family of the socket.\n\n" + "Initiates a connection from a socket using a specified address\n" + "family to the address\n" + "specified by @var{address} and possibly @var{args}.\n" + "The format required for @var{address}\n" + "and @var{args} depends on the family of the socket.\n\n" "For a socket of family @code{AF_UNIX},\n" - "only @code{address} is specified and must be a string with the\n" + "only @var{address} is specified and must be a string with the\n" "filename where the socket is to be created.\n\n" "For a socket of family @code{AF_INET},\n" - "@code{address} must be an integer Internet host address and @var{arg} @dots{}\n" - "must be a single integer port number.\n\n" + "@var{address} must be an integer IPv4 host address and\n" + "@var{args} must be a single integer port number.\n\n" + "For a socket of family @code{AF_INET6},\n" + "@var{address} must be an integer IPv6 host address and\n" + "@var{args} may be up to three integers:\n" + "port [flowinfo] [scope_id],\n" + "where flowinfo and scope_id default to zero.\n\n" "The return value is unspecified.") #define FUNC_NAME s_scm_connect { @@ -906,6 +988,9 @@ scm_init_socket () #ifdef AF_INET scm_sysintern ("AF_INET", SCM_MAKINUM (AF_INET)); #endif +#ifdef AF_INET6 + scm_sysintern ("AF_INET6", SCM_MAKINUM (AF_INET6)); +#endif #ifdef PF_UNSPEC scm_sysintern ("PF_UNSPEC", SCM_MAKINUM (PF_UNSPEC)); @@ -916,6 +1001,9 @@ scm_init_socket () #ifdef PF_INET scm_sysintern ("PF_INET", SCM_MAKINUM (PF_INET)); #endif +#ifdef PF_INET6 + scm_sysintern ("PF_INET6", SCM_MAKINUM (PF_INET6)); +#endif /* socket types. */ #ifdef SOCK_STREAM From 31e74a57aa4ae37262ae8e51699ea06a1fcfee36 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Tue, 17 Apr 2001 23:04:09 +0000 Subject: [PATCH 0829/2047] *** empty log message *** --- ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ChangeLog b/ChangeLog index 694d6f415..87d18fe0d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2001-04-17 Gary Houston + + * configure.in: run the autoconf BIGENDIAN check. + 2001-04-12 Niibe Yutaka * GUILE-VERSION (LIBGUILEQTHREADS_MAJOR_VERSION, From e038c04203e77522ba59c8181df4601ed15621a1 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 19 Apr 2001 09:38:37 +0000 Subject: [PATCH 0830/2047] * Eliminate some further applications of SCM_C[AD]R to non pair cells. --- NEWS | 2 +- RELEASE | 2 +- libguile/ChangeLog | 26 ++++++++++++++++++++++++++ libguile/gc.h | 9 ++++----- libguile/srcprop.h | 21 ++++++++++++++------- libguile/unif.c | 6 +++--- libguile/unif.h | 25 +++++++++++++++---------- 7 files changed, 64 insertions(+), 27 deletions(-) diff --git a/NEWS b/NEWS index 292872726..e138e560b 100644 --- a/NEWS +++ b/NEWS @@ -679,7 +679,7 @@ SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR, SCM_SUBR_DOC, SCM_OPDIRP, SCM_VALIDATE_OPDIR, SCM_WTA, RETURN_SCM_WTA, SCM_CONST_LONG, SCM_WNA, SCM_FUNC_NAME, SCM_VALIDATE_NUMBER_COPY, SCM_VALIDATE_NUMBER_DEF_COPY, SCM_SLOPPY_CONSP, SCM_SLOPPY_NCONSP, -SCM_SETAND_CDR, SCM_SETOR_CDR +SCM_SETAND_CDR, SCM_SETOR_CDR, SCM_SETAND_CAR, SCM_SETOR_CAR Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of SCM_OUTOFRANGE. Use scm_memory_error instead of SCM_NALLOC. diff --git a/RELEASE b/RELEASE index 1d67c6dc2..16c772614 100644 --- a/RELEASE +++ b/RELEASE @@ -69,7 +69,7 @@ In release 1.6: SCM_SUBR_DOC, SCM_OPDIRP, SCM_VALIDATE_OPDIR, SCM_WTA, RETURN_SCM_WTA, SCM_WNA, SCM_FUNC_NAME, SCM_VALIDATE_NUMBER_COPY, SCM_VALIDATE_NUMBER_DEF_COPY, SCM_SLOPPY_CONSP, SCM_SLOPPY_NCONSP, - SCM_SETAND_CDR, SCM_SETOR_CDR + SCM_SETAND_CDR, SCM_SETOR_CDR, SCM_SETAND_CAR, SCM_SETOR_CAR - remove scm_vector_set_length_x - remove function scm_call_catching_errors (replaced by catch functions from throw.[ch]) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f8c4b3ef1..8da43e204 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,29 @@ +2001-04-19 Dirk Herrmann + + This patch eliminates some further applications of SCM_C[AD]R to + non pair cells. + + * gc.h (SCM_SETAND_CAR, SCM_SETOR_CAR): Deprecated. These have + never been applied to real pairs. + + * srcprop.h (SCM_SOURCE_PROPERTY_FLAG_BREAK): Added. + + (SRCPROPBRK): Use SCM_SOURCE_PROPERTY_FLAG_BREAK. + + * unif.h (SCM_ARRAY_CONTIGUOUS, SCM_ARRAY_FLAG_CONTIGUOUS, + SCM_ARRAY_CONTP): Renamed SCM_ARRAY_CONTIGUOUS to + SCM_ARRAY_FLAG_CONTIGUOUS and use it. + + (SCM_SET_ARRAY_CONTIGUOUS_FLAG, SCM_CLR_ARRAY_CONTIGUOUS_FLAG): + Added. + + * srcprop.h (SRCPROPH), unif.h (UNIFH): Renamed to + SCM_SOURCE_PROPERTIES_H and SCM_UNIFORM_VECTORS_H, respectively. + + * srcprop.h (SETSRCPROPBRK, CLEARSRCPROPBRK), unif.c + (scm_dimensions_to_uniform_array, scm_ra_set_contp): Don't use + SCM_SET{AND,OR}_CAR. + 2001-04-17 Gary Houston * some initial support for IPv6: diff --git a/libguile/gc.h b/libguile/gc.h index b833dc763..150074f37 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -218,11 +218,6 @@ typedef unsigned long scm_c_bvec_limb_t; (((const scm_bits_t *) SCM2PTR (x)) [0]) -#define SCM_SETAND_CAR(x, y) \ - (SCM_SETCAR ((x), SCM_PACK (SCM_UNPACK (SCM_CAR (x)) & (y)))) -#define SCM_SETOR_CAR(x, y)\ - (SCM_SETCAR ((x), SCM_PACK (SCM_UNPACK (SCM_CAR (x)) | (y)))) - #define SCM_CELL_WORD_LOC(x, n) ((scm_bits_t *) & SCM_CELL_WORD (x, n)) #define SCM_CARLOC(x) ((SCM *) SCM_CELL_WORD_LOC ((x), 0)) #define SCM_CDRLOC(x) ((SCM *) SCM_CELL_WORD_LOC ((x), 1)) @@ -394,6 +389,10 @@ extern void scm_init_gc (void); #if (SCM_DEBUG_DEPRECATED == 0) +#define SCM_SETAND_CAR(x, y) \ + (SCM_SETCAR ((x), SCM_PACK (SCM_UNPACK (SCM_CAR (x)) & (y)))) +#define SCM_SETOR_CAR(x, y)\ + (SCM_SETCAR ((x), SCM_PACK (SCM_UNPACK (SCM_CAR (x)) | (y)))) #define SCM_SETAND_CDR(x, y)\ (SCM_SETCDR ((x), SCM_PACK (SCM_UNPACK (SCM_CDR (x)) & (y)))) #define SCM_SETOR_CDR(x, y)\ diff --git a/libguile/srcprop.h b/libguile/srcprop.h index 8c5a42faf..93c60ac26 100644 --- a/libguile/srcprop.h +++ b/libguile/srcprop.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef SRCPROPH -#define SRCPROPH -/* Copyright (C) 1995,1996, 2000 Free Software Foundation +#ifndef SCM_SOURCE_PROPERTIES_H +#define SCM_SOURCE_PROPERTIES_H +/* Copyright (C) 1995,1996,2000,2001 Free Software Foundation * * 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 @@ -95,16 +95,23 @@ typedef struct scm_srcprops_chunk scm_srcprops srcprops[1]; } scm_srcprops_chunk; +#define SCM_SOURCE_PROPERTY_FLAG_BREAK (1L << 16) + #define SRCPROPSP(p) (SCM_TYP16_PREDICATE (scm_tc16_srcprops, p)) -#define SRCPROPBRK(p) (SCM_BOOL (SCM_CELL_WORD_0 (p) & (1L << 16))) +#define SRCPROPBRK(p) \ + (SCM_BOOL (SCM_CELL_WORD_0 (p) & SCM_SOURCE_PROPERTY_FLAG_BREAK)) #define SRCPROPPOS(p) ((scm_srcprops *) SCM_CELL_WORD_1 (p))->pos #define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12) #define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL) #define SRCPROPFNAME(p) ((scm_srcprops *) SCM_CELL_WORD_1 (p))->fname #define SRCPROPCOPY(p) ((scm_srcprops *) SCM_CELL_WORD_1 (p))->copy #define SRCPROPPLIST(p) ((scm_srcprops *) SCM_CELL_WORD_1 (p))->plist -#define SETSRCPROPBRK(p) (SCM_SETOR_CAR (p, (1L << 16))) -#define CLEARSRCPROPBRK(p) SCM_SETAND_CAR (p, ~(1L << 16)) +#define SETSRCPROPBRK(p) \ + (SCM_SET_CELL_WORD_0 ((p), SCM_CELL_WORD_0 (p) \ + | SCM_SOURCE_PROPERTY_FLAG_BREAK)) +#define CLEARSRCPROPBRK(p) \ + (SCM_SET_CELL_WORD_0 ((p), SCM_CELL_WORD_0 (p) \ + & ~SCM_SOURCE_PROPERTY_FLAG_BREAK)) #define SRCPROPMAKPOS(l,c) (((l) << 12) + (c)) #define SETSRCPROPPOS(p,l,c) (SRCPROPPOS (p) = SRCPROPMAKPOS (l, c)) #define SETSRCPROPLINE(p,l) SETSRCPROPPOS (p, l, SRCPROPCOL (p)) @@ -134,7 +141,7 @@ extern SCM scm_set_source_properties_x (SCM obj, SCM props); extern void scm_finish_srcprop (void); extern void scm_init_srcprop (void); -#endif /* SRCPROPH */ +#endif /* SCM_SOURCE_PROPERTIES_H */ /* Local Variables: diff --git a/libguile/unif.c b/libguile/unif.c index 70fda42b9..d183dddb9 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -604,7 +604,7 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, SCM_ASSERT (SCM_NULLP (dims) || SCM_CONSP (dims), dims, SCM_ARG1, FUNC_NAME); ra = scm_shap2ra (dims, FUNC_NAME); - SCM_SETOR_CAR (ra, SCM_ARRAY_CONTIGUOUS); + SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); s = SCM_ARRAY_DIMS (ra); k = SCM_ARRAY_NDIM (ra); while (k--) @@ -642,14 +642,14 @@ scm_ra_set_contp (SCM ra) { if (inc != SCM_ARRAY_DIMS (ra)[k].inc) { - SCM_SETAND_CAR (ra, ~SCM_ARRAY_CONTIGUOUS); + SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra); return; } inc *= (SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1); } } - SCM_SETOR_CAR (ra, SCM_ARRAY_CONTIGUOUS); + SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); } diff --git a/libguile/unif.h b/libguile/unif.h index fd4d0e744..bddffa1ed 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef UNIFH -#define UNIFH -/* Copyright (C) 1995,1996,1997,1999, 2000 Free Software Foundation, Inc. +#ifndef SCM_UNIFORM_VECTORS_H +#define SCM_UNIFORM_VECTORS_H +/* Copyright (C) 1995,1996,1997,1999,2000,2001 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 @@ -55,7 +55,7 @@ an array SCM is a non-immediate pointing to a heap cell with: CAR: bits 0-14 hold the dimension (0 -- 32767) - bit 15 is the SCM_ARRAY_CONTIGUOUS flag + bit 15 is the SCM_ARRAY_FLAG_CONTIGUOUS flag bits 16-31 hold the smob type id: scm_tc16_array CDR: pointer to a malloced block containing an scm_array structure followed by an scm_array_dim structure for each dimension. @@ -74,12 +74,17 @@ typedef struct scm_array_dim long inc; } scm_array_dim; - extern scm_bits_t scm_tc16_array; -#define SCM_ARRAYP(a) SCM_TYP16_PREDICATE (scm_tc16_array, a) -#define SCM_ARRAY_NDIM(x) ((scm_sizet) (SCM_CELL_WORD_0 (x) >> 17)) -#define SCM_ARRAY_CONTIGUOUS 0x10000 -#define SCM_ARRAY_CONTP(x) (SCM_ARRAY_CONTIGUOUS & (SCM_CELL_WORD_0 (x))) + +#define SCM_ARRAY_FLAG_CONTIGUOUS (1 << 16) + +#define SCM_ARRAYP(a) SCM_TYP16_PREDICATE (scm_tc16_array, a) +#define SCM_ARRAY_NDIM(x) ((scm_sizet) (SCM_CELL_WORD_0 (x) >> 17)) +#define SCM_ARRAY_CONTP(x) (SCM_CELL_WORD_0 (x) & SCM_ARRAY_FLAG_CONTIGUOUS) +#define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \ + (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | SCM_ARRAY_FLAG_CONTIGUOUS)) +#define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \ + (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~SCM_ARRAY_FLAG_CONTIGUOUS)) #define SCM_ARRAY_MEM(a) ((scm_array *) SCM_CELL_WORD_1 (a)) #define SCM_ARRAY_V(a) (SCM_ARRAY_MEM (a)->v) @@ -151,7 +156,7 @@ extern void scm_init_unif (void); #endif /* SCM_DEBUG_DEPRECATED == 0 */ -#endif /* UNIFH */ +#endif /* SCM_UNIFORM_VECTORS_H */ /* Local Variables: From 726d810a75c140442032ddb1daa6422a104e272f Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 19 Apr 2001 14:46:01 +0000 Subject: [PATCH 0831/2047] * Fixed scm_thunk_p's results when applied to closures. * Extracted macro printing code from print.c to macros.c. * Minor cleanups. --- libguile/ChangeLog | 28 +++++++++++ libguile/debug.c | 2 +- libguile/eval.c | 36 +++++++-------- libguile/goops.c | 6 +-- libguile/macros.c | 50 +++++++++++++++++++- libguile/print.c | 110 ++++++++++---------------------------------- libguile/procprop.c | 8 ++-- libguile/procs.c | 7 ++- libguile/procs.h | 1 + libguile/sort.c | 4 +- 10 files changed, 132 insertions(+), 120 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 8da43e204..6d725d8c9 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,31 @@ +2001-04-19 Dirk Herrmann + + * procs.h (SCM_CLOSURE_FORMALS): New macro. + + * debug.c (scm_procedure_source), eval.c (scm_badformalsp, + SCM_CEVAL, SCM_APPLY), goops.c (get_slot_value, set_slot_value), + procprop.c (scm_i_procedure_arity), sort.c (closureless): Use + SCM_CLOSURE_FORMALS. + + * eval.c (scm_badformalsp, SCM_CEVAL), procprop.c + (scm_i_procedure_arity): Prefer stronger predicates like + SCM_NULLP or SCM_FALSEP over SCM_IMP. + + * macros.c (macro_print): Extracted macro printing code from + print.c and simplified it. + + (scm_macro_type): Use SCM_MACRO_TYPE; + + (scm_init_macros): Use macro_print for printing macros. + + * print.c (scm_print_opts): Improved option documentation. + + (scm_iprin1): Extracted printing of macros to macros.c. + Simplified printing of ordinary closures. + + * procs.c (scm_thunk_p): Fixed handling of closures. Thanks to + Martin Grabmueller for the bug report. + 2001-04-19 Dirk Herrmann This patch eliminates some further applications of SCM_C[AD]R to diff --git a/libguile/debug.c b/libguile/debug.c index 3b4f77fa9..20fa8d7c6 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -429,7 +429,7 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0, SCM src; src = scm_source_property (SCM_CDR (SCM_CODE (proc)), scm_sym_copy); if (! SCM_FALSEP (src)) - return scm_cons2 (scm_sym_lambda, SCM_CAR (SCM_CODE (proc)), src); + return scm_cons2 (scm_sym_lambda, SCM_CLOSURE_FORMALS (proc), src); src = SCM_CODE (proc); return scm_cons (scm_sym_lambda, scm_unmemocopy (src, diff --git a/libguile/eval.c b/libguile/eval.c index 67d90345f..c8136e138 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1489,10 +1489,10 @@ scm_badargsp (SCM formals, SCM args) static int scm_badformalsp (SCM closure, int n) { - SCM formals = SCM_CAR (SCM_CODE (closure)); - while (SCM_NIMP (formals)) + SCM formals = SCM_CLOSURE_FORMALS (closure); + while (!SCM_NULLP (formals)) { - if (SCM_NCONSP (formals)) + if (!SCM_CONSP (formals)) return 0; if (n == 0) return 1; @@ -2218,7 +2218,7 @@ dispatch: debug.info->a.args = t.arg1; #endif #ifndef SCM_RECKLESS - if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), t.arg1)) + if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), t.arg1)) goto wrongnumargs; #endif ENTER_APPLY; @@ -2238,7 +2238,7 @@ dispatch: SCM_SETCDR (tl, t.arg1); } - env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), argl, SCM_ENV (proc)); + env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), argl, SCM_ENV (proc)); x = SCM_CODE (proc); goto nontoplevel_cdrxbegin; } @@ -2630,9 +2630,9 @@ dispatch: #endif if (SCM_CLOSUREP (proc)) { - arg2 = SCM_CAR (SCM_CODE (proc)); + arg2 = SCM_CLOSURE_FORMALS (proc); t.arg1 = SCM_CDR (x); - while (!SCM_IMP (arg2)) + while (!SCM_NULLP (arg2)) { if (!SCM_CONSP (arg2)) goto evapply; @@ -2690,7 +2690,7 @@ evapply: goto umwrongnumargs; case scm_tcs_closures: x = SCM_CODE (proc); - env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, SCM_ENV (proc)); + env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), SCM_EOL, SCM_ENV (proc)); goto nontoplevel_cdrxbegin; case scm_tcs_cons_gloc: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) @@ -2842,9 +2842,9 @@ evapply: /* clos1: */ x = SCM_CODE (proc); #ifdef DEVAL - env = EXTEND_ENV (SCM_CAR (x), debug.info->a.args, SCM_ENV (proc)); + env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), debug.info->a.args, SCM_ENV (proc)); #else - env = EXTEND_ENV (SCM_CAR (x), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc)); + env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc)); #endif goto nontoplevel_cdrxbegin; case scm_tcs_cons_gloc: @@ -3005,11 +3005,11 @@ evapply: case scm_tcs_closures: /* clos2: */ #ifdef DEVAL - env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), + env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), debug.info->a.args, SCM_ENV (proc)); #else - env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), + env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc)); #endif x = SCM_CODE (proc); @@ -3083,11 +3083,11 @@ evapply: debug.info->a.proc = proc; if (!SCM_CLOSUREP (proc)) goto evap3; - if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), debug.info->a.args)) + if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), debug.info->a.args)) goto umwrongnumargs; case scm_tcs_closures: SCM_SET_ARGSREADY (debug); - env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), + env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), debug.info->a.args, SCM_ENV (proc)); x = SCM_CODE (proc); @@ -3145,7 +3145,7 @@ evapply: if (!SCM_CLOSUREP (proc)) goto evap3; { - SCM formals = SCM_CAR (SCM_CODE (proc)); + SCM formals = SCM_CLOSURE_FORMALS (proc); if (SCM_NULLP (formals) || (SCM_CONSP (formals) && (SCM_NULLP (SCM_CDR (formals)) @@ -3157,7 +3157,7 @@ evapply: #ifdef DEVAL SCM_SET_ARGSREADY (debug); #endif - env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), + env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_cons2 (t.arg1, arg2, scm_eval_args (x, env, proc)), @@ -3471,7 +3471,7 @@ tail: arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)); #endif #ifndef SCM_RECKLESS - if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), arg1)) + if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), arg1)) goto wrongnumargs; #endif @@ -3490,7 +3490,7 @@ tail: SCM_SETCDR (tl, arg1); } - args = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), args, SCM_ENV (proc)); + args = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), args, SCM_ENV (proc)); proc = SCM_CDR (SCM_CODE (proc)); again: arg1 = proc; diff --git a/libguile/goops.c b/libguile/goops.c index f63a4a42f..a32cba7d9 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. +/* Copyright (C) 1998,1999,2000,2001 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 @@ -1065,7 +1065,7 @@ get_slot_value (SCM class, SCM obj, SCM slotdef) code = SCM_CAR (access); if (!SCM_CLOSUREP (code)) return SCM_SUBRF (code) (obj); - env = SCM_EXTEND_ENV (SCM_CAR (SCM_CODE (code)), + env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code), SCM_LIST1 (obj), SCM_ENV (code)); /* Evaluate the closure body */ @@ -1104,7 +1104,7 @@ set_slot_value (SCM class, SCM obj, SCM slotdef, SCM value) SCM_SUBRF (code) (obj, value); else { - env = SCM_EXTEND_ENV (SCM_CAR (SCM_CODE (code)), + env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code), SCM_LIST2 (obj, value), SCM_ENV (code)); /* Evaluate the closure body */ diff --git a/libguile/macros.c b/libguile/macros.c index 44eac33d8..734cd6d5d 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001 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 @@ -45,6 +45,10 @@ #include "libguile/_scm.h" +#include "libguile/alist.h" /* for SCM_EXTEND_ENV (well...) */ +#include "libguile/eval.h" +#include "libguile/ports.h" +#include "libguile/print.h" #include "libguile/root.h" #include "libguile/smob.h" @@ -53,6 +57,47 @@ scm_bits_t scm_tc16_macro; + +static int +macro_print (SCM macro, SCM port, scm_print_state *pstate) +{ + SCM code = SCM_MACRO_CODE (macro); + if (!SCM_CLOSUREP (code) + || SCM_FALSEP (scm_procedure_p (SCM_PRINT_CLOSURE)) + || SCM_FALSEP (scm_printer_apply (SCM_PRINT_CLOSURE, + macro, port, pstate))) + { + if (!SCM_CLOSUREP (code)) + scm_puts ("#', port); + } + + return 1; +} + + SCM_DEFINE (scm_makacro, "procedure->syntax", 1, 0, 0, (SCM code), "Return a @dfn{macro} which, when a symbol defined to this value\n" @@ -139,7 +184,7 @@ SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0, { if (!SCM_TYP16_PREDICATE (scm_tc16_macro, m)) return SCM_BOOL_F; - switch (SCM_CELL_WORD_0 (m) >> 16) + switch (SCM_MACRO_TYPE (m)) { case 0: return scm_sym_syntax; case 1: return scm_sym_macro; @@ -186,6 +231,7 @@ scm_init_macros () { scm_tc16_macro = scm_make_smob_type ("macro", 0); scm_set_smob_mark (scm_tc16_macro, scm_markcdr); + scm_set_smob_print (scm_tc16_macro, macro_print); #ifndef SCM_MAGIC_SNARFER #include "libguile/macros.x" #endif diff --git a/libguile/print.c b/libguile/print.c index b1f59d249..e686d26dd 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -128,8 +128,8 @@ char *scm_isymnames[] = }; scm_option scm_print_opts[] = { - { SCM_OPTION_SCM, "closure-hook", SCM_UNPACK(SCM_BOOL_F), - "Hook for printing closures." }, + { SCM_OPTION_SCM, "closure-hook", SCM_UNPACK (SCM_BOOL_F), + "Hook for printing closures (should handle macros as well)." }, { SCM_OPTION_BOOLEAN, "source", 0, "Print closures with source." } }; @@ -310,6 +310,7 @@ print_circref (SCM port,scm_print_state *pstate,SCM ref) SCM_GPROC(s_write, "write", 1, 1, 0, scm_write, g_write); SCM_GPROC(s_display, "display", 1, 1, 0, scm_display, g_display); + void scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) { @@ -408,83 +409,29 @@ taloop: circref: print_circref (port, pstate, exp); break; - macros: - if (!SCM_CLOSUREP (SCM_CDR (exp))) - goto prinmacro; case scm_tcs_closures: - /* The user supplied print closure procedure must handle - macro closures as well. */ if (SCM_FALSEP (scm_procedure_p (SCM_PRINT_CLOSURE)) || SCM_FALSEP (scm_printer_apply (SCM_PRINT_CLOSURE, exp, port, pstate))) - { - SCM name, code, env; - if (SCM_MACROP (exp)) - { - /* Printing a macro. */ - prinmacro: - name = scm_macro_name (exp); - if (!SCM_CLOSUREP (SCM_CDR (exp))) - { - code = env = SCM_UNDEFINED; - scm_puts ("#', port, pstate); - EXIT_NESTED_DATA (pstate); - } - else - { - if (SCM_TYP16 (exp) != scm_tc16_macro) - { - scm_putc (' ', port); - scm_iprin1 (SCM_CAR (code), port, pstate); - } - scm_putc ('>', port); - } - } - else + { + SCM formals = SCM_CLOSURE_FORMALS (exp); + scm_puts ("#', port); - } + } break; case scm_tc7_substring: case scm_tc7_string: @@ -698,19 +645,10 @@ taloop: register long i; ENTER_NESTED_DATA (pstate, exp, circref); i = SCM_SMOBNUM (exp); - if (i < scm_numsmob && scm_smobs[i].print - && (scm_smobs[i].print) (exp, port, pstate)) - { - EXIT_NESTED_DATA (pstate); - break; - } + if (i < scm_numsmob && scm_smobs[i].print) + (scm_smobs[i].print) (exp, port, pstate); EXIT_NESTED_DATA (pstate); - /* Macros have their print field set to NULL. They are - handled at the same place as closures in order to achieve - non-redundancy. Placing the condition here won't slow - down printing of other smobs. */ - if (SCM_TYP16 (exp) == scm_tc16_macro) - goto macros; + break; } default: punk: diff --git a/libguile/procprop.c b/libguile/procprop.c index bcd80c25a..7bfc96b3a 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,2000,2001 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 @@ -128,15 +128,15 @@ scm_i_procedure_arity (SCM proc) proc = SCM_PROCEDURE (proc); goto loop; case scm_tcs_closures: - proc = SCM_CAR (SCM_CODE (proc)); - if (SCM_IMP (proc)) + proc = SCM_CLOSURE_FORMALS (proc); + if (SCM_NULLP (proc)) break; while (SCM_CONSP (proc)) { ++a; proc = SCM_CDR (proc); } - if (SCM_NIMP (proc)) + if (!SCM_NULLP (proc)) r = 1; break; case scm_tcs_cons_gloc: diff --git a/libguile/procs.c b/libguile/procs.c index 0e59df8ad..77cd3b9b2 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1997, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1999,2000,2001 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 @@ -223,7 +223,7 @@ SCM_DEFINE (scm_closure_p, "closure?", 1, 0, 0, "Return @code{#t} if @var{obj} is a closure.") #define FUNC_NAME s_scm_closure_p { - return SCM_BOOL(SCM_CLOSUREP (obj)); + return SCM_BOOL (SCM_CLOSUREP (obj)); } #undef FUNC_NAME @@ -238,8 +238,7 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0, switch (SCM_TYP7 (obj)) { case scm_tcs_closures: - if (SCM_NULLP (SCM_CAR (SCM_CODE (obj)))) - return SCM_BOOL_T; + return SCM_BOOL (!SCM_CONSP (SCM_CLOSURE_FORMALS (obj))); case scm_tc7_subr_0: case scm_tc7_subr_1o: case scm_tc7_lsubr: diff --git a/libguile/procs.h b/libguile/procs.h index 7007b3d2b..ca39c918d 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -93,6 +93,7 @@ typedef struct #define SCM_CLOSUREP(x) (SCM_NIMP(x) && (SCM_TYP3 (x) == scm_tc3_closure)) #define SCM_CLOSCAR(x) SCM_PACK (SCM_CELL_WORD_0 (x) - scm_tc3_closure) #define SCM_CODE(x) SCM_CAR (SCM_CLOSCAR (x)) +#define SCM_CLOSURE_FORMALS(x) SCM_CAR (SCM_CODE (x)) #define SCM_PROCPROPS(x) SCM_CDR (SCM_CLOSCAR (x)) #define SCM_SETPROCPROPS(x, p) SCM_SETCDR (SCM_CLOSCAR (x), p) #define SCM_SETCODE(x, e) (SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (scm_cons ((e), SCM_EOL)) \ diff --git a/libguile/sort.c b/libguile/sort.c index 2d2941aa4..954f75eeb 100644 --- a/libguile/sort.c +++ b/libguile/sort.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1999,2000,2001 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 * the Free Software Foundation; either version 2, or (at your option) @@ -374,7 +374,7 @@ lsubrless (SCM less, const void *a, const void *b) static int closureless (SCM code, const void *a, const void *b) { - SCM env = SCM_EXTEND_ENV (SCM_CAR (SCM_CODE (code)), + SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code), scm_cons (*(SCM *) a, scm_cons (*(SCM *) b, SCM_EOL)), SCM_ENV (code)); From 4daecfeecc06bbd90d1e96b3eb58a7e4eeefd3a0 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 19 Apr 2001 15:20:27 +0000 Subject: [PATCH 0832/2047] * Some simplification, basically a postscriptum to the previous patch. --- libguile/ChangeLog | 5 +++++ libguile/debug.c | 17 ++++++++--------- 2 files changed, 13 insertions(+), 9 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6d725d8c9..d8cff0871 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-04-19 Dirk Herrmann + + * debug.c (scm_procedure_source): Use SCM_CLOSURE_FORMALS more + consistently. + 2001-04-19 Dirk Herrmann * procs.h (SCM_CLOSURE_FORMALS): New macro. diff --git a/libguile/debug.c b/libguile/debug.c index 20fa8d7c6..42981bfe7 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -426,16 +426,15 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0, switch (SCM_TYP7 (proc)) { case scm_tcs_closures: { - SCM src; - src = scm_source_property (SCM_CDR (SCM_CODE (proc)), scm_sym_copy); - if (! SCM_FALSEP (src)) - return scm_cons2 (scm_sym_lambda, SCM_CLOSURE_FORMALS (proc), src); - src = SCM_CODE (proc); + SCM formals = SCM_CLOSURE_FORMALS (proc); + SCM src = scm_source_property (SCM_CDR (SCM_CODE (proc)), scm_sym_copy); + if (!SCM_FALSEP (src)) + return scm_cons2 (scm_sym_lambda, formals, src); return scm_cons (scm_sym_lambda, - scm_unmemocopy (src, - SCM_EXTEND_ENV (SCM_CAR (src), - SCM_EOL, - SCM_ENV (proc)))); + scm_unmemocopy (SCM_CODE (proc), + SCM_EXTEND_ENV (formals, + SCM_EOL, + SCM_ENV (proc)))); } case scm_tcs_subrs: #ifdef CCLO From af7546ebe2b4340c2d0a679f0e8291266e663d9b Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 19 Apr 2001 16:27:01 +0000 Subject: [PATCH 0833/2047] * Allow to convert an array of bytes to a list. Thanks to Masao Uebayashi. --- THANKS | 1 + libguile/ChangeLog | 5 ++++ libguile/unif.c | 64 ++++++++++++++++++++++++++-------------------- 3 files changed, 42 insertions(+), 28 deletions(-) diff --git a/THANKS b/THANKS index 9b98b45a7..b8d24c973 100644 --- a/THANKS +++ b/THANKS @@ -34,6 +34,7 @@ For fixes or providing information which led to a fix: Bill Schottstaedt Miroslav Silovic Dale P. Smith + Masao Uebayashi Jacques A. Vidrine Brett Viren William Webber diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d8cff0871..a7525c6f5 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-04-19 Dirk Herrmann + + * unif.c (scm_array_to_list): Added missing handling of arrays of + bytes. Thanks to Masao Uebayashi for the bug report. + 2001-04-19 Dirk Herrmann * debug.c (scm_procedure_source): Use SCM_CLOSURE_FORMALS more diff --git a/libguile/unif.c b/libguile/unif.c index d183dddb9..afb0a0cf2 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -2108,36 +2108,44 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, res = scm_cons (SCM_BOOL(((long *) data)[k] & mask), res); return res; } - case scm_tc7_uvect: { - long *data = (long *)SCM_VELTS(v); - for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--) - res = scm_cons(scm_ulong2num(data[k]), res); - return res; - } - case scm_tc7_ivect: { - long *data = (long *)SCM_VELTS(v); - for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--) - res = scm_cons(scm_long2num(data[k]), res); - return res; - } - case scm_tc7_svect: { - short *data; - data = (short *)SCM_VELTS(v); - for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--) - res = scm_cons(SCM_MAKINUM (data[k]), res); - return res; - } + case scm_tc7_byvect: + { + signed char *data = (signed char *) SCM_VELTS (v); + scm_sizet k = SCM_UVECTOR_LENGTH (v); + while (k != 0) + res = scm_cons (SCM_MAKINUM (data[--k]), res); + return res; + } + case scm_tc7_uvect: + { + long *data = (long *)SCM_VELTS(v); + for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--) + res = scm_cons(scm_ulong2num(data[k]), res); + return res; + } + case scm_tc7_ivect: + { + long *data = (long *)SCM_VELTS(v); + for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--) + res = scm_cons(scm_long2num(data[k]), res); + return res; + } + case scm_tc7_svect: + { + short *data = (short *)SCM_VELTS(v); + for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--) + res = scm_cons(SCM_MAKINUM (data[k]), res); + return res; + } #ifdef HAVE_LONG_LONGS - case scm_tc7_llvect: { - long_long *data; - data = (long_long *)SCM_VELTS(v); - for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--) - res = scm_cons(scm_long_long2num(data[k]), res); - return res; - } + case scm_tc7_llvect: + { + long_long *data = (long_long *)SCM_VELTS(v); + for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--) + res = scm_cons(scm_long_long2num(data[k]), res); + return res; + } #endif - - case scm_tc7_fvect: { float *data = (float *) SCM_VELTS (v); From c07b3fefa5efb7a4f9419260285c8229b1e92487 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Thu, 19 Apr 2001 21:10:52 +0000 Subject: [PATCH 0834/2047] * __scm.h (SCM_WTA_DISPATCH_0, SCM_WTA_DISPATCH_1, SCM_WTA_DISPATCH_2, SCM_WTA_DISPATCH_n): Inserted required parentheses in order to get the correct associativity. --- libguile/ChangeLog | 6 ++++++ libguile/__scm.h | 40 +++++++++++++++++++++------------------- 2 files changed, 27 insertions(+), 19 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index a7525c6f5..62a0ad945 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2001-04-19 Mikael Djurfeldt + + * __scm.h (SCM_WTA_DISPATCH_0, SCM_WTA_DISPATCH_1, + SCM_WTA_DISPATCH_2, SCM_WTA_DISPATCH_n): Inserted required + parentheses in order to get the correct associativity. + 2001-04-19 Dirk Herrmann * unif.c (scm_array_to_list): Added missing handling of arrays of diff --git a/libguile/__scm.h b/libguile/__scm.h index 75cfe39e1..928c44918 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -514,40 +514,42 @@ do { \ extern SCM scm_call_generic_0 (SCM gf); -#define SCM_WTA_DISPATCH_0(gf, arg, pos, subr) \ - return (SCM_UNPACK (gf) \ - ? scm_call_generic_0 ((gf)) \ - : scm_wrong_type_arg ((subr), (pos), (arg)), 0) +#define SCM_WTA_DISPATCH_0(gf, arg, pos, subr) \ + return (SCM_UNPACK (gf) \ + ? scm_call_generic_0 ((gf)) \ + : (scm_wrong_type_arg ((subr), (pos), (arg)), SCM_UNSPECIFIED)) #define SCM_GASSERT0(cond, gf, arg, pos, subr) \ if (!(cond)) SCM_WTA_DISPATCH_0((gf), (arg), (pos), (subr)) extern SCM scm_call_generic_1 (SCM gf, SCM a1); -#define SCM_WTA_DISPATCH_1(gf, a1, pos, subr) \ - return (SCM_UNPACK (gf) \ - ? scm_call_generic_1 ((gf), (a1)) \ - : scm_wrong_type_arg ((subr), (pos), (a1)), 0) +#define SCM_WTA_DISPATCH_1(gf, a1, pos, subr) \ + return (SCM_UNPACK (gf) \ + ? scm_call_generic_1 ((gf), (a1)) \ + : (scm_wrong_type_arg ((subr), (pos), (a1)), SCM_UNSPECIFIED)) #define SCM_GASSERT1(cond, gf, a1, pos, subr) \ if (!(cond)) SCM_WTA_DISPATCH_1((gf), (a1), (pos), (subr)) extern SCM scm_call_generic_2 (SCM gf, SCM a1, SCM a2); -#define SCM_WTA_DISPATCH_2(gf, a1, a2, pos, subr) \ - return (SCM_UNPACK (gf) \ - ? scm_call_generic_2 ((gf), (a1), (a2)) \ - : scm_wrong_type_arg ((subr), (pos), \ - (pos) == SCM_ARG1 ? (a1) : (a2)), 0) +#define SCM_WTA_DISPATCH_2(gf, a1, a2, pos, subr) \ + return (SCM_UNPACK (gf) \ + ? scm_call_generic_2 ((gf), (a1), (a2)) \ + : (scm_wrong_type_arg ((subr), (pos), \ + (pos) == SCM_ARG1 ? (a1) : (a2)), \ + SCM_UNSPECIFIED)) #define SCM_GASSERT2(cond, gf, a1, a2, pos, subr) \ if (!(cond)) SCM_WTA_DISPATCH_2((gf), (a1), (a2), (pos), (subr)) extern SCM scm_apply_generic (SCM gf, SCM args); -#define SCM_WTA_DISPATCH_n(gf, args, pos, subr) \ - return (SCM_UNPACK (gf) \ - ? scm_apply_generic ((gf), (args)) \ - : scm_wrong_type_arg ((subr), (pos), \ - scm_list_ref ((args), \ - SCM_MAKINUM ((pos) - 1))), 0) +#define SCM_WTA_DISPATCH_n(gf, args, pos, subr) \ + return (SCM_UNPACK (gf) \ + ? scm_apply_generic ((gf), (args)) \ + : (scm_wrong_type_arg ((subr), (pos), \ + scm_list_ref ((args), \ + SCM_MAKINUM ((pos) - 1))), \ + SCM_UNSPECIFIED)) #define SCM_GASSERTn(cond, gf, args, pos, subr) \ if (!(cond)) SCM_WTA_DISPATCH_n((gf), (args), (pos), (subr)) From 65f7a6501c87bb4454c2146a81d13a57efb8378f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 19 Apr 2001 21:35:44 +0000 Subject: [PATCH 0835/2047] * scheme-control.texi (while do): Added documentation for named let. * scheme-binding.texi (Internal Definitions): New explanation of `Internal Definitions'. (Top Level): Documented behaviour of top level definitions. (Binding Constructs): New introductory text. (Local Bindings): Explain concept of local bindings. Document let, let* and letrec. * scheme-modules.texi (Modules): Added menu descriptions. (Scheme and modules, The Guile module system): Some whitespace cleanup (The Guile module system): Layout fixes, docstring fix for `define-module'. --- doc/ChangeLog | 20 ++++ doc/scheme-binding.texi | 206 ++++++++++++++++++++++++++++++++++++++++ doc/scheme-control.texi | 43 +++++++++ doc/scheme-modules.texi | 28 ++++-- 4 files changed, 290 insertions(+), 7 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index a3e0f1a4a..86a6f39e6 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,23 @@ +2001-04-19 Martin Grabmueller + + * scheme-control.texi (while do): Added documentation for named + let. + + * scheme-binding.texi (Internal Definitions): New explanation of + `Internal Definitions'. + (Top Level): Documented behaviour of top level definitions. + (Binding Constructs): New introductory text. + (Local Bindings): Explain concept of local bindings. Document + let, let* and letrec. + +2001-04-18 Martin Grabmueller + + * scheme-modules.texi (Modules): Added menu descriptions. + (Scheme and modules, The Guile module system): Some whitespace + cleanup + (The Guile module system): Layout fixes, docstring fix for + `define-module'. + 2001-04-17 Martin Grabmueller * scheme-control.texi (Multiple Values): Documented concept of diff --git a/doc/scheme-binding.texi b/doc/scheme-binding.texi index b6bbe7447..94d0587bd 100644 --- a/doc/scheme-binding.texi +++ b/doc/scheme-binding.texi @@ -2,6 +2,13 @@ @node Binding Constructs @chapter Definitions and Variable Bindings +@c FIXME::martin: Review me! + +Scheme supports the definition of variables in different contexts. +Variables can be defined at the top level, so that they are visible in +the entire program, and variables can be defined locally to procedures +and expressions. This is important for modularity and data abstraction. + @menu * Top Level:: Top level variable definitions. * Local Bindings:: Local variable bindings. @@ -13,18 +20,217 @@ @node Top Level @section Top Level Variable Definitions +@c FIXME::martin: Review me! + +@cindex variable definition + +On the top level of a program (e.g. when not inside of a procedure +definition or a @code{let}, @code{let*} or @code{letrec} expression), a +definition of the form + +@lisp +(define a 1) +@end lisp + +@noindent +defines a variable called @var{a} and sets it to the value 1. When the +variable already was bound with a @code{define} expression, the above +form is completely equivalent to + +@lisp +(set! a 1) +@end lisp + +@noindent +that means that @code{define} can be used interchangeably with +@code{set!} when at the top level of the REPL or a Scheme source file. +But note that a @code{set!} is not allowed if the variable was not bound +before. + +Attention: definitions inside local binding constructs (@pxref{Local +Bindings}) act differently (@pxref{Internal Definitions}). + @node Local Bindings @section Local Variable Bindings +@c FIXME::martin: Review me! + +@cindex local bindings +@cindex local variables + +As opposed to definitions at the top level, which are visible in the +whole program (or current module, when Guile modules are used), it is +also possible to define variables which are only visible in a +well--defined part of the program. Normally, this part of a program +will be a procedure or a subexpression of a procedure. + +With the constructs for local binding (@code{let}, @code{let*} and +@code{letrec}), the Scheme language has a block structure like most +other programming languages since the days of @sc{Algol 60}. Readers +familiar to languages like C or Java should already be used to this +concept, but the family of @code{let} expressions has a few properties +which are well worth knowing. + +The first local binding construct is @code{let}. The other constructs +@code{let*} and @code{letrec} are specialized versions for usage wher +using plain @code{let} is a bit inconvenient. + +@deffn syntax let bindings body +@var{bindings} has the form + +@lisp +((@var{variable1} @var{init1}) @dots{}) +@end lisp + +that is zero or more two--element lists of a variable and an arbitrary +expression each. All @var{variable} names must be distinct. + +A @code{let} expression is evaluated as follows. + +@itemize @bullet +@item +All @var{init} expressions are evaluated. + +@item +New storage is allocated for the @var{variables}. + +@item +The values of the @var{init} expressions are stored into the variables. + +@item +The expressions in @var{body} are evaluated in order, and the value of +the last expression is returned as the value of the @code{let} +expression. + +@item +The storage for the @var{variables} is freed. +@end itemize + +The @var{init} expressions are not allowed to refer to any of the +@var{variables}. +@end deffn + +@deffn syntax let* bindings body +Similar to @code{let}, but the variable bindings are performed +sequentially, that means that all @var{init} expression are allowed to +use the variables defined on their left in the binding list. + +A @code{let*} expression can always be expressed with nested @code{let} +expressions. + +@lisp +(let* ((a 1) (b a)) + b) +@equiv{} +(let ((a 1)) + (let ((b a)) + b)) +@end lisp +@end deffn + +@deffn syntax letrec bindings body +Similar to @code{let}, but it is possible to refer to the @var{variable} +from lambda expression created in any of the @var{inits}. That is, +procedures created in the @var{init} expression can recursively refer to +the defined variables. + +@lisp +(letrec ((even? + (lambda (n) + (if (zero? n) + #t + (odd? (- n 1))))) + (odd? + (lambda (n) + (if (zero? n) + #f + (even? (- n 1)))))) + (even? 88)) +@result{} +#t +@end lisp +@end deffn + +There is also an alternative form of the @code{let} form, which is used +for expressing iteration. Because of the use as a looping construct, +this form (the @dfn{named let}) is documented in the section about +iteration (@pxref{while do, Iteration}) @node Internal Definitions @section Internal definitions +@c FIXME::martin: Review me! + +A @code{define} form which appears inside the body of a @code{lambda}, +@code{let}, @code{let*}, @code{letrec} or equivalent expression is +called an @dfn{internal definition}. An internal definition differs +from a top level definition (@pxref{Top Level}), because the definition +is only visible inside the complete body of the enclosing form. Let us +examine the following example. + +@lisp +(let ((frumble "froz")) + (define banana (lambda () (apple 'peach))) + (define apple (lambda (x) x)) + (banana)) +@result{} +peach +@end lisp + +Here the enclosing form is a @code{let}, so the @code{define}s in the +@code{let}--body are internal definitions. Because the scope of the +internal definitions is the @strong{complete} body of the +@code{let}--expression, the @code{lambda}--expression which gets bound +to the variable @code{banana} may refer to the variable @code{apple}, +even thogh it's definition appears lexically @emph{after} the definition +of @code{banana}. This is because a sequence of internal definition +acts as if it were a @code{letrec} expression. + +@lisp +(let () + (define a 1) + (define b 2) + (+ a b)) +@end lisp + +@noindent +is equivalent to + +@lisp +(let () + (letrec ((a 1) (b 2)) + (+ a b))) +@end lisp + +Another noteworthy difference to top level definitions is that within +one group of internal definitions all variable names must be distinct. +That means where on the top level a second define for a given variable +acts like a @code{set!}, an exception is thrown for internal definitions +with duplicate bindings. + +@c FIXME::martin: The following is required by R5RS, but Guile does not +@c signal an error. Document it anyway, saying that Guile is sloppy? + +@c Internal definitions are only allowed at the beginning of the body of an +@c enclosing expression. They may not be mixed with other expressions. + +@c @lisp +@c (let () +@c (define a 1) +@c a +@c (define b 2) +@c b) +@c @end lisp @node Binding Reflection @section Querying variable bindings +Guile provides a procedure for checking wehther a symbol is bound in the +top level environment. If you want to whether a symbol is locally bound +in expression, you can use the @code{bound?} macro from the module +@code{(ice-9 optargs)}, documented in @ref{Optional Arguments}. + @c NJFIXME explain [env] @deffn primitive defined? sym [env] Return @code{#t} if @var{sym} is defined in the top-level environment. diff --git a/doc/scheme-control.texi b/doc/scheme-control.texi index 129a1143d..f5f0191ee 100644 --- a/doc/scheme-control.texi +++ b/doc/scheme-control.texi @@ -174,6 +174,7 @@ If used without expressions, @code{#f} is returned. @cindex iteration @cindex looping +@cindex named let Scheme has only few iteration mechanisms, mainly because iteration in Scheme programs is normally expressed using recursion. Nevertheless, @@ -201,6 +202,48 @@ every iteration, so that the body is not evaluated at all if @var{cond} is @code{#f} right from the start. @end deffn +@cindex named let +Another very common way of expressing iteration in Scheme programs is +the use of the so--called @dfn{named let}. + +Named let is a variant of @code{let} which creates a procedure and calls +it in one step. Because of the newly created procedure, named let is +more powerful than @code{do}---it can be used for iteration, but also +for arbitrary recursion. + +@deffn syntax let variable bindings body +For the definition of @var{bindings} see the documentation about +@code{let} (@pxref{Local Bindings}). + +Named @code{let} works as follows: + +@itemize @bullet +@item +A new procedure which accepts as many arguments as are in @var{bindings} +is created and bound locally (using @code{let}) to @var{variable}. The +new procedure's formal argument names are the name of the +@var{variables}. + +@item +The @var{body} expressions are inserted into the newly created procedure. + +@item +The procedure is called with the @var{init} expressions as the formal +arguments. +@end itemize + +The next example implements a loop which iterates (by recursion) 1000 +times. + +@lisp +(let lp ((x 1000)) + (if (positive? x) + (lp (- x 1)) + x)) +@result{} +0 +@end lisp +@end deffn @node Continuations @section Continuations diff --git a/doc/scheme-modules.texi b/doc/scheme-modules.texi index a02229bfb..1cdc6445c 100644 --- a/doc/scheme-modules.texi +++ b/doc/scheme-modules.texi @@ -36,8 +36,8 @@ clutter the global name space. @cindex name space - private @menu -* Scheme and modules:: -* The Guile module system:: +* Scheme and modules:: How modules are handled in standard Scheme. +* The Guile module system:: How Guile does it. * Dynamic Libraries:: Loading libraries of compiled code at run time. * Dynamic Linking from Marius:: @end menu @@ -55,13 +55,17 @@ Library files in SLIB @emph{provide} a feature, and when user programs For example, the file @file{random.scm} in the SLIB package contains the line + @smalllisp (provide 'random) @end smalllisp + so to use its procedures, a user would type + @smalllisp (require 'random) @end smalllisp + and they would magically become available, @emph{but still have the same names!} So this method is nice, but not as good as a full-featured module system. @@ -84,13 +88,17 @@ is called @code{ice-9}. So for example, the SLIB interface, contained in @file{$srcdir/ice-9/slib.scm}, starts out with + @smalllisp (define-module (ice-9 slib)) @end smalllisp + and a user program can use + @smalllisp (use-modules (ice-9 slib)) @end smalllisp + to have access to all procedures and variables defined within the slib module with @code{(define-public ...)}. @@ -99,11 +107,13 @@ So here are the functions involved: @deffn syntax define-module module-specification @var{module-specification} is of the form @code{(hierarchy file)}. One example of this is + @smalllisp -(use-modules (ice-9 slib)) +(define-module (ice-9 slib)) @end smalllisp -define-module makes this module available to Guile programs under the -given @var{module-specification}. + +@code{define-module} makes this module available to Guile programs under +the given @var{module-specification}. @end deffn @c end @@ -118,11 +128,13 @@ module. @deffn syntax use-modules module-specification @var{module-specification} is of the form @code{(hierarchy file)}. One example of this is + @smalllisp (use-modules (ice-9 slib)) @end smalllisp -use-modules allows the current Guile program to use all publicly defined -procedures and variables in the module denoted by + +@code{use-modules} allows the current Guile program to use all publicly +defined procedures and variables in the module denoted by @var{module-specification}. @end deffn @c end @@ -150,6 +162,8 @@ Guile's support for multi threaded execution (@pxref{Scheduling}). @item (ice-9 slib) This module contains hooks for using Aubrey Jaffer's portable Scheme library SLIB from Guile (@pxref{SLIB}). +@c FIXME::martin: This module is not in the distribution. Remove it +@c from here? @item (ice-9 jacal) This module contains hooks for using Aubrey Jaffer's symbolic math packge Jacal from Guile (@pxref{JACAL}). From a9d861e3b225485cca2c30b1e5e7e041357b9b24 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Thu, 19 Apr 2001 22:10:29 +0000 Subject: [PATCH 0836/2047] * unif.h (SCM_ARRAY_CONTIGUOUS): Reintroduced as deprecated. * RELEASE: Added deprecated macro SCM_ARRAY_CONTIGUOUS --- ChangeLog | 4 ++++ RELEASE | 3 ++- libguile/ChangeLog | 2 ++ libguile/unif.h | 4 ++++ 4 files changed, 12 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 87d18fe0d..5e239740b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2001-04-19 Mikael Djurfeldt + + * RELEASE: Added deprecated macro SCM_ARRAY_CONTIGUOUS + 2001-04-17 Gary Houston * configure.in: run the autoconf BIGENDIAN check. diff --git a/RELEASE b/RELEASE index 16c772614..d49ea0942 100644 --- a/RELEASE +++ b/RELEASE @@ -69,7 +69,8 @@ In release 1.6: SCM_SUBR_DOC, SCM_OPDIRP, SCM_VALIDATE_OPDIR, SCM_WTA, RETURN_SCM_WTA, SCM_WNA, SCM_FUNC_NAME, SCM_VALIDATE_NUMBER_COPY, SCM_VALIDATE_NUMBER_DEF_COPY, SCM_SLOPPY_CONSP, SCM_SLOPPY_NCONSP, - SCM_SETAND_CDR, SCM_SETOR_CDR, SCM_SETAND_CAR, SCM_SETOR_CAR + SCM_SETAND_CDR, SCM_SETOR_CDR, SCM_SETAND_CAR, SCM_SETOR_CAR, + SCM_ARRAY_CONTIGUOUS - remove scm_vector_set_length_x - remove function scm_call_catching_errors (replaced by catch functions from throw.[ch]) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 62a0ad945..9969207e6 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,7 @@ 2001-04-19 Mikael Djurfeldt + * unif.h (SCM_ARRAY_CONTIGUOUS): Reintroduced as deprecated. + * __scm.h (SCM_WTA_DISPATCH_0, SCM_WTA_DISPATCH_1, SCM_WTA_DISPATCH_2, SCM_WTA_DISPATCH_n): Inserted required parentheses in order to get the correct associativity. diff --git a/libguile/unif.h b/libguile/unif.h index bddffa1ed..6cd376eda 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -78,6 +78,10 @@ extern scm_bits_t scm_tc16_array; #define SCM_ARRAY_FLAG_CONTIGUOUS (1 << 16) +#if (SCM_DEBUG_DEPRECATED == 0) +#define SCM_ARRAY_CONTIGUOUS SCM_ARRAY_FLAG_CONTIGUOUS +#endif + #define SCM_ARRAYP(a) SCM_TYP16_PREDICATE (scm_tc16_array, a) #define SCM_ARRAY_NDIM(x) ((scm_sizet) (SCM_CELL_WORD_0 (x) >> 17)) #define SCM_ARRAY_CONTP(x) (SCM_CELL_WORD_0 (x) & SCM_ARRAY_FLAG_CONTIGUOUS) From 454a8a8fffcfd86aaf0178e933403cf066449311 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 20 Apr 2001 02:19:36 +0000 Subject: [PATCH 0837/2047] * receive.scm (receive): Use `define-macro'. --- ice-9/ChangeLog | 4 ++++ ice-9/receive.scm | 8 +++----- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 48333bd72..e098ab4a5 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2001-04-19 Keisuke Nishida + + * receive.scm (receive): Use `define-macro'. + 2001-04-15 Keisuke Nishida * boot-9.scm (load-compiled): New variable, initialized in the VM. diff --git a/ice-9/receive.scm b/ice-9/receive.scm index 148db2821..982c9595e 100644 --- a/ice-9/receive.scm +++ b/ice-9/receive.scm @@ -22,8 +22,6 @@ :no-backtrace ) -(define receive - (procedure->memoizing-macro - (lambda (exp env) - `(call-with-values (lambda () ,(caddr exp)) - (lambda ,(cadr exp) ,@(cdddr exp)))))) +(define-macro (receive vars vals . body) + `(call-with-values (lambda () ,vals) + (lambda ,vars ,@body))) From 2da0d971ebb98eaf97581e5b5a608e3bb14c0e97 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 20 Apr 2001 07:31:25 +0000 Subject: [PATCH 0838/2047] * intro.texi (Using Guile Modules): Wrote intro to using modules. (Writing New Modules): New intro for writing modules. (Reporting Bugs): Added info about what is a bug and what to include in a bug report (taken and adapted from the Emacs Reference Manual). --- doc/ChangeLog | 8 ++ doc/intro.texi | 260 ++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 263 insertions(+), 5 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 86a6f39e6..a32c9ad2a 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,11 @@ +2001-04-20 Martin Grabmueller + + * intro.texi (Using Guile Modules): Wrote intro to using modules. + (Writing New Modules): New intro for writing modules. + (Reporting Bugs): Added info about what is a bug and what to + include in a bug report (taken and adapted from the Emacs + Reference Manual). + 2001-04-19 Martin Grabmueller * scheme-control.texi (while do): Added documentation for named diff --git a/doc/intro.texi b/doc/intro.texi index 2d60ef59d..909c3bd52 100644 --- a/doc/intro.texi +++ b/doc/intro.texi @@ -1,4 +1,4 @@ -@c $Id: intro.texi,v 1.5 2001-03-30 16:37:51 ossau Exp $ +@c $Id: intro.texi,v 1.6 2001-04-20 07:31:25 mgrabmue Exp $ @page @node What is Guile? @@ -708,12 +708,100 @@ provide reasonable backwards compatability.) @node Using Guile Modules @subsection Using Existing Modules -To be written. +@c FIXME::martin: Review me! + +@c FIXME::martin: More? Or leave the rest to the module chapter? + +Guile comes with a lot of useful modules, for example for string +processing or command line parsing. Additionally, there exist many +Guile modules written by other Guile hackers, but which have to be +installed manually. + +Existing modules have to be placed in places where Guile looks for them +by default or in directories in the environment variable +@code{GUILE_LOAD_PATH}. + +Suppose you want to use the procedures and variables exported by the +module @code{(ice-9 popen)}, which provides the means for communicating +with other processes over pipes. Add the following line to your +currently running Guile REPL or the top of you script file. + +@lisp +(use-modules (ice-9 popen)) +@end lisp + +This will load the module and make the procedures exported by +@code{(ice-9 popen)} automatically available. The next step could be to +open a pipe to @file{ls} and read the contents of the current directory, +one line at a time. + +@lisp +(define p (open-input-pipe "ls -l")) +(read-line p) +@result{} +"total 30" +(read-line p) +@result{} +"drwxr-sr-x 2 mgrabmue mgrabmue 1024 Mar 29 19:57 CVS" +@end lisp + +More details of module usage can be found in (REFFIXME). + @node Writing New Modules @subsection Writing New Modules -To be written. +Of course it is possible to write modules yourself. Using modules for +structuring your programs makes them more readable and lets you +distribute them more easily. Also, explicitly defining the procedures +and variables which are exported from a module adds documentation to the +source and specifies the interface a module provides. + +In Guile, you can create new modules and switch to exisiting modules in +order to add bindings to them using the syntactic form +@code{define-module}. + +@lisp +(define-module (foo bar)) + +(define (frob x) x) +@end lisp + +Will create the module @code{(foo bar)}.@footnote{It is only convention +that the module names in this section have two elements. One or more +than two elements are perfectly fine, such as @code{(foo)} or @code{(foo +bar braz)}} All definitions following this statement will add bindings +to the module @code{(foo bar)}, and these bindings will not be visible +outside of the module. To make the bindings accessible to other +modules, you have to export them explicitly using one of the following +means: + +@itemize @bullet +@item +Export them with the @code{export} form: +@lisp +(export frob) +@end lisp + +@item +Include them into the @code{define-module} form with the keyword +@code{export}: +@lisp +(define-module (foo bar) + #:export (frob)) +@end lisp + +@item +Change the definition of @code{frob} to use @code{define-public}, which +is a combination of @code{define} and @code{export}. +@lisp +(define-public (frob x) x) +@end lisp +@end itemize + +After exporting, other modules can access the exported items simply by +using @code{use-modules} to load the module @code{(foo bar)}. + @node Modules and Extensions @subsection Modules and Extensions @@ -743,11 +831,173 @@ for example as @file{/usr/local/share/guile/math/bessel.scm}. @node Reporting Bugs @chapter Reporting Bugs +@c FIXME::martin: Review me! + +@c FIXME::martin: A lot of this was taken from the Emacs reference +@c manual and adapted. I guess that is okay? + Any problems with the installation should be reported to @email{bug-guile@@gnu.org}. -[[how about an explanation of what makes a good bug report?]] -[[don't complain to us about problems with contributed modules?]] +Whenever you have found a bug in Guile you are encouraged to report it +to the Guile developers, so they can fix it. They may probably have +also advice what to do to work around a bug when it is not possible for +you to apply the bugfix or install a new version of Guile yourself. + +Before sending in bug reports, please check with the following list that +you really have found a bug. + +@itemize @bullet +@item +Whenever documentation and actual behaviour differ, you have certainly +found a bug, either in the documentation or in the program. + +@item +When Guile crashes, it is a bug. + +@item +When Guile hangs or takes forever to complete a task, it is a bug. + +@item +When calculations produce wrong results, it is a bug. + +@item +When Guile signals an error for valid Scheme programs, it is a bug. + +@item +@c FIXME::martin: Too strict? +When Guile does not signal an error for invalid Scheme programs, it may +be a bug, unless this is explicitly documented. + +@item +When some part of the documentation is not clear and does not make sense +to you even after re--reading the section, it is a bug. +@end itemize + +When you write a bug report, please make sure to include as much of the +information described below in the report. If you can't figure out some +of the items, it is not a problem, but the more information we get, the +better are chances we can diagnose and fix the bug. + +@itemize @bullet +@item +The version number of Guile. Without this, we won't know whether there +is any point in looking for the bug in the current version of Guile. + +You can get the version number by invoking the command + +@example +$ guile --version +Guile 1.4.1 +Copyright (c) 1995, 1996, 1997, 2000 Free Software Foundation +Guile may be distributed under the terms of the GNU General Public Licence; +certain other uses are permitted as well. For details, see the file +`COPYING', which is included in the Guile distribution. +There is no warranty, to the extent permitted by law. +@end example + +@item +The type of machine you are using, and the operating system name and +version number. On GNU systems, you can get it with @file{uname}. + +@example +$ uname -a +Linux tortoise 2.2.17 #1 Thu Dec 21 17:29:05 CET 2000 i586 unknown +@end example + +@item +The operands given to the @file{configure} command when Guile was +installed. + +@item +A complete list of any modifications you have made to the Guile source. +(We may not have time to investigate the bug unless it happens in an +unmodified Guile. But if you've made modifications and you don't tell +us, you are sending us on a wild goose chase.) + +Be precise about these changes. A description in English is not +enough--send a context diff for them. + +Adding files of your own, or porting to another machine, is a +modification of the source. + +@item +Details of any other deviations from the standard procedure for +installing Guile. + +@item +The complete text of any source files needed to reproduce the bug. + +If you can tell us a way to cause the problem without loading any source +files, please do so. This makes it much easier to debug. If you do +need files, make sure you arrange for us to see their exact contents. + +@item +The precise Guile invocation command line we need to type to reproduce +the bug. + +@item +A description of what behavior you observe that you believe is +incorrect. For example, "The Guile process gets a fatal signal," or, +"The resulting output is as follows, which I think is wrong." + +Of course, if the bug is that Guile gets a fatal signal, then one can't +miss it. But if the bug is incorrect results, the maintainer might fail +to notice what is wrong. Why leave it to chance? + +If the manifestation of the bug is an Guile error message, it is +important to report the precise text of the error message, and a +backtrace showing how the Scheme program arrived at the error. + +This can be done using the procedure @code{backtrace} in the REPL. + +@item +Check whether any programs you have loaded into Guile, including your +`.guile' file, set any variables that may affect the functioning of +Guile. Also, see whether the problem happens in a freshly started Guile +without loading your `.guile file (start Guile with the `-q' switch to +prevent loading the init file). If the problem does _not_ occur then, +you must report the precise contents of any programs that you must load +into Guile in order to cause the problem to occur. + +@item +If the problem does depend on an init file or other Lisp programs that +are not part of the standard Guile distribution, then you should make +sure it is not a bug in those programs by complaining to their +maintainers first. After they verify that they are using Guile in a way +that is supposed to work, they should report the bug. + +@item +If you wish to mention something in the Guile source, show the line of +code with a few lines of context. Don't just give a line number. + +The line numbers in the development sources don't match those in your +sources. It would take extra work for the maintainers to determine what +code is in your version at a given line number, and we could not be +certain. + +@item +Additional information from a C debugger such as GDB might enable +someone to find a problem on a machine which he does not have available. +If you don't know how to use GDB, please read the GDB manual--it is not +very long, and using GDB is easy. You can find the GDB distribution, +including the GDB manual in online form, in most of the same places you +can find the Guile distribution. To run Guile under GDB, you should +switch to the `libguile' subdirectory in which Guile was compiled, then +do `gdb guile'. + +However, you need to think when you collect the additional information +if you want it to show what causes the bug. + +For example, many people send just a backtrace, but that is not very +useful by itself. A simple backtrace with arguments often conveys +little about what is happening inside Guile, because most of the +arguments listed in the backtrace are pointers to Scheme objects. The +numeric values of these pointers have no significance whatever; all that +matters is the contents of the objects they point to (and most of the +contents are themselves pointers). +@end itemize + @c Local Variables: From 1a55163887591648e6a31bf8f2cef7619e192171 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 20 Apr 2001 07:55:19 +0000 Subject: [PATCH 0839/2047] * Removed an application of SCM_C[AD]R to non pairs. --- libguile/ChangeLog | 5 +++++ libguile/struct.c | 8 ++++---- 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 9969207e6..4540aedd5 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-04-20 Dirk Herrmann + + * struct.c (scm_free_structs): Only pairs may be accessed with + SCM_C[AD]R. + 2001-04-19 Mikael Djurfeldt * unif.h (SCM_ARRAY_CONTIGUOUS): Reintroduced as deprecated. diff --git a/libguile/struct.c b/libguile/struct.c index d972ba526..3262ef968 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -377,7 +377,7 @@ scm_free_structs (void *dummy1, void *dummy2, void *dummy3) { /* Mark vtables in GC chain. GC mark set means delay freeing. */ SCM chain = newchain; - while (SCM_NNULLP (chain)) + while (!SCM_NULLP (chain)) { SCM vtable = SCM_STRUCT_VTABLE (chain); if (SCM_STRUCT_GC_CHAIN (vtable) != 0 && vtable != chain) @@ -387,7 +387,7 @@ scm_free_structs (void *dummy1, void *dummy2, void *dummy3) /* Free unmarked structs. */ chain = newchain; newchain = SCM_EOL; - while (SCM_NNULLP (chain)) + while (!SCM_NULLP (chain)) { SCM obj = chain; chain = SCM_STRUCT_GC_CHAIN (chain); @@ -402,7 +402,7 @@ scm_free_structs (void *dummy1, void *dummy2, void *dummy3) scm_bits_t word0 = SCM_CELL_WORD_0 (obj) - scm_tc3_cons_gloc; /* access as struct */ scm_bits_t * vtable_data = (scm_bits_t *) word0; - scm_bits_t * data = (scm_bits_t *) SCM_UNPACK (SCM_CDR (obj)); + scm_bits_t * data = SCM_STRUCT_DATA (obj); scm_struct_free_t free_struct_data = ((scm_struct_free_t) vtable_data[scm_struct_i_free]); SCM_SET_CELL_TYPE (obj, scm_tc_free_cell); @@ -410,7 +410,7 @@ scm_free_structs (void *dummy1, void *dummy2, void *dummy3) } } } - while (SCM_NNULLP (newchain)); + while (!SCM_NULLP (newchain)); return 0; } From a26fb67d8357a4c39738a6d2565afa6b1d8871f5 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 20 Apr 2001 11:20:06 +0000 Subject: [PATCH 0840/2047] * Added recipe-guidelines.txt. --- doc/ChangeLog | 5 +++ doc/recipe-guidelines.txt | 80 +++++++++++++++++++++++++++++++++++++++ 2 files changed, 85 insertions(+) create mode 100644 doc/recipe-guidelines.txt diff --git a/doc/ChangeLog b/doc/ChangeLog index a32c9ad2a..c2cecee39 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,8 @@ +2001-04-20 Neil Jerram + + * recipe-guidelines.txt: New file: guidelines for contributions to + the Guile Recipes manual. + 2001-04-20 Martin Grabmueller * intro.texi (Using Guile Modules): Wrote intro to using modules. diff --git a/doc/recipe-guidelines.txt b/doc/recipe-guidelines.txt new file mode 100644 index 000000000..adf8d5c7d --- /dev/null +++ b/doc/recipe-guidelines.txt @@ -0,0 +1,80 @@ + -*-text-*- + +Guidelines for contributions to the Guile Recipes manual +-------------------------------------------------------- + +1. Licensing + +Contributions must be licensed under the GNU Free Documentation +License (GFDL) or the GNU General Public License (GPL). + +2. Copyright + +Contributors are encouraged, but not required, to assign the copyright +for their contribution to the FSF. `not required' also covers the +case where a contributor has every intention of assigning copyright, +but the process is simply taking a little time. Note that: + +- If you assign your copyright, other people (who have also assigned + copyright) can make non-trivial enhancements to your contribution + without any difficulties arising. If you don't assign copyright for + contribution, it complicates the ownership picture if other people + make non-trivial changes to it; and if the burden of tracking + copyright ownership becomes too great, it will be easier simply to + remove that contribution from the manual. + +- If it transpires that non-assigned copyrights turn out to be a bad + thing (for whatever reason), the maintainers reserve the right to + remove non-assigned contributions from the manual. + +3. Manual organization + +Each contribution has its own chapter and lives in its own Texinfo +file. Chapters in related areas may be grouped together, but maybe +not. Instead, the introduction to the manual will contain references +to chapters, and the introductory text will group those references +appropriately. + +4. Copyright ownership + +Given this organization, ownership for copyright purposes is +straightforward. Each Texinfo file is either owned by its +contributor, or assigned to the FSF. + +Every contribution's chapter should begin with a statement of who +contributed it, who owns the copyright, and its license (GFDL or +GPL). These statements should appear in the printed and online +documentation -- i.e. they are _not_ comments. + +5. Documentation vs. code + +Contributed material should be informative and helpful, and should fit +in with the manual syntax. In general, this means that a +straightforward lump of code is _not_ good enough -- it also needs the +statements mentioned above, introduction, explanation or +documentation, Texinfo markup, etc. + +Note that the maintainers may be able to accept a contribution that +requires substantial extra work if copyright for that contribution has +been assigned to the FSF. Where copyright has not been assigned, the +contribution has to be already finished by its author. + +6. Good indexing + +In practice, the manual index will be a very important tool for +someone looking for an example that is useful to them. So please give +some thought to good indexing in your contribution. + +7. Submissions + +To submit material for inclusion in Guile Recipes, please send your +contribution to the guile-sources mailing list +. + +As far as past material is concerned, I do have an archive of material +that I will ask people about including individually, but it would make +things easier for me if people resubmitted past material to +guile-sources anyway. + +-- +Neil Jerram April 20th 2001 From ffda60939e37a76f2804fcd818a4b927748c77b4 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 20 Apr 2001 13:26:55 +0000 Subject: [PATCH 0841/2047] Doc fixes --- doc/ChangeLog | 7 +++++++ doc/data-rep.texi | 15 ++++++++------- doc/gh.texi | 4 ++-- 3 files changed, 17 insertions(+), 9 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index c2cecee39..2d662f6a2 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,5 +1,12 @@ 2001-04-20 Neil Jerram + * gh.texi (Executing Scheme code): gh_eval_file returns + SCM_UNSPECIFIED. Thanks to Dirk for the report! + + * data-rep.texi (Non-immediate Datatypes, Immediates vs + Non-immediates): Emphasize current rather than pre-1.4 practice + when talking about not needing to call SCM_NIMP. + * recipe-guidelines.txt: New file: guidelines for contributions to the Guile Recipes manual. diff --git a/doc/data-rep.texi b/doc/data-rep.texi index f758df3f8..83edcb87c 100644 --- a/doc/data-rep.texi +++ b/doc/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.21 2001-04-16 09:38:32 ossau Exp $ +@c essay @subtitle $Id: data-rep.texi,v 1.22 2001-04-20 13:26:55 ossau Exp $ @c essay @subtitle For use with Guile @value{VERSION} @c essay @author Jim Blandy @c essay @author Free Software Foundation @@ -577,11 +577,12 @@ Return non-zero iff @var{x} is a non-immediate object. This is the exact complement of @code{SCM_IMP}, above. @end deftypefn -Note that, as of Guile 1.4, it is no longer necessary to use the +Note that for versions of Guile prior to 1.4 it was necessary to use the @code{SCM_NIMP} macro before calling a finer-grained predicate to determine @var{x}'s type, such as @code{SCM_CONSP} or -@code{SCM_VECTORP}. The definitions of all Guile type predicates -now include a call to @code{SCM_NIMP} where necessary. +@code{SCM_VECTORP}. This is no longer required: the definitions of all +Guile type predicates now include a call to @code{SCM_NIMP} where +necessary. @node Immediate Datatypes @@ -750,9 +751,9 @@ non-immediate --- in other words stored in a heap cell. The tag stored in the first word of the heap cell indicates more precisely the type of that object. -As of Guile 1.4, the type predicates for non-immediate values work -correctly on any @code{SCM} value; you do not need to call -@code{SCM_NIMP} first, to establish that a value is non-immediate. +The type predicates for non-immediate values work correctly on any +@code{SCM} value; you do not need to call @code{SCM_NIMP} first, to +establish that a value is non-immediate. @menu * Pair Data:: diff --git a/doc/gh.texi b/doc/gh.texi index 691fd5515..106ed057a 100644 --- a/doc/gh.texi +++ b/doc/gh.texi @@ -244,8 +244,8 @@ parentheses, you must either concatenate them into one string, or use @deftypefun SCM gh_eval_file (char *@var{fname}) @deftypefunx SCM gh_load (char *@var{fname}) @code{gh_eval_file} is completely analogous to @code{gh_eval_str()}, -except that a whole file is evaluated instead of a string. Returns the -result of the last expression evaluated. +except that a whole file is evaluated instead of a string. +@code{gh_eval_file} returns @code{SCM_UNSPECIFIED}. @code{gh_load} is identical to @code{gh_eval_file} (it's a macro that calls @code{gh_eval_file} on its argument). It is provided to start From ee7565342629dbfc8920fdc19579c9193c9fb352 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 20 Apr 2001 14:43:30 +0000 Subject: [PATCH 0842/2047] * scheme-evaluation.texi (Comments): Document normal comments and comment conventions. (Block Comments): Documented multiline comments. (Case Sensitivity): Documented R5RS and Guile behaviour and how to switch it off. * scheme-control.texi (Continuations): Added some documentation for call/cc. (Exceptions): Added xref to `Continuations'. * scheme-binding.texi (Binding Reflection): Typo fix. --- doc/ChangeLog | 14 ++++++++ doc/scheme-binding.texi | 4 +-- doc/scheme-control.texi | 54 ++++++++++++++++++++++++++--- doc/scheme-evaluation.texi | 70 ++++++++++++++++++++++++++++++++++++++ 4 files changed, 136 insertions(+), 6 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 2d662f6a2..f9493d38c 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,17 @@ +2001-04-20 Martin Grabmueller + + * scheme-evaluation.texi (Comments): Document normal comments and + comment conventions. + (Block Comments): Documented multiline comments. + (Case Sensitivity): Documented R5RS and Guile behaviour and how to + switch it off. + + * scheme-control.texi (Continuations): Added some documentation + for call/cc. + (Exceptions): Added xref to `Continuations'. + + * scheme-binding.texi (Binding Reflection): Typo fix. + 2001-04-20 Neil Jerram * gh.texi (Executing Scheme code): gh_eval_file returns diff --git a/doc/scheme-binding.texi b/doc/scheme-binding.texi index 94d0587bd..fe51067d9 100644 --- a/doc/scheme-binding.texi +++ b/doc/scheme-binding.texi @@ -227,8 +227,8 @@ with duplicate bindings. @section Querying variable bindings Guile provides a procedure for checking wehther a symbol is bound in the -top level environment. If you want to whether a symbol is locally bound -in expression, you can use the @code{bound?} macro from the module +top level environment. If you want to test whether a symbol is locally +bound in expression, you can use the @code{bound?} macro from the module @code{(ice-9 optargs)}, documented in @ref{Optional Arguments}. @c NJFIXME explain [env] diff --git a/doc/scheme-control.texi b/doc/scheme-control.texi index f5f0191ee..ae7f01edf 100644 --- a/doc/scheme-control.texi +++ b/doc/scheme-control.texi @@ -245,14 +245,60 @@ times. @end lisp @end deffn + @node Continuations @section Continuations +@c FIXME::martin: Review me! + +@cindex call/cc +The possibility to explicitly capture continuation and the use of +@code{call-with-current-continuation} (also often called @code{call/cc} +for shortness) is maybe the most powerful control structure known. All +other control structures like loops or coroutines can be emulated using +continuation. + +@c FIXME::martin: Is this too much of understatement, maybe confusing? +@c I'm not sure. +The implementation of continuations in Guile is not as efficient as one +might except, because it is constrained by the fact that Guile is +required to be cooperative to programs written in other languages, such +as C which do not know about continuations. So continuations should be +used when there is no other possibility to get the needed effect. If +you find yourself using @code{call/cc} for escape procedures and your +program is running to slow, you might want to use exceptions (REFFIXME) +instead. + @rnindex call-with-current-continuation -@c FIXME::martin: Document me! -@deffn primitive call-with-current-continuation +@deffn primitive call-with-current-continuation proc +Capture the current continuation and call @var{proc} with the captured +continuation as the single argument. This continuation can then be +called with arbitrarily many arguments. Such a call will work like a +goto to the invocation location of +@code{call-with-current-continuation}, passing the arguments in a way +that they are returned by the call to +@code{call-with-current-continuation}. Since it is legal to store the +captured continuation in a variable or to pass it to other procedures, +it is possible that a procedure returns more than once, even if it is +called only one time. This can be confusing at times. @end deffn +@c FIXME::martin: Better example needed. +@lisp +(define kont #f) +(call-with-current-continuation + (lambda (k) + (set! kont k) + 1)) +@result{} +1 + +(kont 2) +@result{} +2 +@end lisp + + @node Multiple Values @section Returning and Accepting Multiple Values @@ -327,8 +373,8 @@ the expressions in @var{body} @dots{} are evaluated in order. @cindex exception handling It is traditional in Scheme to implement exception systems using -@code{call-with-current-continuation}. Guile does not do this, for -performance reasons. The implementation of +@code{call-with-current-continuation} (@pxref{Continuations}). Guile +does not do this, for performance reasons. The implementation of @code{call-with-current-continuation} is a stack copying implementation. This allows it to interact well with ordinary C code. Unfortunately, a stack-copying implementation can be slow -- creating a new continuation diff --git a/doc/scheme-evaluation.texi b/doc/scheme-evaluation.texi index 55079d5a2..975787909 100644 --- a/doc/scheme-evaluation.texi +++ b/doc/scheme-evaluation.texi @@ -36,14 +36,84 @@ loading and evaluating Scheme code at run time. @node Comments @subsection Comments +@c FIXME::martin: Review me! + +Comments in Scheme source files are written by starting them with a +semicolon character (@code{;}). The comment then reaches up to the end +of the line. Comments can begin at any column, and the may be inserted +on the same line as Scheme code. + +@lisp +; Comment +;; Comment too +(define x 1) ; Comment after expression +(let ((y 1)) + ;; Display something. + (display y) +;;; Comment at left margin. + (display (+ y 1))) +@end lisp + +It is common to use a single semicolon for comments following +expressions on a line, to use two semicolons for comments which are +indented like code, and three semicolons for comments which start at +column 0, even if they are inside an indented code block. This +convention is used when indenting code in Emacs' Scheme mode. + @node Block Comments @subsection Block Comments +@c FIXME::martin: Review me! + +@cindex multiline comments +In addition to the standard line comments defined by R5RS, Guile has +another comment type for multiline comments, called @dfn{block +comments}. This type of comment begins with the character sequence +@code{#!} and ends with the characters @code{!#}, which must appear on a +line of their own. These comments are compatible with the block +comments in the Scheme Shell @file{scsh} (REFFIXME). The characters +@code{#!} were chosen because they are the magic characters used in +shell scripts for indicating that the name of the program for executing +the script follows on the same line. + +Thus a Guile script often starts like this. + +@lisp +#! /usr/local/bin/guile -s +!# +@end lisp + +More details on Guile scripting can be found in the scripting section +(REFFIXME). + @node Case Sensitivity @subsection Case Sensitivity +@c FIXME::martin: Review me! + +Scheme as defined in R5RS is not case sensitive when reading symbols. +Guile, on the contrary is case sensitive by default, so the identifiers + +@lisp +guile-whuzzy +Guile-Whuzzy +@end lisp + +are the same in R5RS Scheme, but are different in Guile. + +It is possible to turn off case sensitivity in Guile by setting the +reader option @code{case-insensitive}. More on reader options can be +found at (REFFIXME). + +@lisp +(read-enable 'case-insensitive) +@end lisp + +Note that this is seldom a problem, because Scheme programmers tend not +to use uppercase letters in their identifiers anyway. + @node Keyword Syntax @subsection Keyword Syntax From 0447f5c91892000eb991f127e45852834b94ae09 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 20 Apr 2001 15:59:30 +0000 Subject: [PATCH 0843/2047] * Improve doc for exceptions. --- doc/ChangeLog | 5 +++ doc/scheme-control.texi | 92 +++++++++++++++++++++++++++++++++++------ 2 files changed, 85 insertions(+), 12 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index f9493d38c..15ef0b9ad 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,8 @@ +2001-04-20 Neil Jerram + + * scheme-control.texi (Exceptions): Reorganized and extended + existing documentation; more to come. + 2001-04-20 Martin Grabmueller * scheme-evaluation.texi (Comments): Document normal comments and diff --git a/doc/scheme-control.texi b/doc/scheme-control.texi index ae7f01edf..4d4dbcf3c 100644 --- a/doc/scheme-control.texi +++ b/doc/scheme-control.texi @@ -372,17 +372,47 @@ the expressions in @var{body} @dots{} are evaluated in order. @cindex error handling @cindex exception handling -It is traditional in Scheme to implement exception systems using -@code{call-with-current-continuation} (@pxref{Continuations}). Guile -does not do this, for performance reasons. The implementation of -@code{call-with-current-continuation} is a stack copying implementation. -This allows it to interact well with ordinary C code. Unfortunately, a -stack-copying implementation can be slow -- creating a new continuation -involves a block copy of the stack. +A common requirement in applications is to want to jump +@dfn{non-locally} from the depths of a computation back to, say, the +application's main processing loop. Usually, the place that is the +target of the jump is somewhere in the calling stack of procedures that +called the procedure that wants to jump back. For example, typical +logic for a key press driven application might look something like this: -Instead of using @code{call-with-current-continuation}, the exception -primitives documented here are implemented as built-ins that take -advantage of the @emph{upward only} nature of exceptions. +@example +main-loop: + read the next key press and call dispatch-key + +dispatch-key: + lookup the key in a keymap and call an appropriate procedure, + say find-file + +find-file: + interactively read the required file name, then call + find-specified-file + +find-specified-file: + check whether file exists; if not, jump back to main-loop + @dots{} +@end example + +The jump back to @code{main-loop} could be achieved by returning through +the stack one procedure at a time, using the return value of each +procedure to indicate the error condition, but Guile (like most modern +programming languages) provides an additional mechanism called +@dfn{exception handling} that can be used to implement such jumps much +more conveniently. + +@menu +* Catch and Throw:: Basic exception handling primitives. +* Lazy Catch:: Catch without unwinding. +* Stack Catch:: Capturing the stack at a throw. +* Exception Implementation:: How Guile implements exceptions. +@end menu + + +@node Catch and Throw +@subsection Basic Exception Handling Primitives @deffn primitive catch key thunk handler Invoke @var{thunk} in the dynamic context of @var{handler} for @@ -411,6 +441,10 @@ Invoke the catch form matching @var{key}, passing @var{args} to the If there is no handler at all, an error is signaled. @end deffn + +@node Lazy Catch +@subsection Catch Without Unwinding + @deffn primitive lazy-catch key thunk handler This behaves exactly like @code{catch}, except that it does not unwind the stack (this is the major difference), and if @@ -418,6 +452,42 @@ handler returns, its value is returned from the throw. @end deffn +@node Stack Catch +@subsection Capturing the Stack at a Throw + + +@node Exception Implementation +@subsection How Guile Implements Exceptions + +It is traditional in Scheme to implement exception systems using +@code{call-with-current-continuation}. Continuations +(@pxref{Continuations}) are such a powerful concept that any other +control mechanism --- including @code{catch} and @code{throw} --- can be +implemented in terms of them. + +Guile does not implement @code{catch} and @code{throw} like this, +though. Why not? Because Guile is specifically designed to be easy to +integrate with applications written in C. In a mixed Scheme/C +environment, the concept of @dfn{continuation} must logically include +``what happens next'' in the C parts of the application as well as the +Scheme parts, and it turns out that the only reasonable way of +implementing continuations like this is to save and restore the complete +C stack. + +So Guile's implementation of @code{call-with-current-continuation} is a +stack copying one. This allows it to interact well with ordinary C +code, but means that creating and calling a continuation is slowed down +by the time that it takes to copy the C stack. + +The more targeted mechanism provided by @code{catch} and @code{throw} +does not need to save and restore the C stack because the @code{throw} +always jumps to a location higher up the stack of the code that executes +the @code{throw}. Therefore Guile implements the @code{catch} and +@code{throw} primitives independently of +@code{call-with-current-continuation}, in a way that takes advantage of +this @emph{upwards only} nature of exceptions. + + @node Error Reporting @section Procedures for Signaling Errors @@ -425,12 +495,10 @@ Guile provides a set of convenience procedures for signaling error conditions that are implemented on top of the exception primitives just described. -@c begin (scm-doc-string "boot-9.scm" "error") @deffn procedure error msg args @dots{} Raise an error with key @code{misc-error} and a message constructed by displaying @var{msg} and writing @var{args}. @end deffn -@c end @deffn primitive scm-error key subr message args data Raise an error with key @var{key}. @var{subr} can be a string From 6764198159be919a02be9714d264ed0ce4ae0620 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Fri, 20 Apr 2001 19:14:59 +0000 Subject: [PATCH 0844/2047] * acconfig.h: include HAVE_SIN6_SCOPE_ID. * configure.in: check for sin6_scope_id in sockaddr_in6. --- ChangeLog | 5 +++++ acconfig.h | 3 +++ configure.in | 11 +++++++++++ 3 files changed, 19 insertions(+) diff --git a/ChangeLog b/ChangeLog index 5e239740b..6ea0c9c9c 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2001-04-20 Gary Houston + + * acconfig.h: include HAVE_SIN6_SCOPE_ID. + * configure.in: check for sin6_scope_id in sockaddr_in6. + 2001-04-19 Mikael Djurfeldt * RELEASE: Added deprecated macro SCM_ARRAY_CONTIGUOUS diff --git a/acconfig.h b/acconfig.h index dd51a227e..3c0e7887e 100644 --- a/acconfig.h +++ b/acconfig.h @@ -122,6 +122,9 @@ /* Define this if you want support for arrays and uniform arrays. */ #undef HAVE_ARRAYS +/* Define this if your IPv6 has sin6_scope_id in sockaddr_in6 struct. */ +#undef HAVE_SIN6_SCOPE_ID + /* This is included as part of a workaround for a autoheader bug. */ #undef HAVE_REGCOMP diff --git a/configure.in b/configure.in index ff584e4da..49e58231d 100644 --- a/configure.in +++ b/configure.in @@ -264,6 +264,17 @@ if test $guile_cv_have_h_errno = yes; then AC_DEFINE(HAVE_H_ERRNO) fi +# included in rfc2553 but not in older implementations, e.g., glibc 2.1.3. +AC_MSG_CHECKING(whether sockaddr_in6 has sin6_scope_id) +AC_CACHE_VAL(guile_cv_have_sin6_scope_id, +[AC_TRY_COMPILE([#include ], +[struct sockaddr_in6 sok; sok.sin6_scope_id = 0;], +guile_cv_have_sin6_scope_id=yes, guile_cv_have_sin6_scope_id=no)]) +AC_MSG_RESULT($guile_cv_have_sin6_scope_id) +if test $guile_cv_have_sin6_scope_id = yes; then + AC_DEFINE(HAVE_SIN6_SCOPE_ID) +fi + AC_MSG_CHECKING(whether localtime caches TZ) AC_CACHE_VAL(guile_cv_localtime_cache, [if test x$ac_cv_func_tzset = xyes; then From 5a525b84419237ccfa672a0a419b068b3fb2b9f2 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Fri, 20 Apr 2001 19:22:47 +0000 Subject: [PATCH 0845/2047] * socket.c (scm_fill_sockaddr): call htons for sin6_port. Don't assign sin6_scope_id in structure unless HAVE_SIN6_SCOPE_ID is defined. (scm_addr_vector): use a switch instead of multiple if statements. Add support for IPv6 (incomplete) . MAX_ADDR_SIZE: increase to size of struct sockaddr_in if needed. --- libguile/ChangeLog | 9 ++++++ libguile/socket.c | 80 ++++++++++++++++++++++++++++++++-------------- 2 files changed, 65 insertions(+), 24 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 4540aedd5..6b034e44e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2001-04-20 Gary Houston + + * socket.c (scm_fill_sockaddr): call htons for sin6_port. + Don't assign sin6_scope_id in structure unless HAVE_SIN6_SCOPE_ID + is defined. + (scm_addr_vector): use a switch instead of multiple if statements. + Add support for IPv6 (incomplete) . + MAX_ADDR_SIZE: increase to size of struct sockaddr_in if needed. + 2001-04-20 Dirk Herrmann * struct.c (scm_free_structs): Only pairs may be accessed with diff --git a/libguile/socket.c b/libguile/socket.c index 211f2d023..ed51a262c 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -500,9 +500,11 @@ scm_fill_sockaddr (int fam, SCM address, SCM *args, int which_arg, } #endif } - soka->sin6_port = port; + soka->sin6_port = htons (port); soka->sin6_flowinfo = flowinfo; +#ifdef HAVE_SIN6_SCOPE_ID soka->sin6_scope_id = scope_id; +#endif *size = sizeof (struct sockaddr_in6); return (struct sockaddr *) soka; } @@ -666,33 +668,56 @@ scm_addr_vector (struct sockaddr *address, const char *proc) SCM result; SCM *ve; -#ifdef HAVE_UNIX_DOMAIN_SOCKETS - if (fam == AF_UNIX) + switch (fam) { - struct sockaddr_un *nad = (struct sockaddr_un *) address; + case AF_INET: + { + struct sockaddr_in *nad = (struct sockaddr_in *) address; - result = scm_c_make_vector (2, SCM_UNSPECIFIED); - ve = SCM_VELTS (result); - ve[0] = scm_ulong2num ((unsigned long) fam); - ve[1] = scm_makfromstr (nad->sun_path, - (scm_sizet) strlen (nad->sun_path), 0); - } - else + result = scm_c_make_vector (3, SCM_UNSPECIFIED); + ve = SCM_VELTS (result); + ve[0] = scm_ulong2num ((unsigned long) fam); + ve[1] = scm_ulong2num (ntohl (nad->sin_addr.s_addr)); + ve[2] = scm_ulong2num ((unsigned long) ntohs (nad->sin_port)); + } + break; +#ifdef AF_INET6 + case AF_INET6: + { + struct sockaddr_in6 *nad = (struct sockaddr_in6 *) address; + + result = scm_c_make_vector (5, SCM_UNSPECIFIED); + ve = SCM_VELTS (result); + ve[0] = scm_ulong2num ((unsigned long) fam); + /* FIXME */ + ve[1] = SCM_INUM0; + ve[2] = scm_ulong2num ((unsigned long) ntohs (nad->sin6_port)); + ve[3] = scm_ulong2num ((unsigned long) nad->sin6_flowinfo); +#ifdef HAVE_SIN6_SCOPE_ID + ve[4] = scm_ulong2num ((unsigned long) nad->sin6_scope_id); +#else + ve[4] = SCM_INUM0; #endif - if (fam == AF_INET) - { - struct sockaddr_in *nad = (struct sockaddr_in *) address; + } + break; +#endif +#ifdef HAVE_UNIX_DOMAIN_SOCKETS + case AF_UNIX: + { + struct sockaddr_un *nad = (struct sockaddr_un *) address; - result = scm_c_make_vector (3, SCM_UNSPECIFIED); - ve = SCM_VELTS (result); - ve[0] = scm_ulong2num ((unsigned long) fam); - ve[1] = scm_ulong2num (ntohl (nad->sin_addr.s_addr)); - ve[2] = scm_ulong2num ((unsigned long) ntohs (nad->sin_port)); + result = scm_c_make_vector (2, SCM_UNSPECIFIED); + ve = SCM_VELTS (result); + ve[0] = scm_ulong2num ((unsigned long) fam); + ve[1] = scm_makfromstr (nad->sun_path, + (scm_sizet) strlen (nad->sun_path), 0); + } + break; +#endif + default: + scm_misc_error (proc, "Unrecognised address family: ~A", + SCM_LIST1 (SCM_MAKINUM (fam))); } - else - scm_misc_error (proc, "Unrecognised address family: ~A", - SCM_LIST1 (SCM_MAKINUM (fam))); - return result; } @@ -706,7 +731,14 @@ scm_addr_vector (struct sockaddr *address, const char *proc) #define MAX_SIZE_UN 0 #endif -#define MAX_ADDR_SIZE max (sizeof (struct sockaddr_in), MAX_SIZE_UN) +#if defined (AF_INET6) +#define MAX_SIZE_IN6 sizeof (struct sockaddr_in6) +#else +#define MAX_SIZE_IN6 0 +#endif + +#define MAX_ADDR_SIZE max (max (sizeof (struct sockaddr_in), MAX_SIZE_IN6),\ + MAX_SIZE_UN) SCM_DEFINE (scm_accept, "accept", 1, 0, 0, (SCM sock), From e1368a8d44acdae6eb45fb921a6760dbd6356942 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sat, 21 Apr 2001 19:10:15 +0000 Subject: [PATCH 0846/2047] * socket.c (FLIP_NET_HOST_128): new macro. (scm_fill_sockaddr): use new macro. (scm_addr_vector): completed IPv6 address support. added const to the address parameter. --- libguile/ChangeLog | 9 +++++- libguile/socket.c | 74 +++++++++++++++++++++++++++++++++++----------- 2 files changed, 64 insertions(+), 19 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6b034e44e..db553c0b5 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2001-04-21 Gary Houston + + * socket.c (FLIP_NET_HOST_128): new macro. + (scm_fill_sockaddr): use new macro. + (scm_addr_vector): completed IPv6 address support. added const + to the address parameter. + 2001-04-20 Gary Houston * socket.c (scm_fill_sockaddr): call htons for sin6_port. @@ -5,7 +12,7 @@ is defined. (scm_addr_vector): use a switch instead of multiple if statements. Add support for IPv6 (incomplete) . - MAX_ADDR_SIZE: increase to size of struct sockaddr_in if needed. + MAX_ADDR_SIZE: increase to size of struct sockaddr_in6 if needed. 2001-04-20 Dirk Herrmann diff --git a/libguile/socket.c b/libguile/socket.c index ed51a262c..2c5586b5f 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -366,6 +366,24 @@ SCM_DEFINE (scm_setsockopt, "setsockopt", 4, 0, 0, } #undef FUNC_NAME +/* flip a 128 bit IPv6 address between host and network order. */ +#ifdef WORDS_BIGENDIAN +#define FLIP_NET_HOST_128(addr) +#else +#define FLIP_NET_HOST_128(addr)\ +{\ + int i;\ + \ + for (i = 0; i < 8; i++)\ + {\ + char c = (addr)[i];\ + \ + (addr)[i] = (addr)[15 - i];\ + (addr)[15 - i] = c;\ + }\ +} +#endif + SCM_DEFINE (scm_shutdown, "shutdown", 2, 0, 0, (SCM sock, SCM how), "Sockets can be closed simply by using @code{close-port}. The\n" @@ -484,21 +502,10 @@ scm_fill_sockaddr (int fam, SCM address, SCM *args, int which_arg, } else { - scm_sizet i; - memset (soka->sin6_addr.s6_addr, 0, 16); memcpy (soka->sin6_addr.s6_addr, SCM_BDIGITS (address), SCM_NUMDIGS (address) * (SCM_BITSPERDIG / 8)); -#ifndef WORDS_BIGENDIAN - /* flip to network order. */ - for (i = 0; i < 8; i++) - { - char c = soka->sin6_addr.s6_addr[i]; - - soka->sin6_addr.s6_addr[i] = soka->sin6_addr.s6_addr[15 - i]; - soka->sin6_addr.s6_addr[15 - i] = c; - } -#endif + FLIP_NET_HOST_128 (soka->sin6_addr.s6_addr); } soka->sin6_port = htons (port); soka->sin6_flowinfo = flowinfo; @@ -662,7 +669,7 @@ SCM_DEFINE (scm_listen, "listen", 2, 0, 0, /* Put the components of a sockaddr into a new SCM vector. */ static SCM -scm_addr_vector (struct sockaddr *address, const char *proc) +scm_addr_vector (const struct sockaddr *address, const char *proc) { short int fam = address->sa_family; SCM result; @@ -672,7 +679,7 @@ scm_addr_vector (struct sockaddr *address, const char *proc) { case AF_INET: { - struct sockaddr_in *nad = (struct sockaddr_in *) address; + const struct sockaddr_in *nad = (struct sockaddr_in *) address; result = scm_c_make_vector (3, SCM_UNSPECIFIED); ve = SCM_VELTS (result); @@ -684,13 +691,44 @@ scm_addr_vector (struct sockaddr *address, const char *proc) #ifdef AF_INET6 case AF_INET6: { - struct sockaddr_in6 *nad = (struct sockaddr_in6 *) address; + const struct sockaddr_in6 *nad = (struct sockaddr_in6 *) address; + int big_digits = 128 / SCM_BITSPERDIG; + int bytes_per_dig = SCM_BITSPERDIG / 8; + char addr[16]; + char *ptr = addr; + SCM scm_addr; + + memcpy (addr, nad->sin6_addr.s6_addr, 16); + /* get rid of leading zeros. */ + while (big_digits > 0) + { + long test = 0; + + memcpy (&test, ptr, bytes_per_dig); + if (test != 0) + break; + ptr += bytes_per_dig; + big_digits--; + } + FLIP_NET_HOST_128 (addr); + if (big_digits * bytes_per_dig <= sizeof (unsigned long)) + { + /* this is just so that we use INUM where possible. */ + unsigned long l_addr; + + memcpy (&l_addr, addr, sizeof (unsigned long)); + scm_addr = scm_ulong2num (l_addr); + } + else + { + scm_addr = scm_mkbig (big_digits, 0); + memcpy (SCM_BDIGITS (scm_addr), addr, big_digits * bytes_per_dig); + } result = scm_c_make_vector (5, SCM_UNSPECIFIED); ve = SCM_VELTS (result); ve[0] = scm_ulong2num ((unsigned long) fam); - /* FIXME */ - ve[1] = SCM_INUM0; + ve[1] = scm_addr; ve[2] = scm_ulong2num ((unsigned long) ntohs (nad->sin6_port)); ve[3] = scm_ulong2num ((unsigned long) nad->sin6_flowinfo); #ifdef HAVE_SIN6_SCOPE_ID @@ -704,7 +742,7 @@ scm_addr_vector (struct sockaddr *address, const char *proc) #ifdef HAVE_UNIX_DOMAIN_SOCKETS case AF_UNIX: { - struct sockaddr_un *nad = (struct sockaddr_un *) address; + const struct sockaddr_un *nad = (struct sockaddr_un *) address; result = scm_c_make_vector (2, SCM_UNSPECIFIED); ve = SCM_VELTS (result); From 7a7f7c5314d3e5c62a2b0d56ea2b3e404948e431 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 21 Apr 2001 21:50:08 +0000 Subject: [PATCH 0847/2047] * Made creation of new smob types thread safe. * Minor cleanups to smob usage. --- libguile/ChangeLog | 28 +++++++++++++++ libguile/eq.c | 2 +- libguile/gc.c | 21 +++++++---- libguile/print.c | 13 +++---- libguile/ramap.c | 2 +- libguile/smob.c | 89 ++++++++++++++++++++++++++-------------------- libguile/smob.h | 10 +++--- 7 files changed, 103 insertions(+), 62 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index db553c0b5..566c8d415 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,31 @@ +2001-04-21 Dirk Herrmann + + * eq.c (scm_equal_p), ramap.c (scm_init_ramap): Don't compute the + smob number explicitly. Use SCM_TC2SMOBNUM instead. + + * gc.c (MARK, scm_gc_sweep): Only check for illegal heap objects + when compiled in debug mode. + + (scm_gc_sweep): Only call smob's free function if it is defined. + + * print.c (scm_iprin1): No need to check for validity of smob + type or existence of print function. + + * smob.[ch] (scm_smobs): Made into a fixed size global array. + Resizing will not work well with preemptive threading. + + * smob.c (scm_smob_print): Don't use SCM_CDR to access smob data. + + (scm_make_smob_type): Extracted initialization of smob + descriptors to scm_smob_prehistory. Don't use scm_numsmob outside + of the critical section. + + (scm_smob_prehistory): Initialize all smob descriptors. By + default, don't assign a smob free function: Most smob types don't + need one. + + * smob.h (SMOBH, SCM_SMOB_H): Renamed SMOBH to SCM_SMOB_H. + 2001-04-21 Gary Houston * socket.c (FLIP_NET_HOST_128): new macro. diff --git a/libguile/eq.c b/libguile/eq.c index 0bb7f0840..73658cfad 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -188,7 +188,7 @@ SCM_DEFINE1 (scm_equal_p, "equal?", scm_tc7_rpsubr, case scm_tc7_llvect: #endif case scm_tc7_byvect: - if (scm_tc16_array && scm_smobs[0x0ff & (scm_tc16_array >> 8)].equalp) + if (scm_tc16_array && scm_smobs[SCM_TC2SMOBNUM (scm_tc16_array)].equalp) return scm_array_equal_p (x, y); #endif } diff --git a/libguile/gc.c b/libguile/gc.c index 677d695e0..88361246c 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1364,8 +1364,10 @@ gc_mark_loop_first_time: break; case scm_tc7_port: i = SCM_PTOBNUM (ptr); +#if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST)) if (!(i < scm_numptob)) - goto def; + SCM_MISC_ERROR ("undefined port type", SCM_EOL); +#endif if (SCM_PTAB_ENTRY(ptr)) RECURSE (SCM_FILENAME (ptr)); if (scm_ptobs[i].mark) @@ -1387,8 +1389,10 @@ gc_mark_loop_first_time: break; default: i = SCM_SMOBNUM (ptr); +#if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST)) if (!(i < scm_numsmob)) - goto def; + SCM_MISC_ERROR ("undefined smob type", SCM_EOL); +#endif if (scm_smobs[i].mark) { ptr = (scm_smobs[i].mark) (ptr); @@ -1399,7 +1403,6 @@ gc_mark_loop_first_time: } break; default: - def: SCM_MISC_ERROR ("unknown type", SCM_EOL); } #undef RECURSE @@ -1729,8 +1732,10 @@ scm_gc_sweep () if SCM_OPENP (scmptr) { int k = SCM_PTOBNUM (scmptr); +#if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST)) if (!(k < scm_numptob)) - goto sweeperr; + SCM_MISC_ERROR ("undefined port type", SCM_EOL); +#endif /* Keep "revealed" ports alive. */ if (scm_revealed_count (scmptr) > 0) continue; @@ -1764,15 +1769,17 @@ scm_gc_sweep () { int k; k = SCM_SMOBNUM (scmptr); +#if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST)) if (!(k < scm_numsmob)) - goto sweeperr; - m += (scm_smobs[k].free) (scmptr); + SCM_MISC_ERROR ("undefined smob type", SCM_EOL); +#endif + if (scm_smobs[k].free) + m += (scm_smobs[k].free) (scmptr); break; } } break; default: - sweeperr: SCM_MISC_ERROR ("unknown type", SCM_EOL); } diff --git a/libguile/print.c b/libguile/print.c index e686d26dd..1bd903529 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -641,15 +641,10 @@ taloop: goto punk; } case scm_tc7_smob: - { - register long i; - ENTER_NESTED_DATA (pstate, exp, circref); - i = SCM_SMOBNUM (exp); - if (i < scm_numsmob && scm_smobs[i].print) - (scm_smobs[i].print) (exp, port, pstate); - EXIT_NESTED_DATA (pstate); - break; - } + ENTER_NESTED_DATA (pstate, exp, circref); + SCM_SMOB_DESCRIPTOR (exp).print (exp, port, pstate); + EXIT_NESTED_DATA (pstate); + break; default: punk: scm_ipruk ("type", exp, port); diff --git a/libguile/ramap.c b/libguile/ramap.c index b808d6e87..377debc4b 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -2056,7 +2056,7 @@ scm_init_ramap () init_raprocs (ra_rpsubrs); init_raprocs (ra_asubrs); scm_make_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p); - scm_smobs[0x0ff & (scm_tc16_array >> 8)].equalp = scm_raequal; + scm_smobs[SCM_TC2SMOBNUM (scm_tc16_array)].equalp = scm_raequal; #ifndef SCM_MAGIC_SNARFER #include "libguile/ramap.x" #endif diff --git a/libguile/smob.c b/libguile/smob.c index 6cd557cc7..6d80f8fe3 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -61,12 +61,14 @@ /* scm_smobs scm_numsmob - * implement a dynamicly resized array of smob records. + * implement a fixed sized array of smob records. * Indexes into this table are used when generating type * tags for smobjects (if you know a tag you can get an index and conversely). */ + +#define MAX_SMOB_COUNT 256 int scm_numsmob; -scm_smob_descriptor *scm_smobs; +scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT]; /* {Mark} */ @@ -117,11 +119,14 @@ scm_smob_free (SCM obj) int scm_smob_print (SCM exp, SCM port, scm_print_state *pstate) { - int n = SCM_SMOBNUM (exp); + unsigned int n = SCM_SMOBNUM (exp); scm_puts ("#<", port); scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port); scm_putc (' ', port); - scm_intprint (SCM_UNPACK (scm_smobs[n].size ? SCM_CDR (exp) : exp), 16, port); + if (scm_smobs[n].size) + scm_intprint (SCM_CELL_WORD_1 (exp), 16, port); + else + scm_intprint (SCM_UNPACK (exp), 16, port); scm_putc ('>', port); return 1; } @@ -279,45 +284,37 @@ scm_smob_apply_3_error (SCM smob, SCM a1, SCM a2, SCM rst) } + scm_bits_t scm_make_smob_type (char *name, scm_sizet size) +#define FUNC_NAME "scm_make_smob_type" { - char *tmp; - if (255 <= scm_numsmob) - goto smoberr; - SCM_DEFER_INTS; - SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_smobs, - (1 + scm_numsmob) - * sizeof (scm_smob_descriptor))); - if (tmp) + unsigned int new_smob; + + SCM_ENTER_A_SECTION; /* scm_numsmob */ + new_smob = scm_numsmob; + if (scm_numsmob != MAX_SMOB_COUNT) + ++scm_numsmob; + SCM_EXIT_A_SECTION; + + if (new_smob == MAX_SMOB_COUNT) + scm_misc_error (FUNC_NAME, "maximum number of smobs exceeded", SCM_EOL); + + scm_smobs[new_smob].name = name; + if (size != 0) { - scm_smobs = (scm_smob_descriptor *) tmp; - scm_smobs[scm_numsmob].name = name; - scm_smobs[scm_numsmob].size = size; - scm_smobs[scm_numsmob].mark = 0; - scm_smobs[scm_numsmob].free = (size == 0 ? scm_free0 : scm_smob_free); - scm_smobs[scm_numsmob].print = scm_smob_print; - scm_smobs[scm_numsmob].equalp = 0; - scm_smobs[scm_numsmob].apply = 0; - scm_smobs[scm_numsmob].apply_0 = 0; - scm_smobs[scm_numsmob].apply_1 = 0; - scm_smobs[scm_numsmob].apply_2 = 0; - scm_smobs[scm_numsmob].apply_3 = 0; - scm_smobs[scm_numsmob].gsubr_type = 0; - scm_numsmob++; - } - SCM_ALLOW_INTS; - if (!tmp) - { - smoberr: - scm_memory_error ("scm_make_smob_type"); + scm_smobs[new_smob].size = size; + scm_smobs[new_smob].free = scm_smob_free; } + /* Make a class object if Goops is present. */ if (scm_smob_class) - scm_smob_class[scm_numsmob - 1] - = scm_make_extended_class (SCM_SMOBNAME (scm_numsmob - 1)); - return scm_tc7_smob + (scm_numsmob - 1) * 256; + scm_smob_class[new_smob] = scm_make_extended_class (name); + + return scm_tc7_smob + new_smob * 256; } +#undef FUNC_NAME + void scm_set_smob_mark (scm_bits_t tc, SCM (*mark) (SCM)) @@ -529,17 +526,31 @@ free_print (SCM exp, SCM port, scm_print_state *pstate) void scm_smob_prehistory () { + unsigned int i; scm_bits_t tc; scm_numsmob = 0; - scm_smobs = ((scm_smob_descriptor *) - malloc (7 * sizeof (scm_smob_descriptor))); + for (i = 0; i < MAX_SMOB_COUNT; ++i) + { + scm_smobs[i].name = 0; + scm_smobs[i].size = 0; + scm_smobs[i].mark = 0; + scm_smobs[i].free = 0; + scm_smobs[i].print = scm_smob_print; + scm_smobs[i].equalp = 0; + scm_smobs[i].apply = 0; + scm_smobs[i].apply_0 = 0; + scm_smobs[i].apply_1 = 0; + scm_smobs[i].apply_2 = 0; + scm_smobs[i].apply_3 = 0; + scm_smobs[i].gsubr_type = 0; + } /* WARNING: These scm_make_smob_type calls must be done in this order */ tc = scm_make_smob_type ("free", 0); scm_set_smob_print (tc, free_print); - tc = scm_make_smob_type ("big", 0); /* freed in gc */ + tc = scm_make_smob_type ("big", 0); /* freed in gc */ scm_set_smob_print (tc, scm_bigprint); scm_set_smob_equalp (tc, scm_bigequal); @@ -547,7 +558,7 @@ scm_smob_prehistory () 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 */ + 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/smob.h b/libguile/smob.h index aee18b557..5c1a56e8e 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef SMOBH -#define SMOBH -/* Copyright (C) 1995, 1996, 1998, 1999, 2000 Free Software Foundation, Inc. +#ifndef SCM_SMOB_H +#define SCM_SMOB_H +/* Copyright (C) 1995,1996,1998,1999,2000,2001 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 @@ -125,7 +125,7 @@ do { \ #define SCM_SMOB_APPLY_3(x,a1,a2,rst) (SCM_SMOB_DESCRIPTOR (x).apply_3 (x, (a1), (a2), (rst))) extern int scm_numsmob; -extern scm_smob_descriptor *scm_smobs; +extern scm_smob_descriptor scm_smobs[]; @@ -179,7 +179,7 @@ extern void scm_set_smob_mfpe (long tc, #endif /* SCM_DEBUG_DEPRECATED == 0 */ -#endif /* SMOBH */ +#endif /* SCM_SMOB_H */ /* Local Variables: From 006064cefebe79635551e368f83aae6c4b5e41bb Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sun, 22 Apr 2001 13:15:42 +0000 Subject: [PATCH 0848/2047] * Extended documentation on exceptions. * Minor changes to Martin's doc on continuations. --- doc/ChangeLog | 6 ++ doc/scheme-control.texi | 138 ++++++++++++++++++++++++++++++++++------ 2 files changed, 126 insertions(+), 18 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 15ef0b9ad..872378d9d 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,9 @@ +2001-04-22 Neil Jerram + + * scheme-control.texi (Exceptions): Extended documentation. + (Continuations): Correct "except" typo, and fix reference to + Exceptions node. Plus minor review changes. + 2001-04-20 Neil Jerram * scheme-control.texi (Exceptions): Reorganized and extended diff --git a/doc/scheme-control.texi b/doc/scheme-control.texi index 4d4dbcf3c..db5ad186e 100644 --- a/doc/scheme-control.texi +++ b/doc/scheme-control.texi @@ -249,25 +249,27 @@ times. @node Continuations @section Continuations -@c FIXME::martin: Review me! - @cindex call/cc -The possibility to explicitly capture continuation and the use of +@cindex call-with-current-continuation +The ability to explicitly capture continuations using @code{call-with-current-continuation} (also often called @code{call/cc} -for shortness) is maybe the most powerful control structure known. All -other control structures like loops or coroutines can be emulated using -continuation. +for short), and to invoke such continuations later any number of times, +and from any other point in a program, provides maybe the most powerful +control structure known. All other control structures, such as loops +and coroutines, can be emulated using continuations. + +@c NJFIXME - need a little something here about what continuations are +@c and what they do for you. -@c FIXME::martin: Is this too much of understatement, maybe confusing? -@c I'm not sure. The implementation of continuations in Guile is not as efficient as one -might except, because it is constrained by the fact that Guile is -required to be cooperative to programs written in other languages, such -as C which do not know about continuations. So continuations should be -used when there is no other possibility to get the needed effect. If -you find yourself using @code{call/cc} for escape procedures and your -program is running to slow, you might want to use exceptions (REFFIXME) -instead. +might hope, because it is constrained by the fact that Guile is designed +to cooperate with programs written in other languages, such as C, which +do not know about continuations. So continuations should be used when +there is no other simple way of achieving the desired behaviour, or +where the advantages of the elegant continuation mechanism outweigh the +need for optimum performance. If you find yourself using @code{call/cc} +for escape procedures and your program is running too slow, you might +want to use exceptions (@pxref{Exceptions}) instead. @rnindex call-with-current-continuation @deffn primitive call-with-current-continuation proc @@ -404,15 +406,89 @@ programming languages) provides an additional mechanism called more conveniently. @menu -* Catch and Throw:: Basic exception handling primitives. +* Exception Terminology:: Different ways to say the same thing. +* Catch:: Setting up to catch exceptions. +* Throw:: Throwing an exception. * Lazy Catch:: Catch without unwinding. * Stack Catch:: Capturing the stack at a throw. * Exception Implementation:: How Guile implements exceptions. @end menu -@node Catch and Throw -@subsection Basic Exception Handling Primitives +@node Exception Terminology +@subsection Exception Terminology + +There are several variations on the terminology for dealing with +non-local jumps. It is useful to be aware of them, and to realize +that they all refer to the same basic mechanism. + +@itemize @bullet +@item +Actually making a non-local jump may be called @dfn{raising an +exception}, @dfn{raising a signal}, @dfn{throwing an exception} or +@dfn{doing a long jump}. When the jump indicates an error condition, +people may talk about @dfn{signalling}, @dfn{raising} or @dfn{throwing} +@dfn{an error}. + +@item +Handling the jump at its target may be referred to as @dfn{catching} or +@dfn{handling} the @dfn{exception}, @dfn{signal} or, where an error +condition is involved, @dfn{error}. +@end itemize + +Where @dfn{signal} and @dfn{signalling} are used, special care is needed +to avoid the risk of confusion with POSIX signals. (Especially +considering that Guile handles POSIX signals by throwing a corresponding +kind of exception: REFFIXME.) + +This manual prefers to speak of throwing and catching exceptions, since +this terminology matches the corresponding Guile primitives. + + +@node Catch +@subsection Catching Exceptions + +@code{catch} is used to set up a target for a possible non-local jump. +The arguments of a @code{catch} expression are a @dfn{key}, which +restricts the set of exceptions to which this @code{catch} applies, a +thunk that specifies the @dfn{normal case} code --- i.e. what should +happen if no exceptions are thrown --- and a @dfn{handler} procedure +that says what to do if an exception is thrown. Note that if the +@dfn{normal case} thunk executes @dfn{normally}, which means without +throwing any exceptions, the handler procedure is not executed at all. + +When an exception is thrown using the @code{throw} primitive, the first +argument of the @code{throw} is a symbol that indicates the type of the +exception. For example, Guile throws an exception using the symbol +@code{numerical-overflow} to indicate numerical overflow errors such as +division by zero: + +@lisp +(/ 1 0) +@result{} +ABORT: (numerical-overflow) +@end lisp + +The @var{key} argument in a @code{catch} expression corresponds to this +symbol. @var{key} may be a specific symbol, such as +@code{numerical-overflow}, in which case the @code{catch} applies +specifically to exceptions of that type; or it may be @code{#t}, which +means that the @code{catch} applies to all exceptions, irrespective of +their type. + +The second argument of a @code{catch} expression should be a thunk +(i.e. a procedure that accepts no arguments) that specifies the normal +case code. The @code{catch} is active for the execution of this thunk, +including any code called directly or indirectly by the thunk's body. +Evaluation of the @code{catch} expression activates the catch and then +calls this thunk. + +The third argument of a @code{catch} expression is a handler procedure. +If an exception is thrown, this procedure is called with exactly the +arguments specified by the @code{throw}. Therefore, the handler +procedure must be designed to accept a number of arguments that +corresponds to the number of arguments in all @code{throw} expressions +that can be caught by this @code{catch}. @deffn primitive catch key thunk handler Invoke @var{thunk} in the dynamic context of @var{handler} for @@ -431,6 +507,32 @@ If the key is @code{#t}, then a throw to @emph{any} symbol will match this call to @code{catch}. @end deffn +If the handler procedure needs to match a variety of @code{throw} +expressions with varying numbers of arguments, you should write it like +this: + +@lisp +(lambda (key . args) + @dots{}) +@end lisp + +@noindent +The @var{key} argument is guaranteed always to be present, because a +@code{throw} without a @var{key} is not valid. The number and +interpretation of the @var{args} varies from one type of exception to +another, but should be specified by the documentation for each exception +type. + +Note that, once the handler procedure is invoked, the catch that led to +the handler procedure being called is no longer active. Therefore, if +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. + + +@node Throw +@subsection Throwing Exceptions + @deffn primitive throw key . args Invoke the catch form matching @var{key}, passing @var{args} to the @var{handler}. From b9bf148fa27a2cc1db489f55f2768d6b8aba0cad Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sun, 22 Apr 2001 13:22:51 +0000 Subject: [PATCH 0849/2047] * Remove r4rs from distribution. --- doc/ChangeLog | 2 ++ doc/Makefile.am | 2 +- doc/README | 10 +++++++--- doc/r4rs.texi | 0 4 files changed, 10 insertions(+), 4 deletions(-) delete mode 100644 doc/r4rs.texi diff --git a/doc/ChangeLog b/doc/ChangeLog index 872378d9d..76923973f 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,5 +1,7 @@ 2001-04-22 Neil Jerram + * README: Note removal of r4rs, and provide a reference. + * scheme-control.texi (Exceptions): Extended documentation. (Continuations): Correct "except" typo, and fix reference to Exceptions node. Plus minor review changes. diff --git a/doc/Makefile.am b/doc/Makefile.am index f3a6cdbf9..d72418148 100644 --- a/doc/Makefile.am +++ b/doc/Makefile.am @@ -21,7 +21,7 @@ AUTOMAKE_OPTIONS = foreign -info_TEXINFOS = guile.texi r4rs.texi r5rs.texi goops.texi guile-tut.texi +info_TEXINFOS = guile.texi r5rs.texi goops.texi guile-tut.texi guile_TEXINFOS = preface.texi intro.texi scheme-intro.texi \ scheme-ideas.texi scheme-data.texi scheme-procedures.texi \ diff --git a/doc/README b/doc/README index 2f4ec3432..3ecd329b4 100644 --- a/doc/README +++ b/doc/README @@ -12,11 +12,10 @@ The documentation consists of the following manuals. reference documentation for using GOOPS, Guile's Object Oriented Programming System. -- The Revised^4 and Revised^5 Reports on the Algorithmic Language - Scheme (r4rs.texi and r5rs.texi). +- The Revised^5 Report on the Algorithmic Language Scheme (r5rs.texi). Please be aware that this is all very much work in progress (apart -from the Revised Reports). Bug reports and contributions are +from the Revised^5 Report). Bug reports and contributions are welcome! The file `oldfmt.c' contains a function which can be used by @@ -27,3 +26,8 @@ The `sources' directory includes some stuff relevant to the Guile reference manual, and which may eventually be folded in to it. It's not immediately relevant, however, which is why it's not in this directory. + +The Revised^4 Report (r4rs.texi) is no longer in this distribution, as +it is completely superseded by the Revised^5 Report. If you need to +consult R4RS, it is still widely available, for example at +http://www-swiss.ai.mit.edu/projects/info/SchemeDocs/r4rs/. diff --git a/doc/r4rs.texi b/doc/r4rs.texi deleted file mode 100644 index e69de29bb..000000000 From 63f412c209265aa393539685b581d5a65da36767 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sun, 22 Apr 2001 13:32:15 +0000 Subject: [PATCH 0850/2047] * Complete ChangeLog entries for removal of r4rs. --- doc/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/doc/ChangeLog b/doc/ChangeLog index 76923973f..419859fff 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,5 +1,9 @@ 2001-04-22 Neil Jerram + * r4rs.texi: Removed. + + * Makefile.am (info_TEXINFOS): Remove r4rs. + * README: Note removal of r4rs, and provide a reference. * scheme-control.texi (Exceptions): Extended documentation. From 8c34cf5b14ef06c71f3dbcdecfcfd9b30122e6a4 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sun, 22 Apr 2001 14:56:52 +0000 Subject: [PATCH 0851/2047] * Change R4RS references to R5RS. --- doc/ChangeLog | 13 ++ doc/appendices.texi | 279 ------------------------ doc/env.texi | 4 +- doc/format.texi | 434 ------------------------------------- doc/gh.texi | 6 +- doc/guile-tut.texi | 16 +- doc/guile.texi | 6 +- doc/scheme-data.texi | 14 +- doc/scheme-evaluation.texi | 2 +- doc/scheme-io.texi | 11 +- doc/scheme-modules.texi | 2 +- 11 files changed, 37 insertions(+), 750 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 419859fff..e941a0b87 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,5 +1,18 @@ 2001-04-22 Neil Jerram + * scheme-io.texi: Remove old docstring comments referring to + r4rs.scm. + + * appendices.texi (The Basic Guile Package, Packages not shipped + with Guile), env.texi (Switching to Environments), format.texi + (Format Specification), gh.texi + (Executing Scheme code, Calling Scheme procedures from C), + guile-tut.texi (How to characterize Guile), scheme-data.texi + (Symbols, Keywords, Keyword Read Syntax, Append/Reverse), + scheme-evaluation.texi (Delayed Evaluation), scheme-modules.texi + (Scheme and modules), scheme-io.texi (Soft Ports): Change R4RS + references to R5RS. + * r4rs.texi: Removed. * Makefile.am (info_TEXINFOS): Remove r4rs. diff --git a/doc/appendices.texi b/doc/appendices.texi index 058a69b86..e69de29bb 100644 --- a/doc/appendices.texi +++ b/doc/appendices.texi @@ -1,279 +0,0 @@ -@node Obtaining and Installing Guile -@appendix Obtaining and Installing Guile - -Here is the information you will need to get and install Guile and extra -packages and documentation you might need or find interesting. - -@menu -* The Basic Guile Package:: -* Packages not shipped with Guile:: -@end menu - -@node The Basic Guile Package -@section The Basic Guile Package - -Guile can be obtained from the main GNU archive site -@url{ftp://prep.ai.mit.edu/pub/gnu} or any of its mirrors. The file -will be named guile-version.tar.gz. The current version is -@value{VERSION}, so the file you should grab is: - -@url{ftp://prep.ai.mit.edu/pub/gnu/guile-@value{VERSION}.tar.gz} - -To unbundle Guile use the instruction -@example -zcat guile-@value{VERSION}.tar.gz | tar xvf - -@end example -which will create a directory called @file{guile-@value{VERSION}} with -all the sources. You can look at the file @file{INSTALL} for detailed -instructions on how to build and install Guile, but you should be able -to just do -@example -cd guile-@value{VERSION} -./configure -make install -@end example - -This will install the Guile executable @file{guile}, the Guile library -@file{libguile.a} and various associated header files and support -libraries. It will also install the Guile tutorial and reference manual. - -@c [[include instructions for getting R4RS]] - -Since this manual frequently refers to the Scheme ``standard'', also -known as R4RS, or the -@iftex -``Revised$^4$ Report on the Algorithmic Language Scheme'', -@end iftex -@ifinfo -``Revised^4 Report on the Algorithmic Language Scheme'', -@end ifinfo -we have included the report in the Guile distribution; -@xref{Top, , Introduction, r4rs, Revised(4) Report on the Algorithmic -Language Scheme}. -This will also be installed in your info directory. - - -@node Packages not shipped with Guile -@section Packages not shipped with Guile - -We ship the Guile tutorial and reference manual with the Guile -distribution [FIXME: this is not currently true (Sat Sep 20 14:13:33 MDT -1997), but will be soon.] Since the Scheme standard (R4RS) is a stable -document, we ship that too. - -Here are references (usually World Wide Web URLs) to some other freely -redistributable documents and packages which you might find useful if -you are using Guile. - -@table @strong -@item SCSH -the Scheme Shell. Gary Houston has ported SCSH to Guile. The relevant -chapter (@pxref{The Scheme shell (scsh)}) has references to the SCSH web -page with all its documentation. - -@item SLIB -a portable Scheme library maintained by Aubrey Jaffer. SLIB can be -obtained by ftp from @url{ftp://prep.ai.mit.edu/pub/gnu/jacal/}. - -The SLIB package should be unpacked somewhere in Guile's load path. It -will typically be unpacked in @file{/usr/local/share/guile/site}, so -that it will be @file{/usr/local/share/guile/site/slib}. - -Guile might have been installed with a different prefix, in which case -the load path can be checked from inside the interpreter with: - -@smalllisp -guile> %load-path -("/usr/local/share/guile/site" "/usr/local/share/guile/1.3a" "/usr/local/share/guile" ".") -@end smalllisp - -The relevant chapter (@pxref{SLIB}) has details on how to use SLIB with -Guile. - -@item JACAL -a symbolic math package by Aubrey Jaffer. The latest version of Jacal -can be obtained from @url{ftp://prep.ai.mit.edu/pub/gnu/jacal/}, and -should be unpacked in @file{/usr/local/share/guile/site/slib} so that -it will be in @file{/usr/local/share/guile/site/slib/jacal}. - -The relevant section (@pxref{JACAL}) has details on how to use Jacal. -@end table - - -@page -@node Debugger User Interface -@appendix Debugger User Interface - -@c --- The title and introduction of this appendix need to -@c distinguish this clearly from the chapter on the internal -@c debugging interface. - -When debugging a program, programmers often find it helpful to examine -the program's internal status while it runs: the values of internal -variables, the choices made in @code{if} and @code{cond} statements, and -so forth. Guile Scheme provides a debugging interface that programmers -can use to single-step through Scheme functions and examine symbol -bindings. This is different from the @ref{Debugging}, which permits -programmers to debug the Guile interpreter itself. Most programmers -will be more interested in debugging their own Scheme programs than the -interpreter which evaluates them. - -[FIXME: should we include examples of traditional debuggers -and explain why they can't be used to debug interpreted Scheme or Lisp?] - -@menu -* Single-Step:: Execute a program or function one step at a time. -* Trace:: Print a report each time a given function is called. -* Backtrace:: See a list of the statements that caused an error. -* Stacks and Frames:: Examine the state of an interrupted program. -@end menu - -@node Single-Step -@appendixsec Single-Step - -@node Trace -@appendixsec Trace - -When a function is @dfn{traced}, it means that every call to that -function is reported to the user during a program run. This can help a -programmer determine whether a function is being called at the wrong -time or with the wrong set of arguments. - -@defun trace function -Enable debug tracing on @code{function}. While a program is being run, Guile -will print a brief report at each call to a traced function, -advising the user which function was called and the arguments that were -passed to it. -@end defun - -@defun untrace function -Disable debug tracing for @code{function}. -@end defun - -Example: - -@lisp -(define (rev ls) - (if (null? ls) - '() - (append (rev (cdr ls)) - (cons (car ls) '())))) @result{} rev - -(trace rev) @result{} (rev) - -(rev '(a b c d e)) -@result{} [rev (a b c d e)] - | [rev (b c d e)] - | | [rev (c d e)] - | | | [rev (d e)] - | | | | [rev (e)] - | | | | | [rev ()] - | | | | | () - | | | | (e) - | | | (e d) - | | (e d c) - | (e d c b) - (e d c b a) - (e d c b a) -@end lisp - -Note the way Guile indents the output, illustrating the depth of -execution at each function call. This can be used to demonstrate, for -example, that Guile implements self-tail-recursion properly: - -@lisp -(define (rev ls sl) - (if (null? ls) - sl - (rev (cdr ls) - (cons (car ls) sl)))) @result{} rev - -(trace rev) @result{} (rev) - -(rev '(a b c d e) '()) -@result{} [rev (a b c d e) ()] - [rev (b c d e) (a)] - [rev (c d e) (b a)] - [rev (d e) (c b a)] - [rev (e) (d c b a)] - [rev () (e d c b a)] - (e d c b a) - (e d c b a) -@end lisp - -Since the tail call is effectively optimized to a @code{goto} statement, -there is no need for Guile to create a new stack frame for each -iteration. Using @code{trace} here helps us see why this is so. - -@node Backtrace -@appendixsec Backtrace - -@node Stacks and Frames -@appendixsec Stacks and Frames - -When a running program is interrupted, usually upon reaching an error or -breakpoint, its state is represented by a @dfn{stack} of suspended -function calls, each of which is called a @dfn{frame}. The programmer -can learn more about the program's state at the point of interruption by -inspecting and modifying these frames. - -@deffn primitive stack? obj -Return @code{#t} if @var{obj} is a calling stack. -@end deffn - -@deffn primitive make-stack -@end deffn - -@deffn syntax start-stack id exp -Evaluate @var{exp} on a new calling stack with identity @var{id}. If -@var{exp} is interrupted during evaluation, backtraces will not display -frames farther back than @var{exp}'s top-level form. This macro is a -way of artificially limiting backtraces and stack procedures, largely as -a convenience to the user. -@end deffn - -@deffn primitive stack-id stack -Return the identifier given to @var{stack} by @code{start-stack}. -@end deffn - -@deffn primitive stack-ref -@end deffn - -@deffn primitive stack-length -@end deffn - -@deffn primitive frame? -@end deffn - -@deffn primitive last-stack-frame -@end deffn - -@deffn primitive frame-number -@end deffn - -@deffn primitive frame-source -@end deffn - -@deffn primitive frame-procedure -@end deffn - -@deffn primitive frame-arguments -@end deffn - -@deffn primitive frame-previous -@end deffn - -@deffn primitive frame-next -@end deffn - -@deffn primitive frame-real? -@end deffn - -@deffn primitive frame-procedure? -@end deffn - -@deffn primitive frame-evaluating-args? -@end deffn - -@deffn primitive frame-overflow -@end deffn diff --git a/doc/env.texi b/doc/env.texi index 8c79fe146..712cce310 100644 --- a/doc/env.texi +++ b/doc/env.texi @@ -47,7 +47,7 @@ Copyright @copyright{} 1999 Free Software Foundation, Inc. @chapter Motivation @example -$Id: env.texi,v 1.1 2001-03-09 08:21:59 ossau Exp $ +$Id: env.texi,v 1.2 2001-04-22 14:56:52 ossau Exp $ @end example This is a draft proposal for a new datatype for representing top-level @@ -1053,7 +1053,7 @@ interact with, perhaps with some limitations. @item For testing purposes, make an utterly minimal version of -@file{boot-9.scm}: no module system, no R4RS, nothing. I think a simple +@file{boot-9.scm}: no module system, no R5RS, nothing. I think a simple REPL is all we need. @item diff --git a/doc/format.texi b/doc/format.texi index 40064f012..e69de29bb 100644 --- a/doc/format.texi +++ b/doc/format.texi @@ -1,434 +0,0 @@ - -@menu -* Format Interface:: -* Format Specification:: -@end menu - -@node Format Interface, Format Specification, Format, Format -@subsection Format Interface - -@defun format destination format-string . arguments -An almost complete implementation of Common LISP format description -according to the CL reference book @cite{Common LISP} from Guy L. -Steele, Digital Press. Backward compatible to most of the available -Scheme format implementations. - -Returns @code{#t}, @code{#f} or a string; has side effect of printing -according to @var{format-string}. If @var{destination} is @code{#t}, -the output is to the current output port and @code{#t} is returned. If -@var{destination} is @code{#f}, a formatted string is returned as the -result of the call. NEW: If @var{destination} is a string, -@var{destination} is regarded as the format string; @var{format-string} is -then the first argument and the output is returned as a string. If -@var{destination} is a number, the output is to the current error port -if available by the implementation. Otherwise @var{destination} must be -an output port and @code{#t} is returned.@refill - -@var{format-string} must be a string. In case of a formatting error -format returns @code{#f} and prints a message on the current output or -error port. Characters are output as if the string were output by the -@code{display} function with the exception of those prefixed by a tilde -(~). For a detailed description of the @var{format-string} syntax -please consult a Common LISP format reference manual. For a test suite -to verify this format implementation load @file{formatst.scm}. Please -send bug reports to @code{lutzeb@@cs.tu-berlin.de}. - -Note: @code{format} is not reentrant, i.e. only one @code{format}-call -may be executed at a time. - -@end defun - -@node Format Specification, , Format Interface, Format -@subsection Format Specification (Format version 3.0) - -Please consult a Common LISP format reference manual for a detailed -description of the format string syntax. For a demonstration of the -implemented directives see @file{formatst.scm}.@refill - -This implementation supports directive parameters and modifiers -(@code{:} and @code{@@} characters). Multiple parameters must be -separated by a comma (@code{,}). Parameters can be numerical parameters -(positive or negative), character parameters (prefixed by a quote -character (@code{'}), variable parameters (@code{v}), number of rest -arguments parameter (@code{#}), empty and default parameters. Directive -characters are case independent. The general form of a directive -is:@refill - -@noindent -@var{directive} ::= ~@{@var{directive-parameter},@}[:][@@]@var{directive-character} - -@noindent -@var{directive-parameter} ::= [ [-|+]@{0-9@}+ | '@var{character} | v | # ] - - -@subsubsection Implemented CL Format Control Directives - -Documentation syntax: Uppercase characters represent the corresponding -control directive characters. Lowercase characters represent control -directive parameter descriptions. - -@table @asis -@item @code{~A} -Any (print as @code{display} does). -@table @asis -@item @code{~@@A} -left pad. -@item @code{~@var{mincol},@var{colinc},@var{minpad},@var{padchar}A} -full padding. -@end table -@item @code{~S} -S-expression (print as @code{write} does). -@table @asis -@item @code{~@@S} -left pad. -@item @code{~@var{mincol},@var{colinc},@var{minpad},@var{padchar}S} -full padding. -@end table -@item @code{~D} -Decimal. -@table @asis -@item @code{~@@D} -print number sign always. -@item @code{~:D} -print comma separated. -@item @code{~@var{mincol},@var{padchar},@var{commachar}D} -padding. -@end table -@item @code{~X} -Hexadecimal. -@table @asis -@item @code{~@@X} -print number sign always. -@item @code{~:X} -print comma separated. -@item @code{~@var{mincol},@var{padchar},@var{commachar}X} -padding. -@end table -@item @code{~O} -Octal. -@table @asis -@item @code{~@@O} -print number sign always. -@item @code{~:O} -print comma separated. -@item @code{~@var{mincol},@var{padchar},@var{commachar}O} -padding. -@end table -@item @code{~B} -Binary. -@table @asis -@item @code{~@@B} -print number sign always. -@item @code{~:B} -print comma separated. -@item @code{~@var{mincol},@var{padchar},@var{commachar}B} -padding. -@end table -@item @code{~@var{n}R} -Radix @var{n}. -@table @asis -@item @code{~@var{n},@var{mincol},@var{padchar},@var{commachar}R} -padding. -@end table -@item @code{~@@R} -print a number as a Roman numeral. -@item @code{~:@@R} -print a number as an ``old fashioned'' Roman numeral. -@item @code{~:R} -print a number as an ordinal English number. -@item @code{~:@@R} -print a number as a cardinal English number. -@item @code{~P} -Plural. -@table @asis -@item @code{~@@P} -prints @code{y} and @code{ies}. -@item @code{~:P} -as @code{~P but jumps 1 argument backward.} -@item @code{~:@@P} -as @code{~@@P but jumps 1 argument backward.} -@end table -@item @code{~C} -Character. -@table @asis -@item @code{~@@C} -prints a character as the reader can understand it (i.e. @code{#\} prefixing). -@item @code{~:C} -prints a character as emacs does (eg. @code{^C} for ASCII 03). -@end table -@item @code{~F} -Fixed-format floating-point (prints a flonum like @var{mmm.nnn}). -@table @asis -@item @code{~@var{width},@var{digits},@var{scale},@var{overflowchar},@var{padchar}F} -@item @code{~@@F} -If the number is positive a plus sign is printed. -@end table -@item @code{~E} -Exponential floating-point (prints a flonum like @var{mmm.nnn}@code{E}@var{ee}). -@table @asis -@item @code{~@var{width},@var{digits},@var{exponentdigits},@var{scale},@var{overflowchar},@var{padchar},@var{exponentchar}E} -@item @code{~@@E} -If the number is positive a plus sign is printed. -@end table -@item @code{~G} -General floating-point (prints a flonum either fixed or exponential). -@table @asis -@item @code{~@var{width},@var{digits},@var{exponentdigits},@var{scale},@var{overflowchar},@var{padchar},@var{exponentchar}G} -@item @code{~@@G} -If the number is positive a plus sign is printed. -@end table -@item @code{~$} -Dollars floating-point (prints a flonum in fixed with signs separated). -@table @asis -@item @code{~@var{digits},@var{scale},@var{width},@var{padchar}$} -@item @code{~@@$} -If the number is positive a plus sign is printed. -@item @code{~:@@$} -A sign is always printed and appears before the padding. -@item @code{~:$} -The sign appears before the padding. -@end table -@item @code{~%} -Newline. -@table @asis -@item @code{~@var{n}%} -print @var{n} newlines. -@end table -@item @code{~&} -print newline if not at the beginning of the output line. -@table @asis -@item @code{~@var{n}&} -prints @code{~&} and then @var{n-1} newlines. -@end table -@item @code{~|} -Page Separator. -@table @asis -@item @code{~@var{n}|} -print @var{n} page separators. -@end table -@item @code{~~} -Tilde. -@table @asis -@item @code{~@var{n}~} -print @var{n} tildes. -@end table -@item @code{~} -Continuation Line. -@table @asis -@item @code{~:} -newline is ignored, white space left. -@item @code{~@@} -newline is left, white space ignored. -@end table -@item @code{~T} -Tabulation. -@table @asis -@item @code{~@@T} -relative tabulation. -@item @code{~@var{colnum,colinc}T} -full tabulation. -@end table -@item @code{~?} -Indirection (expects indirect arguments as a list). -@table @asis -@item @code{~@@?} -extracts indirect arguments from format arguments. -@end table -@item @code{~(@var{str}~)} -Case conversion (converts by @code{string-downcase}). -@table @asis -@item @code{~:(@var{str}~)} -converts by @code{string-capitalize}. -@item @code{~@@(@var{str}~)} -converts by @code{string-capitalize-first}. -@item @code{~:@@(@var{str}~)} -converts by @code{string-upcase}. -@end table -@item @code{~*} -Argument Jumping (jumps 1 argument forward). -@table @asis -@item @code{~@var{n}*} -jumps @var{n} arguments forward. -@item @code{~:*} -jumps 1 argument backward. -@item @code{~@var{n}:*} -jumps @var{n} arguments backward. -@item @code{~@@*} -jumps to the 0th argument. -@item @code{~@var{n}@@*} -jumps to the @var{n}th argument (beginning from 0) -@end table -@item @code{~[@var{str0}~;@var{str1}~;...~;@var{strn}~]} -Conditional Expression (numerical clause conditional). -@table @asis -@item @code{~@var{n}[} -take argument from @var{n}. -@item @code{~@@[} -true test conditional. -@item @code{~:[} -if-else-then conditional. -@item @code{~;} -clause separator. -@item @code{~:;} -default clause follows. -@end table -@item @code{~@{@var{str}~@}} -Iteration (args come from the next argument (a list)). -@table @asis -@item @code{~@var{n}@{} -at most @var{n} iterations. -@item @code{~:@{} -args from next arg (a list of lists). -@item @code{~@@@{} -args from the rest of arguments. -@item @code{~:@@@{} -args from the rest args (lists). -@end table -@item @code{~^} -Up and out. -@table @asis -@item @code{~@var{n}^} -aborts if @var{n} = 0 -@item @code{~@var{n},@var{m}^} -aborts if @var{n} = @var{m} -@item @code{~@var{n},@var{m},@var{k}^} -aborts if @var{n} <= @var{m} <= @var{k} -@end table -@end table - - -@subsubsection Not Implemented CL Format Control Directives - -@table @asis -@item @code{~:A} -print @code{#f} as an empty list (see below). -@item @code{~:S} -print @code{#f} as an empty list (see below). -@item @code{~<~>} -Justification. -@item @code{~:^} -(sorry I don't understand its semantics completely) -@end table - - -@subsubsection Extended, Replaced and Additional Control Directives - -@table @asis -@item @code{~@var{mincol},@var{padchar},@var{commachar},@var{commawidth}D} -@item @code{~@var{mincol},@var{padchar},@var{commachar},@var{commawidth}X} -@item @code{~@var{mincol},@var{padchar},@var{commachar},@var{commawidth}O} -@item @code{~@var{mincol},@var{padchar},@var{commachar},@var{commawidth}B} -@item @code{~@var{n},@var{mincol},@var{padchar},@var{commachar},@var{commawidth}R} -@var{commawidth} is the number of characters between two comma characters. -@end table - -@table @asis -@item @code{~I} -print a R4RS complex number as @code{~F~@@Fi} with passed parameters for -@code{~F}. -@item @code{~Y} -Pretty print formatting of an argument for scheme code lists. -@item @code{~K} -Same as @code{~?.} -@item @code{~!} -Flushes the output if format @var{destination} is a port. -@item @code{~_} -Print a @code{#\space} character -@table @asis -@item @code{~@var{n}_} -print @var{n} @code{#\space} characters. -@end table -@item @code{~/} -Print a @code{#\tab} character -@table @asis -@item @code{~@var{n}/} -print @var{n} @code{#\tab} characters. -@end table -@item @code{~@var{n}C} -Takes @var{n} as an integer representation for a character. No arguments -are consumed. @var{n} is converted to a character by -@code{integer->char}. @var{n} must be a positive decimal number.@refill -@item @code{~:S} -Print out readproof. Prints out internal objects represented as -@code{#<...>} as strings @code{"#<...>"} so that the format output can always -be processed by @code{read}. -@refill -@item @code{~:A} -Print out readproof. Prints out internal objects represented as -@code{#<...>} as strings @code{"#<...>"} so that the format output can always -be processed by @code{read}. -@item @code{~Q} -Prints information and a copyright notice on the format implementation. -@table @asis -@item @code{~:Q} -prints format version. -@end table -@refill -@item @code{~F, ~E, ~G, ~$} -may also print number strings, i.e. passing a number as a string and -format it accordingly. -@end table - -@subsubsection Configuration Variables - -Format has some configuration variables at the beginning of -@file{format.scm} to suit the systems and users needs. There should be -no modification necessary for the configuration that comes with SLIB. -If modification is desired the variable should be set after the format -code is loaded. Format detects automatically if the running scheme -system implements floating point numbers and complex numbers. - -@table @asis - -@item @var{format:symbol-case-conv} -Symbols are converted by @code{symbol->string} so the case type of the -printed symbols is implementation dependent. -@code{format:symbol-case-conv} is a one arg closure which is either -@code{#f} (no conversion), @code{string-upcase}, @code{string-downcase} -or @code{string-capitalize}. (default @code{#f}) - -@item @var{format:iobj-case-conv} -As @var{format:symbol-case-conv} but applies for the representation of -implementation internal objects. (default @code{#f}) - -@item @var{format:expch} -The character prefixing the exponent value in @code{~E} printing. (default -@code{#\E}) - -@end table - -@subsubsection Compatibility With Other Format Implementations - -@table @asis -@item SLIB format 2.x: -See @file{format.doc}. - -@item SLIB format 1.4: -Downward compatible except for padding support and @code{~A}, @code{~S}, -@code{~P}, @code{~X} uppercase printing. SLIB format 1.4 uses C-style -@code{printf} padding support which is completely replaced by the CL -@code{format} padding style. - -@item MIT C-Scheme 7.1: -Downward compatible except for @code{~}, which is not documented -(ignores all characters inside the format string up to a newline -character). (7.1 implements @code{~a}, @code{~s}, -~@var{newline}, @code{~~}, @code{~%}, numerical and variable -parameters and @code{:/@@} modifiers in the CL sense).@refill - -@item Elk 1.5/2.0: -Downward compatible except for @code{~A} and @code{~S} which print in -uppercase. (Elk implements @code{~a}, @code{~s}, @code{~~}, and -@code{~%} (no directive parameters or modifiers)).@refill - -@item Scheme->C 01nov91: -Downward compatible except for an optional destination parameter: S2C -accepts a format call without a destination which returns a formatted -string. This is equivalent to a #f destination in S2C. (S2C implements -@code{~a}, @code{~s}, @code{~c}, @code{~%}, and @code{~~} (no directive -parameters or modifiers)).@refill - -@end table - -This implementation of format is solely useful in the SLIB context -because it requires other components provided by SLIB.@refill diff --git a/doc/gh.texi b/doc/gh.texi index 106ed057a..668270cb8 100644 --- a/doc/gh.texi +++ b/doc/gh.texi @@ -249,7 +249,7 @@ except that a whole file is evaluated instead of a string. @code{gh_load} is identical to @code{gh_eval_file} (it's a macro that calls @code{gh_eval_file} on its argument). It is provided to start -making the @code{gh_} interface match the R4RS Scheme procedures +making the @code{gh_} interface match the R5RS Scheme procedures closely. @end deftypefun @@ -568,8 +568,8 @@ interface; they take and return objects of type SCM, and one could basically use them to write C code that mimics Scheme code. I will list these routines here without much explanation, since what -they do is the same as documented in @ref{Standard Procedures, R4RS, , -r4rs, R4RS}. But I will point out that when a procedure takes a +they do is the same as documented in @ref{Standard procedures, R5RS, , +r5rs, R5RS}. But I will point out that when a procedure takes a variable number of arguments (such as @code{gh_list}), you should pass the constant @var{SCM_EOL} from C to signify the end of the list. diff --git a/doc/guile-tut.texi b/doc/guile-tut.texi index 7f3d28f0a..20c73e68a 100644 --- a/doc/guile-tut.texi +++ b/doc/guile-tut.texi @@ -347,26 +347,26 @@ expression library @emph{rx}, and many more @dots{} @cindex rx So Guile has many more primitive procedures available to it than those -specified in @ref{Standard Procedures, Revised(4) Report on the -Algorithmic Language Scheme, , r4rs, Revised(4) Report on the +specified in @ref{Standard Procedures, Revised(5) Report on the +Algorithmic Language Scheme, , r5rs, Revised(5) Report on the Algorithmic Language Scheme}. On top of that, Guile will interpret almost all standard Scheme programs. The only incompatible difference -between the basic Guile language and R4RS Scheme is that Guile is case -sensitive, whereas R4RS is case insensitive. We hope that few people +between the basic Guile language and R5RS Scheme is that Guile is case +sensitive, whereas R5RS is case insensitive. We hope that few people have written Scheme programs that depend on case insensitivity. @cindex case sensitivity -@cindex Revised(4) Report on the Algorithmic Language Scheme +@cindex Revised(5) Report on the Algorithmic Language Scheme @cindex report on Scheme @cindex Scheme language - report @cindex Scheme language - definition Here is a possible view of the @emph{sum of the parts} in Guile: @cindex extensions to standard Scheme -@cindex extensions to R4RS +@cindex extensions to R5RS @cindex Scheme extensions @example -guile = standard Scheme (R4RS) - PLUS extensions to R4RS offered by SCM +guile = standard Scheme (R5RS) + PLUS extensions to R5RS offered by SCM PLUS some extra primitives offered by Guile (catch/throw) PLUS portable Scheme library (SLIB) PLUS embeddable Scheme interpreter library (libguile) diff --git a/doc/guile.texi b/doc/guile.texi index ab493753a..8feac9e85 100644 --- a/doc/guile.texi +++ b/doc/guile.texi @@ -85,10 +85,6 @@ @c * should be documented in a section on debugging or Guile internals: @c ports.c: pt-size, pt-member @c eval.c: apply:nconc2last -@c * trivial underlying implementations of R4RS functions: -@c numbers.c: $asinh, $acosh, $atanh, $sqrt, $abs, $exp, $log, $sin, -@c $cos, $tan, $asin, $acos, $atan, $sinh, $cosh, $tanh, $expt, -@c $atan2 @c @c Thanks. -twp @@ -144,7 +140,7 @@ by the Free Software Foundation. @sp 10 @comment The title is printed in a large font. @title Guile Reference Manual -@subtitle $Id: guile.texi,v 1.3 2001-04-09 16:16:09 mgrabmue Exp $ +@subtitle $Id: guile.texi,v 1.4 2001-04-22 14:56:52 ossau Exp $ @subtitle For use with Guile @value{VERSION} @author Mark Galassi @author Cygnus Solution and Los Alamos National Laboratory diff --git a/doc/scheme-data.texi b/doc/scheme-data.texi index 70a7614a3..88b331a28 100755 --- a/doc/scheme-data.texi +++ b/doc/scheme-data.texi @@ -2351,7 +2351,7 @@ standard case is lower case: @deffn primitive symbol->string s Return the name of @var{symbol} as a string. If the symbol was part of an object returned as the value of a literal expression -(section @pxref{Literal expressions,,,r4rs, The Revised^4 +(section @pxref{Literal expressions,,,r5rs, The Revised^5 Report on Scheme}) or by a call to the @code{read} procedure, and its name contains alphabetic characters, then the string returned will contain characters in the implementation's @@ -2544,7 +2544,7 @@ return @code{#f} Keywords are self-evaluating objects with a convenient read syntax that makes them easy to type. -Guile's keyword support conforms to R4RS, and adds a (switchable) read +Guile's keyword support conforms to R5RS, and adds a (switchable) read syntax extension to permit keywords to begin with @code{:} as well as @code{#:}. @@ -2688,9 +2688,9 @@ expression, keywords are self-quoting objects. If the @code{keyword} read option is set to @code{'prefix}, Guile also recognizes the alternative read syntax @code{:NAME}. Otherwise, tokens -of the form @code{:NAME} are read as symbols, as required by R4RS. +of the form @code{:NAME} are read as symbols, as required by R5RS. -To enable and disable the alternative non-R4RS keyword syntax, you use +To enable and disable the alternative non-R5RS keyword syntax, you use the @code{read-options} procedure documented in @ref{General option interface} and @ref{Reader options}. @@ -3058,7 +3058,7 @@ if the last argument is not a proper list. @deffn primitive append! . lists A destructive version of @code{append} (@pxref{Pairs and -Lists,,,r4rs, The Revised^4 Report on Scheme}). The cdr field +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. @@ -3072,8 +3072,8 @@ in reverse order. @c NJFIXME explain new_tail @deffn primitive reverse! lst [new_tail] -A destructive version of @code{reverse} (@pxref{Pairs and Lists,,,r4rs, -The Revised^4 Report on Scheme}). The cdr of each cell in @var{lst} is +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. diff --git a/doc/scheme-evaluation.texi b/doc/scheme-evaluation.texi index 975787909..e1541bf70 100644 --- a/doc/scheme-evaluation.texi +++ b/doc/scheme-evaluation.texi @@ -315,7 +315,7 @@ list @code{("" ".scm")}. @deffn primitive promise? obj Return true if @var{obj} is a promise, i.e. a delayed computation -(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}). +(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}). @end deffn @rnindex force diff --git a/doc/scheme-io.texi b/doc/scheme-io.texi index 547ee9816..69d005c4f 100644 --- a/doc/scheme-io.texi +++ b/doc/scheme-io.texi @@ -560,7 +560,6 @@ requested, @code{open-file} throws an exception. @end deffn @rnindex open-input-file -@c begin (scm-doc-string "r4rs.scm" "open-input-file") @deffn procedure open-input-file filename Open @var{filename} for input. Equivalent to @smalllisp @@ -569,7 +568,6 @@ Open @var{filename} for input. Equivalent to @end deffn @rnindex open-output-file -@c begin (scm-doc-string "r4rs.scm" "open-output-file") @deffn procedure open-output-file filename Open @var{filename} for output. Equivalent to @smalllisp @@ -578,7 +576,6 @@ Open @var{filename} for output. Equivalent to @end deffn @rnindex call-with-input-file -@c begin (scm-doc-string "r4rs.scm" "call-with-input-file") @deffn procedure call-with-input-file file proc @var{proc} should be a procedure of one argument, and @var{file} should be a string naming a file. The file must already exist. These @@ -592,7 +589,6 @@ never again be used for a read or write operation. @end deffn @rnindex call-with-output-file -@c begin (scm-doc-string "r4rs.scm" "call-with-output-file") @deffn procedure call-with-output-file file proc @var{proc} should be a procedure of one argument, and @var{file} should be a string naming a file. The behaviour is unspecified if the file @@ -606,7 +602,6 @@ port will never again be used for a read or write operation. @end deffn @rnindex with-input-from-file -@c begin (scm-doc-string "r4rs.scm" "with-input-from-file") @deffn procedure with-input-from-file file thunk @var{thunk} must be a procedure of no arguments, and @var{file} must be a string naming a file. The file must already exist. The file is opened @@ -620,7 +615,6 @@ dependent. @end deffn @rnindex with-output-to-file -@c begin (scm-doc-string "r4rs.scm" "with-output-to-file") @deffn procedure with-output-to-file file thunk @var{thunk} must be a procedure of no arguments, and @var{file} must be a string naming a file. The effect is unspecified if the file already @@ -633,7 +627,6 @@ used to escape from the continuation of these procedures, their behavior is implementation dependent. @end deffn -@c begin (scm-doc-string "r4rs.scm" "with-error-to-file") @deffn procedure with-error-to-file file thunk @var{thunk} must be a procedure of no arguments, and @var{file} must be a string naming a file. The effect is unspecified if the file already @@ -689,14 +682,12 @@ created input port from which @var{string}'s contents may be read. The value yielded by the @var{proc} is returned. @end deffn -@c begin (scm-doc-string "r4rs.scm" "with-output-to-string") @deffn procedure with-output-to-string thunk Calls the zero-argument procedure @var{thunk} with the current output port set temporarily to a new string port. It returns a string composed of the characters written to the current output. @end deffn -@c begin (scm-doc-string "r4rs.scm" "with-input-from-string") @deffn procedure with-input-from-string string thunk Calls the zero-argument procedure @var{thunk} with the current input port set temporarily to a string port opened on the specified @@ -758,7 +749,7 @@ procedures. For an input-only port only elements 3 and 4 need be procedures. Thunks 2 and 4 can instead be @code{#f} if there is no useful operation for them to perform. If thunk 3 returns @code{#f} or an @code{eof-object} -(@pxref{Input, eof-object?, ,r4rs, The Revised^4 Report on +(@pxref{Input, eof-object?, ,r5rs, The Revised^5 Report on Scheme}) it indicates that the port has reached end-of-file. For example: @lisp diff --git a/doc/scheme-modules.texi b/doc/scheme-modules.texi index 1cdc6445c..5aa23be8c 100644 --- a/doc/scheme-modules.texi +++ b/doc/scheme-modules.texi @@ -46,7 +46,7 @@ clutter the global name space. @node Scheme and modules @section Scheme and modules -Scheme, as defined in R4RS, does @emph{not} have a module system at all. +Scheme, as defined in R5RS, does @emph{not} have a module system at all. Aubrey Jaffer, mostly to support his portable Scheme library SLIB, implemented a provide/require mechanism for many Scheme implementations. From 2a0ef8b74aabc5535d17a58935bf6c18f7ae4abf Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 22 Apr 2001 15:53:44 +0000 Subject: [PATCH 0852/2047] * configure.in: check for inet_pton and inet_ntop. --- ChangeLog | 4 ++++ configure.in | 3 ++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 6ea0c9c9c..ade7ea588 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2001-04-22 Gary Houston + + * configure.in: check for inet_pton and inet_ntop. + 2001-04-20 Gary Houston * acconfig.h: include HAVE_SIN6_SCOPE_ID. diff --git a/configure.in b/configure.in index 49e58231d..6d7b617c2 100644 --- a/configure.in +++ b/configure.in @@ -249,7 +249,8 @@ AC_CHECK_FUNCS(sethostent gethostent endhostent dnl setprotoent getprotoent endprotoent dnl setservent getservent endservent dnl getnetbyaddr getnetbyname dnl - inet_lnaof inet_makeaddr inet_netof hstrerror) + inet_lnaof inet_makeaddr inet_netof hstrerror dnl + inet_pton inet_ntop) dnl Some systems do not declare this. Some systems do declare it, as a dnl macro. With cygwin it may be in a DLL. From 66c73b76544337c70d3b8f14748d937c2524c52d Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 22 Apr 2001 16:05:21 +0000 Subject: [PATCH 0853/2047] * net_db.c: remove bogus "close" declaration. (inet_aton declaration, scm_inet_aton, scm_inet_ntoa, scm_inet_netof, scm_lnaof, scm_inet_makeaddr, INADDR_ANY etc.): moved to socket.c. * net_db.h: declarations moved too. * socket.c (scm_htonl, scm_ntohl): use uint32_t instead of unsigned long. (ipv6_net_to_num, ipv6_num_to_net): new static procedures. (VALIDATE_INET6): new macro. (scm_inet_pton, scm_inet_ntop): new procedures, implementing inet-pton and inet-ntop. (scm_fill_sockaddr): use VALIDATE_INET6 and ipv6_num_to_net. (scm_addr_vector): use ipv6_net_to_num. --- libguile/ChangeLog | 17 +++ libguile/net_db.c | 125 +-------------- libguile/net_db.h | 14 +- libguile/socket.c | 367 +++++++++++++++++++++++++++++++++++---------- libguile/socket.h | 16 +- 5 files changed, 321 insertions(+), 218 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 566c8d415..5c5584f16 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,20 @@ +2001-04-22 Gary Houston + + * net_db.c: remove bogus "close" declaration. + (inet_aton declaration, scm_inet_aton, scm_inet_ntoa, + scm_inet_netof, scm_lnaof, scm_inet_makeaddr, INADDR_ANY etc.): + moved to socket.c. + * net_db.h: declarations moved too. + + * socket.c (scm_htonl, scm_ntohl): use uint32_t instead of unsigned + long. + (ipv6_net_to_num, ipv6_num_to_net): new static procedures. + (VALIDATE_INET6): new macro. + (scm_inet_pton, scm_inet_ntop): new procedures, implementing + inet-pton and inet-ntop. + (scm_fill_sockaddr): use VALIDATE_INET6 and ipv6_num_to_net. + (scm_addr_vector): use ipv6_net_to_num. + 2001-04-21 Dirk Herrmann * eq.c (scm_equal_p), ramap.c (scm_init_ramap): Don't compute the diff --git a/libguile/net_db.c b/libguile/net_db.c index 183a01f76..a2660e2d8 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -71,122 +71,12 @@ #include #include - - -#ifndef STDC_HEADERS -int close (); -#endif /* STDC_HEADERS */ - -#ifndef HAVE_INET_ATON -/* for our definition in inet_aton.c, not usually needed. */ -extern int inet_aton (); -#endif - #ifndef HAVE_H_ERRNO /* h_errno not found in netdb.h, maybe this will help. */ extern int h_errno; #endif -SCM_DEFINE (scm_inet_aton, "inet-aton", 1, 0, 0, - (SCM address), - "Converts a string containing an Internet host address in the\n" - "traditional dotted decimal notation into an integer.\n" - "@lisp\n" - "(inet-aton \"127.0.0.1\") @result{} 2130706433\n" - "@end lisp") -#define FUNC_NAME s_scm_inet_aton -{ - struct in_addr soka; - - SCM_VALIDATE_STRING (1, address); - SCM_STRING_COERCE_0TERMINATION_X (address); - if (inet_aton (SCM_STRING_CHARS (address), &soka) == 0) - SCM_MISC_ERROR ("bad address", SCM_EOL); - return scm_ulong2num (ntohl (soka.s_addr)); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_inet_ntoa, "inet-ntoa", 1, 0, 0, - (SCM inetid), - "Converts an integer Internet host address into a string with\n" - "the traditional dotted decimal representation.\n" - "@lisp\n" - "(inet-ntoa 2130706433) @result{} \"127.0.0.1\"\n" - "@end lisp") -#define FUNC_NAME s_scm_inet_ntoa -{ - struct in_addr addr; - char *s; - SCM answer; - addr.s_addr = htonl (SCM_NUM2ULONG (1, inetid)); - s = inet_ntoa (addr); - answer = scm_makfromstr (s, strlen (s), 0); - return answer; -} -#undef FUNC_NAME - -#ifdef HAVE_INET_NETOF -SCM_DEFINE (scm_inet_netof, "inet-netof", 1, 0, 0, - (SCM address), - "Return the network number part of the given integer Internet\n" - "address.\n" - "@lisp\n" - "(inet-netof 2130706433) @result{} 127\n" - "@end lisp") -#define FUNC_NAME s_scm_inet_netof -{ - struct in_addr addr; - addr.s_addr = htonl (SCM_NUM2ULONG (1, address)); - return scm_ulong2num ((unsigned long) inet_netof (addr)); -} -#undef FUNC_NAME -#endif - -#ifdef HAVE_INET_LNAOF -SCM_DEFINE (scm_lnaof, "inet-lnaof", 1, 0, 0, - (SCM address), - "Return the local-address-with-network part of the given\n" - "Internet address.\n" - "@lisp\n" - "(inet-lnaof 2130706433) @result{} 1\n" - "@end lisp") -#define FUNC_NAME s_scm_lnaof -{ - struct in_addr addr; - addr.s_addr = htonl (SCM_NUM2ULONG (1, address)); - return scm_ulong2num ((unsigned long) inet_lnaof (addr)); -} -#undef FUNC_NAME -#endif - -#ifdef HAVE_INET_MAKEADDR -SCM_DEFINE (scm_inet_makeaddr, "inet-makeaddr", 2, 0, 0, - (SCM net, SCM lna), - "Makes an Internet host address by combining the network number\n" - "@var{net} with the local-address-within-network number\n" - "@var{lna}.\n" - "@lisp\n" - "(inet-makeaddr 127 1) @result{} 2130706433\n" - "@end lisp") -#define FUNC_NAME s_scm_inet_makeaddr -{ - struct in_addr addr; - unsigned long netnum; - unsigned long lnanum; - -#if 0 /* GJB:FIXME:: */ - SCM_VALIDATE_INUM_COPY (1,net,netnum); - SCM_VALIDATE_INUM_COPY (2,lna,lnanum); -#else - netnum = SCM_NUM2ULONG (1, net); - lnanum = SCM_NUM2ULONG (2, lna); -#endif - addr = inet_makeaddr (netnum, lnanum); - return scm_ulong2num (ntohl (addr.s_addr)); -} -#undef FUNC_NAME -#endif + SCM_SYMBOL (scm_host_not_found_key, "host-not-found"); SCM_SYMBOL (scm_try_again_key, "try-again"); @@ -554,19 +444,6 @@ SCM_DEFINE (scm_setserv, "setserv", 0, 1, 0, void scm_init_net_db () { -#ifdef INADDR_ANY - scm_sysintern ("INADDR_ANY", scm_ulong2num (INADDR_ANY)); -#endif -#ifdef INADDR_BROADCAST - scm_sysintern ("INADDR_BROADCAST", scm_ulong2num (INADDR_BROADCAST)); -#endif -#ifdef INADDR_NONE - scm_sysintern ("INADDR_NONE", scm_ulong2num (INADDR_NONE)); -#endif -#ifdef INADDR_LOOPBACK - scm_sysintern ("INADDR_LOOPBACK", scm_ulong2num (INADDR_LOOPBACK)); -#endif - scm_add_feature ("net-db"); #ifndef SCM_MAGIC_SNARFER #include "libguile/net_db.x" diff --git a/libguile/net_db.h b/libguile/net_db.h index 74c7d7c04..f5fdeba07 100644 --- a/libguile/net_db.h +++ b/libguile/net_db.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef NETDBH -#define NETDBH -/* Copyright (C) 1995, 2000 Free Software Foundation, Inc. +#ifndef SCM_NETDBH +#define SCM_NETDBH +/* Copyright (C) 1995, 2000, 2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -51,12 +51,6 @@ -extern SCM scm_gethost (SCM name); -extern SCM scm_inet_aton (SCM address); -extern SCM scm_inet_ntoa (SCM inetid); -extern SCM scm_inet_netof (SCM address); -extern SCM scm_lnaof (SCM address); -extern SCM scm_inet_makeaddr (SCM net, SCM lna); extern SCM scm_getnet (SCM name); extern SCM scm_getproto (SCM name); extern SCM scm_getserv (SCM name, SCM proto); @@ -66,7 +60,7 @@ extern SCM scm_setproto (SCM arg); extern SCM scm_setserv (SCM arg); extern void scm_init_net_db (void); -#endif /* NETDBH */ +#endif /* SCM_NETDBH */ /* Local Variables: diff --git a/libguile/socket.c b/libguile/socket.c index 2c5586b5f..66f8d19cc 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -119,11 +119,12 @@ SCM_DEFINE (scm_ntohs, "ntohs", 1, 0, 0, SCM_DEFINE (scm_htonl, "htonl", 1, 0, 0, (SCM in), "Return a new integer from @var{value} by converting from host\n" - "to network order. @var{value} must be within the range of a C\n" - "unsigned long integer.") + "to network order. @var{value} must be within the range of a\n" + "32 bit unsigned integer.") #define FUNC_NAME s_scm_htonl { - unsigned long c_in = SCM_NUM2ULONG (1, in); + uint32_t c_in = SCM_NUM2ULONG (1, in); + return scm_ulong2num (htonl (c_in)); } #undef FUNC_NAME @@ -132,14 +133,278 @@ SCM_DEFINE (scm_ntohl, "ntohl", 1, 0, 0, (SCM in), "Return a new integer from @var{value} by converting from\n" "network to host order. @var{value} must be within the range of\n" - "a C unsigned long integer.") + "a 32 bit unsigned integer.") #define FUNC_NAME s_scm_ntohl { - unsigned long c_in = SCM_NUM2ULONG (1, in); + uint32_t c_in = SCM_NUM2ULONG (1, in); + return scm_ulong2num (ntohl (c_in)); } #undef FUNC_NAME +#ifndef HAVE_INET_ATON +/* for our definition in inet_aton.c, not usually needed. */ +extern int inet_aton (); +#endif + +SCM_DEFINE (scm_inet_aton, "inet-aton", 1, 0, 0, + (SCM address), + "Converts a string containing an Internet host address in the\n" + "traditional dotted decimal notation into an integer.\n" + "@lisp\n" + "(inet-aton \"127.0.0.1\") @result{} 2130706433\n" + "@end lisp") +#define FUNC_NAME s_scm_inet_aton +{ + struct in_addr soka; + + SCM_VALIDATE_STRING (1, address); + SCM_STRING_COERCE_0TERMINATION_X (address); + if (inet_aton (SCM_STRING_CHARS (address), &soka) == 0) + SCM_MISC_ERROR ("bad address", SCM_EOL); + return scm_ulong2num (ntohl (soka.s_addr)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_inet_ntoa, "inet-ntoa", 1, 0, 0, + (SCM inetid), + "Converts an integer Internet host address into a string with\n" + "the traditional dotted decimal representation.\n" + "@lisp\n" + "(inet-ntoa 2130706433) @result{} \"127.0.0.1\"\n" + "@end lisp") +#define FUNC_NAME s_scm_inet_ntoa +{ + struct in_addr addr; + char *s; + SCM answer; + addr.s_addr = htonl (SCM_NUM2ULONG (1, inetid)); + s = inet_ntoa (addr); + answer = scm_makfromstr (s, strlen (s), 0); + return answer; +} +#undef FUNC_NAME + +#ifdef HAVE_INET_NETOF +SCM_DEFINE (scm_inet_netof, "inet-netof", 1, 0, 0, + (SCM address), + "Return the network number part of the given integer Internet\n" + "address.\n" + "@lisp\n" + "(inet-netof 2130706433) @result{} 127\n" + "@end lisp") +#define FUNC_NAME s_scm_inet_netof +{ + struct in_addr addr; + addr.s_addr = htonl (SCM_NUM2ULONG (1, address)); + return scm_ulong2num ((unsigned long) inet_netof (addr)); +} +#undef FUNC_NAME +#endif + +#ifdef HAVE_INET_LNAOF +SCM_DEFINE (scm_lnaof, "inet-lnaof", 1, 0, 0, + (SCM address), + "Return the local-address-with-network part of the given\n" + "Internet address.\n" + "@lisp\n" + "(inet-lnaof 2130706433) @result{} 1\n" + "@end lisp") +#define FUNC_NAME s_scm_lnaof +{ + struct in_addr addr; + addr.s_addr = htonl (SCM_NUM2ULONG (1, address)); + return scm_ulong2num ((unsigned long) inet_lnaof (addr)); +} +#undef FUNC_NAME +#endif + +#ifdef HAVE_INET_MAKEADDR +SCM_DEFINE (scm_inet_makeaddr, "inet-makeaddr", 2, 0, 0, + (SCM net, SCM lna), + "Makes an Internet host address by combining the network number\n" + "@var{net} with the local-address-within-network number\n" + "@var{lna}.\n" + "@lisp\n" + "(inet-makeaddr 127 1) @result{} 2130706433\n" + "@end lisp") +#define FUNC_NAME s_scm_inet_makeaddr +{ + struct in_addr addr; + unsigned long netnum; + unsigned long lnanum; + + netnum = SCM_NUM2ULONG (1, net); + lnanum = SCM_NUM2ULONG (2, lna); + addr = inet_makeaddr (netnum, lnanum); + return scm_ulong2num (ntohl (addr.s_addr)); +} +#undef FUNC_NAME +#endif + +/* flip a 128 bit IPv6 address between host and network order. */ +#ifdef WORDS_BIGENDIAN +#define FLIP_NET_HOST_128(addr) +#else +#define FLIP_NET_HOST_128(addr)\ +{\ + int i;\ + \ + for (i = 0; i < 8; i++)\ + {\ + char c = (addr)[i];\ + \ + (addr)[i] = (addr)[15 - i];\ + (addr)[15 - i] = c;\ + }\ +} +#endif + +/* convert a 128 bit IPv6 address in network order to a host ordered + SCM integer. */ +static SCM ipv6_net_to_num (const char *src) +{ + int big_digits = 128 / SCM_BITSPERDIG; + const int bytes_per_dig = SCM_BITSPERDIG / 8; + char addr[16]; + char *ptr = addr; + SCM result; + + memcpy (addr, src, 16); + /* get rid of leading zeros. */ + while (big_digits > 0) + { + long test = 0; + + memcpy (&test, ptr, bytes_per_dig); + if (test != 0) + break; + ptr += bytes_per_dig; + big_digits--; + } + FLIP_NET_HOST_128 (addr); + if (big_digits * bytes_per_dig <= sizeof (unsigned long)) + { + /* this is just so that we use INUM where possible. */ + unsigned long l_addr; + + memcpy (&l_addr, addr, sizeof (unsigned long)); + result = scm_ulong2num (l_addr); + } + else + { + result = scm_mkbig (big_digits, 0); + memcpy (SCM_BDIGITS (result), addr, big_digits * bytes_per_dig); + } + return result; +} + +/* convert a host ordered SCM integer to a 128 bit IPv6 address in + network order. */ +static void ipv6_num_to_net (SCM src, char *dst) +{ + if (SCM_INUMP (src)) + { + uint32_t addr = htonl (SCM_INUM (src)); + + memset (dst, 0, 12); + memcpy (dst + 12, &addr, 4); + } + else + { + memset (dst, 0, 16); + memcpy (dst, SCM_BDIGITS (src), + SCM_NUMDIGS (src) * (SCM_BITSPERDIG / 8)); + FLIP_NET_HOST_128 (dst); + } +} + +/* check that an SCM variable contains an IPv6 integer address. */ +#define VALIDATE_INET6(which_arg, address)\ + if (SCM_INUMP (address))\ + SCM_ASSERT_RANGE (which_arg, address, SCM_INUM (address) >= 0);\ + else\ + {\ + SCM_VALIDATE_BIGINT (which_arg, address);\ + SCM_ASSERT_RANGE (which_arg, address,\ + !SCM_BIGSIGN (address)\ + && (SCM_BITSPERDIG\ + * SCM_NUMDIGS (address) <= 128));\ + } + +#ifdef HAVE_INET_PTON +SCM_DEFINE (scm_inet_pton, "inet-pton", 2, 0, 0, + (SCM family, SCM address), + "Convert a printable string network address into\n" + "an integer. Note that unlike the C version of this function,\n" + "the result is an integer with normal host byte ordering.\n" + "@var{family} can be @code{AF_INET} or @code{AF_INET6}. e.g.,\n" + "@lisp\n" + "(inet-pton AF_INET "127.0.0.1") @result{} 2130706433\n" + "(inet-pton AF_INET6 "::1") @result{} 1\n" + "@end lisp") +#define FUNC_NAME s_scm_inet_pton +{ + int af; + char *src; + char dst[16]; + int rv; + + SCM_VALIDATE_INUM_COPY (1, family, af); + SCM_ASSERT_RANGE (1, family, af == AF_INET || af == AF_INET6); + SCM_VALIDATE_STRING_COPY (2, address, src); + rv = inet_pton (af, src, dst); + if (rv == -1) + SCM_SYSERROR; + else if (rv == 0) + SCM_MISC_ERROR ("Bad address", SCM_EOL); + if (af == AF_INET) + return scm_ulong2num (ntohl (*(uint32_t *) dst)); + else + return ipv6_net_to_num ((char *) dst); +} +#undef FUNC_NAME +#endif + +#ifdef HAVE_INET_NTOP +SCM_DEFINE (scm_inet_ntop, "inet-ntop", 2, 0, 0, + (SCM family, SCM address), + "Convert an integer network address into a printable string.\n" + "Note that unlike the C version of this function,\n" + "the input is an integer with normal host byte ordering.\n" + "@var{family} can be @code{AF_INET} or @code{AF_INET6}. e.g.,\n" + "@lisp\n" + "(inet-ntop AF_INET 2130706433) @result{} "127.0.0.1"\n" + "(inet-ntop AF_INET6 (- (expt 2 128) 1)) @result{}\n" + "ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff\n" + "@end lisp") +#define FUNC_NAME s_scm_inet_ntop +{ + int af; +#ifdef INET6_ADDRSTRLEN + char dst[INET6_ADDRSTRLEN]; +#else + char dst[46]; +#endif + char addr6[16]; + + SCM_VALIDATE_INUM_COPY (1, family, af); + SCM_ASSERT_RANGE (1, family, af == AF_INET || af == AF_INET6); + if (af == AF_INET) + *(uint32_t *) addr6 = htonl (SCM_NUM2ULONG (2, address)); + else + { + VALIDATE_INET6 (2, address); + ipv6_num_to_net (address, addr6); + } + if (inet_ntop (af, &addr6, dst, sizeof dst) == NULL) + SCM_SYSERROR; + return scm_makfrom0str (dst); +} +#undef FUNC_NAME +#endif + SCM_SYMBOL (sym_socket, "socket"); #define SCM_SOCK_FD_TO_PORT(fd) scm_fdes_to_port (fd, "r+0", sym_socket) @@ -366,24 +631,6 @@ SCM_DEFINE (scm_setsockopt, "setsockopt", 4, 0, 0, } #undef FUNC_NAME -/* flip a 128 bit IPv6 address between host and network order. */ -#ifdef WORDS_BIGENDIAN -#define FLIP_NET_HOST_128(addr) -#else -#define FLIP_NET_HOST_128(addr)\ -{\ - int i;\ - \ - for (i = 0; i < 8; i++)\ - {\ - char c = (addr)[i];\ - \ - (addr)[i] = (addr)[15 - i];\ - (addr)[15 - i] = c;\ - }\ -} -#endif - SCM_DEFINE (scm_shutdown, "shutdown", 2, 0, 0, (SCM sock, SCM how), "Sockets can be closed simply by using @code{close-port}. The\n" @@ -462,16 +709,7 @@ scm_fill_sockaddr (int fam, SCM address, SCM *args, int which_arg, unsigned long flowinfo = 0; unsigned long scope_id = 0; - if (SCM_INUMP (address)) - SCM_ASSERT_RANGE (which_arg, address, SCM_INUM (address) >= 0); - else - { - SCM_VALIDATE_BIGINT (which_arg, address); - SCM_ASSERT_RANGE (which_arg, address, - !SCM_BIGSIGN (address) - && (SCM_BITSPERDIG - * SCM_NUMDIGS (address) <= 128)); - } + VALIDATE_INET6 (which_arg, address); SCM_VALIDATE_CONS (which_arg + 1, *args); SCM_VALIDATE_INUM_COPY (which_arg + 1, SCM_CAR (*args), port); *args = SCM_CDR (*args); @@ -493,20 +731,7 @@ scm_fill_sockaddr (int fam, SCM address, SCM *args, int which_arg, soka->sin6_len = sizeof (struct sockaddr_in6); #endif soka->sin6_family = AF_INET6; - if (SCM_INUMP (address)) - { - uint32_t addr = htonl (SCM_INUM (address)); - - memset (soka->sin6_addr.s6_addr, 0, 12); - memcpy (soka->sin6_addr.s6_addr + 12, &addr, 4); - } - else - { - memset (soka->sin6_addr.s6_addr, 0, 16); - memcpy (soka->sin6_addr.s6_addr, SCM_BDIGITS (address), - SCM_NUMDIGS (address) * (SCM_BITSPERDIG / 8)); - FLIP_NET_HOST_128 (soka->sin6_addr.s6_addr); - } + ipv6_num_to_net (address, soka->sin6_addr.s6_addr); soka->sin6_port = htons (port); soka->sin6_flowinfo = flowinfo; #ifdef HAVE_SIN6_SCOPE_ID @@ -692,43 +917,11 @@ scm_addr_vector (const struct sockaddr *address, const char *proc) case AF_INET6: { const struct sockaddr_in6 *nad = (struct sockaddr_in6 *) address; - int big_digits = 128 / SCM_BITSPERDIG; - int bytes_per_dig = SCM_BITSPERDIG / 8; - char addr[16]; - char *ptr = addr; - SCM scm_addr; - - memcpy (addr, nad->sin6_addr.s6_addr, 16); - /* get rid of leading zeros. */ - while (big_digits > 0) - { - long test = 0; - - memcpy (&test, ptr, bytes_per_dig); - if (test != 0) - break; - ptr += bytes_per_dig; - big_digits--; - } - FLIP_NET_HOST_128 (addr); - if (big_digits * bytes_per_dig <= sizeof (unsigned long)) - { - /* this is just so that we use INUM where possible. */ - unsigned long l_addr; - - memcpy (&l_addr, addr, sizeof (unsigned long)); - scm_addr = scm_ulong2num (l_addr); - } - else - { - scm_addr = scm_mkbig (big_digits, 0); - memcpy (SCM_BDIGITS (scm_addr), addr, big_digits * bytes_per_dig); - } result = scm_c_make_vector (5, SCM_UNSPECIFIED); ve = SCM_VELTS (result); ve[0] = scm_ulong2num ((unsigned long) fam); - ve[1] = scm_addr; + ve[1] = ipv6_net_to_num (nad->sin6_addr.s6_addr); ve[2] = scm_ulong2num ((unsigned long) ntohs (nad->sin6_port)); ve[3] = scm_ulong2num ((unsigned long) nad->sin6_flowinfo); #ifdef HAVE_SIN6_SCOPE_ID @@ -1075,6 +1268,20 @@ scm_init_socket () scm_sysintern ("PF_INET6", SCM_MAKINUM (PF_INET6)); #endif + /* standard addresses. */ +#ifdef INADDR_ANY + scm_sysintern ("INADDR_ANY", scm_ulong2num (INADDR_ANY)); +#endif +#ifdef INADDR_BROADCAST + scm_sysintern ("INADDR_BROADCAST", scm_ulong2num (INADDR_BROADCAST)); +#endif +#ifdef INADDR_NONE + scm_sysintern ("INADDR_NONE", scm_ulong2num (INADDR_NONE)); +#endif +#ifdef INADDR_LOOPBACK + scm_sysintern ("INADDR_LOOPBACK", scm_ulong2num (INADDR_LOOPBACK)); +#endif + /* socket types. */ #ifdef SOCK_STREAM scm_sysintern ("SOCK_STREAM", SCM_MAKINUM (SOCK_STREAM)); diff --git a/libguile/socket.h b/libguile/socket.h index d2b93d60e..f88b9229e 100644 --- a/libguile/socket.h +++ b/libguile/socket.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef SOCKETH -#define SOCKETH -/* Copyright (C) 1995, 1996, 1997, 2000 Free Software Foundation, Inc. +#ifndef SCM_SOCKETH +#define SCM_SOCKETH +/* Copyright (C) 1995, 1996, 1997, 2000, 2001 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 @@ -52,6 +52,14 @@ extern SCM scm_htons (SCM in); extern SCM scm_ntohs (SCM in); extern SCM scm_htonl (SCM in); extern SCM scm_ntohl (SCM in); +extern SCM scm_gethost (SCM name); +extern SCM scm_inet_aton (SCM address); +extern SCM scm_inet_ntoa (SCM inetid); +extern SCM scm_inet_netof (SCM address); +extern SCM scm_lnaof (SCM address); +extern SCM scm_inet_makeaddr (SCM net, SCM lna); +extern SCM scm_inet_pton (SCM family, SCM address); +extern SCM scm_inet_ntop (SCM family, SCM address); extern SCM scm_socket (SCM family, SCM style, SCM proto); extern SCM scm_socketpair (SCM family, SCM style, SCM proto); extern SCM scm_getsockopt (SCM sfd, SCM level, SCM optname); @@ -69,7 +77,7 @@ extern SCM scm_recvfrom (SCM sockfd, SCM buff_or_size, SCM flags, SCM offset, SC extern SCM scm_sendto (SCM sockfd, SCM message, SCM fam, SCM address, SCM args_and_flags); extern void scm_init_socket (void); -#endif /* SOCKETH */ +#endif /* SCM_SOCKETH */ /* Local Variables: From 5bef627d6153c7dc5aa208e2e44ad1b009266a0f Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 22 Apr 2001 16:06:31 +0000 Subject: [PATCH 0854/2047] *** empty log message *** --- NEWS | 39 ++++++++++++++++++++++++++++----------- 1 file changed, 28 insertions(+), 11 deletions(-) diff --git a/NEWS b/NEWS index e138e560b..4b5e76bf1 100644 --- a/NEWS +++ b/NEWS @@ -231,15 +231,6 @@ work on the top level. The forms `define-public' and behave just like `define' and `defmacro', respectively, when they are used in a lexical environment. -** `port-for-each' makes an additional guarantee. - -From the docstring: @var{proc} is applied exactly once to every port -that exists in the system at the time @var{port-for-each} is invoked. -Changes to the port table while @var{port-for-each} is running have no -effect as far as @var{port-for-each} is concerned. - -This guarantee is important to make (ice-9 popen) work reliable. - ** The semantics of guardians have changed. The changes are for the most part compatible. An important criterion @@ -427,8 +418,12 @@ Determines whether a given object is a port that is related to a file. ** New function: port-for-each proc -Apply PROC to each port in the Guile port table in turn. The -return value is unspecified. + Apply PROC to each port in the Guile port table in turn. The + return value is unspecified. More specifically, PROC is applied + exactly once to every port that exists in the system at the time + PORT-FOR-EACH is invoked. Changes to the port table while + PORT-FOR-EACH is running have no effect as far as PORT-FOR-EACH is + concerned. ** New function: dup2 oldfd newfd @@ -506,6 +501,28 @@ Return the contents of an output string port. Return the argument. +** socket, connect, accept etc., now have support for IPv6. IPv6 addresses + are represented in Scheme as integers with normal host byte ordering. + +** New function: inet-pton family address + + Convert a printable string network address into an integer. Note + that unlike the C version of this function, the result is an + integer with normal host byte ordering. FAMILY can be `AF_INET' + or `AF_INET6'. e.g., + (inet-pton AF_INET "127.0.0.1") => 2130706433 + (inet-pton AF_INET6 "::1") => 1 + +** New function: inet-ntop family address + + Convert an integer network address into a printable string. Note + that unlike the C version of this function, the input is an + integer with normal host byte ordering. FAMILY can be `AF_INET' + or `AF_INET6'. e.g., + (inet-ntop AF_INET 2130706433) => "127.0.0.1" + (inet-ntop AF_INET6 (- (expt 2 128) 1)) => + ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff + ** Deprecated: id Use `identity' instead. From 72ad43dc954665c7925e7dca41b160ec00208b48 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sun, 22 Apr 2001 16:34:28 +0000 Subject: [PATCH 0855/2047] * Automatic docstring updates (for IPv6). --- doc/ChangeLog | 3 ++ doc/maint/guile.texi | 113 +++++++++++++++++++++++-------------------- doc/posix.texi | 27 +++++++---- 3 files changed, 80 insertions(+), 63 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index e941a0b87..e3cb26f13 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,5 +1,8 @@ 2001-04-22 Neil Jerram + * posix.texi (Network Sockets and Communication): Automatic + docstring updates for `socket' and `connect'. (For IPV6 support.) + * scheme-io.texi: Remove old docstring comments referring to r4rs.scm. diff --git a/doc/maint/guile.texi b/doc/maint/guile.texi index d0f54e487..13d681dad 100644 --- a/doc/maint/guile.texi +++ b/doc/maint/guile.texi @@ -442,13 +442,13 @@ Return the source of the procedure @var{proc}. @end deffn procedure-environment -@c snarfed from debug.c:456 +@c snarfed from debug.c:455 @deffn primitive procedure-environment proc Return the environment of the procedure @var{proc}. @end deffn local-eval -@c snarfed from debug.c:488 +@c snarfed from debug.c:487 @deffn primitive local-eval exp [env] Evaluate @var{exp} in its environment. If @var{env} is supplied, it is the environment in which to evaluate @var{exp}. Otherwise, @@ -457,7 +457,7 @@ is implicit). @end deffn debug-object? -@c snarfed from debug.c:575 +@c snarfed from debug.c:574 @deffn primitive debug-object? obj Return @code{#t} if @var{obj} is a debug object. @end deffn @@ -1475,7 +1475,7 @@ If @var{suffix} is privided, and is equal to the end of @end deffn make-fluid -@c snarfed from fluids.c:128 +@c snarfed from fluids.c:124 @deffn primitive make-fluid Return a newly created fluid. Fluids are objects of a certain type (a smob) that can hold one SCM @@ -1487,14 +1487,14 @@ in its own dynamic root, you can use fluids for thread local storage. @end deffn fluid? -@c snarfed from fluids.c:142 +@c snarfed from fluids.c:137 @deffn primitive fluid? obj Return @code{#t} iff @var{obj} is a fluid; otherwise, return @code{#f}. @end deffn fluid-ref -@c snarfed from fluids.c:153 +@c snarfed from fluids.c:148 @deffn primitive fluid-ref fluid Return the value associated with @var{fluid} in the current dynamic root. If @var{fluid} has not been set, then return @@ -1502,13 +1502,13 @@ dynamic root. If @var{fluid} has not been set, then return @end deffn fluid-set! -@c snarfed from fluids.c:170 +@c snarfed from fluids.c:165 @deffn primitive fluid-set! fluid value Set the value associated with @var{fluid} in the current dynamic root. @end deffn with-fluids* -@c snarfed from fluids.c:229 +@c snarfed from fluids.c:224 @deffn primitive with-fluids* fluids values thunk Set @var{fluids} to @var{values} temporary, and call @var{thunk}. @var{fluids} must be a list of fluids and @var{values} must be the same @@ -1601,7 +1601,7 @@ no longer accessible. @end deffn unhash-name -@c snarfed from gc.c:2303 +@c snarfed from gc.c:2306 @deffn primitive unhash-name name Flushes the glocs for @var{name}, or all glocs if @var{name} is @code{#t}. @@ -2790,7 +2790,7 @@ signalled. @end deffn procedure->syntax -@c snarfed from macros.c:61 +@c snarfed from macros.c:106 @deffn primitive procedure->syntax code Return a @dfn{macro} which, when a symbol defined to this value appears as the first symbol in an expression, returns the @@ -2799,7 +2799,7 @@ environment. @end deffn procedure->macro -@c snarfed from macros.c:84 +@c snarfed from macros.c:129 @deffn primitive procedure->macro code Return a @dfn{macro} which, when a symbol defined to this value appears as the first symbol in an expression, evaluates the @@ -2817,7 +2817,7 @@ passed to @var{code}. For example: @end deffn procedure->memoizing-macro -@c snarfed from macros.c:107 +@c snarfed from macros.c:152 @deffn primitive procedure->memoizing-macro code Return a @dfn{macro} which, when a symbol defined to this value appears as the first symbol in an expression, evaluates the @@ -2835,14 +2835,14 @@ passed to @var{proc}. For example: @end deffn macro? -@c snarfed from macros.c:119 +@c snarfed from macros.c:164 @deffn primitive macro? obj Return @code{#t} if @var{obj} is a regular macro, a memoizing macro or a syntax transformer. @end deffn macro-type -@c snarfed from macros.c:137 +@c snarfed from macros.c:182 @deffn primitive macro-type m Return one of the symbols @code{syntax}, @code{macro} or @code{macro!}, depending on whether @var{m} is a syntax @@ -2852,13 +2852,13 @@ returned. @end deffn macro-name -@c snarfed from macros.c:155 +@c snarfed from macros.c:200 @deffn primitive macro-name m Return the name of the macro @var{m}. @end deffn macro-transformer -@c snarfed from macros.c:166 +@c snarfed from macros.c:211 @deffn primitive macro-transformer m Return the transformer of the macro @var{m}. @end deffn @@ -4350,7 +4350,7 @@ and @code{print-options}. @end deffn simple-format -@c snarfed from print.c:976 +@c snarfed from print.c:909 @deffn primitive simple-format destination message . args Write @var{message} to @var{destination}, defaulting to the current output port. @@ -4366,26 +4366,26 @@ containing the formatted text. Does not add a trailing newline. @end deffn newline -@c snarfed from print.c:1041 +@c snarfed from print.c:974 @deffn primitive newline [port] Send a newline to @var{port}. @end deffn write-char -@c snarfed from print.c:1056 +@c snarfed from print.c:989 @deffn primitive write-char chr [port] Send character @var{chr} to @var{port}. @end deffn port-with-print-state -@c snarfed from print.c:1110 +@c snarfed from print.c:1043 @deffn primitive port-with-print-state port pstate Create a new port which behaves like @var{port}, but with an included print state @var{pstate}. @end deffn get-print-state -@c snarfed from print.c:1125 +@c snarfed from print.c:1058 @deffn primitive get-print-state port Return the print state of the port @var{port}. If @var{port} has no associated print state, @code{#f} is returned. @@ -4435,7 +4435,7 @@ Return @code{#t} if @var{obj} is a thunk. @end deffn procedure-documentation -@c snarfed from procs.c:283 +@c snarfed from procs.c:282 @deffn primitive procedure-documentation proc Return the documentation string associated with @code{proc}. By convention, if a procedure contains more than one expression and the @@ -4444,21 +4444,21 @@ documentation for that procedure. @end deffn procedure-with-setter? -@c snarfed from procs.c:319 +@c snarfed from procs.c:318 @deffn primitive procedure-with-setter? obj Return @code{#t} if @var{obj} is a procedure with an associated setter procedure. @end deffn make-procedure-with-setter -@c snarfed from procs.c:329 +@c snarfed from procs.c:328 @deffn primitive make-procedure-with-setter procedure setter Create a new procedure which behaves like @var{procedure}, but with the associated setter @var{setter}. @end deffn procedure -@c snarfed from procs.c:348 +@c snarfed from procs.c:347 @deffn primitive procedure proc Return the procedure of @var{proc}, which must be either a procedure with setter, or an operator struct. @@ -4978,9 +4978,9 @@ a C unsigned long integer. @deffn primitive socket family style proto Return a new socket port of the type specified by @var{family}, @var{style} and @var{protocol}. All three parameters are -integers. Typical values for @var{family} are the values of -@code{AF_UNIX} and @code{AF_INET}. Typical values for -@var{style} are the values of @code{SOCK_STREAM}, +integers. Supported values for @var{family} are +@code{AF_UNIX}, @code{AF_INET} and @code{AF_INET6}. +Typical values for @var{style} are @code{SOCK_STREAM}, @code{SOCK_DGRAM} and @code{SOCK_RAW}. @var{protocol} can be obtained from a protocol name using @code{getprotobyname}. A value of zero specifies the default @@ -5029,7 +5029,7 @@ The return value is unspecified. @end deffn shutdown -@c snarfed from socket.c:385 +@c snarfed from socket.c:403 @deffn primitive shutdown sock how Sockets can be closed simply by using @code{close-port}. The @code{shutdown} procedure allows reception or tranmission on a @@ -5051,26 +5051,33 @@ The return value is unspecified. @end deffn connect -@c snarfed from socket.c:478 +@c snarfed from socket.c:569 @deffn primitive connect sock fam address . args -Initiates a connection from @var{socket} to the address -specified by @var{address} and possibly @var{arg @dots{}}. The format -required for @var{address} -and @var{arg} @dots{} depends on the family of the socket. +Initiates a connection from a socket using a specified address +family to the address +specified by @var{address} and possibly @var{args}. +The format required for @var{address} +and @var{args} depends on the family of the socket. For a socket of family @code{AF_UNIX}, -only @code{address} is specified and must be a string with the +only @var{address} is specified and must be a string with the filename where the socket is to be created. For a socket of family @code{AF_INET}, -@code{address} must be an integer Internet host address and @var{arg} @dots{} -must be a single integer port number. +@var{address} must be an integer IPv4 host address and +@var{args} must be a single integer port number. + +For a socket of family @code{AF_INET6}, +@var{address} must be an integer IPv6 host address and +@var{args} may be up to three integers: +port [flowinfo] [scope_id], +where flowinfo and scope_id default to zero. The return value is unspecified. @end deffn bind -@c snarfed from socket.c:532 +@c snarfed from socket.c:623 @deffn primitive bind sock fam address . args Assigns an address to the socket port @var{socket}. Generally this only needs to be done for server sockets, @@ -5111,7 +5118,7 @@ The return value is unspecified. @end deffn listen -@c snarfed from socket.c:565 +@c snarfed from socket.c:656 @deffn primitive listen sock backlog This procedure enables @var{socket} to accept connection requests. @var{backlog} is an integer specifying @@ -5123,7 +5130,7 @@ The return value is unspecified. @end deffn accept -@c snarfed from socket.c:641 +@c snarfed from socket.c:793 @deffn primitive accept sock Accepts a connection on a bound, listening socket @var{socket}. If there are no pending connections in the queue, it waits until @@ -5142,7 +5149,7 @@ connection and will continue to accept new requests. @end deffn getsockname -@c snarfed from socket.c:672 +@c snarfed from socket.c:824 @deffn primitive getsockname sock Return the address of @var{socket}, in the same form as the object returned by @code{accept}. On many systems the address @@ -5150,7 +5157,7 @@ of a socket in the @code{AF_FILE} namespace cannot be read. @end deffn getpeername -@c snarfed from socket.c:699 +@c snarfed from socket.c:851 @deffn primitive getpeername sock Return the address of the socket that the socket @var{socket} is connected to, in the same form as the object returned by @@ -5159,7 +5166,7 @@ is connected to, in the same form as the object returned by @end deffn recv! -@c snarfed from socket.c:734 +@c snarfed from socket.c:886 @deffn primitive recv! sock buf [flags] Receives data from the socket port @var{socket}. @var{socket} must already be bound to the address from which data is to be received. @@ -5179,7 +5186,7 @@ any unread buffered port data is ignored. @end deffn send -@c snarfed from socket.c:763 +@c snarfed from socket.c:915 @deffn primitive send sock message [flags] Transmits the string @var{message} on the socket port @var{socket}. @var{socket} must already be bound to a destination address. The @@ -5193,7 +5200,7 @@ any unflushed buffered port data is ignored. @end deffn recvfrom! -@c snarfed from socket.c:805 +@c snarfed from socket.c:957 @deffn primitive recvfrom! sock str [flags [start [end]]] Return data from the socket port @var{socket} and also information about where the data was received from. @@ -5215,7 +5222,7 @@ descriptor: any unread buffered port data is ignored. @end deffn sendto -@c snarfed from socket.c:856 +@c snarfed from socket.c:1008 @deffn primitive sendto sock message fam address . args_and_flags Transmits the string @var{message} on the socket port @var{socket}. The destination address is specified using the @var{family}, @var{address} and @@ -5323,27 +5330,27 @@ list elements. This is a stable sort. @end deffn source-properties -@c snarfed from srcprop.c:171 +@c snarfed from srcprop.c:172 @deffn primitive source-properties obj Return the source property association list of @var{obj}. @end deffn set-source-properties! -@c snarfed from srcprop.c:194 +@c snarfed from srcprop.c:195 @deffn primitive set-source-properties! obj plist Install the association list @var{plist} as the source property list for @var{obj}. @end deffn source-property -@c snarfed from srcprop.c:214 +@c snarfed from srcprop.c:215 @deffn primitive source-property obj key Return the source property specified by @var{key} from @var{obj}'s source property list. @end deffn set-source-property! -@c snarfed from srcprop.c:247 +@c snarfed from srcprop.c:248 @deffn primitive set-source-property! obj key datum Set the source property of object @var{obj}, which is specified by @var{key} to @var{datum}. Normally, the key will be a symbol. @@ -5664,7 +5671,7 @@ concatenation of the given strings, @var{args}. make-shared-substring @c snarfed from strings.c:393 @deffn primitive make-shared-substring str [start [end]] -Return a shared substring of @var{str}. The semantics are the +Return a shared substring of @var{str}. The arguments are the same as for the @code{substring} function: the shared substring returned includes all of the text from @var{str} between indexes @var{start} (inclusive) and @var{end} (exclusive). If @@ -6661,7 +6668,7 @@ Return a list consisting of all the elements, in order, of @end deffn list->uniform-array -@c snarfed from unif.c:2175 +@c snarfed from unif.c:2183 @deffn primitive list->uniform-array ndim prot lst @deffnx procedure list->uniform-vector prot lst Return a uniform array of the type indicated by prototype @@ -6671,7 +6678,7 @@ done. @end deffn array-prototype -@c snarfed from unif.c:2526 +@c snarfed from unif.c:2534 @deffn primitive array-prototype ra Return an object that would produce an array of the same type as @var{array}, if used as the @var{prototype} for diff --git a/doc/posix.texi b/doc/posix.texi index f6fbc0994..5bff88c9f 100644 --- a/doc/posix.texi +++ b/doc/posix.texi @@ -1837,9 +1837,9 @@ required. The arguments and return values are thus in host order. @deffn primitive socket family style proto Return a new socket port of the type specified by @var{family}, @var{style} and @var{protocol}. All three parameters are -integers. Typical values for @var{family} are the values of -@code{AF_UNIX} and @code{AF_INET}. Typical values for -@var{style} are the values of @code{SOCK_STREAM}, +integers. Supported values for @var{family} are +@code{AF_UNIX}, @code{AF_INET} and @code{AF_INET6}. +Typical values for @var{style} are @code{SOCK_STREAM}, @code{SOCK_DGRAM} and @code{SOCK_RAW}. @var{protocol} can be obtained from a protocol name using @code{getprotobyname}. A value of zero specifies the default @@ -1902,18 +1902,25 @@ The return value is unspecified. @end deffn @deffn primitive connect sock fam address . args -Initiates a connection from @var{socket} to the address -specified by @var{address} and possibly @var{arg @dots{}}. The format -required for @var{address} -and @var{arg} @dots{} depends on the family of the socket. +Initiates a connection from a socket using a specified address +family to the address +specified by @var{address} and possibly @var{args}. +The format required for @var{address} +and @var{args} depends on the family of the socket. For a socket of family @code{AF_UNIX}, -only @code{address} is specified and must be a string with the +only @var{address} is specified and must be a string with the filename where the socket is to be created. For a socket of family @code{AF_INET}, -@code{address} must be an integer Internet host address and @var{arg} @dots{} -must be a single integer port number. +@var{address} must be an integer IPv4 host address and +@var{args} must be a single integer port number. + +For a socket of family @code{AF_INET6}, +@var{address} must be an integer IPv6 host address and +@var{args} may be up to three integers: +port [flowinfo] [scope_id], +where flowinfo and scope_id default to zero. The return value is unspecified. @end deffn From eefae53898db7a1ae3c87b02677ac56d49552bb0 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 22 Apr 2001 19:52:41 +0000 Subject: [PATCH 0856/2047] * socket.c: attempted to improve the docstrings slightly. --- libguile/ChangeLog | 2 + libguile/socket.c | 255 +++++++++++++++++++++++---------------------- 2 files changed, 135 insertions(+), 122 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 5c5584f16..c463b5a44 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,7 @@ 2001-04-22 Gary Houston + * socket.c: attempted to improve the docstrings slightly. + * net_db.c: remove bogus "close" declaration. (inet_aton declaration, scm_inet_aton, scm_inet_ntoa, scm_inet_netof, scm_lnaof, scm_inet_makeaddr, INADDR_ANY etc.): diff --git a/libguile/socket.c b/libguile/socket.c index 66f8d19cc..88270373a 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -83,60 +83,60 @@ SCM_DEFINE (scm_htons, "htons", 1, 0, 0, - (SCM in), - "Return a new integer from @var{value} by converting from host\n" - "to network order. @var{value} must be within the range of a C\n" - "unsigned short integer.") + (SCM value), + "Convert a 16 bit quantity from host to network byte ordering.\n" + "@var{value} is packed into 2 bytes, which are then converted\n" + "and returned as a new integer.") #define FUNC_NAME s_scm_htons { unsigned short c_in; - SCM_VALIDATE_INUM_COPY (1,in,c_in); - if (c_in != SCM_INUM (in)) - SCM_OUT_OF_RANGE (1,in); + SCM_VALIDATE_INUM_COPY (1, value, c_in); + if (c_in != SCM_INUM (value)) + SCM_OUT_OF_RANGE (1, value); return SCM_MAKINUM (htons (c_in)); } #undef FUNC_NAME SCM_DEFINE (scm_ntohs, "ntohs", 1, 0, 0, - (SCM in), - "Return a new integer from @var{value} by converting from\n" - "network to host order. @var{value} must be within the range of\n" - "a C unsigned short integer.") + (SCM value), + "Convert a 16 bit quantity from network to host byte ordering.\n" + "@var{value} is packed into 2 bytes, which are then converted\n" + "and returned as a new integer.") #define FUNC_NAME s_scm_ntohs { unsigned short c_in; - SCM_VALIDATE_INUM_COPY (1,in,c_in); - if (c_in != SCM_INUM (in)) - SCM_OUT_OF_RANGE (1,in); + SCM_VALIDATE_INUM_COPY (1, value, c_in); + if (c_in != SCM_INUM (value)) + SCM_OUT_OF_RANGE (1, value); return SCM_MAKINUM (ntohs (c_in)); } #undef FUNC_NAME SCM_DEFINE (scm_htonl, "htonl", 1, 0, 0, - (SCM in), - "Return a new integer from @var{value} by converting from host\n" - "to network order. @var{value} must be within the range of a\n" - "32 bit unsigned integer.") + (SCM value), + "Convert a 32 bit quantity from host to network byte ordering.\n" + "@var{value} is packed into 4 bytes, which are then converted\n" + "and returned as a new integer.") #define FUNC_NAME s_scm_htonl { - uint32_t c_in = SCM_NUM2ULONG (1, in); + uint32_t c_in = SCM_NUM2ULONG (1, value); return scm_ulong2num (htonl (c_in)); } #undef FUNC_NAME SCM_DEFINE (scm_ntohl, "ntohl", 1, 0, 0, - (SCM in), - "Return a new integer from @var{value} by converting from\n" - "network to host order. @var{value} must be within the range of\n" - "a 32 bit unsigned integer.") + (SCM value), + "Convert a 32 bit quantity from network to host byte ordering.\n" + "@var{value} is packed into 4 bytes, which are then converted\n" + "and returned as a new integer.") #define FUNC_NAME s_scm_ntohl { - uint32_t c_in = SCM_NUM2ULONG (1, in); + uint32_t c_in = SCM_NUM2ULONG (1, value); return scm_ulong2num (ntohl (c_in)); } @@ -149,8 +149,8 @@ extern int inet_aton (); SCM_DEFINE (scm_inet_aton, "inet-aton", 1, 0, 0, (SCM address), - "Converts a string containing an Internet host address in the\n" - "traditional dotted decimal notation into an integer.\n" + "Convert an IPv4 Internet address from printable string\n" + "(dotted decimal notation) to an integer. E.g.,\n\n" "@lisp\n" "(inet-aton \"127.0.0.1\") @result{} 2130706433\n" "@end lisp") @@ -169,8 +169,8 @@ SCM_DEFINE (scm_inet_aton, "inet-aton", 1, 0, 0, SCM_DEFINE (scm_inet_ntoa, "inet-ntoa", 1, 0, 0, (SCM inetid), - "Converts an integer Internet host address into a string with\n" - "the traditional dotted decimal representation.\n" + "Convert an IPv4 Internet address to a printable\n" + "(dotted decimal notation) string. E.g.,\n\n" "@lisp\n" "(inet-ntoa 2130706433) @result{} \"127.0.0.1\"\n" "@end lisp") @@ -189,8 +189,8 @@ SCM_DEFINE (scm_inet_ntoa, "inet-ntoa", 1, 0, 0, #ifdef HAVE_INET_NETOF SCM_DEFINE (scm_inet_netof, "inet-netof", 1, 0, 0, (SCM address), - "Return the network number part of the given integer Internet\n" - "address.\n" + "Return the network number part of the given IPv4\n" + "Internet address. E.g.,\n\n" "@lisp\n" "(inet-netof 2130706433) @result{} 127\n" "@end lisp") @@ -207,7 +207,8 @@ SCM_DEFINE (scm_inet_netof, "inet-netof", 1, 0, 0, SCM_DEFINE (scm_lnaof, "inet-lnaof", 1, 0, 0, (SCM address), "Return the local-address-with-network part of the given\n" - "Internet address.\n" + "IPv4 Internet address, using the obsolete class A/B/C system.\n" + "E.g.,\n\n" "@lisp\n" "(inet-lnaof 2130706433) @result{} 1\n" "@end lisp") @@ -223,9 +224,9 @@ SCM_DEFINE (scm_lnaof, "inet-lnaof", 1, 0, 0, #ifdef HAVE_INET_MAKEADDR SCM_DEFINE (scm_inet_makeaddr, "inet-makeaddr", 2, 0, 0, (SCM net, SCM lna), - "Makes an Internet host address by combining the network number\n" + "Make an IPv4 Internet address by combining the network number\n" "@var{net} with the local-address-within-network number\n" - "@var{lna}.\n" + "@var{lna}. E.g.,\n\n" "@lisp\n" "(inet-makeaddr 127 1) @result{} 2130706433\n" "@end lisp") @@ -243,6 +244,8 @@ SCM_DEFINE (scm_inet_makeaddr, "inet-makeaddr", 2, 0, 0, #undef FUNC_NAME #endif +#ifdef AF_INET6 + /* flip a 128 bit IPv6 address between host and network order. */ #ifdef WORDS_BIGENDIAN #define FLIP_NET_HOST_128(addr) @@ -336,10 +339,11 @@ static void ipv6_num_to_net (SCM src, char *dst) #ifdef HAVE_INET_PTON SCM_DEFINE (scm_inet_pton, "inet-pton", 2, 0, 0, (SCM family, SCM address), - "Convert a printable string network address into\n" - "an integer. Note that unlike the C version of this function,\n" + "Convert a string containing a printable network address to\n" + "an integer address. Note that unlike the C version of this\n" + "function,\n" "the result is an integer with normal host byte ordering.\n" - "@var{family} can be @code{AF_INET} or @code{AF_INET6}. e.g.,\n" + "@var{family} can be @code{AF_INET} or @code{AF_INET6}. E.g.,\n\n" "@lisp\n" "(inet-pton AF_INET "127.0.0.1") @result{} 2130706433\n" "(inet-pton AF_INET6 "::1") @result{} 1\n" @@ -370,10 +374,10 @@ SCM_DEFINE (scm_inet_pton, "inet-pton", 2, 0, 0, #ifdef HAVE_INET_NTOP SCM_DEFINE (scm_inet_ntop, "inet-ntop", 2, 0, 0, (SCM family, SCM address), - "Convert an integer network address into a printable string.\n" + "Convert a network address into a printable string.\n" "Note that unlike the C version of this function,\n" "the input is an integer with normal host byte ordering.\n" - "@var{family} can be @code{AF_INET} or @code{AF_INET6}. e.g.,\n" + "@var{family} can be @code{AF_INET} or @code{AF_INET6}. E.g.,\n\n" "@lisp\n" "(inet-ntop AF_INET 2130706433) @result{} "127.0.0.1"\n" "(inet-ntop AF_INET6 (- (expt 2 128) 1)) @result{}\n" @@ -405,6 +409,8 @@ SCM_DEFINE (scm_inet_ntop, "inet-ntop", 2, 0, 0, #undef FUNC_NAME #endif +#endif /* AF_INET6 */ + SCM_SYMBOL (sym_socket, "socket"); #define SCM_SOCK_FD_TO_PORT(fd) scm_fdes_to_port (fd, "r+0", sym_socket) @@ -412,16 +418,14 @@ SCM_SYMBOL (sym_socket, "socket"); SCM_DEFINE (scm_socket, "socket", 3, 0, 0, (SCM family, SCM style, SCM proto), "Return a new socket port of the type specified by @var{family},\n" - "@var{style} and @var{protocol}. All three parameters are\n" + "@var{style} and @var{proto}. All three parameters are\n" "integers. Supported values for @var{family} are\n" "@code{AF_UNIX}, @code{AF_INET} and @code{AF_INET6}.\n" "Typical values for @var{style} are @code{SOCK_STREAM},\n" - "@code{SOCK_DGRAM} and @code{SOCK_RAW}.\n" - "\n" - "@var{protocol} can be obtained from a protocol name using\n" + "@code{SOCK_DGRAM} and @code{SOCK_RAW}.\n\n" + "@var{proto} can be obtained from a protocol name using\n" "@code{getprotobyname}. A value of zero specifies the default\n" - "protocol, which is usually right.\n" - "\n" + "protocol, which is usually right.\n\n" "A single socket port cannot by used for communication until it\n" "has been connected to another socket.") #define FUNC_NAME s_scm_socket @@ -442,10 +446,10 @@ SCM_DEFINE (scm_socket, "socket", 3, 0, 0, SCM_DEFINE (scm_socketpair, "socketpair", 3, 0, 0, (SCM family, SCM style, SCM proto), "Return a pair of connected (but unnamed) socket ports of the\n" - "type specified by @var{family}, @var{style} and @var{protocol}.\n" + "type specified by @var{family}, @var{style} and @var{proto}.\n" "Many systems support only socket pairs of the @code{AF_UNIX}\n" "family. Zero is likely to be the only meaningful value for\n" - "@var{protocol}.") + "@var{proto}.") #define FUNC_NAME s_scm_socketpair { int fam; @@ -468,12 +472,11 @@ SCM_DEFINE (scm_socketpair, "socketpair", 3, 0, 0, SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0, (SCM sock, SCM level, SCM optname), "Return the value of a particular socket option for the socket\n" - "port @var{socket}. @var{level} is an integer code for type of\n" + "port @var{sock}. @var{level} is an integer code for type of\n" "option being requested, e.g., @code{SOL_SOCKET} for\n" "socket-level options. @var{optname} is an integer code for the\n" "option required and should be specified using one of the\n" - "symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc.\n" - "\n" + "symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc.\n\n" "The returned value is typically an integer but @code{SO_LINGER}\n" "returns a pair of integers.") #define FUNC_NAME s_scm_getsockopt @@ -534,8 +537,8 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0, SCM_DEFINE (scm_setsockopt, "setsockopt", 4, 0, 0, (SCM sock, SCM level, SCM optname, SCM value), - "Sets the value of a particular socket option for the socket\n" - "port @var{socket}. @var{level} is an integer code for type of option\n" + "Set the value of a particular socket option for the socket\n" + "port @var{sock}. @var{level} is an integer code for type of option\n" "being set, e.g., @code{SOL_SOCKET} for socket-level options.\n" "@var{optname} is an\n" "integer code for the option to set and should be specified using one of\n" @@ -775,7 +778,7 @@ scm_fill_sockaddr (int fam, SCM address, SCM *args, int which_arg, SCM_DEFINE (scm_connect, "connect", 3, 0, 1, (SCM sock, SCM fam, SCM address, SCM args), - "Initiates a connection from a socket using a specified address\n" + "Initiate a connection from a socket using a specified address\n" "family to the address\n" "specified by @var{address} and possibly @var{args}.\n" "The format required for @var{address}\n" @@ -819,20 +822,21 @@ SCM_DEFINE (scm_connect, "connect", 3, 0, 1, SCM_DEFINE (scm_bind, "bind", 3, 0, 1, (SCM sock, SCM fam, SCM address, SCM args), - "Assigns an address to the socket port @var{socket}.\n" + "Assign an address to the socket port @var{sock}.\n" "Generally this only needs to be done for server sockets,\n" "so they know where to look for incoming connections. A socket\n" "without an address will be assigned one automatically when it\n" "starts communicating.\n\n" - "The format of @var{address} and @var{ARG} @dots{} depends on the family\n" - "of the socket.\n\n" + "The format of @var{address} and @var{args} depends\n" + "on the family of the socket.\n\n" "For a socket of family @code{AF_UNIX}, only @var{address}\n" - "is specified and must \n" - "be a string with the filename where the socket is to be created.\n\n" - "For a socket of family @code{AF_INET}, @var{address} must be an integer\n" - "Internet host address and @var{arg} @dots{} must be a single integer\n" - "port number.\n\n" - "The values of the following variables can also be used for @var{address}:\n\n" + "is specified and must be a string with the filename where\n" + "the socket is to be created.\n\n" + "For a socket of family @code{AF_INET}, @var{address}\n" + "must be an integer IPv4 address and @var{args}\n" + "must be a single integer port number.\n\n" + "The values of the following variables can also be used for\n" + "@var{address}:\n\n" "@defvar INADDR_ANY\n" "Allow connections from any address.\n" "@end defvar\n\n" @@ -845,6 +849,11 @@ SCM_DEFINE (scm_bind, "bind", 3, 0, 1, "@defvar INADDR_NONE\n" "No address.\n" "@end defvar\n\n" + "For a socket of family @code{AF_INET6}, @var{address}\n" + "must be an integer IPv6 address and @var{args}\n" + "may be up to three integers:\n" + "port [flowinfo] [scope_id],\n" + "where flowinfo and scope_id default to zero.\n\n" "The return value is unspecified.") #define FUNC_NAME s_scm_bind { @@ -873,11 +882,12 @@ SCM_DEFINE (scm_bind, "bind", 3, 0, 1, SCM_DEFINE (scm_listen, "listen", 2, 0, 0, (SCM sock, SCM backlog), - "This procedure enables @var{socket} to accept connection\n" + "Enable @var{sock} to accept connection\n" "requests. @var{backlog} is an integer specifying\n" "the maximum length of the queue for pending connections.\n" - "If the queue fills, new clients will fail to connect until the\n" - "server calls @code{accept} to accept a connection from the queue.\n\n" + "If the queue fills, new clients will fail to connect until\n" + "the server calls @code{accept} to accept a connection from\n" + "the queue.\n\n" "The return value is unspecified.") #define FUNC_NAME s_scm_listen { @@ -973,16 +983,17 @@ scm_addr_vector (const struct sockaddr *address, const char *proc) SCM_DEFINE (scm_accept, "accept", 1, 0, 0, (SCM sock), - "Accepts a connection on a bound, listening socket @var{socket}. If there\n" - "are no pending connections in the queue, it waits until\n" - "one is available unless the non-blocking option has been set on the\n" - "socket.\n\n" + "Accept a connection on a bound, listening socket.\n" + "If there\n" + "are no pending connections in the queue, wait until\n" + "one is available unless the non-blocking option has been\n" + "set on the socket.\n\n" "The return value is a\n" - "pair in which the CAR is a new socket port for the connection and\n" - "the CDR is an object with address information about the client which\n" - "initiated the connection.\n\n" - "If the address is not available then the CDR will be an empty vector.\n\n" - "@var{socket} does not become part of the\n" + "pair in which the @emph{car} is a new socket port for the\n" + "connection and\n" + "the @emph{cdr} is an object with address information about the\n" + "client which initiated the connection.\n\n" + "@var{sock} does not become part of the\n" "connection and will continue to accept new requests.") #define FUNC_NAME s_scm_accept { @@ -1001,24 +1012,19 @@ SCM_DEFINE (scm_accept, "accept", 1, 0, 0, if (newfd == -1) SCM_SYSERROR; newsock = SCM_SOCK_FD_TO_PORT (newfd); - if (addr_size > 0) - address = scm_addr_vector (addr, FUNC_NAME); - else - address = SCM_BOOL_F; - + address = scm_addr_vector (addr, FUNC_NAME); return scm_cons (newsock, address); } #undef FUNC_NAME SCM_DEFINE (scm_getsockname, "getsockname", 1, 0, 0, (SCM sock), - "Return the address of @var{socket}, in the same form as the\n" + "Return the address of @var{sock}, in the same form as the\n" "object returned by @code{accept}. On many systems the address\n" "of a socket in the @code{AF_FILE} namespace cannot be read.") #define FUNC_NAME s_scm_getsockname { int fd; - SCM result; int addr_size = MAX_ADDR_SIZE; char max_addr[MAX_ADDR_SIZE]; struct sockaddr *addr = (struct sockaddr *) max_addr; @@ -1028,24 +1034,19 @@ SCM_DEFINE (scm_getsockname, "getsockname", 1, 0, 0, fd = SCM_FPORT_FDES (sock); if (getsockname (fd, addr, &addr_size) == -1) SCM_SYSERROR; - if (addr_size > 0) - result = scm_addr_vector (addr, FUNC_NAME); - else - result = SCM_BOOL_F; - return result; + return scm_addr_vector (addr, FUNC_NAME); } #undef FUNC_NAME SCM_DEFINE (scm_getpeername, "getpeername", 1, 0, 0, (SCM sock), - "Return the address of the socket that the socket @var{socket}\n" + "Return the address that @var{sock}\n" "is connected to, in the same form as the object returned by\n" "@code{accept}. On many systems the address of a socket in the\n" "@code{AF_FILE} namespace cannot be read.") #define FUNC_NAME s_scm_getpeername { int fd; - SCM result; int addr_size = MAX_ADDR_SIZE; char max_addr[MAX_ADDR_SIZE]; struct sockaddr *addr = (struct sockaddr *) max_addr; @@ -1055,27 +1056,28 @@ SCM_DEFINE (scm_getpeername, "getpeername", 1, 0, 0, fd = SCM_FPORT_FDES (sock); if (getpeername (fd, addr, &addr_size) == -1) SCM_SYSERROR; - if (addr_size > 0) - result = scm_addr_vector (addr, FUNC_NAME); - else - result = SCM_BOOL_F; - return result; + return scm_addr_vector (addr, FUNC_NAME); } #undef FUNC_NAME SCM_DEFINE (scm_recv, "recv!", 2, 1, 0, (SCM sock, SCM buf, SCM flags), - "Receives data from the socket port @var{socket}. @var{socket} must already\n" + "Receive data from a socket port.\n" + "@var{sock} must already\n" "be bound to the address from which data is to be received.\n" "@var{buf} is a string into which\n" - "the data will be written. The size of @var{buf} limits the amount of\n" + "the data will be written. The size of @var{buf} limits\n" + "the amount of\n" "data which can be received: in the case of packet\n" - "protocols, if a packet larger than this limit is encountered then some data\n" + "protocols, if a packet larger than this limit is encountered\n" + "then some data\n" "will be irrevocably lost.\n\n" "The optional @var{flags} argument is a value or\n" "bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n" - "The value returned is the number of bytes read from the socket.\n\n" - "Note that the data is read directly from the socket file descriptor:\n" + "The value returned is the number of bytes read from the\n" + "socket.\n\n" + "Note that the data is read directly from the socket file\n" + "descriptor:\n" "any unread buffered port data is ignored.") #define FUNC_NAME s_scm_recv { @@ -1098,13 +1100,17 @@ SCM_DEFINE (scm_recv, "recv!", 2, 1, 0, SCM_DEFINE (scm_send, "send", 2, 1, 0, (SCM sock, SCM message, SCM flags), - "Transmits the string @var{message} on the socket port @var{socket}. \n" - "@var{socket} must already be bound to a destination address. The\n" - "value returned is the number of bytes transmitted -- it's possible for\n" - "this to be less than the length of @var{message} if the socket is\n" - "set to be non-blocking. The optional @var{flags} argument is a value or\n" + "Transmit the string @var{message} on a socket port @var{sock}.\n" + "@var{sock} must already be bound to a destination address. The\n" + "value returned is the number of bytes transmitted --\n" + "it's possible for\n" + "this to be less than the length of @var{message}\n" + "if the socket is\n" + "set to be non-blocking. The optional @var{flags} argument\n" + "is a value or\n" "bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n" - "Note that the data is written directly to the socket file descriptor:\n" + "Note that the data is written directly to the socket\n" + "file descriptor:\n" "any unflushed buffered port data is ignored.") #define FUNC_NAME s_scm_send { @@ -1127,25 +1133,23 @@ SCM_DEFINE (scm_send, "send", 2, 1, 0, SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0, (SCM sock, SCM str, SCM flags, SCM start, SCM end), - "Return data from the socket port @var{socket} and also\n" + "Return data from the socket port @var{sock} and also\n" "information about where the data was received from.\n" - "@var{socket} must already be bound to the address from which\n" + "@var{sock} must already be bound to the address from which\n" "data is to be received. @code{str}, is a string into which the\n" "data will be written. The size of @var{str} limits the amount\n" "of data which can be received: in the case of packet protocols,\n" "if a packet larger than this limit is encountered then some\n" - "data will be irrevocably lost.\n" - "\n" + "data will be irrevocably lost.\n\n" "The optional @var{flags} argument is a value or bitwise OR of\n" - "@code{MSG_OOB}, @code{MSG_PEEK}, @code{MSG_DONTROUTE} etc.\n" - "\n" + "@code{MSG_OOB}, @code{MSG_PEEK}, @code{MSG_DONTROUTE} etc.\n\n" "The value returned is a pair: the @emph{car} is the number of\n" "bytes read from the socket and the @emph{cdr} an address object\n" - "in the same form as returned by @code{accept}.\n" - "\n" + "in the same form as returned by @code{accept}. The address\n" + "will given as @code{#f} if not available, as is usually the\n" + "case for stream sockets.\n\n" "The @var{start} and @var{end} arguments specify a substring of\n" - "@var{str} to which the data should be written.\n" - "\n" + "@var{str} to which the data should be written.\n\n" "Note that the data is read directly from the socket file\n" "descriptor: any unread buffered port data is ignored.") #define FUNC_NAME s_scm_recvfrom @@ -1178,7 +1182,7 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0, addr, &addr_size)); if (rv == -1) SCM_SYSERROR; - if (addr_size > 0 && addr->sa_family != AF_UNSPEC) + if (addr->sa_family != AF_UNSPEC) address = scm_addr_vector (addr, FUNC_NAME); else address = SCM_BOOL_F; @@ -1189,15 +1193,22 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0, SCM_DEFINE (scm_sendto, "sendto", 4, 0, 1, (SCM sock, SCM message, SCM fam, SCM address, SCM args_and_flags), - "Transmits the string @var{message} on the socket port @var{socket}. The\n" - "destination address is specified using the @var{family}, @var{address} and\n" - "@var{arg} arguments, in a similar way to the @code{connect}\n" - "procedure. The\n" - "value returned is the number of bytes transmitted -- it's possible for\n" - "this to be less than the length of @var{message} if the socket is\n" - "set to be non-blocking. The optional @var{flags} argument is a value or\n" + "Transmit the string @var{message} on the socket port\n" + "@var{sock}. The\n" + "destination address is specified using the @var{fam},\n" + "@var{address} and\n" + "@var{args_and_flags} arguments, in a similar way to the\n" + "@code{connect} procedure. @var{args_and_flags} contains\n" + "the usual connection arguments optionally followed by\n" + "a flags argument, which is a value or\n" "bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n" - "Note that the data is written directly to the socket file descriptor:\n" + "The value returned is the number of bytes transmitted --\n" + "it's possible for\n" + "this to be less than the length of @var{message} if the\n" + "socket is\n" + "set to be non-blocking.\n" + "Note that the data is written directly to the socket\n" + "file descriptor:\n" "any unflushed buffered port data is ignored.") #define FUNC_NAME s_scm_sendto { From 67835dabdb179760a4feb6e4019385a0daa51cdf Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sun, 22 Apr 2001 22:11:05 +0000 Subject: [PATCH 0857/2047] * More exception handling doc. --- doc/scheme-control.texi | 62 ++++++++++++++++++++++++++++++++++++++++- 1 file changed, 61 insertions(+), 1 deletion(-) diff --git a/doc/scheme-control.texi b/doc/scheme-control.texi index db5ad186e..220db6012 100644 --- a/doc/scheme-control.texi +++ b/doc/scheme-control.texi @@ -533,6 +533,14 @@ there is one. @node Throw @subsection Throwing Exceptions +The @code{throw} primitive is used to throw an exception. One argument, +the @var{key}, is mandatory, and must be a symbol; it indicates the type +of exception that is being thrown. Following the @var{key}, +@code{throw} accepts any number of additional arguments, whose meaning +depends on the exception type. The documentation for each possible type +of exception should specify the additional arguments that are expected +for that kind of exception. + @deffn primitive throw key . args Invoke the catch form matching @var{key}, passing @var{args} to the @var{handler}. @@ -540,9 +548,50 @@ Invoke the catch form matching @var{key}, passing @var{args} to the @var{key} is a symbol. It will match catches of the same symbol or of #t. -If there is no handler at all, an error is signaled. +If there is no handler at all, Guile prints an error and then exits. @end deffn +When an exception is thrown, it will be caught by the innermost +@code{catch} expression that applies to the type of the thrown +exception; in other words, the innermost @code{catch} whose @var{key} is +@code{#t} or is the same symbol as that used in the @code{throw} +expression. Once Guile has identified the appropriate @code{catch}, it +handles the exception by applying that @code{catch} expression's handler +procedure to the arguments of the @code{throw}. + +If there is no appropriate @code{catch} for a thrown exception, Guile +prints an error to the current error port indicating an uncaught +exception, and then exits. In practice, it is quite difficult to +observe this behaviour, because Guile when used interactively installs a +top level @code{catch} handler that will catch all exceptions and print +an appropriate error message @emph{without} exiting. For example, this +is what happens if you try to throw an unhandled exception in the +standard Guile REPL; note that Guile's command loop continues after the +error message: + +@lisp +guile> (throw 'badex) +:3:1: In procedure gsubr-apply @dots{} +:3:1: unhandled-exception: badex +ABORT: (misc-error) +guile> +@end lisp + +The default uncaught exception behaviour can be observed by evaluating a +@code{throw} expression from the shell command line: + +@example +$ guile -c "(begin (throw 'badex) (display \"here\\n\"))" +guile: uncaught throw to badex: () +$ +@end example + +@noindent +That Guile exits immediately following the uncaught exception +is shown by the absence of any output from the @code{display} +expression, because Guile never gets to the point of evaluating that +expression. + @node Lazy Catch @subsection Catch Without Unwinding @@ -553,6 +602,17 @@ not unwind the stack (this is the major difference), and if handler returns, its value is returned from the throw. @end deffn +@lisp +(lazy-catch 'badex + (lambda () + (+ (throw 'badex 1) + (throw 'badex 2))) + (lambda args + (cadr args))) +@result{} +3 +@end lisp + @node Stack Catch @subsection Capturing the Stack at a Throw From 1f7f9ed41d855099432fa6338d8e6a535dac41b3 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sun, 22 Apr 2001 22:16:07 +0000 Subject: [PATCH 0858/2047] * Correct docstring for `throw'. --- libguile/ChangeLog | 4 ++++ libguile/throw.c | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index c463b5a44..d7708ceac 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2001-04-22 Neil Jerram + + * throw.c (scm_throw): Correct docstring. + 2001-04-22 Gary Houston * socket.c: attempted to improve the docstrings slightly. diff --git a/libguile/throw.c b/libguile/throw.c index fce8d8e0f..a4e610b7b 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -592,7 +592,7 @@ SCM_DEFINE (scm_throw, "throw", 1, 0, 1, "@var{handler}. \n\n" "@var{key} is a symbol. It will match catches of the same symbol or of\n" "#t.\n\n" - "If there is no handler at all, an error is signaled.") + "If there is no handler at all, Guile prints an error and then exits.") #define FUNC_NAME s_scm_throw { SCM_VALIDATE_SYMBOL (1,key); From ca003b26ce5576999aefeebc4fd0e3c71fdf9668 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 23 Apr 2001 20:21:01 +0000 Subject: [PATCH 0859/2047] Integrated the guile-srfi package into the Guile distribution. --- srfi/.cvsignore | 12 + srfi/ChangeLog | 87 ++ srfi/Makefile.am | 52 + srfi/README | 141 ++ srfi/autogen.sh | 0 srfi/configure.in | 0 srfi/guile-srfi.texi | 0 srfi/srfi-13.c | 3052 ++++++++++++++++++++++++++++++++++++++++++ srfi/srfi-13.scm | 141 ++ srfi/srfi-14.c | 1361 +++++++++++++++++++ srfi/srfi-14.h | 61 + srfi/srfi-14.scm | 142 ++ 12 files changed, 5049 insertions(+) create mode 100644 srfi/.cvsignore create mode 100644 srfi/ChangeLog create mode 100644 srfi/Makefile.am create mode 100644 srfi/README create mode 100755 srfi/autogen.sh create mode 100644 srfi/configure.in create mode 100644 srfi/guile-srfi.texi create mode 100644 srfi/srfi-13.c create mode 100644 srfi/srfi-13.scm create mode 100644 srfi/srfi-14.c create mode 100644 srfi/srfi-14.h create mode 100644 srfi/srfi-14.scm diff --git a/srfi/.cvsignore b/srfi/.cvsignore new file mode 100644 index 000000000..6c4e65b0c --- /dev/null +++ b/srfi/.cvsignore @@ -0,0 +1,12 @@ +*.la +*.lo +*.x +.deps +.libs +Makefile +Makefile.in +aclocal.m4 +config.log +config.status +configure +libtool diff --git a/srfi/ChangeLog b/srfi/ChangeLog new file mode 100644 index 000000000..ea6016cf0 --- /dev/null +++ b/srfi/ChangeLog @@ -0,0 +1,87 @@ +2001-04-23 Martin Grabmueller + + Integrated the guile-srfi package into the Guile distribution. + + * srfi-13.c: All procedures so specified in the SRFI now accept + character set arguments. + + * Makefile.am: Snarfed some variables from the guile-readline + directory. + + * srfi-14.c, srfi-14.h: Add prefix SCM_ to exported macros. + + * srfi-13.scm, srfi-14.scm, srfi-13.c, srfi-14.c, srfi-14.h, + configure.in, Makefile.am: Added FSF copyright and Guile license + information. + + * srfi-13.c, srfi-14.c: Include srfi-14.h. + (scm_init_srfi_13_14): Initialize the complete module, if not + already done so. + + * srfi-14.h: New file. + + * srfi-13.scm, srfi-14.scm: Load new combined library. + + * Makefile.am: Build only one library, + `libguile-srfi-srfi-13-14.la' + +2001-04-04 Martin Grabmueller + + * guile-srfi.texi: Integrated the SRFI-14 documentation. + + * srfi-14.c, srfi-14.scm: Made the procedures and variables + compliant to the final SRFI document. + + * Renamed the package to guile-srfi. + +2001-04-03 Martin Grabmueller + + * NEWS: New section for 0.0.3. + + * configure.in, README, guile-srfi-13.texi: Bumped version number + to 0.0.3. + + * Released version 0.0.2. + + * Makefile.am: Added rules for builing the SRFI-14 library. + + * srfi-14.c, srfi-14.scm: New files, implementing SRFI-14 + (character set library). + +2001-03-27 Martin Grabmueller + + * README: Updated procedure and incompatibility list. + + * srfi-13.c (string_upcase_x, scm_string_upcase_xS), + (scm_string_upcase, string_downcase_x, scm_string_downcase_xS), + (scm_string_downcaseS, string_titlecase_x), + (scm_string_titlecase_x, scm_string_titlecase), + (scm_string_fill_xS, scm_string_copyS, scm_string_to_listS): New + procedures. + + * srfi-13.scm: Export new case mapping procedures. + + * guile-srfi-13.texi (What cannot be done): Removed case mapping + procedures from incompatibility list. + (Case Mapping): New section for case mapping procedures. + +2001-03-26 Martin Grabmueller + + * NEWS: New section for 0.0.2 + + * configure.in, README, guile-srfi-13.texi: Bumbed version number + to 0.0.2 + + * Released version 0.0.1. + + * README: Made procedure list up-to-date. + + * guile-srfi-13.texi: Fixed typos, completed reference and added + introductory blurb. + + * srfi-13.c, srfi-13.scm: Filled in the last missing pieces. + +2001-03-22 Martin Grabmueller + + * Started guile-srfi-13 package. Files are copied from the + guile-gdbm and slightly modified. diff --git a/srfi/Makefile.am b/srfi/Makefile.am new file mode 100644 index 000000000..c9cd7144f --- /dev/null +++ b/srfi/Makefile.am @@ -0,0 +1,52 @@ +## Process this file with Automake to create Makefile.in +## +## Copyright (C) 2001 Free Software Foundation, Inc. +## +## This file is part of GUILE. +## +## GUILE 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, or +## (at your option) any later version. +## +## GUILE 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 GUILE; see the file COPYING. If not, write +## to the Free Software Foundation, Inc., 59 Temple Place, Suite +## 330, Boston, MA 02111-1307 USA + +AUTOMAKE_OPTIONS = foreign + +#info_TEXINFOS = guile-srfi.texi + +## Prevent automake from adding extra -I options +DEFS = @DEFS@ +## Check for headers in $(srcdir)/.., so that #include +## will find MUMBLE.h in this dir when we're +## building. +INCLUDES = -I.. -I$(srcdir)/.. + + +lib_LTLIBRARIES = libguile-srfi-srfi-13-14.la + +BUILT_SOURCES = srfi-13.x srfi-14.x +libguile_srfi_srfi_13_14_la_SOURCES = srfi-13.x srfi-13.c srf-14.x srfi-14.c +libguile_srfi_srfi_13_14_la_LDFLAGS = -version-info 0:0 -export-dynamic + +srfidir = $(datadir)/guile/$(VERSION)/srfi +srfi_DATA = srfi-13.scm srfi-14.scm + +EXTRA_DIST = $(srfi_DATA) + +GUILE_SNARF = ../libguile/guile-snarf + +SUFFIXES = .x +.c.x: + $(GUILE_SNARF) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \ + || { rm $@; false; } + +DISTCLEANFILES = *.x diff --git a/srfi/README b/srfi/README new file mode 100644 index 000000000..6dca759b2 --- /dev/null +++ b/srfi/README @@ -0,0 +1,141 @@ +This is the integration of guile-srfi into the core. -*- text -*- + +[ this is the README from guile-srfi 0.0.3, slightly modified for the + integration into the Guile core + + 'martin -- 2001-04-23 ] + +This is a compiled Guile module that provides the string procedures +defined in SRFI-13 (string library), and the character set procedures +defined in SRFI-14 (character-set library). + +Getting Started ====================================================== + +1. Type + + guile + + You should now be at the Guile prompt ("guile> "). + +2. Type + + (use-modules (srfi srfi-13)) + + so that the srfi-13 module gets loaded. + +3. We're now ready to try some basic srfi-13/14 functionality. + + $ guile + guile> (use-modules (srfi srfi-13)) + guile> (string-concatenate '("Hello" " " "World")) + "Hello World" + guile> + + Check out the SRFI-14 (character-set library) procedures, too: + + $ guile + guile> (use-modules (srfi srfi-14)) + guile> (char-set-union (char-set #\f #\o #\o) (string->char-set "bar")) + # + guile> + +What Is Included ===================================================== + + All SRFI-13 procedures which are not already compatibly defined in + the Guile core are implemented. These are: + + string-any string-every + string-tabulate + string->list + reverse-list->string + string-join + string-copy + substring/shared string-copy! + string-take string-take-right + string-drop string-drop-right + string-pad string-pad-right + string-trim string-trim-right string-trim-both + string-fill! + string-compare string-compare-ci + string= string<> + string< string> + string<= string>= + string-ci= string-ci<> + string-ci< string-ci> + string-ci<= string-ci>= + string-hash string-hash-ci + string-prefix-length string-prefix-length-ci + string-suffix-length string-suffix-length-ci + string-prefix? string-prefix-ci? + string-suffix? string-suffix-ci? + string-index string-index-right + string-skip string-skip-right + string-count + string-contains string-contains-ci + string-upcase string-upcase! + string-downcase string-downcase! + string-titlecase string-titlecase! + string-reverse string-reverse! + string-append/shared + string-concatenate + reverse-string-concatenate + string-concatenate/shared + reverse-string-concatenate/shared + string-map string-map! + string-fold string-fold-right + string-unfold string-unfold-right + string-for-each + xsubstring string-xcopy! + string-replace string-tokenize + string-filter string-delete + + + All procedures and variables defined in SRFI-14 are implemented. + Thes complete list is: + + char-set? char-set= char-set<= + char-set-hash + char-set-fold char-set-unfold char-set-unfold! + char-set-for-each char-set-map + char-set-copy + char-set + list->char-set list->char-set! + string->char-set string-char-set! + predicate->char-set predicate->char-set! + ucs-range->char-set ucs-range->char-set! + ->char-set ->char-set! + char-set-size char-set-count + char-set-members char-set-contains? + char-set-every char-set-any + char-set-adjoin char-set-adjoin! + char-set-delete char-set-delete! + char-set-invert char-set-invert! + char-set-union char-set-union! + char-set-intersection char-set-intersection! + char-set-difference char-set-difference! + char-set-xor char-set-xor! + char-set-diff+intersection char-set-diff+intersection! + char-set:lower-case char-set:upper-case + char-set:title-case char-set:letter + char-set:digit char-set:letter+digit + char-set:graphic char-set:printing + char-set:whitespace char-set:iso-control + char-set:punctuation char-set:symbol + char-set:hex-digit char-set:blank + char-set:ascii char-set:empty + char-set:full + + +What Is Not Included ================================================= + + The following low-level procedures and syntax defined in SRFI-13 + are currently not supported. + + string-parse-start+end + string-parse-final-start+end + let-string-start+end + check-substring-spec + substring-spec-ok? + make-kmp-restart-vector + kmp-step + string-search-kmp diff --git a/srfi/autogen.sh b/srfi/autogen.sh new file mode 100755 index 000000000..e69de29bb diff --git a/srfi/configure.in b/srfi/configure.in new file mode 100644 index 000000000..e69de29bb diff --git a/srfi/guile-srfi.texi b/srfi/guile-srfi.texi new file mode 100644 index 000000000..e69de29bb diff --git a/srfi/srfi-13.c b/srfi/srfi-13.c new file mode 100644 index 000000000..692f683fe --- /dev/null +++ b/srfi/srfi-13.c @@ -0,0 +1,3052 @@ +/* srfi-13.c --- SRFI-13 procedures for Guile + * + * Copyright (C) 2001 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives + * permission for additional uses of the text contained in its release + * of GUILE. + * + * The exception is that, if you link the GUILE library with other + * files to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public + * License. Your use of that executable is in no way restricted on + * account of linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public + * License. + * + * This exception applies only to the code released by the Free + * Software Foundation under the name GUILE. If you copy code from + * other Free Software Foundation releases into a copy of GUILE, as + * the General Public License permits, the exception does not apply to + * the code that you add in this way. To avoid misleading anyone as + * to the status of such modified files, you must delete this + * exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + + +#include +#include + +#include + +#include "srfi-14.h" + +SCM_DEFINE (scm_string_any, "string-any", 2, 2, 0, + (SCM pred, SCM s, SCM start, SCM end), + "Check if the predicate @var{pred} is true for any character in\n" + "the string @var{s}, proceeding from left (index @var{start}) to\n" + "right (index @var{end}). If @code{string-any} returns true,\n" + "the returned true value is the one produced by the application\n" + "of @var{pred}.") +#define FUNC_NAME s_scm_string_any +{ + char * cstr; + int cstart, cend; + SCM res; + + SCM_VALIDATE_PROC (1, pred); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, + 3, start, cstart, + 4, end, cend); + cstr += cstart; + while (cstart < cend) + { + res = scm_apply (pred, SCM_MAKE_CHAR (*cstr), scm_listofnull); + if (!SCM_FALSEP (res)) + return res; + cstr++; + cstart++; + } + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_every, "string-every", 2, 2, 0, + (SCM pred, SCM s, SCM start, SCM end), + "Check if the predicate @var{pred} is true for every character\n" + "in the string @var{s}, proceeding from left (index @var{start})\n" + "to right (index @var{end}). If @code{string-every} returns\n" + "true, the returned true value is the one produced by the final\n" + "application of @var{pred} to the last character of @var{s}.") +#define FUNC_NAME s_scm_string_every +{ + char * cstr; + int cstart, cend; + SCM res; + + SCM_VALIDATE_PROC (1, pred); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, + 3, start, cstart, + 4, end, cend); + res = SCM_BOOL_F; + cstr += cstart; + while (cstart < cend) + { + res = scm_apply (pred, SCM_MAKE_CHAR (*cstr), scm_listofnull); + if (SCM_FALSEP (res)) + return res; + cstr++; + cstart++; + } + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_tabulate, "string-tabulate", 2, 0, 0, + (SCM proc, SCM len), + "@var{proc} is an integer->char procedure. Construct a string\n" + "of size @var{len} by applying @var{proc} to each index to\n" + "produce the corresponding string element. The order in which\n" + "@var{proc} is applied to the indices is not specified.") +#define FUNC_NAME s_scm_string_tabulate +{ + int clen, i; + SCM res; + SCM ch; + char * p; + + SCM_VALIDATE_PROC (1, proc); + SCM_VALIDATE_INUM_COPY (2, len, clen); + SCM_ASSERT_RANGE (2, len, clen >= 0); + + res = scm_allocate_string (clen); + p = SCM_STRING_CHARS (res); + i = 0; + while (i < clen) + { + ch = scm_apply (proc, SCM_MAKINUM (i), scm_listofnull); + if (!SCM_CHARP (ch)) + SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (proc)); + *p++ = SCM_CHAR (ch); + i++; + } + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_to_listS, "string->list", 1, 2, 0, + (SCM str, SCM start, SCM end), + "Convert the string @var{str} into a list of characters.") +#define FUNC_NAME s_scm_string_to_listS +{ + char * cstr; + int cstart, cend; + SCM result = SCM_EOL; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); + while (cstart < cend) + { + cend--; + result = scm_cons (SCM_MAKE_CHAR (cstr[cend]), result); + } + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_reverse_list_to_string, "reverse-list->string", 1, 0, 0, + (SCM chrs), + "An efficient implementation of @code{(compose string->list\n" + "reverse)}:\n" + "\n" + "@smalllisp\n" + "(reverse-list->string '(#\a #\B #\c)) @result{} \"cBa\"\n" + "@end smalllisp") +#define FUNC_NAME s_scm_reverse_list_to_string +{ + SCM result; + long i = scm_ilength (chrs); + + if (i < 0) + SCM_WRONG_TYPE_ARG (1, chrs); + result = scm_allocate_string (i); + + { + unsigned char *data = SCM_STRING_UCHARS (result) + i; + + while (SCM_NNULLP (chrs)) + { + SCM elt = SCM_CAR (chrs); + + SCM_VALIDATE_CHAR (SCM_ARGn, elt); + data--; + *data = SCM_CHAR (elt); + chrs = SCM_CDR (chrs); + } + } + return result; +} +#undef FUNC_NAME + + +SCM_SYMBOL (scm_sym_infix, "infix"); +SCM_SYMBOL (scm_sym_strict_infix, "strict-infix"); +SCM_SYMBOL (scm_sym_suffix, "suffix"); +SCM_SYMBOL (scm_sym_prefix, "prefix"); + +SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0, + (SCM ls, SCM delimiter, SCM grammar), + "Append the string in the string list @var{ls}, using the string\n" + "@var{delim} as a delimiter between the elements of @var{ls}.\n" + "@var{grammar} is a symbol which specifies how the delimiter is\n" + "placed between the strings, and defaults to the symbol\n" + "@code{infix}.\n" + "\n" + "@table @code\n" + "@item infix\n" + "Insert the separator between list elements. An empty string\n" + "will produce an empty list.\n" + "@item string-infix\n" + "Like @code{infix}, but will raise an error if given the empty\n" + "list.\n" + "@item suffix\n" + "Insert the separator after every list element.\n" + "@item prefix\n" + "Insert the separator before each list element.\n" + "@end table") +#define FUNC_NAME s_scm_string_join +{ +#define GRAM_INFIX 0 +#define GRAM_STRICT_INFIX 1 +#define GRAM_SUFFIX 2 +#define GRAM_PREFIX 3 + SCM tmp; + SCM result; + int gram = GRAM_INFIX; + int del_len = 0, extra_len = 0; + int len = 0; + char * p; + long strings = scm_ilength (ls); + + /* Validate the string list. */ + if (strings < 0) + SCM_WRONG_TYPE_ARG (1, ls); + + /* Validate the delimiter and record its length. */ + if (SCM_UNBNDP (delimiter)) + { + delimiter = scm_makfrom0str (" "); + del_len = 1; + } + else + { + SCM_VALIDATE_STRING (2, delimiter); + del_len = SCM_STRING_LENGTH (delimiter); + } + + /* Validate the grammar symbol and remember the grammar. */ + if (SCM_UNBNDP (grammar)) + gram = GRAM_INFIX; + else if (SCM_EQ_P (grammar, scm_sym_infix)) + gram = GRAM_INFIX; + else if (SCM_EQ_P (grammar, scm_sym_strict_infix)) + gram = GRAM_STRICT_INFIX; + else if (SCM_EQ_P (grammar, scm_sym_suffix)) + gram = GRAM_SUFFIX; + else if (SCM_EQ_P (grammar, scm_sym_prefix)) + gram = GRAM_PREFIX; + else + SCM_WRONG_TYPE_ARG (3, grammar); + + /* Check grammar constraints and calculate the space required for + the delimiter(s). */ + switch (gram) + { + case GRAM_INFIX: + if (!SCM_NULLP (ls)) + extra_len = (strings > 0) ? ((strings - 1) * del_len) : 0; + break; + case GRAM_STRICT_INFIX: + if (strings == 0) + SCM_MISC_ERROR ("strict-infix grammar requires non-empty list", + SCM_EOL); + extra_len = (strings - 1) * del_len; + break; + default: + extra_len = strings * del_len; + break; + } + + tmp = ls; + while (SCM_CONSP (tmp)) + { + SCM elt = SCM_CAR (tmp); + SCM_VALIDATE_STRING (1, elt); + len += SCM_STRING_LENGTH (elt); + tmp = SCM_CDR (tmp); + } + + result = scm_allocate_string (len + extra_len); + p = SCM_STRING_CHARS (result); + + tmp = ls; + switch (gram) + { + case GRAM_INFIX: + case GRAM_STRICT_INFIX: + while (!SCM_NULLP (tmp)) + { + SCM elt = SCM_CAR (tmp); + memmove (p, SCM_STRING_CHARS (elt), + SCM_STRING_LENGTH (elt) * sizeof (char)); + p += SCM_STRING_LENGTH (elt); + if (!SCM_NULLP (SCM_CDR (tmp)) && del_len > 0) + { + memmove (p, SCM_STRING_CHARS (delimiter), + SCM_STRING_LENGTH (delimiter) * sizeof (char)); + p += del_len; + } + tmp = SCM_CDR (tmp); + } + break; + case GRAM_SUFFIX: + while (!SCM_NULLP (tmp)) + { + SCM elt = SCM_CAR (tmp); + memmove (p, SCM_STRING_CHARS (elt), + SCM_STRING_LENGTH (elt) * sizeof (char)); + p += SCM_STRING_LENGTH (elt); + if (del_len > 0) + { + memmove (p, SCM_STRING_CHARS (delimiter), + SCM_STRING_LENGTH (delimiter) * sizeof (char)); + p += del_len; + } + tmp = SCM_CDR (tmp); + } + break; + case GRAM_PREFIX: + while (!SCM_NULLP (tmp)) + { + SCM elt = SCM_CAR (tmp); + if (del_len > 0) + { + memmove (p, SCM_STRING_CHARS (delimiter), + SCM_STRING_LENGTH (delimiter) * sizeof (char)); + p += del_len; + } + memmove (p, SCM_STRING_CHARS (elt), + SCM_STRING_LENGTH (elt) * sizeof (char)); + p += SCM_STRING_LENGTH (elt); + tmp = SCM_CDR (tmp); + } + break; + } + return result; +#undef GRAM_INFIX +#undef GRAM_STRICT_INFIX +#undef GRAM_SUFFIX +#undef GRAM_PREFIX +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_copyS, "string-copy", 1, 2, 0, + (SCM str, SCM start, SCM end), + "Return a freshly allocated copy of the string @var{str}. If\n" + "given, @var{start} and @var{end} delimit the portion of\n" + "@var{str} which is copied.") +#define FUNC_NAME s_scm_string_copyS +{ + char * cstr; + int cstart, cend; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); + return scm_makfromstr (cstr + start, cend - cstart, 0); + +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_substring_shared, "substring/shared", 2, 1, 0, + (SCM str, SCM start, SCM end), + "Like @code{substring}, but the result may share memory with the\n" + "argument @var{str}.") +#define FUNC_NAME s_scm_substring_shared +{ + SCM_VALIDATE_STRING (1, str); + SCM_VALIDATE_INUM (2, start); + if (SCM_UNBNDP (end)) + end = SCM_MAKINUM (SCM_STRING_LENGTH (str)); + else + SCM_VALIDATE_INUM (3, end); + if (SCM_INUM (start) == 0 && + SCM_INUM (end) == SCM_STRING_LENGTH (str)) + return str; + return scm_substring (str, start, end); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_copy_x, "string-copy!", 3, 2, 0, + (SCM target, SCM tstart, SCM s, SCM start, SCM end), + "Copy the sequence of characters from index range [@var{start},\n" + "@var{end}) in string @var{s} to string @var{target}, beginning\n" + "at index @var{tstart}. The characters are copied left-to-right\n" + "or right-to-left as needed -- the copy is guaranteed to work,\n" + "even if @var{target} and @var{s} are the same string. It is an\n" + "error if the copy operation runs off the end of the target\n" + "string.") +#define FUNC_NAME s_scm_string_copy_x +{ + char * cstr, * ctarget; + int cstart, cend, ctstart, dummy; + int len; + SCM sdummy = SCM_UNDEFINED; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, target, ctarget, + 2, tstart, ctstart, + 2, sdummy, dummy); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr, + 4, start, cstart, + 5, end, cend); + len = cend - cstart; + SCM_ASSERT_RANGE (3, s, len <= SCM_STRING_LENGTH (target) - ctstart); + + memmove (SCM_STRING_CHARS (target) + ctstart, + SCM_STRING_CHARS (s) + cstart, + len * sizeof (char)); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_take, "string-take", 2, 0, 0, + (SCM s, SCM n), + "Return the @var{n} first characters of @var{s}.") +#define FUNC_NAME s_scm_string_take +{ + char * cstr; + int cn; + + SCM_VALIDATE_STRING_COPY (1, s, cstr); + SCM_VALIDATE_INUM_COPY (2, n, cn); + SCM_ASSERT_RANGE (2, n, cn >= 0 && cn <= SCM_STRING_LENGTH (s)); + + return scm_makfromstr (cstr, cn, 0); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_drop, "string-drop", 2, 0, 0, + (SCM s, SCM n), + "Return all but the first @var{n} characters of @var{s}.") +#define FUNC_NAME s_scm_string_drop +{ + char * cstr; + int cn; + + SCM_VALIDATE_STRING_COPY (1, s, cstr); + SCM_VALIDATE_INUM_COPY (2, n, cn); + SCM_ASSERT_RANGE (2, n, cn >= 0 && cn <= SCM_STRING_LENGTH (s)); + + return scm_makfromstr (cstr + cn, SCM_STRING_LENGTH (s) - cn, 0); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_take_right, "string-take-right", 2, 0, 0, + (SCM s, SCM n), + "Return the @var{n} last characters of @var{s}.") +#define FUNC_NAME s_scm_string_take_right +{ + char * cstr; + int cn; + + SCM_VALIDATE_STRING_COPY (1, s, cstr); + SCM_VALIDATE_INUM_COPY (2, n, cn); + SCM_ASSERT_RANGE (2, n, cn >= 0 && cn <= SCM_STRING_LENGTH (s)); + + return scm_makfromstr (cstr + SCM_STRING_LENGTH (s) - cn, cn, 0); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_drop_right, "string-drop-right", 2, 0, 0, + (SCM s, SCM n), + "Return all but the last @var{n} characters of @var{s}.") +#define FUNC_NAME s_scm_string_drop_right +{ + char * cstr; + int cn; + + SCM_VALIDATE_STRING_COPY (1, s, cstr); + SCM_VALIDATE_INUM_COPY (2, n, cn); + SCM_ASSERT_RANGE (2, n, cn >= 0 && cn <= SCM_STRING_LENGTH (s)); + + return scm_makfromstr (cstr, SCM_STRING_LENGTH (s) - cn, 0); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_pad, "string-pad", 2, 3, 0, + (SCM s, SCM len, SCM chr, SCM start, SCM end), + "Take that characters from @var{start} to @var{end} from the\n" + "string @var{s} and return a new string, right-padded by the\n" + "character @var{chr} to length @var{len}. If the resulting\n" + "string is longer than @var{len}, it is truncated on the right.") +#define FUNC_NAME s_scm_string_pad +{ + char cchr; + char * cstr; + int cstart, cend, clen; + SCM result; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 4, start, cstart, + 5, end, cend); + SCM_VALIDATE_INUM_COPY (2, len, clen); + if (SCM_UNBNDP (chr)) + cchr = ' '; + else + { + SCM_VALIDATE_CHAR (3, chr); + cchr = SCM_CHAR (chr); + } + result = scm_allocate_string (clen); + if (clen < (cend - cstart)) + memmove (SCM_STRING_CHARS (result), + cstr + cend - clen, + clen * sizeof (char)); + else + { + memset (SCM_STRING_CHARS (result), cchr, + (clen - (cend - cstart)) * sizeof (char)); + memmove (SCM_STRING_CHARS (result) + (clen - (cend - cstart)), + cstr + cstart, + (cend - cstart) * sizeof (char)); + } + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_pad_right, "string-pad-right", 2, 3, 0, + (SCM s, SCM len, SCM chr, SCM start, SCM end), + "Take that characters from @var{start} to @var{end} from the\n" + "string @var{s} and return a new string, left-padded by the\n" + "character @var{chr} to length @var{len}. If the resulting\n" + "string is longer than @var{len}, it is truncated on the left.") +#define FUNC_NAME s_scm_string_pad_right +{ + char cchr; + char * cstr; + int cstart, cend, clen; + SCM result; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 4, start, cstart, + 5, end, cend); + SCM_VALIDATE_INUM_COPY (2, len, clen); + if (SCM_UNBNDP (chr)) + cchr = ' '; + else + { + SCM_VALIDATE_CHAR (3, chr); + cchr = SCM_CHAR (chr); + } + result = scm_allocate_string (clen); + if (clen < (cend - cstart)) + memmove (SCM_STRING_CHARS (result), cstr + cstart, clen * sizeof (char)); + else + { + memset (SCM_STRING_CHARS (result) + (cend - cstart), + cchr, (clen - (cend - cstart)) * sizeof (char)); + memmove (SCM_STRING_CHARS (result), cstr + cstart, + (cend - cstart) * sizeof (char)); + } + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_trim, "string-trim", 1, 3, 0, + (SCM s, SCM char_pred, SCM start, SCM end), + "Trim @var{s} by skipping over all characters on the left\n" + "that satisfy the parameter @var{char_pred}:\n" + "\n" + "@itemize @bullet\n" + "@item\n" + "if it is the character @var{ch}, characters equal to\n" + "@var{ch} are trimmed,\n" + "\n" + "@item\n" + "if it is a procedure @var{pred} characters that\n" + "satisfy @var{pred} are trimmed,\n" + "\n" + "@item\n" + "if it is a character set, characters in that set are trimmed.\n" + "@end itemize\n" + "\n" + "If called without a @var{char_pred} argument, all whitespace is\n" + "trimmed.") +#define FUNC_NAME s_scm_string_trim +{ + char * cstr; + int cstart, cend; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); + if (SCM_UNBNDP (char_pred)) + { + while (cstart < cend) + { + if (!isspace(cstr[cstart])) + break; + cstart++; + } + } + else if (SCM_CHARP (char_pred)) + { + char chr = SCM_CHAR (char_pred); + while (cstart < cend) + { + if (chr != cstr[cstart]) + break; + cstart++; + } + } + else if (SCM_CHARSETP (char_pred)) + { + while (cstart < cend) + { + if (!SCM_CHARSET_GET (char_pred, cstr[cstart])) + break; + cstart++; + } + } + else + { + SCM_VALIDATE_PROC (2, char_pred); + while (cstart < cend) + { + SCM res; + + res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cstart]), + scm_listofnull); + if (SCM_FALSEP (res)) + break; + cstart++; + } + } + return scm_makfromstr (cstr + cstart, cend - cstart, 0); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1, 3, 0, + (SCM s, SCM char_pred, SCM start, SCM end), + "Trim @var{s} by skipping over all characters on the rightt\n" + "that satisfy the parameter @var{char_pred}:\n" + "\n" + "@itemize @bullet\n" + "@item\n" + "if it is the character @var{ch}, characters equal to @var{ch}\n" + "are trimmed,\n" + "\n" + "@item\n" + "if it is a procedure @var{pred} characters that satisfy\n" + "@var{pred} are trimmed,\n" + "\n" + "@item\n" + "if it is a character sets, all characters in that set are\n" + "trimmed.\n" + "@end itemize\n" + "\n" + "If called without a @var{char_pred} argument, all whitespace is\n" + "trimmed.") +#define FUNC_NAME s_scm_string_trim_right +{ + char * cstr; + int cstart, cend; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); + if (SCM_UNBNDP (char_pred)) + { + while (cstart < cend) + { + if (!isspace(cstr[cend - 1])) + break; + cend--; + } + } + else if (SCM_CHARP (char_pred)) + { + char chr = SCM_CHAR (char_pred); + while (cstart < cend) + { + if (chr != cstr[cend - 1]) + break; + cend--; + } + } + else if (SCM_CHARSETP (char_pred)) + { + while (cstart < cend) + { + if (!SCM_CHARSET_GET (char_pred, cstr[cend - 1])) + break; + cend--; + } + } + else + { + SCM_VALIDATE_PROC (2, char_pred); + while (cstart < cend) + { + SCM res; + + res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cend - 1]), + scm_listofnull); + if (SCM_FALSEP (res)) + break; + cend--; + } + } + return scm_makfromstr (cstr + cstart, cend - cstart, 0); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 0, + (SCM s, SCM char_pred, SCM start, SCM end), + "Trim @var{s} by skipping over all characters on both sides of\n" + "the string that satisfy the parameter @var{char_pred}:\n" + "\n" + "@itemize\n" + "@item\n" + "if it is the character @var{ch}, characters equal to @var{ch}\n" + "are trimmed,\n" + "\n" + "@item\n" + "if it is a procedure @var{pred} characters that satisfy\n" + "@var{pred} are trimmed,\n" + "\n" + "@item\n" + "if it is a character set, the characters in the set are\n" + "trimmed.\n" + "@end itemize\n" + "\n" + "If called without a @var{char_pred} argument, all whitespace is\n" + "trimmed.") +#define FUNC_NAME s_scm_string_trim_both +{ + char * cstr; + int cstart, cend; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); + if (SCM_UNBNDP (char_pred)) + { + while (cstart < cend) + { + if (!isspace(cstr[cstart])) + break; + cstart++; + } + while (cstart < cend) + { + if (!isspace(cstr[cend - 1])) + break; + cend--; + } + } + else if (SCM_CHARP (char_pred)) + { + char chr = SCM_CHAR (char_pred); + while (cstart < cend) + { + if (chr != cstr[cstart]) + break; + cstart++; + } + while (cstart < cend) + { + if (chr != cstr[cend - 1]) + break; + cend--; + } + } + else if (SCM_CHARSETP (char_pred)) + { + while (cstart < cend) + { + if (!SCM_CHARSET_GET (char_pred, cstr[cstart])) + break; + cstart++; + } + while (cstart < cend) + { + if (!SCM_CHARSET_GET (char_pred, cstr[cend - 1])) + break; + cend--; + } + } + else + { + SCM_VALIDATE_PROC (2, char_pred); + while (cstart < cend) + { + SCM res; + + res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cstart]), + scm_listofnull); + if (SCM_FALSEP (res)) + break; + cstart++; + } + while (cstart < cend) + { + SCM res; + + res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cend - 1]), + scm_listofnull); + if (SCM_FALSEP (res)) + break; + cend--; + } + } + return scm_makfromstr (cstr + cstart, cend - cstart, 0); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_fill_xS, "string-fill!", 2, 2, 0, + (SCM str, SCM chr, SCM start, SCM end), + "Stores @var{chr} in every element of the given @var{str} and\n" + "returns an unspecified value.") +#define FUNC_NAME s_scm_string_fill_xS +{ + char * cstr; + int cstart, cend; + int c; + long k; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 3, start, cstart, + 4, end, cend); + SCM_VALIDATE_CHAR_COPY (2, chr, c); + for (k = cstart; k < cend; k++) + cstr[k] = c; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_compare, "string-compare", 5, 4, 0, + (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2), + "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n" + "mismatch index, depending upon whether @var{s1} is less than,\n" + "equal to, or greater than @var{s2}. The mismatch index is the\n" + "largest index @var{i} such that for every 0 <= @var{j} <\n" + "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n" + "@var{i} is the first position that does not match.") +#define FUNC_NAME s_scm_string_compare +{ + char * cstr1, * cstr2; + int cstart1, cend1, cstart2, cend2; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 6, start1, cstart1, + 7, end1, cend1); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 8, start2, cstart2, + 9, end2, cend2); + SCM_VALIDATE_PROC (3, proc_lt); + SCM_VALIDATE_PROC (4, proc_eq); + SCM_VALIDATE_PROC (5, proc_gt); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (cstr1[cstart1] < cstr2[cstart2]) + return scm_apply (proc_lt, SCM_MAKINUM (cstart1), scm_listofnull); + else if (cstr1[cstart1] > cstr2[cstart2]) + return scm_apply (proc_gt, SCM_MAKINUM (cstart1), scm_listofnull); + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + return scm_apply (proc_gt, SCM_MAKINUM (cstart1), scm_listofnull); + else if (cstart2 < cend2) + return scm_apply (proc_lt, SCM_MAKINUM (cstart1), scm_listofnull); + else + return scm_apply (proc_eq, SCM_MAKINUM (cstart1), scm_listofnull); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_compare_ci, "string-compare-ci", 5, 4, 0, + (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2), + "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n" + "mismatch index, depending upon whether @var{s1} is less than,\n" + "equal to, or greater than @var{s2}. The mismatch index is the\n" + "largest index @var{i} such that for every 0 <= @var{j} <\n" + "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n" + "@var{i} is the first position that does not match. The\n" + "character comparison is done case-insensitively.") +#define FUNC_NAME s_scm_string_compare_ci +{ + char * cstr1, * cstr2; + int cstart1, cend1, cstart2, cend2; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 6, start1, cstart1, + 7, end1, cend1); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 8, start2, cstart2, + 9, end2, cend2); + SCM_VALIDATE_PROC (3, proc_lt); + SCM_VALIDATE_PROC (4, proc_eq); + SCM_VALIDATE_PROC (5, proc_gt); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (scm_downcase (cstr1[cstart1]) < scm_downcase (cstr2[cstart2])) + return scm_apply (proc_lt, SCM_MAKINUM (cstart1), scm_listofnull); + else if (scm_downcase (cstr1[cstart1]) > scm_downcase (cstr2[cstart2])) + return scm_apply (proc_gt, SCM_MAKINUM (cstart1), scm_listofnull); + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + return scm_apply (proc_gt, SCM_MAKINUM (cstart1), scm_listofnull); + else if (cstart2 < cend2) + return scm_apply (proc_lt, SCM_MAKINUM (cstart1), scm_listofnull); + else + return scm_apply (proc_eq, SCM_MAKINUM (cstart1), scm_listofnull); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_eq, "string=", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n" + "value otherwise.") +#define FUNC_NAME s_scm_string_eq +{ + char * cstr1, * cstr2; + int cstart1, cend1, cstart2, cend2; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (cstr1[cstart1] < cstr2[cstart2]) + return SCM_BOOL_F; + else if (cstr1[cstart1] > cstr2[cstart2]) + return SCM_BOOL_F; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + return SCM_BOOL_F; + else if (cstart2 < cend2) + return SCM_BOOL_F; + else + return SCM_MAKINUM (cstart1); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_neq, "string<>", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n" + "value otherwise.") +#define FUNC_NAME s_scm_string_neq +{ + char * cstr1, * cstr2; + int cstart1, cend1, cstart2, cend2; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (cstr1[cstart1] < cstr2[cstart2]) + return SCM_MAKINUM (cstart1); + else if (cstr1[cstart1] > cstr2[cstart2]) + return SCM_MAKINUM (cstart1); + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + return SCM_MAKINUM (cstart1); + else if (cstart2 < cend2) + return SCM_MAKINUM (cstart1); + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_lt, "string<", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n" + "true value otherwise.") +#define FUNC_NAME s_scm_string_lt +{ + char * cstr1, * cstr2; + int cstart1, cend1, cstart2, cend2; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (cstr1[cstart1] < cstr2[cstart2]) + return SCM_MAKINUM (cstart1); + else if (cstr1[cstart1] > cstr2[cstart2]) + return SCM_BOOL_F; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + return SCM_BOOL_F; + else if (cstart2 < cend2) + return SCM_MAKINUM (cstart1); + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_gt, "string>", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n" + "true value otherwise.") +#define FUNC_NAME s_scm_string_gt +{ + char * cstr1, * cstr2; + int cstart1, cend1, cstart2, cend2; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (cstr1[cstart1] < cstr2[cstart2]) + return SCM_BOOL_F; + else if (cstr1[cstart1] > cstr2[cstart2]) + return SCM_MAKINUM (cstart1); + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + return SCM_MAKINUM (cstart1); + else if (cstart2 < cend2) + return SCM_BOOL_F; + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_le, "string<=", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n" + "value otherwise.") +#define FUNC_NAME s_scm_string_le +{ + char * cstr1, * cstr2; + int cstart1, cend1, cstart2, cend2; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (cstr1[cstart1] < cstr2[cstart2]) + return SCM_MAKINUM (cstart1); + else if (cstr1[cstart1] > cstr2[cstart2]) + return SCM_BOOL_F; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + return SCM_BOOL_F; + else if (cstart2 < cend2) + return SCM_MAKINUM (cstart1); + else + return SCM_MAKINUM (cstart1); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_ge, "string>=", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n" + "otherwise.") +#define FUNC_NAME s_scm_string_ge +{ + char * cstr1, * cstr2; + int cstart1, cend1, cstart2, cend2; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (cstr1[cstart1] < cstr2[cstart2]) + return SCM_BOOL_F; + else if (cstr1[cstart1] > cstr2[cstart2]) + return SCM_MAKINUM (cstart1); + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + return SCM_MAKINUM (cstart1); + else if (cstart2 < cend2) + return SCM_BOOL_F; + else + return SCM_MAKINUM (cstart1); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_ci_eq, "string-ci=", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n" + "value otherwise. The character comparison is done\n" + "case-insensitively.") +#define FUNC_NAME s_scm_string_ci_eq +{ + char * cstr1, * cstr2; + int cstart1, cend1, cstart2, cend2; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (scm_downcase (cstr1[cstart1]) < scm_downcase (cstr2[cstart2])) + return SCM_BOOL_F; + else if (scm_downcase (cstr1[cstart1]) > scm_downcase (cstr2[cstart2])) + return SCM_BOOL_F; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + return SCM_BOOL_F; + else if (cstart2 < cend2) + return SCM_BOOL_F; + else + return SCM_MAKINUM (cstart1); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_ci_neq, "string-ci<>", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n" + "value otherwise. The character comparison is done\n" + "case-insensitively.") +#define FUNC_NAME s_scm_string_ci_neq +{ + char * cstr1, * cstr2; + int cstart1, cend1, cstart2, cend2; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (scm_downcase (cstr1[cstart1]) < scm_downcase (cstr2[cstart2])) + return SCM_MAKINUM (cstart1); + else if (scm_downcase (cstr1[cstart1]) > scm_downcase (cstr2[cstart2])) + return SCM_MAKINUM (cstart1); + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + return SCM_MAKINUM (cstart1); + else if (cstart2 < cend2) + return SCM_MAKINUM (cstart1); + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_ci_lt, "string-ci<", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n" + "true value otherwise. The character comparison is done\n" + "case-insensitively.") +#define FUNC_NAME s_scm_string_ci_lt +{ + char * cstr1, * cstr2; + int cstart1, cend1, cstart2, cend2; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (scm_downcase (cstr1[cstart1]) < scm_downcase (cstr2[cstart2])) + return SCM_MAKINUM (cstart1); + else if (scm_downcase (cstr1[cstart1]) > scm_downcase (cstr2[cstart2])) + return SCM_BOOL_F; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + return SCM_BOOL_F; + else if (cstart2 < cend2) + return SCM_MAKINUM (cstart1); + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_ci_gt, "string-ci>", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n" + "true value otherwise. The character comparison is done\n" + "case-insensitively.") +#define FUNC_NAME s_scm_string_ci_gt +{ + char * cstr1, * cstr2; + int cstart1, cend1, cstart2, cend2; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (scm_downcase (cstr1[cstart1]) < scm_downcase (cstr2[cstart2])) + return SCM_BOOL_F; + else if (scm_downcase (cstr1[cstart1]) > scm_downcase (cstr2[cstart2])) + return SCM_MAKINUM (cstart1); + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + return SCM_MAKINUM (cstart1); + else if (cstart2 < cend2) + return SCM_BOOL_F; + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_ci_le, "string-ci<=", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n" + "value otherwise. The character comparison is done\n" + "case-insensitively.") +#define FUNC_NAME s_scm_string_ci_le +{ + char * cstr1, * cstr2; + int cstart1, cend1, cstart2, cend2; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (scm_downcase (cstr1[cstart1]) < scm_downcase (cstr2[cstart2])) + return SCM_MAKINUM (cstart1); + else if (scm_downcase (cstr1[cstart1]) > scm_downcase (cstr2[cstart2])) + return SCM_BOOL_F; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + return SCM_BOOL_F; + else if (cstart2 < cend2) + return SCM_MAKINUM (cstart1); + else + return SCM_MAKINUM (cstart1); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_ci_ge, "string-ci>=", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n" + "otherwise. The character comparison is done\n" + "case-insensitively.") +#define FUNC_NAME s_scm_string_ci_ge +{ + char * cstr1, * cstr2; + int cstart1, cend1, cstart2, cend2; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (scm_downcase (cstr1[cstart1]) < scm_downcase (cstr2[cstart2])) + return SCM_BOOL_F; + else if (scm_downcase (cstr1[cstart1]) > scm_downcase (cstr2[cstart2])) + return SCM_MAKINUM (cstart1); + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + return SCM_MAKINUM (cstart1); + else if (cstart2 < cend2) + return SCM_BOOL_F; + else + return SCM_MAKINUM (cstart1); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_prefix_length, "string-prefix-length", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return the length of the longest common prefix of the two\n" + "strings.") +#define FUNC_NAME s_scm_string_prefix_length +{ + char * cstr1, * cstr2; + int cstart1, cend1, cstart2, cend2; + int len = 0; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + while (cstart1 < cend1 && cstart2 < cend2) + { + if (cstr1[cstart1] != cstr2[cstart2]) + return SCM_MAKINUM (len); + len++; + cstart1++; + cstart2++; + } + return SCM_MAKINUM (len); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_prefix_length_ci, "string-prefix-length-ci", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return the length of the longest common prefix of the two\n" + "strings, ignoring character case.") +#define FUNC_NAME s_scm_string_prefix_length_ci +{ + char * cstr1, * cstr2; + int cstart1, cend1, cstart2, cend2; + int len = 0; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + while (cstart1 < cend1 && cstart2 < cend2) + { + if (scm_downcase (cstr1[cstart1]) != scm_downcase (cstr2[cstart2])) + return SCM_MAKINUM (len); + len++; + cstart1++; + cstart2++; + } + return SCM_MAKINUM (len); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_suffix_length, "string-suffix-length", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return the length of the longest common suffix of the two\n" + "strings.") +#define FUNC_NAME s_scm_string_suffix_length +{ + char * cstr1, * cstr2; + int cstart1, cend1, cstart2, cend2; + int len = 0; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + while (cstart1 < cend1 && cstart2 < cend2) + { + cend1--; + cend2--; + if (cstr1[cend1] != cstr2[cend2]) + return SCM_MAKINUM (len); + len++; + } + return SCM_MAKINUM (len); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_suffix_length_ci, "string-suffix-length-ci", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return the length of the longest common suffix of the two\n" + "strings, ignoring character case.") +#define FUNC_NAME s_scm_string_suffix_length_ci +{ + char * cstr1, * cstr2; + int cstart1, cend1, cstart2, cend2; + int len = 0; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + while (cstart1 < cend1 && cstart2 < cend2) + { + cend1--; + cend2--; + if (scm_downcase (cstr1[cend1]) != scm_downcase (cstr2[cend2])) + return SCM_MAKINUM (len); + len++; + } + return SCM_MAKINUM (len); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_prefix_p, "string-prefix?", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Is @var{s1} a prefix of @var{s2}?") +#define FUNC_NAME s_scm_string_prefix_p +{ + char * cstr1, * cstr2; + int cstart1, cend1, cstart2, cend2; + int len = 0, len1; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + len1 = cend1 - cstart1; + while (cstart1 < cend1 && cstart2 < cend2) + { + if (cstr1[cstart1] != cstr2[cstart2]) + return SCM_BOOL (len == len1); + len++; + cstart1++; + cstart2++; + } + return SCM_BOOL (len == len1); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_prefix_ci_p, "string-prefix-ci?", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Is @var{s1} a prefix of @var{s2}, ignoring character case?") +#define FUNC_NAME s_scm_string_prefix_ci_p +{ + char * cstr1, * cstr2; + int cstart1, cend1, cstart2, cend2; + int len = 0, len1; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + len1 = cend1 - cstart1; + while (cstart1 < cend1 && cstart2 < cend2) + { + if (scm_downcase (cstr1[cstart1]) != scm_downcase (cstr2[cstart2])) + return SCM_BOOL (len == len1); + len++; + cstart1++; + cstart2++; + } + return SCM_BOOL (len == len1); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_suffix_p, "string-suffix?", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Is @var{s1} a suffix of @var{s2}?") +#define FUNC_NAME s_scm_string_suffix_p +{ + char * cstr1, * cstr2; + int cstart1, cend1, cstart2, cend2; + int len = 0, len1; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + len1 = cend1 - cstart1; + while (cstart1 < cend1 && cstart2 < cend2) + { + cend1--; + cend2--; + if (cstr1[cend1] != cstr2[cend2]) + return SCM_BOOL (len == len1); + len++; + } + return SCM_BOOL (len == len1); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_suffix_ci_p, "string-suffix-ci?", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Is @var{s1} a suffix of @var{s2}, ignoring character case?") +#define FUNC_NAME s_scm_string_suffix_ci_p +{ + char * cstr1, * cstr2; + int cstart1, cend1, cstart2, cend2; + int len = 0, len1; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + len1 = cend1 - cstart1; + while (cstart1 < cend1 && cstart2 < cend2) + { + cend1--; + cend2--; + if (scm_downcase (cstr1[cend1]) != scm_downcase (cstr2[cend2])) + return SCM_BOOL (len == len1); + len++; + } + return SCM_BOOL (len == len1); +} +#undef FUNC_NAME + + +/* FIXME::martin: The `S' is to avoid a name clash with the procedure + in the core, which does not accept a predicate. */ +SCM_DEFINE (scm_string_indexS, "string-index", 2, 2, 0, + (SCM s, SCM char_pred, SCM start, SCM end), + "Search through the string @var{s} from left to right, returning\n" + "the index of the first occurence of a character which\n" + "\n" + "@itemize\n" + "@item\n" + "equals @var{char_pred}, if it is character,\n" + "\n" + "@item\n" + "satisifies the predicate @var{char_pred}, if it is a procedure,\n" + "\n" + "@item\n" + "is in the set @var{char_pred}, if it is a character set.\n" + "@end itemize") +#define FUNC_NAME s_scm_string_indexS +{ + char * cstr; + int cstart, cend; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); + if (SCM_CHARP (char_pred)) + { + char cchr = SCM_CHAR (char_pred); + while (cstart < cend) + { + if (cchr == cstr[cstart]) + return SCM_MAKINUM (cstart); + cstart++; + } + } + else if (SCM_CHARSETP (char_pred)) + { + while (cstart < cend) + { + if (SCM_CHARSET_GET (char_pred, cstr[cstart])) + return SCM_MAKINUM (cstart); + cstart++; + } + } + else + { + SCM_VALIDATE_PROC (2, char_pred); + while (cstart < cend) + { + SCM res; + res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cstart]), + scm_listofnull); + if (!SCM_FALSEP (res)) + return SCM_MAKINUM (cstart); + cstart++; + } + } + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_index_right, "string-index-right", 2, 2, 0, + (SCM s, SCM char_pred, SCM start, SCM end), + "Search through the string @var{s} from right to left, returning\n" + "the index of the last occurence of a character which\n" + "\n" + "@itemize @bullet\n" + "@item\n" + "equals @var{char_pred}, if it is character,\n" + "\n" + "@item\n" + "satisifies the predicate @var{char_pred}, if it is a procedure,\n" + "\n" + "@item\n" + "is in the set if @var{char_pred} is a character set.\n" + "@end itemize") +#define FUNC_NAME s_scm_string_index_right +{ + char * cstr; + int cstart, cend; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); + if (SCM_CHARP (char_pred)) + { + char cchr = SCM_CHAR (char_pred); + while (cstart < cend) + { + cend--; + if (cchr == cstr[cend]) + return SCM_MAKINUM (cend); + } + } + else if (SCM_CHARSETP (char_pred)) + { + while (cstart < cend) + { + cend--; + if (SCM_CHARSET_GET (char_pred, cstr[cend])) + return SCM_MAKINUM (cend); + } + } + else + { + SCM_VALIDATE_PROC (2, char_pred); + while (cstart < cend) + { + SCM res; + cend--; + res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cend]), + scm_listofnull); + if (!SCM_FALSEP (res)) + return SCM_MAKINUM (cend); + } + } + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0, + (SCM s, SCM char_pred, SCM start, SCM end), + "Search through the string @var{s} from left to right, returning\n" + "the index of the first occurence of a character which\n" + "\n" + "@itemize @bullet\n" + "@item\n" + "does not equal @var{char_pred}, if it is character,\n" + "\n" + "@item\n" + "does not satisify the predicate @var{char_pred}, if it is a\n" + "procedure,\n" + "\n" + "@item\n" + "is not in the set if @var{char_pred} is a character set.\n" + "@end itemize") +#define FUNC_NAME s_scm_string_skip +{ + char * cstr; + int cstart, cend; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); + if (SCM_CHARP (char_pred)) + { + char cchr = SCM_CHAR (char_pred); + while (cstart < cend) + { + if (cchr != cstr[cstart]) + return SCM_MAKINUM (cstart); + cstart++; + } + } + else if (SCM_CHARSETP (char_pred)) + { + while (cstart < cend) + { + if (!SCM_CHARSET_GET (char_pred, cstr[cstart])) + return SCM_MAKINUM (cstart); + cstart++; + } + } + else + { + SCM_VALIDATE_PROC (2, char_pred); + while (cstart < cend) + { + SCM res; + res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cstart]), + scm_listofnull); + if (SCM_FALSEP (res)) + return SCM_MAKINUM (cstart); + cstart++; + } + } + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_skip_right, "string-skip-right", 2, 2, 0, + (SCM s, SCM char_pred, SCM start, SCM end), + "Search through the string @var{s} from right to left, returning\n" + "the index of the last occurence of a character which\n" + "\n" + "@itemize @bullet\n" + "@item\n" + "does not equal @var{char_pred}, if it is character,\n" + "\n" + "@item\n" + "does not satisifie the predicate @var{char_pred}, if it is a\n" + "procedure,\n" + "\n" + "@item\n" + "is not in the set if @var{char_pred} is a character set.\n" + "@end itemize") +#define FUNC_NAME s_scm_string_skip_right +{ + char * cstr; + int cstart, cend; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); + if (SCM_CHARP (char_pred)) + { + char cchr = SCM_CHAR (char_pred); + while (cstart < cend) + { + cend--; + if (cchr != cstr[cend]) + return SCM_MAKINUM (cend); + } + } + else if (SCM_CHARSETP (char_pred)) + { + while (cstart < cend) + { + cend--; + if (!SCM_CHARSET_GET (char_pred, cstr[cend])) + return SCM_MAKINUM (cend); + } + } + else + { + SCM_VALIDATE_PROC (2, char_pred); + while (cstart < cend) + { + SCM res; + cend--; + res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cend]), + scm_listofnull); + if (SCM_FALSEP (res)) + return SCM_MAKINUM (cend); + } + } + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_count, "string-count", 2, 2, 0, + (SCM s, SCM char_pred, SCM start, SCM end), + "Return the count of the number of characters in the string\n" + "@var{s} which\n" + "\n" + "@itemize @bullet\n" + "@item\n" + "equals @var{char_pred}, if it is character,\n" + "\n" + "@item\n" + "satisifies the predicate @var{char_pred}, if it is a procedure.\n" + "\n" + "@item\n" + "is in the set @var{char_pred}, if it is a character set.\n" + "@end itemize") +#define FUNC_NAME s_scm_string_count +{ + char * cstr; + int cstart, cend; + int count = 0; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); + if (SCM_CHARP (char_pred)) + { + char cchr = SCM_CHAR (char_pred); + while (cstart < cend) + { + if (cchr == cstr[cstart]) + count++; + cstart++; + } + } + else if (SCM_CHARSETP (char_pred)) + { + while (cstart < cend) + { + if (SCM_CHARSET_GET (char_pred, cstr[cstart])) + count++; + cstart++; + } + } + else + { + SCM_VALIDATE_PROC (2, char_pred); + while (cstart < cend) + { + SCM res; + res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cstart]), + scm_listofnull); + if (!SCM_FALSEP (res)) + count++; + cstart++; + } + } + return SCM_MAKINUM (count); +} +#undef FUNC_NAME + + +/* FIXME::martin: This should definitely get implemented more + efficiently -- maybe with Knuth-Morris-Pratt, like in the reference + implementation. */ +SCM_DEFINE (scm_string_contains, "string-contains", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Does string @var{s1} contain string @var{s2}? Return the index\n" + "in @var{s1} where @var{s2} occurs as a substring, or false.\n" + "The optional start/end indices restrict the operation to the\n" + "indicated substrings.") +#define FUNC_NAME s_scm_string_contains +{ + char * cs1, * cs2; + int cstart1, cend1, cstart2, cend2; + int len2, i, j; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cs1, + 3, start1, cstart1, + 4, end1, cend1); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cs2, + 5, start2, cstart2, + 6, end2, cend2); + len2 = cend2 - cstart2; + while (cstart1 <= cend1 - len2) + { + i = cstart1; + j = cstart2; + while (i < cend1 && j < cend2 && cs1[i] == cs2[j]) + { + i++; + j++; + } + if (j == cend2) + return SCM_MAKINUM (cstart1); + cstart1++; + } + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +/* FIXME::martin: This should definitely get implemented more + efficiently -- maybe with Knuth-Morris-Pratt, like in the reference + implementation. */ +SCM_DEFINE (scm_string_contains_ci, "string-contains-ci", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Does string @var{s1} contain string @var{s2}? Return the index\n" + "in @var{s1} where @var{s2} occurs as a substring, or false.\n" + "The optional start/end indices restrict the operation to the\n" + "indicated substrings. Character comparison is done\n" + "case-insensitively.") +#define FUNC_NAME s_scm_string_contains_ci +{ + char * cs1, * cs2; + int cstart1, cend1, cstart2, cend2; + int len2, i, j; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cs1, + 3, start1, cstart1, + 4, end1, cend1); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cs2, + 5, start2, cstart2, + 6, end2, cend2); + len2 = cend2 - cstart2; + while (cstart1 <= cend1 - len2) + { + i = cstart1; + j = cstart2; + while (i < cend1 && j < cend2 && + scm_downcase (cs1[i]) == scm_downcase (cs2[j])) + { + i++; + j++; + } + if (j == cend2) + return SCM_MAKINUM (cstart1); + cstart1++; + } + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +/* Helper function for the string uppercase conversion functions. + * No argument checking is performed. */ +static SCM +string_upcase_x (SCM v, int start, int end) +{ + unsigned long k; + + for (k = start; k < end; ++k) + SCM_STRING_UCHARS (v) [k] = scm_upcase (SCM_STRING_UCHARS (v) [k]); + + return v; +} + + +/* FIXME::martin: The `S' is to avoid a name clash with the procedure + in the core, which does not accept start/end indices */ +SCM_DEFINE (scm_string_upcase_xS, "string-upcase!", 1, 2, 0, + (SCM str, SCM start, SCM end), + "Destructively upcase every character in @code{str}.\n" + "\n" + "@lisp\n" + "(string-upcase! y)\n" + "@result{} \"ARRDEFG\"\n" + "y\n" + "@result{} \"ARRDEFG\"\n" + "@end lisp") +#define FUNC_NAME s_scm_string_upcase_xS +{ + char * cstr; + int cstart, cend; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); + return string_upcase_x (str, cstart, cend); +} +#undef FUNC_NAME + + +/* FIXME::martin: The `S' is to avoid a name clash with the procedure + in the core, which does not accept start/end indices */ +SCM_DEFINE (scm_string_upcaseS, "string-upcase", 1, 2, 0, + (SCM str, SCM start, SCM end), + "Upcase every character in @code{str}.") +#define FUNC_NAME s_scm_string_upcaseS +{ + char * cstr; + int cstart, cend; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); + return string_upcase_x (scm_string_copy (str), cstart, cend); +} +#undef FUNC_NAME + + +/* Helper function for the string lowercase conversion functions. + * No argument checking is performed. */ +static SCM +string_downcase_x (SCM v, int start, int end) +{ + unsigned long k; + + for (k = start; k < end; ++k) + SCM_STRING_UCHARS (v) [k] = scm_downcase (SCM_STRING_UCHARS (v) [k]); + + return v; +} + + +/* FIXME::martin: The `S' is to avoid a name clash with the procedure + in the core, which does not accept start/end indices */ +SCM_DEFINE (scm_string_downcase_xS, "string-downcase!", 1, 2, 0, + (SCM str, SCM start, SCM end), + "Destructively downcase every character in @var{str}.\n" + "\n" + "@lisp\n" + "y\n" + "@result{} \"ARRDEFG\"\n" + "(string-downcase! y)\n" + "@result{} \"arrdefg\"\n" + "y\n" + "@result{} \"arrdefg\"\n" + "@end lisp") +#define FUNC_NAME s_scm_string_downcase_xS +{ + char * cstr; + int cstart, cend; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); + return string_downcase_x (str, cstart, cend); +} +#undef FUNC_NAME + + +/* FIXME::martin: The `S' is to avoid a name clash with the procedure + in the core, which does not accept start/end indices */ +SCM_DEFINE (scm_string_downcaseS, "string-downcase", 1, 2, 0, + (SCM str, SCM start, SCM end), + "Downcase every character in @var{str}.") +#define FUNC_NAME s_scm_string_downcaseS +{ + char * cstr; + int cstart, cend; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); + return string_downcase_x (scm_string_copy (str), cstart, cend); +} +#undef FUNC_NAME + + +/* Helper function for the string capitalization functions. + * No argument checking is performed. */ +static SCM +string_titlecase_x (SCM str, int start, int end) +{ + char * sz; + int i, in_word = 0; + + sz = SCM_STRING_CHARS (str); + for(i = start; i < end; i++) + { + if(SCM_NFALSEP(scm_char_alphabetic_p(SCM_MAKE_CHAR(sz[i])))) + { + if (!in_word) + { + sz[i] = scm_upcase(sz[i]); + in_word = 1; + } + else + { + sz[i] = scm_downcase(sz[i]); + } + } + else + in_word = 0; + } + return str; +} + + +SCM_DEFINE (scm_string_titlecase_x, "string-titlecase!", 1, 2, 0, + (SCM str, SCM start, SCM end), + "Destructively titlecase every first character in a word in\n" + "@var{str}.") +#define FUNC_NAME s_scm_string_titlecase_x +{ + char * cstr; + int cstart, cend; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); + return string_titlecase_x (str, cstart, cend); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_titlecase, "string-titlecase", 1, 2, 0, + (SCM str, SCM start, SCM end), + "Titlecase every first character in a word in @var{str}.") +#define FUNC_NAME s_scm_string_titlecase +{ + char * cstr; + int cstart, cend; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); + return string_titlecase_x (scm_string_copy (str), cstart, cend); +} +#undef FUNC_NAME + + +/* Reverse the portion of @var{str} between str[cstart] (including) + and str[cend] excluding. */ +static void +string_reverse_x (char * str, int cstart, int cend) +{ + char tmp; + + cend--; + while (cstart < cend) + { + tmp = str[cstart]; + str[cstart] = str[cend]; + str[cend] = tmp; + cstart++; + cend--; + } +} + + +SCM_DEFINE (scm_string_reverse, "string-reverse", 1, 2, 0, + (SCM str, SCM start, SCM end), + "Reverse the string @var{str}. The optional arguments\n" + "@var{start} and @var{end} delimit the region of @var{str} to\n" + "operate on.") +#define FUNC_NAME s_scm_string_reverse +{ + char * cstr; + int cstart; + int cend; + SCM result; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); + result = scm_string_copy (str); + string_reverse_x (SCM_STRING_CHARS (result), cstart, cend); + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_reverse_x, "string-reverse!", 1, 2, 0, + (SCM str, SCM start, SCM end), + "Reverse the string @var{str} in-place. The optional arguments\n" + "@var{start} and @var{end} delimit the region of @var{str} to\n" + "operate on. The return value is unspecified.") +#define FUNC_NAME s_scm_string_reverse_x +{ + char * cstr; + int cstart; + int cend; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); + string_reverse_x (SCM_STRING_CHARS (str), cstart, cend); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_append_shared, "string-append/shared", 0, 0, 1, + (SCM ls), + "Like @code{string-append}, but the result may share memory\n" + "with the argument strings.") +#define FUNC_NAME s_scm_string_append_shared +{ + long i; + + SCM_VALIDATE_REST_ARGUMENT (ls); + + /* Optimize the one-argument case. */ + i = scm_ilength (ls); + if (i == 1) + return SCM_CAR (ls); + else + return scm_string_append (ls); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_concatenate, "string-concatenate", 1, 0, 0, + (SCM ls), + "Append the elements of @var{ls} (which must be strings)\n" + "together into a single string. Guaranteed to return a freshly\n" + "allocated string.") +#define FUNC_NAME s_scm_string_concatenate +{ + long strings = scm_ilength (ls); + SCM tmp, result; + int len = 0; + char * p; + + /* Validate the string list. */ + if (strings < 0) + SCM_WRONG_TYPE_ARG (1, ls); + + /* Calculate the size of the result string. */ + tmp = ls; + while (!SCM_NULLP (tmp)) + { + SCM elt = SCM_CAR (tmp); + SCM_VALIDATE_STRING (1, elt); + len += SCM_STRING_LENGTH (elt); + tmp = SCM_CDR (tmp); + } + result = scm_allocate_string (len); + + /* Copy the list elements into the result. */ + p = SCM_STRING_CHARS (result); + tmp = ls; + while (!SCM_NULLP (tmp)) + { + SCM elt = SCM_CAR (tmp); + memmove (p, SCM_STRING_CHARS (elt), + SCM_STRING_LENGTH (elt) * sizeof (char)); + p += SCM_STRING_LENGTH (elt); + tmp = SCM_CDR (tmp); + } + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_reverse_string_concatenate, "reverse-string-concatenate", 1, 2, 0, + (SCM ls, SCM final_string, SCM end), + "Without optional arguments, this procedure is equivalent to\n" + "\n" + "@smalllisp\n" + "(string-concatenate (reverse ls))\n" + "@end smalllisp\n" + "\n" + "If the optional argument @var{final_string} is specified, it is\n" + "consed onto the beginning to @var{ls} before performing the\n" + "list-reverse and string-concatenate operations.\n" + "\n" + "Guaranteed to return a freshly allocated string.") +#define FUNC_NAME s_scm_reverse_string_concatenate +{ + long strings; + SCM tmp, result; + int len = 0; + char * p; + int cend = 0; + + /* Check the optional arguments and calculate the additional length + of the result string. */ + if (!SCM_UNBNDP (final_string)) + { + SCM_VALIDATE_STRING (2, final_string); + if (!SCM_UNBNDP (end)) + { + SCM_VALIDATE_INUM_COPY (3, end, cend); + SCM_ASSERT_RANGE (3, end, + (cend >= 0) && + (cend <= SCM_STRING_LENGTH (final_string))); + } + else + { + cend = SCM_STRING_LENGTH (final_string); + } + len += cend; + } + strings = scm_ilength (ls); + /* Validate the string list. */ + if (strings < 0) + SCM_WRONG_TYPE_ARG (1, ls); + + /* Calculate the length of the result string. */ + tmp = ls; + while (!SCM_NULLP (tmp)) + { + SCM elt = SCM_CAR (tmp); + SCM_VALIDATE_STRING (1, elt); + len += SCM_STRING_LENGTH (elt); + tmp = SCM_CDR (tmp); + } + + result = scm_allocate_string (len); + + p = SCM_STRING_CHARS (result) + len; + + /* Construct the result string, possibly by using the optional final + string. */ + if (!SCM_UNBNDP (final_string)) + { + p -= cend; + memmove (p, SCM_STRING_CHARS (final_string), cend * sizeof (char)); + } + tmp = ls; + while (!SCM_NULLP (tmp)) + { + SCM elt = SCM_CAR (tmp); + p -= SCM_STRING_LENGTH (elt); + memmove (p, SCM_STRING_CHARS (elt), + SCM_STRING_LENGTH (elt) * sizeof (char)); + tmp = SCM_CDR (tmp); + } + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_concatenate_shared, "string-concatenate/shared", 1, 0, 0, + (SCM ls), + "Like @code{string-concatenate}, but the result may share memory\n" + "with the strings in the list @var{ls}.") +#define FUNC_NAME s_scm_string_concatenate_shared +{ + /* Optimize the one-string case. */ + long i = scm_ilength (ls); + if (i == 1) + { + SCM_VALIDATE_STRING (1, SCM_CAR (ls)); + return SCM_CAR (ls); + } + return scm_string_concatenate (ls); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_reverse_string_concatenate_shared, "reverse-string-concatenate/shared", 1, 2, 0, + (SCM ls, SCM final_string, SCM end), + "Like @code{reverse-string-concatenate}, but the result may\n" + "share memory with the the strings in the @var{ls} arguments.") +#define FUNC_NAME s_scm_reverse_string_concatenate_shared +{ + /* Just call the non-sharing version. */ + return scm_reverse_string_concatenate (ls, final_string, end); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0, + (SCM s, SCM proc, SCM start, SCM end), + "@var{proc} is a char->char procedure, it is mapped over\n" + "@var{s}. The order in which the procedure is applied to the\n" + "string elements is not specified.") +#define FUNC_NAME s_scm_string_map +{ + char * cstr, *p; + int cstart, cend; + SCM result; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); + SCM_VALIDATE_PROC (2, proc); + result = scm_allocate_string (cend - cstart); + p = SCM_STRING_CHARS (result); + while (cstart < cend) + { + SCM ch = scm_apply (proc, SCM_MAKE_CHAR (cstr[cstart]), + scm_listofnull); + if (!SCM_CHARP (ch)) + SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (proc)); + cstart++; + *p++ = SCM_CHAR (ch); + } + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_map_x, "string-map!", 2, 2, 0, + (SCM s, SCM proc, SCM start, SCM end), + "@var{proc} is a char->char procedure, it is mapped over\n" + "@var{s}. The order in which the procedure is applied to the\n" + "string elements is not specified. The string @var{s} is\n" + "modified in-place, the return value is not specified.") +#define FUNC_NAME s_scm_string_map_x +{ + char * cstr, *p; + int cstart, cend; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); + SCM_VALIDATE_PROC (2, proc); + p = SCM_STRING_CHARS (s) + cstart; + while (cstart < cend) + { + SCM ch = scm_apply (proc, SCM_MAKE_CHAR (cstr[cstart]), + scm_listofnull); + if (!SCM_CHARP (ch)) + SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (proc)); + cstart++; + *p++ = SCM_CHAR (ch); + } + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_fold, "string-fold", 3, 2, 0, + (SCM kons, SCM knil, SCM s, SCM start, SCM end), + "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n" + "as the terminating element, from left to right. @var{kons}\n" + "must expect two arguments: The actual character and the last\n" + "result of @var{kons}' application.") +#define FUNC_NAME s_scm_string_fold +{ + char * cstr; + int cstart, cend; + SCM result; + + SCM_VALIDATE_PROC (1, kons); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr, + 4, start, cstart, + 5, end, cend); + result = knil; + while (cstart < cend) + { + result = scm_apply (kons, SCM_LIST2 (SCM_MAKE_CHAR (cstr[cstart]), + result), SCM_EOL); + cstart++; + } + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_fold_right, "string-fold-right", 3, 2, 0, + (SCM kons, SCM knil, SCM s, SCM start, SCM end), + "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n" + "as the terminating element, from right to left. @var{kons}\n" + "must expect two arguments: The actual character and the last\n" + "result of @var{kons}' application.") +#define FUNC_NAME s_scm_string_fold_right +{ + char * cstr; + int cstart, cend; + SCM result; + + SCM_VALIDATE_PROC (1, kons); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr, + 4, start, cstart, + 5, end, cend); + result = knil; + while (cstart < cend) + { + result = scm_apply (kons, SCM_LIST2 (SCM_MAKE_CHAR (cstr[cend - 1]), + result), SCM_EOL); + cend--; + } + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_unfold, "string-unfold", 4, 2, 0, + (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final), + "@itemize\n" + "@item @var{g} is used to generate a series of @emph{seed}\n" + "values from the initial @var{seed}: @var{seed}, (@var{g}\n" + "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n" + "@dots{}\n" + "@item @var{p} tells us when to stop -- when it returns true\n" + "when applied to one of these seed values.\n" + "@item @var{f} maps each seed value to the corresponding \n" + "character in the result string. These chars are assembled\n" + "into the string in a left-to-right order.\n" + "@item @var{base} is the optional initial/leftmost portion\n" + "of the constructed string; it default to the empty\n" + "string.\n" + "@item @var{make_final} is applied to the terminal seed\n" + "value (on which @var{p} returns true) to produce\n" + "the final/rightmost portion of the constructed string.\n" + "It defaults to @code{(lambda (x) "")}.\n" + "@end itemize") +#define FUNC_NAME s_scm_string_unfold +{ + SCM res, ans; + + SCM_VALIDATE_PROC (1, p); + SCM_VALIDATE_PROC (2, f); + SCM_VALIDATE_PROC (3, g); + if (!SCM_UNBNDP (base)) + { + SCM_VALIDATE_STRING (5, base); + ans = base; + } + else + ans = scm_allocate_string (0); + if (!SCM_UNBNDP (make_final)) + SCM_VALIDATE_PROC (6, make_final); + + res = scm_apply (p, seed, scm_listofnull); + while (SCM_FALSEP (res)) + { + SCM str; + SCM ch = scm_apply (f, seed, scm_listofnull); + if (!SCM_CHARP (ch)) + SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (f)); + str = scm_allocate_string (1); + *SCM_STRING_CHARS (str) = SCM_CHAR (ch); + + ans = scm_string_append (SCM_LIST2 (ans, str)); + seed = scm_apply (g, seed, scm_listofnull); + res = scm_apply (p, seed, scm_listofnull); + } + if (!SCM_UNBNDP (make_final)) + { + res = scm_apply (make_final, seed, scm_listofnull); + return scm_string_append (SCM_LIST2 (ans, res)); + } + else + return ans; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_unfold_right, "string-unfold-right", 4, 2, 0, + (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final), + "@itemize\n" + "@item @var{g} is used to generate a series of @emph{seed}\n" + "values from the initial @var{seed}: @var{seed}, (@var{g}\n" + "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n" + "@dots{}\n" + "@item @var{p} tells us when to stop -- when it returns true\n" + "when applied to one of these seed values.\n" + "@item @var{f} maps each seed value to the corresponding \n" + "character in the result string. These chars are assembled\n" + "into the string in a right-to-left order.\n" + "@item @var{base} is the optional initial/rightmost portion\n" + "of the constructed string; it default to the empty\n" + "string.\n" + "@item @var{make_final} is applied to the terminal seed\n" + "value (on which @var{p} returns true) to produce\n" + "the final/leftmost portion of the constructed string.\n" + "It defaults to @code{(lambda (x) "")}.\n" + "@end itemize") +#define FUNC_NAME s_scm_string_unfold_right +{ + SCM res, ans; + + SCM_VALIDATE_PROC (1, p); + SCM_VALIDATE_PROC (2, f); + SCM_VALIDATE_PROC (3, g); + if (!SCM_UNBNDP (base)) + { + SCM_VALIDATE_STRING (5, base); + ans = base; + } + else + ans = scm_allocate_string (0); + if (!SCM_UNBNDP (make_final)) + SCM_VALIDATE_PROC (6, make_final); + + res = scm_apply (p, seed, scm_listofnull); + while (SCM_FALSEP (res)) + { + SCM str; + SCM ch = scm_apply (f, seed, scm_listofnull); + if (!SCM_CHARP (ch)) + SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (f)); + str = scm_allocate_string (1); + *SCM_STRING_CHARS (str) = SCM_CHAR (ch); + + ans = scm_string_append (SCM_LIST2 (str, ans)); + seed = scm_apply (g, seed, scm_listofnull); + res = scm_apply (p, seed, scm_listofnull); + } + if (!SCM_UNBNDP (make_final)) + { + res = scm_apply (make_final, seed, scm_listofnull); + return scm_string_append (SCM_LIST2 (res, ans)); + } + else + return ans; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_for_each, "string-for-each", 2, 2, 0, + (SCM s, SCM proc, SCM start, SCM end), + "@var{proc} is mapped over @var{s} in left-to-right order. The\n" + "return value is not specified.") +#define FUNC_NAME s_scm_string_for_each +{ + char * cstr; + int cstart, cend; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); + SCM_VALIDATE_PROC (2, proc); + while (cstart < cend) + { + scm_apply (proc, SCM_MAKE_CHAR (cstr[cstart]), scm_listofnull); + cstart++; + } + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_xsubstring, "xsubstring", 2, 3, 0, + (SCM s, SCM from, SCM to, SCM start, SCM end), + "This is the @emph{extended substring} procedure that implements\n" + "replicated copying of a substring of some string.\n" + "\n" + "@var{s} is a string, @var{start} and @var{end} are optional\n" + "arguments that demarcate a substring of @var{s}, defaulting to\n" + "0 and the length of @var{s}. Replicate this substring up and\n" + "down index space, in both the positive and negative directions.\n" + "@code{xsubstring} returns the substring of this string\n" + "beginning at index @var{from}, and ending at @var{to}, which\n" + "defaults to @var{from} + (@var{end} - @var{start}).") +#define FUNC_NAME s_scm_xsubstring +{ + char * cs, * p; + int cstart, cend, cfrom, cto; + SCM result; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cs, + 4, start, cstart, + 5, end, cend); + SCM_VALIDATE_INUM_COPY (2, from, cfrom); + SCM_VALIDATE_INUM_DEF_COPY (3, to, cfrom + (cend - cstart), cto); + if (cstart == cend && cfrom != cto) + SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL); + + result = scm_allocate_string (cto - cfrom); + + p = SCM_STRING_CHARS (result); + while (cfrom < cto) + { + int t = ((cfrom < 0) ? -cfrom : cfrom) % (cend - cstart); + if (cfrom < 0) + *p = cs[(cend - cstart) - t]; + else + *p = cs[t]; + cfrom++; + p++; + } + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_xcopy_x, "string-xcopy!", 4, 3, 0, + (SCM target, SCM tstart, SCM s, SCM sfrom, SCM sto, SCM start, SCM end), + "Exactly the same as @code{xsubstring}, but the extracted text\n" + "is written into the string @var{target} starting at index\n" + "@var{tstart}. The operation is not defined if @code{(eq?\n" + "@var{target} @var{s})} or these arguments share storage -- you\n" + "cannot copy a string on top of itself.") +#define FUNC_NAME s_scm_string_xcopy_x +{ + char * ctarget, * cs, * p; + int ctstart, csfrom, csto, cstart, cend; + SCM dummy = SCM_UNDEFINED; + int cdummy; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, target, ctarget, + 2, tstart, ctstart, + 2, dummy, cdummy); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cs, + 6, start, cstart, + 7, end, cend); + SCM_VALIDATE_INUM_COPY (4, sfrom, csfrom); + SCM_VALIDATE_INUM_DEF_COPY (5, sto, csfrom + (cend - cstart), csto); + if (cstart == cend && csfrom != csto) + SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL); + SCM_ASSERT_RANGE (1, tstart, + ctstart + (csto - csfrom) <= SCM_STRING_LENGTH (target)); + + p = ctarget + ctstart; + while (csfrom < csto) + { + int t = ((csfrom < 0) ? -csfrom : csfrom) % (cend - cstart); + if (csfrom < 0) + *p = cs[(cend - cstart) - t]; + else + *p = cs[t]; + csfrom++; + p++; + } + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_replace, "string-replace", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return the string @var{s1}, but with the characters\n" + "@var{start1} @dots{} @var{end1} replaced by the characters\n" + "@var{start2} @dots{} @var{end2} from @var{s2}.") +#define FUNC_NAME s_scm_string_replace +{ + char * cstr1, * cstr2, * p; + int cstart1, cend1, cstart2, cend2; + SCM result; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + result = scm_allocate_string (cstart1 + (cend2 - cstart2) + + SCM_STRING_LENGTH (s1) - cend1); + p = SCM_STRING_CHARS (result); + memmove (p, cstr1, cstart1); + memmove (p + cstart1, cstr2 + cstart2, (cend2 - cstart2)); + memmove (p + cstart1 + (cend2 - cstart2), + cstr1 + cend1, + SCM_STRING_LENGTH (s1) - cend1); + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0, + (SCM s, SCM token_char, SCM start, SCM end), + "Split the string @var{s} into a list of substrings, where each\n" + "substring is a maximal non-empty contiguous sequence of\n" + "characters equal to the character @var{token_char}, or\n" + "whitespace, if @var{token_char} is not given. If\n" + "@var{token_char} is a character set, it is used for finding the\n" + "token borders.") +#define FUNC_NAME s_scm_string_tokenize +{ + char * cstr; + int cstart, cend; + SCM result = SCM_EOL; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); + if (SCM_UNBNDP (token_char)) + { + int idx; + + while (cstart < cend) + { + while (cstart < cend) + { + if (!isspace (cstr[cend - 1])) + break; + cend--; + } + if (cstart >= cend) + break; + idx = cend; + while (cstart < cend) + { + if (isspace (cstr[cend - 1])) + break; + cend--; + } + result = scm_cons (scm_makfromstr (cstr + cend, idx - cend, + 0), result); + } + } + else if (SCM_CHARSETP (token_char)) + { + int idx; + + while (cstart < cend) + { + while (cstart < cend) + { + if (!SCM_CHARSET_GET (token_char, cstr[cend - 1])) + break; + cend--; + } + if (cstart >= cend) + break; + idx = cend; + while (cstart < cend) + { + if (SCM_CHARSET_GET (token_char, cstr[cend - 1])) + break; + cend--; + } + result = scm_cons (scm_makfromstr (cstr + cend, idx - cend, + 0), result); + } + } + else + { + int idx; + char chr; + + SCM_VALIDATE_CHAR (2, token_char); + chr = SCM_CHAR (token_char); + + while (cstart < cend) + { + while (cstart < cend) + { + if (cstr[cend - 1] != chr) + break; + cend--; + } + if (cstart >= cend) + break; + idx = cend; + while (cstart < cend) + { + if (cstr[cend - 1] == chr) + break; + cend--; + } + result = scm_cons (scm_makfromstr (cstr + cend, idx - cend, + 0), result); + } + } + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0, + (SCM s, SCM char_pred, SCM start, SCM end), + "Filter the string @var{s}, retaining only those characters that\n" + "satisfy the @var{char_pred} argument. If the argument is a\n" + "procedure, it is applied to each character as a predicate, if\n" + "it is a character, it is tested for equality and if it is a\n" + "character set, it is tested for membership.") +#define FUNC_NAME s_scm_string_filter +{ + char * cstr; + int cstart, cend; + SCM result; + int idx; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); + if (SCM_CHARP (char_pred)) + { + SCM ls = SCM_EOL; + char chr; + + chr = SCM_CHAR (char_pred); + idx = cstart; + while (idx < cend) + { + if (cstr[idx] == chr) + ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); + idx++; + } + result = scm_reverse_list_to_string (ls); + } + else if (SCM_CHARSETP (char_pred)) + { + SCM ls = SCM_EOL; + + idx = cstart; + while (idx < cend) + { + if (SCM_CHARSET_GET (char_pred, cstr[idx])) + ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); + idx++; + } + result = scm_reverse_list_to_string (ls); + } + else + { + SCM ls = SCM_EOL; + + SCM_VALIDATE_PROC (2, char_pred); + idx = cstart; + while (idx < cend) + { + SCM res; + res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[idx]), + scm_listofnull); + if (!SCM_FALSEP (res)) + ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); + idx++; + } + result = scm_reverse_list_to_string (ls); + } + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0, + (SCM s, SCM char_pred, SCM start, SCM end), + "Filter the string @var{s}, retaining only those characters that\n" + "do not satisfy the @var{char_pred} argument. If the argument\n" + "is a procedure, it is applied to each character as a predicate,\n" + "if it is a character, it is tested for equality and if it is a\n" + "character set, it is tested for membership.") +#define FUNC_NAME s_scm_string_delete +{ + char * cstr; + int cstart, cend; + SCM result; + int idx; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); + if (SCM_CHARP (char_pred)) + { + SCM ls = SCM_EOL; + char chr; + + chr = SCM_CHAR (char_pred); + idx = cstart; + while (idx < cend) + { + if (cstr[idx] != chr) + ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); + idx++; + } + result = scm_reverse_list_to_string (ls); + } + else if (SCM_CHARSETP (char_pred)) + { + SCM ls = SCM_EOL; + + idx = cstart; + while (idx < cend) + { + if (SCM_CHARSET_GET (char_pred, cstr[idx])) + ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); + idx++; + } + result = scm_reverse_list_to_string (ls); + } + else + { + SCM ls = SCM_EOL; + + SCM_VALIDATE_PROC (2, char_pred); + idx = cstart; + while (idx < cend) + { + SCM res; + res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[idx]), + scm_listofnull); + if (SCM_FALSEP (res)) + ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); + idx++; + } + result = scm_reverse_list_to_string (ls); + } + return result; +} +#undef FUNC_NAME + + +void +scm_init_srfi_13 () +{ +#ifndef SCM_MAGIC_SNARFER +#include "srfi-13.x" +#endif +} + + +void +scm_init_srfi_13_14 () +{ + static int initialized = 0; + + if (!initialized) + { + SCM srfi_13_module = scm_make_module (scm_read_0str ("(srfi srfi-13)")); + SCM srfi_14_module = scm_make_module (scm_read_0str ("(srfi srfi-14)")); + SCM old_module; + + initialized = 1; + + old_module = scm_set_current_module (srfi_13_module); + scm_init_srfi_13 (); + scm_set_current_module (srfi_14_module); + scm_init_srfi_14 (); + + scm_set_current_module (old_module); + } +} diff --git a/srfi/srfi-13.scm b/srfi/srfi-13.scm new file mode 100644 index 000000000..9b28b65ee --- /dev/null +++ b/srfi/srfi-13.scm @@ -0,0 +1,141 @@ +;;;; srfi-13.scm --- SRFI-13 procedures for Guile +;;;; +;;;; Copyright (C) 2001 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +(define-module (srfi srfi-13)) + +(export +;;; Predicates + ;; string? string-null? <= in the core + string-any string-every + +;;; Constructors + ;; make-string string <= in the core + string-tabulate + +;;; List/string conversion + string->list + ;; list->string <= in the core + reverse-list->string + string-join + +;;; Selection + ;; string-length string-ref <= in the core + string-copy + substring/shared + string-copy! + string-take string-take-right + string-drop string-drop-right + string-pad string-pad-right + string-trim string-trim-right + string-trim-both + +;;; Modification + ;; string-set! <= in the core + string-fill! + +;;; Comparison + string-compare string-compare-ci + string= string<> + string< string> + string<= string>= + string-ci= string-ci<> + string-ci< string-ci> + string-ci<= string-ci>= + string-hash string-hash-ci ; FIXME::martin: rewrite in C? + +;;; Prefixes/Suffixes + string-prefix-length + string-prefix-length-ci + string-suffix-length + string-suffix-length-ci + string-prefix? + string-prefix-ci? + string-suffix? + string-suffix-ci? + +;;; Searching + string-index string-index-right + string-skip string-skip-right + string-count + string-contains string-contains-ci + +;;; Alphabetic case mapping + + string-upcase string-upcase! + string-downcase string-downcase! + string-titlecase string-titlecase! + +;;; Reverse/Append + string-reverse string-reverse! + ;; string-append <= in the core + string-append/shared + string-concatenate + reverse-string-concatenate + string-concatenate/shared + reverse-string-concatenate/shared + +;;; Fold/Unfold/Map + string-map string-map! + string-fold + string-fold-right + string-unfold + string-unfold-right + string-for-each + +;;; Replicate/Rotate + xsubstring string-xcopy! + +;;; Miscellaneous + string-replace + string-tokenize + +;;; Filtering/Deleting + string-filter + string-delete + ) + +(dynamic-call "scm_init_srfi_13_14" (dynamic-link "libguile-srfi-srfi-13-14")) + +(define string-hash + (lambda (s . rest) + (let ((bound (if (pair? rest) + (or (car rest) + 871) + 871)) + (start (if (and (pair? rest) (pair? (cdr rest))) + (cadr rest) + 0)) + (end (if (and (pair? rest) (pair? (cdr rest)) (pair? (cddr rest))) + (caddr rest) + (string-length s)))) + (hash (substring/shared s start end) bound)))) + +(define string-hash-ci + (lambda (s . rest) + (let ((bound (if (pair? rest) + (or (car rest) + 871) + 871)) + (start (if (and (pair? rest) (pair? (cdr rest))) + (cadr rest) + 0)) + (end (if (and (pair? rest) (pair? (cdr rest)) (pair? (cddr rest))) + (caddr rest) + (string-length s)))) + (hash (string-upcase (substring/shared s start end)) bound)))) diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c new file mode 100644 index 000000000..b3af7c2b4 --- /dev/null +++ b/srfi/srfi-14.c @@ -0,0 +1,1361 @@ +/* srfi-14.c --- SRFI-14 procedures for Guile + * + * Copyright (C) 2001 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives + * permission for additional uses of the text contained in its release + * of GUILE. + * + * The exception is that, if you link the GUILE library with other + * files to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public + * License. Your use of that executable is in no way restricted on + * account of linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public + * License. + * + * This exception applies only to the code released by the Free + * Software Foundation under the name GUILE. If you copy code from + * other Free Software Foundation releases into a copy of GUILE, as + * the General Public License permits, the exception does not apply to + * the code that you add in this way. To avoid misleading anyone as + * to the status of such modified files, you must delete this + * exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + + +#include + +#include + +#include "srfi-14.h" + +#define SCM_CHARSET_SET(cs, idx) (((long *) SCM_SMOB_DATA (cs))[(idx) / sizeof (long)] |= (1 << ((idx) % sizeof (long)))) + +SCM scm_char_set_copy (SCM cs); + +/* Smob type code for character sets. */ +int scm_tc16_charset = 0; + + +/* Smob print hook for character sets. */ +static int +charset_print (SCM charset, SCM port, scm_print_state *pstate) +{ + int i; + int first = 1; + + scm_puts ("#", port); + return 1; +} + + +/* Smob free hook for character sets. */ +static scm_sizet +charset_free (SCM charset) +{ + return scm_smob_free (charset); +} + + +/* Create a new, empty character set. */ +static SCM +make_char_set (const char * func_name) +{ + long * p; + + p = scm_must_malloc (SCM_CHARSET_SIZE, func_name); + memset (p, 0, SCM_CHARSET_SIZE); + SCM_RETURN_NEWSMOB (scm_tc16_charset, p); +} + + +SCM_DEFINE (scm_char_set_p, "char-set?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a character set, @code{#f}\n" + "otherwise.") +#define FUNC_NAME s_scm_char_set_p +{ + return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_charset, obj)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_eq, "char-set=", 1, 0, 1, + (SCM cs1, SCM csr), + "Return @code{#t} if all given character sets are equal.") +#define FUNC_NAME s_scm_char_set_eq +{ + int argnum = 2; + + SCM_VALIDATE_SMOB (1, cs1, charset); + SCM_VALIDATE_REST_ARGUMENT (csr); + + while (!SCM_NULLP (csr)) + { + long * p1, * p2; + SCM cs2 = SCM_CAR (csr); + int k; + + SCM_VALIDATE_SMOB (argnum++, cs2, charset); + p1 = (long *) SCM_SMOB_DATA (cs1); + p2 = (long *) SCM_SMOB_DATA (cs2); + for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + { + if (p1[k] != p2[k]) + return SCM_BOOL_F; + } + + csr = SCM_CDR (csr); + cs1 = cs2; + } + return SCM_BOOL_T; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_leq, "char-set<=", 1, 0, 1, + (SCM cs1, SCM csr), + "Return @code{#t} if every character set @var{cs}i is a subset\n" + "of character set @var{cs}i+1.") +#define FUNC_NAME s_scm_char_set_leq +{ + int argnum = 2; + + SCM_VALIDATE_SMOB (1, cs1, charset); + SCM_VALIDATE_REST_ARGUMENT (csr); + + while (!SCM_NULLP (csr)) + { + long * p1, * p2; + SCM cs2 = SCM_CAR (csr); + int k; + + SCM_VALIDATE_SMOB (argnum++, cs2, charset); + p1 = (long *) SCM_SMOB_DATA (cs1); + p2 = (long *) SCM_SMOB_DATA (cs2); + for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + { + if ((p1[k] & p2[k]) != p1[k]) + return SCM_BOOL_F; + } + + csr = SCM_CDR (csr); + cs1 = cs2; + } + return SCM_BOOL_T; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0, + (SCM cs, SCM bound), + "Compute a hash value for the character set @var{cs}. If\n" + "@var{bound} is given and not @code{#f}, it restricts the\n" + "returned value to the range 0 @dots{} @var{bound - 1}.") +#define FUNC_NAME s_scm_char_set_hash +{ + int bnd; + long * p; + unsigned val = 0; + int k; + + SCM_VALIDATE_SMOB (1, cs, charset); + if (SCM_UNBNDP (bound) || SCM_FALSEP (bound)) + bnd = 871; + else + SCM_VALIDATE_INUM_COPY (2, bound, bnd); + + p = (long *) SCM_SMOB_DATA (cs); + for (k = 0; k < SCM_CHARSET_SIZE - 1; k++) + { + val = p[k] ^ val; + } + return SCM_MAKINUM (val % bnd); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_cursor, "char-set-cursor", 1, 0, 0, + (SCM cs), + "Return a cursor into the character set @var{cs}.") +#define FUNC_NAME s_scm_char_set_cursor +{ + int idx; + + SCM_VALIDATE_SMOB (1, cs, charset); + for (idx = 0; idx < SCM_CHARSET_SIZE; idx++) + { + if (SCM_CHARSET_GET (cs, idx)) + break; + } + return SCM_MAKINUM (idx); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_ref, "char-set-ref", 2, 0, 0, + (SCM cs, SCM cursor), + "Return the character at the current cursor position\n" + "@var{cursor} in the character set @var{cs}. It is an error to\n" + "pass a cursor for which @code{end-of-char-set?} returns true.") +#define FUNC_NAME s_scm_char_set_ref +{ + int ccursor; + + SCM_VALIDATE_SMOB (1, cs, charset); + SCM_VALIDATE_INUM_COPY (2, cursor, ccursor); + + if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor)) + SCM_MISC_ERROR ("invalid character set cursor: ~A", SCM_LIST1 (cursor)); + return SCM_MAKE_CHAR (ccursor); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_cursor_next, "char-set-cursor-next", 2, 0, 0, + (SCM cs, SCM cursor), + "Advance the character set cursor @var{cursor} to the next\n" + "character in the character set @var{cs}. It is an error if the\n" + "cursor given satisfies @code{end-of-char-set?}.") +#define FUNC_NAME s_scm_char_set_cursor_next +{ + int ccursor; + + SCM_VALIDATE_SMOB (1, cs, charset); + SCM_VALIDATE_INUM_COPY (2, cursor, ccursor); + + if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor)) + SCM_MISC_ERROR ("invalid character set cursor: ~A", SCM_LIST1 (cursor)); + for (ccursor++; ccursor < SCM_CHARSET_SIZE; ccursor++) + { + if (SCM_CHARSET_GET (cs, ccursor)) + break; + } + return SCM_MAKINUM (ccursor); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_end_of_char_set_p, "end-of-char-set?", 1, 0, 0, + (SCM cursor), + "Return @code{#t} if @var{cursor} has reached the end of a\n" + "character set, @code{#f} otherwise.") +#define FUNC_NAME s_scm_end_of_char_set_p +{ + int ccursor; + + SCM_VALIDATE_INUM_COPY (1, cursor, ccursor); + return SCM_BOOL (ccursor >= SCM_CHARSET_SIZE); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_fold, "char-set-fold", 3, 0, 0, + (SCM kons, SCM knil, SCM cs), + "Fold the procedure @var{kons} over the character set @var{cs},\n" + "initializing it with @var{knil}.") +#define FUNC_NAME s_scm_char_set_fold +{ + int k; + + SCM_VALIDATE_PROC (1, kons); + SCM_VALIDATE_SMOB (3, cs, charset); + + for (k = 0; k < SCM_CHARSET_SIZE; k++) + if (SCM_CHARSET_GET (cs, k)) + { + knil = scm_apply (kons, SCM_LIST2 (SCM_MAKE_CHAR (k), (knil)), + SCM_EOL); + } + return knil; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_char_set_unfold, "char-set-unfold", 4, 1, 0, + (SCM p, SCM f, SCM g, SCM seed, SCM base_cs), + "This is a fundamental constructor for character sets.\n" + "@itemize\n" + "@item @var{g} is used to generate a series of ``seed'' values \n" + "from the initial seed: @var{seed}, (@var{g} @var{seed}),\n" + "(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n" + "@item @var{p} tells us when to stop -- when it returns true\n" + "when applied to one of the seed values. \n" + "@item @var{f} maps each seed value to a character. These\n" + "characters are added to the base character set @var{base_cs} to\n" + "form the result; @var{base_cs} defaults to the empty set.\n" + "@end itemize") +#define FUNC_NAME s_scm_char_set_unfold +{ + SCM result, tmp; + + SCM_VALIDATE_PROC (1, p); + SCM_VALIDATE_PROC (2, f); + SCM_VALIDATE_PROC (3, g); + if (!SCM_UNBNDP (base_cs)) + { + SCM_VALIDATE_SMOB (5, base_cs, charset); + result = scm_char_set_copy (base_cs); + } + else + result = make_char_set (FUNC_NAME); + + tmp = scm_apply (p, seed, scm_listofnull); + while (SCM_FALSEP (tmp)) + { + SCM ch = scm_apply (f, seed, scm_listofnull); + if (!SCM_CHARP (ch)) + SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (f)); + SCM_CHARSET_SET (result, SCM_CHAR (ch)); + + seed = scm_apply (g, seed, scm_listofnull); + tmp = scm_apply (p, seed, scm_listofnull); + } + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_unfold_x, "char-set-unfold!", 5, 0, 0, + (SCM p, SCM f, SCM g, SCM seed, SCM base_cs), + "This is a fundamental constructor for character sets.\n" + "@itemize\n" + "@item @var{g} is used to generate a series of ``seed'' values\n" + "from the initial seed: @var{seed}, (@var{g} @var{seed}), \n" + "(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n" + "@item @var{p} tells us when to stop -- when it returns true\n" + "when applied to one of the seed values. \n" + "@item @var{f} maps each seed value to a character. These\n" + "characters are added to the base character set @var{base_cs} to\n" + "form the result; @var{base_cs} defaults to the empty set.\n" + "@end itemize") +#define FUNC_NAME s_scm_char_set_unfold_x +{ + SCM tmp; + + SCM_VALIDATE_PROC (1, p); + SCM_VALIDATE_PROC (2, f); + SCM_VALIDATE_PROC (3, g); + SCM_VALIDATE_SMOB (5, base_cs, charset); + + tmp = scm_apply (p, seed, scm_listofnull); + while (SCM_FALSEP (tmp)) + { + SCM ch = scm_apply (f, seed, scm_listofnull); + if (!SCM_CHARP (ch)) + SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (f)); + SCM_CHARSET_SET (base_cs, SCM_CHAR (ch)); + + seed = scm_apply (g, seed, scm_listofnull); + tmp = scm_apply (p, seed, scm_listofnull); + } + return base_cs; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_for_each, "char-set-for-each", 2, 0, 0, + (SCM proc, SCM cs), + "Apply @var{proc} to every character in the character set\n" + "@var{cs}. The return value is not specified.") +#define FUNC_NAME s_scm_char_set_for_each +{ + int k; + + SCM_VALIDATE_PROC (1, proc); + SCM_VALIDATE_SMOB (2, cs, charset); + + for (k = 0; k < SCM_CHARSET_SIZE; k++) + if (SCM_CHARSET_GET (cs, k)) + scm_apply (proc, SCM_MAKE_CHAR (k), scm_listofnull); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_map, "char-set-map", 2, 0, 0, + (SCM proc, SCM cs), + "Map the procedure @var{proc} over every character in @var{cs}.\n" + "@var{proc} must be a character -> character procedure.") +#define FUNC_NAME s_scm_char_set_map +{ + SCM result; + int k; + + SCM_VALIDATE_PROC (1, proc); + SCM_VALIDATE_SMOB (2, cs, charset); + + result = make_char_set (FUNC_NAME); + for (k = 0; k < SCM_CHARSET_SIZE; k++) + if (SCM_CHARSET_GET (cs, k)) + { + SCM ch = scm_apply (proc, SCM_MAKE_CHAR (k), scm_listofnull); + if (!SCM_CHARP (ch)) + SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (proc)); + SCM_CHARSET_SET (cs, SCM_CHAR (ch)); + } + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_copy, "char-set-copy", 1, 0, 0, + (SCM cs), + "Return a newly allocated character set containing all\n" + "characters in @var{cs}.") +#define FUNC_NAME s_scm_char_set_copy +{ + SCM ret; + long * p1, * p2; + int k; + + SCM_VALIDATE_SMOB (1, cs, charset); + ret = make_char_set (FUNC_NAME); + p1 = (long *) SCM_SMOB_DATA (cs); + p2 = (long *) SCM_SMOB_DATA (ret); + for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + p2[k] = p1[k]; + return ret; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set, "char-set", 0, 0, 1, + (SCM rest), + "Return a character set containing all given characters.") +#define FUNC_NAME s_scm_char_set +{ + SCM cs, ls; + long * p; + + SCM_VALIDATE_REST_ARGUMENT (rest); + ls = rest; + cs = make_char_set (FUNC_NAME); + p = (long *) SCM_SMOB_DATA (cs); + while (!SCM_NULLP (ls)) + { + SCM chr = SCM_CAR (ls); + int c; + + SCM_VALIDATE_CHAR_COPY (1, chr, c); + ls = SCM_CDR (ls); + + p[c / sizeof (long)] |= 1 << (c % sizeof (long)); + } + return cs; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_list_to_char_set, "list->char-set", 1, 1, 0, + (SCM list, SCM base_cs), + "Convert the character list @var{list} to a character set. If\n" + "the character set @var{base_cs} is given, the character in this\n" + "set are also included in the result.") +#define FUNC_NAME s_scm_list_to_char_set +{ + SCM cs; + long * p; + + SCM_VALIDATE_LIST (1, list); + if (SCM_UNBNDP (base_cs)) + cs = make_char_set (FUNC_NAME); + else + { + SCM_VALIDATE_SMOB (2, base_cs, charset); + cs = scm_char_set_copy (base_cs); + } + p = (long *) SCM_SMOB_DATA (cs); + while (!SCM_NULLP (list)) + { + SCM chr = SCM_CAR (list); + int c; + + SCM_VALIDATE_CHAR_COPY (1, chr, c); + list = SCM_CDR (list); + + p[c / sizeof (long)] |= 1 << (c % sizeof (long)); + } + return cs; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_list_to_char_set_x, "list->char-set!", 2, 0, 0, + (SCM list, SCM base_cs), + "Convert the character list @var{list} to a character set. The\n" + "characters are added to @var{base_cs} and @var{base_cs} is\n" + "returned.") +#define FUNC_NAME s_scm_list_to_char_set +{ + long * p; + + SCM_VALIDATE_LIST (1, list); + SCM_VALIDATE_SMOB (2, base_cs, charset); + p = (long *) SCM_SMOB_DATA (base_cs); + while (!SCM_NULLP (list)) + { + SCM chr = SCM_CAR (list); + int c; + + SCM_VALIDATE_CHAR_COPY (1, chr, c); + list = SCM_CDR (list); + + p[c / sizeof (long)] |= 1 << (c % sizeof (long)); + } + return base_cs; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_to_char_set, "string->char-set", 1, 1, 0, + (SCM str, SCM base_cs), + "Convert the string @var{str} to a character set. If the\n" + "character set @var{base_cs} is given, the characters in this\n" + "set are also included in the result.") +#define FUNC_NAME s_scm_string_to_char_set +{ + SCM cs; + long * p; + char * s; + int k = 0; + + SCM_VALIDATE_STRING (1, str); + if (SCM_UNBNDP (base_cs)) + cs = make_char_set (FUNC_NAME); + else + { + SCM_VALIDATE_SMOB (2, base_cs, charset); + cs = scm_char_set_copy (base_cs); + } + p = (long *) SCM_SMOB_DATA (cs); + s = SCM_STRING_CHARS (str); + while (k < SCM_STRING_LENGTH (str)) + { + int c = s[k++]; + p[c / sizeof (long)] |= 1 << (c % sizeof (long)); + } + return cs; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_to_char_set_x, "string->char-set!", 2, 0, 0, + (SCM str, SCM base_cs), + "Convert the string @var{str} to a character set. The\n" + "characters from the string are added to @var{base_cs}, and\n" + "@var{base_cs} is returned.") +#define FUNC_NAME s_scm_string_to_char_set_x +{ + long * p; + char * s; + int k = 0; + + SCM_VALIDATE_STRING (1, str); + SCM_VALIDATE_SMOB (2, base_cs, charset); + p = (long *) SCM_SMOB_DATA (base_cs); + s = SCM_STRING_CHARS (str); + while (k < SCM_STRING_LENGTH (str)) + { + int c = s[k++]; + p[c / sizeof (long)] |= 1 << (c % sizeof (long)); + } + return base_cs; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_filter, "char-set-filter", 2, 1, 0, + (SCM pred, SCM cs, SCM base_cs), + "Return a character set containing every character from @var{cs}\n" + "so that it satisfies @var{pred}. If provided, the characters\n" + "from @var{base_cs} are added to the result.") +#define FUNC_NAME s_scm_char_set_filter +{ + SCM ret; + int k; + long * p; + + SCM_VALIDATE_PROC (1, pred); + SCM_VALIDATE_SMOB (2, cs, charset); + if (!SCM_UNBNDP (base_cs)) + { + SCM_VALIDATE_SMOB (3, base_cs, charset); + ret = scm_char_set_copy (base_cs); + } + else + ret = make_char_set (FUNC_NAME); + p = (long *) SCM_SMOB_DATA (ret); + for (k = 0; k < SCM_CHARSET_SIZE; k++) + { + if (SCM_CHARSET_GET (cs, k)) + { + SCM res = scm_apply (pred, SCM_MAKE_CHAR (k), scm_listofnull); + + if (!SCM_FALSEP (res)) + p[k / sizeof (long)] |= 1 << (k % sizeof (long)); + } + } + return ret; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_filter_x, "char-set-filter!", 3, 0, 0, + (SCM pred, SCM cs, SCM base_cs), + "Return a character set containing every character from @var{cs}\n" + "so that it satisfies @var{pred}. The characters are added to\n" + "@var{base_cs} and @var{base_cs} is returned.") +#define FUNC_NAME s_scm_char_set_filter_x +{ + int k; + long * p; + + SCM_VALIDATE_PROC (1, pred); + SCM_VALIDATE_SMOB (2, cs, charset); + SCM_VALIDATE_SMOB (3, base_cs, charset); + p = (long *) SCM_SMOB_DATA (base_cs); + for (k = 0; k < SCM_CHARSET_SIZE; k++) + { + if (SCM_CHARSET_GET (cs, k)) + { + SCM res = scm_apply (pred, SCM_MAKE_CHAR (k), scm_listofnull); + + if (!SCM_FALSEP (res)) + p[k / sizeof (long)] |= 1 << (k % sizeof (long)); + } + } + return base_cs; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0, + (SCM lower, SCM upper, SCM error, SCM base_cs), + "Return a character set containing all characters whose\n" + "character codes lie in the half-open range\n" + "[@var{lower},@var{upper}).\n" + "\n" + "If @var{error} is a true value, an error is signalled if the\n" + "specified range contains characters which are not contained in\n" + "the implemented character range. If @var{error} is @code{#f},\n" + "these characters are silently left out of the resultung\n" + "character set.\n" + "\n" + "The characters in @var{base_cs} are added to the result, if\n" + "given.") +#define FUNC_NAME s_scm_ucs_range_to_char_set +{ + SCM cs; + int clower, cupper; + long * p; + + SCM_VALIDATE_INUM_COPY (1, lower, clower); + SCM_VALIDATE_INUM_COPY (2, upper, cupper); + SCM_ASSERT_RANGE (1, lower, clower >= 0); + SCM_ASSERT_RANGE (2, upper, cupper >= 0 && cupper >= clower); + if (!SCM_UNBNDP (error)) + { + if (!SCM_FALSEP (error)) + { + SCM_ASSERT_RANGE (1, lower, clower <= SCM_CHARSET_SIZE); + SCM_ASSERT_RANGE (2, upper, cupper <= SCM_CHARSET_SIZE); + } + } + if (clower > SCM_CHARSET_SIZE) + clower = SCM_CHARSET_SIZE; + if (cupper > SCM_CHARSET_SIZE) + cupper = SCM_CHARSET_SIZE; + if (SCM_UNBNDP (base_cs)) + cs = make_char_set (FUNC_NAME); + else + { + SCM_VALIDATE_SMOB (2, base_cs, charset); + cs = scm_char_set_copy (base_cs); + } + p = (long *) SCM_SMOB_DATA (cs); + while (clower < cupper) + { + p[clower / sizeof (long)] |= 1 << (clower % sizeof (long)); + clower++; + } + return cs; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_ucs_range_to_char_set_x, "ucs-range->char-set!", 4, 0, 0, + (SCM lower, SCM upper, SCM error, SCM base_cs), + "Return a character set containing all characters whose\n" + "character codes lie in the half-open range\n" + "[@var{lower},@var{upper}).\n" + "\n" + "If @var{error} is a true value, an error is signalled if the\n" + "specified range contains characters which are not contained in\n" + "the implemented character range. If @var{error} is @code{#f},\n" + "these characters are silently left out of the resultung\n" + "character set.\n" + "\n" + "The characters are added to @var{base_cs} and @var{base_cs} is\n" + "returned.") +#define FUNC_NAME s_scm_ucs_range_to_char_set_x +{ + int clower, cupper; + long * p; + + SCM_VALIDATE_INUM_COPY (1, lower, clower); + SCM_VALIDATE_INUM_COPY (2, upper, cupper); + SCM_ASSERT_RANGE (1, lower, clower >= 0); + SCM_ASSERT_RANGE (2, upper, cupper >= 0 && cupper >= clower); + if (!SCM_FALSEP (error)) + { + SCM_ASSERT_RANGE (1, lower, clower <= SCM_CHARSET_SIZE); + SCM_ASSERT_RANGE (2, upper, cupper <= SCM_CHARSET_SIZE); + } + if (clower > SCM_CHARSET_SIZE) + clower = SCM_CHARSET_SIZE; + if (cupper > SCM_CHARSET_SIZE) + cupper = SCM_CHARSET_SIZE; + p = (long *) SCM_SMOB_DATA (base_cs); + while (clower < cupper) + { + p[clower / sizeof (long)] |= 1 << (clower % sizeof (long)); + clower++; + } + return base_cs; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_size, "char-set-size", 1, 0, 0, + (SCM cs), + "Return the number of elements in character set @var{cs}.") +#define FUNC_NAME s_scm_char_set_size +{ + int k, count = 0; + + SCM_VALIDATE_SMOB (1, cs, charset); + for (k = 0; k < SCM_CHARSET_SIZE; k++) + if (SCM_CHARSET_GET (cs, k)) + count++; + return SCM_MAKINUM (count); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_count, "char-set-count", 2, 0, 0, + (SCM pred, SCM cs), + "Return the number of the elements int the character set\n" + "@var{cs} which satisfy the predicate @var{pred}.") +#define FUNC_NAME s_scm_char_set_count +{ + int k, count = 0; + + SCM_VALIDATE_PROC (1, pred); + SCM_VALIDATE_SMOB (2, cs, charset); + + for (k = 0; k < SCM_CHARSET_SIZE; k++) + if (SCM_CHARSET_GET (cs, k)) + { + SCM res = scm_apply (pred, SCM_MAKE_CHAR (k), scm_listofnull); + if (!SCM_FALSEP (res)) + count++; + } + return SCM_MAKINUM (count); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_to_list, "char-set->list", 1, 0, 0, + (SCM cs), + "Return a list containing the elements of the character set\n" + "@var{cs}.") +#define FUNC_NAME s_scm_char_set_to_list +{ + int k; + SCM result = SCM_EOL; + + SCM_VALIDATE_SMOB (1, cs, charset); + for (k = SCM_CHARSET_SIZE; k > 0; k--) + if (SCM_CHARSET_GET (cs, k - 1)) + result = scm_cons (SCM_MAKE_CHAR (k - 1), result); + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_to_string, "char-set->string", 1, 0, 0, + (SCM cs), + "Return a string containing the elements of the character set\n" + "@var{cs}. The order in which the characters are placed in the\n" + "string is not defined.") +#define FUNC_NAME s_scm_char_set_to_string +{ + int k; + int count = 0; + int idx = 0; + SCM result; + char * p; + + SCM_VALIDATE_SMOB (1, cs, charset); + for (k = 0; k < SCM_CHARSET_SIZE; k++) + if (SCM_CHARSET_GET (cs, k)) + count++; + result = scm_allocate_string (count); + p = SCM_STRING_CHARS (result); + for (k = 0; k < SCM_CHARSET_SIZE; k++) + if (SCM_CHARSET_GET (cs, k)) + p[idx++] = k; + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_contains_p, "char-set-contains?", 2, 0, 0, + (SCM cs, SCM ch), + "Return @code{#t} iff the character @var{ch} is contained in the\n" + "character set @var{cs}.") +#define FUNC_NAME s_scm_char_set_contains_p +{ + SCM_VALIDATE_SMOB (1, cs, charset); + SCM_VALIDATE_CHAR (2, ch); + return SCM_BOOL (SCM_CHARSET_GET (cs, SCM_CHAR (ch))); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_every, "char-set-every", 2, 0, 0, + (SCM pred, SCM cs), + "Return a true value if every character in the character set\n" + "@var{cs} satisfies the predicate @var{pred}.") +#define FUNC_NAME s_scm_char_set_every +{ + int k; + SCM res = SCM_BOOL_T; + + SCM_VALIDATE_PROC (1, pred); + SCM_VALIDATE_SMOB (2, cs, charset); + + for (k = 0; k < SCM_CHARSET_SIZE; k++) + if (SCM_CHARSET_GET (cs, k)) + { + res = scm_apply (pred, SCM_MAKE_CHAR (k), scm_listofnull); + if (SCM_FALSEP (res)) + return res; + } + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_any, "char-set-any", 2, 0, 0, + (SCM pred, SCM cs), + "Return a true value if any character in the character set\n" + "@var{cs} satisfies the predicate @var{pred}.") +#define FUNC_NAME s_scm_char_set_any +{ + int k; + + SCM_VALIDATE_PROC (1, pred); + SCM_VALIDATE_SMOB (2, cs, charset); + + for (k = 0; k < SCM_CHARSET_SIZE; k++) + if (SCM_CHARSET_GET (cs, k)) + { + SCM res = scm_apply (pred, SCM_MAKE_CHAR (k), scm_listofnull); + if (!SCM_FALSEP (res)) + return res; + } + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_adjoin, "char-set-adjoin", 1, 0, 1, + (SCM cs, SCM rest), + "Add all character arguments to the first argument, which must\n" + "be a character set.") +#define FUNC_NAME s_scm_char_set_adjoin +{ + long * p; + + SCM_VALIDATE_SMOB (1, cs, charset); + SCM_VALIDATE_REST_ARGUMENT (rest); + cs = scm_char_set_copy (cs); + + p = (long *) SCM_SMOB_DATA (cs); + while (!SCM_NULLP (rest)) + { + SCM chr = SCM_CAR (rest); + int c; + + SCM_VALIDATE_CHAR_COPY (1, chr, c); + rest = SCM_CDR (rest); + + p[c / sizeof (long)] |= 1 << (c % sizeof (long)); + } + return cs; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_char_set_delete, "char-set-delete", 1, 0, 1, + (SCM cs, SCM rest), + "Delete all character arguments from the first argument, which\n" + "must be a character set.") +#define FUNC_NAME s_scm_char_set_delete +{ + long * p; + + SCM_VALIDATE_SMOB (1, cs, charset); + SCM_VALIDATE_REST_ARGUMENT (rest); + cs = scm_char_set_copy (cs); + + p = (long *) SCM_SMOB_DATA (cs); + while (!SCM_NULLP (rest)) + { + SCM chr = SCM_CAR (rest); + int c; + + SCM_VALIDATE_CHAR_COPY (1, chr, c); + rest = SCM_CDR (rest); + + p[c / sizeof (long)] &= ~(1 << (c % sizeof (long))); + } + return cs; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_char_set_adjoin_x, "char-set-adjoin!", 1, 0, 1, + (SCM cs, SCM rest), + "Add all character arguments to the first argument, which must\n" + "be a character set.") +#define FUNC_NAME s_scm_char_set_adjoin_x +{ + long * p; + + SCM_VALIDATE_SMOB (1, cs, charset); + SCM_VALIDATE_REST_ARGUMENT (rest); + + p = (long *) SCM_SMOB_DATA (cs); + while (!SCM_NULLP (rest)) + { + SCM chr = SCM_CAR (rest); + int c; + + SCM_VALIDATE_CHAR_COPY (1, chr, c); + rest = SCM_CDR (rest); + + p[c / sizeof (long)] |= 1 << (c % sizeof (long)); + } + return cs; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_char_set_delete_x, "char-set-delete!", 1, 0, 1, + (SCM cs, SCM rest), + "Delete all character arguments from the first argument, which\n" + "must be a character set.") +#define FUNC_NAME s_scm_char_set_delete_x +{ + long * p; + + SCM_VALIDATE_SMOB (1, cs, charset); + SCM_VALIDATE_REST_ARGUMENT (rest); + + p = (long *) SCM_SMOB_DATA (cs); + while (!SCM_NULLP (rest)) + { + SCM chr = SCM_CAR (rest); + int c; + + SCM_VALIDATE_CHAR_COPY (1, chr, c); + rest = SCM_CDR (rest); + + p[c / sizeof (long)] &= ~(1 << (c % sizeof (long))); + } + return cs; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_complement, "char-set-complement", 1, 0, 0, + (SCM cs), + "Return the complement of the character set @var{cs}.") +#define FUNC_NAME s_scm_char_set_complement +{ + int k; + SCM res; + long * p, * q; + + SCM_VALIDATE_SMOB (1, cs, charset); + + res = make_char_set (FUNC_NAME); + p = (long *) SCM_SMOB_DATA (res); + q = (long *) SCM_SMOB_DATA (cs); + for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + p[k] = ~q[k]; + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_union, "char-set-union", 0, 0, 1, + (SCM rest), + "Return the union of all argument character sets.") +#define FUNC_NAME s_scm_char_set_union +{ + int c = 1; + SCM res; + long * p; + + SCM_VALIDATE_REST_ARGUMENT (rest); + + res = make_char_set (FUNC_NAME); + p = (long *) SCM_SMOB_DATA (res); + while (!SCM_NULLP (rest)) + { + int k; + SCM cs = SCM_CAR (rest); + SCM_VALIDATE_SMOB (c, cs, charset); + c++; + rest = SCM_CDR (rest); + + for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + p[k] |= ((long *) SCM_SMOB_DATA (cs))[k]; + } + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_intersection, "char-set-intersection", 1, 0, 1, + (SCM cs1, SCM rest), + "Return the intersection of all argument character sets.") +#define FUNC_NAME s_scm_char_set_intersection +{ + int c = 2; + SCM res; + long * p; + + SCM_VALIDATE_SMOB (1, cs1, charset); + SCM_VALIDATE_REST_ARGUMENT (rest); + + res = scm_char_set_copy (cs1); + p = (long *) SCM_SMOB_DATA (res); + while (!SCM_NULLP (rest)) + { + int k; + SCM cs = SCM_CAR (rest); + SCM_VALIDATE_SMOB (c, cs, charset); + c++; + rest = SCM_CDR (rest); + + for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + p[k] &= ((long *) SCM_SMOB_DATA (cs))[k]; + } + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_difference, "char-set-difference", 1, 0, 1, + (SCM cs1, SCM rest), + "Return the difference of all argument character sets.") +#define FUNC_NAME s_scm_char_set_difference +{ + int c = 2; + SCM res; + long * p; + + SCM_VALIDATE_SMOB (1, cs1, charset); + SCM_VALIDATE_REST_ARGUMENT (rest); + + res = scm_char_set_copy (cs1); + p = (long *) SCM_SMOB_DATA (res); + while (!SCM_NULLP (rest)) + { + int k; + SCM cs = SCM_CAR (rest); + SCM_VALIDATE_SMOB (c, cs, charset); + c++; + rest = SCM_CDR (rest); + + for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k]; + } + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_xor, "char-set-xor", 1, 0, 1, + (SCM cs1, SCM rest), + "Return the exclusive--or of all argument character sets.") +#define FUNC_NAME s_scm_char_set_xor +{ + int c = 2; + SCM res; + long * p; + + SCM_VALIDATE_SMOB (1, cs1, charset); + SCM_VALIDATE_REST_ARGUMENT (rest); + + res = scm_char_set_copy (cs1); + p = (long *) SCM_SMOB_DATA (res); + while (!SCM_NULLP (rest)) + { + int k; + SCM cs = SCM_CAR (rest); + SCM_VALIDATE_SMOB (c, cs, charset); + c++; + rest = SCM_CDR (rest); + + for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + p[k] ^= ((long *) SCM_SMOB_DATA (cs))[k]; + } + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_diff_plus_intersection, "char-set-diff+intersection", 1, 0, 1, + (SCM cs1, SCM rest), + "Return the difference and the intersection of all argument\n" + "character sets.") +#define FUNC_NAME s_scm_char_set_diff_plus_intersection +{ + int c = 2; + SCM res1, res2; + long * p, * q; + + SCM_VALIDATE_SMOB (1, cs1, charset); + SCM_VALIDATE_REST_ARGUMENT (rest); + + res1 = scm_char_set_copy (cs1); + res2 = scm_char_set_copy (cs1); + p = (long *) SCM_SMOB_DATA (res1); + q = (long *) SCM_SMOB_DATA (res2); + while (!SCM_NULLP (rest)) + { + int k; + SCM cs = SCM_CAR (rest); + SCM_VALIDATE_SMOB (c, cs, charset); + c++; + rest = SCM_CDR (rest); + + for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + { + p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k]; + q[k] &= ((long *) SCM_SMOB_DATA (cs))[k]; + } + } + return scm_values (SCM_LIST2 (res1, res2)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_complement_x, "char-set-complement!", 1, 0, 0, + (SCM cs), + "Return the complement of the character set @var{cs}.") +#define FUNC_NAME s_scm_char_set_complement_x +{ + int k; + long * p; + + SCM_VALIDATE_SMOB (1, cs, charset); + p = (long *) SCM_SMOB_DATA (cs); + for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + p[k] = ~p[k]; + return cs; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_union_x, "char-set-union!", 1, 0, 1, + (SCM cs1, SCM rest), + "Return the union of all argument character sets.") +#define FUNC_NAME s_scm_char_set_union_x +{ + int c = 2; + long * p; + + SCM_VALIDATE_SMOB (1, cs1, charset); + SCM_VALIDATE_REST_ARGUMENT (rest); + + p = (long *) SCM_SMOB_DATA (cs1); + while (!SCM_NULLP (rest)) + { + int k; + SCM cs = SCM_CAR (rest); + SCM_VALIDATE_SMOB (c, cs, charset); + c++; + rest = SCM_CDR (rest); + + for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + p[k] |= ((long *) SCM_SMOB_DATA (cs))[k]; + } + return cs1; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_intersection_x, "char-set-intersection!", 1, 0, 1, + (SCM cs1, SCM rest), + "Return the intersection of all argument character sets.") +#define FUNC_NAME s_scm_char_set_intersection_x +{ + int c = 2; + long * p; + + SCM_VALIDATE_SMOB (1, cs1, charset); + SCM_VALIDATE_REST_ARGUMENT (rest); + + p = (long *) SCM_SMOB_DATA (cs1); + while (!SCM_NULLP (rest)) + { + int k; + SCM cs = SCM_CAR (rest); + SCM_VALIDATE_SMOB (c, cs, charset); + c++; + rest = SCM_CDR (rest); + + for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + p[k] &= ((long *) SCM_SMOB_DATA (cs))[k]; + } + return cs1; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_difference_x, "char-set-difference!", 1, 0, 1, + (SCM cs1, SCM rest), + "Return the difference of all argument character sets.") +#define FUNC_NAME s_scm_char_set_difference_x +{ + int c = 2; + long * p; + + SCM_VALIDATE_SMOB (1, cs1, charset); + SCM_VALIDATE_REST_ARGUMENT (rest); + + p = (long *) SCM_SMOB_DATA (cs1); + while (!SCM_NULLP (rest)) + { + int k; + SCM cs = SCM_CAR (rest); + SCM_VALIDATE_SMOB (c, cs, charset); + c++; + rest = SCM_CDR (rest); + + for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k]; + } + return cs1; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_xor_x, "char-set-xor!", 1, 0, 1, + (SCM cs1, SCM rest), + "Return the exclusive--or of all argument character sets.") +#define FUNC_NAME s_scm_char_set_xor_x +{ + int c = 2; + long * p; + + SCM_VALIDATE_SMOB (1, cs1, charset); + SCM_VALIDATE_REST_ARGUMENT (rest); + + p = (long *) SCM_SMOB_DATA (cs1); + while (!SCM_NULLP (rest)) + { + int k; + SCM cs = SCM_CAR (rest); + SCM_VALIDATE_SMOB (c, cs, charset); + c++; + rest = SCM_CDR (rest); + + for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + p[k] ^= ((long *) SCM_SMOB_DATA (cs))[k]; + } + return cs1; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_diff_plus_intersection_x, "char-set-diff+intersection!", 1, 0, 1, + (SCM cs1, SCM rest), + "Return the difference and the intersection of all argument character sets.") +#define FUNC_NAME s_scm_char_set_diff_plus_intersection_x +{ + int c = 2; + SCM res2; + long * p, * q; + + SCM_VALIDATE_SMOB (1, cs1, charset); + SCM_VALIDATE_REST_ARGUMENT (rest); + + res2 = scm_char_set_copy (cs1); + p = (long *) SCM_SMOB_DATA (cs1); + q = (long *) SCM_SMOB_DATA (res2); + while (!SCM_NULLP (rest)) + { + int k; + SCM cs = SCM_CAR (rest); + SCM_VALIDATE_SMOB (c, cs, charset); + c++; + rest = SCM_CDR (rest); + + for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + { + p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k]; + q[k] &= ((long *) SCM_SMOB_DATA (cs))[k]; + } + } + return scm_values (SCM_LIST2 (cs1, res2)); +} +#undef FUNC_NAME + + +void +scm_init_srfi_14 () +{ + scm_tc16_charset = scm_make_smob_type ("character-set", + SCM_CHARSET_SIZE * sizeof (long)); + scm_set_smob_free (scm_tc16_charset, charset_free); + scm_set_smob_print (scm_tc16_charset, charset_print); + +#ifndef SCM_MAGIC_SNARFER +#include "srfi-14.x" +#endif +} diff --git a/srfi/srfi-14.h b/srfi/srfi-14.h new file mode 100644 index 000000000..623d1f9ab --- /dev/null +++ b/srfi/srfi-14.h @@ -0,0 +1,61 @@ +#ifndef SCM_SRFI_14_H +#define SCM_SRFI_14_H +/* srfi-14.c --- SRFI-14 procedures for Guile + * + * Copyright (C) 2001 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives + * permission for additional uses of the text contained in its release + * of GUILE. + * + * The exception is that, if you link the GUILE library with other + * files to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public + * License. Your use of that executable is in no way restricted on + * account of linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public + * License. + * + * This exception applies only to the code released by the Free + * Software Foundation under the name GUILE. If you copy code from + * other Free Software Foundation releases into a copy of GUILE, as + * the General Public License permits, the exception does not apply to + * the code that you add in this way. To avoid misleading anyone as + * to the status of such modified files, you must delete this + * exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + + +#define SCM_CHARSET_SIZE 256 + +#define SCM_CHARSET_GET(cs, idx) (((long *) SCM_SMOB_DATA (cs))\ + [(idx) / sizeof (long)] & (1 << ((idx) % sizeof (long)))) + +#define SCM_CHARSETP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_charset)) + +/* Smob type code for character sets. */ +extern int scm_tc16_charset; + +void scm_init_srfi_14 (void); + +#endif /* SCM_SRFI_14_H */ diff --git a/srfi/srfi-14.scm b/srfi/srfi-14.scm new file mode 100644 index 000000000..117e27818 --- /dev/null +++ b/srfi/srfi-14.scm @@ -0,0 +1,142 @@ +;;;; srfi-14.scm --- SRFI-14 procedures for Guile +;;;; +;;;; Copyright (C) 2001 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +(define-module (srfi srfi-14)) + +(export +;;; General procedures + char-set? + char-set= + char-set<= + char-set-hash + +;;; Iterating over character sets + char-set-cursor + char-set-ref + char-set-cursor-next + end-of-char-set? + char-set-fold + char-set-unfold char-set-unfold! + char-set-for-each + char-set-map + +;;; Creating character sets + char-set-copy + char-set + list->char-set list->char-set! + string->char-set string-char-set! + char-set-filter char-set-filter! + ucs-range->char-set ucs-range->char-set! + ->char-set + +;;; Querying character sets + char-set-size + char-set-count + char-set->list + char-set->string + char-set-contains? + char-set-every + char-set-any + +;;; Character set algebra + char-set-adjoin char-set-adjoin! + char-set-delete char-set-delete! + char-set-complement + char-set-union + char-set-intersection + char-set-difference + char-set-xor + char-set-diff+intersection + char-set-complement! + char-set-union! + char-set-intersection! + char-set-difference! + char-set-xor! + char-set-diff+intersection! + +;;; Standard character sets + char-set:lower-case + char-set:upper-case + char-set:title-case + char-set:letter + char-set:digit + char-set:letter+digit + char-set:graphic + char-set:printing + char-set:whitespace + char-set:iso-control + char-set:punctuation + char-set:symbol + char-set:hex-digit + char-set:blank + char-set:ascii + char-set:empty + char-set:full + ) + +(dynamic-call "scm_init_srfi_13_14" (dynamic-link "libguile-srfi-srfi-13-14")) + +(define (->char-set x) + (cond + ((string? x) (string->char-set x)) + ((char? x) (char-set x)) + ((char-set? x) x) + (else (error "invalid argument to `->char-set'")))) + +(define char-set:full (ucs-range->char-set 0 256)) + +(define char-set:lower-case (char-set-filter char-lower-case? char-set:full)) + +(define char-set:upper-case (char-set-filter char-upper-case? char-set:full)) + +(define char-set:title-case (char-set)) + +(define char-set:letter (char-set-union char-set:lower-case + char-set:upper-case)) + +(define char-set:digit (string->char-set "0123456789")) + +(define char-set:letter+digit + (char-set-union char-set:letter char-set:digit)) + +(define char-set:punctuation (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}")) + +(define char-set:symbol (string->char-set "$+<=>^`|~")) + +(define char-set:whitespace (char-set #\space #\newline #\tab #\cr #\vt #\np)) + +(define char-set:blank (char-set #\space #\tab)) + +(define char-set:graphic + (char-set-union char-set:letter+digit char-set:punctuation char-set:symbol)) + +(define char-set:printing + (char-set-union char-set:graphic char-set:whitespace)) + +(define char-set:iso-control + (char-set-adjoin + (char-set-filter (lambda (ch) (< (char->integer ch) 31)) char-set:full) + (integer->char 127))) + +(define char-set:hex-digit (string->char-set "0123456789abcdefABCDEF")) + +(define char-set:ascii + (char-set-filter (lambda (ch) (< (char->integer ch) 128)) char-set:full)) + +(define char-set:empty (char-set)) From 6c44688a67b617a8d511beebb74609563109e296 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 23 Apr 2001 20:24:02 +0000 Subject: [PATCH 0860/2047] * Makefile.am (SUBDIRS): Added `srfi'. * configure.in: Added subdirectory `srfi' to build process. * libguile.h: Added inclusion of `values.h'. --- ChangeLog | 8 ++++++++ Makefile.am | 2 +- configure.in | 1 + emacs/ChangeLog | 5 +++++ emacs/guile-c.el | 1 + libguile.h | 1 + 6 files changed, 17 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index ade7ea588..d2da6e626 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2001-04-23 Martin Grabmueller + + * Makefile.am (SUBDIRS): Added `srfi'. + + * configure.in: Added subdirectory `srfi' to build process. + + * libguile.h: Added inclusion of `values.h'. + 2001-04-22 Gary Houston * configure.in: check for inet_pton and inet_ntop. diff --git a/Makefile.am b/Makefile.am index 76b1af194..8b3a17f3a 100644 --- a/Makefile.am +++ b/Makefile.am @@ -19,7 +19,7 @@ ## to the Free Software Foundation, Inc., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA -SUBDIRS = ice-9 oop qt libltdl libguile guile-config guile-readline doc +SUBDIRS = ice-9 oop qt libltdl libguile guile-config guile-readline srfi doc include_HEADERS = libguile.h diff --git a/configure.in b/configure.in index 6d7b617c2..93b8a6332 100644 --- a/configure.in +++ b/configure.in @@ -33,6 +33,7 @@ AM_CONFIG_HEADER(libguile/scmconfig.h) #-------------------------------------------------------------------- AC_CONFIG_SUBDIRS(guile-readline) +AC_CONFIG_SUBDIRS(srfi) #-------------------------------------------------------------------- # diff --git a/emacs/ChangeLog b/emacs/ChangeLog index deb07922b..ef5058742 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,3 +1,8 @@ +2001-03-13 Martin Grabmueller + + * guile-c.el (guile-c-edit-docstring): Set fill-column to 63, so + that fill-paragraph'ed docstrings fit nicely when indented. + 2001-03-13 Keisuke Nishida * guile-c.el (guile-c-window-configuration): New variable. diff --git a/emacs/guile-c.el b/emacs/guile-c.el index ada1dedf5..7c6db51f7 100644 --- a/emacs/guile-c.el +++ b/emacs/guile-c.el @@ -126,6 +126,7 @@ (if global-font-lock-mode (font-lock-fontify-buffer)) (local-set-key "\C-c\C-c" 'guile-c-edit-finish) + (setq fill-column 63) (switch-to-buffer-other-window (current-buffer)) (message "Type `C-c C-c' to finish"))))) diff --git a/libguile.h b/libguile.h index 1ab96bf41..0eaed6891 100644 --- a/libguile.h +++ b/libguile.h @@ -126,6 +126,7 @@ extern "C" { #include "libguile/throw.h" #include "libguile/unif.h" #include "libguile/validate.h" +#include "libguile/values.h" #include "libguile/variable.h" #include "libguile/vectors.h" #include "libguile/version.h" From fafb71de8c0429d5f460216bb556eeeada7b63e4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Tue, 24 Apr 2001 19:38:13 +0000 Subject: [PATCH 0861/2047] * guile-srfi.texi: Removed, because merged with the GRM. * guile-srfi.texi: The docs are now up to date with the implementation and have new introductory material. --- srfi/ChangeLog | 7 +++++++ srfi/guile-srfi.texi | 0 srfi/srfi-13.c | 4 ++-- srfi/srfi-13.scm | 2 +- 4 files changed, 10 insertions(+), 3 deletions(-) delete mode 100644 srfi/guile-srfi.texi diff --git a/srfi/ChangeLog b/srfi/ChangeLog index ea6016cf0..192fe3cef 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,10 @@ +2001-04-24 Martin Grabmueller + + * guile-srfi.texi: Removed, because merged with the GRM. + + * guile-srfi.texi: The docs are now up to date with the + implementation and have new introductory material. + 2001-04-23 Martin Grabmueller Integrated the guile-srfi package into the Guile distribution. diff --git a/srfi/guile-srfi.texi b/srfi/guile-srfi.texi deleted file mode 100644 index e69de29bb..000000000 diff --git a/srfi/srfi-13.c b/srfi/srfi-13.c index 692f683fe..584c8e889 100644 --- a/srfi/srfi-13.c +++ b/srfi/srfi-13.c @@ -56,8 +56,8 @@ SCM_DEFINE (scm_string_any, "string-any", 2, 2, 0, "Check if the predicate @var{pred} is true for any character in\n" "the string @var{s}, proceeding from left (index @var{start}) to\n" "right (index @var{end}). If @code{string-any} returns true,\n" - "the returned true value is the one produced by the application\n" - "of @var{pred}.") + "the returned true value is the one produced by the first\n" + "successful application of @var{pred}.") #define FUNC_NAME s_scm_string_any { char * cstr; diff --git a/srfi/srfi-13.scm b/srfi/srfi-13.scm index 9b28b65ee..c40933a97 100644 --- a/srfi/srfi-13.scm +++ b/srfi/srfi-13.scm @@ -57,7 +57,7 @@ string-ci= string-ci<> string-ci< string-ci> string-ci<= string-ci>= - string-hash string-hash-ci ; FIXME::martin: rewrite in C? + string-hash string-hash-ci ;;; Prefixes/Suffixes string-prefix-length From 612943c6c1ea6a1b84604e6503cee99da1d6351f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Tue, 24 Apr 2001 19:41:48 +0000 Subject: [PATCH 0862/2047] * Makefile.am (guile_TEXINFOS): Added srfi-13-14.texi. * srfi-13-14.texi: New file documenting SRFI-13/14. * guile.texi (Top): Added the SRFI-13/14 menu entry and @include. --- doc/ChangeLog | 8 + doc/Makefile.am | 2 +- doc/guile.texi | 4 +- doc/srfi-13-14.texi | 1091 +++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 1103 insertions(+), 2 deletions(-) create mode 100644 doc/srfi-13-14.texi diff --git a/doc/ChangeLog b/doc/ChangeLog index e3cb26f13..dbc517392 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,11 @@ +2001-04-24 Martin Grabmueller + + * Makefile.am (guile_TEXINFOS): Added srfi-13-14.texi. + + * srfi-13-14.texi: New file documenting SRFI-13/14. + + * guile.texi (Top): Added the SRFI-13/14 menu entry and @include. + 2001-04-22 Neil Jerram * posix.texi (Network Sockets and Communication): Automatic diff --git a/doc/Makefile.am b/doc/Makefile.am index d72418148..94375e3f0 100644 --- a/doc/Makefile.am +++ b/doc/Makefile.am @@ -32,7 +32,7 @@ guile_TEXINFOS = preface.texi intro.texi scheme-intro.texi \ scheme-reading.texi scheme-indices.texi slib.texi posix.texi \ expect.texi scsh.texi tcltk.texi scripts.texi gh.texi scm.texi \ appendices.texi indices.texi script-getopt.texi data-rep.texi \ - extend.texi + extend.texi srfi-13-14.texi goops_TEXINFOS = goops-tutorial.texi hierarchy.eps hierarchy.txt diff --git a/doc/guile.texi b/doc/guile.texi index 8feac9e85..cdb38be29 100644 --- a/doc/guile.texi +++ b/doc/guile.texi @@ -140,7 +140,7 @@ by the Free Software Foundation. @sp 10 @comment The title is printed in a large font. @title Guile Reference Manual -@subtitle $Id: guile.texi,v 1.4 2001-04-22 14:56:52 ossau Exp $ +@subtitle $Id: guile.texi,v 1.5 2001-04-24 19:41:48 mgrabmue Exp $ @subtitle For use with Guile @value{VERSION} @author Mark Galassi @author Cygnus Solution and Los Alamos National Laboratory @@ -241,6 +241,7 @@ Part III: Guile Modules * SLIB:: Using the SLIB Scheme library. * POSIX:: POSIX system calls and networking. +* SRFI-13/14:: String library and character set library. * Expect:: Controlling interactive programs with Guile. * The Scheme shell (scsh):: The SCSH compatibility module has been made an @@ -321,6 +322,7 @@ Indices @include slib.texi @include posix.texi +@include srfi-13-14.texi @include expect.texi @include scsh.texi @include tcltk.texi diff --git a/doc/srfi-13-14.texi b/doc/srfi-13-14.texi new file mode 100644 index 000000000..3daaf81f3 --- /dev/null +++ b/doc/srfi-13-14.texi @@ -0,0 +1,1091 @@ +@node SRFI-13/14 +@chapter SRFI-13 and SRFI-14 + +This chapter documents the SRFI-13/14 library, which provides the string +utility procedures defined in SRFI-13 and the character-set procedures +defined in SRFI-14 for Guile. + +@menu +* Introduction:: What is this all about? +* Loading SRFI-13/14:: Loading the module into a running Guile. +* String Functions:: Available string processing procedures. +* Character-set Procedures:: Procedures for manipulating character sets. +@end menu + + +@c =================================================================== + +@node Introduction +@section Introduction + +The SRFI-13/14 library is a shared library which provides the procedures +defined in SRFI-13 (string library) and the procedures defined in +SRFI-14 (character-set library). You should also refer to the SRFI +documents, which provide some details I will not document here. + +If you don't know what SRFI means, and what all the numbers are about, +you may want to refer to the SRFI home page at +@url{http://srfi.schemers.org}. + +Note that only the procedures from SRFI-13 are documented here which are +not already contained in Guile. For procedures not documented here +please refer to the relevant chapters in the Guile Reference Manual, for +example the documentation of strings and string procedures (REFFIXME). + +The SRFI-14 procedures are documented completely. + +@menu +* What can be done:: What is possible with SRFI-13/14 +* What cannot be done:: and what is not? +@end menu + + +@c =================================================================== + +@node What can be done +@subsection What can be done + +All of the procedures defined in SRFI-13, which are not already included +in the Guile core library, are implemented in the module @code{(srfi +srfi-13)}. The procedures which are both in Guile and in SRFI-13, but +which are slightly extended, have been implemented in this module, and +the bindings overwrite those in the Guile core. + +All procedures from SRFI-14 (character-set library) are implemented in +the module @code{(srfi srfi-14)}, as well as the standard variables +@code{char-set:letter}, @code{char-set:digit} etc. + + +@c =================================================================== + +@node What cannot be done +@subsection What cannot be done + +The procedures which are defined in the section @emph{Low-level +procedures} of SRFI-13 for parsing optional string indices, substring +specification checking and Knuth-Morris-Pratt-Searching are not +implemented. + +The procedures @code{string-contains} and @code{string-contains-ci} are +not implemented very efficiently at the moment. This will be changed as +soon as possible. + + +@c =================================================================== + +@node Loading SRFI-13/14 +@section Loading SRFI-13/14 + +When Guile is properly installed, it can be loaded into a running Guile +by using the @code{(srfi srfi-13)} module. + +@example +$ guile +guile> (use-modules (srfi srfi-13)) +guile> +@end example + +When this step causes any errors, Guile is not properly installed. + +One possible reason is that Guile cannot find either the Scheme module +file @file{srfi-13.scm}, or it cannot find the shared object file +@file{libguile-srfi-srfi-13-14.so}. Make sure that the former is in the +Guile load path and that the latter is either installed in some default +location like @file{/usr/local/lib} or that the directory it was +installed to is in your @code{LTDL_LIBRARY_PATH}. The same applies to +@file{srfi-14.scm}. + +Now you can test whether the SRFI-13 procedures are working by calling +the @code{string-concatenate} procedure. + +@example +guile> (string-concatenate '("Hello" " " "World!")) +"Hello World!" +@end example + +The same goes for the SRFI-14 module, of course. + +@example +$ guile +guile> (use-modules (srfi srfi-14)) +guile> (char-set-union (char-set #\f #\o #\o) (string->char-set "bar")) +# +guile> +@end example + + +@c =================================================================== + +@node String Functions +@section String Functions + +In this section, we will describe all procedures defined in SRFI-13 +(string library) and implemented by the module @code{(srfi srfi-13)}. + +Except for the procedures in the section @emph{Low-level procedures} of +SRFI-13, all string procedures defined there are implemented completely. + +@menu +* Predicates:: Testing strings. +* SRFI-13 Constructors:: Constructing strings. +* SRFI-13 List/String Conversion:: Converstion from/to character lists. +* SRFI-13 Selection:: Selecting portions from strings. +* SRFI-13 Modification:: Modifying string in--place. +* SRFI-13 Comparison:: Comparing strings. +* Prefixes/Suffixes:: Checking for common pre-/suffixes. +* Searching:: Searching in strings. +* Case Mapping:: Changing the case of strings. +* Reverse/Append:: Append, concatenate and reverse strings. +* Fold/Unfold/Map:: Fold/Unfold/Map over strings. +* Replicate/Rotate:: String replication and rotation. +* Miscellaneous:: Miscellaneous string procedures. +* Filtering/Deleting:: Deleting characters from strings. +@end menu + + +@c =================================================================== + +@node Predicates +@subsection Predicates + +In addition to the primitives @code{string?} and @code{string-null?}, +which are already in the Guile core, the string predicates +@code{string-any} and @code{string-every} are defined by SRFI-13. + +@deffn primitive string-any pred s [start end] +Check if the predicate @var{pred} is true for any character in +the string @var{s}, proceeding from left (index @var{start}) to +right (index @var{end}). If @code{string-any} returns true, +the returned true value is the one produced by the first +successful application of @var{pred}. +@end deffn + +@deffn primitive string-every pred s [start end] +Check if the predicate @var{pred} is true for every character +in the string @var{s}, proceeding from left (index @var{start}) +to right (index @var{end}). If @code{string-every} returns +true, the returned true value is the one produced by the final +application of @var{pred} to the last character of @var{s}. +@end deffn + + +@c =================================================================== + +@node SRFI-13 Constructors +@subsection Constructors + +SRFI-13 defines several procedures for constructing new strings. In +addition to @code{make-string} and @code{string} (available in the Guile +core library), the procedure @code{string-tabulate} does exist. + +@deffn primitive string-tabulate proc len +@var{proc} is an integer->char procedure. Construct a string +of size @var{len} by applying @var{proc} to each index to +produce the corresponding string element. The order in which +@var{proc} is applied to the indices is not specified. +@end deffn + + +@c =================================================================== + +@node SRFI-13 List/String Conversion +@subsection List/String Conversion + +The procedure @code{string->list} is extended by SRFI-13, that is why it +is included in @code{(srfi srfi-13)}. The other procedures are new. +The Guile core already contains the procedure @code{list->string} for +converting a list of characters into a string (REFFIXME). + +@deffn primitive string->list str [start end] +Convert the string @var{str} into a list of characters. +@end deffn + +@deffn primitive reverse-list->string chrs +An efficient implementation of @code{(compose string->list +reverse)}: + +@smalllisp +(reverse-list->string '(#\a #\B #\c)) @result{} "cBa" +@end smalllisp +@end deffn + +@deffn primitive string-join ls [delimiter grammar] +Append the string in the string list @var{ls}, using the string +@var{delim} as a delimiter between the elements of @var{ls}. +@var{grammar} is a symbol which specifies how the delimiter is +placed between the strings, and defaults to the symbol +@code{infix}. + +@table @code +@item infix +Insert the separator between list elements. An empty string +will produce an empty list. + +@item string-infix +Like @code{infix}, but will raise an error if given the empty +list. + +@item suffix +Insert the separator after every list element. + +@item prefix +Insert the separator before each list element. +@end table +@end deffn + + +@c =================================================================== + +@node SRFI-13 Selection +@subsection Selection + +These procedures are called @dfn{selectors}, because they access +information about the string or select pieces of a given string. + +Additional selector procedures are documented in the Strings section +(REFFIXME), like @code{string-length} or @code{string-ref}. + +@code{string-copy} is also available in core Guile, but this version +accepts additional start/end indices. + +@deffn primitive string-copy str [start end] +Return a freshly allocated copy of the string @var{str}. If +given, @var{start} and @var{end} delimit the portion of +@var{str} which is copied. +@end deffn + +@deffn primitive substring/shared str start [end] +Like @code{substring}, but the result may share memory with the +argument @var{str}. +@end deffn + +@deffn primitive string-copy! target tstart s [start end] +Copy the sequence of characters from index range [@var{start}, +@var{end}) in string @var{s} to string @var{target}, beginning +at index @var{tstart}. The characters are copied left-to-right +or right-to-left as needed -- the copy is guaranteed to work, +even if @var{target} and @var{s} are the same string. It is an +error if the copy operation runs off the end of the target +string. +@end deffn + +@deffn primitive string-take s n +@deffnx primitive string-take-right s n +Return the @var{n} first/last characters of @var{s}. +@end deffn + +@deffn primitive string-drop s n +@deffnx primitive string-drop-right s n +Return all but the first/last @var{n} characters of @var{s}. +@end deffn + +@deffn primitive string-pad s len [chr start end] +@deffnx primitive string-pad-right s len [chr start end] +Take that characters from @var{start} to @var{end} from the +string @var{s} and return a new string, right(left)-padded by the +character @var{chr} to length @var{len}. If the resulting +string is longer than @var{len}, it is truncated on the right (left). +@end deffn + +@deffn primitive string-trim s [char_pred start end] +@deffnx primitive string-trim-right s [char_pred start end] +@deffnx primitive string-trim-both s [char_pred start end] +Trim @var{s} by skipping over all characters on the left/right/both +sides of the string that satisfy the parameter @var{char_pred}: + +@itemize @bullet +@item +if it is the character @var{ch}, characters equal to +@var{ch} are trimmed, + +@item +if it is a procedure @var{pred} characters that +satisfy @var{pred} are trimmed, + +@item +if it is a character set, characters in that set are trimmed. +@end itemize + +If called without a @var{char_pred} argument, all whitespace is +trimmed. +@end deffn + + +@c =================================================================== + +@node SRFI-13 Modification +@subsection Modification + +The procedure @code{string-fill!} is extended from R5RS because it +accepts optional start/end indices. This bindings shadows the procedure +of the same name in the Guile core. The second modification procedure +@code{string-set!} is documented in the Strings section (REFFIXME). + +@deffn primitive string-fill! str chr [start end] +Stores @var{chr} in every element of the given @var{str} and +returns an unspecified value. +@end deffn + + +@c =================================================================== + +@node SRFI-13 Comparison +@subsection Comparison + +The procedures in this section are used for comparing strings in +different ways. The comparison predicates differ from those in R5RS in +that they do not only return @code{#t} or @code{#f}, but the mismatch +index in the case of a true return value. + +@code{string-hash} and @code{string-hash-ci} are for calculating hash +values for strings, useful for implementing fast lookup mechanisms. + +@deffn primitive string-compare s1 s2 proc_lt proc_eq proc_gt [start1 end1 start2 end2] +@deffnx primitive string-compare-ci s1 s2 proc_lt proc_eq proc_gt [start1 end1 start2 end2] +Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the +mismatch index, depending upon whether @var{s1} is less than, +equal to, or greater than @var{s2}. The mismatch index is the +largest index @var{i} such that for every 0 <= @var{j} < +@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is, +@var{i} is the first position that does not match. The +character comparison is done case-insensitively. +@end deffn + +@deffn primitive string= s1 s2 [start1 end1 start2 end2] +@deffnx primitive string<> s1 s2 [start1 end1 start2 end2] +@deffnx primitive string< s1 s2 [start1 end1 start2 end2] +@deffnx primitive string> s1 s2 [start1 end1 start2 end2] +@deffnx primitive string<= s1 s2 [start1 end1 start2 end2] +@deffnx primitive string>= s1 s2 [start1 end1 start2 end2] +Compare @var{s1} and @var{s2} and return @code{#f} if the predicate +fails. Otherwise, the mismatch index is returned (or @var{end1} in the +case of @code{string=}. +@end deffn + +@deffn primitive string-ci= s1 s2 [start1 end1 start2 end2] +@deffnx primitive string-ci<> s1 s2 [start1 end1 start2 end2] +@deffnx primitive string-ci< s1 s2 [start1 end1 start2 end2] +@deffnx primitive string-ci> s1 s2 [start1 end1 start2 end2] +@deffnx primitive string-ci<= s1 s2 [start1 end1 start2 end2] +@deffnx primitive string-ci>= s1 s2 [start1 end1 start2 end2] +Compare @var{s1} and @var{s2} and return @code{#f} if the predicate +fails. Otherwise, the mismatch index is returned (or @var{end1} in the +case of @code{string=}. These are the case-insensitive variants. +@end deffn + +@deffn primitive string-hash s [bound start end] +@deffnx primitive string-hash-ci s [bound start end] +Return a hash value of the string @var{s} in the range 0 @dots{} +@var{bound} - 1. @code{string-hash-ci} is the case-insensitive variant. +@end deffn + + +@c =================================================================== + +@node Prefixes/Suffixes +@subsection Prefixes/Suffixes + +Using these procedures you can determine whether a given string is a +prefix or suffix of another string or how long a common prefix/suffix +is. + +@deffn primitive string-prefix-length s1 s2 [start1 end1 start2 end2] +@deffnx primitive string-prefix-length-ci s1 s2 [start1 end1 start2 end2] +@deffnx primitive string-suffix-length s1 s2 [start1 end1 start2 end2] +@deffnx primitive string-suffix-length-ci s1 s2 [start1 end1 start2 end2] +Return the length of the longest common prefix/suffix of the two +strings. @code{string-prefix-length-ci} and +@code{string-suffix-length-ci} are the case-insensitive variants. +@end deffn + +@deffn primitive string-prefix? s1 s2 [start1 end1 start2 end2] +@deffnx primitive string-prefix-ci? s1 s2 [start1 end1 start2 end2] +@deffnx primitive string-suffix? s1 s2 [start1 end1 start2 end2] +@deffnx primitive string-suffix-ci? s1 s2 [start1 end1 start2 end2] +Is @var{s1} a prefix/suffix of @var{s2}. @code{string-prefix-ci?} and +@code{string-suffix-ci?} are the case-insensitive variants. +@end deffn + + +@c =================================================================== + +@node Searching +@subsection Searching + +Use these procedures to find out whether a string contains a given +character or a given substring, or a character from a set of characters. + +@deffn primitive string-index s char_pred [start end] +@deffnx primitive string-index-right s char_pred [start end] +Search through the string @var{s} from left to right (right to left), +returning the index of the first (last) occurence of a character which + +@itemize +@item +equals @var{char_pred}, if it is character, + +@item +satisifies the predicate @var{char_pred}, if it is a +procedure, + +@item +is in the set @var{char_pred}, if it is a character set. +@end itemize +@end deffn + +@deffn primitive string-skip s char_pred [start end] +@deffnx primitive string-skip-right s char_pred [start end] +Search through the string @var{s} from left to right (right to left), +returning the index of the first (last) occurence of a character which + +@itemize +@item +does not equal @var{char_pred}, if it is character, + +@item +does not satisify the predicate @var{char_pred}, if it is +a procedure. + +@item +is not in the set if @var{char_pred} is a character set. +@end itemize +@end deffn + +@deffn primitive string-count s char_pred [start end] +Return the count of the number of characters in the string +@var{s} which + +@itemize @bullet +@item +equals @var{char_pred}, if it is character, + +@item +satisifies the predicate @var{char_pred}, if it is a procedure. + +@item +is in the set @var{char_pred}, if it is a character set. +@end itemize +@end deffn + +@deffn primitive string-contains s1 s2 [start1 end1 start2 end2] +@deffnx primitive string-contains-ci s1 s2 [start1 end1 start2 end2] +Does string @var{s1} contain string @var{s2}? Return the index +in @var{s1} where @var{s2} occurs as a substring, or false. +The optional start/end indices restrict the operation to the +indicated substrings. + +@code{string-contains-ci} is the case-insensitive variant. +@end deffn + + +@c =================================================================== + +@node Case Mapping +@subsection Alphabetic Case Mapping + +These procedures convert the alphabetic case of strings. They are +similar to the procedures in the Guile core, but are extended to handle +optional start/end indices. + +@deffn primitive string-upcase s [start end] +@deffnx primitive string-upcase! s [start end] +Upcase every character in @var{s}. @code{string-upcase!} is the +side-effecting variant. +@end deffn + +@deffn primitive string-downcase s [start end] +@deffnx primitive string-downcase! s [start end] +Downcase every character in @var{s}. @code{string-downcase!} is the +side--effecting variant. +@end deffn + +@deffn primitive string-titlecase s [start end] +@deffnx primitive string-titlecase! s [start end] +Upcase every first character in every word in @var{s}, downcase the +other characters. @code{string-titlecase!} is the side--effecting +variant. +@end deffn + + +@c =================================================================== + +@node Reverse/Append +@subsection Reverse/Append + +One appending procedure, @code{string-append} is the same in R5RS and in +SRFI-13, so it is not redefined. + +@deffn primitive string-reverse str [start end] +@deffnx primitive string-reverse! str [start end] +Reverse the string @var{str}. The optional arguments +@var{start} and @var{end} delimit the region of @var{str} to +operate on. + +@code{string-reverse!} modifies the argument string and returns an +unspecified value. +@end deffn + +@deffn primitive string-append/shared ls @dots{} +Like @code{string-append}, but the result may share memory +with the argument strings. +@end deffn + +@deffn primitive string-concatenate ls +Append the elements of @var{ls} (which must be strings) +together into a single string. Guaranteed to return a freshly +allocated string. +@end deffn + +@deffn primitive string-concatenate/shared ls +Like @code{string-concatenate}, but the result may share memory +with the strings in the list @var{ls}. +@end deffn + +@deffn primitive reverse-string-concatenate ls final_string end +Without optional arguments, this procedure is equivalent to + +@smalllisp +(string-concatenate (reverse ls)) +@end smalllisp + +If the optional argument @var{final_string} is specified, it is +consed onto the beginning to @var{ls} before performing the +list-reverse and string-concatenate operations. + +Guaranteed to return a freshly allocated string. +@end deffn + +@deffn primitive reverse-string-concatenate/shared ls final_string end +Like @code{reverse-string-concatenate}, but the result may +share memory with the the strings in the @var{ls} arguments. +@end deffn + + +@c =================================================================== + +@node Fold/Unfold/Map +@subsection Fold/Unfold/Map + +@code{string-map}, @code{string-for-each} etc. are for iterating over +the characters a string is composed of. The fold and unfold procedures +are list iterators and constructors. + +@deffn primitive string-map proc s [start end] +@var{proc} is a char->char procedure, it is mapped over +@var{s}. The order in which the procedure is applied to the +string elements is not specified. +@end deffn + +@deffn primitive string-map! proc s [start end] +@var{proc} is a char->char procedure, it is mapped over +@var{s}. The order in which the procedure is applied to the +string elements is not specified. The string @var{s} is +modified in-place, the return value is not specified. +@end deffn + +@deffn primitive string-fold kons knil s [start end] +@deffnx primitive string-fold-right kons knil s [start end] +Fold @var{kons} over the characters of @var{s}, with @var{knil} as the +terminating element, from left to right (or right to left, for +@code{string-fold-right}). @var{kons} must expect two arguments: The +actual character and the last result of @var{kons}' application. +@end deffn + +@deffn primitive string-unfold p f g seed [base make_final] +@deffnx primitive string-unfold-right p f g seed [base make_final] +These are the fundamental string constructors. +@itemize +@item @var{g} is used to generate a series of @emph{seed} +values from the initial @var{seed}: @var{seed}, (@var{g} +@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), +@dots{} +@item @var{p} tells us when to stop -- when it returns true +when applied to one of these seed values. +@item @var{f} maps each seed value to the corresponding +character in the result string. These chars are assembled into the +string in a left-to-right (right-to-left) order. +@item @var{base} is the optional initial/leftmost (rightmost) + portion of the constructed string; it default to the empty string. +@item @var{make_final} is applied to the terminal seed +value (on which @var{p} returns true) to produce the final/rightmost +(leftmost) portion of the constructed string. It defaults to +@code{(lambda (x) "")}. +@end itemize +@end deffn + +@deffn primitive string-for-each proc s [start end] +@var{proc} is mapped over @var{s} in left-to-right order. The +return value is not specified. +@end deffn + + +@c =================================================================== + +@node Replicate/Rotate +@subsection Replicate/Rotate + +These procedures are special substring procedures, which can also be +used for replicating strings. They are a bit tricky to use, but +consider this code fragment, which replicates the input string +@code{"foo"} so often that the resulting string has a length of six. + +@lisp +(xsubstring "foo" 0 6) +@result{} +"foofoo" +@end lisp + +@deffn primitive xsubstring s from [to start end] +This is the @emph{extended substring} procedure that implements +replicated copying of a substring of some string. + +@var{s} is a string, @var{start} and @var{end} are optional +arguments that demarcate a substring of @var{s}, defaulting to +0 and the length of @var{s}. Replicate this substring up and +down index space, in both the positive and negative directions. +@code{xsubstring} returns the substring of this string +beginning at index @var{from}, and ending at @var{to}, which +defaults to @var{from} + (@var{end} - @var{start}). +@end deffn + +@deffn primitive string-xcopy! target tstart s sfrom [sto start end] +Exactly the same as @code{xsubstring}, but the extracted text +is written into the string @var{target} starting at index +@var{tstart}. The operation is not defined if @code{(eq? +@var{target} @var{s})} or these arguments share storage -- you +cannot copy a string on top of itself. +@end deffn + + +@c =================================================================== + +@node Miscellaneous +@subsection Miscellaneous + +@code{string-replace} is for replacing a portion of a string with +another string and @code{string-tokenize} splits a string into a list of +strings, breaking it up at a specified character. + +@deffn primitive string-replace s1 s2 [start1 end1 start2 end2] +Return the string @var{s1}, but with the characters +@var{start1} @dots{} @var{end1} replaced by the characters +@var{start2} @dots{} @var{end2} from @var{s2}. +@end deffn + +@deffn primitive string-tokenize s [token_char start end] +Split the string @var{s} into a list of substrings, where each +substring is a maximal non-empty contiguous sequence of +characters equal to the character @var{token_char}, or +whitespace, if @var{token_char} is not given. If +@var{token_char} is a character set, it is used for finding the +token borders. +@end deffn + + +@c =================================================================== + +@node Filtering/Deleting +@subsection Filtering/Deleting + +@dfn{Filtering} means to remove all characters from a string which do +not match a given criteria, @dfn{deleting} means the opposite. + +@deffn primitive string-filter s char_pred [start end] +Filter the string @var{s}, retaining only those characters that +satisfy the @var{char_pred} argument. If the argument is a +procedure, it is applied to each character as a predicate, if +it is a character, it is tested for equality and if it is a +character set, it is tested for membership. +@end deffn + +@deffn primitive string-delete s char_pred [start end] +Filter the string @var{s}, retaining only those characters that +do not satisfy the @var{char_pred} argument. If the argument +is a procedure, it is applied to each character as a predicate, +if it is a character, it is tested for equality and if it is a +character set, it is tested for membership. +@end deffn + + +@c =================================================================== + +@node Character-set Procedures +@section Character-set Procedures + +SRFI-14 defines the data type @dfn{character set}, and also defines a +lot of procedures for handling this character type, and a few standard +character sets like whitespace, alphabetic characters and others. + +@menu +* Character Set Data Type:: Description of the character set data type. +* Predicates/Comparison:: Testing character sets. +* Iterating Over Character Sets:: Iterating over the members of a set. +* Creating Character Sets:: Creating new character sets. +* Querying Character Sets:: Extracting information from character sets. +* Character-Set Algebra:: Set-algebra on character sets. +* Standard Character Sets:: Variables containg standard character sets. +@end menu + + +@c =================================================================== + +@node Character Set Data Type +@subsection Character Set Data Type + +The data type @dfn{charset} implements sets of characters (REFFIXME). +Because the internal representation of character sets is not visible to +the user, a lot of procedures for handling them are provided. + +Character sets can be created, extended, tested for the membership of a +characters and be compared to other character sets. + +The Guile implementation of character sets deals with 8-bit characters. +In the standard variables, only the ASCII part of the character range is +really used, so that for example @dfn{Umlaute} and other accented +characters are not considered to be letters. In the future, as Guile +may get support for international character sets, this will change, so +don't rely on these ``features''. + + +@c =================================================================== + +@node Predicates/Comparison +@subsection Predicates/Comparison + +Use these procedures for testing whether an object is a character set, +or whether several character sets are equal or subsets of each other. +@code{char-set-hash} can be used for calculating a hash value, maybe for +usage in fast lookup procedures. + +@deffn primitive char-set? obj +Return @code{#t} if @var{obj} is a character set, @code{#f} +otherwise. +@end deffn + +@deffn primitive char-set= cs1 @dots{} +Return @code{#t} if all given character sets are equal. +@end deffn + +@deffn primitive char-set<= cs1 @dots{} +Return @code{#t} if every character set @var{cs}i is a subset +of character set @var{cs}i+1. +@end deffn + +@deffn primitive char-set-hash cs [bound] +Compute a hash value for the character set @var{cs}. If +@var{bound} is given and not @code{#f}, it restricts the +returned value to the range 0 @dots{} @var{bound - 1}. +@end deffn + + +@c =================================================================== + +@node Iterating Over Character Sets +@subsection Iterating Over Character Sets + +Character set cursors are a means for iterating over the members of a +character sets. After creating a character set cursor with +@code{char-set-cursor}, a cursor can be dereferenced with +@code{char-set-ref}, advanced to the next member with +@code{char-set-cursor-next}. Whether a cursor has passed past the last +element of the set can be checked with @code{end-of-char-set?}. + +Additionally, mapping and (un-)folding procedures for character sets are +provided. + +@deffn primitive char-set-cursor cs +Return a cursor into the character set @var{cs}. +@end deffn + +@deffn primitive char-set-ref cs cursor +Return the character at the current cursor position +@var{cursor} in the character set @var{cs}. It is an error to +pass a cursor for which @code{end-of-char-set?} returns true. +@end deffn + +@deffn primitive char-set-cursor-next cs cursor +Advance the character set cursor @var{cursor} to the next +character in the character set @var{cs}. It is an error if the +cursor given satisfies @code{end-of-char-set?}. +@end deffn + +@deffn primitive end-of-char-set? cursor +Return @code{#t} if @var{cursor} has reached the end of a +character set, @code{#f} otherwise. +@end deffn + +@deffn primitive char-set-fold kons knil cs +Fold the procedure @var{kons} over the character set @var{cs}, +initializing it with @var{knil}. +@end deffn + +@deffn primitive char-set-unfold p f g seed [base_cs] +@deffnx primitive char-set-unfold! p f g seed base_cs +This is a fundamental constructor for character sets. +@itemize +@item @var{g} is used to generate a series of ``seed'' values +from the initial seed: @var{seed}, (@var{g} @var{seed}), +(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{} +@item @var{p} tells us when to stop -- when it returns true +when applied to one of the seed values. +@item @var{f} maps each seed value to a character. These +characters are added to the base character set @var{base_cs} to +form the result; @var{base_cs} defaults to the empty set. +@end itemize + +@code{char-set-unfold!} is the side-effecting variant. +@end deffn + +@deffn primitive char-set-for-each proc cs +Apply @var{proc} to every character in the character set +@var{cs}. The return value is not specified. +@end deffn + +@deffn primitive char-set-map proc cs +Map the procedure @var{proc} over every character in @var{cs}. +@var{proc} must be a character -> character procedure. +@end deffn + + +@c =================================================================== + +@node Creating Character Sets +@subsection Creating Character Sets + +New character sets are produced with these procedures. + +@deffn primitive char-set-copy cs +Return a newly allocated character set containing all +characters in @var{cs}. +@end deffn + +@deffn primitive char-set char1 @dots{} +Return a character set containing all given characters. +@end deffn + +@deffn primitive list->char-set char_list [base_cs] +@deffnx primitive list->char-set! char_list base_cs +Convert the character list @var{list} to a character set. If +the character set @var{base_cs} is given, the character in this +set are also included in the result. + +@code{list->char-set!} is the side-effecting variant. +@end deffn + +@deffn primitive string->char-set s [base_cs] +@deffnx primitive string->char-set! s base_cs +Convert the string @var{str} to a character set. If the +character set @var{base_cs} is given, the characters in this +set are also included in the result. + +@code{string->char-set!} is the side-effecting variant. +@end deffn + +@deffn primitive char-set-filter pred cs [base_cs] +@deffnx primitive char-set-filter! pred cs base_cs +Return a character set containing every character from @var{cs} +so that it satisfies @var{pred}. If provided, the characters +from @var{base_cs} are added to the result. + +@code{char-set-filter!} is the side-effecting variant. +@end deffn + +@deffn primitive ucs-range->char-set lower upper [error? base_cs] +@deffnx primitive uce-range->char-set! lower upper error? base_cs +Return a character set containing all characters whose +character codes lie in the half-open range +[@var{lower},@var{upper}). + +If @var{error} is a true value, an error is signalled if the +specified range contains characters which are not contained in +the implemented character range. If @var{error} is @code{#f}, +these characters are silently left out of the resultung +character set. + +The characters in @var{base_cs} are added to the result, if +given. + +@code{ucs-range->char-set!} is the side-effecting variant. +@end deffn + +@deffn procedure ->char-set x +Coerce @var{x} into a character set. @var{x} may be a string, a +character or a character set. +@end deffn + + +@c =================================================================== + +@node Querying Character Sets +@subsection Querying Character Sets + +Access the elements and other information of a character set with these +procedures. + +@deffn primitive char-set-size cs +Return the number of elements in character set @var{cs}. +@end deffn + +@deffn primitive char-set-count pred cs +Return the number of the elements int the character set +@var{cs} which satisfy the predicate @var{pred}. +@end deffn + +@deffn primitive char-set->list cs +Return a list containing the elements of the character set +@var{cs}. +@end deffn + +@deffn primitive char-set->string cs +Return a string containing the elements of the character set +@var{cs}. The order in which the characters are placed in the +string is not defined. +@end deffn + +@deffn primitive char-set-contains? cs char +Return @code{#t} iff the character @var{ch} is contained in the +character set @var{cs}. +@end deffn + +@deffn primitive char-set-every pred cs +Return a true value if every character in the character set +@var{cs} satisfies the predicate @var{pred}. +@end deffn + +@deffn primitive char-set-any pred cs +Return a true value if any character in the character set +@var{cs} satisfies the predicate @var{pred}. +@end deffn + + +@c =================================================================== + +@node Character-Set Algebra +@subsection Character-Set Algebra + +Character sets can be manipulated with the common set algebra operation, +such as union, complement, intersection etc. All of these procedures +provide side--effecting variants, which modify their character set +argument(s). + +@deffn primitive char-set-adjoin cs char1 @dots{} +@deffnx primitive char-set-adjoin! cs char1 @dots{} +Add all character arguments to the first argument, which must +be a character set. +@end deffn + +@deffn primitive char-set-delete cs char1 @dots{} +@deffnx primitive char-set-delete! cs char1 @dots{} +Delete all character arguments from the first argument, which +must be a character set. +@end deffn + +@deffn primitive char-set-complement cs +@deffnx primitive char-set-complement! cs +Return the complement of the character set @var{cs}. +@end deffn + +@deffn primitive char-set-union cs1 @dots{} +@deffnx primitive char-set-union! cs1 @dots{} +Return the union of all argument character sets. +@end deffn + +@deffn primitive char-set-intersection cs1 @dots{} +@deffnx primitive char-set-intersection! cs1 @dots{} +Return the intersection of all argument character sets. +@end deffn + +@deffn primitive char-set-difference cs1 @dots{} +@deffnx primitive char-set-difference! cs1 @dots{} +Return the difference of all argument character sets. +@end deffn + +@deffn primitive char-set-xor cs1 @dots{} +@deffnx primitive char-set-xor! cs1 @dots{} +Return the exclusive--or of all argument character sets. +@end deffn + +@deffn primitive char-set-diff+intersection cs1 @dots{} +@deffnx primitive char-set-diff+intersection! cs1 @dots{} +Return the difference and the intersection of all argument +character sets. +@end deffn + + +@c =================================================================== + +@node Standard Character Sets +@subsection Standard Character Sets + +In order to make the use of the character set data type and procedures +useful, several predefined character set variables exist. + +@defvar char-set:lower-case +All lower--case characters. +@end defvar + +@defvar char-set:upper-case +All upper--case characters. +@end defvar + +@defvar char-set:title-case +This is empty, because ASCII has no titlecase characters. +@end defvar + +@defvar char-set:letter +All letters, e.g. the union of @code{char-set:lower-case} and +@code{char-set:upper-case}. +@end defvar + +@defvar char-set:digit +All digits. +@end defvar + +@defvar char-set:letter+digit +The union of @code{char-set:letter} and @code{char-set:digit}. +@end defvar + +@defvar char-set:graphic +All characters which would put ink on the paper. +@end defvar + +@defvar char-set:printing +The union of @code{char-set:graphic} and @code{char-set:whitespace}. +@end defvar + +@defvar char-set:whitespace +All whitespace characters. +@end defvar + +@defvar char-set:blank +All horizontal whitespace characters, that is @code{#\space} and +@code{#\tab}. +@end defvar + +@defvar char-set:iso-control +The ISO control characters with the codes 0--31 and 127. +@end defvar + +@defvar char-set:punctuation +The characters @code{!"#%&'()*,-./:;?@@[\\]_@{@}} +@end defvar + +@defvar char-set:symbol +The characters @code{$+<=>^`|~}. +@end defvar + +@defvar char-set:hex-digit +The hexadecimal digits @code{0123456789abcdefABCDEF}. +@end defvar + +@defvar char-set:ascii +All ASCII characters. +@end defvar + +@defvar char-set:empty +The empty character set. +@end defvar + +@defvar char-set:full +This character set contains all possible characters. +@end defvar From b516a720b9e21c30af7be0dc0f608ebd5a4d5f23 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 24 Apr 2001 22:15:10 +0000 Subject: [PATCH 0863/2047] * Fix bug with multiple files including of version.texi. --- doc/ChangeLog | 8 ++++++++ doc/Makefile.am | 5 ++++- doc/guile-tut.texi | 2 +- 3 files changed, 13 insertions(+), 2 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index dbc517392..da006e011 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,11 @@ +2001-04-24 Neil Jerram + + * guile-tut.texi: Include version-tutorial.texi rather than + version.texi. + + * Makefile.am ($(srcdir)/version-tutorial.texi): New target, to + avoid having two files both include version.texi. + 2001-04-24 Martin Grabmueller * Makefile.am (guile_TEXINFOS): Added srfi-13-14.texi. diff --git a/doc/Makefile.am b/doc/Makefile.am index 94375e3f0..5acbb145c 100644 --- a/doc/Makefile.am +++ b/doc/Makefile.am @@ -67,6 +67,9 @@ dist-hook: # This rule overrides automake's rule for version.texi. It causes # version.texi to be created even in non-maintainer-mode. -# $(srcdir)/version.texi: stamp-vti @: + +# And the same for version-tutorial.texi. +$(srcdir)/version-tutorial.texi: stamp-vti1 + @: diff --git a/doc/guile-tut.texi b/doc/guile-tut.texi index 20c73e68a..f2489cdaa 100644 --- a/doc/guile-tut.texi +++ b/doc/guile-tut.texi @@ -3,7 +3,7 @@ @setfilename guile-tut.info @settitle Guile Tutorial -@include version.texi +@include version-tutorial.texi @dircategory The Algorithmic Language Scheme @direntry From 30f32820761c6a0552c055c9c69b54616b9390ea Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 24 Apr 2001 22:15:58 +0000 Subject: [PATCH 0864/2047] * Makefile.am: Fixed "srf-14.x" typo. --- srfi/ChangeLog | 4 ++++ srfi/Makefile.am | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 192fe3cef..5dca1a5cb 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,7 @@ +2001-04-24 Neil Jerram + + * Makefile.am: Fixed "srf-14.x" typo. + 2001-04-24 Martin Grabmueller * guile-srfi.texi: Removed, because merged with the GRM. diff --git a/srfi/Makefile.am b/srfi/Makefile.am index c9cd7144f..0c8f95040 100644 --- a/srfi/Makefile.am +++ b/srfi/Makefile.am @@ -34,7 +34,7 @@ INCLUDES = -I.. -I$(srcdir)/.. lib_LTLIBRARIES = libguile-srfi-srfi-13-14.la BUILT_SOURCES = srfi-13.x srfi-14.x -libguile_srfi_srfi_13_14_la_SOURCES = srfi-13.x srfi-13.c srf-14.x srfi-14.c +libguile_srfi_srfi_13_14_la_SOURCES = srfi-13.x srfi-13.c srfi-14.x srfi-14.c libguile_srfi_srfi_13_14_la_LDFLAGS = -version-info 0:0 -export-dynamic srfidir = $(datadir)/guile/$(VERSION)/srfi From 4cd2722652048079469732bfb1357cb747fce782 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Apr 2001 23:23:05 +0000 Subject: [PATCH 0865/2047] * guile.1: New file, from Robert Merkel and Rob Browning. * Makefile.am (man_MANS, EXTRADIST): Added, but still commented out: install and distirbute the manpage. It is not yet installed or distributed since we don't have the Robert's papers yet. --- doc/Makefile.am | 6 ++++ doc/guile.1 | 93 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 99 insertions(+) create mode 100644 doc/guile.1 diff --git a/doc/Makefile.am b/doc/Makefile.am index 5acbb145c..a22dff8bf 100644 --- a/doc/Makefile.am +++ b/doc/Makefile.am @@ -21,6 +21,9 @@ AUTOMAKE_OPTIONS = foreign +# pending the papers from Robert Merkel +# man_MANS = guile.1 + info_TEXINFOS = guile.texi r5rs.texi goops.texi guile-tut.texi guile_TEXINFOS = preface.texi intro.texi scheme-intro.texi \ @@ -73,3 +76,6 @@ $(srcdir)/version.texi: stamp-vti # And the same for version-tutorial.texi. $(srcdir)/version-tutorial.texi: stamp-vti1 @: + +# pending the papers from Robert Merkel +# EXTRA_DIST = guile.1 diff --git a/doc/guile.1 b/doc/guile.1 new file mode 100644 index 000000000..ddf3cde1c --- /dev/null +++ b/doc/guile.1 @@ -0,0 +1,93 @@ +.\" Written by Robert Merkel (rgmerk@mira.net) +.\" augmented by Rob Browning +.\" Process this file with +.\" groff -man -Tascii foo.1 +.\" +.TH GUILE 1 "January 2001" Version "1.4" +.SH NAME +guile \- a Scheme interpreter +.SH SYNOPSIS +.B guile [-q] [-ds] [--help] [--version] [--emacs] [--debug] +.B [-l FILE] [-e FUNCTION] [\] +.B [-c EXPR] [-s SCRIPT] [--] +.SH DESCRIPTION +Guile is an interpreter for the Scheme programming language. It +implements a superset of R4RS, providing the additional features +necessary for real-world use. It is extremely simple to embed guile +into a C program, calling C from Scheme and Scheme from C. Guile's +design makes it very suitable for use as an "extension" or "glue" +language, but it also works well as a stand-alone scheme development +environment. + +The +.B guile +executable itself provides a stand-alone interpreter for scheme +programs, for either interactive use or executing scripts. + +This manpage provides only brief instruction in invoking +.B guile +from the command line. Please consult the guile info documentation +(type +.B info guile +at a command prompt) for more information. There is also a tutorial +.B (info guile-tut) +available. + +.SH OPTIONS +.IP -l FILE +Load scheme source code from file. +.IP -e FUNCTION +After reading script, apply FUNCTION to command-line arguments +.IP -ds +do -s SCRIPT at this point (note that this argument must be used in +conjuction with -s) +.IP --help +Describe command line options and exit +.IP --debug +Start guile with debugging evaluator and backtraces enabled +(useful for debugging guile scripts) +.IP --version +Display guile version and exit. +.IP --emacs +Enable emacs protocol for use from within emacs (experimental) +.IP -- +Stop argument processing, start guile in interactive mode. +.IP -c EXPR +Stop argument processing, evaluate EXPR as a scheme expression. +.IP -s SCRIPT-FILE +Load Scheme source from SCRIPT-FILE and execute as a script. + +.SH ENVIRONMENT +.\".TP \w'MANROFFSEQ\ \ 'u +.TP +.B GUILE_LOAD_PATH +If +.RB $ GUILE_LOAD_PATH +is set, its value is used to agument the path to search for scheme +files when loading. It should be a colon separated list of +directories which will be prepended to the default %load-path. + +.SH FILES +.I ~/.guile +is a guile script that is executed before any other processing occurs. +For example, the following .guile activates guile's readline +interface: + +.RS 4 +(use-modules (ice-9 readline)) +.RS 0 +(activate-readline) + +.SH "SEE ALSO" +.B info guile, info guile-tut + +http://www.schemers.org provides a general introduction to the +Scheme language. + +.SH AUTHORS +Robert Merkel wrote this manpage. +Rob Browning has added to it. + +.B guile +is GNU software. Guile is originally based on Aubrey Jaffer's +SCM interpreter, and is the work of many individuals. From bcdab802c99253f9a81caef7b3c70014f1f58bde Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Apr 2001 23:27:13 +0000 Subject: [PATCH 0866/2047] * eval.h, eval.c (scm_system_transformer): Deprecated by moving it into the conditionally compiled sections. * eval.c (scm_primitive_eval_x, scm_primitive_eval): Use scm_current_module_transformer instead of scm_system_transformer. --- libguile/eval.c | 11 +++++------ libguile/eval.h | 2 +- 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index c8136e138..4dad2a678 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3909,8 +3909,6 @@ SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0, */ -SCM scm_system_transformer; - SCM scm_i_eval_x (SCM exp, SCM env) { @@ -3927,7 +3925,7 @@ SCM scm_primitive_eval_x (SCM exp) { SCM env; - SCM transformer = scm_fluid_ref (SCM_CDR (scm_system_transformer)); + SCM transformer = scm_current_module_transformer (); if (SCM_NIMP (transformer)) exp = scm_apply (transformer, exp, scm_listofnull); env = scm_top_level_env (scm_current_module_lookup_closure ()); @@ -3941,7 +3939,7 @@ SCM_DEFINE (scm_primitive_eval, "primitive-eval", 1, 0, 0, #define FUNC_NAME s_scm_primitive_eval { SCM env; - SCM transformer = scm_fluid_ref (SCM_CDR (scm_system_transformer)); + SCM transformer = scm_current_module_transformer (); if (SCM_NIMP (transformer)) exp = scm_apply (transformer, exp, scm_listofnull); env = scm_top_level_env (scm_current_module_lookup_closure ()); @@ -4027,6 +4025,7 @@ SCM_DEFINE (scm_eval, "eval", 2, 0, 0, */ SCM scm_top_level_lookup_closure_var; +SCM scm_system_transformer; /* Avoid using this functionality altogether (except for implementing * libguile, where you can use scm_i_eval or scm_i_eval_x). @@ -4084,8 +4083,6 @@ scm_init_eval () scm_set_smob_print (scm_tc16_promise, promise_print); scm_f_apply = scm_make_subr ("apply", scm_tc7_lsubr_2, scm_apply); - scm_system_transformer = scm_sysintern ("scm:eval-transformer", - scm_make_fluid ()); scm_lisp_nil = scm_sysintern ("nil", SCM_UNDEFINED); SCM_SETCDR (scm_lisp_nil, SCM_CAR (scm_lisp_nil)); @@ -4100,6 +4097,8 @@ scm_init_eval () #if SCM_DEBUG_DEPRECATED == 0 scm_top_level_lookup_closure_var = scm_sysintern ("*top-level-lookup-closure*", scm_make_fluid ()); + scm_system_transformer = + scm_sysintern ("scm:eval-transformer", scm_make_fluid ()); #endif #ifndef SCM_MAGIC_SNARFER diff --git a/libguile/eval.h b/libguile/eval.h index 60c5d737a..aee3a399d 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -137,9 +137,9 @@ extern SCM scm_eval_options_interface (SCM setting); #if SCM_DEBUG_DEPRECATED == 0 extern SCM scm_top_level_lookup_closure_var; +extern SCM scm_system_transformer; #endif -extern SCM scm_system_transformer; extern const char scm_s_expression[]; From 07de6c4737a003e7fac90c980029103aee09eebd Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Apr 2001 23:28:36 +0000 Subject: [PATCH 0867/2047] * gh_data.c: Removed FIXME comment about gh_lookup returning SCM_UNDEFINED. That's the right thing to do. --- libguile/gh_data.c | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/libguile/gh_data.c b/libguile/gh_data.c index e431208b3..86ad5a2c1 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -704,10 +704,8 @@ gh_uniform_vector_ref (SCM v, SCM ilist) `vec' argument. The return value is the Scheme object to which SNAME is bound, or - SCM_UNDEFINED if SNAME is not bound in the given context. [FIXME: - should this be SCM_UNSPECIFIED? Can a symbol ever legitimately be - bound to SCM_UNDEFINED or SCM_UNSPECIFIED? What is the difference? - -twp] */ + SCM_UNDEFINED if SNAME is not bound in the given context. + */ SCM gh_lookup (const char *sname) From f2c4aa2a16d7d78ff4a09c72978b74a2a1d2f78b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Apr 2001 23:31:38 +0000 Subject: [PATCH 0868/2047] * eval.h, eval.c (scm_system_transformer): Deprecated by moving it into the conditionally compiled sections. * eval.c (scm_primitive_eval_x, scm_primitive_eval): Use scm_current_module_transformer instead of scm_system_transformer. * init.c (start_stack): Move initialization of scm_system_transformer to the deprecated section. --- libguile/init.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/init.c b/libguile/init.c index f7b023ffb..75722a990 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -178,8 +178,8 @@ start_stack (void *base) #if SCM_DEBUG_DEPRECATED == 0 scm_top_level_lookup_closure_var = SCM_BOOL_F; -#endif scm_system_transformer = SCM_BOOL_F; +#endif scm_root->fluids = scm_make_initial_fluids (); From 55000e5f401fa0c06cac5046e4c388bcc64b8d58 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Apr 2001 23:40:18 +0000 Subject: [PATCH 0869/2047] * modules.c (scm_module_type): New. (scm_post_boot_init_modules): Initialize from Scheme value. (the_module, scm_current_module, scm_init_modules): the_module is now a C only fluid. (scm_current_module): Export to Scheme. (scm_set_current_module): Do not call out to Scheme, do all the work in C. Export procedure to Scheme. Only accept modules, `#f' is no longer valid as the current module. Only set scm_top_level_lookup_closure_var and scm_system_transformer when they are not deprecated. (scm_module_transformer, scm_current_module_transformer): New. * modules.h (scm_module_index_transformer, SCM_MODULE_TRANSFORMER, scm_current_module_transformer, scm_module_transformer): New. --- libguile/modules.c | 78 +++++++++++++++++++++++++++++++++++----------- libguile/modules.h | 5 +++ 2 files changed, 65 insertions(+), 18 deletions(-) diff --git a/libguile/modules.c b/libguile/modules.c index 4259b05f0..710adddc9 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -60,6 +60,7 @@ SCM scm_module_system_booted_p = 0; SCM scm_module_tag; +SCM scm_module_type; static SCM the_root_module; static SCM root_module_lookup_closure; @@ -72,26 +73,51 @@ scm_the_root_module () static SCM the_module; -SCM -scm_current_module () +SCM_DEFINE (scm_current_module, "current-module", 0, 0, 0, + (), + "Return the current module.") +#define FUNC_NAME s_scm_current_module { - return scm_fluid_ref (SCM_CDR (the_module)); + return scm_fluid_ref (the_module); } +#undef FUNC_NAME -static SCM set_current_module; +#define SCM_VALIDATE_STRUCT_TYPE(pos, v, type) \ + do { \ + SCM_ASSERT (SCM_NIMP (v) && SCM_NFALSEP (SCM_STRUCTP (v)) \ + && SCM_STRUCT_VTABLE (v) == (type), \ + v, pos, FUNC_NAME); \ + } while (0) -/* This is the module selected during loading of code. Currently, - * this is the same as (interaction-environment), but need not be in - * the future. - */ - -SCM -scm_set_current_module (SCM module) +SCM_DEFINE (scm_set_current_module, "set-current-module", 1, 0, 0, + (SCM module), + "Set the current module to @var{module} and return" + "the previous current module.") +#define FUNC_NAME s_scm_set_current_module { - SCM old = scm_current_module (); - scm_apply (SCM_CDR (set_current_module), SCM_LIST1 (module), SCM_EOL); + SCM old; + + /* XXX - we can not validate our argument when the module system + hasn't been booted yet since we don't know the type. This + should be fixed when we have a cleaner way of booting + Guile. + */ + if (scm_module_system_booted_p) + SCM_VALIDATE_STRUCT_TYPE (SCM_ARG1, module, scm_module_type); + + old = scm_current_module (); + scm_fluid_set_x (the_module, module); + +#if SCM_DEBUG_DEPRECATED == 0 + scm_fluid_set_x (SCM_CDR (scm_top_level_lookup_closure_var), + scm_current_module_lookup_closure ()); + scm_fluid_set_x (SCM_CDR (scm_system_transformer), + scm_current_module_transformer ()); +#endif + return old; } +#undef FUNC_NAME SCM_DEFINE (scm_interaction_environment, "interaction-environment", 0, 0, 0, (), @@ -153,6 +179,21 @@ scm_current_module_lookup_closure () return SCM_BOOL_F; } +SCM +scm_module_transformer (SCM module) +{ + return SCM_MODULE_TRANSFORMER (module); +} + +SCM +scm_current_module_transformer () +{ + if (scm_module_system_booted_p) + return scm_module_transformer (scm_current_module ()); + else + return SCM_BOOL_F; +} + static SCM resolve_module; SCM @@ -286,20 +327,21 @@ scm_init_modules () scm_tc16_eval_closure = scm_make_smob_type ("eval-closure", 0); scm_set_smob_mark (scm_tc16_eval_closure, scm_markcdr); scm_set_smob_apply (scm_tc16_eval_closure, scm_eval_closure_lookup, 2, 0, 0); + + the_module = scm_permanent_object (scm_make_fluid ()); } void scm_post_boot_init_modules () { - scm_module_tag = (SCM_CELL_WORD_1 (SCM_CDR (scm_intern0 ("module-type"))) - + scm_tc3_cons_gloc); - the_root_module = scm_intern0 ("the-root-module"); - the_module = scm_intern0 ("the-module"); - set_current_module = scm_intern0 ("set-current-module"); + scm_module_type = + scm_permanent_object (SCM_CDR (scm_intern0 ("module-type"))); + scm_module_tag = (SCM_CELL_WORD_1 (scm_module_type) + scm_tc3_cons_gloc); module_prefix = scm_permanent_object (SCM_LIST2 (scm_sym_app, scm_sym_modules)); make_modules_in = scm_intern0 ("make-modules-in"); beautify_user_module_x = scm_intern0 ("beautify-user-module!"); + the_root_module = scm_intern0 ("the-root-module"); root_module_lookup_closure = scm_permanent_object (scm_module_lookup_closure (SCM_CDR (the_root_module))); resolve_module = scm_intern0 ("resolve-module"); diff --git a/libguile/modules.h b/libguile/modules.h index 95906261f..da9913e04 100644 --- a/libguile/modules.h +++ b/libguile/modules.h @@ -63,6 +63,7 @@ #define scm_module_index_uses 1 #define scm_module_index_binder 2 #define scm_module_index_eval_closure 3 +#define scm_module_index_transformer 4 #define SCM_MODULE_OBARRAY(module) \ SCM_PACK (SCM_STRUCT_DATA (module) [scm_module_index_obarray]) @@ -72,6 +73,8 @@ SCM_PACK (SCM_STRUCT_DATA (module) [scm_module_index_binder]) #define SCM_MODULE_EVAL_CLOSURE(module) \ SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_eval_closure]) +#define SCM_MODULE_TRANSFORMER(module) \ + SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_transformer]) extern scm_bits_t scm_tc16_eval_closure; @@ -85,11 +88,13 @@ extern SCM scm_module_tag; extern SCM scm_the_root_module (void); extern SCM scm_current_module (void); extern SCM scm_current_module_lookup_closure (void); +extern SCM scm_current_module_transformer (void); extern SCM scm_interaction_environment (void); extern SCM scm_set_current_module (SCM module); extern SCM scm_make_module (SCM name); extern SCM scm_ensure_user_module (SCM name); extern SCM scm_module_lookup_closure (SCM module); +extern SCM scm_module_transformer (SCM module); extern SCM scm_resolve_module (SCM name); extern SCM scm_load_scheme_module (SCM name); extern SCM scm_env_top_level (SCM env); From 253081cf6a510cae5951ac546866dfb9522fcce1 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Apr 2001 23:51:05 +0000 Subject: [PATCH 0870/2047] *** empty log message *** --- doc/ChangeLog | 7 +++++++ libguile/ChangeLog | 27 +++++++++++++++++++++++++++ 2 files changed, 34 insertions(+) diff --git a/doc/ChangeLog b/doc/ChangeLog index da006e011..c38fac844 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,10 @@ +2001-04-25 Marius Vollmer + + * guile.1: New file, from Robert Merkel and Rob Browning. + * Makefile.am (man_MANS, EXTRADIST): Added, but still commented + out: install and distribute the manpage. It is not yet installed + or distributed since we don't have Robert's papers yet. + 2001-04-24 Neil Jerram * guile-tut.texi: Include version-tutorial.texi rather than diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d7708ceac..3f0afdd50 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,30 @@ +2001-04-25 Marius Vollmer + + * modules.c (scm_module_type): New. + (scm_post_boot_init_modules): Initialize from Scheme value. + (the_module, scm_current_module, scm_init_modules): the_module is + now a C only fluid. + (scm_current_module): Export to Scheme. + (scm_set_current_module): Do not call out to Scheme, do all the + work in C. Export procedure to Scheme. Only accept modules, `#f' + is no longer valid as the current module. Only set + scm_top_level_lookup_closure_var and scm_system_transformer when + they are not deprecated. + (scm_module_transformer, scm_current_module_transformer): New. + + * modules.h (scm_module_index_transformer, SCM_MODULE_TRANSFORMER, + scm_current_module_transformer, scm_module_transformer): New. + + * gh_data.c: Removed FIXME comment about gh_lookup returning + SCM_UNDEFINED. That's the right thing to do. + + * eval.h, eval.c (scm_system_transformer): Deprecated by moving it + into the conditionally compiled sections. + * eval.c (scm_primitive_eval_x, scm_primitive_eval): Use + scm_current_module_transformer instead of scm_system_transformer. + * init.c (start_stack): Move initialization of + scm_system_transformer to the deprecated section. + 2001-04-22 Neil Jerram * throw.c (scm_throw): Correct docstring. From 2d857fb1accfef2948063cf16ecde13f8b7fcd37 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 25 Apr 2001 12:15:24 +0000 Subject: [PATCH 0871/2047] New files for Guile Emacs support. --- emacs/ChangeLog | 4 + emacs/guile-emacs.scm | 127 ++++++++++++++++ emacs/guile-scheme.el | 334 ++++++++++++++++++++++++++++++++++++++++++ emacs/guile.el | 172 ++++++++++++++++++++++ ice-9/ChangeLog | 4 + ice-9/channel.scm | 100 +++++++++++++ 6 files changed, 741 insertions(+) create mode 100644 emacs/guile-emacs.scm create mode 100644 emacs/guile-scheme.el create mode 100644 emacs/guile.el create mode 100644 ice-9/channel.scm diff --git a/emacs/ChangeLog b/emacs/ChangeLog index ef5058742..025a0cd53 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,3 +1,7 @@ +2001-04-25 Keisuke Nishida + + * guile.el, guile-scheme.el, guile-emacs.scm: New files. + 2001-03-13 Martin Grabmueller * guile-c.el (guile-c-edit-docstring): Set fill-column to 63, so diff --git a/emacs/guile-emacs.scm b/emacs/guile-emacs.scm new file mode 100644 index 000000000..7bc0ee785 --- /dev/null +++ b/emacs/guile-emacs.scm @@ -0,0 +1,127 @@ +;;; guile-emacs.scm --- Guile Emacs interface + +;; Copyright (C) 2001 Keisuke Nishida + +;; GNU Emacs 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, or (at your option) +;; any later version. + +;; GNU Emacs 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(use-modules (ice-9 regex)) +(use-modules (ice-9 channel)) +(use-modules (ice-9 session)) +(use-modules (ice-9 documentation)) + + +;;; +;;; Emacs Lisp channel +;;; + +(define (emacs-lisp-channel) + + (define (native-type? x) + (or (integer? x) (symbol? x) (string? x) (pair? x) (vector? x))) + + (define (emacs-lisp-print ch val) + (cond + ((unspecified? val)) + ((eq? val #t) (channel-print-value ch 't)) + ((or (eq? val #f) (null? val)) (channel-print-value ch 'nil)) + ((native-type? val) (channel-print-value ch val)) + (else (channel-print-token ch val)))) + + (channel-open (make-object-channel emacs-lisp-print))) + + +;;; +;;; Scheme channel +;;; + +(define (emacs-scheme-channel) + (define (print ch val) (channel-print-value ch (object->string val))) + (channel-open (make-object-channel print))) + + +;;; +;;; for guile-import and guile-use-modules +;;; + +(define (guile-emacs-export-procedure proc) + (define (procedure-arity proc) + (assq-ref (procedure-properties proc) 'arity)) + + (define (procedure-args proc) + (let ((source (procedure-source proc))) + (if source + ;; formals -> emacs args + (let loop ((formals (cadr source))) + (cond + ((null? formals) '()) + ((symbol? formals) `(&rest ,formals)) + (else (cons (car formals) (loop (cdr formals)))))) + ;; arity -> emacs args + (let* ((arity (procedure-arity proc)) + (nreqs (car arity)) + (nopts (cadr arity)) + (restp (caddr arity))) + (define (nsyms n) + (if (= n 0) '() (cons (gensym "a") (nsyms (1- n))))) + (append! (nsyms nreqs) + (if (> nopts 0) (cons '&optional (nsyms nopts)) '()) + (if restp (cons '&rest (nsyms 1)) '())))))) + + (define (procedure-call name args) + (let ((restp (memq '&rest args)) + (args (delq '&rest (delq '&optional args)))) + (if restp + `(list* ',name ,@args) + `(list ',name ,@args)))) + + (let ((name (procedure-name proc)) + (args (procedure-args proc)) + (docs (object-documentation proc))) + `(defun ,name ,args + ,@(if docs (list docs) '()) + (guile-lisp-eval ,(procedure-call name args))))) + +(define (guile-emacs-export proc-name) + (guile-emacs-export-procedure (module-ref (current-module) proc-name))) + +(define (guile-emacs-export-procedures module-name) + (define (module-public-procedures name) + (hash-fold (lambda (s v d) + (let ((val (variable-ref v))) + (if (procedure? val) (cons val d) d))) + '() (module-obarray (resolve-interface name)))) + `(progn ,@(map guile-emacs-export-procedure + (module-public-procedures module-name)))) + + +;;; +;;; for guile-emacs-complete-symbol +;;; + +(define (guile-emacs-complete-alist str) + (sort! (apropos-fold (lambda (module name val data) + (cons (list (symbol->string name) + (cond ((procedure? val) "

") + ((macro? val) " ") + (else ""))) + data)) + '() (string-append "^" (regexp-quote str)) + apropos-fold-all) + (lambda (p1 p2) (string" + ;; Any whitespace and declared object. + "\\s *(?\\(\\sw+\\)?") + '(1 font-lock-keyword-face) + '(5 (cond ((match-beginning 3) font-lock-function-name-face) + ((match-beginning 4) font-lock-variable-name-face) + (t font-lock-type-face)) nil t)) + (list (concat + "(" (regexp-opt + (mapcar (lambda (e) + (prin1-to-string (if (consp e) (car e) e))) + (append guile-scheme-syntax-keywords + guile-scheme-special-procedures)) 'words)) + '(1 font-lock-keyword-face)) + '("<\\sw+>" . font-lock-type-face) + '("\\<:\\sw+\\>" . font-lock-builtin-face) + )) + "Expressions to highlight in Guile Scheme mode.") + + +;;; +;;; Guile Scheme mode +;;; + +(defvar guile-scheme-mode-map nil + "Keymap for Guile Scheme mode. +All commands in `lisp-mode-shared-map' are inherited by this map.") + +(unless guile-scheme-mode-map + (let ((map (make-sparse-keymap "Guile-Scheme"))) + (setq guile-scheme-mode-map map) + (set-keymap-parent map lisp-mode-shared-map) + (define-key map [menu-bar] (make-sparse-keymap)) + (define-key map [menu-bar guile-scheme] (cons "Guile-Scheme" map)) + (define-key map [uncomment-region] + '("Uncomment Out Region" . (lambda (beg end) + (interactive "r") + (comment-region beg end '(4))))) + (define-key map [comment-region] '("Comment Out Region" . comment-region)) + (define-key map [indent-region] '("Indent Region" . indent-region)) + (define-key map [indent-line] '("Indent Line" . lisp-indent-line)) + (define-key map "\e\C-i" 'guile-scheme-complete-symbol) + (define-key map "\e\C-x" 'guile-scheme-eval-define) + (define-key map "\C-x\C-e" 'guile-scheme-eval-last-sexp) + (define-key map "\C-c\C-b" 'guile-scheme-eval-buffer) + (define-key map "\C-c\C-r" 'guile-scheme-eval-region) + (define-key map "\C-c:" 'guile-scheme-eval-expression) + (define-key map "\C-c\C-a" 'guile-scheme-apropos) + (define-key map "\C-c\C-d" 'guile-scheme-describe) + + (put 'comment-region 'menu-enable 'mark-active) + (put 'uncomment-region 'menu-enable 'mark-active) + (put 'indent-region 'menu-enable 'mark-active))) + +(defcustom guile-scheme-mode-hook nil + "Normal hook run when entering `guile-scheme-mode'." + :type 'hook + :group 'guile-scheme) + +;;;###autoload +(defun guile-scheme-mode () + "Major mode for editing Guile Scheme code. +Editing commands are similar to those of `scheme-mode'. + +\\{scheme-mode-map} +Entry to this mode calls the value of `scheme-mode-hook' +if that value is non-nil." + (interactive) + (kill-all-local-variables) + (setq mode-name "Guile Scheme") + (setq major-mode 'guile-scheme-mode) + (use-local-map guile-scheme-mode-map) + (scheme-mode-variables) + (setq mode-line-process + '(:eval (if (processp guile-scheme-adapter) + (format " [%s]" guile-scheme-command) + ""))) + (setq font-lock-defaults + '((guile-scheme-font-lock-keywords) + nil t (("+-*/.<>=!?$%_&~^:@" . "w")) beginning-of-defun + (font-lock-mark-block-function . mark-defun))) + (run-hooks 'guile-scheme-mode-hook)) + + +;;; +;;; Scheme interaction mode +;;; + +(defvar scheme-interaction-mode-map () + "Keymap for Scheme Interaction mode. +All commands in `guile-scheme-mode-map' are inherited by this map.") + +(unless scheme-interaction-mode-map + (let ((map (make-sparse-keymap))) + (setq scheme-interaction-mode-map map) + (set-keymap-parent map guile-scheme-mode-map) + (define-key map "\C-j" 'guile-scheme-eval-print-last-sexp) + )) + +(defvar scheme-interaction-mode-hook nil + "Normal hook run when entering `scheme-interaction-mode'.") + +(defun scheme-interaction-mode () + "Major mode for evaluating Scheme expressions with Guile. + +\\{scheme-interaction-mode-map}" + (interactive) + (guile-scheme-mode) + (use-local-map scheme-interaction-mode-map) + (setq major-mode 'scheme-interaction-mode) + (setq mode-name "Scheme Interaction") + (run-hooks 'scheme-interaction-mode-hook)) + + +;;; +;;; Guile Scheme adapter +;;; + +(defvar guile-scheme-command "guile") +(defvar guile-scheme-adapter nil) + +(defun guile-scheme-adapter () + (if (and (processp guile-scheme-adapter) + (eq (process-status guile-scheme-adapter) 'run)) + guile-scheme-adapter + (setq guile-scheme-adapter + (guile:make-adapter guile-scheme-command 'emacs-scheme-channel)))) + +(defun guile-scheme-set-module () + "Set the current module based on buffer contents. +If there is a (define-module ...) form, evaluate it. +Otherwise, choose module (guile-user)." + (save-excursion + (guile:eval + (if (re-search-backward "^(define-module " nil t) + (let ((start (match-beginning 0))) + (goto-char start) + (forward-sexp) + (buffer-substring-no-properties start (point))) + "(define-module (emacs-user))") + (guile-scheme-adapter)))) + +(defun guile-scheme-eval-string (string) + (guile-scheme-set-module) + (guile:eval string (guile-scheme-adapter))) + +(defun guile-scheme-display-result (value flag) + (if (string= value "#") + (setq value "done")) + (if flag + (insert value) + (message "%s" value))) + + +;;; +;;; Interactive commands +;;; + +(defun guile-scheme-eval-expression (string) + "Evaluate the expression in STRING and show value in echo area." + (interactive "SGuile Scheme Eval: ") + (guile-scheme-display-result (guile-scheme-eval-string string) nil)) + +(defun guile-scheme-eval-region (start end) + "Evaluate the region as Guile Scheme code." + (interactive "r") + (guile-scheme-eval-expression (buffer-substring-no-properties start end))) + +(defun guile-scheme-eval-buffer () + "Evaluate the current buffer as Guile Scheme code." + (interactive) + (guile-scheme-eval-expression (buffer-string))) + +(defun guile-scheme-eval-last-sexp (arg) + "Evaluate sexp before point; show value in echo area. +With argument, print output into current buffer." + (interactive "P") + (guile-scheme-display-result + (guile-scheme-eval-string + (buffer-substring-no-properties + (point) (save-excursion (backward-sexp) (point)))) arg)) + +(defun guile-scheme-eval-print-last-sexp () + "Evaluate sexp before point; print value into current buffer." + (interactive) + (insert "\n") + (guile-scheme-eval-last-sexp t) + (insert "\n")) + +(defun guile-scheme-eval-define () + (interactive) + (guile-scheme-eval-region (save-excursion (end-of-defun) (point)) + (save-excursion (beginning-of-defun) (point)))) + +(defun guile-scheme-load-file (file) + "Load a Guile Scheme file." + (interactive "fGuile Scheme load file: ") + (guile-scheme-eval-string (format "(load %s)" (expand-file-name file))) + (message "done")) + +(defun guile-scheme-complete-symbol () + (interactive) + (unless (boundp 'guile-emacs-complete-alist) + (guile-import guile-emacs-complete-alist)) + (let* ((end (point)) + (start (save-excursion (skip-syntax-backward "w_") (point))) + (pattern (buffer-substring-no-properties start end)) + (alist (guile-emacs-complete-alist pattern))) + (goto-char end) + (let ((completion (try-completion pattern alist))) + (cond ((eq completion t)) + ((not completion) + (message "Can't find completion for \"%s\"" pattern) + (ding)) + ((not (string= pattern completion)) + (delete-region start end) + (insert completion)) + (t + (message "Making completion list...") + (with-output-to-temp-buffer "*Completions*" + (display-completion-list alist)) + (message "Making completion list...done")))))) + +;; (define-command (guile-scheme-apropos regexp) +;; (interactive "sGuile-Scheme apropos (regexp): ") +;; (guile-scheme-set-module) +;; (let ((old #^guile-scheme-output-buffer)) +;; (dynamic-wind +;; (lambda () (set! #^guile-scheme-output-buffer #f)) +;; (lambda () +;; (with-output-to-temp-buffer "*Help*" +;; (lambda () +;; (apropos regexp)))) +;; (lambda () (set! #^guile-scheme-output-buffer old))))) +;; +;; (define (guile-scheme-input-symbol prompt) +;; (let* ((symbol (thing-at-point 'symbol)) +;; (table (map (lambda (sym) (list (symbol->string sym))) +;; (apropos-list ""))) +;; (default (if (assoc symbol table) +;; (string-append " (default " symbol ")") +;; ""))) +;; (string->symbol (completing-read (string-append prompt default ": ") +;; table #f #t #f #f symbol)))) +;; +;; (define-command (guile-scheme-describe symbol) +;; "Display the value and documentation of SYMBOL." +;; (interactive (list (guile-scheme-input-symbol "Describe Guile-Scheme variable"))) +;; (guile-scheme-set-module) +;; (let ((old #^guile-scheme-output-buffer)) +;; (dynamic-wind +;; (lambda () (set! #^guile-scheme-output-buffer #f)) +;; (lambda () +;; (begin-with-output-to-temp-buffer "*Help*" +;; (describe symbol))) +;; (lambda () (set! #^guile-scheme-output-buffer old))))) +;; +;; (define-command (guile-scheme-find-definition symbol) +;; (interactive (list (guile-scheme-input-symbol "Guile-Scheme find definition"))) +;; (guile-scheme-set-module) +;; ) + + +;;; +;;; Turn on guile-scheme-mode for .scm files by default. +;;; + +(setq auto-mode-alist + (cons '("\\.scm\\'" . guile-scheme-mode) auto-mode-alist)) + +(provide 'guile-scheme) + +;;; guile-scheme.el ends here diff --git a/emacs/guile.el b/emacs/guile.el new file mode 100644 index 000000000..f27bc4b7c --- /dev/null +++ b/emacs/guile.el @@ -0,0 +1,172 @@ +;;; guile.el --- Emacs Guile interface + +;; Copyright (C) 2001 Keisuke Nishida + +;; GNU Emacs 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, or (at your option) +;; any later version. + +;; GNU Emacs 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +;;; +;;; Low level interface +;;; + +(defvar guile-token "") + +(defvar gulie-emacs-file + (catch 'return + (mapc (lambda (dir) + (let ((file (expand-file-name "guile-emacs.scm" dir))) + (if (file-exists-p file) (throw 'return file)))) + load-path) + (error "Cannot find guile-emacs.scm"))) + +(defun guile:make-adapter (command channel) + (let* ((buff (generate-new-buffer " *guile object channel*")) + (proc (start-process "guile-oa" buff command + "-q" "-l" gulie-emacs-file))) + (process-kill-without-query proc) + (accept-process-output proc) + (guile-process-require proc (format "(%s)\n" channel) "channel> ") + proc)) + +(put 'guile-error 'error-conditions '(guile-error error)) +(put 'guile-error 'error-message "Guile error") + +(defun guile:eval (string adapter) + (let ((output (guile-process-require adapter (concat "eval " string "\n") + "channel> "))) + (cond + ((string= output "") nil) + ((string-match "^\\(\\(value\\)\\|\\(token\\)\\|\\(exception\\)\\) = " + output) + (cond + ;; value + ((match-beginning 2) + (car (read-from-string (substring output (match-end 0))))) + ;; token + ((match-beginning 3) + (cons guile-token + (car (read-from-string (substring output (match-end 0)))))) + ;; exception + ((match-beginning 4) + (signal 'guile-error + (car (read-from-string (substring output (match-end 0)))))))) + (t + (error "Unsupported result" output))))) + + +;;; +;;; Guile Lisp adapter +;;; + +(defvar guile-lisp-command "guile") +(defvar guile-lisp-adapter nil) + +(defvar true "#t") +(defvar false "#f") + +(defun guile-lisp-adapter () + (if (and (processp guile-lisp-adapter) + (eq (process-status guile-lisp-adapter) 'run)) + guile-lisp-adapter + (setq guile-lisp-adapter + (guile:make-adapter guile-lisp-command 'emacs-lisp-channel)))) + +(defun guile-lisp-convert (x) + (cond + ((or (eq x true) (eq x false)) x) + ((stringp x) (prin1-to-string x)) + ((consp x) + (if (eq (car x) guile-token) + (cadr x) + (cons (guile-lisp-convert (car x)) (guile-lisp-convert (cdr x))))) + (t x))) + +(defun guile-lisp-eval (exp) + (guile:eval (format "%s" (guile-lisp-convert exp)) (guile-lisp-adapter))) + +;;;###autoload +(defmacro guile-import (name) + `(guile-process-import ',name)) + +(defun guile-process-import (name) + (eval (guile-lisp-eval `(guile-emacs-export ',name)))) + +;;;###autoload +(defmacro guile-use-modules (&rest name-list) + `(guile-process-use-modules ',name-list)) + +(defun guile-process-use-modules (list) + (unless (boundp 'guile-emacs-export-procedures) + (guile-import guile-emacs-export-procedures)) + (guile-lisp-eval `(use-modules ,@list)) + (mapc (lambda (name) (eval (guile-emacs-export-procedures name))) list)) + + +;;; +;;; Process handling +;;; + +(defvar guile-process-output-start nil) +(defvar guile-process-output-value nil) +(defvar guile-process-output-finished nil) +(defvar guile-process-output-separator nil) + +(defun guile-process-require (process string separator) + (setq guile-process-output-value nil) + (setq guile-process-output-finished nil) + (setq guile-process-output-separator separator) + (let (temp-buffer) + (unless (process-buffer process) + (setq temp-buffer (guile-temp-buffer)) + (set-process-buffer process temp-buffer)) + (with-current-buffer (process-buffer process) + (goto-char (point-max)) + (insert string) + (setq guile-process-output-start (point)) + (set-process-filter process 'guile-process-filter) + (process-send-string process string) + (while (not guile-process-output-finished) + (unless (accept-process-output process 3) + (when (> (point) guile-process-output-start) + (display-buffer (current-buffer)) + (error "BUG in Guile object channel!!"))))) + (when temp-buffer + (set-process-buffer process nil) + (kill-buffer temp-buffer))) + guile-process-output-value) + +(defun guile-process-filter (process string) + (with-current-buffer (process-buffer process) + (insert string) + (forward-line -1) + (if (< (point) guile-process-output-start) + (goto-char guile-process-output-start)) + (when (re-search-forward guile-process-output-separator nil 0) + (goto-char (match-beginning 0)) + (setq guile-process-output-value + (buffer-substring guile-process-output-start (point))) + (setq guile-process-output-finished t)))) + +(defun guile-process-kill (process) + (set-process-filter process nil) + (delete-process process) + (if (process-buffer process) + (kill-buffer (process-buffer process)))) + +(provide 'guile) + +;;; guile.el ends here diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index e098ab4a5..36238456a 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2001-04-25 Keisuke Nishida + + * channel.scm: New file. + 2001-04-19 Keisuke Nishida * receive.scm (receive): Use `define-macro'. diff --git a/ice-9/channel.scm b/ice-9/channel.scm new file mode 100644 index 000000000..f453ab85c --- /dev/null +++ b/ice-9/channel.scm @@ -0,0 +1,100 @@ +;;; Guile object channel + +;; Copyright (C) 2001 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 +;; the Free Software Foundation; either version 2, 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 this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (ice-9 channel) + :export (make-object-channel + channel-open channel-print-value channel-print-token)) + +;;; +;;; Channel type +;;; + +(define channel-type + (make-record-type 'channel '(stdin stdout printer token-module))) + +(define make-channel (record-constructor channel-type)) + +(define (make-object-channel printer) + (make-channel (current-input-port) + (current-output-port) + printer + (make-module))) + +(define channel-stdin (record-accessor channel-type 'stdin)) +(define channel-stdout (record-accessor channel-type 'stdout)) +(define channel-printer (record-accessor channel-type 'printer)) +(define channel-token-module (record-accessor channel-type 'token-module)) + +;;; +;;; Channel +;;; + +(define (channel-open ch) + (let ((stdin (channel-stdin ch)) + (stdout (channel-stdout ch)) + (printer (channel-printer ch)) + (token-module (channel-token-module ch))) + (let loop () + (catch #t + (lambda () + (channel:prompt stdout) + (let ((cmd (read stdin))) + (if (eof-object? cmd) + (throw 'quit) + (case cmd + ((eval) + (module-use! (current-module) token-module) + (printer ch (eval (read stdin) (current-module)))) + ((destroy) + (let ((token (read stdin))) + (if (module-defined? token-module token) + (module-remove! token-module token) + (channel:error stdout "Invalid token: ~S" token)))) + ((quit) + (throw 'quit)) + (else + (channel:error stdout "Unknown command: ~S" cmd))))) + (loop)) + (lambda (key . args) + (case key + ((quit) (throw 'quit)) + (else + (format stdout "exception = ~S\n" + (list key (apply format #f (cadr args) (caddr args)))) + (loop)))))))) + +(define (channel-print-value ch val) + (format (channel-stdout ch) "value = ~S\n" val)) + +(define (channel-print-token ch val) + (let* ((token (symbol-append (gensym "%%") '%%)) + (pair (cons token (object->string val)))) + (format (channel-stdout ch) "token = ~S\n" pair) + (module-define! (channel-token-module ch) token val))) + +(define (channel:prompt port) + (display "channel> " port) + (force-output port)) + +(define (channel:error port msg . args) + (display "ERROR: " port) + (apply format port msg args) + (newline port)) From 37052e6073d02208d599079c001762c515c25c6d Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 25 Apr 2001 13:24:45 +0000 Subject: [PATCH 0872/2047] Bug fixes. --- emacs/guile-emacs.scm | 8 ++++++-- emacs/guile.el | 14 +++++++++----- 2 files changed, 15 insertions(+), 7 deletions(-) diff --git a/emacs/guile-emacs.scm b/emacs/guile-emacs.scm index 7bc0ee785..08e56500e 100644 --- a/emacs/guile-emacs.scm +++ b/emacs/guile-emacs.scm @@ -84,9 +84,13 @@ (define (procedure-call name args) (let ((restp (memq '&rest args)) - (args (delq '&rest (delq '&optional args)))) + (args (map (lambda (a) `(let ((_t ,a)) + (if (guile-tokenp _t) + (cadr _t) + (list 'quote _t)))) + (delq '&rest (delq '&optional args))))) (if restp - `(list* ',name ,@args) + `(list 'apply ',name ,@args) `(list ',name ,@args)))) (let ((name (procedure-name proc)) diff --git a/emacs/guile.el b/emacs/guile.el index f27bc4b7c..267613440 100644 --- a/emacs/guile.el +++ b/emacs/guile.el @@ -23,8 +23,6 @@ ;;; Low level interface ;;; -(defvar guile-token "") - (defvar gulie-emacs-file (catch 'return (mapc (lambda (dir) @@ -45,6 +43,10 @@ (put 'guile-error 'error-conditions '(guile-error error)) (put 'guile-error 'error-message "Guile error") +(defvar guile-token-tag "") + +(defun guile-tokenp (x) (and (consp x) (eq (car x) guile-token-tag))) + (defun guile:eval (string adapter) (let ((output (guile-process-require adapter (concat "eval " string "\n") "channel> "))) @@ -58,7 +60,7 @@ (car (read-from-string (substring output (match-end 0))))) ;; token ((match-beginning 3) - (cons guile-token + (cons guile-token-tag (car (read-from-string (substring output (match-end 0)))))) ;; exception ((match-beginning 4) @@ -88,10 +90,12 @@ (defun guile-lisp-convert (x) (cond ((or (eq x true) (eq x false)) x) + ((null x) "'()") ((stringp x) (prin1-to-string x)) + ((guile-tokenp x) (cadr x)) ((consp x) - (if (eq (car x) guile-token) - (cadr x) + (if (null (cdr x)) + (list (guile-lisp-convert (car x))) (cons (guile-lisp-convert (car x)) (guile-lisp-convert (cdr x))))) (t x))) From 0b8d495236d2a686a9b4925ca998fa4750e99da3 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 25 Apr 2001 14:19:28 +0000 Subject: [PATCH 0873/2047] (ice9_sources): Include channel.scm. --- ice-9/Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index 1a07748ce..240159059 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -31,7 +31,7 @@ ice9_sources = \ rdelim.scm receive.scm srfi-8.scm regex.scm runq.scm \ safe-r5rs.scm safe.scm session.scm slib.scm stack-catch.scm \ streams.scm string-fun.scm syncase.scm tags.scm threads.scm \ - buffered-input.scm time.scm history.scm + buffered-input.scm time.scm history.scm channel.scm subpkgdatadir = $(pkgdatadir)/$(VERSION)/ice-9 subpkgdata_DATA = $(ice9_sources) From 0d3e064b0b798dbec9b155aa9aebfd255060cb28 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 25 Apr 2001 14:19:58 +0000 Subject: [PATCH 0874/2047] *** empty log message *** --- ice-9/ChangeLog | 1 + 1 file changed, 1 insertion(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 36238456a..ebbacd627 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,6 +1,7 @@ 2001-04-25 Keisuke Nishida * channel.scm: New file. + * Makefile.am (ice9_sources): Include channel.scm. 2001-04-19 Keisuke Nishida From 653c72912796acd1084f2fd05edd249327cf3ea8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 25 Apr 2001 14:28:11 +0000 Subject: [PATCH 0875/2047] * srfi-13.c (scm_string_replace): Take sizeof (char) into account when using memmove(). * srfi-14.h: Added prototypes for all exported procedures.. * srfi-13.c: Include srfi-13.h * srfi-13.h: New file containing the prototypes. * Makefile.am: Removed guile-srfi.texi and info_TEXINFOS variable. (libguile_srfi_srfi_13_14_la_SOURCES): Added srfi-14.h, so it gets distributed. (libguile_srfi_srfi_13_14_la_SOURCES): Added srfi-13.h. --- srfi/ChangeLog | 16 ++++++ srfi/Makefile.am | 3 +- srfi/srfi-13.c | 11 ++-- srfi/srfi-13.h | 131 +++++++++++++++++++++++++++++++++++++++++++++++ srfi/srfi-14.c | 2 +- srfi/srfi-14.h | 47 +++++++++++++++++ 6 files changed, 203 insertions(+), 7 deletions(-) create mode 100644 srfi/srfi-13.h diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 5dca1a5cb..f3be106e4 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,19 @@ +2001-04-25 Martin Grabmueller + + * srfi-13.c (scm_string_replace): Take sizeof (char) into account + when using memmove(). + + * srfi-14.h: Added prototypes for all exported procedures.. + + * srfi-13.c: Include srfi-13.h + + * srfi-13.h: New file containing the prototypes. + + * Makefile.am: Removed guile-srfi.texi and info_TEXINFOS variable. + (libguile_srfi_srfi_13_14_la_SOURCES): Added srfi-14.h, so it gets + distributed. + (libguile_srfi_srfi_13_14_la_SOURCES): Added srfi-13.h. + 2001-04-24 Neil Jerram * Makefile.am: Fixed "srf-14.x" typo. diff --git a/srfi/Makefile.am b/srfi/Makefile.am index 0c8f95040..6a211b978 100644 --- a/srfi/Makefile.am +++ b/srfi/Makefile.am @@ -34,7 +34,8 @@ INCLUDES = -I.. -I$(srcdir)/.. lib_LTLIBRARIES = libguile-srfi-srfi-13-14.la BUILT_SOURCES = srfi-13.x srfi-14.x -libguile_srfi_srfi_13_14_la_SOURCES = srfi-13.x srfi-13.c srfi-14.x srfi-14.c +libguile_srfi_srfi_13_14_la_SOURCES = srfi-13.x srfi-13.c srfi-14.x srfi-14.c\ + srfi-13.h srfi-14.h libguile_srfi_srfi_13_14_la_LDFLAGS = -version-info 0:0 -export-dynamic srfidir = $(datadir)/guile/$(VERSION)/srfi diff --git a/srfi/srfi-13.c b/srfi/srfi-13.c index 584c8e889..8372a7ad7 100644 --- a/srfi/srfi-13.c +++ b/srfi/srfi-13.c @@ -49,6 +49,7 @@ #include +#include "srfi-13.h" #include "srfi-14.h" SCM_DEFINE (scm_string_any, "string-any", 2, 2, 0, @@ -2775,11 +2776,11 @@ SCM_DEFINE (scm_string_replace, "string-replace", 2, 4, 0, result = scm_allocate_string (cstart1 + (cend2 - cstart2) + SCM_STRING_LENGTH (s1) - cend1); p = SCM_STRING_CHARS (result); - memmove (p, cstr1, cstart1); - memmove (p + cstart1, cstr2 + cstart2, (cend2 - cstart2)); + memmove (p, cstr1, cstart1 * sizeof (char)); + memmove (p + cstart1, cstr2 + cstart2, (cend2 - cstart2) * sizeof (char)); memmove (p + cstart1 + (cend2 - cstart2), cstr1 + cend1, - SCM_STRING_LENGTH (s1) - cend1); + (SCM_STRING_LENGTH (s1) - cend1) * sizeof (char)); return result; } #undef FUNC_NAME @@ -3021,7 +3022,7 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0, void -scm_init_srfi_13 () +scm_init_srfi_13 (void) { #ifndef SCM_MAGIC_SNARFER #include "srfi-13.x" @@ -3030,7 +3031,7 @@ scm_init_srfi_13 () void -scm_init_srfi_13_14 () +scm_init_srfi_13_14 (void) { static int initialized = 0; diff --git a/srfi/srfi-13.h b/srfi/srfi-13.h new file mode 100644 index 000000000..525089d15 --- /dev/null +++ b/srfi/srfi-13.h @@ -0,0 +1,131 @@ +#ifndef SCM_SRFI_13_H +#define SCM_SRFI_13_H +/* srfi-13.c --- SRFI-13 procedures for Guile + * + * Copyright (C) 2001 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives + * permission for additional uses of the text contained in its release + * of GUILE. + * + * The exception is that, if you link the GUILE library with other + * files to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public + * License. Your use of that executable is in no way restricted on + * account of linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public + * License. + * + * This exception applies only to the code released by the Free + * Software Foundation under the name GUILE. If you copy code from + * other Free Software Foundation releases into a copy of GUILE, as + * the General Public License permits, the exception does not apply to + * the code that you add in this way. To avoid misleading anyone as + * to the status of such modified files, you must delete this + * exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + + +void scm_init_srfi_13 (void); +void scm_init_srfi_13_14 (void); + +SCM scm_string_any (SCM pred, SCM s, SCM start, SCM end); +SCM scm_string_every (SCM pred, SCM s, SCM start, SCM end); +SCM scm_string_tabulate (SCM proc, SCM len); +SCM scm_string_to_listS (SCM str, SCM start, SCM end); +SCM scm_reverse_list_to_string (SCM chrs); +SCM scm_string_join (SCM ls, SCM delimiter, SCM grammar); +SCM scm_string_copyS (SCM str, SCM start, SCM end); +SCM scm_substring_shared (SCM str, SCM start, SCM end); +SCM scm_string_copy_x (SCM target, SCM tstart, SCM s, SCM start, SCM end); +SCM scm_string_take (SCM s, SCM n); +SCM scm_string_drop (SCM s, SCM n); +SCM scm_string_take_right (SCM s, SCM n); +SCM scm_string_drop_right (SCM s, SCM n); +SCM scm_string_pad (SCM s, SCM len, SCM chr, SCM start, SCM end); +SCM scm_string_pad_right (SCM s, SCM len, SCM chr, SCM start, SCM end); +SCM scm_string_trim (SCM s, SCM char_pred, SCM start, SCM end); +SCM scm_string_trim_right (SCM s, SCM char_pred, SCM start, SCM end); +SCM scm_string_trim_both (SCM s, SCM char_pred, SCM start, SCM end); +SCM scm_string_fill_xS (SCM str, SCM chr, SCM start, SCM end); +SCM scm_string_compare (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2); +SCM scm_string_compare_ci (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2); +SCM scm_string_eq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM scm_string_neq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM scm_string_lt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM scm_string_gt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM scm_string_le (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM scm_string_ge (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM scm_string_ci_eq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM scm_string_ci_neq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM scm_string_ci_lt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM scm_string_ci_gt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM scm_string_ci_le (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM scm_string_ci_ge (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM scm_string_prefix_length (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM scm_string_prefix_length_ci (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM scm_string_suffix_length (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM scm_string_suffix_length_ci (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM scm_string_prefix_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM scm_string_prefix_ci_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM scm_string_suffix_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM scm_string_suffix_ci_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM scm_string_indexS (SCM s, SCM char_pred, SCM start, SCM end); +SCM scm_string_index_right (SCM s, SCM char_pred, SCM start, SCM end); +SCM scm_string_skip (SCM s, SCM char_pred, SCM start, SCM end); +SCM scm_string_skip_right (SCM s, SCM char_pred, SCM start, SCM end); +SCM scm_string_count (SCM s, SCM char_pred, SCM start, SCM end); +SCM scm_string_contains (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM scm_string_contains_ci (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM scm_string_upcase_xS (SCM str, SCM start, SCM end); +SCM scm_string_upcaseS (SCM str, SCM start, SCM end); +SCM scm_string_downcase_xS (SCM str, SCM start, SCM end); +SCM scm_string_downcaseS (SCM str, SCM start, SCM end); +SCM scm_string_titlecase_x (SCM str, SCM start, SCM end); +SCM scm_string_titlecase (SCM str, SCM start, SCM end); +SCM scm_string_reverse (SCM str, SCM start, SCM end); +SCM scm_string_reverse_x (SCM str, SCM start, SCM end); +SCM scm_string_append_shared (SCM ls); +SCM scm_string_concatenate (SCM ls); +SCM scm_reverse_string_concatenate (SCM ls, SCM final_string, SCM end); +SCM scm_string_concatenate_shared (SCM ls); +SCM scm_reverse_string_concatenate_shared (SCM ls, SCM final_string, SCM end); +SCM scm_string_map (SCM s, SCM proc, SCM start, SCM end); +SCM scm_string_map_x (SCM s, SCM proc, SCM start, SCM end); +SCM scm_string_fold (SCM kons, SCM knil, SCM s, SCM start, SCM end); +SCM scm_string_fold_right (SCM kons, SCM knil, SCM s, SCM start, SCM end); +SCM scm_string_unfold (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final); +SCM scm_string_unfold_right (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final); +SCM scm_string_for_each (SCM s, SCM proc, SCM start, SCM end); +SCM scm_xsubstring (SCM s, SCM from, SCM to, SCM start, SCM end); +SCM scm_string_xcopy_x (SCM target, SCM tstart, SCM s, SCM sfrom, SCM sto, SCM start, SCM end); +SCM scm_string_replace (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM scm_string_tokenize (SCM s, SCM token_char, SCM start, SCM end); +SCM scm_string_filter (SCM s, SCM char_pred, SCM start, SCM end); +SCM scm_string_delete (SCM s, SCM char_pred, SCM start, SCM end); + + + + + +#endif /* SCM_SRFI_13_H */ diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index b3af7c2b4..3cbf63c6e 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -1348,7 +1348,7 @@ SCM_DEFINE (scm_char_set_diff_plus_intersection_x, "char-set-diff+intersection!" void -scm_init_srfi_14 () +scm_init_srfi_14 (void) { scm_tc16_charset = scm_make_smob_type ("character-set", SCM_CHARSET_SIZE * sizeof (long)); diff --git a/srfi/srfi-14.h b/srfi/srfi-14.h index 623d1f9ab..6eef6f9f7 100644 --- a/srfi/srfi-14.h +++ b/srfi/srfi-14.h @@ -58,4 +58,51 @@ extern int scm_tc16_charset; void scm_init_srfi_14 (void); +SCM scm_char_set_p (SCM obj); +SCM scm_char_set_eq (SCM cs1, SCM csr); +SCM scm_char_set_leq (SCM cs1, SCM csr); +SCM scm_char_set_hash (SCM cs, SCM bound); +SCM scm_char_set_cursor (SCM cs); +SCM scm_char_set_ref (SCM cs, SCM cursor); +SCM scm_char_set_cursor_next (SCM cs, SCM cursor); +SCM scm_end_of_char_set_p (SCM cursor); +SCM scm_char_set_fold (SCM kons, SCM knil, SCM cs); +SCM scm_char_set_unfold (SCM p, SCM f, SCM g, SCM seed, SCM base_cs); +SCM scm_char_set_unfold_x (SCM p, SCM f, SCM g, SCM seed, SCM base_cs); +SCM scm_char_set_for_each (SCM proc, SCM cs); +SCM scm_char_set_map (SCM proc, SCM cs); +SCM scm_char_set_copy (SCM cs); +SCM scm_char_set (SCM rest); +SCM scm_list_to_char_set (SCM list, SCM base_cs); +SCM scm_list_to_char_set_x (SCM list, SCM base_cs); +SCM scm_string_to_char_set (SCM str, SCM base_cs); +SCM scm_string_to_char_set_x (SCM str, SCM base_cs); +SCM scm_char_set_filter (SCM pred, SCM cs, SCM base_cs); +SCM scm_char_set_filter_x (SCM pred, SCM cs, SCM base_cs); +SCM scm_ucs_range_to_char_set (SCM lower, SCM upper, SCM error, SCM base_cs); +SCM scm_ucs_range_to_char_set_x (SCM lower, SCM upper, SCM error, SCM base_cs); +SCM scm_char_set_size (SCM cs); +SCM scm_char_set_count (SCM pred, SCM cs); +SCM scm_char_set_to_list (SCM cs); +SCM scm_char_set_to_string (SCM cs); +SCM scm_char_set_contains_p (SCM cs, SCM ch); +SCM scm_char_set_every (SCM pred, SCM cs); +SCM scm_char_set_any (SCM pred, SCM cs); +SCM scm_char_set_adjoin (SCM cs, SCM rest); +SCM scm_char_set_delete (SCM cs, SCM rest); +SCM scm_char_set_adjoin_x (SCM cs, SCM rest); +SCM scm_char_set_delete_x (SCM cs, SCM rest); +SCM scm_char_set_complement (SCM cs); +SCM scm_char_set_union (SCM rest); +SCM scm_char_set_intersection (SCM cs1, SCM rest); +SCM scm_char_set_difference (SCM cs1, SCM rest); +SCM scm_char_set_xor (SCM cs1, SCM rest); +SCM scm_char_set_diff_plus_intersection (SCM cs1, SCM rest); +SCM scm_char_set_complement_x (SCM cs); +SCM scm_char_set_union_x (SCM cs1, SCM rest); +SCM scm_char_set_intersection_x (SCM cs1, SCM rest); +SCM scm_char_set_difference_x (SCM cs1, SCM rest); +SCM scm_char_set_xor_x (SCM cs1, SCM rest); +SCM scm_char_set_diff_plus_intersection_x (SCM cs1, SCM rest); + #endif /* SCM_SRFI_14_H */ From 1f7a1dc98c7b17f0abdd7c984ca248982bfa9fd4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 25 Apr 2001 14:35:34 +0000 Subject: [PATCH 0876/2047] * configure.in: Don't treat srfi directory specially, just create the Makefile there (thanks to Neil Jerram for the patch). * configure.in, autogen.sh: Removed. --- ChangeLog | 5 +++++ configure.in | 21 +++++++++++++++++++-- srfi/ChangeLog | 2 ++ srfi/autogen.sh | 0 srfi/configure.in | 0 5 files changed, 26 insertions(+), 2 deletions(-) delete mode 100755 srfi/autogen.sh delete mode 100644 srfi/configure.in diff --git a/ChangeLog b/ChangeLog index d2da6e626..8ea454c98 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2001-04-25 Martin Grabmueller + + * configure.in: Don't treat srfi directory specially, just create + the Makefile there (thanks to Neil Jerram for the patch). + 2001-04-23 Martin Grabmueller * Makefile.am (SUBDIRS): Added `srfi'. diff --git a/configure.in b/configure.in index 93b8a6332..abf76d111 100644 --- a/configure.in +++ b/configure.in @@ -33,7 +33,6 @@ AM_CONFIG_HEADER(libguile/scmconfig.h) #-------------------------------------------------------------------- AC_CONFIG_SUBDIRS(guile-readline) -AC_CONFIG_SUBDIRS(srfi) #-------------------------------------------------------------------- # @@ -552,7 +551,25 @@ AC_SUBST(LIBLOBJS) AC_SUBST(EXTRA_DOT_DOC_FILES) AC_SUBST(EXTRA_DOT_X_FILES) -AC_OUTPUT([Makefile libguile/Makefile libguile/guile-snarf libguile/guile-doc-snarf libguile/guile-func-name-check libguile/guile-snarf.awk libguile/versiondat.h ice-9/Makefile oop/Makefile oop/goops/Makefile qt/Makefile qt/qt.h qt/md/Makefile qt/time/Makefile guile-config/Makefile doc/Makefile check-guile], [chmod +x libguile/guile-snarf libguile/guile-doc-snarf libguile/guile-func-name-check check-guile]) +AC_OUTPUT([Makefile + libguile/Makefile + libguile/guile-snarf + libguile/guile-doc-snarf + libguile/guile-func-name-check + libguile/guile-snarf.awk + libguile/versiondat.h + ice-9/Makefile + oop/Makefile + oop/goops/Makefile + srfi/Makefile + qt/Makefile + qt/qt.h + qt/md/Makefile + qt/time/Makefile + guile-config/Makefile + doc/Makefile + check-guile], + [chmod +x libguile/guile-snarf libguile/guile-doc-snarf libguile/guile-func-name-check check-guile]) dnl Local Variables: dnl comment-start: "dnl " diff --git a/srfi/ChangeLog b/srfi/ChangeLog index f3be106e4..42e34de24 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,5 +1,7 @@ 2001-04-25 Martin Grabmueller + * configure.in, autogen.sh: Removed. + * srfi-13.c (scm_string_replace): Take sizeof (char) into account when using memmove(). diff --git a/srfi/autogen.sh b/srfi/autogen.sh deleted file mode 100755 index e69de29bb..000000000 diff --git a/srfi/configure.in b/srfi/configure.in deleted file mode 100644 index e69de29bb..000000000 From 8acc3515a0ada6999ae58bb99d301ca2c9f145f9 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Apr 2001 22:04:25 +0000 Subject: [PATCH 0877/2047] * boot-9.scm (the-module, set-current-module, current-module): Removed, they are now defined in libguile. --- ice-9/boot-9.scm | 35 +---------------------------------- 1 file changed, 1 insertion(+), 34 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 4cdfab4c2..a4af8fe4b 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1013,7 +1013,7 @@ ;; to maximally one module. (set-procedure-property! closure 'module module)))) -;;; This procedure is depreated +;;; This procedure is deprecated ;;; (define eval-in-module eval) @@ -1345,39 +1345,6 @@ (make-module 1019 '() scm-module-closure)) - -;; the-module -;; -;; NOTE: This binding is used in libguile/modules.c. -;; -(define the-module (make-fluid)) - -;; scm:eval-transformer -;; -;;(define scm:eval-transformer (make-fluid)) ; initialized in eval.c. - -;; set-current-module module -;; -;; set the current module as viewed by the normalizer. -;; -;; NOTE: This binding is used in libguile/modules.c. -;; -(define (set-current-module m) - (fluid-set! the-module m) - (if m - (begin - ;; *top-level-lookup-closure* is now deprecated - (fluid-set! *top-level-lookup-closure* - (module-eval-closure (fluid-ref the-module))) - (fluid-set! scm:eval-transformer (module-transformer (fluid-ref the-module)))) - (fluid-set! *top-level-lookup-closure* #f))) - - -;; current-module -;; -;; return the current module as viewed by the normalizer. -;; -(define (current-module) (fluid-ref the-module)) ;;; {Module-based Loading} ;;; From c685b42fa3aa3a9efa2a4bf29a5ea1bb901e48d8 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Wed, 25 Apr 2001 23:13:52 +0000 Subject: [PATCH 0878/2047] * tests/r4rs.test: delete files tmp1, tmp2, tmp3 after the tests have run. * tests/ports.test (test-file), tests/load.test (temp-dir): redefined using data-file-name instead of tmpnam. the test files will be created in the build directory instead of /var/tmp or whereever tmpnam puts them. --- test-suite/ChangeLog | 10 ++++++++++ test-suite/tests/load.test | 2 +- test-suite/tests/ports.test | 2 +- test-suite/tests/r4rs.test | 4 ++++ 4 files changed, 16 insertions(+), 2 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 57bfa51a4..d9d83f8a8 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,13 @@ +2001-04-26 Gary Houston + + * tests/r4rs.test: delete files tmp1, tmp2, tmp3 after the tests + have run. + + * tests/ports.test (test-file), tests/load.test (temp-dir): + redefined using data-file-name instead of tmpnam. the test files + will be created in the build directory instead of /var/tmp or + whereever tmpnam puts them. + 2001-04-02 Dirk Herrmann * tests/symbols.c: Added some tests. diff --git a/test-suite/tests/load.test b/test-suite/tests/load.test index 485766ebd..473d09de2 100644 --- a/test-suite/tests/load.test +++ b/test-suite/tests/load.test @@ -20,7 +20,7 @@ (use-modules (test-suite lib)) -(define temp-dir (tmpnam)) +(define temp-dir (data-file-name "load-test.dir")) (define (create-tree parent tree) (let loop ((parent parent) diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index 5429b20f7..e941f91bd 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -27,7 +27,7 @@ (newline)) (define (test-file) - (tmpnam)) + (data-file-name "ports-test.tmp")) ;;;; Some general utilities for testing ports. diff --git a/test-suite/tests/r4rs.test b/test-suite/tests/r4rs.test index f8bba3079..246bbfcfe 100644 --- a/test-suite/tests/r4rs.test +++ b/test-suite/tests/r4rs.test @@ -1018,3 +1018,7 @@ ;; alternatively execute every test file's code in a module of its own (if (defined? 'x) (undefine x)) (if (defined? 'y) (undefine y)) + +(delete-file (data-file-name "tmp1")) +(delete-file (data-file-name "tmp2")) +(delete-file (data-file-name "tmp3")) From 9ab0d7881769e2b1732d9bbf666104783553ebff Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Thu, 26 Apr 2001 04:40:02 +0000 Subject: [PATCH 0879/2047] *** empty log message *** --- emacs/guile-emacs.scm | 31 ++++++++++++-------------- emacs/guile.el | 51 ++++++++++++++++++++++++++++++++----------- 2 files changed, 52 insertions(+), 30 deletions(-) diff --git a/emacs/guile-emacs.scm b/emacs/guile-emacs.scm index 08e56500e..fa61ddbf2 100644 --- a/emacs/guile-emacs.scm +++ b/emacs/guile-emacs.scm @@ -58,7 +58,7 @@ ;;; for guile-import and guile-use-modules ;;; -(define (guile-emacs-export-procedure proc) +(define (guile-emacs-export-procedure name proc docs) (define (procedure-arity proc) (assq-ref (procedure-properties proc) 'arity)) @@ -84,32 +84,29 @@ (define (procedure-call name args) (let ((restp (memq '&rest args)) - (args (map (lambda (a) `(let ((_t ,a)) - (if (guile-tokenp _t) - (cadr _t) - (list 'quote _t)))) - (delq '&rest (delq '&optional args))))) + (args (delq '&rest (delq '&optional args)))) (if restp - `(list 'apply ',name ,@args) - `(list ',name ,@args)))) + `('apply ',name ,@args) + `(',name ,@args)))) - (let ((name (procedure-name proc)) - (args (procedure-args proc)) - (docs (object-documentation proc))) + (let ((args (procedure-args proc)) + (docs (and docs (object-documentation proc)))) `(defun ,name ,args ,@(if docs (list docs) '()) - (guile-lisp-eval ,(procedure-call name args))))) + (guile-lisp-flat-eval ,@(procedure-call name args))))) -(define (guile-emacs-export proc-name) - (guile-emacs-export-procedure (module-ref (current-module) proc-name))) +(define (guile-emacs-export proc-name func-name docs) + (let ((proc (module-ref (current-module) proc-name))) + (guile-emacs-export-procedure func-name proc docs))) -(define (guile-emacs-export-procedures module-name) +(define (guile-emacs-export-procedures module-name docs) (define (module-public-procedures name) (hash-fold (lambda (s v d) (let ((val (variable-ref v))) - (if (procedure? val) (cons val d) d))) + (if (procedure? val) (acons s val d) d))) '() (module-obarray (resolve-interface name)))) - `(progn ,@(map guile-emacs-export-procedure + `(progn ,@(map (lambda (n+p) + (guile-emacs-export-procedure (car n+p) (cdr n+p) docs)) (module-public-procedures module-name)))) diff --git a/emacs/guile.el b/emacs/guile.el index 267613440..743c10cd8 100644 --- a/emacs/guile.el +++ b/emacs/guile.el @@ -31,10 +31,22 @@ load-path) (error "Cannot find guile-emacs.scm"))) +(defvar gulie-channel-file + (catch 'return + (mapc (lambda (dir) + (let ((file (expand-file-name "channel.scm" dir))) + (if (file-exists-p file) (throw 'return file)))) + load-path))) + +(defvar guile-libs + (nconc (if gulie-channel-file (list "-l" gulie-channel-file) '()) + (list "-l" gulie-emacs-file))) + +;;;###autoload (defun guile:make-adapter (command channel) (let* ((buff (generate-new-buffer " *guile object channel*")) - (proc (start-process "guile-oa" buff command - "-q" "-l" gulie-emacs-file))) + (libs (if gulie-channel-file (list "-l" gulie-channel-file) nil)) + (proc (apply 'start-process "guile-oa" buff command "-q" guile-libs))) (process-kill-without-query proc) (accept-process-output proc) (guile-process-require proc (format "(%s)\n" channel) "channel> ") @@ -47,6 +59,7 @@ (defun guile-tokenp (x) (and (consp x) (eq (car x) guile-token-tag))) +;;;###autoload (defun guile:eval (string adapter) (let ((output (guile-process-require adapter (concat "eval " string "\n") "channel> "))) @@ -91,6 +104,7 @@ (cond ((or (eq x true) (eq x false)) x) ((null x) "'()") + ((keywordp x) (concat "#" (prin1-to-string x))) ((stringp x) (prin1-to-string x)) ((guile-tokenp x) (cadr x)) ((consp x) @@ -99,25 +113,36 @@ (cons (guile-lisp-convert (car x)) (guile-lisp-convert (cdr x))))) (t x))) -(defun guile-lisp-eval (exp) - (guile:eval (format "%s" (guile-lisp-convert exp)) (guile-lisp-adapter))) +;;;###autoload +(defun guile-lisp-eval (form) + (guile:eval (format "%s" (guile-lisp-convert form)) (guile-lisp-adapter))) + +(defun guile-lisp-flat-eval (&rest form) + (let ((args (mapcar (lambda (x) + (if (guile-tokenp x) (cadr x) (list 'quote x))) + (cdr form)))) + (guile-lisp-eval (cons (car form) args)))) ;;;###autoload -(defmacro guile-import (name) - `(guile-process-import ',name)) +(defmacro guile-import (name &optional new-name &rest opts) + `(guile-process-import ',name ',new-name ',opts)) -(defun guile-process-import (name) - (eval (guile-lisp-eval `(guile-emacs-export ',name)))) +(defun guile-process-import (name new-name opts) + (let ((real (or new-name name)) + (docs (if (memq :with-docs opts) true false))) + (eval (guile-lisp-eval `(guile-emacs-export ',name ',real ,docs))))) ;;;###autoload -(defmacro guile-use-modules (&rest name-list) - `(guile-process-use-modules ',name-list)) +(defmacro guile-import-module (name &rest opts) + `(guile-process-use-module ',name ',opts)) -(defun guile-process-use-modules (list) +(defun guile-process-use-module (name opts) (unless (boundp 'guile-emacs-export-procedures) (guile-import guile-emacs-export-procedures)) - (guile-lisp-eval `(use-modules ,@list)) - (mapc (lambda (name) (eval (guile-emacs-export-procedures name))) list)) + (let ((docs (if (memq :with-docs opts) true false))) + (guile-lisp-eval `(use-modules ,name)) + (eval (guile-emacs-export-procedures name docs)) + name)) ;;; From 7405a09d39ae2c6ecd823834457a72e0fbe5160a Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Thu, 26 Apr 2001 04:56:14 +0000 Subject: [PATCH 0880/2047] *** empty log message *** --- emacs/guile-emacs.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/emacs/guile-emacs.scm b/emacs/guile-emacs.scm index fa61ddbf2..b345072ff 100644 --- a/emacs/guile-emacs.scm +++ b/emacs/guile-emacs.scm @@ -93,7 +93,7 @@ (docs (and docs (object-documentation proc)))) `(defun ,name ,args ,@(if docs (list docs) '()) - (guile-lisp-flat-eval ,@(procedure-call name args))))) + (guile-lisp-flat-eval ,@(procedure-call (procedure-name proc) args))))) (define (guile-emacs-export proc-name func-name docs) (let ((proc (module-ref (current-module) proc-name))) From 1c446a7f5d631ddf724224802283b9e8c8008a5d Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Thu, 26 Apr 2001 05:19:29 +0000 Subject: [PATCH 0881/2047] Made it Guile 1.4 compatible. --- emacs/guile-emacs.scm | 9 +++++++++ ice-9/channel.scm | 27 ++++++++++++++++++++------- 2 files changed, 29 insertions(+), 7 deletions(-) diff --git a/emacs/guile-emacs.scm b/emacs/guile-emacs.scm index b345072ff..995d0d6eb 100644 --- a/emacs/guile-emacs.scm +++ b/emacs/guile-emacs.scm @@ -125,4 +125,13 @@ apropos-fold-all) (lambda (p1 p2) (stringstring + (if (defined? 'object->string) + object->string + (lambda (x) (format #f "~S" x)))) + ;;; guile-emacs.scm ends here diff --git a/ice-9/channel.scm b/ice-9/channel.scm index f453ab85c..07974be80 100644 --- a/ice-9/channel.scm +++ b/ice-9/channel.scm @@ -19,9 +19,7 @@ ;;; Code: -(define-module (ice-9 channel) - :export (make-object-channel - channel-open channel-print-value channel-print-token)) +(define-module (ice-9 channel)) ;;; ;;; Channel type @@ -32,7 +30,7 @@ (define make-channel (record-constructor channel-type)) -(define (make-object-channel printer) +(define-public (make-object-channel printer) (make-channel (current-input-port) (current-output-port) printer @@ -47,7 +45,7 @@ ;;; Channel ;;; -(define (channel-open ch) +(define-public (channel-open ch) (let ((stdin (channel-stdin ch)) (stdout (channel-stdout ch)) (printer (channel-printer ch)) @@ -81,10 +79,10 @@ (list key (apply format #f (cadr args) (caddr args)))) (loop)))))))) -(define (channel-print-value ch val) +(define-public (channel-print-value ch val) (format (channel-stdout ch) "value = ~S\n" val)) -(define (channel-print-token ch val) +(define-public (channel-print-token ch val) (let* ((token (symbol-append (gensym "%%") '%%)) (pair (cons token (object->string val)))) (format (channel-stdout ch) "token = ~S\n" pair) @@ -98,3 +96,18 @@ (display "ERROR: " port) (apply format port msg args) (newline port)) + +;;; +;;; Guile 1.4 compatibility +;;; + +(define guile:eval eval) +(define eval + (if (= (car (procedure-property guile:eval 'arity)) 1) + (lambda (x e) (guile:eval x)) + guile:eval)) + +(define object->string + (if (defined? 'object->string) + object->string + (lambda (x) (format #f "~S" x)))) From ac667929bcebd842677537ff8472dd71c0171981 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Thu, 26 Apr 2001 05:25:04 +0000 Subject: [PATCH 0882/2047] *** empty log message *** --- emacs/guile-c.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/emacs/guile-c.el b/emacs/guile-c.el index 7c6db51f7..fe05159ec 100644 --- a/emacs/guile-c.el +++ b/emacs/guile-c.el @@ -22,8 +22,8 @@ ;; (add-hook 'c-mode-hook ;; (lambda () ;; (require 'guile-c) -;; (define-key c-mode-map "\C-c\C-g\C-e" 'guile-c-edit-docstring) ;; (define-key c-mode-map "\C-c\C-g\C-p" 'guile-c-insert-define) +;; (define-key c-mode-map "\C-c\C-g\C-e" 'guile-c-edit-docstring) ;; (define-key c-mode-map "\C-c\C-g\C-d" 'guile-c-deprecate-region) ;; )) From bd5e6840910070de8d50e26b968146252841d188 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 26 Apr 2001 18:26:28 +0000 Subject: [PATCH 0883/2047] * Update SMOB example and associated documentation. --- doc/ChangeLog | 6 +++++ doc/data-rep.texi | 47 +++++++++++++++++------------------ doc/example-smob/ChangeLog | 8 ++++++ doc/example-smob/image-type.c | 17 ++++++------- 4 files changed, 45 insertions(+), 33 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index c38fac844..f465bde3f 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,9 @@ +2001-04-26 Neil Jerram + + * data-rep.texi (Defining New Types (Smobs)): Use non-deprecated + smob interface. Thanks to Masao Uebayashi for the patch! + (Creating Instances): Don't need SCM_NIMP anymore. + 2001-04-25 Marius Vollmer * guile.1: New file, from Robert Merkel and Rob Browning. diff --git a/doc/data-rep.texi b/doc/data-rep.texi index 83edcb87c..a563a7154 100644 --- a/doc/data-rep.texi +++ b/doc/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.22 2001-04-20 13:26:55 ossau Exp $ +@c essay @subtitle $Id: data-rep.texi,v 1.23 2001-04-26 18:26:28 ossau Exp $ @c essay @subtitle For use with Guile @value{VERSION} @c essay @author Jim Blandy @c essay @author Free Software Foundation @@ -1493,13 +1493,15 @@ representing eight-bit grayscale images: @example #include -long image_tag; +static long image_tag; void init_image_type () @{ - image_tag = scm_make_smob_type_mfpe ("image",sizeof(struct image), - mark_image, free_image, print_image, NULL); + image_tag = scm_make_smob_type ("image", sizeof (struct image)); + scm_set_smob_mark (image_tag, mark_image); + scm_set_smob_free (image_tag, free_image); + scm_set_smob_print (image_tag, print_image); @} @end example @@ -1573,8 +1575,8 @@ This function isn't usually sufficiently different from the usual Continuing the above example, if the global variable @code{image_tag} -contains a tag returned by @code{scm_newsmob}, here is how we could -construct a smob whose @sc{cdr} contains a pointer to a freshly +contains a tag returned by @code{scm_make_smob_type}, here is how we +could construct a smob whose @sc{cdr} contains a pointer to a freshly allocated @code{struct image}: @example @@ -1597,8 +1599,7 @@ make_image (SCM name, SCM s_width, SCM s_height) struct image *image; int width, height; - SCM_ASSERT (SCM_NIMP (name) && SCM_STRINGP (name), name, - SCM_ARG1, "make-image"); + SCM_ASSERT (SCM_STRINGP (name), name, SCM_ARG1, "make-image"); SCM_ASSERT (SCM_INUMP (s_width), s_width, SCM_ARG2, "make-image"); SCM_ASSERT (SCM_INUMP (s_height), s_height, SCM_ARG3, "make-image"); @@ -1625,7 +1626,7 @@ their arguments, to avoid misinterpreting some other datatype as a smob, and perhaps causing a segmentation fault. Fortunately, this is pretty simple to do. The function need only verify that its argument is a non-immediate, whose @sc{car} is the type tag returned by -@code{scm_newsmob}. +@code{scm_make_smob_type}. For example, here is a simple function that operates on an image smob, and checks the type of its argument. We also present an expanded @@ -1657,10 +1658,13 @@ clear_image (SCM image_smob) void init_image_type () @{ - image_tag = scm_newsmob (&image_funs); + image_tag = scm_make_smob_type ("image", sizeof (struct image)); + scm_set_smob_mark (image_tag, mark_image); + scm_set_smob_free (image_tag, free_image); + scm_set_smob_print (image_tag, print_image); - scm_make_gsubr ("make-image", 3, 0, 0, make_image); scm_make_gsubr ("clear-image", 1, 0, 0, clear_image); + scm_make_gsubr ("make-image", 3, 0, 0, make_image); @} @end example @@ -1826,8 +1830,7 @@ make_image (SCM name, SCM s_width, SCM s_height) SCM image_smob; int width, height; - SCM_ASSERT (SCM_NIMP (name) && SCM_STRINGP (name), name, - SCM_ARG1, "make-image"); + SCM_ASSERT (SCM_STRINGP (name), name, SCM_ARG1, "make-image"); SCM_ASSERT (SCM_INUMP (s_width), s_width, SCM_ARG2, "make-image"); SCM_ASSERT (SCM_INUMP (s_height), s_height, SCM_ARG3, "make-image"); @@ -1949,11 +1952,9 @@ static SCM make_image (SCM name, SCM s_width, SCM s_height) @{ struct image *image; - SCM image_smob; int width, height; - SCM_ASSERT (SCM_NIMP (name) && SCM_STRINGP (name), name, - SCM_ARG1, "make-image"); + SCM_ASSERT (SCM_STRINGP (name), name, SCM_ARG1, "make-image"); SCM_ASSERT (SCM_INUMP (s_width), s_width, SCM_ARG2, "make-image"); SCM_ASSERT (SCM_INUMP (s_height), s_height, SCM_ARG3, "make-image"); @@ -1967,9 +1968,7 @@ make_image (SCM name, SCM s_width, SCM s_height) image->name = name; image->update_func = SCM_BOOL_F; - SCM_NEWSMOB (image_smob, image_tag, image); - - return image_smob; + SCM_RETURN_NEWSMOB (image_tag, image); @} static SCM @@ -1995,6 +1994,7 @@ clear_image (SCM image_smob) static SCM mark_image (SCM image_smob) @{ + /* Mark the image's name and update function. */ struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); scm_gc_mark (image->name); @@ -2026,14 +2026,13 @@ print_image (SCM image_smob, SCM port, scm_print_state *pstate) return 1; @} -static scm_smobfuns image_funs = @{ - mark_image, free_image, print_image, 0 -@}; - void init_image_type () @{ - image_tag = scm_newsmob (&image_funs); + image_tag = scm_make_smob_type ("image", sizeof (struct image)); + scm_set_smob_mark (image_tag, mark_image); + scm_set_smob_free (image_tag, free_image); + scm_set_smob_print (image_tag, print_image); scm_make_gsubr ("clear-image", 1, 0, 0, clear_image); scm_make_gsubr ("make-image", 3, 0, 0, make_image); diff --git a/doc/example-smob/ChangeLog b/doc/example-smob/ChangeLog index 316d0b0ec..12afa8813 100644 --- a/doc/example-smob/ChangeLog +++ b/doc/example-smob/ChangeLog @@ -1,3 +1,11 @@ +2001-04-26 Neil Jerram + + * image-type.c (make_image): Don't need to use SCM_NIMP before + SCM_STRINGP. + (clear_image): Use SCM_SMOB_PREDICATE. + (clear_image, mark_image, free_image, print_image): Use + SCM_SMOB_DATA rather than SCM_CDR. + 2000-06-20 Mikael Djurfeldt * image-type.c: Removed unused scm_smobfuns structure. diff --git a/doc/example-smob/image-type.c b/doc/example-smob/image-type.c index 3c49e592e..fe0a9b802 100644 --- a/doc/example-smob/image-type.c +++ b/doc/example-smob/image-type.c @@ -42,8 +42,7 @@ make_image (SCM name, SCM s_width, SCM s_height) struct image *image; int width, height; - SCM_ASSERT (SCM_NIMP (name) && SCM_STRINGP (name), name, - SCM_ARG1, "make-image"); + SCM_ASSERT (SCM_STRINGP (name), name, SCM_ARG1, "make-image"); SCM_ASSERT (SCM_INUMP (s_width), s_width, SCM_ARG2, "make-image"); SCM_ASSERT (SCM_INUMP (s_height), s_height, SCM_ARG3, "make-image"); @@ -66,11 +65,10 @@ clear_image (SCM image_smob) int area; struct image *image; - SCM_ASSERT ((SCM_NIMP (image_smob) - && SCM_CAR (image_smob) == image_tag), - image_smob, SCM_ARG1, "clear-image"); + SCM_ASSERT (SCM_SMOB_PREDICATE (image_tag, image_smob), + image_smob, SCM_ARG1, "clear-image"); - image = (struct image *) SCM_CDR (image_smob); + image = (struct image *) SCM_SMOB_DATA (image_smob); area = image->width * image->height; memset (image->pixels, 0, area); @@ -84,7 +82,8 @@ clear_image (SCM image_smob) static SCM mark_image (SCM image_smob) { - struct image *image = (struct image *) SCM_CDR (image_smob); + /* Mark the image's name and update function. */ + struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); scm_gc_mark (image->name); return image->update_func; @@ -93,7 +92,7 @@ mark_image (SCM image_smob) static scm_sizet free_image (SCM image_smob) { - struct image *image = (struct image *) SCM_CDR (image_smob); + struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); scm_sizet size = image->width * image->height + sizeof (struct image); free (image->pixels); @@ -105,7 +104,7 @@ free_image (SCM image_smob) static int print_image (SCM image_smob, SCM port, scm_print_state *pstate) { - struct image *image = (struct image *) SCM_CDR (image_smob); + struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); scm_puts ("#name, port); From 8dddb4bc9f65f8c0f944785646e54f0013a32f5c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 26 Apr 2001 19:54:48 +0000 Subject: [PATCH 0884/2047] Changed two procedure names to match final SRFI document. Thanks to Rob Browning for spotting this. * srfi-13.scm (string-concatenate-reverse), (string-concatenate-reverse/shared): Rename from reverse-string-concatenate[/shared]. * srfi-13.c (scm_string_concatenate_reverse_shared): Renamed from scm_reverse_string_concatenate_shared. (scm_string_concatenate_reverse): Renamed from scm_reverse_string_concatenate. --- srfi/ChangeLog | 14 ++++++++++++++ srfi/srfi-13.c | 16 +++++++++------- srfi/srfi-13.scm | 4 ++-- 3 files changed, 25 insertions(+), 9 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 42e34de24..ac85c2fdf 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,17 @@ +2001-04-26 Martin Grabmueller + + Changed two procedure names to match final SRFI document. Thanks + to Rob Browning for spotting this. + + * srfi-13.scm (string-concatenate-reverse), + (string-concatenate-reverse/shared): Rename from + reverse-string-concatenate[/shared]. + + * srfi-13.c (scm_string_concatenate_reverse_shared): Renamed from + scm_reverse_string_concatenate_shared. + (scm_string_concatenate_reverse): Renamed from + scm_reverse_string_concatenate. + 2001-04-25 Martin Grabmueller * configure.in, autogen.sh: Removed. diff --git a/srfi/srfi-13.c b/srfi/srfi-13.c index 8372a7ad7..800677315 100644 --- a/srfi/srfi-13.c +++ b/srfi/srfi-13.c @@ -2297,7 +2297,7 @@ SCM_DEFINE (scm_string_concatenate, "string-concatenate", 1, 0, 0, #undef FUNC_NAME -SCM_DEFINE (scm_reverse_string_concatenate, "reverse-string-concatenate", 1, 2, 0, +SCM_DEFINE (scm_string_concatenate_reverse, "string-concatenate-reverse", 1, 2, 0, (SCM ls, SCM final_string, SCM end), "Without optional arguments, this procedure is equivalent to\n" "\n" @@ -2307,10 +2307,12 @@ SCM_DEFINE (scm_reverse_string_concatenate, "reverse-string-concatenate", 1, 2, "\n" "If the optional argument @var{final_string} is specified, it is\n" "consed onto the beginning to @var{ls} before performing the\n" - "list-reverse and string-concatenate operations.\n" + "list-reverse and string-concatenate operations. If @var{end}\n" + "is given, only the characters of @var{final_string} up to index\n" + "@var{end} are used.\n" "\n" "Guaranteed to return a freshly allocated string.") -#define FUNC_NAME s_scm_reverse_string_concatenate +#define FUNC_NAME s_scm_string_concatenate_reverse { long strings; SCM tmp, result; @@ -2394,14 +2396,14 @@ SCM_DEFINE (scm_string_concatenate_shared, "string-concatenate/shared", 1, 0, 0, #undef FUNC_NAME -SCM_DEFINE (scm_reverse_string_concatenate_shared, "reverse-string-concatenate/shared", 1, 2, 0, +SCM_DEFINE (scm_string_concatenate_reverse_shared, "string-concatenate-reverse/shared", 1, 2, 0, (SCM ls, SCM final_string, SCM end), - "Like @code{reverse-string-concatenate}, but the result may\n" + "Like @code{string-concatenate-reverse}, but the result may\n" "share memory with the the strings in the @var{ls} arguments.") -#define FUNC_NAME s_scm_reverse_string_concatenate_shared +#define FUNC_NAME s_scm_string_concatenate_reverse_shared { /* Just call the non-sharing version. */ - return scm_reverse_string_concatenate (ls, final_string, end); + return scm_string_concatenate_reverse (ls, final_string, end); } #undef FUNC_NAME diff --git a/srfi/srfi-13.scm b/srfi/srfi-13.scm index c40933a97..89f974d8f 100644 --- a/srfi/srfi-13.scm +++ b/srfi/srfi-13.scm @@ -86,9 +86,9 @@ ;; string-append <= in the core string-append/shared string-concatenate - reverse-string-concatenate + string-concatenate-reverse string-concatenate/shared - reverse-string-concatenate/shared + string-concatenate-reverse/shared ;;; Fold/Unfold/Map string-map string-map! From c59ef9c15462b80dd8f5dea57eb3f606403af1f1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 26 Apr 2001 19:59:33 +0000 Subject: [PATCH 0885/2047] * srfi-13-14.texi (Reverse/Append): Updated procedure names for string-concatenate-reverse[/shared]. (Reverse/Append): Document the parameter `end' to string-concatenate-reverse. --- doc/ChangeLog | 7 +++++++ doc/srfi-13-14.texi | 10 ++++++---- 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index f465bde3f..7fdab78aa 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,10 @@ +2001-04-26 Martin Grabmueller + + * srfi-13-14.texi (Reverse/Append): Updated procedure names for + string-concatenate-reverse[/shared]. + (Reverse/Append): Document the parameter `end' to + string-concatenate-reverse. + 2001-04-26 Neil Jerram * data-rep.texi (Defining New Types (Smobs)): Use non-deprecated diff --git a/doc/srfi-13-14.texi b/doc/srfi-13-14.texi index 3daaf81f3..8d96b9618 100644 --- a/doc/srfi-13-14.texi +++ b/doc/srfi-13-14.texi @@ -541,7 +541,7 @@ Like @code{string-concatenate}, but the result may share memory with the strings in the list @var{ls}. @end deffn -@deffn primitive reverse-string-concatenate ls final_string end +@deffn primitive string-concatenate-reverse ls final_string end Without optional arguments, this procedure is equivalent to @smalllisp @@ -550,13 +550,15 @@ Without optional arguments, this procedure is equivalent to If the optional argument @var{final_string} is specified, it is consed onto the beginning to @var{ls} before performing the -list-reverse and string-concatenate operations. +list-reverse and string-concatenate operations. If @var{end} +is given, only the characters of @var{final_string} up to index +@var{end} are used. Guaranteed to return a freshly allocated string. @end deffn -@deffn primitive reverse-string-concatenate/shared ls final_string end -Like @code{reverse-string-concatenate}, but the result may +@deffn primitive string-concatenate-reverse/shared ls final_string end +Like @code{string-concatenate-reverse}, but the result may share memory with the the strings in the @var{ls} arguments. @end deffn From 53e29a1e0cf1f9f1636b4b56f62e27cae5c8111f Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 26 Apr 2001 20:16:12 +0000 Subject: [PATCH 0886/2047] *** empty log message *** --- AUTHORS | 7 +++++++ NEWS | 18 ++++++++++++++++++ 2 files changed, 25 insertions(+) diff --git a/AUTHORS b/AUTHORS index cea4012a5..b5e270857 100644 --- a/AUTHORS +++ b/AUTHORS @@ -91,3 +91,10 @@ Tim Pierce: In the subdirectory libguile, wrote: regex-posix.c regex-posix.h + +Rob Browning: +In the subdirectory srfi, wrote the initial files for: + srfi-2.scm + srfi-6.scm + srfi-8.scm + srfi-11.scm diff --git a/NEWS b/NEWS index 4b5e76bf1..0430c5b97 100644 --- a/NEWS +++ b/NEWS @@ -8,6 +8,24 @@ Changes since Guile 1.4: * Changes to the distribution +** New module (srfi srfi-11): + +This module exports let-values and let*-values. + +** New module (srfi srfi-6): + +This is a dummy file for now, since guile already provides all of the +srfi-6 procedures by default: open-input-string, open-output-string, +get-output-string. + +** New module (srfi srfi-8): + +This module exports receive. + +** New module (srfi srfi-2): + +This module exports and-let*. + ** New module (ice-9 stack-catch): stack-catch is like catch, but saves the current state of the stack in From 69dab98bdbc7a134aa83a7fa0a713286300d5107 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 26 Apr 2001 20:22:28 +0000 Subject: [PATCH 0887/2047] * srfi-11.scm: new file - exports let-values and let*-values. --- srfi/srfi-11.scm | 215 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 215 insertions(+) create mode 100644 srfi/srfi-11.scm diff --git a/srfi/srfi-11.scm b/srfi/srfi-11.scm new file mode 100644 index 000000000..e4910ac87 --- /dev/null +++ b/srfi/srfi-11.scm @@ -0,0 +1,215 @@ +;;;; srfi-11.scm --- SRFI-11 procedures for Guile + +;;; Copyright (C) 2000 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;; Boston, MA 02111-1307 USA + +(define-module (srfi srfi-11) + :use-module (ice-9 syncase)) + +;;;;;;;;;;;;;; +;; let-values +;; +;; Current approach is to translate +;; +;; (let-values (((x y z) (foo a b)) +;; ((p q) (bar c))) +;; (baz x y z p q)) +;; +;; into +;; +;; (call-with-values (lambda () (foo a b)) +;; (lambda ( ) +;; (call-with-values (lambda () (bar c)) +;; (lambda ( ) +;; (let ((x ) +;; (y ) +;; (z ) +;; (p ) +;; (q )) +;; (baz x y z p q)))))) + +;; I originally wrote this as a define-macro, but then I found out +;; that guile's gensym/gentemp was broken, so I tried rewriting it as +;; a syntax-rules statement. +;; +;; Since syntax-rules didn't seem powerful enough to implement +;; let-values in one definition without exposing illegal syntax (or +;; perhaps my brain's just not powerful enough :>). I tried writing +;; it using a private helper, but that didn't work because the +;; let-values expands outside the scope of this module. I wonder why +;; syntax-rules wasn't designed to allow "private" patterns or +;; similar... +;; +;; So in the end, I dumped the syntax-rules implementation, reproduced +;; here for posterity, and went with the define-macro one below -- +;; gensym/gentemp's got to be fixed anyhow... +; +; (define-syntax let-values-helper +; (syntax-rules () +; ;; Take the vars from one let binding (i.e. the (x y z) from ((x y +; ;; z) (values 1 2 3)) and turn it in to the corresponding (lambda +; ;; ( ) ...) from above, keeping track of the +; ;; temps you create so you can use them later... +; ;; +; ;; I really don't fully understand why the (var-1 var-1) trick +; ;; works below, but basically, when all those (x x) bindings show +; ;; up in the final "let", syntax-rules forces a renaming. + +; ((_ "consumer" () lambda-tmps final-let-bindings lv-bindings +; body ...) +; (lambda lambda-tmps +; (let-values-helper "cwv" lv-bindings final-let-bindings body ...))) + +; ((_ "consumer" (var-1 var-2 ...) (lambda-tmp ...) final-let-bindings lv-bindings +; body ...) +; (let-values-helper "consumer" +; (var-2 ...) +; (lambda-tmp ... var-1) +; ((var-1 var-1) . final-let-bindings) +; lv-bindings +; body ...)) + +; ((_ "cwv" () final-let-bindings body ...) +; (let final-let-bindings +; body ...)) + +; ((_ "cwv" ((vars-1 binding-1) other-bindings ...) final-let-bindings +; body ...) +; (call-with-values (lambda () binding-1) +; (let-values-helper "consumer" +; vars-1 +; () +; final-let-bindings +; (other-bindings ...) +; body ...))))) +; +; (define-syntax let-values +; (syntax-rules () +; ((let-values () body ...) +; (begin body ...)) +; ((let-values (binding ...) body ...) +; (let-values-helper "cwv" (binding ...) () body ...)))) +; +; +; (define-syntax let-values +; (letrec-syntax ((build-consumer +; ;; Take the vars from one let binding (i.e. the (x +; ;; y z) from ((x y z) (values 1 2 3)) and turn it +; ;; in to the corresponding (lambda ( +; ;; ) ...) from above. +; (syntax-rules () +; ((_ () new-tmps tmp-vars () body ...) +; (lambda new-tmps +; body ...)) +; ((_ () new-tmps tmp-vars vars body ...) +; (lambda new-tmps +; (lv-builder vars tmp-vars body ...))) +; ((_ (var-1 var-2 ...) new-tmps tmp-vars vars body ...) +; (build-consumer (var-2 ...) +; (tmp-1 . new-tmps) +; ((var-1 tmp-1) . tmp-vars) +; bindings +; body ...)))) +; (lv-builder +; (syntax-rules () +; ((_ () tmp-vars body ...) +; (let tmp-vars +; body ...)) +; ((_ ((vars-1 binding-1) (vars-2 binding-2) ...) +; tmp-vars +; body ...) +; (call-with-values (lambda () binding-1) +; (build-consumer vars-1 +; () +; tmp-vars +; ((vars-2 binding-2) ...) +; body ...)))))) +; +; (syntax-rules () +; ((_ () body ...) +; (begin body ...)) +; ((_ ((vars binding) ...) body ...) +; (lv-builder ((vars binding) ...) () body ...))))) + +;; FIXME: This is currently somewhat unsafe (b/c gentemp/gensym is +;; broken -- right now (as of 1.4.1, it doesn't generate unique +;; symbols) +(define-macro (let-values vars . body) + (define (let-values-helper vars body prev-tmps) + (let* ((var-binding (car vars)) + (new-tmps (map (lambda (sym) (list sym (gentemp))) + (car var-binding))) + (tmps (append new-tmps prev-tmps))) + (if (null? (cdr vars)) + `(call-with-values (lambda () ,(cadr var-binding)) + (lambda ,(map cadr new-tmps) + (let ,tmps + ,@body))) + `(call-with-values (lambda () ,(cadr var-binding)) + (lambda ,(map cadr new-tmps) + ,(let-values-helper (cdr vars) body tmps)))))) + + (if (null? vars) + `(begin ,@body) + (let-values-helper vars body '()))) + +;;;;;;;;;;;;;; +;; let*-values +;; +;; Current approach is to translate +;; +;; (let*-values (((x y z) (foo a b)) +;; ((p q) (bar c))) +;; (baz x y z p q)) +;; +;; into +;; +;; (call-with-values (lambda () (foo a b)) +;; (lambda (x y z) +;; (call-with-values (lambda (bar c)) +;; (lambda (p q) +;; (baz x y z p q))))) + +(define-syntax let*-values + (syntax-rules () + ((let*-values () body ...) + (begin body ...)) + ((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...) + (call-with-values (lambda () binding-1) + (lambda vars-1 + (let*-values ((vars-2 binding-2) ...) + body ...)))))) + +; Alternate define-macro implementation... +; +; (define-macro (let*-values vars . body) +; (define (let-values-helper vars body) +; (let ((var-binding (car vars))) +; (if (null? (cdr vars)) +; `(call-with-values (lambda () ,(cadr var-binding)) +; (lambda ,(car var-binding) +; ,@body)) +; `(call-with-values (lambda () ,(cadr var-binding)) +; (lambda ,(car var-binding) +; ,(let-values-helper (cdr vars) body)))))) + +; (if (null? vars) +; `(begin ,@body) +; (let-values-helper vars body))) + +(export-syntax let-values + let*-values) From 3bd84b2d521cf449d890f3fb420b91d8483e5b24 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 26 Apr 2001 20:22:58 +0000 Subject: [PATCH 0888/2047] * srfi-2.scm: new file - just use/export (ice-9 and-let-star) --- srfi/srfi-2.scm | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) create mode 100644 srfi/srfi-2.scm diff --git a/srfi/srfi-2.scm b/srfi/srfi-2.scm new file mode 100644 index 000000000..aaedf97fa --- /dev/null +++ b/srfi/srfi-2.scm @@ -0,0 +1,23 @@ +;;;; srfi-2.scm --- SRFI-2 procedures for Guile +;;;; +;;;; Copyright (C) 2001 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +(define-module (srfi srfi-2) + :use-module (ice-9 and-let-star)) + +(export-syntax and-let*) From cc790d32f71fcd98dcc2b3a653f2ba0affe753ca Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 26 Apr 2001 20:23:19 +0000 Subject: [PATCH 0889/2047] * srfi-6.scm: new file - guile already has srfi-6 procedures loaded by default, so this is a dummy file right now. --- srfi/srfi-6.scm | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) create mode 100644 srfi/srfi-6.scm diff --git a/srfi/srfi-6.scm b/srfi/srfi-6.scm new file mode 100644 index 000000000..97e54cb22 --- /dev/null +++ b/srfi/srfi-6.scm @@ -0,0 +1,23 @@ +;;;; srfi-6.scm --- SRFI-6 procedures for Guile +;;;; +;;;; Copyright (C) 2001 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +(define-module (srfi srfi-6)) + +;; Currently, guile provides these functions by default, so no action +;; is needed, and this file is just a placeholder. From 818b6dda19a8ad3825c640c32192f31f7951f5ad Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 26 Apr 2001 20:23:39 +0000 Subject: [PATCH 0890/2047] * srfi-8.scm: new file - exports receive. --- srfi/srfi-8.scm | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) create mode 100644 srfi/srfi-8.scm diff --git a/srfi/srfi-8.scm b/srfi/srfi-8.scm new file mode 100644 index 000000000..e9e97a217 --- /dev/null +++ b/srfi/srfi-8.scm @@ -0,0 +1,23 @@ +;;;; srfi-8.scm --- SRFI-8 procedures for Guile + +;;; Copyright (C) 2000 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;; Boston, MA 02111-1307 USA + +(define-module (srfi srfi-8) + :use-module (ice-9 receive)) + +(export-syntax receive) From b9c6d7a5dc33c703fc5ff31a1daf2d3c9a976779 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 26 Apr 2001 20:24:15 +0000 Subject: [PATCH 0891/2047] *** empty log message *** --- srfi/ChangeLog | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index ac85c2fdf..04dcf8567 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,19 @@ +2001-04-26 Rob Browning + + * Makefile.am (srfi_DATA): added srfi-6.scm. + (srfi_DATA): added srfi-11.scm. + (srfi_DATA): added srfi-8.scm. + (srfi_DATA): added srfi-2.scm. + + * srfi-11.scm: new file - exports let-values and let*-values. + + * srfi-6.scm: new file - guile already has srfi-6 procedures + loaded by default, so this is a dummy file right now. + + * srfi-8.scm: new file - exports receive. + + * srfi-2.scm: new file - just use/export (ice-9 and-let-star) + 2001-04-26 Martin Grabmueller Changed two procedure names to match final SRFI document. Thanks From 95f1d86163f8d678256576c33cab6e959cc0aeea Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 26 Apr 2001 20:24:38 +0000 Subject: [PATCH 0892/2047] * Makefile.am (srfi_DATA): added srfi-6.scm. (srfi_DATA): added srfi-11.scm. (srfi_DATA): added srfi-8.scm. (srfi_DATA): added srfi-2.scm. --- srfi/Makefile.am | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/srfi/Makefile.am b/srfi/Makefile.am index 6a211b978..804c2f882 100644 --- a/srfi/Makefile.am +++ b/srfi/Makefile.am @@ -39,7 +39,12 @@ libguile_srfi_srfi_13_14_la_SOURCES = srfi-13.x srfi-13.c srfi-14.x srfi-14.c\ libguile_srfi_srfi_13_14_la_LDFLAGS = -version-info 0:0 -export-dynamic srfidir = $(datadir)/guile/$(VERSION)/srfi -srfi_DATA = srfi-13.scm srfi-14.scm +srfi_DATA = srfi-2.scm \ + srfi-6.scm \ + srfi-8.scm \ + srfi-11.scm \ + srfi-13.scm \ + srfi-14.scm EXTRA_DIST = $(srfi_DATA) From 714d71cc34c0a4a2c72017ed6cb8007d1555ab87 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Fri, 27 Apr 2001 03:45:18 +0000 Subject: [PATCH 0893/2047] * srfi-8.scm: removed in favor of srfi/srfi-8.scm - (wasn't ever in a production release). --- ice-9/srfi-8.scm | 0 1 file changed, 0 insertions(+), 0 deletions(-) delete mode 100644 ice-9/srfi-8.scm diff --git a/ice-9/srfi-8.scm b/ice-9/srfi-8.scm deleted file mode 100644 index e69de29bb..000000000 From 89448795f0569381e80a688a4ac4bdb2f1902a98 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Fri, 27 Apr 2001 03:45:40 +0000 Subject: [PATCH 0894/2047] *** empty log message *** --- ice-9/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index ebbacd627..f55a63502 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2001-04-26 Rob Browning + + * srfi-8.scm: removed in favor of srfi/srfi-8.scm - (wasn't ever + in a production release). + 2001-04-25 Keisuke Nishida * channel.scm: New file. From 7a6a68b1053e47d81b0ff7f5752c7f058598b665 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 27 Apr 2001 05:46:24 +0000 Subject: [PATCH 0895/2047] * Makefile.am (ice9_sources): Remove srfi-8.scm. --- ice-9/ChangeLog | 4 ++++ ice-9/Makefile.am | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index f55a63502..b87a5dc34 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2001-04-27 Martin Grabmueller + + * Makefile.am (ice9_sources): Remove srfi-8.scm. + 2001-04-26 Rob Browning * srfi-8.scm: removed in favor of srfi/srfi-8.scm - (wasn't ever diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index 240159059..14c2594cc 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -28,7 +28,7 @@ ice9_sources = \ format.scm getopt-long.scm hcons.scm lineio.scm ls.scm mapping.scm \ match.scm networking.scm null.scm optargs.scm poe.scm popen.scm \ posix.scm psyntax.pp psyntax.ss q.scm r4rs.scm r5rs.scm \ - rdelim.scm receive.scm srfi-8.scm regex.scm runq.scm \ + rdelim.scm receive.scm regex.scm runq.scm \ safe-r5rs.scm safe.scm session.scm slib.scm stack-catch.scm \ streams.scm string-fun.scm syncase.scm tags.scm threads.scm \ buffered-input.scm time.scm history.scm channel.scm From a6fd89a4975cde56bf42c452257dc0070b4525d5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 27 Apr 2001 05:47:58 +0000 Subject: [PATCH 0896/2047] * Makefile.am (srfi_DATA): Added srfi-9.scm. * srfi-9.scm: New file. Exports `define-record-type'. --- srfi/ChangeLog | 6 ++++ srfi/Makefile.am | 1 + srfi/srfi-9.scm | 85 ++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 92 insertions(+) create mode 100644 srfi/srfi-9.scm diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 04dcf8567..8e2c0b759 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,9 @@ +2001-04-27 Martin Grabmueller + + * Makefile.am (srfi_DATA): Added srfi-9.scm. + + * srfi-9.scm: New file. Exports `define-record-type'. + 2001-04-26 Rob Browning * Makefile.am (srfi_DATA): added srfi-6.scm. diff --git a/srfi/Makefile.am b/srfi/Makefile.am index 804c2f882..5eb8eb9cc 100644 --- a/srfi/Makefile.am +++ b/srfi/Makefile.am @@ -42,6 +42,7 @@ srfidir = $(datadir)/guile/$(VERSION)/srfi srfi_DATA = srfi-2.scm \ srfi-6.scm \ srfi-8.scm \ + srfi-9.scm \ srfi-11.scm \ srfi-13.scm \ srfi-14.scm diff --git a/srfi/srfi-9.scm b/srfi/srfi-9.scm new file mode 100644 index 000000000..fb61dfec0 --- /dev/null +++ b/srfi/srfi-9.scm @@ -0,0 +1,85 @@ +;;;; srfi-9.scm --- SRFI-9 procedures for Guile +;;;; +;;;; Copyright (C) 2001 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +;;; This module exports the syntactic form `define-record-type', which +;;; is the means for creating record types defined in SRFI-9. +;;; +;;; The syntax of a record type definition is: +;;; +;;; +;;; -> (define-record-type +;;; ( ...) +;;; +;;; ...) +;;; +;;; -> ( ) +;;; -> ( ) +;;; +;;; -> +;;; <... name> -> +;;; +;;; Usage example: +;;; +;;; guile> (use-modules (srfi srfi-9)) +;;; guile> (define-record-type :foo (make-foo x) foo? +;;; (x get-x) (y get-y set-y!)) +;;; guile> (define f (make-foo 1)) +;;; guile> f +;;; #<:foo x: 1 y: #f> +;;; guile> (get-x f) +;;; 1 +;;; guile> (set-y! f 2) +;;; 2 +;;; guile> (get-y f) +;;; 2 +;;; guile> f +;;; #<:foo x: 1 y: 2> +;;; guile> (foo? f) +;;; #t +;;; guile> (foo? 1) +;;; #f + +(define-module (srfi srfi-9)) + +(export-syntax define-record-type) + +(define-macro (define-record-type type-name constructor/field-tag + predicate-name . field-specs) + `(begin + (define ,type-name + (make-record-type ',type-name ',(map car field-specs))) + (define ,(car constructor/field-tag) + (record-constructor ,type-name ',(cdr constructor/field-tag))) + (define ,predicate-name + (record-predicate ,type-name)) + ,@(map + (lambda (spec) + (cond + ((= (length spec) 2) + `(define ,(cadr spec) + (record-accessor ,type-name ',(car spec)))) + ((= (length spec) 3) + `(begin + (define ,(cadr spec) + (record-accessor ,type-name ',(car spec))) + (define ,(caddr spec) + (record-modifier ,type-name ',(car spec))))) + (else + (error "invalid field spec " spec)))) + field-specs))) From 4df36934c9541e2fd5e99d5cf86ef6340cd4f838 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 27 Apr 2001 05:52:31 +0000 Subject: [PATCH 0897/2047] Some updates reflecting the latest SRFI-13/14/9 changes. --- AUTHORS | 8 ++++++++ NEWS | 12 ++++++++++++ 2 files changed, 20 insertions(+) diff --git a/AUTHORS b/AUTHORS index b5e270857..9f323c6a9 100644 --- a/AUTHORS +++ b/AUTHORS @@ -98,3 +98,11 @@ In the subdirectory srfi, wrote the initial files for: srfi-6.scm srfi-8.scm srfi-11.scm + +Martin Grabmueller: +In the subdirectory srfi, wrote: + srfi-9.scm + srfi-13.scm + srfi-14.scm + srfi-13.c + srfi-14.c diff --git a/NEWS b/NEWS index 0430c5b97..07bee12f5 100644 --- a/NEWS +++ b/NEWS @@ -8,6 +8,18 @@ Changes since Guile 1.4: * Changes to the distribution +** New module (srfi srfi-13) + +Implements SRFI-13 (string library). + +** New module (srfi srfi-14) + +Implements SRFI-14 (character-set library). + +** New module (srfi srfi-9) + +This module exports define-record-type. + ** New module (srfi srfi-11): This module exports let-values and let*-values. From c3e6287764a6840afd1046a7163507e553e960d9 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 27 Apr 2001 07:52:23 +0000 Subject: [PATCH 0898/2047] * Update NEWS for removal of R4RS from distro. --- NEWS | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index 07bee12f5..0d7d280e7 100644 --- a/NEWS +++ b/NEWS @@ -174,8 +174,8 @@ manuals. reference documentation for using GOOPS, Guile's Object Oriented Programming System. -- The Revised^4 and Revised^5 Reports on the Algorithmic Language - Scheme (r4rs.texi and r5rs.texi). +- The Revised^5 Report on the Algorithmic Language Scheme + (r5rs.texi). See the README file in the `doc' directory for more details. From 7adc2c58b0a78364e2bab08c9e55f8ba7e016405 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Fri, 27 Apr 2001 16:56:01 +0000 Subject: [PATCH 0899/2047] *** empty log message *** --- NEWS | 32 ++++++++++---------------------- 1 file changed, 10 insertions(+), 22 deletions(-) diff --git a/NEWS b/NEWS index 0d7d280e7..62455bc8e 100644 --- a/NEWS +++ b/NEWS @@ -8,35 +8,23 @@ Changes since Guile 1.4: * Changes to the distribution -** New module (srfi srfi-13) +** New SRFI modules: -Implements SRFI-13 (string library). +(srfi srfi-2) exports and-let*. -** New module (srfi srfi-14) +(srfi srfi-6) is a dummy module for now, since guile already provides + all of the srfi-6 procedures by default: open-input-string, + open-output-string, get-output-string. -Implements SRFI-14 (character-set library). +(srfi srfi-8) exports receive. -** New module (srfi srfi-9) +(srfi srfi-9) exports define-record-type. -This module exports define-record-type. +(srfi srfi-11) exports let-values and let*-values. -** New module (srfi srfi-11): +(srfi srfi-13) implements the SRFI String Library. -This module exports let-values and let*-values. - -** New module (srfi srfi-6): - -This is a dummy file for now, since guile already provides all of the -srfi-6 procedures by default: open-input-string, open-output-string, -get-output-string. - -** New module (srfi srfi-8): - -This module exports receive. - -** New module (srfi srfi-2): - -This module exports and-let*. +(srfi srfi-14) implements the SRFI Character-Set Library. ** New module (ice-9 stack-catch): From b2da8b1068dc5c5baac623b5f160b1bdc11cf31d Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Fri, 27 Apr 2001 16:59:12 +0000 Subject: [PATCH 0900/2047] *** empty log message *** --- NEWS | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index 62455bc8e..565ccd583 100644 --- a/NEWS +++ b/NEWS @@ -29,8 +29,8 @@ Changes since Guile 1.4: ** New module (ice-9 stack-catch): stack-catch is like catch, but saves the current state of the stack in -the the-last-stack fluid for the debugger to inspect or in able to -re-throw an error. +the the-last-stack fluid. This fluid can be useful during debugger +inspection or when re-throwing an error. ** The module (ice-9 and-let*) has been renamed to (ice-9 and-let-star) From 3c1d130162ecc3954453a1c4d05f83747316c6cf Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Fri, 27 Apr 2001 17:00:20 +0000 Subject: [PATCH 0901/2047] *** empty log message *** --- NEWS | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index 565ccd583..5386d4db3 100644 --- a/NEWS +++ b/NEWS @@ -29,8 +29,8 @@ Changes since Guile 1.4: ** New module (ice-9 stack-catch): stack-catch is like catch, but saves the current state of the stack in -the the-last-stack fluid. This fluid can be useful during debugger -inspection or when re-throwing an error. +the fluid the-last-stack. This fluid can be useful when using the +debugger and when re-throwing an error. ** The module (ice-9 and-let*) has been renamed to (ice-9 and-let-star) From 485efc12b7884c1657dcbd4632d0957f80d32fce Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Fri, 27 Apr 2001 18:16:09 +0000 Subject: [PATCH 0902/2047] * srfi-13.c (scm_init_srfi_13), srfi-14.c (scm_init_srfi_14): add "srfi/" to lines including .x files so they can be found when build_dir != src_dir. --- srfi/ChangeLog | 6 ++++++ srfi/srfi-13.c | 2 +- srfi/srfi-14.c | 2 +- 3 files changed, 8 insertions(+), 2 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 8e2c0b759..651b7e867 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,9 @@ +2001-04-27 Gary Houston + + * srfi-13.c (scm_init_srfi_13), srfi-14.c (scm_init_srfi_14): + add "srfi/" to lines including .x files so they can be found + when build_dir != src_dir. + 2001-04-27 Martin Grabmueller * Makefile.am (srfi_DATA): Added srfi-9.scm. diff --git a/srfi/srfi-13.c b/srfi/srfi-13.c index 800677315..b50ef085c 100644 --- a/srfi/srfi-13.c +++ b/srfi/srfi-13.c @@ -3027,7 +3027,7 @@ void scm_init_srfi_13 (void) { #ifndef SCM_MAGIC_SNARFER -#include "srfi-13.x" +#include "srfi/srfi-13.x" #endif } diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index 3cbf63c6e..3755608ca 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -1356,6 +1356,6 @@ scm_init_srfi_14 (void) scm_set_smob_print (scm_tc16_charset, charset_print); #ifndef SCM_MAGIC_SNARFER -#include "srfi-14.x" +#include "srfi/srfi-14.x" #endif } From 9351e1b5e37c6f68c05944a5f74f982f7eebda9b Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Fri, 27 Apr 2001 21:03:50 +0000 Subject: [PATCH 0903/2047] * GUILE-VERSION (GUILE_MINOR_VERSION): change to 5.0, switching to the new odd/even ustable/stable version numbering scheme. (LIBGUILEQTHREADS_MAJOR_VERSION): change to 10 to match Debian and libguile. In the future, libguile and libguileqthreads may not stay in sync. This still doesn't appear to affect libguileqthreads, but we'll fix that next. --- GUILE-VERSION | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/GUILE-VERSION b/GUILE-VERSION index 1058c0aca..99ea5cf97 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -1,5 +1,5 @@ GUILE_MAJOR_VERSION=1 -GUILE_MINOR_VERSION=4.1 +GUILE_MINOR_VERSION=5.0 GUILE_VERSION=${GUILE_MAJOR_VERSION}.${GUILE_MINOR_VERSION} # For automake. @@ -13,7 +13,7 @@ LIBGUILE_REVISION_VERSION=0 LIBGUILE_VERSION=${LIBGUILE_MAJOR_VERSION}.${LIBGUILE_MINOR_VERSION}.${LIBGUILE_REVISION_VERSION} # libguileqthreads.so versioning info -LIBGUILEQTHREADS_MAJOR_VERSION=0 +LIBGUILEQTHREADS_MAJOR_VERSION=10 LIBGUILEQTHREADS_MINOR_VERSION=0 LIBGUILEQTHREADS_REVISION_VERSION=0 LIBGUILEQTHREADS_VERSION=${LIBGUILEQTHREADS_MAJOR_VERSION}.${LIBGUILEQTHREADS_MINOR_VERSION}.${LIBGUILEQTHREADS_REVISION_VERSION} From f2a75d811b8b1b3af536214ef03a08484146b8f5 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Fri, 27 Apr 2001 21:05:11 +0000 Subject: [PATCH 0904/2047] *** empty log message *** --- ChangeLog | 9 +++++++++ NEWS | 20 ++++++++++++++------ README | 18 ++++++++++++------ RELEASE | 11 +++-------- 4 files changed, 38 insertions(+), 20 deletions(-) diff --git a/ChangeLog b/ChangeLog index 8ea454c98..f979331be 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +2001-04-27 Rob Browning + + * GUILE-VERSION (GUILE_MINOR_VERSION): change to 5.0, switching to + the new odd/even ustable/stable version numbering scheme. + (LIBGUILEQTHREADS_MAJOR_VERSION): change to 10 to match Debian and + libguile. In the future, libguile and libguileqthreads may not + stay in sync. This still doesn't appear to affect + libguileqthreads, but we'll fix that next. + 2001-04-25 Martin Grabmueller * configure.in: Don't treat srfi directory specially, just create diff --git a/NEWS b/NEWS index 5386d4db3..26391dbce 100644 --- a/NEWS +++ b/NEWS @@ -8,7 +8,20 @@ Changes since Guile 1.4: * Changes to the distribution -** New SRFI modules: +** As per RELEASE directions, deprecated items have been removed + +*** Macros removed + + SCM_INPORTP, SCM_OUTPORTP SCM_ICHRP, SCM_ICHR, SCM_MAKICHR + SCM_SETJMPBUF SCM_NSTRINGP SCM_NRWSTRINGP SCM_NVECTORP + +*** Functions removed + + scm_sysmissing + + gc-thunk - replaced by after-gc-hook. + +** New SRFI modules have been added: (srfi srfi-2) exports and-let*. @@ -985,11 +998,6 @@ an exception with a key of 'unbound-variable instead of 'misc-error. ** The initial default output port is now unbuffered if it's using a tty device. Previously in this situation it was line-buffered. -** gc-thunk is deprecated - -gc-thunk will be removed in next release of Guile. It has been -replaced by after-gc-hook. - ** New hook: after-gc-hook after-gc-hook takes over the role of gc-thunk. This hook is run at diff --git a/README b/README index 85c290797..0598f6ef3 100644 --- a/README +++ b/README @@ -2,11 +2,18 @@ This is not a Guile release; it is a source tree retrieved via anonymous CVS or as a nightly snapshot at some random time after the Guile 1.4 release. -This is version 1.4.1 of Guile, Project GNU's extension language -library. Guile is an interpreter for Scheme, packaged as a library -that you can link into your applications to give them their own -scripting language. Guile will eventually support other languages as -well, giving users of Guile-based applications a choice of languages. +This is a 1.5 development version of Guile, Project GNU's extension +language library. Guile is an interpreter for Scheme, packaged as a +library that you can link into your applications to give them their +own scripting language. Guile will eventually support other languages +as well, giving users of Guile-based applications a choice of +languages. + +Guile versions with an odd middle number, i.e. 1.5.* are unstable +development versions. Even middle numbers indicate stable versions. +This has been the case since the 1.3.* series. + +The next stable release will be version 1.6.0. Please send bug reports to bug-guile@gnu.org. @@ -174,4 +181,3 @@ The mailing list `guile-user@gnu.org' carries discussions, questions, and often answers, about Guile. To subscribe, use the Mailman mailing list interface at Of course, please send bug reports (and fixes!) to bug-guile@gnu.org. - diff --git a/RELEASE b/RELEASE index d49ea0942..1c7b0f969 100644 --- a/RELEASE +++ b/RELEASE @@ -9,7 +9,7 @@ for." * Remove compatability module (ice-9 and-let*) eventually (when a major release with the real module (ice-9 and-let-star) has been out - long enough, probably release 1.6). + long enough, probably release 1.8). * Deprecate `read-only-string?'. @@ -17,12 +17,7 @@ After signal handling and threading have been fixed: - remove the code corresponding to GUILE_OLD_ASYNC_CLICK and the corresponding GUILE_OLD_ASYNC_CLICK macro. -In release 1.5: -- remove deprecated macros: SCM_INPORTP, SCM_OUTPORTP, SCM_CRDY, SCM_ICHRP, - SCM_ICHR, SCM_MAKICHR, SCM_SETJMPBUF, SCM_NSTRINGP, SCM_NRWSTRINGP, - SCM_NVECTORP -- remove gc-thunk (It has been replaced by after-gc-hook.) -- remove scm_sysmissing +In release 1.6.0: - remove gh_int2scmb (replaced by gh_bool2scm) - remove scm_fseek (replaced by scm_seek) - remove scm_tag @@ -39,7 +34,7 @@ In release 1.5: SCM_REALPART, scm_makdbl, SCM_SINGP, SCM_NUM2DBL, SCM_NO_BIGDIG - remove deprecated macro from tags.h: SCM_DOUBLE_CELLP -In release 1.6: +In release 1.8.0: - remove support for autoloading compiled-code modules: try-module-linked try-module-dynamic-link From 2e5b312b80f55a7ca49c0b7ed79195558e3fa7e6 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Fri, 27 Apr 2001 21:07:56 +0000 Subject: [PATCH 0905/2047] * continuations.h (SCM_SETJMPBUF): deprecation expired - removed. --- libguile/continuations.h | 8 -------- 1 file changed, 8 deletions(-) diff --git a/libguile/continuations.h b/libguile/continuations.h index adc962976..85029fb23 100644 --- a/libguile/continuations.h +++ b/libguile/continuations.h @@ -93,14 +93,6 @@ typedef struct extern SCM scm_make_continuation (int *first); extern void scm_init_continuations (void); - - -#if (SCM_DEBUG_DEPRECATED == 0) - -#define SCM_SETJMPBUF(x, r) (SCM_SET_CONTREGS ((x), (r))) - -#endif /* SCM_DEBUG_DEPRECATED == 0 */ - #endif /* CONTINUATIONSH */ /* From 3a2ad295bc18d4693950734050c61b375d0454bb Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Fri, 27 Apr 2001 21:08:25 +0000 Subject: [PATCH 0906/2047] * error.c (scm_sysmissing): deprecation expired - removed. --- libguile/error.c | 27 --------------------------- 1 file changed, 27 deletions(-) diff --git a/libguile/error.c b/libguile/error.c index d8fcc7aa8..88ba47c7d 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -184,33 +184,6 @@ scm_syserror_msg (const char *subr, const char *message, SCM args, int eno) scm_cons (SCM_MAKINUM (eno), SCM_EOL)); } - -#if (SCM_DEBUG_DEPRECATED == 0) - -/* scm_sysmissing is no longer used in libguile. it can probably be - removed after a release or two. there's a comment in NEWS about it - (2000-01-09). */ -void -scm_sysmissing (const char *subr) -{ -#ifdef ENOSYS - scm_error (scm_system_error_key, - subr, - "~A", - scm_cons (scm_makfrom0str (strerror (ENOSYS)), SCM_EOL), - scm_cons (SCM_MAKINUM (ENOSYS), SCM_EOL)); -#else - scm_error (scm_system_error_key, - subr, - "Missing function", - SCM_BOOL_F, - scm_cons (SCM_MAKINUM (0), SCM_EOL)); -#endif -} - -#endif /* SCM_DEBUG_DEPRECATED == 0 */ - - SCM_SYMBOL (scm_num_overflow_key, "numerical-overflow"); void scm_num_overflow (const char *subr) From 8a7fb63c90b94738d9797080409dcb078fa3e8f7 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Fri, 27 Apr 2001 21:08:44 +0000 Subject: [PATCH 0907/2047] * error.h (scm_sysmissing): deprecation expired - removed. --- libguile/chars.h | 10 ---------- libguile/error.h | 1 - 2 files changed, 11 deletions(-) diff --git a/libguile/chars.h b/libguile/chars.h index 74b57866a..7339f0255 100644 --- a/libguile/chars.h +++ b/libguile/chars.h @@ -87,16 +87,6 @@ extern int scm_upcase (unsigned int c); extern int scm_downcase (unsigned int c); extern void scm_init_chars (void); - - -#if (SCM_DEBUG_DEPRECATED == 0) - -#define SCM_ICHRP(x) SCM_CHARP(x) -#define SCM_ICHR(x) SCM_CHAR(x) -#define SCM_MAKICHR(x) SCM_MAKE_CHAR(x) - -#endif /* SCM_DEBUG_DEPRECATED == 0 */ - #endif /* SCM_CHARSH */ /* diff --git a/libguile/error.h b/libguile/error.h index ea7d8d2fc..cfdc604a1 100644 --- a/libguile/error.h +++ b/libguile/error.h @@ -87,7 +87,6 @@ extern void scm_init_error (void); #if (SCM_DEBUG_DEPRECATED == 0) -extern void scm_sysmissing (const char *subr) SCM_NORETURN; extern SCM scm_wta (SCM arg, const char *pos, const char *s_subr); #endif /* SCM_DEBUG_DEPRECATED == 0 */ From 2baa64142b65f17570fb6bb784a1ee05734c5bbe Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Fri, 27 Apr 2001 21:09:02 +0000 Subject: [PATCH 0908/2047] * gc.c (scm_init_gc): gc-thunk deprecation expired - removed. (scm_gc_vcell): deprecation expired - removed. (gc_async_thunk): scm_gc_vcell related code removed. --- libguile/gc.c | 21 --------------------- 1 file changed, 21 deletions(-) diff --git a/libguile/gc.c b/libguile/gc.c index 88361246c..cef92aca9 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -2663,12 +2663,8 @@ scm_init_storage () SCM scm_after_gc_hook; -#if (SCM_DEBUG_DEPRECATED == 0) -static SCM scm_gc_vcell; /* the vcell for gc-thunk. */ -#endif /* SCM_DEBUG_DEPRECATED == 0 */ static SCM gc_async; - /* The function gc_async_thunk causes the execution of the after-gc-hook. It * is run after the gc, as soon as the asynchronous events are handled by the * evaluator. @@ -2677,20 +2673,6 @@ static SCM gc_async_thunk (void) { scm_c_run_hook (scm_after_gc_hook, SCM_EOL); - -#if (SCM_DEBUG_DEPRECATED == 0) - - /* The following code will be removed in Guile 1.5. */ - if (SCM_NFALSEP (scm_gc_vcell)) - { - SCM proc = SCM_CDR (scm_gc_vcell); - - if (SCM_NFALSEP (proc) && !SCM_UNBNDP (proc)) - scm_apply (proc, SCM_EOL, SCM_EOL); - } - -#endif /* SCM_DEBUG_DEPRECATED == 0 */ - return SCM_UNSPECIFIED; } @@ -2719,9 +2701,6 @@ scm_init_gc () scm_after_gc_hook = scm_create_hook ("after-gc-hook", 0); -#if (SCM_DEBUG_DEPRECATED == 0) - scm_gc_vcell = scm_sysintern ("gc-thunk", SCM_BOOL_F); -#endif /* SCM_DEBUG_DEPRECATED == 0 */ after_gc_thunk = scm_make_subr_opt ("%gc-thunk", scm_tc7_subr_0, gc_async_thunk, 0); gc_async = scm_system_async (after_gc_thunk); /* protected via scm_asyncs */ From 4c2fb0c583ed8774351271c4ce1b7537263200ac Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Fri, 27 Apr 2001 21:09:19 +0000 Subject: [PATCH 0909/2047] * ports.h (SCM_INPORTP): deprecation expired - removed. (SCM_OUTPORTP): deprecation expired - removed. --- libguile/ports.h | 4 ---- 1 file changed, 4 deletions(-) diff --git a/libguile/ports.h b/libguile/ports.h index c8c96aa5b..b37634f9b 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -318,10 +318,6 @@ extern SCM scm_pt_member (SCM member); #if (SCM_DEBUG_DEPRECATED == 0) -/* #define SCM_CRDY (32L<<16) obsolete, for pushed back characters */ -#define SCM_INPORTP(x) SCM_INPUT_PORT_P (x) -#define SCM_OUTPORTP(x) SCM_OUTPUT_PORT_P (x) - extern SCM scm_close_all_ports_except (SCM ports); #endif /* SCM_DEBUG_DEPRECATED == 0 */ From da3208a3f5a576f0efa950b84a1ea506daa4d463 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Fri, 27 Apr 2001 21:09:49 +0000 Subject: [PATCH 0910/2047] * strings.h (SCM_NSTRINGP): deprecation expired - removed. (SCM_NRWSTRINGP): deprecation expired - removed. --- libguile/strings.h | 2 -- 1 file changed, 2 deletions(-) diff --git a/libguile/strings.h b/libguile/strings.h index 76919d7c5..a96e8de55 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -90,9 +90,7 @@ extern void scm_init_strings (void); #if (SCM_DEBUG_DEPRECATED == 0) #define SCM_SLOPPY_STRINGP(x) (SCM_STRINGP(x)) -#define SCM_NSTRINGP(x) (!SCM_STRINGP(x)) #define SCM_RWSTRINGP(x) (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_string)) -#define SCM_NRWSTRINGP(x) (! SCM_RWSTRINGP (x)) #define SCM_STRING_UCHARS(x) \ ((SCM_TYP7 (x) == scm_tc7_substring) \ ? (unsigned char *) SCM_CELL_WORD_1 (SCM_CDDR (x)) + SCM_INUM (SCM_CADR (x)) \ From 96230533fa4ea8b2a21e9669641fce5f5c2d2d39 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Fri, 27 Apr 2001 21:10:11 +0000 Subject: [PATCH 0911/2047] * vectors.h (SCM_NVECTORP): deprecation expired - removed. --- libguile/vectors.h | 1 - 1 file changed, 1 deletion(-) diff --git a/libguile/vectors.h b/libguile/vectors.h index d479d1b80..77d6131bf 100644 --- a/libguile/vectors.h +++ b/libguile/vectors.h @@ -95,7 +95,6 @@ extern void scm_init_vectors (void); #if (SCM_DEBUG_DEPRECATED == 0) -#define SCM_NVECTORP(x) (!SCM_VECTORP (x)) extern SCM scm_vector_set_length_x (SCM vect, SCM len); #endif /* SCM_DEBUG_DEPRECATED == 0 */ From 53aef014daea18dc505b154cccbc018cb0b6ab9d Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Fri, 27 Apr 2001 21:10:46 +0000 Subject: [PATCH 0912/2047] * srfi-13.h (scm_reverse_string_concatenate): renamed to scm_string_concatentate_reverse. (scm_reverse_string_concatenate_shared): renamed to scm_string_concatenate_reverse_shared. --- srfi/srfi-13.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/srfi/srfi-13.h b/srfi/srfi-13.h index 525089d15..86c21a832 100644 --- a/srfi/srfi-13.h +++ b/srfi/srfi-13.h @@ -107,9 +107,9 @@ SCM scm_string_reverse (SCM str, SCM start, SCM end); SCM scm_string_reverse_x (SCM str, SCM start, SCM end); SCM scm_string_append_shared (SCM ls); SCM scm_string_concatenate (SCM ls); -SCM scm_reverse_string_concatenate (SCM ls, SCM final_string, SCM end); SCM scm_string_concatenate_shared (SCM ls); -SCM scm_reverse_string_concatenate_shared (SCM ls, SCM final_string, SCM end); +SCM scm_string_concatenate_reverse (SCM ls, SCM final_string, SCM end); +SCM scm_string_concatenate_reverse_shared (SCM ls, SCM final_string, SCM end); SCM scm_string_map (SCM s, SCM proc, SCM start, SCM end); SCM scm_string_map_x (SCM s, SCM proc, SCM start, SCM end); SCM scm_string_fold (SCM kons, SCM knil, SCM s, SCM start, SCM end); From a0f979acdb0902ad3a72f40625f42c028e84487f Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Fri, 27 Apr 2001 21:10:57 +0000 Subject: [PATCH 0913/2047] *** empty log message *** --- libguile/ChangeLog | 28 ++++++++++++++++++++++++++++ srfi/ChangeLog | 8 ++++++++ 2 files changed, 36 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 3f0afdd50..0cca30474 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,31 @@ +2001-04-27 Rob Browning + + * error.c (scm_sysmissing): deprecation expired - removed. + + * error.h (scm_sysmissing): deprecation expired - removed. + + * gc.c + (scm_init_gc): gc-thunk deprecation expired - removed. + (scm_gc_vcell): deprecation expired - removed. + (gc_async_thunk): scm_gc_vcell related code removed. + + * vectors.h (SCM_NVECTORP): deprecation expired - removed. + + * strings.h + (SCM_NSTRINGP): deprecation expired - removed. + (SCM_NRWSTRINGP): deprecation expired - removed. + + * continuations.h (SCM_SETJMPBUF): deprecation expired - removed. + + * chars.h + (SCM_ICHRP): deprecation expired - removed. + (SCM_ICHR): deprecation expired - removed. + (SCM_MAKICHR): deprecation expired - removed. + + * ports.h + (SCM_INPORTP): deprecation expired - removed. + (SCM_OUTPORTP): deprecation expired - removed. + 2001-04-25 Marius Vollmer * modules.c (scm_module_type): New. diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 651b7e867..6ae7274ff 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,11 @@ +2001-04-27 Rob Browning + + * srfi-13.h + (scm_reverse_string_concatenate): renamed to + scm_string_concatentate_reverse. + (scm_reverse_string_concatenate_shared): renamed to + scm_string_concatenate_reverse_shared. + 2001-04-27 Gary Houston * srfi-13.c (scm_init_srfi_13), srfi-14.c (scm_init_srfi_14): From 262098e092252c5e7ff70ab24f109c194c2002cd Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 28 Apr 2001 00:25:22 +0000 Subject: [PATCH 0914/2047] (time-proc): Use `identity' instead of deprecated `id'. --- ice-9/time.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ice-9/time.scm b/ice-9/time.scm index 828b2d5c1..72f2fba7a 100644 --- a/ice-9/time.scm +++ b/ice-9/time.scm @@ -36,7 +36,7 @@ (get tms:stime tms-start tms-end) (get tms:cutime tms-start tms-end) (get tms:cstime tms-start tms-end) - (get id gc-start gc-end)) + (get identity gc-start gc-end)) result)) (define-macro (time exp) From 70afc25b9f18eac0d6cab9d55e3fcd7e4d640cee Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 28 Apr 2001 00:28:58 +0000 Subject: [PATCH 0915/2047] Update copyright. Add commentary. Use `define-module' `:export' clause instead of `define-public'. Autoload (ice-9 regex) on `match:suffix'. (default-in-line-re, default-after-line-re): New vars. (default-scrub): New proc. (file-commentary): New proc, exported. (object-documentation): Expand docstring; nfc. --- ice-9/documentation.scm | 126 +++++++++++++++++++++++++++++++++++++--- 1 file changed, 117 insertions(+), 9 deletions(-) diff --git a/ice-9/documentation.scm b/ice-9/documentation.scm index 5ea3ecd84..fd5a9ad98 100644 --- a/ice-9/documentation.scm +++ b/ice-9/documentation.scm @@ -1,31 +1,135 @@ -;;;; Copyright (C) 2000 Free Software Foundation, Inc. -;;;; +;;;; Copyright (C) 2000,2001 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 ;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA -;;;; +;;;; + +;;; Commentary: + +;; * This module exports: +;; +;; file-commentary -- a procedure that returns a file's "commentary" +;; +;; documentation-files -- a search-list of files using the Guile +;; Documentation Format Version 2. +;; +;; object-documentation -- a procedure that returns its arg's docstring +;; +;; * Guile Documentation Format +;; +;; Here is the complete and authoritative documentation for the Guile +;; Documentation Format Version 2: +;; +;; HEADER +;; ^LPROC1 +;; DOCUMENTATION1 +;; ^LPROC2 +;; DOCUMENTATION2 +;; ... +;; +;; The HEADER is completely ignored. The "^L" are formfeeds. PROC1, PROC2 +;; and so on are symbols that name the element documented. DOCUMENTATION1, +;; DOCUMENTATION2 and so on are the related documentation, w/o any further +;; formatting. +;; +;; (Version 1, corresponding to guile-1.4 and prior, is documented as being +;; not documented anywhere except by this embarrassingly circular comment.) +;; +;; * File Commentary +;; +;; A file's commentary is the body of text found between comments +;; ;;; Commentary: +;; and +;; ;;; Code: +;; both of which must be at the beginning of the line. In the result string, +;; semicolons at the beginning of each line are discarded. +;; +;; You can specify to `file-commentary' alternate begin and end strings, and +;; scrub procedure. Use #t to get default values. For example: +;; +;; (file-commentary "documentation.scm") +;; You should see this text! +;; +;; (file-commentary "documentation.scm" "^;;; Code:" "ends here$") +;; You should see the rest of this file. +;; +;; (file-commentary "documentation.scm" #t #t string-upcase) +;; You should see this text very loudly (note semicolons untouched). + +;;; Code: (define-module (ice-9 documentation) :use-module (ice-9 rdelim) + :export (file-commentary documentation-files object-documentation) + :autoload (ice-9 regex) (match:suffix) :no-backtrace) + +;; +;; commentary extraction +;; +(define default-in-line-re (make-regexp "^;;; Commentary:")) +(define default-after-line-re (make-regexp "^;;; Code:")) +(define default-scrub (let ((dirt (make-regexp "^;+"))) + (lambda (line) + (let ((m (regexp-exec dirt line))) + (if m (match:suffix m) line))))) + +(define (file-commentary filename . cust) ; (IN-LINE-RE AFTER-LINE-RE SCRUB) + ;; fixme: might be cleaner to use optargs here... + (let ((in-line-re (if (> 1 (length cust)) + default-in-line-re + (let ((v (car cust))) + (cond ((regexp? v) v) + ((string? v) (make-regexp v)) + (else default-in-line-re))))) + (after-line-re (if (> 2 (length cust)) + default-after-line-re + (let ((v (cadr cust))) + (cond ((regexp? v) v) + ((string? v) (make-regexp v)) + (else default-after-line-re))))) + (scrub (if (> 3 (length cust)) + default-scrub + (let ((v (caddr cust))) + (cond ((procedure? v) v) + (else default-scrub))))) + (port (open-input-file filename))) + (let loop ((line (read-delimited "\n" port)) + (doc "") + (parse-state 'before)) + (if (or (eof-object? line) (eq? 'after parse-state)) + doc + (let ((new-state + (cond ((regexp-exec in-line-re line) 'in) + ((regexp-exec after-line-re line) 'after) + (else parse-state)))) + (if (eq? 'after new-state) + doc + (loop (read-delimited "\n" port) + (if (and (eq? 'in new-state) (eq? 'in parse-state)) + (string-append doc (scrub line) "\n") + doc) + new-state))))))) + ;; ;; documentation-files is the list of places to look for documentation ;; -(define-public documentation-files +(define documentation-files (map (lambda (vicinity) (in-vicinity (vicinity) "guile-procedures.txt")) (list %library-dir @@ -36,7 +140,7 @@ (define (find-documentation name) (or-map (lambda (file) (find-documentation-in-file name file)) - documentation-files)) + documentation-files)) (define entry-delimiter "\f") @@ -64,8 +168,10 @@ (or (procedure-documentation proc) (procedure-property proc 'documentation))) -(define-public (object-documentation object) - "Return the docstring for OBJECT." +(define (object-documentation object) + "Return the docstring for OBJECT. +OBJECT can be a procedure, macro or any object that has its +`documentation' property set." (or (and (procedure? object) (proc-doc object)) (and (macro? object) @@ -81,3 +187,5 @@ (if docstring (set-procedure-property! object 'documentation docstring)) docstring)))) + +;;; documentation.scm ends here From 7bb1bfc28fcf0865b22856696901c1d41b583190 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 28 Apr 2001 00:32:23 +0000 Subject: [PATCH 0916/2047] Update copyright. Use (ice-9 rdelim). (help): Consider a list of symbols that does not start with `quote' as a module name and call `module-commentary' on it. (module-filename, module-commentary): New procs. (id): Delete. (apropos): Use `identity' instead of deprecated `id'. --- ice-9/session.scm | 44 ++++++++++++++++++++++++++++++++++---------- 1 file changed, 34 insertions(+), 10 deletions(-) diff --git a/ice-9/session.scm b/ice-9/session.scm index 1148bbcf8..b470c6093 100644 --- a/ice-9/session.scm +++ b/ice-9/session.scm @@ -1,26 +1,26 @@ -;;;; Copyright (C) 1997, 2000 Free Software Foundation, Inc. -;;;; +;;;; Copyright (C) 1997, 2000, 2001 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 ;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA -;;;; +;;;; (define-module (ice-9 session) :use-module (ice-9 documentation) :use-module (ice-9 regex) - ) + :use-module (ice-9 rdelim)) @@ -54,11 +54,37 @@ You don't seem to have regular expressions installed.\n")) (if (not doc) (simple-format #t "No documentation found for ~S\n" (cadr name)) - (write-line doc)))) + (write-line doc)))) + ((and (list? name) + (and-map symbol? name) + (not (null? name)) + (not (eq? (car name) 'quote))) + (let ((doc (module-commentary name))) + (if (not doc) + (simple-format + #t "No commentary found for module ~S\n" name) + (begin + (display name) (write-line " commentary:") + (write-line doc))))) (else (help-usage))) *unspecified*)))))) +(define (module-filename name) ; fixme: better way? / done elsewhere? + (let* ((name (map symbol->string name)) + (reverse-name (reverse name)) + (leaf (car reverse-name)) + (dir-hint-module-name (reverse (cdr reverse-name))) + (dir-hint (apply string-append + (map (lambda (elt) + (string-append elt "/")) + dir-hint-module-name)))) + (%search-load-path (in-vicinity dir-hint leaf)))) + +(define (module-commentary name) + (cond ((module-filename name) => file-commentary) + (else #f))) + (define (help-doc term regexp) (let ((entries (apropos-fold (lambda (module name object data) (cons (list module @@ -178,8 +204,6 @@ where OPTIONSET is one of debug, read, eval, print ;;; Author: Roland Orre ;;; -(define (id x) x) - (define-public (apropos rgx . options) "Search for bindings: apropos regexp {options= 'full 'shadow 'value}" (if (zero? (string-length rgx)) @@ -202,7 +226,7 @@ where OPTIONSET is one of debug, read, eval, print (builtin-bindings) (module-obarray module))) (get-ref (if builtin - id + identity variable-ref))) (array-for-each (lambda (oblist) From 8bbe4c8235c99c98eaf1b6df4776d040a1c6bcc5 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 28 Apr 2001 00:35:02 +0000 Subject: [PATCH 0917/2047] (help-usage): Add blurb about "(help (my module))" support. --- ice-9/session.scm | 1 + 1 file changed, 1 insertion(+) diff --git a/ice-9/session.scm b/ice-9/session.scm index b470c6093..27dab6a3d 100644 --- a/ice-9/session.scm +++ b/ice-9/session.scm @@ -167,6 +167,7 @@ You don't seem to have regular expressions installed.\n")) (display "Usage: (help NAME) gives documentation about objects named NAME (a symbol) (help REGEXP) ditto for objects with names matching REGEXP (a string) (help ,EXPR) gives documentation for object returned by EXPR + (help (my module)) gives module commentary for `(my module)' (help) gives this text `help' searches among bindings exported from loaded modules, while From 835b2c877434ab5f58b33555cdd07a8b30523829 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 28 Apr 2001 00:39:09 +0000 Subject: [PATCH 0918/2047] *** empty log message *** --- ice-9/ChangeLog | 24 +++++++++++++++++++++++- 1 file changed, 23 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index b87a5dc34..99c046671 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,25 @@ +2001-04-27 Thien-Thi Nguyen + + * documentation.scm: Update copyright. + Add commentary. + Use `define-module' `:export' clause instead of `define-public'. + Autoload (ice-9 regex) on `match:suffix'. + + (default-in-line-re, default-after-line-re): New vars. + (default-scrub): New proc. + (file-commentary): New proc, exported. + (object-documentation): Expand docstring; nfc. + + * session.scm: Update copyright. + Use (ice-9 rdelim). + + (help): Consider a list of symbols that does not start with + `quote' as a module name and call `module-commentary' on it. + (module-filename, module-commentary): New procs. + (id): Delete. + (apropos): Use `identity' instead of deprecated `id'. + (help-usage): Add blurb about "(help (my module))" support. + 2001-04-27 Martin Grabmueller * Makefile.am (ice9_sources): Remove srfi-8.scm. @@ -25,7 +47,7 @@ * boot-9.scm (call-with-deprecation): New procedure. (identity): New procedure. - (id): Deprecated. + (id): Deprecated. 2001-04-15 Keisuke Nishida From 6c0201ad76fabdad4a7a0b67216e4fd099961d2a Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 28 Apr 2001 00:44:00 +0000 Subject: [PATCH 0919/2047] (New help facility): Add blurb about "(help (my module))" support. --- NEWS | 85 ++++++++++++++++++++++++++++++------------------------------ 1 file changed, 43 insertions(+), 42 deletions(-) diff --git a/NEWS b/NEWS index 26391dbce..59a973fe5 100644 --- a/NEWS +++ b/NEWS @@ -53,7 +53,7 @@ to be named `and-let*', of course. On systems that support it, there is also a compatibility module named (ice-9 and-let*). It will go away in the next release. - + ** New modules (oop goops) etc.: (oop goops) @@ -265,7 +265,7 @@ used in a lexical environment. ** The semantics of guardians have changed. The changes are for the most part compatible. An important criterion -was to keep the typical usage of guardians as simple as before, but to +was to keep the typical usage of guardians as simple as before, but to make the semantics safer and (as a result) more useful. *** All objects returned from guardians are now properly alive. @@ -647,7 +647,7 @@ behaviour is undefined - it may even crash or loop endlessly. Further, for the case that the object is not found in the list, scm_c_memq returns #f which is similar to scm_memq, but different from scm_sloppy_memq's behaviour. -** New functions: scm_remember_upto_here_1, scm_remember_upto_here_2, +** New functions: scm_remember_upto_here_1, scm_remember_upto_here_2, scm_remember_upto_here These functions replace the function scm_remember. @@ -678,26 +678,26 @@ of this variable is (and has been) not fully safe anyway. Use these instead of SCM_LENGTH_MAX. -** New macros: SCM_CONTINUATION_LENGTH, SCM_CCLO_LENGTH, SCM_STACK_LENGTH, +** New macros: SCM_CONTINUATION_LENGTH, SCM_CCLO_LENGTH, SCM_STACK_LENGTH, SCM_STRING_LENGTH, SCM_SYMBOL_LENGTH, SCM_UVECTOR_LENGTH, SCM_BITVECTOR_LENGTH, SCM_VECTOR_LENGTH. Use these instead of SCM_LENGTH. -** New macros: SCM_SET_CONTINUATION_LENGTH, SCM_SET_STRING_LENGTH, +** New macros: SCM_SET_CONTINUATION_LENGTH, SCM_SET_STRING_LENGTH, SCM_SET_SYMBOL_LENGTH, SCM_SET_VECTOR_LENGTH, SCM_SET_UVECTOR_LENGTH, SCM_SET_BITVECTOR_LENGTH Use these instead of SCM_SETLENGTH -** New macros: SCM_STRING_CHARS, SCM_SYMBOL_CHARS, SCM_CCLO_BASE, +** New macros: SCM_STRING_CHARS, SCM_SYMBOL_CHARS, SCM_CCLO_BASE, SCM_VECTOR_BASE, SCM_UVECTOR_BASE, SCM_BITVECTOR_BASE, SCM_COMPLEX_MEM, SCM_ARRAY_MEM Use these instead of SCM_CHARS, SCM_UCHARS, SCM_ROCHARS, SCM_ROUCHARS or SCM_VELTS. -** New macros: SCM_SET_BIGNUM_BASE, SCM_SET_STRING_CHARS, +** New macros: SCM_SET_BIGNUM_BASE, SCM_SET_STRING_CHARS, SCM_SET_SYMBOL_CHARS, SCM_SET_UVECTOR_BASE, SCM_SET_BITVECTOR_BASE, SCM_SET_VECTOR_BASE @@ -713,9 +713,9 @@ Use instead of SCM_COERCE_SUBSTR. For directory objects, use these instead of SCM_OPDIRP and SCM_OPN. -** Deprecated macros: SCM_OUTOFRANGE, SCM_NALLOC, SCM_HUP_SIGNAL, -SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, -SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD, +** Deprecated macros: SCM_OUTOFRANGE, SCM_NALLOC, SCM_HUP_SIGNAL, +SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, +SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD, SCM_ORD_SIG, SCM_NUM_SIGS, SCM_SYMBOL_SLOTS, SCM_SLOTS, SCM_SLOPPY_STRINGP, SCM_VALIDATE_STRINGORSUBSTR, SCM_FREEP, SCM_NFREEP, SCM_CHARS, SCM_UCHARS, SCM_VALIDATE_ROSTRING, SCM_VALIDATE_ROSTRING_COPY, @@ -735,7 +735,7 @@ Use SCM_STRINGP instead of SCM_SLOPPY_STRINGP. Use SCM_VALIDATE_STRING instead of SCM_VALIDATE_STRINGORSUBSTR. Use SCM_FREE_CELL_P instead of SCM_FREEP/SCM_NFREEP Use a type specific accessor macro instead of SCM_CHARS/SCM_UCHARS. -Use a type specific accessor instead of SCM(_|_RO|_HUGE_)LENGTH. +Use a type specific accessor instead of SCM(_|_RO|_HUGE_)LENGTH. Use SCM_VALIDATE_(SYMBOL|STRING) instead of SCM_VALIDATE_ROSTRING. Use SCM_STRING_COERCE_0TERMINATION_X instead of SCM_COERCE_SUBSTR. Use SCM_STRINGP or SCM_SYMBOLP instead of SCM_ROSTRINGP. @@ -920,6 +920,7 @@ This is useful when debugging your .guile init file or scripts. Usage: (help NAME) gives documentation about objects named NAME (a symbol) (help REGEXP) ditto for objects with names matching REGEXP (a string) (help ,EXPR) gives documentation for object returned by EXPR + (help (my module)) gives module commentary for `(my module)' (help) gives this text `help' searches among bindings exported from loaded modules, while @@ -958,7 +959,7 @@ Linux POSIX threads due to their use of the stack pointer to find the thread context. This has now been fixed with a workaround which uses the pthreads to allocate the stack. -** New primitives: `pkgdata-dir', `site-dir', `library-dir' +** New primitives: `pkgdata-dir', `site-dir', `library-dir' ** Positions of erring expression in scripts @@ -1184,13 +1185,13 @@ Thus, the use of SCM_HOOK_NAME and scm_make_hook_with_name is deprecated. You can emulate this feature by using object properties. -** Deprecated macros: SCM_INPORTP, SCM_OUTPORTP, SCM_CRDY, SCM_ICHRP, +** Deprecated macros: SCM_INPORTP, SCM_OUTPORTP, SCM_CRDY, SCM_ICHRP, SCM_ICHR, SCM_MAKICHR, SCM_SETJMPBUF, SCM_NSTRINGP, SCM_NRWSTRINGP, SCM_NVECTORP These macros will be removed in a future release of Guile. -** The following types, functions and macros from numbers.h are deprecated: +** The following types, functions and macros from numbers.h are deprecated: scm_dblproc, SCM_UNEGFIXABLE, SCM_FLOBUFLEN, SCM_INEXP, SCM_CPLXP, SCM_REAL, SCM_IMAG, SCM_REALPART, scm_makdbl, SCM_SINGP, SCM_NUM2DBL, SCM_NO_BIGDIG @@ -1462,7 +1463,7 @@ now possible to use `defined?' to check whether the facility is available. ** Procedures which depend on the timezone should now give the correct -result on systems which cache the TZ environment variable, even if TZ +result on systems which cache the TZ environment variable, even if TZ is changed without calling tzset. * Changes to the networking interfaces: @@ -1972,7 +1973,7 @@ when the hook was created. in a regular expression will still match before a line-break or end-of-file. The default is `regexp/noteol'. -*** The expect-strings macro now uses a variable +*** The expect-strings macro now uses a variable `expect-strings-compile-flags' for the flags to be supplied to `make-regexp'. The default is `regexp/newline', which was previously hard-coded. @@ -2450,7 +2451,7 @@ string, and the source and destination areas may overlap; in all cases, the function behaves as if all the characters were copied simultanously. -*** Extended functions: substring-move-left! substring-move-right! +*** Extended functions: substring-move-left! substring-move-right! These functions now correctly copy arbitrarily overlapping substrings; they are both synonyms for substring-move!. @@ -2484,7 +2485,7 @@ Each option can have the following (PROPERTY VALUE) pairs: (value BOOL) --- If BOOL is #t, the option accepts a value; if it is #f, it does not; and if it is the symbol `optional', the option may appear in ARGS with or - without a value. + without a value. (predicate FUNC) --- If the option accepts a value (i.e. you specified `(value #t)' for this option), then getopt will apply FUNC to the value, and throw an exception @@ -2562,10 +2563,10 @@ So, for example: (single-char #\v) (value #f)) (x-includes (single-char #\x)) - (rnet-server (single-char #\y) + (rnet-server (single-char #\y) (predicate ,string?)))) -(getopt-long '("my-prog" "-vk" "/tmp" "foo1" "--x-includes=/usr/include" +(getopt-long '("my-prog" "-vk" "/tmp" "foo1" "--x-includes=/usr/include" "--rnet-server=lamprod" "--" "-fred" "foo2" "foo3") grammar) => ((() "foo1" "-fred" "foo2" "foo3") @@ -2580,10 +2581,10 @@ It will be removed in a few releases. ** New syntax: lambda* ** New syntax: define* -** New syntax: define*-public +** New syntax: define*-public ** New syntax: defmacro* ** New syntax: defmacro*-public -Guile now supports optional arguments. +Guile now supports optional arguments. `lambda*', `define*', `define*-public', `defmacro*' and `defmacro*-public' are identical to the non-* versions except that @@ -2592,17 +2593,17 @@ syntax (parentheses are literal, square brackets indicate grouping, and `*', `+' and `?' have the usual meaning): ext-param-list ::= ( [identifier]* [#&optional [ext-var-decl]+]? - [#&key [ext-var-decl]+ [#&allow-other-keys]?]? + [#&key [ext-var-decl]+ [#&allow-other-keys]?]? [[#&rest identifier]|[. identifier]]? ) | [identifier] - ext-var-decl ::= identifier | ( identifier expression ) + ext-var-decl ::= identifier | ( identifier expression ) The semantics are best illustrated with the following documentation and examples for `lambda*': lambda* args . body lambda extended for optional and keyword arguments - + lambda* creates a procedure that takes optional arguments. These are specified by putting them inside brackets at the end of the paramater list, but before any dotted rest argument. For example, @@ -2622,11 +2623,11 @@ and examples for `lambda*': Optional and keyword arguments can also be given default values which they take on when they are not present in a call, by giving a two-item list in place of an optional argument, for example in: - (lambda* (foo #&optional (bar 42) #&key (baz 73)) (list foo bar baz)) + (lambda* (foo #&optional (bar 42) #&key (baz 73)) (list foo bar baz)) foo is a fixed argument, bar is an optional argument with default value 42, and baz is a keyword argument with default value 73. Default value expressions are not evaluated unless they are needed - and until the procedure is called. + and until the procedure is called. lambda* now supports two more special parameter list keywords. @@ -2932,7 +2933,7 @@ SIZE to the system. The return value is a tag that is used in creating instances of the type. If SIZE is 0, then no memory will be allocated when instances of the smob are created, and nothing will be freed by the default free function. - + *** Function: void scm_set_smob_mark (long tc, SCM (*mark) (SCM)) This function sets the smob marking procedure for the smob type specified by the tag TC. TC is the tag returned by @@ -3317,7 +3318,7 @@ For example: the-scm-module: backtrace # the-scm-module: after-backtrace-hook () the-scm-module: has-shown-backtrace-hint? #f - guile> + guile> ** There are new functions and syntax for working with macros. @@ -3349,7 +3350,7 @@ values are: The symbol `syntax' --- a macro created by procedure->syntax. The symbol `macro' --- a macro created by procedure->macro. The symbol `macro!' --- a macro created by procedure->memoizing-macro. - The boolean #f --- if OBJ is not a macro object. + The boolean #f --- if OBJ is not a macro object. *** New function: (macro-name MACRO) Return the name of the macro object MACRO's procedure, as returned by @@ -3367,7 +3368,7 @@ top-level environment. TRANSFORMER is an expression evaluated in the resulting environment which must yield a procedure to use as the module's eval transformer: every expression evaluated in this module is passed to this function, and the result passed to the Guile -interpreter. +interpreter. *** macro-eval! is removed. Use local-eval instead. @@ -3442,7 +3443,7 @@ Function: with-fluids* FLUIDS VALUES THUNK FLUIDS is a list of fluids and VALUES a corresponding list of values for these fluids. Before THUNK gets called the values are - installed in the fluids and the old values of the fluids are + installed in the fluids and the old values of the fluids are saved in the VALUES list. When the flow of control leaves THUNK or reenters it, the values get swapped again. You might think of this as a `safe-fluid-excursion'. Note that the VALUES list is @@ -3989,7 +3990,7 @@ Here is a small example that works on GNU/Linux: See the file `libguile/DYNAMIC-LINKING' for additional comments. ** The #/ syntax for module names is depreciated, and will be removed -in a future version of Guile. Instead of +in a future version of Guile. Instead of #/foo/bar/baz @@ -4612,7 +4613,7 @@ argument. ** Changes to I/O functions -*** The functions `read', `primitive-load', `read-and-eval!', and +*** The functions `read', `primitive-load', `read-and-eval!', and `primitive-load-path' no longer take optional arguments controlling case insensitivity and a `#' parser. @@ -4630,7 +4631,7 @@ syntax of Guile Scheme in a somewhat controlled way. The reader applies PROC to two arguments: CHAR and an input port. -*** The new functions read-delimited and read-delimited! provide a +*** The new functions read-delimited and read-delimited! provide a general mechanism for doing delimited input on streams. (read-delimited DELIMS [PORT HANDLE-DELIM]) @@ -4749,7 +4750,7 @@ and `recvfrom!'. They no longer accept a size for a second argument; you must pass a string to hold the received value. They no longer return the buffer. Instead, `recv' returns the length of the message received, and `recvfrom' returns a pair containing the packet's length -and originating address. +and originating address. *** The file descriptor datatype has been removed, as have the `read-fd', `write-fd', `close', `lseek', and `dup' functions. @@ -4875,17 +4876,17 @@ internet protocols: Component Accessor ========================= =============== - official service name servent:name + official service name servent:name alias list servent:aliases - port number servent:port - protocol to use servent:proto + port number servent:port + protocol to use servent:proto *** There are new accessors for the sockaddr structures returned by `accept', `getsockname', `getpeername', `recvfrom!': Component Accessor ======================================== =============== - address format (`family') sockaddr:fam + address format (`family') sockaddr:fam path, for file domain addresses sockaddr:path address, for internet domain addresses sockaddr:addr TCP or UDP port, for internet sockaddr:port @@ -5057,7 +5058,7 @@ command interpreter. For details, see "Changes to the stand-alone interpreter" above. ** The new functions scm_get_meta_args and scm_count_argv help you -implement the SCSH-style meta-argument, `\'. +implement the SCSH-style meta-argument, `\'. char **scm_get_meta_args (int ARGC, char **ARGV) If the second element of ARGV is a string consisting of a single @@ -5065,7 +5066,7 @@ char **scm_get_meta_args (int ARGC, char **ARGV) named by the following argument, parse arguments from it, and return the spliced command line. The returned array is terminated by a null pointer. - + For details of argument parsing, see above, under "guile now accepts command-line arguments compatible with SCSH..." From e3334972a59d6b112bb53929c1e02e2e9f39f46c Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 28 Apr 2001 08:59:48 +0000 Subject: [PATCH 0920/2047] * Fix typo in docstring. --- libguile/ChangeLog | 4 ++++ libguile/stacks.c | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 0cca30474..6699e4dc3 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2001-04-28 Neil Jerram + + * stacks.c (scm_make_stack): Fix typo in docstring. + 2001-04-27 Rob Browning * error.c (scm_sysmissing): deprecation expired - removed. diff --git a/libguile/stacks.c b/libguile/stacks.c index 92873a469..c43ba9b2c 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -417,7 +417,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, "evaluation stack is used for creating the stack frames,\n" "otherwise the frames are taken from @var{obj} (which must be\n" "either a debug object or a continuation).\n" - "@var{args} must be a list if integers and specifies how the\n" + "@var{args} must be a list of integers and specifies how the\n" "resulting stack will be narrowed.") #define FUNC_NAME s_scm_make_stack { From 87f05a7a5a30b5e89729c2d30b6d28bd9db1b79d Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 28 Apr 2001 09:00:31 +0000 Subject: [PATCH 0921/2047] * Updates to authors and thanks files. --- doc/THANKS | 1 + doc/guile.texi | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/doc/THANKS b/doc/THANKS index e5b63ccad..b3674fbeb 100644 --- a/doc/THANKS +++ b/doc/THANKS @@ -10,6 +10,7 @@ Proofreading, bug reports and bug fixes from: Keith Wright Chris Bitmead Dale P. Smith + Masao Uebayashi New entries from: Per Bothner diff --git a/doc/guile.texi b/doc/guile.texi index cdb38be29..3571a51a9 100644 --- a/doc/guile.texi +++ b/doc/guile.texi @@ -140,7 +140,7 @@ by the Free Software Foundation. @sp 10 @comment The title is printed in a large font. @title Guile Reference Manual -@subtitle $Id: guile.texi,v 1.5 2001-04-24 19:41:48 mgrabmue Exp $ +@subtitle $Id: guile.texi,v 1.6 2001-04-28 09:00:31 ossau Exp $ @subtitle For use with Guile @value{VERSION} @author Mark Galassi @author Cygnus Solution and Los Alamos National Laboratory @@ -151,7 +151,7 @@ by the Free Software Foundation. @author @email{jimb@@red-bean.com} @author @author Gary Houston -@author @email{ghouston@@actrix.gen.nz} +@author @email{ghouston@@arglist.com} @author @author Tim Pierce @author @email{twp@@skepsis.com} From 0b7edf57e8a98e77c5d3e02aee02ddc083521466 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 28 Apr 2001 17:17:38 +0000 Subject: [PATCH 0922/2047] * goops/save.scm (write-readably): rename list* to cons*. --- oop/goops/save.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/oop/goops/save.scm b/oop/goops/save.scm index fa13778bd..10d193055 100644 --- a/oop/goops/save.scm +++ b/oop/goops/save.scm @@ -307,7 +307,7 @@ (display (cond ((not not-literal?) #\() (proper? "(list ") (1? "(cons ") - (else "(list* ")) + (else "(cons* ")) file) (if (and not-literal? (literal? (car o) env)) From d3299bc3305f4ab12ddc8db6c390ff346ebf0c42 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 28 Apr 2001 17:18:06 +0000 Subject: [PATCH 0923/2047] * goops.scm (method): rename list* to cons*. --- oop/goops.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/oop/goops.scm b/oop/goops.scm index 32b86108e..9c18cf693 100644 --- a/oop/goops.scm +++ b/oop/goops.scm @@ -498,7 +498,7 @@ (let ((args (cadr exp)) (body (cddr exp))) `(make - #:specializers (list* ,@(specializers args)) + #:specializers (cons* ,@(specializers args)) #:procedure (lambda ,(formals args) ,@(if (null? body) (list *unspecified*) From c90fcdf63f78dc6903be4c8d42e3977c05b552d5 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 28 Apr 2001 17:18:16 +0000 Subject: [PATCH 0924/2047] *** empty log message *** --- oop/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/oop/ChangeLog b/oop/ChangeLog index 170902166..d4d81e37e 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -1,3 +1,9 @@ +2001-04-28 Rob Browning + + * goops/save.scm (write-readably): rename list* to cons*. + + * goops.scm (method): rename list* to cons*. + 2001-04-10 Mikael Djurfeldt * goops/Makefile.am, goops/goopscore.scm: Reverted changes of From af92e2b53d00cd32c1a6aac1feaf36457d476530 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 28 Apr 2001 17:23:23 +0000 Subject: [PATCH 0925/2047] * gh.h (gh_int2scmb): deprecation expired - removed. --- libguile/gh.h | 8 -------- 1 file changed, 8 deletions(-) diff --git a/libguile/gh.h b/libguile/gh.h index c7c88907c..b2b5289ab 100644 --- a/libguile/gh.h +++ b/libguile/gh.h @@ -238,14 +238,6 @@ void gh_newline (void); /* void gh_assert(int cond, char *msg, SCM obj); */ - - -#if (SCM_DEBUG_DEPRECATED == 0) - -SCM gh_int2scmb(int x); /* this is being phased out */ - -#endif /* SCM_DEBUG_DEPRECATED == 0 */ - #ifdef __cplusplus } #endif From 91faf22772c94eb776e3b6492cb146ef9f20622b Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 28 Apr 2001 17:23:48 +0000 Subject: [PATCH 0926/2047] * gh_data.c (gh_int2scmb): deprecation expired - removed. --- libguile/gh_data.c | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/libguile/gh_data.c b/libguile/gh_data.c index 86ad5a2c1..48361645b 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -48,16 +48,6 @@ /* data conversion C->scheme */ -#if (SCM_DEBUG_DEPRECATED == 0) - -SCM -gh_int2scmb (int x) /* this is being phased out */ -{ - return SCM_BOOL(x); -} - -#endif /* SCM_DEBUG_DEPRECATED == 0 */ - SCM gh_bool2scm (int x) { From 22baef2225997c4200718465998472d1dc2b3562 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 28 Apr 2001 17:24:16 +0000 Subject: [PATCH 0927/2047] * ioext.c: (scm_fseek): deprecation expired - removed. --- libguile/ioext.c | 17 ----------------- 1 file changed, 17 deletions(-) diff --git a/libguile/ioext.c b/libguile/ioext.c index c69be4d42..3923ed95c 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -178,23 +178,6 @@ SCM_DEFINE (scm_ftell, "ftell", 1, 0, 0, } #undef FUNC_NAME - -#if (SCM_DEBUG_DEPRECATED == 0) - -SCM_DEFINE (scm_fseek, "fseek", 3, 0, 0, - (SCM fd_port, SCM offset, SCM whence), - "Obsolete. Almost the same as @code{seek}, but the return value\n" - "is unspecified.") -#define FUNC_NAME s_scm_fseek -{ - scm_seek (fd_port, offset, whence); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -#endif /* SCM_DEBUG_DEPRECATED == 0 */ - - SCM_DEFINE (scm_redirect_port, "redirect-port", 2, 0, 0, (SCM old, SCM new), "This procedure takes two ports and duplicates the underlying file\n" From 36aecedd6b82f7a45a188392ee3c7d33a83e689f Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 28 Apr 2001 17:24:43 +0000 Subject: [PATCH 0928/2047] * ioext.h (scm_fseek): deprecation expired - removed. --- libguile/ioext.h | 8 -------- 1 file changed, 8 deletions(-) diff --git a/libguile/ioext.h b/libguile/ioext.h index 36f0ac49e..5853f4490 100644 --- a/libguile/ioext.h +++ b/libguile/ioext.h @@ -61,14 +61,6 @@ extern SCM scm_primitive_move_to_fdes (SCM port, SCM fd); extern SCM scm_fdes_to_ports (SCM fd); extern void scm_init_ioext (void); - - -#if (SCM_DEBUG_DEPRECATED == 0) - -extern SCM scm_fseek (SCM object, SCM offset, SCM whence); - -#endif /* SCM_DEBUG_DEPRECATED == 0 */ - #endif /* IOEXTH */ /* From 5425fc2f3a7782d507ec8b5a5ec23c4e33227d8a Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 28 Apr 2001 17:25:51 +0000 Subject: [PATCH 0929/2047] * list.h (scm_list_star): deprecation expired - removed. --- libguile/list.h | 1 - 1 file changed, 1 deletion(-) diff --git a/libguile/list.h b/libguile/list.h index 96163ec87..4493816ee 100644 --- a/libguile/list.h +++ b/libguile/list.h @@ -103,7 +103,6 @@ extern void scm_init_list (void); #if (SCM_DEBUG_DEPRECATED == 0) -#define scm_list_star scm_cons_star extern SCM scm_sloppy_memq (SCM x, SCM lst); extern SCM scm_sloppy_memv (SCM x, SCM lst); extern SCM scm_sloppy_member (SCM x, SCM lst); From 14efea3dde5df9b333f8ae98d06b2a338f4795a5 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 28 Apr 2001 17:27:04 +0000 Subject: [PATCH 0930/2047] * numbers.c: enabled local definition of SCM_FLOBUFLEN until we know what's supposed to happen to it. --- libguile/numbers.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 9cac82d45..a521ad35c 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -68,7 +68,8 @@ static SCM scm_divbigint (SCM x, long z, int sgn, int mode); #define SCM_SWAP(x,y) do { SCM __t = x; x = y; y = __t; } while (0) -#if (SCM_DEBUG_DEPRECATED == 1) /* not defined in header yet? */ +/*#if (SCM_DEBUG_DEPRECATED == 1)*/ /* not defined in header yet? */ +#if 1 /* SCM_FLOBUFLEN is the maximum number of characters neccessary for the * printed or scm_string representation of an inexact number. From 61fa6c373f3743d04db1d798b6e74c945a83d214 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 28 Apr 2001 17:28:04 +0000 Subject: [PATCH 0931/2047] * numbers.h (scm_dblproc): deprecation expired - removed. (SCM_UNEGFIXABLE): deprecation expired - removed. (SCM_FLOBUFLEN): deprecation expired - removed. (SCM_INEXP): deprecation expired - removed. (SCM_CPLXP): deprecation expired - removed. (SCM_REAL): deprecation expired - removed. (SCM_IMAG): deprecation expired - removed. (SCM_REALPART): deprecation expired - removed. (scm_makdbl): deprecation expired - removed. (SCM_SINGP): deprecation expired - removed. (SCM_NUM2DBL): deprecation expired - removed. (SCM_NO_BIGDIG): deprecation expired - removed. --- libguile/numbers.h | 27 --------------------------- 1 file changed, 27 deletions(-) diff --git a/libguile/numbers.h b/libguile/numbers.h index c8e00b480..23df0d7d8 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -303,33 +303,6 @@ extern unsigned long scm_num2ulong (SCM num, unsigned long int pos, const char *s_caller); extern void scm_init_numbers (void); - - -#if (SCM_DEBUG_DEPRECATED == 0) - -typedef struct scm_dblproc -{ - char *scm_string; - double (*cproc) (); -} scm_dblproc; - -#define SCM_UNEGFIXABLE(n) ((n) <= -SCM_MOST_NEGATIVE_FIXNUM) -#define SCM_FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10) -#define SCM_INEXP(x) SCM_INEXACTP(x) -#define SCM_CPLXP(x) SCM_COMPLEXP(x) -#define SCM_REAL(x) (SCM_SLOPPY_REALP (x) ? SCM_REAL_VALUE (x) : SCM_COMPLEX_REAL (x)) -#define SCM_IMAG(x) (SCM_SLOPPY_REALP (x) ? 0.0 : SCM_COMPLEX_IMAG (x)) -#define SCM_REALPART(x) (SCM_SLOPPY_REALP (x) ? SCM_REAL_VALUE (x) : SCM_COMPLEX_REAL (x)) -#define scm_makdbl scm_make_complex -#define SCM_SINGP(x) 0 -#define SCM_NUM2DBL(x) scm_num2dbl(x, "SCM_NUM2DBL") - -#ifndef SCM_BIGDIG -# define SCM_NO_BIGDIG -#endif - -#endif /* SCM_DEBUG_DEPRECATED == 0 */ - #endif /* NUMBERSH */ /* From a0ea0f6515b8389ad7181e03b86ee5a04c957be5 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 28 Apr 2001 17:29:31 +0000 Subject: [PATCH 0932/2047] * tag.c: (scm_tag): deprecation expired - removed. --- libguile/tag.c | 125 ------------------------------------------------- 1 file changed, 125 deletions(-) diff --git a/libguile/tag.c b/libguile/tag.c index f82731977..511d1d69f 100644 --- a/libguile/tag.c +++ b/libguile/tag.c @@ -90,133 +90,8 @@ CONST_INUM (scm_utag_port_base, "utag_port_base", 253); CONST_INUM (scm_utag_flag_base, "utag_flag_base", 254); CONST_INUM (scm_utag_struct_base, "utag_struct_base", 255); - -#if (SCM_DEBUG_DEPRECATED == 0) - -SCM_DEFINE (scm_tag, "tag", 1, 0, 0, - (SCM x), - "Return an integer corresponding to the type of X. Deprecated.") -#define FUNC_NAME s_scm_tag -{ - switch (SCM_ITAG3 (x)) - { - case scm_tc3_int_1: - case scm_tc3_int_2: - return SCM_CDR (scm_utag_immediate_integer) ; - - case scm_tc3_imm24: - if (SCM_CHARP (x)) - return SCM_CDR (scm_utag_immediate_char) ; - else - { - SCM tag = SCM_MAKINUM ((SCM_UNPACK (x) >> 8) & 0xff); - return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_flag_base) ) | (SCM_UNPACK (tag) << 8)); - } - - case scm_tc3_cons: - switch (SCM_TYP7 (x)) - { - case scm_tcs_cons_nimcar: - return SCM_CDR (scm_utag_pair) ; - case scm_tcs_closures: - return SCM_CDR (scm_utag_closure) ; - case scm_tc7_symbol: - return SCM_CDR (scm_utag_symbol) ; - case scm_tc7_vector: - return SCM_CDR (scm_utag_vector) ; - case scm_tc7_wvect: - return SCM_CDR (scm_utag_wvect) ; - -#ifdef HAVE_ARRAYS - case scm_tc7_bvect: - return SCM_CDR (scm_utag_bvect) ; - case scm_tc7_byvect: - return SCM_CDR (scm_utag_byvect) ; - case scm_tc7_svect: - return SCM_CDR (scm_utag_svect) ; - case scm_tc7_ivect: - return SCM_CDR (scm_utag_ivect) ; - case scm_tc7_uvect: - return SCM_CDR (scm_utag_uvect) ; - case scm_tc7_fvect: - return SCM_CDR (scm_utag_fvect) ; - case scm_tc7_dvect: - return SCM_CDR (scm_utag_dvect) ; - case scm_tc7_cvect: - return SCM_CDR (scm_utag_cvect) ; -#endif - - case scm_tc7_string: - return SCM_CDR (scm_utag_string) ; - case scm_tc7_substring: - return SCM_CDR (scm_utag_substring) ; - case scm_tc7_asubr: - return SCM_CDR (scm_utag_asubr) ; - case scm_tc7_subr_0: - return SCM_CDR (scm_utag_subr_0) ; - case scm_tc7_subr_1: - return SCM_CDR (scm_utag_subr_1) ; - case scm_tc7_cxr: - return SCM_CDR (scm_utag_cxr) ; - case scm_tc7_subr_3: - return SCM_CDR (scm_utag_subr_3) ; - case scm_tc7_subr_2: - return SCM_CDR (scm_utag_subr_2) ; - case scm_tc7_rpsubr: - return SCM_CDR (scm_utag_rpsubr) ; - case scm_tc7_subr_1o: - return SCM_CDR (scm_utag_subr_1o) ; - case scm_tc7_subr_2o: - return SCM_CDR (scm_utag_subr_2o) ; - case scm_tc7_lsubr_2: - return SCM_CDR (scm_utag_lsubr_2) ; - case scm_tc7_lsubr: - return SCM_CDR (scm_utag_lsubr) ; - - case scm_tc7_port: - { - int tag; - tag = (SCM_TYP16 (x) >> 8) & 0xff; - return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_port_base)) | (tag << 8)); - } - case scm_tc7_smob: - { - int tag; - tag = (SCM_TYP16 (x) >> 8) & 0xff; - return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_smob_base)) - | (tag << 8)); - } - case scm_tcs_cons_gloc: - /* must be a struct */ - { - int tag = (int) SCM_STRUCT_VTABLE_DATA (x) >> 3; - return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_struct_base)) - | (tag << 8)); - } - - default: - if (SCM_CONSP (x)) - return SCM_CDR (scm_utag_pair); - else - return SCM_MAKINUM (-1); - } - - case scm_tc3_cons_gloc: - case scm_tc3_tc7_1: - case scm_tc3_tc7_2: - case scm_tc3_closure: - /* Never reached */ - break; - } - return SCM_MAKINUM (-1); -} -#undef FUNC_NAME - -#endif /* SCM_DEBUG_DEPRECATED == 0 */ - - void scm_init_tag () { From 33cc9ac8493eccf553ed4a2f3e5920dc224bba1b Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 28 Apr 2001 17:29:50 +0000 Subject: [PATCH 0933/2047] * tag.h (scm_tag): deprecation expired - removed. --- libguile/tag.h | 67 -------------------------------------------------- 1 file changed, 67 deletions(-) diff --git a/libguile/tag.h b/libguile/tag.h index d2fb1fcb7..e69de29bb 100644 --- a/libguile/tag.h +++ b/libguile/tag.h @@ -1,67 +0,0 @@ -/* classes: h_files */ - -#ifndef TAGH -#define TAGH -/* Copyright (C) 1995, 2000 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 - * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ - - -#include "libguile/__scm.h" - - - -extern void scm_init_tag (void); - - - -#if (SCM_DEBUG_DEPRECATED == 0) - -extern SCM scm_tag (SCM x); - -#endif /* SCM_DEBUG_DEPRECATED == 0 */ - -#endif /* TAGH */ - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ From 457dc52c416d94b1bc30f0d96b5b87f577680e36 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 28 Apr 2001 17:30:20 +0000 Subject: [PATCH 0934/2047] * tags.h (SCM_DOUBLE_CELLP): deprecation expired - removed. (scm_tc_dblr): deprecation expired - removed. (scm_tc_dblc): deprecation expired - removed. (scm_tc16_flo): deprecation expired - removed. (scm_tc_flo): deprecation expired - removed. --- libguile/tags.h | 9 --------- 1 file changed, 9 deletions(-) diff --git a/libguile/tags.h b/libguile/tags.h index 0670c16f7..e64ad4c35 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -290,10 +290,6 @@ typedef long scm_bits_t; #define SCM_CELLP(x) (((sizeof (scm_cell) - 1) & SCM_UNPACK (x)) == 0) #define SCM_NCELLP(x) (!SCM_CELLP (x)) -#if (SCM_DEBUG_DEPRECATED == 0) -#define SCM_DOUBLE_CELLP(x) (((2 * sizeof (scm_cell) - 1) & SCM_UNPACK (x)) == 0) -#endif /* SCM_DEBUG_DEPRECATED == 0 */ - /* See numbers.h for macros relating to immediate integers. */ @@ -546,11 +542,6 @@ extern char *scm_isymnames[]; /* defined in print.c */ #define scm_tc7_msymbol scm_tc7_symbol #define scm_tcs_symbols scm_tc7_symbol -#define scm_tc16_flo scm_tc16_real -#define scm_tc_flo 0x017fL -#define scm_tc_dblr scm_tc16_real -#define scm_tc_dblc scm_tc16_complex - #endif /* SCM_DEBUG_DEPRECATED == 0 */ #endif /* SCM_TAGS_H */ From 0b2da99cb39e9c8ceacf91a2613bd3693881e069 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 28 Apr 2001 17:31:07 +0000 Subject: [PATCH 0935/2047] *** empty log message *** --- NEWS | 16 ++++++++++++---- RELEASE | 29 +++++++++++------------------ libguile/ChangeLog | 38 ++++++++++++++++++++++++++++++++++++++ 3 files changed, 61 insertions(+), 22 deletions(-) diff --git a/NEWS b/NEWS index 59a973fe5..524ab7471 100644 --- a/NEWS +++ b/NEWS @@ -13,13 +13,21 @@ Changes since Guile 1.4: *** Macros removed SCM_INPORTP, SCM_OUTPORTP SCM_ICHRP, SCM_ICHR, SCM_MAKICHR - SCM_SETJMPBUF SCM_NSTRINGP SCM_NRWSTRINGP SCM_NVECTORP + SCM_SETJMPBUF SCM_NSTRINGP SCM_NRWSTRINGP SCM_NVECTORP SCM_DOUBLE_CELLP -*** Functions removed - - scm_sysmissing +*** C Functions removed + scm_sysmissing scm_tag scm_tc16_flo scm_tc_flo + scm_fseek - replaced by scm_seek. gc-thunk - replaced by after-gc-hook. + gh_int2scmb - replaced by gh_bool2scm. + scm_tc_dblr - replaced by scm_tc16_real. + scm_tc_dblc - replaced by scm_tc16_complex. + scm_list_star - replaced by scm_cons_star. + +*** scheme functions removed: + + list* - replaced by cons*. ** New SRFI modules have been added: diff --git a/RELEASE b/RELEASE index 1c7b0f969..8ed8be4e5 100644 --- a/RELEASE +++ b/RELEASE @@ -7,9 +7,7 @@ absinthe, etc. However, the first release containing the module system should be called Godot: "This is the one you've been waiting for." -* Remove compatability module (ice-9 and-let*) eventually (when a - major release with the real module (ice-9 and-let-star) has been out - long enough, probably release 1.8). +=== Eventually: * Deprecate `read-only-string?'. @@ -17,24 +15,19 @@ After signal handling and threading have been fixed: - remove the code corresponding to GUILE_OLD_ASYNC_CLICK and the corresponding GUILE_OLD_ASYNC_CLICK macro. -In release 1.6.0: -- remove gh_int2scmb (replaced by gh_bool2scm) -- remove scm_fseek (replaced by scm_seek) -- remove scm_tag +=== In release 1.6.0: + +- Q: Was SCM_FLOBUFLEN only deprecated publically, or was it supposed + to be removed from numbers.c as well? + - remove code related to the name property of hooks. Also, check init.c, since the dependency between hooks and objprop will then be eliminated. -- remove deprecated function scm_list_star/list* (use SRFI-1 compliant - scm_cons_star/cons* instead.) -- remove scm_tc16_flo, scm_tc_flo (guile always uses doubles to represent - inexact real numbers) -- remove scm_tc_dblr (replaced by scm_tc16_real) -- remove scm_tc_dblc (replaced by scm_tc16_complex) -- remove deprecated types, functions and macros from numbers.h: scm_dblproc, - SCM_UNEGFIXABLE, SCM_FLOBUFLEN, SCM_INEXP, SCM_CPLXP, SCM_REAL, SCM_IMAG, - SCM_REALPART, scm_makdbl, SCM_SINGP, SCM_NUM2DBL, SCM_NO_BIGDIG -- remove deprecated macro from tags.h: SCM_DOUBLE_CELLP -In release 1.8.0: +=== In release 1.8.0: + +- remove compatability module (ice-9 and-let*). It + has been replaced by (ice-9 and-let-star) and/or (srfi srfi-2). + - remove support for autoloading compiled-code modules: try-module-linked try-module-dynamic-link diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6699e4dc3..4a71762eb 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,41 @@ +2001-04-28 Rob Browning + + * numbers.c: enabled local definition of SCM_FLOBUFLEN until we + know what's supposed to happen to it. + + * list.h (scm_list_star): deprecation expired - removed. + + * numbers.h (scm_dblproc): deprecation expired - removed. + (SCM_UNEGFIXABLE): deprecation expired - removed. + (SCM_FLOBUFLEN): deprecation expired - removed. + (SCM_INEXP): deprecation expired - removed. + (SCM_CPLXP): deprecation expired - removed. + (SCM_REAL): deprecation expired - removed. + (SCM_IMAG): deprecation expired - removed. + (SCM_REALPART): deprecation expired - removed. + (scm_makdbl): deprecation expired - removed. + (SCM_SINGP): deprecation expired - removed. + (SCM_NUM2DBL): deprecation expired - removed. + (SCM_NO_BIGDIG): deprecation expired - removed. + + * tags.h (SCM_DOUBLE_CELLP): deprecation expired - removed. + (scm_tc_dblr): deprecation expired - removed. + (scm_tc_dblc): deprecation expired - removed. + (scm_tc16_flo): deprecation expired - removed. + (scm_tc_flo): deprecation expired - removed. + + * tag.h (scm_tag): deprecation expired - removed. + + * tag.c: (scm_tag): deprecation expired - removed. + + * ioext.c: (scm_fseek): deprecation expired - removed. + + * ioext.h (scm_fseek): deprecation expired - removed. + + * gh_data.c (gh_int2scmb): deprecation expired - removed. + + * gh.h (gh_int2scmb): deprecation expired - removed. + 2001-04-28 Neil Jerram * stacks.c (scm_make_stack): Fix typo in docstring. From e9b00bf82088b2aed642b7c0385a75cdfbb05a3f Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 28 Apr 2001 18:34:17 +0000 Subject: [PATCH 0936/2047] (Manual Conventions): New chapter. --- doc/preface.texi | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/doc/preface.texi b/doc/preface.texi index 2391e135c..23d07752f 100644 --- a/doc/preface.texi +++ b/doc/preface.texi @@ -126,6 +126,31 @@ Guile, how to install it, where to find modules to work with Guile, and how to use the Guile debugger. +@iftex +@section Manual Conventions +@end iftex + +@ifnottex +@node Manual Conventions +@chapter Conventions used in this Manual +@end ifnottex + +We use some conventions in this manual. + +@itemize @bullet + +@item +For some procedures, notably type predicates, we use "iff" to mean +"if and only if". The construct is usually something like: "Return +VAL iff CONDITION", where VAL is usually "#t" or "non-#f". This +typically means that VAL is returned if CONDITION holds, and that #f is +returned otherwise. + +@c Add other conventions here. + +@end itemize + + @c Local Variables: @c TeX-master: "guile.texi" @c End: From 255b50e069e9eecdc9d4436c08243b3d461fae76 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 28 Apr 2001 18:35:41 +0000 Subject: [PATCH 0937/2047] *** empty log message *** --- doc/ChangeLog | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 7fdab78aa..a6aa319c7 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,7 @@ +2001-04-28 Thien-Thi Nguyen + + * preface.texi (Manual Conventions): New chapter. + 2001-04-26 Martin Grabmueller * srfi-13-14.texi (Reverse/Append): Updated procedure names for @@ -53,7 +57,7 @@ references to R5RS. * r4rs.texi: Removed. - + * Makefile.am (info_TEXINFOS): Remove r4rs. * README: Note removal of r4rs, and provide a reference. From cd96d7e6209a8798d22a04d0120aaa246c00e435 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 28 Apr 2001 18:45:29 +0000 Subject: [PATCH 0938/2047] Add commentary; nfc. --- ice-9/channel.scm | 58 +++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 56 insertions(+), 2 deletions(-) diff --git a/ice-9/channel.scm b/ice-9/channel.scm index 07974be80..96978aab2 100644 --- a/ice-9/channel.scm +++ b/ice-9/channel.scm @@ -6,17 +6,69 @@ ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, 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 this program; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. +;;; Commentary: + +;; Now you can use Guile's modules in Emacs Lisp like this: +;; +;; (guile-import current-module) +;; (guile-import module-ref) +;; +;; (setq assq (module-ref (current-module) 'assq)) +;; => ("" %%1%% . "#") +;; +;; (guile-use-modules (ice-9 documentation)) +;; +;; (object-documentation assq) +;; => +;; " - primitive: assq key alist +;; - primitive: assv key alist +;; - primitive: assoc key alist +;; Fetches the entry in ALIST that is associated with KEY. To decide +;; whether the argument KEY matches a particular entry in ALIST, +;; `assq' compares keys with `eq?', `assv' uses `eqv?' and `assoc' +;; uses `equal?'. If KEY cannot be found in ALIST (according to +;; whichever equality predicate is in use), then `#f' is returned. +;; These functions return the entire alist entry found (i.e. both the +;; key and the value)." +;; +;; Probably we can use GTK in Emacs Lisp. Can anybody try it? +;; +;; I have also implemented Guile Scheme mode and Scheme Interaction mode. +;; Just put the following lines in your ~/.emacs: +;; +;; (require 'guile-scheme) +;; (setq initial-major-mode 'scheme-interaction-mode) +;; +;; Currently, the following commands are available: +;; +;; M-TAB guile-scheme-complete-symbol +;; M-C-x guile-scheme-eval-define +;; C-x C-e guile-scheme-eval-last-sexp +;; C-c C-b guile-scheme-eval-buffer +;; C-c C-r guile-scheme-eval-region +;; C-c : guile-scheme-eval-expression +;; +;; I'll write more commands soon, or if you want to hack, please take +;; a look at the following files: +;; +;; guile-core/ice-9/channel.scm ;; object channel +;; guile-core/emacs/guile.el ;; object adapter +;; guile-core/emacs/guile-emacs.scm ;; Guile <-> Emacs channels +;; guile-core/emacs/guile-scheme.el ;; Guile Scheme mode +;; +;; As always, there are more than one bugs ;) + ;;; Code: (define-module (ice-9 channel)) @@ -111,3 +163,5 @@ (if (defined? 'object->string) object->string (lambda (x) (format #f "~S" x)))) + +;;; channel.scm ends here From e7d82febca73444cc1f309182dec476673541caa Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 28 Apr 2001 18:54:16 +0000 Subject: [PATCH 0939/2047] Add commentary; nfc. --- ice-9/threads.scm | 8 ++++++++ ice-9/time.scm | 22 ++++++++++++++++++---- 2 files changed, 26 insertions(+), 4 deletions(-) diff --git a/ice-9/threads.scm b/ice-9/threads.scm index b5d0cf9ce..631f5d86e 100644 --- a/ice-9/threads.scm +++ b/ice-9/threads.scm @@ -23,6 +23,14 @@ ;;;; ---------------------------------------------------------------- ;;;; +;;; Commentary: + +;; This module is documented in the Guile Reference Manual. +;; Briefly, one procedure is exported: `%thread-handler'; +;; as well as four macros: `make-thread', `begin-thread', +;; `with-mutex' and `monitor'. + +;;; Code: (define-module (ice-9 threads)) diff --git a/ice-9/time.scm b/ice-9/time.scm index 72f2fba7a..658ffbe56 100644 --- a/ice-9/time.scm +++ b/ice-9/time.scm @@ -1,21 +1,33 @@ ;;;; Copyright (C) 2001 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 ;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA -;;;; +;;;; +;;; Commentary: + +;; This module exports a single macro: `time'. +;; Usage: (time exp) +;; +;; Example: +;; guile> (time (sleep 3)) +;; clock utime stime cutime cstime gctime +;; 3.01 0.00 0.00 0.00 0.00 0.00 +;; 0 + +;;; Code: (define-module (ice-9 time) :use-module (ice-9 format) @@ -41,3 +53,5 @@ (define-macro (time exp) `(,time-proc (lambda () ,exp))) + +;;; time.scm ends here From afab82bc00212fb8384abe34c9c774654ba1170e Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 28 Apr 2001 18:58:09 +0000 Subject: [PATCH 0940/2047] Surround commentary w/ standard markers; nfc. --- ice-9/optargs.scm | 82 ++++++++++++++++++++++++----------------------- 1 file changed, 42 insertions(+), 40 deletions(-) diff --git a/ice-9/optargs.scm b/ice-9/optargs.scm index 5506a388c..9facebf62 100644 --- a/ice-9/optargs.scm +++ b/ice-9/optargs.scm @@ -1,29 +1,27 @@ ;;;; optargs.scm -- support for optional arguments ;;;; ;;;; Copyright (C) 1997, 1998, 1999 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 ;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA -;;;; +;;;; ;;;; Contributed by Maciej Stachowiak -(define-module (ice-9 optargs)) - - +;;; Commentary: ;;; {Optional Arguments} ;;; @@ -40,7 +38,7 @@ ;;; let-keywords* ;;; lambda* ;;; define* -;;; define*-public +;;; define*-public ;;; defmacro* ;;; defmacro*-public ;;; @@ -49,17 +47,19 @@ ;;; are used to indicate grouping only): ;;; ;;; ext-param-list ::= [identifier]* [#:optional [ext-var-decl]+]? -;;; [#:key [ext-var-decl]+ [#:allow-other-keys]?]? +;;; [#:key [ext-var-decl]+ [#:allow-other-keys]?]? ;;; [[#:rest identifier]|[. identifier]]? ;;; -;;; ext-var-decl ::= identifier | ( identifier expression ) +;;; ext-var-decl ::= identifier | ( identifier expression ) ;;; ;;; The characters `*', `+' and `?' are not to be taken literally; they ;;; mean respectively, zero or more occurences, one or more occurences, ;;; and one or zero occurences. ;;; +;;; Code: +(define-module (ice-9 optargs)) ;; bound? var ;; Checks if a variable is bound in the current environment. @@ -71,9 +71,9 @@ (defmacro-public bound? (var) `(catch 'misc-error - (lambda () - ,var - (not (eq? ,var ,(variable-ref + (lambda () + ,var + (not (eq? ,var ,(variable-ref (make-undefined-variable))))) (lambda args #f))) @@ -111,7 +111,7 @@ ;; duplicates keyword args in the rest arg. More explanation of what ;; keyword arguments in a lambda list look like can be found below in ;; the documentation for lambda*. Bindings can have the same form as -;; for let-optional. If allow-other-keys? is false, an error will be +;; for let-optional. If allow-other-keys? is false, an error will be ;; thrown if anything that looks like a keyword argument but does not ;; match a known keyword parameter will result in an error. ;; @@ -127,7 +127,7 @@ ;; some utility procedures for implementing the various let-forms. (define (let-o-k-template REST-ARG BINDINGS BODY let-type proc) - (let ((bindings (map (lambda (x) + (let ((bindings (map (lambda (x) (if (list? x) x (list x (variable-ref @@ -139,8 +139,8 @@ (if (null? BINDINGS) `(begin ,@BODY) (let-o-k-template REST-ARG BINDINGS BODY let-type - (lambda (optional) - `(,(car optional) + (lambda (optional) + `(,(car optional) (cond ((not (null? ,REST-ARG)) (let ((result (car ,REST-ARG))) @@ -157,11 +157,11 @@ (bindfilter (lambda (key) `(,(car key) (cond - ((assq ',(car key) ,kb-list-gensym) + ((assq ',(car key) ,kb-list-gensym) => cdr) - (else + (else ,(cadr key))))))) - `(let* ((ra->kbl ,rest-arg->keyword-binding-list) + `(let* ((ra->kbl ,rest-arg->keyword-binding-list) (,kb-list-gensym (ra->kbl ,REST-ARG ',(map (lambda (x) (symbol->keyword (if (pair? x) (car x) x))) BINDINGS) @@ -186,7 +186,7 @@ (error "Keyword argument has no value.") (next (cons (cons (keyword->symbol first) (car rest)) accum)))) - ((not allow-other-keys?) + ((not allow-other-keys?) (error "Unknown keyword in arguments.")) (else (if (null? rest) accum @@ -199,7 +199,7 @@ ;; "#&optional" instead of "#:optional" (read-hash-extend #\& (lambda (c port) - (display + (display "WARNING: `#&' is deprecated, use `#:' instead\n" (current-error-port)) (case (read port) @@ -212,7 +212,7 @@ ;; lambda* args . body ;; lambda extended for optional and keyword arguments -;; +;; ;; lambda* creates a procedure that takes optional arguments. These ;; are specified by putting them inside brackets at the end of the ;; paramater list, but before any dotted rest argument. For example, @@ -232,11 +232,11 @@ ;; Optional and keyword arguments can also be given default values ;; which they take on when they are not present in a call, by giving a ;; two-item list in place of an optional argument, for example in: -;; (lambda* (foo #:optional (bar 42) #:key (baz 73)) (list foo bar baz)) +;; (lambda* (foo #:optional (bar 42) #:key (baz 73)) (list foo bar baz)) ;; foo is a fixed argument, bar is an optional argument with default ;; value 42, and baz is a keyword argument with default value 73. ;; Default value expressions are not evaluated unless they are needed -;; and until the procedure is called. +;; and until the procedure is called. ;; ;; lambda* now supports two more special parameter list keywords. ;; @@ -259,7 +259,7 @@ (defmacro-public lambda* (ARGLIST . BODY) - (parse-arglist + (parse-arglist ARGLIST (lambda (non-optional-args optionals keys aok? rest-arg) ; Check for syntax errors. @@ -281,7 +281,7 @@ (string? (car BODY))) (list (car BODY)) '()) - (let-optional* + (let-optional* ,rest-gensym ,optionals (let-keywords* ,rest-gensym @@ -292,7 +292,7 @@ (error "Too many arguments."))) '()) ,@BODY))) - `(lambda (,@non-optional-args . ,(if rest-arg rest-arg '())) + `(lambda (,@non-optional-args . ,(if rest-arg rest-arg '())) ,@BODY)))))) @@ -302,7 +302,7 @@ (every? pred (cdr lst))))) (define (ext-decl? obj) - (or (symbol? obj) + (or (symbol? obj) (and (list? obj) (= 2 (length obj)) (symbol? (car obj))))) (define (parse-arglist arglist cont) @@ -311,9 +311,9 @@ ((memq val lst) => (lambda (pos) (if (memq val (cdr pos)) - (error (with-output-to-string + (error (with-output-to-string (lambda () - (map display `(,val + (map display `(,val " specified more than once in argument list."))))) (cont (reverse (cdr (memq val (reverse lst)))) (cdr pos) #t)))) (else (cont lst '() #f)))) @@ -325,25 +325,25 @@ (error "#:optional specified but no optional arguments declared.") (cont before after keys aok? rest))))) (define (parse-keys arglist rest cont) - (split-list-at + (split-list-at #:allow-other-keys arglist (lambda (aok-before aok-after aok-split?) (if (and aok-split? (not (null? aok-after))) (error "#:allow-other-keys not at end of keyword argument declarations.") - (split-list-at + (split-list-at #:key aok-before (lambda (key-before key-after key-split?) - (cond + (cond ((and aok-split? (not key-split?)) (error "#:allow-other-keys specified but no keyword arguments declared.")) - (key-split? + (key-split? (cond ((null? key-after) (error "#:key specified but no keyword arguments declared.")) ((memq #:optional key-after) (error "#:optional arguments declared after #:key arguments.")) (else (parse-opt-and-fixed key-before key-after aok-split? rest cont)))) (else (parse-opt-and-fixed arglist '() #f rest cont))))))))) (define (parse-rest arglist cont) - (cond + (cond ((null? arglist) (cont '() '() '() #f #f)) ((not (pair? arglist)) (cont '() '() '() #f arglist)) ((not (list? arglist)) @@ -354,8 +354,8 @@ (if (memq #:rest copy) (error "Cannot specify both #:rest and dotted rest argument.") (parse-keys copy ra cont)))) - (else (split-list-at - #:rest arglist + (else (split-list-at + #:rest arglist (lambda (before after split?) (if split? (case (length after) @@ -382,7 +382,7 @@ ;; (define-public* ((foo #:optional bar) #:optional baz) '()) ;; This illustrates currying. A procedure foo is defined, which, ;; when called with an optional argument bar, returns a procedure that -;; takes an optional argument baz. +;; takes an optional argument baz. ;; ;; Of course, define*[-public] also supports #:rest and #:allow-other-keys ;; in the same way as lambda*. @@ -414,7 +414,7 @@ ;; defmacro* name args . body ;; defmacro*-public args . body ;; defmacro and defmacro-public extended for optional and keyword arguments -;; +;; ;; These are just like defmacro and defmacro-public except that they ;; take lambda*-style extended paramter lists, where #:optional, ;; #:key, #:allow-other-keys and #:rest are allowed with the usual @@ -432,3 +432,5 @@ `(,DT ,NAME (,(lambda (transformer) (defmacro:transformer transformer)) (lambda* ,ARGLIST ,@BODY)))) + +;;; optargs.scm ends here From f32e992f53991bec82870cdc51afeb05eb7f2e28 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 28 Apr 2001 19:03:42 +0000 Subject: [PATCH 0941/2047] Add commentary; nfc. --- ice-9/expect.scm | 27 ++++++++++++++++++++------- 1 file changed, 20 insertions(+), 7 deletions(-) diff --git a/ice-9/expect.scm b/ice-9/expect.scm index 6e03bc8e0..7aaeca4c2 100644 --- a/ice-9/expect.scm +++ b/ice-9/expect.scm @@ -1,23 +1,35 @@ ;;;; Copyright (C) 1996, 1998, 1999 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 ;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA -;;;; +;;;; +;;; Commentary: -(define-module (ice-9 expect) :use-module (ice-9 regex)) +;; This module is documented in the Guile Reference Manual. +;; Briefly, these are exported: +;; procedures: expec-select, expect-regexec +;; variables: expect-port, expect-timeout, expect-timeout-proc, +;; expect-eof-proc, expect-char-proc, +;; expect-strings-compile-flags, expect-strings-exec-flags, +;; macros: expect + +;;; Code: + +(define-module (ice-9 expect) + :use-module (ice-9 regex)) ;;; Expect: a macro for selecting actions based on what it reads from a port. ;;; The idea is from Don Libes' expect based on Tcl. @@ -86,7 +98,7 @@ #f) `((apply ,(cadar exprs) (,(car tests) ,s ,port))))) - (else + (else (car exprs)))) body))))) ;; if none of the clauses matched the current string. @@ -128,7 +140,7 @@ ;;; timeout is an absolute time in floating point seconds. (define-public (expect-select port timeout) (let* ((secs-usecs (gettimeofday)) - (relative (- timeout + (relative (- timeout (car secs-usecs) (/ (cdr secs-usecs) 1000000)))) ; one million. @@ -153,3 +165,4 @@ ((< i 0) result)) #f))) +;;; expect.scm ends here From 20edfbbdb5746a57e6d76af2acb3a8192f4751c5 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 28 Apr 2001 19:07:38 +0000 Subject: [PATCH 0942/2047] Surround commentary w/ standard markers; nfc. --- ice-9/boot-9.scm | 101 +++++++++++++++++++++++++---------------------- 1 file changed, 53 insertions(+), 48 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index a4af8fe4b..7fa3f86b3 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1,31 +1,35 @@ ;;; installed-scm-file ;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001 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 ;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA -;;;; +;;;; +;;; Commentary: + ;;; This file is the first thing loaded into Guile. It adds many mundane ;;; definitions and a few that are interesting. ;;; -;;; The module system (hence the hierarchical namespace) are defined in this +;;; The module system (hence the hierarchical namespace) are defined in this ;;; file. ;;; +;;; Code: + ;;; {Features} ;; @@ -98,12 +102,12 @@ ;;; apply-to-args is functionally redunant with apply and, worse, ;;; is less general than apply since it only takes two arguments. ;;; -;;; On the other hand, apply-to-args is a syntacticly convenient way to +;;; On the other hand, apply-to-args is a syntacticly convenient way to ;;; perform binding in many circumstances when the "let" family of ;;; of forms don't cut it. E.g.: ;;; ;;; (apply-to-args (return-3d-mouse-coords) -;;; (lambda (x y z) +;;; (lambda (x y z) ;;; ...)) ;;; @@ -250,7 +254,7 @@ new-port)) ;; 0: type-name, 1: fields -(define record-type-vtable +(define record-type-vtable (make-vtable-vtable "prpr" 0 (lambda (s p) (cond ((eq? s record-type-vtable) @@ -395,7 +399,7 @@ ;; Apply f to successive elements of l until exhaustion or f returns #f. ;; If returning early, return #f. Otherwise, return the last value returned ;; by f. If f has never been called because l is empty, return #t. -;; +;; (define (and-map f lst) (let loop ((result #t) (l lst)) @@ -534,7 +538,7 @@ (if (pair? maybe-fd) (set-port-revealed! port 1)) port)) - + (define (dup->inport port/fd . maybe-fd) (apply dup->port port/fd "r" maybe-fd)) @@ -834,9 +838,9 @@ (display help) (newline)))) kw-desc)) - - + + (define (transform-usage-lambda cases) (let* ((raw-usage (delq! 'else (map car cases))) (usage-sans-specials (map (lambda (x) @@ -1062,7 +1066,7 @@ ;;; ;; module-search fn m -;; +;; ;; return the first non-#f result of FN applied to M and then to ;; the modules in the uses of m, and so on recursively. If all applications ;; return #f, then so does this function. @@ -1101,7 +1105,7 @@ ;;; {Is a symbol interned in a module?} ;;; -;;; Symbol S in Module M is interned if S occurs in +;;; Symbol S in Module M is interned if S occurs in ;;; of S in M has been set to some well-defined value. ;;; ;;; It is possible to intern a symbol in a module without providing @@ -1127,7 +1131,7 @@ ((if (symbol? key) hashq-remove! hash-remove!) ob key)) ;; module-symbol-locally-interned? module symbol -;; +;; ;; is a symbol interned (not neccessarily defined) locally in a given module ;; or its uses? Interned symbols shadow inherited bindings even if ;; they are not themselves bound to a defined value. @@ -1136,7 +1140,7 @@ (not (not (module-obarray-get-handle (module-obarray m) v)))) ;; module-symbol-interned? module symbol -;; +;; ;; is a symbol interned (not neccessarily defined) anywhere in a given module ;; or its uses? Interned symbols shadow inherited bindings even if ;; they are not themselves bound to a defined value. @@ -1174,8 +1178,8 @@ ;)) ;; module-variable module symbol -;; -;; like module-local-variable, except search the uses in the +;; +;; like module-local-variable, except search the uses in the ;; case V is not found in M. ;; ;; NOTE: This function is superseded with C code (see modules.c) @@ -1192,7 +1196,7 @@ ;;; ;; module-symbol-binding module symbol opt-value -;; +;; ;; return the binding of a variable specified by name within ;; a given module, signalling an error if the variable is unbound. ;; If the OPT-VALUE is passed, then instead of signalling an error, @@ -1207,7 +1211,7 @@ (error "Locally unbound variable." v))))) ;; module-symbol-binding module symbol opt-value -;; +;; ;; return the binding of a variable specified by name within ;; a given module, signalling an error if the variable is unbound. ;; If the OPT-VALUE is passed, then instead of signalling an error, @@ -1229,7 +1233,7 @@ ;; module-make-local-var! module symbol -;; +;; ;; ensure a variable for V in the local namespace of M. ;; If no variable was already there, then create a new and uninitialzied ;; variable. @@ -1249,7 +1253,7 @@ answer)))) ;; module-add! module symbol var -;; +;; ;; ensure a particular variable for V in the local namespace of M. ;; (define (module-add! m v var) @@ -1258,8 +1262,8 @@ (module-obarray-set! (module-obarray m) v var) (module-modified m)) -;; module-remove! -;; +;; module-remove! +;; ;; make sure that a symbol is undefined in the local namespace of M. ;; (define (module-remove! m v) @@ -1271,7 +1275,7 @@ (module-modified m)) ;; MODULE-FOR-EACH -- exported -;; +;; ;; Call PROC on each symbol in MODULE, with arguments of (SYMBOL VARIABLE). ;; (define (module-for-each proc module) @@ -1304,9 +1308,9 @@ ;;; {Low Level Bootstrapping} ;;; -;; make-root-module +;; make-root-module -;; A root module uses the symhash table (the system's privileged +;; A root module uses the symhash table (the system's privileged ;; obarray). Being inside a root module is like using SCM without ;; any module system. ;; @@ -1324,7 +1328,7 @@ (make-module 1019 '() root-module-closure)) -;; make-scm-module +;; make-scm-module ;; An scm module is a module into which the lazy binder copies ;; variable bindings from the system symhash table. The mapping is @@ -1383,7 +1387,7 @@ ;; Returns the value of a variable called NAME in MODULE or any of its ;; used modules. If there is no such variable, then if the optional third ;; argument DEFAULT is present, it is returned; otherwise an error is signaled. -;; +;; (define (module-ref module name . rest) (let ((variable (module-variable module name))) (if (and variable (variable-bound? variable)) @@ -1397,7 +1401,7 @@ ;; ;; Sets the variable called NAME in MODULE (or in a module that MODULE uses) ;; to VALUE; if there is no such variable, an error is signaled. -;; +;; (define (module-set! module name value) (let ((variable (module-variable module name))) (if variable @@ -1408,7 +1412,7 @@ ;; ;; Sets the variable called NAME in MODULE to VALUE; if there is no such ;; variable, it is added first. -;; +;; (define (module-define! module name value) (let ((variable (module-local-variable module name))) (if variable @@ -1429,7 +1433,7 @@ ;; MODULE-USE! module interface ;; ;; Add INTERFACE to the list of interfaces used by MODULE. -;; +;; (define (module-use! module interface) (set-module-uses! module (cons interface (delq! interface (module-uses module)))) @@ -1447,7 +1451,7 @@ ;;; modules. ;;; ;;; (nested-ref some-root-module '(foo bar baz)) -;;; => ;;; ;;; @@ -1566,7 +1570,7 @@ (try-load-module name)) ;; Get/create it. (make-modules-in (current-module) full-name)))))) - + (define (beautify-user-module! module) (let ((interface (module-public-interface module))) (if (or (not interface) @@ -1675,7 +1679,7 @@ (loop (cddr kws) reversed-interfaces (append (cadr kws) exports))) - (else + (else (error "unrecognized defmodule argument" kws)))))) (set-current-module module) module)) @@ -1758,9 +1762,9 @@ ;; scm_init_ice_9_gtcltk_module ;; ;; This is your `module init' function. It should call -;; +;; ;; scm_register_module_xxx ("ice-9 gtcltk", scm_init_gtcltk); -;; +;; ;; "ice-9 gtcltk" is the C version of the module name. Slashes are ;; replaced by spaces, the rest is untouched. `scm_init_gtcltk' is ;; the real init function that executes the usual initializations @@ -1901,7 +1905,7 @@ (string-append libname ".la")))) (and (file-exists? libtool-filename) libtool-filename))) - + (define (try-using-sharlib-name libdir libname) (in-vicinity libdir (string-append libname ".so"))) @@ -1959,7 +1963,7 @@ ;; in. The only defined situation right now is `load-toplevel' which ;; triggers for code evaluated at the top-level, for example from the ;; REPL or when loading a file. - + (define eval-case (procedure->memoizing-macro (lambda (exp env) @@ -1968,7 +1972,7 @@ (define (syntax) (error "syntax error in eval-case")) (let loop ((clauses (cdr exp))) - (cond + (cond ((null? clauses) #f) ((not (list? (car clauses))) @@ -2207,7 +2211,7 @@ (let ((status #f) (interactive #t)) (define (loop first) - (let ((next + (let ((next (catch #t (lambda () @@ -2219,7 +2223,7 @@ (with-traps (lambda () (first) - + ;; This line is needed because mark ;; doesn't do closures quite right. ;; Unreferenced locals should be @@ -2232,7 +2236,7 @@ (lambda () (mask-signals)))) lazy-handler-dispatch)) - + (lambda (key . args) (case key ((quit) @@ -2279,7 +2283,7 @@ (apply bad-throw key args)))))))))) (if next (loop next) status))) (set! set-batch-mode?! (lambda (arg) - (cond (arg + (cond (arg (set! interactive #f) (restore-signals)) (#t @@ -2458,7 +2462,7 @@ (primitive-eval sourc)))) (run-hook after-eval-hook sourc) val))) - + (-print (let ((maybe-print (lambda (result) (if (or scm-repl-print-unspecified @@ -2496,7 +2500,7 @@ -eval -print))) (-quit status)))) - + ;;; {IOTA functions: generating lists of numbers} @@ -2693,7 +2697,7 @@ (lambda () (fluid-ref using-readline?)) (lambda (v) (fluid-set! using-readline? v))))) -(define (top-repl) +(define (top-repl) ;; Load emacs interface support if emacs option is given. (if (and (module-defined? the-root-module 'use-emacs-interface) @@ -2701,7 +2705,7 @@ (load-emacs-interface)) ;; Place the user in the guile-user module. - (process-define-module + (process-define-module '((guile-user) :use-module (guile) ;so that bindings will be checked here first :use-module (ice-9 session) @@ -2773,3 +2777,4 @@ (append! %load-path (cons "." '())) +;;; boot-9.scm ends here From a7981b6da6a859339b0330785a52f2388e150eee Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 28 Apr 2001 19:19:26 +0000 Subject: [PATCH 0943/2047] *** empty log message *** --- ice-9/ChangeLog | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 99c046671..5f8fb0964 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,11 @@ +2001-04-28 Thien-Thi Nguyen + + * boot-9.scm, optargs.scm: + Surround commentary w/ standard markers; nfc. + + * threads.scm, time.scm, channel.scm, expect.scm: + Add commentary; nfc. + 2001-04-27 Thien-Thi Nguyen * documentation.scm: Update copyright. From cb869864dd2efea3dbe1445240175dc285b6986f Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sat, 28 Apr 2001 20:54:09 +0000 Subject: [PATCH 0944/2047] * take most of the credit for the manual, at least the unreadable bits. --- doc/THANKS | 2 ++ 1 file changed, 2 insertions(+) diff --git a/doc/THANKS b/doc/THANKS index b3674fbeb..82a5d37ab 100644 --- a/doc/THANKS +++ b/doc/THANKS @@ -2,6 +2,8 @@ The Guile reference manual: - Mark Galassi, for general stewardship - Tim Pierce, for writing sections on script interpreter triggers, alists, function tracing, and splitting the manual into its own module. +- Gary Houston, contributions to posix system calls and networking, + expect, I/O internals and extensions, slib installation, error handling. Proofreading, bug reports and bug fixes from: Marcus Daniels From 370bababdadc9bc93ef4fef1125dcdeaa1842a87 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 28 Apr 2001 23:38:52 +0000 Subject: [PATCH 0945/2047] * Consolidate authorship information in AUTHORS file. * Simplify THANKS file and add in recent contributors. * Add top level menu entry for Manual Conventions node. * Consolidate notes at beginning of guile.texi. --- doc/AUTHORS | 79 +- doc/ChangeLog | 13 + doc/Makefile.am | 6 +- doc/THANKS | 23 +- doc/goops.texi | 2794 -------------------------------------------- doc/guile-tut.texi | 1336 --------------------- doc/guile.texi | 117 +- 7 files changed, 119 insertions(+), 4249 deletions(-) diff --git a/doc/AUTHORS b/doc/AUTHORS index b5fb6a66d..13fc1dede 100644 --- a/doc/AUTHORS +++ b/doc/AUTHORS @@ -1,12 +1,73 @@ -The Guile reference and tutorial manuals were written and edited -largely by Mark Galassi and Jim Blandy. Significant portions were -contributed by Gary Houston and Tim Pierce. +@c This file is in -*-texinfo-*- mode because it gets @included by +@c the top level Texinfo source files for each manual in this +@c distribution. We do this so as to avoid having to maintain +@c authorship information in more than one place. -Tom Lord contributed a great deal of material with early Guile -snapshots; although most of this text has been rewritten, all of it -was important, and much of the structure remains. +@ifset guile -Aubrey Jaffer wrote the SCM Scheme implementation and manual upon -which the Guile program and manual are based. Some portions of the -SCM and SLIB manuals have been included here verbatim. +@c The Guile reference and tutorial manuals were written and edited +@c largely by Mark Galassi and Jim Blandy. +@c Significant portions were contributed by Gary Houston (contributions +@c to posix system calls and networking, expect, I/O internals and +@c extensions, slib installation, error handling) and Tim Pierce +@c (sections on script interpreter triggers, alists, function tracing). + +@c Tom Lord contributed a great deal of material with early Guile +@c snapshots; although most of this text has been rewritten, all of it +@c was important, and much of the structure remains. + +@c Aubrey Jaffer wrote the SCM Scheme implementation and manual upon +@c which the Guile program and manual are based. Some portions of the +@c SCM and SLIB manuals have been included here verbatim. + +@c Since Guile 1.4, Neil Jerram has been maintaining and improving the +@c reference manual. Among other contributions, he wrote the Basic +@c Ideas chapter, developed the tools for keeping the manual in sync +@c with snarfed libguile docstrings, and reorganized the structure so as +@c to accommodate docstrings for all Guile's primitives. + +@author Mark Galassi +@author Cygnus Solution and Los Alamos National Laboratory +@author @email{rosalia@@cygnus.com} +@author +@author Jim Blandy +@author Free Software Foundation and MIT AI Lab +@author @email{jimb@@red-bean.com} +@author +@author Gary Houston +@author @email{ghouston@@arglist.com} +@author +@author Tim Pierce +@author @email{twp@@skepsis.com} +@author +@author Neil Jerram +@author @email{neil@@ossau.uklinux.net} + +@end ifset + +@ifset guile-tut + +@author Mark Galassi +@author Cygnus Solutions and Los Alamos National Laboratory +@author @email{rosalia@@nis.lanl.gov} + +@end ifset + +@ifset goops + +@c The GOOPS tutorial was written by Christian Lynbech and Mikael +@c Djurfeldt, who also wrote GOOPS itself. The GOOPS reference manual +@c and MOP documentation were written by Neil Jerram and reviewed by +@c Mikael Djurfeldt. + +@author Christian Lynbech +@author @email{chl@@tbit.dk} +@author +@author Mikael Djurfeldt +@author @email{djurfeldt@@nada.kth.se} +@author +@author Neil Jerram +@author @email{neil@@ossau.uklinux.net} + +@end ifset diff --git a/doc/ChangeLog b/doc/ChangeLog index a6aa319c7..b94443f5c 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,16 @@ +2001-04-29 Neil Jerram + + * guile.texi (Top): Add menu entry for Manual Conventions node. + +2001-04-28 Neil Jerram + + * THANKS: Move authorship bit into AUTHORS, simplify structure, + add Dirk Herrmann. + + * AUTHORS, guile.texi, guile-tut.texi, goops.texi, Makefile.am: + Consolidate authorship information in AUTHORS file, and @include + AUTHORS from the top level source file for each manual. + 2001-04-28 Thien-Thi Nguyen * preface.texi (Manual Conventions): New chapter. diff --git a/doc/Makefile.am b/doc/Makefile.am index a22dff8bf..9975477f7 100644 --- a/doc/Makefile.am +++ b/doc/Makefile.am @@ -35,9 +35,11 @@ guile_TEXINFOS = preface.texi intro.texi scheme-intro.texi \ scheme-reading.texi scheme-indices.texi slib.texi posix.texi \ expect.texi scsh.texi tcltk.texi scripts.texi gh.texi scm.texi \ appendices.texi indices.texi script-getopt.texi data-rep.texi \ - extend.texi srfi-13-14.texi + extend.texi srfi-13-14.texi AUTHORS -goops_TEXINFOS = goops-tutorial.texi hierarchy.eps hierarchy.txt +guile_tut_TEXINFOS = guile-tut.texi AUTHORS + +goops_TEXINFOS = goops-tutorial.texi hierarchy.eps hierarchy.txt AUTHORS # Optionally support building an HTML version of the reference manual. diff --git a/doc/THANKS b/doc/THANKS index 82a5d37ab..7db6082eb 100644 --- a/doc/THANKS +++ b/doc/THANKS @@ -1,21 +1,18 @@ -The Guile reference manual: -- Mark Galassi, for general stewardship -- Tim Pierce, for writing sections on script interpreter triggers, alists, - function tracing, and splitting the manual into its own module. -- Gary Houston, contributions to posix system calls and networking, - expect, I/O internals and extensions, slib installation, error handling. +Many thanks to the following people for contributing to the Guile +manuals! -Proofreading, bug reports and bug fixes from: +Proofreading, bug reports and patches from: + Chris Bitmead Marcus Daniels + Dirk Herrmann + Dale P. Smith + Steve Tell Lee Thomas + Masao Uebayashi Joel Weber Keith Wright - Chris Bitmead - Dale P. Smith - Masao Uebayashi New entries from: Per Bothner - -Build patches from: - Steve Tell + Martin Grabmueller +Thien Thi Nguyen diff --git a/doc/goops.texi b/doc/goops.texi index 981a7a77d..e69de29bb 100644 --- a/doc/goops.texi +++ b/doc/goops.texi @@ -1,2794 +0,0 @@ -\input texinfo -@c -*-texinfo-*- -@c %**start of header -@setfilename goops.info -@settitle Goops Manual -@setchapternewpage odd -@paragraphindent 0 -@c %**end of header - -@set VERSION 0.3 - -@dircategory The Algorithmic Language Scheme -@direntry -* GOOPS: (goops). The GOOPS reference manual. -@end direntry - -@macro goops -GOOPS -@end macro - -@macro guile -Guile -@end macro - -@ifinfo -This file documents GOOPS, an object oriented extension for Guile. - -Copyright (C) 1999, 2000, 2001 Free Software Foundation - -Permission is granted to make and distribute verbatim copies of -this manual provided the copyright notice and this permission notice -are preserved on all copies. - -@end ifinfo - -@c This title page illustrates only one of the -@c two methods of forming a title page. - -@titlepage -@title Goops Manual -@subtitle For use with GOOPS @value{VERSION} -@author Christian Lynbech -@author @email{chl@@tbit.dk} -@author -@author Mikael Djurfeldt -@author @email{djurfeldt@@nada.kth.se} -@author -@author Neil Jerram -@author @email{neil@@ossau.uklinux.net} - -@c The following two commands -@c start the copyright page. -@page -@vskip 0pt plus 1filll -Copyright @copyright{} 1999 Free Software Foundation - -Permission is granted to make and distribute verbatim copies of -this manual provided the copyright notice and this permission notice -are preserved on all copies. - -@end titlepage - -@node Top, Introduction, (dir), (dir) - -@menu -[When the manual is completed, this will be a flat index in the style of - the Emacs manual. More nodes will turn up under parts I-III.] - -Part I: Preliminaries - -* Introduction:: -* Getting Started:: - -Part II: Reference Manual - -* Reference Manual:: - -Part III: GOOPS Meta Object Protocol - -* MOP Specification:: - -The GOOPS tutorial - -* Tutorial:: - -* Index:: -* Concept Index:: -* Function and Variable Index:: -@end menu - -@iftex -@chapter Preliminaries -@end iftex - -@node Introduction, Getting Started, Top, Top -@section Introduction - -@goops{} is the object oriented extension to @guile{}. Its -implementation is derived from @w{STk-3.99.3} by Erick Gallesio and -version 1.3 of Gregor Kiczales @cite{Tiny-Clos}. It is very close in -spirit to CLOS, the Common Lisp Object System (@cite{CLtL2}) but is -adapted for the Scheme language. While GOOPS is not compatible with any -of these systems, GOOPS contains a compatibility module which allows for -execution of STKlos programs. - -Briefly stated, the @goops{} extension gives the user a full object -oriented system with multiple inheritance and generic functions with -multi-method dispatch. Furthermore, the implementation relies on a true -meta object protocol, in the spirit of the one defined for CLOS -(@cite{Gregor Kiczales: A Metaobject Protocol}). - -@node Getting Started, Reference Manual, Introduction, Top -@section Getting Started - -@menu -* Running GOOPS:: - -Examples of some basic GOOPS functionality. - -* Methods:: -* User-defined types:: -* Asking for the type of an object:: - -See further in the GOOPS tutorial available in this distribution in -info (goops.info) and texinfo format. -@end menu - -@node Running GOOPS, Methods, Getting Started, Getting Started -@subsection Running GOOPS - -@enumerate -@item -Type - -@smalllisp -guile-oops -@end smalllisp - -You should now be at the Guile prompt ("guile> "). - -@item -Type - -@smalllisp -(use-modules (oop goops)) -@end smalllisp - -to load GOOPS. (If your system supports dynamic loading, you -should be able to do this not only from `guile-oops' but from an -arbitrary Guile interpreter.) -@end enumerate - -We're now ready to try some basic GOOPS functionality. - -@node Methods, User-defined types, Running GOOPS, Getting Started -@subsection Methods - -@smalllisp -@group -(define-method (+ (x ) (y )) - (string-append x y)) - -(+ 1 2) --> 3 -(+ "abc" "de") --> "abcde" -@end group -@end smalllisp - -@node User-defined types, Asking for the type of an object, Methods, Getting Started -@subsection User-defined types - -@smalllisp -(define-class <2D-vector> () - (x #:init-value 0 #:accessor x-component #:init-keyword #:x) - (y #:init-value 0 #:accessor y-component #:init-keyword #:y)) - -@group -(use-modules (ice-9 format)) - -(define-method (write (obj <2D-vector>) port) - (display (format #f "<~S, ~S>" (x-component obj) (y-component obj)) - port)) - -(define v (make <2D-vector> #:x 3 #:y 4)) - -v --> <3, 4> -@end group - -@group -(define-method (+ (x <2D-vector>) (y <2D-vector>)) - (make <2D-vector> - #:x (+ (x-component x) (x-component y)) - #:y (+ (y-component x) (y-component y)))) - -(+ v v) --> <6, 8> -@end group -@end smalllisp - -@node Asking for the type of an object, , User-defined types, Getting Started -@subsection Types - -@example -(class-of v) --> #< <2D-vector> 40241ac0> -<2D-vector> --> #< <2D-vector> 40241ac0> -(class-of 1) --> #< 401b2a98> - --> #< 401b2a98> - -(is-a? v <2D-vector>) --> #t -@end example - -@node Reference Manual, MOP Specification, Getting Started, Top -@chapter Reference Manual - -This chapter is the GOOPS reference manual. It aims to describe all the -syntax, procedures, options and associated concepts that a typical -application author would need to understand in order to use GOOPS -effectively in their application. It also describes what is meant by -the GOOPS ``metaobject protocol'' (aka ``MOP''), and indicates how -authors can use the metaobject protocol to customize the behaviour of -GOOPS itself. - -For a detailed specification of the GOOPS metaobject protocol, see -@ref{MOP Specification}. - -@menu -* Introductory Remarks:: -* Defining New Classes:: -* Creating Instances:: -* Accessing Slots:: -* Creating Generic Functions:: -* Adding Methods to Generic Functions:: -* Invoking Generic Functions:: -* Redefining a Class:: -* Changing the Class of an Instance:: -* Introspection:: -* Miscellaneous Functions:: -@end menu - -@node Introductory Remarks -@section Introductory Remarks - -GOOPS is an object-oriented programming system based on a ``metaobject -protocol'' derived from the ones used in CLOS (the Common Lisp Object -System), tiny-clos (a small Scheme implementation of a subset of CLOS -functionality) and STKlos. - -GOOPS can be used by application authors at a basic level without any -need to understand what the metaobject protocol (aka ``MOP'') is and how -it works. On the other hand, the MOP underlies even the customizations -that application authors are likely to make use of very quickly --- such -as defining an @code{initialize} method to customize the initialization -of instances of an application-defined class --- and an understanding of -the MOP makes it much easier to explain such customizations in a precise -way. And in the long run, understanding the MOP is the key both to -understanding GOOPS at a deeper level and to taking full advantage of -GOOPS' power, by customizing the behaviour of GOOPS itself. - -Each of the following sections of the reference manual is arranged -such that the most basic usage is introduced first, and then subsequent -subsections discuss the related internal functions and metaobject -protocols, finishing with a description of how to customize that area of -functionality. - -These introductory remarks continue with a few words about metaobjects -and the MOP. Readers who do not want to be bothered yet with the MOP -and customization could safely skip this subsection on a first reading, -and should correspondingly skip subsequent subsections that are -concerned with internals and customization. - -In general, this reference manual assumes familiarity with standard -object oriented concepts and terminology. However, some of the terms -used in GOOPS is less well known, so the Terminology subsection -provides definitions for these terms. - -@menu -* Metaobjects and the Metaobject Protocol:: -* Terminology:: -@end menu - -@node Metaobjects and the Metaobject Protocol -@subsection Metaobjects and the Metaobject Protocol - -The conceptual building blocks of GOOPS are classes, slot definitions, -instances, generic functions and methods. A class is a grouping of -inheritance relations and slot definitions. An instance is an object -with slots that are allocated following the rules implied by its class's -superclasses and slot definitions. A generic function is a collection -of methods and rules for determining which of those methods to apply -when the generic function is invoked. A method is a procedure and a set -of specializers that specify the type of arguments to which the -procedure is applicable. - -Of these entities, GOOPS represents classes, generic functions and -methods as ``metaobjects''. In other words, the values in a GOOPS -program that describe classes, generic functions and methods, are -themselves instances (or ``objects'') of special GOOPS classes that -encapsulate the behaviour, respectively, of classes, generic functions, -and methods. - -(The other two entities are slot definitions and instances. Slot -definitions are not strictly instances, but every slot definition is -associated with a GOOPS class that specifies the behaviour of the slot -as regards accessibility and protection from garbage collection. -Instances are of course objects in the usual sense, and there is no -benefit from thinking of them as metaobjects.) - -The ``metaobject protocol'' (aka ``MOP'') is the specification of the -generic functions which determine the behaviour of these metaobjects and -the circumstances in which these generic functions are invoked. - -For a concrete example of what this means, consider how GOOPS calculates -the set of slots for a class that is being defined using -@code{define-class}. The desired set of slots is the union of the new -class's direct slots and the slots of all its superclasses. But -@code{define-class} itself does not perform this calculation. Instead, -there is a method of the @code{initialize} generic function that is -specialized for instances of type @code{}, and it is this method -that performs the slot calculation. - -@code{initialize} is a generic function which GOOPS calls whenever a new -instance is created, immediately after allocating memory for a new -instance, in order to initialize the new instance's slots. The sequence -of steps is as follows. - -@itemize @bullet -@item -@code{define-class} uses @code{make} to make a new instance of the -@code{}, passing as initialization arguments the superclasses, -slot definitions and class options that were specified in the -@code{define-class} form. - -@item -@code{make} allocates memory for the new instance, and then invokes the -@code{initialize} generic function to initialize the new instance's -slots. - -@item -The @code{initialize} generic function applies the method that is -specialized for instances of type @code{}, and this method -performs the slot calculation. -@end itemize - -In other words, rather than being hardcoded in @code{define-class}, the -behaviour of class definition is encapsulated by generic function -methods that are specialized for the class @code{}. - -It is possible to create a new class that inherits from @code{}, -which is called a ``metaclass'', and to write a new @code{initialize} -method that is specialized for instances of the new metaclass. Then, if -the @code{define-class} form includes a @code{#:metaclass} class option -whose value is the new metaclass, the class that is defined by the -@code{define-class} form will be an instance of the new metaclass rather -than of the default @code{}, and will be defined in accordance -with the new @code{initialize} method. Thus the default slot -calculation, as well as any other aspect of the new class's relationship -with its superclasses, can be modified or overridden. - -In a similar way, the behaviour of generic functions can be modified or -overridden by creating a new class that inherits from the standard -generic function class @code{}, writing appropriate methods -that are specialized to the new class, and creating new generic -functions that are instances of the new class. - -The same is true for method metaobjects. And the same basic mechanism -allows the application class author to write an @code{initialize} method -that is specialized to their application class, to initialize instances -of that class. - -Such is the power of the MOP. Note that @code{initialize} is just one -of a large number of generic functions that can be customized to modify -the behaviour of application objects and classes and of GOOPS itself. -Each subsequent section of the reference manual covers a particular area -of GOOPS functionality, and describes the generic functions that are -relevant for customization of that area. - -We conclude this subsection by emphasizing a point that may seem -obvious, but contrasts with the corresponding situation in some other -MOP implementations, such as CLOS. The point is simply that an -identifier which represents a GOOPS class or generic function is a -variable with a first-class value, the value being an instance of class -@code{} or @code{}. (In CLOS, on the other hand, a -class identifier is a symbol that indexes the corresponding class -metaobject in a separate namespace for classes.) This is, of course, -simply an extension of the tendency in Scheme to avoid the unnecessary -use of, on the one hand, syntactic forms that require unevaluated -arguments and, on the other, separate identifier namespaces (e.g. for -class names), but it is worth noting that GOOPS conforms fully to this -Schemely principle. - -@node Terminology -@subsection Terminology - -It is assumed that the reader is already familiar with standard object -orientation concepts such as classes, objects/instances, -inheritance/subclassing, generic functions and methods, encapsulation -and polymorphism. - -This section explains some of the less well known concepts and -terminology that GOOPS uses, which are assumed by the following sections -of the reference manual. - -@menu -* Metaclass:: -* Class Precedence List:: -* Accessor:: -@end menu - -@node Metaclass -@subsubsection Metaclass - -A @dfn{metaclass} is the class of an object which represents a GOOPS -class. Put more succinctly, a metaclass is a class's class. - -Most GOOPS classes have the metaclass @code{} and, by default, -any new class that is created using @code{define-class} has the -metaclass @code{}. - -But what does this really mean? To find out, let's look in more detail -at what happens when a new class is created using @code{define-class}: - -@example -(define-class () . slots) -@end example - -GOOPS actually expands the @code{define-class} form to something like -this - -@example -(define (class () . slots)) -@end example - -and thence to - -@example -(define - (make #:supers (list ) #:slots slots)) -@end example - -In other words, the value of @code{} is in fact an instance of -the class @code{} with slot values specifying the superclasses -and slot definitions for the class @code{}. (@code{#:supers} -and @code{#:slots} are initialization keywords for the @code{dsupers} -and @code{dslots} slots of the @code{} class.) - -In order to take advantage of the full power of the GOOPS metaobject -protocol (@pxref{MOP Specification}), it is sometimes desirable to -create a new class with a metaclass other than the default -@code{}. This is done by writing: - -@example -(define-class () - slot @dots{} - #:metaclass ) -@end example - -GOOPS expands this to something like: - -@example -(define - (make #:supers (list ) #:slots slots)) -@end example - -In this case, the value of @code{} is an instance of the more -specialized class @code{}. Note that -@code{} itself must previously have been defined as a -subclass of @code{}. For a full discussion of when and how it is -useful to define new metaclasses, see @ref{MOP Specification}. - -Now let's make an instance of @code{}: - -@example -(define my-object (make ...)) -@end example - -All of the following statements are correct expressions of the -relationships between @code{my-object}, @code{}, -@code{} and @code{}. - -@itemize @bullet -@item -@code{my-object} is an instance of the class @code{}. - -@item -@code{} is an instance of the class @code{}. - -@item -@code{} is an instance of the class @code{}. - -@item -The class of @code{my-object} is @code{}. - -@item -The metaclass of @code{my-object} is @code{}. - -@item -The class of @code{} is @code{}. - -@item -The metaclass of @code{} is @code{}. - -@item -The class of @code{} is @code{}. - -@item -The metaclass of @code{} is @code{}. - -@item -@code{} is not a metaclass, since it is does not inherit from -@code{}. - -@item -@code{} is a metaclass, since it inherits from -@code{}. -@end itemize - -@node Class Precedence List -@subsubsection Class Precedence List - -The @dfn{class precedence list} of a class is the list of all direct and -indirect superclasses of that class, including the class itself. - -In the absence of multiple inheritance, the class precedence list is -ordered straightforwardly, beginning with the class itself and ending -with @code{}. - -For example, given this inheritance hierarchy: - -@example -(define-class () @dots{}) -(define-class () @dots{}) -(define-class () @dots{}) -@end example - -the class precedence list of would be - -@example -( ) -@end example - -With multiple inheritance, the algorithm is a little more complicated. -A full description is provided by the GOOPS Tutorial: see @ref{Class -precedence list}. - -``Class precedence list'' is often abbreviated, in documentation and -Scheme variable names, to @dfn{cpl}. - -@node Accessor -@subsubsection Accessor - -An @dfn{accessor} is a generic function with both reference and setter -methods. - -@example -(define-accessor perimeter) -@end example - -Reference methods for an accessor are defined in the same way as generic -function methods. - -@example -(define-method (perimeter (s )) - (* 4 (side-length s))) -@end example - -Setter methods for an accessor are defined by specifying ``(setter -)'' as the first parameter of the @code{define-method} -call. - -@example -(define-method ((setter perimeter) (s ) (n )) - (set! (side-length s) (/ n 4))) -@end example - -Once an appropriate setter method has been defined in this way, it can -be invoked using the generalized @code{set!} syntax, as in: - -@example -(set! (perimeter s1) 18.3) -@end example - -@node Defining New Classes -@section Defining New Classes - -[ *fixme* Somewhere in this manual there needs to be an introductory -discussion about GOOPS classes, generic functions and methods, covering - -@itemize @bullet -@item -how classes encapsulate related items of data in @dfn{slots} - -@item -why it is that, unlike in C++ and Java, a class does not encapsulate the -methods that act upon the class (at least not in the C++/Java sense) - -@item -how generic functions provide a more general solution that provides for -dispatch on all argument types, and avoids idiosyncracies like C++'s -friend classes - -@item -how encapsulation in the sense of data- and code-hiding, or of -distinguishing interface from implementation, is treated in Guile as an -orthogonal concept to object orientation, and is the responsibility of -the module system. -@end itemize - -Some of this is covered in the Tutorial chapter, in @ref{Generic -functions and methods} - perhaps the best solution would be to expand -the discussion there. ] - -@menu -* Basic Class Definition:: -* Class Options:: -* Slot Options:: -* Class Definition Internals:: -* Customizing Class Definition:: -* STKlos Compatibility:: -@end menu - -@node Basic Class Definition -@subsection Basic Class Definition - -New classes are defined using the @code{define-class} syntax, with -arguments that specify the classes that the new class should inherit -from, the direct slots of the new class, and any required class options. - -@deffn syntax define-class name (super @dots{}) slot-definition @dots{} . options -Define a class called @var{name} that inherits from @var{super}s, with -direct slots defined by @var{slot-definition}s and class options -@var{options}. The newly created class is bound to the variable name -@var{name} in the current environment. - -Each @var{slot-definition} is either a symbol that names the slot or a -list, - -@example -(@var{slot-name-symbol} . @var{slot-options}) -@end example - -where @var{slot-name-symbol} is a symbol and @var{slot-options} is a -list with an even number of elements. The even-numbered elements of -@var{slot-options} (counting from zero) are slot option keywords; the -odd-numbered elements are the corresponding values for those keywords. - -@var{options} is a similarly structured list containing class option -keywords and corresponding values. -@end deffn - -The standard GOOPS class and slot options are described in the following -subsections: see @ref{Class Options} and @ref{Slot Options}. - -Example 1. Define a class that combines two pre-existing classes by -inheritance but adds no new slots. - -@example -(define-class ( )) -@end example - -Example 2. Define a @code{regular-polygon} class with slots for side -length and number of sides that have default values and can be accessed -via the generic functions @code{side-length} and @code{num-sides}. - -@example -(define-class () - (sl #:init-value 1 #:accessor side-length) - (ns #:init-value 5 #:accessor num-sides)) -@end example - -Example 3. Define a class whose behavior (and that of its instances) is -customized via an application-defined metaclass. - -@example -(define-class () - (s #:init-value #f #:accessor state) - ... - #:metaclass ) -@end example - -@node Class Options -@subsection Class Options - -@deffn {class option} #:metaclass metaclass -The @code{#:metaclass} class option specifies the metaclass of the class -being defined. @var{metaclass} must be a class that inherits from -@code{}. For an introduction to the use of metaclasses, see -@ref{Metaobjects and the Metaobject Protocol} and @ref{Metaclass}. - -If the @code{#:metaclass} option is absent, GOOPS reuses or constructs a -metaclass for the new class by calling @code{ensure-metaclass} -(@pxref{Class Definition Internals,, ensure-metaclass}). -@end deffn - -@deffn {class option} #:name name -The @code{#:name} class option specifies the new class's name. This -name is used to identify the class whenever related objects - the class -itself, its instances and its subclasses - are printed. - -If the @code{#:name} option is absent, GOOPS uses the first argument to -@code{define-class} as the class name. -@end deffn - -@deffn {class option} #:environment environment -*fixme* Not sure about this one, but I think that the -@code{#:environment} option specifies the environment in which the -class's getters and setters are computed and evaluated. - -If the @code{#:environment} option is not specified, the class's -environment defaults to the top-level environment in which the -@code{define-class} form appears. -@end deffn - -@node Slot Options -@subsection Slot Options - -@deffn {slot option} #:allocation allocation -The @code{#:allocation} option tells GOOPS how to allocate storage for -the slot. Possible values for @var{allocation} are - -@itemize @bullet -@item @code{#:instance} - -Indicates that GOOPS should create separate storage for this slot in -each new instance of the containing class (and its subclasses). - -@item @code{#:class} - -Indicates that GOOPS should create storage for this slot that is shared -by all instances of the containing class (and its subclasses). In other -words, a slot in class @var{C} with allocation @code{#:class} is shared -by all @var{instance}s for which @code{(is-a? @var{instance} @var{c})}. - -@item @code{#:each-subclass} - -Indicates that GOOPS should create storage for this slot that is shared -by all @emph{direct} instances of the containing class, and that -whenever a subclass of the containing class is defined, GOOPS should -create a new storage for the slot that is shared by all @emph{direct} -instances of the subclass. In other words, a slot with allocation -@code{#:each-subclass} is shared by all instances with the same -@code{class-of}. - -@item @code{#:virtual} - -Indicates that GOOPS should not allocate storage for this slot. The -slot definition must also include the @code{#:slot-ref} and -@code{#:slot-set!} options to specify how to reference and set the value -for this slot. -@end itemize - -The default value is @code{#:instance}. - -Slot allocation options are processed when defining a new class by the -generic function @code{compute-get-n-set}, which is specialized by the -class's metaclass. Hence new types of slot allocation can be -implemented by defining a new metaclass and a method for -@code{compute-get-n-set} that is specialized for the new metaclass. For -an example of how to do this, see @ref{Customizing Class Definition}. -@end deffn - -@deffn {slot option} #:slot-ref getter -@deffnx {slot option} #:slot-set! setter -The @code{#:slot-ref} and @code{#:slot-set!} options must be specified -if the slot allocation is @code{#:virtual}, and are ignored otherwise. - -@var{getter} should be a closure taking a single @var{instance} parameter -that returns the current slot value. @var{setter} should be a closure -taking two parameters - @var{instance} and @var{new-val} - that sets the -slot value to @var{new-val}. -@end deffn - -@deffn {slot option} #:getter getter -@deffnx {slot option} #:setter setter -@deffnx {slot option} #:accessor accessor -These options, if present, tell GOOPS to create generic function and -method definitions that can be used to get and set the slot value more -conveniently than by using @code{slot-ref} and @code{slot-set!}. - -@var{getter} specifies a generic function to which GOOPS will add a -method for getting the slot value. @var{setter} specifies a generic -function to which GOOPS will add a method for setting the slot value. -@var{accessor} specifies an accessor to which GOOPS will add methods for -both getting and setting the slot value. - -So if a class includes a slot definition like this: - -@example -(c #:getter get-count #:setter set-count #:accessor count) -@end example - -GOOPS defines generic function methods such that the slot value can be -referenced using either the getter or the accessor - - -@example -(let ((current-count (get-count obj))) @dots{}) -(let ((current-count (count obj))) @dots{}) -@end example - -- and set using either the setter or the accessor - - -@example -(set-count obj (+ 1 current-count)) -(set! (count obj) (+ 1 current-count)) -@end example - -Note that - -@itemize @bullet -@item -with an accessor, the slot value is set using the generalized -@code{set!} syntax - -@item -in practice, it is unusual for a slot to use all three of these options: -read-only, write-only and read-write slots would typically use only -@code{#:getter}, @code{#:setter} and @code{#:accessor} options -respectively. -@end itemize - -If the specified names are already bound in the top-level environment to -values that cannot be upgraded to generic functions, those values are -overwritten during evaluation of the @code{define-class} that contains -the slot definition. For details, see @ref{Generic Function Internals,, -ensure-generic}. -@end deffn - -@deffn {slot option} #:init-value init-value -@deffnx {slot option} #:init-form init-form -@deffnx {slot option} #:init-thunk init-thunk -@deffnx {slot option} #:init-keyword init-keyword -These options provide various ways to specify how to initialize the -slot's value at instance creation time. @var{init-value} is a fixed -value. @var{init-thunk} is a procedure of no arguments that is called -when a new instance is created and should return the desired initial -slot value. @var{init-form} is an unevaluated expression that gets -evaluated when a new instance is created and should return the desired -initial slot value. @var{init-keyword} is a keyword that can be used to -pass an initial slot value to @code{make} when creating a new instance. - -If more than one of these options is specified for the same slot, the -order of precedence, highest first is - -@itemize @bullet -@item -@code{#:init-keyword}, if @var{init-keyword} is present in the options -passed to @code{make} - -@item -@code{#:init-thunk}, @code{#:init-form} or @code{#:init-value}. -@end itemize - -If the slot definition contains more than one initialization option of -the same precedence, the later ones are ignored. If a slot is not -initialized at all, its value is unbound. - -In general, slots that are shared between more than one instance are -only initialized at new instance creation time if the slot value is -unbound at that time. However, if the new instance creation specifies -a valid init keyword and value for a shared slot, the slot is -re-initialized regardless of its previous value. - -Note, however, that the power of GOOPS' metaobject protocol means that -everything written here may be customized or overridden for particular -classes! The slot initializations described here are performed by the least -specialized method of the generic function @code{initialize}, whose -signature is - -@example -(define-method (initialize (object ) initargs) ...) -@end example - -The initialization of instances of any given class can be customized by -defining a @code{initialize} method that is specialized for that class, -and the author of the specialized method may decide to call -@code{next-method} - which will result in a call to the next less -specialized @code{initialize} method - at any point within the -specialized code, or maybe not at all. In general, therefore, the -initialization mechanisms described here may be modified or overridden by -more specialized code, or may not be supported at all for particular -classes. -@end deffn - -@node Class Definition Internals -@subsection Class Definition Internals - -Implementation notes: @code{define-class} expands to an expression which - -@itemize @bullet -@item -checks that it is being evaluated only at top level - -@item -defines any accessors that are implied by the @var{slot-definition}s - -@item -uses @code{class} to create the new class (@pxref{Class Definition -Internals,, class}) - -@item -checks for a previous class definition for @var{name} and, if found, -handles the redefinition by invoking @code{class-redefinition} -(@pxref{Redefining a Class}). -@end itemize - -@deffn syntax class name (super @dots{}) slot-definition @dots{} . options -Return a newly created class that inherits from @var{super}s, with -direct slots defined by @var{slot-definition}s and class options -@var{options}. For the format of @var{slot-definition}s and -@var{options}, see @ref{Basic Class Definition,, define-class}. -@end deffn - -Implementation notes: @code{class} expands to an expression which - -@itemize @bullet -@item -processes the class and slot definition options to check that they are -well-formed, to convert the @code{#:init-form} option to an -@code{#:init-thunk} option, to supply a default environment parameter -(the current top-level environment) and to evaluate all the bits that -need to be evaluated - -@item -calls @code{make-class} to create the class with the processed and -evaluated parameters. -@end itemize - -@deffn procedure make-class supers slots . options -Return a newly created class that inherits from @var{supers}, with -direct slots defined by @var{slots} and class options @var{options}. -For the format of @var{slots} and @var{options}, see @ref{Basic Class -Definition,, define-class}, except note that for @code{make-class}, -@var{slots} and @var{options} are separate list parameters: @var{slots} -here is a list of slot definitions. -@end deffn - -Implementation notes: @code{make-class} - -@itemize @bullet -@item -adds @code{} to the @var{supers} list if @var{supers} is empty -or if none of the classes in @var{supers} have @code{} in their -class precedence list - -@item -defaults the @code{#:environment}, @code{#:name} and @code{#:metaclass} -options, if they are not specified by @var{options}, to the current -top-level environment, the unbound value, and @code{(ensure-metaclass -@var{supers})} respectively (@pxref{Class Definition Internals,, -ensure-metaclass}) - -@item -checks for duplicate classes in @var{supers} and duplicate slot names in -@var{slots}, and signals an error if there are any duplicates - -@item -calls @code{make}, passing the metaclass as the first parameter and all -other parameters as option keywords with values. -@end itemize - -@deffn procedure ensure-metaclass supers env -Return a metaclass suitable for a class that inherits from the list of -classes in @var{supers}. The returned metaclass is the union by -inheritance of the metaclasses of the classes in @var{supers}. - -In the simplest case, where all the @var{supers} are straightforward -classes with metaclass @code{}, the returned metaclass is just -@code{}. - -For a more complex example, suppose that @var{supers} contained one -class with metaclass @code{} and one with metaclass -@code{}. Then the returned metaclass would be a -class that inherits from both @code{} and -@code{}. - -If @var{supers} is the empty list, @code{ensure-metaclass} returns the -default GOOPS metaclass @code{}. - -GOOPS keeps a list of the metaclasses created by -@code{ensure-metaclass}, so that each required type of metaclass only -has to be created once. - -The @code{env} parameter is ignored. -@end deffn - -@deffn procedure ensure-metaclass-with-supers meta-supers -@code{ensure-metaclass-with-supers} is an internal procedure used by -@code{ensure-metaclass} (@pxref{Class Definition Internals,, -ensure-metaclass}). It returns a metaclass that is the union by -inheritance of the metaclasses in @var{meta-supers}. -@end deffn - -The internals of @code{make}, which is ultimately used to create the new -class object, are described in @ref{Customizing Instance Creation}, -which covers the creation and initialization of instances in general. - -@node Customizing Class Definition -@subsection Customizing Class Definition - -During the initialization of a new class, GOOPS calls a number of generic -functions with the newly allocated class instance as the first -argument. Specifically, GOOPS calls the generic function - -@itemize @bullet -@item -(initialize @var{class} @dots{}) -@end itemize - -where @var{class} is the newly allocated class instance, and the default -@code{initialize} method for arguments of type @code{} calls the -generic functions - -@itemize @bullet -@item -(compute-cpl @var{class}) - -@item -(compute-slots @var{class}) - -@item -(compute-get-n-set @var{class} @var{slot-def}), for each of the slot -definitions returned by @code{compute-slots} - -@item -(compute-getter-method @var{class} @var{slot-def}), for each of the -slot definitions returned by @code{compute-slots} that includes a -@code{#:getter} or @code{#:accessor} slot option - -@item -(compute-setter-method @var{class} @var{slot-def}), for each of the -slot definitions returned by @code{compute-slots} that includes a -@code{#:setter} or @code{#:accessor} slot option. -@end itemize - -If the metaclass of the new class is something more specialized than the -default @code{}, then the type of @var{class} in the calls above -is more specialized than @code{}, and hence it becomes possible -to define generic function methods, specialized for the new class's -metaclass, that can modify or override the default behaviour of -@code{initialize}, @code{compute-cpl} or @code{compute-get-n-set}. - -@code{compute-cpl} computes the class precedence list (``CPL'') for the -new class (@pxref{Class precedence list}), and returns it as a list of -class objects. The CPL is important because it defines a superclass -ordering that is used, when a generic function is invoked upon an -instance of the class, to decide which of the available generic function -methods is the most specific. Hence @code{compute-cpl} could be -customized in order to modify the CPL ordering algorithm for all classes -with a special metaclass. - -The default CPL algorithm is encapsulated by the @code{compute-std-cpl} -procedure, which is in turn called by the default @code{compute-cpl} -method. - -@deffn procedure compute-std-cpl class -Compute and return the class precedence list for @var{class} according -to the algorithm described in @ref{Class precedence list}. -@end deffn - -@code{compute-slots} computes and returns a list of all slot definitions -for the new class. By default, this list includes the direct slot -definitions from the @code{define-class} form, plus the slot definitions -that are inherited from the new class's superclasses. The default -@code{compute-slots} method uses the CPL computed by @code{compute-cpl} -to calculate this union of slot definitions, with the rule that slots -inherited from superclasses are shadowed by direct slots with the same -name. One possible reason for customizing @code{compute-slots} would be -to implement an alternative resolution strategy for slot name conflicts. - -@code{compute-get-n-set} computes the low-level closures that will be -used to get and set the value of a particular slot, and returns them in -a list with two elements. - -The closures returned depend on how storage for that slot is allocated. -The standard @code{compute-get-n-set} method, specialized for classes of -type @code{}, handles the standard GOOPS values for the -@code{#:allocation} slot option (@pxref{Slot Options,, allocation}). By -defining a new @code{compute-get-n-set} method for a more specialized -metaclass, it is possible to support new types of slot allocation. - -Suppose you wanted to create a large number of instances of some class -with a slot that should be shared between some but not all instances of -that class - say every 10 instances should share the same slot storage. -The following example shows how to implement and use a new type of slot -allocation to do this. - -@example -(define-class ()) - -(let ((batch-allocation-count 0) - (batch-get-n-set #f)) - (define-method (compute-get-n-set (class ) s) - (case (slot-definition-allocation s) - ((#:batched) - ;; If we've already used the same slot storage for 10 instances, - ;; reset variables. - (if (= batch-allocation-count 10) - (begin - (set! batch-allocation-count 0) - (set! batch-get-n-set #f))) - ;; If we don't have a current pair of get and set closures, - ;; create one. make-closure-variable returns a pair of closures - ;; around a single Scheme variable - see goops.scm for details. - (or batch-get-n-set - (set! batch-get-n-set (make-closure-variable))) - ;; Increment the batch allocation count. - (set! batch-allocation-count (+ batch-allocation-count 1)) - batch-get-n-set) - - ;; Call next-method to handle standard allocation types. - (else (next-method))))) - -(define-class () - ... - (c #:allocation #:batched) - ... - #:metaclass ) -@end example - -The usage of @code{compute-getter-method} and @code{compute-setter-method} -is described in @ref{MOP Specification}. - -@code{compute-cpl} and @code{compute-get-n-set} are called by the -standard @code{initialize} method for classes whose metaclass is -@code{}. But @code{initialize} itself can also be modified, by -defining an @code{initialize} method specialized to the new class's -metaclass. Such a method could complete override the standard -behaviour, by not calling @code{(next-method)} at all, but more -typically it would perform additional class initialization steps before -and/or after calling @code{(next-method)} for the standard behaviour. - -@node STKlos Compatibility -@subsection STKlos Compatibility - -If the STKlos compatibility module is loaded, @code{define-class} is -overwritten by a STKlos-specific definition; the standard GOOPS -definition of @code{define-class} remains available in -@code{standard-define-class}. - -@deffn syntax standard-define-class name (super @dots{}) slot-definition @dots{} . options -@code{standard-define-class} is equivalent to the standard GOOPS -@code{define-class}. -@end deffn - -@node Creating Instances -@section Creating Instances - -@menu -* Basic Instance Creation:: -* Customizing Instance Creation:: -@end menu - -@node Basic Instance Creation -@subsection Basic Instance Creation - -To create a new instance of any GOOPS class, use the generic function -@code{make} or @code{make-instance}, passing the required class and any -appropriate instance initialization arguments as keyword and value -pairs. Note that @code{make} and @code{make-instances} are aliases for -each other - their behaviour is identical. - -@deffn generic make -@deffnx method make (class ) . initargs -Create and return a new instance of class @var{class}, initialized using -@var{initargs}. - -In theory, @var{initargs} can have any structure that is understood by -whatever methods get applied when the @code{initialize} generic function -is applied to the newly allocated instance. - -In practice, specialized @code{initialize} methods would normally call -@code{(next-method)}, and so eventually the standard GOOPS -@code{initialize} methods are applied. These methods expect -@var{initargs} to be a list with an even number of elements, where -even-numbered elements (counting from zero) are keywords and -odd-numbered elements are the corresponding values. - -GOOPS processes initialization argument keywords automatically for slots -whose definition includes the @code{#:init-keyword} option (@pxref{Slot -Options,, init-keyword}). Other keyword value pairs can only be -processed by an @code{initialize} method that is specialized for the new -instance's class. Any unprocessed keyword value pairs are ignored. -@end deffn - -@deffn generic make-instance -@deffnx method make-instance (class ) . initargs -@code{make-instance} is an alias for @code{make}. -@end deffn - -@node Customizing Instance Creation -@subsection Customizing Instance Creation - -@code{make} itself is a generic function. Hence the @code{make} -invocation itself can be customized in the case where the new instance's -metaclass is more specialized than the default @code{}, by -defining a @code{make} method that is specialized to that metaclass. - -Normally, however, the method for classes with metaclass @code{} -will be applied. This method calls two generic functions: - -@itemize @bullet -@item -(allocate-instance @var{class} . @var{initargs}) - -@item -(initialize @var{instance} . @var{initargs}) -@end itemize - -@code{allocate-instance} allocates storage for and returns the new -instance, uninitialized. You might customize @code{allocate-instance}, -for example, if you wanted to provide a GOOPS wrapper around some other -object programming system. - -To do this, you would create a specialized metaclass, which would act as -the metaclass for all classes and instances from the other system. Then -define an @code{allocate-instance} method, specialized to that -metaclass, which calls a Guile primitive C function, which in turn -allocates the new instance using the interface of the other object -system. - -In this case, for a complete system, you would also need to customize a -number of other generic functions like @code{make} and -@code{initialize}, so that GOOPS knows how to make classes from the -other system, access instance slots, and so on. - -@code{initialize} initializes the instance that is returned by -@code{allocate-instance}. The standard GOOPS methods perform -initializations appropriate to the instance class. - -@itemize @bullet -@item -At the least specialized level, the method for instances of type -@code{} performs internal GOOPS instance initialization, and -initializes the instance's slots according to the slot definitions and -any slot initialization keywords that appear in @var{initargs}. - -@item -The method for instances of type @code{} calls -@code{(next-method)}, then performs the class initializations described -in @ref{Customizing Class Definition}. - -@item -and so on for generic functions, method, operator classes @dots{} -@end itemize - -Similarly, you can customize the initialization of instances of any -application-defined class by defining an @code{initialize} method -specialized to that class. - -Imagine a class whose instances' slots need to be initialized at -instance creation time by querying a database. Although it might be -possible to achieve this a combination of @code{#:init-thunk} keywords -and closures in the slot definitions, it is neater to write an -@code{initialize} method for the class that queries the database once -and initializes all the dependent slot values according to the results. - -@node Accessing Slots -@section Accessing Slots - -The definition of a slot contains at the very least a slot name, and may -also contain various slot options, including getter, setter and/or -accessor functions for the slot. - -It is always possible to access slots by name, using the various -``slot-ref'' and ``slot-set!'' procedures described in the following -subsections. For example, - -@example -(define-class () ;; Define a class with slots - (count #:init-value 0) ;; named "count" and "cache". - (cache #:init-value '()) - @dots{}) - -(define inst (make )) ;; Make an instance of this class. - -(slot-set! inst 'count 5) ;; Set the value of the "count" - ;; slot to 5. - -(slot-set! inst 'cache ;; Modify the value of the - (cons (cons "^it" "It") ;; "cache" slot. - (slot-ref inst 'cache))) -@end example - -If a slot definition includes a getter, setter or accessor function, -these can be used instead of @code{slot-ref} and @code{slot-set!} to -access the slot. - -@example -(define-class () ;; Define a new class whose slots - (count #:setter set-count) ;; use a getter, a setter and - (cache #:accessor cache) ;; an accessor. - (csize #:getter cache-size) - @dots{}) - -(define inst (make )) ;; Make an instance of this class. - -(set-count inst 5) ;; Set the value of the "count" - ;; slot to 5. - -(set! (cache inst) ;; Modify the value of the - (cons (cons "^it" "It") ;; "cache" slot. - (cache inst))) - -(let ((size (cache-size inst))) ;; Get the value of the "csize" - @dots{}) ;; slot. -@end example - -Whichever of these methods is used to access slots, GOOPS always calls -the low-level @dfn{getter} and @dfn{setter} closures for the slot to get -and set its value. These closures make sure that the slot behaves -according to the @code{#:allocation} type that was specified in the slot -definition (@pxref{Slot Options,, allocation}). (For more about these -closures, see @ref{Customizing Class Definition,, compute-get-n-set}.) - -@menu -* Instance Slots:: -* Class Slots:: -* Handling Slot Access Errors:: -@end menu - -@node Instance Slots -@subsection Instance Slots - -Any slot, regardless of its allocation, can be queried, referenced and -set using the following four primitive procedures. - -@deffn {primitive procedure} slot-exists? obj slot-name -Return @code{#t} if @var{obj} has a slot with name @var{slot-name}, -otherwise @code{#f}. -@end deffn - -@deffn {primitive procedure} slot-bound? obj slot-name -Return @code{#t} if the slot named @var{slot-name} in @var{obj} has a -value, otherwise @code{#f}. - -@code{slot-bound?} calls the generic function @code{slot-missing} if -@var{obj} does not have a slot called @var{slot-name} (@pxref{Handling -Slot Access Errors, slot-missing}). -@end deffn - -@deffn {primitive procedure} slot-ref obj slot-name -Return the value of the slot named @var{slot-name} in @var{obj}. - -@code{slot-ref} calls the generic function @code{slot-missing} if -@var{obj} does not have a slot called @var{slot-name} (@pxref{Handling -Slot Access Errors, slot-missing}). - -@code{slot-ref} calls the generic function @code{slot-unbound} if the -named slot in @var{obj} does not have a value (@pxref{Handling Slot -Access Errors, slot-unbound}). -@end deffn - -@deffn {primitive procedure} slot-set! obj slot-name value -Set the value of the slot named @var{slot-name} in @var{obj} to @var{value}. - -@code{slot-set!} calls the generic function @code{slot-missing} if -@var{obj} does not have a slot called @var{slot-name} (@pxref{Handling -Slot Access Errors, slot-missing}). -@end deffn - -GOOPS stores information about slots in class metaobjects. Internally, -all of these procedures work by looking up the slot definition for the -slot named @var{slot-name} in the class metaobject for @code{(class-of -@var{obj})}, and then using the slot definition's ``getter'' and -``setter'' closures to get and set the slot value. - -The next four procedures differ from the previous ones in that they take -the class metaobject as an explicit argument, rather than assuming -@code{(class-of @var{obj})}. Therefore they allow you to apply the -``getter'' and ``setter'' closures of a slot definition in one class to -an instance of a different class. - -[ *fixme* I have no idea why this is useful! Perhaps when a slot in -@code{(class-of @var{obj})} shadows a slot with the same name in one of -its superclasses? There should be an enlightening example here. ] - -@deffn {primitive procedure} slot-exists-using-class? class obj slot-name -Return @code{#t} if the class metaobject @var{class} has a slot -definition for a slot with name @var{slot-name}, otherwise @code{#f}. -@end deffn - -@deffn {primitive procedure} slot-bound-using-class? class obj slot-name -Return @code{#t} if applying @code{slot-ref-using-class} to the same -arguments would call the generic function @code{slot-unbound}, otherwise -@code{#f}. - -@code{slot-bound-using-class?} calls the generic function -@code{slot-missing} if @var{class} does not have a slot definition for a -slot called @var{slot-name} (@pxref{Handling Slot Access Errors, -slot-missing}). -@end deffn - -@deffn {primitive procedure} slot-ref-using-class class obj slot-name -Apply the ``getter'' closure for the slot named @var{slot-name} in -@var{class} to @var{obj}, and return its result. - -@code{slot-ref-using-class} calls the generic function -@code{slot-missing} if @var{class} does not have a slot definition for a -slot called @var{slot-name} (@pxref{Handling Slot Access Errors, -slot-missing}). - -@code{slot-ref-using-class} calls the generic function -@code{slot-unbound} if the application of the ``getter'' closure to -@var{obj} returns an unbound value (@pxref{Handling Slot Access Errors, -slot-unbound}). -@end deffn - -@deffn {primitive procedure} slot-set-using-class! class obj slot-name value -Apply the ``setter'' closure for the slot named @var{slot-name} in -@var{class} to @var{obj} and @var{value}. - -@code{slot-set-using-class!} calls the generic function -@code{slot-missing} if @var{class} does not have a slot definition for a -slot called @var{slot-name} (@pxref{Handling Slot Access Errors, -slot-missing}). -@end deffn - -@node Class Slots -@subsection Class Slots - -Slots whose allocation is per-class rather than per-instance can be -referenced and set without needing to specify any particular instance. - -@deffn procedure class-slot-ref class slot-name -Return the value of the slot named @var{slot-name} in class @var{class}. -The named slot must have @code{#:class} or @code{#:each-subclass} -allocation (@pxref{Slot Options,, allocation}). - -If there is no such slot with @code{#:class} or @code{#:each-subclass} -allocation, @code{class-slot-ref} calls the @code{slot-missing} generic -function with arguments @var{class} and @var{slot-name}. Otherwise, if -the slot value is unbound, @code{class-slot-ref} calls the -@code{slot-missing} generic function, with the same arguments. -@end deffn - -@deffn procedure class-slot-set! class slot-name value -Set the value of the slot named @var{slot-name} in class @var{class} to -@var{value}. The named slot must have @code{#:class} or -@code{#:each-subclass} allocation (@pxref{Slot Options,, allocation}). - -If there is no such slot with @code{#:class} or @code{#:each-subclass} -allocation, @code{class-slot-ref} calls the @code{slot-missing} generic -function with arguments @var{class} and @var{slot-name}. -@end deffn - -@node Handling Slot Access Errors -@subsection Handling Slot Access Errors - -GOOPS calls one of the following generic functions when a ``slot-ref'' -or ``slot-set!'' call specifies a non-existent slot name, or tries to -reference a slot whose value is unbound. - -@deffn generic slot-missing -@deffnx method slot-missing (class ) slot-name -@deffnx method slot-missing (class ) (object ) slot-name -@deffnx method slot-missing (class ) (object ) slot-name value -When an application attempts to reference or set a class or instance -slot by name, and the slot name is invalid for the specified @var{class} -or @var{object}, GOOPS calls the @code{slot-missing} generic function. - -The default methods all call @code{goops-error} with an appropriate -message. -@end deffn - -@deffn generic slot-unbound -@deffnx method slot-unbound (object ) -@deffnx method slot-unbound (class ) slot-name -@deffnx method slot-unbound (class ) (object ) slot-name -When an application attempts to reference a class or instance slot, and -the slot's value is unbound, GOOPS calls the @code{slot-unbound} generic -function. - -The default methods all call @code{goops-error} with an appropriate -message. -@end deffn - -@node Creating Generic Functions -@section Creating Generic Functions - -A generic function is a collection of methods, with rules for -determining which of the methods should be applied for any given -invocation of the generic function. - -GOOPS represents generic functions as metaobjects of the class -@code{} (or one of its subclasses). - -@menu -* Basic Generic Function Creation:: -* Generic Function Internals:: -* Extending Guiles Primitives:: -@end menu - -@node Basic Generic Function Creation -@subsection Basic Generic Function Creation - -The following forms may be used to bind a variable to a generic -function. Depending on that variable's pre-existing value, the generic -function may be created empty - with no methods - or it may contain -methods that are inferred from the pre-existing value. - -It is not, in general, necessary to use @code{define-generic} or -@code{define-accessor} before defining methods for the generic function -using @code{define-method}, since @code{define-method} will -automatically interpolate a @code{define-generic} call, or upgrade an -existing generic to an accessor, if that is implied by the -@code{define-method} call. Note in particular that, -if the specified variable already has a @emph{generic function} value, -@code{define-generic} and @code{define-accessor} will @emph{discard} it! -Obviously it is application-dependent whether this is desirable or not. - -If, for example, you wanted to extend @code{+} for a class representing -a new numerical type, you probably want to inherit any existing methods -for @code{+} and so should not use @code{define-generic}. If, on the -other hand, you do not want to risk inheriting methods whose behaviour -might surprise you, you can use @code{define-generic} or -@code{define-accessor} to wipe the slate clean. - -@deffn syntax define-generic symbol -Create a generic function with name @var{symbol} and bind it to the -variable @var{symbol}. - -If the variable @var{symbol} was previously bound to a Scheme procedure -(or procedure-with-setter), the old procedure (and setter) is -incorporated into the new generic function as its default procedure (and -setter). Any other previous value that was bound to @var{symbol}, -including an existing generic function, is overwritten by the new -generic function. -@end deffn - -@deffn syntax define-accessor symbol -Create an accessor with name @var{symbol} and bind it to the variable -@var{symbol}. - -If the variable @var{symbol} was previously bound to a Scheme procedure -(or procedure-with-setter), the old procedure (and setter) is -incorporated into the new accessor as its default procedure (and -setter). Any other previous value that was bound to @var{symbol}, -including an existing generic function or accessor, is overwritten by -the new definition. -@end deffn - -@node Generic Function Internals -@subsection Generic Function Internals - -@code{define-generic} calls @code{ensure-generic} to upgrade a -pre-existing procedure value, or @code{make} with metaclass -@code{} to create a new generic function. - -@code{define-accessor} calls @code{ensure-accessor} to upgrade a -pre-existing procedure value, or @code{make-accessor} to create a new -accessor. - -@deffn procedure ensure-generic old-definition [name] -Return a generic function with name @var{name}, if possible by using or -upgrading @var{old-definition}. If unspecified, @var{name} defaults to -@code{#f}. - -If @var{old-definition} is already a generic function, it is returned -unchanged. - -If @var{old-definition} is a Scheme procedure or procedure-with-setter, -@code{ensure-generic} returns a new generic function that uses -@var{old-definition} for its default procedure and setter. - -Otherwise @code{ensure-generic} returns a new generic function with no -defaults and no methods. -@end deffn - -@deffn procedure make-generic [name] -Return a new generic function with name @code{(car @var{name})}. If -unspecified, @var{name} defaults to @code{#f}. -@end deffn - -@code{ensure-generic} calls @code{make} with metaclasses -@code{} and @code{}, depending on the -previous value of the variable that it is trying to upgrade. - -@code{make-generic} is a simple wrapper for @code{make} with metaclass -@code{}. - -@deffn procedure ensure-accessor proc [name] -Return an accessor with name @var{name}, if possible by using or -upgrading @var{proc}. If unspecified, @var{name} defaults to @code{#f}. - -If @var{proc} is already an accessor, it is returned unchanged. - -If @var{proc} is a Scheme procedure, procedure-with-setter or generic -function, @code{ensure-accessor} returns an accessor that reuses the -reusable elements of @var{proc}. - -Otherwise @code{ensure-accessor} returns a new accessor with no defaults -and no methods. -@end deffn - -@deffn procedure make-accessor [name] -Return a new accessor with name @code{(car @var{name})}. If -unspecified, @var{name} defaults to @code{#f}. -@end deffn - -@code{ensure-accessor} calls @code{make} with -metaclass @code{}, as well as calls to -@code{ensure-generic}, @code{make-accessor} and (tail recursively) -@code{ensure-accessor}. - -@code{make-accessor} calls @code{make} twice, first -with metaclass @code{} to create a generic function for the -setter, then with metaclass @code{} to create the -accessor, passing the setter generic function as the value of the -@code{#:setter} keyword. - -@node Extending Guiles Primitives -@subsection Extending Guile's Primitives - -When GOOPS is loaded, many of Guile's primitive procedures can be -extended by giving them a generic function definition that operates -in conjunction with their normal C-coded implementation. For -primitives that are extended in this way, the result from the user- -or application-level point of view is that the extended primitive -behaves exactly like a generic function with the C-coded implementation -as its default method. - -The @code{generic-capability?} predicate should be used to determine -whether a particular primitive is extensible in this way. - -@deffn {primitive procedure} generic-capability? primitive -Return @code{#t} if @var{primitive} can be extended by giving it a -generic function definition, otherwise @code{#f}. -@end deffn - -Even when a primitive procedure is extensible like this, its generic -function definition is not created until it is needed by a call to -@code{define-method}, or until the application explicitly requests it -by calling @code{enable-primitive-generic!}. - -@deffn {primitive procedure} enable-primitive-generic! primitive -Force the creation of a generic function definition for -@var{primitive}. -@end deffn - -Once the generic function definition for a primitive has been created, -it can be retrieved using @code{primitive-generic-generic}. - -@deffn {primitive procedure} primitive-generic-generic primitive -Return the generic function definition of @var{primitive}. - -@code{primitive-generic-generic} raises an error if @var{primitive} -is not a primitive with generic capability, or if its generic capability -has not yet been enabled, whether implicitly (by @code{define-method}) -or explicitly (by @code{enable-primitive-generic!}). -@end deffn - -Note that the distinction between, on the one hand, primitives with -additional generic function definitions and, on the other hand, generic -functions with a default method, may disappear when GOOPS is fully -integrated into the core of Guile. Consequently, the -procedures described in this section may disappear as well. - -@node Adding Methods to Generic Functions -@section Adding Methods to Generic Functions - -@menu -* Basic Method Definition:: -* Method Definition Internals:: -@end menu - -@node Basic Method Definition -@subsection Basic Method Definition - -To add a method to a generic function, use the @code{define-method} form. - -@deffn syntax define-method (generic parameter @dots{}) . body -Define a method for the generic function or accessor @var{generic} with -parameters @var{parameter}s and body @var{body}. - -@var{generic} is a generic function. If @var{generic} is a variable -which is not yet bound to a generic function object, the expansion of -@code{define-method} will include a call to @code{define-generic}. If -@var{generic} is @code{(setter @var{generic-with-setter})}, where -@var{generic-with-setter} is a variable which is not yet bound to a -generic-with-setter object, the expansion will include a call to -@code{define-accessor}. - -Each @var{parameter} must be either a symbol or a two-element list -@code{(@var{symbol} @var{class})}. The symbols refer to variables in -the @var{body} that will be bound to the parameters supplied by the -caller when calling this method. The @var{class}es, if present, -specify the possible combinations of parameters to which this method -can be applied. - -@var{body} is the body of the method definition. -@end deffn - -@code{define-method} expressions look a little like normal Scheme -procedure definitions of the form - -@example -(define (name formals @dots{}) . body) -@end example - -The most important difference is that each formal parameter, apart from the -possible ``rest'' argument, can be qualified by a class name: -@code{@var{formal}} becomes @code{(@var{formal} @var{class})}. The -meaning of this qualification is that the method being defined -will only be applicable in a particular generic function invocation if -the corresponding argument is an instance of @code{@var{class}} (or one of -its subclasses). If more than one of the formal parameters is qualified -in this way, then the method will only be applicable if each of the -corresponding arguments is an instance of its respective qualifying class. - -Note that unqualified formal parameters act as though they are qualified -by the class @code{}, which GOOPS uses to mean the superclass of -all valid Scheme types, including both primitive types and GOOPS classes. - -For example, if a generic function method is defined with -@var{parameter}s @code{((s1 ) (n ))}, that method is -only applicable to invocations of its generic function that have two -parameters where the first parameter is an instance of the -@code{} class and the second parameter is a number. - -If a generic function is invoked with a combination of parameters for which -there is no applicable method, GOOPS raises an error. For more about -invocation error handling, and generic function invocation in general, -see @ref{Invoking Generic Functions}. - -@node Method Definition Internals -@subsection Method Definition Internals - -@code{define-method} - -@itemize @bullet -@item -checks the form of the first parameter, and applies the following steps -to the accessor's setter if it has the @code{(setter @dots{})} form - -@item -interpolates a call to @code{define-generic} or @code{define-accessor} -if a generic function is not already defined with the supplied name - -@item -calls @code{method} with the @var{parameter}s and @var{body}, to make a -new method instance - -@item -calls @code{add-method!} to add this method to the relevant generic -function. -@end itemize - -@deffn syntax method (parameter @dots{}) . body -Make a method whose specializers are defined by the classes in -@var{parameter}s and whose procedure definition is constructed from the -@var{parameter} symbols and @var{body} forms. - -The @var{parameter} and @var{body} parameters should be as for -@code{define-method} (@pxref{Basic Method Definition,, define-method}). -@end deffn - -@code{method} - -@itemize @bullet -@item -extracts formals and specializing classes from the @var{parameter}s, -defaulting the class for unspecialized parameters to @code{} - -@item -creates a closure using the formals and the @var{body} forms - -@item -calls @code{make} with metaclass @code{} and the specializers -and closure using the @code{#:specializers} and @code{#:procedure} -keywords. -@end itemize - -@deffn procedure make-method specializers procedure -Make a method using @var{specializers} and @var{procedure}. - -@var{specializers} should be a list of classes that specifies the -parameter combinations to which this method will be applicable. - -@var{procedure} should be the closure that will applied to the generic -function parameters when this method is invoked. -@end deffn - -@code{make-method} is a simple wrapper around @code{make} with metaclass -@code{}. - -@deffn generic add-method! target method -Generic function for adding method @var{method} to @var{target}. -@end deffn - -@deffn method add-method! (generic ) (method ) -Add method @var{method} to the generic function @var{generic}. -@end deffn - -@deffn method add-method! (proc ) (method ) -If @var{proc} is a procedure with generic capability (@pxref{Extending -Guiles Primitives,, generic-capability?}), upgrade it to a -primitive generic and add @var{method} to its generic function -definition. -@end deffn - -@deffn method add-method! (pg ) (method ) -Add method @var{method} to the generic function definition of @var{pg}. - -Implementation: @code{(add-method! (primitive-generic-generic pg) method)}. -@end deffn - -@deffn method add-method! (whatever ) (method ) -Raise an error indicating that @var{whatever} is not a valid generic -function. -@end deffn - -@node Invoking Generic Functions -@section Invoking Generic Functions - -When a variable with a generic function definition appears as the first -element of a list that is being evaluated, the Guile evaluator tries -to apply the generic function to the arguments obtained by evaluating -the remaining elements of the list. [ *fixme* How do I put this in a -more Schemely and less Lispy way? ] - -Usually a generic function contains several method definitions, with -varying degrees of formal parameter specialization (@pxref{Basic -Method Definition,, define-method}). So it is necessary to sort these -methods by specificity with respect to the supplied arguments, and then -apply the most specific method definition. Less specific methods -may be applied subsequently if a method that is being applied calls -@code{next-method}. - -@menu -* Determining Which Methods to Apply:: -* Handling Invocation Errors:: -@end menu - -@node Determining Which Methods to Apply -@subsection Determining Which Methods to Apply - -[ *fixme* Sorry - this is the area of GOOPS that I understand least of -all, so I'm afraid I have to pass on this section. Would some other -kind person consider filling it in? ] - -@deffn generic apply-generic -@deffnx method apply-generic (gf ) args -@end deffn - -@deffn generic compute-applicable-methods -@deffnx method compute-applicable-methods (gf ) args -@end deffn - -@deffn generic sort-applicable-methods -@deffnx method sort-applicable-methods (gf ) methods args -@end deffn - -@deffn generic method-more-specific? -@deffnx method method-more-specific? (m1 ) (m2 ) args -@end deffn - -@deffn generic apply-method -@deffnx method apply-method (gf ) methods build-next args -@end deffn - -@deffn generic apply-methods -@deffnx method apply-methods (gf ) (l ) args -@end deffn - -@node Handling Invocation Errors -@subsection Handling Invocation Errors - -@deffn generic no-method -@deffnx method no-method (gf ) args -When an application invokes a generic function, and no methods at all -have been defined for that generic function, GOOPS calls the -@code{no-method} generic function. The default method calls -@code{goops-error} with an appropriate message. -@end deffn - -@deffn generic no-applicable-method -@deffnx method no-applicable-method (gf ) args -When an application applies a generic function to a set of arguments, -and no methods have been defined for those argument types, GOOPS calls -the @code{no-applicable-method} generic function. The default method -calls @code{goops-error} with an appropriate message. -@end deffn - -@deffn generic no-next-method -@deffnx method no-next-method (gf ) args -When a generic function method calls @code{(next-method)} to invoke the -next less specialized method for that generic function, and no less -specialized methods have been defined for the current generic function -arguments, GOOPS calls the @code{no-next-method} generic function. The -default method calls @code{goops-error} with an appropriate message. -@end deffn - -@node Redefining a Class -@section Redefining a Class - -Suppose that a class @code{} is defined using @code{define-class} -(@pxref{Basic Class Definition,, define-class}), with slots that have -accessor functions, and that an application has created several instances -of @code{} using @code{make} (@pxref{Basic Instance Creation,, -make}). What then happens if @code{} is redefined by calling -@code{define-class} again? - -@menu -* Default Class Redefinition Behaviour:: -* Customizing Class Redefinition:: -@end menu - -@node Default Class Redefinition Behaviour -@subsection Default Class Redefinition Behaviour - -GOOPS' default answer to this question is as follows. - -@itemize @bullet -@item -All existing direct instances of @code{} are converted to be -instances of the new class. This is achieved by preserving the values -of slots that exist in both the old and new definitions, and initializing the -values of new slots in the usual way (@pxref{Basic Instance Creation,, -make}). - -@item -All existing subclasses of @code{} are redefined, as though -the @code{define-class} expressions that defined them were re-evaluated -following the redefinition of @code{}, and the class -redefinition process described here is applied recursively to the -redefined subclasses. - -@item -Once all of its instances and subclasses have been updated, the class -metaobject previously bound to the variable @code{} is no -longer needed and so can be allowed to be garbage collected. -@end itemize - -To keep things tidy, GOOPS also needs to do a little housekeeping on -methods that are associated with the redefined class. - -@itemize @bullet -@item -Slot accessor methods for slots in the old definition should be removed -from their generic functions. They will be replaced by accessor methods -for the slots of the new class definition. - -@item -Any generic function method that uses the old @code{} metaobject -as one of its formal parameter specializers must be updated to refer to -the new @code{} metaobject. (Whenever a new generic function -method is defined, @code{define-method} adds the method to a list stored -in the class metaobject for each class used as a formal parameter -specializer, so it is easy to identify all the methods that must be -updated when a class is redefined.) -@end itemize - -If this class redefinition strategy strikes you as rather counter-intuitive, -bear in mind that it is derived from similar behaviour in other object -systems such as CLOS, and that experience in those systems has shown it to be -very useful in practice. - -Also bear in mind that, like most of GOOPS' default behaviour, it can -be customized@dots{} - -@node Customizing Class Redefinition -@subsection Customizing Class Redefinition - -When @code{define-class} notices that a class is being redefined, -it constructs the new class metaobject as usual, and then invokes the -@code{class-redefinition} generic function with the old and new classes -as arguments. Therefore, if the old or new classes have metaclasses -other than the default @code{}, class redefinition behaviour can -be customized by defining a @code{class-redefinition} method that is -specialized for the relevant metaclasses. - -@deffn generic class-redefinition -Handle the class redefinition from @var{old-class} to @var{new-class}, -and return the new class metaobject that should be bound to the -variable specified by @code{define-class}'s first argument. -@end deffn - -@deffn method class-redefinition (old-class ) (new-class ) -Implements GOOPS' default class redefinition behaviour, as described in -@ref{Default Class Redefinition Behaviour}. Returns the metaobject -for the new class definition. -@end deffn - -An alternative class redefinition strategy could be to leave all -existing instances as instances of the old class, but accepting that the -old class is now ``nameless'', since its name has been taken over by the -new definition. In this strategy, any existing subclasses could also -be left as they are, on the understanding that they inherit from a nameless -superclass. - -This strategy is easily implemented in GOOPS, by defining a new metaclass, -that will be used as the metaclass for all classes to which the strategy -should apply, and then defining a @code{class-redefinition} method that -is specialized for this metaclass: - -@example -(define-class ()) - -(define-method (class-redefinition (old ) (new )) - new) -@end example - -When customization can be as easy as this, aren't you glad that GOOPS -implements the far more difficult strategy as its default! - -Finally, note that, if @code{class-redefinition} itself is not customized, -the default @code{class-redefinition} method invokes three further -generic functions that could be individually customized: - -@itemize @bullet -@item -(remove-class-accessors! @var{old-class}) - -@item -(update-direct-method! @var{method} @var{old-class} @var{new-class}) - -@item -(update-direct-subclass! @var{subclass} @var{old-class} @var{new-class}) -@end itemize - -and the default methods for these generic functions invoke further -generic functions, and so on@dots{} The detailed protocol for all of these -is described in @ref{MOP Specification}. - -@node Changing the Class of an Instance -@section Changing the Class of an Instance - -You can change the class of an existing instance by invoking the -generic function @code{change-class} with two arguments: the instance -and the new class. - -@deffn generic change-class -@end deffn - -The default method for @code{change-class} decides how to implement the -change of class by looking at the slot definitions for the instance's -existing class and for the new class. If the new class has slots with -the same name as slots in the existing class, the values for those slots -are preserved. Slots that are present only in the existing class are -discarded. Slots that are present only in the new class are initialized -using the corresponding slot definition's init function (@pxref{Classes,, -slot-init-function}). - -@deffn {method} change-class (obj ) (new ) -Modify instance @var{obj} to make it an instance of class @var{new}. - -The value of each of @var{obj}'s slots is preserved only if a similarly named -slot exists in @var{new}; any other slot values are discarded. - -The slots in @var{new} that do not correspond to any of @var{obj}'s -pre-existing slots are initialized according to @var{new}'s slot definitions' -init functions. -@end deffn - -Customized change of class behaviour can be implemented by defining -@code{change-class} methods that are specialized either by the class -of the instances to be modified or by the metaclass of the new class. - -When a class is redefined (@pxref{Redefining a Class}), and the default -class redefinition behaviour is not overridden, GOOPS (eventually) -invokes the @code{change-class} generic function for each existing -instance of the redefined class. - -@node Introspection -@section Introspection - -@dfn{Introspection}, also known as @dfn{reflection}, is the name given -to the ability to obtain information dynamically about GOOPS metaobjects. -It is perhaps best illustrated by considering an object oriented language -that does not provide any introspection, namely C++. - -Nothing in C++ allows a running program to obtain answers to the following -types of question: - -@itemize @bullet -@item -What are the data members of this object or class? - -@item -What classes does this class inherit from? - -@item -Is this method call virtual or non-virtual? - -@item -If I invoke @code{Employee::adjustHoliday()}, what class contains the -@code{adjustHoliday()} method that will be applied? -@end itemize - -In C++, answers to such questions can only be determined by looking at -the source code, if you have access to it. GOOPS, on the other hand, -includes procedures that allow answers to these questions --- or their -GOOPS equivalents --- to be obtained dynamically, at run time. - -@menu -* Classes:: -* Slots:: -* Instances:: -* Generic Functions:: -* Generic Function Methods:: -@end menu - -@node Classes -@subsection Classes - -@deffn {primitive procedure} class-name class -Return the name of class @var{class}. -This is the value of the @var{class} metaobject's @code{name} slot. -@end deffn - -@deffn {primitive procedure} class-direct-supers class -Return a list containing the direct superclasses of @var{class}. -This is the value of the @var{class} metaobject's -@code{direct-supers} slot. -@end deffn - -@deffn {primitive procedure} class-direct-slots class -Return a list containing the slot definitions of the direct slots of -@var{class}. -This is the value of the @var{class} metaobject's @code{direct-slots} -slot. -@end deffn - -@deffn {primitive procedure} class-direct-subclasses class -Return a list containing the direct subclasses of @var{class}. -This is the value of the @var{class} metaobject's -@code{direct-subclasses} slot. -@end deffn - -@deffn {primitive procedure} class-direct-methods class -Return a list of all the generic function methods that use @var{class} -as a formal parameter specializer. -This is the value of the @var{class} metaobject's @code{direct-methods} -slot. -@end deffn - -@deffn {primitive procedure} class-precedence-list class -Return the class precedence list for class @var{class} (@pxref{Class -precedence list}). -This is the value of the @var{class} metaobject's @code{cpl} slot. -@end deffn - -@deffn {primitive procedure} class-slots class -Return a list containing the slot definitions for all @var{class}'s slots, -including any slots that are inherited from superclasses. -This is the value of the @var{class} metaobject's @code{slots} slot. -@end deffn - -@deffn {primitive procedure} class-environment class -Return the value of @var{class}'s @code{environment} slot. -[ *fixme* I don't know what this value is used for. ] -@end deffn - -@deffn procedure class-subclasses class -Return a list of all subclasses of @var{class}. -@end deffn - -@deffn procedure class-methods class -Return a list of all methods that use @var{class} or a subclass of -@var{class} as one of its formal parameter specializers. -@end deffn - -@node Slots -@subsection Slots - -@deffn procedure class-slot-definition class slot-name -Return the slot definition for the slot named @var{slot-name} in class -@var{class}. @var{slot-name} should be a symbol. -@end deffn - -@deffn procedure slot-definition-name slot-def -Extract and return the slot name from @var{slot-def}. -@end deffn - -@deffn procedure slot-definition-options slot-def -Extract and return the slot options from @var{slot-def}. -@end deffn - -@deffn procedure slot-definition-allocation slot-def -Extract and return the slot allocation option from @var{slot-def}. This -is the value of the @code{#:allocation} keyword (@pxref{Slot Options,, -allocation}), or @code{#:instance} if the @code{#:allocation} keyword is -absent. -@end deffn - -@deffn procedure slot-definition-getter slot-def -Extract and return the slot getter option from @var{slot-def}. This is -the value of the @code{#:getter} keyword (@pxref{Slot Options,, -getter}), or @code{#f} if the @code{#:getter} keyword is absent. -@end deffn - -@deffn procedure slot-definition-setter slot-def -Extract and return the slot setter option from @var{slot-def}. This is -the value of the @code{#:setter} keyword (@pxref{Slot Options,, -setter}), or @code{#f} if the @code{#:setter} keyword is absent. -@end deffn - -@deffn procedure slot-definition-accessor slot-def -Extract and return the slot accessor option from @var{slot-def}. This -is the value of the @code{#:accessor} keyword (@pxref{Slot Options,, -accessor}), or @code{#f} if the @code{#:accessor} keyword is absent. -@end deffn - -@deffn procedure slot-definition-init-value slot-def -Extract and return the slot init-value option from @var{slot-def}. This -is the value of the @code{#:init-value} keyword (@pxref{Slot Options,, -init-value}), or the unbound value if the @code{#:init-value} keyword is -absent. -@end deffn - -@deffn procedure slot-definition-init-form slot-def -Extract and return the slot init-form option from @var{slot-def}. This -is the value of the @code{#:init-form} keyword (@pxref{Slot Options,, -init-form}), or the unbound value if the @code{#:init-form} keyword is -absent. -@end deffn - -@deffn procedure slot-definition-init-thunk slot-def -Extract and return the slot init-thunk option from @var{slot-def}. This -is the value of the @code{#:init-thunk} keyword (@pxref{Slot Options,, -init-thunk}), or @code{#f} if the @code{#:init-thunk} keyword is absent. -@end deffn - -@deffn procedure slot-definition-init-keyword slot-def -Extract and return the slot init-keyword option from @var{slot-def}. -This is the value of the @code{#:init-keyword} keyword (@pxref{Slot -Options,, init-keyword}), or @code{#f} if the @code{#:init-keyword} -keyword is absent. -@end deffn - -@deffn procedure slot-init-function class slot-name -Return the initialization function for the slot named @var{slot-name} in -class @var{class}. @var{slot-name} should be a symbol. - -The returned initialization function incorporates the effects of the -standard @code{#:init-thunk}, @code{#:init-form} and @code{#:init-value} -slot options. These initializations can be overridden by the -@code{#:init-keyword} slot option or by a specialized @code{initialize} -method, so, in general, the function returned by -@code{slot-init-function} may be irrelevant. For a fuller discussion, -see @ref{Slot Options,, init-value}. -@end deffn - -@node Instances -@subsection Instances - -@deffn {primitive procedure} class-of value -Return the GOOPS class of any Scheme @var{value}. -@end deffn - -@deffn {primitive procedure} instance? object -Return @code{#t} if @var{object} is any GOOPS instance, otherwise -@code{#f}. -@end deffn - -@deffn procedure is-a? object class -Return @code{#t} if @var{object} is an instance of @var{class} or one of -its subclasses. -@end deffn - -Implementation notes: @code{is-a?} uses @code{class-of} and -@code{class-precedence-list} to obtain the class precedence list for -@var{object}. - -@node Generic Functions -@subsection Generic Functions - -@deffn {primitive procedure} generic-function-name gf -Return the name of generic function @var{gf}. -@end deffn - -@deffn {primitive procedure} generic-function-methods gf -Return a list of the methods of generic function @var{gf}. -This is the value of the @var{gf} metaobject's @code{methods} slot. -@end deffn - -@node Generic Function Methods -@subsection Generic Function Methods - -@deffn {primitive procedure} method-generic-function method -Return the generic function that @var{method} belongs to. -This is the value of the @var{method} metaobject's -@code{generic-function} slot. -@end deffn - -@deffn {primitive procedure} method-specializers method -Return a list of @var{method}'s formal parameter specializers . -This is the value of the @var{method} metaobject's -@code{specializers} slot. -@end deffn - -@deffn {primitive procedure} method-procedure method -Return the procedure that implements @var{method}. -This is the value of the @var{method} metaobject's -@code{procedure} slot. -@end deffn - -@deffn generic method-source -@deffnx method method-source (m ) -Return an expression that prints to show the definition of method -@var{m}. - -@example -(define-generic cube) - -(define-method (cube (n )) - (* n n n)) - -(map method-source (generic-function-methods cube)) -@result{} -((method ((n )) (* n n n))) -@end example -@end deffn - -@node Miscellaneous Functions -@section Miscellaneous Functions - -@menu -* Administrative Functions:: -* Error Handling:: -* Object Comparisons:: -* Cloning Objects:: -* Write and Display:: -@end menu - -@node Administrative Functions -@subsection Administration Functions - -This section describes administrative, non-technical GOOPS functions. - -@deffn primitive goops-version -Return the current GOOPS version as a string, for example ``0.2''. -@end deffn - -@node Error Handling -@subsection Error Handling - -The procedure @code{goops-error} is called to raise an appropriate error -by the default methods of the following generic functions: - -@itemize @bullet -@item -@code{slot-missing} (@pxref{Handling Slot Access Errors,, slot-missing}) - -@item -@code{slot-unbound} (@pxref{Handling Slot Access Errors,, slot-unbound}) - -@item -@code{no-method} (@pxref{Handling Invocation Errors,, no-method}) - -@item -@code{no-applicable-method} (@pxref{Handling Invocation Errors,, -no-applicable-method}) - -@item -@code{no-next-method} (@pxref{Handling Invocation Errors,, -no-next-method}) -@end itemize - -If you customize these functions for particular classes or metaclasses, -you may still want to use @code{goops-error} to signal any error -conditions that you detect. - -@deffn procedure goops-error format-string . args -Raise an error with key @code{goops-error} and error message constructed -from @var{format-string} and @var{args}. Error message formatting is -as done by @code{scm-error}. -@end deffn - -@node Object Comparisons -@subsection Object Comparisons - -@deffn generic object-eqv? -@deffnx method object-eqv? ((x ) (y )) -@deffnx generic object-equal? -@deffnx method object-equal? ((x ) (y )) -Generic functions and default (unspecialized) methods for comparing two -GOOPS objects. - -The default methods always return @code{#f}. Application class authors -may wish to define specialized methods for @code{object-eqv?} and -@code{object-equal?} that compare instances of the same class for -equality in whatever sense is useful to the application. -@end deffn - -@node Cloning Objects -@subsection Cloning Objects - -@deffn generic shallow-clone -@deffnx method shallow-clone (self ) -Return a ``shallow'' clone of @var{self}. The default method makes a -shallow clone by allocating a new instance and copying slot values from -self to the new instance. Each slot value is copied either as an -immediate value or by reference. -@end deffn - -@deffn generic deep-clone -@deffnx method deep-clone (self ) -Return a ``deep'' clone of @var{self}. The default method makes a deep -clone by allocating a new instance and copying or cloning slot values -from self to the new instance. If a slot value is an instance -(satisfies @code{instance?}), it is cloned by calling @code{deep-clone} -on that value. Other slot values are copied either as immediate values -or by reference. -@end deffn - -@node Write and Display -@subsection Write and Display - -@deffn {primitive generic} write object port -@deffnx {primitive generic} display object port -When GOOPS is loaded, @code{write} and @code{display} become generic -functions with special methods for printing - -@itemize @bullet -@item -objects - instances of the class @code{} - -@item -foreign objects - instances of the class @code{} - -@item -classes - instances of the class @code{} - -@item -generic functions - instances of the class @code{} - -@item -methods - instances of the class @code{}. -@end itemize - -@code{write} and @code{display} print non-GOOPS values in the same way -as the Guile primitive @code{write} and @code{display} functions. -@end deffn - -@node MOP Specification, Tutorial, Reference Manual, Top -@chapter MOP Specification - -For an introduction to metaobjects and the metaobject protocol, -see @ref{Metaobjects and the Metaobject Protocol}. - -The aim of the MOP specification in this chapter is to specify all the -customizable generic function invocations that can be made by the standard -GOOPS syntax, procedures and methods, and to explain the protocol for -customizing such invocations. - -A generic function invocation is customizable if the types of the arguments -to which it is applied are not all determined by the lexical context in -which the invocation appears. For example, - -@itemize @bullet -@item -the @code{(initialize @var{instance} @var{initargs})} invocation in the -default @code{make-instance} method is customizable, because the type of the -@code{@var{instance}} argument is determined by the class that was passed to -@code{make-instance}. - -@item -the @code{(make #:name ',name)} invocation in @code{define-generic} -is not customizable, because all of its arguments have lexically determined -types. -@end itemize - -When using this rule to decide whether a given generic function invocation -is customizable, we ignore arguments that are expected to be handled in -method definitions as a single ``rest'' list argument. - -For each customizable generic function invocation, the @dfn{invocation -protocol} is explained by specifying - -@itemize @bullet -@item -what, conceptually, the applied method is intended to do - -@item -what assumptions, if any, the caller makes about the applied method's side -effects - -@item -what the caller expects to get as the applied method's return value. -@end itemize - -@menu -* Class Definition:: -* Instance Creation:: -* Class Redefinition:: -* Method Definition:: -* Generic Function Invocation:: -@end menu - -@node Class Definition -@section Class Definition - -@code{define-class} (syntax) - -@itemize @bullet -@item -@code{class} (syntax) - -@itemize @bullet -@item -@code{make-class} (procedure) - -@itemize @bullet -@item -@code{make @var{metaclass} @dots{}} (generic) - -@var{metaclass} is the metaclass of the class being defined, either -taken from the @code{#:metaclass} class option or computed by -@code{ensure-metaclass}. The applied method must create and return the -fully initialized class metaobject for the new class definition. -@end itemize - -@end itemize - -@item -@code{class-redefinition @var{old-class} @var{new-class}} (generic) - -@code{define-class} calls @code{class-redefinition} if the variable -specified by its first argument already held a GOOPS class definition. -@var{old-class} and @var{new-class} are the old and new class metaobjects. -The applied method should perform whatever is necessary to handle the -redefinition, and should return the class metaobject that is to be bound -to @code{define-class}'s variable. The default class redefinition -protocol is described in @ref{Class Redefinition}. -@end itemize - -The @code{(make @var{metaclass} @dots{})} invocation above will create -an class metaobject with metaclass @var{metaclass}. By default, this -metaobject will be initialized by the @code{initialize} method that is -specialized for instances of type @code{}. - -@code{initialize @var{initargs}} (method) - -@itemize @bullet -@item -@code{compute-cpl @var{class}} (generic) - -The applied method should compute and return the class precedence list -for @var{class} as a list of class metaobjects. When @code{compute-cpl} -is called, the following @var{class} metaobject slots have all been -initialized: @code{name}, @code{direct-supers}, @code{direct-slots}, -@code{direct-subclasses} (empty), @code{direct-methods}. The value -returned by @code{compute-cpl} will be stored in the @code{cpl} slot. - -@item -@code{compute-slots @var{class}} (generic) - -The applied method should compute and return the slots (union of direct -and inherited) for @var{class} as a list of slot definitions. When -@code{compute-slots} is called, all the @var{class} metaobject slots -mentioned for @code{compute-cpl} have been initialized, plus the -following: @code{cpl}, @code{redefined} (@code{#f}), @code{environment}. -The value returned by @code{compute-slots} will be stored in the -@code{slots} slot. - -@item -@code{compute-get-n-set @var{class} @var{slot-def}} (generic) - -@code{initialize} calls @code{compute-get-n-set} for each slot computed -by @code{compute-slots}. The applied method should compute and return a -pair of closures that, respectively, get and set the value of the specified -slot. The get closure should have arity 1 and expect a single argument -that is the instance whose slot value is to be retrieved. The set closure -should have arity 2 and expect two arguments, where the first argument is -the instance whose slot value is to be set and the second argument is the -new value for that slot. The closures should be returned in a two element -list: @code{(list @var{get} @var{set})}. - -The closures returned by @code{compute-get-n-set} are stored as part of -the value of the @var{class} metaobject's @code{getters-n-setters} slot. -Specifically, the value of this slot is a list with the same number of -elements as there are slots in the class, and each element looks either like - -@example -@code{(@var{slot-name-symbol} @var{init-function} . @var{index})} -@end example - -or like - -@example -@code{(@var{slot-name-symbol} @var{init-function} @var{get} @var{set})} -@end example - -Where the get and set closures are replaced by @var{index}, the slot is -an instance slot and @var{index} is the slot's index in the underlying -structure: GOOPS knows how to get and set the value of such slots and so -does not need specially constructed get and set closures. Otherwise, -@var{get} and @var{set} are the closures returned by @code{compute-get-n-set}. - -The structure of the @code{getters-n-setters} slot value is important when -understanding the next customizable generic functions that @code{initialize} -calls@dots{} - -@item -@code{compute-getter-method @var{class} @var{gns}} (generic) - -@code{initialize} calls @code{compute-getter-method} for each of the class's -slots (as determined by @code{compute-slots}) that includes a -@code{#:getter} or @code{#:accessor} slot option. @var{gns} is the -element of the @var{class} metaobject's @code{getters-n-setters} slot that -specifies how the slot in question is referenced and set, as described -above under @code{compute-get-n-set}. The applied method should create -and return a method that is specialized for instances of type @var{class} -and uses the get closure to retrieve the slot's value. [ *fixme Need -to insert something here about checking that the value is not unbound. ] -@code{initialize} uses @code{add-method!} to add the returned method to -the generic function named by the slot definition's @code{#:getter} or -@code{#:accessor} option. - -@item -@code{compute-setter-method @var{class} @var{gns}} (generic) - -@code{compute-setter-method} is invoked with the same arguments as -@code{compute-getter-method}, for each of the class's slots that includes -a @code{#:setter} or @code{#:accessor} slot option. The applied method -should create and return a method that is specialized for instances of -type @var{class} and uses the set closure to set the slot's value. -@code{initialize} then uses @code{add-method!} to add the returned method -to the generic function named by the slot definition's @code{#:setter} -or @code{#:accessor} option. -@end itemize - -@node Instance Creation -@section Instance Creation - -@code{make . @var{initargs}} (method) - -@itemize @bullet -@item -@code{allocate-instance @var{class} @var{initargs}} (generic) - -The applied @code{allocate-instance} method should allocate storage for -a new instance of class @var{class} and return the uninitialized instance. - -@item -@code{initialize @var{instance} @var{initargs}} (generic) - -@var{instance} is the uninitialized instance returned by -@code{allocate-instance}. The applied method should initialize the new -instance in whatever sense is appropriate for its class. The method's -return value is ignored. -@end itemize - -@node Class Redefinition -@section Class Redefinition - -The default @code{class-redefinition} method, specialized for classes -with the default metaclass @code{}, has the following internal -protocol. - -[ *fixme* I'm not sure that I understand this sufficiently to explain -it. Also, the internals of the default class redefinition method are -extremely implementation-specific, and I'm not sure that there is that -much point trying to describe the internal protocol such that it could -be customized without going to look at the source code. ] - -@code{class-redefinition @var{(old )} @var{(new )}} -(method) - -@itemize @bullet -@item -@code{remove-class-accessors! @var{old}} (generic) - -@item -@code{update-direct-method! @var{method} @var{old} @var{new}} (generic) - -@item -@code{update-direct-subclass! @var{subclass} @var{old} @var{new}} (generic) -@end itemize - -The default @code{update-direct-subclass!} method invokes -@code{class-redefinition} recursively to handle the redefinition of the -subclass. - -When a class is redefined, any existing instance of the redefined class -will be modified for the new class definition before the next time that -any of the instance's slot is referenced or set. GOOPS modifies each -instance by calling the generic function @code{change-class}. [ *fixme* -Actually it sometimes calls @code{change-class} and sometimes -@code{change-object-class}, and I don't understand why. ] - -The default @code{change-class} method copies slot values from the old -to the modified instance, and initializes new slots, as described in -@ref{Changing the Class of an Instance}. After doing so, it makes a -generic function invocation that can be used to customize the instance -update algorithm. - -@code{change-class @var{(old-instance )} @var{(new )}} (method) - -@itemize @bullet -@item -@code{update-instance-for-different-class @var{old-instance} @var{new-instance}} (generic) - -@code{change-class} invokes @code{update-instance-for-different-class} -as the last thing that it does before returning. The applied method can -make any further adjustments to @var{new-instance} that are required to -complete or modify the change of class. The return value from the -applied method is ignored. - -The default @code{update-instance-for-different-class} method does -nothing. -@end itemize - -@node Method Definition -@section Method Definition - -@code{define-method} (syntax) - -@itemize @bullet -@item -@code{add-method! @var{target} @var{method}} (generic) - -@code{define-method} invokes the @code{add-method!} generic function to -handle adding the new method to a variety of possible targets. GOOPS -includes methods to handle @var{target} as - -@itemize @bullet -@item -a generic function (the most common case) - -@item -a procedure - -@item -a primitive generic (@pxref{Extending Guiles Primitives}) -@end itemize - -By defining further methods for @code{add-method!}, you can -theoretically handle adding methods to further types of target. -@end itemize - -@node Generic Function Invocation -@section Generic Function Invocation - -[ *fixme* Description required here. ] - -@code{apply-generic} - -@itemize @bullet -@item -@code{no-method} - -@item -@code{compute-applicable-methods} - -@item -@code{sort-applicable-methods} - -@item -@code{apply-methods} - -@item -@code{no-applicable-method} -@end itemize - -@code{sort-applicable-methods} - -@itemize @bullet -@item -@code{method-more-specific?} -@end itemize - -@code{apply-methods} - -@itemize @bullet -@item -@code{apply-method} -@end itemize - -@code{next-method} - -@itemize @bullet -@item -@code{no-next-method} -@end itemize - -@node Tutorial, Index, MOP Specification, Top -@chapter Tutorial -@include goops-tutorial.texi - -@node Index, Concept Index, Tutorial, Top -@chapter Index -@page -@node Concept Index, Function and Variable Index, Index, Top -@unnumberedsec Concept Index - -@printindex cp - -@node Function and Variable Index, , Concept Index, Top -@unnumberedsec Function and Variable Index - -@printindex fn - -@summarycontents -@contents -@bye diff --git a/doc/guile-tut.texi b/doc/guile-tut.texi index f2489cdaa..e69de29bb 100644 --- a/doc/guile-tut.texi +++ b/doc/guile-tut.texi @@ -1,1336 +0,0 @@ -\input texinfo @c -*-texinfo-*- -@c %**start of header -@setfilename guile-tut.info -@settitle Guile Tutorial - -@include version-tutorial.texi - -@dircategory The Algorithmic Language Scheme -@direntry -* Guile Tutorial: (guile-tut). The Guile tutorial. -@end direntry - -@setchapternewpage off -@c Choices for setchapternewpage are {on,off,odd}. -@paragraphindent 2 -@c %**end of header - -@iftex -@finalout -@c DL: lose the egregious vertical whitespace, esp. around examples -@c but paras in @defun-like things don't have parindent -@parskip 4pt plus 1pt -@end iftex - -@titlepage -@title Guile Tutorial -@subtitle For use with Guile @value{VERSION} -@subtitle Last updated @value{UPDATED} -@author Mark Galassi -@author Cygnus Solutions and -@author Los Alamos National Laboratory -@author @email{rosalia@@nis.lanl.gov} - -@page -@vskip 0pt plus 1filll -Copyright @copyright{} 1997, 1998 Free Software Foundation - -Permission is granted to make and distribute verbatim copies of -this manual provided the copyright notice and this permission notice -are preserved on all copies. - -Permission is granted to copy and distribute modified versions of this -manual under the conditions for verbatim copying, provided that the entire -resulting derived work is distributed under the terms of a permission -notice identical to this one. - -Permission is granted to copy and distribute translations of this manual -into another language, under the above conditions for modified versions, -except that this permission notice may be stated in a translation approved -by the author. -@end titlepage - - -@ifinfo -@node Top -@top Guile Tutorial -@end ifinfo - -@ifinfo -This file gives a tutorial introductionto Guile. - -Copyright (C) 1997 Free Software Foundation - -Permission is granted to make and distribute verbatim copies of -this manual provided the copyright notice and this permission notice -are preserved on all copies. - -@ignore -Permission is granted to process this file through TeX and print the -results, provided the printed document carries copying permission -notice identical to this one except for the removal of this paragraph -(this paragraph not being relevant to the printed manual). - -@end ignore -Permission is granted to copy and distribute modified versions of this -manual under the conditions for verbatim copying, provided that the entire -resulting derived work is distributed under the terms of a permission -notice identical to this one. - -Permission is granted to copy and distribute translations of this manual -into another language, under the above conditions for modified versions, -except that this permission notice may be stated in a translation approved -by the author. -@end ifinfo - - -@menu -* Jump Start:: -* Introduction:: -* Using Guile to program in Scheme:: -* Guile in a Library:: -* Regular Expression Support:: -* UNIX System Programming:: -* Where to find more Guile/Scheme resources:: -* Concept Index:: -* Procedure and Macro Index:: -* Variable Index:: -* Type Index:: -@end menu - -@node Jump Start -@chapter Jump Start - -@noindent -Before giving an overview of Guile, I present some simple commands and -programs that you can type to get going immediately. - -Start by invoking the Guile interpreter (usually you do this by just -typing @code{guile}). Then type (or paste) the following expressions at -the prompt; the interpreter's response is preceded (in this manual) by -@result{}. - -@example - guile -@end example -@lisp -(+ 20 35) -@result{} 55 -(define (recursive-factorial n) - (if (= n 0) - 1 - (* n (recursive-factorial (- n 1))))) -(recursive-factorial 5) -@result{} 120 -(recursive-factorial 500) -@result{} 1220136825991110068701238785423046926253574342803192842192413588 - 3858453731538819976054964475022032818630136164771482035841633787 - 2207817720048078520515932928547790757193933060377296085908627042 - 9174547882424912726344305670173270769461062802310452644218878789 - 4657547771498634943677810376442740338273653974713864778784954384 - 8959553753799042324106127132698432774571554630997720278101456108 - 1188373709531016356324432987029563896628911658974769572087926928 - 8712817800702651745077684107196243903943225364226052349458501299 - 1857150124870696156814162535905669342381300885624924689156412677 - 5654481886506593847951775360894005745238940335798476363944905313 - 0623237490664450488246650759467358620746379251842004593696929810 - 2226397195259719094521782333175693458150855233282076282002340262 - 6907898342451712006207714640979456116127629145951237229913340169 - 5523638509428855920187274337951730145863575708283557801587354327 - 6888868012039988238470215146760544540766353598417443048012893831 - 3896881639487469658817504506926365338175055478128640000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000000 - -@end lisp - -In this example we did some simple arithmetic @code{(+ 20 35)} and got -the answer @code{55}. Then we coded the classic (and rather wasteful) -factorial algorithm, and got a glimpse of Scheme's nice -@emph{bignumbers} by asking for the factorial of 1000. Then we quit -with @code{(quit)}. -@cindex bignumbers - -This is the most basic use of Guile: a simple Scheme interpreter. In -the rest of this tutorial I will show you how Guile has many facets: it -is also an @emph{extensible} interpreter (to which many features can be -easilly added) and an @emph{embeddable} interpreter (which can be -invoked from your C programs). - - -@node Introduction -@chapter Introduction - -@noindent -@dfn{Guile} (which can stand for @emph{GNU Ubiquitous Intelligent -Language Extension}) is the GNU extension language. It started out as -an embeddable Scheme interpreter, and has rapidly evolved into a -kitchen-sink package including a standalone Scheme interpreter, an -embeddable Scheme interpreter, several graphics options, other languages -that can be used along with Scheme (for now just @emph{ctax} and -@emph{Tcl}), and hooks for much more. - - -@menu -* What are scripting and extension languages:: -* History of Guile and its motivations:: -* How to characterize Guile:: -@end menu - -@node What are scripting and extension languages -@section What are scripting and extension languages -@cindex scripting languages -@cindex extension languages - -A @dfn{scripting language} is a programming language which serves as -glue between other system programs. In the UNIX world, the traditional -scripting language is the @emph{Bourne shell}, which allows many UNIX -commands to be executed in sequence, or in a pipeline. Traditional UNIX -commands are cleverly written to work well when put together in a -script. - -Other examples of UNIX scripting languages are AWK, Perl, Scsh (the -Scheme Shell: a Scheme interpreter enhanced to do good scripting), -Python, Tcl, Java @dots{} -@cindex scripting languages - examples - -UNIX programmers noticed, more than 25 years ago, that scripting -languages can do serious work, so the Bourne shell was written to have -variables, operators and control structures, just like a full-featured -programming language. -@cindex Bourne shell - -What scripting languages have, that traditional programming languages do -not, is the ability to easily run an external program (or a pipeline of -external programs) and use the returned values and output from that -program in useful ways. - -An @dfn{extension language} is a programming language interpreter -offered by an application program, so that users can write macros or -even full-fledged programs to extend the original application. -Extension languages have a C interface (it is usually C, but it could be -any other compiled language), and can be given access to the C data -structures. Likewise, there are C routines to access the extension -language data structures. - -Extension languages abound in the software world, even though the name -@emph{extension language} is seldom used. Examples are: -@cindex extension languages - examples - -@itemize @bullet -@item -Emacs Lisp, the language used to program and customize GNU Emacs. -@cindex Emacs Lisp - -@item -Tcl, John Ousterhout's general-purpose scripting and extension language. -@cindex Tcl - -@item -The Lotus 1-2-3 macro language (any spreadsheet macro language, -really). I mention this one first because it is a classic, even though -it is seldom used any more. -@cindex Lotus 1-2-3 - -@item -Other spreadsheet and database macro languages. - -@item -The Dominion empire-style game's @emph{exec} files. -@cindex Dominion - -@item -Any syntax for a ".*rc" file you might have used. Almost all programs -end up parsing some kind of startup or configuration file. The syntax -for those can get pretty involved, thus justifying calling them -"extension languages". The @emph{fvwm} window manager, for example, -parses a rather elaborate @file{.fvwmrc} file. - -@item -Brent Benson's libscheme.a, an embeddable Scheme interpreter. -@cindex Benson, Brent -@cindex libscheme - -@item -Guile, the GNU extension language, which is the subject of this -tutorial. - -@end itemize - -One lesson we can learn from looking at classical large software -applications is that "writers of large programs" always end up throwing -in some kind of parser for configuration or scripting. - -Of the examples listed above, Emacs Lisp, Tcl, Libscheme and Guile have -an important property: they are not added as an afterthought for a -specific application. They are general-purpose languages which a user -can learn (even in college courses) and then use to customize the -application program. - -This is a recent and (in my opinion) very exciting direction in -large-program software engineering: program designers can link in the -Guile or Tcl library from the very beginning, and tell their users "You -want to customize this program? Just use Scheme (or Tcl, or whatever -language), which you already know!" -@cindex large programs - - -@node History of Guile and its motivations -@section History of Guile and its motivations - -A few separate threads of events led to the development of Guile. - -In the fall of 1994, Richard Stallman, director of the GNU project, -posted an article with the subject "Why you should not use Tcl", in -which he argued that Tcl is inadequate as an extension language. This -generated a flurry of flames (available in the hypermail archive -(@url{http://www.utdallas.edu/acc/glv/Tcl/war/}) @strong{The Tcl War}). -@cindex Stallman, Richard -@cindex GNU project -@cindex Tcl - -The result was that Stallman then proposed his design for the GNU -Extension Language, first called GEL and then renamed Guile. The -discussion triggered by that article is also available in a hypermail -archive, @url{http://www.utdallas.edu/acc/glv/Tcl/war2/}. - -One interesting feature of this GNU Extension Language plan was that -users should have a @emph{choice} of languages to use in extending their -program. The basic language would be a slightly modified Scheme, and -translators would be written to convert other languages (like Tcl, -Python, Perl, C-like languages @dots{}) into Scheme. - -Tom Lord started working on this project immediately, taking Aubrey -Jaffer's small and portable implementation of Scheme, SCM, and making it -into an embeddable interpreter: callable from C and allowing new Scheme -procedures to be written in C. -@cindex Lord, Tom -@cindex Jaffer, Aubrey - -In the spring of 1995, the guile-ii snapshot was released. This made it -possible to start writing code in C and Scheme using the guile -facilities. - -The guile-iii snapshot was released the summer of 1995, and it had fixed -enough problems so that the access to Scheme data structures from C was -almost complete. - -After this, Cygnus Support added many features to Guile and finished -implementing others, so that Guile acquired thread support, a regular -expression matcher, a Tk interface, an interface to the SGI OpenGL -graphics system, an @emph{applet} formalism, and some other packages. -This was all in the Cygnus Guile r0.3 and r0.4 releases. -@cindex Cygnus Support - -Meanwhile, Tom Lord left the project after having produced a divergent -version of Guile: 1.0b2. The Free Software Foundation hired Jim Blandy -to coordinate Guile development. The FSF released its first version of -Guile in January 1997. In the future, many of the Cygnus packages will -be re-integrated into Guile. -@cindex Blandy, Jim -@cindex Free Software Foundation - - - -@node How to characterize Guile -@section How to characterize Guile - -I have already mentioned that Guile has become a kitchen sink package; -here you can see how Guile freely takes new commands and constructs from -the portable Scheme library @emph{slib}, the @emph{Tk} widget set, a -posix library (useful for UNIX systems programming), the regular -expression library @emph{rx}, and many more @dots{} -@cindex slib -@cindex Tk -@cindex POSIX -@c @cindex OpenGL -@cindex rx - -So Guile has many more primitive procedures available to it than those -specified in @ref{Standard Procedures, Revised(5) Report on the -Algorithmic Language Scheme, , r5rs, Revised(5) Report on the -Algorithmic Language Scheme}. On top of that, Guile will interpret -almost all standard Scheme programs. The only incompatible difference -between the basic Guile language and R5RS Scheme is that Guile is case -sensitive, whereas R5RS is case insensitive. We hope that few people -have written Scheme programs that depend on case insensitivity. -@cindex case sensitivity -@cindex Revised(5) Report on the Algorithmic Language Scheme -@cindex report on Scheme -@cindex Scheme language - report -@cindex Scheme language - definition - -Here is a possible view of the @emph{sum of the parts} in Guile: -@cindex extensions to standard Scheme -@cindex extensions to R5RS -@cindex Scheme extensions -@example -guile = standard Scheme (R5RS) - PLUS extensions to R5RS offered by SCM - PLUS some extra primitives offered by Guile (catch/throw) - PLUS portable Scheme library (SLIB) - PLUS embeddable Scheme interpreter library (libguile) - PLUS Tk toolkit - PLUS threads - PLUS Posix library -@c PLUS OpenGL library (mesa) -@c PLUS OpenGL toolkit (glut) - PLUS Regular expression library (rx) -@c PLUS Applet formalism - PLUS Tcl library -@end example - - -@node Using Guile to program in Scheme -@chapter Using Guile to program in Scheme -@cindex Scheme programming tutorial -@cindex tutorial on Scheme programming - -In this section I give a tutorial introduction to programming in Scheme, -with a slant toward the interesting things that can be done in Guile. - -@c Applets are so @emph{chic} that they get their own section, but this -This section will try to touch on many of the interesting and cool -aspects of Guile, showing you how new types of problems can be solved -with Guile. Note that using Guile as a library with @code{libguile.a} -is described in its own chapter (@pxref{Guile in a Library}). Also note -that some small examples are given in @ref{Jump Start}. - -To get started you need to know how to program in @dfn{Scheme} (a -dialect of LISP). Fortunately Scheme is a small, clean language and is -not hard to learn. It is also used in many undergraduate courses to -introduce computer programming. -@cindex lisp dialects - -I will not try to teach you Scheme here (although you might end up -learning by example), since there are many good books on the subject, -listed in @ref{Where to find more Guile/Scheme resources}. @footnote{To -get started, look at the books @cite{Simply Scheme} and @cite{The Little -Schemer} from that list.} - - -@subsection Hello World -@cindex hello world - -Our first program is the typical Scheme "hello world" program. Put the -following code in a file called @code{hello.scm} (this can be find in -@file{examples/scheme/hello.scm}). - -@smalllisp -#!/usr/local/bin/guile -s -!# - -(display "hello world") -(newline) -@end smalllisp - -Then run guile on it. One way to do so is to start up guile and load -this file: - -@smallexample - @kbd{guile} -guile> @kbd{(load "hello")} -@end smallexample - -Another way is to make the file executable and execute it directly. -Notice how Guile recognizes a @code{-s} option which tells it to run a -script and then exit. Guile also has a new type of block comment -enclosed by @code{#!} and @code{!#}, so that you can make executable -Scheme scripts with the standard UNIX @code{#!} mechanism. - -In the given example, the first line is used to invoke the Guile -interpreter (make sure you correct the path if you installed Guile in -something other than /usr/local/bin). Once Guile is invoked on this -file, it will understand that the first line is a comment. The comment -is then terminated with @code{!#} on the second line so as to not -interfere with the execution mechanism. - - -@subsection A bunch of operations in Scheme - -Here is some code you can type at the @code{guile>} prompt to see some -of the Scheme data types at work (mostly lists and vectors). I have -inserted brief comments @emph{before} each line of code explaining what -happens. - -@smalllisp -;; @r{make a list and bind it to the symbol @code{ls}} -guile> @kbd{(define ls (list 1 2 3 4 5 6 7))} - @result{} -;; @r{display the list} -guile> @kbd{ls} - @result{(1 2 3 4 5 6 7)} -;; @r{ask if @code{ls} is a vector; @code{#f} means it is not} -guile> @kbd{(vector? ls)} - @result{#f} -;; @r{ask if @code{ls} is a list; @code{#t} means it is} -guile> @kbd{(list? ls)} - @result{#t} -;; @r{ask for the length of @code{ls}} -guile> @kbd{(length ls)} - @result{7} -;; @r{pick out the first element of the list} -guile> @kbd{(car ls)} - @result{1} -;; @r{pick the rest of the list without the first element} -guile> @kbd{(cdr ls)} - @result{(2 3 4 5 6 7} -;; @r{this should pick out the 3rd element of the list} -guile> @kbd{(car (cdr (cdr ls)))} - @result{3} -;; @r{a shorthand for doing the same thing} -guile> @kbd{(caddr ls)} - @result{3} -;; @r{append the given list onto @code{ls}, print the result} -;; @r{@strong{NOTE:} the original list @code{ls} is @emph{not} modified} -guile> @kbd{(append ls (list 8 9 10))} - @result{(1 2 3 4 5 6 7 8 9 10)} -guile> @kbd{(reverse ls)} - @result{(10 9 8 7 6 5 4 3 2 1)} -;; @r{ask if 12 is in the list --- it obviously is not} -guile> @kbd{(memq 12 ls)} - @result{#f} -;; @r{ask if 4 is in the list --- returns the list from 4 on.} -;; @r{Notice that the result will behave as true in conditionals} -guile> @kbd{(memq 4 ls)} - @result{(4 5 6 7)} -;; @r{an @code{if} statement using the aforementioned result} -guile> @kbd{(if (memq 4 ls) - (display "hey, it's true!\n") - (display "dude, it's false\n"))} - @print{hey, it's true!} - @result{} -guile> @kbd{(if (memq 12 ls) - (display "hey, it's true!\n") - (display "dude, it's false\n"))} - @print{dude, it's false} - @result{} -guile> @kbd{(memq 4 (reverse ls))} - @result{(4 3 2 1)} -;; @r{make a smaller list @code{ls2} to work with} -guile> @kbd{(define ls2 (list 2 3 4))} -;; @r{make a list in which the function @code{sin} has been} -;; @r{applied to all elements of @code{ls2}} -guile> @kbd{(map sin ls2)} - @result{(0.909297426825682 0.141120008059867 -0.756802495307928)} -;; @r{make a list in which the squaring function has been} -;; @r{applied to all elements of @code{ls}} -guile> @kbd{(map (lambda (n) (expt n n)) ls)} - @result{(1 4 27 256 3125 46656 823543)} -@end smalllisp - -@smalllisp -;; @r{make a vector and bind it to the symbol @code{v}} -guile> @kbd{(define v #(1 2 3 4 5 6 7))} -guile> @kbd{v} - @result{#(1 2 3 4 5 6 7)} -guile> @kbd{(vector? v)} - @result{#t} -guile> @kbd{(list? v)} - @result{#f} -guile> @kbd{(vector-length v)} - @result{7} -;; @r{vector-ref allows you to pick out elements by index} -guile> @kbd{(vector-ref v 2)} - @result{3} -;; @r{play around with the vector: make it into a list, reverse} -;; @r{the list, go back to a vector and take the second element} -guile> @kbd{(vector-ref (list->vector (reverse (vector->list v))) 2)} - @result{5} -;; @r{this demonstrates that the entries in a vector do not have} -;; @r{to be of uniform type} -guile> @kbd{(vector-set! v 4 "hi there")} - @result{"hi there"} -guile> @kbd{v} - @result{#(1 2 3 4 "hi there" 6 7)} -@end smalllisp - - -@subsection Using recursion to process lists -@cindex recursion -@cindex list processing - -Here are some typical examples of using recursion to process a list. - -@smalllisp -;; @r{this is a rather trivial way of reversing a list} -(define (my-reverse l) - (if (null? l) - l - (append (my-reverse (cdr l)) (list (car l))))) -(my-reverse '(27 32 33 40)) -@result{(40 33 32 27)} -@end smalllisp - - -@subsection Processing matrices - -Suppose you have a matrix represented as a list of lists: - -@smalllisp -(define m - (list - (list 7 2 1 3 2 8 5 3 6) - (list 4 1 1 1 3 8 9 8 1) - (list 5 5 4 8 1 8 2 2 4))) -@end smalllisp - -Then you could apply a certain function to each element of the matrix in -the following manner: -@smalllisp -;; @r{apply the function func to the matrix m element-by-element;} -;; @r{return a matrix with the result.} -(define (process-matrix m func) - (map (lambda (l) - (map func l)) - m)) -@end smalllisp -Notice that I have used the Scheme @code{map} procedure because I am -interested in the matrix that results from the application of -@code{func}, rather than in the side effects associated with applying -@code{func}. - -This could be invoked with @code{(process-matrix m sin)} or -@code{(process-matrix m (lambda (x) (* x x)))}; for example: - -@smalllisp -(process-matrix m (lambda (x) (* x x))) -@result{((49 4 1 9 4 64 25 9 36) (16 1 1 1 9 64 81 64 1) (25 25 16 64 1 64 4 4 16))} -@end smalllisp - -To print a representation of the matrix, we could define a generalized -routine: -@smalllisp -;; @r{proc is a procedure to represent the single element,} -;; @r{row-proc is a procedure that is invoked after each row.} -;; @r{Example: proc could be (lambda (x) (begin (display x) (display " ")))} -;; @r{and row-proc could be (lambda (l) (display "\n"))} -(define (represent-matrix m proc row-proc) - (for-each (lambda (l) - (begin - (for-each proc l) - (row-proc l))) - m)) -@end smalllisp -@findex represent-matrix - -And then invoke it with -@smalllisp -(represent-matrix m - (lambda (x) (begin (display x) (display " "))) - (lambda (l) (begin (display "\n")))) -@print{7 2 1 3 2 8 5 3 6} -@print{4 1 1 1 3 8 9 8 1} -@print{5 5 4 8 1 8 2 2 4} -@end smalllisp - -@cindex objects - -Now we write a helper routine that uses Scheme @dfn{closures} to make -objects with state that then receive messages to draw little squares. -@cindex closures -@cindex syntactic closures - -But let us take it one step at a time. I will start by showing you a -simple example of object in Scheme. The object I make here represents a -cell, which could be a cell in a matrix. The cell responds to commands -to draw itself, to return the next cell, and so forth. @emph{Guile does -not currently have a Tk interface, so I will leave the hooks for -graphical rendering. In a future release of Guile I will add graphical -rendering messages to the cell object.} - -@smallexample -;; @r{cell-object.scm: routines for creating and manipulating cell objects} - -;; @r{(the-x, the-y) is the initial position of the cell.} -;; @r{the-color is a string representing a color; must be something Tk can grok.} -;; @r{square-size is the size of the square that gets drawn.} -;; @r{(sizex, sizey) is the size of the matrix.} -(define (MAKE-CELL the-x the-y the-color square-size sizex sizey) - (define (get-x) the-x) - (define (get-y) the-y) - - (define (set-x! new-x) - (set! the-x new-x) - the-x) - (define (set-y! new-y) - (set! the-y new-y) - the-y) - (define (get-color) the-color) - (define (set-color! new-color) - (set! the-color new-color) - the-color) - (define (next!) - (set! the-x (+ the-x 1)) - (if (>= the-x sizex) - (begin - (set! the-x 0) - (set! the-y (+ the-y 1)))) - (if (>= the-y sizey) - (begin - (display "CELL next!: value of y is too big; not changing it\n") - (set! the-y (- the-y 1)))) - (cons the-x the-y)) - (define (draw) - (let* ((x0 (* the-x square-size)) - (y0 (* the-y square-size)) - (x1 (+ x0 square-size)) - (y1 (+ y0 square-size))) - (display "I should draw a ") - (display the-color) - (display " rectangle with corners at ") - (display x0) (display y0) (display x1) (display y1) - )) - - ;; self is the dispatch procedure - (define (self message) - (case message - ((x) get-x) - ((y) get-y) - ((set-x!) set-x!) - ((set-y!) set-y!) - ((color) get-color) - ((set-color!) set-color!) - ((next!) next!) - ((draw) draw) - (else (error "CELL: Unknown message -> " message)))) - ;; and now return the dispatch procedure - self - ) -@end smallexample -@cindex cell-object -@findex MAKE-CELL - -What does this procedure do? It returns another procedure -(@code{self}) which receives a message (x, y, set-x!, set-y!, @dots{}) -and takes an action to return or modify its state. The state consists -of the values of variables @code{the-x}, @code{the-y}, @code{the-color} -and so forth. - -Here are some examples of how to use MAKE-CELL and the cell object it -creates: -@smallexample -(define c (MAKE-CELL 0 0 "red" 10 7 9)) - -;; @r{retrieve the x and y coordinates} -((c 'x)) -@result{0} -((c 'y)) -@result{0} -;; @r{change the x coordinate} -((c 'set-x!) 5) -@result{5} -((c 'x)) -@result{5} -;; @r{change the color} -((c 'color)) -@result{"red"} -((c 'set-color!) "green") -@result{"green"} -((c 'color)) -@result{"green"} -;; @r{now use the next! message to move to the next cell} -((c 'next!)) -@result{(6 . 0)} -((c 'x)) -@result{6} -((c 'y)) -@result{0} -;; @r{now make things wrap around} -((c 'next!)) -@result{(0 . 1)} -((c 'next!)) -@result{(1 . 1)} -((c 'next!)) -@result{(2 . 1)} -((c 'x)) -@result{2} -((c 'y)) -@result{1} -@end smallexample - -You will notice that expressions like @code{(c 'next)} return procedures -that do the job, so we have to use extra parentheses to make the job -happen. This syntax is rather awkward; one way around it is to define a -@code{send} procedure: - -@smallexample -;; @r{send makes object syntax a bit easier; instead of saying} -;; @r{ ((my-cell 'set-x!) 4)} -;; @r{you can say} -;; @r{ (send my-cell 'set-x! 4)} -(define (send obj . args) - (let ((first-eval (apply obj (list (car args))))) - (if (null? (cdr args)) - (first-eval) - (apply first-eval (cdr args))))) -@end smallexample -@findex send - -You can see that @code{send} passes the message to the object, making -sure that things are evaluated the proper number of times. You can now -type: - -@smallexample -(define c2 (MAKE-CELL 0 0 "red" 10 7 9)) -(send c2 'x) -@result{0} -(send c2 'set-x! 5) -@result{5} -(send c2 'color) -@result{"red"} -(send c2 'set-color! "green") -@result{"green"} -(send c2 'next!) -@result{(1 . 0)} -(send c2 'x) -@result{1} -(send c2 'y) -@result{0} -@end smallexample - -@cindex object-based programming -@cindex object-oriented programming - -This is the simplest way of implementing objects in Scheme, but it does -not really allow for full @emph{object-oriented programming} (for -example, there is no inheritance). But it is useful for -@emph{object-based programming}. - -Guile comes with a couple more complete object-oriented extensions to -Scheme: these are part of slib (@pxref{Object, , , slib, SLIB: the -portable Scheme library} and @pxref{Yasos, , , slib, SLIB: the portable -Scheme library}). - -@node Guile in a Library -@chapter Guile in a Library - -@iftex -@nobreak -@end iftex -In the previous chapters Guile was used to write programs entirely in -Scheme, and no C code was seen; but I have been claiming @emph{ad -nauseam} that Guile is an @emph{extension} language. Here we see how -that is done, and how that can be useful. -@cindex libguile -@cindex extending C programs - - -@menu -* Two world views:: -* What is libguile:: -* How to get started with libguile:: -* More interesting programming with libguile:: -* Further examples:: -@end menu - -@node Two world views -@section Two world views -@cindex master world - -In this manual, I usually jump into examples and explain them as you -type in the code; here I will digress and ramble for a few paragraphs to -set some concepts straight, and then let you type (or paste) in fun -examples. - -In 1995, I implemented a large program, @dfn{Gnudl}, using Guile quite -extensively. In the design phase of Gnudl, I found I had to make a -choice: should the fundamental data structures be C or Scheme data -structures? -@cindex gnudl -@cindex GNU Data Language -@cindex Galassi, Mark - -Guile allows C to see its data structures (scalar types, lists, vectors, -strings @dots{}). C also allows Guile to see its data structures. As a -large program designer, you have to decide which of those capabilities -to use. You have two main choices: - -@enumerate 1 -@item -You can write your software mostly in Scheme. In this case, your C -software will mostly parse the Scheme code with Guile calls, and provide -some new primitive procedures to be used by Scheme. This is what Gnudl -does. - -@item -You can write your software mostly in C, occasionally allowing Scheme -code to be parsed by Guile, either to allow the user to modify data -structures, or to parse a configuration file, @dots{} -@end enumerate - -Mixing the two approaches seems unwise: the overall layout would be -confusing. But who knows? There might be problems that are best solved -by a hybrid approach. Please let me know if you think of such a -problem. - -If you use the former approach, we will say that the @dfn{master world} -is Scheme, and the C routines serve Scheme and access Scheme data -structures. In the latter case, the master world is C, and Scheme -routines serve the C code and access C data structures. - -In both approaches the @code{libguile.a} library is the same, but a -predominantly different set of routines will be used. When we go -through examples of libguile use, we will point out which is the master -world in order to clarify these two approaches. - - -@node What is libguile -@section What is libguile -@cindex libguile -@cindex gh interface -@cindex scm interface - -@dfn{Libguile} is the library which allows C programs to start a Scheme -interpreter and execute Scheme code. There are also facilities in -libguile to make C data structures available to Scheme, and vice versa. - -The interface provided by the libguile C library is somewhat specific to -the implementation of the Scheme interpreter. This low-level libguile -interface is usually referred to as the @code{scm_} interface, since its -public calls (API) all have the @code{scm_} prefix. - -There is also a higher-level libguile interface, which is usually -referred to as the @code{gh_} interface (libGuile High). Its public -calls all have the @code{gh_} prefix. The @code{gh_} library interface -is designed to hide the implementation details, thus making it easier to -assimilate and portable to other underlying Scheme implementations. - -People extending Guile by adding bindings to C libraries (like OpenGL or -Rx) are encouraged to use the @code{gh_} interface, so their work will -be portable to other Scheme systems. The @code{gh_} interface should be -more stable, because it is simpler. - -The @code{scm_} interface is necessary if you want to poke into the -innards of Scheme data structures, or do anything else that is not -offered by the @code{gh_} interface. It is not covered in this -tutorial, but is covered extensively in @ref{Scheme data representation, -Guile Reference Manual, guile-ref, Guile Reference Manual}. - -This chapter gives a gentle introduction to the @code{gh_} interface, -presenting some @emph{hello world}-style programs which I wrote while -teaching myself to use libguile. -@cindex hello world - -The @cite{Guile Programmer's Manual} gives more examples of programs -written using libguile, illustrating diverse applications. You can also -consult my @emph{Gnudl} documentation at -@url{http://nis-www.lanl.gov/~rosalia/mydocs/} to see a large scale -project that uses C and Scheme code together. - - -@node How to get started with libguile -@section How to get started with libguile -@cindex learn0 - -Here is an elementary first program, @code{learn0}, to get going with -libguile. The program (which uses Scheme as a master world) is in a -single source file, @code{learn0.c}: - -@smallexample -/* @r{test the new libgh.a (Guile High-level library) with a trivial - program} */ - -#include - -#include - -void main_prog(int argc, char *argv[]); - -main(int argc, char *argv[]) -@{ - gh_enter(argc, argv, main_prog); -@} - -void main_prog(int argc, char *argv[]) -@{ - int done; - char input_str[200]; - - gh_eval_str("(display \"hello Guile\")"); - gh_eval_str("(newline)"); - - /* @r{for fun, evaluate some simple Scheme expressions here} */ - gh_eval_str("(define (square x) (* x x))"); - gh_eval_str("(define (fact n) (if (= n 1) 1 (* n (fact (- n 1)))))"); - gh_eval_str("(square 9)"); - - /* @r{now sit in a Scheme eval loop: I input the expressions, have - Guile evaluate them, and then get another expression.} */ - done = 0; - fputs("learn0> ", stdout); - while (fgets(input_str, 199, stdin) != NULL) @{ - gh_eval_str(input_str); - fputs("\nlearn0> ", stdout); - @} - - exit(0); -@} -@end smallexample - -If you name this program @code{learn0.c}, it can now be compiled with: -@smallexample -gcc -g -c learn0.c -o learn0.o -gcc -o learn0 learn0.o -lguile -lm -@end smallexample - -@c @emph{NOTE: If you are in the Guile development tree, you can simply do -@c ``cd doc/examples/c; make; ./learn0''.} - -The program is simple: it creates a Scheme interpreter, passes a couple -of strings to it that define new Scheme functions @code{square} and -@code{factorial}, and then a couple of strings that invoke those -functions. - -It then goes into a read-eval-print-loop (REPL), so you could type -one-line Scheme expressions to it and have them evaluated. For example: -@smallexample - ./learn0 -hello Guile -learn0> (display (sin 1.3)) -963.558185417193e-3 -learn0> (display (fact 10)) -3628800 -learn0> (quit) - -@end smallexample - -You should notice the key steps involved in this @code{learn0} program: - -@cartouche -@enumerate -@item -@code{#include } -@item -You need to invoke the initialization routine @code{gh_enter()}. This -starts up a Scheme interpreter, handling many implementation-specific -details. -@item -Your main() function should be almost empty: the real main program goes -in a separate function main_prog() which is passed to gh_enter(). This -rather arcane convention is due to the way Guile's garbage collector -works: the whole program has to run in the dynamic context of -@code{gh_enter()}. -@item -You pass strings to the Scheme interpreter with the @code{gh_eval_str()} -routine. -@item -You link your program with @code{-lguile}. -@end enumerate -@end cartouche - - -@node More interesting programming with libguile -@section More interesting programming with libguile -@cindex learn1 -@cindex callback -@cindex builtin functions - -The @code{learn0} program shows how you can invoke Scheme commands from -a C program. This is not such a great achievement: the same could have -been done by opening a pipe to SCM or any other Scheme interpreter. - -A true extension language must allow @dfn{callbacks}. Callbacks allow -you to write C routines that can be invoked as Scheme procedures, thus -adding new primitive procedures to Scheme. This also means that a -Scheme procedure can modify a C data structure. - -Guile allows you to define new Scheme procedures in C, and provides a -mechanism to go back and forth between C and Scheme data types. - -Here is a second program, @code{learn1}, which demonstrates these -features. It is split into three source files: @code{learn1.c}, -@code{c_builtins.h} and @code{c_builtins.c}. I am including the code -here. -@c , but you might just want to look at the online source code and the -@c Makefile.am that come with Guile in the -@c @file{doc/examples/c} directory. - -Notice that @code{learn1} uses a Scheme master world, and the C routines -in @code{c_builtins.c} are simply adding new primitives to Scheme. - -@menu -* learn1.c:: -* c_builtins.h:: -* c_builtins.c:: -* What learn1 is doing:: -* Compiling and running learn1:: -@end menu - -@node learn1.c -@subsection learn1.c - -Here is @file{learn1.c}: -@smallexample -#include - -#include - -#include "c_builtins.h" - -void main_prog(int argc, char *argv[]); - -main(int argc, char *argv[]) -@{ - gh_enter(argc, argv, main_prog); -@} - -void main_prog(int argc, char *argv[]) -@{ - char input_str[200]; /* @r{ugly hack: assume strlen(line) < 200} */ - int done; - - /* @r{for fun, evaluate some simple Scheme expressions here} */ - gh_eval_str("(define (square x) (* x x))"); - gh_eval_str("(define (fact n) (if (= n 1) 1 (* n (fact (- n 1)))))"); - gh_eval_str("(square 9)"); - gh_eval_str("(fact 100)"); - - /* @r{now try to define some new builtins, coded in C, so that they are - available in Scheme.} */ - gh_new_procedure1_0("c-factorial", c_factorial); - gh_new_procedure1_0("c-sin", c_sin); - gh_new_procedure1_0("v-t", vector_test); - - /* @r{now sit in a Scheme eval loop: I input the expressions, have - Guile evaluate them, and then get another expression.} */ - done = 0; - fputs("learn1> ", stdout); - while (!done) @{ - if (gets(input_str) == NULL) @{ - done = 1; - @} else @{ - gh_eval_str(input_str); - fputs("learn1> ", stdout); - @} - @} - - exit(0); -@} -@end smallexample - -@node c_builtins.h -@subsection c_builtins.h - -Here is @file{c_builtins.h}: -@smallexample -/* @r{builtin function prototypes} */ - -#include - -SCM c_factorial(SCM n); -SCM c_sin(SCM n); -SCM vector_test(SCM s_length); -@end smallexample - -@node c_builtins.c -@subsection c_builtins.c - -Here is @file{c_builtins.c}: -@smallexample -#include -#include - -#include - -#include "c_builtins.h" - -/* @r{this is a factorial routine in C, made to be callable by Scheme} */ -SCM c_factorial(SCM s_n) -@{ - int i; - unsigned long result = 1, n; - - n = gh_scm2ulong(s_n); - - gh_defer_ints(); - for (i = 1; i <= n; ++i) @{ - result = result*i; - @} - gh_allow_ints(); - return gh_ulong2scm(result); -@} - -/* @r{a sin routine in C, callable from Scheme. it is named c_sin() to - distinguish it from the default Scheme sin function} */ -SCM c_sin(SCM s_x) -@{ - double x = gh_scm2double(s_x); - - return gh_double2scm(sin(x)); -@} - -/* @r{play around with vectors in Guile: this routine creates a vector of - the given length, initializes it all to zero except element 2 which - is set to 1.9.} */ -SCM vector_test(SCM s_length) -@{ - SCM xvec; - - c_length = gh_scm2ulong(s_length); - printf("requested length for vector: %ld\n", gh_scm2ulong(s_length)); - - /* create a vector */ - xvec = gh_make_vector(s_length, gh_double2scm(0.0)); - /* set the second element in it */ - gh_vector_set_x(xvec, gh_int2scm(2), gh_double2scm(1.9)); - - return xvec; -@} -@end smallexample - -@node What learn1 is doing -@subsection What learn1 is doing -@cindex registering callbacks -@cindex registering C functions -@cindex primitive procedures - -If you compare learn1 to learn0, you will find that learn1 uses a new -Guile construct: the function @code{gh_new_procedure()}, and its -siblings: - -@smallexample - /* @r{now try to define some new builtins, coded in C, so that they are - available in Scheme.} */ - gh_new_procedure1_0("c-factorial", c_factorial); - gh_new_procedure1_0("c-sin", c_sin); - gh_new_procedure1_0("v-t", vector_test); -@end smallexample - -It is clear that @code{gh_new_procedure()} adds a new builtin -routine written in C which can be invoked from Scheme. We can now -revise our checklist for programming with libguile, so it includes -adding callbacks. -@cindex libguile - step by step - -@cartouche -@enumerate -@item -@code{#include } -@item -You need to invoke the initialization routine @code{gh_enter()}. This -starts up a Scheme interpreter, handling many details. -@item -Your main() function should be almost empty: the real main program goes -in a separate function main_prog() which is passed to gh_enter(). This -rather arcane convention is due to the way Guile's garbage collector -works: the whole program has to run in the dynamic context of -@code{gh_enter()}. -@item -You pass strings to the Scheme interpreter with the @code{gh_eval_str()} -routine. -@item -@strong{[new]} You can now define new builtin Scheme functions; -i.e. define new builtin Scheme functions, with the -@code{gh_new_procedure()} routine. -@item -You pass strings to the Scheme interpreter with the -@code{gh_eval_str()} routine. -@item -You link your program with @code{-lguile}. -@end enumerate -@end cartouche - -I breezed by the issue of how to write your C routines that are -registered to be called from Scheme. This is non-trivial, and is -discussed at length in the @cite{Guile Programmer's Manual}. - - -@node Compiling and running learn1 -@subsection Compiling and running learn1 - -@smallexample -gcc -g -c learn1.c -o learn1.o -gcc -g -c c_builtins.c -o c_builtins.o -gcc -o learn1 learn1.o c_builtins.o -lguile -lm -@end smallexample - -If you run @code{learn1}, it will prompt you for a one-line Scheme -expression, just as @code{learn0} did. The difference is that you can -use the new C builtin procedures (@code{c-factorial}, @code{c-sin}, -@code{v-t}). - -@smallexample - ./learn1 -welcome to Guile -hello Guile -learn1> (display (c-factorial 6)) -720 -learn1> (display (c-factorial 20)) -2192834560 -learn1> (display (c-factorial 100)) -0 -learn1> (display (c-sin 1.5)) -0.997494986604054 -learn1> (display (v-t 10)) -requested length for vector: 10 -#(0.0 0.0 1.9 0.0 0.0 0.0 0.0 0.0 0.0 0.0) -learn1> (display (v-t 15)) -requested length for vector: 15 -#(0.0 0.0 1.9 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0) -learn1> (quit) - -@end smallexample - -As you see, taking @code{(c-factorial 100)} does not use bignumbers and -returns a bogus answer. - -@node Further examples -@section Further examples - -Further ``idealized'' examples are included in the @code{doc/examples/c} -distribution. They include programs to: - -@c [FIXME: still have to write some of these; then I will revise the list.] - -@itemize @bullet -@item -Parse a startup file (C is the master world). -@item -Set up initial conditions for an n-body simulation (C is the master -world). -@item -Implement a Scheme interpreter with all of Guile's goodies, @emph{plus} -the readline library @emph{and} a fast Fourier transform routine -provided in C (Scheme is the master world). -@end itemize - -@node Regular Expression Support -@chapter Regular Expression Support - -@node UNIX System Programming -@chapter UNIX System Programming - -@node Where to find more Guile/Scheme resources -@chapter Where to find more Guile/Scheme resources - - -@node Concept Index -@unnumbered Concept Index - -@printindex cp - -@node Procedure and Macro Index -@unnumbered Procedure and Macro Index - -This is an alphabetical list of all the procedures and macros in Dominion. - -@printindex fn - -@node Variable Index -@unnumbered Variable Index - -This is an alphabetical list of the major global variables in Dominion. - -@printindex vr - -@node Type Index -@unnumbered Type Index - -This is an alphabetical list of the major data structures in Dominion. - -@printindex tp - -@contents - -@bye diff --git a/doc/guile.texi b/doc/guile.texi index 3571a51a9..a163dfaad 100644 --- a/doc/guile.texi +++ b/doc/guile.texi @@ -3,90 +3,30 @@ @c %**start of header @setfilename guile.info @settitle Guile Reference Manual +@set guile @c %**end of header -@c Neil's notes: - -@c This file started life as a copy of guile-ref.texi, which I then -@c modified to reflect the organization described in -@c sources/jimb-org.texi. - -@c Jim's notes: - -@c Remember to use "subr" whereever appropriate. -@c Actually, use "primitive", not "subr." Why coin a new term? +@c Notes: (distilled from Jim's and Tim's notes, and kept up to date) +@c +@c Remember to use "primitive" whereever appropriate. @c FIXME: gotta change existing "subr" uses to "Primitive". -@c In my text for the Guile snarfer, I've used the term "subr" to denote -@c a C function made available to the Scheme world as a function. This -@c terminology is weird, but consistent with the function names and also -@c with Emacs Lisp, which I assume takes Maclisp's lead. - -@c Tim's notes: - +@c [JimB:] In my text for the Guile snarfer, I've used the term "subr" +@c to denote a C function made available to the Scheme world as a +@c function. This terminology is weird, but consistent with the +@c function names and also with Emacs Lisp, which I assume takes +@c Maclisp's lead. +@c @c When adding a new function to the Guile manual, please document @c it with @deffn as one of `primitive', `procedure', or `syntax'. @c -@c The following Guile primitives are not documented. We have a lot -@c of work to do. -@c -@c arbiters.c: make-arbiter, try-arbiter, release-arbiter -@c async.c: async, async-mark, system-async, system-async-mark, -@c run-asyncs, noop, set-tick-rate, set-switch-rate, -@c unmask-signals, mask-signals -@c backtrace.c: backtrace, display-error, display-application, -@c display-backtrace -@c chars.c: char-is-both? -@c debug.c: single-step, memoized?, unmemoize, memoized-environment, -@c procedure-name, procedure-source, procedure-environment, -@c local-eval, debug-object?, debug-hang -@c dynl.c: c-registered-modules, c-clear-registered-modules, -@c dynamic-link, dynamic-object?, dynamic-unlink, dynamic-func, -@c dynamic-call, dynamic-args-call -@c eval.c: procedure->syntax, procedure->macro, procedure->memoizing-macro, -@c macro-name, macro-transformer -@c fluids.c: make-fluid, fluid?, fluid-ref, fluid-set, with-fluids* -@c gc.c: map-free-list, unhash-name -@c kw.c: make-keyword-from-dash-symbol -@c net_db.c: sethost, setnet, setproto, setserv -@c print.c: current-pstate -@c procs.c: make-cclo, closure?, thunk? -@c read.c: read-hash-extend -@c readline.c: readline, add-history -@c srcprop.c: source-properties, set-source-properties!, -@c source-property, set-source-property! -@c stacks.c: make-stack, stack-ref, stack-length, -@c frame?, last-stack-frame, frame-number, frame-source, -@c frame-procedure, frame-arguments, frame-previous, frame-next, -@c frame-real?, frame-procedure?, frame-evaluating-args?, -@c frame-overflow -@c struct.c: struct-vtable-tag -@c symbols.c: builtin-weak-bindings -@c tag.c: tag -@c threads.c: single-active-thread?, yield, call-with-new-thread, -@c make-condition-variable, wait-condition-variable, -@c signal-condition-variable -@c throw.c: lazy-catch, vector-set-length! -@c unif.c: uniform-vector-ref, uniform-array-set1! -@c variable.c: make-variable, make-undefined-variable, variable?, -@c variable-ref, variable-set!, builtin-variable, variable-bound? -@c weaks.c: make-weak-vector, weak-vector, list->weak-vector, -@c weak-vector? make-weak-key-hash-table, -@c make-weak-value-hash-table, make-doubly-weak-hash-table, -@c weak-key-hash-table?, weak-value-hash-table?, -@c doubly-weak-hash-table? -@c -@c If you have worked with some of these concepts, implemented them, -@c or just happen to know what they do, please write up a little -@c explanation -- it would be a big help. Alternatively, if you -@c know of a great reason why some of these should *not* go in the -@c manual, please let me know. -@c -@c The following functions are currently left undocumented for various reasons. -@c * should be documented in a section on debugging or Guile internals: -@c ports.c: pt-size, pt-member -@c eval.c: apply:nconc2last -@c -@c Thanks. -twp +@c For a list of Guile primitives that are not yet incorporated into the +@c reference manual, see the file `new-docstrings.texi', which holds all +@c the docstrings snarfed from the libguile C sources for primitives +@c that are not in the reference manual. If you have worked with some +@c of these concepts, implemented them, or just happen to know what they +@c do, please write up a little explanation -- it would be a big help. +@c Alternatively, if you know of a great reason why some of these should +@c *not* go in the manual, please let me know. @c Define indices that are used in the Guile Scheme part of the @c reference manual to group stuff according to whether it is R5RS or a @@ -140,24 +80,10 @@ by the Free Software Foundation. @sp 10 @comment The title is printed in a large font. @title Guile Reference Manual -@subtitle $Id: guile.texi,v 1.6 2001-04-28 09:00:31 ossau Exp $ +@subtitle $Id: guile.texi,v 1.7 2001-04-28 23:38:52 ossau Exp $ @subtitle For use with Guile @value{VERSION} -@author Mark Galassi -@author Cygnus Solution and Los Alamos National Laboratory -@author @email{rosalia@@cygnus.com} -@author -@author Jim Blandy -@author Free Software Foundation and MIT AI Lab -@author @email{jimb@@red-bean.com} -@author -@author Gary Houston -@author @email{ghouston@@arglist.com} -@author -@author Tim Pierce -@author @email{twp@@skepsis.com} -@author -@author Neil Jerram -@author @email{neil@@ossau.uklinux.net} +@include AUTHORS + @c The following two commands start the copyright page. @page @vskip 0pt plus 1filll @@ -207,6 +133,7 @@ Preface * Guile License:: Conditions for copying and using Guile. * Manual Layout:: How to read the rest of this manual. +* Manual Conventions:: Conventional terminology. Part I: Introduction to Guile From b0e5fd8c3d8c09b4b11224e9f8d4cbf6a20a07a8 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 29 Apr 2001 13:03:14 +0000 Subject: [PATCH 0946/2047] * rw.c: new file, implementing C part of module (ice-9 rw). (scm_read_string_x_partial): moved from ioext.c (scm_init_rw): new proc. * rw.h: new file. init.c: include rw.h and call scm_init_rw. Makefile.am: include rw.c and rw.h. --- libguile/ChangeLog | 9 +++ libguile/Makefile.am | 10 +-- libguile/init.c | 4 +- libguile/ioext.c | 103 ------------------------- libguile/ioext.h | 2 - libguile/rw.c | 178 +++++++++++++++++++++++++++++++++++++++++++ libguile/rw.h | 59 ++++++++++++++ 7 files changed, 254 insertions(+), 111 deletions(-) create mode 100644 libguile/rw.c create mode 100644 libguile/rw.h diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 4a71762eb..961b87f40 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2001-04-29 Gary Houston + + * rw.c: new file, implementing C part of module (ice-9 rw). + (scm_read_string_x_partial): moved from ioext.c + (scm_init_rw): new proc. + * rw.h: new file. + init.c: include rw.h and call scm_init_rw. + Makefile.am: include rw.c and rw.h. + 2001-04-28 Rob Browning * numbers.c: enabled local definition of SCM_FLOBUFLEN until we diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 145413368..4bd6aa12e 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -1,6 +1,6 @@ ## Process this file with Automake to create Makefile.in ## -## Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. +## Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -46,7 +46,7 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ hashtab.c hooks.c init.c ioext.c iselect.c keywords.c lang.c list.c \ load.c macros.c mallocs.c modules.c numbers.c objects.c objprop.c \ options.c pairs.c ports.c print.c procprop.c procs.c properties.c \ - random.c rdelim.c read.c root.c scmsigs.c script.c simpos.c smob.c \ + random.c rdelim.c read.c root.c rw.c scmsigs.c script.c simpos.c smob.c \ sort.c srcprop.c stackchk.c stacks.c stime.c strings.c strop.c \ strorder.c strports.c struct.c symbols.c tag.c throw.c values.c \ variable.c vectors.c version.c vports.c weaks.c @@ -57,7 +57,7 @@ DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ gsubr.x guardians.x hash.x hashtab.x hooks.x init.x ioext.x iselect.x \ keywords.x lang.x list.x load.x macros.x mallocs.x modules.x \ numbers.x objects.x objprop.x options.x pairs.x ports.x print.x \ - procprop.x procs.x properties.x random.x rdelim.x read.x root.x \ + procprop.x procs.x properties.x random.x rdelim.x read.x root.x rw.x \ scmsigs.x script.x simpos.x smob.x sort.x srcprop.x \ stackchk.x stacks.x stime.x strings.x strop.x strorder.x strports.x \ struct.x symbols.x tag.x throw.x values.x variable.x vectors.x \ @@ -73,7 +73,7 @@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \ iselect.doc keywords.doc lang.doc list.doc load.doc macros.doc \ mallocs.doc modules.doc numbers.doc objects.doc objprop.doc \ options.doc pairs.doc ports.doc print.doc procprop.doc \ - procs.doc properties.doc random.doc rdelim.doc read.doc root.doc \ + procs.doc properties.doc random.doc rdelim.doc read.doc root.doc rw.doc \ scmsigs.doc script.doc simpos.doc smob.doc sort.doc \ srcprop.doc stackchk.doc stacks.doc stime.doc strings.doc strop.doc \ strorder.doc strports.doc struct.doc symbols.doc tag.doc throw.doc \ @@ -118,7 +118,7 @@ modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h boolean.h \ iselect.h keywords.h lang.h list.h load.h macros.h mallocs.h modules.h \ net_db.h numbers.h objects.h objprop.h options.h pairs.h ports.h posix.h \ regex-posix.h print.h procprop.h procs.h properties.h random.h ramap.h \ - rdelim.h read.h root.h scmsigs.h validate.h script.h simpos.h smob.h \ + rdelim.h read.h root.h rw.h scmsigs.h validate.h script.h simpos.h smob.h \ snarf.h socket.h sort.h srcprop.h stackchk.h stacks.h stime.h strings.h \ strop.h strorder.h strports.h struct.h symbols.h tag.h tags.h threads.h \ throw.h unif.h values.h variable.h vectors.h version.h vports.h weaks.h diff --git a/libguile/init.c b/libguile/init.c index 75722a990..99e67cdae 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -114,6 +114,7 @@ #include "libguile/random.h" #include "libguile/rdelim.h" #include "libguile/read.h" +#include "libguile/rw.h" #include "libguile/scmsigs.h" #include "libguile/script.h" #include "libguile/simpos.h" @@ -588,10 +589,11 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_load_startup_files (); - /* this is located here, not from a deep understanding of the + /* these are located here, not from a deep understanding of the module system, but as a way of avoiding segv and other undesirable side effects that arise from various alternatives. */ scm_init_rdelim (); + scm_init_rw (); } /* Record here whether SCM_BOOT_GUILE_1 has already been called. This diff --git a/libguile/ioext.c b/libguile/ioext.c index 3923ed95c..2c1ed4a46 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -51,119 +51,16 @@ #include "libguile/fports.h" #include "libguile/feature.h" #include "libguile/ports.h" -#include "libguile/root.h" #include "libguile/strings.h" #include "libguile/validate.h" #include -#ifdef HAVE_STRING_H -#include -#endif #ifdef HAVE_UNISTD_H #include #endif -#if defined (EAGAIN) -#define SCM_MAYBE_EAGAIN || errno == EAGAIN -#else -#define SCM_MAYBE_EAGAIN -#endif - -#if defined (EWOULDBLOCK) -#define SCM_MAYBE_EWOULDBLOCK || errno == EWOULDBLOCK -#else -#define SCM_MAYBE_EWOULDBLOCK -#endif - -/* MAYBE there is EAGAIN way of defining this macro but now I EWOULDBLOCK. */ -#define SCM_EBLOCK(errno) \ - (0 SCM_MAYBE_EAGAIN SCM_MAYBE_EWOULDBLOCK) - -SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0, - (SCM str, SCM port_or_fdes, SCM start, SCM end), - "Read characters from an fport or file descriptor into a\n" - "string @var{str}. This procedure is scsh-compatible\n" - "and can efficiently read large strings. It will:\n\n" - "@itemize\n" - "@item\n" - "attempt to fill the entire string, unless the @var{start}\n" - "and/or @var{end} arguments are supplied. i.e., @var{start}\n" - "defaults to 0 and @var{end} defaults to\n" - "@code{(string-length str)}\n" - "@item\n" - "use the current input port if @var{port_or_fdes} is not\n" - "supplied.\n" - "@item\n" - "read any characters that are currently available,\n" - "without waiting for the rest (short reads are possible).\n\n" - "@item\n" - "wait for as long as it needs to for the first character to\n" - "become available, unless the port is in non-blocking mode\n" - "@item\n" - "return @code{#f} if end-of-file is encountered before reading\n" - "any characters, otherwise return the number of characters\n" - "read.\n" - "@item\n" - "return 0 if the port is in non-blocking mode and no characters\n" - "are immediately available.\n" - "@item\n" - "return 0 if the request is for 0 bytes, with no\n" - "end-of-file check\n" - "@end itemize") -#define FUNC_NAME s_scm_read_string_x_partial -{ - char *dest; - long read_len; - long chars_read = 0; - int fdes; - - { - long offset; - long last; - - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, dest, 3, start, offset, - 4, end, last); - dest += offset; - read_len = last - offset; - } - - if (SCM_INUMP (port_or_fdes)) - fdes = SCM_INUM (port_or_fdes); - else - { - SCM port = SCM_UNBNDP (port_or_fdes) ? scm_cur_inp : port_or_fdes; - - SCM_VALIDATE_OPFPORT (2, port); - SCM_VALIDATE_INPUT_PORT (2, port); - - /* if there's anything in the port buffers, use it, but then - don't touch the file descriptor. otherwise the - "return immediately if something is available" rule may - be violated. */ - chars_read = scm_take_from_input_buffers (port, dest, read_len); - fdes = SCM_FPORT_FDES (port); - } - - if (chars_read == 0 && read_len > 0) /* don't confuse read_len == 0 with - EOF. */ - { - SCM_SYSCALL (chars_read = read (fdes, dest, read_len)); - if (chars_read == -1) - { - if (SCM_EBLOCK (errno)) - chars_read = 0; - else - SCM_SYSERROR; - } - else if (chars_read == 0) - return SCM_BOOL_F; - } - return scm_long2num (chars_read); -} -#undef FUNC_NAME - SCM_DEFINE (scm_ftell, "ftell", 1, 0, 0, (SCM fd_port), "Return an integer representing the current position of\n" diff --git a/libguile/ioext.h b/libguile/ioext.h index 5853f4490..c6b4712ac 100644 --- a/libguile/ioext.h +++ b/libguile/ioext.h @@ -48,8 +48,6 @@ -extern SCM scm_read_string_x_partial (SCM str, SCM port_or_fdes, SCM start, - SCM end); extern SCM scm_ftell (SCM object); extern SCM scm_redirect_port (SCM into_pt, SCM from_pt); extern SCM scm_dup_to_fdes (SCM fd_or_port, SCM newfd); diff --git a/libguile/rw.c b/libguile/rw.c new file mode 100644 index 000000000..343c28210 --- /dev/null +++ b/libguile/rw.c @@ -0,0 +1,178 @@ +/* Copyright (C) 2001 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 + * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + + + +/* This is the C part of the (ice-9 rw) module. */ + +#include + +#include "libguile/_scm.h" +#include "libguile/fports.h" +#include "libguile/ports.h" +#include "libguile/root.h" +#include "libguile/rw.h" +#include "libguile/strings.h" +#include "libguile/validate.h" + +#ifdef HAVE_UNISTD_H +#include +#endif + + + +#if defined (EAGAIN) +#define SCM_MAYBE_EAGAIN || errno == EAGAIN +#else +#define SCM_MAYBE_EAGAIN +#endif + +#if defined (EWOULDBLOCK) +#define SCM_MAYBE_EWOULDBLOCK || errno == EWOULDBLOCK +#else +#define SCM_MAYBE_EWOULDBLOCK +#endif + +/* MAYBE there is EAGAIN way of defining this macro but now I EWOULDBLOCK. */ +#define SCM_EBLOCK(errno) \ + (0 SCM_MAYBE_EAGAIN SCM_MAYBE_EWOULDBLOCK) + +SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0, + (SCM str, SCM port_or_fdes, SCM start, SCM end), + "Read characters from an fport or file descriptor into a\n" + "string @var{str}. This procedure is scsh-compatible\n" + "and can efficiently read large strings. It will:\n\n" + "@itemize\n" + "@item\n" + "attempt to fill the entire string, unless the @var{start}\n" + "and/or @var{end} arguments are supplied. i.e., @var{start}\n" + "defaults to 0 and @var{end} defaults to\n" + "@code{(string-length str)}\n" + "@item\n" + "use the current input port if @var{port_or_fdes} is not\n" + "supplied.\n" + "@item\n" + "read any characters that are currently available,\n" + "without waiting for the rest (short reads are possible).\n\n" + "@item\n" + "wait for as long as it needs to for the first character to\n" + "become available, unless the port is in non-blocking mode\n" + "@item\n" + "return @code{#f} if end-of-file is encountered before reading\n" + "any characters, otherwise return the number of characters\n" + "read.\n" + "@item\n" + "return 0 if the port is in non-blocking mode and no characters\n" + "are immediately available.\n" + "@item\n" + "return 0 if the request is for 0 bytes, with no\n" + "end-of-file check\n" + "@end itemize") +#define FUNC_NAME s_scm_read_string_x_partial +{ + char *dest; + long read_len; + long chars_read = 0; + int fdes; + + { + long offset; + long last; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, dest, 3, start, offset, + 4, end, last); + dest += offset; + read_len = last - offset; + } + + if (SCM_INUMP (port_or_fdes)) + fdes = SCM_INUM (port_or_fdes); + else + { + SCM port = SCM_UNBNDP (port_or_fdes) ? scm_cur_inp : port_or_fdes; + + SCM_VALIDATE_OPFPORT (2, port); + SCM_VALIDATE_INPUT_PORT (2, port); + + /* if there's anything in the port buffers, use it, but then + don't touch the file descriptor. otherwise the + "return immediately if something is available" rule may + be violated. */ + chars_read = scm_take_from_input_buffers (port, dest, read_len); + fdes = SCM_FPORT_FDES (port); + } + + if (chars_read == 0 && read_len > 0) /* don't confuse read_len == 0 with + EOF. */ + { + SCM_SYSCALL (chars_read = read (fdes, dest, read_len)); + if (chars_read == -1) + { + if (SCM_EBLOCK (errno)) + chars_read = 0; + else + SCM_SYSERROR; + } + else if (chars_read == 0) + return SCM_BOOL_F; + } + return scm_long2num (chars_read); +} +#undef FUNC_NAME + +void +scm_init_rw () +{ + SCM rw_module = scm_make_module (scm_read_0str ("(ice-9 rw)")); + SCM old_module = scm_set_current_module (rw_module); + +#ifndef SCM_MAGIC_SNARFER +#include "libguile/rw.x" +#endif + + scm_set_current_module (old_module); +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/rw.h b/libguile/rw.h new file mode 100644 index 000000000..0e160cc79 --- /dev/null +++ b/libguile/rw.h @@ -0,0 +1,59 @@ +/* classes: h_files */ + +#ifndef SCM_RW +#define SCM_RW +/* Copyright (C) 2001 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 + * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + + +#include "libguile/__scm.h" + +extern SCM scm_read_string_x_partial (SCM str, SCM port_or_fdes, SCM start, + SCM end); +void scm_init_rw (void); + +#endif + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ From 54947d7c67467bdaf8fd9e1af97b0c131d6b7b4d Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 29 Apr 2001 13:04:55 +0000 Subject: [PATCH 0947/2047] 2001-04-29 Gary Houston MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * rw.scm: new file, for module (ice-9 rw). * Makefile.am: add rw.scm. 2001-04-28 Thien-Thi Nguyen * boot-9.scm, optargs.scm: Surround commentary w/ standard markers; nfc. * threads.scm, time.scm, channel.scm, expect.scm: Add commentary; nfc. 2001-04-27 Thien-Thi Nguyen * documentation.scm: Update copyright. Add commentary. Use `define-module' `:export' clause instead of `define-public'. Autoload (ice-9 regex) on `match:suffix'. (default-in-line-re, default-after-line-re): New vars. (default-scrub): New proc. (file-commentary): New proc, exported. (object-documentation): Expand docstring; nfc. * session.scm: Update copyright. Use (ice-9 rdelim). (help): Consider a list of symbols that does not start with `quote' as a module name and call `module-commentary' on it. (module-filename, module-commentary): New procs. (id): Delete. (apropos): Use `identity' instead of deprecated `id'. (help-usage): Add blurb about "(help (my module))" support. 2001-04-27 Martin Grabmueller * Makefile.am (ice9_sources): Remove srfi-8.scm. 2001-04-26 Rob Browning * srfi-8.scm: removed in favor of srfi/srfi-8.scm - (wasn't ever in a production release). 2001-04-25 Keisuke Nishida * channel.scm: New file. * Makefile.am (ice9_sources): Include channel.scm. 2001-04-19 Keisuke Nishida * receive.scm (receive): Use `define-macro'. 2001-04-15 Keisuke Nishida * boot-9.scm (load-compiled): New variable, initialized in the VM. (try-module-autoload): Try loading compiled modules if applicable. 2001-04-15 Keisuke Nishida * boot-9.scm (call-with-deprecation): New procedure. (identity): New procedure. (id): Deprecated. 2001-04-15 Keisuke Nishida * boot-9.scm (defmacro, define-macro, define-syntax-macro): Define only at the top level. 2001-04-06 Thien-Thi Nguyen * threads.scm: Update copyright. Use `export' and `export-syntax' instead of `define-public' and `defmacro-public'. (make-thread): Rename first arg to `proc'; nfc. (begin-thread, monitor): Rename second arg to `rest'; nfc. (with-mutex): Rename second arg to `body'; nfc. 2001-04-06 Neil Jerram * boot-9.scm (warn-autoload-deprecation): Close parenthesis in "You just tried to autoload ..." message. 2001-04-05 Keisuke Nishida * Makefile.am (ice9_sources): Add history.scm. * history.scm: Create the module (value-history) at the beginning. 2001-03-29 Marius Vollmer * boot-9.scm (init-dynamic-module): Fix typo in call to warn-autoload-deprecation. I feel silly. 2001-03-27 Marius Vollmer * r4rs.scm (call-with-values): New definition, defers to @call-with-values. 2001-03-26 Marius Vollmer * boot-9.scm (warn-autoload-deprecation): New function. (init-dynamic-module): Use it here to print warning. Only give warning when a module has actually been found. 2001-03-25 Marius Vollmer * boot-9.scm (init-dynamic-module): Issue warning about auto-loading of compiled code modules being deprecated. * Makefile.am (ice9_sources): Added "time.scm". 2001-03-20 Keisuke Nishida * time.scm (time): Reimplemented as a procedure call. (Thanks to Marius Vollmer) 2001-03-20 Keisuke Nishida * safe-r5rs.scm (list): Export. 2001-03-17 Keisuke Nishida * boot-9.scm (before-eval-hook, after-eval-hook, before-print-hook, after-print-hook): New hooks. (scm-style-repl): Call these hooks. * history.scm: New file. 2001-03-17 Keisuke Nishida * time.scm: New file. 2001-03-17 Dirk Herrmann * oldprint.scm: Removed. 2001-03-12 Mikael Djurfeldt * arrays.scm (make-array): Added quote in front of (). 2001-03-12 Keisuke Nishida * common-list.scm (count-if): New procedure. 2001-03-10 Neil Jerram * buffered-input.scm (make-buffered-input-port): New, more general buffered input procedure. Does not assume that a newline character should be interpolated between chunks of input returned by the reader proc. (make-line-buffered-input-port): Redefine in terms of make-buffered-input-port. 2001-03-09 Keisuke Nishida * match.scm: Don't export defstruct. Use (unquote defstruct) instead. 2001-03-09 Mikael Djurfeldt * Makefile.am (psyntax.pp): Added rule for producing psyntax.pp. 2001-03-09 Keisuke Nishida * match.scm: export defstruct. 2001-03-08 Mikael Djurfeldt * psyntax.ss: Added FSF copyright notice. Added a notice of changes in order to comply with paragraph 2a of the GPL. (Thanks to Keith Wright.) 2001-03-07 Neil Jerram * buffered-input.scm (make-line-buffered-input-port): Don't set the continuation flag for leading whitespace. Thanks to Dirk Herrmann for the suggestion. 2001-03-05 Neil Jerram * optargs.scm (rest-arg->keyword-binding-list): Use "'()" instead of "()". * buffered-input.scm: New file, with guts of line buffered input port implementation extracted from guile-readline/readline.scm. 2001-03-03 Mikael Djurfeldt * stack-catch.scm: New file. * Makefile.am (ice9_sources): Added stack-catch.scm. 2001-03-03 Marius Vollmer * boot-9.scm, rdelim.scm: Use "'()" instead of "()" in all places where the empty list is meant. 2001-02-26 Mikael Djurfeldt * boot-9.scm (save-stack): Use `primitive-eval' for stack cutting. Makes backtraces work again! Also added a reference to save-stack from the place in the repl where the primitive-eval frame is invoked. 2001-02-25 Keisuke Nishida * match.scm: New file, including Andrew K. Wright's pattern matcher. * Makefile.am (ice9_sources): Added match.scm. 2001-02-16 Marius Vollmer * boot-9.scm (eval-when, eval-case): Renamed `eval-when' to `eval-case', everywhere. 2001-02-13 Marius Vollmer * boot-9.scm (define-public): Removed spurious call to `interaction-evironment'. (define-public, defmacro-public): Use `export' instead of explicit module magic. (eval-when): New macro. (define-module, use-modules, use-syntax, export): Use it to restrict the use of these forms to the top level. (define-public, defmacro-public): Only export binding when on top-level. (process-define-module): Call `set-current-module' with the defined module. (define-module): Simply call `process-define-module' without any fuss (but only on top-level). (named-module-use!): New function. (top-repl): Do not use `define-module'. Use equivalent low-level means instead. 2001-02-11 Marius Vollmer * boot-9.scm (scm-style-repl): Use `primitive-eval' instead of `eval'. (define-public): Do not use `eval'. 2001-02-08 Marius Vollmer * and-let-star-compat.scm: Display the warning to the `current-error-port'. 2001-02-04 Marius Vollmer Avoid the use of "*" in file names for the benefit of lesser operating systems. * and-let-star.scm, and-let*.scm: Renamed `and-let*.scm' to `and-let-star.scm'. Updated module name as well. * and-let-star-compat.scm: New file, installed as `and-let*.scm'. * Makefile.am (ice9_sources): Replaced "and-let*.scm" with "and-let-star.scm". (install-data-local): Install "and-let-star-compat.scm" as "and-let*.scm", ignoring errors. (EXTRA_DIST): Distribute `and-let-star-compat.scm'. 2001-01-26 Dirk Herrmann This patch fixes a problem reported by Martin Grabmueller about the impossibility to access readline's run-time options. * boot-9.scm (define-option-interface): New macro. Allows to conveniently define a group of option interface functions. (readline-options readline-enable readline-disable, readline-set!): Moved to guile-readline/readline.scm. 2001-01-24 Gary Houston * boot-9.scm: don't import (ice-9 rdelim) here. it's done in C for now. * rdelim.scm: export the C primitives too. * documentation.scm: use (ice-9 rdelim). 2001-01-21 Gary Houston * rdelim.scm: new file implementing module (ice-9 rdelim). * ice-9.scm (scm-line-incrementors read-line! read-delimited! read-delimited read-line): moved to rdelim.scm. scm-line-incrementors is not exported. * boot-9.scm: import (ice-9 rdelim) for backwards compatibility, for now. * lineio.scm: use module (ice-9 rdelim). * Makefile.am (ice9_sources): add rdelim.scm. 2000-12-29 Dirk Herrmann * boot-9.scm (root-module-closure, scm-module-closure): Remove calls '(symbol-interned? #f s)'. Formerly, these calls were basically no-ops, guaranteed to return #t if 's' was a symbol. After the separation of symbols and bindings, a call to '(symbol-interned? #f s)' will only return #t if there really is a binding for 's' in the scm_symhash table. Thanks to Dale P. Smith for providing a test case that helped finding this bug. 2000-12-13 Dirk Herrmann * session.scm (apropos): Completed the last patch, which did only half the job. Thanks to Dale P. Smith. 2000-12-12 Dirk Herrmann * session.scm (apropos, apropos-fold): There are no weak bindings any more. 2000-12-12 Dirk Herrmann * boot-9.scm (top-repl): Lookup 'use-emacs-interface in the-root-module. 2000-12-07 Neil Jerram * emacs.scm (flush-whitespace): Fix spelling typo ("recieving"). 2000-11-28 Dirk Herrmann * boot-9.scm (read-delimited), lineio.scm (make-line-buffering-input-port), regex.scm (match:prefix, match:suffix, match:substring, regexp-substitute/global), slib.scm (slib-parent-dir), string-fun.scm (split-after-char, split-before-char, split-discarding-char, split-after-char-last, split-before-char-last, split-discarding-char-last, split-before-predicate, split-after-predicate, split-discarding-predicate, separate-fields-discarding-char, separate-fields-after-char, separate-fields-before-char, string-prefix-predicate, sans-surrounding-whitespace, sans-trailing-whitespace, sans-leading-whitespace, sans-final-newline): Use substring instead of make-shared-substring. 2000-11-26 Gary Houston * boot-9.scm: values?, get-values, values, call-with-values: removed. values and call-with-values are now primitives and the other two were only exported by accident. don't define *values-rtd* record type or handle multiple values in scm-style-repl. 2000-11-07 Gary Houston * popen.scm (open-output-pipe): added docstrings for open-input-pipe and open-output-pipe. 2000-11-06 Gary Houston * popen.scm (open-process): bug fix: don't use close-all-ports-except to close ports in the child process, since it causes port buffers to be flushed. they may be flushed again in the parent, causing duplicate output. use a more elaborate method for setting up the child descriptors (thanks to David Pirotte for the bug report). standard file descriptors 0, 1, 2 in the child process are now set up from current-input-port etc., where possible. 2000-10-10 Dirk Herrmann * syncase.scm (eval): string=? requires a string argument. Thanks to Dale P. Smith for the patch. 2000-10-15 Neil Jerram * optargs.scm: Fix typos in commentary for bound? and lambda*. 2000-10-10 Dirk Herrmann * session.scm (apropos, apropos-fold): regexp-exec does not accept symbol arguments any more. Thanks to Dale P. Smith for the patch. 2000-09-30 Gary Houston * posix.scm (setgrent): pass #t, not #f. thanks to Jacques A. Vidrine. 2000-09-29 Neil Jerram * documentation.scm (find-documentation-in-file): Modified according to changed format of guile-procedures.txt caused by my snarfing/makeinfo changes in libguile. * session.scm (help-doc): Improvements to (help) output: (i) a friendlier Emacs-style introduction line; (ii) where the help arg matches multiple documented entries, print an initial list of the entries for which documentation is found, before printing the actual documentation entries themselves. 2000-09-20 Mikael Djurfeldt * boot-9.scm: Removed comment. (Thanks to Brad Knotwell.) 2000-09-12 Dirk Herrmann * syncase.scm (putprop): Use the high-level property interface. 2000-09-12 Mikael Djurfeldt * psyntax.ss (build-lexical-var): Use gentemp instead of gensym; Convert first argument to a string. * calling.scm (excursion-function-syntax, getter-and-setter-syntax, delegating-getter-and-setter-syntax): Call gensym with string argument. (Thanks to Dale P. Smith.) * oldprint.scm (print-table-add!): Ditto. * boot-9.scm (gentemp): Moved to symbols.c. 2000-08-27 Marius Vollmer * boot-9.scm (make-object-property): New function. 2000-08-26 Mikael Djurfeldt * boot-9.scm (make-record-type): Use `string-append' instead of `symbol-append'. (symbol-append): Map `symbol->string' on args. (obarray-symbol-append, obarray-gensym): Simply removed. I don't think I'll announce this in NEWS even. One of the functions never even worked... /mdj. (find-and-link-dynamic-module, keyword->symbol): Use `symbol->string'. (try-module-autoload, process-define-module): Rewrote using R5RS semantics. 2000-08-24 Mikael Djurfeldt * psyntax.ss (set!): Added generalized set! support to core syntax form set!. 2000-08-19 Marius Vollmer * optargs.scm (#\&): Changed #:allow-other-keys-value to #:allow-other-keys. Thanks to Bill Schottstaedt! 2000-08-17 Marius Vollmer * optargs.scm (#\&): Emit warning about `#&' being deprecated. 2000-08-16 Marius Vollmer * optargs.scm: Replaced `#&' reader syntax with keywords. 2000-08-14 Mikael Djurfeldt * format.scm (format:obj->str): Made tail-recursive. (Thanks to Matthias Köppe.) 2000-08-13 Mikael Djurfeldt * psyntax.ss (top-level-eval-hook, local-eval-hook): Pass `(interaction-environment)' as second arg to `eval'. This is completely equivalent with the state before the change to eval of 2000-08-11, but we should extend psyntax.ss to be module aware. (Thanks to Ian Bicking.) * emacs.scm (emacs-symdoc): Parenthesis fix. 2000-08-11 Mikael Djurfeldt * r5rs.scm (interaction-environment): Removed definition. (Is now provided by libguile/modules.c.) * safe-r5rs.scm (null-environment): Bugfix: Should include syntactic bindings. * boot-9.scm (record-constructor, record-accessor, record-modifier, scm-style-repl): Add second arg to eval. (read-hash-extend #\.): Ditto. (This is actually a bugfix!) (eval-in-module): Redefined to be eval and deprecated. * syncase.scm (eval): Add second arg both in definition and use. * slib.scm (slib:eval): Use eval instead of eval-in-module. (defmacro:eval): Eval in (interaction-environment). * safe-r5rs.scm (eval): Removed definition. * emacs.scm (emacs-eval-request): (emacs-symdoc): (This procedure needs updating!) 2000-08-10 Mikael Djurfeldt * boot-9.scm: Added note about dependency in modules.h to definition of module-type. * Makefile.am (ice9_sources): Added receive.scm, srfi-8.scm. * receive.scm, srfi-8.scm: New files. * boot-9.scm (scm-style-repl): Print multiple values on successive lines. (process-define-module): Bugfix: Make sure that exports are done *after* all used interfaces has been added. 2000-07-24 Marius Vollmer * common-list.scm (uniq): Made tail-recursive. Thanks to thi! 2000-07-13 Dirk Herrmann * boot-9.scm (expt): In case of negative integer exponents return an exact result if the input paramters were exact. Thanks to Mikael for the suggestion. 2000-07-12 Dirk Herrmann * boot-9.scm (expt): Make sure that integer-expt is only called if the exponent is a non-negative integer. 2000-07-01 Mikael Djurfeldt * boot-9.scm (process-define-module): Bugfix: Only check the CDR for export args. 2000-06-27 Dirk Herrmann * popen.scm: gc-thunk is deprecated. Use after-gc-hook instead. 2000-06-16 Dirk Herrmann * common-list.scm (intersection, set-difference, remove-if, remove-if-not): Made tail-recursive. Thanks to William Webber for the hint. (delete-if!, delete-if-not!): Renamed parameter from `list' to `l' in order to avoid confusion. Note: These functions are not tail recursive yet. 2000-06-21 Mikael Djurfeldt * boot-9.scm: Turned `the-module', `*top-level-lookup-closure*', and `scm:eval-transformer' into fluids. * boot-9.scm (purify-module!, module-export!): New procedures. (export): Rewritten using `module-export!'. (process-define-module): New define-module options: pure, export. See NEWS. (scm-style-repl): Added optional module argument. * null.scm, r5rs.scm, safe-r5rs.scm, safe.scm: New modules. 2000-06-20 Mikael Djurfeldt * session.scm (make-fold-modules): Detect circular references in module graph. (Thanks to Matthias Köppe.) 2000-06-20 Mikael Djurfeldt * session.scm: Use module (ice-9 regex). (help): Regexp-quote a name given as a symbol. 2000-06-16 Dirk Herrmann * common-list.scm (list*): Removed, since this function is implemented as a primitive in libguile/list.c. 2000-06-12 Mikael Djurfeldt * session.scm (help): Warn user if 'regex isn't provided. * Makefile.am (ice9_sources): Removed getopt-gnu-style.scm. * getopt-gnu-style.scm: Removed deprecated module. 2000-06-11 Mikael Djurfeldt * boot-9.scm (make-autoload-interface): Set init value for uses to '() instead of #f. (make-modules-in): Name modules with their real (= full) names. (the-root-module, the-scm-module): Named `(guile)' instead of `the-root-module'. (the-scm-module): Set kind to 'interface. * Makefile.am (ice9_sources): Replaced doc.scm with documentation.scm. * session.scm (ice-9): Use module (ice-9 documentation). (name): Use the name property if everything else fails. (apropos-fold): New procedure. (apropos-internal): Re-implement in terms of `apropos-fold'. (help): Rewritten. * doc.scm: Removed module (ice-9 doc). * documentation.scm: New module (ice-9 documentation). 2000-06-08 Mikael Djurfeldt * doc.scm (documentation-files): Renamed from `doc-files'. (write-all): Removed. (find-documentation): Renamed from `documentation'. Return documentation string instead of printing it. Not exported. Tue Jun 6 09:21:28 2000 Greg J. Badros * session.scm: Update references to `proc-doc' to be `proc-documentation' * doc.scm: Cleaned up a great deal. Put variables at the top of the file, eliminated `object-documentation' that was broken (referencing Scwm), drop `help' as session.scm has a better supported version of that procedure. Rename `proc-doc' to `proc-documentation' -- `procedure-documentation' is a primitive getter function, so I use the shorter name for this more useful function. (Alternatively, we could rename the primitive getter...) 2000-06-05 Mikael Djurfeldt * boot-9.scm (error-catching-loop): Inform about debugger on error. 2000-06-04 Mikael Djurfeldt * boot-9.scm (scm-module-closure): New procedure: Was previously anonymous. Now needed in modules.c. (make-module): Use `standard-eval-closure' to create the eval closure. 2000-05-14 Gary Houston * boot-9.scm (load-user-init): rewritten. first work out the home directory and then try to open the file (previously it could try to open a file in more than one place). catch exceptions when trying to get a directory from the user database. don't check that ~/.guile is not a directory before trying to load it (a lack of ~/.guile is not a crime, but if the file is not valid for any reason then primitive-load will raise an error). 2000-05-11 Dirk Herrmann * boot-9.scm (abs): Don't set to magnitude. abs now does not accept complex numbers as parameter. 2000-05-09 Marius Vollmer * common-list.scm (delete-if-not!): Bug fix of bug fix: change label of named let to `delete-if-not'. Sorry. 2000-05-08 Marius Vollmer * common-list.scm (doc fixes): Talk about `true values' instead of `#t' when a function treats all non-#f valuers the same. (remove-if-not): Bug fix: call remove-if-not instead of remove-if when iterating. (delete-if-not!): Bug fix: call delete-if-not! instead of delete-if! when iterating. 2000-04-16 Mikael Djurfeldt * r4rs.scm (close-input-port, close-output-port): Removed. 2000-04-13 Mikael Djurfeldt * session.scm (help): New macro. Prints helpful information. 2000-04-10 Gary Houston * popen.scm (open-process): after forking, close all ports except the end of the pipe to the parent. otherwise move->fdes and the exec'd program and the exit handlers can interfere with file descriptors still in use in parent ports. 2000-04-09 Gary Houston * popen.scm (close-process-quietly): new procedure. use it from reap-pipes to avoid errors or hanging during background cleanup. 2000-04-04 Mikael Djurfeldt * format.scm (format:obj->str): Handle circular references. Also, print improper lists with (x y . z) syntax rather than as individual pairs. (This code should probably be integrated into C level facilities. It is currently terribly slow.) 2000-04-03 Michael Livshin * streams.scm (stream-fold, stream-for-each): don't use named let, because it prevents the gc from junking the stream argument. Thu Mar 9 08:05:08 2000 Greg J. Badros * slib.scm: Back-out change to software-type -- renamed slib:software-type to software-type, and leave it non-public. Thu Mar 2 12:20:52 2000 Greg J. Badros * boot-9.scm: Drop unused definition of sfx function -- thanks Dirk Hermann! Wed Mar 1 12:21:02 2000 Greg J. Badros * streams.scm: Doc patch from Richard Kim, using MIT Scheme as source of the numerous very short changes. Sun Feb 13 18:03:19 2000 Greg J. Badros * slib.scm: Rename software-type to slib:software-type and make it public. * r4rs.scm: Added documentation; largely cut and pasted from R4RS info pages. Sun Feb 13 17:49:29 2000 Greg J. Badros * common-list.scm: Added documentation; largely cut and pasted from slib docs. 2000-02-11 Mikael Djurfeldt * format.scm (format): Reintroduce (define format format:format) so that the binding in the public interface of the module will be OK. 2000-01-30 Gary Houston * boot-9.scm (find-and-link-dynamic-module): pass strings, not symbols, to string-append. 2000-01-29 Gary Houston * expect.scm (expect): don't call char-ready? before expect-select, since select now checks port buffers itself. don't bother to check the time first either, since expect-select does it. Thu Jan 20 12:57:36 2000 Greg J. Badros * format.scm: Use (variable-set! (builtin-variable 'format)) to re-define format to be format:format (instead of just define, which interacts poorly with the module system). Thanks to Shuji Narazaki for this change. Tue Jan 11 10:49:22 2000 Greg J. Badros * boot-9.scm expect.scm, syncase.scm: Switch to new style `simple-format' message strings: substitute ~A for %s, and ~S for %S. * boot-9.scm: Added (define format simple-format) to expose that primitive via the simpler name until format.scm is loaded. 2000-01-09 Marius Vollmer * boot-9.scm (try-using-libtool-name): Do not bother to look inside libtool ".la" file, dynamic-link does this for us now. 1999-12-15 Gary Houston * slib.scm (library-vicinity, home-vicinity, scheme-implementation-type, scheme-implemenation-version): use define-public to export from the module. Wed Dec 15 08:32:09 1999 Greg J. Badros * doc.scm: Use `%library-dir' and the other system directories, not the quickly defuncted `library-dir' that I added before realizing the former existed. Thanks Brad Knotwell! Sun Dec 12 19:18:52 1999 Greg J. Badros * Makefile.am, doc.scm: Added doc.scm. 1999-12-12 18:54:06 1999 Greg J. Badros * popen.scm, slib.scm: Added some docstrings for procedures that were primitives that I encountered in posix.texi. 1999-11-19 Gary Houston * Makefile.am (ice9_sources): add arrays.scm. * boot-9.scm: load arrays.scm if 'array is provided. * arrays.scm: new file with stuff from boot-9.scm. 1999-11-18 Gary Houston * boot-9.scm (read-hash-extend to set up arrays): add 'l' for long_long uniform vectors. 1999-11-17 Gary Houston * networking.scm (sethostent, setnetent, setprotoent, setservent): take an optional argument STAYOPEN. default is #f. 1999-10-05 Jim Blandy * Makefile.in: Deleted from CVS repository. Run the autogen.sh script to create generated files like this one. 1999-09-23 Gary Houston * boot-9.scm (load-user-init): check that the posix feature is available before using getpw and getuid. (top-repl): don't install handlers for SIGINT etc., without posix. (file-is-directory?): use 'posix instead of i/o-extensions to check for stat. (load-user-init): use file-exists? and file-is-directory? to check for .guile, instead of stat. (file-is-directory?): don't display the file name if posix not available. (feature?): I guess this is deprecated. redefined using "provided?" and changed users in boot-9.scm to "provided?". Conditionally load posix.scm and networking.scm. posix.scm, networking.scm: new files. Move definitions from boot-9.scm if they are only useful with posix/networking available. * Makefile.am (ice9_sources): add posix.scm, networking.scm. 1999-09-17 Mikael Djurfeldt * debugger.scm (read-and-dispatch-commands): Handle other throws than 'exit-debugger. * boot-9.scm (before-signal-stack): New fluid. (top-repl): Set before-signal-stack in the signal handler. * debugger.scm (eval-handler): Handle unhandled exceptions. 1999-09-16 Mikael Djurfeldt * debugger.scm ("p"): New alias for "evaluate"; Mark module with :no-backtrace. ("position"): New command. (source-position, display-position): New procedures. (display-source): Display position of expression, if available. (catch-user-errors): Return #f on error. (Commands are expected to return a valid state.) (read-and-dispatch-command): Bugfix: Return old state on error. 1999-09-16 Jim Blandy * regex.scm (regexp-substitute/global): Handle the end of the match list and an empty match list identically. (Thanks to Greg Badros.) 1999-09-15 Mikael Djurfeldt * debugger.scm ("evaluate"): Replaced `write-line' with calls to `write' and `newline' since write-line doesn't write but displays. 1999-09-12 Mikael Djurfeldt * debugger.scm ("evaluate"): Newline after no env announcement. * debug.scm, emacs.scm: Updated copyright notices. * boot-9.scm (make-autoload-interface): Bugfix. (top-repl): Autoload debugger. * debugger.scm ("backtrace"): Don't pass length param to display-backtrace if it wasn't explicitly given by the user. (write-frame-long/application): Also print corresponding source expression. ("evaluate"): Evaluate in local environment frame, if existent; Handle errors. 1999-09-11 Jim Blandy * format.scm (format:format-work): Use #\tab and #\page instead of slib:form-feed and slib:tab. (Thanks to Ceri Storey.) * format.scm (format:abort): Call error, not slib:error. 1999-09-11 Mikael Djurfeldt * boot-9.scm (using-readline?): New procedure: Returns #t if readline is used by the repl run by this thread. (handle-system-error): Print "Backtrace:" before backtrace since this is no longer done by display-backtrace. * debug.scm (frame-number->index): Optionally take stack as argument. * debugger.scm: Use the frame number abstraction which allows for both forward and backward views of the stack (write-frame-index-short, write-frame-index-long): Use selector `frame-number'; (select-frame-absolute): Use frame-number->index. ("backtrace"): Use builtin backtrace printing. Use (ice-9 debug). Use readline conditionally. 1999-09-11 Jim Blandy * regex.scm (fold-matches, list-matches): New functions. (regexp-substitute/global): Rewritten again in terms of list-matches, to get null match behavior correct. * regex.scm (regexp-substitute/global): Rewrite so that 'post at the end of the item list actually causes a tail call. (Thanks to Jan Nieuwenhuizen.) 1999-09-11 Marius Vollmer * readline.scm: Moved to ../guile-readline. * boot-9.scm (top-repl): Removed code for activating readline. * Makefile.am: Removed mention of readline.scm. * Makefile.in: Regenerated. 1999-09-11 Jim Blandy Delete the test which compares the configuration date of libguile with the configuration date of ice-9. This test yields too many false positives to be helpful. For example, if you build Guile for several architectures but have them all share a "share" directory (which is supposed to work), then all but one architecture's Guile will complain that the configuration dates don't match. Which is true, but indicates nothing wrong. * boot-9.scm: Delete code which compares ice-9-config-stamp with libguile-config-stamp. * version.scm.in: Delete. * Makefile.am (ice9_generated): Delete. (subpkgdata_DATA): Remove ice9_generated. (EXTRA_DIST): Remove version.scm.in. * Makefile.in: Regenerate. 1999-09-11 Mikael Djurfeldt * debugger.scm: New file: Initial version of the Guile debugger written by Chris Hanson. (The debugger isn't finished, but is included in Guile anyway since it is already quite useful.) * boot-9.scm (top-repl): Use (ice-9 debug) (ice-9 debugger) (ice-9 session) (ice-9 threads) (ice-9 regex) from guile-user only if top-repl is called. This makes startup time for scripts 30% of what it was before... Removed redundant code for loading of readline. * Makefile.am (ice9_sources): Added debugger.scm. 1999-08-29 Keisuke Nishida * boot-9.scm (try-module-autoload): Use %search-load-path. 1999-08-24 Mikael Djurfeldt * boot-9.scm: Removed old style hooks. (inherit-print-state): Rwwritten to use port-with-print-state. 1999-08-20 James Blandy Remove support for the #/ path list syntax entirely. * boot-9.scm (read-path-list-notation, read-path-list-notation-warning): Deleted. Don't register read-path-list-notation-warning as a reader for objects starting with '#/'. 1999-08-05 Mikael Djurfeldt GOOPS needs the observer protocol specified for the new module system. Here's a simple version for the old module system: * boot-9.scm (module-observers, module-weak-observers, module-observer-id, set-module-observers!, set-module-observer-id!): New accessors. (module-type): Added slots `observers', `weak-observers' and `observer-id'. (module-observe, module-observe-weak, module-unobserve, module-modified): New procedures. (module-make-local-var!, module-add!, module-remove!, module-clear!, module-define!, module-use!): Call module-modified. 1999-07-29 Marius Vollmer * boot-9.scm (error-catching-loop): Correct non-RnRS usage of internal defines. 1999-07-19 Jim Blandy * streams.scm: New module, contributed by Michael Livshin. * Makefile.am (ice9_sources): List it. * Makefile.in: Regenerated. * boot-9.scm (read-delimited!): Put the terminator in the correct position. 1999-06-29 Mikael Djurfeldt * readline.scm: Bugfix: Avoid getting the continued-lines prompt at multiple calls to read. (promtp2): Variable for continued-lines prompt. (make-readline-port): Use prompt2. (set-readline-prompt!): New optional arg which sets continued-lines prompt. * boot-9.scm (top-repl): Set/clear readline prompts before/after reading expressions. 1999-06-18 Jim Blandy * ls.scm (ls, lls): Handle no arguments as meaning to look in `(current-module)'. (Patch from Thien-Thi Nguyen.) 1999-06-14 Jim Blandy * string-fun.scm (split-before-predicate, split-after-predicate, split-discarding-predicate): Make these public. (Thanks to Thien-Thi Nguyen.) 1999-06-13 Gary Houston * more changes to expect.scm, to avoid the one-character lookhead that was introduced to fix the $ problem: * expect.scm (expect): call the match proc an extra time at end of file and set the eof? argument appropriately. call expect-eof-proc only if the last call didn't match. * expect.scm (expect-strings): change port to eof? in match proc. * expect.scm (expect-regexec): take an eof indicator as an argument instead of a port. 1999-06-09 Jim Blandy * Makefile.am (ice9_sources): Add popen.scm to list. * Makefile.in: Regenerated. Fixes for expect from Gary Houston : * expect.scm (expect-regexec): define 'eof-next?'. I don't know why it was missing. also don't peek for end of lines unless expect-strings-exec-flags contains regexp/noteol. (expect-strings-exec-flags): initialise to regexp/noteol. Gary Houston's open-buffer port patches: 1999-04-01 Gary Houston * popen.scm: applied fixes from Greg Harvey. use a guardian and a gc-thunk so that cleanup is done if a pipe is garbage collected or closed with close-port. use a weak hash-table instead of an alist. 1999-03-20 Gary Houston * expect.scm (expect): call the match proc with the port instead. (expect-strings): use peek-char to get the next char. this has the advantage of getting the handling of $ "correct", but the disadvantage of needing to get (and maybe block for) an extra character from the port when it may not be needed. hence: (expect-strings-exec-flags): new variable/parameter, supplies flags for regexp-exec. if this includes regexp/noteol, then automatic regexp/noteol handling (requiring an extra peeked char) is enabled. default is regexp/noteol. (expect-strings-compile-flags): new variable/parameter, supplies flags for make-regexp. default is regexp/newline. 1999-03-15 Gary Houston * expect.scm (expect): call the match proc with an extra char, peeked from the stream. (expect-strings): build a match proc which takes the extra char. (expect-regexec): take an extra arg "eof-next?" and use it to decide whether the regexp/noteol flag should be added. 1999-02-26 Gary Houston * boot-9.scm (top-repl): don't flush all ports at exit. (error-catching-loop): likewise. 1998-12-23 Gary Houston * boot-9.scm (scm-style-repl): -read: don't call consume-trailing-whitespace if val is eof object. Allows exiting repl with single control-D. 1998-12-06 Gary Houston * boot-9.scm (error-catching-loop): don't force output within error catching loop after quit received. (top-repl): flush all ports when the repl terminates. * boot-9.scm (error-catching-loop): flush all ports before primitive exit if non-interactive. force-output on current-error-port if interactive. * boot-9.scm (reopen-file): deleted. * popen.scm (open-output-pipe, open-input-pipe): moved from boot-9.scm. * popen.scm: new file. 1999-06-04 Dirk Herrmann * boot-9.scm (iota): replaced by a tail recursive version. (reverse-iota): removed. 1999-06-03 Mikael Djurfeldt * optargs.scm (lambda*): Bugfix: Replaced ARGLIST --> non-optional-args. (Thanks to David Lutterkort.) 1999-05-09 Jim Blandy * string-case.scm: Removed; functions moved to libguile/strop.c (which could be dynamically linked in the future anyway). * Makefile.am (ice9_sources): Don't list string-case.scm. * Makefile.in: Regenerated. * format.scm: Don't bother importing (ice-9 string-case). 1999-05-02 Jim Blandy * boot-9.scm (provided?): New function. * Makefile.am: Add string-case.scm and format.scm to ice9_sources. * Makefile.in: Regenerated. * string-case.scm: New file, brought in from SLIB, and adapted to Guile's module system. * format.scm: New file, brought in from SLIB, with the following changes: (format:format): If the first argument is the format string, stick a #f on the front of it, so it is now a valid CL format argument list. This is easier than changing everyplace else (like the error formatter) that expects it to be in CL form. The other clause which explicitly tests for this case is now dead code. (format:format-work): Allow `@' and `:' in either order, as per modern CL behavior. (format:num->cardinal): Don't assume that an elseless if returns '() when the condition is false. 1999-04-17 Jim Blandy * Makefile.in: Regenerated. 1999-04-08 Mikael Djurfeldt * boot-9.scm: Provide 'values. 1999-03-21 Mikael Djurfeldt * boot-9.scm (process-define-module, use-syntax): Bugfix: :use-syntax should add syntax to using module, not current module. (internal-use-syntax): Removed. 1999-03-21 Mikael Djurfeldt * session.scm (apropos-internal): Modified to comply with new argument order for hash-fold. 1999-03-19 Mikael Djurfeldt * boot-9.scm (try-load-module): New procedure. Broken out from resolve-module. (resolve-module): Bugfix: Make it possible for a module at a deeper level (x y z) to depend on a module on a higher (x y). This also has the desired side-effect that multiple attempts to load a module (e.g. with `use-modules') work until source is actually found for the module (e.g. because the correct catalog has been added to the load path). Use try-load-module. 1999-03-18 Mikael Djurfeldt * session.scm (system-module): New procedure. Used to switch a module between system and user state. 1999-03-16 Mikael Djurfeldt * session.scm (apropos-internal): Rewritten using hash-fold. * emacs.scm, session.scm, slib.scm): Added :no-backtrace in module definition. 1999-03-14 Mikael Djurfeldt * boot-9.scm (make-record-type): Use `set-struct-vtable-name!' to associate a name to the record type descriptor so that the object system can create a wrapper class for it. 1999-03-12 Mikael Djurfeldt Improvement of backtraces: Introduces a new stack narrowing specifier, #t, for the inner cut. If the inner cut is specified by #t, `make-stack' will throw away inner stack frames (most recent calls on call chain) up to but excluding the first user stack frame encountered. This specifier is now used in `save-stack' so that the call `(save-stack)' will get the new behaviour. [It is recommended that any error reporting functions written by the user have this call on the outermost expression level (i.e. as a member of the lambda list).] Modules are partitioned into "user" and "system" modules. [I know that some names used here are silly, but I don't have more time to spend on a better solution, especially considering that the module system will be replaced. But if people have better ideas, then please tell me!] System modules are created by adding :no-backtrace among the define-module switches: (define-module (foo) :no-backtrace) Modules which doesn't have the :no-backtrace specifier are user modules. A stack frame is classified as a user frame if it has source code associated with it and if this source code can be proven to come from a user module. If it can be proven to come from a system module it is a system frame. Frames which can't be classified, e.g. application frames, are cut away if they occur between system frames, but are left on the stack if they occur between the last system frame and the first user frame encountered. (Note that the first user frame encountered is the last user code being evaluated!) In some cases the system part of the call chain is introduced by frames which should but can't be proven to be system frames. The following workaround has been implemented: The cutting proceeds over application frames where the operator is marked by the `system-procedure' property. (This has been used to cut away generic function dispatch code in the object system.) * boot-9.scm (set-system-module!): New procedure: Set system/user status of a module.; Mark `the-root-module' and `the-scm-module' as system modules. (process-define-module): Add new keyword :no-backtrace. * boot-9.scm (environment-module): Bugfixed. (set-module-eval-closure!): Add a pointer back from the eval closure to the module. * emacs.scm (emacs-load): Reset port filename after transfer. 1999-03-03 Mikael Djurfeldt * slib.scm (make-random-state): Added for compatibility. 1999-02-16 Maciej Stachowiak * optargs.scm (lambda*): Handle empty argument lists properly. 1999-02-15 Jim Blandy Fix from Russ McManus: * getopt-long.scm (parse-option-spec): Store 'optional as the value-required? field for options that take optional values. (process-short-option): Grab a value for the option when it takes either an optional or required value. 1999-02-12 Jim Blandy * getopt-long.scm: Remove debugging calls to `pk'. * getopt-long.scm: Return list of ordinary arguments as the value of the '() key, not `rest'. A new argument-processing package from Russ McManus. * getopt-long.scm: New file. * Makefile.am (ice9_sources): Added getopt-long.scm. * Makefile.in: Regenerated. 1999-02-09 Maciej Stachowiak * optargs.scm: New file. * Makefile.am (ice9_sources): Add optargs.scm here. Makefile.in not regenerated because I don't have the right version of Automake. 1999-02-06 Jim Blandy * and-let*.scm: New file, from Michael Livshin. * Makefile.am (ice9_sources): Add and-let* here. * Makefile.in: Regenerated. 1999-01-11 Mikael Djurfeldt * slib.scm (install-require-module): Fixed the kludge which loads the slib catalog: Doesn't anylonger assume that the feature tested for isn't loaded. 1998-12-14 Jim Blandy * Makefile.in: Regenerated. 1998-12-14 Mikael Djurfeldt * boot-9.scm (process-define-module): Reverted the change of 1998-11-23 which caused loading of object code if :use-module was applied to the module itself. 1998-12-11 Mikael Djurfeldt * Makefile.am: Removed setf.scm. * setf.scm: Removed. 1. It was buggy. 2. It was unschemey. (These shortcomings were my fault.) 1998-12-10 Mikael Djurfeldt * boot-9.scm (environment-module): New procedure. 1998-12-07 Mikael Djurfeldt * Makefile.am: Added setf.scm. 1998-12-05 Christian Lynbech * setf.scm: New file. Adds the new forms `setf!' and `setter' which implements generalized references a la Common LISP. 1998-12-02 Mikael Djurfeldt * boot-9.scm (process-define-module): Added new specifier :autoload MODULENAME BINDINGS to the define-module form. The autoload specifier tells the module system to load the module MODULENAME at the first occasion that any variable with its name among BINDINGS is referenced. (make-autoload-interface): New procedure: Constructs a stand-in for the public interface for the module to be autoloaded. 1998-12-01 Mikael Djurfeldt * boot-9.scm (*suppress-old-style-hook-warning*): Set this to #t if you don't want the old style hook warnings. 1998-12-01 Christian Lynbech * boot-9.scm (try-using-libtool-name): Fix check on dlname to make sure that it isn't empty, as it is when we are only buidling static libraries. 1998-11-27 Mikael Djurfeldt * session.scm (arity): New procedure. 1998-11-26 Mikael Djurfeldt * boot-9.scm: Use run-hook instead of run-hooks everywhere. 1998-11-26 Mikael Djurfeldt * boot-9.scm (run-hooks, add-hook!, remove-hook!): Added temporary code for backward compatibility until people have had time to adapt to the new hooks. 1998-11-23 Mikael Djurfeldt * boot-9.scm (beautify-user-module!): Beautify also if public interface is set to the module itself. In this way we can use beautify-user-module! to beautify a module prepared for object code. (process-define-module): Special case: Try to load object code as well if a module does :use-module on itself. * boot-9.scm: Bugfix: Since boot-9.scm is now loaded from invoke_main_func, we can no longer be sure that all modules have been registered when boot-9.scm is loaded. (register-modules): New function: Register and tag modules registered by scm_register_module_xxx since last call to this function. Modules are tagged with the dynamic object passed as argument. (Already linked modules should be tagged with #f.) (init-dynamic-module, link-dynamic-module): Call register-modules first to register linked modules. * boot-9.scm (init-dynamic-module): Remove module from registered-modules as soon as possible in case we are recursively invoked; Set public interface before doing the dynamic-call. * boot-9.scm (map-in-order): Removed (replaced by scm_serial_map). (abort-hook, before-error-hook, after-error-hook, before-backtrace-hook, after-backtrace-hook, before-read-hook, after-read-hook, exit-hook): Make hooks with `make-hook'. * boot-9.scm: Make hooks first class citizens and make them easier to use from C: (make-hook, add-hook!, remove-hook!, run-hooks): Moved to libguile/feature.c. * boot-9.scm: Added warnings about bindings used in libguile/modules.c: the-module, set-current-module, make-modules-in, beautify-user-module!, module-eval-closure. 1998-11-21 Mikael Djurfeldt * boot-9.scm (the-environment): New special form: Returns an object representing the current local evaluation environment. This object can be used in `local-eval' and `defined?'. 1998-11-13 Mikael Djurfeldt * boot-9.scm (collect): New syntax. Similar to begin but returns a list of the results of all forms in the sequence instead of the result of the last form. 1998-11-10 Mikael Djurfeldt * boot-9.scm (values, call-with-values): Moved here from syncase.scm. * syncase.scm (values, call-with-values): Moved to boot-9.scm. * boot-9.scm (readline-options, readline-enable, readline.disable, readline-set!: New options interface. * readline.scm (readline-port): Use readline-options-interface. 1998-11-05 Mikael Djurfeldt * boot-9.scm: Set the repl start module in `top-repl' instead of at the end of boot-9.scm. 1998-11-01 Mikael Djurfeldt * emacs.scm (format): Bugfix: Handle multiple arguments correctly. (Thanks to Thien-Thi Nguyen.) 1998-11-01 Mikael Djurfeldt * boot-9.scm (exit-hook): New hook: Is run at the very end of an interactive session. (top-repl): Run exit-hook on exit. * readline.scm (readline-port): Maybe read history; Maybe write history at exit (add to exit-hook). Fri Oct 30 15:15:37 1998 Mikael Djurfeldt * readline.scm (make-readline-port): Bugfixed last change... 1998-10-28 Mikael Djurfeldt * readline.scm (make-readline-port): Don't set prompt to "... " if read line was empty. 1998-10-19 Jim Blandy * boot-9.scm, debug.scm, expect.scm, hcons.scm, lineio.scm, r4rs.scm, slib.scm, threads.scm: Update copyright years. * getopt-gnu-style.scm, slib.scm: Add copyright notice. Talked to Stallman. Actually, the syntax-case copyright is no problem. Duh. * Makefile.am (ice9_sources): Revert last change. * syncase.scm, psyntax.pp, psyntax.ss: Added again. * Makefile.in: Regeneretade. * boot-9.scm: Don't assume that this file is loaded just before entering a read-eval-print loop. Turn code to load (ice-9 emacs) into... (load-emacs-interface): New function. (top-repl): Call it, if use-emacs-interface is defined and true. At this point, we *do* know we're about to enter a REPL. We can't include Kent Dybvig's syntax-case macro expander in the core Guile distribution, because we don't have copyright assignments for this code. We can certainly distribute them as a separate package, but Guile should be FSF code. * syncase.scm, psyntax.pp, psyntax.ss: Removed. * Makefile.am (ice9_sources): Removed syncase.scm, psyntax.pp, and psyntax.ss. * Makefile.in: Regenerated. * Makefile.am (ice9_sources): Add getopt-gnu-style.scm. * Makefile.in: Regenerated. 1998-10-18 Mikael Djurfeldt * boot-9.scm: Added extended read syntax for byte vectors #y(...) and short vectors #h(...). 1998-10-14 Jim Blandy * calling.scm (excursion-function-syntax): Use a sequence of set!'s, not a single multi-variable set!; we removed support for that syntax a long time ago. (Thanks to Shuji Narazaki.) 1998-10-12 Jim Blandy * r4rs.scm (OPEN_READ, OPEN_WRITE, OPEN_BOTH): Don't bother testing software-type here. That's the least of our Windows porting issues, and it's done wrong anyway. 1998-10-09 Jim Blandy * boot-9.scm (read-path-list-notation-warning): New function: print a warning the first time we see `#/' notation. * q.scm (sync-q!, q?, q-remove!, q-push!, enq!): Lots of bugs, and (eq? #f '()) assumptions. Make functions that aren't documented to return anything else return the queue itself. (Bug report from Michael Livshin --- thanks!) 1998-08-21 Mikael Djurfeldt * debug.scm (trace-entry, trace-exit): Removed re-enabling of trace flag. * boot-9.scm (make-options): Bugfix: Changed pair? --> list? in order to allow the empty list as arg. (error-catching-loop): Use `with-traps' to create a dynamic context with traps enabled. 1998-08-19 Mikael Djurfeldt * boot-9.scm: Removed (ice-9 regex) from use-list of (guile) module. (try-using-libtool-name): Removed dependency on (ice-9 regex). 1998-08-15 Mikael Djurfeldt * boot-9.scm: Make the root module use (ice-9 regex) if available. The dynamic linking facilities in boot-9.scm are currently dependent upon regular expressions. My change of 1998-07-14 removed (ice-9 regex) from the use-list of the root module and thereby destroyed dynamic linking. 1998-07-29 Jim Blandy * Makefile.in: Regenerated using the last public version of automake, not the hacked Cygnus version. 1998-07-28 Jim Blandy * Makefile.in: Regenerated, after removing Totoro kludge. 1998-07-28 Jim Blandy * getopt-gnu-style.scm: New file. (Thanks to Russ McManus.) 1998-07-26 Jim Blandy * Makefile.in Rebuilt, for config changes in parent dir. 1998-07-21 Mikael Djurfeldt * readline.scm (make-readline-port): Set prompt string to "... " after first read line. (Thanks to Richard Polton.) 1998-07-19 Jim Blandy * lineio.scm (make-line-buffering-input-port): Don't use ungetc-char-ready?, since we don't provide that function any more. The unread-string function doesn't interact properly with any of the standard I/O functions anyway. (Thanks to Andrew Archibald.) * hcons.scm (hashq-cons-assoc): Don't assume the empty list is false. Return false when we cannot find a matching entry in the list. (Thanks to Andrew Archibald.) 1998-07-16 Mikael Djurfeldt * boot-9.scm (export, export-syntax): New special forms: Export bindings from a module. `(export name1 name2 ...)' can be used at the top of a module (after `define-module') to specify which names should be exported. It can be used as an alternative to `define-public'. `export-syntax' works equivalently to `export' but is intended for export of syntactic keywords. (Thanks to Thien-Thi Nguyen.) 1998-07-15 Mikael Djurfeldt * boot-9.scm: Renamed module `(guile-repl)' --> `(guile-user)'. 1998-07-14 Mikael Djurfeldt * boot-9.scm: Let the user start in module `(guile-repl)' instead of module `(guile)'. Also make sure that `(guile-repl)' uses suitable modules. This change improves Guile stability substantially since bindings will only be copied from the root module: If the user redefines builtins in `(guile-repl)' it won't affect the internal operation of Guile itself. 1998-06-19 Mikael Djurfeldt * boot-9.scm (load-module): When loading files from within files themselves being loaded: Use the directory path of the file being loaded as root for relative filenames. (After suggestion by Steven G. Johnson.) 1998-06-15 Mikael Djurfeldt * emacs.scm (emacs-load): New feature: Eval in specified module. 1998-06-14 Mikael Djurfeldt * readline.scm: Typo in regex module name. 1998-06-13 Mikael Djurfeldt * readline.scm (apropos-completion-function): regexp-quote text to be completed. 1998-06-11 Mikael Djurfeldt * debug.scm, emacs.scm: Bugfix: Treat `the-last-stack' as a fluid. 1998-06-09 Mikael Djurfeldt * boot-9.scm: Check that (current-input-port) is a tty before enabling readline. (Thanks to Michael N. Livshin.) 1998-06-07 Mikael Djurfeldt * boot-9.scm (use-syntax): Turned into a macro inorder to be similar in use to `use-modules'. Example: (use-syntax (ice-9 syncase)) will 1. load the module (ice-9 syncase), and, 2. install the procedure `syncase' as eval transformer. (internal-use-syntax): New procedure. (process-define-module): Use `internal-use-syntax'. 1998-05-19 Mikael Djurfeldt * Makefile.am (ice9_sources): Add emacs.scm. 1998-05-13 Mikael Djurfeldt * readline.scm: Use the new readline facilities: Add the possibility to control input and output ports; Add apropos completion. * boot-9.scm: Antirevert Jim's readline code which he reverted 19971027 and adapt it to the current readline interface. * boot-9.scm (top-repl): Only enable readline if not using the Emacs interface; Only use repl prompt when using the readline port from repl-read. (We don't want to see it when calling `read'.) * boot-9.scm (remove-hook!): Parenthesis bug. 1998-05-11 Mikael Djurfeldt * boot-9.scm: Load readline module if readline is present. * readline.scm (apropos-completion-function): New procedure: Symbolic completion. (Thanks to Andrew Archibald!) 1998-04-22 Mikael Djurfeldt * boot-9.scm (process-define-module): Added keyword use-syntax. 1998-04-19 Mikael Djurfeldt * nonblocking.scm: Removed. libguile is now inherently nonblocking through the use of scm_internal_select. * emacs.scm: Removed use of nonblocking.scm. * gwish.scm, gtcl.scm: Removed. tcltk.scm has made these obsolete. 1998-04-15 Mikael Djurfeldt * runq.scm (runq-control): Corrected spelling of enqueue!. (Thanks to Karl M. Hegbloom.) 1998-03-30 Mikael Djurfeldt * boot-9.scm: Added new run-time option interface eval-options. 1998-03-28 Mikael Djurfeldt * boot-9.scm (remove-hook!): New macro. (Thanks to Maciej Stachowiak.) 1998-01-30 Mikael Djurfeldt * threads.scm: Added simple error and signal handler. (make-thread, begin-handler): Use this handler. The most important effect of this is that signals get unmasked. Previously, when a signal was thrown signals remained masked (signals get masked when a signal is taken) which influenced other threads. 1998-01-01 Tim Pierce A better fix to the SLIB identity problem -- thanks to Marius Vollmer. * slib.scm (identity): Unmake public. (slib:eval): Evaluate inside `slib-module'. 1997-12-24 Tim Pierce * boot-9.scm: Doc fix. * slib.scm (identity): Made public. (home-vicinity): New function (from SLIB/Template.scm). 1997-12-13 Tim Pierce * boot-9.scm (read-line): Rewritten to call %read-line for improved speed. Minor user-visible changes: the new functions are hardwired to treat the LFD character as signifying end-of-line, so changing `scm-line-incrementors' will no longer affect the behavior of read-line. On platforms which do not represent end-of-line with a LFD character, read-line should behave more like native line-processing facilities, but there is still a ways to go here. Sat Nov 29 01:24:46 1997 Mikael Djurfeldt * boot-9.scm (error-catching-loop, save-stack): `the-last-stack' is now a fluid. 1997-11-28 Tim Pierce * boot-9.scm (find-and-link-dynamic-module): If a module directory contains a .la file (a libtool support file), attempt to extract the shared library name from that file. If the .la file does not exist, try to link against a .so file. Libtool-generated compiled modules should load more cleanly in Guile now. (try-using-libtool-name, try-using-sharlib-name): New functions. Sun Nov 9 06:10:59 1997 Gary Houston * boot-9.scm (set-batch-mode?!, batch-mode?): initialize more usefully so they will work from a script. 1997-10-31 Marius Vollmer * boot-9.scm (inherit-print-state): Moved definition to the neighborhood of the record code. Mon Oct 27 02:05:49 1997 Jim Blandy * boot-9.scm: Revert changes to this file from Oct 23. It turns out to interact badly with the Emacs support and the Tcl/Tk support. It's not a high enough priority at the moment to be worth fixing. I'm leaving the other readline support in, though. Sat Oct 25 14:23:22 1997 Jim Blandy * Makefile.am: Include readline.scm in the list of files to be installed, so Guile can find it for interactive use. * Makefile.in: Regenerated. Thu Oct 23 01:00:33 1997 Jim Blandy Add support for readline function. * readline.scm: New module. * boot-9.scm (repl-reader): New function. (scm-style-repl): Call repl-reader, instead of doing the reading ourselves. Remove repl-report-reset; it was never used for anything. (top-repl): If we've got the readline primitives, then redefine repl-reader to use them. If we've got the readline primitives, import the readline module. * ls.scm (ls, lls): Don't assume (eq? #f '()). Wed Oct 22 18:26:57 1997 Jim Blandy * calling.scm, common-list.scm, ls.scm, q.scm, runq.scm, string-fun.scm: Added copyright notices; reformatted. Thu Oct 9 05:44:00 1997 Gary Houston * expect.scm: (expect-regexec): new procedure, use it in expect-strings to fix the => syntax under the new regex system. (top): include regex module in define-module statement. Wed Oct 8 03:16:01 1997 Gary Houston * (error-catching-loop): new local variable "interactive". if #f, abort terminates the process. (set-batch-mode?!, batch-mode?): new closures, defined in error-catching-loop. the names are from scsh. 1997-10-06 Marius Vollmer * boot-9.scm (inherit-print-state): If NEW-PORT contains a print-state, throw it away. Fri Oct 3 12:00:00 Mikael Djurfeldt * boot-9.scm (struct-layout): Use `vtable-index-layout' instead of `0'. Thu Oct 2 12:00:00 Mikael Djurfeldt * boot-9.scm (struct-printer, make-struct-printer, set-struct-printer-in-vtable!, *struct-printer*): Removed. (record-type-vtable, make-record-type): Don't use make-struct-printer. (record-type-vtable): User fields "prpr" (printer is no longer a user field). (record-type-name, record-type-fields): Decreased slot index by one; Use `vtable-offset-user'. Thu Oct 2 12:00:00 Marius Vollmer * boot-9.scm (inherit-print-state): New experimental function. Tue Sep 30 13:12:48 1997 Jim Blandy Suggestion and script from Maciej Stachowiak: * boot-9.scm: Split off modules into separate, autoloadable files. This reduces startup time from 10.5s to 5.5s (user cpu). * calling.scm, common-list.scm, ls.scm, q.scm, runq.scm, string-fun.scm: New files, containing stuff that used to be in boot-9.scm. * Makefile.am (ice9_sources): List new files here, for distribution and installation. * Makefile.in: Regenerated. Mon Sep 29 23:53:55 1997 Jim Blandy * Makefile.in: Regenerated with automake 1.2c. Mon Sep 29 03:21:24 1997 Mikael Djurfeldt * slib.scm (slib:load): slib:load first tries to load the file named NAME, then NAME.scm. On error, report the error occuring at the first attempt (NAME) rather than the second (NAME.scm). * boot-9.scm: Bugfix: Hard-solder the print-option procedure into the make-options macro so that we needn't refer to a global symbol. Sun Sep 28 21:40:24 1997 Mikael Djurfeldt * debug.scm: Moved options interface procedures to boot-9.scm. * boot-9.scm: Define options interface procedures here instead. Sat Sep 27 20:19:20 1997 Jim Blandy * boot-9.scm (separate-fields-discarding-char, separate-fields-after-char, separate-fields-before-char): Call continuation function, RET, as advertised: with each separated field a separate argument. * Makefile.in: Regenerated with automake 1.2a. Sat Sep 20 14:23:53 1997 Mikael Djurfeldt * slib.scm (slib:load): Export. * boot-9.scm (in-vicinity): Bugfix: Don't add "/" to an empty vicinity; Provide defmacro. Thu Sep 18 01:24:31 1997 Mikael Djurfeldt * r4rs.scm (apply): Set name property to 'apply. Tue Sep 16 22:09:50 1997 Mikael Djurfeldt * boot-9.scm (keyword->symbol, display-usage-report): Changed length --> string-length. (Thanks to Aleksandar Bakic.) (separate-fields-discarding-char, separate-fields-after-char, separate-fields-before-char): Bugfix from Maciej Stachowiak . Thanks! (try-module-linked): Try to find module among those already registered. (try-module-dynamic-link): Removed the first test which corresponds to a call to `try-module-linked'. (resolve-module): Resolve modules in this order: 1. Already registered modules (for example those which have been statically linked), 2. Try to autoload an .scm-file, 3. Try to dynamically link a .so-file. Mon Sep 15 23:39:54 1997 Mikael Djurfeldt * boot-9.scm (iota): Renamed list-reverse! --> reverse! Thu Sep 11 02:31:38 1997 Mikael Djurfeldt * session.scm (name): New procedure: Gives name of object. (source): New procedure: Gives source of object. Wed Sep 10 20:12:45 1997 Mikael Djurfeldt * boot-9.scm (primitive-macro?): New procedure. * slib.scm: Added hack which transfers syntactic information from the builtin variable `define' to the slib version if module (ice-9 syncase) has been loaded. This is necessary to get correct expansion inside the slib module. * psyntax.ss (build-let, build-named-let): New output constructors. (build-lexical-var): Seed gensym with symbolic name. (self-evaluating?): Add keywords among self-evaluating types. (let): New core form. (if): Removed from core language. (or, and, let, cond): Removed syntactic definitions. (sc-expand3): New procedure: Expander which takes optional mode and eval-syntactic-expanders-when arguments. * syncase.scm (psyncomp): New procedure: Recompiles psyntax.pp. Should be used inside the (ice-9 syncase) module with (use-syntax syncase) and with the current directory containing the psyntax.ss source. Added hack to transfer syntactic information from the builtin variable `define' to the slib version if module (ice-9 slib) has been loaded. Fri Sep 5 05:47:36 1997 Mikael Djurfeldt * syncase.scm (sc-interface, sc-expand): Removed hook setup. (syncase): Publish syntax transformer to be used with `use-syntax'. (sc-macro): Use this as the value when publishing macros. * boot-9.scm (module-type): Added `transformer'. (make-module): Modified initialization. (module-transformer, set-module-transformer!): Selector and mutator for module-associated transformer. (set-current-module): Use module-transformer to set `scm:eval-transformer'. (module-use!): Previous change reverted. (use-syntax): New function: Install a transformer in current module. (sc-interface, sc-expand): Removed! :) Fri Sep 5 03:09:09 1997 Mikael Djurfeldt * emacs.scm (emacs-load): Added new parameter `module'. * syncase.scm (putprop, getprop): Modified to use the object properties of the variable object corresponding to the symbol; This way we can ride on the mechanisms of the module system. Changed `builtin-variable' calls to `define-public' calls. Setup the hooks sc-expand and sc-interface. * boot-9.scm (sc-interface, sc-expand): New builtin variables. (set-current-module): Switch to and from sc-expand as scm:eval-transformer when going into and out of modules using syncase macros. (module-use!): Set scm:eval-transformer to sc-expand when adding the syncase interface. Thu Sep 4 14:57:04 1997 Mikael Djurfeldt * syncase.scm (putprop): Temporary fix which publishes new syntax globally (the old behaviour was complex and connected to the inner workings of the current module system). Wed Sep 3 21:29:13 1997 Mikael Djurfeldt * psyntax.ss: Updated. psyntax.pp: Bugfix: Previous version had some leading "t":s cut off! Tue Sep 2 00:26:42 1997 Mikael Djurfeldt * boot-9.scm (gensym): Removed (replaced by primitive). (obarray-gensym): Rewritten to use `gensym'. (gentemp): Rewritten to use `gensym'. Mon Sep 1 20:08:32 1997 Mikael Djurfeldt * gtcl.scm (make-tcl-binder): Rewritten to choose bindings according to the following priorities: 1. tcl bindings which are present in override-scheme-list 2. bindings from the-scm-module 3. tcl bindings This way the gtcl module can occur first in the use-list without disabling the scheme interpreter. (new-interpreter): New function. * gwish.scm: Moved initialization code for the-interpreter to gtcl.scm; Moved name space cleaning code to gtcl.scm and rewrote it; Call `new-interpreter'; Don't :use-module (guile). Thu Aug 28 23:48:53 1997 Jim Blandy * Makefile.in: Regenerated. Wed Aug 27 11:35:09 1997 Jim Blandy * Makefile.in: Regenerated, so it uses "tar", not "gtar". Mon Aug 25 22:00:44 1997 Mikael Djurfeldt * emacs.scm (object->string, format, error-args->string): New procedures. (emacs-frame-eval): Reworked. Mon Aug 25 16:15:55 1997 Mikael Djurfeldt * session.scm (apropos-internal): Musn't initialize symbol accumulator with a constant pair. That led to mutation of the source! Sun Aug 24 01:03:10 1997 Mikael Djurfeldt * session.scm (vector-for-each): Removed. (apropos): vector-for-each --> array-for-each. (apropos-internal): New function. Return list of accessible symbols matching regexp. * debug.scm (frame-number->index): New function. Convert frame number (as displayed in the backtrace) to frame index (to be used in stack-ref). * emacs.scm (emacs-load): New arguments: interactivep: when non-false, send back results to Emacs; colnum: Column number; Use modules (ice-9 debug) and (ice-9 session); (no-stack, no-source): New simple-actions; (result-to-emacs): New procedure. Sends data to Emacs via the result protocol; (get-frame-source, emacs-select-frame, emacs-frame-eval, emacs-symdoc): New procedures. Wed Aug 20 13:21:11 1997 Mikael Djurfeldt * emacs.scm (emacs-load): Adjust stack narrowing. (whitespace-chars): Include #\np. * syncase.scm: Also turn off debugging evaluator and recording of procedure names during loading of psyntax.pp. * psyntax.pp: Removed leading blanks => 800K -> 100K. Tue Aug 19 02:39:41 1997 Mikael Djurfeldt * syncase.scm: Don't tamper with debug mode setting when enabling macros. Instead cut the stack with start-stack. Load psyntax.pp with recording of positions turned off. * psyntax.pp, psyntax.ss (quasiquote): Changed fx= --> =. * syncase.scm: New file: Guile-adaption for syntax-case macros. * psyntax.pp, psyntax.ss: Syntax-case macros, portable version 2 by R. Kent Dybvig, Oscar Waddell, Bob Hieb and Carl Bruggeman Mon Aug 18 21:58:25 1997 Mikael Djurfeldt * session.scm: New file: Session support. (apropos): New procedure: List bindings given regexp. Sat Aug 16 18:44:24 1997 Gary Houston * boot-9.scm: define tms accessors: clock, utime, stime, cutime, cstime. Thu Aug 14 19:55:37 1997 Mikael Djurfeldt * emacs.scm (emacs-load): Something has changed in the reader so that we now should set the port line count to the specified value (linum) instead of (- linum 1). * slib.scm (slib:load): Use load-from-path instead of primitive-load-path so that backtraces get narrowed properly at the top. * boot-9.scm (top-repl): Save stack already in signal handler in order to narrow it correctly. (save-stack): Adjust narrowing tag for the top of load-stacks. Tue Jul 29 01:18:08 1997 Gary Houston * boot-9.scm (move->fdes, dup->port): use dup->fdes, not primitive-dup. (dup->fdes): deleted, now done in C. Sat Jul 26 08:00:42 1997 Gary Houston * boot-9.scm (setenv): new procedure, scsh compatible. Sat Jul 26 21:30:10 1997 Marius Vollmer * boot-9.scm (with-fluids): New macro to go with the builtin `with-fluids*'. Thu Jul 24 04:28:11 1997 Mikael Djurfeldt * slib.scm (install-require-module): In newer versions of slib *catalog* is #f until the first access. Therefore we call require:provided? for a random feature if *catalog* is #f. Wed Jul 23 20:13:04 1997 Mikael Djurfeldt * boot-9.scm: If using emacs interface, enable backtraces automatically. Mon Jul 21 06:45:45 1997 Gary Houston * boot-9.scm (dup->port, dup->inport, dup->outport, dup->fdes, dup, fdes->inport, fdes->outport, port->fdes): new procedures. (duplicate-port): was a C primitive, now it's here. (move->fdes): allow the first argument to be a file descriptor. Return the modified port or file descriptor (was unspecified.) Fri Jul 11 00:13:43 1997 Jim Blandy Changes to compile under gnu-win32, from Marcus Daniels: * boot-9.scm (load-user-init): If HOME is unset, provide a default of /. * boot-9.scm (define-public): Changed to accomodate Hobbit. Tue Jun 24 00:31:47 1997 Jim Blandy * boot-9.scm, debug.scm, hcons.scm, lineio.scm, mapping.scm, poe.scm, slib.scm, tags.scm, threads.scm: Use normal list notation, instead of #/ notation. * expect.scm (expect-strings): Pass regexp/newline flag to make-regexp. Mon Jun 23 16:13:38 1997 Jim Blandy Fix inconsistencies in parsing of #/ style lists. * boot-9.scm (read-path-list-notation): New function. (parse-path-symbol): Deleted. Replaced by above. Plug in read-path-list-notation as the parser for #/ lists, instead of the anonymous lambda form calling parse-path-symbol. (Thanks to Maurizio Vitale.) * boot-9.scm (make-list): Remove the definition of this function from the (ice-9 common-list) module; make the `init' argument optional in the scm module's definition, to match the deleted definition. Harmony reigneth? (Thanks to Bernard URBAN.) Sun Jun 22 18:33:17 1997 Jim Blandy Try to detect when people are using one version of libguile and a different version of ice-9. People have been skewing things and sending in bug reports. * version.scm.in: New file, which the configure script munges to produce version.scm, which contains the ice-9 config stamp. * boot-9.scm: Compare the libguile and ice-9 config stamps; display a warning if the two are different. * Makefile.am: Install version.scm, but don't distribute it. Distribute version.scm.in, but don't install it. * Makefile.in: Regenerated. Thu Jun 19 21:01:16 1997 Jim Blandy * slib.scm (slib:warn): Alias for WARN function. Fri Jun 13 00:32:04 1997 Jim Blandy * boot-9.scm (struct-printer): Fix off-by-one error in range check. Correctly check for struct printer tag. * expect.scm: Turn this into a module, (ice-9 expect). (expect-port, expect-timeout, expect-timeout-proc, expect-eof-proc, expect-char-proc, expect, expect-strings, expect-select): Make these public definitions. (expect-strings): Use make-regexp and regexp-exec, instead of regcomp and regexec. We've omitted the REG_NEWLINE flag; hope that's okay. * boot-9.scm (with-regexp-parts): Comment this out. It has no users in the core, and relies on mildly hairy details of the old regexp interface. * test.scm: Re-enable tests asserting that '() is true, and not a boolean. This stuff has been true for a while. * boot-9.scm (ipow-by-squaring, butlast): Fix uses of outdated function names. * boot-9.scm (with-excursion-getter-and-setter, q-rear): Doc fixes. Wed Jun 11 00:31:40 1997 Jim Blandy * Makefile.in: Regenerated after xtra_PLUGIN_guile_libs change in ../configure.in. Fri Jun 6 14:37:18 1997 Marius Vollmer * boot-9.scm (struct-printer): Bugfix: Check the layout of the vtable and not the one of the struct. Wed Jun 4 23:27:16 1997 Marius Vollmer * boot-9.scm (struct-layout, %struct-printer-tag, struct-printer, make-struct-printer, set-struct-printer-in-vtable!): New bindings to support printing of structures. (record-type-vtable, make-record-type): Add slot to hold printing function and initialize it with something appropriate. Removed commented out printing code. (record-type-name, record-type-fields): Adjusted slot offsets. (%print-module): Reduce argument list to "mod" and "port". Tue Jun 3 17:04:18 1997 Jim Blandy * slib.scm (identity): New function, used by SLIB. Sat May 31 18:57:12 1997 Gary Houston * boot-9.scm: signal-handler, alarm-thunk: removed. don't define ticks-interrupt etc. top-repl: install signal handlers for SIGINT, SIGFPE, SIGSEGV, SIGBUS during call to scm-style-repl. Fri May 30 18:08:10 1997 Jim Blandy * slib.scm (slib:load): Use primitive-load-path instead of basic-load. This is probably wrong, but hopefully the entire source access system will be revised soon anyway, and this will make require behave more like Emacs Lisp's require. If this breaks something, please let me know. Maybe this is real dumb. Thu May 29 02:36:48 1997 Jim Blandy * regex.scm: Add a module declaration. Use DEFINE-PUBLIC everywhere. * boot-9.scm: If the `regex' feature is present, use the module (ice-9 regex). Tue May 27 22:48:14 1997 Tim Pierce * regex.scm: New file. * Makefile.am (subpkgdata_DATA): Add regex.scm. * Makefile.in: Regenerated. Mon May 26 17:24:48 1997 Jim Blandy * COPYING, boot-9.scm, debug.scm, emacs.scm, expect.scm, gtcl.scm, gwish.scm, hcons.scm, lineio.scm, mapping.scm, nonblocking.scm, oldprint.scm, poe.scm, r4rs.scm, source.scm, tags.scm, test.scm, threads.scm: New address for FSF. Fri May 16 04:09:45 1997 Jim Blandy * debug.scm: Update copyright years; this file has been worked on in 1997. Thu May 15 07:56:08 1997 Gary Houston * expect.scm: use gettimeofday instead of get-internal-real-time and use a floating point timeout when calling select. Untested, since the regex library is currently AWOL. Wed May 14 21:00:30 1997 Jim Blandy * boot-9.scm (eval-string): Function deleted; it was already implemented in C, so there's no point in making a divergable copy here. Tue May 13 16:40:06 1997 Jim Blandy * Makefile.in: Regenerated, using automake-1.1p. Tue May 13 16:40:06 1997 Jim Blandy * Makefile.in: Regenerated, using automake-1.1p. Tue May 13 02:48:49 1997 Gary Houston * boot-9.scm (error-catching-loop): don't read a line from current input when quit is encountered, the previous change fixes this too. Mon May 12 19:00:21 1997 Jim Blandy * boot-9.scm (scm-style-repl): After reading an expression, consume any trailing newline (perhaps preceded by whitespace), to avoid screwing up GDB. More detail in comments. Mon May 5 13:18:38 1997 Jim Blandy * Makefile.am (ETAGS_ARGS): New variable, since we're not treating the Scheme code like code yet. * Makefile.in: Resrac,husrched. Wed Apr 30 15:25:15 1997 Marius Vollmer * boot-9.scm (link-dynamic-module): Do not catch errors from dynamic-link and dynamic-call. When the shared library exists it is now assumed to be suitable for a dynamic C module. Fri Apr 25 21:21:35 1997 Marius Vollmer * boot-9.scm (process-use-modules): New function to support the use-modules macro (use-modules): throw an error iff one of the requested modules can't be found. Tue Apr 29 06:54:46 1997 Gary Houston * boot-9.scm: don't define timer-thunk or gc-thunk. Sun Apr 27 17:56:09 1997 Jim Blandy * aclocal.m4: Removed; unnecessary, given changes of Apr 24. * Makefile.am (subpkgdatadir): Use "ice-9" instead of "@module@"; we're not using AM_INIT_GUILE_MODULE any more. * Makefile.in: Regeneratitetedrerd. Thu Apr 24 01:33:33 1997 Jim Blandy Get 'make dist' to work again. * Makefile.am (EXTRA_DIST): Remove PLUGIN files. * Makefile.in: Regenerated, like two tons of fleas. Changes for reduced Guile distribution: one configure script, no plugins. * configure.in, configure: Removed. * Makefile.in: Regenerated. Sat Apr 19 08:03:50 1997 Jim Blandy * boot-9.scm (eval-string, command-line, load-user-init): New functions. Sat Apr 12 08:27:05 1997 Gary Houston * boot-9.scm (log10): defined. Tue Apr 1 17:46:49 1997 Gary Houston * expect.scm (expect-select): correct the millisecond timeout arithmetic (from Marko.Kohtala@ntc.nokia.com). Mon Mar 31 03:23:19 1997 Gary Houston * boot-9.scm (open-input-pipe, open-output-pipe): defined here instead of in libguile. (tm:sec etc.) new accessors for broken-down time. (set-tm:sec etc.) new setters for broken-down time. Thu Mar 27 05:06:00 1997 Gary Houston * boot-9.scm (netent:addrtype, servent:port): added missing procedures. (netent:net, servent:proto): repaired. (utsname:sysname etc.): new accessors for uname. Tue Mar 25 03:04:03 1997 Gary Houston * boot-9.scm (sockaddr:fam, sockaddr:path, sockaddr:addr, sockaddr:port): new functions. Wed Mar 19 04:50:34 1997 Gary Houston * boot-9.scm: define accessor procedures for the objects returned by getpw, getgr, gethost, getnet, getproto, getserv (e.g., passwd:name, where the first component is the name of the C structure and the second is the unprefixed C member name.) Tue Mar 18 18:39:31 1997 Gary Houston * boot-9.scm (setpwent, setgrent, sethostent, setnetent, setprotoent, setservent): no longer take an argument, it was bogus. Thu Mar 13 00:13:41 1997 Gary Houston * boot-9.scm (scm-error): deleted, reimplemented in C. Mon Mar 10 15:48:31 1997 Mikael Djurfeldt * boot-9.scm (process-define-module): Modified to handle both keywords and symbols. Sat Mar 8 04:32:44 1997 Gary Houston * slib.scm: update read usage. * r4rs.scm: update primitive-load usage. Don't define read-sharp. * boot-9.scm: use read-hash-extend to install extra read syntax. (read-sharp): removed. Adjust usage of primitive-load-path, read, which no longer take case_i or read-sharp arguments. Sat Mar 8 00:07:54 1997 Mikael Djurfeldt * boot-9.scm: Added loading of session support module. * debug.scm: Removed `display-application'. (Replaced by primitive procedure.) * boot-9.scm (beautify-user-module!): Don't add the root module interface to the end of the use-list of the root module. Thu Mar 6 07:26:34 1997 Gary Houston * boot-9.scm: repl-quit, repl-abort: obsolete variables deleted. Wed Mar 5 20:30:24 1997 Gary Houston * boot-9.scm: check use-emacs-interface for emacs support. Sun Mar 2 19:47:14 1997 Gary Houston * boot-9.scm (scm-style-repl): call repl-report-start-timing if read gets EOF. * (exit): alias for quit. Sun Mar 2 05:25:11 1997 Gary Houston * boot-9.scm (error-catching-loop thunk): use a status variable to return the quit args. (scm-style-repl): call -quit, passing return value from error-catching-repl. Make -quit return its args. stand-alone-repl: comment out, since it seems unused. (error-catching-loop thunk): discard trailing junk after a (quit). Sat Mar 1 15:24:39 1997 Mikael Djurfeldt * boot-9.scm: Removed the old printer code. * r4rs.scm (apply, call-with-current-continuation): Added comment explaining why apply and call/cc need to be closures. * boot-9.scm (apply, call-with-current-continuation): Bugfix: Removed. These definitions are already present in r4rs.scm. * debug.scm (trace-entry, trace-exit): Check that we're on a repl stack before printing traced frames; Re-enable trace flag at end of handlers. Sat Mar 1 00:10:38 1997 Mikael Djurfeldt * debug.scm: Add hook for reset of trace level at abort. * boot-9.scm (run-hooks): New procedure. (add-hooks!): New macro. Change hooks to use these functions. * debug.scm: *Warning* This feature is a bit premature. I add it anyway because 1. it is very useful, and, 2. you can start making it less premature by complaining to me and by modifying the source! :-) (trace): Given one or more procedure objects, trace each one. Given no arguments, show all traced procedures. (untrace): Given one or more procedure objects, untrace each one. Given no arguments, untrace all traced procedures. The tracing in Guile have an advantage to most other systems: We don't create new procedure objects, but mark the procedure objects themselves. This means that also anonymous and internal procedures can be traced. * boot-9.scm (error-catching-loop): Added handling of apply-frame and exit-frame exceptions. * boot-9.scm (assert-repl-prompt, the-prompt-string): Removed. (set-repl-prompt!): Setter for repl prompt. (scm-style-repl): If prompt is #f, don't prompt; if prompt is a string, display it; if prompt is a thunk, call it and display its result; otherwise display "> ". (Change suggested by Roland Orre .) * r4rs.scm (%load-verbosely): Reverted change to `module-defined?', since the module system isn't bootstrapped when we load r4rs.scm. This is just a temporary fix to make the repository version runnable. Thu Feb 27 23:25:47 1997 Mikael Djurfeldt * boot-9.scm: Removed the enabling of debug evaluator and recording of source code positions. This was placed there for our convenience, but it has already sneaked into the distribution once... so we'd better add this in our local copies instead when we need it. (These options are normally enabled at the end of boot-9.scm when loading the debug module.) Thu Feb 27 16:04:45 1997 Marius Vollmer * boot-9.scm (module-defined?): New function. (macroexpand-1, macroexpand): Use local-ref instead of defined? and eval. * r4rs.scm (%load-verbosely): Use "module-defined?" instead of "defined?". * slib.scm (defined?): New function to take the place of the builtin "defined?". It allways examines the slib module. Mon Feb 24 21:46:15 1997 Mikael Djurfeldt * configure.in: Added AM_MAINTAINER_MODE Sat Feb 15 04:51:20 1997 Gary Houston * boot-9.scm (read-sharp): define directly, don't go through a %read-sharp layer. Tue Feb 11 08:45:48 1997 Gary Houston * boot-9.scm (uniform-vector-set!): use uniform-array-set1!, not uniform-vector-set1! which doesn't exist. Mon Feb 10 03:01:48 1997 Mikael Djurfeldt * boot-9.scm (backtrace): Removed. (A C version now exists in backtrace.c.) Fri Jan 24 06:05:36 1997 Gary Houston * boot-9.scm (read-line!, read-delimited!, read-delimited, read-line): new procedures, see libguile/ChangeLog. Thu Jan 16 17:07:03 1997 Marius Vollmer Added dynamic linking of modules. See libguile/DYNAMIC-LINKING. * boot-9.scm (split-c-module-name, convert-c-registered-modules, init-dynamic-module, dynamic-maybe-call, find-and-link-dynamic-module, link-dynamic-module, try-module-dynamic-link, registered-modules): New definitions for dynamic linking of modules. (resolve-module): Try to dynamically link the requested module after failing to load it as Scheme code. Wed Jan 8 05:50:14 1997 Gary Houston * boot-9.scm (getservbyport, getservbyname): remove stray %. Tue Jan 7 20:02:24 1997 Jim Blandy * boot-9.scm (and=>): Rename THUNK argument to PROCEDURE, 'cos that's what it is. * lineio.scm (make-line-buffering-input-port): Properly test for the case of an empty buffer list. The old code assumed that '() was false. Mon Jan 6 01:13:53 1997 Mikael Djurfeldt * boot-9.scm (use-modules): New macro (from Marius Vollmer). (use-modules ...) Put the the modules named by ... on the use list of the current module. Sun Jan 5 15:52:59 1997 Jim Blandy * boot-9.scm (error-catching-loop): Remove message saying that typing "$" will put you in the debugger. This isn't implemented yet. Sun Dec 22 23:27:25 1996 Jim Blandy * boot-9.scm (delq-all!): Function deleted; delq!'s semantics have been fixed, so this function is superfluous. (transform-usage-lambda): Use delq!, not delq-all!. Tue Dec 17 20:36:45 1996 Marius Vollmer * boot-9.scm (resolve-module): New optional parameter that controls whether autoloading is attempted or not. Default is #t. (process-define-module): Don't autoload the defined module. (try-module-autoload): Don't autoload the directory modules. * boot-9.scm (process-define-module): Ensure that the-scm-module is last in the `uses' list to allow shadowing builtin bindings. All :use-module options are added in the order they appear in the arguments but before anything already on the list (such as the-scm-module). Wed Dec 11 21:06:05 1996 Gary Houston * slib.scm (slib-parent-dir): throw error if #f returned from %search-load-path. Sat Nov 30 23:57:28 1996 Tom Tromey * PLUGIN/greet, PLUGIN/split.sed, PLUGIN/this.configure: Removed. * Makefile.am, aclocal.m4: New files. * configure.in: Updated for Automake. Wed Nov 27 14:16:14 1996 Marius Vollmer * boot-9.scm (macroexpand-1, macroexpand), slib.scm (slib:features), r4rs.scm (%load-verbosely): "defined?" is now a function, use it accordingly. Thu Nov 21 11:12:10 1996 Jim Blandy It's an "eval closure", not an "eval thunk." A thunk is a function of no arguments. * boot-9.scm (module-type): Rename module field. (make-module, eval-in-module, make-root-module, set-current-module): Uses changed. (module-eval-closure, set-module-eval-closure!, root-module-closure): Renamed from module-eval-thunk, set-module-eval-thunk!, root-module-thunk. (set-current-module): Change uses of *top-level-lookup-thunk* to *top-level-eval-closure*. Wed Nov 20 14:45:27 1996 Jim Blandy * slib.scm (slib-parent-dir): Use string-length, not length. (Thanks to Bernard Urban.) Sat Nov 2 20:00:42 1996 Mikael Djurfeldt * boot-9.scm: The debugging evaluator and recording of positions aren't enabled by default any longer (they are switched on in debug.scm). But during development we want to have them also *inside* boot-9.scm. Therefore, two lines are added at the beginning of boot-9.scm to enable these. Call `provide' so that `records' are included among the `*features*'. The scheme for saving the stack has been adjusted: save-stack is now commonly available for saving the stack. Calling `save-stack' sets a flag `stack-saved?' which prevents overwriting the stack. `stack-saved?' is reset at `abort'. Spelling correction: seperate --> separate. Removed `:'s that had creeped into some comments. The repl now doesn't print # results any longer If the user wants to see this, he can do (assert-repl-print-unspecified #t) in his startup file. The user now gets a friendly message instead of a backtrace at error. Added `before-read-hook'. Load module (ice-9 emacs) if option `-e' was specified. (provide): New function. (error): Save stack at entry, so that Guile entrails won't show up in backtraces. (backtrace): New function. (save-stack): Can now take arbitrary number of stack narrowing specifier pairs. The first specifier in a pair controls inner border, the second the outer border. A number means cut that number of frames, a procedure object means cut until that object is found in operator position in a frame. * debug.scm: Enable debugging evaluator and recording of positions by default. * slib.scm (slib:load): Adapt to the new behavior of primitive-load: It doesn't any longer try both with and without ".scm" extension. (We don't want to use %search-load-path here.) (implementation-vicinity): New function. slib requires it (library-vicinity): Updated. Load "require.scm" in the library-vicinity. (install-require-vicinity, install-require-module): New functions. Mon Oct 28 17:56:29 1996 Jim Blandy * boot-9.scm (load-from-path): New function. * boot-9.scm (try-load, basic-try-load, try-load-module, try-load): Deleted. I don't think they're being used. * Makefile.in (scm_files): Add r4rs.scm and test.scm to this list, so they'll get distributed. Get Guile to be a little less chatty by default. The new user should see as little clutter as possible. * r4rs.scm (%load-verbosely): Make this #f by default. * boot-9.scm (scm-repl-verbose): Make this #f by default. (scm-style-repl): Don't run 'pk' on the value passed to quit. * r4rs.scm: New file. * boot-9.scm: Load r4rs.scm, first thing. (OPEN_READ, OPEN_WRITE, OPEN_BOTH, *null-device*, open-input-file, open-output-file, open-io-file, close-input-port, close-output-port, close-io-port, call-with-input-file, call-with-output-file, with-input-from-port, with-output-to-port, with-error-to-port, with-input-from-file, with-output-to-file, with-error-to-file, with-input-from-string, with-output-to-string, with-error-to-string, the-eof-object): Definitions moved to r4rs.scm. Not all of them are R4RS, but those that are use those that are not. (load, %load-verbosely, %load-announce): Moved, along with code to set %load-hook, to r4rs.scm. * test.scm: New file. * boot-9.scm (integer?): Definition deleted, in favor of the one present in libguile (which used to be called int?). I have no idea why integer? didn't just call int? to begin with. * boot-9.scm (<, <=, =, >, >=): Definitions in terms of ?, and >=? deleted; they're defined that way by libguile now. * boot-9.scm (load): Simplified; primitive-load does most of this work now. (%load-announce-win): Removed; no longer used. Set %load-hook to call %load-announce. Sun Oct 27 07:47:03 1996 Gary Houston * boot-9.scm (stat:dev, stat:ino, stat:mode, stat:nlink, stat:uid, stat:gid, stat:rdev, stat:size, stat:atime, stat:mtime, stat:ctime, stat:blksize, stat:blocks) accessor functions for stat components. (file-is-directory?): use stat:type. Fri Oct 25 03:34:47 1996 Jim Blandy * boot-9.scm (%read-sharp): Don't recognize the `#!' syntax here; that's now taken care of in libguile, and in a way compatible with SCSH (which this isn't). Mon Oct 21 18:52:36 1996 Jim Blandy * boot-9.scm: Formatting tweaks. Fri Oct 18 01:03:08 1996 Mikael Djurfeldt * boot-9.scm (handle-system-error): Added hooks before-error-hook, after-error-hook, before-backtrace-hook and after-backtrace-hook to the error handler. E.g.: fancy emacs support could plug into these. (save-stack): New function. The stack is now made differently depending on the stack id. (The motivation is to make a better choice regarding what stack frames to present to the user.) (error-catching-loop): Stack handling code moved outside into save-stack. Thu Oct 17 20:33:08 1996 Gary Houston * Makefile.in (scm_files): add expect.scm. * expect.scm: new file ported from guile-iii. * boot-9.scm: remove handle-system-error, after moving the code into error-catching-loop. Don't set 'throw-handler-default property on error keys. Just interpret (almost) any throw with 4 args as an error throw. Delete some try-load stuff that was already commented out. Second thoughts, keep handle-system-error but call it from error-catching-loop. Tue Oct 15 17:07:20 1996 Jim Blandy * boot-9.scm: Doc fixes. (make-module): Rework for readability. (make-root-module, make-scm-module): USES argument to make-module should be '(), not #f. * boot-9.scm (try-load): %sys-load-path has been renamed to primitive-load-path; adjust call here. Tue Oct 15 14:25:01 1996 Mikael Djurfeldt * boot-9.scm (signal-handler): Bugfix: Moved the recording of the stack to the correct place: when it is decided to generate an error-signal. Mon Oct 14 22:20:30 1996 Mikael Djurfeldt * boot-9.scm (error-catching-loop, signal-handler, handle-system-error): Backtracing now works for signals aswell; Backtracing mechanism can now identify the stack root created by start-stack so that the user isn't exposed to system stack frames. Mon Oct 14 06:05:42 1996 Mikael Djurfeldt * Makefile.in: Added threads.scm. Mon Oct 14 04:21:51 1996 Mikael Djurfeldt * debug.scm (make-enable, make-disable): Simplified. * boot-9.scm: Renamed %%throw-handler-default --> throw-handler-default. ((handle-system-error key . arg-list)): Changed the way errors are reported. ((scm-style-repl)): Wrap up the call to eval in a start-stack acro. ((error-catching-loop thunk)): Introduce a lazy-catch into error-catching-loop so that the stack can be captured. Thu Oct 10 22:27:32 1996 Jim Blandy * mapping.scm (hash-table-mapping): Explicitly request that make-vector fill new vectors with '(); this will make it easier to port Guile Scheme code to other Schemes. * boot-9.scm (make-print-style, make-print-table): Same. Sun Oct 6 03:54:59 1996 Gary Houston * boot-9.scm (load): rewritten again. Append "." to the default %load-path. (feature?): new function: checks for a symbol in the features list. (module-local-variable): remove apparently useless (caddr (list m v ...)) (%load-announce): minor formatting change. (file-exists?): use access? if posix is featured. (file-is-directory?): use stat if i/o-extensions is featured. (try-module-autoload module-name): use file-exists? before file-is-directory? Sat Oct 5 18:54:03 1996 Mikael Djurfeldt * boot-9.scm: Added conditional loading of threads.scm. * threads.scm: New file. Modified from the Cygnus-r0.3 distribution. * boot-9.scm (error-catching-loop): Added handling of key `switch-repl'. * boot-9.scm: Name change %%bad-throw --> bad-throw. Wed Oct 2 23:38:44 1996 Jim Blandy * boot-9.scm (make-record-type, record-constructor): Don't assume the empty list is false when parsing the argument list. Mon Sep 30 22:15:50 1996 Jim Blandy * boot-9.scm (signal-handler): Clean up logic. * boot-9.scm (load): Assume %load-path is always bound. Sat Sep 28 00:15:37 1996 Gary Houston * boot-9.scm (error): replace another throw with scm-error. Throw to 'misc-error instead of 'error (no need to distinguish these.) Don't set up 'error as a key. Set up regex-error as a key, if regex is available. (signal-handler): use scm-error, not throw. (%try-load, try-load-with-path, %load, load-with-path, basic-try-load-with-path, basic-load-with-path, try-load-module-with-path,load-module-with-path): deleted, since they seem redundant. (try-load): define using %try-load, not try-load-with-path. (load): rewritten. load tries to open the file directly and with a .scm extension before searching the library directories (should "." be added to %load-path? then load could still open directly files starting with "/"). (try-module-autoload): use load, not load-with-path. (%load-indent): deleted, -2 was causing errors. (%read-sharp): use port-line, not line-number. Fri Sep 27 16:23:51 1996 Jim Blandy * boot-9.scm (%%bad-throw): Delete definition. 1) It's very straightforward to provide the equivalent functionality using (catch #t ...), so there's no need for the extra complexity. 2) Outside the context of a read-eval-print loop (which Guile should not require) it's not clear we should do anything more complicated than print an error and exit; the user or REPL can establish something better if it wants. 3) In that case, it's much more robust to just do it in the C code. Tue Sep 24 06:53:04 1996 Gary Houston * boot-9.scm (%try-load): define using primitive-load. Previously %try-load itself was the primitive. (load-with-path): use scm-error instead of %load-announce-lossage. Errors are thrown to 'misc-error instead of 'could-not-load. (%load-announce-lossage): deleted. Mon Sep 23 00:16:31 1996 Mikael Djurfeldt * boot-9.scm (warn, scm-style-repl): Use C printer instead of `print'. (make-record-type type-name fields): Temporarily remove support for printing of records (not possible yet with C printer). Fri Sep 20 00:24:27 1996 Gary Houston * boot-9.scm (file-exists?, file-is-directory): catch only system-error, not every kind of error. (scm-error): new procedure. Thu Sep 19 16:02:46 1996 Jim Blandy * boot-9.scm: Formatting tweaks. Wed Sep 18 09:07:37 1996 Gary Houston * boot-9.scm (%%handle-system-error key): remove the code for SCM-style errors. handle the case that an unexpected number of args are supplied. (%%system-errors): removed. (error): redefine using a throw with key and 4 args. ('error): associate 'error, 'error-signal keys with %%handle-system-error. (%%default-error-handler): removed. (signal-handler): throw with 4 args and use the error-signal key. Create an error message instead of using numerical codes. (%%bad-throw): call error instead of throw if key not found. Tue Sep 17 04:11:28 1996 Gary Houston * boot-9.scm: initialize new error keys (see libguile/ChangeLog). (%%handle-system-error key): check subr is not #f before printing. Recognize %s (embed an argument using "display") and %S (embed an argument using "write"). Sun Sep 15 03:55:35 1996 Gary Houston * boot-9.scm (%%handle-system-error key): set args and rest to the empty list if they are #f. Initialize out-of-range as an error key. Sat Sep 14 03:41:15 1996 Gary Houston * PLUGIN/REQ: remove the "ice-9 lgh" line which causes a cycle. * boot-9.scm: remove leading %% from references to '%%system-error. (%%handle-system-error): don't pass all the thrown arguments when aborting, just the key and subr. Remove the code to "Install default handlers for built-in errors." Remove the definition of the syserror procedure. Associate 'numerical-overflow with default handler. Fri Sep 13 04:58:11 1996 Mikael Djurfeldt * boot-9.scm: Name change: value-ref --> local-ref resolved-ref --> nested-ref Motivation: conformance to the other dictionary operators: list-ref operates on list, vector-ref operates on vector, nested-ref operates on nested namespace, local-ref operates on the local nested namespace. Sat Sep 7 06:44:47 1996 Gary Houston * boot-9.scm (%%handle-system-error): recognise errors thrown by lgh-error (fill-message etc.) (fill-message): check first whether args is null. (fill-message): bug fix and check that args is a list. Thu Sep 5 11:33:41 1996 Jim Blandy * boot-9.scm: %load-path is initialized in C code now. (implementation-vicinity, parse-path): Deleted, along with code to initialize %load-path. * boot-9.scm (in-vicinity): If the vicinity doesn't end with a "/", use one to separate it from the file. Thu Aug 29 23:05:11 1996 Thomas Morgan * boot-9.scm (%load-path): Add the site directory. Add the directory named after the version number. Prepend the version number to the other directories in the path. Simplify by mapping the common prefix onto each item. * Makefile.in (datadir, pkgdatadir, pkgverdatadir, subpkgdatadir, sitedatadir): New definitions. (libparent, libdir, install_path): Replaced by above. (install): Create the above directories. Put the source files into subpkgdatadir. (uninstall): Remove the above directories. Thu Aug 29 21:48:47 1996 Jim Blandy Don't use the PLUGIN system to gather information for the Makefile's distribution and installation targets; just put it all in the Makefile directly. * PLUGIN/this.configure (scm_files, aux_files): Remove sections for these. * configure.in: Remove code that gets and substitutes scm_files and aux_files. * Makefile.in (scm_files, aux_files): Write out the list of files here, where people expect to find them. Fri Aug 23 06:44:36 1996 Mikael Djurfeldt * boot-9.scm: Preliminary solution: optionally load the debug module. Changed "gls" to "guile1.0b3". * debug.scm: New file: debug extensions. Wed Aug 21 13:06:56 1996 Mikael Djurfeldt * boot-9.scm (print-vector): Renamed weak-hash-table? --> weak-key-hash-table?. (Again!) Tue Aug 20 07:31:39 1996 Mikael Djurfeldt * boot-9.scm (print-vector, macro-table, xformer-table): Renamed weak-hash-table --> weak-key-hash-table. * poe.scm (funcq-memo): Renamed weak-hash-table --> weak-key-hash-table. Sat Aug 3 06:16:35 1996 Gary Houston * boot-9.scm (*null-device*): global constant from goonix. (move->fdes): adjusted for boolean primitive-move->fdes. return the modified port, always set revealed count to 1 (SCSH compatible). (release-port-handle port): from goonix (SCSH compatible). (%open-file): removed. (open-input-file, open-output-file, file-exists?, file-is-directory?): modified for open-file change (does not return #f). Thu Aug 1 02:52:42 1996 Jim Blandy * Makefile.in (dist-dir): New target for new dist system. (manifest): Deleted. * PLUGIN/this.configure (aux_files): Removed PLUGIN; it's a directory, and needs special treatment in the dist-dir target. Thu Aug 1 09:00:21 1996 Gary Houston * boot-9.scm: remove the wrappers for '%' system primitives, now that they throw errors directly. remove make-simple-wrapper and similar functions. protect a call to getenv which may now throw an exception. Wed Jul 31 23:44:42 1996 Gary Houston * boot-9.scm (false-if-exception): new macro. Fri Apr 19 13:53:08 1996 Tom Lord * The more things change... --- ice-9/rw.scm | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) create mode 100644 ice-9/rw.scm diff --git a/ice-9/rw.scm b/ice-9/rw.scm new file mode 100644 index 000000000..6b5327ea1 --- /dev/null +++ b/ice-9/rw.scm @@ -0,0 +1,26 @@ +;;; installed-scm-file + +;;;; Copyright (C) 2001 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; + + +;;; This is the Scheme part of (ice-9 rw), which is a subset of +;;; (scsh rw). + +(define-module (ice-9 rw) + :export (read-string!/partial)) From 9a6fb1645e594e54c34169117d4a420c51ac9688 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 29 Apr 2001 13:05:27 +0000 Subject: [PATCH 0948/2047] ## Process this file with automake to produce Makefile.in. ## ## Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## ## GUILE 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, or ## (at your option) any later version. ## ## GUILE 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 GUILE; see the file COPYING. If not, write ## to the Free Software Foundation, Inc., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA AUTOMAKE_OPTIONS = foreign # These should be installed and distributed. ice9_sources = \ and-let-star.scm arrays.scm boot-9.scm calling.scm common-list.scm \ debug.scm debugger.scm documentation.scm emacs.scm expect.scm \ format.scm getopt-long.scm hcons.scm lineio.scm ls.scm mapping.scm \ match.scm networking.scm null.scm optargs.scm poe.scm popen.scm \ posix.scm psyntax.pp psyntax.ss q.scm r4rs.scm r5rs.scm \ rdelim.scm receive.scm regex.scm runq.scm rw.scm \ safe-r5rs.scm safe.scm session.scm slib.scm stack-catch.scm \ streams.scm string-fun.scm syncase.scm tags.scm threads.scm \ buffered-input.scm time.scm history.scm channel.scm subpkgdatadir = $(pkgdatadir)/$(VERSION)/ice-9 subpkgdata_DATA = $(ice9_sources) ETAGS_ARGS = $(subpkgdata_DATA) install-data-local: -$(INSTALL_DATA) and-let-star-compat.scm \ $(subpkgdatadir)/'and-let*.scm' ## test.scm is not currently installed. EXTRA_DIST = $(ice9_sources) test.scm and-let-star-compat.scm psyntax.pp: cd $(srcdir) && guile -c '(load-from-path "ice-9/syncase") (psyncomp)' --- ice-9/ChangeLog | 5 +++++ ice-9/Makefile.am | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 5f8fb0964..78fafd4f5 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2001-04-29 Gary Houston + + * rw.scm: new file, for module (ice-9 rw). + * Makefile.am: add rw.scm. + 2001-04-28 Thien-Thi Nguyen * boot-9.scm, optargs.scm: diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index 14c2594cc..a05a63bf7 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -28,7 +28,7 @@ ice9_sources = \ format.scm getopt-long.scm hcons.scm lineio.scm ls.scm mapping.scm \ match.scm networking.scm null.scm optargs.scm poe.scm popen.scm \ posix.scm psyntax.pp psyntax.ss q.scm r4rs.scm r5rs.scm \ - rdelim.scm receive.scm regex.scm runq.scm \ + rdelim.scm receive.scm regex.scm runq.scm rw.scm \ safe-r5rs.scm safe.scm session.scm slib.scm stack-catch.scm \ streams.scm string-fun.scm syncase.scm tags.scm threads.scm \ buffered-input.scm time.scm history.scm channel.scm From 7e267da19f0c331afe8e4cde42d5928a95b669b5 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 29 Apr 2001 13:06:31 +0000 Subject: [PATCH 0949/2047] * libguile.h: include rw.h. --- ChangeLog | 4 ++++ NEWS | 61 +++++++++++++++++++++++++++++------------------------- libguile.h | 1 + 3 files changed, 38 insertions(+), 28 deletions(-) diff --git a/ChangeLog b/ChangeLog index f979331be..8f728e564 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2001-04-29 Gary Houston + + * libguile.h: include rw.h. + 2001-04-27 Rob Browning * GUILE-VERSION (GUILE_MINOR_VERSION): change to 5.0, switching to diff --git a/NEWS b/NEWS index 524ab7471..b852cce58 100644 --- a/NEWS +++ b/NEWS @@ -140,6 +140,38 @@ future. Alternatively, if guile-scsh is installed, the (scsh rdelim) module can be used for similar functionality. +** New module (ice-9 rw) + +This is a subset of the (scsh rw) module from guile-scsh. Currently +it defines a single procedure: + +** New function: read-string!/partial str [port_or_fdes [start [end]]] + + Read characters from an fport or file descriptor into a string + STR. This procedure is scsh-compatible and can efficiently read + large strings. It will: + + * attempt to fill the entire string, unless the START and/or + END arguments are supplied. i.e., START defaults to 0 and + END defaults to `(string-length str)' + + * use the current input port if PORT_OR_FDES is not supplied. + + * read any characters that are currently available, without + waiting for the rest (short reads are possible). + + * wait for as long as it needs to for the first character to + become available, unless the port is in non-blocking mode + + * return `#f' if end-of-file is encountered before reading any + characters, otherwise return the number of characters read. + + * return 0 if the port is in non-blocking mode and no characters + are immediately available. + + * return 0 if the request is for 0 bytes, with no end-of-file + check + ** New module (ice-9 match) This module includes Andrew K. Wright's pattern matcher: @@ -415,33 +447,6 @@ Guile. Instead, use scm_c_memq or scm_memq, scm_memv, scm_member. -** New function: read-string!/partial str [port_or_fdes [start [end]]] - - Read characters from an fport or file descriptor into a string - STR. This procedure is scsh-compatible and can efficiently read - large strings. It will: - - * attempt to fill the entire string, unless the START and/or - END arguments are supplied. i.e., START defaults to 0 and - END defaults to `(string-length str)' - - * use the current input port if PORT_OR_FDES is not supplied. - - * read any characters that are currently available, without - waiting for the rest (short reads are possible). - - * wait for as long as it needs to for the first character to - become available, unless the port is in non-blocking mode - - * return `#f' if end-of-file is encountered before reading any - characters, otherwise return the number of characters read. - - * return 0 if the port is in non-blocking mode and no characters - are immediately available. - - * return 0 if the request is for 0 bytes, with no end-of-file - check - ** New function: object->string OBJ Return a Scheme string obtained by printing a given object. @@ -5483,7 +5488,7 @@ Until then, gtcltk-lib provides trivial, low-maintenance functionality. Copyright information: -Copyright (C) 1996,1997 Free Software Foundation, Inc. +Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 Free Software Foundation, Inc. Permission is granted to anyone to make or distribute verbatim copies of this document as received, in any medium, provided that the diff --git a/libguile.h b/libguile.h index 0eaed6891..d3e8a9adf 100644 --- a/libguile.h +++ b/libguile.h @@ -86,6 +86,7 @@ extern "C" { #include "libguile/init.h" #include "libguile/ioext.h" #include "libguile/rdelim.h" +#include "libguile/rw.h" #include "libguile/keywords.h" #include "libguile/list.h" #include "libguile/load.h" From c8127e2f87265597d38977cbcbea6ff9efc29818 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 29 Apr 2001 17:15:50 +0000 Subject: [PATCH 0950/2047] *** empty log message *** --- ice-9/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 78fafd4f5..ba0e2dada 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2001-04-26 Marius Vollmer + + * boot-9.scm (the-module, set-current-module, current-module): + Removed, they are now defined in libguile. + 2001-04-29 Gary Houston * rw.scm: new file, for module (ice-9 rw). @@ -42,6 +47,7 @@ * srfi-8.scm: removed in favor of srfi/srfi-8.scm - (wasn't ever in a production release). +>>>>>>> 1.412 2001-04-25 Keisuke Nishida * channel.scm: New file. From d72691f2915827d2dfd90bc41efb3b5330634412 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sun, 29 Apr 2001 23:01:07 +0000 Subject: [PATCH 0951/2047] * Doc updates for removal of previously deprecated features. * More detailed AUTHORS description for Jim Blandy. --- NEWS | 2 ++ doc/AUTHORS | 4 +++- doc/ChangeLog | 5 +++++ doc/deprecated.texi | 9 --------- doc/scheme-io.texi | 5 ----- ice-9/ChangeLog | 1 - 6 files changed, 10 insertions(+), 16 deletions(-) diff --git a/NEWS b/NEWS index b852cce58..9a0b7cb78 100644 --- a/NEWS +++ b/NEWS @@ -27,6 +27,8 @@ Changes since Guile 1.4: *** scheme functions removed: + tag - no replacement. + fseek - replaced by seek. list* - replaced by cons*. ** New SRFI modules have been added: diff --git a/doc/AUTHORS b/doc/AUTHORS index 13fc1dede..8c09603e1 100644 --- a/doc/AUTHORS +++ b/doc/AUTHORS @@ -6,7 +6,9 @@ @ifset guile @c The Guile reference and tutorial manuals were written and edited -@c largely by Mark Galassi and Jim Blandy. +@c largely by Mark Galassi and Jim Blandy. In particular, Jim wrote the +@c original tutorial on Guile's data representation and the C API for +@c accessing Guile objects. @c Significant portions were contributed by Gary Houston (contributions @c to posix system calls and networking, expect, I/O internals and diff --git a/doc/ChangeLog b/doc/ChangeLog index b94443f5c..dd041c2bd 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,5 +1,10 @@ 2001-04-29 Neil Jerram + * deprecated.texi (Tags): Removed - deprecation expired. + + * scheme-io.texi (Random Access): Removed `fseek' - deprecation + expired. + * guile.texi (Top): Add menu entry for Manual Conventions node. 2001-04-28 Neil Jerram diff --git a/doc/deprecated.texi b/doc/deprecated.texi index 0b2fdd30a..f569e89fa 100644 --- a/doc/deprecated.texi +++ b/doc/deprecated.texi @@ -3,7 +3,6 @@ @menu * Shared And Read Only Strings:: -* Tags:: @end menu @@ -136,11 +135,3 @@ ERROR: Wrong type argument (expecting STRINGP): /home/ Return @code{#t} if @var{obj} is either a string or a symbol, otherwise return @code{#f}. @end deffn - - -@node Tags -@section Tags - -@deffn primitive tag x -Return an integer corresponding to the type of @var{x}. Deprecated. -@end deffn diff --git a/doc/scheme-io.texi b/doc/scheme-io.texi index 69d005c4f..cc7b4b848 100644 --- a/doc/scheme-io.texi +++ b/doc/scheme-io.texi @@ -304,11 +304,6 @@ that the current position of a port can be obtained using: @end lisp @end deffn -@deffn primitive fseek fd_port offset whence -Obsolete. Almost the same as @code{seek}, but the return value -is unspecified. -@end deffn - @deffn primitive ftell fd_port Return an integer representing the current position of @var{fd/port}, measured from the beginning. Equivalent to: diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index ba0e2dada..b3f721fab 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -47,7 +47,6 @@ * srfi-8.scm: removed in favor of srfi/srfi-8.scm - (wasn't ever in a production release). ->>>>>>> 1.412 2001-04-25 Keisuke Nishida * channel.scm: New file. From 28c313422bd760db681d9216a5e68f1761480f56 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 30 Apr 2001 01:40:32 +0000 Subject: [PATCH 0952/2047] New file --- scripts/ChangeLog | 5 + scripts/Makefile.am | 40 ++++ scripts/PROGRAM | 45 ++++ scripts/README | 76 +++++++ scripts/display-commentary | 47 ++++ scripts/doc-snarf | 442 +++++++++++++++++++++++++++++++++++++ scripts/generate-autoload | 138 ++++++++++++ scripts/punify | 81 +++++++ scripts/use2dot | 166 ++++++++++++++ 9 files changed, 1040 insertions(+) create mode 100644 scripts/ChangeLog create mode 100644 scripts/Makefile.am create mode 100755 scripts/PROGRAM create mode 100644 scripts/README create mode 100755 scripts/display-commentary create mode 100755 scripts/doc-snarf create mode 100755 scripts/generate-autoload create mode 100755 scripts/punify create mode 100755 scripts/use2dot diff --git a/scripts/ChangeLog b/scripts/ChangeLog new file mode 100644 index 000000000..22e913b13 --- /dev/null +++ b/scripts/ChangeLog @@ -0,0 +1,5 @@ +2001-04-29 Thien-Thi Nguyen + + * Makefile.am, PROGRAM, README, display-commentary, + doc-snarf, generate-autoload, punify, use2dot: New file + diff --git a/scripts/Makefile.am b/scripts/Makefile.am new file mode 100644 index 000000000..cca40e458 --- /dev/null +++ b/scripts/Makefile.am @@ -0,0 +1,40 @@ +## Process this file with automake to produce Makefile.in. +## +## Copyright (C) 2001 Free Software Foundation, Inc. +## +## This file is part of GUILE. +## +## GUILE 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, or +## (at your option) any later version. +## +## GUILE 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 GUILE; see the file COPYING. If not, write +## to the Free Software Foundation, Inc., 59 Temple Place, Suite +## 330, Boston, MA 02111-1307 USA + +AUTOMAKE_OPTIONS = foreign + +# These should be installed and distributed. +scripts_sources = \ + PROGRAM \ + display-commentary \ + doc-snarf \ + generate-autoload \ + punify \ + use2dot + +subpkgdatadir = $(pkgdatadir)/$(VERSION)/scripts +subpkgdata_SCRIPTS = $(scripts_sources) + +EXTRA_DIST = $(scripts_sources) + +overview: + @GUILE_LOAD_PATH=`(cd .. ; pwd)` \ + ./display-commentary $(scripts_sources) diff --git a/scripts/PROGRAM b/scripts/PROGRAM new file mode 100755 index 000000000..ea0146f15 --- /dev/null +++ b/scripts/PROGRAM @@ -0,0 +1,45 @@ +#!/bin/sh +# aside from this initial boilerplate, this is actually -*- scheme -*- code +main='(module-ref (resolve-module '\''(scripts PROGRAM)) '\'main')' +exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" +!# +;;; PROGRAM --- Does something + +;; Copyright (C) 2001 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA + +;;; Commentary: + +;; Usage: PROGRAM [ARGS] +;; +;; PROGRAM does something. +;; +;; TODO: Write it! +;; +;; Author: J.R.Hacker + +;;; Code: + +(define-module (scripts PROGRAM) + :export (PROGRAM)) + +(define (PROGRAM . args) + #t) + +(define main PROGRAM) + +;;; PROGRAM ends here diff --git a/scripts/README b/scripts/README new file mode 100644 index 000000000..c1a3ef998 --- /dev/null +++ b/scripts/README @@ -0,0 +1,76 @@ +Overview and Usage +------------------ + +This directory contains Scheme programs, some useful in maintaining Guile. +On "make install", these programs are copied to PKGDATADIR/VERSION/scripts. + +You can invoke a program from the shell, or alternatively, load its file +as a Guile Scheme module, and use its exported procedure(s) from Scheme code. +Typically for any PROGRAM: + + (use-modules (scripts PROGRAM)) + (PROGRAM ARG1 ARG2 ...) + +For programs that write to stdout, you might try, instead: + + (use-modules (scripts PROGRAM)) + (with-output-to-string (lambda () (PROGRAM ARG1 ARG2 ...))) + +Note that all args must be strings. + +To see PROGRAM's commentary, which may or may not be helpful: + + (help (scripts PROGRAM)) + +To see all commentaries and module dependencies, try: "make overview". + +If you want to try the programs before installing Guile, you will probably +need to set environment variable GUILE_LOAD_PATH to be the parent directory. +This can be done in Bourne-compatible shells like so: + + GUILE_LOAD_PATH=`(cd .. ; pwd)` + export GUILE_LOAD_PATH + +[FIXME: Can someone supply the csh-compatible equivalent?] + + + +How to Contribute +----------------- + +See template file PROGRAM for a quick start. + +Programs must follow the "executable module" convention, documented here: + +- The file name must not end in ".scm". + +- The file must be executable (chmod +x). + +- The module name must be "(scripts PROGRAM)". A procedure named PROGRAM w/ + signature "(PROGRAM . args)" must be exported. Basically, use some variant + of the form: + + (define-module (scripts PROGRAM) + :export (PROGRAM)) + + Feel free to export other definitions useful in the module context. + +- There must be the alias: + + (define main PROGRAM) + + However, `main' must NOT be exported. + +- The beginning of the file must use the following invocation sequence: + + #!/bin/sh + main='(module-ref (resolve-module '\''(scripts PROGRAM)) '\'main')' + exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" + !# + +Following these conventions allows the program file to be used as module +(scripts PROGRAM) in addition to as a standalone executable. Please also +include a helpful Commentary section w/ some usage info. + + +[README ends here] diff --git a/scripts/display-commentary b/scripts/display-commentary new file mode 100755 index 000000000..537ef2ca8 --- /dev/null +++ b/scripts/display-commentary @@ -0,0 +1,47 @@ +#!/bin/sh +# aside from this initial boilerplate, this is actually -*- scheme -*- code +main='(module-ref (resolve-module '\''(scripts display-commentary)) '\'main')' +exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" +!# +;;; display-commentary --- As advertized + +;; Copyright (C) 2001 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA + +;;; Commentary: + +;; Usage: display-commentary FILE1 FILE2 ... +;; +;; Display Commentary section from FILE1, FILE2 and so on. +;; +;; Author: Thien-Thi Nguyen + +;;; Code: + +(define-module (scripts display-commentary) + :use-module (ice-9 documentation) + :export (display-commentary)) + +(define (display-commentary-one file) + (format #t "~A commentary:\n~A" file (file-commentary file))) + +(define (display-commentary . files) + (for-each display-commentary-one files)) + +(define main display-commentary) + +;;; display-commentary ends here diff --git a/scripts/doc-snarf b/scripts/doc-snarf new file mode 100755 index 000000000..ae417c0f2 --- /dev/null +++ b/scripts/doc-snarf @@ -0,0 +1,442 @@ +#!/bin/sh +# aside from this initial boilerplate, this is actually -*- scheme -*- code +main='(module-ref (resolve-module '\''(scripts doc-snarf)) '\'main')' +exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" +!# +;;; doc-snarf --- Extract documentation from source files + +;; Copyright (C) 2001 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA + +;;; Commentary: + +;; Usage: doc-snarf FILE +;; +;; This program reads in a Scheme source file and extracts docstrings +;; in the format specified below. Additionally, a procedure protoype +;; is infered from the procedure definition line starting with +;; (define... ). +;; +;; Currently, two output modi are implemented: texinfo and plaintext. +;; Default is plaintext, texinfo can be switched on with the +;; `--texinfo, -t' command line option. +;; +;; Format: A docstring can span multiple lines and a docstring line +;; begins with `;; ' (two semicoli and a space). A docstring is ended +;; by either a line beginning with (define ...) or one or more lines +;; beginning with `;;-' (two semicoli and a dash). These lines are +;; called `options' and begin with a keyword, followed by a colon and +;; a string. +;; +;; Additionally, "standard internal docstrings" (for Scheme source) are +;; recognized and output as "options". The output formatting is likely +;; to change in the future. +;; +;; Example: + +;; This procedure foos, or bars, depending on the argument @var{braz}. +;;-Author: Martin Grabmueller +(define (foo/bar braz) + (if braz 'foo 'bar)) + +;;; Which results in the following docstring if texinfo output is +;;; enabled: +#! + foo/bar +@deffn procedure foo/bar braz +This procedure foos, or bars, depending on the argument @var{braz}. +@c Author: Martin Grabmueller +@end deffn +!# + +;;; Or in this if plaintext output is used: +#! +Procedure: foo/bar braz +This procedure foos, or bars, depending on the argument @var{braz}. +;; Author: Martin Grabmueller +^L +!# + +;; TODO: Convert option lines to alist. +;; More parameterization. +;; ../libguile/guile-doc-snarf emulation + +;;; Author: Martin Grabmueller + +(define doc-snarf-version "0.0.2") ; please update before publishing! + +;;; Code: + +(define-module (scripts doc-snarf) + :use-module (ice-9 getopt-long) + :use-module (ice-9 regex) + :use-module (ice-9 string-fun) + :use-module (ice-9 rdelim) + :export (doc-snarf)) + +(define command-synopsis + '((version (single-char #\v) (value #f)) + (help (single-char #\h) (value #f)) + (output (single-char #\o) (value #t)) + (texinfo (single-char #\t) (value #f)) + (lang (single-char #\l) (value #t)))) + +;; Display version information and exit. +;;-ttn-mod: use var +(define (display-version) + (display "doc-snarf ") (display doc-snarf-version) (newline)) + +;; Display the usage help message and exit. +;;-ttn-mod: change option "source" to "lang" +(define (display-help) + (display "Usage: doc-snarf [options...] inputfile\n") + (display " --help, -h Show this usage information\n") + (display " --version, -v Show version information\n") + (display + " --output=FILE, -o Specify output file [default=stdout]\n") + (display " --texinfo, -t Format output as texinfo\n") + (display " --lang=[c,scheme], -l Specify the input language\n")) + +;; Main program. +;;-ttn-mod: canonicalize lang +(define (doc-snarf . args) + (let ((options (getopt-long (cons "doc-snarf" args) command-synopsis))) + (let ((help-wanted (option-ref options 'help #f)) + (version-wanted (option-ref options 'version #f)) + (texinfo-wanted (option-ref options 'texinfo #f)) + (lang (string->symbol + (string-downcase (option-ref options 'lang "scheme"))))) + (cond + (version-wanted (display-version)) + (help-wanted (display-help)) + (else + (let ((input (option-ref options '() #f)) + (output (option-ref options 'output #f))) + (if + ;; Bonard B. Timmons III says `(pair? input)' alone is sufficient. + ;; (and input (pair? input)) + (pair? input) + (snarf-file (car input) output texinfo-wanted lang) + (display-help)))))))) + +(define main doc-snarf) + +;; Supported languages and their parameters. Each element has form: +;; (LANG DOC-START DOC-END DOC-PREFIX OPT-PREFIX SIG-START STD-INT-DOC?) +;; LANG is a symbol, STD-INT-DOC? is a boolean indicating whether or not +;; LANG supports "standard internal docstring" (a string after the formals), +;; everything else is a string specifying a regexp. +;;-ttn-mod: new var +(define supported-languages + '((c + "^/\\*(.*)" + "^ \\*/" + "^ \\* (.*)" + "^ \\*-(.*)" + "NOTHING AT THIS TIME!!!" + #f + ) + (scheme + "^;; (.*)" + "^;;\\." + "^;; (.*)" + "^;;-(.*)" + "^\\(define" + #t + ))) + +;; Get @var{lang}'s @var{parameter}. Both args are symbols. +;;-ttn-mod: new proc +(define (lang-parm lang parm) + (list-ref (assq-ref supported-languages lang) + (case parm + ((docstring-start) 0) + ((docstring-end) 1) + ((docstring-prefix) 2) + ((option-prefix) 3) + ((signature-start) 4) + ((std-int-doc?) 5)))) + +;; Snarf all docstrings from the file @var{input} and write them to +;; file @var{output}. Use texinfo format for the output if +;; @var{texinfo?} is true. +;;-ttn-mod: don't use string comparison, consult table instead +(define (snarf-file input output texinfo? lang) + (or (memq lang (map car supported-languages)) + (error "doc-snarf: input language must be c or scheme.")) + (write-output (snarf input lang) output + (if texinfo? format-texinfo format-plain))) + +;; fixme: this comment is required to trigger standard internal +;; docstring snarfing... ideally, it wouldn't be necessary. +;;-ttn-mod: new proc, from snarf-docs (aren't these names fun?) +(define (find-std-int-doc line input-port) + "Unread @var{line} from @var{input-port}, then read in the entire form and +return the standard internal docstring if found. Return #f if not." + (unread-string line input-port) ; ugh + (let ((form (read input-port))) + (cond ((and (list? form) ; (define (PROC ARGS) "DOC" ...) + (< 3 (length form)) + (eq? 'define (car form)) + (pair? (cadr form)) + (symbol? (caadr form)) + (string? (caddr form))) + (caddr form)) + ((and (list? form) ; (define VAR (lambda ARGS "DOC" ...)) + (< 2 (length form)) + (eq? 'define (car form)) + (symbol? (cadr form)) + (list? (caddr form)) + (< 3 (length (caddr form))) + (eq? 'lambda (car (caddr form))) + (string? (caddr (caddr form)))) + (caddr (caddr form))) + (else #f)))) + +;; Split @var{string} into lines, adding @var{prefix} to each. +;;-ttn-mod: new proc +(define (split-prefixed string prefix) + (separate-fields-discarding-char + #\newline string + (lambda lines + (map (lambda (line) + (string-append prefix line)) + lines)))) + +;; snarf input-file output-file +;; Extract docstrings from the input file @var{input}, presumed +;; to be written in language @var{lang}. +;;-Author: Martin Grabmueller +;;-Created: 2001-02-17 +;;-ttn-mod: regluarize lang parm lookup, add "std int doc" snarfing (2 places) +(define (snarf input-file lang) + (let* ((i-p (open-input-file input-file)) + (parm-regexp (lambda (parm) (make-regexp (lang-parm lang parm)))) + (docstring-start (parm-regexp 'docstring-start)) + (docstring-end (parm-regexp 'docstring-end)) + (docstring-prefix (parm-regexp 'docstring-prefix)) + (option-prefix (parm-regexp 'option-prefix)) + (signature-start (parm-regexp 'signature-start)) + (augmented-options + (lambda (line i-p options) + (let ((int-doc (and (lang-parm lang 'std-int-doc?) + (let ((d (find-std-int-doc line i-p))) + (and d (split-prefixed d "internal: ")))))) + (if int-doc + (append (reverse int-doc) options) + options))))) + + (let lp ((line (read-line i-p)) (state 'neutral) (doc-strings '()) + (options '()) (entries '()) (lno 0)) + (cond + ((eof-object? line) + (close-input-port i-p) + (reverse entries)) + + ;; State 'neutral: we're currently not within a docstring or + ;; option section + ((eq? state 'neutral) + (let ((m (regexp-exec docstring-start line))) + (if m + (lp (read-line i-p) 'doc-string + (list (match:substring m 1)) '() entries (+ lno 1)) + (lp (read-line i-p) state '() '() entries (+ lno 1))))) + + ;; State 'doc-string: we have started reading a docstring and + ;; are waiting for more, for options or for a define. + ((eq? state 'doc-string) + (let ((m0 (regexp-exec docstring-prefix line)) + (m1 (regexp-exec option-prefix line)) + (m2 (regexp-exec signature-start line)) + (m3 (regexp-exec docstring-end line))) + (cond + (m0 + (lp (read-line i-p) 'doc-string + (cons (match:substring m0 1) doc-strings) '() entries + (+ lno 1))) + (m1 + (lp (read-line i-p) 'options + doc-strings (cons (match:substring m1 1) options) entries + (+ lno 1))) + (m2 + (let ((options (augmented-options line i-p options))) ; ttn-mod + (lp (read-line i-p) 'neutral '() '() + (cons (parse-entry doc-strings options line input-file lno) + entries) + (+ lno 1)))) + (m3 + (lp (read-line i-p) 'neutral '() '() + (cons (parse-entry doc-strings options #f input-file lno) + entries) + (+ lno 1))) + (else + (lp (read-line i-p) 'neutral '() '() entries (+ lno 1)))))) + + ;; State 'options: We're waiting for more options or for a + ;; define. + ((eq? state 'options) + (let ((m1 (regexp-exec option-prefix line)) + (m2 (regexp-exec signature-start line)) + (m3 (regexp-exec docstring-end line))) + (cond + (m1 + (lp (read-line i-p) 'options + doc-strings (cons (match:substring m1 1) options) entries + (+ lno 1))) + (m2 + (let ((options (augmented-options line i-p options))) ; ttn-mod + (lp (read-line i-p) 'neutral '() '() + (cons (parse-entry doc-strings options line input-file lno) + entries) + (+ lno 1)))) + (m3 + (lp (read-line i-p) 'neutral '() '() + (cons (parse-entry doc-strings options #f input-file lno) + entries) + (+ lno 1))) + (else + (lp (read-line i-p) 'neutral '() '() entries (+ lno 1)))))))))) + +(define (make-entry symbol signature docstrings options filename line) + (vector 'entry symbol signature docstrings options filename line)) +(define (entry-symbol e) + (vector-ref e 1)) +(define (entry-signature e) + (vector-ref e 2)) +(define (entry-docstrings e) + (vector-ref e 3)) +(define (entry-options e) + (vector-ref e 4)) +(define (entry-filename e) + (vector-ref e 5)) +(define (entry-line e) + "This docstring will not be snarfed, unfortunately..." + (vector-ref e 6)) + +;; Create a docstring entry from the docstring line list +;; @var{doc-strings}, the option line list @var{options} and the +;; define line @var{def-line} +(define (parse-entry docstrings options def-line filename line-no) +; (write-line docstrings) + (cond + (def-line + (make-entry (get-symbol def-line) + (make-prototype def-line) (reverse docstrings) + (reverse options) filename + (+ (- line-no (length docstrings) (length options)) 1))) + ((> (length docstrings) 0) + (make-entry (string->symbol (car (reverse docstrings))) + (car (reverse docstrings)) + (cdr (reverse docstrings)) + (reverse options) filename + (+ (- line-no (length docstrings) (length options)) 1))) + (else + (make-entry 'foo "" (reverse docstrings) (reverse options) filename + (+ (- line-no (length docstrings) (length options)) 1))))) + +;; Create a string which is a procedure prototype. The necessary +;; information for constructing the prototype is taken from the line +;; @var{def-line}, which is a line starting with @code{(define...}. +(define (make-prototype def-line) + (call-with-input-string + def-line + (lambda (s-p) + (let* ((paren (read-char s-p)) + (keyword (read s-p)) + (tmp (read s-p))) + (cond + ((pair? tmp) + (join-symbols tmp)) + ((symbol? tmp) + (symbol->string tmp)) + (else + "")))))) + +(define (get-symbol def-line) + (call-with-input-string + def-line + (lambda (s-p) + (let* ((paren (read-char s-p)) + (keyword (read s-p)) + (tmp (read s-p))) + (cond + ((pair? tmp) + (car tmp)) + ((symbol? tmp) + tmp) + (else + 'foo)))))) + +;; Append the symbols in the string list @var{s}, separated with a +;; space character. +(define (join-symbols s) + (cond ((null? s) + "") + ((symbol? s) + (string-append ". " (symbol->string s))) + ((null? (cdr s)) + (symbol->string (car s))) + (else + (string-append (symbol->string (car s)) " " (join-symbols (cdr s)))))) + +;; Write @var{entries} to @var{output-file} using @var{writer}. +;; @var{writer} is a proc that takes one entry. +;; If @var{output-file} is #f, write to stdout. +;;-ttn-mod: new proc +(define (write-output entries output-file writer) + (with-output-to-port (cond (output-file (open-output-file output-file)) + (else (current-output-port))) + (lambda () (for-each writer entries)))) + +;; Write an @var{entry} using texinfo format. +;;-ttn-mod: renamed from `texinfo-output', distilled +(define (format-texinfo entry) + (display "\n\f") + (display (entry-symbol entry)) + (newline) + (display "@c snarfed from ") + (display (entry-filename entry)) + (display ":") + (display (entry-line entry)) + (newline) + (display "@deffn procedure ") + (display (entry-signature entry)) + (newline) + (for-each (lambda (s) (write-line s)) + (entry-docstrings entry)) + (for-each (lambda (s) (display "@c ") (write-line s)) + (entry-options entry)) + (write-line "@end deffn")) + +;; Write an @var{entry} using plain format. +;;-ttn-mod: renamed from `texinfo-output', distilled +(define (format-plain entry) + (display "Procedure: ") + (display (entry-signature entry)) + (newline) + (for-each (lambda (s) (write-line s)) + (entry-docstrings entry)) + (for-each (lambda (s) (display ";; ") (write-line s)) + (entry-options entry)) + (display "Snarfed from ") + (display (entry-filename entry)) + (display ":") + (display (entry-line entry)) + (newline) + (write-line "\f")) + +;;; doc-snarf ends here diff --git a/scripts/generate-autoload b/scripts/generate-autoload new file mode 100755 index 000000000..523b6049d --- /dev/null +++ b/scripts/generate-autoload @@ -0,0 +1,138 @@ +#!/bin/sh +# aside from this initial boilerplate, this is actually -*- scheme -*- code +main='(module-ref (resolve-module '\''(scripts generate-autoload)) '\'main')' +exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" +!# +;;; generate-autoload --- Display define-module form with autoload info + +;; Copyright (C) 2001 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA + +;;; Commentary: + +;; Usage: generate-autoload [OPTIONS] FILE1 FILE2 ... +;; +;; The autoload form is displayed to standard output: +;; +;; (define-module (guile-user) +;; :autoload (ZAR FOO) (FOO-1 FOO-2 ...) +;; : +;; : +;; :autoload (ZAR BAR) (BAR-1 BAR-2 ...)) +;; +;; For each file, a symbol triggers an autoload if it is found in one +;; of these situations: +;; - in the `:export' clause of a `define-module' form; +;; - in a top-level `export' or `export-syntax' form; +;; - in a `define-public' form. +;; +;; The module name is inferred from the `define-module' form. If either the +;; module name or the exports list cannot be determined, no autoload entry is +;; generated for that file. +;; +;; Options: +;; --target MODULE-NAME -- Use MODULE-NAME instead of `(guile-user)'. +;; Note that some shells may require you to +;; quote the argument to handle parentheses +;; and spaces. +;; +;; Usage examples from Scheme code as a module: +;; (use-modules (scripts generate-autoload)) +;; (generate-autoload "generate-autoload") +;; (generate-autoload "--target" "(my module)" "generate-autoload") +;; (apply generate-autoload "--target" "(my module)" '("foo" "bar" "baz")) +;; +;; Author: Thien-Thi Nguyen + +;;; Code: + +(define-module (scripts generate-autoload) + :export (generate-autoload)) + +(define (autoload-info file) + (let ((p (open-input-file file))) + (let loop ((form (read p)) (module-name #f) (exports '())) + (if (eof-object? form) + (and module-name + (not (null? exports)) + (list module-name exports)) ; ret + (cond ((and (list? form) + (< 1 (length form)) + (eq? 'define-module (car form))) + (loop (read p) + (cadr form) + (cond ((member ':export form) + => (lambda (val) + (append (cadr val) exports))) + (else exports)))) + ((and (list? form) + (< 1 (length form)) + (memq (car form) '(export export-syntax))) + (loop (read p) + module-name + (append (cdr form) exports))) + ((and (list? form) + (< 2 (length form)) + (eq? 'define-public (car form)) + (list? (cadr form)) + (symbol? (caadr form))) + (loop (read p) + module-name + (cons (caadr form) exports))) + ((and (list? form) + (< 2 (length form)) + (eq? 'define-public (car form)) + (symbol? (cadr form))) + (loop (read p) + module-name + (cons (cadr form) exports))) + (else (loop (read p) module-name exports))))))) + +(define (generate-autoload . args) + (let* ((module-count 0) + (syms-count 0) + (target-override (cond ((member "--target" args) => cadr) + (else #f))) + (files (if target-override (cddr args) (cdr args)))) + (display ";;; do not edit --- generated ") + (display (strftime "%Y-%m-%d %H:%M:%S" (localtime (current-time)))) + (newline) + (display "(define-module ") + (display (or target-override "(guile-user)")) + (for-each (lambda (file) + (cond ((autoload-info file) + => (lambda (info) + (and info + (apply (lambda (module-name exports) + (set! module-count (1+ module-count)) + (set! syms-count (+ (length exports) + syms-count)) + (for-each display + (list "\n :autoload " + module-name " " + exports))) + info)))))) + files) + (display ")") + (newline) + (for-each display (list " ;;; " + syms-count " symbols in " + module-count " modules\n")))) + +(define main generate-autoload) + +;;; generate-autoload ends here diff --git a/scripts/punify b/scripts/punify new file mode 100755 index 000000000..e5b0f9d78 --- /dev/null +++ b/scripts/punify @@ -0,0 +1,81 @@ +#!/bin/sh +# aside from this initial boilerplate, this is actually -*- scheme -*- code +main='(module-ref (resolve-module '\''(scripts punify)) '\'main')' +exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" +!# +;;; punify --- Display Scheme code w/o unnecessary comments / whitespace + +;; Copyright (C) 2001 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA + +;;; Commentary: + +;; Usage: punify FILE1 FILE2 ... +;; +;; Each file's forms are read and written to stdout. +;; The effect is to remove comments and much non-essential whitespace. +;; This is useful when installing Scheme source to space-limited media. +;; +;; Example: +;; $ wc ./punify ; ./punify ./punify | wc +;; 81 355 2622 ./punify +;; 0 34 694 +;; +;; TODO: Read from stdin. +;; Handle vectors. +;; Identifier punification. +;; +;; Author: Thien-Thi Nguyen + +;;; Code: + +(define-module (scripts punify) + :export (punify)) + +(define (write-punily form) + (if (and (list? form) (not (null? form))) + (let ((first (car form))) + (display "(") + (write-punily first) + (let loop ((ls (cdr form)) (last-was-list? (list? first))) + (if (null? ls) + (display ")") + (let* ((new-first (car ls)) + (this-is-list? (list? new-first))) + (and (not last-was-list?) + (not this-is-list?) + (display " ")) + (write-punily new-first) + (loop (cdr ls) this-is-list?))))) + (write form))) + +(define (punify-one file) + (with-input-from-file file + (lambda () + (let ((toke (lambda () (read (current-input-port))))) + (let loop ((form (toke))) + (or (eof-object? form) + (begin + (write-punily form) + (loop (toke))))))))) + +(define (punify . args) + (for-each punify-one args)) + +(define main punify) + +;;; punify ends here diff --git a/scripts/use2dot b/scripts/use2dot new file mode 100755 index 000000000..1b59519ae --- /dev/null +++ b/scripts/use2dot @@ -0,0 +1,166 @@ +#!/bin/sh +# aside from this initial boilerplate, this is actually -*- scheme -*- code +main='(module-ref (resolve-module '\''(scripts use2dot)) '\'main')' +exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" +!# +;;; use2dot --- Display module dependencies as a DOT specification + +;; Copyright (C) 2001 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA + +;;; Commentary: + +;; Usage: use2dot [OPTIONS] [FILE ...] +;; Display to stdout a DOT specification that describes module dependencies +;; in FILEs. +;; +;; A top-level `use-modules' form or a `:use-module' `define-module'-component +;; results in a "solid" style edge. +;; +;; An `:autoload' `define-module'-component results in a "dotted" style edge +;; with label "N" indicating that N names are responsible for triggering the +;; autoload. +;; +;; A top-level `load' or `primitive-load' form results in a a "bold" style +;; edge to a node named with either the file name if the `load' argument is a +;; string, or "[computed in FILE]" otherwise. +;; +;; Options: +;; --default-module MOD -- Set MOD as the default module (for top-level +;; `use-modules' forms that do not follow some +;; `define-module' form in a file). MOD should be +;; be a list or `#f', in which case such top-level +;; `use-modules' forms are effectively ignored. +;; Default value: `(guile)'. +;; +;; TODO +;; - add `--load-synonyms' option +;; - add `--ignore-module' option +;; - handle arbitrary command-line key/value configuration +;; +;; Author: Thien-Thi Nguyen based on PERL script by Keisuke Nishida + +;;; Code: + +(define-module (scripts use2dot) + :use-module (ice-9 regex)) + +(define (string-append/separator separator strings) + ;; from (ttn stringutils) -- todo: use srfi-13 + ;; "Append w/ SEPARATOR a list of STRINGS. + ;; SEPARATOR can be a character or a string." + (let ((rev (reverse strings)) + (sep (if (char? separator) + (make-string 1 separator) + separator))) + (apply string-append + (let loop ((s (cdr rev)) + (acc (list (car rev)))) + (if (null? s) + acc + (loop (cdr s) + (cons (car s) + (cons sep acc)))))))) + +(define (mapconcat proc ls sep) + ;; from (ttn stringutils) -- todo: use srfi-13 + ;; "Map PROC over LS, concatening resulting strings with separator SEP." + (string-append/separator sep (map proc ls))) + +(define default-module '(guile)) + +(define (q s) ; quote + (format #f "~S" s)) + +(define (vv pair) ; var=val + (format #f "~A=~A" (car pair) (cdr pair))) + +(define (spew module use . etc) + (and module + (let ((etc-spec (if (null? etc) + "" + (format #f " [~A]" (mapconcat vv etc ","))))) + (format #t " \"~A\" -> \"~A\"~A;\n" module use etc-spec)))) + +(define (header) + (format #t "digraph use2dot {") + (for-each (lambda (s) (format #t " ~A;\n" s)) + (map vv `((label . ,(q "Guile Module Dependencies")) + ;(rankdir . LR) + ;(size . ,(q "7.5,10")) + (ratio . fill) + ;(nodesep . ,(q "0.05")) + )))) + +(define (grok filename) + (let* ((p (open-file filename "r")) + (next (lambda () (read p))) + (curmod #f)) + (let loop ((form (next))) + (cond ((eof-object? form)) + ((not (list? form)) (loop (next))) + (else (case (car form) + ((define-module) + (let ((module (cadr form))) + (set! curmod module) + (let loop ((ls form)) + (or (null? ls) + (case (car ls) + ((:use-module) + (spew module (cadr ls)) + (loop (cddr ls))) + ((:autoload) + (spew module (cadr ls) + '(style . dotted) + '(fontsize . 5) + (let ((len (length (caddr ls)))) + `(label . ,(q (number->string len))))) + (loop (cdddr ls))) + (else (loop (cdr ls)))))))) + ((use-modules) + (for-each (lambda (use) + (spew (or curmod default-module) use)) + (cdr form))) + ((load primitive-load) + (spew (or curmod default-module) + (let ((file (cadr form))) + (if (string? file) + file + (format #f "[computed in ~A]" filename))) + '(style . bold)))) + (loop (next))))))) + +(define (body files) + (for-each grok files)) + +(define (footer) + (format #t "}")) + +(define (use2dot . args) + (header) + (let* ((override (cond ((member "--default-module" args) => cadr) + (else #f))) + (files (if override (cddr args) args))) + (and override + (set! default-module + (with-input-from-string override (lambda () (read))))) + (body files)) + (footer)) + +(define main use2dot) + +;;; use2dot ends here From 14353f06e0b64ce7f107e33148d4052cb7e5b0e9 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 30 Apr 2001 01:42:14 +0000 Subject: [PATCH 0953/2047] (SUBDIRS): Add "scripts". --- Makefile.am | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/Makefile.am b/Makefile.am index 8b3a17f3a..21cb5f833 100644 --- a/Makefile.am +++ b/Makefile.am @@ -3,23 +3,24 @@ ## Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. ## ## This file is part of GUILE. -## +## ## GUILE 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, or ## (at your option) any later version. -## +## ## GUILE 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 GUILE; see the file COPYING. If not, write ## to the Free Software Foundation, Inc., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA -SUBDIRS = ice-9 oop qt libltdl libguile guile-config guile-readline srfi doc +SUBDIRS = ice-9 oop qt libltdl libguile guile-config guile-readline \ + scripts srfi doc include_HEADERS = libguile.h From 5546a30117f2a33e93b2d8aaa5b116f46dba30b7 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 30 Apr 2001 01:44:25 +0000 Subject: [PATCH 0954/2047] (AC_OUTPUT): Add scripts/Makefile. --- configure.in | 1 + 1 file changed, 1 insertion(+) diff --git a/configure.in b/configure.in index abf76d111..b7897b452 100644 --- a/configure.in +++ b/configure.in @@ -561,6 +561,7 @@ AC_OUTPUT([Makefile ice-9/Makefile oop/Makefile oop/goops/Makefile + scripts/Makefile srfi/Makefile qt/Makefile qt/qt.h From 14a7d5f84bed0b350495e718e02c7e8ad1be6bb1 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 30 Apr 2001 01:47:16 +0000 Subject: [PATCH 0955/2047] *** empty log message *** --- ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/ChangeLog b/ChangeLog index 8f728e564..b933f9726 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2001-04-29 Thien-Thi Nguyen + + * Makefile.am (SUBDIRS): Add "scripts". + + * configure.in (AC_OUTPUT): Add scripts/Makefile. + 2001-04-29 Gary Houston * libguile.h: include rw.h. From 466bb4b35006d48011016b338afb80b0d13a9eb2 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 30 Apr 2001 01:52:58 +0000 Subject: [PATCH 0956/2047] *** empty log message *** --- NEWS | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index 9a0b7cb78..7f6aa8469 100644 --- a/NEWS +++ b/NEWS @@ -29,7 +29,7 @@ Changes since Guile 1.4: tag - no replacement. fseek - replaced by seek. - list* - replaced by cons*. + list* - replaced by cons*. ** New SRFI modules have been added: @@ -49,6 +49,19 @@ Changes since Guile 1.4: (srfi srfi-14) implements the SRFI Character-Set Library. +** New scripts / "executable modules" + +Subdirectory "scripts" contains Scheme modules that are packaged to +also be executable as scripts. At this time, these scripts are available: + + display-commentary + doc-snarf + generate-autoload + punify + use2dot + +See README there for more info. + ** New module (ice-9 stack-catch): stack-catch is like catch, but saves the current state of the stack in From e200c20fa0f6d1514256c6ccdca5fe452dc030e5 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Tue, 1 May 2001 21:05:44 +0000 Subject: [PATCH 0957/2047] * scheme-io.texi: Removed obsolete section Binary IO. Added new section Block Reading and Writing. Updated section Line/Delimited with module usage. --- doc/ChangeLog | 6 +++++ doc/scheme-io.texi | 62 +++++++++++++++++++--------------------------- 2 files changed, 32 insertions(+), 36 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index dd041c2bd..6072aabd8 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,9 @@ +2001-05-01 Gary Houston + + * scheme-io.texi: Removed obsolete section Binary IO. Added + new section Block Reading and Writing. Updated section + Line/Delimited with module usage. + 2001-04-29 Neil Jerram * deprecated.texi (Tags): Removed - deprecation expired. diff --git a/doc/scheme-io.texi b/doc/scheme-io.texi index cc7b4b848..02cf8a864 100644 --- a/doc/scheme-io.texi +++ b/doc/scheme-io.texi @@ -9,7 +9,7 @@ * Closing:: Procedures to close a port. * Random Access:: Moving around a random access port. * Line/Delimited:: Read and write lines or delimited text. -* Binary IO:: Save and restore Scheme objects. +* Block Reading and Writing:: Reading and writing blocks of text. * Default Ports:: Defaults for input, output and errors. * Port Types:: Types of port and how to make them. @end menu @@ -323,23 +323,21 @@ in which case the truncation occurs at the current port. position. The return value is unspecified. @end deffn - @node Line/Delimited -@section Handling Line Oriented and Delimited Text +@section Line Oriented and Delimited Text -[Line-oriented and delimited IO. Or should this be merged into the -previous two sections?] +The delimited-I/O module can be accessed with: -Extended I/O procedures are available which read or write lines of text -or read text delimited by a specified set of characters. +@smalllisp +(use-modules (ice-9 rdelim)) +@end smalllisp -@findex fwrite -@findex fread -Interfaces to @code{read}/@code{fread} and @code{write}/@code{fwrite} are -also available, as @code{uniform-array-read!} and @code{uniform-array-write!}, -@ref{Uniform Arrays}. +It can be used to read or write lines of text, or read text delimited by +a specified set of characters. It's similar to the @code{(scsh rdelim)} +module from guile-scsh, but does not use multiple values or character +sets and has an extra procedure @code{write-line}. -@c begin (scm-doc-string "boot-9.scm" "read-line") +@c begin (scm-doc-string "rdelim.scm" "read-line") @deffn procedure read-line [port] [handle-delim] Return a line of text from @var{port} if specified, otherwise from the value returned by @code{(current-input-port)}. Under Unix, a line of text @@ -359,13 +357,10 @@ Push the terminating delimiter (if any) back on to the port. @item split Return a pair containing the string read from the port and the terminating delimiter or end-of-file object. - -NOTE: if the scsh module is loaded then -multiple values are returned instead of a pair. @end table @end deffn -@c begin (scm-doc-string "boot-9.scm" "read-line!") +@c begin (scm-doc-string "rdelim.scm" "read-line!") @deffn procedure read-line! buf [port] Read a line of text into the supplied string @var{buf} and return the number of characters added to @var{buf}. If @var{buf} is filled, then @@ -374,18 +369,15 @@ Read from @var{port} if specified, otherwise from the value returned by @code{(current-input-port)}. @end deffn -@c begin (scm-doc-string "boot-9.scm" "read-delimited") +@c begin (scm-doc-string "rdelim.scm" "read-delimited") @deffn procedure read-delimited delims [port] [handle-delim] Read text until one of the characters in the string @var{delims} is found or end-of-file is reached. Read from @var{port} if supplied, otherwise from the value returned by @code{(current-input-port)}. @var{handle-delim} takes the same values as described for @code{read-line}. - -NOTE: if the scsh module is loaded then @var{delims} must be an scsh -char-set, not a string. @end deffn -@c begin (scm-doc-string "boot-9.scm" "read-delimited!") +@c begin (scm-doc-string "rdelim.scm" "read-delimited!") @deffn procedure read-delimited! delims buf [port] [handle-delim] [start] [end] Read text into the supplied string @var{buf} and return the number of characters added to @var{buf} (subject to @var{handle-delim}, which takes @@ -395,9 +387,6 @@ delimiter. Also terminates if one of the characters in the string @var{delims} is found or end-of-file is reached. Read from @var{port} if supplied, otherwise from the value returned by @code{(current-input-port)}. - -NOTE: if the scsh module is loaded then @var{delims} must be an scsh -char-set, not a string. @end deffn @deffn primitive write-line obj [port] @@ -440,20 +429,21 @@ delimiter may be either a newline or the @var{eof-object}; if @code{(# . #)}. @end deffn -@node Binary IO -@section Saving and Restoring Scheme Objects +@node Block reading and writing +@section Block reading and writing -@deffn primitive binary-read [port] -Read and return an object from @var{port} in a binary format. -If omitted, @var{port} defaults to the current output port. +The Block-string-I/O module can be accessed with: + +@smalllisp +(use-modules (ice-9 rw)) +@end smalllisp + +It currently contains a single procedure which helps implement +the @code{(scsh rw)} module in guile-scsh. + +@deffn primitive read-string!/partial str [port_or_fdes] [start] [end] @end deffn -@deffn primitive binary-write obj [port] -Write @var{obj} to @var{port} in a binary format. -If omitted, @var{port} defaults to the current output port. -@end deffn - - @node Default Ports @section Default Ports for Input, Output and Errors From 1464aae01fd816268e7e738ff5af61f80393f3f3 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 2 May 2001 00:43:01 +0000 Subject: [PATCH 0958/2047] * gh.h (gh_init_guile, gh_make_string, gh_string_length, gh_string_ref, gh_string_set_x, gh_substring, gh_string_append): New. --- libguile/gh.h | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/libguile/gh.h b/libguile/gh.h index b2b5289ab..7afd5048d 100644 --- a/libguile/gh.h +++ b/libguile/gh.h @@ -59,6 +59,7 @@ extern "C" { #endif /* __GNUC__ */ void gh_enter(int argc, char *argv[], void (*c_main_prog)(int, char **)); +#define gh_init () scm_init_guile () void gh_repl(int argc, char *argv[]); SCM gh_catch(SCM tag, scm_catch_body_t body, void *body_data, scm_catch_handler_t handler, void *handler_data); @@ -159,6 +160,15 @@ int gh_null_p(SCM l); SCM gh_define(const char *name, SCM val); +/* string manipulation routines */ +#define gh_make_string(k, chr) scm_make_string(k, chr) +#define gh_string_length(str) scm_string_length(str) +#define gh_string_ref(str, k) scm_string_ref(str, k) +#define gh_string_set_x(str, k, chr) scm_string_set_x(str, k, chr) +#define gh_substring(str, start,end) scm_substring(str, start, end) +#define gh_string_append(args) scm_string_append(args) + + /* vector manipulation routines */ /* note that gh_vector() does not behave quite like the Scheme (vector obj1 obj2 ...), because the interpreter engine does not pass the From 7e51628821072e86da259ca3bb80b53d78c1677f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 2 May 2001 00:45:45 +0000 Subject: [PATCH 0959/2047] * deprecation.h, deprecation.c: New. * Makefile.am (libguile_la_SOURCES): Added "deprecation.c". (DOT_X_FILES): Added "deprecation.x". (modinclude_HEADERS): Added "deprecation.h". --- libguile/Makefile.am | 25 +++---- libguile/deprecation.c | 159 +++++++++++++++++++++++++++++++++++++++++ libguile/deprecation.h | 67 +++++++++++++++++ 3 files changed, 239 insertions(+), 12 deletions(-) create mode 100644 libguile/deprecation.c create mode 100644 libguile/deprecation.h diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 4bd6aa12e..caa46ff15 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -39,7 +39,7 @@ guile_LDADD = libguile.la ${THREAD_LIBS_LOCAL} guile_LDFLAGS = @DLPREOPEN@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ - chars.c continuations.c debug.c dynl.c dynwind.c \ + chars.c continuations.c debug.c deprecation.c dynl.c dynwind.c \ environments.c eq.c error.c eval.c evalext.c feature.c fluids.c fports.c \ gc.c gc_os_dep.c gdbint.c gh_data.c gh_eval.c gh_funcs.c gh_init.c \ gh_io.c gh_list.c gh_predicates.c goops.c gsubr.c guardians.c hash.c \ @@ -51,16 +51,17 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ strorder.c strports.c struct.c symbols.c tag.c throw.c values.c \ variable.c vectors.c version.c vports.c weaks.c -DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ - continuations.x debug.x dynl.x dynwind.x environments.x eq.x \ - error.x eval.x evalext.x feature.x fluids.x fports.x gc.x goops.x \ - gsubr.x guardians.x hash.x hashtab.x hooks.x init.x ioext.x iselect.x \ - keywords.x lang.x list.x load.x macros.x mallocs.x modules.x \ - numbers.x objects.x objprop.x options.x pairs.x ports.x print.x \ - procprop.x procs.x properties.x random.x rdelim.x read.x root.x rw.x \ - scmsigs.x script.x simpos.x smob.x sort.x srcprop.x \ - stackchk.x stacks.x stime.x strings.x strop.x strorder.x strports.x \ - struct.x symbols.x tag.x throw.x values.x variable.x vectors.x \ +DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ + continuations.x debug.x deprecation.x dynl.x dynwind.x \ + environments.x eq.x \ + error.x eval.x evalext.x feature.x fluids.x fports.x gc.x goops.x \ + gsubr.x guardians.x hash.x hashtab.x hooks.x init.x ioext.x iselect.x \ + keywords.x lang.x list.x load.x macros.x mallocs.x modules.x \ + numbers.x objects.x objprop.x options.x pairs.x ports.x print.x \ + procprop.x procs.x properties.x random.x rdelim.x read.x root.x rw.x \ + scmsigs.x script.x simpos.x smob.x sort.x srcprop.x \ + stackchk.x stacks.x stime.x strings.x strop.x strorder.x strports.x \ + struct.x symbols.x tag.x throw.x values.x variable.x vectors.x \ version.x vports.x weaks.x EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@ @@ -111,7 +112,7 @@ pkginclude_HEADERS = gh.h # These are headers visible as . modincludedir = $(includedir)/libguile modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h boolean.h \ - chars.h continuations.h coop-defs.h debug.h debug-malloc.h \ + chars.h continuations.h coop-defs.h debug.h debug-malloc.h deprecation.h \ dynl.h dynwind.h environments.h eq.h error.h eval.h evalext.h \ feature.h filesys.h fluids.h fports.h gc.h gdb_interface.h gdbint.h \ goops.h gsubr.h guardians.h hash.h hashtab.h hooks.h init.h ioext.h \ diff --git a/libguile/deprecation.c b/libguile/deprecation.c new file mode 100644 index 000000000..cc0a9db49 --- /dev/null +++ b/libguile/deprecation.c @@ -0,0 +1,159 @@ +/* Copyright (C) 1995,1996,1998,1999,2000,2001 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 + * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + + + +#include + +#include "libguile/_scm.h" + +#include "libguile/deprecation.h" +#include "libguile/hashtab.h" +#include "libguile/strings.h" +#include "libguile/ports.h" + + + +#if SCM_DEBUG_DEPRECATED == 0 + +/* This is either a boolean (when a summary should be printed) or a + hashtab (when detailed warnings shouold be printed). +*/ +SCM issued_msgs; + +void +scm_c_issue_deprecation_warning (const char *msg) +{ + if (SCM_BOOLP (issued_msgs)) + issued_msgs = SCM_BOOL_T; + else + scm_issue_deprecation_warning (SCM_LIST1 (scm_makfrom0str (msg))); +} + +SCM_DEFINE(scm_issue_deprecation_warning, + "issue-deprecation-warning", 0, 0, 1, + (SCM msgs), + "Output @var{msgs} to @code{(current-error-port)} when this " + "is the first call to @code{issue-deprecation-warning} with " + "this specific @var{msg}. Do nothing otherwise. " + "The argument @var{msgs} should be a list of strings; " + "they are printed in turn, each one followed by a newline.") +#define FUNC_NAME s_scm_issue_deprecation_warning +{ + if (SCM_BOOLP (issued_msgs)) + issued_msgs = SCM_BOOL_T; + else + { + SCM handle = scm_hash_create_handle_x (issued_msgs, msgs, SCM_BOOL_F); + if (SCM_CDR (handle) == SCM_BOOL_F) + { + while (SCM_CONSP (msgs)) + { + scm_display (SCM_CAR (msgs), scm_current_error_port ()); + scm_newline (scm_current_error_port ()); + msgs = SCM_CDR (msgs); + } + SCM_SETCDR (handle, SCM_BOOL_T); + } + } + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +static void +print_deprecation_summary (void) +{ + if (issued_msgs == SCM_BOOL_T) + { + fputs ("\n" + "Some deprecated features have been used. Set the environment\n" + "variable GUILE_WARN_DEPRECATED to \"detailed\" and rerun the\n" + "program to get more information. Set it to \"no\" to suppress\n" + "this message.\n", stderr); + } +} + +#endif + +SCM_DEFINE(scm_include_deprecated_features, + "include-deprecated-features", 0, 0, 0, + (), + "Return @code{#t} iff deprecated features should be included + in public interfaces.") +#define FUNC_NAME s_scm_include_deprecated_features +{ +#if SCM_DEBUG_DEPRECATED == 0 + return SCM_BOOL_T; +#else + return SCM_BOOL_F; +#endif +} +#undef FUNC_NAME + + + + +void +scm_init_deprecation () +{ +#if SCM_DEBUG_DEPRECATED == 0 + const char *level = getenv ("GUILE_WARN_DEPRECATED"); + if (level == NULL) + level = GUILE_WARN_DEPRECATED_DEFAULT; + if (!strcmp (level, "detailed")) + issued_msgs = scm_permanent_object (scm_c_make_hash_table (17)); + else if (!strcmp (level, "no")) + issued_msgs = SCM_BOOL_F; + else + { + issued_msgs = SCM_BOOL_F; + atexit (print_deprecation_summary); + } +#endif +#ifndef SCM_MAGIC_SNARFER +#include "libguile/deprecation.x" +#endif +} + +/* + Local Variables: + c-file-style: "gnu" + End: */ diff --git a/libguile/deprecation.h b/libguile/deprecation.h new file mode 100644 index 000000000..663014387 --- /dev/null +++ b/libguile/deprecation.h @@ -0,0 +1,67 @@ +/* classes: h_files */ + +#ifndef DEPRECATION_H +#define DEPRECATION_H +/* Copyright (C) 2001 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 + * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +#include "libguile/__scm.h" + + + +#if SCM_DEBUG_DEPRECATED == 0 + +void scm_c_issue_deprecation_warning (const char *msg); +SCM scm_issue_deprecation_warning (SCM msgs); + +#endif + +SCM scm_include_deprecated_features (void); + +void scm_init_deprecation (void); + +#endif /* DEPRECATION_H */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ From 388bebbc7e63aa8bb9e04f285eb47a0d3bb2a431 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 2 May 2001 00:47:50 +0000 Subject: [PATCH 0960/2047] * init.c: Include "deprecation.h". (scm_init_guile_1): Call scm_init_deprecation. --- libguile/init.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/libguile/init.c b/libguile/init.c index 99e67cdae..4feb92c2d 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -66,6 +66,7 @@ #ifdef GUILE_DEBUG_MALLOC #include "libguile/debug-malloc.h" #endif +#include "libguile/deprecation.h" #include "libguile/dynl.h" #include "libguile/dynwind.h" #include "libguile/environments.h" @@ -504,6 +505,7 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_init_gdbint (); /* Requires strports */ scm_init_hash (); scm_init_hashtab (); + scm_init_deprecation (); /* Requires hashtabs */ scm_init_objprop (); scm_init_properties (); scm_init_hooks (); /* Requires objprop until hook names are removed */ From 28280fe3a50fa480ca847be90e0299d745ffa7d7 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 2 May 2001 00:48:32 +0000 Subject: [PATCH 0961/2047] * net_db.h (scm_gethost): Added prototype. --- libguile/net_db.h | 1 + 1 file changed, 1 insertion(+) diff --git a/libguile/net_db.h b/libguile/net_db.h index f5fdeba07..56c04157f 100644 --- a/libguile/net_db.h +++ b/libguile/net_db.h @@ -51,6 +51,7 @@ +extern SCM scm_gethost (SCM host); extern SCM scm_getnet (SCM name); extern SCM scm_getproto (SCM name); extern SCM scm_getserv (SCM name, SCM proto); From fee12d1806970be7e7698f43bf084bc4e7e92a76 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 2 May 2001 00:49:11 +0000 Subject: [PATCH 0962/2047] * rw.c: Include "modules.h" and "strports.h". --- libguile/rw.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/libguile/rw.c b/libguile/rw.c index 343c28210..3acb796f2 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -52,6 +52,8 @@ #include "libguile/rw.h" #include "libguile/strings.h" #include "libguile/validate.h" +#include "libguile/modules.h" +#include "libguile/strports.h" #ifdef HAVE_UNISTD_H #include From b65e6bfee286a1504e6c31cc12410a446759c2bb Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 2 May 2001 00:49:27 +0000 Subject: [PATCH 0963/2047] *** empty log message *** --- libguile/ChangeLog | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 961b87f40..db6ebcbb5 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,23 @@ +2001-05-02 Marius Vollmer + + * rw.c: Include "modules.h" and "strports.h". + + * net_db.h (scm_gethost): Added prototype. + + * deprecation.h, deprecation.c: New. + * Makefile.am (libguile_la_SOURCES): Added "deprecation.c". + (DOT_X_FILES): Added "deprecation.x". + (modinclude_HEADERS): Added "deprecation.h". + + * init.c: Include "deprecation.h". + (scm_init_guile_1): Call scm_init_deprecation. + +2001-05-01 Marius Vollmer + + * gh.h (gh_init_guile, gh_make_string, gh_string_length, + gh_string_ref, gh_string_set_x, gh_substring, gh_string_append): + New. + 2001-04-29 Gary Houston * rw.c: new file, implementing C part of module (ice-9 rw). From 6503ad7fe48b9efd967521e0d78b7c62b51efbcf Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 2 May 2001 00:50:43 +0000 Subject: [PATCH 0964/2047] Reformatted configure options. Added `--enable-deprecated' option. --- INSTALL | 128 ++++++++++++++++++++++++++++++++++---------------------- 1 file changed, 77 insertions(+), 51 deletions(-) diff --git a/INSTALL b/INSTALL index c96d81917..fc6516953 100644 --- a/INSTALL +++ b/INSTALL @@ -58,73 +58,99 @@ If you run the configure script with no arguments, it should examine your system and set things up appropriately. However, there are a few switches specific to Guile you may find useful in some circumstances. ---enable-maintainer-mode --- If you have automake, autoconf, and -libtool installed on your system, this switch causes configure to -generate Makefiles which know how to automatically regenerate -configure scripts, makefiles, and headers, when they are out of date. -The README file says which versions of those tools you will need. ---with-threads --- Build a Guile executable and library that supports -cooperative threading. If you use this switch, Guile will also build -and install the QuickThreads non-preemptive threading library, -libqthreads, which you will need to link into your programs after -libguile. When you use `guile-config', you will pick up all -neccessary linker flags automatically. +--enable-maintainer-mode -Cooperative threads are not yet thoroughly tested; once they are, they -will be enabled by default. The interaction with blocking I/O is -pretty ad hoc at the moment. In our experience, bugs in the thread -support do not affect you if you don't actually use threads. + If you have automake, autoconf, and libtool installed on your + system, this switch causes configure to generate Makefiles which + know how to automatically regenerate configure scripts, makefiles, + and headers, when they are out of date. The README file says which + versions of those tools you will need. ---with-modules --- Guile can dynamically load `plugin modules' during -runtime, using facilities provided by libtool. Not all platforms -support this, however. On these platforms, you can statically link -the plugin modules into libguile when Guile itself is build. XXX - -how does one specify the modules? ---disable-shared --- Do not build shared libraries. Normally, Guile -will build shared libraries if your system supports them. Guile -always builds static libraries. +--with-threads --- Build with thread support ---enable-debug-freelist --- Enable freelist debugging. + Build a Guile executable and library that supports cooperative + threading. If you use this switch, Guile will also build and + install the QuickThreads non-preemptive threading library, + libqthreads, which you will need to link into your programs after + libguile. When you use `guile-config', you will pick up all + neccessary linker flags automatically. -This enables a debugging version of SCM_NEWCELL(), and also registers -an extra primitive, the setter `gc-set-debug-check-freelist!'. + Cooperative threads are not yet thoroughly tested; once they are, + they will be enabled by default. The interaction with blocking I/O + is pretty ad hoc at the moment. In our experience, bugs in the + thread support do not affect you if you don't actually use threads. -Configure with the --enable-debug-freelist option to enable -the gc-set-debug-check-freelist! primitive, and then use: -(gc-set-debug-check-freelist! #t) # turn on checking of the freelist -(gc-set-debug-check-freelist! #f) # turn off checking +--with-modules --- Specify statically linked `modules' -Checking of the freelist forces a traversal of the freelist and -a garbage collection before each allocation of a cell. This can -slow down the interpreter dramatically, so the setter should be used to -turn on this extra processing only when necessary. + Guile can dynamically load `plugin modules' during runtime, using + facilities provided by libtool. Not all platforms support this, + however. On these platforms, you can statically link the plugin + modules into libguile when Guile itself is build. XXX - how does + one specify the modules? ---enable-debug-malloc --- Enable malloc debugging. -Include code for debugging of calls to scm_must_malloc/realloc/free. +--enable-deprecated=LEVEL --- Control the inclusion of deprecated features. -Checks that + You can select between different behaviours via the LEVEL argument: + a value of "no" will omit all deprecated features and you will get + "undefined reference", "variable unbound" or similar errors when you + try to use them. All other values will include all deprecated + features. The LEVEL argument is used as the default value for the + environment variable GUILE_WARN_DEPRECATED. See the README for + documentation about this. -1. objects freed by scm_must_free has been mallocated by scm_must_malloc -2. objects reallocated by scm_must_realloc has been allocated by - scm_must_malloc -3. reallocated objects are reallocated with the same what string -But, most importantly, it records the number of allocated objects of -each kind. This is useful when searching for memory leaks. +--disable-shared --- Do not build shared libraries. -A Guile compiled with this option provides the primitive -`malloc-stats' which returns an alist with pairs of kind and the -number of objects of that kind. + Normally, Guile will build shared libraries if your system supports + them. Guile always builds static libraries. ---enable-guile-debug --- Include internal debugging functions ---disable-arrays --- omit array and uniform array support ---disable-posix --- omit posix interfaces ---disable-networking --- omit networking interfaces ---disable-regex --- omit regular expression interfaces + +--enable-debug-freelist --- Enable freelist debugging. + + This enables a debugging version of SCM_NEWCELL(), and also + registers an extra primitive, the setter + `gc-set-debug-check-freelist!'. + + Configure with the --enable-debug-freelist option to enable the + gc-set-debug-check-freelist! primitive, and then use: + + (gc-set-debug-check-freelist! #t) # turn on checking of the freelist + (gc-set-debug-check-freelist! #f) # turn off checking + + Checking of the freelist forces a traversal of the freelist and a + garbage collection before each allocation of a cell. This can slow + down the interpreter dramatically, so the setter should be used to + turn on this extra processing only when necessary. + + +--enable-debug-malloc --- Enable malloc debugging. + + Include code for debugging of calls to scm_must_malloc/realloc/free. + + Checks that + + 1. objects freed by scm_must_free has been mallocated by scm_must_malloc + 2. objects reallocated by scm_must_realloc has been allocated by + scm_must_malloc + 3. reallocated objects are reallocated with the same what string + + But, most importantly, it records the number of allocated objects of + each kind. This is useful when searching for memory leaks. + + A Guile compiled with this option provides the primitive + `malloc-stats' which returns an alist with pairs of kind and the + number of objects of that kind. + + +--enable-guile-debug --- Include internal debugging functions +--disable-arrays --- omit array and uniform array support +--disable-posix --- omit posix interfaces +--disable-networking --- omit networking interfaces +--disable-regex --- omit regular expression interfaces Using Guile Without Installing It ========================================= From 6b3ccfcc161800c5a730cdac819ce5f816a2fd3d Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 2 May 2001 00:53:07 +0000 Subject: [PATCH 0965/2047] Added section about the handling of deprecated features. --- README | 50 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 50 insertions(+) diff --git a/README b/README index 0598f6ef3..57cc6c7c3 100644 --- a/README +++ b/README @@ -86,6 +86,56 @@ license statement as found in any individual file that it applies to: whether to permit this exception to apply to your modifications. If you do not wish that, delete this exception notice. +Handling of Deprecated Features ====================================== + +Guile may contain features that are `deprecated'. When a feature is +deprecated, it means that it is still there and fully functional, but +that there is a better way of achieving the same thing, and we'd +rather have you use this better way. This allows us to eventually +remove the old implementation and helps to keep Guile reasonably clean +of historic baggage. + +See the file NEWS for a list of features that are currently +deprecated. Each entry will also tell you what you should replace +your code with. + +To give you some help with this process, and to encourage (OK, nudge) +people to switch to the newer methods, Guile can emit warnings or +errors when you use a deprecated feature. There is quite a range of +possibilities, from being completely silent to giving errors at link +time. What exactly happens is determined both by the value of the +`--enable-deprecated' configuration option when Guile was built, and +by the GUILE_WARN_DEPRECATED environment variable. + +It works like this: + + When Guile has been configured with `--enable-deprecated=no' (or, + equivalently, with `--disable-deprecated') then all deprecated + features are omitted from Guile. You will get "undefined + reference", "variable unbound" or similar errors when you try to use + them. + + When `--enable-deprecated=LEVEL' has been specified (for LEVEL not + "no"), LEVEL will be used as the default value of the environment + variable GUILE_WARN_DEPRECATED. A value of "yes" is changed to + "summary", however. + + When GUILE_WARN_DEPRECATION has the value "no", nothing special will + happen when a deprecated feature is used. + + When GUILE_WARN_DEPRECATION has the value "summary", and a deprecated + feature has been used, Guile will print this message at exit: + + Some deprecated features have been used. Set the environment + variable GUILE_WARN_DEPRECATED to "detailed" and rerun the program + to get more information. Set it to "no" to suppress this message. + + When GUILE_WARN_DEPRECATION has the value "detailed", a detailed + warning is emitted immediatly for the first use of a deprecated + feature. + +The default is `--enable-deprecation=yes'. + About This Distribution ============================================== Interesting files include: From cbc227623e8bb655407f5b92d03ef1a06632567a Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 2 May 2001 00:53:49 +0000 Subject: [PATCH 0966/2047] * acconfig.h (SCM_DEBUG_DEPRECATED, GUILE_WARN_DEPRECATED_DEFAULT): Added. --- acconfig.h | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/acconfig.h b/acconfig.h index 3c0e7887e..b7e588d27 100644 --- a/acconfig.h +++ b/acconfig.h @@ -44,6 +44,12 @@ * If you do not wish that, delete this exception notice. */ +/* Define this if you want to exclude deprecated features */ +#undef SCM_DEBUG_DEPRECATED + +/* Define this to control the default warning level for deprecated features */ +#undef GUILE_WARN_DEPRECATED_DEFAULT + /* Define these two if you want support for debugging of Scheme programs. */ #undef DEBUG_EXTENSIONS From e73dd5498e721aea2dcf7044fe0c152b14ecdef7 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 2 May 2001 00:54:58 +0000 Subject: [PATCH 0967/2047] * configure.in: Added handling of `--enable-deprecated'. --- configure.in | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/configure.in b/configure.in index b7897b452..45a880765 100644 --- a/configure.in +++ b/configure.in @@ -41,13 +41,13 @@ AC_CONFIG_SUBDIRS(guile-readline) #-------------------------------------------------------------------- AC_ARG_ENABLE(debug-freelist, - [ --enable-debug-freelist include garbage collector freelist debugging code], + [ --enable-debug-freelist include garbage collector freelist debugging code], if test "$enable_debug_freelist" = y || test "$enable_debug_freelist" = yes; then AC_DEFINE(GUILE_DEBUG_FREELIST) fi) AC_ARG_ENABLE(debug-malloc, - [ --enable-debug-malloc include malloc debugging code], + [ --enable-debug-malloc include malloc debugging code], if test "$enable_debug_malloc" = y || test "$enable_debug_malloc" = yes; then AC_DEFINE(GUILE_DEBUG_MALLOC) fi) @@ -96,6 +96,18 @@ AC_ARG_ENABLE(htmldoc, AM_CONDITIONAL(HTMLDOC, test x$htmldoc_enabled = xyes) +AC_ARG_ENABLE(deprecated, + [ --disable-deprecated omit deprecated features [no]]) + +if test "$enable_deprecated" = no; then + AC_DEFINE(SCM_DEBUG_DEPRECATED) +else + if test "$enable_deprecated" = yes || test "$enable_deprecated" = ""; then + enable_deprecated=summary + fi + AC_DEFINE_UNQUOTED(GUILE_WARN_DEPRECATED_DEFAULT, "$enable_deprecated") +fi + dnl The --disable-debug used to control these two. But now they are dnl a required part of the distribution. AC_DEFINE(DEBUG_EXTENSIONS) From 7440341cf61664f7eb3dfeb81213d068549898ea Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 2 May 2001 00:56:15 +0000 Subject: [PATCH 0968/2047] *** empty log message *** --- ChangeLog | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/ChangeLog b/ChangeLog index b933f9726..c944900fb 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2001-05-02 Marius Vollmer + + * configure.in: Added handling of `--enable-deprecated'. + + * acconfig.h (SCM_DEBUG_DEPRECATED, + GUILE_WARN_DEPRECATED_DEFAULT): Added. + 2001-04-29 Thien-Thi Nguyen * Makefile.am (SUBDIRS): Add "scripts". From 9fb41ceac51bffbdcd9e5cfda790b1dde018cb3e Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 2 May 2001 00:59:43 +0000 Subject: [PATCH 0969/2047] * boot-9.scm (begin-deprecated): New. (call-with-deprecation): Removed. (id): Use `issue-deprecation-warning' instead of `call-with-deprecation'. Wrap definition in `begin-deprecated'. (eval-in-module): Manifest deprecation via `begin-deprecation' and `issue-deprecation-warning'. (warn-autoload-deprecation): Deactivated. --- ice-9/boot-9.scm | 110 ++++++++++++++++------------------------------- 1 file changed, 37 insertions(+), 73 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 7fa3f86b3..053feec14 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -30,6 +30,20 @@ ;;; Code: + +;;; {Deprecation} +;;; + +;; We don't have macros here, but we do want to define +;; `begin-deprecated' early. + +(define begin-deprecated + (procedure->memoizing-macro + (lambda (exp env) + (if (include-deprecated-features) + `(begin ,@(cdr exp)) + `#f)))) + ;;; {Features} ;; @@ -99,6 +113,11 @@ (define (and=> value procedure) (and value (procedure value))) (define (make-hash-table k) (make-vector k '())) +(begin-deprecated + (define (id x) + (issue-deprecation-warning "`id' is deprecated. Use `identity' instead.") + (identity x))) + ;;; apply-to-args is functionally redunant with apply and, worse, ;;; is less general than apply since it only takes two arguments. ;;; @@ -114,25 +133,7 @@ (define (apply-to-args args fn) (apply fn args)) -;;; {Deprecation} -;;; -(define call-with-deprecation - (let ((issued-warnings (make-hash-table 13))) - (lambda (msg thunk) - (cond ((not (hashv-ref issued-warnings msg #f)) - (display ";;; " (current-error-port)) - (display msg (current-error-port)) - (newline (current-error-port)) - (hashv-set! issued-warnings msg #t))) - (thunk)))) - -(define (id x) - (call-with-deprecation "`id' is deprecated. Use `identity' instead." - (lambda () - (identity x)))) - - ;;; {Integer Math} ;;; @@ -1017,9 +1018,11 @@ ;; to maximally one module. (set-procedure-property! closure 'module module)))) -;;; This procedure is deprecated -;;; -(define eval-in-module eval) +(begin-deprecated + (define (eval-in-module exp mod) + (issue-deprecation-warning + "`eval-in-module' is deprecated. Use `eval' instead.") + (eval exp mod))) ;;; {Observer protocol} @@ -1738,48 +1741,12 @@ ;;; Dynamic linking of modules -;; Initializing a module that is written in C is a two step process. -;; First the module's `module init' function is called. This function -;; is expected to call `scm_register_module_xxx' to register the `real -;; init' function. Later, when the module is referenced for the first -;; time, this real init function is called in the right context. See -;; gtcltk-lib/gtcltk-module.c for an example. -;; -;; The code for the module can be in a regular shared library (so that -;; the `module init' function will be called when libguile is -;; initialized). Or it can be dynamically linked. -;; -;; You can safely call `scm_register_module_xxx' before libguile -;; itself is initialized. You could call it from an C++ constructor -;; of a static object, for example. -;; -;; To make your Guile extension into a dynamic linkable module, follow -;; these easy steps: -;; -;; - Find a name for your module, like (ice-9 gtcltk) -;; - Write a function with a name like -;; -;; scm_init_ice_9_gtcltk_module -;; -;; This is your `module init' function. It should call -;; -;; scm_register_module_xxx ("ice-9 gtcltk", scm_init_gtcltk); -;; -;; "ice-9 gtcltk" is the C version of the module name. Slashes are -;; replaced by spaces, the rest is untouched. `scm_init_gtcltk' is -;; the real init function that executes the usual initializations -;; like making new smobs, etc. -;; -;; - Make a shared library with your code and a name like -;; -;; ice-9/libgtcltk.so -;; -;; and put it somewhere in %load-path. -;; -;; - Then you can simply write `:use-module (ice-9 gtcltk)' and it -;; will be linked automatically. -;; -;; This is all very experimental. +;; This method of dynamically linking Guile Extensions is deprecated. +;; Use `dynamic-link' and `dynamic-call' explicitely from Scheme code +;; instead. + +;; XXX - We can not offer the removal of this code thru the +;; deprecation mechanism since we have no complete replacement yet. (define (split-c-module-name str) (let loop ((rev '()) @@ -1812,17 +1779,14 @@ registered-modules))) (define (warn-autoload-deprecation modname) - (display - ";;; Autoloading of compiled code modules is deprecated.\n" - (current-error-port)) - (display - ";;; Write a Scheme file instead that uses `dynamic-link' directly.\n" - (current-error-port)) - (format (current-error-port) - ";;; (You just tried to autoload module ~S.)\n" modname)) - + ;; Do nothing here until we can deprecate the code for real. + (if #f + (issue-deprecation-warning + "Autoloading of compiled code modules is deprecated." + "Write a Scheme file instead that uses `dynamic-link' directly."))) + (define (init-dynamic-module modname) - ;; Register any linked modules which has been registered on the C level + ;; Register any linked modules which have been registered on the C level (register-modules #f) (or-map (lambda (modinfo) (if (equal? (car modinfo) modname) From 41ed8fedd2d9ec3914aaca2fdc90054dce156ce9 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 2 May 2001 01:01:21 +0000 Subject: [PATCH 0970/2047] *** empty log message *** --- ice-9/ChangeLog | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index b3f721fab..0fe364029 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,13 @@ +2001-05-02 Marius Vollmer + + * boot-9.scm (begin-deprecated): New. + (call-with-deprecation): Removed. + (id): Use `issue-deprecation-warning' instead of + `call-with-deprecation'. Wrap definition in `begin-deprecated'. + (eval-in-module): Manifest deprecation via `begin-deprecation' and + `issue-deprecation-warning'. + (warn-autoload-deprecation): Deactivated. + 2001-04-26 Marius Vollmer * boot-9.scm (the-module, set-current-module, current-module): From e1633bf39b5931e07b8b752eeda15c4cc3d8e3d9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 2 May 2001 13:13:35 +0000 Subject: [PATCH 0971/2047] * Makefile.am (srfi_DATA): Added srfi-10.scm and srfi-17.scm. * srfi-10.scm: New file. * srfi-17.scm: New file, contributed by Matthias Koeppe. Thanks a lot! Added `Commentary:' tag. * srfi-9.scm: Added `Commentary:' tag. --- srfi/ChangeLog | 12 ++++++ srfi/Makefile.am | 6 +-- srfi/srfi-10.scm | 85 +++++++++++++++++++++++++++++++++++++++++ srfi/srfi-17.scm | 99 ++++++++++++++++++++++++++++++++++++++++++++++++ srfi/srfi-9.scm | 4 ++ 5 files changed, 203 insertions(+), 3 deletions(-) create mode 100644 srfi/srfi-10.scm create mode 100644 srfi/srfi-17.scm diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 6ae7274ff..40afe47b5 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,15 @@ +2001-05-02 Martin Grabmueller + + * Makefile.am (srfi_DATA): Added srfi-10.scm and srfi-17.scm. + + * srfi-10.scm: New file. + + * srfi-17.scm: New file, contributed by Matthias Koeppe. Thanks a + lot! + Added `Commentary:' tag. + + * srfi-9.scm: Added `Commentary:' tag. + 2001-04-27 Rob Browning * srfi-13.h diff --git a/srfi/Makefile.am b/srfi/Makefile.am index 5eb8eb9cc..11c25b8d9 100644 --- a/srfi/Makefile.am +++ b/srfi/Makefile.am @@ -21,8 +21,6 @@ AUTOMAKE_OPTIONS = foreign -#info_TEXINFOS = guile-srfi.texi - ## Prevent automake from adding extra -I options DEFS = @DEFS@ ## Check for headers in $(srcdir)/.., so that #include @@ -43,9 +41,11 @@ srfi_DATA = srfi-2.scm \ srfi-6.scm \ srfi-8.scm \ srfi-9.scm \ + srfi-10.scm \ srfi-11.scm \ srfi-13.scm \ - srfi-14.scm + srfi-14.scm \ + srfi-17.scm EXTRA_DIST = $(srfi_DATA) diff --git a/srfi/srfi-10.scm b/srfi/srfi-10.scm new file mode 100644 index 000000000..0ce743af3 --- /dev/null +++ b/srfi/srfi-10.scm @@ -0,0 +1,85 @@ +;;;; srfi-10.scm --- SRFI-10 read hash extension for Guile +;;;; +;;;; Copyright (C) 2001 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +;;; Commentary: + +;;; This module implements the syntax extension #,(), also called +;;; hash-comma, which is defined in SRFI-10. +;;; +;;; The support for SRFI-10 consists of the procedure +;;; `define-reader-ctor' for defining new reader constructors and the +;;; read syntax form +;;; +;;; #,( ...) +;;; +;;; where must be a symbol for which a read constructor was +;;; defined previously. +;;; +;;; Example: +;;; +;;; (define-reader-ctor 'file open-input-file) +;;; (define f '#,(file "/etc/passwd")) +;;; (read-line f) +;;; => +;;; :root:x:0:0:root:/root:/bin/bash" +;;; +;;; Please note the quote before the #,(file ...) expression. This is +;;; necessary because ports are not self-evaluating in Guile. + +;;; Code: + +(define-module (srfi srfi-10) + #:use-module (ice-9 rdelim)) + +(export define-reader-ctor) + +;; This hash table stores the association between comma-hash tags and +;; the corresponding constructor procedures. +;; +(define reader-ctors (make-hash-table 31)) + +;; This procedure installs the procedure @var{proc} as the constructor +;; for the comma-hash tag @var{symbol}. +;; +(define (define-reader-ctor symbol proc) + (hashq-set! reader-ctors symbol proc) + (if #f #f)) ; Return unspecified value. + +;; Retrieve the constructor procedure for the tag @var{symbol} or +;; throw an error if no such tag is defined. +;; +(define (lookup symbol) + (let ((p (hashq-ref reader-ctors symbol #f))) + (if (procedure? p) + p + (error "unknown hash-comma tag " symbol)))) + +;; This is the actual reader extension. +;; +(define (hash-comma char port) + (let* ((obj (read port))) + (if (and (list? obj) (positive? (length obj)) (symbol? (car obj))) + (let ((p (lookup (car obj)))) + (let ((res (apply p (cdr obj)))) + res)) + (error "syntax error in hash-comma expression")))) + +;; Install the hash extension. +;; +(read-hash-extend #\, hash-comma) diff --git a/srfi/srfi-17.scm b/srfi/srfi-17.scm new file mode 100644 index 000000000..1a82ea09d --- /dev/null +++ b/srfi/srfi-17.scm @@ -0,0 +1,99 @@ +;;;; srfi-17.scm --- SRFI-17 procedures for Guile + +;;; Copyright (C) 2001 Free Software Foundation, Inc. +;;; Originally by Matthias Koeppe +;;; +;;; 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, 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 this software; see the file COPYING. If not, write to +;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;; Boston, MA 02111-1307 USA + +;;; Commentary: + +;; This is an implementation of SRFI-17: Generalized set! +;; +;; It exports the Guile procedure `make-procedure-with-setter' under +;; the SRFI name `getter-with-setter' and exports the standard +;; procedures `car', `cdr', ..., `cdddr', `string-ref' and +;; `vector-ref' as procedures with setters, as required by the SRFI. +;; +;; SRFI-17 was heavily criticized during its discussion period but it +;; was finalized anyway. One issue was its concept of globally +;; associating setter "properties" with (procedure) values, which is +;; non-Schemy. For this reason, this implementation chooses not to +;; provide a way to set the setter of a procedure. In fact, (set! +;; (setter PROC) SETTER) signals an error. The only way to attach a +;; setter to a procedure is to create a new object (a "procedure with +;; setter") via the `getter-with-setter' procedure. This procedure is +;; also specified in the SRFI. Using it avoids the described +;; problems. + +;;; Code: + +(define-module (srfi srfi-17) + :export (getter-with-setter + setter + ;; redefined standard procedures + 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 string-ref vector-ref)) + +;;; Procedures + +(define getter-with-setter make-procedure-with-setter) + +(define setter + (getter-with-setter + setter + (lambda args + (error "Setting setters is not supported for a good reason.")))) + +;;; Redefine R5RS procedures to appropriate procedures with setters + +(define (compose-setter setter location) + (lambda (obj value) + (setter (location obj) value))) + +(define car (getter-with-setter car set-car!)) +(define cdr (getter-with-setter cdr set-cdr!)) +(define caar (getter-with-setter caar (compose-setter set-car! car))) +(define cadr (getter-with-setter cadr (compose-setter set-car! cdr))) +(define cdar (getter-with-setter cdar (compose-setter set-cdr! car))) +(define cddr (getter-with-setter cddr (compose-setter set-cdr! cdr))) +(define caaar (getter-with-setter caaar (compose-setter set-car! caar))) +(define caadr (getter-with-setter caadr (compose-setter set-car! cadr))) +(define cadar (getter-with-setter cadar (compose-setter set-car! cdar))) +(define caddr (getter-with-setter caddr (compose-setter set-car! cddr))) +(define cdaar (getter-with-setter cdaar (compose-setter set-cdr! caar))) +(define cdadr (getter-with-setter cdadr (compose-setter set-cdr! cadr))) +(define cddar (getter-with-setter cddar (compose-setter set-cdr! cdar))) +(define cdddr (getter-with-setter cdddr (compose-setter set-cdr! cddr))) +(define caaaar (getter-with-setter caaaar (compose-setter set-car! caaar))) +(define caaadr (getter-with-setter caaadr (compose-setter set-car! caadr))) +(define caadar (getter-with-setter caadar (compose-setter set-car! cadar))) +(define caaddr (getter-with-setter caaddr (compose-setter set-car! caddr))) +(define cadaar (getter-with-setter cadaar (compose-setter set-car! cdaar))) +(define cadadr (getter-with-setter cadadr (compose-setter set-car! cdadr))) +(define caddar (getter-with-setter caddar (compose-setter set-car! cddar))) +(define cadddr (getter-with-setter cadddr (compose-setter set-car! cdddr))) +(define cdaaar (getter-with-setter cdaaar (compose-setter set-cdr! caaar))) +(define cdaadr (getter-with-setter cdaadr (compose-setter set-cdr! caadr))) +(define cdadar (getter-with-setter cdadar (compose-setter set-cdr! cadar))) +(define cdaddr (getter-with-setter cdaddr (compose-setter set-cdr! caddr))) +(define cddaar (getter-with-setter cddaar (compose-setter set-cdr! cdaar))) +(define cddadr (getter-with-setter cddadr (compose-setter set-cdr! cdadr))) +(define cdddar (getter-with-setter cdddar (compose-setter set-cdr! cddar))) +(define cddddr (getter-with-setter cddddr (compose-setter set-cdr! cdddr))) +(define string-ref (getter-with-setter string-ref string-set!)) +(define vector-ref (getter-with-setter vector-ref vector-set!)) diff --git a/srfi/srfi-9.scm b/srfi/srfi-9.scm index fb61dfec0..7d2468892 100644 --- a/srfi/srfi-9.scm +++ b/srfi/srfi-9.scm @@ -17,6 +17,8 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;; Commentary: + ;;; This module exports the syntactic form `define-record-type', which ;;; is the means for creating record types defined in SRFI-9. ;;; @@ -55,6 +57,8 @@ ;;; guile> (foo? 1) ;;; #f +;;; Code: + (define-module (srfi srfi-9)) (export-syntax define-record-type) From 0892b63b25a3eda50c568e4b829ef52c6e09e1cf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 2 May 2001 14:44:38 +0000 Subject: [PATCH 0972/2047] * scheme-modules.texi (Dynamic Libraries): Renamed from `Dynamic Linking from Marius''. (The Guile module system): Removed obsolete naming convention. (Loading Guile Modules, Creating Guile Modules), (More Module Procedures, Included Guile Modules): New nodes, split from `The Guile module system'. (The Guile module system): Changed references to (ice-9 slib) to (ice-9 popen), because note everybody has SLIB installed. (Included Guile Modules): Added a bunch of modules shipped with Guile. (Dynamic Libraries): (old version) Removed. * scheme-io.texi (Block Reading and Writing): Corrected capitalization, so it builds again. --- doc/ChangeLog | 18 ++ doc/scheme-io.texi | 2 +- doc/scheme-modules.texi | 367 ++++++++++++++++++++++++---------------- 3 files changed, 242 insertions(+), 145 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 6072aabd8..b136680b9 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,21 @@ +2001-05-02 Martin Grabmueller + + * scheme-modules.texi (Dynamic Libraries): Renamed from `Dynamic + Linking from Marius''. + (The Guile module system): Removed obsolete naming convention. + (Loading Guile Modules, Creating Guile Modules), + (More Module Procedures, Included Guile Modules): New nodes, split + from `The Guile module system'. + (The Guile module system): Changed references to (ice-9 slib) to + (ice-9 popen), because note everybody has SLIB installed. + (Included Guile Modules): Added a bunch of modules shipped with + Guile. + + (Dynamic Libraries): (old version) Removed. + + * scheme-io.texi (Block Reading and Writing): Corrected + capitalization, so it builds again. + 2001-05-01 Gary Houston * scheme-io.texi: Removed obsolete section Binary IO. Added diff --git a/doc/scheme-io.texi b/doc/scheme-io.texi index 02cf8a864..809b5f135 100644 --- a/doc/scheme-io.texi +++ b/doc/scheme-io.texi @@ -429,7 +429,7 @@ delimiter may be either a newline or the @var{eof-object}; if @code{(# . #)}. @end deffn -@node Block reading and writing +@node Block Reading and Writing @section Block reading and writing The Block-string-I/O module can be accessed with: diff --git a/doc/scheme-modules.texi b/doc/scheme-modules.texi index 5aa23be8c..0445b15b8 100644 --- a/doc/scheme-modules.texi +++ b/doc/scheme-modules.texi @@ -38,8 +38,7 @@ clutter the global name space. @menu * Scheme and modules:: How modules are handled in standard Scheme. * The Guile module system:: How Guile does it. -* Dynamic Libraries:: Loading libraries of compiled code at run time. -* Dynamic Linking from Marius:: +* Dynamic Libraries:: Loading libraries of compiled code at run time. @end menu @@ -81,42 +80,190 @@ This module system is regarded as being rather idiosyncratic, and will probably change to something more like the ML module system, so for now I will simply describe how it works for a couple of simple cases. -First of all, the Guile module system sets up a hierarchical name space, -and that name space can be represented like Unix pathnames preceded by a -@key{#} character. The root name space for all Guile-supplied modules -is called @code{ice-9}. - -So for example, the SLIB interface, contained in -@file{$srcdir/ice-9/slib.scm}, starts out with +So for example, the pipe interprocess communication interface +(REFFIXME), contained in @file{$srcdir/ice-9/popen.scm}, starts out with @smalllisp -(define-module (ice-9 slib)) +(define-module (ice-9 popen)) @end smalllisp and a user program can use @smalllisp -(use-modules (ice-9 slib)) +(use-modules (ice-9 popen)) @end smalllisp -to have access to all procedures and variables defined within the slib -module with @code{(define-public ...)}. +to have access to all procedures and variables exported from the module. + +@menu +* General Information about Modules:: Guile module basics. +* Loading Guile Modules:: How to use existing modules. +* Creating Guile Modules:: How to package your code into modules. +* More Module Procedures:: Low--level module code. +* Included Guile Modules:: Which modules come with Guile? +@end menu + +@node General Information about Modules +@subsection General Information about Modules + +A Guile module is a collection of procedures, variables and syntactic +forms (macros), which are either public or private. Public bindings are +in the so--called @dfn{export list} of a module and can be made visible +to other modules, which import them. This @dfn{module import} is called +@dfn{using} of a module, and consists of loading of the module code (if +it has not already been loaded) and making all exported items of the +loaded module visible to the importing module (@pxref{Loading Guile +Modules}). + +The other side is called @dfn{defining} a module, and consists of giving +a name to a module, add procedures and variables to it and declare which +of the names should be exported when another module uses it +(@pxref{Creating Guile Modules}). + +All Guile modules have unique names, which are lists of one or more +symbols. Examples are @code{(ice-9 popen)} or @code{(srfi srfi-11)}. +When Guile searches for the code of a module, it constructs the name of +the file to load by concatenating the name elements with slashes between +the elements and appending a number of file name extensions from the +list @code{%load-extensions} (REFFIXME). The resulting file name is +then searched in all directories in the variable @code{%load-path}. For +example, the @code{(ice-9 popen)} module would result in the filename +@code{ice-9/popen.scm} and searched in the installation directory of +Guile and in all other directories in the load path. + +@c FIXME::martin: Not sure about this, maybe someone knows better? +Every module has a so--called syntax transformer associated with it. +This is a procedure which performs all syntax transformation for the +time the module is read in and evaluated. When working with modules, +you can manipulate the current syntax transformer using the +@code{use-syntax} syntactic form or the @code{#:use-syntax} module +definition option (@pxref{Creating Guile Modules}). + +Please note that there are some problems with the current module system +you should keep in mind. When importing a module which exports a macro +definition, the other module must export all bindings the macro +expansion uses, too, because the expanded code would otherwise not be +able to see these definitions and issue a ``variable unbound'' error, or +worse, would use another binding which might be present in the scope of +the expansion. + +When two or more modules are imported, and they export bindings with the +same names, the last imported module wins, and the exported binding of +that last module will silently be used. This might lead to +hard--to--find errors because wrong procedures or variables are used. + + +@node Loading Guile Modules +@subsection Loading Guile Modules + +@c FIXME::martin: Review me! + +There are several modules included in the Guile distribution, and not +all of the procedures available for Guile are immedietely available when +you start up the interpreter. Some of the procedures are packaged in +modules, so that they are only accessible after the user has explicitly +said that she wants to use them. In Guile, the syntactic form +@code{use-modules} is used for telling the interpreter that he should +locate the code for a given module, load it and make the exported +bindings of the module visible to the caller. + +@c begin (scm-doc-string "boot-9.scm" "use-modules") +@deffn syntax use-modules module-specification @dots{} +All @var{module-specification}s are of the form @code{(hierarchy file)}. +One example of this is + +@smalllisp +(use-modules (ice-9 popen)) +@end smalllisp + +@code{use-modules} allows the current Guile program to use all publicly +defined procedures and variables in the modules denoted by the +@var{module-specification}s. +@end deffn +@c end + +@c FIXME::martin: Is this correct, and is there more to say? +@c FIXME::martin: Define term and concept `system transformer' somewhere. + +@deffn syntax use-syntax module-specification +Load the module @code{module-specification} and use its system +transformer as the system transformer for the currently defined module, +as well as installing it as the current system transformer. +@end deffn + + +@node Creating Guile Modules +@subsection Creating Guile Modules + +@c FIXME::martin: Review me! + +When you want to create your own modules, you have to take the following +steps: + +@itemize @bullet +@item +Create a Scheme source file and add all variables and procedures you wish +to export, or which are required by the exported procedures. + +@item +Add a @code{define-module} form at the beginning. + +@item +Export all bindings which should be visible to importing modules, either +by using @code{define-public} or @code{export} (both documented below). +@end itemize -So here are the functions involved: @c begin (scm-doc-string "boot-9.scm" "define-module") -@deffn syntax define-module module-specification +@deffn syntax define-module module-specification [options @dots{}] @var{module-specification} is of the form @code{(hierarchy file)}. One example of this is @smalllisp -(define-module (ice-9 slib)) +(define-module (ice-9 popen)) @end smalllisp @code{define-module} makes this module available to Guile programs under the given @var{module-specification}. + +The @var{options} are keyword/value--pairs which specify more about the +defined module. The recognized options and their meaning is shown in +the following table. + +@table @code +@item #:use-module @var{module} +Equivalent to a @code{(use-modules @var{module})}. Use the specified +@var{module} when loading this module. + +@item #:use-syntax @var{module} +Use @var{module} when loading the currently defined module, and install +it as the syntax transformer. + +@item #:autoload @var{module} @var{symbol} +Load @var{module} whenever @var{symbol} is accessed. + +@item #:export @var{list} +Export all identifiers in @var{list}, which must be a list of symbols. +This is equivalent to @code{(export @var{list})} in the module body. + +@item #:no-backtrace +Tell Guile not to record information for procedure backtraces when +executing the procedures in this module. + +@item #:pure +Create a @dfn{pure} module, that is a module which does not contain any +of the standard procedure bindings except for the syntax forms. This is +useful if you want to create @dfn{safe} modules, that is modules which +do not know anything about dangerous procedures. +@end table + @end deffn @c end +@deffn syntax export variable @dots{} +Add all @var{variable}s (which must be symbols) to the list of exported +bindings of the current module. +@end deffn + @c begin (scm-doc-string "boot-9.scm" "define-public") @deffn syntax define-public @dots{} Makes a procedure or variable available to programs that use the current @@ -124,44 +271,87 @@ module. @end deffn @c end -@c begin (scm-doc-string "boot-9.scm" "use-modules") -@deffn syntax use-modules module-specification -@var{module-specification} is of the form @code{(hierarchy file)}. One -example of this is - -@smalllisp -(use-modules (ice-9 slib)) -@end smalllisp - -@code{use-modules} allows the current Guile program to use all publicly -defined procedures and variables in the module denoted by -@var{module-specification}. -@end deffn -@c end [FIXME: must say more, and explain, and also demonstrate a private name space use, and demonstrate how one would do Python's "from Tkinter import *" versus "import Tkinter". Must also add something about paths and standards for contributed modules.] +@node More Module Procedures +@subsection More Module Procedures + +@c FIXME::martin: Review me! + +@c FIXME::martin: Should this procedure be documented and supported +@c at all? + +The procedures in this section are useful if you want to dig into the +innards of Guile's module system. If you don't know precisely what you +do, you should probably avoid using any of them. + @deffn primitive standard-eval-closure module Return an eval closure for the module @var{module}. @end deffn + +@node Included Guile Modules +@subsection Included Guile Modules + +@c FIXME::martin: Review me! + Some modules are included in the Guile distribution; here are references to the entries in this manual which describe them in more detail: + @table @strong @item boot-9 boot-9 is Guile's initialization module, and it is always loaded when Guile starts up. + @item (ice-9 debug) Mikael Djurfeldt's source-level debugging support for Guile (@pxref{Debugger User Interface}). + @item (ice-9 threads) Guile's support for multi threaded execution (@pxref{Scheduling}). + +@item (ice-9 rdelim) +Line-- and character--delimited input (REFFIXME). + +@item (ice-9 documentation) +Online documentation (REFFIXME). + +@item (srfi srfi-2) +Support for @code{and-let*} (REFFIXME). + +@item (srfi srfi-6) +Support for some additional string port procedures (REFFIXME). + +@item (srfi srfi-8) +Multiple--value handling with @code{receive} (REFFIXME). + +@item (srfi srfi-9) +Record definition with @code{define-record-type} (REFFIXME). + +@item (srfi srfi-10) +Read--hash extension @code{#,()} (REFFIXME). + +@item (srfi srfi-11) +Multiple--value handling with @code{let-values} and @code{let-values*} +(REFFIXME). + +@item (srfi srfi-13) +String library (REFFIXME). + +@item (srfi srfi-14) +Character--set library (REFFIXME). + +@item (srfi srfi-17) +Getter--with--setter support (REFFIXME). + @item (ice-9 slib) This module contains hooks for using Aubrey Jaffer's portable Scheme library SLIB from Guile (@pxref{SLIB}). + @c FIXME::martin: This module is not in the distribution. Remove it @c from here? @item (ice-9 jacal) @@ -173,117 +363,6 @@ packge Jacal from Guile (@pxref{JACAL}). @node Dynamic Libraries @section Dynamic Libraries -Often you will want to extend Guile by linking it with some existing -system library. For example, linking Guile with a @code{curses} or -@code{termcap} library would be useful if you want to implement a -full-screen user interface for a Guile application. However, if you -were to link Guile with these libraries at compile time, it would bloat -the interpreter considerably, affecting everyone on the system even if -the new libraries are useful only to you. Also, every time a new -library is installed, you would have to reconfigure, recompile and -relink Guile merely in order to provide a new interface. - -Many Unix systems permit you to get around this problem by using -@dfn{dynamic loading}. When a new library is linked, it can be made a -@dfn{dynamic library} by passing certain switches to the linker. A -dynamic library does not need to be linked with an executable image at -link time; instead, the executable may choose to load it dynamically at -run time. This is a powerful concept that permits an executable to link -itself with almost any library without reconfiguration, if it has been -written properly. - -Guile's dynamic linking functions make it relatively easy to write a -module that incorporates code from third-party object code libraries. - -@deffn primitive dynamic-link filename -Open the dynamic library called @var{filename}. A library -handle representing the opened library is returned; this handle -should be used as the @var{dobj} argument to the following -functions. -@end deffn - -@deffn primitive dynamic-object? obj -Return @code{#t} if @var{obj} is a dynamic library handle, or @code{#f} -otherwise. -@end deffn - -@deffn primitive dynamic-unlink dobj -Unlink the indicated object file from the application. The -argument @var{dobj} must have been obtained by a call to -@code{dynamic-link}. After @code{dynamic-unlink} has been -called on @var{dobj}, its content is no longer accessible. -@end deffn - -@deffn primitive dynamic-func name dobj -Search the dynamic object @var{dobj} for the C function -indicated by the string @var{name} and return some Scheme -handle that can later be used with @code{dynamic-call} to -actually call the function. - -Regardless whether your C compiler prepends an underscore @samp{_} to -the global names in a program, you should @strong{not} include this -underscore in @var{function}. Guile knows whether the underscore is -needed or not and will add it when necessary. -@end deffn - -@deffn primitive dynamic-call func dobj -Call the C function indicated by @var{func} and @var{dobj}. -The function is passed no arguments and its return value is -ignored. When @var{function} is something returned by -@code{dynamic-func}, call that function and ignore @var{dobj}. -When @var{func} is a string , look it up in @var{dynobj}; this -is equivalent to -@smallexample -(dynamic-call (dynamic-func @var{func} @var{dobj} #f)) -@end smallexample - -Interrupts are deferred while the C function is executing (with -@code{SCM_DEFER_INTS}/@code{SCM_ALLOW_INTS}). -@end deffn - -@deffn primitive dynamic-args-call func dobj args -Call the C function indicated by @var{func} and @var{dobj}, -just like @code{dynamic-call}, but pass it some arguments and -return its return value. The C function is expected to take -two arguments and return an @code{int}, just like @code{main}: -@smallexample -int c_func (int argc, char **argv); -@end smallexample - -The parameter @var{args} must be a list of strings and is -converted into an array of @code{char *}. The array is passed -in @var{argv} and its size in @var{argc}. The return value is -converted to a Scheme number and returned from the call to -@code{dynamic-args-call}. -@end deffn - -@deffn primitive c-registered-modules -Return a list of the object code modules that have been imported into -the current Guile process. Each element of the list is a pair whose -car is the name of the module, and whose cdr is the function handle -for that module's initializer function. The name is the string that -has been passed to scm_register_module_xxx. -@end deffn - -@deffn primitive c-clear-registered-modules -Destroy the list of modules registered with the current Guile process. -The return value is unspecified. @strong{Warning:} this function does -not actually unlink or deallocate these modules, but only destroys the -records of which modules have been loaded. It should therefore be used -only by module bookkeeping operations. -@end deffn - -[FIXME: provide a brief example here of writing the C hooks for an -object code module, and using dynamic-link and dynamic-call to load the -module.] - - -@node Dynamic Linking from Marius -@section Dynamic Linking from Marius - -@c NJFIXME primitive documentation here duplicates (and is generally -@c better than) documentation for the same primitives earlier on. - Most modern Unices have something called @dfn{shared libraries}. This ordinarily means that they have the capability to share the executable image of a library between several running programs to save memory and @@ -319,9 +398,9 @@ dynamic linking apparatus, and a more high-level interface that integrates dynamically linked libraries into the module system. @menu -* Low level dynamic linking:: -* Compiled Code Modules:: -* Dynamic Linking and Compiled Code Modules:: +* Low level dynamic linking:: +* Compiled Code Modules:: +* Dynamic Linking and Compiled Code Modules:: @end menu @node Low level dynamic linking From 109c463fddd5d213e62dc91436fbf39c6e03650f Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Wed, 2 May 2001 21:15:57 +0000 Subject: [PATCH 0973/2047] * srfi-11.scm (let-values): fix (a b c . d) case. Thanks Martin. --- srfi/ChangeLog | 4 ++++ srfi/srfi-11.scm | 40 ++++++++++++++++++++++++++++++---------- 2 files changed, 34 insertions(+), 10 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 40afe47b5..0692786ca 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,7 @@ +2001-05-02 Rob Browning + + * srfi-11.scm (let-values): fix (a b c . d) case. Thanks Martin. + 2001-05-02 Martin Grabmueller * Makefile.am (srfi_DATA): Added srfi-10.scm and srfi-17.scm. diff --git a/srfi/srfi-11.scm b/srfi/srfi-11.scm index e4910ac87..0caebab05 100644 --- a/srfi/srfi-11.scm +++ b/srfi/srfi-11.scm @@ -25,14 +25,14 @@ ;; ;; Current approach is to translate ;; -;; (let-values (((x y z) (foo a b)) +;; (let-values (((x y . z) (foo a b)) ;; ((p q) (bar c))) ;; (baz x y z p q)) ;; ;; into ;; ;; (call-with-values (lambda () (foo a b)) -;; (lambda ( ) +;; (lambda ( . ) ;; (call-with-values (lambda () (bar c)) ;; (lambda ( ) ;; (let ((x ) @@ -149,19 +149,39 @@ ;; broken -- right now (as of 1.4.1, it doesn't generate unique ;; symbols) (define-macro (let-values vars . body) - (define (let-values-helper vars body prev-tmps) + + (define (map-1-dot proc elts) + ;; map over one optionally dotted (a b c . d) list, producing an + ;; optionally dotted result. + (cond + ((null? elts) '()) + ((pair? elts) (cons (proc (car elts)) (map-1-dot proc (cdr elts)))) + (else (proc elts)))) + + (define (undot-list lst) + ;; produce a non-dotted list from a possibly dotted list. + (cond + ((null? lst) '()) + ((pair? lst) (cons (car lst) (undot-list (cdr lst)))) + (else (list lst)))) + + (define (let-values-helper vars body prev-let-vars) (let* ((var-binding (car vars)) - (new-tmps (map (lambda (sym) (list sym (gentemp))) - (car var-binding))) - (tmps (append new-tmps prev-tmps))) + (new-tmps (map-1-dot (lambda (sym) (gentemp)) + (car var-binding))) + (let-vars (map (lambda (sym tmp) (list sym tmp)) + (undot-list (car var-binding)) + (undot-list new-tmps)))) + (if (null? (cdr vars)) `(call-with-values (lambda () ,(cadr var-binding)) - (lambda ,(map cadr new-tmps) - (let ,tmps + (lambda ,new-tmps + (let ,(apply append let-vars prev-let-vars) ,@body))) `(call-with-values (lambda () ,(cadr var-binding)) - (lambda ,(map cadr new-tmps) - ,(let-values-helper (cdr vars) body tmps)))))) + (lambda ,new-tmps + ,(let-values-helper (cdr vars) body + (cons let-vars prev-let-vars))))))) (if (null? vars) `(begin ,@body) From c2c43dab1fbb81d26c7d1abc460da99f7d6174e1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 2 May 2001 21:42:28 +0000 Subject: [PATCH 0974/2047] * safe-r5rs.scm: Fix typo: make-rectangualr => make-rectangular. --- ice-9/ChangeLog | 4 ++++ ice-9/safe-r5rs.scm | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 0fe364029..3d32842cd 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2001-05-02 Martin Grabmueller + + * safe-r5rs.scm: Fix typo: make-rectangualr => make-rectangular. + 2001-05-02 Marius Vollmer * boot-9.scm (begin-deprecated): New. diff --git a/ice-9/safe-r5rs.scm b/ice-9/safe-r5rs.scm index 9f36feb35..ae7e4f82a 100644 --- a/ice-9/safe-r5rs.scm +++ b/ice-9/safe-r5rs.scm @@ -40,7 +40,7 @@ exp log sin cos tan asin acos atan sqrt expt - make-rectangualr make-polar real-part imag-part magnitude angle + make-rectangular make-polar real-part imag-part magnitude angle exact->inexact inexact->exact number->string string->number From 2d953700f66d3e5a72dd6fde05caf77ddda93a57 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 2 May 2001 21:47:36 +0000 Subject: [PATCH 0975/2047] * srfi-14.c, srfi-13.c: Added @bullet to various @itemize lists. * srfi-10.scm: Typo fix. --- srfi/ChangeLog | 6 ++++++ srfi/srfi-10.scm | 2 +- srfi/srfi-13.c | 8 ++++---- srfi/srfi-14.c | 4 ++-- 4 files changed, 13 insertions(+), 7 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 0692786ca..2b5eade25 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,9 @@ +2001-05-02 Martin Grabmueller + + * srfi-14.c, srfi-13.c: Added @bullet to various @itemize lists. + + * srfi-10.scm: Typo fix. + 2001-05-02 Rob Browning * srfi-11.scm (let-values): fix (a b c . d) case. Thanks Martin. diff --git a/srfi/srfi-10.scm b/srfi/srfi-10.scm index 0ce743af3..8efef2693 100644 --- a/srfi/srfi-10.scm +++ b/srfi/srfi-10.scm @@ -37,7 +37,7 @@ ;;; (define f '#,(file "/etc/passwd")) ;;; (read-line f) ;;; => -;;; :root:x:0:0:root:/root:/bin/bash" +;;; "root:x:0:0:root:/root:/bin/bash" ;;; ;;; Please note the quote before the #,(file ...) expression. This is ;;; necessary because ports are not self-evaluating in Guile. diff --git a/srfi/srfi-13.c b/srfi/srfi-13.c index b50ef085c..e7fe76c57 100644 --- a/srfi/srfi-13.c +++ b/srfi/srfi-13.c @@ -743,7 +743,7 @@ SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 0, "Trim @var{s} by skipping over all characters on both sides of\n" "the string that satisfy the parameter @var{char_pred}:\n" "\n" - "@itemize\n" + "@itemize @bullet\n" "@item\n" "if it is the character @var{ch}, characters equal to @var{ch}\n" "are trimmed,\n" @@ -1614,7 +1614,7 @@ SCM_DEFINE (scm_string_indexS, "string-index", 2, 2, 0, "Search through the string @var{s} from left to right, returning\n" "the index of the first occurence of a character which\n" "\n" - "@itemize\n" + "@itemize @bullet\n" "@item\n" "equals @var{char_pred}, if it is character,\n" "\n" @@ -2527,7 +2527,7 @@ SCM_DEFINE (scm_string_fold_right, "string-fold-right", 3, 2, 0, SCM_DEFINE (scm_string_unfold, "string-unfold", 4, 2, 0, (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final), - "@itemize\n" + "@itemize @bullet\n" "@item @var{g} is used to generate a series of @emph{seed}\n" "values from the initial @var{seed}: @var{seed}, (@var{g}\n" "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n" @@ -2589,7 +2589,7 @@ SCM_DEFINE (scm_string_unfold, "string-unfold", 4, 2, 0, SCM_DEFINE (scm_string_unfold_right, "string-unfold-right", 4, 2, 0, (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final), - "@itemize\n" + "@itemize @bullet\n" "@item @var{g} is used to generate a series of @emph{seed}\n" "values from the initial @var{seed}: @var{seed}, (@var{g}\n" "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n" diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index 3755608ca..9fb6b4847 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -305,7 +305,7 @@ SCM_DEFINE (scm_char_set_fold, "char-set-fold", 3, 0, 0, SCM_DEFINE (scm_char_set_unfold, "char-set-unfold", 4, 1, 0, (SCM p, SCM f, SCM g, SCM seed, SCM base_cs), "This is a fundamental constructor for character sets.\n" - "@itemize\n" + "@itemize @bullet\n" "@item @var{g} is used to generate a series of ``seed'' values \n" "from the initial seed: @var{seed}, (@var{g} @var{seed}),\n" "(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n" @@ -349,7 +349,7 @@ SCM_DEFINE (scm_char_set_unfold, "char-set-unfold", 4, 1, 0, SCM_DEFINE (scm_char_set_unfold_x, "char-set-unfold!", 5, 0, 0, (SCM p, SCM f, SCM g, SCM seed, SCM base_cs), "This is a fundamental constructor for character sets.\n" - "@itemize\n" + "@itemize @bullet\n" "@item @var{g} is used to generate a series of ``seed'' values\n" "from the initial seed: @var{seed}, (@var{g} @var{seed}), \n" "(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n" From fc8529c7668ad32dc83048e77b8bd7ed0af81b8e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 2 May 2001 21:50:15 +0000 Subject: [PATCH 0976/2047] * srfi-13-14.texi: Added @bullet to various @itemize lists. * srfi-modules.texi (SRFI Support): New file and chapter. * Makefile.am (guile_TEXINFOS): Added repl-modules.texi and srfi-modules.texi. * guile.texi (Top): New menu entries for the new chapters. (Top): @includes for the new chapters. (Top): New menu entry for `SRFI Support', @include for `srfi-modules.texi'. * repl-modules.texi: New file. (Readline Support): New chapter for (ice-9 readline). (Value History): New chapter for (ice-9 history). --- doc/ChangeLog | 18 + doc/Makefile.am | 3 +- doc/guile.texi | 7 +- doc/repl-modules.texi | 79 +++ doc/srfi-13-14.texi | 1093 ----------------------------------------- doc/srfi-modules.texi | 183 +++++++ 6 files changed, 288 insertions(+), 1095 deletions(-) create mode 100644 doc/repl-modules.texi create mode 100644 doc/srfi-modules.texi diff --git a/doc/ChangeLog b/doc/ChangeLog index b136680b9..d097ace4a 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,21 @@ +2001-05-02 Martin Grabmueller + + * srfi-13-14.texi: Added @bullet to various @itemize lists. + + * srfi-modules.texi (SRFI Support): New file and chapter. + + * Makefile.am (guile_TEXINFOS): Added repl-modules.texi and + srfi-modules.texi. + + * guile.texi (Top): New menu entries for the new chapters. + (Top): @includes for the new chapters. + (Top): New menu entry for `SRFI Support', @include for + `srfi-modules.texi'. + + * repl-modules.texi: New file. + (Readline Support): New chapter for (ice-9 readline). + (Value History): New chapter for (ice-9 history). + 2001-05-02 Martin Grabmueller * scheme-modules.texi (Dynamic Libraries): Renamed from `Dynamic diff --git a/doc/Makefile.am b/doc/Makefile.am index 9975477f7..c51cf392f 100644 --- a/doc/Makefile.am +++ b/doc/Makefile.am @@ -35,7 +35,8 @@ guile_TEXINFOS = preface.texi intro.texi scheme-intro.texi \ scheme-reading.texi scheme-indices.texi slib.texi posix.texi \ expect.texi scsh.texi tcltk.texi scripts.texi gh.texi scm.texi \ appendices.texi indices.texi script-getopt.texi data-rep.texi \ - extend.texi srfi-13-14.texi AUTHORS + extend.texi srfi-13-14.texi repl-modules.texi srfi-modules.texi \ + AUTHORS guile_tut_TEXINFOS = guile-tut.texi AUTHORS diff --git a/doc/guile.texi b/doc/guile.texi index a163dfaad..6c8c57338 100644 --- a/doc/guile.texi +++ b/doc/guile.texi @@ -80,7 +80,7 @@ by the Free Software Foundation. @sp 10 @comment The title is printed in a large font. @title Guile Reference Manual -@subtitle $Id: guile.texi,v 1.7 2001-04-28 23:38:52 ossau Exp $ +@subtitle $Id: guile.texi,v 1.8 2001-05-02 21:50:15 mgrabmue Exp $ @subtitle For use with Guile @value{VERSION} @include AUTHORS @@ -168,7 +168,10 @@ Part III: Guile Modules * SLIB:: Using the SLIB Scheme library. * POSIX:: POSIX system calls and networking. +* SRFI Support:: Support for various SRFIs. * SRFI-13/14:: String library and character set library. +* Readline Support:: Module for using the readline library. +* Value History:: Maintaining a value history in the REPL. * Expect:: Controlling interactive programs with Guile. * The Scheme shell (scsh):: The SCSH compatibility module has been made an @@ -249,7 +252,9 @@ Indices @include slib.texi @include posix.texi +@include srfi-modules.texi @include srfi-13-14.texi +@include repl-modules.texi @include expect.texi @include scsh.texi @include tcltk.texi diff --git a/doc/repl-modules.texi b/doc/repl-modules.texi new file mode 100644 index 000000000..3bf68ffc8 --- /dev/null +++ b/doc/repl-modules.texi @@ -0,0 +1,79 @@ +@node Readline Support +@chapter Readline Support + +@c FIXME::martin: Review me! + +@cindex readline +@cindex command line history +Guile comes with an interface module to the readline library. This +makes interactive use much more convenient, because of the command--line +editing features of readline. Using @code{(ice-9 readline)}, you can +navigate through the current input line with the cursor keys, retrieve +older command lines from the input history and even search through the +history entries. + +The module is not loaded by default and so has to be loaded and +activated explicitly. This is done with two simple lines of code: + +@lisp +(use-modules (ice-9 readline)) +(activate-readline) +@end lisp + +The first line will load the necessary code, and the second will +activate readline's features for the REPL. If you plan to use this +module often, you should save these to lines to your @file{.guile} +personal startup file. + +You will notice that the REPL's behaviour changes a bit when you have +loaded the readline module. For examle, when you press Enter before +typing in the closing parentheses of a list, you will see the +@dfn{continuation} prompt, three dots: @code{...} This gives you a nice +visual feedback when trying to match parentheses. To make this even +easier, @dfn{bouncing parentheses} are implemented. That means that +when you type in a closing parentheses, the cursor will jump to the +corresponding opening paren for a short time, making it trivial to make +them match. + +Once the readline module is activated, all lines entered interactively +will be stored in a history and can be recalled later using the +cursor-up and -down keys. Readline also understands the Emacs keys for +navigating through the command line and history. + +When you quit your Guile session by evaluating @code{(quit)} or pressing +Ctrl-D, the history will be saved to the file @file{.guile_history} and +read in when you start Guile for the next time. Thus you can start a +new Guile session and still have the (probably long--winded) definition +expressions available. + + +@node Value History +@chapter Value History + +@c FIXME::martin: Review me! + +@cindex value history +Another module which makes command line usage more convenient is +@code{(ice-9 history)}. This module will change the REPL so that each +value which is evaluated and printed will be remembered under a name +constructed from the dollar character (@code{$}) and the number of the +evaluated expression. + +Consider an example session. + +@example +guile> (use-modules (ice-9 history)) +guile> 1 +$1 = 1 +guile> (+ $1 $1) +$2 = 2 +guile> (* $2 $2) +$3 = 4 +@end example + +After loading the value history module @code{(ice-9 history)}, one +(trivial) expression is evaluated. The result is stored into the +variable @code{$1}. This fact is indicated by the output @code{$1 = }, +which is also caused by @code{(ice-9 history)}. In the next line, this +variable is used two times, to produce the value @code{$2}, which in +turn is used in the calculation for @code{$3}. diff --git a/doc/srfi-13-14.texi b/doc/srfi-13-14.texi index 8d96b9618..e69de29bb 100644 --- a/doc/srfi-13-14.texi +++ b/doc/srfi-13-14.texi @@ -1,1093 +0,0 @@ -@node SRFI-13/14 -@chapter SRFI-13 and SRFI-14 - -This chapter documents the SRFI-13/14 library, which provides the string -utility procedures defined in SRFI-13 and the character-set procedures -defined in SRFI-14 for Guile. - -@menu -* Introduction:: What is this all about? -* Loading SRFI-13/14:: Loading the module into a running Guile. -* String Functions:: Available string processing procedures. -* Character-set Procedures:: Procedures for manipulating character sets. -@end menu - - -@c =================================================================== - -@node Introduction -@section Introduction - -The SRFI-13/14 library is a shared library which provides the procedures -defined in SRFI-13 (string library) and the procedures defined in -SRFI-14 (character-set library). You should also refer to the SRFI -documents, which provide some details I will not document here. - -If you don't know what SRFI means, and what all the numbers are about, -you may want to refer to the SRFI home page at -@url{http://srfi.schemers.org}. - -Note that only the procedures from SRFI-13 are documented here which are -not already contained in Guile. For procedures not documented here -please refer to the relevant chapters in the Guile Reference Manual, for -example the documentation of strings and string procedures (REFFIXME). - -The SRFI-14 procedures are documented completely. - -@menu -* What can be done:: What is possible with SRFI-13/14 -* What cannot be done:: and what is not? -@end menu - - -@c =================================================================== - -@node What can be done -@subsection What can be done - -All of the procedures defined in SRFI-13, which are not already included -in the Guile core library, are implemented in the module @code{(srfi -srfi-13)}. The procedures which are both in Guile and in SRFI-13, but -which are slightly extended, have been implemented in this module, and -the bindings overwrite those in the Guile core. - -All procedures from SRFI-14 (character-set library) are implemented in -the module @code{(srfi srfi-14)}, as well as the standard variables -@code{char-set:letter}, @code{char-set:digit} etc. - - -@c =================================================================== - -@node What cannot be done -@subsection What cannot be done - -The procedures which are defined in the section @emph{Low-level -procedures} of SRFI-13 for parsing optional string indices, substring -specification checking and Knuth-Morris-Pratt-Searching are not -implemented. - -The procedures @code{string-contains} and @code{string-contains-ci} are -not implemented very efficiently at the moment. This will be changed as -soon as possible. - - -@c =================================================================== - -@node Loading SRFI-13/14 -@section Loading SRFI-13/14 - -When Guile is properly installed, it can be loaded into a running Guile -by using the @code{(srfi srfi-13)} module. - -@example -$ guile -guile> (use-modules (srfi srfi-13)) -guile> -@end example - -When this step causes any errors, Guile is not properly installed. - -One possible reason is that Guile cannot find either the Scheme module -file @file{srfi-13.scm}, or it cannot find the shared object file -@file{libguile-srfi-srfi-13-14.so}. Make sure that the former is in the -Guile load path and that the latter is either installed in some default -location like @file{/usr/local/lib} or that the directory it was -installed to is in your @code{LTDL_LIBRARY_PATH}. The same applies to -@file{srfi-14.scm}. - -Now you can test whether the SRFI-13 procedures are working by calling -the @code{string-concatenate} procedure. - -@example -guile> (string-concatenate '("Hello" " " "World!")) -"Hello World!" -@end example - -The same goes for the SRFI-14 module, of course. - -@example -$ guile -guile> (use-modules (srfi srfi-14)) -guile> (char-set-union (char-set #\f #\o #\o) (string->char-set "bar")) -# -guile> -@end example - - -@c =================================================================== - -@node String Functions -@section String Functions - -In this section, we will describe all procedures defined in SRFI-13 -(string library) and implemented by the module @code{(srfi srfi-13)}. - -Except for the procedures in the section @emph{Low-level procedures} of -SRFI-13, all string procedures defined there are implemented completely. - -@menu -* Predicates:: Testing strings. -* SRFI-13 Constructors:: Constructing strings. -* SRFI-13 List/String Conversion:: Converstion from/to character lists. -* SRFI-13 Selection:: Selecting portions from strings. -* SRFI-13 Modification:: Modifying string in--place. -* SRFI-13 Comparison:: Comparing strings. -* Prefixes/Suffixes:: Checking for common pre-/suffixes. -* Searching:: Searching in strings. -* Case Mapping:: Changing the case of strings. -* Reverse/Append:: Append, concatenate and reverse strings. -* Fold/Unfold/Map:: Fold/Unfold/Map over strings. -* Replicate/Rotate:: String replication and rotation. -* Miscellaneous:: Miscellaneous string procedures. -* Filtering/Deleting:: Deleting characters from strings. -@end menu - - -@c =================================================================== - -@node Predicates -@subsection Predicates - -In addition to the primitives @code{string?} and @code{string-null?}, -which are already in the Guile core, the string predicates -@code{string-any} and @code{string-every} are defined by SRFI-13. - -@deffn primitive string-any pred s [start end] -Check if the predicate @var{pred} is true for any character in -the string @var{s}, proceeding from left (index @var{start}) to -right (index @var{end}). If @code{string-any} returns true, -the returned true value is the one produced by the first -successful application of @var{pred}. -@end deffn - -@deffn primitive string-every pred s [start end] -Check if the predicate @var{pred} is true for every character -in the string @var{s}, proceeding from left (index @var{start}) -to right (index @var{end}). If @code{string-every} returns -true, the returned true value is the one produced by the final -application of @var{pred} to the last character of @var{s}. -@end deffn - - -@c =================================================================== - -@node SRFI-13 Constructors -@subsection Constructors - -SRFI-13 defines several procedures for constructing new strings. In -addition to @code{make-string} and @code{string} (available in the Guile -core library), the procedure @code{string-tabulate} does exist. - -@deffn primitive string-tabulate proc len -@var{proc} is an integer->char procedure. Construct a string -of size @var{len} by applying @var{proc} to each index to -produce the corresponding string element. The order in which -@var{proc} is applied to the indices is not specified. -@end deffn - - -@c =================================================================== - -@node SRFI-13 List/String Conversion -@subsection List/String Conversion - -The procedure @code{string->list} is extended by SRFI-13, that is why it -is included in @code{(srfi srfi-13)}. The other procedures are new. -The Guile core already contains the procedure @code{list->string} for -converting a list of characters into a string (REFFIXME). - -@deffn primitive string->list str [start end] -Convert the string @var{str} into a list of characters. -@end deffn - -@deffn primitive reverse-list->string chrs -An efficient implementation of @code{(compose string->list -reverse)}: - -@smalllisp -(reverse-list->string '(#\a #\B #\c)) @result{} "cBa" -@end smalllisp -@end deffn - -@deffn primitive string-join ls [delimiter grammar] -Append the string in the string list @var{ls}, using the string -@var{delim} as a delimiter between the elements of @var{ls}. -@var{grammar} is a symbol which specifies how the delimiter is -placed between the strings, and defaults to the symbol -@code{infix}. - -@table @code -@item infix -Insert the separator between list elements. An empty string -will produce an empty list. - -@item string-infix -Like @code{infix}, but will raise an error if given the empty -list. - -@item suffix -Insert the separator after every list element. - -@item prefix -Insert the separator before each list element. -@end table -@end deffn - - -@c =================================================================== - -@node SRFI-13 Selection -@subsection Selection - -These procedures are called @dfn{selectors}, because they access -information about the string or select pieces of a given string. - -Additional selector procedures are documented in the Strings section -(REFFIXME), like @code{string-length} or @code{string-ref}. - -@code{string-copy} is also available in core Guile, but this version -accepts additional start/end indices. - -@deffn primitive string-copy str [start end] -Return a freshly allocated copy of the string @var{str}. If -given, @var{start} and @var{end} delimit the portion of -@var{str} which is copied. -@end deffn - -@deffn primitive substring/shared str start [end] -Like @code{substring}, but the result may share memory with the -argument @var{str}. -@end deffn - -@deffn primitive string-copy! target tstart s [start end] -Copy the sequence of characters from index range [@var{start}, -@var{end}) in string @var{s} to string @var{target}, beginning -at index @var{tstart}. The characters are copied left-to-right -or right-to-left as needed -- the copy is guaranteed to work, -even if @var{target} and @var{s} are the same string. It is an -error if the copy operation runs off the end of the target -string. -@end deffn - -@deffn primitive string-take s n -@deffnx primitive string-take-right s n -Return the @var{n} first/last characters of @var{s}. -@end deffn - -@deffn primitive string-drop s n -@deffnx primitive string-drop-right s n -Return all but the first/last @var{n} characters of @var{s}. -@end deffn - -@deffn primitive string-pad s len [chr start end] -@deffnx primitive string-pad-right s len [chr start end] -Take that characters from @var{start} to @var{end} from the -string @var{s} and return a new string, right(left)-padded by the -character @var{chr} to length @var{len}. If the resulting -string is longer than @var{len}, it is truncated on the right (left). -@end deffn - -@deffn primitive string-trim s [char_pred start end] -@deffnx primitive string-trim-right s [char_pred start end] -@deffnx primitive string-trim-both s [char_pred start end] -Trim @var{s} by skipping over all characters on the left/right/both -sides of the string that satisfy the parameter @var{char_pred}: - -@itemize @bullet -@item -if it is the character @var{ch}, characters equal to -@var{ch} are trimmed, - -@item -if it is a procedure @var{pred} characters that -satisfy @var{pred} are trimmed, - -@item -if it is a character set, characters in that set are trimmed. -@end itemize - -If called without a @var{char_pred} argument, all whitespace is -trimmed. -@end deffn - - -@c =================================================================== - -@node SRFI-13 Modification -@subsection Modification - -The procedure @code{string-fill!} is extended from R5RS because it -accepts optional start/end indices. This bindings shadows the procedure -of the same name in the Guile core. The second modification procedure -@code{string-set!} is documented in the Strings section (REFFIXME). - -@deffn primitive string-fill! str chr [start end] -Stores @var{chr} in every element of the given @var{str} and -returns an unspecified value. -@end deffn - - -@c =================================================================== - -@node SRFI-13 Comparison -@subsection Comparison - -The procedures in this section are used for comparing strings in -different ways. The comparison predicates differ from those in R5RS in -that they do not only return @code{#t} or @code{#f}, but the mismatch -index in the case of a true return value. - -@code{string-hash} and @code{string-hash-ci} are for calculating hash -values for strings, useful for implementing fast lookup mechanisms. - -@deffn primitive string-compare s1 s2 proc_lt proc_eq proc_gt [start1 end1 start2 end2] -@deffnx primitive string-compare-ci s1 s2 proc_lt proc_eq proc_gt [start1 end1 start2 end2] -Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the -mismatch index, depending upon whether @var{s1} is less than, -equal to, or greater than @var{s2}. The mismatch index is the -largest index @var{i} such that for every 0 <= @var{j} < -@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is, -@var{i} is the first position that does not match. The -character comparison is done case-insensitively. -@end deffn - -@deffn primitive string= s1 s2 [start1 end1 start2 end2] -@deffnx primitive string<> s1 s2 [start1 end1 start2 end2] -@deffnx primitive string< s1 s2 [start1 end1 start2 end2] -@deffnx primitive string> s1 s2 [start1 end1 start2 end2] -@deffnx primitive string<= s1 s2 [start1 end1 start2 end2] -@deffnx primitive string>= s1 s2 [start1 end1 start2 end2] -Compare @var{s1} and @var{s2} and return @code{#f} if the predicate -fails. Otherwise, the mismatch index is returned (or @var{end1} in the -case of @code{string=}. -@end deffn - -@deffn primitive string-ci= s1 s2 [start1 end1 start2 end2] -@deffnx primitive string-ci<> s1 s2 [start1 end1 start2 end2] -@deffnx primitive string-ci< s1 s2 [start1 end1 start2 end2] -@deffnx primitive string-ci> s1 s2 [start1 end1 start2 end2] -@deffnx primitive string-ci<= s1 s2 [start1 end1 start2 end2] -@deffnx primitive string-ci>= s1 s2 [start1 end1 start2 end2] -Compare @var{s1} and @var{s2} and return @code{#f} if the predicate -fails. Otherwise, the mismatch index is returned (or @var{end1} in the -case of @code{string=}. These are the case-insensitive variants. -@end deffn - -@deffn primitive string-hash s [bound start end] -@deffnx primitive string-hash-ci s [bound start end] -Return a hash value of the string @var{s} in the range 0 @dots{} -@var{bound} - 1. @code{string-hash-ci} is the case-insensitive variant. -@end deffn - - -@c =================================================================== - -@node Prefixes/Suffixes -@subsection Prefixes/Suffixes - -Using these procedures you can determine whether a given string is a -prefix or suffix of another string or how long a common prefix/suffix -is. - -@deffn primitive string-prefix-length s1 s2 [start1 end1 start2 end2] -@deffnx primitive string-prefix-length-ci s1 s2 [start1 end1 start2 end2] -@deffnx primitive string-suffix-length s1 s2 [start1 end1 start2 end2] -@deffnx primitive string-suffix-length-ci s1 s2 [start1 end1 start2 end2] -Return the length of the longest common prefix/suffix of the two -strings. @code{string-prefix-length-ci} and -@code{string-suffix-length-ci} are the case-insensitive variants. -@end deffn - -@deffn primitive string-prefix? s1 s2 [start1 end1 start2 end2] -@deffnx primitive string-prefix-ci? s1 s2 [start1 end1 start2 end2] -@deffnx primitive string-suffix? s1 s2 [start1 end1 start2 end2] -@deffnx primitive string-suffix-ci? s1 s2 [start1 end1 start2 end2] -Is @var{s1} a prefix/suffix of @var{s2}. @code{string-prefix-ci?} and -@code{string-suffix-ci?} are the case-insensitive variants. -@end deffn - - -@c =================================================================== - -@node Searching -@subsection Searching - -Use these procedures to find out whether a string contains a given -character or a given substring, or a character from a set of characters. - -@deffn primitive string-index s char_pred [start end] -@deffnx primitive string-index-right s char_pred [start end] -Search through the string @var{s} from left to right (right to left), -returning the index of the first (last) occurence of a character which - -@itemize -@item -equals @var{char_pred}, if it is character, - -@item -satisifies the predicate @var{char_pred}, if it is a -procedure, - -@item -is in the set @var{char_pred}, if it is a character set. -@end itemize -@end deffn - -@deffn primitive string-skip s char_pred [start end] -@deffnx primitive string-skip-right s char_pred [start end] -Search through the string @var{s} from left to right (right to left), -returning the index of the first (last) occurence of a character which - -@itemize -@item -does not equal @var{char_pred}, if it is character, - -@item -does not satisify the predicate @var{char_pred}, if it is -a procedure. - -@item -is not in the set if @var{char_pred} is a character set. -@end itemize -@end deffn - -@deffn primitive string-count s char_pred [start end] -Return the count of the number of characters in the string -@var{s} which - -@itemize @bullet -@item -equals @var{char_pred}, if it is character, - -@item -satisifies the predicate @var{char_pred}, if it is a procedure. - -@item -is in the set @var{char_pred}, if it is a character set. -@end itemize -@end deffn - -@deffn primitive string-contains s1 s2 [start1 end1 start2 end2] -@deffnx primitive string-contains-ci s1 s2 [start1 end1 start2 end2] -Does string @var{s1} contain string @var{s2}? Return the index -in @var{s1} where @var{s2} occurs as a substring, or false. -The optional start/end indices restrict the operation to the -indicated substrings. - -@code{string-contains-ci} is the case-insensitive variant. -@end deffn - - -@c =================================================================== - -@node Case Mapping -@subsection Alphabetic Case Mapping - -These procedures convert the alphabetic case of strings. They are -similar to the procedures in the Guile core, but are extended to handle -optional start/end indices. - -@deffn primitive string-upcase s [start end] -@deffnx primitive string-upcase! s [start end] -Upcase every character in @var{s}. @code{string-upcase!} is the -side-effecting variant. -@end deffn - -@deffn primitive string-downcase s [start end] -@deffnx primitive string-downcase! s [start end] -Downcase every character in @var{s}. @code{string-downcase!} is the -side--effecting variant. -@end deffn - -@deffn primitive string-titlecase s [start end] -@deffnx primitive string-titlecase! s [start end] -Upcase every first character in every word in @var{s}, downcase the -other characters. @code{string-titlecase!} is the side--effecting -variant. -@end deffn - - -@c =================================================================== - -@node Reverse/Append -@subsection Reverse/Append - -One appending procedure, @code{string-append} is the same in R5RS and in -SRFI-13, so it is not redefined. - -@deffn primitive string-reverse str [start end] -@deffnx primitive string-reverse! str [start end] -Reverse the string @var{str}. The optional arguments -@var{start} and @var{end} delimit the region of @var{str} to -operate on. - -@code{string-reverse!} modifies the argument string and returns an -unspecified value. -@end deffn - -@deffn primitive string-append/shared ls @dots{} -Like @code{string-append}, but the result may share memory -with the argument strings. -@end deffn - -@deffn primitive string-concatenate ls -Append the elements of @var{ls} (which must be strings) -together into a single string. Guaranteed to return a freshly -allocated string. -@end deffn - -@deffn primitive string-concatenate/shared ls -Like @code{string-concatenate}, but the result may share memory -with the strings in the list @var{ls}. -@end deffn - -@deffn primitive string-concatenate-reverse ls final_string end -Without optional arguments, this procedure is equivalent to - -@smalllisp -(string-concatenate (reverse ls)) -@end smalllisp - -If the optional argument @var{final_string} is specified, it is -consed onto the beginning to @var{ls} before performing the -list-reverse and string-concatenate operations. If @var{end} -is given, only the characters of @var{final_string} up to index -@var{end} are used. - -Guaranteed to return a freshly allocated string. -@end deffn - -@deffn primitive string-concatenate-reverse/shared ls final_string end -Like @code{string-concatenate-reverse}, but the result may -share memory with the the strings in the @var{ls} arguments. -@end deffn - - -@c =================================================================== - -@node Fold/Unfold/Map -@subsection Fold/Unfold/Map - -@code{string-map}, @code{string-for-each} etc. are for iterating over -the characters a string is composed of. The fold and unfold procedures -are list iterators and constructors. - -@deffn primitive string-map proc s [start end] -@var{proc} is a char->char procedure, it is mapped over -@var{s}. The order in which the procedure is applied to the -string elements is not specified. -@end deffn - -@deffn primitive string-map! proc s [start end] -@var{proc} is a char->char procedure, it is mapped over -@var{s}. The order in which the procedure is applied to the -string elements is not specified. The string @var{s} is -modified in-place, the return value is not specified. -@end deffn - -@deffn primitive string-fold kons knil s [start end] -@deffnx primitive string-fold-right kons knil s [start end] -Fold @var{kons} over the characters of @var{s}, with @var{knil} as the -terminating element, from left to right (or right to left, for -@code{string-fold-right}). @var{kons} must expect two arguments: The -actual character and the last result of @var{kons}' application. -@end deffn - -@deffn primitive string-unfold p f g seed [base make_final] -@deffnx primitive string-unfold-right p f g seed [base make_final] -These are the fundamental string constructors. -@itemize -@item @var{g} is used to generate a series of @emph{seed} -values from the initial @var{seed}: @var{seed}, (@var{g} -@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), -@dots{} -@item @var{p} tells us when to stop -- when it returns true -when applied to one of these seed values. -@item @var{f} maps each seed value to the corresponding -character in the result string. These chars are assembled into the -string in a left-to-right (right-to-left) order. -@item @var{base} is the optional initial/leftmost (rightmost) - portion of the constructed string; it default to the empty string. -@item @var{make_final} is applied to the terminal seed -value (on which @var{p} returns true) to produce the final/rightmost -(leftmost) portion of the constructed string. It defaults to -@code{(lambda (x) "")}. -@end itemize -@end deffn - -@deffn primitive string-for-each proc s [start end] -@var{proc} is mapped over @var{s} in left-to-right order. The -return value is not specified. -@end deffn - - -@c =================================================================== - -@node Replicate/Rotate -@subsection Replicate/Rotate - -These procedures are special substring procedures, which can also be -used for replicating strings. They are a bit tricky to use, but -consider this code fragment, which replicates the input string -@code{"foo"} so often that the resulting string has a length of six. - -@lisp -(xsubstring "foo" 0 6) -@result{} -"foofoo" -@end lisp - -@deffn primitive xsubstring s from [to start end] -This is the @emph{extended substring} procedure that implements -replicated copying of a substring of some string. - -@var{s} is a string, @var{start} and @var{end} are optional -arguments that demarcate a substring of @var{s}, defaulting to -0 and the length of @var{s}. Replicate this substring up and -down index space, in both the positive and negative directions. -@code{xsubstring} returns the substring of this string -beginning at index @var{from}, and ending at @var{to}, which -defaults to @var{from} + (@var{end} - @var{start}). -@end deffn - -@deffn primitive string-xcopy! target tstart s sfrom [sto start end] -Exactly the same as @code{xsubstring}, but the extracted text -is written into the string @var{target} starting at index -@var{tstart}. The operation is not defined if @code{(eq? -@var{target} @var{s})} or these arguments share storage -- you -cannot copy a string on top of itself. -@end deffn - - -@c =================================================================== - -@node Miscellaneous -@subsection Miscellaneous - -@code{string-replace} is for replacing a portion of a string with -another string and @code{string-tokenize} splits a string into a list of -strings, breaking it up at a specified character. - -@deffn primitive string-replace s1 s2 [start1 end1 start2 end2] -Return the string @var{s1}, but with the characters -@var{start1} @dots{} @var{end1} replaced by the characters -@var{start2} @dots{} @var{end2} from @var{s2}. -@end deffn - -@deffn primitive string-tokenize s [token_char start end] -Split the string @var{s} into a list of substrings, where each -substring is a maximal non-empty contiguous sequence of -characters equal to the character @var{token_char}, or -whitespace, if @var{token_char} is not given. If -@var{token_char} is a character set, it is used for finding the -token borders. -@end deffn - - -@c =================================================================== - -@node Filtering/Deleting -@subsection Filtering/Deleting - -@dfn{Filtering} means to remove all characters from a string which do -not match a given criteria, @dfn{deleting} means the opposite. - -@deffn primitive string-filter s char_pred [start end] -Filter the string @var{s}, retaining only those characters that -satisfy the @var{char_pred} argument. If the argument is a -procedure, it is applied to each character as a predicate, if -it is a character, it is tested for equality and if it is a -character set, it is tested for membership. -@end deffn - -@deffn primitive string-delete s char_pred [start end] -Filter the string @var{s}, retaining only those characters that -do not satisfy the @var{char_pred} argument. If the argument -is a procedure, it is applied to each character as a predicate, -if it is a character, it is tested for equality and if it is a -character set, it is tested for membership. -@end deffn - - -@c =================================================================== - -@node Character-set Procedures -@section Character-set Procedures - -SRFI-14 defines the data type @dfn{character set}, and also defines a -lot of procedures for handling this character type, and a few standard -character sets like whitespace, alphabetic characters and others. - -@menu -* Character Set Data Type:: Description of the character set data type. -* Predicates/Comparison:: Testing character sets. -* Iterating Over Character Sets:: Iterating over the members of a set. -* Creating Character Sets:: Creating new character sets. -* Querying Character Sets:: Extracting information from character sets. -* Character-Set Algebra:: Set-algebra on character sets. -* Standard Character Sets:: Variables containg standard character sets. -@end menu - - -@c =================================================================== - -@node Character Set Data Type -@subsection Character Set Data Type - -The data type @dfn{charset} implements sets of characters (REFFIXME). -Because the internal representation of character sets is not visible to -the user, a lot of procedures for handling them are provided. - -Character sets can be created, extended, tested for the membership of a -characters and be compared to other character sets. - -The Guile implementation of character sets deals with 8-bit characters. -In the standard variables, only the ASCII part of the character range is -really used, so that for example @dfn{Umlaute} and other accented -characters are not considered to be letters. In the future, as Guile -may get support for international character sets, this will change, so -don't rely on these ``features''. - - -@c =================================================================== - -@node Predicates/Comparison -@subsection Predicates/Comparison - -Use these procedures for testing whether an object is a character set, -or whether several character sets are equal or subsets of each other. -@code{char-set-hash} can be used for calculating a hash value, maybe for -usage in fast lookup procedures. - -@deffn primitive char-set? obj -Return @code{#t} if @var{obj} is a character set, @code{#f} -otherwise. -@end deffn - -@deffn primitive char-set= cs1 @dots{} -Return @code{#t} if all given character sets are equal. -@end deffn - -@deffn primitive char-set<= cs1 @dots{} -Return @code{#t} if every character set @var{cs}i is a subset -of character set @var{cs}i+1. -@end deffn - -@deffn primitive char-set-hash cs [bound] -Compute a hash value for the character set @var{cs}. If -@var{bound} is given and not @code{#f}, it restricts the -returned value to the range 0 @dots{} @var{bound - 1}. -@end deffn - - -@c =================================================================== - -@node Iterating Over Character Sets -@subsection Iterating Over Character Sets - -Character set cursors are a means for iterating over the members of a -character sets. After creating a character set cursor with -@code{char-set-cursor}, a cursor can be dereferenced with -@code{char-set-ref}, advanced to the next member with -@code{char-set-cursor-next}. Whether a cursor has passed past the last -element of the set can be checked with @code{end-of-char-set?}. - -Additionally, mapping and (un-)folding procedures for character sets are -provided. - -@deffn primitive char-set-cursor cs -Return a cursor into the character set @var{cs}. -@end deffn - -@deffn primitive char-set-ref cs cursor -Return the character at the current cursor position -@var{cursor} in the character set @var{cs}. It is an error to -pass a cursor for which @code{end-of-char-set?} returns true. -@end deffn - -@deffn primitive char-set-cursor-next cs cursor -Advance the character set cursor @var{cursor} to the next -character in the character set @var{cs}. It is an error if the -cursor given satisfies @code{end-of-char-set?}. -@end deffn - -@deffn primitive end-of-char-set? cursor -Return @code{#t} if @var{cursor} has reached the end of a -character set, @code{#f} otherwise. -@end deffn - -@deffn primitive char-set-fold kons knil cs -Fold the procedure @var{kons} over the character set @var{cs}, -initializing it with @var{knil}. -@end deffn - -@deffn primitive char-set-unfold p f g seed [base_cs] -@deffnx primitive char-set-unfold! p f g seed base_cs -This is a fundamental constructor for character sets. -@itemize -@item @var{g} is used to generate a series of ``seed'' values -from the initial seed: @var{seed}, (@var{g} @var{seed}), -(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{} -@item @var{p} tells us when to stop -- when it returns true -when applied to one of the seed values. -@item @var{f} maps each seed value to a character. These -characters are added to the base character set @var{base_cs} to -form the result; @var{base_cs} defaults to the empty set. -@end itemize - -@code{char-set-unfold!} is the side-effecting variant. -@end deffn - -@deffn primitive char-set-for-each proc cs -Apply @var{proc} to every character in the character set -@var{cs}. The return value is not specified. -@end deffn - -@deffn primitive char-set-map proc cs -Map the procedure @var{proc} over every character in @var{cs}. -@var{proc} must be a character -> character procedure. -@end deffn - - -@c =================================================================== - -@node Creating Character Sets -@subsection Creating Character Sets - -New character sets are produced with these procedures. - -@deffn primitive char-set-copy cs -Return a newly allocated character set containing all -characters in @var{cs}. -@end deffn - -@deffn primitive char-set char1 @dots{} -Return a character set containing all given characters. -@end deffn - -@deffn primitive list->char-set char_list [base_cs] -@deffnx primitive list->char-set! char_list base_cs -Convert the character list @var{list} to a character set. If -the character set @var{base_cs} is given, the character in this -set are also included in the result. - -@code{list->char-set!} is the side-effecting variant. -@end deffn - -@deffn primitive string->char-set s [base_cs] -@deffnx primitive string->char-set! s base_cs -Convert the string @var{str} to a character set. If the -character set @var{base_cs} is given, the characters in this -set are also included in the result. - -@code{string->char-set!} is the side-effecting variant. -@end deffn - -@deffn primitive char-set-filter pred cs [base_cs] -@deffnx primitive char-set-filter! pred cs base_cs -Return a character set containing every character from @var{cs} -so that it satisfies @var{pred}. If provided, the characters -from @var{base_cs} are added to the result. - -@code{char-set-filter!} is the side-effecting variant. -@end deffn - -@deffn primitive ucs-range->char-set lower upper [error? base_cs] -@deffnx primitive uce-range->char-set! lower upper error? base_cs -Return a character set containing all characters whose -character codes lie in the half-open range -[@var{lower},@var{upper}). - -If @var{error} is a true value, an error is signalled if the -specified range contains characters which are not contained in -the implemented character range. If @var{error} is @code{#f}, -these characters are silently left out of the resultung -character set. - -The characters in @var{base_cs} are added to the result, if -given. - -@code{ucs-range->char-set!} is the side-effecting variant. -@end deffn - -@deffn procedure ->char-set x -Coerce @var{x} into a character set. @var{x} may be a string, a -character or a character set. -@end deffn - - -@c =================================================================== - -@node Querying Character Sets -@subsection Querying Character Sets - -Access the elements and other information of a character set with these -procedures. - -@deffn primitive char-set-size cs -Return the number of elements in character set @var{cs}. -@end deffn - -@deffn primitive char-set-count pred cs -Return the number of the elements int the character set -@var{cs} which satisfy the predicate @var{pred}. -@end deffn - -@deffn primitive char-set->list cs -Return a list containing the elements of the character set -@var{cs}. -@end deffn - -@deffn primitive char-set->string cs -Return a string containing the elements of the character set -@var{cs}. The order in which the characters are placed in the -string is not defined. -@end deffn - -@deffn primitive char-set-contains? cs char -Return @code{#t} iff the character @var{ch} is contained in the -character set @var{cs}. -@end deffn - -@deffn primitive char-set-every pred cs -Return a true value if every character in the character set -@var{cs} satisfies the predicate @var{pred}. -@end deffn - -@deffn primitive char-set-any pred cs -Return a true value if any character in the character set -@var{cs} satisfies the predicate @var{pred}. -@end deffn - - -@c =================================================================== - -@node Character-Set Algebra -@subsection Character-Set Algebra - -Character sets can be manipulated with the common set algebra operation, -such as union, complement, intersection etc. All of these procedures -provide side--effecting variants, which modify their character set -argument(s). - -@deffn primitive char-set-adjoin cs char1 @dots{} -@deffnx primitive char-set-adjoin! cs char1 @dots{} -Add all character arguments to the first argument, which must -be a character set. -@end deffn - -@deffn primitive char-set-delete cs char1 @dots{} -@deffnx primitive char-set-delete! cs char1 @dots{} -Delete all character arguments from the first argument, which -must be a character set. -@end deffn - -@deffn primitive char-set-complement cs -@deffnx primitive char-set-complement! cs -Return the complement of the character set @var{cs}. -@end deffn - -@deffn primitive char-set-union cs1 @dots{} -@deffnx primitive char-set-union! cs1 @dots{} -Return the union of all argument character sets. -@end deffn - -@deffn primitive char-set-intersection cs1 @dots{} -@deffnx primitive char-set-intersection! cs1 @dots{} -Return the intersection of all argument character sets. -@end deffn - -@deffn primitive char-set-difference cs1 @dots{} -@deffnx primitive char-set-difference! cs1 @dots{} -Return the difference of all argument character sets. -@end deffn - -@deffn primitive char-set-xor cs1 @dots{} -@deffnx primitive char-set-xor! cs1 @dots{} -Return the exclusive--or of all argument character sets. -@end deffn - -@deffn primitive char-set-diff+intersection cs1 @dots{} -@deffnx primitive char-set-diff+intersection! cs1 @dots{} -Return the difference and the intersection of all argument -character sets. -@end deffn - - -@c =================================================================== - -@node Standard Character Sets -@subsection Standard Character Sets - -In order to make the use of the character set data type and procedures -useful, several predefined character set variables exist. - -@defvar char-set:lower-case -All lower--case characters. -@end defvar - -@defvar char-set:upper-case -All upper--case characters. -@end defvar - -@defvar char-set:title-case -This is empty, because ASCII has no titlecase characters. -@end defvar - -@defvar char-set:letter -All letters, e.g. the union of @code{char-set:lower-case} and -@code{char-set:upper-case}. -@end defvar - -@defvar char-set:digit -All digits. -@end defvar - -@defvar char-set:letter+digit -The union of @code{char-set:letter} and @code{char-set:digit}. -@end defvar - -@defvar char-set:graphic -All characters which would put ink on the paper. -@end defvar - -@defvar char-set:printing -The union of @code{char-set:graphic} and @code{char-set:whitespace}. -@end defvar - -@defvar char-set:whitespace -All whitespace characters. -@end defvar - -@defvar char-set:blank -All horizontal whitespace characters, that is @code{#\space} and -@code{#\tab}. -@end defvar - -@defvar char-set:iso-control -The ISO control characters with the codes 0--31 and 127. -@end defvar - -@defvar char-set:punctuation -The characters @code{!"#%&'()*,-./:;?@@[\\]_@{@}} -@end defvar - -@defvar char-set:symbol -The characters @code{$+<=>^`|~}. -@end defvar - -@defvar char-set:hex-digit -The hexadecimal digits @code{0123456789abcdefABCDEF}. -@end defvar - -@defvar char-set:ascii -All ASCII characters. -@end defvar - -@defvar char-set:empty -The empty character set. -@end defvar - -@defvar char-set:full -This character set contains all possible characters. -@end defvar diff --git a/doc/srfi-modules.texi b/doc/srfi-modules.texi new file mode 100644 index 000000000..e611414c9 --- /dev/null +++ b/doc/srfi-modules.texi @@ -0,0 +1,183 @@ +@node SRFI Support +@chapter Various SRFI Support Modules + +In addition to the string and character--set libraries --- documented in +the next chapter --- Guile has support for a number of SRFIs. This +chapter gives an overview over the available SRFIs and some usage hints. +For complete documentation, we advise you to get the relevant SRFI +documents from the SRFI home page @url{http://srfi.schemers.org}. + +@menu +* SRFI-2:: and-let*. +* SRFI-6:: Basic String Ports. +* SRFI-8:: receive. +* SRFI-9:: define-record-type. +* SRFI-10:: Hash--Comma Reader Extension. +* SRFI-11:: let-values and let-values*. +* SRFI-17:: Generalized set! +@end menu + + +@node SRFI-2 +@section SRFI-2 -- and-let* + +The syntactic form @code{and-let*} combines the conditional evaluation +form @code{and} with the binding form @var{let*}. Each argument +expression will be evaluated sequentially, bound to a variable (if a +variable name is given), but only as long as no expression returns +the false value @code{#f}. + +Use @code{(use-modules (srfi srfi-2)} to access this syntax form. + + +@node SRFI-6 +@section SRFI-6 -- Basic String Ports + +SRFI-6 defines the procedures @code{open-input-string}, +@code{open-output-string} and @code{get-output-string}. These +procedures are included in the Guile core, so using this module does not +make any difference at the moment. But it is possible that support for +SRFI-6 will be factored out of the core library in the future, so using +this module does not hurt, after all. + +@node SRFI-8 +@section SRFI-8 -- receive + +@code{receive} is a syntax for making the handling of multiple--value +procedures easier. It is documented in @xref{Multiple Values}. + + +@node SRFI-9 +@section SRFI-9 -- define-record-type + +This is the SRFI way for defining record types. The Guile +implementation is a layer above Guile's normal record construction +procedures (REFFIXME). The nice thing about this kind of record +definition method is that no new names are implicitly created, all +constructor, accessor and predicates are explicitly given. This reduces +the risk of variable capture. + +The syntax of a record type definition is: + +@example + + -> (define-record-type + ( ...) + + ...) + -> ( ) + -> ( ) + -> +<... name> -> +@end example + +Usage example: + +@example +guile> (use-modules (srfi srfi-9)) +guile> (define-record-type :foo (make-foo x) foo? + (x get-x) (y get-y set-y!)) +guile> (define f (make-foo 1)) +guile> f +#<:foo x: 1 y: #f> +guile> (get-x f) +1 +guile> (set-y! f 2) +2 +guile> (get-y f) +2 +guile> f +#<:foo x: 1 y: 2> +guile> (foo? f) +#t +guile> (foo? 1) +#f +@end example + + +@node SRFI-10 +@section SRFI-10 -- Hash--Comma Reader Extension + +@cindex hash--comma +@cindex #,() +The module @code{(srfi srfi-10)} implements the syntax extension +@code{#,()}, also called hash-comma, which is defined in SRFI-10. + +The support for SRFI-10 consists of the procedure +@code{define-reader-ctor} for defining new reader constructors and the +read syntax form + +@example +#,(@var{ctor} @var{datum} ...) +@end example + +where @var{ctor} must be a symbol for which a read constructor was +defined previouly, using @code{define-reader-ctor}. + +Example: + +@lisp +(define-reader-ctor 'file open-input-file) +(define f '#,(file "/etc/passwd")) +(read-line f) +@result{} +"root:x:0:0:root:/root:/bin/bash" +@end lisp + +Please note the quote before the @code{#,(file ...)} expression. This +is necessary because ports are not self-evaluating in Guile. + +@deffn procedure define-reader-ctor symbol proc +Define @var{proc} as the reader constructor for hash--comma forms with a +tag @var{symbol}. @var{proc} will be applied to the datum(s) following +the tag in the hash--comma expression after the complete form has been +read in. The result of @var{proc} is returned by the Scheme reader. +@end deffn + + +@node SRFI-11 +@section SRFI-11 -- let-values + +This module implements the binding forms for multiple values +@code{let-values} and @code{let-values*}. These forms are similar to +@code{let} and @code{let*} (REFFIXME), but they support binding of the +values returned by multiple--valued expressions. + +Write @code{(use-modules (srfi srfi-11))} to make the bindings +available. + +@lisp +(let-values (((x y) (values 1 2)) + ((z f) (values 3 4))) + (+ x y z f)) +@result{} +10 +@end lisp + +@code{let-values} performs all bindings simultaneously, which means that +no expression in the binding clauses may refer to variables bound in the +same clause list. @code{let-values*}, on the other hand, performs the +bindings sequentially, just like @code{let*} does for single--valued +expressions. + + +@node SRFI-17 +@section SRFI-17 -- Generalized set! + +This is an implementation of SRFI-17: Generalized set! + +It exports the Guile procedure @code{make-procedure-with-setter} under +the SRFI name @code{getter-with-setter} and exports the standard +procedures @code{car}, @code{cdr}, @dots{}, @code{cdddr}, +@code{string-ref} and @code{vector-ref} as procedures with setters, as +required by the SRFI. + +SRFI-17 was heavily criticized during its discussion period but it was +finalized anyway. One issue was its concept of globally associating +setter @dfn{properties} with (procedure) values, which is non-Schemy. +For this reason, this implementation chooses not to provide a way to set +the setter of a procedure. In fact, @code{(set! (setter @var{proc}) +@var{setter})} signals an error. The only way to attach a setter to a +procedure is to create a new object (a @dfn{procedure with setter}) via +the @code{getter-with-setter} procedure. This procedure is also +specified in the SRFI. Using it avoids the described problems. From a29bd01993b8fbf26309cdcbabdfd74b90b3df07 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Wed, 2 May 2001 22:11:35 +0000 Subject: [PATCH 0977/2047] Added --disable-static. --- INSTALL | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/INSTALL b/INSTALL index fc6516953..c87ec4f90 100644 --- a/INSTALL +++ b/INSTALL @@ -104,9 +104,10 @@ switches specific to Guile you may find useful in some circumstances. --disable-shared --- Do not build shared libraries. +--disable-static --- Do not build static libraries. - Normally, Guile will build shared libraries if your system supports - them. Guile always builds static libraries. + Normally, both static and shared libraries will be built if your + system supports them. --enable-debug-freelist --- Enable freelist debugging. From 1db8171ab30ea2eb2d56dfeab368d96dfaa87dcd Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Wed, 2 May 2001 22:51:49 +0000 Subject: [PATCH 0978/2047] Added more text to --enable-deprecated, because it's confusing stuff. --- INSTALL | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/INSTALL b/INSTALL index c87ec4f90..458b9c168 100644 --- a/INSTALL +++ b/INSTALL @@ -100,7 +100,26 @@ switches specific to Guile you may find useful in some circumstances. try to use them. All other values will include all deprecated features. The LEVEL argument is used as the default value for the environment variable GUILE_WARN_DEPRECATED. See the README for - documentation about this. + more information. + + The default is to get a vague warning at program exit if deprecated + features were used: + + --enable-deprecated=yes + --enable-deprecated=summary + + To get a detailed warning at first use of a deprecated feature: + + --enable-deprecated=detailed + + To get no warnings: + + [ FIXME: this doesn't seem to be possible, without setting the + environment variable ] + + To omit deprecated features completely and irrevokably: + + --enable-deprecated=no --disable-shared --- Do not build shared libraries. From 21d12a62e14a8ce2892ed9d41b5ed7e77e0bd535 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 2 May 2001 22:55:33 +0000 Subject: [PATCH 0979/2047] Updated section about deprecating features. --- HACKING | 28 +++++++++++++++++++--------- 1 file changed, 19 insertions(+), 9 deletions(-) diff --git a/HACKING b/HACKING index 3aac223ae..929e185f6 100644 --- a/HACKING +++ b/HACKING @@ -185,18 +185,28 @@ When deprecating a definition, always follow this procedure: 1. Mark the definition using -#if (SCM_DEBUG_DEPRECATED == 0) -... -#endif + #if (SCM_DEBUG_DEPRECATED == 0) + ... + #endif -2. Write a comment at the definition explaining how a programmer -can manage without the deprecated definition. + or, for Scheme code, wrap it using -3. Add an entry that the definition has been deprecated in NEWS + (begin-deprecated + ...) -4. At the top of RELEASE, there is a list of releases with reminders -about what to do at each release. Add a reminder about the removal of -the deprecated defintion at the appropriate release. +2. Make the deprecated code issue a warning when it is used, by using + scm_c_issue_deprecation_warning (in C) or issue-deprecation-warning + (in Scheme). + +3. Write a comment at the definition explaining how a programmer can + manage without the deprecated definition. + +4. Add an entry that the definition has been deprecated in NEWS and + explain what do do instead. + +5. At the top of RELEASE, there is a list of releases with reminders + about what to do at each release. Add a reminder about the removal + of the deprecated defintion at the appropriate release. - When you make a user-visible change (i.e. one that should be documented, and appear in NEWS, put an asterisk in column zero of the From c5316ea33f912587da0045c4873ac3e777307561 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Thu, 3 May 2001 23:41:44 +0000 Subject: [PATCH 0980/2047] * configure.in: check whether uint32_t is defined when netdb.h is included. acconfig.h: added HAVE_UINT32_T. --- ChangeLog | 6 ++++++ acconfig.h | 3 +++ configure.in | 10 ++++++++++ 3 files changed, 19 insertions(+) diff --git a/ChangeLog b/ChangeLog index c944900fb..46ac5bff8 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2001-05-04 Gary Houston + + * configure.in: check whether uint32_t is defined when netdb.h + is included. + acconfig.h: added HAVE_UINT32_T. + 2001-05-02 Marius Vollmer * configure.in: Added handling of `--enable-deprecated'. diff --git a/acconfig.h b/acconfig.h index b7e588d27..fa3d8d5c7 100644 --- a/acconfig.h +++ b/acconfig.h @@ -116,6 +116,9 @@ /* Define if h_errno is declared in netdb.h. */ #undef HAVE_H_ERRNO +/* Define if uint32_t typedef is defined when netdb.h is include. */ +#undef HAVE_UINT32_T + /* Define if localtime caches the TZ setting. */ #undef LOCALTIME_CACHE diff --git a/configure.in b/configure.in index 45a880765..6fb73a2c9 100644 --- a/configure.in +++ b/configure.in @@ -277,6 +277,16 @@ if test $guile_cv_have_h_errno = yes; then AC_DEFINE(HAVE_H_ERRNO) fi +AC_MSG_CHECKING(whether netdb.h defines uint32_t) +AC_CACHE_VAL(guile_cv_have_uint32_t, +[AC_TRY_COMPILE([#include ], +[uint32_t a;], +guile_cv_have_uint32_t=yes, guile_cv_have_uint32_t=no)]) +AC_MSG_RESULT($guile_cv_have_uint32_t) +if test $guile_cv_have_uint32_t = yes; then + AC_DEFINE(HAVE_UINT32_T) +fi + # included in rfc2553 but not in older implementations, e.g., glibc 2.1.3. AC_MSG_CHECKING(whether sockaddr_in6 has sin6_scope_id) AC_CACHE_VAL(guile_cv_have_sin6_scope_id, From 0012013017feb6064b6e767b30cd3f499ec960a8 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Thu, 3 May 2001 23:42:31 +0000 Subject: [PATCH 0981/2047] * socket.c: define uint32_t if netdb.h doesn't. thanks to Dale P. Smith. --- libguile/ChangeLog | 5 +++++ libguile/socket.c | 10 ++++++++++ 2 files changed, 15 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index db6ebcbb5..a21b2562f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-05-04 Gary Houston + + * socket.c: define uint32_t if netdb.h doesn't. thanks to + Dale P. Smith. + 2001-05-02 Marius Vollmer * rw.c: Include "modules.h" and "strports.h". diff --git a/libguile/socket.c b/libguile/socket.c index 88270373a..4e60d16f6 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -76,6 +76,16 @@ + strlen ((ptr)->sun_path)) #endif +#if !defined (HAVE_UINT32_T) +#if SIZEOF_INT == 4 +typedef unsigned int uint32_t; +#elif SIZEOF_LONG == 4 +typedef unsigned long uint32_t; +#else +#error can not define uint32_t +#endif +#endif + /* we are not currently using socklen_t. it's not defined on all systems, so would need to be checked by configure. in the meantime, plain int is the best alternative. */ From 76f944c3ca6b870e721a4058563f5284571bea53 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 4 May 2001 04:57:39 +0000 Subject: [PATCH 0982/2047] * scheme-io.texi (Block Reading and Writing): Moved the documentation for read-string!/partial from the node `Reading'. * scheme-data.texi (List/String Conversion): Added docstring for `string-split'. --- doc/ChangeLog | 8 ++++++ doc/scheme-data.texi | 21 ++++++++++++++ doc/scheme-io.texi | 67 +++++++++++++++++++++----------------------- 3 files changed, 61 insertions(+), 35 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index d097ace4a..4a1fffb51 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,11 @@ +2001-05-04 Martin Grabmueller + + * scheme-io.texi (Block Reading and Writing): Moved the + documentation for read-string!/partial from the node `Reading'. + + * scheme-data.texi (List/String Conversion): Added docstring for + `string-split'. + 2001-05-02 Martin Grabmueller * srfi-13-14.texi: Added @bullet to various @itemize lists. diff --git a/doc/scheme-data.texi b/doc/scheme-data.texi index 88b331a28..3032a02d1 100755 --- a/doc/scheme-data.texi +++ b/doc/scheme-data.texi @@ -1436,6 +1436,27 @@ the given string @var{str}. @code{string->list} and concerned. @end deffn +@deffn primitive string-split str chr +Split the string @var{str} into the a list of the substrings delimited +by appearances of the character @var{chr}. Note that an empty substring +between separator characters will result in an empty string in the +result list. +@lisp +(string-split "root:x:0:0:root:/root:/bin/bash" #\:) +@result{} +("root" "x" "0" "0" "root" "/root" "/bin/bash") + +(string-split "::" #\:) +@result{} +("" "" "") + +(string-split "" #\:) +@result{} +("") +@end lisp +@end deffn + + @node String Selection @subsection String Selection diff --git a/doc/scheme-io.texi b/doc/scheme-io.texi index 809b5f135..3562e57ba 100644 --- a/doc/scheme-io.texi +++ b/doc/scheme-io.texi @@ -141,41 +141,6 @@ Set the current column or line number of @var{port}, using the current input port if none is specified. @end deffn -@deffn primitive read-string!/partial str [port_or_fdes [start [end]]] -Read characters from an fport or file descriptor into a -string @var{str}. This procedure is scsh-compatible -and can efficiently read large strings. It will: - -@itemize -@item -attempt to fill the entire string, unless the @var{start} -and/or @var{end} arguments are supplied. i.e., @var{start} -defaults to 0 and @var{end} defaults to -@code{(string-length str)} -@item -use the current input port if @var{port_or_fdes} is not -supplied. -@item -read any characters that are currently available, -without waiting for the rest (short reads are possible). - -@item -wait for as long as it needs to for the first character to -become available, unless the port is in non-blocking mode -@item -return @code{#f} if end-of-file is encountered before reading -any characters, otherwise return the number of characters -read. -@item -return 0 if the port is in non-blocking mode and no characters -are immediately available. -@item -return 0 if the request is for 0 bytes, with no -end-of-file check -@end itemize -@end deffn - - @node Writing @section Writing @@ -442,8 +407,40 @@ It currently contains a single procedure which helps implement the @code{(scsh rw)} module in guile-scsh. @deffn primitive read-string!/partial str [port_or_fdes] [start] [end] +Read characters from an fport or file descriptor into a +string @var{str}. This procedure is scsh-compatible +and can efficiently read large strings. It will: + +@itemize +@item +attempt to fill the entire string, unless the @var{start} +and/or @var{end} arguments are supplied. i.e., @var{start} +defaults to 0 and @var{end} defaults to +@code{(string-length str)} +@item +use the current input port if @var{port_or_fdes} is not +supplied. +@item +read any characters that are currently available, +without waiting for the rest (short reads are possible). + +@item +wait for as long as it needs to for the first character to +become available, unless the port is in non-blocking mode +@item +return @code{#f} if end-of-file is encountered before reading +any characters, otherwise return the number of characters +read. +@item +return 0 if the port is in non-blocking mode and no characters +are immediately available. +@item +return 0 if the request is for 0 bytes, with no +end-of-file check +@end itemize @end deffn + @node Default Ports @section Default Ports for Input, Output and Errors From dd2a6f3ac634bcd3d8b73f4d1c948f8442da9082 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 4 May 2001 04:59:05 +0000 Subject: [PATCH 0983/2047] * strop.c (scm_string_split): New procedure. * strop.h (scm_string_split): Added prototype. --- libguile/ChangeLog | 6 ++++++ libguile/strop.c | 49 ++++++++++++++++++++++++++++++++++++++++++++++ libguile/strop.h | 1 + 3 files changed, 56 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index a21b2562f..cc9b7ad64 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2001-05-04 Martin Grabmueller + + * strop.c (scm_string_split): New procedure. + + * strop.h (scm_string_split): Added prototype. + 2001-05-04 Gary Houston * socket.c: define uint32_t if netdb.h doesn't. thanks to diff --git a/libguile/strop.c b/libguile/strop.c index 48f3c33b6..037b2bd60 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -509,6 +509,55 @@ SCM_DEFINE (scm_string_capitalize, "string-capitalize", 1, 0, 0, #undef FUNC_NAME +SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0, + (SCM str, SCM chr), + "Split the string @var{str} into the a list of the substrings delimited\n" + "by appearances of the character @var{chr}. Note that an empty substring\n" + "between separator characters will result in an empty string in the\n" + "result list.\n" + "\n" + "@lisp\n" + "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\:)\n" + "@result{}\n" + "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n" + "\n" + "(string-split \"::\" #\:)\n" + "@result{}\n" + "(\"\" \"\" \"\")\n" + "\n" + "(string-split \"\" #\:)\n" + "@result{}\n" + "(\"\")\n" + "@end lisp") +#define FUNC_NAME s_scm_string_split +{ + int idx, last_idx; + char * p; + int ch; + SCM res = SCM_EOL; + + SCM_VALIDATE_STRING (1, str); + SCM_VALIDATE_CHAR (2, chr); + + idx = SCM_STRING_LENGTH (str); + p = SCM_STRING_CHARS (str); + ch = SCM_CHAR (chr); + while (idx >= 0) + { + last_idx = idx; + while (idx > 0 && p[idx - 1] != ch) + idx--; + if (idx >= 0) + { + res = scm_cons (scm_makfromstr (p + idx, last_idx - idx, 0), res); + idx--; + } + } + return res; +} +#undef FUNC_NAME + + SCM_DEFINE (scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0, (SCM str), "Return the symbol whose name is @var{str}. @var{str} is\n" diff --git a/libguile/strop.h b/libguile/strop.h index acd1928ed..45a3ecb84 100644 --- a/libguile/strop.h +++ b/libguile/strop.h @@ -64,6 +64,7 @@ extern SCM scm_string_downcase_x (SCM v); extern SCM scm_string_downcase (SCM v); extern SCM scm_string_capitalize_x (SCM v); extern SCM scm_string_capitalize (SCM v); +extern SCM scm_string_split (SCM str, SCM chr); extern SCM scm_string_ci_to_symbol (SCM v); #define scm_substring_move_left_x scm_substring_move_x From 5366cbbeab5be1be5f6a773238e121e7d2774842 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 4 May 2001 05:01:51 +0000 Subject: [PATCH 0984/2047] *** empty log message *** --- AUTHORS | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/AUTHORS b/AUTHORS index 9f323c6a9..bea86d356 100644 --- a/AUTHORS +++ b/AUTHORS @@ -102,7 +102,12 @@ In the subdirectory srfi, wrote the initial files for: Martin Grabmueller: In the subdirectory srfi, wrote: srfi-9.scm + srfi-10.scm srfi-13.scm srfi-14.scm srfi-13.c srfi-14.c +In the subdirectory doc, wrote: + srfi-modules.texi + srfi-13-14.texi + repl-modules.texi From c83cf54eada9ce90fd3ea18b7e5a2d2664393458 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 4 May 2001 14:42:25 +0000 Subject: [PATCH 0985/2047] Mention checking of deprecation mechanism. It's important that it is in 1.6.0 and works. --- RELEASE | 3 +++ 1 file changed, 3 insertions(+) diff --git a/RELEASE b/RELEASE index 8ed8be4e5..c462887fa 100644 --- a/RELEASE +++ b/RELEASE @@ -17,6 +17,9 @@ After signal handling and threading have been fixed: === In release 1.6.0: +- Make sure that the deprecation mechanism explained in INSTALL and + README is completed and works. + - Q: Was SCM_FLOBUFLEN only deprecated publically, or was it supposed to be removed from numbers.c as well? From 7e1cd073f7d29109e1314b7680c2c48243cb65cd Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 4 May 2001 20:26:48 +0000 Subject: [PATCH 0986/2047] Initial revision --- guile-tools.in | 101 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 101 insertions(+) create mode 100644 guile-tools.in diff --git a/guile-tools.in b/guile-tools.in new file mode 100644 index 000000000..21bcafa7d --- /dev/null +++ b/guile-tools.in @@ -0,0 +1,101 @@ +#!/bin/sh + +# Copyright (C) 2001 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +# the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +# Boston, MA 02111-1307 USA + +# Usage: guile-tools --version +# guile-tools --help +# guile-tools [OPTION] PROGRAM [ARGS] +# +# PROGRAM is run w/ ARGS. To see a list of available programs, use +# "guile-tools --help" to find the default scripts directory and then +# do a "ls" on that directory. Or just read the source 14 lines below. +# +# Options (only one of which may be used at a time): +# --scriptsdir DIR -- Look in DIR for scripts +# --guileversion VERS -- Look in $pkgdatadir/VERS/scripts for scripts +# +# TODO +# - handle pre-install invocation +# - "full" option processing (but see comment below) +# +# Author: Thien-Thi Nguyen + +prefix="@prefix@" +pkgdatadir="@datadir@/@PACKAGE@" +guileversion="@GUILE_VERSION@" +default_scriptsdir=$pkgdatadir/$guileversion/scripts + +# pre-install invocation frob +mydir=`dirname $0` +if [ -d "$mydir/scripts" -a -f "$mydir/scripts/Makefile.am" ] ; then + default_scriptsdir=`(cd $mydir/scripts ; pwd)` +fi + +help () +{ + echo "$0 [--scriptsdir DIR | --guileversion VERSION] PROGRAM [ARGS]" + echo default scriptsdir: $default_scriptsdir +} + +# option processing -- basically, you can override either the script dir +# completely, or just the guile version. we choose implementation simplicity +# over orthogonality. + +if [ x"$1" = x--version ] ; then + echo $0 $guileversion + exit 0 +fi + +if [ x"$1" = x--help -o x"$1" = x ] ; then + help + exit 0 +fi + +if [ x"$1" = x--scriptsdir ] ; then + user_scriptsdir=$2 + shift + shift +elif [ x"$1" = x--guileversion ] ; then + user_scriptsdir=$pkgdatadir/$2/scripts + shift + shift +fi + +scriptsdir=${user_scriptsdir-$default_scriptsdir} + +if [ ! -d $scriptsdir ] ; then + echo $0: no such directory: $scriptsdir + exit 1 +fi + +if [ x"$1" = x ] ; then + help + exit 1 +fi + +program=$scriptsdir/$1 +shift + +if [ -x $program ] ; then + exec $program "$@" +else + echo $0: no such program: $program + exit 1 +fi + +# guile-tools ends here From 01e5e07e868857517e381e19c220cb4cb687d4c2 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 4 May 2001 20:28:25 +0000 Subject: [PATCH 0987/2047] (AC_OUTPUT): Add guile-tools, and make executable. --- configure.in | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/configure.in b/configure.in index 6fb73a2c9..19b606377 100644 --- a/configure.in +++ b/configure.in @@ -225,7 +225,7 @@ AC_CHECK_LIB(crypt, crypt) AC_DEFUN(GUILE_FUNC_DECLARED, [ AC_CACHE_CHECK(for $1 declaration, guile_cv_func_$1_declared, AC_EGREP_HEADER($1, $2, - guile_cv_func_$1_declared=yes, + guile_cv_func_$1_declared=yes, guile_cv_func_$1_declared=no)) if test [x$guile_cv_func_]$1[_declared] = xno; then AC_DEFINE([MISSING_]translit($1, [a-z], [A-Z])[_DECL]) @@ -386,7 +386,7 @@ AC_STRUCT_ST_RDEV AC_STRUCT_ST_BLKSIZE # We could use AC_STRUCT_ST_BLOCKS here, but that adds fileblocks.o to -# LIBOBJS, which we don't need. This seems more direct. +# LIBOBJS, which we don't need. This seems more direct. AC_CACHE_CHECK([for st_blocks in struct stat], ac_cv_struct_st_blocks, [AC_TRY_COMPILE([#include #include ], [struct stat s; s.st_blocks;], @@ -417,7 +417,7 @@ GUILE_STRUCT_UTIMBUF AC_TRY_RUN(aux (l) unsigned long l; { int x; exit (l >= ((unsigned long)&x)); } - main () { int q; aux((unsigned long)&q); }, + main () { int q; aux((unsigned long)&q); }, AC_DEFINE(SCM_STACK_GROWS_UP),,AC_MSG_WARN(Guessing that stack grows down -- see scmconfig.h.in)) AC_CACHE_CHECK([whether floats fit in longs], guile_cv_type_float_fits_long, @@ -591,8 +591,9 @@ AC_OUTPUT([Makefile qt/time/Makefile guile-config/Makefile doc/Makefile - check-guile], - [chmod +x libguile/guile-snarf libguile/guile-doc-snarf libguile/guile-func-name-check check-guile]) + check-guile + guile-tools], + [chmod +x libguile/guile-snarf libguile/guile-doc-snarf libguile/guile-func-name-check check-guile guile-tools]) dnl Local Variables: dnl comment-start: "dnl " From 629d3a80f63ac4ec90eab7325e7eb3e609d24bd4 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 4 May 2001 20:29:11 +0000 Subject: [PATCH 0988/2047] (bin_SCRIPTS): New var. --- Makefile.am | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Makefile.am b/Makefile.am index 21cb5f833..69c6cfc4f 100644 --- a/Makefile.am +++ b/Makefile.am @@ -22,6 +22,8 @@ SUBDIRS = ice-9 oop qt libltdl libguile guile-config guile-readline \ scripts srfi doc +bin_SCRIPTS = guile-tools + include_HEADERS = libguile.h EXTRA_DIST = qthreads.m4 HACKING GUILE-VERSION ANON-CVS SNAPSHOTS From 26f798bdb22b341e9c260463cfe21972a56e81db Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 4 May 2001 20:33:02 +0000 Subject: [PATCH 0989/2047] *** empty log message *** --- ChangeLog | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/ChangeLog b/ChangeLog index 46ac5bff8..13f606a9c 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +2001-05-04 Thien-Thi Nguyen + + * guile-tools.in: New file. + + * configure.in (AC_OUTPUT): Add guile-tools, and make + executable. + + * Makefile.am (bin_SCRIPTS): New var. + 2001-05-04 Gary Houston * configure.in: check whether uint32_t is defined when netdb.h From 54c17ccbf70c8ba0e516f0756568c5129a01c503 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 4 May 2001 20:45:19 +0000 Subject: [PATCH 0990/2047] *** empty log message *** --- NEWS | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/NEWS b/NEWS index 7f6aa8469..f01839ee1 100644 --- a/NEWS +++ b/NEWS @@ -62,6 +62,14 @@ also be executable as scripts. At this time, these scripts are available: See README there for more info. +These scripts can be invoked from the shell with the new program +"guile-tools", which keeps track of installation directory for you. +For example: + + $ guile-tools display-commentary srfi/*.scm + +guile-tools is copied to the standard $bindir on "make install". + ** New module (ice-9 stack-catch): stack-catch is like catch, but saves the current state of the stack in From b77e2f28d145866443841045654cfbebe3860f9f Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 4 May 2001 20:59:16 +0000 Subject: [PATCH 0991/2047] *** empty log message *** --- emacs/guile.el | 2 ++ 1 file changed, 2 insertions(+) diff --git a/emacs/guile.el b/emacs/guile.el index 743c10cd8..3bf1463ab 100644 --- a/emacs/guile.el +++ b/emacs/guile.el @@ -19,6 +19,8 @@ ;;; Code: +(require 'cl) + ;;; ;;; Low level interface ;;; From 14e94b6096d29e8fdd063c2e523f7abeae542624 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 4 May 2001 21:01:35 +0000 Subject: [PATCH 0992/2047] (iff): Use proper texi markup. Thanks to Florian Weimer. --- doc/preface.texi | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/doc/preface.texi b/doc/preface.texi index 23d07752f..3c0ab509b 100644 --- a/doc/preface.texi +++ b/doc/preface.texi @@ -140,11 +140,13 @@ We use some conventions in this manual. @itemize @bullet @item -For some procedures, notably type predicates, we use "iff" to mean -"if and only if". The construct is usually something like: "Return -VAL iff CONDITION", where VAL is usually "#t" or "non-#f". This -typically means that VAL is returned if CONDITION holds, and that #f is -returned otherwise. +For some procedures, notably type predicates, we use @dfn{iff} to +mean `if and only if'. The construct is usually something like: +`Return @var{val} iff @var{condition}', where @var{val} is usually +`@code{#t}' or `non-@code{#f}'. This typically means that @var{val} +is returned if @var{condition} holds, and that @samp{#f} is returned +otherwise. +@cindex iff @c Add other conventions here. From f92a9df0ff2a0a93153745e27677d59841ac650b Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 4 May 2001 21:03:43 +0000 Subject: [PATCH 0993/2047] *** empty log message *** --- doc/ChangeLog | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 4a1fffb51..d8ea4fc32 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,8 @@ +2001-05-04 Thien-Thi Nguyen + + * preface.texi (iff): Use proper texi markup. + Thanks to Florian Weimer. + 2001-05-04 Martin Grabmueller * scheme-io.texi (Block Reading and Writing): Moved the @@ -56,7 +61,7 @@ expired. * guile.texi (Top): Add menu entry for Manual Conventions node. - + 2001-04-28 Neil Jerram * THANKS: Move authorship bit into AUTHORS, simplify structure, From 7a095584a9bc80eafb9563d1b83b40d9e1f372bf Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 4 May 2001 21:54:00 +0000 Subject: [PATCH 0994/2047] * eval.c (scm_promise_p), list.c (scm_append_x, scm_reverse_x), symbols.c (scm_symbol_to_string), vports.c (scm_make_soft_port): Change R4RS references to R5RS. * guile-snarf.awk.in: Fixes so that (i) blank lines in the docstring source are correctly reproduced in the output (ii) we don't anymore get occasional trailing quotes. Also reorganized and commented the code a little. * scmsigs.c (scm_raise), throw.c (scm_throw): Docstring format fixes. * new-docstrings.texi, posix.texi, scheme-control.texi, scheme-data.texi, scheme-debug.texi, scheme-evaluation.texi, scheme-io.texi, scheme-memory.texi, scheme-procedures.texi: Automatic docstring updates (mostly argument name updates and blank lines). * scheme-modules.texi: Change double hyphens to single. * scheme-control.texi (Lazy Catch): Completed. * posix.texi (Network Databases and Address Conversion): New subsubsection `IPv6 Address Conversion'. --- doc/ChangeLog | 15 + doc/maint/guile.texi | 626 ++++++++++++++++++++++-------------- doc/new-docstrings.texi | 494 ---------------------------- doc/posix.texi | 238 +++++++++----- doc/scheme-control.texi | 112 ++++++- doc/scheme-data.texi | 29 ++ doc/scheme-debug.texi | 2 +- doc/scheme-evaluation.texi | 2 +- doc/scheme-io.texi | 9 + doc/scheme-memory.texi | 221 ------------- doc/scheme-modules.texi | 22 +- doc/scheme-procedures.texi | 2 + libguile/ChangeLog | 14 + libguile/eval.c | 2 +- libguile/guile-snarf.awk.in | 40 ++- libguile/list.c | 6 +- libguile/scmsigs.c | 1 - libguile/symbols.c | 2 +- libguile/throw.c | 2 +- libguile/vports.c | 2 +- 20 files changed, 765 insertions(+), 1076 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index d8ea4fc32..5bbc58bd3 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,18 @@ +2001-05-04 Neil Jerram + + * new-docstrings.texi, posix.texi, scheme-control.texi, + scheme-data.texi, scheme-debug.texi, scheme-evaluation.texi, + scheme-io.texi, scheme-memory.texi, scheme-procedures.texi: + Automatic docstring updates (mostly argument name updates and + blank lines). + + * scheme-modules.texi: Change double hyphens to single. + + * scheme-control.texi (Lazy Catch): Completed. + + * posix.texi (Network Databases and Address Conversion): New + subsubsection `IPv6 Address Conversion'. + 2001-05-04 Thien-Thi Nguyen * preface.texi (iff): Use proper texi markup. diff --git a/doc/maint/guile.texi b/doc/maint/guile.texi index 13d681dad..622fbba08 100644 --- a/doc/maint/guile.texi +++ b/doc/maint/guile.texi @@ -462,6 +462,23 @@ is implicit). Return @code{#t} if @var{obj} is a debug object. @end deffn + issue-deprecation-warning +@c snarfed from deprecation.c:78 +@deffn primitive issue-deprecation-warning . msgs +Output @var{msgs} to @code{(current-error-port)} when this +is the first call to @code{issue-deprecation-warning} with +this specific @var{msg}. Do nothing otherwise. +The argument @var{msgs} should be a list of strings; +they are printed in turn, each one followed by a newline. +@end deffn + + include-deprecated-features +@c snarfed from deprecation.c:120 +@deffn primitive include-deprecated-features +Return @code{#t} iff deprecated features should be included +in public interfaces. +@end deffn + c-registered-modules @c snarfed from dynl.c:183 @deffn primitive c-registered-modules @@ -562,6 +579,7 @@ converted to a Scheme number and returned from the call to All three arguments must be 0-argument procedures. @var{in_guard} is called, then @var{thunk}, then @var{out_guard}. + If, any time during the execution of @var{thunk}, the continuation of the @code{dynamic_wind} expression is escaped non-locally, @var{out_guard} is called. If the continuation of @@ -578,15 +596,18 @@ times. ;; in-guard: ;; (lambda () (set! x 'special-binding)) + ;; thunk ;; (lambda () (display x) (newline) (call-with-current-continuation escape) (display x) (newline) x) + ;; out-guard: ;; (lambda () (set! x old-x))))))) + ;; Prints: special-binding ;; Evaluates to: @@ -1051,14 +1072,14 @@ any other object. @end deffn primitive-eval -@c snarfed from eval.c:3940 +@c snarfed from eval.c:3938 @deffn primitive primitive-eval exp Evaluate @var{exp} in the top-level environment specified by the current module. @end deffn eval -@c snarfed from eval.c:4009 +@c snarfed from eval.c:4007 @deffn primitive eval exp module Evaluate @var{exp}, a list representing a Scheme expression, in the top-level environment specified by @var{module}. @@ -1068,10 +1089,10 @@ is reset to its previous value when @var{eval} returns. @end deffn eval2 -@c snarfed from eval.c:4052 +@c snarfed from eval.c:4051 @deffn primitive eval2 obj env_thunk Evaluate @var{exp}, a Scheme expression, in the environment -designated by @var{lookup}, a symbol-lookup function." +designated by @var{lookup}, a symbol-lookup function. Do not use this version of eval, it does not play well with the module system. Use @code{eval} or @code{primitive-eval} instead. @@ -1219,9 +1240,11 @@ determined by @var{obj}. @var{obj} can be a string containing a file name or a port or integer file descriptor which is open on a file (in which case @code{fstat} is used as the underlying system call). + The object returned by @code{stat} can be passed as a single parameter to the following procedures, all of which return integers: + @table @code @item stat:dev The device containing the file. @@ -1256,8 +1279,10 @@ bytes. The amount of disk space that the file occupies measured in units of 512 byte blocks. @end table + In addition, the following procedures return the information from stat:mode in a more convenient form: + @table @code @item stat:type A symbol representing the type of file. Possible values are @@ -2136,6 +2161,7 @@ function, but uses @var{hash} as a hash function and 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-ref table key} is equivalent to @code{hashx-ref hashq assq table key}. @end deffn @@ -2149,6 +2175,7 @@ function, but uses @var{hash} as a hash function and 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 @@ -2228,61 +2255,19 @@ last. Convert the procedure list of @var{hook} to a list. @end deffn - read-string!/partial -@c snarfed from ioext.c:114 -@deffn primitive read-string!/partial str [port_or_fdes [start [end]]] -Read characters from an fport or file descriptor into a -string @var{str}. This procedure is scsh-compatible -and can efficiently read large strings. It will: - -@itemize -@item -attempt to fill the entire string, unless the @var{start} -and/or @var{end} arguments are supplied. i.e., @var{start} -defaults to 0 and @var{end} defaults to -@code{(string-length str)} -@item -use the current input port if @var{port_or_fdes} is not -supplied. -@item -read any characters that are currently available, -without waiting for the rest (short reads are possible). - -@item -wait for as long as it needs to for the first character to -become available, unless the port is in non-blocking mode -@item -return @code{#f} if end-of-file is encountered before reading -any characters, otherwise return the number of characters -read. -@item -return 0 if the port is in non-blocking mode and no characters -are immediately available. -@item -return 0 if the request is for 0 bytes, with no -end-of-file check -@end itemize -@end deffn - ftell -@c snarfed from ioext.c:174 +@c snarfed from ioext.c:71 @deffn primitive ftell fd_port Return an integer representing the current position of @var{fd/port}, measured from the beginning. Equivalent to: + @lisp (seek port 0 SEEK_CUR) @end lisp @end deffn - fseek -@c snarfed from ioext.c:187 -@deffn primitive fseek fd_port offset whence -Obsolete. Almost the same as @code{seek}, but the return value -is unspecified. -@end deffn - redirect-port -@c snarfed from ioext.c:209 +@c snarfed from ioext.c:89 @deffn primitive redirect-port old new This procedure takes two ports and duplicates the underlying file descriptor from @var{old-port} into @var{new-port}. The @@ -2300,7 +2285,7 @@ revealed counts. @end deffn dup->fdes -@c snarfed from ioext.c:248 +@c snarfed from ioext.c:128 @deffn primitive dup->fdes fd_or_port [fd] Return a new integer file descriptor referring to the open file designated by @var{fd_or_port}, which must be either an open @@ -2308,7 +2293,7 @@ file port or a file descriptor. @end deffn dup2 -@c snarfed from ioext.c:295 +@c snarfed from ioext.c:175 @deffn primitive dup2 oldfd newfd A simple wrapper for the @code{dup2} system call. Copies the file descriptor @var{oldfd} to descriptor @@ -2321,21 +2306,21 @@ The return value is unspecified. @end deffn fileno -@c snarfed from ioext.c:314 +@c snarfed from ioext.c:194 @deffn primitive fileno port Return the integer file descriptor underlying @var{port}. Does not change its revealed count. @end deffn isatty? -@c snarfed from ioext.c:330 +@c snarfed from ioext.c:210 @deffn primitive isatty? port Return @code{#t} if @var{port} is using a serial non--file device, otherwise @code{#f}. @end deffn fdopen -@c snarfed from ioext.c:352 +@c snarfed from ioext.c:232 @deffn primitive fdopen fdes modes Return a new port based on the file descriptor @var{fdes}. Modes are given by the string @var{modes}. The revealed count @@ -2344,7 +2329,7 @@ same as that accepted by @ref{File Ports, open-file}. @end deffn primitive-move->fdes -@c snarfed from ioext.c:377 +@c snarfed from ioext.c:257 @deffn primitive primitive-move->fdes port fd Moves the underlying file descriptor for @var{port} to the integer value @var{fdes} without changing the revealed count of @var{port}. @@ -2355,7 +2340,7 @@ required value or @code{#t} if it was moved. @end deffn fdes->ports -@c snarfed from ioext.c:411 +@c snarfed from ioext.c:291 @deffn primitive fdes->ports fd Return a list of existing ports which have @var{fdes} as an underlying file descriptor, without changing their revealed @@ -2807,6 +2792,7 @@ result of applying @var{code} to the expression and the environment. The value returned from @var{code} which has been passed to @code{procedure->memoizing-macro} replaces the form passed to @var{code}. For example: + @lisp (define trace (procedure->macro @@ -2825,6 +2811,7 @@ result of applying @var{proc} to the expression and the environment. The value returned from @var{proc} which has been passed to @code{procedure->memoizing-macro} replaces the form passed to @var{proc}. For example: + @lisp (define trace (procedure->macro @@ -2863,8 +2850,21 @@ Return the name of the macro @var{m}. Return the transformer of the macro @var{m}. @end deffn + current-module +@c snarfed from modules.c:78 +@deffn primitive current-module +Return the current module. +@end deffn + + set-current-module +@c snarfed from modules.c:95 +@deffn primitive set-current-module module +Set the current module to @var{module} and return +the previous current module. +@end deffn + interaction-environment -@c snarfed from modules.c:102 +@c snarfed from modules.c:128 @deffn primitive interaction-environment Return a specifier for the environment that contains implementation--defined bindings, typically a superset of those @@ -2874,64 +2874,13 @@ evaluate expressions dynamically typed by the user. @end deffn standard-eval-closure -@c snarfed from modules.c:271 +@c snarfed from modules.c:312 @deffn primitive standard-eval-closure module Return an eval closure for the module @var{module}. @end deffn - inet-aton -@c snarfed from net_db.c:96 -@deffn primitive inet-aton address -Converts a string containing an Internet host address in the -traditional dotted decimal notation into an integer. -@lisp -(inet-aton "127.0.0.1") @result{} 2130706433 -@end lisp -@end deffn - - inet-ntoa -@c snarfed from net_db.c:116 -@deffn primitive inet-ntoa inetid -Converts an integer Internet host address into a string with -the traditional dotted decimal representation. -@lisp -(inet-ntoa 2130706433) @result{} "127.0.0.1" -@end lisp -@end deffn - - inet-netof -@c snarfed from net_db.c:136 -@deffn primitive inet-netof address -Return the network number part of the given integer Internet -address. -@lisp -(inet-netof 2130706433) @result{} 127 -@end lisp -@end deffn - - inet-lnaof -@c snarfed from net_db.c:153 -@deffn primitive inet-lnaof address -Return the local-address-with-network part of the given -Internet address. -@lisp -(inet-lnaof 2130706433) @result{} 1 -@end lisp -@end deffn - - inet-makeaddr -@c snarfed from net_db.c:171 -@deffn primitive inet-makeaddr net lna -Makes an Internet host address by combining the network number -@var{net} with the local-address-within-network number -@var{lna}. -@lisp -(inet-makeaddr 127 1) @result{} 2130706433 -@end lisp -@end deffn - gethost -@c snarfed from net_db.c:256 +@c snarfed from net_db.c:146 @deffn primitive gethost [host] @deffnx procedure gethostbyname hostname @deffnx procedure gethostbyaddr address @@ -2947,7 +2896,7 @@ Unusual conditions may result in errors thrown to the @end deffn getnet -@c snarfed from net_db.c:337 +@c snarfed from net_db.c:227 @deffn primitive getnet [net] @deffnx procedure getnetbyname net-name @deffnx procedure getnetbyaddr net-number @@ -2959,7 +2908,7 @@ given. @end deffn getproto -@c snarfed from net_db.c:387 +@c snarfed from net_db.c:277 @deffn primitive getproto [protocol] @deffnx procedure getprotobyname name @deffnx procedure getprotobynumber number @@ -2970,7 +2919,7 @@ argument. @code{getproto} will accept either type, behaving like @end deffn getserv -@c snarfed from net_db.c:454 +@c snarfed from net_db.c:344 @deffn primitive getserv [name [protocol]] @deffnx procedure getservbyname name protocol @deffnx procedure getservbyport port protocol @@ -2985,59 +2934,60 @@ as its first argument; if given no arguments, it behaves like @end deffn sethost -@c snarfed from net_db.c:493 +@c snarfed from net_db.c:383 @deffn primitive sethost [stayopen] If @var{stayopen} is omitted, this is equivalent to @code{endhostent}. Otherwise it is equivalent to @code{sethostent stayopen}. @end deffn setnet -@c snarfed from net_db.c:509 +@c snarfed from net_db.c:399 @deffn primitive setnet [stayopen] If @var{stayopen} is omitted, this is equivalent to @code{endnetent}. Otherwise it is equivalent to @code{setnetent stayopen}. @end deffn setproto -@c snarfed from net_db.c:525 +@c snarfed from net_db.c:415 @deffn primitive setproto [stayopen] If @var{stayopen} is omitted, this is equivalent to @code{endprotoent}. Otherwise it is equivalent to @code{setprotoent stayopen}. @end deffn setserv -@c snarfed from net_db.c:541 +@c snarfed from net_db.c:431 @deffn primitive setserv [stayopen] If @var{stayopen} is omitted, this is equivalent to @code{endservent}. Otherwise it is equivalent to @code{setservent stayopen}. @end deffn exact? -@c snarfed from numbers.c:106 +@c snarfed from numbers.c:107 @deffn primitive exact? x Return @code{#t} if @var{x} is an exact number, @code{#f} otherwise. @end deffn odd? -@c snarfed from numbers.c:123 +@c snarfed from numbers.c:124 @deffn primitive odd? n Return @code{#t} if @var{n} is an odd number, @code{#f} otherwise. @end deffn even? -@c snarfed from numbers.c:140 +@c snarfed from numbers.c:141 @deffn primitive even? n Return @code{#t} if @var{n} is an even number, @code{#f} otherwise. @end deffn logand -@c snarfed from numbers.c:755 +@c snarfed from numbers.c:756 @deffn primitive logand n1 n2 Return the integer which is the bit-wise AND of the two integer arguments. + @lisp (number->string (logand #b1100 #b1010) 2) @result{} "1000" @@ -3045,10 +2995,11 @@ arguments. @end deffn logior -@c snarfed from numbers.c:842 +@c snarfed from numbers.c:843 @deffn primitive logior n1 n2 Return the integer which is the bit-wise OR of the two integer arguments. + @lisp (number->string (logior #b1100 #b1010) 2) @result{} "1110" @@ -3056,10 +3007,11 @@ arguments. @end deffn logxor -@c snarfed from numbers.c:928 +@c snarfed from numbers.c:929 @deffn primitive logxor n1 n2 Return the integer which is the bit-wise XOR of the two integer arguments. + @lisp (number->string (logxor #b1100 #b1010) 2) @result{} "110" @@ -3067,7 +3019,7 @@ arguments. @end deffn logtest -@c snarfed from numbers.c:997 +@c snarfed from numbers.c:998 @deffn primitive logtest j k @lisp (logtest j k) @equiv{} (not (zero? (logand j k))) @@ -3078,7 +3030,7 @@ arguments. @end deffn logbit? -@c snarfed from numbers.c:1054 +@c snarfed from numbers.c:1055 @deffn primitive logbit? index j @lisp (logbit? index j) @equiv{} (logtest (integer-expt 2 index) j) @@ -3092,10 +3044,11 @@ arguments. @end deffn lognot -@c snarfed from numbers.c:1103 +@c snarfed from numbers.c:1104 @deffn primitive lognot n Return the integer which is the 2s-complement of the integer argument. + @lisp (number->string (lognot #b10000000) 2) @result{} "-10000001" @@ -3105,10 +3058,11 @@ argument. @end deffn integer-expt -@c snarfed from numbers.c:1120 +@c snarfed from numbers.c:1121 @deffn primitive integer-expt n k Return @var{n} raised to the non-negative integer exponent @var{k}. + @lisp (integer-expt 2 5) @result{} 32 @@ -3118,7 +3072,7 @@ Return @var{n} raised to the non-negative integer exponent @end deffn ash -@c snarfed from numbers.c:1167 +@c snarfed from numbers.c:1168 @deffn primitive ash n cnt The function ash performs an arithmetic shift left by @var{cnt} bits (or shift right, if @var{cnt} is negative). 'Arithmetic' @@ -3127,8 +3081,10 @@ structure of @var{n}, but rather guarantees that the result will always be rounded towards minus infinity. Therefore, the results of ash and a corresponding bitwise shift will differ if @var{n} is negative. + Formally, the function returns an integer equivalent to @code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}. + @lisp (number->string (ash #b1 3) 2) @result{} "1000" (number->string (ash #b1010 -1) 2) @result{} "101" @@ -3136,11 +3092,12 @@ Formally, the function returns an integer equivalent to @end deffn bit-extract -@c snarfed from numbers.c:1220 +@c snarfed from numbers.c:1221 @deffn primitive bit-extract n start end Return the integer composed of the @var{start} (inclusive) through @var{end} (exclusive) bits of @var{n}. The @var{start}th bit becomes the 0-th bit in the result. + @lisp (number->string (bit-extract #b1101101010 0 4) 2) @result{} "1010" @@ -3150,12 +3107,13 @@ through @var{end} (exclusive) bits of @var{n}. The @end deffn logcount -@c snarfed from numbers.c:1292 +@c snarfed from numbers.c:1293 @deffn primitive logcount n Return the number of bits in integer @var{n}. If integer is positive, the 1-bits in its binary representation are counted. If negative, the 0-bits in its two's-complement binary representation are counted. If 0, 0 is returned. + @lisp (logcount #b10101010) @result{} 4 @@ -3167,9 +3125,10 @@ representation are counted. If 0, 0 is returned. @end deffn integer-length -@c snarfed from numbers.c:1343 +@c snarfed from numbers.c:1344 @deffn primitive integer-length n Return the number of bits neccessary to represent @var{n}. + @lisp (integer-length #b10101010) @result{} 8 @@ -3181,7 +3140,7 @@ Return the number of bits neccessary to represent @var{n}. @end deffn number->string -@c snarfed from numbers.c:2289 +@c snarfed from numbers.c:2290 @deffn primitive number->string n [radix] Return a string holding the external representation of the number @var{n} in the given @var{radix}. If @var{n} is @@ -3189,7 +3148,7 @@ inexact, a radix of 10 will be used. @end deffn string->number -@c snarfed from numbers.c:2874 +@c snarfed from numbers.c:2875 @deffn primitive string->number string [radix] Return a number of the maximally precise representation expressed by the given @var{string}. @var{radix} must be an @@ -3202,13 +3161,13 @@ syntactically valid notation for a number, then @end deffn number? -@c snarfed from numbers.c:2941 +@c snarfed from numbers.c:2942 @deffn primitive number? scm_number_p @end deffn complex? -@c snarfed from numbers.c:2953 +@c snarfed from numbers.c:2954 @deffn primitive complex? x Return @code{#t} if @var{x} is a complex number, @code{#f} else. Note that the sets of real, rational and integer @@ -3218,13 +3177,13 @@ rational or integer number. @end deffn real? -@c snarfed from numbers.c:2961 +@c snarfed from numbers.c:2962 @deffn primitive real? scm_real_p @end deffn rational? -@c snarfed from numbers.c:2974 +@c snarfed from numbers.c:2975 @deffn primitive rational? x Return @code{#t} if @var{x} is a rational number, @code{#f} else. Note that the set of integer values forms a subset of @@ -3235,28 +3194,28 @@ precision. @end deffn integer? -@c snarfed from numbers.c:2995 +@c snarfed from numbers.c:2996 @deffn primitive integer? x Return @code{#t} if @var{x} is an integer number, @code{#f} else. @end deffn inexact? -@c snarfed from numbers.c:3020 +@c snarfed from numbers.c:3021 @deffn primitive inexact? x Return @code{#t} if @var{x} is an inexact number, @code{#f} else. @end deffn $expt -@c snarfed from numbers.c:4072 +@c snarfed from numbers.c:4073 @deffn primitive $expt x y Return @var{x} raised to the power of @var{y}. This procedure does not accept complex arguments. @end deffn $atan2 -@c snarfed from numbers.c:4088 +@c snarfed from numbers.c:4089 @deffn primitive $atan2 x y Return the arc tangent of the two arguments @var{x} and @var{y}. This is similar to calculating the arc tangent of @@ -3266,20 +3225,20 @@ procedure does not accept complex arguments. @end deffn make-rectangular -@c snarfed from numbers.c:4101 +@c snarfed from numbers.c:4102 @deffn primitive make-rectangular real imaginary Return a complex number constructed of the given @var{real} and @var{imaginary} parts. @end deffn make-polar -@c snarfed from numbers.c:4114 +@c snarfed from numbers.c:4115 @deffn primitive make-polar x y Return the complex number @var{x} * e^(i * @var{y}). @end deffn inexact->exact -@c snarfed from numbers.c:4232 +@c snarfed from numbers.c:4233 @deffn primitive inexact->exact z Return an exact number that is numerically closest to @var{z}. @end deffn @@ -3642,6 +3601,7 @@ unread characters will be read again in last-in first-out order. If Sets the current position of @var{fd/port} to the integer @var{offset}, which is interpreted according to the value of @var{whence}. + One of the following variables should be supplied for @var{whence}: @defvar SEEK_SET @@ -3655,6 +3615,7 @@ Seek from the end of the file. @end defvar If @var{fd/port} is a file descriptor, the underlying system call is @code{lseek}. @var{port} may be a string port. + The value returned is the new position in the file. This means that the current position of a port can be obtained using: @lisp @@ -3743,6 +3704,7 @@ flushed) to the output port can be read from the input port. 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}. + 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 @@ -4008,6 +3970,7 @@ terminal for the current process. Return the process group ID of the foreground process group associated with the terminal open on the file descriptor underlying @var{port}. + If there is no foreground process group, the return value is a number greater than 1 that does not match the process group ID of any existing process group. This can happen if all of the @@ -4139,9 +4102,11 @@ and the current process has the type of access specified by using the values of the variables listed below. Multiple values can be combined using a bitwise or, in which case @code{#t} will only be returned if all accesses are granted. + Permissions are checked using the real id of the current process, not the effective id, although it's the effective id which determines whether the access would actually be granted. + @defvar R_OK test for read permission. @end defvar @@ -4185,6 +4150,7 @@ If @var{locale} is omitted, return the current value of the specified locale category as a system-dependent string. @var{category} should be specified using the values @code{LC_COLLATE}, @code{LC_ALL} etc. + Otherwise the specified locale category is set to the string @var{locale} and the new value is returned as a system-dependent string. If @var{locale} is an empty string, @@ -4572,10 +4538,12 @@ Another example: @c snarfed from random.c:370 @deffn primitive random n [state] Return a number in [0,N). + Accepts a positive integer or real n and returns a number of the same type between zero (inclusive) and N (exclusive). The values returned have a uniform distribution. + The optional argument @var{state} must be of the type produced by @code{seed->random-state}. It defaults to the value of the variable @var{*random-state*}. This object is used to maintain @@ -4661,6 +4629,7 @@ otherwise, leave it in the input stream for the next read. If specified, store data only into the substring of @var{str} bounded by @var{start} and @var{end} (which default to the beginning and end of the string, respectively). + Return a pair consisting of the delimiter that terminated the string and the number of characters read. If reading stopped at the end of file, the delimiter returned is the @@ -4731,8 +4700,10 @@ Compile the regular expression described by @var{pat}, and return the compiled regexp structure. If @var{pat} does not describe a legal regular expression, @code{make-regexp} throws a @code{regular-expression-syntax} error. + The @var{flags} arguments change the behavior of the compiled regular expression. The following flags may be supplied: + @table @code @item regexp/icase Consider uppercase and lowercase letters to be the same when @@ -4831,6 +4802,42 @@ They are currently represented as numbers, but your code should in no way depend on this. @end deffn + read-string!/partial +@c snarfed from rw.c:110 +@deffn primitive read-string!/partial str [port_or_fdes [start [end]]] +Read characters from an fport or file descriptor into a +string @var{str}. This procedure is scsh-compatible +and can efficiently read large strings. It will: + +@itemize +@item +attempt to fill the entire string, unless the @var{start} +and/or @var{end} arguments are supplied. i.e., @var{start} +defaults to 0 and @var{end} defaults to +@code{(string-length str)} +@item +use the current input port if @var{port_or_fdes} is not +supplied. +@item +read any characters that are currently available, +without waiting for the rest (short reads are possible). + +@item +wait for as long as it needs to for the first character to +become available, unless the port is in non-blocking mode +@item +return @code{#f} if end-of-file is encountered before reading +any characters, otherwise return the number of characters +read. +@item +return 0 if the port is in non-blocking mode and no characters +are immediately available. +@item +return 0 if the request is for 0 bytes, with no +end-of-file check +@end itemize +@end deffn + sigaction @c snarfed from scmsigs.c:201 @deffn primitive sigaction signum [handler [flags]] @@ -4907,7 +4914,7 @@ all platforms. @end deffn raise -@c snarfed from scmsigs.c:475 +@c snarfed from scmsigs.c:474 @deffn primitive raise sig Sends a specified signal @var{sig} to the current process, where @var{sig} is as described for the kill procedure. @@ -4921,6 +4928,7 @@ processor". Under Unix this is usually the default shell @code{sh}. The value returned is @var{cmd}'s exit status as returned by @code{waitpid}, which can be interpreted using the functions above. + If @code{system} is called without arguments, return a boolean indicating whether the command processor is available. @end deffn @@ -4943,80 +4951,170 @@ is @var{status} if supplied, otherwise zero. htons @c snarfed from socket.c:89 -@deffn primitive htons in -Return a new integer from @var{value} by converting from host -to network order. @var{value} must be within the range of a C -unsigned short integer. +@deffn primitive htons value +Convert a 16 bit quantity from host to network byte ordering. +@var{value} is packed into 2 bytes, which are then converted +and returned as a new integer. @end deffn ntohs @c snarfed from socket.c:106 -@deffn primitive ntohs in -Return a new integer from @var{value} by converting from -network to host order. @var{value} must be within the range of -a C unsigned short integer. +@deffn primitive ntohs value +Convert a 16 bit quantity from network to host byte ordering. +@var{value} is packed into 2 bytes, which are then converted +and returned as a new integer. @end deffn htonl @c snarfed from socket.c:123 -@deffn primitive htonl in -Return a new integer from @var{value} by converting from host -to network order. @var{value} must be within the range of a C -unsigned long integer. +@deffn primitive htonl value +Convert a 32 bit quantity from host to network byte ordering. +@var{value} is packed into 4 bytes, which are then converted +and returned as a new integer. @end deffn ntohl -@c snarfed from socket.c:135 -@deffn primitive ntohl in -Return a new integer from @var{value} by converting from -network to host order. @var{value} must be within the range of -a C unsigned long integer. +@c snarfed from socket.c:136 +@deffn primitive ntohl value +Convert a 32 bit quantity from network to host byte ordering. +@var{value} is packed into 4 bytes, which are then converted +and returned as a new integer. +@end deffn + + inet-aton +@c snarfed from socket.c:156 +@deffn primitive inet-aton address +Convert an IPv4 Internet address from printable string +(dotted decimal notation) to an integer. E.g., + +@lisp +(inet-aton "127.0.0.1") @result{} 2130706433 +@end lisp +@end deffn + + inet-ntoa +@c snarfed from socket.c:176 +@deffn primitive inet-ntoa inetid +Convert an IPv4 Internet address to a printable +(dotted decimal notation) string. E.g., + +@lisp +(inet-ntoa 2130706433) @result{} "127.0.0.1" +@end lisp +@end deffn + + inet-netof +@c snarfed from socket.c:196 +@deffn primitive inet-netof address +Return the network number part of the given IPv4 +Internet address. E.g., + +@lisp +(inet-netof 2130706433) @result{} 127 +@end lisp +@end deffn + + inet-lnaof +@c snarfed from socket.c:214 +@deffn primitive inet-lnaof address +Return the local-address-with-network part of the given +IPv4 Internet address, using the obsolete class A/B/C system. +E.g., + +@lisp +(inet-lnaof 2130706433) @result{} 1 +@end lisp +@end deffn + + inet-makeaddr +@c snarfed from socket.c:232 +@deffn primitive inet-makeaddr net lna +Make an IPv4 Internet address by combining the network number +@var{net} with the local-address-within-network number +@var{lna}. E.g., + +@lisp +(inet-makeaddr 127 1) @result{} 2130706433 +@end lisp +@end deffn + + inet-pton +@c snarfed from socket.c:350 +@deffn primitive inet-pton family address +Convert a string containing a printable network address to +an integer address. Note that unlike the C version of this +function, +the result is an integer with normal host byte ordering. +@var{family} can be @code{AF_INET} or @code{AF_INET6}. E.g., + +@lisp +(inet-pton AF_INET "127.0.0.1") @result{} 2130706433 +(inet-pton AF_INET6 "::1") @result{} 1 +@end lisp +@end deffn + + inet-ntop +@c snarfed from socket.c:385 +@deffn primitive inet-ntop family address +Convert a network address into a printable string. +Note that unlike the C version of this function, +the input is an integer with normal host byte ordering. +@var{family} can be @code{AF_INET} or @code{AF_INET6}. E.g., + +@lisp +(inet-ntop AF_INET 2130706433) @result{} "127.0.0.1" +(inet-ntop AF_INET6 (- (expt 2 128) 1)) @result{} +ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff +@end lisp @end deffn socket -@c snarfed from socket.c:161 +@c snarfed from socket.c:430 @deffn primitive socket family style proto Return a new socket port of the type specified by @var{family}, -@var{style} and @var{protocol}. All three parameters are +@var{style} and @var{proto}. All three parameters are integers. Supported values for @var{family} are @code{AF_UNIX}, @code{AF_INET} and @code{AF_INET6}. Typical values for @var{style} are @code{SOCK_STREAM}, @code{SOCK_DGRAM} and @code{SOCK_RAW}. -@var{protocol} can be obtained from a protocol name using + +@var{proto} can be obtained from a protocol name using @code{getprotobyname}. A value of zero specifies the default protocol, which is usually right. + A single socket port cannot by used for communication until it has been connected to another socket. @end deffn socketpair -@c snarfed from socket.c:183 +@c snarfed from socket.c:452 @deffn primitive socketpair family style proto Return a pair of connected (but unnamed) socket ports of the -type specified by @var{family}, @var{style} and @var{protocol}. +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{protocol}. +@var{proto}. @end deffn getsockopt -@c snarfed from socket.c:213 +@c snarfed from socket.c:481 @deffn primitive getsockopt sock level optname Return the value of a particular socket option for the socket -port @var{socket}. @var{level} is an integer code for type of +port @var{sock}. @var{level} is an integer code for type of option being requested, e.g., @code{SOL_SOCKET} for socket-level options. @var{optname} is an integer code for the option required and should be specified using one of the symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc. + The returned value is typically an integer but @code{SO_LINGER} returns a pair of integers. @end deffn setsockopt -@c snarfed from socket.c:281 +@c snarfed from socket.c:549 @deffn primitive setsockopt sock level optname value -Sets the value of a particular socket option for the socket -port @var{socket}. @var{level} is an integer code for type of option +Set the value of a particular socket option for the socket +port @var{sock}. @var{level} is an integer code for type of option being set, e.g., @code{SOL_SOCKET} for socket-level options. @var{optname} is an integer code for the option to set and should be specified using one of @@ -5029,7 +5127,7 @@ The return value is unspecified. @end deffn shutdown -@c snarfed from socket.c:403 +@c snarfed from socket.c:653 @deffn primitive shutdown sock how Sockets can be closed simply by using @code{close-port}. The @code{shutdown} procedure allows reception or tranmission on a @@ -5051,9 +5149,9 @@ The return value is unspecified. @end deffn connect -@c snarfed from socket.c:569 +@c snarfed from socket.c:797 @deffn primitive connect sock fam address . args -Initiates a connection from a socket using a specified address +Initiate a connection from a socket using a specified address family to the address specified by @var{address} and possibly @var{args}. The format required for @var{address} @@ -5077,26 +5175,27 @@ The return value is unspecified. @end deffn bind -@c snarfed from socket.c:623 +@c snarfed from socket.c:857 @deffn primitive bind sock fam address . args -Assigns an address to the socket port @var{socket}. +Assign an address to the socket port @var{sock}. Generally this only needs to be done for server sockets, so they know where to look for incoming connections. A socket without an address will be assigned one automatically when it starts communicating. -The format of @var{address} and @var{ARG} @dots{} depends on the family -of the socket. +The format of @var{address} and @var{args} depends +on the family of the socket. For a socket of family @code{AF_UNIX}, only @var{address} -is specified and must -be a string with the filename where the socket is to be created. +is specified and must be a string with the filename where +the socket is to be created. -For a socket of family @code{AF_INET}, @var{address} must be an integer -Internet host address and @var{arg} @dots{} must be a single integer -port number. +For a socket of family @code{AF_INET}, @var{address} +must be an integer IPv4 address and @var{args} +must be a single integer port number. -The values of the following variables can also be used for @var{address}: +The values of the following variables can also be used for +@var{address}: @defvar INADDR_ANY Allow connections from any address. @@ -5114,126 +5213,155 @@ The broadcast address on the local network. No address. @end defvar +For a socket of family @code{AF_INET6}, @var{address} +must be an integer IPv6 address and @var{args} +may be up to three integers: +port [flowinfo] [scope_id], +where flowinfo and scope_id default to zero. + The return value is unspecified. @end deffn listen -@c snarfed from socket.c:656 +@c snarfed from socket.c:891 @deffn primitive listen sock backlog -This procedure enables @var{socket} to accept connection +Enable @var{sock} to accept connection requests. @var{backlog} is an integer specifying the maximum length of the queue for pending connections. -If the queue fills, new clients will fail to connect until the -server calls @code{accept} to accept a connection from the queue. +If the queue fills, new clients will fail to connect until +the server calls @code{accept} to accept a connection from +the queue. The return value is unspecified. @end deffn accept -@c snarfed from socket.c:793 +@c snarfed from socket.c:997 @deffn primitive accept sock -Accepts a connection on a bound, listening socket @var{socket}. If there -are no pending connections in the queue, it waits until -one is available unless the non-blocking option has been set on the -socket. +Accept a connection on a bound, listening socket. +If there +are no pending connections in the queue, wait until +one is available unless the non-blocking option has been +set on the socket. The return value is a -pair in which the CAR is a new socket port for the connection and -the CDR is an object with address information about the client which -initiated the connection. +pair in which the @emph{car} is a new socket port for the +connection and +the @emph{cdr} is an object with address information about the +client which initiated the connection. -If the address is not available then the CDR will be an empty vector. - -@var{socket} does not become part of the +@var{sock} does not become part of the connection and will continue to accept new requests. @end deffn getsockname -@c snarfed from socket.c:824 +@c snarfed from socket.c:1024 @deffn primitive getsockname sock -Return the address of @var{socket}, in the same form as the +Return the address of @var{sock}, in the same form as the object returned by @code{accept}. On many systems the address of a socket in the @code{AF_FILE} namespace cannot be read. @end deffn getpeername -@c snarfed from socket.c:851 +@c snarfed from socket.c:1046 @deffn primitive getpeername sock -Return the address of the socket that the socket @var{socket} +Return the address that @var{sock} is connected to, in the same form as the object returned by @code{accept}. On many systems the address of a socket in the @code{AF_FILE} namespace cannot be read. @end deffn recv! -@c snarfed from socket.c:886 +@c snarfed from socket.c:1081 @deffn primitive recv! sock buf [flags] -Receives data from the socket port @var{socket}. @var{socket} must already +Receive data from a socket port. +@var{sock} must already be bound to the address from which data is to be received. @var{buf} is a string into which -the data will be written. The size of @var{buf} limits the amount of +the data will be written. The size of @var{buf} limits +the amount of data which can be received: in the case of packet -protocols, if a packet larger than this limit is encountered then some data +protocols, if a packet larger than this limit is encountered +then some data will be irrevocably lost. The optional @var{flags} argument is a value or bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc. -The value returned is the number of bytes read from the socket. +The value returned is the number of bytes read from the +socket. -Note that the data is read directly from the socket file descriptor: +Note that the data is read directly from the socket file +descriptor: any unread buffered port data is ignored. @end deffn send -@c snarfed from socket.c:915 +@c snarfed from socket.c:1114 @deffn primitive send sock message [flags] -Transmits the string @var{message} on the socket port @var{socket}. -@var{socket} must already be bound to a destination address. The -value returned is the number of bytes transmitted -- it's possible for -this to be less than the length of @var{message} if the socket is -set to be non-blocking. The optional @var{flags} argument is a value or +Transmit the string @var{message} on a socket port @var{sock}. +@var{sock} must already be bound to a destination address. The +value returned is the number of bytes transmitted -- +it's possible for +this to be less than the length of @var{message} +if the socket is +set to be non-blocking. The optional @var{flags} argument +is a value or bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc. -Note that the data is written directly to the socket file descriptor: +Note that the data is written directly to the socket +file descriptor: any unflushed buffered port data is ignored. @end deffn recvfrom! -@c snarfed from socket.c:957 +@c snarfed from socket.c:1154 @deffn primitive recvfrom! sock str [flags [start [end]]] -Return data from the socket port @var{socket} and also +Return data from the socket port @var{sock} and also information about where the data was received from. -@var{socket} must already be bound to the address from which +@var{sock} must already be bound to the address from which data is to be received. @code{str}, is a string into which the data will be written. The size of @var{str} limits the amount of data which can be received: in the case of packet protocols, if a packet larger than this limit is encountered then some data will be irrevocably lost. + The optional @var{flags} argument is a value or bitwise OR of @code{MSG_OOB}, @code{MSG_PEEK}, @code{MSG_DONTROUTE} etc. + The value returned is a pair: the @emph{car} is the number of bytes read from the socket and the @emph{cdr} an address object -in the same form as returned by @code{accept}. +in the same form as returned by @code{accept}. The address +will given as @code{#f} if not available, as is usually the +case for stream sockets. + The @var{start} and @var{end} arguments specify a substring of @var{str} to which the data should be written. + Note that the data is read directly from the socket file descriptor: any unread buffered port data is ignored. @end deffn sendto -@c snarfed from socket.c:1008 +@c snarfed from socket.c:1212 @deffn primitive sendto sock message fam address . args_and_flags -Transmits the string @var{message} on the socket port @var{socket}. The -destination address is specified using the @var{family}, @var{address} and -@var{arg} arguments, in a similar way to the @code{connect} -procedure. The -value returned is the number of bytes transmitted -- it's possible for -this to be less than the length of @var{message} if the socket is -set to be non-blocking. The optional @var{flags} argument is a value or +Transmit the string @var{message} on the socket port +@var{sock}. The +destination address is specified using the @var{fam}, +@var{address} and +@var{args_and_flags} arguments, in a similar way to the +@code{connect} procedure. @var{args_and_flags} contains +the usual connection arguments optionally followed by +a flags argument, which is a value or bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc. -Note that the data is written directly to the socket file descriptor: +The value returned is the number of bytes transmitted -- +it's possible for +this to be less than the length of @var{message} if the +socket is +set to be non-blocking. +Note that the data is written directly to the socket +file descriptor: any unflushed buffered port data is ignored. @end deffn @@ -5369,7 +5497,7 @@ Create a new stack. If @var{obj} is @code{#t}, the current evaluation stack is used for creating the stack frames, otherwise the frames are taken from @var{obj} (which must be either a debug object or a continuation). -@var{args} must be a list if integers and specifies how the +@var{args} must be a list of integers and specifies how the resulting stack will be narrowed. @end deffn @@ -5481,6 +5609,7 @@ started. Return an object with information about real and processor time. The following procedures accept such an object as an argument and return a selected component: + @table @code @item tms:clock The current real time, expressed as time units relative to an @@ -5688,6 +5817,7 @@ Return the index of the first occurrence of @var{chr} in @var{to} limit the search to a portion of the string. This procedure essentially implements the @code{index} or @code{strchr} functions from the C library. + @lisp (string-index "weiner" #\e) @result{} 1 @@ -5707,6 +5837,7 @@ Like @code{string-index}, but search from the right of the string rather than from the left. This procedure essentially implements the @code{rindex} or @code{strrchr} functions from the C library. + @lisp (string-rindex "weiner" #\e) @result{} 4 @@ -5759,6 +5890,7 @@ are different strings, it does not matter which function you use. @deffn primitive substring-fill! str start end fill Change every character in @var{str} between @var{start} and @var{end} to @var{fill}. + @lisp (define y "abcdefg") (substring-fill! y 1 3 #\r) @@ -5844,6 +5976,7 @@ Return a freshly allocation string containing the characters in @deffn primitive string-capitalize! str Upcase the first character of every word in @var{str} destructively and return @var{str}. + @lisp y @result{} "hello world" (string-capitalize! y) @result{} "Hello World" @@ -5873,6 +6006,7 @@ is currently reading symbols case--insensitively. Lexicographic equality predicate; return @code{#t} if the two strings are the same length and contain the same characters in the same positions, otherwise return @code{#f}. + The procedure @code{string-ci=?} treats upper and lower case letters as though they were the same character, but @code{string=?} treats upper and lower case as distinct @@ -6194,8 +6328,10 @@ returned will be the same as the case in the string that was passed to @code{string->symbol}. It is an error to apply mutation procedures like @code{string-set!} to strings returned by this procedure. + The following examples assume that the implementation's standard case is lower case: + @lisp (symbol->string 'flying-fish) @result{} "flying-fish" (symbol->string 'Martin) @result{} "martin" @@ -6213,8 +6349,10 @@ letters in the non-standard case, but it is usually a bad idea to create such symbols because in some implementations of Scheme they cannot be read as themselves. See @code{symbol->string}. + The following examples assume that the implementation's standard case is lower case: + @lisp (eq? 'mISSISSIppi 'mississippi) @result{} #t (string->symbol "mISSISSIppi") @result{} @r{the symbol with name "mISSISSIppi"} @@ -6355,12 +6493,6 @@ interned. The counter is increased by 1 at each call. There is no provision for resetting the counter. @end deffn - tag -@c snarfed from tag.c:98 -@deffn primitive tag x -Return an integer corresponding to the type of X. Deprecated. -@end deffn - catch @c snarfed from throw.c:535 @deffn primitive catch key thunk handler @@ -6370,12 +6502,16 @@ exceptions matching @var{key}. If thunk throws to the symbol @lisp (handler key args ...) @end lisp + @var{key} is a symbol or @code{#t}. + @var{thunk} takes no arguments. If @var{thunk} returns normally, that is the return value of @code{catch}. + Handler is invoked outside the scope of its own @code{catch}. If @var{handler} again throws to the same key, a new handler from further up the call chain is invoked. + If the key is @code{#t}, then a throw to @emph{any} symbol will match this call to @code{catch}. @end deffn @@ -6395,9 +6531,9 @@ Invoke the catch form matching @var{key}, passing @var{args} to the @var{handler}. @var{key} is a symbol. It will match catches of the same symbol or of -#t. +@code{#t}. -If there is no handler at all, an error is signaled. +If there is no handler at all, Guile prints an error and then exits. @end deffn uniform-vector-length @@ -6488,11 +6624,13 @@ dimensions arranged in a different order. There must be one @var{dim0}, @var{dim1}, @dots{} should be integers between 0 and the rank of the array to be returned. Each integer in that range must appear at least once in the argument list. + The values of @var{dim0}, @var{dim1}, @dots{} correspond to dimensions in the array to be returned, their positions in the argument list to dimensions of @var{array}. Several @var{dim}s may have the same value, in which case the returned array will have smaller rank than @var{array}. + @lisp (transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d)) (transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d) @@ -6772,6 +6910,7 @@ scm_vector @deffnx primitive list->vector l Return a newly allocated vector whose elements contain the given arguments. Analogous to @code{list}. + @lisp (vector 'a 'b 'c) @result{} #(a b c) @end lisp @@ -6791,6 +6930,7 @@ unspecified. @deffn primitive vector->list v Return a newly allocated list of the objects contained in the elements of @var{vector}. + @lisp (vector->list '#(dah dah didah)) @result{} (dah dah didah) (list->vector '(dididit dah)) @result{} #(dididit dah) @@ -6852,6 +6992,7 @@ Return a port capable of receiving or delivering characters as specified by the @var{modes} string (@pxref{File Ports, open-file}). @var{pv} must be a vector of length 5. Its components are as follows: + @enumerate 0 @item procedure accepting one character for output @@ -6864,14 +7005,17 @@ thunk for getting one character @item thunk for closing port (not by garbage collection) @end enumerate + For an output-only port only elements 0, 1, 2, and 4 need be procedures. For an input-only port only elements 3 and 4 need be procedures. Thunks 2 and 4 can instead be @code{#f} if there is no useful operation for them to perform. + If thunk 3 returns @code{#f} or an @code{eof-object} (@pxref{Input, eof-object?, ,r4rs, The Revised^4 Report on Scheme}) it indicates that the port has reached end-of-file. For example: + @lisp (define stdout (current-output-port)) (define p (make-soft-port @@ -6882,6 +7026,7 @@ For example: (lambda () (char-upcase (read-char))) (lambda () (display "@@" stdout))) "rw")) + (write p p) @result{} # @end lisp @end deffn @@ -6926,6 +7071,7 @@ weak hashes are also weak vectors. Return a weak hash table with @var{size} buckets. As with any hash table, choosing a good size for the table requires some caution. + You can modify weak hash tables in exactly the same way you would modify regular hash tables. (@pxref{Hash Tables}) @end deffn diff --git a/doc/new-docstrings.texi b/doc/new-docstrings.texi index 21e979221..e69de29bb 100644 --- a/doc/new-docstrings.texi +++ b/doc/new-docstrings.texi @@ -1,494 +0,0 @@ - -@c module (guile) - -@deffn primitive environment? obj -Return @code{#t} if @var{obj} is an environment, or @code{#f} -otherwise. -@end deffn - -@deffn primitive environment-bound? env sym -Return @code{#t} if @var{sym} is bound in @var{env}, or -@code{#f} otherwise. -@end deffn - -@deffn primitive environment-ref env sym -Return the value of the location bound to @var{sym} in -@var{env}. If @var{sym} is unbound in @var{env}, signal an -@code{environment:unbound} error. -@end deffn - -@deffn primitive environment-fold env proc init -Iterate over all the bindings in @var{env}, accumulating some -value. -For each binding in @var{env}, apply @var{proc} to the symbol -bound, its value, and the result from the previous application -of @var{proc}. -Use @var{init} as @var{proc}'s third argument the first time -@var{proc} is applied. -If @var{env} contains no bindings, this function simply returns -@var{init}. -If @var{env} binds the symbol sym1 to the value val1, sym2 to -val2, and so on, then this procedure computes: -@lisp - (proc sym1 val1 - (proc sym2 val2 - ... - (proc symn valn - init))) -@end lisp -Each binding in @var{env} will be processed exactly once. -@code{environment-fold} makes no guarantees about the order in -which the bindings are processed. -Here is a function which, given an environment, constructs an -association list representing that environment's bindings, -using environment-fold: -@lisp - (define (environment->alist env) - (environment-fold env - (lambda (sym val tail) - (cons (cons sym val) tail)) - '())) -@end lisp -@end deffn - -@deffn primitive environment-define env sym val -Bind @var{sym} to a new location containing @var{val} in -@var{env}. If @var{sym} is already bound to another location -in @var{env} and the binding is mutable, that binding is -replaced. The new binding and location are both mutable. The -return value is unspecified. -If @var{sym} is already bound in @var{env}, and the binding is -immutable, signal an @code{environment:immutable-binding} error. -@end deffn - -@deffn primitive environment-undefine env sym -Remove any binding for @var{sym} from @var{env}. If @var{sym} -is unbound in @var{env}, do nothing. The return value is -unspecified. -If @var{sym} is already bound in @var{env}, and the binding is -immutable, signal an @code{environment:immutable-binding} error. -@end deffn - -@deffn primitive environment-set! env sym val -If @var{env} binds @var{sym} to some location, change that -location's value to @var{val}. The return value is -unspecified. -If @var{sym} is not bound in @var{env}, signal an -@code{environment:unbound} error. If @var{env} binds @var{sym} -to an immutable location, signal an -@code{environment:immutable-location} error. -@end deffn - -@deffn primitive environment-cell env sym for_write -Return the value cell which @var{env} binds to @var{sym}, or -@code{#f} if the binding does not live in a value cell. -The argument @var{for-write} indicates whether the caller -intends to modify the variable's value by mutating the value -cell. If the variable is immutable, then -@code{environment-cell} signals an -@code{environment:immutable-location} error. -If @var{sym} is unbound in @var{env}, signal an -@code{environment:unbound} error. -If you use this function, you should consider using -@code{environment-observe}, to be notified when @var{sym} gets -re-bound to a new value cell, or becomes undefined. -@end deffn - -@deffn primitive environment-observe env proc -Whenever @var{env}'s bindings change, apply @var{proc} to -@var{env}. -This function returns an object, token, which you can pass to -@code{environment-unobserve} to remove @var{proc} from the set -of procedures observing @var{env}. The type and value of -token is unspecified. -@end deffn - -@deffn primitive environment-observe-weak env proc -This function is the same as environment-observe, except that -the reference @var{env} retains to @var{proc} is a weak -reference. This means that, if there are no other live, -non-weak references to @var{proc}, it will be -garbage-collected, and dropped from @var{env}'s -list of observing procedures. -@end deffn - -@deffn primitive environment-unobserve token -Cancel the observation request which returned the value -@var{token}. The return value is unspecified. -If a call @code{(environment-observe env proc)} returns -@var{token}, then the call @code{(environment-unobserve token)} -will cause @var{proc} to no longer be called when @var{env}'s -bindings change. -@end deffn - -@deffn primitive make-leaf-environment -Create a new leaf environment, containing no bindings. -All bindings and locations created in the new environment -will be mutable. -@end deffn - -@deffn primitive leaf-environment? object -Return @code{#t} if object is a leaf environment, or @code{#f} -otherwise. -@end deffn - -@deffn primitive make-eval-environment local imported -Return a new environment object eval whose bindings are the -union of the bindings in the environments @var{local} and -@var{imported}, with bindings from @var{local} taking -precedence. Definitions made in eval are placed in @var{local}. -Applying @code{environment-define} or -@code{environment-undefine} to eval has the same effect as -applying the procedure to @var{local}. -Note that eval incorporates @var{local} and @var{imported} by -reference: -If, after creating eval, the program changes the bindings of -@var{local} or @var{imported}, those changes will be visible -in eval. -Since most Scheme evaluation takes place in eval environments, -they transparently cache the bindings received from @var{local} -and @var{imported}. Thus, the first time the program looks up -a symbol in eval, eval may make calls to @var{local} or -@var{imported} to find their bindings, but subsequent -references to that symbol will be as fast as references to -bindings in finite environments. -In typical use, @var{local} will be a finite environment, and -@var{imported} will be an import environment -@end deffn - -@deffn primitive eval-environment? object -Return @code{#t} if object is an eval environment, or @code{#f} -otherwise. -@end deffn - -@deffn primitive eval-environment-local env -Return the local environment of eval environment @var{env}. -@end deffn - -@deffn primitive eval-environment-set-local! env local -Change @var{env}'s local environment to @var{local}. -@end deffn - -@deffn primitive eval-environment-imported env -Return the imported environment of eval environment @var{env}. -@end deffn - -@deffn primitive eval-environment-set-imported! env imported -Change @var{env}'s imported environment to @var{imported}. -@end deffn - -@deffn primitive make-import-environment imports conflict_proc -Return a new environment @var{imp} whose bindings are the union -of the bindings from the environments in @var{imports}; -@var{imports} must be a list of environments. That is, -@var{imp} binds a symbol to a location when some element of -@var{imports} does. -If two different elements of @var{imports} have a binding for -the same symbol, the @var{conflict-proc} is called with the -following parameters: the import environment, the symbol and -the list of the imported environments that bind the symbol. -If the @var{conflict-proc} returns an environment @var{env}, -the conflict is considered as resolved and the binding from -@var{env} is used. If the @var{conflict-proc} returns some -non-environment object, the conflict is considered unresolved -and the symbol is treated as unspecified in the import -environment. -The checking for conflicts may be performed lazily, i. e. at -the moment when a value or binding for a certain symbol is -requested instead of the moment when the environment is -created or the bindings of the imports change. -All bindings in @var{imp} are immutable. If you apply -@code{environment-define} or @code{environment-undefine} to -@var{imp}, Guile will signal an - @code{environment:immutable-binding} error. However, -notice that the set of bindings in @var{imp} may still change, -if one of its imported environments changes. -@end deffn - -@deffn primitive import-environment? object -Return @code{#t} if object is an import environment, or -@code{#f} otherwise. -@end deffn - -@deffn primitive import-environment-imports env -Return the list of environments imported by the import -environment @var{env}. -@end deffn - -@deffn primitive import-environment-set-imports! env imports -Change @var{env}'s list of imported environments to -@var{imports}, and check for conflicts. -@end deffn - -@deffn primitive make-export-environment private signature -Return a new environment @var{exp} containing only those -bindings in private whose symbols are present in -@var{signature}. The @var{private} argument must be an -environment. - -The environment @var{exp} binds symbol to location when -@var{env} does, and symbol is exported by @var{signature}. - -@var{signature} is a list specifying which of the bindings in -@var{private} should be visible in @var{exp}. Each element of -@var{signature} should be a list of the form: - (symbol attribute ...) -where each attribute is one of the following: -@table @asis -@item the symbol @code{mutable-location} - @var{exp} should treat the - location bound to symbol as mutable. That is, @var{exp} - will pass calls to @code{environment-set!} or - @code{environment-cell} directly through to private. -@item the symbol @code{immutable-location} - @var{exp} should treat - the location bound to symbol as immutable. If the program - applies @code{environment-set!} to @var{exp} and symbol, or - calls @code{environment-cell} to obtain a writable value - cell, @code{environment-set!} will signal an - @code{environment:immutable-location} error. Note that, even - if an export environment treats a location as immutable, the - underlying environment may treat it as mutable, so its - value may change. -@end table -It is an error for an element of signature to specify both -@code{mutable-location} and @code{immutable-location}. If -neither is specified, @code{immutable-location} is assumed. - -As a special case, if an element of signature is a lone -symbol @var{sym}, it is equivalent to an element of the form -@code{(sym)}. - -All bindings in @var{exp} are immutable. If you apply -@code{environment-define} or @code{environment-undefine} to -@var{exp}, Guile will signal an -@code{environment:immutable-binding} error. However, -notice that the set of bindings in @var{exp} may still change, -if the bindings in private change. -@end deffn - -@deffn primitive export-environment? object -Return @code{#t} if object is an export environment, or -@code{#f} otherwise. -@end deffn - -@deffn primitive export-environment-private env -Return the private environment of export environment @var{env}. -@end deffn - -@deffn primitive export-environment-set-private! env private -Change the private environment of export environment @var{env}. -@end deffn - -@deffn primitive export-environment-signature env -Return the signature of export environment @var{env}. -@end deffn - -@deffn primitive export-environment-set-signature! env signature -Change the signature of export environment @var{env}. -@end deffn - -@deffn primitive %compute-slots class -Return a list consisting of the names of all slots belonging to -class @var{class}, i. e. the slots of @var{class} and of all of -its superclasses. -@end deffn - -@deffn primitive get-keyword key l default_value -Determine an associated value for the keyword @var{key} from -the list @var{l}. The list @var{l} has to consist of an even -number of elements, where, starting with the first, every -second element is a keyword, followed by its associated value. -If @var{l} does not hold a value for @var{key}, the value -@var{default_value} is returned. -@end deffn - -@deffn primitive slot-ref-using-class class obj slot_name -@end deffn - -@deffn primitive slot-set-using-class! class obj slot_name value -@end deffn - -@deffn primitive class-of x -Return the class of @var{x}. -@end deffn - -@deffn primitive %goops-loaded -Announce that GOOPS is loaded and perform initialization -on the C level which depends on the loaded GOOPS modules. -@end deffn - -@deffn primitive %method-more-specific? m1 m2 targs -@end deffn - -@deffn primitive find-method . l -@end deffn - -@deffn primitive primitive-generic-generic subr -@end deffn - -@deffn primitive enable-primitive-generic! . subrs -@end deffn - -@deffn primitive generic-capability? proc -@end deffn - -@deffn primitive %invalidate-method-cache! gf -@end deffn - -@deffn primitive %invalidate-class class -@end deffn - -@deffn primitive %modify-class old new -@end deffn - -@deffn primitive %modify-instance old new -@end deffn - -@deffn primitive %set-object-setter! obj setter -@end deffn - -@deffn primitive %allocate-instance class initargs -Create a new instance of class @var{class} and initialize it -from the arguments @var{initargs}. -@end deffn - -@deffn primitive slot-exists? obj slot_name -Return @code{#t} if @var{obj} has a slot named @var{slot_name}. -@end deffn - -@deffn primitive slot-bound? obj slot_name -Return @code{#t} if the slot named @var{slot_name} of @var{obj} -is bound. -@end deffn - -@deffn primitive slot-set! obj slot_name value -Set the slot named @var{slot_name} of @var{obj} to @var{value}. -@end deffn - -@deffn primitive slot-exists-using-class? class obj slot_name -@end deffn - -@deffn primitive slot-bound-using-class? class obj slot_name -@end deffn - -@deffn primitive %fast-slot-set! obj index value -Set the slot with index @var{index} in @var{obj} to -@var{value}. -@end deffn - -@deffn primitive %fast-slot-ref obj index -Return the slot value with index @var{index} from @var{obj}. -@end deffn - -@deffn primitive @@assert-bound-ref obj index -Like @code{assert-bound}, but use @var{index} for accessing -the value from @var{obj}. -@end deffn - -@deffn primitive assert-bound value obj -Return @var{value} if it is bound, and invoke the -@var{slot-unbound} method of @var{obj} if it is not. -@end deffn - -@deffn primitive unbound? obj -Return @code{#t} if @var{obj} is unbound. -@end deffn - -@deffn primitive make-unbound -Return the unbound value. -@end deffn - -@deffn primitive accessor-method-slot-definition obj -Return the slot definition of the accessor @var{obj}. -@end deffn - -@deffn primitive method-procedure obj -Return the procedure of the method @var{obj}. -@end deffn - -@deffn primitive method-specializers obj -Return specializers of the method @var{obj}. -@end deffn - -@deffn primitive method-generic-function obj -Return the generic function fot the method @var{obj}. -@end deffn - -@deffn primitive generic-function-methods obj -Return the methods of the generic function @var{obj}. -@end deffn - -@deffn primitive generic-function-name obj -Return the name of the generic function @var{obj}. -@end deffn - -@deffn primitive class-environment obj -Return the environment of the class @var{obj}. -@end deffn - -@deffn primitive class-slots obj -Return the slot list of the class @var{obj}. -@end deffn - -@deffn primitive class-precedence-list obj -Return the class precedence list of the class @var{obj}. -@end deffn - -@deffn primitive class-direct-methods obj -Return the direct methods of the class @var{obj} -@end deffn - -@deffn primitive class-direct-subclasses obj -Return the direct subclasses of the class @var{obj}. -@end deffn - -@deffn primitive class-direct-slots obj -Return the direct slots of the class @var{obj}. -@end deffn - -@deffn primitive class-direct-supers obj -Return the direct superclasses of the class @var{obj}. -@end deffn - -@deffn primitive class-name obj -Return the class name of @var{obj}. -@end deffn - -@deffn primitive instance? obj -Return @code{#t} if @var{obj} is an instance. -@end deffn - -@deffn primitive %inherit-magic! class dsupers -@end deffn - -@deffn primitive %prep-layout! class -@end deffn - -@deffn primitive %initialize-object obj initargs -Initialize the object @var{obj} with the given arguments -@var{initargs}. -@end deffn - -@deffn primitive make . args -Make a new object. @var{args} must contain the class and -all necessary initialization information. -@end deffn - -@deffn primitive slot-ref obj slot_name -Return the value from @var{obj}'s slot with the name -@var{slot_name}. -@end deffn - -@deffn primitive builtin-bindings -Create and return a copy of the global symbol table, removing all -unbound symbols. -@end deffn - -@deffn primitive %tag-body body -Internal GOOPS magic---don't use this function! -@end deffn - -@deffn primitive list* -scm_cons_star -@end deffn diff --git a/doc/posix.texi b/doc/posix.texi index 5bff88c9f..71148ca60 100644 --- a/doc/posix.texi +++ b/doc/posix.texi @@ -295,6 +295,7 @@ flushed) to the output port can be read from the input port. 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}. + 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 @@ -511,9 +512,11 @@ and the current process has the type of access specified by using the values of the variables listed below. Multiple values can be combined using a bitwise or, in which case @code{#t} will only be returned if all accesses are granted. + Permissions are checked using the real id of the current process, not the effective id, although it's the effective id which determines whether the access would actually be granted. + @defvar R_OK test for read permission. @end defvar @@ -535,9 +538,11 @@ determined by @var{obj}. @var{obj} can be a string containing a file name or a port or integer file descriptor which is open on a file (in which case @code{fstat} is used as the underlying system call). + The object returned by @code{stat} can be passed as a single parameter to the following procedures, all of which return integers: + @table @code @item stat:dev The device containing the file. @@ -572,8 +577,10 @@ bytes. The amount of disk space that the file occupies measured in units of 512 byte blocks. @end table + In addition, the following procedures return the information from stat:mode in a more convenient form: + @table @code @item stat:type A symbol representing the type of file. Possible values are @@ -993,6 +1000,7 @@ reported by the following procedures. Return an object with information about real and processor time. The following procedures accept such an object as an argument and return a selected component: + @table @code @item tms:clock The current real time, expressed as time units relative to an @@ -1262,6 +1270,7 @@ processor". Under Unix this is usually the default shell @code{sh}. The value returned is @var{cmd}'s exit status as returned by @code{waitpid}, which can be interpreted using the functions above. + If @code{system} is called without arguments, return a boolean indicating whether the command processor is available. @end deffn @@ -1475,6 +1484,7 @@ terminal for the current process. Return the process group ID of the foreground process group associated with the terminal open on the file descriptor underlying @var{port}. + If there is no foreground process group, the return value is a number greater than 1 that does not match the process group ID of any existing process group. This can happen if all of the @@ -1546,24 +1556,27 @@ the database routines since they are not reentrant. @subsubsection Address Conversion @deffn primitive inet-aton address -Converts a string containing an Internet host address in the -traditional dotted decimal notation into an integer. +Convert an IPv4 Internet address from printable string +(dotted decimal notation) to an integer. E.g., + @lisp (inet-aton "127.0.0.1") @result{} 2130706433 @end lisp @end deffn @deffn primitive inet-ntoa inetid -Converts an integer Internet host address into a string with -the traditional dotted decimal representation. +Convert an IPv4 Internet address to a printable +(dotted decimal notation) string. E.g., + @lisp (inet-ntoa 2130706433) @result{} "127.0.0.1" @end lisp @end deffn @deffn primitive inet-netof address -Return the network number part of the given integer Internet -address. +Return the network number part of the given IPv4 +Internet address. E.g., + @lisp (inet-netof 2130706433) @result{} 127 @end lisp @@ -1571,21 +1584,52 @@ address. @deffn primitive inet-lnaof address Return the local-address-with-network part of the given -Internet address. +IPv4 Internet address, using the obsolete class A/B/C system. +E.g., + @lisp (inet-lnaof 2130706433) @result{} 1 @end lisp @end deffn @deffn primitive inet-makeaddr net lna -Makes an Internet host address by combining the network number +Make an IPv4 Internet address by combining the network number @var{net} with the local-address-within-network number -@var{lna}. +@var{lna}. E.g., + @lisp (inet-makeaddr 127 1) @result{} 2130706433 @end lisp @end deffn +@subsubsection IPv6 Address Conversion + +@deffn primitive inet-ntop family address +Convert a network address into a printable string. +Note that unlike the C version of this function, +the input is an integer with normal host byte ordering. +@var{family} can be @code{AF_INET} or @code{AF_INET6}. E.g., + +@lisp +(inet-ntop AF_INET 2130706433) @result{} "127.0.0.1" +(inet-ntop AF_INET6 (- (expt 2 128) 1)) @result{} +ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff +@end lisp +@end deffn + +@deffn primitive inet-pton family address +Convert a string containing a printable network address to +an integer address. Note that unlike the C version of this +function, +the result is an integer with normal host byte ordering. +@var{family} can be @code{AF_INET} or @code{AF_INET6}. E.g., + +@lisp +(inet-pton AF_INET "127.0.0.1") @result{} 2130706433 +(inet-pton AF_INET6 "::1") @result{} 1 +@end lisp +@end deffn + @subsubsection The Host Database A @dfn{host object} is a structure that represents what is known about a @@ -1836,40 +1880,43 @@ required. The arguments and return values are thus in host order. @deffn primitive socket family style proto Return a new socket port of the type specified by @var{family}, -@var{style} and @var{protocol}. All three parameters are +@var{style} and @var{proto}. All three parameters are integers. Supported values for @var{family} are @code{AF_UNIX}, @code{AF_INET} and @code{AF_INET6}. Typical values for @var{style} are @code{SOCK_STREAM}, @code{SOCK_DGRAM} and @code{SOCK_RAW}. -@var{protocol} can be obtained from a protocol name using + +@var{proto} can be obtained from a protocol name using @code{getprotobyname}. A value of zero specifies the default protocol, which is usually right. + A single socket port cannot by used for communication until it has been connected to another socket. @end deffn @deffn primitive socketpair family style proto Return a pair of connected (but unnamed) socket ports of the -type specified by @var{family}, @var{style} and @var{protocol}. +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{protocol}. +@var{proto}. @end deffn @deffn primitive getsockopt sock level optname Return the value of a particular socket option for the socket -port @var{socket}. @var{level} is an integer code for type of +port @var{sock}. @var{level} is an integer code for type of option being requested, e.g., @code{SOL_SOCKET} for socket-level options. @var{optname} is an integer code for the option required and should be specified using one of the symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc. + The returned value is typically an integer but @code{SO_LINGER} returns a pair of integers. @end deffn @deffn primitive setsockopt sock level optname value -Sets the value of a particular socket option for the socket -port @var{socket}. @var{level} is an integer code for type of option +Set the value of a particular socket option for the socket +port @var{sock}. @var{level} is an integer code for type of option being set, e.g., @code{SOL_SOCKET} for socket-level options. @var{optname} is an integer code for the option to set and should be specified using one of @@ -1902,7 +1949,7 @@ The return value is unspecified. @end deffn @deffn primitive connect sock fam address . args -Initiates a connection from a socket using a specified address +Initiate a connection from a socket using a specified address family to the address specified by @var{address} and possibly @var{args}. The format required for @var{address} @@ -1926,24 +1973,25 @@ The return value is unspecified. @end deffn @deffn primitive bind sock fam address . args -Assigns an address to the socket port @var{socket}. +Assign an address to the socket port @var{sock}. Generally this only needs to be done for server sockets, so they know where to look for incoming connections. A socket without an address will be assigned one automatically when it starts communicating. -The format of @var{address} and @var{ARG} @dots{} depends on the family -of the socket. +The format of @var{address} and @var{args} depends +on the family of the socket. -For a socket of family @code{AF_UNIX}, only @var{address} is specified -and must be a string with the filename where the socket is to be -created. +For a socket of family @code{AF_UNIX}, only @var{address} +is specified and must be a string with the filename where +the socket is to be created. -For a socket of family @code{AF_INET}, @var{address} must be an integer -Internet host address and @var{arg} @dots{} must be a single integer -port number. +For a socket of family @code{AF_INET}, @var{address} +must be an integer IPv4 address and @var{args} +must be a single integer port number. -The values of the following variables can also be used for @var{address}: +The values of the following variables can also be used for +@var{address}: @defvar INADDR_ANY Allow connections from any address. @@ -1961,33 +2009,40 @@ The broadcast address on the local network. No address. @end defvar +For a socket of family @code{AF_INET6}, @var{address} +must be an integer IPv6 address and @var{args} +may be up to three integers: +port [flowinfo] [scope_id], +where flowinfo and scope_id default to zero. + The return value is unspecified. @end deffn @deffn primitive listen sock backlog -This procedure enables @var{socket} to accept connection +Enable @var{sock} to accept connection requests. @var{backlog} is an integer specifying the maximum length of the queue for pending connections. -If the queue fills, new clients will fail to connect until the -server calls @code{accept} to accept a connection from the queue. +If the queue fills, new clients will fail to connect until +the server calls @code{accept} to accept a connection from +the queue. The return value is unspecified. @end deffn @deffn primitive accept sock -Accepts a connection on a bound, listening socket @var{socket}. If there -are no pending connections in the queue, it waits until -one is available unless the non-blocking option has been set on the -socket. +Accept a connection on a bound, listening socket. +If there +are no pending connections in the queue, wait until +one is available unless the non-blocking option has been +set on the socket. The return value is a -pair in which the CAR is a new socket port for the connection and -the CDR is an object with address information about the client which -initiated the connection. +pair in which the @emph{car} is a new socket port for the +connection and +the @emph{cdr} is an object with address information about the +client which initiated the connection. -If the address is not available then the CDR will be an empty vector. - -@var{socket} does not become part of the +@var{sock} does not become part of the connection and will continue to accept new requests. @end deffn @@ -2010,79 +2065,101 @@ number. @end table @deffn primitive getsockname sock -Return the address of @var{socket}, in the same form as the +Return the address of @var{sock}, in the same form as the object returned by @code{accept}. On many systems the address of a socket in the @code{AF_FILE} namespace cannot be read. @end deffn @deffn primitive getpeername sock -Return the address of the socket that the socket @var{socket} +Return the address that @var{sock} is connected to, in the same form as the object returned by @code{accept}. On many systems the address of a socket in the @code{AF_FILE} namespace cannot be read. @end deffn @deffn primitive recv! sock buf [flags] -Receives data from the socket port @var{socket}. @var{socket} must already +Receive data from a socket port. +@var{sock} must already be bound to the address from which data is to be received. @var{buf} is a string into which -the data will be written. The size of @var{buf} limits the amount of +the data will be written. The size of @var{buf} limits +the amount of data which can be received: in the case of packet -protocols, if a packet larger than this limit is encountered then some data +protocols, if a packet larger than this limit is encountered +then some data will be irrevocably lost. The optional @var{flags} argument is a value or bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc. -The value returned is the number of bytes read from the socket. +The value returned is the number of bytes read from the +socket. -Note that the data is read directly from the socket file descriptor: +Note that the data is read directly from the socket file +descriptor: any unread buffered port data is ignored. @end deffn @deffn primitive send sock message [flags] -Transmits the string @var{message} on the socket port @var{socket}. -@var{socket} must already be bound to a destination address. The -value returned is the number of bytes transmitted -- it's possible for -this to be less than the length of @var{message} if the socket is -set to be non-blocking. The optional @var{flags} argument is a value or +Transmit the string @var{message} on a socket port @var{sock}. +@var{sock} must already be bound to a destination address. The +value returned is the number of bytes transmitted -- +it's possible for +this to be less than the length of @var{message} +if the socket is +set to be non-blocking. The optional @var{flags} argument +is a value or bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc. -Note that the data is written directly to the socket file descriptor: +Note that the data is written directly to the socket +file descriptor: any unflushed buffered port data is ignored. @end deffn @deffn primitive recvfrom! sock str [flags [start [end]]] -Return data from the socket port @var{socket} and also +Return data from the socket port @var{sock} and also information about where the data was received from. -@var{socket} must already be bound to the address from which +@var{sock} must already be bound to the address from which data is to be received. @code{str}, is a string into which the data will be written. The size of @var{str} limits the amount of data which can be received: in the case of packet protocols, if a packet larger than this limit is encountered then some data will be irrevocably lost. + The optional @var{flags} argument is a value or bitwise OR of @code{MSG_OOB}, @code{MSG_PEEK}, @code{MSG_DONTROUTE} etc. + The value returned is a pair: the @emph{car} is the number of bytes read from the socket and the @emph{cdr} an address object -in the same form as returned by @code{accept}. +in the same form as returned by @code{accept}. The address +will given as @code{#f} if not available, as is usually the +case for stream sockets. + The @var{start} and @var{end} arguments specify a substring of @var{str} to which the data should be written. + Note that the data is read directly from the socket file descriptor: any unread buffered port data is ignored. @end deffn @deffn primitive sendto sock message fam address . args_and_flags -Transmits the string @var{message} on the socket port @var{socket}. The -destination address is specified using the @var{family}, @var{address} and -@var{arg} arguments, in a similar way to the @code{connect} -procedure. The -value returned is the number of bytes transmitted -- it's possible for -this to be less than the length of @var{message} if the socket is -set to be non-blocking. The optional @var{flags} argument is a value or +Transmit the string @var{message} on the socket port +@var{sock}. The +destination address is specified using the @var{fam}, +@var{address} and +@var{args_and_flags} arguments, in a similar way to the +@code{connect} procedure. @var{args_and_flags} contains +the usual connection arguments optionally followed by +a flags argument, which is a value or bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc. -Note that the data is written directly to the socket file descriptor: +The value returned is the number of bytes transmitted -- +it's possible for +this to be less than the length of @var{message} if the +socket is +set to be non-blocking. +Note that the data is written directly to the socket +file descriptor: any unflushed buffered port data is ignored. @end deffn @@ -2091,28 +2168,28 @@ between "host" and "network" order. Although the procedures above do this automatically for addresses, the conversion will still need to be done when sending or receiving encoded integer data from the network. -@deffn primitive htons in -Return a new integer from @var{value} by converting from host -to network order. @var{value} must be within the range of a C -unsigned short integer. +@deffn primitive htons value +Convert a 16 bit quantity from host to network byte ordering. +@var{value} is packed into 2 bytes, which are then converted +and returned as a new integer. @end deffn -@deffn primitive ntohs in -Return a new integer from @var{value} by converting from -network to host order. @var{value} must be within the range of -a C unsigned short integer. +@deffn primitive ntohs value +Convert a 16 bit quantity from network to host byte ordering. +@var{value} is packed into 2 bytes, which are then converted +and returned as a new integer. @end deffn -@deffn primitive htonl in -Return a new integer from @var{value} by converting from host -to network order. @var{value} must be within the range of a C -unsigned long integer. +@deffn primitive htonl value +Convert a 32 bit quantity from host to network byte ordering. +@var{value} is packed into 4 bytes, which are then converted +and returned as a new integer. @end deffn -@deffn primitive ntohl in -Return a new integer from @var{value} by converting from -network to host order. @var{value} must be within the range of -a C unsigned long integer. +@deffn primitive ntohl value +Convert a 32 bit quantity from network to host byte ordering. +@var{value} is packed into 4 bytes, which are then converted +and returned as a new integer. @end deffn These procedures are inconvenient to use at present, but consider: @@ -2190,6 +2267,7 @@ If @var{locale} is omitted, return the current value of the specified locale category as a system-dependent string. @var{category} should be specified using the values @code{LC_COLLATE}, @code{LC_ALL} etc. + Otherwise the specified locale category is set to the string @var{locale} and the new value is returned as a system-dependent string. If @var{locale} is an empty string, diff --git a/doc/scheme-control.texi b/doc/scheme-control.texi index 220db6012..472b3267a 100644 --- a/doc/scheme-control.texi +++ b/doc/scheme-control.texi @@ -409,8 +409,7 @@ more conveniently. * Exception Terminology:: Different ways to say the same thing. * Catch:: Setting up to catch exceptions. * Throw:: Throwing an exception. -* Lazy Catch:: Catch without unwinding. -* Stack Catch:: Capturing the stack at a throw. +* Lazy Catch:: Catch without unwinding the stack. * Exception Implementation:: How Guile implements exceptions. @end menu @@ -497,12 +496,16 @@ exceptions matching @var{key}. If thunk throws to the symbol @lisp (handler key args ...) @end lisp + @var{key} is a symbol or @code{#t}. + @var{thunk} takes no arguments. If @var{thunk} returns normally, that is the return value of @code{catch}. + Handler is invoked outside the scope of its own @code{catch}. If @var{handler} again throws to the same key, a new handler from further up the call chain is invoked. + If the key is @code{#t}, then a throw to @emph{any} symbol will match this call to @code{catch}. @end deffn @@ -543,10 +546,10 @@ for that kind of exception. @deffn primitive throw key . args Invoke the catch form matching @var{key}, passing @var{args} to the -@var{handler}. +@var{handler}. @var{key} is a symbol. It will match catches of the same symbol or of -#t. +@code{#t}. If there is no handler at all, Guile prints an error and then exits. @end deffn @@ -596,26 +599,113 @@ expression. @node Lazy Catch @subsection Catch Without Unwinding +A @dfn{lazy catch} is used in the same way as a normal @code{catch}, +with @var{key}, @var{thunk} and @var{handler} arguments specifying the +exception type, normal case code and handler procedure, but differs in +two important respects. + +@itemize +@item +The handler procedure is executed without unwinding the call stack from +the context of the @code{throw} expression that caused the handler to be +invoked. + +@item +If the handler returns normally --- i.e. does not @emph{itself} throw an +exception --- then the @code{throw} expression returns normally to its +caller with the handler's value. +@end itemize + @deffn primitive lazy-catch key thunk handler This behaves exactly like @code{catch}, except that it does not unwind the stack (this is the major difference), and if handler returns, its value is returned from the throw. @end deffn +The net result is that throwing an exception that is caught by a +@code{lazy-catch} is @emph{almost} equivalent to calling the +@code{lazy-catch}'s handler inline instead of each @code{throw}, and +then omitting the surrounding @code{lazy-catch}. In other words, + @lisp -(lazy-catch 'badex +(lazy-catch 'key + (lambda () @dots{} (throw 'key args @dots{}) @dots{}) + handler) +@end lisp + +@noindent +is @emph{almost} equivalent to + +@lisp +((lambda () @dots{} (handler 'key args @dots{}) @dots{})) +@end lisp + +@noindent +But why only @emph{almost}? The difference is that with +@code{lazy-catch}, the dynamic context is unwound back to just outside +the @code{lazy-catch} expression before invoking the handler. (For an +introduction to what is meant by dynamic context, @xref{Dynamic Wind}.) + +Then, if the handler @emph{itself} throws an exception, that exception +must be caught by some kind of @code{catch} (including perhaps another +@code{lazy-catch}) higher up the call stack. On the other hand, if the +handler returns normally, the dynamic context is wound back to that of +the @code{throw} expression before passing the handler's return value to +the continuation of the @code{throw}. + +In most cases where @code{lazy-catch} is used, the handler does indeed +throw another exception, which is caught by a higher-level @code{catch}. +But this pattern is not mandatory, and it can be useful for the handler +to return normally. In the following example, the @code{lazy-catch} +handler is called twice and the results of the two calls added together. + +@lisp +(lazy-catch 'foo (lambda () - (+ (throw 'badex 1) - (throw 'badex 2))) + (+ (throw 'foo 1) + (throw 'foo 2))) (lambda args (cadr args))) @result{} 3 @end lisp +To see the point about dynamic context, consider the case where the +normal case thunk uses @code{with-fluids} (REFFIXME) to temporarily +change the value of a fluid: -@node Stack Catch -@subsection Capturing the Stack at a Throw +@lisp +(define f (make-fluid)) +(fluid-set! f "top level value") + +(define (handler . args) + (cons (fluid-ref f) args)) + +(lazy-catch 'foo + (lambda () + (with-fluids ((f "local value")) + (throw 'foo))) + handler) +@result{} +("top level value" foo) + +((lambda () + (with-fluids ((f "local value")) + (handler 'foo)))) +@result{} +("local value" foo) +@end lisp + +@noindent +In the @code{lazy-catch} version, the unwinding of dynamic context +restores @code{f} to its value outside the @code{with-fluids} block +before the handler is invoked, so the handler's @code{(fluid-ref f)} +returns the external value. + +@code{lazy-catch} is useful because it permits the implementation of +debuggers and other reflective programming tools that need to access the +state of the call stack at the exact point where an exception or an +error is thrown. For an example of this, see REFFIXME:stack-catch. @node Exception Implementation @@ -702,6 +792,7 @@ be reviewed] All three arguments must be 0-argument procedures. @var{in_guard} is called, then @var{thunk}, then @var{out_guard}. + If, any time during the execution of @var{thunk}, the continuation of the @code{dynamic_wind} expression is escaped non-locally, @var{out_guard} is called. If the continuation of @@ -718,15 +809,18 @@ times. ;; in-guard: ;; (lambda () (set! x 'special-binding)) + ;; thunk ;; (lambda () (display x) (newline) (call-with-current-continuation escape) (display x) (newline) x) + ;; out-guard: ;; (lambda () (set! x old-x))))))) + ;; Prints: special-binding ;; Evaluates to: diff --git a/doc/scheme-data.texi b/doc/scheme-data.texi index 3032a02d1..a541752ee 100755 --- a/doc/scheme-data.texi +++ b/doc/scheme-data.texi @@ -943,6 +943,7 @@ Return the hyperbolic arctangent of @var{x}. @deffn primitive logand n1 n2 Return the integer which is the bit-wise AND of the two integer arguments. + @lisp (number->string (logand #b1100 #b1010) 2) @result{} "1000" @@ -952,6 +953,7 @@ arguments. @deffn primitive logior n1 n2 Return the integer which is the bit-wise OR of the two integer arguments. + @lisp (number->string (logior #b1100 #b1010) 2) @result{} "1110" @@ -961,6 +963,7 @@ arguments. @deffn primitive logxor n1 n2 Return the integer which is the bit-wise XOR of the two integer arguments. + @lisp (number->string (logxor #b1100 #b1010) 2) @result{} "110" @@ -970,6 +973,7 @@ arguments. @deffn primitive lognot n Return the integer which is the 2s-complement of the integer argument. + @lisp (number->string (lognot #b10000000) 2) @result{} "-10000001" @@ -1007,8 +1011,10 @@ structure of @var{n}, but rather guarantees that the result will always be rounded towards minus infinity. Therefore, the results of ash and a corresponding bitwise shift will differ if @var{n} is negative. + Formally, the function returns an integer equivalent to @code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}. + @lisp (number->string (ash #b1 3) 2) @result{} "1000" (number->string (ash #b1010 -1) 2) @result{} "101" @@ -1020,6 +1026,7 @@ Return the number of bits in integer @var{n}. If integer is positive, the 1-bits in its binary representation are counted. If negative, the 0-bits in its two's-complement binary representation are counted. If 0, 0 is returned. + @lisp (logcount #b10101010) @result{} 4 @@ -1032,6 +1039,7 @@ representation are counted. If 0, 0 is returned. @deffn primitive integer-length n Return the number of bits neccessary to represent @var{n}. + @lisp (integer-length #b10101010) @result{} 8 @@ -1045,6 +1053,7 @@ Return the number of bits neccessary to represent @var{n}. @deffn primitive integer-expt n k Return @var{n} raised to the non-negative integer exponent @var{k}. + @lisp (integer-expt 2 5) @result{} 32 @@ -1057,6 +1066,7 @@ Return @var{n} raised to the non-negative integer exponent Return the integer composed of the @var{start} (inclusive) through @var{end} (exclusive) bits of @var{n}. The @var{start}th bit becomes the 0-th bit in the result. + @lisp (number->string (bit-extract #b1101101010 0 4) 2) @result{} "1010" @@ -1075,10 +1085,12 @@ Return a copy of the random state @var{state}. @deffn primitive random n [state] Return a number in [0,N). + Accepts a positive integer or real n and returns a number of the same type between zero (inclusive) and N (exclusive). The values returned have a uniform distribution. + The optional argument @var{state} must be of the type produced by @code{seed->random-state}. It defaults to the value of the variable @var{*random-state*}. This object is used to maintain @@ -1514,6 +1526,7 @@ return an unspecified value. @deffn primitive substring-fill! str start end fill Change every character in @var{str} between @var{start} and @var{end} to @var{fill}. + @lisp (define y "abcdefg") (substring-fill! y 1 3 #\r) @@ -1610,6 +1623,7 @@ ending in @code{-ci} ignore the character case when comparing strings. Lexicographic equality predicate; return @code{#t} if the two strings are the same length and contain the same characters in the same positions, otherwise return @code{#f}. + The procedure @code{string-ci=?} treats upper and lower case letters as though they were the same character, but @code{string=?} treats upper and lower case as distinct @@ -1689,6 +1703,7 @@ Return the index of the first occurrence of @var{chr} in @var{to} limit the search to a portion of the string. This procedure essentially implements the @code{index} or @code{strchr} functions from the C library. + @lisp (string-index "weiner" #\e) @result{} 1 @@ -1706,6 +1721,7 @@ Like @code{string-index}, but search from the right of the string rather than from the left. This procedure essentially implements the @code{rindex} or @code{strrchr} functions from the C library. + @lisp (string-rindex "weiner" #\e) @result{} 4 @@ -1763,6 +1779,7 @@ capitalized. @deffn primitive string-capitalize! str Upcase the first character of every word in @var{str} destructively and return @var{str}. + @lisp y @result{} "hello world" (string-capitalize! y) @result{} "Hello World" @@ -1862,8 +1879,10 @@ Compile the regular expression described by @var{pat}, and return the compiled regexp structure. If @var{pat} does not describe a legal regular expression, @code{make-regexp} throws a @code{regular-expression-syntax} error. + The @var{flags} arguments change the behavior of the compiled regular expression. The following flags may be supplied: + @table @code @item regexp/icase Consider uppercase and lowercase letters to be the same when @@ -2354,8 +2373,10 @@ letters in the non-standard case, but it is usually a bad idea to create such symbols because in some implementations of Scheme they cannot be read as themselves. See @code{symbol->string}. + The following examples assume that the implementation's standard case is lower case: + @lisp (eq? 'mISSISSIppi 'mississippi) @result{} #t (string->symbol "mISSISSIppi") @result{} @r{the symbol with name "mISSISSIppi"} @@ -2383,8 +2404,10 @@ returned will be the same as the case in the string that was passed to @code{string->symbol}. It is an error to apply mutation procedures like @code{string-set!} to strings returned by this procedure. + The following examples assume that the implementation's standard case is lower case: + @lisp (symbol->string 'flying-fish) @result{} "flying-fish" (symbol->string 'Martin) @result{} "martin" @@ -3804,11 +3827,13 @@ dimensions arranged in a different order. There must be one @var{dim0}, @var{dim1}, @dots{} should be integers between 0 and the rank of the array to be returned. Each integer in that range must appear at least once in the argument list. + The values of @var{dim0}, @var{dim1}, @dots{} correspond to dimensions in the array to be returned, their positions in the argument list to dimensions of @var{array}. Several @var{dim}s may have the same value, in which case the returned array will have smaller rank than @var{array}. + @lisp (transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d)) (transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d) @@ -4705,6 +4730,7 @@ function, but uses @var{hash} as a hash function and 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-ref table key} is equivalent to @code{hashx-ref hashq assq table key}. @end deffn @@ -4716,6 +4742,7 @@ function, but uses @var{hash} as a hash function and 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 @@ -4849,6 +4876,7 @@ unspecified. @deffnx primitive list->vector l Return a newly allocated vector whose elements contain the given arguments. Analogous to @code{list}. + @lisp (vector 'a 'b 'c) @result{} #(a b c) @end lisp @@ -4858,6 +4886,7 @@ given arguments. Analogous to @code{list}. @deffn primitive vector->list v Return a newly allocated list of the objects contained in the elements of @var{vector}. + @lisp (vector->list '#(dah dah didah)) @result{} (dah dah didah) (list->vector '(dididit dah)) @result{} #(dididit dah) diff --git a/doc/scheme-debug.texi b/doc/scheme-debug.texi index d8876cba8..cbb35cb17 100644 --- a/doc/scheme-debug.texi +++ b/doc/scheme-debug.texi @@ -139,7 +139,7 @@ Create a new stack. If @var{obj} is @code{#t}, the current evaluation stack is used for creating the stack frames, otherwise the frames are taken from @var{obj} (which must be either a debug object or a continuation). -@var{args} must be a list if integers and specifies how the +@var{args} must be a list of integers and specifies how the resulting stack will be narrowed. @end deffn diff --git a/doc/scheme-evaluation.texi b/doc/scheme-evaluation.texi index e1541bf70..d3edc523f 100644 --- a/doc/scheme-evaluation.texi +++ b/doc/scheme-evaluation.texi @@ -226,7 +226,7 @@ the current module. @deffn primitive eval2 obj env_thunk Evaluate @var{exp}, a Scheme expression, in the environment -designated by @var{lookup}, a symbol-lookup function." +designated by @var{lookup}, a symbol-lookup function. Do not use this version of eval, it does not play well with the module system. Use @code{eval} or @code{primitive-eval} instead. diff --git a/doc/scheme-io.texi b/doc/scheme-io.texi index 3562e57ba..e538f0dc6 100644 --- a/doc/scheme-io.texi +++ b/doc/scheme-io.texi @@ -249,6 +249,7 @@ open. Sets the current position of @var{fd/port} to the integer @var{offset}, which is interpreted according to the value of @var{whence}. + One of the following variables should be supplied for @var{whence}: @defvar SEEK_SET @@ -262,6 +263,7 @@ Seek from the end of the file. @end defvar If @var{fd/port} is a file descriptor, the underlying system call is @code{lseek}. @var{port} may be a string port. + The value returned is the new position in the file. This means that the current position of a port can be obtained using: @lisp @@ -272,6 +274,7 @@ that the current position of a port can be obtained using: @deffn primitive ftell fd_port Return an integer representing the current position of @var{fd/port}, measured from the beginning. Equivalent to: + @lisp (seek port 0 SEEK_CUR) @end lisp @@ -378,6 +381,7 @@ otherwise, leave it in the input stream for the next read. If specified, store data only into the substring of @var{str} bounded by @var{start} and @var{end} (which default to the beginning and end of the string, respectively). + Return a pair consisting of the delimiter that terminated the string and the number of characters read. If reading stopped at the end of file, the delimiter returned is the @@ -714,6 +718,7 @@ Return a port capable of receiving or delivering characters as specified by the @var{modes} string (@pxref{File Ports, open-file}). @var{pv} must be a vector of length 5. Its components are as follows: + @enumerate 0 @item procedure accepting one character for output @@ -726,14 +731,17 @@ thunk for getting one character @item thunk for closing port (not by garbage collection) @end enumerate + For an output-only port only elements 0, 1, 2, and 4 need be procedures. For an input-only port only elements 3 and 4 need be procedures. Thunks 2 and 4 can instead be @code{#f} if there is no useful operation for them to perform. + If thunk 3 returns @code{#f} or an @code{eof-object} (@pxref{Input, eof-object?, ,r5rs, The Revised^5 Report on Scheme}) it indicates that the port has reached end-of-file. For example: + @lisp (define stdout (current-output-port)) (define p (make-soft-port @@ -744,6 +752,7 @@ For example: (lambda () (char-upcase (read-char))) (lambda () (display "@@" stdout))) "rw")) + (write p p) @result{} # @end lisp @end deffn diff --git a/doc/scheme-memory.texi b/doc/scheme-memory.texi index 196ba5318..e69de29bb 100644 --- a/doc/scheme-memory.texi +++ b/doc/scheme-memory.texi @@ -1,221 +0,0 @@ -@page -@node Memory Management -@chapter Memory Management and Garbage Collection - -@menu -* Garbage Collection:: -* Weak References:: -* Guardians:: -@end menu - - -@node Garbage Collection -@section Garbage Collection - -[FIXME: this is pasted in from Tom Lord's original guile.texi and should -be reviewed] - -@deffn primitive gc -Scans all of SCM objects and reclaims for further use those that are -no longer accessible. -@end deffn - -@deffn primitive gc-stats -Return an association list of statistics about Guile's current -use of storage. -@end deffn - -@deffn primitive object-address obj -Return an integer that for the lifetime of @var{obj} is uniquely -returned by this function for @var{obj} -@end deffn - -@deffn primitive unhash-name name -Flushes the glocs for @var{name}, or all glocs if @var{name} -is @code{#t}. -@end deffn - - -@node Weak References -@section Weak References - -[FIXME: This chapter is based on Mikael Djurfeldt's answer to a question -by Michael Livshin. Any mistakes are not theirs, of course. ] - -Weak references let you attach bookkeeping information to data so that -the additional information automatically disappears when the original -data is no longer in use and gets garbage collected. In a weak key hash, -the hash entry for that key disappears as soon as the key is no longer -referneced from anywhere else. For weak value hashes, the same happens -as soon as the value is no longer in use. Entries in a doubly weak hash -disappear when either the key or the value are not used anywhere else -anymore. - -Property lists offer the same kind of functionality as weak key hashes -in many situations. (@pxref{Property Lists}) - -Here's an example (a little bit strained perhaps, but one of the -examples is actually used in Guile): - -Assume that you're implementing a debugging system where you want to -associate information about filename and position of source code -expressions with the expressions themselves. - -Hashtables can be used for that, but if you use ordinary hash tables -it will be impossible for the scheme interpreter to "forget" old -source when, for example, a file is reloaded. - -To implement the mapping from source code expressions to positional -information it is necessary to use weak-key tables since we don't want -the expressions to be remembered just because they are in our table. - -To implement a mapping from source file line numbers to source code -expressions you would use a weak-value table. - -To implement a mapping from source code expressions to the procedures -they constitute a doubly-weak table has to be used. - -@menu -* Weak key hashes:: -* Weak vectors:: -@end menu - - -@node Weak key hashes -@subsection Weak key hashes - -@deffn primitive make-weak-key-hash-table size -@deffnx primitive make-weak-value-hash-table size -@deffnx primitive make-doubly-weak-hash-table size -Return a weak hash table with @var{size} buckets. As with any -hash table, choosing a good size for the table requires some -caution. -You can modify weak hash tables in exactly the same way you -would modify regular hash tables. (@pxref{Hash Tables}) -@end deffn - -@deffn primitive weak-key-hash-table? obj -@deffnx primitive weak-value-hash-table? obj -@deffnx primitive doubly-weak-hash-table? obj -Return @code{#t} if @var{obj} is the specified weak hash -table. Note that a doubly weak hash table is neither a weak key -nor a weak value hash table. -@end deffn - -@deffn primitive make-weak-value-hash-table k -@end deffn - -@deffn primitive weak-value-hash-table? x -@end deffn - -@deffn primitive make-doubly-weak-hash-table k -@end deffn - -@deffn primitive doubly-weak-hash-table? x -@end deffn - - -@node Weak vectors -@subsection Weak vectors - -Weak vectors are mainly useful in Guile's implementation of weak hash -tables. - -@deffn primitive make-weak-vector size [fill] -Return a weak vector with @var{size} elements. If the optional -argument @var{fill} is given, all entries in the vector will be -set to @var{fill}. The default value for @var{fill} is the -empty list. -@end deffn - -@deffn primitive weak-vector . l -@deffnx primitive list->weak-vector l -Construct a weak vector from a list: @code{weak-vector} uses -the list of its arguments while @code{list->weak-vector} uses -its only argument @var{l} (a list) to construct a weak vector -the same way @code{list->vector} would. -@end deffn - -@deffn primitive weak-vector? obj -Return @code{#t} if @var{obj} is a weak vector. Note that all -weak hashes are also weak vectors. -@end deffn - - -@node Guardians -@section Guardians - -@deffn primitive make-guardian [greedy?] -Create a new guardian. -A guardian protects a set of objects from garbage collection, -allowing a program to apply cleanup or other actions. - -@code{make-guardian} returns a procedure representing the guardian. -Calling the guardian procedure with an argument adds the -argument to the guardian's set of protected objects. -Calling the guardian procedure without an argument returns -one of the protected objects which are ready for garbage -collection, or @code{#f} if no such object is available. -Objects which are returned in this way are removed from -the guardian. - -@code{make-guardian} takes one optional argument that says whether the -new guardian should be greedy or sharing. If there is any chance -that any object protected by the guardian may be resurrected, -then you should make the guardian greedy (this is the default). - -See R. Kent Dybvig, Carl Bruggeman, and David Eby (1993) -"Guardians in a Generation-Based Garbage Collector". -ACM SIGPLAN Conference on Programming Language Design -and Implementation, June 1993. - -(the semantics are slightly different at this point, but the -paper still (mostly) accurately describes the interface). -@end deffn - -@deffn primitive destroy-guardian! guardian -Destroys @var{guardian}, by making it impossible to put any more -objects in it or get any objects from it. It also unguards any -objects guarded by @var{guardian}. -@end deffn - -@deffn primitive guardian-greedy? guardian -Return @code{#t} if @var{guardian} is a greedy guardian, otherwise @code{#f}. -@end deffn - -@deffn primitive guardian-destroyed? guardian -Return @code{#t} if @var{guardian} has been destroyed, otherwise @code{#f}. -@end deffn - - -@page -@node Objects -@chapter Objects - -@deffn primitive entity? obj -Return @code{#t} if @var{obj} is an entity. -@end deffn - -@deffn primitive operator? obj -Return @code{#t} if @var{obj} is an operator. -@end deffn - -@deffn primitive set-object-procedure! obj proc -Return the object procedure of @var{obj} to @var{proc}. -@var{obj} must be either an entity or an operator. -@end deffn - -@deffn primitive make-class-object metaclass layout -Create a new class object of class @var{metaclass}, with the -slot layout specified by @var{layout}. -@end deffn - -@deffn primitive make-subclass-object class layout -Create a subclass object of @var{class}, with the slot layout -specified by @var{layout}. -@end deffn - - -@c Local Variables: -@c TeX-master: "guile.texi" -@c End: diff --git a/doc/scheme-modules.texi b/doc/scheme-modules.texi index 0445b15b8..1ff18961d 100644 --- a/doc/scheme-modules.texi +++ b/doc/scheme-modules.texi @@ -99,7 +99,7 @@ to have access to all procedures and variables exported from the module. * General Information about Modules:: Guile module basics. * Loading Guile Modules:: How to use existing modules. * Creating Guile Modules:: How to package your code into modules. -* More Module Procedures:: Low--level module code. +* More Module Procedures:: Low-level module code. * Included Guile Modules:: Which modules come with Guile? @end menu @@ -108,7 +108,7 @@ to have access to all procedures and variables exported from the module. A Guile module is a collection of procedures, variables and syntactic forms (macros), which are either public or private. Public bindings are -in the so--called @dfn{export list} of a module and can be made visible +in the so-called @dfn{export list} of a module and can be made visible to other modules, which import them. This @dfn{module import} is called @dfn{using} of a module, and consists of loading of the module code (if it has not already been loaded) and making all exported items of the @@ -132,7 +132,7 @@ example, the @code{(ice-9 popen)} module would result in the filename Guile and in all other directories in the load path. @c FIXME::martin: Not sure about this, maybe someone knows better? -Every module has a so--called syntax transformer associated with it. +Every module has a so-called syntax transformer associated with it. This is a procedure which performs all syntax transformation for the time the module is read in and evaluated. When working with modules, you can manipulate the current syntax transformer using the @@ -150,7 +150,7 @@ the expansion. When two or more modules are imported, and they export bindings with the same names, the last imported module wins, and the exported binding of that last module will silently be used. This might lead to -hard--to--find errors because wrong procedures or variables are used. +hard-to-find errors because wrong procedures or variables are used. @node Loading Guile Modules @@ -225,7 +225,7 @@ example of this is @code{define-module} makes this module available to Guile programs under the given @var{module-specification}. -The @var{options} are keyword/value--pairs which specify more about the +The @var{options} are keyword/value pairs which specify more about the defined module. The recognized options and their meaning is shown in the following table. @@ -315,7 +315,7 @@ Mikael Djurfeldt's source-level debugging support for Guile Guile's support for multi threaded execution (@pxref{Scheduling}). @item (ice-9 rdelim) -Line-- and character--delimited input (REFFIXME). +Line- and character-delimited input (REFFIXME). @item (ice-9 documentation) Online documentation (REFFIXME). @@ -327,26 +327,26 @@ Support for @code{and-let*} (REFFIXME). Support for some additional string port procedures (REFFIXME). @item (srfi srfi-8) -Multiple--value handling with @code{receive} (REFFIXME). +Multiple-value handling with @code{receive} (REFFIXME). @item (srfi srfi-9) Record definition with @code{define-record-type} (REFFIXME). @item (srfi srfi-10) -Read--hash extension @code{#,()} (REFFIXME). +Read hash extension @code{#,()} (REFFIXME). @item (srfi srfi-11) -Multiple--value handling with @code{let-values} and @code{let-values*} +Multiple-value handling with @code{let-values} and @code{let-values*} (REFFIXME). @item (srfi srfi-13) String library (REFFIXME). @item (srfi srfi-14) -Character--set library (REFFIXME). +Character-set library (REFFIXME). @item (srfi srfi-17) -Getter--with--setter support (REFFIXME). +Getter-with-setter support (REFFIXME). @item (ice-9 slib) This module contains hooks for using Aubrey Jaffer's portable Scheme diff --git a/doc/scheme-procedures.texi b/doc/scheme-procedures.texi index 800e230f6..b526bf7e7 100644 --- a/doc/scheme-procedures.texi +++ b/doc/scheme-procedures.texi @@ -521,6 +521,7 @@ result of applying @var{code} to the expression and the environment. The value returned from @var{code} which has been passed to @code{procedure->memoizing-macro} replaces the form passed to @var{code}. For example: + @lisp (define trace (procedure->macro @@ -537,6 +538,7 @@ result of applying @var{proc} to the expression and the environment. The value returned from @var{proc} which has been passed to @code{procedure->memoizing-macro} replaces the form passed to @var{proc}. For example: + @lisp (define trace (procedure->macro diff --git a/libguile/ChangeLog b/libguile/ChangeLog index cc9b7ad64..49e8bae09 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,17 @@ +2001-05-04 Neil Jerram + + * eval.c (scm_promise_p), list.c (scm_append_x, scm_reverse_x), + symbols.c (scm_symbol_to_string), vports.c (scm_make_soft_port): + Change R4RS references to R5RS. + + * guile-snarf.awk.in: Fixes so that (i) blank lines in the + docstring source are correctly reproduced in the output (ii) + we don't anymore get occasional trailing quotes. Also reorganized + and commented the code a little. + + * scmsigs.c (scm_raise), throw.c (scm_throw): Docstring format + fixes. + 2001-05-04 Martin Grabmueller * strop.c (scm_string_split): New procedure. diff --git a/libguile/eval.c b/libguile/eval.c index 4dad2a678..67a45a9dd 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3809,7 +3809,7 @@ SCM_DEFINE (scm_force, "force", 1, 0, 0, SCM_DEFINE (scm_promise_p, "promise?", 1, 0, 0, (SCM obj), "Return true if @var{obj} is a promise, i.e. a delayed computation\n" - "(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}).") + "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).") #define FUNC_NAME s_scm_promise_p { return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise, obj)); diff --git a/libguile/guile-snarf.awk.in b/libguile/guile-snarf.awk.in index 64641efad..8d2e73bb3 100644 --- a/libguile/guile-snarf.awk.in +++ b/libguile/guile-snarf.awk.in @@ -96,17 +96,35 @@ BEGIN { FS="|"; print "@deffn primitive " nicer_function_proto > dot_doc_file; } -/SCM_SNARF_DOCSTRING_START/,/SCM_SNARF_DOCSTRING_END.*$/ { copy = $0; - gsub(/.*SCM_SNARF_DOCSTRING_START/,"",copy); - sub(/^\#.*/,"", copy); - sub(/^[ \t]*\"?/,"", copy); - sub(/\"?[ \t]*SCM_SNARF_DOCSTRING_END.*$/,"", copy); - gsub(/\\n\\n\"?/,"\n",copy); - gsub(/\\n\"?[ \t]*$/,"",copy); - gsub(/\\\"/,"\"",copy); - gsub(/\\\\/,"\\",copy); - gsub(/[ \t]*$/,"", copy); - if (copy != "") { print copy > dot_doc_file } +/SCM_SNARF_DOCSTRING_START/,/SCM_SNARF_DOCSTRING_END.*$/ { copy = $0; + + # Trim everything up to and including + # SCM_SNARF_DOCSTRING_START marker. + gsub(/.*SCM_SNARF_DOCSTRING_START/,"",copy); + + # Trim leading whitespace and opening quote. + sub(/^[ \t]*\"?/,"", copy); + + # Trim closing quote and trailing whitespace, or + # closing quote and whitespace followed by the + # SCM_SNARF_DOCSTRING_END marker. + sub(/[ \t]*\"?[ \t]*$/,"", copy); + sub(/[ \t]*\"?[ \t]*SCM_SNARF_DOCSTRING_END.*$/,"", copy); + + # Replace escaped characters. + gsub(/\\n/,"\n",copy); + gsub(/\\\"/,"\"",copy); + gsub(/\\\\/,"\\",copy); + + # Some docstrings end each line with "\n", while + # others don't. Therefore we always strip off one "\n" + # if present at the end of the line. Docstrings must + # therefore always use "\n\n" to indicate a blank line. + if (copy != "") + { + sub(/[ \t]*\n$/, "", copy); + print copy > dot_doc_file; + } } /SCM_SNARF_DOCSTRING_END[ \t]*/ { print "@end deffn" >> dot_doc_file; } diff --git a/libguile/list.c b/libguile/list.c index bf1a1725c..956a4aa85 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -237,7 +237,7 @@ SCM_DEFINE (scm_append, "append", 0, 0, 1, SCM_DEFINE (scm_append_x, "append!", 0, 0, 1, (SCM lists), "A destructive version of @code{append} (@pxref{Pairs and\n" - "Lists,,,r4rs, The Revised^4 Report on Scheme}). The cdr field\n" + "Lists,,,r5rs, The Revised^5 Report on Scheme}). The cdr field\n" "of each list's final pair is changed to point to the head of\n" "the next list, so no consing is performed. Return a pointer to\n" "the mutated list.") @@ -321,8 +321,8 @@ SCM_DEFINE (scm_reverse, "reverse", 1, 0, 0, SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0, (SCM lst, SCM new_tail), - "A destructive version of @code{reverse} (@pxref{Pairs and Lists,,,r4rs,\n" - "The Revised^4 Report on Scheme}). The cdr of each cell in @var{lst} is\n" + "A destructive version of @code{reverse} (@pxref{Pairs and Lists,,,r5rs,\n" + "The Revised^5 Report on Scheme}). The cdr of each cell in @var{lst} is\n" "modified to point to the previous list element. Return a pointer to the\n" "head of the reversed list.\n\n" "Caveat: because the list is modified in place, the tail of the original\n" diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index 1625c3a87..bc57429ae 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -470,7 +470,6 @@ SCM_DEFINE (scm_usleep, "usleep", 1, 0, 0, SCM_DEFINE (scm_raise, "raise", 1, 0, 0, (SCM sig), - "\n" "Sends a specified signal @var{sig} to the current process, where\n" "@var{sig} is as described for the kill procedure.") #define FUNC_NAME s_scm_raise diff --git a/libguile/symbols.c b/libguile/symbols.c index 0f47fa3be..1bb2778a8 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -430,7 +430,7 @@ SCM_DEFINE (scm_symbol_to_string, "symbol->string", 1, 0, 0, (SCM s), "Return the name of @var{symbol} as a string. If the symbol was\n" "part of an object returned as the value of a literal expression\n" - "(section @pxref{Literal expressions,,,r4rs, The Revised^4\n" + "(section @pxref{Literal expressions,,,r5rs, The Revised^5\n" "Report on Scheme}) or by a call to the @code{read} procedure,\n" "and its name contains alphabetic characters, then the string\n" "returned will contain characters in the implementation's\n" diff --git a/libguile/throw.c b/libguile/throw.c index a4e610b7b..8be37a006 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -591,7 +591,7 @@ SCM_DEFINE (scm_throw, "throw", 1, 0, 1, "Invoke the catch form matching @var{key}, passing @var{args} to the\n" "@var{handler}. \n\n" "@var{key} is a symbol. It will match catches of the same symbol or of\n" - "#t.\n\n" + "@code{#t}.\n\n" "If there is no handler at all, Guile prints an error and then exits.") #define FUNC_NAME s_scm_throw { diff --git a/libguile/vports.c b/libguile/vports.c index 9a4975aff..ba4230e50 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -171,7 +171,7 @@ SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0, "there is no useful operation for them to perform.\n" "\n" "If thunk 3 returns @code{#f} or an @code{eof-object}\n" - "(@pxref{Input, eof-object?, ,r4rs, The Revised^4 Report on\n" + "(@pxref{Input, eof-object?, ,r5rs, The Revised^5 Report on\n" "Scheme}) it indicates that the port has reached end-of-file.\n" "For example:\n" "\n" From 018a53a198c48e199123d27c941486f4af8c851b Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sat, 5 May 2001 08:30:17 +0000 Subject: [PATCH 0995/2047] * acconfig.h: add HAVE_IPV6. * configure.in: check whether we can compile with IPv6 support. --- ChangeLog | 5 +++++ acconfig.h | 3 +++ configure.in | 10 ++++++++++ 3 files changed, 18 insertions(+) diff --git a/ChangeLog b/ChangeLog index 13f606a9c..51364b410 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2001-05-05 Gary Houston + + * acconfig.h: add HAVE_IPV6. + * configure.in: check whether we can compile with IPv6 support. + 2001-05-04 Thien-Thi Nguyen * guile-tools.in: New file. diff --git a/acconfig.h b/acconfig.h index fa3d8d5c7..1f14a914e 100644 --- a/acconfig.h +++ b/acconfig.h @@ -119,6 +119,9 @@ /* Define if uint32_t typedef is defined when netdb.h is include. */ #undef HAVE_UINT32_T +/* Define if you want support for IPv6. */ +#undef HAVE_IPV6 + /* Define if localtime caches the TZ setting. */ #undef LOCALTIME_CACHE diff --git a/configure.in b/configure.in index 19b606377..8676efe63 100644 --- a/configure.in +++ b/configure.in @@ -287,6 +287,16 @@ if test $guile_cv_have_uint32_t = yes; then AC_DEFINE(HAVE_UINT32_T) fi +AC_MSG_CHECKING(for working IPv6 support) +AC_CACHE_VAL(guile_cv_have_ipv6, +[AC_TRY_COMPILE([#include ], +[struct sockaddr_in6 a; a.sin6_family = AF_INET6;], +guile_cv_have_ipv6=yes, guile_cv_have_ipv6=no)]) +AC_MSG_RESULT($guile_cv_have_ipv6) +if test $guile_cv_have_ipv6 = yes; then + AC_DEFINE(HAVE_IPV6) +fi + # included in rfc2553 but not in older implementations, e.g., glibc 2.1.3. AC_MSG_CHECKING(whether sockaddr_in6 has sin6_scope_id) AC_CACHE_VAL(guile_cv_have_sin6_scope_id, From a57a0b1e6a049d27b0770a89ff72caae94fbea51 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sat, 5 May 2001 08:31:00 +0000 Subject: [PATCH 0996/2047] * socket.c: use HAVE_IPV6 instead of AF_INET6 to enable IPv6 support. --- libguile/ChangeLog | 5 +++++ libguile/socket.c | 10 +++++----- 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 49e8bae09..8b65a5cf9 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-05-05 Gary Houston + + * socket.c: use HAVE_IPV6 instead of AF_INET6 to enable IPv6 + support. + 2001-05-04 Neil Jerram * eval.c (scm_promise_p), list.c (scm_append_x, scm_reverse_x), diff --git a/libguile/socket.c b/libguile/socket.c index 4e60d16f6..c9cbef07b 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -254,7 +254,7 @@ SCM_DEFINE (scm_inet_makeaddr, "inet-makeaddr", 2, 0, 0, #undef FUNC_NAME #endif -#ifdef AF_INET6 +#ifdef HAVE_IPV6 /* flip a 128 bit IPv6 address between host and network order. */ #ifdef WORDS_BIGENDIAN @@ -419,7 +419,7 @@ SCM_DEFINE (scm_inet_ntop, "inet-ntop", 2, 0, 0, #undef FUNC_NAME #endif -#endif /* AF_INET6 */ +#endif /* HAVE_IPV6 */ SCM_SYMBOL (sym_socket, "socket"); @@ -713,7 +713,7 @@ scm_fill_sockaddr (int fam, SCM address, SCM *args, int which_arg, *size = sizeof (struct sockaddr_in); return (struct sockaddr *) soka; } -#ifdef AF_INET6 +#ifdef HAVE_IPV6 case AF_INET6: { /* see RFC2553. */ @@ -933,7 +933,7 @@ scm_addr_vector (const struct sockaddr *address, const char *proc) ve[2] = scm_ulong2num ((unsigned long) ntohs (nad->sin_port)); } break; -#ifdef AF_INET6 +#ifdef HAVE_IPV6 case AF_INET6: { const struct sockaddr_in6 *nad = (struct sockaddr_in6 *) address; @@ -982,7 +982,7 @@ scm_addr_vector (const struct sockaddr *address, const char *proc) #define MAX_SIZE_UN 0 #endif -#if defined (AF_INET6) +#if defined (HAVE_IPV6) #define MAX_SIZE_IN6 sizeof (struct sockaddr_in6) #else #define MAX_SIZE_IN6 0 From b6f04d92f70ed26fc7ebea99505b2c24fc51d8f2 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sat, 5 May 2001 08:41:01 +0000 Subject: [PATCH 0997/2047] * better have sys/socket.h too. --- configure.in | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/configure.in b/configure.in index 8676efe63..f233c0d91 100644 --- a/configure.in +++ b/configure.in @@ -289,7 +289,8 @@ fi AC_MSG_CHECKING(for working IPv6 support) AC_CACHE_VAL(guile_cv_have_ipv6, -[AC_TRY_COMPILE([#include ], +[AC_TRY_COMPILE([#include +#include ], [struct sockaddr_in6 a; a.sin6_family = AF_INET6;], guile_cv_have_ipv6=yes, guile_cv_have_ipv6=no)]) AC_MSG_RESULT($guile_cv_have_ipv6) From 725fd9806aebf648464dcd3d52c10ade17d956ab Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 5 May 2001 13:40:18 +0000 Subject: [PATCH 0998/2047] * New material on macros. --- doc/ChangeLog | 8 ++ doc/scheme-data.texi | 21 +-- doc/scheme-procedures.texi | 264 ++++++++++++++++++++++++++++++++----- 3 files changed, 250 insertions(+), 43 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 5bbc58bd3..24f5e991e 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,11 @@ +2001-05-05 Neil Jerram + + * scheme-procedures.texi (Macros, Syntax Rules, Internal Macros): + New material. + (Syntax Case): New node, but currently empty. + + * scheme-data.texi (Booleans, Symbols): Supply cross-references. + 2001-05-04 Neil Jerram * new-docstrings.texi, posix.texi, scheme-control.texi, diff --git a/doc/scheme-data.texi b/doc/scheme-data.texi index a541752ee..7c5b649ca 100755 --- a/doc/scheme-data.texi +++ b/doc/scheme-data.texi @@ -69,7 +69,8 @@ The two boolean values are @code{#t} for true and @code{#f} for false. Boolean values are returned by predicate procedures, such as the general equality predicates @code{eq?}, @code{eqv?} and @code{equal?} (@pxref{Equality}) and numerical and string comparison operators like -@code{string=?} (REFFIXME) and @code{<=} (REFFIXME). +@code{string=?} (@pxref{String Comparison}) and @code{<=} +(@pxref{Comparison}). @lisp (<= 3 8) @@ -89,8 +90,8 @@ equality predicates @code{eq?}, @code{eqv?} and @code{equal?} #t @end lisp -In test condition contexts like @code{if} (REFFIXME) and @code{cond} -(REFFIXME), where a group of subexpressions will be evaluated only if a +In test condition contexts like @code{if} and @code{cond} (@pxref{if +cond case}), where a group of subexpressions will be evaluated only if a @var{condition} expression evaluates to ``true'', ``true'' means any value at all except @code{#f}. @@ -2312,9 +2313,9 @@ can be compared extremely efficiently, although they carry more information for the human reader than, say, numbers. It is very common in Scheme programs to use symbols as keys in -association lists (REFFIXME) or hash tables (REFFIXME), because this -usage improves the readability a lot, and does not cause any performance -loss. +association lists (@pxref{Association Lists}) or hash tables +(@pxref{Hash Tables}), because this usage improves the readability a +lot, and does not cause any performance loss. The read syntax for symbols is a sequence of letters, digits, and @emph{extended alphabetic characters} that begins with a character that @@ -2329,10 +2330,10 @@ they were letters. The following are extended alphabetic characters: @end example In addition to the read syntax defined above (which is taken from R5RS -(REFFIXME)), Guile provides a method for writing symbols with unusual -characters, such as space characters. If you (for whatever reason) need -to write a symbol containing characters not mentioned above, you write -symbols as follows: +(@pxref{Formal syntax,,,r5rs,The Revised^5 Report on Scheme})), Guile +provides a method for writing symbols with unusual characters, such as +space characters. If you (for whatever reason) need to write a symbol +containing characters not mentioned above, you write symbols as follows: @itemize @bullet @item diff --git a/doc/scheme-procedures.texi b/doc/scheme-procedures.texi index b526bf7e7..62d99e519 100644 --- a/doc/scheme-procedures.texi +++ b/doc/scheme-procedures.texi @@ -7,7 +7,10 @@ * Optional Arguments:: Handling keyword, optional and rest arguments. * Procedure Properties:: Procedure properties and metainformation. * Procedures with Setters:: Procedures with setters. -* Macros:: Macros. +* Macros:: Lisp style macro definitions. +* Syntax Rules:: Support for R5RS @code{syntax-rules}. +* Syntax Case:: Support for the @code{syntax-case} system. +* Internal Macros:: Guile's internal representation. @end menu @@ -500,54 +503,249 @@ setter or an operator struct. @node Macros -@section Macros +@section Lisp Style Macro Definitions -[FIXME: This needs some more text on the difference between procedures, -macros and memoizing macros. Also, any definitions listed here should -be double-checked by someone who knows what's going on. Ask Mikael, Jim -or Aubrey for help. -twp] +@cindex macros +@cindex transformation +Macros are objects which cause the expression that they appear in to be +transformed in some way @emph{before} being evaluated. In expressions +that are intended for macro transformation, the identifier that names +the relevant macro must appear as the first element, like this: + +@lisp +(@var{macro-name} @var{macro-args} @dots{}) +@end lisp + +In Lisp-like languages, the traditional way to define macros is very +similar to procedure definitions. The key differences are that the +macro definition body should return a list that describes the +transformed expression, and that the definition is marked as a macro +definition (rather than a procedure definition) by the use of a +different definition keyword: in Lisp, @code{defmacro} rather than +@code{defun}, and in Scheme, @code{define-macro} rather than +@code{define}. + +@fnindex defmacro +@fnindex define-macro +Guile supports this style of macro definition using both @code{defmacro} +and @code{define-macro}. The only difference between them is how the +macro name and arguments are grouped together in the definition: + +@lisp +(defmacro @var{name} (@var{args} @dots{}) @var{body} @dots{}) +@end lisp + +@noindent +is the same as + +@lisp +(define-macro (@var{name} @var{args} @dots{}) @var{body} @dots{}) +@end lisp + +@noindent +The difference is analogous to the corresponding difference between +Lisp's @code{defun} and Scheme's @code{define}. + +@code{false-if-exception}, from the @file{boot-9.scm} file in the Guile +distribution, is a good example of macro definition using +@code{defmacro}: + +@lisp +(defmacro false-if-exception (expr) + `(catch #t + (lambda () ,expr) + (lambda args #f))) +@end lisp + +@noindent +The effect of this definition is that expressions beginning with the +identifier @code{false-if-exception} are automatically transformed into +a @code{catch} expression following the macro definition specification. +For example: + +@lisp +(false-if-exception (open-input-file "may-not-exist")) +@equiv{} +(catch #t + (lambda () (open-input-file "may-not-exist")) + (lambda args #f)) +@end lisp + + +@node Syntax Rules +@section The R5RS @code{syntax-rules} System + +R5RS defines an alternative system for macro and syntax transformations +using the keywords @code{define-syntax}, @code{let-syntax}, +@code{letrec-syntax} and @code{syntax-rules}. + +The main difference between the R5RS system and the traditional macros +of the previous section is how the transformation is specified. In +R5RS, rather than permitting a macro definition to return an arbitrary +expression, the transformation is specified in a pattern language that + +@itemize @bullet +@item +does not require complicated quoting and extraction of components of the +source expression using @code{caddr} etc. + +@item +is designed such that the bindings associated with identifiers in the +transformed expression are well defined, and such that it is impossible +for the transformed expression to construct new identifiers. +@end itemize + +@noindent +The last point is commonly referred to as being @dfn{hygienic}: the R5RS +@code{syntax-case} system provides @dfn{hygienic macros}. + +For example, the R5RS pattern language for the @code{false-if-exception} +example of the previous section looks like this: + +@lisp +(syntax-rules () + ((_ expr) + (catch #t + (lambda () expr) + (lambda args #f)))) +@end lisp + +In Guile, the @code{syntax-rules} system is provided by the @code{(ice-9 +syncase)} module. To make these facilities available in your code, +include the expression @code{(use-modules (ice-9 syncase))} or +@code{(use-syntax (ice-9 syncase))} (@pxref{Loading Guile Modules}) +before the first usage of @code{define-syntax} etc. If you are writing +a Scheme module, you can alternatively use one of the keywords +@code{#:use-module} and @code{#:use-syntax} in your @code{define-module} +declaration (@pxref{Creating Guile Modules}). + +@menu +* Pattern Language:: The @code{syntax-rules} pattern language. +* Define-Syntax:: Top level syntax definitions. +* Let-Syntax:: Local syntax definitions. +@end menu + + +@node Pattern Language +@subsection The @code{syntax-rules} Pattern Language + + +@node Define-Syntax +@subsection Top Level Syntax Definitions + +define-syntax: The gist is + + (define-syntax ) + +makes the into a macro so that + + ( ...) + +expands at _compile_ or _read_ time (i.e. before any +evaluation begins) into some expression that is +given by the . + + +@node Let-Syntax +@subsection Local Syntax Definitions + + +@node Syntax Case +@section Support for the @code{syntax-case} System + + + +@node Internal Macros +@section Internal Representation of Macros and Syntax + +Internally, Guile uses three different flavours of macros. The three +flavours are called @dfn{acro} (or @dfn{syntax}), @dfn{macro} and +@dfn{mmacro}. + +Given the expression + +@lisp +(foo @dots{}) +@end lisp + +@noindent +with @code{foo} being some flavour of macro, one of the following things +will happen when the expression is evaluated. + +@itemize +@item +When @code{foo} has been defined to be an @dfn{acro}, the procedure used +in the acro definition of @code{foo} is passed the whole expression and +the current lexical environment, and whatever that procedure returns is +the value of evaluating the expression. You can think of this a +procedure that receives its argument as an unevaluated expression. + +@item +When @code{foo} has been defined to be a @dfn{macro}, the procedure used +in the macro definition of @code{foo} is passed the whole expression and +the current lexical environment, and whatever that procedure returns is +evaluated again. That is, the procedure should return a valid Scheme +expression. + +@item +When @code{foo} has been defined to be a @dfn{mmacro}, the procedure +used in the mmacro definition of `foo' is passed the whole expression +and the current lexical environment, and whatever that procedure returns +replaces the original expression. Evaluation then starts over from the +new expression that has just been returned. +@end itemize + +The key difference between a @dfn{macro} and a @dfn{mmacro} is that the +expression returned by a @dfn{mmacro} procedure is remembered (or +@dfn{memoized}) so that the expansion does not need to be done again +next time the containing code is evaluated. + +The primitives @code{procedure->syntax}, @code{procedure->macro} and +@code{procedure->memoizing-macro} are used to construct acros, macros +and mmacros respectively. However, if you do not have a very special +reason to use one of these primitives, you should avoid them: they are +very specific to Guile's current implementation and therefore likely to +change. Use @code{defmacro}, @code{define-macro} (@pxref{Macros}) or +@code{define-syntax} (@pxref{Syntax Rules}) instead. (In low level +terms, @code{defmacro}, @code{define-macro} and @code{define-syntax} are +all implemented as mmacros.) @deffn primitive procedure->syntax code -Return a @dfn{macro} which, when a symbol defined to this value -appears as the first symbol in an expression, returns the -result of applying @var{code} to the expression and the -environment. +Return a macro which, when a symbol defined to this value appears as the +first symbol in an expression, returns the result of applying @var{code} +to the expression and the environment. @end deffn @deffn primitive procedure->macro code -Return a @dfn{macro} which, when a symbol defined to this value -appears as the first symbol in an expression, evaluates the -result of applying @var{code} to the expression and the -environment. The value returned from @var{code} which has been -passed to @code{procedure->memoizing-macro} replaces the form -passed to @var{code}. For example: +Return a macro which, when a symbol defined to this value appears as the +first symbol in an expression, evaluates the result of applying +@var{code} to the expression and the environment. For example: @lisp (define trace (procedure->macro - (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x)))))) + (lambda (x env) + `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x)))))) -(trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})). +(trace @i{foo}) +@equiv{} +(set! @i{foo} (tracef @i{foo} '@i{foo})). @end lisp @end deffn @deffn primitive procedure->memoizing-macro code -Return a @dfn{macro} which, when a symbol defined to this value -appears as the first symbol in an expression, evaluates the -result of applying @var{proc} to the expression and the -environment. The value returned from @var{proc} which has been -passed to @code{procedure->memoizing-macro} replaces the form -passed to @var{proc}. For example: - -@lisp -(define trace - (procedure->macro - (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x)))))) - -(trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})). -@end lisp +Return a macro which, when a symbol defined to this value appears as the +first symbol in an expression, evaluates the result of applying +@var{code} to the expression and the environment. +@code{procedure->memoizing-macro} is the same as +@code{procedure->macro}, except that the expression returned by +@var{code} replaces the original macro expression in the memoized form +of the containing code. @end deffn +In the following primitives, @dfn{acro} flavour macros are referred to +as @dfn{syntax transformers}. + @deffn primitive macro? obj Return @code{#t} if @var{obj} is a regular macro, a memoizing macro or a syntax transformer. @@ -556,7 +754,7 @@ syntax transformer. @deffn primitive macro-type m Return one of the symbols @code{syntax}, @code{macro} or @code{macro!}, depending on whether @var{m} is a syntax -tranformer, a regular macro, or a memoizing macro, +transformer, a regular macro, or a memoizing macro, respectively. If @var{m} is not a macro, @code{#f} is returned. @end deffn From 4879243cdcc58bdfbe24ba72f1162ae2f1ee0be1 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 5 May 2001 13:41:59 +0000 Subject: [PATCH 0999/2047] * Correct error message in `use-syntax'. --- ice-9/ChangeLog | 5 +++++ ice-9/boot-9.scm | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 3d32842cd..e53f38fa1 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2001-05-05 Neil Jerram + + * boot-9.scm (use-syntax): Change error message to say + `use-syntax' rather than `use-modules'. + 2001-05-02 Martin Grabmueller * safe-r5rs.scm: Fix typo: make-rectangualr => make-rectangular. diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 053feec14..55253c592 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -2582,7 +2582,7 @@ `((set-module-transformer! (current-module) ,spec))) (fluid-set! scm:eval-transformer (module-transformer (current-module)))) (else - (error "use-modules can only be used at the top level")))) + (error "use-syntax can only be used at the top level")))) (define define-private define) From 3777a9d3b6617f9c333ad7dcf50d3e57af5726df Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 5 May 2001 13:49:14 +0000 Subject: [PATCH 1000/2047] * Add Martin to AUTHORS for reference manual. --- doc/AUTHORS | 75 --------------------------------------------------- doc/ChangeLog | 2 ++ 2 files changed, 2 insertions(+), 75 deletions(-) diff --git a/doc/AUTHORS b/doc/AUTHORS index 8c09603e1..e69de29bb 100644 --- a/doc/AUTHORS +++ b/doc/AUTHORS @@ -1,75 +0,0 @@ -@c This file is in -*-texinfo-*- mode because it gets @included by -@c the top level Texinfo source files for each manual in this -@c distribution. We do this so as to avoid having to maintain -@c authorship information in more than one place. - -@ifset guile - -@c The Guile reference and tutorial manuals were written and edited -@c largely by Mark Galassi and Jim Blandy. In particular, Jim wrote the -@c original tutorial on Guile's data representation and the C API for -@c accessing Guile objects. - -@c Significant portions were contributed by Gary Houston (contributions -@c to posix system calls and networking, expect, I/O internals and -@c extensions, slib installation, error handling) and Tim Pierce -@c (sections on script interpreter triggers, alists, function tracing). - -@c Tom Lord contributed a great deal of material with early Guile -@c snapshots; although most of this text has been rewritten, all of it -@c was important, and much of the structure remains. - -@c Aubrey Jaffer wrote the SCM Scheme implementation and manual upon -@c which the Guile program and manual are based. Some portions of the -@c SCM and SLIB manuals have been included here verbatim. - -@c Since Guile 1.4, Neil Jerram has been maintaining and improving the -@c reference manual. Among other contributions, he wrote the Basic -@c Ideas chapter, developed the tools for keeping the manual in sync -@c with snarfed libguile docstrings, and reorganized the structure so as -@c to accommodate docstrings for all Guile's primitives. - -@author Mark Galassi -@author Cygnus Solution and Los Alamos National Laboratory -@author @email{rosalia@@cygnus.com} -@author -@author Jim Blandy -@author Free Software Foundation and MIT AI Lab -@author @email{jimb@@red-bean.com} -@author -@author Gary Houston -@author @email{ghouston@@arglist.com} -@author -@author Tim Pierce -@author @email{twp@@skepsis.com} -@author -@author Neil Jerram -@author @email{neil@@ossau.uklinux.net} - -@end ifset - -@ifset guile-tut - -@author Mark Galassi -@author Cygnus Solutions and Los Alamos National Laboratory -@author @email{rosalia@@nis.lanl.gov} - -@end ifset - -@ifset goops - -@c The GOOPS tutorial was written by Christian Lynbech and Mikael -@c Djurfeldt, who also wrote GOOPS itself. The GOOPS reference manual -@c and MOP documentation were written by Neil Jerram and reviewed by -@c Mikael Djurfeldt. - -@author Christian Lynbech -@author @email{chl@@tbit.dk} -@author -@author Mikael Djurfeldt -@author @email{djurfeldt@@nada.kth.se} -@author -@author Neil Jerram -@author @email{neil@@ossau.uklinux.net} - -@end ifset diff --git a/doc/ChangeLog b/doc/ChangeLog index 24f5e991e..2e3293b37 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,5 +1,7 @@ 2001-05-05 Neil Jerram + * AUTHORS: Added Martin Grabmueller. + * scheme-procedures.texi (Macros, Syntax Rules, Internal Macros): New material. (Syntax Case): New node, but currently empty. From 67dc6a4ea26ddd00c41ec3a095843249ea9fa6c9 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 5 May 2001 19:03:42 +0000 Subject: [PATCH 1001/2047] (scm_definedp): Fix docstring. --- libguile/evalext.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/libguile/evalext.c b/libguile/evalext.c index 22e0c2f36..55996b76f 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -71,7 +71,10 @@ scm_m_generalized_set_x (SCM xorig, SCM env) SCM_DEFINE (scm_definedp, "defined?", 1, 1, 0, (SCM sym, SCM env), - "Return @code{#t} if @var{sym} is defined in the top-level environment.") + "Return @code{#t} if @var{sym} is defined in the lexical " + "environment@var{env}. When @var{env} is not specified, " + "look in the top-level environment as as defined by the " + "current module.") #define FUNC_NAME s_scm_definedp { SCM vcell; From cec0d28c565f2a311e89d1657087a84b9f8d80da Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 5 May 2001 19:05:47 +0000 Subject: [PATCH 1002/2047] (scm_valid_object_procedure_p): New. (scm_set_object_procedure_x): Use it to check argument. Fix docstring. --- libguile/objects.c | 30 ++++++++++++++++++++++++++++-- libguile/objects.h | 3 ++- 2 files changed, 30 insertions(+), 3 deletions(-) diff --git a/libguile/objects.c b/libguile/objects.c index c5ddb0538..82033b378 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -374,9 +374,35 @@ SCM_DEFINE (scm_operator_p, "operator?", 1, 0, 0, } #undef FUNC_NAME +/* XXX - What code requires the object procedure to be only of certain + types? */ + +SCM_DEFINE (scm_valid_object_procedure_p, "valid-object-procedure?", 1, 0, 0, + (SCM proc), + "Return @code{#t} iff @var{proc} is a procedure that can be used " + "with @code{set-object-procedure}. It is always valid to use " + "a closure constructed by @code{lambda}.") +#define FUNC_NAME s_scm_valid_object_procedure_p +{ + if (SCM_IMP (proc)) + return SCM_BOOL_F; + switch (SCM_TYP7 (proc)) + { + default: + return SCM_BOOL_F; + case scm_tcs_closures: + case scm_tc7_subr_1: + case scm_tc7_subr_2: + case scm_tc7_subr_3: + case scm_tc7_lsubr_2: + return SCM_BOOL_T; + } +} +#undef FUNC_NAME + SCM_DEFINE (scm_set_object_procedure_x, "set-object-procedure!", 2, 0, 0, (SCM obj, SCM proc), - "Return the object procedure of @var{obj} to @var{proc}.\n" + "Set the object procedure of @var{obj} to @var{proc}.\n" "@var{obj} must be either an entity or an operator.") #define FUNC_NAME s_scm_set_object_procedure_x { @@ -388,7 +414,7 @@ SCM_DEFINE (scm_set_object_procedure_x, "set-object-procedure!", 2, 0, 0, obj, SCM_ARG1, FUNC_NAME); - SCM_VALIDATE_PROC (2,proc); + SCM_ASSERT (scm_valid_object_procedure_p (proc), proc, SCM_ARG2, FUNC_NAME); if (SCM_I_ENTITYP (obj)) SCM_SET_ENTITY_PROCEDURE (obj, proc); else diff --git a/libguile/objects.h b/libguile/objects.h index 110158a8e..20e3fb3ea 100644 --- a/libguile/objects.h +++ b/libguile/objects.h @@ -230,7 +230,8 @@ extern SCM scm_apply_generic (SCM gf, SCM args); extern SCM scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3); extern SCM scm_entity_p (SCM obj); extern SCM scm_operator_p (SCM obj); -extern SCM scm_set_object_procedure_x (SCM obj, SCM procs); +extern SCM scm_valid_object_procedure_p (SCM proc); +extern SCM scm_set_object_procedure_x (SCM obj, SCM proc); #ifdef GUILE_DEBUG extern SCM scm_object_procedure (SCM obj); #endif From a524a03f87f5e243e072b7ad1d02b29ffae1b8da Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 5 May 2001 19:08:32 +0000 Subject: [PATCH 1003/2047] (initialize-object-procedure): Use `valid-object-procedure?' instead of explicit tag magic. (object-procedure-tags): Removed. --- oop/goops.scm | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/oop/goops.scm b/oop/goops.scm index 9c18cf693..7cf7c7b64 100644 --- a/oop/goops.scm +++ b/oop/goops.scm @@ -1281,15 +1281,12 @@ ;; Set the layout slot (%prep-layout! class))) -(define object-procedure-tags - '(utag_closure utag_subr_1 utag_subr_2 utag_subr3 utag_lsubr_2)) - (define (initialize-object-procedure object initargs) (let ((proc (get-keyword #:procedure initargs #f))) (cond ((not proc)) ((pair? proc) (apply set-object-procedure! object proc)) - ((memq (tag proc) object-procedure-tags) + ((valid-object-procedure? proc) (set-object-procedure! object proc)) (else (set-object-procedure! object From 2b33d8dcd7744aa93840b4318154cd67aac91e93 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 5 May 2001 19:09:14 +0000 Subject: [PATCH 1004/2047] (top-level-env): Use `current-module' instead of the deprecated *top-level-lookup-closure*. --- oop/goops/util.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/oop/goops/util.scm b/oop/goops/util.scm index 0e6df4147..b5ab894da 100644 --- a/oop/goops/util.scm +++ b/oop/goops/util.scm @@ -80,9 +80,10 @@ (else (find-duplicate (cdr l))))) (define (top-level-env) - (if *top-level-lookup-closure* - (list *top-level-lookup-closure*) - '())) + (let ((mod (current-module))) + (if mod + (module-eval-closure mod) + '()))) (define (top-level-env? env) (or (null? env) From 96a4a5b2c40abb9a6fa854f7431c192f6c047d44 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 5 May 2001 19:11:36 +0000 Subject: [PATCH 1005/2047] Mention the new `--enable-deprecated=shutup' option. --- INSTALL | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/INSTALL b/INSTALL index 458b9c168..271c1da5e 100644 --- a/INSTALL +++ b/INSTALL @@ -98,9 +98,9 @@ switches specific to Guile you may find useful in some circumstances. a value of "no" will omit all deprecated features and you will get "undefined reference", "variable unbound" or similar errors when you try to use them. All other values will include all deprecated - features. The LEVEL argument is used as the default value for the - environment variable GUILE_WARN_DEPRECATED. See the README for - more information. + features. The LEVEL argument is used to determine the default value + for the environment variable GUILE_WARN_DEPRECATED. See the README + for more information. The default is to get a vague warning at program exit if deprecated features were used: @@ -114,8 +114,7 @@ switches specific to Guile you may find useful in some circumstances. To get no warnings: - [ FIXME: this doesn't seem to be possible, without setting the - environment variable ] + --enable-deprecated=shutup To omit deprecated features completely and irrevokably: From a5eebee787fc4ce4cbcbc2f20fa5df3019bf588f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 5 May 2001 19:13:54 +0000 Subject: [PATCH 1006/2047] Mention AUHTORS and THANKS in the `spiffing' phase. --- RELEASE | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/RELEASE b/RELEASE index c462887fa..c9b568d46 100644 --- a/RELEASE +++ b/RELEASE @@ -145,7 +145,7 @@ Spiffing checklist: copyright notices. This can be as simple as doing: grep 'Copyright' * | grep -v 1999 and looking for files you know you've worked on a lot. -* Make sure NEWS, INSTALL and the docs are up to date: +* Make sure NEWS, INSTALL, AUTHORS and THANKS and the docs are up to date: + Scan the ChangeLogs for user-visible changes, marked with an asterisk at the left margin. + Update NEWS and the Texinfo documentation as appropriate. @@ -153,6 +153,7 @@ Spiffing checklist: documented. + Check for any [[incomplete]] sections of NEWS. + Fact-check INSTALL. + + Make sure AUTHORS and THANKS are up-to-date. * Make sure the downloading addresses and filenames in README are current. (But don't bump the version number yet. We do that below.) * Check that the versions of aclocal, automake, autoconf, and autoheader From 94a0d8859a92d31bfedcaf257e41f6f6b742d8eb Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 5 May 2001 19:15:52 +0000 Subject: [PATCH 1007/2047] (--enable-deprecated): Recognize "shutup" option argument and turn it into the default warning level "no". --- configure.in | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/configure.in b/configure.in index f233c0d91..dbe5bbd28 100644 --- a/configure.in +++ b/configure.in @@ -103,9 +103,13 @@ if test "$enable_deprecated" = no; then AC_DEFINE(SCM_DEBUG_DEPRECATED) else if test "$enable_deprecated" = yes || test "$enable_deprecated" = ""; then - enable_deprecated=summary + warn_default=summary + elif test "$enable_deprecated" = shutup; then + warn_default=no + else + warn_default=$enable_deprecated fi - AC_DEFINE_UNQUOTED(GUILE_WARN_DEPRECATED_DEFAULT, "$enable_deprecated") + AC_DEFINE_UNQUOTED(GUILE_WARN_DEPRECATED_DEFAULT, "$warn_default") fi dnl The --disable-debug used to control these two. But now they are From c10ecc4c8177679874f2127c0526ee63bcafe097 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 5 May 2001 19:16:08 +0000 Subject: [PATCH 1008/2047] *** empty log message *** --- ChangeLog | 5 +++++ NEWS | 19 +++++++++++++------ README | 4 ++-- libguile/ChangeLog | 8 ++++++++ oop/ChangeLog | 9 +++++++++ 5 files changed, 37 insertions(+), 8 deletions(-) diff --git a/ChangeLog b/ChangeLog index 51364b410..ce5cd84a7 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2001-05-05 Marius Vollmer + + * configure.in (--enable-deprecated): Recognize "shutup" option + argument and turn it into the default warning level "no". + 2001-05-05 Gary Houston * acconfig.h: add HAVE_IPV6. diff --git a/NEWS b/NEWS index f01839ee1..94876886e 100644 --- a/NEWS +++ b/NEWS @@ -271,7 +271,7 @@ to write the empty list as a literal constant is to use quote: "'()". ** Auto-loading of compiled-code modules is deprecated. Guile used to be able to automatically find and link a shared -libraries to satisfy requests for a module. For example, the module +library to satisfy requests for a module. For example, the module `(foo bar)' could be implemented by placing a shared library named "foo/libbar.so" (or with a different extension) in a directory on the load path of Guile. @@ -373,14 +373,14 @@ objects are usually permanent. ** Escape procedures created by call-with-current-continuation now accept any number of arguments, as required by R5RS. -** New function `call-with-deprecation' +** New function `issue-deprecation-warning' -Call a thunk, displaying a deprecation message at the first call: +This function is used to displaying the deprecation messages that are +controlled by GUILE_WARN_DEPRECATION as explained in the README. (define (id x) - (call-with-deprecation "`id' is deprecated. Use `identity' instead." - (lambda () - (identity x)))) + (issue-deprecation-warning "`id' is deprecated. Use `identity' instead.") + (identity x)) guile> (id 1) ;; `id' is deprecated. Use `identity' instead. @@ -388,6 +388,13 @@ Call a thunk, displaying a deprecation message at the first call: guile> (id 1) 1 +** New syntax `begin-deprecated' + +When deprecated features are included (as determined by the configure +option --enable-deprecated), `begin-deprecated' is identical to +`begin'. When deprecated features are excluded, it always evaluates +to `#f', ignoring the body forms. + ** New function `make-object-property' This function returns a new `procedure with setter' P that can be used diff --git a/README b/README index 57cc6c7c3..84684b58f 100644 --- a/README +++ b/README @@ -118,7 +118,7 @@ It works like this: When `--enable-deprecated=LEVEL' has been specified (for LEVEL not "no"), LEVEL will be used as the default value of the environment variable GUILE_WARN_DEPRECATED. A value of "yes" is changed to - "summary", however. + "summary" and "shutup" is changed to "no", however. When GUILE_WARN_DEPRECATION has the value "no", nothing special will happen when a deprecated feature is used. @@ -134,7 +134,7 @@ It works like this: warning is emitted immediatly for the first use of a deprecated feature. -The default is `--enable-deprecation=yes'. +The default is `--enable-deprecated=yes'. About This Distribution ============================================== diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 8b65a5cf9..0783b47d0 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2001-05-05 Marius Vollmer + + * objects.c, objects.h (scm_valid_object_procedure_p): New. + (scm_set_object_procedure_x): Use it to check argument. Fix + docstring. + + * evalext.c (scm_definedp): Fix docstring. + 2001-05-05 Gary Houston * socket.c: use HAVE_IPV6 instead of AF_INET6 to enable IPv6 diff --git a/oop/ChangeLog b/oop/ChangeLog index d4d81e37e..6c4a8e6a9 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -1,3 +1,12 @@ +2001-05-05 Marius Vollmer + + * goops.scm (initialize-object-procedure): Use + `valid-object-procedure?' instead of explicit tag magic. + (object-procedure-tags): Removed. + + * goops/util.scm (top-level-env): Use `current-module' instead of + the deprecated *top-level-lookup-closure*. + 2001-04-28 Rob Browning * goops/save.scm (write-readably): rename list* to cons*. From 826e91f350088a9b30428f3eeb34a8c25c5c7cbd Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 6 May 2001 00:02:06 +0000 Subject: [PATCH 1009/2047] Read what you type, you bloody jerk. --- libguile/evalext.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/evalext.c b/libguile/evalext.c index 55996b76f..1cbac13f7 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -72,8 +72,8 @@ scm_m_generalized_set_x (SCM xorig, SCM env) SCM_DEFINE (scm_definedp, "defined?", 1, 1, 0, (SCM sym, SCM env), "Return @code{#t} if @var{sym} is defined in the lexical " - "environment@var{env}. When @var{env} is not specified, " - "look in the top-level environment as as defined by the " + "environment @var{env}. When @var{env} is not specified, " + "look in the top-level environment as defined by the " "current module.") #define FUNC_NAME s_scm_definedp { From 94bb46ab5707671ca4ccd4f126459e56f7256e0d Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 6 May 2001 00:39:01 +0000 Subject: [PATCH 1010/2047] (scm_regexp_exec): Expand docstring to briefly describe `regexp/notbol' and `regexp/noteol' execution flags. --- libguile/regex-posix.c | 34 ++++++++++++++++++++++++---------- 1 file changed, 24 insertions(+), 10 deletions(-) diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index 8174217a7..df7fe06a0 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -1,15 +1,15 @@ -/* Copyright (C) 1997, 1998, 1999, 2000 Free Software Foundation, Inc. - * +/* Copyright (C) 1997, 1998, 1999, 2000, 2001 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 * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, @@ -37,7 +37,7 @@ * * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. + * If you do not wish that, delete this exception notice. */ /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, @@ -133,7 +133,7 @@ scm_regexp_error_msg (int regerrno, regex_t *rx) return SCM_STRING_CHARS (errmsg); } -SCM_DEFINE (scm_regexp_p, "regexp?", 1, 0, 0, +SCM_DEFINE (scm_regexp_p, "regexp?", 1, 0, 0, (SCM obj), "Return @code{#t} if @var{obj} is a compiled regular expression,\n" "or @code{#f} otherwise.") @@ -143,7 +143,7 @@ SCM_DEFINE (scm_regexp_p, "regexp?", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_make_regexp, "make-regexp", 1, 0, 1, +SCM_DEFINE (scm_make_regexp, "make-regexp", 1, 0, 1, (SCM pat, SCM flags), "Compile the regular expression described by @var{pat}, and\n" "return the compiled regexp structure. If @var{pat} does not\n" @@ -204,7 +204,7 @@ SCM_DEFINE (scm_make_regexp, "make-regexp", 1, 0, 1, cflags |= SCM_INUM (SCM_CAR (flag)); flag = SCM_CDR (flag); } - + rx = SCM_MUST_MALLOC_TYPE (regex_t); status = regcomp (rx, SCM_STRING_CHARS (pat), /* Make sure they're not passing REG_NOSUB; @@ -223,13 +223,27 @@ SCM_DEFINE (scm_make_regexp, "make-regexp", 1, 0, 1, } #undef FUNC_NAME -SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, +SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, (SCM rx, SCM str, SCM start, SCM flags), "Match the compiled regular expression @var{rx} against\n" "@code{str}. If the optional integer @var{start} argument is\n" "provided, begin matching from that position in the string.\n" "Return a match structure describing the results of the match,\n" - "or @code{#f} if no match could be found.") + "or @code{#f} if no match could be found.\n" + "\n" + "The @var{flags} arguments change the matching behavior.\n" + "The following flags may be supplied:\n" + "\n" + "@table @code\n" + "@item regexp/notbol\n" + "Operator @samp{^} always fails (unless @code{regexp/newline}\n" + "is used). Use this when the beginning of the string should\n" + "not be considered the beginning of a line.\n" + "@item regexp/noteol\n" + "Operator @samp{$} always fails (unless @code{regexp/newline}\n" + "is used). Use this when the end of the string should not be\n" + "considered the end of a line.\n" + "@end table") #define FUNC_NAME s_scm_regexp_exec { int status, nmatches, offset; From 1c938eb810fe076e2daa6ebbf02dcc6d54536349 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 6 May 2001 00:56:15 +0000 Subject: [PATCH 1011/2047] *** empty log message *** --- libguile/ChangeLog | 57 +++++++++++++++++++++++++--------------------- 1 file changed, 31 insertions(+), 26 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 0783b47d0..31fd78cc1 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-05-05 Thien-Thi Nguyen + + * regex-posix.c (scm_regexp_exec): Expand docstring to briefly + describe `regexp/notbol' and `regexp/noteol' execution flags. + 2001-05-05 Marius Vollmer * objects.c, objects.h (scm_valid_object_procedure_p): New. @@ -49,7 +54,7 @@ * init.c: Include "deprecation.h". (scm_init_guile_1): Call scm_init_deprecation. - + 2001-05-01 Marius Vollmer * gh.h (gh_init_guile, gh_make_string, gh_string_length, @@ -151,7 +156,7 @@ * modules.h (scm_module_index_transformer, SCM_MODULE_TRANSFORMER, scm_current_module_transformer, scm_module_transformer): New. - + * gh_data.c: Removed FIXME comment about gh_lookup returning SCM_UNDEFINED. That's the right thing to do. @@ -161,7 +166,7 @@ scm_current_module_transformer instead of scm_system_transformer. * init.c (start_stack): Move initialization of scm_system_transformer to the deprecated section. - + 2001-04-22 Neil Jerram * throw.c (scm_throw): Correct docstring. @@ -184,7 +189,7 @@ inet-pton and inet-ntop. (scm_fill_sockaddr): use VALIDATE_INET6 and ipv6_num_to_net. (scm_addr_vector): use ipv6_net_to_num. - + 2001-04-21 Dirk Herrmann * eq.c (scm_equal_p), ramap.c (scm_init_ramap): Don't compute the @@ -258,7 +263,7 @@ * debug.c (scm_procedure_source), eval.c (scm_badformalsp, SCM_CEVAL, SCM_APPLY), goops.c (get_slot_value, set_slot_value), - procprop.c (scm_i_procedure_arity), sort.c (closureless): Use + procprop.c (scm_i_procedure_arity), sort.c (closureless): Use SCM_CLOSURE_FORMALS. * eval.c (scm_badformalsp, SCM_CEVAL), procprop.c @@ -309,7 +314,7 @@ 2001-04-17 Gary Houston * some initial support for IPv6: - + * socket.c (scm_fill_sockaddr): improve the argument validation. don't allocate memory until all args are checked. instead of unconditional memset of soka, try setting sin_len to 0 if @@ -371,9 +376,9 @@ * debug-malloc.c (grow, scm_debug_malloc_prehistory): Use memset instead of bzero. - + * coop.c, iselect.c (FD_ZERO_N): Unconditionally use memset. - (MISSING_BZERO_DECL): Remove the declaration. + (MISSING_BZERO_DECL): Remove the declaration. Thanks to NIIBE Yutaka. @@ -422,7 +427,7 @@ 2001-04-03 Martin Grabmueller The following changes make the documentation more consistent. - + * rdelim.c (scm_write_line), posix.c (scm_utime), ports.c (scm_seek), net_db.c (scm_inet_aton, scm_inet_ntoa), (scm_inet_netof, scm_lnaof, scm_inet_makeaddr), ioext.c @@ -465,7 +470,7 @@ (scm_dynamic_unlink, scm_dynamic_call, scm_dynamic_args_call): Made parameter names match documentation by renaming parameters and/or fixing docstrings. - + * numbers.c (scm_ash): Corrected Texinfo markup. * strop.c (scm_string_index, scm_string_rindex), @@ -510,8 +515,8 @@ (scm_stat, scm_directory_stream_p, scm_getcwd, scm_readlink): Docstring correction: `Returns' -> `Return' - * gc.c (scm_set_debug_cell_accesses_x): - (s_scm_gc_set_debug_check_freelist_x): + * gc.c (scm_set_debug_cell_accesses_x): + (s_scm_gc_set_debug_check_freelist_x): * fluids.c (scm_fluid_p): Added texinfo markup. * error.c (scm_strerror): Made docstring more precise. @@ -707,7 +712,7 @@ * values.c (values_vtable, scm_values_vtable): Added "scm_" prefix so that it can be exported. (scm_call_with_values): Removed. - + * tags.h (SCM_IM_CALL_WITH_VALUES): New isym. * eval.c: Include "libguile/values.h" (scm_m_at_call_with_values, scm_sym_at_call_with_values): @@ -718,7 +723,7 @@ * eval.c (scm_primitive_eval_x, scm_primitive_eval): Fix syntax errors with last change. - + 2001-03-25 Marius Vollmer * eval.c (scm_primitive_eval_x, scm_primitive_eval, scm_i_eval_x, @@ -856,7 +861,7 @@ (scm_num2ulong_long): New. (ULONG_LONG_MAX): Define if not already defined. * numbers.h: (scm_num2ulong_long): New prototype. - + 2001-03-15 Martin Grabmueller * validate.h (SCM_VALIDATE_OPOUTSTRPORT): New macro. @@ -865,7 +870,7 @@ (SCM_OPOUTSTRPORTP): New predicate macros. (scm_open_input_string, scm_open_output_string), (scm_get_output_string): New prototypes. - + * strports.c (scm_open_input_string, scm_open_output_string), (scm_get_output_string): New procedures (SRFI-6 compliant). Made scm_tc16_strport non-static. @@ -959,7 +964,7 @@ posix.c, print.c, putenv.c, scmsigs.c, script.c, simpos.c, smob.c, socket.c, srcprop.c, stime.c, strop.c, unif.c, vports.c: Added #include in these 20 out of 100 files. - + 2001-03-10 Gary Houston * socket.c: add a definition of SUN_LEN (from glibc) for when it's @@ -989,7 +994,7 @@ regex-posix.c, root.c, scmsigs.c, simpos.c, socket.c, srcprop.c, stackchk.c, stacks.c, strings.c, strop.c, strorder.c, struct.c, symbols.c, tag.c, threads.c, variable.c, vectors.c, weaks.c: - Remove #include + Remove #include * gc.c, gdbint.c, root.c, sort.c, unif.c: Add #include . * procs.c (scm_make_subr_opt): Init symcell to avoid warning. @@ -1037,7 +1042,7 @@ function. * coop-threads.c: Fixed change of 2001-03-06. - + * validate.h: Code formatting. 2001-03-07 Keisuke Nishida @@ -1083,7 +1088,7 @@ * socket.c (scm_fill_sockaddr): don't allow buffer overflows when taking an unexpectedly large filename for an AF_UNIX socket from bind/connect/sendto (thanks to Martin Grabmueller). - + * socket.c (scm_sock_fd_to_port, SCM_SOCK_FD_TO_PORT): removed the former and adjusted the latter. (scm_socket, scm_socketpair): cosmetic changes. @@ -1257,7 +1262,7 @@ module around the call to DEFVAR, scm_eval takes care of that. (scm_init_goops): Make scm_module_goops and scm_goops_lookup_closure permanent objects. - + * eval.c (scm_ceval, scm_deval): When evaluating expressions on top level, create a fresh top-level environment for each expression instead of mutating the exisint frame. This is @@ -1337,7 +1342,7 @@ scm_random_hollow_sphere_x, scm_random_normal_vector_x, scm_random_exp), dynwind.c (scm_dynamic_wind): Removed unnecessary "" from docstrings. - + * goops.c (scm_sys_initialize_object, scm_instance_p, scm_class_name, scm_class_precedence_list, scm_class_slots, scm_class_environment, scm_generic_function_name, @@ -1420,7 +1425,7 @@ Fix evaluator so that top-level expressions are correctly evaluated with respect to the module system. - + * modules.h. modules.c (scm_current_module_lookup_closure): New function. @@ -1435,7 +1440,7 @@ (scm_primitve_eval_x, scm_primitive_eval): New functions. (scm_eval_x, scm_eval): Reimplement in terms of scm_primitive_eval_x and scm_primitive_eval, respectively. - + 2001-02-09 Marius Vollmer * macros.c (scm_macro_name, scm_macro_transformer): Use @@ -1463,7 +1468,7 @@ and C names. (scm_select_module, scm_set_current_module): Likewise. Changed all uses. - + * ports.c (scm_port_for_each): Make a snapshot of the port table before iterating over it. The table might change while the user code is running. With the snapshot, the user can depend on the @@ -1795,7 +1800,7 @@ 2001-01-11 Michael Livshin from Matthias Köppe: - + * objects.h (SCM_SET_ENTITY_SETTER): new macro. SCM_ENTITY_SETTER casts its result, so doesn't yield an lvalue per ANSI C. From 5ad8ab0a97c69072d57ec562b18eddbc54e97b0f Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 6 May 2001 01:12:50 +0000 Subject: [PATCH 1012/2047] (scm_substring_move_x): Doc fix; nfc. --- libguile/strop.c | 50 ++++++++++++++++++++++++------------------------ 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/libguile/strop.c b/libguile/strop.c index 037b2bd60..2cf4c0221 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -40,7 +40,7 @@ Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA /* -xSCM_DEFINE (scm_i_index, "i-index", 2, 2, 0, +xSCM_DEFINE (scm_i_index, "i-index", 2, 2, 0, (SCM str, SCM chr, SCM frm, SCM to), "@deftypefn {Internal C Function} {static int} scm_i_index (SCM *@var{str}, \n" "SCM @var{chr}, int @var{direction}, SCM @var{sub_start}, SCM @var{sub_end}, char *@var{why}) @@ -49,7 +49,7 @@ xSCM_DEFINE (scm_i_index, "i-index", 2, 2, 0, */ /* implements index if direction > 0 otherwise rindex. */ static int -scm_i_index (SCM *str, SCM chr, int direction, SCM sub_start, +scm_i_index (SCM *str, SCM chr, int direction, SCM sub_start, SCM sub_end, const char *why) { unsigned char * p; @@ -98,7 +98,7 @@ scm_i_index (SCM *str, SCM chr, int direction, SCM sub_start, return -1; } -SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0, +SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0, (SCM str, SCM chr, SCM frm, SCM to), "Return the index of the first occurrence of @var{chr} in\n" "@var{str}. The optional integer arguments @var{frm} and\n" @@ -117,7 +117,7 @@ SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0, #define FUNC_NAME s_scm_string_index { int pos; - + if (SCM_UNBNDP (frm)) frm = SCM_BOOL_F; if (SCM_UNBNDP (to)) @@ -129,7 +129,7 @@ SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_string_rindex, "string-rindex", 2, 2, 0, +SCM_DEFINE (scm_string_rindex, "string-rindex", 2, 2, 0, (SCM str, SCM chr, SCM frm, SCM to), "Like @code{string-index}, but search from the right of the\n" "string rather than from the left. This procedure essentially\n" @@ -147,7 +147,7 @@ SCM_DEFINE (scm_string_rindex, "string-rindex", 2, 2, 0, #define FUNC_NAME s_scm_string_rindex { int pos; - + if (SCM_UNBNDP (frm)) frm = SCM_BOOL_F; if (SCM_UNBNDP (to)) @@ -215,14 +215,14 @@ y y @result{} "abccdeg" @end lisp -*/ +*/ -SCM_DEFINE (scm_substring_move_x, "substring-move!", 5, 0, 0, +SCM_DEFINE (scm_substring_move_x, "substring-move!", 5, 0, 0, (SCM str1, SCM start1, SCM end1, SCM str2, SCM start2), "@deffnx primitive substring-move-left! str1 start1 end1 str2 start2\n" "@deffnx primitive substring-move-right! str1 start1 end1 str2 start2\n" "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}\n" - "into @var{str2} beginning at position @var{end2}.\n" + "into @var{str2} beginning at position @var{start2}.\n" "@code{substring-move-right!} begins copying from the rightmost character\n" "and moves left, and @code{substring-move-left!} copies from the leftmost\n" "character moving right.\n\n" @@ -255,13 +255,13 @@ SCM_DEFINE (scm_substring_move_x, "substring-move!", 5, 0, 0, SCM_SYSCALL(memmove((void *)(&(SCM_STRING_CHARS(str2)[s2])), (void *)(&(SCM_STRING_CHARS(str1)[s1])), len)); - + return scm_return_first(SCM_UNSPECIFIED, str1, str2); } #undef FUNC_NAME -SCM_DEFINE (scm_substring_fill_x, "substring-fill!", 4, 0, 0, +SCM_DEFINE (scm_substring_fill_x, "substring-fill!", 4, 0, 0, (SCM str, SCM start, SCM end, SCM fill), "Change every character in @var{str} between @var{start} and\n" "@var{end} to @var{fill}.\n" @@ -288,7 +288,7 @@ SCM_DEFINE (scm_substring_fill_x, "substring-fill!", 4, 0, 0, #undef FUNC_NAME -SCM_DEFINE (scm_string_null_p, "string-null?", 1, 0, 0, +SCM_DEFINE (scm_string_null_p, "string-null?", 1, 0, 0, (SCM str), "Return @code{#t} if @var{str}'s length is nonzero, and\n" "@code{#f} otherwise.\n" @@ -305,7 +305,7 @@ SCM_DEFINE (scm_string_null_p, "string-null?", 1, 0, 0, #undef FUNC_NAME -SCM_DEFINE (scm_string_to_list, "string->list", 1, 0, 0, +SCM_DEFINE (scm_string_to_list, "string->list", 1, 0, 0, (SCM str), "Return a newly allocated list of the characters that make up\n" "the given string @var{str}. @code{string->list} and\n" @@ -333,7 +333,7 @@ string_copy (SCM str) } -SCM_DEFINE (scm_string_copy, "string-copy", 1, 0, 0, +SCM_DEFINE (scm_string_copy, "string-copy", 1, 0, 0, (SCM str), "Return a newly allocated copy of the given @var{string}.") #define FUNC_NAME s_scm_string_copy @@ -361,7 +361,7 @@ SCM_DEFINE (scm_string_fill_x, "string-fill!", 2, 0, 0, #undef FUNC_NAME -/* Helper function for the string uppercase conversion functions. +/* Helper function for the string uppercase conversion functions. * No argument checking is performed. */ static SCM string_upcase_x (SCM v) @@ -375,7 +375,7 @@ string_upcase_x (SCM v) } -SCM_DEFINE (scm_string_upcase_x, "string-upcase!", 1, 0, 0, +SCM_DEFINE (scm_string_upcase_x, "string-upcase!", 1, 0, 0, (SCM str), "Destructively upcase every character in @var{str} and return\n" "@var{str}.\n" @@ -393,7 +393,7 @@ SCM_DEFINE (scm_string_upcase_x, "string-upcase!", 1, 0, 0, #undef FUNC_NAME -SCM_DEFINE (scm_string_upcase, "string-upcase", 1, 0, 0, +SCM_DEFINE (scm_string_upcase, "string-upcase", 1, 0, 0, (SCM str), "Return a freshly allocated string containing the characters of\n" "@var{str} in upper case.") @@ -406,7 +406,7 @@ SCM_DEFINE (scm_string_upcase, "string-upcase", 1, 0, 0, #undef FUNC_NAME -/* Helper function for the string lowercase conversion functions. +/* Helper function for the string lowercase conversion functions. * No argument checking is performed. */ static SCM string_downcase_x (SCM v) @@ -420,7 +420,7 @@ string_downcase_x (SCM v) } -SCM_DEFINE (scm_string_downcase_x, "string-downcase!", 1, 0, 0, +SCM_DEFINE (scm_string_downcase_x, "string-downcase!", 1, 0, 0, (SCM str), "Destructively downcase every character in @var{str} and return\n" "@var{str}.\n" @@ -438,7 +438,7 @@ SCM_DEFINE (scm_string_downcase_x, "string-downcase!", 1, 0, 0, #undef FUNC_NAME -SCM_DEFINE (scm_string_downcase, "string-downcase", 1, 0, 0, +SCM_DEFINE (scm_string_downcase, "string-downcase", 1, 0, 0, (SCM str), "Return a freshly allocation string containing the characters in\n" "@var{str} in lower case.") @@ -451,7 +451,7 @@ SCM_DEFINE (scm_string_downcase, "string-downcase", 1, 0, 0, #undef FUNC_NAME -/* Helper function for the string capitalization functions. +/* Helper function for the string capitalization functions. * No argument checking is performed. */ static SCM string_capitalize_x (SCM str) @@ -476,7 +476,7 @@ string_capitalize_x (SCM str) } -SCM_DEFINE (scm_string_capitalize_x, "string-capitalize!", 1, 0, 0, +SCM_DEFINE (scm_string_capitalize_x, "string-capitalize!", 1, 0, 0, (SCM str), "Upcase the first character of every word in @var{str}\n" "destructively and return @var{str}.\n" @@ -495,7 +495,7 @@ SCM_DEFINE (scm_string_capitalize_x, "string-capitalize!", 1, 0, 0, #undef FUNC_NAME -SCM_DEFINE (scm_string_capitalize, "string-capitalize", 1, 0, 0, +SCM_DEFINE (scm_string_capitalize, "string-capitalize", 1, 0, 0, (SCM str), "Return a freshly allocated string with the characters in\n" "@var{str}, where the first character of every word is\n" @@ -509,7 +509,7 @@ SCM_DEFINE (scm_string_capitalize, "string-capitalize", 1, 0, 0, #undef FUNC_NAME -SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0, +SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0, (SCM str, SCM chr), "Split the string @var{str} into the a list of the substrings delimited\n" "by appearances of the character @var{chr}. Note that an empty substring\n" @@ -558,7 +558,7 @@ SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0, #undef FUNC_NAME -SCM_DEFINE (scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0, +SCM_DEFINE (scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0, (SCM str), "Return the symbol whose name is @var{str}. @var{str} is\n" "converted to lowercase before the conversion is done, if Guile\n" From 3a6379f7f74282380147014434f6c03f5a8f2c0e Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 6 May 2001 01:14:26 +0000 Subject: [PATCH 1013/2047] *** empty log message *** --- libguile/ChangeLog | 2 ++ 1 file changed, 2 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 31fd78cc1..91fb6520f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -3,6 +3,8 @@ * regex-posix.c (scm_regexp_exec): Expand docstring to briefly describe `regexp/notbol' and `regexp/noteol' execution flags. + * strop.c (scm_substring_move_x): Doc fix; nfc. + 2001-05-05 Marius Vollmer * objects.c, objects.h (scm_valid_object_procedure_p): New. From e68fc82964e6f5dc81955818eff6f98bd0b9e417 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 6 May 2001 01:25:15 +0000 Subject: [PATCH 1014/2047] (SCM_WTA_DISPATCH_0): Removed ARG and POS parameters, they are not used. Changed `wrong type' error into `wrong num args' error. Changed all callers. --- libguile/__scm.h | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/libguile/__scm.h b/libguile/__scm.h index 928c44918..8fe7c3b56 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -514,12 +514,12 @@ do { \ extern SCM scm_call_generic_0 (SCM gf); -#define SCM_WTA_DISPATCH_0(gf, arg, pos, subr) \ +#define SCM_WTA_DISPATCH_0(gf, subr) \ return (SCM_UNPACK (gf) \ ? scm_call_generic_0 ((gf)) \ - : (scm_wrong_type_arg ((subr), (pos), (arg)), SCM_UNSPECIFIED)) -#define SCM_GASSERT0(cond, gf, arg, pos, subr) \ - if (!(cond)) SCM_WTA_DISPATCH_0((gf), (arg), (pos), (subr)) + : (scm_error_num_args_subr ((subr)), SCM_UNSPECIFIED)) +#define SCM_GASSERT0(cond, gf, subr) \ + if (!(cond)) SCM_WTA_DISPATCH_0((gf), (subr)) extern SCM scm_call_generic_1 (SCM gf, SCM a1); From c05e97b7493c69be70a6ab6da576e44664c28493 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 6 May 2001 01:26:23 +0000 Subject: [PATCH 1015/2047] (scm_difference): Call SCM_WTA_DISPATCH_0 when zero arguments are supplied. --- libguile/numbers.c | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index a521ad35c..ce7252a07 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -3261,7 +3261,7 @@ scm_max (SCM x, SCM y) { if (SCM_UNBNDP (y)) { if (SCM_UNBNDP (x)) { - SCM_WTA_DISPATCH_0 (g_max, x, SCM_ARG1, s_max); + SCM_WTA_DISPATCH_0 (g_max, s_max); } else if (SCM_NUMBERP (x)) { return x; } else { @@ -3319,7 +3319,7 @@ scm_min (SCM x, SCM y) { if (SCM_UNBNDP (y)) { if (SCM_UNBNDP (x)) { - SCM_WTA_DISPATCH_0 (g_min, x, SCM_ARG1, s_min); + SCM_WTA_DISPATCH_0 (g_min, s_min); } else if (SCM_NUMBERP (x)) { return x; } else { @@ -3481,11 +3481,14 @@ SCM_GPROC1 (s_difference, "-", scm_tc7_asubr, scm_difference, g_difference); * "all but the first argument are subtracted from the first\n" * "argument." */ +#define FUNC_NAME s_difference SCM scm_difference (SCM x, SCM y) { if (SCM_UNBNDP (y)) { - if (SCM_INUMP (x)) { + if (SCM_UNBNDP (x)) { + SCM_WTA_DISPATCH_0 (g_difference, s_difference); + } else if (SCM_INUMP (x)) { long xx = -SCM_INUM (x); if (SCM_FIXABLE (xx)) { return SCM_MAKINUM (xx); @@ -3603,7 +3606,7 @@ scm_difference (SCM x, SCM y) SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARG1, s_difference); } } - +#undef FUNC_NAME SCM_GPROC1 (s_product, "*", scm_tc7_asubr, scm_product, g_product); /* "Return the product of all arguments. If called without arguments,\n" @@ -3757,6 +3760,7 @@ scm_num2dbl (SCM a, const char *why) SCM_GPROC1 (s_divide, "/", scm_tc7_asubr, scm_divide, g_divide); /* "Divide the first argument by the product of the remaining arguments." */ +#define FUNC_NAME s_divide SCM scm_divide (SCM x, SCM y) { @@ -3764,7 +3768,7 @@ scm_divide (SCM x, SCM y) if (SCM_UNBNDP (y)) { if (SCM_UNBNDP (x)) { - SCM_WTA_DISPATCH_0 (g_divide, x, SCM_ARG1, s_divide); + SCM_WTA_DISPATCH_0 (g_divide, s_divide); } else if (SCM_INUMP (x)) { if (SCM_EQ_P (x, SCM_MAKINUM (1L)) || SCM_EQ_P (x, SCM_MAKINUM (-1L))) { return x; @@ -3909,7 +3913,7 @@ scm_divide (SCM x, SCM y) SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide); } } - +#undef FUNC_NAME SCM_GPROC1 (s_asinh, "$asinh", scm_tc7_cxr, (SCM (*)()) scm_asinh, g_asinh); /* "Return the inverse hyperbolic sine of @var{x}." From 26c1d5495bf9ddf02e769270a373bae97f2235c8 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 6 May 2001 01:26:41 +0000 Subject: [PATCH 1016/2047] *** empty log message *** --- libguile/ChangeLog | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 91fb6520f..939d76ce5 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2001-05-06 Marius Vollmer + + * __scm.h (SCM_WTA_DISPATCH_0): Removed ARG and POS parameters, + they are not used. Changed `wrong type' error into `wrong num + args' error. Changed all callers. + + * numbers.c (scm_difference): Call SCM_WTA_DISPATCH_0 when zero + arguments are supplied. + 2001-05-05 Thien-Thi Nguyen * regex-posix.c (scm_regexp_exec): Expand docstring to briefly From 5134bfa7515fa54ffce4df1abedf72bc82bac157 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 6 May 2001 01:49:56 +0000 Subject: [PATCH 1017/2047] (Using Guile Modules): Review; remove reviewme comment. Expand `GUILE_LOAD_PATH' blurb; add small example. (Reporting Bugs): Review; remove reviewme comment. Reword some phrases; add texi markup. Add suggestion to include `guile-config info' output. Update gdb invocation; add fixme question. --- doc/intro.texi | 71 +++++++++++++++++++++++++------------------------- 1 file changed, 35 insertions(+), 36 deletions(-) diff --git a/doc/intro.texi b/doc/intro.texi index 909c3bd52..7077201cf 100644 --- a/doc/intro.texi +++ b/doc/intro.texi @@ -1,4 +1,4 @@ -@c $Id: intro.texi,v 1.6 2001-04-20 07:31:25 mgrabmue Exp $ +@c $Id: intro.texi,v 1.7 2001-05-06 01:49:56 ttn Exp $ @page @node What is Guile? @@ -59,11 +59,11 @@ This chapter presents a quick tour of all the ways that Guile can be used. @menu -* Running Guile Interactively:: -* Guile Scripts:: -* Linking Programs With Guile:: -* Writing Extensions for Guile:: -* Guile Modules:: +* Running Guile Interactively:: +* Guile Scripts:: +* Linking Programs With Guile:: +* Writing Extensions for Guile:: +* Guile Modules:: @end menu @@ -186,7 +186,7 @@ $ ./foo ("./foo") $ ./foo bar baz ("./foo" "bar" "baz") -$ +$ @end example As another example, here is a simple replacement for the POSIX @@ -580,7 +580,7 @@ guile> (getpwnam "jimb") #("jimb" "83Z7d75W2tyJQ" 4008 10 "Jim Blandy" "/u/jimb" "/usr/local/bin/bash") guile> (exit) -$ +$ @end example @node Writing Extensions for Guile @@ -622,7 +622,7 @@ standalone program. The shared library can then be loaded dynamically by Guile. @menu -* A Sample Guile Extension:: +* A Sample Guile Extension:: @end menu @node A Sample Guile Extension @@ -700,26 +700,28 @@ the future. Feel free to use the existing system anyway. Guile will provide reasonable backwards compatability.) @menu -* Using Guile Modules:: -* Writing New Modules:: -* Modules and Extensions:: +* Using Guile Modules:: +* Writing New Modules:: +* Modules and Extensions:: @end menu @node Using Guile Modules @subsection Using Existing Modules -@c FIXME::martin: Review me! - -@c FIXME::martin: More? Or leave the rest to the module chapter? - Guile comes with a lot of useful modules, for example for string processing or command line parsing. Additionally, there exist many Guile modules written by other Guile hackers, but which have to be installed manually. Existing modules have to be placed in places where Guile looks for them -by default or in directories in the environment variable -@code{GUILE_LOAD_PATH}. +by default or in colon-separated directories in the environment variable +@code{GUILE_LOAD_PATH}. When this variable is set, those directories +are searched first, then the the default. The following command +shows the complete list of directories searched: + +@smallexample +guile -c '(for-each write-line %load-path)' +@end smallexample Suppose you want to use the procedures and variables exported by the module @code{(ice-9 popen)}, which provides the means for communicating @@ -831,18 +833,13 @@ for example as @file{/usr/local/share/guile/math/bessel.scm}. @node Reporting Bugs @chapter Reporting Bugs -@c FIXME::martin: Review me! - -@c FIXME::martin: A lot of this was taken from the Emacs reference -@c manual and adapted. I guess that is okay? - Any problems with the installation should be reported to @email{bug-guile@@gnu.org}. Whenever you have found a bug in Guile you are encouraged to report it -to the Guile developers, so they can fix it. They may probably have -also advice what to do to work around a bug when it is not possible for -you to apply the bugfix or install a new version of Guile yourself. +to the Guile developers, so they can fix it. They may also be able to +suggest workarounds when it is not possible for you to apply the bugfix +or install a new version of Guile yourself. Before sending in bug reports, please check with the following list that you really have found a bug. @@ -865,7 +862,6 @@ When calculations produce wrong results, it is a bug. When Guile signals an error for valid Scheme programs, it is a bug. @item -@c FIXME::martin: Too strict? When Guile does not signal an error for invalid Scheme programs, it may be a bug, unless this is explicitly documented. @@ -877,7 +873,7 @@ to you even after re--reading the section, it is a bug. When you write a bug report, please make sure to include as much of the information described below in the report. If you can't figure out some of the items, it is not a problem, but the more information we get, the -better are chances we can diagnose and fix the bug. +more likely we can diagnose and fix the bug. @itemize @bullet @item @@ -907,7 +903,8 @@ Linux tortoise 2.2.17 #1 Thu Dec 21 17:29:05 CET 2000 i586 unknown @item The operands given to the @file{configure} command when Guile was -installed. +installed. It's often useful to augment this with the output of the +command @code{guile-config info}. @item A complete list of any modifications you have made to the Guile source. @@ -953,12 +950,13 @@ This can be done using the procedure @code{backtrace} in the REPL. @item Check whether any programs you have loaded into Guile, including your -`.guile' file, set any variables that may affect the functioning of +@file{.guile} file, set any variables that may affect the functioning of Guile. Also, see whether the problem happens in a freshly started Guile -without loading your `.guile file (start Guile with the `-q' switch to -prevent loading the init file). If the problem does _not_ occur then, -you must report the precise contents of any programs that you must load -into Guile in order to cause the problem to occur. +without loading your @file{.guile} file (start Guile with the @code{-q} +switch to prevent loading the init file). If the problem does +@emph{not} occur then, you must report the precise contents of any +programs that you must load into Guile in order to cause the problem to +occur. @item If the problem does depend on an init file or other Lisp programs that @@ -983,8 +981,9 @@ If you don't know how to use GDB, please read the GDB manual--it is not very long, and using GDB is easy. You can find the GDB distribution, including the GDB manual in online form, in most of the same places you can find the Guile distribution. To run Guile under GDB, you should -switch to the `libguile' subdirectory in which Guile was compiled, then -do `gdb guile'. +switch to the @file{libguile} subdirectory in which Guile was compiled, then +do @code{gdb .libs/guile}. +@c fixme: libguile/.libs is for libtool-enabled systems -- what about rest? However, you need to think when you collect the additional information if you want it to show what causes the bug. From 677cd590ad3d0614322a8e7c100253b6503a5179 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sun, 6 May 2001 03:29:52 +0000 Subject: [PATCH 1018/2047] * psyntax.ss: make sure emacs knows it's scheme code. --- ice-9/ChangeLog | 4 ++++ ice-9/psyntax.ss | 2 ++ 2 files changed, 6 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index e53f38fa1..bd433e3d3 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2001-05-05 Rob Browning + + * psyntax.ss: make sure emacs knows it's scheme code. + 2001-05-05 Neil Jerram * boot-9.scm (use-syntax): Change error message to say diff --git a/ice-9/psyntax.ss b/ice-9/psyntax.ss index 608f99f5a..166095e11 100644 --- a/ice-9/psyntax.ss +++ b/ice-9/psyntax.ss @@ -1,3 +1,5 @@ +;;;; -*-scheme-*- +;;;; ;;;; Copyright (C) 2001 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify From 5bbfe8cbf1583fb0527baee06b27551acd7e3c4a Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sun, 6 May 2001 03:31:19 +0000 Subject: [PATCH 1019/2047] * srfi-19.scm: New file - time/date SRFI. Thanks to Will Fitzgerald. --- srfi/srfi-19.scm | 1485 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1485 insertions(+) create mode 100644 srfi/srfi-19.scm diff --git a/srfi/srfi-19.scm b/srfi/srfi-19.scm new file mode 100644 index 000000000..1ac2f0f43 --- /dev/null +++ b/srfi/srfi-19.scm @@ -0,0 +1,1485 @@ +;;; srfi-19.scm --- SRFI-19 procedures for Guile +;;; +;;; Copyright (C) 2001 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;; Boston, MA 02111-1307 USA +;;; +;;; Originally from SRFI reference implementation by Will Fitzgerald. +;;; Ported to Guile by Rob Browning + +;; FIXME: I haven't checked a decent amount of this code for potential +;; performance improvements, but I suspect that there may be some +;; substantial ones to be realized, esp. in the later "parsing" half +;; of the file, by rewriting the code with use of more Guile native +;; functions that do more work in a "chunk". + +(define-module (srfi srfi-19) + :use-module (ice-9 syncase) + :use-module (srfi srfi-6) + :use-module (srfi srfi-8) + :use-module (srfi srfi-9) + :export (;; Constants + time-duration + time-monotonic + time-process + time-tai + time-thread + time-utc + ;; Current time and clock resolution + current-date + current-julian-day + current-modified-julian-day + current-time + time-resolution + ;; Time object and accessors + make-time + time? + time-type + time-nanosecond + time-second + set-time-type! + set-time-nanosecond! + set-time-second! + copy-time + ;; Time comparison procedures + time<=? + time=? + time>? + ;; Time arithmetic procedures + time-difference + time-difference! + add-duration + add-duration! + subtract-duration + subtract-duration! + ;; Date object and accessors + make-date + date? + date-nanosecond + date-second + date-minute + date-hour + date-day + date-month + date-year + date-zone-offset? + date-year-day + date-week-day + date-week-number + ;; Time/Date/Julian Day/Modified Julian Day converters + date->julian-day + date->modified-julian-day + date->time-monotonic + date->time-tai + date->time-utc + julian-day->date + julian-day->time-monotonic + julian-day->time-tai + julian-day->time-utc + modified-julian-day->date + modified-julian-day->time-monotonic + modified-julian-day->time-tai + modified-julian-day->time-utc + time-monotonic->date + time-monotonic->time-monotonic + time-monotonic->time-tai + time-monotonic->time-tai! + time-monotonic->time-utc + time-monotonic->time-utc! + time-tai->date + time-tai->julian-day + time-tai->modified-julian-day + time-tai->time-monotonic + time-tai->time-monotonic! + time-tai->time-utc + time-tai->time-utc! + time-utc->date + time-utc->julian-day + time-utc->modified-julian-day + time-utc->time-monotonic + time-utc->time-monotonic! + time-utc->time-tai + time-utc->time-tai! + ;; Date to string/string to date converters. + date->string + string->date)) + +;; :OPTIONAL is nice + +(define-syntax :optional + (syntax-rules () + ((_ val default-value) + (if (null? val) default-value (car val))))) + +(define time-tai 'time-tai) +(define time-utc 'time-utc) +(define time-monotonic 'time-monotonic) +(define time-thread 'time-thread) +(define time-process 'time-process) +(define time-duration 'time-duration) + +;; FIXME: do we want to add gc time? +;; (define time-gc 'time-gc) + +;;-- LOCALE dependent constants + +(define priv:locale-number-separator ".") + +(define priv:locale-abbr-weekday-vector + (vector "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat")) + +(define priv:locale-long-weekday-vector + (vector + "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday")) + +;; note empty string in 0th place. +(define priv:locale-abbr-month-vector + (vector "" + "Jan" + "Feb" + "Mar" + "Apr" + "May" + "Jun" + "Jul" + "Aug" + "Sep" + "Oct" + "Nov" + "Dec")) + +(define priv:locale-long-month-vector + (vector "" + "January" + "February" + "March" + "April" + "May" + "June" + "July" + "August" + "September" + "October" + "November" + "December")) + +(define priv:locale-pm "PM") +(define priv:locale-am "AM") + +;; See date->string +(define priv:locale-date-time-format "~a ~b ~d ~H:~M:~S~z ~Y") +(define priv:locale-short-date-format "~m/~d/~y") +(define priv:locale-time-format "~H:~M:~S") +(define priv:iso-8601-date-time-format "~Y-~m-~dT~H:~M:~S~z") + +;;-- Miscellaneous Constants. +;;-- only the priv:tai-epoch-in-jd might need changing if +;; a different epoch is used. + +(define priv:nano 1000000000) ; nanoseconds in a second +(define priv:sid 86400) ; seconds in a day +(define priv:sihd 43200) ; seconds in a half day +(define priv:tai-epoch-in-jd 4881175/2) ; julian day number for 'the epoch' + +;; FIXME: should this be something other than misc-error? +(define (priv:time-error caller type value) + (if value + (throw 'misc-error caller "TIME-ERROR type ~A: ~S" (list type value) #f) + (throw 'misc-error caller "TIME-ERROR type ~A" (list type) #f))) + +;; A table of leap seconds +;; See ftp://maia.usno.navy.mil/ser7/tai-utc.dat +;; and update as necessary. +;; this procedures reads the file in the abover +;; format and creates the leap second table +;; it also calls the almost standard, but not R5 procedures read-line +;; & open-input-string +;; ie (set! priv:leap-second-table (priv:read-tai-utc-date "tai-utc.dat")) + +(define (priv:read-tai-utc-data filename) + (define (convert-jd jd) + (* (- (inexact->exact jd) priv:tai-epoch-in-jd) priv:sid)) + (define (convert-sec sec) + (inexact->exact sec)) + (let ((port (open-input-file filename)) + (table '())) + (let loop ((line (read-line port))) + (if (not (eq? line eof)) + (begin + (let* ((data (read (open-input-string + (string-append "(" line ")")))) + (year (car data)) + (jd (cadddr (cdr data))) + (secs (cadddr (cdddr data)))) + (if (>= year 1972) + (set! table (cons + (cons (convert-jd jd) (convert-sec secs)) + table))) + (loop (read-line port)))))) + table)) + +;; each entry is (tai seconds since epoch . # seconds to subtract for utc) +;; note they go higher to lower, and end in 1972. +(define priv:leap-second-table + '((915148800 . 32) + (867715200 . 31) + (820454400 . 30) + (773020800 . 29) + (741484800 . 28) + (709948800 . 27) + (662688000 . 26) + (631152000 . 25) + (567993600 . 24) + (489024000 . 23) + (425865600 . 22) + (394329600 . 21) + (362793600 . 20) + (315532800 . 19) + (283996800 . 18) + (252460800 . 17) + (220924800 . 16) + (189302400 . 15) + (157766400 . 14) + (126230400 . 13) + (94694400 . 12) + (78796800 . 11) + (63072000 . 10))) + +(define (read-leap-second-table filename) + (set! priv:leap-second-table (priv:read-tai-utc-data filename)) + (values)) + + +(define (priv:leap-second-delta utc-seconds) + (letrec ((lsd (lambda (table) + (cond ((>= utc-seconds (caar table)) + (cdar table)) + (else (lsd (cdr table))))))) + (if (< utc-seconds (* (- 1972 1970) 365 priv:sid)) 0 + (lsd priv:leap-second-table)))) + + +;;; the TIME structure; creates the accessors, too. + +(define-record-type time + (make-time-unnormalized type nanosecond second) + time? + (type time-type set-time-type!) + (nanosecond time-nanosecond set-time-nanosecond!) + (second time-second set-time-second!)) + +(define (copy-time time) + (make-time (time-type time) (time-nanosecond time) (time-second time))) + +(define (priv:time-normalize! t) + (if (>= (abs (time-nanosecond t)) 1000000000) + (begin + (set-time-second! t (+ (time-second t) + (quotient (time-nanosecond t) 1000000000))) + (set-time-nanosecond! t (remainder (time-nanosecond t) + 1000000000)))) + (if (and (positive? (time-second t)) + (negative? (time-nanosecond t))) + (begin + (set-time-second! t (- (time-second t) 1)) + (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t)))) + (if (and (negative? (time-second t)) + (positive? (time-nanosecond t))) + (begin + (set-time-second! t (+ (time-second t) 1)) + (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t)))))) + t) + +(define (make-time type nanosecond second) + (priv:time-normalize! (make-time-unnormalized type nanosecond second))) + +;; Helpers +;; FIXME: finish this and publish it? +(define (date->broken-down-time date) + (let ((result (mktime 0))) + ;; FIXME: What should we do about leap-seconds which may overflow + ;; set-tm:sec? + (set-tm:sec result (date-second date)) + (set-tm:min result (date-minute date)) + (set-tm:hour result (date-hour date)) + ;; FIXME: SRFI day ranges from 0-31. (not compatible with set-tm:mday). + (set-tm:mday result (date-day date)) + (set-tm:month result (- (date-month date) 1)) + ;; FIXME: need to signal error on range violation. + (set-tm:year result (+ 1900 (date-year date))) + (set-tm:isdst result -1) + (set-tm:gmtoff result (- (date-zone-offset date))) + result)) + +;;; current-time + +;;; specific time getters. + +(define (priv:current-time-utc) + ;; Resolution is microseconds. + (let ((tod (gettimeofday))) + (make-time time-utc (* (cdr tod) 1000) (car tod)))) + +(define (priv:current-time-tai) + ;; Resolution is microseconds. + (let* ((tod (gettimeofday)) + (sec (car tod)) + (usec (cdr tod))) + (make-time time-tai + (* usec 1000) + (+ (car tod) (priv:leap-second-delta seconds))))) + +;;(define (priv:current-time-ms-time time-type proc) +;; (let ((current-ms (proc))) +;; (make-time time-type +;; (quotient current-ms 10000) +;; (* (remainder current-ms 1000) 10000)))) + +;; -- we define it to be the same as TAI. +;; A different implemation of current-time-montonic +;; will require rewriting all of the time-monotonic converters, +;; of course. + +(define (priv:current-time-monotonic) + ;; Resolution is microseconds. + (priv:current-time-tai)) + +(define (priv:current-time-thread) + (priv:time-error 'current-time 'unsupported-clock-type 'time-thread)) + +(define priv:ns-per-guile-tick (/ 1000000000 internal-time-units-per-second)) + +(define (priv:current-time-process) + (let ((run-time (get-internal-run-time))) + (make-time + time-process + (quotient run-time internal-time-units-per-second) + (* (remainder run-time internal-time-units-per-second) + priv:ns-per-guile-tick)))) + +(define (priv:current-time-process) + (let ((run-time (get-internal-run-time))) + (list + 'time-process + (* (remainder run-time internal-time-units-per-second) + priv:ns-per-guile-tick) + (quotient run-time internal-time-units-per-second)))) + +;;(define (priv:current-time-gc) +;; (priv:current-time-ms-time time-gc current-gc-milliseconds)) + +(define (current-time . clock-type) + (let ((clock-type (:optional clock-type time-utc))) + (cond + ((eq? clock-type time-tai) (priv:current-time-tai)) + ((eq? clock-type time-utc) (priv:current-time-utc)) + ((eq? clock-type time-monotonic) (priv:current-time-monotonic)) + ((eq? clock-type time-thread) (priv:current-time-thread)) + ((eq? clock-type time-process) (priv:current-time-process)) + ;; ((eq? clock-type time-gc) (priv:current-time-gc)) + (else (priv:time-error 'current-time 'invalid-clock-type clock-type))))) + +;; -- Time Resolution +;; This is the resolution of the clock in nanoseconds. +;; This will be implementation specific. + +(define (time-resolution . clock-type) + (let ((clock-type (:optional clock-type time-utc))) + (case clock-type + ((time-tai) 1000) + ((time-utc) 1000) + ((time-monotonic) 1000) + ((time-process) priv:ns-per-guile-tick) + ;; ((eq? clock-type time-thread) 1000) + ;; ((eq? clock-type time-gc) 10000) + (else (priv:time-error 'time-resolution 'invalid-clock-type clock-type))))) + +;; -- Time comparisons + +(define (time=? t1 t2) + ;; Arrange tests for speed and presume that t1 and t2 are actually times. + ;; also presume it will be rare to check two times of different types. + (and (= (time-second t1) (time-second t2)) + (= (time-nanosecond t1) (time-nanosecond 2)) + (eq? (time-type t1) (time-type t2)))) + +(define (time>? t1 t2) + (or (> (time-second t1) (time-second t2)) + (and (= (time-second t1) (time-second t2)) + (> (time-nanosecond t1) (time-nanosecond t2))))) + +(define (time=? t1 t2) + (or (> (time-second t1) (time-second t2)) + (and (= (time-second t1) (time-second t2)) + (>= (time-nanosecond t1) (time-nanosecond t2))))) + +(define (time<=? t1 t2) + (or (< (time-second time1) (time-second time2)) + (and (= (time-second time1) (time-second time2)) + (<= (time-nanosecond time1) (time-nanosecond time2))))) + +;; -- Time arithmetic + +(define (time-difference! time1 time2) + (let ((sec-diff (- (time-second time1) (time-second time2))) + (nsec-diff (- (time-nanosecond time1) (time-nanosecond time2)))) + (set-time-type! time1 time-duration) + (set-time-second! time1 sec-diff) + (set-time-nanosecond! time1 nsec-diff) + (priv:time-normalize! time1))) + +(define (time-difference time1 time2) + (let ((result (copy-time time1))) + (time-difference! result time2))) + +(define (add-duration! t duration) + (if (not (eq? (time-type duration) time-duration)) + (priv:time-error 'add-duration 'not-duration duration) + (let ((sec-plus (+ (time-second t) (time-second duration))) + (nsec-plus (+ (time-nanosecond t) (time-nanosecond duration)))) + (set-time-second! t sec-plus) + (set-time-nanosecond! t nsec-plus) + (priv:time-normalize! t)))) + +(define (priv:add-duration t duration) + (let ((result (copy-time t))) + (add-duration! result))) + +(define (subtract-duration! t duration) + (if (not (eq? (time-type duration) time-duration)) + (priv:time-error 'add-duration 'not-duration duration) + (let ((sec-minus (- (time-second t) (time-second duration))) + (nsec-minus (- (time-nanosecond t) (time-nanosecond duration)))) + (set-time-second! t sec-minus) + (set-time-nanosecond! t nsec-minus) + (priv:time-normalize! t)))) + +(define (subtract-duration time1 duration) + (let ((result (copy-time time1))) + (subtract-duration! result duration))) + +;; -- Converters between types. + +(define (priv:time-tai->time-utc! time-in time-out caller) + (if (not (eq? (time-type time-in) time-tai)) + (priv:time-error caller 'incompatible-time-types time-in)) + (set-time-type! time-out time-utc) + (set-time-nanosecond! time-out (time-nanosecond time-in)) + (set-time-second! time-out (- (time-second time-in) + (priv:leap-second-delta + (time-second time-in)))) + time-out) + +(define (time-tai->time-utc time-in) + (priv:time-tai->time-utc! time-in (make-time #f #f #f) 'time-tai->time-utc)) + + +(define (time-tai->time-utc! time-in) + (priv:time-tai->time-utc! time-in time-in 'time-tai->time-utc!)) + +(define (priv:time-utc->time-tai! time-in time-out caller) + (if (not (eq? (time-type time-in) time-utc)) + (priv:time-error caller 'incompatible-time-types time-in)) + (set-time-type! time-out time-tai) + (set-time-nanosecond! time-out (time-nanosecond time-in)) + (set-time-second! time-out (+ (time-second time-in) + (priv:leap-second-delta + (time-second time-in)))) + time-out) + +(define (time-utc->time-tai time-in) + (priv:time-utc->time-tai! time-in (make-time #f #f #f) 'time-utc->time-tai)) + +(define (time-utc->time-tai! time-in) + (priv:time-utc->time-tai! time-in time-in 'time-utc->time-tai!)) + +;; -- these depend on time-monotonic having the same definition as time-tai! +(define (time-monotonic->time-utc time-in) + (if (not (eq? (time-type time-in) time-monotonic)) + (priv:time-error caller 'incompatible-time-types time-in)) + (let ((ntime (copy-time time-in))) + (set-time-type! ntime time-tai) + (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc))) + +(define (time-monotonic->time-utc! time-in) + (if (not (eq? (time-type time-in) time-monotonic)) + (priv:time-error caller 'incompatible-time-types time-in)) + (set-time-type! time-in time-tai) + (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc)) + +(define (time-monotonic->time-tai time-in) + (if (not (eq? (time-type time-in) time-monotonic)) + (priv:time-error caller 'incompatible-time-types time-in)) + (let ((ntime (copy-time time-in))) + (set-time-type! ntime time-tai) + ntime)) + +(define (time-monotonic->time-tai! time-in) + (if (not (eq? (time-type time-in) time-monotonic)) + (priv:time-error caller 'incompatible-time-types time-in)) + (set-time-type! time-in time-tai) + time-in) + +(define (time-utc->time-monotonic time-in) + (if (not (eq? (time-type time-in) time-utc)) + (priv:time-error caller 'incompatible-time-types time-in)) + (let ((ntime (priv:time-utc->time-tai! time-in (make-time #f #f #f) + 'time-utc->time-monotonic))) + (set-time-type! ntime time-monotonic) + ntime)) + +(define (time-utc->time-monotonic! time-in) + (if (not (eq? (time-type time-in) time-utc)) + (priv:time-error caller 'incompatible-time-types time-in)) + (let ((ntime (priv:time-utc->time-tai! time-in time-in + 'time-utc->time-monotonic!))) + (set-time-type! ntime time-monotonic) + ntime)) + +(define (time-tai->time-monotonic time-in) + (if (not (eq? (time-type time-in) time-tai)) + (priv:time-error caller 'incompatible-time-types time-in)) + (let ((ntime (copy-time time-in))) + (set-time-type! ntime time-monotonic) + ntime)) + +(define (time-tai->time-monotonic! time-in) + (if (not (eq? (time-type time-in) time-tai)) + (priv:time-error caller 'incompatible-time-types time-in)) + (set-time-type! time-in time-monotonic) + time-in) + +;; -- Date Structures + +(define-record-type date + (make-date-unnormalized nanosecond second minute + hour day month + year + zone-offset) + date? + (nanosecond date-nanosecond) + (second date-second) + (minute date-minute) + (hour date-hour) + (day date-day) + (month date-month) + (year date-year) + (zone-offset date-zone-offset)) + +;; gives the julian day which starts at noon. +(define (priv:encode-julian-day-number day month year) + (let* ((a (quotient (- 14 month) 12)) + (y (- (+ year 4800) a (if (negative? year) -1 0))) + (m (- (+ month (* 12 a)) 3))) + (+ day + (quotient (+ (* 153 m) 2) 5) + (* 365 y) + (quotient y 4) + (- (quotient y 100)) + (quotient y 400) + -32045))) + +(define (priv:split-real r) + (if (integer? r) (values r 0) + (let ((l (truncate r))) + (values l (- r l))))) + +;; gives the seconds/date/month/year +(define (priv:decode-julian-day-number jdn) + (let* ((days (truncate jdn)) + (a (+ days 32044)) + (b (quotient (+ (* 4 a) 3) 146097)) + (c (- a (quotient (* 146097 b) 4))) + (d (quotient (+ (* 4 c) 3) 1461)) + (e (- c (quotient (* 1461 d) 4))) + (m (quotient (+ (* 5 e) 2) 153)) + (y (+ (* 100 b) d -4800 (quotient m 10)))) + (values ; seconds date month year + (* (- jdn days) priv:sid) + (+ e (- (quotient (+ (* 153 m) 2) 5)) 1) + (+ m 3 (* -12 (quotient m 10))) + (if (>= 0 y) (- y 1) y)))) + +;; relies on the fact that we named our time zone accessor +;; differently from MzScheme's.... +;; This should be written to be OS specific. + +(define (priv:local-tz-offset) + ;; SRFI uses seconds West, but guile (and libc) use seconds East. + (- (tm:gmtoff (localtime 0)))) + +;; special thing -- ignores nanos +(define (priv:time->julian-day-number seconds tz-offset) + (+ (/ (+ seconds tz-offset priv:sihd) + priv:sid) + priv:tai-epoch-in-jd)) + +(define (priv:leap-second? second) + (and (assoc second priv:leap-second-table) #t)) + +(define (time-utc->date time . tz-offset) + (if (not (eq? (time-type time) time-utc)) + (priv:time-error 'time->date 'incompatible-time-types time)) + (let* ((offset (:optional tz-offset (priv:local-tz-offset))) + (leap-second? (priv:leap-second? (+ offset (time-second time)))) + (jdn (priv:time->julian-day-number (if leap-second? + (- (time-second time) 1) + (time-second time)) + offset))) + + (call-with-values (lambda () (priv:decode-julian-day-number jdn)) + (lambda (secs date month year) + (let* ((hours (quotient secs (* 60 60))) + (rem (remainder secs (* 60 60))) + (minutes (quotient rem 60)) + (seconds (remainder rem 60))) + (make-date (time-nanosecond time) + (if leap-second? (+ seconds 1) seconds) + minutes + hours + date + month + year + offset)))))) + +(define (time-tai->date time . tz-offset) + (if (not (eq? (time-type time) time-tai)) + (priv:time-error 'time->date 'incompatible-time-types time)) + (let* ((offset (:optional tz-offset (priv:local-tz-offset))) + (seconds (- (time-second time) + (priv:leap-second-delta (time-second time)))) + (leap-second? (priv:leap-second? (+ offset seconds))) + (jdn (priv:time->julian-day-number (if leap-second? + (- seconds 1) + seconds) + offset))) + (call-with-values (lambda () (priv:decode-julian-day-number jdn)) + (lambda (secs date month year) + ;; adjust for leap seconds if necessary ... + (let* ((hours (quotient secs (* 60 60))) + (rem (remainder secs (* 60 60))) + (minutes (quotient rem 60)) + (seconds (remainder rem 60))) + (make-date (time-nanosecond time) + (if leap-second? (+ seconds 1) seconds) + minutes + hours + date + month + year + offset)))))) + +;; this is the same as time-tai->date. +(define (time-monotonic->date time . tz-offset) + (if (not (eq? (time-type time) time-monotonic)) + (priv:time-error 'time->date 'incompatible-time-types time)) + (let* ((offset (:optional tz-offset (priv:local-tz-offset))) + (seconds (- (time-second time) + (priv:leap-second-delta (time-second time)))) + (leap-second? (priv:leap-second? (+ offset seconds))) + (jdn (priv:time->julian-day-number (if leap-second? + (- seconds 1) + seconds) + offset))) + (call-with-values (lambda () (priv:decode-julian-day-number jdn)) + (lambda (secs date month year) + ;; adjust for leap seconds if necessary ... + (let* ((hours (quotient secs (* 60 60))) + (rem (remainder secs (* 60 60))) + (minutes (quotient rem 60)) + (seconds (remainder rem 60))) + (make-date (time-nanosecond time) + (if leap-second? (+ seconds 1) seconds) + minutes + hours + date + month + year + offset)))))) + +(define (date->time-utc date) + (let ((jdays (- (priv:encode-julian-day-number (date-day date) + (date-month date) + (date-year date)) + priv:tai-epoch-in-jd))) + (make-time + time-utc + (date-nanosecond date) + (+ (* (- jdays 1/2) 24 60 60) + (* (date-hour date) 60 60) + (* (date-minute date) 60) + (date-second date))))) + +(define (date->time-tai date) + (time-utc->time-tai! (date->time-utc date))) + +(define (date->time-monotonic date) + (time-utc->time-monotonic! (date->time-utc date))) + +(define (priv:leap-year? year) + (or (= (modulo year 400) 0) + (and (= (modulo year 4) 0) (not (= (modulo year 100) 0))))) + +(define (leap-year? date) + (priv:leap-year? (date-year date))) + +(define priv:month-assoc '((1 . 31) (2 . 59) (3 . 90) (4 . 120) + (5 . 151) (6 . 181) (7 . 212) (8 . 243) + (9 . 273) (10 . 304) (11 . 334) (12 . 365))) + +(define (priv:year-day day month year) + (let ((days-pr (assoc day priv:month-assoc))) + (if (not days-pr) + (priv:error 'date-year-day 'invalid-month-specification month)) + (if (and (priv:leap-year? year) (> month 2)) + (+ day (cdr days-pr) 1) + (+ day (cdr days-pr))))) + +(define (date-year-day date) + (priv:year-day (date-day date) (date-month date) (date-year date))) + +;; from calendar faq +(define (priv:week-day day month year) + (let* ((a (quotient (- 14 month) 12)) + (y (- year a)) + (m (+ month (* 12 a) -2))) + (modulo (+ day + y + (quotient y 4) + (- (quotient y 100)) + (quotient y 400) + (quotient (* 31 m) 12)) + 7))) + +(define (date-week-day date) + (priv:week-day (date-day date) (date-month date) (date-year date))) + +(define (priv:days-before-first-week date day-of-week-starting-week) + (let* ((first-day (make-date 0 0 0 0 + 1 + 1 + (date-year date) + #f)) + (fdweek-day (date-week-day first-day))) + (modulo (- day-of-week-starting-week fdweek-day) + 7))) + +(define (date-week-number date day-of-week-starting-week) + (quotient (- (date-year-day date) + (priv:days-before-first-week date day-of-week-starting-week)) + 7)) + +(define (current-date . tz-offset) + (time-utc->date (current-time time-utc) + (:optional tz-offset (priv:local-tz-offset)))) + +;; given a 'two digit' number, find the year within 50 years +/- +(define (priv:natural-year n) + (let* ((current-year (date-year (current-date))) + (current-century (* (quotient current-year 100) 100))) + (cond + ((>= n 100) n) + ((< n 0) n) + ((<= (- (+ current-century n) current-year) 50) (+ current-century n)) + (else (+ (- current-century 100) n))))) + +(define (date->julian-day date) + (let ((nanosecond (date-nanosecond date)) + (second (date-second date)) + (minute (date-minute date)) + (hour (date-hour date)) + (day (date-day date)) + (month (date-month date)) + (year (date-year date))) + (+ (priv:encode-julian-day-number day month year) + (- 1/2) + (+ (/ (+ (* hour 60 60) + (* minute 60) + second + (/ nanosecond priv:nano)) + priv:sid))))) + +(define (date->modified-julian-day date) + (- (date->julian-day date) + 4800001/2)) + +(define (time-utc->julian-day time) + (if (not (eq? (time-type time) time-utc)) + (priv:time-error 'time->date 'incompatible-time-types time)) + (+ (/ (+ (time-second time) (/ (time-nanosecond time) priv:nano)) + priv:sid) + priv:tai-epoch-in-jd)) + +(define (time-utc->modified-julian-day time) + (- (time-utc->julian-day time) + 4800001/2)) + +(define (time-tai->julian-day time) + (if (not (eq? (time-type time) time-tai)) + (priv:time-error 'time->date 'incompatible-time-types time)) + (+ (/ (+ (- (time-second time) + (priv:leap-second-delta (time-second time))) + (/ (time-nanosecond time) priv:nano)) + priv:sid) + priv:tai-epoch-in-jd)) + +(define (time-tai->modified-julian-day time) + (- (time-tai->julian-day time) + 4800001/2)) + +;; this is the same as time-tai->julian-day +(define (time-monotonic->julian-day time) + (if (not (eq? (time-type time) time-monotonic)) + (priv:time-error 'time->date 'incompatible-time-types time)) + (+ (/ (+ (- (time-second time) + (priv:leap-second-delta (time-second time))) + (/ (time-nanosecond time) priv:nano)) + priv:sid) + priv:tai-epoch-in-jd)) + +(define (time-monotonic->modified-julian-day time) + (- (time-monotonic->julian-day time) + 4800001/2)) + +(define (julian-day->time-utc jdn) + (let ((secs (* priv:sid (- jdn priv:tai-epoch-in-jd)))) + (receive (seconds parts) + (priv:split-real secs) + (make-time time-utc + (inexact->exact (truncate (* parts priv:nano))) + (inexact->exact seconds))))) + +(define (julian-day->time-tai jdn) + (time-utc->time-tai! (julian-day->time-utc jdn))) + +(define (julian-day->time-monotonic jdn) + (time-utc->time-monotonic! (julian-day->time-utc jdn))) + +(define (julian-day->date jdn . tz-offset) + (let ((offset (:optional tz-offset (priv:local-tz-offset)))) + (time-utc->date (julian-day->time-utc jdn) offset))) + +(define (modified-julian-day->date jdn . tz-offset) + (let ((offset (:optional tz-offset (priv:local-tz-offset)))) + (julian-day->date (+ jdn 4800001/2) offset))) + +(define (modified-julian-day->time-utc jdn) + (julian-day->time-utc (+ jdn 4800001/2))) + +(define (modified-julian-day->time-tai jdn) + (julian-day->time-tai (+ jdn 4800001/2))) + +(define (modified-julian-day->time-monotonic jdn) + (julian-day->time-monotonic (+ jdn 4800001/2))) + +(define (current-julian-day) + (time-utc->julian-day (current-time time-utc))) + +(define (current-modified-julian-day) + (time-utc->modified-julian-day (current-time time-utc))) + +;; returns a string rep. of number N, of minimum LENGTH, padded with +;; character PAD-WITH. If PAD-WITH is #f, no padding is done, and it's +;; as if number->string was used. if string is longer than or equal +;; in length to LENGTH, it's as if number->string was used. + +(define (priv:padding n pad-with length) + (let* ((str (number->string n)) + (str-len (string-length str))) + (if (or (>= str-len length) + (not pad-with)) + str + (string-append (make-string (- length str-len) pad-with) str)))) + +(define (priv:last-n-digits i n) + (abs (remainder i (expt 10 n)))) + +(define (priv:locale-abbr-weekday n) + (vector-ref priv:locale-abbr-weekday-vector n)) + +(define (priv:locale-long-weekday n) + (vector-ref priv:locale-long-weekday-vector n)) + +(define (priv:locale-abbr-month n) + (vector-ref priv:locale-abbr-month-vector n)) + +(define (priv:locale-long-month n) + (vector-ref priv:locale-long-month-vector n)) + +(define (priv:vector-find needle haystack comparator) + (let ((len (vector-length haystack))) + (define (priv:vector-find-int index) + (cond + ((>= index len) #f) + ((comparator needle (vector-ref haystack index)) index) + (else (priv:vector-find-int (+ index 1))))) + (priv:vector-find-int 0))) + +(define (priv:locale-abbr-weekday->index string) + (priv:vector-find string priv:locale-abbr-weekday-vector string=?)) + +(define (priv:locale-long-weekday->index string) + (priv:vector-find string priv:locale-long-weekday-vector string=?)) + +(define (priv:locale-abbr-month->index string) + (priv:vector-find string priv:locale-abbr-month-vector string=?)) + +(define (priv:locale-long-month->index string) + (priv:vector-find string priv:locale-long-month-vector string=?)) + + + +;; do nothing. +;; Your implementation might want to do something... +;; +;; FIXME: is it even possible to do anything reasonable here? +(define (priv:locale-print-time-zone date port) + (values)) + +;; FIXME: we should use strftime to determine this dynamically if possible. +;; Again, locale specific. +(define (priv:locale-am/pm hr) + (if (> hr 11) priv:locale-pm priv:locale-am)) + +(define (priv:tz-printer offset port) + (cond + ((= offset 0) (display "Z" port)) + ((negative? offset) (display "-" port)) + (else (display "+" port))) + (if (not (= offset 0)) + (let ((hours (abs (quotient offset (* 60 60)))) + (minutes (abs (quotient (remainder offset (* 60 60)) 60)))) + (display (priv:padding hours #\0 2) port) + (display (priv:padding minutes #\0 2) port)))) + +;; STOPPED-HERE + +;; A table of output formatting directives. +;; the first time is the format char. +;; the second is a procedure that takes the date, a padding character +;; (which might be #f), and the output port. +;; +(define priv:directives + (list + (cons #\~ (lambda (date pad-with port) + (display #\~ port))) + (cons #\a (lambda (date pad-with port) + (display (priv:locale-abbr-weekday (date-week-day date)) + port))) + (cons #\A (lambda (date pad-with port) + (display (priv:locale-long-weekday (date-week-day date)) + port))) + (cons #\b (lambda (date pad-with port) + (display (priv:locale-abbr-month (date-month date)) + port))) + (cons #\B (lambda (date pad-with port) + (display (priv:locale-long-month (date-month date)) + port))) + (cons #\c (lambda (date pad-with port) + (display (date->string date priv:locale-date-time-format) port))) + (cons #\d (lambda (date pad-with port) + (display (priv:padding (date-day date) + #\0 2) + port))) + (cons #\D (lambda (date pad-with port) + (display (date->string date "~m/~d/~y") port))) + (cons #\e (lambda (date pad-with port) + (display (priv:padding (date-day date) + #\Space 2) + port))) + (cons #\f (lambda (date pad-with port) + (if (> (date-nanosecond date) + priv:nano) + (display (priv:padding (+ (date-second date) 1) + pad-with 2) + port) + (display (priv:padding (date-second date) + pad-with 2) + port)) + (receive (i f) + (priv:split-real (/ + (date-nanosecond date) + priv:nano 1.0)) + (let* ((ns (number->string f)) + (le (string-length ns))) + (if (> le 2) + (begin + (display priv:locale-number-separator port) + (display (substring ns 2 le) port))))))) + (cons #\h (lambda (date pad-with port) + (display (date->string date "~b") port))) + (cons #\H (lambda (date pad-with port) + (display (priv:padding (date-hour date) + pad-with 2) + port))) + (cons #\I (lambda (date pad-with port) + (let ((hr (date-hour date))) + (if (> hr 12) + (display (priv:padding (- hr 12) + pad-with 2) + port) + (display (priv:padding hr + pad-with 2) + port))))) + (cons #\j (lambda (date pad-with port) + (display (priv:padding (date-year-day date) + pad-with 3) + port))) + (cons #\k (lambda (date pad-with port) + (display (priv:padding (date-hour date) + #\Space 2) + port))) + (cons #\l (lambda (date pad-with port) + (let ((hr (if (> (date-hour date) 12) + (- (date-hour date) 12) (date-hour date)))) + (display (priv:padding hr #\Space 2) + port)))) + (cons #\m (lambda (date pad-with port) + (display (priv:padding (date-month date) + pad-with 2) + port))) + (cons #\M (lambda (date pad-with port) + (display (priv:padding (date-minute date) + pad-with 2) + port))) + (cons #\n (lambda (date pad-with port) + (newline port))) + (cons #\N (lambda (date pad-with port) + (display (priv:padding (date-nanosecond date) + pad-with 7) + port))) + (cons #\p (lambda (date pad-with port) + (display (priv:locale-am/pm (date-hour date)) port))) + (cons #\r (lambda (date pad-with port) + (display (date->string date "~I:~M:~S ~p") port))) + (cons #\s (lambda (date pad-with port) + (display (time-second (date->time-utc date)) port))) + (cons #\S (lambda (date pad-with port) + (if (> (date-nanosecond date) + priv:nano) + (display (priv:padding (+ (date-second date) 1) + pad-with 2) + port) + (display (priv:padding (date-second date) + pad-with 2) + port)))) + (cons #\t (lambda (date pad-with port) + (display #\Tab port))) + (cons #\T (lambda (date pad-with port) + (display (date->string date "~H:~M:~S") port))) + (cons #\U (lambda (date pad-with port) + (if (> (priv:days-before-first-week date 0) 0) + (display (priv:padding (+ (date-week-number date 0) 1) + #\0 2) port) + (display (priv:padding (date-week-number date 0) + #\0 2) port)))) + (cons #\V (lambda (date pad-with port) + (display (priv:padding (date-week-number date 1) + #\0 2) port))) + (cons #\w (lambda (date pad-with port) + (display (date-week-day date) port))) + (cons #\x (lambda (date pad-with port) + (display (date->string date priv:locale-short-date-format) port))) + (cons #\X (lambda (date pad-with port) + (display (date->string date priv:locale-time-format) port))) + (cons #\W (lambda (date pad-with port) + (if (> (priv:days-before-first-week date 1) 0) + (display (priv:padding (+ (date-week-number date 1) 1) + #\0 2) port) + (display (priv:padding (date-week-number date 1) + #\0 2) port)))) + (cons #\y (lambda (date pad-with port) + (display (priv:padding (priv:last-n-digits + (date-year date) 2) + pad-with + 2) + port))) + (cons #\Y (lambda (date pad-with port) + (display (date-year date) port))) + (cons #\z (lambda (date pad-with port) + (priv:tz-printer (date-zone-offset date) port))) + (cons #\Z (lambda (date pad-with port) + (priv:locale-print-time-zone date port))) + (cons #\1 (lambda (date pad-with port) + (display (date->string date "~Y-~m-~d") port))) + (cons #\2 (lambda (date pad-with port) + (display (date->string date "~k:~M:~S~z") port))) + (cons #\3 (lambda (date pad-with port) + (display (date->string date "~k:~M:~S") port))) + (cons #\4 (lambda (date pad-with port) + (display (date->string date "~Y-~m-~dT~k:~M:~S~z") port))) + (cons #\5 (lambda (date pad-with port) + (display (date->string date "~Y-~m-~dT~k:~M:~S") port))))) + + +(define (priv:get-formatter char) + (let ((associated (assoc char priv:directives))) + (if associated (cdr associated) #f))) + +(define (priv:date-printer date index format-string str-len port) + (if (>= index str-len) + (values) + (let ((current-char (string-ref format-string index))) + (if (not (char=? current-char #\~)) + (begin + (display current-char port) + (priv:date-printer date (+ index 1) format-string str-len port)) + (if (= (+ index 1) str-len) ; bad format string. + (priv:time-error 'priv:date-printer 'bad-date-format-string + format-string) + (let ((pad-char? (string-ref format-string (+ index 1)))) + (cond + ((char=? pad-char? #\-) + (if (= (+ index 2) str-len) ; bad format string. + (priv:time-error 'priv:date-printer + 'bad-date-format-string + format-string) + (let ((formatter (priv:get-formatter + (string-ref format-string + (+ index 2))))) + (if (not formatter) + (priv:time-error 'priv:date-printer + 'bad-date-format-string + format-string) + (begin + (formatter date #f port) + (priv:date-printer date + (+ index 3) + format-string + str-len + port)))))) + + ((char=? pad-char? #\_) + (if (= (+ index 2) str-len) ; bad format string. + (priv:time-error 'priv:date-printer + 'bad-date-format-string + format-string) + (let ((formatter (priv:get-formatter + (string-ref format-string + (+ index 2))))) + (if (not formatter) + (priv:time-error 'priv:date-printer + 'bad-date-format-string + format-string) + (begin + (formatter date #\Space port) + (priv:date-printer date + (+ index 3) + format-string + str-len + port)))))) + (else + (let ((formatter (priv:get-formatter + (string-ref format-string + (+ index 1))))) + (if (not formatter) + (priv:time-error 'priv:date-printer + 'bad-date-format-string + format-string) + (begin + (formatter date #\0 port) + (priv:date-printer date + (+ index 2) + format-string + str-len + port)))))))))))) + + +(define (date->string date . format-string) + (let ((str-port (open-output-string)) + (fmt-str (:optional format-string "~c"))) + (priv:date-printer date 0 fmt-str (string-length fmt-str) str-port) + (get-output-string str-port))) + +(define (priv:char->int ch) + (case ch + ((#\0) 0) + ((#\1) 1) + ((#\2) 2) + ((#\3) 3) + ((#\4) 4) + ((#\5) 5) + ((#\6) 6) + ((#\7) 7) + ((#\8) 8) + ((#\9) 9) + (else (priv:time-error 'bad-date-template-string + (list "Non-integer character" ch i))))) + +;; read an integer upto n characters long on port; upto -> #f is any length +(define (priv:integer-reader upto port) + (let loop ((accum 0) (nchars 0)) + (let ((ch (peek-char port))) + (if (or (eof-object? ch) + (not (char-numeric? ch)) + (and upto (>= nchars upto))) + accum + (loop port + (+ (* accum 10) (priv:char->int (read-char port))) + (+ nchars 1)))))) + +(define (priv:make-integer-reader upto) + (lambda (port) + (priv:integer-reader upto port))) + +;; read *exactly* n characters and convert to integer; could be padded +(define (priv:integer-reader-exact n port) + (let ((padding-ok #t)) + (define (accum-int port accum nchars) + (let ((ch (peek-char port))) + (cond + ((>= nchars n) accum) + ((eof-object? ch) + (priv:time-error 'string->date 'bad-date-template-string + "Premature ending to integer read.")) + ((char-numeric? ch) + (set! padding-ok #f) + (accum-int port (+ (* accum 10) (priv:char->int (read-char + port))) + (+ nchars 1))) + (padding-ok + (read-ch port) ; consume padding + (accum-int prot accum (+ nchars 1))) + (else ; padding where it shouldn't be + (priv:time-error 'string->date 'bad-date-template-string + "Non-numeric characters in integer read."))))) + (accum-int port 0 0))) + + +(define (priv:make-integer-exact-reader n) + (lambda (port) + (priv:integer-reader-exact n port))) + +(define (priv:zone-reader port) + (let ((offset 0) + (positive? #f)) + (let ((ch (read-char port))) + (if (eof-object? ch) + (priv:time-error 'string->date 'bad-date-template-string + (list "Invalid time zone +/-" ch))) + (if (or (char=? ch #\Z) (char=? ch #\z)) + 0 + (begin + (cond + ((char=? ch #\+) (set! positive? #t)) + ((char=? ch #\-) (set! positive? #f)) + (else + (priv:time-error 'string->date 'bad-date-template-string + (list "Invalid time zone +/-" ch)))) + (let ((ch (read-char port))) + (if (eof-object? ch) + (priv:time-error 'string->date 'bad-date-template-string + (list "Invalid time zone number" ch))) + (set! offset (* (priv:char->int ch) + 10 60 60))) + (let ((ch (read-char port))) + (if (eof-object? ch) + (priv:time-error 'string->date 'bad-date-template-string + (list "Invalid time zone number" ch))) + (set! offset (+ offset (* (priv:char->int ch) + 60 60)))) + (let ((ch (read-char port))) + (if (eof-object? ch) + (priv:time-error 'string->date 'bad-date-template-string + (list "Invalid time zone number" ch))) + (set! offset (+ offset (* (priv:char->int ch) + 10 60)))) + (let ((ch (read-char port))) + (if (eof-object? ch) + (priv:time-error 'string->date 'bad-date-template-string + (list "Invalid time zone number" ch))) + (set! offset (+ offset (* (priv:char->int ch) + 60)))) + (if positive? offset (- offset))))))) + +;; looking at a char, read the char string, run thru indexer, return index +(define (priv:locale-reader port indexer) + (let ((string-port (open-output-string))) + (define (read-char-string) + (let ((ch (peek-char port))) + (if (char-alphabetic? ch) + (begin (write-char (read-char port) string-port) + (read-char-string)) + (get-output-string string-port)))) + (let* ((str (read-char-string)) + (index (indexer str))) + (if index index (priv:time-error 'string->date + 'bad-date-template-string + (list "Invalid string for " indexer)))))) + +(define (priv:make-locale-reader indexer) + (lambda (port) + (priv:locale-reader port indexer))) + +(define (priv:make-char-id-reader char) + (lambda (port) + (if (char=? char (read-char port)) + char + (priv:time-error 'string->date + 'bad-date-template-string + "Invalid character match.")))) + +;; A List of formatted read directives. +;; Each entry is a list. +;; 1. the character directive; +;; a procedure, which takes a character as input & returns +;; 2. #t as soon as a character on the input port is acceptable +;; for input, +;; 3. a port reader procedure that knows how to read the current port +;; for a value. Its one parameter is the port. +;; 4. a action procedure, that takes the value (from 3.) and some +;; object (here, always the date) and (probably) side-effects it. +;; In some cases (e.g., ~A) the action is to do nothing + +(define priv:read-directives + (let ((ireader4 (priv:make-integer-reader 4)) + (ireader2 (priv:make-integer-reader 2)) + (ireaderf (priv:make-integer-reader #f)) + (eireader2 (priv:make-integer-exact-reader 2)) + (eireader4 (priv:make-integer-exact-reader 4)) + (locale-reader-abbr-weekday (priv:make-locale-reader + priv:locale-abbr-weekday->index)) + (locale-reader-long-weekday (priv:make-locale-reader + priv:locale-long-weekday->index)) + (locale-reader-abbr-month (priv:make-locale-reader + priv:locale-abbr-month->index)) + (locale-reader-long-month (priv:make-locale-reader + priv:locale-long-month->index)) + (char-fail (lambda (ch) #t)) + (do-nothing (lambda (val object) (values)))) + + (list + (list #\~ char-fail (priv:make-char-id-reader #\~) do-nothing) + (list #\a char-alphabetic? locale-reader-abbr-weekday do-nothing) + (list #\A char-alphabetic? locale-reader-long-weekday do-nothing) + (list #\b char-alphabetic? locale-reader-abbr-month + (lambda (val object) + (priv:set-date-month! object val))) + (list #\B char-alphabetic? locale-reader-long-month + (lambda (val object) + (priv:set-date-month! object val))) + (list #\d char-numeric? ireader2 (lambda (val object) + (priv:set-date-day! + object val))) + (list #\e char-fail eireader2 (lambda (val object) + (priv:set-date-day! object val))) + (list #\h char-alphabetic? locale-reader-abbr-month + (lambda (val object) + (priv:set-date-month! object val))) + (list #\H char-numeric? ireader2 (lambda (val object) + (priv:set-date-hour! object val))) + (list #\k char-fail eireader2 (lambda (val object) + (priv:set-date-hour! object val))) + (list #\m char-numeric? ireader2 (lambda (val object) + (priv:set-date-month! object val))) + (list #\M char-numeric? ireader2 (lambda (val object) + (priv:set-date-minute! + object val))) + (list #\S char-numeric? ireader2 (lambda (val object) + (priv:set-date-second! object val))) + (list #\y char-fail eireader2 + (lambda (val object) + (priv:set-date-year! object (priv:natural-year val)))) + (list #\Y char-numeric? ireader4 (lambda (val object) + (priv:set-date-year! object val))) + (list #\z (lambda (c) + (or (char=? c #\Z) + (char=? c #\z) + (char=? c #\+) + (char=? c #\-))) + priv:zone-reader (lambda (val object) + (priv:set-date-zone-offset! object val)))))) + +(define (priv:string->date date index format-string str-len port template-string) + (define (skip-until port skipper) + (let ((ch (peek-char port))) + (if (eof-object? port) + (priv:time-error 'string->date 'bad-date-format-string template-string) + (if (not (skipper ch)) + (begin (read-char port) (skip-until port skipper)))))) + (if (>= index str-len) + (begin + (values)) + (let ((current-char (string-ref format-string index))) + (if (not (char=? current-char #\~)) + (let ((port-char (read-char port))) + (if (or (eof-object? port-char) + (not (char=? current-char port-char))) + (priv:time-error 'string->date + 'bad-date-format-string template-string)) + (priv:string->date date + (+ index 1) + format-string + str-len + port + template-string)) + ;; otherwise, it's an escape, we hope + (if (> (+ index 1) str-len) + (priv:time-error 'string->date + 'bad-date-format-string template-string) + (let* ((format-char (string-ref format-string (+ index 1))) + (format-info (assoc format-char priv:read-directives))) + (if (not format-info) + (priv:time-error 'string->date + 'bad-date-format-string template-string) + (begin + (let ((skipper (cadr format-info)) + (reader (caddr format-info)) + (actor (cadddr format-info))) + (skip-until port skipper) + (let ((val (reader port))) + (if (eof-object? val) + (priv:time-error 'string->date + 'bad-date-format-string + template-string) + (actor val date))) + (priv:string->date date + (+ index 2) + format-string + str-len + port + template-string)))))))))) + +(define (string->date input-string template-string) + (define (priv:date-ok? date) + (and (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))) + (let ((newdate (make-date 0 0 0 0 #f #f #f (priv:local-tz-offset)))) + (priv:string->date newdate + 0 + template-string + (string-length template-string) + (open-input-string input-string) + template-string) + (if (priv:date-ok? newdate) + newdate + (priv:time-error + 'string->date + 'bad-date-format-string + (list "Incomplete date read. " newdate template-string))))) From a19422d7bfcb9bb8eeb03f97b667c7ab87da5603 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sun, 6 May 2001 03:33:02 +0000 Subject: [PATCH 1020/2047] * Makefile.am (srfi_DATA): added srfi-19.scm. --- srfi/Makefile.am | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/srfi/Makefile.am b/srfi/Makefile.am index 11c25b8d9..f976ec822 100644 --- a/srfi/Makefile.am +++ b/srfi/Makefile.am @@ -45,7 +45,8 @@ srfi_DATA = srfi-2.scm \ srfi-11.scm \ srfi-13.scm \ srfi-14.scm \ - srfi-17.scm + srfi-17.scm \ + srfi-19.scm EXTRA_DIST = $(srfi_DATA) From 2b60bc955f84e5d5b6e82d753e5ee4ae5b5acdd7 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sun, 6 May 2001 03:33:46 +0000 Subject: [PATCH 1021/2047] *** empty log message *** --- AUTHORS | 13 ++++++++----- NEWS | 2 ++ THANKS | 2 ++ srfi/ChangeLog | 7 +++++++ 4 files changed, 19 insertions(+), 5 deletions(-) diff --git a/AUTHORS b/AUTHORS index bea86d356..1c66eb486 100644 --- a/AUTHORS +++ b/AUTHORS @@ -93,11 +93,11 @@ In the subdirectory libguile, wrote: regex-posix.h Rob Browning: -In the subdirectory srfi, wrote the initial files for: - srfi-2.scm - srfi-6.scm - srfi-8.scm - srfi-11.scm + wrote initial srfi/srfi-2.scm. + wrote initial srfi/srfi-6.scm. + wrote initial srfi/srfi-8.scm. + wrote initial srfi/srfi-11.scm. + ported srfi/srfi-19.scm to Guile. Martin Grabmueller: In the subdirectory srfi, wrote: @@ -111,3 +111,6 @@ In the subdirectory doc, wrote: srfi-modules.texi srfi-13-14.texi repl-modules.texi + +Will Fitzgerald: + wrote initial srfi/srfi-19.scm. diff --git a/NEWS b/NEWS index 94876886e..425a3c662 100644 --- a/NEWS +++ b/NEWS @@ -49,6 +49,8 @@ Changes since Guile 1.4: (srfi srfi-14) implements the SRFI Character-Set Library. +(srfi srfi-14) implements the SRFI Time/Date Library. + ** New scripts / "executable modules" Subdirectory "scripts" contains Scheme modules that are packaged to diff --git a/THANKS b/THANKS index b8d24c973..5d9e51890 100644 --- a/THANKS +++ b/THANKS @@ -9,6 +9,8 @@ Contributors since the last release: Jost Boekemeier Greg Harvey + Will Fitzgerald + Rob Browning For fixes or providing information which led to a fix: diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 2b5eade25..b64ea9d23 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,10 @@ +2001-05-05 Rob Browning + + * Makefile.am (srfi_DATA): added srfi-19.scm. + + * srfi-19.scm: New file - time/date SRFI. Thanks to Will + Fitzgerald. + 2001-05-02 Martin Grabmueller * srfi-14.c, srfi-13.c: Added @bullet to various @itemize lists. From 90b7e69a9e1afe935067a1470000787a35f6d1dc Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 6 May 2001 09:18:43 +0000 Subject: [PATCH 1022/2047] *** empty log message *** --- doc/ChangeLog | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 2e3293b37..968f99256 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,12 @@ +2001-05-06 Thien-Thi Nguyen + + * intro.texi (Using Guile Modules): Review; remove reviewme + comment. Expand `GUILE_LOAD_PATH' blurb; add small example. + (Reporting Bugs): Review; remove reviewme comment. + Reword some phrases; add texi markup. + Add suggestion to include `guile-config info' output. + Update gdb invocation; add fixme question. + 2001-05-05 Neil Jerram * AUTHORS: Added Martin Grabmueller. @@ -17,7 +26,7 @@ blank lines). * scheme-modules.texi: Change double hyphens to single. - + * scheme-control.texi (Lazy Catch): Completed. * posix.texi (Network Databases and Address Conversion): New From 2b1621ac77018ea7e8f5dbf339f5f54366f586aa Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 6 May 2001 09:26:16 +0000 Subject: [PATCH 1023/2047] Update copyright. Fix commentary typo; nfc. --- ice-9/expect.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ice-9/expect.scm b/ice-9/expect.scm index 7aaeca4c2..8a8d1e9d0 100644 --- a/ice-9/expect.scm +++ b/ice-9/expect.scm @@ -1,4 +1,4 @@ -;;;; Copyright (C) 1996, 1998, 1999 Free Software Foundation, Inc. +;;;; Copyright (C) 1996, 1998, 1999, 2001 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 @@ -20,7 +20,7 @@ ;; This module is documented in the Guile Reference Manual. ;; Briefly, these are exported: -;; procedures: expec-select, expect-regexec +;; procedures: expect-select, expect-regexec ;; variables: expect-port, expect-timeout, expect-timeout-proc, ;; expect-eof-proc, expect-char-proc, ;; expect-strings-compile-flags, expect-strings-exec-flags, From 64705682ddf1fe3f0306daa604de7031d5f33963 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 6 May 2001 09:40:32 +0000 Subject: [PATCH 1024/2047] Update copyright. Surround commentary w/ standard markers; nfc. --- ice-9/getopt-long.scm | 84 ++++++++++++++++++++++-------------------- ice-9/q.scm | 40 +++++++++++--------- ice-9/runq.scm | 85 +++++++++++++++++++++---------------------- 3 files changed, 108 insertions(+), 101 deletions(-) diff --git a/ice-9/getopt-long.scm b/ice-9/getopt-long.scm index 339011268..c3660f5ff 100644 --- a/ice-9/getopt-long.scm +++ b/ice-9/getopt-long.scm @@ -1,30 +1,32 @@ ;;; Author: Russ McManus -;;; $Id: getopt-long.scm,v 1.2 1999-02-15 12:53:10 jimb Exp $ +;;; $Id: getopt-long.scm,v 1.3 2001-05-06 09:40:32 ttn Exp $ ;;; -;;; Copyright (C) 1998 FSF +;;; Copyright (C) 1998, 2001 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 ;;; 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 this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -;;; + +;;; Commentary: + ;;; This module implements some complex command line option parsing, in ;;; the spirit of the GNU C library function 'getopt_long'. Both long ;;; and short options are supported. -;;; +;;; ;;; The theory is that people should be able to constrain the set of ;;; options they want to process using a grammar, rather than some arbitrary ;;; structure. The grammar makes the option descriptions easy to read. -;;; +;;; ;;; getopt-long is a function for parsing command-line arguments in a ;;; manner consistent with other GNU programs. @@ -43,7 +45,7 @@ ;;; Each OPTION should be a symbol. `getopt-long' will accept a ;;; command-line option named `--OPTION'. ;;; Each option can have the following (PROPERTY VALUE) pairs: -;;; +;;; ;;; (single-char CHAR) --- Accept `-CHAR' as a single-character ;;; equivalent to `--OPTION'. This is how to specify traditional ;;; Unix-style flags. @@ -52,7 +54,7 @@ ;;; (value BOOL) --- If BOOL is #t, the option accepts a value; if ;;; it is #f, it does not; and if it is the symbol ;;; `optional', the option may appear in ARGS with or -;;; without a value. +;;; without a value. ;;; (predicate FUNC) --- If the option accepts a value (i.e. you ;;; specified `(value #t)' for this option), then getopt ;;; will apply FUNC to the value, and throw an exception @@ -64,7 +66,7 @@ ;;; property may occur only once. By default, options do not have ;;; single-character equivalents, are not required, and do not take ;;; values. -;;; +;;; ;;; In ARGS, single-character options may be combined, in the usual ;;; Unix fashion: ("-x" "-y") is equivalent to ("-xy"). If an option ;;; accepts values, then it must be the last option in the @@ -130,10 +132,10 @@ ;;; (single-char #\v) ;;; (value #f)) ;;; (x-includes (single-char #\x)) -;;; (rnet-server (single-char #\y) +;;; (rnet-server (single-char #\y) ;;; (predicate ,string?)))) ;;; -;;; (getopt-long '("my-prog" "-vk" "/tmp" "foo1" "--x-includes=/usr/include" +;;; (getopt-long '("my-prog" "-vk" "/tmp" "foo1" "--x-includes=/usr/include" ;;; "--rnet-server=lamprod" "--" "-fred" "foo2" "foo3") ;;; grammar) ;;; => ((() "foo1" "-fred" "foo2" "foo3") @@ -142,22 +144,22 @@ ;;; (lockfile-dir . "/tmp") ;;; (verbose . #t)) +;;; Code: (define-module (ice-9 getopt-long) :use-module (ice-9 common-list)) -;;; end-header ;;; The code on this page was expanded by hand using the following code: -;;; (pretty-print -;;; (macroexpand -;;; '(define-record option-spec -;;; (name -;;; value -;;; value-required? -;;; single-char -;;; predicate-ls -;;; parse-ls)))) +;;; (pretty-print +;;; (macroexpand +;;; '(define-record option-spec +;;; (name +;;; value +;;; value-required? +;;; single-char +;;; predicate-ls +;;; parse-ls)))) ;;; ;;; This avoids the need to load slib for records. (define slib:error error) @@ -335,7 +337,7 @@ (let ((name (option-spec->name spec))) (error "option must be specified:" name))))))) -(define make-option-value-predicate +(define make-option-value-predicate (lambda (predicate) (lambda (spec) (let ((val (option-spec->value spec))) @@ -351,10 +353,10 @@ (let ((name (option-spec->name spec))) (error "option must be specified with argument:" name))))))) -(define single-char-value? +(define single-char-value? (lambda (val) (char? val))) - + (define (parse-option-spec desc) (letrec ((parse-iter (lambda (spec) @@ -393,7 +395,7 @@ (option-spec->value spec) #t (option-spec->single-char spec) - (cons (make-required-value-fn) + (cons (make-required-value-fn) (option-spec->predicate-ls spec)) (cdr parse-ls)))) ((eq? val #f) @@ -404,7 +406,7 @@ (option-spec->value spec) #f (option-spec->single-char spec) - (cons (make-not-allowed-value-fn) + (cons (make-not-allowed-value-fn) (option-spec->predicate-ls spec)) (cdr parse-ls)))) ((eq? val 'optional) @@ -446,7 +448,7 @@ (string? (car desc))) (error "Bad option specification:" desc)) (parse-iter (make-option-spec (car desc) - #f + #f #f #f '() @@ -454,13 +456,13 @@ ;;; -;;; +;;; ;;; (define (split-arg-list argument-list) - "Given an ARGUMENT-LIST, decide which part to process for options. -Everything before an arg of \"--\" is fair game, everything after it -should not be processed. The \"--\" is discarded. A cons pair is -returned whose car is the list to process for options, and whose cdr + "Given an ARGUMENT-LIST, decide which part to process for options. +Everything before an arg of \"--\" is fair game, everything after it +should not be processed. The \"--\" is discarded. A cons pair is +returned whose car is the list to process for options, and whose cdr is the list to not process." (let loop ((process-ls '()) (not-process-ls argument-list)) @@ -500,12 +502,12 @@ is the list to not process." (define (process-short-option specifications argument-ls alist) "Process a single short option that appears at the front of the ARGUMENT-LS, -according to SPECIFICATIONS. Returns #f is there is no such argument. Otherwise -returns a pair whose car is the list of remaining arguments, and whose cdr is a -new association list, constructed by adding a pair to the supplied ALIST. -The pair on the front of the returned association list describes the option -found at the head of ARGUMENT-LS. The way this routine currently works, an -option that never takes a value that is followed by a non option will cause +according to SPECIFICATIONS. Returns #f is there is no such argument. Otherwise +returns a pair whose car is the list of remaining arguments, and whose cdr is a +new association list, constructed by adding a pair to the supplied ALIST. +The pair on the front of the returned association list describes the option +found at the head of ARGUMENT-LS. The way this routine currently works, an +option that never takes a value that is followed by a non option will cause an error, which is probably a bug. To fix the bug the option specification needs to record whether the option ever can take a value." (define (short-option->char option) @@ -622,7 +624,7 @@ option name is a symbol. The option value will be '#t' if no value was specified. There is a special item in the returned alist with a key of the empty list, (): the list of arguments that are not options or option values. - By default, options are not required, and option values are not + By default, options are not required, and option values are not required. By default, single character equivalents are not supported; if you want to allow the user to use single character options, you need to add a 'single-char' clause to the option description." @@ -660,3 +662,5 @@ found, return DEFAULT." (export option-ref) (export getopt-long) + +;;; getopt-long.scm ends here diff --git a/ice-9/q.scm b/ice-9/q.scm index 08e754396..453ef95d1 100644 --- a/ice-9/q.scm +++ b/ice-9/q.scm @@ -1,33 +1,30 @@ ;;;; q.scm --- Queues ;;;; -;;;; Copyright (C) 1995 Free Software Foundation, Inc. -;;;; +;;;; Copyright (C) 1995, 2001 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 ;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA -;;;; - -(define-module (ice-9 q)) - ;;;; -;;; Q: Based on the interface to + +;;; Commentary: + +;;; Q: Based on the interface to ;;; -;;; "queue.scm" Queues/Stacks for Scheme +;;; "queue.scm" Queues/Stacks for Scheme ;;; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992. -;;; -;;;; ;;; {Q} ;;; ;;; A list is just a bunch of cons pairs that follows some constrains, @@ -39,7 +36,7 @@ ;;; simple, regular structure and non-disjointedness (associations ;;; being lists and so forth). ;;; -;;; So I figured, queues should be the same -- just a "subtype" of cons-pair +;;; So I figured, queues should be the same -- just a "subtype" of cons-pair ;;; structures in general. ;;; ;;; A queue is a cons pair: @@ -49,7 +46,7 @@ ;;; of that list. ;;; ;;; is #f if the q is empty, and otherwise is the last -;;;pair of . +;;; pair of . ;;; ;;; q's print nicely, but alas, they do not read well because the ;;; eq?-ness of and (last-pair ) is lost by read. @@ -57,12 +54,17 @@ ;;; All the functions that aren't explicitly defined to return ;;; something else (a queue element; a boolean value) return the queue ;;; object itself. + +;;; Code: + +(define-module (ice-9 q)) + +;;; sync-q! +;;; The procedure ;;; -;;; The procedure -;;; ;;; (sync-q! q) ;;; -;;; recomputes and resets the component of a queue. +;;; recomputes and resets the component of a queue. ;;; (define-public (sync-q! q) (set-cdr! q (if (pair? (car q)) (last-pair (car q)) @@ -88,7 +90,7 @@ (not (cdr obj)))))) ;;; q-empty? obj -;;; +;;; (define-public (q-empty? obj) (null? (car obj))) ;;; q-empty-check q @@ -146,3 +148,5 @@ ;;; Return the number of enqueued elements. ;;; (define-public (q-length q) (length (car q))) + +;;; q.scm ends here diff --git a/ice-9/runq.scm b/ice-9/runq.scm index 9adb89776..136f92595 100644 --- a/ice-9/runq.scm +++ b/ice-9/runq.scm @@ -1,43 +1,40 @@ ;;;; runq.scm --- the runq data structure ;;;; -;;;; Copyright (C) 1996 Free Software Foundation, Inc. -;;;; +;;;; Copyright (C) 1996, 2001 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 ;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA -;;;; - -(define-module (ice-9 runq) - :use-module (ice-9 q)) - ;;;; -;;; + +;;; Commentary: + ;;; One way to schedule parallel computations in a serial environment is ;;; to explicitly divide each task up into small, finite execution time, ;;; strips. Then you interleave the execution of strips from various ;;; tasks to achieve a kind of parallelism. Runqs are a handy data ;;; structure for this style of programming. -;;; +;;; ;;; We use thunks (nullary procedures) and lists of thunks to represent ;;; strips. By convention, the return value of a strip-thunk must either ;;; be another strip or the value #f. -;;; +;;; ;;; A runq is a procedure that manages a queue of strips. Called with no ;;; arguments, it processes one strip from the queue. Called with ;;; arguments, the arguments form a control message for the queue. The ;;; first argument is a symbol which is the message selector. -;;; +;;; ;;; A strip is processed this way: If the strip is a thunk, the thunk is ;;; called -- if it returns a strip, that strip is added back to the ;;; queue. To process a strip which is a list of thunks, the CAR of that @@ -47,20 +44,21 @@ ;;; these strips exist back on the queue. (The exact order in which ;;; strips are put back on the queue determines the scheduling behavior of ;;; a particular queue -- it's a parameter.) -;;; -;;; +;;; Code: +(define-module (ice-9 runq) + :use-module (ice-9 q)) ;;;; ;;; (runq-control q msg . args) -;;; +;;; ;;; processes in the default way the control messages that ;;; can be sent to a runq. Q should be an ordinary ;;; Q (see utils/q.scm). -;;; +;;; ;;; The standard runq messages are: -;;; +;;; ;;; 'add! strip0 strip1... ;; to enqueue one or more strips ;;; 'enqueue! strip0 strip1... ;; to enqueue one or more strips ;;; 'push! strip0 ... ;; add strips to the front of the queue @@ -68,7 +66,7 @@ ;;; 'length ;; how many strips in the queue? ;;; 'kill! ;; empty the queue ;;; else ;; throw 'not-understood -;;; +;;; (define-public (runq-control q msg . args) (case msg ((add!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*) @@ -96,20 +94,20 @@ ((length) 0) (else #f))))))) -;;;; +;;;; ;;; (make-fair-runq) -;;; +;;; ;;; Returns a runq procedure. ;;; Called with no arguments, the procedure processes one strip from the queue. ;;; Called with arguments, it uses runq-control. -;;; +;;; ;;; In a fair runq, if a strip returns a new strip X, X is added ;;; to the end of the queue, meaning it will be the last to execute ;;; of all the remaining procedures. -;;; +;;; (define-public (make-fair-runq) (letrec ((q (make-q)) - (self + (self (lambda ctl (if ctl (apply runq-control q ctl) @@ -126,26 +124,26 @@ self)) -;;;; +;;;; ;;; (make-exclusive-runq) -;;; +;;; ;;; Returns a runq procedure. ;;; Called with no arguments, the procedure processes one strip from the queue. ;;; Called with arguments, it uses runq-control. -;;; +;;; ;;; In an exclusive runq, if a strip W returns a new strip X, X is added ;;; to the front of the queue, meaning it will be the next to execute ;;; of all the remaining procedures. -;;; +;;; ;;; An exception to this occurs if W was the CAR of a list of strips. ;;; In that case, after the return value of W is pushed onto the front ;;; of the queue, the CDR of the list of strips is pushed in front ;;; of that (if the CDR is not nil). This way, the rest of the thunks ;;; in the list that contained W have priority over the return value of W. -;;; +;;; (define-public (make-exclusive-runq) (letrec ((q (make-q)) - (self + (self (lambda ctl (if ctl (apply runq-control q ctl) @@ -162,19 +160,19 @@ self)) -;;;; +;;;; ;;; (make-subordinate-runq-to superior basic-inferior) -;;; +;;; ;;; Returns a runq proxy for the runq basic-inferior. -;;; +;;; ;;; The proxy watches for operations on the basic-inferior that cause -;;; a transition from a queue length of 0 to a non-zero length and +;;; a transition from a queue length of 0 to a non-zero length and ;;; vice versa. While the basic-inferior queue is not empty, ;;; the proxy installs a task on the superior runq. Each strip ;;; of that task processes N strips from the basic-inferior where ;;; N is the length of the basic-inferior queue when the proxy -;;; strip is entered. [Countless scheduling variations are possible.] -;;; +;;; strip is entered. [Countless scheduling variations are possible.] +;;; (define-public (make-subordinate-runq-to superior-runq basic-runq) (let ((runq-task (cons #f #f))) (set-car! runq-task @@ -203,7 +201,7 @@ ;;;; ;;; (define fork-strips (lambda args args)) -;;; Return a strip that starts several strips in +;;; Return a strip that starts several strips in ;;; parallel. If this strip is enqueued on a fair ;;; runq, strips of the parallel subtasks will run ;;; round-robin style. @@ -211,11 +209,11 @@ (define fork-strips (lambda args args)) -;;;; +;;;; ;;; (strip-sequence . strips) -;;; +;;; ;;; Returns a new strip which is the concatenation of the argument strips. -;;; +;;; (define-public ((strip-sequence . strips)) (let loop ((st (let ((a strips)) (set! strips #f) a))) (and (not (null? st)) @@ -227,14 +225,15 @@ ;;;; ;;; (fair-strip-subtask . initial-strips) -;;; +;;; ;;; Returns a new strip which is the synchronos, fair, ;;; parallel execution of the argument strips. -;;; -;;; +;;; +;;; ;;; (define-public (fair-strip-subtask . initial-strips) (let ((st (make-fair-runq))) (apply st 'add! initial-strips) st)) +;;; runq.scm ends here From 7874f3d0005bfc8c22a092571b50e27f115ceaf5 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 6 May 2001 10:05:35 +0000 Subject: [PATCH 1025/2047] *** empty log message *** --- ice-9/ChangeLog | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index bd433e3d3..4ad7325d1 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,11 @@ +2001-05-06 Thien-Thi Nguyen + + * q.scm, runq.scm, getopt-long.scm: Update copyright. + Surround commentary w/ standard markers; nfc. + + * expect.scm: Update copyright. + Fix commentary typo; nfc. + 2001-05-05 Rob Browning * psyntax.ss: make sure emacs knows it's scheme code. @@ -20,7 +28,7 @@ (eval-in-module): Manifest deprecation via `begin-deprecation' and `issue-deprecation-warning'. (warn-autoload-deprecation): Deactivated. - + 2001-04-26 Marius Vollmer * boot-9.scm (the-module, set-current-module, current-module): From e1fbffa9f4d2fa6085306dfc7fec0e8a8112b536 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 6 May 2001 21:19:53 +0000 Subject: [PATCH 1026/2047] (SCM_FUNC_CAST_ARBITRARY_ARGS): Use "SCM (*)()" for C++ as well. "SCM (*)(...)" does not work on RedHat 7.1. --- libguile/snarf.h | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/libguile/snarf.h b/libguile/snarf.h index d6bcaa2be..540c95947 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -52,7 +52,12 @@ #if defined(__cplusplus) || defined(GUILE_CPLUSPLUS_SNARF) -#define SCM_FUNC_CAST_ARBITRARY_ARGS SCM (*)(...) + +/* This used to be "SCM (*)(...)" but GCC on RedHat 7.1 doesn't seem + to like it. + */ +#define SCM_FUNC_CAST_ARBITRARY_ARGS SCM (*)() + #else #define SCM_FUNC_CAST_ARBITRARY_ARGS SCM (*)() #endif From fe7c2f88c2a343c9d87aa74c0dfcd3349efc1dae Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 6 May 2001 21:20:11 +0000 Subject: [PATCH 1027/2047] *** empty log message *** --- libguile/ChangeLog | 3 +++ 1 file changed, 3 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 939d76ce5..137e4e9da 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,8 @@ 2001-05-06 Marius Vollmer + * snarf.h (SCM_FUNC_CAST_ARBITRARY_ARGS): Use "SCM (*)()" for C++ + as well. "SCM (*)(...)" does not work on RedHat 7.1. + * __scm.h (SCM_WTA_DISPATCH_0): Removed ARG and POS parameters, they are not used. Changed `wrong type' error into `wrong num args' error. Changed all callers. From 19a96c8ae4f1d2968742faa06e8373904dfc3fa6 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 6 May 2001 21:35:14 +0000 Subject: [PATCH 1028/2047] New commands: guile-scheme-apropos, guile-scheme-describe, guile-scheme-kill-process. Bug fixed for GNU Emacs 20.7. --- emacs/ChangeLog | 21 ++++++++ emacs/guile-emacs.scm | 21 +++++++- emacs/guile-scheme.el | 116 +++++++++++++++++++++++------------------- emacs/guile.el | 57 ++++++++++++--------- 4 files changed, 138 insertions(+), 77 deletions(-) diff --git a/emacs/ChangeLog b/emacs/ChangeLog index 025a0cd53..2b02bf87f 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,3 +1,24 @@ +2001-05-06 Keisuke Nishida + + * guile.el (guile:eval): Propagate user interrupt. + (keywordp): Define it if not defined yet. + (guile-use-module): New macro. + (guile-process-import-module): Renamed from guile-process-use-module. + + * guile-emacs.scm (guile-emacs-apropos, guile-emacs-describe): + New procedures. + + * guile-scheme.el (guile-scheme-mode-map): Use + `shared-lisp-mode-map' as the parent keymap if + `lisp-mode-shared-map' is not defined. + (guile-scheme-module): New variable. + (guile-scheme-set-module): Set module only when necessary. + (guile-scheme-eval-print-last-sexp): Insert newline after eval. + (guile-scheme-complete-table): New variable. + (guile-scheme-input-symbol): New function. + (guile-scheme-apropos, guile-scheme-describe, + guile-scheme-kill-process): New commands. + 2001-04-25 Keisuke Nishida * guile.el, guile-scheme.el, guile-emacs.scm: New files. diff --git a/emacs/guile-emacs.scm b/emacs/guile-emacs.scm index 995d0d6eb..78b897e31 100644 --- a/emacs/guile-emacs.scm +++ b/emacs/guile-emacs.scm @@ -55,7 +55,7 @@ ;;; -;;; for guile-import and guile-use-modules +;;; for guile-import and guile-import-module ;;; (define (guile-emacs-export-procedure name proc docs) @@ -111,7 +111,7 @@ ;;; -;;; for guile-emacs-complete-symbol +;;; for guile-scheme-complete-symbol ;;; (define (guile-emacs-complete-alist str) @@ -125,6 +125,23 @@ apropos-fold-all) (lambda (p1 p2) (stringstring sym))) -;; (apropos-list ""))) -;; (default (if (assoc symbol table) -;; (string-append " (default " symbol ")") -;; ""))) -;; (string->symbol (completing-read (string-append prompt default ": ") -;; table #f #t #f #f symbol)))) -;; -;; (define-command (guile-scheme-describe symbol) -;; "Display the value and documentation of SYMBOL." -;; (interactive (list (guile-scheme-input-symbol "Describe Guile-Scheme variable"))) -;; (guile-scheme-set-module) -;; (let ((old #^guile-scheme-output-buffer)) -;; (dynamic-wind -;; (lambda () (set! #^guile-scheme-output-buffer #f)) -;; (lambda () -;; (begin-with-output-to-temp-buffer "*Help*" -;; (describe symbol))) -;; (lambda () (set! #^guile-scheme-output-buffer old))))) -;; -;; (define-command (guile-scheme-find-definition symbol) -;; (interactive (list (guile-scheme-input-symbol "Guile-Scheme find definition"))) -;; (guile-scheme-set-module) -;; ) +(guile-import guile-emacs-apropos) + +(defun guile-scheme-apropos (regexp) + (interactive "sGuile Scheme apropos (regexp): ") + (guile-scheme-set-module) + (with-output-to-temp-buffer "*Help*" + (princ (guile-emacs-apropos regexp)))) + +(guile-import guile-emacs-describe) + +(defun guile-scheme-describe (symbol) + (interactive (list (guile-scheme-input-symbol "Describe Guile variable"))) + (guile-scheme-set-module) + (with-output-to-temp-buffer "*Help*" + (princ (guile-emacs-describe symbol)))) + +(defun guile-scheme-kill-process () + (interactive) + (if guile-scheme-adapter + (guile-process-kill guile-scheme-adapter)) + (setq guile-scheme-adapter nil)) + + +;;; +;;; Internal functions +;;; + +(guile-import apropos-internal guile-apropos-internal) + +(defvar guile-scheme-complete-table (make-vector 151 nil)) + +(defun guile-scheme-input-symbol (prompt) + (mapc (lambda (sym) + (if (symbolp sym) + (intern (symbol-name sym) guile-scheme-complete-table))) + (guile-apropos-internal "")) + (let* ((str (thing-at-point 'symbol)) + (default (if (intern-soft str guile-scheme-complete-table) + (concat " (default " str ")") + ""))) + (intern (completing-read (concat prompt default ": ") + guile-scheme-complete-table nil t nil nil str)))) ;;; diff --git a/emacs/guile.el b/emacs/guile.el index 3bf1463ab..efd91fd69 100644 --- a/emacs/guile.el +++ b/emacs/guile.el @@ -63,26 +63,30 @@ ;;;###autoload (defun guile:eval (string adapter) - (let ((output (guile-process-require adapter (concat "eval " string "\n") - "channel> "))) - (cond - ((string= output "") nil) - ((string-match "^\\(\\(value\\)\\|\\(token\\)\\|\\(exception\\)\\) = " - output) - (cond - ;; value - ((match-beginning 2) - (car (read-from-string (substring output (match-end 0))))) - ;; token - ((match-beginning 3) - (cons guile-token-tag - (car (read-from-string (substring output (match-end 0)))))) - ;; exception - ((match-beginning 4) - (signal 'guile-error - (car (read-from-string (substring output (match-end 0)))))))) - (t - (error "Unsupported result" output))))) + (condition-case error + (let ((output (guile-process-require adapter (concat "eval " string "\n") + "channel> "))) + (cond + ((string= output "") nil) + ((string-match "^\\(\\(value\\)\\|\\(token\\)\\|\\(exception\\)\\) = " + output) + (cond + ;; value + ((match-beginning 2) + (car (read-from-string (substring output (match-end 0))))) + ;; token + ((match-beginning 3) + (cons guile-token-tag + (car (read-from-string (substring output (match-end 0)))))) + ;; exception + ((match-beginning 4) + (signal 'guile-error + (car (read-from-string (substring output (match-end 0)))))))) + (t + (error "Unsupported result" output)))) + (quit + (signal-process (process-id adapter) 'SIGINT) + (signal 'quit nil)))) ;;; @@ -95,6 +99,9 @@ (defvar true "#t") (defvar false "#f") +(unless (boundp 'keywordp) + (defun keywordp (x) (and (symbolp x) (eq (aref (symbol-name x) 0) ?:)))) + (defun guile-lisp-adapter () (if (and (processp guile-lisp-adapter) (eq (process-status guile-lisp-adapter) 'run)) @@ -135,10 +142,14 @@ (eval (guile-lisp-eval `(guile-emacs-export ',name ',real ,docs))))) ;;;###autoload -(defmacro guile-import-module (name &rest opts) - `(guile-process-use-module ',name ',opts)) +(defmacro guile-use-module (name) + `(guile-lisp-eval '(use-modules ,name))) -(defun guile-process-use-module (name opts) +;;;###autoload +(defmacro guile-import-module (name &rest opts) + `(guile-process-import-module ',name ',opts)) + +(defun guile-process-import-module (name opts) (unless (boundp 'guile-emacs-export-procedures) (guile-import guile-emacs-export-procedures)) (let ((docs (if (memq :with-docs opts) true false))) From e466c6a2d66a1c1c589da449b2e8f3e07a0ea58f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 6 May 2001 22:14:09 +0000 Subject: [PATCH 1029/2047] (raeql_1): Do not call scm_uniform_vector_length on arrays. The length of array is already determined differently and scm_uniform_vector_length does not work on arrays. --- libguile/ramap.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/libguile/ramap.c b/libguile/ramap.c index 377debc4b..c594828ff 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -1789,7 +1789,7 @@ raeql_1 (SCM ra0,SCM as_equal,SCM ra1) SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; scm_sizet i0 = 0, i1 = 0; long inc0 = 1, inc1 = 1; - scm_sizet n = SCM_INUM (scm_uniform_vector_length (ra0)); + scm_sizet n; ra1 = SCM_CAR (ra1); if (SCM_ARRAYP(ra0)) { @@ -1798,6 +1798,8 @@ raeql_1 (SCM ra0,SCM as_equal,SCM ra1) inc0 = SCM_ARRAY_DIMS (ra0)->inc; ra0 = SCM_ARRAY_V (ra0); } + else + n = SCM_INUM (scm_uniform_vector_length (ra0)); if (SCM_ARRAYP (ra1)) { i1 = SCM_ARRAY_BASE (ra1); From d204b24c16997253c00c651979a0e4faa6d571c8 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 6 May 2001 22:14:25 +0000 Subject: [PATCH 1030/2047] *** empty log message *** --- libguile/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 137e4e9da..10703a28a 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2001-05-07 Marius Vollmer + + * ramap.c (raeql_1): Do not call scm_uniform_vector_length on + arrays. The length of array is already determined differently and + scm_uniform_vector_length does not work on arrays. + 2001-05-06 Marius Vollmer * snarf.h (SCM_FUNC_CAST_ARBITRARY_ARGS): Use "SCM (*)()" for C++ From abc235ad1cd66f8d0670c451a51352bfcdc1e97f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 7 May 2001 18:11:20 +0000 Subject: [PATCH 1031/2047] (gh_lookup): Call gh_module_lookup with `scm_current_module ()', not `#f'. (gh_module_lookup): Expect a module instead of an obarray as first argument and do lookup in that module. --- libguile/gh.h | 2 +- libguile/gh_data.c | 18 +++++++++++++----- 2 files changed, 14 insertions(+), 6 deletions(-) diff --git a/libguile/gh.h b/libguile/gh.h index 7afd5048d..834e4b775 100644 --- a/libguile/gh.h +++ b/libguile/gh.h @@ -185,7 +185,7 @@ SCM gh_uniform_vector_ref (SCM v, SCM ilist); #define gh_vector_to_list(v) scm_vector_to_list(v) SCM gh_lookup (const char *sname); -SCM gh_module_lookup (SCM vector, const char *sname); +SCM gh_module_lookup (SCM module, const char *sname); SCM gh_cons(SCM x, SCM y); #define gh_list scm_listify diff --git a/libguile/gh_data.c b/libguile/gh_data.c index 48361645b..0ee8896a9 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -700,18 +700,26 @@ gh_uniform_vector_ref (SCM v, SCM ilist) SCM gh_lookup (const char *sname) { - return gh_module_lookup (SCM_BOOL_F, sname); + return gh_module_lookup (scm_current_module (), sname); } + SCM -gh_module_lookup (SCM vec, const char *sname) +gh_module_lookup (SCM module, const char *sname) +#define FUNC_NAME "gh_module_lookup" { - SCM sym = gh_symbol2scm (sname); - if (SCM_EQ_P (scm_symbol_bound_p (vec, sym), SCM_BOOL_T)) - return scm_symbol_binding (vec, sym); + SCM sym, cell; + + SCM_VALIDATE_MODULE (SCM_ARG1, module); + + sym = gh_symbol2scm (sname); + cell = scm_sym2vcell (sym, scm_module_lookup_closure (module), SCM_BOOL_F); + if (cell != SCM_BOOL_F) + return SCM_CDR (cell); else return SCM_UNDEFINED; } +#undef FUNC_NAME /* Local Variables: From 438201b47f96a288936a300c61fe9e48be3d931d Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 7 May 2001 18:11:40 +0000 Subject: [PATCH 1032/2047] *** empty log message *** --- libguile/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 10703a28a..2ce8417be 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,10 @@ 2001-05-07 Marius Vollmer + * gh_data.c (gh_lookup): Call gh_module_lookup with + `scm_current_module ()', not `#f'. + (gh_module_lookup): Expect a module instead of an obarray as first + argument and do lookup in that module. + * ramap.c (raeql_1): Do not call scm_uniform_vector_length on arrays. The length of array is already determined differently and scm_uniform_vector_length does not work on arrays. From a080fe396cd0b800c04aeb6bbdcad5c685b61c47 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 7 May 2001 19:29:22 +0000 Subject: [PATCH 1033/2047] * modules/module-snippets.texi: New file, documenting the module system. Placed in `devel' for review purposes. --- devel/ChangeLog | 5 + devel/modules/module-snippets.texi | 734 +++++++++++++++++++++++++++++ 2 files changed, 739 insertions(+) create mode 100644 devel/modules/module-snippets.texi diff --git a/devel/ChangeLog b/devel/ChangeLog index 4760a3aa8..8fd38f050 100644 --- a/devel/ChangeLog +++ b/devel/ChangeLog @@ -1,3 +1,8 @@ +2001-05-07 Martin Grabmueller + + * modules/module-snippets.texi: New file, documenting the module + system. Placed in `devel' for review purposes. + 2001-03-16 Martin Grabmueller * modules: New directory. diff --git a/devel/modules/module-snippets.texi b/devel/modules/module-snippets.texi new file mode 100644 index 000000000..c810db626 --- /dev/null +++ b/devel/modules/module-snippets.texi @@ -0,0 +1,734 @@ +\input texinfo +@c -*-texinfo-*- +@c %**start of header +@setfilename module-snippets.info +@settitle Module Snippets +@iftex +@afourpaper +@end iftex +@c %**end of header + +@set UPDATED 7May 2001 +@set EDITION 0.0.1 +@set VERSION 0.0.1 + +@dircategory Guile +@direntry +* module-snippets: (module-snippets). Documentation for the Guile Module System +@end direntry + + +@c --- title page starts here --- + +@titlepage +@title Module Snippets +@subtitle Documentation for the Guile Module System +@subtitle Version @value{VERSION} +@author Martin Grabmueller + +@c The following two commands +@c start the copyright page. +@page +@vskip 0pt plus 1filll +Copyright @copyright{} 2001 Martin Grabmueller + +Permission is granted to make and distribute verbatim copies of +this manual provided the copyright notice and this permission notice +are preserved on all copies. +@end titlepage + +@c --- title page ends here --- + +@syncodeindex vr cp +@syncodeindex fn cp + +@c =================================================================== + +@node Top, Introduction, (dir), (dir) + +@ifinfo +This file tries to shed some light on Guile's current module system. +@end ifinfo + +@menu +* Introduction:: What is this all about? +* Module Data Type:: Modules from a data-centric view. +* Modules and Evaluation:: Interaction between the module system + and the evaluator. +* Index:: Procedure index. +@end menu + + +@c =================================================================== + +@node Introduction, Module Data Type, Top, Top +@chapter Introduction + +This document contains all information about the module system I have +been able to deduce from the source code or from mailing list +conversation. I have written down everything while trying to figure out +how the Guile module system actually works, and some of the text is +taken from commentary in the file @file{boot-9.scm}. + +The information contained herein is surely not complete, and I will be +happy to receive additions, corrections and suggestions for improving +it. + +Also note that the information contained in this document reflects the +current state as of the time writing, and the facts stated are not +guaranteed to be stable. A complete redesign of the module system is +planned for a long time now, and actually might happen some day. + +There are basically three views on the module system: + +@itemize @bullet +@item +Data-centric: The module as a data type, with all procedures for +creating and manipulating modules. This is documented in the +@ref{Module Data Type}. + +@item +Declarational: How to use declarations like @code{use-modules} or +@code{define-module} for dealing with modules and the scoping mechanisms +they provide. This issue is documented in the Guile Reference Manual, +and will not be covered in detail here. + +@item +Internal: How do the module system and the Guile evaluator interact? +This is documented in @ref{Modules and Evaluation}. +@end itemize + + +@c =================================================================== + +@node Module Data Type, Modules and Evaluation, Introduction, Top +@chapter Module Data Type + +This chapter will describe the module system from the point of the data +type @code{module}. Thus we will first see what this data type looks +like and what operations are defined on it. + +Modules in Guile are instances of a data type @code{module}. A module +has the following fields. + +@table @var +@item obarray +This is a hash table which contains all bindings made in the module. + +@item uses-list +List of the modules imported by the module. A lot of search procedures +search through all modules in this list when a specified binding cannot +be found in the module's obarray. + +@item lazy-binding-proc +A procedure for determining a binding for a module lazily. This is +invoked if a binding for a name is requested from the module, but does +not exist. The procedure can create a new binding, by loading +additional code or fetching it from another module/data structure. + +@item eval-closure +A procedure for determining a binding in a module. The evaluator uses +this procedure for accessing top-level variables. + +@item transformer +The syntax transformer used for all evaluations in the module. + +@item name +The name of the module. This is a list of symbols, such as +@code{(guile)} or @code{(ice-9 popen)}. + +@item kind +A symbol describing the type of the module. Normal modules are of type +@code{module}, interfaces are of type @code{interface} and directories +(modules which implement the hierarchical namespace) are of kind +@code{directory}). Autoload modules (placeholder for not-yet-loaded +modules) are of type @code{autoload}. FIXME: Are there other types? + +@item observers +A list of procedures to call when one of the module's bindings is +removed or modified or a new binding is created. + +@item weak-observers +Similar to @var{observers}, but this is a hash table from which the +observer procedures will magically disappear when there are no other +references to the procedure left except from the module they observe. + +@item observer-id +This is an integer, which specifies the identifer the next weak observer +will get. It is incremented each time a weak observer is added. +@end table + +@menu +* The Data Type:: The data type @code{module}. +* Module Loading:: How to load modules. +* Modules and Variables:: How do variables and modules relate. +* Iterating over Module Bindings:: How to access all bindings of a module. +* The Lazy Binder:: The lazy binding procedures. +* Module Observers:: The observer protocol. +* The Current Module:: Notion of ``current module'' in Guile. +* High-Level Module Access:: High-level access to module features. +* Recursive Namespaces:: Hierarchical organisation of namespaces. +* Module Hierarchy:: The currently implemented hierarchy. +* Modules and Interfaces:: How modules implement different scopes. +* Modules and Environments:: Relation between modules and environments. +* Modules Miscallenea:: Miscellaneous module procedures. +@end menu + + +@c =================================================================== + +@node The Data Type, Module Loading, Module Data Type, Module Data Type +@section The Data Type + +A new module is created using @code{make-module}. Several procedures +are defined for accessing the members of a module. + +@deffn procedure make-module size uses-list lazy-binding-proc +Create a new module and initialize its fields with the parameters. + +@table @var +@item size +Size of the module's obarray. + +@item uses-list +List of the modules imported by the module. + +@item lazy-binding-proc +The procedure for determining a binding for a module lazily. +@end table +@end deffn + +The various fields of a module can be accessed and modified using the +following procedures: + +@deffn procedure module-obarray module +@deffnx procedure set-module-obarray! module obj +@deffnx procedure module-uses module +@deffnx procedure set-module-uses! module obj +@deffnx procedure module-binder module +@deffnx procedure set-module-binder! module obj +@deffnx procedure module-eval-closure module +@deffnx procedure set-module-eval-closure! module obj +@deffnx procedure module-transformer module +@deffnx procedure set-module-transformer! module obj +@deffnx procedure module-name module +@deffnx procedure set-module-name! module obj +@deffnx procedure module-kind module +@deffnx procedure set-module-kind! module obj +@deffnx procedure module-observers module +@deffnx procedure set-module-observers! module obj +@deffnx procedure module-weak-observers module +@deffnx procedure module-observer-id module +@deffnx procedure set-module-observer-id! module obj +Read the corresponding member of @var{module}, or write the value +@var{obj} into the slot. +@end deffn + +@deffn procedure module? obj +This is the type predicate for modules, which will return @code{#t} if +its argument is a module, and @code{#f} otherwise. +@end deffn + +@deffn procedure make-scm-module +This will create a module which represents Guile's builtin bindings. +Initially, it is empty, but when variable lookups are made in it, the +requested bindings will get copied into the module from the internal +obarray. Bindings will get copied even if only accessed. +@end deffn + +@deffn procedure make-root-module +Create a new module which works on the internal obarrary. The +difference to the modules returned by @code{make-scm-module} is that +bindings are only copied to the obarray if they are explicitly defined. +@end deffn + + +@c =================================================================== + +@node Module Loading, Modules and Variables, The Data Type, Module Data Type +@section Module Loading + +The normal way of loading modules in Scheme programs is to use the +special form @code{use-modules}, which loads the source of one or more +specified modules and imports their public bindings into the current +module. This procedure is documented in the Guile Reference Manual, so +I will not go into details here. This section rather contains the +underlying mechanisms, on which @code{use-modules} is built. + +Normally, you will not need to create new modules explicitly, adding +definitions to it manually. For more often, you will want to load some +Scheme code from a file, and install its definitions into a module, only +exporting the public bits. This is what the procedure +@code{resolve-module} is for. + +@deffn procedure resolve-module name [maybe-autoload] +If the module @var{name} already exists, return it. Otherwise, try to +load the Scheme code for @var{name} into a newly created module, adding +the exports to the public interface. + +The parameter @var{maybe-autoload} controls the behaviour when the +module code is going to be loaded. + +@table @asis +@item @var{maybe-autoload} == @code{#f} +Do not defer loading. + +@item @var{maybe-autoload} == @code{#t} +Defer loading of the source code until a binding from the module is +requested. + +@item @var{maybe-autoload} not given +Like @var{maybe-autoload} == @code{#t}. +@end table +@end deffn + + +@c =================================================================== + +@node Modules and Variables, Iterating over Module Bindings, Module Loading, Module Data Type +@section Modules and Variables + +Modules can be regarded as mappings from symbols (variable names) to +bindings (variable locations). The procedures documented in this +section can be used to test whether such a mapping exists for a given +variable name, how to add mappings and how to retrieve a variables +value. + +We sometimes want to look for properties of a symbol just within the +obarray of one module. If the property holds, then it is said to hold +``locally'' as in, ``The symbol @code{display} is locally rebound in the +module @code{safe-guile}.'' + +Other times, we want to test for a symbol property in the obarray of +@var{m} and, if it is not found there, try each of the modules in the +uses list of @var{m}. This is the normal way of testing for some +property, so we state these properties without qualification as in: +``The symbol 'fnord is interned in module M because it is interned +locally in module @var{m2} which is a member of the uses list of +@var{m}.'' + +@deffn procedure module-locally-bound? module sym +Test if @var{sym} is bound in @var{module} directly, e.g. it does not +suffice that @var{sym} is bound in one of the used modules of +@var{module}. @dfn{Bound} means that the symbol is interned and bound +to some well-defined value. +@end deffn + +@deffn procedure module-bound? module sym +Return true if @var{sym} is bound in @var{module} or one of the modules +in @var{module}'s uses list. The search looks in all transitively used +modules. @dfn{Bound} means that the symbol is interned and bound to +some well-defined value. +@end deffn + +@deffn procedure module-symbol-locally-interned? module sym +Test if @var{sym} is interned in @var{module} directly, e.g. it does not +suffice that @var{sym} is bound in one of the used modules of +@var{module}. Unlike @code{module-locally-bound}, the symbol is not +required to be bound to a well-defined value. +@end deffn + +@deffn procedure module-symbol-interned? module sym +Return true if @var{sym} is interned in @var{module} or one of the +modules in @var{module}'s uses list. The search looks in all +transitively used modules. Unlike @code{module-bound}, the symbol is +not required to be bound to a well-defined value. +@end deffn + +@deffn procedure module-local-variable module sym +Return a variable object for @var{SYM} in the module @var{module}, or +@code{#f} if no such symbol is defined in @var{module}. If the symbols +is not found at first, but the module has a lazy binder, then try the +binder. +@end deffn + +@deffn procedure module-variable module sym +Return a variable object for @var{sym} in the module @var{module} or one +of its used modules, or @code{#f} if no such symbol is defined in +@var{module} or its uses. +@end deffn + +@deffn procedure module-symbol-local-binding module symbol [opt-value] +Return the value of the binding called @var{symbol} in @var{module}, or +@var{opt-val} if no such binding exists. If no @var{opt-value} is given +and no binding exists, an error is thrown. +@end deffn + +@deffn procedure module-symbol-binding module symbol [opt-value] +Return the value of the binding called @var{symbol} in @var{module}, or +@var{opt-val} if no such binding exists. If no @var{opt-value} is given +and no binding exists, an error is thrown. Unlike +@code{module-symbol-local-binding}, this will search all used modules as +well as @var{module}. +@end deffn + +@deffn procedure module-make-local-var! module symbol +Create a binding for a variable called @var{symbol} in @var{module} and +return the variable object representing the new location in the module. +If @var{symbol} is already defined in @var{module}, nothing happens. +@end deffn + +@deffn procedure module-add! module symbol var +Add the variable @var{var} to @var{module} under the name @var{symbol}. +@end deffn + +@deffn procedure module-remove! module symbol +Remove the binding for @var{symbol} in @var{module}. The return value +is not specified. +@end deffn + +@deffn procedure module-clear! module +Remove all bindings from @var{module}. +@end deffn + + +@c =================================================================== + +@node Iterating over Module Bindings, The Lazy Binder, Modules and Variables, Module Data Type +@section Iterating over Module Bindings + +@deffn procedure module-for-each proc module +Apply @var{proc} to every binding in @var{module}. @var{proc} is called +with two parameters, the name and variable for each binding. +@end deffn + +@deffn procedure module-map proc module +Apply @var{proc} to every binding in @var{module} and return a list of +the results of all applications of @var{proc}. @var{proc} is called +with two parameters, the name and variable for each binding. +@end deffn + + +@c =================================================================== + +@node The Lazy Binder, Module Observers, Iterating over Module Bindings, Module Data Type +@section The Lazy Binder + +The lazy binding procedures which are connected to modules are invoked +every time a binding is searched in a module, but is not present. A +binder is called with three arguments. + +When a lazy binder returns a variable object, the search is successful +and the return value will be used. If the return value is @code{#f}, +the search is continued in the modules from the uses list. FIXME: Is +this always the case or only in the standard eval closure? + +@table @var +@item module +The module for which the binding is requested. + +@item symbol +The name of the searched symbol. + +@item define? +@code{#t} if the binding should be defined, @code{#f} otherwise. +@end table + + +@c =================================================================== + +@node Module Observers, The Current Module, The Lazy Binder, Module Data Type +@section Module Observers + +A module can have a number of @dfn{observers} attached. These are +procedures which are called whenever something withing the module +changes. This can be the creation, deletion or modification of a +binding. + +When a change occurs, the procedure @code{module-modified} (documented +below in this section) will be called which in turn will apply all +observer procedures to the modified module. + +@deffn procedure module-observe module proc +Add the observer @var{proc} to @var{module} and return a pair of +@var{module} and @var{proc}. The returned value can be used with +@code{module-unobserve}. +@end deffn + +@deffn procedure module-observe-weak module proc +Add @var{proc} as a weak observer to @var{module} and erturn a pair of +@var{module} and a unique integer, the observer ID. The returned value +can be used with @code{module-unobserve}. +@end deffn + +@deffn procedure module-unobserve token +Remove an observer from a module. The module and the observer to be +removed are taken from @var{token}, which must be returned by +@code{module-observe} or @code{module-unobserve}. +@end deffn + +@deffn procedure module-modified m +Signal a modification of module @var{m} to all associated observers. +@end deffn + + + +@c =================================================================== + +@node The Current Module, High-Level Module Access, Module Observers, Module Data Type +@section The Current Module + +For all evaluations, Guile maintains a so-called @dfn{current +module}.@footnote{A current module does not exist until Guile has been +completely booted, that means until @file{boot-9.scm} has been loaded. +But this should be no issue unless you are doing weird things withe the +module system, which might be a bad idea, but YMMV.} This is used for +all top-level definitions and variable lookups. When the current module +changes, new definitions will go to the new module. The procedures in +this section manipulate the notion of the current module. + +The current module is also used when C code calls @code{scm_make_gsubr} +for creating new primitives or @code{scm_sysintern} for interning +symbols. From C, the current module can be set by calling +@code{scm_set_current_module}, which will return the old module. This +returned module can later be used to switch back to the old module after +creating a new one and installing bindings there. + + +@deffn procedure set-current-module module +Make @var{module} the current module, into which all following +definitions will go. Return the old module in effect before the call to +@code{set-current-module}. +@end deffn + +@deffn procedure current-module +Return the module which is currently registered as the @dfn{current +module}. +@end deffn + + + +@c =================================================================== + +@node High-Level Module Access, Recursive Namespaces, The Current Module, Module Data Type +@section High-Level Module Access + +The procedure in the previous chapter are not for general use. The +current chapter will document all procedures which are meant to be used +by users who need to work with modules. + +The parameter @var{module} in the following descriptions must be a +module, @var{name} must be a symbol (which most probably will need to be +quoted). + +@deffn procedure module-ref module name [default] +Return the value of a variable called @var{name} in @var{module} or any +of its used modules. If there is no such variable, then if the optional +third argument @var{default} is present, it is returned; otherwise an +error is signaled. +@end deffn + +@deffn procedure module-set! module name value +Sets the variable called @var{name} in @var{module} (or in a module that +@var{module} uses) to @var{value}; if there is no such variable, an +error is signaled. +@end deffn + +@deffn procedure module-define! module name value +Sets the variable called @var{name} in @var{module} to @var{value}; if +there is no such variable, it is added first. +@end deffn + +@deffn procedure module-defined? module name +Return @code{#t} if @var{name} is defined in @var{module} (or in a +module that @var{module} uses). +@end deffn + +@deffn procedure module-use! module interface +Add @var{interface} to the list of interfaces used by @var{module}. For +information what an @dfn{interface} is, see @ref{Modules and +Interfaces}. +@end deffn + +@deffn procedure module-export! module names +Add all variables from @var{names} (a list of symbols) to the public +interface of @var{module} (@pxref{Modules and Interfaces}). +@end deffn + +@c =================================================================== + +@node Recursive Namespaces, Module Hierarchy, High-Level Module Access, Module Data Type +@section Recursive Namespaces + +A hierarchical namespace emerges if we consider some module to be root, +and variables bound to modules as nested namespaces. + +The modules which implement the internal nodes are of kind +@code{directory}. FIXME: Is this correct? + +The routines in this chapter manage variable names in hierarchical +namespace. Each variable name is a list of elements, looked up in +successively nested modules. + +@example +(nested-ref some-root-module '(foo bar baz)) +@result{} + +@end example + +@deffn procedure nested-ref root names +Look up the variable identified by the symbol list @var{names}, starting +in the module @var{root}. +@end deffn + +@deffn procedure nested-set! root names val +Set the variable identified by the symbol list @var{names} to @var{val}, +starting the variable lookup in module @var{root}. The return value is +not specified. +@end deffn + +@deffn procedure nested-define! root names val +Set the variable identified by the symbol list @var{names} to @var{val}, +starting the variable lookup in module @var{root}. If the variable does +not exist, create it before setting its value. The return value is not +specified. +@end deffn + +@deffn procedure nested-remove! root names +Remove the variable identified by the symbol list @var{names}, starting +the variable lookup in module @var{root}. The return value is not +specified. +@end deffn + +@deffn procedure local-ref names +@deffnx procedure local-set! names val +@deffnx procedure local-define! names val +@deffnx procedure local-remove! names +Like the @code{nested-ref}, @code{nested-set!}, @code{nested-define!} +and @code{nested-remove!} procedures above, but start the variable +lookup in the module returned by @code{current-module}. +@end deffn + + +@c =================================================================== + +@node Module Hierarchy, Modules and Interfaces, Recursive Namespaces, Module Data Type +@section Module Hierarchy + +Currently, the following entries are defined in the hierarchical +namespace. + +@table @code +@item (app) +This is the root of all named objects which are not in the top level. + +@item (app modules) +This is the directory of all modules. + +@item (app modules guile) +This is the standard root module. +@end table + +User modules which are loaded into Guile as well as the modules shipped +with the Guile distribution are installed under @code{(app modules)} as +well. + + +@c =================================================================== + +@node Modules and Interfaces, Modules and Environments, Module Hierarchy, Module Data Type +@section Modules and Interfaces + +Interfaces are modules of kind @code{interface}. They always belong to +another module and contain the bindings which are exported from that +module. Interfaces are the means by which the different scopes of a +module (private vs. public bindings) are implemented. + +Every module can define a special variable called +@code{%module-public-interface}, which is bound to the module's +interface. + +Whenever a variable is exported (with the @code{export} form or the +@code{:export} keyword in the @code{define-module} form), this variable +is added to the defining module's interface. Because importing a module +means adding other modules' interfaces to the uses list, the exported +variables become visible in the importing module. + +@deffn procedure module-public-interface m +Return the public interface of module @var{m}, or @code{#f} if @var{m} +does not have a public interface. +@end deffn + +@deffn procedure set-module-public-interface! m i +Set the public interface of the module @var{m} to @var{i}. +@end deffn + + +@c =================================================================== + +@node Modules and Environments, Modules Miscallenea, Modules and Interfaces, Module Data Type +@section Modules and Environments + +An environment belongs to a specific module, which can be determined by +calling @code{environment-module}. + +@deffn procedure environment-module env +@end deffn + + +@c =================================================================== + +@node Modules Miscallenea, , Modules and Environments, Module Data Type +@section Modules Miscallenea + +This chapter contains all miscellaneous information and procedure +documentation which I have not been able to include elsewhere. If +someone knows how to include them into other chapters, suggestions are +welcome. + +@deffn procedure set-system-module! m s +Set the @code{system-module} property of the module @var{m} to @var{s}. +@var{s} should be a module telling whehter @var{m} is a system module or +not. System modules are treated specially in some cases, for example +procedures defined in system modules are excluded from backtraces. +FIXME: Is this last sentence true? +@end deffn + + +@c =================================================================== + +@node Modules and Evaluation, Index, Module Data Type, Top +@chapter Modules and Evaluation + +Up to here, we have seen how modules are implemented as a data type, +which can be manipulated by C and Scheme code to implement module system +work like providing private and public name spaces, loading of modules +and creating new modules. + +This chapter will describe the connection between the module system and +the Guile evaluator. Top-level variables (that is, variables not +lexically bound) need to be resolved in the current module, and if not +defined there, in the used modules, and so on, until the root module has +been asked for the bindings. + +First, we have to recall how Guile normally figures out the location for +a given variable when evaluating a form. The evaluator starts by +scanning the lexical environment it maintains. It first looks in each +slot in the top-most environment frame, continuing in the next frame and +so on, until it reaches the end of the lexical environment chain. + +The @sc{car} of the last pair of the environment chain is either +@code{#f}, or it is a procedure. When it is @code{#f}, the normal +system obarray is searched for the variable, otherwise the procedure is +called for returning the requested variable. This procedure is the +current module's @dfn{eval closure}, and is responsible for searching a +variable's binding, installing it if necessary. + +When a variable is finally found, the reference to the variable in the +currently executed Scheme code is replaced by a special value (a +so-called @code{gloc}), so that this environment search is not necessary +the next time the variable is looked up. + + +@c =================================================================== + +@node Index, , Modules and Evaluation, Top +@comment node-name, next, previous, up +@unnumbered Index + +@printindex cp + +@contents + +@bye From 75141eb0c18b65ddb19cf3610135159976629852 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Mon, 7 May 2001 21:38:13 +0000 Subject: [PATCH 1034/2047] * Add docs-related authorship information. --- AUTHORS | 65 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ ChangeLog | 4 ++++ 2 files changed, 69 insertions(+) diff --git a/AUTHORS b/AUTHORS index 1c66eb486..306e5dbfe 100644 --- a/AUTHORS +++ b/AUTHORS @@ -22,10 +22,18 @@ In the subdirectory libguile, wrote: Gary Houston: changes to many files in libguile. In the subdirectory ice-9, wrote: expect.scm networking.scm popen.scm posix.scm +In the subdirectory doc, changes to: + data-rep.texi expect.texi guile-tut.texi + posix.texi r5rs.texi scheme-io.texi Jim Blandy: Many changes throughout. In the subdirectory libguile, wrote: script.c (partially) +In the subdirectory doc, wrote: + data-rep.texi env.texi mbapi.texi + mltext.texi hacks.el +In the subdirectory doc/example-smob, wrote: + image-type.c image-type.h myguile.c Tom Lord: Many changes throughout. In the subdirectory ice-9, wrote: @@ -51,6 +59,11 @@ In the subdirectory libguile, wrote: In the subdirectory libguile, rewrote: coop-threads.c coop.c mit-pthreads.c threads.c print.c coop-threads.h fsu-pthreads.h mit-pthreads.h threads.h print.h +In the subdirectory doc, wrote: + goops-tutorial.texi hierarchy.eps + hierarchy.txt mop.txt oldfmt.c +In the subdirectory doc, changes to: + data-rep.texi gh.texi goops.texi Many other changes throughout. Mark Galassi: @@ -60,6 +73,8 @@ subdirectory libguile, wrote: gh.h gh_funcs.c gh_list.c gh_test_repl.c gh_data.c gh_init.c gh_predicates.c gh_eval.c gh_io.c gh_test_c.c +In the subdirectory doc, wrote: + appendices.texi gh.texi guile-tut.texi Marius Vollmer: In the subdirectory libguile, wrote: @@ -68,6 +83,9 @@ In the subdirectory libguile, wrote: In the subdirectory libguile, rewrote: dynl.c dynl-dl.c dynl-shl.c dynl.h dynl-dld.c +In the subdirectory doc, changes to: + data-rep.texi intro.texi posix.texi + scheme-modules.texi R. Kent Dybvig: In the subdirectory ice-9, wrote: @@ -91,6 +109,8 @@ Tim Pierce: In the subdirectory libguile, wrote: regex-posix.c regex-posix.h +In the subdirectory doc, changes to: + appendices.texi posix.texi Rob Browning: wrote initial srfi/srfi-2.scm. @@ -108,9 +128,54 @@ In the subdirectory srfi, wrote: srfi-13.c srfi-14.c In the subdirectory doc, wrote: + script-getopt.texi srfi-modules.texi srfi-13-14.texi repl-modules.texi +In the subdirectory doc, changes to: + guile.texi intro.texi posix.texi + scheme-binding.texi scheme-control.texi + scheme-data.texi scheme-evaluation.texi + scheme-indices.texi scheme-io.texi + scheme-memory.texi scheme-modules.texi + scheme-options.texi scheme-procedures.texi + scheme-scheduling.texi scheme-utility.texi Will Fitzgerald: wrote initial srfi/srfi-19.scm. + +Dirk Herrmann: +In the subdirectory doc, changes to: + data-rep.texi + scm.texi + +Greg Badros: +In the subdirectory doc, changes to: + data-rep.texi + +Neil Jerram: +In the subdirectory ice-9, wrote: + buffered-input.scm +In the subdirectory doc, wrote: + deprecated.texi goops.texi scheme-ideas.texi + scheme-reading.texi +In the subdirectory doc, changes to: + appendices.texi data-rep.texi expect.texi + extend.texi gh.texi guile-tut.texi + guile.texi indices.texi intro.texi + posix.texi preface.texi r5rs.texi + scheme-binding.texi scheme-modules.texi + scheme-control.texi scheme-data.texi + scheme-debug.texi scheme-evaluation.texi + scheme-ideas.texi scheme-indices.texi + scheme-intro.texi scheme-io.texi + scheme-memory.texi scheme-options.texi + scheme-procedures.texi scheme-scheduling.texi + scheme-translation.texi scheme-utility.texi + scm.texi scripts.texi script-getopt.texi +In the subdirectory doc/maint, wrote: + docstring.el + +Thien Thi Nguyen: +In the subdirectory doc, changes to: + preface.texi scheme-scheduling.texi diff --git a/ChangeLog b/ChangeLog index ce5cd84a7..39e343d44 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2001-05-07 Neil Jerram + + * AUTHORS: Add docs-related authorship details. + 2001-05-05 Marius Vollmer * configure.in (--enable-deprecated): Recognize "shutup" option From df937d20e01d0a1de561aec6ff2dbaa865b85851 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 7 May 2001 21:52:25 +0000 Subject: [PATCH 1035/2047] * tests/srfi-13.test: New file testing the SRFI string library. --- test-suite/ChangeLog | 4 + test-suite/tests/srfi-13.test | 332 ++++++++++++++++++++++++++++++++++ 2 files changed, 336 insertions(+) create mode 100644 test-suite/tests/srfi-13.test diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index d9d83f8a8..619cf4906 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2001-05-07 Martin Grabmueller + + * tests/srfi-13.test: New file testing the SRFI string library. + 2001-04-26 Gary Houston * tests/r4rs.test: delete files tmp1, tmp2, tmp3 after the tests diff --git a/test-suite/tests/srfi-13.test b/test-suite/tests/srfi-13.test new file mode 100644 index 000000000..1c345c8ff --- /dev/null +++ b/test-suite/tests/srfi-13.test @@ -0,0 +1,332 @@ +;;;; srfi-13.test --- Test suite for Guile's SRFI-13 functions. -*- scheme -*- +;;;; Martin Grabmueller, 2001-05-07 +;;;; +;;;; Copyright (C) 2001 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +(use-modules (srfi srfi-13)) + +(define exception:strict-infix-grammar + (cons 'misc-error "^strict-infix")) + +(with-test-prefix "string-any" + + (pass-if "no match" + (not (string-any char-upper-case? "abcde"))) + + (pass-if "one match" + (string-any char-upper-case? "abCde")) + + (pass-if "more than one match" + (string-any char-upper-case? "abCDE")) + + (pass-if "no match, start index" + (not (string-any char-upper-case? "Abcde" 1))) + + (pass-if "one match, start index" + (string-any char-upper-case? "abCde" 1)) + + (pass-if "more than one match, start index" + (string-any char-upper-case? "abCDE" 1)) + + (pass-if "no match, start and end index" + (not (string-any char-upper-case? "AbcdE" 1 4))) + + (pass-if "one match, start and end index" + (string-any char-upper-case? "abCde" 1 4)) + + (pass-if "more than one match, start and end index" + (string-any char-upper-case? "abCDE" 1 4))) + +(with-test-prefix "string-every" + + (pass-if "no match at all" + (not (string-every char-upper-case? "abcde"))) + + (pass-if "not all match" + (not (string-every char-upper-case? "abCDE"))) + + (pass-if "all match" + (string-every char-upper-case? "ABCDE")) + + (pass-if "no match at all, start index" + (not (string-every char-upper-case? "Abcde" 1))) + + (pass-if "not all match, start index" + (not (string-every char-upper-case? "ABcde" 1))) + + (pass-if "all match, start index" + (string-every char-upper-case? "aBCDE" 1)) + + (pass-if "no match at all, start and end index" + (not (string-every char-upper-case? "AbcdE" 1 4))) + + (pass-if "not all match, start and end index" + (not (string-every char-upper-case? "ABcde" 1 4))) + + (pass-if "all match, start and end index" + (string-every char-upper-case? "aBCDe" 1 4))) + +(with-test-prefix "string-tabulate" + + (pass-if "static fill-char" + (string=? (string-tabulate (lambda (idx) #\!) 10) "!!!!!!!!!!")) + + (pass-if "variable fill-char" + (string=? (string-tabulate + (lambda (idx) (integer->char (+ idx 32))) 10) " !\"#$%&'()"))) + + +(with-test-prefix "string->list" + + (pass-if "empty" + (zero? (length (string->list "")))) + + (pass-if "nonempty" + (= (length (string->list "foo")) 3)) + +;;; FIXME: These do not work, because the standard definition is used, +;;; apparently. +; (pass-if "empty, start index" +; (zero? (length (string->list "foo" 3 3)))) + +; (pass-if "nonempty, start index" +; (= (length (string->list "foo" 2)) 1 3)) + ) + +(with-test-prefix "reverse-list->string" + + (pass-if "empty" + (string-null? (reverse-list->string '()))) + + (pass-if "nonempty" + (string=? "foo" (reverse-list->string '(#\o #\o #\f))))) + + +(with-test-prefix "string-join" + + (pass-if "empty list, no delimiter, implicit infix, empty 1" + (string=? "" (string-join '()))) + + (pass-if "empty string, no delimiter, implicit infix, empty 2" + (string=? "" (string-join '("")))) + + (pass-if "non-empty, no delimiter, implicit infix" + (string=? "bla" (string-join '("bla")))) + + (pass-if "empty list, implicit infix, empty 1" + (string=? "" (string-join '() "|delim|"))) + + (pass-if "empty string, implicit infix, empty 2" + (string=? "" (string-join '("") "|delim|"))) + + (pass-if "non-empty, implicit infix" + (string=? "bla" (string-join '("bla") "|delim|"))) + + (pass-if "non-empty, implicit infix" + (string=? "bla" (string-join '("bla") "|delim|"))) + + (pass-if "two strings, implicit infix" + (string=? "bla|delim|fasel" (string-join '("bla" "fasel") "|delim|"))) + + (pass-if "empty, explicit infix" + (string=? "" (string-join '("") "|delim|" 'infix))) + + (pass-if "empty list, explicit infix" + (string=? "" (string-join '() "|delim|" 'infix))) + + (pass-if "non-empty, explicit infix" + (string=? "bla" (string-join '("bla") "|delim|" 'infix))) + + (pass-if "two strings, explicit infix" + (string=? "bla|delim|fasel" (string-join '("bla" "fasel") "|delim|" + 'infix))) + + (pass-if-exception "empty list, strict infix" + exception:strict-infix-grammar + (string-join '() "|delim|" 'strict-infix)) + + (pass-if "empty, strict infix" + (string=? "" (string-join '("") "|delim|" 'strict-infix))) + + (pass-if "non-empty, strict infix" + (string=? "foo" (string-join '("foo") "|delim|" 'strict-infix))) + + (pass-if "two strings, strict infix" + (string=? "foo|delim|bar" (string-join '("foo" "bar") "|delim|" + 'strict-infix))) + + (pass-if "empty list, prefix" + (string=? "" (string-join '() "|delim|" 'prefix))) + + (pass-if "empty, prefix" + (string=? "|delim|" (string-join '("") "|delim|" 'prefix))) + + (pass-if "non-empty, prefix" + (string=? "|delim|foo" (string-join '("foo") "|delim|" 'prefix))) + + (pass-if "two strings, prefix" + (string=? "|delim|foo|delim|bar" (string-join '("foo" "bar") "|delim|" + 'prefix))) + + (pass-if "empty list, suffix" + (string=? "" (string-join '() "|delim|" 'suffix))) + + (pass-if "empty, suffix" + (string=? "|delim|" (string-join '("") "|delim|" 'suffix))) + + (pass-if "non-empty, suffix" + (string=? "foo|delim|" (string-join '("foo") "|delim|" 'suffix))) + + (pass-if "two strings, suffix" + (string=? "foo|delim|bar|delim|" (string-join '("foo" "bar") "|delim|" + 'suffix)))) + + +(with-test-prefix "string-copy" + + (pass-if "empty string" + (string=? "" (string-copy ""))) + + (pass-if "full string" + (string=? "foo-bar" (string-copy "foo-bar"))) + +;;; FIXME: These do not work, because the standard definition is used, +;;; apparently. +; (pass-if "start index" +; (string=? "o-bar" (string-copy "foo-bar" 2))) + +; (pass-if "start and end index" +; (string=? "o-ba" (string-copy "foo-bar" 2 6))) +) + +(with-test-prefix "substring/shared" + + (pass-if "empty string" + (eq? "" (substring/shared "" 0))) + + (pass-if "non-empty string" + (string=? "foo" (substring/shared "foo-bar" 0 3))) + + (pass-if "non-empty string, not eq?" + (string=? "foo-bar" (substring/shared "foo-bar" 0 7)))) + +(with-test-prefix "string-copy!" + + (pass-if "non-empty string" + (string=? "welld, oh yeah!" + (let* ((s "hello") + (t "world, oh yeah!")) + (string-copy! t 1 s 1 3) + t)))) + +(with-test-prefix "string-take" + + (pass-if "empty string" + (string=? "" (string-take "foo bar braz" 0))) + + (pass-if "non-empty string" + (string=? "foo " (string-take "foo bar braz" 4))) + + (pass-if "full string" + (string=? "foo bar braz" (string-take "foo bar braz" 12)))) + +(with-test-prefix "string-take-right" + + (pass-if "empty string" + (string=? "" (string-take-right "foo bar braz" 0))) + + (pass-if "non-empty string" + (string=? "braz" (string-take-right "foo bar braz" 4))) + + (pass-if "full string" + (string=? "foo bar braz" (string-take-right "foo bar braz" 12)))) + +(with-test-prefix "string-drop" + + (pass-if "empty string" + (string=? "" (string-drop "foo bar braz" 12))) + + (pass-if "non-empty string" + (string=? "braz" (string-drop "foo bar braz" 8))) + + (pass-if "full string" + (string=? "foo bar braz" (string-drop "foo bar braz" 0)))) + +(with-test-prefix "string-drop-right" + + (pass-if "empty string" + (string=? "" (string-drop-right "foo bar braz" 12))) + + (pass-if "non-empty string" + (string=? "foo " (string-drop-right "foo bar braz" 8))) + + (pass-if "full string" + (string=? "foo bar braz" (string-drop-right "foo bar braz" 0)))) + +(with-test-prefix "string-pad" + + (pass-if "empty string, zero pad" + (string=? "" (string-pad "" 0))) + + (pass-if "empty string, zero pad, pad char" + (string=? "" (string-pad "" 0))) + + (pass-if "empty pad string, 2 pad " + (string=? " " (string-pad "" 2))) + + (pass-if "empty pad string, 2 pad, pad char" + (string=? "!!" (string-pad "" 2 #\!))) + + (pass-if "empty pad string, 2 pad, pad char, start index" + (string=? "!c" (string-pad "abc" 2 #\! 2))) + + (pass-if "empty pad string, 2 pad, pad char, start and end index" + (string=? "!c" (string-pad "abcd" 2 #\! 2 3))) + + (pass-if "freestyle 1" + (string=? "32" (string-pad (number->string 532) 2 #\!))) + + (pass-if "freestyle 2" + (string=? "!532" (string-pad (number->string 532) 4 #\!)))) + +(with-test-prefix "string-pad-right" + + (pass-if "empty string, zero pad" + (string=? "" (string-pad-right "" 0))) + + (pass-if "empty string, zero pad, pad char" + (string=? "" (string-pad-right "" 0))) + + (pass-if "empty pad string, 2 pad " + (string=? " " (string-pad-right "" 2))) + + (pass-if "empty pad string, 2 pad, pad char" + (string=? "!!" (string-pad-right "" 2 #\!))) + + (pass-if "empty pad string, 2 pad, pad char, start index" + (string=? "c!" (string-pad-right "abc" 2 #\! 2))) + + (pass-if "empty pad string, 2 pad, pad char, start and end index" + (string=? "c!" (string-pad-right "abcd" 2 #\! 2 3))) + + (pass-if "freestyle 1" + (string=? "53" (string-pad-right (number->string 532) 2 #\!))) + + (pass-if "freestyle 2" + (string=? "532!" (string-pad-right (number->string 532) 4 #\!)))) + From 2abe254daca370fecf3e06244c01e828c48fec1a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 7 May 2001 22:27:29 +0000 Subject: [PATCH 1036/2047] * srfi-13.c (scm_string_copyS): Fixed nasty bug. --- srfi/ChangeLog | 4 ++++ srfi/srfi-13.c | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index b64ea9d23..9e8779ccd 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,7 @@ +2001-05-08 Martin Grabmueller + + * srfi-13.c (scm_string_copyS): Fixed nasty bug. + 2001-05-05 Rob Browning * Makefile.am (srfi_DATA): added srfi-19.scm. diff --git a/srfi/srfi-13.c b/srfi/srfi-13.c index e7fe76c57..41adb596b 100644 --- a/srfi/srfi-13.c +++ b/srfi/srfi-13.c @@ -379,7 +379,7 @@ SCM_DEFINE (scm_string_copyS, "string-copy", 1, 2, 0, SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, 2, start, cstart, 3, end, cend); - return scm_makfromstr (cstr + start, cend - cstart, 0); + return scm_makfromstr (cstr + cstart, cend - cstart, 0); } #undef FUNC_NAME From db69b3a7b79f9dfca3c0d06f9cc22fc9672c97ac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Tue, 8 May 2001 06:03:03 +0000 Subject: [PATCH 1037/2047] * modules/module-snippets.texi: Fixed a lot of typos and clarified some points. Thanks to Neil for the typo+questions patch! --- devel/ChangeLog | 5 + devel/modules/module-snippets.texi | 734 ----------------------------- 2 files changed, 5 insertions(+), 734 deletions(-) diff --git a/devel/ChangeLog b/devel/ChangeLog index 8fd38f050..4cefcf50a 100644 --- a/devel/ChangeLog +++ b/devel/ChangeLog @@ -1,3 +1,8 @@ +2001-05-08 Martin Grabmueller + + * modules/module-snippets.texi: Fixed a lot of typos and clarified + some points. Thanks to Neil for the typo+questions patch! + 2001-05-07 Martin Grabmueller * modules/module-snippets.texi: New file, documenting the module diff --git a/devel/modules/module-snippets.texi b/devel/modules/module-snippets.texi index c810db626..e69de29bb 100644 --- a/devel/modules/module-snippets.texi +++ b/devel/modules/module-snippets.texi @@ -1,734 +0,0 @@ -\input texinfo -@c -*-texinfo-*- -@c %**start of header -@setfilename module-snippets.info -@settitle Module Snippets -@iftex -@afourpaper -@end iftex -@c %**end of header - -@set UPDATED 7May 2001 -@set EDITION 0.0.1 -@set VERSION 0.0.1 - -@dircategory Guile -@direntry -* module-snippets: (module-snippets). Documentation for the Guile Module System -@end direntry - - -@c --- title page starts here --- - -@titlepage -@title Module Snippets -@subtitle Documentation for the Guile Module System -@subtitle Version @value{VERSION} -@author Martin Grabmueller - -@c The following two commands -@c start the copyright page. -@page -@vskip 0pt plus 1filll -Copyright @copyright{} 2001 Martin Grabmueller - -Permission is granted to make and distribute verbatim copies of -this manual provided the copyright notice and this permission notice -are preserved on all copies. -@end titlepage - -@c --- title page ends here --- - -@syncodeindex vr cp -@syncodeindex fn cp - -@c =================================================================== - -@node Top, Introduction, (dir), (dir) - -@ifinfo -This file tries to shed some light on Guile's current module system. -@end ifinfo - -@menu -* Introduction:: What is this all about? -* Module Data Type:: Modules from a data-centric view. -* Modules and Evaluation:: Interaction between the module system - and the evaluator. -* Index:: Procedure index. -@end menu - - -@c =================================================================== - -@node Introduction, Module Data Type, Top, Top -@chapter Introduction - -This document contains all information about the module system I have -been able to deduce from the source code or from mailing list -conversation. I have written down everything while trying to figure out -how the Guile module system actually works, and some of the text is -taken from commentary in the file @file{boot-9.scm}. - -The information contained herein is surely not complete, and I will be -happy to receive additions, corrections and suggestions for improving -it. - -Also note that the information contained in this document reflects the -current state as of the time writing, and the facts stated are not -guaranteed to be stable. A complete redesign of the module system is -planned for a long time now, and actually might happen some day. - -There are basically three views on the module system: - -@itemize @bullet -@item -Data-centric: The module as a data type, with all procedures for -creating and manipulating modules. This is documented in the -@ref{Module Data Type}. - -@item -Declarational: How to use declarations like @code{use-modules} or -@code{define-module} for dealing with modules and the scoping mechanisms -they provide. This issue is documented in the Guile Reference Manual, -and will not be covered in detail here. - -@item -Internal: How do the module system and the Guile evaluator interact? -This is documented in @ref{Modules and Evaluation}. -@end itemize - - -@c =================================================================== - -@node Module Data Type, Modules and Evaluation, Introduction, Top -@chapter Module Data Type - -This chapter will describe the module system from the point of the data -type @code{module}. Thus we will first see what this data type looks -like and what operations are defined on it. - -Modules in Guile are instances of a data type @code{module}. A module -has the following fields. - -@table @var -@item obarray -This is a hash table which contains all bindings made in the module. - -@item uses-list -List of the modules imported by the module. A lot of search procedures -search through all modules in this list when a specified binding cannot -be found in the module's obarray. - -@item lazy-binding-proc -A procedure for determining a binding for a module lazily. This is -invoked if a binding for a name is requested from the module, but does -not exist. The procedure can create a new binding, by loading -additional code or fetching it from another module/data structure. - -@item eval-closure -A procedure for determining a binding in a module. The evaluator uses -this procedure for accessing top-level variables. - -@item transformer -The syntax transformer used for all evaluations in the module. - -@item name -The name of the module. This is a list of symbols, such as -@code{(guile)} or @code{(ice-9 popen)}. - -@item kind -A symbol describing the type of the module. Normal modules are of type -@code{module}, interfaces are of type @code{interface} and directories -(modules which implement the hierarchical namespace) are of kind -@code{directory}). Autoload modules (placeholder for not-yet-loaded -modules) are of type @code{autoload}. FIXME: Are there other types? - -@item observers -A list of procedures to call when one of the module's bindings is -removed or modified or a new binding is created. - -@item weak-observers -Similar to @var{observers}, but this is a hash table from which the -observer procedures will magically disappear when there are no other -references to the procedure left except from the module they observe. - -@item observer-id -This is an integer, which specifies the identifer the next weak observer -will get. It is incremented each time a weak observer is added. -@end table - -@menu -* The Data Type:: The data type @code{module}. -* Module Loading:: How to load modules. -* Modules and Variables:: How do variables and modules relate. -* Iterating over Module Bindings:: How to access all bindings of a module. -* The Lazy Binder:: The lazy binding procedures. -* Module Observers:: The observer protocol. -* The Current Module:: Notion of ``current module'' in Guile. -* High-Level Module Access:: High-level access to module features. -* Recursive Namespaces:: Hierarchical organisation of namespaces. -* Module Hierarchy:: The currently implemented hierarchy. -* Modules and Interfaces:: How modules implement different scopes. -* Modules and Environments:: Relation between modules and environments. -* Modules Miscallenea:: Miscellaneous module procedures. -@end menu - - -@c =================================================================== - -@node The Data Type, Module Loading, Module Data Type, Module Data Type -@section The Data Type - -A new module is created using @code{make-module}. Several procedures -are defined for accessing the members of a module. - -@deffn procedure make-module size uses-list lazy-binding-proc -Create a new module and initialize its fields with the parameters. - -@table @var -@item size -Size of the module's obarray. - -@item uses-list -List of the modules imported by the module. - -@item lazy-binding-proc -The procedure for determining a binding for a module lazily. -@end table -@end deffn - -The various fields of a module can be accessed and modified using the -following procedures: - -@deffn procedure module-obarray module -@deffnx procedure set-module-obarray! module obj -@deffnx procedure module-uses module -@deffnx procedure set-module-uses! module obj -@deffnx procedure module-binder module -@deffnx procedure set-module-binder! module obj -@deffnx procedure module-eval-closure module -@deffnx procedure set-module-eval-closure! module obj -@deffnx procedure module-transformer module -@deffnx procedure set-module-transformer! module obj -@deffnx procedure module-name module -@deffnx procedure set-module-name! module obj -@deffnx procedure module-kind module -@deffnx procedure set-module-kind! module obj -@deffnx procedure module-observers module -@deffnx procedure set-module-observers! module obj -@deffnx procedure module-weak-observers module -@deffnx procedure module-observer-id module -@deffnx procedure set-module-observer-id! module obj -Read the corresponding member of @var{module}, or write the value -@var{obj} into the slot. -@end deffn - -@deffn procedure module? obj -This is the type predicate for modules, which will return @code{#t} if -its argument is a module, and @code{#f} otherwise. -@end deffn - -@deffn procedure make-scm-module -This will create a module which represents Guile's builtin bindings. -Initially, it is empty, but when variable lookups are made in it, the -requested bindings will get copied into the module from the internal -obarray. Bindings will get copied even if only accessed. -@end deffn - -@deffn procedure make-root-module -Create a new module which works on the internal obarrary. The -difference to the modules returned by @code{make-scm-module} is that -bindings are only copied to the obarray if they are explicitly defined. -@end deffn - - -@c =================================================================== - -@node Module Loading, Modules and Variables, The Data Type, Module Data Type -@section Module Loading - -The normal way of loading modules in Scheme programs is to use the -special form @code{use-modules}, which loads the source of one or more -specified modules and imports their public bindings into the current -module. This procedure is documented in the Guile Reference Manual, so -I will not go into details here. This section rather contains the -underlying mechanisms, on which @code{use-modules} is built. - -Normally, you will not need to create new modules explicitly, adding -definitions to it manually. For more often, you will want to load some -Scheme code from a file, and install its definitions into a module, only -exporting the public bits. This is what the procedure -@code{resolve-module} is for. - -@deffn procedure resolve-module name [maybe-autoload] -If the module @var{name} already exists, return it. Otherwise, try to -load the Scheme code for @var{name} into a newly created module, adding -the exports to the public interface. - -The parameter @var{maybe-autoload} controls the behaviour when the -module code is going to be loaded. - -@table @asis -@item @var{maybe-autoload} == @code{#f} -Do not defer loading. - -@item @var{maybe-autoload} == @code{#t} -Defer loading of the source code until a binding from the module is -requested. - -@item @var{maybe-autoload} not given -Like @var{maybe-autoload} == @code{#t}. -@end table -@end deffn - - -@c =================================================================== - -@node Modules and Variables, Iterating over Module Bindings, Module Loading, Module Data Type -@section Modules and Variables - -Modules can be regarded as mappings from symbols (variable names) to -bindings (variable locations). The procedures documented in this -section can be used to test whether such a mapping exists for a given -variable name, how to add mappings and how to retrieve a variables -value. - -We sometimes want to look for properties of a symbol just within the -obarray of one module. If the property holds, then it is said to hold -``locally'' as in, ``The symbol @code{display} is locally rebound in the -module @code{safe-guile}.'' - -Other times, we want to test for a symbol property in the obarray of -@var{m} and, if it is not found there, try each of the modules in the -uses list of @var{m}. This is the normal way of testing for some -property, so we state these properties without qualification as in: -``The symbol 'fnord is interned in module M because it is interned -locally in module @var{m2} which is a member of the uses list of -@var{m}.'' - -@deffn procedure module-locally-bound? module sym -Test if @var{sym} is bound in @var{module} directly, e.g. it does not -suffice that @var{sym} is bound in one of the used modules of -@var{module}. @dfn{Bound} means that the symbol is interned and bound -to some well-defined value. -@end deffn - -@deffn procedure module-bound? module sym -Return true if @var{sym} is bound in @var{module} or one of the modules -in @var{module}'s uses list. The search looks in all transitively used -modules. @dfn{Bound} means that the symbol is interned and bound to -some well-defined value. -@end deffn - -@deffn procedure module-symbol-locally-interned? module sym -Test if @var{sym} is interned in @var{module} directly, e.g. it does not -suffice that @var{sym} is bound in one of the used modules of -@var{module}. Unlike @code{module-locally-bound}, the symbol is not -required to be bound to a well-defined value. -@end deffn - -@deffn procedure module-symbol-interned? module sym -Return true if @var{sym} is interned in @var{module} or one of the -modules in @var{module}'s uses list. The search looks in all -transitively used modules. Unlike @code{module-bound}, the symbol is -not required to be bound to a well-defined value. -@end deffn - -@deffn procedure module-local-variable module sym -Return a variable object for @var{SYM} in the module @var{module}, or -@code{#f} if no such symbol is defined in @var{module}. If the symbols -is not found at first, but the module has a lazy binder, then try the -binder. -@end deffn - -@deffn procedure module-variable module sym -Return a variable object for @var{sym} in the module @var{module} or one -of its used modules, or @code{#f} if no such symbol is defined in -@var{module} or its uses. -@end deffn - -@deffn procedure module-symbol-local-binding module symbol [opt-value] -Return the value of the binding called @var{symbol} in @var{module}, or -@var{opt-val} if no such binding exists. If no @var{opt-value} is given -and no binding exists, an error is thrown. -@end deffn - -@deffn procedure module-symbol-binding module symbol [opt-value] -Return the value of the binding called @var{symbol} in @var{module}, or -@var{opt-val} if no such binding exists. If no @var{opt-value} is given -and no binding exists, an error is thrown. Unlike -@code{module-symbol-local-binding}, this will search all used modules as -well as @var{module}. -@end deffn - -@deffn procedure module-make-local-var! module symbol -Create a binding for a variable called @var{symbol} in @var{module} and -return the variable object representing the new location in the module. -If @var{symbol} is already defined in @var{module}, nothing happens. -@end deffn - -@deffn procedure module-add! module symbol var -Add the variable @var{var} to @var{module} under the name @var{symbol}. -@end deffn - -@deffn procedure module-remove! module symbol -Remove the binding for @var{symbol} in @var{module}. The return value -is not specified. -@end deffn - -@deffn procedure module-clear! module -Remove all bindings from @var{module}. -@end deffn - - -@c =================================================================== - -@node Iterating over Module Bindings, The Lazy Binder, Modules and Variables, Module Data Type -@section Iterating over Module Bindings - -@deffn procedure module-for-each proc module -Apply @var{proc} to every binding in @var{module}. @var{proc} is called -with two parameters, the name and variable for each binding. -@end deffn - -@deffn procedure module-map proc module -Apply @var{proc} to every binding in @var{module} and return a list of -the results of all applications of @var{proc}. @var{proc} is called -with two parameters, the name and variable for each binding. -@end deffn - - -@c =================================================================== - -@node The Lazy Binder, Module Observers, Iterating over Module Bindings, Module Data Type -@section The Lazy Binder - -The lazy binding procedures which are connected to modules are invoked -every time a binding is searched in a module, but is not present. A -binder is called with three arguments. - -When a lazy binder returns a variable object, the search is successful -and the return value will be used. If the return value is @code{#f}, -the search is continued in the modules from the uses list. FIXME: Is -this always the case or only in the standard eval closure? - -@table @var -@item module -The module for which the binding is requested. - -@item symbol -The name of the searched symbol. - -@item define? -@code{#t} if the binding should be defined, @code{#f} otherwise. -@end table - - -@c =================================================================== - -@node Module Observers, The Current Module, The Lazy Binder, Module Data Type -@section Module Observers - -A module can have a number of @dfn{observers} attached. These are -procedures which are called whenever something withing the module -changes. This can be the creation, deletion or modification of a -binding. - -When a change occurs, the procedure @code{module-modified} (documented -below in this section) will be called which in turn will apply all -observer procedures to the modified module. - -@deffn procedure module-observe module proc -Add the observer @var{proc} to @var{module} and return a pair of -@var{module} and @var{proc}. The returned value can be used with -@code{module-unobserve}. -@end deffn - -@deffn procedure module-observe-weak module proc -Add @var{proc} as a weak observer to @var{module} and erturn a pair of -@var{module} and a unique integer, the observer ID. The returned value -can be used with @code{module-unobserve}. -@end deffn - -@deffn procedure module-unobserve token -Remove an observer from a module. The module and the observer to be -removed are taken from @var{token}, which must be returned by -@code{module-observe} or @code{module-unobserve}. -@end deffn - -@deffn procedure module-modified m -Signal a modification of module @var{m} to all associated observers. -@end deffn - - - -@c =================================================================== - -@node The Current Module, High-Level Module Access, Module Observers, Module Data Type -@section The Current Module - -For all evaluations, Guile maintains a so-called @dfn{current -module}.@footnote{A current module does not exist until Guile has been -completely booted, that means until @file{boot-9.scm} has been loaded. -But this should be no issue unless you are doing weird things withe the -module system, which might be a bad idea, but YMMV.} This is used for -all top-level definitions and variable lookups. When the current module -changes, new definitions will go to the new module. The procedures in -this section manipulate the notion of the current module. - -The current module is also used when C code calls @code{scm_make_gsubr} -for creating new primitives or @code{scm_sysintern} for interning -symbols. From C, the current module can be set by calling -@code{scm_set_current_module}, which will return the old module. This -returned module can later be used to switch back to the old module after -creating a new one and installing bindings there. - - -@deffn procedure set-current-module module -Make @var{module} the current module, into which all following -definitions will go. Return the old module in effect before the call to -@code{set-current-module}. -@end deffn - -@deffn procedure current-module -Return the module which is currently registered as the @dfn{current -module}. -@end deffn - - - -@c =================================================================== - -@node High-Level Module Access, Recursive Namespaces, The Current Module, Module Data Type -@section High-Level Module Access - -The procedure in the previous chapter are not for general use. The -current chapter will document all procedures which are meant to be used -by users who need to work with modules. - -The parameter @var{module} in the following descriptions must be a -module, @var{name} must be a symbol (which most probably will need to be -quoted). - -@deffn procedure module-ref module name [default] -Return the value of a variable called @var{name} in @var{module} or any -of its used modules. If there is no such variable, then if the optional -third argument @var{default} is present, it is returned; otherwise an -error is signaled. -@end deffn - -@deffn procedure module-set! module name value -Sets the variable called @var{name} in @var{module} (or in a module that -@var{module} uses) to @var{value}; if there is no such variable, an -error is signaled. -@end deffn - -@deffn procedure module-define! module name value -Sets the variable called @var{name} in @var{module} to @var{value}; if -there is no such variable, it is added first. -@end deffn - -@deffn procedure module-defined? module name -Return @code{#t} if @var{name} is defined in @var{module} (or in a -module that @var{module} uses). -@end deffn - -@deffn procedure module-use! module interface -Add @var{interface} to the list of interfaces used by @var{module}. For -information what an @dfn{interface} is, see @ref{Modules and -Interfaces}. -@end deffn - -@deffn procedure module-export! module names -Add all variables from @var{names} (a list of symbols) to the public -interface of @var{module} (@pxref{Modules and Interfaces}). -@end deffn - -@c =================================================================== - -@node Recursive Namespaces, Module Hierarchy, High-Level Module Access, Module Data Type -@section Recursive Namespaces - -A hierarchical namespace emerges if we consider some module to be root, -and variables bound to modules as nested namespaces. - -The modules which implement the internal nodes are of kind -@code{directory}. FIXME: Is this correct? - -The routines in this chapter manage variable names in hierarchical -namespace. Each variable name is a list of elements, looked up in -successively nested modules. - -@example -(nested-ref some-root-module '(foo bar baz)) -@result{} - -@end example - -@deffn procedure nested-ref root names -Look up the variable identified by the symbol list @var{names}, starting -in the module @var{root}. -@end deffn - -@deffn procedure nested-set! root names val -Set the variable identified by the symbol list @var{names} to @var{val}, -starting the variable lookup in module @var{root}. The return value is -not specified. -@end deffn - -@deffn procedure nested-define! root names val -Set the variable identified by the symbol list @var{names} to @var{val}, -starting the variable lookup in module @var{root}. If the variable does -not exist, create it before setting its value. The return value is not -specified. -@end deffn - -@deffn procedure nested-remove! root names -Remove the variable identified by the symbol list @var{names}, starting -the variable lookup in module @var{root}. The return value is not -specified. -@end deffn - -@deffn procedure local-ref names -@deffnx procedure local-set! names val -@deffnx procedure local-define! names val -@deffnx procedure local-remove! names -Like the @code{nested-ref}, @code{nested-set!}, @code{nested-define!} -and @code{nested-remove!} procedures above, but start the variable -lookup in the module returned by @code{current-module}. -@end deffn - - -@c =================================================================== - -@node Module Hierarchy, Modules and Interfaces, Recursive Namespaces, Module Data Type -@section Module Hierarchy - -Currently, the following entries are defined in the hierarchical -namespace. - -@table @code -@item (app) -This is the root of all named objects which are not in the top level. - -@item (app modules) -This is the directory of all modules. - -@item (app modules guile) -This is the standard root module. -@end table - -User modules which are loaded into Guile as well as the modules shipped -with the Guile distribution are installed under @code{(app modules)} as -well. - - -@c =================================================================== - -@node Modules and Interfaces, Modules and Environments, Module Hierarchy, Module Data Type -@section Modules and Interfaces - -Interfaces are modules of kind @code{interface}. They always belong to -another module and contain the bindings which are exported from that -module. Interfaces are the means by which the different scopes of a -module (private vs. public bindings) are implemented. - -Every module can define a special variable called -@code{%module-public-interface}, which is bound to the module's -interface. - -Whenever a variable is exported (with the @code{export} form or the -@code{:export} keyword in the @code{define-module} form), this variable -is added to the defining module's interface. Because importing a module -means adding other modules' interfaces to the uses list, the exported -variables become visible in the importing module. - -@deffn procedure module-public-interface m -Return the public interface of module @var{m}, or @code{#f} if @var{m} -does not have a public interface. -@end deffn - -@deffn procedure set-module-public-interface! m i -Set the public interface of the module @var{m} to @var{i}. -@end deffn - - -@c =================================================================== - -@node Modules and Environments, Modules Miscallenea, Modules and Interfaces, Module Data Type -@section Modules and Environments - -An environment belongs to a specific module, which can be determined by -calling @code{environment-module}. - -@deffn procedure environment-module env -@end deffn - - -@c =================================================================== - -@node Modules Miscallenea, , Modules and Environments, Module Data Type -@section Modules Miscallenea - -This chapter contains all miscellaneous information and procedure -documentation which I have not been able to include elsewhere. If -someone knows how to include them into other chapters, suggestions are -welcome. - -@deffn procedure set-system-module! m s -Set the @code{system-module} property of the module @var{m} to @var{s}. -@var{s} should be a module telling whehter @var{m} is a system module or -not. System modules are treated specially in some cases, for example -procedures defined in system modules are excluded from backtraces. -FIXME: Is this last sentence true? -@end deffn - - -@c =================================================================== - -@node Modules and Evaluation, Index, Module Data Type, Top -@chapter Modules and Evaluation - -Up to here, we have seen how modules are implemented as a data type, -which can be manipulated by C and Scheme code to implement module system -work like providing private and public name spaces, loading of modules -and creating new modules. - -This chapter will describe the connection between the module system and -the Guile evaluator. Top-level variables (that is, variables not -lexically bound) need to be resolved in the current module, and if not -defined there, in the used modules, and so on, until the root module has -been asked for the bindings. - -First, we have to recall how Guile normally figures out the location for -a given variable when evaluating a form. The evaluator starts by -scanning the lexical environment it maintains. It first looks in each -slot in the top-most environment frame, continuing in the next frame and -so on, until it reaches the end of the lexical environment chain. - -The @sc{car} of the last pair of the environment chain is either -@code{#f}, or it is a procedure. When it is @code{#f}, the normal -system obarray is searched for the variable, otherwise the procedure is -called for returning the requested variable. This procedure is the -current module's @dfn{eval closure}, and is responsible for searching a -variable's binding, installing it if necessary. - -When a variable is finally found, the reference to the variable in the -currently executed Scheme code is replaced by a special value (a -so-called @code{gloc}), so that this environment search is not necessary -the next time the variable is looked up. - - -@c =================================================================== - -@node Index, , Modules and Evaluation, Top -@comment node-name, next, previous, up -@unnumbered Index - -@printindex cp - -@contents - -@bye From 7cfbc4f7b0b709ffe5c45b36cfa55cbff9731ecb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Tue, 8 May 2001 06:04:15 +0000 Subject: [PATCH 1038/2047] * tests/srfi-13.test: Added module access kludge, and uncommented some tests depending on this. --- test-suite/ChangeLog | 5 +++++ test-suite/tests/srfi-13.test | 27 +++++++++++++++------------ 2 files changed, 20 insertions(+), 12 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 619cf4906..b5f414160 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2001-05-08 Martin Grabmueller + + * tests/srfi-13.test: Added module access kludge, and uncommented + some tests depending on this. + 2001-05-07 Martin Grabmueller * tests/srfi-13.test: New file testing the SRFI string library. diff --git a/test-suite/tests/srfi-13.test b/test-suite/tests/srfi-13.test index 1c345c8ff..2cc0295a5 100644 --- a/test-suite/tests/srfi-13.test +++ b/test-suite/tests/srfi-13.test @@ -20,6 +20,11 @@ (use-modules (srfi srfi-13)) +;;; This kludge is needed, because SRFI-13 redefines some bindings in +;;; the core. +(define (module-peek module-name sym) + (variable-ref (module-variable (resolve-module module-name) sym))) + (define exception:strict-infix-grammar (cons 'misc-error "^strict-infix")) @@ -90,6 +95,7 @@ (string=? (string-tabulate (lambda (idx) (integer->char (+ idx 32))) 10) " !\"#$%&'()"))) +(define string->list (module-peek '(srfi srfi-13) 'string->list)) (with-test-prefix "string->list" @@ -99,13 +105,11 @@ (pass-if "nonempty" (= (length (string->list "foo")) 3)) -;;; FIXME: These do not work, because the standard definition is used, -;;; apparently. -; (pass-if "empty, start index" -; (zero? (length (string->list "foo" 3 3)))) + (pass-if "empty, start index" + (zero? (length (string->list "foo" 3 3)))) -; (pass-if "nonempty, start index" -; (= (length (string->list "foo" 2)) 1 3)) + (pass-if "nonempty, start index" + (= (length (string->list "foo" 1 3)) 2)) ) (with-test-prefix "reverse-list->string" @@ -196,6 +200,7 @@ (string=? "foo|delim|bar|delim|" (string-join '("foo" "bar") "|delim|" 'suffix)))) +(define string-copy (module-peek '(srfi srfi-13) 'string-copy)) (with-test-prefix "string-copy" @@ -205,13 +210,11 @@ (pass-if "full string" (string=? "foo-bar" (string-copy "foo-bar"))) -;;; FIXME: These do not work, because the standard definition is used, -;;; apparently. -; (pass-if "start index" -; (string=? "o-bar" (string-copy "foo-bar" 2))) + (pass-if "start index" + (string=? "o-bar" (string-copy "foo-bar" 2))) -; (pass-if "start and end index" -; (string=? "o-ba" (string-copy "foo-bar" 2 6))) + (pass-if "start and end index" + (string=? "o-ba" (string-copy "foo-bar" 2 6))) ) (with-test-prefix "substring/shared" From 56e55ac7cfcfefc033ac6da130bafe745e9e109f Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 8 May 2001 10:23:17 +0000 Subject: [PATCH 1039/2047] * Removed deprecated hook names. * Fix use of SCM_FLOBUFLEN. --- RELEASE | 6 ------ libguile/ChangeLog | 27 +++++++++++++++++++++++++-- libguile/gc.c | 1 + libguile/hooks.c | 26 ++------------------------ libguile/hooks.h | 18 ++++-------------- libguile/init.c | 4 ++-- libguile/numbers.c | 15 +++++---------- 7 files changed, 39 insertions(+), 58 deletions(-) diff --git a/RELEASE b/RELEASE index c9b568d46..36a494ab8 100644 --- a/RELEASE +++ b/RELEASE @@ -20,12 +20,6 @@ After signal handling and threading have been fixed: - Make sure that the deprecation mechanism explained in INSTALL and README is completed and works. -- Q: Was SCM_FLOBUFLEN only deprecated publically, or was it supposed - to be removed from numbers.c as well? - -- remove code related to the name property of hooks. Also, check init.c, - since the dependency between hooks and objprop will then be eliminated. - === In release 1.8.0: - remove compatability module (ice-9 and-let*). It diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 2ce8417be..3c9fc431c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,10 +1,33 @@ +2001-04-21 Dirk Herrmann + + * gc.c (scm_init_gc): Added FIXME comment. + + * hooks.c: Since hooks don't have a name any more, it is not + necessary to include objprop.h. + + (hook_print, scm_add_hook_x): Replace SCM_NFALSEP by !SCM_FALSEP. + + (symbol_name, scm_make_hook_with_name): Removed. + + (scm_create_hook): Don't set the hook's name property. + + * hooks.h (HOOKSH, SCM_HOOKS_H): Renamed HOOKSH to SCM_HOOKS_H. + + (SCM_HOOK_NAME, scm_make_hook_with_name): Removed. + + * init.c (scm_init_guile_1): Hooks don't use objprops any more. + + * numbers.c (SCM_FLOBUFLEN, FLOBUFLEN, scm_number_to_string, + scm_print_real, scm_print_complex): Renamed SCM_FLOBUFLEN to + FLOBUFLEN and define it unconditionally. + 2001-05-07 Marius Vollmer * gh_data.c (gh_lookup): Call gh_module_lookup with `scm_current_module ()', not `#f'. (gh_module_lookup): Expect a module instead of an obarray as first argument and do lookup in that module. - + * ramap.c (raeql_1): Do not call scm_uniform_vector_length on arrays. The length of array is already determined differently and scm_uniform_vector_length does not work on arrays. @@ -17,7 +40,7 @@ * __scm.h (SCM_WTA_DISPATCH_0): Removed ARG and POS parameters, they are not used. Changed `wrong type' error into `wrong num args' error. Changed all callers. - + * numbers.c (scm_difference): Call SCM_WTA_DISPATCH_0 when zero arguments are supplied. diff --git a/libguile/gc.c b/libguile/gc.c index cef92aca9..b92549f16 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -2699,6 +2699,7 @@ scm_init_gc () scm_tc16_allocated = scm_make_smob_type ("allocated cell", 0); #endif /* SCM_DEBUG_CELL_ACCESSES == 1 */ + /* Dirk:FIXME:: scm_create_hook is strange. */ scm_after_gc_hook = scm_create_hook ("after-gc-hook", 0); after_gc_thunk = scm_make_subr_opt ("%gc-thunk", scm_tc7_subr_0, gc_async_thunk, 0); diff --git a/libguile/hooks.c b/libguile/hooks.c index 3ad60ce85..88fa69d75 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001 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 @@ -49,7 +49,6 @@ #include "libguile/eval.h" #include "libguile/ports.h" -#include "libguile/objprop.h" #include "libguile/procprop.h" #include "libguile/root.h" #include "libguile/smob.h" @@ -184,7 +183,7 @@ hook_print (SCM hook, SCM port, scm_print_state *pstate) { scm_putc (' ', port); name = scm_procedure_name (SCM_CAR (ls)); - if (SCM_NFALSEP (name)) + if (!SCM_FALSEP (name)) scm_iprin1 (name, port, pstate); else scm_putc ('?', port); @@ -195,37 +194,16 @@ hook_print (SCM hook, SCM port, scm_print_state *pstate) } -SCM_SYMBOL (symbol_name, "name"); - SCM scm_create_hook (const char* name, int n_args) { SCM hook = make_hook (SCM_MAKINUM (n_args), "scm_create_hook"); scm_sysintern (name, hook); - scm_set_object_property_x (hook, symbol_name, scm_makfrom0str (name)); scm_protect_object (hook); return hook; } -#if (SCM_DEBUG_DEPRECATED == 0) - -SCM_DEFINE (scm_make_hook_with_name, "make-hook-with-name", 1, 1, 0, - (SCM name, SCM n_args), - "Create a named hook with the name @var{name} for storing\n" - "procedures of arity @var{n_args}. @var{n_args} defaults to\n" - "zero.") -#define FUNC_NAME s_scm_make_hook_with_name -{ - SCM hook = make_hook (n_args, FUNC_NAME); - scm_set_object_property_x (hook, scm_makfrom0str ("name"), name); - return hook; -} -#undef FUNC_NAME - -#endif /* SCM_DEBUG_DEPRECATED == 0 */ - - SCM_DEFINE (scm_make_hook, "make-hook", 0, 1, 0, (SCM n_args), "Create a hook for storing procedure of arity\n" diff --git a/libguile/hooks.h b/libguile/hooks.h index 95623c114..216d63062 100644 --- a/libguile/hooks.h +++ b/libguile/hooks.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef HOOKSH -#define HOOKSH -/* Copyright (C) 1995, 1996, 1999, 2000 Free Software Foundation, Inc. +#ifndef SCM_HOOKS_H +#define SCM_HOOKS_H +/* Copyright (C) 1995,1996,1999,2000,2001 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 @@ -115,17 +115,7 @@ extern void scm_c_run_hook (SCM hook, SCM args); extern SCM scm_hook_to_list (SCM hook); extern void scm_init_hooks (void); - - -#if (SCM_DEBUG_DEPRECATED == 0) - -/* Use scm_set_object_property_x to set the name property of a hook: */ -#define SCM_HOOK_NAME(h) scm_object_property (h, scm_makfrom0str ("name")) -extern SCM scm_make_hook_with_name (SCM name, SCM n_args); - -#endif /* SCM_DEBUG_DEPRECATED == 0 */ - -#endif /* HOOKSH */ +#endif /* SCM_HOOKS_H */ /* Local Variables: diff --git a/libguile/init.c b/libguile/init.c index 4feb92c2d..c53d1a4ac 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999, 2000, 2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 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 @@ -508,7 +508,7 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_init_deprecation (); /* Requires hashtabs */ scm_init_objprop (); scm_init_properties (); - scm_init_hooks (); /* Requires objprop until hook names are removed */ + scm_init_hooks (); /* Requires smob_prehistory */ scm_init_gc (); /* Requires hooks, async */ #ifdef GUILE_ISELECT scm_init_iselect (); diff --git a/libguile/numbers.c b/libguile/numbers.c index ce7252a07..a0405d5ff 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -68,15 +68,10 @@ static SCM scm_divbigint (SCM x, long z, int sgn, int mode); #define SCM_SWAP(x,y) do { SCM __t = x; x = y; y = __t; } while (0) -/*#if (SCM_DEBUG_DEPRECATED == 1)*/ /* not defined in header yet? */ -#if 1 - -/* SCM_FLOBUFLEN is the maximum number of characters neccessary for the +/* FLOBUFLEN is the maximum number of characters neccessary for the * printed or scm_string representation of an inexact number. */ -#define SCM_FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10) - -#endif /* SCM_DEBUG_DEPRECATED == 1 */ +#define FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10) /* IS_INF tests its floating point number for infiniteness @@ -2307,7 +2302,7 @@ SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0, } else if (SCM_BIGP (n)) { return big2str (n, (unsigned int) base); } else if (SCM_INEXACTP (n)) { - char num_buf [SCM_FLOBUFLEN]; + char num_buf [FLOBUFLEN]; return scm_makfromstr (num_buf, iflo2str (n, num_buf), 0); } else { SCM_WRONG_TYPE_ARG (1, n); @@ -2322,7 +2317,7 @@ SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0, int scm_print_real (SCM sexp, SCM port, scm_print_state *pstate) { - char num_buf[SCM_FLOBUFLEN]; + char num_buf[FLOBUFLEN]; scm_lfwrite (num_buf, iflo2str (sexp, num_buf), port); return !0; } @@ -2330,7 +2325,7 @@ scm_print_real (SCM sexp, SCM port, scm_print_state *pstate) int scm_print_complex (SCM sexp, SCM port, scm_print_state *pstate) { - char num_buf[SCM_FLOBUFLEN]; + char num_buf[FLOBUFLEN]; scm_lfwrite (num_buf, iflo2str (sexp, num_buf), port); return !0; } From 8ff45739c59e1150b09d251792b6c74c522439fe Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 8 May 2001 10:30:32 +0000 Subject: [PATCH 1040/2047] * Ooops: This patch belongs to the previous ChangeLog entry... --- libguile/hooks.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/hooks.c b/libguile/hooks.c index 88fa69d75..96a9657b3 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -247,7 +247,7 @@ SCM_DEFINE (scm_add_hook_x, "add-hook!", 2, 1, 0, SCM arity, rest; int n_args; SCM_VALIDATE_HOOK (1,hook); - SCM_ASSERT (SCM_NFALSEP (arity = scm_i_procedure_arity (proc)), + SCM_ASSERT (!SCM_FALSEP (arity = scm_i_procedure_arity (proc)), proc, SCM_ARG2, FUNC_NAME); n_args = SCM_HOOK_ARITY (hook); if (SCM_INUM (SCM_CAR (arity)) > n_args From bff56cdfa1af12f1933f09649ae33adcae211252 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 9 May 2001 01:50:39 +0000 Subject: [PATCH 1041/2047] Initial revision --- scripts/read-scheme-source | 197 +++++++++++++++++++++++++++++++++++++ 1 file changed, 197 insertions(+) create mode 100755 scripts/read-scheme-source diff --git a/scripts/read-scheme-source b/scripts/read-scheme-source new file mode 100755 index 000000000..54cad4db0 --- /dev/null +++ b/scripts/read-scheme-source @@ -0,0 +1,197 @@ +#!/bin/sh +# aside from this initial boilerplate, this is actually -*- scheme -*- code +main='(module-ref (resolve-module '\''(scripts read-scheme-source)) '\'main')' +exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" +!# +;;; read-scheme-source --- Read a file, recognizing scheme forms and comments + +;; Copyright (C) 2001 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA + +;;; Commentary: + +;; Usage: read-scheme-source FILE1 FILE2 ... +;; +;; This program parses each FILE and writes to stdout sexps that describe the +;; top-level structures of the file: scheme forms, single-line comments, and +;; hash-bang comments. You can further process these (to associate comments +;; w/ scheme forms as a kind of documentation, for example). +;; +;; The output sexps have one of these forms: +;; +;; (quote (filename FILENAME)) +;; +;; (quote (comment :leading-parens N +;; :text LINE)) +;; +;; (quote (whitespace :text LINE)) +;; +;; (quote (hash-bang-comment :line LINUM +;; :line-count N +;; :text-list (LINE1 LINE2 ...))) +;; +;; (quote (following-form-properties :line LINUM +;; :line-count N) +;; :type TYPE +;; :signature SIGNATURE +;; :std-int-doc DOCSTRING)) +;; +;; SEXP +;; +;; The first four are straightforward (both FILENAME and LINE are strings sans +;; newline, while LINUM and N are integers). The last two always go together, +;; in that order. SEXP is scheme code processed only by `read' and then +;; `write'. +;; +;; The :type field may be omitted if the form is not recognized. Otherwise, +;; TYPE may be one of: procedure, alias, define-module, variable. +;; +;; The :signature field may be omitted if the form is not a procedure. +;; Otherwise, SIGNATURE is a list showing the procedure's signature. +;; +;; If the type is `procedure' and the form has a standard internal docstring +;; (first body form a string), that is extracted in full -- including any +;; embedded newlines -- and recorded by field :std-int-doc. +;; +;; +;; Usage from a program: The output list of sexps can be retrieved by scheme +;; programs w/o having to capture stdout, like so: +;; +;; (use-modules (scripts read-scheme-source)) +;; (define source-forms (read-scheme-source-silently "FILE1" "FILE2" ...)) +;; +;; +;; TODO: Add option "--clump-comments", maybe w/ different clumping styles. +;; Make `annotate!' extensible. +;; +;; Author: Thien-Thi Nguyen + +;;; Code: + +(define-module (scripts read-scheme-source) + :use-module (ice-9 rdelim) + :export (read-scheme-source read-scheme-source-silently)) + +;; Try to figure out what FORM is and its various attributes. +;; Call proc NOTE! with key (a symbol) and value. +;; +(define (annotate! form note!) + (cond ((and (list? form) + (< 2 (length form)) + (eq? 'define (car form)) + (pair? (cadr form)) + (symbol? (caadr form))) + (note! ':type 'procedure) + (note! ':signature (cadr form)) + (and (< 3 (length form)) + (string? (caddr form)) + (note! ':std-int-doc (caddr form)))) + ((and (list? form) + (< 2 (length form)) + (eq? 'define (car form)) + (symbol? (cadr form)) + (list? (caddr form)) + (< 3 (length (caddr form))) + (eq? 'lambda (car (caddr form))) + (string? (caddr (caddr form)))) + (note! ':type 'procedure) + (note! ':signature (cons (cadr form) (cadr (caddr form)))) + (note! ':std-int-doc (caddr (caddr form)))) + ((and (list? form) + (= 3 (length form)) + (eq? 'define (car form)) + (symbol? (cadr form)) + (symbol? (caddr form))) + (note! ':type 'alias)) + ((and (list? form) + (eq? 'define-module (car form))) + (note! ':type 'define-module)) + ;; Add other types here. + (else (note! ':type 'variable)))) + +;; Process FILE, calling NB! on parsed top-level elements. +;; Recognized: #!-!# and regular comments in addition to normal forms. +;; +(define (process file nb!) + (nb! `'(filename ,file)) + (let ((hash-bang-rx (make-regexp "^#!")) + (bang-hash-rx (make-regexp "^!#")) + (all-comment-rx (make-regexp "^[ \t]*(;+)")) + (all-whitespace-rx (make-regexp "^[ \t]*$")) + (p (open-input-file file))) + (let loop ((n (1+ (port-line p))) (line (read-line p))) + (or (not n) + (eof-object? line) + (begin + (cond ((regexp-exec hash-bang-rx line) + (let loop ((line (read-line p)) + (text (list line))) + (if (or (eof-object? line) + (regexp-exec bang-hash-rx line)) + (nb! `'(hash-bang-comment + :line ,n + :line-count ,(1+ (length text)) + :text-list ,(reverse + (cons line text)))) + (loop (read-line p) + (cons line text))))) + ((regexp-exec all-whitespace-rx line) + (nb! `'(whitespace :text ,line))) + ((regexp-exec all-comment-rx line) + => (lambda (m) + (nb! `'(comment + :leading-parens ,(let ((m1 (vector-ref m 1))) + (- (cdr m1) (car m1))) + :text ,line)))) + (else + (unread-string line p) + (let* ((form (read p)) + (count (- (port-line p) n)) + (props (let* ((props '()) + (prop+ (lambda args + (set! props + (append props args))))) + (annotate! form prop+) + props))) + (or (= count 1) ; ugh + (begin + (read-line p) + (set! count (1+ count)))) + (nb! `'(following-form-properties + :line ,n + :line-count ,count + ,@props)) + (nb! form)))) + (loop (1+ (port-line p)) (read-line p))))))) + +(define (read-scheme-source-silently . files) + "See commentary in module (scripts read-scheme-source)." + (let* ((res '())) + (for-each (lambda (file) + (process file (lambda (e) (set! res (cons e res))))) + files) + (reverse res))) + +(define (read-scheme-source . files) + "See commentary in module (scripts read-scheme-source)." + (for-each (lambda (file) + (process file (lambda (e) (write e) (newline)))) + files)) + +(define main read-scheme-source) + +;;; read-scheme-source ends here From d0a4c011be66ea0512d07dfd7e51d076df6d5169 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 9 May 2001 01:51:14 +0000 Subject: [PATCH 1042/2047] (scripts_sources): Add read-scheme-source. --- scripts/Makefile.am | 1 + 1 file changed, 1 insertion(+) diff --git a/scripts/Makefile.am b/scripts/Makefile.am index cca40e458..3d5b126bf 100644 --- a/scripts/Makefile.am +++ b/scripts/Makefile.am @@ -28,6 +28,7 @@ scripts_sources = \ doc-snarf \ generate-autoload \ punify \ + read-scheme-source \ use2dot subpkgdatadir = $(pkgdatadir)/$(VERSION)/scripts From adcd97c8bf22241a974f0636fc51b8fa363fe892 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 9 May 2001 01:52:55 +0000 Subject: [PATCH 1043/2047] *** empty log message *** --- scripts/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/scripts/ChangeLog b/scripts/ChangeLog index 22e913b13..9967dac99 100644 --- a/scripts/ChangeLog +++ b/scripts/ChangeLog @@ -1,3 +1,9 @@ +2001-05-08 Thien-Thi Nguyen + + * read-scheme-source: New file + + * Makefile.am (scripts_sources): Add read-scheme-source. + 2001-04-29 Thien-Thi Nguyen * Makefile.am, PROGRAM, README, display-commentary, From 910d1e40f9a91d4eba7f08fa0b32bb7d3796b31a Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Wed, 9 May 2001 16:32:06 +0000 Subject: [PATCH 1044/2047] * ports.c (scm_c_read): pointer arithmetic on void pointers isn't portable. * deprecation.c (s_scm_include_deprecated_features): ANSI'fied the docstring. --- libguile/ChangeLog | 10 ++++++++++ libguile/deprecation.c | 4 ++-- libguile/ports.c | 2 +- 3 files changed, 13 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 3c9fc431c..0e9d9c8cf 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,13 @@ +2001-05-09 Michael Livshin + + from Matthias Köppe (thanks!): + + * ports.c (scm_c_read): pointer arithmetic on void pointers isn't + portable. + + * deprecation.c (s_scm_include_deprecated_features): ANSI'fied the + docstring. + 2001-04-21 Dirk Herrmann * gc.c (scm_init_gc): Added FIXME comment. diff --git a/libguile/deprecation.c b/libguile/deprecation.c index cc0a9db49..0dd44cb54 100644 --- a/libguile/deprecation.c +++ b/libguile/deprecation.c @@ -116,8 +116,8 @@ print_deprecation_summary (void) SCM_DEFINE(scm_include_deprecated_features, "include-deprecated-features", 0, 0, 0, (), - "Return @code{#t} iff deprecated features should be included - in public interfaces.") + "Return @code{#t} iff deprecated features should be included\n" + "in public interfaces.") #define FUNC_NAME s_scm_include_deprecated_features { #if SCM_DEBUG_DEPRECATED == 0 diff --git a/libguile/ports.c b/libguile/ports.c index 0762733f4..8fa5e8067 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1027,7 +1027,7 @@ scm_c_read (SCM port, void *buffer, scm_sizet size) while (n_available < size) { memcpy (buffer, pt->read_pos, n_available); - buffer += n_available; + buffer = (char *) buffer + n_available; pt->read_pos += n_available; n_read += n_available; From dd9eb5324296d8e0abbed6462fc7a887f3d5d3f8 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Wed, 9 May 2001 16:38:45 +0000 Subject: [PATCH 1045/2047] *** empty log message *** --- .cvsignore | 1 + doc/.cvsignore | 2 ++ libltdl/.cvsignore | 21 --------------------- scripts/.cvsignore | 2 ++ 4 files changed, 5 insertions(+), 21 deletions(-) create mode 100644 scripts/.cvsignore diff --git a/.cvsignore b/.cvsignore index f023b667e..da5d0bd13 100644 --- a/.cvsignore +++ b/.cvsignore @@ -14,3 +14,4 @@ libtool ltconfig ltmain.sh check-guile +guile-tools diff --git a/doc/.cvsignore b/doc/.cvsignore index 4a29810e7..a73aeda2b 100644 --- a/doc/.cvsignore +++ b/doc/.cvsignore @@ -1,6 +1,7 @@ Makefile Makefile.in stamp-vti +stamp-vti1 *.log *.dvi *.aux @@ -19,3 +20,4 @@ stamp-vti *.info* *.html version.texi +version-tutorial.texi diff --git a/libltdl/.cvsignore b/libltdl/.cvsignore index a76fe0370..e69de29bb 100644 --- a/libltdl/.cvsignore +++ b/libltdl/.cvsignore @@ -1,21 +0,0 @@ -.libs -COPYING.LIB -Makefile -Makefile.am -Makefile.in -README -acconfig.h -acinclude.m4 -aclocal.m4 -config.h -config.h.in -config.log -config.status -configure -configure.in -libltdlc.la -libtool -ltdl.c -ltdl.h -ltdl.lo -stamp-h diff --git a/scripts/.cvsignore b/scripts/.cvsignore new file mode 100644 index 000000000..282522db0 --- /dev/null +++ b/scripts/.cvsignore @@ -0,0 +1,2 @@ +Makefile +Makefile.in From 26fb6390fbc094ce6e39bd0448bff38faa92caab Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 9 May 2001 20:25:44 +0000 Subject: [PATCH 1046/2047] (scm_i_eval): Copy expression before passing it to SCM_XEVAL. The copy operation was removed unintendedly during my change on 2001-03-25. --- libguile/eval.c | 1 + 1 file changed, 1 insertion(+) diff --git a/libguile/eval.c b/libguile/eval.c index 67a45a9dd..24f274938 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3918,6 +3918,7 @@ scm_i_eval_x (SCM exp, SCM env) SCM scm_i_eval (SCM exp, SCM env) { + exp = scm_copy_tree (exp); return SCM_XEVAL (exp, env); } From 284ab60172b49efb4960395865bbbafd17777e5b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 9 May 2001 20:26:19 +0000 Subject: [PATCH 1047/2047] *** empty log message *** --- libguile/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 0e9d9c8cf..b0a3ae171 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2001-05-09 Marius Vollmer + + * eval.c (scm_i_eval): Copy expression before passing it to + SCM_XEVAL. The copy operation was removed unintendedly during my + change on 2001-03-25. + 2001-05-09 Michael Livshin from Matthias Köppe (thanks!): From 7c582ec9b5ffe22256c11043b4cb370297db293c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 9 May 2001 21:50:43 +0000 Subject: [PATCH 1048/2047] * procs.c: Increased `scm_subr_table_room' to 800 because Guile now has 779 primitives on startup. --- libguile/ChangeLog | 5 +++++ libguile/procs.c | 5 ++++- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b0a3ae171..be24ff63f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-05-09 Martin Grabmueller + + * procs.c: Increased `scm_subr_table_room' to 800 because Guile now + has 779 primitives on startup. + 2001-05-09 Marius Vollmer * eval.c (scm_i_eval): Copy expression before passing it to diff --git a/libguile/procs.c b/libguile/procs.c index 77cd3b9b2..e9ba44f08 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -63,8 +63,11 @@ scm_subr_entry *scm_subr_table; /* libguile contained approx. 700 primitive procedures on 24 Aug 1999. */ +/* Increased to 800 on 2001-05-07 -- Guile now has 779 primitives on + startup, 786 with guile-readline. 'martin */ + int scm_subr_table_size = 0; -int scm_subr_table_room = 750; +int scm_subr_table_room = 800; SCM scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set) From 414959cad8c42777ca7050fac1229ad0feaa45f0 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Thu, 10 May 2001 00:02:51 +0000 Subject: [PATCH 1049/2047] ("evaluator" "memoization"): New test prefix block. ("transparency"): New "evaluator memoization" test. --- test-suite/tests/eval.test | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index 533b564bc..96e3afc8d 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -57,6 +57,13 @@ (with-test-prefix "evaluator" + (with-test-prefix "memoization" + + (pass-if "transparency" + (let ((x '(begin 1))) + (eval x (current-module)) + (equal? '(begin 1) x)))) + (with-test-prefix "symbol lookup" (with-test-prefix "top level" @@ -169,3 +176,5 @@ exception:out-of-range (map + '(1 2) '(3))) ))) + +;;; eval.test ends here From bc47e084475e7804c8bcaaf42c260cb41e3838ae Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Thu, 10 May 2001 00:04:45 +0000 Subject: [PATCH 1050/2047] *** empty log message *** --- test-suite/ChangeLog | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index b5f414160..78a12684b 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,9 @@ +2001-05-09 Thien-Thi Nguyen + + * tests/eval.test: ("evaluator" "memoization"): New test + prefix block. + ("transparency"): New "evaluator memoization" test. + 2001-05-08 Martin Grabmueller * tests/srfi-13.test: Added module access kludge, and uncommented @@ -35,7 +41,7 @@ * guile-test: use #!/bogus-path/..., not #!/home/dirk/... in the first line. - + 2001-03-12 Dirk Herrmann * tests/syntax.test: Added a test for let* bindings and @@ -62,7 +68,7 @@ * tests/syntax.test ("duplicate formals"): New category, move appropriate tests here. Expect them to pass. ("empty parentheses"): Expect to pass, bug has been fixed. - + * tests/alist.test: Use "'()" instead of "()" in all places where the empty list is meant. @@ -154,7 +160,7 @@ * tests/hooks.test (catch-error-returning-true, pass-if-not, catch-error-returning-false), tests/weaks.test (catch-error-returning-true, pass-if-not, - catch-error-returning-false): Removed. The macro pass-if-not was + catch-error-returning-false): Removed. The macro pass-if-not was not used. The macro catch-error-returning-false is unnecessary since exceptions are caught by the test-suite anyway. The functionality of catch-error-returning-true is provided by the new From f764e6d10d8b52c4febdfd866fe2b27c943ec1d6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 10 May 2001 13:52:27 +0000 Subject: [PATCH 1051/2047] * tests/srfi-10.test: New file. * tests/srfi-9.test: New file. * tests/srfi-13.test: Added some more tests. --- test-suite/ChangeLog | 8 ++ test-suite/tests/srfi-10.test | 30 ++++ test-suite/tests/srfi-13.test | 256 +++++++++++++++++++++++++++++++++- test-suite/tests/srfi-9.test | 42 ++++++ 4 files changed, 335 insertions(+), 1 deletion(-) create mode 100644 test-suite/tests/srfi-10.test create mode 100644 test-suite/tests/srfi-9.test diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 78a12684b..d588caf13 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,11 @@ +2001-05-10 Martin Grabmueller + + * tests/srfi-10.test: New file. + + * tests/srfi-9.test: New file. + + * tests/srfi-13.test: Added some more tests. + 2001-05-09 Thien-Thi Nguyen * tests/eval.test: ("evaluator" "memoization"): New test diff --git a/test-suite/tests/srfi-10.test b/test-suite/tests/srfi-10.test new file mode 100644 index 000000000..28caf3ad3 --- /dev/null +++ b/test-suite/tests/srfi-10.test @@ -0,0 +1,30 @@ +;;;; srfi-10.test --- Test suite for Guile's SRFI-10 functions. -*- scheme -*- +;;;; Martin Grabmueller, 2001-05-10 +;;;; +;;;; Copyright (C) 2001 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +(use-modules (srfi srfi-10)) + +(define-reader-ctor 'rx make-regexp) + +(with-test-prefix "hash-comma read extension" + + (pass-if "basic feature" + (let* ((rx #,(rx "^foo$"))) + (and (->bool (regexp-exec rx "foo")) + (not (regexp-exec rx "bar foo frob")))))) diff --git a/test-suite/tests/srfi-13.test b/test-suite/tests/srfi-13.test index 2cc0295a5..ec60836cd 100644 --- a/test-suite/tests/srfi-13.test +++ b/test-suite/tests/srfi-13.test @@ -18,7 +18,7 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA -(use-modules (srfi srfi-13)) +(use-modules (srfi srfi-13) (srfi srfi-14)) ;;; This kludge is needed, because SRFI-13 redefines some bindings in ;;; the core. @@ -95,6 +95,7 @@ (string=? (string-tabulate (lambda (idx) (integer->char (+ idx 32))) 10) " !\"#$%&'()"))) +;; Get the procedure from the library. (define string->list (module-peek '(srfi srfi-13) 'string->list)) (with-test-prefix "string->list" @@ -200,6 +201,7 @@ (string=? "foo|delim|bar|delim|" (string-join '("foo" "bar") "|delim|" 'suffix)))) +;; Get the procedure from the library. (define string-copy (module-peek '(srfi srfi-13) 'string-copy)) (with-test-prefix "string-copy" @@ -333,3 +335,255 @@ (pass-if "freestyle 2" (string=? "532!" (string-pad-right (number->string 532) 4 #\!)))) +(with-test-prefix "string-trim" + + (pass-if "empty string" + (string=? "" (string-trim ""))) + + (pass-if "no char/pred" + (string=? "foo " (string-trim " \tfoo "))) + + (pass-if "start index, pred" + (string=? "foo " (string-trim " \tfoo " char-whitespace? 1))) + + (pass-if "start and end index, pred" + (string=? "f" (string-trim " \tfoo " char-whitespace? 1 3))) + + (pass-if "start index, char" + (string=? "\tfoo " (string-trim " \tfoo " #\space 1))) + + (pass-if "start and end index, char" + (string=? "\tf" (string-trim " \tfoo " #\space 1 3))) + + (pass-if "start index, charset" + (string=? "foo " (string-trim " \tfoo " char-set:whitespace 1))) + + (pass-if "start and end index, charset" + (string=? "f" (string-trim " \tfoo " char-set:whitespace 1 3)))) + +(with-test-prefix "string-trim-right" + + (pass-if "empty string" + (string=? "" (string-trim-right ""))) + + (pass-if "no char/pred" + (string=? " \tfoo" (string-trim-right " \tfoo "))) + + (pass-if "start index, pred" + (string=? "\tfoo" (string-trim-right " \tfoo " char-whitespace? 1))) + + (pass-if "start and end index, pred" + (string=? "\tf" (string-trim-right " \tfoo " char-whitespace? 1 3))) + + (pass-if "start index, char" + (string=? "\tfoo" (string-trim-right " \tfoo " #\space 1))) + + (pass-if "start and end index, char" + (string=? "\tf" (string-trim-right " \tfoo " #\space 1 3))) + + (pass-if "start index, charset" + (string=? "\tfoo" (string-trim-right " \tfoo " char-set:whitespace 1))) + + (pass-if "start and end index, charset" + (string=? "\tf" (string-trim-right " \tfoo " char-set:whitespace 1 3)))) + +(with-test-prefix "string-trim-both" + + (pass-if "empty string" + (string=? "" (string-trim-both ""))) + + (pass-if "no char/pred" + (string=? "foo" (string-trim-both " \tfoo "))) + + (pass-if "start index, pred" + (string=? "foo" (string-trim-both " \tfoo " char-whitespace? 1))) + + (pass-if "start and end index, pred" + (string=? "f" (string-trim-both " \tfoo " char-whitespace? 1 3))) + + (pass-if "start index, char" + (string=? "\tfoo" (string-trim-both " \tfoo " #\space 1))) + + (pass-if "start and end index, char" + (string=? "\tf" (string-trim-both " \tfoo " #\space 1 3))) + + (pass-if "start index, charset" + (string=? "foo" (string-trim-both " \tfoo " char-set:whitespace 1))) + + (pass-if "start and end index, charset" + (string=? "f" (string-trim-both " \tfoo " char-set:whitespace 1 3)))) + +;; Get the procedure from the library. +(define string-fill! (module-peek '(srfi srfi-13) 'string-fill!)) + +(define s0 (make-string 200 #\!)) +(define s1 (make-string 0 #\!)) + +(with-test-prefix "string-fill!" + + (pass-if "empty string, no indices" + (string-fill! s1 #\*) + (= (string-length s1) 0)) + + (pass-if "empty string, start index" + (string-fill! s1 #\* 0) + (= (string-length s1) 0)) + + (pass-if "empty string, start and end index" + (string-fill! s1 #\* 0 0) + (= (string-length s1) 0)) + + (pass-if "no indices" + (string-fill! s0 #\*) + (char=? (string-ref s0 0) #\*)) + + (pass-if "start index" + (string-fill! s0 #\+ 10) + (char=? (string-ref s0 11) #\+)) + + (pass-if "start and end index" + (string-fill! s0 #\| 12 20) + (char=? (string-ref s0 13) #\|))) + +(with-test-prefix "string-replace" + + (pass-if "empty string(s), no indices" + (string=? "" (string-replace "" ""))) + + (pass-if "empty string(s), 1 index" + (string=? "" (string-replace "" "" 0))) + + (pass-if "empty string(s), 2 indices" + (string=? "" (string-replace "" "" 0 0))) + + (pass-if "empty string(s), 3 indices" + (string=? "" (string-replace "" "" 0 0 0))) + + (pass-if "empty string(s), 4 indices" + (string=? "" (string-replace "" "" 0 0 0 0))) + + (pass-if "no indices" + (string=? "uu" (string-replace "foo bar" "uu"))) + + (pass-if "one index" + (string=? "fuu" (string-replace "foo bar" "uu" 1))) + + (pass-if "two indices" + (string=? "fuuar" (string-replace "foo bar" "uu" 1 5))) + + (pass-if "three indices" + (string=? "fuar" (string-replace "foo bar" "uu" 1 5 1))) + + (pass-if "four indices" + (string=? "fuar" (string-replace "foo bar" "uu" 1 5 1 2)))) + +(with-test-prefix "string-tokenize" + + (pass-if "empty string, no char/pred" + (zero? (length (string-tokenize "")))) + + (pass-if "empty string, char" + (zero? (length (string-tokenize "" #\.)))) + + (pass-if "empty string, charset" + (zero? (length (string-tokenize "" char-set:punctuation)))) + + (pass-if "no char/pred" + (equal? '("foo" "bar" "!a") (string-tokenize "foo\tbar !a"))) + + (pass-if "char" + (equal? '("foo:bar" "!a") (string-tokenize "foo:bar.!a" #\.))) + + (pass-if "charset" + (equal? '("foo" "bar" "a") (string-tokenize "foo:bar.!a" + char-set:punctuation))) + + (pass-if "char, start index" + (equal? '("oo:bar" "!a") (string-tokenize "foo:bar.!a" #\. 1))) + + (pass-if "charset, start index" + (equal? '("oo" "bar" "a") (string-tokenize "foo:bar.!a" + char-set:punctuation 1))) + + (pass-if "char, start and end index" + (equal? '("oo:bar" "!") (string-tokenize "foo:bar.!a" #\. 1 9))) + + (pass-if "charset, start and end index" + (equal? '("oo" "bar") (string-tokenize "foo:bar.!a" + char-set:punctuation 1 9)))) + +(with-test-prefix "string-filter" + + (pass-if "empty string, char" + (string=? "" (string-filter "" #\.))) + + (pass-if "empty string, charset" + (string=? "" (string-filter "" char-set:punctuation))) + + (pass-if "empty string, pred" + (string=? "" (string-filter "" char-alphabetic?))) + + (pass-if "char" + (string=? "..." (string-filter ".foo.bar." #\.))) + + (pass-if "charset" + (string=? "..." (string-filter ".foo.bar." char-set:punctuation))) + + (pass-if "pred" + (string=? "foobar" (string-filter ".foo.bar." char-alphabetic?))) + + (pass-if "char, start index" + (string=? ".." (string-filter ".foo.bar." #\. 2))) + + (pass-if "charset, start index" + (string=? ".." (string-filter ".foo.bar." char-set:punctuation 2))) + + (pass-if "pred, start index" + (string=? "oobar" (string-filter ".foo.bar." char-alphabetic? 2))) + + (pass-if "char, start and end index" + (string=? "" (string-filter ".foo.bar." #\. 2 4))) + + (pass-if "charset, start and end index" + (string=? "" (string-filter ".foo.bar." char-set:punctuation 2 4))) + + (pass-if "pred, start and end index" + (string=? "oo" (string-filter ".foo.bar." char-alphabetic? 2 4)))) + +(with-test-prefix "string-delete" + + (pass-if "empty string, char" + (string=? "" (string-delete "" #\.))) + + (pass-if "empty string, charset" + (string=? "" (string-delete "" char-set:punctuation))) + + (pass-if "empty string, pred" + (string=? "" (string-delete "" char-alphabetic?))) + + (pass-if "char" + (string=? "foobar" (string-delete ".foo.bar." #\.))) + + (pass-if "charset" + (string=? "foobar" (string-delete ".foo.bar." char-set:punctuation))) + + (pass-if "pred" + (string=? "..." (string-delete ".foo.bar." char-alphabetic?))) + + (pass-if "char, start index" + (string=? "oobar" (string-delete ".foo.bar." #\. 2))) + + (pass-if "charset, start index" + (string=? "oobar" (string-delete ".foo.bar." char-set:punctuation 2))) + + (pass-if "pred, start index" + (string=? ".." (string-delete ".foo.bar." char-alphabetic? 2))) + + (pass-if "char, start and end index" + (string=? "oo" (string-delete ".foo.bar." #\. 2 4))) + + (pass-if "charset, start and end index" + (string=? "oo" (string-delete ".foo.bar." char-set:punctuation 2 4))) + + (pass-if "pred, start and end index" + (string=? "" (string-delete ".foo.bar." char-alphabetic? 2 4)))) diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test new file mode 100644 index 000000000..da33d5488 --- /dev/null +++ b/test-suite/tests/srfi-9.test @@ -0,0 +1,42 @@ +;;;; srfi-9.test --- Test suite for Guile's SRFI-9 functions. -*- scheme -*- +;;;; Martin Grabmueller, 2001-05-10 +;;;; +;;;; Copyright (C) 2001 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +(use-modules (srfi srfi-9)) + +(define-record-type :foo (make-foo x) foo? + (x get-x) (y get-y set-y!)) + +(define f (make-foo 1)) +(set-y! f 2) + +(with-test-prefix "record procedures" + + (pass-if "predicate" + (foo? f)) + + (pass-if "accessor 1" + (= 1 (get-x f))) + + (pass-if "accessor 2" + (= 2 (get-y f))) + + (pass-if "modifier" + (set-y! f #t) + (eq? #t (get-y f)))) From 163a7e0d02c8b98cee00d09837ed44f7b06a63b4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 10 May 2001 13:53:28 +0000 Subject: [PATCH 1052/2047] * srfi-13.c (scm_string_delete): Logic was inversed for charset. Fixed. --- srfi/ChangeLog | 5 +++++ srfi/srfi-13.c | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 9e8779ccd..c207f9228 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,8 @@ +2001-05-10 Martin Grabmueller + + * srfi-13.c (scm_string_delete): Logic was inversed for charset. + Fixed. + 2001-05-08 Martin Grabmueller * srfi-13.c (scm_string_copyS): Fixed nasty bug. diff --git a/srfi/srfi-13.c b/srfi/srfi-13.c index 41adb596b..4b709781f 100644 --- a/srfi/srfi-13.c +++ b/srfi/srfi-13.c @@ -2995,7 +2995,7 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0, idx = cstart; while (idx < cend) { - if (SCM_CHARSET_GET (char_pred, cstr[idx])) + if (!SCM_CHARSET_GET (char_pred, cstr[idx])) ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); idx++; } From fb1b76f432292ac6275e13f94c545e9115c435a2 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Thu, 10 May 2001 22:00:22 +0000 Subject: [PATCH 1053/2047] (resolve-module): Abstraction maintenance: Use `module-public-interface'. (resolve-module): Extend to handle selection and renaming in spec. Arg is now `spec' which can be a simple module name (list of symbols) or a interface spec. (symbol-prefix-proc): New proc. (process-define-module): Use "define-module" in error messages instead of "defmodule". Factor error into internal proc. Rewrite `use-module' and `use-syntax' handlers. Replace some single-arm `if-not' constructs w/ `or'. (process-use-modules): Arg is now `module-interface-specs', which is passed through to `resolve-interface' as before; nfc. (named-module-use!, top-repl): Abstraction maintenance: Use `provided?'. --- ice-9/boot-9.scm | 142 +++++++++++++++++++++++++++++++---------------- 1 file changed, 94 insertions(+), 48 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 55253c592..d86ca12af 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1560,7 +1560,7 @@ (if already ;; The module already exists... (if (and (or (null? maybe-autoload) (car maybe-autoload)) - (not (module-ref already '%module-public-interface #f))) + (not (module-public-interface already))) ;; ...but we are told to load and it doesn't contain source, so (begin (try-load-module name) @@ -1584,7 +1584,8 @@ (set-module-public-interface! module interface)))) (if (and (not (memq the-scm-module (module-uses module))) (not (eq? module the-root-module))) - (set-module-uses! module (append (module-uses module) (list the-scm-module))))) + (set-module-uses! module (append (module-uses module) + (list the-scm-module))))) (define (purify-module! module) "Removes bindings in MODULE which are inherited from the (guile) module." @@ -1609,17 +1610,70 @@ (module-define! module (car name) m) (make-modules-in m (cdr name))))))) -(define (resolve-interface name) - (let ((module (resolve-module name))) - (and module (module-public-interface module)))) +;; Return a module interface made from SPEC. +;; SPEC can be a list of symbols, in which case it names a module +;; whose public interface is found and returned. +;; +;; SPEC can also be of the form: +;; (MODULE-NAME [:select SELECTION] [:rename RENAMER]) +;; in which case a partial interface is newly created and returned. +;; MODULE-NAME is a list of symbols, as above; SELECTION is a list of +;; selection-specs to be imported; and RENAMER is a procedure that takes a +;; symbol and returns its new name. A selection-spec is either a symbol or a +;; pair of symbols (ORIG . SEEN), where ORIG is the name in the used module +;; and SEEN is the name in the using module. Note that SEEN is also passed +;; through RENAMER. +;; +;; The `:select' and `:rename' clauses are optional. If both are omitted, the +;; returned interface has no bindings. If the `:select' clause is omitted, +;; RENAMER operates on the used module's public interface. +;; +;; Signal error if module name is not resolvable. +;; +(define (resolve-interface spec) + (let* ((simple? (not (pair? (car spec)))) + (name (if simple? spec (car spec))) + (module (resolve-module name))) + (if (not module) + (error "no code for module" name) + (let ((public-i (module-public-interface module))) + (cond ((not public-i) + (beautify-user-module! module) + (set! public-i (module-public-interface module)))) + (if simple? + public-i + (let ((selection (cond ((memq ':select spec) => cadr) + (else (module-map (lambda (sym var) sym) + public-i)))) + (rename (cond ((memq ':rename spec) + => (lambda (x) + (eval (cadr x) (current-module)))) + (else identity))) + (partial-i (make-module 31))) + (set-module-kind! partial-i 'interface) + (for-each (lambda (sel-spec) + (let* ((direct? (symbol? sel-spec)) + (orig (if direct? + sel-spec + (car sel-spec))) + (seen (if direct? + sel-spec + (cdr sel-spec)))) + (module-add! partial-i (rename seen) + (module-variable module orig)))) + selection) + partial-i)))))) - -(define %autoloader-developer-mode #t) +(define (symbol-prefix-proc prefix) + (lambda (symbol) + (symbol-append prefix symbol))) (define (process-define-module args) (let* ((module-id (car args)) (module (resolve-module module-id #f)) - (kws (cdr args))) + (kws (cdr args)) + (unrecognized (lambda () + (error "unrecognized define-module argument" kws)))) (beautify-user-module! module) (let loop ((kws kws) (reversed-interfaces '()) @@ -1638,32 +1692,24 @@ (string->symbol (substring s 1)))))))) (case keyword ((use-module use-syntax) - (if (not (pair? (cdr kws))) - (error "unrecognized defmodule argument" kws)) - (let* ((used-name (cadr kws)) - (used-module (resolve-module used-name))) - (if (not (module-ref used-module - '%module-public-interface - #f)) - (begin - ((if %autoloader-developer-mode warn error) - "no code for module" (module-name used-module)) - (beautify-user-module! used-module))) - (let ((interface (module-public-interface used-module))) - (if (not interface) - (error "missing interface for use-module" - used-module)) - (if (eq? keyword 'use-syntax) - (set-module-transformer! - module - (module-ref interface (car (last-pair used-name)) - #f))) - (loop (cddr kws) - (cons interface reversed-interfaces) - exports)))) + (or (pair? (cdr kws)) + (unrecognized)) + (let* ((spec (cadr kws)) + (interface (resolve-interface spec))) + (and (eq? keyword 'use-syntax) + (or (symbol? (car spec)) + (error "invalid module name for use-syntax" + spec)) + (set-module-transformer! + module + (module-ref interface (car (last-pair module-name)) + #f))) + (loop (cddr kws) + (cons interface reversed-interfaces) + exports))) ((autoload) - (if (not (and (pair? (cdr kws)) (pair? (cddr kws)))) - (error "unrecognized defmodule argument" kws)) + (or (and (pair? (cdr kws)) (pair? (cddr kws))) + (unrecognized)) (loop (cdddr kws) (cons (make-autoload-interface module (cadr kws) @@ -1677,13 +1723,13 @@ (purify-module! module) (loop (cdr kws) reversed-interfaces exports)) ((export) - (if (not (pair? (cdr kws))) - (error "unrecognized defmodule argument" kws)) + (or (pair? (cdr kws)) + (unrecognized)) (loop (cddr kws) reversed-interfaces (append (cadr kws) exports))) (else - (error "unrecognized defmodule argument" kws)))))) + (unrecognized)))))) (set-current-module module) module)) @@ -1784,7 +1830,7 @@ (issue-deprecation-warning "Autoloading of compiled code modules is deprecated." "Write a Scheme file instead that uses `dynamic-link' directly."))) - + (define (init-dynamic-module modname) ;; Register any linked modules which have been registered on the C level (register-modules #f) @@ -2557,13 +2603,13 @@ ;; the guts of the use-modules macro. add the interfaces of the named ;; modules to the use-list of the current module, in order -(define (process-use-modules module-names) - (for-each (lambda (module-name) - (let ((mod-iface (resolve-interface module-name))) +(define (process-use-modules module-interface-specs) + (for-each (lambda (mif-spec) + (let ((mod-iface (resolve-interface mif-spec))) (or mod-iface - (error "no such module" module-name)) + (error "no such module" mif-spec)) (module-use! (current-module) mod-iface))) - (reverse module-names))) + module-interface-specs)) (defmacro use-modules modules `(eval-case @@ -2649,8 +2695,8 @@ (module-use! (resolve-module user) (resolve-module usee))) (define (load-emacs-interface) - (if (memq 'debug-extensions *features*) - (debug-enable 'backtrace)) + (and (provided? 'debug-extensions) + (debug-enable 'backtrace)) (named-module-use! '(guile-user) '(ice-9 emacs))) @@ -2675,10 +2721,10 @@ :use-module (ice-9 session) :use-module (ice-9 debug) :autoload (ice-9 debugger) (debug))) ;load debugger on demand - (if (memq 'threads *features*) - (named-module-use! '(guile-user) '(ice-9 threads))) - (if (memq 'regex *features*) - (named-module-use! '(guile-user) '(ice-9 regex))) + (and (provided? 'threads) + (named-module-use! '(guile-user) '(ice-9 threads))) + (and (provided? 'regex) + (named-module-use! '(guile-user) '(ice-9 regex))) (let ((old-handlers #f) (signals (if (provided? 'posix) From 7787297b59ccebfad75351aad22b5d0c20a4949f Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Thu, 10 May 2001 22:03:48 +0000 Subject: [PATCH 1054/2047] *** empty log message *** --- ice-9/ChangeLog | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 4ad7325d1..ea58e2bcc 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,21 @@ +2001-05-10 Thien-Thi Nguyen + + * boot-9.scm (resolve-module): Abstraction maintenance: Use + `module-public-interface'. + (resolve-module): Extend to handle selection and renaming in spec. + Arg is now `spec' which can be a simple module name (list of symbols) + or a interface spec. + (symbol-prefix-proc): New proc. + (%autoloader-developer-mode): Delete. + (process-define-module): Use "define-module" in error messages + instead of "defmodule". Factor error into internal proc. + Rewrite `use-module' and `use-syntax' handlers. + Replace some single-arm `if-not' constructs w/ `or'. + (process-use-modules): Arg is now `module-interface-specs', + which is passed through to `resolve-interface' as before; nfc. + (named-module-use!, top-repl): Abstraction maintenance: Use + `provided?'. + 2001-05-06 Thien-Thi Nguyen * q.scm, runq.scm, getopt-long.scm: Update copyright. From c9dcc5ae18447fe4bde3e8a818902934c8b247eb Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 10 May 2001 22:31:32 +0000 Subject: [PATCH 1055/2047] *** empty log message *** --- libguile/ChangeLog | 5 +++++ libguile/ports.c | 4 ++-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index be24ff63f..7a1bc2145 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-05-10 Marius Vollmer + + * ports.c (scm_port_revealed, scm_set_port_revealed_x): Only + accept open ports. Thanks to Quetzalcoatl Bradley! + 2001-05-09 Martin Grabmueller * procs.c: Increased `scm_subr_table_room' to 800 because Guile now diff --git a/libguile/ports.c b/libguile/ports.c index 8fa5e8067..91e2a79b5 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -557,7 +557,7 @@ SCM_DEFINE (scm_port_revealed, "port-revealed", 1, 0, 0, #define FUNC_NAME s_scm_port_revealed { port = SCM_COERCE_OUTPORT (port); - SCM_VALIDATE_PORT (1,port); + SCM_VALIDATE_OPENPORT (1,port); return SCM_MAKINUM (scm_revealed_count (port)); } #undef FUNC_NAME @@ -570,7 +570,7 @@ SCM_DEFINE (scm_set_port_revealed_x, "set-port-revealed!", 2, 0, 0, #define FUNC_NAME s_scm_set_port_revealed_x { port = SCM_COERCE_OUTPORT (port); - SCM_VALIDATE_PORT (1,port); + SCM_VALIDATE_OPENPORT (1,port); SCM_VALIDATE_INUM (2,rcount); SCM_REVEALED (port) = SCM_INUM (rcount); return SCM_UNSPECIFIED; From 230b61abbb918180c14fa8f5ae3a3ee8db4ce501 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Thu, 10 May 2001 23:34:33 +0000 Subject: [PATCH 1056/2047] Update copyright. Fix relative path bug. Thanks to Sergey Poznyakoff. --- libguile/guile-doc-snarf.in | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/libguile/guile-doc-snarf.in b/libguile/guile-doc-snarf.in index fa84c589f..954075592 100755 --- a/libguile/guile-doc-snarf.in +++ b/libguile/guile-doc-snarf.in @@ -1,18 +1,18 @@ #!/bin/sh # Extract the initialization actions for builtin things. # -# Copyright (C) 1999, 2000 Free Software Foundation, Inc. -# +# Copyright (C) 1999, 2000, 2001 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 # the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to # the Free Software Foundation, Inc., 59 Temple Place, Suite 330, @@ -40,9 +40,11 @@ test -n "${CPP+set}" || CPP="@CPP@" test -n "${AWK+set}" || AWK="@AWK@" ## Must run guile-func-name-check on the unpreprocessed source -${AWK} -f guile-func-name-check "$fullfilename" +${AWK} -f `dirname $0`/guile-func-name-check "$fullfilename" ## We must use a temporary file here, instead of a pipe, because we ## need to know if CPP exits with a non-zero status. ${CPP} -DSCM_MAGIC_SNARFER "$@" > ${temp} || exit $? cut -c1-1023 ${temp} | ${AWK} -f `dirname $0`/guile-snarf.awk ${dot_doc} + +# guile-doc-snarf ends here From 32bac999a16c1e1608ffaa4528e9573a0d0e8936 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Thu, 10 May 2001 23:38:29 +0000 Subject: [PATCH 1057/2047] *** empty log message *** --- THANKS | 1 + libguile/ChangeLog | 5 +++++ 2 files changed, 6 insertions(+) diff --git a/THANKS b/THANKS index 5d9e51890..92ca5ba8a 100644 --- a/THANKS +++ b/THANKS @@ -32,6 +32,7 @@ For fixes or providing information which led to a fix: Thien-Thi Nguyen Han-Wen Nienhuys David Pirotte + Sergey Poznyakoff Julian Satchell Bill Schottstaedt Miroslav Silovic diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 7a1bc2145..47ac504ff 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-05-10 Thien-Thi Nguyen + + * guile-doc-snarf.in: Update copyright. + Fix relative path bug. Thanks to Sergey Poznyakoff. + 2001-05-10 Marius Vollmer * ports.c (scm_port_revealed, scm_set_port_revealed_x): Only From 7f24bc58dc5e130f714d8e42cbae47b2f3450f8e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 11 May 2001 05:41:03 +0000 Subject: [PATCH 1058/2047] * boot-9.scm: Added `cond-expand' (SRFI-0) for portable feature checking. --- ice-9/ChangeLog | 5 +++ ice-9/boot-9.scm | 91 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 96 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index ea58e2bcc..676d4959c 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2001-05-11 Martin Grabmueller + + * boot-9.scm: Added `cond-expand' (SRFI-0) for portable feature + checking. + 2001-05-10 Thien-Thi Nguyen * boot-9.scm (resolve-module): Abstraction maintenance: Use diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index d86ca12af..fa6e377a6 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -2686,6 +2686,97 @@ (define load load-module) + + +;;; {`cond-expand' for SRFI-0 support.} +;;; +;;; This syntactic form expands into different commands or +;;; definitions, depending on the features provided by the Scheme +;;; implementation. +;;; +;;; Syntax: +;;; +;;; +;;; --> (cond-expand +) +;;; | (cond-expand * (else )) +;;; +;;; --> ( *) +;;; +;;; --> +;;; | (and *) +;;; | (or *) +;;; | (not ) +;;; +;;; --> +;;; +;;; Additionally, this implementation provides the +;;; s `guile' and `r5rs', so that programs can +;;; determine the implementation type and the supported standard. +;;; +;;; Currently, the following feature identifiers are supported: +;;; +;;; guile r5rs srfi-0 srfi-2 srfi-6 srfi-8 srfi-9 srfi-10 srfi-11 srfi-13 +;;; srfi-14 srfi-17 srfi-19 +;;; +;;; Remember to update the features list when adding more SRFIs. + +(define-macro (cond-expand clause . clauses) + (define features + '(guile r5rs srfi-0 srfi-2 srfi-6 srfi-8 srfi-9 srfi-10 srfi-11 srfi-13 + srfi-14 srfi-17 srfi-19)) + (let ((clauses (cons clause clauses)) + (syntax-error (lambda (cl) + (error "invalid clause in `cond-expand'" cl)))) + (letrec + ((test-clause + (lambda (clause) + (cond + ((symbol? clause) + (memq clause features)) + ((pair? clause) + (cond + ((eq? 'and (car clause)) + (let lp ((l (cdr clause))) + (cond ((null? l) + #t) + ((pair? l) + (and (test-clause (car l)) (lp (cdr l)))) + (else + (syntax-error clause))))) + ((eq? 'or (car clause)) + (let lp ((l (cdr clause))) + (cond ((null? l) + #f) + ((pair? l) + (or (test-clause (car l)) (lp (cdr l)))) + (else + (syntax-error clause))))) + ((eq? 'not (car clause)) + (cond ((not (pair? (cdr clause))) + (syntax-error clause)) + ((pair? (cddr clause)) + ((syntax-error clause)))) + (not (test-clause (cadr clause)))) + (else + (syntax-error clause)))) + (else + (syntax-error clause)))))) + (let lp ((c clauses)) + (cond + ((null? c) + (error "Unfulfilled `cond-expand'")) + ((not (pair? c)) + (syntax-error c)) + ((not (pair? (car c))) + (syntax-error (car c))) + ((test-clause (caar c)) + `(begin ,@(cdar c))) + ((eq? (caar c) 'else) + (if (pair? (cdr c)) + (syntax-error c)) + `(begin ,@(cdar c))) + (else + (lp (cdr c)))))))) From 0e70d77b81b59bf225ff33f6949e7bd7654fa00d Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 11 May 2001 09:42:11 +0000 Subject: [PATCH 1059/2047] For SRFI testing, set and export env var `LTDL_LIBRARY_PATH'. --- check-guile.in | 3 +++ 1 file changed, 3 insertions(+) diff --git a/check-guile.in b/check-guile.in index 14cd94421..e876af5e7 100644 --- a/check-guile.in +++ b/check-guile.in @@ -21,12 +21,15 @@ if [ x"$1" = x-i ] ; then else guile=libguile/guile GUILE_LOAD_PATH=$srcdir:$TEST_SUITE_DIR + LTDL_LIBRARY_PATH=$srcdir/srfi/.libs:${LTDL_LIBRARY_PATH} fi export GUILE_LOAD_PATH +export LTDL_LIBRARY_PATH if [ -f "$guile" -a -x "$guile" ] ; then echo Testing $guile ... "$@" echo with GUILE_LOAD_PATH=$GUILE_LOAD_PATH + echo with LTDL_LIBRARY_PATH=$LTDL_LIBRARY_PATH else echo ERROR: Cannot execute $guile exit 1 From c87501734a37dd9c41b2e26476bc1f4f0327c3bc Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 11 May 2001 09:44:23 +0000 Subject: [PATCH 1060/2047] *** empty log message *** --- ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ChangeLog b/ChangeLog index 39e343d44..abf5c0493 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2001-05-11 Thien-Thi Nguyen + + * check-guile.in: For SRFI testing, set and export env + var `LTDL_LIBRARY_PATH'. + 2001-05-07 Neil Jerram * AUTHORS: Add docs-related authorship details. From 3db4f31baa873898d18c88b0b6c8e0b0e954d72f Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 13 May 2001 09:00:23 +0000 Subject: [PATCH 1061/2047] Update copyright. Add blurb pointing to devel/tasks.text. --- HACKING | 29 +++++++++++++++++++++-------- 1 file changed, 21 insertions(+), 8 deletions(-) diff --git a/HACKING b/HACKING index 929e185f6..ed25e6572 100644 --- a/HACKING +++ b/HACKING @@ -1,5 +1,5 @@ Guile Hacking Guide -Copyright (c) 1996, 1997, 1998, 1999, 2000 Free software Foundation, Inc. +Copyright (c) 1996, 1997, 1998, 1999, 2000, 2001 Free software Foundation, Inc. Permission is granted to anyone to make or distribute verbatim copies of this document as received, in any medium, provided that the @@ -15,6 +15,19 @@ Copyright (c) 1996, 1997, 1998, 1999, 2000 Free software Foundation, Inc. of the Free Software Foundation are approved by the Foundation. +What to Hack ========================================================= + +You can hack whatever you want, thank GNU. + +However, to see what others have indicated as their interest (and avoid +potential wasteful duplication of effort), see devel/tasks.text. Note +that this file is available only from CVS checkout and not distributed +w/ Guile releases. + +It's also a good idea to join the guile-devel@gnu.org mailing list. +See http://www.gnu.org/software/guile/mail/mail.html for more info. + + Hacking It Yourself ================================================== As distributed, Guile needs only an ANSI C compiler and a Unix system @@ -46,7 +59,7 @@ libtool 1.3.5 --- a system for managing the zillion hairy options needed You are lost in a little maze of automatically generated files, all different. -> +> Contributing Your Changes ============================================ @@ -309,7 +322,7 @@ diff -r -u cvs-1.10/src/cvs.h cvs-1.10.ignore-hack/src/cvs.h --- cvs-1.10/src/cvs.h Mon Jul 27 04:54:11 1998 +++ cvs-1.10.ignore-hack/src/cvs.h Sun Jan 23 12:58:09 2000 @@ -516,7 +516,7 @@ - + extern int ign_name PROTO ((char *name)); void ign_add PROTO((char *ign, int hold)); -void ign_add_file PROTO((char *file, int hold)); @@ -349,27 +362,27 @@ diff -r -u cvs-1.10/src/ignore.c cvs-1.10.ignore-hack/src/ignore.c free (line); + return 1; } - + /* Parse a line of space-separated wildcards and add them to the list. */ @@ -375,6 +376,7 @@ struct stat sb; char *file; char *xdir; + char *cvsdotignore; - + /* Set SUBDIRS if we have subdirectory information in ENTRIES. */ if (entries == NULL) @@ -397,7 +399,10 @@ if (dirp == NULL) return; - + - ign_add_file (CVSDOTIGNORE, 1); + cvsdotignore = getenv("CVSDOTIGNORE"); + if (cvsdotignore == NULL || !ign_add_file (cvsdotignore, 1)) + ign_add_file (CVSDOTIGNORE, 1); + wrap_add_file (CVSDOTWRAPPER, 1); - + while ((dp = readdir (dirp)) != NULL) === patch end === @@ -384,7 +397,7 @@ This one is for pcl-cvs-2.9.2, so that `i' adds to the local Can only be used in the *cvs* buffer." (save-window-excursion - (set-buffer (find-file-noselect (expand-file-name ".cvsignore" dir))) -+ (set-buffer (find-file-noselect ++ (set-buffer (find-file-noselect + (expand-file-name (or (getenv "CVSDOTIGNORE") + ".cvsignore") + dir))) From a232c19ea5264319caa2c77d3fc51880bef8d38b Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 13 May 2001 09:02:21 +0000 Subject: [PATCH 1062/2047] *** empty log message *** --- ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ChangeLog b/ChangeLog index abf5c0493..26aeb7d7e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2001-05-13 Thien-Thi Nguyen + + * HACKING: Update copyright. + Add blurb pointing to devel/tasks.text. + 2001-05-11 Thien-Thi Nguyen * check-guile.in: For SRFI testing, set and export env From 2b0ce070a30b69edabcb67be38fcc87875807164 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 13 May 2001 11:22:01 +0000 Subject: [PATCH 1063/2047] (Modules): Remove "babbling" fixme. (The Guile module system): Rewrite intro. (General Information about Modules): Rewrite some parts. Move problems to "Module System Quirks". (Using Guile Modules): Renamed from "Loading Guile Modules". Rewrite most parts. Remove reivewme comment. (Creating Guile Modules): Review, touch up. Remove "Tkintr" comment. (Module System Quirks): New node/subsection. --- doc/scheme-modules.texi | 265 ++++++++++++++++++++++++++-------------- 1 file changed, 172 insertions(+), 93 deletions(-) diff --git a/doc/scheme-modules.texi b/doc/scheme-modules.texi index 1ff18961d..5188a43ad 100644 --- a/doc/scheme-modules.texi +++ b/doc/scheme-modules.texi @@ -3,9 +3,6 @@ @chapter Modules @cindex modules -[FIXME: somewhat babbling; should be reviewed by someone who understands -modules, once the new module system is in place] - When programs become large, naming conflicts can occur when a function or global variable defined in one file has the same name as a function or global variable in another file. Even just a @emph{similarity} @@ -73,60 +70,59 @@ module system. @node The Guile module system @section The Guile module system -In 1996 Tom Lord implemented a full-featured module system for Guile -which allows loading Scheme source files into a private name space. +In 1996 Tom Lord implemented a full-featured module system for Guile which +allows loading Scheme source files into a private name space. This system has +been in available since Guile version 1.4. +@c fixme: Actually, was it available before? 1.4 seems a bit late... -This module system is regarded as being rather idiosyncratic, and will -probably change to something more like the ML module system, so for now -I will simply describe how it works for a couple of simple cases. +For Guile version 1.5.0 and later, the system has been improved to have better +integration from C code, more fine-grained user control over interfaces, and +documentation. -So for example, the pipe interprocess communication interface -(REFFIXME), contained in @file{$srcdir/ice-9/popen.scm}, starts out with - -@smalllisp -(define-module (ice-9 popen)) -@end smalllisp - -and a user program can use - -@smalllisp -(use-modules (ice-9 popen)) -@end smalllisp - -to have access to all procedures and variables exported from the module. +Although it is anticipated that the module system implementation will +change in the future, the Scheme programming interface described in this +manual should be considered stable. The C programming interface is +considered relatively stable, although at the time of this writing, +there is still some flux. +@c fixme: Review: Need better C code interface commentary. @menu * General Information about Modules:: Guile module basics. -* Loading Guile Modules:: How to use existing modules. +* Using Guile Modules:: How to use existing modules. * Creating Guile Modules:: How to package your code into modules. * More Module Procedures:: Low-level module code. +* Module System Quirks:: Strange things to be aware of. * Included Guile Modules:: Which modules come with Guile? @end menu @node General Information about Modules @subsection General Information about Modules -A Guile module is a collection of procedures, variables and syntactic -forms (macros), which are either public or private. Public bindings are -in the so-called @dfn{export list} of a module and can be made visible -to other modules, which import them. This @dfn{module import} is called -@dfn{using} of a module, and consists of loading of the module code (if -it has not already been loaded) and making all exported items of the -loaded module visible to the importing module (@pxref{Loading Guile +A Guile module is a collection of named procedures, variables and +macros, altogether called the @dfn{bindings}, since they bind, or +associate, a symbol (the name) to a Scheme object (procedure, variable, +or macro). Within a module, all bindings are visible. Certain bindings +can be declared @dfn{public}, in which case they are added to the +module's so-called @dfn{export list}; this set of public bindings is +called the module's @dfn{public interface} (@pxref{Creating Guile Modules}). -The other side is called @dfn{defining} a module, and consists of giving -a name to a module, add procedures and variables to it and declare which -of the names should be exported when another module uses it -(@pxref{Creating Guile Modules}). +A client module @dfn{uses} a providing module's bindings by either +accessing the providing module's public interface, or by building a +custom interface (and then accessing that). In a custom interface, the +client module can @dfn{select} which bindings to access and can also +algorithmically @dfn{rename} bindings. In contrast, when using the +providing module's public interface, the entire export list is available +without renaming (@pxref{Using Guile Modules}). -All Guile modules have unique names, which are lists of one or more -symbols. Examples are @code{(ice-9 popen)} or @code{(srfi srfi-11)}. -When Guile searches for the code of a module, it constructs the name of -the file to load by concatenating the name elements with slashes between -the elements and appending a number of file name extensions from the -list @code{%load-extensions} (REFFIXME). The resulting file name is -then searched in all directories in the variable @code{%load-path}. For +To use a module, it must be found and loaded. All Guile modules have a +unique @dfn{module name}, which is a list of one or more symbols. +Examples are @code{(ice-9 popen)} or @code{(srfi srfi-11)}. When Guile +searches for the code of a module, it constructs the name of the file to +load by concatenating the name elements with slashes between the +elements and appending a number of file name extensions from the list +@code{%load-extensions} (REFFIXME). The resulting file name is then +searched in all directories in the variable @code{%load-path}. For example, the @code{(ice-9 popen)} module would result in the filename @code{ice-9/popen.scm} and searched in the installation directory of Guile and in all other directories in the load path. @@ -140,53 +136,106 @@ you can manipulate the current syntax transformer using the definition option (@pxref{Creating Guile Modules}). Please note that there are some problems with the current module system -you should keep in mind. When importing a module which exports a macro -definition, the other module must export all bindings the macro -expansion uses, too, because the expanded code would otherwise not be -able to see these definitions and issue a ``variable unbound'' error, or -worse, would use another binding which might be present in the scope of -the expansion. - -When two or more modules are imported, and they export bindings with the -same names, the last imported module wins, and the exported binding of -that last module will silently be used. This might lead to -hard-to-find errors because wrong procedures or variables are used. +you should keep in mind (@pxref{Module System Quirks}). We hope to +address these eventually. -@node Loading Guile Modules -@subsection Loading Guile Modules +@node Using Guile Modules +@subsection Using Guile Modules -@c FIXME::martin: Review me! +To use a Guile module is to access either its public interface or a +custom interface (@pxref{General Information About Modules}). Both +types of access are handled by the syntactic form @code{use-modules}, +which accepts one or more interface specifications and, upon evaluation, +arranges for those interfaces to be available to the current module. +This process may include locating and loading code for a given module if +that code has not yet been loaded (REFFIXME %load-path). -There are several modules included in the Guile distribution, and not -all of the procedures available for Guile are immedietely available when -you start up the interpreter. Some of the procedures are packaged in -modules, so that they are only accessible after the user has explicitly -said that she wants to use them. In Guile, the syntactic form -@code{use-modules} is used for telling the interpreter that he should -locate the code for a given module, load it and make the exported -bindings of the module visible to the caller. - -@c begin (scm-doc-string "boot-9.scm" "use-modules") -@deffn syntax use-modules module-specification @dots{} -All @var{module-specification}s are of the form @code{(hierarchy file)}. -One example of this is +An @dfn{interface specification} has one of two forms. The first +variation is simply to name the module, in which case its public +interface is the one accessed. For example: @smalllisp (use-modules (ice-9 popen)) @end smalllisp -@code{use-modules} allows the current Guile program to use all publicly -defined procedures and variables in the modules denoted by the -@var{module-specification}s. +Here, the interface specification is @code{(ice-9 popen)}, and the +result is that the current module now has access to @code{open-pipe}, +@code{close-pipe}, @code{open-input-pipe}, and so on (@pxref{Included +Guile Modules}). + +Note in the previous example that if the current module had already +defined @code{open-pipe}, that definition would be overwritten by the +definition in @code{(ice-9 popen)}. For this reason (and others), there +is a second variation of interface specification that not only names a +module to be accessed, but also selects bindings from it and renames +them to suit the current module's needs. For example: + +@smalllisp +(use-modules ((ice-9 popen) + :select ((open-pipe . pipe-open) close-pipe) + :rename (symbol-prefix-proc 'unixy:))) +@end smalllisp + +Here, the interface specification is more complex than before, and the +result is that a custom interface with only two bindings is created and +subsequently accessed by the current module. The mapping of old to new +names is as follows: + +@c Use `smallexample' since `table' is ugly. --ttn +@smallexample +(ice-9 popen) sees: current module sees: +open-pipe unixy:pipe-open +close-pipe unixy:close-pipe +@end smallexample + +This example also shows how to use the convenience procedure +@code{symbol-prefix-proc}. + +@c begin (scm-doc-string "boot-9.scm" "symbol-prefix-proc") +@deffn procedure symbol-prefix-proc prefix-sym +Return a procedure that prefixes its arg (a symbol) with +@var{prefix-sym}. +@c Insert gratuitous C++ slam here. --ttn @end deffn -@c end + +@c begin (scm-doc-string "boot-9.scm" "use-modules") +@deffn syntax use-modules spec @dots{} +Resolve each interface specification @var{spec} into an interface and +arrange for these to be accessible by the current module. The return +value is unspecified. + +@var{spec} can be a list of symbols, in which case it names a module +whose public interface is found and used. + +@var{spec} can also be of the form: + +@smalllisp + (MODULE-NAME [:select SELECTION] [:rename RENAMER]) +@end smalllisp + +in which case a custom interface is newly created and used. +@var{module-name} is a list of symbols, as above; @var{selection} is a +list of selection-specs; and @var{renamer} is a procedure that takes a +symbol and returns its new name. A selection-spec is either a symbol or +a pair of symbols @code{(ORIG . SEEN)}, where @var{orig} is the name in +the used module and @var{seen} is the name in the using module. Note +that @var{seen} is also passed through @var{renamer}. + +The @code{:select} and @code{:rename} clauses are optional. If both are +omitted, the returned interface has no bindings. If the @code{:select} +clause is omitted, @var{renamer} operates on the used module's public +interface. + +Signal error if module name is not resolvable. +@end deffn + @c FIXME::martin: Is this correct, and is there more to say? @c FIXME::martin: Define term and concept `system transformer' somewhere. -@deffn syntax use-syntax module-specification -Load the module @code{module-specification} and use its system +@deffn syntax use-syntax module-name +Load the module @code{module-name} and use its system transformer as the system transformer for the currently defined module, as well as installing it as the current system transformer. @end deffn @@ -195,8 +244,6 @@ as well as installing it as the current system transformer. @node Creating Guile Modules @subsection Creating Guile Modules -@c FIXME::martin: Review me! - When you want to create your own modules, you have to take the following steps: @@ -209,13 +256,13 @@ to export, or which are required by the exported procedures. Add a @code{define-module} form at the beginning. @item -Export all bindings which should be visible to importing modules, either +Export all bindings which should be in the public interface, either by using @code{define-public} or @code{export} (both documented below). @end itemize @c begin (scm-doc-string "boot-9.scm" "define-module") -@deffn syntax define-module module-specification [options @dots{}] -@var{module-specification} is of the form @code{(hierarchy file)}. One +@deffn syntax define-module module-name [options @dots{}] +@var{module-name} is of the form @code{(hierarchy file)}. One example of this is @smalllisp @@ -223,16 +270,18 @@ example of this is @end smalllisp @code{define-module} makes this module available to Guile programs under -the given @var{module-specification}. +the given @var{module-name}. The @var{options} are keyword/value pairs which specify more about the defined module. The recognized options and their meaning is shown in the following table. +@c fixme: Should we use "#:" or ":"? + @table @code -@item #:use-module @var{module} -Equivalent to a @code{(use-modules @var{module})}. Use the specified -@var{module} when loading this module. +@item #:use-module @var{interface-specification} +Equivalent to a @code{(use-modules @var{interface-specification})} +(@pxref{Using Guile Modules}). @item #:use-syntax @var{module} Use @var{module} when loading the currently defined module, and install @@ -266,17 +315,11 @@ bindings of the current module. @c begin (scm-doc-string "boot-9.scm" "define-public") @deffn syntax define-public @dots{} -Makes a procedure or variable available to programs that use the current -module. +Equivalent to @code{(begin (define foo ...) (export foo))}. @end deffn @c end -[FIXME: must say more, and explain, and also demonstrate a private name -space use, and demonstrate how one would do Python's "from Tkinter -import *" versus "import Tkinter". Must also add something about paths -and standards for contributed modules.] - @node More Module Procedures @subsection More Module Procedures @@ -294,6 +337,42 @@ Return an eval closure for the module @var{module}. @end deffn +@node Module System Quirks +@subsection Module System Quirks + +Although the programming interfaces are relatively stable, the Guile +module system itself is still evolving. Here are some situations where +usage surpasses design. + +@itemize @bullet + +@item +When using a module which exports a macro definition, the other module +must export all bindings the macro expansion uses, too, because the +expanded code would otherwise not be able to see these definitions and +issue a ``variable unbound'' error, or worse, would use another binding +which might be present in the scope of the expansion. + +@item +From C, you need to construct a @code{module-export!} call using +@code{gh_eval_str}. This is cumbersome. + +@item +When two or more used modules export bindings with the same names, the +last accessed module wins, and the exported binding of that last module +will silently be used. This might lead to hard-to-find errors because +wrong procedures or variables are used. To avoid this kind of +@dfn{name-clash} situation, use a custom interface specification +(@pxref{Using Guile Modules}). (We include this entry for the possible +benefit of users of Guile versions previous to 1.5.0, when custom +interfaces were added to the module system.) + +@item +[Add other quirks here.] + +@end itemize + + @node Included Guile Modules @subsection Included Guile Modules @@ -398,9 +477,9 @@ dynamic linking apparatus, and a more high-level interface that integrates dynamically linked libraries into the module system. @menu -* Low level dynamic linking:: -* Compiled Code Modules:: -* Dynamic Linking and Compiled Code Modules:: +* Low level dynamic linking:: +* Compiled Code Modules:: +* Dynamic Linking and Compiled Code Modules:: @end menu @node Low level dynamic linking From 0281752f6ae16617208d00c88ac5620061007fa9 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 13 May 2001 11:24:35 +0000 Subject: [PATCH 1064/2047] *** empty log message *** --- doc/ChangeLog | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/doc/ChangeLog b/doc/ChangeLog index 968f99256..986ef3d5f 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,16 @@ +2001-05-13 Thien-Thi Nguyen + + * scheme-modules.texi (Modules): Remove "babbling" fixme. + (The Guile module system): Rewrite intro. + (General Information about Modules): Rewrite some parts. + Move problems to "Module System Quirks". + (Using Guile Modules): Renamed from "Loading Guile Modules". + Rewrite most parts. + Remove reivewme comment. + (Creating Guile Modules): Review, touch up. + Remove "Tkintr" comment. + (Module System Quirks): New node/subsection. + 2001-05-06 Thien-Thi Nguyen * intro.texi (Using Guile Modules): Review; remove reviewme From c71375c94bc34e81983f0f96ea639c0edb182a4f Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 13 May 2001 19:14:41 +0000 Subject: [PATCH 1065/2047] Fixup some module-related references. --- doc/intro.texi | 32 +++++++++++++++++--------------- doc/scheme-modules.texi | 2 +- doc/scheme-procedures.texi | 12 ++++++------ 3 files changed, 24 insertions(+), 22 deletions(-) diff --git a/doc/intro.texi b/doc/intro.texi index 7077201cf..ed4061253 100644 --- a/doc/intro.texi +++ b/doc/intro.texi @@ -1,4 +1,4 @@ -@c $Id: intro.texi,v 1.7 2001-05-06 01:49:56 ttn Exp $ +@c $Id: intro.texi,v 1.8 2001-05-13 19:14:41 ttn Exp $ @page @node What is Guile? @@ -695,18 +695,21 @@ Guile has support for dividing a program into @dfn{modules}. By using modules, you can group related code together and manage the composition of complete programs from largely independent parts. -(The module system is in flux, and will likely look very different in -the future. Feel free to use the existing system anyway. Guile will -provide reasonable backwards compatability.) +(Although the module system implementation is in flux, feel free to use it +anyway. Guile will provide reasonable backwards compatability.) + +Details on the module system beyond this introductory material can be found in +@xref{Modules}. + @menu -* Using Guile Modules:: -* Writing New Modules:: -* Modules and Extensions:: +* Intro to Using Guile Modules:: +* Intro to Writing New Modules:: +* Intro to Modules and Extensions:: @end menu -@node Using Guile Modules -@subsection Using Existing Modules +@node Intro to Using Guile Modules +@subsection Intro to Using Existing Modules Guile comes with a lot of useful modules, for example for string processing or command line parsing. Additionally, there exist many @@ -747,11 +750,9 @@ one line at a time. "drwxr-sr-x 2 mgrabmue mgrabmue 1024 Mar 29 19:57 CVS" @end lisp -More details of module usage can be found in (REFFIXME). - -@node Writing New Modules -@subsection Writing New Modules +@node Intro to Writing New Modules +@subsection Intro to Writing New Modules Of course it is possible to write modules yourself. Using modules for structuring your programs makes them more readable and lets you @@ -805,8 +806,8 @@ After exporting, other modules can access the exported items simply by using @code{use-modules} to load the module @code{(foo bar)}. -@node Modules and Extensions -@subsection Modules and Extensions +@node Intro to Modules and Extensions +@subsection Intro to Modules and Extensions In addition to Scheme code you can also put new procedures and other named features that are provided by an extension into a module. @@ -829,6 +830,7 @@ write a Scheme file with this contents The file should of course be saved in the right place for autoloading, for example as @file{/usr/local/share/guile/math/bessel.scm}. + @page @node Reporting Bugs @chapter Reporting Bugs diff --git a/doc/scheme-modules.texi b/doc/scheme-modules.texi index 5188a43ad..63c86f5c4 100644 --- a/doc/scheme-modules.texi +++ b/doc/scheme-modules.texi @@ -144,7 +144,7 @@ address these eventually. @subsection Using Guile Modules To use a Guile module is to access either its public interface or a -custom interface (@pxref{General Information About Modules}). Both +custom interface (@pxref{General Information about Modules}). Both types of access are handled by the syntactic form @code{use-modules}, which accepts one or more interface specifications and, upon evaluation, arranges for those interfaces to be available to the current module. diff --git a/doc/scheme-procedures.texi b/doc/scheme-procedures.texi index 62d99e519..770f6cace 100644 --- a/doc/scheme-procedures.texi +++ b/doc/scheme-procedures.texi @@ -189,10 +189,10 @@ For quick reference, here is the syntax of the formal argument list for @example ext-param-list ::= [identifier]* [#:optional [ext-var-decl]+]? - [#:key [ext-var-decl]+ [#:allow-other-keys]?]? + [#:key [ext-var-decl]+ [#:allow-other-keys]?]? [[#:rest identifier]|[. identifier]]? -ext-var-decl ::= identifier | ( identifier expression ) +ext-var-decl ::= identifier | ( identifier expression ) @end example The characters `*', `+' and `?' are not to be taken literally; they mean @@ -231,7 +231,7 @@ two-item list in place of an optional argument, for example in: @lisp (lambda* (foo #:optional (bar 42) #:key (baz 73)) - (list foo bar baz)) + (list foo bar baz)) @end lisp @var{foo} is a fixed argument, @var{bar} is an optional argument with @@ -446,7 +446,7 @@ Let @code{f} be a variable containing such a @code{foo} data structure.@footnote{Working definitions would be: @lisp (define foo-ref vector-ref) -(define foo-set! vector-set!) +(define foo-set! vector-set!) (define f (make-vector 2 #f)) @end lisp } @@ -477,7 +477,7 @@ Let us call this new procedure @code{foo}. structure stored in @code{f}, or to write into the structure. @lisp -(set! (foo f 0) 'dum) +(set! (foo f 0) 'dum) (foo f 0) @result{} dum @end lisp @@ -613,7 +613,7 @@ example of the previous section looks like this: In Guile, the @code{syntax-rules} system is provided by the @code{(ice-9 syncase)} module. To make these facilities available in your code, include the expression @code{(use-modules (ice-9 syncase))} or -@code{(use-syntax (ice-9 syncase))} (@pxref{Loading Guile Modules}) +@code{(use-syntax (ice-9 syncase))} (@pxref{Using Guile Modules}) before the first usage of @code{define-syntax} etc. If you are writing a Scheme module, you can alternatively use one of the keywords @code{#:use-module} and @code{#:use-syntax} in your @code{define-module} From a8b56291db515c462f941612d4187ab5cfea78e2 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 13 May 2001 19:16:20 +0000 Subject: [PATCH 1066/2047] *** empty log message *** --- doc/ChangeLog | 3 +++ 1 file changed, 3 insertions(+) diff --git a/doc/ChangeLog b/doc/ChangeLog index 986ef3d5f..1c8098ab4 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,5 +1,8 @@ 2001-05-13 Thien-Thi Nguyen + * intro.texi, scheme-modules.texi, scheme-procedures.texi: + Fixup some module-related references. + * scheme-modules.texi (Modules): Remove "babbling" fixme. (The Guile module system): Rewrite intro. (General Information about Modules): Rewrite some parts. From f67712234f483a7841e36735fc5f43245345c989 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 13 May 2001 19:20:00 +0000 Subject: [PATCH 1067/2047] (Martin Grabmueller, Thien-Thi Nguyen): Update. --- AUTHORS | 23 +++++++++++++++++++++-- 1 file changed, 21 insertions(+), 2 deletions(-) diff --git a/AUTHORS b/AUTHORS index 306e5dbfe..f8c58bcb6 100644 --- a/AUTHORS +++ b/AUTHORS @@ -127,6 +127,8 @@ In the subdirectory srfi, wrote: srfi-14.scm srfi-13.c srfi-14.c +In the subdirectory scripts, wrote: + doc-snarf In the subdirectory doc, wrote: script-getopt.texi srfi-modules.texi @@ -176,6 +178,23 @@ In the subdirectory doc, changes to: In the subdirectory doc/maint, wrote: docstring.el -Thien Thi Nguyen: +Thien-Thi Nguyen: +In the top-level directory, wrote: + check-guile.in guile-tools.in +In the subdirectory ice-9, changes to: + boot-9.scm documentation.scm emacs.scm + ls.scm session.scm string-fun.scm + threads.scm +In the subdirectory scripts, wrote: + Makefile.am PROGRAM + display-commentary generate-autoload + punify read-scheme-source + use2dot +In the subdirectory scripts, changes to: + doc-snarf +In the subdirectory libguile, changes to: + guile-doc-snarf.in regex-posix.c In the subdirectory doc, changes to: - preface.texi scheme-scheduling.texi + intro.texi preface.texi + scheme-modules.texi scheme-procedures.texi + scheme-scheduling.texi From 928f20fb8730fa4e0c61c8aa44761717c349dcc7 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 13 May 2001 19:21:44 +0000 Subject: [PATCH 1068/2047] *** empty log message *** --- ChangeLog | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ChangeLog b/ChangeLog index 26aeb7d7e..d492435df 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,7 @@ 2001-05-13 Thien-Thi Nguyen + * AUTHORS (Martin Grabmueller, Thien-Thi Nguyen): Update. + * HACKING: Update copyright. Add blurb pointing to devel/tasks.text. From 5cd06d5eaac5a96af1e8d65dbf06131411fe9a6c Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 14 May 2001 16:38:08 +0000 Subject: [PATCH 1069/2047] * Deprecated some definitions. * Minor fixes. --- ChangeLog | 4 ++++ NEWS | 16 ++++++++++++++++ RELEASE | 3 ++- configure.in | 3 ++- ice-9/ChangeLog | 5 +++++ ice-9/boot-9.scm | 34 +++++++++++++++++----------------- libguile/ChangeLog | 7 +++++++ libguile/deprecation.c | 2 +- libguile/deprecation.h | 8 ++++---- 9 files changed, 58 insertions(+), 24 deletions(-) diff --git a/ChangeLog b/ChangeLog index d492435df..4366dd4a6 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2001-05-14 Dirk Herrmann + + * configure.in (SCM_DEBUG_DEPRECATED): Always defined. + 2001-05-13 Thien-Thi Nguyen * AUTHORS (Martin Grabmueller, Thien-Thi Nguyen): Update. diff --git a/NEWS b/NEWS index 425a3c662..2f666cce5 100644 --- a/NEWS +++ b/NEWS @@ -603,6 +603,22 @@ Return the argument. Use `identity' instead. +** Deprecated: -1+ + +Use `1-' instead. + +** Deprecated: return-it + +Use `noop' instead. + +** Deprecated: string-character-length + +Use `string-length' instead. + +** Deprecated: flags + +Use `logior' instead. + ** Deprecated: close-all-ports-except. This was intended for closing ports in a child process after a fork, diff --git a/RELEASE b/RELEASE index 36a494ab8..09ce29aac 100644 --- a/RELEASE +++ b/RELEASE @@ -40,7 +40,8 @@ After signal handling and threading have been fixed: gc.c: scm_remember string.c: scm_makstr - remove deprecated procedures: - boot-9.scm: eval-in-module, id + boot-9.scm: eval-in-module, id, -1+, return-it, string-character-length, + flags - remove deprecated macros: SCM_OUTOFRANGE, SCM_NALLOC, SCM_HUP_SIGNAL, SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD, diff --git a/configure.in b/configure.in index dbe5bbd28..143aa4d86 100644 --- a/configure.in +++ b/configure.in @@ -100,7 +100,7 @@ AC_ARG_ENABLE(deprecated, [ --disable-deprecated omit deprecated features [no]]) if test "$enable_deprecated" = no; then - AC_DEFINE(SCM_DEBUG_DEPRECATED) + AC_DEFINE(SCM_DEBUG_DEPRECATED, 1) else if test "$enable_deprecated" = yes || test "$enable_deprecated" = ""; then warn_default=summary @@ -109,6 +109,7 @@ else else warn_default=$enable_deprecated fi + AC_DEFINE(SCM_DEBUG_DEPRECATED, 0) AC_DEFINE_UNQUOTED(GUILE_WARN_DEPRECATED_DEFAULT, "$warn_default") fi diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 676d4959c..6adf45be1 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2001-05-14 Dirk Herrmann + + * boot-9.scm (-1+, return-it, string-character-length, flags): + Deprecated. + 2001-05-11 Martin Grabmueller * boot-9.scm: Added `cond-expand' (SRFI-0) for portable feature diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index fa6e377a6..909346062 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -107,18 +107,22 @@ (define (identity x) x) (define (1+ n) (+ n 1)) -(define (-1+ n) (+ n -1)) -(define 1- -1+) -(define return-it noop) +(define (1- n) (+ n -1)) (define (and=> value procedure) (and value (procedure value))) (define (make-hash-table k) (make-vector k '())) (begin-deprecated (define (id x) (issue-deprecation-warning "`id' is deprecated. Use `identity' instead.") - (identity x))) + (identity x)) + (define (-1+ n) + (issue-deprecation-warning "`-1+' is deprecated. Use `1-' instead.") + (1- n)) + (define (return-it . args) + (issue-deprecation-warning "`return-it' is deprecated. Use `noop' instead.") + (apply noop args))) -;;; apply-to-args is functionally redunant with apply and, worse, +;;; apply-to-args is functionally redundant with apply and, worse, ;;; is less general than apply since it only takes two arguments. ;;; ;;; On the other hand, apply-to-args is a syntacticly convenient way to @@ -145,18 +149,13 @@ (if (even? k) acc (proc acc x)) proc)))) -(define string-character-length string-length) - - - -;; A convenience function for combining flag bits. Like logior, but -;; handles the cases of 0 and 1 arguments. -;; -(define (flags . args) - (cond - ((null? args) 0) - ((null? (cdr args)) (car args)) - (else (apply logior args)))) +(begin-deprecated + (define (string-character-length s) + (issue-deprecation-warning "`string-character-length' is deprecated. Use `string-length' instead.") + (string-length s)) + (define (flags . args) + (issue-deprecation-warning "`flags' is deprecated. Use `logior' instead.") + (apply logior args))) ;;; {Symbol Properties} @@ -178,6 +177,7 @@ (symbol-pset! sym (delq! pair (symbol-pref sym)))))) ;;; {General Properties} +;;; ;; This is a more modern interface to properties. It will replace all ;; other property-like things eventually. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 47ac504ff..41f9a5755 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2001-05-14 Dirk Herrmann + + * deprecation.c: Fixed copyright date. + + * deprecation.h (DEPRECATION_H, SCM_DEPRECATION_H): Renamed + DEPRECATION_H to SCM_DEPRECATION_H. + 2001-05-10 Thien-Thi Nguyen * guile-doc-snarf.in: Update copyright. diff --git a/libguile/deprecation.c b/libguile/deprecation.c index 0dd44cb54..a8e2e6cab 100644 --- a/libguile/deprecation.c +++ b/libguile/deprecation.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,1999,2000,2001 Free Software Foundation, Inc. +/* Copyright (C) 2001 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 diff --git a/libguile/deprecation.h b/libguile/deprecation.h index 663014387..aa75824f2 100644 --- a/libguile/deprecation.h +++ b/libguile/deprecation.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef DEPRECATION_H -#define DEPRECATION_H -/* Copyright (C) 2001 Free Software Foundation, Inc. +#ifndef SCM_DEPRECATION_H +#define SCM_DEPRECATION_H +/* Copyright (C) 2001 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 @@ -58,7 +58,7 @@ SCM scm_include_deprecated_features (void); void scm_init_deprecation (void); -#endif /* DEPRECATION_H */ +#endif /* SCM_DEPRECATION_H */ /* Local Variables: From 6851c8a4464105d8c740d173966bbcab5ae5bde0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 14 May 2001 19:07:51 +0000 Subject: [PATCH 1070/2047] * Makefile.am (srfi_DATA): Added srfi-16.scm. * srfi-16.scm: New file. --- srfi/ChangeLog | 6 +++ srfi/Makefile.am | 1 + srfi/srfi-16.scm | 123 +++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 130 insertions(+) create mode 100644 srfi/srfi-16.scm diff --git a/srfi/ChangeLog b/srfi/ChangeLog index c207f9228..c48ddc226 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,9 @@ +2001-05-14 Martin Grabmueller + + * Makefile.am (srfi_DATA): Added srfi-16.scm. + + * srfi-16.scm: New file. + 2001-05-10 Martin Grabmueller * srfi-13.c (scm_string_delete): Logic was inversed for charset. diff --git a/srfi/Makefile.am b/srfi/Makefile.am index f976ec822..17108567e 100644 --- a/srfi/Makefile.am +++ b/srfi/Makefile.am @@ -45,6 +45,7 @@ srfi_DATA = srfi-2.scm \ srfi-11.scm \ srfi-13.scm \ srfi-14.scm \ + srfi-16.scm \ srfi-17.scm \ srfi-19.scm diff --git a/srfi/srfi-16.scm b/srfi/srfi-16.scm new file mode 100644 index 000000000..011bcdb46 --- /dev/null +++ b/srfi/srfi-16.scm @@ -0,0 +1,123 @@ +;;;; srfi-16.scm --- `case-lambda' for Guile + +;;; Copyright (C) 2001 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;; Boston, MA 02111-1307 USA + +;;; Commentary: + +;;; Implementation of SRFI-16. `case-lambda' is a syntactic form +;;; which permits writing functions acting different according to the +;;; number of arguments passed. +;;; +;;; The syntax of the `case-lambda' form is defined in the following +;;; EBNF grammar. +;;; +;;; +;;; --> (case-lambda ) +;;; +;;; --> ( *) +;;; +;;; --> (*) +;;; | (* . ) +;;; | +;;; +;;; The value returned by a `case-lambda' form is a procedure which +;;; matches the number of actual arguments against the signatures in +;;; the various clauses, in order. The first matching clause is +;;; selected, the corresponding values from the actual parameter list +;;; are bound to the variable names in the clauses and the body of the +;;; clause is evaluated. + +;;; Author: Martin Grabmueller + +;;; Code: +(define-module (srfi srfi-16)) + +(export-syntax case-lambda) + +(define-macro (case-lambda . clauses) + + ;; Return the length of the list @var{l}, but allow dotted list. + ;; + (define (alength l) + (cond ((null? l) 0) + ((pair? l) (+ 1 (alength (cdr l)))) + (else 0))) + + ;; Return @code{#t} if @var{l} is a dotted list, @code{#f} if it is + ;; a normal list. + ;; + (define (dotted? l) + (cond ((null? l) #f) + ((pair? l) (dotted? (cdr l))) + (else #t))) + + ;; Return the expression for accessing the @var{index}th element of + ;; the list called @var{args-name}. If @var{tail?} is true, code + ;; for accessing the list-tail is generated, otherwise for accessing + ;; the list element itself. + ;; + (define (accessor args-name index tail?) + (if tail? + (case index + ((0) `,args-name) + ((1) `(cdr ,args-name)) + ((2) `(cddr ,args-name)) + ((3) `(cdddr ,args-name)) + ((4) `(cddddr ,args-name)) + (else `(list-tail ,args-name ,index))) + (case index + ((0) `(car ,args-name)) + ((1) `(cadr ,args-name)) + ((2) `(caddr ,args-name)) + ((3) `(cadddr ,args-name)) + (else `(list-ref ,args-name ,index))))) + + ;; Generate the binding lists of the variables of one case-lambda + ;; clause. @var{vars} is the (possibly dotted) list of variables + ;; and @var{args-name} is the generated name used for the argument + ;; list. + ;; + (define (gen-temps vars args-name) + (let lp ((v vars) (i 0)) + (cond ((null? v) '()) + ((pair? v) + (cons `(,(car v) ,(accessor args-name i #f)) + (lp (cdr v) (+ i 1)))) + (else `((,v ,(accessor args-name i #t))))))) + + ;; Generate the cond clauses for each of the clauses of case-lambda, + ;; including the parameter count check, binding of the parameters + ;; and the code of the corresponding body. + ;; + (define (gen-clauses l length-name args-name) + (cond ((null? l) (list '(else (error "too few arguments")))) + (else + (cons + `((,(if (dotted? (caar l)) '>= '=) + ,length-name ,(alength (caar l))) + (let ,(gen-temps (caar l) args-name) + ,@(cdar l))) + (gen-clauses (cdr l) length-name args-name))))) + + (let ((args-name (gensym)) + (length-name (gensym))) + (let ((proc + `(lambda ,args-name + (let ((,length-name (length ,args-name))) + (cond ,@(gen-clauses clauses length-name args-name)))))) + proc))) From 1d00af09c77f9b31f2cbfa247452ee164aa83326 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 14 May 2001 19:09:50 +0000 Subject: [PATCH 1071/2047] * boot-9.scm (cond-expand): Reduce feature list to built-in features. --- ice-9/ChangeLog | 5 +++++ ice-9/boot-9.scm | 9 +++++---- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 6adf45be1..a81605198 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2001-05-14 Martin Grabmueller + + * boot-9.scm (cond-expand): Reduce feature list to built-in + features. + 2001-05-14 Dirk Herrmann * boot-9.scm (-1+, return-it, string-character-length, flags): diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 909346062..7134743db 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -2715,15 +2715,16 @@ ;;; ;;; Currently, the following feature identifiers are supported: ;;; -;;; guile r5rs srfi-0 srfi-2 srfi-6 srfi-8 srfi-9 srfi-10 srfi-11 srfi-13 -;;; srfi-14 srfi-17 srfi-19 +;;; guile r5rs srfi-0 srfi-6 ;;; ;;; Remember to update the features list when adding more SRFIs. (define-macro (cond-expand clause . clauses) + (define features - '(guile r5rs srfi-0 srfi-2 srfi-6 srfi-8 srfi-9 srfi-10 srfi-11 srfi-13 - srfi-14 srfi-17 srfi-19)) + ;; Adjust the above comment when changing this. + '(guile r5rs srfi-0 srfi-6)) + (let ((clauses (cons clause clauses)) (syntax-error (lambda (cl) (error "invalid clause in `cond-expand'" cl)))) From dfdf58267a5d46e41d0ecc2166a48c20cc65de8f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 14 May 2001 19:12:42 +0000 Subject: [PATCH 1072/2047] * AUTHORS (Martin Grabmueller): Added srfi-16.scm. * NEWS: Updated and corrected NEWS entries for SRFI modules. --- AUTHORS | 1 + NEWS | 12 +++++++++++- 2 files changed, 12 insertions(+), 1 deletion(-) diff --git a/AUTHORS b/AUTHORS index f8c58bcb6..357d4d1d6 100644 --- a/AUTHORS +++ b/AUTHORS @@ -127,6 +127,7 @@ In the subdirectory srfi, wrote: srfi-14.scm srfi-13.c srfi-14.c + srfi-16.scm In the subdirectory scripts, wrote: doc-snarf In the subdirectory doc, wrote: diff --git a/NEWS b/NEWS index 2f666cce5..bedb80f45 100644 --- a/NEWS +++ b/NEWS @@ -33,6 +33,9 @@ Changes since Guile 1.4: ** New SRFI modules have been added: +SRFI-0 `cond-expand' is now supported in Guile, without requiring +using a module. + (srfi srfi-2) exports and-let*. (srfi srfi-6) is a dummy module for now, since guile already provides @@ -43,13 +46,20 @@ Changes since Guile 1.4: (srfi srfi-9) exports define-record-type. +(srfi srfi-10) exports define-reader-ctor and implements the reader + extension #,(). + (srfi srfi-11) exports let-values and let*-values. (srfi srfi-13) implements the SRFI String Library. (srfi srfi-14) implements the SRFI Character-Set Library. -(srfi srfi-14) implements the SRFI Time/Date Library. +(srfi srfi-17) implements setter and getter-with-setter and redefines + some accessor procedures as procedures with getters. (such as car, + cdr, vector-ref etc.) + +(srfi srfi-19) implements the SRFI Time/Date Library. ** New scripts / "executable modules" From e8cd769d381cdaaf72701099923064f3be2312b5 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 14 May 2001 19:25:32 +0000 Subject: [PATCH 1073/2047] Move author tag outside commentary; nfc. --- scripts/PROGRAM | 4 ++-- scripts/display-commentary | 4 ++-- scripts/doc-snarf | 4 ++-- scripts/generate-autoload | 4 ++-- scripts/punify | 4 ++-- scripts/read-scheme-source | 11 ++++++----- scripts/use2dot | 4 ++-- 7 files changed, 18 insertions(+), 17 deletions(-) diff --git a/scripts/PROGRAM b/scripts/PROGRAM index ea0146f15..3511ccdfc 100755 --- a/scripts/PROGRAM +++ b/scripts/PROGRAM @@ -22,6 +22,8 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA +;;; Author: J.R.Hacker + ;;; Commentary: ;; Usage: PROGRAM [ARGS] @@ -29,8 +31,6 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; PROGRAM does something. ;; ;; TODO: Write it! -;; -;; Author: J.R.Hacker ;;; Code: diff --git a/scripts/display-commentary b/scripts/display-commentary index 537ef2ca8..1eeb842d8 100755 --- a/scripts/display-commentary +++ b/scripts/display-commentary @@ -22,13 +22,13 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA +;;; Author: Thien-Thi Nguyen + ;;; Commentary: ;; Usage: display-commentary FILE1 FILE2 ... ;; ;; Display Commentary section from FILE1, FILE2 and so on. -;; -;; Author: Thien-Thi Nguyen ;;; Code: diff --git a/scripts/doc-snarf b/scripts/doc-snarf index ae417c0f2..941682e78 100755 --- a/scripts/doc-snarf +++ b/scripts/doc-snarf @@ -22,6 +22,8 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA +;;; Author: Martin Grabmueller + ;;; Commentary: ;; Usage: doc-snarf FILE @@ -75,8 +77,6 @@ This procedure foos, or bars, depending on the argument @var{braz}. ;; More parameterization. ;; ../libguile/guile-doc-snarf emulation -;;; Author: Martin Grabmueller - (define doc-snarf-version "0.0.2") ; please update before publishing! ;;; Code: diff --git a/scripts/generate-autoload b/scripts/generate-autoload index 523b6049d..eef2b88c5 100755 --- a/scripts/generate-autoload +++ b/scripts/generate-autoload @@ -22,6 +22,8 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA +;;; Author: Thien-Thi Nguyen + ;;; Commentary: ;; Usage: generate-autoload [OPTIONS] FILE1 FILE2 ... @@ -55,8 +57,6 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; (generate-autoload "generate-autoload") ;; (generate-autoload "--target" "(my module)" "generate-autoload") ;; (apply generate-autoload "--target" "(my module)" '("foo" "bar" "baz")) -;; -;; Author: Thien-Thi Nguyen ;;; Code: diff --git a/scripts/punify b/scripts/punify index e5b0f9d78..1cc318fb6 100755 --- a/scripts/punify +++ b/scripts/punify @@ -22,6 +22,8 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA +;;; Author: Thien-Thi Nguyen + ;;; Commentary: ;; Usage: punify FILE1 FILE2 ... @@ -38,8 +40,6 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; TODO: Read from stdin. ;; Handle vectors. ;; Identifier punification. -;; -;; Author: Thien-Thi Nguyen ;;; Code: diff --git a/scripts/read-scheme-source b/scripts/read-scheme-source index 54cad4db0..48e96058a 100755 --- a/scripts/read-scheme-source +++ b/scripts/read-scheme-source @@ -22,6 +22,8 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA +;;; Author: Thien-Thi Nguyen + ;;; Commentary: ;; Usage: read-scheme-source FILE1 FILE2 ... @@ -35,7 +37,7 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; ;; (quote (filename FILENAME)) ;; -;; (quote (comment :leading-parens N +;; (quote (comment :leading-semicolons N ;; :text LINE)) ;; ;; (quote (whitespace :text LINE)) @@ -77,8 +79,6 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; ;; TODO: Add option "--clump-comments", maybe w/ different clumping styles. ;; Make `annotate!' extensible. -;; -;; Author: Thien-Thi Nguyen ;;; Code: @@ -154,8 +154,9 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ((regexp-exec all-comment-rx line) => (lambda (m) (nb! `'(comment - :leading-parens ,(let ((m1 (vector-ref m 1))) - (- (cdr m1) (car m1))) + :leading-semicolons + ,(let ((m1 (vector-ref m 1))) + (- (cdr m1) (car m1))) :text ,line)))) (else (unread-string line p) diff --git a/scripts/use2dot b/scripts/use2dot index 1b59519ae..2f1b58d04 100755 --- a/scripts/use2dot +++ b/scripts/use2dot @@ -22,6 +22,8 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA +;;; Author: Thien-Thi Nguyen based on PERL script by Keisuke Nishida + ;;; Commentary: ;; Usage: use2dot [OPTIONS] [FILE ...] @@ -51,8 +53,6 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; - add `--load-synonyms' option ;; - add `--ignore-module' option ;; - handle arbitrary command-line key/value configuration -;; -;; Author: Thien-Thi Nguyen based on PERL script by Keisuke Nishida ;;; Code: From b50ba18c268baa024f943f618b7eda425f4ea06d Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 14 May 2001 19:27:37 +0000 Subject: [PATCH 1074/2047] *** empty log message *** --- scripts/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/scripts/ChangeLog b/scripts/ChangeLog index 9967dac99..466a582fa 100644 --- a/scripts/ChangeLog +++ b/scripts/ChangeLog @@ -1,3 +1,9 @@ +2001-05-14 Thien-Thi Nguyen + + * PROGRAM, display-commentary, doc-snarf, generate-autoload, + punify, read-scheme-source, use2dot: Move author tag outside + commentary; nfc. + 2001-05-08 Thien-Thi Nguyen * read-scheme-source: New file From 554901a3adf4fa26f0aa6f0372c11daa5ae2cd91 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 14 May 2001 21:37:51 +0000 Subject: [PATCH 1075/2047] * srfi-13-14.texi: Removed. * srfi-modules.texi (SRFI-13): Merged SRFI-13 docs into SRFI chapter. (SRFI-14): Merged SRFI-14 too. * guile.texi (Top): Remove inclusion of obsolete SRFI-13/14 file. * srfi-modules.texi (SRFI-0): New section. (SRFI-16): New section. Change `--' to `-' throughout. --- doc/ChangeLog | 15 + doc/Makefile.am | 2 +- doc/guile.texi | 4 +- doc/srfi-13-14.texi | 0 doc/srfi-modules.texi | 1221 ++++++++++++++++++++++++++++++++++++++++- 5 files changed, 1220 insertions(+), 22 deletions(-) delete mode 100644 doc/srfi-13-14.texi diff --git a/doc/ChangeLog b/doc/ChangeLog index 1c8098ab4..8b2ac8559 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,18 @@ +2001-05-14 Martin Grabmueller + + * srfi-13-14.texi: Removed. + + * srfi-modules.texi (SRFI-13): Merged SRFI-13 docs into SRFI + chapter. + (SRFI-14): Merged SRFI-14 too. + + * guile.texi (Top): Remove inclusion of obsolete SRFI-13/14 file. + + * srfi-modules.texi (SRFI-0): New section. + (SRFI-16): New section. + + Change `--' to `-' throughout. + 2001-05-13 Thien-Thi Nguyen * intro.texi, scheme-modules.texi, scheme-procedures.texi: diff --git a/doc/Makefile.am b/doc/Makefile.am index c51cf392f..739938988 100644 --- a/doc/Makefile.am +++ b/doc/Makefile.am @@ -35,7 +35,7 @@ guile_TEXINFOS = preface.texi intro.texi scheme-intro.texi \ scheme-reading.texi scheme-indices.texi slib.texi posix.texi \ expect.texi scsh.texi tcltk.texi scripts.texi gh.texi scm.texi \ appendices.texi indices.texi script-getopt.texi data-rep.texi \ - extend.texi srfi-13-14.texi repl-modules.texi srfi-modules.texi \ + extend.texi repl-modules.texi srfi-modules.texi \ AUTHORS guile_tut_TEXINFOS = guile-tut.texi AUTHORS diff --git a/doc/guile.texi b/doc/guile.texi index 6c8c57338..633b2b03a 100644 --- a/doc/guile.texi +++ b/doc/guile.texi @@ -80,7 +80,7 @@ by the Free Software Foundation. @sp 10 @comment The title is printed in a large font. @title Guile Reference Manual -@subtitle $Id: guile.texi,v 1.8 2001-05-02 21:50:15 mgrabmue Exp $ +@subtitle $Id: guile.texi,v 1.9 2001-05-14 21:37:51 mgrabmue Exp $ @subtitle For use with Guile @value{VERSION} @include AUTHORS @@ -169,7 +169,6 @@ Part III: Guile Modules * SLIB:: Using the SLIB Scheme library. * POSIX:: POSIX system calls and networking. * SRFI Support:: Support for various SRFIs. -* SRFI-13/14:: String library and character set library. * Readline Support:: Module for using the readline library. * Value History:: Maintaining a value history in the REPL. * Expect:: Controlling interactive programs with Guile. @@ -253,7 +252,6 @@ Indices @include slib.texi @include posix.texi @include srfi-modules.texi -@include srfi-13-14.texi @include repl-modules.texi @include expect.texi @include scsh.texi diff --git a/doc/srfi-13-14.texi b/doc/srfi-13-14.texi deleted file mode 100644 index e69de29bb..000000000 diff --git a/doc/srfi-modules.texi b/doc/srfi-modules.texi index e611414c9..0ff767d46 100644 --- a/doc/srfi-modules.texi +++ b/doc/srfi-modules.texi @@ -1,25 +1,94 @@ @node SRFI Support @chapter Various SRFI Support Modules -In addition to the string and character--set libraries --- documented in -the next chapter --- Guile has support for a number of SRFIs. This +SRFI is an acronym for Scheme Request For Implementation. The SRFI +documents define a lot of syntactic and procedure extensions to standard +Scheme as defined in R5RS. + +In addition to the string and character-set libraries---documented in +the next chapter---Guile has support for a number of SRFIs. This chapter gives an overview over the available SRFIs and some usage hints. -For complete documentation, we advise you to get the relevant SRFI -documents from the SRFI home page @url{http://srfi.schemers.org}. +For complete documentation, design rationales and further examples, we +advise you to get the relevant SRFI documents from the SRFI home page +@url{http://srfi.schemers.org}. @menu +* SRFI-0:: cond-expand * SRFI-2:: and-let*. * SRFI-6:: Basic String Ports. * SRFI-8:: receive. * SRFI-9:: define-record-type. -* SRFI-10:: Hash--Comma Reader Extension. +* SRFI-10:: Hash-Comma Reader Extension. * SRFI-11:: let-values and let-values*. +* SRFI-13:: String library. +* SRFI-14:: Character-set library. +* SRFI-16:: case-lambda * SRFI-17:: Generalized set! @end menu +@node SRFI-0 +@section SRFI-0 - cond-expand + +@c FIXME::martin: Review me! + +SRFI-0 defines a means for checking whether a Scheme implementation has +support for a specified feature. The syntactic form @code{cond-expand}, +which implements this means, has the following syntax. + +@example + + --> (cond-expand +) + | (cond-expand * (else )) + + --> ( *) + + --> + | (and *) + | (or *) + | (not ) + + --> +@end example + +When evaluated, this form checks all clauses in order, until it finds +one whose feature requirement is satisfied. Then the form expands into +the commands or definitions in the clause. A requirement is tested as +follows: + +@itemize @bullet +@item +If it is a symbol, it is satisfied if the feature identifier is +supported. + +@item +If it is an @code{and} form, all requirements must be satisfied. If no +requirements are given, it is satisfied, too. + +@item +If it is an @code{or} form, at least one of the requirements must be +satisfied. If no requirements are given, it is not satisfied. + +@item +If it is a @code{not} form, the feature requirement must @emph{not} be +satisfied. + +@item +If the feature requirement is the keyword @code{else} and it is the last +clause, it is satisfied if no prior clause matched. +@end itemize + +Since @code{cond-expand} is needed to tell what a Scheme implementation +provides, it must be accessible without using any +implementation-dependant operations, such as @code{use-modules} in +Guile. Thus, it is not necessary to use any module to get access to +this form. + + @node SRFI-2 -@section SRFI-2 -- and-let* +@section SRFI-2 - and-let* + +@c FIXME::martin: Review me! The syntactic form @code{and-let*} combines the conditional evaluation form @code{and} with the binding form @var{let*}. Each argument @@ -29,9 +98,26 @@ the false value @code{#f}. Use @code{(use-modules (srfi srfi-2)} to access this syntax form. +A short example will demonstrate how it works. In the first expression, +@var{x} will get bound to 1, but the next expression (@code{#f}) is +false, so evaluation of the form is stopped, and @code{#f} is returned. +In the next expression, @var{x} is bound to 1, @var{y} is bound to +@code{#t} and since no expression in the binding section was false, the +body of the @code{and-let*} expression is evaluated, which in this case +returns the value of @var{x}. + +@lisp +(and-let* ((x 1) (y #f)) 42) +@result{} +#f +(and-let* ((x 1) (y #t)) x) +@result{} +1 +@end lisp + @node SRFI-6 -@section SRFI-6 -- Basic String Ports +@section SRFI-6 - Basic String Ports SRFI-6 defines the procedures @code{open-input-string}, @code{open-output-string} and @code{get-output-string}. These @@ -41,14 +127,14 @@ SRFI-6 will be factored out of the core library in the future, so using this module does not hurt, after all. @node SRFI-8 -@section SRFI-8 -- receive +@section SRFI-8 - receive -@code{receive} is a syntax for making the handling of multiple--value +@code{receive} is a syntax for making the handling of multiple-value procedures easier. It is documented in @xref{Multiple Values}. @node SRFI-9 -@section SRFI-9 -- define-record-type +@section SRFI-9 - define-record-type This is the SRFI way for defining record types. The Guile implementation is a layer above Guile's normal record construction @@ -96,9 +182,9 @@ guile> (foo? 1) @node SRFI-10 -@section SRFI-10 -- Hash--Comma Reader Extension +@section SRFI-10 - Hash-Comma Reader Extension -@cindex hash--comma +@cindex hash-comma @cindex #,() The module @code{(srfi srfi-10)} implements the syntax extension @code{#,()}, also called hash-comma, which is defined in SRFI-10. @@ -128,20 +214,20 @@ Please note the quote before the @code{#,(file ...)} expression. This is necessary because ports are not self-evaluating in Guile. @deffn procedure define-reader-ctor symbol proc -Define @var{proc} as the reader constructor for hash--comma forms with a +Define @var{proc} as the reader constructor for hash-comma forms with a tag @var{symbol}. @var{proc} will be applied to the datum(s) following -the tag in the hash--comma expression after the complete form has been +the tag in the hash-comma expression after the complete form has been read in. The result of @var{proc} is returned by the Scheme reader. @end deffn @node SRFI-11 -@section SRFI-11 -- let-values +@section SRFI-11 - let-values This module implements the binding forms for multiple values @code{let-values} and @code{let-values*}. These forms are similar to @code{let} and @code{let*} (REFFIXME), but they support binding of the -values returned by multiple--valued expressions. +values returned by multiple-valued expressions. Write @code{(use-modules (srfi srfi-11))} to make the bindings available. @@ -157,12 +243,1111 @@ available. @code{let-values} performs all bindings simultaneously, which means that no expression in the binding clauses may refer to variables bound in the same clause list. @code{let-values*}, on the other hand, performs the -bindings sequentially, just like @code{let*} does for single--valued +bindings sequentially, just like @code{let*} does for single-valued expressions. +@node SRFI-13 +@section SRFI-13 - String Library + +In this section, we will describe all procedures defined in SRFI-13 +(string library) and implemented by the module @code{(srfi srfi-13)}. + +Note that only the procedures from SRFI-13 are documented here which are +not already contained in Guile. For procedures not documented here +please refer to the relevant chapters in the Guile Reference Manual, for +example the documentation of strings and string procedures (REFFIXME). + +All of the procedures defined in SRFI-13, which are not already included +in the Guile core library, are implemented in the module @code{(srfi +srfi-13)}. The procedures which are both in Guile and in SRFI-13, but +which are slightly extended, have been implemented in this module, and +the bindings overwrite those in the Guile core. + +The procedures which are defined in the section @emph{Low-level +procedures} of SRFI-13 for parsing optional string indices, substring +specification checking and Knuth-Morris-Pratt-Searching are not +implemented. + +The procedures @code{string-contains} and @code{string-contains-ci} are +not implemented very efficiently at the moment. This will be changed as +soon as possible. + +@menu +* Loading SRFI-13:: How to load SRFI-13 support. +* SRFI-13 Predicates:: String predicates. +* SRFI-13 Constructors:: String constructing procedures. +* SRFI-13 List/String Conversion:: Conversion from/to lists. +* SRFI-13 Selection:: Selection portions of strings. +* SRFI-13 Modification:: Modfify strings in-place. +* SRFI-13 Comparison:: Compare strings. +* SRFI-13 Prefixes/Suffixes:: Detect common pre-/suffixes. +* SRFI-13 Searching:: Searching for substrings. +* SRFI-13 Case Mapping:: Mapping to lower-/upper-case. +* SRFI-13 Reverse/Append:: Reverse and append strings. +* SRFI-13 Fold/Unfold/Map:: Construct/deconstruct strings. +* SRFI-13 Replicate/Rotate:: Replacate and rotate portions of strings. +* SRFI-13 Miscellaneous:: Left-over string procedures. +* SRFI-13 Filtering/Deleting:: Filter and delete characters from strings. +@end menu + + +@node Loading SRFI-13 +@subsection Loading SRFI-13 + +When Guile is properly installed, SRFI-13 support can be loaded into a +running Guile by using the @code{(srfi srfi-13)} module. + +@example +$ guile +guile> (use-modules (srfi srfi-13)) +guile> +@end example + +When this step causes any errors, Guile is not properly installed. + +One possible reason is that Guile cannot find either the Scheme module +file @file{srfi-13.scm}, or it cannot find the shared object file +@file{libguile-srfi-srfi-13-14.so}. Make sure that the former is in the +Guile load path and that the latter is either installed in some default +location like @file{/usr/local/lib} or that the directory it was +installed to is in your @code{LTDL_LIBRARY_PATH}. The same applies to +@file{srfi-14.scm}. + +Now you can test whether the SRFI-13 procedures are working by calling +the @code{string-concatenate} procedure. + +@example +guile> (string-concatenate '("Hello" " " "World!")) +"Hello World!" +@end example + +@node SRFI-13 Predicates +@subsection Predicates + +In addition to the primitives @code{string?} and @code{string-null?}, +which are already in the Guile core, the string predicates +@code{string-any} and @code{string-every} are defined by SRFI-13. + +@deffn primitive string-any pred s [start end] +Check if the predicate @var{pred} is true for any character in +the string @var{s}, proceeding from left (index @var{start}) to +right (index @var{end}). If @code{string-any} returns true, +the returned true value is the one produced by the first +successful application of @var{pred}. +@end deffn + +@deffn primitive string-every pred s [start end] +Check if the predicate @var{pred} is true for every character +in the string @var{s}, proceeding from left (index @var{start}) +to right (index @var{end}). If @code{string-every} returns +true, the returned true value is the one produced by the final +application of @var{pred} to the last character of @var{s}. +@end deffn + + +@c =================================================================== + +@node SRFI-13 Constructors +@subsection Constructors + +SRFI-13 defines several procedures for constructing new strings. In +addition to @code{make-string} and @code{string} (available in the Guile +core library), the procedure @code{string-tabulate} does exist. + +@deffn primitive string-tabulate proc len +@var{proc} is an integer->char procedure. Construct a string +of size @var{len} by applying @var{proc} to each index to +produce the corresponding string element. The order in which +@var{proc} is applied to the indices is not specified. +@end deffn + + +@c =================================================================== + +@node SRFI-13 List/String Conversion +@subsection List/String Conversion + +The procedure @code{string->list} is extended by SRFI-13, that is why it +is included in @code{(srfi srfi-13)}. The other procedures are new. +The Guile core already contains the procedure @code{list->string} for +converting a list of characters into a string (REFFIXME). + +@deffn primitive string->list str [start end] +Convert the string @var{str} into a list of characters. +@end deffn + +@deffn primitive reverse-list->string chrs +An efficient implementation of @code{(compose string->list +reverse)}: + +@smalllisp +(reverse-list->string '(#\a #\B #\c)) @result{} "cBa" +@end smalllisp +@end deffn + +@deffn primitive string-join ls [delimiter grammar] +Append the string in the string list @var{ls}, using the string +@var{delim} as a delimiter between the elements of @var{ls}. +@var{grammar} is a symbol which specifies how the delimiter is +placed between the strings, and defaults to the symbol +@code{infix}. + +@table @code +@item infix +Insert the separator between list elements. An empty string +will produce an empty list. + +@item string-infix +Like @code{infix}, but will raise an error if given the empty +list. + +@item suffix +Insert the separator after every list element. + +@item prefix +Insert the separator before each list element. +@end table +@end deffn + + +@c =================================================================== + +@node SRFI-13 Selection +@subsection Selection + +These procedures are called @dfn{selectors}, because they access +information about the string or select pieces of a given string. + +Additional selector procedures are documented in the Strings section +(REFFIXME), like @code{string-length} or @code{string-ref}. + +@code{string-copy} is also available in core Guile, but this version +accepts additional start/end indices. + +@deffn primitive string-copy str [start end] +Return a freshly allocated copy of the string @var{str}. If +given, @var{start} and @var{end} delimit the portion of +@var{str} which is copied. +@end deffn + +@deffn primitive substring/shared str start [end] +Like @code{substring}, but the result may share memory with the +argument @var{str}. +@end deffn + +@deffn primitive string-copy! target tstart s [start end] +Copy the sequence of characters from index range [@var{start}, +@var{end}) in string @var{s} to string @var{target}, beginning +at index @var{tstart}. The characters are copied left-to-right +or right-to-left as needed - the copy is guaranteed to work, +even if @var{target} and @var{s} are the same string. It is an +error if the copy operation runs off the end of the target +string. +@end deffn + +@deffn primitive string-take s n +@deffnx primitive string-take-right s n +Return the @var{n} first/last characters of @var{s}. +@end deffn + +@deffn primitive string-drop s n +@deffnx primitive string-drop-right s n +Return all but the first/last @var{n} characters of @var{s}. +@end deffn + +@deffn primitive string-pad s len [chr start end] +@deffnx primitive string-pad-right s len [chr start end] +Take that characters from @var{start} to @var{end} from the +string @var{s} and return a new string, right(left)-padded by the +character @var{chr} to length @var{len}. If the resulting +string is longer than @var{len}, it is truncated on the right (left). +@end deffn + +@deffn primitive string-trim s [char_pred start end] +@deffnx primitive string-trim-right s [char_pred start end] +@deffnx primitive string-trim-both s [char_pred start end] +Trim @var{s} by skipping over all characters on the left/right/both +sides of the string that satisfy the parameter @var{char_pred}: + +@itemize @bullet +@item +if it is the character @var{ch}, characters equal to +@var{ch} are trimmed, + +@item +if it is a procedure @var{pred} characters that +satisfy @var{pred} are trimmed, + +@item +if it is a character set, characters in that set are trimmed. +@end itemize + +If called without a @var{char_pred} argument, all whitespace is +trimmed. +@end deffn + + +@c =================================================================== + +@node SRFI-13 Modification +@subsection Modification + +The procedure @code{string-fill!} is extended from R5RS because it +accepts optional start/end indices. This bindings shadows the procedure +of the same name in the Guile core. The second modification procedure +@code{string-set!} is documented in the Strings section (REFFIXME). + +@deffn primitive string-fill! str chr [start end] +Stores @var{chr} in every element of the given @var{str} and +returns an unspecified value. +@end deffn + + +@c =================================================================== + +@node SRFI-13 Comparison +@subsection Comparison + +The procedures in this section are used for comparing strings in +different ways. The comparison predicates differ from those in R5RS in +that they do not only return @code{#t} or @code{#f}, but the mismatch +index in the case of a true return value. + +@code{string-hash} and @code{string-hash-ci} are for calculating hash +values for strings, useful for implementing fast lookup mechanisms. + +@deffn primitive string-compare s1 s2 proc_lt proc_eq proc_gt [start1 end1 start2 end2] +@deffnx primitive string-compare-ci s1 s2 proc_lt proc_eq proc_gt [start1 end1 start2 end2] +Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the +mismatch index, depending upon whether @var{s1} is less than, +equal to, or greater than @var{s2}. The mismatch index is the +largest index @var{i} such that for every 0 <= @var{j} < +@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] - that is, +@var{i} is the first position that does not match. The +character comparison is done case-insensitively. +@end deffn + +@deffn primitive string= s1 s2 [start1 end1 start2 end2] +@deffnx primitive string<> s1 s2 [start1 end1 start2 end2] +@deffnx primitive string< s1 s2 [start1 end1 start2 end2] +@deffnx primitive string> s1 s2 [start1 end1 start2 end2] +@deffnx primitive string<= s1 s2 [start1 end1 start2 end2] +@deffnx primitive string>= s1 s2 [start1 end1 start2 end2] +Compare @var{s1} and @var{s2} and return @code{#f} if the predicate +fails. Otherwise, the mismatch index is returned (or @var{end1} in the +case of @code{string=}. +@end deffn + +@deffn primitive string-ci= s1 s2 [start1 end1 start2 end2] +@deffnx primitive string-ci<> s1 s2 [start1 end1 start2 end2] +@deffnx primitive string-ci< s1 s2 [start1 end1 start2 end2] +@deffnx primitive string-ci> s1 s2 [start1 end1 start2 end2] +@deffnx primitive string-ci<= s1 s2 [start1 end1 start2 end2] +@deffnx primitive string-ci>= s1 s2 [start1 end1 start2 end2] +Compare @var{s1} and @var{s2} and return @code{#f} if the predicate +fails. Otherwise, the mismatch index is returned (or @var{end1} in the +case of @code{string=}. These are the case-insensitive variants. +@end deffn + +@deffn primitive string-hash s [bound start end] +@deffnx primitive string-hash-ci s [bound start end] +Return a hash value of the string @var{s} in the range 0 @dots{} +@var{bound} - 1. @code{string-hash-ci} is the case-insensitive variant. +@end deffn + + +@c =================================================================== + +@node SRFI-13 Prefixes/Suffixes +@subsection Prefixes/Suffixes + +Using these procedures you can determine whether a given string is a +prefix or suffix of another string or how long a common prefix/suffix +is. + +@deffn primitive string-prefix-length s1 s2 [start1 end1 start2 end2] +@deffnx primitive string-prefix-length-ci s1 s2 [start1 end1 start2 end2] +@deffnx primitive string-suffix-length s1 s2 [start1 end1 start2 end2] +@deffnx primitive string-suffix-length-ci s1 s2 [start1 end1 start2 end2] +Return the length of the longest common prefix/suffix of the two +strings. @code{string-prefix-length-ci} and +@code{string-suffix-length-ci} are the case-insensitive variants. +@end deffn + +@deffn primitive string-prefix? s1 s2 [start1 end1 start2 end2] +@deffnx primitive string-prefix-ci? s1 s2 [start1 end1 start2 end2] +@deffnx primitive string-suffix? s1 s2 [start1 end1 start2 end2] +@deffnx primitive string-suffix-ci? s1 s2 [start1 end1 start2 end2] +Is @var{s1} a prefix/suffix of @var{s2}. @code{string-prefix-ci?} and +@code{string-suffix-ci?} are the case-insensitive variants. +@end deffn + + +@c =================================================================== + +@node SRFI-13 Searching +@subsection Searching + +Use these procedures to find out whether a string contains a given +character or a given substring, or a character from a set of characters. + +@deffn primitive string-index s char_pred [start end] +@deffnx primitive string-index-right s char_pred [start end] +Search through the string @var{s} from left to right (right to left), +returning the index of the first (last) occurence of a character which + +@itemize @bullet +@item +equals @var{char_pred}, if it is character, + +@item +satisifies the predicate @var{char_pred}, if it is a +procedure, + +@item +is in the set @var{char_pred}, if it is a character set. +@end itemize +@end deffn + +@deffn primitive string-skip s char_pred [start end] +@deffnx primitive string-skip-right s char_pred [start end] +Search through the string @var{s} from left to right (right to left), +returning the index of the first (last) occurence of a character which + +@itemize @bullet +@item +does not equal @var{char_pred}, if it is character, + +@item +does not satisify the predicate @var{char_pred}, if it is +a procedure. + +@item +is not in the set if @var{char_pred} is a character set. +@end itemize +@end deffn + +@deffn primitive string-count s char_pred [start end] +Return the count of the number of characters in the string +@var{s} which + +@itemize @bullet +@item +equals @var{char_pred}, if it is character, + +@item +satisifies the predicate @var{char_pred}, if it is a procedure. + +@item +is in the set @var{char_pred}, if it is a character set. +@end itemize +@end deffn + +@deffn primitive string-contains s1 s2 [start1 end1 start2 end2] +@deffnx primitive string-contains-ci s1 s2 [start1 end1 start2 end2] +Does string @var{s1} contain string @var{s2}? Return the index +in @var{s1} where @var{s2} occurs as a substring, or false. +The optional start/end indices restrict the operation to the +indicated substrings. + +@code{string-contains-ci} is the case-insensitive variant. +@end deffn + + +@c =================================================================== + +@node SRFI-13 Case Mapping +@subsection Alphabetic Case Mapping + +These procedures convert the alphabetic case of strings. They are +similar to the procedures in the Guile core, but are extended to handle +optional start/end indices. + +@deffn primitive string-upcase s [start end] +@deffnx primitive string-upcase! s [start end] +Upcase every character in @var{s}. @code{string-upcase!} is the +side-effecting variant. +@end deffn + +@deffn primitive string-downcase s [start end] +@deffnx primitive string-downcase! s [start end] +Downcase every character in @var{s}. @code{string-downcase!} is the +side-effecting variant. +@end deffn + +@deffn primitive string-titlecase s [start end] +@deffnx primitive string-titlecase! s [start end] +Upcase every first character in every word in @var{s}, downcase the +other characters. @code{string-titlecase!} is the side-effecting +variant. +@end deffn + + +@c =================================================================== + +@node SRFI-13 Reverse/Append +@subsection Reverse/Append + +One appending procedure, @code{string-append} is the same in R5RS and in +SRFI-13, so it is not redefined. + +@deffn primitive string-reverse str [start end] +@deffnx primitive string-reverse! str [start end] +Reverse the string @var{str}. The optional arguments +@var{start} and @var{end} delimit the region of @var{str} to +operate on. + +@code{string-reverse!} modifies the argument string and returns an +unspecified value. +@end deffn + +@deffn primitive string-append/shared ls @dots{} +Like @code{string-append}, but the result may share memory +with the argument strings. +@end deffn + +@deffn primitive string-concatenate ls +Append the elements of @var{ls} (which must be strings) +together into a single string. Guaranteed to return a freshly +allocated string. +@end deffn + +@deffn primitive string-concatenate/shared ls +Like @code{string-concatenate}, but the result may share memory +with the strings in the list @var{ls}. +@end deffn + +@deffn primitive string-concatenate-reverse ls final_string end +Without optional arguments, this procedure is equivalent to + +@smalllisp +(string-concatenate (reverse ls)) +@end smalllisp + +If the optional argument @var{final_string} is specified, it is +consed onto the beginning to @var{ls} before performing the +list-reverse and string-concatenate operations. If @var{end} +is given, only the characters of @var{final_string} up to index +@var{end} are used. + +Guaranteed to return a freshly allocated string. +@end deffn + +@deffn primitive string-concatenate-reverse/shared ls final_string end +Like @code{string-concatenate-reverse}, but the result may +share memory with the the strings in the @var{ls} arguments. +@end deffn + + +@c =================================================================== + +@node SRFI-13 Fold/Unfold/Map +@subsection Fold/Unfold/Map + +@code{string-map}, @code{string-for-each} etc. are for iterating over +the characters a string is composed of. The fold and unfold procedures +are list iterators and constructors. + +@deffn primitive string-map proc s [start end] +@var{proc} is a char->char procedure, it is mapped over +@var{s}. The order in which the procedure is applied to the +string elements is not specified. +@end deffn + +@deffn primitive string-map! proc s [start end] +@var{proc} is a char->char procedure, it is mapped over +@var{s}. The order in which the procedure is applied to the +string elements is not specified. The string @var{s} is +modified in-place, the return value is not specified. +@end deffn + +@deffn primitive string-fold kons knil s [start end] +@deffnx primitive string-fold-right kons knil s [start end] +Fold @var{kons} over the characters of @var{s}, with @var{knil} as the +terminating element, from left to right (or right to left, for +@code{string-fold-right}). @var{kons} must expect two arguments: The +actual character and the last result of @var{kons}' application. +@end deffn + +@deffn primitive string-unfold p f g seed [base make_final] +@deffnx primitive string-unfold-right p f g seed [base make_final] +These are the fundamental string constructors. +@itemize @bullet +@item @var{g} is used to generate a series of @emph{seed} +values from the initial @var{seed}: @var{seed}, (@var{g} +@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), +@dots{} +@item @var{p} tells us when to stop - when it returns true +when applied to one of these seed values. +@item @var{f} maps each seed value to the corresponding +character in the result string. These chars are assembled into the +string in a left-to-right (right-to-left) order. +@item @var{base} is the optional initial/leftmost (rightmost) + portion of the constructed string; it default to the empty string. +@item @var{make_final} is applied to the terminal seed +value (on which @var{p} returns true) to produce the final/rightmost +(leftmost) portion of the constructed string. It defaults to +@code{(lambda (x) "")}. +@end itemize +@end deffn + +@deffn primitive string-for-each proc s [start end] +@var{proc} is mapped over @var{s} in left-to-right order. The +return value is not specified. +@end deffn + + +@c =================================================================== + +@node SRFI-13 Replicate/Rotate +@subsection Replicate/Rotate + +These procedures are special substring procedures, which can also be +used for replicating strings. They are a bit tricky to use, but +consider this code fragment, which replicates the input string +@code{"foo"} so often that the resulting string has a length of six. + +@lisp +(xsubstring "foo" 0 6) +@result{} +"foofoo" +@end lisp + +@deffn primitive xsubstring s from [to start end] +This is the @emph{extended substring} procedure that implements +replicated copying of a substring of some string. + +@var{s} is a string, @var{start} and @var{end} are optional +arguments that demarcate a substring of @var{s}, defaulting to +0 and the length of @var{s}. Replicate this substring up and +down index space, in both the positive and negative directions. +@code{xsubstring} returns the substring of this string +beginning at index @var{from}, and ending at @var{to}, which +defaults to @var{from} + (@var{end} - @var{start}). +@end deffn + +@deffn primitive string-xcopy! target tstart s sfrom [sto start end] +Exactly the same as @code{xsubstring}, but the extracted text +is written into the string @var{target} starting at index +@var{tstart}. The operation is not defined if @code{(eq? +@var{target} @var{s})} or these arguments share storage - you +cannot copy a string on top of itself. +@end deffn + + +@c =================================================================== + +@node SRFI-13 Miscellaneous +@subsection Miscellaneous + +@code{string-replace} is for replacing a portion of a string with +another string and @code{string-tokenize} splits a string into a list of +strings, breaking it up at a specified character. + +@deffn primitive string-replace s1 s2 [start1 end1 start2 end2] +Return the string @var{s1}, but with the characters +@var{start1} @dots{} @var{end1} replaced by the characters +@var{start2} @dots{} @var{end2} from @var{s2}. +@end deffn + +@deffn primitive string-tokenize s [token_char start end] +Split the string @var{s} into a list of substrings, where each +substring is a maximal non-empty contiguous sequence of +characters equal to the character @var{token_char}, or +whitespace, if @var{token_char} is not given. If +@var{token_char} is a character set, it is used for finding the +token borders. +@end deffn + + +@c =================================================================== + +@node SRFI-13 Filtering/Deleting +@subsection Filtering/Deleting + +@dfn{Filtering} means to remove all characters from a string which do +not match a given criteria, @dfn{deleting} means the opposite. + +@deffn primitive string-filter s char_pred [start end] +Filter the string @var{s}, retaining only those characters that +satisfy the @var{char_pred} argument. If the argument is a +procedure, it is applied to each character as a predicate, if +it is a character, it is tested for equality and if it is a +character set, it is tested for membership. +@end deffn + +@deffn primitive string-delete s char_pred [start end] +Filter the string @var{s}, retaining only those characters that +do not satisfy the @var{char_pred} argument. If the argument +is a procedure, it is applied to each character as a predicate, +if it is a character, it is tested for equality and if it is a +character set, it is tested for membership. +@end deffn + + +@node SRFI-14 +@section SRFI-14 - Character-set Library + +SRFI-14 defines the data type @dfn{character set}, and also defines a +lot of procedures for handling this character type, and a few standard +character sets like whitespace, alphabetic characters and others. + +All procedures from SRFI-14 (character-set library) are implemented in +the module @code{(srfi srfi-14)}, as well as the standard variables +@code{char-set:letter}, @code{char-set:digit} etc. + +@menu +* Loading SRFI-14:: How to make charsets available. +* SRFI-14 Character Set Data Type:: Underlying data type for charsets. +* SRFI-14 Predicates/Comparison:: Charset predicates. +* SRFI-14 Iterating Over Character Sets:: Enumerate charset elements. +* SRFI-14 Creating Character Sets:: Makeing new charsets. +* SRFI-14 Querying Character Sets:: Test charsets for membership etc. +* SRFI-14 Character-Set Algebra:: Calculating new charsets. +* SRFI-14 Standard Character Sets:: Variables containing predefined charsets. +@end menu + + +@node Loading SRFI-14 +@subsection Loading SRFI-14 + +When Guile is properly installed, SRFI-14 support can be loaded into a +running Guile by using the @code{(srfi srfi-14)} module. + +@example +$ guile +guile> (use-modules (srfi srfi-14)) +guile> (char-set-union (char-set #\f #\o #\o) (string->char-set "bar")) +# +guile> +@end example + + +@node SRFI-14 Character Set Data Type +@subsection Character Set Data Type + +The data type @dfn{charset} implements sets of characters (REFFIXME). +Because the internal representation of character sets is not visible to +the user, a lot of procedures for handling them are provided. + +Character sets can be created, extended, tested for the membership of a +characters and be compared to other character sets. + +The Guile implementation of character sets deals with 8-bit characters. +In the standard variables, only the ASCII part of the character range is +really used, so that for example @dfn{Umlaute} and other accented +characters are not considered to be letters. In the future, as Guile +may get support for international character sets, this will change, so +don't rely on these ``features''. + + +@c =================================================================== + +@node SRFI-14 Predicates/Comparison +@subsection Predicates/Comparison + +Use these procedures for testing whether an object is a character set, +or whether several character sets are equal or subsets of each other. +@code{char-set-hash} can be used for calculating a hash value, maybe for +usage in fast lookup procedures. + +@deffn primitive char-set? obj +Return @code{#t} if @var{obj} is a character set, @code{#f} +otherwise. +@end deffn + +@deffn primitive char-set= cs1 @dots{} +Return @code{#t} if all given character sets are equal. +@end deffn + +@deffn primitive char-set<= cs1 @dots{} +Return @code{#t} if every character set @var{cs}i is a subset +of character set @var{cs}i+1. +@end deffn + +@deffn primitive char-set-hash cs [bound] +Compute a hash value for the character set @var{cs}. If +@var{bound} is given and not @code{#f}, it restricts the +returned value to the range 0 @dots{} @var{bound - 1}. +@end deffn + + +@c =================================================================== + +@node SRFI-14 Iterating Over Character Sets +@subsection Iterating Over Character Sets + +Character set cursors are a means for iterating over the members of a +character sets. After creating a character set cursor with +@code{char-set-cursor}, a cursor can be dereferenced with +@code{char-set-ref}, advanced to the next member with +@code{char-set-cursor-next}. Whether a cursor has passed past the last +element of the set can be checked with @code{end-of-char-set?}. + +Additionally, mapping and (un-)folding procedures for character sets are +provided. + +@deffn primitive char-set-cursor cs +Return a cursor into the character set @var{cs}. +@end deffn + +@deffn primitive char-set-ref cs cursor +Return the character at the current cursor position +@var{cursor} in the character set @var{cs}. It is an error to +pass a cursor for which @code{end-of-char-set?} returns true. +@end deffn + +@deffn primitive char-set-cursor-next cs cursor +Advance the character set cursor @var{cursor} to the next +character in the character set @var{cs}. It is an error if the +cursor given satisfies @code{end-of-char-set?}. +@end deffn + +@deffn primitive end-of-char-set? cursor +Return @code{#t} if @var{cursor} has reached the end of a +character set, @code{#f} otherwise. +@end deffn + +@deffn primitive char-set-fold kons knil cs +Fold the procedure @var{kons} over the character set @var{cs}, +initializing it with @var{knil}. +@end deffn + +@deffn primitive char-set-unfold p f g seed [base_cs] +@deffnx primitive char-set-unfold! p f g seed base_cs +This is a fundamental constructor for character sets. +@itemize +@item @var{g} is used to generate a series of ``seed'' values +from the initial seed: @var{seed}, (@var{g} @var{seed}), +(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{} +@item @var{p} tells us when to stop -- when it returns true +when applied to one of the seed values. +@item @var{f} maps each seed value to a character. These +characters are added to the base character set @var{base_cs} to +form the result; @var{base_cs} defaults to the empty set. +@end itemize + +@code{char-set-unfold!} is the side-effecting variant. +@end deffn + +@deffn primitive char-set-for-each proc cs +Apply @var{proc} to every character in the character set +@var{cs}. The return value is not specified. +@end deffn + +@deffn primitive char-set-map proc cs +Map the procedure @var{proc} over every character in @var{cs}. +@var{proc} must be a character -> character procedure. +@end deffn + + +@c =================================================================== + +@node SRFI-14 Creating Character Sets +@subsection Creating Character Sets + +New character sets are produced with these procedures. + +@deffn primitive char-set-copy cs +Return a newly allocated character set containing all +characters in @var{cs}. +@end deffn + +@deffn primitive char-set char1 @dots{} +Return a character set containing all given characters. +@end deffn + +@deffn primitive list->char-set char_list [base_cs] +@deffnx primitive list->char-set! char_list base_cs +Convert the character list @var{list} to a character set. If +the character set @var{base_cs} is given, the character in this +set are also included in the result. + +@code{list->char-set!} is the side-effecting variant. +@end deffn + +@deffn primitive string->char-set s [base_cs] +@deffnx primitive string->char-set! s base_cs +Convert the string @var{str} to a character set. If the +character set @var{base_cs} is given, the characters in this +set are also included in the result. + +@code{string->char-set!} is the side-effecting variant. +@end deffn + +@deffn primitive char-set-filter pred cs [base_cs] +@deffnx primitive char-set-filter! pred cs base_cs +Return a character set containing every character from @var{cs} +so that it satisfies @var{pred}. If provided, the characters +from @var{base_cs} are added to the result. + +@code{char-set-filter!} is the side-effecting variant. +@end deffn + +@deffn primitive ucs-range->char-set lower upper [error? base_cs] +@deffnx primitive uce-range->char-set! lower upper error? base_cs +Return a character set containing all characters whose +character codes lie in the half-open range +[@var{lower},@var{upper}). + +If @var{error} is a true value, an error is signalled if the +specified range contains characters which are not contained in +the implemented character range. If @var{error} is @code{#f}, +these characters are silently left out of the resultung +character set. + +The characters in @var{base_cs} are added to the result, if +given. + +@code{ucs-range->char-set!} is the side-effecting variant. +@end deffn + +@deffn procedure ->char-set x +Coerce @var{x} into a character set. @var{x} may be a string, a +character or a character set. +@end deffn + + +@c =================================================================== + +@node SRFI-14 Querying Character Sets +@subsection Querying Character Sets + +Access the elements and other information of a character set with these +procedures. + +@deffn primitive char-set-size cs +Return the number of elements in character set @var{cs}. +@end deffn + +@deffn primitive char-set-count pred cs +Return the number of the elements int the character set +@var{cs} which satisfy the predicate @var{pred}. +@end deffn + +@deffn primitive char-set->list cs +Return a list containing the elements of the character set +@var{cs}. +@end deffn + +@deffn primitive char-set->string cs +Return a string containing the elements of the character set +@var{cs}. The order in which the characters are placed in the +string is not defined. +@end deffn + +@deffn primitive char-set-contains? cs char +Return @code{#t} iff the character @var{ch} is contained in the +character set @var{cs}. +@end deffn + +@deffn primitive char-set-every pred cs +Return a true value if every character in the character set +@var{cs} satisfies the predicate @var{pred}. +@end deffn + +@deffn primitive char-set-any pred cs +Return a true value if any character in the character set +@var{cs} satisfies the predicate @var{pred}. +@end deffn + + +@c =================================================================== + +@node SRFI-14 Character-Set Algebra +@subsection Character-Set Algebra + +Character sets can be manipulated with the common set algebra operation, +such as union, complement, intersection etc. All of these procedures +provide side--effecting variants, which modify their character set +argument(s). + +@deffn primitive char-set-adjoin cs char1 @dots{} +@deffnx primitive char-set-adjoin! cs char1 @dots{} +Add all character arguments to the first argument, which must +be a character set. +@end deffn + +@deffn primitive char-set-delete cs char1 @dots{} +@deffnx primitive char-set-delete! cs char1 @dots{} +Delete all character arguments from the first argument, which +must be a character set. +@end deffn + +@deffn primitive char-set-complement cs +@deffnx primitive char-set-complement! cs +Return the complement of the character set @var{cs}. +@end deffn + +@deffn primitive char-set-union cs1 @dots{} +@deffnx primitive char-set-union! cs1 @dots{} +Return the union of all argument character sets. +@end deffn + +@deffn primitive char-set-intersection cs1 @dots{} +@deffnx primitive char-set-intersection! cs1 @dots{} +Return the intersection of all argument character sets. +@end deffn + +@deffn primitive char-set-difference cs1 @dots{} +@deffnx primitive char-set-difference! cs1 @dots{} +Return the difference of all argument character sets. +@end deffn + +@deffn primitive char-set-xor cs1 @dots{} +@deffnx primitive char-set-xor! cs1 @dots{} +Return the exclusive--or of all argument character sets. +@end deffn + +@deffn primitive char-set-diff+intersection cs1 @dots{} +@deffnx primitive char-set-diff+intersection! cs1 @dots{} +Return the difference and the intersection of all argument +character sets. +@end deffn + + +@c =================================================================== + +@node SRFI-14 Standard Character Sets +@subsection Standard Character Sets + +In order to make the use of the character set data type and procedures +useful, several predefined character set variables exist. + +@defvar char-set:lower-case +All lower--case characters. +@end defvar + +@defvar char-set:upper-case +All upper--case characters. +@end defvar + +@defvar char-set:title-case +This is empty, because ASCII has no titlecase characters. +@end defvar + +@defvar char-set:letter +All letters, e.g. the union of @code{char-set:lower-case} and +@code{char-set:upper-case}. +@end defvar + +@defvar char-set:digit +All digits. +@end defvar + +@defvar char-set:letter+digit +The union of @code{char-set:letter} and @code{char-set:digit}. +@end defvar + +@defvar char-set:graphic +All characters which would put ink on the paper. +@end defvar + +@defvar char-set:printing +The union of @code{char-set:graphic} and @code{char-set:whitespace}. +@end defvar + +@defvar char-set:whitespace +All whitespace characters. +@end defvar + +@defvar char-set:blank +All horizontal whitespace characters, that is @code{#\space} and +@code{#\tab}. +@end defvar + +@defvar char-set:iso-control +The ISO control characters with the codes 0--31 and 127. +@end defvar + +@defvar char-set:punctuation +The characters @code{!"#%&'()*,-./:;?@@[\\]_@{@}} +@end defvar + +@defvar char-set:symbol +The characters @code{$+<=>^`|~}. +@end defvar + +@defvar char-set:hex-digit +The hexadecimal digits @code{0123456789abcdefABCDEF}. +@end defvar + +@defvar char-set:ascii +All ASCII characters. +@end defvar + +@defvar char-set:empty +The empty character set. +@end defvar + +@defvar char-set:full +This character set contains all possible characters. +@end defvar + +@node SRFI-16 +@section SRFI-16 - case-lambda + +@c FIXME::martin: Review me! + +The syntactic form @code{case-lambda} creates procedures, just like +@code{lambda}, but has syntactic extensions for writing procedures of +varying arity easier. + +The syntax of the @code{case-lambda} form is defined in the following +EBNF grammar. + +@example + + --> (case-lambda ) + + --> ( *) + + --> (*) + | (* . ) + | +@end example + +The value returned by a @code{case-lambda} form is a procedure which +matches the number of actual arguments against the formals in the +various clauses, in order. @dfn{Formals} means a formal argument list +just like with @code{lambda} (REFFIXME). The first matching clause is +selected, the corresponding values from the actual parameter list are +bound to the variable names in the clauses and the body of the clause is +evaluated. If no clause matches, an error is signalled. + +The following (silly) definition creates a procedure @var{foo} which +acts differently, depending on the number of actual arguments. If one +argument is given, the constant @code{#t} is returned, two arguments are +added and if more arguments are passed, their product is calculated. + +@lisp +(define foo (case-lambda + ((x) #t) + ((x y) (+ x y)) + (z + (apply * z)))) +(foo 'bar) +@result{} +#t +(foo 2 4) +@result{} +6 +(foo 3 3 3) +@result{} +27 +(foo) +@result{} +1 +@end lisp + +The last expression evaluates to 1 because the last clause is matched, +@var{z} is bound to the empty list and the following multiplication, +applied to zero arguments, yields 1. + + @node SRFI-17 -@section SRFI-17 -- Generalized set! +@section SRFI-17 - Generalized set! This is an implementation of SRFI-17: Generalized set! From cf46055fc3a4fb1f8ccbb5ae7c54b9fbd5a8eaa4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 14 May 2001 21:38:58 +0000 Subject: [PATCH 1076/2047] * AUTHORS (Martin Grabmueller): Remove obsolete file doc/srfi-13-14.texi. --- AUTHORS | 1 - 1 file changed, 1 deletion(-) diff --git a/AUTHORS b/AUTHORS index 357d4d1d6..363ef8f8d 100644 --- a/AUTHORS +++ b/AUTHORS @@ -133,7 +133,6 @@ In the subdirectory scripts, wrote: In the subdirectory doc, wrote: script-getopt.texi srfi-modules.texi - srfi-13-14.texi repl-modules.texi In the subdirectory doc, changes to: guile.texi intro.texi posix.texi From 5f89fb1313f9bbbd222c5240450e4b29fa9d8574 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 15 May 2001 00:51:06 +0000 Subject: [PATCH 1077/2047] =?UTF-8?q?(error-catching-repl):=20Call=20the?= =?UTF-8?q?=20E=20("eval'er")=20procedure=20via=20call-with-values=20and?= =?UTF-8?q?=20call=20the=20P=20("printer")=20for=20each=20produced=20value?= =?UTF-8?q?.=20=20Thanks=20to=20Matthias=20K=C3=B6ppe!?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- ice-9/boot-9.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 7134743db..1f87908fa 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -2375,7 +2375,10 @@ ;; (display "No backtrace available.\n"))) (define (error-catching-repl r e p) - (error-catching-loop (lambda () (p (e (r)))))) + (error-catching-loop + (lambda () + (call-with-values (lambda () (e (r))) + (lambda the-values (for-each p the-values)))))) (define (gc-run-time) (cdr (assq 'gc-time-taken (gc-stats)))) From 9d47027ee6e0534e96e595bc7d517abe392d4fdb Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 15 May 2001 00:52:20 +0000 Subject: [PATCH 1078/2047] =?UTF-8?q?(print=5Fvalues):=20Print=20as=20a=20?= =?UTF-8?q?unreadable=20object,=20not=20as=20multiple=20lines.=20=20Thanks?= =?UTF-8?q?=20to=20Matthias=20K=C3=B6ppe!?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- libguile/values.c | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/libguile/values.c b/libguile/values.c index a5377e690..b37124759 100644 --- a/libguile/values.c +++ b/libguile/values.c @@ -61,13 +61,10 @@ print_values (SCM obj, SCM pwps) SCM port = SCM_PORT_WITH_PS_PORT (pwps); scm_print_state *ps = SCM_PRINT_STATE (SCM_PORT_WITH_PS_PS (pwps)); - while (SCM_CONSP (values)) - { - scm_iprin1 (SCM_CAR (values), port, ps); - values = SCM_CDR (values); - if (SCM_CONSP (values)) - scm_newline (port); - } + scm_puts ("#", port); + return SCM_UNSPECIFIED; } From 9e54671afe1783a321708ac1be277a9e31bd3e91 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 15 May 2001 00:54:08 +0000 Subject: [PATCH 1079/2047] Removed copy of "libtool.m4". --- acinclude.m4 | 432 --------------------------------------------------- 1 file changed, 432 deletions(-) diff --git a/acinclude.m4 b/acinclude.m4 index 2c64e7fc1..7765f64d4 100644 --- a/acinclude.m4 +++ b/acinclude.m4 @@ -102,435 +102,3 @@ ifelse([$4], , , [$4 ])dnl fi ]) - - -## libtool.m4 - Configure libtool for the target system. -*-Shell-script-*- -## Copyright (C) 1996-1999 Free Software Foundation, Inc. -## Originally by Gordon Matzigkeit , 1996 -## -## 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 this program; if not, write to the Free Software -## Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -## -## As a special exception to the GNU General Public License, if you -## distribute this file as part of a program that contains a -## configuration script generated by Autoconf, you may include it under -## the same distribution terms that you use for the rest of that program. - -# serial 40 AC_PROG_LIBTOOL -AC_DEFUN(AC_PROG_LIBTOOL, -[AC_REQUIRE([AC_LIBTOOL_SETUP])dnl - -# Save cache, so that ltconfig can load it -AC_CACHE_SAVE - -# Actually configure libtool. ac_aux_dir is where install-sh is found. -CC="$CC" CFLAGS="$CFLAGS" CPPFLAGS="$CPPFLAGS" \ -LD="$LD" LDFLAGS="$LDFLAGS" LIBS="$LIBS" \ -LN_S="$LN_S" NM="$NM" RANLIB="$RANLIB" \ -DLLTOOL="$DLLTOOL" AS="$AS" OBJDUMP="$OBJDUMP" \ -${CONFIG_SHELL-/bin/sh} $ac_aux_dir/ltconfig --no-reexec \ -$libtool_flags --no-verify $ac_aux_dir/ltmain.sh $lt_target \ -|| AC_MSG_ERROR([libtool configure failed]) - -# Reload cache, that may have been modified by ltconfig -AC_CACHE_LOAD - -# This can be used to rebuild libtool when needed -LIBTOOL_DEPS="$ac_aux_dir/ltconfig $ac_aux_dir/ltmain.sh" - -# Always use our own libtool. -LIBTOOL='$(SHELL) $(top_builddir)/libtool' -AC_SUBST(LIBTOOL)dnl - -# Redirect the config.log output again, so that the ltconfig log is not -# clobbered by the next message. -exec 5>>./config.log -]) - -AC_DEFUN(AC_LIBTOOL_SETUP, -[AC_PREREQ(2.13)dnl -AC_REQUIRE([AC_ENABLE_SHARED])dnl -AC_REQUIRE([AC_ENABLE_STATIC])dnl -AC_REQUIRE([AC_ENABLE_FAST_INSTALL])dnl -AC_REQUIRE([AC_CANONICAL_HOST])dnl -AC_REQUIRE([AC_CANONICAL_BUILD])dnl -AC_REQUIRE([AC_PROG_RANLIB])dnl -AC_REQUIRE([AC_PROG_CC])dnl -AC_REQUIRE([AC_PROG_LD])dnl -AC_REQUIRE([AC_PROG_NM])dnl -AC_REQUIRE([AC_PROG_LN_S])dnl -dnl - -case "$target" in -NONE) lt_target="$host" ;; -*) lt_target="$target" ;; -esac - -# Check for any special flags to pass to ltconfig. -libtool_flags="--cache-file=$cache_file" -test "$enable_shared" = no && libtool_flags="$libtool_flags --disable-shared" -test "$enable_static" = no && libtool_flags="$libtool_flags --disable-static" -test "$enable_fast_install" = no && libtool_flags="$libtool_flags --disable-fast-install" -test "$ac_cv_prog_gcc" = yes && libtool_flags="$libtool_flags --with-gcc" -test "$ac_cv_prog_gnu_ld" = yes && libtool_flags="$libtool_flags --with-gnu-ld" -ifdef([AC_PROVIDE_AC_LIBTOOL_DLOPEN], -[libtool_flags="$libtool_flags --enable-dlopen"]) -ifdef([AC_PROVIDE_AC_LIBTOOL_WIN32_DLL], -[libtool_flags="$libtool_flags --enable-win32-dll"]) -AC_ARG_ENABLE(libtool-lock, - [ --disable-libtool-lock avoid locking (might break parallel builds)]) -test "x$enable_libtool_lock" = xno && libtool_flags="$libtool_flags --disable-lock" -test x"$silent" = xyes && libtool_flags="$libtool_flags --silent" - -# Some flags need to be propagated to the compiler or linker for good -# libtool support. -case "$lt_target" in -*-*-irix6*) - # Find out which ABI we are using. - echo '[#]line __oline__ "configure"' > conftest.$ac_ext - if AC_TRY_EVAL(ac_compile); then - case "`/usr/bin/file conftest.o`" in - *32-bit*) - LD="${LD-ld} -32" - ;; - *N32*) - LD="${LD-ld} -n32" - ;; - *64-bit*) - LD="${LD-ld} -64" - ;; - esac - fi - rm -rf conftest* - ;; - -*-*-sco3.2v5*) - # On SCO OpenServer 5, we need -belf to get full-featured binaries. - SAVE_CFLAGS="$CFLAGS" - CFLAGS="$CFLAGS -belf" - AC_CACHE_CHECK([whether the C compiler needs -belf], lt_cv_cc_needs_belf, - [AC_TRY_LINK([],[],[lt_cv_cc_needs_belf=yes],[lt_cv_cc_needs_belf=no])]) - if test x"$lt_cv_cc_needs_belf" != x"yes"; then - # this is probably gcc 2.8.0, egcs 1.0 or newer; no need for -belf - CFLAGS="$SAVE_CFLAGS" - fi - ;; - -ifdef([AC_PROVIDE_AC_LIBTOOL_WIN32_DLL], -[*-*-cygwin* | *-*-mingw*) - AC_CHECK_TOOL(DLLTOOL, dlltool, false) - AC_CHECK_TOOL(AS, as, false) - AC_CHECK_TOOL(OBJDUMP, objdump, false) - ;; -]) -esac -]) - -# AC_LIBTOOL_DLOPEN - enable checks for dlopen support -AC_DEFUN(AC_LIBTOOL_DLOPEN, [AC_BEFORE([$0],[AC_LIBTOOL_SETUP])]) - -# AC_LIBTOOL_WIN32_DLL - declare package support for building win32 dll's -AC_DEFUN(AC_LIBTOOL_WIN32_DLL, [AC_BEFORE([$0], [AC_LIBTOOL_SETUP])]) - -# AC_ENABLE_SHARED - implement the --enable-shared flag -# Usage: AC_ENABLE_SHARED[(DEFAULT)] -# Where DEFAULT is either `yes' or `no'. If omitted, it defaults to -# `yes'. -AC_DEFUN(AC_ENABLE_SHARED, [dnl -define([AC_ENABLE_SHARED_DEFAULT], ifelse($1, no, no, yes))dnl -AC_ARG_ENABLE(shared, -changequote(<<, >>)dnl -<< --enable-shared[=PKGS] build shared libraries [default=>>AC_ENABLE_SHARED_DEFAULT], -changequote([, ])dnl -[p=${PACKAGE-default} -case "$enableval" in -yes) enable_shared=yes ;; -no) enable_shared=no ;; -*) - enable_shared=no - # Look at the argument we got. We use all the common list separators. - IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:," - for pkg in $enableval; do - if test "X$pkg" = "X$p"; then - enable_shared=yes - fi - done - IFS="$ac_save_ifs" - ;; -esac], -enable_shared=AC_ENABLE_SHARED_DEFAULT)dnl -]) - -# AC_DISABLE_SHARED - set the default shared flag to --disable-shared -AC_DEFUN(AC_DISABLE_SHARED, [AC_BEFORE([$0],[AC_LIBTOOL_SETUP])dnl -AC_ENABLE_SHARED(no)]) - -# AC_ENABLE_STATIC - implement the --enable-static flag -# Usage: AC_ENABLE_STATIC[(DEFAULT)] -# Where DEFAULT is either `yes' or `no'. If omitted, it defaults to -# `yes'. -AC_DEFUN(AC_ENABLE_STATIC, [dnl -define([AC_ENABLE_STATIC_DEFAULT], ifelse($1, no, no, yes))dnl -AC_ARG_ENABLE(static, -changequote(<<, >>)dnl -<< --enable-static[=PKGS] build static libraries [default=>>AC_ENABLE_STATIC_DEFAULT], -changequote([, ])dnl -[p=${PACKAGE-default} -case "$enableval" in -yes) enable_static=yes ;; -no) enable_static=no ;; -*) - enable_static=no - # Look at the argument we got. We use all the common list separators. - IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:," - for pkg in $enableval; do - if test "X$pkg" = "X$p"; then - enable_static=yes - fi - done - IFS="$ac_save_ifs" - ;; -esac], -enable_static=AC_ENABLE_STATIC_DEFAULT)dnl -]) - -# AC_DISABLE_STATIC - set the default static flag to --disable-static -AC_DEFUN(AC_DISABLE_STATIC, [AC_BEFORE([$0],[AC_LIBTOOL_SETUP])dnl -AC_ENABLE_STATIC(no)]) - - -# AC_ENABLE_FAST_INSTALL - implement the --enable-fast-install flag -# Usage: AC_ENABLE_FAST_INSTALL[(DEFAULT)] -# Where DEFAULT is either `yes' or `no'. If omitted, it defaults to -# `yes'. -AC_DEFUN(AC_ENABLE_FAST_INSTALL, [dnl -define([AC_ENABLE_FAST_INSTALL_DEFAULT], ifelse($1, no, no, yes))dnl -AC_ARG_ENABLE(fast-install, -changequote(<<, >>)dnl -<< --enable-fast-install[=PKGS] optimize for fast installation [default=>>AC_ENABLE_FAST_INSTALL_DEFAULT], -changequote([, ])dnl -[p=${PACKAGE-default} -case "$enableval" in -yes) enable_fast_install=yes ;; -no) enable_fast_install=no ;; -*) - enable_fast_install=no - # Look at the argument we got. We use all the common list separators. - IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:," - for pkg in $enableval; do - if test "X$pkg" = "X$p"; then - enable_fast_install=yes - fi - done - IFS="$ac_save_ifs" - ;; -esac], -enable_fast_install=AC_ENABLE_FAST_INSTALL_DEFAULT)dnl -]) - -# AC_ENABLE_FAST_INSTALL - set the default to --disable-fast-install -AC_DEFUN(AC_DISABLE_FAST_INSTALL, [AC_BEFORE([$0],[AC_LIBTOOL_SETUP])dnl -AC_ENABLE_FAST_INSTALL(no)]) - -# AC_PROG_LD - find the path to the GNU or non-GNU linker -AC_DEFUN(AC_PROG_LD, -[AC_ARG_WITH(gnu-ld, -[ --with-gnu-ld assume the C compiler uses GNU ld [default=no]], -test "$withval" = no || with_gnu_ld=yes, with_gnu_ld=no) -AC_REQUIRE([AC_PROG_CC])dnl -AC_REQUIRE([AC_CANONICAL_HOST])dnl -AC_REQUIRE([AC_CANONICAL_BUILD])dnl -ac_prog=ld -if test "$ac_cv_prog_gcc" = yes; then - # Check if gcc -print-prog-name=ld gives a path. - AC_MSG_CHECKING([for ld used by GCC]) - ac_prog=`($CC -print-prog-name=ld) 2>&5` - case "$ac_prog" in - # Accept absolute paths. -changequote(,)dnl - [\\/]* | [A-Za-z]:[\\/]*) - re_direlt='/[^/][^/]*/\.\./' -changequote([,])dnl - # Canonicalize the path of ld - ac_prog=`echo $ac_prog| sed 's%\\\\%/%g'` - while echo $ac_prog | grep "$re_direlt" > /dev/null 2>&1; do - ac_prog=`echo $ac_prog| sed "s%$re_direlt%/%"` - done - test -z "$LD" && LD="$ac_prog" - ;; - "") - # If it fails, then pretend we aren't using GCC. - ac_prog=ld - ;; - *) - # If it is relative, then search for the first ld in PATH. - with_gnu_ld=unknown - ;; - esac -elif test "$with_gnu_ld" = yes; then - AC_MSG_CHECKING([for GNU ld]) -else - AC_MSG_CHECKING([for non-GNU ld]) -fi -AC_CACHE_VAL(ac_cv_path_LD, -[if test -z "$LD"; then - IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}${PATH_SEPARATOR-:}" - for ac_dir in $PATH; do - test -z "$ac_dir" && ac_dir=. - if test -f "$ac_dir/$ac_prog" || test -f "$ac_dir/$ac_prog$ac_exeext"; then - ac_cv_path_LD="$ac_dir/$ac_prog" - # Check to see if the program is GNU ld. I'd rather use --version, - # but apparently some GNU ld's only accept -v. - # Break only if it was the GNU/non-GNU ld that we prefer. - if "$ac_cv_path_LD" -v 2>&1 < /dev/null | egrep '(GNU|with BFD)' > /dev/null; then - test "$with_gnu_ld" != no && break - else - test "$with_gnu_ld" != yes && break - fi - fi - done - IFS="$ac_save_ifs" -else - ac_cv_path_LD="$LD" # Let the user override the test with a path. -fi]) -LD="$ac_cv_path_LD" -if test -n "$LD"; then - AC_MSG_RESULT($LD) -else - AC_MSG_RESULT(no) -fi -test -z "$LD" && AC_MSG_ERROR([no acceptable ld found in \$PATH]) -AC_PROG_LD_GNU -]) - -AC_DEFUN(AC_PROG_LD_GNU, -[AC_CACHE_CHECK([if the linker ($LD) is GNU ld], ac_cv_prog_gnu_ld, -[# I'd rather use --version here, but apparently some GNU ld's only accept -v. -if $LD -v 2>&1 &5; then - ac_cv_prog_gnu_ld=yes -else - ac_cv_prog_gnu_ld=no -fi]) -]) - -# AC_PROG_NM - find the path to a BSD-compatible name lister -AC_DEFUN(AC_PROG_NM, -[AC_MSG_CHECKING([for BSD-compatible nm]) -AC_CACHE_VAL(ac_cv_path_NM, -[if test -n "$NM"; then - # Let the user override the test. - ac_cv_path_NM="$NM" -else - IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}${PATH_SEPARATOR-:}" - for ac_dir in $PATH /usr/ccs/bin /usr/ucb /bin; do - test -z "$ac_dir" && ac_dir=. - if test -f $ac_dir/nm || test -f $ac_dir/nm$ac_exeext ; then - # Check to see if the nm accepts a BSD-compat flag. - # Adding the `sed 1q' prevents false positives on HP-UX, which says: - # nm: unknown option "B" ignored - if ($ac_dir/nm -B /dev/null 2>&1 | sed '1q'; exit 0) | egrep /dev/null >/dev/null; then - ac_cv_path_NM="$ac_dir/nm -B" - break - elif ($ac_dir/nm -p /dev/null 2>&1 | sed '1q'; exit 0) | egrep /dev/null >/dev/null; then - ac_cv_path_NM="$ac_dir/nm -p" - break - else - ac_cv_path_NM=${ac_cv_path_NM="$ac_dir/nm"} # keep the first match, but - continue # so that we can try to find one that supports BSD flags - fi - fi - done - IFS="$ac_save_ifs" - test -z "$ac_cv_path_NM" && ac_cv_path_NM=nm -fi]) -NM="$ac_cv_path_NM" -AC_MSG_RESULT([$NM]) -]) - -# AC_CHECK_LIBM - check for math library -AC_DEFUN(AC_CHECK_LIBM, -[AC_REQUIRE([AC_CANONICAL_HOST])dnl -LIBM= -case "$lt_target" in -*-*-beos* | *-*-cygwin*) - # These system don't have libm - ;; -*-ncr-sysv4.3*) - AC_CHECK_LIB(mw, _mwvalidcheckl, LIBM="-lmw") - AC_CHECK_LIB(m, main, LIBM="$LIBM -lm") - ;; -*) - AC_CHECK_LIB(m, main, LIBM="-lm") - ;; -esac -]) - -# AC_LIBLTDL_CONVENIENCE[(dir)] - sets LIBLTDL to the link flags for -# the libltdl convenience library, adds --enable-ltdl-convenience to -# the configure arguments. Note that LIBLTDL is not AC_SUBSTed, nor -# is AC_CONFIG_SUBDIRS called. If DIR is not provided, it is assumed -# to be `${top_builddir}/libltdl'. Make sure you start DIR with -# '${top_builddir}/' (note the single quotes!) if your package is not -# flat, and, if you're not using automake, define top_builddir as -# appropriate in the Makefiles. -AC_DEFUN(AC_LIBLTDL_CONVENIENCE, [AC_BEFORE([$0],[AC_LIBTOOL_SETUP])dnl - case "$enable_ltdl_convenience" in - no) AC_MSG_ERROR([this package needs a convenience libltdl]) ;; - "") enable_ltdl_convenience=yes - ac_configure_args="$ac_configure_args --enable-ltdl-convenience" ;; - esac - LIBLTDL=ifelse($#,1,$1,['${top_builddir}/libltdl'])/libltdlc.la - INCLTDL=ifelse($#,1,-I$1,['-I${top_srcdir}/libltdl']) -]) - -# AC_LIBLTDL_INSTALLABLE[(dir)] - sets LIBLTDL to the link flags for -# the libltdl installable library, and adds --enable-ltdl-install to -# the configure arguments. Note that LIBLTDL is not AC_SUBSTed, nor -# is AC_CONFIG_SUBDIRS called. If DIR is not provided, it is assumed -# to be `${top_builddir}/libltdl'. Make sure you start DIR with -# '${top_builddir}/' (note the single quotes!) if your package is not -# flat, and, if you're not using automake, define top_builddir as -# appropriate in the Makefiles. -# In the future, this macro may have to be called after AC_PROG_LIBTOOL. -AC_DEFUN(AC_LIBLTDL_INSTALLABLE, [AC_BEFORE([$0],[AC_LIBTOOL_SETUP])dnl - AC_CHECK_LIB(ltdl, main, - [test x"$enable_ltdl_install" != xyes && enable_ltdl_install=no], - [if test x"$enable_ltdl_install" = xno; then - AC_MSG_WARN([libltdl not installed, but installation disabled]) - else - enable_ltdl_install=yes - fi - ]) - if test x"$enable_ltdl_install" = x"yes"; then - ac_configure_args="$ac_configure_args --enable-ltdl-install" - LIBLTDL=ifelse($#,1,$1,['${top_builddir}/libltdl'])/libltdl.la - INCLTDL=ifelse($#,1,-I$1,['-I${top_builddir}/libltdl']) - else - ac_configure_args="$ac_configure_args --enable-ltdl-install=no" - LIBLTDL="-lltdl" - INCLTDL= - fi -]) - -dnl old names -AC_DEFUN(AM_PROG_LIBTOOL, [indir([AC_PROG_LIBTOOL])])dnl -AC_DEFUN(AM_ENABLE_SHARED, [indir([AC_ENABLE_SHARED], $@)])dnl -AC_DEFUN(AM_ENABLE_STATIC, [indir([AC_ENABLE_STATIC], $@)])dnl -AC_DEFUN(AM_DISABLE_SHARED, [indir([AC_DISABLE_SHARED], $@)])dnl -AC_DEFUN(AM_DISABLE_STATIC, [indir([AC_DISABLE_STATIC], $@)])dnl -AC_DEFUN(AM_PROG_LD, [indir([AC_PROG_LD])])dnl -AC_DEFUN(AM_PROG_NM, [indir([AC_PROG_NM])])dnl - -dnl This is just to silence aclocal about the macro not being used -ifelse([AC_DISABLE_FAST_INSTALL])dnl From 11bbab474a77ef0c190fd494db4ac81f5c8febdd Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 15 May 2001 00:54:23 +0000 Subject: [PATCH 1080/2047] *** empty log message *** --- ChangeLog | 4 ++++ ice-9/ChangeLog | 6 ++++++ libguile/ChangeLog | 5 +++++ 3 files changed, 15 insertions(+) diff --git a/ChangeLog b/ChangeLog index 4366dd4a6..a17fc1b35 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2001-05-15 Marius Vollmer + + * acinclude.m4: Removed copy of "libtool.m4". + 2001-05-14 Dirk Herrmann * configure.in (SCM_DEBUG_DEPRECATED): Always defined. diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index a81605198..08098d53b 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,9 @@ +2001-05-15 Marius Vollmer + + * boot-9.scm (error-catching-repl): Call the E + ("eval'er") procedure via call-with-values and call the P + ("printer") for each produced value. Thanks to Matthias Köppe! + 2001-05-14 Martin Grabmueller * boot-9.scm (cond-expand): Reduce feature list to built-in diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 41f9a5755..e52e956aa 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-05-15 Marius Vollmer + + * values.c (print_values): Print as a unreadable object, not as + multiple lines. Thanks to Matthias Köppe! + 2001-05-14 Dirk Herrmann * deprecation.c: Fixed copyright date. From 7c33806ae676601f902dbdc0f39c1f0828d68951 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 15 May 2001 09:45:10 +0000 Subject: [PATCH 1081/2047] * Make SCM_DEBUG_CELL_ACCESSES=1 work with GUILE_DEBUG_FREELIST. --- libguile/ChangeLog | 27 +++++++++++++++++++++++++++ libguile/eval.c | 8 +++++--- libguile/gc.c | 27 ++++++++++++++------------- libguile/gc.h | 4 ++-- libguile/init.c | 12 ++++++------ libguile/load.c | 2 +- libguile/strings.c | 4 +++- libguile/vectors.c | 2 ++ 8 files changed, 60 insertions(+), 26 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index e52e956aa..ea0440f89 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,30 @@ +2001-05-15 Dirk Herrmann + + * eval.c (scm_init_eval): Initialize scm_undefineds and + scm_listofnull. + + * gc.c (scm_debug_newcell, scm_debug_newcell2): Fixed to behave + like the SCM_NEWCELL macro counterparts. + + (scm_init_storage, scm_init_gc): Moved initialization of + scm_tc16_allocated from scm_init_gc to scm_init_storage. + + (scm_init_storage): Moved initialization of scm_undefineds and + scm_listofnull to eval.c, initializion of scm_nullstr to + strings.c, initializion of scm_nullvect to vectors.c. + + * gc.h (SCM_NEWCELL, SCM_NEWCELL2): Prefer SCM_NULLP over + SCM_IMP, as in scm_debug_newcell and scm_debug_newcell2. + + * init.c (scm_init_guile_1): Reordered some initializations and + added dependcy information comments. + + * load.c (scm_init_load): Use scm_nullstr. + + * strings.c (scm_init_strings): Initialize scm_nullstr. + + * vectors.c (scm_init_vectors): Initialize scm_nullvect. + 2001-05-15 Marius Vollmer * values.c (print_values): Print as a unreadable object, not as diff --git a/libguile/eval.c b/libguile/eval.c index 24f274938..a4fea7d63 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -4083,6 +4083,11 @@ scm_init_eval () scm_set_smob_mark (scm_tc16_promise, scm_markcdr); scm_set_smob_print (scm_tc16_promise, promise_print); + /* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */ + scm_undefineds = scm_cons (SCM_UNDEFINED, SCM_EOL); + SCM_SETCDR (scm_undefineds, scm_undefineds); + scm_listofnull = scm_cons (SCM_EOL, SCM_EOL); + scm_f_apply = scm_make_subr ("apply", scm_tc7_lsubr_2, scm_apply); scm_lisp_nil = scm_sysintern ("nil", SCM_UNDEFINED); @@ -4092,9 +4097,6 @@ scm_init_eval () SCM_SETCDR (scm_lisp_t, SCM_CAR (scm_lisp_t)); scm_lisp_t = SCM_CAR (scm_lisp_t); - /* acros */ - /* end of acros */ - #if SCM_DEBUG_DEPRECATED == 0 scm_top_level_lookup_closure_var = scm_sysintern ("*top-level-lookup-closure*", scm_make_fluid ()); diff --git a/libguile/gc.c b/libguile/gc.c index b92549f16..ddfbbec41 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -672,11 +672,15 @@ scm_debug_newcell (void) /* The rest of this is supposed to be identical to the SCM_NEWCELL macro. */ if (SCM_NULLP (scm_freelist)) - new = scm_gc_for_newcell (&scm_master_freelist, &scm_freelist); + { + new = scm_gc_for_newcell (&scm_master_freelist, &scm_freelist); + SCM_GC_SET_ALLOCATED (new); + } else { new = scm_freelist; scm_freelist = SCM_FREE_CELL_CDR (scm_freelist); + SCM_GC_SET_ALLOCATED (new); } return new; @@ -697,11 +701,15 @@ scm_debug_newcell2 (void) /* The rest of this is supposed to be identical to the SCM_NEWCELL macro. */ if (SCM_NULLP (scm_freelist2)) - new = scm_gc_for_newcell (&scm_master_freelist2, &scm_freelist2); + { + new = scm_gc_for_newcell (&scm_master_freelist2, &scm_freelist2); + SCM_GC_SET_ALLOCATED (new); + } else { new = scm_freelist2; scm_freelist2 = SCM_FREE_CELL_CDR (scm_freelist2); + SCM_GC_SET_ALLOCATED (new); } return new; @@ -2589,6 +2597,10 @@ scm_init_storage () scm_sizet init_heap_size_2; scm_sizet j; +#if (SCM_DEBUG_CELL_ACCESSES == 1) + scm_tc16_allocated = scm_make_smob_type ("allocated cell", 0); +#endif /* SCM_DEBUG_CELL_ACCESSES == 1 */ + j = SCM_NUM_PROTECTS; while (j) scm_sys_protects[--j] = SCM_BOOL_F; @@ -2641,13 +2653,6 @@ scm_init_storage () #endif #endif - scm_undefineds = scm_cons (SCM_UNDEFINED, SCM_EOL); - SCM_SETCDR (scm_undefineds, scm_undefineds); - - scm_listofnull = scm_cons (SCM_EOL, SCM_EOL); - scm_nullstr = scm_allocate_string (0); - scm_nullvect = scm_c_make_vector (0, SCM_UNDEFINED); - #define DEFAULT_SYMHASH_SIZE 277 scm_symhash = scm_c_make_hash_table (DEFAULT_SYMHASH_SIZE); scm_symhash_vars = scm_c_make_hash_table (DEFAULT_SYMHASH_SIZE); @@ -2695,10 +2700,6 @@ scm_init_gc () { SCM after_gc_thunk; -#if (SCM_DEBUG_CELL_ACCESSES == 1) - scm_tc16_allocated = scm_make_smob_type ("allocated cell", 0); -#endif /* SCM_DEBUG_CELL_ACCESSES == 1 */ - /* Dirk:FIXME:: scm_create_hook is strange. */ scm_after_gc_hook = scm_create_hook ("after-gc-hook", 0); diff --git a/libguile/gc.h b/libguile/gc.h index 150074f37..0fe4d513f 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -261,7 +261,7 @@ typedef unsigned long scm_c_bvec_limb_t; a freelist of its own. */ #define SCM_NEWCELL(_into) \ do { \ - if (SCM_IMP (scm_freelist)) \ + if (SCM_NULLP (scm_freelist)) \ { \ _into = scm_gc_for_newcell (&scm_master_freelist, \ &scm_freelist); \ @@ -276,7 +276,7 @@ typedef unsigned long scm_c_bvec_limb_t; } while(0) #define SCM_NEWCELL2(_into) \ do { \ - if (SCM_IMP (scm_freelist2)) \ + if (SCM_NULLP (scm_freelist2)) \ { \ _into = scm_gc_for_newcell (&scm_master_freelist2, \ &scm_freelist2); \ diff --git a/libguile/init.c b/libguile/init.c index c53d1a4ac..dacd1ee92 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -471,7 +471,7 @@ scm_init_guile_1 (SCM_STACKITEM *base) #ifdef GUILE_DEBUG_MALLOC scm_debug_malloc_prehistory (); #endif - scm_init_storage (); + scm_init_storage (); /* requires smob_prehistory */ scm_struct_prehistory (); /* requires storage */ scm_symbols_prehistory (); /* requires storage */ scm_weaks_prehistory (); /* requires storage */ @@ -541,17 +541,17 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_init_srcprop (); #endif scm_init_stackchk (); - scm_init_struct (); - scm_init_stacks (); /* Requires struct */ + scm_init_strings (); + scm_init_struct (); /* Requires strings */ + scm_init_stacks (); /* Requires strings, struct */ scm_init_symbols (); scm_init_tag (); scm_init_values (); /* Requires struct */ - scm_init_load (); + scm_init_load (); /* Requires strings */ scm_init_objects (); /* Requires struct */ - scm_init_print (); /* Requires struct */ + scm_init_print (); /* Requires strings, struct */ scm_init_read (); scm_init_stime (); - scm_init_strings (); scm_init_strorder (); scm_init_strop (); scm_init_throw (); diff --git a/libguile/load.c b/libguile/load.c index d6612b12c..98158e6da 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -513,7 +513,7 @@ scm_init_load () scm_loc_load_extensions = SCM_CDRLOC (scm_sysintern ("%load-extensions", SCM_LIST2 (scm_makfrom0str (".scm"), - scm_makfrom0str ("")))); + scm_nullstr))); scm_loc_load_hook = SCM_CDRLOC (scm_sysintern ("%load-hook", SCM_BOOL_F)); init_build_info (); diff --git a/libguile/strings.c b/libguile/strings.c index c4843ebf5..792b0f8af 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -48,7 +48,7 @@ #include "libguile/_scm.h" #include "libguile/chars.h" - +#include "libguile/root.h" #include "libguile/strings.h" #include "libguile/validate.h" @@ -437,6 +437,8 @@ SCM_DEFINE (scm_make_shared_substring, "make-shared-substring", 1, 2, 0, void scm_init_strings () { + scm_nullstr = scm_allocate_string (0); + #ifndef SCM_MAGIC_SNARFER #include "libguile/strings.x" #endif diff --git a/libguile/vectors.c b/libguile/vectors.c index e21c5b0aa..5958338c3 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -413,6 +413,8 @@ SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0, void scm_init_vectors () { + scm_nullvect = scm_c_make_vector (0, SCM_UNDEFINED); + #ifndef SCM_MAGIC_SNARFER #include "libguile/vectors.x" #endif From 86d31dfe7d0754b863863f6544c75097ef68fe8c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 15 May 2001 14:57:22 +0000 Subject: [PATCH 1082/2047] Merge from mvo-vcell-cleanup-1-branch. --- libguile/Makefile.am | 29 +- libguile/__scm.h | 9 + libguile/_scm.h | 2 + libguile/backtrace.c | 13 +- libguile/backtrace.h | 2 +- libguile/cpp_cnvt.awk | 2 +- libguile/debug.c | 48 ++- libguile/deprecation.c | 4 +- libguile/dynwind.c | 3 +- libguile/eval.c | 207 +++++------ libguile/eval.h | 14 +- libguile/evalext.c | 25 +- libguile/feature.c | 10 +- libguile/filesys.c | 38 +- libguile/fports.c | 6 +- libguile/gc.c | 102 ++---- libguile/gdbint.c | 6 +- libguile/gh_data.c | 8 +- libguile/gh_funcs.c | 3 +- libguile/goops.c | 13 +- libguile/gsubr.c | 8 +- libguile/hooks.c | 2 +- libguile/init.c | 5 +- libguile/keywords.c | 13 +- libguile/load.c | 12 +- libguile/macros.c | 6 +- libguile/modules.c | 339 +++++++++++++++--- libguile/modules.h | 23 +- libguile/numbers.c | 6 +- libguile/objects.c | 6 +- libguile/ports.c | 6 +- libguile/posix.c | 46 +-- libguile/print.c | 3 +- libguile/procs.c | 17 +- libguile/ramap.c | 11 +- libguile/random.c | 18 +- libguile/read.c | 2 +- libguile/regex-posix.c | 12 +- libguile/root.h | 22 +- libguile/scmsigs.c | 14 +- libguile/script.c | 2 +- libguile/snarf.h | 26 +- libguile/socket.c | 72 ++-- libguile/srcprop.c | 2 +- libguile/stacks.c | 6 +- libguile/stime.c | 2 +- libguile/struct.c | 9 +- libguile/symbols-deprecated.c | 637 ++++++++++++++++++++++++++++++++++ libguile/symbols.c | 631 +++------------------------------ libguile/symbols.h | 51 +-- libguile/tag.c | 108 ------ libguile/throw.c | 4 +- libguile/variable.c | 136 +++----- libguile/variable.h | 30 +- 54 files changed, 1538 insertions(+), 1293 deletions(-) create mode 100644 libguile/symbols-deprecated.c diff --git a/libguile/Makefile.am b/libguile/Makefile.am index caa46ff15..1931d2dc9 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -49,7 +49,7 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ random.c rdelim.c read.c root.c rw.c scmsigs.c script.c simpos.c smob.c \ sort.c srcprop.c stackchk.c stacks.c stime.c strings.c strop.c \ strorder.c strports.c struct.c symbols.c tag.c throw.c values.c \ - variable.c vectors.c version.c vports.c weaks.c + variable.c vectors.c version.c vports.c weaks.c symbols-deprecated.c DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ continuations.x debug.x deprecation.x dynl.x dynwind.x \ @@ -62,23 +62,24 @@ DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ scmsigs.x script.x simpos.x smob.x sort.x srcprop.x \ stackchk.x stacks.x stime.x strings.x strop.x strorder.x strports.x \ struct.x symbols.x tag.x throw.x values.x variable.x vectors.x \ - version.x vports.x weaks.x + version.x vports.x weaks.x symbols-deprecated.x EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@ -DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \ - boolean.doc chars.doc continuations.doc debug.doc dynl.doc \ - dynwind.doc environments.doc eq.doc error.doc eval.doc evalext.doc \ - feature.doc fluids.doc fports.doc gc.doc goops.doc gsubr.doc \ - guardians.doc hash.doc hashtab.doc hooks.doc init.doc ioext.doc \ - iselect.doc keywords.doc lang.doc list.doc load.doc macros.doc \ - mallocs.doc modules.doc numbers.doc objects.doc objprop.doc \ - options.doc pairs.doc ports.doc print.doc procprop.doc \ +DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \ + boolean.doc chars.doc continuations.doc debug.doc dynl.doc \ + dynwind.doc environments.doc eq.doc error.doc eval.doc evalext.doc \ + feature.doc fluids.doc fports.doc gc.doc goops.doc gsubr.doc \ + guardians.doc hash.doc hashtab.doc hooks.doc init.doc ioext.doc \ + iselect.doc keywords.doc lang.doc list.doc load.doc macros.doc \ + mallocs.doc modules.doc numbers.doc objects.doc objprop.doc \ + options.doc pairs.doc ports.doc print.doc procprop.doc \ procs.doc properties.doc random.doc rdelim.doc read.doc root.doc rw.doc \ - scmsigs.doc script.doc simpos.doc smob.doc sort.doc \ - srcprop.doc stackchk.doc stacks.doc stime.doc strings.doc strop.doc \ - strorder.doc strports.doc struct.doc symbols.doc tag.doc throw.doc \ - values.doc variable.doc vectors.doc version.doc vports.doc weaks.doc + scmsigs.doc script.doc simpos.doc smob.doc sort.doc \ + srcprop.doc stackchk.doc stacks.doc stime.doc strings.doc strop.doc \ + strorder.doc strports.doc struct.doc symbols.doc tag.doc throw.doc \ + values.doc variable.doc vectors.doc version.doc vports.doc weaks.doc \ + symbols-deprecated.doc EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@ diff --git a/libguile/__scm.h b/libguile/__scm.h index 8fe7c3b56..9e0fea279 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -195,6 +195,15 @@ #define SCM_DEBUG_TYPING_STRICTNESS 0 #endif +/* If SCM_ENABLE_VCELLS is set to 1, a couple of functions that deal + * with vcells are defined for compatability reasons. Supporting + * vcells reduces performance however. + * + * We use a dedicated macro instead of just SCM_DEBUG_DEPRECATED so + * that code the belongs to the `vcell' feature is easier to find. + */ +#define SCM_ENABLE_VCELLS !SCM_DEBUG_DEPRECATED + #ifdef HAVE_LONG_LONGS diff --git a/libguile/_scm.h b/libguile/_scm.h index 3ffdc64c4..ec9839d80 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -75,6 +75,8 @@ switching at async ticks. */ #endif #include "libguile/snarf.h" /* Everyone snarfs. */ +#include "libguile/variable.h" +#include "libguile/modules.h" /* SCM_SYSCALL retries system calls that have been interrupted (EINTR). However this can be avoided if the operating system can restart diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 4d2534ad3..95fb71cd0 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -80,7 +80,7 @@ return SCM_BOOL_F; #endif -SCM scm_the_last_stack_fluid; +SCM scm_the_last_stack_fluid_var; static void display_header (SCM source, SCM port) @@ -634,7 +634,7 @@ SCM_DEFINE (scm_display_backtrace, "display-backtrace", 2, 2, 0, } #undef FUNC_NAME -SCM_VCELL (scm_has_shown_backtrace_hint_p_var, "has-shown-backtrace-hint?"); +SCM_VARIABLE (scm_has_shown_backtrace_hint_p_var, "has-shown-backtrace-hint?"); SCM_DEFINE (scm_backtrace, "backtrace", 0, 0, 0, (), @@ -642,7 +642,8 @@ SCM_DEFINE (scm_backtrace, "backtrace", 0, 0, 0, "to the current output port.") #define FUNC_NAME s_scm_backtrace { - SCM the_last_stack = scm_fluid_ref (SCM_CDR (scm_the_last_stack_fluid)); + SCM the_last_stack = + scm_fluid_ref (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var)); if (SCM_NFALSEP (the_last_stack)) { scm_newline (scm_cur_outp); @@ -652,14 +653,14 @@ SCM_DEFINE (scm_backtrace, "backtrace", 0, 0, 0, SCM_UNDEFINED, SCM_UNDEFINED); scm_newline (scm_cur_outp); - if (SCM_FALSEP (SCM_CDR (scm_has_shown_backtrace_hint_p_var)) + if (SCM_FALSEP (SCM_VARIABLE_REF (scm_has_shown_backtrace_hint_p_var)) && !SCM_BACKTRACE_P) { scm_puts ("Type \"(debug-enable 'backtrace)\" if you would like " "a backtrace\n" "automatically if an error occurs in the future.\n", scm_cur_outp); - SCM_SETCDR (scm_has_shown_backtrace_hint_p_var, SCM_BOOL_T); + SCM_VARIABLE_SET (scm_has_shown_backtrace_hint_p_var, SCM_BOOL_T); } } else @@ -676,7 +677,7 @@ void scm_init_backtrace () { SCM f = scm_make_fluid (); - scm_the_last_stack_fluid = scm_sysintern ("the-last-stack", f); + scm_the_last_stack_fluid_var = scm_c_define ("the-last-stack", f); #ifndef SCM_MAGIC_SNARFER #include "libguile/backtrace.x" diff --git a/libguile/backtrace.h b/libguile/backtrace.h index 68f85a2c7..0bc8c0803 100644 --- a/libguile/backtrace.h +++ b/libguile/backtrace.h @@ -49,7 +49,7 @@ #include "libguile/__scm.h" -extern SCM scm_the_last_stack_fluid; +extern SCM scm_the_last_stack_fluid_var; void scm_display_error_message (SCM message, SCM args, SCM port); void scm_i_display_error (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest); diff --git a/libguile/cpp_cnvt.awk b/libguile/cpp_cnvt.awk index a01ba52a8..128136fa2 100644 --- a/libguile/cpp_cnvt.awk +++ b/libguile/cpp_cnvt.awk @@ -2,6 +2,6 @@ # in Guile. { print "#ifdef " $0; -print "scm_sysintern (\""$0"\", SCM_MAKINUM ("$0"));"; +print "scm_c_define (\""$0"\", SCM_MAKINUM ("$0"));"; print "#endif" } diff --git a/libguile/debug.c b/libguile/debug.c index 42981bfe7..c5e7468db 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -260,17 +260,12 @@ SCM_DEFINE (scm_make_gloc, "make-gloc", 1, 1, 0, "@var{env}.") #define FUNC_NAME s_scm_make_gloc { -#if 1 /* Unsafe */ - if (SCM_CONSP (var)) - var = scm_cons (SCM_BOOL_F, var); - else -#endif - SCM_VALIDATE_VARIABLE (1,var); + SCM_VALIDATE_VARIABLE (1,var); if (SCM_UNBNDP (env)) env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE); else SCM_VALIDATE_NULLORCONS (2,env); - return scm_make_memoized (SCM_VARVCELL (var) + 1, env); + return scm_make_memoized (SCM_UNPACK (var) + scm_tc3_cons_gloc, env); } #undef FUNC_NAME @@ -279,8 +274,9 @@ SCM_DEFINE (scm_gloc_p, "gloc?", 1, 0, 0, "Return @code{#t} if @var{obj} is a gloc.") #define FUNC_NAME s_scm_gloc_p { - return SCM_BOOL((SCM_MEMOIZEDP (obj) - && (SCM_UNPACK(SCM_MEMOIZED_EXP (obj)) & 7) == 1)); + return + SCM_BOOL (SCM_MEMOIZEDP (obj) + && ((SCM_UNPACK(SCM_MEMOIZED_EXP(obj))&7) == scm_tc3_cons_gloc)); } #undef FUNC_NAME @@ -623,23 +619,23 @@ scm_init_debug () scm_set_smob_print (scm_tc16_debugobj, debugobj_print); #ifdef GUILE_DEBUG - scm_sysintern ("SCM_IM_AND", SCM_IM_AND); - scm_sysintern ("SCM_IM_BEGIN", SCM_IM_BEGIN); - scm_sysintern ("SCM_IM_CASE", SCM_IM_CASE); - scm_sysintern ("SCM_IM_COND", SCM_IM_COND); - scm_sysintern ("SCM_IM_DO", SCM_IM_DO); - scm_sysintern ("SCM_IM_IF", SCM_IM_IF); - scm_sysintern ("SCM_IM_LAMBDA", SCM_IM_LAMBDA); - scm_sysintern ("SCM_IM_LET", SCM_IM_LET); - scm_sysintern ("SCM_IM_LETSTAR", SCM_IM_LETSTAR); - scm_sysintern ("SCM_IM_LETREC", SCM_IM_LETREC); - scm_sysintern ("SCM_IM_OR", SCM_IM_OR); - scm_sysintern ("SCM_IM_QUOTE", SCM_IM_QUOTE); - scm_sysintern ("SCM_IM_SET_X", SCM_IM_SET_X); - scm_sysintern ("SCM_IM_DEFINE", SCM_IM_DEFINE); - scm_sysintern ("SCM_IM_APPLY", SCM_IM_APPLY); - scm_sysintern ("SCM_IM_CONT", SCM_IM_CONT); - scm_sysintern ("SCM_IM_DISPATCH", SCM_IM_DISPATCH); + scm_define ("SCM_IM_AND", SCM_IM_AND); + scm_define ("SCM_IM_BEGIN", SCM_IM_BEGIN); + scm_define ("SCM_IM_CASE", SCM_IM_CASE); + scm_define ("SCM_IM_COND", SCM_IM_COND); + scm_define ("SCM_IM_DO", SCM_IM_DO); + scm_define ("SCM_IM_IF", SCM_IM_IF); + scm_define ("SCM_IM_LAMBDA", SCM_IM_LAMBDA); + scm_define ("SCM_IM_LET", SCM_IM_LET); + scm_define ("SCM_IM_LETSTAR", SCM_IM_LETSTAR); + scm_define ("SCM_IM_LETREC", SCM_IM_LETREC); + scm_define ("SCM_IM_OR", SCM_IM_OR); + scm_define ("SCM_IM_QUOTE", SCM_IM_QUOTE); + scm_define ("SCM_IM_SET_X", SCM_IM_SET_X); + scm_define ("SCM_IM_DEFINE", SCM_IM_DEFINE); + scm_define ("SCM_IM_APPLY", SCM_IM_APPLY); + scm_define ("SCM_IM_CONT", SCM_IM_CONT); + scm_define ("SCM_IM_DISPATCH", SCM_IM_DISPATCH); #endif scm_add_feature ("debug-extensions"); diff --git a/libguile/deprecation.c b/libguile/deprecation.c index a8e2e6cab..b826f190e 100644 --- a/libguile/deprecation.c +++ b/libguile/deprecation.c @@ -116,8 +116,8 @@ print_deprecation_summary (void) SCM_DEFINE(scm_include_deprecated_features, "include-deprecated-features", 0, 0, 0, (), - "Return @code{#t} iff deprecated features should be included\n" - "in public interfaces.") + "Return @code{#t} iff deprecated features should be included + in public interfaces.") #define FUNC_NAME s_scm_include_deprecated_features { #if SCM_DEBUG_DEPRECATED == 0 diff --git a/libguile/dynwind.c b/libguile/dynwind.c index c79097b61..54323a568 100644 --- a/libguile/dynwind.c +++ b/libguile/dynwind.c @@ -193,8 +193,7 @@ scm_swap_bindings (SCM glocs, SCM vals) while (SCM_NIMP (vals)) { tmp = SCM_GLOC_VAL (SCM_CAR (glocs)); - SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (glocs)) - 1L), - SCM_CAR (vals)); + SCM_GLOC_SET_VAL (SCM_CAR (glocs), SCM_CAR (vals)); SCM_SETCAR (vals, tmp); glocs = SCM_CDR (glocs); vals = SCM_CDR (vals); diff --git a/libguile/eval.c b/libguile/eval.c index a4fea7d63..5d8185c9f 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -52,7 +52,6 @@ * marked with the string "SECTION:". */ - /* SECTION: This code is compiled once. */ @@ -265,9 +264,6 @@ scm_lookupcar (SCM vloc, SCM genv, int check) { SCM env = genv; register SCM *al, fl, var = SCM_CAR (vloc); -#ifdef USE_THREADS - register SCM var2 = var; -#endif #ifdef MEMOIZE_LOCALS register SCM iloc = SCM_ILOC00; #endif @@ -322,69 +318,70 @@ scm_lookupcar (SCM vloc, SCM genv, int check) #endif } { - SCM top_thunk, vcell; + SCM top_thunk, real_var; if (SCM_NIMP (env)) { - top_thunk = SCM_CAR (env); /* env now refers to a top level env thunk */ + top_thunk = SCM_CAR (env); /* env now refers to a + top level env thunk */ env = SCM_CDR (env); } else top_thunk = SCM_BOOL_F; - vcell = scm_sym2vcell (var, top_thunk, SCM_BOOL_F); - if (SCM_FALSEP (vcell)) + real_var = scm_sym2var (var, top_thunk, SCM_BOOL_F); + if (SCM_FALSEP (real_var)) goto errout; - else - var = vcell; - } + #ifndef SCM_RECKLESS - if (SCM_NNULLP (env) || SCM_UNBNDP (SCM_CDR (var))) - { - var = SCM_CAR (var); - errout: - /* scm_everr (vloc, genv,...) */ - if (check) - { - if (SCM_NULLP (env)) - scm_error (scm_unbound_variable_key, NULL, "Unbound variable: ~S", - scm_cons (var, SCM_EOL), SCM_BOOL_F); - else - scm_misc_error (NULL, "Damaged environment: ~S", - scm_cons (var, SCM_EOL)); - } - else { - /* A variable could not be found, but we shall not throw an error. */ - static SCM undef_object = SCM_UNDEFINED; - return &undef_object; + if (SCM_NNULLP (env) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var))) + { + errout: + /* scm_everr (vloc, genv,...) */ + if (check) + { + if (SCM_NULLP (env)) + scm_error (scm_unbound_variable_key, NULL, + "Unbound variable: ~S", + scm_cons (var, SCM_EOL), SCM_BOOL_F); + else + scm_misc_error (NULL, "Damaged environment: ~S", + scm_cons (var, SCM_EOL)); + } + else + { + /* A variable could not be found, but we shall + not throw an error. */ + static SCM undef_object = SCM_UNDEFINED; + return &undef_object; + } } - } #endif + #ifdef USE_THREADS - if (SCM_CAR (vloc) != var2) - { - /* Some other thread has changed the very cell we are working - on. In effect, it must have done our job or messed it up - completely. */ - race: - var = SCM_CAR (vloc); - if (SCM_ITAG3 (var) == scm_tc3_cons_gloc) - return SCM_GLOC_VAL_LOC (var); + if (SCM_CAR (vloc) != var) + { + /* Some other thread has changed the very cell we are working + on. In effect, it must have done our job or messed it up + completely. */ + race: + var = SCM_CAR (vloc); + if (SCM_ITAG3 (var) == scm_tc3_cons_gloc) + return SCM_GLOC_VAL_LOC (var); #ifdef MEMOIZE_LOCALS - if (SCM_ITAG7 (var) == SCM_ITAG7 (SCM_ILOC00)) - return scm_ilookup (var, genv); + if (SCM_ITAG7 (var) == SCM_ITAG7 (SCM_ILOC00)) + return scm_ilookup (var, genv); #endif - /* We can't cope with anything else than glocs and ilocs. When - a special form has been memoized (i.e. `let' into `#@let') we - return NULL and expect the calling function to do the right - thing. For the evaluator, this means going back and redoing - the dispatch on the car of the form. */ - return NULL; - } + /* We can't cope with anything else than glocs and ilocs. When + a special form has been memoized (i.e. `let' into `#@let') we + return NULL and expect the calling function to do the right + thing. For the evaluator, this means going back and redoing + the dispatch on the car of the form. */ + return NULL; + } #endif /* USE_THREADS */ - SCM_SET_CELL_WORD_0 (vloc, SCM_UNPACK (var) + scm_tc3_cons_gloc); - /* Except wait...what if the var is not a vcell, - * but syntax or something.... */ - return SCM_CDRLOC (var); + SCM_SET_CELL_WORD_0 (vloc, SCM_UNPACK (real_var) + scm_tc3_cons_gloc); + return SCM_VARIABLE_LOC (real_var); + } } #ifdef USE_THREADS @@ -400,6 +397,8 @@ scm_lookupcar (SCM vloc, SCM genv, int check) #define unmemocar scm_unmemocar +SCM_SYMBOL (sym_three_question_marks, "???"); + SCM scm_unmemocar (SCM form, SCM env) { @@ -409,7 +408,13 @@ scm_unmemocar (SCM form, SCM env) return form; c = SCM_CAR (form); if (SCM_ITAG3 (c) == scm_tc3_cons_gloc) - SCM_SETCAR (form, SCM_GLOC_SYM (c)); + { + SCM sym = + scm_module_reverse_lookup (scm_env_module (env), SCM_GLOC_VAR (c)); + if (sym == SCM_BOOL_F) + sym = sym_three_question_marks; + SCM_SETCAR (form, sym); + } #ifdef MEMOIZE_LOCALS #ifdef DEBUG_EXTENSIONS else if (SCM_ILOCP (c)) @@ -885,10 +890,10 @@ scm_m_define (SCM x, SCM env) } } #endif - arg1 = scm_sym2vcell (proc, scm_env_top_level (env), SCM_BOOL_T); - SCM_SETCDR (arg1, x); + arg1 = scm_sym2var (proc, scm_env_top_level (env), SCM_BOOL_T); + SCM_VARIABLE_SET (arg1, x); #ifdef SICP - return scm_cons2 (scm_sym_quote, SCM_CAR (arg1), SCM_EOL); + return scm_cons2 (scm_sym_quote, proc, SCM_EOL); #else return SCM_UNSPECIFIED; #endif @@ -1030,8 +1035,8 @@ scm_m_cont (SCM xorig, SCM env) /* Multi-language support */ -SCM scm_lisp_nil; -SCM scm_lisp_t; +SCM_GLOBAL_SYMBOL (scm_lisp_nil, "nil"); +SCM_GLOBAL_SYMBOL (scm_lisp_t, "t"); SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond); @@ -1094,12 +1099,12 @@ SCM_SYNTAX (s_atfop, "@fop", scm_makmmacro, scm_m_atfop); SCM scm_m_atfop (SCM xorig, SCM env) { - SCM x = SCM_CDR (xorig), vcell; + SCM x = SCM_CDR (xorig), var; SCM_ASSYNT (scm_ilength (x) >= 1, scm_s_expression, "@fop"); - vcell = scm_symbol_fref (SCM_CAR (x)); - SCM_ASSYNT (SCM_CONSP (vcell), + var = scm_symbol_fref (SCM_CAR (x)); + SCM_ASSYNT (SCM_VARIABLEP (var), "Symbol's function definition is void", NULL); - SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (vcell) + scm_tc3_cons_gloc); + SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (var) + scm_tc3_cons_gloc); return x; } @@ -1125,7 +1130,7 @@ scm_m_atbind (SCM xorig, SCM env) x = SCM_CAR (x); while (SCM_NIMP (x)) { - SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (scm_sym2vcell (SCM_CAR (x), env, SCM_BOOL_T)) + scm_tc3_cons_gloc); + SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (scm_sym2var (SCM_CAR (x), env, SCM_BOOL_T)) + scm_tc3_cons_gloc); x = SCM_CDR (x); } return scm_cons (SCM_IM_BIND, SCM_CDR (xorig)); @@ -1202,13 +1207,14 @@ scm_m_expand_body (SCM xorig, SCM env) SCM scm_macroexp (SCM x, SCM env) { - SCM res, proc; + SCM res, proc, orig_sym; /* Don't bother to produce error messages here. We get them when we eventually execute the code for real. */ macro_tail: - if (!SCM_SYMBOLP (SCM_CAR (x))) + orig_sym = SCM_CAR (x); + if (!SCM_SYMBOLP (orig_sym)) return x; #ifdef USE_THREADS @@ -1231,7 +1237,7 @@ scm_macroexp (SCM x, SCM env) if (!SCM_MACROP (proc) || SCM_MACRO_TYPE (proc) != 2) return x; - unmemocar (x, env); + SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */ res = scm_apply (SCM_MACRO_CODE (proc), x, scm_cons (env, scm_listofnull)); if (scm_ilength (res) <= 0) @@ -1252,13 +1258,12 @@ scm_macroexp (SCM x, SCM env) * code of a closure, in scm_procedure_source, in display_frame when * generating the source for a stackframe in a backtrace, and in * display_expression. - */ - -/* We should introduce an anti-macro interface so that it is possible - * to plug in transformers in both directions from other compilation - * units. unmemocopy could then dispatch to anti-macro transformers. - * (Those transformers could perhaps be written in slightly more - * readable style... :) + * + * Unmemoizing is not a realiable process. You can not in general + * expect to get the original source back. + * + * However, GOOPS currently relies on this for method compilation. + * This ought to change. */ #define SCM_BIT8(x) (127 & SCM_UNPACK (x)) @@ -1519,11 +1524,12 @@ scm_eval_args (SCM l, SCM env, SCM proc) } else if (SCM_TYP3 (l) == scm_tc3_cons_gloc) { - scm_bits_t vcell = SCM_STRUCT_VTABLE_DATA (l) [scm_vtable_index_vcell]; + scm_bits_t vcell = + SCM_STRUCT_VTABLE_DATA (l) [scm_vtable_index_vcell]; if (vcell == 0) res = SCM_CAR (l); /* struct planted in code */ else - res = SCM_PACK (vcell); + res = SCM_GLOC_VAL (SCM_CAR (l)); } else goto wrongnumargs; @@ -1742,11 +1748,12 @@ scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc) } else if (SCM_TYP3 (l) == scm_tc3_cons_gloc) { - scm_bits_t vcell = SCM_STRUCT_VTABLE_DATA (l) [scm_vtable_index_vcell]; + scm_bits_t vcell = + SCM_STRUCT_VTABLE_DATA (l) [scm_vtable_index_vcell]; if (vcell == 0) res = SCM_CAR (l); /* struct planted in code */ else - res = SCM_PACK (vcell); + res = SCM_GLOC_VAL (SCM_CAR (l)); } else goto wrongnumargs; @@ -1814,7 +1821,7 @@ SCM_CEVAL (SCM x, SCM env) SCM *lloc; SCM arg1; } t; - SCM proc, arg2; + SCM proc, arg2, orig_sym; #ifdef DEVAL scm_debug_frame debug; scm_debug_info *debug_info_end; @@ -2542,7 +2549,7 @@ dispatch: /* This is a struct implanted in the code, not a gloc. */ RETURN (x); } else { - proc = SCM_PACK (vcell); + proc = SCM_GLOC_VAL (SCM_CAR (x)); SCM_ASRTGO (SCM_NIMP (proc), badfun); #ifndef SCM_RECKLESS #ifdef SCM_CAUTIOUS @@ -2554,7 +2561,8 @@ dispatch: } case scm_tcs_cons_nimcar: - if (SCM_SYMBOLP (SCM_CAR (x))) + orig_sym = SCM_CAR (x); + if (SCM_SYMBOLP (orig_sym)) { #ifdef USE_THREADS t.lloc = scm_lookupcar1 (x, env, 1); @@ -2570,13 +2578,14 @@ dispatch: if (SCM_IMP (proc)) { - unmemocar (x, env); + SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of + lookupcar */ goto badfun; } if (SCM_MACROP (proc)) { - unmemocar (x, env); - + SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of + lookupcar */ handle_a_macro: #ifdef DEVAL /* Set a flag during macro expansion so that macro @@ -2692,7 +2701,7 @@ evapply: x = SCM_CODE (proc); env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), SCM_EOL, SCM_ENV (proc)); goto nontoplevel_cdrxbegin; - case scm_tcs_cons_gloc: + case scm_tcs_cons_gloc: /* really structs, not glocs */ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { x = SCM_ENTITY_PROCEDURE (proc); @@ -2751,7 +2760,7 @@ evapply: if (vcell == 0) t.arg1 = SCM_CAR (x); /* struct planted in code */ else - t.arg1 = SCM_PACK (vcell); + t.arg1 = SCM_GLOC_VAL (SCM_CAR (x)); } else goto wrongnumargs; @@ -2847,7 +2856,7 @@ evapply: env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc)); #endif goto nontoplevel_cdrxbegin; - case scm_tcs_cons_gloc: + case scm_tcs_cons_gloc: /* really structs, not glocs */ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { x = SCM_ENTITY_PROCEDURE (proc); @@ -2901,7 +2910,7 @@ evapply: if (vcell == 0) arg2 = SCM_CAR (x); /* struct planted in code */ else - arg2 = SCM_PACK (vcell); + arg2 = SCM_GLOC_VAL (SCM_CAR (x)); } else goto wrongnumargs; @@ -2951,7 +2960,7 @@ evapply: proc))), SCM_EOL)); #endif - case scm_tcs_cons_gloc: + case scm_tcs_cons_gloc: /* really structs, not glocs */ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { x = SCM_ENTITY_PROCEDURE (proc); @@ -3165,7 +3174,7 @@ evapply: x = SCM_CODE (proc); goto nontoplevel_cdrxbegin; #endif /* DEVAL */ - case scm_tcs_cons_gloc: + case scm_tcs_cons_gloc: /* really structs, not glocs */ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { #ifdef DEVAL @@ -3541,7 +3550,7 @@ tail: debug.vect[0].a.proc = proc; #endif goto tail; - case scm_tcs_cons_gloc: + case scm_tcs_cons_gloc: /* really structs, not glocs */ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { #ifdef DEVAL @@ -3752,6 +3761,7 @@ SCM scm_closure (SCM code, SCM env) { register SCM z; + SCM_NEWCELL (z); SCM_SETCODE (z, code); SCM_SETENV (z, env); @@ -4090,24 +4100,23 @@ scm_init_eval () scm_f_apply = scm_make_subr ("apply", scm_tc7_lsubr_2, scm_apply); - scm_lisp_nil = scm_sysintern ("nil", SCM_UNDEFINED); - SCM_SETCDR (scm_lisp_nil, SCM_CAR (scm_lisp_nil)); - scm_lisp_nil = SCM_CAR (scm_lisp_nil); - scm_lisp_t = scm_sysintern ("t", SCM_UNDEFINED); - SCM_SETCDR (scm_lisp_t, SCM_CAR (scm_lisp_t)); - scm_lisp_t = SCM_CAR (scm_lisp_t); - + /* acros */ + /* end of acros */ + #if SCM_DEBUG_DEPRECATED == 0 scm_top_level_lookup_closure_var = - scm_sysintern ("*top-level-lookup-closure*", scm_make_fluid ()); + scm_c_define ("*top-level-lookup-closure*", scm_make_fluid ()); scm_system_transformer = - scm_sysintern ("scm:eval-transformer", scm_make_fluid ()); + scm_c_define ("scm:eval-transformer", scm_make_fluid ()); #endif #ifndef SCM_MAGIC_SNARFER #include "libguile/eval.x" #endif + scm_c_define ("nil", scm_lisp_nil); + scm_c_define ("t", scm_lisp_t); + scm_add_feature ("delay"); } diff --git a/libguile/eval.h b/libguile/eval.h index aee3a399d..80e0e5faa 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -46,8 +46,6 @@ #include "libguile/__scm.h" -/* Needed by SCM_TOP_LEVEL_LOOKUP_CLOSURE below. */ - #include "struct.h" @@ -131,8 +129,7 @@ extern SCM scm_eval_options_interface (SCM setting); /*fixme* This should probably be removed throught the code. */ -#define SCM_TOP_LEVEL_LOOKUP_CLOSURE \ - SCM_MODULE_EVAL_CLOSURE (scm_current_module ()) +#define SCM_TOP_LEVEL_LOOKUP_CLOSURE (scm_current_module_lookup_closure()) #if SCM_DEBUG_DEPRECATED == 0 @@ -181,13 +178,14 @@ extern SCM scm_sym_args; extern SCM scm_f_apply; /* A resolved global variable reference in the CAR position - * of a list is stored (in code only) as a pointer to a pair with a + * of a list is stored (in code only) as a pointer to a variable with a * tag of 1. This is called a "gloc". */ -#define SCM_GLOC_SYM(x) (SCM_CAR (SCM_PACK (SCM_UNPACK (x) - 1L))) -#define SCM_GLOC_VAL(x) (SCM_CDR (SCM_PACK (SCM_UNPACK (x) - 1L))) -#define SCM_GLOC_VAL_LOC(x) (SCM_CDRLOC (SCM_PACK (SCM_UNPACK (x) - 1L))) +#define SCM_GLOC_VAR(x) (SCM_PACK(SCM_UNPACK(x)-scm_tc3_cons_gloc)) +#define SCM_GLOC_VAL(x) (SCM_VARIABLE_REF (SCM_GLOC_VAR (x))) +#define SCM_GLOC_SET_VAL(x, y) (SCM_VARIABLE_SET (SCM_GLOC_VAR (x), y)) +#define SCM_GLOC_VAL_LOC(x) (SCM_VARIABLE_LOC (SCM_GLOC_VAR (x))) diff --git a/libguile/evalext.c b/libguile/evalext.c index 1cbac13f7..a36ef687b 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -77,16 +77,13 @@ SCM_DEFINE (scm_definedp, "defined?", 1, 1, 0, "current module.") #define FUNC_NAME s_scm_definedp { - SCM vcell; + SCM var; SCM_VALIDATE_SYMBOL (1,sym); if (SCM_UNBNDP (env)) - vcell = scm_sym2vcell(sym, - scm_module_system_booted_p - ? SCM_TOP_LEVEL_LOOKUP_CLOSURE - : SCM_EOL, - SCM_BOOL_F); + var = scm_sym2var (sym, scm_current_module_lookup_closure (), + SCM_BOOL_F); else { SCM frames = env; @@ -111,12 +108,12 @@ SCM_DEFINE (scm_definedp, "defined?", 1, 1, 0, return SCM_BOOL_T; } } - vcell = scm_sym2vcell (sym, - SCM_NIMP (frames) ? SCM_CAR (frames) : SCM_BOOL_F, - SCM_BOOL_F); + var = scm_sym2var (sym, + SCM_NIMP (frames) ? SCM_CAR (frames) : SCM_BOOL_F, + SCM_BOOL_F); } - return (SCM_FALSEP (vcell) || SCM_UNBNDP (SCM_CDR (vcell)) + return (SCM_FALSEP (var) || SCM_UNBNDP (SCM_VARIABLE_REF (var)) ? SCM_BOOL_F : SCM_BOOL_T); } @@ -135,12 +132,12 @@ scm_m_undefine (SCM x, SCM env) scm_s_expression, s_undefine); x = SCM_CAR (x); SCM_ASSYNT (SCM_SYMBOLP (x), scm_s_variable, s_undefine); - arg1 = scm_sym2vcell (x, scm_env_top_level (env), SCM_BOOL_F); - SCM_ASSYNT (SCM_NFALSEP (arg1) && !SCM_UNBNDP (SCM_CDR (arg1)), + arg1 = scm_sym2var (x, scm_env_top_level (env), SCM_BOOL_F); + SCM_ASSYNT (SCM_NFALSEP (arg1) && !SCM_UNBNDP (SCM_VARIABLE_REF (arg1)), "variable already unbound ", s_undefine); - SCM_SETCDR (arg1, SCM_UNDEFINED); + SCM_VARIABLE_SET (arg1, SCM_UNDEFINED); #ifdef SICP - return SCM_CAR (arg1); + return x; #else return SCM_UNSPECIFIED; #endif diff --git a/libguile/feature.c b/libguile/feature.c index d37b83ce9..43073e91d 100644 --- a/libguile/feature.c +++ b/libguile/feature.c @@ -57,15 +57,15 @@ -static SCM features; +static SCM features_var; void scm_add_feature (const char *str) { - SCM old = SCM_CDR (features); + SCM old = SCM_VARIABLE_REF (features_var); SCM new = scm_cons (scm_str2symbol (str), old); - SCM_SETCDR (features, new); + SCM_VARIABLE_SET (features_var, new); } @@ -103,7 +103,7 @@ scm_set_program_arguments (int argc, char **argv, char *first) void scm_init_feature() { - features = scm_sysintern ("*features*", SCM_EOL); + features_var = scm_c_define ("*features*", SCM_EOL); #ifdef SCM_RECKLESS scm_add_feature("reckless"); #endif @@ -126,7 +126,7 @@ scm_init_feature() scm_add_feature ("threads"); #endif - scm_sysintern ("char-code-limit", SCM_MAKINUM (SCM_CHAR_CODE_LIMIT)); + scm_c_define ("char-code-limit", SCM_MAKINUM (SCM_CHAR_CODE_LIMIT)); #ifndef SCM_MAGIC_SNARFER #include "libguile/feature.x" diff --git a/libguile/filesys.c b/libguile/filesys.c index 81b7522a7..e48d37764 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1440,62 +1440,62 @@ scm_init_filesys () scm_dot_string = scm_permanent_object (scm_makfrom0str (".")); #ifdef O_RDONLY -scm_sysintern ("O_RDONLY", scm_long2num (O_RDONLY)); + scm_c_define ("O_RDONLY", scm_long2num (O_RDONLY)); #endif #ifdef O_WRONLY -scm_sysintern ("O_WRONLY", scm_long2num (O_WRONLY)); + scm_c_define ("O_WRONLY", scm_long2num (O_WRONLY)); #endif #ifdef O_RDWR -scm_sysintern ("O_RDWR", scm_long2num (O_RDWR)); + scm_c_define ("O_RDWR", scm_long2num (O_RDWR)); #endif #ifdef O_CREAT -scm_sysintern ("O_CREAT", scm_long2num (O_CREAT)); + scm_c_define ("O_CREAT", scm_long2num (O_CREAT)); #endif #ifdef O_EXCL -scm_sysintern ("O_EXCL", scm_long2num (O_EXCL)); + scm_c_define ("O_EXCL", scm_long2num (O_EXCL)); #endif #ifdef O_NOCTTY -scm_sysintern ("O_NOCTTY", scm_long2num (O_NOCTTY)); + scm_c_define ("O_NOCTTY", scm_long2num (O_NOCTTY)); #endif #ifdef O_TRUNC -scm_sysintern ("O_TRUNC", scm_long2num (O_TRUNC)); + scm_c_define ("O_TRUNC", scm_long2num (O_TRUNC)); #endif #ifdef O_APPEND -scm_sysintern ("O_APPEND", scm_long2num (O_APPEND)); + scm_c_define ("O_APPEND", scm_long2num (O_APPEND)); #endif #ifdef O_NONBLOCK -scm_sysintern ("O_NONBLOCK", scm_long2num (O_NONBLOCK)); + scm_c_define ("O_NONBLOCK", scm_long2num (O_NONBLOCK)); #endif #ifdef O_NDELAY -scm_sysintern ("O_NDELAY", scm_long2num (O_NDELAY)); + scm_c_define ("O_NDELAY", scm_long2num (O_NDELAY)); #endif #ifdef O_SYNC -scm_sysintern ("O_SYNC", scm_long2num (O_SYNC)); + scm_c_define ("O_SYNC", scm_long2num (O_SYNC)); #endif #ifdef F_DUPFD -scm_sysintern ("F_DUPFD", scm_long2num (F_DUPFD)); + scm_c_define ("F_DUPFD", scm_long2num (F_DUPFD)); #endif #ifdef F_GETFD -scm_sysintern ("F_GETFD", scm_long2num (F_GETFD)); + scm_c_define ("F_GETFD", scm_long2num (F_GETFD)); #endif #ifdef F_SETFD -scm_sysintern ("F_SETFD", scm_long2num (F_SETFD)); + scm_c_define ("F_SETFD", scm_long2num (F_SETFD)); #endif #ifdef F_GETFL -scm_sysintern ("F_GETFL", scm_long2num (F_GETFL)); + scm_c_define ("F_GETFL", scm_long2num (F_GETFL)); #endif #ifdef F_SETFL -scm_sysintern ("F_SETFL", scm_long2num (F_SETFL)); + scm_c_define ("F_SETFL", scm_long2num (F_SETFL)); #endif #ifdef F_GETOWN -scm_sysintern ("F_GETOWN", scm_long2num (F_GETOWN)); + scm_c_define ("F_GETOWN", scm_long2num (F_GETOWN)); #endif #ifdef F_SETOWN -scm_sysintern ("F_SETOWN", scm_long2num (F_SETOWN)); + scm_c_define ("F_SETOWN", scm_long2num (F_SETOWN)); #endif #ifdef FD_CLOEXEC -scm_sysintern ("FD_CLOEXEC", scm_long2num (FD_CLOEXEC)); + scm_c_define ("FD_CLOEXEC", scm_long2num (FD_CLOEXEC)); #endif #ifndef SCM_MAGIC_SNARFER diff --git a/libguile/fports.c b/libguile/fports.c index 422d7d938..4579d3eb7 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -802,9 +802,9 @@ scm_init_fports () { scm_tc16_fport = scm_make_fptob (); - scm_sysintern ("_IOFBF", SCM_MAKINUM (_IOFBF)); - scm_sysintern ("_IOLBF", SCM_MAKINUM (_IOLBF)); - scm_sysintern ("_IONBF", SCM_MAKINUM (_IONBF)); + scm_c_define ("_IOFBF", SCM_MAKINUM (_IOFBF)); + scm_c_define ("_IOLBF", SCM_MAKINUM (_IOLBF)); + scm_c_define ("_IONBF", SCM_MAKINUM (_IONBF)); #ifndef SCM_MAGIC_SNARFER #include "libguile/fports.x" diff --git a/libguile/gc.c b/libguile/gc.c index ddfbbec41..d93bf1ae8 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1145,6 +1145,17 @@ MARK (SCM p) goto gc_mark_loop_first_time; #endif +/* A simple hack for debugging. Chose the second branch to get a + meaningful backtrace for crashes inside the GC. +*/ +#if 1 +#define goto_gc_mark_loop goto gc_mark_loop +#define goto_gc_mark_nimp goto gc_mark_nimp +#else +#define goto_gc_mark_loop RECURSE(ptr); return +#define goto_gc_mark_nimp RECURSE(ptr); return +#endif + gc_mark_loop: if (SCM_IMP (ptr)) return; @@ -1187,26 +1198,31 @@ gc_mark_loop_first_time: if (SCM_IMP (SCM_CDR (ptr))) { ptr = SCM_CAR (ptr); - goto gc_mark_nimp; + goto_gc_mark_nimp; } RECURSE (SCM_CAR (ptr)); ptr = SCM_CDR (ptr); - goto gc_mark_nimp; + goto_gc_mark_nimp; case scm_tcs_cons_imcar: ptr = SCM_CDR (ptr); - goto gc_mark_loop; + goto_gc_mark_loop; case scm_tc7_pws: RECURSE (SCM_SETTER (ptr)); ptr = SCM_PROCEDURE (ptr); - goto gc_mark_loop; + goto_gc_mark_loop; case scm_tcs_cons_gloc: { - /* Dirk:FIXME:: The following code is super ugly: ptr may be a struct - * or a gloc. If it is a gloc, the cell word #0 of ptr is a pointer - * to a heap cell. If it is a struct, the cell word #0 of ptr is a - * pointer to a struct vtable data region. The fact that these are - * accessed in the same way restricts the possibilites to change the - * data layout of structs or heap cells. + /* Dirk:FIXME:: The following code is super ugly: ptr may be a + * struct or a gloc. If it is a gloc, the cell word #0 of ptr + * is the address of a scm_tc16_variable smob. If it is a + * struct, the cell word #0 of ptr is a pointer to a struct + * vtable data region. (The fact that these are accessed in + * the same way restricts the possibilites to change the data + * layout of structs or heap cells.) To discriminate between + * the two, it is guaranteed that the scm_vtable_index_vcell + * element of the prospective vtable is always zero. For a + * gloc, this location has the CDR of the variable smob, which + * is guaranteed to be non-zero. */ scm_bits_t word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_cons_gloc; scm_bits_t * vtable_data = (scm_bits_t *) word0; /* access as struct */ @@ -1249,7 +1265,7 @@ gc_mark_loop_first_time: } /* mark vtable */ ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]); - goto gc_mark_loop; + goto_gc_mark_loop; } } break; @@ -1257,11 +1273,11 @@ gc_mark_loop_first_time: if (SCM_IMP (SCM_ENV (ptr))) { ptr = SCM_CLOSCAR (ptr); - goto gc_mark_nimp; + goto_gc_mark_nimp; } RECURSE (SCM_CLOSCAR (ptr)); ptr = SCM_ENV (ptr); - goto gc_mark_nimp; + goto_gc_mark_nimp; case scm_tc7_vector: i = SCM_VECTOR_LENGTH (ptr); if (i == 0) @@ -1270,7 +1286,7 @@ gc_mark_loop_first_time: if (SCM_NIMP (SCM_VELTS (ptr)[i])) RECURSE (SCM_VELTS (ptr)[i]); ptr = SCM_VELTS (ptr)[0]; - goto gc_mark_loop; + goto_gc_mark_loop; #ifdef CCLO case scm_tc7_cclo: { @@ -1283,7 +1299,7 @@ gc_mark_loop_first_time: RECURSE (obj); } ptr = SCM_CCLO_REF (ptr, 0); - goto gc_mark_loop; + goto_gc_mark_loop; } #endif #ifdef HAVE_ARRAYS @@ -1304,7 +1320,7 @@ gc_mark_loop_first_time: case scm_tc7_substring: ptr = SCM_CDR (ptr); - goto gc_mark_loop; + goto_gc_mark_loop; case scm_tc7_wvect: SCM_WVECT_GC_CHAIN (ptr) = scm_weak_vectors; @@ -1367,7 +1383,7 @@ gc_mark_loop_first_time: case scm_tc7_symbol: ptr = SCM_PROP_SLOTS (ptr); - goto gc_mark_loop; + goto_gc_mark_loop; case scm_tcs_subrs: break; case scm_tc7_port: @@ -1381,7 +1397,7 @@ gc_mark_loop_first_time: if (scm_ptobs[i].mark) { ptr = (scm_ptobs[i].mark) (ptr); - goto gc_mark_loop; + goto_gc_mark_loop; } else return; @@ -1404,7 +1420,7 @@ gc_mark_loop_first_time: if (scm_smobs[i].mark) { ptr = (scm_smobs[i].mark) (ptr); - goto gc_mark_loop; + goto_gc_mark_loop; } else return; @@ -2307,50 +2323,6 @@ alloc_some_heap (scm_freelist_t *freelist, policy_on_error error_policy) } #undef FUNC_NAME - -SCM_DEFINE (scm_unhash_name, "unhash-name", 1, 0, 0, - (SCM name), - "Flushes the glocs for @var{name}, or all glocs if @var{name}\n" - "is @code{#t}.") -#define FUNC_NAME s_scm_unhash_name -{ - int x; - int bound; - SCM_VALIDATE_SYMBOL (1,name); - SCM_DEFER_INTS; - bound = scm_n_heap_segs; - for (x = 0; x < bound; ++x) - { - SCM_CELLPTR p; - SCM_CELLPTR pbound; - p = scm_heap_table[x].bounds[0]; - pbound = scm_heap_table[x].bounds[1]; - while (p < pbound) - { - SCM cell = PTR2SCM (p); - if (SCM_TYP3 (cell) == scm_tc3_cons_gloc) - { - /* Dirk:FIXME:: Again, super ugly code: cell may be a gloc or a - * struct cell. See the corresponding comment in scm_gc_mark. - */ - scm_bits_t word0 = SCM_CELL_WORD_0 (cell) - scm_tc3_cons_gloc; - SCM gloc_car = SCM_PACK (word0); /* access as gloc */ - SCM vcell = SCM_CELL_OBJECT_1 (gloc_car); - if ((SCM_EQ_P (name, SCM_BOOL_T) || SCM_EQ_P (SCM_CAR (gloc_car), name)) - && (SCM_UNPACK (vcell) != 0) && (SCM_UNPACK (vcell) != 1)) - { - SCM_SET_CELL_OBJECT_0 (cell, name); - } - } - ++p; - } - } - SCM_ALLOW_INTS; - return name; -} -#undef FUNC_NAME - - /* {GC Protection Helper Functions} */ @@ -2653,10 +2625,6 @@ scm_init_storage () #endif #endif -#define DEFAULT_SYMHASH_SIZE 277 - scm_symhash = scm_c_make_hash_table (DEFAULT_SYMHASH_SIZE); - scm_symhash_vars = scm_c_make_hash_table (DEFAULT_SYMHASH_SIZE); - scm_stand_in_procs = SCM_EOL; scm_permobjs = SCM_EOL; scm_protects = scm_c_make_hash_table (31); diff --git a/libguile/gdbint.c b/libguile/gdbint.c index 8511365d3..3a28549da 100644 --- a/libguile/gdbint.c +++ b/libguile/gdbint.c @@ -300,10 +300,8 @@ gdb_binding (SCM name, SCM value) } SCM_BEGIN_FOREIGN_BLOCK; { - SCM vcell = scm_sym2vcell (name, - SCM_TOP_LEVEL_LOOKUP_CLOSURE, - SCM_BOOL_T); - SCM_SETCDR (vcell, value); + SCM var = scm_sym2var (name, SCM_TOP_LEVEL_LOOKUP_CLOSURE, SCM_BOOL_T); + SCM_VARIABLE_SET (var, value); } SCM_END_FOREIGN_BLOCK; return 0; diff --git a/libguile/gh_data.c b/libguile/gh_data.c index 0ee8896a9..368b223f5 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -708,14 +708,14 @@ SCM gh_module_lookup (SCM module, const char *sname) #define FUNC_NAME "gh_module_lookup" { - SCM sym, cell; + SCM sym, var; SCM_VALIDATE_MODULE (SCM_ARG1, module); sym = gh_symbol2scm (sname); - cell = scm_sym2vcell (sym, scm_module_lookup_closure (module), SCM_BOOL_F); - if (cell != SCM_BOOL_F) - return SCM_CDR (cell); + var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F); + if (var != SCM_BOOL_F) + return SCM_VARIABLE_REF (var); else return SCM_UNDEFINED; } diff --git a/libguile/gh_funcs.c b/libguile/gh_funcs.c index 6f43cf734..cdb07a4cc 100644 --- a/libguile/gh_funcs.c +++ b/libguile/gh_funcs.c @@ -130,7 +130,8 @@ gh_new_procedure5_0 (const char *proc_name, SCM (*fn) ()) SCM gh_define (const char *name, SCM val) { - return scm_sysintern (name, val); + scm_c_define (name, val); + return SCM_UNSPECIFIED; } diff --git a/libguile/goops.c b/libguile/goops.c index a32cba7d9..f108d1407 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -79,7 +79,7 @@ scm_module_goops); } /* Temporary hack until we get the new module system */ /*fixme* Should optimize by keeping track of the variable object itself */ -#define GETVAR(v) (SCM_CDDR (scm_apply (scm_goops_lookup_closure, \ +#define GETVAR(v) (SCM_VARIABLE_REF (scm_apply (scm_goops_lookup_closure, \ SCM_LIST2 ((v), SCM_BOOL_F), \ SCM_EOL))) @@ -1861,7 +1861,8 @@ scm_sys_compute_applicable_methods (SCM gf, SCM args) } #undef FUNC_NAME -SCM_VCELL_INIT (var_compute_applicable_methods, "compute-applicable-methods", scm_make_gsubr (s_sys_compute_applicable_methods, 2, 0, 0, scm_sys_compute_applicable_methods)); +SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods"); +SCM_VARIABLE_INIT (var_compute_applicable_methods, "compute-applicable-methods", scm_make_gsubr (s_sys_compute_applicable_methods, 2, 0, 0, scm_sys_compute_applicable_methods)); SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_makmmacro, scm_m_atslot_ref); @@ -2635,11 +2636,9 @@ SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0, #define FUNC_NAME s_scm_sys_goops_loaded { goops_loaded_p = 1; - var_compute_applicable_methods - = SCM_CDR (scm_apply (scm_goops_lookup_closure, - SCM_LIST2 (SCM_CAR (var_compute_applicable_methods), - SCM_BOOL_F), - SCM_EOL)); + var_compute_applicable_methods = + scm_sym2var (sym_compute_applicable_methods, scm_goops_lookup_closure, + SCM_BOOL_F); return SCM_UNSPECIFIED; } #undef FUNC_NAME diff --git a/libguile/gsubr.c b/libguile/gsubr.c index 83c268479..3b7c08d55 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -77,7 +77,9 @@ scm_make_gsubr(const char *name,int req,int opt,int rst,SCM (*fcn)()) case SCM_GSUBR_MAKTYPE(2, 0, 1): return scm_make_subr(name, scm_tc7_lsubr_2, fcn); default: { - SCM symcell = scm_sysintern (name, SCM_UNDEFINED); + SCM sym = scm_str2symbol (name); + SCM var = scm_sym2var (sym, scm_current_module_lookup_closure (), + SCM_BOOL_T); SCM cclo = scm_makcclo (scm_f_gsubr_apply, 3L); if (SCM_GSUBR_MAX < req + opt + rst) { fputs("ERROR in scm_make_gsubr: too many args\n", stderr); @@ -85,10 +87,10 @@ scm_make_gsubr(const char *name,int req,int opt,int rst,SCM (*fcn)()) } SCM_SET_GSUBR_PROC (cclo, scm_make_subr_opt (name, scm_tc7_subr_0, fcn, 0)); SCM_SET_GSUBR_TYPE (cclo, SCM_MAKINUM (SCM_GSUBR_MAKTYPE (req, opt, rst))); - SCM_SETCDR (symcell, cclo); + SCM_VARIABLE_SET (var, cclo); #ifdef DEBUG_EXTENSIONS if (SCM_REC_PROCNAMES_P) - scm_set_procedure_property_x (cclo, scm_sym_name, SCM_CAR (symcell)); + scm_set_procedure_property_x (cclo, scm_sym_name, sym); #endif return cclo; } diff --git a/libguile/hooks.c b/libguile/hooks.c index 96a9657b3..9834474aa 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -198,7 +198,7 @@ SCM scm_create_hook (const char* name, int n_args) { SCM hook = make_hook (SCM_MAKINUM (n_args), "scm_create_hook"); - scm_sysintern (name, hook); + scm_c_define (name, hook); scm_protect_object (hook); return hook; } diff --git a/libguile/init.c b/libguile/init.c index dacd1ee92..45ecb5f7a 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -366,8 +366,6 @@ scm_load_startup_files () /* Load the init.scm file. */ if (SCM_NFALSEP (init_path)) scm_primitive_load (init_path); - - scm_post_boot_init_modules (); } } @@ -477,6 +475,8 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_weaks_prehistory (); /* requires storage */ scm_init_subr_table (); scm_environments_prehistory (); /* requires storage */ + scm_modules_prehistory (); /* requires storage */ + scm_init_variable (); /* all bindings need variables */ scm_init_continuations (); scm_init_root (); /* requires continuations */ #ifdef USE_THREADS @@ -555,7 +555,6 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_init_strorder (); scm_init_strop (); scm_init_throw (); - scm_init_variable (); scm_init_vectors (); scm_init_version (); scm_init_weaks (); diff --git a/libguile/keywords.c b/libguile/keywords.c index ff86b582f..f17eedacc 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -71,24 +71,21 @@ SCM_DEFINE (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", "Make a keyword object from a @var{symbol} that starts with a dash.") #define FUNC_NAME s_scm_make_keyword_from_dash_symbol { - SCM vcell; + SCM keyword; SCM_ASSERT (SCM_SYMBOLP (symbol) && ('-' == SCM_SYMBOL_CHARS(symbol)[0]), symbol, SCM_ARG1, FUNC_NAME); SCM_DEFER_INTS; - vcell = scm_sym2ovcell_soft (symbol, scm_keyword_obarray); - if (SCM_FALSEP (vcell)) + keyword = scm_hashq_ref (scm_keyword_obarray, symbol, SCM_BOOL_F); + if (SCM_FALSEP (keyword)) { - SCM keyword; SCM_NEWSMOB (keyword, scm_tc16_keyword, SCM_UNPACK (symbol)); - scm_intern_symbol (scm_keyword_obarray, symbol); - vcell = scm_sym2ovcell_soft (symbol, scm_keyword_obarray); - SCM_SETCDR (vcell, keyword); + scm_hashq_set_x (scm_keyword_obarray, symbol, keyword); } SCM_ALLOW_INTS; - return SCM_CDR (vcell); + return keyword; } #undef FUNC_NAME diff --git a/libguile/load.c b/libguile/load.c index 98158e6da..acc75e46f 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -494,7 +494,7 @@ static void init_build_info () { static struct { char *name; char *value; } info[] = SCM_BUILD_INFO; - SCM *loc = SCM_CDRLOC (scm_sysintern ("%guile-build-info", SCM_EOL)); + SCM *loc = SCM_VARIABLE_LOC (scm_c_define ("%guile-build-info", SCM_EOL)); unsigned int i; for (i = 0; i < (sizeof (info) / sizeof (info[0])); i++) @@ -509,12 +509,12 @@ void scm_init_load () { scm_listofnullstr = scm_permanent_object (SCM_LIST1 (scm_nullstr)); - scm_loc_load_path = SCM_CDRLOC (scm_sysintern ("%load-path", SCM_EOL)); + scm_loc_load_path = SCM_VARIABLE_LOC (scm_c_define ("%load-path", SCM_EOL)); scm_loc_load_extensions - = SCM_CDRLOC (scm_sysintern ("%load-extensions", - SCM_LIST2 (scm_makfrom0str (".scm"), - scm_nullstr))); - scm_loc_load_hook = SCM_CDRLOC (scm_sysintern ("%load-hook", SCM_BOOL_F)); + = SCM_VARIABLE_LOC (scm_c_define ("%load-extensions", + SCM_LIST2 (scm_makfrom0str (".scm"), + scm_nullstr))); + scm_loc_load_hook = SCM_VARIABLE_LOC (scm_c_define ("%load-hook", SCM_BOOL_F)); init_build_info (); diff --git a/libguile/macros.c b/libguile/macros.c index 734cd6d5d..79618bd12 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -220,10 +220,10 @@ SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0, SCM scm_make_synt (const char *name, SCM (*macroizer) (), SCM (*fcn)() ) { - SCM symcell = scm_sysintern (name, SCM_UNDEFINED); + SCM var = scm_c_define (name, SCM_UNDEFINED); SCM transformer = scm_make_subr_opt (name, scm_tc7_subr_2, fcn, 0); - SCM_SETCDR (symcell, macroizer (transformer)); - return SCM_CAR (symcell); + SCM_VARIABLE_SET (var, macroizer (transformer)); + return SCM_UNSPECIFIED; } void diff --git a/libguile/modules.c b/libguile/modules.c index 710adddc9..f889fe9aa 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -57,18 +57,20 @@ #include "libguile/modules.h" -SCM scm_module_system_booted_p = 0; +int scm_module_system_booted_p = 0; SCM scm_module_tag; -SCM scm_module_type; -static SCM the_root_module; +static SCM the_root_module_var; static SCM root_module_lookup_closure; SCM scm_the_root_module () { - return SCM_CDR (the_root_module); + if (scm_module_system_booted_p) + return SCM_VARIABLE_REF (the_root_module_var); + else + return SCM_BOOL_F; } static SCM the_module; @@ -82,12 +84,7 @@ SCM_DEFINE (scm_current_module, "current-module", 0, 0, 0, } #undef FUNC_NAME -#define SCM_VALIDATE_STRUCT_TYPE(pos, v, type) \ - do { \ - SCM_ASSERT (SCM_NIMP (v) && SCM_NFALSEP (SCM_STRUCTP (v)) \ - && SCM_STRUCT_VTABLE (v) == (type), \ - v, pos, FUNC_NAME); \ - } while (0) +static void scm_post_boot_init_modules (void); SCM_DEFINE (scm_set_current_module, "set-current-module", 1, 0, 0, (SCM module), @@ -97,21 +94,18 @@ SCM_DEFINE (scm_set_current_module, "set-current-module", 1, 0, 0, { SCM old; - /* XXX - we can not validate our argument when the module system - hasn't been booted yet since we don't know the type. This - should be fixed when we have a cleaner way of booting - Guile. - */ - if (scm_module_system_booted_p) - SCM_VALIDATE_STRUCT_TYPE (SCM_ARG1, module, scm_module_type); + if (!scm_module_system_booted_p) + scm_post_boot_init_modules (); + + SCM_VALIDATE_MODULE (SCM_ARG1, module); old = scm_current_module (); scm_fluid_set_x (the_module, module); #if SCM_DEBUG_DEPRECATED == 0 - scm_fluid_set_x (SCM_CDR (scm_top_level_lookup_closure_var), + scm_fluid_set_x (SCM_VARIABLE_REF (scm_top_level_lookup_closure_var), scm_current_module_lookup_closure ()); - scm_fluid_set_x (SCM_CDR (scm_system_transformer), + scm_fluid_set_x (SCM_VARIABLE_REF (scm_system_transformer), scm_current_module_transformer ()); #endif @@ -145,13 +139,13 @@ scm_module_full_name (SCM name) return scm_append (SCM_LIST2 (module_prefix, name)); } -static SCM make_modules_in; -static SCM beautify_user_module_x; +static SCM make_modules_in_var; +static SCM beautify_user_module_x_var; SCM scm_make_module (SCM name) { - return scm_apply (SCM_CDR (make_modules_in), + return scm_apply (SCM_VARIABLE_REF (make_modules_in_var), SCM_LIST2 (scm_the_root_module (), scm_module_full_name (name)), SCM_EOL); @@ -160,14 +154,18 @@ scm_make_module (SCM name) SCM scm_ensure_user_module (SCM module) { - scm_apply (SCM_CDR (beautify_user_module_x), SCM_LIST1 (module), SCM_EOL); + scm_apply (SCM_VARIABLE_REF (beautify_user_module_x_var), + SCM_LIST1 (module), SCM_EOL); return SCM_UNSPECIFIED; } SCM scm_module_lookup_closure (SCM module) { - return SCM_MODULE_EVAL_CLOSURE (module); + if (module == SCM_BOOL_F) + return SCM_BOOL_F; + else + return SCM_MODULE_EVAL_CLOSURE (module); } SCM @@ -182,7 +180,10 @@ scm_current_module_lookup_closure () SCM scm_module_transformer (SCM module) { - return SCM_MODULE_TRANSFORMER (module); + if (module == SCM_BOOL_F) + return SCM_BOOL_F; + else + return SCM_MODULE_TRANSFORMER (module); } SCM @@ -194,20 +195,22 @@ scm_current_module_transformer () return SCM_BOOL_F; } -static SCM resolve_module; +static SCM resolve_module_var; SCM scm_resolve_module (SCM name) { - return scm_apply (SCM_CDR (resolve_module), SCM_LIST1 (name), SCM_EOL); + return scm_apply (SCM_VARIABLE_REF (resolve_module_var), + SCM_LIST1 (name), SCM_EOL); } -static SCM try_module_autoload; +static SCM try_module_autoload_var; SCM scm_load_scheme_module (SCM name) { - return scm_apply (SCM_CDR (try_module_autoload), SCM_LIST1 (name), SCM_EOL); + return scm_apply (SCM_VARIABLE_REF (try_module_autoload_var), + SCM_LIST1 (name), SCM_EOL); } /* Environments */ @@ -234,6 +237,30 @@ scm_env_top_level (SCM env) return SCM_BOOL_F; } +SCM_SYMBOL (sym_module, "module"); + +SCM +scm_lookup_closure_module (SCM proc) +{ + if (SCM_FALSEP (proc)) + return scm_the_root_module (); + else if (SCM_EVAL_CLOSURE_P (proc)) + return SCM_PACK (SCM_SMOB_DATA (proc)); + else + { + SCM mod = scm_procedure_property (proc, sym_module); + if (mod == SCM_BOOL_F) + mod = scm_the_root_module (); + return mod; + } +} + +SCM +scm_env_module (SCM env) +{ + return scm_lookup_closure_module (scm_env_top_level (env)); +} + SCM_SYMBOL (scm_sym_system_module, "system-module"); @@ -256,7 +283,7 @@ scm_system_module_env_p (SCM env) * The code will be replaced by the low-level environments in next release. */ -static SCM module_make_local_var_x; +static SCM module_make_local_var_x_var; static SCM module_variable (SCM module, SCM sym) @@ -293,6 +320,10 @@ module_variable (SCM module, SCM sym) scm_bits_t scm_tc16_eval_closure; +#define SCM_F_EVAL_CLOSURE_INTERFACE (1<<16) +#define SCM_EVAL_CLOSURE_INTERFACE_P(e) \ + (SCM_CELL_WORD_0 (e) & SCM_F_EVAL_CLOSURE_INTERFACE) + /* NOTE: This function may be called by a smob application or from another C function directly. */ SCM @@ -300,9 +331,13 @@ scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep) { SCM module = SCM_PACK (SCM_SMOB_DATA (eclo)); if (SCM_NFALSEP (definep)) - return scm_apply (SCM_CDR (module_make_local_var_x), - SCM_LIST2 (module, sym), - SCM_EOL); + { + if (SCM_EVAL_CLOSURE_INTERFACE_P (eclo)) + return SCM_BOOL_F; + return scm_apply (SCM_VARIABLE_REF (module_make_local_var_x_var), + SCM_LIST2 (module, sym), + SCM_EOL); + } else return module_variable (module, sym); } @@ -316,14 +351,222 @@ SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_standard_interface_eval_closure, + "standard-interface-eval-closure", 1, 0, 0, + (SCM module), + "Return a interface eval closure for the module @var{module}. " + "Such a closure does not allow new bindings to be added.") +#define FUNC_NAME s_scm_standard_interface_eval_closure +{ + SCM_RETURN_NEWSMOB (scm_tc16_eval_closure | SCM_F_EVAL_CLOSURE_INTERFACE, + SCM_UNPACK (module)); +} +#undef FUNC_NAME + +/* scm_sym2var + * + * looks up the variable bound to SYM according to PROC. PROC should be + * a `eval closure' of some module. + * + * When no binding exists, and DEFINEP is true, create a new binding + * with a initial value of SCM_UNDEFINED. Return `#f' when DEFINEP as + * false and no binding exists. + * + * When PROC is `#f', it is ignored and the binding is searched for in + * the scm_pre_modules_obarray (a `eq' hash table). + */ + +SCM scm_pre_modules_obarray; + +SCM +scm_sym2var (SCM sym, SCM proc, SCM definep) +#define FUNC_NAME "scm_sym2var" +{ + SCM var; + + if (SCM_NIMP (proc)) + { + if (SCM_EVAL_CLOSURE_P (proc)) + { + /* Bypass evaluator in the standard case. */ + var = scm_eval_closure_lookup (proc, sym, definep); + } + else + var = scm_apply (proc, sym, scm_cons (definep, scm_listofnull)); + } + else + { + SCM handle; + + if (definep == SCM_BOOL_F) + var = scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_BOOL_F); + else + { + handle = scm_hashq_create_handle_x (scm_pre_modules_obarray, + sym, SCM_BOOL_F); + var = SCM_CDR (handle); + if (var == SCM_BOOL_F) + { + var = scm_make_variable (SCM_UNDEFINED); +#if SCM_ENABLE_VCELLS + scm_variable_set_name_hint (var, sym); +#endif + SCM_SETCDR (handle, var); + } + } + } + + if (var != SCM_BOOL_F && !SCM_VARIABLEP (var)) + SCM_MISC_ERROR ("~S is not bound to a variable", SCM_LIST1 (sym)); + + return var; +} +#undef FUNC_NAME + +SCM +scm_c_module_lookup (SCM module, const char *name) +{ + return scm_module_lookup (module, scm_str2symbol (name)); +} + +SCM +scm_module_lookup (SCM module, SCM sym) +#define FUNC_NAME "module-lookup" +{ + SCM var; + SCM_VALIDATE_MODULE (1, module); + + var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F); + if (SCM_FALSEP (var)) + SCM_MISC_ERROR ("unbound variable: ~S", SCM_LIST1 (sym)); + return var; +} +#undef FUNC_NAME + +SCM +scm_c_lookup (const char *name) +{ + return scm_lookup (scm_str2symbol (name)); +} + +SCM +scm_lookup (SCM sym) +{ + SCM var = + scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F); + if (SCM_FALSEP (var)) + scm_misc_error ("scm_lookup", "unbound variable: ~S", SCM_LIST1 (sym)); + return var; +} + +SCM +scm_c_module_define (SCM module, const char *name, SCM value) +{ + return scm_module_define (module, scm_str2symbol (name), value); +} + +SCM +scm_module_define (SCM module, SCM sym, SCM value) +#define FUNC_NAME "module-define" +{ + SCM var; + SCM_VALIDATE_MODULE (1, module); + + var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_T); + SCM_VARIABLE_SET (var, value); + return var; +} +#undef FUNC_NAME + +SCM +scm_c_define (const char *name, SCM value) +{ + return scm_define (scm_str2symbol (name), value); +} + +SCM +scm_define (SCM sym, SCM value) +{ + SCM var = + scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_T); + SCM_VARIABLE_SET (var, value); + return var; +} + +SCM +scm_module_reverse_lookup (SCM module, SCM variable) +#define FUNC_NAME "module-reverse-lookup" +{ + SCM obarray; + int i, n; + + if (module == SCM_BOOL_F) + obarray = scm_pre_modules_obarray; + else + { + SCM_VALIDATE_MODULE (1, module); + obarray = SCM_MODULE_OBARRAY (module); + } + + /* XXX - We do not use scm_hash_fold here to avoid searching the + whole obarray. We should have a scm_hash_find procedure. */ + + n = SCM_VECTOR_LENGTH (obarray); + for (i = 0; i < n; ++i) + { + SCM ls = SCM_VELTS (obarray)[i], handle; + while (!SCM_NULLP (ls)) + { + handle = SCM_CAR (ls); + if (SCM_CDR (handle) == variable) + return SCM_CAR (handle); + ls = SCM_CDR (ls); + } + } + + /* Try the `uses' list. + */ + { + SCM uses = SCM_MODULE_USES (module); + while (SCM_CONSP (uses)) + { + SCM sym = scm_module_reverse_lookup (SCM_CAR (uses), variable); + if (sym != SCM_BOOL_F) + return sym; + uses = SCM_CDR (uses); + } + } + + return SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_get_pre_modules_obarray, "%get-pre-modules-obarray", 0, 0, 0, + (), + "Return the obarray that is used for all new bindings before " + "the module system is booted. The first call to " + "@code{set-current-module} will boot the module system.") +#define FUNC_NAME s_scm_get_pre_modules_obarray +{ + return scm_pre_modules_obarray; +} +#undef FUNC_NAME + +void +scm_modules_prehistory () +{ + scm_pre_modules_obarray + = scm_permanent_object (scm_c_make_hash_table (2001)); +} + void scm_init_modules () { #ifndef SCM_MAGIC_SNARFER #include "libguile/modules.x" #endif - module_make_local_var_x = scm_sysintern ("module-make-local-var!", - SCM_UNDEFINED); + module_make_local_var_x_var = scm_c_define ("module-make-local-var!", + SCM_UNDEFINED); scm_tc16_eval_closure = scm_make_smob_type ("eval-closure", 0); scm_set_smob_mark (scm_tc16_eval_closure, scm_markcdr); scm_set_smob_apply (scm_tc16_eval_closure, scm_eval_closure_lookup, 2, 0, 0); @@ -331,21 +574,21 @@ scm_init_modules () the_module = scm_permanent_object (scm_make_fluid ()); } -void +static void scm_post_boot_init_modules () { - scm_module_type = - scm_permanent_object (SCM_CDR (scm_intern0 ("module-type"))); - scm_module_tag = (SCM_CELL_WORD_1 (scm_module_type) + scm_tc3_cons_gloc); - module_prefix = scm_permanent_object (SCM_LIST2 (scm_sym_app, - scm_sym_modules)); - make_modules_in = scm_intern0 ("make-modules-in"); - beautify_user_module_x = scm_intern0 ("beautify-user-module!"); - the_root_module = scm_intern0 ("the-root-module"); - root_module_lookup_closure = scm_permanent_object - (scm_module_lookup_closure (SCM_CDR (the_root_module))); - resolve_module = scm_intern0 ("resolve-module"); - try_module_autoload = scm_intern0 ("try-module-autoload"); +#define PERM(x) scm_permanent_object(x) + + SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type")); + scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_cons_gloc); + module_prefix = PERM (SCM_LIST2 (scm_sym_app, scm_sym_modules)); + make_modules_in_var = PERM (scm_c_lookup ("make-modules-in")); + beautify_user_module_x_var = PERM (scm_c_lookup ("beautify-user-module!")); + the_root_module_var = PERM (scm_c_lookup ("the-root-module")); + root_module_lookup_closure = + PERM (scm_module_lookup_closure (SCM_VARIABLE_REF (the_root_module_var))); + resolve_module_var = PERM (scm_c_lookup ("resolve-module")); + try_module_autoload_var = PERM (scm_c_lookup ("try-module-autoload")); scm_module_system_booted_p = 1; } diff --git a/libguile/modules.h b/libguile/modules.h index da9913e04..9869e42a0 100644 --- a/libguile/modules.h +++ b/libguile/modules.h @@ -82,7 +82,7 @@ extern scm_bits_t scm_tc16_eval_closure; -extern SCM scm_module_system_booted_p; +extern int scm_module_system_booted_p; extern SCM scm_module_tag; extern SCM scm_the_root_module (void); @@ -102,8 +102,27 @@ extern SCM scm_top_level_env (SCM thunk); extern SCM scm_system_module_env_p (SCM env); extern SCM scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep); extern SCM scm_standard_eval_closure (SCM module); +extern SCM scm_standard_interface_eval_closure (SCM module); +extern SCM scm_get_pre_modules_obarray (void); + +extern SCM scm_lookup_closure_module (SCM proc); +extern SCM scm_env_module (SCM env); + +extern SCM scm_c_lookup (const char *name); +extern SCM scm_c_define (const char *name, SCM val); +extern SCM scm_lookup (SCM symbol); +extern SCM scm_define (SCM symbol, SCM val); + +extern SCM scm_c_module_lookup (SCM module, const char *name); +extern SCM scm_c_module_define (SCM module, const char *name, SCM val); +extern SCM scm_module_lookup (SCM module, SCM symbol); +extern SCM scm_module_define (SCM module, SCM symbol, SCM val); +extern SCM scm_module_reverse_lookup (SCM module, SCM variable); + +extern SCM scm_sym2var (SCM sym, SCM thunk, SCM definep); + +extern void scm_modules_prehistory (void); extern void scm_init_modules (void); -extern void scm_post_boot_init_modules (void); #endif /* MODULESH */ diff --git a/libguile/numbers.c b/libguile/numbers.c index a0405d5ff..26da3e4ad 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -4546,8 +4546,10 @@ scm_init_numbers () * the following constants to avoid the creation of bignums. Please, before * using these values, remember the two rules of program optimization: * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */ - scm_sysintern ("most-positive-fixnum", SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)); - scm_sysintern ("most-negative-fixnum", SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM)); + scm_c_define ("most-positive-fixnum", + SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)); + scm_c_define ("most-negative-fixnum", + SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM)); scm_add_feature ("complex"); scm_add_feature ("inexact"); diff --git a/libguile/objects.c b/libguile/objects.c index 82033b378..ac32e89ec 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -509,13 +509,13 @@ scm_init_objects () SCM et = scm_make_struct (mt, SCM_INUM0, SCM_LIST4 (el, SCM_BOOL_F, SCM_EOL, SCM_EOL)); - scm_sysintern ("", mt); + scm_c_define ("", mt); scm_metaclass_standard = mt; - scm_sysintern ("", ot); + scm_c_define ("", ot); scm_metaclass_operator = ot; SCM_SET_CLASS_FLAGS (et, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY); SCM_SET_CLASS_DESTRUCTOR (et, scm_struct_free_entity); - scm_sysintern ("", et); + scm_c_define ("", et); #ifndef SCM_MAGIC_SNARFER #include "libguile/objects.x" diff --git a/libguile/ports.c b/libguile/ports.c index 91e2a79b5..6a15c2c0b 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1564,9 +1564,9 @@ void scm_init_ports () { /* lseek() symbols. */ - scm_sysintern ("SEEK_SET", SCM_MAKINUM (SEEK_SET)); - scm_sysintern ("SEEK_CUR", SCM_MAKINUM (SEEK_CUR)); - scm_sysintern ("SEEK_END", SCM_MAKINUM (SEEK_END)); + scm_c_define ("SEEK_SET", SCM_MAKINUM (SEEK_SET)); + scm_c_define ("SEEK_CUR", SCM_MAKINUM (SEEK_CUR)); + scm_c_define ("SEEK_END", SCM_MAKINUM (SEEK_END)); scm_tc16_void_port = scm_make_port_type ("void", fill_input_void_port, write_void_port); diff --git a/libguile/posix.c b/libguile/posix.c index 4c4ee235d..6f8c11e0a 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1572,70 +1572,70 @@ scm_init_posix () scm_add_feature ("EIDs"); #endif #ifdef WAIT_ANY - scm_sysintern ("WAIT_ANY", SCM_MAKINUM (WAIT_ANY)); + scm_c_define ("WAIT_ANY", SCM_MAKINUM (WAIT_ANY)); #endif #ifdef WAIT_MYPGRP - scm_sysintern ("WAIT_MYPGRP", SCM_MAKINUM (WAIT_MYPGRP)); + scm_c_define ("WAIT_MYPGRP", SCM_MAKINUM (WAIT_MYPGRP)); #endif #ifdef WNOHANG - scm_sysintern ("WNOHANG", SCM_MAKINUM (WNOHANG)); + scm_c_define ("WNOHANG", SCM_MAKINUM (WNOHANG)); #endif #ifdef WUNTRACED - scm_sysintern ("WUNTRACED", SCM_MAKINUM (WUNTRACED)); + scm_c_define ("WUNTRACED", SCM_MAKINUM (WUNTRACED)); #endif /* access() symbols. */ - scm_sysintern ("R_OK", SCM_MAKINUM (R_OK)); - scm_sysintern ("W_OK", SCM_MAKINUM (W_OK)); - scm_sysintern ("X_OK", SCM_MAKINUM (X_OK)); - scm_sysintern ("F_OK", SCM_MAKINUM (F_OK)); + scm_c_define ("R_OK", SCM_MAKINUM (R_OK)); + scm_c_define ("W_OK", SCM_MAKINUM (W_OK)); + scm_c_define ("X_OK", SCM_MAKINUM (X_OK)); + scm_c_define ("F_OK", SCM_MAKINUM (F_OK)); #ifdef LC_COLLATE - scm_sysintern ("LC_COLLATE", SCM_MAKINUM (LC_COLLATE)); + scm_c_define ("LC_COLLATE", SCM_MAKINUM (LC_COLLATE)); #endif #ifdef LC_CTYPE - scm_sysintern ("LC_CTYPE", SCM_MAKINUM (LC_CTYPE)); + scm_c_define ("LC_CTYPE", SCM_MAKINUM (LC_CTYPE)); #endif #ifdef LC_MONETARY - scm_sysintern ("LC_MONETARY", SCM_MAKINUM (LC_MONETARY)); + scm_c_define ("LC_MONETARY", SCM_MAKINUM (LC_MONETARY)); #endif #ifdef LC_NUMERIC - scm_sysintern ("LC_NUMERIC", SCM_MAKINUM (LC_NUMERIC)); + scm_c_define ("LC_NUMERIC", SCM_MAKINUM (LC_NUMERIC)); #endif #ifdef LC_TIME - scm_sysintern ("LC_TIME", SCM_MAKINUM (LC_TIME)); + scm_c_define ("LC_TIME", SCM_MAKINUM (LC_TIME)); #endif #ifdef LC_MESSAGES - scm_sysintern ("LC_MESSAGES", SCM_MAKINUM (LC_MESSAGES)); + scm_c_define ("LC_MESSAGES", SCM_MAKINUM (LC_MESSAGES)); #endif #ifdef LC_ALL - scm_sysintern ("LC_ALL", SCM_MAKINUM (LC_ALL)); + scm_c_define ("LC_ALL", SCM_MAKINUM (LC_ALL)); #endif #ifdef PIPE_BUF -scm_sysintern ("PIPE_BUF", scm_long2num (PIPE_BUF)); + scm_c_define ("PIPE_BUF", scm_long2num (PIPE_BUF)); #endif #ifdef PRIO_PROCESS - scm_sysintern ("PRIO_PROCESS", SCM_MAKINUM (PRIO_PROCESS)); + scm_c_define ("PRIO_PROCESS", SCM_MAKINUM (PRIO_PROCESS)); #endif #ifdef PRIO_PGRP - scm_sysintern ("PRIO_PGRP", SCM_MAKINUM (PRIO_PGRP)); + scm_c_define ("PRIO_PGRP", SCM_MAKINUM (PRIO_PGRP)); #endif #ifdef PRIO_USER - scm_sysintern ("PRIO_USER", SCM_MAKINUM (PRIO_USER)); + scm_c_define ("PRIO_USER", SCM_MAKINUM (PRIO_USER)); #endif #ifdef LOCK_SH - scm_sysintern ("LOCK_SH", SCM_MAKINUM (LOCK_SH)); + scm_c_define ("LOCK_SH", SCM_MAKINUM (LOCK_SH)); #endif #ifdef LOCK_EX - scm_sysintern ("LOCK_EX", SCM_MAKINUM (LOCK_EX)); + scm_c_define ("LOCK_EX", SCM_MAKINUM (LOCK_EX)); #endif #ifdef LOCK_UN - scm_sysintern ("LOCK_UN", SCM_MAKINUM (LOCK_UN)); + scm_c_define ("LOCK_UN", SCM_MAKINUM (LOCK_UN)); #endif #ifdef LOCK_NB - scm_sysintern ("LOCK_NB", SCM_MAKINUM (LOCK_NB)); + scm_c_define ("LOCK_NB", SCM_MAKINUM (LOCK_NB)); #endif #include "libguile/cpp_sig_symbols.c" diff --git a/libguile/print.c b/libguile/print.c index 1bd903529..dca8d84df 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -371,7 +371,8 @@ taloop: case scm_tc3_cons_gloc: /* gloc */ scm_puts ("#@", port); - exp = SCM_GLOC_SYM (exp); + exp = scm_module_reverse_lookup (scm_current_module (), + SCM_GLOC_VAR (exp)); goto taloop; case scm_tc3_cons: switch (SCM_TYP7 (exp)) diff --git a/libguile/procs.c b/libguile/procs.c index e9ba44f08..65331edb8 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -73,7 +73,7 @@ SCM scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set) { SCM symbol; - SCM symcell; + SCM var; register SCM z; int entry; @@ -89,17 +89,14 @@ scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set) scm_subr_table_room = new_size; } + symbol = scm_str2symbol (name); + SCM_NEWCELL (z); if (set) - { - symcell = scm_sysintern (name, SCM_UNDEFINED); - symbol = SCM_CAR (symcell); - } + var = scm_sym2var (symbol, scm_current_module_lookup_closure (), + SCM_BOOL_T); else - { - symcell = SCM_BOOL_F; /* to avoid warning */ - symbol = scm_str2symbol (name); - } + var = SCM_BOOL_F; entry = scm_subr_table_size; scm_subr_table[entry].handle = z; @@ -112,7 +109,7 @@ scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set) scm_subr_table_size++; if (set) - SCM_SETCDR (symcell, z); + SCM_VARIABLE_SET (var, z); return z; } diff --git a/libguile/ramap.c b/libguile/ramap.c index c594828ff..5fe765624 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -2043,12 +2043,19 @@ scm_array_equal_p (SCM ra0, SCM ra1) } - static void init_raprocs (ra_iproc *subra) { for (; subra->name; subra++) - subra->sproc = scm_symbol_binding (SCM_BOOL_F, scm_str2symbol (subra->name)); + { + SCM sym = scm_str2symbol (subra->name); + SCM var = + scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F); + if (var != SCM_BOOL_F) + subra->sproc = SCM_VARIABLE_REF (var); + else + subra->sproc = SCM_BOOL_F; + } } diff --git a/libguile/random.c b/libguile/random.c index 384731478..63cfffe33 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -352,7 +352,7 @@ rstate_free (SCM rstate) * Scheme level interface. */ -SCM_GLOBAL_VCELL_INIT (scm_var_random_state, "*random-state*", scm_seed_to_random_state (scm_makfrom0str ("URL:http://stat.fsu.edu/~geo/diehard.html"))); +SCM_GLOBAL_VARIABLE_INIT (scm_var_random_state, "*random-state*", scm_seed_to_random_state (scm_makfrom0str ("URL:http://stat.fsu.edu/~geo/diehard.html"))); SCM_DEFINE (scm_random, "random", 1, 1, 0, (SCM n, SCM state), @@ -371,7 +371,7 @@ SCM_DEFINE (scm_random, "random", 1, 1, 0, #define FUNC_NAME s_scm_random { if (SCM_UNBNDP (state)) - state = SCM_CDR (scm_var_random_state); + state = SCM_VARIABLE_REF (scm_var_random_state); SCM_VALIDATE_RSTATE (2,state); if (SCM_INUMP (n)) { @@ -394,7 +394,7 @@ SCM_DEFINE (scm_copy_random_state, "copy-random-state", 0, 1, 0, #define FUNC_NAME s_scm_copy_random_state { if (SCM_UNBNDP (state)) - state = SCM_CDR (scm_var_random_state); + state = SCM_VARIABLE_REF (scm_var_random_state); SCM_VALIDATE_RSTATE (1,state); return make_rstate (scm_the_rng.copy_rstate (SCM_RSTATE (state))); } @@ -420,7 +420,7 @@ SCM_DEFINE (scm_random_uniform, "random:uniform", 0, 1, 0, #define FUNC_NAME s_scm_random_uniform { if (SCM_UNBNDP (state)) - state = SCM_CDR (scm_var_random_state); + state = SCM_VARIABLE_REF (scm_var_random_state); SCM_VALIDATE_RSTATE (1,state); return scm_make_real (scm_c_uniform01 (SCM_RSTATE (state))); } @@ -435,7 +435,7 @@ SCM_DEFINE (scm_random_normal, "random:normal", 0, 1, 0, #define FUNC_NAME s_scm_random_normal { if (SCM_UNBNDP (state)) - state = SCM_CDR (scm_var_random_state); + state = SCM_VARIABLE_REF (scm_var_random_state); SCM_VALIDATE_RSTATE (1,state); return scm_make_real (scm_c_normal01 (SCM_RSTATE (state))); } @@ -492,7 +492,7 @@ SCM_DEFINE (scm_random_solid_sphere_x, "random:solid-sphere!", 1, 1, 0, { SCM_VALIDATE_VECTOR_OR_DVECTOR (1,v); if (SCM_UNBNDP (state)) - state = SCM_CDR (scm_var_random_state); + state = SCM_VARIABLE_REF (scm_var_random_state); SCM_VALIDATE_RSTATE (2,state); scm_random_normal_vector_x (v, state); vector_scale (v, @@ -515,7 +515,7 @@ SCM_DEFINE (scm_random_hollow_sphere_x, "random:hollow-sphere!", 1, 1, 0, { SCM_VALIDATE_VECTOR_OR_DVECTOR (1,v); if (SCM_UNBNDP (state)) - state = SCM_CDR (scm_var_random_state); + state = SCM_VARIABLE_REF (scm_var_random_state); SCM_VALIDATE_RSTATE (2,state); scm_random_normal_vector_x (v, state); vector_scale (v, 1 / sqrt (vector_sum_squares (v))); @@ -534,7 +534,7 @@ SCM_DEFINE (scm_random_normal_vector_x, "random:normal-vector!", 1, 1, 0, int n; SCM_VALIDATE_VECTOR_OR_DVECTOR (1,v); if (SCM_UNBNDP (state)) - state = SCM_CDR (scm_var_random_state); + state = SCM_VARIABLE_REF (scm_var_random_state); SCM_VALIDATE_RSTATE (2,state); n = SCM_INUM (scm_uniform_vector_length (v)); if (SCM_VECTORP (v)) @@ -557,7 +557,7 @@ SCM_DEFINE (scm_random_exp, "random:exp", 0, 1, 0, #define FUNC_NAME s_scm_random_exp { if (SCM_UNBNDP (state)) - state = SCM_CDR (scm_var_random_state); + state = SCM_VARIABLE_REF (scm_var_random_state); SCM_VALIDATE_RSTATE (1,state); return scm_make_real (scm_c_exp1 (SCM_RSTATE (state))); } diff --git a/libguile/read.c b/libguile/read.c index 221035ff1..635a4ae42 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -819,7 +819,7 @@ void scm_init_read () { scm_read_hash_procedures = - SCM_CDRLOC (scm_sysintern ("read-hash-procedures", SCM_EOL)); + SCM_VARIABLE_LOC (scm_c_define ("read-hash-procedures", SCM_EOL)); scm_init_opts (scm_read_options, scm_read_opts, SCM_N_READ_OPTIONS); #ifndef SCM_MAGIC_SNARFER diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index df7fe06a0..1f02d688b 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -303,14 +303,14 @@ scm_init_regex_posix () scm_set_smob_free (scm_tc16_regex, regex_free); /* Compilation flags. */ - scm_sysintern ("regexp/basic", scm_long2num (REG_BASIC)); - scm_sysintern ("regexp/extended", scm_long2num (REG_EXTENDED)); - scm_sysintern ("regexp/icase", scm_long2num (REG_ICASE)); - scm_sysintern ("regexp/newline", scm_long2num (REG_NEWLINE)); + scm_c_define ("regexp/basic", scm_long2num (REG_BASIC)); + scm_c_define ("regexp/extended", scm_long2num (REG_EXTENDED)); + scm_c_define ("regexp/icase", scm_long2num (REG_ICASE)); + scm_c_define ("regexp/newline", scm_long2num (REG_NEWLINE)); /* Execution flags. */ - scm_sysintern ("regexp/notbol", scm_long2num (REG_NOTBOL)); - scm_sysintern ("regexp/noteol", scm_long2num (REG_NOTEOL)); + scm_c_define ("regexp/notbol", scm_long2num (REG_NOTBOL)); + scm_c_define ("regexp/noteol", scm_long2num (REG_NOTEOL)); #ifndef SCM_MAGIC_SNARFER #include "libguile/regex-posix.x" diff --git a/libguile/root.h b/libguile/root.h index 82e12312c..40671e55e 100644 --- a/libguile/root.h +++ b/libguile/root.h @@ -61,20 +61,18 @@ #define scm_undefineds scm_sys_protects[2] #define scm_nullvect scm_sys_protects[3] #define scm_nullstr scm_sys_protects[4] -#define scm_symhash scm_sys_protects[5] -#define scm_symhash_vars scm_sys_protects[6] -#define scm_keyword_obarray scm_sys_protects[7] -#define scm_stand_in_procs scm_sys_protects[8] -#define scm_object_whash scm_sys_protects[9] -#define scm_permobjs scm_sys_protects[10] -#define scm_asyncs scm_sys_protects[11] -#define scm_protects scm_sys_protects[12] -#define scm_properties_whash scm_sys_protects[13] +#define scm_keyword_obarray scm_sys_protects[5] +#define scm_stand_in_procs scm_sys_protects[6] +#define scm_object_whash scm_sys_protects[7] +#define scm_permobjs scm_sys_protects[8] +#define scm_asyncs scm_sys_protects[9] +#define scm_protects scm_sys_protects[10] +#define scm_properties_whash scm_sys_protects[11] #ifdef DEBUG_EXTENSIONS -#define scm_source_whash scm_sys_protects[14] -#define SCM_NUM_PROTECTS 15 +#define scm_source_whash scm_sys_protects[12] +#define SCM_NUM_PROTECTS 13 #else -#define SCM_NUM_PROTECTS 14 +#define SCM_NUM_PROTECTS 12 #endif extern SCM scm_sys_protects[]; diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index bc57429ae..380dea0c2 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -492,8 +492,8 @@ scm_init_scmsigs () int i; signal_handlers = - SCM_CDRLOC (scm_sysintern ("signal-handlers", - scm_c_make_vector (NSIG, SCM_BOOL_F))); + SCM_VARIABLE_LOC (scm_c_define ("signal-handlers", + scm_c_make_vector (NSIG, SCM_BOOL_F))); thunk = scm_make_gsubr ("%deliver-signals", 0, 0, 0, sys_deliver_signals); signal_async = scm_system_async (thunk); @@ -532,14 +532,14 @@ scm_init_scmsigs () #endif } - scm_sysintern ("NSIG", scm_long2num (NSIG)); - scm_sysintern ("SIG_IGN", scm_long2num ((long) SIG_IGN)); - scm_sysintern ("SIG_DFL", scm_long2num ((long) SIG_DFL)); + scm_c_define ("NSIG", scm_long2num (NSIG)); + scm_c_define ("SIG_IGN", scm_long2num ((long) SIG_IGN)); + scm_c_define ("SIG_DFL", scm_long2num ((long) SIG_DFL)); #ifdef SA_NOCLDSTOP - scm_sysintern ("SA_NOCLDSTOP", scm_long2num (SA_NOCLDSTOP)); + scm_c_define ("SA_NOCLDSTOP", scm_long2num (SA_NOCLDSTOP)); #endif #ifdef SA_RESTART - scm_sysintern ("SA_RESTART", scm_long2num (SA_RESTART)); + scm_c_define ("SA_RESTART", scm_long2num (SA_RESTART)); #endif #ifndef SCM_MAGIC_SNARFER diff --git a/libguile/script.c b/libguile/script.c index ae2a738e0..2bcb184a1 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -571,7 +571,7 @@ scm_compile_shell_switches (int argc, char **argv) scm_set_program_arguments (argc ? argc - i : 0, argv + i, argv0); /* If the --emacs switch was set, now is when we process it. */ - scm_sysintern ("use-emacs-interface", SCM_BOOL (use_emacs_interface)); + scm_c_define ("use-emacs-interface", SCM_BOOL (use_emacs_interface)); /* Handle the `-e' switch, if it was specified. */ if (!SCM_NULLP (entry_point)) diff --git a/libguile/snarf.h b/libguile/snarf.h index 540c95947..9aef75fcc 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -172,6 +172,27 @@ SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_make_keyword (scheme_name))) SCM_SNARF_HERE(SCM c_name) \ SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_make_keyword (scheme_name))) +#define SCM_VARIABLE(c_name, scheme_name) \ +SCM_SNARF_HERE(static SCM c_name) \ +SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, SCM_BOOL_F));) + +#define SCM_GLOBAL_VARIABLE(c_name, scheme_name) \ +SCM_SNARF_HERE(SCM c_name) \ +SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, SCM_BOOL_F));) + +#define SCM_VARIABLE_INIT(c_name, scheme_name, init_val) \ +SCM_SNARF_HERE(static SCM c_name) \ +SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, init_val));) + +#define SCM_GLOBAL_VARIABLE_INIT(c_name, scheme_name, init_val) \ +SCM_SNARF_HERE(SCM c_name) \ +SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, init_val));) + +#if (SCM_DEBUG_DEPRECATED == 0) + +#define SCM_CONST_LONG(c_name, scheme_name,value) \ +SCM_VARIABLE_INIT(c_name, scheme_name, scm_long2num(value)) + #define SCM_VCELL(c_name, scheme_name) \ SCM_SNARF_HERE(static SCM c_name) \ SCM_SNARF_INIT(c_name = scm_permanent_object (scm_sysintern (scheme_name, SCM_BOOL_F));) @@ -188,11 +209,6 @@ SCM_SNARF_INIT(c_name = scm_permanent_object (scm_sysintern (scheme_name, init_v SCM_SNARF_HERE(SCM c_name) \ SCM_SNARF_INIT(c_name = scm_permanent_object (scm_sysintern (scheme_name, init_val));) -#if (SCM_DEBUG_DEPRECATED == 0) - -#define SCM_CONST_LONG(c_name, scheme_name,value) \ -SCM_VCELL_INIT(c_name, scheme_name, scm_long2num(value)) - #endif /* (SCM_DEBUG_DEPRECATED == 0) */ #ifdef SCM_MAGIC_SNARFER diff --git a/libguile/socket.c b/libguile/socket.c index c9cbef07b..5fbba91ca 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -1264,123 +1264,123 @@ scm_init_socket () { /* protocol families. */ #ifdef AF_UNSPEC - scm_sysintern ("AF_UNSPEC", SCM_MAKINUM (AF_UNSPEC)); + scm_c_define ("AF_UNSPEC", SCM_MAKINUM (AF_UNSPEC)); #endif #ifdef AF_UNIX - scm_sysintern ("AF_UNIX", SCM_MAKINUM (AF_UNIX)); + scm_c_define ("AF_UNIX", SCM_MAKINUM (AF_UNIX)); #endif #ifdef AF_INET - scm_sysintern ("AF_INET", SCM_MAKINUM (AF_INET)); + scm_c_define ("AF_INET", SCM_MAKINUM (AF_INET)); #endif #ifdef AF_INET6 - scm_sysintern ("AF_INET6", SCM_MAKINUM (AF_INET6)); + scm_c_define ("AF_INET6", SCM_MAKINUM (AF_INET6)); #endif #ifdef PF_UNSPEC - scm_sysintern ("PF_UNSPEC", SCM_MAKINUM (PF_UNSPEC)); + scm_c_define ("PF_UNSPEC", SCM_MAKINUM (PF_UNSPEC)); #endif #ifdef PF_UNIX - scm_sysintern ("PF_UNIX", SCM_MAKINUM (PF_UNIX)); + scm_c_define ("PF_UNIX", SCM_MAKINUM (PF_UNIX)); #endif #ifdef PF_INET - scm_sysintern ("PF_INET", SCM_MAKINUM (PF_INET)); + scm_c_define ("PF_INET", SCM_MAKINUM (PF_INET)); #endif #ifdef PF_INET6 - scm_sysintern ("PF_INET6", SCM_MAKINUM (PF_INET6)); + scm_c_define ("PF_INET6", SCM_MAKINUM (PF_INET6)); #endif /* standard addresses. */ #ifdef INADDR_ANY - scm_sysintern ("INADDR_ANY", scm_ulong2num (INADDR_ANY)); + scm_c_define ("INADDR_ANY", scm_ulong2num (INADDR_ANY)); #endif #ifdef INADDR_BROADCAST - scm_sysintern ("INADDR_BROADCAST", scm_ulong2num (INADDR_BROADCAST)); + scm_c_define ("INADDR_BROADCAST", scm_ulong2num (INADDR_BROADCAST)); #endif #ifdef INADDR_NONE - scm_sysintern ("INADDR_NONE", scm_ulong2num (INADDR_NONE)); + scm_c_define ("INADDR_NONE", scm_ulong2num (INADDR_NONE)); #endif #ifdef INADDR_LOOPBACK - scm_sysintern ("INADDR_LOOPBACK", scm_ulong2num (INADDR_LOOPBACK)); + scm_c_define ("INADDR_LOOPBACK", scm_ulong2num (INADDR_LOOPBACK)); #endif /* socket types. */ #ifdef SOCK_STREAM - scm_sysintern ("SOCK_STREAM", SCM_MAKINUM (SOCK_STREAM)); + scm_c_define ("SOCK_STREAM", SCM_MAKINUM (SOCK_STREAM)); #endif #ifdef SOCK_DGRAM - scm_sysintern ("SOCK_DGRAM", SCM_MAKINUM (SOCK_DGRAM)); + scm_c_define ("SOCK_DGRAM", SCM_MAKINUM (SOCK_DGRAM)); #endif #ifdef SOCK_RAW - scm_sysintern ("SOCK_RAW", SCM_MAKINUM (SOCK_RAW)); + scm_c_define ("SOCK_RAW", SCM_MAKINUM (SOCK_RAW)); #endif /* setsockopt level. */ #ifdef SOL_SOCKET - scm_sysintern ("SOL_SOCKET", SCM_MAKINUM (SOL_SOCKET)); + scm_c_define ("SOL_SOCKET", SCM_MAKINUM (SOL_SOCKET)); #endif #ifdef SOL_IP - scm_sysintern ("SOL_IP", SCM_MAKINUM (SOL_IP)); + scm_c_define ("SOL_IP", SCM_MAKINUM (SOL_IP)); #endif #ifdef SOL_TCP - scm_sysintern ("SOL_TCP", SCM_MAKINUM (SOL_TCP)); + scm_c_define ("SOL_TCP", SCM_MAKINUM (SOL_TCP)); #endif #ifdef SOL_UDP - scm_sysintern ("SOL_UDP", SCM_MAKINUM (SOL_UDP)); + scm_c_define ("SOL_UDP", SCM_MAKINUM (SOL_UDP)); #endif /* setsockopt names. */ #ifdef SO_DEBUG - scm_sysintern ("SO_DEBUG", SCM_MAKINUM (SO_DEBUG)); + scm_c_define ("SO_DEBUG", SCM_MAKINUM (SO_DEBUG)); #endif #ifdef SO_REUSEADDR - scm_sysintern ("SO_REUSEADDR", SCM_MAKINUM (SO_REUSEADDR)); + scm_c_define ("SO_REUSEADDR", SCM_MAKINUM (SO_REUSEADDR)); #endif #ifdef SO_STYLE - scm_sysintern ("SO_STYLE", SCM_MAKINUM (SO_STYLE)); + scm_c_define ("SO_STYLE", SCM_MAKINUM (SO_STYLE)); #endif #ifdef SO_TYPE - scm_sysintern ("SO_TYPE", SCM_MAKINUM (SO_TYPE)); + scm_c_define ("SO_TYPE", SCM_MAKINUM (SO_TYPE)); #endif #ifdef SO_ERROR - scm_sysintern ("SO_ERROR", SCM_MAKINUM (SO_ERROR)); + scm_c_define ("SO_ERROR", SCM_MAKINUM (SO_ERROR)); #endif #ifdef SO_DONTROUTE - scm_sysintern ("SO_DONTROUTE", SCM_MAKINUM (SO_DONTROUTE)); + scm_c_define ("SO_DONTROUTE", SCM_MAKINUM (SO_DONTROUTE)); #endif #ifdef SO_BROADCAST - scm_sysintern ("SO_BROADCAST", SCM_MAKINUM (SO_BROADCAST)); + scm_c_define ("SO_BROADCAST", SCM_MAKINUM (SO_BROADCAST)); #endif #ifdef SO_SNDBUF - scm_sysintern ("SO_SNDBUF", SCM_MAKINUM (SO_SNDBUF)); + scm_c_define ("SO_SNDBUF", SCM_MAKINUM (SO_SNDBUF)); #endif #ifdef SO_RCVBUF - scm_sysintern ("SO_RCVBUF", SCM_MAKINUM (SO_RCVBUF)); + scm_c_define ("SO_RCVBUF", SCM_MAKINUM (SO_RCVBUF)); #endif #ifdef SO_KEEPALIVE - scm_sysintern ("SO_KEEPALIVE", SCM_MAKINUM (SO_KEEPALIVE)); + scm_c_define ("SO_KEEPALIVE", SCM_MAKINUM (SO_KEEPALIVE)); #endif #ifdef SO_OOBINLINE - scm_sysintern ("SO_OOBINLINE", SCM_MAKINUM (SO_OOBINLINE)); + scm_c_define ("SO_OOBINLINE", SCM_MAKINUM (SO_OOBINLINE)); #endif #ifdef SO_NO_CHECK - scm_sysintern ("SO_NO_CHECK", SCM_MAKINUM (SO_NO_CHECK)); + scm_c_define ("SO_NO_CHECK", SCM_MAKINUM (SO_NO_CHECK)); #endif #ifdef SO_PRIORITY - scm_sysintern ("SO_PRIORITY", SCM_MAKINUM (SO_PRIORITY)); + scm_c_define ("SO_PRIORITY", SCM_MAKINUM (SO_PRIORITY)); #endif #ifdef SO_LINGER - scm_sysintern ("SO_LINGER", SCM_MAKINUM (SO_LINGER)); + scm_c_define ("SO_LINGER", SCM_MAKINUM (SO_LINGER)); #endif /* recv/send options. */ #ifdef MSG_OOB - scm_sysintern ("MSG_OOB", SCM_MAKINUM (MSG_OOB)); + scm_c_define ("MSG_OOB", SCM_MAKINUM (MSG_OOB)); #endif #ifdef MSG_PEEK - scm_sysintern ("MSG_PEEK", SCM_MAKINUM (MSG_PEEK)); + scm_c_define ("MSG_PEEK", SCM_MAKINUM (MSG_PEEK)); #endif #ifdef MSG_DONTROUTE - scm_sysintern ("MSG_DONTROUTE", SCM_MAKINUM (MSG_DONTROUTE)); + scm_c_define ("MSG_DONTROUTE", SCM_MAKINUM (MSG_DONTROUTE)); #endif scm_add_feature ("socket"); diff --git a/libguile/srcprop.c b/libguile/srcprop.c index 606a62392..ef368aa2c 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -334,7 +334,7 @@ scm_init_srcprop () scm_set_smob_print (scm_tc16_srcprops, srcprops_print); scm_source_whash = scm_make_weak_key_hash_table (SCM_MAKINUM (2047)); - scm_sysintern ("source-whash", scm_source_whash); + scm_c_define ("source-whash", scm_source_whash); #ifndef SCM_MAGIC_SNARFER #include "libguile/srcprop.x" diff --git a/libguile/stacks.c b/libguile/stacks.c index c43ba9b2c..63bbda07b 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -221,9 +221,9 @@ read_frame (scm_debug_frame *dframe,long offset,scm_info_frame *iframe) static SCM get_applybody () { - SCM cell = scm_sym2vcell (scm_sym_apply, SCM_BOOL_F, SCM_BOOL_F); - if (SCM_CONSP (cell) && SCM_CLOSUREP (SCM_CDR (cell))) - return SCM_CADR (SCM_CODE (SCM_CDR (cell))); + SCM var = scm_sym2var (scm_sym_apply, SCM_BOOL_F, SCM_BOOL_F); + if (SCM_VARIABLEP (var) && SCM_CLOSUREP (SCM_VARIABLE_REF (var))) + return SCM_CADR (SCM_CODE (SCM_VARIABLE_REF (var))); else return SCM_UNDEFINED; } diff --git a/libguile/stime.c b/libguile/stime.c index d63ad85d3..ac99a1587 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -706,7 +706,7 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, void scm_init_stime() { - scm_sysintern("internal-time-units-per-second", + scm_c_define ("internal-time-units-per-second", scm_long2num((long)CLKTCK)); #ifdef HAVE_FTIME diff --git a/libguile/struct.c b/libguile/struct.c index 3262ef968..4e8db5d17 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -820,10 +820,11 @@ scm_init_struct () = scm_permanent_object (scm_make_weak_key_hash_table (SCM_MAKINUM (31))); required_vtable_fields = scm_makfrom0str ("pruosrpw"); scm_permanent_object (required_vtable_fields); - scm_sysintern ("vtable-index-layout", SCM_MAKINUM (scm_vtable_index_layout)); - scm_sysintern ("vtable-index-vtable", SCM_MAKINUM (scm_vtable_index_vtable)); - scm_sysintern ("vtable-index-printer", SCM_MAKINUM (scm_vtable_index_printer)); - scm_sysintern ("vtable-offset-user", SCM_MAKINUM (scm_vtable_offset_user)); + scm_c_define ("vtable-index-layout", SCM_MAKINUM (scm_vtable_index_layout)); + scm_c_define ("vtable-index-vtable", SCM_MAKINUM (scm_vtable_index_vtable)); + scm_c_define ("vtable-index-printer", + SCM_MAKINUM (scm_vtable_index_printer)); + scm_c_define ("vtable-offset-user", SCM_MAKINUM (scm_vtable_offset_user)); #ifndef SCM_MAGIC_SNARFER #include "libguile/struct.x" #endif diff --git a/libguile/symbols-deprecated.c b/libguile/symbols-deprecated.c new file mode 100644 index 000000000..49ba28799 --- /dev/null +++ b/libguile/symbols-deprecated.c @@ -0,0 +1,637 @@ +/* Copyright (C) 1995,1996,1997,1998, 2000, 2001 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 + * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + + + +#include "libguile/_scm.h" +#include "libguile/chars.h" +#include "libguile/eval.h" +#include "libguile/hash.h" +#include "libguile/smob.h" +#include "libguile/variable.h" +#include "libguile/alist.h" +#include "libguile/fluids.h" +#include "libguile/strings.h" +#include "libguile/vectors.h" +#include "libguile/hashtab.h" +#include "libguile/weaks.h" +#include "libguile/modules.h" +#include "libguile/deprecation.h" + +#include "libguile/validate.h" +#include "libguile/symbols.h" + +#ifdef HAVE_STRING_H +#include +#endif + + + +#if SCM_ENABLE_VCELLS + +/* scm_sym2ovcell + * looks up the symbol in an arbitrary obarray. + */ + +SCM +scm_sym2ovcell_soft (SCM sym, SCM obarray) +{ + SCM lsym, z; + scm_sizet hash = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (obarray); + + scm_c_issue_deprecation_warning ("`scm_sym2ovcell_soft' is deprecated. " + "Use hashtables instead."); + + SCM_REDEFER_INTS; + for (lsym = SCM_VELTS (obarray)[hash]; + SCM_NIMP (lsym); + lsym = SCM_CDR (lsym)) + { + z = SCM_CAR (lsym); + if (SCM_EQ_P (SCM_CAR (z), sym)) + { + SCM_REALLOW_INTS; + return z; + } + } + SCM_REALLOW_INTS; + return SCM_BOOL_F; +} + + +SCM +scm_sym2ovcell (SCM sym, SCM obarray) +#define FUNC_NAME "scm_sym2ovcell" +{ + SCM answer; + + scm_c_issue_deprecation_warning ("`scm_sym2ovcell' is deprecated. " + "Use hashtables instead."); + + answer = scm_sym2ovcell_soft (sym, obarray); + if (!SCM_FALSEP (answer)) + return answer; + SCM_MISC_ERROR ("uninterned symbol: ~S", SCM_LIST1 (sym)); + return SCM_UNSPECIFIED; /* not reached */ +} +#undef FUNC_NAME + + +/* Intern a symbol whose name is the LEN characters at NAME in OBARRAY. + + OBARRAY should be a vector of lists, indexed by the name's hash + value, modulo OBARRAY's length. Each list has the form + ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the + value associated with that symbol (in the current module? in the + system module?) + + To "intern" a symbol means: if OBARRAY already contains a symbol by + that name, return its (SYMBOL . VALUE) pair; otherwise, create a + new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the + appropriate list of the OBARRAY, and return the pair. + + If softness is non-zero, don't create a symbol if it isn't already + in OBARRAY; instead, just return #f. + + If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and + return (SYMBOL . SCM_UNDEFINED). */ + + +SCM +scm_intern_obarray_soft (const char *name,scm_sizet len,SCM obarray,unsigned int softness) +{ + SCM symbol = scm_mem2symbol (name, len); + scm_sizet raw_hash = SCM_SYMBOL_HASH (symbol); + scm_sizet hash; + SCM lsym; + + scm_c_issue_deprecation_warning ("`scm_intern_obarray_soft' is deprecated. " + "Use hashtables instead."); + + if (SCM_FALSEP (obarray)) + { + if (softness) + return SCM_BOOL_F; + else + return scm_cons (symbol, SCM_UNDEFINED); + } + + hash = raw_hash % SCM_VECTOR_LENGTH (obarray); + + for (lsym = SCM_VELTS (obarray)[hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) + { + SCM a = SCM_CAR (lsym); + SCM z = SCM_CAR (a); + if (SCM_EQ_P (z, symbol)) + return a; + } + + if (softness) + { + return SCM_BOOL_F; + } + else + { + SCM cell = scm_cons (symbol, SCM_UNDEFINED); + SCM slot = SCM_VELTS (obarray) [hash]; + + SCM_VELTS (obarray) [hash] = scm_cons (cell, slot); + + return cell; + } +} + + +SCM +scm_intern_obarray (const char *name,scm_sizet len,SCM obarray) +{ + scm_c_issue_deprecation_warning ("`scm_intern_obarray' is deprecated. " + "Use hashtables instead."); + + return scm_intern_obarray_soft (name, len, obarray, 0); +} + + +SCM +scm_intern (const char *name,scm_sizet len) +{ + scm_c_issue_deprecation_warning ("`scm_intern' is deprecated. " + "Use scm_c_define or scm_c_lookup instead."); + + { + SCM symbol = scm_mem2symbol (name, len); + SCM var = scm_sym2var (symbol, SCM_BOOL_F, SCM_BOOL_T); + SCM vcell = SCM_VARVCELL (var); + SCM_SETCAR (vcell, symbol); + return vcell; + } +} + + +SCM +scm_intern0 (const char * name) +{ + scm_c_issue_deprecation_warning ("`scm_intern0' is deprecated. " + "Use scm_define or scm_lookup instead."); + + return scm_intern (name, strlen (name)); +} + +/* Intern the symbol named NAME in scm_symhash, and give it the value + VAL. NAME is null-terminated. Use the current top_level lookup + closure to give NAME its value. + */ +SCM +scm_sysintern (const char *name, SCM val) +{ + SCM var; + + scm_c_issue_deprecation_warning ("`scm_sysintern' is deprecated. " + "Use `scm_define' instead."); + + var = scm_c_define (name, val); + return SCM_VARVCELL (var); +} + +SCM +scm_sysintern0 (const char *name) +{ + SCM var; + SCM symbol; + + scm_c_issue_deprecation_warning ("`scm_sysintern0' is deprecated. " + "Use `scm_define' instead."); + + symbol = scm_str2symbol (name); + var = scm_sym2var (symbol, scm_current_module_lookup_closure (), SCM_BOOL_T); + if (var == SCM_BOOL_F) + scm_misc_error ("sysintern0", "can't define variable", symbol); + return SCM_VARVCELL (var); +} + +/* Lookup the value of the symbol named by the nul-terminated string + NAME in the current module. */ +SCM +scm_symbol_value0 (const char *name) +{ + scm_c_issue_deprecation_warning ("`scm_symbol_value0' is deprecated. " + "Use `scm_lookup' instead."); + + return scm_variable_ref (scm_c_lookup (name)); +} + +SCM +scm_sym2vcell (SCM sym, SCM thunk, SCM definep) +{ + SCM var; + + scm_c_issue_deprecation_warning("`scm_sym2vcell' is deprecated. " + "Use `scm_define' or `scm_lookup' instead."); + + var = scm_sym2var (sym, thunk, definep); + if (var == SCM_BOOL_F) + return SCM_BOOL_F; + return SCM_VARVCELL (var); +} + +SCM_DEFINE (scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, + (SCM o, SCM s, SCM softp), + "Intern a new symbol in @var{obarray}, a symbol table, with name\n" + "@var{string}.\n\n" + "If @var{obarray} is @code{#f}, use the default system symbol table. If\n" + "@var{obarray} is @code{#t}, the symbol should not be interned in any\n" + "symbol table; merely return the pair (@var{symbol}\n" + ". @var{#}).\n\n" + "The @var{soft?} argument determines whether new symbol table entries\n" + "should be created when the specified symbol is not already present in\n" + "@var{obarray}. If @var{soft?} is specified and is a true value, then\n" + "new entries should not be added for symbols not already present in the\n" + "table; instead, simply return @code{#f}.") +#define FUNC_NAME s_scm_string_to_obarray_symbol +{ + SCM vcell; + SCM answer; + int softness; + + SCM_VALIDATE_STRING (2, s); + SCM_ASSERT (SCM_BOOLP (o) || SCM_VECTORP (o), o, SCM_ARG1, FUNC_NAME); + + scm_c_issue_deprecation_warning ("`string->obarray-symbol' is deprecated. " + "Use hashtables instead."); + + softness = (!SCM_UNBNDP (softp) && !SCM_FALSEP(softp)); + /* iron out some screwy calling conventions */ + if (SCM_FALSEP (o)) + { + /* nothing interesting to do here. */ + return scm_string_to_symbol (s); + } + else if (SCM_EQ_P (o, SCM_BOOL_T)) + o = SCM_BOOL_F; + + vcell = scm_intern_obarray_soft (SCM_STRING_CHARS(s), + SCM_STRING_LENGTH (s), + o, + softness); + if (SCM_FALSEP (vcell)) + return vcell; + answer = SCM_CAR (vcell); + return answer; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0, + (SCM o, SCM s), + "Add a new symbol to @var{obarray} with name @var{string}, bound to an\n" + "unspecified initial value. The symbol table is not modified if a symbol\n" + "with this name is already present.") +#define FUNC_NAME s_scm_intern_symbol +{ + scm_sizet hval; + SCM_VALIDATE_SYMBOL (2,s); + if (SCM_FALSEP (o)) + return SCM_UNSPECIFIED; + + scm_c_issue_deprecation_warning ("`intern-symbol' is deprecated. " + "Use hashtables instead."); + + SCM_VALIDATE_VECTOR (1,o); + hval = SCM_SYMBOL_HASH (s) % SCM_VECTOR_LENGTH (o); + /* If the symbol is already interned, simply return. */ + SCM_REDEFER_INTS; + { + SCM lsym; + SCM sym; + for (lsym = SCM_VELTS (o)[hval]; + SCM_NIMP (lsym); + lsym = SCM_CDR (lsym)) + { + sym = SCM_CAR (lsym); + if (SCM_EQ_P (SCM_CAR (sym), s)) + { + SCM_REALLOW_INTS; + return SCM_UNSPECIFIED; + } + } + SCM_VELTS (o)[hval] = + scm_acons (s, SCM_UNDEFINED, SCM_VELTS (o)[hval]); + } + SCM_REALLOW_INTS; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0, + (SCM o, SCM s), + "Remove the symbol with name @var{string} from @var{obarray}. This\n" + "function returns @code{#t} if the symbol was present and @code{#f}\n" + "otherwise.") +#define FUNC_NAME s_scm_unintern_symbol +{ + scm_sizet hval; + + scm_c_issue_deprecation_warning ("`unintern-symbol' is deprecated. " + "Use hashtables instead."); + + SCM_VALIDATE_SYMBOL (2,s); + if (SCM_FALSEP (o)) + return SCM_BOOL_F; + SCM_VALIDATE_VECTOR (1,o); + hval = SCM_SYMBOL_HASH (s) % SCM_VECTOR_LENGTH (o); + SCM_DEFER_INTS; + { + SCM lsym_follow; + SCM lsym; + SCM sym; + for (lsym = SCM_VELTS (o)[hval], lsym_follow = SCM_BOOL_F; + SCM_NIMP (lsym); + lsym_follow = lsym, lsym = SCM_CDR (lsym)) + { + sym = SCM_CAR (lsym); + if (SCM_EQ_P (SCM_CAR (sym), s)) + { + /* Found the symbol to unintern. */ + if (SCM_FALSEP (lsym_follow)) + SCM_VELTS(o)[hval] = lsym; + else + SCM_SETCDR (lsym_follow, SCM_CDR(lsym)); + SCM_ALLOW_INTS; + return SCM_BOOL_T; + } + } + } + SCM_ALLOW_INTS; + return SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_symbol_binding, "symbol-binding", 2, 0, 0, + (SCM o, SCM s), + "Look up in @var{obarray} the symbol whose name is @var{string}, and\n" + "return the value to which it is bound. If @var{obarray} is @code{#f},\n" + "use the global symbol table. If @var{string} is not interned in\n" + "@var{obarray}, an error is signalled.") +#define FUNC_NAME s_scm_symbol_binding +{ + SCM vcell; + + scm_c_issue_deprecation_warning ("`symbol-binding' is deprecated. " + "Use hashtables instead."); + + SCM_VALIDATE_SYMBOL (2,s); + if (SCM_FALSEP (o)) + return scm_variable_ref (scm_lookup (s)); + SCM_VALIDATE_VECTOR (1,o); + vcell = scm_sym2ovcell (s, o); + return SCM_CDR(vcell); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 2, 0, 0, + (SCM o, SCM s), + "Return @code{#t} if @var{obarray} contains a symbol with name\n" + "@var{string}, and @code{#f} otherwise.") +#define FUNC_NAME s_scm_symbol_interned_p +{ + SCM vcell; + + scm_c_issue_deprecation_warning ("`symbol-interned?' is deprecated. " + "Use hashtables instead."); + + SCM_VALIDATE_SYMBOL (2,s); + if (SCM_FALSEP (o)) + { + SCM var = scm_sym2var (s, SCM_BOOL_F, SCM_BOOL_F); + if (var != SCM_BOOL_F) + return SCM_BOOL_T; + return SCM_BOOL_F; + } + SCM_VALIDATE_VECTOR (1,o); + vcell = scm_sym2ovcell_soft (s, o); + return (SCM_NIMP(vcell) + ? SCM_BOOL_T + : SCM_BOOL_F); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_symbol_bound_p, "symbol-bound?", 2, 0, 0, + (SCM o, SCM s), + "Return @code{#t} if @var{obarray} contains a symbol with name\n" + "@var{string} bound to a defined value. This differs from\n" + "@var{symbol-interned?} in that the mere mention of a symbol\n" + "usually causes it to be interned; @code{symbol-bound?}\n" + "determines whether a symbol has been given any meaningful\n" + "value.") +#define FUNC_NAME s_scm_symbol_bound_p +{ + SCM vcell; + + scm_c_issue_deprecation_warning ("`symbol-bound?' is deprecated. " + "Use hashtables instead."); + + SCM_VALIDATE_SYMBOL (2,s); + if (SCM_FALSEP (o)) + { + SCM var = scm_sym2var (s, SCM_BOOL_F, SCM_BOOL_F); + if (SCM_DEFVARIABLEP (var)) + return SCM_BOOL_T; + return SCM_BOOL_F; + } + SCM_VALIDATE_VECTOR (1,o); + vcell = scm_sym2ovcell_soft (s, o); + return SCM_BOOL (SCM_NIMP (vcell) && !SCM_UNBNDP (SCM_CDR (vcell))); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_symbol_set_x, "symbol-set!", 3, 0, 0, + (SCM o, SCM s, SCM v), + "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n" + "it to @var{value}. An error is signalled if @var{string} is not present\n" + "in @var{obarray}.") +#define FUNC_NAME s_scm_symbol_set_x +{ + SCM vcell; + + scm_c_issue_deprecation_warning ("`symbol-set!' is deprecated. " + "Use the module system instead."); + + SCM_VALIDATE_SYMBOL (2,s); + if (SCM_FALSEP (o)) + { + scm_define (s, v); + return SCM_UNSPECIFIED; + } + SCM_VALIDATE_VECTOR (1,o); + vcell = scm_sym2ovcell (s, o); + SCM_SETCDR (vcell, v); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +#if 0 + +static void +copy_and_prune_obarray (SCM from, SCM to) +{ + int i; + int length = SCM_VECTOR_LENGTH (from); + for (i = 0; i < length; ++i) + { + SCM head = SCM_VELTS (from)[i]; /* GC protection */ + SCM ls = head; + SCM res = SCM_EOL; + SCM *lloc = &res; + while (SCM_NIMP (ls)) + { + if (!SCM_UNBNDP (SCM_CDAR (ls))) + { + *lloc = scm_cons (SCM_CAR (ls), SCM_EOL); + lloc = SCM_CDRLOC (*lloc); + } + ls = SCM_CDR (ls); + } + SCM_VELTS (to)[i] = res; + } +} + + +SCM_DEFINE (scm_builtin_bindings, "builtin-bindings", 0, 0, 0, + (), + "Create and return a copy of the global symbol table, removing all\n" + "unbound symbols.") +#define FUNC_NAME s_scm_builtin_bindings +{ + int length = SCM_VECTOR_LENGTH (scm_symhash); + SCM obarray = scm_c_make_hash_table (length); + + scm_issue_deprecation_warning ("`builtin-bindings' is deprecated. " + "Use the module system instead."); + + copy_and_prune_obarray (scm_symhash, obarray); + return obarray; +} +#undef FUNC_NAME + +#endif + +#define MAX_PREFIX_LENGTH 30 + +static int gentemp_counter; + +SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0, + (SCM prefix, SCM obarray), + "Create a new symbol with a name unique in an obarray.\n" + "The name is constructed from an optional string @var{prefix}\n" + "and a counter value. The default prefix is @code{t}. The\n" + "@var{obarray} is specified as a second optional argument.\n" + "Default is the system obarray where all normal symbols are\n" + "interned. The counter is increased by 1 at each\n" + "call. There is no provision for resetting the counter.") +#define FUNC_NAME s_scm_gentemp +{ + char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; + char *name = buf; + int len, n_digits; + + scm_c_issue_deprecation_warning ("`gentemp' is deprecated. " + "Use `gensym' instead."); + + if (SCM_UNBNDP (prefix)) + { + name[0] = 't'; + len = 1; + } + else + { + SCM_VALIDATE_STRING (1, prefix); + len = SCM_STRING_LENGTH (prefix); + if (len > MAX_PREFIX_LENGTH) + name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); + strncpy (name, SCM_STRING_CHARS (prefix), len); + } + + if (SCM_UNBNDP (obarray)) + return scm_gensym (prefix); + else + SCM_ASSERT ((SCM_VECTORP (obarray) || SCM_WVECTP (obarray)), + obarray, + SCM_ARG2, + FUNC_NAME); + do + n_digits = scm_iint2str (gentemp_counter++, 10, &name[len]); + while (!SCM_FALSEP (scm_intern_obarray_soft (name, + len + n_digits, + obarray, + 1))); + { + SCM vcell = scm_intern_obarray_soft (name, + len + n_digits, + obarray, + 0); + if (name != buf) + scm_must_free (name); + return SCM_CAR (vcell); + } +} +#undef FUNC_NAME + +void +scm_init_symbols_deprecated () +{ + gentemp_counter = 0; +#ifndef SCM_MAGIC_SNARFER +#include "libguile/symbols-deprecated.x" +#endif +} + +#endif /* SCM_ENABLE_VCELLS */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/symbols.c b/libguile/symbols.c index 1bb2778a8..45f5ee982 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -158,264 +158,6 @@ scm_str2symbol (const char *str) return scm_mem2symbol (str, strlen (str)); } - -/* scm_sym2vcell - * looks up the symbol in the symhash table. - */ - -SCM -scm_sym2vcell (SCM sym, SCM thunk, SCM definep) -#define FUNC_NAME "scm_sym2vcell" -{ - if (SCM_NIMP (thunk)) - { - SCM var; - - if (SCM_EVAL_CLOSURE_P (thunk)) - /* Bypass evaluator in the standard case. */ - var = scm_eval_closure_lookup (thunk, sym, definep); - else - var = scm_apply (thunk, sym, scm_cons (definep, scm_listofnull)); - - if (SCM_FALSEP (var)) - return SCM_BOOL_F; - else if (SCM_VARIABLEP (var)) - return SCM_VARVCELL (var); - else - SCM_MISC_ERROR ("strangely interned symbol: ~S", SCM_LIST1 (sym)); - } - else - { - SCM lsym; - scm_sizet hash; - - SCM_DEFER_INTS; - hash = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (scm_symhash); - for (lsym = SCM_VELTS (scm_symhash)[hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) - { - SCM z = SCM_CAR (lsym); - if (SCM_EQ_P (SCM_CAR (z), sym)) - { - SCM_ALLOW_INTS; - return z; - } - } - - if (!SCM_FALSEP (definep)) - { - SCM cell = scm_cons (sym, SCM_UNDEFINED); - SCM slot = SCM_VELTS (scm_symhash) [hash]; - - SCM_VELTS (scm_symhash) [hash] = scm_cons (cell, slot); - - SCM_ALLOW_INTS; - return cell; - } - else - { - SCM_ALLOW_INTS; - return SCM_BOOL_F; - } - } -} -#undef FUNC_NAME - - -/* scm_sym2ovcell - * looks up the symbol in an arbitrary obarray. - */ - -SCM -scm_sym2ovcell_soft (SCM sym, SCM obarray) -{ - SCM lsym, z; - scm_sizet hash = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (obarray); - SCM_REDEFER_INTS; - for (lsym = SCM_VELTS (obarray)[hash]; - SCM_NIMP (lsym); - lsym = SCM_CDR (lsym)) - { - z = SCM_CAR (lsym); - if (SCM_EQ_P (SCM_CAR (z), sym)) - { - SCM_REALLOW_INTS; - return z; - } - } - SCM_REALLOW_INTS; - return SCM_BOOL_F; -} - - -SCM -scm_sym2ovcell (SCM sym, SCM obarray) -#define FUNC_NAME "scm_sym2ovcell" -{ - SCM answer; - answer = scm_sym2ovcell_soft (sym, obarray); - if (!SCM_FALSEP (answer)) - return answer; - SCM_MISC_ERROR ("uninterned symbol: ~S", SCM_LIST1 (sym)); - return SCM_UNSPECIFIED; /* not reached */ -} -#undef FUNC_NAME - - -/* Intern a symbol whose name is the LEN characters at NAME in OBARRAY. - - OBARRAY should be a vector of lists, indexed by the name's hash - value, modulo OBARRAY's length. Each list has the form - ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the - value associated with that symbol (in the current module? in the - system module?) - - To "intern" a symbol means: if OBARRAY already contains a symbol by - that name, return its (SYMBOL . VALUE) pair; otherwise, create a - new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the - appropriate list of the OBARRAY, and return the pair. - - If softness is non-zero, don't create a symbol if it isn't already - in OBARRAY; instead, just return #f. - - If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and - return (SYMBOL . SCM_UNDEFINED). */ - - -SCM -scm_intern_obarray_soft (const char *name,scm_sizet len,SCM obarray,unsigned int softness) -{ - SCM symbol = scm_mem2symbol (name, len); - scm_sizet raw_hash = SCM_SYMBOL_HASH (symbol); - scm_sizet hash; - SCM lsym; - - if (SCM_FALSEP (obarray)) - { - if (softness) - return SCM_BOOL_F; - else - return scm_cons (symbol, SCM_UNDEFINED); - } - - hash = raw_hash % SCM_VECTOR_LENGTH (obarray); - - for (lsym = SCM_VELTS (obarray)[hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) - { - SCM a = SCM_CAR (lsym); - SCM z = SCM_CAR (a); - if (SCM_EQ_P (z, symbol)) - return a; - } - - if (softness) - { - return SCM_BOOL_F; - } - else - { - SCM cell = scm_cons (symbol, SCM_UNDEFINED); - SCM slot = SCM_VELTS (obarray) [hash]; - - SCM_VELTS (obarray) [hash] = scm_cons (cell, slot); - - return cell; - } -} - - -SCM -scm_intern_obarray (const char *name,scm_sizet len,SCM obarray) -{ - return scm_intern_obarray_soft (name, len, obarray, 0); -} - - -SCM -scm_intern (const char *name,scm_sizet len) -{ - return scm_intern_obarray (name, len, scm_symhash); -} - - -SCM -scm_intern0 (const char * name) -{ - return scm_intern (name, strlen (name)); -} - - -/* Intern the symbol named NAME in scm_symhash, NAME is null-terminated. */ -SCM -scm_sysintern0_no_module_lookup (const char *name) -{ - scm_sizet len = strlen (name); - SCM easy_answer; - SCM_DEFER_INTS; - easy_answer = scm_intern_obarray_soft (name, len, scm_symhash, 1); - if (SCM_NIMP (easy_answer)) - { - SCM_ALLOW_INTS; - return easy_answer; - } - else - { - SCM symbol = scm_mem2symbol (name, len); - scm_sizet raw_hash = SCM_SYMBOL_HASH (symbol); - scm_sizet hash = raw_hash % SCM_VECTOR_LENGTH (scm_symhash); - SCM cell = scm_cons (symbol, SCM_UNDEFINED); - SCM slot = SCM_VELTS (scm_symhash) [hash]; - - SCM_VELTS (scm_symhash) [hash] = scm_cons (cell, slot); - SCM_ALLOW_INTS; - return cell; - } -} - -/* Intern the symbol named NAME in scm_symhash, and give it the value - VAL. NAME is null-terminated. Use the current top_level lookup - closure to give NAME its value. - */ -SCM -scm_sysintern (const char *name, SCM val) -{ - SCM vcell = scm_sysintern0 (name); - SCM_SETCDR (vcell, val); - return vcell; -} - -SCM -scm_sysintern0 (const char *name) -{ - SCM lookup_proc; - if (scm_module_system_booted_p - && SCM_NIMP (lookup_proc = SCM_TOP_LEVEL_LOOKUP_CLOSURE)) - { - SCM sym = scm_str2symbol (name); - SCM vcell = scm_sym2vcell (sym, lookup_proc, SCM_BOOL_T); - if (SCM_FALSEP (vcell)) - scm_misc_error ("sysintern0", "can't define variable", sym); - return vcell; - } - else - return scm_sysintern0_no_module_lookup (name); -} - -/* Lookup the value of the symbol named by the nul-terminated string - NAME in the current module. */ -SCM -scm_symbol_value0 (const char *name) -{ - /* This looks silly - we look up the symbol twice. But it is in - fact necessary given the current module system because the module - lookup closures are written in scheme which needs real symbols. */ - SCM symbol = scm_str2symbol (name); - SCM vcell = scm_sym2vcell (symbol, SCM_TOP_LEVEL_LOOKUP_CLOSURE, SCM_BOOL_F); - if (SCM_FALSEP (vcell)) - return SCM_UNDEFINED; - return SCM_CDR (vcell); -} - - SCM_DEFINE (scm_symbol_p, "symbol?", 1, 0, 0, (SCM obj), "Return @code{#t} if @var{obj} is a symbol, otherwise return\n" @@ -489,202 +231,55 @@ SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0, } #undef FUNC_NAME +#define MAX_PREFIX_LENGTH 30 -SCM_DEFINE (scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, - (SCM o, SCM s, SCM softp), - "Intern a new symbol in @var{obarray}, a symbol table, with name\n" - "@var{string}.\n\n" - "If @var{obarray} is @code{#f}, use the default system symbol table. If\n" - "@var{obarray} is @code{#t}, the symbol should not be interned in any\n" - "symbol table; merely return the pair (@var{symbol}\n" - ". @var{#}).\n\n" - "The @var{soft?} argument determines whether new symbol table entries\n" - "should be created when the specified symbol is not already present in\n" - "@var{obarray}. If @var{soft?} is specified and is a true value, then\n" - "new entries should not be added for symbols not already present in the\n" - "table; instead, simply return @code{#f}.") -#define FUNC_NAME s_scm_string_to_obarray_symbol +static int gensym_counter; + +SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, + (SCM prefix), + "Create a new symbol with a name constructed from a prefix and\n" + "a counter value. The string @var{prefix} can be specified as\n" + "an optional argument. Default prefix is @code{g}. The counter\n" + "is increased by 1 at each call. There is no provision for\n" + "resetting the counter.") +#define FUNC_NAME s_scm_gensym { - SCM vcell; - SCM answer; - int softness; - - SCM_VALIDATE_STRING (2, s); - SCM_ASSERT (SCM_BOOLP (o) || SCM_VECTORP (o), o, SCM_ARG1, FUNC_NAME); - - softness = (!SCM_UNBNDP (softp) && !SCM_FALSEP(softp)); - /* iron out some screwy calling conventions */ - if (SCM_FALSEP (o)) - o = scm_symhash; - else if (SCM_EQ_P (o, SCM_BOOL_T)) - o = SCM_BOOL_F; - - vcell = scm_intern_obarray_soft (SCM_STRING_CHARS(s), - SCM_STRING_LENGTH (s), - o, - softness); - if (SCM_FALSEP (vcell)) - return vcell; - answer = SCM_CAR (vcell); - return answer; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0, - (SCM o, SCM s), - "Add a new symbol to @var{obarray} with name @var{string}, bound to an\n" - "unspecified initial value. The symbol table is not modified if a symbol\n" - "with this name is already present.") -#define FUNC_NAME s_scm_intern_symbol -{ - scm_sizet hval; - SCM_VALIDATE_SYMBOL (2,s); - if (SCM_FALSEP (o)) - o = scm_symhash; - SCM_VALIDATE_VECTOR (1,o); - hval = SCM_SYMBOL_HASH (s) % SCM_VECTOR_LENGTH (o); - /* If the symbol is already interned, simply return. */ - SCM_REDEFER_INTS; + char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; + char *name = buf; + int len; + if (SCM_UNBNDP (prefix)) + { + name[0] = 'g'; + len = 1; + } + else + { + SCM_VALIDATE_STRING (1, prefix); + len = SCM_STRING_LENGTH (prefix); + if (len > MAX_PREFIX_LENGTH) + name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); + strncpy (name, SCM_STRING_CHARS (prefix), len); + } { - SCM lsym; - SCM sym; - for (lsym = SCM_VELTS (o)[hval]; - SCM_NIMP (lsym); - lsym = SCM_CDR (lsym)) - { - sym = SCM_CAR (lsym); - if (SCM_EQ_P (SCM_CAR (sym), s)) - { - SCM_REALLOW_INTS; - return SCM_UNSPECIFIED; - } - } - SCM_VELTS (o)[hval] = - scm_acons (s, SCM_UNDEFINED, SCM_VELTS (o)[hval]); + int n_digits = scm_iint2str (gensym_counter++, 10, &name[len]); + SCM res = scm_mem2symbol (name, len + n_digits); + if (name != buf) + scm_must_free (name); + return res; } - SCM_REALLOW_INTS; - return SCM_UNSPECIFIED; } #undef FUNC_NAME -SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0, - (SCM o, SCM s), - "Remove the symbol with name @var{string} from @var{obarray}. This\n" - "function returns @code{#t} if the symbol was present and @code{#f}\n" - "otherwise.") -#define FUNC_NAME s_scm_unintern_symbol +SCM_DEFINE (scm_symbol_hash, "symbol-hash", 1, 0, 0, + (SCM symbol), + "Return a hash value for @var{symbol}.") +#define FUNC_NAME s_scm_symbol_hash { - scm_sizet hval; - SCM_VALIDATE_SYMBOL (2,s); - if (SCM_FALSEP (o)) - o = scm_symhash; - SCM_VALIDATE_VECTOR (1,o); - hval = SCM_SYMBOL_HASH (s) % SCM_VECTOR_LENGTH (o); - SCM_DEFER_INTS; - { - SCM lsym_follow; - SCM lsym; - SCM sym; - for (lsym = SCM_VELTS (o)[hval], lsym_follow = SCM_BOOL_F; - SCM_NIMP (lsym); - lsym_follow = lsym, lsym = SCM_CDR (lsym)) - { - sym = SCM_CAR (lsym); - if (SCM_EQ_P (SCM_CAR (sym), s)) - { - /* Found the symbol to unintern. */ - if (SCM_FALSEP (lsym_follow)) - SCM_VELTS(o)[hval] = lsym; - else - SCM_SETCDR (lsym_follow, SCM_CDR(lsym)); - SCM_ALLOW_INTS; - return SCM_BOOL_T; - } - } - } - SCM_ALLOW_INTS; - return SCM_BOOL_F; + SCM_VALIDATE_SYMBOL (1, symbol); + return SCM_MAKINUM (SCM_SYMBOL_HASH (symbol)); } #undef FUNC_NAME -SCM_DEFINE (scm_symbol_binding, "symbol-binding", 2, 0, 0, - (SCM o, SCM s), - "Look up in @var{obarray} the symbol whose name is @var{string}, and\n" - "return the value to which it is bound. If @var{obarray} is @code{#f},\n" - "use the global symbol table. If @var{string} is not interned in\n" - "@var{obarray}, an error is signalled.") -#define FUNC_NAME s_scm_symbol_binding -{ - SCM vcell; - SCM_VALIDATE_SYMBOL (2,s); - if (SCM_FALSEP (o)) - o = scm_symhash; - SCM_VALIDATE_VECTOR (1,o); - vcell = scm_sym2ovcell (s, o); - return SCM_CDR(vcell); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 2, 0, 0, - (SCM o, SCM s), - "Return @code{#t} if @var{obarray} contains a symbol with name\n" - "@var{string}, and @code{#f} otherwise.") -#define FUNC_NAME s_scm_symbol_interned_p -{ - SCM vcell; - SCM_VALIDATE_SYMBOL (2,s); - if (SCM_FALSEP (o)) - o = scm_symhash; - SCM_VALIDATE_VECTOR (1,o); - vcell = scm_sym2ovcell_soft (s, o); - return (SCM_NIMP(vcell) - ? SCM_BOOL_T - : SCM_BOOL_F); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_symbol_bound_p, "symbol-bound?", 2, 0, 0, - (SCM o, SCM s), - "Return @code{#t} if @var{obarray} contains a symbol with name\n" - "@var{string} bound to a defined value. This differs from\n" - "@var{symbol-interned?} in that the mere mention of a symbol\n" - "usually causes it to be interned; @code{symbol-bound?}\n" - "determines whether a symbol has been given any meaningful\n" - "value.") -#define FUNC_NAME s_scm_symbol_bound_p -{ - SCM vcell; - SCM_VALIDATE_SYMBOL (2,s); - if (SCM_FALSEP (o)) - o = scm_symhash; - SCM_VALIDATE_VECTOR (1,o); - vcell = scm_sym2ovcell_soft (s, o); - return SCM_BOOL (SCM_NIMP (vcell) && !SCM_UNBNDP (SCM_CDR (vcell))); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_symbol_set_x, "symbol-set!", 3, 0, 0, - (SCM o, SCM s, SCM v), - "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n" - "it to @var{value}. An error is signalled if @var{string} is not present\n" - "in @var{obarray}.") -#define FUNC_NAME s_scm_symbol_set_x -{ - SCM vcell; - SCM_VALIDATE_SYMBOL (2,s); - if (SCM_FALSEP (o)) - o = scm_symhash; - SCM_VALIDATE_VECTOR (1,o); - vcell = scm_sym2ovcell (s, o); - SCM_SETCDR (vcell, v); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - SCM_DEFINE (scm_symbol_fref, "symbol-fref", 1, 0, 0, (SCM s), "Return the contents of @var{symbol}'s @dfn{function slot}.") @@ -732,152 +327,6 @@ SCM_DEFINE (scm_symbol_pset_x, "symbol-pset!", 2, 0, 0, } #undef FUNC_NAME - -SCM_DEFINE (scm_symbol_hash, "symbol-hash", 1, 0, 0, - (SCM symbol), - "Return a hash value for @var{symbol}.") -#define FUNC_NAME s_scm_symbol_hash -{ - SCM_VALIDATE_SYMBOL (1, symbol); - return SCM_MAKINUM (SCM_SYMBOL_HASH (symbol)); -} -#undef FUNC_NAME - - -static void -copy_and_prune_obarray (SCM from, SCM to) -{ - int i; - int length = SCM_VECTOR_LENGTH (from); - for (i = 0; i < length; ++i) - { - SCM head = SCM_VELTS (from)[i]; /* GC protection */ - SCM ls = head; - SCM res = SCM_EOL; - SCM *lloc = &res; - while (SCM_NIMP (ls)) - { - if (!SCM_UNBNDP (SCM_CDAR (ls))) - { - *lloc = scm_cons (SCM_CAR (ls), SCM_EOL); - lloc = SCM_CDRLOC (*lloc); - } - ls = SCM_CDR (ls); - } - SCM_VELTS (to)[i] = res; - } -} - - -SCM_DEFINE (scm_builtin_bindings, "builtin-bindings", 0, 0, 0, - (), - "Create and return a copy of the global symbol table, removing all\n" - "unbound symbols.") -#define FUNC_NAME s_scm_builtin_bindings -{ - int length = SCM_VECTOR_LENGTH (scm_symhash); - SCM obarray = scm_c_make_hash_table (length); - copy_and_prune_obarray (scm_symhash, obarray); - return obarray; -} -#undef FUNC_NAME - - -#define MAX_PREFIX_LENGTH 30 - -static int gensym_counter; - -SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, - (SCM prefix), - "Create a new symbol with a name constructed from a prefix and\n" - "a counter value. The string @var{prefix} can be specified as\n" - "an optional argument. Default prefix is @code{g}. The counter\n" - "is increased by 1 at each call. There is no provision for\n" - "resetting the counter.") -#define FUNC_NAME s_scm_gensym -{ - char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; - char *name = buf; - int len; - if (SCM_UNBNDP (prefix)) - { - name[0] = 'g'; - len = 1; - } - else - { - SCM_VALIDATE_STRING (1, prefix); - len = SCM_STRING_LENGTH (prefix); - if (len > MAX_PREFIX_LENGTH) - name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); - strncpy (name, SCM_STRING_CHARS (prefix), len); - } - { - int n_digits = scm_iint2str (gensym_counter++, 10, &name[len]); - SCM res = scm_mem2symbol (name, len + n_digits); - if (name != buf) - scm_must_free (name); - return res; - } -} -#undef FUNC_NAME - -static int gentemp_counter; - -SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0, - (SCM prefix, SCM obarray), - "Create a new symbol with a name unique in an obarray.\n" - "The name is constructed from an optional string @var{prefix}\n" - "and a counter value. The default prefix is @code{t}. The\n" - "@var{obarray} is specified as a second optional argument.\n" - "Default is the system obarray where all normal symbols are\n" - "interned. The counter is increased by 1 at each\n" - "call. There is no provision for resetting the counter.") -#define FUNC_NAME s_scm_gentemp -{ - char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; - char *name = buf; - int len, n_digits; - if (SCM_UNBNDP (prefix)) - { - name[0] = 't'; - len = 1; - } - else - { - SCM_VALIDATE_STRING (1, prefix); - len = SCM_STRING_LENGTH (prefix); - if (len > MAX_PREFIX_LENGTH) - name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); - strncpy (name, SCM_STRING_CHARS (prefix), len); - } - - if (SCM_UNBNDP (obarray)) - obarray = scm_symhash; - else - SCM_ASSERT ((SCM_VECTORP (obarray) || SCM_WVECTP (obarray)), - obarray, - SCM_ARG2, - FUNC_NAME); - do - n_digits = scm_iint2str (gentemp_counter++, 10, &name[len]); - while (!SCM_FALSEP (scm_intern_obarray_soft (name, - len + n_digits, - obarray, - 1))); - { - SCM vcell = scm_intern_obarray_soft (name, - len + n_digits, - obarray, - 0); - if (name != buf) - scm_must_free (name); - return SCM_CAR (vcell); - } -} -#undef FUNC_NAME - - void scm_symbols_prehistory () { @@ -890,10 +339,12 @@ void scm_init_symbols () { gensym_counter = 0; - gentemp_counter = 0; #ifndef SCM_MAGIC_SNARFER #include "libguile/symbols.x" #endif +#if SCM_ENABLE_VCELLS + scm_init_symbols_deprecated (); +#endif } /* diff --git a/libguile/symbols.h b/libguile/symbols.h index a2987aa47..1d10b371e 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -77,35 +77,18 @@ extern SCM scm_sys_symbols (void); extern SCM scm_mem2symbol (const char*, scm_sizet); extern SCM scm_str2symbol (const char*); -extern SCM scm_sym2vcell (SCM sym, SCM thunk, SCM definep); -extern SCM scm_sym2ovcell_soft (SCM sym, SCM obarray); -extern SCM scm_sym2ovcell (SCM sym, SCM obarray); -extern SCM scm_intern_obarray_soft (const char *name, scm_sizet len, SCM obarray, unsigned int softness); -extern SCM scm_intern_obarray (const char *name, scm_sizet len, SCM obarray); -extern SCM scm_intern (const char *name, scm_sizet len); -extern SCM scm_intern0 (const char *name); -extern SCM scm_sysintern (const char *name, SCM val); -extern SCM scm_sysintern0 (const char *name); -extern SCM scm_sysintern0_no_module_lookup (const char *name); -extern SCM scm_symbol_value0 (const char *name); extern SCM scm_symbol_p (SCM x); extern SCM scm_symbol_to_string (SCM s); extern SCM scm_string_to_symbol (SCM s); -extern SCM scm_string_to_obarray_symbol (SCM o, SCM s, SCM softp); -extern SCM scm_intern_symbol (SCM o, SCM s); -extern SCM scm_unintern_symbol (SCM o, SCM s); -extern SCM scm_symbol_binding (SCM o, SCM s); -extern SCM scm_symbol_interned_p (SCM o, SCM s); -extern SCM scm_symbol_bound_p (SCM o, SCM s); -extern SCM scm_symbol_set_x (SCM o, SCM s, SCM v); + extern SCM scm_symbol_fref (SCM s); extern SCM scm_symbol_pref (SCM s); extern SCM scm_symbol_fset_x (SCM s, SCM val); extern SCM scm_symbol_pset_x (SCM s, SCM val); + extern SCM scm_symbol_hash (SCM s); -extern SCM scm_builtin_bindings (void); extern SCM scm_gensym (SCM prefix); -extern SCM scm_gentemp (SCM prefix, SCM obarray); + extern void scm_symbols_prehistory (void); extern void scm_init_symbols (void); @@ -141,6 +124,34 @@ extern void scm_init_symbols (void); #endif /* SCM_DEBUG_DEPRECATED == 0 */ +#if SCM_ENABLE_VCELLS + +extern SCM scm_sym2vcell (SCM sym, SCM thunk, SCM definep); +extern SCM scm_sym2ovcell_soft (SCM sym, SCM obarray); +extern SCM scm_sym2ovcell (SCM sym, SCM obarray); +extern SCM scm_intern_obarray_soft (const char *name, scm_sizet len, SCM obarray, unsigned int softness); +extern SCM scm_intern_obarray (const char *name, scm_sizet len, SCM obarray); +extern SCM scm_intern (const char *name, scm_sizet len); +extern SCM scm_intern0 (const char *name); +extern SCM scm_sysintern (const char *name, SCM val); +extern SCM scm_sysintern0 (const char *name); +extern SCM scm_sysintern0_no_module_lookup (const char *name); +extern SCM scm_symbol_value0 (const char *name); + +extern SCM scm_string_to_obarray_symbol (SCM o, SCM s, SCM softp); +extern SCM scm_intern_symbol (SCM o, SCM s); +extern SCM scm_unintern_symbol (SCM o, SCM s); +extern SCM scm_symbol_binding (SCM o, SCM s); +extern SCM scm_symbol_interned_p (SCM o, SCM s); +extern SCM scm_symbol_bound_p (SCM o, SCM s); +extern SCM scm_symbol_set_x (SCM o, SCM s, SCM v); + +extern SCM scm_gentemp (SCM prefix, SCM obarray); + +extern void scm_init_symbols_deprecated (void); + +#endif /* SCM_ENABLE_VCELLS */ + #endif /* SYMBOLSH */ /* diff --git a/libguile/tag.c b/libguile/tag.c index 511d1d69f..e69de29bb 100644 --- a/libguile/tag.c +++ b/libguile/tag.c @@ -1,108 +0,0 @@ -/* Copyright (C) 1996, 1997, 2000 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 - * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ - -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ - - -#include "libguile/_scm.h" -#include "libguile/chars.h" -#include "libguile/struct.h" - -#include "libguile/tag.h" - - -#define CONST_INUM(c_name, scheme_name, value) \ -SCM_VCELL_INIT(c_name, scheme_name, SCM_MAKINUM (value)) - -CONST_INUM (scm_utag_immediate_integer, "utag_immediate_integer", 0); -CONST_INUM (scm_utag_immediate_char, "utag_immediate_char", 1); -CONST_INUM (scm_utag_pair, "utag_pair", 2); -CONST_INUM (scm_utag_closure, "utag_closure", 3); -CONST_INUM (scm_utag_symbol, "utag_symbol", 4); -CONST_INUM (scm_utag_vector, "utag_vector", 5); -CONST_INUM (scm_utag_wvect, "utag_wvect", 6); - -#ifdef HAVE_ARRAYS -CONST_INUM (scm_utag_bvect, "utag_bvect", 7); -CONST_INUM (scm_utag_byvect, "utag_byvect", 8); -CONST_INUM (scm_utag_svect, "utag_svect", 9); -CONST_INUM (scm_utag_ivect, "utag_ivect", 10); -CONST_INUM (scm_utag_uvect, "utag_uvect", 11); -CONST_INUM (scm_utag_fvect, "utag_fvect", 12); -CONST_INUM (scm_utag_dvect, "utag_dvect", 13); -CONST_INUM (scm_utag_cvect, "utag_cvect", 14); -#endif - -CONST_INUM (scm_utag_string, "utag_string", 15); -CONST_INUM (scm_utag_substring, "utag_substring", 17); -CONST_INUM (scm_utag_asubr, "utag_asubr", 19); -CONST_INUM (scm_utag_subr_0, "utag_subr_0", 20); -CONST_INUM (scm_utag_subr_1, "utag_subr_1", 21); -CONST_INUM (scm_utag_cxr, "utag_cxr", 22); -CONST_INUM (scm_utag_subr_3, "utag_subr_3", 23); -CONST_INUM (scm_utag_subr_2, "utag_subr_2", 24); -CONST_INUM (scm_utag_rpsubr, "utag_rpsubr", 25); -CONST_INUM (scm_utag_subr_1o, "utag_subr_1o", 26); -CONST_INUM (scm_utag_subr_2o, "utag_subr_2o", 27); -CONST_INUM (scm_utag_lsubr_2, "utag_lsubr_2", 28); -CONST_INUM (scm_utag_lsubr, "utag_lsubr", 29); -CONST_INUM (scm_utag_smob_base, "utag_smob_base", 252); -CONST_INUM (scm_utag_port_base, "utag_port_base", 253); -CONST_INUM (scm_utag_flag_base, "utag_flag_base", 254); -CONST_INUM (scm_utag_struct_base, "utag_struct_base", 255); - - - -void -scm_init_tag () -{ -#ifndef SCM_MAGIC_SNARFER -#include "libguile/tag.x" -#endif -} - - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ diff --git a/libguile/throw.c b/libguile/throw.c index 8be37a006..b1f945602 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -292,13 +292,13 @@ scm_internal_lazy_catch (SCM tag, scm_catch_body_t body, void *body_data, scm_ca /* scm_internal_stack_catch Use this one if you want debugging information to be stored in - scm_the_last_stack_fluid on error. */ + scm_the_last_stack_fluid_var on error. */ static SCM ss_handler (void *data, SCM tag, SCM throw_args) { /* Save the stack */ - scm_fluid_set_x (SCM_CDR (scm_the_last_stack_fluid), + scm_fluid_set_x (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var), scm_make_stack (SCM_BOOL_T, SCM_EOL)); /* Throw the error */ return scm_throw (tag, throw_args); diff --git a/libguile/variable.c b/libguile/variable.c index 064744f73..4c0ad5a04 100644 --- a/libguile/variable.c +++ b/libguile/variable.c @@ -49,6 +49,7 @@ #include "libguile/ports.h" #include "libguile/root.h" #include "libguile/smob.h" +#include "libguile/deprecation.h" #include "libguile/validate.h" #include "libguile/variable.h" @@ -60,16 +61,8 @@ variable_print (SCM exp, SCM port, scm_print_state *pstate) { scm_puts ("#', port); return 1; } @@ -77,55 +70,40 @@ variable_print (SCM exp, SCM port, scm_print_state *pstate) static SCM variable_equalp (SCM var1, SCM var2) { - return scm_equal_p (SCM_VARVCELL (var1), SCM_VARVCELL (var2)); + return scm_equal_p (SCM_VARIABLE_REF (var1), SCM_VARIABLE_REF (var2)); } -SCM_SYMBOL (anonymous_variable_sym, "anonymous-variable"); - +#if SCM_ENABLE_VCELLS +SCM_SYMBOL (sym_huh, "???"); +#endif static SCM -make_vcell_variable (SCM vcell) +make_variable (SCM init) { - SCM_RETURN_NEWSMOB (scm_tc16_variable, SCM_UNPACK (vcell)); +#if !SCM_ENABLE_VCELLS + SCM_RETURN_NEWSMOB (scm_tc16_variable, SCM_UNPACK (init)); +#else + SCM_RETURN_NEWSMOB (scm_tc16_variable, scm_cons (sym_huh, init)); +#endif } -SCM_DEFINE (scm_make_variable, "make-variable", 1, 1, 0, - (SCM init, SCM name_hint), - "Return a variable object initialized to value @var{init}.\n" - "If given, uses @var{name-hint} as its internal (debugging)\n" - "name, otherwise just treat it as an anonymous variable.\n" - "Remember, of course, that multiple bindings to the same\n" - "variable may exist, so @var{name-hint} is just that---a hint.\n") +SCM_DEFINE (scm_make_variable, "make-variable", 1, 0, 0, + (SCM init), + "Return a variable initialized to value @var{init}.\n") #define FUNC_NAME s_scm_make_variable { - SCM vcell; - - if (SCM_UNBNDP (name_hint)) - name_hint = anonymous_variable_sym; - - vcell = scm_cons (name_hint, init); - return make_vcell_variable (vcell); + return make_variable (init); } #undef FUNC_NAME -SCM_DEFINE (scm_make_undefined_variable, "make-undefined-variable", 0, 1, 0, - (SCM name_hint), - "Return a variable object initialized to an undefined value.\n" - "If given, uses @var{name-hint} as its internal (debugging)\n" - "name, otherwise just treat it as an anonymous variable.\n" - "Remember, of course, that multiple bindings to the same\n" - "variable may exist, so @var{name-hint} is just that---a hint.\n") +SCM_DEFINE (scm_make_undefined_variable, "make-undefined-variable", 0, 0, 0, + (), + "Return a variable that is initially unbound.\n") #define FUNC_NAME s_scm_make_undefined_variable { - SCM vcell; - - if (SCM_UNBNDP (name_hint)) - name_hint = anonymous_variable_sym; - - vcell = scm_cons (name_hint, SCM_UNDEFINED); - return make_vcell_variable (vcell); + return make_variable (SCM_UNDEFINED); } #undef FUNC_NAME @@ -148,13 +126,15 @@ SCM_DEFINE (scm_variable_ref, "variable-ref", 1, 0, 0, "and @code{make-undefined-variable}.") #define FUNC_NAME s_scm_variable_ref { + SCM val; SCM_VALIDATE_VARIABLE (1, var); - return SCM_CDR (SCM_VARVCELL (var)); + val = SCM_VARIABLE_REF (var); + if (val == SCM_UNDEFINED) + SCM_MISC_ERROR ("variable is unbound: ~S", SCM_LIST1 (var)); + return val; } #undef FUNC_NAME - - SCM_DEFINE (scm_variable_set_x, "variable-set!", 2, 0, 0, (SCM var, SCM val), "Set the value of the variable @var{var} to @var{val}.\n" @@ -163,41 +143,11 @@ SCM_DEFINE (scm_variable_set_x, "variable-set!", 2, 0, 0, #define FUNC_NAME s_scm_variable_set_x { SCM_VALIDATE_VARIABLE (1, var); - SCM_SETCDR (SCM_VARVCELL (var), val); + SCM_VARIABLE_SET (var, val); return SCM_UNSPECIFIED; } #undef FUNC_NAME - -SCM_DEFINE (scm_builtin_variable, "builtin-variable", 1, 0, 0, - (SCM name), - "Return the built-in variable with the name @var{name}.\n" - "@var{name} must be a symbol (not a string).\n" - "Then use @code{variable-ref} to access its value.\n") -#define FUNC_NAME s_scm_builtin_variable -{ - SCM vcell; - SCM var_slot; - - SCM_VALIDATE_SYMBOL (1,name); - vcell = scm_sym2vcell (name, SCM_BOOL_F, SCM_BOOL_T); - if (SCM_FALSEP (vcell)) - return SCM_BOOL_F; - - scm_intern_symbol (scm_symhash_vars, name); - var_slot = scm_sym2ovcell (name, scm_symhash_vars); - - SCM_DEFER_INTS; - if (SCM_IMP (SCM_CDR (var_slot)) - || !SCM_EQ_P (SCM_VARVCELL (var_slot), vcell)) - SCM_SETCDR (var_slot, make_vcell_variable (vcell)); - SCM_ALLOW_INTS; - - return SCM_CDR (var_slot); -} -#undef FUNC_NAME - - SCM_DEFINE (scm_variable_bound_p, "variable-bound?", 1, 0, 0, (SCM var), "Return @code{#t} iff @var{var} is bound to a value.\n" @@ -205,12 +155,41 @@ SCM_DEFINE (scm_variable_bound_p, "variable-bound?", 1, 0, 0, #define FUNC_NAME s_scm_variable_bound_p { SCM_VALIDATE_VARIABLE (1, var); - return SCM_BOOL (!SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (var)))); + return SCM_BOOL (SCM_VARIABLE_REF (var) != SCM_UNDEFINED); } #undef FUNC_NAME +SCM_DEFINE (scm_variable_set_name_hint, "variable-set-name-hint!", 2, 0, 0, + (SCM var, SCM hint), + "Do not use this function.") +#define FUNC_NAME s_scm_variable_set_name_hint +{ + SCM_VALIDATE_VARIABLE (1, var); + SCM_VALIDATE_SYMBOL (2, hint); +#if SCM_ENABLE_VCELLS + SCM_SETCAR (SCM_SMOB_DATA (var), hint); +#endif + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME +#if SCM_ENABLE_VCELLS +SCM_DEFINE (scm_builtin_variable, "builtin-variable", 1, 0, 0, + (SCM name), + "Return the built-in variable with the name @var{name}.\n" + "@var{name} must be a symbol (not a string).\n" + "Then use @code{variable-ref} to access its value.\n") +#define FUNC_NAME s_scm_builtin_variable +{ + SCM_VALIDATE_SYMBOL (1,name); + scm_c_issue_deprecation_warning ("`builtin-variable' is deprecated. " + "Use module system operations instead."); + return scm_sym2var (name, SCM_BOOL_F, SCM_BOOL_T); +} +#undef FUNC_NAME + +#endif /* SCM_ENABLE_VCELLS */ void scm_init_variable () @@ -225,7 +204,6 @@ scm_init_variable () #endif } - /* Local Variables: c-file-style: "gnu" diff --git a/libguile/variable.h b/libguile/variable.h index f5fc686ed..f899658a4 100644 --- a/libguile/variable.h +++ b/libguile/variable.h @@ -47,6 +47,7 @@ gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" +#include "libguile/smob.h" @@ -55,20 +56,35 @@ */ extern scm_bits_t scm_tc16_variable; -#define SCM_VARVCELL(V) SCM_CELL_OBJECT_1 (V) -#define SCM_VARIABLEP(X) (!SCM_IMP (X) && SCM_CELL_TYPE (X) == scm_tc16_variable) -#define SCM_UDVARIABLEP(X) (SCM_VARIABLEP(X) && SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X)))) -#define SCM_DEFVARIABLEP(X) (SCM_VARIABLEP(X) && !SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X)))) +#define SCM_VARIABLEP(X) SCM_SMOB_PREDICATE (scm_tc16_variable, X) + +#if !SCM_ENABLE_VCELLS +#define SCM_VARIABLE_REF(V) SCM_CELL_OBJECT_1(V) +#define SCM_VARIABLE_SET(V,X) SCM_SET_CELL_OBJECT_1 (V, X) +#define SCM_VARIABLE_LOC(V) ((SCM *) SCM_CELL_WORD_LOC ((V), 1)) +#else +#define SCM_VARVCELL(V) SCM_CELL_OBJECT_1(V) +#define SCM_UDVARIABLEP(X) (SCM_VARIABLEP(X) && SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X)))) +#define SCM_DEFVARIABLEP(X) (SCM_VARIABLEP(X) && !SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X)))) + +#define SCM_VARIABLE_REF(V) SCM_CDR(SCM_VARVCELL(V)) +#define SCM_VARIABLE_SET(V,X) SCM_SETCDR(SCM_VARVCELL(V),X) +#define SCM_VARIABLE_LOC(V) SCM_CDRLOC(SCM_VARVCELL(V)) +#endif -extern SCM scm_make_variable (SCM init, SCM name_hint); -extern SCM scm_make_undefined_variable (SCM name_hint); +extern SCM scm_make_variable (SCM init); +extern SCM scm_make_undefined_variable (void); extern SCM scm_variable_p (SCM obj); extern SCM scm_variable_ref (SCM var); extern SCM scm_variable_set_x (SCM var, SCM val); -extern SCM scm_builtin_variable (SCM name); extern SCM scm_variable_bound_p (SCM var); +extern SCM scm_variable_set_name_hint (SCM var, SCM hint); +#if SCM_ENABLE_VCELLS +extern SCM scm_builtin_variable (SCM name); +#endif + extern void scm_init_variable (void); #endif /* SCM_VARIABLE_H */ From 296ff5e78b8322fe4bf00c5ec1497dc28da776b8 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 15 May 2001 14:59:42 +0000 Subject: [PATCH 1083/2047] Merged from mvo-vcell-cleanup-1-branch. --- guile-readline/readline.c | 4 +- ice-9/boot-9.scm | 138 +++++++++++++++++++------------------- ice-9/debug.scm | 3 +- ice-9/format.scm | 2 +- ice-9/optargs.scm | 32 ++------- ice-9/session.scm | 28 +++----- oop/goops/compile.scm | 4 +- 7 files changed, 90 insertions(+), 121 deletions(-) diff --git a/guile-readline/readline.c b/guile-readline/readline.c index 565c264ad..35c332fd6 100644 --- a/guile-readline/readline.c +++ b/guile-readline/readline.c @@ -397,7 +397,7 @@ SCM scm_readline_completion_function_var; static char * completion_function (char *text, int continuep) { - SCM compfunc = SCM_CDR (scm_readline_completion_function_var); + SCM compfunc = SCM_VARIABLE_REF (scm_readline_completion_function_var); SCM res; if (SCM_FALSEP (compfunc)) @@ -542,7 +542,7 @@ scm_init_readline () #ifdef HAVE_RL_GETC_FUNCTION #include "guile-readline/readline.x" scm_readline_completion_function_var - = scm_sysintern ("*readline-completion-function*", SCM_BOOL_F); + = scm_c_define ("*readline-completion-function*", SCM_BOOL_F); rl_getc_function = current_input_getc; rl_redisplay_function = redisplay; rl_completion_entry_function = (Function*) completion_function; diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 1f87908fa..92ad0c776 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1250,7 +1250,8 @@ (and (module-binder m) ((module-binder m) m v #t)) (begin - (let ((answer (make-undefined-variable v))) + (let ((answer (make-undefined-variable))) + (variable-set-name-hint! answer v) (module-obarray-set! (module-obarray m) v answer) (module-modified m) answer)))) @@ -1313,43 +1314,28 @@ ;; make-root-module -;; A root module uses the symhash table (the system's privileged -;; obarray). Being inside a root module is like using SCM without -;; any module system. +;; A root module uses the pre-modules-obarray as its obarray. This +;; special obarray accumulates all bindings that have been established +;; before the module system is fully booted. ;; - - -(define (root-module-closure m s define?) - (let ((bi (builtin-variable s))) - (and bi - (or define? (variable-bound? bi)) - (begin - (module-add! m s bi) - bi)))) +;; (The obarray continues to be used by code that has been closed over +;; before the module system has been booted.) (define (make-root-module) - (make-module 1019 '() root-module-closure)) + (let ((m (make-module 0))) + (set-module-obarray! m (%get-pre-modules-obarray)) + m)) +;; make-scm-module -;; make-scm-module - -;; An scm module is a module into which the lazy binder copies -;; variable bindings from the system symhash table. The mapping is -;; one way only; newly introduced bindings in an scm module are not -;; copied back into the system symhash table (and can be used to override -;; bindings from the symhash table). -;; - -(define (scm-module-closure m s define?) - (let ((bi (builtin-variable s))) - (and bi - (variable-bound? bi) - (begin - (module-add! m s bi) - bi)))) +;; The root interface is a module that uses the same obarray as the +;; root module. It does not allow new definitions, tho. (define (make-scm-module) - (make-module 1019 '() scm-module-closure)) + (let ((m (make-module 0))) + (set-module-obarray! m (%get-pre-modules-obarray)) + (set-module-eval-closure! m (standard-interface-eval-closure m)) + m)) @@ -1422,7 +1408,9 @@ (begin (variable-set! variable value) (module-modified module)) - (module-add! module name (make-variable value name))))) + (let ((variable (make-variable value))) + (variable-set-name-hint! variable name) + (module-add! module name variable))))) ;; MODULE-DEFINED? -- exported ;; @@ -1539,18 +1527,33 @@ (set-module-kind! the-scm-module 'interface) (for-each set-system-module! (list the-root-module the-scm-module) '(#t #t)) -(set-current-module the-root-module) +;; NOTE: This binding is used in libguile/modules.c. +;; +(define (make-modules-in module name) + (if (null? name) + module + (cond + ((module-ref module (car name) #f) + => (lambda (m) (make-modules-in m (cdr name)))) + (else (let ((m (make-module 31))) + (set-module-kind! m 'directory) + (set-module-name! m (append (or (module-name module) + '()) + (list (car name)))) + (module-define! module (car name) m) + (make-modules-in m (cdr name))))))) -(define app (make-module 31)) -(local-define '(app modules) (make-module 31)) -(local-define '(app modules guile) the-root-module) - -;; (define-special-value '(app modules new-ws) (lambda () (make-scm-module))) - -(define (try-load-module name) - (or (try-module-linked name) - (try-module-autoload name) - (try-module-dynamic-link name))) +(define (beautify-user-module! module) + (let ((interface (module-public-interface module))) + (if (or (not interface) + (eq? interface module)) + (let ((interface (make-module 31))) + (set-module-name! interface (module-name module)) + (set-module-kind! interface 'interface) + (set-module-public-interface! module interface)))) + (if (and (not (memq the-scm-module (module-uses module))) + (not (eq? module the-root-module))) + (set-module-uses! module (append (module-uses module) (list the-scm-module))))) ;; NOTE: This binding is used in libguile/modules.c. ;; @@ -1574,18 +1577,24 @@ ;; Get/create it. (make-modules-in (current-module) full-name)))))) -(define (beautify-user-module! module) - (let ((interface (module-public-interface module))) - (if (or (not interface) - (eq? interface module)) - (let ((interface (make-module 31))) - (set-module-name! interface (module-name module)) - (set-module-kind! interface 'interface) - (set-module-public-interface! module interface)))) - (if (and (not (memq the-scm-module (module-uses module))) - (not (eq? module the-root-module))) - (set-module-uses! module (append (module-uses module) - (list the-scm-module))))) +;; Cheat. +(define try-module-autoload #f) + +;; This boots the module system. All bindings needed by modules.c +;; must have been defined by now. +;; +(set-current-module the-root-module) + +(define app (make-module 31)) +(local-define '(app modules) (make-module 31)) +(local-define '(app modules guile) the-root-module) + +;; (define-special-value '(app modules new-ws) (lambda () (make-scm-module))) + +(define (try-load-module name) + (or (try-module-linked name) + (try-module-autoload name) + (try-module-dynamic-link name))) (define (purify-module! module) "Removes bindings in MODULE which are inherited from the (guile) module." @@ -1594,21 +1603,10 @@ (eq? (car (last-pair use-list)) the-scm-module)) (set-module-uses! module (reverse (cdr (reverse use-list))))))) -;; NOTE: This binding is used in libguile/modules.c. -;; -(define (make-modules-in module name) - (if (null? name) - module - (cond - ((module-ref module (car name) #f) - => (lambda (m) (make-modules-in m (cdr name)))) - (else (let ((m (make-module 31))) - (set-module-kind! m 'directory) - (set-module-name! m (append (or (module-name module) - '()) - (list (car name)))) - (module-define! module (car name) m) - (make-modules-in m (cdr name))))))) +(define (resolve-interface name) + (let ((module (resolve-module name))) + (and module (module-public-interface module)))) + ;; Return a module interface made from SPEC. ;; SPEC can be a list of symbols, in which case it names a module diff --git a/ice-9/debug.scm b/ice-9/debug.scm index d99e79682..04043a13e 100644 --- a/ice-9/debug.scm +++ b/ice-9/debug.scm @@ -109,7 +109,8 @@ ;;; A fix to get the error handling working together with the module system. ;;; -(variable-set! (builtin-variable 'debug-options) debug-options) +;;; XXX - Still needed? +(module-set! the-root-module 'debug-options debug-options) diff --git a/ice-9/format.scm b/ice-9/format.scm index abd13ddab..ffc70f382 100644 --- a/ice-9/format.scm +++ b/ice-9/format.scm @@ -1704,7 +1704,7 @@ (define format format:format) ;; Thanks to Shuji Narazaki -(variable-set! (builtin-variable 'format) format) +(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. diff --git a/ice-9/optargs.scm b/ice-9/optargs.scm index 9facebf62..bf9653773 100644 --- a/ice-9/optargs.scm +++ b/ice-9/optargs.scm @@ -31,7 +31,6 @@ ;;; a convenient and attractive syntax. ;;; ;;; exported macros are: -;;; bound? ;;; let-optional ;;; let-optional* ;;; let-keywords @@ -61,36 +60,19 @@ (define-module (ice-9 optargs)) -;; bound? var -;; Checks if a variable is bound in the current environment. -;; -;; defined? doesn't quite cut it as it stands, since it only -;; checks bindings in the top-level environment, not those in -;; local scope only. -;; - -(defmacro-public bound? (var) - `(catch 'misc-error - (lambda () - ,var - (not (eq? ,var ,(variable-ref - (make-undefined-variable))))) - (lambda args #f))) - - ;; let-optional rest-arg (binding ...) . body ;; let-optional* rest-arg (binding ...) . body ;; macros used to bind optional arguments ;; -;; These two macros give you an optional argument interface that -;; is very "Schemey" and introduces no fancy syntax. They are -;; compatible with the scsh macros of the same name, but are slightly +;; These two macros give you an optional argument interface that is +;; very "Schemey" and introduces no fancy syntax. They are compatible +;; with the scsh macros of the same name, but are slightly ;; extended. Each of binding may be of one of the forms or ;; ( ). rest-arg should be the rest-argument of ;; the procedures these are used from. The items in rest-arg are ;; sequentially bound to the variable namess are given. When rest-arg ;; runs out, the remaining vars are bound either to the default values -;; or left unbound if no default value was specified. rest-arg remains +;; or to `#f' if no default value was specified. rest-arg remains ;; bound to whatever may have been left of rest-arg. ;; @@ -130,8 +112,7 @@ (let ((bindings (map (lambda (x) (if (list? x) x - (list x (variable-ref - (make-undefined-variable))))) + (list x #f))) BINDINGS))) `(,let-type ,(map proc bindings) ,@BODY))) @@ -219,8 +200,7 @@ ;; (lambda* (a b #:optional c d . e) '()) ;; creates a procedure with fixed arguments a and b, optional arguments c ;; and d, and rest argument e. If the optional arguments are omitted -;; in a call, the variables for them are unbound in the procedure. This -;; can be checked with the bound? macro. +;; in a call, the variables for them are bound to `#f'. ;; ;; lambda* can also take keyword arguments. For example, a procedure ;; defined like this: diff --git a/ice-9/session.scm b/ice-9/session.scm index 27dab6a3d..5bd404374 100644 --- a/ice-9/session.scm +++ b/ice-9/session.scm @@ -220,15 +220,9 @@ where OPTIONSET is one of debug, read, eval, print (set! value #t))) (for-each (lambda (module) - (let* ((builtin (or (eq? module the-scm-module) - (eq? module the-root-module))) - (name (module-name module)) - (obarray (if builtin - (builtin-bindings) - (module-obarray module))) - (get-ref (if builtin - identity - variable-ref))) + (let* ((name (module-name module)) + (obarray (module-obarray module))) + ;; XXX - should use hash-fold here (array-for-each (lambda (oblist) (for-each @@ -237,20 +231,19 @@ where OPTIONSET is one of debug, read, eval, print (display name) (display ": ") (display (car x)) - (cond ((procedure? (get-ref (cdr x))) + (cond ((procedure? (variable-ref (cdr x))) (display separator) - (display (get-ref (cdr x)))) + (display (variable-ref (cdr x)))) (value (display separator) - (display (get-ref (cdr x))))) + (display (variable-ref (cdr x))))) (if (and shadow (not (eq? (module-ref module (car x)) (module-ref (current-module) (car x))))) (display " shadowed")) - (newline) - ))) + (newline)))) oblist)) obarray))) modules)))) @@ -295,12 +288,7 @@ Fourth arg FOLDER is one of (module-filter (lambda (name var data) (obarray-filter name (variable-ref var) data)))) - (cond ((or (eq? module the-scm-module) - (eq? module the-root-module)) - (hash-fold obarray-filter - data - (builtin-bindings))) - (module (hash-fold module-filter + (cond (module (hash-fold module-filter data (module-obarray module))) (else data)))))) diff --git a/oop/goops/compile.scm b/oop/goops/compile.scm index 8e99733a1..024c2a886 100644 --- a/oop/goops/compile.scm +++ b/oop/goops/compile.scm @@ -114,7 +114,9 @@ (define (compile-method methods types) (let* ((proc (method-procedure (car methods))) - (src (procedure-source proc)) + ;; XXX - procedure-source can not be guaranteed to be + ;; reliable or efficient + (src (procedure-source proc)) (formals (source-formals src)) (body (source-body src))) (if (next-method? body) From f3f9dcbc5dfb329ec07e9f9b85c922517e7a3e63 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 15 May 2001 15:00:31 +0000 Subject: [PATCH 1084/2047] *** empty log message *** --- NEWS | 26 ++++++ RELEASE | 4 + guile-readline/ChangeLog | 7 ++ ice-9/ChangeLog | 38 ++++++++- libguile/ChangeLog | 166 +++++++++++++++++++++++++++++++++++++++ oop/ChangeLog | 6 ++ 6 files changed, 246 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index bedb80f45..d5ea8fb4e 100644 --- a/NEWS +++ b/NEWS @@ -660,6 +660,12 @@ If you have old code using the old syntax, import (use-modules (oop goops old-define-method) (oop goops)) +** Deprecated function: builtin-variable + Removed function: builtin-bindings + +There is no longer a distinction between builtin or other variables. +Use module system operations for all variables. + * Changes to the gh_ interface * Changes to the scm_ interface @@ -880,6 +886,26 @@ Use scm_object_to_string instead. Use scm_wrong_type_arg, or another appropriate error signalling function instead. +** Explicit support for obarrays has been deprecated. + +Use `scm_str2symbol' and the generic hashtable functions instead. + +** The concept of `vcells' has been deprecated. + +The data type `variable' is now used exclusively. `Vcells' have been +a low-level concept so you are likely not affected by this change. + +*** Deprecated functions: scm_sym2vcell, scm_sysintern, + scm_sysintern0, scm_symbol_value0, scm_intern, scm_intern0. + +Use scm_c_define or scm_c_lookup instead, as appropriate. + +*** New functions: scm_c_module_lookup, scm_c_lookup, + scm_c_module_define, scm_c_define, scm_module_lookup, scm_lookup, + scm_module_define, scm_define. + +These functions work with variables instead of with vcells. + Changes since Guile 1.3.4: diff --git a/RELEASE b/RELEASE index 09ce29aac..bb1bd4396 100644 --- a/RELEASE +++ b/RELEASE @@ -22,6 +22,10 @@ After signal handling and threading have been fixed: === In release 1.8.0: +- remove vcell and obarray support. + Remove all code bracketed by `#if SCM_ENABLE_VCELLS'. + Also remove `variable-set-name-hint' completely. + - remove compatability module (ice-9 and-let*). It has been replaced by (ice-9 and-let-star) and/or (srfi srfi-2). diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index f0c8108ae..5adbb6e54 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,10 @@ +2001-05-10 Marius Vollmer + + * readline.c (completion_function): Use SCM_VARIABLE_REF to access + scm_readline_completion_function_var. + (scm_init_readline): Use scm_c_define instead of scm_sysintern to + create scm_readline_completion_function_var. + 2001-04-09 Marius Vollmer * readline.c (scm_clear_history): New function. diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 08098d53b..1918ab2db 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,39 @@ +2001-05-10 Marius Vollmer + + Merge from mvo-vcell-clenaup-1-branch. + + * session.scm (apropos): Do not use `builtin-bindings', always use + the module obarray. + (apropos-fold): Likewise. + + * optargs.scm (bound?): Removed. We should not play games with + the magical undefined value. + (let-o-k-template): Use `#f' instead of the undefined value as + the default default for bindings. + + * boot-9.scm (module-make-local-var!): Do not pass name hint to + make-undefined-variable, use `variable-set-name-hint!' instead. + (root-module-closure): Removed. + (make-root-module): Set the obarray of the module to the + `pre-modules-obarray'. Do not use a lazy binder. + (scm-module-closure): Removed. + (make-root-module): Set the obarray of the module to the + `pre-modules-obarray'. Do not use a lazy binder. Set the + eval-closure to a `standard-interface-eval-closure'. + (module-define!): Do not pass name hint to make-variable, use + `variable-set-name-hint!' instead. + (make-modules-in, beautify-user-module, resolve-module): Moved + towards the beginning of boot-9.scm, across the call to + set-current-module that boots the module system. These + definitions need to be visible at the time of the first + `set-current-module' call. + (try-module-autoload): Define a `#f' before the call to + set-current-module. It is redefined later. + + * debug.scm: Use `module-set!' instead of `variable-set!' to set + insert `debug-options' into the-root-module. + * format.scm: Likewise, for `format'. + 2001-05-15 Marius Vollmer * boot-9.scm (error-catching-repl): Call the E @@ -23,7 +59,7 @@ * boot-9.scm (resolve-module): Abstraction maintenance: Use `module-public-interface'. - (resolve-module): Extend to handle selection and renaming in spec. + (resolve-interface): Extend to handle selection and renaming in spec. Arg is now `spec' which can be a simple module name (list of symbols) or a interface spec. (symbol-prefix-proc): New proc. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index ea0440f89..173be0295 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,169 @@ +2001-05-10 Marius Vollmer + + Merge from mvo-vcell-clenaup-1-branch. + + The concept of vcells has been removed from Guile. With it, + explicit obarrays and associated operations are gone. Use + hashtables instead of obarrays. + + Throughout: use scm_sym2var instead of scm_sym2vcell and treat + result as variable instead of vcell. Glocs no longer point to a + vcell but to a variable. Use scm_c_define instead of + scm_sysintern and treat the result as a variable (which it is), + not a vcell. + + * variable.c, variable.h (SCM_VARVCELL, SCM_UDVARIABLEP, + SCM_DEFVARIABLEP): Deprecated. + (SCM_VARIABLE_REF, SCM_VARIABLE_SET, SCM_VARIABLE_LOC): New. + (variable_print): Do not print name of variable. + (variable_equalp): Compare values, not vcells. + (anonymous_variable_sym): Removed. + (make_vcell_variable): Removed. + (make_variable): New, as replacement. + (scm_make_variable, scm_make_undefined_variable): Do not take name + hint parameter. + (scm_variable_ref): Check for SCM_UNDEFINED and throw "unbound" + error in that case. + (scm_builtin_variable): Deprecated. + + * symbols.c, symbols.h (scm_sym2vcell, scm_sym2ovcell_soft, + scm_sym2ovcell, scm_intern_obarray_soft, scm_intern_obarray, + scm_intern, scm_intern0, scm_sysintern0_no_module_lookup, + scm_sysintern, scm_sysintern0, scm_symbol_value0, + scm_string_to_obarray_symbol, scm_intern_symbol, + scm_unintern_symbol, scm_symbol_binding, scm_symbol_interned, + scm_symbol_bound_p, scm_symbol_set_x, scm_gentmp, gentmp_counter): + Deprecated and moved to "symbols-deprecated.c". + (copy_and_prune_obarray, scm_builtin_bindings): Removed. + (scm_init_symbols): Call scm_init_symbols_deprecated. + * symbols-deprecated.c: New file. + * Makefile.am: Added symbols-deprecated.c and related files in all + the right places. + + * snarf.h (SCM_VCELL, SCM_GLOBAL_VCELL, SCM_VCELL_INIT, + SCM_GLOBAL_VCELL_INIT): Deprecated. + (SCM_VARIABLE, SCM_GLOBAL_VARIABLE, SCM_VARIABLE_INIT, + SCM_GLOBAL_VARIABLE_INIT): New, as replacement. Changed all uses. + + * print.c (scm_iprin1): Use scm_module_reverse_lookup instead of + SCM_GLOC_SYM. + + * evalext.c, filesys.c, fports.c, gdbint.c, gh_data.c, gsubr.c, + hooks.c, load.c, numbers.c, objects.c, ports.c, posix.c, procs.c, + ramap.c, random.c, read.c, regex-posix.c, scmsigs.c, script.c, + socket.c, srcprop.c, stacks.c, stime.c, struct.c, tag.c, throw.c: + Changed according to the `throughout' comments. + + * modules.h, modules.c (scm_module_system_booted_p): Changed type + to `int'. + (scm_module_type): Removed. + (the_root_module): Renamed to the_root_module_var. Now points to + a variable instead of a vcell. Updated all uses. + (scm_the_root_module): Return SCM_BOOL_F when module systems + hasn't been booted yet. + (SCM_VALIDATE_STRUCT_TYPE): Removed. + (scm_post_boot_init_modules): Made static. + (scm_set_current_module): Call scm_post_boot_init_modules on first + call. + (make_modules_in, beautify_user_module_x, resolve_module, + try_module_autoload, module_make_local_var_x): Tacked on "_var" + suffix. Now point to variables instead of vcells. Updated all + uses. + (scm_module_lookup_closure): Deal with the module being SCM_BOOL_F + and return SCM_BOOL_F in that case. + (scm_module_transformer): Likewise. + (sym_module, scm_lookup_closure_module, scm_env_module): New. + (SCM_F_EVAL_CLOSURE_INTERFACE, SCM_EVAL_CLOSURE_INTERFACE_P): New. + (scm_eval_closure_lookup): Do not allow new definitions when + `interface' flag is set. + (scm_standard_interface_eval_closure): New. + (scm_pre_modules_obarray, scm_sym2var, scm_module_lookup, + scm_lookup, scm_module_define, scm_define, scm_c_module_lookup, + scm_c_lookup, scm_c_module_define, scm_c_define, + scm_module_reverse_lookup, scm_get_pre_modules_obarray, + scm_modules_prehistory): New. + (scm_post_boot_init_modules): Use scm_c_define and scm_c_lookup + instead of scm_intern0. + + * macros.c (scm_make_synt): Return SCM_UNSPECIFIED instead of the + symbol. + + * keywords.c (s_scm_make_keyword_from_dash_symbol): Use a regular + hashtable operations to maintain the keywords, not obarray ones. + + * init.c (scm_load_startup_files): Do not call + scm_post_boot_init_modules. This is done by + scm_set_current_module now. + (scm_init_guile_1): Call scm_modules_prehistory. Call + scm_init_variable early on. + + * goops.c (s_scm_sys_goops_loaded): Get + var_compute_applicable_methods from scm_sym2var, not from a direct + invocation of scm_goops_lookup_closure. + + * gh_funcs.c (gh_define): Return SCM_UNSPECIFIED instead of vcell. + + * gc.c: Added simple debugging hack to mark phase of GC: When + activated, do not tail-call scm_gc_mark. This gives nice + backtraces. + (scm_unhash_name): Removed. + + * feature.c (features): Renamed to features_var. Now points to a + variable instead of a vcell. Updated all uses. + + * eval.h (SCM_TOP_LEVEL_LOOKUP_CLOSURE): Use + `scm_current_module_lookup_closure' which will do the right thing + when the module system hasn't been booted yet. + (SCM_GLOC_SYM): Removed. + (SCM_GLOC_VAR, SCM_GLOC_SET_VAL): New. + (SCM_GLOC_VAL, SCM_GLOC_LOC): Reimplemented in terms of variables. + + * eval.c (scm_lookupcar, scm_lookupcar1): Deal with variables + instead of with vcells. Do not overwrite `var' with the result of + the lookup, use the new `real_var' instead. Remove `var2' in + exchange (which was only used with threads). + (sym_three_question_marks): New. + (scm_unmemocar): Use `scm_module_reverse_lookup' instead of + `SCM_GLOC_SYM'. + (scm_lisp_nil, scm_lisp_t): Directly define as symbols. + (scm_m_atfop): Expect the function definition to be a variable + instead of a vcell. + (scm_macroexp): Do not use `unmemocar', explicitely remember the + symbol instead. + (scm_unmemocopy): Removed thoughts about anti-macro interface. + (scm_eval_args): Use more explicit code in the gloc branch of the + atrocious struct ambiguity test. The optimizer will sort this + out. + (scm_deval_args): Likewise. + (SCM_CEVAL): Likewise. Also, do not use unmemocar, explicitely + remember the symbol instead. Added some comments where + scm_tc3_cons_gloc really exclusively refers to structs. + (scm_init_eval): Use scm_define to initialize "nil" and "t" to + scm_lisp_nil and scm_lisp_t, respectively. Use scm_define instead + of scm_sysintern in general. + + * dynwind.c (scm_swap_bindings): Use SCM_GLOC_SET_VAL instead of + explicit magic. + + * debug.c (s_scm_make_gloc): Only allow proper variables, no + pairs. Put the variable directly in the gloc. + (s_scm_gloc_p): Use `scm_tc3_cons_gloc' instead of the magic `1'. + (scm_init_debug): Use scm_c_define instead scm_sysintern. + + * cpp_cnvt.awk: Emit "scm_c_define" instead of "scm_sysintern". + + * backtrace.h, backtrace.c (scm_the_last_stack_fluid): Renamed to + scm_the_last_stack_fluid_var. It now points to a variable instead + of a vcell. Updated all uses. + (scm_has_shown_backtrace_hint_p_var): Now points to a variable + instead of a vcell. Updated all uses. + + * _scm.h: Include "variables.h" and "modules.h" since almost + everybody needs them now. + + * root.h (scm_symhash, scm_symhash_vars): Removed. + * gc.c (scm_init_storage): Do not initialize them. + 2001-05-15 Dirk Herrmann * eval.c (scm_init_eval): Initialize scm_undefineds and diff --git a/oop/ChangeLog b/oop/ChangeLog index 6c4a8e6a9..b4c27c788 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -1,3 +1,9 @@ +2001-05-10 Marius Vollmer + + * goops/compile.scm (compile-method): Insert comment that + `procedure-source' can not be guaranteed to be reliable or + efficient. + 2001-05-05 Marius Vollmer * goops.scm (initialize-object-procedure): Use From b622dec7533df56bcd4c26ac13bdcd11501c6c62 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 15 May 2001 19:33:43 +0000 Subject: [PATCH 1085/2047] (resolve-interface): Signal error now also if used module's public interface is not available. No longer call `beautify-user-module!'. Signal error now also if selected binding not found. --- ice-9/boot-9.scm | 69 ++++++++++++++++++++++++++---------------------- 1 file changed, 37 insertions(+), 32 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 92ad0c776..94ea5042d 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1326,7 +1326,7 @@ (set-module-obarray! m (%get-pre-modules-obarray)) m)) -;; make-scm-module +;; make-scm-module ;; The root interface is a module that uses the same obarray as the ;; root module. It does not allow new definitions, tho. @@ -1626,41 +1626,46 @@ ;; returned interface has no bindings. If the `:select' clause is omitted, ;; RENAMER operates on the used module's public interface. ;; -;; Signal error if module name is not resolvable. +;; Signal "no code for module" error if module name is not resolvable or its +;; public interface is not available. Signal "no binding" error if selected +;; binding does not exist in the used module. ;; (define (resolve-interface spec) (let* ((simple? (not (pair? (car spec)))) (name (if simple? spec (car spec))) - (module (resolve-module name))) - (if (not module) - (error "no code for module" name) - (let ((public-i (module-public-interface module))) - (cond ((not public-i) - (beautify-user-module! module) - (set! public-i (module-public-interface module)))) - (if simple? - public-i - (let ((selection (cond ((memq ':select spec) => cadr) - (else (module-map (lambda (sym var) sym) - public-i)))) - (rename (cond ((memq ':rename spec) - => (lambda (x) - (eval (cadr x) (current-module)))) - (else identity))) - (partial-i (make-module 31))) - (set-module-kind! partial-i 'interface) - (for-each (lambda (sel-spec) - (let* ((direct? (symbol? sel-spec)) - (orig (if direct? - sel-spec - (car sel-spec))) - (seen (if direct? - sel-spec - (cdr sel-spec)))) - (module-add! partial-i (rename seen) - (module-variable module orig)))) - selection) - partial-i)))))) + (module (resolve-module name)) + (public-i (and module (module-public-interface module)))) + (and (or (not module) (not public-i)) + (error "no code for module" name)) + (if simple? + public-i + (let ((selection (cond ((memq ':select spec) => cadr) + (else (module-map (lambda (sym var) sym) + public-i)))) + (rename (cond ((memq ':rename spec) + => (lambda (x) + ;; fixme:ttn -- move to macroexpansion time + (eval (cadr x) (current-module)))) + (else identity))) + (custom-i (make-module 31))) + (set-module-kind! custom-i 'interface) + (for-each (lambda (sel-spec) + (let* ((direct? (symbol? sel-spec)) + (orig (if direct? + sel-spec + (car sel-spec))) + (seen (if direct? + sel-spec + (cdr sel-spec)))) + (module-add! custom-i (rename seen) + (or (module-local-variable module orig) + (error + ;; fixme: format manually for now + (simple-format + #f "no binding `~A' in module ~A" + orig name)))))) + selection) + custom-i)))) (define (symbol-prefix-proc prefix) (lambda (symbol) From 7dfc3d0f56f7883b6bd12acf36bc8c16fc2712fc Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 15 May 2001 19:38:57 +0000 Subject: [PATCH 1086/2047] *** empty log message *** --- ice-9/ChangeLog | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 1918ab2db..c246c5854 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,7 +1,14 @@ +2001-05-15 Thien-Thi Nguyen + + * boot-9.scm (resolve-interface): Signal error now also if + used module's public interface is not available. + No longer call `beautify-user-module!'. + Signal error now also if selected binding not found. + 2001-05-10 Marius Vollmer Merge from mvo-vcell-clenaup-1-branch. - + * session.scm (apropos): Do not use `builtin-bindings', always use the module obarray. (apropos-fold): Likewise. @@ -10,7 +17,7 @@ the magical undefined value. (let-o-k-template): Use `#f' instead of the undefined value as the default default for bindings. - + * boot-9.scm (module-make-local-var!): Do not pass name hint to make-undefined-variable, use `variable-set-name-hint!' instead. (root-module-closure): Removed. From 39cde5c57c24bed323abddc049e63d189ec3ebe2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Tue, 15 May 2001 20:12:10 +0000 Subject: [PATCH 1087/2047] * script.c (scm_compile_shell_switches): New command line option `--use-srfi' for loading a list of SRFIs on startup. (scm_shell_usage): Added `--use-srfi' to help message. --- libguile/ChangeLog | 6 ++++++ libguile/script.c | 40 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 46 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 173be0295..4f7b42056 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2001-05-15 Martin Grabmueller + + * script.c (scm_compile_shell_switches): New command line option + `--use-srfi' for loading a list of SRFIs on startup. + (scm_shell_usage): Added `--use-srfi' to help message. + 2001-05-10 Marius Vollmer Merge from mvo-vcell-clenaup-1-branch. diff --git a/libguile/script.c b/libguile/script.c index 2bcb184a1..914317b2d 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -384,6 +384,8 @@ scm_shell_usage (int fatal, char *message) " --debug start with debugging evaluator and backtraces\n" " -q inhibit loading of user init file\n" " --emacs enable Emacs protocol (experimental)\n" + " --use-srfi=LS load SRFI modules for the SRFIs in LS,\n" + " which is a list of numbers like \"2,13,14\"\n" " -h, --help display this help and exit\n" " -v, --version display version information and exit\n" " \\ read arguments from following script lines\n", @@ -402,6 +404,7 @@ SCM_SYMBOL (sym_begin, "begin"); SCM_SYMBOL (sym_load_user_init, "load-user-init"); SCM_SYMBOL (sym_top_repl, "top-repl"); SCM_SYMBOL (sym_quit, "quit"); +SCM_SYMBOL (sym_use_srfis, "use-srfis"); /* Given an array of command-line switches, return a Scheme expression @@ -533,6 +536,43 @@ scm_compile_shell_switches (int argc, char **argv) else if (! strcmp (argv[i], "-q")) /* don't load user init */ inhibit_user_init = 1; + else if (! strncmp (argv[i], "--use-srfi=", 11)) /* load SRFIs */ + { + SCM srfis = SCM_EOL; /* List of requested SRFIs. */ + char * p = argv[i] + 11; + while (*p) + { + long num; + char * end; + + num = strtol (p, &end, 10); + if (end - p > 0) + { + srfis = scm_cons (scm_long2num (num), srfis); + if (*end) + { + if (*end == ',') + p = end + 1; + else + scm_shell_usage (1, "invalid SRFI specification"); + } + else + break; + } + else + scm_shell_usage (1, "invalid SRFI specification"); + } + if (scm_ilength (srfis) <= 0) + scm_shell_usage (1, "invalid SRFI specification"); + srfis = scm_reverse_x (srfis, SCM_UNDEFINED); + tail = scm_cons (scm_listify + (sym_use_srfis, + scm_listify (scm_sym_quote, + srfis, SCM_UNDEFINED), + SCM_UNDEFINED), + tail); + } + else if (! strcmp (argv[i], "-h") || ! strcmp (argv[i], "--help")) { From f41be016f68e18bd95cac7e024f40ba608a6e896 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Tue, 15 May 2001 20:20:51 +0000 Subject: [PATCH 1088/2047] * boot-9.scm (cond-expand-features): Made the feature list public, so it can be manipulated by `use-srfis'. (use-srfis): New procedure. --- ice-9/ChangeLog | 6 ++++++ ice-9/boot-9.scm | 26 ++++++++++++++++++++------ 2 files changed, 26 insertions(+), 6 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index c246c5854..6a83b18f3 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,9 @@ +2001-05-15 Martin Grabmueller + + * boot-9.scm (cond-expand-features): Made the feature list public, + so it can be manipulated by `use-srfis'. + (use-srfis): New procedure. + 2001-05-15 Thien-Thi Nguyen * boot-9.scm (resolve-interface): Signal error now also if diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 94ea5042d..21f4f908a 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -2721,15 +2721,15 @@ ;;; ;;; Currently, the following feature identifiers are supported: ;;; -;;; guile r5rs srfi-0 srfi-6 +;;; guile r5rs srfi-0 ;;; ;;; Remember to update the features list when adding more SRFIs. -(define-macro (cond-expand clause . clauses) +(define cond-expand-features + ;; Adjust the above comment when changing this. + '(guile r5rs srfi-0)) - (define features - ;; Adjust the above comment when changing this. - '(guile r5rs srfi-0 srfi-6)) +(define-macro (cond-expand clause . clauses) (let ((clauses (cons clause clauses)) (syntax-error (lambda (cl) @@ -2739,7 +2739,7 @@ (lambda (clause) (cond ((symbol? clause) - (memq clause features)) + (memq clause cond-expand-features)) ((pair? clause) (cond ((eq? 'and (car clause)) @@ -2785,6 +2785,20 @@ (else (lp (cdr c)))))))) +;; This procedure gets called from the startup code with a list of +;; numbers, which are the numbers of the SRFIs to be loaded on startup. +;; +(define (use-srfis srfis) + (let lp ((s srfis)) + (if (pair? s) + (let* ((srfi (string->symbol + (string-append "srfi-" (number->string (car s))))) + (mod (resolve-interface (list 'srfi srfi)))) + (module-use! (current-module) mod) + (set! cond-expand-features + (append cond-expand-features (list srfi))) + (lp (cdr s)))))) + ;;; {Load emacs interface support if emacs option is given.} From a9c093e27f6670161b7a41df851821ffb68cdfb1 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 16 May 2001 00:56:48 +0000 Subject: [PATCH 1089/2047] (cpp_sig_symbols.c, cpp_err_symbols.c): Make dependent on cpp_cnvt.awk --- libguile/Makefile.am | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 1931d2dc9..9f798076c 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -201,12 +201,12 @@ schemelib_DATA = guile-procedures.txt ## Add -MG to make the .x magic work with auto-dep code. MKDEP = gcc -M -MG $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) -cpp_err_symbols.c: cpp_err_symbols.in +cpp_err_symbols.c: cpp_err_symbols.in cpp_cnvt.awk $(AWK) -f $(srcdir)/cpp_cnvt.awk < $(srcdir)/cpp_err_symbols.in > \ cpp_err_symbols.tmp mv cpp_err_symbols.tmp cpp_err_symbols.c -cpp_sig_symbols.c: cpp_sig_symbols.in +cpp_sig_symbols.c: cpp_sig_symbols.in cpp_cnvt.awk $(AWK) -f $(srcdir)/cpp_cnvt.awk < $(srcdir)/cpp_sig_symbols.in > \ cpp_sig_symbols.tmp mv cpp_sig_symbols.tmp cpp_sig_symbols.c From 78930a69eec67a243344d8a1d0389812f6d372cd Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 16 May 2001 00:57:08 +0000 Subject: [PATCH 1090/2047] *** empty log message *** --- libguile/ChangeLog | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 4f7b42056..629260128 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-05-16 Marius Vollmer + + * Makefile.am (cpp_sig_symbols.c, cpp_err_symbols.c): Make + dependent on cpp_cnvt.awk + 2001-05-15 Martin Grabmueller * script.c (scm_compile_shell_switches): New command line option @@ -6,7 +11,7 @@ 2001-05-10 Marius Vollmer - Merge from mvo-vcell-clenaup-1-branch. + Merged from mvo-vcell-cleanup-1-branch. The concept of vcells has been removed from Guile. With it, explicit obarrays and associated operations are gone. Use From 887dfa7d56e5471d1f33613fe9d7e2255b5e395c Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 16 May 2001 07:20:53 +0000 Subject: [PATCH 1091/2047] * Renamed GUILE_WARN_DEPRECATED_DEFAULT to SCM_WARN_DEPRECATED_DEFAULT. --- ChangeLog | 5 +++++ acconfig.h | 2 +- configure.in | 2 +- libguile/ChangeLog | 21 +++++++++++++-------- libguile/deprecation.c | 2 +- 5 files changed, 21 insertions(+), 11 deletions(-) diff --git a/ChangeLog b/ChangeLog index a17fc1b35..9333cbd1f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2001-05-16 Dirk Herrmann + + * acconfig.h, configure.in: Renamed + GUILE_WARN_DEPRECATED_DEFAULT to SCM_WARN_DEPRECATED_DEFAULT. + 2001-05-15 Marius Vollmer * acinclude.m4: Removed copy of "libtool.m4". diff --git a/acconfig.h b/acconfig.h index 1f14a914e..1d28d2eac 100644 --- a/acconfig.h +++ b/acconfig.h @@ -48,7 +48,7 @@ #undef SCM_DEBUG_DEPRECATED /* Define this to control the default warning level for deprecated features */ -#undef GUILE_WARN_DEPRECATED_DEFAULT +#undef SCM_WARN_DEPRECATED_DEFAULT /* Define these two if you want support for debugging of Scheme programs. */ diff --git a/configure.in b/configure.in index 143aa4d86..78665abc7 100644 --- a/configure.in +++ b/configure.in @@ -110,7 +110,7 @@ else warn_default=$enable_deprecated fi AC_DEFINE(SCM_DEBUG_DEPRECATED, 0) - AC_DEFINE_UNQUOTED(GUILE_WARN_DEPRECATED_DEFAULT, "$warn_default") + AC_DEFINE_UNQUOTED(SCM_WARN_DEPRECATED_DEFAULT, "$warn_default") fi dnl The --disable-debug used to control these two. But now they are diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 629260128..5b3182fec 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-05-16 Dirk Herrmann + + * deprecation.c (scm_init_deprecation): Renamed + GUILE_WARN_DEPRECATED_DEFAULT to SCM_WARN_DEPRECATED_DEFAULT. + 2001-05-16 Marius Vollmer * Makefile.am (cpp_sig_symbols.c, cpp_err_symbols.c): Make @@ -12,17 +17,17 @@ 2001-05-10 Marius Vollmer Merged from mvo-vcell-cleanup-1-branch. - + The concept of vcells has been removed from Guile. With it, explicit obarrays and associated operations are gone. Use hashtables instead of obarrays. - + Throughout: use scm_sym2var instead of scm_sym2vcell and treat result as variable instead of vcell. Glocs no longer point to a vcell but to a variable. Use scm_c_define instead of scm_sysintern and treat the result as a variable (which it is), not a vcell. - + * variable.c, variable.h (SCM_VARVCELL, SCM_UDVARIABLEP, SCM_DEFVARIABLEP): Deprecated. (SCM_VARIABLE_REF, SCM_VARIABLE_SET, SCM_VARIABLE_LOC): New. @@ -50,12 +55,12 @@ * symbols-deprecated.c: New file. * Makefile.am: Added symbols-deprecated.c and related files in all the right places. - + * snarf.h (SCM_VCELL, SCM_GLOBAL_VCELL, SCM_VCELL_INIT, SCM_GLOBAL_VCELL_INIT): Deprecated. (SCM_VARIABLE, SCM_GLOBAL_VARIABLE, SCM_VARIABLE_INIT, SCM_GLOBAL_VARIABLE_INIT): New, as replacement. Changed all uses. - + * print.c (scm_iprin1): Use scm_module_reverse_lookup instead of SCM_GLOC_SYM. @@ -95,7 +100,7 @@ scm_modules_prehistory): New. (scm_post_boot_init_modules): Use scm_c_define and scm_c_lookup instead of scm_intern0. - + * macros.c (scm_make_synt): Return SCM_UNSPECIFIED instead of the symbol. @@ -128,7 +133,7 @@ (SCM_GLOC_SYM): Removed. (SCM_GLOC_VAR, SCM_GLOC_SET_VAL): New. (SCM_GLOC_VAL, SCM_GLOC_LOC): Reimplemented in terms of variables. - + * eval.c (scm_lookupcar, scm_lookupcar1): Deal with variables instead of with vcells. Do not overwrite `var' with the result of the lookup, use the new `real_var' instead. Remove `var2' in @@ -174,7 +179,7 @@ * root.h (scm_symhash, scm_symhash_vars): Removed. * gc.c (scm_init_storage): Do not initialize them. - + 2001-05-15 Dirk Herrmann * eval.c (scm_init_eval): Initialize scm_undefineds and diff --git a/libguile/deprecation.c b/libguile/deprecation.c index b826f190e..87f516476 100644 --- a/libguile/deprecation.c +++ b/libguile/deprecation.c @@ -137,7 +137,7 @@ scm_init_deprecation () #if SCM_DEBUG_DEPRECATED == 0 const char *level = getenv ("GUILE_WARN_DEPRECATED"); if (level == NULL) - level = GUILE_WARN_DEPRECATED_DEFAULT; + level = SCM_WARN_DEPRECATED_DEFAULT; if (!strcmp (level, "detailed")) issued_msgs = scm_permanent_object (scm_c_make_hash_table (17)); else if (!strcmp (level, "no")) From 5f5850b38c592b591a36367243eb2613fcc60a90 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 16 May 2001 18:04:20 +0000 Subject: [PATCH 1092/2047] * tests/srfi-13.test: More tests. --- test-suite/ChangeLog | 4 + test-suite/tests/srfi-13.test | 423 ++++++++++++++++++++++++++++++++++ 2 files changed, 427 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index d588caf13..3b75a0234 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2001-05-16 Martin Grabmueller + + * tests/srfi-13.test: More tests. + 2001-05-10 Martin Grabmueller * tests/srfi-10.test: New file. diff --git a/test-suite/tests/srfi-13.test b/test-suite/tests/srfi-13.test index ec60836cd..b55472b75 100644 --- a/test-suite/tests/srfi-13.test +++ b/test-suite/tests/srfi-13.test @@ -445,6 +445,429 @@ (string-fill! s0 #\| 12 20) (char=? (string-ref s0 13) #\|))) +(with-test-prefix "string-prefix-length" + + (pass-if "empty prefix" + (= 0 (string-prefix-length "" "foo bar"))) + + (pass-if "non-empty prefix - match" + (= 3 (string-prefix-length "foo" "foo bar"))) + + (pass-if "non-empty prefix - no match" + (= 0 (string-prefix-length "bar" "foo bar")))) + +(with-test-prefix "string-prefix-length-ci" + + (pass-if "empty prefix" + (= 0 (string-prefix-length-ci "" "foo bar"))) + + (pass-if "non-empty prefix - match" + (= 3 (string-prefix-length-ci "fOo" "foo bar"))) + + (pass-if "non-empty prefix - no match" + (= 0 (string-prefix-length-ci "bAr" "foo bar")))) + +(with-test-prefix "string-suffix-length" + + (pass-if "empty suffix" + (= 0 (string-suffix-length "" "foo bar"))) + + (pass-if "non-empty suffix - match" + (= 3 (string-suffix-length "bar" "foo bar"))) + + (pass-if "non-empty suffix - no match" + (= 0 (string-suffix-length "foo" "foo bar")))) + +(with-test-prefix "string-suffix-length-ci" + + (pass-if "empty suffix" + (= 0 (string-suffix-length-ci "" "foo bar"))) + + (pass-if "non-empty suffix - match" + (= 3 (string-suffix-length-ci "bAr" "foo bar"))) + + (pass-if "non-empty suffix - no match" + (= 0 (string-suffix-length-ci "fOo" "foo bar")))) + +(with-test-prefix "string-prefix?" + + (pass-if "empty prefix" + (string-prefix? "" "foo bar")) + + (pass-if "non-empty prefix - match" + (string-prefix? "foo" "foo bar")) + + (pass-if "non-empty prefix - no match" + (not (string-prefix? "bar" "foo bar")))) + +(with-test-prefix "string-prefix-ci?" + + (pass-if "empty prefix" + (string-prefix-ci? "" "foo bar")) + + (pass-if "non-empty prefix - match" + (string-prefix-ci? "fOo" "foo bar")) + + (pass-if "non-empty prefix - no match" + (not (string-prefix-ci? "bAr" "foo bar")))) + +(with-test-prefix "string-suffix?" + + (pass-if "empty suffix" + (string-suffix? "" "foo bar")) + + (pass-if "non-empty suffix - match" + (string-suffix? "bar" "foo bar")) + + (pass-if "non-empty suffix - no match" + (not (string-suffix? "foo" "foo bar")))) + +(with-test-prefix "string-suffix-ci?" + + (pass-if "empty suffix" + (string-suffix-ci? "" "foo bar")) + + (pass-if "non-empty suffix - match" + (string-suffix-ci? "bAr" "foo bar")) + + (pass-if "non-empty suffix - no match" + (not (string-suffix-ci? "fOo" "foo bar")))) + +;; Get the procedure from the library. +(define string-index (module-peek '(srfi srfi-13) 'string-index)) + +(with-test-prefix "string-index" + + (pass-if "empty string - char" + (not (string-index "" #\a))) + + (pass-if "non-empty - char - match" + (= 5 (string-index "foo bar" #\a))) + + (pass-if "non-empty - char - no match" + (not (string-index "frobnicate" #\x))) + + (pass-if "empty string - char - start index" + (not (string-index "" #\a 0))) + + (pass-if "non-empty - char - match - start index" + (= 5 (string-index "foo bar" #\a 1))) + + (pass-if "non-empty - char - no match - start index" + (not (string-index "frobnicate" #\x 2))) + + (pass-if "empty string - char - start and end index" + (not (string-index "" #\a 0 0))) + + (pass-if "non-empty - char - match - start and end index" + (= 5 (string-index "foo bar" #\a 1 6))) + + (pass-if "non-empty - char - no match - start and end index" + (not (string-index "frobnicate" #\a 2 5))) + + (pass-if "empty string - charset" + (not (string-index "" char-set:letter))) + + (pass-if "non-empty - charset - match" + (= 0 (string-index "foo bar" char-set:letter))) + + (pass-if "non-empty - charset - no match" + (not (string-index "frobnicate" char-set:digit))) + + (pass-if "empty string - charset - start index" + (not (string-index "" char-set:letter 0))) + + (pass-if "non-empty - charset - match - start index" + (= 1 (string-index "foo bar" char-set:letter 1))) + + (pass-if "non-empty - charset - no match - start index" + (not (string-index "frobnicate" char-set:digit 2))) + + (pass-if "empty string - charset - start and end index" + (not (string-index "" char-set:letter 0 0))) + + (pass-if "non-empty - charset - match - start and end index" + (= 1 (string-index "foo bar" char-set:letter 1 6))) + + (pass-if "non-empty - charset - no match - start and end index" + (not (string-index "frobnicate" char-set:digit 2 5))) + + (pass-if "empty string - pred" + (not (string-index "" char-alphabetic?))) + + (pass-if "non-empty - pred - match" + (= 0 (string-index "foo bar" char-alphabetic?))) + + (pass-if "non-empty - pred - no match" + (not (string-index "frobnicate" char-numeric?))) + + (pass-if "empty string - pred - start index" + (not (string-index "" char-alphabetic? 0))) + + (pass-if "non-empty - pred - match - start index" + (= 1 (string-index "foo bar" char-alphabetic? 1))) + + (pass-if "non-empty - pred - no match - start index" + (not (string-index "frobnicate" char-numeric? 2))) + + (pass-if "empty string - pred - start and end index" + (not (string-index "" char-alphabetic? 0 0))) + + (pass-if "non-empty - pred - match - start and end index" + (= 1 (string-index "foo bar" char-alphabetic? 1 6))) + + (pass-if "non-empty - pred - no match - start and end index" + (not (string-index "frobnicate" char-numeric? 2 5)))) + +(with-test-prefix "string-index-right" + + (pass-if "empty string - char" + (not (string-index-right "" #\a))) + + (pass-if "non-empty - char - match" + (= 5 (string-index-right "foo bar" #\a))) + + (pass-if "non-empty - char - no match" + (not (string-index-right "frobnicate" #\x))) + + (pass-if "empty string - char - start index-right" + (not (string-index-right "" #\a 0))) + + (pass-if "non-empty - char - match - start index" + (= 5 (string-index-right "foo bar" #\a 1))) + + (pass-if "non-empty - char - no match - start index" + (not (string-index-right "frobnicate" #\x 2))) + + (pass-if "empty string - char - start and end index" + (not (string-index-right "" #\a 0 0))) + + (pass-if "non-empty - char - match - start and end index" + (= 5 (string-index-right "foo bar" #\a 1 6))) + + (pass-if "non-empty - char - no match - start and end index" + (not (string-index-right "frobnicate" #\a 2 5))) + + (pass-if "empty string - charset" + (not (string-index-right "" char-set:letter))) + + (pass-if "non-empty - charset - match" + (= 6 (string-index-right "foo bar" char-set:letter))) + + (pass-if "non-empty - charset - no match" + (not (string-index-right "frobnicate" char-set:digit))) + + (pass-if "empty string - charset - start index" + (not (string-index-right "" char-set:letter 0))) + + (pass-if "non-empty - charset - match - start index" + (= 6 (string-index-right "foo bar" char-set:letter 1))) + + (pass-if "non-empty - charset - no match - start index" + (not (string-index-right "frobnicate" char-set:digit 2))) + + (pass-if "empty string - charset - start and end index" + (not (string-index-right "" char-set:letter 0 0))) + + (pass-if "non-empty - charset - match - start and end index" + (= 5 (string-index-right "foo bar" char-set:letter 1 6))) + + (pass-if "non-empty - charset - no match - start and end index" + (not (string-index-right "frobnicate" char-set:digit 2 5))) + + (pass-if "empty string - pred" + (not (string-index-right "" char-alphabetic?))) + + (pass-if "non-empty - pred - match" + (= 6 (string-index-right "foo bar" char-alphabetic?))) + + (pass-if "non-empty - pred - no match" + (not (string-index-right "frobnicate" char-numeric?))) + + (pass-if "empty string - pred - start index" + (not (string-index-right "" char-alphabetic? 0))) + + (pass-if "non-empty - pred - match - start index" + (= 6 (string-index-right "foo bar" char-alphabetic? 1))) + + (pass-if "non-empty - pred - no match - start index" + (not (string-index-right "frobnicate" char-numeric? 2))) + + (pass-if "empty string - pred - start and end index" + (not (string-index-right "" char-alphabetic? 0 0))) + + (pass-if "non-empty - pred - match - start and end index" + (= 5 (string-index-right "foo bar" char-alphabetic? 1 6))) + + (pass-if "non-empty - pred - no match - start and end index" + (not (string-index-right "frobnicate" char-numeric? 2 5)))) + +(with-test-prefix "string-skip" + + (pass-if "empty string - char" + (not (string-skip "" #\a))) + + (pass-if "non-empty - char - match" + (= 0 (string-skip "foo bar" #\a))) + + (pass-if "non-empty - char - no match" + (= 0 (string-skip "frobnicate" #\x))) + + (pass-if "empty string - char - start index" + (not (string-skip "" #\a 0))) + + (pass-if "non-empty - char - match - start index" + (= 1 (string-skip "foo bar" #\a 1))) + + (pass-if "non-empty - char - no match - start index" + (= 2 (string-skip "frobnicate" #\x 2))) + + (pass-if "empty string - char - start and end index" + (not (string-skip "" #\a 0 0))) + + (pass-if "non-empty - char - match - start and end index" + (= 1 (string-skip "foo bar" #\a 1 6))) + + (pass-if "non-empty - char - no match - start and end index" + (= 2 (string-skip "frobnicate" #\a 2 5))) + + (pass-if "empty string - charset" + (not (string-skip "" char-set:letter))) + + (pass-if "non-empty - charset - match" + (= 3 (string-skip "foo bar" char-set:letter))) + + (pass-if "non-empty - charset - no match" + (= 0 (string-skip "frobnicate" char-set:digit))) + + (pass-if "empty string - charset - start index" + (not (string-skip "" char-set:letter 0))) + + (pass-if "non-empty - charset - match - start index" + (= 3 (string-skip "foo bar" char-set:letter 1))) + + (pass-if "non-empty - charset - no match - start index" + (= 2 (string-skip "frobnicate" char-set:digit 2))) + + (pass-if "empty string - charset - start and end index" + (not (string-skip "" char-set:letter 0 0))) + + (pass-if "non-empty - charset - match - start and end index" + (= 3 (string-skip "foo bar" char-set:letter 1 6))) + + (pass-if "non-empty - charset - no match - start and end index" + (= 2 (string-skip "frobnicate" char-set:digit 2 5))) + + (pass-if "empty string - pred" + (not (string-skip "" char-alphabetic?))) + + (pass-if "non-empty - pred - match" + (= 3 (string-skip "foo bar" char-alphabetic?))) + + (pass-if "non-empty - pred - no match" + (= 0 (string-skip "frobnicate" char-numeric?))) + + (pass-if "empty string - pred - start index" + (not (string-skip "" char-alphabetic? 0))) + + (pass-if "non-empty - pred - match - start index" + (= 3 (string-skip "foo bar" char-alphabetic? 1))) + + (pass-if "non-empty - pred - no match - start index" + (= 2 (string-skip "frobnicate" char-numeric? 2))) + + (pass-if "empty string - pred - start and end index" + (not (string-skip "" char-alphabetic? 0 0))) + + (pass-if "non-empty - pred - match - start and end index" + (= 3 (string-skip "foo bar" char-alphabetic? 1 6))) + + (pass-if "non-empty - pred - no match - start and end index" + (= 2 (string-skip "frobnicate" char-numeric? 2 5)))) + +(with-test-prefix "string-skip-right" + + (pass-if "empty string - char" + (not (string-skip-right "" #\a))) + + (pass-if "non-empty - char - match" + (= 6 (string-skip-right "foo bar" #\a))) + + (pass-if "non-empty - char - no match" + (= 9 (string-skip-right "frobnicate" #\x))) + + (pass-if "empty string - char - start index-right" + (not (string-skip-right "" #\a 0))) + + (pass-if "non-empty - char - match - start index" + (= 6 (string-skip-right "foo bar" #\a 1))) + + (pass-if "non-empty - char - no match - start index" + (= 9 (string-skip-right "frobnicate" #\x 2))) + + (pass-if "empty string - char - start and end index" + (not (string-skip-right "" #\a 0 0))) + + (pass-if "non-empty - char - match - start and end index" + (= 4 (string-skip-right "foo bar" #\a 1 6))) + + (pass-if "non-empty - char - no match - start and end index" + (= 4 (string-skip-right "frobnicate" #\a 2 5))) + + (pass-if "empty string - charset" + (not (string-skip-right "" char-set:letter))) + + (pass-if "non-empty - charset - match" + (= 3 (string-skip-right "foo bar" char-set:letter))) + + (pass-if "non-empty - charset - no match" + (= 9 (string-skip-right "frobnicate" char-set:digit))) + + (pass-if "empty string - charset - start index" + (not (string-skip-right "" char-set:letter 0))) + + (pass-if "non-empty - charset - match - start index" + (= 3 (string-skip-right "foo bar" char-set:letter 1))) + + (pass-if "non-empty - charset - no match - start index" + (= 9 (string-skip-right "frobnicate" char-set:digit 2))) + + (pass-if "empty string - charset - start and end index" + (not (string-skip-right "" char-set:letter 0 0))) + + (pass-if "non-empty - charset - match - start and end index" + (= 3 (string-skip-right "foo bar" char-set:letter 1 6))) + + (pass-if "non-empty - charset - no match - start and end index" + (= 4 (string-skip-right "frobnicate" char-set:digit 2 5))) + + (pass-if "empty string - pred" + (not (string-skip-right "" char-alphabetic?))) + + (pass-if "non-empty - pred - match" + (= 3 (string-skip-right "foo bar" char-alphabetic?))) + + (pass-if "non-empty - pred - no match" + (= 9 (string-skip-right "frobnicate" char-numeric?))) + + (pass-if "empty string - pred - start index" + (not (string-skip-right "" char-alphabetic? 0))) + + (pass-if "non-empty - pred - match - start index" + (= 3 (string-skip-right "foo bar" char-alphabetic? 1))) + + (pass-if "non-empty - pred - no match - start index" + (= 9 (string-skip-right "frobnicate" char-numeric? 2))) + + (pass-if "empty string - pred - start and end index" + (not (string-skip-right "" char-alphabetic? 0 0))) + + (pass-if "non-empty - pred - match - start and end index" + (= 3 (string-skip-right "foo bar" char-alphabetic? 1 6))) + + (pass-if "non-empty - pred - no match - start and end index" + (= 4 (string-skip-right "frobnicate" char-numeric? 2 5)))) + (with-test-prefix "string-replace" (pass-if "empty string(s), no indices" From fb02eb66f6c0aef0db0664f20b4bdbbc27c98aaa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 16 May 2001 18:08:12 +0000 Subject: [PATCH 1093/2047] * scripts.texi (Invoking Guile): Added docs for --use-srfi. * expect.texi, repl-modules.texi: Start the chapters with a new page. * srfi-modules.texi (SRFI-0): Added note about supported feature identifiers and an example. Start the chapter with a new page. * srfi-modules.texi, scheme-data.texi, scheme-control.texi, scheme-binding.texi, repl-modules.texi, posix.texi, intro.texi, scheme-utility.texi: Change `--' to `-' throughout. --- doc/ChangeLog | 14 ++ doc/expect.texi | 141 ------------------ doc/intro.texi | 8 +- doc/posix.texi | 2 +- doc/repl-modules.texi | 6 +- doc/scheme-binding.texi | 8 +- doc/scheme-control.texi | 24 +-- doc/scheme-data.texi | 28 ++-- doc/scheme-procedures.texi | 4 +- doc/scheme-utility.texi | 295 ------------------------------------- doc/scripts.texi | 11 ++ doc/srfi-modules.texi | 34 +++-- 12 files changed, 91 insertions(+), 484 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 8b2ac8559..b9791cd9d 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,17 @@ +2001-05-15 Martin Grabmueller + + * scripts.texi (Invoking Guile): Added docs for --use-srfi. + + * expect.texi, repl-modules.texi: Start the chapters with a new + page. + + * srfi-modules.texi (SRFI-0): Added note about supported feature + identifiers and an example. Start the chapter with a new page. + + * srfi-modules.texi, scheme-data.texi, scheme-control.texi, + scheme-binding.texi, repl-modules.texi, posix.texi, intro.texi, + scheme-utility.texi: Change `--' to `-' throughout. + 2001-05-14 Martin Grabmueller * srfi-13-14.texi: Removed. diff --git a/doc/expect.texi b/doc/expect.texi index 5b5be1307..e69de29bb 100644 --- a/doc/expect.texi +++ b/doc/expect.texi @@ -1,141 +0,0 @@ -@node Expect -@chapter Expect - -The macros in this section are made available with: - -@smalllisp -(use-modules (ice-9 expect)) -@end smalllisp - -@code{expect} is a macro for selecting actions based on the output from -a port. The name comes from a tool of similar functionality by Don Libes. -Actions can be taken when a particular string is matched, when a timeout -occurs, or when end-of-file is seen on the port. The @code{expect} macro -is described below; @code{expect-strings} is a front-end to @code{expect} -based on regexec (see the regular expression documentation). - -@defmac expect-strings clause @dots{} -By default, @code{expect-strings} will read from the current input port. -The first term in each clause consists of an expression evaluating to -a string pattern (regular expression). As characters -are read one-by-one from the port, they are accumulated in a buffer string -which is matched against each of the patterns. When a -pattern matches, the remaining expression(s) in -the clause are evaluated and the value of the last is returned. For example: - -@smalllisp -(with-input-from-file "/etc/passwd" - (lambda () - (expect-strings - ("^nobody" (display "Got a nobody user.\n") - (display "That's no problem.\n")) - ("^daemon" (display "Got a daemon user.\n"))))) -@end smalllisp - -The regular expression is compiled with the @code{REG_NEWLINE} flag, so -that the ^ and $ anchors will match at any newline, not just at the start -and end of the string. - -There are two other ways to write a clause: - -The expression(s) to evaluate -can be omitted, in which case the result of the regular expression match -(converted to strings, as obtained from regexec with match-pick set to "") -will be returned if the pattern matches. - -The symbol @code{=>} can be used to indicate that the expression is a -procedure which will accept the result of a successful regular expression -match. E.g., - -@smalllisp -("^daemon" => write) -("^d\\(aemon\\)" => (lambda args (for-each write args))) -("^da\\(em\\)on" => (lambda (all sub) - (write all) (newline) - (write sub) (newline))) -@end smalllisp - -The order of the substrings corresponds to the order in which the -opening brackets occur. - -A number of variables can be used to control the behaviour -of @code{expect} (and @code{expect-strings}). -Most have default top-level bindings to the value @code{#f}, -which produces the default behaviour. -They can be redefined at the -top level or locally bound in a form enclosing the expect expression. - -@table @code -@item expect-port -A port to read characters from, instead of the current input port. -@item expect-timeout -@code{expect} will terminate after this number of -seconds, returning @code{#f} or the value returned by expect-timeout-proc. -@item expect-timeout-proc -A procedure called if timeout occurs. The procedure takes a single argument: -the accumulated string. -@item expect-eof-proc -A procedure called if end-of-file is detected on the input port. The -procedure takes a single argument: the accumulated string. -@item expect-char-proc -A procedure to be called every time a character is read from the -port. The procedure takes a single argument: the character which was read. -@item expect-strings-compile-flags -Flags to be used when compiling a regular expression, which are passed -to @code{make-regexp} @xref{Regexp Functions}. The default value -is @code{regexp/newline}. -@item expect-strings-exec-flags -Flags to be used when executing a regular expression, which are -passed to regexp-exec @xref{Regexp Functions}. -The default value is @code{regexp/noteol}, which prevents @code{$} -from matching the end of the string while it is still accumulating, -but still allows it to match after a line break or at the end of file. -@end table - -Here's an example using all of the variables: - -@smalllisp -(let ((expect-port (open-input-file "/etc/passwd")) - (expect-timeout 1) - (expect-timeout-proc - (lambda (s) (display "Times up!\n"))) - (expect-eof-proc - (lambda (s) (display "Reached the end of the file!\n"))) - (expect-char-proc display) - (expect-strings-compile-flags (logior regexp/newline regexp/icase)) - (expect-strings-exec-flags 0)) - (expect-strings - ("^nobody" (display "Got a nobody user\n")))) -@end smalllisp -@end defmac - -@defmac expect clause @dots{} -@code{expect} is used in the same way as @code{expect-strings}, -but tests are specified not as patterns, but as procedures. The -procedures are called in turn after each character is read from the -port, with two arguments: the value of the accumulated string and -a flag to indicate whether end-of-file has been reached. The flag -will usually be @code{#f}, but if end-of-file is reached, the procedures -are called an additional time with the final accumulated string and -@code{#t}. - -The test is successful if the procedure returns a non-false value. - -If the @code{=>} syntax is used, then if the test succeeds it must return -a list containing the arguments to be provided to the corresponding -expression. - -In the following example, a string will only be matched at the beginning -of the file: - -@smalllisp -(let ((expect-port (open-input-file "/etc/passwd"))) - (expect - ((lambda (s eof?) (string=? s "fnord!")) - (display "Got a nobody user!\n")))) -@end smalllisp - -The control variables described for @code{expect-strings} also -influence the behaviour of @code{expect}, with the exception of -variables whose names begin with @code{expect-strings-}. -@end defmac diff --git a/doc/intro.texi b/doc/intro.texi index ed4061253..5c24c3aa3 100644 --- a/doc/intro.texi +++ b/doc/intro.texi @@ -1,4 +1,4 @@ -@c $Id: intro.texi,v 1.8 2001-05-13 19:14:41 ttn Exp $ +@c $Id: intro.texi,v 1.9 2001-05-16 18:08:12 mgrabmue Exp $ @page @node What is Guile? @@ -869,7 +869,7 @@ be a bug, unless this is explicitly documented. @item When some part of the documentation is not clear and does not make sense -to you even after re--reading the section, it is a bug. +to you even after re-reading the section, it is a bug. @end itemize When you write a bug report, please make sure to include as much of the @@ -915,7 +915,7 @@ unmodified Guile. But if you've made modifications and you don't tell us, you are sending us on a wild goose chase.) Be precise about these changes. A description in English is not -enough--send a context diff for them. +enough---send a context diff for them. Adding files of your own, or porting to another machine, is a modification of the source. @@ -979,7 +979,7 @@ certain. @item Additional information from a C debugger such as GDB might enable someone to find a problem on a machine which he does not have available. -If you don't know how to use GDB, please read the GDB manual--it is not +If you don't know how to use GDB, please read the GDB manual---it is not very long, and using GDB is easy. You can find the GDB distribution, including the GDB manual in online form, in most of the same places you can find the Guile distribution. To run Guile under GDB, you should diff --git a/doc/posix.texi b/doc/posix.texi index 71148ca60..12508cffd 100644 --- a/doc/posix.texi +++ b/doc/posix.texi @@ -2278,7 +2278,7 @@ the locale will be set using envirionment variables. @section Encryption Please note that the procedures in this section are not suited for -strong encryption, they are only interfaces to the well--known and +strong encryption, they are only interfaces to the well-known and common system library functions of the same name. They are just as good (or bad) as the underlying functions, so you should refer to your system documentation before using them. diff --git a/doc/repl-modules.texi b/doc/repl-modules.texi index 3bf68ffc8..2a0361126 100644 --- a/doc/repl-modules.texi +++ b/doc/repl-modules.texi @@ -1,3 +1,4 @@ +@page @node Readline Support @chapter Readline Support @@ -6,7 +7,7 @@ @cindex readline @cindex command line history Guile comes with an interface module to the readline library. This -makes interactive use much more convenient, because of the command--line +makes interactive use much more convenient, because of the command-line editing features of readline. Using @code{(ice-9 readline)}, you can navigate through the current input line with the cursor keys, retrieve older command lines from the input history and even search through the @@ -43,10 +44,11 @@ navigating through the command line and history. When you quit your Guile session by evaluating @code{(quit)} or pressing Ctrl-D, the history will be saved to the file @file{.guile_history} and read in when you start Guile for the next time. Thus you can start a -new Guile session and still have the (probably long--winded) definition +new Guile session and still have the (probably long-winded) definition expressions available. +@page @node Value History @chapter Value History diff --git a/doc/scheme-binding.texi b/doc/scheme-binding.texi index fe51067d9..8ea515e9f 100644 --- a/doc/scheme-binding.texi +++ b/doc/scheme-binding.texi @@ -62,7 +62,7 @@ Bindings}) act differently (@pxref{Internal Definitions}). As opposed to definitions at the top level, which are visible in the whole program (or current module, when Guile modules are used), it is also possible to define variables which are only visible in a -well--defined part of the program. Normally, this part of a program +well-defined part of the program. Normally, this part of a program will be a procedure or a subexpression of a procedure. With the constructs for local binding (@code{let}, @code{let*} and @@ -83,7 +83,7 @@ using plain @code{let} is a bit inconvenient. ((@var{variable1} @var{init1}) @dots{}) @end lisp -that is zero or more two--element lists of a variable and an arbitrary +that is zero or more two-element lists of a variable and an arbitrary expression each. All @var{variable} names must be distinct. A @code{let} expression is evaluated as follows. @@ -179,9 +179,9 @@ peach @end lisp Here the enclosing form is a @code{let}, so the @code{define}s in the -@code{let}--body are internal definitions. Because the scope of the +@code{let}-body are internal definitions. Because the scope of the internal definitions is the @strong{complete} body of the -@code{let}--expression, the @code{lambda}--expression which gets bound +@code{let}-expression, the @code{lambda}-expression which gets bound to the variable @code{banana} may refer to the variable @code{apple}, even thogh it's definition appears lexically @emph{after} the definition of @code{banana}. This is because a sequence of internal definition diff --git a/doc/scheme-control.texi b/doc/scheme-control.texi index 472b3267a..a5440a94d 100644 --- a/doc/scheme-control.texi +++ b/doc/scheme-control.texi @@ -39,13 +39,13 @@ expression below: @end lisp If the two calls to @code{display} and @code{newline} were not embedded -in a @code{begin}--statement, the call to @code{newline} would get -misinterpreted as the else--branch of the @code{if}--expression. +in a @code{begin}-statement, the call to @code{newline} would get +misinterpreted as the else-branch of the @code{if}-expression. @deffn syntax begin expr1 expr2 @dots{} -The expression(s) are evaluated in left--to--right order and the value +The expression(s) are evaluated in left-to-right order and the value of the last expression is returned as the value of the -@code{begin}--expression. This expression type is used when the +@code{begin}-expression. This expression type is used when the expressions before the last one are evaluated for their side effects. @end deffn @@ -62,7 +62,7 @@ expressions before the last one are evaluated for their side effects. @cindex cond Guile provides three syntactic constructs for conditional evaluation. -@code{if} is the normal if--then--else expression (with an optional else +@code{if} is the normal if-then-else expression (with an optional else branch), @code{cond} is a conditional expression with multiple branches and @code{case} branches if an expression has one of a set of constant values. @@ -98,13 +98,13 @@ where @var{expression} must evaluate to a procedure. The @var{test}s of the clauses are evaluated in order and as soon as one of them evaluates to a true values, the corresponding @var{expression}s are evaluated in order and the last value is returned as the value of -the @code{cond}--expression. For the @code{=>} clause type, +the @code{cond}-expression. For the @code{=>} clause type, @var{expression} is evaluated and the resulting procedure is applied to the value of @var{test}. The result of this procedure application is -then the result of the @code{cond}--expression. +then the result of the @code{cond}-expression. The @var{test} of the last @var{clause} may be the keyword @code{else}. -Then, if none of the preceding @var{test}s is true, the @var{expression}s following the @code{else} are evaluated to produce the result of the @code{cond}--expression. +Then, if none of the preceding @var{test}s is true, the @var{expression}s following the @code{else} are evaluated to produce the result of the @code{cond}-expression. @end deffn @deffn syntax case key clause1 clause2 @dots{} @@ -127,7 +127,7 @@ the @var{datum} are evaluated from left to right, returning the value of the last expression as the result of the @code{case} expression. If the @var{key} matches no @var{datum} and there is an -@code{else}--clause, the expressions following the @code{else} are +@code{else}-clause, the expressions following the @code{else} are evaluated. If there is no such clause, the result of the expression is unspecified. @end deffn @@ -204,11 +204,11 @@ is @code{#f} right from the start. @cindex named let Another very common way of expressing iteration in Scheme programs is -the use of the so--called @dfn{named let}. +the use of the so-called @dfn{named let}. Named let is a variant of @code{let} which creates a procedure and calls it in one step. Because of the newly created procedure, named let is -more powerful than @code{do}---it can be used for iteration, but also +more powerful than @code{do}--it can be used for iteration, but also for arbitrary recursion. @deffn syntax let variable bindings body @@ -310,7 +310,7 @@ called only one time. This can be confusing at times. Scheme allows a procedure to return more than one value to its caller. This is quite different to other languages which only allow -single--value returns. Returning multiple values is different from +single-value returns. Returning multiple values is different from returning a list (or pair or vector) of values to the caller, because conceptionally not @emph{one} compound object is returned, but several distinct values. diff --git a/doc/scheme-data.texi b/doc/scheme-data.texi index 7c5b649ca..b5b3bb619 100755 --- a/doc/scheme-data.texi +++ b/doc/scheme-data.texi @@ -1337,7 +1337,7 @@ Return the lowercase character version of @var{chr}. @node Strings @section Strings -Strings are fixed--length sequences of characters. They can be created +Strings are fixed-length sequences of characters. They can be created by calling constructor procedures, but they can also literally get entered at the REPL or in Scheme source files. @@ -1345,11 +1345,11 @@ Guile provides a rich set of string processing procedures, because text handling is very important when Guile is used as a scripting language. Strings always carry the information about how many characters they are -composed of with them, so there is no special end--of--string character, +composed of with them, so there is no special end-of-string character, like in C. That means that Scheme strings can contain any character, even the NUL character @code{'\0'}. But note: Since most operating system calls dealing with strings (such as for file operations) expect -strings to be zero--terminated, they might do unexpected things when +strings to be zero-terminated, they might do unexpected things when called with string containing unusal characters. @menu @@ -1507,7 +1507,7 @@ exact integers satisfying: @node String Modification @subsection String Modification -These procedures are for modifying strings in--place. That means, that +These procedures are for modifying strings in-place. That means, that not a new string is the result of a string operation, but that the actual memory representation of a string is modified. @@ -1738,7 +1738,7 @@ the C library. @node Alphabetic Case Mapping @subsection Alphabetic Case Mapping -These are procedures for mapping strings to their upper-- or lower--case +These are procedures for mapping strings to their upper- or lower-case equivalents, respectively, or for capitalizing strings. @deffn primitive string-upcase str @@ -1810,7 +1810,7 @@ This section contains several remaining string procedures. @deffn primitive string-ci->symbol str Return the symbol whose name is @var{str}. @var{str} is converted to lowercase before the conversion is done, if Guile -is currently reading symbols case--insensitively. +is currently reading symbols case-insensitively. @end deffn @@ -2292,13 +2292,13 @@ other they can be used as literal data as well. The association between symbols and values is maintained in special data structures, the symbol tables. -In addition, Guile offers variables as first--class objects. They can +In addition, Guile offers variables as first-class objects. They can be used for interacting with the module system. @menu * Symbols:: All about symbols as a data type. * Symbol Tables:: Tables for mapping symbols to values. -* Variables:: First--class variables. +* Variables:: First-class variables. @end menu @node Symbols @@ -2398,7 +2398,7 @@ part of an object returned as the value of a literal expression Report on Scheme}) or by a call to the @code{read} procedure, and its name contains alphabetic characters, then the string returned will contain characters in the implementation's -preferred standard case---some implementations will prefer +preferred standard case--some implementations will prefer upper case, others lower case. If the symbol was returned by @code{string->symbol}, the case of characters in the string returned will be the same as the case in the string that was @@ -2535,7 +2535,7 @@ Variables do not have a read syntax, they have to be created by calling one of the constructor procedures @code{make-variable} or @code{make-undefined-variable} or retrieved by @code{builtin-variable}. -First--class variables are especially useful for interacting with the +First-class variables are especially useful for interacting with the current module system (REFFIXME). @deffn primitive builtin-variable name @@ -2976,7 +2976,7 @@ applications (REFFIXME). @c FIXME::martin: Review me! Often it is useful to test whether a given Scheme object is a list or -not. List--processing procedures could use this information to test +not. List-processing procedures could use this information to test whether their input is valid, or they could do different things depending on the datatype of their arguments. @@ -2985,7 +2985,7 @@ depending on the datatype of their arguments. Return @code{#t} iff @var{x} is a proper list, else @code{#f}. @end deffn -The predicate @code{null?} is often used in list--processing code to +The predicate @code{null?} is often used in list-processing code to tell whether a given list has run out of elements. That is, a loop somehow deals with the elements of a list until the list satisfies @code{null?}. Then, teh algorithm terminates. @@ -3079,7 +3079,7 @@ lists in order to form a new list. @code{reverse} and @code{reverse!} return lists with the same elements as their arguments, but in reverse order. The procedure variants with an @code{!} directly modify the pairs which form the list, whereas the other procedures create new -pairs. This is why you should be careful when using the side--effecting +pairs. This is why you should be careful when using the side-effecting variants. @rnindex append @@ -4978,7 +4978,7 @@ a hook with @code{add-hook!} or removed with @code{remove-hook!} or @subsection Hook Examples Hook usage is shown by some examples in this section. First, we will -define a hook of arity 2---that is, the procedures stored in the hook +define a hook of arity 2 --- that is, the procedures stored in the hook will have to accept two arguments. @lisp diff --git a/doc/scheme-procedures.texi b/doc/scheme-procedures.texi index 770f6cace..0ff419dd8 100644 --- a/doc/scheme-procedures.texi +++ b/doc/scheme-procedures.texi @@ -65,7 +65,7 @@ The procedure takes any number of arguments; when the procedure is called, the sequence of actual arguments will converted into a list and stored into the newly created location for the formal variable. @item (@var{variable1} @dots{} @var{variablen} . @var{variablen+1}) -If a space--delimited period precedes the last variable, then the +If a space-delimited period precedes the last variable, then the procedure takes @var{n} or more variablesm where @var{n} is the number of formal arguments before the period. There must be at least one argument before the period. The first @var{n} actual arguments will be @@ -432,7 +432,7 @@ Return the source property specified by @var{key} from A @dfn{procedure with setter} is a special kind of procedure which normally behaves like any accesor procedure, that is a procedure which accesses a data structure. The difference is that this kind of -procedure has a so--called @dfn{setter} attached, which is a procedure +procedure has a so-called @dfn{setter} attached, which is a procedure for storing something into a data structure. Procedures with setters are treated specially when the procedure appears diff --git a/doc/scheme-utility.texi b/doc/scheme-utility.texi index 9254ec449..e69de29bb 100644 --- a/doc/scheme-utility.texi +++ b/doc/scheme-utility.texi @@ -1,295 +0,0 @@ -@page -@node Utility Functions -@chapter General Utility Functions - -@c FIXME::martin: Review me! - -This chapter contains information about procedures which are not cleanly -tied to a specific data type. Because of their wide range of -applications, they are collected in a @dfn{utlity} chapter. - -@menu -* Equality:: When are two values `the same'? -* Property Lists:: Managing metainformation about Scheme objects. -* Primitive Properties:: A modern low-level interface to object properties. -* Sorting:: Sort utility procedures. -* Copying:: Copying deep structures. -* General Conversion:: Converting objects to strings. -@end menu - - -@node Equality -@section Equality - -@c FIXME::martin: Review me! - -@cindex sameness -@cindex equality - -Three different kinds of @dfn{sameness} are defined in Scheme. - -@itemize @bullet -@item -Two values can refer to exactly the same object. - -@item -Two objects can have the same @dfn{value}. - -@item -Two objects can be structurally equivalent. -@end itemize - -The differentiation between these three kinds is important, because -determining whether two values are the same objects is very efficient, -while determining structural equivalence can be quite expensive -(consider comparing two very long lists). Therefore, three different -procedures for testing for equality are provided, which correspond to -the three kinds of @dfn{sameness} defined above. - -@rnindex eq? -@deffn primitive eq? x y -Return @code{#t} iff @var{x} references the same object as @var{y}. -@code{eq?} is similar to @code{eqv?} except that in some cases it is -capable of discerning distinctions finer than those detectable by -@code{eqv?}. -@end deffn - -@rnindex eqv? -@deffn primitive eqv? x y -The @code{eqv?} procedure defines a useful equivalence relation on objects. -Briefly, it returns @code{#t} if @var{x} and @var{y} should normally be -regarded as the same object. This relation is left slightly open to -interpretation, but works for comparing immediate integers, characters, -and inexact numbers. -@end deffn - -@rnindex equal? -@deffn primitive equal? x y -Return @code{#t} iff @var{x} and @var{y} are recursively @code{eqv?} equivalent. -@code{equal?} recursively compares the contents of pairs, -vectors, and strings, applying @code{eqv?} on other objects such as -numbers and symbols. A rule of thumb is that objects are generally -@code{equal?} if they print the same. @code{equal?} may fail to -terminate if its arguments are circular data structures. -@end deffn - - -@node Property Lists -@section Property Lists - -Every object in the system can have a @dfn{property list} that may -be used for information about that object. For example, a -function may have a property list that includes information about -the source file in which it is defined. - -Property lists are implemented as assq lists (@pxref{Association Lists}). - -Currently, property lists are implemented differently for procedures and -closures than for other kinds of objects. Therefore, when manipulating -a property list associated with a procedure object, use the -@code{procedure} functions; otherwise, use the @code{object} functions. - -@deffn primitive object-properties obj -@deffnx primitive procedure-properties obj -Return @var{obj}'s property list. -@end deffn - -@deffn primitive set-object-properties! obj alist -@deffnx primitive set-procedure-properties! obj alist -Set @var{obj}'s property list to @var{alist}. -@end deffn - -@deffn primitive object-property obj key -@deffnx primitive procedure-property obj key -Return the property of @var{obj} with name @var{key}. -@end deffn - -@deffn primitive set-object-property! obj key value -@deffnx primitive set-procedure-property! obj key value -In @var{obj}'s property list, set the property named @var{key} -to @var{value}. -@end deffn - -[Interface bug: there should be a second level of interface in which -the user provides a "property table" that is possibly private.] - - -@node Primitive Properties -@section Primitive Properties - -@deffn primitive primitive-make-property not_found_proc -Create a @dfn{property token} that can be used with -@code{primitive-property-ref} and @code{primitive-property-set!}. -See @code{primitive-property-ref} for the significance of -@var{not_found_proc}. -@end deffn - -@deffn primitive primitive-property-ref prop obj -Return the property @var{prop} of @var{obj}. When no value -has yet been associated with @var{prop} and @var{obj}, call -@var{not-found-proc} instead (see @code{primitive-make-property}) -and use its return value. That value is also associated with -@var{obj} via @code{primitive-property-set!}. When -@var{not-found-proc} is @code{#f}, use @code{#f} as the -default value of @var{prop}. -@end deffn - -@deffn primitive primitive-property-set! prop obj val -Associate @var{code} with @var{prop} and @var{obj}. -@end deffn - -@deffn primitive primitive-property-del! prop obj -Remove any value associated with @var{prop} and @var{obj}. -@end deffn - - -@node Sorting -@section Sorting - -@c FIXME::martin: Review me! - -@cindex sorting -@cindex sorting lists -@cindex sorting vectors - -Sorting is very important in computer programs. Therefore, Guile comes -with several sorting procedures built--in. As always, procedures with -names ending in @code{!} are side--effecting, that means that they may -modify their parameters in order to produce their results. - -The first group of procedures can be used to merge two lists (which must -be already sorted on their own) and produce sorted lists containing -all elements of the input lists. - -@deffn primitive merge alist blist less -Take two lists @var{alist} and @var{blist} such that -@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and -returns a new list in which the elements of @var{alist} and -@var{blist} have been stably interleaved so that -@code{(sorted? (merge alist blist less?) less?)}. -@end deffn - -@deffn primitive merge! alist blist less -Takes two lists @var{alist} and @var{blist} such that -@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and -returns a new list in which the elements of @var{alist} and -@var{blist} have been stably interleaved so that - @code{(sorted? (merge alist blist less?) less?)}. -This is the destructive variant of @code{merge} -Note: this does _not_ accept vectors. -@end deffn - -The following procedures can operate on sequences which are either -vectors or list. According to the given arguments, they return sorted -vectors or lists, respectively. The first of the following procedures -determines whether a sequence is already sorted, the other sort a given -sequence. The variants with names starting with @code{stable-} are -special in that they maintain a special property of the input sequences: -If two or more elements are the same according to the comparison -predicate, they are left in the same order as they appeared in the -input. - -@deffn primitive sorted? items less -Return @code{#t} iff @var{items} is a list or a vector such that -for all 1 <= i <= m, the predicate @var{less} returns true when -applied to all elements i - 1 and i -@end deffn - -@deffn primitive sort items less -Sort the sequence @var{items}, which may be a list or a -vector. @var{less} is used for comparing the sequence -elements. This is not a stable sort. -@end deffn - -@deffn primitive sort! items less -Sort the sequence @var{items}, which may be a list or a -vector. @var{less} is used for comparing the sequence -elements. The sorting is destructive, that means that the -input sequence is modified to produce the sorted result. -This is not a stable sort. -@end deffn - -@deffn primitive stable-sort items less -Sort the sequence @var{items}, which may be a list or a -vector. @var{less} is used for comparing the sequence elements. -This is a stable sort. -@end deffn - -@deffn primitive stable-sort! items less -Sort the sequence @var{items}, which may be a list or a -vector. @var{less} is used for comparing the sequence elements. -The sorting is destructive, that means that the input sequence -is modified to produce the sorted result. -This is a stable sort. -@end deffn - -The procedures in the last group only accept lists or vectors as input, -as their names indicate. - -@deffn primitive sort-list items less -Sort the list @var{items}, using @var{less} for comparing the -list elements. This is a stable sort. -@end deffn - -@deffn primitive sort-list! items less -Sort the list @var{items}, using @var{less} for comparing the -list elements. The sorting is destructive, that means that the -input list is modified to produce the sorted result. -This is a stable sort. -@end deffn - -@deffn primitive restricted-vector-sort! vec less startpos endpos -Sort the vector @var{vec}, using @var{less} for comparing -the vector elements. @var{startpos} and @var{endpos} delimit -the range of the vector which gets sorted. The return value -is not specified. -@end deffn - - -@node Copying -@section Copying Deep Structures - -@c FIXME::martin: Review me! - -The procedures for copying lists (@pxref{Lists}) only produce a flat -copy of the input list, and currently Guile does not even contain -procedures for copying vectors. @code{copy-tree} can be used for these -application, as it does not only copy the spine of a list, but also -copies any pairs in the cars of the input lists. - -@deffn primitive copy-tree obj -Recursively copy the data tree that is bound to @var{obj}, and return a -pointer to the new data structure. @code{copy-tree} recurses down the -contents of both pairs and vectors (since both cons cells and vector -cells may point to arbitrary objects), and stops recursing when it hits -any other object. -@end deffn - - -@node General Conversion -@section General String Conversion - -@c FIXME::martin: Review me! - -When debugging Scheme programs, but also for providing a human--friendly -interface, a procedure for converting any Scheme object into string -format is very useful. Conversion from/to strings can of course be done -with specialized procedures when the data type of the object to convert -is known, but with this procedure, it is often more comfortable. - -@code{object->string} converts an object by using a print procedure for -writing to a string port, and then returning the resulting string. -Converting an object back from the string is only possible if the object -type has a read syntax and the read syntax is preserved by the printing -procedure. - -@deffn primitive object->string obj [printer] -Return a Scheme string obtained by printing @var{obj}. -Printing function can be specified by the optional second -argument @var{printer} (default: @code{write}). -@end deffn - - -@c Local Variables: -@c TeX-master: "guile.texi" -@c End: diff --git a/doc/scripts.texi b/doc/scripts.texi index 25d4cf2ae..69b8d1661 100644 --- a/doc/scripts.texi +++ b/doc/scripts.texi @@ -83,6 +83,17 @@ This switch sets the global variable use-emacs-interface to @code{#t}. This switch is still experimental. +@item --use-srfi=@var{list} +The option @code{--use-srfi} expects a comma-separated list of numbers, +each representing a SRFI number to be loaded into the interpreter +before starting evaluating a script file or the REPL. Additionally, +the feature identifier for the loaded SRFIs is recognized by +`cond-expand' when using this option. + +@example +guile --use-srfi=8,13 +@end example + @item -h@r{, }--help Display help on invoking Guile, and then exit. diff --git a/doc/srfi-modules.texi b/doc/srfi-modules.texi index 0ff767d46..c2d9eea77 100644 --- a/doc/srfi-modules.texi +++ b/doc/srfi-modules.texi @@ -1,3 +1,4 @@ +@page @node SRFI Support @chapter Various SRFI Support Modules @@ -5,11 +6,10 @@ SRFI is an acronym for Scheme Request For Implementation. The SRFI documents define a lot of syntactic and procedure extensions to standard Scheme as defined in R5RS. -In addition to the string and character-set libraries---documented in -the next chapter---Guile has support for a number of SRFIs. This -chapter gives an overview over the available SRFIs and some usage hints. -For complete documentation, design rationales and further examples, we -advise you to get the relevant SRFI documents from the SRFI home page +Guile has support for a number of SRFIs. This chapter gives an overview +over the available SRFIs and some usage hints. For complete +documentation, design rationales and further examples, we advise you to +get the relevant SRFI documents from the SRFI home page @url{http://srfi.schemers.org}. @menu @@ -84,6 +84,22 @@ implementation-dependant operations, such as @code{use-modules} in Guile. Thus, it is not necessary to use any module to get access to this form. +Currently, the feature identifiers @code{guile}, @code{r5rs} and +@code{srfi-0} are supported. The other SRFIs are not in that list, +because the SRFI modules must be explicitly used before their exported +bindings can be used. So if a Scheme program wishes to detect whether +SRFI-8 is supported in the running implementation, code similar to this +may be needed: + +@lisp +(cond-expand + (guile + (use-modules (srfi srfi-8))) + (srfi-8 + #t)) + ;; otherwise fail. +@end lisp + @node SRFI-2 @section SRFI-2 - and-let* @@ -1160,7 +1176,7 @@ Return a true value if any character in the character set Character sets can be manipulated with the common set algebra operation, such as union, complement, intersection etc. All of these procedures -provide side--effecting variants, which modify their character set +provide side-effecting variants, which modify their character set argument(s). @deffn primitive char-set-adjoin cs char1 @dots{} @@ -1197,7 +1213,7 @@ Return the difference of all argument character sets. @deffn primitive char-set-xor cs1 @dots{} @deffnx primitive char-set-xor! cs1 @dots{} -Return the exclusive--or of all argument character sets. +Return the exclusive-or of all argument character sets. @end deffn @deffn primitive char-set-diff+intersection cs1 @dots{} @@ -1216,11 +1232,11 @@ In order to make the use of the character set data type and procedures useful, several predefined character set variables exist. @defvar char-set:lower-case -All lower--case characters. +All lower-case characters. @end defvar @defvar char-set:upper-case -All upper--case characters. +All upper-case characters. @end defvar @defvar char-set:title-case From e7e58018d70e39bcb346b640b309863f95634d7d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 16 May 2001 18:10:25 +0000 Subject: [PATCH 1094/2047] Added section about --use-srfi. --- NEWS | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/NEWS b/NEWS index d5ea8fb4e..b57e4fb41 100644 --- a/NEWS +++ b/NEWS @@ -272,6 +272,26 @@ Example: (eval '(+ 1 2) m) --> 3 (eval 'load m) --> ERROR: Unbound variable: load +** New command line option `--use-srfi' + +Using this option, SRFI modules can be loaded on startup and be +available right from the beginning. This makes programming portable +Scheme programs easier. + +The option `--use-srfi' expects a comma-separated list of numbers, +each representing a SRFI number to be loaded into the interpreter +before starting evaluating a script file or the REPL. Additionally, +the feature identifier for the loaded SRFIs is recognized by +`cond-expand' when using this option. + +Example: +$ guile --use-srfi=8,13 +guile> (receive (x z) (values 1 2) (+ 1 2)) +3 +guile> (string-pad "bla" 20) +" bla" + + * Changes to Scheme functions and syntax ** The empty combination is no longer valid syntax. From 230712c9058dc9a9428568db0723b6f1f7111742 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Wed, 16 May 2001 19:30:57 +0000 Subject: [PATCH 1095/2047] * Fix uses of @itemize without a format specifier. --- doc/ChangeLog | 8 ++++++++ doc/data-rep.texi | 10 +++++----- doc/scheme-control.texi | 2 +- doc/scheme-io.texi | 2 +- doc/scheme-procedures.texi | 2 +- doc/srfi-modules.texi | 2 +- 6 files changed, 17 insertions(+), 9 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index b9791cd9d..51b687bd8 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,11 @@ +2001-05-16 Neil Jerram + + * data-rep.texi, srfi-modules.texi (SRFI-14 Iterating Over + Character Sets), scheme-io.texi (Block Reading and Writing), + scheme-control.texi (Lazy Catch), scheme-procedures.texi (Internal + Macros): Add @bullet to @itemize usages. (Thanks for Masao + Uebayashi for the bug report!) + 2001-05-15 Martin Grabmueller * scripts.texi (Invoking Guile): Added docs for --use-srfi. diff --git a/doc/data-rep.texi b/doc/data-rep.texi index a563a7154..d4156477a 100644 --- a/doc/data-rep.texi +++ b/doc/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.23 2001-04-26 18:26:28 ossau Exp $ +@c essay @subtitle $Id: data-rep.texi,v 1.24 2001-05-16 19:30:57 ossau Exp $ @c essay @subtitle For use with Guile @value{VERSION} @c essay @author Jim Blandy @c essay @author Free Software Foundation @@ -1235,7 +1235,7 @@ Deliver the cell entry @var{n} of the heap cell referenced by the non-immediate Scheme object @var{x} as raw data. It is illegal, to access cell entries that hold Scheme objects by using these macros. For convenience, the following macros are also provided. -@itemize +@itemize @bullet @item SCM_CELL_WORD_0 (@var{x}) @result{} SCM_CELL_WORD (@var{x}, 0) @item @@ -1252,7 +1252,7 @@ Deliver the cell entry @var{n} of the heap cell referenced by the non-immediate Scheme object @var{x} as a Scheme object. It is illegal, to access cell entries that do not hold Scheme objects by using these macros. For convenience, the following macros are also provided. -@itemize +@itemize @bullet @item SCM_CELL_OBJECT_0 (@var{x}) @result{} SCM_CELL_OBJECT (@var{x}, 0) @item @@ -1274,7 +1274,7 @@ the @code{SCM_CELL_TYPE} macro. For the special case of cell entry 0 it has to be made sure that @var{w} contains a cell type information which does not describe a Scheme object. For convenience, the following macros are also provided. -@itemize +@itemize @bullet @item SCM_SET_CELL_WORD_0 (@var{x}, @var{w}) @result{} SCM_SET_CELL_WORD (@var{x}, 0, @var{w}) @@ -1298,7 +1298,7 @@ using the @code{SCM_CELL_TYPE} macro. For the special case of cell entry 0 the writing of a Scheme object into this cell is only allowed if the cell forms a Scheme pair. For convenience, the following macros are also provided. -@itemize +@itemize @bullet @item SCM_SET_CELL_OBJECT_0 (@var{x}, @var{o}) @result{} SCM_SET_CELL_OBJECT (@var{x}, 0, @var{o}) diff --git a/doc/scheme-control.texi b/doc/scheme-control.texi index a5440a94d..b1e67d2c5 100644 --- a/doc/scheme-control.texi +++ b/doc/scheme-control.texi @@ -604,7 +604,7 @@ with @var{key}, @var{thunk} and @var{handler} arguments specifying the exception type, normal case code and handler procedure, but differs in two important respects. -@itemize +@itemize @bullet @item The handler procedure is executed without unwinding the call stack from the context of the @code{throw} expression that caused the handler to be diff --git a/doc/scheme-io.texi b/doc/scheme-io.texi index e538f0dc6..942ffabf5 100644 --- a/doc/scheme-io.texi +++ b/doc/scheme-io.texi @@ -415,7 +415,7 @@ Read characters from an fport or file descriptor into a string @var{str}. This procedure is scsh-compatible and can efficiently read large strings. It will: -@itemize +@itemize @bullet @item attempt to fill the entire string, unless the @var{start} and/or @var{end} arguments are supplied. i.e., @var{start} diff --git a/doc/scheme-procedures.texi b/doc/scheme-procedures.texi index 0ff419dd8..2dc28968f 100644 --- a/doc/scheme-procedures.texi +++ b/doc/scheme-procedures.texi @@ -672,7 +672,7 @@ Given the expression with @code{foo} being some flavour of macro, one of the following things will happen when the expression is evaluated. -@itemize +@itemize @bullet @item When @code{foo} has been defined to be an @dfn{acro}, the procedure used in the acro definition of @code{foo} is passed the whole expression and diff --git a/doc/srfi-modules.texi b/doc/srfi-modules.texi index c2d9eea77..8c9543889 100644 --- a/doc/srfi-modules.texi +++ b/doc/srfi-modules.texi @@ -1033,7 +1033,7 @@ initializing it with @var{knil}. @deffn primitive char-set-unfold p f g seed [base_cs] @deffnx primitive char-set-unfold! p f g seed base_cs This is a fundamental constructor for character sets. -@itemize +@itemize @bullet @item @var{g} is used to generate a series of ``seed'' values from the initial seed: @var{seed}, (@var{g} @var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{} From 8f581c2b4824af9dbc28ae91f078c395bde61604 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 17 May 2001 04:51:53 +0000 Subject: [PATCH 1096/2047] * GUILE-VERSION (GUILE_VERSION): now MAJOR.MINOR.MICRO (GUILE_MICRO_VERSION): new variable, records final revision. i.e. the 5 in 1.6.5. MINOR_VERSION is now just the middle number, i.e. the 6. --- GUILE-VERSION | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/GUILE-VERSION b/GUILE-VERSION index 99ea5cf97..55f99d9f6 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -1,6 +1,10 @@ GUILE_MAJOR_VERSION=1 -GUILE_MINOR_VERSION=5.0 -GUILE_VERSION=${GUILE_MAJOR_VERSION}.${GUILE_MINOR_VERSION} +GUILE_MINOR_VERSION=5 +GUILE_MICRO_VERSION=0 + +GUILE_VERSION=${GUILE_MAJOR_VERSION} +GUILE_VERSION=${GUILE_VERSION}.${GUILE_MINOR_VERSION} +GUILE_VERSION=${GUILE_VERSION}.${GUILE_MICRO_VERSION} # For automake. VERSION=${GUILE_VERSION} From df4a8db0d27156eb9460cadb3f83e3409eac942f Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 17 May 2001 04:53:47 +0000 Subject: [PATCH 1097/2047] * configure.in: add AC_SUBST for GUILE_MICRO_VERSION. --- configure.in | 1 + 1 file changed, 1 insertion(+) diff --git a/configure.in b/configure.in index 78665abc7..8eebe814e 100644 --- a/configure.in +++ b/configure.in @@ -574,6 +574,7 @@ EXTRA_DOT_X_FILES="`echo ${LIBOBJS} | sed 's/\.o/.x/g'`" AC_SUBST(GUILE_MAJOR_VERSION) AC_SUBST(GUILE_MINOR_VERSION) +AC_SUBST(GUILE_MICRO_VERSION) AC_SUBST(GUILE_VERSION) AC_SUBST(LIBGUILE_MAJOR_VERSION) AC_SUBST(LIBGUILE_MINOR_VERSION) From 7907f7994976d0f7491c2ca48e4a4eae78e95158 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 17 May 2001 04:53:58 +0000 Subject: [PATCH 1098/2047] * scheme-options.texi (Install Config): fixed minor-version docs and added micro-version docs. --- doc/scheme-options.texi | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/doc/scheme-options.texi b/doc/scheme-options.texi index 472f4807c..4e711764a 100644 --- a/doc/scheme-options.texi +++ b/doc/scheme-options.texi @@ -278,13 +278,15 @@ Guile's configuration at run time. @deffn primitive version @deffnx primitive major-version @deffnx primitive minor-version +@deffnx primitive micro-version Return a string describing Guile's version number, or its major or minor version numbers, respectively. @lisp -(version) @result{} "1.3a" +(version) @result{} "1.6.5" (major-version) @result{} "1" -(minor-version) @result{} "3a" +(minor-version) @result{} "6" +(micro-version) @result{} "5" @end lisp @end deffn From b89d554bd0e5356d3142cad1613339b5a96b5a72 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 17 May 2001 04:54:27 +0000 Subject: [PATCH 1099/2047] * version.c (s_scm_major_version): doc fixes. (s_scm_minor_version): doc fixes. (s_scm_minor_version): new function. --- libguile/version.c | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/libguile/version.c b/libguile/version.c index 85cc484aa..005bf6c76 100644 --- a/libguile/version.c +++ b/libguile/version.c @@ -56,7 +56,7 @@ SCM_DEFINE (scm_major_version, "major-version", 0, 0, 0, (), "Return a string containing Guile's major version number.\n" - "E.g., \"1\".") + "E.g., the 1 in \"1.6.5\".") #define FUNC_NAME s_scm_major_version { return scm_makfrom0str (GUILE_MAJOR_VERSION); @@ -68,13 +68,25 @@ SCM_DEFINE (scm_major_version, "major-version", 0, 0, 0, SCM_DEFINE (scm_minor_version, "minor-version", 0, 0, 0, (), "Return a string containing Guile's minor version number.\n" - "E.g., \"3.5\".") + "E.g., the 6 in \"1.6.5\".") #define FUNC_NAME s_scm_minor_version { return scm_makfrom0str (GUILE_MINOR_VERSION); } #undef FUNC_NAME +/* Return a Scheme string containing Guile's minor version number. */ + +SCM_DEFINE (scm_micro_version, "micro-version", 0, 0, 0, + (), + "Return a string containing Guile's micro version number.\n" + "E.g., the 5 in \"1.6.5\".") +#define FUNC_NAME s_scm_minor_version +{ + return scm_makfrom0str (GUILE_MICRO_VERSION); +} +#undef FUNC_NAME + /* Return a Scheme string containing Guile's complete version. */ SCM_DEFINE (scm_version, "version", 0, 0, 0, From fb872f3ad9f03241fa037c499e06aaa84d32bf3f Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 17 May 2001 04:54:37 +0000 Subject: [PATCH 1100/2047] * version.h (scm_init_version): new function. --- libguile/version.h | 1 + 1 file changed, 1 insertion(+) diff --git a/libguile/version.h b/libguile/version.h index 1a4efa776..15b01406f 100644 --- a/libguile/version.h +++ b/libguile/version.h @@ -50,6 +50,7 @@ extern SCM scm_major_version (void); extern SCM scm_minor_version (void); +extern SCM scm_micro_version (void); extern SCM scm_version (void); extern void scm_init_version (void); From c493c8c093a86b2a8754d898a4cec4022ac0ad62 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 17 May 2001 04:54:45 +0000 Subject: [PATCH 1101/2047] * versiondat.h.in: add GUILE_MICRO_VERSION. --- libguile/versiondat.h.in | 3 --- 1 file changed, 3 deletions(-) diff --git a/libguile/versiondat.h.in b/libguile/versiondat.h.in index 60f2f55ab..e69de29bb 100644 --- a/libguile/versiondat.h.in +++ b/libguile/versiondat.h.in @@ -1,3 +0,0 @@ -#define GUILE_VERSION "@GUILE_VERSION@" -#define GUILE_MAJOR_VERSION "@GUILE_MAJOR_VERSION@" -#define GUILE_MINOR_VERSION "@GUILE_MINOR_VERSION@" From 5a1920ded26e9f8f2cd0e1cbbf71085d39e5760d Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 17 May 2001 04:54:59 +0000 Subject: [PATCH 1102/2047] * srfi-19.scm (priv:integer-reader-exact): minor cleanups. --- srfi/srfi-19.scm | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/srfi/srfi-19.scm b/srfi/srfi-19.scm index 1ac2f0f43..00d5837d6 100644 --- a/srfi/srfi-19.scm +++ b/srfi/srfi-19.scm @@ -1247,21 +1247,21 @@ (let ((padding-ok #t)) (define (accum-int port accum nchars) (let ((ch (peek-char port))) - (cond - ((>= nchars n) accum) - ((eof-object? ch) - (priv:time-error 'string->date 'bad-date-template-string + (cond + ((>= nchars n) accum) + ((eof-object? ch) + (priv:time-error 'string->date 'bad-date-template-string "Premature ending to integer read.")) - ((char-numeric? ch) - (set! padding-ok #f) - (accum-int port (+ (* accum 10) (priv:char->int (read-char - port))) - (+ nchars 1))) - (padding-ok - (read-ch port) ; consume padding - (accum-int prot accum (+ nchars 1))) - (else ; padding where it shouldn't be - (priv:time-error 'string->date 'bad-date-template-string + ((char-numeric? ch) + (set! padding-ok #f) + (accum-int port + (+ (* accum 10) (priv:char->int (read-char port))) + (+ nchars 1))) + (padding-ok + (read-char port) ; consume padding + (accum-int port accum (+ nchars 1))) + (else ; padding where it shouldn't be + (priv:time-error 'string->date 'bad-date-template-string "Non-numeric characters in integer read."))))) (accum-int port 0 0))) From c81ea65d61403a46ba3f2da1d5d6d4b39160ad5f Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 17 May 2001 04:56:13 +0000 Subject: [PATCH 1103/2047] *** empty log message *** --- ChangeLog | 10 ++++++++++ NEWS | 21 +++++++++++++++++++++ libguile/ChangeLog | 10 ++++++++++ 3 files changed, 41 insertions(+) diff --git a/ChangeLog b/ChangeLog index 9333cbd1f..40ce4add6 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,13 @@ +2001-05-16 Rob Browning + + * configure.in: add AC_SUBST for GUILE_MICRO_VERSION. + + * GUILE-VERSION + (GUILE_VERSION): now MAJOR.MINOR.MICRO + (GUILE_MICRO_VERSION): new variable, records final revision. + i.e. the 5 in 1.6.5. MINOR_VERSION is now just the middle number, + i.e. the 6. + 2001-05-16 Dirk Herrmann * acconfig.h, configure.in: Renamed diff --git a/NEWS b/NEWS index b57e4fb41..6308e29b7 100644 --- a/NEWS +++ b/NEWS @@ -8,6 +8,27 @@ Changes since Guile 1.4: * Changes to the distribution +** Guile now using versioning scheme similar to that of the Linux kernel. + +Guile now always uses three numbers to represent the version, +i.e. "1.6.5". The first number, 1, is the major version number, the +second number, 6, is the minor version number, and the third number, +5, is the micro version number. Changes in major version number +indicate major changes in Guile. + +Minor version numbers that are even denote stable releases, and odd +minor version numbers denote development versions (which may be +unstable). The micro version number indicates a minor sub-revision of +a given MAJOR.MINOR release. + +In keeping with the new scheme, (minor-version) and scm_minor_version +no longer return everything but the major version number. They now +just return the minor version number. Two new functions +(micro-version) and scm_micro_version have been added to report the +micro version number. + +In addition, ./GUILE-VERSION now defines GUILE_MICRO_VERSION. + ** As per RELEASE directions, deprecated items have been removed *** Macros removed diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 5b3182fec..330afc5ec 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,13 @@ +2001-05-16 Rob Browning + + * version.c (s_scm_major_version): doc fixes. + (s_scm_minor_version): doc fixes. + (s_scm_minor_version): new function. + + * version.h (scm_init_version): new function. + + * versiondat.h.in: add GUILE_MICRO_VERSION. + 2001-05-16 Dirk Herrmann * deprecation.c (scm_init_deprecation): Renamed From 09cb9e738b6e96c67a4f719c4399026f38ae9375 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 17 May 2001 06:38:25 +0000 Subject: [PATCH 1104/2047] * Removed SCM_CDR misuse. --- libguile/ChangeLog | 9 +++++++++ libguile/print.h | 21 +++++++++------------ 2 files changed, 18 insertions(+), 12 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 330afc5ec..d6c9c183b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2001-05-17 Dirk Herrmann + + * print.h (PRINTH, SCM_PRINT_H): Renamed PRINTH to SCM_PRINT_H. + + (SCM_PORT_WITH_PS_PORT, SCM_PORT_WITH_PS_PS): Only pairs may be + accessed with SCM_C[AD]R. + + (SCM_COERCE_OUTPORT): Removed redundant SCM_NIMP test. + 2001-05-16 Rob Browning * version.c (s_scm_major_version): doc fixes. diff --git a/libguile/print.h b/libguile/print.h index c6946aa4d..25c1dbe0f 100644 --- a/libguile/print.h +++ b/libguile/print.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef PRINTH -#define PRINTH -/* Copyright (C) 1995,1996,1998, 2000 Free Software Foundation, Inc. +#ifndef SCM_PRINT_H +#define SCM_PRINT_H +/* Copyright (C) 1995,1996,1998,2000,2001 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 @@ -74,12 +74,11 @@ do { \ #define SCM_SET_WRITINGP(pstate, x) { (pstate)->writingp = (x); } #define SCM_PORT_WITH_PS_P(p) SCM_TYP16_PREDICATE (scm_tc16_port_with_ps, p) -#define SCM_PORT_WITH_PS_PORT(p) SCM_CADR (p) -#define SCM_PORT_WITH_PS_PS(p) SCM_CDDR (p) +#define SCM_PORT_WITH_PS_PORT(p) SCM_CAR (SCM_CELL_OBJECT_1 (p)) +#define SCM_PORT_WITH_PS_PS(p) SCM_CDR (SCM_CELL_OBJECT_1 (p)) -#define SCM_COERCE_OUTPORT(p) (SCM_NIMP (p) && SCM_PORT_WITH_PS_P (p) \ - ? SCM_PORT_WITH_PS_PORT (p) \ - : p) +#define SCM_COERCE_OUTPORT(p) \ + (SCM_PORT_WITH_PS_P (p) ? SCM_PORT_WITH_PS_PORT (p) : p) #define SCM_PRINT_STATE_LAYOUT "sruwuwuwuwuwpwuwuwuruopr" typedef struct scm_print_state { @@ -100,7 +99,6 @@ typedef struct scm_print_state { extern SCM scm_print_state_vtable; -/* ? scm or long? print.h and print.c disagree */ extern scm_bits_t scm_tc16_port_with_ps; extern SCM scm_print_options (SCM setting); @@ -116,8 +114,7 @@ extern SCM scm_display (SCM obj, SCM port); extern SCM scm_simple_format (SCM port, SCM message, SCM args); extern SCM scm_newline (SCM port); extern SCM scm_write_char (SCM chr, SCM port); -extern SCM scm_printer_apply (SCM proc, SCM exp, SCM port, - scm_print_state *); +extern SCM scm_printer_apply (SCM proc, SCM exp, SCM port, scm_print_state *); extern SCM scm_port_with_print_state (SCM port, SCM pstate); extern SCM scm_get_print_state (SCM port); extern int scm_valid_oport_value_p (SCM val); @@ -126,7 +123,7 @@ extern void scm_init_print (void); #ifdef GUILE_DEBUG extern SCM scm_current_pstate (void); #endif -#endif /* PRINTH */ +#endif /* SCM_PRINT_H */ /* Local Variables: From 115d80dc977ec748c71f09baefe89fa9a2c90cd9 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 18 May 2001 16:30:59 +0000 Subject: [PATCH 1105/2047] Fix documentation for Guile Documentation Format Version 2: Mention required terminating newlines. (find-documentation): Delete. (search-documentation-files): New proc, exported. (object-documentation): Use `search-documentation-files'. --- ice-9/documentation.scm | 32 ++++++++++++++++++++++---------- 1 file changed, 22 insertions(+), 10 deletions(-) diff --git a/ice-9/documentation.scm b/ice-9/documentation.scm index fd5a9ad98..27d160ff5 100644 --- a/ice-9/documentation.scm +++ b/ice-9/documentation.scm @@ -25,6 +25,12 @@ ;; documentation-files -- a search-list of files using the Guile ;; Documentation Format Version 2. ;; +;; search-documentation-files -- a procedure that takes NAME (a symbol) +;; and searches `documentation-files' for +;; associated documentation. optional +;; arg FILES is a list of filenames to use +;; instead of `documentation-files'. +;; ;; object-documentation -- a procedure that returns its arg's docstring ;; ;; * Guile Documentation Format @@ -35,14 +41,17 @@ ;; HEADER ;; ^LPROC1 ;; DOCUMENTATION1 +;; ;; ^LPROC2 ;; DOCUMENTATION2 -;; ... +;; +;; ^L... ;; ;; The HEADER is completely ignored. The "^L" are formfeeds. PROC1, PROC2 ;; and so on are symbols that name the element documented. DOCUMENTATION1, ;; DOCUMENTATION2 and so on are the related documentation, w/o any further -;; formatting. +;; formatting. Note that there are two newlines before the next formfeed; +;; these are discarded when the documentation is read in. ;; ;; (Version 1, corresponding to guile-1.4 and prior, is documented as being ;; not documented anywhere except by this embarrassingly circular comment.) @@ -72,7 +81,9 @@ (define-module (ice-9 documentation) :use-module (ice-9 rdelim) - :export (file-commentary documentation-files object-documentation) + :export (file-commentary + documentation-files search-documentation-files + object-documentation) :autoload (ice-9 regex) (match:suffix) :no-backtrace) @@ -137,11 +148,6 @@ %site-dir (lambda () ".")))) -(define (find-documentation name) - (or-map (lambda (file) - (find-documentation-in-file name file)) - documentation-files)) - (define entry-delimiter "\f") (define (find-documentation-in-file name file) @@ -163,6 +169,12 @@ (substring entry (+ len 2) (- (string-length entry) 2))) (else (loop (read-delimited entry-delimiter port))))))))) +(define (search-documentation-files name . files) + (or-map (lambda (file) + (find-documentation-in-file name file)) + (cond ((null? files) documentation-files) + (else files)))) + ;; helper until the procedure documentation property is cleaned up (define (proc-doc proc) (or (procedure-documentation proc) @@ -179,11 +191,11 @@ OBJECT can be a procedure, macro or any object that has its (and transformer (proc-doc transformer)))) (object-property object 'documentation) - ;; find-documentation currently only works for builtin primitives (and (procedure? object) (not (closure? object)) (procedure-name object) - (let ((docstring (find-documentation (procedure-name object)))) + (let ((docstring (search-documentation-files + (procedure-name object)))) (if docstring (set-procedure-property! object 'documentation docstring)) docstring)))) From adcbdb16879fd323c2e1150b8891f1707a546cce Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 18 May 2001 16:34:25 +0000 Subject: [PATCH 1106/2047] *** empty log message *** --- ice-9/ChangeLog | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 6a83b18f3..ff7dd2c45 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,12 @@ +2001-05-18 Thien-Thi Nguyen + + * documentation.scm: Fix documentation for Guile Documentation + Format Version 2: Mention required terminating newlines. + + (find-documentation): Delete. + (search-documentation-files): New proc, exported. + (object-documentation): Use `search-documentation-files'. + 2001-05-15 Martin Grabmueller * boot-9.scm (cond-expand-features): Made the feature list public, From de25f281fd6385e8db4e541dbcc6fb587589fc90 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 18 May 2001 17:05:06 +0000 Subject: [PATCH 1107/2047] (help): Use `provided?' instead of `feature?'. Factor "TYPE not found for X" output into internal proc. Support `(quote SYMBOL)'; call `search-documentation-files'. (help-doc): If initial search fails, try using `search-documentation-files'. (apropos-fold-accessible, apropos-fold-all): Use `identity' instead of `(lambda (x) x)'. "An identity edit", ha ha. --- ice-9/session.scm | 211 ++++++++++++++++++++++++++-------------------- 1 file changed, 119 insertions(+), 92 deletions(-) diff --git a/ice-9/session.scm b/ice-9/session.scm index 5bd404374..0519f5237 100644 --- a/ice-9/session.scm +++ b/ice-9/session.scm @@ -32,43 +32,61 @@ "(help [NAME]) Prints useful information. Try `(help)'." (cond ((not (= (length exp) 2)) - (help-usage)) - ((not (feature? 'regex)) - (display "`help' depends on the `regex' feature. + (help-usage)) + ((not (provided? 'regex)) + (display "`help' depends on the `regex' feature. You don't seem to have regular expressions installed.\n")) - (else - (let ((name (cadr exp))) - (cond ((symbol? name) - (help-doc name - (string-append "^" - (regexp-quote - (symbol->string name)) - "$"))) - ((string? name) - (help-doc name name)) - ((and (list? name) - (= (length name) 2) - (eq? (car name) 'unquote)) - (let ((doc (object-documentation (local-eval (cadr name) - env)))) - (if (not doc) - (simple-format #t "No documentation found for ~S\n" - (cadr name)) - (write-line doc)))) - ((and (list? name) - (and-map symbol? name) - (not (null? name)) - (not (eq? (car name) 'quote))) - (let ((doc (module-commentary name))) - (if (not doc) - (simple-format - #t "No commentary found for module ~S\n" name) - (begin - (display name) (write-line " commentary:") - (write-line doc))))) - (else - (help-usage))) - *unspecified*)))))) + (else + (let ((name (cadr exp)) + (not-found (lambda (type x) + (simple-format #t "No ~A found for ~A\n" + type x)))) + (cond + + ;; SYMBOL + ((symbol? name) + (help-doc name + (simple-format + #f "^~A$" + (regexp-quote (symbol->string name))))) + + ;; "STRING" + ((string? name) + (help-doc name name)) + + ;; (unquote SYMBOL) + ((and (list? name) + (= (length name) 2) + (eq? (car name) 'unquote)) + (cond ((object-documentation + (local-eval (cadr name) env)) + => write-line) + (else (not-found 'documentation (cadr name))))) + + ;; (quote SYMBOL) + ((and (list? name) + (= (length name) 2) + (eq? (car name) 'quote) + (symbol? (cadr name))) + (cond ((search-documentation-files (cadr name)) + => write-line) + (else (not-found 'documentation (cadr name))))) + + ;; (SYM1 SYM2 ...) + ((and (list? name) + (and-map symbol? name) + (not (null? name)) + (not (eq? (car name) 'quote))) + (cond ((module-commentary name) + => (lambda (doc) + (display name) (write-line " commentary:") + (write-line doc))) + (else (not-found 'commentary name)))) + + ;; unrecognized + (else + (help-usage))) + *unspecified*)))))) (define (module-filename name) ; fixme: better way? / done elsewhere? (let* ((name (map symbol->string name)) @@ -104,64 +122,71 @@ You don't seem to have regular expressions installed.\n")) (name cadr) (doc caddr) (type cadddr)) - (if (null? entries) - ;; no matches - (begin - (display "Did not find any object ") - (simple-format #t - (if (symbol? term) - "named `~A'\n" - "matching regexp \"~A\"\n") - term)) - (let ((first? #t) - (undocumented-entries '()) - (documented-entries '()) - (documentations '())) + (cond ((not (null? entries)) + (let ((first? #t) + (undocumented-entries '()) + (documented-entries '()) + (documentations '())) - (for-each (lambda (entry) - (let ((entry-summary (simple-format #f - "~S: ~S\n" - (module-name (module entry)) - (name entry)))) - (if (doc entry) - (begin - (set! documented-entries - (cons entry-summary documented-entries)) - ;; *fixme*: Use `describe' when we have GOOPS? - (set! documentations - (cons (simple-format #f - "`~S' is ~A in the ~S module.\n\n~A\n" - (name entry) - (type entry) - (module-name (module entry)) - (doc entry)) - documentations))) - (set! undocumented-entries - (cons entry-summary undocumented-entries))))) - entries) + (for-each (lambda (entry) + (let ((entry-summary (simple-format + #f "~S: ~S\n" + (module-name (module entry)) + (name entry)))) + (if (doc entry) + (begin + (set! documented-entries + (cons entry-summary documented-entries)) + ;; *fixme*: Use `describe' when we have GOOPS? + (set! documentations + (cons (simple-format + #f "`~S' is ~A in the ~S module.\n\n~A\n" + (name entry) + (type entry) + (module-name (module entry)) + (doc entry)) + documentations))) + (set! undocumented-entries + (cons entry-summary + undocumented-entries))))) + entries) - (if (and (not (null? documented-entries)) - (or (> (length documented-entries) 1) - (not (null? undocumented-entries)))) - (begin - (display "Documentation found for:\n") - (for-each (lambda (entry) (display entry)) documented-entries) - (set! first? #f))) + (if (and (not (null? documented-entries)) + (or (> (length documented-entries) 1) + (not (null? undocumented-entries)))) + (begin + (display "Documentation found for:\n") + (for-each (lambda (entry) (display entry)) + documented-entries) + (set! first? #f))) - (for-each (lambda (entry) - (if first? - (set! first? #f) - (newline)) - (display entry)) - documentations) + (for-each (lambda (entry) + (if first? + (set! first? #f) + (newline)) + (display entry)) + documentations) - (if (not (null? undocumented-entries)) - (begin - (if first? - (set! first? #f) - (newline)) - (display "No documentation found for:\n") - (for-each (lambda (entry) (display entry)) undocumented-entries))))))) + (if (not (null? undocumented-entries)) + (begin + (if first? + (set! first? #f) + (newline)) + (display "No documentation found for:\n") + (for-each (lambda (entry) (display entry)) + undocumented-entries))))) + ((search-documentation-files term) + => (lambda (doc) + (write-line "Documentation from file:") + (write-line doc))) + (else + ;; no matches + (display "Did not find any object ") + (simple-format #t + (if (symbol? term) + "named `~A'\n" + "matching regexp \"~A\"\n") + term))))) (define (help-usage) (display "Usage: (help NAME) gives documentation about objects named NAME (a symbol) @@ -318,7 +343,7 @@ It is an image under the mapping EXTRACT." (define-public (apropos-fold-accessible module) (make-fold-modules (lambda () (list module)) module-uses - (lambda (x) x))) + identity)) (define (root-modules) (cons the-root-module @@ -338,7 +363,7 @@ It is an image under the mapping EXTRACT." (make-fold-modules root-modules submodules module-public-interface)) (define-public apropos-fold-all - (make-fold-modules root-modules submodules (lambda (x) x))) + (make-fold-modules root-modules submodules identity)) (define-public (source obj) (cond ((procedure? obj) (procedure-source obj)) @@ -396,3 +421,5 @@ It is an image under the mapping EXTRACT." (set-system-module! m s) (string-append "Module " (symbol->string (module-name m)) " is now a " (if s "system" "user") " module.")))))) + +;;; session.scm ends here From d58f1edfad9b906bb0d0f60547692cdcda4681d6 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 18 May 2001 17:07:48 +0000 Subject: [PATCH 1108/2047] *** empty log message *** --- ice-9/ChangeLog | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index ff7dd2c45..8de2aea19 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,5 +1,13 @@ 2001-05-18 Thien-Thi Nguyen + * session.scm: (help): Use `provided?' instead of `feature?'. + Factor "TYPE not found for X" output into internal proc. + Support `(quote SYMBOL)'; call `search-documentation-files'. + (help-doc): If initial search fails, try using + `search-documentation-files'. + (apropos-fold-accessible, apropos-fold-all): Use `identity' + instead of `(lambda (x) x)'. "An identity edit", ha ha. + * documentation.scm: Fix documentation for Guile Documentation Format Version 2: Mention required terminating newlines. From 1de3b33b0b065d5229b70d56390da68622061004 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 18 May 2001 17:10:42 +0000 Subject: [PATCH 1109/2047] (help-usage): Mention support for "(help 'NAME)". --- ice-9/session.scm | 1 + 1 file changed, 1 insertion(+) diff --git a/ice-9/session.scm b/ice-9/session.scm index 0519f5237..87ad2c5f7 100644 --- a/ice-9/session.scm +++ b/ice-9/session.scm @@ -191,6 +191,7 @@ You don't seem to have regular expressions installed.\n")) (define (help-usage) (display "Usage: (help NAME) gives documentation about objects named NAME (a symbol) (help REGEXP) ditto for objects with names matching REGEXP (a string) + (help 'NAME) gives documentation for NAME, even if it is not an object (help ,EXPR) gives documentation for object returned by EXPR (help (my module)) gives module commentary for `(my module)' (help) gives this text From 3125fbe050491e3304e62447f3c17f39aafe30d8 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 18 May 2001 17:12:37 +0000 Subject: [PATCH 1110/2047] *** empty log message *** --- ice-9/ChangeLog | 1 + 1 file changed, 1 insertion(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 8de2aea19..aff5f294d 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -7,6 +7,7 @@ `search-documentation-files'. (apropos-fold-accessible, apropos-fold-all): Use `identity' instead of `(lambda (x) x)'. "An identity edit", ha ha. + (help-usage): Mention support for "(help 'NAME)". * documentation.scm: Fix documentation for Guile Documentation Format Version 2: Mention required terminating newlines. From 58e5b910864b9a7a3dcc6b747d537d0ddbfda5e2 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 18 May 2001 17:16:40 +0000 Subject: [PATCH 1111/2047] Mention `read-scheme-source'. Mention support for "(help 'NAME)". --- NEWS | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index 6308e29b7..0c5ec903f 100644 --- a/NEWS +++ b/NEWS @@ -91,6 +91,7 @@ also be executable as scripts. At this time, these scripts are available: doc-snarf generate-autoload punify + read-scheme-source use2dot See README there for more info. @@ -309,7 +310,7 @@ Example: $ guile --use-srfi=8,13 guile> (receive (x z) (values 1 2) (+ 1 2)) 3 -guile> (string-pad "bla" 20) +guile> (string-pad "bla" 20) " bla" @@ -1057,6 +1058,7 @@ This is useful when debugging your .guile init file or scripts. Usage: (help NAME) gives documentation about objects named NAME (a symbol) (help REGEXP) ditto for objects with names matching REGEXP (a string) + (help 'NAME) gives documentation for NAME, even if it is not an object (help ,EXPR) gives documentation for object returned by EXPR (help (my module)) gives module commentary for `(my module)' (help) gives this text From f8a502cb722c2c96a790838390daf7e5a9c5c885 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 18 May 2001 17:28:03 +0000 Subject: [PATCH 1112/2047] (resolve-interface, use-srfis): Small cleanup; nfc. (process-define-module): Internal proc `unrecognized' now accepts arg; update callers. Reverse order of interfaces added to module to be consistent with that specified in `define-module' form. --- ice-9/boot-9.scm | 57 ++++++++++++++++++++---------------------------- 1 file changed, 24 insertions(+), 33 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 21f4f908a..6ff5cf5ea 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1603,11 +1603,6 @@ (eq? (car (last-pair use-list)) the-scm-module)) (set-module-uses! module (reverse (cdr (reverse use-list))))))) -(define (resolve-interface name) - (let ((module (resolve-module name))) - (and module (module-public-interface module)))) - - ;; Return a module interface made from SPEC. ;; SPEC can be a list of symbols, in which case it names a module ;; whose public interface is found and returned. @@ -1616,8 +1611,8 @@ ;; (MODULE-NAME [:select SELECTION] [:rename RENAMER]) ;; in which case a partial interface is newly created and returned. ;; MODULE-NAME is a list of symbols, as above; SELECTION is a list of -;; selection-specs to be imported; and RENAMER is a procedure that takes a -;; symbol and returns its new name. A selection-spec is either a symbol or a +;; binding-specs to be imported; and RENAMER is a procedure that takes a +;; symbol and returns its new name. A binding-spec is either a symbol or a ;; pair of symbols (ORIG . SEEN), where ORIG is the name in the used module ;; and SEEN is the name in the using module. Note that SEEN is also passed ;; through RENAMER. @@ -1649,14 +1644,10 @@ (else identity))) (custom-i (make-module 31))) (set-module-kind! custom-i 'interface) - (for-each (lambda (sel-spec) - (let* ((direct? (symbol? sel-spec)) - (orig (if direct? - sel-spec - (car sel-spec))) - (seen (if direct? - sel-spec - (cdr sel-spec)))) + (for-each (lambda (bspec) + (let* ((direct? (symbol? bspec)) + (orig (if direct? bspec (car bspec))) + (seen (if direct? bspec (cdr bspec)))) (module-add! custom-i (rename seen) (or (module-local-variable module orig) (error @@ -1672,11 +1663,11 @@ (symbol-append prefix symbol))) (define (process-define-module args) - (let* ((module-id (car args)) - (module (resolve-module module-id #f)) - (kws (cdr args)) - (unrecognized (lambda () - (error "unrecognized define-module argument" kws)))) + (let* ((module-id (car args)) + (module (resolve-module module-id #f)) + (kws (cdr args)) + (unrecognized (lambda (arg) + (error "unrecognized define-module argument" arg)))) (beautify-user-module! module) (let loop ((kws kws) (reversed-interfaces '()) @@ -1685,7 +1676,7 @@ (begin (for-each (lambda (interface) (module-use! module interface)) - reversed-interfaces) + (reverse reversed-interfaces)) (module-export! module exports)) (let ((keyword (if (keyword? (car kws)) (keyword->symbol (car kws)) @@ -1696,7 +1687,7 @@ (case keyword ((use-module use-syntax) (or (pair? (cdr kws)) - (unrecognized)) + (unrecognized kws)) (let* ((spec (cadr kws)) (interface (resolve-interface spec))) (and (eq? keyword 'use-syntax) @@ -1712,7 +1703,7 @@ exports))) ((autoload) (or (and (pair? (cdr kws)) (pair? (cddr kws))) - (unrecognized)) + (unrecognized kws)) (loop (cdddr kws) (cons (make-autoload-interface module (cadr kws) @@ -1727,12 +1718,12 @@ (loop (cdr kws) reversed-interfaces exports)) ((export) (or (pair? (cdr kws)) - (unrecognized)) + (unrecognized kws)) (loop (cddr kws) reversed-interfaces (append (cadr kws) exports))) (else - (unrecognized)))))) + (unrecognized kws)))))) (set-current-module module) module)) @@ -2791,14 +2782,14 @@ (define (use-srfis srfis) (let lp ((s srfis)) (if (pair? s) - (let* ((srfi (string->symbol - (string-append "srfi-" (number->string (car s))))) - (mod (resolve-interface (list 'srfi srfi)))) - (module-use! (current-module) mod) - (set! cond-expand-features - (append cond-expand-features (list srfi))) - (lp (cdr s)))))) - + (let* ((srfi (string->symbol + (string-append "srfi-" (number->string (car s))))) + (mod-i (resolve-interface (list 'srfi srfi)))) + (module-use! (current-module) mod-i) + (set! cond-expand-features + (append cond-expand-features (list srfi))) + (lp (cdr s)))))) + ;;; {Load emacs interface support if emacs option is given.} From d28690d78a190d533ae326406ee1067295fd31a0 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 18 May 2001 17:30:58 +0000 Subject: [PATCH 1113/2047] *** empty log message *** --- ice-9/ChangeLog | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index aff5f294d..1ca0d2a0c 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,5 +1,12 @@ 2001-05-18 Thien-Thi Nguyen + * boot-9.scm: (resolve-interface, use-srfis): Small + cleanup; nfc. + (process-define-module): Internal proc `unrecognized' + now accepts arg; update callers. + Reverse order of interfaces added to module to be + consistent with that specified in `define-module' form. + * session.scm: (help): Use `provided?' instead of `feature?'. Factor "TYPE not found for X" output into internal proc. Support `(quote SYMBOL)'; call `search-documentation-files'. From 94451729e00a4a14c410929a2d37368a5d07d114 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 19 May 2001 00:17:05 +0000 Subject: [PATCH 1114/2047] Avoid using module operations from C. * srfi-13.c (scm_init_srfi_13_14): Removed. * srfi-14.h, srfi-14.c (scm_c_init_srfi_14): New. Contains initializations needed by C clients of srfi-14. (scm_init_srfi_13, scm_init_srfi_14): Call it. * srfi-13.scm: Call "scm_init_srf_13" instead of "scm_init_srfi_13_14". * srfi-14.scm: Call "scm_init_srf_14" instead of "scm_init_srfi_13_14". --- srfi/srfi-13.c | 24 +----------------------- srfi/srfi-13.scm | 2 +- srfi/srfi-14.c | 21 ++++++++++++++++----- srfi/srfi-14.h | 1 + srfi/srfi-14.scm | 2 +- 5 files changed, 20 insertions(+), 30 deletions(-) diff --git a/srfi/srfi-13.c b/srfi/srfi-13.c index 4b709781f..88584caaa 100644 --- a/srfi/srfi-13.c +++ b/srfi/srfi-13.c @@ -3026,30 +3026,8 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0, void scm_init_srfi_13 (void) { + scm_c_init_srfi_14 (); #ifndef SCM_MAGIC_SNARFER #include "srfi/srfi-13.x" #endif } - - -void -scm_init_srfi_13_14 (void) -{ - static int initialized = 0; - - if (!initialized) - { - SCM srfi_13_module = scm_make_module (scm_read_0str ("(srfi srfi-13)")); - SCM srfi_14_module = scm_make_module (scm_read_0str ("(srfi srfi-14)")); - SCM old_module; - - initialized = 1; - - old_module = scm_set_current_module (srfi_13_module); - scm_init_srfi_13 (); - scm_set_current_module (srfi_14_module); - scm_init_srfi_14 (); - - scm_set_current_module (old_module); - } -} diff --git a/srfi/srfi-13.scm b/srfi/srfi-13.scm index 89f974d8f..612518105 100644 --- a/srfi/srfi-13.scm +++ b/srfi/srfi-13.scm @@ -110,7 +110,7 @@ string-delete ) -(dynamic-call "scm_init_srfi_13_14" (dynamic-link "libguile-srfi-srfi-13-14")) +(dynamic-call "scm_init_srfi_13" (dynamic-link "libguile-srfi-srfi-13-14")) (define string-hash (lambda (s . rest) diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index 9fb6b4847..24388fc5c 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -1347,14 +1347,25 @@ SCM_DEFINE (scm_char_set_diff_plus_intersection_x, "char-set-diff+intersection!" #undef FUNC_NAME +void +scm_c_init_srfi_14 (void) +{ + static initialized = 0; + + if (!initialized) + { + scm_tc16_charset = scm_make_smob_type ("character-set", + SCM_CHARSET_SIZE * sizeof (long)); + scm_set_smob_free (scm_tc16_charset, charset_free); + scm_set_smob_print (scm_tc16_charset, charset_print); + initialized = 1; + } +} + void scm_init_srfi_14 (void) { - scm_tc16_charset = scm_make_smob_type ("character-set", - SCM_CHARSET_SIZE * sizeof (long)); - scm_set_smob_free (scm_tc16_charset, charset_free); - scm_set_smob_print (scm_tc16_charset, charset_print); - + scm_c_init_srfi_14 (); #ifndef SCM_MAGIC_SNARFER #include "srfi/srfi-14.x" #endif diff --git a/srfi/srfi-14.h b/srfi/srfi-14.h index 6eef6f9f7..48bb88337 100644 --- a/srfi/srfi-14.h +++ b/srfi/srfi-14.h @@ -56,6 +56,7 @@ /* Smob type code for character sets. */ extern int scm_tc16_charset; +void scm_c_init_srfi_14 (void); void scm_init_srfi_14 (void); SCM scm_char_set_p (SCM obj); diff --git a/srfi/srfi-14.scm b/srfi/srfi-14.scm index 117e27818..b947b9187 100644 --- a/srfi/srfi-14.scm +++ b/srfi/srfi-14.scm @@ -90,7 +90,7 @@ char-set:full ) -(dynamic-call "scm_init_srfi_13_14" (dynamic-link "libguile-srfi-srfi-13-14")) +(dynamic-call "scm_init_srfi_14" (dynamic-link "libguile-srfi-srfi-13-14")) (define (->char-set x) (cond From 78ec533c40f83b200a529beb12d75e50c4384b23 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 19 May 2001 00:19:25 +0000 Subject: [PATCH 1115/2047] Call `%init-goops-builtins' instead of using the `(oop goops goopscore)' module. --- oop/goops.scm | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/oop/goops.scm b/oop/goops.scm index 7cf7c7b64..162cd2811 100644 --- a/oop/goops.scm +++ b/oop/goops.scm @@ -27,12 +27,15 @@ ;;;; (define-module (oop goops) - :use-module (oop goops goopscore) - :use-module (oop goops util) - :use-module (oop goops dispatch) - :use-module (oop goops compile) - :no-backtrace - ) + :no-backtrace) + +;; First initialize the builtin part of GOOPS +(%init-goops-builtins) + +;; Then load the rest of GOOPS +(use-modules (oop goops util) + (oop goops dispatch) + (oop goops compile) (export ; Define the exported symbols of this file goops-version is-a? From 7c628196fdc8fba0a4551166ee9b13fb36b7869a Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 19 May 2001 00:19:42 +0000 Subject: [PATCH 1116/2047] *** empty log message *** --- oop/ChangeLog | 5 +++++ srfi/ChangeLog | 13 +++++++++++++ 2 files changed, 18 insertions(+) diff --git a/oop/ChangeLog b/oop/ChangeLog index b4c27c788..f6eebba30 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -1,3 +1,8 @@ +2001-05-19 Marius Vollmer + + * goops.scm: Call `%init-goops-builtins' instead of using the + `(oop goops goopscore)' module. + 2001-05-10 Marius Vollmer * goops/compile.scm (compile-method): Insert comment that diff --git a/srfi/ChangeLog b/srfi/ChangeLog index c48ddc226..e909c27c9 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,16 @@ +2001-05-19 Marius Vollmer + + Avoid using module operations from C. + + * srfi-13.c (scm_init_srfi_13_14): Removed. + * srfi-14.h, srfi-14.c (scm_c_init_srfi_14): New. Contains + initializations needed by C clients of srfi-14. + (scm_init_srfi_13, scm_init_srfi_14): Call it. + * srfi-13.scm: Call "scm_init_srf_13" instead of + "scm_init_srfi_13_14". + * srfi-14.scm: Call "scm_init_srf_14" instead of + "scm_init_srfi_13_14". + 2001-05-14 Martin Grabmueller * Makefile.am (srfi_DATA): Added srfi-16.scm. From de208a7462dd2e570edf6a0c5d934eee3caa0385 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 19 May 2001 00:19:43 +0000 Subject: [PATCH 1117/2047] Fix typos. --- srfi/ChangeLog | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index e909c27c9..4231ab088 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -6,9 +6,9 @@ * srfi-14.h, srfi-14.c (scm_c_init_srfi_14): New. Contains initializations needed by C clients of srfi-14. (scm_init_srfi_13, scm_init_srfi_14): Call it. - * srfi-13.scm: Call "scm_init_srf_13" instead of + * srfi-13.scm: Call "scm_init_srfi_13" instead of "scm_init_srfi_13_14". - * srfi-14.scm: Call "scm_init_srf_14" instead of + * srfi-14.scm: Call "scm_init_srfi_14" instead of "scm_init_srfi_13_14". 2001-05-14 Martin Grabmueller From f366ed28ee32b05c9412ec362b4e73dbe20e6c38 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 19 May 2001 00:21:41 +0000 Subject: [PATCH 1118/2047] (narrow_stack): Do not call `scm_system_module_env_p' when deprecated features are excluded from Guile. --- libguile/stacks.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/libguile/stacks.c b/libguile/stacks.c index 63bbda07b..61c262453 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -360,7 +360,10 @@ narrow_stack (SCM stack,int inner,SCM inner_key,int outer,SCM outer_key) SCM m = s->frames[i].source; if ( SCM_MEMOIZEDP (m) && SCM_NIMP (SCM_MEMOIZED_ENV (m)) - && SCM_FALSEP (scm_system_module_env_p (SCM_MEMOIZED_ENV (m)))) +#if SCM_DEBUG_DEPRECATED == 0 + && SCM_FALSEP (scm_system_module_env_p (SCM_MEMOIZED_ENV (m))) +#endif + ) { /* Back up in order to include any non-source frames */ while (i > 0 From deec8fc26c432fcdfd440503e7de33c53b54b7f2 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 19 May 2001 00:22:51 +0000 Subject: [PATCH 1119/2047] (scm_shell): Evaluate the compiled switches in the current module, not in the root module. --- libguile/script.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/script.c b/libguile/script.c index 914317b2d..2eda0b378 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -675,7 +675,7 @@ scm_shell (int argc, char **argv) } exit (scm_exit_status (scm_eval_x (scm_compile_shell_switches (argc, argv), - scm_the_root_module ()))); + scm_current_module ()))); } From e615ee8d210321c503bb3d53763b7fcde6fc9034 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 19 May 2001 00:24:15 +0000 Subject: [PATCH 1120/2047] (scm_init_rw_builtins): Renamed from scm_init_rw. Return SCM_UNSPECIFIED. (scm_init_rw): Only register `%init-rw-builtins' procedure. --- libguile/rw.c | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/libguile/rw.c b/libguile/rw.c index 3acb796f2..d1a6b2782 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -160,17 +160,20 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0, } #undef FUNC_NAME -void -scm_init_rw () +SCM +scm_init_rw_builtins () { - SCM rw_module = scm_make_module (scm_read_0str ("(ice-9 rw)")); - SCM old_module = scm_set_current_module (rw_module); - #ifndef SCM_MAGIC_SNARFER #include "libguile/rw.x" #endif - scm_set_current_module (old_module); + return SCM_UNSPECIFIED; +} + +void +scm_init_rw () +{ + scm_make_gsubr ("%init-rw-builtins", 0, 0, 0, scm_init_rw_builtins); } /* From a0c32266ceab30fdcfca0419fb45aed807e135db Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 19 May 2001 00:25:04 +0000 Subject: [PATCH 1121/2047] Call `%init-rw-builtins'. --- ice-9/rw.scm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ice-9/rw.scm b/ice-9/rw.scm index 6b5327ea1..da4bd86d9 100644 --- a/ice-9/rw.scm +++ b/ice-9/rw.scm @@ -24,3 +24,5 @@ (define-module (ice-9 rw) :export (read-string!/partial)) + +(%init-rw-builtins) From 6280d4294ec1181522e0e1016f0852bb6db897e3 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 19 May 2001 00:27:22 +0000 Subject: [PATCH 1122/2047] (scm_init_rdelim_builtins): Renamed from scm_init_rdelim. Do not switch explicetly create/switch modules. Return SCM_UNSPECIFIED. (scm_init_rdelim): Only register `%init-rdelim-builtins' procedure. --- libguile/rdelim.c | 20 ++++++++++++-------- libguile/rdelim.h | 2 ++ 2 files changed, 14 insertions(+), 8 deletions(-) diff --git a/libguile/rdelim.c b/libguile/rdelim.c index 3ebd39955..3e8697a31 100644 --- a/libguile/rdelim.c +++ b/libguile/rdelim.c @@ -282,28 +282,32 @@ SCM_DEFINE (scm_write_line, "write-line", 1, 1, 0, } #undef FUNC_NAME -void -scm_init_rdelim (void) +SCM +scm_init_rdelim_builtins (void) { - SCM rdelim_module = scm_make_module (scm_read_0str ("(ice-9 rdelim)")); - SCM old_module = scm_set_current_module (rdelim_module); - #ifndef SCM_MAGIC_SNARFER #include "libguile/rdelim.x" #endif - scm_set_current_module (old_module); - #if DEBUG_DEPRECATED == 0 { + SCM old_module = scm_current_module (); const char expr[] = "\ (define-module (guile) :use-module (ice-9 rdelim))\ (define-module (guile-user) :use-module (ice-9 rdelim))"; scm_eval_string (scm_makfromstr (expr, (sizeof expr) - 1, 0)); + scm_set_current_module (old_module); } - scm_set_current_module (old_module); #endif + + return SCM_UNSPECIFIED; +} + +void +scm_init_rdelim (void) +{ + scm_make_gsubr ("%init-rdelim-builtins", 0, 0, 0, scm_init_rdelim_builtins); } /* diff --git a/libguile/rdelim.h b/libguile/rdelim.h index 1f27a1d17..3b1039bdc 100644 --- a/libguile/rdelim.h +++ b/libguile/rdelim.h @@ -50,6 +50,8 @@ extern SCM scm_read_delimited_x (SCM delims, SCM buf, SCM gobble, SCM port, SCM offset, SCM length); extern SCM scm_read_line (SCM port); extern SCM scm_write_line (SCM obj, SCM port); +extern SCM scm_init_rdelim_builtins (void); + void scm_init_rdelim (void); #endif From 43fd4402572c996e7d5d131216153d067caac6cf Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 19 May 2001 00:28:06 +0000 Subject: [PATCH 1123/2047] Call `%init-rdelim-builtins'. --- ice-9/rdelim.scm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ice-9/rdelim.scm b/ice-9/rdelim.scm index 732163e5d..787b79f0d 100644 --- a/ice-9/rdelim.scm +++ b/ice-9/rdelim.scm @@ -24,6 +24,8 @@ (define-module (ice-9 rdelim)) +(%init-rdelim-builtins) + (export read-line read-line! read-delimited read-delimited!) (export %read-delimited! %read-line write-line) ; C From e2d085f3a22fa6d126afc5b04171ac04556e6d64 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 19 May 2001 00:29:36 +0000 Subject: [PATCH 1124/2047] (scm_init_guile_1): Call `scm_init_goops' instead of `scm_init_oop_goops_goopscore_module'. Call `scm_init_rdelim' and `scm_init_rw' prior to loading the startup files. --- libguile/init.c | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/libguile/init.c b/libguile/init.c index 45ecb5f7a..0e91a7559 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -577,7 +577,7 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_init_lang (); scm_init_script (); - scm_init_oop_goops_goopscore_module (); + scm_init_goops (); scm_initialized_p = 1; @@ -588,13 +588,10 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; #endif - scm_load_startup_files (); - - /* these are located here, not from a deep understanding of the - module system, but as a way of avoiding segv and other - undesirable side effects that arise from various alternatives. */ scm_init_rdelim (); scm_init_rw (); + + scm_load_startup_files (); } /* Record here whether SCM_BOOT_GUILE_1 has already been called. This From abd28220e73130a282718b44c4c3190bfb24ae37 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 19 May 2001 00:33:25 +0000 Subject: [PATCH 1125/2047] (scm_init_goops_builtins): Renamed from `scm_init_goops'. Do not explicitly create/switch modules. Return SCM_UNSPECIFIED. (scm_init_goops): Only register `%init-goops-builtins' procedure. (scm_load_goops): Use scm_c_resolve_module instead of scm_resolve_module. --- libguile/goops.c | 19 ++++++++----------- libguile/goops.h | 3 ++- 2 files changed, 10 insertions(+), 12 deletions(-) diff --git a/libguile/goops.c b/libguile/goops.c index f108d1407..ea07bc3ba 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -2437,7 +2437,7 @@ void scm_load_goops () { if (!goops_loaded_p) - scm_resolve_module (scm_read_0str ("(oop goops)")); + scm_c_resolve_module ("oop goops"); } @@ -2645,13 +2645,10 @@ SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0, SCM scm_module_goops; -void -scm_init_goops (void) +SCM +scm_init_goops_builtins (void) { - SCM old_module; - scm_module_goops = scm_make_module (scm_read_0str ("(oop goops)")); - old_module = scm_set_current_module (scm_module_goops); - + scm_module_goops = scm_current_module (); scm_goops_lookup_closure = scm_module_lookup_closure (scm_module_goops); /* Not really necessary right now, but who knows... @@ -2689,14 +2686,14 @@ scm_init_goops (void) name))); DEFVAR (name, scm_no_applicable_method); } - - scm_set_current_module (old_module); + + return SCM_UNSPECIFIED; } void -scm_init_oop_goops_goopscore_module () +scm_init_goops () { - scm_register_module_xxx ("oop goops goopscore", (void *) scm_init_goops); + scm_make_gsubr ("%init-goops-builtins", 0, 0, 0, scm_init_goops_builtins); } /* diff --git a/libguile/goops.h b/libguile/goops.h index 624ca3075..9867096af 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -237,7 +237,6 @@ SCM scm_m_atdispatch (SCM xorig, SCM env); #ifdef GUILE_DEBUG SCM scm_pure_generic_p (SCM obj); #endif -extern void scm_init_oop_goops_goopscore_module (void); SCM scm_sys_compute_slots (SCM c); SCM scm_i_get_keyword (SCM key, SCM l, int len, SCM default_value, const char *subr); @@ -281,6 +280,8 @@ SCM stklos_version (void); SCM scm_make (SCM args); SCM scm_find_method (SCM args); SCM scm_sys_method_more_specific_p (SCM m1, SCM m2, SCM targs); + +SCM scm_init_goops_builtins (void); void scm_init_goops (void); #endif /* GOOPSH */ From 143e09021525f2ec20df191164784ded5723cad9 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 19 May 2001 00:36:22 +0000 Subject: [PATCH 1126/2047] (scm_internal_with_fluids): Deprecated. (scm_c_with_fluids): Renamed from scm_internal_with_fluids. (scm_c_with_fluid): New. (scm_with_fluids): Use scm_c_with_fluids instead of scm_internal_with_fluids. --- libguile/fluids.c | 29 +++++++++++++++++++++++++---- libguile/fluids.h | 14 ++++++++++++-- 2 files changed, 37 insertions(+), 6 deletions(-) diff --git a/libguile/fluids.c b/libguile/fluids.c index a5bc280af..0283467c8 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -51,6 +51,7 @@ #include "libguile/alist.h" #include "libguile/eval.h" #include "libguile/ports.h" +#include "libguile/deprecation.h" #define INITIAL_FLUIDS 10 #include "libguile/validate.h" @@ -224,13 +225,13 @@ SCM_DEFINE (scm_with_fluids, "with-fluids*", 3, 0, 0, "one after another. @var{thunk} must be a procedure with no argument.") #define FUNC_NAME s_scm_with_fluids { - return scm_internal_with_fluids (fluids, values, apply_thunk, (void *) SCM_UNPACK (thunk)); + return scm_c_with_fluids (fluids, values, apply_thunk, (void *) SCM_UNPACK (thunk)); } #undef FUNC_NAME SCM -scm_internal_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata) -#define FUNC_NAME "scm_internal_with_fluids" +scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata) +#define FUNC_NAME "scm_c_with_fluids" { SCM ans; int flen, vlen; @@ -249,7 +250,14 @@ scm_internal_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata) } #undef FUNC_NAME - +SCM +scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (), void *cdata) +#define FUNC_NAME "scm_c_with_fluid" +{ + return scm_c_with_fluids (SCM_LIST1 (fluid), SCM_LIST1 (value), + cproc, cdata); +} +#undef FUNC_NAME void scm_init_fluids () @@ -261,6 +269,19 @@ scm_init_fluids () #endif } +#if SCM_DEBUG_DEPRECATED == 0 + +SCM +scm_internal_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata) +{ + scm_c_issue_deprecation_warning ("`scm_internal_with_fluids' is deprecated. " + "Use `scm_c_with_fluids' instead."); + + return scm_c_with_fluids (fluids, values, cproc, cdata); +} + +#endif + /* Local Variables: c-file-style: "gnu" diff --git a/libguile/fluids.h b/libguile/fluids.h index 7b67318be..c80d1e696 100644 --- a/libguile/fluids.h +++ b/libguile/fluids.h @@ -95,8 +95,10 @@ SCM scm_fluid_p (SCM fl); SCM scm_fluid_ref (SCM fluid); SCM scm_fluid_set_x (SCM fluid, SCM value); -SCM scm_internal_with_fluids (SCM fluids, SCM vals, - SCM (*cproc)(void *), void *cdata); +SCM scm_c_with_fluids (SCM fluids, SCM vals, + SCM (*cproc)(void *), void *cdata); +SCM scm_c_with_fluid (SCM fluid, SCM val, + SCM (*cproc)(void *), void *cdata); SCM scm_with_fluids (SCM fluids, SCM vals, SCM thunk); SCM scm_make_initial_fluids (void); @@ -106,6 +108,14 @@ void scm_swap_fluids_reverse (SCM fluids, SCM vals); void scm_init_fluids (void); +#if SCM_DEBUG_DEPRECATED == 0 + +/* Use scm_c_with_fluids instead. */ +SCM scm_internal_with_fluids (SCM fluids, SCM vals, + SCM (*cproc)(void *), void *cdata); + +#endif + #endif /* !FLUIDSH */ /* From d02b98e9609b8418867d3b46d844d385d128eb0c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 19 May 2001 01:22:12 +0000 Subject: [PATCH 1127/2047] * modules.h, modules.c: Moved around a lot of code so that deprecated features appear at the bottom. (root_module_lookup_closure, scm_sym_app, scm_sym_modules, module_prefix, make_modules_in_var, beautify_user_module_x_var, scm_the_root_module, scm_make_module, scm_ensure_user_module, scm_load_scheme_module): Deprecated. (scm_system_module_env_p): Return SCM_BOOL_T directly for environments corresponding to the root module. (convert_module_name, scm_c_resolve_module, scm_c_call_with_current_module, scm_c_define_module, scm_c_use_module, scm_c_export): New. (the_root_module): New static variant of scm_the_root_module. Use it everywhere instead of scm_the_root_module. --- libguile/modules.c | 322 +++++++++++++++++++++++++++++++-------------- libguile/modules.h | 57 +++++--- 2 files changed, 257 insertions(+), 122 deletions(-) diff --git a/libguile/modules.c b/libguile/modules.c index f889fe9aa..fb466d511 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -44,6 +44,8 @@ +#include + #include "libguile/_scm.h" #include "libguile/eval.h" @@ -54,6 +56,7 @@ #include "libguile/struct.h" #include "libguile/variable.h" #include "libguile/fluids.h" +#include "libguile/deprecation.h" #include "libguile/modules.h" @@ -61,18 +64,6 @@ int scm_module_system_booted_p = 0; SCM scm_module_tag; -static SCM the_root_module_var; -static SCM root_module_lookup_closure; - -SCM -scm_the_root_module () -{ - if (scm_module_system_booted_p) - return SCM_VARIABLE_REF (the_root_module_var); - else - return SCM_BOOL_F; -} - static SCM the_module; SCM_DEFINE (scm_current_module, "current-module", 0, 0, 0, @@ -126,77 +117,48 @@ SCM_DEFINE (scm_interaction_environment, "interaction-environment", 0, 0, 0, } #undef FUNC_NAME -SCM_SYMBOL (scm_sym_app, "app"); -SCM_SYMBOL (scm_sym_modules, "modules"); -static SCM module_prefix; +SCM +scm_c_call_with_current_module (SCM module, + SCM (*func)(void *), void *data) +{ + return scm_c_with_fluid (the_module, module, func, data); +} static SCM -scm_module_full_name (SCM name) +convert_module_name (const char *name) { - if (SCM_EQ_P (SCM_CAR (name), scm_sym_app)) - return name; - else - return scm_append (SCM_LIST2 (module_prefix, name)); -} - -static SCM make_modules_in_var; -static SCM beautify_user_module_x_var; - -SCM -scm_make_module (SCM name) -{ - return scm_apply (SCM_VARIABLE_REF (make_modules_in_var), - SCM_LIST2 (scm_the_root_module (), - scm_module_full_name (name)), - SCM_EOL); -} - -SCM -scm_ensure_user_module (SCM module) -{ - scm_apply (SCM_VARIABLE_REF (beautify_user_module_x_var), - SCM_LIST1 (module), SCM_EOL); - return SCM_UNSPECIFIED; -} - -SCM -scm_module_lookup_closure (SCM module) -{ - if (module == SCM_BOOL_F) - return SCM_BOOL_F; - else - return SCM_MODULE_EVAL_CLOSURE (module); -} - -SCM -scm_current_module_lookup_closure () -{ - if (scm_module_system_booted_p) - return scm_module_lookup_closure (scm_current_module ()); - else - return SCM_BOOL_F; -} - -SCM -scm_module_transformer (SCM module) -{ - if (module == SCM_BOOL_F) - return SCM_BOOL_F; - else - return SCM_MODULE_TRANSFORMER (module); -} - -SCM -scm_current_module_transformer () -{ - if (scm_module_system_booted_p) - return scm_module_transformer (scm_current_module ()); - else - return SCM_BOOL_F; + SCM list = SCM_EOL; + SCM *tail = &list; + + const char *ptr; + while (*name) + { + while (*name == ' ') + name++; + ptr = name; + while (*ptr && *ptr != ' ') + ptr++; + if (ptr > name) + { + *tail = scm_cons (scm_mem2symbol (name, ptr-name), SCM_EOL); + tail = SCM_CDRLOC (*tail); + } + name = ptr; + } + + return list; } +static SCM process_define_module_var; +static SCM process_use_modules_var; static SCM resolve_module_var; +SCM +scm_c_resolve_module (const char *name) +{ + return scm_resolve_module (convert_module_name (name)); +} + SCM scm_resolve_module (SCM name) { @@ -204,13 +166,47 @@ scm_resolve_module (SCM name) SCM_LIST1 (name), SCM_EOL); } -static SCM try_module_autoload_var; - SCM -scm_load_scheme_module (SCM name) +scm_c_define_module (const char *name, + void (*init)(void *), void *data) { - return scm_apply (SCM_VARIABLE_REF (try_module_autoload_var), - SCM_LIST1 (name), SCM_EOL); + SCM module = scm_apply (SCM_VARIABLE_REF (process_define_module_var), + SCM_LIST1 (SCM_LIST1 (convert_module_name (name))), + SCM_EOL); + if (init) + scm_c_call_with_current_module (module, (SCM (*)(void*))init, data); + return module; +} + +void +scm_c_use_module (const char *name) +{ + scm_apply (SCM_VARIABLE_REF (process_use_modules_var), + SCM_LIST1 (SCM_LIST1 (convert_module_name (name))), + SCM_EOL); +} + +static SCM module_export_x_var; + +void +scm_c_export (const char *name, ...) +{ + va_list ap; + SCM names = scm_cons (scm_str2symbol (name), SCM_EOL); + SCM *tail = SCM_CDRLOC (names); + va_start (ap, name); + while (1) + { + const char *n = va_arg (ap, const char *); + if (n == NULL) + break; + *tail = scm_cons (scm_str2symbol (n), SCM_EOL); + tail = SCM_CDRLOC (*tail); + } + scm_apply (SCM_VARIABLE_REF (module_export_x_var), + SCM_LIST2 (scm_current_module (), + names), + SCM_EOL); } /* Environments */ @@ -239,18 +235,29 @@ scm_env_top_level (SCM env) SCM_SYMBOL (sym_module, "module"); +static SCM the_root_module_var; + +static SCM +the_root_module () +{ + if (scm_module_system_booted_p) + return SCM_VARIABLE_REF (the_root_module_var); + else + return SCM_BOOL_F; +} + SCM scm_lookup_closure_module (SCM proc) { if (SCM_FALSEP (proc)) - return scm_the_root_module (); + return the_root_module (); else if (SCM_EVAL_CLOSURE_P (proc)) return SCM_PACK (SCM_SMOB_DATA (proc)); else { SCM mod = scm_procedure_property (proc, sym_module); if (mod == SCM_BOOL_F) - mod = scm_the_root_module (); + mod = the_root_module (); return mod; } } @@ -261,21 +268,6 @@ scm_env_module (SCM env) return scm_lookup_closure_module (scm_env_top_level (env)); } - -SCM_SYMBOL (scm_sym_system_module, "system-module"); - -SCM -scm_system_module_env_p (SCM env) -{ - SCM proc = scm_env_top_level (env); - if (SCM_FALSEP (proc)) - proc = root_module_lookup_closure; - return ((SCM_NFALSEP (scm_procedure_property (proc, - scm_sym_system_module))) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - /* * C level implementation of the standard eval closure * @@ -363,6 +355,42 @@ SCM_DEFINE (scm_standard_interface_eval_closure, } #undef FUNC_NAME +SCM +scm_module_lookup_closure (SCM module) +{ + if (module == SCM_BOOL_F) + return SCM_BOOL_F; + else + return SCM_MODULE_EVAL_CLOSURE (module); +} + +SCM +scm_current_module_lookup_closure () +{ + if (scm_module_system_booted_p) + return scm_module_lookup_closure (scm_current_module ()); + else + return SCM_BOOL_F; +} + +SCM +scm_module_transformer (SCM module) +{ + if (module == SCM_BOOL_F) + return SCM_BOOL_F; + else + return SCM_MODULE_TRANSFORMER (module); +} + +SCM +scm_current_module_transformer () +{ + if (scm_module_system_booted_p) + return scm_module_transformer (scm_current_module ()); + else + return SCM_BOOL_F; +} + /* scm_sym2var * * looks up the variable bound to SYM according to PROC. PROC should be @@ -552,6 +580,32 @@ SCM_DEFINE (scm_get_pre_modules_obarray, "%get-pre-modules-obarray", 0, 0, 0, } #undef FUNC_NAME +#if SCM_DEBUG_DEPRECATED == 0 + +static SCM root_module_lookup_closure; +SCM_SYMBOL (scm_sym_app, "app"); +SCM_SYMBOL (scm_sym_modules, "modules"); +static SCM module_prefix; +static SCM make_modules_in_var; +static SCM beautify_user_module_x_var; +static SCM try_module_autoload_var; + +#endif + +SCM_SYMBOL (scm_sym_system_module, "system-module"); + +SCM +scm_system_module_env_p (SCM env) +{ + SCM proc = scm_env_top_level (env); + if (SCM_FALSEP (proc)) + return SCM_BOOL_T; + return ((SCM_NFALSEP (scm_procedure_property (proc, + scm_sym_system_module))) + ? SCM_BOOL_T + : SCM_BOOL_F); +} + void scm_modules_prehistory () { @@ -581,17 +635,83 @@ scm_post_boot_init_modules () SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type")); scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_cons_gloc); + + resolve_module_var = PERM (scm_c_lookup ("resolve-module")); + process_define_module_var = PERM (scm_c_lookup ("process-define-module")); + process_use_modules_var = PERM (scm_c_lookup ("process-use-modules")); + module_export_x_var = PERM (scm_c_lookup ("module-export!")); + the_root_module_var = PERM (scm_c_lookup ("the-root-module")); + +#if SCM_DEBUG_DEPRECATED == 0 + module_prefix = PERM (SCM_LIST2 (scm_sym_app, scm_sym_modules)); make_modules_in_var = PERM (scm_c_lookup ("make-modules-in")); - beautify_user_module_x_var = PERM (scm_c_lookup ("beautify-user-module!")); - the_root_module_var = PERM (scm_c_lookup ("the-root-module")); root_module_lookup_closure = PERM (scm_module_lookup_closure (SCM_VARIABLE_REF (the_root_module_var))); - resolve_module_var = PERM (scm_c_lookup ("resolve-module")); + beautify_user_module_x_var = PERM (scm_c_lookup ("beautify-user-module!")); try_module_autoload_var = PERM (scm_c_lookup ("try-module-autoload")); + +#endif + scm_module_system_booted_p = 1; } +#if SCM_DEBUG_DEPRECATED == 0 + +SCM +scm_the_root_module () +{ + scm_c_issue_deprecation_warning ("`scm_the_root_module' is deprecated. " + "Use `scm_c_resolve_module (\"guile\") " + "instead."); + + return the_root_module (); +} + +static SCM +scm_module_full_name (SCM name) +{ + if (SCM_EQ_P (SCM_CAR (name), scm_sym_app)) + return name; + else + return scm_append (SCM_LIST2 (module_prefix, name)); +} + +SCM +scm_make_module (SCM name) +{ + scm_c_issue_deprecation_warning ("`scm_make_module' is deprecated. " + "Use `scm_c_define_module instead."); + + return scm_apply (SCM_VARIABLE_REF (make_modules_in_var), + SCM_LIST2 (scm_the_root_module (), + scm_module_full_name (name)), + SCM_EOL); +} + +SCM +scm_ensure_user_module (SCM module) +{ + scm_c_issue_deprecation_warning ("`scm_ensure_user_module' is deprecated. " + "Use `scm_c_define_module instead."); + + scm_apply (SCM_VARIABLE_REF (beautify_user_module_x_var), + SCM_LIST1 (module), SCM_EOL); + return SCM_UNSPECIFIED; +} + +SCM +scm_load_scheme_module (SCM name) +{ + scm_c_issue_deprecation_warning ("`scm_load_scheme_module' is deprecated. " + "Use `scm_c_resolve_module instead."); + + return scm_apply (SCM_VARIABLE_REF (try_module_autoload_var), + SCM_LIST1 (name), SCM_EOL); +} + +#endif + /* Local Variables: c-file-style: "gnu" diff --git a/libguile/modules.h b/libguile/modules.h index 9869e42a0..c1074ee81 100644 --- a/libguile/modules.h +++ b/libguile/modules.h @@ -50,6 +50,9 @@ +extern int scm_module_system_booted_p; +extern SCM scm_module_tag; + #define SCM_MODULEP(OBJ) \ (SCM_NIMP (OBJ) && SCM_CELL_TYPE (OBJ) == scm_module_tag) @@ -82,31 +85,12 @@ extern scm_bits_t scm_tc16_eval_closure; -extern int scm_module_system_booted_p; -extern SCM scm_module_tag; - -extern SCM scm_the_root_module (void); extern SCM scm_current_module (void); -extern SCM scm_current_module_lookup_closure (void); -extern SCM scm_current_module_transformer (void); extern SCM scm_interaction_environment (void); extern SCM scm_set_current_module (SCM module); -extern SCM scm_make_module (SCM name); -extern SCM scm_ensure_user_module (SCM name); -extern SCM scm_module_lookup_closure (SCM module); -extern SCM scm_module_transformer (SCM module); -extern SCM scm_resolve_module (SCM name); -extern SCM scm_load_scheme_module (SCM name); -extern SCM scm_env_top_level (SCM env); -extern SCM scm_top_level_env (SCM thunk); -extern SCM scm_system_module_env_p (SCM env); -extern SCM scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep); -extern SCM scm_standard_eval_closure (SCM module); -extern SCM scm_standard_interface_eval_closure (SCM module); -extern SCM scm_get_pre_modules_obarray (void); -extern SCM scm_lookup_closure_module (SCM proc); -extern SCM scm_env_module (SCM env); +extern SCM scm_c_call_with_current_module (SCM module, + SCM (*func)(void *), void *data); extern SCM scm_c_lookup (const char *name); extern SCM scm_c_define (const char *name, SCM val); @@ -119,11 +103,42 @@ extern SCM scm_module_lookup (SCM module, SCM symbol); extern SCM scm_module_define (SCM module, SCM symbol, SCM val); extern SCM scm_module_reverse_lookup (SCM module, SCM variable); +extern SCM scm_c_resolve_module (const char *name); +extern SCM scm_resolve_module (SCM name); +extern SCM scm_c_define_module (const char *name, + void (*init)(void *), void *data); +extern void scm_c_use_module (const char *name); +extern void scm_c_export (const char *name, ...); + extern SCM scm_sym2var (SCM sym, SCM thunk, SCM definep); +extern SCM scm_module_lookup_closure (SCM module); +extern SCM scm_module_transformer (SCM module); +extern SCM scm_current_module_lookup_closure (void); +extern SCM scm_current_module_transformer (void); +extern SCM scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep); +extern SCM scm_standard_eval_closure (SCM module); +extern SCM scm_standard_interface_eval_closure (SCM module); +extern SCM scm_get_pre_modules_obarray (void); +extern SCM scm_lookup_closure_module (SCM proc); + +extern SCM scm_env_top_level (SCM env); +extern SCM scm_env_module (SCM env); +extern SCM scm_top_level_env (SCM thunk); + extern void scm_modules_prehistory (void); extern void scm_init_modules (void); +#if SCM_DEBUG_DEPRECATED == 0 + +extern SCM scm_the_root_module (void); +extern SCM scm_make_module (SCM name); +extern SCM scm_ensure_user_module (SCM name); +extern SCM scm_load_scheme_module (SCM name); +extern SCM scm_system_module_env_p (SCM env); + +#endif + #endif /* MODULESH */ /* From 9bba1435c379151536814bc779980873d1a94c4f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 19 May 2001 01:23:06 +0000 Subject: [PATCH 1128/2047] Undo last change. I have decided not to deprecate scm_system_module_env_p. --- libguile/stacks.c | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/libguile/stacks.c b/libguile/stacks.c index 61c262453..63bbda07b 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -360,10 +360,7 @@ narrow_stack (SCM stack,int inner,SCM inner_key,int outer,SCM outer_key) SCM m = s->frames[i].source; if ( SCM_MEMOIZEDP (m) && SCM_NIMP (SCM_MEMOIZED_ENV (m)) -#if SCM_DEBUG_DEPRECATED == 0 - && SCM_FALSEP (scm_system_module_env_p (SCM_MEMOIZED_ENV (m))) -#endif - ) + && SCM_FALSEP (scm_system_module_env_p (SCM_MEMOIZED_ENV (m)))) { /* Back up in order to include any non-source frames */ while (i > 0 From fce1a51729b95cb4daddba998a16a6e27ac2cdca Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 19 May 2001 01:23:23 +0000 Subject: [PATCH 1129/2047] Updated test for new micro version stuff. --- test-suite/tests/version.test | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/test-suite/tests/version.test b/test-suite/tests/version.test index 0f9531c2b..3bf6bb6fe 100644 --- a/test-suite/tests/version.test +++ b/test-suite/tests/version.test @@ -1,4 +1,4 @@ -;;;; chars.test --- test suite for Guile's char functions -*- scheme -*- +;;;; versions.test --- test suite for Guile's version functions -*- scheme -*- ;;;; Greg J. Badros ;;;; ;;;; Copyright (C) 2000 Free Software Foundation, Inc. @@ -23,4 +23,8 @@ (pass-if "version reporting works" (and (string? (major-version)) (string? (minor-version)) - (string=? (version) (string-append (major-version) "." (minor-version))))) + (string? (micro-version)) + (string=? (version) + (string-append (major-version) "." + (minor-version) "." + (micro-version))))) From 41bc3f429af36dbd88cdc6bd9d5510c0233bc21b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 19 May 2001 01:24:59 +0000 Subject: [PATCH 1130/2047] (s_scm_micro_version): Fix typo in FUNC_NAME, it refered to s_scm_minor_version previously. --- libguile/version.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/version.c b/libguile/version.c index 005bf6c76..8b7808a57 100644 --- a/libguile/version.c +++ b/libguile/version.c @@ -75,13 +75,13 @@ SCM_DEFINE (scm_minor_version, "minor-version", 0, 0, 0, } #undef FUNC_NAME -/* Return a Scheme string containing Guile's minor version number. */ +/* Return a Scheme string containing Guile's micro version number. */ SCM_DEFINE (scm_micro_version, "micro-version", 0, 0, 0, (), "Return a string containing Guile's micro version number.\n" "E.g., the 5 in \"1.6.5\".") -#define FUNC_NAME s_scm_minor_version +#define FUNC_NAME s_scm_micro_version { return scm_makfrom0str (GUILE_MICRO_VERSION); } From 21a13beb2062d908d5a82d7cb7a1b95772518212 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 19 May 2001 01:25:15 +0000 Subject: [PATCH 1131/2047] *** empty log message *** --- libguile/ChangeLog | 56 ++++++++++++++++++++++++++++++++++++++++++++ test-suite/ChangeLog | 4 ++++ 2 files changed, 60 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d6c9c183b..be323df59 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,59 @@ +2001-05-19 Marius Vollmer + + * version.c (s_scm_micro_version): Fix typo in FUNC_NAME, it + refered to s_scm_minor_version previously. + + * modules.h, modules.c: Moved around a lot of code so that + deprecated features appear at the bottom. + (root_module_lookup_closure, scm_sym_app, scm_sym_modules, + module_prefix, make_modules_in_var, beautify_user_module_x_var, + scm_the_root_module, scm_make_module, scm_ensure_user_module, + scm_load_scheme_module): Deprecated. + (scm_system_module_env_p): Return SCM_BOOL_T directly for + environments corresponding to the root module. + (convert_module_name, scm_c_resolve_module, + scm_c_call_with_current_module, scm_c_define_module, + scm_c_use_module, scm_c_export): New. + (the_root_module): New static variant of scm_the_root_module. Use + it everywhere instead of scm_the_root_module. + + * fluids.h, fluids.c (scm_internal_with_fluids): Deprecated. + (scm_c_with_fluids): Renamed from scm_internal_with_fluids. + (scm_c_with_fluid): New. + (scm_with_fluids): Use scm_c_with_fluids instead of + scm_internal_with_fluids. + + * goops.h, goops.c (scm_init_goops_builtins): Renamed from + `scm_init_goops'. Do not explicitly create/switch modules. + Return SCM_UNSPECIFIED. + (scm_init_goops): Only register `%init-goops-builtins' procedure. + (scm_load_goops): Use scm_c_resolve_module instead of + scm_resolve_module. + + * init.c (scm_init_guile_1): Call `scm_init_goops' instead of + `scm_init_oop_goops_goopscore_module'. Call `scm_init_rdelim' and + `scm_init_rw' prior to loading the startup files. + + * rdelim.h, rdelim.c: (scm_init_rdelim_builtins): Renamed from + scm_init_rdelim. Do not explicitly create/switch modules. + Return SCM_UNSPECIFIED. + (scm_init_rdelim): Only register `%init-rdelim-builtins' + procedure. + + * rw.c (scm_init_rw_builtins): Renamed from scm_init_rw. Do not + explicitly create/switch modules. Return SCM_UNSPECIFIED. + (scm_init_rw): Only register `%init-rw-builtins' procedure. + + * script.c (scm_shell): Evaluate the compiled switches in the + current module, not in the root module. + +2001-05-18 Marius Vollmer + + * fluids.c (scm_c_with_fluids): Rename from + scm_internal_with_fluids. + (scm_internal_with_fluids): Deprecated. + (scm_c_with_fluid): New. + 2001-05-17 Dirk Herrmann * print.h (PRINTH, SCM_PRINT_H): Renamed PRINTH to SCM_PRINT_H. diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 3b75a0234..2a94f203c 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2001-05-19 Marius Vollmer + + * tests/version.test: Updated test for new micro version stuff. + 2001-05-16 Martin Grabmueller * tests/srfi-13.test: More tests. From d866f4455b36c992fe9010724fcc880de24084a5 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 19 May 2001 01:30:02 +0000 Subject: [PATCH 1132/2047] (process-define-module): Do not call set-current-module. (define-module): Do it here, in the expansion. (top-repl): Do not define '(guile-user)' module and conditionally load `(ice-9 threads)' and/or `(ice-9 regex)' here. Do it on top-level as the last thing in boot-9.scm instead. (%load-path): Use `list' instead of `cons' to create a single element list when adding "." to it. (process-define-module, process-use-modules, module-export!): Add dummy definitions prior to booting the mdule system. --- ice-9/boot-9.scm | 37 ++++++++++++++++++++----------------- 1 file changed, 20 insertions(+), 17 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 6ff5cf5ea..1eb6a7e76 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1577,8 +1577,13 @@ ;; Get/create it. (make-modules-in (current-module) full-name)))))) -;; Cheat. +;; Cheat. These bindings are needed by modules.c, but we don't want +;; to move their real definition here because that would be unnatural. +;; (define try-module-autoload #f) +(define process-define-module #f) +(define process-use-modules #f) +(define module-export! #f) ;; This boots the module system. All bindings needed by modules.c ;; must have been defined by now. @@ -1724,7 +1729,6 @@ (append (cadr kws) exports))) (else (unrecognized kws)))))) - (set-current-module module) module)) ;;; {Autoload} @@ -2594,7 +2598,7 @@ (defmacro define-module args `(eval-case ((load-toplevel) - (process-define-module ',args)) + (set-current-module (process-define-module ',args))) (else (error "define-module can only be used at the top level")))) @@ -2817,18 +2821,6 @@ (module-ref the-root-module 'use-emacs-interface)) (load-emacs-interface)) - ;; Place the user in the guile-user module. - (process-define-module - '((guile-user) - :use-module (guile) ;so that bindings will be checked here first - :use-module (ice-9 session) - :use-module (ice-9 debug) - :autoload (ice-9 debugger) (debug))) ;load debugger on demand - (and (provided? 'threads) - (named-module-use! '(guile-user) '(ice-9 threads))) - (and (provided? 'regex) - (named-module-use! '(guile-user) '(ice-9 regex))) - (let ((old-handlers #f) (signals (if (provided? 'posix) `((,SIGINT . "User interrupt") @@ -2886,8 +2878,19 @@ (define exit-hook (make-hook)) -(define-module (guile)) +(append! %load-path (list ".")) -(append! %load-path (cons "." '())) +;; Place the user in the guile-user module. +;; +(define-module (guile-user) + :use-module (guile) ;so that bindings will be checked here first + :use-module (ice-9 session) + :use-module (ice-9 debug) + :autoload (ice-9 debugger) (debug)) ;load debugger on demand + +(if (provided? 'threads) + (use-modules (ice-9 threads))) +(if (provided? 'regex) + (use-modules (ice-9 regex))) ;;; boot-9.scm ends here From 872bd1947067fb46ef75b6d30e994bcdef3e17f8 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 19 May 2001 01:31:33 +0000 Subject: [PATCH 1133/2047] * psyntax.ss (build-lexical-var): Use gensym instead of gentemp. * match.scm: Likewise. * expect.scm: Likewise. * psyntax.pp: Regenerated. --- ice-9/expect.scm | 10 +++++----- ice-9/match.scm | 16 ++++++++-------- ice-9/psyntax.pp | 2 +- ice-9/psyntax.ss | 2 +- 4 files changed, 15 insertions(+), 15 deletions(-) diff --git a/ice-9/expect.scm b/ice-9/expect.scm index 8a8d1e9d0..2a0c1b954 100644 --- a/ice-9/expect.scm +++ b/ice-9/expect.scm @@ -45,10 +45,10 @@ ;;; expect: each test is a procedure which is applied to the accumulating ;;; string. (defmacro-public expect clauses - (let ((s (gentemp)) - (c (gentemp)) - (port (gentemp)) - (timeout (gentemp))) + (let ((s (gensym)) + (c (gensym)) + (port (gensym)) + (timeout (gensym))) `(let ((,s "") (,port (or expect-port (current-input-port))) ;; when timeout occurs, in floating point seconds. @@ -123,7 +123,7 @@ (cond ((null? tests) (list (reverse defs) `(expect ,@(reverse body)))) (else - (let ((rxname (gentemp))) + (let ((rxname (gensym))) (next-test (cdr tests) (cdr exprs) (cons `(,rxname (make-regexp diff --git a/ice-9/match.scm b/ice-9/match.scm index 2c08dc54c..ca10d7d37 100644 --- a/ice-9/match.scm +++ b/ice-9/match.scm @@ -177,7 +177,7 @@ (define match:andmap (lambda (f l) (if (null? l) (and) (and (f (car l)) (match:andmap f (cdr l)))))) (define match:syntax-err (lambda (obj msg) (slib:error msg obj))) (define match:disjoint-structure-tags (quote ())) -(define match:make-structure-tag (lambda (name) (if (or (eq? match:structure-control (quote disjoint)) match:runtime-structures) (let ((tag (gentemp))) (set! match:disjoint-structure-tags (cons tag match:disjoint-structure-tags)) tag) (string->symbol (string-append "<" (symbol->string name) ">"))))) +(define match:make-structure-tag (lambda (name) (if (or (eq? match:structure-control (quote disjoint)) match:runtime-structures) (let ((tag (gensym))) (set! match:disjoint-structure-tags (cons tag match:disjoint-structure-tags)) tag) (string->symbol (string-append "<" (symbol->string name) ">"))))) (define match:structure? (lambda (tag) (memq tag match:disjoint-structure-tags))) (define match:structure-control (quote vector)) (define match:set-structure-control (lambda (v) (set! match:structure-control v))) @@ -186,17 +186,17 @@ (define match:set-error-control (lambda (v) (set! match:error-control v))) (define match:disjoint-predicates (cons (quote null) (quote (pair? symbol? boolean? number? string? char? procedure? vector?)))) (define match:vector-structures (quote ())) -(define match:expanders (letrec ((genmatch (lambda (x clauses match-expr) (let* ((length>= (gentemp)) (eb-errf (error-maker match-expr)) (blist (car eb-errf)) (plist (map (lambda (c) (let* ((x (bound (validate-pattern (car c)))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gentemp)) (fail (and (pair? (cdr c)) (pair? (cadr c)) (eq? (caadr c) (quote =>)) (symbol? (cadadr c)) (pair? (cdadr c)) (null? (cddadr c)) (pair? (cddr c)) (cadadr c))) (bv2 (if fail (cons fail bv) bv)) (body (if fail (cddr c) (cdr c)))) (set! blist (cons (quasiquote ((unquote code) (lambda (unquote bv2) (unquote-splicing body)))) (append bindings blist))) (list p code bv (and fail (gentemp)) #f))) clauses)) (code (gen x (quote ()) plist (cdr eb-errf) length>= (gentemp)))) (unreachable plist match-expr) (inline-let (quasiquote (let (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) (unquote-splicing blist)) (unquote code))))))) (genletrec (lambda (pat exp body match-expr) (let* ((length>= (gentemp)) (eb-errf (error-maker match-expr)) (x (bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gentemp)) (plist (list (list p code bv #f #f))) (x (gentemp)) (m (gen x (quote ()) plist (cdr eb-errf) length>= (gentemp))) (gs (map (lambda (_) (gentemp)) bv))) (unreachable plist match-expr) (quasiquote (letrec (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) (unquote-splicing (map (lambda (v) (quasiquote ((unquote v) #f))) bv)) ((unquote x) (unquote exp)) ((unquote code) (lambda (unquote gs) (unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote v) (unquote g)))) bv gs)) (unquote-splicing body))) (unquote-splicing bindings) (unquote-splicing (car eb-errf))) (unquote m)))))) (gendefine (lambda (pat exp match-expr) (let* ((length>= (gentemp)) (eb-errf (error-maker match-expr)) (x (bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gentemp)) (plist (list (list p code bv #f #f))) (x (gentemp)) (m (gen x (quote ()) plist (cdr eb-errf) length>= (gentemp))) (gs (map (lambda (_) (gentemp)) bv))) (unreachable plist match-expr) (quasiquote (begin (unquote-splicing (map (lambda (v) (quasiquote (define (unquote v) #f))) bv)) (unquote (inline-let (quasiquote (let (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) ((unquote x) (unquote exp)) ((unquote code) (lambda (unquote gs) (unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote v) (unquote g)))) bv gs)) (cond (#f #f)))) (unquote-splicing bindings) (unquote-splicing (car eb-errf))) (unquote m)))))))))) (pattern-var? (lambda (x) (and (symbol? x) (not (dot-dot-k? x)) (not (memq x (quote (quasiquote quote unquote unquote-splicing ? _ $ = and or not set! get! ... ___))))))) (dot-dot-k? (lambda (s) (and (symbol? s) (if (memq s (quote (... ___))) 0 (let* ((s (symbol->string s)) (n (string-length s))) (and (<= 3 n) (memq (string-ref s 0) (quote (#\. #\_))) (memq (string-ref s 1) (quote (#\. #\_))) (match:andmap char-numeric? (string->list (substring s 2 n))) (string->number (substring s 2 n)))))))) (error-maker (lambda (match-expr) (cond ((eq? match:error-control (quote unspecified)) (cons (quote ()) (lambda (x) (quasiquote (cond (#f #f)))))) ((memq match:error-control (quote (error fail))) (cons (quote ()) (lambda (x) (quasiquote (match:error (unquote x)))))) ((eq? match:error-control (quote match)) (let ((errf (gentemp)) (arg (gentemp))) (cons (quasiquote (((unquote errf) (lambda ((unquote arg)) (match:error (unquote arg) (quote (unquote match-expr))))))) (lambda (x) (quasiquote ((unquote errf) (unquote x))))))) (else (match:syntax-err (quote (unspecified error fail match)) "invalid value for match:error-control, legal values are"))))) (unreachable (lambda (plist match-expr) (for-each (lambda (x) (if (not (car (cddddr x))) (begin (display "Warning: unreachable pattern ") (display (car x)) (display " in ") (display match-expr) (newline)))) plist))) (validate-pattern (lambda (pattern) (letrec ((simple? (lambda (x) (or (string? x) (boolean? x) (char? x) (number? x) (null? x)))) (ordinary (lambda (p) (let ((g157 (lambda (x y) (cons (ordinary x) (ordinary y))))) (if (simple? p) ((lambda (p) p) p) (if (equal? p (quote _)) ((lambda () (quote _))) (if (pattern-var? p) ((lambda (p) p) p) (if (pair? p) (if (equal? (car p) (quote quasiquote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) (quasi p)) (cadr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote quote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote ?)) (if (and (pair? (cdr p)) (list? (cddr p))) ((lambda (pred ps) (quasiquote (? (unquote pred) (unquote-splicing (map ordinary ps))))) (cadr p) (cddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote =)) (if (and (pair? (cdr p)) (pair? (cddr p)) (null? (cdddr p))) ((lambda (sel p) (quasiquote (= (unquote sel) (unquote (ordinary p))))) (cadr p) (caddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote and)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (and (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote or)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (or (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote not)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (not (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote $)) (if (and (pair? (cdr p)) (symbol? (cadr p)) (list? (cddr p))) ((lambda (r ps) (quasiquote ($ (unquote r) (unquote-splicing (map ordinary ps))))) (cadr p) (cddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote set!)) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote get!)) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote unquote)) (g157 (car p) (cdr p)) (if (equal? (car p) (quote unquote-splicing)) (g157 (car p) (cdr p)) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cddr p))) ((lambda (p ddk) (quasiquote ((unquote (ordinary p)) (unquote ddk)))) (car p) (cadr p)) (g157 (car p) (cdr p))))))))))))))) (if (vector? p) ((lambda (p) (let* ((pl (vector->list p)) (rpl (reverse pl))) (apply vector (if (and (not (null? rpl)) (dot-dot-k? (car rpl))) (reverse (cons (car rpl) (map ordinary (cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err pattern "syntax error in pattern"))))))))))) (quasi (lambda (p) (let ((g178 (lambda (x y) (cons (quasi x) (quasi y))))) (if (simple? p) ((lambda (p) p) p) (if (symbol? p) ((lambda (p) (quasiquote (quote (unquote p)))) p) (if (pair? p) (if (equal? (car p) (quote unquote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) (ordinary p)) (cadr p)) (g178 (car p) (cdr p))) (if (and (pair? (car p)) (equal? (caar p) (quote unquote-splicing)) (pair? (cdar p)) (null? (cddar p))) (if (null? (cdr p)) ((lambda (p) (ordinary p)) (cadar p)) ((lambda (p y) (append (ordlist p) (quasi y))) (cadar p) (cdr p))) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cddr p))) ((lambda (p ddk) (quasiquote ((unquote (quasi p)) (unquote ddk)))) (car p) (cadr p)) (g178 (car p) (cdr p))))) (if (vector? p) ((lambda (p) (let* ((pl (vector->list p)) (rpl (reverse pl))) (apply vector (if (dot-dot-k? (car rpl)) (reverse (cons (car rpl) (map quasi (cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err pattern "syntax error in pattern")))))))))) (ordlist (lambda (p) (cond ((null? p) (quote ())) ((pair? p) (cons (ordinary (car p)) (ordlist (cdr p)))) (else (match:syntax-err pattern "invalid use of unquote-splicing in pattern")))))) (ordinary pattern)))) (bound (lambda (pattern) (letrec ((pred-bodies (quote ())) (bound (lambda (p a k) (cond ((eq? (quote _) p) (k p a)) ((symbol? p) (if (memq p a) (match:syntax-err pattern "duplicate variable in pattern")) (k p (cons p a))) ((and (pair? p) (eq? (quote quote) (car p))) (k p a)) ((and (pair? p) (eq? (quote ?) (car p))) (cond ((not (null? (cddr p))) (bound (quasiquote (and (? (unquote (cadr p))) (unquote-splicing (cddr p)))) a k)) ((or (not (symbol? (cadr p))) (memq (cadr p) a)) (let ((g (gentemp))) (set! pred-bodies (cons (quasiquote ((unquote g) (unquote (cadr p)))) pred-bodies)) (k (quasiquote (? (unquote g))) a))) (else (k p a)))) ((and (pair? p) (eq? (quote =) (car p))) (cond ((or (not (symbol? (cadr p))) (memq (cadr p) a)) (let ((g (gentemp))) (set! pred-bodies (cons (quasiquote ((unquote g) (unquote (cadr p)))) pred-bodies)) (bound (quasiquote (= (unquote g) (unquote (caddr p)))) a k))) (else (bound (caddr p) a (lambda (p2 a) (k (quasiquote (= (unquote (cadr p)) (unquote p2))) a)))))) ((and (pair? p) (eq? (quote and) (car p))) (bound* (cdr p) a (lambda (p a) (k (quasiquote (and (unquote-splicing p))) a)))) ((and (pair? p) (eq? (quote or) (car p))) (bound (cadr p) a (lambda (first-p first-a) (let or* ((plist (cddr p)) (k (lambda (plist) (k (quasiquote (or (unquote first-p) (unquote-splicing plist))) first-a)))) (if (null? plist) (k plist) (bound (car plist) a (lambda (car-p car-a) (if (not (permutation car-a first-a)) (match:syntax-err pattern "variables of or-pattern differ in")) (or* (cdr plist) (lambda (cdr-p) (k (cons car-p cdr-p))))))))))) ((and (pair? p) (eq? (quote not) (car p))) (cond ((not (null? (cddr p))) (bound (quasiquote (not (or (unquote-splicing (cdr p))))) a k)) (else (bound (cadr p) a (lambda (p2 a2) (if (not (permutation a a2)) (match:syntax-err p "no variables allowed in")) (k (quasiquote (not (unquote p2))) a)))))) ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p))) (bound (car p) a (lambda (q b) (let ((bvars (find-prefix b a))) (k (quasiquote ((unquote q) (unquote (cadr p)) (unquote bvars) (unquote (gentemp)) (unquote (gentemp)) (unquote (map (lambda (_) (gentemp)) bvars)))) b))))) ((and (pair? p) (eq? (quote $) (car p))) (bound* (cddr p) a (lambda (p1 a) (k (quasiquote ($ (unquote (cadr p)) (unquote-splicing p1))) a)))) ((and (pair? p) (eq? (quote set!) (car p))) (if (memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((and (pair? p) (eq? (quote get!) (car p))) (if (memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((pair? p) (bound (car p) a (lambda (car-p a) (bound (cdr p) a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))) ((vector? p) (boundv (vector->list p) a (lambda (pl a) (k (list->vector pl) a)))) (else (k p a))))) (boundv (lambda (plist a k) (let ((g184 (lambda () (k plist a)))) (if (pair? plist) (if (and (pair? (cdr plist)) (dot-dot-k? (cadr plist)) (null? (cddr plist))) ((lambda () (bound plist a k))) (if (null? plist) (g184) ((lambda (x y) (bound x a (lambda (car-p a) (boundv y a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))) (car plist) (cdr plist)))) (if (null? plist) (g184) (match:error plist)))))) (bound* (lambda (plist a k) (if (null? plist) (k plist a) (bound (car plist) a (lambda (car-p a) (bound* (cdr plist) a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))))) (find-prefix (lambda (b a) (if (eq? b a) (quote ()) (cons (car b) (find-prefix (cdr b) a))))) (permutation (lambda (p1 p2) (and (= (length p1) (length p2)) (match:andmap (lambda (x1) (memq x1 p2)) p1))))) (bound pattern (quote ()) (lambda (p a) (list p (reverse a) pred-bodies)))))) (inline-let (lambda (let-exp) (letrec ((occ (lambda (x e) (let loop ((e e)) (cond ((pair? e) (+ (loop (car e)) (loop (cdr e)))) ((eq? x e) 1) (else 0))))) (subst (lambda (e old new) (let loop ((e e)) (cond ((pair? e) (cons (loop (car e)) (loop (cdr e)))) ((eq? old e) new) (else e))))) (const? (lambda (sexp) (or (symbol? sexp) (boolean? sexp) (string? sexp) (char? sexp) (number? sexp) (null? sexp) (and (pair? sexp) (eq? (car sexp) (quote quote)) (pair? (cdr sexp)) (symbol? (cadr sexp)) (null? (cddr sexp)))))) (isval? (lambda (sexp) (or (const? sexp) (and (pair? sexp) (memq (car sexp) (quote (lambda quote match-lambda match-lambda*))))))) (small? (lambda (sexp) (or (const? sexp) (and (pair? sexp) (eq? (car sexp) (quote lambda)) (pair? (cdr sexp)) (pair? (cddr sexp)) (const? (caddr sexp)) (null? (cdddr sexp))))))) (let loop ((b (cadr let-exp)) (new-b (quote ())) (e (caddr let-exp))) (cond ((null? b) (if (null? new-b) e (quasiquote (let (unquote (reverse new-b)) (unquote e))))) ((isval? (cadr (car b))) (let* ((x (caar b)) (n (occ x e))) (cond ((= 0 n) (loop (cdr b) new-b e)) ((or (= 1 n) (small? (cadr (car b)))) (loop (cdr b) new-b (subst e x (cadr (car b))))) (else (loop (cdr b) (cons (car b) new-b) e))))) (else (loop (cdr b) (cons (car b) new-b) e))))))) (gen (lambda (x sf plist erract length>= eta) (if (null? plist) (erract x) (let* ((v (quote ())) (val (lambda (x) (cdr (assq x v)))) (fail (lambda (sf) (gen x sf (cdr plist) erract length>= eta))) (success (lambda (sf) (set-car! (cddddr (car plist)) #t) (let* ((code (cadr (car plist))) (bv (caddr (car plist))) (fail-sym (cadddr (car plist)))) (if fail-sym (let ((ap (quasiquote ((unquote code) (unquote fail-sym) (unquote-splicing (map val bv)))))) (quasiquote (call-with-current-continuation (lambda ((unquote fail-sym)) (let (((unquote fail-sym) (lambda () ((unquote fail-sym) (unquote (fail sf)))))) (unquote ap)))))) (quasiquote ((unquote code) (unquote-splicing (map val bv))))))))) (let next ((p (caar plist)) (e x) (sf sf) (kf fail) (ks success)) (cond ((eq? (quote _) p) (ks sf)) ((symbol? p) (set! v (cons (cons p e) v)) (ks sf)) ((null? p) (emit (quasiquote (null? (unquote e))) sf kf ks)) ((equal? p (quote (quote ()))) (emit (quasiquote (null? (unquote e))) sf kf ks)) ((string? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((boolean? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((char? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((number? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((and (pair? p) (eq? (quote quote) (car p))) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((and (pair? p) (eq? (quote ?) (car p))) (let ((tst (quasiquote ((unquote (cadr p)) (unquote e))))) (emit tst sf kf ks))) ((and (pair? p) (eq? (quote =) (car p))) (next (caddr p) (quasiquote ((unquote (cadr p)) (unquote e))) sf kf ks)) ((and (pair? p) (eq? (quote and) (car p))) (let loop ((p (cdr p)) (sf sf)) (if (null? p) (ks sf) (next (car p) e sf kf (lambda (sf) (loop (cdr p) sf)))))) ((and (pair? p) (eq? (quote or) (car p))) (let ((or-v v)) (let loop ((p (cdr p)) (sf sf)) (if (null? p) (kf sf) (begin (set! v or-v) (next (car p) e sf (lambda (sf) (loop (cdr p) sf)) ks)))))) ((and (pair? p) (eq? (quote not) (car p))) (next (cadr p) e sf ks kf)) ((and (pair? p) (eq? (quote $) (car p))) (let* ((tag (cadr p)) (fields (cdr p)) (rlen (length fields)) (tst (quasiquote ((unquote (symbol-append tag (quote ?))) (unquote e))))) (emit tst sf kf (let rloop ((n 1)) (lambda (sf) (if (= n rlen) (ks sf) (next (list-ref fields n) (quasiquote ((unquote (symbol-append tag (quote -) n)) (unquote e))) sf kf (rloop (+ 1 n))))))))) ((and (pair? p) (eq? (quote set!) (car p))) (set! v (cons (cons (cadr p) (setter e p)) v)) (ks sf)) ((and (pair? p) (eq? (quote get!) (car p))) (set! v (cons (cons (cadr p) (getter e p)) v)) (ks sf)) ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p))) (emit (quasiquote (list? (unquote e))) sf kf (lambda (sf) (let* ((k (dot-dot-k? (cadr p))) (ks (lambda (sf) (let ((bound (list-ref p 2))) (cond ((eq? (car p) (quote _)) (ks sf)) ((null? bound) (let* ((ptst (next (car p) eta sf (lambda (sf) #f) (lambda (sf) #t))) (tst (if (and (pair? ptst) (symbol? (car ptst)) (pair? (cdr ptst)) (eq? eta (cadr ptst)) (null? (cddr ptst))) (car ptst) (quasiquote (lambda ((unquote eta)) (unquote ptst)))))) (assm (quasiquote (match:andmap (unquote tst) (unquote e))) (kf sf) (ks sf)))) ((and (symbol? (car p)) (equal? (list (car p)) bound)) (next (car p) e sf kf ks)) (else (let* ((gloop (list-ref p 3)) (ge (list-ref p 4)) (fresh (list-ref p 5)) (p1 (next (car p) (quasiquote (car (unquote ge))) sf kf (lambda (sf) (quasiquote ((unquote gloop) (cdr (unquote ge)) (unquote-splicing (map (lambda (b f) (quasiquote (cons (unquote (val b)) (unquote f)))) bound fresh)))))))) (set! v (append (map cons bound (map (lambda (x) (quasiquote (reverse (unquote x)))) fresh)) v)) (quasiquote (let (unquote gloop) (((unquote ge) (unquote e)) (unquote-splicing (map (lambda (x) (quasiquote ((unquote x) (quote ())))) fresh))) (if (null? (unquote ge)) (unquote (ks sf)) (unquote p1))))))))))) (case k ((0) (ks sf)) ((1) (emit (quasiquote (pair? (unquote e))) sf kf ks)) (else (emit (quasiquote (((unquote length>=) (unquote k)) (unquote e))) sf kf ks))))))) ((pair? p) (emit (quasiquote (pair? (unquote e))) sf kf (lambda (sf) (next (car p) (add-a e) sf kf (lambda (sf) (next (cdr p) (add-d e) sf kf ks)))))) ((and (vector? p) (>= (vector-length p) 6) (dot-dot-k? (vector-ref p (- (vector-length p) 5)))) (let* ((vlen (- (vector-length p) 6)) (k (dot-dot-k? (vector-ref p (+ vlen 1)))) (minlen (+ vlen k)) (bound (vector-ref p (+ vlen 2)))) (emit (quasiquote (vector? (unquote e))) sf kf (lambda (sf) (assm (quasiquote (>= (vector-length (unquote e)) (unquote minlen))) (kf sf) ((let vloop ((n 0)) (lambda (sf) (cond ((not (= n vlen)) (next (vector-ref p n) (quasiquote (vector-ref (unquote e) (unquote n))) sf kf (vloop (+ 1 n)))) ((eq? (vector-ref p vlen) (quote _)) (ks sf)) (else (let* ((gloop (vector-ref p (+ vlen 3))) (ind (vector-ref p (+ vlen 4))) (fresh (vector-ref p (+ vlen 5))) (p1 (next (vector-ref p vlen) (quasiquote (vector-ref (unquote e) (unquote ind))) sf kf (lambda (sf) (quasiquote ((unquote gloop) (- (unquote ind) 1) (unquote-splicing (map (lambda (b f) (quasiquote (cons (unquote (val b)) (unquote f)))) bound fresh)))))))) (set! v (append (map cons bound fresh) v)) (quasiquote (let (unquote gloop) (((unquote ind) (- (vector-length (unquote e)) 1)) (unquote-splicing (map (lambda (x) (quasiquote ((unquote x) (quote ())))) fresh))) (if (> (unquote minlen) (unquote ind)) (unquote (ks sf)) (unquote p1))))))))) sf)))))) ((vector? p) (let ((vlen (vector-length p))) (emit (quasiquote (vector? (unquote e))) sf kf (lambda (sf) (emit (quasiquote (equal? (vector-length (unquote e)) (unquote vlen))) sf kf (let vloop ((n 0)) (lambda (sf) (if (= n vlen) (ks sf) (next (vector-ref p n) (quasiquote (vector-ref (unquote e) (unquote n))) sf kf (vloop (+ 1 n))))))))))) (else (display "FATAL ERROR IN PATTERN MATCHER") (newline) (error #f "THIS NEVER HAPPENS")))))))) (emit (lambda (tst sf kf ks) (cond ((in tst sf) (ks sf)) ((in (quasiquote (not (unquote tst))) sf) (kf sf)) (else (let* ((e (cadr tst)) (implied (cond ((eq? (car tst) (quote equal?)) (let ((p (caddr tst))) (cond ((string? p) (quasiquote ((string? (unquote e))))) ((boolean? p) (quasiquote ((boolean? (unquote e))))) ((char? p) (quasiquote ((char? (unquote e))))) ((number? p) (quasiquote ((number? (unquote e))))) ((and (pair? p) (eq? (quote quote) (car p))) (quasiquote ((symbol? (unquote e))))) (else (quote ()))))) ((eq? (car tst) (quote null?)) (quasiquote ((list? (unquote e))))) ((vec-structure? tst) (quasiquote ((vector? (unquote e))))) (else (quote ())))) (not-imp (case (car tst) ((list?) (quasiquote ((not (null? (unquote e)))))) (else (quote ())))) (s (ks (cons tst (append implied sf)))) (k (kf (cons (quasiquote (not (unquote tst))) (append not-imp sf))))) (assm tst k s)))))) (assm (lambda (tst f s) (cond ((equal? s f) s) ((and (eq? s #t) (eq? f #f)) tst) ((and (eq? (car tst) (quote pair?)) (memq match:error-control (quote (unspecified fail))) (memq (car f) (quote (cond match:error))) (guarantees s (cadr tst))) s) ((and (pair? s) (eq? (car s) (quote if)) (equal? (cadddr s) f)) (if (eq? (car (cadr s)) (quote and)) (quasiquote (if (and (unquote tst) (unquote-splicing (cdr (cadr s)))) (unquote (caddr s)) (unquote f))) (quasiquote (if (and (unquote tst) (unquote (cadr s))) (unquote (caddr s)) (unquote f))))) ((and (pair? s) (equal? (car s) (quote call-with-current-continuation)) (pair? (cdr s)) (pair? (cadr s)) (equal? (caadr s) (quote lambda)) (pair? (cdadr s)) (pair? (cadadr s)) (null? (cdr (cadadr s))) (pair? (cddadr s)) (pair? (car (cddadr s))) (equal? (caar (cddadr s)) (quote let)) (pair? (cdar (cddadr s))) (pair? (cadar (cddadr s))) (pair? (caadar (cddadr s))) (pair? (cdr (caadar (cddadr s)))) (pair? (cadr (caadar (cddadr s)))) (equal? (caadr (caadar (cddadr s))) (quote lambda)) (pair? (cdadr (caadar (cddadr s)))) (null? (cadadr (caadar (cddadr s)))) (pair? (cddadr (caadar (cddadr s)))) (pair? (car (cddadr (caadar (cddadr s))))) (pair? (cdar (cddadr (caadar (cddadr s))))) (null? (cddar (cddadr (caadar (cddadr s))))) (null? (cdr (cddadr (caadar (cddadr s))))) (null? (cddr (caadar (cddadr s)))) (null? (cdadar (cddadr s))) (pair? (cddar (cddadr s))) (null? (cdddar (cddadr s))) (null? (cdr (cddadr s))) (null? (cddr s)) (equal? f (cadar (cddadr (caadar (cddadr s)))))) (let ((k (car (cadadr s))) (fail (car (caadar (cddadr s)))) (s2 (caddar (cddadr s)))) (quasiquote (call-with-current-continuation (lambda ((unquote k)) (let (((unquote fail) (lambda () ((unquote k) (unquote f))))) (unquote (assm tst (quasiquote ((unquote fail))) s2)))))))) ((and #f (pair? s) (equal? (car s) (quote let)) (pair? (cdr s)) (pair? (cadr s)) (pair? (caadr s)) (pair? (cdaadr s)) (pair? (car (cdaadr s))) (equal? (caar (cdaadr s)) (quote lambda)) (pair? (cdar (cdaadr s))) (null? (cadar (cdaadr s))) (pair? (cddar (cdaadr s))) (null? (cdddar (cdaadr s))) (null? (cdr (cdaadr s))) (null? (cdadr s)) (pair? (cddr s)) (null? (cdddr s)) (equal? (caddar (cdaadr s)) f)) (let ((fail (caaadr s)) (s2 (caddr s))) (quasiquote (let (((unquote fail) (lambda () (unquote f)))) (unquote (assm tst (quasiquote ((unquote fail))) s2)))))) (else (quasiquote (if (unquote tst) (unquote s) (unquote f))))))) (guarantees (lambda (code x) (let ((a (add-a x)) (d (add-d x))) (let loop ((code code)) (cond ((not (pair? code)) #f) ((memq (car code) (quote (cond match:error))) #t) ((or (equal? code a) (equal? code d)) #t) ((eq? (car code) (quote if)) (or (loop (cadr code)) (and (loop (caddr code)) (loop (cadddr code))))) ((eq? (car code) (quote lambda)) #f) ((and (eq? (car code) (quote let)) (symbol? (cadr code))) #f) (else (or (loop (car code)) (loop (cdr code))))))))) (in (lambda (e l) (or (member e l) (and (eq? (car e) (quote list?)) (or (member (quasiquote (null? (unquote (cadr e)))) l) (member (quasiquote (pair? (unquote (cadr e)))) l))) (and (eq? (car e) (quote not)) (let* ((srch (cadr e)) (const-class (equal-test? srch))) (cond (const-class (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (equal? const-class (car x)))) (equal? x (quasiquote (not ((unquote const-class) (unquote (cadr srch)))))) (and (equal? (cadr x) (cadr srch)) (equal-test? x) (not (equal? (caddr srch) (caddr x)))) (mem (cdr l))))))) ((disjoint? srch) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (equal? (car x) (car srch)))) (mem (cdr l))))))) ((eq? (car srch) (quote list?)) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (memq (car x) (quote (list? pair? null?))))) (mem (cdr l))))))) ((vec-structure? srch) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (or (disjoint? x) (vec-structure? x)) (not (equal? (car x) (quote vector?))) (not (equal? (car x) (car srch)))) (equal? x (quasiquote (not (vector? (unquote (cadr srch)))))) (mem (cdr l))))))) (else #f))))))) (equal-test? (lambda (tst) (and (eq? (car tst) (quote equal?)) (let ((p (caddr tst))) (cond ((string? p) (quote string?)) ((boolean? p) (quote boolean?)) ((char? p) (quote char?)) ((number? p) (quote number?)) ((and (pair? p) (pair? (cdr p)) (null? (cddr p)) (eq? (quote quote) (car p)) (symbol? (cadr p))) (quote symbol?)) (else #f)))))) (disjoint? (lambda (tst) (memq (car tst) match:disjoint-predicates))) (vec-structure? (lambda (tst) (memq (car tst) match:vector-structures))) (add-a (lambda (a) (let ((new (and (pair? a) (assq (car a) c---rs)))) (if new (cons (cadr new) (cdr a)) (quasiquote (car (unquote a))))))) (add-d (lambda (a) (let ((new (and (pair? a) (assq (car a) c---rs)))) (if new (cons (cddr new) (cdr a)) (quasiquote (cdr (unquote a))))))) (c---rs (quote ((car caar . cdar) (cdr cadr . cddr) (caar caaar . cdaar) (cadr caadr . cdadr) (cdar cadar . cddar) (cddr caddr . cdddr) (caaar caaaar . cdaaar) (caadr caaadr . cdaadr) (cadar caadar . cdadar) (caddr caaddr . cdaddr) (cdaar cadaar . cddaar) (cdadr cadadr . cddadr) (cddar caddar . cdddar) (cdddr cadddr . cddddr)))) (setter (lambda (e p) (let ((mk-setter (lambda (s) (symbol-append (quote set-) s (quote !))))) (cond ((not (pair? e)) (match:syntax-err p "unnested set! pattern")) ((eq? (car e) (quote vector-ref)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (vector-set! x (unquote (caddr e)) y))))) ((eq? (car e) (quote unbox)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-box! x y))))) ((eq? (car e) (quote car)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-car! x y))))) ((eq? (car e) (quote cdr)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-cdr! x y))))) ((let ((a (assq (car e) get-c---rs))) (and a (quasiquote (let ((x ((unquote (cadr a)) (unquote (cadr e))))) (lambda (y) ((unquote (mk-setter (cddr a))) x y))))))) (else (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) ((unquote (mk-setter (car e))) x y))))))))) (getter (lambda (e p) (cond ((not (pair? e)) (match:syntax-err p "unnested get! pattern")) ((eq? (car e) (quote vector-ref)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (vector-ref x (unquote (caddr e))))))) ((eq? (car e) (quote unbox)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (unbox x))))) ((eq? (car e) (quote car)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (car x))))) ((eq? (car e) (quote cdr)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (cdr x))))) ((let ((a (assq (car e) get-c---rs))) (and a (quasiquote (let ((x ((unquote (cadr a)) (unquote (cadr e))))) (lambda () ((unquote (cddr a)) x))))))) (else (quasiquote (let ((x (unquote (cadr e)))) (lambda () ((unquote (car e)) x)))))))) (get-c---rs (quote ((caar car . car) (cadr cdr . car) (cdar car . cdr) (cddr cdr . cdr) (caaar caar . car) (caadr cadr . car) (cadar cdar . car) (caddr cddr . car) (cdaar caar . cdr) (cdadr cadr . cdr) (cddar cdar . cdr) (cdddr cddr . cdr) (caaaar caaar . car) (caaadr caadr . car) (caadar cadar . car) (caaddr caddr . car) (cadaar cdaar . car) (cadadr cdadr . car) (caddar cddar . car) (cadddr cdddr . car) (cdaaar caaar . cdr) (cdaadr caadr . cdr) (cdadar cadar . cdr) (cdaddr caddr . cdr) (cddaar cdaar . cdr) (cddadr cdadr . cdr) (cdddar cddar . cdr) (cddddr cdddr . cdr)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l))))) (rac (lambda (l) (if (null? (cdr l)) (car l) (rac (cdr l))))) (rdc (lambda (l) (if (null? (cdr l)) (quote ()) (cons (car l) (rdc (cdr l))))))) (list genmatch genletrec gendefine pattern-var?))) -(defmacro match args (cond ((and (list? args) (<= 1 (length args)) (match:andmap (lambda (y) (and (list? y) (<= 2 (length y)))) (cdr args))) (let* ((exp (car args)) (clauses (cdr args)) (e (if (symbol? exp) exp (gentemp)))) (if (symbol? exp) ((car match:expanders) e clauses (quasiquote (match (unquote-splicing args)))) (quasiquote (let (((unquote e) (unquote exp))) (unquote ((car match:expanders) e clauses (quasiquote (match (unquote-splicing args)))))))))) (else (match:syntax-err (quasiquote (match (unquote-splicing args))) "syntax error in")))) -(defmacro match-lambda args (if (and (list? args) (match:andmap (lambda (g195) (if (and (pair? g195) (list? (cdr g195))) (pair? (cdr g195)) #f)) args)) ((lambda () (let ((e (gentemp))) (quasiquote (lambda ((unquote e)) (match (unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err (quasiquote (match-lambda (unquote-splicing args))) "syntax error in"))))) -(defmacro match-lambda* args (if (and (list? args) (match:andmap (lambda (g203) (if (and (pair? g203) (list? (cdr g203))) (pair? (cdr g203)) #f)) args)) ((lambda () (let ((e (gentemp))) (quasiquote (lambda (unquote e) (match (unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err (quasiquote (match-lambda* (unquote-splicing args))) "syntax error in"))))) -(defmacro match-let args (let ((g227 (lambda (pat exp body) (quasiquote (match (unquote exp) ((unquote pat) (unquote-splicing body)))))) (g223 (lambda (pat exp body) (let ((g (map (lambda (x) (gentemp)) pat)) (vpattern (list->vector pat))) (quasiquote (let (unquote (map list g exp)) (match (vector (unquote-splicing g)) ((unquote vpattern) (unquote-splicing body)))))))) (g215 (lambda () (match:syntax-err (quasiquote (match-let (unquote-splicing args))) "syntax error in"))) (g214 (lambda (p1 e1 p2 e2 body) (let ((g1 (gentemp)) (g2 (gentemp))) (quasiquote (let (((unquote g1) (unquote e1)) ((unquote g2) (unquote e2))) (match (cons (unquote g1) (unquote g2)) (((unquote p1) unquote p2) (unquote-splicing body)))))))) (g205 (cadddr match:expanders))) (if (pair? args) (if (symbol? (car args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g230 ((g231 (cadr args)) (g229 (quote ())) (g228 (quote ()))) (if (null? g231) (if (and (list? (cddr args)) (pair? (cddr args))) ((lambda (name pat exp body) (if (match:andmap (cadddr match:expanders) pat) (quasiquote (let (unquote-splicing args))) (quasiquote (letrec (((unquote name) (match-lambda* ((unquote pat) (unquote-splicing body))))) ((unquote name) (unquote-splicing exp)))))) (car args) (reverse g228) (reverse g229) (cddr args)) (g215)) (if (and (pair? (car g231)) (pair? (cdar g231)) (null? (cddar g231))) (g230 (cdr g231) (cons (cadar g231) g229) (cons (caar g231) g228)) (g215)))) (g215)) (if (list? (car args)) (if (match:andmap (lambda (g236) (if (and (pair? g236) (g205 (car g236)) (pair? (cdr g236))) (null? (cddr g236)) #f)) (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda () (quasiquote (let (unquote-splicing args))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaar args) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g214 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (if (pair? (car args)) (if (and (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaar args) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g214 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (g215)))) (g215)))) +(define match:expanders (letrec ((genmatch (lambda (x clauses match-expr) (let* ((length>= (gensym)) (eb-errf (error-maker match-expr)) (blist (car eb-errf)) (plist (map (lambda (c) (let* ((x (bound (validate-pattern (car c)))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gensym)) (fail (and (pair? (cdr c)) (pair? (cadr c)) (eq? (caadr c) (quote =>)) (symbol? (cadadr c)) (pair? (cdadr c)) (null? (cddadr c)) (pair? (cddr c)) (cadadr c))) (bv2 (if fail (cons fail bv) bv)) (body (if fail (cddr c) (cdr c)))) (set! blist (cons (quasiquote ((unquote code) (lambda (unquote bv2) (unquote-splicing body)))) (append bindings blist))) (list p code bv (and fail (gensym)) #f))) clauses)) (code (gen x (quote ()) plist (cdr eb-errf) length>= (gensym)))) (unreachable plist match-expr) (inline-let (quasiquote (let (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) (unquote-splicing blist)) (unquote code))))))) (genletrec (lambda (pat exp body match-expr) (let* ((length>= (gensym)) (eb-errf (error-maker match-expr)) (x (bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gensym)) (plist (list (list p code bv #f #f))) (x (gensym)) (m (gen x (quote ()) plist (cdr eb-errf) length>= (gensym))) (gs (map (lambda (_) (gensym)) bv))) (unreachable plist match-expr) (quasiquote (letrec (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) (unquote-splicing (map (lambda (v) (quasiquote ((unquote v) #f))) bv)) ((unquote x) (unquote exp)) ((unquote code) (lambda (unquote gs) (unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote v) (unquote g)))) bv gs)) (unquote-splicing body))) (unquote-splicing bindings) (unquote-splicing (car eb-errf))) (unquote m)))))) (gendefine (lambda (pat exp match-expr) (let* ((length>= (gensym)) (eb-errf (error-maker match-expr)) (x (bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gensym)) (plist (list (list p code bv #f #f))) (x (gensym)) (m (gen x (quote ()) plist (cdr eb-errf) length>= (gensym))) (gs (map (lambda (_) (gensym)) bv))) (unreachable plist match-expr) (quasiquote (begin (unquote-splicing (map (lambda (v) (quasiquote (define (unquote v) #f))) bv)) (unquote (inline-let (quasiquote (let (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) ((unquote x) (unquote exp)) ((unquote code) (lambda (unquote gs) (unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote v) (unquote g)))) bv gs)) (cond (#f #f)))) (unquote-splicing bindings) (unquote-splicing (car eb-errf))) (unquote m)))))))))) (pattern-var? (lambda (x) (and (symbol? x) (not (dot-dot-k? x)) (not (memq x (quote (quasiquote quote unquote unquote-splicing ? _ $ = and or not set! get! ... ___))))))) (dot-dot-k? (lambda (s) (and (symbol? s) (if (memq s (quote (... ___))) 0 (let* ((s (symbol->string s)) (n (string-length s))) (and (<= 3 n) (memq (string-ref s 0) (quote (#\. #\_))) (memq (string-ref s 1) (quote (#\. #\_))) (match:andmap char-numeric? (string->list (substring s 2 n))) (string->number (substring s 2 n)))))))) (error-maker (lambda (match-expr) (cond ((eq? match:error-control (quote unspecified)) (cons (quote ()) (lambda (x) (quasiquote (cond (#f #f)))))) ((memq match:error-control (quote (error fail))) (cons (quote ()) (lambda (x) (quasiquote (match:error (unquote x)))))) ((eq? match:error-control (quote match)) (let ((errf (gensym)) (arg (gensym))) (cons (quasiquote (((unquote errf) (lambda ((unquote arg)) (match:error (unquote arg) (quote (unquote match-expr))))))) (lambda (x) (quasiquote ((unquote errf) (unquote x))))))) (else (match:syntax-err (quote (unspecified error fail match)) "invalid value for match:error-control, legal values are"))))) (unreachable (lambda (plist match-expr) (for-each (lambda (x) (if (not (car (cddddr x))) (begin (display "Warning: unreachable pattern ") (display (car x)) (display " in ") (display match-expr) (newline)))) plist))) (validate-pattern (lambda (pattern) (letrec ((simple? (lambda (x) (or (string? x) (boolean? x) (char? x) (number? x) (null? x)))) (ordinary (lambda (p) (let ((g157 (lambda (x y) (cons (ordinary x) (ordinary y))))) (if (simple? p) ((lambda (p) p) p) (if (equal? p (quote _)) ((lambda () (quote _))) (if (pattern-var? p) ((lambda (p) p) p) (if (pair? p) (if (equal? (car p) (quote quasiquote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) (quasi p)) (cadr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote quote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote ?)) (if (and (pair? (cdr p)) (list? (cddr p))) ((lambda (pred ps) (quasiquote (? (unquote pred) (unquote-splicing (map ordinary ps))))) (cadr p) (cddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote =)) (if (and (pair? (cdr p)) (pair? (cddr p)) (null? (cdddr p))) ((lambda (sel p) (quasiquote (= (unquote sel) (unquote (ordinary p))))) (cadr p) (caddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote and)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (and (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote or)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (or (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote not)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (not (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote $)) (if (and (pair? (cdr p)) (symbol? (cadr p)) (list? (cddr p))) ((lambda (r ps) (quasiquote ($ (unquote r) (unquote-splicing (map ordinary ps))))) (cadr p) (cddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote set!)) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote get!)) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote unquote)) (g157 (car p) (cdr p)) (if (equal? (car p) (quote unquote-splicing)) (g157 (car p) (cdr p)) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cddr p))) ((lambda (p ddk) (quasiquote ((unquote (ordinary p)) (unquote ddk)))) (car p) (cadr p)) (g157 (car p) (cdr p))))))))))))))) (if (vector? p) ((lambda (p) (let* ((pl (vector->list p)) (rpl (reverse pl))) (apply vector (if (and (not (null? rpl)) (dot-dot-k? (car rpl))) (reverse (cons (car rpl) (map ordinary (cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err pattern "syntax error in pattern"))))))))))) (quasi (lambda (p) (let ((g178 (lambda (x y) (cons (quasi x) (quasi y))))) (if (simple? p) ((lambda (p) p) p) (if (symbol? p) ((lambda (p) (quasiquote (quote (unquote p)))) p) (if (pair? p) (if (equal? (car p) (quote unquote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) (ordinary p)) (cadr p)) (g178 (car p) (cdr p))) (if (and (pair? (car p)) (equal? (caar p) (quote unquote-splicing)) (pair? (cdar p)) (null? (cddar p))) (if (null? (cdr p)) ((lambda (p) (ordinary p)) (cadar p)) ((lambda (p y) (append (ordlist p) (quasi y))) (cadar p) (cdr p))) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cddr p))) ((lambda (p ddk) (quasiquote ((unquote (quasi p)) (unquote ddk)))) (car p) (cadr p)) (g178 (car p) (cdr p))))) (if (vector? p) ((lambda (p) (let* ((pl (vector->list p)) (rpl (reverse pl))) (apply vector (if (dot-dot-k? (car rpl)) (reverse (cons (car rpl) (map quasi (cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err pattern "syntax error in pattern")))))))))) (ordlist (lambda (p) (cond ((null? p) (quote ())) ((pair? p) (cons (ordinary (car p)) (ordlist (cdr p)))) (else (match:syntax-err pattern "invalid use of unquote-splicing in pattern")))))) (ordinary pattern)))) (bound (lambda (pattern) (letrec ((pred-bodies (quote ())) (bound (lambda (p a k) (cond ((eq? (quote _) p) (k p a)) ((symbol? p) (if (memq p a) (match:syntax-err pattern "duplicate variable in pattern")) (k p (cons p a))) ((and (pair? p) (eq? (quote quote) (car p))) (k p a)) ((and (pair? p) (eq? (quote ?) (car p))) (cond ((not (null? (cddr p))) (bound (quasiquote (and (? (unquote (cadr p))) (unquote-splicing (cddr p)))) a k)) ((or (not (symbol? (cadr p))) (memq (cadr p) a)) (let ((g (gensym))) (set! pred-bodies (cons (quasiquote ((unquote g) (unquote (cadr p)))) pred-bodies)) (k (quasiquote (? (unquote g))) a))) (else (k p a)))) ((and (pair? p) (eq? (quote =) (car p))) (cond ((or (not (symbol? (cadr p))) (memq (cadr p) a)) (let ((g (gensym))) (set! pred-bodies (cons (quasiquote ((unquote g) (unquote (cadr p)))) pred-bodies)) (bound (quasiquote (= (unquote g) (unquote (caddr p)))) a k))) (else (bound (caddr p) a (lambda (p2 a) (k (quasiquote (= (unquote (cadr p)) (unquote p2))) a)))))) ((and (pair? p) (eq? (quote and) (car p))) (bound* (cdr p) a (lambda (p a) (k (quasiquote (and (unquote-splicing p))) a)))) ((and (pair? p) (eq? (quote or) (car p))) (bound (cadr p) a (lambda (first-p first-a) (let or* ((plist (cddr p)) (k (lambda (plist) (k (quasiquote (or (unquote first-p) (unquote-splicing plist))) first-a)))) (if (null? plist) (k plist) (bound (car plist) a (lambda (car-p car-a) (if (not (permutation car-a first-a)) (match:syntax-err pattern "variables of or-pattern differ in")) (or* (cdr plist) (lambda (cdr-p) (k (cons car-p cdr-p))))))))))) ((and (pair? p) (eq? (quote not) (car p))) (cond ((not (null? (cddr p))) (bound (quasiquote (not (or (unquote-splicing (cdr p))))) a k)) (else (bound (cadr p) a (lambda (p2 a2) (if (not (permutation a a2)) (match:syntax-err p "no variables allowed in")) (k (quasiquote (not (unquote p2))) a)))))) ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p))) (bound (car p) a (lambda (q b) (let ((bvars (find-prefix b a))) (k (quasiquote ((unquote q) (unquote (cadr p)) (unquote bvars) (unquote (gensym)) (unquote (gensym)) (unquote (map (lambda (_) (gensym)) bvars)))) b))))) ((and (pair? p) (eq? (quote $) (car p))) (bound* (cddr p) a (lambda (p1 a) (k (quasiquote ($ (unquote (cadr p)) (unquote-splicing p1))) a)))) ((and (pair? p) (eq? (quote set!) (car p))) (if (memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((and (pair? p) (eq? (quote get!) (car p))) (if (memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((pair? p) (bound (car p) a (lambda (car-p a) (bound (cdr p) a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))) ((vector? p) (boundv (vector->list p) a (lambda (pl a) (k (list->vector pl) a)))) (else (k p a))))) (boundv (lambda (plist a k) (let ((g184 (lambda () (k plist a)))) (if (pair? plist) (if (and (pair? (cdr plist)) (dot-dot-k? (cadr plist)) (null? (cddr plist))) ((lambda () (bound plist a k))) (if (null? plist) (g184) ((lambda (x y) (bound x a (lambda (car-p a) (boundv y a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))) (car plist) (cdr plist)))) (if (null? plist) (g184) (match:error plist)))))) (bound* (lambda (plist a k) (if (null? plist) (k plist a) (bound (car plist) a (lambda (car-p a) (bound* (cdr plist) a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))))) (find-prefix (lambda (b a) (if (eq? b a) (quote ()) (cons (car b) (find-prefix (cdr b) a))))) (permutation (lambda (p1 p2) (and (= (length p1) (length p2)) (match:andmap (lambda (x1) (memq x1 p2)) p1))))) (bound pattern (quote ()) (lambda (p a) (list p (reverse a) pred-bodies)))))) (inline-let (lambda (let-exp) (letrec ((occ (lambda (x e) (let loop ((e e)) (cond ((pair? e) (+ (loop (car e)) (loop (cdr e)))) ((eq? x e) 1) (else 0))))) (subst (lambda (e old new) (let loop ((e e)) (cond ((pair? e) (cons (loop (car e)) (loop (cdr e)))) ((eq? old e) new) (else e))))) (const? (lambda (sexp) (or (symbol? sexp) (boolean? sexp) (string? sexp) (char? sexp) (number? sexp) (null? sexp) (and (pair? sexp) (eq? (car sexp) (quote quote)) (pair? (cdr sexp)) (symbol? (cadr sexp)) (null? (cddr sexp)))))) (isval? (lambda (sexp) (or (const? sexp) (and (pair? sexp) (memq (car sexp) (quote (lambda quote match-lambda match-lambda*))))))) (small? (lambda (sexp) (or (const? sexp) (and (pair? sexp) (eq? (car sexp) (quote lambda)) (pair? (cdr sexp)) (pair? (cddr sexp)) (const? (caddr sexp)) (null? (cdddr sexp))))))) (let loop ((b (cadr let-exp)) (new-b (quote ())) (e (caddr let-exp))) (cond ((null? b) (if (null? new-b) e (quasiquote (let (unquote (reverse new-b)) (unquote e))))) ((isval? (cadr (car b))) (let* ((x (caar b)) (n (occ x e))) (cond ((= 0 n) (loop (cdr b) new-b e)) ((or (= 1 n) (small? (cadr (car b)))) (loop (cdr b) new-b (subst e x (cadr (car b))))) (else (loop (cdr b) (cons (car b) new-b) e))))) (else (loop (cdr b) (cons (car b) new-b) e))))))) (gen (lambda (x sf plist erract length>= eta) (if (null? plist) (erract x) (let* ((v (quote ())) (val (lambda (x) (cdr (assq x v)))) (fail (lambda (sf) (gen x sf (cdr plist) erract length>= eta))) (success (lambda (sf) (set-car! (cddddr (car plist)) #t) (let* ((code (cadr (car plist))) (bv (caddr (car plist))) (fail-sym (cadddr (car plist)))) (if fail-sym (let ((ap (quasiquote ((unquote code) (unquote fail-sym) (unquote-splicing (map val bv)))))) (quasiquote (call-with-current-continuation (lambda ((unquote fail-sym)) (let (((unquote fail-sym) (lambda () ((unquote fail-sym) (unquote (fail sf)))))) (unquote ap)))))) (quasiquote ((unquote code) (unquote-splicing (map val bv))))))))) (let next ((p (caar plist)) (e x) (sf sf) (kf fail) (ks success)) (cond ((eq? (quote _) p) (ks sf)) ((symbol? p) (set! v (cons (cons p e) v)) (ks sf)) ((null? p) (emit (quasiquote (null? (unquote e))) sf kf ks)) ((equal? p (quote (quote ()))) (emit (quasiquote (null? (unquote e))) sf kf ks)) ((string? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((boolean? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((char? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((number? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((and (pair? p) (eq? (quote quote) (car p))) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((and (pair? p) (eq? (quote ?) (car p))) (let ((tst (quasiquote ((unquote (cadr p)) (unquote e))))) (emit tst sf kf ks))) ((and (pair? p) (eq? (quote =) (car p))) (next (caddr p) (quasiquote ((unquote (cadr p)) (unquote e))) sf kf ks)) ((and (pair? p) (eq? (quote and) (car p))) (let loop ((p (cdr p)) (sf sf)) (if (null? p) (ks sf) (next (car p) e sf kf (lambda (sf) (loop (cdr p) sf)))))) ((and (pair? p) (eq? (quote or) (car p))) (let ((or-v v)) (let loop ((p (cdr p)) (sf sf)) (if (null? p) (kf sf) (begin (set! v or-v) (next (car p) e sf (lambda (sf) (loop (cdr p) sf)) ks)))))) ((and (pair? p) (eq? (quote not) (car p))) (next (cadr p) e sf ks kf)) ((and (pair? p) (eq? (quote $) (car p))) (let* ((tag (cadr p)) (fields (cdr p)) (rlen (length fields)) (tst (quasiquote ((unquote (symbol-append tag (quote ?))) (unquote e))))) (emit tst sf kf (let rloop ((n 1)) (lambda (sf) (if (= n rlen) (ks sf) (next (list-ref fields n) (quasiquote ((unquote (symbol-append tag (quote -) n)) (unquote e))) sf kf (rloop (+ 1 n))))))))) ((and (pair? p) (eq? (quote set!) (car p))) (set! v (cons (cons (cadr p) (setter e p)) v)) (ks sf)) ((and (pair? p) (eq? (quote get!) (car p))) (set! v (cons (cons (cadr p) (getter e p)) v)) (ks sf)) ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p))) (emit (quasiquote (list? (unquote e))) sf kf (lambda (sf) (let* ((k (dot-dot-k? (cadr p))) (ks (lambda (sf) (let ((bound (list-ref p 2))) (cond ((eq? (car p) (quote _)) (ks sf)) ((null? bound) (let* ((ptst (next (car p) eta sf (lambda (sf) #f) (lambda (sf) #t))) (tst (if (and (pair? ptst) (symbol? (car ptst)) (pair? (cdr ptst)) (eq? eta (cadr ptst)) (null? (cddr ptst))) (car ptst) (quasiquote (lambda ((unquote eta)) (unquote ptst)))))) (assm (quasiquote (match:andmap (unquote tst) (unquote e))) (kf sf) (ks sf)))) ((and (symbol? (car p)) (equal? (list (car p)) bound)) (next (car p) e sf kf ks)) (else (let* ((gloop (list-ref p 3)) (ge (list-ref p 4)) (fresh (list-ref p 5)) (p1 (next (car p) (quasiquote (car (unquote ge))) sf kf (lambda (sf) (quasiquote ((unquote gloop) (cdr (unquote ge)) (unquote-splicing (map (lambda (b f) (quasiquote (cons (unquote (val b)) (unquote f)))) bound fresh)))))))) (set! v (append (map cons bound (map (lambda (x) (quasiquote (reverse (unquote x)))) fresh)) v)) (quasiquote (let (unquote gloop) (((unquote ge) (unquote e)) (unquote-splicing (map (lambda (x) (quasiquote ((unquote x) (quote ())))) fresh))) (if (null? (unquote ge)) (unquote (ks sf)) (unquote p1))))))))))) (case k ((0) (ks sf)) ((1) (emit (quasiquote (pair? (unquote e))) sf kf ks)) (else (emit (quasiquote (((unquote length>=) (unquote k)) (unquote e))) sf kf ks))))))) ((pair? p) (emit (quasiquote (pair? (unquote e))) sf kf (lambda (sf) (next (car p) (add-a e) sf kf (lambda (sf) (next (cdr p) (add-d e) sf kf ks)))))) ((and (vector? p) (>= (vector-length p) 6) (dot-dot-k? (vector-ref p (- (vector-length p) 5)))) (let* ((vlen (- (vector-length p) 6)) (k (dot-dot-k? (vector-ref p (+ vlen 1)))) (minlen (+ vlen k)) (bound (vector-ref p (+ vlen 2)))) (emit (quasiquote (vector? (unquote e))) sf kf (lambda (sf) (assm (quasiquote (>= (vector-length (unquote e)) (unquote minlen))) (kf sf) ((let vloop ((n 0)) (lambda (sf) (cond ((not (= n vlen)) (next (vector-ref p n) (quasiquote (vector-ref (unquote e) (unquote n))) sf kf (vloop (+ 1 n)))) ((eq? (vector-ref p vlen) (quote _)) (ks sf)) (else (let* ((gloop (vector-ref p (+ vlen 3))) (ind (vector-ref p (+ vlen 4))) (fresh (vector-ref p (+ vlen 5))) (p1 (next (vector-ref p vlen) (quasiquote (vector-ref (unquote e) (unquote ind))) sf kf (lambda (sf) (quasiquote ((unquote gloop) (- (unquote ind) 1) (unquote-splicing (map (lambda (b f) (quasiquote (cons (unquote (val b)) (unquote f)))) bound fresh)))))))) (set! v (append (map cons bound fresh) v)) (quasiquote (let (unquote gloop) (((unquote ind) (- (vector-length (unquote e)) 1)) (unquote-splicing (map (lambda (x) (quasiquote ((unquote x) (quote ())))) fresh))) (if (> (unquote minlen) (unquote ind)) (unquote (ks sf)) (unquote p1))))))))) sf)))))) ((vector? p) (let ((vlen (vector-length p))) (emit (quasiquote (vector? (unquote e))) sf kf (lambda (sf) (emit (quasiquote (equal? (vector-length (unquote e)) (unquote vlen))) sf kf (let vloop ((n 0)) (lambda (sf) (if (= n vlen) (ks sf) (next (vector-ref p n) (quasiquote (vector-ref (unquote e) (unquote n))) sf kf (vloop (+ 1 n))))))))))) (else (display "FATAL ERROR IN PATTERN MATCHER") (newline) (error #f "THIS NEVER HAPPENS")))))))) (emit (lambda (tst sf kf ks) (cond ((in tst sf) (ks sf)) ((in (quasiquote (not (unquote tst))) sf) (kf sf)) (else (let* ((e (cadr tst)) (implied (cond ((eq? (car tst) (quote equal?)) (let ((p (caddr tst))) (cond ((string? p) (quasiquote ((string? (unquote e))))) ((boolean? p) (quasiquote ((boolean? (unquote e))))) ((char? p) (quasiquote ((char? (unquote e))))) ((number? p) (quasiquote ((number? (unquote e))))) ((and (pair? p) (eq? (quote quote) (car p))) (quasiquote ((symbol? (unquote e))))) (else (quote ()))))) ((eq? (car tst) (quote null?)) (quasiquote ((list? (unquote e))))) ((vec-structure? tst) (quasiquote ((vector? (unquote e))))) (else (quote ())))) (not-imp (case (car tst) ((list?) (quasiquote ((not (null? (unquote e)))))) (else (quote ())))) (s (ks (cons tst (append implied sf)))) (k (kf (cons (quasiquote (not (unquote tst))) (append not-imp sf))))) (assm tst k s)))))) (assm (lambda (tst f s) (cond ((equal? s f) s) ((and (eq? s #t) (eq? f #f)) tst) ((and (eq? (car tst) (quote pair?)) (memq match:error-control (quote (unspecified fail))) (memq (car f) (quote (cond match:error))) (guarantees s (cadr tst))) s) ((and (pair? s) (eq? (car s) (quote if)) (equal? (cadddr s) f)) (if (eq? (car (cadr s)) (quote and)) (quasiquote (if (and (unquote tst) (unquote-splicing (cdr (cadr s)))) (unquote (caddr s)) (unquote f))) (quasiquote (if (and (unquote tst) (unquote (cadr s))) (unquote (caddr s)) (unquote f))))) ((and (pair? s) (equal? (car s) (quote call-with-current-continuation)) (pair? (cdr s)) (pair? (cadr s)) (equal? (caadr s) (quote lambda)) (pair? (cdadr s)) (pair? (cadadr s)) (null? (cdr (cadadr s))) (pair? (cddadr s)) (pair? (car (cddadr s))) (equal? (caar (cddadr s)) (quote let)) (pair? (cdar (cddadr s))) (pair? (cadar (cddadr s))) (pair? (caadar (cddadr s))) (pair? (cdr (caadar (cddadr s)))) (pair? (cadr (caadar (cddadr s)))) (equal? (caadr (caadar (cddadr s))) (quote lambda)) (pair? (cdadr (caadar (cddadr s)))) (null? (cadadr (caadar (cddadr s)))) (pair? (cddadr (caadar (cddadr s)))) (pair? (car (cddadr (caadar (cddadr s))))) (pair? (cdar (cddadr (caadar (cddadr s))))) (null? (cddar (cddadr (caadar (cddadr s))))) (null? (cdr (cddadr (caadar (cddadr s))))) (null? (cddr (caadar (cddadr s)))) (null? (cdadar (cddadr s))) (pair? (cddar (cddadr s))) (null? (cdddar (cddadr s))) (null? (cdr (cddadr s))) (null? (cddr s)) (equal? f (cadar (cddadr (caadar (cddadr s)))))) (let ((k (car (cadadr s))) (fail (car (caadar (cddadr s)))) (s2 (caddar (cddadr s)))) (quasiquote (call-with-current-continuation (lambda ((unquote k)) (let (((unquote fail) (lambda () ((unquote k) (unquote f))))) (unquote (assm tst (quasiquote ((unquote fail))) s2)))))))) ((and #f (pair? s) (equal? (car s) (quote let)) (pair? (cdr s)) (pair? (cadr s)) (pair? (caadr s)) (pair? (cdaadr s)) (pair? (car (cdaadr s))) (equal? (caar (cdaadr s)) (quote lambda)) (pair? (cdar (cdaadr s))) (null? (cadar (cdaadr s))) (pair? (cddar (cdaadr s))) (null? (cdddar (cdaadr s))) (null? (cdr (cdaadr s))) (null? (cdadr s)) (pair? (cddr s)) (null? (cdddr s)) (equal? (caddar (cdaadr s)) f)) (let ((fail (caaadr s)) (s2 (caddr s))) (quasiquote (let (((unquote fail) (lambda () (unquote f)))) (unquote (assm tst (quasiquote ((unquote fail))) s2)))))) (else (quasiquote (if (unquote tst) (unquote s) (unquote f))))))) (guarantees (lambda (code x) (let ((a (add-a x)) (d (add-d x))) (let loop ((code code)) (cond ((not (pair? code)) #f) ((memq (car code) (quote (cond match:error))) #t) ((or (equal? code a) (equal? code d)) #t) ((eq? (car code) (quote if)) (or (loop (cadr code)) (and (loop (caddr code)) (loop (cadddr code))))) ((eq? (car code) (quote lambda)) #f) ((and (eq? (car code) (quote let)) (symbol? (cadr code))) #f) (else (or (loop (car code)) (loop (cdr code))))))))) (in (lambda (e l) (or (member e l) (and (eq? (car e) (quote list?)) (or (member (quasiquote (null? (unquote (cadr e)))) l) (member (quasiquote (pair? (unquote (cadr e)))) l))) (and (eq? (car e) (quote not)) (let* ((srch (cadr e)) (const-class (equal-test? srch))) (cond (const-class (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (equal? const-class (car x)))) (equal? x (quasiquote (not ((unquote const-class) (unquote (cadr srch)))))) (and (equal? (cadr x) (cadr srch)) (equal-test? x) (not (equal? (caddr srch) (caddr x)))) (mem (cdr l))))))) ((disjoint? srch) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (equal? (car x) (car srch)))) (mem (cdr l))))))) ((eq? (car srch) (quote list?)) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (memq (car x) (quote (list? pair? null?))))) (mem (cdr l))))))) ((vec-structure? srch) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (or (disjoint? x) (vec-structure? x)) (not (equal? (car x) (quote vector?))) (not (equal? (car x) (car srch)))) (equal? x (quasiquote (not (vector? (unquote (cadr srch)))))) (mem (cdr l))))))) (else #f))))))) (equal-test? (lambda (tst) (and (eq? (car tst) (quote equal?)) (let ((p (caddr tst))) (cond ((string? p) (quote string?)) ((boolean? p) (quote boolean?)) ((char? p) (quote char?)) ((number? p) (quote number?)) ((and (pair? p) (pair? (cdr p)) (null? (cddr p)) (eq? (quote quote) (car p)) (symbol? (cadr p))) (quote symbol?)) (else #f)))))) (disjoint? (lambda (tst) (memq (car tst) match:disjoint-predicates))) (vec-structure? (lambda (tst) (memq (car tst) match:vector-structures))) (add-a (lambda (a) (let ((new (and (pair? a) (assq (car a) c---rs)))) (if new (cons (cadr new) (cdr a)) (quasiquote (car (unquote a))))))) (add-d (lambda (a) (let ((new (and (pair? a) (assq (car a) c---rs)))) (if new (cons (cddr new) (cdr a)) (quasiquote (cdr (unquote a))))))) (c---rs (quote ((car caar . cdar) (cdr cadr . cddr) (caar caaar . cdaar) (cadr caadr . cdadr) (cdar cadar . cddar) (cddr caddr . cdddr) (caaar caaaar . cdaaar) (caadr caaadr . cdaadr) (cadar caadar . cdadar) (caddr caaddr . cdaddr) (cdaar cadaar . cddaar) (cdadr cadadr . cddadr) (cddar caddar . cdddar) (cdddr cadddr . cddddr)))) (setter (lambda (e p) (let ((mk-setter (lambda (s) (symbol-append (quote set-) s (quote !))))) (cond ((not (pair? e)) (match:syntax-err p "unnested set! pattern")) ((eq? (car e) (quote vector-ref)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (vector-set! x (unquote (caddr e)) y))))) ((eq? (car e) (quote unbox)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-box! x y))))) ((eq? (car e) (quote car)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-car! x y))))) ((eq? (car e) (quote cdr)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-cdr! x y))))) ((let ((a (assq (car e) get-c---rs))) (and a (quasiquote (let ((x ((unquote (cadr a)) (unquote (cadr e))))) (lambda (y) ((unquote (mk-setter (cddr a))) x y))))))) (else (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) ((unquote (mk-setter (car e))) x y))))))))) (getter (lambda (e p) (cond ((not (pair? e)) (match:syntax-err p "unnested get! pattern")) ((eq? (car e) (quote vector-ref)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (vector-ref x (unquote (caddr e))))))) ((eq? (car e) (quote unbox)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (unbox x))))) ((eq? (car e) (quote car)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (car x))))) ((eq? (car e) (quote cdr)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (cdr x))))) ((let ((a (assq (car e) get-c---rs))) (and a (quasiquote (let ((x ((unquote (cadr a)) (unquote (cadr e))))) (lambda () ((unquote (cddr a)) x))))))) (else (quasiquote (let ((x (unquote (cadr e)))) (lambda () ((unquote (car e)) x)))))))) (get-c---rs (quote ((caar car . car) (cadr cdr . car) (cdar car . cdr) (cddr cdr . cdr) (caaar caar . car) (caadr cadr . car) (cadar cdar . car) (caddr cddr . car) (cdaar caar . cdr) (cdadr cadr . cdr) (cddar cdar . cdr) (cdddr cddr . cdr) (caaaar caaar . car) (caaadr caadr . car) (caadar cadar . car) (caaddr caddr . car) (cadaar cdaar . car) (cadadr cdadr . car) (caddar cddar . car) (cadddr cdddr . car) (cdaaar caaar . cdr) (cdaadr caadr . cdr) (cdadar cadar . cdr) (cdaddr caddr . cdr) (cddaar cdaar . cdr) (cddadr cdadr . cdr) (cdddar cddar . cdr) (cddddr cdddr . cdr)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l))))) (rac (lambda (l) (if (null? (cdr l)) (car l) (rac (cdr l))))) (rdc (lambda (l) (if (null? (cdr l)) (quote ()) (cons (car l) (rdc (cdr l))))))) (list genmatch genletrec gendefine pattern-var?))) +(defmacro match args (cond ((and (list? args) (<= 1 (length args)) (match:andmap (lambda (y) (and (list? y) (<= 2 (length y)))) (cdr args))) (let* ((exp (car args)) (clauses (cdr args)) (e (if (symbol? exp) exp (gensym)))) (if (symbol? exp) ((car match:expanders) e clauses (quasiquote (match (unquote-splicing args)))) (quasiquote (let (((unquote e) (unquote exp))) (unquote ((car match:expanders) e clauses (quasiquote (match (unquote-splicing args)))))))))) (else (match:syntax-err (quasiquote (match (unquote-splicing args))) "syntax error in")))) +(defmacro match-lambda args (if (and (list? args) (match:andmap (lambda (g195) (if (and (pair? g195) (list? (cdr g195))) (pair? (cdr g195)) #f)) args)) ((lambda () (let ((e (gensym))) (quasiquote (lambda ((unquote e)) (match (unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err (quasiquote (match-lambda (unquote-splicing args))) "syntax error in"))))) +(defmacro match-lambda* args (if (and (list? args) (match:andmap (lambda (g203) (if (and (pair? g203) (list? (cdr g203))) (pair? (cdr g203)) #f)) args)) ((lambda () (let ((e (gensym))) (quasiquote (lambda (unquote e) (match (unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err (quasiquote (match-lambda* (unquote-splicing args))) "syntax error in"))))) +(defmacro match-let args (let ((g227 (lambda (pat exp body) (quasiquote (match (unquote exp) ((unquote pat) (unquote-splicing body)))))) (g223 (lambda (pat exp body) (let ((g (map (lambda (x) (gensym)) pat)) (vpattern (list->vector pat))) (quasiquote (let (unquote (map list g exp)) (match (vector (unquote-splicing g)) ((unquote vpattern) (unquote-splicing body)))))))) (g215 (lambda () (match:syntax-err (quasiquote (match-let (unquote-splicing args))) "syntax error in"))) (g214 (lambda (p1 e1 p2 e2 body) (let ((g1 (gensym)) (g2 (gensym))) (quasiquote (let (((unquote g1) (unquote e1)) ((unquote g2) (unquote e2))) (match (cons (unquote g1) (unquote g2)) (((unquote p1) unquote p2) (unquote-splicing body)))))))) (g205 (cadddr match:expanders))) (if (pair? args) (if (symbol? (car args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g230 ((g231 (cadr args)) (g229 (quote ())) (g228 (quote ()))) (if (null? g231) (if (and (list? (cddr args)) (pair? (cddr args))) ((lambda (name pat exp body) (if (match:andmap (cadddr match:expanders) pat) (quasiquote (let (unquote-splicing args))) (quasiquote (letrec (((unquote name) (match-lambda* ((unquote pat) (unquote-splicing body))))) ((unquote name) (unquote-splicing exp)))))) (car args) (reverse g228) (reverse g229) (cddr args)) (g215)) (if (and (pair? (car g231)) (pair? (cdar g231)) (null? (cddar g231))) (g230 (cdr g231) (cons (cadar g231) g229) (cons (caar g231) g228)) (g215)))) (g215)) (if (list? (car args)) (if (match:andmap (lambda (g236) (if (and (pair? g236) (g205 (car g236)) (pair? (cdr g236))) (null? (cddr g236)) #f)) (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda () (quasiquote (let (unquote-splicing args))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaar args) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g214 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (if (pair? (car args)) (if (and (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaar args) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g214 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (g215)))) (g215)))) (defmacro match-let* args (let ((g245 (lambda () (match:syntax-err (quasiquote (match-let* (unquote-splicing args))) "syntax error in")))) (if (pair? args) (if (null? (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda (body) (quasiquote (let* (unquote-splicing args)))) (cdr args)) (g245)) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args)) (list? (cdar args)) (list? (cdr args)) (pair? (cdr args))) ((lambda (pat exp rest body) (if ((cadddr match:expanders) pat) (quasiquote (let (((unquote pat) (unquote exp))) (match-let* (unquote rest) (unquote-splicing body)))) (quasiquote (match (unquote exp) ((unquote pat) (match-let* (unquote rest) (unquote-splicing body))))))) (caaar args) (cadaar args) (cdar args) (cdr args)) (g245))) (g245)))) (defmacro match-letrec args (let ((g269 (cadddr match:expanders)) (g268 (lambda (p1 e1 p2 e2 body) (quasiquote (match-letrec ((((unquote p1) unquote p2) (cons (unquote e1) (unquote e2)))) (unquote-splicing body))))) (g264 (lambda () (match:syntax-err (quasiquote (match-letrec (unquote-splicing args))) "syntax error in"))) (g263 (lambda (pat exp body) (quasiquote (match-letrec (((unquote (list->vector pat)) (vector (unquote-splicing exp)))) (unquote-splicing body))))) (g255 (lambda (pat exp body) ((cadr match:expanders) pat exp body (quasiquote (match-letrec (((unquote pat) (unquote exp))) (unquote-splicing body))))))) (if (pair? args) (if (list? (car args)) (if (match:andmap (lambda (g275) (if (and (pair? g275) (g269 (car g275)) (pair? (cdr g275))) (null? (cddr g275)) #f)) (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda () (quasiquote (letrec (unquote-splicing args))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g255 (caaar args) (cadaar args) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g268 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (if (pair? (car args)) (if (and (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g255 (caaar args) (cadaar args) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g268 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (g264))) (g264)))) (defmacro match-define args (let ((g279 (cadddr match:expanders)) (g278 (lambda () (match:syntax-err (quasiquote (match-define (unquote-splicing args))) "syntax error in")))) (if (pair? args) (if (g279 (car args)) (if (and (pair? (cdr args)) (null? (cddr args))) ((lambda () (quasiquote (begin (define (unquote-splicing args)))))) (g278)) (if (and (pair? (cdr args)) (null? (cddr args))) ((lambda (pat exp) ((caddr match:expanders) pat exp (quasiquote (match-define (unquote-splicing args))))) (car args) (cadr args)) (g278))) (g278)))) (define match:runtime-structures #f) (define match:set-runtime-structures (lambda (v) (set! match:runtime-structures v))) (define match:primitive-vector? vector?) -(defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda () #t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda (x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x))))) (mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x)) (match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let ((g296 (lambda () (match:syntax-err (quasiquote ((unquote defstruct) (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (symbol? (car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args)) (symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args)) (g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate fields) (let* ((selectors (map selector-name fields)) (mutators (map mutator-name fields)) (tag (if match:runtime-structures (gentemp) (quasiquote (quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq? match:structure-control (quote disjoint)) (quote match:primitive-vector?)) ((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq? match:structure-control (quote disjoint)) (if (eq? vector? match:primitive-vector?) (set! vector? (lambda (v) (and (match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol? (vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not (memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates (cons predicate match:disjoint-predicates)))) ((eq? match:structure-control (quote vector)) (if (not (memq predicate match:vector-structures)) (set! match:vector-structures (cons predicate match:vector-structures)))) (else (match:syntax-err (quote (vector disjoint)) "invalid value for match:structure-control, legal values are"))) (quasiquote (begin (unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define (unquote constructor) (lambda (unquote selectors) (vector (unquote tag) (unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and ((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing (filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda (obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing (filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n) (lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators)))))) (car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299)) (g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296))))) +(defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda () #t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda (x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x))))) (mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x)) (match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let ((g296 (lambda () (match:syntax-err (quasiquote ((unquote defstruct) (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (symbol? (car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args)) (symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args)) (g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate fields) (let* ((selectors (map selector-name fields)) (mutators (map mutator-name fields)) (tag (if match:runtime-structures (gensym) (quasiquote (quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq? match:structure-control (quote disjoint)) (quote match:primitive-vector?)) ((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq? match:structure-control (quote disjoint)) (if (eq? vector? match:primitive-vector?) (set! vector? (lambda (v) (and (match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol? (vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not (memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates (cons predicate match:disjoint-predicates)))) ((eq? match:structure-control (quote vector)) (if (not (memq predicate match:vector-structures)) (set! match:vector-structures (cons predicate match:vector-structures)))) (else (match:syntax-err (quote (vector disjoint)) "invalid value for match:structure-control, legal values are"))) (quasiquote (begin (unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define (unquote constructor) (lambda (unquote selectors) (vector (unquote tag) (unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and ((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing (filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda (obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing (filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n) (lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators)))))) (car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299)) (g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296))))) (defmacro define-structure args (let ((g311 (lambda () (match:syntax-err (quasiquote (define-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g308 ((g309 (cadr args)) (g307 (quote ())) (g306 (quote ()))) (if (null? g309) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let ((mk-id (lambda (id) (if (and (pair? id) (equal? (car id) (quote @)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda (x) x) (cadr id)) ((lambda () (quasiquote (! (unquote id))))))))) (quasiquote (define-const-structure ((unquote name) (unquote-splicing (map mk-id id1))) (unquote (map (lambda (id v) (quasiquote ((unquote (mk-id id)) (unquote v)))) id2 val)))))) (caar args) (cdar args) (reverse g306) (reverse g307)) (g311)) (if (and (pair? (car g309)) (pair? (cdar g309)) (null? (cddar g309))) (g308 (cdr g309) (cons (cadar g309) g307) (cons (caar g309) g306)) (g311)))) (g311))) (g311)))) -(defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol? id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda () #f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator? (lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote (define-const-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if (and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args)) (g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor (symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin ((unquote defstruct) (unquote name) (unquote raw-constructor) (unquote predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if (has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i)) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))) (symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2) (quasiquote (define (unquote constructor) (unquote raw-constructor))) (let* ((make-fresh (lambda (x) (if (eq? (quote _) x) (gentemp) x))) (names1 (map make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1) (let* (unquote (map list names2 val)) ((unquote raw-constructor) (unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing (filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _)) #f (quasiquote (define (unquote (symbol-append name (quote -) (field-name field))) (unquote (symbol-append name (quote -) i)))))) id1id2)) (unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq? (field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote (define (unquote (symbol-append (quote set-) name (quote -) (field-name field) (quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331)) (g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333)) (null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons (car g329) g327)) (g335)))) (g335))) (g335))))) +(defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol? id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda () #f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator? (lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote (define-const-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if (and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args)) (g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor (symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin ((unquote defstruct) (unquote name) (unquote raw-constructor) (unquote predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if (has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i)) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))) (symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2) (quasiquote (define (unquote constructor) (unquote raw-constructor))) (let* ((make-fresh (lambda (x) (if (eq? (quote _) x) (gensym) x))) (names1 (map make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1) (let* (unquote (map list names2 val)) ((unquote raw-constructor) (unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing (filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _)) #f (quasiquote (define (unquote (symbol-append name (quote -) (field-name field))) (unquote (symbol-append name (quote -) i)))))) id1id2)) (unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq? (field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote (define (unquote (symbol-append (quote set-) name (quote -) (field-name field) (quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331)) (g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333)) (null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons (car g329) g327)) (g335)))) (g335))) (g335))))) diff --git a/ice-9/psyntax.pp b/ice-9/psyntax.pp index 605403444..8f90b9a55 100644 --- a/ice-9/psyntax.pp +++ b/ice-9/psyntax.pp @@ -1,4 +1,4 @@ -(letrec ((lambda-var-list116 (lambda (vars323) (let lvl324 ((vars325 vars323) (ls326 (quote ())) (w327 (quote (())))) (cond ((pair? vars325) (lvl324 (cdr vars325) (cons (wrap95 (car vars325) w327) ls326) w327)) ((id?67 vars325) (cons (wrap95 vars325 w327) ls326)) ((null? vars325) ls326) ((syntax-object?53 vars325) (lvl324 (syntax-object-expression54 vars325) ls326 (join-wraps86 w327 (syntax-object-wrap55 vars325)))) ((annotation?42 vars325) (lvl324 (annotation-expression vars325) ls326 w327)) (else (cons vars325 ls326)))))) (gen-var115 (lambda (id328) (let ((id329 (if (syntax-object?53 id328) (syntax-object-expression54 id328) id328))) (if (annotation?42 id329) (gentemp (symbol->string (annotation-expression id329)) generated-symbols) (gentemp (symbol->string id329) generated-symbols))))) (strip114 (lambda (x330 w331) (if (memq (quote top) (wrap-marks70 w331)) (if (or (annotation?42 x330) (and (pair? x330) (annotation?42 (car x330)))) (strip-annotation113 x330 (quote #f)) x330) (let f332 ((x333 x330)) (cond ((syntax-object?53 x333) (strip114 (syntax-object-expression54 x333) (syntax-object-wrap55 x333))) ((pair? x333) (let ((a334 (f332 (car x333))) (d335 (f332 (cdr x333)))) (if (and (eq? a334 (car x333)) (eq? d335 (cdr x333))) x333 (cons a334 d335)))) ((vector? x333) (let ((old336 (vector->list x333))) (let ((new337 (map f332 old336))) (if (andmap eq? old336 new337) x333 (list->vector new337))))) (else x333)))))) (strip-annotation113 (lambda (x338 parent339) (cond ((pair? x338) (let ((new340 (cons (quote #f) (quote #f)))) (begin (when parent339 (set-annotation-stripped! parent339 new340)) (set-car! new340 (strip-annotation113 (car x338) (quote #f))) (set-cdr! new340 (strip-annotation113 (cdr x338) (quote #f))) new340))) ((annotation?42 x338) (or (annotation-stripped x338) (strip-annotation113 (annotation-expression x338) x338))) ((vector? x338) (let ((new341 (make-vector (vector-length x338)))) (begin (when parent339 (set-annotation-stripped! parent339 new341)) (let loop342 ((i343 (- (vector-length x338) (quote 1)))) (unless (fx<41 i343 (quote 0)) (vector-set! new341 i343 (strip-annotation113 (vector-ref x338 i343) (quote #f))) (loop342 (fx-39 i343 (quote 1))))) new341))) (else x338)))) (ellipsis?112 (lambda (x344) (and (nonsymbol-id?66 x344) (free-id=?90 x344 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))))))) (chi-void111 (lambda () (list (quote void)))) (eval-local-transformer110 (lambda (expanded345) (let ((p346 (local-eval-hook44 expanded345))) (if (procedure? p346) p346 (syntax-error p346 (quote "nonprocedure transfomer")))))) (chi-local-syntax109 (lambda (rec?347 e348 r349 w350 s351 k352) ((lambda (tmp353) ((lambda (tmp354) (if tmp354 (apply (lambda (_355 id356 val357 e1358 e2359) (let ((ids360 id356)) (if (not (valid-bound-ids?92 ids360)) (syntax-error e348 (quote "duplicate bound keyword in")) (let ((labels362 (gen-labels73 ids360))) (let ((new-w363 (make-binding-wrap84 ids360 labels362 w350))) (k352 (cons e1358 e2359) (extend-env61 labels362 (let ((w365 (if rec?347 new-w363 w350)) (trans-r366 (macros-only-env63 r349))) (map (lambda (x367) (cons (quote macro) (eval-local-transformer110 (chi103 x367 trans-r366 w365)))) val357)) r349) new-w363 s351)))))) tmp354) ((lambda (_369) (syntax-error (source-wrap96 e348 w350 s351))) tmp353))) (syntax-dispatch tmp353 (quote (any #(each (any any)) any . each-any))))) e348))) (chi-lambda-clause108 (lambda (e370 c371 r372 w373 k374) ((lambda (tmp375) ((lambda (tmp376) (if tmp376 (apply (lambda (id377 e1378 e2379) (let ((ids380 id377)) (if (not (valid-bound-ids?92 ids380)) (syntax-error e370 (quote "invalid parameter list in")) (let ((labels382 (gen-labels73 ids380)) (new-vars383 (map gen-var115 ids380))) (k374 new-vars383 (chi-body107 (cons e1378 e2379) e370 (extend-var-env62 labels382 new-vars383 r372) (make-binding-wrap84 ids380 labels382 w373))))))) tmp376) ((lambda (tmp385) (if tmp385 (apply (lambda (ids386 e1387 e2388) (let ((old-ids389 (lambda-var-list116 ids386))) (if (not (valid-bound-ids?92 old-ids389)) (syntax-error e370 (quote "invalid parameter list in")) (let ((labels390 (gen-labels73 old-ids389)) (new-vars391 (map gen-var115 old-ids389))) (k374 (let f392 ((ls1393 (cdr new-vars391)) (ls2394 (car new-vars391))) (if (null? ls1393) ls2394 (f392 (cdr ls1393) (cons (car ls1393) ls2394)))) (chi-body107 (cons e1387 e2388) e370 (extend-var-env62 labels390 new-vars391 r372) (make-binding-wrap84 old-ids389 labels390 w373))))))) tmp385) ((lambda (_396) (syntax-error e370)) tmp375))) (syntax-dispatch tmp375 (quote (any any . each-any)))))) (syntax-dispatch tmp375 (quote (each-any any . each-any))))) c371))) (chi-body107 (lambda (body397 outer-form398 r399 w400) (let ((r401 (cons (quote ("placeholder" placeholder)) r399))) (let ((ribcage402 (make-ribcage74 (quote ()) (quote ()) (quote ())))) (let ((w403 (make-wrap69 (wrap-marks70 w400) (cons ribcage402 (wrap-subst71 w400))))) (let parse404 ((body405 (map (lambda (x411) (cons r401 (wrap95 x411 w403))) body397)) (ids406 (quote ())) (labels407 (quote ())) (vars408 (quote ())) (vals409 (quote ())) (bindings410 (quote ()))) (if (null? body405) (syntax-error outer-form398 (quote "no expressions in body")) (let ((e412 (cdar body405)) (er413 (caar body405))) (call-with-values (lambda () (syntax-type101 e412 er413 (quote (())) (quote #f) ribcage402)) (lambda (type414 value415 e416 w417 s418) (let ((t419 type414)) (if (memv t419 (quote (define-form))) (let ((id420 (wrap95 value415 w417)) (label421 (gen-label72))) (let ((var422 (gen-var115 id420))) (begin (extend-ribcage!83 ribcage402 id420 label421) (parse404 (cdr body405) (cons id420 ids406) (cons label421 labels407) (cons var422 vars408) (cons (cons er413 (wrap95 e416 w417)) vals409) (cons (cons (quote lexical) var422) bindings410))))) (if (memv t419 (quote (define-syntax-form))) (let ((id423 (wrap95 value415 w417)) (label424 (gen-label72))) (begin (extend-ribcage!83 ribcage402 id423 label424) (parse404 (cdr body405) (cons id423 ids406) (cons label424 labels407) vars408 vals409 (cons (cons (quote macro) (cons er413 (wrap95 e416 w417))) bindings410)))) (if (memv t419 (quote (begin-form))) ((lambda (tmp425) ((lambda (tmp426) (if tmp426 (apply (lambda (_427 e1428) (parse404 (let f429 ((forms430 e1428)) (if (null? forms430) (cdr body405) (cons (cons er413 (wrap95 (car forms430) w417)) (f429 (cdr forms430))))) ids406 labels407 vars408 vals409 bindings410)) tmp426) (syntax-error tmp425))) (syntax-dispatch tmp425 (quote (any . each-any))))) e416) (if (memv t419 (quote (local-syntax-form))) (chi-local-syntax109 value415 e416 er413 w417 s418 (lambda (forms432 er433 w434 s435) (parse404 (let f436 ((forms437 forms432)) (if (null? forms437) (cdr body405) (cons (cons er433 (wrap95 (car forms437) w434)) (f436 (cdr forms437))))) ids406 labels407 vars408 vals409 bindings410))) (if (null? ids406) (build-sequence48 (quote #f) (map (lambda (x438) (chi103 (cdr x438) (car x438) (quote (())))) (cons (cons er413 (source-wrap96 e416 w417 s418)) (cdr body405)))) (begin (if (not (valid-bound-ids?92 ids406)) (syntax-error outer-form398 (quote "invalid or duplicate identifier in definition"))) (let loop439 ((bs440 bindings410) (er-cache441 (quote #f)) (r-cache442 (quote #f))) (if (not (null? bs440)) (let ((b443 (car bs440))) (if (eq? (car b443) (quote macro)) (let ((er444 (cadr b443))) (let ((r-cache445 (if (eq? er444 er-cache441) r-cache442 (macros-only-env63 er444)))) (begin (set-cdr! b443 (eval-local-transformer110 (chi103 (cddr b443) r-cache445 (quote (()))))) (loop439 (cdr bs440) er444 r-cache445)))) (loop439 (cdr bs440) er-cache441 r-cache442))))) (set-cdr! r401 (extend-env61 labels407 bindings410 (cdr r401))) (build-letrec51 (quote #f) vars408 (map (lambda (x446) (chi103 (cdr x446) (car x446) (quote (())))) vals409) (build-sequence48 (quote #f) (map (lambda (x447) (chi103 (cdr x447) (car x447) (quote (())))) (cons (cons er413 (source-wrap96 e416 w417 s418)) (cdr body405)))))))))))))))))))))) (chi-macro106 (lambda (p448 e449 r450 w451 rib452) (letrec ((rebuild-macro-output453 (lambda (x454 m455) (cond ((pair? x454) (cons (rebuild-macro-output453 (car x454) m455) (rebuild-macro-output453 (cdr x454) m455))) ((syntax-object?53 x454) (let ((w456 (syntax-object-wrap55 x454))) (let ((ms457 (wrap-marks70 w456)) (s458 (wrap-subst71 w456))) (make-syntax-object52 (syntax-object-expression54 x454) (if (and (pair? ms457) (eq? (car ms457) (quote #f))) (make-wrap69 (cdr ms457) (if rib452 (cons rib452 (cdr s458)) (cdr s458))) (make-wrap69 (cons m455 ms457) (if rib452 (cons rib452 (cons (quote shift) s458)) (cons (quote shift) s458)))))))) ((vector? x454) (let ((n459 (vector-length x454))) (let ((v460 (make-vector n459))) (let doloop461 ((i462 (quote 0))) (if (fx=40 i462 n459) v460 (begin (vector-set! v460 i462 (rebuild-macro-output453 (vector-ref x454 i462) m455)) (doloop461 (fx+38 i462 (quote 1))))))))) ((symbol? x454) (syntax-error x454 (quote "encountered raw symbol in macro output"))) (else x454))))) (rebuild-macro-output453 (p448 (wrap95 e449 (anti-mark82 w451))) (string (quote #\m)))))) (chi-application105 (lambda (x463 e464 r465 w466 s467) ((lambda (tmp468) ((lambda (tmp469) (if tmp469 (apply (lambda (e0470 e1471) (cons x463 (map (lambda (e472) (chi103 e472 r465 w466)) e1471))) tmp469) (syntax-error tmp468))) (syntax-dispatch tmp468 (quote (any . each-any))))) e464))) (chi-expr104 (lambda (type474 value475 e476 r477 w478 s479) (let ((t480 type474)) (if (memv t480 (quote (lexical))) value475 (if (memv t480 (quote (core))) (value475 e476 r477 w478 s479) (if (memv t480 (quote (lexical-call))) (chi-application105 value475 e476 r477 w478 s479) (if (memv t480 (quote (global-call))) (chi-application105 value475 e476 r477 w478 s479) (if (memv t480 (quote (constant))) (list (quote quote) (strip114 (source-wrap96 e476 w478 s479) (quote (())))) (if (memv t480 (quote (global))) value475 (if (memv t480 (quote (call))) (chi-application105 (chi103 (car e476) r477 w478) e476 r477 w478 s479) (if (memv t480 (quote (begin-form))) ((lambda (tmp481) ((lambda (tmp482) (if tmp482 (apply (lambda (_483 e1484 e2485) (chi-sequence97 (cons e1484 e2485) r477 w478 s479)) tmp482) (syntax-error tmp481))) (syntax-dispatch tmp481 (quote (any any . each-any))))) e476) (if (memv t480 (quote (local-syntax-form))) (chi-local-syntax109 value475 e476 r477 w478 s479 chi-sequence97) (if (memv t480 (quote (eval-when-form))) ((lambda (tmp487) ((lambda (tmp488) (if tmp488 (apply (lambda (_489 x490 e1491 e2492) (let ((when-list493 (chi-when-list100 e476 x490 w478))) (if (memq (quote eval) when-list493) (chi-sequence97 (cons e1491 e2492) r477 w478 s479) (chi-void111)))) tmp488) (syntax-error tmp487))) (syntax-dispatch tmp487 (quote (any each-any any . each-any))))) e476) (if (memv t480 (quote (define-form define-syntax-form))) (syntax-error (wrap95 value475 w478) (quote "invalid context for definition of")) (if (memv t480 (quote (syntax))) (syntax-error (source-wrap96 e476 w478 s479) (quote "reference to pattern variable outside syntax form")) (if (memv t480 (quote (displaced-lexical))) (syntax-error (source-wrap96 e476 w478 s479) (quote "reference to identifier outside its scope")) (syntax-error (source-wrap96 e476 w478 s479)))))))))))))))))) (chi103 (lambda (e496 r497 w498) (call-with-values (lambda () (syntax-type101 e496 r497 w498 (quote #f) (quote #f))) (lambda (type499 value500 e501 w502 s503) (chi-expr104 type499 value500 e501 r497 w502 s503))))) (chi-top102 (lambda (e504 r505 w506 m507 esew508) (call-with-values (lambda () (syntax-type101 e504 r505 w506 (quote #f) (quote #f))) (lambda (type515 value516 e517 w518 s519) (let ((t520 type515)) (if (memv t520 (quote (begin-form))) ((lambda (tmp521) ((lambda (tmp522) (if tmp522 (apply (lambda (_523) (chi-void111)) tmp522) ((lambda (tmp524) (if tmp524 (apply (lambda (_525 e1526 e2527) (chi-top-sequence98 (cons e1526 e2527) r505 w518 s519 m507 esew508)) tmp524) (syntax-error tmp521))) (syntax-dispatch tmp521 (quote (any any . each-any)))))) (syntax-dispatch tmp521 (quote (any))))) e517) (if (memv t520 (quote (local-syntax-form))) (chi-local-syntax109 value516 e517 r505 w518 s519 (lambda (body529 r530 w531 s532) (chi-top-sequence98 body529 r530 w531 s532 m507 esew508))) (if (memv t520 (quote (eval-when-form))) ((lambda (tmp533) ((lambda (tmp534) (if tmp534 (apply (lambda (_535 x536 e1537 e2538) (let ((when-list539 (chi-when-list100 e517 x536 w518)) (body540 (cons e1537 e2538))) (cond ((eq? m507 (quote e)) (if (memq (quote eval) when-list539) (chi-top-sequence98 body540 r505 w518 s519 (quote e) (quote (eval))) (chi-void111))) ((memq (quote load) when-list539) (if (or (memq (quote compile) when-list539) (and (eq? m507 (quote c&e)) (memq (quote eval) when-list539))) (chi-top-sequence98 body540 r505 w518 s519 (quote c&e) (quote (compile load))) (if (memq m507 (quote (c c&e))) (chi-top-sequence98 body540 r505 w518 s519 (quote c) (quote (load))) (chi-void111)))) ((or (memq (quote compile) when-list539) (and (eq? m507 (quote c&e)) (memq (quote eval) when-list539))) (top-level-eval-hook43 (chi-top-sequence98 body540 r505 w518 s519 (quote e) (quote (eval)))) (chi-void111)) (else (chi-void111))))) tmp534) (syntax-error tmp533))) (syntax-dispatch tmp533 (quote (any each-any any . each-any))))) e517) (if (memv t520 (quote (define-syntax-form))) (let ((n543 (id-var-name89 value516 w518)) (r544 (macros-only-env63 r505))) (let ((t545 m507)) (if (memv t545 (quote (c))) (if (memq (quote compile) esew508) (let ((e546 (chi-install-global99 n543 (chi103 e517 r544 w518)))) (begin (top-level-eval-hook43 e546) (if (memq (quote load) esew508) e546 (chi-void111)))) (if (memq (quote load) esew508) (chi-install-global99 n543 (chi103 e517 r544 w518)) (chi-void111))) (if (memv t545 (quote (c&e))) (let ((e547 (chi-install-global99 n543 (chi103 e517 r544 w518)))) (begin (top-level-eval-hook43 e547) e547)) (begin (if (memq (quote eval) esew508) (top-level-eval-hook43 (chi-install-global99 n543 (chi103 e517 r544 w518)))) (chi-void111)))))) (if (memv t520 (quote (define-form))) (let ((n548 (id-var-name89 value516 w518))) (let ((t549 (binding-type59 (lookup64 n548 r505)))) (if (memv t549 (quote (global))) (let ((x550 (list (quote define) n548 (chi103 e517 r505 w518)))) (begin (if (eq? m507 (quote c&e)) (top-level-eval-hook43 x550)) x550)) (if (memv t549 (quote (displaced-lexical))) (syntax-error (wrap95 value516 w518) (quote "identifier out of context")) (syntax-error (wrap95 value516 w518) (quote "cannot define keyword at top level")))))) (let ((x551 (chi-expr104 type515 value516 e517 r505 w518 s519))) (begin (if (eq? m507 (quote c&e)) (top-level-eval-hook43 x551)) x551)))))))))))) (syntax-type101 (lambda (e552 r553 w554 s555 rib556) (cond ((symbol? e552) (let ((n557 (id-var-name89 e552 w554))) (let ((b558 (lookup64 n557 r553))) (let ((type559 (binding-type59 b558))) (let ((t560 type559)) (if (memv t560 (quote (lexical))) (values type559 (binding-value60 b558) e552 w554 s555) (if (memv t560 (quote (global))) (values type559 n557 e552 w554 s555) (if (memv t560 (quote (macro))) (syntax-type101 (chi-macro106 (binding-value60 b558) e552 r553 w554 rib556) r553 (quote (())) s555 rib556) (values type559 (binding-value60 b558) e552 w554 s555))))))))) ((pair? e552) (let ((first561 (car e552))) (if (id?67 first561) (let ((n562 (id-var-name89 first561 w554))) (let ((b563 (lookup64 n562 r553))) (let ((type564 (binding-type59 b563))) (let ((t565 type564)) (if (memv t565 (quote (lexical))) (values (quote lexical-call) (binding-value60 b563) e552 w554 s555) (if (memv t565 (quote (global))) (values (quote global-call) n562 e552 w554 s555) (if (memv t565 (quote (macro))) (syntax-type101 (chi-macro106 (binding-value60 b563) e552 r553 w554 rib556) r553 (quote (())) s555 rib556) (if (memv t565 (quote (core))) (values type564 (binding-value60 b563) e552 w554 s555) (if (memv t565 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value60 b563) e552 w554 s555) (if (memv t565 (quote (begin))) (values (quote begin-form) (quote #f) e552 w554 s555) (if (memv t565 (quote (eval-when))) (values (quote eval-when-form) (quote #f) e552 w554 s555) (if (memv t565 (quote (define))) ((lambda (tmp566) ((lambda (tmp567) (if (if tmp567 (apply (lambda (_568 name569 val570) (id?67 name569)) tmp567) (quote #f)) (apply (lambda (_571 name572 val573) (values (quote define-form) name572 val573 w554 s555)) tmp567) ((lambda (tmp574) (if (if tmp574 (apply (lambda (_575 name576 args577 e1578 e2579) (and (id?67 name576) (valid-bound-ids?92 (lambda-var-list116 args577)))) tmp574) (quote #f)) (apply (lambda (_580 name581 args582 e1583 e2584) (values (quote define-form) (wrap95 name581 w554) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) (wrap95 (cons args582 (cons e1583 e2584)) w554)) (quote (())) s555)) tmp574) ((lambda (tmp586) (if (if tmp586 (apply (lambda (_587 name588) (id?67 name588)) tmp586) (quote #f)) (apply (lambda (_589 name590) (values (quote define-form) (wrap95 name590 w554) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote (())) s555)) tmp586) (syntax-error tmp566))) (syntax-dispatch tmp566 (quote (any any)))))) (syntax-dispatch tmp566 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp566 (quote (any any any))))) e552) (if (memv t565 (quote (define-syntax))) ((lambda (tmp591) ((lambda (tmp592) (if (if tmp592 (apply (lambda (_593 name594 val595) (id?67 name594)) tmp592) (quote #f)) (apply (lambda (_596 name597 val598) (values (quote define-syntax-form) name597 val598 w554 s555)) tmp592) (syntax-error tmp591))) (syntax-dispatch tmp591 (quote (any any any))))) e552) (values (quote call) (quote #f) e552 w554 s555)))))))))))))) (values (quote call) (quote #f) e552 w554 s555)))) ((syntax-object?53 e552) (syntax-type101 (syntax-object-expression54 e552) r553 (join-wraps86 w554 (syntax-object-wrap55 e552)) (quote #f) rib556)) ((annotation?42 e552) (syntax-type101 (annotation-expression e552) r553 w554 (annotation-source e552) rib556)) ((let ((x599 e552)) (or (boolean? x599) (number? x599) (string? x599) (char? x599) (null? x599) (keyword? x599))) (values (quote constant) (quote #f) e552 w554 s555)) (else (values (quote other) (quote #f) e552 w554 s555))))) (chi-when-list100 (lambda (e600 when-list601 w602) (let f603 ((when-list604 when-list601) (situations605 (quote ()))) (if (null? when-list604) situations605 (f603 (cdr when-list604) (cons (let ((x606 (car when-list604))) (cond ((free-id=?90 x606 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote compile)) ((free-id=?90 x606 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote load)) ((free-id=?90 x606 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote eval)) (else (syntax-error (wrap95 x606 w602) (quote "invalid eval-when situation"))))) situations605)))))) (chi-install-global99 (lambda (name607 e608) (list (quote install-global-transformer) (list (quote quote) name607) e608))) (chi-top-sequence98 (lambda (body609 r610 w611 s612 m613 esew614) (build-sequence48 s612 (let dobody615 ((body616 body609) (r617 r610) (w618 w611) (m619 m613) (esew620 esew614)) (if (null? body616) (quote ()) (let ((first621 (chi-top102 (car body616) r617 w618 m619 esew620))) (cons first621 (dobody615 (cdr body616) r617 w618 m619 esew620)))))))) (chi-sequence97 (lambda (body622 r623 w624 s625) (build-sequence48 s625 (let dobody626 ((body627 body622) (r628 r623) (w629 w624)) (if (null? body627) (quote ()) (let ((first630 (chi103 (car body627) r628 w629))) (cons first630 (dobody626 (cdr body627) r628 w629)))))))) (source-wrap96 (lambda (x631 w632 s633) (wrap95 (if s633 (make-annotation x631 s633 (quote #f)) x631) w632))) (wrap95 (lambda (x634 w635) (cond ((and (null? (wrap-marks70 w635)) (null? (wrap-subst71 w635))) x634) ((syntax-object?53 x634) (make-syntax-object52 (syntax-object-expression54 x634) (join-wraps86 w635 (syntax-object-wrap55 x634)))) ((null? x634) x634) (else (make-syntax-object52 x634 w635))))) (bound-id-member?94 (lambda (x636 list637) (and (not (null? list637)) (or (bound-id=?91 x636 (car list637)) (bound-id-member?94 x636 (cdr list637)))))) (distinct-bound-ids?93 (lambda (ids638) (let distinct?639 ((ids640 ids638)) (or (null? ids640) (and (not (bound-id-member?94 (car ids640) (cdr ids640))) (distinct?639 (cdr ids640))))))) (valid-bound-ids?92 (lambda (ids641) (and (let all-ids?642 ((ids643 ids641)) (or (null? ids643) (and (id?67 (car ids643)) (all-ids?642 (cdr ids643))))) (distinct-bound-ids?93 ids641)))) (bound-id=?91 (lambda (i644 j645) (if (and (syntax-object?53 i644) (syntax-object?53 j645)) (and (eq? (let ((e646 (syntax-object-expression54 i644))) (if (annotation?42 e646) (annotation-expression e646) e646)) (let ((e647 (syntax-object-expression54 j645))) (if (annotation?42 e647) (annotation-expression e647) e647))) (same-marks?88 (wrap-marks70 (syntax-object-wrap55 i644)) (wrap-marks70 (syntax-object-wrap55 j645)))) (eq? (let ((e648 i644)) (if (annotation?42 e648) (annotation-expression e648) e648)) (let ((e649 j645)) (if (annotation?42 e649) (annotation-expression e649) e649)))))) (free-id=?90 (lambda (i650 j651) (and (eq? (let ((x652 i650)) (let ((e653 (if (syntax-object?53 x652) (syntax-object-expression54 x652) x652))) (if (annotation?42 e653) (annotation-expression e653) e653))) (let ((x654 j651)) (let ((e655 (if (syntax-object?53 x654) (syntax-object-expression54 x654) x654))) (if (annotation?42 e655) (annotation-expression e655) e655)))) (eq? (id-var-name89 i650 (quote (()))) (id-var-name89 j651 (quote (()))))))) (id-var-name89 (lambda (id656 w657) (letrec ((search-vector-rib660 (lambda (sym666 subst667 marks668 symnames669 ribcage670) (let ((n671 (vector-length symnames669))) (let f672 ((i673 (quote 0))) (cond ((fx=40 i673 n671) (search658 sym666 (cdr subst667) marks668)) ((and (eq? (vector-ref symnames669 i673) sym666) (same-marks?88 marks668 (vector-ref (ribcage-marks77 ribcage670) i673))) (values (vector-ref (ribcage-labels78 ribcage670) i673) marks668)) (else (f672 (fx+38 i673 (quote 1))))))))) (search-list-rib659 (lambda (sym674 subst675 marks676 symnames677 ribcage678) (let f679 ((symnames680 symnames677) (i681 (quote 0))) (cond ((null? symnames680) (search658 sym674 (cdr subst675) marks676)) ((and (eq? (car symnames680) sym674) (same-marks?88 marks676 (list-ref (ribcage-marks77 ribcage678) i681))) (values (list-ref (ribcage-labels78 ribcage678) i681) marks676)) (else (f679 (cdr symnames680) (fx+38 i681 (quote 1)))))))) (search658 (lambda (sym682 subst683 marks684) (if (null? subst683) (values (quote #f) marks684) (let ((fst685 (car subst683))) (if (eq? fst685 (quote shift)) (search658 sym682 (cdr subst683) (cdr marks684)) (let ((symnames686 (ribcage-symnames76 fst685))) (if (vector? symnames686) (search-vector-rib660 sym682 subst683 marks684 symnames686 fst685) (search-list-rib659 sym682 subst683 marks684 symnames686 fst685))))))))) (cond ((symbol? id656) (or (call-with-values (lambda () (search658 id656 (wrap-subst71 w657) (wrap-marks70 w657))) (lambda (x688 . ignore687) x688)) id656)) ((syntax-object?53 id656) (let ((id689 (let ((e691 (syntax-object-expression54 id656))) (if (annotation?42 e691) (annotation-expression e691) e691))) (w1690 (syntax-object-wrap55 id656))) (let ((marks692 (join-marks87 (wrap-marks70 w657) (wrap-marks70 w1690)))) (call-with-values (lambda () (search658 id689 (wrap-subst71 w657) marks692)) (lambda (new-id693 marks694) (or new-id693 (call-with-values (lambda () (search658 id689 (wrap-subst71 w1690) marks694)) (lambda (x696 . ignore695) x696)) id689)))))) ((annotation?42 id656) (let ((id697 (let ((e698 id656)) (if (annotation?42 e698) (annotation-expression e698) e698)))) (or (call-with-values (lambda () (search658 id697 (wrap-subst71 w657) (wrap-marks70 w657))) (lambda (x700 . ignore699) x700)) id697))) (else (error-hook45 (quote id-var-name) (quote "invalid id") id656)))))) (same-marks?88 (lambda (x701 y702) (or (eq? x701 y702) (and (not (null? x701)) (not (null? y702)) (eq? (car x701) (car y702)) (same-marks?88 (cdr x701) (cdr y702)))))) (join-marks87 (lambda (m1703 m2704) (smart-append85 m1703 m2704))) (join-wraps86 (lambda (w1705 w2706) (let ((m1707 (wrap-marks70 w1705)) (s1708 (wrap-subst71 w1705))) (if (null? m1707) (if (null? s1708) w2706 (make-wrap69 (wrap-marks70 w2706) (smart-append85 s1708 (wrap-subst71 w2706)))) (make-wrap69 (smart-append85 m1707 (wrap-marks70 w2706)) (smart-append85 s1708 (wrap-subst71 w2706))))))) (smart-append85 (lambda (m1709 m2710) (if (null? m2710) m1709 (append m1709 m2710)))) (make-binding-wrap84 (lambda (ids711 labels712 w713) (if (null? ids711) w713 (make-wrap69 (wrap-marks70 w713) (cons (let ((labelvec714 (list->vector labels712))) (let ((n715 (vector-length labelvec714))) (let ((symnamevec716 (make-vector n715)) (marksvec717 (make-vector n715))) (begin (let f718 ((ids719 ids711) (i720 (quote 0))) (if (not (null? ids719)) (call-with-values (lambda () (id-sym-name&marks68 (car ids719) w713)) (lambda (symname721 marks722) (begin (vector-set! symnamevec716 i720 symname721) (vector-set! marksvec717 i720 marks722) (f718 (cdr ids719) (fx+38 i720 (quote 1)))))))) (make-ribcage74 symnamevec716 marksvec717 labelvec714))))) (wrap-subst71 w713)))))) (extend-ribcage!83 (lambda (ribcage723 id724 label725) (begin (set-ribcage-symnames!79 ribcage723 (cons (let ((e726 (syntax-object-expression54 id724))) (if (annotation?42 e726) (annotation-expression e726) e726)) (ribcage-symnames76 ribcage723))) (set-ribcage-marks!80 ribcage723 (cons (wrap-marks70 (syntax-object-wrap55 id724)) (ribcage-marks77 ribcage723))) (set-ribcage-labels!81 ribcage723 (cons label725 (ribcage-labels78 ribcage723)))))) (anti-mark82 (lambda (w727) (make-wrap69 (cons (quote #f) (wrap-marks70 w727)) (cons (quote shift) (wrap-subst71 w727))))) (set-ribcage-labels!81 (lambda (x728 update729) (vector-set! x728 (quote 3) update729))) (set-ribcage-marks!80 (lambda (x730 update731) (vector-set! x730 (quote 2) update731))) (set-ribcage-symnames!79 (lambda (x732 update733) (vector-set! x732 (quote 1) update733))) (ribcage-labels78 (lambda (x734) (vector-ref x734 (quote 3)))) (ribcage-marks77 (lambda (x735) (vector-ref x735 (quote 2)))) (ribcage-symnames76 (lambda (x736) (vector-ref x736 (quote 1)))) (ribcage?75 (lambda (x737) (and (vector? x737) (= (vector-length x737) (quote 4)) (eq? (vector-ref x737 (quote 0)) (quote ribcage))))) (make-ribcage74 (lambda (symnames738 marks739 labels740) (vector (quote ribcage) symnames738 marks739 labels740))) (gen-labels73 (lambda (ls741) (if (null? ls741) (quote ()) (cons (gen-label72) (gen-labels73 (cdr ls741)))))) (gen-label72 (lambda () (string (quote #\i)))) (wrap-subst71 cdr) (wrap-marks70 car) (make-wrap69 cons) (id-sym-name&marks68 (lambda (x742 w743) (if (syntax-object?53 x742) (values (let ((e744 (syntax-object-expression54 x742))) (if (annotation?42 e744) (annotation-expression e744) e744)) (join-marks87 (wrap-marks70 w743) (wrap-marks70 (syntax-object-wrap55 x742)))) (values (let ((e745 x742)) (if (annotation?42 e745) (annotation-expression e745) e745)) (wrap-marks70 w743))))) (id?67 (lambda (x746) (cond ((symbol? x746) (quote #t)) ((syntax-object?53 x746) (symbol? (let ((e747 (syntax-object-expression54 x746))) (if (annotation?42 e747) (annotation-expression e747) e747)))) ((annotation?42 x746) (symbol? (annotation-expression x746))) (else (quote #f))))) (nonsymbol-id?66 (lambda (x748) (and (syntax-object?53 x748) (symbol? (let ((e749 (syntax-object-expression54 x748))) (if (annotation?42 e749) (annotation-expression e749) e749)))))) (global-extend65 (lambda (type750 sym751 val752) (put-global-definition-hook46 sym751 (cons type750 val752)))) (lookup64 (lambda (x753 r754) (cond ((assq x753 r754) => cdr) ((symbol? x753) (or (get-global-definition-hook47 x753) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env63 (lambda (r755) (if (null? r755) (quote ()) (let ((a756 (car r755))) (if (eq? (cadr a756) (quote macro)) (cons a756 (macros-only-env63 (cdr r755))) (macros-only-env63 (cdr r755))))))) (extend-var-env62 (lambda (labels757 vars758 r759) (if (null? labels757) r759 (extend-var-env62 (cdr labels757) (cdr vars758) (cons (cons (car labels757) (cons (quote lexical) (car vars758))) r759))))) (extend-env61 (lambda (labels760 bindings761 r762) (if (null? labels760) r762 (extend-env61 (cdr labels760) (cdr bindings761) (cons (cons (car labels760) (car bindings761)) r762))))) (binding-value60 cdr) (binding-type59 car) (source-annotation58 (lambda (x763) (cond ((annotation?42 x763) (annotation-source x763)) ((syntax-object?53 x763) (source-annotation58 (syntax-object-expression54 x763))) (else (quote #f))))) (set-syntax-object-wrap!57 (lambda (x764 update765) (vector-set! x764 (quote 2) update765))) (set-syntax-object-expression!56 (lambda (x766 update767) (vector-set! x766 (quote 1) update767))) (syntax-object-wrap55 (lambda (x768) (vector-ref x768 (quote 2)))) (syntax-object-expression54 (lambda (x769) (vector-ref x769 (quote 1)))) (syntax-object?53 (lambda (x770) (and (vector? x770) (= (vector-length x770) (quote 3)) (eq? (vector-ref x770 (quote 0)) (quote syntax-object))))) (make-syntax-object52 (lambda (expression771 wrap772) (vector (quote syntax-object) expression771 wrap772))) (build-letrec51 (lambda (src773 vars774 val-exps775 body-exp776) (if (null? vars774) body-exp776 (list (quote letrec) (map list vars774 val-exps775) body-exp776)))) (build-named-let50 (lambda (src777 vars778 val-exps779 body-exp780) (if (null? vars778) body-exp780 (list (quote let) (car vars778) (map list (cdr vars778) val-exps779) body-exp780)))) (build-let49 (lambda (src781 vars782 val-exps783 body-exp784) (if (null? vars782) body-exp784 (list (quote let) (map list vars782 val-exps783) body-exp784)))) (build-sequence48 (lambda (src785 exps786) (if (null? (cdr exps786)) (car exps786) (cons (quote begin) exps786)))) (get-global-definition-hook47 (lambda (symbol787) (getprop symbol787 (quote *sc-expander*)))) (put-global-definition-hook46 (lambda (symbol788 binding789) (putprop symbol788 (quote *sc-expander*) binding789))) (error-hook45 (lambda (who790 why791 what792) (error who790 (quote "~a ~s") why791 what792))) (local-eval-hook44 (lambda (x793) (eval (list noexpand37 x793) (interaction-environment)))) (top-level-eval-hook43 (lambda (x794) (eval (list noexpand37 x794) (interaction-environment)))) (annotation?42 (lambda (x795) (quote #f))) (fx<41 <) (fx=40 =) (fx-39 -) (fx+38 +) (noexpand37 (quote "noexpand"))) (begin (global-extend65 (quote local-syntax) (quote letrec-syntax) (quote #t)) (global-extend65 (quote local-syntax) (quote let-syntax) (quote #f)) (global-extend65 (quote core) (quote fluid-let-syntax) (lambda (e796 r797 w798 s799) ((lambda (tmp800) ((lambda (tmp801) (if (if tmp801 (apply (lambda (_802 var803 val804 e1805 e2806) (valid-bound-ids?92 var803)) tmp801) (quote #f)) (apply (lambda (_808 var809 val810 e1811 e2812) (let ((names813 (map (lambda (x814) (id-var-name89 x814 w798)) var809))) (begin (for-each (lambda (id816 n817) (let ((t818 (binding-type59 (lookup64 n817 r797)))) (if (memv t818 (quote (displaced-lexical))) (syntax-error (source-wrap96 id816 w798 s799) (quote "identifier out of context"))))) var809 names813) (chi-body107 (cons e1811 e2812) (source-wrap96 e796 w798 s799) (extend-env61 names813 (let ((trans-r821 (macros-only-env63 r797))) (map (lambda (x822) (cons (quote macro) (eval-local-transformer110 (chi103 x822 trans-r821 w798)))) val810)) r797) w798)))) tmp801) ((lambda (_824) (syntax-error (source-wrap96 e796 w798 s799))) tmp800))) (syntax-dispatch tmp800 (quote (any #(each (any any)) any . each-any))))) e796))) (global-extend65 (quote core) (quote quote) (lambda (e825 r826 w827 s828) ((lambda (tmp829) ((lambda (tmp830) (if tmp830 (apply (lambda (_831 e832) (list (quote quote) (strip114 e832 w827))) tmp830) ((lambda (_833) (syntax-error (source-wrap96 e825 w827 s828))) tmp829))) (syntax-dispatch tmp829 (quote (any any))))) e825))) (global-extend65 (quote core) (quote syntax) (letrec ((regen841 (lambda (x842) (let ((t843 (car x842))) (if (memv t843 (quote (ref))) (cadr x842) (if (memv t843 (quote (primitive))) (cadr x842) (if (memv t843 (quote (quote))) (list (quote quote) (cadr x842)) (if (memv t843 (quote (lambda))) (list (quote lambda) (cadr x842) (regen841 (caddr x842))) (if (memv t843 (quote (map))) (let ((ls844 (map regen841 (cdr x842)))) (cons (if (fx=40 (length ls844) (quote 2)) (quote map) (quote map)) ls844)) (cons (car x842) (map regen841 (cdr x842))))))))))) (gen-vector840 (lambda (x845) (cond ((eq? (car x845) (quote list)) (cons (quote vector) (cdr x845))) ((eq? (car x845) (quote quote)) (list (quote quote) (list->vector (cadr x845)))) (else (list (quote list->vector) x845))))) (gen-append839 (lambda (x846 y847) (if (equal? y847 (quote (quote ()))) x846 (list (quote append) x846 y847)))) (gen-cons838 (lambda (x848 y849) (let ((t850 (car y849))) (if (memv t850 (quote (quote))) (if (eq? (car x848) (quote quote)) (list (quote quote) (cons (cadr x848) (cadr y849))) (if (eq? (cadr y849) (quote ())) (list (quote list) x848) (list (quote cons) x848 y849))) (if (memv t850 (quote (list))) (cons (quote list) (cons x848 (cdr y849))) (list (quote cons) x848 y849)))))) (gen-map837 (lambda (e851 map-env852) (let ((formals853 (map cdr map-env852)) (actuals854 (map (lambda (x855) (list (quote ref) (car x855))) map-env852))) (cond ((eq? (car e851) (quote ref)) (car actuals854)) ((andmap (lambda (x856) (and (eq? (car x856) (quote ref)) (memq (cadr x856) formals853))) (cdr e851)) (cons (quote map) (cons (list (quote primitive) (car e851)) (map (let ((r857 (map cons formals853 actuals854))) (lambda (x858) (cdr (assq (cadr x858) r857)))) (cdr e851))))) (else (cons (quote map) (cons (list (quote lambda) formals853 e851) actuals854))))))) (gen-mappend836 (lambda (e859 map-env860) (list (quote apply) (quote (primitive append)) (gen-map837 e859 map-env860)))) (gen-ref835 (lambda (src861 var862 level863 maps864) (if (fx=40 level863 (quote 0)) (values var862 maps864) (if (null? maps864) (syntax-error src861 (quote "missing ellipsis in syntax form")) (call-with-values (lambda () (gen-ref835 src861 var862 (fx-39 level863 (quote 1)) (cdr maps864))) (lambda (outer-var865 outer-maps866) (let ((b867 (assq outer-var865 (car maps864)))) (if b867 (values (cdr b867) maps864) (let ((inner-var868 (gen-var115 (quote tmp)))) (values inner-var868 (cons (cons (cons outer-var865 inner-var868) (car maps864)) outer-maps866))))))))))) (gen-syntax834 (lambda (src869 e870 r871 maps872 ellipsis?873) (if (id?67 e870) (let ((label874 (id-var-name89 e870 (quote (()))))) (let ((b875 (lookup64 label874 r871))) (if (eq? (binding-type59 b875) (quote syntax)) (call-with-values (lambda () (let ((var.lev876 (binding-value60 b875))) (gen-ref835 src869 (car var.lev876) (cdr var.lev876) maps872))) (lambda (var877 maps878) (values (list (quote ref) var877) maps878))) (if (ellipsis?873 e870) (syntax-error src869 (quote "misplaced ellipsis in syntax form")) (values (list (quote quote) e870) maps872))))) ((lambda (tmp879) ((lambda (tmp880) (if (if tmp880 (apply (lambda (dots881 e882) (ellipsis?873 dots881)) tmp880) (quote #f)) (apply (lambda (dots883 e884) (gen-syntax834 src869 e884 r871 maps872 (lambda (x885) (quote #f)))) tmp880) ((lambda (tmp886) (if (if tmp886 (apply (lambda (x887 dots888 y889) (ellipsis?873 dots888)) tmp886) (quote #f)) (apply (lambda (x890 dots891 y892) (let f893 ((y894 y892) (k895 (lambda (maps896) (call-with-values (lambda () (gen-syntax834 src869 x890 r871 (cons (quote ()) maps896) ellipsis?873)) (lambda (x897 maps898) (if (null? (car maps898)) (syntax-error src869 (quote "extra ellipsis in syntax form")) (values (gen-map837 x897 (car maps898)) (cdr maps898)))))))) ((lambda (tmp899) ((lambda (tmp900) (if (if tmp900 (apply (lambda (dots901 y902) (ellipsis?873 dots901)) tmp900) (quote #f)) (apply (lambda (dots903 y904) (f893 y904 (lambda (maps905) (call-with-values (lambda () (k895 (cons (quote ()) maps905))) (lambda (x906 maps907) (if (null? (car maps907)) (syntax-error src869 (quote "extra ellipsis in syntax form")) (values (gen-mappend836 x906 (car maps907)) (cdr maps907)))))))) tmp900) ((lambda (_908) (call-with-values (lambda () (gen-syntax834 src869 y894 r871 maps872 ellipsis?873)) (lambda (y909 maps910) (call-with-values (lambda () (k895 maps910)) (lambda (x911 maps912) (values (gen-append839 x911 y909) maps912)))))) tmp899))) (syntax-dispatch tmp899 (quote (any . any))))) y894))) tmp886) ((lambda (tmp913) (if tmp913 (apply (lambda (x914 y915) (call-with-values (lambda () (gen-syntax834 src869 x914 r871 maps872 ellipsis?873)) (lambda (x916 maps917) (call-with-values (lambda () (gen-syntax834 src869 y915 r871 maps917 ellipsis?873)) (lambda (y918 maps919) (values (gen-cons838 x916 y918) maps919)))))) tmp913) ((lambda (tmp920) (if tmp920 (apply (lambda (e1921 e2922) (call-with-values (lambda () (gen-syntax834 src869 (cons e1921 e2922) r871 maps872 ellipsis?873)) (lambda (e924 maps925) (values (gen-vector840 e924) maps925)))) tmp920) ((lambda (_926) (values (list (quote quote) e870) maps872)) tmp879))) (syntax-dispatch tmp879 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp879 (quote (any . any)))))) (syntax-dispatch tmp879 (quote (any any . any)))))) (syntax-dispatch tmp879 (quote (any any))))) e870))))) (lambda (e927 r928 w929 s930) (let ((e931 (source-wrap96 e927 w929 s930))) ((lambda (tmp932) ((lambda (tmp933) (if tmp933 (apply (lambda (_934 x935) (call-with-values (lambda () (gen-syntax834 e931 x935 r928 (quote ()) ellipsis?112)) (lambda (e936 maps937) (regen841 e936)))) tmp933) ((lambda (_938) (syntax-error e931)) tmp932))) (syntax-dispatch tmp932 (quote (any any))))) e931))))) (global-extend65 (quote core) (quote lambda) (lambda (e939 r940 w941 s942) ((lambda (tmp943) ((lambda (tmp944) (if tmp944 (apply (lambda (_945 c946) (chi-lambda-clause108 (source-wrap96 e939 w941 s942) c946 r940 w941 (lambda (vars947 body948) (list (quote lambda) vars947 body948)))) tmp944) (syntax-error tmp943))) (syntax-dispatch tmp943 (quote (any . any))))) e939))) (global-extend65 (quote core) (quote let) (letrec ((chi-let949 (lambda (e950 r951 w952 s953 constructor954 ids955 vals956 exps957) (if (not (valid-bound-ids?92 ids955)) (syntax-error e950 (quote "duplicate bound variable in")) (let ((labels958 (gen-labels73 ids955)) (new-vars959 (map gen-var115 ids955))) (let ((nw960 (make-binding-wrap84 ids955 labels958 w952)) (nr961 (extend-var-env62 labels958 new-vars959 r951))) (constructor954 s953 new-vars959 (map (lambda (x962) (chi103 x962 r951 w952)) vals956) (chi-body107 exps957 (source-wrap96 e950 nw960 s953) nr961 nw960)))))))) (lambda (e963 r964 w965 s966) ((lambda (tmp967) ((lambda (tmp968) (if tmp968 (apply (lambda (_969 id970 val971 e1972 e2973) (chi-let949 e963 r964 w965 s966 build-let49 id970 val971 (cons e1972 e2973))) tmp968) ((lambda (tmp977) (if (if tmp977 (apply (lambda (_978 f979 id980 val981 e1982 e2983) (id?67 f979)) tmp977) (quote #f)) (apply (lambda (_984 f985 id986 val987 e1988 e2989) (chi-let949 e963 r964 w965 s966 build-named-let50 (cons f985 id986) val987 (cons e1988 e2989))) tmp977) ((lambda (_993) (syntax-error (source-wrap96 e963 w965 s966))) tmp967))) (syntax-dispatch tmp967 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp967 (quote (any #(each (any any)) any . each-any))))) e963)))) (global-extend65 (quote core) (quote letrec) (lambda (e994 r995 w996 s997) ((lambda (tmp998) ((lambda (tmp999) (if tmp999 (apply (lambda (_1000 id1001 val1002 e11003 e21004) (let ((ids1005 id1001)) (if (not (valid-bound-ids?92 ids1005)) (syntax-error e994 (quote "duplicate bound variable in")) (let ((labels1007 (gen-labels73 ids1005)) (new-vars1008 (map gen-var115 ids1005))) (let ((w1009 (make-binding-wrap84 ids1005 labels1007 w996)) (r1010 (extend-var-env62 labels1007 new-vars1008 r995))) (build-letrec51 s997 new-vars1008 (map (lambda (x1011) (chi103 x1011 r1010 w1009)) val1002) (chi-body107 (cons e11003 e21004) (source-wrap96 e994 w1009 s997) r1010 w1009))))))) tmp999) ((lambda (_1014) (syntax-error (source-wrap96 e994 w996 s997))) tmp998))) (syntax-dispatch tmp998 (quote (any #(each (any any)) any . each-any))))) e994))) (global-extend65 (quote core) (quote set!) (lambda (e1015 r1016 w1017 s1018) ((lambda (tmp1019) ((lambda (tmp1020) (if (if tmp1020 (apply (lambda (_1021 id1022 val1023) (id?67 id1022)) tmp1020) (quote #f)) (apply (lambda (_1024 id1025 val1026) (let ((val1027 (chi103 val1026 r1016 w1017)) (n1028 (id-var-name89 id1025 w1017))) (let ((b1029 (lookup64 n1028 r1016))) (let ((t1030 (binding-type59 b1029))) (if (memv t1030 (quote (lexical))) (list (quote set!) (binding-value60 b1029) val1027) (if (memv t1030 (quote (global))) (list (quote set!) n1028 val1027) (if (memv t1030 (quote (displaced-lexical))) (syntax-error (wrap95 id1025 w1017) (quote "identifier out of context")) (syntax-error (source-wrap96 e1015 w1017 s1018))))))))) tmp1020) ((lambda (tmp1031) (if tmp1031 (apply (lambda (_1032 getter1033 arg1034 val1035) (cons (chi103 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) getter1033) r1016 w1017) (map (lambda (e1036) (chi103 e1036 r1016 w1017)) (append arg1034 (list val1035))))) tmp1031) ((lambda (_1038) (syntax-error (source-wrap96 e1015 w1017 s1018))) tmp1019))) (syntax-dispatch tmp1019 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp1019 (quote (any any any))))) e1015))) (global-extend65 (quote begin) (quote begin) (quote ())) (global-extend65 (quote define) (quote define) (quote ())) (global-extend65 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend65 (quote eval-when) (quote eval-when) (quote ())) (global-extend65 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1042 (lambda (x1043 keys1044 clauses1045 r1046) (if (null? clauses1045) (list (quote syntax-error) x1043) ((lambda (tmp1047) ((lambda (tmp1048) (if tmp1048 (apply (lambda (pat1049 exp1050) (if (and (id?67 pat1049) (andmap (lambda (x1051) (not (free-id=?90 pat1049 x1051))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) keys1044))) (let ((labels1052 (list (gen-label72))) (var1053 (gen-var115 pat1049))) (list (list (quote lambda) (list var1053) (chi103 exp1050 (extend-env61 labels1052 (list (cons (quote syntax) (cons var1053 (quote 0)))) r1046) (make-binding-wrap84 (list pat1049) labels1052 (quote (()))))) x1043)) (gen-clause1041 x1043 keys1044 (cdr clauses1045) r1046 pat1049 (quote #t) exp1050))) tmp1048) ((lambda (tmp1054) (if tmp1054 (apply (lambda (pat1055 fender1056 exp1057) (gen-clause1041 x1043 keys1044 (cdr clauses1045) r1046 pat1055 fender1056 exp1057)) tmp1054) ((lambda (_1058) (syntax-error (car clauses1045) (quote "invalid syntax-case clause"))) tmp1047))) (syntax-dispatch tmp1047 (quote (any any any)))))) (syntax-dispatch tmp1047 (quote (any any))))) (car clauses1045))))) (gen-clause1041 (lambda (x1059 keys1060 clauses1061 r1062 pat1063 fender1064 exp1065) (call-with-values (lambda () (convert-pattern1039 pat1063 keys1060)) (lambda (p1066 pvars1067) (cond ((not (distinct-bound-ids?93 (map car pvars1067))) (syntax-error pat1063 (quote "duplicate pattern variable in syntax-case pattern"))) ((not (andmap (lambda (x1068) (not (ellipsis?112 (car x1068)))) pvars1067)) (syntax-error pat1063 (quote "misplaced ellipsis in syntax-case pattern"))) (else (let ((y1069 (gen-var115 (quote tmp)))) (list (list (quote lambda) (list y1069) (let ((y1070 y1069)) (list (quote if) ((lambda (tmp1071) ((lambda (tmp1072) (if tmp1072 (apply (lambda () y1070) tmp1072) ((lambda (_1073) (list (quote if) y1070 (build-dispatch-call1040 pvars1067 fender1064 y1070 r1062) (list (quote quote) (quote #f)))) tmp1071))) (syntax-dispatch tmp1071 (quote #(atom #t))))) fender1064) (build-dispatch-call1040 pvars1067 exp1065 y1070 r1062) (gen-syntax-case1042 x1059 keys1060 clauses1061 r1062)))) (if (eq? p1066 (quote any)) (list (quote list) x1059) (list (quote syntax-dispatch) x1059 (list (quote quote) p1066))))))))))) (build-dispatch-call1040 (lambda (pvars1074 exp1075 y1076 r1077) (let ((ids1078 (map car pvars1074)) (levels1079 (map cdr pvars1074))) (let ((labels1080 (gen-labels73 ids1078)) (new-vars1081 (map gen-var115 ids1078))) (list (quote apply) (list (quote lambda) new-vars1081 (chi103 exp1075 (extend-env61 labels1080 (map (lambda (var1082 level1083) (cons (quote syntax) (cons var1082 level1083))) new-vars1081 (map cdr pvars1074)) r1077) (make-binding-wrap84 ids1078 labels1080 (quote (()))))) y1076))))) (convert-pattern1039 (lambda (pattern1084 keys1085) (let cvt1086 ((p1087 pattern1084) (n1088 (quote 0)) (ids1089 (quote ()))) (if (id?67 p1087) (if (bound-id-member?94 p1087 keys1085) (values (vector (quote free-id) p1087) ids1089) (values (quote any) (cons (cons p1087 n1088) ids1089))) ((lambda (tmp1090) ((lambda (tmp1091) (if (if tmp1091 (apply (lambda (x1092 dots1093) (ellipsis?112 dots1093)) tmp1091) (quote #f)) (apply (lambda (x1094 dots1095) (call-with-values (lambda () (cvt1086 x1094 (fx+38 n1088 (quote 1)) ids1089)) (lambda (p1096 ids1097) (values (if (eq? p1096 (quote any)) (quote each-any) (vector (quote each) p1096)) ids1097)))) tmp1091) ((lambda (tmp1098) (if tmp1098 (apply (lambda (x1099 y1100) (call-with-values (lambda () (cvt1086 y1100 n1088 ids1089)) (lambda (y1101 ids1102) (call-with-values (lambda () (cvt1086 x1099 n1088 ids1102)) (lambda (x1103 ids1104) (values (cons x1103 y1101) ids1104)))))) tmp1098) ((lambda (tmp1105) (if tmp1105 (apply (lambda () (values (quote ()) ids1089)) tmp1105) ((lambda (tmp1106) (if tmp1106 (apply (lambda (x1107) (call-with-values (lambda () (cvt1086 x1107 n1088 ids1089)) (lambda (p1109 ids1110) (values (vector (quote vector) p1109) ids1110)))) tmp1106) ((lambda (x1111) (values (vector (quote atom) (strip114 p1087 (quote (())))) ids1089)) tmp1090))) (syntax-dispatch tmp1090 (quote #(vector each-any)))))) (syntax-dispatch tmp1090 (quote ()))))) (syntax-dispatch tmp1090 (quote (any . any)))))) (syntax-dispatch tmp1090 (quote (any any))))) p1087)))))) (lambda (e1112 r1113 w1114 s1115) (let ((e1116 (source-wrap96 e1112 w1114 s1115))) ((lambda (tmp1117) ((lambda (tmp1118) (if tmp1118 (apply (lambda (_1119 val1120 key1121 m1122) (if (andmap (lambda (x1123) (and (id?67 x1123) (not (ellipsis?112 x1123)))) key1121) (let ((x1125 (gen-var115 (quote tmp)))) (list (list (quote lambda) (list x1125) (gen-syntax-case1042 x1125 key1121 m1122 r1113)) (chi103 val1120 r1113 (quote (()))))) (syntax-error e1116 (quote "invalid literals list in")))) tmp1118) (syntax-error tmp1117))) (syntax-dispatch tmp1117 (quote (any any each-any . each-any))))) e1116))))) (set! sc-expand (let ((m1128 (quote e)) (esew1129 (quote (eval)))) (lambda (x1130) (if (and (pair? x1130) (equal? (car x1130) noexpand37)) (cadr x1130) (chi-top102 x1130 (quote ()) (quote ((top))) m1128 esew1129))))) (set! sc-expand3 (let ((m1131 (quote e)) (esew1132 (quote (eval)))) (lambda (x1134 . rest1133) (if (and (pair? x1134) (equal? (car x1134) noexpand37)) (cadr x1134) (chi-top102 x1134 (quote ()) (quote ((top))) (if (null? rest1133) m1131 (car rest1133)) (if (or (null? rest1133) (null? (cdr rest1133))) esew1132 (cadr rest1133))))))) (set! identifier? (lambda (x1135) (nonsymbol-id?66 x1135))) (set! datum->syntax-object (lambda (id1136 datum1137) (begin (let ((x1138 id1136)) (if (not (nonsymbol-id?66 x1138)) (error-hook45 (quote datum->syntax-object) (quote "invalid argument") x1138))) (make-syntax-object52 datum1137 (syntax-object-wrap55 id1136))))) (set! syntax-object->datum (lambda (x1139) (strip114 x1139 (quote (()))))) (set! generate-temporaries (lambda (ls1140) (begin (let ((x1141 ls1140)) (if (not (list? x1141)) (error-hook45 (quote generate-temporaries) (quote "invalid argument") x1141))) (map (lambda (x1142) (wrap95 (gensym) (quote ((top))))) ls1140)))) (set! free-identifier=? (lambda (x1143 y1144) (begin (let ((x1145 x1143)) (if (not (nonsymbol-id?66 x1145)) (error-hook45 (quote free-identifier=?) (quote "invalid argument") x1145))) (let ((x1146 y1144)) (if (not (nonsymbol-id?66 x1146)) (error-hook45 (quote free-identifier=?) (quote "invalid argument") x1146))) (free-id=?90 x1143 y1144)))) (set! bound-identifier=? (lambda (x1147 y1148) (begin (let ((x1149 x1147)) (if (not (nonsymbol-id?66 x1149)) (error-hook45 (quote bound-identifier=?) (quote "invalid argument") x1149))) (let ((x1150 y1148)) (if (not (nonsymbol-id?66 x1150)) (error-hook45 (quote bound-identifier=?) (quote "invalid argument") x1150))) (bound-id=?91 x1147 y1148)))) (set! syntax-error (lambda (object1152 . messages1151) (begin (for-each (lambda (x1153) (let ((x1154 x1153)) (if (not (string? x1154)) (error-hook45 (quote syntax-error) (quote "invalid argument") x1154)))) messages1151) (let ((message1155 (if (null? messages1151) (quote "invalid syntax") (apply string-append messages1151)))) (error-hook45 (quote #f) message1155 (strip114 object1152 (quote (())))))))) (set! install-global-transformer (lambda (sym1156 v1157) (begin (let ((x1158 sym1156)) (if (not (symbol? x1158)) (error-hook45 (quote define-syntax) (quote "invalid argument") x1158))) (let ((x1159 v1157)) (if (not (procedure? x1159)) (error-hook45 (quote define-syntax) (quote "invalid argument") x1159))) (global-extend65 (quote macro) sym1156 v1157)))) (letrec ((match1164 (lambda (e1165 p1166 w1167 r1168) (cond ((not r1168) (quote #f)) ((eq? p1166 (quote any)) (cons (wrap95 e1165 w1167) r1168)) ((syntax-object?53 e1165) (match*1163 (let ((e1169 (syntax-object-expression54 e1165))) (if (annotation?42 e1169) (annotation-expression e1169) e1169)) p1166 (join-wraps86 w1167 (syntax-object-wrap55 e1165)) r1168)) (else (match*1163 (let ((e1170 e1165)) (if (annotation?42 e1170) (annotation-expression e1170) e1170)) p1166 w1167 r1168))))) (match*1163 (lambda (e1171 p1172 w1173 r1174) (cond ((null? p1172) (and (null? e1171) r1174)) ((pair? p1172) (and (pair? e1171) (match1164 (car e1171) (car p1172) w1173 (match1164 (cdr e1171) (cdr p1172) w1173 r1174)))) ((eq? p1172 (quote each-any)) (let ((l1175 (match-each-any1161 e1171 w1173))) (and l1175 (cons l1175 r1174)))) (else (let ((t1176 (vector-ref p1172 (quote 0)))) (if (memv t1176 (quote (each))) (if (null? e1171) (match-empty1162 (vector-ref p1172 (quote 1)) r1174) (let ((l1177 (match-each1160 e1171 (vector-ref p1172 (quote 1)) w1173))) (and l1177 (let collect1178 ((l1179 l1177)) (if (null? (car l1179)) r1174 (cons (map car l1179) (collect1178 (map cdr l1179)))))))) (if (memv t1176 (quote (free-id))) (and (id?67 e1171) (free-id=?90 (wrap95 e1171 w1173) (vector-ref p1172 (quote 1))) r1174) (if (memv t1176 (quote (atom))) (and (equal? (vector-ref p1172 (quote 1)) (strip114 e1171 w1173)) r1174) (if (memv t1176 (quote (vector))) (and (vector? e1171) (match1164 (vector->list e1171) (vector-ref p1172 (quote 1)) w1173 r1174))))))))))) (match-empty1162 (lambda (p1180 r1181) (cond ((null? p1180) r1181) ((eq? p1180 (quote any)) (cons (quote ()) r1181)) ((pair? p1180) (match-empty1162 (car p1180) (match-empty1162 (cdr p1180) r1181))) ((eq? p1180 (quote each-any)) (cons (quote ()) r1181)) (else (let ((t1182 (vector-ref p1180 (quote 0)))) (if (memv t1182 (quote (each))) (match-empty1162 (vector-ref p1180 (quote 1)) r1181) (if (memv t1182 (quote (free-id atom))) r1181 (if (memv t1182 (quote (vector))) (match-empty1162 (vector-ref p1180 (quote 1)) r1181))))))))) (match-each-any1161 (lambda (e1183 w1184) (cond ((annotation?42 e1183) (match-each-any1161 (annotation-expression e1183) w1184)) ((pair? e1183) (let ((l1185 (match-each-any1161 (cdr e1183) w1184))) (and l1185 (cons (wrap95 (car e1183) w1184) l1185)))) ((null? e1183) (quote ())) ((syntax-object?53 e1183) (match-each-any1161 (syntax-object-expression54 e1183) (join-wraps86 w1184 (syntax-object-wrap55 e1183)))) (else (quote #f))))) (match-each1160 (lambda (e1186 p1187 w1188) (cond ((annotation?42 e1186) (match-each1160 (annotation-expression e1186) p1187 w1188)) ((pair? e1186) (let ((first1189 (match1164 (car e1186) p1187 w1188 (quote ())))) (and first1189 (let ((rest1190 (match-each1160 (cdr e1186) p1187 w1188))) (and rest1190 (cons first1189 rest1190)))))) ((null? e1186) (quote ())) ((syntax-object?53 e1186) (match-each1160 (syntax-object-expression54 e1186) p1187 (join-wraps86 w1188 (syntax-object-wrap55 e1186)))) (else (quote #f)))))) (set! syntax-dispatch (lambda (e1191 p1192) (cond ((eq? p1192 (quote any)) (list e1191)) ((syntax-object?53 e1191) (match*1163 (let ((e1193 (syntax-object-expression54 e1191))) (if (annotation?42 e1193) (annotation-expression e1193) e1193)) p1192 (syntax-object-wrap55 e1191) (quote ()))) (else (match*1163 (let ((e1194 e1191)) (if (annotation?42 e1194) (annotation-expression e1194) e1194)) p1192 (quote (())) (quote ()))))))))) +(letrec ((lambda-var-list116 (lambda (vars323) (let lvl324 ((vars325 vars323) (ls326 (quote ())) (w327 (quote (())))) (cond ((pair? vars325) (lvl324 (cdr vars325) (cons (wrap95 (car vars325) w327) ls326) w327)) ((id?67 vars325) (cons (wrap95 vars325 w327) ls326)) ((null? vars325) ls326) ((syntax-object?53 vars325) (lvl324 (syntax-object-expression54 vars325) ls326 (join-wraps86 w327 (syntax-object-wrap55 vars325)))) ((annotation?42 vars325) (lvl324 (annotation-expression vars325) ls326 w327)) (else (cons vars325 ls326)))))) (gen-var115 (lambda (id328) (let ((id329 (if (syntax-object?53 id328) (syntax-object-expression54 id328) id328))) (if (annotation?42 id329) (gensym (symbol->string (annotation-expression id329))) (gensym (symbol->string id329)))))) (strip114 (lambda (x330 w331) (if (memq (quote top) (wrap-marks70 w331)) (if (or (annotation?42 x330) (and (pair? x330) (annotation?42 (car x330)))) (strip-annotation113 x330 (quote #f)) x330) (let f332 ((x333 x330)) (cond ((syntax-object?53 x333) (strip114 (syntax-object-expression54 x333) (syntax-object-wrap55 x333))) ((pair? x333) (let ((a334 (f332 (car x333))) (d335 (f332 (cdr x333)))) (if (and (eq? a334 (car x333)) (eq? d335 (cdr x333))) x333 (cons a334 d335)))) ((vector? x333) (let ((old336 (vector->list x333))) (let ((new337 (map f332 old336))) (if (andmap eq? old336 new337) x333 (list->vector new337))))) (else x333)))))) (strip-annotation113 (lambda (x338 parent339) (cond ((pair? x338) (let ((new340 (cons (quote #f) (quote #f)))) (begin (when parent339 (set-annotation-stripped! parent339 new340)) (set-car! new340 (strip-annotation113 (car x338) (quote #f))) (set-cdr! new340 (strip-annotation113 (cdr x338) (quote #f))) new340))) ((annotation?42 x338) (or (annotation-stripped x338) (strip-annotation113 (annotation-expression x338) x338))) ((vector? x338) (let ((new341 (make-vector (vector-length x338)))) (begin (when parent339 (set-annotation-stripped! parent339 new341)) (let loop342 ((i343 (- (vector-length x338) (quote 1)))) (unless (fx<41 i343 (quote 0)) (vector-set! new341 i343 (strip-annotation113 (vector-ref x338 i343) (quote #f))) (loop342 (fx-39 i343 (quote 1))))) new341))) (else x338)))) (ellipsis?112 (lambda (x344) (and (nonsymbol-id?66 x344) (free-id=?90 x344 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))))))) (chi-void111 (lambda () (list (quote void)))) (eval-local-transformer110 (lambda (expanded345) (let ((p346 (local-eval-hook44 expanded345))) (if (procedure? p346) p346 (syntax-error p346 (quote "nonprocedure transfomer")))))) (chi-local-syntax109 (lambda (rec?347 e348 r349 w350 s351 k352) ((lambda (tmp353) ((lambda (tmp354) (if tmp354 (apply (lambda (_355 id356 val357 e1358 e2359) (let ((ids360 id356)) (if (not (valid-bound-ids?92 ids360)) (syntax-error e348 (quote "duplicate bound keyword in")) (let ((labels362 (gen-labels73 ids360))) (let ((new-w363 (make-binding-wrap84 ids360 labels362 w350))) (k352 (cons e1358 e2359) (extend-env61 labels362 (let ((w365 (if rec?347 new-w363 w350)) (trans-r366 (macros-only-env63 r349))) (map (lambda (x367) (cons (quote macro) (eval-local-transformer110 (chi103 x367 trans-r366 w365)))) val357)) r349) new-w363 s351)))))) tmp354) ((lambda (_369) (syntax-error (source-wrap96 e348 w350 s351))) tmp353))) (syntax-dispatch tmp353 (quote (any #(each (any any)) any . each-any))))) e348))) (chi-lambda-clause108 (lambda (e370 c371 r372 w373 k374) ((lambda (tmp375) ((lambda (tmp376) (if tmp376 (apply (lambda (id377 e1378 e2379) (let ((ids380 id377)) (if (not (valid-bound-ids?92 ids380)) (syntax-error e370 (quote "invalid parameter list in")) (let ((labels382 (gen-labels73 ids380)) (new-vars383 (map gen-var115 ids380))) (k374 new-vars383 (chi-body107 (cons e1378 e2379) e370 (extend-var-env62 labels382 new-vars383 r372) (make-binding-wrap84 ids380 labels382 w373))))))) tmp376) ((lambda (tmp385) (if tmp385 (apply (lambda (ids386 e1387 e2388) (let ((old-ids389 (lambda-var-list116 ids386))) (if (not (valid-bound-ids?92 old-ids389)) (syntax-error e370 (quote "invalid parameter list in")) (let ((labels390 (gen-labels73 old-ids389)) (new-vars391 (map gen-var115 old-ids389))) (k374 (let f392 ((ls1393 (cdr new-vars391)) (ls2394 (car new-vars391))) (if (null? ls1393) ls2394 (f392 (cdr ls1393) (cons (car ls1393) ls2394)))) (chi-body107 (cons e1387 e2388) e370 (extend-var-env62 labels390 new-vars391 r372) (make-binding-wrap84 old-ids389 labels390 w373))))))) tmp385) ((lambda (_396) (syntax-error e370)) tmp375))) (syntax-dispatch tmp375 (quote (any any . each-any)))))) (syntax-dispatch tmp375 (quote (each-any any . each-any))))) c371))) (chi-body107 (lambda (body397 outer-form398 r399 w400) (let ((r401 (cons (quote ("placeholder" placeholder)) r399))) (let ((ribcage402 (make-ribcage74 (quote ()) (quote ()) (quote ())))) (let ((w403 (make-wrap69 (wrap-marks70 w400) (cons ribcage402 (wrap-subst71 w400))))) (let parse404 ((body405 (map (lambda (x411) (cons r401 (wrap95 x411 w403))) body397)) (ids406 (quote ())) (labels407 (quote ())) (vars408 (quote ())) (vals409 (quote ())) (bindings410 (quote ()))) (if (null? body405) (syntax-error outer-form398 (quote "no expressions in body")) (let ((e412 (cdar body405)) (er413 (caar body405))) (call-with-values (lambda () (syntax-type101 e412 er413 (quote (())) (quote #f) ribcage402)) (lambda (type414 value415 e416 w417 s418) (let ((t419 type414)) (if (memv t419 (quote (define-form))) (let ((id420 (wrap95 value415 w417)) (label421 (gen-label72))) (let ((var422 (gen-var115 id420))) (begin (extend-ribcage!83 ribcage402 id420 label421) (parse404 (cdr body405) (cons id420 ids406) (cons label421 labels407) (cons var422 vars408) (cons (cons er413 (wrap95 e416 w417)) vals409) (cons (cons (quote lexical) var422) bindings410))))) (if (memv t419 (quote (define-syntax-form))) (let ((id423 (wrap95 value415 w417)) (label424 (gen-label72))) (begin (extend-ribcage!83 ribcage402 id423 label424) (parse404 (cdr body405) (cons id423 ids406) (cons label424 labels407) vars408 vals409 (cons (cons (quote macro) (cons er413 (wrap95 e416 w417))) bindings410)))) (if (memv t419 (quote (begin-form))) ((lambda (tmp425) ((lambda (tmp426) (if tmp426 (apply (lambda (_427 e1428) (parse404 (let f429 ((forms430 e1428)) (if (null? forms430) (cdr body405) (cons (cons er413 (wrap95 (car forms430) w417)) (f429 (cdr forms430))))) ids406 labels407 vars408 vals409 bindings410)) tmp426) (syntax-error tmp425))) (syntax-dispatch tmp425 (quote (any . each-any))))) e416) (if (memv t419 (quote (local-syntax-form))) (chi-local-syntax109 value415 e416 er413 w417 s418 (lambda (forms432 er433 w434 s435) (parse404 (let f436 ((forms437 forms432)) (if (null? forms437) (cdr body405) (cons (cons er433 (wrap95 (car forms437) w434)) (f436 (cdr forms437))))) ids406 labels407 vars408 vals409 bindings410))) (if (null? ids406) (build-sequence48 (quote #f) (map (lambda (x438) (chi103 (cdr x438) (car x438) (quote (())))) (cons (cons er413 (source-wrap96 e416 w417 s418)) (cdr body405)))) (begin (if (not (valid-bound-ids?92 ids406)) (syntax-error outer-form398 (quote "invalid or duplicate identifier in definition"))) (let loop439 ((bs440 bindings410) (er-cache441 (quote #f)) (r-cache442 (quote #f))) (if (not (null? bs440)) (let ((b443 (car bs440))) (if (eq? (car b443) (quote macro)) (let ((er444 (cadr b443))) (let ((r-cache445 (if (eq? er444 er-cache441) r-cache442 (macros-only-env63 er444)))) (begin (set-cdr! b443 (eval-local-transformer110 (chi103 (cddr b443) r-cache445 (quote (()))))) (loop439 (cdr bs440) er444 r-cache445)))) (loop439 (cdr bs440) er-cache441 r-cache442))))) (set-cdr! r401 (extend-env61 labels407 bindings410 (cdr r401))) (build-letrec51 (quote #f) vars408 (map (lambda (x446) (chi103 (cdr x446) (car x446) (quote (())))) vals409) (build-sequence48 (quote #f) (map (lambda (x447) (chi103 (cdr x447) (car x447) (quote (())))) (cons (cons er413 (source-wrap96 e416 w417 s418)) (cdr body405)))))))))))))))))))))) (chi-macro106 (lambda (p448 e449 r450 w451 rib452) (letrec ((rebuild-macro-output453 (lambda (x454 m455) (cond ((pair? x454) (cons (rebuild-macro-output453 (car x454) m455) (rebuild-macro-output453 (cdr x454) m455))) ((syntax-object?53 x454) (let ((w456 (syntax-object-wrap55 x454))) (let ((ms457 (wrap-marks70 w456)) (s458 (wrap-subst71 w456))) (make-syntax-object52 (syntax-object-expression54 x454) (if (and (pair? ms457) (eq? (car ms457) (quote #f))) (make-wrap69 (cdr ms457) (if rib452 (cons rib452 (cdr s458)) (cdr s458))) (make-wrap69 (cons m455 ms457) (if rib452 (cons rib452 (cons (quote shift) s458)) (cons (quote shift) s458)))))))) ((vector? x454) (let ((n459 (vector-length x454))) (let ((v460 (make-vector n459))) (let doloop461 ((i462 (quote 0))) (if (fx=40 i462 n459) v460 (begin (vector-set! v460 i462 (rebuild-macro-output453 (vector-ref x454 i462) m455)) (doloop461 (fx+38 i462 (quote 1))))))))) ((symbol? x454) (syntax-error x454 (quote "encountered raw symbol in macro output"))) (else x454))))) (rebuild-macro-output453 (p448 (wrap95 e449 (anti-mark82 w451))) (string (quote #\m)))))) (chi-application105 (lambda (x463 e464 r465 w466 s467) ((lambda (tmp468) ((lambda (tmp469) (if tmp469 (apply (lambda (e0470 e1471) (cons x463 (map (lambda (e472) (chi103 e472 r465 w466)) e1471))) tmp469) (syntax-error tmp468))) (syntax-dispatch tmp468 (quote (any . each-any))))) e464))) (chi-expr104 (lambda (type474 value475 e476 r477 w478 s479) (let ((t480 type474)) (if (memv t480 (quote (lexical))) value475 (if (memv t480 (quote (core))) (value475 e476 r477 w478 s479) (if (memv t480 (quote (lexical-call))) (chi-application105 value475 e476 r477 w478 s479) (if (memv t480 (quote (global-call))) (chi-application105 value475 e476 r477 w478 s479) (if (memv t480 (quote (constant))) (list (quote quote) (strip114 (source-wrap96 e476 w478 s479) (quote (())))) (if (memv t480 (quote (global))) value475 (if (memv t480 (quote (call))) (chi-application105 (chi103 (car e476) r477 w478) e476 r477 w478 s479) (if (memv t480 (quote (begin-form))) ((lambda (tmp481) ((lambda (tmp482) (if tmp482 (apply (lambda (_483 e1484 e2485) (chi-sequence97 (cons e1484 e2485) r477 w478 s479)) tmp482) (syntax-error tmp481))) (syntax-dispatch tmp481 (quote (any any . each-any))))) e476) (if (memv t480 (quote (local-syntax-form))) (chi-local-syntax109 value475 e476 r477 w478 s479 chi-sequence97) (if (memv t480 (quote (eval-when-form))) ((lambda (tmp487) ((lambda (tmp488) (if tmp488 (apply (lambda (_489 x490 e1491 e2492) (let ((when-list493 (chi-when-list100 e476 x490 w478))) (if (memq (quote eval) when-list493) (chi-sequence97 (cons e1491 e2492) r477 w478 s479) (chi-void111)))) tmp488) (syntax-error tmp487))) (syntax-dispatch tmp487 (quote (any each-any any . each-any))))) e476) (if (memv t480 (quote (define-form define-syntax-form))) (syntax-error (wrap95 value475 w478) (quote "invalid context for definition of")) (if (memv t480 (quote (syntax))) (syntax-error (source-wrap96 e476 w478 s479) (quote "reference to pattern variable outside syntax form")) (if (memv t480 (quote (displaced-lexical))) (syntax-error (source-wrap96 e476 w478 s479) (quote "reference to identifier outside its scope")) (syntax-error (source-wrap96 e476 w478 s479)))))))))))))))))) (chi103 (lambda (e496 r497 w498) (call-with-values (lambda () (syntax-type101 e496 r497 w498 (quote #f) (quote #f))) (lambda (type499 value500 e501 w502 s503) (chi-expr104 type499 value500 e501 r497 w502 s503))))) (chi-top102 (lambda (e504 r505 w506 m507 esew508) (call-with-values (lambda () (syntax-type101 e504 r505 w506 (quote #f) (quote #f))) (lambda (type515 value516 e517 w518 s519) (let ((t520 type515)) (if (memv t520 (quote (begin-form))) ((lambda (tmp521) ((lambda (tmp522) (if tmp522 (apply (lambda (_523) (chi-void111)) tmp522) ((lambda (tmp524) (if tmp524 (apply (lambda (_525 e1526 e2527) (chi-top-sequence98 (cons e1526 e2527) r505 w518 s519 m507 esew508)) tmp524) (syntax-error tmp521))) (syntax-dispatch tmp521 (quote (any any . each-any)))))) (syntax-dispatch tmp521 (quote (any))))) e517) (if (memv t520 (quote (local-syntax-form))) (chi-local-syntax109 value516 e517 r505 w518 s519 (lambda (body529 r530 w531 s532) (chi-top-sequence98 body529 r530 w531 s532 m507 esew508))) (if (memv t520 (quote (eval-when-form))) ((lambda (tmp533) ((lambda (tmp534) (if tmp534 (apply (lambda (_535 x536 e1537 e2538) (let ((when-list539 (chi-when-list100 e517 x536 w518)) (body540 (cons e1537 e2538))) (cond ((eq? m507 (quote e)) (if (memq (quote eval) when-list539) (chi-top-sequence98 body540 r505 w518 s519 (quote e) (quote (eval))) (chi-void111))) ((memq (quote load) when-list539) (if (or (memq (quote compile) when-list539) (and (eq? m507 (quote c&e)) (memq (quote eval) when-list539))) (chi-top-sequence98 body540 r505 w518 s519 (quote c&e) (quote (compile load))) (if (memq m507 (quote (c c&e))) (chi-top-sequence98 body540 r505 w518 s519 (quote c) (quote (load))) (chi-void111)))) ((or (memq (quote compile) when-list539) (and (eq? m507 (quote c&e)) (memq (quote eval) when-list539))) (top-level-eval-hook43 (chi-top-sequence98 body540 r505 w518 s519 (quote e) (quote (eval)))) (chi-void111)) (else (chi-void111))))) tmp534) (syntax-error tmp533))) (syntax-dispatch tmp533 (quote (any each-any any . each-any))))) e517) (if (memv t520 (quote (define-syntax-form))) (let ((n543 (id-var-name89 value516 w518)) (r544 (macros-only-env63 r505))) (let ((t545 m507)) (if (memv t545 (quote (c))) (if (memq (quote compile) esew508) (let ((e546 (chi-install-global99 n543 (chi103 e517 r544 w518)))) (begin (top-level-eval-hook43 e546) (if (memq (quote load) esew508) e546 (chi-void111)))) (if (memq (quote load) esew508) (chi-install-global99 n543 (chi103 e517 r544 w518)) (chi-void111))) (if (memv t545 (quote (c&e))) (let ((e547 (chi-install-global99 n543 (chi103 e517 r544 w518)))) (begin (top-level-eval-hook43 e547) e547)) (begin (if (memq (quote eval) esew508) (top-level-eval-hook43 (chi-install-global99 n543 (chi103 e517 r544 w518)))) (chi-void111)))))) (if (memv t520 (quote (define-form))) (let ((n548 (id-var-name89 value516 w518))) (let ((t549 (binding-type59 (lookup64 n548 r505)))) (if (memv t549 (quote (global))) (let ((x550 (list (quote define) n548 (chi103 e517 r505 w518)))) (begin (if (eq? m507 (quote c&e)) (top-level-eval-hook43 x550)) x550)) (if (memv t549 (quote (displaced-lexical))) (syntax-error (wrap95 value516 w518) (quote "identifier out of context")) (syntax-error (wrap95 value516 w518) (quote "cannot define keyword at top level")))))) (let ((x551 (chi-expr104 type515 value516 e517 r505 w518 s519))) (begin (if (eq? m507 (quote c&e)) (top-level-eval-hook43 x551)) x551)))))))))))) (syntax-type101 (lambda (e552 r553 w554 s555 rib556) (cond ((symbol? e552) (let ((n557 (id-var-name89 e552 w554))) (let ((b558 (lookup64 n557 r553))) (let ((type559 (binding-type59 b558))) (let ((t560 type559)) (if (memv t560 (quote (lexical))) (values type559 (binding-value60 b558) e552 w554 s555) (if (memv t560 (quote (global))) (values type559 n557 e552 w554 s555) (if (memv t560 (quote (macro))) (syntax-type101 (chi-macro106 (binding-value60 b558) e552 r553 w554 rib556) r553 (quote (())) s555 rib556) (values type559 (binding-value60 b558) e552 w554 s555))))))))) ((pair? e552) (let ((first561 (car e552))) (if (id?67 first561) (let ((n562 (id-var-name89 first561 w554))) (let ((b563 (lookup64 n562 r553))) (let ((type564 (binding-type59 b563))) (let ((t565 type564)) (if (memv t565 (quote (lexical))) (values (quote lexical-call) (binding-value60 b563) e552 w554 s555) (if (memv t565 (quote (global))) (values (quote global-call) n562 e552 w554 s555) (if (memv t565 (quote (macro))) (syntax-type101 (chi-macro106 (binding-value60 b563) e552 r553 w554 rib556) r553 (quote (())) s555 rib556) (if (memv t565 (quote (core))) (values type564 (binding-value60 b563) e552 w554 s555) (if (memv t565 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value60 b563) e552 w554 s555) (if (memv t565 (quote (begin))) (values (quote begin-form) (quote #f) e552 w554 s555) (if (memv t565 (quote (eval-when))) (values (quote eval-when-form) (quote #f) e552 w554 s555) (if (memv t565 (quote (define))) ((lambda (tmp566) ((lambda (tmp567) (if (if tmp567 (apply (lambda (_568 name569 val570) (id?67 name569)) tmp567) (quote #f)) (apply (lambda (_571 name572 val573) (values (quote define-form) name572 val573 w554 s555)) tmp567) ((lambda (tmp574) (if (if tmp574 (apply (lambda (_575 name576 args577 e1578 e2579) (and (id?67 name576) (valid-bound-ids?92 (lambda-var-list116 args577)))) tmp574) (quote #f)) (apply (lambda (_580 name581 args582 e1583 e2584) (values (quote define-form) (wrap95 name581 w554) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) (wrap95 (cons args582 (cons e1583 e2584)) w554)) (quote (())) s555)) tmp574) ((lambda (tmp586) (if (if tmp586 (apply (lambda (_587 name588) (id?67 name588)) tmp586) (quote #f)) (apply (lambda (_589 name590) (values (quote define-form) (wrap95 name590 w554) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote (())) s555)) tmp586) (syntax-error tmp566))) (syntax-dispatch tmp566 (quote (any any)))))) (syntax-dispatch tmp566 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp566 (quote (any any any))))) e552) (if (memv t565 (quote (define-syntax))) ((lambda (tmp591) ((lambda (tmp592) (if (if tmp592 (apply (lambda (_593 name594 val595) (id?67 name594)) tmp592) (quote #f)) (apply (lambda (_596 name597 val598) (values (quote define-syntax-form) name597 val598 w554 s555)) tmp592) (syntax-error tmp591))) (syntax-dispatch tmp591 (quote (any any any))))) e552) (values (quote call) (quote #f) e552 w554 s555)))))))))))))) (values (quote call) (quote #f) e552 w554 s555)))) ((syntax-object?53 e552) (syntax-type101 (syntax-object-expression54 e552) r553 (join-wraps86 w554 (syntax-object-wrap55 e552)) (quote #f) rib556)) ((annotation?42 e552) (syntax-type101 (annotation-expression e552) r553 w554 (annotation-source e552) rib556)) ((let ((x599 e552)) (or (boolean? x599) (number? x599) (string? x599) (char? x599) (null? x599) (keyword? x599))) (values (quote constant) (quote #f) e552 w554 s555)) (else (values (quote other) (quote #f) e552 w554 s555))))) (chi-when-list100 (lambda (e600 when-list601 w602) (let f603 ((when-list604 when-list601) (situations605 (quote ()))) (if (null? when-list604) situations605 (f603 (cdr when-list604) (cons (let ((x606 (car when-list604))) (cond ((free-id=?90 x606 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote compile)) ((free-id=?90 x606 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote load)) ((free-id=?90 x606 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote eval)) (else (syntax-error (wrap95 x606 w602) (quote "invalid eval-when situation"))))) situations605)))))) (chi-install-global99 (lambda (name607 e608) (list (quote install-global-transformer) (list (quote quote) name607) e608))) (chi-top-sequence98 (lambda (body609 r610 w611 s612 m613 esew614) (build-sequence48 s612 (let dobody615 ((body616 body609) (r617 r610) (w618 w611) (m619 m613) (esew620 esew614)) (if (null? body616) (quote ()) (let ((first621 (chi-top102 (car body616) r617 w618 m619 esew620))) (cons first621 (dobody615 (cdr body616) r617 w618 m619 esew620)))))))) (chi-sequence97 (lambda (body622 r623 w624 s625) (build-sequence48 s625 (let dobody626 ((body627 body622) (r628 r623) (w629 w624)) (if (null? body627) (quote ()) (let ((first630 (chi103 (car body627) r628 w629))) (cons first630 (dobody626 (cdr body627) r628 w629)))))))) (source-wrap96 (lambda (x631 w632 s633) (wrap95 (if s633 (make-annotation x631 s633 (quote #f)) x631) w632))) (wrap95 (lambda (x634 w635) (cond ((and (null? (wrap-marks70 w635)) (null? (wrap-subst71 w635))) x634) ((syntax-object?53 x634) (make-syntax-object52 (syntax-object-expression54 x634) (join-wraps86 w635 (syntax-object-wrap55 x634)))) ((null? x634) x634) (else (make-syntax-object52 x634 w635))))) (bound-id-member?94 (lambda (x636 list637) (and (not (null? list637)) (or (bound-id=?91 x636 (car list637)) (bound-id-member?94 x636 (cdr list637)))))) (distinct-bound-ids?93 (lambda (ids638) (let distinct?639 ((ids640 ids638)) (or (null? ids640) (and (not (bound-id-member?94 (car ids640) (cdr ids640))) (distinct?639 (cdr ids640))))))) (valid-bound-ids?92 (lambda (ids641) (and (let all-ids?642 ((ids643 ids641)) (or (null? ids643) (and (id?67 (car ids643)) (all-ids?642 (cdr ids643))))) (distinct-bound-ids?93 ids641)))) (bound-id=?91 (lambda (i644 j645) (if (and (syntax-object?53 i644) (syntax-object?53 j645)) (and (eq? (let ((e646 (syntax-object-expression54 i644))) (if (annotation?42 e646) (annotation-expression e646) e646)) (let ((e647 (syntax-object-expression54 j645))) (if (annotation?42 e647) (annotation-expression e647) e647))) (same-marks?88 (wrap-marks70 (syntax-object-wrap55 i644)) (wrap-marks70 (syntax-object-wrap55 j645)))) (eq? (let ((e648 i644)) (if (annotation?42 e648) (annotation-expression e648) e648)) (let ((e649 j645)) (if (annotation?42 e649) (annotation-expression e649) e649)))))) (free-id=?90 (lambda (i650 j651) (and (eq? (let ((x652 i650)) (let ((e653 (if (syntax-object?53 x652) (syntax-object-expression54 x652) x652))) (if (annotation?42 e653) (annotation-expression e653) e653))) (let ((x654 j651)) (let ((e655 (if (syntax-object?53 x654) (syntax-object-expression54 x654) x654))) (if (annotation?42 e655) (annotation-expression e655) e655)))) (eq? (id-var-name89 i650 (quote (()))) (id-var-name89 j651 (quote (()))))))) (id-var-name89 (lambda (id656 w657) (letrec ((search-vector-rib660 (lambda (sym666 subst667 marks668 symnames669 ribcage670) (let ((n671 (vector-length symnames669))) (let f672 ((i673 (quote 0))) (cond ((fx=40 i673 n671) (search658 sym666 (cdr subst667) marks668)) ((and (eq? (vector-ref symnames669 i673) sym666) (same-marks?88 marks668 (vector-ref (ribcage-marks77 ribcage670) i673))) (values (vector-ref (ribcage-labels78 ribcage670) i673) marks668)) (else (f672 (fx+38 i673 (quote 1))))))))) (search-list-rib659 (lambda (sym674 subst675 marks676 symnames677 ribcage678) (let f679 ((symnames680 symnames677) (i681 (quote 0))) (cond ((null? symnames680) (search658 sym674 (cdr subst675) marks676)) ((and (eq? (car symnames680) sym674) (same-marks?88 marks676 (list-ref (ribcage-marks77 ribcage678) i681))) (values (list-ref (ribcage-labels78 ribcage678) i681) marks676)) (else (f679 (cdr symnames680) (fx+38 i681 (quote 1)))))))) (search658 (lambda (sym682 subst683 marks684) (if (null? subst683) (values (quote #f) marks684) (let ((fst685 (car subst683))) (if (eq? fst685 (quote shift)) (search658 sym682 (cdr subst683) (cdr marks684)) (let ((symnames686 (ribcage-symnames76 fst685))) (if (vector? symnames686) (search-vector-rib660 sym682 subst683 marks684 symnames686 fst685) (search-list-rib659 sym682 subst683 marks684 symnames686 fst685))))))))) (cond ((symbol? id656) (or (call-with-values (lambda () (search658 id656 (wrap-subst71 w657) (wrap-marks70 w657))) (lambda (x688 . ignore687) x688)) id656)) ((syntax-object?53 id656) (let ((id689 (let ((e691 (syntax-object-expression54 id656))) (if (annotation?42 e691) (annotation-expression e691) e691))) (w1690 (syntax-object-wrap55 id656))) (let ((marks692 (join-marks87 (wrap-marks70 w657) (wrap-marks70 w1690)))) (call-with-values (lambda () (search658 id689 (wrap-subst71 w657) marks692)) (lambda (new-id693 marks694) (or new-id693 (call-with-values (lambda () (search658 id689 (wrap-subst71 w1690) marks694)) (lambda (x696 . ignore695) x696)) id689)))))) ((annotation?42 id656) (let ((id697 (let ((e698 id656)) (if (annotation?42 e698) (annotation-expression e698) e698)))) (or (call-with-values (lambda () (search658 id697 (wrap-subst71 w657) (wrap-marks70 w657))) (lambda (x700 . ignore699) x700)) id697))) (else (error-hook45 (quote id-var-name) (quote "invalid id") id656)))))) (same-marks?88 (lambda (x701 y702) (or (eq? x701 y702) (and (not (null? x701)) (not (null? y702)) (eq? (car x701) (car y702)) (same-marks?88 (cdr x701) (cdr y702)))))) (join-marks87 (lambda (m1703 m2704) (smart-append85 m1703 m2704))) (join-wraps86 (lambda (w1705 w2706) (let ((m1707 (wrap-marks70 w1705)) (s1708 (wrap-subst71 w1705))) (if (null? m1707) (if (null? s1708) w2706 (make-wrap69 (wrap-marks70 w2706) (smart-append85 s1708 (wrap-subst71 w2706)))) (make-wrap69 (smart-append85 m1707 (wrap-marks70 w2706)) (smart-append85 s1708 (wrap-subst71 w2706))))))) (smart-append85 (lambda (m1709 m2710) (if (null? m2710) m1709 (append m1709 m2710)))) (make-binding-wrap84 (lambda (ids711 labels712 w713) (if (null? ids711) w713 (make-wrap69 (wrap-marks70 w713) (cons (let ((labelvec714 (list->vector labels712))) (let ((n715 (vector-length labelvec714))) (let ((symnamevec716 (make-vector n715)) (marksvec717 (make-vector n715))) (begin (let f718 ((ids719 ids711) (i720 (quote 0))) (if (not (null? ids719)) (call-with-values (lambda () (id-sym-name&marks68 (car ids719) w713)) (lambda (symname721 marks722) (begin (vector-set! symnamevec716 i720 symname721) (vector-set! marksvec717 i720 marks722) (f718 (cdr ids719) (fx+38 i720 (quote 1)))))))) (make-ribcage74 symnamevec716 marksvec717 labelvec714))))) (wrap-subst71 w713)))))) (extend-ribcage!83 (lambda (ribcage723 id724 label725) (begin (set-ribcage-symnames!79 ribcage723 (cons (let ((e726 (syntax-object-expression54 id724))) (if (annotation?42 e726) (annotation-expression e726) e726)) (ribcage-symnames76 ribcage723))) (set-ribcage-marks!80 ribcage723 (cons (wrap-marks70 (syntax-object-wrap55 id724)) (ribcage-marks77 ribcage723))) (set-ribcage-labels!81 ribcage723 (cons label725 (ribcage-labels78 ribcage723)))))) (anti-mark82 (lambda (w727) (make-wrap69 (cons (quote #f) (wrap-marks70 w727)) (cons (quote shift) (wrap-subst71 w727))))) (set-ribcage-labels!81 (lambda (x728 update729) (vector-set! x728 (quote 3) update729))) (set-ribcage-marks!80 (lambda (x730 update731) (vector-set! x730 (quote 2) update731))) (set-ribcage-symnames!79 (lambda (x732 update733) (vector-set! x732 (quote 1) update733))) (ribcage-labels78 (lambda (x734) (vector-ref x734 (quote 3)))) (ribcage-marks77 (lambda (x735) (vector-ref x735 (quote 2)))) (ribcage-symnames76 (lambda (x736) (vector-ref x736 (quote 1)))) (ribcage?75 (lambda (x737) (and (vector? x737) (= (vector-length x737) (quote 4)) (eq? (vector-ref x737 (quote 0)) (quote ribcage))))) (make-ribcage74 (lambda (symnames738 marks739 labels740) (vector (quote ribcage) symnames738 marks739 labels740))) (gen-labels73 (lambda (ls741) (if (null? ls741) (quote ()) (cons (gen-label72) (gen-labels73 (cdr ls741)))))) (gen-label72 (lambda () (string (quote #\i)))) (wrap-subst71 cdr) (wrap-marks70 car) (make-wrap69 cons) (id-sym-name&marks68 (lambda (x742 w743) (if (syntax-object?53 x742) (values (let ((e744 (syntax-object-expression54 x742))) (if (annotation?42 e744) (annotation-expression e744) e744)) (join-marks87 (wrap-marks70 w743) (wrap-marks70 (syntax-object-wrap55 x742)))) (values (let ((e745 x742)) (if (annotation?42 e745) (annotation-expression e745) e745)) (wrap-marks70 w743))))) (id?67 (lambda (x746) (cond ((symbol? x746) (quote #t)) ((syntax-object?53 x746) (symbol? (let ((e747 (syntax-object-expression54 x746))) (if (annotation?42 e747) (annotation-expression e747) e747)))) ((annotation?42 x746) (symbol? (annotation-expression x746))) (else (quote #f))))) (nonsymbol-id?66 (lambda (x748) (and (syntax-object?53 x748) (symbol? (let ((e749 (syntax-object-expression54 x748))) (if (annotation?42 e749) (annotation-expression e749) e749)))))) (global-extend65 (lambda (type750 sym751 val752) (put-global-definition-hook46 sym751 (cons type750 val752)))) (lookup64 (lambda (x753 r754) (cond ((assq x753 r754) => cdr) ((symbol? x753) (or (get-global-definition-hook47 x753) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env63 (lambda (r755) (if (null? r755) (quote ()) (let ((a756 (car r755))) (if (eq? (cadr a756) (quote macro)) (cons a756 (macros-only-env63 (cdr r755))) (macros-only-env63 (cdr r755))))))) (extend-var-env62 (lambda (labels757 vars758 r759) (if (null? labels757) r759 (extend-var-env62 (cdr labels757) (cdr vars758) (cons (cons (car labels757) (cons (quote lexical) (car vars758))) r759))))) (extend-env61 (lambda (labels760 bindings761 r762) (if (null? labels760) r762 (extend-env61 (cdr labels760) (cdr bindings761) (cons (cons (car labels760) (car bindings761)) r762))))) (binding-value60 cdr) (binding-type59 car) (source-annotation58 (lambda (x763) (cond ((annotation?42 x763) (annotation-source x763)) ((syntax-object?53 x763) (source-annotation58 (syntax-object-expression54 x763))) (else (quote #f))))) (set-syntax-object-wrap!57 (lambda (x764 update765) (vector-set! x764 (quote 2) update765))) (set-syntax-object-expression!56 (lambda (x766 update767) (vector-set! x766 (quote 1) update767))) (syntax-object-wrap55 (lambda (x768) (vector-ref x768 (quote 2)))) (syntax-object-expression54 (lambda (x769) (vector-ref x769 (quote 1)))) (syntax-object?53 (lambda (x770) (and (vector? x770) (= (vector-length x770) (quote 3)) (eq? (vector-ref x770 (quote 0)) (quote syntax-object))))) (make-syntax-object52 (lambda (expression771 wrap772) (vector (quote syntax-object) expression771 wrap772))) (build-letrec51 (lambda (src773 vars774 val-exps775 body-exp776) (if (null? vars774) body-exp776 (list (quote letrec) (map list vars774 val-exps775) body-exp776)))) (build-named-let50 (lambda (src777 vars778 val-exps779 body-exp780) (if (null? vars778) body-exp780 (list (quote let) (car vars778) (map list (cdr vars778) val-exps779) body-exp780)))) (build-let49 (lambda (src781 vars782 val-exps783 body-exp784) (if (null? vars782) body-exp784 (list (quote let) (map list vars782 val-exps783) body-exp784)))) (build-sequence48 (lambda (src785 exps786) (if (null? (cdr exps786)) (car exps786) (cons (quote begin) exps786)))) (get-global-definition-hook47 (lambda (symbol787) (getprop symbol787 (quote *sc-expander*)))) (put-global-definition-hook46 (lambda (symbol788 binding789) (putprop symbol788 (quote *sc-expander*) binding789))) (error-hook45 (lambda (who790 why791 what792) (error who790 (quote "~a ~s") why791 what792))) (local-eval-hook44 (lambda (x793) (eval (list noexpand37 x793) (interaction-environment)))) (top-level-eval-hook43 (lambda (x794) (eval (list noexpand37 x794) (interaction-environment)))) (annotation?42 (lambda (x795) (quote #f))) (fx<41 <) (fx=40 =) (fx-39 -) (fx+38 +) (noexpand37 (quote "noexpand"))) (begin (global-extend65 (quote local-syntax) (quote letrec-syntax) (quote #t)) (global-extend65 (quote local-syntax) (quote let-syntax) (quote #f)) (global-extend65 (quote core) (quote fluid-let-syntax) (lambda (e796 r797 w798 s799) ((lambda (tmp800) ((lambda (tmp801) (if (if tmp801 (apply (lambda (_802 var803 val804 e1805 e2806) (valid-bound-ids?92 var803)) tmp801) (quote #f)) (apply (lambda (_808 var809 val810 e1811 e2812) (let ((names813 (map (lambda (x814) (id-var-name89 x814 w798)) var809))) (begin (for-each (lambda (id816 n817) (let ((t818 (binding-type59 (lookup64 n817 r797)))) (if (memv t818 (quote (displaced-lexical))) (syntax-error (source-wrap96 id816 w798 s799) (quote "identifier out of context"))))) var809 names813) (chi-body107 (cons e1811 e2812) (source-wrap96 e796 w798 s799) (extend-env61 names813 (let ((trans-r821 (macros-only-env63 r797))) (map (lambda (x822) (cons (quote macro) (eval-local-transformer110 (chi103 x822 trans-r821 w798)))) val810)) r797) w798)))) tmp801) ((lambda (_824) (syntax-error (source-wrap96 e796 w798 s799))) tmp800))) (syntax-dispatch tmp800 (quote (any #(each (any any)) any . each-any))))) e796))) (global-extend65 (quote core) (quote quote) (lambda (e825 r826 w827 s828) ((lambda (tmp829) ((lambda (tmp830) (if tmp830 (apply (lambda (_831 e832) (list (quote quote) (strip114 e832 w827))) tmp830) ((lambda (_833) (syntax-error (source-wrap96 e825 w827 s828))) tmp829))) (syntax-dispatch tmp829 (quote (any any))))) e825))) (global-extend65 (quote core) (quote syntax) (letrec ((regen841 (lambda (x842) (let ((t843 (car x842))) (if (memv t843 (quote (ref))) (cadr x842) (if (memv t843 (quote (primitive))) (cadr x842) (if (memv t843 (quote (quote))) (list (quote quote) (cadr x842)) (if (memv t843 (quote (lambda))) (list (quote lambda) (cadr x842) (regen841 (caddr x842))) (if (memv t843 (quote (map))) (let ((ls844 (map regen841 (cdr x842)))) (cons (if (fx=40 (length ls844) (quote 2)) (quote map) (quote map)) ls844)) (cons (car x842) (map regen841 (cdr x842))))))))))) (gen-vector840 (lambda (x845) (cond ((eq? (car x845) (quote list)) (cons (quote vector) (cdr x845))) ((eq? (car x845) (quote quote)) (list (quote quote) (list->vector (cadr x845)))) (else (list (quote list->vector) x845))))) (gen-append839 (lambda (x846 y847) (if (equal? y847 (quote (quote ()))) x846 (list (quote append) x846 y847)))) (gen-cons838 (lambda (x848 y849) (let ((t850 (car y849))) (if (memv t850 (quote (quote))) (if (eq? (car x848) (quote quote)) (list (quote quote) (cons (cadr x848) (cadr y849))) (if (eq? (cadr y849) (quote ())) (list (quote list) x848) (list (quote cons) x848 y849))) (if (memv t850 (quote (list))) (cons (quote list) (cons x848 (cdr y849))) (list (quote cons) x848 y849)))))) (gen-map837 (lambda (e851 map-env852) (let ((formals853 (map cdr map-env852)) (actuals854 (map (lambda (x855) (list (quote ref) (car x855))) map-env852))) (cond ((eq? (car e851) (quote ref)) (car actuals854)) ((andmap (lambda (x856) (and (eq? (car x856) (quote ref)) (memq (cadr x856) formals853))) (cdr e851)) (cons (quote map) (cons (list (quote primitive) (car e851)) (map (let ((r857 (map cons formals853 actuals854))) (lambda (x858) (cdr (assq (cadr x858) r857)))) (cdr e851))))) (else (cons (quote map) (cons (list (quote lambda) formals853 e851) actuals854))))))) (gen-mappend836 (lambda (e859 map-env860) (list (quote apply) (quote (primitive append)) (gen-map837 e859 map-env860)))) (gen-ref835 (lambda (src861 var862 level863 maps864) (if (fx=40 level863 (quote 0)) (values var862 maps864) (if (null? maps864) (syntax-error src861 (quote "missing ellipsis in syntax form")) (call-with-values (lambda () (gen-ref835 src861 var862 (fx-39 level863 (quote 1)) (cdr maps864))) (lambda (outer-var865 outer-maps866) (let ((b867 (assq outer-var865 (car maps864)))) (if b867 (values (cdr b867) maps864) (let ((inner-var868 (gen-var115 (quote tmp)))) (values inner-var868 (cons (cons (cons outer-var865 inner-var868) (car maps864)) outer-maps866))))))))))) (gen-syntax834 (lambda (src869 e870 r871 maps872 ellipsis?873) (if (id?67 e870) (let ((label874 (id-var-name89 e870 (quote (()))))) (let ((b875 (lookup64 label874 r871))) (if (eq? (binding-type59 b875) (quote syntax)) (call-with-values (lambda () (let ((var.lev876 (binding-value60 b875))) (gen-ref835 src869 (car var.lev876) (cdr var.lev876) maps872))) (lambda (var877 maps878) (values (list (quote ref) var877) maps878))) (if (ellipsis?873 e870) (syntax-error src869 (quote "misplaced ellipsis in syntax form")) (values (list (quote quote) e870) maps872))))) ((lambda (tmp879) ((lambda (tmp880) (if (if tmp880 (apply (lambda (dots881 e882) (ellipsis?873 dots881)) tmp880) (quote #f)) (apply (lambda (dots883 e884) (gen-syntax834 src869 e884 r871 maps872 (lambda (x885) (quote #f)))) tmp880) ((lambda (tmp886) (if (if tmp886 (apply (lambda (x887 dots888 y889) (ellipsis?873 dots888)) tmp886) (quote #f)) (apply (lambda (x890 dots891 y892) (let f893 ((y894 y892) (k895 (lambda (maps896) (call-with-values (lambda () (gen-syntax834 src869 x890 r871 (cons (quote ()) maps896) ellipsis?873)) (lambda (x897 maps898) (if (null? (car maps898)) (syntax-error src869 (quote "extra ellipsis in syntax form")) (values (gen-map837 x897 (car maps898)) (cdr maps898)))))))) ((lambda (tmp899) ((lambda (tmp900) (if (if tmp900 (apply (lambda (dots901 y902) (ellipsis?873 dots901)) tmp900) (quote #f)) (apply (lambda (dots903 y904) (f893 y904 (lambda (maps905) (call-with-values (lambda () (k895 (cons (quote ()) maps905))) (lambda (x906 maps907) (if (null? (car maps907)) (syntax-error src869 (quote "extra ellipsis in syntax form")) (values (gen-mappend836 x906 (car maps907)) (cdr maps907)))))))) tmp900) ((lambda (_908) (call-with-values (lambda () (gen-syntax834 src869 y894 r871 maps872 ellipsis?873)) (lambda (y909 maps910) (call-with-values (lambda () (k895 maps910)) (lambda (x911 maps912) (values (gen-append839 x911 y909) maps912)))))) tmp899))) (syntax-dispatch tmp899 (quote (any . any))))) y894))) tmp886) ((lambda (tmp913) (if tmp913 (apply (lambda (x914 y915) (call-with-values (lambda () (gen-syntax834 src869 x914 r871 maps872 ellipsis?873)) (lambda (x916 maps917) (call-with-values (lambda () (gen-syntax834 src869 y915 r871 maps917 ellipsis?873)) (lambda (y918 maps919) (values (gen-cons838 x916 y918) maps919)))))) tmp913) ((lambda (tmp920) (if tmp920 (apply (lambda (e1921 e2922) (call-with-values (lambda () (gen-syntax834 src869 (cons e1921 e2922) r871 maps872 ellipsis?873)) (lambda (e924 maps925) (values (gen-vector840 e924) maps925)))) tmp920) ((lambda (_926) (values (list (quote quote) e870) maps872)) tmp879))) (syntax-dispatch tmp879 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp879 (quote (any . any)))))) (syntax-dispatch tmp879 (quote (any any . any)))))) (syntax-dispatch tmp879 (quote (any any))))) e870))))) (lambda (e927 r928 w929 s930) (let ((e931 (source-wrap96 e927 w929 s930))) ((lambda (tmp932) ((lambda (tmp933) (if tmp933 (apply (lambda (_934 x935) (call-with-values (lambda () (gen-syntax834 e931 x935 r928 (quote ()) ellipsis?112)) (lambda (e936 maps937) (regen841 e936)))) tmp933) ((lambda (_938) (syntax-error e931)) tmp932))) (syntax-dispatch tmp932 (quote (any any))))) e931))))) (global-extend65 (quote core) (quote lambda) (lambda (e939 r940 w941 s942) ((lambda (tmp943) ((lambda (tmp944) (if tmp944 (apply (lambda (_945 c946) (chi-lambda-clause108 (source-wrap96 e939 w941 s942) c946 r940 w941 (lambda (vars947 body948) (list (quote lambda) vars947 body948)))) tmp944) (syntax-error tmp943))) (syntax-dispatch tmp943 (quote (any . any))))) e939))) (global-extend65 (quote core) (quote let) (letrec ((chi-let949 (lambda (e950 r951 w952 s953 constructor954 ids955 vals956 exps957) (if (not (valid-bound-ids?92 ids955)) (syntax-error e950 (quote "duplicate bound variable in")) (let ((labels958 (gen-labels73 ids955)) (new-vars959 (map gen-var115 ids955))) (let ((nw960 (make-binding-wrap84 ids955 labels958 w952)) (nr961 (extend-var-env62 labels958 new-vars959 r951))) (constructor954 s953 new-vars959 (map (lambda (x962) (chi103 x962 r951 w952)) vals956) (chi-body107 exps957 (source-wrap96 e950 nw960 s953) nr961 nw960)))))))) (lambda (e963 r964 w965 s966) ((lambda (tmp967) ((lambda (tmp968) (if tmp968 (apply (lambda (_969 id970 val971 e1972 e2973) (chi-let949 e963 r964 w965 s966 build-let49 id970 val971 (cons e1972 e2973))) tmp968) ((lambda (tmp977) (if (if tmp977 (apply (lambda (_978 f979 id980 val981 e1982 e2983) (id?67 f979)) tmp977) (quote #f)) (apply (lambda (_984 f985 id986 val987 e1988 e2989) (chi-let949 e963 r964 w965 s966 build-named-let50 (cons f985 id986) val987 (cons e1988 e2989))) tmp977) ((lambda (_993) (syntax-error (source-wrap96 e963 w965 s966))) tmp967))) (syntax-dispatch tmp967 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp967 (quote (any #(each (any any)) any . each-any))))) e963)))) (global-extend65 (quote core) (quote letrec) (lambda (e994 r995 w996 s997) ((lambda (tmp998) ((lambda (tmp999) (if tmp999 (apply (lambda (_1000 id1001 val1002 e11003 e21004) (let ((ids1005 id1001)) (if (not (valid-bound-ids?92 ids1005)) (syntax-error e994 (quote "duplicate bound variable in")) (let ((labels1007 (gen-labels73 ids1005)) (new-vars1008 (map gen-var115 ids1005))) (let ((w1009 (make-binding-wrap84 ids1005 labels1007 w996)) (r1010 (extend-var-env62 labels1007 new-vars1008 r995))) (build-letrec51 s997 new-vars1008 (map (lambda (x1011) (chi103 x1011 r1010 w1009)) val1002) (chi-body107 (cons e11003 e21004) (source-wrap96 e994 w1009 s997) r1010 w1009))))))) tmp999) ((lambda (_1014) (syntax-error (source-wrap96 e994 w996 s997))) tmp998))) (syntax-dispatch tmp998 (quote (any #(each (any any)) any . each-any))))) e994))) (global-extend65 (quote core) (quote set!) (lambda (e1015 r1016 w1017 s1018) ((lambda (tmp1019) ((lambda (tmp1020) (if (if tmp1020 (apply (lambda (_1021 id1022 val1023) (id?67 id1022)) tmp1020) (quote #f)) (apply (lambda (_1024 id1025 val1026) (let ((val1027 (chi103 val1026 r1016 w1017)) (n1028 (id-var-name89 id1025 w1017))) (let ((b1029 (lookup64 n1028 r1016))) (let ((t1030 (binding-type59 b1029))) (if (memv t1030 (quote (lexical))) (list (quote set!) (binding-value60 b1029) val1027) (if (memv t1030 (quote (global))) (list (quote set!) n1028 val1027) (if (memv t1030 (quote (displaced-lexical))) (syntax-error (wrap95 id1025 w1017) (quote "identifier out of context")) (syntax-error (source-wrap96 e1015 w1017 s1018))))))))) tmp1020) ((lambda (tmp1031) (if tmp1031 (apply (lambda (_1032 getter1033 arg1034 val1035) (cons (chi103 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) getter1033) r1016 w1017) (map (lambda (e1036) (chi103 e1036 r1016 w1017)) (append arg1034 (list val1035))))) tmp1031) ((lambda (_1038) (syntax-error (source-wrap96 e1015 w1017 s1018))) tmp1019))) (syntax-dispatch tmp1019 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp1019 (quote (any any any))))) e1015))) (global-extend65 (quote begin) (quote begin) (quote ())) (global-extend65 (quote define) (quote define) (quote ())) (global-extend65 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend65 (quote eval-when) (quote eval-when) (quote ())) (global-extend65 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1042 (lambda (x1043 keys1044 clauses1045 r1046) (if (null? clauses1045) (list (quote syntax-error) x1043) ((lambda (tmp1047) ((lambda (tmp1048) (if tmp1048 (apply (lambda (pat1049 exp1050) (if (and (id?67 pat1049) (andmap (lambda (x1051) (not (free-id=?90 pat1049 x1051))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) keys1044))) (let ((labels1052 (list (gen-label72))) (var1053 (gen-var115 pat1049))) (list (list (quote lambda) (list var1053) (chi103 exp1050 (extend-env61 labels1052 (list (cons (quote syntax) (cons var1053 (quote 0)))) r1046) (make-binding-wrap84 (list pat1049) labels1052 (quote (()))))) x1043)) (gen-clause1041 x1043 keys1044 (cdr clauses1045) r1046 pat1049 (quote #t) exp1050))) tmp1048) ((lambda (tmp1054) (if tmp1054 (apply (lambda (pat1055 fender1056 exp1057) (gen-clause1041 x1043 keys1044 (cdr clauses1045) r1046 pat1055 fender1056 exp1057)) tmp1054) ((lambda (_1058) (syntax-error (car clauses1045) (quote "invalid syntax-case clause"))) tmp1047))) (syntax-dispatch tmp1047 (quote (any any any)))))) (syntax-dispatch tmp1047 (quote (any any))))) (car clauses1045))))) (gen-clause1041 (lambda (x1059 keys1060 clauses1061 r1062 pat1063 fender1064 exp1065) (call-with-values (lambda () (convert-pattern1039 pat1063 keys1060)) (lambda (p1066 pvars1067) (cond ((not (distinct-bound-ids?93 (map car pvars1067))) (syntax-error pat1063 (quote "duplicate pattern variable in syntax-case pattern"))) ((not (andmap (lambda (x1068) (not (ellipsis?112 (car x1068)))) pvars1067)) (syntax-error pat1063 (quote "misplaced ellipsis in syntax-case pattern"))) (else (let ((y1069 (gen-var115 (quote tmp)))) (list (list (quote lambda) (list y1069) (let ((y1070 y1069)) (list (quote if) ((lambda (tmp1071) ((lambda (tmp1072) (if tmp1072 (apply (lambda () y1070) tmp1072) ((lambda (_1073) (list (quote if) y1070 (build-dispatch-call1040 pvars1067 fender1064 y1070 r1062) (list (quote quote) (quote #f)))) tmp1071))) (syntax-dispatch tmp1071 (quote #(atom #t))))) fender1064) (build-dispatch-call1040 pvars1067 exp1065 y1070 r1062) (gen-syntax-case1042 x1059 keys1060 clauses1061 r1062)))) (if (eq? p1066 (quote any)) (list (quote list) x1059) (list (quote syntax-dispatch) x1059 (list (quote quote) p1066))))))))))) (build-dispatch-call1040 (lambda (pvars1074 exp1075 y1076 r1077) (let ((ids1078 (map car pvars1074)) (levels1079 (map cdr pvars1074))) (let ((labels1080 (gen-labels73 ids1078)) (new-vars1081 (map gen-var115 ids1078))) (list (quote apply) (list (quote lambda) new-vars1081 (chi103 exp1075 (extend-env61 labels1080 (map (lambda (var1082 level1083) (cons (quote syntax) (cons var1082 level1083))) new-vars1081 (map cdr pvars1074)) r1077) (make-binding-wrap84 ids1078 labels1080 (quote (()))))) y1076))))) (convert-pattern1039 (lambda (pattern1084 keys1085) (let cvt1086 ((p1087 pattern1084) (n1088 (quote 0)) (ids1089 (quote ()))) (if (id?67 p1087) (if (bound-id-member?94 p1087 keys1085) (values (vector (quote free-id) p1087) ids1089) (values (quote any) (cons (cons p1087 n1088) ids1089))) ((lambda (tmp1090) ((lambda (tmp1091) (if (if tmp1091 (apply (lambda (x1092 dots1093) (ellipsis?112 dots1093)) tmp1091) (quote #f)) (apply (lambda (x1094 dots1095) (call-with-values (lambda () (cvt1086 x1094 (fx+38 n1088 (quote 1)) ids1089)) (lambda (p1096 ids1097) (values (if (eq? p1096 (quote any)) (quote each-any) (vector (quote each) p1096)) ids1097)))) tmp1091) ((lambda (tmp1098) (if tmp1098 (apply (lambda (x1099 y1100) (call-with-values (lambda () (cvt1086 y1100 n1088 ids1089)) (lambda (y1101 ids1102) (call-with-values (lambda () (cvt1086 x1099 n1088 ids1102)) (lambda (x1103 ids1104) (values (cons x1103 y1101) ids1104)))))) tmp1098) ((lambda (tmp1105) (if tmp1105 (apply (lambda () (values (quote ()) ids1089)) tmp1105) ((lambda (tmp1106) (if tmp1106 (apply (lambda (x1107) (call-with-values (lambda () (cvt1086 x1107 n1088 ids1089)) (lambda (p1109 ids1110) (values (vector (quote vector) p1109) ids1110)))) tmp1106) ((lambda (x1111) (values (vector (quote atom) (strip114 p1087 (quote (())))) ids1089)) tmp1090))) (syntax-dispatch tmp1090 (quote #(vector each-any)))))) (syntax-dispatch tmp1090 (quote ()))))) (syntax-dispatch tmp1090 (quote (any . any)))))) (syntax-dispatch tmp1090 (quote (any any))))) p1087)))))) (lambda (e1112 r1113 w1114 s1115) (let ((e1116 (source-wrap96 e1112 w1114 s1115))) ((lambda (tmp1117) ((lambda (tmp1118) (if tmp1118 (apply (lambda (_1119 val1120 key1121 m1122) (if (andmap (lambda (x1123) (and (id?67 x1123) (not (ellipsis?112 x1123)))) key1121) (let ((x1125 (gen-var115 (quote tmp)))) (list (list (quote lambda) (list x1125) (gen-syntax-case1042 x1125 key1121 m1122 r1113)) (chi103 val1120 r1113 (quote (()))))) (syntax-error e1116 (quote "invalid literals list in")))) tmp1118) (syntax-error tmp1117))) (syntax-dispatch tmp1117 (quote (any any each-any . each-any))))) e1116))))) (set! sc-expand (let ((m1128 (quote e)) (esew1129 (quote (eval)))) (lambda (x1130) (if (and (pair? x1130) (equal? (car x1130) noexpand37)) (cadr x1130) (chi-top102 x1130 (quote ()) (quote ((top))) m1128 esew1129))))) (set! sc-expand3 (let ((m1131 (quote e)) (esew1132 (quote (eval)))) (lambda (x1134 . rest1133) (if (and (pair? x1134) (equal? (car x1134) noexpand37)) (cadr x1134) (chi-top102 x1134 (quote ()) (quote ((top))) (if (null? rest1133) m1131 (car rest1133)) (if (or (null? rest1133) (null? (cdr rest1133))) esew1132 (cadr rest1133))))))) (set! identifier? (lambda (x1135) (nonsymbol-id?66 x1135))) (set! datum->syntax-object (lambda (id1136 datum1137) (begin (let ((x1138 id1136)) (if (not (nonsymbol-id?66 x1138)) (error-hook45 (quote datum->syntax-object) (quote "invalid argument") x1138))) (make-syntax-object52 datum1137 (syntax-object-wrap55 id1136))))) (set! syntax-object->datum (lambda (x1139) (strip114 x1139 (quote (()))))) (set! generate-temporaries (lambda (ls1140) (begin (let ((x1141 ls1140)) (if (not (list? x1141)) (error-hook45 (quote generate-temporaries) (quote "invalid argument") x1141))) (map (lambda (x1142) (wrap95 (gensym) (quote ((top))))) ls1140)))) (set! free-identifier=? (lambda (x1143 y1144) (begin (let ((x1145 x1143)) (if (not (nonsymbol-id?66 x1145)) (error-hook45 (quote free-identifier=?) (quote "invalid argument") x1145))) (let ((x1146 y1144)) (if (not (nonsymbol-id?66 x1146)) (error-hook45 (quote free-identifier=?) (quote "invalid argument") x1146))) (free-id=?90 x1143 y1144)))) (set! bound-identifier=? (lambda (x1147 y1148) (begin (let ((x1149 x1147)) (if (not (nonsymbol-id?66 x1149)) (error-hook45 (quote bound-identifier=?) (quote "invalid argument") x1149))) (let ((x1150 y1148)) (if (not (nonsymbol-id?66 x1150)) (error-hook45 (quote bound-identifier=?) (quote "invalid argument") x1150))) (bound-id=?91 x1147 y1148)))) (set! syntax-error (lambda (object1152 . messages1151) (begin (for-each (lambda (x1153) (let ((x1154 x1153)) (if (not (string? x1154)) (error-hook45 (quote syntax-error) (quote "invalid argument") x1154)))) messages1151) (let ((message1155 (if (null? messages1151) (quote "invalid syntax") (apply string-append messages1151)))) (error-hook45 (quote #f) message1155 (strip114 object1152 (quote (())))))))) (set! install-global-transformer (lambda (sym1156 v1157) (begin (let ((x1158 sym1156)) (if (not (symbol? x1158)) (error-hook45 (quote define-syntax) (quote "invalid argument") x1158))) (let ((x1159 v1157)) (if (not (procedure? x1159)) (error-hook45 (quote define-syntax) (quote "invalid argument") x1159))) (global-extend65 (quote macro) sym1156 v1157)))) (letrec ((match1164 (lambda (e1165 p1166 w1167 r1168) (cond ((not r1168) (quote #f)) ((eq? p1166 (quote any)) (cons (wrap95 e1165 w1167) r1168)) ((syntax-object?53 e1165) (match*1163 (let ((e1169 (syntax-object-expression54 e1165))) (if (annotation?42 e1169) (annotation-expression e1169) e1169)) p1166 (join-wraps86 w1167 (syntax-object-wrap55 e1165)) r1168)) (else (match*1163 (let ((e1170 e1165)) (if (annotation?42 e1170) (annotation-expression e1170) e1170)) p1166 w1167 r1168))))) (match*1163 (lambda (e1171 p1172 w1173 r1174) (cond ((null? p1172) (and (null? e1171) r1174)) ((pair? p1172) (and (pair? e1171) (match1164 (car e1171) (car p1172) w1173 (match1164 (cdr e1171) (cdr p1172) w1173 r1174)))) ((eq? p1172 (quote each-any)) (let ((l1175 (match-each-any1161 e1171 w1173))) (and l1175 (cons l1175 r1174)))) (else (let ((t1176 (vector-ref p1172 (quote 0)))) (if (memv t1176 (quote (each))) (if (null? e1171) (match-empty1162 (vector-ref p1172 (quote 1)) r1174) (let ((l1177 (match-each1160 e1171 (vector-ref p1172 (quote 1)) w1173))) (and l1177 (let collect1178 ((l1179 l1177)) (if (null? (car l1179)) r1174 (cons (map car l1179) (collect1178 (map cdr l1179)))))))) (if (memv t1176 (quote (free-id))) (and (id?67 e1171) (free-id=?90 (wrap95 e1171 w1173) (vector-ref p1172 (quote 1))) r1174) (if (memv t1176 (quote (atom))) (and (equal? (vector-ref p1172 (quote 1)) (strip114 e1171 w1173)) r1174) (if (memv t1176 (quote (vector))) (and (vector? e1171) (match1164 (vector->list e1171) (vector-ref p1172 (quote 1)) w1173 r1174))))))))))) (match-empty1162 (lambda (p1180 r1181) (cond ((null? p1180) r1181) ((eq? p1180 (quote any)) (cons (quote ()) r1181)) ((pair? p1180) (match-empty1162 (car p1180) (match-empty1162 (cdr p1180) r1181))) ((eq? p1180 (quote each-any)) (cons (quote ()) r1181)) (else (let ((t1182 (vector-ref p1180 (quote 0)))) (if (memv t1182 (quote (each))) (match-empty1162 (vector-ref p1180 (quote 1)) r1181) (if (memv t1182 (quote (free-id atom))) r1181 (if (memv t1182 (quote (vector))) (match-empty1162 (vector-ref p1180 (quote 1)) r1181))))))))) (match-each-any1161 (lambda (e1183 w1184) (cond ((annotation?42 e1183) (match-each-any1161 (annotation-expression e1183) w1184)) ((pair? e1183) (let ((l1185 (match-each-any1161 (cdr e1183) w1184))) (and l1185 (cons (wrap95 (car e1183) w1184) l1185)))) ((null? e1183) (quote ())) ((syntax-object?53 e1183) (match-each-any1161 (syntax-object-expression54 e1183) (join-wraps86 w1184 (syntax-object-wrap55 e1183)))) (else (quote #f))))) (match-each1160 (lambda (e1186 p1187 w1188) (cond ((annotation?42 e1186) (match-each1160 (annotation-expression e1186) p1187 w1188)) ((pair? e1186) (let ((first1189 (match1164 (car e1186) p1187 w1188 (quote ())))) (and first1189 (let ((rest1190 (match-each1160 (cdr e1186) p1187 w1188))) (and rest1190 (cons first1189 rest1190)))))) ((null? e1186) (quote ())) ((syntax-object?53 e1186) (match-each1160 (syntax-object-expression54 e1186) p1187 (join-wraps86 w1188 (syntax-object-wrap55 e1186)))) (else (quote #f)))))) (set! syntax-dispatch (lambda (e1191 p1192) (cond ((eq? p1192 (quote any)) (list e1191)) ((syntax-object?53 e1191) (match*1163 (let ((e1193 (syntax-object-expression54 e1191))) (if (annotation?42 e1193) (annotation-expression e1193) e1193)) p1192 (syntax-object-wrap55 e1191) (quote ()))) (else (match*1163 (let ((e1194 e1191)) (if (annotation?42 e1194) (annotation-expression e1194) e1194)) p1192 (quote (())) (quote ()))))))))) (install-global-transformer (quote with-syntax) (lambda (x1195) ((lambda (tmp1196) ((lambda (tmp1197) (if tmp1197 (apply (lambda (_1198 e11199 e21200) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11199 e21200))) tmp1197) ((lambda (tmp1202) (if tmp1202 (apply (lambda (_1203 out1204 in1205 e11206 e21207) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) in1205 (quote ()) (list out1204 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11206 e21207))))) tmp1202) ((lambda (tmp1209) (if tmp1209 (apply (lambda (_1210 out1211 in1212 e11213 e21214) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) in1212) (quote ()) (list out1211 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11213 e21214))))) tmp1209) (syntax-error tmp1196))) (syntax-dispatch tmp1196 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp1196 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp1196 (quote (any () any . each-any))))) x1195))) (install-global-transformer (quote syntax-rules) (lambda (x1218) ((lambda (tmp1219) ((lambda (tmp1220) (if tmp1220 (apply (lambda (_1221 k1222 keyword1223 pattern1224 template1225) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons k1222 (map (lambda (tmp1228 tmp1227) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) tmp1227) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) tmp1228))) template1225 pattern1224)))))) tmp1220) (syntax-error tmp1219))) (syntax-dispatch tmp1219 (quote (any each-any . #(each ((any . any) any))))))) x1218))) (install-global-transformer (quote let*) (lambda (x1229) ((lambda (tmp1230) ((lambda (tmp1231) (if (if tmp1231 (apply (lambda (let*1232 x1233 v1234 e11235 e21236) (andmap identifier? x1233)) tmp1231) (quote #f)) (apply (lambda (let*1238 x1239 v1240 e11241 e21242) (let f1243 ((bindings1244 (map list x1239 v1240))) (if (null? bindings1244) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote ()) (cons e11241 e21242))) ((lambda (tmp1248) ((lambda (tmp1249) (if tmp1249 (apply (lambda (body1250 binding1251) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list binding1251) body1250)) tmp1249) (syntax-error tmp1248))) (syntax-dispatch tmp1248 (quote (any any))))) (list (f1243 (cdr bindings1244)) (car bindings1244)))))) tmp1231) (syntax-error tmp1230))) (syntax-dispatch tmp1230 (quote (any #(each (any any)) any . each-any))))) x1229))) diff --git a/ice-9/psyntax.ss b/ice-9/psyntax.ss index 166095e11..ab55a2f27 100644 --- a/ice-9/psyntax.ss +++ b/ice-9/psyntax.ss @@ -424,7 +424,7 @@ (define-syntax build-lexical-var (syntax-rules () - ((_ src id) (gentemp (symbol->string id) generated-symbols)))) + ((_ src id) (gensym (symbol->string id))))) (define-syntax self-evaluating? (syntax-rules () From e4e1ea73f3dbe54361a5d4dc2773f43aa01777e4 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 19 May 2001 01:32:02 +0000 Subject: [PATCH 1134/2047] *** empty log message *** --- ice-9/ChangeLog | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 1ca0d2a0c..0a1a59743 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,25 @@ +2001-05-19 Marius Vollmer + + * psyntax.ss (build-lexical-var): Use gensym instead of gentemp. + * match.scm: Likewise. + * expect.scm: Likewise. + * psyntax.pp: Regenerated. + + * rdelim.scm: Call `%init-rdelim-builtins'. + + * rw.scm: Call `%init-rw-builtins'. + + * boot-9.scm (process-define-module): Do not call + set-current-module. + (define-module): Do it here, in the expansion. + (top-repl): Do not define '(guile-user)' module and conditionally + load `(ice-9 threads)' and/or `(ice-9 regex)' here. Do it on + top-level as the last thing in boot-9.scm instead. + (%load-path): Use `list' instead of `cons' to create a single + element list when adding "." to it. + (process-define-module, process-use-modules, module-export!): Add + dummy definitions prior to booting the mdule system. + 2001-05-18 Thien-Thi Nguyen * boot-9.scm: (resolve-interface, use-srfis): Small From b84735089f363854956adc755df0694c4f100abb Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 19 May 2001 02:01:12 +0000 Subject: [PATCH 1135/2047] Lazy-catch handlers are no longer allowed to return. Fixed comments throughout. (scm_ithrow): Signal an error when a lazy-catch handler returns. Moved actual jump to jmpbuf into if-branch where the jmpbuf is recognized as such. --- libguile/throw.c | 26 +++++++++----------------- 1 file changed, 9 insertions(+), 17 deletions(-) diff --git a/libguile/throw.c b/libguile/throw.c index b1f945602..e16945a64 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -265,7 +265,7 @@ make_lazy_catch (struct lazy_catch *c) /* Exactly like scm_internal_catch, except: - It does not unwind the stack (this is the major difference). - - If handler returns, its value is returned from the throw. */ + - The handler is not allowed to return. */ SCM scm_internal_lazy_catch (SCM tag, scm_catch_body_t body, void *body_data, scm_catch_handler_t handler, void *handler_data) { @@ -558,8 +558,9 @@ SCM_DEFINE (scm_catch, "catch", 3, 0, 0, SCM_DEFINE (scm_lazy_catch, "lazy-catch", 3, 0, 0, (SCM key, SCM thunk, SCM handler), "This behaves exactly like @code{catch}, except that it does\n" - "not unwind the stack (this is the major difference), and if\n" - "handler returns, its value is returned from the throw.") + "not unwind the stack. The @var{handler} procedure is not " + "allowed to return, it must throw to another catch, or " + "otherwise exit non-locally.") #define FUNC_NAME s_scm_lazy_catch { struct scm_body_thunk_data c; @@ -596,7 +597,6 @@ SCM_DEFINE (scm_throw, "throw", 1, 0, 1, #define FUNC_NAME s_scm_throw { SCM_VALIDATE_SYMBOL (1,key); - /* May return if handled by lazy catch. */ return scm_ithrow (key, args, 1); } #undef FUNC_NAME @@ -657,7 +657,6 @@ scm_ithrow (SCM key, SCM args, int noreturn) if (SCM_LAZY_CATCH_P (jmpbuf)) { struct lazy_catch *c = (struct lazy_catch *) SCM_CELL_WORD_1 (jmpbuf); - SCM oldwinds = scm_dynwinds; SCM handle, answer; scm_dowinds (wind_goal, (scm_ilength (scm_dynwinds) - scm_ilength (wind_goal))); @@ -666,13 +665,7 @@ scm_ithrow (SCM key, SCM args, int noreturn) scm_dynwinds = SCM_CDR (scm_dynwinds); SCM_REALLOW_INTS; answer = (c->handler) (c->handler_data, key, args); - SCM_REDEFER_INTS; - SCM_SETCDR (handle, scm_dynwinds); - scm_dynwinds = handle; - SCM_REALLOW_INTS; - scm_dowinds (oldwinds, (scm_ilength (scm_dynwinds) - - scm_ilength (oldwinds))); - return answer; + scm_misc_error ("throw", "lazy-catch handler did return.", SCM_EOL); } /* Otherwise, it's a normal catch. */ @@ -684,16 +677,15 @@ scm_ithrow (SCM key, SCM args, int noreturn) jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf); jbr->throw_tag = key; jbr->retval = args; +#ifdef DEBUG_EXTENSIONS + scm_last_debug_frame = SCM_JBDFRAME (jmpbuf); +#endif + longjmp (*JBJMPBUF (jmpbuf), 1); } /* Otherwise, it's some random piece of junk. */ else abort (); - -#ifdef DEBUG_EXTENSIONS - scm_last_debug_frame = SCM_JBDFRAME (jmpbuf); -#endif - longjmp (*JBJMPBUF (jmpbuf), 1); } From e2b6ddc66839c339d3f53890116aae8d955834c9 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 19 May 2001 02:01:33 +0000 Subject: [PATCH 1136/2047] *** empty log message *** --- libguile/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index be323df59..b114f3d54 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,11 @@ 2001-05-19 Marius Vollmer + * throw.c: Lazy-catch handlers are no longer allowed to return. + Fixed comments throughout. + (scm_ithrow): Signal an error when a lazy-catch handler returns. + Moved actual jump to jmpbuf into if-branch where the jmpbuf is + recognized as such. + * version.c (s_scm_micro_version): Fix typo in FUNC_NAME, it refered to s_scm_minor_version previously. From 7215d65eb2b8492b0ce8fb46b61fbb2cda62fe43 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 19 May 2001 11:13:47 +0000 Subject: [PATCH 1137/2047] * Doc updates for lazy-catch and IP address conversion --- doc/ChangeLog | 8 + doc/posix.texi | 20 +- doc/scheme-control.texi | 843 ---------------------------------------- 3 files changed, 22 insertions(+), 849 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 51b687bd8..d11246258 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,11 @@ +2001-05-19 Neil Jerram + + * posix.texi (Networking): Split existing material into new nodes + `Network Address Conversion' and `Network Databases'. + + * scheme-control.texi (Lazy Catch): Update doc for new constraint + that lazy-catch handlers are not allowed to return. + 2001-05-16 Neil Jerram * data-rep.texi, srfi-modules.texi (SRFI-14 Iterating Over diff --git a/doc/posix.texi b/doc/posix.texi index 12508cffd..e16d0307a 100644 --- a/doc/posix.texi +++ b/doc/posix.texi @@ -1542,18 +1542,18 @@ close a pipe, but doesn't return the status. @section Networking @menu -* Network Databases and Address Conversion:: +* Network Address Conversion:: +* Network Databases:: * Network Sockets and Communication:: @end menu -@node Network Databases and Address Conversion -@subsection Network Databases and Address Conversion +@node Network Address Conversion +@subsection Network Address Conversion This section describes procedures which convert internet addresses -and query various network databases. Care should be taken when using -the database routines since they are not reentrant. +between numeric and string formats. -@subsubsection Address Conversion +@subsubsection IPv4 Address Conversion @deffn primitive inet-aton address Convert an IPv4 Internet address from printable string @@ -1630,6 +1630,14 @@ the result is an integer with normal host byte ordering. @end lisp @end deffn + +@node Network Databases +@subsection Network Databases + +This section describes procedures which query various network databases. +Care should be taken when using the database routines since they are not +reentrant. + @subsubsection The Host Database A @dfn{host object} is a structure that represents what is known about a diff --git a/doc/scheme-control.texi b/doc/scheme-control.texi index b1e67d2c5..e69de29bb 100644 --- a/doc/scheme-control.texi +++ b/doc/scheme-control.texi @@ -1,843 +0,0 @@ -@page -@node Control Mechanisms -@chapter Controlling the Flow of Program Execution - -@menu -* begin:: Evaluating a sequence of expressions. -* if cond case:: Simple conditional evaluation. -* and or:: Conditional evaluation of a sequence. -* while do:: Iteration mechanisms. -* Continuations:: Continuations. -* Multiple Values:: Returning and accepting multiple values. -* Exceptions:: Throwing and catching exceptions. -* Error Reporting:: Procedures for signaling errors. -* Dynamic Wind:: Guarding against non-local entrance/exit. -@end menu - - -@node begin -@section Evaluating a Sequence of Expressions - -@c FIXME::martin: Review me! - -@c FIXME::martin: Maybe add examples? - -@cindex begin -@cindex sequencing -@cindex expression sequencing - -@code{begin} is used for grouping several expression together so that -they syntactically are treated as if they were one expression. This is -particularly important when syntactic expressions are used which only -allow one expression, but the programmer wants to use more than one -expression in that place. As an example, consider the conditional -expression below: - -@lisp -(if (> x 0) - (begin (display "greater") (newline))) -@end lisp - -If the two calls to @code{display} and @code{newline} were not embedded -in a @code{begin}-statement, the call to @code{newline} would get -misinterpreted as the else-branch of the @code{if}-expression. - -@deffn syntax begin expr1 expr2 @dots{} -The expression(s) are evaluated in left-to-right order and the value -of the last expression is returned as the value of the -@code{begin}-expression. This expression type is used when the -expressions before the last one are evaluated for their side effects. -@end deffn - -@node if cond case -@section Simple Conditional Evaluation - -@c FIXME::martin: Review me! - -@c FIXME::martin: Maybe add examples? - -@cindex conditional evaluation -@cindex if -@cindex case -@cindex cond - -Guile provides three syntactic constructs for conditional evaluation. -@code{if} is the normal if-then-else expression (with an optional else -branch), @code{cond} is a conditional expression with multiple branches -and @code{case} branches if an expression has one of a set of constant -values. - -@deffn syntax if test consequent [alternate] -All arguments may be arbitrary expressions. First, @var{test} is -evaluated. If it returns a true value, the expression @var{consequent} -is evaluated and @var{alternate} is ignoret. If @var{test} evaluates to -@code{#f}, @var{alternate} is evaluated instead. The value of the -evaluated branch (@var{consequent} or @var{alternate}) is returned as -the value of the @code{if} expression. - -When @var{alternate} is omitted and the @var{test} evaluates to -@code{#f}, the value of the expression is not specified. -@end deffn - -@deffn syntax cond clause1 clause2 @dots{} -Each @code{cond}-clause must look like this: - -@lisp -(@var{test} @var{expression} @dots{}) -@end lisp - -where @var{test} and @var{expression} are arbitrary expression, or like -this - -@lisp -(@var{test} => @var{expression} -@end lisp - -where @var{expression} must evaluate to a procedure. - -The @var{test}s of the clauses are evaluated in order and as soon as one -of them evaluates to a true values, the corresponding @var{expression}s -are evaluated in order and the last value is returned as the value of -the @code{cond}-expression. For the @code{=>} clause type, -@var{expression} is evaluated and the resulting procedure is applied to -the value of @var{test}. The result of this procedure application is -then the result of the @code{cond}-expression. - -The @var{test} of the last @var{clause} may be the keyword @code{else}. -Then, if none of the preceding @var{test}s is true, the @var{expression}s following the @code{else} are evaluated to produce the result of the @code{cond}-expression. -@end deffn - -@deffn syntax case key clause1 clause2 @dots{} -@var{key} may be any expression, the @var{clause}s must have the form - -@lisp -((@var{datum1} @dots{}) @var{expr1} @var{expr2} @dots{}) -@end lisp - -and the last @var{clause} may have the form - -@lisp -(else @var{expr1} @var{expr2} @dots{}) -@end lisp - -All @var{datum}s must be distinct. First, @var{key} is evaluated. The -the result of this evaluation is compared against all @var{datum}s using -@code{eqv?}. When this comparison succeeds, the epression(s) following -the @var{datum} are evaluated from left to right, returning the value of -the last expression as the result of the @code{case} expression. - -If the @var{key} matches no @var{datum} and there is an -@code{else}-clause, the expressions following the @code{else} are -evaluated. If there is no such clause, the result of the expression is -unspecified. -@end deffn - - -@node and or -@section Conditional Evaluation of a Sequence of Expressions - -@c FIXME::martin: Review me! - -@c FIXME::martin: Maybe add examples? - -@code{and} and @code{or} evaluate all their arguments, similar to -@code{begin}, but evaluation stops as soon as one of the expressions -evaluates to false or true, respectively. - -@deffn syntax and expr @dots{} -Evaluate the @var{expr}s from left to right and stop evaluation as soon -as one expression evaluates to @code{#f}; the remaining expressions are -not evaluated. The value of the last evaluated expression is returned. -If no expression evaluates to @code{#f}, the value of the last -expression is returned. - -If used without expressions, @code{#t} is returned. -@end deffn - -@deffn syntax or expr @dots{} -Evaluate the @var{expr}s from left to right and stop evaluation as soon -as one expression evaluates to a true value (that is, a value different -from @code{#f}); the remaining expressions are not evaluated. The value -of the last evaluated expression is returned. If all expressions -evaluate to @code{#f}, @code{#f} is returned. - -If used without expressions, @code{#f} is returned. -@end deffn - - -@node while do -@section Iteration mechanisms - -@c FIXME::martin: Review me! - -@c FIXME::martin: Maybe add examples? - -@cindex iteration -@cindex looping -@cindex named let - -Scheme has only few iteration mechanisms, mainly because iteration in -Scheme programs is normally expressed using recursion. Nevertheless, -R5RS defines a construct for programming loops, calling @code{do}. In -addition, Guile has an explicit looping syntax called @code{while}. - -@deffn syntax do ((variable1 init1 step1) @dots{}) (test expr @dots{}) command @dots{} -The @var{init} expressions are evaluated and the @var{variables} are -bound to their values. Then looping starts with testing the @var{test} -expression. If @var{test} evaluates to a true value, the @var{expr} -following the @var{test} are evaluated and the value of the last -@var{expr} is returned as the value of the @code{do} expression. If -@var{test} evaluates to false, the @var{command}s are evaluated in -order, the @var{step}s are evaluated and stored into the @var{variables} -and the next iteration starts. - -Any of the @var{step} expressions may be omitted, so that the -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. -@end deffn - -@cindex named let -Another very common way of expressing iteration in Scheme programs is -the use of the so-called @dfn{named let}. - -Named let is a variant of @code{let} which creates a procedure and calls -it in one step. Because of the newly created procedure, named let is -more powerful than @code{do}--it can be used for iteration, but also -for arbitrary recursion. - -@deffn syntax let variable bindings body -For the definition of @var{bindings} see the documentation about -@code{let} (@pxref{Local Bindings}). - -Named @code{let} works as follows: - -@itemize @bullet -@item -A new procedure which accepts as many arguments as are in @var{bindings} -is created and bound locally (using @code{let}) to @var{variable}. The -new procedure's formal argument names are the name of the -@var{variables}. - -@item -The @var{body} expressions are inserted into the newly created procedure. - -@item -The procedure is called with the @var{init} expressions as the formal -arguments. -@end itemize - -The next example implements a loop which iterates (by recursion) 1000 -times. - -@lisp -(let lp ((x 1000)) - (if (positive? x) - (lp (- x 1)) - x)) -@result{} -0 -@end lisp -@end deffn - - -@node Continuations -@section Continuations - -@cindex call/cc -@cindex call-with-current-continuation -The ability to explicitly capture continuations using -@code{call-with-current-continuation} (also often called @code{call/cc} -for short), and to invoke such continuations later any number of times, -and from any other point in a program, provides maybe the most powerful -control structure known. All other control structures, such as loops -and coroutines, can be emulated using continuations. - -@c NJFIXME - need a little something here about what continuations are -@c and what they do for you. - -The implementation of continuations in Guile is not as efficient as one -might hope, because it is constrained by the fact that Guile is designed -to cooperate with programs written in other languages, such as C, which -do not know about continuations. So continuations should be used when -there is no other simple way of achieving the desired behaviour, or -where the advantages of the elegant continuation mechanism outweigh the -need for optimum performance. If you find yourself using @code{call/cc} -for escape procedures and your program is running too slow, you might -want to use exceptions (@pxref{Exceptions}) instead. - -@rnindex call-with-current-continuation -@deffn primitive call-with-current-continuation proc -Capture the current continuation and call @var{proc} with the captured -continuation as the single argument. This continuation can then be -called with arbitrarily many arguments. Such a call will work like a -goto to the invocation location of -@code{call-with-current-continuation}, passing the arguments in a way -that they are returned by the call to -@code{call-with-current-continuation}. Since it is legal to store the -captured continuation in a variable or to pass it to other procedures, -it is possible that a procedure returns more than once, even if it is -called only one time. This can be confusing at times. -@end deffn - -@c FIXME::martin: Better example needed. -@lisp -(define kont #f) -(call-with-current-continuation - (lambda (k) - (set! kont k) - 1)) -@result{} -1 - -(kont 2) -@result{} -2 -@end lisp - - -@node Multiple Values -@section Returning and Accepting Multiple Values - -@c FIXME::martin: Review me! -@cindex multiple values -@cindex receive - -Scheme allows a procedure to return more than one value to its caller. -This is quite different to other languages which only allow -single-value returns. Returning multiple values is different from -returning a list (or pair or vector) of values to the caller, because -conceptionally not @emph{one} compound object is returned, but several -distinct values. - -The primitive procedures for handling multiple values are @code{values} -and @code{call-with-values}. @code{values} is used for returning -multiple values from a procedure. This is done by placing a call to -@code{values} with zero or more arguments in tail position in a -procedure body. @code{call-with-values} combines a procedure returning -multiple values with a procedure which accepts these values as -parameters. - -@rnindex values -@deffn primitive values expr @dots{} -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. -@end deffn - -@rnindex call-with-values -@deffn primitive call-with-values producer consumer -Calls its @var{producer} argument with no values and a -continuation that, when passed some values, calls the -@var{consumer} procedure with those values as arguments. The -continuation for the call to @var{consumer} is the continuation -of the call to @code{call-with-values}. - -@example -(call-with-values (lambda () (values 4 5)) - (lambda (a b) b)) - ==> 5 - -@end example -@example -(call-with-values * -) ==> -1 -@end example -@end deffn - -In addition to the fundamental procedures described above, Guile has a -module which exports a syntax called @code{receive}, which is much more -convenient. If you want to use it in your programs, you have to load -the module @code{(ice-9 receive)} with the statement - -@lisp -(use-modules (ice-9 receive)) -@end lisp - -@deffn {library syntax} receive formals expr body @dots{} -Evaluate the expression @var{expr}, and bind the result values (zero or -more) to the formal arguments in the formal argument list @var{formals}. -@var{formals} must have the same syntax like the formal argument list -used in @code{lambda} (@pxref{Lambda}). After binding the variables, -the expressions in @var{body} @dots{} are evaluated in order. -@end deffn - - -@node Exceptions -@section Exceptions -@cindex error handling -@cindex exception handling - -A common requirement in applications is to want to jump -@dfn{non-locally} from the depths of a computation back to, say, the -application's main processing loop. Usually, the place that is the -target of the jump is somewhere in the calling stack of procedures that -called the procedure that wants to jump back. For example, typical -logic for a key press driven application might look something like this: - -@example -main-loop: - read the next key press and call dispatch-key - -dispatch-key: - lookup the key in a keymap and call an appropriate procedure, - say find-file - -find-file: - interactively read the required file name, then call - find-specified-file - -find-specified-file: - check whether file exists; if not, jump back to main-loop - @dots{} -@end example - -The jump back to @code{main-loop} could be achieved by returning through -the stack one procedure at a time, using the return value of each -procedure to indicate the error condition, but Guile (like most modern -programming languages) provides an additional mechanism called -@dfn{exception handling} that can be used to implement such jumps much -more conveniently. - -@menu -* Exception Terminology:: Different ways to say the same thing. -* Catch:: Setting up to catch exceptions. -* Throw:: Throwing an exception. -* Lazy Catch:: Catch without unwinding the stack. -* Exception Implementation:: How Guile implements exceptions. -@end menu - - -@node Exception Terminology -@subsection Exception Terminology - -There are several variations on the terminology for dealing with -non-local jumps. It is useful to be aware of them, and to realize -that they all refer to the same basic mechanism. - -@itemize @bullet -@item -Actually making a non-local jump may be called @dfn{raising an -exception}, @dfn{raising a signal}, @dfn{throwing an exception} or -@dfn{doing a long jump}. When the jump indicates an error condition, -people may talk about @dfn{signalling}, @dfn{raising} or @dfn{throwing} -@dfn{an error}. - -@item -Handling the jump at its target may be referred to as @dfn{catching} or -@dfn{handling} the @dfn{exception}, @dfn{signal} or, where an error -condition is involved, @dfn{error}. -@end itemize - -Where @dfn{signal} and @dfn{signalling} are used, special care is needed -to avoid the risk of confusion with POSIX signals. (Especially -considering that Guile handles POSIX signals by throwing a corresponding -kind of exception: REFFIXME.) - -This manual prefers to speak of throwing and catching exceptions, since -this terminology matches the corresponding Guile primitives. - - -@node Catch -@subsection Catching Exceptions - -@code{catch} is used to set up a target for a possible non-local jump. -The arguments of a @code{catch} expression are a @dfn{key}, which -restricts the set of exceptions to which this @code{catch} applies, a -thunk that specifies the @dfn{normal case} code --- i.e. what should -happen if no exceptions are thrown --- and a @dfn{handler} procedure -that says what to do if an exception is thrown. Note that if the -@dfn{normal case} thunk executes @dfn{normally}, which means without -throwing any exceptions, the handler procedure is not executed at all. - -When an exception is thrown using the @code{throw} primitive, the first -argument of the @code{throw} is a symbol that indicates the type of the -exception. For example, Guile throws an exception using the symbol -@code{numerical-overflow} to indicate numerical overflow errors such as -division by zero: - -@lisp -(/ 1 0) -@result{} -ABORT: (numerical-overflow) -@end lisp - -The @var{key} argument in a @code{catch} expression corresponds to this -symbol. @var{key} may be a specific symbol, such as -@code{numerical-overflow}, in which case the @code{catch} applies -specifically to exceptions of that type; or it may be @code{#t}, which -means that the @code{catch} applies to all exceptions, irrespective of -their type. - -The second argument of a @code{catch} expression should be a thunk -(i.e. a procedure that accepts no arguments) that specifies the normal -case code. The @code{catch} is active for the execution of this thunk, -including any code called directly or indirectly by the thunk's body. -Evaluation of the @code{catch} expression activates the catch and then -calls this thunk. - -The third argument of a @code{catch} expression is a handler procedure. -If an exception is thrown, this procedure is called with exactly the -arguments specified by the @code{throw}. Therefore, the handler -procedure must be designed to accept a number of arguments that -corresponds to the number of arguments in all @code{throw} expressions -that can be caught by this @code{catch}. - -@deffn primitive catch key thunk handler -Invoke @var{thunk} in the dynamic context of @var{handler} for -exceptions matching @var{key}. If thunk throws to the symbol -@var{key}, then @var{handler} is invoked this way: -@lisp -(handler key args ...) -@end lisp - -@var{key} is a symbol or @code{#t}. - -@var{thunk} takes no arguments. If @var{thunk} returns -normally, that is the return value of @code{catch}. - -Handler is invoked outside the scope of its own @code{catch}. -If @var{handler} again throws to the same key, a new handler -from further up the call chain is invoked. - -If the key is @code{#t}, then a throw to @emph{any} symbol will -match this call to @code{catch}. -@end deffn - -If the handler procedure needs to match a variety of @code{throw} -expressions with varying numbers of arguments, you should write it like -this: - -@lisp -(lambda (key . args) - @dots{}) -@end lisp - -@noindent -The @var{key} argument is guaranteed always to be present, because a -@code{throw} without a @var{key} is not valid. The number and -interpretation of the @var{args} varies from one type of exception to -another, but should be specified by the documentation for each exception -type. - -Note that, once the handler procedure is invoked, the catch that led to -the handler procedure being called is no longer active. Therefore, if -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. - - -@node Throw -@subsection Throwing Exceptions - -The @code{throw} primitive is used to throw an exception. One argument, -the @var{key}, is mandatory, and must be a symbol; it indicates the type -of exception that is being thrown. Following the @var{key}, -@code{throw} accepts any number of additional arguments, whose meaning -depends on the exception type. The documentation for each possible type -of exception should specify the additional arguments that are expected -for that kind of exception. - -@deffn primitive throw key . args -Invoke the catch form matching @var{key}, passing @var{args} to the -@var{handler}. - -@var{key} is a symbol. It will match catches of the same symbol or of -@code{#t}. - -If there is no handler at all, Guile prints an error and then exits. -@end deffn - -When an exception is thrown, it will be caught by the innermost -@code{catch} expression that applies to the type of the thrown -exception; in other words, the innermost @code{catch} whose @var{key} is -@code{#t} or is the same symbol as that used in the @code{throw} -expression. Once Guile has identified the appropriate @code{catch}, it -handles the exception by applying that @code{catch} expression's handler -procedure to the arguments of the @code{throw}. - -If there is no appropriate @code{catch} for a thrown exception, Guile -prints an error to the current error port indicating an uncaught -exception, and then exits. In practice, it is quite difficult to -observe this behaviour, because Guile when used interactively installs a -top level @code{catch} handler that will catch all exceptions and print -an appropriate error message @emph{without} exiting. For example, this -is what happens if you try to throw an unhandled exception in the -standard Guile REPL; note that Guile's command loop continues after the -error message: - -@lisp -guile> (throw 'badex) -:3:1: In procedure gsubr-apply @dots{} -:3:1: unhandled-exception: badex -ABORT: (misc-error) -guile> -@end lisp - -The default uncaught exception behaviour can be observed by evaluating a -@code{throw} expression from the shell command line: - -@example -$ guile -c "(begin (throw 'badex) (display \"here\\n\"))" -guile: uncaught throw to badex: () -$ -@end example - -@noindent -That Guile exits immediately following the uncaught exception -is shown by the absence of any output from the @code{display} -expression, because Guile never gets to the point of evaluating that -expression. - - -@node Lazy Catch -@subsection Catch Without Unwinding - -A @dfn{lazy catch} is used in the same way as a normal @code{catch}, -with @var{key}, @var{thunk} and @var{handler} arguments specifying the -exception type, normal case code and handler procedure, but differs in -two important respects. - -@itemize @bullet -@item -The handler procedure is executed without unwinding the call stack from -the context of the @code{throw} expression that caused the handler to be -invoked. - -@item -If the handler returns normally --- i.e. does not @emph{itself} throw an -exception --- then the @code{throw} expression returns normally to its -caller with the handler's value. -@end itemize - -@deffn primitive lazy-catch key thunk handler -This behaves exactly like @code{catch}, except that it does -not unwind the stack (this is the major difference), and if -handler returns, its value is returned from the throw. -@end deffn - -The net result is that throwing an exception that is caught by a -@code{lazy-catch} is @emph{almost} equivalent to calling the -@code{lazy-catch}'s handler inline instead of each @code{throw}, and -then omitting the surrounding @code{lazy-catch}. In other words, - -@lisp -(lazy-catch 'key - (lambda () @dots{} (throw 'key args @dots{}) @dots{}) - handler) -@end lisp - -@noindent -is @emph{almost} equivalent to - -@lisp -((lambda () @dots{} (handler 'key args @dots{}) @dots{})) -@end lisp - -@noindent -But why only @emph{almost}? The difference is that with -@code{lazy-catch}, the dynamic context is unwound back to just outside -the @code{lazy-catch} expression before invoking the handler. (For an -introduction to what is meant by dynamic context, @xref{Dynamic Wind}.) - -Then, if the handler @emph{itself} throws an exception, that exception -must be caught by some kind of @code{catch} (including perhaps another -@code{lazy-catch}) higher up the call stack. On the other hand, if the -handler returns normally, the dynamic context is wound back to that of -the @code{throw} expression before passing the handler's return value to -the continuation of the @code{throw}. - -In most cases where @code{lazy-catch} is used, the handler does indeed -throw another exception, which is caught by a higher-level @code{catch}. -But this pattern is not mandatory, and it can be useful for the handler -to return normally. In the following example, the @code{lazy-catch} -handler is called twice and the results of the two calls added together. - -@lisp -(lazy-catch 'foo - (lambda () - (+ (throw 'foo 1) - (throw 'foo 2))) - (lambda args - (cadr args))) -@result{} -3 -@end lisp - -To see the point about dynamic context, consider the case where the -normal case thunk uses @code{with-fluids} (REFFIXME) to temporarily -change the value of a fluid: - -@lisp -(define f (make-fluid)) -(fluid-set! f "top level value") - -(define (handler . args) - (cons (fluid-ref f) args)) - -(lazy-catch 'foo - (lambda () - (with-fluids ((f "local value")) - (throw 'foo))) - handler) -@result{} -("top level value" foo) - -((lambda () - (with-fluids ((f "local value")) - (handler 'foo)))) -@result{} -("local value" foo) -@end lisp - -@noindent -In the @code{lazy-catch} version, the unwinding of dynamic context -restores @code{f} to its value outside the @code{with-fluids} block -before the handler is invoked, so the handler's @code{(fluid-ref f)} -returns the external value. - -@code{lazy-catch} is useful because it permits the implementation of -debuggers and other reflective programming tools that need to access the -state of the call stack at the exact point where an exception or an -error is thrown. For an example of this, see REFFIXME:stack-catch. - - -@node Exception Implementation -@subsection How Guile Implements Exceptions - -It is traditional in Scheme to implement exception systems using -@code{call-with-current-continuation}. Continuations -(@pxref{Continuations}) are such a powerful concept that any other -control mechanism --- including @code{catch} and @code{throw} --- can be -implemented in terms of them. - -Guile does not implement @code{catch} and @code{throw} like this, -though. Why not? Because Guile is specifically designed to be easy to -integrate with applications written in C. In a mixed Scheme/C -environment, the concept of @dfn{continuation} must logically include -``what happens next'' in the C parts of the application as well as the -Scheme parts, and it turns out that the only reasonable way of -implementing continuations like this is to save and restore the complete -C stack. - -So Guile's implementation of @code{call-with-current-continuation} is a -stack copying one. This allows it to interact well with ordinary C -code, but means that creating and calling a continuation is slowed down -by the time that it takes to copy the C stack. - -The more targeted mechanism provided by @code{catch} and @code{throw} -does not need to save and restore the C stack because the @code{throw} -always jumps to a location higher up the stack of the code that executes -the @code{throw}. Therefore Guile implements the @code{catch} and -@code{throw} primitives independently of -@code{call-with-current-continuation}, in a way that takes advantage of -this @emph{upwards only} nature of exceptions. - - -@node Error Reporting -@section Procedures for Signaling Errors - -Guile provides a set of convenience procedures for signaling error -conditions that are implemented on top of the exception primitives just -described. - -@deffn procedure error msg args @dots{} -Raise an error with key @code{misc-error} and a message constructed by -displaying @var{msg} and writing @var{args}. -@end deffn - -@deffn primitive scm-error key subr message args data -Raise an error with key @var{key}. @var{subr} can be a string -naming the procedure associated with the error, or @code{#f}. -@var{message} is the error message string, possibly containing -@code{~S} and @code{~A} escapes. When an error is reported, -these are replaced by formatting the corresponding members of -@var{args}: @code{~A} (was @code{%s} in older versions of -Guile) formats using @code{display} and @code{~S} (was -@code{%S}) formats using @code{write}. @var{data} is a list or -@code{#f} depending on @var{key}: if @var{key} is -@code{system-error} then it should be a list containing the -Unix @code{errno} value; If @var{key} is @code{signal} then it -should be a list containing the Unix signal number; otherwise -it will usually be @code{#f}. -@end deffn - -@deffn primitive strerror err -Return the Unix error message corresponding to @var{err}, which -must be an integer value. -@end deffn - -@c begin (scm-doc-string "boot-9.scm" "false-if-exception") -@deffn syntax false-if-exception expr -Returns the result of evaluating its argument; however -if an exception occurs then @code{#f} is returned instead. -@end deffn -@c end - - -@node Dynamic Wind -@section Dynamic Wind - -[FIXME: this is pasted in from Tom Lord's original guile.texi and should -be reviewed] - -@rnindex dynamic-wind -@deffn primitive dynamic-wind in_guard thunk out_guard -All three arguments must be 0-argument procedures. -@var{in_guard} is called, then @var{thunk}, then -@var{out_guard}. - -If, any time during the execution of @var{thunk}, the -continuation of the @code{dynamic_wind} expression is escaped -non-locally, @var{out_guard} is called. If the continuation of -the dynamic-wind is re-entered, @var{in_guard} is called. Thus -@var{in_guard} and @var{out_guard} may be called any number of -times. -@lisp -(define x 'normal-binding) -@result{} x -(define a-cont (call-with-current-continuation - (lambda (escape) - (let ((old-x x)) - (dynamic-wind - ;; in-guard: - ;; - (lambda () (set! x 'special-binding)) - - ;; thunk - ;; - (lambda () (display x) (newline) - (call-with-current-continuation escape) - (display x) (newline) - x) - - ;; out-guard: - ;; - (lambda () (set! x old-x))))))) - -;; Prints: -special-binding -;; Evaluates to: -@result{} a-cont -x -@result{} normal-binding -(a-cont #f) -;; Prints: -special-binding -;; Evaluates to: -@result{} a-cont ;; the value of the (define a-cont...) -x -@result{} normal-binding -a-cont -@result{} special-binding -@end lisp -@end deffn -@c Local Variables: -@c TeX-master: "guile.texi" -@c End: From 189285962e82806e5b962d97acd847a07ac4e790 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 19 May 2001 11:18:02 +0000 Subject: [PATCH 1138/2047] * Slight clarification of lazy-catch docstring. --- libguile/ChangeLog | 4 ++++ libguile/throw.c | 6 +++--- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b114f3d54..94bb85edb 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2001-05-19 Neil Jerram + + * throw.c (scm_lazy_catch): Slight docstring clarification. + 2001-05-19 Marius Vollmer * throw.c: Lazy-catch handlers are no longer allowed to return. diff --git a/libguile/throw.c b/libguile/throw.c index e16945a64..677b6bdc0 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -558,9 +558,9 @@ SCM_DEFINE (scm_catch, "catch", 3, 0, 0, SCM_DEFINE (scm_lazy_catch, "lazy-catch", 3, 0, 0, (SCM key, SCM thunk, SCM handler), "This behaves exactly like @code{catch}, except that it does\n" - "not unwind the stack. The @var{handler} procedure is not " - "allowed to return, it must throw to another catch, or " - "otherwise exit non-locally.") + "not unwind the stack before invoking @var{handler}.\n" + "The @var{handler} procedure is not allowed to return:\n" + "it must throw to another catch, or otherwise exit non-locally.") #define FUNC_NAME s_scm_lazy_catch { struct scm_body_thunk_data c; From 51f7ef47f9128bae406bb16fd808b7831113ace1 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 19 May 2001 22:58:29 +0000 Subject: [PATCH 1139/2047] Fix missing paren. --- oop/goops.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/oop/goops.scm b/oop/goops.scm index 162cd2811..85ecf028c 100644 --- a/oop/goops.scm +++ b/oop/goops.scm @@ -35,7 +35,7 @@ ;; Then load the rest of GOOPS (use-modules (oop goops util) (oop goops dispatch) - (oop goops compile) + (oop goops compile)) (export ; Define the exported symbols of this file goops-version is-a? From 5d98055804eb42fa276b287a0311694760099537 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 20 May 2001 00:33:12 +0000 Subject: [PATCH 1140/2047] (scm_c_init_srfi_14): Added "int" to declaration of `initialized'. --- srfi/srfi-14.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index 24388fc5c..ceb10f2e0 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -1350,7 +1350,7 @@ SCM_DEFINE (scm_char_set_diff_plus_intersection_x, "char-set-diff+intersection!" void scm_c_init_srfi_14 (void) { - static initialized = 0; + static int initialized = 0; if (!initialized) { From 0a53fd6e357ef214f18d76a83d9f146ec2f785e6 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 20 May 2001 00:33:26 +0000 Subject: [PATCH 1141/2047] (scm_init_rw): Added prototype. --- libguile/rw.h | 1 + 1 file changed, 1 insertion(+) diff --git a/libguile/rw.h b/libguile/rw.h index 0e160cc79..c0bb4868e 100644 --- a/libguile/rw.h +++ b/libguile/rw.h @@ -48,6 +48,7 @@ extern SCM scm_read_string_x_partial (SCM str, SCM port_or_fdes, SCM start, SCM end); +SCM scm_init_rw_builtins (void); void scm_init_rw (void); #endif From c36f65a8f0a9f1bd4969f0b58bc670f2dd35bc34 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 20 May 2001 00:33:49 +0000 Subject: [PATCH 1142/2047] (scm_system_module_env_p): Move out of deprecated section. --- libguile/modules.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/modules.h b/libguile/modules.h index c1074ee81..632668ebe 100644 --- a/libguile/modules.h +++ b/libguile/modules.h @@ -125,6 +125,7 @@ extern SCM scm_lookup_closure_module (SCM proc); extern SCM scm_env_top_level (SCM env); extern SCM scm_env_module (SCM env); extern SCM scm_top_level_env (SCM thunk); +extern SCM scm_system_module_env_p (SCM env); extern void scm_modules_prehistory (void); extern void scm_init_modules (void); @@ -135,7 +136,6 @@ extern SCM scm_the_root_module (void); extern SCM scm_make_module (SCM name); extern SCM scm_ensure_user_module (SCM name); extern SCM scm_load_scheme_module (SCM name); -extern SCM scm_system_module_env_p (SCM env); #endif From 9d78586faf6848734b2b61d22cec6d5b8742fbbd Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 20 May 2001 00:34:10 +0000 Subject: [PATCH 1143/2047] (scm_c_make_gsubr, scm_c_define_gsubr, scm_c_make_gsubr_with_generic, scm_c_define_gsubr_with_generic): New functions. They replace scm_make_gsubr and scm_make_gsubr_with_generic. The `make' variants only create the gsubr object, while the `define' variants also put it into the current module. Changed all callers. (scm_make_gsubr, scm_make_gsubr_with_generic): Deprecated. --- libguile/gsubr.c | 212 ++++++++++++++++++++++++++++++++++------------- libguile/gsubr.h | 20 ++++- 2 files changed, 174 insertions(+), 58 deletions(-) diff --git a/libguile/gsubr.c b/libguile/gsubr.c index 3b7c08d55..6989080bb 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -63,74 +63,148 @@ SCM_GLOBAL_SYMBOL (scm_sym_name, "name"); SCM scm_f_gsubr_apply; -SCM -scm_make_gsubr(const char *name,int req,int opt,int rst,SCM (*fcn)()) +static SCM +create_gsubr (int define, const char *name, + int req, int opt, int rst, SCM (*fcn)()) { - switch SCM_GSUBR_MAKTYPE(req, opt, rst) { - case SCM_GSUBR_MAKTYPE(0, 0, 0): return scm_make_subr(name, scm_tc7_subr_0, fcn); - case SCM_GSUBR_MAKTYPE(1, 0, 0): return scm_make_subr(name, scm_tc7_subr_1, fcn); - case SCM_GSUBR_MAKTYPE(0, 1, 0): return scm_make_subr(name, scm_tc7_subr_1o, fcn); - case SCM_GSUBR_MAKTYPE(1, 1, 0): return scm_make_subr(name, scm_tc7_subr_2o, fcn); - case SCM_GSUBR_MAKTYPE(2, 0, 0): return scm_make_subr(name, scm_tc7_subr_2, fcn); - case SCM_GSUBR_MAKTYPE(3, 0, 0): return scm_make_subr(name, scm_tc7_subr_3, fcn); - case SCM_GSUBR_MAKTYPE(0, 0, 1): return scm_make_subr(name, scm_tc7_lsubr, fcn); - case SCM_GSUBR_MAKTYPE(2, 0, 1): return scm_make_subr(name, scm_tc7_lsubr_2, fcn); - default: + SCM subr; + + switch (SCM_GSUBR_MAKTYPE (req, opt, rst)) { - SCM sym = scm_str2symbol (name); - SCM var = scm_sym2var (sym, scm_current_module_lookup_closure (), - SCM_BOOL_T); - SCM cclo = scm_makcclo (scm_f_gsubr_apply, 3L); - if (SCM_GSUBR_MAX < req + opt + rst) { - fputs("ERROR in scm_make_gsubr: too many args\n", stderr); - exit (1); - } - SCM_SET_GSUBR_PROC (cclo, scm_make_subr_opt (name, scm_tc7_subr_0, fcn, 0)); - SCM_SET_GSUBR_TYPE (cclo, SCM_MAKINUM (SCM_GSUBR_MAKTYPE (req, opt, rst))); - SCM_VARIABLE_SET (var, cclo); + case SCM_GSUBR_MAKTYPE(0, 0, 0): + subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn); + goto create_subr; + case SCM_GSUBR_MAKTYPE(1, 0, 0): + subr = scm_c_make_subr (name, scm_tc7_subr_1, fcn); + goto create_subr; + case SCM_GSUBR_MAKTYPE(0, 1, 0): + subr = scm_c_make_subr (name, scm_tc7_subr_1o, fcn); + goto create_subr; + case SCM_GSUBR_MAKTYPE(1, 1, 0): + subr = scm_c_make_subr (name, scm_tc7_subr_2o, fcn); + goto create_subr; + case SCM_GSUBR_MAKTYPE(2, 0, 0): + subr = scm_c_make_subr (name, scm_tc7_subr_2, fcn); + goto create_subr; + case SCM_GSUBR_MAKTYPE(3, 0, 0): + subr = scm_c_make_subr (name, scm_tc7_subr_3, fcn); + goto create_subr; + case SCM_GSUBR_MAKTYPE(0, 0, 1): + subr = scm_c_make_subr (name, scm_tc7_lsubr, fcn); + goto create_subr; + case SCM_GSUBR_MAKTYPE(2, 0, 1): + subr = scm_c_make_subr (name, scm_tc7_lsubr_2, fcn); + create_subr: + if (define) + scm_define (SCM_SUBR_ENTRY(subr).name, subr); + return subr; + default: + { + SCM cclo = scm_makcclo (scm_f_gsubr_apply, 3L); + SCM subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn); + SCM sym = SCM_SUBR_ENTRY(subr).name; + if (SCM_GSUBR_MAX < req + opt + rst) + { + fputs ("ERROR in scm_c_make_gsubr: too many args\n", stderr); + exit (1); + } + SCM_SET_GSUBR_PROC (cclo, subr); + SCM_SET_GSUBR_TYPE (cclo, + SCM_MAKINUM (SCM_GSUBR_MAKTYPE (req, opt, rst))); #ifdef DEBUG_EXTENSIONS - if (SCM_REC_PROCNAMES_P) - scm_set_procedure_property_x (cclo, scm_sym_name, sym); + if (SCM_REC_PROCNAMES_P) + scm_set_procedure_property_x (cclo, scm_sym_name, sym); #endif + if (define) + scm_define (sym, cclo); return cclo; + } } - } } SCM -scm_make_gsubr_with_generic (const char *name, - int req, - int opt, - int rst, - SCM (*fcn)(), - SCM *gf) +scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)()) { - switch SCM_GSUBR_MAKTYPE(req, opt, rst) { - case SCM_GSUBR_MAKTYPE(0, 0, 0): - return scm_make_subr_with_generic(name, scm_tc7_subr_0, fcn, gf); - case SCM_GSUBR_MAKTYPE(1, 0, 0): - return scm_make_subr_with_generic(name, scm_tc7_subr_1, fcn, gf); - case SCM_GSUBR_MAKTYPE(0, 1, 0): - return scm_make_subr_with_generic(name, scm_tc7_subr_1o, fcn, gf); - case SCM_GSUBR_MAKTYPE(1, 1, 0): - return scm_make_subr_with_generic(name, scm_tc7_subr_2o, fcn, gf); - case SCM_GSUBR_MAKTYPE(2, 0, 0): - return scm_make_subr_with_generic(name, scm_tc7_subr_2, fcn, gf); - case SCM_GSUBR_MAKTYPE(3, 0, 0): - return scm_make_subr_with_generic(name, scm_tc7_subr_3, fcn, gf); - case SCM_GSUBR_MAKTYPE(0, 0, 1): - return scm_make_subr_with_generic(name, scm_tc7_lsubr, fcn, gf); - case SCM_GSUBR_MAKTYPE(2, 0, 1): - return scm_make_subr_with_generic(name, scm_tc7_lsubr_2, fcn, gf); - default: - ; - } - scm_misc_error ("scm_make_gsubr_with_generic", + return create_gsubr (0, name, req, opt, rst, fcn); +} + +SCM +scm_c_define_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)()) +{ + return create_gsubr (1, name, req, opt, rst, fcn); +} + +static SCM +create_gsubr_with_generic (int define, + const char *name, + int req, + int opt, + int rst, + SCM (*fcn)(), + SCM *gf) +{ + SCM subr; + + switch (SCM_GSUBR_MAKTYPE(req, opt, rst)) + { + case SCM_GSUBR_MAKTYPE(0, 0, 0): + subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_0, fcn, gf); + goto create_subr; + case SCM_GSUBR_MAKTYPE(1, 0, 0): + subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_1, fcn, gf); + goto create_subr; + case SCM_GSUBR_MAKTYPE(0, 1, 0): + subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_1o, fcn, gf); + goto create_subr; + case SCM_GSUBR_MAKTYPE(1, 1, 0): + subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_2o, fcn, gf); + goto create_subr; + case SCM_GSUBR_MAKTYPE(2, 0, 0): + subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_2, fcn, gf); + goto create_subr; + case SCM_GSUBR_MAKTYPE(3, 0, 0): + subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_3, fcn, gf); + goto create_subr; + case SCM_GSUBR_MAKTYPE(0, 0, 1): + subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr, fcn, gf); + goto create_subr; + case SCM_GSUBR_MAKTYPE(2, 0, 1): + subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr_2, fcn, gf); + create_subr: + if (define) + scm_define (SCM_SUBR_ENTRY(subr).name, subr); + return subr; + default: + ; + } + scm_misc_error ("scm_c_make_gsubr_with_generic", "can't make primitive-generic with this arity", SCM_EOL); return SCM_BOOL_F; /* never reached */ } +SCM +scm_c_make_gsubr_with_generic (const char *name, + int req, + int opt, + int rst, + SCM (*fcn)(), + SCM *gf) +{ + return create_gsubr_with_generic (0, name, req, opt, rst, fcn, gf); +} + +SCM +scm_c_define_gsubr_with_generic (const char *name, + int req, + int opt, + int rst, + SCM (*fcn)(), + SCM *gf) +{ + return create_gsubr_with_generic (1, name, req, opt, rst, fcn, gf); +} + SCM scm_gsubr_apply (SCM args) @@ -209,10 +283,10 @@ gsubr_21l(SCM req1, SCM req2, SCM opt, SCM rst) void scm_init_gsubr() { - scm_f_gsubr_apply = scm_make_subr_opt("gsubr-apply", scm_tc7_lsubr, scm_gsubr_apply, 0); - + scm_f_gsubr_apply = scm_c_make_subr ("gsubr-apply", scm_tc7_lsubr, + scm_gsubr_apply); #ifdef GSUBR_TEST - scm_make_gsubr("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */ + scm_c_define_gsubr ("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */ #endif #ifndef SCM_MAGIC_SNARFER @@ -220,6 +294,32 @@ scm_init_gsubr() #endif } +#if SCM_DEBUG_DEPRECATED == 0 + +SCM +scm_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)()) +{ + scm_c_issue_deprecation_warning + ("`scm_make_gsubr' is deprecated. Use `scm_c_define_gsubr' instead."); + + return scm_c_define_gsubr (name, req, opt, rst, fcn); +} + +SCM +scm_make_gsubr_with_generic (const char *name, + int req, int opt, int rst, + SCM (*fcn)(), SCM *gf) +{ + scm_c_issue_deprecation_warning + ("`scm_make_gsubr_with_generic' is deprecated. " + "Use `scm_c_define_gsubr_with_generic' instead."); + + return scm_c_define_gsubr_with_generic (name, req, opt, rst, fcn, gf); +} + +#endif /* !SCM_DEBUG_DEPRECATED */ + + /* Local Variables: c-file-style: "gnu" diff --git a/libguile/gsubr.h b/libguile/gsubr.h index 90153c30a..108243374 100644 --- a/libguile/gsubr.h +++ b/libguile/gsubr.h @@ -61,6 +61,22 @@ extern SCM scm_f_gsubr_apply; +extern SCM scm_c_make_gsubr (const char *name, + int req, int opt, int rst, SCM (*fcn) ()); +extern SCM scm_c_make_gsubr_with_generic (const char *name, + int req, int opt, int rst, + SCM (*fcn) (), SCM *gf); +extern SCM scm_c_define_gsubr (const char *name, + int req, int opt, int rst, SCM (*fcn) ()); +extern SCM scm_c_define_gsubr_with_generic (const char *name, + int req, int opt, int rst, + SCM (*fcn) (), SCM *gf); + +extern SCM scm_gsubr_apply (SCM args); +extern void scm_init_gsubr (void); + +#if SCM_DEBUG_DEPRECATED == 0 + extern SCM scm_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)()); extern SCM scm_make_gsubr_with_generic (const char *name, @@ -69,8 +85,8 @@ extern SCM scm_make_gsubr_with_generic (const char *name, int rst, SCM (*fcn)(), SCM *gf); -extern SCM scm_gsubr_apply (SCM args); -extern void scm_init_gsubr (void); + +#endif #endif /* GSUBRH */ From c88a8162c408fe70d27e144a4a380fc88ab20dc5 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 20 May 2001 00:34:25 +0000 Subject: [PATCH 1144/2047] (scm_c_make_subr, scm_c_define_subr, scm_c_make_subr_with_generic, scm_c_define_subr_with_generic): New functions. They replace scm_make_subr, scm_make_subr_opt and scm_make_subr_with_generic. The `make' variants only create the subr object, while the `define' variants also put it into the current module. Changed all callers. (scm_make_subr, scm_make_subr_opt, scm_make_subr_with_generic): Deprecated. --- libguile/procs.c | 79 +++++++++++++++++++++++++++++++++++------------- libguile/procs.h | 25 +++++++++------ 2 files changed, 74 insertions(+), 30 deletions(-) diff --git a/libguile/procs.c b/libguile/procs.c index 65331edb8..66989d5e8 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -50,6 +50,7 @@ #include "libguile/strings.h" #include "libguile/vectors.h" #include "libguile/smob.h" +#include "libguile/deprecation.h" #include "libguile/validate.h" #include "libguile/procs.h" @@ -70,10 +71,8 @@ int scm_subr_table_size = 0; int scm_subr_table_room = 800; SCM -scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set) +scm_c_make_subr (const char *name, int type, SCM (*fcn) ()) { - SCM symbol; - SCM var; register SCM z; int entry; @@ -89,18 +88,11 @@ scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set) scm_subr_table_room = new_size; } - symbol = scm_str2symbol (name); - SCM_NEWCELL (z); - if (set) - var = scm_sym2var (symbol, scm_current_module_lookup_closure (), - SCM_BOOL_T); - else - var = SCM_BOOL_F; - + entry = scm_subr_table_size; scm_subr_table[entry].handle = z; - scm_subr_table[entry].name = symbol; + scm_subr_table[entry].name = scm_str2symbol (name); scm_subr_table[entry].generic = 0; scm_subr_table[entry].properties = SCM_EOL; @@ -108,12 +100,17 @@ scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set) SCM_SET_CELL_TYPE (z, (entry << 8) + type); scm_subr_table_size++; - if (set) - SCM_VARIABLE_SET (var, z); - return z; } +SCM +scm_c_define_subr (const char *name, int type, SCM (*fcn) ()) +{ + SCM subr = scm_c_make_subr (name, type, fcn); + scm_define (SCM_SUBR_ENTRY(subr).name, subr); + return subr; +} + /* This function isn't currently used since subrs are never freed. */ /* *fixme* Need mutex here. */ void @@ -126,17 +123,21 @@ scm_free_subr_entry (SCM subr) scm_subr_table_size--; } -SCM -scm_make_subr (const char *name, int type, SCM (*fcn) ()) +SCM +scm_c_make_subr_with_generic (const char *name, + int type, SCM (*fcn) (), SCM *gf) { - return scm_make_subr_opt (name, type, fcn, 1); + SCM subr = scm_c_make_subr (name, type, fcn); + SCM_SUBR_ENTRY(subr).generic = gf; + return subr; } SCM -scm_make_subr_with_generic (const char *name, int type, SCM (*fcn) (), SCM *gf) +scm_c_define_subr_with_generic (const char *name, + int type, SCM (*fcn) (), SCM *gf) { - SCM subr = scm_make_subr_opt (name, type, fcn, 1); - scm_subr_table[scm_subr_table_size - 1].generic = gf; + SCM subr = scm_c_make_subr_with_generic (name, type, fcn, gf); + scm_define (SCM_SUBR_ENTRY(subr).name, subr); return subr; } @@ -402,6 +403,42 @@ scm_init_procs () #endif } +#if SCM_DEBUG_DEPRECATED == 0 + +SCM +scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set) +{ + scm_c_issue_deprecation_warning + ("`scm_make_subr_opt' is deprecated. Use `scm_c_make_subr' or " + "`scm_c_define_subr' instead."); + + if (set) + return scm_c_define_subr (name, type, fcn); + else + return scm_c_make_subr (name, type, fcn); +} + +SCM +scm_make_subr (const char *name, int type, SCM (*fcn) ()) +{ + scm_c_issue_deprecation_warning + ("`scm_make_subr' is deprecated. Use `scm_c_define_subr' instead."); + + return scm_c_define_subr (name, type, fcn); +} + +SCM +scm_make_subr_with_generic (const char *name, int type, SCM (*fcn) (), SCM *gf) +{ + scm_c_issue_deprecation_warning + ("`scm_make_subr_with_generic' is deprecated. Use " + "`scm_c_define_subr_with_generic' instead."); + + return scm_c_define_subr_with_generic (name, type, fcn); +} + +#endif /* !SCM_DEBUG_DEPRECATION */ + /* Local Variables: c-file-style: "gnu" diff --git a/libguile/procs.h b/libguile/procs.h index ca39c918d..9b8af9138 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -161,15 +161,12 @@ extern int scm_subr_table_room; extern void scm_mark_subr_table (void); extern void scm_free_subr_entry (SCM subr); -extern SCM scm_make_subr (const char *name, int type, SCM (*fcn) ()); -extern SCM scm_make_subr_with_generic (const char *name, - int type, - SCM (*fcn) (), - SCM *gf); -extern SCM scm_make_subr_opt (const char *name, - int type, - SCM (*fcn) (), - int set); +extern SCM scm_c_make_subr (const char *name, int type, SCM (*fcn)()); +extern SCM scm_c_make_subr_with_generic (const char *name, int type, + SCM (*fcn)(), SCM *gf); +extern SCM scm_c_define_subr (const char *name, int type, SCM (*fcn)()); +extern SCM scm_c_define_subr_with_generic (const char *name, int type, + SCM (*fcn)(), SCM *gf); extern SCM scm_makcclo (SCM proc, long len); extern SCM scm_procedure_p (SCM obj); extern SCM scm_closure_p (SCM obj); @@ -193,6 +190,16 @@ extern SCM scm_make_cclo (SCM proc, SCM len); #define SCM_SUBR_DOC(x) SCM_BOOL_F +extern SCM scm_make_subr (const char *name, int type, SCM (*fcn) ()); +extern SCM scm_make_subr_with_generic (const char *name, + int type, + SCM (*fcn) (), + SCM *gf); +extern SCM scm_make_subr_opt (const char *name, + int type, + SCM (*fcn) (), + int set); + #endif /* SCM_DEBUG_DEPRECATED == 0 */ #endif /* SCM_PROCS_H */ From 9a441ddb342277f220435280718658f3f126ed43 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 20 May 2001 00:35:43 +0000 Subject: [PATCH 1145/2047] (scm_c_make_gsubr, scm_c_define_gsubr, scm_c_make_gsubr_with_generic, scm_c_define_gsubr_with_generic): New functions. They replace scm_make_gsubr and scm_make_gsubr_with_generic. The `make' variants only create the gsubr object, while the `define' variants also put it into the current module. Changed all callers. (scm_make_gsubr, scm_make_gsubr_with_generic): Deprecated. (scm_c_make_subr, scm_c_define_subr, scm_c_make_subr_with_generic, scm_c_define_subr_with_generic): New functions. They replace scm_make_subr, scm_make_subr_opt and scm_make_subr_with_generic. The `make' variants only create the subr object, while the `define' variants also put it into the current module. Changed all callers. (scm_make_subr, scm_make_subr_opt, scm_make_subr_with_generic): Deprecated. --- libguile/eval.c | 2 +- libguile/gc.c | 3 ++- libguile/gh_funcs.c | 4 ++-- libguile/goops.c | 11 ++++++----- libguile/macros.c | 2 +- libguile/pairs.c | 2 +- libguile/ramap.c | 2 +- libguile/rdelim.c | 3 ++- libguile/rw.c | 2 +- libguile/scmsigs.c | 5 +++-- libguile/snarf.h | 24 ++++++++++++------------ libguile/values.c | 3 ++- 12 files changed, 34 insertions(+), 29 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index 5d8185c9f..adee9ae0b 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -4098,7 +4098,7 @@ scm_init_eval () SCM_SETCDR (scm_undefineds, scm_undefineds); scm_listofnull = scm_cons (SCM_EOL, SCM_EOL); - scm_f_apply = scm_make_subr ("apply", scm_tc7_lsubr_2, scm_apply); + scm_f_apply = scm_c_define_subr ("apply", scm_tc7_lsubr_2, scm_apply); /* acros */ /* end of acros */ diff --git a/libguile/gc.c b/libguile/gc.c index d93bf1ae8..25c9971b0 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -2671,7 +2671,8 @@ scm_init_gc () /* Dirk:FIXME:: scm_create_hook is strange. */ scm_after_gc_hook = scm_create_hook ("after-gc-hook", 0); - after_gc_thunk = scm_make_subr_opt ("%gc-thunk", scm_tc7_subr_0, gc_async_thunk, 0); + after_gc_thunk = scm_c_make_subr ("%gc-thunk", scm_tc7_subr_0, + gc_async_thunk); gc_async = scm_system_async (after_gc_thunk); /* protected via scm_asyncs */ scm_c_hook_add (&scm_after_gc_c_hook, mark_gc_async, NULL, 0); diff --git a/libguile/gh_funcs.c b/libguile/gh_funcs.c index cdb07a4cc..de3b97a92 100644 --- a/libguile/gh_funcs.c +++ b/libguile/gh_funcs.c @@ -50,8 +50,8 @@ SCM gh_new_procedure (const char *proc_name, SCM (*fn) (), int n_required_args, int n_optional_args, int varp) { - return scm_make_gsubr (proc_name, n_required_args, n_optional_args, - varp, fn); + return scm_c_define_gsubr (proc_name, n_required_args, n_optional_args, + varp, fn); } SCM diff --git a/libguile/goops.c b/libguile/goops.c index ea07bc3ba..1b9b6e57d 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1862,7 +1862,7 @@ scm_sys_compute_applicable_methods (SCM gf, SCM args) #undef FUNC_NAME SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods"); -SCM_VARIABLE_INIT (var_compute_applicable_methods, "compute-applicable-methods", scm_make_gsubr (s_sys_compute_applicable_methods, 2, 0, 0, scm_sys_compute_applicable_methods)); +SCM_VARIABLE_INIT (var_compute_applicable_methods, "compute-applicable-methods", scm_c_define_gsubr (s_sys_compute_applicable_methods, 2, 0, 0, scm_sys_compute_applicable_methods)); SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_makmmacro, scm_m_atslot_ref); @@ -2511,9 +2511,9 @@ scm_add_slot (SCM class, char *slot_name, SCM slot_class, char *accessor_name) { { - SCM get = scm_make_subr_opt ("goops:get", scm_tc7_subr_1, getter, 0); - SCM set = scm_make_subr_opt ("goops:set", scm_tc7_subr_2, - setter ? setter : default_setter, 0); + SCM get = scm_c_make_subr ("goops:get", scm_tc7_subr_1, getter); + SCM set = scm_c_make_subr ("goops:set", scm_tc7_subr_2, + setter ? setter : default_setter); SCM getm = scm_closure (SCM_LIST2 (SCM_LIST1 (sym_o), SCM_LIST2 (get, sym_o)), SCM_EOL); @@ -2693,7 +2693,8 @@ scm_init_goops_builtins (void) void scm_init_goops () { - scm_make_gsubr ("%init-goops-builtins", 0, 0, 0, scm_init_goops_builtins); + scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0, + scm_init_goops_builtins); } /* diff --git a/libguile/macros.c b/libguile/macros.c index 79618bd12..98b27d718 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -221,7 +221,7 @@ SCM scm_make_synt (const char *name, SCM (*macroizer) (), SCM (*fcn)() ) { SCM var = scm_c_define (name, SCM_UNDEFINED); - SCM transformer = scm_make_subr_opt (name, scm_tc7_subr_2, fcn, 0); + SCM transformer = scm_c_make_subr (name, scm_tc7_subr_2, fcn); SCM_VARIABLE_SET (var, macroizer (transformer)); return SCM_UNSPECIFIED; } diff --git a/libguile/pairs.c b/libguile/pairs.c index 0dee9b6f6..812c39235 100644 --- a/libguile/pairs.c +++ b/libguile/pairs.c @@ -169,7 +169,7 @@ scm_init_pairs () unsigned int subnr = 0; for (subnr = 0; cxrs [subnr]; subnr++) - scm_make_subr(cxrs [subnr], scm_tc7_cxr, NULL); + scm_c_define_subr (cxrs [subnr], scm_tc7_cxr, NULL); #ifndef SCM_MAGIC_SNARFER #include "libguile/pairs.x" diff --git a/libguile/ramap.c b/libguile/ramap.c index 5fe765624..023cd5ad5 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -2064,7 +2064,7 @@ scm_init_ramap () { init_raprocs (ra_rpsubrs); init_raprocs (ra_asubrs); - scm_make_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p); + scm_c_define_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p); scm_smobs[SCM_TC2SMOBNUM (scm_tc16_array)].equalp = scm_raequal; #ifndef SCM_MAGIC_SNARFER #include "libguile/ramap.x" diff --git a/libguile/rdelim.c b/libguile/rdelim.c index 3e8697a31..1440e1b6c 100644 --- a/libguile/rdelim.c +++ b/libguile/rdelim.c @@ -307,7 +307,8 @@ scm_init_rdelim_builtins (void) void scm_init_rdelim (void) { - scm_make_gsubr ("%init-rdelim-builtins", 0, 0, 0, scm_init_rdelim_builtins); + scm_c_define_gsubr ("%init-rdelim-builtins", 0, 0, 0, + scm_init_rdelim_builtins); } /* diff --git a/libguile/rw.c b/libguile/rw.c index d1a6b2782..28d4ea604 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -173,7 +173,7 @@ scm_init_rw_builtins () void scm_init_rw () { - scm_make_gsubr ("%init-rw-builtins", 0, 0, 0, scm_init_rw_builtins); + scm_c_define_gsubr ("%init-rw-builtins", 0, 0, 0, scm_init_rw_builtins); } /* diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index 380dea0c2..c36c83d98 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -494,8 +494,9 @@ scm_init_scmsigs () signal_handlers = SCM_VARIABLE_LOC (scm_c_define ("signal-handlers", scm_c_make_vector (NSIG, SCM_BOOL_F))); - thunk = scm_make_gsubr ("%deliver-signals", 0, 0, 0, - sys_deliver_signals); + /* XXX - use scm_c_make_gsubr here instead of `define'? */ + thunk = scm_c_define_gsubr ("%deliver-signals", 0, 0, 0, + sys_deliver_signals); signal_async = scm_system_async (thunk); for (i = 0; i < NSIG; i++) diff --git a/libguile/snarf.h b/libguile/snarf.h index 9aef75fcc..ea1926632 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -92,8 +92,8 @@ static const char s_ ## FNAME [] = PRIMNAME; \ SCM FNAME ARGLIST\ )\ SCM_SNARF_INIT(\ -scm_make_gsubr (s_ ## FNAME, REQ, OPT, VAR, \ - (SCM_FUNC_CAST_ARBITRARY_ARGS) FNAME); \ +scm_c_define_gsubr (s_ ## FNAME, REQ, OPT, VAR, \ + (SCM_FUNC_CAST_ARBITRARY_ARGS) FNAME); \ )\ SCM_SNARF_DOCS(\ SCM_SNARF_DOC_STARTP PRIMNAME #ARGLIST | REQ | OPT | VAR | __FILE__:__LINE__ | \ @@ -105,7 +105,7 @@ SCM_SNARF_HERE(\ static const char s_ ## FNAME [] = PRIMNAME; \ SCM FNAME ARGLIST\ )\ -SCM_SNARF_INIT(scm_make_subr (s_ ## FNAME, TYPE, FNAME); ) \ +SCM_SNARF_INIT(scm_c_define_subr (s_ ## FNAME, TYPE, FNAME); ) \ SCM_SNARF_DOCS(\ SCM_SNARF_DOC_START1 PRIMNAME #ARGLIST | 2 | 0 | 0 | __FILE__:__LINE__ | \ SCM_SNARF_DOCSTRING_START DOCSTRING SCM_SNARF_DOCSTRING_END \ @@ -113,13 +113,13 @@ SCM_SNARF_DOC_START1 PRIMNAME #ARGLIST | 2 | 0 | 0 | __FILE__:__LINE__ | \ #define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \ SCM_SNARF_HERE(static const char RANAME[]=STR) \ -SCM_SNARF_INIT(scm_make_gsubr (RANAME, REQ, OPT, VAR, \ - (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN)) +SCM_SNARF_INIT(scm_c_define_gsubr (RANAME, REQ, OPT, VAR, \ + (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN)) #define SCM_REGISTER_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \ SCM_SNARF_HERE(static const char RANAME[]=STR) \ -SCM_SNARF_INIT(scm_make_gsubr (RANAME, REQ, OPT, VAR, \ - (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN);) \ +SCM_SNARF_INIT(scm_c_define_gsubr (RANAME, REQ, OPT, VAR, \ + (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN);) \ SCM_SNARF_DOCS(\ SCM_SNARF_DOC_STARTR STR | REQ | OPT | VAR | __FILE__:__LINE__ | \ SCM_SNARF_DOCSTRING_START CFN SCM_SNARF_DOCSTRING_END \ @@ -131,14 +131,14 @@ static const char RANAME[]=STR;\ static SCM GF \ )SCM_SNARF_INIT(\ GF = SCM_PACK (0); /* Dirk:FIXME:: Can we safely use #f instead of 0? */ \ -scm_make_gsubr_with_generic (RANAME, REQ, OPT, VAR, \ - (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN, &GF) \ +scm_c_define_gsubr_with_generic (RANAME, REQ, OPT, VAR, \ + (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN, &GF) \ ) #define SCM_PROC1(RANAME, STR, TYPE, CFN) \ SCM_SNARF_HERE(static const char RANAME[]=STR) \ SCM_SNARF_INIT(\ -scm_make_subr (RANAME, TYPE, (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN) \ +scm_c_define_subr (RANAME, TYPE, (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN) \ ) @@ -148,8 +148,8 @@ static const char RANAME[]=STR; \ static SCM GF \ )SCM_SNARF_INIT(\ GF = SCM_PACK (0); /* Dirk:FIXME:: Can we safely use #f instead of 0? */ \ -scm_make_subr_with_generic (RANAME, TYPE, \ - (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN, &GF) \ +scm_c_define_subr_with_generic (RANAME, TYPE, \ + (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN, &GF) \ ) #define SCM_SYNTAX(RANAME, STR, TYPE, CFN) \ diff --git a/libguile/values.c b/libguile/values.c index b37124759..5aad29a89 100644 --- a/libguile/values.c +++ b/libguile/values.c @@ -96,7 +96,8 @@ SCM_DEFINE (scm_values, "values", 0, 0, 1, void scm_init_values (void) { - SCM print = scm_make_subr ("%print-values", scm_tc7_subr_2, print_values); + SCM print = scm_c_define_subr ("%print-values", scm_tc7_subr_2, + print_values); scm_values_vtable = scm_permanent_object (scm_make_vtable_vtable (scm_makfrom0str ("pr"), From 2fc933fe89cc3934ea35e4f02e62d9b006ddad7f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 20 May 2001 00:36:40 +0000 Subject: [PATCH 1146/2047] *** empty log message *** --- RELEASE | 14 ++++++++++++++ libguile/ChangeLog | 28 ++++++++++++++++++++++++++++ srfi/ChangeLog | 5 +++++ 3 files changed, 47 insertions(+) diff --git a/RELEASE b/RELEASE index bb1bd4396..c234462cc 100644 --- a/RELEASE +++ b/RELEASE @@ -22,8 +22,21 @@ After signal handling and threading have been fixed: === In release 1.8.0: +- remove deprecated subr and gsubr functions + in procs.h, procs.c: scm_make_subr, scm_make_subr_opt, + scm_make_subr_with_generic, + in gsubr.h, gsubr.c: scm_make_gsubr, scm_make_gsubr_with_generic. + +- remove deprecated C interface to modules + in modules.h, modules.c: + root_module_lookup_closure, scm_sym_app, scm_sym_modules, + module_prefix, make_modules_in_var, beautify_user_module_x_var, + scm_the_root_module, scm_make_module, scm_ensure_user_module, + scm_load_scheme_module + - remove vcell and obarray support. Remove all code bracketed by `#if SCM_ENABLE_VCELLS'. + Remove SCM_ENABLE_VCELLS itself. Also remove `variable-set-name-hint' completely. - remove compatability module (ice-9 and-let*). It @@ -37,6 +50,7 @@ After signal handling and threading have been fixed: etc. - remove deprecated variables: scm_top_level_lookup_closure_var + scm_scm_system_transformer - remove deprecated functions: eval.c: scm_eval2, scm_eval_3 load.c: scm_read_and_eval_x diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 94bb85edb..bfae3ad4c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,31 @@ +2001-05-20 Marius Vollmer + + * modules.h (scm_system_module_env_p): Move out of deprecated + section. + + * rw.h (scm_init_rw): Added prototype. + + * gsubr.h, gsubr.c (scm_c_make_gsubr, scm_c_define_gsubr, + scm_c_make_gsubr_with_generic, scm_c_define_gsubr_with_generic): + New functions. They replace scm_make_gsubr and + scm_make_gsubr_with_generic. The `make' variants only create the + gsubr object, while the `define' variants also put it into the + current module. Changed all callers. + (scm_make_gsubr, scm_make_gsubr_with_generic): Deprecated. + + * procs.h, procs.c (scm_c_make_subr, scm_c_define_subr, + scm_c_make_subr_with_generic, scm_c_define_subr_with_generic): New + functions. They replace scm_make_subr, scm_make_subr_opt and + scm_make_subr_with_generic. The `make' variants only create the + subr object, while the `define' variants also put it into the + current module. Changed all callers. + (scm_make_subr, scm_make_subr_opt, scm_make_subr_with_generic): + Deprecated. + + * eval.c, gc.c, gh_funcs.c, goops.c, macros.c, pairs.c, ramap.c, + rdelim.c, rw.c, scmsigs.c, snarf.h, values.c: Changed according to + the comments above. + 2001-05-19 Neil Jerram * throw.c (scm_lazy_catch): Slight docstring clarification. diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 4231ab088..be1ea2aed 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,8 @@ +2001-05-20 Marius Vollmer + + * srfi-14.c (scm_c_init_srfi_14): Added "int" to declaration of + `initialized'. + 2001-05-19 Marius Vollmer Avoid using module operations from C. From e2ab7927bfab05cb08b611ec8827258a395b72ae Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 20 May 2001 19:26:23 +0000 Subject: [PATCH 1147/2047] New files. --- libguile/extensions.c | 157 ++++++++++++++++++++++++++++++++++++++++++ libguile/extensions.h | 64 +++++++++++++++++ 2 files changed, 221 insertions(+) create mode 100644 libguile/extensions.c create mode 100644 libguile/extensions.h diff --git a/libguile/extensions.c b/libguile/extensions.c new file mode 100644 index 000000000..3d4f7d8cd --- /dev/null +++ b/libguile/extensions.c @@ -0,0 +1,157 @@ +/* extensions.c - registering and loading extensions. + * + * Copyright (C) 2001 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 + * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +#include "libguile/_scm.h" +#include "libguile/strings.h" +#include "libguile/gc.h" +#include "libguile/dynl.h" + +#include "libguile/extensions.h" + +struct extension { + struct extension *next; + const char *lib; + const char *init; + void (*func)(void *); + void *data; +}; + +static struct extension *registered_extensions; + +void +scm_c_register_extension (const char *lib, const char *init, + void (*func) (void *), void *data) +{ + struct extension *ext = scm_must_malloc (sizeof(struct extension), + "scm_register_extension"); + ext->lib = scm_must_strdup (lib); + ext->init = scm_must_strdup (init); + ext->func = func; + ext->data = data; + + ext->next = registered_extensions; + registered_extensions = ext; +} + +static void +load_extension (SCM lib, SCM init) +{ + /* Search the registry. */ + { + struct extension *ext; + + for (ext = registered_extensions; ext; ext = ext->next) + if (!strcmp (ext->lib, SCM_STRING_CHARS (lib)) + && !strcmp (ext->init, SCM_STRING_CHARS (init))) + { + ext->func (ext->data); + return; + } + } + + /* Dynamically link the library. */ + + scm_dynamic_call (init, scm_dynamic_link (lib)); +} + +void +scm_c_load_extension (const char *lib, const char *init) +{ + load_extension (scm_makfrom0str (lib), scm_makfrom0str (init)); +} + +SCM_DEFINE (scm_load_extension, "load-extension", 2, 0, 0, + (SCM lib, SCM init), + "Load and initilize the extension designated by LIB and INIT." +"When there is no pre-registered function for LIB/INIT, this is " +"equivalent to " +" " +" (dynamic-call INIT (dynamic-link LIB)) " +" " +"When there is a pre-registered function, that function is called " +"instead. " +" " +"Normally, there is no pre-registered function. This option exists " +"only for situations where dynamic linking is unavailable or unwanted. " +"In that case, you would statically link your program with the desired " +"library, and register its init function right after Guile has been " +"initialized. " +" " +"LIB should be a string denoting a shared library without any file type " +"suffix such as \".so\". The suffix is provided automatically. It " +"should also not contain any directory components. Libraries that " +"implement Guile Extensions should be put into the normal locations for " +"shared libraries. We recommend to use the naming convention " +"libguile-bla-blum for a extension related to a module `(bla blum)'. " +" " +"The normal way for a extension to be used is to write a small Scheme " +"file that defines a module, and to load the extension into this " +"module. When the module is auto-loaded, the extension is loaded as " +"well. For example, " +" " +" (define-module (bla blum)) " +" " +" (load-extension \"libguile-bla-blum\" \"bla_init_blum\")") +#define FUNC_NAME s_scm_load_extension +{ + SCM_VALIDATE_STRING (1, lib); + SCM_VALIDATE_STRING (2, init); + load_extension (lib, init); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +void +scm_init_extensions () +{ + registered_extensions = NULL; +#ifndef SCM_MAGIC_SNARFER +#include "libguile/extensions.x" +#endif +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/extensions.h b/libguile/extensions.h new file mode 100644 index 000000000..f42b85535 --- /dev/null +++ b/libguile/extensions.h @@ -0,0 +1,64 @@ +/* Copyright (C) 2001 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 + * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + + +#ifndef LIBGUILE_EXTENSIONS_H +#define LIBGUILE_EXTENSIONS_H + +#include "libguile/__scm.h" + + + +extern void scm_c_register_extension (const char *lib, const char *init, + void (*func) (void *), void *data); + +extern void scm_c_load_extension (const char *lib, const char *init); +extern SCM scm_load_extension (SCM lib, SCM init); + +void scm_init_extensions (void); + +#endif /* LIBGUILE_EXTENSIONS_H */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ From e4a7824f4e17897eba28b288bb6e92db0c627ed4 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 20 May 2001 19:27:22 +0000 Subject: [PATCH 1148/2047] * gc.h, gc.c (scm_must_strdup, scm_must_strndup): New. --- libguile/gc.c | 14 ++++++++++++++ libguile/gc.h | 2 ++ 2 files changed, 16 insertions(+) diff --git a/libguile/gc.c b/libguile/gc.c index 25c9971b0..657346d84 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1985,6 +1985,20 @@ scm_must_realloc (void *where, scm_memory_error (what); } +char * +scm_must_strndup (const char *str, unsigned long length) +{ + char * dst = scm_must_malloc (length + 1, "scm_must_strndup"); + memcpy (dst, str, length); + dst[length] = 0; + return dst; +} + +char * +scm_must_strdup (const char *str) +{ + return scm_must_strndup (str, strlen (str)); +} void scm_must_free (void *obj) diff --git a/libguile/gc.h b/libguile/gc.h index 0fe4d513f..331c15386 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -370,6 +370,8 @@ extern void * scm_must_malloc (scm_sizet len, const char *what); extern void * scm_must_realloc (void *where, scm_sizet olen, scm_sizet len, const char *what); +extern char *scm_must_strdup (const char *str); +extern char *scm_must_strndup (const char *str, unsigned long n); extern void scm_done_malloc (long size); extern void scm_done_free (long size); extern void scm_must_free (void *obj); From 438b273828ba85f8ae0fcaacfcb187b79b495662 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 20 May 2001 19:27:59 +0000 Subject: [PATCH 1149/2047] Add "extensions.c" and related files in all the right places. --- libguile/Makefile.am | 38 +++++++++++++++++++++----------------- 1 file changed, 21 insertions(+), 17 deletions(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 9f798076c..b123255d0 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -38,23 +38,25 @@ guile_SOURCES = guile.c guile_LDADD = libguile.la ${THREAD_LIBS_LOCAL} guile_LDFLAGS = @DLPREOPEN@ -libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ - chars.c continuations.c debug.c deprecation.c dynl.c dynwind.c \ - environments.c eq.c error.c eval.c evalext.c feature.c fluids.c fports.c \ - gc.c gc_os_dep.c gdbint.c gh_data.c gh_eval.c gh_funcs.c gh_init.c \ - gh_io.c gh_list.c gh_predicates.c goops.c gsubr.c guardians.c hash.c \ - hashtab.c hooks.c init.c ioext.c iselect.c keywords.c lang.c list.c \ - load.c macros.c mallocs.c modules.c numbers.c objects.c objprop.c \ - options.c pairs.c ports.c print.c procprop.c procs.c properties.c \ - random.c rdelim.c read.c root.c rw.c scmsigs.c script.c simpos.c smob.c \ - sort.c srcprop.c stackchk.c stacks.c stime.c strings.c strop.c \ - strorder.c strports.c struct.c symbols.c tag.c throw.c values.c \ +libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ + chars.c continuations.c debug.c deprecation.c dynl.c dynwind.c \ + environments.c eq.c error.c eval.c evalext.c extensions.c \ + feature.c fluids.c fports.c \ + gc.c gc_os_dep.c gdbint.c gh_data.c gh_eval.c gh_funcs.c gh_init.c \ + gh_io.c gh_list.c gh_predicates.c goops.c gsubr.c guardians.c hash.c \ + hashtab.c hooks.c init.c ioext.c iselect.c keywords.c lang.c list.c \ + load.c macros.c mallocs.c modules.c numbers.c objects.c objprop.c \ + options.c pairs.c ports.c print.c procprop.c procs.c properties.c \ + random.c rdelim.c read.c root.c rw.c scmsigs.c script.c simpos.c smob.c \ + sort.c srcprop.c stackchk.c stacks.c stime.c strings.c strop.c \ + strorder.c strports.c struct.c symbols.c tag.c throw.c values.c \ variable.c vectors.c version.c vports.c weaks.c symbols-deprecated.c DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ continuations.x debug.x deprecation.x dynl.x dynwind.x \ environments.x eq.x \ - error.x eval.x evalext.x feature.x fluids.x fports.x gc.x goops.x \ + error.x eval.x evalext.x extensions.x feature.x fluids.x fports.x \ + gc.x goops.x \ gsubr.x guardians.x hash.x hashtab.x hooks.x init.x ioext.x iselect.x \ keywords.x lang.x list.x load.x macros.x mallocs.x modules.x \ numbers.x objects.x objprop.x options.x pairs.x ports.x print.x \ @@ -69,7 +71,8 @@ EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \ boolean.doc chars.doc continuations.doc debug.doc dynl.doc \ dynwind.doc environments.doc eq.doc error.doc eval.doc evalext.doc \ - feature.doc fluids.doc fports.doc gc.doc goops.doc gsubr.doc \ + extensions.doc feature.doc fluids.doc fports.doc gc.doc goops.doc \ + gsubr.doc \ guardians.doc hash.doc hashtab.doc hooks.doc init.doc ioext.doc \ iselect.doc keywords.doc lang.doc list.doc load.doc macros.doc \ mallocs.doc modules.doc numbers.doc objects.doc objprop.doc \ @@ -86,10 +89,10 @@ EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@ BUILT_SOURCES = cpp_err_symbols.c cpp_sig_symbols.c libpath.h scmconfig.h \ $(DOT_X_FILES) $(EXTRA_DOT_X_FILES) $(DOT_DOC_FILES) -EXTRA_libguile_la_SOURCES = _scm.h \ +EXTRA_libguile_la_SOURCES = _scm.h \ alloca.c inet_aton.c memmove.c putenv.c strerror.c \ - threads.c regex-posix.c \ - filesys.c posix.c net_db.c socket.c \ + threads.c regex-posix.c \ + filesys.c posix.c net_db.c socket.c \ ramap.c unif.c debug-malloc.c ## In next release, threads will be factored out of libguile. @@ -115,7 +118,8 @@ modincludedir = $(includedir)/libguile modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h boolean.h \ chars.h continuations.h coop-defs.h debug.h debug-malloc.h deprecation.h \ dynl.h dynwind.h environments.h eq.h error.h eval.h evalext.h \ - feature.h filesys.h fluids.h fports.h gc.h gdb_interface.h gdbint.h \ + extensions.h feature.h filesys.h fluids.h fports.h gc.h \ + gdb_interface.h gdbint.h \ goops.h gsubr.h guardians.h hash.h hashtab.h hooks.h init.h ioext.h \ iselect.h keywords.h lang.h list.h load.h macros.h mallocs.h modules.h \ net_db.h numbers.h objects.h objprop.h options.h pairs.h ports.h posix.h \ From 08045107a0eea3871b9b98a5cca41988f3ef9c05 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 20 May 2001 19:29:11 +0000 Subject: [PATCH 1150/2047] (scm_init_guile_1): Call scm_init_extensions. --- libguile/init.c | 1 + 1 file changed, 1 insertion(+) diff --git a/libguile/init.c b/libguile/init.c index 0e91a7559..2001e7910 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -590,6 +590,7 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_init_rdelim (); scm_init_rw (); + scm_init_extensions (); scm_load_startup_files (); } From 25c507d9a2fec70c481801259a96c1d5eec52ef6 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 20 May 2001 19:31:58 +0000 Subject: [PATCH 1151/2047] (scm_mem2symbol): Call `scm_must_strndup' instead of `duplicate_string'. Do not use an indirect cell, store symbol directly in collision list of hash table. (duplicate_string): Removed. --- libguile/symbols.c | 22 +++++----------------- 1 file changed, 5 insertions(+), 17 deletions(-) diff --git a/libguile/symbols.c b/libguile/symbols.c index 45f5ee982..f78ece091 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -82,17 +82,6 @@ SCM_DEFINE (scm_sys_symbols, "%symbols", 0, 0, 0, -static char * -duplicate_string (const char * src, unsigned long length) -{ - char * dst = scm_must_malloc (length + 1, "duplicate_string"); - memcpy (dst, src, length); - dst[length] = 0; - return dst; -} - - - /* {Symbols} */ @@ -110,8 +99,9 @@ scm_mem2symbol (const char *name, scm_sizet len) for (l = SCM_VELTS (symbols) [hash]; !SCM_NULLP (l); l = SCM_CDR (l)) { - SCM sym = SCM_CAAR (l); - if (SCM_SYMBOL_HASH (sym) == raw_hash && SCM_SYMBOL_LENGTH (sym) == len) + SCM sym = SCM_CAR (l); + if (SCM_SYMBOL_HASH (sym) == raw_hash + && SCM_SYMBOL_LENGTH (sym) == len) { char *chrs = SCM_SYMBOL_CHARS (sym); scm_sizet i = len; @@ -134,18 +124,16 @@ scm_mem2symbol (const char *name, scm_sizet len) /* The symbol was not found - create it. */ SCM symbol; - SCM cell; SCM slot; SCM_NEWCELL2 (symbol); - SCM_SET_SYMBOL_CHARS (symbol, duplicate_string (name, len)); + SCM_SET_SYMBOL_CHARS (symbol, scm_must_strndup (name, len)); SCM_SET_SYMBOL_HASH (symbol, raw_hash); SCM_SET_PROP_SLOTS (symbol, scm_cons (SCM_BOOL_F, SCM_EOL)); SCM_SET_SYMBOL_LENGTH (symbol, (long) len); - cell = scm_cons (symbol, SCM_UNDEFINED); slot = SCM_VELTS (symbols) [hash]; - SCM_VELTS (symbols) [hash] = scm_cons (cell, slot); + SCM_VELTS (symbols) [hash] = scm_cons (symbol, slot); return symbol; } From 57ae112df6d436fe578c1dcb849359e708f7f193 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 20 May 2001 19:32:11 +0000 Subject: [PATCH 1152/2047] *** empty log message *** --- libguile/ChangeLog | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index bfae3ad4c..ea471ec80 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,19 @@ 2001-05-20 Marius Vollmer + * symbols.c (scm_mem2symbol): Call `scm_must_strndup' instead of + `duplicate_string'. Do not use an indirect cell, store symbol + directly in collision list of hash table. + (duplicate_string): Removed. + + * init.c (scm_init_guile_1): Call scm_init_extensions. + + * Makefile.am: Add "extensions.c" and related files in all the + right places. + + * extensions.h, extension.c: New files. + + * gc.h, gc.c (scm_must_strdup, scm_must_strndup): New. + * modules.h (scm_system_module_env_p): Move out of deprecated section. From 33485be9b6aafc9301c2b364cab7944199217baa Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 20 May 2001 23:37:42 +0000 Subject: [PATCH 1153/2047] (#\&): Use `issue-deprecation-warning' instead of `display'. --- ice-9/optargs.scm | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/ice-9/optargs.scm b/ice-9/optargs.scm index bf9653773..db2d7d2a4 100644 --- a/ice-9/optargs.scm +++ b/ice-9/optargs.scm @@ -180,9 +180,8 @@ ;; "#&optional" instead of "#:optional" (read-hash-extend #\& (lambda (c port) - (display - "WARNING: `#&' is deprecated, use `#:' instead\n" - (current-error-port)) + (issue-deprecation-warning + "`#&' is deprecated, use `#:' instead.") (case (read port) ((optional) #:optional) ((key) #:key) From 1990dd38aba7eb6af2481c0427dab7715401853e Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 20 May 2001 23:38:36 +0000 Subject: [PATCH 1154/2047] (SCM_EVALIM2): Use SCM_EQ_P instead of `=='. --- libguile/eval.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/eval.h b/libguile/eval.h index 80e0e5faa..2ce79fd5c 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -95,7 +95,7 @@ extern SCM scm_eval_options_interface (SCM setting); * * For an explanation of symbols containing "EVAL", see beginning of eval.c. */ -#define SCM_EVALIM2(x) (((x) == SCM_EOL) \ +#define SCM_EVALIM2(x) ((SCM_EQ_P ((x), SCM_EOL)) \ ? scm_misc_error (NULL, scm_s_expression, SCM_EOL), 0 \ : (x)) #ifdef MEMOIZE_LOCALS From c6772927b44296372cd364a61f6158d46edad84e Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 20 May 2001 23:39:55 +0000 Subject: [PATCH 1155/2047] Use SCM_EQ_P insteda of `==' or `!=' in certain places. (scm_c_improper_memq): Return q instead of SCM_BOOL_T. --- libguile/eval.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index adee9ae0b..335afd03b 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -302,7 +302,7 @@ scm_lookupcar (SCM vloc, SCM genv, int check) } #endif #ifdef USE_THREADS - if (SCM_CAR (vloc) != var) + if (!SCM_EQ_P (SCM_CAR (vloc), var)) goto race; #endif SCM_SETCAR (vloc, iloc); @@ -357,7 +357,7 @@ scm_lookupcar (SCM vloc, SCM genv, int check) #endif #ifdef USE_THREADS - if (SCM_CAR (vloc) != var) + if (!SCM_EQ_P (SCM_CAR (vloc), var)) { /* Some other thread has changed the very cell we are working on. In effect, it must have done our job or messed it up @@ -411,7 +411,7 @@ scm_unmemocar (SCM form, SCM env) { SCM sym = scm_module_reverse_lookup (scm_env_module (env), SCM_GLOC_VAR (c)); - if (sym == SCM_BOOL_F) + if (SCM_EQ_P (sym, SCM_BOOL_F)) sym = sym_three_question_marks; SCM_SETCAR (form, sym); } @@ -639,7 +639,7 @@ scm_m_cond (SCM xorig, SCM env) SCM_SYNTAX(s_lambda, "lambda", scm_makmmacro, scm_m_lambda); SCM_GLOBAL_SYMBOL(scm_sym_lambda, s_lambda); -/* Return #t if OBJ is `eq?' to one of the elements of LIST or to the +/* Return true if OBJ is `eq?' to one of the elements of LIST or to the cdr of the last cons. (Thus, LIST is not required to be a proper list and when OBJ also found in the improper ending.) */ @@ -649,7 +649,7 @@ scm_c_improper_memq (SCM obj, SCM list) for (; SCM_CONSP (list); list = SCM_CDR (list)) { if (SCM_EQ_P (SCM_CAR (list), obj)) - return SCM_BOOL_T; + return 1; } return SCM_EQ_P (list, obj); } From 311b6a3cb18be08e3cbba22bf529d7e145e8f4e4 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 20 May 2001 23:42:00 +0000 Subject: [PATCH 1156/2047] *** empty log message *** --- NEWS | 358 ++++++++++++++++++++++----------------------- ice-9/ChangeLog | 5 + libguile/ChangeLog | 7 + 3 files changed, 187 insertions(+), 183 deletions(-) diff --git a/NEWS b/NEWS index 0c5ec903f..bfb9995ea 100644 --- a/NEWS +++ b/NEWS @@ -8,7 +8,7 @@ Changes since Guile 1.4: * Changes to the distribution -** Guile now using versioning scheme similar to that of the Linux kernel. +** Guile now uses a versioning scheme similar to that of the Linux kernel. Guile now always uses three numbers to represent the version, i.e. "1.6.5". The first number, 1, is the major version number, the @@ -29,7 +29,13 @@ micro version number. In addition, ./GUILE-VERSION now defines GUILE_MICRO_VERSION. -** As per RELEASE directions, deprecated items have been removed +** Guile now actively warns about deprecated features. + +The new configure option `--enable-deprecated=LEVEL' and the +environment variable GUILE_WARN_DEPRECATED control this mechanism. +See INSTALL and README for more information. + +** Deprecated items have been removed *** Macros removed @@ -46,12 +52,6 @@ In addition, ./GUILE-VERSION now defines GUILE_MICRO_VERSION. scm_tc_dblc - replaced by scm_tc16_complex. scm_list_star - replaced by scm_cons_star. -*** scheme functions removed: - - tag - no replacement. - fseek - replaced by seek. - list* - replaced by cons*. - ** New SRFI modules have been added: SRFI-0 `cond-expand' is now supported in Guile, without requiring @@ -128,55 +128,8 @@ On systems that support it, there is also a compatibility module named (oop goops composite-slot) The Guile Object Oriented Programming System (GOOPS) has been -integrated into Guile. - -Type - - (use-modules (oop goops)) - -access GOOPS bindings. - -We're now ready to try some basic GOOPS functionality. - -Generic functions - - (define-method (+ (x ) (y )) - (string-append x y)) - - (+ 1 2) --> 3 - (+ "abc" "de") --> "abcde" - -User-defined types - - (define-class <2D-vector> () - (x #:init-value 0 #:accessor x-component #:init-keyword #:x) - (y #:init-value 0 #:accessor y-component #:init-keyword #:y)) - - (define-method write ((obj <2D-vector>) port) - (display (format #f "<~S, ~S>" (x-component obj) (y-component obj)) - port)) - - (define v (make <2D-vector> #:x 3 #:y 4)) - v --> <3, 4> - - (define-method + ((x <2D-vector>) (y <2D-vector>)) - (make <2D-vector> - #:x (+ (x-component x) (x-component y)) - #:y (+ (y-component x) (y-component y)))) - - (+ v v) --> <6, 8> - -Asking for the type of an object - - (class-of v) --> #< <2D-vector> 40241ac0> - <2D-vector> --> #< <2D-vector> 40241ac0> - (class-of 1) --> #< 401b2a98> - --> #< 401b2a98> - - (is-a? v <2D-vector>) --> #t - -See further in the GOOPS manual and tutorial in the `doc' directory, -in info (goops.info) and texinfo formats. +integrated into Guile. For further information, consult the GOOPS +manual and tutorial in the `doc' directory. ** New module (ice-9 rdelim). @@ -202,46 +155,20 @@ can be used for similar functionality. This is a subset of the (scsh rw) module from guile-scsh. Currently it defines a single procedure: -** New function: read-string!/partial str [port_or_fdes [start [end]]] +*** New function: read-string!/partial str [port_or_fdes [start [end]]] Read characters from an fport or file descriptor into a string STR. This procedure is scsh-compatible and can efficiently read - large strings. It will: - - * attempt to fill the entire string, unless the START and/or - END arguments are supplied. i.e., START defaults to 0 and - END defaults to `(string-length str)' - - * use the current input port if PORT_OR_FDES is not supplied. - - * read any characters that are currently available, without - waiting for the rest (short reads are possible). - - * wait for as long as it needs to for the first character to - become available, unless the port is in non-blocking mode - - * return `#f' if end-of-file is encountered before reading any - characters, otherwise return the number of characters read. - - * return 0 if the port is in non-blocking mode and no characters - are immediately available. - - * return 0 if the request is for 0 bytes, with no end-of-file - check + large strings. ** New module (ice-9 match) -This module includes Andrew K. Wright's pattern matcher: +This module includes Andrew K. Wright's pattern matcher. See +ice-9/match.scm for brief description or -(use-modules (ice-9 match)) + http://www.star-lab.com/wright/code.html -(match '(+ 1 2) - (('+ x) x) - (('+ x y) `(add ,x ,y)) - (('- x y) `(sub ,x ,y))) => (add 1 2) - -See ice-9/match.scm for brief description or -http://www.star-lab.com/wright/code.html for complete documentation. +for complete documentation. This module requires SLIB to be installed and available from Guile. @@ -279,21 +206,6 @@ See the README file in the `doc' directory for more details. * Changes to the stand-alone interpreter -** Evaluation of "()", the empty list, is now an error. - -Previously, you could for example write (cons 1 ()); now you need to -be more explicit and write (cons 1 '()). - -** It's now possible to create modules with controlled environments - -Example: - -(use-modules (ice-9 safe)) -(define m (make-safe-module)) -;;; m will now be a module containing only a safe subset of R5RS -(eval '(+ 1 2) m) --> 3 -(eval 'load m) --> ERROR: Unbound variable: load - ** New command line option `--use-srfi' Using this option, SRFI modules can be loaded on startup and be @@ -316,12 +228,52 @@ guile> (string-pad "bla" 20) * Changes to Scheme functions and syntax -** The empty combination is no longer valid syntax. +** Previously deprecated Scheme functions have been removed: + + tag - no replacement. + fseek - replaced by seek. + list* - replaced by cons*. + +** It's now possible to create modules with controlled environments + +Example: + +(use-modules (ice-9 safe)) +(define m (make-safe-module)) +;;; m will now be a module containing only a safe subset of R5RS +(eval '(+ 1 2) m) --> 3 +(eval 'load m) --> ERROR: Unbound variable: load + +** Evaluation of "()", the empty list, is now an error. Previously, the expression "()" evaluated to the empty list. This has been changed to signal a "missing expression" error. The correct way to write the empty list as a literal constant is to use quote: "'()". +** New concept of `Guile Extensions'. + +A Guile Extension is just a ordinary shared library that can be linked +at run-time. We found it advantageous to give this simple concept a +dedicated name to distinguish the issues related to shared libraries +from the issues related to the module system. + +*** New function: load-extension + +Executing (load-extension lib init) is mostly equivalent to + + (dynamic-call init (dynamic-link lib)) + +except when scm_register_extension has been called previously. +Whenever appropriate, you should use `load-extension' instead of +dynamic-link and dynamic-call. + +*** New C function: scm_c_register_extension + +This function registers a initialization function for use by +`load-extension'. Use it when you don't want specific extensions to +be loaded as shared libraries (for example on platforms that don't +support dynamic linking). + ** Auto-loading of compiled-code modules is deprecated. Guile used to be able to automatically find and link a shared @@ -330,10 +282,10 @@ library to satisfy requests for a module. For example, the module "foo/libbar.so" (or with a different extension) in a directory on the load path of Guile. -This has been found to be too tricky, and is no longer supported. -What you should do instead now is to write a small Scheme file that -explicitly calls `dynamic-link' to load the shared library and -`dynamic-call' to initialize it. +This has been found to be too tricky, and is no longer supported. The +shared libraries are now called "extensions". You should now write a +small Scheme file that calls `load-extension' to load the shared +library and initialize it explicitely. The shared libraries themselves should be installed in the usual places for shared libraries, with names like "libguile-foo-bar". @@ -342,20 +294,29 @@ For example, place this into a file "foo/bar.scm" (define-module (foo bar)) - (dynamic-call "foobar_init" (dynamic-link "libguile-foo-bar")) + (load-extension "libguile-foo-bar" "foobar_init") -The file name passed to `dynamic-link' should not contain an -extension. It will be provided automatically. +** Backward incompatible change: eval EXP ENVIRONMENT-SPECIFIER + +`eval' is now R5RS, that is it takes two arguments. +The second argument is an environment specifier, i.e. either + + (scheme-report-environment 5) + (null-environment 5) + (interaction-environment) + +or + + any module. ** The module system has been made more disciplined. -The function `eval' will now save and restore the current module -around the evaluation of the specified expression. While this -expression is evaluated, `(current-module)' will now return the right -module, which is the module specified as the second argument to -`eval'. +The function `eval' will save and restore the current module around +the evaluation of the specified expression. While this expression is +evaluated, `(current-module)' will now return the right module, which +is the module specified as the second argument to `eval'. -A consequence of this change is that `eval' is not particularily +A consequence of this change is that `eval' is not particularly useful when you want allow the evaluated code to change what module is designated as the current module and have this change persist from one call to `eval' to the next. The read-eval-print-loop is an example @@ -372,7 +333,7 @@ Previously, subforms of top-level forms such as `begin', `case', etc. did not respect changes to the current module although these subforms are at the top-level as well. -To prevent strange behaviour, the forms `define-module', +To prevent strange behavior, the forms `define-module', `use-modules', `use-syntax', and `export' have been restricted to only work on the top level. The forms `define-public' and `defmacro-public' only export the new binding on the top level. They @@ -424,12 +385,12 @@ objects that were guarded by it, thus undoing the side effect. Note that all this hair is hardly very important, since guardian objects are usually permanent. -** Escape procedures created by call-with-current-continuation now -accept any number of arguments, as required by R5RS. +** Continuations created by call-with-current-continuation now accept +any number of arguments, as required by R5RS. ** New function `issue-deprecation-warning' -This function is used to displaying the deprecation messages that are +This function is used to display the deprecation messages that are controlled by GUILE_WARN_DEPRECATION as explained in the README. (define (id x) @@ -473,19 +434,6 @@ Instead of #&optional, #&key, etc you should now use #:optional, The old reader syntax `#&' is still supported, but deprecated. It will be removed in the next release. -** Backward incompatible change: eval EXP ENVIRONMENT-SPECIFIER - -`eval' is now R5RS, that is it takes two arguments. -The second argument is an environment specifier, i.e. either - - (scheme-report-environment 5) - (null-environment 5) - (interaction-environment) - -or - - any module. - ** New define-module option: pure Tells the module system not to include any bindings from the root @@ -505,31 +453,15 @@ a module which doesn't import one of `define-public' or `export'. Example: -(define-module (foo) - :pure - :use-module (ice-9 r5rs) - :export (bar)) + (define-module (foo) + :pure + :use-module (ice-9 r5rs) + :export (bar)) -;;; Note that we're pure R5RS below this point! + ;;; Note that we're pure R5RS below this point! -(define (bar) - ...) - -** Deprecated: scm_make_shared_substring - -Explicit shared substrings will disappear from Guile. - -Instead, "normal" strings will be implemented using sharing -internally, combined with a copy-on-write strategy. - -** Deprecated: scm_read_only_string_p - -The concept of read-only strings will disappear in next release of -Guile. - -** Deprecated: scm_sloppy_memq, scm_sloppy_memv, scm_sloppy_member - -Instead, use scm_c_memq or scm_memq, scm_memv, scm_member. + (define (bar) + ...) ** New function: object->string OBJ @@ -546,12 +478,11 @@ Determines whether a given object is a port that is related to a file. ** New function: port-for-each proc - Apply PROC to each port in the Guile port table in turn. The - return value is unspecified. More specifically, PROC is applied - exactly once to every port that exists in the system at the time - PORT-FOR-EACH is invoked. Changes to the port table while - PORT-FOR-EACH is running have no effect as far as PORT-FOR-EACH is - concerned. +Apply PROC to each port in the Guile port table in turn. The return +value is unspecified. More specifically, PROC is applied exactly once +to every port that exists in the system at the time PORT-FOR-EACH is +invoked. Changes to the port table while PORT-FOR-EACH is running +have no effect as far as PORT-FOR-EACH is concerned. ** New function: dup2 oldfd newfd @@ -634,21 +565,23 @@ Return the argument. ** New function: inet-pton family address - Convert a printable string network address into an integer. Note - that unlike the C version of this function, the result is an - integer with normal host byte ordering. FAMILY can be `AF_INET' - or `AF_INET6'. e.g., - (inet-pton AF_INET "127.0.0.1") => 2130706433 - (inet-pton AF_INET6 "::1") => 1 +Convert a printable string network address into an integer. Note that +unlike the C version of this function, the result is an integer with +normal host byte ordering. FAMILY can be `AF_INET' or `AF_INET6'. +e.g., + + (inet-pton AF_INET "127.0.0.1") => 2130706433 + (inet-pton AF_INET6 "::1") => 1 ** New function: inet-ntop family address - Convert an integer network address into a printable string. Note - that unlike the C version of this function, the input is an - integer with normal host byte ordering. FAMILY can be `AF_INET' - or `AF_INET6'. e.g., - (inet-ntop AF_INET 2130706433) => "127.0.0.1" - (inet-ntop AF_INET6 (- (expt 2 128) 1)) => +Convert an integer network address into a printable string. Note that +unlike the C version of this function, the input is an integer with +normal host byte ordering. FAMILY can be `AF_INET' or `AF_INET6'. +e.g., + + (inet-ntop AF_INET 2130706433) => "127.0.0.1" + (inet-ntop AF_INET6 (- (expt 2 128) 1)) => ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff ** Deprecated: id @@ -661,7 +594,7 @@ Use `1-' instead. ** Deprecated: return-it -Use `noop' instead. +Do without it. ** Deprecated: string-character-length @@ -708,9 +641,28 @@ If you have old code using the old syntax, import There is no longer a distinction between builtin or other variables. Use module system operations for all variables. -* Changes to the gh_ interface +** Lazy-catch handlers are no longer allowed to return. -* Changes to the scm_ interface +That is, a call to `throw', `error', etc is now guaranteed to not +return. + +* Changes to the C interface + +** Deprecated: scm_make_shared_substring + +Explicit shared substrings will disappear from Guile. + +Instead, "normal" strings will be implemented using sharing +internally, combined with a copy-on-write strategy. + +** Deprecated: scm_read_only_string_p + +The concept of read-only strings will disappear in next release of +Guile. + +** Deprecated: scm_sloppy_memq, scm_sloppy_memv, scm_sloppy_member + +Instead, use scm_c_memq or scm_memq, scm_memv, scm_member. ** New function: scm_c_read (SCM port, void *buffer, scm_sizet size) @@ -901,10 +853,6 @@ Instead, create a fresh vector of the desired size and copy the contents. scm_gensym now only takes one argument. -** New function: scm_gentemp (SCM prefix, SCM obarray) - -The builtin `gentemp' has now become a primitive. - ** Deprecated type tags: scm_tc7_ssymbol, scm_tc7_msymbol, scm_tcs_symbols, scm_tc7_lvector @@ -948,6 +896,50 @@ Use scm_c_define or scm_c_lookup instead, as appropriate. These functions work with variables instead of with vcells. +** New functions for creating and defining `subr's and `gsubr's. + +The new functions more clearly distinguish between creating a subr (or +gsubr) object and adding it to the current module. + +These new functions are available: scm_c_make_subr, scm_c_define_subr, +scm_c_make_subr_with_generic, scm_c_define_subr_with_generic, +scm_c_make_gsubr, scm_c_define_gsubr, scm_c_make_gsubr_with_generic, +scm_c_define_gsubr_with_generic. + +** Deprecated functions: scm_make_subr, scm_make_subr_opt, + scm_make_subr_with_generic, scm_make_gsubr, + scm_make_gsubr_with_generic. + +Use the new ones from above instead. + +** C interface to the module system has changed. + +While we suggest that you avoid as many explicit module system +operations from C as possible for the time being, the C interface has +been made more similar to the high-level Scheme module system. + +*** New functions: scm_c_define_module, scm_c_use_module, + scm_c_export, scm_c_resolve_module. + +They mostly work like their Scheme namesakes. scm_c_define_module +takes a function that is called a context where the new module is +current. + +*** Deprecated functions: scm_the_root_module, scm_make_module, + scm_ensure_user_module, scm_load_scheme_module. + +Use the new functions instead. + +** Renamed function: scm_internal_with_fluids becomes + scm_c_with_fluids. + +scm_internal_with_fluids is available as a deprecated function. + +** New function: scm_c_with_fluid. + +Just like scm_c_with_fluids, but takes one fluid and one value instead +of lists of same. + Changes since Guile 1.3.4: diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 0a1a59743..ca72c29c7 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2001-05-21 Marius Vollmer + + * optargs.scm (#\&): Use `issue-deprecation-warning' instead of + `display'. + 2001-05-19 Marius Vollmer * psyntax.ss (build-lexical-var): Use gensym instead of gentemp. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index ea471ec80..2b8ced568 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2001-05-21 Marius Vollmer + + * eval.c: Use SCM_EQ_P insteda of `==' or `!=' in certain + places. (scm_c_improper_memq): Return q instead of SCM_BOOL_T. + + * eval.h (SCM_EVALIM2): Use SCM_EQ_P instead of `=='. + 2001-05-20 Marius Vollmer * symbols.c (scm_mem2symbol): Call `scm_must_strndup' instead of From a7a59ea9d02dc5e043083616f8362c05aace1ef1 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 21 May 2001 12:26:37 +0000 Subject: [PATCH 1157/2047] (scm_mem2symbol): Re-introduce indirect cell. It is needed for weak-key hashtables. --- libguile/symbols.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/libguile/symbols.c b/libguile/symbols.c index f78ece091..d46085a09 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -99,7 +99,7 @@ scm_mem2symbol (const char *name, scm_sizet len) for (l = SCM_VELTS (symbols) [hash]; !SCM_NULLP (l); l = SCM_CDR (l)) { - SCM sym = SCM_CAR (l); + SCM sym = SCM_CAAR (l); if (SCM_SYMBOL_HASH (sym) == raw_hash && SCM_SYMBOL_LENGTH (sym) == len) { @@ -124,6 +124,7 @@ scm_mem2symbol (const char *name, scm_sizet len) /* The symbol was not found - create it. */ SCM symbol; + SCM cell; SCM slot; SCM_NEWCELL2 (symbol); @@ -133,7 +134,8 @@ scm_mem2symbol (const char *name, scm_sizet len) SCM_SET_SYMBOL_LENGTH (symbol, (long) len); slot = SCM_VELTS (symbols) [hash]; - SCM_VELTS (symbols) [hash] = scm_cons (symbol, slot); + cell = scm_cons (symbol, SCM_UNDEFINED); + SCM_VELTS (symbols) [hash] = scm_cons (cell, slot); return symbol; } From aac7e260566febc0ee146661913d94c6b114885c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 21 May 2001 12:27:08 +0000 Subject: [PATCH 1158/2047] (scm_make_subr_with_generic): Add missing last argument in call to scm_c_define_gsubr_with_generic. Thanks to Ariel Rios. --- libguile/procs.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/procs.c b/libguile/procs.c index 66989d5e8..735a76c26 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -434,7 +434,7 @@ scm_make_subr_with_generic (const char *name, int type, SCM (*fcn) (), SCM *gf) ("`scm_make_subr_with_generic' is deprecated. Use " "`scm_c_define_subr_with_generic' instead."); - return scm_c_define_subr_with_generic (name, type, fcn); + return scm_c_define_subr_with_generic (name, type, fcn, gf); } #endif /* !SCM_DEBUG_DEPRECATION */ From 9dfc4faa10cc313aaaede82ab8c905899ff9ef88 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 21 May 2001 12:27:38 +0000 Subject: [PATCH 1159/2047] *** empty log message *** --- libguile/ChangeLog | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 2b8ced568..a47d9a7e4 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,7 +1,13 @@ 2001-05-21 Marius Vollmer - * eval.c: Use SCM_EQ_P insteda of `==' or `!=' in certain - places. (scm_c_improper_memq): Return q instead of SCM_BOOL_T. + * symbols.c (scm_mem2symbol): Re-introduce indirect cell. It is + needed for weak-key hashtables. + + * procs.c (scm_make_subr_with_generic): Add missing last argument + in call to scm_c_define_gsubr_with_generic. Thanks to Ariel Rios. + + * eval.c: Use SCM_EQ_P instead of `==' or `!=' in certain + places. (scm_c_improper_memq): Return 1 instead of SCM_BOOL_T. * eval.h (SCM_EVALIM2): Use SCM_EQ_P instead of `=='. From eee58958bb4dc0216ed4b06c2143e082df7a9d8e Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 21 May 2001 13:19:40 +0000 Subject: [PATCH 1160/2047] (use-syntax): Do not set scm:eval-transformer when deprecated features have been removed. Thanks to Dale P. Smith! --- ice-9/boot-9.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 1eb6a7e76..49fa04dfe 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -2627,7 +2627,8 @@ (set-module-transformer! (current-module) ,(car (last-pair spec)))) `((set-module-transformer! (current-module) ,spec))) - (fluid-set! scm:eval-transformer (module-transformer (current-module)))) + (begin-deprecated + (fluid-set! scm:eval-transformer (module-transformer (current-module))))) (else (error "use-syntax can only be used at the top level")))) From e6c9e4973849a674b818c09a906edb14a74ac2b5 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 21 May 2001 13:21:01 +0000 Subject: [PATCH 1161/2047] Moved deprecated C stuff to C section. --- NEWS | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/NEWS b/NEWS index bfb9995ea..395da23df 100644 --- a/NEWS +++ b/NEWS @@ -35,23 +35,6 @@ The new configure option `--enable-deprecated=LEVEL' and the environment variable GUILE_WARN_DEPRECATED control this mechanism. See INSTALL and README for more information. -** Deprecated items have been removed - -*** Macros removed - - SCM_INPORTP, SCM_OUTPORTP SCM_ICHRP, SCM_ICHR, SCM_MAKICHR - SCM_SETJMPBUF SCM_NSTRINGP SCM_NRWSTRINGP SCM_NVECTORP SCM_DOUBLE_CELLP - -*** C Functions removed - - scm_sysmissing scm_tag scm_tc16_flo scm_tc_flo - scm_fseek - replaced by scm_seek. - gc-thunk - replaced by after-gc-hook. - gh_int2scmb - replaced by gh_bool2scm. - scm_tc_dblr - replaced by scm_tc16_real. - scm_tc_dblc - replaced by scm_tc16_complex. - scm_list_star - replaced by scm_cons_star. - ** New SRFI modules have been added: SRFI-0 `cond-expand' is now supported in Guile, without requiring @@ -648,6 +631,23 @@ return. * Changes to the C interface +** Deprecated feature have been removed. + +*** Macros removed + + SCM_INPORTP, SCM_OUTPORTP SCM_ICHRP, SCM_ICHR, SCM_MAKICHR + SCM_SETJMPBUF SCM_NSTRINGP SCM_NRWSTRINGP SCM_NVECTORP SCM_DOUBLE_CELLP + +*** C Functions removed + + scm_sysmissing scm_tag scm_tc16_flo scm_tc_flo + scm_fseek - replaced by scm_seek. + gc-thunk - replaced by after-gc-hook. + gh_int2scmb - replaced by gh_bool2scm. + scm_tc_dblr - replaced by scm_tc16_real. + scm_tc_dblc - replaced by scm_tc16_complex. + scm_list_star - replaced by scm_cons_star. + ** Deprecated: scm_make_shared_substring Explicit shared substrings will disappear from Guile. From 2a63747af8151805e1fcae2eb9442a182a157246 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 21 May 2001 13:21:45 +0000 Subject: [PATCH 1162/2047] More details for the removal of scm:eval-transformer and scm_top_level_lookup_closure_var. --- RELEASE | 3 +++ 1 file changed, 3 insertions(+) diff --git a/RELEASE b/RELEASE index c234462cc..8bbe5df04 100644 --- a/RELEASE +++ b/RELEASE @@ -51,6 +51,9 @@ After signal handling and threading have been fixed: - remove deprecated variables: scm_top_level_lookup_closure_var scm_scm_system_transformer + Remove all code that still sets them: + `use-syntax', scm_set_current_module, ... + - remove deprecated functions: eval.c: scm_eval2, scm_eval_3 load.c: scm_read_and_eval_x From 4ed29c73dda18fcd15372abe9bc2acd1da2403dd Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 21 May 2001 13:22:18 +0000 Subject: [PATCH 1163/2047] New, minimal tests. --- test-suite/tests/goops.test | 29 +++++++++++++++++++++++++++++ test-suite/tests/syncase.test | 30 ++++++++++++++++++++++++++++++ 2 files changed, 59 insertions(+) create mode 100644 test-suite/tests/goops.test create mode 100644 test-suite/tests/syncase.test diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test new file mode 100644 index 000000000..c5d5984d2 --- /dev/null +++ b/test-suite/tests/goops.test @@ -0,0 +1,29 @@ +;;;; goops.test --- test suite for GOOPS -*- scheme -*- +;;;; +;;;; Copyright (C) 2001 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +(use-modules (test-suite lib)) + +(pass-if "GOOPS loads" + (false-if-exception + (begin (resolve-module '(oop goops)) + #t))) + +(use-modules (oop goops)) + +;;; more tests here... diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test new file mode 100644 index 000000000..1a389a549 --- /dev/null +++ b/test-suite/tests/syncase.test @@ -0,0 +1,30 @@ +;;;; syncase.test --- test suite for (ice-9 syncase) -*- scheme -*- +;;;; +;;;; Copyright (C) 2001 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +;; These tests are in a module so that the syntax transformer does not +;; affect code outside of this file. +;; +(define-module (syncase-test)) + +(use-modules (test-suite lib)) + +(pass-if "(ice-9 syncase) loads" + (false-if-exception + (begin (eval '(use-syntax (ice-9 syncase)) (current-module)) + #t))) From bab34d2a6fe77cebebcff11fd71f5c66197ac720 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 21 May 2001 13:22:44 +0000 Subject: [PATCH 1164/2047] *** empty log message *** --- ice-9/ChangeLog | 3 +++ test-suite/ChangeLog | 4 ++++ 2 files changed, 7 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index ca72c29c7..d1d419ab8 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,5 +1,8 @@ 2001-05-21 Marius Vollmer + * boot-9.scm (use-syntax): Do not set scm:eval-transformer when + deprecated features have been removed. Thanks to Dale P. Smith! + * optargs.scm (#\&): Use `issue-deprecation-warning' instead of `display'. diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 2a94f203c..a1afa6d36 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2001-05-21 Marius Vollmer + + * test/goops.test, test/syncase.test: New, minimal tests. + 2001-05-19 Marius Vollmer * tests/version.test: Updated test for new micro version stuff. From 25afac9812f69fc0a55da07c0115978b480333d8 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 22 May 2001 22:45:13 +0000 Subject: [PATCH 1165/2047] (define-module): Return the new module. (process-define-module): Use `spec' instead of `module-name' when getting the syntax transformer. --- ice-9/boot-9.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 49fa04dfe..cf38dcaed 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1701,7 +1701,7 @@ spec)) (set-module-transformer! module - (module-ref interface (car (last-pair module-name)) + (module-ref interface (car (last-pair spec)) #f))) (loop (cddr kws) (cons interface reversed-interfaces) @@ -2598,7 +2598,9 @@ (defmacro define-module args `(eval-case ((load-toplevel) - (set-current-module (process-define-module ',args))) + (let ((m (process-define-module ',args))) + (set-current-module m) + m)) (else (error "define-module can only be used at the top level")))) From a0f3e7475266b932b9a5128042da8d0909f85692 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 22 May 2001 22:46:14 +0000 Subject: [PATCH 1166/2047] (SCM_CONST_LONG): Use SCM_VCELL_INIT instead of SCM_VARIABLE_INIT since that it what it used to be. --- libguile/snarf.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/snarf.h b/libguile/snarf.h index ea1926632..ac7a59baa 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -191,7 +191,7 @@ SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, init_va #if (SCM_DEBUG_DEPRECATED == 0) #define SCM_CONST_LONG(c_name, scheme_name,value) \ -SCM_VARIABLE_INIT(c_name, scheme_name, scm_long2num(value)) +SCM_VCELL_INIT(c_name, scheme_name, scm_long2num(value)) #define SCM_VCELL(c_name, scheme_name) \ SCM_SNARF_HERE(static SCM c_name) \ From 7bad99fd986df882d3aaa63668511021c040e252 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 22 May 2001 22:46:39 +0000 Subject: [PATCH 1167/2047] (scm_include_deprecated_features): Make docstring ANSIsh. --- libguile/deprecation.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/deprecation.c b/libguile/deprecation.c index 87f516476..aad7bc09c 100644 --- a/libguile/deprecation.c +++ b/libguile/deprecation.c @@ -116,8 +116,8 @@ print_deprecation_summary (void) SCM_DEFINE(scm_include_deprecated_features, "include-deprecated-features", 0, 0, 0, (), - "Return @code{#t} iff deprecated features should be included - in public interfaces.") + "Return @code{#t} iff deprecated features should be included " + "in public interfaces.") #define FUNC_NAME s_scm_include_deprecated_features { #if SCM_DEBUG_DEPRECATED == 0 From a6219f222cb212340a01061ffb18908e5687cca6 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 22 May 2001 22:47:02 +0000 Subject: [PATCH 1168/2047] *** empty log message *** --- ice-9/ChangeLog | 6 ++++++ libguile/ChangeLog | 8 ++++++++ 2 files changed, 14 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index d1d419ab8..39ad3c82f 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,9 @@ +2001-05-22 Marius Vollmer + + * boot-9.scm (define-module): Return the new module. + (process-define-module): Use `spec' instead of `module-name' when + getting the syntax transformer. Thanks to Matthias Köppe! + 2001-05-21 Marius Vollmer * boot-9.scm (use-syntax): Do not set scm:eval-transformer when diff --git a/libguile/ChangeLog b/libguile/ChangeLog index a47d9a7e4..54089721f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2001-05-23 Marius Vollmer + + * snarf.h (SCM_CONST_LONG): Use SCM_VCELL_INIT instead of + SCM_VARIABLE_INIT since that it what it used to be. + + * deprecation.c (scm_include_deprecated_features): Make docstring + ANSIsh. Thanks to Matthias Köppe! + 2001-05-21 Marius Vollmer * symbols.c (scm_mem2symbol): Re-introduce indirect cell. It is From d579d1652d5c334f83096e36e62763a5c5d7141e Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Tue, 22 May 2001 23:26:36 +0000 Subject: [PATCH 1169/2047] *** empty log message *** --- doc/ChangeLog | 5 +++++ srfi/ChangeLog | 4 ++++ 2 files changed, 9 insertions(+) diff --git a/doc/ChangeLog b/doc/ChangeLog index d11246258..cff21ad5c 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -6,6 +6,11 @@ * scheme-control.texi (Lazy Catch): Update doc for new constraint that lazy-catch handlers are not allowed to return. +2001-05-16 Rob Browning + + * scheme-options.texi (Install Config): fixed minor-version docs + and added micro-version docs. + 2001-05-16 Neil Jerram * data-rep.texi, srfi-modules.texi (SRFI-14 Iterating Over diff --git a/srfi/ChangeLog b/srfi/ChangeLog index be1ea2aed..635e03ef9 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -16,6 +16,10 @@ * srfi-14.scm: Call "scm_init_srfi_14" instead of "scm_init_srfi_13_14". +2001-05-16 Rob Browning + + * srfi-19.scm (priv:integer-reader-exact): minor cleanups. + 2001-05-14 Martin Grabmueller * Makefile.am (srfi_DATA): Added srfi-16.scm. From 1b2f40b9f1b5950f014ad44943e081fc8b004970 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 23 May 2001 05:04:55 +0000 Subject: [PATCH 1170/2047] * README: Update, document available SRFIs. * srfi-19.scm, srfi-17.scm, srfi-16.scm, srfi-14.scm, srfi-13.scm, srfi-11.scm, srfi-10.scm, srfi-9.scm, srfi-8.scm, srfi-6.scm, srfi-2.scm: Use `cond-expand-provide' for providing features to `cond-expand'. --- srfi/ChangeLog | 11 ++++ srfi/README | 167 ++++++++++++++--------------------------------- srfi/srfi-10.scm | 2 + srfi/srfi-11.scm | 2 + srfi/srfi-13.scm | 3 + srfi/srfi-14.scm | 2 + srfi/srfi-16.scm | 2 + srfi/srfi-17.scm | 2 + srfi/srfi-19.scm | 2 + srfi/srfi-2.scm | 2 + srfi/srfi-6.scm | 2 + srfi/srfi-8.scm | 2 + srfi/srfi-9.scm | 2 + 13 files changed, 84 insertions(+), 117 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 635e03ef9..913f3a7b1 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,14 @@ +2001-05-22 Martin Grabmueller + + * README: Update, document available SRFIs. + +2001-05-21 Martin Grabmueller + + * srfi-19.scm, srfi-17.scm, srfi-16.scm, srfi-14.scm, srfi-13.scm, + srfi-11.scm, srfi-10.scm, srfi-9.scm, srfi-8.scm, srfi-6.scm, + srfi-2.scm: Use `cond-expand-provide' for providing features to + `cond-expand'. + 2001-05-20 Marius Vollmer * srfi-14.c (scm_c_init_srfi_14): Added "int" to declaration of diff --git a/srfi/README b/srfi/README index 6dca759b2..bfe1af158 100644 --- a/srfi/README +++ b/srfi/README @@ -1,141 +1,74 @@ -This is the integration of guile-srfi into the core. -*- text -*- +This directory includes most of Guile's SRFI support. -*- text -*- -[ this is the README from guile-srfi 0.0.3, slightly modified for the - integration into the Guile core +For more details about what SRFI means, and what the various numbers +stand for, please refer to the SRFI homepage at - 'martin -- 2001-04-23 ] + http://srfi.schemers.org -This is a compiled Guile module that provides the string procedures -defined in SRFI-13 (string library), and the character set procedures -defined in SRFI-14 (character-set library). +The following SRFIs are supported (as of 2001-05-22 -- 'martin): -Getting Started ====================================================== +SRFI-0: cond-expand -1. Type + Supported by default, no module needs to get used. - guile +SRFI-2: and-let* - You should now be at the Guile prompt ("guile> "). + (use-modules (srfi srfi-2)) to make and-let* available. -2. Type +SRFI-6: open-input-string, open-output-string and get-output-string - (use-modules (srfi srfi-13)) + (use-modules (srfi srfi-6)) to make these available. (Currently, + these procedures are available without using the module, but the + procedures might be factored out of the core library in the + future.) - so that the srfi-13 module gets loaded. +SRFI-8: receive -3. We're now ready to try some basic srfi-13/14 functionality. + (use-modules (srfi srfi-8)) to make receive available. - $ guile - guile> (use-modules (srfi srfi-13)) - guile> (string-concatenate '("Hello" " " "World")) - "Hello World" - guile> +SRFI-9: define-record-type - Check out the SRFI-14 (character-set library) procedures, too: + A mechanism for defining record types. (use-modules (srfi srfi-9)) + makes this syntactic form available. - $ guile - guile> (use-modules (srfi srfi-14)) - guile> (char-set-union (char-set #\f #\o #\o) (string->char-set "bar")) - # - guile> +SRFI-10: #,() -What Is Included ===================================================== + The hash-comma reader extension. (use-modules (srfi srfi-10)) + activates the extension. - All SRFI-13 procedures which are not already compatibly defined in - the Guile core are implemented. These are: +SRFI-11: let-values and let-values* - string-any string-every - string-tabulate - string->list - reverse-list->string - string-join - string-copy - substring/shared string-copy! - string-take string-take-right - string-drop string-drop-right - string-pad string-pad-right - string-trim string-trim-right string-trim-both - string-fill! - string-compare string-compare-ci - string= string<> - string< string> - string<= string>= - string-ci= string-ci<> - string-ci< string-ci> - string-ci<= string-ci>= - string-hash string-hash-ci - string-prefix-length string-prefix-length-ci - string-suffix-length string-suffix-length-ci - string-prefix? string-prefix-ci? - string-suffix? string-suffix-ci? - string-index string-index-right - string-skip string-skip-right - string-count - string-contains string-contains-ci - string-upcase string-upcase! - string-downcase string-downcase! - string-titlecase string-titlecase! - string-reverse string-reverse! - string-append/shared - string-concatenate - reverse-string-concatenate - string-concatenate/shared - reverse-string-concatenate/shared - string-map string-map! - string-fold string-fold-right - string-unfold string-unfold-right - string-for-each - xsubstring string-xcopy! - string-replace string-tokenize - string-filter string-delete + Syntactic extensions for handling multiple values. (use-modules + (srfi srfi-11)) makes these syntactic forms available. +SRFI-13: string library - All procedures and variables defined in SRFI-14 are implemented. - Thes complete list is: + A lot of (more or less) useful string processing procedures. + (use-modules (srfi srfi-13)) loads the procedures. - char-set? char-set= char-set<= - char-set-hash - char-set-fold char-set-unfold char-set-unfold! - char-set-for-each char-set-map - char-set-copy - char-set - list->char-set list->char-set! - string->char-set string-char-set! - predicate->char-set predicate->char-set! - ucs-range->char-set ucs-range->char-set! - ->char-set ->char-set! - char-set-size char-set-count - char-set-members char-set-contains? - char-set-every char-set-any - char-set-adjoin char-set-adjoin! - char-set-delete char-set-delete! - char-set-invert char-set-invert! - char-set-union char-set-union! - char-set-intersection char-set-intersection! - char-set-difference char-set-difference! - char-set-xor char-set-xor! - char-set-diff+intersection char-set-diff+intersection! - char-set:lower-case char-set:upper-case - char-set:title-case char-set:letter - char-set:digit char-set:letter+digit - char-set:graphic char-set:printing - char-set:whitespace char-set:iso-control - char-set:punctuation char-set:symbol - char-set:hex-digit char-set:blank - char-set:ascii char-set:empty - char-set:full +SRFI-14: character-set library + Character-set library. (use-modules (srfi srfi-14)) loads the + procedures and standard variables. -What Is Not Included ================================================= +SRFI-16: case-lambda - The following low-level procedures and syntax defined in SRFI-13 - are currently not supported. + Syntactic form which permits writing functions acting different + according to the number of arguments passed. (use-modules (srfi + srfi-16)) makes this syntactic form available. - string-parse-start+end - string-parse-final-start+end - let-string-start+end - check-substring-spec - substring-spec-ok? - make-kmp-restart-vector - kmp-step - string-search-kmp +SRFI-17: Generalized set! + + Guile supports generalized set! by default, but this module makes it + fully compliant to the SRFI. (use-modules (srfi srfi-17)) loads the + procedures. + +SRFI-19: Time Data Types and Procedures + + A lot of data types and procedures for dealing with times and + dates. (use-modules (srfi srfi-19)) loads the procedures. + +SRFI-23: Error reporting mechanism (draft) + + This SRFI is still in draft status, but Guile fully supports it + already. No need to load any module. diff --git a/srfi/srfi-10.scm b/srfi/srfi-10.scm index 8efef2693..5aa8b04a8 100644 --- a/srfi/srfi-10.scm +++ b/srfi/srfi-10.scm @@ -49,6 +49,8 @@ (export define-reader-ctor) +(cond-expand-provide (current-module) '(srfi-10)) + ;; This hash table stores the association between comma-hash tags and ;; the corresponding constructor procedures. ;; diff --git a/srfi/srfi-11.scm b/srfi/srfi-11.scm index 0caebab05..032e5daf6 100644 --- a/srfi/srfi-11.scm +++ b/srfi/srfi-11.scm @@ -20,6 +20,8 @@ (define-module (srfi srfi-11) :use-module (ice-9 syncase)) +(cond-expand-provide (current-module) '(srfi-11)) + ;;;;;;;;;;;;;; ;; let-values ;; diff --git a/srfi/srfi-13.scm b/srfi/srfi-13.scm index 612518105..76fcc6d06 100644 --- a/srfi/srfi-13.scm +++ b/srfi/srfi-13.scm @@ -110,6 +110,8 @@ string-delete ) +(cond-expand-provide (current-module) '(srfi-13)) + (dynamic-call "scm_init_srfi_13" (dynamic-link "libguile-srfi-srfi-13-14")) (define string-hash @@ -139,3 +141,4 @@ (caddr rest) (string-length s)))) (hash (string-upcase (substring/shared s start end)) bound)))) + diff --git a/srfi/srfi-14.scm b/srfi/srfi-14.scm index b947b9187..1cea4e079 100644 --- a/srfi/srfi-14.scm +++ b/srfi/srfi-14.scm @@ -90,6 +90,8 @@ char-set:full ) +(cond-expand-provide (current-module) '(srfi-14)) + (dynamic-call "scm_init_srfi_14" (dynamic-link "libguile-srfi-srfi-13-14")) (define (->char-set x) diff --git a/srfi/srfi-16.scm b/srfi/srfi-16.scm index 011bcdb46..1746657cf 100644 --- a/srfi/srfi-16.scm +++ b/srfi/srfi-16.scm @@ -49,6 +49,8 @@ (export-syntax case-lambda) +(cond-expand-provide (current-module) '(srfi-16)) + (define-macro (case-lambda . clauses) ;; Return the length of the list @var{l}, but allow dotted list. diff --git a/srfi/srfi-17.scm b/srfi/srfi-17.scm index 1a82ea09d..fda6fb9ae 100644 --- a/srfi/srfi-17.scm +++ b/srfi/srfi-17.scm @@ -49,6 +49,8 @@ caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr string-ref vector-ref)) +(cond-expand-provide (current-module) '(srfi-17)) + ;;; Procedures (define getter-with-setter make-procedure-with-setter) diff --git a/srfi/srfi-19.scm b/srfi/srfi-19.scm index 00d5837d6..3b65a69e1 100644 --- a/srfi/srfi-19.scm +++ b/srfi/srfi-19.scm @@ -119,6 +119,8 @@ date->string string->date)) +(cond-expand-provide (current-module) '(srfi-19)) + ;; :OPTIONAL is nice (define-syntax :optional diff --git a/srfi/srfi-2.scm b/srfi/srfi-2.scm index aaedf97fa..4ffb49c6f 100644 --- a/srfi/srfi-2.scm +++ b/srfi/srfi-2.scm @@ -21,3 +21,5 @@ :use-module (ice-9 and-let-star)) (export-syntax and-let*) + +(cond-expand-provide (current-module) '(srfi-2)) diff --git a/srfi/srfi-6.scm b/srfi/srfi-6.scm index 97e54cb22..41aeeb362 100644 --- a/srfi/srfi-6.scm +++ b/srfi/srfi-6.scm @@ -21,3 +21,5 @@ ;; Currently, guile provides these functions by default, so no action ;; is needed, and this file is just a placeholder. + +(cond-expand-provide (current-module) '(srfi-6)) diff --git a/srfi/srfi-8.scm b/srfi/srfi-8.scm index e9e97a217..5971d1696 100644 --- a/srfi/srfi-8.scm +++ b/srfi/srfi-8.scm @@ -21,3 +21,5 @@ :use-module (ice-9 receive)) (export-syntax receive) + +(cond-expand-provide (current-module) '(srfi-8)) diff --git a/srfi/srfi-9.scm b/srfi/srfi-9.scm index 7d2468892..0df0fee6d 100644 --- a/srfi/srfi-9.scm +++ b/srfi/srfi-9.scm @@ -63,6 +63,8 @@ (export-syntax define-record-type) +(cond-expand-provide (current-module) '(srfi-9)) + (define-macro (define-record-type type-name constructor/field-tag predicate-name . field-specs) `(begin From b9b8f9da6020bbb18a0478d980ed8b291f6ee168 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 23 May 2001 05:08:17 +0000 Subject: [PATCH 1171/2047] * boot-9.scm (%cond-expand-table): New hash table mapping modules to feature lists. (cond-expand): Use feature information associated with modules. * boot-9.scm (use-srfis): Do not extend the srfi-0 feature list. (cond-expand-provide): New procedure. --- ice-9/ChangeLog | 11 +++++++++++ ice-9/boot-9.scm | 26 ++++++++++++++++++++++---- 2 files changed, 33 insertions(+), 4 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 39ad3c82f..fda2e46f7 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,14 @@ +2001-05-23 Martin Grabmueller + + * boot-9.scm (%cond-expand-table): New hash table mapping modules + to feature lists. + (cond-expand): Use feature information associated with modules. + +2001-05-21 Martin Grabmueller + + * boot-9.scm (use-srfis): Do not extend the srfi-0 feature list. + (cond-expand-provide): New procedure. + 2001-05-22 Marius Vollmer * boot-9.scm (define-module): Return the new module. diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index cf38dcaed..884b7f3c3 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -2723,10 +2723,24 @@ ;;; ;;; Remember to update the features list when adding more SRFIs. -(define cond-expand-features +(define %cond-expand-features ;; Adjust the above comment when changing this. '(guile r5rs srfi-0)) +;; This table maps module public interfaces to the list of features. +;; +(define %cond-expand-table (make-hash-table 31)) + +;; Add one or more features to the `cond-expand' feature list of the +;; module `module'. +;; +(define (cond-expand-provide module features) + (let ((mod (module-public-interface module))) + (and mod + (hashq-set! %cond-expand-table mod + (append (hashq-ref %cond-expand-table mod '()) + features))))) + (define-macro (cond-expand clause . clauses) (let ((clauses (cons clause clauses)) @@ -2737,7 +2751,13 @@ (lambda (clause) (cond ((symbol? clause) - (memq clause cond-expand-features)) + (or (memq clause %cond-expand-features) + (let lp ((uses (module-uses (current-module)))) + (if (pair? uses) + (or (memq clause + (hashq-ref %cond-expand-table (car uses) '())) + (lp (cdr uses))) + #f)))) ((pair? clause) (cond ((eq? 'and (car clause)) @@ -2793,8 +2813,6 @@ (string-append "srfi-" (number->string (car s))))) (mod-i (resolve-interface (list 'srfi srfi)))) (module-use! (current-module) mod-i) - (set! cond-expand-features - (append cond-expand-features (list srfi))) (lp (cdr s)))))) From b9309d16650b30700198deec40d792354e765a8b Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Wed, 23 May 2001 15:24:41 +0000 Subject: [PATCH 1172/2047] * srfi-19.scm (:optional): renamed to optional to avoid reader keywords conflict. Thanks to Matthias Koeppe for the report. --- srfi/ChangeLog | 5 +++++ srfi/srfi-19.scm | 22 +++++++++++----------- 2 files changed, 16 insertions(+), 11 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 913f3a7b1..0eaaa71a2 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,8 @@ +2001-05-23 Rob Browning + + * srfi-19.scm (:optional): renamed to optional to avoid reader + keywords conflict. Thanks to Matthias Koeppe for the report. + 2001-05-22 Martin Grabmueller * README: Update, document available SRFIs. diff --git a/srfi/srfi-19.scm b/srfi/srfi-19.scm index 3b65a69e1..ee51aee1a 100644 --- a/srfi/srfi-19.scm +++ b/srfi/srfi-19.scm @@ -121,9 +121,9 @@ (cond-expand-provide (current-module) '(srfi-19)) -;; :OPTIONAL is nice +;; OPTIONAL is nice -(define-syntax :optional +(define-syntax optional (syntax-rules () ((_ val default-value) (if (null? val) default-value (car val))))) @@ -386,7 +386,7 @@ ;; (priv:current-time-ms-time time-gc current-gc-milliseconds)) (define (current-time . clock-type) - (let ((clock-type (:optional clock-type time-utc))) + (let ((clock-type (optional clock-type time-utc))) (cond ((eq? clock-type time-tai) (priv:current-time-tai)) ((eq? clock-type time-utc) (priv:current-time-utc)) @@ -401,7 +401,7 @@ ;; This will be implementation specific. (define (time-resolution . clock-type) - (let ((clock-type (:optional clock-type time-utc))) + (let ((clock-type (optional clock-type time-utc))) (case clock-type ((time-tai) 1000) ((time-utc) 1000) @@ -642,7 +642,7 @@ (define (time-utc->date time . tz-offset) (if (not (eq? (time-type time) time-utc)) (priv:time-error 'time->date 'incompatible-time-types time)) - (let* ((offset (:optional tz-offset (priv:local-tz-offset))) + (let* ((offset (optional tz-offset (priv:local-tz-offset))) (leap-second? (priv:leap-second? (+ offset (time-second time)))) (jdn (priv:time->julian-day-number (if leap-second? (- (time-second time) 1) @@ -667,7 +667,7 @@ (define (time-tai->date time . tz-offset) (if (not (eq? (time-type time) time-tai)) (priv:time-error 'time->date 'incompatible-time-types time)) - (let* ((offset (:optional tz-offset (priv:local-tz-offset))) + (let* ((offset (optional tz-offset (priv:local-tz-offset))) (seconds (- (time-second time) (priv:leap-second-delta (time-second time)))) (leap-second? (priv:leap-second? (+ offset seconds))) @@ -695,7 +695,7 @@ (define (time-monotonic->date time . tz-offset) (if (not (eq? (time-type time) time-monotonic)) (priv:time-error 'time->date 'incompatible-time-types time)) - (let* ((offset (:optional tz-offset (priv:local-tz-offset))) + (let* ((offset (optional tz-offset (priv:local-tz-offset))) (seconds (- (time-second time) (priv:leap-second-delta (time-second time)))) (leap-second? (priv:leap-second? (+ offset seconds))) @@ -793,7 +793,7 @@ (define (current-date . tz-offset) (time-utc->date (current-time time-utc) - (:optional tz-offset (priv:local-tz-offset)))) + (optional tz-offset (priv:local-tz-offset)))) ;; given a 'two digit' number, find the year within 50 years +/- (define (priv:natural-year n) @@ -878,11 +878,11 @@ (time-utc->time-monotonic! (julian-day->time-utc jdn))) (define (julian-day->date jdn . tz-offset) - (let ((offset (:optional tz-offset (priv:local-tz-offset)))) + (let ((offset (optional tz-offset (priv:local-tz-offset)))) (time-utc->date (julian-day->time-utc jdn) offset))) (define (modified-julian-day->date jdn . tz-offset) - (let ((offset (:optional tz-offset (priv:local-tz-offset)))) + (let ((offset (optional tz-offset (priv:local-tz-offset)))) (julian-day->date (+ jdn 4800001/2) offset))) (define (modified-julian-day->time-utc jdn) @@ -1209,7 +1209,7 @@ (define (date->string date . format-string) (let ((str-port (open-output-string)) - (fmt-str (:optional format-string "~c"))) + (fmt-str (optional format-string "~c"))) (priv:date-printer date 0 fmt-str (string-length fmt-str) str-port) (get-output-string str-port))) From 5e1fb41f97dd7e6dba57d7e3646196acafcd8cee Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Wed, 23 May 2001 17:00:22 +0000 Subject: [PATCH 1173/2047] * srfi-19.scm (:optional): renamed to optional to avoid reader keywords conflict. Time passes... Removed :optional altogether and just handle optional args directly. Thanks to Matthias Koeppe for the report of this and the two bits below. (priv:decode-julian-day-number): add inexact->exact for truncate result. (time-utc->date): add inexact->exact and floor so quotient will work. --- srfi/srfi-19.scm | 69 ++++++++++++++++++++++++++++++------------------ 1 file changed, 44 insertions(+), 25 deletions(-) diff --git a/srfi/srfi-19.scm b/srfi/srfi-19.scm index ee51aee1a..8a398e3ad 100644 --- a/srfi/srfi-19.scm +++ b/srfi/srfi-19.scm @@ -27,7 +27,6 @@ ;; functions that do more work in a "chunk". (define-module (srfi srfi-19) - :use-module (ice-9 syncase) :use-module (srfi srfi-6) :use-module (srfi srfi-8) :use-module (srfi srfi-9) @@ -121,13 +120,6 @@ (cond-expand-provide (current-module) '(srfi-19)) -;; OPTIONAL is nice - -(define-syntax optional - (syntax-rules () - ((_ val default-value) - (if (null? val) default-value (car val))))) - (define time-tai 'time-tai) (define time-utc 'time-utc) (define time-monotonic 'time-monotonic) @@ -386,7 +378,7 @@ ;; (priv:current-time-ms-time time-gc current-gc-milliseconds)) (define (current-time . clock-type) - (let ((clock-type (optional clock-type time-utc))) + (let ((clock-type (if (null? clock-type) time-utc (car clock-type)))) (cond ((eq? clock-type time-tai) (priv:current-time-tai)) ((eq? clock-type time-utc) (priv:current-time-utc)) @@ -401,7 +393,7 @@ ;; This will be implementation specific. (define (time-resolution . clock-type) - (let ((clock-type (optional clock-type time-utc))) + (let ((clock-type (if (null? clock-type) time-utc (car clock-type)))) (case clock-type ((time-tai) 1000) ((time-utc) 1000) @@ -573,11 +565,14 @@ ;; -- Date Structures +;; FIXME: to be really safe, perhaps we should normalize the +;; seconds/nanoseconds/minutes coming in to make-date... + (define-record-type date - (make-date-unnormalized nanosecond second minute - hour day month - year - zone-offset) + (make-date nanosecond second minute + hour day month + year + zone-offset) date? (nanosecond date-nanosecond) (second date-second) @@ -588,6 +583,28 @@ (year date-year) (zone-offset date-zone-offset)) +(define (priv:time-normalize! t) + (if (>= (abs (time-nanosecond t)) 1000000000) + (begin + (set-time-second! t (+ (time-second t) + (quotient (time-nanosecond t) 1000000000))) + (set-time-nanosecond! t (remainder (time-nanosecond t) + 1000000000)))) + (if (and (positive? (time-second t)) + (negative? (time-nanosecond t))) + (begin + (set-time-second! t (- (time-second t) 1)) + (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t)))) + (if (and (negative? (time-second t)) + (positive? (time-nanosecond t))) + (begin + (set-time-second! t (+ (time-second t) 1)) + (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t)))))) + t) + + + ( + ;; gives the julian day which starts at noon. (define (priv:encode-julian-day-number day month year) (let* ((a (quotient (- 14 month) 12)) @@ -608,7 +625,7 @@ ;; gives the seconds/date/month/year (define (priv:decode-julian-day-number jdn) - (let* ((days (truncate jdn)) + (let* ((days (inexact->exact (truncate jdn))) (a (+ days 32044)) (b (quotient (+ (* 4 a) 3) 146097)) (c (- a (quotient (* 146097 b) 4))) @@ -642,7 +659,7 @@ (define (time-utc->date time . tz-offset) (if (not (eq? (time-type time) time-utc)) (priv:time-error 'time->date 'incompatible-time-types time)) - (let* ((offset (optional tz-offset (priv:local-tz-offset))) + (let* ((offset (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset))) (leap-second? (priv:leap-second? (+ offset (time-second time)))) (jdn (priv:time->julian-day-number (if leap-second? (- (time-second time) 1) @@ -651,8 +668,9 @@ (call-with-values (lambda () (priv:decode-julian-day-number jdn)) (lambda (secs date month year) - (let* ((hours (quotient secs (* 60 60))) - (rem (remainder secs (* 60 60))) + (let* ((int-secs (inexact->exact (floor secs))) + (hours (quotient int-secs (* 60 60))) + (rem (remainder int-secs (* 60 60))) (minutes (quotient rem 60)) (seconds (remainder rem 60))) (make-date (time-nanosecond time) @@ -667,7 +685,7 @@ (define (time-tai->date time . tz-offset) (if (not (eq? (time-type time) time-tai)) (priv:time-error 'time->date 'incompatible-time-types time)) - (let* ((offset (optional tz-offset (priv:local-tz-offset))) + (let* ((offset (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset))) (seconds (- (time-second time) (priv:leap-second-delta (time-second time)))) (leap-second? (priv:leap-second? (+ offset seconds))) @@ -695,7 +713,7 @@ (define (time-monotonic->date time . tz-offset) (if (not (eq? (time-type time) time-monotonic)) (priv:time-error 'time->date 'incompatible-time-types time)) - (let* ((offset (optional tz-offset (priv:local-tz-offset))) + (let* ((offset (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset))) (seconds (- (time-second time) (priv:leap-second-delta (time-second time)))) (leap-second? (priv:leap-second? (+ offset seconds))) @@ -792,8 +810,9 @@ 7)) (define (current-date . tz-offset) - (time-utc->date (current-time time-utc) - (optional tz-offset (priv:local-tz-offset)))) + (time-utc->date + (current-time time-utc) + (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset)))) ;; given a 'two digit' number, find the year within 50 years +/- (define (priv:natural-year n) @@ -878,11 +897,11 @@ (time-utc->time-monotonic! (julian-day->time-utc jdn))) (define (julian-day->date jdn . tz-offset) - (let ((offset (optional tz-offset (priv:local-tz-offset)))) + (let ((offset (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset)))) (time-utc->date (julian-day->time-utc jdn) offset))) (define (modified-julian-day->date jdn . tz-offset) - (let ((offset (optional tz-offset (priv:local-tz-offset)))) + (let ((offset (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset)))) (julian-day->date (+ jdn 4800001/2) offset))) (define (modified-julian-day->time-utc jdn) @@ -1209,7 +1228,7 @@ (define (date->string date . format-string) (let ((str-port (open-output-string)) - (fmt-str (optional format-string "~c"))) + (fmt-str (if (null? format-string) "~c" (car format-string)))) (priv:date-printer date 0 fmt-str (string-length fmt-str) str-port) (get-output-string str-port))) From 60a54e2fca6e1ca3bce9aa93a0eb17331d4dda02 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Wed, 23 May 2001 17:00:53 +0000 Subject: [PATCH 1174/2047] *** empty log message *** --- srfi/ChangeLog | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 0eaaa71a2..7d897618b 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,7 +1,13 @@ 2001-05-23 Rob Browning * srfi-19.scm (:optional): renamed to optional to avoid reader - keywords conflict. Thanks to Matthias Koeppe for the report. + keywords conflict. Time passes... Removed :optional altogether + and just handle optional args directly. Thanks to Matthias Koeppe + for the report of this and the two bits below. + (priv:decode-julian-day-number): add inexact->exact for truncate + result. + (time-utc->date): add inexact->exact and floor so quotient will + work. 2001-05-22 Martin Grabmueller From 92905faf2c34bf86e3b45d72d7b16a16ec4948f5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 23 May 2001 17:24:50 +0000 Subject: [PATCH 1175/2047] * guile.texi: Commented out menu entry and inclusion of Tcl/Tk stuff. * indices.texi: Users are advised to look under C and Scheme names, xref to transformation rules added. * intro.texi, scheme-modules.texi, scheme-ideas.texi, scheme-evaluation.texi, scheme-data.texi, scheme-procedures.texi: Fixed most REFFIXMEs. * srfi-modules.texi (About SRFI Usage): New node. (SRFI-0): Extended. Fixed all REFFIXMEs. --- doc/ChangeLog | 16 + doc/guile.texi | 6 +- doc/indices.texi | 28 +- doc/intro.texi | 4 +- doc/scheme-data.texi | 18 +- doc/scheme-evaluation.texi | 12 +- doc/scheme-ideas.texi | 1458 ------------------------------------ doc/scheme-modules.texi | 20 +- doc/scheme-procedures.texi | 779 ------------------- doc/srfi-modules.texi | 98 ++- 10 files changed, 151 insertions(+), 2288 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index cff21ad5c..32522fff9 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,19 @@ +2001-05-23 Martin Grabmueller + + * guile.texi: Commented out menu entry and inclusion of Tcl/Tk + stuff. + + * indices.texi: Users are advised to look under C and Scheme + names, xref to transformation rules added. + + * intro.texi, scheme-modules.texi, scheme-ideas.texi, + scheme-evaluation.texi, scheme-data.texi, scheme-procedures.texi: + Fixed most REFFIXMEs. + + * srfi-modules.texi (About SRFI Usage): New node. + (SRFI-0): Extended. + Fixed all REFFIXMEs. + 2001-05-19 Neil Jerram * posix.texi (Networking): Split existing material into new nodes diff --git a/doc/guile.texi b/doc/guile.texi index 633b2b03a..29da7b221 100644 --- a/doc/guile.texi +++ b/doc/guile.texi @@ -80,7 +80,7 @@ by the Free Software Foundation. @sp 10 @comment The title is printed in a large font. @title Guile Reference Manual -@subtitle $Id: guile.texi,v 1.9 2001-05-14 21:37:51 mgrabmue Exp $ +@subtitle $Id: guile.texi,v 1.10 2001-05-23 17:24:49 mgrabmue Exp $ @subtitle For use with Guile @value{VERSION} @include AUTHORS @@ -177,7 +177,7 @@ Part III: Guile Modules add-on, so maybe it shouldn't be documented here (though it is nice to have a link from here to the Guile-scsh manual, if one exists). -* Tcl/Tk Interface:: +@c * Tcl/Tk Interface:: Part IV: Guile Scripting @@ -255,7 +255,7 @@ Indices @include repl-modules.texi @include expect.texi @include scsh.texi -@include tcltk.texi +@c @include tcltk.texi @c Guile as an scripting language @iftex diff --git a/doc/indices.texi b/doc/indices.texi index 69760b0bb..47b8d4cc2 100644 --- a/doc/indices.texi +++ b/doc/indices.texi @@ -1,22 +1,40 @@ @node Concept Index @unnumbered Concept Index + +This index contains concepts, keywords and non-Schemey names for several +features, to make it easier to locate the desired sections. + @printindex cp @node Procedure Index @unnumbered Procedure Index + +@c FIXME::martin: Review me! + This is an alphabetical list of all the procedures and macros in Guile. -[[Remind people to look for functions under their Scheme names as well -as their C names.]] + +When looking for a particular procedure, please look under its Scheme +name as well as under its C name. The C name can be constructed from +the Scheme names by a simple transformation described in the section +@xref{Transforming Scheme name to C name}. + @printindex fn @node Variable Index @unnumbered Variable Index + +@c FIXME::martin: Review me! + This is an alphabetical list of all the important variables and constants in Guile. -[[Remind people to look for variables under their Scheme names as well -as their C names.]] + +When looking for a particular variable or constant, please look under +its Scheme name as well as under its C name. The C name can be +constructed from the Scheme names by a simple transformation described +in the section @xref{Transforming Scheme name to C name}. + @printindex vr @@ -25,7 +43,9 @@ as their C names.]] @c spurious makeinfo errors. @node Type Index @unnumbered Type Index + This is an alphabetical list of all the important data types defined in the Guile Programmers Manual. + @printindex tp diff --git a/doc/intro.texi b/doc/intro.texi index 5c24c3aa3..f12c3c980 100644 --- a/doc/intro.texi +++ b/doc/intro.texi @@ -1,4 +1,4 @@ -@c $Id: intro.texi,v 1.9 2001-05-16 18:08:12 mgrabmue Exp $ +@c $Id: intro.texi,v 1.10 2001-05-23 17:24:49 mgrabmue Exp $ @page @node What is Guile? @@ -686,7 +686,7 @@ usual for your operating system, and it will additionally look into the directories listed in the @code{LTDL_LIBRRAY_PATH} environment variable. To see how these Guile extensions via shared libraries relate to the -module system, see below REFFIXME. +module system, see below @xref{Intro to Modules and Extensions}. @node Guile Modules @section Guile Modules diff --git a/doc/scheme-data.texi b/doc/scheme-data.texi index b5b3bb619..7f283f446 100755 --- a/doc/scheme-data.texi +++ b/doc/scheme-data.texi @@ -1614,9 +1614,10 @@ y @subsection String Comparison The procedures in this section are similar to the character ordering -predicates (REFFIXME), but are defined on character sequences. They all -return @code{#t} on success and @code{#f} on failure. The predicates -ending in @code{-ci} ignore the character case when comparing strings. +predicates (@pxref{Characters}), but are defined on character sequences. +They all return @code{#t} on success and @code{#f} on failure. The +predicates ending in @code{-ci} ignore the character case when comparing +strings. @rnindex string=? @@ -2536,7 +2537,7 @@ one of the constructor procedures @code{make-variable} or @code{make-undefined-variable} or retrieved by @code{builtin-variable}. First-class variables are especially useful for interacting with the -current module system (REFFIXME). +current module system (@pxref{The Guile module system}). @deffn primitive builtin-variable name Return the built-in variable with the name @var{name}. @@ -2967,7 +2968,7 @@ up a list. An example will clear that up: This example also shows that lists have to be quoted (REFFIXME) when written, because they would otherwise be mistakingly taken as procedure -applications (REFFIXME). +applications (@pxref{Simple Invocation}). @node List Predicates @@ -3028,7 +3029,7 @@ that modifying the elements of the new list also modyfies the elements of the old list. On the other hand, applying procedures like @code{set-cdr!} or @code{delv!} to the new list will not alter the old list. If you also need to copy the list elements (making a deep copy), -use the procedure @code{copy-tree} (REFFIXME). +use the procedure @code{copy-tree} (@pxref{Copying}). @node List Selection @subsection List Selection @@ -4896,8 +4897,9 @@ elements of @var{vector}. @subsection Vector Modification -A vector created by any of the vector constructor procedures (REFFIXME) -documented above can be modified using the following procedures. +A vector created by any of the vector constructor procedures +(@pxref{Vectors}) documented above can be modified using the +following procedures. According to R5RS, using any of these procedures on literally entered vectors is an error, because these vectors are considered to be diff --git a/doc/scheme-evaluation.texi b/doc/scheme-evaluation.texi index d3edc523f..d3b3f6eea 100644 --- a/doc/scheme-evaluation.texi +++ b/doc/scheme-evaluation.texi @@ -72,10 +72,10 @@ another comment type for multiline comments, called @dfn{block comments}. This type of comment begins with the character sequence @code{#!} and ends with the characters @code{!#}, which must appear on a line of their own. These comments are compatible with the block -comments in the Scheme Shell @file{scsh} (REFFIXME). The characters -@code{#!} were chosen because they are the magic characters used in -shell scripts for indicating that the name of the program for executing -the script follows on the same line. +comments in the Scheme Shell @file{scsh} (@pxref{The Scheme shell +(scsh)}). The characters @code{#!} were chosen because they are the +magic characters used in shell scripts for indicating that the name of +the program for executing the script follows on the same line. Thus a Guile script often starts like this. @@ -85,7 +85,7 @@ Thus a Guile script often starts like this. @end lisp More details on Guile scripting can be found in the scripting section -(REFFIXME). +(@pxref{Guile Scripting}). @node Case Sensitivity @@ -105,7 +105,7 @@ are the same in R5RS Scheme, but are different in Guile. It is possible to turn off case sensitivity in Guile by setting the reader option @code{case-insensitive}. More on reader options can be -found at (REFFIXME). +found at (@pxref{Reader options}). @lisp (read-enable 'case-insensitive) diff --git a/doc/scheme-ideas.texi b/doc/scheme-ideas.texi index 6db8ce219..e69de29bb 100644 --- a/doc/scheme-ideas.texi +++ b/doc/scheme-ideas.texi @@ -1,1458 +0,0 @@ -@page -@node Basic Ideas -@chapter Basic Ideas in Scheme - -In this chapter, we introduce the basic concepts that underpin the -elegance and power of the Scheme language. - -Readers who already possess a background knowledge of Scheme may happily -skip this chapter. For the reader who is new to the language, however, -the following discussions on data, procedures, expressions and closure -are designed to provide a minimum level of Scheme understanding that is -more or less assumed by the reference chapters that follow. - -The style of this introductory material aims about halfway between the -terse precision of R5RS and the discursive randomness of a Scheme -tutorial. - -@menu -* About Data:: Latent typing, types, values and variables. -* About Procedures:: The representation and use of procedures. -* About Expressions:: All kinds of expressions and their meaning. -* About Closure:: Closure, scoping and environments. -@end menu - - -@node About Data -@section Data Types, Values and Variables - -This section discusses the representation of data types and values, what -it means for Scheme to be a @dfn{latently typed} language, and the role -of variables. We conclude by introducing the Scheme syntaxes for -defining a new variable, and for changing the value of an existing -variable. - -@menu -* Latent Typing:: Scheme as a "latently typed" language. -* Values and Variables:: About data types, values and variables. -* Definition:: Defining variables and setting their values. -@end menu - - -@node Latent Typing -@subsection Latent Typing - -The term @dfn{latent typing} is used to descibe a computer language, -such as Scheme, for which you cannot, @emph{in general}, simply look at -a program's source code and determine what type of data will be -associated with a particular variable, or with the result of a -particular expression. - -Sometimes, of course, you @emph{can} tell from the code what the type of -an expression will be. If you have a line in your program that sets the -variable @code{x} to the numeric value 1, you can be certain that, -immediately after that line has executed (and in the absence of multiple -threads), @code{x} has the numeric value 1. Or if you write a procedure -that is designed to concatenate two strings, it is likely that the rest -of your application will always invoke this procedure with two string -parameters, and quite probable that the procedure would go wrong in some -way if it was ever invoked with parameters that were not both strings. - -Nevertheless, the point is that there is nothing in Scheme which -requires the procedure parameters always to be strings, or @code{x} -always to hold a numeric value, and there is no way of declaring in your -program that such constraints should always be obeyed. In the same -vein, there is no way to declare the expected type of a procedure's -return value. - -Instead, the types of variables and expressions are only known -- in -general -- at run time. If you @emph{need} to check at some point that -a value has the expected type, Scheme provides run time procedures that -you can invoke to do so. But equally, it can be perfectly valid for two -separate invocations of the same procedure to specify arguments with -different types, and to return values with different types. - -The next subsection explains what this means in practice, for the ways -that Scheme programs use data types, values and variables. - - -@node Values and Variables -@subsection Values and Variables - -Scheme provides many data types that you can use to represent your data. -Primitive types include characters, strings, numbers and procedures. -Compound types, which allow a group of primitive and compound values to -be stored together, include lists, pairs, vectors and multi-dimensional -arrays. In addition, Guile allows applications to define their own data -types, with the same status as the built-in standard Scheme types. - -As a Scheme program runs, values of all types pop in and out of -existence. Sometimes values are stored in variables, but more commonly -they pass seamlessly from being the result of one computation to being -one of the parameters for the next. - -Consider an example. A string value is created because the interpreter -reads in a literal string from your program's source code. Then a -numeric value is created as the result of calculating the length of the -string. A second numeric value is created by doubling the calculated -length. Finally the program creates a list with two elements -- the -doubled length and the original string itself -- and stores this list in -a program variable. - -All of the values involved here -- in fact, all values in Scheme -- -carry their type with them. In other words, every value ``knows,'' at -runtime, what kind of value it is. A number, a string, a list, -whatever. - -A variable, on the other hand, has no fixed type. A variable -- -@code{x}, say -- is simply the name of a location -- a box -- in which -you can store any kind of Scheme value. So the same variable in a -program may hold a number at one moment, a list of procedures the next, -and later a pair of strings. The ``type'' of a variable -- insofar as -the idea is meaningful at all -- is simply the type of whatever value -the variable happens to be storing at a particular moment. - - -@node Definition -@subsection Defining and Setting Variables - -To define a new variable, you use Scheme's @code{define} syntax like -this: - -@lisp -(define @var{variable-name} @var{value}) -@end lisp - -This makes a new variable called @var{variable-name} and stores -@var{value} in it as the variable's initial value. For example: - -@lisp -;; Make a variable `x' with initial numeric value 1. -(define x 1) - -;; Make a variable `organization' with an initial string value. -(define organization "Free Software Foundation") -@end lisp - -(In Scheme, a semicolon marks the beginning of a comment that continues -until the end of the line. So the lines beginning @code{;;} are -comments.) - -Changing the value of an already existing variable is very similar, -except that @code{define} is replaced by the Scheme syntax @code{set!}, -like this: - -@lisp -(set! @var{variable-name} @var{new-value}) -@end lisp - -Remember that variables do not have fixed types, so @var{new-value} may -have a completely different type from whatever was previously stored in -the location named by @var{variable-name}. Both of the following -examples are therefore correct. - -@lisp -;; Change the value of `x' to 5. -(set! x 5) - -;; Change the value of `organization' to the FSF's street number. -(set! organization 545) -@end lisp - -In these examples, @var{value} and @var{new-value} are literal numeric -or string values. In general, however, @var{value} and @var{new-value} -can be any Scheme expression. Even though we have not yet covered the -forms that Scheme expressions can take (@pxref{About Expressions}), you -can probably guess what the following @code{set!} example does@dots{} - -@lisp -(set! x (+ x 1)) -@end lisp - -(Note: this is not a complete description of @code{define} and -@code{set!}, because we need to introduce some other aspects of Scheme -before the missing pieces can be filled in. If, however, you are -already familiar with the structure of Scheme, you may like to read -about those missing pieces immediately by jumping ahead to the following -references. - -@itemize @bullet -@item -REFFIXME, to read about using @code{define} other than at top level in a -Scheme program, including a discussion of when it works to use -@code{define} rather than @code{set!} to change the value of an existing -variable. - -@item -@ref{Lambda Alternatives}, to read about an alternative form of the -@code{define} syntax that can be used when defining new procedures. - -@item -REFFIXME, to read about an alternative form of the @code{set!} syntax -that helps with changing a single value in the depths of a compound data -structure.) -@end itemize - - -@node About Procedures -@section The Representation and Use of Procedures - -This section introduces the basics of using and creating Scheme -procedures. It discusses the representation of procedures as just -another kind of Scheme value, and shows how procedure invocation -expressions are constructed. We then explain how @code{lambda} is used -to create new procedures, and conclude by presenting the various -shorthand forms of @code{define} that can be used instead of writing an -explicit @code{lambda} expression. - -@menu -* Procedures as Values:: Procedures are values like everything else. -* Simple Invocation:: How to write a simple procedure invocation. -* Creating a Procedure:: How to create your own procedures. -* Lambda Alternatives:: Other ways of writing procedure definitions. -@end menu - - -@node Procedures as Values -@subsection Procedures as Values - -One of the great simplifications of Scheme is that a procedure is just -another type of value, and that procedure values can be passed around -and stored in variables in exactly the same way as, for example, strings -and lists. When we talk about a built-in standard Scheme procedure such -as @code{open-input-file}, what we actually mean is that there is a -pre-defined top level variable called @code{open-input-file}, whose -value is a procedure that implements what R5RS says that -@code{open-input-file} should do. - -Note that this is quite different from many dialects of Lisp --- -including Emacs Lisp --- in which a program can use the same name with -two quite separate meanings: one meaning identifies a Lisp function, -while the other meaning identifies a Lisp variable, whose value need -have nothing to do with the function that is associated with the first -meaning. In these dialects, functions and variables are said to live in -different @dfn{namespaces}. - -In Scheme, on the other hand, all names belong to a single unified -namespace, and the variables that these names identify can hold any kind -of Scheme value, including procedure values. - -One consequence of the ``procedures as values'' idea is that, if you -don't happen to like the standard name for a Scheme procedure, you can -change it. - -For example, @code{call-with-current-continuation} is a very important -standard Scheme procedure, but it also has a very long name! So, many -programmers use the following definition to assign the same procedure -value to the more convenient name @code{call/cc}. - -@lisp -(define call/cc call-with-current-continuation) -@end lisp - -Let's understand exactly how this works. The definition creates a new -variable @code{call/cc}, and then sets its value to the value of the -variable @code{call-with-current-continuation}; the latter value is a -procedure that implements the behaviour that R5RS specifies under the -name ``call-with-current-continuation''. So @code{call/cc} ends up -holding this value as well. - -Now that @code{call/cc} holds the required procedure value, you could -choose to use @code{call-with-current-continuation} for a completely -different purpose, or just change its value so that you will get an -error if you accidentally use @code{call-with-current-continuation} as a -procedure in your program rather than @code{call/cc}. For example: - -@lisp -(set! call-with-current-continuation "Not a procedure any more!") -@end lisp - -Or you could just leave @code{call-with-current-continuation} as it was. -It's perfectly fine for more than one variable to hold the same -procedure value. - - -@node Simple Invocation -@subsection Simple Procedure Invocation - -A procedure invocation in Scheme is written like this: - -@lisp -(@var{procedure} [@var{arg1} [@var{arg2} @dots{}]]) -@end lisp - -In this expression, @var{procedure} can be any Scheme expression whose -value is a procedure. Most commonly, however, @var{procedure} is simply -the name of a variable whose value is a procedure. - -For example, @code{string-append} is a standard Scheme procedure whose -behaviour is to concatenate together all the arguments, which are -expected to be strings, that it is given. So the expression - -@lisp -(string-append "/home" "/" "andrew") -@end lisp - -@noindent -is a procedure invocation whose result is the string value -@code{"/home/andrew"}. - -Similarly, @code{string-length} is a standard Scheme procedure that -returns the length of a single string argument, so - -@lisp -(string-length "abc") -@end lisp - -@noindent -is a procedure invocation whose result is the numeric value 3. - -Each of the parameters in a procedure invocation can itself be any -Scheme expression. Since a procedure invocation is itself a type of -expression, we can put these two examples together to get - -@lisp -(string-length (string-append "/home" "/" "andrew")) -@end lisp - -@noindent ---- a procedure invocation whose result is the numeric value 12. - -(You may be wondering what happens if the two examples are combined the -other way round. If we do this, we can make a procedure invocation -expression that is @emph{syntactically} correct: - -@lisp -(string-append "/home" (string-length "abc")) -@end lisp - -@noindent -but when this expression is executed, it will cause an error, because -the result of @code{(string-length "abc")} is a numeric value, and -@code{string-append} is not designed to accept a numeric value as one of -its arguments.) - - -@node Creating a Procedure -@subsection Creating and Using a New Procedure - -Scheme has lots of standard procedures, and Guile provides all of these -via predefined top level variables. All of these standard procedures -are documented in the later chapters of this reference manual. - -Before very long, though, you will want to create new procedures that -encapsulate aspects of your own applications' functionality. To do -this, you can use the famous @code{lambda} syntax. - -For example, the value of the following Scheme expression - -@lisp -(lambda (name address) @var{expression} @dots{}) -@end lisp - -@noindent -is a newly created procedure that takes two arguments: -@code{name} and @code{address}. The behaviour of the -new procedure is determined by the sequence of @var{expression}s in the -@dfn{body} of the procedure definition. (Typically, these -@var{expression}s would use the arguments in some way, or else there -wouldn't be any point in giving them to the procedure.) When invoked, -the new procedure returns a value that is the value of the last -@var{expression} in the procedure body. - -To make things more concrete, let's suppose that the two arguments are -both strings, and that the purpose of this procedure is to form a -combined string that includes these arguments. Then the full lambda -expression might look like this: - -@lisp -(lambda (name address) - (string-append "Name=" name ":Address=" address)) -@end lisp - -We noted in the previous subsection that the @var{procedure} part of a -procedure invocation expression can be any Scheme expression whose value -is a procedure. But that's exactly what a lambda expression is! So we -can use a lambda expression directly in a procedure invocation, like -this: - -@lisp -((lambda (name address) - (string-append "Name=" name ":Address=" address)) - "FSF" - "Cambridge") -@end lisp - -@noindent -This is a valid procedure invocation expression, whose result is the -string @code{"Name=FSF:Address=Cambridge"}. - -It it more common, though, to store the procedure value in a variable --- - -@lisp -(define make-combined-string - (lambda (name address) - (string-append "Name=" name ":Address=" address))) -@end lisp - -@noindent ---- and then to use the variable name in the procedure invocation: - -@lisp -(make-combined-string "FSF" "Cambridge") -@end lisp - -@noindent -Which has exactly the same result. - -It's important to note that procedures created using @code{lambda} have -exactly the same status as the standard built in Scheme procedures, and -can be invoked, passed around, and stored in variables in exactly the -same ways. - - -@node Lambda Alternatives -@subsection Lambda Alternatives - -Since it is so common in Scheme programs to want to create a procedure -and then store it in a variable, there is an alternative form of the -@code{define} syntax that allows you to do just that. - -A @code{define} expression of the form - -@lisp -(define (@var{name} [@var{arg1} [@var{arg2} @dots{}]]) - @var{expression} @dots{}) -@end lisp - -@noindent -is exactly equivalent to the longer form - -@lisp -(define @var{name} - (lambda ([@var{arg1} [@var{arg2} @dots{}]]) - @var{expression} @dots{})) -@end lisp - -So, for example, the definition of @code{make-combined-string} in the -previous subsection could equally be written: - -@lisp -(define (make-combined-string name address) - (string-append "Name=" name ":Address=" address)) -@end lisp - -This kind of procedure definition creates a procedure that requires -exactly the expected number of arguments. There are two further forms -of the @code{lambda} expression, which create a procedure that can -accept a variable number of arguments: - -@lisp -(lambda (@var{arg1} @dots{} . @var{args}) @var{expression} @dots{}) - -(lambda @var{args} @var{expression} @dots{}) -@end lisp - -@noindent -The corresponding forms of the alternative @code{define} syntax are: - -@lisp -(define (@var{name} @var{arg1} @dots{} . @var{args}) @var{expression} @dots{}) - -(define (@var{name} . @var{args}) @var{expression} @dots{}) -@end lisp - -@noindent -For details on how these forms work, see @xref{Lambda}. - -(It could be argued that the alternative @code{define} forms are rather -confusing, especially for newcomers to the Scheme language, as they hide -both the role of @code{lambda} and the fact that procedures are values -that are stored in variables in the some way as any other kind of value. -On the other hand, they are very convenient, and they are also a good -example of another of Scheme's powerful features: the ability to specify -arbitrary syntactic transformations at run time, which can be applied to -subsequently read input.) - - -@node About Expressions -@section Expressions and Evaluation - -So far, we have met expressions that @emph{do} things, such as the -@code{define} expressions that create and initialize new variables, and -we have also talked about expressions that have @emph{values}, for -example the value of the procedure invocation expression: - -@lisp -(string-append "/home" "/" "andrew") -@end lisp - -@noindent -but we haven't yet been precise about what causes an expression like -this procedure invocation to be reduced to its ``value'', or how the -processing of such expressions relates to the execution of a Scheme -program as a whole. - -This section clarifies what we mean by an expression's value, by -introducing the idea of @dfn{evaluation}. It discusses the side effects -that evaluation can have, explains how each of the various types of -Scheme expression is evaluated, and describes the behaviour and use of -the Guile REPL as a mechanism for exploring evaluation. The section -concludes with a very brief summary of Scheme's common syntactic -expressions. - -@menu -* Evaluating:: How a Scheme program is executed. -* The REPL:: Interacting with the Guile interpreter. -* Syntax Summary:: Common syntactic expressions -- in brief. -@end menu - - -@node Evaluating -@subsection Evaluating Expressions and Executing Programs - -In Scheme, the process of executing an expression is known as -@dfn{evaluation}. Evaluation has two kinds of result: - -@itemize @bullet -@item -the @dfn{value} of the evaluated expression - -@item -the @dfn{side effects} of the evaluation, which consist of any effects of -evaluating the expression that are not represented by the value. -@end itemize - -Of the expressions that we have met so far, @code{define} and -@code{set!} expressions have side effects --- the creation or -modification of a variable --- but no value; @code{lambda} expressions -have values --- the newly constructed procedures --- but no side -effects; and procedure invocation expressions, in general, have either -values, or side effects, or both. - -It is tempting to try to define more intuitively what we mean by -``value'' and ``side effects'', and what the difference between them is. -In general, though, this is extremely difficult. It is also -unnecessary; instead, we can quite happily define the behaviour of a -Scheme program by specifying how Scheme executes a program as a whole, -and then by describing the value and side effects of evaluation for each -type of expression individually. - -@noindent -So, some@footnote{These definitions are approximate. For the whole and -detailed truth, see @xref{Formal syntax and semantics,R5RS -syntax,,r5rs}.} definitions@dots{} - -@itemize @bullet - -@item -A Scheme program consists of a sequence of expressions. - -@item -A Scheme interpreter executes the program by evaluating these -expressions in order, one by one. - -@item -An expression can be - -@itemize @bullet -@item -a piece of literal data, such as a number @code{2.3} or a string -@code{"Hello world!"} -@item -a variable name -@item -a procedure invocation expression -@item -one of Scheme's special syntactic expressions. -@end itemize -@end itemize - -@noindent -The following subsections describe how each of these types of expression -is evaluated. - -@menu -* Eval Literal:: Evaluating literal data. -* Eval Variable:: Evaluating variable references. -* Eval Procedure:: Evaluating procedure invocation expressions. -* Eval Special:: Evaluating special syntactic expressions. -@end menu - -@node Eval Literal -@subsubsection Evaluating Literal Data - -When a literal data expression is evaluated, the value of the expression -is simply the value that the expression describes. The evaluation of a -literal data expression has no side effects. - -@noindent -So, for example, - -@itemize @bullet -@item -the value of the expression @code{"abc"} is the string value -@code{"abc"} - -@item -the value of the expression @code{3+4i} is the complex number 3 + 4i - -@item -the value of the expression @code{#(1 2 3)} is a three-element vector -containing the numeric values 1, 2 and 3. -@end itemize - -For any data type which can be expressed literally like this, the syntax -of the literal data expression for that data type --- in other words, -what you need to write in your code to indicate a literal value of that -type --- is known as the data type's @dfn{read syntax}. This manual -specifies the read syntax for each such data type in the section that -describes that data type. - -Some data types do not have a read syntax. Procedures, for example, -cannot be expressed as literal data; they must be created using a -@code{lambda} expression (@pxref{Creating a Procedure}) or implicitly -using the shorthand form of @code{define} (@pxref{Lambda Alternatives}). - - -@node Eval Variable -@subsubsection Evaluating a Variable Reference - -When an expression that consists simply of a variable name is evaluated, -the value of the expression is the value of the named variable. The -evaluation of a variable reference expression has no side effects. - -So, after - -@lisp -(define key "Paul Evans") -@end lisp - -@noindent -the value of the expression @code{key} is the string value @code{"Paul -Evans"}. If @var{key} is then modified by - -@lisp -(set! key 3.74) -@end lisp - -@noindent -the value of the expression @code{key} is the numeric value 3.74. - -If there is no variable with the specified name, evaluation of the -variable reference expression signals an error. - - -@node Eval Procedure -@subsubsection Evaluating a Procedure Invocation Expression - -This is where evaluation starts getting interesting! As already noted, -a procedure invocation expression has the form - -@lisp -(@var{procedure} [@var{arg1} [@var{arg2} @dots{}]]) -@end lisp - -@noindent -where @var{procedure} must be an expression whose value, when evaluated, -is a procedure. - -The evaluation of a procedure invocation expression like this proceeds -by - -@itemize @bullet -@item -evaluating individually the expressions @var{procedure}, @var{arg1}, -@var{arg2}, and so on - -@item -calling the procedure that is the value of the @var{procedure} -expression with the list of values obtained from the evaluations of -@var{arg1}, @var{arg2} etc. as its parameters. -@end itemize - -For a procedure defined in Scheme, ``calling the procedure with the list -of values as its parameters'' means binding the values to the -procedure's formal parameters and then evaluating the sequence of -expressions that make up the body of the procedure definition. The -value of the procedure invocation expression is the value of the last -evaluated expression in the procedure body. The side effects of calling -the procedure are the combination of the side effects of the sequence of -evaluations of expressions in the procedure body. - -For a built-in procedure, the value and side-effects of calling the -procedure are best described by that procedure's documentation. - -Note that the complete side effects of evaluating a procedure invocation -expression consist not only of the side effects of the procedure call, -but also of any side effects of the preceding evaluation of the -expressions @var{procedure}, @var{arg1}, @var{arg2}, and so on. - -To illustrate this, let's look again at the procedure invocation -expression: - -@lisp -(string-length (string-append "/home" "/" "andrew")) -@end lisp - -In the outermost expression, @var{procedure} is @code{string-length} and -@var{arg1} is @code{(string-append "/home" "/" "andrew")}. - -@itemize @bullet -@item -Evaluation of @code{string-length}, which is a variable, gives a -procedure value that implements the expected behaviour for -``string-length''. - -@item -Evaluation of @code{(string-append "/home" "/" "andrew")}, which is -another procedure invocation expression, means evaluating each of - -@itemize @bullet -@item -@code{string-append}, which gives a procedure value that implements the -expected behaviour for ``string-append'' - -@item -@code{"/home"}, which gives the string value @code{"/home"} - -@item -@code{"/"}, which gives the string value @code{"/"} - -@item -@code{"andrew"}, which gives the string value @code{"andrew"} -@end itemize - -and then invoking the procedure value with this list of string values as -its arguments. The resulting value is a single string value that is the -concatenation of all the arguments, namely @code{"/home/andrew"}. -@end itemize - -In the evaluation of the outermost expression, the interpreter can now -invoke the procedure value obtained from @var{procedure} with the value -obtained from @var{arg1} as its arguments. The resulting value is a -numeric value that is the length of the argument string, which is 12. - - -@node Eval Special -@subsubsection Evaluating Special Syntactic Expressions - -When a procedure invocation expression is evaluated, the procedure and -@emph{all} the argument expressions must be evaluated before the -procedure can be invoked. Special syntactic expressions are special -because they are able to manipulate their arguments in an unevaluated -form, and can choose whether to evaluate any or all of the argument -expressions. - -Why is this needed? Consider a program fragment that asks the user -whether or not to delete a file, and then deletes the file if the user -answers yes. - -@lisp -(if (string=? (read-answer "Should I delete this file?") - "yes") - (delete-file file)) -@end lisp - -If the outermost @code{(if @dots{})} expression here was a procedure -invocation expression, the expression @code{(delete-file file)}, whose -effect is to actually delete a file, would already have been executed -before the @code{if} procedure even got invoked! Clearly this is no use ---- the whole point of an @code{if} expression is that the -@dfn{consequent} expression is only evaluated if the condition of the -@code{if} expression is ``true''. - -Therefore @code{if} must be special syntax, not a procedure. Other -special syntaxes that we have already met are @code{define}, @code{set!} -and @code{lambda}. @code{define} and @code{set!} are syntax because -they need to know the variable @emph{name} that is given as the first -argument in a @code{define} or @code{set!} expression, not that -variable's value. @code{lambda} is syntax because it does not -immediately evaluate the expressions that define the procedure body; -instead it creates a procedure object that incorporates these -expressions so that they can be evaluated in the future, when that -procedure is invoked. - -The rules for evaluating each special syntactic expression are specified -individually for each special syntax. For a summary of standard special -syntax, see @xref{Syntax Summary}. - - -@node The REPL -@subsection Using the Guile REPL - -If you start Guile without specifying a particular program for it to -execute, Guile enters its standard Read Evaluate Print Loop --- or -@dfn{REPL} for short. In this mode, Guile repeatedly reads in the next -Scheme expression that the user types, evaluates it, and prints the -resulting value. - -The REPL is a useful mechanism for exploring the evaluation behaviour -described in the previous subsection. If you type @code{string-append}, -for example, the REPL replies @code{#}, illustrating the relationship between the variable -@code{string-append} and the procedure value stored in that variable. - -In this manual, the notation @result{} is used to mean ``evaluates -to''. Wherever you see an example of the form - -@lisp -@var{expression} -@result{} -@var{result} -@end lisp - -@noindent -feel free to try it out yourself by typing @var{expression} into the -REPL and checking that it gives the expected @var{result}. - - -@node Syntax Summary -@subsection Summary of Common Syntax - -This subsection lists the most commonly used Scheme syntactic -expressions, simply so that you will recognize common special syntax -when you see it. For a full description of each of these syntaxes, -follow the appropriate reference. - -@code{if} (REFFIXME) and @code{cond} (REFFIXME) provide conditional -evaluation of argument expressions depending on whether one or more -conditions evaluate to ``true'' or ``false''. - -@code{case} (REFFIXME) provides conditional evaluation of argument -expressions depending on whether a variable has one of a specified group -of values. - -@code{define} (REFFIXME) is used to create a new variable and set its -initial value. - -@code{set!} (REFFIXME) is used to modify an existing variable's value. - -@code{lambda} (REFFIXME) is used to construct procedure objects. - -@code{let} (REFFIXME), @code{let*} (REFFIXME) and @code{letrec} -(REFFIXME) create an inner lexical environment for the evaluation of a -sequence of expressions, in which a specified set of local variables is -bound to the values of a corresponding set of expressions. For an -introduction to environments, see @xref{About Closure}. - -@code{begin} (REFFIXME) executes a sequence of expressions in order and -returns the value of the last expression. Note that this is not the -same as a procedure which returns its last argument, because the -evaluation of a procedure invocation expression does not guarantee to -evaluate the arguments in order. - -@code{and} (REFFIXME) executes a sequence of expressions in order until -either there are no expressions left, or one of them evaluates to -``false''. - -@code{or} (REFFIXME) executes a sequence of expressions in order until -either there are no expressions left, or one of them evaluates to -``true''. - - -@node About Closure -@section The Concept of Closure - -@cindex closure - -The concept of @dfn{closure} is the idea that a lambda expression -``captures'' the variable bindings that are in lexical scope at the -point where the lambda expression occurs. The procedure created by the -lambda expression can refer to and mutate the captured bindings, and the -values of those bindings persist between procedure calls. - -This section explains and explores the various parts of this idea in -more detail. - -@menu -* About Environments:: Names, locations, values and environments. -* Local Variables:: Local variables and local environments. -* Chaining:: Environment chaining. -* Lexical Scope:: The meaning of lexical scoping. -* Closure:: Explaining the concept of closure. -* Serial Number:: Example 1: a serial number generator. -* Shared Variable:: Example 2: a shared persistent variable. -* Callback Closure:: Example 3: the callback closure problem. -* OO Closure:: Example 4: object orientation. -@end menu - -@node About Environments -@subsection Names, Locations, Values and Environments - -@cindex location -@cindex environment -@cindex vcell -@cindex top level environment -@cindex environment, top level - -We said earlier that a variable name in a Scheme program is associated -with a location in which any kind of Scheme value may be stored. -(Incidentally, the term ``vcell'' is often used in Lisp and Scheme -circles as an alternative to ``location''.) Thus part of what we mean -when we talk about ``creating a variable'' is in fact establishing an -association between a name, or identifier, that is used by the Scheme -program code, and the variable location to which that name refers. -Although the value that is stored in that location may change, the -location to which a given name refers is always the same. - -We can illustrate this by breaking down the operation of the -@code{define} syntax into three parts: @code{define} - -@itemize @bullet -@item -creates a new location - -@item -establishes an association between that location and the name specified -as the first argument of the @code{define} expression - -@item -stores in that location the value obtained by evaluating the second -argument of the @code{define} expression. -@end itemize - -A collection of associations between names and locations is called an -@dfn{environment}. When you create a top level variable in a program -using @code{define}, the name-location association for that variable is -added to the ``top level'' environment. The ``top level'' environment -also includes name-location associations for all the procedures that are -supplied by standard Scheme. - -It is also possible to create environments other than the top level one, -and to create variable bindings, or name-location associations, in those -environments. This ability is a key ingredient in the concept of -closure; the next subsection shows how it is done. - - -@node Local Variables -@subsection Local Variables and Environments - -@cindex local variable -@cindex variable, local -@cindex local environment -@cindex environment, local - -We have seen how to create top level variables using the @code{define} -syntax (@pxref{Definition}). It is often useful to create variables -that are more limited in their scope, typically as part of a procedure -body. In Scheme, this is done using the @code{let} syntax, or one of -its modified forms @code{let*} and @code{letrec}. These syntaxes are -described in full later in the manual (REFFIXME). Here our purpose is -to illustrate their use just enough that we can see how local variables -work. - -For example, the following code uses a local variable @code{s} to -simplify the computation of the area of a triangle given the lengths of -its three sides. - -@lisp -(define a 5.3) -(define b 4.7) -(define c 2.8) - -(define area - (let ((s (/ (+ a b c) 2))) - (sqrt (* s (- s a) (- s b) (- s c))))) -@end lisp - -The effect of the @code{let} expression is to create a new environment -and, within this environment, an association between the name @code{s} -and a new location whose initial value is obtained by evaluating -@code{(/ (+ a b c) 2)}. The expressions in the body of the @code{let}, -namely @code{(sqrt (* s (- s a) (- s b) (- s c)))}, are then evaluated -in the context of the new environment, and the value of the last -expression evaluated becomes the value of the whole @code{let} -expression, and therefore the value of the variable @code{area}. - - -@node Chaining -@subsection Environment Chaining - -@cindex shadowing an imported variable binding -@cindex chaining environments - -In the example of the previous subsection, we glossed over an important -point. The body of the @code{let} expression in that example refers not -only to the local variable @code{s}, but also to the top level variables -@code{a}, @code{b}, @code{c} and @code{sqrt}. (@code{sqrt} is the -standard Scheme procedure for calculating a square root.) If the body -of the @code{let} expression is evaluated in the context of the -@emph{local} @code{let} environment, how does the evaluation get at the -values of these top level variables? - -The answer is that the local environment created by a @code{let} -expression automatically has a reference to its containing environment ---- in this case the top level environment --- and that the Scheme -interpreter automatically looks for a variable binding in the containing -environment if it doesn't find one in the local environment. More -generally, every environment except for the top level one has a -reference to its containing environment, and the interpreter keeps -searching back up the chain of environments --- from most local to top -level --- until it either finds a variable binding for the required -identifier or exhausts the chain. - -This description also determines what happens when there is more than -one variable binding with the same name. Suppose, continuing the -example of the previous subsection, that there was also a pre-existing -top level variable @code{s} created by the expression: - -@lisp -(define s "Some beans, my lord!") -@end lisp - -Then both the top level environment and the local @code{let} environment -would contain bindings for the name @code{s}. When evaluating code -within the @code{let} body, the interpreter looks first in the local -@code{let} environment, and so finds the binding for @code{s} created by -the @code{let} syntax. Even though this environment has a reference to -the top level environment, which also has a binding for @code{s}, the -interpreter doesn't get as far as looking there. When evaluating code -outside the @code{let} body, the interpreter looks up variable names in -the top level environment, so the name @code{s} refers to the top level -variable. - -Within the @code{let} body, the binding for @code{s} in the local -environment is said to @dfn{shadow} the binding for @code{s} in the top -level environment. - - -@node Lexical Scope -@subsection Lexical Scope - -The rules that we have just been describing are the details of how -Scheme implements ``lexical scoping''. This subsection takes a brief -diversion to explain what lexical scope means in general and to present -an example of non-lexical scoping. - -``Lexical scope'' in general is the idea that - -@itemize @bullet -@item -an identifier at a particular place in a program always refers to the -same variable location --- where ``always'' means ``every time that the -containing expression is executed'', and that - -@item -the variable location to which it refers can be determined by static -examination of the source code context in which that identifier appears, -without having to consider the flow of execution through the program as -a whole. -@end itemize - -In practice, lexical scoping is the norm for most programming languages, -and probably corresponds to what you would intuitively consider to be -``normal''. You may even be wondering how the situation could possibly ---- and usefully --- be otherwise. To demonstrate that another kind of -scoping is possible, therefore, and to compare it against lexical -scoping, the following subsection presents an example of non-lexical -scoping and examines in detail how its behavior differs from the -corresponding lexically scoped code. - -@menu -* Scoping Example:: An example of non-lexical scoping. -@end menu - - -@node Scoping Example -@subsubsection An Example of Non-Lexical Scoping - -To demonstrate that non-lexical scoping does exist and can be useful, we -present the following example from Emacs Lisp, which is a ``dynamically -scoped'' language. - -@lisp -(defvar currency-abbreviation "USD") - -(defun currency-string (units hundredths) - (concat currency-abbreviation - (number-to-string units) - "." - (number-to-string hundredths))) - -(defun french-currency-string (units hundredths) - (let ((currency-abbreviation "FRF")) - (currency-string units hundredths))) -@end lisp - -The question to focus on here is: what does the identifier -@code{currency-abbreviation} refer to in the @code{currency-string} -function? The answer, in Emacs Lisp, is that all variable bindings go -onto a single stack, and that @code{currency-abbreviation} refers to the -topmost binding from that stack which has the name -``currency-abbreviation''. The binding that is created by the -@code{defvar} form, to the value @code{"USD"}, is only relevant if none -of the code that calls @code{currency-string} rebinds the name -``currency-abbreviation'' in the meanwhile. - -The second function @code{french-currency-string} works precisely by -taking advantage of this behaviour. It creates a new binding for the -name ``currency-abbreviation'' which overrides the one established by -the @code{defvar} form. - -@lisp -;; Note! This is Emacs Lisp evaluation, not Scheme! -(french-currency-string 33 44) -@result{} -"FRF33.44" -@end lisp - -Now let's look at the corresponding, @emph{lexically scoped} Scheme -code: - -@lisp -(define currency-abbreviation "USD") - -(define (currency-string units hundredths) - (string-append currency-abbreviation - (number->string units) - "." - (number->string hundredths))) - -(define (french-currency-string units hundredths) - (let ((currency-abbreviation "FRF")) - (currency-string units hundredths))) -@end lisp - -According to the rules of lexical scoping, the -@code{currency-abbreviation} in @code{currency-string} refers to the -variable location in the innermost environment at that point in the code -which has a binding for @code{currency-abbreviation}, which is the -variable location in the top level environment created by the preceding -@code{(define currency-abbreviation @dots{})} expression. - -In Scheme, therefore, the @code{french-currency-string} procedure does -not work as intended. The variable binding that it creates for -``currency-abbreviation'' is purely local to the code that forms the -body of the @code{let} expression. Since this code doesn't directly use -the name ``currency-abbreviation'' at all, the binding is pointless. - -@lisp -(french-currency-string 33 44) -@result{} -"USD33.44" -@end lisp - -This begs the question of how the Emacs Lisp behaviour can be -implemented in Scheme. In general, this is a design question whose -answer depends upon the problem that is being addressed. In this case, -the best answer may be that @code{currency-string} should be -redesigned so that it can take an optional third argument. This third -argument, if supplied, is interpreted as a currency abbreviation that -overrides the default. - -It is possible to change @code{french-currency-string} so that it mostly -works without changing @code{currency-string}, but the fix is inelegant, -and susceptible to interrupts that could leave the -@code{currency-abbreviation} variable in the wrong state: - -@lisp -(define (french-currency-string units hundredths) - (set! currency-abbreviation "FRF") - (let ((result (currency-string units hundredths))) - (set! currency-abbreviation "USD") - result)) -@end lisp - -The key point here is that the code does not create any local binding -for the identifier @code{currency-abbreviation}, so all occurences of -this identifier refer to the top level variable. - - -@node Closure -@subsection Closure - -Consider a @code{let} expression that doesn't contain any -@code{lambda}s: - -@lisp -(let ((s (/ (+ a b c) 2))) - (sqrt (* s (- s a) (- s b) (- s c)))) -@end lisp - -@noindent -When the Scheme interpreter evaluates this, it - -@itemize @bullet -@item -creates a new environment with a reference to the environment that was -current when it encountered the @code{let} - -@item -creates a variable binding for @code{s} in the new environment, with -value given by @code{(/ (+ a b c) 2)} - -@item -evaluates the expression in the body of the @code{let} in the context of -the new local environment, and remembers the value @code{V} - -@item -forgets the local environment - -@item -continues evaluating the expression that contained the @code{let}, using -the value @code{V} as the value of the @code{let} expression, in the -context of the containing environment. -@end itemize - -After the @code{let} expression has been evaluated, the local -environment that was created is simply forgotten, and there is no longer -any way to access the binding that was created in this environment. If -the same code is evaluated again, it will follow the same steps again, -creating a second new local environment that has no connection with the -first, and then forgetting this one as well. - -If the @code{let} body contains a @code{lambda} expression, however, the -local environment is @emph{not} forgotten. Instead, it becomes -associated with the procedure that is created by the @code{lambda} -expression, and is reinstated every time that that procedure is called. -In detail, this works as follows. - -@itemize @bullet -@item -When the Scheme interpreter evaluates a @code{lambda} expression, to -create a procedure object, it stores the current environment as part of -the procedure definition. - -@item -Then, whenever that procedure is called, the interpreter reinstates the -environment that is stored in the procedure definition and evaluates the -procedure body within the context of that environment. -@end itemize - -The result is that the procedure body is always evaluated in the context -of the environment that was current when the procedure was created. - -This is what is meant by @dfn{closure}. The next few subsections -present examples that explore the usefulness of this concept. - - -@node Serial Number -@subsection Example 1: A Serial Number Generator - -This example uses closure to create a procedure with a variable binding -that is private to the procedure, like a local variable, but whose value -persists between procedure calls. - -@lisp -(define (make-serial-number-generator) - (let ((current-serial-number 0)) - (lambda () - (set! current-serial-number (+ current-serial-number 1)) - current-serial-number))) - -(define entry-sn-generator (make-serial-number-generator)) - -(entry-sn-generator) -@result{} -1 - -(entry-sn-generator) -@result{} -2 -@end lisp - -When @code{make-serial-number-generator} is called, it creates a local -environment with a binding for @code{current-serial-number} whose -initial value is 0, then, within this environment, creates a procedure. -The local environment is stored within the created procedure object and -so persists for the lifetime of the created procedure. - -Every time the created procedure is invoked, it increments the value of -the @code{current-serial-number} binding in the captured environment and -then returns the current value. - -Note that @code{make-serial-number-generator} can be called again to -create a second serial number generator that is independent of the -first. Every new invocation of @code{make-serial-number-generator} -creates a new local @code{let} environment and returns a new procedure -object with an association to this environment. - - -@node Shared Variable -@subsection Example 2: A Shared Persistent Variable - -This example uses closure to create two procedures, @code{get-balance} -and @code{deposit}, that both refer to the same captured local -environment so that they can both access the @code{balance} variable -binding inside that environment. The value of this variable binding -persists between calls to either procedure. - -Note that the captured @code{balance} variable binding is private to -these two procedures: it is not directly accessible to any other code. -It can only be accessed indirectly via @code{get-balance} or -@code{deposit}, as illustrated by the @code{withdraw} procedure. - -@lisp -(define get-balance #f) -(define deposit #f) - -(let ((balance 0)) - (set! get-balance - (lambda () - balance)) - (set! deposit - (lambda (amount) - (set! balance (+ balance amount)) - balance))) - -(define (withdraw amount) - (deposit (- amount))) - -(get-balance) -@result{} -0 - -(deposit 50) -@result{} -50 - -(withdraw 75) -@result{} --25 -@end lisp - -A detail here is that the @code{get-balance} and @code{deposit} -variables must be set up by @code{define}ing them at top level and then -@code{set!}ing their values inside the @code{let} body. Using -@code{define} within the @code{let} body would not work: this would -create variable bindings within the local @code{let} environment that -would not be accessible at top level. - - -@node Callback Closure -@subsection Example 3: The Callback Closure Problem - -A frequently used programming model for library code is to allow an -application to register a callback function for the library to call when -some particular event occurs. It is often useful for the application to -make several such registrations using the same callback function, for -example if several similar library events can be handled using the same -application code, but the need then arises to distinguish the callback -function calls that are associated with one callback registration from -those that are associated with different callback registrations. - -In languages without the ability to create functions dynamically, this -problem is usually solved by passing a @code{user_data} parameter on the -registration call, and including the value of this parameter as one of -the parameters on the callback function. Here is an example of -declarations using this solution in C: - -@example -typedef void (event_handler_t) (int event_type, - void *user_data); - -void register_callback (int event_type, - event_handler_t *handler, - void *user_data); -@end example - -In Scheme, closure can be used to achieve the same functionality without -requiring the library code to store a @code{user-data} for each callback -registration. - -@lisp -;; In the library: - -(define (register-callback event-type handler-proc) - @dots{}) - -;; In the application: - -(define (make-handler event-type user-data) - (lambda () - @dots{} - - @dots{})) - -(register-callback event-type - (make-handler event-type @dots{})) -@end lisp - -As far as the library is concerned, @code{handler-proc} is a procedure -with no arguments, and all the library has to do is call it when the -appropriate event occurs. From the application's point of view, though, -the handler procedure has used closure to capture an environment that -includes all the context that the handler code needs --- -@code{event-type} and @code{user-data} --- to handle the event -correctly. - - -@node OO Closure -@subsection Example 4: Object Orientation - -Closure is the capture of an environment, containing persistent variable -bindings, within the definition of a procedure or a set of related -procedures. This is rather similar to the idea in some object oriented -languages of encapsulating a set of related data variables inside an -``object'', together with a set of ``methods'' that operate on the -encapsulated data. The following example shows how closure can be used -to emulate the ideas of objects, methods and encapsulation in Scheme. - -@lisp -(define (make-account) - (let ((balance 0)) - (define (get-balance) - balance) - (define (deposit amount) - (set! balance (+ balance amount)) - balance) - (define (withdraw amount) - (deposit (- amount))) - - (lambda args - (apply - (case (car args) - ((get-balance) get-balance) - ((deposit) deposit) - ((withdraw) withdraw) - (else (error "Invalid method!"))) - (cdr args))))) -@end lisp - -Each call to @code{make-account} creates and returns a new procedure, -created by the expression in the example code that begins ``(lambda -args''. - -@lisp -(define my-account (make-account)) - -my-account -@result{} -# -@end lisp - -This procedure acts as an account object with methods -@code{get-balance}, @code{deposit} and @code{withdraw}. To apply one of -the methods to the account, you call the procedure with a symbol -indicating the required method as the first parameter, followed by any -other parameters that are required by that method. - -@lisp -(my-account 'get-balance) -@result{} -0 - -(my-account 'withdraw 5) -@result{} --5 - -(my-account 'deposit 396) -@result{} -391 - -(my-account 'get-balance) -@result{} -391 -@end lisp - -Note how, in this example, both the current balance and the helper -procedures @code{get-balance}, @code{deposit} and @code{withdraw}, used -to implement the guts of the account object's methods, are all stored in -variable bindings within the private local environment captured by the -@code{lambda} expression that creates the account object procedure. - - -@c Local Variables: -@c TeX-master: "guile.texi" -@c End: diff --git a/doc/scheme-modules.texi b/doc/scheme-modules.texi index 63c86f5c4..293ab0517 100644 --- a/doc/scheme-modules.texi +++ b/doc/scheme-modules.texi @@ -394,38 +394,38 @@ Mikael Djurfeldt's source-level debugging support for Guile Guile's support for multi threaded execution (@pxref{Scheduling}). @item (ice-9 rdelim) -Line- and character-delimited input (REFFIXME). +Line- and character-delimited input (@pxref{Line/Delimited}). @item (ice-9 documentation) Online documentation (REFFIXME). @item (srfi srfi-2) -Support for @code{and-let*} (REFFIXME). +Support for @code{and-let*} (@pxref{SRFI-2}). @item (srfi srfi-6) -Support for some additional string port procedures (REFFIXME). +Support for some additional string port procedures (@pxref{SRFI-6}). @item (srfi srfi-8) -Multiple-value handling with @code{receive} (REFFIXME). +Multiple-value handling with @code{receive} (@pxref{SRFI-8}). @item (srfi srfi-9) -Record definition with @code{define-record-type} (REFFIXME). +Record definition with @code{define-record-type} (@pxref{SRFI-9}). @item (srfi srfi-10) -Read hash extension @code{#,()} (REFFIXME). +Read hash extension @code{#,()} (@pxref{SRFI-10}). @item (srfi srfi-11) Multiple-value handling with @code{let-values} and @code{let-values*} -(REFFIXME). +(@pxref{SRFI-11}). @item (srfi srfi-13) -String library (REFFIXME). +String library (@pxref{SRFI-13}). @item (srfi srfi-14) -Character-set library (REFFIXME). +Character-set library (@pxref{SRFI-14}). @item (srfi srfi-17) -Getter-with-setter support (REFFIXME). +Getter-with-setter support (@pxref{SRFI-17}). @item (ice-9 slib) This module contains hooks for using Aubrey Jaffer's portable Scheme diff --git a/doc/scheme-procedures.texi b/doc/scheme-procedures.texi index 2dc28968f..e69de29bb 100644 --- a/doc/scheme-procedures.texi +++ b/doc/scheme-procedures.texi @@ -1,779 +0,0 @@ -@page -@node Procedures and Macros -@chapter Procedures and Macros - -@menu -* Lambda:: Basic procedure creation using lambda. -* Optional Arguments:: Handling keyword, optional and rest arguments. -* Procedure Properties:: Procedure properties and metainformation. -* Procedures with Setters:: Procedures with setters. -* Macros:: Lisp style macro definitions. -* Syntax Rules:: Support for R5RS @code{syntax-rules}. -* Syntax Case:: Support for the @code{syntax-case} system. -* Internal Macros:: Guile's internal representation. -@end menu - - -@node Lambda -@section Lambda: Basic Procedure Creation - -@c FIXME::martin: Review me! - -A @code{lambda} expression evaluates to a procedure. The environment -which is in effect when a @code{lambda} expression is evaluated is -enclosed in the newly created procedure, this is referred to as a -@dfn{closure} (@pxref{About Closure}). - -When a procedure created by @code{lambda} is called with some actual -arguments, the environment enclosed in the procedure is extended by -binding the variables named in the formal argument list to new locations -and storing the actual arguments into these locations. Then the body of -the @code{lambda} expression is evaluation sequentially. The result of -the last expression in the procedure body is then the result of the -procedure invocation. - -The following examples will show how procedures can be created using -@code{lambda}, and what you can do with these procedures. - -@lisp -(lambda (x) (+ x x)) @result{} @r{a procedure} -((lambda (x) (+ x x)) 4) @result{} 8 -@end lisp - -The fact that the environment in effect when creating a procedure is -enclosed in the procedure is shown with this example: - -@lisp -(define add4 - (let ((x 4)) - (lambda (y) (+ x y)))) -(add4 6) @result{} 10 -@end lisp - - -@deffn syntax lambda formals body -@var{formals} should be a formal argument list as described in the -following table. - -@table @code -@item (@var{variable1} @dots{}) -The procedure takes a fixed number of arguments; when the procedure is -called, the arguments will be stored into the newly created location for -the formal variables. -@item @var{variable} -The procedure takes any number of arguments; when the procedure is -called, the sequence of actual arguments will converted into a list and -stored into the newly created location for the formal variable. -@item (@var{variable1} @dots{} @var{variablen} . @var{variablen+1}) -If a space-delimited period precedes the last variable, then the -procedure takes @var{n} or more variablesm where @var{n} is the number -of formal arguments before the period. There must be at least one -argument before the period. The first @var{n} actual arguments will be -stored into the newly allocated locations for the first @var{n} formal -arguments and the sequence of the remaining actual arguments is -converted into a list and the stored into the location for the last -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 - -@var{body} is a sequence of Scheme expressions which are evaluated in -order when the procedure is invoked. -@end deffn - - -@node Optional Arguments -@section Optional Arguments - -@c FIXME::martin: Review me! - -Scheme procedures, as defined in R5RS, can wither handle a fixed number -of actual arguments, or a fixed number of actual arguments followed by -arbitrarily many additional arguments. Writing procedures of variable -arity can be useful, but unfortunately, the syntactic means for handling -argument lists of varying length is a bit inconvenient. It is possible -to give names to the fixed number of argument, but the remaining -(optional) arguments can be only referenced as a list of values -(@pxref{Lambda}). - -Guile comes with the module @code{(ice-9 optargs)}, which makes using -optional arguments much more convenient. In addition, this module -provides syntax for handling keywords in argument lists -(@pxref{Keywords}). - -Before using any of the procedures or macros defined in this section, -you have to load the module @code{(ice-9 optargs)} with the statement: - -@lisp -(use-modules (ice-9 optargs)) -@end lisp - -@menu -* let-optional Reference:: Locally binding optional arguments. -* let-keywords Reference:: Locally binding keywords arguments. -* lambda* Reference:: Creating advanced argument handling procedures. -* define* Reference:: Defining procedures and macros. -@end menu - - -@node let-optional Reference -@subsection let-optional Reference - -@c FIXME::martin: Review me! - -The syntax @code{let-optional} and @code{let-optional*} are for -destructuring rest argument lists and giving names to the various list -elements. @code{let-optional} binds all variables simultaneously, while -@code{let-optional*} binds them sequentially, consistent with @code{let} -and @code{let*} (REFFIXME). - -@deffn {libary syntax} let-optional rest-arg (binding @dots{}) expr @dots{} -@deffnx {library syntax} let-optional* rest-arg (binding @dots{}) expr @dots{} -These two macros give you an optional argument interface that is very -@dfn{Schemey} and introduces no fancy syntax. They are compatible with -the scsh macros of the same name, but are slightly extended. Each of -@var{binding} may be of one of the forms @var{var} or @code{(@var{var} -@var{default-value})}. @var{rest-arg} should be the rest-argument of the -procedures these are used from. The items in @var{rest-arg} are -sequentially bound to the variable names are given. When @var{rest-arg} -runs out, the remaining vars are bound either to the default values or -left unbound if no default value was specified. @var{rest-arg} remains -bound to whatever may have been left of @var{rest-arg}. - -After binding the variables, the expressions @var{expr} @dots{} are -evaluated in order. -@end deffn - - -@node let-keywords Reference -@subsection let-keywords Reference - -@c FIXME::martin: Review me! - -@code{let-keywords} and @code{let-keywords*} are used for extracting -values from argument lists which use keywords instead of argument -position for binding local variables to argument values. - -@code{let-keywords} binds all variables simultaneously, while -@code{let-keywords*} binds them sequentially, consistent with @code{let} -and @code{let*} (REFFIXME). - -@deffn {library syntax} let-keywords rest-arg allow-other-keys? (binding @dots{}) expr @dots{} -@deffnx {library syntax} let-keywords rest-arg allow-other-keys? (binding @dots{}) expr @dots{} -These macros pick out keyword arguments from @var{rest-arg}, but do not -modify it. This is consistent at least with Common Lisp, which -duplicates keyword arguments in the rest argument. More explanation of what -keyword arguments in a lambda list look like can be found below in -the documentation for @code{lambda*} - (@pxref{lambda* Reference}). @var{binding}s can have the same form as -for @code{let-optional}. If @var{allow-other-keys?} is false, an error -will be thrown if anything that looks like a keyword argument but does -not match a known keyword parameter will result in an error. - -After binding the variables, the expressions @var{expr} @dots{} are -evaluated in order. -@end deffn - - -@node lambda* Reference -@subsection lambda* Reference - -@c FIXME::martin: Review me! - -When using optional and keyword argument lists, using @code{lambda} for -creating procedures and using @code{let-optional} or @code{let-keywords} -is a bit lengthy. Therefore, @code{lambda*} is provided, which combines -the features of those macros into a single convenient syntax. - -For quick reference, here is the syntax of the formal argument list for -@code{lambda*} (brackets are used to indicate grouping only): - -@example -ext-param-list ::= [identifier]* [#:optional [ext-var-decl]+]? - [#:key [ext-var-decl]+ [#:allow-other-keys]?]? - [[#:rest identifier]|[. identifier]]? - -ext-var-decl ::= identifier | ( identifier expression ) -@end example - -The characters `*', `+' and `?' are not to be taken literally; they mean -respectively, zero or more occurences, one or more occurences, and one -or zero occurences. - -@deffn {library syntax} lambda* formals body -@code{lambda*} creates a procedure that takes optional arguments. These -are specified by putting them inside brackets at the end of the -paramater list, but before any dotted rest argument. For example, - -@lisp -(lambda* (a b #:optional c d . e) '()) -@end lisp - -creates a procedure with fixed arguments @var{a} and @var{b}, optional -arguments @var{c} and @var{d}, and rest argument @var{e}. If the -optional arguments are omitted in a call, the variables for them are -unbound in the procedure. This can be checked with the @code{bound?} -macro (documented below). - -@code{lambda*} can also take keyword arguments. For example, a procedure -defined like this: - -@lisp -(lambda* (#:key xyzzy larch) '()) -@end lisp - -can be called with any of the argument lists @code{(#:xyzzy 11)} -@code{(#:larch 13)} @code{(#:larch 42 #:xyzzy 19)} @code{()}. Whichever -arguments are given as keywords are bound to values. - -Optional and keyword arguments can also be given default values -which they take on when they are not present in a call, by giving a -two-item list in place of an optional argument, for example in: - -@lisp -(lambda* (foo #:optional (bar 42) #:key (baz 73)) - (list foo bar baz)) -@end lisp - -@var{foo} is a fixed argument, @var{bar} is an optional argument with -default value 42, and baz is a keyword argument with default value 73. -Default value expressions are not evaluated unless they are needed and -until the procedure is called. - -@code{lambda*} also supports two more special parameter list keywords. - -@code{lambda*}-defined procedures now throw an error by default if a -keyword other than one of those specified is found in the actual -passed arguments. However, specifying @code{#:allow-other-keys} -immediately after the keyword argument declarations restores the -previous behavior of ignoring unknown keywords. @code{lambda*} also now -guarantees that if the same keyword is passed more than once, the -last one passed is the one that takes effect. For example, - -@lisp -((lambda* (#:key (heads 0) (tails 0)) (display (list heads tails))) - #:heads 37 #:tails 42 #:heads 99) -@end lisp - -would result in (99 47) being displayed. - -@code{#:rest} is also now provided as a synonym for the dotted syntax -rest argument. The argument lists @code{(a . b)} and @code{(a #:rest b)} -are equivalent in all respects to @code{lambda*}. This is provided for -more similarity to DSSSL, MIT-Scheme and Kawa among others, as well as -for refugees from other Lisp dialects. -@end deffn - -@deffn {library syntax} bound? variable -Check if a variable is bound in the current environment. - -The procedure @code{defined?} doesn't quite cut it as it stands, since -it only checks bindings in the top-level environment, not those in local -scope only. -@end deffn - - -@node define* Reference -@subsection define* Reference - -@c FIXME::martin: Review me! - -Just like @code{define} has a shorthand notation for defining procedures -(@pxref{Lambda Alternatives}), @code{define*} is provided as an -abbreviation of the combination of @code{define} and @code{lambda*}. - -@code{define*-public} is the @code{lambda*} version of -@code{define-public}; @code{defmacro*} and @code{defmacro*-public} exist -for defining macros with the improved argument list handling -possibilities. The @code{-public} versions not only define the -procedures/macros, but also export them from the current module. - -@deffn {library syntax} define* formals body -@deffnx {library syntax} define*-public formals body -@code{define*} and @code{define*-public} support optional arguments with -a similar syntax to @code{lambda*}. They also support arbitrary-depth -currying, just like Guile's define. Some examples: - -@lisp -(define* (x y #:optional a (z 3) #:key w . u) - (display (list y z u))) -@end lisp -defines a procedure @code{x} with a fixed argument @var{y}, an optional -agument @var{a}, another optional argument @var{z} with default value 3, -a keyword argument @var{w}, and a rest argument @var{u}. - -@lisp -(define-public* ((foo #:optional bar) #:optional baz) '()) -@end lisp - -This illustrates currying. A procedure @code{foo} is defined, which, -when called with an optional argument @var{bar}, returns a procedure -that takes an optional argument @var{baz}. - -Of course, @code{define*[-public]} also supports @code{#:rest} and -@code{#:allow-other-keys} in the same way as @code{lambda*}. -@end deffn - -@deffn {library syntax} defmacro* name formals body -@deffnx {library syntax} defmacro*-public name formals body -These are just like @code{defmacro} and @code{defmacro-public} except that they -take @code{lambda*}-style extended paramter lists, where @code{#:optional}, -@code{#:key}, @code{#:allow-other-keys} and @code{#:rest} are allowed with the usual -semantics. Here is an example of a macro with an optional argument: - -@lisp -(defmacro* transmorgify (a #:optional b) - (a 1)) -@end lisp -@end deffn - - -@node Procedure Properties -@section Procedure Properties and Metainformation - -@c FIXME::martin: Review me! - -Procedures always have attached the environment in which they were -created and information about how to apply them to actual arguments. In -addition to that, properties and metainformation can be stored with -procedures. The procedures in this section can be used to test whether -a given procedure satisfies a condition; and to access and set a -procedure's property. - -The first group of procedures are predicates to test whether a Scheme -object is a procedure, or a special procedure, respectively. -@code{procedure?} is the most general predicates, it returns @code{#t} -for any kind of procedure. @code{closure?} does not return @code{#t} -for primitive procedures, and @code{thunk?} only returns @code{#t} for -procedures which do not accept any arguments. -@c FIXME::martin: thunk? returns true for `id'. What's wrong here? - -@rnindex procedure? -@deffn primitive procedure? obj -Return @code{#t} if @var{obj} is a procedure. -@end deffn - -@deffn primitive closure? obj -Return @code{#t} if @var{obj} is a closure. -@end deffn - -@deffn primitive thunk? obj -Return @code{#t} if @var{obj} is a thunk. -@end deffn - -@c FIXME::martin: Is that true? -@cindex procedure properties -Procedure properties are general properties to be attached to -procedures. These can be the name of a procedure or other relevant -information, such as debug hints. - -@deffn primitive procedure-properties proc -Return @var{obj}'s property list. -@end deffn - -@deffn primitive procedure-property p k -Return the property of @var{obj} with name @var{key}. -@end deffn - -@deffn primitive set-procedure-properties! proc new_val -Set @var{obj}'s property list to @var{alist}. -@end deffn - -@deffn primitive set-procedure-property! p k v -In @var{obj}'s property list, set the property named @var{key} to -@var{value}. -@end deffn - -@cindex procedure documentation -Documentation for a procedure can be accessed with the procedure -@code{procedure-documentation}. - -@deffn primitive procedure-documentation proc -Return the documentation string associated with @code{proc}. By -convention, if a procedure contains more than one expression and the -first expression is a string constant, that string is assumed to contain -documentation for that procedure. -@end deffn - -@cindex source properties -@c FIXME::martin: Is the following true? -Source properties are properties which are related to the source code of -a procedure, such as the line and column numbers, the file name etc. - -@deffn primitive set-source-properties! obj plist -Install the association list @var{plist} as the source property -list for @var{obj}. -@end deffn - -@deffn primitive set-source-property! obj key datum -Set the source property of object @var{obj}, which is specified by -@var{key} to @var{datum}. Normally, the key will be a symbol. -@end deffn - -@deffn primitive source-properties obj -Return the source property association list of @var{obj}. -@end deffn - - -@deffn primitive source-property obj key -Return the source property specified by @var{key} from -@var{obj}'s source property list. -@end deffn - - -@node Procedures with Setters -@section Procedures with Setters - -@c FIXME::martin: Review me! - -@c FIXME::martin: Document `operator struct'. - -@cindex procedure with setter -@cindex setter -A @dfn{procedure with setter} is a special kind of procedure which -normally behaves like any accesor procedure, that is a procedure which -accesses a data structure. The difference is that this kind of -procedure has a so-called @dfn{setter} attached, which is a procedure -for storing something into a data structure. - -Procedures with setters are treated specially when the procedure appears -in the special form @code{set!} (REFFIXME). How it works is best shown -by example. - -Suppose we have a procedure called @code{foo-ref}, which accepts two -arguments, a value of type @code{foo} and an integer. The procedure -returns the value stored at the given index in the @code{foo} object. -Let @code{f} be a variable containing such a @code{foo} data -structure.@footnote{Working definitions would be: -@lisp -(define foo-ref vector-ref) -(define foo-set! vector-set!) -(define f (make-vector 2 #f)) -@end lisp -} - -@lisp -(foo-ref f 0) @result{} bar -(foo-ref f 1) @result{} braz -@end lisp - -Also suppose that a corresponding setter procedure called -@code{foo-set!} does exist. - -@lisp -(foo-set! f 0 'bla) -(foo-ref f 0) @result{} bla -@end lisp - -Now we could create a new procedure called @code{foo}, which is a -procedure with setter, by calling @code{make-procedure-with-setter} with -the accessor and setter procedures @code{foo-ref} and @code{foo-set!}. -Let us call this new procedure @code{foo}. - -@lisp -(define foo (make-procedure-with-setter foo-ref foo-set!)) -@end lisp - -@code{foo} can from now an be used to either read from the data -structure stored in @code{f}, or to write into the structure. - -@lisp -(set! (foo f 0) 'dum) -(foo f 0) @result{} dum -@end lisp - -@deffn primitive make-procedure-with-setter procedure setter -Create a new procedure which behaves like @var{procedure}, but -with the associated setter @var{setter}. -@end deffn - -@deffn primitive procedure-with-setter? obj -Return @code{#t} if @var{obj} is a procedure with an -associated setter procedure. -@end deffn - -@deffn primitive procedure proc -Return the procedure of @var{proc}, which must be either a -procedure with setter, or an operator struct. -@end deffn - -@deffn primitive setter proc -Return the setter of @var{proc}, which must be either a procedure with -setter or an operator struct. -@end deffn - - -@node Macros -@section Lisp Style Macro Definitions - -@cindex macros -@cindex transformation -Macros are objects which cause the expression that they appear in to be -transformed in some way @emph{before} being evaluated. In expressions -that are intended for macro transformation, the identifier that names -the relevant macro must appear as the first element, like this: - -@lisp -(@var{macro-name} @var{macro-args} @dots{}) -@end lisp - -In Lisp-like languages, the traditional way to define macros is very -similar to procedure definitions. The key differences are that the -macro definition body should return a list that describes the -transformed expression, and that the definition is marked as a macro -definition (rather than a procedure definition) by the use of a -different definition keyword: in Lisp, @code{defmacro} rather than -@code{defun}, and in Scheme, @code{define-macro} rather than -@code{define}. - -@fnindex defmacro -@fnindex define-macro -Guile supports this style of macro definition using both @code{defmacro} -and @code{define-macro}. The only difference between them is how the -macro name and arguments are grouped together in the definition: - -@lisp -(defmacro @var{name} (@var{args} @dots{}) @var{body} @dots{}) -@end lisp - -@noindent -is the same as - -@lisp -(define-macro (@var{name} @var{args} @dots{}) @var{body} @dots{}) -@end lisp - -@noindent -The difference is analogous to the corresponding difference between -Lisp's @code{defun} and Scheme's @code{define}. - -@code{false-if-exception}, from the @file{boot-9.scm} file in the Guile -distribution, is a good example of macro definition using -@code{defmacro}: - -@lisp -(defmacro false-if-exception (expr) - `(catch #t - (lambda () ,expr) - (lambda args #f))) -@end lisp - -@noindent -The effect of this definition is that expressions beginning with the -identifier @code{false-if-exception} are automatically transformed into -a @code{catch} expression following the macro definition specification. -For example: - -@lisp -(false-if-exception (open-input-file "may-not-exist")) -@equiv{} -(catch #t - (lambda () (open-input-file "may-not-exist")) - (lambda args #f)) -@end lisp - - -@node Syntax Rules -@section The R5RS @code{syntax-rules} System - -R5RS defines an alternative system for macro and syntax transformations -using the keywords @code{define-syntax}, @code{let-syntax}, -@code{letrec-syntax} and @code{syntax-rules}. - -The main difference between the R5RS system and the traditional macros -of the previous section is how the transformation is specified. In -R5RS, rather than permitting a macro definition to return an arbitrary -expression, the transformation is specified in a pattern language that - -@itemize @bullet -@item -does not require complicated quoting and extraction of components of the -source expression using @code{caddr} etc. - -@item -is designed such that the bindings associated with identifiers in the -transformed expression are well defined, and such that it is impossible -for the transformed expression to construct new identifiers. -@end itemize - -@noindent -The last point is commonly referred to as being @dfn{hygienic}: the R5RS -@code{syntax-case} system provides @dfn{hygienic macros}. - -For example, the R5RS pattern language for the @code{false-if-exception} -example of the previous section looks like this: - -@lisp -(syntax-rules () - ((_ expr) - (catch #t - (lambda () expr) - (lambda args #f)))) -@end lisp - -In Guile, the @code{syntax-rules} system is provided by the @code{(ice-9 -syncase)} module. To make these facilities available in your code, -include the expression @code{(use-modules (ice-9 syncase))} or -@code{(use-syntax (ice-9 syncase))} (@pxref{Using Guile Modules}) -before the first usage of @code{define-syntax} etc. If you are writing -a Scheme module, you can alternatively use one of the keywords -@code{#:use-module} and @code{#:use-syntax} in your @code{define-module} -declaration (@pxref{Creating Guile Modules}). - -@menu -* Pattern Language:: The @code{syntax-rules} pattern language. -* Define-Syntax:: Top level syntax definitions. -* Let-Syntax:: Local syntax definitions. -@end menu - - -@node Pattern Language -@subsection The @code{syntax-rules} Pattern Language - - -@node Define-Syntax -@subsection Top Level Syntax Definitions - -define-syntax: The gist is - - (define-syntax ) - -makes the into a macro so that - - ( ...) - -expands at _compile_ or _read_ time (i.e. before any -evaluation begins) into some expression that is -given by the . - - -@node Let-Syntax -@subsection Local Syntax Definitions - - -@node Syntax Case -@section Support for the @code{syntax-case} System - - - -@node Internal Macros -@section Internal Representation of Macros and Syntax - -Internally, Guile uses three different flavours of macros. The three -flavours are called @dfn{acro} (or @dfn{syntax}), @dfn{macro} and -@dfn{mmacro}. - -Given the expression - -@lisp -(foo @dots{}) -@end lisp - -@noindent -with @code{foo} being some flavour of macro, one of the following things -will happen when the expression is evaluated. - -@itemize @bullet -@item -When @code{foo} has been defined to be an @dfn{acro}, the procedure used -in the acro definition of @code{foo} is passed the whole expression and -the current lexical environment, and whatever that procedure returns is -the value of evaluating the expression. You can think of this a -procedure that receives its argument as an unevaluated expression. - -@item -When @code{foo} has been defined to be a @dfn{macro}, the procedure used -in the macro definition of @code{foo} is passed the whole expression and -the current lexical environment, and whatever that procedure returns is -evaluated again. That is, the procedure should return a valid Scheme -expression. - -@item -When @code{foo} has been defined to be a @dfn{mmacro}, the procedure -used in the mmacro definition of `foo' is passed the whole expression -and the current lexical environment, and whatever that procedure returns -replaces the original expression. Evaluation then starts over from the -new expression that has just been returned. -@end itemize - -The key difference between a @dfn{macro} and a @dfn{mmacro} is that the -expression returned by a @dfn{mmacro} procedure is remembered (or -@dfn{memoized}) so that the expansion does not need to be done again -next time the containing code is evaluated. - -The primitives @code{procedure->syntax}, @code{procedure->macro} and -@code{procedure->memoizing-macro} are used to construct acros, macros -and mmacros respectively. However, if you do not have a very special -reason to use one of these primitives, you should avoid them: they are -very specific to Guile's current implementation and therefore likely to -change. Use @code{defmacro}, @code{define-macro} (@pxref{Macros}) or -@code{define-syntax} (@pxref{Syntax Rules}) instead. (In low level -terms, @code{defmacro}, @code{define-macro} and @code{define-syntax} are -all implemented as mmacros.) - -@deffn primitive procedure->syntax code -Return a macro which, when a symbol defined to this value appears as the -first symbol in an expression, returns the result of applying @var{code} -to the expression and the environment. -@end deffn - -@deffn primitive procedure->macro code -Return a macro which, when a symbol defined to this value appears as the -first symbol in an expression, evaluates the result of applying -@var{code} to the expression and the environment. For example: - -@lisp -(define trace - (procedure->macro - (lambda (x env) - `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x)))))) - -(trace @i{foo}) -@equiv{} -(set! @i{foo} (tracef @i{foo} '@i{foo})). -@end lisp -@end deffn - -@deffn primitive procedure->memoizing-macro code -Return a macro which, when a symbol defined to this value appears as the -first symbol in an expression, evaluates the result of applying -@var{code} to the expression and the environment. -@code{procedure->memoizing-macro} is the same as -@code{procedure->macro}, except that the expression returned by -@var{code} replaces the original macro expression in the memoized form -of the containing code. -@end deffn - -In the following primitives, @dfn{acro} flavour macros are referred to -as @dfn{syntax transformers}. - -@deffn primitive macro? obj -Return @code{#t} if @var{obj} is a regular macro, a memoizing macro or a -syntax transformer. -@end deffn - -@deffn primitive macro-type m -Return one of the symbols @code{syntax}, @code{macro} or -@code{macro!}, depending on whether @var{m} is a syntax -transformer, a regular macro, or a memoizing macro, -respectively. If @var{m} is not a macro, @code{#f} is -returned. -@end deffn - -@deffn primitive macro-name m -Return the name of the macro @var{m}. -@end deffn - -@deffn primitive macro-transformer m -Return the transformer of the macro @var{m}. -@end deffn - -@deffn primitive cons-source xorig x y -Create and return a new pair whose car and cdr are @var{x} and @var{y}. -Any source properties associated with @var{xorig} are also associated -with the new pair. -@end deffn - - -@c Local Variables: -@c TeX-master: "guile.texi" -@c End: diff --git a/doc/srfi-modules.texi b/doc/srfi-modules.texi index 8c9543889..da2cefee0 100644 --- a/doc/srfi-modules.texi +++ b/doc/srfi-modules.texi @@ -1,6 +1,6 @@ @page @node SRFI Support -@chapter Various SRFI Support Modules +@chapter SRFI Support Modules SRFI is an acronym for Scheme Request For Implementation. The SRFI documents define a lot of syntactic and procedure extensions to standard @@ -13,6 +13,7 @@ get the relevant SRFI documents from the SRFI home page @url{http://srfi.schemers.org}. @menu +* About SRFI Usage:: What to know about Guile's SRFI support. * SRFI-0:: cond-expand * SRFI-2:: and-let*. * SRFI-6:: Basic String Ports. @@ -27,6 +28,40 @@ get the relevant SRFI documents from the SRFI home page @end menu +@node About SRFI Usage +@section About SRFI Usage + +@c FIXME::martin: Review me! + +SRFI support in Guile is currently implemented partly in the core +library, and partly as add-on modules. That means that some SRFIs are +automatically available when the interpreter is started, whereas the +other SRFIs require you to use the appropriate support module +explicitly. + +There are several reasons for this inconsistency. First, the feature +checking syntactic form @code{cond-expand} (@pxref{SRFI-0}) must be +available immediately, because it must be there when the user wants to +check for the Scheme implementation, that is, before she can know that +it is safe to use @code{use-modules} to load SRFI support modules. The +second reason is that some features defined in SRFIs had been +implemented in Guile before the developers started to add SRFI +implementations as modules (for example SRFI-6 (@pxref{SRFI-6})). In +the future, it is possible that SRFIs in the core library might be +factored out into separate modules, requiring explicit module loading +when they are needed. So you should be prepared to have to use +@code{use-modules} someday in the future to access SRFI-6 bindings. If +you want, you can do that already. We have included the module +@code{(srfi srfi-6)} in the distribution, which currently does nothing, +but ensures that you can write future-safe code. + +Generally, support for a specific SRFI is made available by using +modules named @code{(srfi srfi-@var{number})}, where @var{number} is the +number of the SRFI needed. Another possibility is to use the command +line option @code{--use-srfi}, which will load the necessary modules +automatically (@pxref{Invoking Guile}). + + @node SRFI-0 @section SRFI-0 - cond-expand @@ -78,6 +113,8 @@ If the feature requirement is the keyword @code{else} and it is the last clause, it is satisfied if no prior clause matched. @end itemize +If no clause is satisfied, an error is signalled. + Since @code{cond-expand} is needed to tell what a Scheme implementation provides, it must be accessible without using any implementation-dependant operations, such as @code{use-modules} in @@ -85,11 +122,13 @@ Guile. Thus, it is not necessary to use any module to get access to this form. Currently, the feature identifiers @code{guile}, @code{r5rs} and -@code{srfi-0} are supported. The other SRFIs are not in that list, -because the SRFI modules must be explicitly used before their exported -bindings can be used. So if a Scheme program wishes to detect whether -SRFI-8 is supported in the running implementation, code similar to this -may be needed: +@code{srfi-0} are supported. The other SRFIs are not in that list by +default, because the SRFI modules must be explicitly used before their +exported bindings can be used. + +So if a Scheme program wishes to use SRFI-8, it has two possibilities: +First, it can check whether the running Scheme implementation is Guile, +and if it is, it can use the appropriate module: @lisp (cond-expand @@ -100,6 +139,23 @@ may be needed: ;; otherwise fail. @end lisp +The other possibility is to use the @code{--use-srfi} command line +option when invoking Guile (@pxref{Invoking Guile}). When you do that, +the specified SRFI support modules will be loaded and add their feature +identifier to the list of symbols checked by @code{cond-expand}. + +So, if you invoke Guile like this: + +@example +$ guile --use-srfi=8 +@end example + +the following snippet will expand to @code{'hooray}. + +@lisp +(cond-expand (srfi-8 'hooray)) +@end lisp + @node SRFI-2 @section SRFI-2 - and-let* @@ -154,7 +210,7 @@ procedures easier. It is documented in @xref{Multiple Values}. This is the SRFI way for defining record types. The Guile implementation is a layer above Guile's normal record construction -procedures (REFFIXME). The nice thing about this kind of record +procedures (@pxref{Records}). The nice thing about this kind of record definition method is that no new names are implicitly created, all constructor, accessor and predicates are explicitly given. This reduces the risk of variable capture. @@ -242,8 +298,8 @@ read in. The result of @var{proc} is returned by the Scheme reader. This module implements the binding forms for multiple values @code{let-values} and @code{let-values*}. These forms are similar to -@code{let} and @code{let*} (REFFIXME), but they support binding of the -values returned by multiple-valued expressions. +@code{let} and @code{let*} (@pxref{Local Bindings}), but they support +binding of the values returned by multiple-valued expressions. Write @code{(use-modules (srfi srfi-11))} to make the bindings available. @@ -272,7 +328,8 @@ In this section, we will describe all procedures defined in SRFI-13 Note that only the procedures from SRFI-13 are documented here which are not already contained in Guile. For procedures not documented here please refer to the relevant chapters in the Guile Reference Manual, for -example the documentation of strings and string procedures (REFFIXME). +example the documentation of strings and string procedures +(@pxref{Strings}). All of the procedures defined in SRFI-13, which are not already included in the Guile core library, are implemented in the module @code{(srfi @@ -387,7 +444,8 @@ produce the corresponding string element. The order in which The procedure @code{string->list} is extended by SRFI-13, that is why it is included in @code{(srfi srfi-13)}. The other procedures are new. The Guile core already contains the procedure @code{list->string} for -converting a list of characters into a string (REFFIXME). +converting a list of characters into a string (@pxref{List/String +Conversion}). @deffn primitive string->list str [start end] Convert the string @var{str} into a list of characters. @@ -436,7 +494,8 @@ These procedures are called @dfn{selectors}, because they access information about the string or select pieces of a given string. Additional selector procedures are documented in the Strings section -(REFFIXME), like @code{string-length} or @code{string-ref}. +(@pxref{String Selection}), like @code{string-length} or +@code{string-ref}. @code{string-copy} is also available in core Guile, but this version accepts additional start/end indices. @@ -512,7 +571,8 @@ trimmed. The procedure @code{string-fill!} is extended from R5RS because it accepts optional start/end indices. This bindings shadows the procedure of the same name in the Guile core. The second modification procedure -@code{string-set!} is documented in the Strings section (REFFIXME). +@code{string-set!} is documented in the Strings section (@pxref{String +Modification}). @deffn primitive string-fill! str chr [start end] Stores @var{chr} in every element of the given @var{str} and @@ -943,9 +1003,10 @@ guile> @node SRFI-14 Character Set Data Type @subsection Character Set Data Type -The data type @dfn{charset} implements sets of characters (REFFIXME). -Because the internal representation of character sets is not visible to -the user, a lot of procedures for handling them are provided. +The data type @dfn{charset} implements sets of characters +(@pxref{Characters}). Because the internal representation of character +sets is not visible to the user, a lot of procedures for handling them +are provided. Character sets can be created, extended, tested for the membership of a characters and be compared to other character sets. @@ -1327,8 +1388,8 @@ EBNF grammar. The value returned by a @code{case-lambda} form is a procedure which matches the number of actual arguments against the formals in the various clauses, in order. @dfn{Formals} means a formal argument list -just like with @code{lambda} (REFFIXME). The first matching clause is -selected, the corresponding values from the actual parameter list are +just like with @code{lambda} (@pxref{Lambda}). The first matching clause +is selected, the corresponding values from the actual parameter list are bound to the variable names in the clauses and the body of the clause is evaluated. If no clause matches, an error is signalled. @@ -1382,3 +1443,4 @@ the setter of a procedure. In fact, @code{(set! (setter @var{proc}) procedure is to create a new object (a @dfn{procedure with setter}) via the @code{getter-with-setter} procedure. This procedure is also specified in the SRFI. Using it avoids the described problems. + From 1be6b49ccb7b078813668f1decb186116e2e2d18 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Thu, 24 May 2001 00:50:51 +0000 Subject: [PATCH 1176/2047] * validate.h (SCM_NUM2{SIZE,PTRDIFF,SHORT,USHORT,BITS,UBITS,INT,UINT}[_DEF]): new macros. * unif.h: type renaming: scm_array -> scm_array_t scm_array_dim -> scm_array_dim_t the old names are deprecated, all in-Guile uses changed. * tags.h (scm_ubits_t): new typedef, representing unsigned scm_bits_t. * stacks.h: type renaming: scm_info_frame -> scm_info_frame_t scm_stack -> scm_stack_t the old names are deprecated, all in-Guile uses changed. * srcprop.h: type renaming: scm_srcprops -> scm_srcprops_t scm_srcprops_chunk -> scm_srcprops_chunk_t the old names are deprecated, all in-Guile uses changed. * gsubr.c, procs.c, print.c, ports.c, read.c, rdelim.c, ramap.c, rw.c, smob.c, sort.c, srcprop.c, stacks.c, strings.c, strop.c, strorder.c, strports.c, struct.c, symbols.c, unif.c, values.c, vectors.c, vports.c, weaks.c: various int/size_t -> size_t/scm_bits_t changes. * random.h: type renaming: scm_rstate -> scm_rstate_t scm_rng -> scm_rng_t scm_i_rstate -> scm_i_rstate_t the old names are deprecated, all in-Guile uses changed. * procs.h: type renaming: scm_subr_entry -> scm_subr_entry_t the old name is deprecated, all in-Guile uses changed. * options.h (scm_option_t.val): unsigned long -> scm_bits_t. type renaming: scm_option -> scm_option_t the old name is deprecated, all in-Guile uses changed. * objects.c: various long -> scm_bits_t changes. (scm_i_make_class_object): flags: unsigned long -> scm_ubits_t * numbers.h (SCM_FIXNUM_BIT): deprecated, renamed to SCM_I_FIXNUM_BIT. * num2integral.i.c: new file, multiply included by numbers.c, used to "templatize" the various integral <-> num conversion routines. * numbers.c (scm_mkbig, scm_big2num, scm_adjbig, scm_normbig, scm_copybig, scm_2ulong2big, scm_dbl2big, scm_big2dbl): deprecated. (scm_i_mkbig, scm_i_big2inum, scm_i_adjbig, scm_i_normbig, scm_i_copybig, scm_i_short2big, scm_i_ushort2big, scm_i_int2big, scm_i_uint2big, scm_i_long2big, scm_i_ulong2big, scm_i_bits2big, scm_i_ubits2big, scm_i_size2big, scm_i_ptrdiff2big, scm_i_long_long2big, scm_i_ulong_long2big, scm_i_dbl2big, scm_i_big2dbl, scm_short2num, scm_ushort2num, scm_int2num, scm_uint2num, scm_bits2num, scm_ubits2num, scm_size2num, scm_ptrdiff2num, scm_num2short, scm_num2ushort, scm_num2int, scm_num2uint, scm_num2bits, scm_num2ubits, scm_num2ptrdiff, scm_num2size): new functions. * modules.c (scm_module_reverse_lookup): i, n: int -> scm_bits_t.x * load.c: change int -> size_t in various places (where the variable is used to store a string length). (search-path): call scm_done_free, not scm_done_malloc. * list.c (scm_ilength): return a scm_bits_t, not long. some other {int,long} -> scm_bits_t changes. * hashtab.c: various [u]int -> scm_bits_t changes. scm_ihashx_closure -> scm_ihashx_closure_t (and made a typedef). (scm_ihashx): n: uint -> scm_bits_t use scm_bits2num instead of scm_ulong2num. * gsubr.c: various int -> scm_bits_t changes. * gh_data.c (gh_scm2double): no loss of precision any more. * gh.h (gh_str2scm): len: int -> size_t (gh_{get,set}_substr): start: int -> scm_bits_t, len: int -> size_t (gh_2scm): n: int -> scm_bits_t (gh_*vector_length): return scm_[u]size_t, not unsigned long. (gh_length): return scm_bits_t, not unsigned long. * fports.h: type renaming: scm_fport -> scm_fport_t the old name is deprecated, all in-Guile uses changed. * fports.c (fport_fill_input): count: int -> scm_bits_t (fport_flush): init_size, remaining, count: int -> scm_bits_t * debug.h (scm_lookup_cstr, scm_lookup_soft, scm_evstr): removed those prototypes, as the functions they prototype don't exist. * fports.c (default_buffer_size): int -> size_t (scm_fport_buffer_add): read_size, write_size: int -> scm_bits_t default_size: int -> size_t (scm_setvbuf): csize: int -> scm_bits_t * fluids.c (n_fluids): int -> scm_bits_t (grow_fluids): old_length, i: int -> scm_bits_t (next_fluid_num, scm_fluid_ref, scm_fluid_set_x): n: int -> scm_bits_t (scm_c_with_fluids): flen, vlen: int -> scm_bits_t * filesys.c (s_scm_open_fdes): changed calls to SCM_NUM2LONG to the new and shiny SCM_NUM2INT. * extensions.c: extension -> extension_t (and made a typedef). * eval.h (SCM_IFRAME): cast to scm_bits_t, not int. just so there are no nasty surprises if/when the various deeply magic tag bits move somewhere else. * eval.c: changed the locals used to store results of SCM_IFRAME, scm_ilength and such to be of type scm_bits_t (and not int/long). (iqq): depth, edepth: int -> scm_bits_t (scm_eval_stack): int -> scm_bits_t (SCM_CEVAL): various vars are not scm_bits_t instead of int. (check_map_args, scm_map, scm_for_each): len: long -> scm_bits_t i: int -> scm_bits_t * environments.c: changed the many calls to scm_ulong2num to scm_ubits2num. (import_environment_fold): proc_as_ul: ulong -> scm_ubits_t * dynwind.c (scm_dowinds): delta: long -> scm_bits_t * debug.h: type renaming: scm_debug_info -> scm_debug_info_t scm_debug_frame -> scm_debug_frame_t the old names are deprecated, all in-Guile uses changed. (scm_debug_eframe_size): int -> scm_bits_t * debug.c (scm_init_debug): use scm_c_define instead of the deprecated scm_define. * continuations.h: type renaming: scm_contregs -> scm_contregs_t the old name is deprecated, all in-Guile uses changed. (scm_contregs_t.num_stack_items): size_t -> scm_bits_t (scm_contregs_t.num_stack_items): ulong -> scm_ubits_t * continuations.c (scm_make_continuation): change the type of stack_size form long to scm_bits_t. * ports.h: type renaming: scm_port_rw_active -> scm_port_rw_active_t (and made a typedef) scm_port -> scm_port_t scm_ptob_descriptor -> scm_ptob_descriptor_t the old names are deprecated, all in-Guile uses changed. (scm_port_t.entry): int -> scm_bits_t. (scm_port_t.line_number): int -> long. (scm_port_t.putback_buf_size): int -> size_t. * __scm.h (long_long, ulong_long): deprecated (they pollute the global namespace and have little value besides that). (SCM_BITS_LENGTH): new, is the bit size of scm_bits_t (i.e. of an SCM handle). (ifdef spaghetti): include sys/types.h and sys/stdtypes.h, if they exist (for size_t & ptrdiff_t) (scm_sizet): deprecated. * Makefile.am (noinst_HEADERS): add num2integral.i.c --- ChangeLog | 9 + NEWS | 43 ++ RELEASE | 8 + acconfig.h | 8 + configure.in | 27 +- doc/scheme-data.texi | 2 +- guile-readline/ChangeLog | 4 + guile-readline/readline.c | 2 +- libguile/ChangeLog | 189 ++++++++ libguile/Makefile.am | 8 +- libguile/__scm.h | 24 +- libguile/backtrace.c | 2 +- libguile/continuations.c | 28 +- libguile/continuations.h | 16 +- libguile/coop-threads.c | 4 +- libguile/debug.c | 40 +- libguile/debug.h | 27 +- libguile/dynl.c | 2 +- libguile/dynwind.c | 4 +- libguile/dynwind.h | 2 +- libguile/environments.c | 48 +- libguile/environments.h | 2 +- libguile/error.c | 2 +- libguile/eval.c | 76 +-- libguile/eval.h | 10 +- libguile/extensions.c | 13 +- libguile/filesys.c | 14 +- libguile/fluids.c | 16 +- libguile/fports.c | 63 +-- libguile/fports.h | 10 +- libguile/gc.c | 420 ++++++++++------- libguile/gc.h | 42 +- libguile/gdbint.c | 2 +- libguile/gh.h | 32 +- libguile/gh_data.c | 73 ++- libguile/gh_list.c | 14 +- libguile/goops.c | 74 +-- libguile/goops.h | 4 +- libguile/gsubr.c | 19 +- libguile/gsubr.h | 6 +- libguile/guardians.c | 2 +- libguile/hash.c | 69 +-- libguile/hash.h | 10 +- libguile/hashtab.c | 66 +-- libguile/hashtab.h | 12 +- libguile/hooks.c | 2 +- libguile/init.c | 5 +- libguile/ioext.c | 20 +- libguile/list.c | 18 +- libguile/list.h | 2 +- libguile/load.c | 12 +- libguile/mallocs.c | 4 +- libguile/mallocs.h | 2 +- libguile/modules.c | 2 +- libguile/net_db.c | 10 +- libguile/num2integral.i.c | 165 +++++++ libguile/numbers.c | 848 +++++++++++++++------------------- libguile/numbers.h | 116 +++-- libguile/objects.c | 14 +- libguile/objects.h | 4 +- libguile/options.c | 6 +- libguile/options.h | 14 +- libguile/ports.c | 96 ++-- libguile/ports.h | 58 +-- libguile/posix.c | 4 +- libguile/print.c | 32 +- libguile/print.h | 2 +- libguile/procs.c | 32 +- libguile/procs.h | 22 +- libguile/ramap.c | 231 ++++----- libguile/random.c | 44 +- libguile/random.h | 50 +- libguile/rdelim.c | 30 +- libguile/read.c | 14 +- libguile/read.h | 4 +- libguile/regex-posix.c | 2 +- libguile/root.c | 4 +- libguile/root.h | 2 +- libguile/rw.c | 8 +- libguile/script.c | 10 +- libguile/simpos.c | 2 +- libguile/smob.c | 28 +- libguile/smob.h | 20 +- libguile/socket.c | 16 +- libguile/sort.c | 42 +- libguile/srcprop.c | 38 +- libguile/srcprop.h | 27 +- libguile/stackchk.c | 2 +- libguile/stacks.c | 81 ++-- libguile/stacks.h | 25 +- libguile/strings.c | 32 +- libguile/strings.h | 10 +- libguile/strop.c | 29 +- libguile/strorder.c | 12 +- libguile/strports.c | 26 +- libguile/struct.c | 14 +- libguile/struct.h | 12 +- libguile/symbols-deprecated.c | 16 +- libguile/symbols.c | 10 +- libguile/symbols.h | 14 +- libguile/tags.h | 3 +- libguile/throw.c | 2 +- libguile/unif.c | 385 ++++++++------- libguile/unif.h | 49 +- libguile/validate.h | 56 ++- libguile/values.c | 2 +- libguile/vectors.c | 52 +-- libguile/vectors.h | 10 +- libguile/vports.c | 6 +- libguile/weaks.c | 9 +- srfi/srfi-14.c | 2 +- test-suite/guile-test | 2 +- 112 files changed, 2577 insertions(+), 1894 deletions(-) create mode 100644 libguile/num2integral.i.c diff --git a/ChangeLog b/ChangeLog index 40ce4add6..7b04c5ab2 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +2001-05-23 Michael Livshin + + * configure.in: configury for SCM_[U]BITS_T, some more sizeofs. + also, make sure that the integral type choosen to represent an SCM + has exactly the same size as a void pointer. + + * acconfig.h: add undefs for SCM_BITS_T, SCM_UBITS_T, + SCM_SIZEOF_BITS_T, ptrdiff_t. + 2001-05-16 Rob Browning * configure.in: add AC_SUBST for GUILE_MICRO_VERSION. diff --git a/NEWS b/NEWS index 395da23df..9238563d1 100644 --- a/NEWS +++ b/NEWS @@ -940,6 +940,49 @@ scm_internal_with_fluids is available as a deprecated function. Just like scm_c_with_fluids, but takes one fluid and one value instead of lists of same. +** Deprecated typedefs: long_long, ulong_long. + +They are of questionable utility and they pollute the global +namespace. + +** New macro: SCM_BITS_LENGTH. + +The bit size of an SCM. + +** Deprecated typedef: scm_sizet + +It is of questionable utility now that Guile requires ANSI C, and is +oddly named. + +** Deprecated typedefs: scm_port_rw_active, scm_port, + scm_ptob_descriptor, scm_debug_info, scm_debug_frame, scm_fport, + scm_option, scm_rstate, scm_rng, scm_array, scm_array_dim. + +Made more compliant with the naming policy by adding a _t at the end. + +** Deprecated functions: scm_mkbig, scm_big2num, scm_adjbig, + scm_normbig, scm_copybig, scm_2ulong2big, scm_dbl2big, scm_big2dbl + +With the exception of the misterious scm_2ulong2big, they are still +available under new names (scm_i_mkbig etc). These functions are not +intended to be used in user code. You should avoid dealing with +bignums directly, and should deal with numbers in general (which can +be bignums). + +** New functions: scm_short2num, scm_ushort2num, scm_int2num, + scm_uint2num, scm_bits2num, scm_ubits2num, scm_size2num, + scm_ptrdiff2num, scm_num2short, scm_num2ushort, scm_num2int, + scm_num2uint, scm_num2bits, scm_num2ubits, scm_num2ptrdiff, + scm_num2size. + +These are conversion functions between the various ANSI C integral +types and Scheme numbers. + +** New number validation macros: + SCM_NUM2{SIZE,PTRDIFF,SHORT,USHORT,BITS,UBITS,INT,UINT}[_DEF] + +See above. + Changes since Guile 1.3.4: diff --git a/RELEASE b/RELEASE index 8bbe5df04..dd50962b8 100644 --- a/RELEASE +++ b/RELEASE @@ -99,6 +99,14 @@ After signal handling and threading have been fixed: - remove scm_strprint_obj - remove SCM_CONST_LONG - remove scm_wta +- remove deprecated typedefs: long_long, ulong_long, scm_sizet +- remove deprecated macros: scm_contregs, scm_port_rw_active, + scm_port, scm_ptob_descriptor, scm_debug_info, scm_debug_frame, + scm_fport, SCM_FIXNUM_BIT, scm_option, scm_subr_entry, scm_rstate, + scm_rng, scm_i_rstate, scm_srcprops, scm_srcprops_chunk, + scm_info_frame, scm_stack, scm_array, scm_array_dim. +- remove deprecated functions: scm_mkbig, scm_big2num, scm_adjbig, + scm_normbig, scm_copybig, scm_2ulong2big, scm_dbl2big, scm_big2dbl. Modules sort.c and random.c should be factored out into separate modules (but still be distributed with guile-core) when we get a new diff --git a/acconfig.h b/acconfig.h index 1d28d2eac..35c37f95f 100644 --- a/acconfig.h +++ b/acconfig.h @@ -166,3 +166,11 @@ /* Define if the compiler supports long longs. */ #undef HAVE_LONG_LONGS + +/* SCM will actually be represented by this type. */ +#undef SCM_BITS_T +#undef SCM_UBITS_T +#undef SCM_SIZEOF_BITS_T + +/* defined to signed long if doesn't exist: */ +#undef ptrdiff_t diff --git a/configure.in b/configure.in index 8eebe814e..89257b497 100644 --- a/configure.in +++ b/configure.in @@ -161,6 +161,12 @@ AC_C_BIGENDIAN AC_CHECK_SIZEOF(int) AC_CHECK_SIZEOF(long) + +dnl by the pre C9X ANSI C standards, size_t & ptrdiff_t have to be +dnl representable by a standard integral type. since the largest +dnl integer type in the pre-C9X ANSI C standards is long... +AC_CHECK_TYPE(ptrdiff_t, long) + AC_CACHE_CHECK([for long longs], scm_cv_long_longs, AC_TRY_COMPILE(, [long long a], @@ -168,13 +174,32 @@ AC_CACHE_CHECK([for long longs], scm_cv_long_longs, scm_cv_long_longs=no)) if test "$scm_cv_long_longs" = yes; then AC_DEFINE(HAVE_LONG_LONGS) + AC_CHECK_SIZEOF(long long) +fi + +AC_CHECK_SIZEOF(void *) + +if test "$ac_cv_sizeof_long" -eq "$ac_cv_sizeof_void_p"; then + AC_DEFINE(SCM_BITS_T, long) + AC_DEFINE(SCM_UBITS_T, unsigned long) + AC_DEFINE(SCM_SIZEOF_BITS_T, SIZEOF_LONG) +elif test \( "$scm_cv_long_longs" = yes \) -a \( "$ac_cv_sizeof_long_long" -eq "$ac_cv_sizeof_void_p" \); then + AC_DEFINE(SCM_BITS_T, long long) + AC_DEFINE(SCM_UBITS_T, unsigned long long) + AC_DEFINE(SCM_SIZEOF_BITS_T, SIZEOF_LONG_LONG) +elif test "$ac_cv_sizeof_int" -eq "$ac_cv_sizeof_void_p"; then + AC_DEFINE(SCM_BITS_T, int) + AC_DEFINE(SCM_UBITS_T, unsigned int) + AC_DEFINE(SCM_SIZEOF_BITS_T, SIZEOF_INT) +else + AC_MSG_ERROR(cannot find an integral type capable of storing a pointer: "$ac_cv_sizeof_void_p" bytes) fi AC_HEADER_STDC AC_HEADER_DIRENT AC_HEADER_TIME AC_HEADER_SYS_WAIT -AC_CHECK_HEADERS(io.h libc.h limits.h malloc.h memory.h string.h regex.h rxposix.h rx/rxposix.h sys/ioctl.h sys/select.h sys/time.h sys/timeb.h sys/times.h sys/types.h sys/utime.h time.h unistd.h utime.h) +AC_CHECK_HEADERS(io.h libc.h limits.h malloc.h memory.h string.h regex.h rxposix.h rx/rxposix.h sys/ioctl.h sys/select.h sys/time.h sys/timeb.h sys/times.h sys/stdtypes.h sys/types.h sys/utime.h time.h unistd.h utime.h) GUILE_HEADER_LIBC_WITH_UNISTD AC_TYPE_GETGROUPS diff --git a/doc/scheme-data.texi b/doc/scheme-data.texi index 7f283f446..03d7043fc 100755 --- a/doc/scheme-data.texi +++ b/doc/scheme-data.texi @@ -4143,7 +4143,7 @@ length. If @var{bool} is @code{#t}, uve is OR'ed into @var{bv}; If @var{bool} is @code{#f}, the inversion of uve is AND'ed into @var{bv}. -If uve is a unsigned integer vector all the elements of uve +If uve is a unsigned long integer vector all the elements of uve must be between 0 and the @code{length} of @var{bv}. The bits of @var{bv} corresponding to the indexes in uve are set to @var{bool}. The return value is unspecified. diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 5adbb6e54..00119b8bf 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,7 @@ +2001-05-23 Michael Livshin + + * readline.c (strdup): make `len' a size_t. + 2001-05-10 Marius Vollmer * readline.c (completion_function): Use SCM_VARIABLE_REF to access diff --git a/guile-readline/readline.c b/guile-readline/readline.c index 35c332fd6..04a797ba0 100644 --- a/guile-readline/readline.c +++ b/guile-readline/readline.c @@ -71,7 +71,7 @@ SCM_DEFINE (scm_readline_options, "readline-options-interface", 0, 1, 0, static char * strdup (char *s) { - int len = strlen (s); + size_t len = strlen (s); char *new = malloc (len + 1); strcpy (new, s); return new; diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 54089721f..ba567ae01 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,192 @@ +2001-05-24 Michael Livshin + + The purpose of this set of changes is to regularize Guile's usage + of ANSI C integral types, with the following ideas in mind: + + - SCM does not nesessarily has to be long. + - long is not nesessarily the same size as int. + + The changes are incomplete and possibly buggy. Please test on + something exotic. + + * validate.h + (SCM_NUM2{SIZE,PTRDIFF,SHORT,USHORT,BITS,UBITS,INT,UINT}[_DEF]): + new macros. + + * unif.h: type renaming: + scm_array -> scm_array_t + scm_array_dim -> scm_array_dim_t + the old names are deprecated, all in-Guile uses changed. + + * tags.h (scm_ubits_t): new typedef, representing unsigned + scm_bits_t. + + * stacks.h: type renaming: + scm_info_frame -> scm_info_frame_t + scm_stack -> scm_stack_t + the old names are deprecated, all in-Guile uses changed. + + * srcprop.h: type renaming: + scm_srcprops -> scm_srcprops_t + scm_srcprops_chunk -> scm_srcprops_chunk_t + the old names are deprecated, all in-Guile uses changed. + + * gsubr.c, procs.c, print.c, ports.c, read.c, rdelim.c, ramap.c, + rw.c, smob.c, sort.c, srcprop.c, stacks.c, strings.c, strop.c, + strorder.c, strports.c, struct.c, symbols.c, unif.c, values.c, + vectors.c, vports.c, weaks.c: + various int/size_t -> size_t/scm_bits_t changes. + + * random.h: type renaming: + scm_rstate -> scm_rstate_t + scm_rng -> scm_rng_t + scm_i_rstate -> scm_i_rstate_t + the old names are deprecated, all in-Guile uses changed. + + * procs.h: type renaming: + scm_subr_entry -> scm_subr_entry_t + the old name is deprecated, all in-Guile uses changed. + + * options.h (scm_option_t.val): unsigned long -> scm_bits_t. + type renaming: + scm_option -> scm_option_t + the old name is deprecated, all in-Guile uses changed. + + * objects.c: various long -> scm_bits_t changes. + (scm_i_make_class_object): flags: unsigned long -> scm_ubits_t + + * numbers.h (SCM_FIXNUM_BIT): deprecated, renamed to + SCM_I_FIXNUM_BIT. + + * num2integral.i.c: new file, multiply included by numbers.c, used + to "templatize" the various integral <-> num conversion routines. + + * numbers.c (scm_mkbig, scm_big2num, scm_adjbig, scm_normbig, + scm_copybig, scm_2ulong2big, scm_dbl2big, scm_big2dbl): + deprecated. + (scm_i_mkbig, scm_i_big2inum, scm_i_adjbig, scm_i_normbig, + scm_i_copybig, scm_i_short2big, scm_i_ushort2big, scm_i_int2big, + scm_i_uint2big, scm_i_long2big, scm_i_ulong2big, scm_i_bits2big, + scm_i_ubits2big, scm_i_size2big, scm_i_ptrdiff2big, + scm_i_long_long2big, scm_i_ulong_long2big, scm_i_dbl2big, + scm_i_big2dbl, scm_short2num, scm_ushort2num, scm_int2num, + scm_uint2num, scm_bits2num, scm_ubits2num, scm_size2num, + scm_ptrdiff2num, scm_num2short, scm_num2ushort, scm_num2int, + scm_num2uint, scm_num2bits, scm_num2ubits, scm_num2ptrdiff, + scm_num2size): new functions. + + * modules.c (scm_module_reverse_lookup): i, n: int -> scm_bits_t.x + + * load.c: change int -> size_t in various places (where the + variable is used to store a string length). + (search-path): call scm_done_free, not scm_done_malloc. + + * list.c (scm_ilength): return a scm_bits_t, not long. + some other {int,long} -> scm_bits_t changes. + + * hashtab.c: various [u]int -> scm_bits_t changes. + scm_ihashx_closure -> scm_ihashx_closure_t (and made a typedef). + (scm_ihashx): n: uint -> scm_bits_t + use scm_bits2num instead of scm_ulong2num. + + * gsubr.c: various int -> scm_bits_t changes. + + * goops.[hc]: various {int,long} -> scm_bits_t changes. + + * gh_data.c (gh_scm2double): no loss of precision any more. + + * gh.h (gh_str2scm): len: int -> size_t + (gh_{get,set}_substr): start: int -> scm_bits_t, + len: int -> size_t + (gh_2scm): n: int -> scm_bits_t + (gh_*vector_length): return scm_[u]size_t, not unsigned long. + (gh_length): return scm_bits_t, not unsigned long. + + * gc.[hc]: various small changes relating to many things stopping + being long and starting being scm_[u]bits_t instead. + scm_mallocated should no longer wrap around. + + * fports.h: type renaming: + scm_fport -> scm_fport_t + the old name is deprecated, all in-Guile uses changed. + + * fports.c (fport_fill_input): count: int -> scm_bits_t + (fport_flush): init_size, remaining, count: int -> scm_bits_t + + * debug.h (scm_lookup_cstr, scm_lookup_soft, scm_evstr): removed + those prototypes, as the functions they prototype don't exist. + + * fports.c (default_buffer_size): int -> size_t + (scm_fport_buffer_add): read_size, write_size: int -> scm_bits_t + default_size: int -> size_t + (scm_setvbuf): csize: int -> scm_bits_t + + * fluids.c (n_fluids): int -> scm_bits_t + (grow_fluids): old_length, i: int -> scm_bits_t + (next_fluid_num, scm_fluid_ref, scm_fluid_set_x): n: int -> + scm_bits_t + (scm_c_with_fluids): flen, vlen: int -> scm_bits_t + + * filesys.c (s_scm_open_fdes): changed calls to SCM_NUM2LONG to + the new and shiny SCM_NUM2INT. + + * extensions.c: extension -> extension_t (and made a typedef). + + * eval.h (SCM_IFRAME): cast to scm_bits_t, not int. just so + there are no nasty surprises if/when the various deeply magic tag + bits move somewhere else. + + * eval.c: changed the locals used to store results of SCM_IFRAME, + scm_ilength and such to be of type scm_bits_t (and not int/long). + (iqq): depth, edepth: int -> scm_bits_t + (scm_eval_stack): int -> scm_bits_t + (SCM_CEVAL): various vars are not scm_bits_t instead of int. + (check_map_args, scm_map, scm_for_each): len: long -> scm_bits_t + i: int -> scm_bits_t + + * environments.c: changed the many calls to scm_ulong2num to + scm_ubits2num. + (import_environment_fold): proc_as_ul: ulong -> scm_ubits_t + + * dynwind.c (scm_dowinds): delta: long -> scm_bits_t + + * debug.h: type renaming: + scm_debug_info -> scm_debug_info_t + scm_debug_frame -> scm_debug_frame_t + the old names are deprecated, all in-Guile uses changed. + (scm_debug_eframe_size): int -> scm_bits_t + + * debug.c (scm_init_debug): use scm_c_define instead of the + deprecated scm_define. + + * continuations.h: type renaming: + scm_contregs -> scm_contregs_t + the old name is deprecated, all in-Guile uses changed. + (scm_contregs_t.num_stack_items): size_t -> scm_bits_t + (scm_contregs_t.num_stack_items): ulong -> scm_ubits_t + + * continuations.c (scm_make_continuation): change the type of + stack_size form long to scm_bits_t. + + * ports.h: type renaming: + scm_port_rw_active -> scm_port_rw_active_t (and made a typedef) + scm_port -> scm_port_t + scm_ptob_descriptor -> scm_ptob_descriptor_t + the old names are deprecated, all in-Guile uses changed. + (scm_port_t.entry): int -> scm_bits_t. + (scm_port_t.line_number): int -> long. + (scm_port_t.putback_buf_size): int -> size_t. + + * __scm.h (long_long, ulong_long): deprecated (they pollute the + global namespace and have little value besides that). + (SCM_BITS_LENGTH): new, is the bit size of scm_bits_t (i.e. of an + SCM handle). + (ifdef spaghetti): include sys/types.h and sys/stdtypes.h, if they + exist (for size_t & ptrdiff_t) + (scm_sizet): deprecated. + + * Makefile.am (noinst_HEADERS): add num2integral.i.c + 2001-05-23 Marius Vollmer * snarf.h (SCM_CONST_LONG): Use SCM_VCELL_INIT instead of diff --git a/libguile/Makefile.am b/libguile/Makefile.am index b123255d0..5a8cc58e1 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -101,10 +101,10 @@ OMIT_DEPENDENCIES = libguile.h ltdl.h \ axp.h hppa.h i386.h ksr.h m88k.h mips.h sparc.h vax.h ## This is kind of nasty... there are ".c" files that we don't want to -## compile, since they are #included in threads.c. So instead we list -## them here. Perhaps we can deal with them normally once the merge -## seems to be working. -noinst_HEADERS = coop-threads.c coop-threads.h coop.c +## compile, since they are #included. So instead we list them here. +## Perhaps we can deal with them normally once the merge seems to be +## working. +noinst_HEADERS = coop-threads.c coop-threads.h coop.c num2integral.i.c libguile_la_DEPENDENCIES = @LIBLOBJS@ libguile_la_LIBADD = @LIBLOBJS@ $(LIBLTDL) diff --git a/libguile/__scm.h b/libguile/__scm.h index 9e0fea279..753684edc 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -211,8 +211,11 @@ /* Some auto-generated .h files contain unused prototypes * that need these typedefs. */ + +#if (SCM_DEBUG_DEPRECATED == 0) typedef long long long_long; typedef unsigned long long ulong_long; +#endif #endif /* HAVE_LONG_LONGS */ @@ -252,6 +255,8 @@ typedef unsigned long long ulong_long; # define SCM_LONG_BIT (SCM_CHAR_BIT * sizeof (long) / sizeof (char)) #endif +#define SCM_BITS_LENGTH (SCM_CHAR_BIT * SCM_SIZEOF_BITS_T) + #ifdef UCHAR_MAX # define SCM_CHAR_CODE_LIMIT (UCHAR_MAX + 1L) #else @@ -262,18 +267,19 @@ typedef unsigned long long ulong_long; #ifdef STDC_HEADERS # include -# ifdef AMIGA +# if HAVE_SYS_TYPES_H +# include +# endif +# if HAVE_SYS_STDTYPES_H +# include +# endif # include -# endif /* def AMIGA */ -# define scm_sizet size_t -#else -# ifdef _SIZE_T -# define scm_sizet size_t -# else -# define scm_sizet unsigned int -# endif /* def _SIZE_T */ #endif /* def STDC_HEADERS */ +#if (SCM_DEBUG_DEPRECATED == 0) +# define scm_sizet size_t +#endif + #include "libguile/tags.h" diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 95fb71cd0..b4636a160 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -338,7 +338,7 @@ display_frame_expr (char *hdr,SCM exp,char *tlr,int indentation,SCM sport,SCM po { SCM string; int i = 0, n; - scm_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (sport); + scm_ptob_descriptor_t *ptob = scm_ptobs + SCM_PTOBNUM (sport); do { pstate->length = print_params[i].length; diff --git a/libguile/continuations.c b/libguile/continuations.c index 28985e060..81bbe65bd 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -71,22 +71,22 @@ scm_bits_t scm_tc16_continuation; static SCM continuation_mark (SCM obj) { - scm_contregs *continuation = SCM_CONTREGS (obj); + scm_contregs_t *continuation = SCM_CONTREGS (obj); scm_gc_mark (continuation->throw_value); scm_mark_locations (continuation->stack, continuation->num_stack_items); return continuation->dynenv; } -static scm_sizet +static size_t continuation_free (SCM obj) { - scm_contregs *continuation = SCM_CONTREGS (obj); + scm_contregs_t *continuation = SCM_CONTREGS (obj); /* stack array size is 1 if num_stack_items is 0 (rootcont). */ - scm_sizet extra_items = (continuation->num_stack_items > 0) + size_t extra_items = (continuation->num_stack_items > 0) ? (continuation->num_stack_items - 1) : 0; - scm_sizet bytes_free = sizeof (scm_contregs) + size_t bytes_free = sizeof (scm_contregs_t) + extra_items * sizeof (SCM_STACKITEM); scm_must_free (continuation); @@ -96,7 +96,7 @@ continuation_free (SCM obj) static int continuation_print (SCM obj, SCM port, scm_print_state *state) { - scm_contregs *continuation = SCM_CONTREGS (obj); + scm_contregs_t *continuation = SCM_CONTREGS (obj); scm_puts ("#num_stack_items, 10, port); @@ -114,15 +114,15 @@ SCM scm_make_continuation (int *first) { volatile SCM cont; - scm_contregs *continuation; - scm_contregs *rootcont = SCM_CONTREGS (scm_rootcont); - long stack_size; + scm_contregs_t *continuation; + scm_contregs_t *rootcont = SCM_CONTREGS (scm_rootcont); + scm_bits_t stack_size; SCM_STACKITEM * src; SCM_ENTER_A_SECTION; SCM_FLUSH_REGISTER_WINDOWS; stack_size = scm_stack_size (rootcont->base); - continuation = scm_must_malloc (sizeof (scm_contregs) + continuation = scm_must_malloc (sizeof (scm_contregs_t) + (stack_size - 1) * sizeof (SCM_STACKITEM), FUNC_NAME); continuation->num_stack_items = stack_size; @@ -180,7 +180,7 @@ grow_stack (SCM cont, SCM val) * own frame are overwritten. Thus, memcpy can be used for best performance. */ static void -copy_stack_and_call (scm_contregs *continuation, SCM val, +copy_stack_and_call (scm_contregs_t *continuation, SCM val, SCM_STACKITEM * dst) { memcpy (dst, continuation->stack, @@ -202,7 +202,7 @@ copy_stack_and_call (scm_contregs *continuation, SCM val, static void scm_dynthrow (SCM cont, SCM val) { - scm_contregs *continuation = SCM_CONTREGS (cont); + scm_contregs_t *continuation = SCM_CONTREGS (cont); SCM_STACKITEM * dst = SCM_BASE (scm_rootcont); SCM_STACKITEM stack_top_element; @@ -224,8 +224,8 @@ static SCM continuation_apply (SCM cont, SCM args) #define FUNC_NAME "continuation_apply" { - scm_contregs *continuation = SCM_CONTREGS (cont); - scm_contregs *rootcont = SCM_CONTREGS (scm_rootcont); + scm_contregs_t *continuation = SCM_CONTREGS (cont); + scm_contregs_t *rootcont = SCM_CONTREGS (scm_rootcont); if (continuation->seq != rootcont->seq /* this base comparison isn't needed */ diff --git a/libguile/continuations.h b/libguile/continuations.h index 85029fb23..0d31225c9 100644 --- a/libguile/continuations.h +++ b/libguile/continuations.h @@ -50,7 +50,7 @@ /* a continuation SCM is a non-immediate pointing to a heap cell with: word 0: bits 0-15: unused. bits 16-31: smob type tag: scm_tc16_continuation. - word 1: malloc block containing an scm_contregs structure with a + word 1: malloc block containing an scm_contregs_t structure with a tail array of SCM_STACKITEM. the size of the array is stored in the num_stack_items field of the structure. */ @@ -63,20 +63,24 @@ typedef struct jmp_buf jmpbuf; SCM dynenv; SCM_STACKITEM *base; /* base of the live stack, before it was saved. */ - scm_sizet num_stack_items; /* size of the saved stack. */ - unsigned long seq; /* dynamic root identifier. */ + scm_bits_t num_stack_items; /* size of the saved stack. */ + scm_ubits_t seq; /* dynamic root identifier. */ #ifdef DEBUG_EXTENSIONS /* the most recently created debug frame on the live stack, before it was saved. */ - struct scm_debug_frame *dframe; + struct scm_debug_frame_t *dframe; #endif SCM_STACKITEM stack[1]; /* copied stack of size num_stack_items. */ -} scm_contregs; +} scm_contregs_t; + +#if (SCM_DEBUG_DEPRECATED == 0) +# define scm_contregs scm_contregs_t +#endif #define SCM_CONTINUATIONP(x) SCM_TYP16_PREDICATE (scm_tc16_continuation, x) -#define SCM_CONTREGS(x) ((scm_contregs *) SCM_CELL_WORD_1 (x)) +#define SCM_CONTREGS(x) ((scm_contregs_t *) SCM_CELL_WORD_1 (x)) #define SCM_CONTINUATION_LENGTH(x) (SCM_CONTREGS (x)->num_stack_items) #define SCM_SET_CONTINUATION_LENGTH(x,n)\ diff --git a/libguile/coop-threads.c b/libguile/coop-threads.c index e76f9179c..a003d5b41 100644 --- a/libguile/coop-threads.c +++ b/libguile/coop-threads.c @@ -109,7 +109,7 @@ scm_threads_mark_stacks (void) /* This assumes that all registers are saved into the jmp_buf */ setjmp (scm_save_regs_gc_mark); scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark, - ((scm_sizet) sizeof scm_save_regs_gc_mark + ((size_t) sizeof scm_save_regs_gc_mark / sizeof (SCM_STACKITEM))); scm_mark_locations (((size_t) thread->base, @@ -130,7 +130,7 @@ scm_threads_mark_stacks (void) /* This assumes that all registers are saved into the jmp_buf */ setjmp (scm_save_regs_gc_mark); scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark, - ((scm_sizet) sizeof scm_save_regs_gc_mark + ((size_t) sizeof scm_save_regs_gc_mark / sizeof (SCM_STACKITEM))); scm_mark_locations ((SCM_STACKITEM *) &thread, diff --git a/libguile/debug.c b/libguile/debug.c index c5e7468db..efece65f7 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -521,8 +521,8 @@ SCM scm_start_stack (SCM id, SCM exp, SCM env) { SCM answer; - scm_debug_frame vframe; - scm_debug_info vframe_vect_body; + scm_debug_frame_t vframe; + scm_debug_info_t vframe_vect_body; vframe.prev = scm_last_debug_frame; vframe.status = SCM_VOIDFRAME; vframe.vect = &vframe_vect_body; @@ -576,7 +576,7 @@ SCM_DEFINE (scm_debug_object_p, "debug-object?", 1, 0, 0, SCM -scm_make_debugobj (scm_debug_frame *frame) +scm_make_debugobj (scm_debug_frame_t *frame) { register SCM z; SCM_NEWCELL (z); @@ -619,23 +619,23 @@ scm_init_debug () scm_set_smob_print (scm_tc16_debugobj, debugobj_print); #ifdef GUILE_DEBUG - scm_define ("SCM_IM_AND", SCM_IM_AND); - scm_define ("SCM_IM_BEGIN", SCM_IM_BEGIN); - scm_define ("SCM_IM_CASE", SCM_IM_CASE); - scm_define ("SCM_IM_COND", SCM_IM_COND); - scm_define ("SCM_IM_DO", SCM_IM_DO); - scm_define ("SCM_IM_IF", SCM_IM_IF); - scm_define ("SCM_IM_LAMBDA", SCM_IM_LAMBDA); - scm_define ("SCM_IM_LET", SCM_IM_LET); - scm_define ("SCM_IM_LETSTAR", SCM_IM_LETSTAR); - scm_define ("SCM_IM_LETREC", SCM_IM_LETREC); - scm_define ("SCM_IM_OR", SCM_IM_OR); - scm_define ("SCM_IM_QUOTE", SCM_IM_QUOTE); - scm_define ("SCM_IM_SET_X", SCM_IM_SET_X); - scm_define ("SCM_IM_DEFINE", SCM_IM_DEFINE); - scm_define ("SCM_IM_APPLY", SCM_IM_APPLY); - scm_define ("SCM_IM_CONT", SCM_IM_CONT); - scm_define ("SCM_IM_DISPATCH", SCM_IM_DISPATCH); + scm_c_define ("SCM_IM_AND", SCM_IM_AND); + scm_c_define ("SCM_IM_BEGIN", SCM_IM_BEGIN); + scm_c_define ("SCM_IM_CASE", SCM_IM_CASE); + scm_c_define ("SCM_IM_COND", SCM_IM_COND); + scm_c_define ("SCM_IM_DO", SCM_IM_DO); + scm_c_define ("SCM_IM_IF", SCM_IM_IF); + scm_c_define ("SCM_IM_LAMBDA", SCM_IM_LAMBDA); + scm_c_define ("SCM_IM_LET", SCM_IM_LET); + scm_c_define ("SCM_IM_LETSTAR", SCM_IM_LETSTAR); + scm_c_define ("SCM_IM_LETREC", SCM_IM_LETREC); + scm_c_define ("SCM_IM_OR", SCM_IM_OR); + scm_c_define ("SCM_IM_QUOTE", SCM_IM_QUOTE); + scm_c_define ("SCM_IM_SET_X", SCM_IM_SET_X); + scm_c_define ("SCM_IM_DEFINE", SCM_IM_DEFINE); + scm_c_define ("SCM_IM_APPLY", SCM_IM_APPLY); + scm_c_define ("SCM_IM_CONT", SCM_IM_CONT); + scm_c_define ("SCM_IM_DISPATCH", SCM_IM_DISPATCH); #endif scm_add_feature ("debug-extensions"); diff --git a/libguile/debug.h b/libguile/debug.h index ba143ace6..2ee0e777c 100644 --- a/libguile/debug.h +++ b/libguile/debug.h @@ -69,7 +69,7 @@ /* scm_debug_opts is defined in eval.c. */ -extern scm_option scm_debug_opts[]; +extern scm_option_t scm_debug_opts[]; #define SCM_CHEAPTRAPS_P scm_debug_opts[0].val #define SCM_BREAKPOINTS_P scm_debug_opts[1].val @@ -108,25 +108,30 @@ do {\ /* {Evaluator} */ -typedef union scm_debug_info +typedef union scm_debug_info_t { struct { SCM exp, env; } e; struct { SCM proc, args; } a; SCM id; -} scm_debug_info; +} scm_debug_info_t; -extern int scm_debug_eframe_size; +extern scm_bits_t scm_debug_eframe_size; -typedef struct scm_debug_frame +typedef struct scm_debug_frame_t { - struct scm_debug_frame *prev; + struct scm_debug_frame_t *prev; long status; - scm_debug_info *vect; - scm_debug_info *info; -} scm_debug_frame; + scm_debug_info_t *vect; + scm_debug_info_t *info; +} scm_debug_frame_t; + +#if (SCM_DEBUG_DEPRECATED == 0) +# define scm_debug_info scm_debug_info_t +# define scm_debug_frame scm_debug_frame_t +#endif #ifndef USE_THREADS -extern scm_debug_frame *scm_last_debug_frame; +extern scm_debug_frame_t *scm_last_debug_frame; #endif #define SCM_EVALFRAME (0L << 11) @@ -201,7 +206,7 @@ extern SCM scm_with_traps (SCM thunk); extern SCM scm_evaluator_traps (SCM setting); extern SCM scm_debug_options (SCM setting); extern SCM scm_unmemoize (SCM memoized); -extern SCM scm_make_debugobj (scm_debug_frame* debug); +extern SCM scm_make_debugobj (scm_debug_frame_t *debug); extern void scm_init_debug (void); #ifdef GUILE_DEBUG diff --git a/libguile/dynl.c b/libguile/dynl.c index e46866beb..c26dd2a15 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -101,7 +101,7 @@ scm_make_argv_from_stringlist (SCM args,int *argcp,const char *subr,int argn) argv = (char **) scm_must_malloc ((argc + 1) * sizeof (char *), subr); for (i = 0; !SCM_NULLP (args); args = SCM_CDR (args), ++i) { SCM arg = SCM_CAR (args); - scm_sizet len; + size_t len; char *dst; char *src; diff --git a/libguile/dynwind.c b/libguile/dynwind.c index 54323a568..ef0a144ce 100644 --- a/libguile/dynwind.c +++ b/libguile/dynwind.c @@ -201,11 +201,11 @@ scm_swap_bindings (SCM glocs, SCM vals) } void -scm_dowinds (SCM to, long delta) +scm_dowinds (SCM to, scm_bits_t delta) { tail: if (SCM_EQ_P (to, scm_dynwinds)); - else if (0 > delta) + else if (delta < 0) { SCM wind_elt; SCM wind_key; diff --git a/libguile/dynwind.h b/libguile/dynwind.h index a8e888b23..49823762c 100644 --- a/libguile/dynwind.h +++ b/libguile/dynwind.h @@ -56,7 +56,7 @@ extern SCM scm_internal_dynamic_wind (scm_guard_t before, scm_guard_t after, void *inner_data, void *guard_data); -extern void scm_dowinds (SCM to, long delta); +extern void scm_dowinds (SCM to, scm_bits_t delta); extern void scm_init_dynwind (void); #ifdef GUILE_DEBUG diff --git a/libguile/environments.c b/libguile/environments.c index c7b9f2d85..6455cd9b1 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -479,7 +479,7 @@ environment_mark (SCM env) } -static scm_sizet +static size_t environment_free (SCM env) { return (*(SCM_ENVIRONMENT_FUNCS (env)->free)) (env); @@ -508,7 +508,7 @@ observer_mark (SCM observer) static int observer_print (SCM type, SCM port, scm_print_state *pstate) { - SCM address = scm_ulong2num (SCM_UNPACK (type)); + SCM address = scm_ubits2num (SCM_UNPACK (type)); SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16)); scm_puts ("#obarray; @@ -991,7 +991,7 @@ leaf_environment_mark (SCM env) } -static scm_sizet +static size_t leaf_environment_free (SCM env) { core_environments_finalize (env); @@ -1004,7 +1004,7 @@ leaf_environment_free (SCM env) static int leaf_environment_print (SCM type, SCM port, scm_print_state *pstate) { - SCM address = scm_ulong2num (SCM_UNPACK (type)); + SCM address = scm_ubits2num (SCM_UNPACK (type)); SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16)); scm_puts ("#local; SCM imported = EVAL_ENVIRONMENT (env)->imported; - SCM proc_as_nr = scm_ulong2num ((unsigned long int) proc); + SCM proc_as_nr = scm_ubits2num ((scm_ubits_t) proc); SCM extended_data = scm_cons2 (local, proc_as_nr, data); SCM tmp_result = scm_c_environment_fold (imported, eval_environment_folder, extended_data, init); @@ -1352,7 +1352,7 @@ eval_environment_mark (SCM env) } -static scm_sizet +static size_t eval_environment_free (SCM env) { core_environments_finalize (env); @@ -1365,7 +1365,7 @@ eval_environment_free (SCM env) static int eval_environment_print (SCM type, SCM port, scm_print_state *pstate) { - SCM address = scm_ulong2num (SCM_UNPACK (type)); + SCM address = scm_ubits2num (SCM_UNPACK (type)); SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16)); scm_puts ("#= 2 && len <= 3, scm_s_expression, "if"); return scm_cons (SCM_IM_IF, SCM_CDR (xorig)); } @@ -563,7 +563,7 @@ SCM_GLOBAL_SYMBOL(scm_sym_and, s_and); SCM scm_m_and (SCM xorig, SCM env) { - int len = scm_ilength (SCM_CDR (xorig)); + scm_bits_t len = scm_ilength (SCM_CDR (xorig)); SCM_ASSYNT (len >= 0, scm_s_test, s_and); if (len >= 1) return scm_cons (SCM_IM_AND, SCM_CDR (xorig)); @@ -577,7 +577,7 @@ SCM_GLOBAL_SYMBOL(scm_sym_or,s_or); SCM scm_m_or (SCM xorig, SCM env) { - int len = scm_ilength (SCM_CDR (xorig)); + scm_bits_t len = scm_ilength (SCM_CDR (xorig)); SCM_ASSYNT (len >= 0, scm_s_test, s_or); if (len >= 1) return scm_cons (SCM_IM_OR, SCM_CDR (xorig)); @@ -615,7 +615,7 @@ SCM scm_m_cond (SCM xorig, SCM env) { SCM arg1, cdrx = scm_list_copy (SCM_CDR (xorig)), x = cdrx; - int len = scm_ilength (x); + scm_bits_t len = scm_ilength (x); SCM_ASSYNT (len >= 1, scm_s_clauses, s_cond); while (SCM_NIMP (x)) { @@ -705,7 +705,7 @@ SCM scm_m_letstar (SCM xorig, SCM env) { SCM x = SCM_CDR (xorig), arg1, proc, vars = SCM_EOL, *varloc = &vars; - int len = scm_ilength (x); + scm_bits_t len = scm_ilength (x); SCM_ASSYNT (len >= 2, scm_s_body, s_letstar); proc = SCM_CAR (x); SCM_ASSYNT (scm_ilength (proc) >= 0, scm_s_bindings, s_letstar); @@ -747,7 +747,7 @@ scm_m_do (SCM xorig, SCM env) SCM x = SCM_CDR (xorig), arg1, proc; SCM vars = SCM_EOL, inits = SCM_EOL, steps = SCM_EOL; SCM *initloc = &inits, *steploc = &steps; - int len = scm_ilength (x); + scm_bits_t len = scm_ilength (x); SCM_ASSYNT (len >= 2, scm_s_test, "do"); proc = SCM_CAR (x); SCM_ASSYNT (scm_ilength (proc) >= 0, scm_s_bindings, "do"); @@ -780,7 +780,7 @@ scm_m_do (SCM xorig, SCM env) #define evalcar scm_eval_car -static SCM iqq (SCM form, SCM env, int depth); +static SCM iqq (SCM form, SCM env, scm_bits_t depth); SCM_SYNTAX(s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote); SCM_GLOBAL_SYMBOL(scm_sym_quasiquote, s_quasiquote); @@ -795,15 +795,15 @@ scm_m_quasiquote (SCM xorig, SCM env) static SCM -iqq (SCM form, SCM env, int depth) +iqq (SCM form, SCM env, scm_bits_t depth) { SCM tmp; - int edepth = depth; + scm_bits_t edepth = depth; if (SCM_IMP (form)) return form; if (SCM_VECTORP (form)) { - long i = SCM_VECTOR_LENGTH (form); + scm_bits_t i = SCM_VECTOR_LENGTH (form); SCM *data = SCM_VELTS (form); tmp = SCM_EOL; for (; --i >= 0;) @@ -1043,7 +1043,7 @@ SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond); SCM scm_m_nil_cond (SCM xorig, SCM env) { - int len = scm_ilength (SCM_CDR (xorig)); + scm_bits_t len = scm_ilength (SCM_CDR (xorig)); SCM_ASSYNT (len >= 1 && (len & 1) == 1, scm_s_expression, "nil-cond"); return scm_cons (SCM_IM_NIL_COND, SCM_CDR (xorig)); } @@ -1071,7 +1071,7 @@ SCM_SYNTAX (s_0_cond, "0-cond", scm_makmmacro, scm_m_0_cond); SCM scm_m_0_cond (SCM xorig, SCM env) { - int len = scm_ilength (SCM_CDR (xorig)); + scm_bits_t len = scm_ilength (SCM_CDR (xorig)); SCM_ASSYNT (len >= 1 && (len & 1) == 1, scm_s_expression, "0-cond"); return scm_cons (SCM_IM_0_COND, SCM_CDR (xorig)); } @@ -1651,24 +1651,24 @@ SCM (*scm_ceval_ptr) (SCM x, SCM env); */ #ifndef USE_THREADS -scm_debug_frame *scm_last_debug_frame; +scm_debug_frame_t *scm_last_debug_frame; #endif /* scm_debug_eframe_size is the number of slots available for pseudo * stack frames at each real stack frame. */ -int scm_debug_eframe_size; +scm_bits_t scm_debug_eframe_size; int scm_debug_mode, scm_check_entry_p, scm_check_apply_p, scm_check_exit_p; -int scm_eval_stack; +scm_bits_t scm_eval_stack; -scm_option scm_eval_opts[] = { +scm_option_t scm_eval_opts[] = { { SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." } }; -scm_option scm_debug_opts[] = { +scm_option_t scm_debug_opts[] = { { SCM_OPTION_BOOLEAN, "cheap", 1, "*Flyweight representation of the stack at traps." }, { SCM_OPTION_BOOLEAN, "breakpoints", 0, "*Check for breakpoints." }, @@ -1689,7 +1689,7 @@ scm_option scm_debug_opts[] = { { SCM_OPTION_INTEGER, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." } }; -scm_option scm_evaluator_trap_table[] = { +scm_option_t scm_evaluator_trap_table[] = { { SCM_OPTION_BOOLEAN, "traps", 0, "Enable evaluator traps." }, { SCM_OPTION_BOOLEAN, "enter-frame", 0, "Trap when eval enters new frame." }, { SCM_OPTION_BOOLEAN, "apply-frame", 0, "Trap when entering apply." }, @@ -1823,17 +1823,17 @@ SCM_CEVAL (SCM x, SCM env) } t; SCM proc, arg2, orig_sym; #ifdef DEVAL - scm_debug_frame debug; - scm_debug_info *debug_info_end; + scm_debug_frame_t debug; + scm_debug_info_t *debug_info_end; debug.prev = scm_last_debug_frame; debug.status = scm_debug_eframe_size; /* - * The debug.vect contains twice as much scm_debug_info frames as the + * The debug.vect contains twice as much scm_debug_info_t frames as the * user has specified with (debug-set! frames ). * * Even frames are eval frames, odd frames are apply frames. */ - debug.vect = (scm_debug_info *) alloca (scm_debug_eframe_size + debug.vect = (scm_debug_info_t *) alloca (scm_debug_eframe_size * sizeof (debug.vect[0])); debug.info = debug.vect; debug_info_end = debug.vect + scm_debug_eframe_size; @@ -2303,7 +2303,7 @@ dispatch: * cuts down execution time for type dispatch to 50%. */ { - int i, n, end, mask; + scm_bits_t i, n, end, mask; SCM z = SCM_CDDR (x); n = SCM_INUM (SCM_CAR (z)); /* maximum number of specializers */ proc = SCM_CADR (z); @@ -2318,8 +2318,8 @@ dispatch: else { /* Compute a hash value */ - int hashset = SCM_INUM (proc); - int j = n; + scm_bits_t hashset = SCM_INUM (proc); + scm_bits_t j = n; mask = SCM_INUM (SCM_CAR (z = SCM_CDDR (z))); proc = SCM_CADR (z); i = 0; @@ -2339,7 +2339,7 @@ dispatch: /* Search for match */ do { - int j = n; + scm_bits_t j = n; z = SCM_VELTS (proc)[i]; t.arg1 = arg2; /* list of arguments */ if (SCM_NIMP (t.arg1)) @@ -2797,7 +2797,7 @@ evapply: #ifdef SCM_BIGDIG if (SCM_BIGP (t.arg1)) { - RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_big2dbl (t.arg1)))); + RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (t.arg1)))); } #endif floerr: @@ -3313,8 +3313,8 @@ SCM_APPLY (SCM proc, SCM arg1, SCM args) { #ifdef DEBUG_EXTENSIONS #ifdef DEVAL - scm_debug_frame debug; - scm_debug_info debug_vect_body; + scm_debug_frame_t debug; + scm_debug_info_t debug_vect_body; debug.prev = scm_last_debug_frame; debug.status = SCM_APPLYFRAME; debug.vect = &debug_vect_body; @@ -3419,7 +3419,7 @@ tail: } #ifdef SCM_BIGDIG if (SCM_BIGP (arg1)) - RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_big2dbl (arg1)))) + RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))) #endif floerr: SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, @@ -3631,18 +3631,18 @@ ret: and claim that the i'th element of ARGV is WHO's i+2'th argument. */ static inline void check_map_args (SCM argv, - long len, + scm_bits_t len, SCM gf, SCM proc, SCM args, const char *who) { SCM *ve = SCM_VELTS (argv); - int i; + scm_bits_t i; for (i = SCM_VECTOR_LENGTH (argv) - 1; i >= 1; i--) { - int elt_len = scm_ilength (ve[i]); + scm_bits_t elt_len = scm_ilength (ve[i]); if (elt_len < 0) { @@ -3673,7 +3673,7 @@ SCM scm_map (SCM proc, SCM arg1, SCM args) #define FUNC_NAME s_map { - long i, len; + scm_bits_t i, len; SCM res = SCM_EOL; SCM *pres = &res; SCM *ve = &args; /* Keep args from being optimized away. */ @@ -3722,7 +3722,7 @@ scm_for_each (SCM proc, SCM arg1, SCM args) #define FUNC_NAME s_for_each { SCM *ve = &args; /* Keep args from being optimized away. */ - long i, len; + scm_bits_t i, len; len = scm_ilength (arg1); SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args), SCM_ARG2, s_for_each); @@ -3861,7 +3861,7 @@ SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0, return obj; if (SCM_VECTORP (obj)) { - scm_sizet i = SCM_VECTOR_LENGTH (obj); + size_t i = SCM_VECTOR_LENGTH (obj); ans = scm_c_make_vector (i, SCM_UNSPECIFIED); while (i--) SCM_VELTS (ans)[i] = scm_copy_tree (SCM_VELTS (obj)[i]); diff --git a/libguile/eval.h b/libguile/eval.h index 2ce79fd5c..d34c723da 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -53,14 +53,14 @@ /* {Options} */ -extern scm_option scm_eval_opts[]; +extern scm_option_t scm_eval_opts[]; #define SCM_EVAL_STACK scm_eval_opts[0].val #define SCM_N_EVAL_OPTIONS 1 -extern int scm_eval_stack; +extern scm_bits_t scm_eval_stack; -extern scm_option scm_evaluator_trap_table[]; +extern scm_option_t scm_evaluator_trap_table[]; extern SCM scm_eval_options_interface (SCM setting); @@ -83,8 +83,8 @@ extern SCM scm_eval_options_interface (SCM setting); #define SCM_ICDR (0x00080000L) #define SCM_IFRINC (0x00000100L) #define SCM_IDSTMSK (-SCM_IDINC) -#define SCM_IFRAME(n) ((int)((SCM_ICDR-SCM_IFRINC)>>8) \ - & (SCM_UNPACK (n) >> 8)) +#define SCM_IFRAME(n) ((scm_bits_t)((SCM_ICDR-SCM_IFRINC)>>8) \ + & (SCM_UNPACK (n)) >> 8) #define SCM_IDIST(n) (SCM_UNPACK (n) >> 20) #define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n)) diff --git a/libguile/extensions.c b/libguile/extensions.c index 3d4f7d8cd..0a5346009 100644 --- a/libguile/extensions.c +++ b/libguile/extensions.c @@ -48,21 +48,22 @@ #include "libguile/extensions.h" -struct extension { - struct extension *next; +typedef struct extension_t +{ + struct extension_t *next; const char *lib; const char *init; void (*func)(void *); void *data; -}; +} extension_t; -static struct extension *registered_extensions; +static extension_t *registered_extensions; void scm_c_register_extension (const char *lib, const char *init, void (*func) (void *), void *data) { - struct extension *ext = scm_must_malloc (sizeof(struct extension), + extension_t *ext = scm_must_malloc (sizeof(extension_t), "scm_register_extension"); ext->lib = scm_must_strdup (lib); ext->init = scm_must_strdup (init); @@ -78,7 +79,7 @@ load_extension (SCM lib, SCM init) { /* Search the registry. */ { - struct extension *ext; + extension_t *ext; for (ext = registered_extensions; ext; ext = ext->next) if (!strcmp (ext->lib, SCM_STRING_CHARS (lib)) diff --git a/libguile/filesys.c b/libguile/filesys.c index e48d37764..8648d447a 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -243,8 +243,8 @@ SCM_DEFINE (scm_open_fdes, "open-fdes", 2, 1, 0, SCM_VALIDATE_STRING (1, path); SCM_STRING_COERCE_0TERMINATION_X (path); - iflags = SCM_NUM2LONG (2, flags); - imode = SCM_NUM2LONG_DEF (3, mode, 0666); + iflags = SCM_NUM2INT (2, flags); + imode = SCM_NUM2INT_DEF (3, mode, 0666); SCM_SYSCALL (fd = open (SCM_STRING_CHARS (path), iflags, imode)); if (fd == -1) SCM_SYSERROR; @@ -286,7 +286,7 @@ SCM_DEFINE (scm_open, "open", 2, 1, 0, int iflags; fd = SCM_INUM (scm_open_fdes (path, flags, mode)); - iflags = SCM_NUM2LONG (2, flags); + iflags = SCM_NUM2INT (2, flags); if (iflags & O_RDWR) { if (iflags & O_APPEND) @@ -795,7 +795,7 @@ scm_dir_print (SCM exp, SCM port, scm_print_state *pstate) } -static scm_sizet +static size_t scm_dir_free (SCM p) { if (SCM_DIR_OPEN_P (p)) @@ -832,7 +832,7 @@ SCM_DEFINE (scm_getcwd, "getcwd", 0, 0, 0, #define FUNC_NAME s_scm_getcwd { char *rv; - scm_sizet size = 100; + size_t size = 100; char *wd; SCM result; @@ -879,7 +879,7 @@ set_element (SELECT_TYPE *set, SCM *ports_ready, SCM element, int pos) if (pos == SCM_ARG1) { /* check whether port has buffered input. */ - scm_port *pt = SCM_PTAB_ENTRY (element); + scm_port_t *pt = SCM_PTAB_ENTRY (element); if (pt->read_pos < pt->read_end) use_buf = 1; @@ -887,7 +887,7 @@ set_element (SELECT_TYPE *set, SCM *ports_ready, SCM element, int pos) else if (pos == SCM_ARG2) { /* check whether port's output buffer has room. */ - scm_port *pt = SCM_PTAB_ENTRY (element); + scm_port_t *pt = SCM_PTAB_ENTRY (element); /* > 1 since writing the last byte in the buffer causes flush. */ if (pt->write_end - pt->write_pos > 1) diff --git a/libguile/fluids.c b/libguile/fluids.c index 0283467c8..aedb27ed8 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -56,7 +56,7 @@ #define INITIAL_FLUIDS 10 #include "libguile/validate.h" -static volatile int n_fluids; +static volatile scm_bits_t n_fluids; scm_bits_t scm_tc16_fluid; SCM @@ -69,7 +69,7 @@ static void grow_fluids (scm_root_state *root_state, int new_length) { SCM old_fluids, new_fluids; - int old_length, i; + scm_bits_t old_length, i; old_fluids = root_state->fluids; old_length = SCM_VECTOR_LENGTH (old_fluids); @@ -104,10 +104,10 @@ fluid_print (SCM exp, SCM port, scm_print_state *pstate) return 1; } -static int +static scm_bits_t next_fluid_num () { - int n; + scm_bits_t n; SCM_CRITICAL_SECTION_START; n = n_fluids++; SCM_CRITICAL_SECTION_END; @@ -125,7 +125,7 @@ SCM_DEFINE (scm_make_fluid, "make-fluid", 0, 0, 0, "in its own dynamic root, you can use fluids for thread local storage.") #define FUNC_NAME s_scm_make_fluid { - int n; + scm_bits_t n; n = next_fluid_num (); SCM_RETURN_NEWSMOB (scm_tc16_fluid, n); @@ -149,7 +149,7 @@ SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0, "@code{#f}.") #define FUNC_NAME s_scm_fluid_ref { - int n; + scm_bits_t n; SCM_VALIDATE_FLUID (1, fluid); @@ -166,7 +166,7 @@ SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0, "Set the value associated with @var{fluid} in the current dynamic root.") #define FUNC_NAME s_scm_fluid_set_x { - int n; + scm_bits_t n; SCM_VALIDATE_FLUID (1, fluid); n = SCM_FLUID_NUM (fluid); @@ -234,7 +234,7 @@ scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata) #define FUNC_NAME "scm_c_with_fluids" { SCM ans; - int flen, vlen; + scm_bits_t flen, vlen; SCM_VALIDATE_LIST_COPYLEN (1, fluids, flen); SCM_VALIDATE_LIST_COPYLEN (2, values, vlen); diff --git a/libguile/fports.c b/libguile/fports.c index 4579d3eb7..68fba2b13 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -59,7 +59,7 @@ #ifdef HAVE_UNISTD_H #include #else -scm_sizet fwrite (); +size_t fwrite (); #endif #ifdef HAVE_ST_BLKSIZE #include @@ -74,20 +74,20 @@ scm_bits_t scm_tc16_fport; /* default buffer size, used if the O/S won't supply a value. */ -static const int default_buffer_size = 1024; +static const size_t default_buffer_size = 1024; /* create FPORT buffer with specified sizes (or -1 to use default size or 0 for no buffer. */ static void -scm_fport_buffer_add (SCM port, int read_size, int write_size) +scm_fport_buffer_add (SCM port, scm_bits_t read_size, scm_bits_t write_size) #define FUNC_NAME "scm_fport_buffer_add" { - struct scm_fport *fp = SCM_FSTREAM (port); - scm_port *pt = SCM_PTAB_ENTRY (port); + scm_fport_t *fp = SCM_FSTREAM (port); + scm_port_t *pt = SCM_PTAB_ENTRY (port); if (read_size == -1 || write_size == -1) { - int default_size; + size_t default_size; #ifdef HAVE_ST_BLKSIZE struct stat st; @@ -148,8 +148,9 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, "@end table") #define FUNC_NAME s_scm_setvbuf { - int cmode, csize; - scm_port *pt; + int cmode; + scm_bits_t csize; + scm_port_t *pt; port = SCM_COERCE_OUTPORT (port); @@ -202,7 +203,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, void scm_evict_ports (int fd) { - int i; + scm_bits_t i; for (i = 0; i < scm_port_table_size; i++) { @@ -210,7 +211,7 @@ scm_evict_ports (int fd) if (SCM_FPORTP (port)) { - struct scm_fport *fp = SCM_FSTREAM (port); + scm_fport_t *fp = SCM_FSTREAM (port); if (fp->fdes == fd) { @@ -361,7 +362,7 @@ scm_fdes_to_port (int fdes, char *mode, SCM name) { long mode_bits = scm_mode_bits (mode); SCM port; - scm_port *pt; + scm_port_t *pt; int flags; /* test that fdes is valid. */ @@ -383,8 +384,8 @@ scm_fdes_to_port (int fdes, char *mode, SCM name) SCM_SET_CELL_TYPE (port, (scm_tc16_fport | mode_bits)); { - struct scm_fport *fp - = (struct scm_fport *) scm_must_malloc (sizeof (struct scm_fport), + scm_fport_t *fp + = (scm_fport_t *) scm_must_malloc (sizeof (scm_fport_t), FUNC_NAME); fp->fdes = fdes; @@ -504,9 +505,9 @@ static void fport_flush (SCM port); static int fport_fill_input (SCM port) { - int count; - scm_port *pt = SCM_PTAB_ENTRY (port); - struct scm_fport *fp = SCM_FSTREAM (port); + scm_bits_t count; + scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_fport_t *fp = SCM_FSTREAM (port); #ifdef GUILE_ISELECT fport_wait_for_input (port); @@ -527,8 +528,8 @@ fport_fill_input (SCM port) static off_t fport_seek (SCM port, off_t offset, int whence) { - scm_port *pt = SCM_PTAB_ENTRY (port); - struct scm_fport *fp = SCM_FSTREAM (port); + scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_fport_t *fp = SCM_FSTREAM (port); off_t rv; off_t result; @@ -579,7 +580,7 @@ fport_seek (SCM port, off_t offset, int whence) static void fport_truncate (SCM port, off_t length) { - struct scm_fport *fp = SCM_FSTREAM (port); + scm_fport_t *fp = SCM_FSTREAM (port); if (ftruncate (fp->fdes, length) == -1) scm_syserror ("ftruncate"); @@ -610,7 +611,7 @@ static void fport_write (SCM port, const void *data, size_t size) { /* this procedure tries to minimize the number of writes/flushes. */ - scm_port *pt = SCM_PTAB_ENTRY (port); + scm_port_t *pt = SCM_PTAB_ENTRY (port); if (pt->write_buf == &pt->shortbuf || (pt->write_pos == pt->write_buf && size >= pt->write_buf_size)) @@ -671,22 +672,22 @@ extern int terminating; static void fport_flush (SCM port) { - scm_port *pt = SCM_PTAB_ENTRY (port); - struct scm_fport *fp = SCM_FSTREAM (port); + scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_fport_t *fp = SCM_FSTREAM (port); unsigned char *ptr = pt->write_buf; - int init_size = pt->write_pos - pt->write_buf; - int remaining = init_size; + scm_bits_t init_size = pt->write_pos - pt->write_buf; + scm_bits_t remaining = init_size; while (remaining > 0) { - int count; + scm_bits_t count; SCM_SYSCALL (count = write (fp->fdes, ptr, remaining)); if (count < 0) { /* error. assume nothing was written this call, but fix up the buffer for any previous successful writes. */ - int done = init_size - remaining; + scm_bits_t done = init_size - remaining; if (done > 0) { @@ -729,8 +730,8 @@ fport_flush (SCM port) static void fport_end_input (SCM port, int offset) { - struct scm_fport *fp = SCM_FSTREAM (port); - scm_port *pt = SCM_PTAB_ENTRY (port); + scm_fport_t *fp = SCM_FSTREAM (port); + scm_port_t *pt = SCM_PTAB_ENTRY (port); offset += pt->read_end - pt->read_pos; @@ -748,8 +749,8 @@ fport_end_input (SCM port, int offset) static int fport_close (SCM port) { - struct scm_fport *fp = SCM_FSTREAM (port); - scm_port *pt = SCM_PTAB_ENTRY (port); + scm_fport_t *fp = SCM_FSTREAM (port); + scm_port_t *pt = SCM_PTAB_ENTRY (port); int rv; fport_flush (port); @@ -773,7 +774,7 @@ fport_close (SCM port) return rv; } -static scm_sizet +static size_t fport_free (SCM port) { fport_close (port); diff --git a/libguile/fports.h b/libguile/fports.h index 3d970d9a8..efdf81885 100644 --- a/libguile/fports.h +++ b/libguile/fports.h @@ -54,13 +54,17 @@ /* struct allocated for each buffered FPORT. */ -struct scm_fport { +typedef struct scm_fport_t { int fdes; /* file descriptor. */ -}; +} scm_fport_t; + +#if (SCM_DEBUG_DEPRECATED == 0) +# define scm_fport scm_fport_t +#endif extern scm_bits_t scm_tc16_fport; -#define SCM_FSTREAM(x) ((struct scm_fport *) SCM_STREAM (x)) +#define SCM_FSTREAM(x) ((scm_fport_t *) SCM_STREAM (x)) #define SCM_FPORT_FDES(x) (SCM_FSTREAM (x)->fdes) #define SCM_FPORTP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_fport)) diff --git a/libguile/gc.c b/libguile/gc.c index 657346d84..3aaab5c0e 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -71,6 +71,7 @@ #include "libguile/tags.h" #include "libguile/validate.h" +#include "libguile/deprecation.h" #include "libguile/gc.h" #ifdef GUILE_DEBUG_MALLOC @@ -124,7 +125,8 @@ scm_assert_cell_valid (SCM cell) if (!scm_cellp (cell)) { - fprintf (stderr, "scm_assert_cell_valid: Not a cell object: %lx\n", SCM_UNPACK (cell)); + fprintf (stderr, "scm_assert_cell_valid: Not a cell object: %lux\n", + (unsigned long) SCM_UNPACK (cell)); abort (); } else if (!scm_gc_running_p) @@ -140,7 +142,8 @@ scm_assert_cell_valid (SCM cell) */ if (SCM_FREE_CELL_P (cell)) { - fprintf (stderr, "scm_assert_cell_valid: Accessing free cell: %lx\n", SCM_UNPACK (cell)); + fprintf (stderr, "scm_assert_cell_valid: Accessing free cell: %lux\n", + (unsigned long) SCM_UNPACK (cell)); abort (); } } @@ -187,7 +190,7 @@ SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0, * * If SCM_INIT_HEAP_SIZE heap cannot be allocated initially, SCM_HEAP_SEG_SIZE * will be used, and the heap will grow by SCM_HEAP_SEG_SIZE when more - * heap is needed. SCM_HEAP_SEG_SIZE must fit into type scm_sizet. This code + * heap is needed. SCM_HEAP_SEG_SIZE must fit into type size_t. This code * is in scm_init_storage() and alloc_some_heap() in sys.c * * If SCM_INIT_HEAP_SIZE can be allocated initially, the heap will grow by @@ -216,19 +219,19 @@ SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0, #define SCM_DATA_CELLS2CARDS(n) (((n) + SCM_GC_CARD_N_DATA_CELLS - 1) / SCM_GC_CARD_N_DATA_CELLS) #define SCM_CARDS_PER_CLUSTER SCM_DATA_CELLS2CARDS (2000L) #define SCM_CLUSTER_SIZE_1 (SCM_CARDS_PER_CLUSTER * SCM_GC_CARD_N_DATA_CELLS) -int scm_default_init_heap_size_1 = (((SCM_DATA_CELLS2CARDS (45000L) + SCM_CARDS_PER_CLUSTER - 1) +size_t scm_default_init_heap_size_1 = (((SCM_DATA_CELLS2CARDS (45000L) + SCM_CARDS_PER_CLUSTER - 1) / SCM_CARDS_PER_CLUSTER) * SCM_GC_CARD_SIZE); int scm_default_min_yield_1 = 40; #define SCM_CLUSTER_SIZE_2 (SCM_CARDS_PER_CLUSTER * (SCM_GC_CARD_N_DATA_CELLS / 2)) -int scm_default_init_heap_size_2 = (((SCM_DATA_CELLS2CARDS (2500L * 2) + SCM_CARDS_PER_CLUSTER - 1) +size_t scm_default_init_heap_size_2 = (((SCM_DATA_CELLS2CARDS (2500L * 2) + SCM_CARDS_PER_CLUSTER - 1) / SCM_CARDS_PER_CLUSTER) * SCM_GC_CARD_SIZE); /* The following value may seem large, but note that if we get to GC at * all, this means that we have a numerically intensive application */ int scm_default_min_yield_2 = 40; -int scm_default_max_segment_size = 2097000L;/* a little less (adm) than 2 Mb */ +size_t scm_default_max_segment_size = 2097000L;/* a little less (adm) than 2 Mb */ #define SCM_MIN_HEAP_SEG_SIZE (8 * SCM_GC_CARD_SIZE) #ifdef _QC @@ -254,11 +257,11 @@ int scm_default_max_segment_size = 2097000L;/* a little less (adm) than 2 Mb */ # define CELL_DN(p, span) MK_FP(FP_SEG(p), ~(8*(span)-1)&FP_OFF(p)) #else # ifdef _UNICOS -# define CELL_UP(p, span) (SCM_CELLPTR)(~(span) & ((long)(p)+(span))) -# define CELL_DN(p, span) (SCM_CELLPTR)(~(span) & (long)(p)) +# define CELL_UP(p, span) (SCM_CELLPTR)(~(span) & ((scm_ubits_t)(p)+(span))) +# define CELL_DN(p, span) (SCM_CELLPTR)(~(span) & (scm_ubits_t)(p)) # else -# define CELL_UP(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & ((long)(p)+sizeof(scm_cell)*(span)-1L)) -# define CELL_DN(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & (long)(p)) +# define CELL_UP(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & ((scm_ubits_t)(p)+sizeof(scm_cell)*(span)-1L)) +# define CELL_DN(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & (scm_ubits_t)(p)) # endif /* UNICOS */ #endif /* PROT386 */ @@ -285,7 +288,7 @@ typedef struct scm_freelist_t { SCM clusters; SCM *clustertail; /* this is the number of objects in each cluster, including the spine cell */ - int cluster_size; + unsigned int cluster_size; /* indicates that we should grow heap instead of GC:ing */ int grow_heap_p; @@ -298,13 +301,13 @@ typedef struct scm_freelist_t { /* number of cells per object on this list */ int span; /* number of collected cells during last GC */ - long collected; + scm_ubits_t collected; /* number of collected cells during penultimate GC */ - long collected_1; + scm_ubits_t collected_1; /* total number of cells in heap segments * belonging to this list. */ - long heap_size; + scm_ubits_t heap_size; } scm_freelist_t; SCM scm_freelist = SCM_EOL; @@ -319,7 +322,7 @@ scm_freelist_t scm_master_freelist2 = { /* scm_mtrigger * is the number of bytes of must_malloc allocation needed to trigger gc. */ -unsigned long scm_mtrigger; +scm_ubits_t scm_mtrigger; /* scm_gc_heap_lock * If set, don't expand the heap. Set only during gc, during which no allocation @@ -344,20 +347,20 @@ SCM scm_structs_to_free; /* GC Statistics Keeping */ -unsigned long scm_cells_allocated = 0; -long scm_mallocated = 0; -unsigned long scm_gc_cells_collected; -unsigned long scm_gc_yield; -static unsigned long scm_gc_yield_1 = 0; /* previous GC yield */ -unsigned long scm_gc_malloc_collected; -unsigned long scm_gc_ports_collected; +scm_ubits_t scm_cells_allocated = 0; +scm_ubits_t scm_mallocated = 0; +scm_ubits_t scm_gc_cells_collected; +scm_ubits_t scm_gc_yield; +static scm_ubits_t scm_gc_yield_1 = 0; /* previous GC yield */ +scm_ubits_t scm_gc_malloc_collected; +scm_ubits_t scm_gc_ports_collected; unsigned long scm_gc_time_taken = 0; -static unsigned long t_before_gc; -static unsigned long t_before_sweep; +static scm_ubits_t t_before_gc; +static scm_ubits_t t_before_sweep; unsigned long scm_gc_mark_time_taken = 0; unsigned long scm_gc_sweep_time_taken = 0; -unsigned long scm_gc_times = 0; -unsigned long scm_gc_cells_swept = 0; +scm_ubits_t scm_gc_times = 0; +scm_ubits_t scm_gc_cells_swept = 0; double scm_gc_cells_marked_acc = 0.; double scm_gc_cells_swept_acc = 0.; @@ -388,7 +391,7 @@ typedef struct scm_heap_seg_data_t -static scm_sizet init_heap_seg (SCM_CELLPTR, scm_sizet, scm_freelist_t *); +static size_t init_heap_seg (SCM_CELLPTR, size_t, scm_freelist_t *); typedef enum { return_on_error, abort_on_error } policy_on_error; static void alloc_some_heap (scm_freelist_t *, policy_on_error); @@ -412,7 +415,7 @@ typedef struct scm_mark_space_t static scm_mark_space_t *current_mark_space; static scm_mark_space_t **mark_space_ptr; -static int current_mark_space_offset; +static ptrdiff_t current_mark_space_offset; static scm_mark_space_t *mark_space_head; static scm_c_bvec_limb_t * @@ -479,17 +482,17 @@ clear_mark_space () #if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST) /* Return the number of the heap segment containing CELL. */ -static int +static scm_bits_t which_seg (SCM cell) { - int i; + scm_bits_t i; for (i = 0; i < scm_n_heap_segs; i++) if (SCM_PTR_LE (scm_heap_table[i].bounds[0], SCM2PTR (cell)) && SCM_PTR_GT (scm_heap_table[i].bounds[1], SCM2PTR (cell))) return i; - fprintf (stderr, "which_seg: can't find segment containing cell %lx\n", - SCM_UNPACK (cell)); + fprintf (stderr, "which_seg: can't find segment containing cell %lux\n", + (unsigned long) SCM_UNPACK (cell)); abort (); } @@ -497,26 +500,26 @@ which_seg (SCM cell) static void map_free_list (scm_freelist_t *master, SCM freelist) { - int last_seg = -1, count = 0; + scm_bits_t last_seg = -1, count = 0; SCM f; for (f = freelist; !SCM_NULLP (f); f = SCM_FREE_CELL_CDR (f)) { - int this_seg = which_seg (f); + scm_bits_t this_seg = which_seg (f); if (this_seg != last_seg) { if (last_seg != -1) - fprintf (stderr, " %5d %d-cells in segment %d\n", - count, master->span, last_seg); + fprintf (stderr, " %5ld %d-cells in segment %ld\n", + (long) count, master->span, (long) last_seg); last_seg = this_seg; count = 0; } count++; } if (last_seg != -1) - fprintf (stderr, " %5d %d-cells in segment %d\n", - count, master->span, last_seg); + fprintf (stderr, " %5ld %d-cells in segment %ld\n", + (long) count, master->span, (long) last_seg); } SCM_DEFINE (scm_map_free_list, "map-free-list", 0, 0, 0, @@ -526,15 +529,15 @@ SCM_DEFINE (scm_map_free_list, "map-free-list", 0, 0, 0, "@code{--enable-guile-debug} builds of Guile.") #define FUNC_NAME s_scm_map_free_list { - int i; - fprintf (stderr, "%d segments total (%d:%d", - scm_n_heap_segs, + scm_bits_t i; + fprintf (stderr, "%ld segments total (%d:%ld", + (long) scm_n_heap_segs, scm_heap_table[0].span, - scm_heap_table[0].bounds[1] - scm_heap_table[0].bounds[0]); + (long) (scm_heap_table[0].bounds[1] - scm_heap_table[0].bounds[0])); for (i = 1; i < scm_n_heap_segs; i++) - fprintf (stderr, ", %d:%d", + fprintf (stderr, ", %d:%ld", scm_heap_table[i].span, - scm_heap_table[i].bounds[1] - scm_heap_table[i].bounds[0]); + (long) (scm_heap_table[i].bounds[1] - scm_heap_table[i].bounds[0])); fprintf (stderr, ")\n"); map_free_list (&scm_master_freelist, scm_freelist); map_free_list (&scm_master_freelist2, scm_freelist2); @@ -544,20 +547,20 @@ SCM_DEFINE (scm_map_free_list, "map-free-list", 0, 0, 0, } #undef FUNC_NAME -static int last_cluster; -static int last_size; +static scm_bits_t last_cluster; +static scm_bits_t last_size; -static int -free_list_length (char *title, int i, SCM freelist) +static scm_bits_t +free_list_length (char *title, scm_bits_t i, SCM freelist) { SCM ls; - int n = 0; + scm_bits_t n = 0; for (ls = freelist; !SCM_NULLP (ls); ls = SCM_FREE_CELL_CDR (ls)) if (SCM_FREE_CELL_P (ls)) ++n; else { - fprintf (stderr, "bad cell in %s at position %d\n", title, n); + fprintf (stderr, "bad cell in %s at position %ld\n", title, (long) n); abort (); } if (n != last_size) @@ -565,14 +568,14 @@ free_list_length (char *title, int i, SCM freelist) if (i > 0) { if (last_cluster == i - 1) - fprintf (stderr, "\t%d\n", last_size); + fprintf (stderr, "\t%ld\n", (long) last_size); else - fprintf (stderr, "-%d\t%d\n", i - 1, last_size); + fprintf (stderr, "-%ld\t%ld\n", (long) (i - 1), (long) last_size); } if (i >= 0) - fprintf (stderr, "%s %d", title, i); + fprintf (stderr, "%s %ld", title, (long) i); else - fprintf (stderr, "%s\t%d\n", title, n); + fprintf (stderr, "%s\t%ld\n", title, (long) n); last_cluster = i; last_size = n; } @@ -583,7 +586,7 @@ static void free_list_lengths (char *title, scm_freelist_t *master, SCM freelist) { SCM clusters; - int i = 0, len, n = 0; + scm_bits_t i = 0, len, n = 0; fprintf (stderr, "%s\n\n", title); n += free_list_length ("free list", -1, freelist); for (clusters = master->clusters; @@ -594,10 +597,10 @@ free_list_lengths (char *title, scm_freelist_t *master, SCM freelist) n += len; } if (last_cluster == i - 1) - fprintf (stderr, "\t%d\n", last_size); + fprintf (stderr, "\t%ld\n", (long) last_size); else - fprintf (stderr, "-%d\t%d\n", i - 1, last_size); - fprintf (stderr, "\ntotal %d objects\n\n", n); + fprintf (stderr, "-%ld\t%ld\n", (long) (i - 1), (long) last_size); + fprintf (stderr, "\ntotal %ld objects\n\n", (long) n); } SCM_DEFINE (scm_free_list_length, "free-list-length", 0, 0, 0, @@ -622,8 +625,8 @@ SCM_DEFINE (scm_free_list_length, "free-list-length", 0, 0, 0, static int scm_debug_check_freelist = 0; /* Number of calls to SCM_NEWCELL since startup. */ -static unsigned long scm_newcell_count; -static unsigned long scm_newcell2_count; +static scm_ubits_t scm_newcell_count; +static scm_ubits_t scm_newcell2_count; /* Search freelist for anything that isn't marked as a free cell. Abort if we find something. */ @@ -631,13 +634,13 @@ static void scm_check_freelist (SCM freelist) { SCM f; - int i = 0; + scm_bits_t i = 0; for (f = freelist; !SCM_NULLP (f); f = SCM_FREE_CELL_CDR (f), i++) if (!SCM_FREE_CELL_P (f)) { - fprintf (stderr, "Bad cell in freelist on newcell %lu: %d'th elt\n", - scm_newcell_count, i); + fprintf (stderr, "Bad cell in freelist on newcell %lu: %lu'th elt\n", + (long) scm_newcell_count, (long) i); abort (); } } @@ -719,26 +722,26 @@ scm_debug_newcell2 (void) -static unsigned long +static scm_ubits_t master_cells_allocated (scm_freelist_t *master) { /* the '- 1' below is to ignore the cluster spine cells. */ - int objects = master->clusters_allocated * (master->cluster_size - 1); + scm_bits_t objects = master->clusters_allocated * (master->cluster_size - 1); if (SCM_NULLP (master->clusters)) objects -= master->left_to_collect; return master->span * objects; } -static unsigned long +static scm_ubits_t freelist_length (SCM freelist) { - int n; + scm_bits_t n; for (n = 0; !SCM_NULLP (freelist); freelist = SCM_FREE_CELL_CDR (freelist)) ++n; return n; } -static unsigned long +static scm_ubits_t compute_cells_allocated () { return (scm_cells_allocated @@ -757,17 +760,17 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, "use of storage.") #define FUNC_NAME s_scm_gc_stats { - int i; - int n; + scm_bits_t i; + scm_bits_t n; SCM heap_segs; - long int local_scm_mtrigger; - long int local_scm_mallocated; - long int local_scm_heap_size; - long int local_scm_cells_allocated; - long int local_scm_gc_time_taken; - long int local_scm_gc_times; - long int local_scm_gc_mark_time_taken; - long int local_scm_gc_sweep_time_taken; + scm_ubits_t local_scm_mtrigger; + scm_ubits_t local_scm_mallocated; + scm_ubits_t local_scm_heap_size; + scm_ubits_t local_scm_cells_allocated; + unsigned long local_scm_gc_time_taken; + scm_ubits_t local_scm_gc_times; + unsigned long local_scm_gc_mark_time_taken; + unsigned long local_scm_gc_sweep_time_taken; double local_scm_gc_cells_swept; double local_scm_gc_cells_marked; SCM answer; @@ -780,8 +783,8 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, heap_segs = SCM_EOL; n = scm_n_heap_segs; for (i = scm_n_heap_segs; i--; ) - heap_segs = scm_cons (scm_cons (scm_ulong2num ((unsigned long)scm_heap_table[i].bounds[1]), - scm_ulong2num ((unsigned long)scm_heap_table[i].bounds[0])), + heap_segs = scm_cons (scm_cons (scm_ubits2num ((scm_ubits_t)scm_heap_table[i].bounds[1]), + scm_ubits2num ((scm_ubits_t)scm_heap_table[i].bounds[0])), heap_segs); if (scm_n_heap_segs != n) goto retry; @@ -803,15 +806,15 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, local_scm_gc_cells_marked = scm_gc_cells_marked_acc; answer = scm_listify (scm_cons (sym_gc_time_taken, scm_ulong2num (local_scm_gc_time_taken)), - scm_cons (sym_cells_allocated, scm_ulong2num (local_scm_cells_allocated)), - scm_cons (sym_heap_size, scm_ulong2num (local_scm_heap_size)), - scm_cons (sym_mallocated, scm_ulong2num (local_scm_mallocated)), - scm_cons (sym_mtrigger, scm_ulong2num (local_scm_mtrigger)), - scm_cons (sym_times, scm_ulong2num (local_scm_gc_times)), + scm_cons (sym_cells_allocated, scm_ubits2num (local_scm_cells_allocated)), + scm_cons (sym_heap_size, scm_ubits2num (local_scm_heap_size)), + scm_cons (sym_mallocated, scm_ubits2num (local_scm_mallocated)), + scm_cons (sym_mtrigger, scm_ubits2num (local_scm_mtrigger)), + scm_cons (sym_times, scm_ubits2num (local_scm_gc_times)), scm_cons (sym_gc_mark_time_taken, scm_ulong2num (local_scm_gc_mark_time_taken)), scm_cons (sym_gc_sweep_time_taken, scm_ulong2num (local_scm_gc_sweep_time_taken)), - scm_cons (sym_cells_marked, scm_dbl2big (local_scm_gc_cells_marked)), - scm_cons (sym_cells_swept, scm_dbl2big (local_scm_gc_cells_swept)), + scm_cons (sym_cells_marked, scm_i_dbl2big (local_scm_gc_cells_marked)), + scm_cons (sym_cells_swept, scm_i_dbl2big (local_scm_gc_cells_swept)), scm_cons (sym_heap_segments, heap_segs), SCM_UNDEFINED); SCM_ALLOW_INTS; @@ -854,7 +857,7 @@ SCM_DEFINE (scm_object_address, "object-address", 1, 0, 0, "returned by this function for @var{obj}") #define FUNC_NAME s_scm_object_address { - return scm_ulong2num ((unsigned long) SCM_UNPACK (obj)); + return scm_ubits2num (SCM_UNPACK (obj)); } #undef FUNC_NAME @@ -897,12 +900,12 @@ adjust_min_yield (scm_freelist_t *freelist) if (freelist->min_yield_fraction) { /* Pick largest of last two yields. */ - int delta = ((SCM_HEAP_SIZE * freelist->min_yield_fraction / 100) + long delta = ((SCM_HEAP_SIZE * freelist->min_yield_fraction / 100) - (long) SCM_MAX (scm_gc_yield_1, scm_gc_yield)); #ifdef DEBUGINFO - fprintf (stderr, " after GC = %d, delta = %d\n", - scm_cells_allocated, - delta); + fprintf (stderr, " after GC = %lu, delta = %ld\n", + (long) scm_cells_allocated, + (long) delta); #endif if (delta > 0) freelist->min_yield += delta; @@ -939,10 +942,10 @@ scm_gc_for_newcell (scm_freelist_t *master, SCM *freelist) * both cases we have to try gc to get some free cells. */ #ifdef DEBUGINFO - fprintf (stderr, "allocated = %d, ", - scm_cells_allocated + fprintf (stderr, "allocated = %lu, ", + (long) (scm_cells_allocated + master_cells_allocated (&scm_master_freelist) - + master_cells_allocated (&scm_master_freelist2)); + + master_cells_allocated (&scm_master_freelist2))); #endif scm_igc ("cells"); adjust_min_yield (master); @@ -999,7 +1002,7 @@ scm_c_hook_t scm_after_gc_c_hook; void scm_igc (const char *what) { - int j; + scm_bits_t j; ++scm_gc_running_p; scm_c_hook_run (&scm_before_gc_c_hook, 0); @@ -1022,14 +1025,6 @@ scm_igc (const char *what) gc_start_stats (what); - if (scm_mallocated < 0) - /* The byte count of allocated objects has underflowed. This is - probably because you forgot to report the sizes of objects you - have allocated, by calling scm_done_malloc or some such. When - the GC freed them, it subtracted their size from - scm_mallocated, which underflowed. */ - abort (); - if (scm_gc_heap_lock) /* We've invoked the collector while a GC is already in progress. That should never happen. */ @@ -1039,8 +1034,8 @@ scm_igc (const char *what) /* flush dead entries from the continuation stack */ { - int x; - int bound; + scm_bits_t x; + scm_bits_t bound; SCM * elts; elts = SCM_VELTS (scm_continuation_stack); bound = SCM_VECTOR_LENGTH (scm_continuation_stack); @@ -1063,12 +1058,12 @@ scm_igc (const char *what) /* This assumes that all registers are saved into the jmp_buf */ setjmp (scm_save_regs_gc_mark); scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark, - ( (scm_sizet) (sizeof (SCM_STACKITEM) - 1 + + ( (size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof scm_save_regs_gc_mark) / sizeof (SCM_STACKITEM))); { - scm_sizet stack_len = scm_stack_size (scm_stack_base); + size_t stack_len = scm_stack_size (scm_stack_base); #ifdef SCM_STACK_GROWS_UP scm_mark_locations (scm_stack_base, stack_len); #else @@ -1129,7 +1124,7 @@ void MARK (SCM p) #define FUNC_NAME FNAME { - register long i; + register scm_bits_t i; register SCM ptr; scm_bits_t cell_type; @@ -1238,7 +1233,7 @@ gc_mark_loop_first_time: { /* ptr is a struct */ SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]); - int len = SCM_SYMBOL_LENGTH (layout); + scm_bits_t len = SCM_SYMBOL_LENGTH (layout); char * fields_desc = SCM_SYMBOL_CHARS (layout); scm_bits_t * struct_data = (scm_bits_t *) SCM_STRUCT_DATA (ptr); @@ -1249,7 +1244,7 @@ gc_mark_loop_first_time: } if (len) { - int x; + scm_bits_t x; for (x = 0; x < len - 2; x += 2, ++struct_data) if (fields_desc[x] == 'p') @@ -1290,8 +1285,8 @@ gc_mark_loop_first_time: #ifdef CCLO case scm_tc7_cclo: { - unsigned long int i = SCM_CCLO_LENGTH (ptr); - unsigned long int j; + size_t i = SCM_CCLO_LENGTH (ptr); + size_t j; for (j = 1; j != i; ++j) { SCM obj = SCM_CCLO_REF (ptr, j); @@ -1327,8 +1322,8 @@ gc_mark_loop_first_time: scm_weak_vectors = ptr; if (SCM_IS_WHVEC_ANY (ptr)) { - int x; - int len; + scm_bits_t x; + scm_bits_t len; int weak_keys; int weak_values; @@ -1454,9 +1449,9 @@ gc_mark_loop_first_time: */ void -scm_mark_locations (SCM_STACKITEM x[], scm_sizet n) +scm_mark_locations (SCM_STACKITEM x[], scm_ubits_t n) { - unsigned long m; + scm_ubits_t m; for (m = 0; m < n; ++m) { @@ -1464,14 +1459,14 @@ scm_mark_locations (SCM_STACKITEM x[], scm_sizet n) if (SCM_CELLP (obj)) { SCM_CELLPTR ptr = SCM2PTR (obj); - int i = 0; - int j = scm_n_heap_segs - 1; + scm_bits_t i = 0; + scm_bits_t j = scm_n_heap_segs - 1; if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr) && SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr)) { while (i <= j) { - int seg_id; + scm_bits_t seg_id; seg_id = -1; if ((i == j) || SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr)) @@ -1480,7 +1475,7 @@ scm_mark_locations (SCM_STACKITEM x[], scm_sizet n) seg_id = j; else { - int k; + scm_bits_t k; k = (i + j) / 2; if (k == i) break; @@ -1528,14 +1523,14 @@ scm_cellp (SCM value) { if (SCM_CELLP (value)) { scm_cell * ptr = SCM2PTR (value); - unsigned int i = 0; - unsigned int j = scm_n_heap_segs - 1; + scm_bits_t i = 0; + scm_bits_t j = scm_n_heap_segs - 1; if (SCM_GC_IN_CARD_HEADERP (ptr)) return 0; while (i < j) { - int k = (i + j) / 2; + scm_bits_t k = (i + j) / 2; if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr)) { j = k; } else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr)) { @@ -1571,7 +1566,7 @@ gc_sweep_freelist_start (scm_freelist_t *freelist) static void gc_sweep_freelist_finish (scm_freelist_t *freelist) { - int collected; + scm_bits_t collected; *freelist->clustertail = freelist->cells; if (!SCM_NULLP (freelist->cells)) { @@ -1609,10 +1604,10 @@ scm_gc_sweep () register SCM_CELLPTR ptr; register SCM nfreelist; register scm_freelist_t *freelist; - register long m; + register scm_ubits_t m; register int span; - long i; - scm_sizet seg_size; + scm_bits_t i; + size_t seg_size; m = 0; @@ -1621,8 +1616,8 @@ scm_gc_sweep () for (i = 0; i < scm_n_heap_segs; i++) { - register unsigned int left_to_collect; - register scm_sizet j; + register scm_bits_t left_to_collect; + register size_t j; /* Unmarked cells go onto the front of the freelist this heap segment points to. Rather than updating the real freelist @@ -1700,7 +1695,7 @@ scm_gc_sweep () break; case scm_tc7_vector: { - unsigned long int length = SCM_VECTOR_LENGTH (scmptr); + scm_ubits_t length = SCM_VECTOR_LENGTH (scmptr); if (length > 0) { m += length * sizeof (scm_bits_t); @@ -1717,10 +1712,10 @@ scm_gc_sweep () #ifdef HAVE_ARRAYS case scm_tc7_bvect: { - unsigned long int length = SCM_BITVECTOR_LENGTH (scmptr); + size_t length = SCM_BITVECTOR_LENGTH (scmptr); if (length > 0) { - m += sizeof (long) * ((length + SCM_LONG_BIT - 1) / SCM_LONG_BIT); + m += sizeof (long) * ((length + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH); scm_must_free (SCM_BITVECTOR_BASE (scmptr)); } } @@ -1832,7 +1827,7 @@ scm_gc_sweep () #ifdef GC_FREE_SEGMENTS if (n == seg_size) { - register long j; + register scm_bits_t j; freelist->heap_size -= seg_size; free ((char *) scm_heap_table[i].bounds[0]); @@ -1866,6 +1861,15 @@ scm_gc_sweep () scm_cells_allocated = (SCM_HEAP_SIZE - scm_gc_cells_collected); scm_gc_yield -= scm_cells_allocated; + + if (scm_mallocated < m) + /* The byte count of allocated objects has underflowed. This is + probably because you forgot to report the sizes of objects you + have allocated, by calling scm_done_malloc or some such. When + the GC freed them, it subtracted their size from + scm_mallocated, which underflowed. */ + abort (); + scm_mallocated -= m; scm_gc_malloc_collected = m; } @@ -1896,10 +1900,16 @@ scm_gc_sweep () * The limit scm_mtrigger may be raised by this allocation. */ void * -scm_must_malloc (scm_sizet size, const char *what) +scm_must_malloc (size_t size, const char *what) { void *ptr; - unsigned long nm = scm_mallocated + size; + scm_ubits_t nm = scm_mallocated + size; + + if (nm < size) + /* The byte count of allocated objects has overflowed. This is + probably because you forgot to report the correct size of freed + memory in some of your smob free methods. */ + abort (); if (nm <= scm_mtrigger) { @@ -1917,6 +1927,13 @@ scm_must_malloc (scm_sizet size, const char *what) scm_igc (what); nm = scm_mallocated + size; + + if (nm < size) + /* The byte count of allocated objects has overflowed. This is + probably because you forgot to report the correct size of freed + memory in some of your smob free methods. */ + abort (); + SCM_SYSCALL (ptr = malloc (size)); if (NULL != ptr) { @@ -1943,12 +1960,23 @@ scm_must_malloc (scm_sizet size, const char *what) */ void * scm_must_realloc (void *where, - scm_sizet old_size, - scm_sizet size, + size_t old_size, + size_t size, const char *what) { void *ptr; - scm_sizet nm = scm_mallocated + size - old_size; + scm_ubits_t nm; + + if (size <= old_size) + return where; + + nm = scm_mallocated + size - old_size; + + if (nm < (size - old_size)) + /* The byte count of allocated objects has overflowed. This is + probably because you forgot to report the correct size of freed + memory in some of your smob free methods. */ + abort (); if (nm <= scm_mtrigger) { @@ -1966,6 +1994,13 @@ scm_must_realloc (void *where, scm_igc (what); nm = scm_mallocated + size - old_size; + + if (nm < (size - old_size)) + /* The byte count of allocated objects has overflowed. This is + probably because you forgot to report the correct size of freed + memory in some of your smob free methods. */ + abort (); + SCM_SYSCALL (ptr = realloc (where, size)); if (NULL != ptr) { @@ -1986,7 +2021,7 @@ scm_must_realloc (void *where, } char * -scm_must_strndup (const char *str, unsigned long length) +scm_must_strndup (const char *str, size_t length) { char * dst = scm_must_malloc (length + 1, "scm_must_strndup"); memcpy (dst, str, length); @@ -2030,8 +2065,25 @@ scm_must_free (void *obj) * eh? Or even better, call scm_done_free. */ void -scm_done_malloc (long size) +scm_done_malloc (scm_bits_t size) { + if (size < 0) { + if (scm_mallocated < size) + /* The byte count of allocated objects has underflowed. This is + probably because you forgot to report the sizes of objects you + have allocated, by calling scm_done_malloc or some such. When + the GC freed them, it subtracted their size from + scm_mallocated, which underflowed. */ + abort (); + } else { + scm_ubits_t nm = scm_mallocated + size; + if (nm < size) + /* The byte count of allocated objects has overflowed. This is + probably because you forgot to report the correct size of freed + memory in some of your smob free methods. */ + abort (); + } + scm_mallocated += size; if (scm_mallocated > scm_mtrigger) @@ -2048,8 +2100,25 @@ scm_done_malloc (long size) } void -scm_done_free (long size) +scm_done_free (scm_bits_t size) { + if (size >= 0) { + if (scm_mallocated < size) + /* The byte count of allocated objects has underflowed. This is + probably because you forgot to report the sizes of objects you + have allocated, by calling scm_done_malloc or some such. When + the GC freed them, it subtracted their size from + scm_mallocated, which underflowed. */ + abort (); + } else { + scm_ubits_t nm = scm_mallocated + size; + if (nm < size) + /* The byte count of allocated objects has overflowed. This is + probably because you forgot to report the correct size of freed + memory in some of your smob free methods. */ + abort (); + } + scm_mallocated -= size; } @@ -2071,7 +2140,7 @@ scm_done_free (long size) */ int scm_expmem = 0; -scm_sizet scm_max_segment_size; +size_t scm_max_segment_size; /* scm_heap_org * is the lowest base address of any heap segment. @@ -2079,8 +2148,8 @@ scm_sizet scm_max_segment_size; SCM_CELLPTR scm_heap_org; scm_heap_seg_data_t * scm_heap_table = 0; -static unsigned int heap_segment_table_size = 0; -int scm_n_heap_segs = 0; +static size_t heap_segment_table_size = 0; +size_t scm_n_heap_segs = 0; /* init_heap_seg * initializes a new heap segment and returns the number of objects it contains. @@ -2100,13 +2169,13 @@ int scm_n_heap_segs = 0; SCM_GC_SET_CARD_DOUBLECELL (card); \ } while (0) -static scm_sizet -init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, scm_freelist_t *freelist) +static size_t +init_heap_seg (SCM_CELLPTR seg_org, size_t size, scm_freelist_t *freelist) { register SCM_CELLPTR ptr; SCM_CELLPTR seg_end; - int new_seg_index; - int n_new_cells; + scm_bits_t new_seg_index; + ptrdiff_t n_new_cells; int span = freelist->span; if (seg_org == NULL) @@ -2214,10 +2283,10 @@ init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, scm_freelist_t *freelist) return size; } -static scm_sizet -round_to_cluster_size (scm_freelist_t *freelist, scm_sizet len) +static size_t +round_to_cluster_size (scm_freelist_t *freelist, size_t len) { - scm_sizet cluster_size_in_bytes = CLUSTER_SIZE_IN_BYTES (freelist); + size_t cluster_size_in_bytes = CLUSTER_SIZE_IN_BYTES (freelist); return (len + cluster_size_in_bytes - 1) / cluster_size_in_bytes * cluster_size_in_bytes @@ -2229,7 +2298,7 @@ alloc_some_heap (scm_freelist_t *freelist, policy_on_error error_policy) #define FUNC_NAME "alloc_some_heap" { SCM_CELLPTR ptr; - long len; + size_t len; if (scm_gc_heap_lock) { @@ -2246,9 +2315,9 @@ alloc_some_heap (scm_freelist_t *freelist, policy_on_error error_policy) * segment. Do not yet increment scm_n_heap_segs -- that is done by * init_heap_seg only if the allocation of the segment itself succeeds. */ - unsigned int new_table_size = scm_n_heap_segs + 1; + size_t new_table_size = scm_n_heap_segs + 1; size_t size = new_table_size * sizeof (scm_heap_seg_data_t); - scm_heap_seg_data_t * new_heap_table; + scm_heap_seg_data_t *new_heap_table; SCM_SYSCALL (new_heap_table = ((scm_heap_seg_data_t *) realloc ((char *)scm_heap_table, size))); @@ -2290,11 +2359,11 @@ alloc_some_heap (scm_freelist_t *freelist, policy_on_error error_policy) * This gives dh > (f * h - y) / (1 - f) */ int f = freelist->min_yield_fraction; - long h = SCM_HEAP_SIZE; - long min_cells = (f * h - 100 * (long) scm_gc_yield) / (99 - f); + scm_ubits_t h = SCM_HEAP_SIZE; + size_t min_cells = (f * h - 100 * (long) scm_gc_yield) / (99 - f); len = SCM_EXPHEAP (freelist->heap_size); #ifdef DEBUGINFO - fprintf (stderr, "(%d < %d)", len, min_cells); + fprintf (stderr, "(%ld < %ld)", (long) len, (long) min_cells); #endif if (len < min_cells) len = min_cells + freelist->cluster_size; @@ -2307,7 +2376,7 @@ alloc_some_heap (scm_freelist_t *freelist, policy_on_error error_policy) len = scm_max_segment_size; { - scm_sizet smallest; + size_t smallest; smallest = CLUSTER_SIZE_IN_BYTES (freelist); @@ -2318,7 +2387,7 @@ alloc_some_heap (scm_freelist_t *freelist, policy_on_error error_policy) while ((len >= SCM_MIN_HEAP_SEG_SIZE) && (len >= smallest)) { - scm_sizet rounded_len = round_to_cluster_size (freelist, len); + size_t rounded_len = round_to_cluster_size (freelist, len); SCM_SYSCALL (ptr = (SCM_CELLPTR) malloc (rounded_len)); if (ptr) { @@ -2391,7 +2460,8 @@ scm_remember_upto_here (SCM obj, ...) void scm_remember (SCM *ptr) { - /* empty */ + scm_c_issue_deprecation_warning ("`scm_remember' is deprecated. " + "Use the `scm_remember_upto_here*' family of functions instead."); } #endif /* SCM_DEBUG_DEPRECATED == 0 */ @@ -2450,7 +2520,7 @@ scm_protect_object (SCM obj) SCM_REDEFER_INTS; handle = scm_hashq_create_handle_x (scm_protects, obj, SCM_MAKINUM (0)); - SCM_SETCDR (handle, SCM_MAKINUM (SCM_INUM (SCM_CDR (handle)) + 1)); + SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), SCM_MAKINUM (1))); SCM_REALLOW_INTS; @@ -2479,11 +2549,11 @@ scm_unprotect_object (SCM obj) } else { - unsigned long int count = SCM_INUM (SCM_CDR (handle)) - 1; - if (count == 0) + SCM count = scm_difference (SCM_CDR (handle), SCM_MAKINUM (1)); + if (SCM_EQ_P (count, SCM_MAKINUM (0))) scm_hashq_remove_x (scm_protects, obj); else - SCM_SETCDR (handle, SCM_MAKINUM (count)); + SCM_SETCDR (handle, count); } SCM_REALLOW_INTS; @@ -2514,9 +2584,9 @@ cleanup (int status, void *arg) static int -make_initial_segment (scm_sizet init_heap_size, scm_freelist_t *freelist) +make_initial_segment (size_t init_heap_size, scm_freelist_t *freelist) { - scm_sizet rounded_size = round_to_cluster_size (freelist, init_heap_size); + size_t rounded_size = round_to_cluster_size (freelist, init_heap_size); if (!init_heap_seg ((SCM_CELLPTR) malloc (rounded_size), rounded_size, @@ -2543,7 +2613,7 @@ make_initial_segment (scm_sizet init_heap_size, scm_freelist_t *freelist) static void init_freelist (scm_freelist_t *freelist, int span, - int cluster_size, + scm_bits_t cluster_size, int min_yield) { freelist->clusters = SCM_EOL; @@ -2577,11 +2647,11 @@ scm_i_getenv_int (const char *var, int def) int scm_init_storage () { - scm_sizet gc_trigger_1; - scm_sizet gc_trigger_2; - scm_sizet init_heap_size_1; - scm_sizet init_heap_size_2; - scm_sizet j; + unsigned long gc_trigger_1; + unsigned long gc_trigger_2; + size_t init_heap_size_1; + size_t init_heap_size_2; + size_t j; #if (SCM_DEBUG_CELL_ACCESSES == 1) scm_tc16_allocated = scm_make_smob_type ("allocated cell", 0); @@ -2626,8 +2696,8 @@ scm_init_storage () scm_c_hook_init (&scm_after_gc_c_hook, 0, SCM_C_HOOK_NORMAL); /* Initialise the list of ports. */ - scm_port_table = (scm_port **) - malloc (sizeof (scm_port *) * scm_port_table_room); + scm_port_table = (scm_port_t **) + malloc (sizeof (scm_port_t *) * scm_port_table_room); if (!scm_port_table) return 1; diff --git a/libguile/gc.h b/libguile/gc.h index 331c15386..464d4df08 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -97,7 +97,7 @@ typedef scm_cell * SCM_CELLPTR; #define SCM_GC_SET_CARD_BVEC(card, bvec) \ ((card)->word_0 = (scm_bits_t) (bvec)) -#define SCM_GC_GET_CARD_FLAGS(card) ((long) ((card)->word_1)) +#define SCM_GC_GET_CARD_FLAGS(card) ((scm_ubits_t) ((card)->word_1)) #define SCM_GC_SET_CARD_FLAGS(card, flags) \ ((card)->word_1 = (scm_bits_t) (flags)) #define SCM_GC_CLR_CARD_FLAGS(card) (SCM_GC_SET_CARD_FLAGS (card, 0L)) @@ -119,9 +119,9 @@ typedef scm_cell * SCM_CELLPTR; #define SCM_GC_CARD_SIZE_MASK (SCM_GC_CARD_SIZE - 1) #define SCM_GC_CARD_ADDR_MASK (~SCM_GC_CARD_SIZE_MASK) -#define SCM_GC_CELL_CARD(x) ((SCM_CELLPTR) ((long) (x) & SCM_GC_CARD_ADDR_MASK)) +#define SCM_GC_CELL_CARD(x) ((SCM_CELLPTR) ((scm_bits_t) (x) & SCM_GC_CARD_ADDR_MASK)) #define SCM_GC_CELL_SPAN(x) ((SCM_GC_CARD_DOUBLECELLP (SCM_GC_CELL_CARD (x))) ? 2 : 1) -#define SCM_GC_CELL_OFFSET(x) (((long) (x) & SCM_GC_CARD_SIZE_MASK) >> SCM_CELL_SIZE_SHIFT) +#define SCM_GC_CELL_OFFSET(x) (((scm_bits_t) (x) & SCM_GC_CARD_SIZE_MASK) >> SCM_CELL_SIZE_SHIFT) #define SCM_GC_CELL_BVEC(x) SCM_GC_CARD_BVEC (SCM_GC_CELL_CARD (x)) #define SCM_GC_CELL_GET_BIT(x) SCM_C_BVEC_GET (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x)) #define SCM_GC_CELL_SET_BIT(x) SCM_C_BVEC_SET (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x)) @@ -301,31 +301,31 @@ extern unsigned int scm_debug_cell_accesses_p; #endif extern struct scm_heap_seg_data_t *scm_heap_table; -extern int scm_n_heap_segs; +extern size_t scm_n_heap_segs; extern int scm_block_gc; extern int scm_gc_heap_lock; extern unsigned int scm_gc_running_p; -extern int scm_default_init_heap_size_1; +extern size_t scm_default_init_heap_size_1; extern int scm_default_min_yield_1; -extern int scm_default_init_heap_size_2; +extern size_t scm_default_init_heap_size_2; extern int scm_default_min_yield_2; -extern int scm_default_max_segment_size; +extern size_t scm_default_max_segment_size; -extern scm_sizet scm_max_segment_size; +extern size_t scm_max_segment_size; extern SCM_CELLPTR scm_heap_org; extern SCM scm_freelist; extern struct scm_freelist_t scm_master_freelist; extern SCM scm_freelist2; extern struct scm_freelist_t scm_master_freelist2; -extern unsigned long scm_gc_cells_collected; -extern unsigned long scm_gc_yield; -extern unsigned long scm_gc_malloc_collected; -extern unsigned long scm_gc_ports_collected; -extern unsigned long scm_cells_allocated; -extern long scm_mallocated; -extern unsigned long scm_mtrigger; +extern scm_ubits_t scm_gc_cells_collected; +extern scm_ubits_t scm_gc_yield; +extern scm_ubits_t scm_gc_malloc_collected; +extern scm_ubits_t scm_gc_ports_collected; +extern scm_ubits_t scm_cells_allocated; +extern scm_ubits_t scm_mallocated; +extern scm_ubits_t scm_mtrigger; extern SCM scm_after_gc_hook; @@ -363,17 +363,17 @@ extern void scm_alloc_cluster (struct scm_freelist_t *master); extern void scm_igc (const char *what); extern void scm_gc_mark (SCM p); extern void scm_gc_mark_dependencies (SCM p); -extern void scm_mark_locations (SCM_STACKITEM x[], scm_sizet n); +extern void scm_mark_locations (SCM_STACKITEM x[], scm_ubits_t n); extern int scm_cellp (SCM value); extern void scm_gc_sweep (void); -extern void * scm_must_malloc (scm_sizet len, const char *what); +extern void * scm_must_malloc (size_t len, const char *what); extern void * scm_must_realloc (void *where, - scm_sizet olen, scm_sizet len, + size_t olen, size_t len, const char *what); +extern void scm_done_malloc (scm_bits_t size); +extern void scm_done_free (scm_bits_t size); extern char *scm_must_strdup (const char *str); -extern char *scm_must_strndup (const char *str, unsigned long n); -extern void scm_done_malloc (long size); -extern void scm_done_free (long size); +extern char *scm_must_strndup (const char *str, size_t n); extern void scm_must_free (void *obj); extern void scm_remember_upto_here_1 (SCM obj); extern void scm_remember_upto_here_2 (SCM obj1, SCM obj2); diff --git a/libguile/gdbint.c b/libguile/gdbint.c index 3a28549da..4965de4f2 100644 --- a/libguile/gdbint.c +++ b/libguile/gdbint.c @@ -277,7 +277,7 @@ gdb_print (SCM obj) scm_write (obj, gdb_output_port); scm_truncate_file (gdb_output_port, SCM_UNDEFINED); { - scm_port *pt = SCM_PTAB_ENTRY (gdb_output_port); + scm_port_t *pt = SCM_PTAB_ENTRY (gdb_output_port); scm_flush (gdb_output_port); *(pt->write_buf + pt->read_buf_size) = 0; diff --git a/libguile/gh.h b/libguile/gh.h index 834e4b775..ed3f2d386 100644 --- a/libguile/gh.h +++ b/libguile/gh.h @@ -101,22 +101,22 @@ SCM gh_ulong2scm(unsigned long x); SCM gh_long2scm(long x); SCM gh_double2scm(double x); SCM gh_char2scm(char c); -SCM gh_str2scm(const char *s, int len); +SCM gh_str2scm(const char *s, size_t len); SCM gh_str02scm(const char *s); -void gh_set_substr(char *src, SCM dst, int start, int len); +void gh_set_substr(char *src, SCM dst, scm_bits_t start, size_t len); SCM gh_symbol2scm(const char *symbol_str); -SCM gh_ints2scm(const int *d, int n); +SCM gh_ints2scm(const int *d, scm_bits_t n); #ifdef HAVE_ARRAYS -SCM gh_chars2byvect(const char *d, int n); -SCM gh_shorts2svect(const short *d, int n); -SCM gh_longs2ivect(const long *d, int n); -SCM gh_ulongs2uvect(const unsigned long *d, int n); -SCM gh_floats2fvect(const float *d, int n); -SCM gh_doubles2dvect(const double *d, int n); +SCM gh_chars2byvect(const char *d, scm_bits_t n); +SCM gh_shorts2svect(const short *d, scm_bits_t n); +SCM gh_longs2ivect(const long *d, scm_bits_t n); +SCM gh_ulongs2uvect(const unsigned long *d, scm_bits_t n); +SCM gh_floats2fvect(const float *d, scm_bits_t n); +SCM gh_doubles2dvect(const double *d, scm_bits_t n); #endif -SCM gh_doubles2scm(const double *d, int n); +SCM gh_doubles2scm(const double *d, scm_bits_t n); /* Scheme to C conversion */ int gh_scm2bool(SCM obj); @@ -125,9 +125,9 @@ unsigned long gh_scm2ulong(SCM obj); long gh_scm2long(SCM obj); char gh_scm2char(SCM obj); double gh_scm2double(SCM obj); -char *gh_scm2newstr(SCM str, int *lenp); -void gh_get_substr(SCM src, char *dst, int start, int len); -char *gh_symbol2newstr(SCM sym, int *lenp); +char *gh_scm2newstr(SCM str, size_t *lenp); +void gh_get_substr(SCM src, char *dst, scm_bits_t start, size_t len); +char *gh_symbol2newstr(SCM sym, size_t *lenp); char *gh_scm2chars(SCM vector, char *result); short *gh_scm2shorts(SCM vector, short *result); long *gh_scm2longs(SCM vector, long *result); @@ -178,8 +178,8 @@ SCM gh_define(const char *name, SCM val); SCM gh_make_vector(SCM length, SCM val); SCM gh_vector_set_x(SCM vec, SCM pos, SCM val); SCM gh_vector_ref(SCM vec, SCM pos); -unsigned long gh_vector_length (SCM v); -unsigned long gh_uniform_vector_length (SCM v); +scm_bits_t gh_vector_length (SCM v); +scm_ubits_t gh_uniform_vector_length (SCM v); SCM gh_uniform_vector_ref (SCM v, SCM ilist); #define gh_list_to_vector(ls) scm_vector(ls) #define gh_vector_to_list(v) scm_vector_to_list(v) @@ -189,7 +189,7 @@ SCM gh_module_lookup (SCM module, const char *sname); SCM gh_cons(SCM x, SCM y); #define gh_list scm_listify -unsigned long gh_length(SCM l); +scm_bits_t gh_length(SCM l); SCM gh_append(SCM args); SCM gh_append2(SCM l1, SCM l2); SCM gh_append3(SCM l1, SCM l2, SCM l3); diff --git a/libguile/gh_data.c b/libguile/gh_data.c index 368b223f5..5dbf21da9 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -79,7 +79,7 @@ gh_char2scm (char c) return SCM_MAKE_CHAR (c); } SCM -gh_str2scm (const char *s, int len) +gh_str2scm (const char *s, size_t len) { return scm_makfromstr (s, len, 0); } @@ -95,20 +95,20 @@ gh_str02scm (const char *s) If START + LEN is off the end of DST, signal an out-of-range error. */ void -gh_set_substr (char *src, SCM dst, int start, int len) +gh_set_substr (char *src, SCM dst, scm_bits_t start, size_t len) { char *dst_ptr; - unsigned long dst_len; - unsigned long effective_length; + size_t dst_len; + size_t effective_length; SCM_ASSERT (SCM_STRINGP (dst), dst, SCM_ARG3, "gh_set_substr"); dst_ptr = SCM_STRING_CHARS (dst); dst_len = SCM_STRING_LENGTH (dst); - SCM_ASSERT (len >= 0 && (unsigned) len <= dst_len, + SCM_ASSERT (len >= 0 && len <= dst_len, dst, SCM_ARG4, "gh_set_substr"); - effective_length = ((unsigned) len < dst_len) ? len : dst_len; + effective_length = (len < dst_len) ? len : dst_len; memmove (dst_ptr + start, src, effective_length); scm_remember_upto_here_1 (dst); } @@ -121,22 +121,22 @@ gh_symbol2scm (const char *symbol_str) } SCM -gh_ints2scm (const int *d, int n) +gh_ints2scm (const int *d, scm_bits_t n) { - int i; + scm_bits_t i; SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED); SCM *velts = SCM_VELTS(v); for (i = 0; i < n; ++i) - velts[i] = (SCM_FIXABLE (d[i]) ? SCM_MAKINUM (d[i]) : scm_long2big (d[i])); + velts[i] = (SCM_FIXABLE (d[i]) ? SCM_MAKINUM (d[i]) : scm_i_long2big (d[i])); return v; } SCM -gh_doubles2scm (const double *d, int n) +gh_doubles2scm (const double *d, scm_bits_t n) { - int i; + scm_bits_t i; SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED); SCM *velts = SCM_VELTS(v); @@ -150,7 +150,7 @@ gh_doubles2scm (const double *d, int n) you arrange for the elements to be protected from GC while you initialize the vector. */ static SCM -makvect (char* m, int len, int type) +makvect (char *m, size_t len, int type) { SCM ans; SCM_NEWCELL (ans); @@ -162,7 +162,7 @@ makvect (char* m, int len, int type) } SCM -gh_chars2byvect (const char *d, int n) +gh_chars2byvect (const char *d, scm_bits_t n) { char *m = scm_must_malloc (n * sizeof (char), "vector"); memcpy (m, d, n * sizeof (char)); @@ -170,7 +170,7 @@ gh_chars2byvect (const char *d, int n) } SCM -gh_shorts2svect (const short *d, int n) +gh_shorts2svect (const short *d, scm_bits_t n) { char *m = scm_must_malloc (n * sizeof (short), "vector"); memcpy (m, d, n * sizeof (short)); @@ -178,7 +178,7 @@ gh_shorts2svect (const short *d, int n) } SCM -gh_longs2ivect (const long *d, int n) +gh_longs2ivect (const long *d, scm_bits_t n) { char *m = scm_must_malloc (n * sizeof (long), "vector"); memcpy (m, d, n * sizeof (long)); @@ -186,7 +186,7 @@ gh_longs2ivect (const long *d, int n) } SCM -gh_ulongs2uvect (const unsigned long *d, int n) +gh_ulongs2uvect (const unsigned long *d, scm_bits_t n) { char *m = scm_must_malloc (n * sizeof (unsigned long), "vector"); memcpy (m, d, n * sizeof (unsigned long)); @@ -194,7 +194,7 @@ gh_ulongs2uvect (const unsigned long *d, int n) } SCM -gh_floats2fvect (const float *d, int n) +gh_floats2fvect (const float *d, scm_bits_t n) { char *m = scm_must_malloc (n * sizeof (float), "vector"); memcpy (m, d, n * sizeof (float)); @@ -202,7 +202,7 @@ gh_floats2fvect (const float *d, int n) } SCM -gh_doubles2dvect (const double *d, int n) +gh_doubles2dvect (const double *d, scm_bits_t n) { char *m = scm_must_malloc (n * sizeof (double), "vector"); memcpy (m, d, n * sizeof (double)); @@ -229,8 +229,7 @@ gh_scm2long (SCM obj) int gh_scm2int (SCM obj) { - /* NOTE: possible loss of precision here */ - return (int) scm_num2long (obj, SCM_ARG1, "gh_scm2int"); + return (int) scm_num2int (obj, SCM_ARG1, "gh_scm2int"); } double gh_scm2double (SCM obj) @@ -252,8 +251,8 @@ gh_scm2char (SCM obj) char * gh_scm2chars (SCM obj, char *m) { - int i, n; - long v; + scm_bits_t i, n; + scm_bits_t v; SCM val; if (SCM_IMP (obj)) scm_wrong_type_arg (0, 0, obj); @@ -312,8 +311,8 @@ gh_scm2chars (SCM obj, char *m) short * gh_scm2shorts (SCM obj, short *m) { - int i, n; - long v; + scm_bits_t i, n; + scm_bits_t v; SCM val; if (SCM_IMP (obj)) scm_wrong_type_arg (0, 0, obj); @@ -363,7 +362,7 @@ gh_scm2shorts (SCM obj, short *m) long * gh_scm2longs (SCM obj, long *m) { - int i, n; + scm_bits_t i, n; SCM val; if (SCM_IMP (obj)) scm_wrong_type_arg (0, 0, obj); @@ -413,7 +412,7 @@ gh_scm2longs (SCM obj, long *m) float * gh_scm2floats (SCM obj, float *m) { - int i, n; + scm_bits_t i, n; SCM val; if (SCM_IMP (obj)) scm_wrong_type_arg (0, 0, obj); @@ -476,7 +475,7 @@ gh_scm2floats (SCM obj, float *m) double * gh_scm2doubles (SCM obj, double *m) { - int i, n; + scm_bits_t i, n; SCM val; if (SCM_IMP (obj)) scm_wrong_type_arg (0, 0, obj); @@ -549,10 +548,10 @@ gh_scm2doubles (SCM obj, double *m) function always copies the complete contents of STR, and sets *LEN_P to the true length of the string (when LEN_P is non-null). */ char * -gh_scm2newstr (SCM str, int *lenp) +gh_scm2newstr (SCM str, size_t *lenp) { char *ret_str; - int len; + size_t len; SCM_ASSERT (SCM_STRINGP (str), str, SCM_ARG3, "gh_scm2newstr"); @@ -584,9 +583,9 @@ gh_scm2newstr (SCM str, int *lenp) region to fit the string. If truncation occurs, the corresponding area of DST is left unchanged. */ void -gh_get_substr (SCM src, char *dst, int start, int len) +gh_get_substr (SCM src, char *dst, scm_bits_t start, size_t len) { - int src_len, effective_length; + size_t src_len, effective_length; SCM_ASSERT (SCM_STRINGP (src), src, SCM_ARG3, "gh_get_substr"); src_len = SCM_STRING_LENGTH (src); @@ -606,10 +605,10 @@ gh_get_substr (SCM src, char *dst, int start, int len) caller is responsible for freeing it. If out of memory, NULL is returned.*/ char * -gh_symbol2newstr (SCM sym, int *lenp) +gh_symbol2newstr (SCM sym, size_t *lenp) { char *ret_str; - int len; + size_t len; SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG3, "gh_scm2newsymbol"); @@ -656,20 +655,20 @@ gh_vector_ref (SCM vec, SCM pos) } /* returns the length of the given vector */ -unsigned long +scm_bits_t gh_vector_length (SCM v) { - return gh_scm2ulong (scm_vector_length (v)); + return (size_t) SCM_VECTOR_LENGTH (v); } #ifdef HAVE_ARRAYS /* uniform vector support */ /* returns the length as a C unsigned long integer */ -unsigned long +scm_ubits_t gh_uniform_vector_length (SCM v) { - return gh_scm2ulong (scm_uniform_vector_length (v)); + return SCM_UVECTOR_LENGTH (v); } /* gets the given element from a uniform vector; ilist is a list (or diff --git a/libguile/gh_list.c b/libguile/gh_list.c index 7bdd9440d..c52af4223 100644 --- a/libguile/gh_list.c +++ b/libguile/gh_list.c @@ -45,7 +45,7 @@ #include "libguile/gh.h" /* returns the length of a list */ -unsigned long +scm_bits_t gh_length (SCM l) { return gh_scm2ulong (scm_length (l)); @@ -58,22 +58,26 @@ gh_length (SCM l) /* gh_append() takes a args, which is a list of lists, and appends them all together into a single list, which is returned. This is equivalent to the Scheme procedure (append list1 list2 ...) */ -SCM gh_append(SCM args) +SCM +gh_append(SCM args) { return scm_append(args); } -SCM gh_append2(SCM l1, SCM l2) +SCM +gh_append2(SCM l1, SCM l2) { return scm_append(scm_listify(l1, l2, SCM_UNDEFINED)); } -SCM gh_append3(SCM l1, SCM l2, SCM l3) +SCM +gh_append3(SCM l1, SCM l2, SCM l3) { return scm_append(scm_listify(l1, l2, l3, SCM_UNDEFINED)); } -SCM gh_append4(SCM l1, SCM l2, SCM l3, SCM l4) +SCM +gh_append4(SCM l1, SCM l2, SCM l3, SCM l4) { return scm_append(scm_listify(l1, l2, l3, l4, SCM_UNDEFINED)); } diff --git a/libguile/goops.c b/libguile/goops.c index 1b9b6e57d..dc6d3a8f0 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -131,7 +131,7 @@ #define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND) static int goops_loaded_p = 0; -static scm_rstate *goops_rstate; +static scm_rstate_t *goops_rstate; static SCM scm_goops_lookup_closure; @@ -314,7 +314,7 @@ compute_getters_n_setters (SCM slots) { SCM res = SCM_EOL; SCM *cdrloc = &res; - long i = 0; + scm_bits_t i = 0; for ( ; SCM_NNULLP(slots); slots = SCM_CDR(slots)) { @@ -345,9 +345,9 @@ compute_getters_n_setters (SCM slots) /*fixme* Manufacture keywords in advance */ SCM -scm_i_get_keyword (SCM key, SCM l, int len, SCM default_value, const char *subr) +scm_i_get_keyword (SCM key, SCM l, scm_bits_t len, SCM default_value, const char *subr) { - unsigned int i; + scm_bits_t i; for (i = 0; i != len; i += 2) { @@ -375,7 +375,7 @@ SCM_DEFINE (scm_get_keyword, "get-keyword", 3, 0, 0, "@var{default_value} is returned.") #define FUNC_NAME s_scm_get_keyword { - int len; + scm_bits_t len; SCM_ASSERT (SCM_KEYWORDP (key), key, SCM_ARG1, FUNC_NAME); len = scm_ilength (l); @@ -400,7 +400,7 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0, { SCM tmp, get_n_set, slots; SCM class = SCM_CLASS_OF (obj); - int n_initargs; + scm_bits_t n_initargs; SCM_VALIDATE_INSTANCE (1, obj); n_initargs = scm_ilength (initargs); @@ -420,7 +420,7 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0, if (SCM_NIMP (SCM_CDR (slot_name))) { /* This slot admits (perhaps) to be initialized at creation time */ - int n = scm_ilength (SCM_CDR (slot_name)); + scm_bits_t n = scm_ilength (SCM_CDR (slot_name)); if (n & 1) /* odd or -1 */ SCM_MISC_ERROR ("class contains bogus slot definition: ~S", SCM_LIST1 (slot_name)); @@ -479,7 +479,7 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0, "") #define FUNC_NAME s_scm_sys_prep_layout_x { - int i, n, len; + scm_bits_t i, n, len; char *s, p, a; SCM nfields, slots, type; @@ -543,7 +543,7 @@ SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0, #define FUNC_NAME s_scm_sys_inherit_magic_x { SCM ls = dsupers; - long flags = 0; + scm_bits_t flags = 0; SCM_VALIDATE_INSTANCE (1, class); while (SCM_NNULLP (ls)) { @@ -560,7 +560,7 @@ SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0, SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity); else { - int n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); + scm_bits_t n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); #if 0 /* * We could avoid calling scm_must_malloc in the allocation code @@ -998,7 +998,7 @@ SCM_DEFINE (scm_sys_fast_slot_ref, "%fast-slot-ref", 2, 0, 0, "Return the slot value with index @var{index} from @var{obj}.") #define FUNC_NAME s_scm_sys_fast_slot_ref { - register long i; + register scm_bits_t i; SCM_VALIDATE_INSTANCE (1, obj); SCM_VALIDATE_INUM (2, index); @@ -1015,7 +1015,7 @@ SCM_DEFINE (scm_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0, "@var{value}.") #define FUNC_NAME s_scm_sys_fast_slot_set_x { - register long i; + register scm_bits_t i; SCM_VALIDATE_INSTANCE (1, obj); SCM_VALIDATE_INUM (2, index); @@ -1279,10 +1279,10 @@ SCM_DEFINE (scm_slots_exists_p, "slot-exists?", 2, 0, 0, static void clear_method_cache (SCM); static SCM -wrap_init (SCM class, SCM *m, int n) +wrap_init (SCM class, SCM *m, scm_bits_t n) { SCM z; - int i; + scm_bits_t i; /* Set all slots to unbound */ for (i = 0; i < n; i++) @@ -1303,7 +1303,7 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0, #define FUNC_NAME s_scm_sys_allocate_instance { SCM *m; - int n; + scm_bits_t n; SCM_VALIDATE_CLASS (1, class); @@ -1343,7 +1343,7 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0, /* Class objects */ if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS) { - int i; + scm_bits_t i; /* allocate class object */ SCM z = scm_make_struct (class, SCM_INUM0, SCM_EOL); @@ -1463,16 +1463,16 @@ SCM_DEFINE (scm_sys_invalidate_class, "%invalidate-class", 1, 0, 0, */ static SCM **hell; -static int n_hell = 1; /* one place for the evil one himself */ -static int hell_size = 4; +static scm_bits_t n_hell = 1; /* one place for the evil one himself */ +static scm_bits_t hell_size = 4; #ifdef USE_THREADS static scm_mutex_t hell_mutex; #endif -static int +static scm_bits_t burnin (SCM o) { - int i; + scm_bits_t i; for (i = 1; i < n_hell; ++i) if (SCM_INST (o) == hell[i]) return i; @@ -1488,7 +1488,7 @@ go_to_hell (void *o) #endif if (n_hell == hell_size) { - int new_size = 2 * hell_size; + scm_bits_t new_size = 2 * hell_size; hell = scm_must_realloc (hell, hell_size, new_size, "hell"); hell_size = new_size; } @@ -1668,7 +1668,7 @@ static int more_specificp (SCM m1, SCM m2, SCM *targs) { register SCM s1, s2; - register int i; + register scm_bits_t i; /* * Note: * m1 and m2 can have != length (i.e. one can be one element longer than the @@ -1706,9 +1706,9 @@ more_specificp (SCM m1, SCM m2, SCM *targs) #define BUFFSIZE 32 /* big enough for most uses */ static SCM -scm_i_vector2list (SCM l, int len) +scm_i_vector2list (SCM l, scm_bits_t len) { - int j; + size_t j; SCM z = scm_c_make_vector (len, SCM_UNDEFINED); for (j = 0; j < len; j++, l = SCM_CDR (l)) { @@ -1718,9 +1718,9 @@ scm_i_vector2list (SCM l, int len) } static SCM -sort_applicable_methods (SCM method_list, int size, SCM *targs) +sort_applicable_methods (SCM method_list, scm_bits_t size, SCM *targs) { - int i, j, incr; + scm_bits_t i, j, incr; SCM *v, vector = SCM_EOL; SCM buffer[BUFFSIZE]; SCM save = method_list; @@ -1782,10 +1782,10 @@ sort_applicable_methods (SCM method_list, int size, SCM *targs) } SCM -scm_compute_applicable_methods (SCM gf, SCM args, int len, int find_method_p) +scm_compute_applicable_methods (SCM gf, SCM args, scm_bits_t len, int find_method_p) { - register int i; - int count = 0; + register scm_bits_t i; + scm_bits_t count = 0; SCM l, fl, applicable = SCM_EOL; SCM save = args; SCM buffer[BUFFSIZE], *types, *p; @@ -1853,7 +1853,7 @@ SCM scm_sys_compute_applicable_methods (SCM gf, SCM args) #define FUNC_NAME s_sys_compute_applicable_methods { - int n; + scm_bits_t n; SCM_VALIDATE_GENERIC (1, gf); n = scm_ilength (args); SCM_ASSERT (n >= 0, args, SCM_ARG2, FUNC_NAME); @@ -1991,7 +1991,7 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1, #define FUNC_NAME s_scm_make { SCM class, z; - int len = scm_ilength (args); + scm_bits_t len = scm_ilength (args); if (len <= 0 || (len & 1) == 0) SCM_WRONG_NUM_ARGS (); @@ -2084,7 +2084,7 @@ SCM_DEFINE (scm_find_method, "find-method", 0, 0, 1, #define FUNC_NAME s_scm_find_method { SCM gf; - int len = scm_ilength (l); + scm_bits_t len = scm_ilength (l); if (len == 0) SCM_WRONG_NUM_ARGS (); @@ -2104,7 +2104,7 @@ SCM_DEFINE (scm_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0, #define FUNC_NAME s_scm_sys_method_more_specific_p { SCM l, v; - int i, len; + scm_bits_t i, len; SCM_VALIDATE_METHOD (1, m1); SCM_VALIDATE_METHOD (2, m2); @@ -2357,7 +2357,7 @@ scm_make_extended_class (char *type_name) static void create_smob_classes (void) { - int i; + scm_bits_t i; scm_smob_class = (SCM *) malloc (255 * sizeof (SCM)); for (i = 0; i < 255; ++i) @@ -2374,7 +2374,7 @@ create_smob_classes (void) } void -scm_make_port_classes (int ptobnum, char *type_name) +scm_make_port_classes (scm_bits_t ptobnum, char *type_name) { SCM c, class = make_class_from_template ("<%s-port>", type_name, @@ -2401,7 +2401,7 @@ scm_make_port_classes (int ptobnum, char *type_name) static void create_port_classes (void) { - int i; + scm_bits_t i; scm_port_class = (SCM *) malloc (3 * 256 * sizeof (SCM)); for (i = 0; i < 3 * 256; ++i) @@ -2551,7 +2551,7 @@ scm_add_slot (SCM class, char *slot_name, SCM slot_class, } } { - int n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); + scm_bits_t n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); SCM_SLOT (class, scm_si_nfields) = SCM_MAKINUM (n + 1); diff --git a/libguile/goops.h b/libguile/goops.h index 9867096af..60b331cbb 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -229,7 +229,7 @@ SCM scm_sys_set_object_setter_x (SCM obj, SCM setter); SCM scm_slot_ref (SCM obj, SCM slot_name); SCM scm_slot_set_x (SCM obj, SCM slot_name, SCM value); -SCM scm_compute_applicable_methods (SCM gf, SCM args, int len, int scm_find_method); +SCM scm_compute_applicable_methods (SCM gf, SCM args, scm_bits_t len, int scm_find_method); SCM scm_sys_compute_applicable_methods (SCM gf, SCM args); SCM scm_m_atslot_ref (SCM xorig, SCM env); SCM scm_m_atslot_set_x (SCM xorig, SCM env); @@ -239,7 +239,7 @@ SCM scm_pure_generic_p (SCM obj); #endif SCM scm_sys_compute_slots (SCM c); -SCM scm_i_get_keyword (SCM key, SCM l, int len, SCM default_value, const char *subr); +SCM scm_i_get_keyword (SCM key, SCM l, scm_bits_t len, SCM default_value, const char *subr); SCM scm_get_keyword (SCM key, SCM l, SCM default_value); SCM scm_sys_initialize_object (SCM obj, SCM initargs); SCM scm_sys_prep_layout_x (SCM c); diff --git a/libguile/gsubr.c b/libguile/gsubr.c index 6989080bb..090b1e928 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -50,6 +50,7 @@ #include "libguile/root.h" #include "libguile/gsubr.h" +#include "libguile/deprecation.h" /* * gsubr.c @@ -210,19 +211,19 @@ SCM scm_gsubr_apply (SCM args) #define FUNC_NAME "scm_gsubr_apply" { - SCM self = SCM_CAR(args); - SCM (*fcn)() = SCM_SUBRF(SCM_GSUBR_PROC(self)); + SCM self = SCM_CAR (args); + SCM (*fcn)() = SCM_SUBRF (SCM_GSUBR_PROC (self)); SCM v[SCM_GSUBR_MAX]; - int typ = SCM_INUM(SCM_GSUBR_TYPE(self)); - int i, n = SCM_GSUBR_REQ(typ) + SCM_GSUBR_OPT(typ) + SCM_GSUBR_REST(typ); + scm_bits_t typ = SCM_INUM (SCM_GSUBR_TYPE (self)); + scm_bits_t i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ); #if 0 if (n > SCM_GSUBR_MAX) scm_misc_error (FUNC_NAME, "Function ~S has illegal arity ~S.", SCM_LIST2 (self, SCM_MAKINUM (n))); #endif - args = SCM_CDR(args); - for (i = 0; i < SCM_GSUBR_REQ(typ); i++) { + args = SCM_CDR (args); + for (i = 0; i < SCM_GSUBR_REQ (typ); i++) { #ifndef SCM_RECKLESS if (SCM_NULLP (args)) scm_wrong_num_args (SCM_SNAME (SCM_GSUBR_PROC (self))); @@ -230,9 +231,9 @@ scm_gsubr_apply (SCM args) v[i] = SCM_CAR(args); args = SCM_CDR(args); } - for (; i < SCM_GSUBR_REQ(typ) + SCM_GSUBR_OPT(typ); i++) { - if (SCM_NIMP(args)) { - v[i] = SCM_CAR(args); + for (; i < SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ); i++) { + if (SCM_NIMP (args)) { + v[i] = SCM_CAR (args); args = SCM_CDR(args); } else diff --git a/libguile/gsubr.h b/libguile/gsubr.h index 108243374..fbf546203 100644 --- a/libguile/gsubr.h +++ b/libguile/gsubr.h @@ -49,9 +49,9 @@ #define SCM_GSUBR_MAKTYPE(req, opt, rst) ((req)|((opt)<<4)|((rst)<<8)) -#define SCM_GSUBR_REQ(x) ((int)(x)&0xf) -#define SCM_GSUBR_OPT(x) (((int)(x)&0xf0)>>4) -#define SCM_GSUBR_REST(x) ((int)(x)>>8) +#define SCM_GSUBR_REQ(x) ((scm_bits_t)(x)&0xf) +#define SCM_GSUBR_OPT(x) (((scm_bits_t)(x)&0xf0)>>4) +#define SCM_GSUBR_REST(x) ((scm_bits_t)(x)>>8) #define SCM_GSUBR_MAX 10 #define SCM_GSUBR_TYPE(cclo) (SCM_CCLO_REF ((cclo), 1)) diff --git a/libguile/guardians.c b/libguile/guardians.c index f7eac2817..c41f048bd 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -175,7 +175,7 @@ guardian_mark (SCM ptr) } -static scm_sizet +static size_t guardian_free (SCM ptr) { scm_must_free (GUARDIAN (ptr)); diff --git a/libguile/hash.c b/libguile/hash.c index 4bc40d291..5a7244569 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -60,21 +60,21 @@ extern double floor(); #endif -unsigned long -scm_string_hash (const unsigned char *str, scm_sizet len) +scm_bits_t +scm_string_hash (const unsigned char *str, size_t len) { if (len > 5) { - scm_sizet i = 5; - unsigned long h = 264; + size_t i = 5; + scm_bits_t h = 264; while (i--) h = (h << 8) + (unsigned) str[h % len]; return h; } else { - scm_sizet i = len; - unsigned long h = 0; + size_t i = len; + scm_bits_t h = 0; while (i) h = (h << 8) + (unsigned) str[--i]; return h; @@ -86,8 +86,8 @@ scm_string_hash (const unsigned char *str, scm_sizet len) /* Dirk:FIXME:: scm_hasher could be made static. */ -unsigned long -scm_hasher(SCM obj, unsigned long n, scm_sizet d) +scm_bits_t +scm_hasher (SCM obj, scm_bits_t n, size_t d) { switch (SCM_ITAG3 (obj)) { case scm_tc3_int_1: @@ -95,7 +95,7 @@ scm_hasher(SCM obj, unsigned long n, scm_sizet d) return SCM_INUM(obj) % n; /* SCM_INUMP(obj) */ case scm_tc3_imm24: if (SCM_CHARP(obj)) - return (unsigned)(scm_downcase(SCM_CHAR(obj))) % n; + return (scm_ubits_t) (scm_downcase(SCM_CHAR(obj))) % n; switch (SCM_UNPACK (obj)) { #ifndef SICP case SCM_EOL: @@ -122,22 +122,22 @@ scm_hasher(SCM obj, unsigned long n, scm_sizet d) default: return 263 % n; case scm_tc7_smob: - switch SCM_TYP16(obj) { + switch SCM_TYP16 (obj) { case scm_tc16_big: - return SCM_INUM(scm_modulo(obj, SCM_MAKINUM(n))); + return SCM_INUM (scm_modulo (obj, SCM_MAKINUM (n))); default: return 263 % n; case scm_tc16_real: { - double r = SCM_REAL_VALUE(obj); - if (floor(r)==r) { + double r = SCM_REAL_VALUE (obj); + if (floor (r) == r) { obj = scm_inexact_to_exact (obj); - if SCM_IMP(obj) return SCM_INUM(obj) % n; - return SCM_INUM(scm_modulo(obj, SCM_MAKINUM(n))); + if SCM_IMP (obj) return SCM_INUM (obj) % n; + return SCM_INUM (scm_modulo (obj, SCM_MAKINUM (n))); } } case scm_tc16_complex: - obj = scm_number_to_string(obj, SCM_MAKINUM(10)); + obj = scm_number_to_string (obj, SCM_MAKINUM (10)); } case scm_tc7_string: case scm_tc7_substring: @@ -147,26 +147,27 @@ scm_hasher(SCM obj, unsigned long n, scm_sizet d) case scm_tc7_wvect: case scm_tc7_vector: { - scm_sizet len = SCM_VECTOR_LENGTH(obj); + size_t len = SCM_VECTOR_LENGTH(obj); SCM *data = SCM_VELTS(obj); - if (len>5) + if (len > 5) { - scm_sizet i = d/2; - unsigned long h = 1; - while (i--) h = ((h<<8) + (scm_hasher(data[h % len], n, 2))) % n; + size_t i = d/2; + scm_bits_t h = 1; + while (i--) h = ((h << 8) + (scm_hasher (data[h % len], n, 2))) % n; return h; } else { - scm_sizet i = len; - unsigned long h = (n)-1; - while (i--) h = ((h<<8) + (scm_hasher(data[i], n, d/len))) % n; + size_t i = len; + scm_bits_t h = (n)-1; + while (i--) h = ((h << 8) + (scm_hasher (data[i], n, d/len))) % n; return h; } } case scm_tcs_cons_imcar: case scm_tcs_cons_nimcar: - if (d) return (scm_hasher(SCM_CAR(obj), n, d/2)+scm_hasher(SCM_CDR(obj), n, d/2)) % n; + if (d) return (scm_hasher (SCM_CAR (obj), n, d/2) + + scm_hasher (SCM_CDR (obj), n, d/2)) % n; else return 1; case scm_tc7_port: return ((SCM_RDNG & SCM_CELL_WORD_0 (obj)) ? 260 : 261) % n; @@ -181,8 +182,8 @@ scm_hasher(SCM obj, unsigned long n, scm_sizet d) -unsigned int -scm_ihashq (SCM obj, unsigned int n) +scm_bits_t +scm_ihashq (SCM obj, scm_bits_t n) { return (SCM_UNPACK (obj) >> 1) % n; } @@ -211,14 +212,14 @@ SCM_DEFINE (scm_hashq, "hashq", 2, 0, 0, -unsigned int -scm_ihashv (SCM obj, unsigned int n) +scm_bits_t +scm_ihashv (SCM obj, scm_bits_t n) { if (SCM_CHARP(obj)) - return ((unsigned int)(scm_downcase(SCM_CHAR(obj)))) % n; /* downcase!?!! */ + return ((scm_ubits_t)(scm_downcase(SCM_CHAR(obj)))) % n; /* downcase!?!! */ if (SCM_NUMP(obj)) - return (unsigned int) scm_hasher(obj, n, 10); + return (scm_bits_t) scm_hasher(obj, n, 10); else return SCM_UNPACK (obj) % n; } @@ -247,10 +248,10 @@ SCM_DEFINE (scm_hashv, "hashv", 2, 0, 0, -unsigned int -scm_ihash (SCM obj, unsigned int n) +scm_bits_t +scm_ihash (SCM obj, scm_bits_t n) { - return (unsigned int)scm_hasher (obj, n, 10); + return (scm_bits_t) scm_hasher (obj, n, 10); } SCM_DEFINE (scm_hash, "hash", 2, 0, 0, diff --git a/libguile/hash.h b/libguile/hash.h index 0b2ba1037..95bd8581f 100644 --- a/libguile/hash.h +++ b/libguile/hash.h @@ -48,13 +48,13 @@ -extern unsigned long scm_string_hash (const unsigned char *str, scm_sizet len); -extern unsigned long scm_hasher (SCM obj, unsigned long n, scm_sizet d); -extern unsigned int scm_ihashq (SCM obj, unsigned int n); +extern scm_bits_t scm_string_hash (const unsigned char *str, size_t len); +extern scm_bits_t scm_hasher (SCM obj, scm_bits_t n, size_t d); +extern scm_bits_t scm_ihashq (SCM obj, scm_bits_t n); extern SCM scm_hashq (SCM obj, SCM n); -extern unsigned int scm_ihashv (SCM obj, unsigned int n); +extern scm_bits_t scm_ihashv (SCM obj, scm_bits_t n); extern SCM scm_hashv (SCM obj, SCM n); -extern unsigned int scm_ihash (SCM obj, unsigned int n); +extern scm_bits_t scm_ihash (SCM obj, scm_bits_t n); extern SCM scm_hash (SCM obj, SCM n); extern void scm_init_hash (void); diff --git a/libguile/hashtab.c b/libguile/hashtab.c index 50eac4ce8..ef91c7aca 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -55,17 +55,20 @@ SCM -scm_c_make_hash_table (unsigned long k) +scm_c_make_hash_table (scm_bits_t k) { return scm_c_make_vector (k, SCM_EOL); } SCM -scm_hash_fn_get_handle (SCM table,SCM obj,unsigned int (*hash_fn)(),SCM (*assoc_fn)(),void * closure) +scm_hash_fn_get_handle (SCM table, SCM obj, + scm_bits_t (*hash_fn) (), + SCM (*assoc_fn) (), + void *closure) #define FUNC_NAME "scm_hash_fn_get_handle" { - unsigned int k; + scm_bits_t k; SCM h; SCM_VALIDATE_VECTOR (1, table); @@ -81,11 +84,13 @@ scm_hash_fn_get_handle (SCM table,SCM obj,unsigned int (*hash_fn)(),SCM (*assoc_ SCM -scm_hash_fn_create_handle_x (SCM table,SCM obj,SCM init,unsigned int (*hash_fn)(), - SCM (*assoc_fn)(),void * closure) +scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, + scm_bits_t (*hash_fn) (), + SCM (*assoc_fn) (), + void *closure) #define FUNC_NAME "scm_hash_fn_create_handle_x" { - unsigned int k; + scm_bits_t k; SCM it; SCM_ASSERT (SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_create_handle_x"); @@ -116,8 +121,10 @@ scm_hash_fn_create_handle_x (SCM table,SCM obj,SCM init,unsigned int (*hash_fn)( SCM -scm_hash_fn_ref (SCM table,SCM obj,SCM dflt,unsigned int (*hash_fn)(), - SCM (*assoc_fn)(),void * closure) +scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, + scm_bits_t (*hash_fn) (), + SCM (*assoc_fn) (), + void *closure) { SCM it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure); if (SCM_CONSP (it)) @@ -130,8 +137,10 @@ scm_hash_fn_ref (SCM table,SCM obj,SCM dflt,unsigned int (*hash_fn)(), SCM -scm_hash_fn_set_x (SCM table,SCM obj,SCM val,unsigned int (*hash_fn)(), - SCM (*assoc_fn)(),void * closure) +scm_hash_fn_set_x (SCM table, SCM obj, SCM val, + scm_bits_t (*hash_fn) (), + SCM (*assoc_fn) (), + void * closure) { SCM it; @@ -145,10 +154,13 @@ scm_hash_fn_set_x (SCM table,SCM obj,SCM val,unsigned int (*hash_fn)(), SCM -scm_hash_fn_remove_x (SCM table,SCM obj,unsigned int (*hash_fn)(),SCM (*assoc_fn)(), - SCM (*delete_fn)(),void * closure) +scm_hash_fn_remove_x (SCM table, SCM obj, + scm_bits_t (*hash_fn) (), + SCM (*assoc_fn) (), + SCM (*delete_fn) (), + void *closure) { - unsigned int k; + scm_bits_t k; SCM h; SCM_ASSERT (SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_remove_x"); @@ -366,22 +378,22 @@ SCM_DEFINE (scm_hash_remove_x, "hash-remove!", 2, 0, 0, -struct scm_ihashx_closure +typedef struct scm_ihashx_closure_t { SCM hash; SCM assoc; SCM delete; -}; +} scm_ihashx_closure_t; -static unsigned int -scm_ihashx (SCM obj,unsigned int n,struct scm_ihashx_closure * closure) +static scm_bits_t +scm_ihashx (SCM obj, scm_bits_t n, scm_ihashx_closure_t *closure) { SCM answer; SCM_DEFER_INTS; answer = scm_apply (closure->hash, - SCM_LIST2 (obj, scm_ulong2num ((unsigned long)n)), + SCM_LIST2 (obj, scm_bits2num (n)), SCM_EOL); SCM_ALLOW_INTS; return SCM_INUM (answer); @@ -390,7 +402,7 @@ scm_ihashx (SCM obj,unsigned int n,struct scm_ihashx_closure * closure) static SCM -scm_sloppy_assx (SCM obj,SCM alist,struct scm_ihashx_closure * closure) +scm_sloppy_assx (SCM obj, SCM alist, scm_ihashx_closure_t *closure) { SCM answer; SCM_DEFER_INTS; @@ -405,7 +417,7 @@ scm_sloppy_assx (SCM obj,SCM alist,struct scm_ihashx_closure * closure) static SCM -scm_delx_x (SCM obj,SCM alist,struct scm_ihashx_closure * closure) +scm_delx_x (SCM obj, SCM alist, scm_ihashx_closure_t *closure) { SCM answer; SCM_DEFER_INTS; @@ -428,7 +440,7 @@ SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0, "@code{assoc}, @code{assq} or @code{assv}.") #define FUNC_NAME s_scm_hashx_get_handle { - struct scm_ihashx_closure closure; + scm_ihashx_closure_t closure; closure.hash = hash; closure.assoc = assoc; return scm_hash_fn_get_handle (table, key, scm_ihashx, scm_sloppy_assx, @@ -447,7 +459,7 @@ SCM_DEFINE (scm_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0, "@code{assoc}, @code{assq} or @code{assv}.") #define FUNC_NAME s_scm_hashx_create_handle_x { - struct scm_ihashx_closure closure; + scm_ihashx_closure_t closure; closure.hash = hash; closure.assoc = assoc; return scm_hash_fn_create_handle_x (table, key, init, scm_ihashx, @@ -470,7 +482,7 @@ SCM_DEFINE (scm_hashx_ref, "hashx-ref", 4, 1, 0, "equivalent to @code{hashx-ref hashq assq table key}.") #define FUNC_NAME s_scm_hashx_ref { - struct scm_ihashx_closure closure; + scm_ihashx_closure_t closure; if (SCM_UNBNDP (dflt)) dflt = SCM_BOOL_F; closure.hash = hash; @@ -496,7 +508,7 @@ SCM_DEFINE (scm_hashx_set_x, "hashx-set!", 5, 0, 0, "equivalent to @code{hashx-set! hashq assq table key}.") #define FUNC_NAME s_scm_hashx_set_x { - struct scm_ihashx_closure closure; + scm_ihashx_closure_t closure; closure.hash = hash; closure.assoc = assoc; return scm_hash_fn_set_x (table, key, val, scm_ihashx, scm_sloppy_assx, @@ -507,9 +519,9 @@ SCM_DEFINE (scm_hashx_set_x, "hashx-set!", 5, 0, 0, SCM -scm_hashx_remove_x (SCM hash,SCM assoc,SCM delete,SCM table,SCM obj) +scm_hashx_remove_x (SCM hash, SCM assoc, SCM delete, SCM table, SCM obj) { - struct scm_ihashx_closure closure; + scm_ihashx_closure_t closure; closure.hash = hash; closure.assoc = assoc; closure.delete = delete; @@ -543,7 +555,7 @@ SCM_DEFINE (scm_hash_fold, "hash-fold", 3, 0, 0, SCM scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table) { - int i, n = SCM_VECTOR_LENGTH (table); + scm_bits_t i, n = SCM_VECTOR_LENGTH (table); SCM result = init; for (i = 0; i < n; ++i) { diff --git a/libguile/hashtab.h b/libguile/hashtab.h index ff79cc701..1bd2a1483 100644 --- a/libguile/hashtab.h +++ b/libguile/hashtab.h @@ -53,13 +53,13 @@ typedef SCM scm_assoc_fn_t (SCM key, SCM alist, void *closure); typedef SCM scm_delete_fn_t (SCM elt, SCM list); #endif -extern SCM scm_c_make_hash_table (unsigned long k); +extern SCM scm_c_make_hash_table (scm_bits_t k); -extern SCM scm_hash_fn_get_handle (SCM table, SCM obj, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), void * closure); -extern SCM scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), void * closure); -extern SCM scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), void * closure); -extern SCM scm_hash_fn_set_x (SCM table, SCM obj, SCM val, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), void * closure); -extern SCM scm_hash_fn_remove_x (SCM table, SCM obj, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), SCM (*delete_fn) (), void * closure); +extern SCM scm_hash_fn_get_handle (SCM table, SCM obj, scm_bits_t (*hash_fn) (), SCM (*assoc_fn) (), void * closure); +extern SCM scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, scm_bits_t (*hash_fn) (), SCM (*assoc_fn) (), void * closure); +extern SCM scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, scm_bits_t (*hash_fn) (), SCM (*assoc_fn) (), void * closure); +extern SCM scm_hash_fn_set_x (SCM table, SCM obj, SCM val, scm_bits_t (*hash_fn) (), SCM (*assoc_fn) (), void * closure); +extern SCM scm_hash_fn_remove_x (SCM table, SCM obj, scm_bits_t (*hash_fn) (), SCM (*assoc_fn) (), SCM (*delete_fn) (), void * closure); extern SCM scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table); extern SCM scm_hashq_get_handle (SCM table, SCM obj); diff --git a/libguile/hooks.c b/libguile/hooks.c index 9834474aa..9d7cf5b00 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -195,7 +195,7 @@ hook_print (SCM hook, SCM port, scm_print_state *pstate) SCM -scm_create_hook (const char* name, int n_args) +scm_create_hook (const char *name, int n_args) { SCM hook = make_hook (SCM_MAKINUM (n_args), "scm_create_hook"); scm_c_define (name, hook); diff --git a/libguile/init.c b/libguile/init.c index 2001e7910..0cb54f3ad 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -142,6 +142,7 @@ #include "libguile/vports.h" #include "libguile/weaks.h" #include "libguile/guardians.h" +#include "libguile/extensions.h" #include "libguile/init.h" @@ -188,7 +189,7 @@ start_stack (void *base) /* Create an object to hold the root continuation. */ { - scm_contregs *contregs = scm_must_malloc (sizeof (scm_contregs), + scm_contregs_t *contregs = scm_must_malloc (sizeof (scm_contregs_t), "continuation"); contregs->num_stack_items = 0; contregs->seq = 0; @@ -228,7 +229,7 @@ fixconfig (char *s1,char *s2,int s) static void check_config (void) { - scm_sizet j; + size_t j; j = HEAP_SEG_SIZE; if (HEAP_SEG_SIZE != j) diff --git a/libguile/ioext.c b/libguile/ioext.c index 2c1ed4a46..c142d2981 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -90,7 +90,7 @@ SCM_DEFINE (scm_redirect_port, "redirect-port", 2, 0, 0, #define FUNC_NAME s_scm_redirect_port { int ans, oldfd, newfd; - struct scm_fport *fp; + scm_fport_t *fp; old = SCM_COERCE_OUTPORT (old); new = SCM_COERCE_OUTPORT (new); @@ -102,9 +102,9 @@ SCM_DEFINE (scm_redirect_port, "redirect-port", 2, 0, 0, newfd = fp->fdes; if (oldfd != newfd) { - scm_port *pt = SCM_PTAB_ENTRY (new); - scm_port *old_pt = SCM_PTAB_ENTRY (old); - scm_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (new)]; + scm_port_t *pt = SCM_PTAB_ENTRY (new); + scm_port_t *old_pt = SCM_PTAB_ENTRY (old); + scm_ptob_descriptor_t *ptob = &scm_ptobs[SCM_PTOBNUM (new)]; /* must flush to old fdes. */ if (pt->rw_active == SCM_PORT_WRITE) @@ -203,7 +203,11 @@ SCM_DEFINE (scm_fileno, "fileno", 1, 0, 0, /* GJB:FIXME:: why does this not throw an error if the arg is not a port? This proc as is would be better names isattyport? - if it is not going to assume that the arg is a port */ + if it is not going to assume that the arg is a port + + [cmm] I don't see any problem with the above. why should a type + predicate assume _anything_ about its argument? +*/ SCM_DEFINE (scm_isatty_p, "isatty?", 1, 0, 0, (SCM port), "Return @code{#t} if @var{port} is using a serial non--file\n" @@ -257,7 +261,7 @@ SCM_DEFINE (scm_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0, "required value or @code{#t} if it was moved.") #define FUNC_NAME s_scm_primitive_move_to_fdes { - struct scm_fport *stream; + scm_fport_t *stream; int old_fd; int new_fd; int rv; @@ -293,14 +297,14 @@ SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0, { SCM result = SCM_EOL; int int_fd; - int i; + scm_bits_t i; SCM_VALIDATE_INUM_COPY (1,fd,int_fd); for (i = 0; i < scm_port_table_size; i++) { if (SCM_OPFPORTP (scm_port_table[i]->port) - && ((struct scm_fport *) scm_port_table[i]->stream)->fdes == int_fd) + && ((scm_fport_t *) scm_port_table[i]->stream)->fdes == int_fd) result = scm_cons (scm_port_table[i]->port, result); } return result; diff --git a/libguile/list.c b/libguile/list.c index 956a4aa85..6bc0371be 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -148,10 +148,10 @@ SCM_DEFINE (scm_list_p, "list?", 1, 0, 0, This uses the "tortoise and hare" algorithm to detect "infinitely long" lists (i.e. lists with cycles in their cdrs), and returns -1 if it does find one. */ -long -scm_ilength(SCM sx) +scm_bits_t +scm_ilength (SCM sx) { - long i = 0; + scm_bits_t i = 0; SCM tortoise = sx; SCM hare = sx; @@ -180,7 +180,7 @@ SCM_DEFINE (scm_length, "length", 1, 0, 0, "Return the number of elements in list @var{lst}.") #define FUNC_NAME s_scm_length { - int i; + scm_bits_t i; SCM_VALIDATE_LIST_COPYLEN (1,lst,i); return SCM_MAKINUM (i); } @@ -360,7 +360,7 @@ SCM_DEFINE (scm_list_ref, "list-ref", 2, 0, 0, #define FUNC_NAME s_scm_list_ref { SCM lst = list; - unsigned long int i; + register scm_bits_t i; SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i); while (SCM_CONSP (lst)) { if (i == 0) @@ -384,7 +384,7 @@ SCM_DEFINE (scm_list_set_x, "list-set!", 3, 0, 0, #define FUNC_NAME s_scm_list_set_x { SCM lst = list; - unsigned long int i; + register scm_bits_t i; SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i); while (SCM_CONSP (lst)) { if (i == 0) { @@ -415,7 +415,7 @@ SCM_DEFINE (scm_list_tail, "list-tail", 2, 0, 0, "or returning the results of cdring @var{k} times down @var{lst}.") #define FUNC_NAME s_scm_list_tail { - register long i; + register scm_bits_t i; SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i); while (i-- > 0) { SCM_VALIDATE_CONS (1,lst); @@ -432,7 +432,7 @@ SCM_DEFINE (scm_list_cdr_set_x, "list-cdr-set!", 3, 0, 0, #define FUNC_NAME s_scm_list_cdr_set_x { SCM lst = list; - unsigned long int i; + scm_bits_t i; SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i); while (SCM_CONSP (lst)) { if (i == 0) { @@ -462,7 +462,7 @@ SCM_DEFINE (scm_list_head, "list-head", 2, 0, 0, { SCM answer; SCM * pos; - register long i; + register scm_bits_t i; SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i); answer = SCM_EOL; diff --git a/libguile/list.h b/libguile/list.h index 4493816ee..70a2eca3a 100644 --- a/libguile/list.h +++ b/libguile/list.h @@ -72,7 +72,7 @@ extern SCM scm_list (SCM objs); extern SCM scm_cons_star (SCM arg, SCM objs); extern SCM scm_null_p (SCM x); extern SCM scm_list_p (SCM x); -extern long scm_ilength (SCM sx); +extern scm_bits_t scm_ilength (SCM sx); extern SCM scm_length (SCM x); extern SCM scm_append (SCM args); extern SCM scm_append_x (SCM args); diff --git a/libguile/load.c b/libguile/load.c index acc75e46f..b17224600 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -124,7 +124,7 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0, { /* scope */ SCM port, save_port; port = scm_open_file (filename, - scm_makfromstr ("r", (scm_sizet) sizeof (char), 0)); + scm_makfromstr ("r", (size_t) sizeof (char), 0)); save_port = port; scm_internal_dynamic_wind (swap_port, load, @@ -349,7 +349,7 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, { /* scope */ SCM result = SCM_BOOL_F; - int buf_size = max_path_len + 1 + filename_len + max_ext_len + 1; + size_t buf_size = max_path_len + 1 + filename_len + max_ext_len + 1; char *buf = SCM_MUST_MALLOC (buf_size); /* This simplifies the loop below a bit. */ @@ -360,7 +360,7 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, proper list of strings. */ for (; !SCM_NULLP (path); path = SCM_CDR (path)) { - int len; + size_t len; SCM dir = SCM_CAR (path); SCM exts; @@ -377,7 +377,7 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, for (exts = extensions; !SCM_NULLP (exts); exts = SCM_CDR (exts)) { SCM ext = SCM_CAR (exts); - int ext_len = SCM_STRING_LENGTH (ext); + size_t ext_len = SCM_STRING_LENGTH (ext); struct stat mode; /* Concatenate the extension. */ @@ -397,7 +397,7 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, end: scm_must_free (buf); - scm_done_malloc (- buf_size); + scm_done_free (buf_size); SCM_ALLOW_INTS; return result; } @@ -495,7 +495,7 @@ init_build_info () { static struct { char *name; char *value; } info[] = SCM_BUILD_INFO; SCM *loc = SCM_VARIABLE_LOC (scm_c_define ("%guile-build-info", SCM_EOL)); - unsigned int i; + scm_bits_t i; for (i = 0; i < (sizeof (info) / sizeof (info[0])); i++) *loc = scm_acons (scm_str2symbol (info[i].name), diff --git a/libguile/mallocs.c b/libguile/mallocs.c index 1874f3bde..3ce7d2f90 100644 --- a/libguile/mallocs.c +++ b/libguile/mallocs.c @@ -40,7 +40,7 @@ scm_bits_t scm_tc16_malloc; -static scm_sizet +static size_t malloc_free (SCM ptr) { if (SCM_MALLOCDATA (ptr)) @@ -60,7 +60,7 @@ malloc_print (SCM exp, SCM port, scm_print_state *pstate) SCM -scm_malloc_obj (scm_sizet n) +scm_malloc_obj (size_t n) { scm_bits_t mem = n ? (scm_bits_t) malloc (n) : 0; if (n && !mem) diff --git a/libguile/mallocs.h b/libguile/mallocs.h index e6a393891..f60622d8f 100644 --- a/libguile/mallocs.h +++ b/libguile/mallocs.h @@ -54,7 +54,7 @@ extern scm_bits_t scm_tc16_malloc; -extern SCM scm_malloc_obj (scm_sizet n); +extern SCM scm_malloc_obj (size_t n); extern void scm_init_mallocs (void); #endif /* MALLOCSH */ diff --git a/libguile/modules.c b/libguile/modules.c index fb466d511..fb2d456e9 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -526,7 +526,7 @@ scm_module_reverse_lookup (SCM module, SCM variable) #define FUNC_NAME "module-reverse-lookup" { SCM obarray; - int i, n; + scm_bits_t i, n; if (module == SCM_BOOL_F) obarray = scm_pre_modules_obarray; diff --git a/libguile/net_db.c b/libguile/net_db.c index a2660e2d8..4f5e64ed8 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -185,7 +185,7 @@ SCM_DEFINE (scm_gethost, "gethost", 0, 1, 0, scm_resolv_error (FUNC_NAME, host); ve[0] = scm_makfromstr (entry->h_name, - (scm_sizet) strlen (entry->h_name), 0); + (size_t) strlen (entry->h_name), 0); ve[1] = scm_makfromstrs (-1, entry->h_aliases); ve[2] = SCM_MAKINUM (entry->h_addrtype + 0L); ve[3] = SCM_MAKINUM (entry->h_length + 0L); @@ -257,7 +257,7 @@ SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0, } if (!entry) SCM_SYSERROR_MSG ("no such network ~A", SCM_LIST1 (net), errno); - ve[0] = scm_makfromstr (entry->n_name, (scm_sizet) strlen (entry->n_name), 0); + ve[0] = scm_makfromstr (entry->n_name, (size_t) strlen (entry->n_name), 0); ve[1] = scm_makfromstrs (-1, entry->n_aliases); ve[2] = SCM_MAKINUM (entry->n_addrtype + 0L); ve[3] = scm_ulong2num (entry->n_net + 0L); @@ -307,7 +307,7 @@ SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0, } if (!entry) SCM_SYSERROR_MSG ("no such protocol ~A", SCM_LIST1 (protocol), errno); - ve[0] = scm_makfromstr (entry->p_name, (scm_sizet) strlen (entry->p_name), 0); + ve[0] = scm_makfromstr (entry->p_name, (size_t) strlen (entry->p_name), 0); ve[1] = scm_makfromstrs (-1, entry->p_aliases); ve[2] = SCM_MAKINUM (entry->p_proto + 0L); return ans; @@ -323,10 +323,10 @@ scm_return_entry (struct servent *entry) ans = scm_c_make_vector (4, SCM_UNSPECIFIED); ve = SCM_VELTS (ans); - ve[0] = scm_makfromstr (entry->s_name, (scm_sizet) strlen (entry->s_name), 0); + ve[0] = scm_makfromstr (entry->s_name, (size_t) strlen (entry->s_name), 0); ve[1] = scm_makfromstrs (-1, entry->s_aliases); ve[2] = SCM_MAKINUM (ntohs (entry->s_port) + 0L); - ve[3] = scm_makfromstr (entry->s_proto, (scm_sizet) strlen (entry->s_proto), 0); + ve[3] = scm_makfromstr (entry->s_proto, (size_t) strlen (entry->s_proto), 0); return ans; } diff --git a/libguile/num2integral.i.c b/libguile/num2integral.i.c new file mode 100644 index 000000000..3e5d65389 --- /dev/null +++ b/libguile/num2integral.i.c @@ -0,0 +1,165 @@ +/* this file is #include'd (many times) by numbers.c */ + +ITYPE +NUM2INTEGRAL (SCM num, unsigned long int pos, const char *s_caller) +{ + if (SCM_INUMP (num)) + { /* immediate */ + + scm_bits_t n = SCM_INUM (num); + +#ifdef UNSIGNED + if (n < 0) + scm_out_of_range (s_caller, num); +#endif + + if (sizeof (ITYPE) >= sizeof (scm_bits_t)) + /* can't fit anything too big for this type in an inum + anyway */ + return (ITYPE) n; + else + { /* an inum can be out of range, so check */ + if (n > (scm_bits_t)MAX_VALUE +#ifndef UNSIGNED + || n < (scm_bits_t)MIN_VALUE +#endif + ) + scm_out_of_range (s_caller, num); + else + return (ITYPE) n; + } + } + else if (SCM_BIGP (num)) + { /* bignum */ + + ITYPE res = 0; + size_t l; + + for (l = SCM_NUMDIGS (num); l--;) + { + ITYPE new = SCM_I_BIGUP (ITYPE, res) + SCM_BDIGITS (num)[l]; + if (new < res +#ifndef UNSIGNED + && !(new == MIN_VALUE && l == 0) +#endif + ) + scm_out_of_range (s_caller, num); + res = new; + } + +#ifndef UNSIGNED + if (SCM_BIGSIGN (num)) + { + res = -res; + if (res <= 0) + return res; + else + scm_out_of_range (s_caller, num); + } + else + { + if (res >= 0) + return res; + else + scm_out_of_range (s_caller, num); + } +#endif + + return res; + } + else if (SCM_REALP (num)) + { /* inexact */ + + double u = SCM_REAL_VALUE (num); + ITYPE res = u; + if ((double) res == u) + return res; + else + scm_out_of_range (s_caller, num); + } + else + scm_wrong_type_arg (s_caller, pos, num); +} + +SCM +INTEGRAL2NUM (ITYPE n) +{ + if (sizeof (ITYPE) < sizeof (scm_bits_t) + || +#ifndef UNSIGNED + SCM_FIXABLE (n) +#else + SCM_POSFIXABLE (n) +#endif + ) + return SCM_MAKINUM (n); + +#ifdef SCM_BIGDIG + return INTEGRAL2BIG (n); +#else + return scm_make_real ((double) n); +#endif +} + +#ifdef SCM_BIGDIG + +SCM +INTEGRAL2BIG (ITYPE n) +{ + SCM res; + int neg_p; + int n_digits; + size_t i; + SCM_BIGDIG *digits; + +#ifndef UNSIGNED + neg_p = (n < 0); + if (neg_p) n = -n; +#else + neg_p = 0; +#endif + +#ifndef UNSIGNED + if (n == MIN_VALUE) + /* special case */ + n_digits = + (sizeof (ITYPE) + sizeof (SCM_BIGDIG) - 1) / sizeof (SCM_BIGDIG); + else +#endif + { + ITYPE tn; + for (tn = n, n_digits = 0; + tn; + ++n_digits, tn = SCM_BIGDN (tn)) + ; + } + + i = 0; + res = scm_i_mkbig (n_digits, neg_p); + digits = SCM_BDIGITS (res); + + while (i < n_digits) + { + digits[i++] = SCM_BIGLO (n); + n = SCM_BIGDN (n); + } + + return res; +} + +#endif + +/* clean up */ +#undef INTEGRAL2NUM +#undef INTEGRAL2BIG +#undef NUM2INTEGRAL +#undef UNSIGNED +#undef ITYPE +#undef MIN_VALUE +#undef MAX_VALUE + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/numbers.c b/libguile/numbers.c index 26da3e4ad..261248b62 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -54,10 +54,11 @@ #include "libguile/validate.h" #include "libguile/numbers.h" +#include "libguile/deprecation.h" -static SCM scm_divbigbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn, int modes); +static SCM scm_divbigbig (SCM_BIGDIG *x, size_t nx, SCM_BIGDIG *y, size_t ny, int sgn, int modes); static SCM scm_divbigint (SCM x, long z, int sgn, int mode); @@ -161,7 +162,7 @@ scm_abs (SCM x) return SCM_MAKINUM (-xx); } else { #ifdef SCM_BIGDIG - return scm_long2big (-xx); + return scm_i_long2big (-xx); #else scm_num_overflow (s_abs); #endif @@ -170,7 +171,7 @@ scm_abs (SCM x) if (!SCM_BIGSIGN (x)) { return x; } else { - return scm_copybig (x, 0); + return scm_i_copybig (x, 0); } } else if (SCM_REALP (x)) { return scm_make_real (fabs (SCM_REAL_VALUE (x))); @@ -198,7 +199,7 @@ scm_quotient (SCM x, SCM y) return SCM_MAKINUM (z); } else { #ifdef SCM_BIGDIG - return scm_long2big (z); + return scm_i_long2big (z); #else scm_num_overflow (s_quotient); #endif @@ -227,9 +228,9 @@ scm_quotient (SCM x, SCM y) long z = yy < 0 ? -yy : yy; if (z < SCM_BIGRAD) { - SCM sw = scm_copybig (x, SCM_BIGSIGN (x) ? (yy > 0) : (yy < 0)); + SCM sw = scm_i_copybig (x, SCM_BIGSIGN (x) ? (yy > 0) : (yy < 0)); scm_divbigdig (SCM_BDIGITS (sw), SCM_NUMDIGS (sw), (SCM_BIGDIG) z); - return scm_normbig (sw); + return scm_i_normbig (sw); } else { #ifndef SCM_DIGSTOOBIG long w = scm_pseudolong (z); @@ -421,7 +422,7 @@ scm_gcd (SCM x, SCM y) return SCM_MAKINUM (result); } else { #ifdef SCM_BIGDIG - return scm_long2big (result); + return scm_i_long2big (result); #else scm_num_overflow (s_gcd); #endif @@ -435,7 +436,7 @@ scm_gcd (SCM x, SCM y) } else if (SCM_BIGP (x)) { big_gcd: if (SCM_BIGSIGN (x)) - x = scm_copybig (x, 0); + x = scm_i_copybig (x, 0); newy: if (SCM_INUMP (y)) { if (SCM_EQ_P (y, SCM_INUM0)) { @@ -445,7 +446,7 @@ scm_gcd (SCM x, SCM y) } } else if (SCM_BIGP (y)) { if (SCM_BIGSIGN (y)) - y = scm_copybig (y, 0); + y = scm_i_copybig (y, 0); switch (scm_bigcomp (x, y)) { case -1: /* x > y */ @@ -555,18 +556,18 @@ scm_lcm (SCM n1, SCM n2) #ifdef SCM_BIGDIG SCM scm_copy_big_dec(SCM b, int sign); -SCM scm_copy_smaller(SCM_BIGDIG *x, scm_sizet nx, int zsgn); -SCM scm_big_ior(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy); -SCM scm_big_xor(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy); -SCM scm_big_and(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy, int zsgn); -SCM scm_big_test(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy); +SCM scm_copy_smaller(SCM_BIGDIG *x, size_t nx, int zsgn); +SCM scm_big_ior(SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy); +SCM scm_big_xor(SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy); +SCM scm_big_and(SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy, int zsgn); +SCM scm_big_test(SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy); SCM scm_copy_big_dec(SCM b, int sign) { long num = -1; - scm_sizet nx = SCM_NUMDIGS(b); - scm_sizet i = 0; - SCM ans = scm_mkbig(nx, sign); + size_t nx = SCM_NUMDIGS(b); + size_t i = 0; + SCM ans = scm_i_mkbig(nx, sign); SCM_BIGDIG *src = SCM_BDIGITS(b), *dst = SCM_BDIGITS(ans); if SCM_BIGSIGN(b) do { num += src[i]; @@ -578,11 +579,11 @@ SCM scm_copy_big_dec(SCM b, int sign) return ans; } -SCM scm_copy_smaller(SCM_BIGDIG *x, scm_sizet nx, int zsgn) +SCM scm_copy_smaller(SCM_BIGDIG *x, size_t nx, int zsgn) { long num = -1; - scm_sizet i = 0; - SCM z = scm_mkbig(nx, zsgn); + size_t i = 0; + SCM z = scm_i_mkbig(nx, zsgn); SCM_BIGDIG *zds = SCM_BDIGITS(z); if (zsgn) do { num += x[i]; @@ -593,12 +594,12 @@ SCM scm_copy_smaller(SCM_BIGDIG *x, scm_sizet nx, int zsgn) return z; } -SCM scm_big_ior(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy) +SCM scm_big_ior(SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy) /* Assumes nx <= SCM_NUMDIGS(bigy) */ /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */ { long num = -1; - scm_sizet i = 0, ny = SCM_NUMDIGS(bigy); + size_t i = 0, ny = SCM_NUMDIGS(bigy); SCM z = scm_copy_big_dec (bigy, xsgn & SCM_BIGSIGN (bigy)); SCM_BIGDIG *zds = SCM_BDIGITS(z); if (xsgn) { @@ -615,7 +616,7 @@ SCM scm_big_ior(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy) num = SCM_BIGDN(num); if (!num) return z; } - scm_adjbig(z, 1 + ny); /* OOPS, overflowed into next digit. */ + scm_i_adjbig(z, 1 + ny); /* OOPS, overflowed into next digit. */ SCM_BDIGITS(z)[ny] = 1; return z; } @@ -623,12 +624,12 @@ SCM scm_big_ior(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy) return z; } -SCM scm_big_xor(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy) +SCM scm_big_xor(SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy) /* Assumes nx <= SCM_NUMDIGS(bigy) */ /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */ { long num = -1; - scm_sizet i = 0, ny = SCM_NUMDIGS(bigy); + size_t i = 0, ny = SCM_NUMDIGS(bigy); SCM z = scm_copy_big_dec(bigy, xsgn ^ SCM_BIGSIGN(bigy)); SCM_BIGDIG *zds = SCM_BDIGITS(z); if (xsgn) do { @@ -647,19 +648,19 @@ SCM scm_big_xor(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy) num += zds[i]; zds[i++] = SCM_BIGLO(num); num = SCM_BIGDN(num); - if (!num) return scm_normbig(z); + if (!num) return scm_i_normbig(z); } } - return scm_normbig(z); + return scm_i_normbig(z); } -SCM scm_big_and(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy, int zsgn) +SCM scm_big_and(SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy, int zsgn) /* Assumes nx <= SCM_NUMDIGS(bigy) */ /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */ /* return sign equals either 0 or SCM_BIGSIGNFLAG */ { long num = -1; - scm_sizet i = 0; + size_t i = 0; SCM z; SCM_BIGDIG *zds; if (xsgn==zsgn) { @@ -683,7 +684,7 @@ SCM scm_big_and(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy, int zsgn) num += zds[i]; zds[i++] = SCM_BIGLO(num); num = SCM_BIGDN(num); - if (!num) return scm_normbig(z); + if (!num) return scm_i_normbig(z); } } else if (xsgn) { @@ -694,15 +695,15 @@ SCM scm_big_and(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy, int zsgn) carry = (mask >= SCM_BIGRAD) ? 1 : 0; } while (++i < nx); } else do zds[i] = zds[i] & x[i]; while (++i < nx); - return scm_normbig(z); + return scm_i_normbig(z); } -SCM scm_big_test(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy) +SCM scm_big_test(SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy) /* Assumes nx <= SCM_NUMDIGS(bigy) */ /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */ { SCM_BIGDIG *y; - scm_sizet i = 0; + size_t i = 0; long num = -1; if (SCM_BIGSIGN(bigy) & xsgn) return SCM_BOOL_T; if (SCM_NUMDIGS(bigy) != nx && xsgn) return SCM_BOOL_T; @@ -1062,9 +1063,9 @@ SCM_DEFINE (scm_logbit_p, "logbit?", 2, 0, 0, return SCM_BOOL_F; } else if (SCM_BIGSIGN (j)) { long num = -1; - scm_sizet i = 0; + size_t i = 0; SCM_BIGDIG * x = SCM_BDIGITS (j); - scm_sizet nx = iindex / SCM_BITSPERDIG; + size_t nx = iindex / SCM_BITSPERDIG; while (1) { num += x[i]; if (nx == i++) { @@ -1225,7 +1226,7 @@ SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0, long int in = SCM_INUM (n); unsigned long int bits = iend - istart; - if (in < 0 && bits >= SCM_FIXNUM_BIT) + if (in < 0 && bits >= SCM_I_FIXNUM_BIT) { /* Since we emulate two's complement encoded numbers, this special * case requires us to produce a result that has more bits than can be @@ -1235,10 +1236,10 @@ SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0, goto generalcase; } - if (istart < SCM_FIXNUM_BIT) + if (istart < SCM_I_FIXNUM_BIT) { in = in >> istart; - if (bits < SCM_FIXNUM_BIT) + if (bits < SCM_I_FIXNUM_BIT) return SCM_MAKINUM (in & ((1L << bits) - 1)); else /* we know: in >= 0 */ return SCM_MAKINUM (in); @@ -1304,7 +1305,7 @@ SCM_DEFINE (scm_logcount, "logcount", 1, 0, 0, return scm_logcount (scm_difference (SCM_MAKINUM (-1L), n)); } else { unsigned long int c = 0; - scm_sizet i = SCM_NUMDIGS (n); + size_t i = SCM_NUMDIGS (n); SCM_BIGDIG * ds = SCM_BDIGITS (n); while (i--) { SCM_BIGDIG d; @@ -1379,7 +1380,7 @@ SCM_DEFINE (scm_integer_length, "integer-length", 1, 0, 0, static const char s_bignum[] = "bignum"; SCM -scm_mkbig (scm_sizet nlen, int sign) +scm_i_mkbig (size_t nlen, int sign) { SCM v; /* Cast to long int to avoid signed/unsigned comparison warnings. */ @@ -1395,9 +1396,8 @@ scm_mkbig (scm_sizet nlen, int sign) return v; } - SCM -scm_big2inum (SCM b, scm_sizet l) +scm_i_big2inum (SCM b, size_t l) { unsigned long num = 0; SCM_BIGDIG *tmp = SCM_BDIGITS (b); @@ -1413,13 +1413,12 @@ scm_big2inum (SCM b, scm_sizet l) return b; } - -static const char s_adjbig[] = "scm_adjbig"; +static const char s_adjbig[] = "scm_i_adjbig"; SCM -scm_adjbig (SCM b, scm_sizet nlen) +scm_i_adjbig (SCM b, size_t nlen) { - scm_sizet nsiz = nlen; + size_t nsiz = nlen; if (((nsiz << SCM_BIGSIZEFIELD) >> SCM_BIGSIZEFIELD) != nlen) scm_memory_error (s_adjbig); @@ -1438,13 +1437,11 @@ scm_adjbig (SCM b, scm_sizet nlen) return b; } - - SCM -scm_normbig (SCM b) +scm_i_normbig (SCM b) { #ifndef _UNICOS - scm_sizet nlen = SCM_NUMDIGS (b); + size_t nlen = SCM_NUMDIGS (b); #else int nlen = SCM_NUMDIGS (b); /* unsigned nlen breaks on Cray when nlen => 0 */ #endif @@ -1452,137 +1449,30 @@ scm_normbig (SCM b) while (nlen-- && !zds[nlen]); nlen++; if (nlen * SCM_BITSPERDIG / SCM_CHAR_BIT <= sizeof (SCM)) - if (SCM_INUMP (b = scm_big2inum (b, (scm_sizet) nlen))) + if (SCM_INUMP (b = scm_i_big2inum (b, (size_t) nlen))) return b; if (SCM_NUMDIGS (b) == nlen) return b; - return scm_adjbig (b, (scm_sizet) nlen); + return scm_i_adjbig (b, (size_t) nlen); } - - SCM -scm_copybig (SCM b, int sign) +scm_i_copybig (SCM b, int sign) { - scm_sizet i = SCM_NUMDIGS (b); - SCM ans = scm_mkbig (i, sign); + size_t i = SCM_NUMDIGS (b); + SCM ans = scm_i_mkbig (i, sign); SCM_BIGDIG *src = SCM_BDIGITS (b), *dst = SCM_BDIGITS (ans); while (i--) dst[i] = src[i]; return ans; } - - -SCM -scm_long2big (long n) -{ - scm_sizet i = 0; - SCM_BIGDIG *digits; - SCM ans = scm_mkbig (SCM_DIGSPERLONG, n < 0); - digits = SCM_BDIGITS (ans); - if (n < 0) - n = -n; - while (i < SCM_DIGSPERLONG) - { - digits[i++] = SCM_BIGLO (n); - n = SCM_BIGDN ((unsigned long) n); - } - return ans; -} - -#ifdef HAVE_LONG_LONGS - -SCM -scm_long_long2big (long_long n) -{ - scm_sizet i; - SCM_BIGDIG *digits; - SCM ans; - int n_digits; - - { - long tn; - tn = (long) n; - if ((long long) tn == n) - return scm_long2big (tn); - } - - { - long_long tn; - - for (tn = n, n_digits = 0; - tn; - ++n_digits, tn = SCM_BIGDN ((ulong_long) tn)) - ; - } - - i = 0; - ans = scm_mkbig (n_digits, n < 0); - digits = SCM_BDIGITS (ans); - if (n < 0) - n = -n; - while (i < n_digits) - { - digits[i++] = SCM_BIGLO (n); - n = SCM_BIGDN ((ulong_long) n); - } - return ans; -} -#endif /* HAVE_LONG_LONGS */ - - -SCM -scm_2ulong2big (unsigned long *np) -{ - unsigned long n; - scm_sizet i; - SCM_BIGDIG *digits; - SCM ans; - - ans = scm_mkbig (2 * SCM_DIGSPERLONG, 0); - digits = SCM_BDIGITS (ans); - - n = np[0]; - for (i = 0; i < SCM_DIGSPERLONG; ++i) - { - digits[i] = SCM_BIGLO (n); - n = SCM_BIGDN ((unsigned long) n); - } - n = np[1]; - for (i = 0; i < SCM_DIGSPERLONG; ++i) - { - digits[i + SCM_DIGSPERLONG] = SCM_BIGLO (n); - n = SCM_BIGDN ((unsigned long) n); - } - return ans; -} - - - -SCM -scm_ulong2big (unsigned long n) -{ - scm_sizet i = 0; - SCM_BIGDIG *digits; - SCM ans = scm_mkbig (SCM_DIGSPERLONG, 0); - digits = SCM_BDIGITS (ans); - while (i < SCM_DIGSPERLONG) - { - digits[i++] = SCM_BIGLO (n); - n = SCM_BIGDN (n); - } - return ans; -} - - - int scm_bigcomp (SCM x, SCM y) { int xsign = SCM_BIGSIGN (x); int ysign = SCM_BIGSIGN (y); - scm_sizet xlen, ylen; + size_t xlen, ylen; /* Look at the signs, first. */ if (ysign < xsign) @@ -1627,7 +1517,7 @@ scm_pseudolong (long x) SCM_BIGDIG bd[SCM_DIGSPERLONG]; } p; - scm_sizet i = 0; + size_t i = 0; if (x < 0) x = -x; while (i < SCM_DIGSPERLONG) @@ -1645,7 +1535,7 @@ scm_pseudolong (long x) void scm_longdigs (long x, SCM_BIGDIG digs[]) { - scm_sizet i = 0; + size_t i = 0; if (x < 0) x = -x; while (i < SCM_DIGSPERLONG) @@ -1659,13 +1549,13 @@ scm_longdigs (long x, SCM_BIGDIG digs[]) SCM -scm_addbig (SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy, int sgny) +scm_addbig (SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy, int sgny) { /* Assumes nx <= SCM_NUMDIGS(bigy) */ /* Assumes xsgn and sgny scm_equal either 0 or SCM_BIGSIGNFLAG */ long num = 0; - scm_sizet i = 0, ny = SCM_NUMDIGS (bigy); - SCM z = scm_copybig (bigy, SCM_BIGSIGN (bigy) ^ sgny); + size_t i = 0, ny = SCM_NUMDIGS (bigy); + SCM z = scm_i_copybig (bigy, SCM_BIGSIGN (bigy) ^ sgny); SCM_BIGDIG *zds = SCM_BDIGITS (z); if (xsgn ^ SCM_BIGSIGN (z)) { @@ -1734,21 +1624,21 @@ scm_addbig (SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy, int sgny) } if (num) { - z = scm_adjbig (z, ny + 1); + z = scm_i_adjbig (z, ny + 1); SCM_BDIGITS (z)[ny] = num; return z; } } - return scm_normbig (z); + return scm_i_normbig (z); } SCM -scm_mulbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn) +scm_mulbig (SCM_BIGDIG *x, size_t nx, SCM_BIGDIG *y, size_t ny, int sgn) { - scm_sizet i = 0, j = nx + ny; + size_t i = 0, j = nx + ny; unsigned long n = 0; - SCM z = scm_mkbig (j, sgn); + SCM z = scm_i_mkbig (j, sgn); SCM_BIGDIG *zds = SCM_BDIGITS (z); while (j--) zds[j] = 0; @@ -1772,12 +1662,12 @@ scm_mulbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn) } } while (++i < nx); - return scm_normbig (z); + return scm_i_normbig (z); } unsigned int -scm_divbigdig (SCM_BIGDIG * ds, scm_sizet h, SCM_BIGDIG div) +scm_divbigdig (SCM_BIGDIG * ds, size_t h, SCM_BIGDIG div) { register unsigned long t2 = 0; while (h--) @@ -1800,7 +1690,7 @@ scm_divbigint (SCM x, long z, int sgn, int mode) { register unsigned long t2 = 0; register SCM_BIGDIG *ds = SCM_BDIGITS (x); - scm_sizet nd = SCM_NUMDIGS (x); + size_t nd = SCM_NUMDIGS (x); while (nd--) t2 = (SCM_BIGUP (t2) + ds[nd]) % z; if (mode && t2) @@ -1825,14 +1715,14 @@ scm_divbigint (SCM x, long z, int sgn, int mode) static SCM -scm_divbigbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn, int modes) +scm_divbigbig (SCM_BIGDIG *x, size_t nx, SCM_BIGDIG *y, size_t ny, int sgn, int modes) { /* modes description 0 remainder 1 scm_modulo 2 quotient 3 quotient but returns SCM_UNDEFINED if division is not exact. */ - scm_sizet i = 0, j = 0; + size_t i = 0, j = 0; long num = 0; unsigned long t2 = 0; SCM z, newy; @@ -1842,7 +1732,7 @@ scm_divbigbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn switch (modes) { case 0: /* remainder -- just return x */ - z = scm_mkbig (nx, sgn); + z = scm_i_mkbig (nx, sgn); zds = SCM_BDIGITS (z); do { @@ -1851,7 +1741,7 @@ scm_divbigbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn while (++i < nx); return z; case 1: /* scm_modulo -- return y-x */ - z = scm_mkbig (ny, sgn); + z = scm_i_mkbig (ny, sgn); zds = SCM_BDIGITS (z); do { @@ -1889,7 +1779,7 @@ scm_divbigbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn return SCM_UNDEFINED; /* the division is not exact */ } - z = scm_mkbig (nx == ny ? nx + 2 : nx + 1, sgn); + z = scm_i_mkbig (nx == ny ? nx + 2 : nx + 1, sgn); zds = SCM_BDIGITS (z); if (nx == ny) zds[nx + 1] = 0; @@ -1898,7 +1788,7 @@ scm_divbigbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn if (y[ny - 1] < (SCM_BIGRAD >> 1)) { /* normalize operands */ d = SCM_BIGRAD / (y[ny - 1] + 1); - newy = scm_mkbig (ny, 0); + newy = scm_i_mkbig (ny, 0); yds = SCM_BDIGITS (newy); while (j < ny) { @@ -2012,9 +1902,9 @@ scm_divbigbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn doadj: for (j = ny; j && !zds[j - 1]; --j); if (j * SCM_BITSPERDIG <= sizeof (SCM) * SCM_CHAR_BIT) - if (SCM_INUMP (z = scm_big2inum (z, j))) + if (SCM_INUMP (z = scm_i_big2inum (z, j))) return z; - return scm_adjbig (z, j); + return scm_i_adjbig (z, j); } #endif @@ -2033,11 +1923,11 @@ static const double fx[] = -static scm_sizet +static size_t idbl2str (double f, char *a) { int efmt, dpt, d, i, wp = scm_dblprec; - scm_sizet ch = 0; + size_t ch = 0; int exp = 0; if (f == 0.0) @@ -2173,10 +2063,10 @@ idbl2str (double f, char *a) } -static scm_sizet +static size_t iflo2str (SCM flt, char *str) { - scm_sizet i; + size_t i; if (SCM_SLOPPY_REALP (flt)) i = idbl2str (SCM_REAL_VALUE (flt), str); else @@ -2197,11 +2087,11 @@ iflo2str (SCM flt, char *str) characters in the result. rad is output base p is destination: worst case (base 2) is SCM_INTBUFLEN */ -scm_sizet +size_t scm_iint2str (long num, int rad, char *p) { - scm_sizet j = 1; - scm_sizet i; + size_t j = 1; + size_t i; unsigned long n = (num < 0) ? -num : num; for (n /= rad; n > 0; n /= rad) @@ -2232,14 +2122,14 @@ scm_iint2str (long num, int rad, char *p) static SCM big2str (SCM b, unsigned int radix) { - SCM t = scm_copybig (b, 0); /* sign of temp doesn't matter */ + SCM t = scm_i_copybig (b, 0); /* sign of temp doesn't matter */ register SCM_BIGDIG *ds = SCM_BDIGITS (t); - scm_sizet i = SCM_NUMDIGS (t); - scm_sizet j = radix == 16 ? (SCM_BITSPERDIG * i) / 4 + 2 + size_t i = SCM_NUMDIGS (t); + size_t j = radix == 16 ? (SCM_BITSPERDIG * i) / 4 + 2 : radix >= 10 ? (SCM_BITSPERDIG * i * 241L) / 800 + 2 : (SCM_BITSPERDIG * i) + 2; - scm_sizet k = 0; - scm_sizet radct = 0; + size_t k = 0; + size_t radct = 0; SCM_BIGDIG radpow = 1, radmod = 0; SCM ss = scm_allocate_string (j); char *s = SCM_STRING_CHARS (ss), c; @@ -2297,7 +2187,7 @@ SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0, if (SCM_INUMP (n)) { char num_buf [SCM_INTBUFLEN]; - scm_sizet length = scm_iint2str (SCM_INUM (n), base, num_buf); + size_t length = scm_iint2str (SCM_INUM (n), base, num_buf); return scm_makfromstr (num_buf, length, 0); } else if (SCM_BIGP (n)) { return big2str (n, (unsigned int) base); @@ -2335,7 +2225,7 @@ scm_bigprint (SCM exp, SCM port, scm_print_state *pstate) { #ifdef SCM_BIGDIG exp = big2str (exp, (unsigned int) 10); - scm_lfwrite (SCM_STRING_CHARS (exp), (scm_sizet) SCM_STRING_LENGTH (exp), port); + scm_lfwrite (SCM_STRING_CHARS (exp), (size_t) SCM_STRING_LENGTH (exp), port); #else scm_ipruk ("bignum", exp, port); #endif @@ -2412,9 +2302,9 @@ scm_small_istr2int (char *str, long len, long radix) SCM scm_istr2int (char *str, long len, long radix) { - scm_sizet j; - register scm_sizet k, blen = 1; - scm_sizet i = 0; + size_t j; + register size_t k, blen = 1; + size_t i = 0; int c; SCM res; register SCM_BIGDIG *ds; @@ -2441,7 +2331,7 @@ scm_istr2int (char *str, long len, long radix) if (++i == (unsigned) len) return SCM_BOOL_F; /* bad if lone `+' or `-' */ } - res = scm_mkbig (j, '-' == str[0]); + res = scm_i_mkbig (j, '-' == str[0]); ds = SCM_BDIGITS (res); for (k = j; k--;) ds[k] = 0; @@ -2494,11 +2384,11 @@ scm_istr2int (char *str, long len, long radix) } while (i < (unsigned) len); if (blen * SCM_BITSPERDIG / SCM_CHAR_BIT <= sizeof (SCM)) - if (SCM_INUMP (res = scm_big2inum (res, blen))) + if (SCM_INUMP (res = scm_i_big2inum (res, blen))) return res; if (j == blen) return res; - return scm_adjbig (res, blen); + return scm_i_adjbig (res, blen); } SCM @@ -3047,9 +2937,9 @@ scm_num_eq_p (SCM x, SCM y) } else if (SCM_BIGP (y)) { return SCM_BOOL (0 == scm_bigcomp (x, y)); } else if (SCM_REALP (y)) { - return SCM_BOOL (scm_big2dbl (x) == SCM_REAL_VALUE (y)); + return SCM_BOOL (scm_i_big2dbl (x) == SCM_REAL_VALUE (y)); } else if (SCM_COMPLEXP (y)) { - return SCM_BOOL ((scm_big2dbl (x) == SCM_COMPLEX_REAL (y)) + return SCM_BOOL ((scm_i_big2dbl (x) == SCM_COMPLEX_REAL (y)) && (0.0 == SCM_COMPLEX_IMAG (y))); } else { SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p); @@ -3058,7 +2948,7 @@ scm_num_eq_p (SCM x, SCM y) if (SCM_INUMP (y)) { return SCM_BOOL (SCM_REAL_VALUE (x) == (double) SCM_INUM (y)); } else if (SCM_BIGP (y)) { - return SCM_BOOL (SCM_REAL_VALUE (x) == scm_big2dbl (y)); + return SCM_BOOL (SCM_REAL_VALUE (x) == scm_i_big2dbl (y)); } else if (SCM_REALP (y)) { return SCM_BOOL (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y)); } else if (SCM_COMPLEXP (y)) { @@ -3072,7 +2962,7 @@ scm_num_eq_p (SCM x, SCM y) return SCM_BOOL ((SCM_COMPLEX_REAL (x) == (double) SCM_INUM (y)) && (SCM_COMPLEX_IMAG (x) == 0.0)); } else if (SCM_BIGP (y)) { - return SCM_BOOL ((SCM_COMPLEX_REAL (x) == scm_big2dbl (y)) + return SCM_BOOL ((SCM_COMPLEX_REAL (x) == scm_i_big2dbl (y)) && (SCM_COMPLEX_IMAG (x) == 0.0)); } else if (SCM_REALP (y)) { return SCM_BOOL ((SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y)) @@ -3114,7 +3004,7 @@ scm_less_p (SCM x, SCM y) } else if (SCM_BIGP (y)) { return SCM_BOOL (1 == scm_bigcomp (x, y)); } else if (SCM_REALP (y)) { - return SCM_BOOL (scm_big2dbl (x) < SCM_REAL_VALUE (y)); + return SCM_BOOL (scm_i_big2dbl (x) < SCM_REAL_VALUE (y)); } else { SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); } @@ -3122,7 +3012,7 @@ scm_less_p (SCM x, SCM y) if (SCM_INUMP (y)) { return SCM_BOOL (SCM_REAL_VALUE (x) < (double) SCM_INUM (y)); } else if (SCM_BIGP (y)) { - return SCM_BOOL (SCM_REAL_VALUE (x) < scm_big2dbl (y)); + return SCM_BOOL (SCM_REAL_VALUE (x) < scm_i_big2dbl (y)); } else if (SCM_REALP (y)) { return SCM_BOOL (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y)); } else { @@ -3283,7 +3173,7 @@ scm_max (SCM x, SCM y) } else if (SCM_BIGP (y)) { return (1 == scm_bigcomp (x, y)) ? y : x; } else if (SCM_REALP (y)) { - double z = scm_big2dbl (x); + double z = scm_i_big2dbl (x); return (z <= SCM_REAL_VALUE (y)) ? y : scm_make_real (z); } else { SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max); @@ -3293,7 +3183,7 @@ scm_max (SCM x, SCM y) double z = SCM_INUM (y); return (SCM_REAL_VALUE (x) < z) ? scm_make_real (z) : x; } else if (SCM_BIGP (y)) { - double z = scm_big2dbl (y); + double z = scm_i_big2dbl (y); return (SCM_REAL_VALUE (x) < z) ? scm_make_real (z) : x; } else if (SCM_REALP (y)) { return (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y)) ? y : x; @@ -3341,7 +3231,7 @@ scm_min (SCM x, SCM y) } else if (SCM_BIGP (y)) { return (-1 == scm_bigcomp (x, y)) ? y : x; } else if (SCM_REALP (y)) { - double z = scm_big2dbl (x); + double z = scm_i_big2dbl (x); return (z < SCM_REAL_VALUE (y)) ? scm_make_real (z) : y; } else { SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min); @@ -3351,7 +3241,7 @@ scm_min (SCM x, SCM y) double z = SCM_INUM (y); return (SCM_REAL_VALUE (x) <= z) ? x : scm_make_real (z); } else if (SCM_BIGP (y)) { - double z = scm_big2dbl (y); + double z = scm_i_big2dbl (y); return (SCM_REAL_VALUE (x) <= z) ? x : scm_make_real (z); } else if (SCM_REALP (y)) { return (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y)) ? x : y; @@ -3390,7 +3280,7 @@ scm_sum (SCM x, SCM y) return SCM_MAKINUM (z); } else { #ifdef SCM_BIGDIG - return scm_long2big (z); + return scm_i_long2big (z); #else /* SCM_BIGDIG */ return scm_make_real ((double) z); #endif /* SCM_BIGDIG */ @@ -3429,9 +3319,9 @@ scm_sum (SCM x, SCM y) return scm_addbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), SCM_BIGSIGN (x), y, 0); } else if (SCM_REALP (y)) { - return scm_make_real (scm_big2dbl (x) + SCM_REAL_VALUE (y)); + return scm_make_real (scm_i_big2dbl (x) + SCM_REAL_VALUE (y)); } else if (SCM_COMPLEXP (y)) { - return scm_make_complex (scm_big2dbl (x) + SCM_COMPLEX_REAL (y), + return scm_make_complex (scm_i_big2dbl (x) + SCM_COMPLEX_REAL (y), SCM_COMPLEX_IMAG (y)); } else { SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum); @@ -3440,7 +3330,7 @@ scm_sum (SCM x, SCM y) if (SCM_INUMP (y)) { return scm_make_real (SCM_REAL_VALUE (x) + SCM_INUM (y)); } else if (SCM_BIGP (y)) { - return scm_make_real (SCM_REAL_VALUE (x) + scm_big2dbl (y)); + return scm_make_real (SCM_REAL_VALUE (x) + scm_i_big2dbl (y)); } else if (SCM_REALP (y)) { return scm_make_real (SCM_REAL_VALUE (x) + SCM_REAL_VALUE (y)); } else if (SCM_COMPLEXP (y)) { @@ -3454,7 +3344,7 @@ scm_sum (SCM x, SCM y) return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_INUM (y), SCM_COMPLEX_IMAG (x)); } else if (SCM_BIGP (y)) { - return scm_make_complex (SCM_COMPLEX_REAL (x) + scm_big2dbl (y), + return scm_make_complex (SCM_COMPLEX_REAL (x) + scm_i_big2dbl (y), SCM_COMPLEX_IMAG (x)); } else if (SCM_REALP (y)) { return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_REAL_VALUE (y), @@ -3489,16 +3379,16 @@ scm_difference (SCM x, SCM y) return SCM_MAKINUM (xx); } else { #ifdef SCM_BIGDIG - return scm_long2big (xx); + return scm_i_long2big (xx); #else return scm_make_real ((double) xx); #endif } } else if (SCM_BIGP (x)) { - SCM z = scm_copybig (x, !SCM_BIGSIGN (x)); + SCM z = scm_i_copybig (x, !SCM_BIGSIGN (x)); unsigned int digs = SCM_NUMDIGS (z); unsigned int size = digs * SCM_BITSPERDIG / SCM_CHAR_BIT; - return size <= sizeof (SCM) ? scm_big2inum (z, digs) : z; + return size <= sizeof (SCM) ? scm_i_big2inum (z, digs) : z; } else if (SCM_REALP (x)) { return scm_make_real (-SCM_REAL_VALUE (x)); } else if (SCM_COMPLEXP (x)) { @@ -3517,7 +3407,7 @@ scm_difference (SCM x, SCM y) return SCM_MAKINUM (z); } else { #ifdef SCM_BIGDIG - return scm_long2big (z); + return scm_i_long2big (z); #else return scm_make_real ((double) z); #endif @@ -3561,9 +3451,9 @@ scm_difference (SCM x, SCM y) : scm_addbig (SCM_BDIGITS (y), SCM_NUMDIGS (y), SCM_BIGSIGN (y) ^ SCM_BIGSIGNFLAG, x, 0); } else if (SCM_REALP (y)) { - return scm_make_real (scm_big2dbl (x) - SCM_REAL_VALUE (y)); + return scm_make_real (scm_i_big2dbl (x) - SCM_REAL_VALUE (y)); } else if (SCM_COMPLEXP (y)) { - return scm_make_complex (scm_big2dbl (x) - SCM_COMPLEX_REAL (y), + return scm_make_complex (scm_i_big2dbl (x) - SCM_COMPLEX_REAL (y), - SCM_COMPLEX_IMAG (y)); } else { SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference); @@ -3572,7 +3462,7 @@ scm_difference (SCM x, SCM y) if (SCM_INUMP (y)) { return scm_make_real (SCM_REAL_VALUE (x) - SCM_INUM (y)); } else if (SCM_BIGP (y)) { - return scm_make_real (SCM_REAL_VALUE (x) - scm_big2dbl (y)); + return scm_make_real (SCM_REAL_VALUE (x) - scm_i_big2dbl (y)); } else if (SCM_REALP (y)) { return scm_make_real (SCM_REAL_VALUE (x) - SCM_REAL_VALUE (y)); } else if (SCM_COMPLEXP (y)) { @@ -3586,7 +3476,7 @@ scm_difference (SCM x, SCM y) return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_INUM (y), SCM_COMPLEX_IMAG (x)); } else if (SCM_BIGP (y)) { - return scm_make_complex (SCM_COMPLEX_REAL (x) - scm_big2dbl (y), + return scm_make_complex (SCM_COMPLEX_REAL (x) - scm_i_big2dbl (y), SCM_COMPLEX_IMAG (x)); } else if (SCM_REALP (y)) { return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_REAL_VALUE (y), @@ -3689,9 +3579,9 @@ scm_product (SCM x, SCM y) SCM_BDIGITS (y), SCM_NUMDIGS (y), SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y)); } else if (SCM_REALP (y)) { - return scm_make_real (scm_big2dbl (x) * SCM_REAL_VALUE (y)); + return scm_make_real (scm_i_big2dbl (x) * SCM_REAL_VALUE (y)); } else if (SCM_COMPLEXP (y)) { - double z = scm_big2dbl (x); + double z = scm_i_big2dbl (x); return scm_make_complex (z * SCM_COMPLEX_REAL (y), z * SCM_COMPLEX_IMAG (y)); } else { @@ -3701,7 +3591,7 @@ scm_product (SCM x, SCM y) if (SCM_INUMP (y)) { return scm_make_real (SCM_INUM (y) * SCM_REAL_VALUE (x)); } else if (SCM_BIGP (y)) { - return scm_make_real (scm_big2dbl (y) * SCM_REAL_VALUE (x)); + return scm_make_real (scm_i_big2dbl (y) * SCM_REAL_VALUE (x)); } else if (SCM_REALP (y)) { return scm_make_real (SCM_REAL_VALUE (x) * SCM_REAL_VALUE (y)); } else if (SCM_COMPLEXP (y)) { @@ -3715,7 +3605,7 @@ scm_product (SCM x, SCM y) return scm_make_complex (SCM_INUM (y) * SCM_COMPLEX_REAL (x), SCM_INUM (y) * SCM_COMPLEX_IMAG (x)); } else if (SCM_BIGP (y)) { - double z = scm_big2dbl (y); + double z = scm_i_big2dbl (y); return scm_make_complex (z * SCM_COMPLEX_REAL (x), z * SCM_COMPLEX_IMAG (x)); } else if (SCM_REALP (y)) { @@ -3742,7 +3632,7 @@ scm_num2dbl (SCM a, const char *why) if (SCM_INUMP (a)) { return (double) SCM_INUM (a); } else if (SCM_BIGP (a)) { - return scm_big2dbl (a); + return scm_i_big2dbl (a); } else if (SCM_REALP (a)) { return (SCM_REAL_VALUE (a)); } else { @@ -3771,7 +3661,7 @@ scm_divide (SCM x, SCM y) return scm_make_real (1.0 / (double) SCM_INUM (x)); } } else if (SCM_BIGP (x)) { - return scm_make_real (1.0 / scm_big2dbl (x)); + return scm_make_real (1.0 / scm_i_big2dbl (x)); } else if (SCM_REALP (x)) { return scm_make_real (1.0 / SCM_REAL_VALUE (x)); } else if (SCM_COMPLEXP (x)) { @@ -3798,14 +3688,14 @@ scm_divide (SCM x, SCM y) return SCM_MAKINUM (z); } else { #ifdef SCM_BIGDIG - return scm_long2big (z); + return scm_i_long2big (z); #else return scm_make_real ((double) xx / (double) yy); #endif } } } else if (SCM_BIGP (y)) { - return scm_make_real ((double) xx / scm_big2dbl (y)); + return scm_make_real ((double) xx / scm_i_big2dbl (y)); } else if (SCM_REALP (y)) { return scm_make_real ((double) xx / SCM_REAL_VALUE (y)); } else if (SCM_COMPLEXP (y)) { @@ -3830,11 +3720,11 @@ scm_divide (SCM x, SCM y) } else { long z = yy < 0 ? -yy : yy; if (z < SCM_BIGRAD) { - SCM w = scm_copybig (x, SCM_BIGSIGN (x) ? (yy > 0) : (yy < 0)); + SCM w = scm_i_copybig (x, SCM_BIGSIGN (x) ? (yy > 0) : (yy < 0)); return scm_divbigdig (SCM_BDIGITS (w), SCM_NUMDIGS (w), (SCM_BIGDIG) z) - ? scm_make_real (scm_big2dbl (x) / (double) yy) - : scm_normbig (w); + ? scm_make_real (scm_i_big2dbl (x) / (double) yy) + : scm_i_normbig (w); } else { SCM w; #ifndef SCM_DIGSTOOBIG @@ -3851,7 +3741,7 @@ scm_divide (SCM x, SCM y) #endif return (!SCM_UNBNDP (w)) ? w - : scm_make_real (scm_big2dbl (x) / (double) yy); + : scm_make_real (scm_i_big2dbl (x) / (double) yy); } } } else if (SCM_BIGP (y)) { @@ -3860,11 +3750,11 @@ scm_divide (SCM x, SCM y) SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y), 3); return (!SCM_UNBNDP (w)) ? w - : scm_make_real (scm_big2dbl (x) / scm_big2dbl (y)); + : scm_make_real (scm_i_big2dbl (x) / scm_i_big2dbl (y)); } else if (SCM_REALP (y)) { - return scm_make_real (scm_big2dbl (x) / SCM_REAL_VALUE (y)); + return scm_make_real (scm_i_big2dbl (x) / SCM_REAL_VALUE (y)); } else if (SCM_COMPLEXP (y)) { - a = scm_big2dbl (x); + a = scm_i_big2dbl (x); goto complex_div; } else { SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); @@ -3874,7 +3764,7 @@ scm_divide (SCM x, SCM y) if (SCM_INUMP (y)) { return scm_make_real (rx / (double) SCM_INUM (y)); } else if (SCM_BIGP (y)) { - return scm_make_real (rx / scm_big2dbl (y)); + return scm_make_real (rx / scm_i_big2dbl (y)); } else if (SCM_REALP (y)) { return scm_make_real (rx / SCM_REAL_VALUE (y)); } else if (SCM_COMPLEXP (y)) { @@ -3890,7 +3780,7 @@ scm_divide (SCM x, SCM y) double d = SCM_INUM (y); return scm_make_complex (rx / d, ix / d); } else if (SCM_BIGP (y)) { - double d = scm_big2dbl (y); + double d = scm_i_big2dbl (y); return scm_make_complex (rx / d, ix / d); } else if (SCM_REALP (y)) { double d = SCM_REAL_VALUE (y); @@ -4047,7 +3937,7 @@ scm_two_doubles (SCM x, SCM y, const char *sstring, struct dpair *xy) if (SCM_INUMP (x)) { xy->x = SCM_INUM (x); } else if (SCM_BIGP (x)) { - xy->x = scm_big2dbl (x); + xy->x = scm_i_big2dbl (x); } else if (SCM_REALP (x)) { xy->x = SCM_REAL_VALUE (x); } else { @@ -4057,7 +3947,7 @@ scm_two_doubles (SCM x, SCM y, const char *sstring, struct dpair *xy) if (SCM_INUMP (y)) { xy->y = SCM_INUM (y); } else if (SCM_BIGP (y)) { - xy->y = scm_big2dbl (y); + xy->y = scm_i_big2dbl (y); } else if (SCM_REALP (y)) { xy->y = SCM_REAL_VALUE (y); } else { @@ -4176,7 +4066,7 @@ scm_magnitude (SCM z) return SCM_MAKINUM (-zz); } else { #ifdef SCM_BIGDIG - return scm_long2big (-zz); + return scm_i_long2big (-zz); #else scm_num_overflow (s_magnitude); #endif @@ -4185,7 +4075,7 @@ scm_magnitude (SCM z) if (!SCM_BIGSIGN (z)) { return z; } else { - return scm_copybig (z, 0); + return scm_i_copybig (z, 0); } } else if (SCM_REALP (z)) { return scm_make_real (fabs (SCM_REAL_VALUE (z))); @@ -4243,7 +4133,7 @@ SCM_DEFINE (scm_inexact_to_exact, "inexact->exact", 1, 0, 0, return SCM_MAKINUM (lu); #ifdef SCM_BIGDIG } else if (isfinite (u)) { - return scm_dbl2big (u); + return scm_i_dbl2big (u); #endif } else { scm_num_overflow (s_scm_inexact_to_exact); @@ -4259,9 +4149,9 @@ SCM_DEFINE (scm_inexact_to_exact, "inexact->exact", 1, 0, 0, /* d must be integer */ SCM -scm_dbl2big (double d) +scm_i_dbl2big (double d) { - scm_sizet i = 0; + size_t i = 0; long c; SCM_BIGDIG *digits; SCM ans; @@ -4271,7 +4161,7 @@ scm_dbl2big (double d) u /= SCM_BIGRAD; i++; } - ans = scm_mkbig (i, d < 0); + ans = scm_i_mkbig (i, d < 0); digits = SCM_BDIGITS (ans); while (i--) { @@ -4287,13 +4177,11 @@ scm_dbl2big (double d) return ans; } - - double -scm_big2dbl (SCM b) +scm_i_big2dbl (SCM b) { double ans = 0.0; - scm_sizet i = SCM_NUMDIGS (b); + size_t i = SCM_NUMDIGS (b); SCM_BIGDIG *digits = SCM_BDIGITS (b); while (i--) ans = digits[i] + SCM_BIGRAD * ans; @@ -4301,111 +4189,101 @@ scm_big2dbl (SCM b) return - ans; return ans; } + #endif - -SCM -scm_long2num (long sl) -{ - if (!SCM_FIXABLE (sl)) - { -#ifdef SCM_BIGDIG - return scm_long2big (sl); -#else - return scm_make_real ((double) sl); -#endif - } - return SCM_MAKINUM (sl); -} - - #ifdef HAVE_LONG_LONGS - -SCM -scm_long_long2num (long_long sl) -{ - if (!SCM_FIXABLE (sl)) - { -#ifdef SCM_BIGDIG - return scm_long_long2big (sl); -#else - return scm_make_real ((double) sl); +# ifndef LLONG_MAX +# define ULLONG_MAX ((unsigned long long) (-1)) +# define LLONG_MAX ((long long) (ULLONG_MAX >> 1)) +# define LLONG_MIN (~LLONG_MAX) +# endif #endif - } - else - { - /* we know that sl fits into an inum */ - return SCM_MAKINUM ((scm_bits_t) sl); - } -} -#endif /* HAVE_LONG_LONGS */ +#define SIZE_MAX ((size_t) (-1)) +/* the below is not really guaranteed to work (I think), but probably does: */ +#define PTRDIFF_MIN ((ptrdiff_t) ((ptrdiff_t)1 << (sizeof (ptrdiff_t) * 8 - 1))) +#define PTRDIFF_MAX (~ PTRDIFF_MIN) +#define NUM2INTEGRAL scm_num2short +#define INTEGRAL2NUM scm_short2num +#define INTEGRAL2BIG scm_i_short2big +#define ITYPE short +#define MIN_VALUE SHRT_MIN +#define MAX_VALUE SHRT_MAX +#include "libguile/num2integral.i.c" -SCM -scm_ulong2num (unsigned long sl) -{ - if (!SCM_POSFIXABLE (sl)) - { -#ifdef SCM_BIGDIG - return scm_ulong2big (sl); -#else - return scm_make_real ((double) sl); -#endif - } - return SCM_MAKINUM (sl); -} +#define NUM2INTEGRAL scm_num2ushort +#define INTEGRAL2NUM scm_ushort2num +#define INTEGRAL2BIG scm_i_ushort2big +#define UNSIGNED +#define ITYPE unsigned short +#define MAX_VALUE USHRT_MAX +#include "libguile/num2integral.i.c" +#define NUM2INTEGRAL scm_num2int +#define INTEGRAL2NUM scm_int2num +#define INTEGRAL2BIG scm_i_int2big +#define ITYPE int +#define MIN_VALUE INT_MIN +#define MAX_VALUE INT_MAX +#include "libguile/num2integral.i.c" -long -scm_num2long (SCM num, unsigned long int pos, const char *s_caller) -{ - if (SCM_INUMP (num)) { - return SCM_INUM (num); - } else if (SCM_BIGP (num)) { - long int res; - /* can't use res directly in case num is -2^31. */ - unsigned long int pos_res = 0; - unsigned long int old_res = 0; - scm_sizet l; +#define NUM2INTEGRAL scm_num2uint +#define INTEGRAL2NUM scm_uint2num +#define INTEGRAL2BIG scm_i_uint2big +#define UNSIGNED +#define ITYPE unsigned int +#define MAX_VALUE UINT_MAX +#include "libguile/num2integral.i.c" - for (l = SCM_NUMDIGS (num); l--;) { - pos_res = SCM_BIGUP (pos_res) + SCM_BDIGITS (num)[l]; - if (pos_res >= old_res) { - old_res = pos_res; - } else { - /* overflow. */ - scm_out_of_range (s_caller, num); - } - } - if (SCM_BIGSIGN (num)) { - res = -pos_res; - if (res <= 0) { - return res; - } else { - scm_out_of_range (s_caller, num); - } - } else { - res = pos_res; - if (res >= 0) { - return res; - } else { - scm_out_of_range (s_caller, num); - } - } - } else if (SCM_REALP (num)) { - double u = SCM_REAL_VALUE (num); - long int res = u; - if ((double) res == u) { - return res; - } else { - scm_out_of_range (s_caller, num); - } - } else { - scm_wrong_type_arg (s_caller, pos, num); - } -} +#define NUM2INTEGRAL scm_num2long +#define INTEGRAL2NUM scm_long2num +#define INTEGRAL2BIG scm_i_long2big +#define ITYPE long +#define MIN_VALUE LONG_MIN +#define MAX_VALUE LONG_MAX +#include "libguile/num2integral.i.c" +#define NUM2INTEGRAL scm_num2ulong +#define INTEGRAL2NUM scm_ulong2num +#define INTEGRAL2BIG scm_i_ulong2big +#define UNSIGNED +#define ITYPE unsigned long +#define MAX_VALUE ULONG_MAX +#include "libguile/num2integral.i.c" + +#define NUM2INTEGRAL scm_num2bits +#define INTEGRAL2NUM scm_bits2num +#define INTEGRAL2BIG scm_i_bits2big +#define ITYPE scm_bits_t +#define MIN_VALUE ((scm_bits_t) ((scm_ubits_t)1 << (sizeof (scm_bits_t) - 1))) +#define MAX_VALUE (~MIN_VALUE) +#include "libguile/num2integral.i.c" + +#define NUM2INTEGRAL scm_num2ubits +#define INTEGRAL2NUM scm_ubits2num +#define INTEGRAL2BIG scm_i_ubits2big +#define UNSIGNED +#define ITYPE scm_ubits_t +#define MAX_VALUE ((scm_ubits_t) ((scm_bits_t) (-1))) +#include "libguile/num2integral.i.c" + +#define NUM2INTEGRAL scm_num2ptrdiff +#define INTEGRAL2NUM scm_ptrdiff2num +#define INTEGRAL2BIG scm_i_ptrdiff2big +#define ITYPE ptrdiff_t +#define MIN_VALUE PTRDIFF_MIN +#define MAX_VALUE PTRDIFF_MAX +#include "libguile/num2integral.i.c" + +#define NUM2INTEGRAL scm_num2size +#define INTEGRAL2NUM scm_size2num +#define INTEGRAL2BIG scm_i_size2big +#define UNSIGNED +#define ITYPE size_t +#define MAX_VALUE SIZE_MAX +#include "libguile/num2integral.i.c" #ifdef HAVE_LONG_LONGS @@ -4413,133 +4291,80 @@ scm_num2long (SCM num, unsigned long int pos, const char *s_caller) #define ULONG_LONG_MAX (~0ULL) #endif -long_long -scm_num2long_long (SCM num, unsigned long int pos, const char *s_caller) -{ - if (SCM_INUMP (num)) { - return SCM_INUM (num); - } else if (SCM_BIGP (num)) { - long long res; - /* can't use res directly in case num is -2^63. */ - unsigned long long int pos_res = 0; - scm_sizet l; +#define NUM2INTEGRAL scm_num2long_long +#define INTEGRAL2NUM scm_long_long2num +#define INTEGRAL2BIG scm_i_long_long2big +#define ITYPE long long +#define MIN_VALUE LLONG_MIN +#define MAX_VALUE LLONG_MAX +#include "libguile/num2integral.i.c" - for (l = SCM_NUMDIGS (num); l--;) { - if (pos_res > SCM_BIGDN(ULONG_LONG_MAX)) - scm_out_of_range (s_caller, num); - pos_res = SCM_LONGLONGBIGUP (pos_res) + SCM_BDIGITS (num)[l]; - } - if (SCM_BIGSIGN (num)) { - res = -pos_res; - if (res <= 0) { - return res; - } else { - scm_out_of_range (s_caller, num); - } - } else { - res = pos_res; - if (res >= 0) { - return res; - } else { - scm_out_of_range (s_caller, num); - } - } - } else if (SCM_REALP (num)) { - double u = SCM_REAL_VALUE (num); - long long int res = u; - if ((double) res == u) { - return res; - } else { - scm_out_of_range (s_caller, num); - } - } else { - scm_wrong_type_arg (s_caller, pos, num); - } -} - -ulong_long -scm_num2ulong_long (SCM num, unsigned long int pos, const char *s_caller) -{ - if (SCM_INUMP (num)) - { - long long nnum = SCM_INUM (num); - if (nnum >= 0) - return nnum; - else - scm_out_of_range (s_caller, num); - } - else if (SCM_BIGP (num)) - { - unsigned long long res = 0; - scm_sizet l; - - if (SCM_BIGSIGN (num)) - scm_out_of_range (s_caller, num); - - for (l = SCM_NUMDIGS (num); l--;) { - if (res > SCM_BIGDN(ULONG_LONG_MAX)) - scm_out_of_range (s_caller, num); - res = SCM_LONGLONGBIGUP (res) + SCM_BDIGITS (num)[l]; - } - return res; - } - else if (SCM_REALP (num)) - { - double u = SCM_REAL_VALUE (num); - unsigned long long int res = u; - if ((double) res == u) - return res; - else - scm_out_of_range (s_caller, num); - } - else - scm_wrong_type_arg (s_caller, pos, num); -} +#define NUM2INTEGRAL scm_num2ulong_long +#define INTEGRAL2NUM scm_ulong_long2num +#define INTEGRAL2BIG scm_i_ulong_long2big +#define UNSIGNED +#define ITYPE unsigned long long +#define MAX_VALUE ULLONG_MAX +#include "libguile/num2integral.i.c" #endif /* HAVE_LONG_LONGS */ +#ifdef GUILE_DEBUG -unsigned long -scm_num2ulong (SCM num, unsigned long int pos, const char *s_caller) +#define CHECK(type, v) \ + do { \ + if ((v) != scm_num2##type (scm_##type##2num (v), 1, "check_sanity")) \ + abort (); \ + } while (0); + +static void +check_sanity () { - if (SCM_INUMP (num)) { - long nnum = SCM_INUM (num); - if (nnum >= 0) { - return nnum; - } else { - scm_out_of_range (s_caller, num); - } - } else if (SCM_BIGP (num)) { - unsigned long int res = 0; - scm_sizet l; - - if (SCM_BIGSIGN (num)) - scm_out_of_range (s_caller, num); - - for (l = SCM_NUMDIGS (num); l--;) { - if (res > SCM_BIGDN(ULONG_MAX)) - scm_out_of_range (s_caller, num); - res = SCM_BIGUP (res) + SCM_BDIGITS (num)[l]; - } - return res; - } else if (SCM_REALP (num)) { - double u = SCM_REAL_VALUE (num); - unsigned long int res = u; - if ((double) res == u) { - return res; - } else { - scm_out_of_range (s_caller, num); - } - } else { - scm_wrong_type_arg (s_caller, pos, num); - } + CHECK (short, 0); + CHECK (ushort, 0U); + CHECK (int, 0); + CHECK (uint, 0U); + CHECK (long, 0L); + CHECK (ulong, 0UL); + CHECK (size, 0); + CHECK (ptrdiff, 0); + + CHECK (short, -1); + CHECK (int, -1); + CHECK (long, -1L); + CHECK (ptrdiff, -1); + + CHECK (short, SHRT_MAX); + CHECK (short, SHRT_MIN); + CHECK (ushort, USHRT_MAX); + CHECK (int, INT_MAX); + CHECK (int, INT_MIN); + CHECK (uint, UINT_MAX); + CHECK (long, LONG_MAX); + CHECK (long, LONG_MIN); + CHECK (ulong, ULONG_MAX); + CHECK (size, SIZE_MAX); + CHECK (ptrdiff, PTRDIFF_MAX); + CHECK (ptrdiff, PTRDIFF_MIN); + +#ifdef HAVE_LONG_LONGS + CHECK (long_long, 0LL); + CHECK (ulong_long, 0ULL); + + CHECK (long_long, -1LL); + + CHECK (long_long, LLONG_MAX); + CHECK (long_long, LLONG_MIN); + CHECK (ulong_long, ULLONG_MAX); +#endif } +#endif void scm_init_numbers () { - abs_most_negative_fixnum = scm_long2big (- SCM_MOST_NEGATIVE_FIXNUM); + abs_most_negative_fixnum = scm_i_long2big (- SCM_MOST_NEGATIVE_FIXNUM); scm_permanent_object (abs_most_negative_fixnum); /* It may be possible to tune the performance of some algorithms by using @@ -4571,11 +4396,104 @@ scm_init_numbers () scm_dblprec = scm_dblprec - 1; } #endif /* DBL_DIG */ + +#ifdef GUILE_DEBUG + check_sanity (); +#endif + #ifndef SCM_MAGIC_SNARFER #include "libguile/numbers.x" #endif } +#if (SCM_DEBUG_DEPRECATED == 0) + +SCM +scm_mkbig (size_t len, int sign) +{ + scm_c_issue_deprecation_warning ("`scm_mkbig' is deprecated. " + "Use `scm_i_mkbig' instead."); + return scm_i_mkbig (len, sign); +} + +SCM +scm_big2inum (SCM b, size_t l) +{ + scm_c_issue_deprecation_warning ("`scm_big2inum' is deprecated. " + "Use `scm_i_big2num' instead."); + return scm_i_big2inum (b, l); +} + +SCM +scm_adjbig (SCM b, size_t nlen) +{ + scm_c_issue_deprecation_warning ("`scm_adjbig' is deprecated. " + "Use `scm_i_adjbig' instead."); + return scm_i_adjbig (b, nlen); +} + +SCM +scm_normbig (SCM b) +{ + scm_c_issue_deprecation_warning ("`scm_normbig' is deprecated. " + "Use `scm_i_normbig' instead."); + return scm_i_normbig (b); +} + +SCM +scm_copybig (SCM b, int sign) +{ + scm_c_issue_deprecation_warning ("`scm_copybig' is deprecated. " + "Use `scm_i_copybig' instead."); + return scm_i_copybig (b, sign); +} + +SCM +scm_2ulong2big (unsigned long *np) +{ + unsigned long n; + size_t i; + SCM_BIGDIG *digits; + SCM ans; + + ans = scm_i_mkbig (2 * SCM_DIGSPERLONG, 0); + digits = SCM_BDIGITS (ans); + + n = np[0]; + for (i = 0; i < SCM_DIGSPERLONG; ++i) + { + digits[i] = SCM_BIGLO (n); + n = SCM_BIGDN ((unsigned long) n); + } + n = np[1]; + for (i = 0; i < SCM_DIGSPERLONG; ++i) + { + digits[i + SCM_DIGSPERLONG] = SCM_BIGLO (n); + n = SCM_BIGDN ((unsigned long) n); + } + return ans; +} + +SCM +scm_dbl2big (double d) +{ + scm_c_issue_deprecation_warning ("`scm_dbl2big' is deprecated. " + "Use `scm_dbl2num' instead," + "or `scm_i_dbl2big'."); + return scm_i_dbl2big (d); +} + +double +scm_big2dbl (SCM b) +{ + scm_c_issue_deprecation_warning ("`scm_big2dbl' is deprecated. " + "Use `scm_num2dbl' instead," + "or `scm_i_big2dbl'."); + return scm_i_big2dbl (b); +} + +#endif + /* Local Variables: c-file-style: "gnu" diff --git a/libguile/numbers.h b/libguile/numbers.h index 23df0d7d8..09dc4bdbe 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -62,8 +62,8 @@ * SCM_INUMP (SCM_CAR (x)) can give wrong answers. */ -#define SCM_FIXNUM_BIT (SCM_LONG_BIT - 2) -#define SCM_MOST_POSITIVE_FIXNUM ((1L << (SCM_FIXNUM_BIT - 1)) - 1) +#define SCM_I_FIXNUM_BIT (SCM_BITS_LENGTH - 2) +#define SCM_MOST_POSITIVE_FIXNUM ((1L << (SCM_I_FIXNUM_BIT - 1)) - 1) #define SCM_MOST_NEGATIVE_FIXNUM (-SCM_MOST_POSITIVE_FIXNUM - 1) @@ -115,7 +115,7 @@ /* SCM_INTBUFLEN is the maximum number of characters neccessary for the * printed or scm_string representation of an exact immediate. */ -#define SCM_INTBUFLEN (5 + SCM_LONG_BIT) +#define SCM_INTBUFLEN (5 + SCM_BITS_LENGTH) @@ -154,9 +154,10 @@ # endif /* def _UNICOS */ # define SCM_BIGRAD (1L << SCM_BITSPERDIG) -# define SCM_DIGSPERLONG ((scm_sizet)((sizeof(long)*SCM_CHAR_BIT+SCM_BITSPERDIG-1)/SCM_BITSPERDIG)) -# define SCM_BIGUP(x) ((unsigned long)(x) << SCM_BITSPERDIG) -# define SCM_LONGLONGBIGUP(x) ((ulong_long)(x) << SCM_BITSPERDIG) +# define SCM_DIGSPERLONG ((size_t)((sizeof(long)*SCM_CHAR_BIT+SCM_BITSPERDIG-1)/SCM_BITSPERDIG)) +# define SCM_I_BIGUP(type, x) ((type)(x) << SCM_BITSPERDIG) +# define SCM_BIGUP(x) SCM_I_BIGUP (unsigned long, x) +# define SCM_LONGLONGBIGUP(x) SCM_I_BIGUP (unsigned long long, x) # define SCM_BIGDN(x) ((x) >> SCM_BITSPERDIG) # define SCM_BIGLO(x) ((x) & (SCM_BIGRAD-1)) #endif /* def BIGNUMS */ @@ -176,7 +177,7 @@ #define SCM_BIGSIGN(x) (SCM_CELL_WORD_0 (x) & SCM_BIGSIGNFLAG) #define SCM_BDIGITS(x) ((SCM_BIGDIG *) (SCM_CELL_WORD_1 (x))) #define SCM_SET_BIGNUM_BASE(n, b) (SCM_SET_CELL_WORD_1 ((n), (b))) -#define SCM_NUMDIGS(x) ((scm_sizet) (SCM_CELL_WORD_0 (x) >> SCM_BIGSIZEFIELD)) +#define SCM_NUMDIGS(x) ((size_t) ((scm_ubits_t) SCM_CELL_WORD_0 (x) >> SCM_BIGSIZEFIELD)) #define SCM_SETNUMDIGS(x, v, sign) \ SCM_SET_CELL_WORD_0 (x, \ scm_tc16_big \ @@ -220,24 +221,49 @@ extern SCM scm_ash (SCM n, SCM cnt); extern SCM scm_bit_extract (SCM n, SCM start, SCM end); extern SCM scm_logcount (SCM n); extern SCM scm_integer_length (SCM n); -extern SCM scm_mkbig (scm_sizet nlen, int sign); -extern SCM scm_big2inum (SCM b, scm_sizet l); -extern SCM scm_adjbig (SCM b, scm_sizet nlen); +extern SCM scm_i_mkbig (size_t nlen, int sign); +extern SCM scm_i_big2inum (SCM b, size_t l); +extern SCM scm_i_adjbig (SCM b, size_t nlen); +extern SCM scm_i_normbig (SCM b); +extern SCM scm_i_copybig (SCM b, int sign); +extern SCM scm_i_short2big (short n); +extern SCM scm_i_ushort2big (unsigned short n); +extern SCM scm_i_int2big (int n); +extern SCM scm_i_uint2big (unsigned int n); +extern SCM scm_i_long2big (long n); +extern SCM scm_i_ulong2big (unsigned long n); +extern SCM scm_i_bits2big (scm_bits_t n); +extern SCM scm_i_ubits2big (scm_ubits_t n); +extern SCM scm_i_size2big (size_t n); +extern SCM scm_i_ptrdiff2big (ptrdiff_t n); + + +#if (SCM_DEBUG_DEPRECATED == 0) +extern SCM scm_big2inum (SCM b, size_t l); +extern SCM scm_mkbig (size_t nlen, int sign); +extern SCM scm_adjbig (SCM b, size_t len); extern SCM scm_normbig (SCM b); extern SCM scm_copybig (SCM b, int sign); -extern SCM scm_long2big (long n); -#ifdef HAVE_LONG_LONGS -extern SCM scm_long_long2big (long_long n); + +#define SCM_FIXNUM_BIT SCM_I_FIXNUM_BIT #endif + +#ifdef HAVE_LONG_LONGS +extern SCM scm_i_long_long2big (long long n); +extern SCM scm_i_ulong_long2big (unsigned long long n); +#endif + +#if (SCM_DEBUG_DEPRECATED == 0) extern SCM scm_2ulong2big (unsigned long * np); -extern SCM scm_ulong2big (unsigned long n); +#endif + extern int scm_bigcomp (SCM x, SCM y); extern long scm_pseudolong (long x); extern void scm_longdigs (long x, SCM_BIGDIG digs[]); -extern SCM scm_addbig (SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy, int sgny); -extern SCM scm_mulbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn); -extern unsigned int scm_divbigdig (SCM_BIGDIG *ds, scm_sizet h, SCM_BIGDIG div); -extern scm_sizet scm_iint2str (long num, int rad, char *p); +extern SCM scm_addbig (SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy, int sgny); +extern SCM scm_mulbig (SCM_BIGDIG *x, size_t nx, SCM_BIGDIG *y, size_t ny, int sgn); +extern unsigned int scm_divbigdig (SCM_BIGDIG *ds, size_t h, SCM_BIGDIG div); +extern size_t scm_iint2str (long num, int rad, char *p); extern SCM scm_number_to_string (SCM x, SCM radix); extern int scm_print_real (SCM sexp, SCM port, scm_print_state *pstate); extern int scm_print_complex (SCM sexp, SCM port, scm_print_state *pstate); @@ -286,21 +312,57 @@ extern SCM scm_magnitude (SCM z); extern SCM scm_angle (SCM z); extern SCM scm_inexact_to_exact (SCM z); extern SCM scm_trunc (SCM x); +extern SCM scm_i_dbl2big (double d); + +#if (SCM_DEBUG_DEPRECATED == 0) extern SCM scm_dbl2big (double d); +#endif + +extern double scm_i_big2dbl (SCM b); + +#if (SCM_DEBUG_DEPRECATED == 0) extern double scm_big2dbl (SCM b); -extern SCM scm_long2num (long sl); -extern SCM scm_ulong2num (unsigned long sl); +#endif + +extern SCM scm_short2num (short n); +extern SCM scm_ushort2num (unsigned short n); +extern SCM scm_int2num (int n); +extern SCM scm_uint2num (unsigned int n); +extern SCM scm_long2num (long n); +extern SCM scm_ulong2num (unsigned long n); +extern SCM scm_bits2num (scm_bits_t n); +extern SCM scm_ubits2num (scm_ubits_t n); +extern SCM scm_size2num (size_t n); +extern SCM scm_ptrdiff2num (ptrdiff_t n); +extern short scm_num2short (SCM num, unsigned long int pos, + const char *s_caller); +extern unsigned short scm_num2ushort (SCM num, unsigned long int pos, + const char *s_caller); +extern int scm_num2int (SCM num, unsigned long int pos, + const char *s_caller); +extern unsigned int scm_num2uint (SCM num, unsigned long int pos, + const char *s_caller); extern long scm_num2long (SCM num, unsigned long int pos, const char *s_caller); -#ifdef HAVE_LONG_LONGS -extern SCM scm_long_long2num (long_long sl); -extern long_long scm_num2long_long (SCM num, unsigned long int pos, - const char *s_caller); -extern ulong_long scm_num2ulong_long (SCM num, unsigned long int pos, - const char *s_caller); -#endif extern unsigned long scm_num2ulong (SCM num, unsigned long int pos, const char *s_caller); +extern scm_bits_t scm_num2bits (SCM num, unsigned long int pos, + const char *s_caller); +extern scm_ubits_t scm_num2ubits (SCM num, unsigned long int pos, + const char *s_caller); +extern ptrdiff_t scm_num2ptrdiff (SCM num, unsigned long int pos, + const char *s_caller); +extern size_t scm_num2size (SCM num, unsigned long int pos, + const char *s_caller); +#ifdef HAVE_LONG_LONGS +extern SCM scm_long_long2num (long long sl); +extern SCM scm_ulong_long2num (unsigned long long sl); +extern long long scm_num2long_long (SCM num, unsigned long int pos, + const char *s_caller); +extern unsigned long long scm_num2ulong_long (SCM num, unsigned long int pos, + const char *s_caller); +#endif + extern void scm_init_numbers (void); #endif /* NUMBERSH */ diff --git a/libguile/objects.c b/libguile/objects.c index ac32e89ec..042549ca6 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -158,7 +158,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, case scm_tc7_smob: { - long type = SCM_TYP16 (x); + scm_bits_t type = SCM_TYP16 (x); if (type != scm_tc16_port_with_ps) return scm_smob_class[SCM_TC2SMOBNUM (type)]; x = SCM_PORT_WITH_PS_PORT (x); @@ -251,7 +251,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, SCM scm_mcache_lookup_cmethod (SCM cache, SCM args) { - int i, n, end, mask; + scm_bits_t i, n, end, mask; SCM ls, methods, z = SCM_CDDR (cache); n = SCM_INUM (SCM_CAR (z)); /* maximum number of specializers */ methods = SCM_CADR (z); @@ -266,8 +266,8 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args) else { /* Compute a hash value */ - int hashset = SCM_INUM (methods); - int j = n; + scm_bits_t hashset = SCM_INUM (methods); + scm_bits_t j = n; mask = SCM_INUM (SCM_CAR (z = SCM_CDDR (z))); methods = SCM_CADR (z); i = 0; @@ -287,7 +287,7 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args) /* Search for match */ do { - int j = n; + scm_bits_t j = n; z = SCM_VELTS (methods)[i]; ls = args; /* list of arguments */ if (SCM_NIMP (ls)) @@ -449,7 +449,7 @@ SCM_DEFINE (scm_object_procedure, "object-procedure", 1, 0, 0, SCM scm_i_make_class_object (SCM meta, SCM layout_string, - unsigned long flags) + scm_ubits_t flags) { SCM c; SCM layout = scm_make_struct_layout (layout_string); @@ -466,7 +466,7 @@ SCM_DEFINE (scm_make_class_object, "make-class-object", 2, 0, 0, "slot layout specified by @var{layout}.") #define FUNC_NAME s_scm_make_class_object { - unsigned long flags = 0; + scm_ubits_t flags = 0; SCM_VALIDATE_STRUCT (1,metaclass); SCM_VALIDATE_STRING (2,layout); if (SCM_EQ_P (metaclass, scm_metaclass_operator)) diff --git a/libguile/objects.h b/libguile/objects.h index 20e3fb3ea..5e3d27f30 100644 --- a/libguile/objects.h +++ b/libguile/objects.h @@ -214,7 +214,7 @@ extern SCM scm_no_applicable_method; /* Goops functions. */ extern SCM scm_make_extended_class (char *type_name); -extern void scm_make_port_classes (int ptobnum, char *type_name); +extern void scm_make_port_classes (scm_bits_t ptobnum, char *type_name); extern void scm_change_object_class (SCM, SCM, SCM); extern SCM scm_memoize_method (SCM x, SCM args); @@ -239,7 +239,7 @@ extern SCM scm_make_class_object (SCM metaclass, SCM layout); extern SCM scm_make_subclass_object (SCM c, SCM layout); extern SCM scm_i_make_class_object (SCM metaclass, SCM layout_string, - unsigned long flags); + scm_ubits_t flags); extern void scm_init_objects (void); #endif /* OBJECTSH */ diff --git a/libguile/options.c b/libguile/options.c index c5260e669..f363ce866 100644 --- a/libguile/options.c +++ b/libguile/options.c @@ -121,7 +121,7 @@ SCM_SYMBOL (scm_no_sym, "no"); static SCM protected_objects; SCM -scm_options (SCM arg, scm_option options[], int n, const char *s) +scm_options (SCM arg, scm_option_t options[], int n, const char *s) { int i, docp = (!SCM_UNBNDP (arg) && !SCM_NULLP (arg) && !SCM_CONSP (arg)); /* Let `arg' GC protect the arguments */ @@ -139,7 +139,7 @@ scm_options (SCM arg, scm_option options[], int n, const char *s) ls); break; case SCM_OPTION_INTEGER: - ls = scm_cons (SCM_MAKINUM ((int) options[i].val), ls); + ls = scm_cons (SCM_MAKINUM (options[i].val), ls); break; case SCM_OPTION_SCM: ls = scm_cons ((SCM) options[i].val, ls); @@ -212,7 +212,7 @@ scm_options (SCM arg, scm_option options[], int n, const char *s) void -scm_init_opts (SCM (*func) (SCM), scm_option options[], int n) +scm_init_opts (SCM (*func) (SCM), scm_option_t options[], int n) { int i; diff --git a/libguile/options.h b/libguile/options.h index 7b36fc21c..7450b7309 100644 --- a/libguile/options.h +++ b/libguile/options.h @@ -51,7 +51,7 @@ -typedef struct scm_option +typedef struct scm_option_t { int type; char *name; @@ -59,18 +59,22 @@ typedef struct scm_option /* schizophrenic use: both SCM and int */ - unsigned long val; + scm_bits_t val; /* SCM val */ char *doc; -} scm_option; +} scm_option_t; + +#if (SCM_DEBUG_DEPRECATED == 0) +# define scm_option scm_option_t +#endif #define SCM_OPTION_BOOLEAN 0 #define SCM_OPTION_INTEGER 1 #define SCM_OPTION_SCM 2 -extern SCM scm_options (SCM new_mode, scm_option options[], int n, const char *s); -extern void scm_init_opts (SCM (*func) (SCM), scm_option options[], int n); +extern SCM scm_options (SCM new_mode, scm_option_t options[], int n, const char *s); +extern void scm_init_opts (SCM (*func) (SCM), scm_option_t options[], int n); extern void scm_init_options (void); #endif /* OPTIONSH */ diff --git a/libguile/ports.c b/libguile/ports.c index 6a15c2c0b..f49a72dfa 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -86,8 +86,8 @@ * Indexes into this table are used when generating type * tags for smobjects (if you know a tag you can get an index and conversely). */ -scm_ptob_descriptor *scm_ptobs; -int scm_numptob; +scm_ptob_descriptor_t *scm_ptobs; +scm_bits_t scm_numptob; /* GC marker for a port with stream of SCM type. */ SCM @@ -128,10 +128,10 @@ scm_make_port_type (char *name, SCM_DEFER_INTS; SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_ptobs, (1 + scm_numptob) - * sizeof (scm_ptob_descriptor))); + * sizeof (scm_ptob_descriptor_t))); if (tmp) { - scm_ptobs = (scm_ptob_descriptor *) tmp; + scm_ptobs = (scm_ptob_descriptor_t *) tmp; scm_ptobs[scm_numptob].name = name; scm_ptobs[scm_numptob].mark = 0; @@ -171,7 +171,7 @@ scm_set_port_mark (long tc, SCM (*mark) (SCM)) } void -scm_set_port_free (long tc, scm_sizet (*free) (SCM)) +scm_set_port_free (long tc, size_t (*free) (SCM)) { scm_ptobs[SCM_TC2PTOBNUM (tc)].free = free; } @@ -246,7 +246,7 @@ SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0, "interactive port that has no ready characters.}") #define FUNC_NAME s_scm_char_ready_p { - scm_port *pt; + scm_port_t *pt; if (SCM_UNBNDP (port)) port = scm_cur_inp; @@ -264,7 +264,7 @@ SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0, return SCM_BOOL_T; else { - scm_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; + scm_ptob_descriptor_t *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; if (ptob->input_waiting) return SCM_BOOL(ptob->input_waiting (port)); @@ -278,7 +278,7 @@ SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0, into memory starting at dest. returns the number of chars moved. */ size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len) { - scm_port *pt = SCM_PTAB_ENTRY (port); + scm_port_t *pt = SCM_PTAB_ENTRY (port); size_t chars_read = 0; size_t from_buf = min (pt->read_end - pt->read_pos, read_len); @@ -313,8 +313,8 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, #define FUNC_NAME s_scm_drain_input { SCM result; - scm_port *pt = SCM_PTAB_ENTRY (port); - int count; + scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_bits_t count; SCM_VALIDATE_OPINPORT (1,port); @@ -422,32 +422,32 @@ SCM_DEFINE (scm_set_current_error_port, "set-current-error-port", 1, 0, 0, /* The port table --- an array of pointers to ports. */ -scm_port **scm_port_table; +scm_port_t **scm_port_table; -int scm_port_table_size = 0; /* Number of ports in scm_port_table. */ -int scm_port_table_room = 20; /* Size of the array. */ +scm_bits_t scm_port_table_size = 0; /* Number of ports in scm_port_table. */ +scm_bits_t scm_port_table_room = 20; /* Size of the array. */ /* Add a port to the table. */ -scm_port * +scm_port_t * scm_add_to_port_table (SCM port) #define FUNC_NAME "scm_add_to_port_table" { - scm_port *entry; + scm_port_t *entry; if (scm_port_table_size == scm_port_table_room) { /* initial malloc is in gc.c. this doesn't use scm_must_malloc etc., since it can never be freed during gc. */ void *newt = realloc ((char *) scm_port_table, - (scm_sizet) (sizeof (scm_port *) + (size_t) (sizeof (scm_port_t *) * scm_port_table_room * 2)); if (newt == NULL) scm_memory_error ("scm_add_to_port_table"); - scm_port_table = (scm_port **) newt; + scm_port_table = (scm_port_t **) newt; scm_port_table_room *= 2; } - entry = (scm_port *) scm_must_malloc (sizeof (scm_port), FUNC_NAME); + entry = (scm_port_t *) scm_must_malloc (sizeof (scm_port_t), FUNC_NAME); entry->port = port; entry->entry = scm_port_table_size; @@ -474,8 +474,8 @@ void scm_remove_from_port_table (SCM port) #define FUNC_NAME "scm_remove_from_port_table" { - scm_port *p = SCM_PTAB_ENTRY (port); - int i = p->entry; + scm_port_t *p = SCM_PTAB_ENTRY (port); + scm_bits_t i = p->entry; if (i >= scm_port_table_size) SCM_MISC_ERROR ("Port not in table: ~S", SCM_LIST1 (port)); @@ -515,7 +515,7 @@ SCM_DEFINE (scm_pt_member, "pt-member", 1, 0, 0, "@code{--enable-guile-debug} builds.") #define FUNC_NAME s_scm_pt_member { - int i; + scm_bits_t i; SCM_VALIDATE_INUM_COPY (1,index,i); if (i < 0 || i >= scm_port_table_size) return SCM_BOOL_F; @@ -526,7 +526,7 @@ SCM_DEFINE (scm_pt_member, "pt-member", 1, 0, 0, #endif void -scm_port_non_buffer (scm_port *pt) +scm_port_non_buffer (scm_port_t *pt) { pt->read_pos = pt->read_buf = pt->read_end = &pt->shortbuf; pt->write_buf = pt->write_pos = &pt->shortbuf; @@ -649,7 +649,7 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0, "descriptors.") #define FUNC_NAME s_scm_close_port { - scm_sizet i; + size_t i; int rv; port = SCM_COERCE_OUTPORT (port); @@ -709,7 +709,7 @@ SCM_DEFINE (scm_port_for_each, "port-for-each", 1, 0, 0, "have no effect as far as @var{port-for-each} is concerned.\n") #define FUNC_NAME s_scm_port_for_each { - int i; + scm_bits_t i; SCM ports; SCM_VALIDATE_PROC (1, proc); @@ -752,7 +752,7 @@ SCM_DEFINE (scm_close_all_ports_except, "close-all-ports-except", 0, 0, 1, "Use port-for-each instead.") #define FUNC_NAME s_scm_close_all_ports_except { - int i = 0; + scm_bits_t i = 0; SCM_VALIDATE_REST_ARGUMENT (ports); while (i < scm_port_table_size) { @@ -872,7 +872,7 @@ SCM_DEFINE (scm_flush_all_ports, "flush-all-ports", 0, 0, 0, "all open output ports. The return value is unspecified.") #define FUNC_NAME s_scm_flush_all_ports { - int i; + size_t i; for (i = 0; i < scm_port_table_size; i++) { @@ -907,7 +907,7 @@ SCM_DEFINE (scm_read_char, "read-char", 0, 1, 0, int scm_fill_input (SCM port) { - scm_port *pt = SCM_PTAB_ENTRY (port); + scm_port_t *pt = SCM_PTAB_ENTRY (port); if (pt->read_buf == pt->putback_buf) { @@ -926,7 +926,7 @@ int scm_getc (SCM port) { int c; - scm_port *pt = SCM_PTAB_ENTRY (port); + scm_port_t *pt = SCM_PTAB_ENTRY (port); if (pt->rw_active == SCM_PORT_WRITE) { @@ -982,10 +982,10 @@ scm_puts (const char *s, SCM port) */ void -scm_lfwrite (const char *ptr, scm_sizet size, SCM port) +scm_lfwrite (const char *ptr, size_t size, SCM port) { - scm_port *pt = SCM_PTAB_ENTRY (port); - scm_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; + scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_ptob_descriptor_t *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; if (pt->rw_active == SCM_PORT_READ) scm_end_input (port); @@ -1004,11 +1004,11 @@ scm_lfwrite (const char *ptr, scm_sizet size, SCM port) * * Warning: Doesn't update port line and column counts! */ -scm_sizet -scm_c_read (SCM port, void *buffer, scm_sizet size) +size_t +scm_c_read (SCM port, void *buffer, size_t size) { - scm_port *pt = SCM_PTAB_ENTRY (port); - scm_sizet n_read = 0, n_available; + scm_port_t *pt = SCM_PTAB_ENTRY (port); + size_t n_read = 0, n_available; if (pt->rw_active == SCM_PORT_WRITE) scm_ptobs[SCM_PTOBNUM (port)].flush (port); @@ -1058,10 +1058,10 @@ scm_c_read (SCM port, void *buffer, scm_sizet size) */ void -scm_c_write (SCM port, const void *ptr, scm_sizet size) +scm_c_write (SCM port, const void *ptr, size_t size) { - scm_port *pt = SCM_PTAB_ENTRY (port); - scm_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; + scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_ptob_descriptor_t *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; if (pt->rw_active == SCM_PORT_READ) scm_end_input (port); @@ -1075,15 +1075,15 @@ scm_c_write (SCM port, const void *ptr, scm_sizet size) void scm_flush (SCM port) { - scm_sizet i = SCM_PTOBNUM (port); + scm_bits_t i = SCM_PTOBNUM (port); (scm_ptobs[i].flush) (port); } void scm_end_input (SCM port) { - int offset; - scm_port *pt = SCM_PTAB_ENTRY (port); + scm_bits_t offset; + scm_port_t *pt = SCM_PTAB_ENTRY (port); if (pt->read_buf == pt->putback_buf) { @@ -1106,7 +1106,7 @@ void scm_ungetc (int c, SCM port) #define FUNC_NAME "scm_ungetc" { - scm_port *pt = SCM_PTAB_ENTRY (port); + scm_port_t *pt = SCM_PTAB_ENTRY (port); if (pt->read_buf == pt->putback_buf) /* already using the put-back buffer. */ @@ -1115,7 +1115,7 @@ scm_ungetc (int c, SCM port) if (pt->read_end == pt->read_buf + pt->read_buf_size && pt->read_buf == pt->read_pos) { - int new_size = pt->read_buf_size * 2; + size_t new_size = pt->read_buf_size * 2; unsigned char *tmp = (unsigned char *) scm_must_realloc (pt->putback_buf, pt->read_buf_size, new_size, FUNC_NAME); @@ -1302,7 +1302,7 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, SCM_OUT_OF_RANGE (3, whence); if (SCM_OPPORTP (fd_port)) { - scm_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (fd_port); + scm_ptob_descriptor_t *ptob = scm_ptobs + SCM_PTOBNUM (fd_port); if (!ptob->seek) SCM_MISC_ERROR ("port is not seekable", @@ -1355,8 +1355,8 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, } else if (SCM_OPOUTPORTP (object)) { - scm_port *pt = SCM_PTAB_ENTRY (object); - scm_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (object); + scm_port_t *pt = SCM_PTAB_ENTRY (object); + scm_ptob_descriptor_t *ptob = scm_ptobs + SCM_PTOBNUM (object); if (!ptob->truncate) SCM_MISC_ERROR ("port is not truncatable", SCM_EOL); @@ -1505,7 +1505,7 @@ void scm_ports_prehistory () { scm_numptob = 0; - scm_ptobs = (scm_ptob_descriptor *) malloc (sizeof (scm_ptob_descriptor)); + scm_ptobs = (scm_ptob_descriptor_t *) malloc (sizeof (scm_ptob_descriptor_t)); } @@ -1529,7 +1529,7 @@ scm_void_port (char *mode_str) { int mode_bits; SCM answer; - scm_port * pt; + scm_port_t * pt; SCM_NEWCELL (answer); SCM_DEFER_INTS; diff --git a/libguile/ports.h b/libguile/ports.h index b37634f9b..fa9198415 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -59,18 +59,18 @@ #define SCM_INITIAL_PUTBACK_BUF_SIZE 4 /* values for the rw_active flag. */ -enum scm_port_rw_active { +typedef enum scm_port_rw_active_t { SCM_PORT_NEITHER = 0, SCM_PORT_READ = 1, SCM_PORT_WRITE = 2 -}; +} scm_port_rw_active_t; /* C representation of a Scheme port. */ typedef struct { SCM port; /* Link back to the port object. */ - int entry; /* Index in port table. */ + scm_bits_t entry; /* Index in port table. */ int revealed; /* 0 not revealed, > 1 revealed. * Revealed ports do not get GC'd. */ @@ -78,7 +78,7 @@ typedef struct scm_bits_t stream; SCM file_name; /* debugging support. */ - int line_number; /* debugging support. */ + long line_number; /* debugging support. */ int column_number; /* debugging support. */ /* port buffers. the buffer(s) are set up for all ports. @@ -120,20 +120,20 @@ typedef struct flushed before switching between reading and writing, seeking, etc. */ - enum scm_port_rw_active rw_active; /* for random access ports, - indicates which of the buffers - is currently in use. can be - SCM_PORT_WRITE, SCM_PORT_READ, - or SCM_PORT_NEITHER. */ + scm_port_rw_active_t rw_active; /* for random access ports, + indicates which of the buffers + is currently in use. can be + SCM_PORT_WRITE, SCM_PORT_READ, + or SCM_PORT_NEITHER. */ /* a buffer for un-read chars and strings. */ unsigned char *putback_buf; - int putback_buf_size; /* allocated size of putback_buf. */ -} scm_port; + size_t putback_buf_size; /* allocated size of putback_buf. */ +} scm_port_t; -extern scm_port **scm_port_table; -extern int scm_port_table_size; /* Number of ports in scm_port_table. */ +extern scm_port_t **scm_port_table; +extern scm_bits_t scm_port_table_size; /* Number of ports in scm_port_table. */ #define SCM_READ_BUFFER_EMPTY_P(c_port) (c_port->read_pos >= c_port->read_end) @@ -167,7 +167,7 @@ extern int scm_port_table_size; /* Number of ports in scm_port_table. */ #define SCM_CLR_PORT_OPEN_FLAG(p) \ SCM_SET_CELL_WORD_0 ((p), SCM_CELL_WORD_0 (p) & ~SCM_OPN) -#define SCM_PTAB_ENTRY(x) ((scm_port *) SCM_CELL_WORD_1 (x)) +#define SCM_PTAB_ENTRY(x) ((scm_port_t *) SCM_CELL_WORD_1 (x)) #define SCM_SETPTAB_ENTRY(x,ent) (SCM_SET_CELL_WORD_1 ((x), (scm_bits_t) (ent))) #define SCM_STREAM(x) (SCM_PTAB_ENTRY(x)->stream) #define SCM_SETSTREAM(x,s) (SCM_PTAB_ENTRY(x)->stream = (scm_bits_t) (s)) @@ -185,11 +185,11 @@ extern int scm_port_table_size; /* Number of ports in scm_port_table. */ /* port-type description. */ -typedef struct scm_ptob_descriptor +typedef struct scm_ptob_descriptor_t { char *name; SCM (*mark) (SCM); - scm_sizet (*free) (SCM); + size_t (*free) (SCM); int (*print) (SCM exp, SCM port, scm_print_state *pstate); SCM (*equalp) (SCM, SCM); int (*close) (SCM port); @@ -204,7 +204,13 @@ typedef struct scm_ptob_descriptor off_t (*seek) (SCM port, off_t OFFSET, int WHENCE); void (*truncate) (SCM port, off_t length); -} scm_ptob_descriptor; +} scm_ptob_descriptor_t; + +#if (SCM_DEBUG_DEPRECATED == 0) +# define scm_port scm_port_t +# define scm_ptob_descriptor scm_ptob_descriptor_t +# define scm_port_rw_active scm_port_rw_active_t +#endif #define SCM_TC2PTOBNUM(x) (0x0ff & ((x) >> 8)) #define SCM_PTOBNUM(x) (SCM_TC2PTOBNUM (SCM_CELL_TYPE (x))) @@ -213,9 +219,9 @@ typedef struct scm_ptob_descriptor -extern scm_ptob_descriptor *scm_ptobs; -extern int scm_numptob; -extern int scm_port_table_room; +extern scm_ptob_descriptor_t *scm_ptobs; +extern scm_bits_t scm_numptob; +extern scm_bits_t scm_port_table_room; @@ -226,7 +232,7 @@ extern scm_bits_t scm_make_port_type (char *name, const void *data, size_t size)); extern void scm_set_port_mark (long tc, SCM (*mark) (SCM)); -extern void scm_set_port_free (long tc, scm_sizet (*free) (SCM)); +extern void scm_set_port_free (long tc, size_t (*free) (SCM)); extern void scm_set_port_print (long tc, int (*print) (SCM exp, SCM port, @@ -257,12 +263,12 @@ extern SCM scm_current_load_port (void); extern SCM scm_set_current_input_port (SCM port); extern SCM scm_set_current_output_port (SCM port); extern SCM scm_set_current_error_port (SCM port); -extern scm_port * scm_add_to_port_table (SCM port); +extern scm_port_t * scm_add_to_port_table (SCM port); extern void scm_remove_from_port_table (SCM port); extern void scm_grow_port_cbuf (SCM port, size_t requested); extern SCM scm_pt_size (void); extern SCM scm_pt_member (SCM member); -extern void scm_port_non_buffer (scm_port *pt); +extern void scm_port_non_buffer (scm_port_t *pt); extern int scm_revealed_count (SCM port); extern SCM scm_port_revealed (SCM port); extern SCM scm_set_port_revealed_x (SCM port, SCM rcount); @@ -282,9 +288,9 @@ extern SCM scm_flush_all_ports (void); extern SCM scm_read_char (SCM port); extern void scm_putc (char c, SCM port); extern void scm_puts (const char *str_data, SCM port); -extern scm_sizet scm_c_read (SCM port, void *buffer, scm_sizet size); -extern void scm_c_write (SCM port, const void *buffer, scm_sizet size); -extern void scm_lfwrite (const char *ptr, scm_sizet size, SCM port); +extern size_t scm_c_read (SCM port, void *buffer, size_t size); +extern void scm_c_write (SCM port, const void *buffer, size_t size); +extern void scm_lfwrite (const char *ptr, size_t size, SCM port); extern void scm_flush (SCM port); extern void scm_end_input (SCM port); extern int scm_fill_input (SCM port); diff --git a/libguile/posix.c b/libguile/posix.c index 6f8c11e0a..83e8bac10 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -224,7 +224,7 @@ SCM_DEFINE (scm_getgroups, "getgroups", 0, 0, 0, { SCM ans; int ngroups; - scm_sizet size; + size_t size; GETGROUPS_T *groups; ngroups = getgroups (0, NULL); @@ -831,7 +831,7 @@ scm_convert_exec_args (SCM args, int argn, const char *subr) for (i = 0; !SCM_NULLP (args); args = SCM_CDR (args), ++i) { SCM arg = SCM_CAR (args); - scm_sizet len; + size_t len; char *dst; char *src; diff --git a/libguile/print.c b/libguile/print.c index dca8d84df..7e08fe49a 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -127,7 +127,7 @@ char *scm_isymnames[] = "#" }; -scm_option scm_print_opts[] = { +scm_option_t scm_print_opts[] = { { SCM_OPTION_SCM, "closure-hook", SCM_UNPACK (SCM_BOOL_F), "Hook for printing closures (should handle macros as well)." }, { SCM_OPTION_BOOLEAN, "source", 0, @@ -282,8 +282,8 @@ grow_ref_stack (scm_print_state *pstate) static void print_circref (SCM port,scm_print_state *pstate,SCM ref) { - register int i; - int self = pstate->top - 1; + register scm_bits_t i; + scm_bits_t self = pstate->top - 1; i = pstate->top - 1; if (SCM_CONSP (pstate->ref_stack[i])) { @@ -358,9 +358,9 @@ taloop: else if (SCM_ILOCP (exp)) { scm_puts ("#@", port); - scm_intprint (SCM_IFRAME (exp), 10, port); + scm_intprint ((long) SCM_IFRAME (exp), 10, port); scm_putc (SCM_ICDRP (exp) ? '-' : '+', port); - scm_intprint (SCM_IDIST (exp), 10, port); + scm_intprint ((long) SCM_IDIST (exp), 10, port); } else { @@ -438,7 +438,7 @@ taloop: case scm_tc7_string: if (SCM_WRITINGP (pstate)) { - scm_sizet i; + size_t i; scm_putc ('"', port); for (i = 0; i < SCM_STRING_LENGTH (exp); ++i) @@ -458,13 +458,13 @@ taloop: break; case scm_tc7_symbol: { - int pos; - int end; - int len; + size_t pos; + size_t end; + size_t len; char * str; int weird; int maybe_weird; - int mw_pos = 0; + size_t mw_pos = 0; len = SCM_SYMBOL_LENGTH (exp); str = SCM_SYMBOL_CHARS (exp); @@ -548,8 +548,8 @@ taloop: scm_puts ("#(", port); common_vector_printer: { - register long i; - int last = SCM_VECTOR_LENGTH (exp) - 1; + register scm_bits_t i; + scm_bits_t last = SCM_VECTOR_LENGTH (exp) - 1; int cutp = 0; if (pstate->fancyp && SCM_VECTOR_LENGTH (exp) > pstate->length) { @@ -749,7 +749,7 @@ void scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate) { register SCM hare, tortoise; - int floor = pstate->top - 2; + scm_bits_t floor = pstate->top - 2; scm_puts (hdr, port); /* CHECK_INTS; */ if (pstate->fancyp) @@ -774,7 +774,7 @@ scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate) scm_iprin1 (SCM_CAR (exp), port, pstate); for (exp = SCM_CDR (exp); SCM_ECONSP (exp); exp = SCM_CDR (exp)) { - register int i; + register scm_bits_t i; for (i = floor; i >= 0; --i) if (SCM_EQ_P (pstate->ref_stack[i], exp)) @@ -797,13 +797,13 @@ end: fancy_printing: { - int n = pstate->length; + scm_bits_t n = pstate->length; scm_iprin1 (SCM_CAR (exp), port, pstate); exp = SCM_CDR (exp); --n; for (; SCM_ECONSP (exp); exp = SCM_CDR (exp)) { - register unsigned long i; + register scm_ubits_t i; for (i = 0; i < pstate->top; ++i) if (SCM_EQ_P (pstate->ref_stack[i], exp)) diff --git a/libguile/print.h b/libguile/print.h index 25c1dbe0f..25fa3d5db 100644 --- a/libguile/print.h +++ b/libguile/print.h @@ -51,7 +51,7 @@ #include "libguile/options.h" -extern scm_option scm_print_opts[]; +extern scm_option_t scm_print_opts[]; #define SCM_PRINT_CLOSURE (SCM_PACK (scm_print_opts[0].val)) #define SCM_PRINT_SOURCE_P ((int) scm_print_opts[1].val) diff --git a/libguile/procs.c b/libguile/procs.c index 735a76c26..85e9abd08 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -60,29 +60,29 @@ /* {Procedures} */ -scm_subr_entry *scm_subr_table; +scm_subr_entry_t *scm_subr_table; /* libguile contained approx. 700 primitive procedures on 24 Aug 1999. */ /* Increased to 800 on 2001-05-07 -- Guile now has 779 primitives on startup, 786 with guile-readline. 'martin */ -int scm_subr_table_size = 0; -int scm_subr_table_room = 800; +scm_bits_t scm_subr_table_size = 0; +scm_bits_t scm_subr_table_room = 800; SCM -scm_c_make_subr (const char *name, int type, SCM (*fcn) ()) +scm_c_make_subr (const char *name, scm_bits_t type, SCM (*fcn) ()) { register SCM z; - int entry; + scm_bits_t entry; if (scm_subr_table_size == scm_subr_table_room) { - scm_sizet new_size = scm_subr_table_room * 3 / 2; + scm_bits_t new_size = scm_subr_table_room * 3 / 2; void *new_table = scm_must_realloc ((char *) scm_subr_table, - sizeof (scm_subr_entry) * scm_subr_table_room, - sizeof (scm_subr_entry) * new_size, + sizeof (scm_subr_entry_t) * scm_subr_table_room, + sizeof (scm_subr_entry_t) * new_size, "scm_subr_table"); scm_subr_table = new_table; scm_subr_table_room = new_size; @@ -104,7 +104,7 @@ scm_c_make_subr (const char *name, int type, SCM (*fcn) ()) } SCM -scm_c_define_subr (const char *name, int type, SCM (*fcn) ()) +scm_c_define_subr (const char *name, scm_bits_t type, SCM (*fcn) ()) { SCM subr = scm_c_make_subr (name, type, fcn); scm_define (SCM_SUBR_ENTRY(subr).name, subr); @@ -116,7 +116,7 @@ scm_c_define_subr (const char *name, int type, SCM (*fcn) ()) void scm_free_subr_entry (SCM subr) { - int entry = SCM_SUBRNUM (subr); + scm_bits_t entry = SCM_SUBRNUM (subr); /* Move last entry in table to the free position */ scm_subr_table[entry] = scm_subr_table[scm_subr_table_size - 1]; SCM_SET_SUBRNUM (scm_subr_table[entry].handle, entry); @@ -125,7 +125,7 @@ scm_free_subr_entry (SCM subr) SCM scm_c_make_subr_with_generic (const char *name, - int type, SCM (*fcn) (), SCM *gf) + scm_bits_t type, SCM (*fcn) (), SCM *gf) { SCM subr = scm_c_make_subr (name, type, fcn); SCM_SUBR_ENTRY(subr).generic = gf; @@ -134,7 +134,7 @@ scm_c_make_subr_with_generic (const char *name, SCM scm_c_define_subr_with_generic (const char *name, - int type, SCM (*fcn) (), SCM *gf) + scm_bits_t type, SCM (*fcn) (), SCM *gf) { SCM subr = scm_c_make_subr_with_generic (name, type, fcn, gf); scm_define (SCM_SUBR_ENTRY(subr).name, subr); @@ -144,7 +144,7 @@ scm_c_define_subr_with_generic (const char *name, void scm_mark_subr_table () { - int i; + scm_bits_t i; for (i = 0; i < scm_subr_table_size; ++i) { SCM_SETGCMARK (scm_subr_table[i].name); @@ -158,7 +158,7 @@ scm_mark_subr_table () #ifdef CCLO SCM -scm_makcclo (SCM proc, long len) +scm_makcclo (SCM proc, size_t len) { scm_bits_t *base = scm_must_malloc (len * sizeof (scm_bits_t), "compiled-closure"); unsigned long i; @@ -390,8 +390,8 @@ void scm_init_subr_table () { scm_subr_table - = ((scm_subr_entry *) - scm_must_malloc (sizeof (scm_subr_entry) * scm_subr_table_room, + = ((scm_subr_entry_t *) + scm_must_malloc (sizeof (scm_subr_entry_t) * scm_subr_table_room, "scm_subr_table")); } diff --git a/libguile/procs.h b/libguile/procs.h index 9b8af9138..acb2bc94f 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -63,7 +63,11 @@ typedef struct * *generic == 0 until first method */ SCM properties; /* procedure properties */ -} scm_subr_entry; +} scm_subr_entry_t; + +#if (SCM_DEBUG_DEPRECATED == 0) +# define scm_subr_entry scm_subr_entry_t +#endif #define SCM_SUBRNUM(subr) (SCM_CELL_WORD_0 (subr) >> 8) #define SCM_SET_SUBRNUM(subr, num) \ @@ -153,21 +157,21 @@ typedef struct #define SCM_PROCEDURE(obj) SCM_CELL_OBJECT_1 (obj) #define SCM_SETTER(obj) SCM_CELL_OBJECT_2 (obj) -extern scm_subr_entry *scm_subr_table; -extern int scm_subr_table_size; -extern int scm_subr_table_room; +extern scm_subr_entry_t *scm_subr_table; +extern scm_bits_t scm_subr_table_size; +extern scm_bits_t scm_subr_table_room; extern void scm_mark_subr_table (void); extern void scm_free_subr_entry (SCM subr); -extern SCM scm_c_make_subr (const char *name, int type, SCM (*fcn)()); -extern SCM scm_c_make_subr_with_generic (const char *name, int type, +extern SCM scm_c_make_subr (const char *name, scm_bits_t type, SCM (*fcn)()); +extern SCM scm_c_make_subr_with_generic (const char *name, scm_bits_t type, SCM (*fcn)(), SCM *gf); -extern SCM scm_c_define_subr (const char *name, int type, SCM (*fcn)()); -extern SCM scm_c_define_subr_with_generic (const char *name, int type, +extern SCM scm_c_define_subr (const char *name, scm_bits_t type, SCM (*fcn)()); +extern SCM scm_c_define_subr_with_generic (const char *name, scm_bits_t type, SCM (*fcn)(), SCM *gf); -extern SCM scm_makcclo (SCM proc, long len); +extern SCM scm_makcclo (SCM proc, size_t len); extern SCM scm_procedure_p (SCM obj); extern SCM scm_closure_p (SCM obj); extern SCM scm_thunk_p (SCM obj); diff --git a/libguile/ramap.c b/libguile/ramap.c index 023cd5ad5..3970f6191 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -166,12 +166,12 @@ do { type (*v0)[2] = (type (*)[2]) SCM_VELTS (ra0);\ break;\ } while (0) -static scm_sizet +static scm_bits_t cind (SCM ra, SCM inds) { - scm_sizet i; + scm_bits_t i; int k; - long *ve = (long*) SCM_VELTS (inds); + scm_bits_t *ve = (scm_bits_t *) SCM_VELTS (inds); if (!SCM_ARRAYP (ra)) return *ve; i = SCM_ARRAY_BASE (ra); @@ -193,10 +193,10 @@ int scm_ra_matchp (SCM ra0, SCM ras) { SCM ra1; - scm_array_dim dims; - scm_array_dim *s0 = &dims; - scm_array_dim *s1; - scm_sizet bas0 = 0; + scm_array_dim_t dims; + scm_array_dim_t *s0 = &dims; + scm_array_dim_t *s1; + scm_bits_t bas0 = 0; int i, ndim = 1; int exact = 2 /* 4 */ ; /* Don't care about values >2 (yet?) */ if (SCM_IMP (ra0)) return 0; @@ -255,7 +255,7 @@ scm_ra_matchp (SCM ra0, SCM ras) case scm_tc7_dvect: case scm_tc7_cvect: { - unsigned long int length; + scm_bits_t length; if (1 != ndim) return 0; @@ -322,7 +322,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) SCM inds, z; SCM vra0, ra1, vra1; SCM lvra, *plvra; - long *vinds; + scm_bits_t *vinds; int k, kmax; switch (scm_ra_matchp (ra0, lra)) { @@ -339,7 +339,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) if (SCM_IMP (vra0)) goto gencase; if (!SCM_ARRAYP (vra0)) { - unsigned long int length = SCM_INUM (scm_uniform_vector_length (vra0)); + scm_bits_t length = SCM_INUM (scm_uniform_vector_length (vra0)); vra1 = scm_make_ra (1); SCM_ARRAY_BASE (vra1) = 0; SCM_ARRAY_DIMS (vra1)->lbnd = 0; @@ -397,7 +397,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) } else { - unsigned long int length = SCM_INUM (scm_uniform_vector_length (ra0)); + scm_bits_t length = SCM_INUM (scm_uniform_vector_length (ra0)); kmax = 0; SCM_ARRAY_DIMS (vra0)->lbnd = 0; SCM_ARRAY_DIMS (vra0)->ubnd = length - 1; @@ -429,7 +429,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) plvra = SCM_CDRLOC (*plvra); } inds = scm_make_uve (SCM_ARRAY_NDIM (ra0), SCM_MAKINUM (-1L)); - vinds = (long *) SCM_VELTS (inds); + vinds = (scm_bits_t *) SCM_VELTS (inds); for (k = 0; k <= kmax; k++) vinds[k] = SCM_ARRAY_DIMS (ra0)[k].lbnd; k = kmax; @@ -478,10 +478,10 @@ int scm_array_fill_int (SCM ra, SCM fill, SCM ignore) #define FUNC_NAME s_scm_array_fill_x { - scm_sizet i; - scm_sizet n = SCM_ARRAY_DIMS (ra)->ubnd - SCM_ARRAY_DIMS (ra)->lbnd + 1; - long inc = SCM_ARRAY_DIMS (ra)->inc; - scm_sizet base = SCM_ARRAY_BASE (ra); + scm_bits_t i; + scm_bits_t n = SCM_ARRAY_DIMS (ra)->ubnd - SCM_ARRAY_DIMS (ra)->lbnd + 1; + scm_bits_t inc = SCM_ARRAY_DIMS (ra)->inc; + scm_bits_t base = SCM_ARRAY_BASE (ra); ra = SCM_ARRAY_V (ra); switch SCM_TYP7 (ra) @@ -511,27 +511,27 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore) break; case scm_tc7_bvect: { /* scope */ - long *ve = (long *) SCM_VELTS (ra); - if (1 == inc && (n >= SCM_LONG_BIT || n == SCM_BITVECTOR_LENGTH (ra))) + scm_bits_t *ve = (scm_bits_t *) SCM_VELTS (ra); + if (1 == inc && (n >= SCM_BITS_LENGTH || n == SCM_BITVECTOR_LENGTH (ra))) { - i = base / SCM_LONG_BIT; + i = base / SCM_BITS_LENGTH; if (SCM_FALSEP (fill)) { - if (base % SCM_LONG_BIT) /* leading partial word */ - ve[i++] &= ~(~0L << (base % SCM_LONG_BIT)); - for (; i < (base + n) / SCM_LONG_BIT; i++) + if (base % SCM_BITS_LENGTH) /* leading partial word */ + ve[i++] &= ~(~0L << (base % SCM_BITS_LENGTH)); + for (; i < (base + n) / SCM_BITS_LENGTH; i++) ve[i] = 0L; - if ((base + n) % SCM_LONG_BIT) /* trailing partial word */ - ve[i] &= (~0L << ((base + n) % SCM_LONG_BIT)); + if ((base + n) % SCM_BITS_LENGTH) /* trailing partial word */ + ve[i] &= (~0L << ((base + n) % SCM_BITS_LENGTH)); } else if (SCM_EQ_P (fill, SCM_BOOL_T)) { - if (base % SCM_LONG_BIT) - ve[i++] |= ~0L << (base % SCM_LONG_BIT); - for (; i < (base + n) / SCM_LONG_BIT; i++) + if (base % SCM_BITS_LENGTH) + ve[i++] |= ~0L << (base % SCM_BITS_LENGTH); + for (; i < (base + n) / SCM_BITS_LENGTH; i++) ve[i] = ~0L; - if ((base + n) % SCM_LONG_BIT) - ve[i] |= ~(~0L << ((base + n) % SCM_LONG_BIT)); + if ((base + n) % SCM_BITS_LENGTH) + ve[i] |= ~(~0L << ((base + n) % SCM_BITS_LENGTH)); } else badarg2:SCM_WRONG_TYPE_ARG (2, fill); @@ -540,10 +540,10 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore) { if (SCM_FALSEP (fill)) for (i = base; n--; i += inc) - ve[i / SCM_LONG_BIT] &= ~(1L << (i % SCM_LONG_BIT)); + ve[i / SCM_BITS_LENGTH] &= ~(1L << (i % SCM_BITS_LENGTH)); else if (SCM_EQ_P (fill, SCM_BOOL_T)) for (i = base; n--; i += inc) - ve[i / SCM_LONG_BIT] |= (1L << (i % SCM_LONG_BIT)); + ve[i / SCM_BITS_LENGTH] |= (1L << (i % SCM_BITS_LENGTH)); else goto badarg2; } @@ -637,9 +637,9 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore) static int racp (SCM src, SCM dst) { - long n = (SCM_ARRAY_DIMS (src)->ubnd - SCM_ARRAY_DIMS (src)->lbnd + 1); - long inc_d, inc_s = SCM_ARRAY_DIMS (src)->inc; - scm_sizet i_d, i_s = SCM_ARRAY_BASE (src); + scm_bits_t n = (SCM_ARRAY_DIMS (src)->ubnd - SCM_ARRAY_DIMS (src)->lbnd + 1); + scm_bits_t inc_d, inc_s = SCM_ARRAY_DIMS (src)->inc; + scm_bits_t i_d, i_s = SCM_ARRAY_BASE (src); dst = SCM_CAR (dst); inc_d = SCM_ARRAY_DIMS (dst)->inc; i_d = SCM_ARRAY_BASE (dst); @@ -674,21 +674,22 @@ racp (SCM src, SCM dst) case scm_tc7_bvect: if (SCM_TYP7 (src) != scm_tc7_bvect) goto gencase; - if (1 == inc_d && 1 == inc_s && i_s % SCM_LONG_BIT == i_d % SCM_LONG_BIT && n >= SCM_LONG_BIT) + if (1 == inc_d && 1 == inc_s && i_s % SCM_BITS_LENGTH == i_d % SCM_BITS_LENGTH + && n >= SCM_BITS_LENGTH) { - long *sv = (long *) SCM_VELTS (src); - long *dv = (long *) SCM_VELTS (dst); - sv += i_s / SCM_LONG_BIT; - dv += i_d / SCM_LONG_BIT; - if (i_s % SCM_LONG_BIT) + scm_bits_t *sv = (scm_bits_t *) SCM_VELTS (src); + scm_bits_t *dv = (scm_bits_t *) SCM_VELTS (dst); + sv += i_s / SCM_BITS_LENGTH; + dv += i_d / SCM_BITS_LENGTH; + if (i_s % SCM_BITS_LENGTH) { /* leading partial word */ - *dv = (*dv & ~(~0L << (i_s % SCM_LONG_BIT))) | (*sv & (~0L << (i_s % SCM_LONG_BIT))); + *dv = (*dv & ~(~0L << (i_s % SCM_BITS_LENGTH))) | (*sv & (~0L << (i_s % SCM_BITS_LENGTH))); dv++; sv++; - n -= SCM_LONG_BIT - (i_s % SCM_LONG_BIT); + n -= SCM_BITS_LENGTH - (i_s % SCM_BITS_LENGTH); } IVDEP (src != dst, - for (; n >= SCM_LONG_BIT; n -= SCM_LONG_BIT, sv++, dv++) + for (; n >= SCM_BITS_LENGTH; n -= SCM_BITS_LENGTH, sv++, dv++) *dv = *sv;) if (n) /* trailing partial word */ *dv = (*dv & (~0L << n)) | (*sv & ~(~0L << n)); @@ -853,11 +854,11 @@ int scm_ra_eqp (SCM ra0, SCM ras) { SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras)); - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; - long inc2 = SCM_ARRAY_DIMS (ra1)->inc; + scm_bits_t n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; + scm_bits_t i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2); + scm_bits_t inc0 = SCM_ARRAY_DIMS (ra0)->inc; + scm_bits_t inc1 = SCM_ARRAY_DIMS (ra1)->inc; + scm_bits_t inc2 = SCM_ARRAY_DIMS (ra1)->inc; ra0 = SCM_ARRAY_V (ra0); ra1 = SCM_ARRAY_V (ra1); ra2 = SCM_ARRAY_V (ra2); @@ -912,11 +913,11 @@ scm_ra_eqp (SCM ra0, SCM ras) static int ra_compare (SCM ra0,SCM ra1,SCM ra2,int opt) { - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; - long inc2 = SCM_ARRAY_DIMS (ra1)->inc; + scm_bits_t n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; + scm_bits_t i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2); + scm_bits_t inc0 = SCM_ARRAY_DIMS (ra0)->inc; + scm_bits_t inc1 = SCM_ARRAY_DIMS (ra1)->inc; + scm_bits_t inc2 = SCM_ARRAY_DIMS (ra1)->inc; ra0 = SCM_ARRAY_V (ra0); ra1 = SCM_ARRAY_V (ra1); ra2 = SCM_ARRAY_V (ra2); @@ -1006,15 +1007,15 @@ scm_ra_greqp (SCM ra0, SCM ras) int scm_ra_sum (SCM ra0, SCM ras) { - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; + scm_bits_t n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; + scm_bits_t i0 = SCM_ARRAY_BASE (ra0); + scm_bits_t inc0 = SCM_ARRAY_DIMS (ra0)->inc; ra0 = SCM_ARRAY_V (ra0); if (SCM_NNULLP(ras)) { SCM ra1 = SCM_CAR (ras); - scm_sizet i1 = SCM_ARRAY_BASE (ra1); - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; + scm_bits_t i1 = SCM_ARRAY_BASE (ra1); + scm_bits_t inc1 = SCM_ARRAY_DIMS (ra1)->inc; ra1 = SCM_ARRAY_V (ra1); switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) { @@ -1045,9 +1046,9 @@ scm_ra_sum (SCM ra0, SCM ras) int scm_ra_difference (SCM ra0, SCM ras) { - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; + scm_bits_t n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; + scm_bits_t i0 = SCM_ARRAY_BASE (ra0); + scm_bits_t inc0 = SCM_ARRAY_DIMS (ra0)->inc; ra0 = SCM_ARRAY_V (ra0); if (SCM_NULLP (ras)) { @@ -1073,8 +1074,8 @@ scm_ra_difference (SCM ra0, SCM ras) else { SCM ra1 = SCM_CAR (ras); - scm_sizet i1 = SCM_ARRAY_BASE (ra1); - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; + scm_bits_t i1 = SCM_ARRAY_BASE (ra1); + scm_bits_t inc1 = SCM_ARRAY_DIMS (ra1)->inc; ra1 = SCM_ARRAY_V (ra1); switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) { @@ -1101,15 +1102,15 @@ scm_ra_difference (SCM ra0, SCM ras) int scm_ra_product (SCM ra0, SCM ras) { - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; + scm_bits_t n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; + scm_bits_t i0 = SCM_ARRAY_BASE (ra0); + scm_bits_t inc0 = SCM_ARRAY_DIMS (ra0)->inc; ra0 = SCM_ARRAY_V (ra0); if (SCM_NNULLP (ras)) { SCM ra1 = SCM_CAR (ras); - scm_sizet i1 = SCM_ARRAY_BASE (ra1); - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; + scm_bits_t i1 = SCM_ARRAY_BASE (ra1); + scm_bits_t inc1 = SCM_ARRAY_DIMS (ra1)->inc; ra1 = SCM_ARRAY_V (ra1); switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) { @@ -1152,9 +1153,9 @@ scm_ra_product (SCM ra0, SCM ras) int scm_ra_divide (SCM ra0, SCM ras) { - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; + scm_bits_t n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; + scm_bits_t i0 = SCM_ARRAY_BASE (ra0); + scm_bits_t inc0 = SCM_ARRAY_DIMS (ra0)->inc; ra0 = SCM_ARRAY_V (ra0); if (SCM_NULLP (ras)) { @@ -1188,8 +1189,8 @@ scm_ra_divide (SCM ra0, SCM ras) else { SCM ra1 = SCM_CAR (ras); - scm_sizet i1 = SCM_ARRAY_BASE (ra1); - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; + scm_bits_t i1 = SCM_ARRAY_BASE (ra1); + scm_bits_t inc1 = SCM_ARRAY_DIMS (ra1)->inc; ra1 = SCM_ARRAY_V (ra1); switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) { @@ -1237,10 +1238,10 @@ scm_array_identity (SCM dst, SCM src) static int ramap (SCM ra0,SCM proc,SCM ras) { - long i = SCM_ARRAY_DIMS (ra0)->lbnd; - long inc = SCM_ARRAY_DIMS (ra0)->inc; - long n = SCM_ARRAY_DIMS (ra0)->ubnd; - long base = SCM_ARRAY_BASE (ra0) - i * inc; + scm_bits_t i = SCM_ARRAY_DIMS (ra0)->lbnd; + scm_bits_t inc = SCM_ARRAY_DIMS (ra0)->inc; + scm_bits_t n = SCM_ARRAY_DIMS (ra0)->ubnd; + scm_bits_t base = SCM_ARRAY_BASE (ra0) - i * inc; ra0 = SCM_ARRAY_V (ra0); if (SCM_NULLP (ras)) for (; i <= n; i++) @@ -1249,8 +1250,8 @@ ramap (SCM ra0,SCM proc,SCM ras) { SCM ra1 = SCM_CAR (ras); SCM args, *ve = &ras; - scm_sizet k, i1 = SCM_ARRAY_BASE (ra1); - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; + scm_bits_t k, i1 = SCM_ARRAY_BASE (ra1); + scm_bits_t inc1 = SCM_ARRAY_DIMS (ra1)->inc; ra1 = SCM_ARRAY_V (ra1); ras = SCM_CDR (ras); if (SCM_NULLP(ras)) @@ -1278,9 +1279,9 @@ ramap_cxr (SCM ra0,SCM proc,SCM ras) { SCM ra1 = SCM_CAR (ras); SCM e1 = SCM_UNDEFINED; - scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc; - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra1)->lbnd + 1; + scm_bits_t i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1); + scm_bits_t inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc; + scm_bits_t n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra1)->lbnd + 1; ra0 = SCM_ARRAY_V (ra0); ra1 = SCM_ARRAY_V (ra1); switch (SCM_TYP7 (ra0)) @@ -1339,11 +1340,11 @@ ramap_rp (SCM ra0,SCM proc,SCM ras) { SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras)); SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED; - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; - long inc2 = SCM_ARRAY_DIMS (ra1)->inc; + scm_bits_t n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; + scm_bits_t i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2); + scm_bits_t inc0 = SCM_ARRAY_DIMS (ra0)->inc; + scm_bits_t inc1 = SCM_ARRAY_DIMS (ra1)->inc; + scm_bits_t inc2 = SCM_ARRAY_DIMS (ra1)->inc; ra0 = SCM_ARRAY_V (ra0); ra1 = SCM_ARRAY_V (ra1); ra2 = SCM_ARRAY_V (ra2); @@ -1424,9 +1425,9 @@ ramap_1 (SCM ra0,SCM proc,SCM ras) { SCM ra1 = SCM_CAR (ras); SCM e1 = SCM_UNDEFINED; - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc; + scm_bits_t n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; + scm_bits_t i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1); + scm_bits_t inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc; ra0 = SCM_ARRAY_V (ra0); ra1 = SCM_ARRAY_V (ra1); if (scm_tc7_vector == SCM_TYP7 (ra0) || scm_tc7_wvect == SCM_TYP7 (ra0)) @@ -1445,9 +1446,9 @@ ramap_2o (SCM ra0,SCM proc,SCM ras) { SCM ra1 = SCM_CAR (ras); SCM e1 = SCM_UNDEFINED; - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc; + scm_bits_t n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; + scm_bits_t i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1); + scm_bits_t inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc; ra0 = SCM_ARRAY_V (ra0); ra1 = SCM_ARRAY_V (ra1); ras = SCM_CDR (ras); @@ -1468,8 +1469,8 @@ ramap_2o (SCM ra0,SCM proc,SCM ras) { SCM ra2 = SCM_CAR (ras); SCM e2 = SCM_UNDEFINED; - scm_sizet i2 = SCM_ARRAY_BASE (ra2); - long inc2 = SCM_ARRAY_DIMS (ra2)->inc; + scm_bits_t i2 = SCM_ARRAY_BASE (ra2); + scm_bits_t inc2 = SCM_ARRAY_DIMS (ra2)->inc; ra2 = SCM_ARRAY_V (ra2); if (scm_tc7_vector == SCM_TYP7 (ra0) || scm_tc7_wvect == SCM_TYP7 (ra0)) for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) @@ -1491,9 +1492,9 @@ static int ramap_a (SCM ra0,SCM proc,SCM ras) { SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; + scm_bits_t n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; + scm_bits_t i0 = SCM_ARRAY_BASE (ra0); + scm_bits_t inc0 = SCM_ARRAY_DIMS (ra0)->inc; ra0 = SCM_ARRAY_V (ra0); if (SCM_NULLP (ras)) for (; n-- > 0; i0 += inc0) @@ -1501,8 +1502,8 @@ ramap_a (SCM ra0,SCM proc,SCM ras) else { SCM ra1 = SCM_CAR (ras); - scm_sizet i1 = SCM_ARRAY_BASE (ra1); - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; + scm_bits_t i1 = SCM_ARRAY_BASE (ra1); + scm_bits_t inc1 = SCM_ARRAY_DIMS (ra1)->inc; ra1 = SCM_ARRAY_V (ra1); for (; n-- > 0; i0 += inc0, i1 += inc1) scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), @@ -1631,10 +1632,10 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1, static int rafe (SCM ra0,SCM proc,SCM ras) { - long i = SCM_ARRAY_DIMS (ra0)->lbnd; - scm_sizet i0 = SCM_ARRAY_BASE (ra0); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; - long n = SCM_ARRAY_DIMS (ra0)->ubnd; + scm_bits_t i = SCM_ARRAY_DIMS (ra0)->lbnd; + scm_bits_t i0 = SCM_ARRAY_BASE (ra0); + scm_bits_t inc0 = SCM_ARRAY_DIMS (ra0)->inc; + scm_bits_t n = SCM_ARRAY_DIMS (ra0)->ubnd; ra0 = SCM_ARRAY_V (ra0); if (SCM_NULLP (ras)) for (; i <= n; i++, i0 += inc0) @@ -1643,8 +1644,8 @@ rafe (SCM ra0,SCM proc,SCM ras) { SCM ra1 = SCM_CAR (ras); SCM args, *ve = &ras; - scm_sizet k, i1 = SCM_ARRAY_BASE (ra1); - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; + scm_bits_t k, i1 = SCM_ARRAY_BASE (ra1); + scm_bits_t inc1 = SCM_ARRAY_DIMS (ra1)->inc; ra1 = SCM_ARRAY_V (ra1); ras = SCM_CDR (ras); if (SCM_NULLP(ras)) @@ -1701,7 +1702,7 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0, "@end lisp") #define FUNC_NAME s_scm_array_index_map_x { - scm_sizet i; + scm_bits_t i; SCM_VALIDATE_NIM (1,ra); SCM_VALIDATE_PROC (2,proc); switch (SCM_TYP7(ra)) @@ -1729,7 +1730,7 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0, case scm_tc7_dvect: case scm_tc7_cvect: { - unsigned long int length = SCM_INUM (scm_uniform_vector_length (ra)); + scm_bits_t length = SCM_INUM (scm_uniform_vector_length (ra)); for (i = 0; i < length; i++) scm_array_set_x (ra, scm_apply (proc, SCM_MAKINUM (i), scm_listofnull), SCM_MAKINUM (i)); @@ -1740,7 +1741,7 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0, { SCM args = SCM_EOL; SCM inds = scm_make_uve (SCM_ARRAY_NDIM (ra), SCM_MAKINUM (-1L)); - long *vinds = (long *) SCM_VELTS (inds); + scm_bits_t *vinds = (scm_bits_t *) SCM_VELTS (inds); int j, k, kmax = SCM_ARRAY_NDIM (ra) - 1; if (kmax < 0) return scm_array_set_x (ra, scm_apply(proc, SCM_EOL, SCM_EOL), @@ -1787,9 +1788,9 @@ static int raeql_1 (SCM ra0,SCM as_equal,SCM ra1) { SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; - scm_sizet i0 = 0, i1 = 0; - long inc0 = 1, inc1 = 1; - scm_sizet n; + scm_bits_t i0 = 0, i1 = 0; + scm_bits_t inc0 = 1, inc1 = 1; + scm_bits_t n; ra1 = SCM_CAR (ra1); if (SCM_ARRAYP(ra0)) { @@ -1915,9 +1916,9 @@ static int raeql (SCM ra0,SCM as_equal,SCM ra1) { SCM v0 = ra0, v1 = ra1; - scm_array_dim dim0, dim1; - scm_array_dim *s0 = &dim0, *s1 = &dim1; - scm_sizet bas0 = 0, bas1 = 0; + scm_array_dim_t dim0, dim1; + scm_array_dim_t *s0 = &dim0, *s1 = &dim1; + scm_bits_t bas0 = 0, bas1 = 0; int k, unroll = 1, vlen = 1, ndim = 1; if (SCM_ARRAYP (ra0)) { diff --git a/libguile/random.c b/libguile/random.c index 63cfffe33..b41db73b2 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -73,7 +73,7 @@ * scm_init_random(). */ -scm_rng scm_the_rng; +scm_rng_t scm_the_rng; /* @@ -106,7 +106,7 @@ scm_rng scm_the_rng; #if SIZEOF_LONG > 4 || defined (HAVE_LONG_LONGS) unsigned long -scm_i_uniform32 (scm_i_rstate *state) +scm_i_uniform32 (scm_i_rstate_t *state) { LONG64 x = (LONG64) A * state->w + state->c; LONG32 w = x & 0xffffffffUL; @@ -132,7 +132,7 @@ scm_i_uniform32 (scm_i_rstate *state) #define H(x) ((x) >> 16) unsigned long -scm_i_uniform32 (scm_i_rstate *state) +scm_i_uniform32 (scm_i_rstate_t *state) { LONG32 x1 = L (A) * L (state->w); LONG32 x2 = L (A) * H (state->w); @@ -148,7 +148,7 @@ scm_i_uniform32 (scm_i_rstate *state) #endif void -scm_i_init_rstate (scm_i_rstate *state, char *seed, int n) +scm_i_init_rstate (scm_i_rstate_t *state, char *seed, int n) { LONG32 w = 0L; LONG32 c = 0L; @@ -167,10 +167,10 @@ scm_i_init_rstate (scm_i_rstate *state, char *seed, int n) state->c = c; } -scm_i_rstate * -scm_i_copy_rstate (scm_i_rstate *state) +scm_i_rstate_t * +scm_i_copy_rstate (scm_i_rstate_t *state) { - scm_rstate *new_state = malloc (scm_the_rng.rstate_size); + scm_rstate_t *new_state = malloc (scm_the_rng.rstate_size); if (new_state == 0) scm_memory_error ("rstate"); return memcpy (new_state, state, scm_the_rng.rstate_size); @@ -181,10 +181,10 @@ scm_i_copy_rstate (scm_i_rstate *state) * Random number library functions */ -scm_rstate * +scm_rstate_t * scm_c_make_rstate (char *seed, int n) { - scm_rstate *state = malloc (scm_the_rng.rstate_size); + scm_rstate_t *state = malloc (scm_the_rng.rstate_size); if (state == 0) scm_memory_error ("rstate"); state->reserved0 = 0; @@ -193,7 +193,7 @@ scm_c_make_rstate (char *seed, int n) } -scm_rstate * +scm_rstate_t * scm_c_default_rstate () #define FUNC_NAME "scm_c_default_rstate" { @@ -206,7 +206,7 @@ scm_c_default_rstate () inline double -scm_c_uniform01 (scm_rstate *state) +scm_c_uniform01 (scm_rstate_t *state) { double x = (double) scm_the_rng.random_bits (state) / (double) 0xffffffffUL; return ((x + (double) scm_the_rng.random_bits (state)) @@ -214,7 +214,7 @@ scm_c_uniform01 (scm_rstate *state) } double -scm_c_normal01 (scm_rstate *state) +scm_c_normal01 (scm_rstate_t *state) { if (state->reserved0) { @@ -237,7 +237,7 @@ scm_c_normal01 (scm_rstate *state) } double -scm_c_exp1 (scm_rstate *state) +scm_c_exp1 (scm_rstate_t *state) { return - log (scm_c_uniform01 (state)); } @@ -245,7 +245,7 @@ scm_c_exp1 (scm_rstate *state) unsigned char scm_masktab[256]; unsigned long -scm_c_random (scm_rstate *state, unsigned long m) +scm_c_random (scm_rstate_t *state, unsigned long m) { unsigned int r, mask; mask = (m < 0x100 @@ -260,7 +260,7 @@ scm_c_random (scm_rstate *state, unsigned long m) } SCM -scm_c_random_bignum (scm_rstate *state, SCM m) +scm_c_random_bignum (scm_rstate_t *state, SCM m) { SCM b; int i, nd; @@ -292,7 +292,7 @@ scm_c_random_bignum (scm_rstate *state, SCM m) ? scm_masktab[w >> 16] << 16 | 0xffff : scm_masktab[w >> 24] << 24 | 0xffffff)); } - b = scm_mkbig (nd, 0); + b = scm_i_mkbig (nd, 0); bits = (LONG32 *) SCM_BDIGITS (b); do { @@ -322,7 +322,7 @@ scm_c_random_bignum (scm_rstate *state, SCM m) /* now fill up the rest of the bignum */ while (i) bits[--i] = scm_the_rng.random_bits (state); - b = scm_normbig (b); + b = scm_i_normbig (b); if (SCM_INUMP (b)) return b; } while (scm_bigcomp (b, m) <= 0); @@ -336,12 +336,12 @@ scm_c_random_bignum (scm_rstate *state, SCM m) scm_bits_t scm_tc16_rstate; static SCM -make_rstate (scm_rstate *state) +make_rstate (scm_rstate_t *state) { SCM_RETURN_NEWSMOB (scm_tc16_rstate, state); } -static scm_sizet +static size_t rstate_free (SCM rstate) { free (SCM_RSTATE (rstate)); @@ -568,12 +568,12 @@ scm_init_random () { int i, m; /* plug in default RNG */ - scm_rng rng = + scm_rng_t rng = { - sizeof (scm_i_rstate), + sizeof (scm_i_rstate_t), (unsigned long (*)()) scm_i_uniform32, (void (*)()) scm_i_init_rstate, - (scm_rstate *(*)()) scm_i_copy_rstate + (scm_rstate_t *(*)()) scm_i_copy_rstate }; scm_the_rng = rng; diff --git a/libguile/random.h b/libguile/random.h index 797bae4a0..f6d37cc81 100644 --- a/libguile/random.h +++ b/libguile/random.h @@ -62,47 +62,53 @@ * Look how the default generator is "plugged in" in scm_init_random(). */ -typedef struct scm_rstate { +typedef struct scm_rstate_t { int reserved0; double reserved1; /* Custom fields follow here */ -} scm_rstate; +} scm_rstate_t; -typedef struct scm_rng { +typedef struct scm_rng_t { size_t rstate_size; /* size of random state */ - unsigned long (*random_bits) (scm_rstate *state); /* gives 32 random bits */ - void (*init_rstate) (scm_rstate *state, char *seed, int n); - scm_rstate *(*copy_rstate) (scm_rstate *state); -} scm_rng; + unsigned long (*random_bits) (scm_rstate_t *state); /* gives 32 random bits */ + void (*init_rstate) (scm_rstate_t *state, char *seed, int n); + scm_rstate_t *(*copy_rstate) (scm_rstate_t *state); +} scm_rng_t; -extern scm_rng scm_the_rng; +extern scm_rng_t scm_the_rng; /* * Default RNG */ -typedef struct scm_i_rstate { - scm_rstate rstate; +typedef struct scm_i_rstate_t { + scm_rstate_t rstate; unsigned long w; unsigned long c; -} scm_i_rstate; +} scm_i_rstate_t; -extern unsigned long scm_i_uniform32 (scm_i_rstate *); -extern void scm_i_init_rstate (scm_i_rstate *, char *seed, int n); -extern scm_i_rstate *scm_i_copy_rstate (scm_i_rstate *); +#if (SCM_DEBUG_DEPRECATED == 0) +# define scm_rstate scm_rstate_t +# define scm_rng scm_rng_t +# define scm_i_rstate scm_i_rstate_t +#endif + +extern unsigned long scm_i_uniform32 (scm_i_rstate_t *); +extern void scm_i_init_rstate (scm_i_rstate_t *, char *seed, int n); +extern scm_i_rstate_t *scm_i_copy_rstate (scm_i_rstate_t *); /* * Random number library functions */ -extern scm_rstate *scm_c_make_rstate (char *, int); -extern scm_rstate *scm_c_default_rstate (void); +extern scm_rstate_t *scm_c_make_rstate (char *, int); +extern scm_rstate_t *scm_c_default_rstate (void); #define scm_c_uniform32(RSTATE) scm_the_rng.random_bits (RSTATE) -extern double scm_c_uniform01 (scm_rstate *); -extern double scm_c_normal01 (scm_rstate *); -extern double scm_c_exp1 (scm_rstate *); -extern unsigned long scm_c_random (scm_rstate *, unsigned long m); -extern SCM scm_c_random_bignum (scm_rstate *, SCM m); +extern double scm_c_uniform01 (scm_rstate_t *); +extern double scm_c_normal01 (scm_rstate_t *); +extern double scm_c_exp1 (scm_rstate_t *); +extern unsigned long scm_c_random (scm_rstate_t *, unsigned long m); +extern SCM scm_c_random_bignum (scm_rstate_t *, SCM m); /* @@ -110,7 +116,7 @@ extern SCM scm_c_random_bignum (scm_rstate *, SCM m); */ extern scm_bits_t scm_tc16_rstate; #define SCM_RSTATEP(obj) SCM_TYP16_PREDICATE (scm_tc16_rstate, obj) -#define SCM_RSTATE(obj) ((scm_rstate *) SCM_CELL_WORD_1 (obj)) +#define SCM_RSTATE(obj) ((scm_rstate_t *) SCM_CELL_WORD_1 (obj)) extern unsigned char scm_masktab[256]; diff --git a/libguile/rdelim.c b/libguile/rdelim.c index 1440e1b6c..c029b3f8c 100644 --- a/libguile/rdelim.c +++ b/libguile/rdelim.c @@ -78,13 +78,13 @@ SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0, "a delimiter, this value is @code{#f}.") #define FUNC_NAME s_scm_read_delimited_x { - long j; + size_t j; char *buf; - long cstart; - long cend; + size_t cstart; + size_t cend; int c; char *cdelims; - int num_delims; + size_t num_delims; SCM_VALIDATE_STRING_COPY (1, delims, cdelims); num_delims = SCM_STRING_LENGTH (delims); @@ -97,7 +97,7 @@ SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0, for (j = cstart; j < cend; j++) { - int k; + size_t k; c = scm_getc (port); for (k = 0; k < num_delims; k++) @@ -122,9 +122,9 @@ SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0, #undef FUNC_NAME static unsigned char * -scm_do_read_line (SCM port, int *len_p) +scm_do_read_line (SCM port, size_t *len_p) { - scm_port *pt = SCM_PTAB_ENTRY (port); + scm_port_t *pt = SCM_PTAB_ENTRY (port); unsigned char *end; /* I thought reading lines was simple. Mercy me. */ @@ -134,7 +134,7 @@ scm_do_read_line (SCM port, int *len_p) if ((end = memchr (pt->read_pos, '\n', (pt->read_end - pt->read_pos))) != 0) { - int buf_len = (end + 1) - pt->read_pos; + size_t buf_len = (end + 1) - pt->read_pos; /* Allocate a buffer of the perfect size. */ unsigned char *buf = scm_must_malloc (buf_len + 1, "%read-line"); @@ -151,18 +151,18 @@ scm_do_read_line (SCM port, int *len_p) { /* When live, len is always the number of characters in the current buffer that are part of the current line. */ - int len = (pt->read_end - pt->read_pos); - int buf_size = (len < 50) ? 60 : len * 2; + size_t len = (pt->read_end - pt->read_pos); + size_t buf_size = (len < 50) ? 60 : len * 2; /* Invariant: buf always has buf_size + 1 characters allocated; the `+ 1' is for the final '\0'. */ unsigned char *buf = scm_must_malloc (buf_size + 1, "%read-line"); - int buf_len = 0; + size_t buf_len = 0; for (;;) { if (buf_len + len > buf_size) { - int new_size = (buf_len + len) * 2; + size_t new_size = (buf_len + len) * 2; buf = scm_must_realloc (buf, buf_size + 1, new_size + 1, "%read-line"); buf_size = new_size; @@ -223,9 +223,9 @@ SCM_DEFINE (scm_read_line, "%read-line", 0, 1, 0, "@code{(# . #)}.") #define FUNC_NAME s_scm_read_line { - scm_port *pt; + scm_port_t *pt; char *s; - int slen; + size_t slen; SCM line, term; if (SCM_UNBNDP (port)) @@ -247,7 +247,7 @@ SCM_DEFINE (scm_read_line, "%read-line", 0, 1, 0, term = SCM_MAKE_CHAR ('\n'); s[slen-1] = '\0'; line = scm_take_str (s, slen-1); - scm_done_malloc (-1); + scm_done_free (1); SCM_INCLINE (port); } else diff --git a/libguile/read.c b/libguile/read.c index 635a4ae42..57c90d6e0 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -66,7 +66,7 @@ SCM_SYMBOL (scm_keyword_prefix, "prefix"); -scm_option scm_read_opts[] = { +scm_option_t scm_read_opts[] = { { SCM_OPTION_BOOLEAN, "copy", 0, "Copy source code expressions." }, { SCM_OPTION_BOOLEAN, "positions", 0, @@ -126,9 +126,9 @@ SCM_DEFINE (scm_read, "read", 0, 1, 0, char * scm_grow_tok_buf (SCM *tok_buf) { - unsigned long int oldlen = SCM_STRING_LENGTH (*tok_buf); + size_t oldlen = SCM_STRING_LENGTH (*tok_buf); SCM newstr = scm_allocate_string (2 * oldlen); - unsigned long int i; + size_t i; for (i = 0; i != oldlen; ++i) SCM_STRING_CHARS (newstr) [i] = SCM_STRING_CHARS (*tok_buf) [i]; @@ -203,7 +203,7 @@ scm_casei_streq (char *s1, char *s2) #define recsexpr(obj, line, column, filename) (obj) #else static SCM -recsexpr (SCM obj,int line,int column,SCM filename) +recsexpr (SCM obj, long line, int column, SCM filename) { if (!SCM_CONSP(obj)) { return obj; @@ -286,7 +286,7 @@ scm_lreadr (SCM *tok_buf,SCM port,SCM *copy) #define FUNC_NAME "scm_lreadr" { int c; - scm_sizet j; + size_t j; SCM p; tryagain: @@ -535,10 +535,10 @@ tryagain_no_flush_ws: _Pragma ("noopt"); /* # pragma _CRI noopt */ #endif -scm_sizet +size_t scm_read_token (int ic, SCM *tok_buf, SCM port, int weird) { - register scm_sizet j; + register size_t j; register int c; register char *p; diff --git a/libguile/read.h b/libguile/read.h index 3b5c37902..5c93e6d20 100644 --- a/libguile/read.h +++ b/libguile/read.h @@ -67,7 +67,7 @@ #define SCM_WHITE_SPACES SCM_SINGLE_SPACES: case '\t' -extern scm_option scm_read_opts[]; +extern scm_option_t scm_read_opts[]; #define SCM_COPY_SOURCE_P scm_read_opts[0].val #define SCM_RECORD_POSITIONS_P scm_read_opts[1].val @@ -83,7 +83,7 @@ extern char * scm_grow_tok_buf (SCM * tok_buf); extern int scm_flush_ws (SCM port, const char *eoferr); extern int scm_casei_streq (char * s1, char * s2); extern SCM scm_lreadr (SCM * tok_buf, SCM port, SCM *copy); -extern scm_sizet scm_read_token (int ic, SCM * tok_buf, SCM port, int weird); +extern size_t scm_read_token (int ic, SCM * tok_buf, SCM port, int weird); extern SCM scm_lreadparen (SCM * tok_buf, SCM port, char *name, SCM *copy); extern SCM scm_lreadrecparen (SCM * tok_buf, SCM port, char *name, SCM *copy); extern SCM scm_read_hash_extend (SCM chr, SCM proc); diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index 1f02d688b..867bed14d 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -93,7 +93,7 @@ scm_bits_t scm_tc16_regex; -static scm_sizet +static size_t regex_free (SCM obj) { regfree (SCM_RGX (obj)); diff --git a/libguile/root.c b/libguile/root.c index a0d092030..23ca98256 100644 --- a/libguile/root.c +++ b/libguile/root.c @@ -171,7 +171,7 @@ scm_make_root (SCM parent) #if 0 SCM scm_exitval; /* INUM with return value */ #endif -static int n_dynamic_roots = 0; +static scm_bits_t n_dynamic_roots = 0; /* cwdr fills out both of these structures, and then passes a pointer @@ -253,7 +253,7 @@ scm_internal_cwdr (scm_catch_body_t body, void *body_data, SCM_REDEFER_INTS; { - scm_contregs *contregs = scm_must_malloc (sizeof (scm_contregs), + scm_contregs_t *contregs = scm_must_malloc (sizeof (scm_contregs_t), "inferior root continuation"); contregs->num_stack_items = 0; diff --git a/libguile/root.h b/libguile/root.h index 40671e55e..764052ce6 100644 --- a/libguile/root.h +++ b/libguile/root.h @@ -96,7 +96,7 @@ typedef struct scm_root_state SCM continuation_stack_ptr; #ifdef DEBUG_EXTENSIONS /* It is very inefficient to have this variable in the root state. */ - scm_debug_frame *last_debug_frame; + scm_debug_frame_t *last_debug_frame; #endif SCM progargs; /* vestigial */ diff --git a/libguile/rw.c b/libguile/rw.c index 28d4ea604..e0d271cf5 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -111,13 +111,13 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0, #define FUNC_NAME s_scm_read_string_x_partial { char *dest; - long read_len; - long chars_read = 0; + scm_bits_t read_len; + scm_bits_t chars_read = 0; int fdes; { - long offset; - long last; + scm_bits_t offset; + scm_bits_t last; SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, dest, 3, start, offset, 4, end, last); diff --git a/libguile/script.c b/libguile/script.c index 2eda0b378..7c7c3f162 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -74,14 +74,14 @@ scm_cat_path (char *str1, const char *str2, long n) n = strlen (str2); if (str1) { - long len = strlen (str1); - str1 = (char *) realloc (str1, (scm_sizet) (len + n + 1)); + size_t len = strlen (str1); + str1 = (char *) realloc (str1, (size_t) (len + n + 1)); if (!str1) return 0L; strncat (str1 + len, str2, n); return str1; } - str1 = (char *) malloc ((scm_sizet) (n + 1)); + str1 = (char *) malloc ((size_t) (n + 1)); if (!str1) return 0L; str1[0] = 0; @@ -233,9 +233,9 @@ static char * script_read_arg (FILE *f) #define FUNC_NAME "script_read_arg" { - int size = 7; + size_t size = 7; char *buf = malloc (size + 1); - int len = 0; + size_t len = 0; if (! buf) return 0; diff --git a/libguile/simpos.c b/libguile/simpos.c index a03ec6c30..cfc1c9e41 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -110,7 +110,7 @@ SCM_DEFINE (scm_getenv, "getenv", 1, 0, 0, SCM_VALIDATE_STRING (1, nam); SCM_STRING_COERCE_0TERMINATION_X (nam); val = getenv (SCM_STRING_CHARS (nam)); - return (val) ? scm_makfromstr(val, (scm_sizet)strlen(val), 0) : SCM_BOOL_F; + return (val) ? scm_makfromstr(val, (size_t)strlen(val), 0) : SCM_BOOL_F; } #undef FUNC_NAME diff --git a/libguile/smob.c b/libguile/smob.c index 6d80f8fe3..a487b9715 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -67,7 +67,7 @@ */ #define MAX_SMOB_COUNT 256 -int scm_numsmob; +scm_bits_t scm_numsmob; scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT]; /* {Mark} @@ -100,13 +100,13 @@ scm_markcdr (SCM ptr) /* {Free} */ -scm_sizet +size_t scm_free0 (SCM ptr) { return 0; } -scm_sizet +size_t scm_smob_free (SCM obj) { scm_must_free ((char *) SCM_CELL_WORD_1 (obj)); @@ -119,7 +119,7 @@ scm_smob_free (SCM obj) int scm_smob_print (SCM exp, SCM port, scm_print_state *pstate) { - unsigned int n = SCM_SMOBNUM (exp); + size_t n = SCM_SMOBNUM (exp); scm_puts ("#<", port); scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port); scm_putc (' ', port); @@ -286,10 +286,10 @@ scm_smob_apply_3_error (SCM smob, SCM a1, SCM a2, SCM rst) scm_bits_t -scm_make_smob_type (char *name, scm_sizet size) +scm_make_smob_type (char *name, size_t size) #define FUNC_NAME "scm_make_smob_type" { - unsigned int new_smob; + size_t new_smob; SCM_ENTER_A_SECTION; /* scm_numsmob */ new_smob = scm_numsmob; @@ -323,7 +323,7 @@ scm_set_smob_mark (scm_bits_t tc, SCM (*mark) (SCM)) } void -scm_set_smob_free (scm_bits_t tc, scm_sizet (*free) (SCM)) +scm_set_smob_free (scm_bits_t tc, size_t (*free) (SCM)) { scm_smobs[SCM_TC2SMOBNUM (tc)].free = free; } @@ -453,8 +453,8 @@ scm_set_smob_apply (scm_bits_t tc, SCM (*apply) (), SCM scm_make_smob (scm_bits_t tc) { - int n = SCM_TC2SMOBNUM (tc); - scm_sizet size = scm_smobs[n].size; + size_t n = SCM_TC2SMOBNUM (tc); + size_t size = scm_smobs[n].size; SCM z; SCM_NEWCELL (z); if (size != 0) @@ -481,13 +481,13 @@ scm_make_smob (scm_bits_t tc) #if (SCM_DEBUG_DEPRECATED == 0) long -scm_make_smob_type_mfpe (char *name, scm_sizet size, +scm_make_smob_type_mfpe (char *name, size_t size, SCM (*mark) (SCM), - scm_sizet (*free) (SCM), + size_t (*free) (SCM), int (*print) (SCM, SCM, scm_print_state *), SCM (*equalp) (SCM, SCM)) { - long answer = scm_make_smob_type (name, size); + scm_bits_t answer = scm_make_smob_type (name, size); scm_set_smob_mfpe (answer, mark, free, print, equalp); return answer; } @@ -495,7 +495,7 @@ scm_make_smob_type_mfpe (char *name, scm_sizet size, void scm_set_smob_mfpe (long tc, SCM (*mark) (SCM), - scm_sizet (*free) (SCM), + size_t (*free) (SCM), int (*print) (SCM, SCM, scm_print_state *), SCM (*equalp) (SCM, SCM)) { @@ -526,7 +526,7 @@ free_print (SCM exp, SCM port, scm_print_state *pstate) void scm_smob_prehistory () { - unsigned int i; + size_t i; scm_bits_t tc; scm_numsmob = 0; diff --git a/libguile/smob.h b/libguile/smob.h index 5c1a56e8e..9cbf38738 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -52,9 +52,9 @@ typedef struct scm_smob_descriptor { char *name; - scm_sizet size; + size_t size; SCM (*mark) (SCM); - scm_sizet (*free) (SCM); + size_t (*free) (SCM); int (*print) (SCM exp, SCM port, scm_print_state *pstate); SCM (*equalp) (SCM, SCM); SCM (*apply) (); @@ -124,15 +124,15 @@ do { \ #define SCM_SMOB_APPLY_2(x,a1,a2) (SCM_SMOB_DESCRIPTOR (x).apply_2 (x, (a1), (a2))) #define SCM_SMOB_APPLY_3(x,a1,a2,rst) (SCM_SMOB_DESCRIPTOR (x).apply_3 (x, (a1), (a2), (rst))) -extern int scm_numsmob; +extern scm_bits_t scm_numsmob; extern scm_smob_descriptor scm_smobs[]; extern SCM scm_mark0 (SCM ptr); extern SCM scm_markcdr (SCM ptr); -extern scm_sizet scm_free0 (SCM ptr); -extern scm_sizet scm_smob_free (SCM obj); +extern size_t scm_free0 (SCM ptr); +extern size_t scm_smob_free (SCM obj); extern int scm_smob_print (SCM exp, SCM port, scm_print_state *pstate); /* The following set of functions is the standard way to create new @@ -143,10 +143,10 @@ extern int scm_smob_print (SCM exp, SCM port, scm_print_state *pstate); * values using `scm_set_smob_xxx'. */ -extern scm_bits_t scm_make_smob_type (char *name, scm_sizet size); +extern scm_bits_t scm_make_smob_type (char *name, size_t size); extern void scm_set_smob_mark (scm_bits_t tc, SCM (*mark) (SCM)); -extern void scm_set_smob_free (scm_bits_t tc, scm_sizet (*free) (SCM)); +extern void scm_set_smob_free (scm_bits_t tc, size_t (*free) (SCM)); extern void scm_set_smob_print (scm_bits_t tc, int (*print) (SCM, SCM, scm_print_state*)); extern void scm_set_smob_equalp (scm_bits_t tc, SCM (*equalp) (SCM, SCM)); @@ -165,15 +165,15 @@ extern void scm_smob_prehistory (void); #if (SCM_DEBUG_DEPRECATED == 0) -extern long scm_make_smob_type_mfpe (char *name, scm_sizet size, +extern long scm_make_smob_type_mfpe (char *name, size_t size, SCM (*mark) (SCM), - scm_sizet (*free) (SCM), + size_t (*free) (SCM), int (*print) (SCM, SCM, scm_print_state*), SCM (*equalp) (SCM, SCM)); extern void scm_set_smob_mfpe (long tc, SCM (*mark) (SCM), - scm_sizet (*free) (SCM), + size_t (*free) (SCM), int (*print) (SCM, SCM, scm_print_state*), SCM (*equalp) (SCM, SCM)); diff --git a/libguile/socket.c b/libguile/socket.c index 5fbba91ca..109918d83 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -307,7 +307,7 @@ static SCM ipv6_net_to_num (const char *src) } else { - result = scm_mkbig (big_digits, 0); + result = scm_i_mkbig (big_digits, 0); memcpy (SCM_BDIGITS (result), addr, big_digits * bytes_per_dig); } return result; @@ -497,8 +497,8 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0, char optval[sizeof (struct linger)]; int optlen = sizeof (struct linger); #else - char optval[sizeof (scm_sizet)]; - int optlen = sizeof (scm_sizet); + char optval[sizeof (size_t)]; + int optlen = sizeof (size_t); #endif int ilevel; int ioptname; @@ -538,7 +538,7 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0, #endif ) { - return scm_long2num (*(scm_sizet *) optval); + return scm_long2num (*(size_t *) optval); } } return scm_long2num (*(int *) optval); @@ -565,7 +565,7 @@ SCM_DEFINE (scm_setsockopt, "setsockopt", 4, 0, 0, #ifdef HAVE_STRUCT_LINGER char optval[sizeof (struct linger)]; #else - char optval[sizeof (scm_sizet)]; + char optval[sizeof (size_t)]; #endif int ilevel, ioptname; @@ -624,8 +624,8 @@ SCM_DEFINE (scm_setsockopt, "setsockopt", 4, 0, 0, { long lv = SCM_NUM2LONG (4, value); - optlen = (int) sizeof (scm_sizet); - (*(scm_sizet *) optval) = (scm_sizet) lv; + optlen = (int) sizeof (size_t); + (*(size_t *) optval) = (size_t) lv; } } if (optlen == -1) @@ -961,7 +961,7 @@ scm_addr_vector (const struct sockaddr *address, const char *proc) ve = SCM_VELTS (result); ve[0] = scm_ulong2num ((unsigned long) fam); ve[1] = scm_makfromstr (nad->sun_path, - (scm_sizet) strlen (nad->sun_path), 0); + (size_t) strlen (nad->sun_path), 0); } break; #endif diff --git a/libguile/sort.c b/libguile/sort.c index 954f75eeb..5b5dc9584 100644 --- a/libguile/sort.c +++ b/libguile/sort.c @@ -456,7 +456,7 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0, "applied to all elements i - 1 and i") #define FUNC_NAME s_scm_sorted_p { - long len, j; /* list/vector length, temp j */ + scm_bits_t len, j; /* list/vector length, temp j */ SCM item, rest; /* rest of items loop variable */ SCM *vp; cmp_fun_t cmp = scm_cmp_function (less); @@ -528,7 +528,7 @@ SCM_DEFINE (scm_merge, "merge", 3, 0, 0, "Note: this does _not_ accept vectors.") #define FUNC_NAME s_scm_merge { - long alen, blen; /* list lengths */ + scm_bits_t alen, blen; /* list lengths */ SCM build, last; cmp_fun_t cmp = scm_cmp_function (less); SCM_VALIDATE_NIM (3,less); @@ -641,7 +641,7 @@ SCM_DEFINE (scm_merge_x, "merge!", 3, 0, 0, "Note: this does _not_ accept vectors.") #define FUNC_NAME s_scm_merge_x { - long alen, blen; /* list lengths */ + scm_bits_t alen, blen; /* list lengths */ SCM_VALIDATE_NIM (3,less); if (SCM_NULLP (alist)) @@ -669,13 +669,13 @@ static SCM scm_merge_list_step (SCM * seq, cmp_fun_t cmp, SCM less, - int n) + scm_bits_t n) { SCM a, b; if (n > 2) { - long mid = n / 2; + scm_bits_t mid = n / 2; a = scm_merge_list_step (seq, cmp, less, mid); b = scm_merge_list_step (seq, cmp, less, n - mid); return scm_merge_list_x (a, b, mid, n - mid, cmp, less); @@ -717,7 +717,7 @@ SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0, "This is not a stable sort.") #define FUNC_NAME s_scm_sort_x { - long len; /* list/vector length */ + scm_bits_t len; /* list/vector length */ if (SCM_NULLP(items)) return SCM_EOL; @@ -757,7 +757,7 @@ SCM_DEFINE (scm_sort, "sort", 2, 0, 0, SCM_VALIDATE_NIM (2,less); if (SCM_CONSP (items)) { - long len; + scm_bits_t len; SCM_VALIDATE_LIST_COPYLEN (1,items,len); items = scm_list_copy (items); @@ -767,7 +767,7 @@ SCM_DEFINE (scm_sort, "sort", 2, 0, 0, /* support ordinary vectors even if arrays not available? */ else if (SCM_VECTORP (items)) { - long len = SCM_VECTOR_LENGTH (items); + scm_bits_t len = SCM_VECTOR_LENGTH (items); SCM sortvec = scm_make_uve (len, scm_array_prototype (items)); scm_array_copy_x (items, sortvec); @@ -788,15 +788,15 @@ scm_merge_vector_x (void *const vecbase, void *const tempbase, cmp_fun_t cmp, SCM less, - long low, - long mid, - long high) + scm_bits_t low, + scm_bits_t mid, + scm_bits_t high) { register SCM *vp = (SCM *) vecbase; register SCM *temp = (SCM *) tempbase; - long it; /* Index for temp vector */ - long i1 = low; /* Index for lower vector segment */ - long i2 = mid + 1; /* Index for upper vector segment */ + scm_bits_t it; /* Index for temp vector */ + scm_bits_t i1 = low; /* Index for lower vector segment */ + scm_bits_t i2 = mid + 1; /* Index for upper vector segment */ /* Copy while both segments contain more characters */ for (it = low; (i1 <= mid) && (i2 <= high); ++it) @@ -823,12 +823,12 @@ scm_merge_vector_step (void *const vp, void *const temp, cmp_fun_t cmp, SCM less, - long low, - long high) + scm_bits_t low, + scm_bits_t high) { if (high > low) { - long mid = (low + high) / 2; + scm_bits_t mid = (low + high) / 2; scm_merge_vector_step (vp, temp, cmp, less, low, mid); scm_merge_vector_step (vp, temp, cmp, less, mid+1, high); scm_merge_vector_x (vp, temp, cmp, less, low, mid, high); @@ -847,7 +847,7 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0, "This is a stable sort.") #define FUNC_NAME s_scm_stable_sort_x { - long len; /* list/vector length */ + scm_bits_t len; /* list/vector length */ if (SCM_NULLP (items)) return SCM_EOL; @@ -887,7 +887,7 @@ SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0, "This is a stable sort.") #define FUNC_NAME s_scm_stable_sort { - long len; /* list/vector length */ + scm_bits_t len; /* list/vector length */ if (SCM_NULLP (items)) return SCM_EOL; @@ -933,7 +933,7 @@ SCM_DEFINE (scm_sort_list_x, "sort-list!", 2, 0, 0, "This is a stable sort.") #define FUNC_NAME s_scm_sort_list_x { - long len; + scm_bits_t len; SCM_VALIDATE_LIST_COPYLEN (1,items,len); SCM_VALIDATE_NIM (2,less); return scm_merge_list_step (&items, scm_cmp_function (less), less, len); @@ -947,7 +947,7 @@ SCM_DEFINE (scm_sort_list, "sort-list", 2, 0, 0, "list elements. This is a stable sort.") #define FUNC_NAME s_scm_sort_list { - long len; + scm_bits_t len; SCM_VALIDATE_LIST_COPYLEN (1,items,len); SCM_VALIDATE_NIM (2,less); items = scm_list_copy (items); diff --git a/libguile/srcprop.c b/libguile/srcprop.c index ef368aa2c..e16573ec0 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -84,8 +84,8 @@ SCM_GLOBAL_SYMBOL (scm_sym_column, "column"); SCM_GLOBAL_SYMBOL (scm_sym_breakpoint, "breakpoint"); scm_bits_t scm_tc16_srcprops; -static scm_srcprops_chunk *srcprops_chunklist = 0; -static scm_srcprops *srcprops_freelist = 0; +static scm_srcprops_chunk_t *srcprops_chunklist = 0; +static scm_srcprops_t *srcprops_freelist = 0; static SCM @@ -97,11 +97,11 @@ srcprops_mark (SCM obj) } -static scm_sizet +static size_t srcprops_free (SCM obj) { - *((scm_srcprops **) SCM_CELL_WORD_1 (obj)) = srcprops_freelist; - srcprops_freelist = (scm_srcprops *) SCM_CELL_WORD_1 (obj); + *((scm_srcprops_t **) SCM_CELL_WORD_1 (obj)) = srcprops_freelist; + srcprops_freelist = (scm_srcprops_t *) SCM_CELL_WORD_1 (obj); return 0; /* srcprops_chunks are not freed until leaving guile */ } @@ -120,19 +120,19 @@ srcprops_print (SCM obj, SCM port, scm_print_state *pstate) SCM -scm_make_srcprops (int line, int col, SCM filename, SCM copy, SCM plist) +scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM plist) { - register scm_srcprops *ptr; + register scm_srcprops_t *ptr; SCM_DEFER_INTS; if ((ptr = srcprops_freelist) != NULL) - srcprops_freelist = *(scm_srcprops **)ptr; + srcprops_freelist = *(scm_srcprops_t **)ptr; else { - int i; - scm_srcprops_chunk *mem; - scm_sizet n = sizeof (scm_srcprops_chunk) - + sizeof (scm_srcprops) * (SRCPROPS_CHUNKSIZE - 1); - SCM_SYSCALL (mem = (scm_srcprops_chunk *) malloc (n)); + size_t i; + scm_srcprops_chunk_t *mem; + size_t n = sizeof (scm_srcprops_chunk_t) + + sizeof (scm_srcprops_t) * (SRCPROPS_CHUNKSIZE - 1); + SCM_SYSCALL (mem = (scm_srcprops_chunk_t *) malloc (n)); if (mem == NULL) scm_memory_error ("srcprops"); scm_mallocated += n; @@ -140,9 +140,9 @@ scm_make_srcprops (int line, int col, SCM filename, SCM copy, SCM plist) srcprops_chunklist = mem; ptr = &mem->srcprops[0]; for (i = 1; i < SRCPROPS_CHUNKSIZE - 1; ++i) - *(scm_srcprops **)&ptr[i] = &ptr[i + 1]; - *(scm_srcprops **)&ptr[SRCPROPS_CHUNKSIZE - 1] = 0; - srcprops_freelist = (scm_srcprops *) &ptr[1]; + *(scm_srcprops_t **)&ptr[i] = &ptr[i + 1]; + *(scm_srcprops_t **)&ptr[SRCPROPS_CHUNKSIZE - 1] = 0; + srcprops_freelist = (scm_srcprops_t *) &ptr[1]; } ptr->pos = SRCPROPMAKPOS (line, col); ptr->fname = filename; @@ -344,13 +344,13 @@ scm_init_srcprop () void scm_finish_srcprop () { - register scm_srcprops_chunk *ptr = srcprops_chunklist, *next; + register scm_srcprops_chunk_t *ptr = srcprops_chunklist, *next; while (ptr) { next = ptr->next; free ((char *) ptr); - scm_mallocated -= sizeof (scm_srcprops_chunk) - + sizeof (scm_srcprops) * (SRCPROPS_CHUNKSIZE - 1); + scm_mallocated -= sizeof (scm_srcprops_chunk_t) + + sizeof (scm_srcprops_t) * (SRCPROPS_CHUNKSIZE - 1); ptr = next; } } diff --git a/libguile/srcprop.h b/libguile/srcprop.h index 93c60ac26..b53eb13b7 100644 --- a/libguile/srcprop.h +++ b/libguile/srcprop.h @@ -80,32 +80,37 @@ do { \ extern scm_bits_t scm_tc16_srcprops; -typedef struct scm_srcprops +typedef struct scm_srcprops_t { unsigned long pos; SCM fname; SCM copy; SCM plist; -} scm_srcprops; +} scm_srcprops_t; #define SRCPROPS_CHUNKSIZE 2047 /* Number of srcprops per chunk */ -typedef struct scm_srcprops_chunk +typedef struct scm_srcprops_chunk_t { - struct scm_srcprops_chunk *next; - scm_srcprops srcprops[1]; -} scm_srcprops_chunk; + struct scm_srcprops_chunk_t *next; + scm_srcprops_t srcprops[1]; +} scm_srcprops_chunk_t; + +#if (SCM_DEBUG_DEPRECATED == 0) +# define scm_srcprops scm_srcprops_t +# define scm_srcprops_chunk scm_srcprops_chunk_t +#endif #define SCM_SOURCE_PROPERTY_FLAG_BREAK (1L << 16) #define SRCPROPSP(p) (SCM_TYP16_PREDICATE (scm_tc16_srcprops, p)) #define SRCPROPBRK(p) \ (SCM_BOOL (SCM_CELL_WORD_0 (p) & SCM_SOURCE_PROPERTY_FLAG_BREAK)) -#define SRCPROPPOS(p) ((scm_srcprops *) SCM_CELL_WORD_1 (p))->pos +#define SRCPROPPOS(p) ((scm_srcprops_t *) SCM_CELL_WORD_1 (p))->pos #define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12) #define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL) -#define SRCPROPFNAME(p) ((scm_srcprops *) SCM_CELL_WORD_1 (p))->fname -#define SRCPROPCOPY(p) ((scm_srcprops *) SCM_CELL_WORD_1 (p))->copy -#define SRCPROPPLIST(p) ((scm_srcprops *) SCM_CELL_WORD_1 (p))->plist +#define SRCPROPFNAME(p) ((scm_srcprops_t *) SCM_CELL_WORD_1 (p))->fname +#define SRCPROPCOPY(p) ((scm_srcprops_t *) SCM_CELL_WORD_1 (p))->copy +#define SRCPROPPLIST(p) ((scm_srcprops_t *) SCM_CELL_WORD_1 (p))->plist #define SETSRCPROPBRK(p) \ (SCM_SET_CELL_WORD_0 ((p), SCM_CELL_WORD_0 (p) \ | SCM_SOURCE_PROPERTY_FLAG_BREAK)) @@ -133,7 +138,7 @@ extern SCM scm_sym_breakpoint; extern SCM scm_srcprops_to_plist (SCM obj); -extern SCM scm_make_srcprops (int line, int col, SCM fname, SCM copy, SCM plist); +extern SCM scm_make_srcprops (long line, int col, SCM fname, SCM copy, SCM plist); extern SCM scm_source_property (SCM obj, SCM key); extern SCM scm_set_source_property_x (SCM obj, SCM key, SCM datum); extern SCM scm_source_properties (SCM obj); diff --git a/libguile/stackchk.c b/libguile/stackchk.c index bede70e86..e8971e322 100644 --- a/libguile/stackchk.c +++ b/libguile/stackchk.c @@ -72,7 +72,7 @@ scm_report_stack_overflow () #endif -long +long scm_stack_size (SCM_STACKITEM *start) { SCM_STACKITEM stack; diff --git a/libguile/stacks.c b/libguile/stacks.c index 63bbda07b..9085bec68 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -92,11 +92,11 @@ * Representation: * * The stack is represented as a struct with an id slot and a tail - * array of scm_info_frame structs. + * array of scm_info_frame_t structs. * * A frame is represented as a pair where the car contains a stack and * the cdr an inum. The inum is an index to the first SCM value of - * the scm_info_frame struct. + * the scm_info_frame_t struct. * * Stacks * Constructor @@ -129,7 +129,7 @@ */ /* Stacks often contain pointers to other items on the stack; for - example, each scm_debug_frame structure contains a pointer to the + example, each scm_debug_frame_t structure contains a pointer to the next frame out. When we capture a continuation, we copy the stack into the heap, and just leave all the pointers unchanged. This makes it simple to restore the continuation --- just copy the stack @@ -143,30 +143,30 @@ OFFSET) is a pointer to the copy in the continuation of the original referent, cast to an scm_debug_MUMBLE *. */ #define RELOC_INFO(ptr, offset) \ - ((scm_debug_info *) ((SCM_STACKITEM *) (ptr) + (offset))) + ((scm_debug_info_t *) ((SCM_STACKITEM *) (ptr) + (offset))) #define RELOC_FRAME(ptr, offset) \ - ((scm_debug_frame *) ((SCM_STACKITEM *) (ptr) + (offset))) + ((scm_debug_frame_t *) ((SCM_STACKITEM *) (ptr) + (offset))) /* Count number of debug info frames on a stack, beginning with * DFRAME. OFFSET is used for relocation of pointers when the stack * is read from a continuation. */ -static int -stack_depth (scm_debug_frame *dframe,long offset,SCM *id,int *maxp) +static scm_bits_t +stack_depth (scm_debug_frame_t *dframe,scm_bits_t offset,SCM *id,int *maxp) { - int n; - int max_depth = SCM_BACKTRACE_MAXDEPTH; + scm_bits_t n; + scm_bits_t max_depth = SCM_BACKTRACE_MAXDEPTH; for (n = 0; dframe && !SCM_VOIDFRAMEP (*dframe) && n < max_depth; dframe = RELOC_FRAME (dframe->prev, offset)) { if (SCM_EVALFRAMEP (*dframe)) { - scm_debug_info * info = RELOC_INFO (dframe->info, offset); + scm_debug_info_t * info = RELOC_INFO (dframe->info, offset); n += (info - dframe->vect) / 2 + 1; /* Data in the apply part of an eval info frame comes from previous - stack frame if the scm_debug_info vector is overflowed. */ + stack frame if the scm_debug_info_t vector is overflowed. */ if ((((info - dframe->vect) & 1) == 0) && SCM_OVERFLOWP (*dframe) && !SCM_UNBNDP (info[1].a.proc)) @@ -185,12 +185,12 @@ stack_depth (scm_debug_frame *dframe,long offset,SCM *id,int *maxp) /* Read debug info from DFRAME into IFRAME. */ static void -read_frame (scm_debug_frame *dframe,long offset,scm_info_frame *iframe) +read_frame (scm_debug_frame_t *dframe,scm_bits_t offset,scm_info_frame_t *iframe) { scm_bits_t flags = SCM_UNPACK (SCM_INUM0); /* UGh. */ if (SCM_EVALFRAMEP (*dframe)) { - scm_debug_info * info = RELOC_INFO (dframe->info, offset); + scm_debug_info_t * info = RELOC_INFO (dframe->info, offset); if ((info - dframe->vect) & 1) { /* Debug.vect ends with apply info. */ @@ -246,16 +246,16 @@ do { \ } while (0) -/* Fill the scm_info_frame vector IFRAME with data from N stack frames +/* Fill the scm_info_frame_t vector IFRAME with data from N stack frames * starting with the first stack frame represented by debug frame * DFRAME. */ -static int -read_frames (scm_debug_frame *dframe,long offset,int n,scm_info_frame *iframes) +static scm_bits_t +read_frames (scm_debug_frame_t *dframe,scm_bits_t offset,scm_bits_t n,scm_info_frame_t *iframes) { - scm_info_frame *iframe = iframes; - scm_debug_info *info; + scm_info_frame_t *iframe = iframes; + scm_debug_info_t *info; static SCM applybody = SCM_UNDEFINED; /* The value of applybody has to be setup after r4rs.scm has executed. */ @@ -280,7 +280,7 @@ read_frames (scm_debug_frame *dframe,long offset,int n,scm_info_frame *iframes) if ((info - dframe->vect) & 1) --info; /* Data in the apply part of an eval info frame comes from - previous stack frame if the scm_debug_info vector is overflowed. */ + previous stack frame if the scm_debug_info_t vector is overflowed. */ else if (SCM_OVERFLOWP (*dframe) && !SCM_UNBNDP (info[1].a.proc)) { @@ -345,11 +345,11 @@ read_frames (scm_debug_frame *dframe,long offset,int n,scm_info_frame *iframes) */ static void -narrow_stack (SCM stack,int inner,SCM inner_key,int outer,SCM outer_key) +narrow_stack (SCM stack,scm_bits_t inner,SCM inner_key,scm_bits_t outer,SCM outer_key) { - scm_stack *s = SCM_STACK (stack); - int i; - int n = s->length; + scm_stack_t *s = SCM_STACK (stack); + scm_bits_t i; + scm_bits_t n = s->length; /* Cut inner part. */ if (SCM_EQ_P (inner_key, SCM_BOOL_T)) @@ -421,10 +421,11 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, "resulting stack will be narrowed.") #define FUNC_NAME s_scm_make_stack { - int n, maxp, size; - scm_debug_frame *dframe = scm_last_debug_frame; - scm_info_frame *iframe; - long offset = 0; + scm_bits_t n, size; + int maxp; + scm_debug_frame_t *dframe = scm_last_debug_frame; + scm_info_frame_t *iframe; + scm_bits_t offset = 0; SCM stack, id; SCM inner_cut, outer_cut; @@ -436,10 +437,10 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, { SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, FUNC_NAME); if (SCM_DEBUGOBJP (obj)) - dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (obj); + dframe = (scm_debug_frame_t *) SCM_DEBUGOBJ_FRAME (obj); else if (SCM_CONTINUATIONP (obj)) { - offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (obj) + sizeof (scm_contregs)) + offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (obj) + sizeof (scm_contregs_t)) - SCM_BASE (obj)); #ifndef STACK_GROWS_UP offset += SCM_CONTINUATION_LENGTH (obj); @@ -512,18 +513,18 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0, "Return the identifier given to @var{stack} by @code{start-stack}.") #define FUNC_NAME s_scm_stack_id { - scm_debug_frame *dframe; - long offset = 0; + scm_debug_frame_t *dframe; + scm_bits_t offset = 0; if (SCM_EQ_P (stack, SCM_BOOL_T)) dframe = scm_last_debug_frame; else { SCM_VALIDATE_NIM (1,stack); if (SCM_DEBUGOBJP (stack)) - dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (stack); + dframe = (scm_debug_frame_t *) SCM_DEBUGOBJ_FRAME (stack); else if (SCM_CONTINUATIONP (stack)) { - offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (stack) + sizeof (scm_contregs)) + offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (stack) + sizeof (scm_contregs_t)) - SCM_BASE (stack)); #ifndef STACK_GROWS_UP offset += SCM_CONTINUATION_LENGTH (stack); @@ -586,16 +587,16 @@ SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0, "debug object or a continuation.") #define FUNC_NAME s_scm_last_stack_frame { - scm_debug_frame *dframe; - long offset = 0; + scm_debug_frame_t *dframe; + scm_bits_t offset = 0; SCM stack; SCM_VALIDATE_NIM (1,obj); if (SCM_DEBUGOBJP (obj)) - dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (obj); + dframe = (scm_debug_frame_t *) SCM_DEBUGOBJ_FRAME (obj); else if (SCM_CONTINUATIONP (obj)) { - offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (obj) + sizeof (scm_contregs)) + offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (obj) + sizeof (scm_contregs_t)) - SCM_BASE (obj)); #ifndef STACK_GROWS_UP offset += SCM_CONTINUATION_LENGTH (obj); @@ -616,7 +617,7 @@ SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0, SCM_STACK (stack) -> length = 1; SCM_STACK (stack) -> frames = &SCM_STACK (stack) -> tail[0]; read_frame (dframe, offset, - (scm_info_frame *) &SCM_STACK (stack) -> frames[0]); + (scm_info_frame_t *) &SCM_STACK (stack) -> frames[0]); return scm_cons (stack, SCM_INUM0);; } @@ -671,7 +672,7 @@ SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0, "@var{frame} is the first frame in its stack.") #define FUNC_NAME s_scm_frame_previous { - int n; + scm_bits_t n; SCM_VALIDATE_FRAME (1,frame); n = SCM_INUM (SCM_CDR (frame)) + 1; if (n >= SCM_STACK_LENGTH (SCM_CAR (frame))) @@ -687,7 +688,7 @@ SCM_DEFINE (scm_frame_next, "frame-next", 1, 0, 0, "@var{frame} is the last frame in its stack.") #define FUNC_NAME s_scm_frame_next { - int n; + scm_bits_t n; SCM_VALIDATE_FRAME (1,frame); n = SCM_INUM (SCM_CDR (frame)) - 1; if (n < 0) diff --git a/libguile/stacks.h b/libguile/stacks.h index fda1f1b00..b596f87cf 100644 --- a/libguile/stacks.h +++ b/libguile/stacks.h @@ -55,24 +55,29 @@ /* {Frames and stacks} */ -typedef struct scm_info_frame { +typedef struct scm_info_frame_t { /* SCM flags; */ scm_bits_t flags; SCM source; SCM proc; SCM args; -} scm_info_frame; -#define SCM_FRAME_N_SLOTS (sizeof (scm_info_frame) / sizeof (SCM)) +} scm_info_frame_t; +#define SCM_FRAME_N_SLOTS (sizeof (scm_info_frame_t) / sizeof (SCM)) -#define SCM_STACK(obj) ((scm_stack *) SCM_STRUCT_DATA (obj)) +#define SCM_STACK(obj) ((scm_stack_t *) SCM_STRUCT_DATA (obj)) #define SCM_STACK_LAYOUT "pwuourpW" -typedef struct scm_stack { +typedef struct scm_stack_t { SCM id; /* Stack id */ - scm_info_frame *frames; /* Info frames */ - unsigned int length; /* Stack length */ - unsigned int tail_length; - scm_info_frame tail[1]; -} scm_stack; + scm_info_frame_t *frames; /* Info frames */ + scm_bits_t length; /* Stack length */ + scm_bits_t tail_length; + scm_info_frame_t tail[1]; +} scm_stack_t; + +#if (SCM_DEBUG_DEPRECATED == 0) +# define scm_info_frame scm_info_frame_t +# define scm_stack scm_stack_t +#endif extern SCM scm_stack_type; diff --git a/libguile/strings.c b/libguile/strings.c index 792b0f8af..c2ab44166 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -96,7 +96,7 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1, SCM result; { - long i = scm_ilength (chrs); + scm_bits_t i = scm_ilength (chrs); SCM_ASSERT (i >= 0, chrs, SCM_ARGn, FUNC_NAME); result = scm_allocate_string (i); @@ -121,7 +121,7 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1, #if (SCM_DEBUG_DEPRECATED == 0) SCM -scm_makstr (long len, int dummy) +scm_makstr (size_t len, int dummy) #define FUNC_NAME "scm_makstr" { SCM s; @@ -153,7 +153,7 @@ scm_makfromstrs (int argc, char **argv) if (0 > i) for (i = 0; argv[i]; i++); while (i--) - lst = scm_cons (scm_makfromstr (argv[i], (scm_sizet) strlen (argv[i]), 0), lst); + lst = scm_cons (scm_makfromstr (argv[i], (size_t) strlen (argv[i]), 0), lst); return lst; } @@ -167,7 +167,7 @@ scm_makfromstrs (int argc, char **argv) strings by claiming they're shared substrings of a string we just made up. */ SCM -scm_take_str (char *s, int len) +scm_take_str (char *s, size_t len) #define FUNC_NAME "scm_take_str" { SCM answer; @@ -192,7 +192,7 @@ scm_take0str (char *s) } SCM -scm_makfromstr (const char *src, scm_sizet len, int dummy) +scm_makfromstr (const char *src, size_t len, int dummy) { SCM s = scm_allocate_string (len); char *dst = SCM_STRING_CHARS (s); @@ -206,7 +206,7 @@ SCM scm_makfrom0str (const char *src) { if (!src) return SCM_BOOL_F; - return scm_makfromstr (src, (scm_sizet) strlen (src), 0); + return scm_makfromstr (src, (size_t) strlen (src), 0); } @@ -218,7 +218,7 @@ scm_makfrom0str_opt (const char *src) SCM -scm_allocate_string (scm_sizet len) +scm_allocate_string (size_t len) #define FUNC_NAME "scm_allocate_string" { char *mem; @@ -248,7 +248,7 @@ SCM_DEFINE (scm_make_string, "make-string", 1, 1, 0, { if (SCM_INUMP (k)) { - long int i = SCM_INUM (k); + scm_bits_t i = SCM_INUM (k); SCM res; SCM_ASSERT_RANGE (1, k, i >= 0); @@ -290,7 +290,7 @@ SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0, "indexing. @var{k} must be a valid index of @var{str}.") #define FUNC_NAME s_scm_string_ref { - int idx; + scm_bits_t idx; SCM_VALIDATE_STRING (1, str); SCM_VALIDATE_INUM_COPY (2, k, idx); @@ -330,8 +330,8 @@ SCM_DEFINE (scm_substring, "substring", 2, 1, 0, "0 <= @var{start} <= @var{end} <= (string-length @var{str}).") #define FUNC_NAME s_scm_substring { - long int from; - long int to; + scm_bits_t from; + scm_bits_t to; SCM_VALIDATE_STRING (1, str); SCM_VALIDATE_INUM (2, start); @@ -342,7 +342,7 @@ SCM_DEFINE (scm_substring, "substring", 2, 1, 0, to = SCM_INUM (end); SCM_ASSERT_RANGE (3, end, from <= to && to <= SCM_STRING_LENGTH (str)); - return scm_makfromstr (&SCM_STRING_CHARS (str)[from], (scm_sizet) (to - from), 0); + return scm_makfromstr (&SCM_STRING_CHARS (str)[from], (size_t) (to - from), 0); } #undef FUNC_NAME @@ -354,7 +354,7 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, #define FUNC_NAME s_scm_string_append { SCM res; - register long i = 0; + size_t i = 0; register SCM l, s; register unsigned char *data; @@ -393,8 +393,8 @@ SCM_DEFINE (scm_make_shared_substring, "make-shared-substring", 1, 2, 0, "occupies the same storage space as @var{str}.") #define FUNC_NAME s_scm_make_shared_substring { - long f; - long t; + scm_bits_t f; + scm_bits_t t; SCM answer; SCM len_str; @@ -411,7 +411,7 @@ SCM_DEFINE (scm_make_shared_substring, "make-shared-substring", 1, 2, 0, SCM_DEFER_INTS; if (SCM_SUBSTRP (str)) { - long offset; + scm_bits_t offset; offset = SCM_INUM (SCM_SUBSTR_OFFSET (str)); f += offset; t += offset; diff --git a/libguile/strings.h b/libguile/strings.h index a96e8de55..608467d52 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -58,7 +58,7 @@ #endif #define SCM_SET_STRING_CHARS(s, c) (SCM_SET_CELL_WORD_1 ((s), (c))) #define SCM_STRING_MAX_LENGTH ((1L << 24) - 1) -#define SCM_STRING_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) +#define SCM_STRING_LENGTH(x) (((size_t) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_SET_STRING_LENGTH(s, l) (SCM_SET_CELL_WORD_0 ((s), ((l) << 8) + scm_tc7_string)) #define SCM_STRING_COERCE_0TERMINATION_X(x) \ @@ -71,12 +71,12 @@ extern SCM scm_string_p (SCM x); extern SCM scm_read_only_string_p (SCM x); extern SCM scm_string (SCM chrs); extern SCM scm_makfromstrs (int argc, char **argv); -extern SCM scm_take_str (char *s, int len); +extern SCM scm_take_str (char *s, size_t len); extern SCM scm_take0str (char *s); -extern SCM scm_makfromstr (const char *src, scm_sizet len, int); +extern SCM scm_makfromstr (const char *src, size_t len, int); extern SCM scm_makfrom0str (const char *src); extern SCM scm_makfrom0str_opt (const char *src); -extern SCM scm_allocate_string (scm_sizet len); +extern SCM scm_allocate_string (size_t len); extern SCM scm_make_string (SCM k, SCM chr); extern SCM scm_string_length (SCM str); extern SCM scm_string_ref (SCM str, SCM k); @@ -100,7 +100,7 @@ extern void scm_init_strings (void); ? (char *) SCM_CELL_WORD_1 (SCM_CDDR (x)) + SCM_INUM (SCM_CADR (x)) \ : (char *) SCM_CELL_WORD_1 (x)) extern SCM scm_make_shared_substring (SCM str, SCM frm, SCM to); -extern SCM scm_makstr (long len, int); +extern SCM scm_makstr (size_t len, int); #endif /* SCM_DEBUG_DEPRECATED == 0 */ diff --git a/libguile/strop.c b/libguile/strop.c index 2cf4c0221..4efb95599 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -48,14 +48,14 @@ xSCM_DEFINE (scm_i_index, "i-index", 2, 2, 0, "@code{rindex} function, depending on the value of @var{direction}." */ /* implements index if direction > 0 otherwise rindex. */ -static int +static scm_bits_t scm_i_index (SCM *str, SCM chr, int direction, SCM sub_start, SCM sub_end, const char *why) { unsigned char * p; - int x; - int lower; - int upper; + scm_bits_t x; + scm_bits_t lower; + scm_bits_t upper; int ch; SCM_ASSERT (SCM_STRINGP (*str), *str, SCM_ARG1, why); @@ -116,7 +116,7 @@ SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0, "@end lisp") #define FUNC_NAME s_scm_string_index { - int pos; + scm_bits_t pos; if (SCM_UNBNDP (frm)) frm = SCM_BOOL_F; @@ -146,7 +146,7 @@ SCM_DEFINE (scm_string_rindex, "string-rindex", 2, 2, 0, "@end lisp") #define FUNC_NAME s_scm_string_rindex { - int pos; + scm_bits_t pos; if (SCM_UNBNDP (frm)) frm = SCM_BOOL_F; @@ -238,7 +238,7 @@ SCM_DEFINE (scm_substring_move_x, "substring-move!", 5, 0, 0, "are different strings, it does not matter which function you use.") #define FUNC_NAME s_scm_substring_move_x { - long s1, s2, e, len; + scm_bits_t s1, s2, e, len; SCM_VALIDATE_STRING (1,str1); SCM_VALIDATE_INUM_COPY (2,start1,s1); @@ -274,7 +274,7 @@ SCM_DEFINE (scm_substring_fill_x, "substring-fill!", 4, 0, 0, "@end lisp") #define FUNC_NAME s_scm_substring_fill_x { - long i, e; + scm_bits_t i, e; char c; SCM_VALIDATE_STRING (1,str); SCM_VALIDATE_INUM_COPY (2,start,i); @@ -313,7 +313,7 @@ SCM_DEFINE (scm_string_to_list, "string->list", 1, 0, 0, "concerned.") #define FUNC_NAME s_scm_string_to_list { - long i; + scm_bits_t i; SCM res = SCM_EOL; unsigned char *src; SCM_VALIDATE_STRING (1,str); @@ -352,7 +352,7 @@ SCM_DEFINE (scm_string_fill_x, "string-fill!", 2, 0, 0, #define FUNC_NAME s_scm_string_fill_x { register char *dst, c; - register long k; + register scm_bits_t k; SCM_VALIDATE_STRING_COPY (1,str,dst); SCM_VALIDATE_CHAR_COPY (2,chr,c); for (k = SCM_STRING_LENGTH (str)-1;k >= 0;k--) dst[k] = c; @@ -366,7 +366,7 @@ SCM_DEFINE (scm_string_fill_x, "string-fill!", 2, 0, 0, static SCM string_upcase_x (SCM v) { - unsigned long k; + scm_bits_t k; for (k = 0; k < SCM_STRING_LENGTH (v); ++k) SCM_STRING_UCHARS (v) [k] = scm_upcase (SCM_STRING_UCHARS (v) [k]); @@ -411,7 +411,7 @@ SCM_DEFINE (scm_string_upcase, "string-upcase", 1, 0, 0, static SCM string_downcase_x (SCM v) { - unsigned long k; + scm_bits_t k; for (k = 0; k < SCM_STRING_LENGTH (v); ++k) SCM_STRING_UCHARS (v) [k] = scm_downcase (SCM_STRING_UCHARS (v) [k]); @@ -457,7 +457,8 @@ static SCM string_capitalize_x (SCM str) { char *sz; - int i, len, in_word=0; + scm_bits_t i, len; + int in_word=0; len = SCM_STRING_LENGTH(str); sz = SCM_STRING_CHARS (str); @@ -531,7 +532,7 @@ SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0, "@end lisp") #define FUNC_NAME s_scm_string_split { - int idx, last_idx; + scm_bits_t idx, last_idx; char * p; int ch; SCM res = SCM_EOL; diff --git a/libguile/strorder.c b/libguile/strorder.c index bbf4ba30f..c50a2469b 100644 --- a/libguile/strorder.c +++ b/libguile/strorder.c @@ -64,7 +64,7 @@ SCM_DEFINE1 (scm_string_equal_p, "string=?", scm_tc7_rpsubr, "characters.") #define FUNC_NAME s_scm_string_equal_p { - scm_sizet length; + size_t length; SCM_VALIDATE_STRING (1, s1); SCM_VALIDATE_STRING (2, s2); @@ -74,7 +74,7 @@ SCM_DEFINE1 (scm_string_equal_p, "string=?", scm_tc7_rpsubr, { unsigned char *c1 = SCM_STRING_UCHARS (s1) + length - 1; unsigned char *c2 = SCM_STRING_UCHARS (s2) + length - 1; - scm_sizet i; + size_t i; /* comparing from back to front typically finds mismatches faster */ for (i = 0; i != length; ++i, --c1, --c2) @@ -99,7 +99,7 @@ SCM_DEFINE1 (scm_string_ci_equal_p, "string-ci=?", scm_tc7_rpsubr, "return @code{#f}.") #define FUNC_NAME s_scm_string_ci_equal_p { - scm_sizet length; + size_t length; SCM_VALIDATE_STRING (1, s1); SCM_VALIDATE_STRING (2, s2); @@ -109,7 +109,7 @@ SCM_DEFINE1 (scm_string_ci_equal_p, "string-ci=?", scm_tc7_rpsubr, { unsigned char *c1 = SCM_STRING_UCHARS (s1) + length - 1; unsigned char *c2 = SCM_STRING_UCHARS (s2) + length - 1; - scm_sizet i; + size_t i; /* comparing from back to front typically finds mismatches faster */ for (i = 0; i != length; ++i, --c1, --c2) @@ -131,7 +131,7 @@ SCM_DEFINE1 (scm_string_ci_equal_p, "string-ci=?", scm_tc7_rpsubr, static SCM string_less_p (SCM s1, SCM s2) { - scm_sizet i, length1, length2, lengthm; + size_t i, length1, length2, lengthm; unsigned char *c1, *c2; length1 = SCM_STRING_LENGTH (s1); @@ -211,7 +211,7 @@ SCM_DEFINE1 (scm_string_geq_p, "string>=?", scm_tc7_rpsubr, static SCM string_ci_less_p (SCM s1, SCM s2) { - scm_sizet i, length1, length2, lengthm; + size_t i, length1, length2, lengthm; unsigned char *c1, *c2; length1 = SCM_STRING_LENGTH (s1); diff --git a/libguile/strports.c b/libguile/strports.c index 3a8faaa51..4fb102664 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -86,7 +86,7 @@ scm_bits_t scm_tc16_strport; static int stfill_buffer (SCM port) { - scm_port *pt = SCM_PTAB_ENTRY (port); + scm_port_t *pt = SCM_PTAB_ENTRY (port); if (pt->read_pos >= pt->read_end) return EOF; @@ -97,13 +97,13 @@ stfill_buffer (SCM port) /* change the size of a port's string to new_size. this doesn't change read_buf_size. */ static void -st_resize_port (scm_port *pt, off_t new_size) +st_resize_port (scm_port_t *pt, off_t new_size) { SCM old_stream = SCM_PACK (pt->stream); SCM new_stream = scm_allocate_string (new_size); - unsigned long int old_size = SCM_STRING_LENGTH (old_stream); - unsigned long int min_size = min (old_size, new_size); - unsigned long int i; + size_t old_size = SCM_STRING_LENGTH (old_stream); + size_t min_size = min (old_size, new_size); + size_t i; off_t index = pt->write_pos - pt->write_buf; @@ -130,7 +130,7 @@ st_resize_port (scm_port *pt, off_t new_size) static void st_flush (SCM port) { - scm_port *pt = SCM_PTAB_ENTRY (port); + scm_port_t *pt = SCM_PTAB_ENTRY (port); if (pt->write_pos == pt->write_end) { @@ -148,7 +148,7 @@ st_flush (SCM port) static void st_write (SCM port, const void *data, size_t size) { - scm_port *pt = SCM_PTAB_ENTRY (port); + scm_port_t *pt = SCM_PTAB_ENTRY (port); const char *input = (char *) data; while (size > 0) @@ -168,7 +168,7 @@ st_write (SCM port, const void *data, size_t size) static void st_end_input (SCM port, int offset) { - scm_port *pt = SCM_PTAB_ENTRY (port); + scm_port_t *pt = SCM_PTAB_ENTRY (port); if (pt->read_pos - pt->read_buf < offset) scm_misc_error ("st_end_input", "negative position", SCM_EOL); @@ -180,7 +180,7 @@ st_end_input (SCM port, int offset) static off_t st_seek (SCM port, off_t offset, int whence) { - scm_port *pt = SCM_PTAB_ENTRY (port); + scm_port_t *pt = SCM_PTAB_ENTRY (port); off_t target; if (pt->rw_active == SCM_PORT_READ && offset == 0 && whence == SEEK_CUR) @@ -252,7 +252,7 @@ st_seek (SCM port, off_t offset, int whence) static void st_truncate (SCM port, off_t length) { - scm_port *pt = SCM_PTAB_ENTRY (port); + scm_port_t *pt = SCM_PTAB_ENTRY (port); if (length > pt->write_buf_size) st_resize_port (pt, length); @@ -270,8 +270,8 @@ SCM scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) { SCM z; - scm_port *pt; - int str_len; + scm_port_t *pt; + size_t str_len; SCM_ASSERT (SCM_INUMP(pos) && SCM_INUM(pos) >= 0, pos, SCM_ARG1, caller); SCM_ASSERT (SCM_STRINGP (str), str, SCM_ARG1, caller); @@ -304,7 +304,7 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) /* create a new string from a string port's buffer. */ SCM scm_strport_to_string (SCM port) { - scm_port *pt = SCM_PTAB_ENTRY (port); + scm_port_t *pt = SCM_PTAB_ENTRY (port); if (pt->rw_active == SCM_PORT_WRITE) st_flush (port); diff --git a/libguile/struct.c b/libguile/struct.c index 4e8db5d17..5710f4080 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -84,7 +84,7 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, { /* scope */ char * field_desc; - scm_sizet len; + size_t len; int x; len = SCM_STRING_LENGTH (fields); @@ -331,20 +331,20 @@ scm_alloc_struct (int n_words, int n_extra, char *who) return p; } -scm_sizet +size_t scm_struct_free_0 (scm_bits_t * vtable, scm_bits_t * data) { return 0; } -scm_sizet +size_t scm_struct_free_light (scm_bits_t * vtable, scm_bits_t * data) { scm_must_free (data); return vtable [scm_struct_i_size] & ~SCM_STRUCTF_MASK; } -scm_sizet +size_t scm_struct_free_standard (scm_bits_t * vtable, scm_bits_t * data) { size_t n = (data[scm_struct_i_n_words] + scm_struct_n_extra_words) @@ -353,7 +353,7 @@ scm_struct_free_standard (scm_bits_t * vtable, scm_bits_t * data) return n; } -scm_sizet +size_t scm_struct_free_entity (scm_bits_t * vtable, scm_bits_t * data) { size_t n = (data[scm_struct_i_n_words] + scm_struct_entity_n_extra_words) @@ -736,8 +736,8 @@ SCM_DEFINE (scm_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0, * how to associate names with vtables. */ -unsigned int -scm_struct_ihashq (SCM obj, unsigned int n) +scm_bits_t +scm_struct_ihashq (SCM obj, scm_bits_t n) { /* The length of the hash table should be a relative prime it's not necessary to shift down the address. */ diff --git a/libguile/struct.h b/libguile/struct.h index 7c784eb3b..b66db2122 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -70,7 +70,7 @@ #define scm_vtable_index_printer 3 /* A printer for this struct type. */ #define scm_vtable_offset_user 4 /* Where do user fields start? */ -typedef scm_sizet (*scm_struct_free_t) (scm_bits_t * vtable, scm_bits_t * data); +typedef size_t (*scm_struct_free_t) (scm_bits_t * vtable, scm_bits_t * data); #define SCM_STRUCTF_MASK (0xFFF << 20) #define SCM_STRUCTF_ENTITY (1L << 30) /* Indicates presence of proc slots */ @@ -106,10 +106,10 @@ extern SCM scm_structs_to_free; extern scm_bits_t * scm_alloc_struct (int n_words, int n_extra, char * who); -extern scm_sizet scm_struct_free_0 (scm_bits_t * vtable, scm_bits_t * data); -extern scm_sizet scm_struct_free_light (scm_bits_t * vtable, scm_bits_t * data); -extern scm_sizet scm_struct_free_standard (scm_bits_t * vtable, scm_bits_t * data); -extern scm_sizet scm_struct_free_entity (scm_bits_t * vtable, scm_bits_t * data); +extern size_t scm_struct_free_0 (scm_bits_t * vtable, scm_bits_t * data); +extern size_t scm_struct_free_light (scm_bits_t * vtable, scm_bits_t * data); +extern size_t scm_struct_free_standard (scm_bits_t * vtable, scm_bits_t * data); +extern size_t scm_struct_free_entity (scm_bits_t * vtable, scm_bits_t * data); extern SCM scm_make_struct_layout (SCM fields); extern SCM scm_struct_p (SCM x); extern SCM scm_struct_vtable_p (SCM x); @@ -119,7 +119,7 @@ extern SCM scm_struct_ref (SCM handle, SCM pos); extern SCM scm_struct_set_x (SCM handle, SCM pos, SCM val); extern SCM scm_struct_vtable (SCM handle); extern SCM scm_struct_vtable_tag (SCM handle); -extern unsigned int scm_struct_ihashq (SCM obj, unsigned int n); +extern scm_bits_t scm_struct_ihashq (SCM obj, scm_bits_t n); extern SCM scm_struct_create_handle (SCM obj); extern SCM scm_struct_vtable_name (SCM vtable); extern SCM scm_set_struct_vtable_name_x (SCM vtable, SCM name); diff --git a/libguile/symbols-deprecated.c b/libguile/symbols-deprecated.c index 49ba28799..63dfdbd0d 100644 --- a/libguile/symbols-deprecated.c +++ b/libguile/symbols-deprecated.c @@ -78,7 +78,7 @@ SCM scm_sym2ovcell_soft (SCM sym, SCM obarray) { SCM lsym, z; - scm_sizet hash = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (obarray); + size_t hash = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (obarray); scm_c_issue_deprecation_warning ("`scm_sym2ovcell_soft' is deprecated. " "Use hashtables instead."); @@ -139,11 +139,11 @@ scm_sym2ovcell (SCM sym, SCM obarray) SCM -scm_intern_obarray_soft (const char *name,scm_sizet len,SCM obarray,unsigned int softness) +scm_intern_obarray_soft (const char *name,size_t len,SCM obarray,unsigned int softness) { SCM symbol = scm_mem2symbol (name, len); - scm_sizet raw_hash = SCM_SYMBOL_HASH (symbol); - scm_sizet hash; + size_t raw_hash = SCM_SYMBOL_HASH (symbol); + size_t hash; SCM lsym; scm_c_issue_deprecation_warning ("`scm_intern_obarray_soft' is deprecated. " @@ -184,7 +184,7 @@ scm_intern_obarray_soft (const char *name,scm_sizet len,SCM obarray,unsigned int SCM -scm_intern_obarray (const char *name,scm_sizet len,SCM obarray) +scm_intern_obarray (const char *name,size_t len,SCM obarray) { scm_c_issue_deprecation_warning ("`scm_intern_obarray' is deprecated. " "Use hashtables instead."); @@ -194,7 +194,7 @@ scm_intern_obarray (const char *name,scm_sizet len,SCM obarray) SCM -scm_intern (const char *name,scm_sizet len) +scm_intern (const char *name,size_t len) { scm_c_issue_deprecation_warning ("`scm_intern' is deprecated. " "Use scm_c_define or scm_c_lookup instead."); @@ -328,7 +328,7 @@ SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0, "with this name is already present.") #define FUNC_NAME s_scm_intern_symbol { - scm_sizet hval; + size_t hval; SCM_VALIDATE_SYMBOL (2,s); if (SCM_FALSEP (o)) return SCM_UNSPECIFIED; @@ -369,7 +369,7 @@ SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0, "otherwise.") #define FUNC_NAME s_scm_unintern_symbol { - scm_sizet hval; + size_t hval; scm_c_issue_deprecation_warning ("`unintern-symbol' is deprecated. " "Use hashtables instead."); diff --git a/libguile/symbols.c b/libguile/symbols.c index d46085a09..6a463f914 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -87,10 +87,10 @@ SCM_DEFINE (scm_sys_symbols, "%symbols", 0, 0, 0, SCM -scm_mem2symbol (const char *name, scm_sizet len) +scm_mem2symbol (const char *name, size_t len) { - scm_sizet raw_hash = scm_string_hash ((const unsigned char *) name, len); - scm_sizet hash = raw_hash % SCM_VECTOR_LENGTH (symbols); + size_t raw_hash = scm_string_hash ((const unsigned char *) name, len); + size_t hash = raw_hash % SCM_VECTOR_LENGTH (symbols); { /* Try to find the symbol in the symbols table */ @@ -104,7 +104,7 @@ scm_mem2symbol (const char *name, scm_sizet len) && SCM_SYMBOL_LENGTH (sym) == len) { char *chrs = SCM_SYMBOL_CHARS (sym); - scm_sizet i = len; + size_t i = len; while (i != 0) { @@ -236,7 +236,7 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, { char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; char *name = buf; - int len; + size_t len; if (SCM_UNBNDP (prefix)) { name[0] = 'g'; diff --git a/libguile/symbols.h b/libguile/symbols.h index 1d10b371e..fe4870b0e 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -55,11 +55,11 @@ */ #define SCM_SYMBOLP(x) (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_symbol)) -#define SCM_SYMBOL_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) +#define SCM_SYMBOL_LENGTH(x) (((scm_ubits_t) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_SET_SYMBOL_LENGTH(s, l) (SCM_SET_CELL_WORD_0 ((s), ((l) << 8) + scm_tc7_symbol)) #define SCM_SYMBOL_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) #define SCM_SET_SYMBOL_CHARS(s, c) (SCM_SET_CELL_WORD_1 ((s), (c))) -#define SCM_SYMBOL_HASH(X) ((unsigned long) SCM_CELL_WORD_2 (X)) +#define SCM_SYMBOL_HASH(X) ((scm_ubits_t) SCM_CELL_WORD_2 (X)) #define SCM_SET_SYMBOL_HASH(X, v) (SCM_SET_CELL_WORD_2 ((X), (v))) #define SCM_PROP_SLOTS(X) (SCM_CELL_WORD_3 (X)) @@ -74,7 +74,7 @@ #ifdef GUILE_DEBUG extern SCM scm_sys_symbols (void); #endif -extern SCM scm_mem2symbol (const char*, scm_sizet); +extern SCM scm_mem2symbol (const char*, size_t); extern SCM scm_str2symbol (const char*); extern SCM scm_symbol_p (SCM x); @@ -103,7 +103,7 @@ extern void scm_init_symbols (void); #define SCM_SUBSTR_STR(x) (SCM_CDDR (x)) #define SCM_SUBSTR_OFFSET(x) (SCM_CADR (x)) #define SCM_LENGTH_MAX (0xffffffL) -#define SCM_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) +#define SCM_LENGTH(x) (((scm_ubits_t) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_SETLENGTH(x, v, t) (SCM_SET_CELL_WORD_0 ((x), ((v) << 8) + (t))) #define SCM_ROSTRINGP(x) (SCM_NIMP(x) && ((SCM_TYP7S(x)==scm_tc7_string) \ || (SCM_TYP7(x) == scm_tc7_symbol))) @@ -129,9 +129,9 @@ extern void scm_init_symbols (void); extern SCM scm_sym2vcell (SCM sym, SCM thunk, SCM definep); extern SCM scm_sym2ovcell_soft (SCM sym, SCM obarray); extern SCM scm_sym2ovcell (SCM sym, SCM obarray); -extern SCM scm_intern_obarray_soft (const char *name, scm_sizet len, SCM obarray, unsigned int softness); -extern SCM scm_intern_obarray (const char *name, scm_sizet len, SCM obarray); -extern SCM scm_intern (const char *name, scm_sizet len); +extern SCM scm_intern_obarray_soft (const char *name, size_t len, SCM obarray, unsigned int softness); +extern SCM scm_intern_obarray (const char *name, size_t len, SCM obarray); +extern SCM scm_intern (const char *name, size_t len); extern SCM scm_intern0 (const char *name); extern SCM scm_sysintern (const char *name, SCM val); extern SCM scm_sysintern0 (const char *name); diff --git a/libguile/tags.h b/libguile/tags.h index e64ad4c35..eebe63e75 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -58,7 +58,8 @@ /* In the beginning was the Word: */ -typedef long scm_bits_t; +typedef SCM_BITS_T scm_bits_t; +typedef SCM_UBITS_T scm_ubits_t; /* But as external interface, we use SCM, which may, according to the desired * level of type checking, be defined in several ways: diff --git a/libguile/throw.c b/libguile/throw.c index 677b6bdc0..63af28650 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -79,7 +79,7 @@ static scm_bits_t tc16_jmpbuffer; #define JBJMPBUF(OBJ) ((jmp_buf *) SCM_CELL_WORD_1 (OBJ)) #define SETJBJMPBUF(x,v) (SCM_SET_CELL_WORD_1 ((x), (v))) #ifdef DEBUG_EXTENSIONS -#define SCM_JBDFRAME(x) ((scm_debug_frame *) SCM_CELL_WORD_2 (x)) +#define SCM_JBDFRAME(x) ((scm_debug_frame_t *) SCM_CELL_WORD_2 (x)) #define SCM_SETJBDFRAME(x,v) (SCM_SET_CELL_WORD_2 ((x), (v))) #endif diff --git a/libguile/unif.c b/libguile/unif.c index afb0a0cf2..daa74bd3f 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -93,14 +93,16 @@ scm_bits_t scm_tc16_array; /* return the size of an element in a uniform array or 0 if type not found. */ -scm_sizet +size_t scm_uniform_element_size (SCM obj) { - scm_sizet result; + size_t result; switch (SCM_TYP7 (obj)) { case scm_tc7_bvect: + result = sizeof (scm_bits_t); + break; case scm_tc7_uvect: case scm_tc7_ivect: result = sizeof (long); @@ -116,7 +118,7 @@ scm_uniform_element_size (SCM obj) #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: - result = sizeof (long_long); + result = sizeof (long long); break; #endif @@ -154,20 +156,32 @@ singp (SCM obj) } } +#if (SIZEOF_SIZE_T < SCM_SIZEOF_BITS_T) +# define CHECK_BYTE_SIZE(s,k) SCM_ASSERT_RANGE (1, scm_bits2num (k), k <= (size_t)(~(size_t)0)) +#else +# define CHECK_BYTE_SIZE(s,k) +#endif + SCM -scm_make_uve (long k, SCM prot) +scm_make_uve (scm_bits_t k, SCM prot) #define FUNC_NAME "scm_make_uve" { SCM v; - long i, type; + size_t i; + scm_bits_t type; + scm_ubits_t size_in_bytes; if (SCM_EQ_P (prot, SCM_BOOL_T)) { SCM_NEWCELL (v); if (k > 0) { - SCM_ASSERT_RANGE (1, scm_long2num (k), k <= SCM_BITVECTOR_MAX_LENGTH); - i = sizeof (long) * ((k + SCM_LONG_BIT - 1) / SCM_LONG_BIT); + SCM_ASSERT_RANGE (1, scm_bits2num (k), + k <= SCM_BITVECTOR_MAX_LENGTH); + size_in_bytes = sizeof (scm_bits_t) * ((k + SCM_BITS_LENGTH - 1) / + SCM_BITS_LENGTH); + CHECK_BYTE_SIZE (size_in_bytes, k); + i = (size_t) size_in_bytes; SCM_SET_BITVECTOR_BASE (v, (char *) scm_must_malloc (i, "vector")); SCM_SET_BITVECTOR_LENGTH (v, k); } @@ -180,17 +194,19 @@ scm_make_uve (long k, SCM prot) } else if (SCM_CHARP (prot) && (SCM_CHAR (prot) == '\0')) { - i = sizeof (char) * k; + size_in_bytes = sizeof (char) * k; type = scm_tc7_byvect; } else if (SCM_CHARP (prot)) { - i = sizeof (char) * k; + size_in_bytes = sizeof (char) * k; + CHECK_BYTE_SIZE (size_in_bytes, k); + i = (size_t) size_in_bytes; return scm_allocate_string (i); } else if (SCM_INUMP (prot)) { - i = sizeof (long) * k; + size_in_bytes = sizeof (long) * k; if (SCM_INUM (prot) > 0) type = scm_tc7_uvect; else @@ -203,13 +219,13 @@ scm_make_uve (long k, SCM prot) s = SCM_SYMBOL_CHARS (prot)[0]; if (s == 's') { - i = sizeof (short) * k; + size_in_bytes = sizeof (short) * k; type = scm_tc7_svect; } #ifdef HAVE_LONG_LONGS else if (s == 'l') { - i = sizeof (long_long) * k; + size_in_bytes = sizeof (long long) * k; type = scm_tc7_llvect; } #endif @@ -217,6 +233,7 @@ scm_make_uve (long k, SCM prot) { return scm_c_make_vector (k, SCM_UNDEFINED); } + } else if (!SCM_INEXACTP (prot)) /* Huge non-unif vectors are NOT supported. */ @@ -224,21 +241,24 @@ scm_make_uve (long k, SCM prot) return scm_c_make_vector (k, SCM_UNDEFINED); else if (singp (prot)) { - i = sizeof (float) * k; + size_in_bytes = sizeof (float) * k; type = scm_tc7_fvect; } else if (SCM_COMPLEXP (prot)) { - i = 2 * sizeof (double) * k; + size_in_bytes = 2 * sizeof (double) * k; type = scm_tc7_cvect; } else { - i = sizeof (double) * k; + size_in_bytes = sizeof (double) * k; type = scm_tc7_dvect; } - SCM_ASSERT_RANGE (1, scm_long2num (k), k <= SCM_UVECTOR_MAX_LENGTH); + CHECK_BYTE_SIZE (size_in_bytes, k); + i = (size_t) size_in_bytes; + + SCM_ASSERT_RANGE (1, scm_bits2num (k), k <= SCM_UVECTOR_MAX_LENGTH); SCM_NEWCELL (v); SCM_DEFER_INTS; @@ -399,8 +419,8 @@ SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0, #define FUNC_NAME s_scm_array_dimensions { SCM res = SCM_EOL; - scm_sizet k; - scm_array_dim *s; + size_t k; + scm_array_dim_t *s; if (SCM_IMP (ra)) return SCM_BOOL_F; switch (SCM_TYP7 (ra)) @@ -468,8 +488,8 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0, #define FUNC_NAME s_scm_shared_array_increments { SCM res = SCM_EOL; - scm_sizet k; - scm_array_dim *s; + size_t k; + scm_array_dim_t *s; SCM_ASSERT (SCM_ARRAYP (ra), ra, SCM_ARG1, FUNC_NAME); k = SCM_ARRAY_NDIM (ra); s = SCM_ARRAY_DIMS (ra); @@ -483,22 +503,22 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0, static char s_bad_ind[] = "Bad scm_array index"; -long +scm_bits_t scm_aind (SCM ra, SCM args, const char *what) #define FUNC_NAME what { SCM ind; - register long j; - register scm_sizet pos = SCM_ARRAY_BASE (ra); - register scm_sizet k = SCM_ARRAY_NDIM (ra); - scm_array_dim *s = SCM_ARRAY_DIMS (ra); + register scm_bits_t j; + register scm_bits_t pos = SCM_ARRAY_BASE (ra); + register size_t k = SCM_ARRAY_NDIM (ra); + scm_array_dim_t *s = SCM_ARRAY_DIMS (ra); if (SCM_INUMP (args)) { if (k != 1) scm_error_num_args_subr (what); return pos + (SCM_INUM (args) - s->lbnd) * (s->inc); } - while (k && SCM_NIMP (args)) + while (k && !SCM_NULLP (args)) { ind = SCM_CAR (args); args = SCM_CDR (args); @@ -525,8 +545,8 @@ scm_make_ra (int ndim) SCM ra; SCM_NEWCELL (ra); SCM_DEFER_INTS; - SCM_NEWSMOB(ra, ((long) ndim << 17) + scm_tc16_array, - scm_must_malloc ((long) (sizeof (scm_array) + ndim * sizeof (scm_array_dim)), + SCM_NEWSMOB(ra, ((scm_bits_t) ndim << 17) + scm_tc16_array, + scm_must_malloc ((sizeof (scm_array) + ndim * sizeof (scm_array_dim)), "array")); SCM_ARRAY_V (ra) = scm_nullvect; SCM_ALLOW_INTS; @@ -540,7 +560,7 @@ static char s_bad_spec[] = "Bad scm_array dimension"; SCM scm_shap2ra (SCM args, const char *what) { - scm_array_dim *s; + scm_array_dim_t *s; SCM ra, spec, sp; int ndim = scm_ilength (args); if (ndim < 0) @@ -586,10 +606,11 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, "fill the array, otherwise @var{prototype} is used.") #define FUNC_NAME s_scm_dimensions_to_uniform_array { - scm_sizet k; - unsigned long int rlen = 1; - scm_array_dim *s; + size_t k; + scm_bits_t rlen = 1; + scm_array_dim_t *s; SCM ra; + if (SCM_INUMP (dims)) { SCM answer = scm_make_uve (SCM_INUM (dims), prot); @@ -601,15 +622,18 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, scm_array_fill_x (answer, prot); return answer; } + SCM_ASSERT (SCM_NULLP (dims) || SCM_CONSP (dims), dims, SCM_ARG1, FUNC_NAME); ra = scm_shap2ra (dims, FUNC_NAME); SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); s = SCM_ARRAY_DIMS (ra); k = SCM_ARRAY_NDIM (ra); + while (k--) { s[k].inc = rlen; + SCM_ASSERT_RANGE (1, dims, s[k].inc >= 0); SCM_ASSERT_RANGE (1, dims, s[k].lbnd <= s[k].ubnd); rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc; } @@ -624,7 +648,7 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, scm_array_fill_x (ra, prot); if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra)) - if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc)) + if (s[0].ubnd < s[0].lbnd || (0 == s[0].lbnd && 1 == s[0].inc)) return SCM_ARRAY_V (ra); return ra; } @@ -634,10 +658,10 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, void scm_ra_set_contp (SCM ra) { - scm_sizet k = SCM_ARRAY_NDIM (ra); + size_t k = SCM_ARRAY_NDIM (ra); if (k) { - long inc = SCM_ARRAY_DIMS (ra)[k - 1].inc; + scm_bits_t inc = SCM_ARRAY_DIMS (ra)[k - 1].inc; /*??*/ while (k--) { if (inc != SCM_ARRAY_DIMS (ra)[k].inc) @@ -675,9 +699,10 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, SCM ra; SCM inds, indptr; SCM imap; - scm_sizet i, k; - long old_min, new_min, old_max, new_max; - scm_array_dim *s; + size_t k; + scm_bits_t i; + scm_bits_t old_min, new_min, old_max, new_max; + scm_array_dim_t *s; SCM_VALIDATE_REST_ARGUMENT (dims); SCM_VALIDATE_ARRAY (1,oldra); @@ -719,7 +744,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, } imap = scm_apply (mapfunc, scm_reverse (inds), SCM_EOL); if (SCM_ARRAYP (oldra)) - i = (scm_sizet) scm_aind (oldra, imap, FUNC_NAME); + i = scm_aind (oldra, imap, FUNC_NAME); else { if (SCM_NINUMP (imap)) @@ -768,7 +793,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra)) { SCM v = SCM_ARRAY_V (ra); - unsigned long int length = SCM_INUM (scm_uniform_vector_length (v)); + scm_bits_t length = SCM_INUM (scm_uniform_vector_length (v)); if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd) return v; if (s->ubnd < s->lbnd) @@ -805,7 +830,7 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, #define FUNC_NAME s_scm_transpose_array { SCM res, vargs, *ve = &vargs; - scm_array_dim *s, *r; + scm_array_dim_t *s, *r; int ndim, i, k; SCM_VALIDATE_REST_ARGUMENT (args); @@ -914,7 +939,7 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, #define FUNC_NAME s_scm_enclose_array { SCM axv, res, ra_inr; - scm_array_dim vdim, *s = &vdim; + scm_array_dim_t vdim, *s = &vdim; int ndim, j, k, ninr, noutr; SCM_VALIDATE_REST_ARGUMENT (axes); @@ -998,10 +1023,10 @@ SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1, #define FUNC_NAME s_scm_array_in_bounds_p { SCM ind = SCM_EOL; - long pos = 0; - register scm_sizet k; - register long j; - scm_array_dim *s; + scm_bits_t pos = 0; + register size_t k; + register scm_bits_t j; + scm_array_dim_t *s; SCM_VALIDATE_REST_ARGUMENT (args); SCM_ASRTGO (SCM_NIMP (v), badarg1); @@ -1064,7 +1089,7 @@ tail: case scm_tc7_vector: case scm_tc7_wvect: { - unsigned long int length = SCM_INUM (scm_uniform_vector_length (v)); + scm_bits_t length = SCM_INUM (scm_uniform_vector_length (v)); SCM_ASRTGO (SCM_NULLP (args) && SCM_INUMP (ind), wna); return SCM_BOOL(pos >= 0 && pos < length); } @@ -1083,7 +1108,7 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, "@var{array}.") #define FUNC_NAME s_scm_uniform_vector_ref { - long pos; + scm_bits_t pos; if (SCM_IMP (v)) { @@ -1097,7 +1122,7 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, } else { - unsigned long int length; + scm_bits_t length; if (SCM_NIMP (args)) { SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, FUNC_NAME); @@ -1151,13 +1176,13 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, case scm_tc7_uvect: return scm_ulong2num (((unsigned long *) SCM_VELTS (v))[pos]); case scm_tc7_ivect: - return scm_long2num(((signed long *) SCM_VELTS (v))[pos]); + return scm_long2num (((signed long *) SCM_VELTS (v))[pos]); case scm_tc7_svect: return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v))[pos]); #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: - return scm_long_long2num (((long_long *) SCM_CELL_WORD_1 (v))[pos]); + return scm_long_long2num (((long long *) SCM_CELL_WORD_1 (v))[pos]); #endif case scm_tc7_fvect: @@ -1178,7 +1203,7 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, tries to recycle conses. (Make *sure* you want them recycled.) */ SCM -scm_cvref (SCM v, scm_sizet pos, SCM last) +scm_cvref (SCM v, scm_bits_t pos, SCM last) #define FUNC_NAME "scm_cvref" { switch SCM_TYP7 (v) @@ -1202,7 +1227,7 @@ scm_cvref (SCM v, scm_sizet pos, SCM last) return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v))[pos]); #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: - return scm_long_long2num (((long_long *) SCM_CELL_WORD_1 (v))[pos]); + 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)) @@ -1261,7 +1286,7 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, "@var{new-value}. The value returned by array-set! is unspecified.") #define FUNC_NAME s_scm_array_set_x { - long pos = 0; + scm_bits_t pos = 0; SCM_VALIDATE_REST_ARGUMENT (args); SCM_ASRTGO (SCM_NIMP (v), badarg1); @@ -1272,7 +1297,7 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, } else { - unsigned long int length; + scm_bits_t length; if (SCM_NIMP (args)) { SCM_ASSERT (SCM_CONSP(args) && SCM_INUMP (SCM_CAR (args)), args, @@ -1317,10 +1342,10 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, ((char *) SCM_UVECTOR_BASE (v))[pos] = SCM_INUM (obj); break; case scm_tc7_uvect: - SCM_VELTS(v)[pos] = SCM_PACK (scm_num2ulong(obj, SCM_ARG2, FUNC_NAME)); + ((unsigned long *) SCM_VELTS(v))[pos] = SCM_PACK (scm_num2ulong(obj, SCM_ARG2, FUNC_NAME)); break; case scm_tc7_ivect: - SCM_VELTS(v)[pos] = SCM_PACK (scm_num2long (obj, SCM_ARG2, FUNC_NAME)); + ((long *) SCM_VELTS(v))[pos] = SCM_PACK (scm_num2long (obj, SCM_ARG2, FUNC_NAME)); break; case scm_tc7_svect: SCM_ASRTGO (SCM_INUMP (obj), badobj); @@ -1328,7 +1353,7 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, break; #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: - ((long_long *) SCM_CELL_WORD_1 (v))[pos] = scm_num2long_long (obj, SCM_ARG2, FUNC_NAME); + ((long long *) SCM_CELL_WORD_1 (v))[pos] = scm_num2long_long (obj, SCM_ARG2, FUNC_NAME); break; #endif @@ -1400,7 +1425,8 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, return ra; case scm_tc7_smob: { - scm_sizet k, ndim = SCM_ARRAY_NDIM (ra), len = 1; + size_t k, ndim = SCM_ARRAY_NDIM (ra); + scm_bits_t len = 1; if (!SCM_ARRAYP (ra) || !SCM_ARRAY_CONTP (ra)) return SCM_BOOL_F; for (k = 0; k < ndim; k++) @@ -1412,15 +1438,15 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, if (scm_tc7_bvect == SCM_TYP7 (SCM_ARRAY_V (ra))) { if (len != SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra)) || - SCM_ARRAY_BASE (ra) % SCM_LONG_BIT || - len % SCM_LONG_BIT) + SCM_ARRAY_BASE (ra) % SCM_BITS_LENGTH || + len % SCM_BITS_LENGTH) return SCM_BOOL_F; } } { SCM v = SCM_ARRAY_V (ra); - unsigned long int length = SCM_INUM (scm_uniform_vector_length (v)); + scm_bits_t length = SCM_INUM (scm_uniform_vector_length (v)); if ((len == length) && 0 == SCM_ARRAY_BASE (ra) && SCM_ARRAY_DIMS (ra)->inc) return v; } @@ -1442,8 +1468,9 @@ SCM scm_ra2contig (SCM ra, int copy) { SCM ret; - long inc = 1; - scm_sizet k, len = 1; + scm_bits_t inc = 1; + size_t k; + scm_bits_t len = 1; for (k = SCM_ARRAY_NDIM (ra); k--;) len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1; k = SCM_ARRAY_NDIM (ra); @@ -1452,8 +1479,8 @@ scm_ra2contig (SCM ra, int copy) if (scm_tc7_bvect != SCM_TYP7 (SCM_ARRAY_V (ra))) return ra; if ((len == SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra)) && - 0 == SCM_ARRAY_BASE (ra) % SCM_LONG_BIT && - 0 == len % SCM_LONG_BIT)) + 0 == SCM_ARRAY_BASE (ra) % SCM_BITS_LENGTH && + 0 == len % SCM_BITS_LENGTH)) return ra; } ret = scm_make_ra (k); @@ -1491,10 +1518,10 @@ SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0, #define FUNC_NAME s_scm_uniform_array_read_x { SCM cra = SCM_UNDEFINED, v = ra; - long sz, vlen, ans; - long cstart = 0; - long cend; - long offset = 0; + int sz; + scm_bits_t vlen, ans; + scm_bits_t cstart = 0, cend = 0; + scm_bits_t offset = 0; char *base; SCM_ASRTGO (SCM_NIMP (v), badarg1); @@ -1525,9 +1552,9 @@ loop: break; case scm_tc7_bvect: base = (char *) SCM_BITVECTOR_BASE (v); - vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT; - cstart /= SCM_LONG_BIT; - sz = sizeof (long); + vlen = (vlen + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH; + cstart /= SCM_BITS_LENGTH; + sz = sizeof (scm_bits_t); break; case scm_tc7_byvect: base = (char *) SCM_UVECTOR_BASE (v); @@ -1545,7 +1572,7 @@ loop: #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: base = (char *) SCM_UVECTOR_BASE (v); - sz = sizeof (long_long); + sz = sizeof (long long); break; #endif case scm_tc7_fvect: @@ -1566,15 +1593,15 @@ loop: if (!SCM_UNBNDP (start)) { offset = - SCM_NUM2LONG (3, start); + SCM_NUM2BITS (3, start); if (offset < 0 || offset >= cend) scm_out_of_range (FUNC_NAME, start); if (!SCM_UNBNDP (end)) { - long tend = - SCM_NUM2LONG (4, end); + scm_bits_t tend = + SCM_NUM2BITS (4, end); if (tend <= offset || tend > cend) scm_out_of_range (FUNC_NAME, end); @@ -1584,7 +1611,7 @@ loop: if (SCM_NIMP (port_or_fd)) { - scm_port *pt = SCM_PTAB_ENTRY (port_or_fd); + scm_port_t *pt = SCM_PTAB_ENTRY (port_or_fd); int remaining = (cend - offset) * sz; char *dest = base + (cstart + offset) * sz; @@ -1625,12 +1652,12 @@ loop: { SCM_SYSCALL (ans = read (SCM_INUM (port_or_fd), base + (cstart + offset) * sz, - (scm_sizet) (sz * (cend - offset)))); + (sz * (cend - offset)))); if (ans == -1) SCM_SYSERROR; } if (SCM_TYP7 (v) == scm_tc7_bvect) - ans *= SCM_LONG_BIT; + ans *= SCM_BITS_LENGTH; if (!SCM_EQ_P (v, ra) && !SCM_EQ_P (cra, ra)) scm_array_copy_x (cra, ra); @@ -1653,10 +1680,9 @@ SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0, "@code{(current-output-port)}.") #define FUNC_NAME s_scm_uniform_array_write { - long sz, vlen, ans; - long offset = 0; - long cstart = 0; - long cend; + int sz; + scm_bits_t vlen, ans; + scm_bits_t offset = 0, cstart = 0, cend; char *base; port_or_fd = SCM_COERCE_OUTPORT (port_or_fd); @@ -1689,9 +1715,9 @@ loop: break; case scm_tc7_bvect: base = (char *) SCM_BITVECTOR_BASE (v); - vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT; - cstart /= SCM_LONG_BIT; - sz = sizeof (long); + vlen = (vlen + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH; + cstart /= SCM_BITS_LENGTH; + sz = sizeof (scm_bits_t); break; case scm_tc7_byvect: base = (char *) SCM_UVECTOR_BASE (v); @@ -1709,7 +1735,7 @@ loop: #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: base = (char *) SCM_UVECTOR_BASE (v); - sz = sizeof (long_long); + sz = sizeof (long long); break; #endif case scm_tc7_fvect: @@ -1730,15 +1756,15 @@ loop: if (!SCM_UNBNDP (start)) { offset = - SCM_NUM2LONG (3, start); + SCM_NUM2BITS (3, start); if (offset < 0 || offset >= cend) scm_out_of_range (FUNC_NAME, start); if (!SCM_UNBNDP (end)) { - long tend = - SCM_NUM2LONG (4, end); + scm_bits_t tend = + SCM_NUM2BITS (4, end); if (tend <= offset || tend > cend) scm_out_of_range (FUNC_NAME, end); @@ -1757,12 +1783,12 @@ loop: { SCM_SYSCALL (ans = write (SCM_INUM (port_or_fd), base + (cstart + offset) * sz, - (scm_sizet) (sz * (cend - offset)))); + (sz * (cend - offset)))); if (ans == -1) SCM_SYSERROR; } if (SCM_TYP7 (v) == scm_tc7_bvect) - ans *= SCM_LONG_BIT; + ans *= SCM_BITS_LENGTH; return SCM_MAKINUM (ans); } @@ -1783,13 +1809,13 @@ SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0, if (SCM_BITVECTOR_LENGTH (bitvector) == 0) { return SCM_INUM0; } else { - unsigned long int count = 0; - unsigned long int i = (SCM_BITVECTOR_LENGTH (bitvector) - 1) / SCM_LONG_BIT; - unsigned long int w = SCM_UNPACK (SCM_VELTS (bitvector)[i]); + scm_bits_t count = 0; + size_t i = (SCM_BITVECTOR_LENGTH (bitvector) - 1) / SCM_BITS_LENGTH; + scm_ubits_t w = SCM_UNPACK (SCM_VELTS (bitvector)[i]); if (SCM_FALSEP (b)) { w = ~w; }; - w <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (bitvector) - 1) % SCM_LONG_BIT); + w <<= SCM_BITS_LENGTH - 1 - ((SCM_BITVECTOR_LENGTH (bitvector) - 1) % SCM_BITS_LENGTH); while (1) { while (w) { count += cnt_tab[w & 0x0f]; @@ -1817,8 +1843,11 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, "within the specified range @code{#f} is returned.") #define FUNC_NAME s_scm_bit_position { - long i, lenw, xbits, pos; - register unsigned long w; + size_t i; + scm_bits_t pos; + size_t lenw; + int xbits; + register scm_ubits_t w; SCM_VALIDATE_BOOL (1, item); SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG2, FUNC_NAME); @@ -1828,15 +1857,15 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, if (pos == SCM_BITVECTOR_LENGTH (v)) return SCM_BOOL_F; - lenw = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; /* watch for part words */ - i = pos / SCM_LONG_BIT; + lenw = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_BITS_LENGTH; /* watch for part words */ + i = pos / SCM_BITS_LENGTH; w = SCM_UNPACK (SCM_VELTS (v)[i]); if (SCM_FALSEP (item)) w = ~w; - xbits = (pos % SCM_LONG_BIT); + xbits = (pos % SCM_BITS_LENGTH); pos -= xbits; w = ((w >> xbits) << xbits); - xbits = SCM_LONG_BIT - 1 - (SCM_BITVECTOR_LENGTH (v) - 1) % SCM_LONG_BIT; + xbits = SCM_BITS_LENGTH - 1 - (SCM_BITVECTOR_LENGTH (v) - 1) % SCM_BITS_LENGTH; while (!0) { if (w && (i == lenw)) @@ -1863,7 +1892,7 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, } if (++i > lenw) break; - pos += SCM_LONG_BIT; + pos += SCM_BITS_LENGTH; w = SCM_UNPACK (SCM_VELTS (v)[i]); if (SCM_FALSEP (item)) w = ~w; @@ -1885,7 +1914,8 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, "@var{bool}. The return value is unspecified.") #define FUNC_NAME s_scm_bit_set_star_x { - register long i, k, vlen; + register size_t i; + scm_bits_t vlen; SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME); SCM_ASRTGO (SCM_NIMP (kv), badarg2); switch SCM_TYP7 (kv) @@ -1893,11 +1923,13 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, default: badarg2:SCM_WRONG_TYPE_ARG (2, kv); case scm_tc7_uvect: + { + unsigned long k; vlen = SCM_BITVECTOR_LENGTH (v); if (SCM_FALSEP (obj)) for (i = SCM_UVECTOR_LENGTH (kv); i;) { - k = SCM_UNPACK (SCM_VELTS (kv)[--i]); + k = ((unsigned long *) SCM_VELTS (kv))[--i]; if (k >= vlen) scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k)); SCM_BITVEC_CLR(v,k); @@ -1905,7 +1937,7 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, else if (SCM_EQ_P (obj, SCM_BOOL_T)) for (i = SCM_UVECTOR_LENGTH (kv); i;) { - k = SCM_UNPACK (SCM_VELTS (kv)[--i]); + k = ((unsigned long *) SCM_VELTS (kv))[--i]; if (k >= vlen) scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k)); SCM_BITVEC_SET(v,k); @@ -1913,18 +1945,22 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, else badarg3:SCM_WRONG_TYPE_ARG (3, obj); break; + } case scm_tc7_bvect: + { + scm_ubits_t k; SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME); if (SCM_FALSEP (obj)) - for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) - SCM_UNPACK (SCM_VELTS (v)[k]) &= ~ SCM_UNPACK(SCM_VELTS (kv)[k]); + for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH; k--;) + ((scm_ubits_t *) SCM_VELTS (v))[k] &= ~ ((scm_ubits_t *) SCM_VELTS (kv))[k]; else if (SCM_EQ_P (obj, SCM_BOOL_T)) - for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) - SCM_UNPACK (SCM_VELTS (v)[k]) |= SCM_UNPACK (SCM_VELTS (kv)[k]); + for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH; k--;) + ((scm_ubits_t *) SCM_VELTS (v))[k] |= ((scm_ubits_t *) SCM_VELTS (kv))[k]; else goto badarg3; break; } + } return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -1939,8 +1975,8 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, "@var{bv} is not modified.") #define FUNC_NAME s_scm_bit_count_star { - register long i, vlen, count = 0; - register unsigned long k; + register size_t i; + scm_bits_t vlen, count = 0; int fObj = 0; SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME); @@ -1951,11 +1987,13 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, badarg2: SCM_WRONG_TYPE_ARG (2, kv); case scm_tc7_uvect: + { + unsigned long k; vlen = SCM_BITVECTOR_LENGTH (v); if (SCM_FALSEP (obj)) for (i = SCM_UVECTOR_LENGTH (kv); i;) { - k = SCM_UNPACK (SCM_VELTS (kv)[--i]); + k = ((unsigned long *) SCM_VELTS (kv))[--i]; if (k >= vlen) scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k)); if (!SCM_BITVEC_REF(v,k)) @@ -1964,7 +2002,7 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, else if (SCM_EQ_P (obj, SCM_BOOL_T)) for (i = SCM_UVECTOR_LENGTH (kv); i;) { - k = SCM_UNPACK (SCM_VELTS (kv)[--i]); + k = ((unsigned long *) SCM_VELTS (kv))[--i]; if (k >= vlen) scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k)); if (SCM_BITVEC_REF (v,k)) @@ -1973,15 +2011,20 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, else badarg3:SCM_WRONG_TYPE_ARG (3, obj); break; + } case scm_tc7_bvect: + { + scm_ubits_t k; SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME); if (0 == SCM_BITVECTOR_LENGTH (v)) return SCM_INUM0; SCM_ASRTGO (SCM_BOOLP (obj), badarg3); fObj = SCM_EQ_P (obj, SCM_BOOL_T); - i = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; - k = SCM_UNPACK (SCM_VELTS (kv)[i]) & (fObj ? SCM_UNPACK (SCM_VELTS (v)[i]) : ~ SCM_UNPACK (SCM_VELTS (v)[i])); - k <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (v) - 1) % SCM_LONG_BIT); + i = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_BITS_LENGTH; + k = + ((scm_ubits_t *) SCM_VELTS (kv))[i] + & (fObj ? ((scm_ubits_t *) SCM_VELTS (v))[i] : ~ ((scm_ubits_t *) SCM_VELTS (v))[i]); + k <<= SCM_BITS_LENGTH - 1 - ((SCM_BITVECTOR_LENGTH (v) - 1) % SCM_BITS_LENGTH); while (1) { for (; k; k >>= 4) @@ -1990,7 +2033,10 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, return SCM_MAKINUM (count); /* urg. repetitive (see above.) */ - k = SCM_UNPACK (SCM_VELTS (kv)[i]) & (fObj ? SCM_UNPACK(SCM_VELTS (v)[i]) : ~SCM_UNPACK (SCM_VELTS (v)[i])); + k = + ((scm_ubits_t *) SCM_VELTS (kv))[i] + & (fObj ? ((scm_ubits_t *) SCM_VELTS (v))[i] : ~ ((scm_ubits_t *) SCM_VELTS (v))[i]); + } } } return SCM_MAKINUM (count); @@ -2003,13 +2049,13 @@ SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0, "Modifies @var{bv} by replacing each element with its negation.") #define FUNC_NAME s_scm_bit_invert_x { - long int k; + scm_bits_t k; SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME); k = SCM_BITVECTOR_LENGTH (v); - for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) - SCM_UNPACK (SCM_VELTS (v)[k]) = ~SCM_UNPACK (SCM_VELTS (v)[k]); + for (k = (k + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH; k--;) + ((scm_ubits_t *) SCM_VELTS (v))[k] = ~((scm_ubits_t *) SCM_VELTS (v))[k]; return SCM_UNSPECIFIED; } @@ -2017,19 +2063,19 @@ SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0, SCM -scm_istr2bve (char *str, long len) +scm_istr2bve (char *str, scm_bits_t len) { SCM v = scm_make_uve (len, SCM_BOOL_T); - long *data = (long *) SCM_VELTS (v); - register unsigned long mask; - register long k; - register long j; - for (k = 0; k < (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k++) + scm_ubits_t *data = (scm_ubits_t *) SCM_VELTS (v); + register scm_bits_t mask; + register size_t k; + register int j; + for (k = 0; k < (len + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH; k++) { data[k] = 0L; - j = len - k * SCM_LONG_BIT; - if (j > SCM_LONG_BIT) - j = SCM_LONG_BIT; + j = len - k * SCM_BITS_LENGTH; + if (j > SCM_BITS_LENGTH) + j = SCM_BITS_LENGTH; for (mask = 1L; j--; mask <<= 1) switch (*str++) { @@ -2048,11 +2094,11 @@ scm_istr2bve (char *str, long len) static SCM -ra2l (SCM ra,scm_sizet base,scm_sizet k) +ra2l (SCM ra, scm_bits_t base, size_t k) { register SCM res = SCM_EOL; - register long inc = SCM_ARRAY_DIMS (ra)[k].inc; - register scm_sizet i; + register scm_bits_t inc = SCM_ARRAY_DIMS (ra)[k].inc; + register scm_bits_t i; if (SCM_ARRAY_DIMS (ra)[k].ubnd < SCM_ARRAY_DIMS (ra)[k].lbnd) return SCM_EOL; i = base + (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd) * inc; @@ -2083,7 +2129,7 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, #define FUNC_NAME s_scm_array_to_list { SCM res = SCM_EOL; - register long k; + register size_t k; SCM_ASRTGO (SCM_NIMP (v), badarg1); switch SCM_TYP7 (v) { @@ -2099,48 +2145,48 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, return scm_string_to_list (v); case scm_tc7_bvect: { - long *data = (long *) SCM_VELTS (v); - register unsigned long mask; - for (k = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; k > 0; k--) - for (mask = 1UL << (SCM_LONG_BIT - 1); mask; mask >>= 1) - res = scm_cons (SCM_BOOL(((long *) data)[k] & mask), res); - for (mask = 1L << ((SCM_BITVECTOR_LENGTH (v) % SCM_LONG_BIT) - 1); mask; mask >>= 1) - res = scm_cons (SCM_BOOL(((long *) data)[k] & mask), res); + scm_ubits_t *data = (scm_ubits_t *) SCM_VELTS (v); + register scm_ubits_t mask; + for (k = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_BITS_LENGTH; k > 0; k--) + for (mask = 1UL << (SCM_BITS_LENGTH - 1); mask; mask >>= 1) + res = scm_cons (SCM_BOOL(data[k] & mask), res); + for (mask = 1L << ((SCM_BITVECTOR_LENGTH (v) % SCM_BITS_LENGTH) - 1); mask; mask >>= 1) + res = scm_cons (SCM_BOOL(data[k] & mask), res); return res; } case scm_tc7_byvect: { signed char *data = (signed char *) SCM_VELTS (v); - scm_sizet k = SCM_UVECTOR_LENGTH (v); + scm_bits_t k = SCM_UVECTOR_LENGTH (v); while (k != 0) res = scm_cons (SCM_MAKINUM (data[--k]), res); return res; } case scm_tc7_uvect: { - long *data = (long *)SCM_VELTS(v); + scm_ubits_t *data = (scm_ubits_t *) SCM_VELTS(v); for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--) - res = scm_cons(scm_ulong2num(data[k]), res); + res = scm_cons(scm_ubits2num(data[k]), res); return res; } case scm_tc7_ivect: { - long *data = (long *)SCM_VELTS(v); + scm_bits_t *data = (scm_bits_t *) SCM_VELTS(v); for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--) - res = scm_cons(scm_long2num(data[k]), res); + res = scm_cons(scm_bits2num(data[k]), res); return res; } case scm_tc7_svect: { short *data = (short *)SCM_VELTS(v); for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--) - res = scm_cons(SCM_MAKINUM (data[k]), res); + res = scm_cons(scm_short2num (data[k]), res); return res; } #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: { - long_long *data = (long_long *)SCM_VELTS(v); + long long *data = (long long *)SCM_VELTS(v); for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--) res = scm_cons(scm_long_long2num(data[k]), res); return res; @@ -2172,7 +2218,7 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, #undef FUNC_NAME -static int l2ra(SCM lst, SCM ra, scm_sizet base, scm_sizet k); +static int l2ra (SCM lst, SCM ra, scm_bits_t base, size_t k); SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, (SCM ndim, SCM prot, SCM lst), @@ -2186,7 +2232,7 @@ SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, SCM shp = SCM_EOL; SCM row = lst; SCM ra; - scm_sizet k; + scm_bits_t k; long n; SCM_VALIDATE_INUM_COPY (1,ndim,k); while (k--) @@ -2207,7 +2253,7 @@ SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, } if (!SCM_ARRAYP (ra)) { - unsigned long int length = SCM_INUM (scm_uniform_vector_length (ra)); + scm_bits_t length = SCM_INUM (scm_uniform_vector_length (ra)); for (k = 0; k < length; k++, lst = SCM_CDR (lst)) scm_array_set_x (ra, SCM_CAR (lst), SCM_MAKINUM (k)); return ra; @@ -2220,10 +2266,10 @@ SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, #undef FUNC_NAME static int -l2ra (SCM lst, SCM ra, scm_sizet base, scm_sizet k) +l2ra (SCM lst, SCM ra, scm_bits_t base, size_t k) { - register long inc = SCM_ARRAY_DIMS (ra)[k].inc; - register long n = (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd); + register scm_bits_t inc = SCM_ARRAY_DIMS (ra)[k].inc; + register scm_bits_t n = (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd); int ok = 1; if (n <= 0) return (SCM_NULLP (lst)); @@ -2258,10 +2304,10 @@ l2ra (SCM lst, SCM ra, scm_sizet base, scm_sizet k) static void -rapr1 (SCM ra,scm_sizet j,scm_sizet k,SCM port,scm_print_state *pstate) +rapr1 (SCM ra, scm_bits_t j, size_t k, SCM port, scm_print_state *pstate) { - long inc = 1; - long n = (SCM_TYP7 (ra) == scm_tc7_smob + scm_bits_t inc = 1; + scm_bits_t n = (SCM_TYP7 (ra) == scm_tc7_smob ? 0 : SCM_INUM (scm_uniform_vector_length (ra))); int enclosed = 0; @@ -2284,7 +2330,7 @@ tail: } if (k + 1 < SCM_ARRAY_NDIM (ra)) { - long i; + scm_bits_t i; inc = SCM_ARRAY_DIMS (ra)[k].inc; for (i = SCM_ARRAY_DIMS (ra)[k].lbnd; i < SCM_ARRAY_DIMS (ra)[k].ubnd; i++) { @@ -2301,8 +2347,7 @@ tail: } break; } - if SCM_ARRAY_NDIM - (ra) + if (SCM_ARRAY_NDIM (ra) > 0) { /* Could be zero-dimensional */ inc = SCM_ARRAY_DIMS (ra)[k].inc; n = (SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1); @@ -2438,7 +2483,7 @@ int scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate) { SCM v = exp; - scm_sizet base = 0; + scm_bits_t base = 0; scm_putc ('#', port); tail: switch SCM_TYP7 (v) @@ -2465,21 +2510,23 @@ tail: case scm_tc7_bvect: if (SCM_EQ_P (exp, v)) { /* a uve, not an scm_array */ - register long i, j, w; + register size_t i; + register int j; + scm_ubits_t w; scm_putc ('*', port); - for (i = 0; i < (SCM_BITVECTOR_LENGTH (exp)) / SCM_LONG_BIT; i++) + for (i = 0; i < (SCM_BITVECTOR_LENGTH (exp) / SCM_BITS_LENGTH); i++) { - scm_bits_t w = SCM_UNPACK (SCM_VELTS (exp)[i]); - for (j = SCM_LONG_BIT; j; j--) + w = SCM_UNPACK (SCM_VELTS (exp)[i]); + for (j = SCM_BITS_LENGTH; j; j--) { scm_putc (w & 1 ? '1' : '0', port); w >>= 1; } } - j = SCM_BITVECTOR_LENGTH (exp) % SCM_LONG_BIT; + j = SCM_BITVECTOR_LENGTH (exp) % SCM_BITS_LENGTH; if (j) { - w = SCM_UNPACK (SCM_VELTS (exp)[SCM_BITVECTOR_LENGTH (exp) / SCM_LONG_BIT]); + w = SCM_UNPACK (SCM_VELTS (exp)[SCM_BITVECTOR_LENGTH (exp) / SCM_BITS_LENGTH]); for (; j; j--) { scm_putc (w & 1 ? '1' : '0', port); @@ -2584,7 +2631,7 @@ array_mark (SCM ptr) } -static scm_sizet +static size_t array_free (SCM ptr) { scm_must_free (SCM_ARRAY_MEM (ptr)); diff --git a/libguile/unif.h b/libguile/unif.h index 6cd376eda..14ff17904 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -58,21 +58,26 @@ bit 15 is the SCM_ARRAY_FLAG_CONTIGUOUS flag bits 16-31 hold the smob type id: scm_tc16_array CDR: pointer to a malloced block containing an scm_array structure - followed by an scm_array_dim structure for each dimension. + followed by an scm_array_dim_t structure for each dimension. */ -typedef struct scm_array +typedef struct scm_array_t { SCM v; /* the contents of the array, e.g., a vector or uniform vector. */ - scm_sizet base; -} scm_array; + scm_bits_t base; +} scm_array_t; -typedef struct scm_array_dim +typedef struct scm_array_dim_t { - long lbnd; - long ubnd; - long inc; -} scm_array_dim; + scm_bits_t lbnd; + scm_bits_t ubnd; + scm_bits_t inc; +} scm_array_dim_t; + +#if (SCM_DEBUG_DEPRECATED == 0) +# define scm_array scm_array_t +# define scm_array_dim scm_array_dim_t +#endif extern scm_bits_t scm_tc16_array; @@ -83,35 +88,37 @@ extern scm_bits_t scm_tc16_array; #endif #define SCM_ARRAYP(a) SCM_TYP16_PREDICATE (scm_tc16_array, a) -#define SCM_ARRAY_NDIM(x) ((scm_sizet) (SCM_CELL_WORD_0 (x) >> 17)) +#define SCM_ARRAY_NDIM(x) ((size_t) ((scm_ubits_t) (SCM_CELL_WORD_0 (x)) >> 17)) #define SCM_ARRAY_CONTP(x) (SCM_CELL_WORD_0 (x) & SCM_ARRAY_FLAG_CONTIGUOUS) #define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \ (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | SCM_ARRAY_FLAG_CONTIGUOUS)) #define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \ (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~SCM_ARRAY_FLAG_CONTIGUOUS)) -#define SCM_ARRAY_MEM(a) ((scm_array *) SCM_CELL_WORD_1 (a)) +#define SCM_ARRAY_MEM(a) ((scm_array_t *) SCM_CELL_WORD_1 (a)) #define SCM_ARRAY_V(a) (SCM_ARRAY_MEM (a)->v) #define SCM_ARRAY_BASE(a) (SCM_ARRAY_MEM (a)->base) -#define SCM_ARRAY_DIMS(a) ((scm_array_dim *)((char *) SCM_ARRAY_MEM (a) + sizeof (scm_array))) +#define SCM_ARRAY_DIMS(a) ((scm_array_dim_t *)((char *) SCM_ARRAY_MEM (a) + sizeof (scm_array))) + +#define SCM_I_MAX_LENGTH ((scm_ubits_t)((scm_bits_t)-1) >> 8) #define SCM_UVECTOR_BASE(x) ((void *) (SCM_CELL_WORD_1 (x))) #define SCM_SET_UVECTOR_BASE(v, b) (SCM_SET_CELL_WORD_1 ((v), (b))) -#define SCM_UVECTOR_MAX_LENGTH (0xffffffL) -#define SCM_UVECTOR_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) +#define SCM_UVECTOR_MAX_LENGTH SCM_I_MAX_LENGTH +#define SCM_UVECTOR_LENGTH(x) (((scm_ubits_t) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_SET_UVECTOR_LENGTH(v, l, t) (SCM_SET_CELL_WORD_0 ((v), ((l) << 8) + (t))) #define SCM_BITVECTOR_P(x) (!SCM_IMP (x) && (SCM_TYP7 (x) == scm_tc7_bvect)) #define SCM_BITVECTOR_BASE(x) ((void *) (SCM_CELL_WORD_1 (x))) #define SCM_SET_BITVECTOR_BASE(v, b) (SCM_SET_CELL_WORD_1 ((v), (b))) -#define SCM_BITVECTOR_MAX_LENGTH (0xffffffL) -#define SCM_BITVECTOR_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) +#define SCM_BITVECTOR_MAX_LENGTH SCM_I_MAX_LENGTH +#define SCM_BITVECTOR_LENGTH(x) (((scm_ubits_t) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_SET_BITVECTOR_LENGTH(v, l) (SCM_SET_CELL_WORD_0 ((v), ((l) << 8) + scm_tc7_bvect)) -extern scm_sizet scm_uniform_element_size (SCM obj); -extern SCM scm_make_uve (long k, SCM prot); +extern size_t scm_uniform_element_size (SCM obj); +extern SCM scm_make_uve (scm_bits_t k, SCM prot); extern SCM scm_uniform_vector_length (SCM v); extern SCM scm_array_p (SCM v, SCM prot); extern SCM scm_array_rank (SCM ra); @@ -119,7 +126,7 @@ extern SCM scm_array_dimensions (SCM ra); extern SCM scm_shared_array_root (SCM ra); extern SCM scm_shared_array_offset (SCM ra); extern SCM scm_shared_array_increments (SCM ra); -extern long scm_aind (SCM ra, SCM args, const char *what); +extern scm_bits_t scm_aind (SCM ra, SCM args, const char *what); extern SCM scm_make_ra (int ndim); extern SCM scm_shap2ra (SCM args, const char *what); extern SCM scm_dimensions_to_uniform_array (SCM dims, SCM prot, SCM fill); @@ -129,7 +136,7 @@ extern SCM scm_transpose_array (SCM ra, SCM args); extern SCM scm_enclose_array (SCM ra, SCM axes); extern SCM scm_array_in_bounds_p (SCM v, SCM args); extern SCM scm_uniform_vector_ref (SCM v, SCM args); -extern SCM scm_cvref (SCM v, scm_sizet pos, SCM last); +extern SCM scm_cvref (SCM v, scm_bits_t pos, SCM last); extern SCM scm_array_set_x (SCM v, SCM obj, SCM args); extern SCM scm_array_contents (SCM ra, SCM strict); extern SCM scm_ra2contig (SCM ra, int copy); @@ -140,7 +147,7 @@ extern SCM scm_bit_position (SCM item, SCM v, SCM k); extern SCM scm_bit_set_star_x (SCM v, SCM kv, SCM obj); extern SCM scm_bit_count_star (SCM v, SCM kv, SCM obj); extern SCM scm_bit_invert_x (SCM v); -extern SCM scm_istr2bve (char *str, long len); +extern SCM scm_istr2bve (char *str, scm_bits_t len); extern SCM scm_array_to_list (SCM v); extern SCM scm_list_to_uniform_array (SCM ndim, SCM prot, SCM lst); extern int scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate); diff --git a/libguile/validate.h b/libguile/validate.h index e2699b255..cc8df1561 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -1,4 +1,4 @@ -/* $Id: validate.h,v 1.31 2001-04-10 07:57:05 dirk Exp $ */ +/* $Id: validate.h,v 1.32 2001-05-24 00:50:51 cmm Exp $ */ /* Copyright (C) 1999,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify @@ -61,8 +61,51 @@ #define SCM_WRONG_TYPE_ARG(pos, obj) \ do { scm_wrong_type_arg (FUNC_NAME, pos, obj); } while (0) +#define SCM_NUM2SIZE(pos, arg) (scm_num2size (arg, pos, FUNC_NAME)) + +#define SCM_NUM2SIZE_DEF(pos, arg, def) \ + (SCM_UNBNDP (arg) ? def : scm_num2size (arg, pos, FUNC_NAME)) + +#define SCM_NUM2PTRDIFF(pos, arg) (scm_num2ptrdiff (arg, pos, FUNC_NAME)) + +#define SCM_NUM2PTRDIFF_DEF(pos, arg, def) \ + (SCM_UNBNDP (arg) ? def : scm_num2ptrdiff (arg, pos, FUNC_NAME)) + +#define SCM_NUM2SHORT(pos, arg) (scm_num2short (arg, pos, FUNC_NAME)) + +#define SCM_NUM2SHORT_DEF(pos, arg, def) \ + (SCM_UNBNDP (arg) ? def : scm_num2short (arg, pos, FUNC_NAME)) + +#define SCM_NUM2USHORT(pos, arg) (scm_num2ushort (arg, pos, FUNC_NAME)) + +#define SCM_NUM2USHORT_DEF(pos, arg, def) \ + (SCM_UNBNDP (arg) ? def : scm_num2ushort (arg, pos, FUNC_NAME)) + +#define SCM_NUM2BITS(pos, arg) (scm_num2bits (arg, pos, FUNC_NAME)) + +#define SCM_NUM2BITS_DEF(pos, arg, def) \ + (SCM_UNBNDP (arg) ? def : scm_num2bits (arg, pos, FUNC_NAME)) + +#define SCM_NUM2UBITS(pos, arg) (scm_num2ubits (arg, pos, FUNC_NAME)) + +#define SCM_NUM2UBITS_DEF(pos, arg, def) \ + (SCM_UNBNDP (arg) ? def : scm_num2ubits (arg, pos, FUNC_NAME)) + +#define SCM_NUM2INT(pos, arg) (scm_num2int (arg, pos, FUNC_NAME)) + +#define SCM_NUM2INT_DEF(pos, arg, def) \ + (SCM_UNBNDP (arg) ? def : scm_num2int (arg, pos, FUNC_NAME)) + +#define SCM_NUM2UINT(pos, arg) (scm_num2uint (arg, pos, FUNC_NAME)) + +#define SCM_NUM2UINT_DEF(pos, arg, def) \ + (SCM_UNBNDP (arg) ? def : scm_num2uint (arg, pos, FUNC_NAME)) + #define SCM_NUM2ULONG(pos, arg) (scm_num2ulong (arg, pos, FUNC_NAME)) +#define SCM_NUM2ULONG_DEF(pos, arg, def) \ + (SCM_UNBNDP (arg) ? def : scm_num2ulong (arg, pos, FUNC_NAME)) + #define SCM_NUM2LONG(pos, arg) (scm_num2long (arg, pos, FUNC_NAME)) #define SCM_NUM2LONG_DEF(pos, arg, def) \ @@ -71,6 +114,15 @@ #define SCM_NUM2LONG_LONG(pos, arg) \ (scm_num2long_long (arg, pos, FUNC_NAME)) +#define SCM_NUM2LONG_LONG_DEF(pos, arg, def) \ + (SCM_UNBNDP (arg) ? def : scm_num2long_long (arg, pos, FUNC_NAME)) + +#define SCM_NUM2ULONG_LONG(pos, arg) \ + (scm_num2ulong_long (arg, pos, FUNC_NAME)) + +#define SCM_NUM2ULONG_LONG_DEF(pos, arg, def) \ + (SCM_UNBNDP (arg) ? def : scm_num2ulong_long (arg, pos, FUNC_NAME)) + #define SCM_OUT_OF_RANGE(pos, arg) \ do { scm_out_of_range_pos (FUNC_NAME, arg, SCM_MAKINUM (pos)); } while (0) @@ -395,7 +447,7 @@ else if (SCM_REALP (z)) \ cvar = SCM_REAL_VALUE (z); \ else if (SCM_BIGP (z)) \ - cvar = scm_big2dbl (z); \ + cvar = scm_i_big2dbl (z); \ else \ { \ cvar = 0.0; \ diff --git a/libguile/values.c b/libguile/values.c index 5aad29a89..2fbfaaae9 100644 --- a/libguile/values.c +++ b/libguile/values.c @@ -77,7 +77,7 @@ SCM_DEFINE (scm_values, "values", 0, 0, 1, "were not created by @code{call-with-values} is unspecified.") #define FUNC_NAME s_scm_values { - long n; + scm_bits_t n; SCM result; SCM_VALIDATE_LIST_COPYLEN (1, args, n); diff --git a/libguile/vectors.c b/libguile/vectors.c index 5958338c3..d6d5a7867 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -73,9 +73,9 @@ static char s_vector_set_length_x[] = "vector-set-length!"; SCM scm_vector_set_length_x (SCM vect, SCM len) { - long l; - scm_sizet siz; - scm_sizet sz; + scm_bits_t l; + size_t siz; + size_t sz; char *base; l = SCM_INUM (len); @@ -84,7 +84,7 @@ scm_vector_set_length_x (SCM vect, SCM len) #ifdef HAVE_ARRAYS if (SCM_TYP7 (vect) == scm_tc7_bvect) { - l = (l + SCM_LONG_BIT - 1) / SCM_LONG_BIT; + l = (l + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH; } sz = scm_uniform_element_size (vect); if (sz != 0) @@ -118,8 +118,8 @@ scm_vector_set_length_x (SCM vect, SCM len) SCM_SETCHARS (vect, ((char *) scm_must_realloc (base, - (long) SCM_LENGTH (vect) * sz, - (long) siz, + (size_t) SCM_LENGTH (vect) * sz, + (size_t) siz, s_vector_set_length_x))); if (SCM_VECTORP (vect)) { @@ -180,7 +180,7 @@ SCM_DEFINE (scm_vector, "vector", 0, 0, 1, { SCM res; SCM *data; - long i; + scm_bits_t i; /* Dirk:FIXME:: In case of multiple threads, the list might get corrupted while the vector is being created. */ @@ -222,7 +222,7 @@ scm_vector_ref (SCM v, SCM k) SCM_GASSERT2 (SCM_INUMP (k), g_vector_ref, v, k, SCM_ARG2, s_vector_ref); SCM_ASSERT_RANGE (2, k, SCM_INUM (k) < SCM_VECTOR_LENGTH (v) && SCM_INUM (k) >= 0); - return SCM_VELTS (v)[(long) SCM_INUM (k)]; + return SCM_VELTS (v)[(ptrdiff_t) SCM_INUM (k)]; } #undef FUNC_NAME @@ -250,7 +250,7 @@ scm_vector_set_x (SCM v, SCM k, SCM obj) g_vector_set_x, SCM_LIST3 (v, k, obj), SCM_ARG2, s_vector_set_x); SCM_ASSERT_RANGE (2, k, SCM_INUM (k) < SCM_VECTOR_LENGTH (v) && SCM_INUM (k) >= 0); - SCM_VELTS(v)[(long) SCM_INUM(k)] = obj; + SCM_VELTS(v)[(ptrdiff_t) SCM_INUM(k)] = obj; return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -281,7 +281,7 @@ SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0, SCM -scm_c_make_vector (unsigned long int k, SCM fill) +scm_c_make_vector (size_t k, SCM fill) #define FUNC_NAME s_scm_make_vector { SCM v; @@ -289,9 +289,9 @@ scm_c_make_vector (unsigned long int k, SCM fill) if (k > 0) { - unsigned long int j; + size_t j; - SCM_ASSERT_RANGE (1, scm_ulong2num (k), k <= SCM_VECTOR_MAX_LENGTH); + SCM_ASSERT_RANGE (1, scm_size2num (k), k <= SCM_VECTOR_MAX_LENGTH); base = scm_must_malloc (k * sizeof (scm_bits_t), FUNC_NAME); for (j = 0; j != k; ++j) @@ -322,7 +322,7 @@ SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0, #define FUNC_NAME s_scm_vector_to_list { SCM res = SCM_EOL; - long i; + scm_bits_t i; SCM *data; SCM_VALIDATE_VECTOR (1,v); data = SCM_VELTS(v); @@ -338,11 +338,11 @@ SCM_DEFINE (scm_vector_fill_x, "vector-fill!", 2, 0, 0, "returned by @code{vector-fill!} is unspecified.") #define FUNC_NAME s_scm_vector_fill_x { - register long i; + register scm_bits_t i; register SCM *data; - SCM_VALIDATE_VECTOR (1,v); - data = SCM_VELTS(v); - for(i = SCM_VECTOR_LENGTH(v) - 1; i >= 0; i--) + SCM_VALIDATE_VECTOR (1, v); + data = SCM_VELTS (v); + for(i = SCM_VECTOR_LENGTH (v) - 1; i >= 0; i--) data[i] = fill; return SCM_UNSPECIFIED; } @@ -352,9 +352,9 @@ SCM_DEFINE (scm_vector_fill_x, "vector-fill!", 2, 0, 0, SCM scm_vector_equal_p(SCM x, SCM y) { - long i; - for(i = SCM_VECTOR_LENGTH(x)-1;i >= 0;i--) - if (SCM_FALSEP(scm_equal_p(SCM_VELTS(x)[i], SCM_VELTS(y)[i]))) + scm_bits_t i; + for(i = SCM_VECTOR_LENGTH (x) - 1; i >= 0; i--) + if (SCM_FALSEP (scm_equal_p (SCM_VELTS (x)[i], SCM_VELTS (y)[i]))) return SCM_BOOL_F; return SCM_BOOL_T; } @@ -365,9 +365,9 @@ SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0, "Vector version of @code{substring-move-left!}.") #define FUNC_NAME s_scm_vector_move_left_x { - long i; - long j; - long e; + scm_bits_t i; + scm_bits_t j; + scm_bits_t e; SCM_VALIDATE_VECTOR (1,vec1); SCM_VALIDATE_INUM_COPY (2,start1,i); @@ -388,9 +388,9 @@ SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0, "Vector version of @code{substring-move-right!}.") #define FUNC_NAME s_scm_vector_move_right_x { - long i; - long j; - long e; + scm_bits_t i; + scm_bits_t j; + scm_bits_t e; SCM_VALIDATE_VECTOR (1,vec1); SCM_VALIDATE_INUM_COPY (2,start1,i); diff --git a/libguile/vectors.h b/libguile/vectors.h index 77d6131bf..7058dcac2 100644 --- a/libguile/vectors.h +++ b/libguile/vectors.h @@ -55,7 +55,7 @@ #define SCM_VECTOR_BASE(x) ((scm_bits_t *) SCM_CELL_WORD_1 (x)) #define SCM_SET_VECTOR_BASE(v, b) (SCM_SET_CELL_WORD_1 ((v), (b))) #define SCM_VECTOR_MAX_LENGTH ((1L << 24) - 1) -#define SCM_VECTOR_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) +#define SCM_VECTOR_LENGTH(x) (((scm_ubits_t) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_SET_VECTOR_LENGTH(v, l, t) (SCM_SET_CELL_WORD_0 ((v), ((l) << 8) + (t))) #define SCM_VELTS(x) ((SCM *) SCM_CELL_WORD_1 (x)) @@ -67,14 +67,14 @@ /* bit vectors */ -#define SCM_BITVEC_REF(a, i) ((SCM_UNPACK(SCM_VELTS(a)[(i)/SCM_LONG_BIT]) & (1L<<((i)%SCM_LONG_BIT))) ? 1 : 0) -#define SCM_BITVEC_SET(a, i) SCM_UNPACK(SCM_VELTS(a)[(i)/SCM_LONG_BIT]) |= (1L<<((i)%SCM_LONG_BIT)) -#define SCM_BITVEC_CLR(a, i) SCM_UNPACK(SCM_VELTS(a)[(i)/SCM_LONG_BIT]) &= ~(1L<<((i)%SCM_LONG_BIT)) +#define SCM_BITVEC_REF(a, i) ((SCM_UNPACK(SCM_VELTS(a)[(i)/SCM_BITS_LENGTH]) & (1L<<((i)%SCM_BITS_LENGTH))) ? 1 : 0) +#define SCM_BITVEC_SET(a, i) SCM_UNPACK(SCM_VELTS(a)[(i)/SCM_BITS_LENGTH]) |= (1L<<((i)%SCM_BITS_LENGTH)) +#define SCM_BITVEC_CLR(a, i) SCM_UNPACK(SCM_VELTS(a)[(i)/SCM_BITS_LENGTH]) &= ~(1L<<((i)%SCM_BITS_LENGTH)) -extern SCM scm_c_make_vector (unsigned long int k, SCM fill); +extern SCM scm_c_make_vector (size_t k, SCM fill); extern SCM scm_vector_p (SCM x); extern SCM scm_vector_length (SCM v); diff --git a/libguile/vports.c b/libguile/vports.c index ba4230e50..cd29ce31d 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -75,7 +75,7 @@ static scm_bits_t scm_tc16_sfport; static void sf_flush (SCM port) { - scm_port *pt = SCM_PTAB_ENTRY (port); + scm_port_t *pt = SCM_PTAB_ENTRY (port); SCM stream = SCM_PACK (pt->stream); if (pt->write_pos > pt->write_buf) @@ -121,7 +121,7 @@ sf_fill_input (SCM port) return EOF; SCM_ASSERT (SCM_CHARP (ans), ans, SCM_ARG1, "sf_fill_input"); { - scm_port *pt = SCM_PTAB_ENTRY (port); + scm_port_t *pt = SCM_PTAB_ENTRY (port); *pt->read_buf = SCM_CHAR (ans); pt->read_pos = pt->read_buf; @@ -190,7 +190,7 @@ SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0, "@end lisp") #define FUNC_NAME s_scm_make_soft_port { - scm_port *pt; + scm_port_t *pt; SCM z; SCM_VALIDATE_VECTOR_LEN (1,pv,5); SCM_VALIDATE_STRING (2, modes); diff --git a/libguile/weaks.c b/libguile/weaks.c index 81a4b879f..1432ae264 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -90,7 +90,7 @@ SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1, { SCM res; SCM *data; - long i; + scm_bits_t i; /* Dirk:FIXME:: In case of multiple threads, the list might get corrupted while the vector is being created. */ @@ -235,8 +235,7 @@ scm_mark_weak_vector_spines (void *dummy1, void *dummy2, void *dummy3) { SCM *ptr; SCM obj; - int j; - int n; + scm_bits_t j, n; obj = w; ptr = SCM_VELTS (w); @@ -280,8 +279,8 @@ scm_scan_weak_vectors (void *dummy1, void *dummy2, void *dummy3) else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */ { SCM obj = w; - register long n = SCM_VECTOR_LENGTH (w); - register long j; + register scm_bits_t n = SCM_VECTOR_LENGTH (w); + register scm_bits_t j; int weak_keys = SCM_IS_WHVEC (obj) || SCM_IS_WHVEC_B (obj); int weak_values = SCM_IS_WHVEC_V (obj) || SCM_IS_WHVEC_B (obj); diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index ceb10f2e0..2cb7dc9e3 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -81,7 +81,7 @@ charset_print (SCM charset, SCM port, scm_print_state *pstate) /* Smob free hook for character sets. */ -static scm_sizet +static size_t charset_free (SCM charset) { return scm_smob_free (charset); diff --git a/test-suite/guile-test b/test-suite/guile-test index fa2b714f8..362938a9d 100755 --- a/test-suite/guile-test +++ b/test-suite/guile-test @@ -1,4 +1,4 @@ -#!/bogus-path/guile \ +#!../libguile/guile \ -e main -s !# From 90d892e32e07c0d1ad3ac30893e90cb85f0c9246 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 24 May 2001 06:51:42 +0000 Subject: [PATCH 1177/2047] Make it compile with --disable-deprecated. * readline.h: scm_option->scm_option_t. * readline.c (stream_from_fport): scm_fport->scm_fport_t; scm_option->scm_option_t. --- guile-readline/ChangeLog | 9 +++++++++ guile-readline/readline.c | 4 ++-- guile-readline/readline.h | 2 +- 3 files changed, 12 insertions(+), 3 deletions(-) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 00119b8bf..b4d3a7893 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,12 @@ +2001-05-24 Martin Grabmueller + + Make it compile with --disable-deprecated. + + * readline.h: scm_option->scm_option_t. + + * readline.c (stream_from_fport): scm_fport->scm_fport_t; + scm_option->scm_option_t. + 2001-05-23 Michael Livshin * readline.c (strdup): make `len' a size_t. diff --git a/guile-readline/readline.c b/guile-readline/readline.c index 04a797ba0..6070e174f 100644 --- a/guile-readline/readline.c +++ b/guile-readline/readline.c @@ -42,7 +42,7 @@ #include "libguile/validate.h" #include "guile-readline/readline.h" -scm_option scm_readline_opts[] = { +scm_option_t scm_readline_opts[] = { { SCM_OPTION_BOOLEAN, "history-file", 1, "Use history file." }, { SCM_OPTION_INTEGER, "history-length", 200, @@ -277,7 +277,7 @@ stream_from_fport (SCM port, char *mode, const char *subr) int fd; FILE *f; - fd = dup (((struct scm_fport *) SCM_STREAM (port))->fdes); + fd = dup (((struct scm_fport_t *) SCM_STREAM (port))->fdes); if (fd == -1) { --in_readline; diff --git a/guile-readline/readline.h b/guile-readline/readline.h index 05ab78cb0..85d115b4a 100644 --- a/guile-readline/readline.h +++ b/guile-readline/readline.h @@ -22,7 +22,7 @@ #include "libguile/__scm.h" -extern scm_option scm_readline_opts[]; +extern scm_option_t scm_readline_opts[]; #define SCM_HISTORY_FILE_P scm_readline_opts[0].val #define SCM_HISTORY_LENGTH scm_readline_opts[1].val From 880a7d13795dec0f1256fa8ba1626eb4c44d7e52 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 24 May 2001 06:53:26 +0000 Subject: [PATCH 1178/2047] * unif.c (scm_make_ra, array_free), unif.h (SCM_ARRAY_DIMS): Changed use of scm_array->scm_array_t and scm_array_dim->scm_array_dim_t to enable build with --disable-deprecated. --- libguile/ChangeLog | 7 +++++++ libguile/unif.c | 6 ++++-- libguile/unif.h | 2 +- 3 files changed, 12 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index ba567ae01..7efb8cc1a 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2001-05-24 Martin Grabmueller + + * unif.c (scm_make_ra, array_free), unif.h (SCM_ARRAY_DIMS): + Changed use of scm_array->scm_array_t and + scm_array_dim->scm_array_dim_t to enable build with + --disable-deprecated. + 2001-05-24 Michael Livshin The purpose of this set of changes is to regularize Guile's usage diff --git a/libguile/unif.c b/libguile/unif.c index daa74bd3f..aad700af9 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -546,7 +546,8 @@ scm_make_ra (int ndim) SCM_NEWCELL (ra); SCM_DEFER_INTS; SCM_NEWSMOB(ra, ((scm_bits_t) ndim << 17) + scm_tc16_array, - scm_must_malloc ((sizeof (scm_array) + ndim * sizeof (scm_array_dim)), + scm_must_malloc ((sizeof (scm_array_t) + + ndim * sizeof (scm_array_dim_t)), "array")); SCM_ARRAY_V (ra) = scm_nullvect; SCM_ALLOW_INTS; @@ -2635,7 +2636,8 @@ static size_t array_free (SCM ptr) { scm_must_free (SCM_ARRAY_MEM (ptr)); - return sizeof (scm_array) + SCM_ARRAY_NDIM (ptr) * sizeof (scm_array_dim); + return sizeof (scm_array_t) + + SCM_ARRAY_NDIM (ptr) * sizeof (scm_array_dim_t); } void diff --git a/libguile/unif.h b/libguile/unif.h index 14ff17904..3da009a12 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -98,7 +98,7 @@ extern scm_bits_t scm_tc16_array; #define SCM_ARRAY_MEM(a) ((scm_array_t *) SCM_CELL_WORD_1 (a)) #define SCM_ARRAY_V(a) (SCM_ARRAY_MEM (a)->v) #define SCM_ARRAY_BASE(a) (SCM_ARRAY_MEM (a)->base) -#define SCM_ARRAY_DIMS(a) ((scm_array_dim_t *)((char *) SCM_ARRAY_MEM (a) + sizeof (scm_array))) +#define SCM_ARRAY_DIMS(a) ((scm_array_dim_t *)((char *) SCM_ARRAY_MEM (a) + sizeof (scm_array_t))) #define SCM_I_MAX_LENGTH ((scm_ubits_t)((scm_bits_t)-1) >> 8) From d69c867aae576166d56187a9466f6f3ce4126462 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Thu, 24 May 2001 08:19:45 +0000 Subject: [PATCH 1179/2047] *** empty log message *** --- libguile/ChangeLog | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 7efb8cc1a..884f97504 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -10,7 +10,8 @@ The purpose of this set of changes is to regularize Guile's usage of ANSI C integral types, with the following ideas in mind: - - SCM does not nesessarily has to be long. + - SCM does not nesessarily have to be long. + - long is not nesessarily enough to store pointers. - long is not nesessarily the same size as int. The changes are incomplete and possibly buggy. Please test on @@ -82,7 +83,7 @@ scm_num2uint, scm_num2bits, scm_num2ubits, scm_num2ptrdiff, scm_num2size): new functions. - * modules.c (scm_module_reverse_lookup): i, n: int -> scm_bits_t.x + * modules.c (scm_module_reverse_lookup): i, n: int -> scm_bits_t. * load.c: change int -> size_t in various places (where the variable is used to store a string length). @@ -100,7 +101,7 @@ * goops.[hc]: various {int,long} -> scm_bits_t changes. - * gh_data.c (gh_scm2double): no loss of precision any more. + * gh_data.c (gh_num2int): no loss of precision any more. * gh.h (gh_str2scm): len: int -> size_t (gh_{get,set}_substr): start: int -> scm_bits_t, @@ -173,7 +174,7 @@ (scm_contregs_t.num_stack_items): ulong -> scm_ubits_t * continuations.c (scm_make_continuation): change the type of - stack_size form long to scm_bits_t. + stack_size from long to scm_bits_t. * ports.h: type renaming: scm_port_rw_active -> scm_port_rw_active_t (and made a typedef) @@ -185,11 +186,11 @@ (scm_port_t.putback_buf_size): int -> size_t. * __scm.h (long_long, ulong_long): deprecated (they pollute the - global namespace and have little value besides that). + global namespace and have little value beside that). (SCM_BITS_LENGTH): new, is the bit size of scm_bits_t (i.e. of an SCM handle). (ifdef spaghetti): include sys/types.h and sys/stdtypes.h, if they - exist (for size_t & ptrdiff_t) + exist (for size_t & ptrdiff_t). (scm_sizet): deprecated. * Makefile.am (noinst_HEADERS): add num2integral.i.c From 4a0ef52435021716f7de16c0c184a5a7addded24 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 24 May 2001 08:46:50 +0000 Subject: [PATCH 1180/2047] Created a usecase diagram for Guile. --- doc/use-cases.fig | 199 ++++++++++++++++++++++++++++++++++++++++++++++ doc/use-cases.txt | 22 +++++ 2 files changed, 221 insertions(+) create mode 100644 doc/use-cases.fig create mode 100644 doc/use-cases.txt diff --git a/doc/use-cases.fig b/doc/use-cases.fig new file mode 100644 index 000000000..24118ff31 --- /dev/null +++ b/doc/use-cases.fig @@ -0,0 +1,199 @@ +#FIG 3.2 +Portrait +Center +Metric +A4 +100.00 +Single +-2 +1200 2 +0 32 #424242 +0 33 #848484 +0 34 #c6c6c6 +0 35 #8c8c8c +0 36 #c6c6c6 +0 37 #848484 +0 38 #8c8c8c +0 39 #424242 +0 40 #848484 +0 41 #c6c6c6 +0 42 #e7e7e7 +0 43 #c6b594 +0 44 #efffff +0 45 #decea5 +0 46 #adadad +0 47 #525252 +0 48 #8c8c8c +0 49 #424242 +0 50 #848484 +0 51 #c6c6c6 +0 52 #e7e7e7 +0 53 #424242 +0 54 #848484 +0 55 #c6c6c6 +0 56 #e7e7e7 +0 57 #424242 +0 58 #848484 +0 59 #c6c6c6 +0 60 #e7e7e7 +0 61 #424242 +0 62 #848484 +0 63 #c6c6c6 +0 64 #e7e7e7 +0 65 #424242 +0 66 #848484 +0 67 #c6c6c6 +0 68 #e7e7e7 +0 69 #8c8c8c +0 70 #424242 +0 71 #848484 +0 72 #c6c6c6 +0 73 #424242 +0 74 #c6c6c6 +0 75 #e7e7e7 +0 76 #424242 +0 77 #848484 +0 78 #c6c6c6 +0 79 #848484 +0 80 #c6c6c6 +0 81 #e7e7e7 +0 82 #424242 +0 83 #8c8c8c +0 84 #424242 +0 85 #8c8c8c +0 86 #424242 +0 87 #8c8c8c +0 88 #424242 +0 89 #8c8c8c +0 90 #424242 +0 91 #8c8c8c +0 92 #424242 +0 93 #8c8c8c +0 94 #424242 +0 95 #8c8c8c +0 96 #424242 +0 97 #8c8c8c +0 98 #c6c6c6 +0 99 #e7e7e7 +0 100 #848484 +0 101 #c6c6c6 +0 102 #e7e7e7 +0 103 #8c8c8c +0 104 #424242 +0 105 #8c8c8c +0 106 #424242 +0 107 #848484 +0 108 #c6c6c6 +0 109 #e7e7e7 +0 110 #8c8c8c +0 111 #424242 +0 112 #8c8c8c +0 113 #8c8c8c +0 114 #8c8c8c +0 115 #424242 +0 116 #adadad +6 450 225 1350 1710 +1 4 0 1 0 7 100 0 -1 4.000 1 0.0000 900 406 176 176 765 294 1035 519 +2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 3 + 450 1710 900 1260 1350 1710 +2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 16 + 900 1260 900 1215 900 1170 900 1125 900 1080 900 1035 + 900 990 900 945 900 900 900 855 900 810 900 765 + 900 720 900 675 900 630 900 585 +2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 2 + 450 810 1350 810 +-6 +6 450 2250 1350 3735 +1 4 0 1 0 7 100 0 -1 4.000 1 0.0000 900 2431 176 176 765 2319 1035 2544 +2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 3 + 450 3735 900 3285 1350 3735 +2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 16 + 900 3285 900 3240 900 3195 900 3150 900 3105 900 3060 + 900 3015 900 2970 900 2925 900 2880 900 2835 900 2790 + 900 2745 900 2700 900 2655 900 2610 +2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 2 + 450 2835 1350 2835 +-6 +6 450 4275 1350 5760 +1 4 0 1 0 7 100 0 -1 4.000 1 0.0000 900 4456 176 176 765 4344 1035 4569 +2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 3 + 450 5760 900 5310 1350 5760 +2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 16 + 900 5310 900 5265 900 5220 900 5175 900 5130 900 5085 + 900 5040 900 4995 900 4950 900 4905 900 4860 900 4815 + 900 4770 900 4725 900 4680 900 4635 +2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 2 + 450 4860 1350 4860 +-6 +6 2250 540 3645 1305 +1 2 0 1 0 7 100 0 20 4.000 1 0.0000 2947 922 697 382 2250 540 3645 1305 +4 0 0 100 0 16 12 0.0000 4 135 1245 2340 990 Hack On Guile\001 +-6 +6 2250 2745 3645 3510 +1 2 0 1 0 7 100 0 20 4.000 1 0.0000 2947 3127 697 382 2250 2745 3645 3510 +4 0 0 100 0 16 12 0.0000 4 135 915 2520 3060 Write Guile\001 +4 0 0 50 0 16 12 0.0000 4 135 900 2520 3285 Extensions\001 +-6 +6 2250 4770 3645 5535 +1 2 0 1 0 7 100 0 20 4.000 1 0.0000 2947 5152 697 382 2250 4770 3645 5535 +4 0 0 100 0 16 12 0.0000 4 135 1065 2430 5220 Embed Guile\001 +-6 +6 2250 3690 3645 4455 +1 2 0 1 0 7 100 0 20 4.000 1 0.0000 2947 4072 697 382 2250 3690 3645 4455 +4 0 0 100 0 16 12 0.0000 4 180 1215 2385 4140 Use Guile App\001 +-6 +6 2250 1620 3645 2385 +1 2 0 1 0 7 100 0 20 4.000 1 0.0000 2947 2002 697 382 2250 1620 3645 2385 +4 0 0 100 0 16 12 0.0000 4 180 1050 2430 2070 Write Scripts\001 +-6 +6 4635 1350 5535 2835 +1 4 0 1 0 7 100 0 -1 4.000 1 0.0000 5085 1531 176 176 4950 1419 5220 1644 +2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 3 + 4635 2835 5085 2385 5535 2835 +2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 16 + 5085 2385 5085 2340 5085 2295 5085 2250 5085 2205 5085 2160 + 5085 2115 5085 2070 5085 2025 5085 1980 5085 1935 5085 1890 + 5085 1845 5085 1800 5085 1755 5085 1710 +2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 2 + 4635 1935 5535 1935 +-6 +6 4635 3375 5535 4860 +1 4 0 1 0 7 100 0 -1 4.000 1 0.0000 5085 3556 176 176 4950 3444 5220 3669 +2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 3 + 4635 4860 5085 4410 5535 4860 +2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 16 + 5085 4410 5085 4365 5085 4320 5085 4275 5085 4230 5085 4185 + 5085 4140 5085 4095 5085 4050 5085 4005 5085 3960 5085 3915 + 5085 3870 5085 3825 5085 3780 5085 3735 +2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 2 + 4635 3960 5535 3960 +-6 +2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 1 0 2 + 1 0 1.00 314.32 228.60 + 1395 945 2272 945 +2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 1 0 2 + 1 0 1.00 314.32 228.60 + 1395 3150 2272 3150 +2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 1 0 2 + 1 0 1.00 314.32 228.60 + 1395 5130 2272 5130 +2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 1 0 2 + 1 0 1.00 314.32 228.60 + 1395 4860 2295 3330 +2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 1 0 2 + 1 0 1.00 314.32 228.60 + 1395 1215 2385 2880 +2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 1 0 2 + 1 0 1.00 314.32 228.60 + 4545 1980 3668 1980 +2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 1 0 2 + 1 0 1.00 314.32 228.60 + 4545 4050 3668 4050 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 1980 135 3960 135 3960 6075 1980 6075 1980 135 +4 0 0 50 0 16 12 0.0000 4 180 1365 225 1935 Guile Developer\001 +4 0 0 50 0 16 12 0.0000 4 180 1740 90 3960 Extension Developer\001 +4 0 0 50 0 16 12 0.0000 4 180 1875 45 5985 Application Developer\001 +4 0 0 50 0 16 12 0.0000 4 135 435 2790 360 Guile\001 +4 0 0 50 0 16 12 0.0000 4 180 1725 4230 3060 Scheme Programmer\001 +4 0 0 50 0 16 12 0.0000 4 180 1380 4410 5085 Application User\001 diff --git a/doc/use-cases.txt b/doc/use-cases.txt new file mode 100644 index 000000000..e455fd1b8 --- /dev/null +++ b/doc/use-cases.txt @@ -0,0 +1,22 @@ + +-------------------+ + | Guile | + O | | + -+- | .---------------. | + | -------->| Hack On Guile | | + / \ \ | `---------------' | O +Guile Developer | .---------------. | -+- + \ | | Write Scripts |<------ | + O \ | `---------------' | / \ + -+- `--->.---------------. | Scheme Programmer + | -------->| Write Guile | | + / \ .-->| Extensions | | + Extension / | `---------------' | O + Developer / | .---------------. | -+- + / | | Use Guile App |<------ | + O / | `---------------' | / \ + -+- / | .---------------. | Application User + | -------->| Embed Guile | | + / \ | `---------------' | + Application | | + Developer | | + +-------------------+ From b337528fb5cd6d8bf281fd387bec60fcf503467b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 25 May 2001 00:15:32 +0000 Subject: [PATCH 1181/2047] * Makefile.am (ice9_sources): Added "pretty-print.scm". * pretty-print.scm: New file, copied from SLIB. * format.scm: Autoload `pretty-print'. --- ice-9/Makefile.am | 7 +- ice-9/format.scm | 5 +- ice-9/pretty-print.scm | 279 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 286 insertions(+), 5 deletions(-) create mode 100644 ice-9/pretty-print.scm diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index a05a63bf7..4e436295a 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -28,10 +28,11 @@ ice9_sources = \ format.scm getopt-long.scm hcons.scm lineio.scm ls.scm mapping.scm \ match.scm networking.scm null.scm optargs.scm poe.scm popen.scm \ posix.scm psyntax.pp psyntax.ss q.scm r4rs.scm r5rs.scm \ - rdelim.scm receive.scm regex.scm runq.scm rw.scm \ + rdelim.scm receive.scm regex.scm runq.scm rw.scm \ safe-r5rs.scm safe.scm session.scm slib.scm stack-catch.scm \ - streams.scm string-fun.scm syncase.scm tags.scm threads.scm \ - buffered-input.scm time.scm history.scm channel.scm + streams.scm string-fun.scm syncase.scm tags.scm threads.scm \ + buffered-input.scm time.scm history.scm channel.scm \ + pretty-print.scm subpkgdatadir = $(pkgdatadir)/$(VERSION)/ice-9 subpkgdata_DATA = $(ice9_sources) diff --git a/ice-9/format.scm b/ice-9/format.scm index ffc70f382..c54d57839 100644 --- a/ice-9/format.scm +++ b/ice-9/format.scm @@ -11,7 +11,9 @@ ; ; Version 3.0 -(define-module (ice-9 format)) +(define-module (ice-9 format) + :autoload (ice-9 pretty-print) (pretty-print)) + (export format format:symbol-case-conv format:iobj-case-conv @@ -445,7 +447,6 @@ (format:tabulate modifier params) (anychar-dispatch)) ((#\Y) ; Pretty-print - (require 'pretty-print) (pretty-print (next-arg) format:port) (set! format:output-col 0) (anychar-dispatch)) diff --git a/ice-9/pretty-print.scm b/ice-9/pretty-print.scm new file mode 100644 index 000000000..daa65c5bd --- /dev/null +++ b/ice-9/pretty-print.scm @@ -0,0 +1,279 @@ +(define-module (ice-9 pretty-print)) + +(export pretty-print) + +;; From SLIB. + +;;"genwrite.scm" generic write used by pretty-print and truncated-print. +;; Copyright (c) 1991, Marc Feeley +;; Author: Marc Feeley (feeley@iro.umontreal.ca) +;; Distribution restrictions: none + +(define genwrite:newline-str (make-string 1 #\newline)) + +(define (generic-write obj display? width output) + + (define (read-macro? l) + (define (length1? l) (and (pair? l) (null? (cdr l)))) + (let ((head (car l)) (tail (cdr l))) + (case head + ((quote quasiquote unquote unquote-splicing) (length1? tail)) + (else #f)))) + + (define (read-macro-body l) + (cadr l)) + + (define (read-macro-prefix l) + (let ((head (car l)) (tail (cdr l))) + (case head + ((quote) "'") + ((quasiquote) "`") + ((unquote) ",") + ((unquote-splicing) ",@")))) + + (define (out str col) + (and col (output str) (+ col (string-length str)))) + + (define (wr obj col) + + (define (wr-expr expr col) + (if (read-macro? expr) + (wr (read-macro-body expr) (out (read-macro-prefix expr) col)) + (wr-lst expr col))) + + (define (wr-lst l col) + (if (pair? l) + (let loop ((l (cdr l)) + (col (and col (wr (car l) (out "(" col))))) + (cond ((not col) col) + ((pair? l) + (loop (cdr l) (wr (car l) (out " " col)))) + ((null? l) (out ")" col)) + (else (out ")" (wr l (out " . " col)))))) + (out "()" col))) + + (cond ((pair? obj) (wr-expr obj col)) + ((null? obj) (wr-lst obj col)) + ((vector? obj) (wr-lst (vector->list obj) (out "#" col))) + ((boolean? obj) (out (if obj "#t" "#f") col)) + ((number? obj) (out (number->string obj) col)) + ((symbol? obj) (out (symbol->string obj) col)) + ((procedure? obj) (out "#[procedure]" col)) + ((string? obj) (if display? + (out obj col) + (let loop ((i 0) (j 0) (col (out "\"" col))) + (if (and col (< j (string-length obj))) + (let ((c (string-ref obj j))) + (if (or (char=? c #\\) + (char=? c #\")) + (loop j + (+ j 1) + (out "\\" + (out (substring obj i j) + col))) + (loop i (+ j 1) col))) + (out "\"" + (out (substring obj i j) col)))))) + ((char? obj) (if display? + (out (make-string 1 obj) col) + (out (case obj + ((#\space) "space") + ((#\newline) "newline") + (else (make-string 1 obj))) + (out "#\\" col)))) + ((input-port? obj) (out "#[input-port]" col)) + ((output-port? obj) (out "#[output-port]" col)) + ((eof-object? obj) (out "#[eof-object]" col)) + (else (out "#[unknown]" col)))) + + (define (pp obj col) + + (define (spaces n col) + (if (> n 0) + (if (> n 7) + (spaces (- n 8) (out " " col)) + (out (substring " " 0 n) col)) + col)) + + (define (indent to col) + (and col + (if (< to col) + (and (out genwrite:newline-str col) (spaces to 0)) + (spaces (- to col) col)))) + + (define (pr obj col extra pp-pair) + (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines + (let ((result '()) + (left (min (+ (- (- width col) extra) 1) max-expr-width))) + (generic-write obj display? #f + (lambda (str) + (set! result (cons str result)) + (set! left (- left (string-length str))) + (> left 0))) + (if (> left 0) ; all can be printed on one line + (out (reverse-string-append result) col) + (if (pair? obj) + (pp-pair obj col extra) + (pp-list (vector->list obj) (out "#" col) extra pp-expr)))) + (wr obj col))) + + (define (pp-expr expr col extra) + (if (read-macro? expr) + (pr (read-macro-body expr) + (out (read-macro-prefix expr) col) + extra + pp-expr) + (let ((head (car expr))) + (if (symbol? head) + (let ((proc (style head))) + (if proc + (proc expr col extra) + (if (> (string-length (symbol->string head)) + max-call-head-width) + (pp-general expr col extra #f #f #f pp-expr) + (pp-call expr col extra pp-expr)))) + (pp-list expr col extra pp-expr))))) + + ; (head item1 + ; item2 + ; item3) + (define (pp-call expr col extra pp-item) + (let ((col* (wr (car expr) (out "(" col)))) + (and col + (pp-down (cdr expr) col* (+ col* 1) extra pp-item)))) + + ; (item1 + ; item2 + ; item3) + (define (pp-list l col extra pp-item) + (let ((col (out "(" col))) + (pp-down l col col extra pp-item))) + + (define (pp-down l col1 col2 extra pp-item) + (let loop ((l l) (col col1)) + (and col + (cond ((pair? l) + (let ((rest (cdr l))) + (let ((extra (if (null? rest) (+ extra 1) 0))) + (loop rest + (pr (car l) (indent col2 col) extra pp-item))))) + ((null? l) + (out ")" col)) + (else + (out ")" + (pr l + (indent col2 (out "." (indent col2 col))) + (+ extra 1) + pp-item))))))) + + (define (pp-general expr col extra named? pp-1 pp-2 pp-3) + + (define (tail1 rest col1 col2 col3) + (if (and pp-1 (pair? rest)) + (let* ((val1 (car rest)) + (rest (cdr rest)) + (extra (if (null? rest) (+ extra 1) 0))) + (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3)) + (tail2 rest col1 col2 col3))) + + (define (tail2 rest col1 col2 col3) + (if (and pp-2 (pair? rest)) + (let* ((val1 (car rest)) + (rest (cdr rest)) + (extra (if (null? rest) (+ extra 1) 0))) + (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2))) + (tail3 rest col1 col2))) + + (define (tail3 rest col1 col2) + (pp-down rest col2 col1 extra pp-3)) + + (let* ((head (car expr)) + (rest (cdr expr)) + (col* (wr head (out "(" col)))) + (if (and named? (pair? rest)) + (let* ((name (car rest)) + (rest (cdr rest)) + (col** (wr name (out " " col*)))) + (tail1 rest (+ col indent-general) col** (+ col** 1))) + (tail1 rest (+ col indent-general) col* (+ col* 1))))) + + (define (pp-expr-list l col extra) + (pp-list l col extra pp-expr)) + + (define (pp-LAMBDA expr col extra) + (pp-general expr col extra #f pp-expr-list #f pp-expr)) + + (define (pp-IF expr col extra) + (pp-general expr col extra #f pp-expr #f pp-expr)) + + (define (pp-COND expr col extra) + (pp-call expr col extra pp-expr-list)) + + (define (pp-CASE expr col extra) + (pp-general expr col extra #f pp-expr #f pp-expr-list)) + + (define (pp-AND expr col extra) + (pp-call expr col extra pp-expr)) + + (define (pp-LET expr col extra) + (let* ((rest (cdr expr)) + (named? (and (pair? rest) (symbol? (car rest))))) + (pp-general expr col extra named? pp-expr-list #f pp-expr))) + + (define (pp-BEGIN expr col extra) + (pp-general expr col extra #f #f #f pp-expr)) + + (define (pp-DO expr col extra) + (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr)) + + ; define formatting style (change these to suit your style) + + (define indent-general 2) + + (define max-call-head-width 5) + + (define max-expr-width 50) + + (define (style head) + (case head + ((lambda let* letrec define) pp-LAMBDA) + ((if set!) pp-IF) + ((cond) pp-COND) + ((case) pp-CASE) + ((and or) pp-AND) + ((let) pp-LET) + ((begin) pp-BEGIN) + ((do) pp-DO) + (else #f))) + + (pr obj col 0 pp-expr)) + + (if width + (out genwrite:newline-str (pp obj 0)) + (wr obj 0))) + +; (reverse-string-append l) = (apply string-append (reverse l)) + +(define (reverse-string-append l) + + (define (rev-string-append l i) + (if (pair? l) + (let* ((str (car l)) + (len (string-length str)) + (result (rev-string-append (cdr l) (+ i len)))) + (let loop ((j 0) (k (- (- (string-length result) i) len))) + (if (< j len) + (begin + (string-set! result k (string-ref str j)) + (loop (+ j 1) (+ k 1))) + result))) + (make-string i))) + + (rev-string-append l 0)) + +;"pp.scm" Pretty-Print +(define (pretty-print obj . opt) + (let ((port (if (pair? opt) (car opt) (current-output-port)))) + (generic-write obj #f 79 + (lambda (s) (display s port) #t)))) + From 863e833bc68d87b914c0446b4ad0f3b0833b4b9c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 25 May 2001 00:17:32 +0000 Subject: [PATCH 1182/2047] * eval.c (scm_debug_opts): New option `show-file-name'. * debug.h (SCM_SHOW_FILE_NAME): New. --- libguile/eval.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/eval.c b/libguile/eval.c index 17fbdc632..c2307c550 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1686,7 +1686,8 @@ scm_option_t scm_debug_opts[] = { { SCM_OPTION_INTEGER, "depth", 20, "Maximal length of printed backtrace." }, { SCM_OPTION_BOOLEAN, "backtrace", 0, "Show backtrace on error." }, { SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." }, - { SCM_OPTION_INTEGER, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." } + { SCM_OPTION_INTEGER, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }, + { SCM_OPTION_SCM, "show-file-name", SCM_BOOL_T, "Show file names and line numbers in backtraces when not `#f'. A value of `base' displays only base names, while `#t' displays full names."} }; scm_option_t scm_evaluator_trap_table[] = { From 29067b9dca63a019b1d8997d2a6632b5660cec82 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 25 May 2001 00:17:54 +0000 Subject: [PATCH 1183/2047] * eval.c (scm_debug_opts): New option `show-file-name'. * debug.h (SCM_SHOW_FILE_NAME): New. * debug.h (scm_lookup_cstr, scm_lookup_soft, scm_evstr): Prototypes removed since there's no definition for these functions. --- libguile/debug.h | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/libguile/debug.h b/libguile/debug.h index 2ee0e777c..d0f78a55e 100644 --- a/libguile/debug.h +++ b/libguile/debug.h @@ -84,7 +84,8 @@ extern scm_option_t scm_debug_opts[]; #define SCM_BACKTRACE_P scm_debug_opts[10].val #define SCM_DEVAL_P scm_debug_opts[11].val #define SCM_STACK_LIMIT scm_debug_opts[12].val -#define SCM_N_DEBUG_OPTIONS 13 +#define SCM_SHOW_FILE_NAME scm_debug_opts[13].val +#define SCM_N_DEBUG_OPTIONS 14 extern SCM (*scm_ceval_ptr) (SCM exp, SCM env); @@ -186,9 +187,6 @@ extern scm_bits_t scm_tc16_memoized; -extern SCM * scm_lookup_cstr (char *str, int len, SCM env); -extern SCM * scm_lookup_soft (SCM var, SCM genv); -extern SCM scm_evstr (char *str); extern SCM scm_eval_string (SCM str); extern int scm_ready_p (void); extern void debug_print (SCM obj); From fec097f0382528ca46092d2a835d153950e075e7 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 25 May 2001 00:19:36 +0000 Subject: [PATCH 1184/2047] Include "libguile/filesys.h". (sym_base, display_backtrace_get_file_line, display_backtrace_file, display_backtrace_file_and_line): New. (display_frame): Call display_backtrace_file_and_line if that is requested. (display_backtrace_body): Call scm_display_backtrace_file if requested. --- libguile/backtrace.c | 100 +++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 96 insertions(+), 4 deletions(-) diff --git a/libguile/backtrace.c b/libguile/backtrace.c index b4636a160..a602d9139 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -66,6 +66,7 @@ #include "libguile/validate.h" #include "libguile/backtrace.h" +#include "libguile/filesys.h" /* {Error reporting and backtraces} * (A first approximation.) @@ -436,6 +437,88 @@ SCM_DEFINE (scm_display_application, "display-application", 1, 2, 0, } #undef FUNC_NAME +SCM_SYMBOL (sym_base, "base"); + +static void +display_backtrace_get_file_line (SCM frame, SCM *file, SCM *line) +{ + SCM source = SCM_FRAME_SOURCE (frame); + *file = SCM_MEMOIZEDP (source) ? scm_source_property (source, scm_sym_filename) : SCM_BOOL_F; + *line = (SCM_MEMOIZEDP (source)) ? scm_source_property (source, scm_sym_line) : SCM_BOOL_F; +} + +static void +display_backtrace_file (frame, last_file, port, pstate) + SCM frame; + SCM *last_file; + SCM port; + scm_print_state *pstate; +{ + SCM file, line; + + display_backtrace_get_file_line (frame, &file, &line); + + if (file == *last_file) + return; + + *last_file = file; + + scm_puts ("In ", port); + if (file == SCM_BOOL_F) + if (line == SCM_BOOL_F) + scm_puts ("unknown file", port); + else + scm_puts ("current input", port); + else + { + pstate->writingp = 0; + scm_iprin1 (file, port, pstate); + pstate->writingp = 1; + } + scm_puts (":\n", port); +} + +static void +display_backtrace_file_and_line (SCM frame, SCM port, scm_print_state *pstate) +{ + SCM file, line; + + display_backtrace_get_file_line (frame, &file, &line); + + if (SCM_EQ_P (SCM_SHOW_FILE_NAME, sym_base)) + { + if (file == SCM_BOOL_F) + { + if (line == SCM_BOOL_F) + scm_putc ('?', port); + else + scm_puts ("", port); + } + else + { + pstate -> writingp = 0; + scm_iprin1 (SCM_STRINGP (file) ? scm_basename (file, SCM_UNDEFINED) : file, + port, pstate); + pstate -> writingp = 1; + } + + scm_putc (':', port); + } + else if (line != SCM_BOOL_F) + { + int i, j=0; + for (i = SCM_INUM (line)+1; i > 0; i = i/10, j++) + ; + indent (4-j, port); + } + + if (line == SCM_BOOL_F) + scm_puts (" ?", port); + else + scm_intprint (SCM_INUM (line) + 1, 10, port); + scm_puts (": ", port); +} + static void display_frame (SCM frame,int nfield,int indentation,SCM sport,SCM port,scm_print_state *pstate) { @@ -448,6 +531,10 @@ display_frame (SCM frame,int nfield,int indentation,SCM sport,SCM port,scm_print scm_puts ("...\n", port); } + /* display file name and line number */ + if (SCM_NFALSEP (SCM_SHOW_FILE_NAME)) + display_backtrace_file_and_line (frame, port, pstate); + /* Check size of frame number. */ n = SCM_FRAME_NUMBER (frame); for (i = 0, j = n; j > 0; ++i) j /= 10; @@ -509,6 +596,7 @@ display_backtrace_body(struct display_backtrace_args *a) int n_frames, beg, end, n, i, j; int nfield, indent_p, indentation; SCM frame, sport, print_state; + SCM last_file; scm_print_state *pstate; a->port = SCM_COERCE_OUTPORT (a->port); @@ -595,13 +683,17 @@ display_backtrace_body(struct display_backtrace_args *a) /* Print frames. */ frame = scm_stack_ref (a->stack, SCM_MAKINUM (beg)); indentation = 1; - display_frame (frame, nfield, indentation, sport, a->port, pstate); - for (i = 1; i < n; ++i) + last_file = SCM_UNDEFINED; + for (i = 0; i < n; ++i) { + if (!SCM_EQ_P (SCM_SHOW_FILE_NAME, sym_base)) + display_backtrace_file (frame, &last_file, a->port, pstate); + + display_frame (frame, nfield, indentation, sport, a->port, pstate); if (indent_p && SCM_FRAME_EVAL_ARGS_P (frame)) ++indentation; - frame = SCM_BACKWARDS_P ? SCM_FRAME_PREV (frame) : SCM_FRAME_NEXT (frame); - display_frame (frame, nfield, indentation, sport, a->port, pstate); + frame = (SCM_BACKWARDS_P ? + SCM_FRAME_PREV (frame) : SCM_FRAME_NEXT (frame)); } scm_remember_upto_here_1 (print_state); From 0120801d39369cfb658a16efb5f5616f393690dc Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 25 May 2001 00:19:52 +0000 Subject: [PATCH 1185/2047] *** empty log message *** --- ice-9/ChangeLog | 6 ++++++ libguile/ChangeLog | 17 +++++++++++++++++ 2 files changed, 23 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index fda2e46f7..d275a6ae4 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,9 @@ +2001-05-25 Marius Vollmer + + * Makefile.am (ice9_sources): Added "pretty-print.scm". + * pretty-print.scm: New file, copied from SLIB. + * format.scm: Autoload `pretty-print'. + 2001-05-23 Martin Grabmueller * boot-9.scm (%cond-expand-table): New hash table mapping modules diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 884f97504..967063853 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,20 @@ +2001-05-25 Marius Vollmer + + * eval.c (scm_debug_opts): New option `show-file-name'. + * debug.h (SCM_SHOW_FILE_NAME): New. + + * backtrace.c: Include "libguile/filesys.h". + (sym_base, display_backtrace_get_file_line, + display_backtrace_file, display_backtrace_file_and_line): New. + (display_frame): Call display_backtrace_file_and_line if that is + requested. + (display_backtrace_body): Call scm_display_backtrace_file if + requested. + + * debug.h (scm_lookup_cstr, scm_lookup_soft, scm_evstr): + Prototypes removed since there's no definition for these + functions. + 2001-05-24 Martin Grabmueller * unif.c (scm_make_ra, array_free), unif.h (SCM_ARRAY_DIMS): From e24ca5385a5e24e02c34c4691a9337ab7b35c050 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 25 May 2001 13:15:57 +0000 Subject: [PATCH 1186/2047] (scm_env_module): Exported to Scheme. --- libguile/modules.c | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/libguile/modules.c b/libguile/modules.c index fb2d456e9..439925755 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -262,11 +262,14 @@ scm_lookup_closure_module (SCM proc) } } -SCM -scm_env_module (SCM env) +SCM_DEFINE (scm_env_module, "env-module", 1, 0, 0, + (SCM env), + "Return the module of @var{ENV}, a lexical environment.") +#define FUNC_NAME s_scm_env_module { return scm_lookup_closure_module (scm_env_top_level (env)); } +#undef FUNC_NAME /* * C level implementation of the standard eval closure From 9f79272ab3e724cb34f1b494f931c17d1561dc4a Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 25 May 2001 13:18:52 +0000 Subject: [PATCH 1187/2047] (cond-expand): Define using `procedure->memoizing-macro' to get at the lexical environment. Use `env-module' instead of `current-module' to get the right module. --- ice-9/boot-9.scm | 120 ++++++++++++++++++++++++----------------------- 1 file changed, 61 insertions(+), 59 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 884b7f3c3..4c4f0a9ca 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -2741,67 +2741,69 @@ (append (hashq-ref %cond-expand-table mod '()) features))))) -(define-macro (cond-expand clause . clauses) - - (let ((clauses (cons clause clauses)) - (syntax-error (lambda (cl) - (error "invalid clause in `cond-expand'" cl)))) - (letrec - ((test-clause - (lambda (clause) - (cond - ((symbol? clause) - (or (memq clause %cond-expand-features) - (let lp ((uses (module-uses (current-module)))) - (if (pair? uses) - (or (memq clause - (hashq-ref %cond-expand-table (car uses) '())) - (lp (cdr uses))) - #f)))) - ((pair? clause) +(define cond-expand + (procedure->memoizing-macro + (lambda (exp env) + (let ((clauses (cdr exp)) + (syntax-error (lambda (cl) + (error "invalid clause in `cond-expand'" cl)))) + (letrec + ((test-clause + (lambda (clause) (cond - ((eq? 'and (car clause)) - (let lp ((l (cdr clause))) - (cond ((null? l) - #t) - ((pair? l) - (and (test-clause (car l)) (lp (cdr l)))) - (else - (syntax-error clause))))) - ((eq? 'or (car clause)) - (let lp ((l (cdr clause))) - (cond ((null? l) - #f) - ((pair? l) - (or (test-clause (car l)) (lp (cdr l)))) - (else - (syntax-error clause))))) - ((eq? 'not (car clause)) - (cond ((not (pair? (cdr clause))) - (syntax-error clause)) - ((pair? (cddr clause)) - ((syntax-error clause)))) - (not (test-clause (cadr clause)))) - (else - (syntax-error clause)))) - (else - (syntax-error clause)))))) - (let lp ((c clauses)) - (cond - ((null? c) - (error "Unfulfilled `cond-expand'")) - ((not (pair? c)) - (syntax-error c)) - ((not (pair? (car c))) - (syntax-error (car c))) - ((test-clause (caar c)) - `(begin ,@(cdar c))) - ((eq? (caar c) 'else) - (if (pair? (cdr c)) + ((symbol? clause) + (or (memq clause %cond-expand-features) + (let lp ((uses (module-uses (env-module env)))) + (if (pair? uses) + (or (memq clause + (hashq-ref %cond-expand-table + (car uses) '())) + (lp (cdr uses))) + #f)))) + ((pair? clause) + (cond + ((eq? 'and (car clause)) + (let lp ((l (cdr clause))) + (cond ((null? l) + #t) + ((pair? l) + (and (test-clause (car l)) (lp (cdr l)))) + (else + (syntax-error clause))))) + ((eq? 'or (car clause)) + (let lp ((l (cdr clause))) + (cond ((null? l) + #f) + ((pair? l) + (or (test-clause (car l)) (lp (cdr l)))) + (else + (syntax-error clause))))) + ((eq? 'not (car clause)) + (cond ((not (pair? (cdr clause))) + (syntax-error clause)) + ((pair? (cddr clause)) + ((syntax-error clause)))) + (not (test-clause (cadr clause)))) + (else + (syntax-error clause)))) + (else + (syntax-error clause)))))) + (let lp ((c clauses)) + (cond + ((null? c) + (error "Unfulfilled `cond-expand'")) + ((not (pair? c)) (syntax-error c)) - `(begin ,@(cdar c))) - (else - (lp (cdr c)))))))) + ((not (pair? (car c))) + (syntax-error (car c))) + ((test-clause (caar c)) + `(begin ,@(cdar c))) + ((eq? (caar c) 'else) + (if (pair? (cdr c)) + (syntax-error c)) + `(begin ,@(cdar c))) + (else + (lp (cdr c)))))))))) ;; This procedure gets called from the startup code with a list of ;; numbers, which are the numbers of the SRFIs to be loaded on startup. From 21a10205edfdb05f702dadb9a1d44ce49dbd2bef Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 25 May 2001 13:20:41 +0000 Subject: [PATCH 1188/2047] (generic-write): Return the `unspecified' value. --- ice-9/pretty-print.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/ice-9/pretty-print.scm b/ice-9/pretty-print.scm index daa65c5bd..bf4aac2ac 100644 --- a/ice-9/pretty-print.scm +++ b/ice-9/pretty-print.scm @@ -250,7 +250,9 @@ (if width (out genwrite:newline-str (pp obj 0)) - (wr obj 0))) + (wr obj 0)) + ;; Return `unspecified' + (if #f #f)) ; (reverse-string-append l) = (apply string-append (reverse l)) From f4e0611e9937d9b9abb34495b49c17c4a3576c2e Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 25 May 2001 13:22:14 +0000 Subject: [PATCH 1189/2047] *** empty log message *** --- ice-9/ChangeLog | 7 +++++++ libguile/ChangeLog | 2 ++ 2 files changed, 9 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index d275a6ae4..4c22e75f1 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,7 +1,14 @@ 2001-05-25 Marius Vollmer + * boot-9.scm (cond-expand): Define using + `procedure->memoizing-macro' to get at the lexical environment. + Use `env-module' instead of `current-module' to get the right + module. + * Makefile.am (ice9_sources): Added "pretty-print.scm". * pretty-print.scm: New file, copied from SLIB. + (generic-write): Return the `unspecified' value. + * format.scm: Autoload `pretty-print'. 2001-05-23 Martin Grabmueller diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 967063853..38bd63680 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,7 @@ 2001-05-25 Marius Vollmer + * modules.c (scm_env_module): Exported to Scheme. + * eval.c (scm_debug_opts): New option `show-file-name'. * debug.h (SCM_SHOW_FILE_NAME): New. From f3f70257a3befb6495760923d167e52d5cdfddae Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Sat, 26 May 2001 20:49:01 +0000 Subject: [PATCH 1190/2047] revert the ill-considered part of 2001-05-23 changes --- ChangeLog | 4 ++++ NEWS | 11 +++-------- acconfig.h | 5 ----- configure.in | 16 ++-------------- 4 files changed, 9 insertions(+), 27 deletions(-) diff --git a/ChangeLog b/ChangeLog index 7b04c5ab2..e4eecbc30 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2001-05-26 Michael Livshin + + revert the controversial part of the 2001-05-23 changes + 2001-05-23 Michael Livshin * configure.in: configury for SCM_[U]BITS_T, some more sizeofs. diff --git a/NEWS b/NEWS index 9238563d1..724a3589e 100644 --- a/NEWS +++ b/NEWS @@ -945,10 +945,6 @@ of lists of same. They are of questionable utility and they pollute the global namespace. -** New macro: SCM_BITS_LENGTH. - -The bit size of an SCM. - ** Deprecated typedef: scm_sizet It is of questionable utility now that Guile requires ANSI C, and is @@ -970,16 +966,15 @@ bignums directly, and should deal with numbers in general (which can be bignums). ** New functions: scm_short2num, scm_ushort2num, scm_int2num, - scm_uint2num, scm_bits2num, scm_ubits2num, scm_size2num, - scm_ptrdiff2num, scm_num2short, scm_num2ushort, scm_num2int, - scm_num2uint, scm_num2bits, scm_num2ubits, scm_num2ptrdiff, + scm_uint2num, scm_size2num, scm_ptrdiff2num, scm_num2short, + scm_num2ushort, scm_num2int, scm_num2uint, scm_num2ptrdiff, scm_num2size. These are conversion functions between the various ANSI C integral types and Scheme numbers. ** New number validation macros: - SCM_NUM2{SIZE,PTRDIFF,SHORT,USHORT,BITS,UBITS,INT,UINT}[_DEF] + SCM_NUM2{SIZE,PTRDIFF,SHORT,USHORT,INT,UINT}[_DEF] See above. diff --git a/acconfig.h b/acconfig.h index 35c37f95f..adfbc0bd1 100644 --- a/acconfig.h +++ b/acconfig.h @@ -167,10 +167,5 @@ /* Define if the compiler supports long longs. */ #undef HAVE_LONG_LONGS -/* SCM will actually be represented by this type. */ -#undef SCM_BITS_T -#undef SCM_UBITS_T -#undef SCM_SIZEOF_BITS_T - /* defined to signed long if doesn't exist: */ #undef ptrdiff_t diff --git a/configure.in b/configure.in index 89257b497..92d1c5444 100644 --- a/configure.in +++ b/configure.in @@ -179,20 +179,8 @@ fi AC_CHECK_SIZEOF(void *) -if test "$ac_cv_sizeof_long" -eq "$ac_cv_sizeof_void_p"; then - AC_DEFINE(SCM_BITS_T, long) - AC_DEFINE(SCM_UBITS_T, unsigned long) - AC_DEFINE(SCM_SIZEOF_BITS_T, SIZEOF_LONG) -elif test \( "$scm_cv_long_longs" = yes \) -a \( "$ac_cv_sizeof_long_long" -eq "$ac_cv_sizeof_void_p" \); then - AC_DEFINE(SCM_BITS_T, long long) - AC_DEFINE(SCM_UBITS_T, unsigned long long) - AC_DEFINE(SCM_SIZEOF_BITS_T, SIZEOF_LONG_LONG) -elif test "$ac_cv_sizeof_int" -eq "$ac_cv_sizeof_void_p"; then - AC_DEFINE(SCM_BITS_T, int) - AC_DEFINE(SCM_UBITS_T, unsigned int) - AC_DEFINE(SCM_SIZEOF_BITS_T, SIZEOF_INT) -else - AC_MSG_ERROR(cannot find an integral type capable of storing a pointer: "$ac_cv_sizeof_void_p" bytes) +if test "$ac_cv_sizeof_long" -ne "$ac_cv_sizeof_void_p"; then + AC_MSG_ERROR(sizes of long and void* are not identical) fi AC_HEADER_STDC From c014a02eec7b99c54d8a156ce491ae8d1e341f97 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Sat, 26 May 2001 20:51:22 +0000 Subject: [PATCH 1191/2047] revert the ill-considered part of the 2001-05-24 changes --- libguile/ChangeLog | 4 + libguile/__scm.h | 2 - libguile/continuations.c | 2 +- libguile/continuations.h | 4 +- libguile/debug.h | 2 +- libguile/deprecation.c | 2 +- libguile/dynwind.c | 2 +- libguile/dynwind.h | 2 +- libguile/environments.c | 18 +-- libguile/eval.c | 52 +++---- libguile/eval.h | 6 +- libguile/fluids.c | 16 +- libguile/fports.c | 16 +- libguile/gc.c | 182 +++++++++++------------ libguile/gc.h | 26 ++-- libguile/gh.h | 26 ++-- libguile/gh_data.c | 46 +++--- libguile/gh_list.c | 2 +- libguile/goops.c | 72 ++++----- libguile/goops.h | 4 +- libguile/gsubr.c | 4 +- libguile/gsubr.h | 6 +- libguile/hash.c | 34 ++--- libguile/hash.h | 10 +- libguile/hashtab.c | 46 +++--- libguile/hashtab.h | 12 +- libguile/ioext.c | 2 +- libguile/list.c | 18 +-- libguile/list.h | 2 +- libguile/load.c | 2 +- libguile/modules.c | 2 +- libguile/numbers.c | 16 -- libguile/numbers.h | 14 +- libguile/objects.c | 14 +- libguile/objects.h | 4 +- libguile/options.h | 2 +- libguile/ports.c | 20 +-- libguile/ports.h | 8 +- libguile/print.c | 16 +- libguile/procs.c | 20 +-- libguile/procs.h | 12 +- libguile/ramap.c | 221 ++++++++++++++-------------- libguile/root.c | 2 +- libguile/rw.c | 8 +- libguile/smob.c | 12 +- libguile/smob.h | 2 +- libguile/sort.c | 42 +++--- libguile/stacks.c | 28 ++-- libguile/stacks.h | 4 +- libguile/strings.c | 16 +- libguile/strop.c | 28 ++-- libguile/strports.c | 6 +- libguile/struct.c | 4 +- libguile/struct.h | 2 +- libguile/symbols.h | 6 +- libguile/tags.h | 3 +- libguile/unif.c | 311 +++++++++++++++++---------------------- libguile/unif.h | 24 +-- libguile/validate.h | 12 +- libguile/values.c | 2 +- libguile/vectors.c | 34 ++--- libguile/vectors.h | 10 +- libguile/weaks.c | 9 +- 63 files changed, 723 insertions(+), 813 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 38bd63680..0e432309d 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2001-05-26 Michael Livshin + + revert the controversial part of the 2001-05-24 changes. + 2001-05-25 Marius Vollmer * modules.c (scm_env_module): Exported to Scheme. diff --git a/libguile/__scm.h b/libguile/__scm.h index 753684edc..5e7637f0d 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -255,8 +255,6 @@ typedef unsigned long long ulong_long; # define SCM_LONG_BIT (SCM_CHAR_BIT * sizeof (long) / sizeof (char)) #endif -#define SCM_BITS_LENGTH (SCM_CHAR_BIT * SCM_SIZEOF_BITS_T) - #ifdef UCHAR_MAX # define SCM_CHAR_CODE_LIMIT (UCHAR_MAX + 1L) #else diff --git a/libguile/continuations.c b/libguile/continuations.c index 81bbe65bd..7b33d7248 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -116,7 +116,7 @@ scm_make_continuation (int *first) volatile SCM cont; scm_contregs_t *continuation; scm_contregs_t *rootcont = SCM_CONTREGS (scm_rootcont); - scm_bits_t stack_size; + long stack_size; SCM_STACKITEM * src; SCM_ENTER_A_SECTION; diff --git a/libguile/continuations.h b/libguile/continuations.h index 0d31225c9..400eee326 100644 --- a/libguile/continuations.h +++ b/libguile/continuations.h @@ -63,8 +63,8 @@ typedef struct jmp_buf jmpbuf; SCM dynenv; SCM_STACKITEM *base; /* base of the live stack, before it was saved. */ - scm_bits_t num_stack_items; /* size of the saved stack. */ - scm_ubits_t seq; /* dynamic root identifier. */ + size_t num_stack_items; /* size of the saved stack. */ + unsigned long seq; /* dynamic root identifier. */ #ifdef DEBUG_EXTENSIONS /* the most recently created debug frame on the live stack, before diff --git a/libguile/debug.h b/libguile/debug.h index d0f78a55e..742726fae 100644 --- a/libguile/debug.h +++ b/libguile/debug.h @@ -116,7 +116,7 @@ typedef union scm_debug_info_t SCM id; } scm_debug_info_t; -extern scm_bits_t scm_debug_eframe_size; +extern long scm_debug_eframe_size; typedef struct scm_debug_frame_t { diff --git a/libguile/deprecation.c b/libguile/deprecation.c index aad7bc09c..1f6d1ffb0 100644 --- a/libguile/deprecation.c +++ b/libguile/deprecation.c @@ -52,7 +52,7 @@ -#if SCM_DEBUG_DEPRECATED == 0 +#if (SCM_DEBUG_DEPRECATED == 0) /* This is either a boolean (when a summary should be printed) or a hashtab (when detailed warnings shouold be printed). diff --git a/libguile/dynwind.c b/libguile/dynwind.c index ef0a144ce..bc4c72575 100644 --- a/libguile/dynwind.c +++ b/libguile/dynwind.c @@ -201,7 +201,7 @@ scm_swap_bindings (SCM glocs, SCM vals) } void -scm_dowinds (SCM to, scm_bits_t delta) +scm_dowinds (SCM to, long delta) { tail: if (SCM_EQ_P (to, scm_dynwinds)); diff --git a/libguile/dynwind.h b/libguile/dynwind.h index 49823762c..a8e888b23 100644 --- a/libguile/dynwind.h +++ b/libguile/dynwind.h @@ -56,7 +56,7 @@ extern SCM scm_internal_dynamic_wind (scm_guard_t before, scm_guard_t after, void *inner_data, void *guard_data); -extern void scm_dowinds (SCM to, scm_bits_t delta); +extern void scm_dowinds (SCM to, long delta); extern void scm_init_dynwind (void); #ifdef GUILE_DEBUG diff --git a/libguile/environments.c b/libguile/environments.c index 6455cd9b1..aad811d32 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -508,7 +508,7 @@ observer_mark (SCM observer) static int observer_print (SCM type, SCM port, scm_print_state *pstate) { - SCM address = scm_ubits2num (SCM_UNPACK (type)); + SCM address = scm_ulong2num (SCM_UNPACK (type)); SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16)); scm_puts ("#local; SCM imported = EVAL_ENVIRONMENT (env)->imported; - SCM proc_as_nr = scm_ubits2num ((scm_ubits_t) proc); + SCM proc_as_nr = scm_ulong2num ((unsigned long int) proc); SCM extended_data = scm_cons2 (local, proc_as_nr, data); SCM tmp_result = scm_c_environment_fold (imported, eval_environment_folder, extended_data, init); @@ -1365,7 +1365,7 @@ eval_environment_free (SCM env) static int eval_environment_print (SCM type, SCM port, scm_print_state *pstate) { - SCM address = scm_ubits2num (SCM_UNPACK (type)); + SCM address = scm_ulong2num (SCM_UNPACK (type)); SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16)); scm_puts ("#= 2 && len <= 3, scm_s_expression, "if"); return scm_cons (SCM_IM_IF, SCM_CDR (xorig)); } @@ -563,7 +563,7 @@ SCM_GLOBAL_SYMBOL(scm_sym_and, s_and); SCM scm_m_and (SCM xorig, SCM env) { - scm_bits_t len = scm_ilength (SCM_CDR (xorig)); + long len = scm_ilength (SCM_CDR (xorig)); SCM_ASSYNT (len >= 0, scm_s_test, s_and); if (len >= 1) return scm_cons (SCM_IM_AND, SCM_CDR (xorig)); @@ -577,7 +577,7 @@ SCM_GLOBAL_SYMBOL(scm_sym_or,s_or); SCM scm_m_or (SCM xorig, SCM env) { - scm_bits_t len = scm_ilength (SCM_CDR (xorig)); + long len = scm_ilength (SCM_CDR (xorig)); SCM_ASSYNT (len >= 0, scm_s_test, s_or); if (len >= 1) return scm_cons (SCM_IM_OR, SCM_CDR (xorig)); @@ -615,7 +615,7 @@ SCM scm_m_cond (SCM xorig, SCM env) { SCM arg1, cdrx = scm_list_copy (SCM_CDR (xorig)), x = cdrx; - scm_bits_t len = scm_ilength (x); + long len = scm_ilength (x); SCM_ASSYNT (len >= 1, scm_s_clauses, s_cond); while (SCM_NIMP (x)) { @@ -705,7 +705,7 @@ SCM scm_m_letstar (SCM xorig, SCM env) { SCM x = SCM_CDR (xorig), arg1, proc, vars = SCM_EOL, *varloc = &vars; - scm_bits_t len = scm_ilength (x); + long len = scm_ilength (x); SCM_ASSYNT (len >= 2, scm_s_body, s_letstar); proc = SCM_CAR (x); SCM_ASSYNT (scm_ilength (proc) >= 0, scm_s_bindings, s_letstar); @@ -747,7 +747,7 @@ scm_m_do (SCM xorig, SCM env) SCM x = SCM_CDR (xorig), arg1, proc; SCM vars = SCM_EOL, inits = SCM_EOL, steps = SCM_EOL; SCM *initloc = &inits, *steploc = &steps; - scm_bits_t len = scm_ilength (x); + long len = scm_ilength (x); SCM_ASSYNT (len >= 2, scm_s_test, "do"); proc = SCM_CAR (x); SCM_ASSYNT (scm_ilength (proc) >= 0, scm_s_bindings, "do"); @@ -780,7 +780,7 @@ scm_m_do (SCM xorig, SCM env) #define evalcar scm_eval_car -static SCM iqq (SCM form, SCM env, scm_bits_t depth); +static SCM iqq (SCM form, SCM env, long depth); SCM_SYNTAX(s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote); SCM_GLOBAL_SYMBOL(scm_sym_quasiquote, s_quasiquote); @@ -795,15 +795,15 @@ scm_m_quasiquote (SCM xorig, SCM env) static SCM -iqq (SCM form, SCM env, scm_bits_t depth) +iqq (SCM form, SCM env, long depth) { SCM tmp; - scm_bits_t edepth = depth; + long edepth = depth; if (SCM_IMP (form)) return form; if (SCM_VECTORP (form)) { - scm_bits_t i = SCM_VECTOR_LENGTH (form); + long i = SCM_VECTOR_LENGTH (form); SCM *data = SCM_VELTS (form); tmp = SCM_EOL; for (; --i >= 0;) @@ -1043,7 +1043,7 @@ SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond); SCM scm_m_nil_cond (SCM xorig, SCM env) { - scm_bits_t len = scm_ilength (SCM_CDR (xorig)); + long len = scm_ilength (SCM_CDR (xorig)); SCM_ASSYNT (len >= 1 && (len & 1) == 1, scm_s_expression, "nil-cond"); return scm_cons (SCM_IM_NIL_COND, SCM_CDR (xorig)); } @@ -1071,7 +1071,7 @@ SCM_SYNTAX (s_0_cond, "0-cond", scm_makmmacro, scm_m_0_cond); SCM scm_m_0_cond (SCM xorig, SCM env) { - scm_bits_t len = scm_ilength (SCM_CDR (xorig)); + long len = scm_ilength (SCM_CDR (xorig)); SCM_ASSYNT (len >= 1 && (len & 1) == 1, scm_s_expression, "0-cond"); return scm_cons (SCM_IM_0_COND, SCM_CDR (xorig)); } @@ -1658,11 +1658,11 @@ scm_debug_frame_t *scm_last_debug_frame; * stack frames at each real stack frame. */ -scm_bits_t scm_debug_eframe_size; +long scm_debug_eframe_size; int scm_debug_mode, scm_check_entry_p, scm_check_apply_p, scm_check_exit_p; -scm_bits_t scm_eval_stack; +long scm_eval_stack; scm_option_t scm_eval_opts[] = { { SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." } @@ -2304,7 +2304,7 @@ dispatch: * cuts down execution time for type dispatch to 50%. */ { - scm_bits_t i, n, end, mask; + long i, n, end, mask; SCM z = SCM_CDDR (x); n = SCM_INUM (SCM_CAR (z)); /* maximum number of specializers */ proc = SCM_CADR (z); @@ -2319,8 +2319,8 @@ dispatch: else { /* Compute a hash value */ - scm_bits_t hashset = SCM_INUM (proc); - scm_bits_t j = n; + long hashset = SCM_INUM (proc); + long j = n; mask = SCM_INUM (SCM_CAR (z = SCM_CDDR (z))); proc = SCM_CADR (z); i = 0; @@ -2340,7 +2340,7 @@ dispatch: /* Search for match */ do { - scm_bits_t j = n; + long j = n; z = SCM_VELTS (proc)[i]; t.arg1 = arg2; /* list of arguments */ if (SCM_NIMP (t.arg1)) @@ -3632,18 +3632,18 @@ ret: and claim that the i'th element of ARGV is WHO's i+2'th argument. */ static inline void check_map_args (SCM argv, - scm_bits_t len, + long len, SCM gf, SCM proc, SCM args, const char *who) { SCM *ve = SCM_VELTS (argv); - scm_bits_t i; + long i; for (i = SCM_VECTOR_LENGTH (argv) - 1; i >= 1; i--) { - scm_bits_t elt_len = scm_ilength (ve[i]); + long elt_len = scm_ilength (ve[i]); if (elt_len < 0) { @@ -3674,7 +3674,7 @@ SCM scm_map (SCM proc, SCM arg1, SCM args) #define FUNC_NAME s_map { - scm_bits_t i, len; + long i, len; SCM res = SCM_EOL; SCM *pres = &res; SCM *ve = &args; /* Keep args from being optimized away. */ @@ -3723,7 +3723,7 @@ scm_for_each (SCM proc, SCM arg1, SCM args) #define FUNC_NAME s_for_each { SCM *ve = &args; /* Keep args from being optimized away. */ - scm_bits_t i, len; + long i, len; len = scm_ilength (arg1); SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args), SCM_ARG2, s_for_each); @@ -3862,7 +3862,7 @@ SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0, return obj; if (SCM_VECTORP (obj)) { - size_t i = SCM_VECTOR_LENGTH (obj); + unsigned long i = SCM_VECTOR_LENGTH (obj); ans = scm_c_make_vector (i, SCM_UNSPECIFIED); while (i--) SCM_VELTS (ans)[i] = scm_copy_tree (SCM_VELTS (obj)[i]); diff --git a/libguile/eval.h b/libguile/eval.h index d34c723da..06ad86969 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -58,7 +58,7 @@ extern scm_option_t scm_eval_opts[]; #define SCM_EVAL_STACK scm_eval_opts[0].val #define SCM_N_EVAL_OPTIONS 1 -extern scm_bits_t scm_eval_stack; +extern long scm_eval_stack; extern scm_option_t scm_evaluator_trap_table[]; @@ -83,8 +83,8 @@ extern SCM scm_eval_options_interface (SCM setting); #define SCM_ICDR (0x00080000L) #define SCM_IFRINC (0x00000100L) #define SCM_IDSTMSK (-SCM_IDINC) -#define SCM_IFRAME(n) ((scm_bits_t)((SCM_ICDR-SCM_IFRINC)>>8) \ - & (SCM_UNPACK (n)) >> 8) +#define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \ + & (SCM_UNPACK (n) >> 8)) #define SCM_IDIST(n) (SCM_UNPACK (n) >> 20) #define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n)) diff --git a/libguile/fluids.c b/libguile/fluids.c index aedb27ed8..718dc5f3f 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -56,7 +56,7 @@ #define INITIAL_FLUIDS 10 #include "libguile/validate.h" -static volatile scm_bits_t n_fluids; +static volatile long n_fluids; scm_bits_t scm_tc16_fluid; SCM @@ -69,7 +69,7 @@ static void grow_fluids (scm_root_state *root_state, int new_length) { SCM old_fluids, new_fluids; - scm_bits_t old_length, i; + long old_length, i; old_fluids = root_state->fluids; old_length = SCM_VECTOR_LENGTH (old_fluids); @@ -104,10 +104,10 @@ fluid_print (SCM exp, SCM port, scm_print_state *pstate) return 1; } -static scm_bits_t +static long next_fluid_num () { - scm_bits_t n; + long n; SCM_CRITICAL_SECTION_START; n = n_fluids++; SCM_CRITICAL_SECTION_END; @@ -125,7 +125,7 @@ SCM_DEFINE (scm_make_fluid, "make-fluid", 0, 0, 0, "in its own dynamic root, you can use fluids for thread local storage.") #define FUNC_NAME s_scm_make_fluid { - scm_bits_t n; + long n; n = next_fluid_num (); SCM_RETURN_NEWSMOB (scm_tc16_fluid, n); @@ -149,7 +149,7 @@ SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0, "@code{#f}.") #define FUNC_NAME s_scm_fluid_ref { - scm_bits_t n; + long n; SCM_VALIDATE_FLUID (1, fluid); @@ -166,7 +166,7 @@ SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0, "Set the value associated with @var{fluid} in the current dynamic root.") #define FUNC_NAME s_scm_fluid_set_x { - scm_bits_t n; + long n; SCM_VALIDATE_FLUID (1, fluid); n = SCM_FLUID_NUM (fluid); @@ -234,7 +234,7 @@ scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata) #define FUNC_NAME "scm_c_with_fluids" { SCM ans; - scm_bits_t flen, vlen; + long flen, vlen; SCM_VALIDATE_LIST_COPYLEN (1, fluids, flen); SCM_VALIDATE_LIST_COPYLEN (2, values, vlen); diff --git a/libguile/fports.c b/libguile/fports.c index 68fba2b13..c8586a38b 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -79,7 +79,7 @@ static const size_t default_buffer_size = 1024; /* create FPORT buffer with specified sizes (or -1 to use default size or 0 for no buffer. */ static void -scm_fport_buffer_add (SCM port, scm_bits_t read_size, scm_bits_t write_size) +scm_fport_buffer_add (SCM port, long read_size, int write_size) #define FUNC_NAME "scm_fport_buffer_add" { scm_fport_t *fp = SCM_FSTREAM (port); @@ -149,7 +149,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, #define FUNC_NAME s_scm_setvbuf { int cmode; - scm_bits_t csize; + long csize; scm_port_t *pt; port = SCM_COERCE_OUTPORT (port); @@ -203,7 +203,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, void scm_evict_ports (int fd) { - scm_bits_t i; + long i; for (i = 0; i < scm_port_table_size; i++) { @@ -505,7 +505,7 @@ static void fport_flush (SCM port); static int fport_fill_input (SCM port) { - scm_bits_t count; + long count; scm_port_t *pt = SCM_PTAB_ENTRY (port); scm_fport_t *fp = SCM_FSTREAM (port); @@ -675,19 +675,19 @@ fport_flush (SCM port) scm_port_t *pt = SCM_PTAB_ENTRY (port); scm_fport_t *fp = SCM_FSTREAM (port); unsigned char *ptr = pt->write_buf; - scm_bits_t init_size = pt->write_pos - pt->write_buf; - scm_bits_t remaining = init_size; + long init_size = pt->write_pos - pt->write_buf; + long remaining = init_size; while (remaining > 0) { - scm_bits_t count; + long count; SCM_SYSCALL (count = write (fp->fdes, ptr, remaining)); if (count < 0) { /* error. assume nothing was written this call, but fix up the buffer for any previous successful writes. */ - scm_bits_t done = init_size - remaining; + long done = init_size - remaining; if (done > 0) { diff --git a/libguile/gc.c b/libguile/gc.c index 3aaab5c0e..2069a1628 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -257,11 +257,11 @@ size_t scm_default_max_segment_size = 2097000L;/* a little less (adm) than 2 Mb # define CELL_DN(p, span) MK_FP(FP_SEG(p), ~(8*(span)-1)&FP_OFF(p)) #else # ifdef _UNICOS -# define CELL_UP(p, span) (SCM_CELLPTR)(~(span) & ((scm_ubits_t)(p)+(span))) -# define CELL_DN(p, span) (SCM_CELLPTR)(~(span) & (scm_ubits_t)(p)) +# define CELL_UP(p, span) (SCM_CELLPTR)(~(span) & ((long)(p)+(span))) +# define CELL_DN(p, span) (SCM_CELLPTR)(~(span) & (long)(p)) # else -# define CELL_UP(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & ((scm_ubits_t)(p)+sizeof(scm_cell)*(span)-1L)) -# define CELL_DN(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & (scm_ubits_t)(p)) +# define CELL_UP(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & ((long)(p)+sizeof(scm_cell)*(span)-1L)) +# define CELL_DN(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & (long)(p)) # endif /* UNICOS */ #endif /* PROT386 */ @@ -301,13 +301,13 @@ typedef struct scm_freelist_t { /* number of cells per object on this list */ int span; /* number of collected cells during last GC */ - scm_ubits_t collected; + unsigned long collected; /* number of collected cells during penultimate GC */ - scm_ubits_t collected_1; + unsigned long collected_1; /* total number of cells in heap segments * belonging to this list. */ - scm_ubits_t heap_size; + unsigned long heap_size; } scm_freelist_t; SCM scm_freelist = SCM_EOL; @@ -322,7 +322,7 @@ scm_freelist_t scm_master_freelist2 = { /* scm_mtrigger * is the number of bytes of must_malloc allocation needed to trigger gc. */ -scm_ubits_t scm_mtrigger; +unsigned long scm_mtrigger; /* scm_gc_heap_lock * If set, don't expand the heap. Set only during gc, during which no allocation @@ -347,20 +347,20 @@ SCM scm_structs_to_free; /* GC Statistics Keeping */ -scm_ubits_t scm_cells_allocated = 0; -scm_ubits_t scm_mallocated = 0; -scm_ubits_t scm_gc_cells_collected; -scm_ubits_t scm_gc_yield; -static scm_ubits_t scm_gc_yield_1 = 0; /* previous GC yield */ -scm_ubits_t scm_gc_malloc_collected; -scm_ubits_t scm_gc_ports_collected; +unsigned long scm_cells_allocated = 0; +unsigned long scm_mallocated = 0; +unsigned long scm_gc_cells_collected; +unsigned long scm_gc_yield; +static unsigned long scm_gc_yield_1 = 0; /* previous GC yield */ +unsigned long scm_gc_malloc_collected; +unsigned long scm_gc_ports_collected; unsigned long scm_gc_time_taken = 0; -static scm_ubits_t t_before_gc; -static scm_ubits_t t_before_sweep; +static unsigned long t_before_gc; +static unsigned long t_before_sweep; unsigned long scm_gc_mark_time_taken = 0; unsigned long scm_gc_sweep_time_taken = 0; -scm_ubits_t scm_gc_times = 0; -scm_ubits_t scm_gc_cells_swept = 0; +unsigned long scm_gc_times = 0; +unsigned long scm_gc_cells_swept = 0; double scm_gc_cells_marked_acc = 0.; double scm_gc_cells_swept_acc = 0.; @@ -482,10 +482,10 @@ clear_mark_space () #if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST) /* Return the number of the heap segment containing CELL. */ -static scm_bits_t +static long which_seg (SCM cell) { - scm_bits_t i; + long i; for (i = 0; i < scm_n_heap_segs; i++) if (SCM_PTR_LE (scm_heap_table[i].bounds[0], SCM2PTR (cell)) @@ -500,12 +500,12 @@ which_seg (SCM cell) static void map_free_list (scm_freelist_t *master, SCM freelist) { - scm_bits_t last_seg = -1, count = 0; + long last_seg = -1, count = 0; SCM f; for (f = freelist; !SCM_NULLP (f); f = SCM_FREE_CELL_CDR (f)) { - scm_bits_t this_seg = which_seg (f); + long this_seg = which_seg (f); if (this_seg != last_seg) { @@ -529,7 +529,7 @@ SCM_DEFINE (scm_map_free_list, "map-free-list", 0, 0, 0, "@code{--enable-guile-debug} builds of Guile.") #define FUNC_NAME s_scm_map_free_list { - scm_bits_t i; + long i; fprintf (stderr, "%ld segments total (%d:%ld", (long) scm_n_heap_segs, scm_heap_table[0].span, @@ -547,14 +547,14 @@ SCM_DEFINE (scm_map_free_list, "map-free-list", 0, 0, 0, } #undef FUNC_NAME -static scm_bits_t last_cluster; -static scm_bits_t last_size; +static long last_cluster; +static long last_size; -static scm_bits_t -free_list_length (char *title, scm_bits_t i, SCM freelist) +static long +free_list_length (char *title, long i, SCM freelist) { SCM ls; - scm_bits_t n = 0; + long n = 0; for (ls = freelist; !SCM_NULLP (ls); ls = SCM_FREE_CELL_CDR (ls)) if (SCM_FREE_CELL_P (ls)) ++n; @@ -586,7 +586,7 @@ static void free_list_lengths (char *title, scm_freelist_t *master, SCM freelist) { SCM clusters; - scm_bits_t i = 0, len, n = 0; + long i = 0, len, n = 0; fprintf (stderr, "%s\n\n", title); n += free_list_length ("free list", -1, freelist); for (clusters = master->clusters; @@ -625,8 +625,8 @@ SCM_DEFINE (scm_free_list_length, "free-list-length", 0, 0, 0, static int scm_debug_check_freelist = 0; /* Number of calls to SCM_NEWCELL since startup. */ -static scm_ubits_t scm_newcell_count; -static scm_ubits_t scm_newcell2_count; +static unsigned long scm_newcell_count; +static unsigned long scm_newcell2_count; /* Search freelist for anything that isn't marked as a free cell. Abort if we find something. */ @@ -634,7 +634,7 @@ static void scm_check_freelist (SCM freelist) { SCM f; - scm_bits_t i = 0; + long i = 0; for (f = freelist; !SCM_NULLP (f); f = SCM_FREE_CELL_CDR (f), i++) if (!SCM_FREE_CELL_P (f)) @@ -722,26 +722,26 @@ scm_debug_newcell2 (void) -static scm_ubits_t +static unsigned long master_cells_allocated (scm_freelist_t *master) { /* the '- 1' below is to ignore the cluster spine cells. */ - scm_bits_t objects = master->clusters_allocated * (master->cluster_size - 1); + long objects = master->clusters_allocated * (master->cluster_size - 1); if (SCM_NULLP (master->clusters)) objects -= master->left_to_collect; return master->span * objects; } -static scm_ubits_t +static unsigned long freelist_length (SCM freelist) { - scm_bits_t n; + long n; for (n = 0; !SCM_NULLP (freelist); freelist = SCM_FREE_CELL_CDR (freelist)) ++n; return n; } -static scm_ubits_t +static unsigned long compute_cells_allocated () { return (scm_cells_allocated @@ -760,17 +760,17 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, "use of storage.") #define FUNC_NAME s_scm_gc_stats { - scm_bits_t i; - scm_bits_t n; + long i; + long n; SCM heap_segs; - scm_ubits_t local_scm_mtrigger; - scm_ubits_t local_scm_mallocated; - scm_ubits_t local_scm_heap_size; - scm_ubits_t local_scm_cells_allocated; - unsigned long local_scm_gc_time_taken; - scm_ubits_t local_scm_gc_times; - unsigned long local_scm_gc_mark_time_taken; - unsigned long local_scm_gc_sweep_time_taken; + unsigned long int local_scm_mtrigger; + unsigned long int local_scm_mallocated; + unsigned long int local_scm_heap_size; + unsigned long int local_scm_cells_allocated; + unsigned long int local_scm_gc_time_taken; + unsigned long int local_scm_gc_times; + unsigned long int local_scm_gc_mark_time_taken; + unsigned long int local_scm_gc_sweep_time_taken; double local_scm_gc_cells_swept; double local_scm_gc_cells_marked; SCM answer; @@ -783,8 +783,8 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, heap_segs = SCM_EOL; n = scm_n_heap_segs; for (i = scm_n_heap_segs; i--; ) - heap_segs = scm_cons (scm_cons (scm_ubits2num ((scm_ubits_t)scm_heap_table[i].bounds[1]), - scm_ubits2num ((scm_ubits_t)scm_heap_table[i].bounds[0])), + heap_segs = scm_cons (scm_cons (scm_ulong2num ((unsigned long)scm_heap_table[i].bounds[1]), + scm_ulong2num ((unsigned long)scm_heap_table[i].bounds[0])), heap_segs); if (scm_n_heap_segs != n) goto retry; @@ -806,11 +806,11 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, local_scm_gc_cells_marked = scm_gc_cells_marked_acc; answer = scm_listify (scm_cons (sym_gc_time_taken, scm_ulong2num (local_scm_gc_time_taken)), - scm_cons (sym_cells_allocated, scm_ubits2num (local_scm_cells_allocated)), - scm_cons (sym_heap_size, scm_ubits2num (local_scm_heap_size)), - scm_cons (sym_mallocated, scm_ubits2num (local_scm_mallocated)), - scm_cons (sym_mtrigger, scm_ubits2num (local_scm_mtrigger)), - scm_cons (sym_times, scm_ubits2num (local_scm_gc_times)), + scm_cons (sym_cells_allocated, scm_ulong2num (local_scm_cells_allocated)), + scm_cons (sym_heap_size, scm_ulong2num (local_scm_heap_size)), + scm_cons (sym_mallocated, scm_ulong2num (local_scm_mallocated)), + scm_cons (sym_mtrigger, scm_ulong2num (local_scm_mtrigger)), + scm_cons (sym_times, scm_ulong2num (local_scm_gc_times)), scm_cons (sym_gc_mark_time_taken, scm_ulong2num (local_scm_gc_mark_time_taken)), scm_cons (sym_gc_sweep_time_taken, scm_ulong2num (local_scm_gc_sweep_time_taken)), scm_cons (sym_cells_marked, scm_i_dbl2big (local_scm_gc_cells_marked)), @@ -857,7 +857,7 @@ SCM_DEFINE (scm_object_address, "object-address", 1, 0, 0, "returned by this function for @var{obj}") #define FUNC_NAME s_scm_object_address { - return scm_ubits2num (SCM_UNPACK (obj)); + return scm_ulong2num ((unsigned long) SCM_UNPACK (obj)); } #undef FUNC_NAME @@ -945,7 +945,7 @@ scm_gc_for_newcell (scm_freelist_t *master, SCM *freelist) fprintf (stderr, "allocated = %lu, ", (long) (scm_cells_allocated + master_cells_allocated (&scm_master_freelist) - + master_cells_allocated (&scm_master_freelist2))); + + master_cells_allocated (&scm_master_freelist2))); #endif scm_igc ("cells"); adjust_min_yield (master); @@ -1002,7 +1002,7 @@ scm_c_hook_t scm_after_gc_c_hook; void scm_igc (const char *what) { - scm_bits_t j; + long j; ++scm_gc_running_p; scm_c_hook_run (&scm_before_gc_c_hook, 0); @@ -1034,8 +1034,8 @@ scm_igc (const char *what) /* flush dead entries from the continuation stack */ { - scm_bits_t x; - scm_bits_t bound; + long x; + long bound; SCM * elts; elts = SCM_VELTS (scm_continuation_stack); bound = SCM_VECTOR_LENGTH (scm_continuation_stack); @@ -1124,7 +1124,7 @@ void MARK (SCM p) #define FUNC_NAME FNAME { - register scm_bits_t i; + register long i; register SCM ptr; scm_bits_t cell_type; @@ -1233,7 +1233,7 @@ gc_mark_loop_first_time: { /* ptr is a struct */ SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]); - scm_bits_t len = SCM_SYMBOL_LENGTH (layout); + long len = SCM_SYMBOL_LENGTH (layout); char * fields_desc = SCM_SYMBOL_CHARS (layout); scm_bits_t * struct_data = (scm_bits_t *) SCM_STRUCT_DATA (ptr); @@ -1244,7 +1244,7 @@ gc_mark_loop_first_time: } if (len) { - scm_bits_t x; + long x; for (x = 0; x < len - 2; x += 2, ++struct_data) if (fields_desc[x] == 'p') @@ -1322,8 +1322,8 @@ gc_mark_loop_first_time: scm_weak_vectors = ptr; if (SCM_IS_WHVEC_ANY (ptr)) { - scm_bits_t x; - scm_bits_t len; + long x; + long len; int weak_keys; int weak_values; @@ -1449,9 +1449,9 @@ gc_mark_loop_first_time: */ void -scm_mark_locations (SCM_STACKITEM x[], scm_ubits_t n) +scm_mark_locations (SCM_STACKITEM x[], unsigned long n) { - scm_ubits_t m; + unsigned long m; for (m = 0; m < n; ++m) { @@ -1459,14 +1459,14 @@ scm_mark_locations (SCM_STACKITEM x[], scm_ubits_t n) if (SCM_CELLP (obj)) { SCM_CELLPTR ptr = SCM2PTR (obj); - scm_bits_t i = 0; - scm_bits_t j = scm_n_heap_segs - 1; + long i = 0; + long j = scm_n_heap_segs - 1; if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr) && SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr)) { while (i <= j) { - scm_bits_t seg_id; + long seg_id; seg_id = -1; if ((i == j) || SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr)) @@ -1475,7 +1475,7 @@ scm_mark_locations (SCM_STACKITEM x[], scm_ubits_t n) seg_id = j; else { - scm_bits_t k; + long k; k = (i + j) / 2; if (k == i) break; @@ -1523,14 +1523,14 @@ scm_cellp (SCM value) { if (SCM_CELLP (value)) { scm_cell * ptr = SCM2PTR (value); - scm_bits_t i = 0; - scm_bits_t j = scm_n_heap_segs - 1; + unsigned long i = 0; + unsigned long j = scm_n_heap_segs - 1; if (SCM_GC_IN_CARD_HEADERP (ptr)) return 0; while (i < j) { - scm_bits_t k = (i + j) / 2; + long k = (i + j) / 2; if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr)) { j = k; } else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr)) { @@ -1566,7 +1566,7 @@ gc_sweep_freelist_start (scm_freelist_t *freelist) static void gc_sweep_freelist_finish (scm_freelist_t *freelist) { - scm_bits_t collected; + long collected; *freelist->clustertail = freelist->cells; if (!SCM_NULLP (freelist->cells)) { @@ -1604,9 +1604,9 @@ scm_gc_sweep () register SCM_CELLPTR ptr; register SCM nfreelist; register scm_freelist_t *freelist; - register scm_ubits_t m; + register unsigned long m; register int span; - scm_bits_t i; + long i; size_t seg_size; m = 0; @@ -1616,7 +1616,7 @@ scm_gc_sweep () for (i = 0; i < scm_n_heap_segs; i++) { - register scm_bits_t left_to_collect; + register long left_to_collect; register size_t j; /* Unmarked cells go onto the front of the freelist this heap @@ -1695,7 +1695,7 @@ scm_gc_sweep () break; case scm_tc7_vector: { - scm_ubits_t length = SCM_VECTOR_LENGTH (scmptr); + unsigned long int length = SCM_VECTOR_LENGTH (scmptr); if (length > 0) { m += length * sizeof (scm_bits_t); @@ -1712,10 +1712,10 @@ scm_gc_sweep () #ifdef HAVE_ARRAYS case scm_tc7_bvect: { - size_t length = SCM_BITVECTOR_LENGTH (scmptr); + unsigned long int length = SCM_BITVECTOR_LENGTH (scmptr); if (length > 0) { - m += sizeof (long) * ((length + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH); + m += sizeof (long) * ((length + SCM_LONG_BIT - 1) / SCM_LONG_BIT); scm_must_free (SCM_BITVECTOR_BASE (scmptr)); } } @@ -1827,7 +1827,7 @@ scm_gc_sweep () #ifdef GC_FREE_SEGMENTS if (n == seg_size) { - register scm_bits_t j; + register long j; freelist->heap_size -= seg_size; free ((char *) scm_heap_table[i].bounds[0]); @@ -1903,7 +1903,7 @@ void * scm_must_malloc (size_t size, const char *what) { void *ptr; - scm_ubits_t nm = scm_mallocated + size; + unsigned long nm = scm_mallocated + size; if (nm < size) /* The byte count of allocated objects has overflowed. This is @@ -1965,7 +1965,7 @@ scm_must_realloc (void *where, const char *what) { void *ptr; - scm_ubits_t nm; + unsigned long nm; if (size <= old_size) return where; @@ -2065,7 +2065,7 @@ scm_must_free (void *obj) * eh? Or even better, call scm_done_free. */ void -scm_done_malloc (scm_bits_t size) +scm_done_malloc (long size) { if (size < 0) { if (scm_mallocated < size) @@ -2076,7 +2076,7 @@ scm_done_malloc (scm_bits_t size) scm_mallocated, which underflowed. */ abort (); } else { - scm_ubits_t nm = scm_mallocated + size; + unsigned long nm = scm_mallocated + size; if (nm < size) /* The byte count of allocated objects has overflowed. This is probably because you forgot to report the correct size of freed @@ -2100,7 +2100,7 @@ scm_done_malloc (scm_bits_t size) } void -scm_done_free (scm_bits_t size) +scm_done_free (long size) { if (size >= 0) { if (scm_mallocated < size) @@ -2111,7 +2111,7 @@ scm_done_free (scm_bits_t size) scm_mallocated, which underflowed. */ abort (); } else { - scm_ubits_t nm = scm_mallocated + size; + unsigned long nm = scm_mallocated + size; if (nm < size) /* The byte count of allocated objects has overflowed. This is probably because you forgot to report the correct size of freed @@ -2174,7 +2174,7 @@ init_heap_seg (SCM_CELLPTR seg_org, size_t size, scm_freelist_t *freelist) { register SCM_CELLPTR ptr; SCM_CELLPTR seg_end; - scm_bits_t new_seg_index; + long new_seg_index; ptrdiff_t n_new_cells; int span = freelist->span; @@ -2359,7 +2359,7 @@ alloc_some_heap (scm_freelist_t *freelist, policy_on_error error_policy) * This gives dh > (f * h - y) / (1 - f) */ int f = freelist->min_yield_fraction; - scm_ubits_t h = SCM_HEAP_SIZE; + unsigned long h = SCM_HEAP_SIZE; size_t min_cells = (f * h - 100 * (long) scm_gc_yield) / (99 - f); len = SCM_EXPHEAP (freelist->heap_size); #ifdef DEBUGINFO @@ -2613,7 +2613,7 @@ make_initial_segment (size_t init_heap_size, scm_freelist_t *freelist) static void init_freelist (scm_freelist_t *freelist, int span, - scm_bits_t cluster_size, + long cluster_size, int min_yield) { freelist->clusters = SCM_EOL; diff --git a/libguile/gc.h b/libguile/gc.h index 464d4df08..a7631c3f7 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -97,7 +97,7 @@ typedef scm_cell * SCM_CELLPTR; #define SCM_GC_SET_CARD_BVEC(card, bvec) \ ((card)->word_0 = (scm_bits_t) (bvec)) -#define SCM_GC_GET_CARD_FLAGS(card) ((scm_ubits_t) ((card)->word_1)) +#define SCM_GC_GET_CARD_FLAGS(card) ((long) ((card)->word_1)) #define SCM_GC_SET_CARD_FLAGS(card, flags) \ ((card)->word_1 = (scm_bits_t) (flags)) #define SCM_GC_CLR_CARD_FLAGS(card) (SCM_GC_SET_CARD_FLAGS (card, 0L)) @@ -119,9 +119,9 @@ typedef scm_cell * SCM_CELLPTR; #define SCM_GC_CARD_SIZE_MASK (SCM_GC_CARD_SIZE - 1) #define SCM_GC_CARD_ADDR_MASK (~SCM_GC_CARD_SIZE_MASK) -#define SCM_GC_CELL_CARD(x) ((SCM_CELLPTR) ((scm_bits_t) (x) & SCM_GC_CARD_ADDR_MASK)) +#define SCM_GC_CELL_CARD(x) ((SCM_CELLPTR) ((long) (x) & SCM_GC_CARD_ADDR_MASK)) #define SCM_GC_CELL_SPAN(x) ((SCM_GC_CARD_DOUBLECELLP (SCM_GC_CELL_CARD (x))) ? 2 : 1) -#define SCM_GC_CELL_OFFSET(x) (((scm_bits_t) (x) & SCM_GC_CARD_SIZE_MASK) >> SCM_CELL_SIZE_SHIFT) +#define SCM_GC_CELL_OFFSET(x) (((long) (x) & SCM_GC_CARD_SIZE_MASK) >> SCM_CELL_SIZE_SHIFT) #define SCM_GC_CELL_BVEC(x) SCM_GC_CARD_BVEC (SCM_GC_CELL_CARD (x)) #define SCM_GC_CELL_GET_BIT(x) SCM_C_BVEC_GET (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x)) #define SCM_GC_CELL_SET_BIT(x) SCM_C_BVEC_SET (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x)) @@ -319,13 +319,13 @@ extern SCM scm_freelist; extern struct scm_freelist_t scm_master_freelist; extern SCM scm_freelist2; extern struct scm_freelist_t scm_master_freelist2; -extern scm_ubits_t scm_gc_cells_collected; -extern scm_ubits_t scm_gc_yield; -extern scm_ubits_t scm_gc_malloc_collected; -extern scm_ubits_t scm_gc_ports_collected; -extern scm_ubits_t scm_cells_allocated; -extern scm_ubits_t scm_mallocated; -extern scm_ubits_t scm_mtrigger; +extern unsigned long scm_gc_cells_collected; +extern unsigned long scm_gc_yield; +extern unsigned long scm_gc_malloc_collected; +extern unsigned long scm_gc_ports_collected; +extern unsigned long scm_cells_allocated; +extern unsigned long scm_mallocated; +extern unsigned long scm_mtrigger; extern SCM scm_after_gc_hook; @@ -363,17 +363,17 @@ extern void scm_alloc_cluster (struct scm_freelist_t *master); extern void scm_igc (const char *what); extern void scm_gc_mark (SCM p); extern void scm_gc_mark_dependencies (SCM p); -extern void scm_mark_locations (SCM_STACKITEM x[], scm_ubits_t n); +extern void scm_mark_locations (SCM_STACKITEM x[], unsigned long n); extern int scm_cellp (SCM value); extern void scm_gc_sweep (void); extern void * scm_must_malloc (size_t len, const char *what); extern void * scm_must_realloc (void *where, size_t olen, size_t len, const char *what); -extern void scm_done_malloc (scm_bits_t size); -extern void scm_done_free (scm_bits_t size); extern char *scm_must_strdup (const char *str); extern char *scm_must_strndup (const char *str, size_t n); +extern void scm_done_malloc (long size); +extern void scm_done_free (long size); extern void scm_must_free (void *obj); extern void scm_remember_upto_here_1 (SCM obj); extern void scm_remember_upto_here_2 (SCM obj1, SCM obj2); diff --git a/libguile/gh.h b/libguile/gh.h index ed3f2d386..6921d22e9 100644 --- a/libguile/gh.h +++ b/libguile/gh.h @@ -103,20 +103,20 @@ SCM gh_double2scm(double x); SCM gh_char2scm(char c); SCM gh_str2scm(const char *s, size_t len); SCM gh_str02scm(const char *s); -void gh_set_substr(char *src, SCM dst, scm_bits_t start, size_t len); +void gh_set_substr(char *src, SCM dst, long start, size_t len); SCM gh_symbol2scm(const char *symbol_str); -SCM gh_ints2scm(const int *d, scm_bits_t n); +SCM gh_ints2scm(const int *d, long n); #ifdef HAVE_ARRAYS -SCM gh_chars2byvect(const char *d, scm_bits_t n); -SCM gh_shorts2svect(const short *d, scm_bits_t n); -SCM gh_longs2ivect(const long *d, scm_bits_t n); -SCM gh_ulongs2uvect(const unsigned long *d, scm_bits_t n); -SCM gh_floats2fvect(const float *d, scm_bits_t n); -SCM gh_doubles2dvect(const double *d, scm_bits_t n); +SCM gh_chars2byvect(const char *d, long n); +SCM gh_shorts2svect(const short *d, long n); +SCM gh_longs2ivect(const long *d, long n); +SCM gh_ulongs2uvect(const unsigned long *d, long n); +SCM gh_floats2fvect(const float *d, long n); +SCM gh_doubles2dvect(const double *d, long n); #endif -SCM gh_doubles2scm(const double *d, scm_bits_t n); +SCM gh_doubles2scm(const double *d, long n); /* Scheme to C conversion */ int gh_scm2bool(SCM obj); @@ -126,7 +126,7 @@ long gh_scm2long(SCM obj); char gh_scm2char(SCM obj); double gh_scm2double(SCM obj); char *gh_scm2newstr(SCM str, size_t *lenp); -void gh_get_substr(SCM src, char *dst, scm_bits_t start, size_t len); +void gh_get_substr(SCM src, char *dst, long start, size_t len); char *gh_symbol2newstr(SCM sym, size_t *lenp); char *gh_scm2chars(SCM vector, char *result); short *gh_scm2shorts(SCM vector, short *result); @@ -178,8 +178,8 @@ SCM gh_define(const char *name, SCM val); SCM gh_make_vector(SCM length, SCM val); SCM gh_vector_set_x(SCM vec, SCM pos, SCM val); SCM gh_vector_ref(SCM vec, SCM pos); -scm_bits_t gh_vector_length (SCM v); -scm_ubits_t gh_uniform_vector_length (SCM v); +unsigned long gh_vector_length (SCM v); +unsigned long gh_uniform_vector_length (SCM v); SCM gh_uniform_vector_ref (SCM v, SCM ilist); #define gh_list_to_vector(ls) scm_vector(ls) #define gh_vector_to_list(v) scm_vector_to_list(v) @@ -189,7 +189,7 @@ SCM gh_module_lookup (SCM module, const char *sname); SCM gh_cons(SCM x, SCM y); #define gh_list scm_listify -scm_bits_t gh_length(SCM l); +unsigned long gh_length(SCM l); SCM gh_append(SCM args); SCM gh_append2(SCM l1, SCM l2); SCM gh_append3(SCM l1, SCM l2, SCM l3); diff --git a/libguile/gh_data.c b/libguile/gh_data.c index 5dbf21da9..dc31bae09 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -95,7 +95,7 @@ gh_str02scm (const char *s) If START + LEN is off the end of DST, signal an out-of-range error. */ void -gh_set_substr (char *src, SCM dst, scm_bits_t start, size_t len) +gh_set_substr (char *src, SCM dst, long start, size_t len) { char *dst_ptr; size_t dst_len; @@ -121,9 +121,9 @@ gh_symbol2scm (const char *symbol_str) } SCM -gh_ints2scm (const int *d, scm_bits_t n) +gh_ints2scm (const int *d, long n) { - scm_bits_t i; + long i; SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED); SCM *velts = SCM_VELTS(v); @@ -134,9 +134,9 @@ gh_ints2scm (const int *d, scm_bits_t n) } SCM -gh_doubles2scm (const double *d, scm_bits_t n) +gh_doubles2scm (const double *d, long n) { - scm_bits_t i; + long i; SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED); SCM *velts = SCM_VELTS(v); @@ -162,7 +162,7 @@ makvect (char *m, size_t len, int type) } SCM -gh_chars2byvect (const char *d, scm_bits_t n) +gh_chars2byvect (const char *d, long n) { char *m = scm_must_malloc (n * sizeof (char), "vector"); memcpy (m, d, n * sizeof (char)); @@ -170,7 +170,7 @@ gh_chars2byvect (const char *d, scm_bits_t n) } SCM -gh_shorts2svect (const short *d, scm_bits_t n) +gh_shorts2svect (const short *d, long n) { char *m = scm_must_malloc (n * sizeof (short), "vector"); memcpy (m, d, n * sizeof (short)); @@ -178,7 +178,7 @@ gh_shorts2svect (const short *d, scm_bits_t n) } SCM -gh_longs2ivect (const long *d, scm_bits_t n) +gh_longs2ivect (const long *d, long n) { char *m = scm_must_malloc (n * sizeof (long), "vector"); memcpy (m, d, n * sizeof (long)); @@ -186,7 +186,7 @@ gh_longs2ivect (const long *d, scm_bits_t n) } SCM -gh_ulongs2uvect (const unsigned long *d, scm_bits_t n) +gh_ulongs2uvect (const unsigned long *d, long n) { char *m = scm_must_malloc (n * sizeof (unsigned long), "vector"); memcpy (m, d, n * sizeof (unsigned long)); @@ -194,7 +194,7 @@ gh_ulongs2uvect (const unsigned long *d, scm_bits_t n) } SCM -gh_floats2fvect (const float *d, scm_bits_t n) +gh_floats2fvect (const float *d, long n) { char *m = scm_must_malloc (n * sizeof (float), "vector"); memcpy (m, d, n * sizeof (float)); @@ -202,7 +202,7 @@ gh_floats2fvect (const float *d, scm_bits_t n) } SCM -gh_doubles2dvect (const double *d, scm_bits_t n) +gh_doubles2dvect (const double *d, long n) { char *m = scm_must_malloc (n * sizeof (double), "vector"); memcpy (m, d, n * sizeof (double)); @@ -251,8 +251,8 @@ gh_scm2char (SCM obj) char * gh_scm2chars (SCM obj, char *m) { - scm_bits_t i, n; - scm_bits_t v; + long i, n; + long v; SCM val; if (SCM_IMP (obj)) scm_wrong_type_arg (0, 0, obj); @@ -311,8 +311,8 @@ gh_scm2chars (SCM obj, char *m) short * gh_scm2shorts (SCM obj, short *m) { - scm_bits_t i, n; - scm_bits_t v; + long i, n; + long v; SCM val; if (SCM_IMP (obj)) scm_wrong_type_arg (0, 0, obj); @@ -362,7 +362,7 @@ gh_scm2shorts (SCM obj, short *m) long * gh_scm2longs (SCM obj, long *m) { - scm_bits_t i, n; + long i, n; SCM val; if (SCM_IMP (obj)) scm_wrong_type_arg (0, 0, obj); @@ -412,7 +412,7 @@ gh_scm2longs (SCM obj, long *m) float * gh_scm2floats (SCM obj, float *m) { - scm_bits_t i, n; + long i, n; SCM val; if (SCM_IMP (obj)) scm_wrong_type_arg (0, 0, obj); @@ -475,7 +475,7 @@ gh_scm2floats (SCM obj, float *m) double * gh_scm2doubles (SCM obj, double *m) { - scm_bits_t i, n; + long i, n; SCM val; if (SCM_IMP (obj)) scm_wrong_type_arg (0, 0, obj); @@ -583,7 +583,7 @@ gh_scm2newstr (SCM str, size_t *lenp) region to fit the string. If truncation occurs, the corresponding area of DST is left unchanged. */ void -gh_get_substr (SCM src, char *dst, scm_bits_t start, size_t len) +gh_get_substr (SCM src, char *dst, long start, size_t len) { size_t src_len, effective_length; SCM_ASSERT (SCM_STRINGP (src), src, SCM_ARG3, "gh_get_substr"); @@ -655,20 +655,20 @@ gh_vector_ref (SCM vec, SCM pos) } /* returns the length of the given vector */ -scm_bits_t +unsigned long gh_vector_length (SCM v) { - return (size_t) SCM_VECTOR_LENGTH (v); + return (unsigned long) SCM_VECTOR_LENGTH (v); } #ifdef HAVE_ARRAYS /* uniform vector support */ /* returns the length as a C unsigned long integer */ -scm_ubits_t +unsigned long gh_uniform_vector_length (SCM v) { - return SCM_UVECTOR_LENGTH (v); + return (unsigned long) SCM_UVECTOR_LENGTH (v); } /* gets the given element from a uniform vector; ilist is a list (or diff --git a/libguile/gh_list.c b/libguile/gh_list.c index c52af4223..71af25ee8 100644 --- a/libguile/gh_list.c +++ b/libguile/gh_list.c @@ -45,7 +45,7 @@ #include "libguile/gh.h" /* returns the length of a list */ -scm_bits_t +unsigned long gh_length (SCM l) { return gh_scm2ulong (scm_length (l)); diff --git a/libguile/goops.c b/libguile/goops.c index dc6d3a8f0..1fe133828 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -314,7 +314,7 @@ compute_getters_n_setters (SCM slots) { SCM res = SCM_EOL; SCM *cdrloc = &res; - scm_bits_t i = 0; + long i = 0; for ( ; SCM_NNULLP(slots); slots = SCM_CDR(slots)) { @@ -345,9 +345,9 @@ compute_getters_n_setters (SCM slots) /*fixme* Manufacture keywords in advance */ SCM -scm_i_get_keyword (SCM key, SCM l, scm_bits_t len, SCM default_value, const char *subr) +scm_i_get_keyword (SCM key, SCM l, long len, SCM default_value, const char *subr) { - scm_bits_t i; + long i; for (i = 0; i != len; i += 2) { @@ -375,7 +375,7 @@ SCM_DEFINE (scm_get_keyword, "get-keyword", 3, 0, 0, "@var{default_value} is returned.") #define FUNC_NAME s_scm_get_keyword { - scm_bits_t len; + long len; SCM_ASSERT (SCM_KEYWORDP (key), key, SCM_ARG1, FUNC_NAME); len = scm_ilength (l); @@ -400,7 +400,7 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0, { SCM tmp, get_n_set, slots; SCM class = SCM_CLASS_OF (obj); - scm_bits_t n_initargs; + long n_initargs; SCM_VALIDATE_INSTANCE (1, obj); n_initargs = scm_ilength (initargs); @@ -420,7 +420,7 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0, if (SCM_NIMP (SCM_CDR (slot_name))) { /* This slot admits (perhaps) to be initialized at creation time */ - scm_bits_t n = scm_ilength (SCM_CDR (slot_name)); + long n = scm_ilength (SCM_CDR (slot_name)); if (n & 1) /* odd or -1 */ SCM_MISC_ERROR ("class contains bogus slot definition: ~S", SCM_LIST1 (slot_name)); @@ -479,7 +479,7 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0, "") #define FUNC_NAME s_scm_sys_prep_layout_x { - scm_bits_t i, n, len; + long i, n, len; char *s, p, a; SCM nfields, slots, type; @@ -543,7 +543,7 @@ SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0, #define FUNC_NAME s_scm_sys_inherit_magic_x { SCM ls = dsupers; - scm_bits_t flags = 0; + long flags = 0; SCM_VALIDATE_INSTANCE (1, class); while (SCM_NNULLP (ls)) { @@ -560,7 +560,7 @@ SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0, SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity); else { - scm_bits_t n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); + long n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); #if 0 /* * We could avoid calling scm_must_malloc in the allocation code @@ -998,7 +998,7 @@ SCM_DEFINE (scm_sys_fast_slot_ref, "%fast-slot-ref", 2, 0, 0, "Return the slot value with index @var{index} from @var{obj}.") #define FUNC_NAME s_scm_sys_fast_slot_ref { - register scm_bits_t i; + register long i; SCM_VALIDATE_INSTANCE (1, obj); SCM_VALIDATE_INUM (2, index); @@ -1015,7 +1015,7 @@ SCM_DEFINE (scm_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0, "@var{value}.") #define FUNC_NAME s_scm_sys_fast_slot_set_x { - register scm_bits_t i; + register long i; SCM_VALIDATE_INSTANCE (1, obj); SCM_VALIDATE_INUM (2, index); @@ -1279,10 +1279,10 @@ SCM_DEFINE (scm_slots_exists_p, "slot-exists?", 2, 0, 0, static void clear_method_cache (SCM); static SCM -wrap_init (SCM class, SCM *m, scm_bits_t n) +wrap_init (SCM class, SCM *m, long n) { SCM z; - scm_bits_t i; + long i; /* Set all slots to unbound */ for (i = 0; i < n; i++) @@ -1303,7 +1303,7 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0, #define FUNC_NAME s_scm_sys_allocate_instance { SCM *m; - scm_bits_t n; + long n; SCM_VALIDATE_CLASS (1, class); @@ -1343,7 +1343,7 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0, /* Class objects */ if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS) { - scm_bits_t i; + long i; /* allocate class object */ SCM z = scm_make_struct (class, SCM_INUM0, SCM_EOL); @@ -1463,16 +1463,16 @@ SCM_DEFINE (scm_sys_invalidate_class, "%invalidate-class", 1, 0, 0, */ static SCM **hell; -static scm_bits_t n_hell = 1; /* one place for the evil one himself */ -static scm_bits_t hell_size = 4; +static long n_hell = 1; /* one place for the evil one himself */ +static long hell_size = 4; #ifdef USE_THREADS static scm_mutex_t hell_mutex; #endif -static scm_bits_t +static long burnin (SCM o) { - scm_bits_t i; + long i; for (i = 1; i < n_hell; ++i) if (SCM_INST (o) == hell[i]) return i; @@ -1488,7 +1488,7 @@ go_to_hell (void *o) #endif if (n_hell == hell_size) { - scm_bits_t new_size = 2 * hell_size; + long new_size = 2 * hell_size; hell = scm_must_realloc (hell, hell_size, new_size, "hell"); hell_size = new_size; } @@ -1668,7 +1668,7 @@ static int more_specificp (SCM m1, SCM m2, SCM *targs) { register SCM s1, s2; - register scm_bits_t i; + register long i; /* * Note: * m1 and m2 can have != length (i.e. one can be one element longer than the @@ -1706,9 +1706,9 @@ more_specificp (SCM m1, SCM m2, SCM *targs) #define BUFFSIZE 32 /* big enough for most uses */ static SCM -scm_i_vector2list (SCM l, scm_bits_t len) +scm_i_vector2list (SCM l, long len) { - size_t j; + long j; SCM z = scm_c_make_vector (len, SCM_UNDEFINED); for (j = 0; j < len; j++, l = SCM_CDR (l)) { @@ -1718,9 +1718,9 @@ scm_i_vector2list (SCM l, scm_bits_t len) } static SCM -sort_applicable_methods (SCM method_list, scm_bits_t size, SCM *targs) +sort_applicable_methods (SCM method_list, long size, SCM *targs) { - scm_bits_t i, j, incr; + long i, j, incr; SCM *v, vector = SCM_EOL; SCM buffer[BUFFSIZE]; SCM save = method_list; @@ -1782,10 +1782,10 @@ sort_applicable_methods (SCM method_list, scm_bits_t size, SCM *targs) } SCM -scm_compute_applicable_methods (SCM gf, SCM args, scm_bits_t len, int find_method_p) +scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p) { - register scm_bits_t i; - scm_bits_t count = 0; + register long i; + long count = 0; SCM l, fl, applicable = SCM_EOL; SCM save = args; SCM buffer[BUFFSIZE], *types, *p; @@ -1853,7 +1853,7 @@ SCM scm_sys_compute_applicable_methods (SCM gf, SCM args) #define FUNC_NAME s_sys_compute_applicable_methods { - scm_bits_t n; + long n; SCM_VALIDATE_GENERIC (1, gf); n = scm_ilength (args); SCM_ASSERT (n >= 0, args, SCM_ARG2, FUNC_NAME); @@ -1991,7 +1991,7 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1, #define FUNC_NAME s_scm_make { SCM class, z; - scm_bits_t len = scm_ilength (args); + long len = scm_ilength (args); if (len <= 0 || (len & 1) == 0) SCM_WRONG_NUM_ARGS (); @@ -2084,7 +2084,7 @@ SCM_DEFINE (scm_find_method, "find-method", 0, 0, 1, #define FUNC_NAME s_scm_find_method { SCM gf; - scm_bits_t len = scm_ilength (l); + long len = scm_ilength (l); if (len == 0) SCM_WRONG_NUM_ARGS (); @@ -2104,7 +2104,7 @@ SCM_DEFINE (scm_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0, #define FUNC_NAME s_scm_sys_method_more_specific_p { SCM l, v; - scm_bits_t i, len; + long i, len; SCM_VALIDATE_METHOD (1, m1); SCM_VALIDATE_METHOD (2, m2); @@ -2357,7 +2357,7 @@ scm_make_extended_class (char *type_name) static void create_smob_classes (void) { - scm_bits_t i; + long i; scm_smob_class = (SCM *) malloc (255 * sizeof (SCM)); for (i = 0; i < 255; ++i) @@ -2374,7 +2374,7 @@ create_smob_classes (void) } void -scm_make_port_classes (scm_bits_t ptobnum, char *type_name) +scm_make_port_classes (long ptobnum, char *type_name) { SCM c, class = make_class_from_template ("<%s-port>", type_name, @@ -2401,7 +2401,7 @@ scm_make_port_classes (scm_bits_t ptobnum, char *type_name) static void create_port_classes (void) { - scm_bits_t i; + long i; scm_port_class = (SCM *) malloc (3 * 256 * sizeof (SCM)); for (i = 0; i < 3 * 256; ++i) @@ -2551,7 +2551,7 @@ scm_add_slot (SCM class, char *slot_name, SCM slot_class, } } { - scm_bits_t n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); + long n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); SCM_SLOT (class, scm_si_nfields) = SCM_MAKINUM (n + 1); diff --git a/libguile/goops.h b/libguile/goops.h index 60b331cbb..481ff0067 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -229,7 +229,7 @@ SCM scm_sys_set_object_setter_x (SCM obj, SCM setter); SCM scm_slot_ref (SCM obj, SCM slot_name); SCM scm_slot_set_x (SCM obj, SCM slot_name, SCM value); -SCM scm_compute_applicable_methods (SCM gf, SCM args, scm_bits_t len, int scm_find_method); +SCM scm_compute_applicable_methods (SCM gf, SCM args, long len, int scm_find_method); SCM scm_sys_compute_applicable_methods (SCM gf, SCM args); SCM scm_m_atslot_ref (SCM xorig, SCM env); SCM scm_m_atslot_set_x (SCM xorig, SCM env); @@ -239,7 +239,7 @@ SCM scm_pure_generic_p (SCM obj); #endif SCM scm_sys_compute_slots (SCM c); -SCM scm_i_get_keyword (SCM key, SCM l, scm_bits_t len, SCM default_value, const char *subr); +SCM scm_i_get_keyword (SCM key, SCM l, long len, SCM default_value, const char *subr); SCM scm_get_keyword (SCM key, SCM l, SCM default_value); SCM scm_sys_initialize_object (SCM obj, SCM initargs); SCM scm_sys_prep_layout_x (SCM c); diff --git a/libguile/gsubr.c b/libguile/gsubr.c index 090b1e928..ebb09f3b1 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -214,8 +214,8 @@ scm_gsubr_apply (SCM args) SCM self = SCM_CAR (args); SCM (*fcn)() = SCM_SUBRF (SCM_GSUBR_PROC (self)); SCM v[SCM_GSUBR_MAX]; - scm_bits_t typ = SCM_INUM (SCM_GSUBR_TYPE (self)); - scm_bits_t i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ); + long typ = SCM_INUM (SCM_GSUBR_TYPE (self)); + long i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ); #if 0 if (n > SCM_GSUBR_MAX) scm_misc_error (FUNC_NAME, diff --git a/libguile/gsubr.h b/libguile/gsubr.h index fbf546203..131854c4f 100644 --- a/libguile/gsubr.h +++ b/libguile/gsubr.h @@ -49,9 +49,9 @@ #define SCM_GSUBR_MAKTYPE(req, opt, rst) ((req)|((opt)<<4)|((rst)<<8)) -#define SCM_GSUBR_REQ(x) ((scm_bits_t)(x)&0xf) -#define SCM_GSUBR_OPT(x) (((scm_bits_t)(x)&0xf0)>>4) -#define SCM_GSUBR_REST(x) ((scm_bits_t)(x)>>8) +#define SCM_GSUBR_REQ(x) ((long)(x)&0xf) +#define SCM_GSUBR_OPT(x) (((long)(x)&0xf0)>>4) +#define SCM_GSUBR_REST(x) ((long)(x)>>8) #define SCM_GSUBR_MAX 10 #define SCM_GSUBR_TYPE(cclo) (SCM_CCLO_REF ((cclo), 1)) diff --git a/libguile/hash.c b/libguile/hash.c index 5a7244569..ae09a3862 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -60,13 +60,13 @@ extern double floor(); #endif -scm_bits_t +unsigned long scm_string_hash (const unsigned char *str, size_t len) { if (len > 5) { size_t i = 5; - scm_bits_t h = 264; + unsigned long h = 264; while (i--) h = (h << 8) + (unsigned) str[h % len]; return h; @@ -74,7 +74,7 @@ scm_string_hash (const unsigned char *str, size_t len) else { size_t i = len; - scm_bits_t h = 0; + unsigned long h = 0; while (i) h = (h << 8) + (unsigned) str[--i]; return h; @@ -86,8 +86,8 @@ scm_string_hash (const unsigned char *str, size_t len) /* Dirk:FIXME:: scm_hasher could be made static. */ -scm_bits_t -scm_hasher (SCM obj, scm_bits_t n, size_t d) +unsigned long +scm_hasher(SCM obj, unsigned long n, size_t d) { switch (SCM_ITAG3 (obj)) { case scm_tc3_int_1: @@ -95,7 +95,7 @@ scm_hasher (SCM obj, scm_bits_t n, size_t d) return SCM_INUM(obj) % n; /* SCM_INUMP(obj) */ case scm_tc3_imm24: if (SCM_CHARP(obj)) - return (scm_ubits_t) (scm_downcase(SCM_CHAR(obj))) % n; + return (unsigned)(scm_downcase(SCM_CHAR(obj))) % n; switch (SCM_UNPACK (obj)) { #ifndef SICP case SCM_EOL: @@ -152,14 +152,14 @@ scm_hasher (SCM obj, scm_bits_t n, size_t d) if (len > 5) { size_t i = d/2; - scm_bits_t h = 1; + unsigned long h = 1; while (i--) h = ((h << 8) + (scm_hasher (data[h % len], n, 2))) % n; return h; } else { size_t i = len; - scm_bits_t h = (n)-1; + unsigned long h = (n)-1; while (i--) h = ((h << 8) + (scm_hasher (data[i], n, d/len))) % n; return h; } @@ -182,8 +182,8 @@ scm_hasher (SCM obj, scm_bits_t n, size_t d) -scm_bits_t -scm_ihashq (SCM obj, scm_bits_t n) +unsigned long +scm_ihashq (SCM obj, unsigned long n) { return (SCM_UNPACK (obj) >> 1) % n; } @@ -212,14 +212,14 @@ SCM_DEFINE (scm_hashq, "hashq", 2, 0, 0, -scm_bits_t -scm_ihashv (SCM obj, scm_bits_t n) +unsigned long +scm_ihashv (SCM obj, unsigned long n) { if (SCM_CHARP(obj)) - return ((scm_ubits_t)(scm_downcase(SCM_CHAR(obj)))) % n; /* downcase!?!! */ + return ((unsigned long) (scm_downcase (SCM_CHAR (obj)))) % n; /* downcase!?!! */ if (SCM_NUMP(obj)) - return (scm_bits_t) scm_hasher(obj, n, 10); + return (unsigned long) scm_hasher(obj, n, 10); else return SCM_UNPACK (obj) % n; } @@ -248,10 +248,10 @@ SCM_DEFINE (scm_hashv, "hashv", 2, 0, 0, -scm_bits_t -scm_ihash (SCM obj, scm_bits_t n) +unsigned long +scm_ihash (SCM obj, unsigned long n) { - return (scm_bits_t) scm_hasher (obj, n, 10); + return (unsigned long) scm_hasher (obj, n, 10); } SCM_DEFINE (scm_hash, "hash", 2, 0, 0, diff --git a/libguile/hash.h b/libguile/hash.h index 95bd8581f..5b2d5bb80 100644 --- a/libguile/hash.h +++ b/libguile/hash.h @@ -48,13 +48,13 @@ -extern scm_bits_t scm_string_hash (const unsigned char *str, size_t len); -extern scm_bits_t scm_hasher (SCM obj, scm_bits_t n, size_t d); -extern scm_bits_t scm_ihashq (SCM obj, scm_bits_t n); +extern unsigned long scm_string_hash (const unsigned char *str, size_t len); +extern unsigned long scm_hasher (SCM obj, unsigned long n, size_t d); +extern unsigned long scm_ihashq (SCM obj, unsigned long n); extern SCM scm_hashq (SCM obj, SCM n); -extern scm_bits_t scm_ihashv (SCM obj, scm_bits_t n); +extern unsigned long scm_ihashv (SCM obj, unsigned long n); extern SCM scm_hashv (SCM obj, SCM n); -extern scm_bits_t scm_ihash (SCM obj, scm_bits_t n); +extern unsigned long scm_ihash (SCM obj, unsigned long n); extern SCM scm_hash (SCM obj, SCM n); extern void scm_init_hash (void); diff --git a/libguile/hashtab.c b/libguile/hashtab.c index ef91c7aca..d9f629240 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -55,20 +55,17 @@ SCM -scm_c_make_hash_table (scm_bits_t k) +scm_c_make_hash_table (unsigned long k) { return scm_c_make_vector (k, SCM_EOL); } SCM -scm_hash_fn_get_handle (SCM table, SCM obj, - scm_bits_t (*hash_fn) (), - SCM (*assoc_fn) (), - void *closure) +scm_hash_fn_get_handle (SCM table,SCM obj,unsigned long (*hash_fn)(),SCM (*assoc_fn)(),void * closure) #define FUNC_NAME "scm_hash_fn_get_handle" { - scm_bits_t k; + unsigned long k; SCM h; SCM_VALIDATE_VECTOR (1, table); @@ -84,13 +81,11 @@ scm_hash_fn_get_handle (SCM table, SCM obj, SCM -scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, - scm_bits_t (*hash_fn) (), - SCM (*assoc_fn) (), - void *closure) +scm_hash_fn_create_handle_x (SCM table,SCM obj,SCM init,unsigned long (*hash_fn)(), + SCM (*assoc_fn)(),void * closure) #define FUNC_NAME "scm_hash_fn_create_handle_x" { - scm_bits_t k; + unsigned long k; SCM it; SCM_ASSERT (SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_create_handle_x"); @@ -121,10 +116,8 @@ scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, SCM -scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, - scm_bits_t (*hash_fn) (), - SCM (*assoc_fn) (), - void *closure) +scm_hash_fn_ref (SCM table,SCM obj,SCM dflt,unsigned long (*hash_fn)(), + SCM (*assoc_fn)(),void * closure) { SCM it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure); if (SCM_CONSP (it)) @@ -137,10 +130,8 @@ scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, SCM -scm_hash_fn_set_x (SCM table, SCM obj, SCM val, - scm_bits_t (*hash_fn) (), - SCM (*assoc_fn) (), - void * closure) +scm_hash_fn_set_x (SCM table,SCM obj,SCM val,unsigned long (*hash_fn)(), + SCM (*assoc_fn)(),void * closure) { SCM it; @@ -154,13 +145,10 @@ scm_hash_fn_set_x (SCM table, SCM obj, SCM val, SCM -scm_hash_fn_remove_x (SCM table, SCM obj, - scm_bits_t (*hash_fn) (), - SCM (*assoc_fn) (), - SCM (*delete_fn) (), - void *closure) +scm_hash_fn_remove_x (SCM table,SCM obj,unsigned long (*hash_fn)(),SCM (*assoc_fn)(), + SCM (*delete_fn)(),void * closure) { - scm_bits_t k; + unsigned long k; SCM h; SCM_ASSERT (SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_remove_x"); @@ -387,13 +375,13 @@ typedef struct scm_ihashx_closure_t -static scm_bits_t -scm_ihashx (SCM obj, scm_bits_t n, scm_ihashx_closure_t *closure) +static unsigned long +scm_ihashx (SCM obj, unsigned long n, scm_ihashx_closure_t *closure) { SCM answer; SCM_DEFER_INTS; answer = scm_apply (closure->hash, - SCM_LIST2 (obj, scm_bits2num (n)), + SCM_LIST2 (obj, scm_ulong2num ((unsigned long)n)), SCM_EOL); SCM_ALLOW_INTS; return SCM_INUM (answer); @@ -555,7 +543,7 @@ SCM_DEFINE (scm_hash_fold, "hash-fold", 3, 0, 0, SCM scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table) { - scm_bits_t i, n = SCM_VECTOR_LENGTH (table); + long i, n = SCM_VECTOR_LENGTH (table); SCM result = init; for (i = 0; i < n; ++i) { diff --git a/libguile/hashtab.h b/libguile/hashtab.h index 1bd2a1483..64a932c61 100644 --- a/libguile/hashtab.h +++ b/libguile/hashtab.h @@ -53,13 +53,13 @@ typedef SCM scm_assoc_fn_t (SCM key, SCM alist, void *closure); typedef SCM scm_delete_fn_t (SCM elt, SCM list); #endif -extern SCM scm_c_make_hash_table (scm_bits_t k); +extern SCM scm_c_make_hash_table (unsigned long k); -extern SCM scm_hash_fn_get_handle (SCM table, SCM obj, scm_bits_t (*hash_fn) (), SCM (*assoc_fn) (), void * closure); -extern SCM scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, scm_bits_t (*hash_fn) (), SCM (*assoc_fn) (), void * closure); -extern SCM scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, scm_bits_t (*hash_fn) (), SCM (*assoc_fn) (), void * closure); -extern SCM scm_hash_fn_set_x (SCM table, SCM obj, SCM val, scm_bits_t (*hash_fn) (), SCM (*assoc_fn) (), void * closure); -extern SCM scm_hash_fn_remove_x (SCM table, SCM obj, scm_bits_t (*hash_fn) (), SCM (*assoc_fn) (), SCM (*delete_fn) (), void * closure); +extern SCM scm_hash_fn_get_handle (SCM table, SCM obj, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure); +extern SCM scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure); +extern SCM scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure); +extern SCM scm_hash_fn_set_x (SCM table, SCM obj, SCM val, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure); +extern SCM scm_hash_fn_remove_x (SCM table, SCM obj, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), SCM (*delete_fn) (), void * closure); extern SCM scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table); extern SCM scm_hashq_get_handle (SCM table, SCM obj); diff --git a/libguile/ioext.c b/libguile/ioext.c index c142d2981..ca51321d8 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -297,7 +297,7 @@ SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0, { SCM result = SCM_EOL; int int_fd; - scm_bits_t i; + long i; SCM_VALIDATE_INUM_COPY (1,fd,int_fd); diff --git a/libguile/list.c b/libguile/list.c index 6bc0371be..043444aa3 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -148,10 +148,10 @@ SCM_DEFINE (scm_list_p, "list?", 1, 0, 0, This uses the "tortoise and hare" algorithm to detect "infinitely long" lists (i.e. lists with cycles in their cdrs), and returns -1 if it does find one. */ -scm_bits_t -scm_ilength (SCM sx) +long +scm_ilength(SCM sx) { - scm_bits_t i = 0; + long i = 0; SCM tortoise = sx; SCM hare = sx; @@ -180,7 +180,7 @@ SCM_DEFINE (scm_length, "length", 1, 0, 0, "Return the number of elements in list @var{lst}.") #define FUNC_NAME s_scm_length { - scm_bits_t i; + long i; SCM_VALIDATE_LIST_COPYLEN (1,lst,i); return SCM_MAKINUM (i); } @@ -360,7 +360,7 @@ SCM_DEFINE (scm_list_ref, "list-ref", 2, 0, 0, #define FUNC_NAME s_scm_list_ref { SCM lst = list; - register scm_bits_t i; + unsigned long int i; SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i); while (SCM_CONSP (lst)) { if (i == 0) @@ -384,7 +384,7 @@ SCM_DEFINE (scm_list_set_x, "list-set!", 3, 0, 0, #define FUNC_NAME s_scm_list_set_x { SCM lst = list; - register scm_bits_t i; + unsigned long int i; SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i); while (SCM_CONSP (lst)) { if (i == 0) { @@ -415,7 +415,7 @@ SCM_DEFINE (scm_list_tail, "list-tail", 2, 0, 0, "or returning the results of cdring @var{k} times down @var{lst}.") #define FUNC_NAME s_scm_list_tail { - register scm_bits_t i; + register long i; SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i); while (i-- > 0) { SCM_VALIDATE_CONS (1,lst); @@ -432,7 +432,7 @@ SCM_DEFINE (scm_list_cdr_set_x, "list-cdr-set!", 3, 0, 0, #define FUNC_NAME s_scm_list_cdr_set_x { SCM lst = list; - scm_bits_t i; + unsigned long int i; SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i); while (SCM_CONSP (lst)) { if (i == 0) { @@ -462,7 +462,7 @@ SCM_DEFINE (scm_list_head, "list-head", 2, 0, 0, { SCM answer; SCM * pos; - register scm_bits_t i; + register long i; SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i); answer = SCM_EOL; diff --git a/libguile/list.h b/libguile/list.h index 70a2eca3a..4493816ee 100644 --- a/libguile/list.h +++ b/libguile/list.h @@ -72,7 +72,7 @@ extern SCM scm_list (SCM objs); extern SCM scm_cons_star (SCM arg, SCM objs); extern SCM scm_null_p (SCM x); extern SCM scm_list_p (SCM x); -extern scm_bits_t scm_ilength (SCM sx); +extern long scm_ilength (SCM sx); extern SCM scm_length (SCM x); extern SCM scm_append (SCM args); extern SCM scm_append_x (SCM args); diff --git a/libguile/load.c b/libguile/load.c index b17224600..73eb2b9ab 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -495,7 +495,7 @@ init_build_info () { static struct { char *name; char *value; } info[] = SCM_BUILD_INFO; SCM *loc = SCM_VARIABLE_LOC (scm_c_define ("%guile-build-info", SCM_EOL)); - scm_bits_t i; + unsigned long i; for (i = 0; i < (sizeof (info) / sizeof (info[0])); i++) *loc = scm_acons (scm_str2symbol (info[i].name), diff --git a/libguile/modules.c b/libguile/modules.c index 439925755..5bf40ac89 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -529,7 +529,7 @@ scm_module_reverse_lookup (SCM module, SCM variable) #define FUNC_NAME "module-reverse-lookup" { SCM obarray; - scm_bits_t i, n; + long i, n; if (module == SCM_BOOL_F) obarray = scm_pre_modules_obarray; diff --git a/libguile/numbers.c b/libguile/numbers.c index 261248b62..8f08a74a3 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -4253,22 +4253,6 @@ scm_i_big2dbl (SCM b) #define MAX_VALUE ULONG_MAX #include "libguile/num2integral.i.c" -#define NUM2INTEGRAL scm_num2bits -#define INTEGRAL2NUM scm_bits2num -#define INTEGRAL2BIG scm_i_bits2big -#define ITYPE scm_bits_t -#define MIN_VALUE ((scm_bits_t) ((scm_ubits_t)1 << (sizeof (scm_bits_t) - 1))) -#define MAX_VALUE (~MIN_VALUE) -#include "libguile/num2integral.i.c" - -#define NUM2INTEGRAL scm_num2ubits -#define INTEGRAL2NUM scm_ubits2num -#define INTEGRAL2BIG scm_i_ubits2big -#define UNSIGNED -#define ITYPE scm_ubits_t -#define MAX_VALUE ((scm_ubits_t) ((scm_bits_t) (-1))) -#include "libguile/num2integral.i.c" - #define NUM2INTEGRAL scm_num2ptrdiff #define INTEGRAL2NUM scm_ptrdiff2num #define INTEGRAL2BIG scm_i_ptrdiff2big diff --git a/libguile/numbers.h b/libguile/numbers.h index 09dc4bdbe..e6ec6e10c 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -62,7 +62,7 @@ * SCM_INUMP (SCM_CAR (x)) can give wrong answers. */ -#define SCM_I_FIXNUM_BIT (SCM_BITS_LENGTH - 2) +#define SCM_I_FIXNUM_BIT (SCM_LONG_BIT - 2) #define SCM_MOST_POSITIVE_FIXNUM ((1L << (SCM_I_FIXNUM_BIT - 1)) - 1) #define SCM_MOST_NEGATIVE_FIXNUM (-SCM_MOST_POSITIVE_FIXNUM - 1) @@ -115,7 +115,7 @@ /* SCM_INTBUFLEN is the maximum number of characters neccessary for the * printed or scm_string representation of an exact immediate. */ -#define SCM_INTBUFLEN (5 + SCM_BITS_LENGTH) +#define SCM_INTBUFLEN (5 + SCM_LONG_BIT) @@ -177,7 +177,7 @@ #define SCM_BIGSIGN(x) (SCM_CELL_WORD_0 (x) & SCM_BIGSIGNFLAG) #define SCM_BDIGITS(x) ((SCM_BIGDIG *) (SCM_CELL_WORD_1 (x))) #define SCM_SET_BIGNUM_BASE(n, b) (SCM_SET_CELL_WORD_1 ((n), (b))) -#define SCM_NUMDIGS(x) ((size_t) ((scm_ubits_t) SCM_CELL_WORD_0 (x) >> SCM_BIGSIZEFIELD)) +#define SCM_NUMDIGS(x) ((size_t) (SCM_CELL_WORD_0 (x) >> SCM_BIGSIZEFIELD)) #define SCM_SETNUMDIGS(x, v, sign) \ SCM_SET_CELL_WORD_0 (x, \ scm_tc16_big \ @@ -232,8 +232,6 @@ extern SCM scm_i_int2big (int n); extern SCM scm_i_uint2big (unsigned int n); extern SCM scm_i_long2big (long n); extern SCM scm_i_ulong2big (unsigned long n); -extern SCM scm_i_bits2big (scm_bits_t n); -extern SCM scm_i_ubits2big (scm_ubits_t n); extern SCM scm_i_size2big (size_t n); extern SCM scm_i_ptrdiff2big (ptrdiff_t n); @@ -330,8 +328,6 @@ extern SCM scm_int2num (int n); extern SCM scm_uint2num (unsigned int n); extern SCM scm_long2num (long n); extern SCM scm_ulong2num (unsigned long n); -extern SCM scm_bits2num (scm_bits_t n); -extern SCM scm_ubits2num (scm_ubits_t n); extern SCM scm_size2num (size_t n); extern SCM scm_ptrdiff2num (ptrdiff_t n); extern short scm_num2short (SCM num, unsigned long int pos, @@ -346,10 +342,6 @@ extern long scm_num2long (SCM num, unsigned long int pos, const char *s_caller); extern unsigned long scm_num2ulong (SCM num, unsigned long int pos, const char *s_caller); -extern scm_bits_t scm_num2bits (SCM num, unsigned long int pos, - const char *s_caller); -extern scm_ubits_t scm_num2ubits (SCM num, unsigned long int pos, - const char *s_caller); extern ptrdiff_t scm_num2ptrdiff (SCM num, unsigned long int pos, const char *s_caller); extern size_t scm_num2size (SCM num, unsigned long int pos, diff --git a/libguile/objects.c b/libguile/objects.c index 042549ca6..4cec90ba2 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -158,7 +158,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, case scm_tc7_smob: { - scm_bits_t type = SCM_TYP16 (x); + long type = SCM_TYP16 (x); if (type != scm_tc16_port_with_ps) return scm_smob_class[SCM_TC2SMOBNUM (type)]; x = SCM_PORT_WITH_PS_PORT (x); @@ -251,7 +251,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, SCM scm_mcache_lookup_cmethod (SCM cache, SCM args) { - scm_bits_t i, n, end, mask; + long i, n, end, mask; SCM ls, methods, z = SCM_CDDR (cache); n = SCM_INUM (SCM_CAR (z)); /* maximum number of specializers */ methods = SCM_CADR (z); @@ -266,8 +266,8 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args) else { /* Compute a hash value */ - scm_bits_t hashset = SCM_INUM (methods); - scm_bits_t j = n; + long hashset = SCM_INUM (methods); + long j = n; mask = SCM_INUM (SCM_CAR (z = SCM_CDDR (z))); methods = SCM_CADR (z); i = 0; @@ -287,7 +287,7 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args) /* Search for match */ do { - scm_bits_t j = n; + long j = n; z = SCM_VELTS (methods)[i]; ls = args; /* list of arguments */ if (SCM_NIMP (ls)) @@ -449,7 +449,7 @@ SCM_DEFINE (scm_object_procedure, "object-procedure", 1, 0, 0, SCM scm_i_make_class_object (SCM meta, SCM layout_string, - scm_ubits_t flags) + unsigned long flags) { SCM c; SCM layout = scm_make_struct_layout (layout_string); @@ -466,7 +466,7 @@ SCM_DEFINE (scm_make_class_object, "make-class-object", 2, 0, 0, "slot layout specified by @var{layout}.") #define FUNC_NAME s_scm_make_class_object { - scm_ubits_t flags = 0; + unsigned long flags = 0; SCM_VALIDATE_STRUCT (1,metaclass); SCM_VALIDATE_STRING (2,layout); if (SCM_EQ_P (metaclass, scm_metaclass_operator)) diff --git a/libguile/objects.h b/libguile/objects.h index 5e3d27f30..3f9b5e9a8 100644 --- a/libguile/objects.h +++ b/libguile/objects.h @@ -214,7 +214,7 @@ extern SCM scm_no_applicable_method; /* Goops functions. */ extern SCM scm_make_extended_class (char *type_name); -extern void scm_make_port_classes (scm_bits_t ptobnum, char *type_name); +extern void scm_make_port_classes (long ptobnum, char *type_name); extern void scm_change_object_class (SCM, SCM, SCM); extern SCM scm_memoize_method (SCM x, SCM args); @@ -239,7 +239,7 @@ extern SCM scm_make_class_object (SCM metaclass, SCM layout); extern SCM scm_make_subclass_object (SCM c, SCM layout); extern SCM scm_i_make_class_object (SCM metaclass, SCM layout_string, - scm_ubits_t flags); + unsigned long flags); extern void scm_init_objects (void); #endif /* OBJECTSH */ diff --git a/libguile/options.h b/libguile/options.h index 7450b7309..5ff2c4fa3 100644 --- a/libguile/options.h +++ b/libguile/options.h @@ -59,7 +59,7 @@ typedef struct scm_option_t /* schizophrenic use: both SCM and int */ - scm_bits_t val; + unsigned long val; /* SCM val */ char *doc; } scm_option_t; diff --git a/libguile/ports.c b/libguile/ports.c index f49a72dfa..9bc8168bd 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -87,7 +87,7 @@ * tags for smobjects (if you know a tag you can get an index and conversely). */ scm_ptob_descriptor_t *scm_ptobs; -scm_bits_t scm_numptob; +long scm_numptob; /* GC marker for a port with stream of SCM type. */ SCM @@ -314,7 +314,7 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, { SCM result; scm_port_t *pt = SCM_PTAB_ENTRY (port); - scm_bits_t count; + long count; SCM_VALIDATE_OPINPORT (1,port); @@ -424,8 +424,8 @@ SCM_DEFINE (scm_set_current_error_port, "set-current-error-port", 1, 0, 0, scm_port_t **scm_port_table; -scm_bits_t scm_port_table_size = 0; /* Number of ports in scm_port_table. */ -scm_bits_t scm_port_table_room = 20; /* Size of the array. */ +long scm_port_table_size = 0; /* Number of ports in scm_port_table. */ +long scm_port_table_room = 20; /* Size of the array. */ /* Add a port to the table. */ @@ -475,7 +475,7 @@ scm_remove_from_port_table (SCM port) #define FUNC_NAME "scm_remove_from_port_table" { scm_port_t *p = SCM_PTAB_ENTRY (port); - scm_bits_t i = p->entry; + long i = p->entry; if (i >= scm_port_table_size) SCM_MISC_ERROR ("Port not in table: ~S", SCM_LIST1 (port)); @@ -515,7 +515,7 @@ SCM_DEFINE (scm_pt_member, "pt-member", 1, 0, 0, "@code{--enable-guile-debug} builds.") #define FUNC_NAME s_scm_pt_member { - scm_bits_t i; + long i; SCM_VALIDATE_INUM_COPY (1,index,i); if (i < 0 || i >= scm_port_table_size) return SCM_BOOL_F; @@ -709,7 +709,7 @@ SCM_DEFINE (scm_port_for_each, "port-for-each", 1, 0, 0, "have no effect as far as @var{port-for-each} is concerned.\n") #define FUNC_NAME s_scm_port_for_each { - scm_bits_t i; + long i; SCM ports; SCM_VALIDATE_PROC (1, proc); @@ -752,7 +752,7 @@ SCM_DEFINE (scm_close_all_ports_except, "close-all-ports-except", 0, 0, 1, "Use port-for-each instead.") #define FUNC_NAME s_scm_close_all_ports_except { - scm_bits_t i = 0; + long i = 0; SCM_VALIDATE_REST_ARGUMENT (ports); while (i < scm_port_table_size) { @@ -1075,14 +1075,14 @@ scm_c_write (SCM port, const void *ptr, size_t size) void scm_flush (SCM port) { - scm_bits_t i = SCM_PTOBNUM (port); + long i = SCM_PTOBNUM (port); (scm_ptobs[i].flush) (port); } void scm_end_input (SCM port) { - scm_bits_t offset; + long offset; scm_port_t *pt = SCM_PTAB_ENTRY (port); if (pt->read_buf == pt->putback_buf) diff --git a/libguile/ports.h b/libguile/ports.h index fa9198415..1ebbd7ce7 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -70,7 +70,7 @@ typedef enum scm_port_rw_active_t { typedef struct { SCM port; /* Link back to the port object. */ - scm_bits_t entry; /* Index in port table. */ + long entry; /* Index in port table. */ int revealed; /* 0 not revealed, > 1 revealed. * Revealed ports do not get GC'd. */ @@ -133,7 +133,7 @@ typedef struct } scm_port_t; extern scm_port_t **scm_port_table; -extern scm_bits_t scm_port_table_size; /* Number of ports in scm_port_table. */ +extern long scm_port_table_size; /* Number of ports in scm_port_table. */ #define SCM_READ_BUFFER_EMPTY_P(c_port) (c_port->read_pos >= c_port->read_end) @@ -220,8 +220,8 @@ typedef struct scm_ptob_descriptor_t extern scm_ptob_descriptor_t *scm_ptobs; -extern scm_bits_t scm_numptob; -extern scm_bits_t scm_port_table_room; +extern long scm_numptob; +extern long scm_port_table_room; diff --git a/libguile/print.c b/libguile/print.c index 7e08fe49a..0ca427f29 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -282,8 +282,8 @@ grow_ref_stack (scm_print_state *pstate) static void print_circref (SCM port,scm_print_state *pstate,SCM ref) { - register scm_bits_t i; - scm_bits_t self = pstate->top - 1; + register long i; + long self = pstate->top - 1; i = pstate->top - 1; if (SCM_CONSP (pstate->ref_stack[i])) { @@ -548,8 +548,8 @@ taloop: scm_puts ("#(", port); common_vector_printer: { - register scm_bits_t i; - scm_bits_t last = SCM_VECTOR_LENGTH (exp) - 1; + register long i; + long last = SCM_VECTOR_LENGTH (exp) - 1; int cutp = 0; if (pstate->fancyp && SCM_VECTOR_LENGTH (exp) > pstate->length) { @@ -749,7 +749,7 @@ void scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate) { register SCM hare, tortoise; - scm_bits_t floor = pstate->top - 2; + long floor = pstate->top - 2; scm_puts (hdr, port); /* CHECK_INTS; */ if (pstate->fancyp) @@ -774,7 +774,7 @@ scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate) scm_iprin1 (SCM_CAR (exp), port, pstate); for (exp = SCM_CDR (exp); SCM_ECONSP (exp); exp = SCM_CDR (exp)) { - register scm_bits_t i; + register long i; for (i = floor; i >= 0; --i) if (SCM_EQ_P (pstate->ref_stack[i], exp)) @@ -797,13 +797,13 @@ end: fancy_printing: { - scm_bits_t n = pstate->length; + long n = pstate->length; scm_iprin1 (SCM_CAR (exp), port, pstate); exp = SCM_CDR (exp); --n; for (; SCM_ECONSP (exp); exp = SCM_CDR (exp)) { - register scm_ubits_t i; + register unsigned long i; for (i = 0; i < pstate->top; ++i) if (SCM_EQ_P (pstate->ref_stack[i], exp)) diff --git a/libguile/procs.c b/libguile/procs.c index 85e9abd08..74f751e6c 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -67,18 +67,18 @@ scm_subr_entry_t *scm_subr_table; /* Increased to 800 on 2001-05-07 -- Guile now has 779 primitives on startup, 786 with guile-readline. 'martin */ -scm_bits_t scm_subr_table_size = 0; -scm_bits_t scm_subr_table_room = 800; +long scm_subr_table_size = 0; +long scm_subr_table_room = 800; SCM -scm_c_make_subr (const char *name, scm_bits_t type, SCM (*fcn) ()) +scm_c_make_subr (const char *name, long type, SCM (*fcn) ()) { register SCM z; - scm_bits_t entry; + long entry; if (scm_subr_table_size == scm_subr_table_room) { - scm_bits_t new_size = scm_subr_table_room * 3 / 2; + long new_size = scm_subr_table_room * 3 / 2; void *new_table = scm_must_realloc ((char *) scm_subr_table, sizeof (scm_subr_entry_t) * scm_subr_table_room, @@ -104,7 +104,7 @@ scm_c_make_subr (const char *name, scm_bits_t type, SCM (*fcn) ()) } SCM -scm_c_define_subr (const char *name, scm_bits_t type, SCM (*fcn) ()) +scm_c_define_subr (const char *name, long type, SCM (*fcn) ()) { SCM subr = scm_c_make_subr (name, type, fcn); scm_define (SCM_SUBR_ENTRY(subr).name, subr); @@ -116,7 +116,7 @@ scm_c_define_subr (const char *name, scm_bits_t type, SCM (*fcn) ()) void scm_free_subr_entry (SCM subr) { - scm_bits_t entry = SCM_SUBRNUM (subr); + long entry = SCM_SUBRNUM (subr); /* Move last entry in table to the free position */ scm_subr_table[entry] = scm_subr_table[scm_subr_table_size - 1]; SCM_SET_SUBRNUM (scm_subr_table[entry].handle, entry); @@ -125,7 +125,7 @@ scm_free_subr_entry (SCM subr) SCM scm_c_make_subr_with_generic (const char *name, - scm_bits_t type, SCM (*fcn) (), SCM *gf) + long type, SCM (*fcn) (), SCM *gf) { SCM subr = scm_c_make_subr (name, type, fcn); SCM_SUBR_ENTRY(subr).generic = gf; @@ -134,7 +134,7 @@ scm_c_make_subr_with_generic (const char *name, SCM scm_c_define_subr_with_generic (const char *name, - scm_bits_t type, SCM (*fcn) (), SCM *gf) + long type, SCM (*fcn) (), SCM *gf) { SCM subr = scm_c_make_subr_with_generic (name, type, fcn, gf); scm_define (SCM_SUBR_ENTRY(subr).name, subr); @@ -144,7 +144,7 @@ scm_c_define_subr_with_generic (const char *name, void scm_mark_subr_table () { - scm_bits_t i; + long i; for (i = 0; i < scm_subr_table_size; ++i) { SCM_SETGCMARK (scm_subr_table[i].name); diff --git a/libguile/procs.h b/libguile/procs.h index acb2bc94f..0f07bb08f 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -158,18 +158,18 @@ typedef struct #define SCM_SETTER(obj) SCM_CELL_OBJECT_2 (obj) extern scm_subr_entry_t *scm_subr_table; -extern scm_bits_t scm_subr_table_size; -extern scm_bits_t scm_subr_table_room; +extern long scm_subr_table_size; +extern long scm_subr_table_room; extern void scm_mark_subr_table (void); extern void scm_free_subr_entry (SCM subr); -extern SCM scm_c_make_subr (const char *name, scm_bits_t type, SCM (*fcn)()); -extern SCM scm_c_make_subr_with_generic (const char *name, scm_bits_t type, +extern SCM scm_c_make_subr (const char *name, long type, SCM (*fcn)()); +extern SCM scm_c_make_subr_with_generic (const char *name, long type, SCM (*fcn)(), SCM *gf); -extern SCM scm_c_define_subr (const char *name, scm_bits_t type, SCM (*fcn)()); -extern SCM scm_c_define_subr_with_generic (const char *name, scm_bits_t type, +extern SCM scm_c_define_subr (const char *name, long type, SCM (*fcn)()); +extern SCM scm_c_define_subr_with_generic (const char *name, long type, SCM (*fcn)(), SCM *gf); extern SCM scm_makcclo (SCM proc, size_t len); extern SCM scm_procedure_p (SCM obj); diff --git a/libguile/ramap.c b/libguile/ramap.c index 3970f6191..a1e290c7a 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -166,12 +166,12 @@ do { type (*v0)[2] = (type (*)[2]) SCM_VELTS (ra0);\ break;\ } while (0) -static scm_bits_t +static unsigned long cind (SCM ra, SCM inds) { - scm_bits_t i; + unsigned long i; int k; - scm_bits_t *ve = (scm_bits_t *) SCM_VELTS (inds); + long *ve = (long*) SCM_VELTS (inds); if (!SCM_ARRAYP (ra)) return *ve; i = SCM_ARRAY_BASE (ra); @@ -196,7 +196,7 @@ scm_ra_matchp (SCM ra0, SCM ras) scm_array_dim_t dims; scm_array_dim_t *s0 = &dims; scm_array_dim_t *s1; - scm_bits_t bas0 = 0; + unsigned long bas0 = 0; int i, ndim = 1; int exact = 2 /* 4 */ ; /* Don't care about values >2 (yet?) */ if (SCM_IMP (ra0)) return 0; @@ -255,7 +255,7 @@ scm_ra_matchp (SCM ra0, SCM ras) case scm_tc7_dvect: case scm_tc7_cvect: { - scm_bits_t length; + unsigned long int length; if (1 != ndim) return 0; @@ -322,7 +322,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) SCM inds, z; SCM vra0, ra1, vra1; SCM lvra, *plvra; - scm_bits_t *vinds; + long *vinds; int k, kmax; switch (scm_ra_matchp (ra0, lra)) { @@ -339,7 +339,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) if (SCM_IMP (vra0)) goto gencase; if (!SCM_ARRAYP (vra0)) { - scm_bits_t length = SCM_INUM (scm_uniform_vector_length (vra0)); + unsigned long int length = SCM_INUM (scm_uniform_vector_length (vra0)); vra1 = scm_make_ra (1); SCM_ARRAY_BASE (vra1) = 0; SCM_ARRAY_DIMS (vra1)->lbnd = 0; @@ -397,7 +397,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) } else { - scm_bits_t length = SCM_INUM (scm_uniform_vector_length (ra0)); + unsigned long int length = SCM_INUM (scm_uniform_vector_length (ra0)); kmax = 0; SCM_ARRAY_DIMS (vra0)->lbnd = 0; SCM_ARRAY_DIMS (vra0)->ubnd = length - 1; @@ -429,7 +429,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) plvra = SCM_CDRLOC (*plvra); } inds = scm_make_uve (SCM_ARRAY_NDIM (ra0), SCM_MAKINUM (-1L)); - vinds = (scm_bits_t *) SCM_VELTS (inds); + vinds = (long *) SCM_VELTS (inds); for (k = 0; k <= kmax; k++) vinds[k] = SCM_ARRAY_DIMS (ra0)[k].lbnd; k = kmax; @@ -478,10 +478,10 @@ int scm_array_fill_int (SCM ra, SCM fill, SCM ignore) #define FUNC_NAME s_scm_array_fill_x { - scm_bits_t i; - scm_bits_t n = SCM_ARRAY_DIMS (ra)->ubnd - SCM_ARRAY_DIMS (ra)->lbnd + 1; - scm_bits_t inc = SCM_ARRAY_DIMS (ra)->inc; - scm_bits_t base = SCM_ARRAY_BASE (ra); + unsigned long i; + unsigned long n = SCM_ARRAY_DIMS (ra)->ubnd - SCM_ARRAY_DIMS (ra)->lbnd + 1; + long inc = SCM_ARRAY_DIMS (ra)->inc; + unsigned long base = SCM_ARRAY_BASE (ra); ra = SCM_ARRAY_V (ra); switch SCM_TYP7 (ra) @@ -511,27 +511,27 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore) break; case scm_tc7_bvect: { /* scope */ - scm_bits_t *ve = (scm_bits_t *) SCM_VELTS (ra); - if (1 == inc && (n >= SCM_BITS_LENGTH || n == SCM_BITVECTOR_LENGTH (ra))) + long *ve = (long *) SCM_VELTS (ra); + if (1 == inc && (n >= SCM_LONG_BIT || n == SCM_BITVECTOR_LENGTH (ra))) { - i = base / SCM_BITS_LENGTH; + i = base / SCM_LONG_BIT; if (SCM_FALSEP (fill)) { - if (base % SCM_BITS_LENGTH) /* leading partial word */ - ve[i++] &= ~(~0L << (base % SCM_BITS_LENGTH)); - for (; i < (base + n) / SCM_BITS_LENGTH; i++) + if (base % SCM_LONG_BIT) /* leading partial word */ + ve[i++] &= ~(~0L << (base % SCM_LONG_BIT)); + for (; i < (base + n) / SCM_LONG_BIT; i++) ve[i] = 0L; - if ((base + n) % SCM_BITS_LENGTH) /* trailing partial word */ - ve[i] &= (~0L << ((base + n) % SCM_BITS_LENGTH)); + if ((base + n) % SCM_LONG_BIT) /* trailing partial word */ + ve[i] &= (~0L << ((base + n) % SCM_LONG_BIT)); } else if (SCM_EQ_P (fill, SCM_BOOL_T)) { - if (base % SCM_BITS_LENGTH) - ve[i++] |= ~0L << (base % SCM_BITS_LENGTH); - for (; i < (base + n) / SCM_BITS_LENGTH; i++) + if (base % SCM_LONG_BIT) + ve[i++] |= ~0L << (base % SCM_LONG_BIT); + for (; i < (base + n) / SCM_LONG_BIT; i++) ve[i] = ~0L; - if ((base + n) % SCM_BITS_LENGTH) - ve[i] |= ~(~0L << ((base + n) % SCM_BITS_LENGTH)); + if ((base + n) % SCM_LONG_BIT) + ve[i] |= ~(~0L << ((base + n) % SCM_LONG_BIT)); } else badarg2:SCM_WRONG_TYPE_ARG (2, fill); @@ -540,10 +540,10 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore) { if (SCM_FALSEP (fill)) for (i = base; n--; i += inc) - ve[i / SCM_BITS_LENGTH] &= ~(1L << (i % SCM_BITS_LENGTH)); + ve[i / SCM_LONG_BIT] &= ~(1L << (i % SCM_LONG_BIT)); else if (SCM_EQ_P (fill, SCM_BOOL_T)) for (i = base; n--; i += inc) - ve[i / SCM_BITS_LENGTH] |= (1L << (i % SCM_BITS_LENGTH)); + ve[i / SCM_LONG_BIT] |= (1L << (i % SCM_LONG_BIT)); else goto badarg2; } @@ -637,9 +637,9 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore) static int racp (SCM src, SCM dst) { - scm_bits_t n = (SCM_ARRAY_DIMS (src)->ubnd - SCM_ARRAY_DIMS (src)->lbnd + 1); - scm_bits_t inc_d, inc_s = SCM_ARRAY_DIMS (src)->inc; - scm_bits_t i_d, i_s = SCM_ARRAY_BASE (src); + long n = (SCM_ARRAY_DIMS (src)->ubnd - SCM_ARRAY_DIMS (src)->lbnd + 1); + long inc_d, inc_s = SCM_ARRAY_DIMS (src)->inc; + unsigned long i_d, i_s = SCM_ARRAY_BASE (src); dst = SCM_CAR (dst); inc_d = SCM_ARRAY_DIMS (dst)->inc; i_d = SCM_ARRAY_BASE (dst); @@ -674,22 +674,21 @@ racp (SCM src, SCM dst) case scm_tc7_bvect: if (SCM_TYP7 (src) != scm_tc7_bvect) goto gencase; - if (1 == inc_d && 1 == inc_s && i_s % SCM_BITS_LENGTH == i_d % SCM_BITS_LENGTH - && n >= SCM_BITS_LENGTH) + if (1 == inc_d && 1 == inc_s && i_s % SCM_LONG_BIT == i_d % SCM_LONG_BIT && n >= SCM_LONG_BIT) { - scm_bits_t *sv = (scm_bits_t *) SCM_VELTS (src); - scm_bits_t *dv = (scm_bits_t *) SCM_VELTS (dst); - sv += i_s / SCM_BITS_LENGTH; - dv += i_d / SCM_BITS_LENGTH; - if (i_s % SCM_BITS_LENGTH) + long *sv = (long *) SCM_VELTS (src); + long *dv = (long *) SCM_VELTS (dst); + sv += i_s / SCM_LONG_BIT; + dv += i_d / SCM_LONG_BIT; + if (i_s % SCM_LONG_BIT) { /* leading partial word */ - *dv = (*dv & ~(~0L << (i_s % SCM_BITS_LENGTH))) | (*sv & (~0L << (i_s % SCM_BITS_LENGTH))); + *dv = (*dv & ~(~0L << (i_s % SCM_LONG_BIT))) | (*sv & (~0L << (i_s % SCM_LONG_BIT))); dv++; sv++; - n -= SCM_BITS_LENGTH - (i_s % SCM_BITS_LENGTH); + n -= SCM_LONG_BIT - (i_s % SCM_LONG_BIT); } IVDEP (src != dst, - for (; n >= SCM_BITS_LENGTH; n -= SCM_BITS_LENGTH, sv++, dv++) + for (; n >= SCM_LONG_BIT; n -= SCM_LONG_BIT, sv++, dv++) *dv = *sv;) if (n) /* trailing partial word */ *dv = (*dv & (~0L << n)) | (*sv & ~(~0L << n)); @@ -854,11 +853,11 @@ int scm_ra_eqp (SCM ra0, SCM ras) { SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras)); - scm_bits_t n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_bits_t i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2); - scm_bits_t inc0 = SCM_ARRAY_DIMS (ra0)->inc; - scm_bits_t inc1 = SCM_ARRAY_DIMS (ra1)->inc; - scm_bits_t inc2 = SCM_ARRAY_DIMS (ra1)->inc; + long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; + unsigned long i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2); + long inc0 = SCM_ARRAY_DIMS (ra0)->inc; + long inc1 = SCM_ARRAY_DIMS (ra1)->inc; + long inc2 = SCM_ARRAY_DIMS (ra1)->inc; ra0 = SCM_ARRAY_V (ra0); ra1 = SCM_ARRAY_V (ra1); ra2 = SCM_ARRAY_V (ra2); @@ -913,11 +912,11 @@ scm_ra_eqp (SCM ra0, SCM ras) static int ra_compare (SCM ra0,SCM ra1,SCM ra2,int opt) { - scm_bits_t n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_bits_t i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2); - scm_bits_t inc0 = SCM_ARRAY_DIMS (ra0)->inc; - scm_bits_t inc1 = SCM_ARRAY_DIMS (ra1)->inc; - scm_bits_t inc2 = SCM_ARRAY_DIMS (ra1)->inc; + long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; + unsigned long i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2); + long inc0 = SCM_ARRAY_DIMS (ra0)->inc; + long inc1 = SCM_ARRAY_DIMS (ra1)->inc; + long inc2 = SCM_ARRAY_DIMS (ra1)->inc; ra0 = SCM_ARRAY_V (ra0); ra1 = SCM_ARRAY_V (ra1); ra2 = SCM_ARRAY_V (ra2); @@ -1007,15 +1006,15 @@ scm_ra_greqp (SCM ra0, SCM ras) int scm_ra_sum (SCM ra0, SCM ras) { - scm_bits_t n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_bits_t i0 = SCM_ARRAY_BASE (ra0); - scm_bits_t inc0 = SCM_ARRAY_DIMS (ra0)->inc; + long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; + unsigned long i0 = SCM_ARRAY_BASE (ra0); + long inc0 = SCM_ARRAY_DIMS (ra0)->inc; ra0 = SCM_ARRAY_V (ra0); if (SCM_NNULLP(ras)) { SCM ra1 = SCM_CAR (ras); - scm_bits_t i1 = SCM_ARRAY_BASE (ra1); - scm_bits_t inc1 = SCM_ARRAY_DIMS (ra1)->inc; + unsigned long i1 = SCM_ARRAY_BASE (ra1); + long inc1 = SCM_ARRAY_DIMS (ra1)->inc; ra1 = SCM_ARRAY_V (ra1); switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) { @@ -1046,9 +1045,9 @@ scm_ra_sum (SCM ra0, SCM ras) int scm_ra_difference (SCM ra0, SCM ras) { - scm_bits_t n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_bits_t i0 = SCM_ARRAY_BASE (ra0); - scm_bits_t inc0 = SCM_ARRAY_DIMS (ra0)->inc; + long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; + unsigned long i0 = SCM_ARRAY_BASE (ra0); + long inc0 = SCM_ARRAY_DIMS (ra0)->inc; ra0 = SCM_ARRAY_V (ra0); if (SCM_NULLP (ras)) { @@ -1074,8 +1073,8 @@ scm_ra_difference (SCM ra0, SCM ras) else { SCM ra1 = SCM_CAR (ras); - scm_bits_t i1 = SCM_ARRAY_BASE (ra1); - scm_bits_t inc1 = SCM_ARRAY_DIMS (ra1)->inc; + unsigned long i1 = SCM_ARRAY_BASE (ra1); + long inc1 = SCM_ARRAY_DIMS (ra1)->inc; ra1 = SCM_ARRAY_V (ra1); switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) { @@ -1102,15 +1101,15 @@ scm_ra_difference (SCM ra0, SCM ras) int scm_ra_product (SCM ra0, SCM ras) { - scm_bits_t n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_bits_t i0 = SCM_ARRAY_BASE (ra0); - scm_bits_t inc0 = SCM_ARRAY_DIMS (ra0)->inc; + long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; + unsigned long i0 = SCM_ARRAY_BASE (ra0); + long inc0 = SCM_ARRAY_DIMS (ra0)->inc; ra0 = SCM_ARRAY_V (ra0); if (SCM_NNULLP (ras)) { SCM ra1 = SCM_CAR (ras); - scm_bits_t i1 = SCM_ARRAY_BASE (ra1); - scm_bits_t inc1 = SCM_ARRAY_DIMS (ra1)->inc; + unsigned long i1 = SCM_ARRAY_BASE (ra1); + long inc1 = SCM_ARRAY_DIMS (ra1)->inc; ra1 = SCM_ARRAY_V (ra1); switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) { @@ -1153,9 +1152,9 @@ scm_ra_product (SCM ra0, SCM ras) int scm_ra_divide (SCM ra0, SCM ras) { - scm_bits_t n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_bits_t i0 = SCM_ARRAY_BASE (ra0); - scm_bits_t inc0 = SCM_ARRAY_DIMS (ra0)->inc; + long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; + unsigned long i0 = SCM_ARRAY_BASE (ra0); + long inc0 = SCM_ARRAY_DIMS (ra0)->inc; ra0 = SCM_ARRAY_V (ra0); if (SCM_NULLP (ras)) { @@ -1189,8 +1188,8 @@ scm_ra_divide (SCM ra0, SCM ras) else { SCM ra1 = SCM_CAR (ras); - scm_bits_t i1 = SCM_ARRAY_BASE (ra1); - scm_bits_t inc1 = SCM_ARRAY_DIMS (ra1)->inc; + unsigned long i1 = SCM_ARRAY_BASE (ra1); + long inc1 = SCM_ARRAY_DIMS (ra1)->inc; ra1 = SCM_ARRAY_V (ra1); switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) { @@ -1238,10 +1237,10 @@ scm_array_identity (SCM dst, SCM src) static int ramap (SCM ra0,SCM proc,SCM ras) { - scm_bits_t i = SCM_ARRAY_DIMS (ra0)->lbnd; - scm_bits_t inc = SCM_ARRAY_DIMS (ra0)->inc; - scm_bits_t n = SCM_ARRAY_DIMS (ra0)->ubnd; - scm_bits_t base = SCM_ARRAY_BASE (ra0) - i * inc; + long i = SCM_ARRAY_DIMS (ra0)->lbnd; + long inc = SCM_ARRAY_DIMS (ra0)->inc; + long n = SCM_ARRAY_DIMS (ra0)->ubnd; + long base = SCM_ARRAY_BASE (ra0) - i * inc; ra0 = SCM_ARRAY_V (ra0); if (SCM_NULLP (ras)) for (; i <= n; i++) @@ -1250,8 +1249,8 @@ ramap (SCM ra0,SCM proc,SCM ras) { SCM ra1 = SCM_CAR (ras); SCM args, *ve = &ras; - scm_bits_t k, i1 = SCM_ARRAY_BASE (ra1); - scm_bits_t inc1 = SCM_ARRAY_DIMS (ra1)->inc; + unsigned long k, i1 = SCM_ARRAY_BASE (ra1); + long inc1 = SCM_ARRAY_DIMS (ra1)->inc; ra1 = SCM_ARRAY_V (ra1); ras = SCM_CDR (ras); if (SCM_NULLP(ras)) @@ -1279,9 +1278,9 @@ ramap_cxr (SCM ra0,SCM proc,SCM ras) { SCM ra1 = SCM_CAR (ras); SCM e1 = SCM_UNDEFINED; - scm_bits_t i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1); - scm_bits_t inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc; - scm_bits_t n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra1)->lbnd + 1; + unsigned long i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1); + long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc; + long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra1)->lbnd + 1; ra0 = SCM_ARRAY_V (ra0); ra1 = SCM_ARRAY_V (ra1); switch (SCM_TYP7 (ra0)) @@ -1340,11 +1339,11 @@ ramap_rp (SCM ra0,SCM proc,SCM ras) { SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras)); SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED; - scm_bits_t n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_bits_t i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2); - scm_bits_t inc0 = SCM_ARRAY_DIMS (ra0)->inc; - scm_bits_t inc1 = SCM_ARRAY_DIMS (ra1)->inc; - scm_bits_t inc2 = SCM_ARRAY_DIMS (ra1)->inc; + long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; + unsigned long i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2); + long inc0 = SCM_ARRAY_DIMS (ra0)->inc; + long inc1 = SCM_ARRAY_DIMS (ra1)->inc; + long inc2 = SCM_ARRAY_DIMS (ra1)->inc; ra0 = SCM_ARRAY_V (ra0); ra1 = SCM_ARRAY_V (ra1); ra2 = SCM_ARRAY_V (ra2); @@ -1425,9 +1424,9 @@ ramap_1 (SCM ra0,SCM proc,SCM ras) { SCM ra1 = SCM_CAR (ras); SCM e1 = SCM_UNDEFINED; - scm_bits_t n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_bits_t i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1); - scm_bits_t inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc; + long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; + unsigned long i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1); + long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc; ra0 = SCM_ARRAY_V (ra0); ra1 = SCM_ARRAY_V (ra1); if (scm_tc7_vector == SCM_TYP7 (ra0) || scm_tc7_wvect == SCM_TYP7 (ra0)) @@ -1446,9 +1445,9 @@ ramap_2o (SCM ra0,SCM proc,SCM ras) { SCM ra1 = SCM_CAR (ras); SCM e1 = SCM_UNDEFINED; - scm_bits_t n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_bits_t i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1); - scm_bits_t inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc; + long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; + unsigned long i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1); + long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc; ra0 = SCM_ARRAY_V (ra0); ra1 = SCM_ARRAY_V (ra1); ras = SCM_CDR (ras); @@ -1469,8 +1468,8 @@ ramap_2o (SCM ra0,SCM proc,SCM ras) { SCM ra2 = SCM_CAR (ras); SCM e2 = SCM_UNDEFINED; - scm_bits_t i2 = SCM_ARRAY_BASE (ra2); - scm_bits_t inc2 = SCM_ARRAY_DIMS (ra2)->inc; + unsigned long i2 = SCM_ARRAY_BASE (ra2); + long inc2 = SCM_ARRAY_DIMS (ra2)->inc; ra2 = SCM_ARRAY_V (ra2); if (scm_tc7_vector == SCM_TYP7 (ra0) || scm_tc7_wvect == SCM_TYP7 (ra0)) for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) @@ -1492,9 +1491,9 @@ static int ramap_a (SCM ra0,SCM proc,SCM ras) { SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; - scm_bits_t n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_bits_t i0 = SCM_ARRAY_BASE (ra0); - scm_bits_t inc0 = SCM_ARRAY_DIMS (ra0)->inc; + long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; + unsigned long i0 = SCM_ARRAY_BASE (ra0); + long inc0 = SCM_ARRAY_DIMS (ra0)->inc; ra0 = SCM_ARRAY_V (ra0); if (SCM_NULLP (ras)) for (; n-- > 0; i0 += inc0) @@ -1502,8 +1501,8 @@ ramap_a (SCM ra0,SCM proc,SCM ras) else { SCM ra1 = SCM_CAR (ras); - scm_bits_t i1 = SCM_ARRAY_BASE (ra1); - scm_bits_t inc1 = SCM_ARRAY_DIMS (ra1)->inc; + unsigned long i1 = SCM_ARRAY_BASE (ra1); + long inc1 = SCM_ARRAY_DIMS (ra1)->inc; ra1 = SCM_ARRAY_V (ra1); for (; n-- > 0; i0 += inc0, i1 += inc1) scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), @@ -1632,10 +1631,10 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1, static int rafe (SCM ra0,SCM proc,SCM ras) { - scm_bits_t i = SCM_ARRAY_DIMS (ra0)->lbnd; - scm_bits_t i0 = SCM_ARRAY_BASE (ra0); - scm_bits_t inc0 = SCM_ARRAY_DIMS (ra0)->inc; - scm_bits_t n = SCM_ARRAY_DIMS (ra0)->ubnd; + long i = SCM_ARRAY_DIMS (ra0)->lbnd; + unsigned long i0 = SCM_ARRAY_BASE (ra0); + long inc0 = SCM_ARRAY_DIMS (ra0)->inc; + long n = SCM_ARRAY_DIMS (ra0)->ubnd; ra0 = SCM_ARRAY_V (ra0); if (SCM_NULLP (ras)) for (; i <= n; i++, i0 += inc0) @@ -1644,8 +1643,8 @@ rafe (SCM ra0,SCM proc,SCM ras) { SCM ra1 = SCM_CAR (ras); SCM args, *ve = &ras; - scm_bits_t k, i1 = SCM_ARRAY_BASE (ra1); - scm_bits_t inc1 = SCM_ARRAY_DIMS (ra1)->inc; + unsigned long k, i1 = SCM_ARRAY_BASE (ra1); + long inc1 = SCM_ARRAY_DIMS (ra1)->inc; ra1 = SCM_ARRAY_V (ra1); ras = SCM_CDR (ras); if (SCM_NULLP(ras)) @@ -1702,7 +1701,7 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0, "@end lisp") #define FUNC_NAME s_scm_array_index_map_x { - scm_bits_t i; + unsigned long i; SCM_VALIDATE_NIM (1,ra); SCM_VALIDATE_PROC (2,proc); switch (SCM_TYP7(ra)) @@ -1730,7 +1729,7 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0, case scm_tc7_dvect: case scm_tc7_cvect: { - scm_bits_t length = SCM_INUM (scm_uniform_vector_length (ra)); + unsigned long int length = SCM_INUM (scm_uniform_vector_length (ra)); for (i = 0; i < length; i++) scm_array_set_x (ra, scm_apply (proc, SCM_MAKINUM (i), scm_listofnull), SCM_MAKINUM (i)); @@ -1741,7 +1740,7 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0, { SCM args = SCM_EOL; SCM inds = scm_make_uve (SCM_ARRAY_NDIM (ra), SCM_MAKINUM (-1L)); - scm_bits_t *vinds = (scm_bits_t *) SCM_VELTS (inds); + long *vinds = (long *) SCM_VELTS (inds); int j, k, kmax = SCM_ARRAY_NDIM (ra) - 1; if (kmax < 0) return scm_array_set_x (ra, scm_apply(proc, SCM_EOL, SCM_EOL), @@ -1788,9 +1787,9 @@ static int raeql_1 (SCM ra0,SCM as_equal,SCM ra1) { SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; - scm_bits_t i0 = 0, i1 = 0; - scm_bits_t inc0 = 1, inc1 = 1; - scm_bits_t n; + unsigned long i0 = 0, i1 = 0; + long inc0 = 1, inc1 = 1; + unsigned long n; ra1 = SCM_CAR (ra1); if (SCM_ARRAYP(ra0)) { @@ -1918,7 +1917,7 @@ raeql (SCM ra0,SCM as_equal,SCM ra1) SCM v0 = ra0, v1 = ra1; scm_array_dim_t dim0, dim1; scm_array_dim_t *s0 = &dim0, *s1 = &dim1; - scm_bits_t bas0 = 0, bas1 = 0; + unsigned long bas0 = 0, bas1 = 0; int k, unroll = 1, vlen = 1, ndim = 1; if (SCM_ARRAYP (ra0)) { diff --git a/libguile/root.c b/libguile/root.c index 23ca98256..f3d6edd86 100644 --- a/libguile/root.c +++ b/libguile/root.c @@ -171,7 +171,7 @@ scm_make_root (SCM parent) #if 0 SCM scm_exitval; /* INUM with return value */ #endif -static scm_bits_t n_dynamic_roots = 0; +static long n_dynamic_roots = 0; /* cwdr fills out both of these structures, and then passes a pointer diff --git a/libguile/rw.c b/libguile/rw.c index e0d271cf5..28d4ea604 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -111,13 +111,13 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0, #define FUNC_NAME s_scm_read_string_x_partial { char *dest; - scm_bits_t read_len; - scm_bits_t chars_read = 0; + long read_len; + long chars_read = 0; int fdes; { - scm_bits_t offset; - scm_bits_t last; + long offset; + long last; SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, dest, 3, start, offset, 4, end, last); diff --git a/libguile/smob.c b/libguile/smob.c index a487b9715..e2d9fcb7c 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -67,7 +67,7 @@ */ #define MAX_SMOB_COUNT 256 -scm_bits_t scm_numsmob; +long scm_numsmob; scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT]; /* {Mark} @@ -119,7 +119,7 @@ scm_smob_free (SCM obj) int scm_smob_print (SCM exp, SCM port, scm_print_state *pstate) { - size_t n = SCM_SMOBNUM (exp); + long n = SCM_SMOBNUM (exp); scm_puts ("#<", port); scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port); scm_putc (' ', port); @@ -289,7 +289,7 @@ scm_bits_t scm_make_smob_type (char *name, size_t size) #define FUNC_NAME "scm_make_smob_type" { - size_t new_smob; + long new_smob; SCM_ENTER_A_SECTION; /* scm_numsmob */ new_smob = scm_numsmob; @@ -453,7 +453,7 @@ scm_set_smob_apply (scm_bits_t tc, SCM (*apply) (), SCM scm_make_smob (scm_bits_t tc) { - size_t n = SCM_TC2SMOBNUM (tc); + long n = SCM_TC2SMOBNUM (tc); size_t size = scm_smobs[n].size; SCM z; SCM_NEWCELL (z); @@ -487,7 +487,7 @@ scm_make_smob_type_mfpe (char *name, size_t size, int (*print) (SCM, SCM, scm_print_state *), SCM (*equalp) (SCM, SCM)) { - scm_bits_t answer = scm_make_smob_type (name, size); + long answer = scm_make_smob_type (name, size); scm_set_smob_mfpe (answer, mark, free, print, equalp); return answer; } @@ -526,7 +526,7 @@ free_print (SCM exp, SCM port, scm_print_state *pstate) void scm_smob_prehistory () { - size_t i; + long i; scm_bits_t tc; scm_numsmob = 0; diff --git a/libguile/smob.h b/libguile/smob.h index 9cbf38738..c0dd0976a 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -124,7 +124,7 @@ do { \ #define SCM_SMOB_APPLY_2(x,a1,a2) (SCM_SMOB_DESCRIPTOR (x).apply_2 (x, (a1), (a2))) #define SCM_SMOB_APPLY_3(x,a1,a2,rst) (SCM_SMOB_DESCRIPTOR (x).apply_3 (x, (a1), (a2), (rst))) -extern scm_bits_t scm_numsmob; +extern long scm_numsmob; extern scm_smob_descriptor scm_smobs[]; diff --git a/libguile/sort.c b/libguile/sort.c index 5b5dc9584..5f849328f 100644 --- a/libguile/sort.c +++ b/libguile/sort.c @@ -456,7 +456,7 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0, "applied to all elements i - 1 and i") #define FUNC_NAME s_scm_sorted_p { - scm_bits_t len, j; /* list/vector length, temp j */ + long len, j; /* list/vector length, temp j */ SCM item, rest; /* rest of items loop variable */ SCM *vp; cmp_fun_t cmp = scm_cmp_function (less); @@ -528,7 +528,7 @@ SCM_DEFINE (scm_merge, "merge", 3, 0, 0, "Note: this does _not_ accept vectors.") #define FUNC_NAME s_scm_merge { - scm_bits_t alen, blen; /* list lengths */ + long alen, blen; /* list lengths */ SCM build, last; cmp_fun_t cmp = scm_cmp_function (less); SCM_VALIDATE_NIM (3,less); @@ -641,7 +641,7 @@ SCM_DEFINE (scm_merge_x, "merge!", 3, 0, 0, "Note: this does _not_ accept vectors.") #define FUNC_NAME s_scm_merge_x { - scm_bits_t alen, blen; /* list lengths */ + long alen, blen; /* list lengths */ SCM_VALIDATE_NIM (3,less); if (SCM_NULLP (alist)) @@ -669,13 +669,13 @@ static SCM scm_merge_list_step (SCM * seq, cmp_fun_t cmp, SCM less, - scm_bits_t n) + long n) { SCM a, b; if (n > 2) { - scm_bits_t mid = n / 2; + long mid = n / 2; a = scm_merge_list_step (seq, cmp, less, mid); b = scm_merge_list_step (seq, cmp, less, n - mid); return scm_merge_list_x (a, b, mid, n - mid, cmp, less); @@ -717,7 +717,7 @@ SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0, "This is not a stable sort.") #define FUNC_NAME s_scm_sort_x { - scm_bits_t len; /* list/vector length */ + long len; /* list/vector length */ if (SCM_NULLP(items)) return SCM_EOL; @@ -757,7 +757,7 @@ SCM_DEFINE (scm_sort, "sort", 2, 0, 0, SCM_VALIDATE_NIM (2,less); if (SCM_CONSP (items)) { - scm_bits_t len; + long len; SCM_VALIDATE_LIST_COPYLEN (1,items,len); items = scm_list_copy (items); @@ -767,7 +767,7 @@ SCM_DEFINE (scm_sort, "sort", 2, 0, 0, /* support ordinary vectors even if arrays not available? */ else if (SCM_VECTORP (items)) { - scm_bits_t len = SCM_VECTOR_LENGTH (items); + long len = SCM_VECTOR_LENGTH (items); SCM sortvec = scm_make_uve (len, scm_array_prototype (items)); scm_array_copy_x (items, sortvec); @@ -788,15 +788,15 @@ scm_merge_vector_x (void *const vecbase, void *const tempbase, cmp_fun_t cmp, SCM less, - scm_bits_t low, - scm_bits_t mid, - scm_bits_t high) + long low, + long mid, + long high) { register SCM *vp = (SCM *) vecbase; register SCM *temp = (SCM *) tempbase; - scm_bits_t it; /* Index for temp vector */ - scm_bits_t i1 = low; /* Index for lower vector segment */ - scm_bits_t i2 = mid + 1; /* Index for upper vector segment */ + long it; /* Index for temp vector */ + long i1 = low; /* Index for lower vector segment */ + long i2 = mid + 1; /* Index for upper vector segment */ /* Copy while both segments contain more characters */ for (it = low; (i1 <= mid) && (i2 <= high); ++it) @@ -823,12 +823,12 @@ scm_merge_vector_step (void *const vp, void *const temp, cmp_fun_t cmp, SCM less, - scm_bits_t low, - scm_bits_t high) + long low, + long high) { if (high > low) { - scm_bits_t mid = (low + high) / 2; + long mid = (low + high) / 2; scm_merge_vector_step (vp, temp, cmp, less, low, mid); scm_merge_vector_step (vp, temp, cmp, less, mid+1, high); scm_merge_vector_x (vp, temp, cmp, less, low, mid, high); @@ -847,7 +847,7 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0, "This is a stable sort.") #define FUNC_NAME s_scm_stable_sort_x { - scm_bits_t len; /* list/vector length */ + long len; /* list/vector length */ if (SCM_NULLP (items)) return SCM_EOL; @@ -887,7 +887,7 @@ SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0, "This is a stable sort.") #define FUNC_NAME s_scm_stable_sort { - scm_bits_t len; /* list/vector length */ + long len; /* list/vector length */ if (SCM_NULLP (items)) return SCM_EOL; @@ -933,7 +933,7 @@ SCM_DEFINE (scm_sort_list_x, "sort-list!", 2, 0, 0, "This is a stable sort.") #define FUNC_NAME s_scm_sort_list_x { - scm_bits_t len; + long len; SCM_VALIDATE_LIST_COPYLEN (1,items,len); SCM_VALIDATE_NIM (2,less); return scm_merge_list_step (&items, scm_cmp_function (less), less, len); @@ -947,7 +947,7 @@ SCM_DEFINE (scm_sort_list, "sort-list", 2, 0, 0, "list elements. This is a stable sort.") #define FUNC_NAME s_scm_sort_list { - scm_bits_t len; + long len; SCM_VALIDATE_LIST_COPYLEN (1,items,len); SCM_VALIDATE_NIM (2,less); items = scm_list_copy (items); diff --git a/libguile/stacks.c b/libguile/stacks.c index 9085bec68..d6a6e16af 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -153,10 +153,10 @@ * is read from a continuation. */ static scm_bits_t -stack_depth (scm_debug_frame_t *dframe,scm_bits_t offset,SCM *id,int *maxp) +stack_depth (scm_debug_frame_t *dframe,long offset,SCM *id,int *maxp) { - scm_bits_t n; - scm_bits_t max_depth = SCM_BACKTRACE_MAXDEPTH; + long n; + long max_depth = SCM_BACKTRACE_MAXDEPTH; for (n = 0; dframe && !SCM_VOIDFRAMEP (*dframe) && n < max_depth; dframe = RELOC_FRAME (dframe->prev, offset)) @@ -185,7 +185,7 @@ stack_depth (scm_debug_frame_t *dframe,scm_bits_t offset,SCM *id,int *maxp) /* Read debug info from DFRAME into IFRAME. */ static void -read_frame (scm_debug_frame_t *dframe,scm_bits_t offset,scm_info_frame_t *iframe) +read_frame (scm_debug_frame_t *dframe,long offset,scm_info_frame_t *iframe) { scm_bits_t flags = SCM_UNPACK (SCM_INUM0); /* UGh. */ if (SCM_EVALFRAMEP (*dframe)) @@ -252,7 +252,7 @@ do { \ */ static scm_bits_t -read_frames (scm_debug_frame_t *dframe,scm_bits_t offset,scm_bits_t n,scm_info_frame_t *iframes) +read_frames (scm_debug_frame_t *dframe,long offset,long n,scm_info_frame_t *iframes) { scm_info_frame_t *iframe = iframes; scm_debug_info_t *info; @@ -345,11 +345,11 @@ read_frames (scm_debug_frame_t *dframe,scm_bits_t offset,scm_bits_t n,scm_info_f */ static void -narrow_stack (SCM stack,scm_bits_t inner,SCM inner_key,scm_bits_t outer,SCM outer_key) +narrow_stack (SCM stack,long inner,SCM inner_key,long outer,SCM outer_key) { scm_stack_t *s = SCM_STACK (stack); - scm_bits_t i; - scm_bits_t n = s->length; + long i; + long n = s->length; /* Cut inner part. */ if (SCM_EQ_P (inner_key, SCM_BOOL_T)) @@ -421,11 +421,11 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, "resulting stack will be narrowed.") #define FUNC_NAME s_scm_make_stack { - scm_bits_t n, size; + long n, size; int maxp; scm_debug_frame_t *dframe = scm_last_debug_frame; scm_info_frame_t *iframe; - scm_bits_t offset = 0; + long offset = 0; SCM stack, id; SCM inner_cut, outer_cut; @@ -514,7 +514,7 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0, #define FUNC_NAME s_scm_stack_id { scm_debug_frame_t *dframe; - scm_bits_t offset = 0; + long offset = 0; if (SCM_EQ_P (stack, SCM_BOOL_T)) dframe = scm_last_debug_frame; else @@ -588,7 +588,7 @@ SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0, #define FUNC_NAME s_scm_last_stack_frame { scm_debug_frame_t *dframe; - scm_bits_t offset = 0; + long offset = 0; SCM stack; SCM_VALIDATE_NIM (1,obj); @@ -672,7 +672,7 @@ SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0, "@var{frame} is the first frame in its stack.") #define FUNC_NAME s_scm_frame_previous { - scm_bits_t n; + long n; SCM_VALIDATE_FRAME (1,frame); n = SCM_INUM (SCM_CDR (frame)) + 1; if (n >= SCM_STACK_LENGTH (SCM_CAR (frame))) @@ -688,7 +688,7 @@ SCM_DEFINE (scm_frame_next, "frame-next", 1, 0, 0, "@var{frame} is the last frame in its stack.") #define FUNC_NAME s_scm_frame_next { - scm_bits_t n; + long n; SCM_VALIDATE_FRAME (1,frame); n = SCM_INUM (SCM_CDR (frame)) - 1; if (n < 0) diff --git a/libguile/stacks.h b/libguile/stacks.h index b596f87cf..b86d87aa3 100644 --- a/libguile/stacks.h +++ b/libguile/stacks.h @@ -69,8 +69,8 @@ typedef struct scm_info_frame_t { typedef struct scm_stack_t { SCM id; /* Stack id */ scm_info_frame_t *frames; /* Info frames */ - scm_bits_t length; /* Stack length */ - scm_bits_t tail_length; + unsigned long length; /* Stack length */ + unsigned long tail_length; scm_info_frame_t tail[1]; } scm_stack_t; diff --git a/libguile/strings.c b/libguile/strings.c index c2ab44166..b87864973 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -96,7 +96,7 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1, SCM result; { - scm_bits_t i = scm_ilength (chrs); + long i = scm_ilength (chrs); SCM_ASSERT (i >= 0, chrs, SCM_ARGn, FUNC_NAME); result = scm_allocate_string (i); @@ -248,7 +248,7 @@ SCM_DEFINE (scm_make_string, "make-string", 1, 1, 0, { if (SCM_INUMP (k)) { - scm_bits_t i = SCM_INUM (k); + long int i = SCM_INUM (k); SCM res; SCM_ASSERT_RANGE (1, k, i >= 0); @@ -290,7 +290,7 @@ SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0, "indexing. @var{k} must be a valid index of @var{str}.") #define FUNC_NAME s_scm_string_ref { - scm_bits_t idx; + long idx; SCM_VALIDATE_STRING (1, str); SCM_VALIDATE_INUM_COPY (2, k, idx); @@ -330,8 +330,8 @@ SCM_DEFINE (scm_substring, "substring", 2, 1, 0, "0 <= @var{start} <= @var{end} <= (string-length @var{str}).") #define FUNC_NAME s_scm_substring { - scm_bits_t from; - scm_bits_t to; + long int from; + long int to; SCM_VALIDATE_STRING (1, str); SCM_VALIDATE_INUM (2, start); @@ -393,8 +393,8 @@ SCM_DEFINE (scm_make_shared_substring, "make-shared-substring", 1, 2, 0, "occupies the same storage space as @var{str}.") #define FUNC_NAME s_scm_make_shared_substring { - scm_bits_t f; - scm_bits_t t; + long f; + long t; SCM answer; SCM len_str; @@ -411,7 +411,7 @@ SCM_DEFINE (scm_make_shared_substring, "make-shared-substring", 1, 2, 0, SCM_DEFER_INTS; if (SCM_SUBSTRP (str)) { - scm_bits_t offset; + long offset; offset = SCM_INUM (SCM_SUBSTR_OFFSET (str)); f += offset; t += offset; diff --git a/libguile/strop.c b/libguile/strop.c index 4efb95599..ff2698fb3 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -48,14 +48,14 @@ xSCM_DEFINE (scm_i_index, "i-index", 2, 2, 0, "@code{rindex} function, depending on the value of @var{direction}." */ /* implements index if direction > 0 otherwise rindex. */ -static scm_bits_t +static long scm_i_index (SCM *str, SCM chr, int direction, SCM sub_start, SCM sub_end, const char *why) { unsigned char * p; - scm_bits_t x; - scm_bits_t lower; - scm_bits_t upper; + long x; + long lower; + long upper; int ch; SCM_ASSERT (SCM_STRINGP (*str), *str, SCM_ARG1, why); @@ -116,7 +116,7 @@ SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0, "@end lisp") #define FUNC_NAME s_scm_string_index { - scm_bits_t pos; + long pos; if (SCM_UNBNDP (frm)) frm = SCM_BOOL_F; @@ -146,7 +146,7 @@ SCM_DEFINE (scm_string_rindex, "string-rindex", 2, 2, 0, "@end lisp") #define FUNC_NAME s_scm_string_rindex { - scm_bits_t pos; + long pos; if (SCM_UNBNDP (frm)) frm = SCM_BOOL_F; @@ -238,7 +238,7 @@ SCM_DEFINE (scm_substring_move_x, "substring-move!", 5, 0, 0, "are different strings, it does not matter which function you use.") #define FUNC_NAME s_scm_substring_move_x { - scm_bits_t s1, s2, e, len; + long s1, s2, e, len; SCM_VALIDATE_STRING (1,str1); SCM_VALIDATE_INUM_COPY (2,start1,s1); @@ -274,7 +274,7 @@ SCM_DEFINE (scm_substring_fill_x, "substring-fill!", 4, 0, 0, "@end lisp") #define FUNC_NAME s_scm_substring_fill_x { - scm_bits_t i, e; + long i, e; char c; SCM_VALIDATE_STRING (1,str); SCM_VALIDATE_INUM_COPY (2,start,i); @@ -313,7 +313,7 @@ SCM_DEFINE (scm_string_to_list, "string->list", 1, 0, 0, "concerned.") #define FUNC_NAME s_scm_string_to_list { - scm_bits_t i; + long i; SCM res = SCM_EOL; unsigned char *src; SCM_VALIDATE_STRING (1,str); @@ -352,7 +352,7 @@ SCM_DEFINE (scm_string_fill_x, "string-fill!", 2, 0, 0, #define FUNC_NAME s_scm_string_fill_x { register char *dst, c; - register scm_bits_t k; + register long k; SCM_VALIDATE_STRING_COPY (1,str,dst); SCM_VALIDATE_CHAR_COPY (2,chr,c); for (k = SCM_STRING_LENGTH (str)-1;k >= 0;k--) dst[k] = c; @@ -366,7 +366,7 @@ SCM_DEFINE (scm_string_fill_x, "string-fill!", 2, 0, 0, static SCM string_upcase_x (SCM v) { - scm_bits_t k; + unsigned long k; for (k = 0; k < SCM_STRING_LENGTH (v); ++k) SCM_STRING_UCHARS (v) [k] = scm_upcase (SCM_STRING_UCHARS (v) [k]); @@ -411,7 +411,7 @@ SCM_DEFINE (scm_string_upcase, "string-upcase", 1, 0, 0, static SCM string_downcase_x (SCM v) { - scm_bits_t k; + unsigned long k; for (k = 0; k < SCM_STRING_LENGTH (v); ++k) SCM_STRING_UCHARS (v) [k] = scm_downcase (SCM_STRING_UCHARS (v) [k]); @@ -457,7 +457,7 @@ static SCM string_capitalize_x (SCM str) { char *sz; - scm_bits_t i, len; + long i, len; int in_word=0; len = SCM_STRING_LENGTH(str); @@ -532,7 +532,7 @@ SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0, "@end lisp") #define FUNC_NAME s_scm_string_split { - scm_bits_t idx, last_idx; + long idx, last_idx; char * p; int ch; SCM res = SCM_EOL; diff --git a/libguile/strports.c b/libguile/strports.c index 4fb102664..21bffde78 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -101,9 +101,9 @@ st_resize_port (scm_port_t *pt, off_t new_size) { SCM old_stream = SCM_PACK (pt->stream); SCM new_stream = scm_allocate_string (new_size); - size_t old_size = SCM_STRING_LENGTH (old_stream); - size_t min_size = min (old_size, new_size); - size_t i; + unsigned long int old_size = SCM_STRING_LENGTH (old_stream); + unsigned long int min_size = min (old_size, new_size); + unsigned long int i; off_t index = pt->write_pos - pt->write_buf; diff --git a/libguile/struct.c b/libguile/struct.c index 5710f4080..b13a8c1c8 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -736,8 +736,8 @@ SCM_DEFINE (scm_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0, * how to associate names with vtables. */ -scm_bits_t -scm_struct_ihashq (SCM obj, scm_bits_t n) +unsigned long +scm_struct_ihashq (SCM obj, unsigned long n) { /* The length of the hash table should be a relative prime it's not necessary to shift down the address. */ diff --git a/libguile/struct.h b/libguile/struct.h index b66db2122..bd952f7eb 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -119,7 +119,7 @@ extern SCM scm_struct_ref (SCM handle, SCM pos); extern SCM scm_struct_set_x (SCM handle, SCM pos, SCM val); extern SCM scm_struct_vtable (SCM handle); extern SCM scm_struct_vtable_tag (SCM handle); -extern scm_bits_t scm_struct_ihashq (SCM obj, scm_bits_t n); +extern unsigned long scm_struct_ihashq (SCM obj, unsigned long n); extern SCM scm_struct_create_handle (SCM obj); extern SCM scm_struct_vtable_name (SCM vtable); extern SCM scm_set_struct_vtable_name_x (SCM vtable, SCM name); diff --git a/libguile/symbols.h b/libguile/symbols.h index fe4870b0e..3691ac46e 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -55,11 +55,11 @@ */ #define SCM_SYMBOLP(x) (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_symbol)) -#define SCM_SYMBOL_LENGTH(x) (((scm_ubits_t) SCM_CELL_WORD_0 (x)) >> 8) +#define SCM_SYMBOL_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_SET_SYMBOL_LENGTH(s, l) (SCM_SET_CELL_WORD_0 ((s), ((l) << 8) + scm_tc7_symbol)) #define SCM_SYMBOL_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) #define SCM_SET_SYMBOL_CHARS(s, c) (SCM_SET_CELL_WORD_1 ((s), (c))) -#define SCM_SYMBOL_HASH(X) ((scm_ubits_t) SCM_CELL_WORD_2 (X)) +#define SCM_SYMBOL_HASH(X) ((unsigned long) SCM_CELL_WORD_2 (X)) #define SCM_SET_SYMBOL_HASH(X, v) (SCM_SET_CELL_WORD_2 ((X), (v))) #define SCM_PROP_SLOTS(X) (SCM_CELL_WORD_3 (X)) @@ -103,7 +103,7 @@ extern void scm_init_symbols (void); #define SCM_SUBSTR_STR(x) (SCM_CDDR (x)) #define SCM_SUBSTR_OFFSET(x) (SCM_CADR (x)) #define SCM_LENGTH_MAX (0xffffffL) -#define SCM_LENGTH(x) (((scm_ubits_t) SCM_CELL_WORD_0 (x)) >> 8) +#define SCM_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_SETLENGTH(x, v, t) (SCM_SET_CELL_WORD_0 ((x), ((v) << 8) + (t))) #define SCM_ROSTRINGP(x) (SCM_NIMP(x) && ((SCM_TYP7S(x)==scm_tc7_string) \ || (SCM_TYP7(x) == scm_tc7_symbol))) diff --git a/libguile/tags.h b/libguile/tags.h index eebe63e75..e64ad4c35 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -58,8 +58,7 @@ /* In the beginning was the Word: */ -typedef SCM_BITS_T scm_bits_t; -typedef SCM_UBITS_T scm_ubits_t; +typedef long scm_bits_t; /* But as external interface, we use SCM, which may, according to the desired * level of type checking, be defined in several ways: diff --git a/libguile/unif.c b/libguile/unif.c index aad700af9..fbb9b96d7 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -101,8 +101,6 @@ scm_uniform_element_size (SCM obj) switch (SCM_TYP7 (obj)) { case scm_tc7_bvect: - result = sizeof (scm_bits_t); - break; case scm_tc7_uvect: case scm_tc7_ivect: result = sizeof (long); @@ -156,32 +154,20 @@ singp (SCM obj) } } -#if (SIZEOF_SIZE_T < SCM_SIZEOF_BITS_T) -# define CHECK_BYTE_SIZE(s,k) SCM_ASSERT_RANGE (1, scm_bits2num (k), k <= (size_t)(~(size_t)0)) -#else -# define CHECK_BYTE_SIZE(s,k) -#endif - SCM -scm_make_uve (scm_bits_t k, SCM prot) +scm_make_uve (long k, SCM prot) #define FUNC_NAME "scm_make_uve" { SCM v; - size_t i; - scm_bits_t type; - scm_ubits_t size_in_bytes; + long i, type; if (SCM_EQ_P (prot, SCM_BOOL_T)) { SCM_NEWCELL (v); if (k > 0) { - SCM_ASSERT_RANGE (1, scm_bits2num (k), - k <= SCM_BITVECTOR_MAX_LENGTH); - size_in_bytes = sizeof (scm_bits_t) * ((k + SCM_BITS_LENGTH - 1) / - SCM_BITS_LENGTH); - CHECK_BYTE_SIZE (size_in_bytes, k); - i = (size_t) size_in_bytes; + SCM_ASSERT_RANGE (1, scm_long2num (k), k <= SCM_BITVECTOR_MAX_LENGTH); + i = sizeof (long) * ((k + SCM_LONG_BIT - 1) / SCM_LONG_BIT); SCM_SET_BITVECTOR_BASE (v, (char *) scm_must_malloc (i, "vector")); SCM_SET_BITVECTOR_LENGTH (v, k); } @@ -194,19 +180,17 @@ scm_make_uve (scm_bits_t k, SCM prot) } else if (SCM_CHARP (prot) && (SCM_CHAR (prot) == '\0')) { - size_in_bytes = sizeof (char) * k; + i = sizeof (char) * k; type = scm_tc7_byvect; } else if (SCM_CHARP (prot)) { - size_in_bytes = sizeof (char) * k; - CHECK_BYTE_SIZE (size_in_bytes, k); - i = (size_t) size_in_bytes; + i = sizeof (char) * k; return scm_allocate_string (i); } else if (SCM_INUMP (prot)) { - size_in_bytes = sizeof (long) * k; + i = sizeof (long) * k; if (SCM_INUM (prot) > 0) type = scm_tc7_uvect; else @@ -219,13 +203,13 @@ scm_make_uve (scm_bits_t k, SCM prot) s = SCM_SYMBOL_CHARS (prot)[0]; if (s == 's') { - size_in_bytes = sizeof (short) * k; + i = sizeof (short) * k; type = scm_tc7_svect; } #ifdef HAVE_LONG_LONGS else if (s == 'l') { - size_in_bytes = sizeof (long long) * k; + i = sizeof (long long) * k; type = scm_tc7_llvect; } #endif @@ -233,7 +217,6 @@ scm_make_uve (scm_bits_t k, SCM prot) { return scm_c_make_vector (k, SCM_UNDEFINED); } - } else if (!SCM_INEXACTP (prot)) /* Huge non-unif vectors are NOT supported. */ @@ -241,24 +224,21 @@ scm_make_uve (scm_bits_t k, SCM prot) return scm_c_make_vector (k, SCM_UNDEFINED); else if (singp (prot)) { - size_in_bytes = sizeof (float) * k; + i = sizeof (float) * k; type = scm_tc7_fvect; } else if (SCM_COMPLEXP (prot)) { - size_in_bytes = 2 * sizeof (double) * k; + i = 2 * sizeof (double) * k; type = scm_tc7_cvect; } else { - size_in_bytes = sizeof (double) * k; + i = sizeof (double) * k; type = scm_tc7_dvect; } - CHECK_BYTE_SIZE (size_in_bytes, k); - i = (size_t) size_in_bytes; - - SCM_ASSERT_RANGE (1, scm_bits2num (k), k <= SCM_UVECTOR_MAX_LENGTH); + SCM_ASSERT_RANGE (1, scm_long2num (k), k <= SCM_UVECTOR_MAX_LENGTH); SCM_NEWCELL (v); SCM_DEFER_INTS; @@ -503,14 +483,14 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0, static char s_bad_ind[] = "Bad scm_array index"; -scm_bits_t +long scm_aind (SCM ra, SCM args, const char *what) #define FUNC_NAME what { SCM ind; - register scm_bits_t j; - register scm_bits_t pos = SCM_ARRAY_BASE (ra); - register size_t k = SCM_ARRAY_NDIM (ra); + register long j; + register unsigned long pos = SCM_ARRAY_BASE (ra); + register unsigned long k = SCM_ARRAY_NDIM (ra); scm_array_dim_t *s = SCM_ARRAY_DIMS (ra); if (SCM_INUMP (args)) { @@ -608,7 +588,7 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, #define FUNC_NAME s_scm_dimensions_to_uniform_array { size_t k; - scm_bits_t rlen = 1; + unsigned long rlen = 1; scm_array_dim_t *s; SCM ra; @@ -634,7 +614,6 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, while (k--) { s[k].inc = rlen; - SCM_ASSERT_RANGE (1, dims, s[k].inc >= 0); SCM_ASSERT_RANGE (1, dims, s[k].lbnd <= s[k].ubnd); rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc; } @@ -649,7 +628,7 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, scm_array_fill_x (ra, prot); if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra)) - if (s[0].ubnd < s[0].lbnd || (0 == s[0].lbnd && 1 == s[0].inc)) + if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc)) return SCM_ARRAY_V (ra); return ra; } @@ -662,7 +641,7 @@ scm_ra_set_contp (SCM ra) size_t k = SCM_ARRAY_NDIM (ra); if (k) { - scm_bits_t inc = SCM_ARRAY_DIMS (ra)[k - 1].inc; /*??*/ + long inc = SCM_ARRAY_DIMS (ra)[k - 1].inc; while (k--) { if (inc != SCM_ARRAY_DIMS (ra)[k].inc) @@ -700,9 +679,8 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, SCM ra; SCM inds, indptr; SCM imap; - size_t k; - scm_bits_t i; - scm_bits_t old_min, new_min, old_max, new_max; + size_t k, i; + long old_min, new_min, old_max, new_max; scm_array_dim_t *s; SCM_VALIDATE_REST_ARGUMENT (dims); @@ -745,7 +723,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, } imap = scm_apply (mapfunc, scm_reverse (inds), SCM_EOL); if (SCM_ARRAYP (oldra)) - i = scm_aind (oldra, imap, FUNC_NAME); + i = (size_t) scm_aind (oldra, imap, FUNC_NAME); else { if (SCM_NINUMP (imap)) @@ -794,7 +772,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra)) { SCM v = SCM_ARRAY_V (ra); - scm_bits_t length = SCM_INUM (scm_uniform_vector_length (v)); + unsigned long int length = SCM_INUM (scm_uniform_vector_length (v)); if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd) return v; if (s->ubnd < s->lbnd) @@ -1024,9 +1002,9 @@ SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1, #define FUNC_NAME s_scm_array_in_bounds_p { SCM ind = SCM_EOL; - scm_bits_t pos = 0; + long pos = 0; register size_t k; - register scm_bits_t j; + register long j; scm_array_dim_t *s; SCM_VALIDATE_REST_ARGUMENT (args); @@ -1090,7 +1068,7 @@ tail: case scm_tc7_vector: case scm_tc7_wvect: { - scm_bits_t length = SCM_INUM (scm_uniform_vector_length (v)); + unsigned long int length = SCM_INUM (scm_uniform_vector_length (v)); SCM_ASRTGO (SCM_NULLP (args) && SCM_INUMP (ind), wna); return SCM_BOOL(pos >= 0 && pos < length); } @@ -1109,7 +1087,7 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, "@var{array}.") #define FUNC_NAME s_scm_uniform_vector_ref { - scm_bits_t pos; + long pos; if (SCM_IMP (v)) { @@ -1123,7 +1101,7 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, } else { - scm_bits_t length; + unsigned long int length; if (SCM_NIMP (args)) { SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, FUNC_NAME); @@ -1204,7 +1182,7 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, tries to recycle conses. (Make *sure* you want them recycled.) */ SCM -scm_cvref (SCM v, scm_bits_t pos, SCM last) +scm_cvref (SCM v, unsigned long pos, SCM last) #define FUNC_NAME "scm_cvref" { switch SCM_TYP7 (v) @@ -1287,7 +1265,7 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, "@var{new-value}. The value returned by array-set! is unspecified.") #define FUNC_NAME s_scm_array_set_x { - scm_bits_t pos = 0; + long pos = 0; SCM_VALIDATE_REST_ARGUMENT (args); SCM_ASRTGO (SCM_NIMP (v), badarg1); @@ -1298,7 +1276,7 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, } else { - scm_bits_t length; + unsigned long int length; if (SCM_NIMP (args)) { SCM_ASSERT (SCM_CONSP(args) && SCM_INUMP (SCM_CAR (args)), args, @@ -1426,8 +1404,7 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, return ra; case scm_tc7_smob: { - size_t k, ndim = SCM_ARRAY_NDIM (ra); - scm_bits_t len = 1; + size_t k, ndim = SCM_ARRAY_NDIM (ra), len = 1; if (!SCM_ARRAYP (ra) || !SCM_ARRAY_CONTP (ra)) return SCM_BOOL_F; for (k = 0; k < ndim; k++) @@ -1439,15 +1416,15 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, if (scm_tc7_bvect == SCM_TYP7 (SCM_ARRAY_V (ra))) { if (len != SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra)) || - SCM_ARRAY_BASE (ra) % SCM_BITS_LENGTH || - len % SCM_BITS_LENGTH) + SCM_ARRAY_BASE (ra) % SCM_LONG_BIT || + len % SCM_LONG_BIT) return SCM_BOOL_F; } } { SCM v = SCM_ARRAY_V (ra); - scm_bits_t length = SCM_INUM (scm_uniform_vector_length (v)); + unsigned long int length = SCM_INUM (scm_uniform_vector_length (v)); if ((len == length) && 0 == SCM_ARRAY_BASE (ra) && SCM_ARRAY_DIMS (ra)->inc) return v; } @@ -1469,9 +1446,8 @@ SCM scm_ra2contig (SCM ra, int copy) { SCM ret; - scm_bits_t inc = 1; - size_t k; - scm_bits_t len = 1; + long inc = 1; + size_t k, len = 1; for (k = SCM_ARRAY_NDIM (ra); k--;) len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1; k = SCM_ARRAY_NDIM (ra); @@ -1480,8 +1456,8 @@ scm_ra2contig (SCM ra, int copy) if (scm_tc7_bvect != SCM_TYP7 (SCM_ARRAY_V (ra))) return ra; if ((len == SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra)) && - 0 == SCM_ARRAY_BASE (ra) % SCM_BITS_LENGTH && - 0 == len % SCM_BITS_LENGTH)) + 0 == SCM_ARRAY_BASE (ra) % SCM_LONG_BIT && + 0 == len % SCM_LONG_BIT)) return ra; } ret = scm_make_ra (k); @@ -1519,10 +1495,10 @@ SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0, #define FUNC_NAME s_scm_uniform_array_read_x { SCM cra = SCM_UNDEFINED, v = ra; - int sz; - scm_bits_t vlen, ans; - scm_bits_t cstart = 0, cend = 0; - scm_bits_t offset = 0; + long sz, vlen, ans; + long cstart = 0; + long cend; + long offset = 0; char *base; SCM_ASRTGO (SCM_NIMP (v), badarg1); @@ -1553,9 +1529,9 @@ loop: break; case scm_tc7_bvect: base = (char *) SCM_BITVECTOR_BASE (v); - vlen = (vlen + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH; - cstart /= SCM_BITS_LENGTH; - sz = sizeof (scm_bits_t); + vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT; + cstart /= SCM_LONG_BIT; + sz = sizeof (long); break; case scm_tc7_byvect: base = (char *) SCM_UVECTOR_BASE (v); @@ -1594,15 +1570,15 @@ loop: if (!SCM_UNBNDP (start)) { offset = - SCM_NUM2BITS (3, start); + SCM_NUM2LONG (3, start); if (offset < 0 || offset >= cend) scm_out_of_range (FUNC_NAME, start); if (!SCM_UNBNDP (end)) { - scm_bits_t tend = - SCM_NUM2BITS (4, end); + long tend = + SCM_NUM2LONG (4, end); if (tend <= offset || tend > cend) scm_out_of_range (FUNC_NAME, end); @@ -1658,7 +1634,7 @@ loop: SCM_SYSERROR; } if (SCM_TYP7 (v) == scm_tc7_bvect) - ans *= SCM_BITS_LENGTH; + ans *= SCM_LONG_BIT; if (!SCM_EQ_P (v, ra) && !SCM_EQ_P (cra, ra)) scm_array_copy_x (cra, ra); @@ -1681,9 +1657,10 @@ SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0, "@code{(current-output-port)}.") #define FUNC_NAME s_scm_uniform_array_write { - int sz; - scm_bits_t vlen, ans; - scm_bits_t offset = 0, cstart = 0, cend; + long sz, vlen, ans; + long offset = 0; + long cstart = 0; + long cend; char *base; port_or_fd = SCM_COERCE_OUTPORT (port_or_fd); @@ -1716,9 +1693,9 @@ loop: break; case scm_tc7_bvect: base = (char *) SCM_BITVECTOR_BASE (v); - vlen = (vlen + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH; - cstart /= SCM_BITS_LENGTH; - sz = sizeof (scm_bits_t); + vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT; + cstart /= SCM_LONG_BIT; + sz = sizeof (long); break; case scm_tc7_byvect: base = (char *) SCM_UVECTOR_BASE (v); @@ -1757,15 +1734,15 @@ loop: if (!SCM_UNBNDP (start)) { offset = - SCM_NUM2BITS (3, start); + SCM_NUM2LONG (3, start); if (offset < 0 || offset >= cend) scm_out_of_range (FUNC_NAME, start); if (!SCM_UNBNDP (end)) { - scm_bits_t tend = - SCM_NUM2BITS (4, end); + long tend = + SCM_NUM2LONG (4, end); if (tend <= offset || tend > cend) scm_out_of_range (FUNC_NAME, end); @@ -1789,7 +1766,7 @@ loop: SCM_SYSERROR; } if (SCM_TYP7 (v) == scm_tc7_bvect) - ans *= SCM_BITS_LENGTH; + ans *= SCM_LONG_BIT; return SCM_MAKINUM (ans); } @@ -1810,13 +1787,13 @@ SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0, if (SCM_BITVECTOR_LENGTH (bitvector) == 0) { return SCM_INUM0; } else { - scm_bits_t count = 0; - size_t i = (SCM_BITVECTOR_LENGTH (bitvector) - 1) / SCM_BITS_LENGTH; - scm_ubits_t w = SCM_UNPACK (SCM_VELTS (bitvector)[i]); + unsigned long int count = 0; + unsigned long int i = (SCM_BITVECTOR_LENGTH (bitvector) - 1) / SCM_LONG_BIT; + unsigned long int w = SCM_UNPACK (SCM_VELTS (bitvector)[i]); if (SCM_FALSEP (b)) { w = ~w; }; - w <<= SCM_BITS_LENGTH - 1 - ((SCM_BITVECTOR_LENGTH (bitvector) - 1) % SCM_BITS_LENGTH); + w <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (bitvector) - 1) % SCM_LONG_BIT); while (1) { while (w) { count += cnt_tab[w & 0x0f]; @@ -1844,11 +1821,8 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, "within the specified range @code{#f} is returned.") #define FUNC_NAME s_scm_bit_position { - size_t i; - scm_bits_t pos; - size_t lenw; - int xbits; - register scm_ubits_t w; + long i, lenw, xbits, pos; + register unsigned long w; SCM_VALIDATE_BOOL (1, item); SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG2, FUNC_NAME); @@ -1858,15 +1832,15 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, if (pos == SCM_BITVECTOR_LENGTH (v)) return SCM_BOOL_F; - lenw = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_BITS_LENGTH; /* watch for part words */ - i = pos / SCM_BITS_LENGTH; + lenw = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; /* watch for part words */ + i = pos / SCM_LONG_BIT; w = SCM_UNPACK (SCM_VELTS (v)[i]); if (SCM_FALSEP (item)) w = ~w; - xbits = (pos % SCM_BITS_LENGTH); + xbits = (pos % SCM_LONG_BIT); pos -= xbits; w = ((w >> xbits) << xbits); - xbits = SCM_BITS_LENGTH - 1 - (SCM_BITVECTOR_LENGTH (v) - 1) % SCM_BITS_LENGTH; + xbits = SCM_LONG_BIT - 1 - (SCM_BITVECTOR_LENGTH (v) - 1) % SCM_LONG_BIT; while (!0) { if (w && (i == lenw)) @@ -1893,7 +1867,7 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, } if (++i > lenw) break; - pos += SCM_BITS_LENGTH; + pos += SCM_LONG_BIT; w = SCM_UNPACK (SCM_VELTS (v)[i]); if (SCM_FALSEP (item)) w = ~w; @@ -1915,8 +1889,7 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, "@var{bool}. The return value is unspecified.") #define FUNC_NAME s_scm_bit_set_star_x { - register size_t i; - scm_bits_t vlen; + register long i, k, vlen; SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME); SCM_ASRTGO (SCM_NIMP (kv), badarg2); switch SCM_TYP7 (kv) @@ -1924,13 +1897,11 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, default: badarg2:SCM_WRONG_TYPE_ARG (2, kv); case scm_tc7_uvect: - { - unsigned long k; vlen = SCM_BITVECTOR_LENGTH (v); if (SCM_FALSEP (obj)) for (i = SCM_UVECTOR_LENGTH (kv); i;) { - k = ((unsigned long *) SCM_VELTS (kv))[--i]; + k = SCM_UNPACK (SCM_VELTS (kv)[--i]); if (k >= vlen) scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k)); SCM_BITVEC_CLR(v,k); @@ -1938,7 +1909,7 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, else if (SCM_EQ_P (obj, SCM_BOOL_T)) for (i = SCM_UVECTOR_LENGTH (kv); i;) { - k = ((unsigned long *) SCM_VELTS (kv))[--i]; + k = SCM_UNPACK (SCM_VELTS (kv)[--i]); if (k >= vlen) scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k)); SCM_BITVEC_SET(v,k); @@ -1946,22 +1917,18 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, else badarg3:SCM_WRONG_TYPE_ARG (3, obj); break; - } case scm_tc7_bvect: - { - scm_ubits_t k; SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME); if (SCM_FALSEP (obj)) - for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH; k--;) - ((scm_ubits_t *) SCM_VELTS (v))[k] &= ~ ((scm_ubits_t *) SCM_VELTS (kv))[k]; + for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) + SCM_UNPACK (SCM_VELTS (v)[k]) &= ~ SCM_UNPACK(SCM_VELTS (kv)[k]); else if (SCM_EQ_P (obj, SCM_BOOL_T)) - for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH; k--;) - ((scm_ubits_t *) SCM_VELTS (v))[k] |= ((scm_ubits_t *) SCM_VELTS (kv))[k]; + for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) + SCM_UNPACK (SCM_VELTS (v)[k]) |= SCM_UNPACK (SCM_VELTS (kv)[k]); else goto badarg3; break; } - } return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -1976,8 +1943,8 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, "@var{bv} is not modified.") #define FUNC_NAME s_scm_bit_count_star { - register size_t i; - scm_bits_t vlen, count = 0; + register long i, vlen, count = 0; + register unsigned long k; int fObj = 0; SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME); @@ -1988,13 +1955,11 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, badarg2: SCM_WRONG_TYPE_ARG (2, kv); case scm_tc7_uvect: - { - unsigned long k; vlen = SCM_BITVECTOR_LENGTH (v); if (SCM_FALSEP (obj)) for (i = SCM_UVECTOR_LENGTH (kv); i;) { - k = ((unsigned long *) SCM_VELTS (kv))[--i]; + k = SCM_UNPACK (SCM_VELTS (kv)[--i]); if (k >= vlen) scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k)); if (!SCM_BITVEC_REF(v,k)) @@ -2003,7 +1968,7 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, else if (SCM_EQ_P (obj, SCM_BOOL_T)) for (i = SCM_UVECTOR_LENGTH (kv); i;) { - k = ((unsigned long *) SCM_VELTS (kv))[--i]; + k = SCM_UNPACK (SCM_VELTS (kv)[--i]); if (k >= vlen) scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k)); if (SCM_BITVEC_REF (v,k)) @@ -2012,20 +1977,15 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, else badarg3:SCM_WRONG_TYPE_ARG (3, obj); break; - } case scm_tc7_bvect: - { - scm_ubits_t k; SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME); if (0 == SCM_BITVECTOR_LENGTH (v)) return SCM_INUM0; SCM_ASRTGO (SCM_BOOLP (obj), badarg3); fObj = SCM_EQ_P (obj, SCM_BOOL_T); - i = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_BITS_LENGTH; - k = - ((scm_ubits_t *) SCM_VELTS (kv))[i] - & (fObj ? ((scm_ubits_t *) SCM_VELTS (v))[i] : ~ ((scm_ubits_t *) SCM_VELTS (v))[i]); - k <<= SCM_BITS_LENGTH - 1 - ((SCM_BITVECTOR_LENGTH (v) - 1) % SCM_BITS_LENGTH); + i = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; + k = SCM_UNPACK (SCM_VELTS (kv)[i]) & (fObj ? SCM_UNPACK (SCM_VELTS (v)[i]) : ~ SCM_UNPACK (SCM_VELTS (v)[i])); + k <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (v) - 1) % SCM_LONG_BIT); while (1) { for (; k; k >>= 4) @@ -2034,10 +1994,7 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, return SCM_MAKINUM (count); /* urg. repetitive (see above.) */ - k = - ((scm_ubits_t *) SCM_VELTS (kv))[i] - & (fObj ? ((scm_ubits_t *) SCM_VELTS (v))[i] : ~ ((scm_ubits_t *) SCM_VELTS (v))[i]); - } + k = SCM_UNPACK (SCM_VELTS (kv)[i]) & (fObj ? SCM_UNPACK(SCM_VELTS (v)[i]) : ~SCM_UNPACK (SCM_VELTS (v)[i])); } } return SCM_MAKINUM (count); @@ -2050,13 +2007,13 @@ SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0, "Modifies @var{bv} by replacing each element with its negation.") #define FUNC_NAME s_scm_bit_invert_x { - scm_bits_t k; + long int k; SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME); k = SCM_BITVECTOR_LENGTH (v); - for (k = (k + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH; k--;) - ((scm_ubits_t *) SCM_VELTS (v))[k] = ~((scm_ubits_t *) SCM_VELTS (v))[k]; + for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) + SCM_UNPACK (SCM_VELTS (v)[k]) = ~SCM_UNPACK (SCM_VELTS (v)[k]); return SCM_UNSPECIFIED; } @@ -2064,19 +2021,19 @@ SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0, SCM -scm_istr2bve (char *str, scm_bits_t len) +scm_istr2bve (char *str, long len) { SCM v = scm_make_uve (len, SCM_BOOL_T); - scm_ubits_t *data = (scm_ubits_t *) SCM_VELTS (v); - register scm_bits_t mask; - register size_t k; - register int j; - for (k = 0; k < (len + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH; k++) + long *data = (long *) SCM_VELTS (v); + register unsigned long mask; + register long k; + register long j; + for (k = 0; k < (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k++) { data[k] = 0L; - j = len - k * SCM_BITS_LENGTH; - if (j > SCM_BITS_LENGTH) - j = SCM_BITS_LENGTH; + j = len - k * SCM_LONG_BIT; + if (j > SCM_LONG_BIT) + j = SCM_LONG_BIT; for (mask = 1L; j--; mask <<= 1) switch (*str++) { @@ -2095,11 +2052,11 @@ scm_istr2bve (char *str, scm_bits_t len) static SCM -ra2l (SCM ra, scm_bits_t base, size_t k) +ra2l (SCM ra,unsigned long base,unsigned long k) { register SCM res = SCM_EOL; - register scm_bits_t inc = SCM_ARRAY_DIMS (ra)[k].inc; - register scm_bits_t i; + register long inc = SCM_ARRAY_DIMS (ra)[k].inc; + register size_t i; if (SCM_ARRAY_DIMS (ra)[k].ubnd < SCM_ARRAY_DIMS (ra)[k].lbnd) return SCM_EOL; i = base + (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd) * inc; @@ -2130,7 +2087,7 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, #define FUNC_NAME s_scm_array_to_list { SCM res = SCM_EOL; - register size_t k; + register long k; SCM_ASRTGO (SCM_NIMP (v), badarg1); switch SCM_TYP7 (v) { @@ -2146,35 +2103,35 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, return scm_string_to_list (v); case scm_tc7_bvect: { - scm_ubits_t *data = (scm_ubits_t *) SCM_VELTS (v); - register scm_ubits_t mask; - for (k = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_BITS_LENGTH; k > 0; k--) - for (mask = 1UL << (SCM_BITS_LENGTH - 1); mask; mask >>= 1) - res = scm_cons (SCM_BOOL(data[k] & mask), res); - for (mask = 1L << ((SCM_BITVECTOR_LENGTH (v) % SCM_BITS_LENGTH) - 1); mask; mask >>= 1) - res = scm_cons (SCM_BOOL(data[k] & mask), res); + long *data = (long *) SCM_VELTS (v); + register unsigned long mask; + for (k = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; k > 0; k--) + for (mask = 1UL << (SCM_LONG_BIT - 1); mask; mask >>= 1) + res = scm_cons (SCM_BOOL(((long *) data)[k] & mask), res); + for (mask = 1L << ((SCM_BITVECTOR_LENGTH (v) % SCM_LONG_BIT) - 1); mask; mask >>= 1) + res = scm_cons (SCM_BOOL(((long *) data)[k] & mask), res); return res; } case scm_tc7_byvect: { signed char *data = (signed char *) SCM_VELTS (v); - scm_bits_t k = SCM_UVECTOR_LENGTH (v); + unsigned long k = SCM_UVECTOR_LENGTH (v); while (k != 0) res = scm_cons (SCM_MAKINUM (data[--k]), res); return res; } case scm_tc7_uvect: { - scm_ubits_t *data = (scm_ubits_t *) SCM_VELTS(v); + long *data = (long *)SCM_VELTS(v); for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--) - res = scm_cons(scm_ubits2num(data[k]), res); + res = scm_cons(scm_ulong2num(data[k]), res); return res; } case scm_tc7_ivect: { - scm_bits_t *data = (scm_bits_t *) SCM_VELTS(v); + long *data = (long *)SCM_VELTS(v); for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--) - res = scm_cons(scm_bits2num(data[k]), res); + res = scm_cons(scm_long2num(data[k]), res); return res; } case scm_tc7_svect: @@ -2219,7 +2176,7 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, #undef FUNC_NAME -static int l2ra (SCM lst, SCM ra, scm_bits_t base, size_t k); +static int l2ra(SCM lst, SCM ra, unsigned long base, unsigned long k); SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, (SCM ndim, SCM prot, SCM lst), @@ -2233,7 +2190,7 @@ SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, SCM shp = SCM_EOL; SCM row = lst; SCM ra; - scm_bits_t k; + unsigned long k; long n; SCM_VALIDATE_INUM_COPY (1,ndim,k); while (k--) @@ -2254,7 +2211,7 @@ SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, } if (!SCM_ARRAYP (ra)) { - scm_bits_t length = SCM_INUM (scm_uniform_vector_length (ra)); + unsigned long int length = SCM_INUM (scm_uniform_vector_length (ra)); for (k = 0; k < length; k++, lst = SCM_CDR (lst)) scm_array_set_x (ra, SCM_CAR (lst), SCM_MAKINUM (k)); return ra; @@ -2267,10 +2224,10 @@ SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, #undef FUNC_NAME static int -l2ra (SCM lst, SCM ra, scm_bits_t base, size_t k) +l2ra (SCM lst, SCM ra, unsigned long base, unsigned long k) { - register scm_bits_t inc = SCM_ARRAY_DIMS (ra)[k].inc; - register scm_bits_t n = (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd); + register long inc = SCM_ARRAY_DIMS (ra)[k].inc; + register long n = (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd); int ok = 1; if (n <= 0) return (SCM_NULLP (lst)); @@ -2305,10 +2262,10 @@ l2ra (SCM lst, SCM ra, scm_bits_t base, size_t k) static void -rapr1 (SCM ra, scm_bits_t j, size_t k, SCM port, scm_print_state *pstate) +rapr1 (SCM ra,unsigned long j,unsigned long k,SCM port,scm_print_state *pstate) { - scm_bits_t inc = 1; - scm_bits_t n = (SCM_TYP7 (ra) == scm_tc7_smob + long inc = 1; + long n = (SCM_TYP7 (ra) == scm_tc7_smob ? 0 : SCM_INUM (scm_uniform_vector_length (ra))); int enclosed = 0; @@ -2331,7 +2288,7 @@ tail: } if (k + 1 < SCM_ARRAY_NDIM (ra)) { - scm_bits_t i; + long i; inc = SCM_ARRAY_DIMS (ra)[k].inc; for (i = SCM_ARRAY_DIMS (ra)[k].lbnd; i < SCM_ARRAY_DIMS (ra)[k].ubnd; i++) { @@ -2484,7 +2441,7 @@ int scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate) { SCM v = exp; - scm_bits_t base = 0; + unsigned long base = 0; scm_putc ('#', port); tail: switch SCM_TYP7 (v) @@ -2511,23 +2468,21 @@ tail: case scm_tc7_bvect: if (SCM_EQ_P (exp, v)) { /* a uve, not an scm_array */ - register size_t i; - register int j; - scm_ubits_t w; + register long i, j, w; scm_putc ('*', port); - for (i = 0; i < (SCM_BITVECTOR_LENGTH (exp) / SCM_BITS_LENGTH); i++) + for (i = 0; i < (SCM_BITVECTOR_LENGTH (exp)) / SCM_LONG_BIT; i++) { - w = SCM_UNPACK (SCM_VELTS (exp)[i]); - for (j = SCM_BITS_LENGTH; j; j--) + scm_bits_t w = SCM_UNPACK (SCM_VELTS (exp)[i]); + for (j = SCM_LONG_BIT; j; j--) { scm_putc (w & 1 ? '1' : '0', port); w >>= 1; } } - j = SCM_BITVECTOR_LENGTH (exp) % SCM_BITS_LENGTH; + j = SCM_BITVECTOR_LENGTH (exp) % SCM_LONG_BIT; if (j) { - w = SCM_UNPACK (SCM_VELTS (exp)[SCM_BITVECTOR_LENGTH (exp) / SCM_BITS_LENGTH]); + w = SCM_UNPACK (SCM_VELTS (exp)[SCM_BITVECTOR_LENGTH (exp) / SCM_LONG_BIT]); for (; j; j--) { scm_putc (w & 1 ? '1' : '0', port); diff --git a/libguile/unif.h b/libguile/unif.h index 3da009a12..1a7b1b46f 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -64,14 +64,14 @@ typedef struct scm_array_t { SCM v; /* the contents of the array, e.g., a vector or uniform vector. */ - scm_bits_t base; + unsigned long base; } scm_array_t; typedef struct scm_array_dim_t { - scm_bits_t lbnd; - scm_bits_t ubnd; - scm_bits_t inc; + long lbnd; + long ubnd; + long inc; } scm_array_dim_t; #if (SCM_DEBUG_DEPRECATED == 0) @@ -88,7 +88,7 @@ extern scm_bits_t scm_tc16_array; #endif #define SCM_ARRAYP(a) SCM_TYP16_PREDICATE (scm_tc16_array, a) -#define SCM_ARRAY_NDIM(x) ((size_t) ((scm_ubits_t) (SCM_CELL_WORD_0 (x)) >> 17)) +#define SCM_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x)) >> 17) #define SCM_ARRAY_CONTP(x) (SCM_CELL_WORD_0 (x) & SCM_ARRAY_FLAG_CONTIGUOUS) #define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \ (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | SCM_ARRAY_FLAG_CONTIGUOUS)) @@ -100,25 +100,25 @@ extern scm_bits_t scm_tc16_array; #define SCM_ARRAY_BASE(a) (SCM_ARRAY_MEM (a)->base) #define SCM_ARRAY_DIMS(a) ((scm_array_dim_t *)((char *) SCM_ARRAY_MEM (a) + sizeof (scm_array_t))) -#define SCM_I_MAX_LENGTH ((scm_ubits_t)((scm_bits_t)-1) >> 8) +#define SCM_I_MAX_LENGTH ((unsigned long) (-1L) >> 8) #define SCM_UVECTOR_BASE(x) ((void *) (SCM_CELL_WORD_1 (x))) #define SCM_SET_UVECTOR_BASE(v, b) (SCM_SET_CELL_WORD_1 ((v), (b))) #define SCM_UVECTOR_MAX_LENGTH SCM_I_MAX_LENGTH -#define SCM_UVECTOR_LENGTH(x) (((scm_ubits_t) SCM_CELL_WORD_0 (x)) >> 8) +#define SCM_UVECTOR_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_SET_UVECTOR_LENGTH(v, l, t) (SCM_SET_CELL_WORD_0 ((v), ((l) << 8) + (t))) #define SCM_BITVECTOR_P(x) (!SCM_IMP (x) && (SCM_TYP7 (x) == scm_tc7_bvect)) #define SCM_BITVECTOR_BASE(x) ((void *) (SCM_CELL_WORD_1 (x))) #define SCM_SET_BITVECTOR_BASE(v, b) (SCM_SET_CELL_WORD_1 ((v), (b))) #define SCM_BITVECTOR_MAX_LENGTH SCM_I_MAX_LENGTH -#define SCM_BITVECTOR_LENGTH(x) (((scm_ubits_t) SCM_CELL_WORD_0 (x)) >> 8) +#define SCM_BITVECTOR_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_SET_BITVECTOR_LENGTH(v, l) (SCM_SET_CELL_WORD_0 ((v), ((l) << 8) + scm_tc7_bvect)) extern size_t scm_uniform_element_size (SCM obj); -extern SCM scm_make_uve (scm_bits_t k, SCM prot); +extern SCM scm_make_uve (long k, SCM prot); extern SCM scm_uniform_vector_length (SCM v); extern SCM scm_array_p (SCM v, SCM prot); extern SCM scm_array_rank (SCM ra); @@ -126,7 +126,7 @@ extern SCM scm_array_dimensions (SCM ra); extern SCM scm_shared_array_root (SCM ra); extern SCM scm_shared_array_offset (SCM ra); extern SCM scm_shared_array_increments (SCM ra); -extern scm_bits_t scm_aind (SCM ra, SCM args, const char *what); +extern long scm_aind (SCM ra, SCM args, const char *what); extern SCM scm_make_ra (int ndim); extern SCM scm_shap2ra (SCM args, const char *what); extern SCM scm_dimensions_to_uniform_array (SCM dims, SCM prot, SCM fill); @@ -136,7 +136,7 @@ extern SCM scm_transpose_array (SCM ra, SCM args); extern SCM scm_enclose_array (SCM ra, SCM axes); extern SCM scm_array_in_bounds_p (SCM v, SCM args); extern SCM scm_uniform_vector_ref (SCM v, SCM args); -extern SCM scm_cvref (SCM v, scm_bits_t pos, SCM last); +extern SCM scm_cvref (SCM v, unsigned long pos, SCM last); extern SCM scm_array_set_x (SCM v, SCM obj, SCM args); extern SCM scm_array_contents (SCM ra, SCM strict); extern SCM scm_ra2contig (SCM ra, int copy); @@ -147,7 +147,7 @@ extern SCM scm_bit_position (SCM item, SCM v, SCM k); extern SCM scm_bit_set_star_x (SCM v, SCM kv, SCM obj); extern SCM scm_bit_count_star (SCM v, SCM kv, SCM obj); extern SCM scm_bit_invert_x (SCM v); -extern SCM scm_istr2bve (char *str, scm_bits_t len); +extern SCM scm_istr2bve (char *str, long len); extern SCM scm_array_to_list (SCM v); extern SCM scm_list_to_uniform_array (SCM ndim, SCM prot, SCM lst); extern int scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate); diff --git a/libguile/validate.h b/libguile/validate.h index cc8df1561..5f152138c 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -1,4 +1,4 @@ -/* $Id: validate.h,v 1.32 2001-05-24 00:50:51 cmm Exp $ */ +/* $Id: validate.h,v 1.33 2001-05-26 20:51:22 cmm Exp $ */ /* Copyright (C) 1999,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify @@ -81,16 +81,6 @@ #define SCM_NUM2USHORT_DEF(pos, arg, def) \ (SCM_UNBNDP (arg) ? def : scm_num2ushort (arg, pos, FUNC_NAME)) -#define SCM_NUM2BITS(pos, arg) (scm_num2bits (arg, pos, FUNC_NAME)) - -#define SCM_NUM2BITS_DEF(pos, arg, def) \ - (SCM_UNBNDP (arg) ? def : scm_num2bits (arg, pos, FUNC_NAME)) - -#define SCM_NUM2UBITS(pos, arg) (scm_num2ubits (arg, pos, FUNC_NAME)) - -#define SCM_NUM2UBITS_DEF(pos, arg, def) \ - (SCM_UNBNDP (arg) ? def : scm_num2ubits (arg, pos, FUNC_NAME)) - #define SCM_NUM2INT(pos, arg) (scm_num2int (arg, pos, FUNC_NAME)) #define SCM_NUM2INT_DEF(pos, arg, def) \ diff --git a/libguile/values.c b/libguile/values.c index 2fbfaaae9..5aad29a89 100644 --- a/libguile/values.c +++ b/libguile/values.c @@ -77,7 +77,7 @@ SCM_DEFINE (scm_values, "values", 0, 0, 1, "were not created by @code{call-with-values} is unspecified.") #define FUNC_NAME s_scm_values { - scm_bits_t n; + long n; SCM result; SCM_VALIDATE_LIST_COPYLEN (1, args, n); diff --git a/libguile/vectors.c b/libguile/vectors.c index d6d5a7867..4407d57d8 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -73,7 +73,7 @@ static char s_vector_set_length_x[] = "vector-set-length!"; SCM scm_vector_set_length_x (SCM vect, SCM len) { - scm_bits_t l; + long l; size_t siz; size_t sz; char *base; @@ -84,7 +84,7 @@ scm_vector_set_length_x (SCM vect, SCM len) #ifdef HAVE_ARRAYS if (SCM_TYP7 (vect) == scm_tc7_bvect) { - l = (l + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH; + l = (l + SCM_LONG_BIT - 1) / SCM_LONG_BIT; } sz = scm_uniform_element_size (vect); if (sz != 0) @@ -180,7 +180,7 @@ SCM_DEFINE (scm_vector, "vector", 0, 0, 1, { SCM res; SCM *data; - scm_bits_t i; + long i; /* Dirk:FIXME:: In case of multiple threads, the list might get corrupted while the vector is being created. */ @@ -222,7 +222,7 @@ scm_vector_ref (SCM v, SCM k) SCM_GASSERT2 (SCM_INUMP (k), g_vector_ref, v, k, SCM_ARG2, s_vector_ref); SCM_ASSERT_RANGE (2, k, SCM_INUM (k) < SCM_VECTOR_LENGTH (v) && SCM_INUM (k) >= 0); - return SCM_VELTS (v)[(ptrdiff_t) SCM_INUM (k)]; + return SCM_VELTS (v)[(long) SCM_INUM (k)]; } #undef FUNC_NAME @@ -250,7 +250,7 @@ scm_vector_set_x (SCM v, SCM k, SCM obj) g_vector_set_x, SCM_LIST3 (v, k, obj), SCM_ARG2, s_vector_set_x); SCM_ASSERT_RANGE (2, k, SCM_INUM (k) < SCM_VECTOR_LENGTH (v) && SCM_INUM (k) >= 0); - SCM_VELTS(v)[(ptrdiff_t) SCM_INUM(k)] = obj; + SCM_VELTS(v)[(long) SCM_INUM(k)] = obj; return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -281,7 +281,7 @@ SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0, SCM -scm_c_make_vector (size_t k, SCM fill) +scm_c_make_vector (unsigned long int k, SCM fill) #define FUNC_NAME s_scm_make_vector { SCM v; @@ -289,9 +289,9 @@ scm_c_make_vector (size_t k, SCM fill) if (k > 0) { - size_t j; + unsigned long int j; - SCM_ASSERT_RANGE (1, scm_size2num (k), k <= SCM_VECTOR_MAX_LENGTH); + SCM_ASSERT_RANGE (1, scm_ulong2num (k), k <= SCM_VECTOR_MAX_LENGTH); base = scm_must_malloc (k * sizeof (scm_bits_t), FUNC_NAME); for (j = 0; j != k; ++j) @@ -322,7 +322,7 @@ SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0, #define FUNC_NAME s_scm_vector_to_list { SCM res = SCM_EOL; - scm_bits_t i; + long i; SCM *data; SCM_VALIDATE_VECTOR (1,v); data = SCM_VELTS(v); @@ -338,7 +338,7 @@ SCM_DEFINE (scm_vector_fill_x, "vector-fill!", 2, 0, 0, "returned by @code{vector-fill!} is unspecified.") #define FUNC_NAME s_scm_vector_fill_x { - register scm_bits_t i; + register long i; register SCM *data; SCM_VALIDATE_VECTOR (1, v); data = SCM_VELTS (v); @@ -352,7 +352,7 @@ SCM_DEFINE (scm_vector_fill_x, "vector-fill!", 2, 0, 0, SCM scm_vector_equal_p(SCM x, SCM y) { - scm_bits_t i; + long i; for(i = SCM_VECTOR_LENGTH (x) - 1; i >= 0; i--) if (SCM_FALSEP (scm_equal_p (SCM_VELTS (x)[i], SCM_VELTS (y)[i]))) return SCM_BOOL_F; @@ -365,9 +365,9 @@ SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0, "Vector version of @code{substring-move-left!}.") #define FUNC_NAME s_scm_vector_move_left_x { - scm_bits_t i; - scm_bits_t j; - scm_bits_t e; + long i; + long j; + long e; SCM_VALIDATE_VECTOR (1,vec1); SCM_VALIDATE_INUM_COPY (2,start1,i); @@ -388,9 +388,9 @@ SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0, "Vector version of @code{substring-move-right!}.") #define FUNC_NAME s_scm_vector_move_right_x { - scm_bits_t i; - scm_bits_t j; - scm_bits_t e; + long i; + long j; + long e; SCM_VALIDATE_VECTOR (1,vec1); SCM_VALIDATE_INUM_COPY (2,start1,i); diff --git a/libguile/vectors.h b/libguile/vectors.h index 7058dcac2..77d6131bf 100644 --- a/libguile/vectors.h +++ b/libguile/vectors.h @@ -55,7 +55,7 @@ #define SCM_VECTOR_BASE(x) ((scm_bits_t *) SCM_CELL_WORD_1 (x)) #define SCM_SET_VECTOR_BASE(v, b) (SCM_SET_CELL_WORD_1 ((v), (b))) #define SCM_VECTOR_MAX_LENGTH ((1L << 24) - 1) -#define SCM_VECTOR_LENGTH(x) (((scm_ubits_t) SCM_CELL_WORD_0 (x)) >> 8) +#define SCM_VECTOR_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) #define SCM_SET_VECTOR_LENGTH(v, l, t) (SCM_SET_CELL_WORD_0 ((v), ((l) << 8) + (t))) #define SCM_VELTS(x) ((SCM *) SCM_CELL_WORD_1 (x)) @@ -67,14 +67,14 @@ /* bit vectors */ -#define SCM_BITVEC_REF(a, i) ((SCM_UNPACK(SCM_VELTS(a)[(i)/SCM_BITS_LENGTH]) & (1L<<((i)%SCM_BITS_LENGTH))) ? 1 : 0) -#define SCM_BITVEC_SET(a, i) SCM_UNPACK(SCM_VELTS(a)[(i)/SCM_BITS_LENGTH]) |= (1L<<((i)%SCM_BITS_LENGTH)) -#define SCM_BITVEC_CLR(a, i) SCM_UNPACK(SCM_VELTS(a)[(i)/SCM_BITS_LENGTH]) &= ~(1L<<((i)%SCM_BITS_LENGTH)) +#define SCM_BITVEC_REF(a, i) ((SCM_UNPACK(SCM_VELTS(a)[(i)/SCM_LONG_BIT]) & (1L<<((i)%SCM_LONG_BIT))) ? 1 : 0) +#define SCM_BITVEC_SET(a, i) SCM_UNPACK(SCM_VELTS(a)[(i)/SCM_LONG_BIT]) |= (1L<<((i)%SCM_LONG_BIT)) +#define SCM_BITVEC_CLR(a, i) SCM_UNPACK(SCM_VELTS(a)[(i)/SCM_LONG_BIT]) &= ~(1L<<((i)%SCM_LONG_BIT)) -extern SCM scm_c_make_vector (size_t k, SCM fill); +extern SCM scm_c_make_vector (unsigned long int k, SCM fill); extern SCM scm_vector_p (SCM x); extern SCM scm_vector_length (SCM v); diff --git a/libguile/weaks.c b/libguile/weaks.c index 1432ae264..4bfe975a0 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -90,7 +90,7 @@ SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1, { SCM res; SCM *data; - scm_bits_t i; + long i; /* Dirk:FIXME:: In case of multiple threads, the list might get corrupted while the vector is being created. */ @@ -235,7 +235,8 @@ scm_mark_weak_vector_spines (void *dummy1, void *dummy2, void *dummy3) { SCM *ptr; SCM obj; - scm_bits_t j, n; + long j; + long n; obj = w; ptr = SCM_VELTS (w); @@ -279,8 +280,8 @@ scm_scan_weak_vectors (void *dummy1, void *dummy2, void *dummy3) else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */ { SCM obj = w; - register scm_bits_t n = SCM_VECTOR_LENGTH (w); - register scm_bits_t j; + register long n = SCM_VECTOR_LENGTH (w); + register long j; int weak_keys = SCM_IS_WHVEC (obj) || SCM_IS_WHVEC_B (obj); int weak_values = SCM_IS_WHVEC_V (obj) || SCM_IS_WHVEC_B (obj); From 6b1b030e4de34568273e87176d3eb93eddf81c7f Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Sat, 26 May 2001 22:10:58 +0000 Subject: [PATCH 1192/2047] * gc.c (scm_init_storage): init `scm_gc_registered_roots'. (scm_igc): mark from them, too (precisely, not conservatively!). * root.h (scm_gc_registered_roots): new object in scm_sys_protects. * hooks.c (scm_create_hook): call `scm_gc_protect_object' instead `scm_protect_object'. shouldn't call it at all, though, it seems. * gc.c (scm_[un]protect_object): deprecated. (scm_gc_[un]protect_object): new names for scm_[un]protect_object. (scm_gc_[un]register_root[s]): new. * gc.h: add prototypes for scm_gc_[un]protect_object, scm_gc_[un]register_root[s]. --- libguile/ChangeLog | 18 +++++++++ libguile/gc.c | 98 +++++++++++++++++++++++++++++++++++++++++++--- libguile/gc.h | 11 +++++- libguile/hooks.c | 2 +- libguile/root.h | 7 ++-- 5 files changed, 125 insertions(+), 11 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 0e432309d..07474e65d 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,21 @@ +2001-05-27 Michael Livshin + + * gc.c (scm_init_storage): init `scm_gc_registered_roots'. + (scm_igc): mark from them, too (precisely, not conservatively!). + + * root.h (scm_gc_registered_roots): new object in + scm_sys_protects. + + * hooks.c (scm_create_hook): call `scm_gc_protect_object' instead + `scm_protect_object'. shouldn't call it at all, though, it seems. + + * gc.c (scm_[un]protect_object): deprecated. + (scm_gc_[un]protect_object): new names for scm_[un]protect_object. + (scm_gc_[un]register_root[s]): new. + + * gc.h: add prototypes for scm_gc_[un]protect_object, + scm_gc_[un]register_root[s]. + 2001-05-26 Michael Livshin revert the controversial part of the 2001-05-24 changes. diff --git a/libguile/gc.c b/libguile/gc.c index 2069a1628..750ef4969 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1063,7 +1063,7 @@ scm_igc (const char *what) / sizeof (SCM_STACKITEM))); { - size_t stack_len = scm_stack_size (scm_stack_base); + unsigned long stack_len = scm_stack_size (scm_stack_base); #ifdef SCM_STACK_GROWS_UP scm_mark_locations (scm_stack_base, stack_len); #else @@ -1082,6 +1082,18 @@ scm_igc (const char *what) while (j--) scm_gc_mark (scm_sys_protects[j]); + /* mark the registered roots */ + { + long i; + for (i = 0; i < SCM_VECTOR_LENGTH (scm_gc_registered_roots); ++i) { + SCM l = SCM_VELTS (scm_gc_registered_roots)[i]; + for (; ! SCM_NULLP (l); l = SCM_CDR (l)) { + SCM *p = (SCM *) (scm_num2long (SCM_CAAR (l), 0, NULL)); + scm_gc_mark (*p); + } + } + } + /* FIXME: we should have a means to register C functions to be run * in different phases of GC */ @@ -2464,6 +2476,22 @@ scm_remember (SCM *ptr) "Use the `scm_remember_upto_here*' family of functions instead."); } +SCM +scm_protect_object (SCM obj) +{ + scm_c_issue_deprecation_warning ("`scm_protect_object' is deprecated. " + "Use `scm_gc_protect_object' instead."); + return scm_gc_protect_object (obj); +} + +SCM +scm_unprotect_object (SCM obj) +{ + scm_c_issue_deprecation_warning ("`scm_unprotect_object' is deprecated. " + "Use `scm_gc_unprotect_object' instead."); + return scm_gc_unprotect_object (obj); +} + #endif /* SCM_DEBUG_DEPRECATED == 0 */ /* @@ -2499,7 +2527,7 @@ scm_permanent_object (SCM obj) /* Protect OBJ from the garbage collector. OBJ will not be freed, even if all other references are dropped, until the object is unprotected by calling - scm_unprotect_object (OBJ). Calls to scm_protect/unprotect_object nest, + scm_gc_unprotect_object (OBJ). Calls to scm_gc_protect/unprotect_object nest, i. e. it is possible to protect the same object several times, but it is necessary to unprotect the object the same number of times to actually get the object unprotected. It is an error to unprotect an object more often @@ -2508,11 +2536,11 @@ scm_permanent_object (SCM obj) */ /* Implementation note: For every object X, there is a counter which - scm_protect_object(X) increments and scm_unprotect_object(X) decrements. + scm_gc_protect_object(X) increments and scm_gc_unprotect_object(X) decrements. */ SCM -scm_protect_object (SCM obj) +scm_gc_protect_object (SCM obj) { SCM handle; @@ -2533,7 +2561,7 @@ scm_protect_object (SCM obj) See scm_protect_object for more information. */ SCM -scm_unprotect_object (SCM obj) +scm_gc_unprotect_object (SCM obj) { SCM handle; @@ -2561,6 +2589,65 @@ scm_unprotect_object (SCM obj) return obj; } +void +scm_gc_register_root (SCM *p) +{ + SCM handle; + SCM key = scm_long2num ((long) p); + + /* This critical section barrier will be replaced by a mutex. */ + SCM_REDEFER_INTS; + + handle = scm_hashv_create_handle_x (scm_gc_registered_roots, key, SCM_MAKINUM (0)); + SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), SCM_MAKINUM (1))); + + SCM_REALLOW_INTS; +} + +void +scm_gc_unregister_root (SCM *p) +{ + SCM handle; + SCM key = scm_long2num ((long) p); + + /* This critical section barrier will be replaced by a mutex. */ + SCM_REDEFER_INTS; + + handle = scm_hashv_get_handle (scm_gc_registered_roots, key); + + if (SCM_FALSEP (handle)) + { + fprintf (stderr, "scm_gc_unregister_root called on unregistered root\n"); + abort (); + } + else + { + SCM count = scm_difference (SCM_CDR (handle), SCM_MAKINUM (1)); + if (SCM_EQ_P (count, SCM_MAKINUM (0))) + scm_hashv_remove_x (scm_gc_registered_roots, key); + else + SCM_SETCDR (handle, count); + } + + SCM_REALLOW_INTS; +} + +void +scm_gc_register_roots (SCM *b, unsigned long n) +{ + SCM *p = b; + for (; p < b + n; ++p) + scm_gc_register_root (p); +} + +void +scm_gc_unregister_roots (SCM *b, unsigned long n) +{ + SCM *p = b; + for (; p < b + n; ++p) + scm_gc_unregister_root (p); +} + int terminating; /* called on process termination. */ @@ -2712,6 +2799,7 @@ scm_init_storage () scm_stand_in_procs = SCM_EOL; scm_permobjs = SCM_EOL; scm_protects = scm_c_make_hash_table (31); + scm_gc_registered_roots = scm_c_make_hash_table (31); return 0; } diff --git a/libguile/gc.h b/libguile/gc.h index a7631c3f7..9b4214325 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -381,8 +381,12 @@ extern void scm_remember_upto_here (SCM obj1, ...); extern SCM scm_return_first (SCM elt, ...); extern int scm_return_first_int (int x, ...); extern SCM scm_permanent_object (SCM obj); -extern SCM scm_protect_object (SCM obj); -extern SCM scm_unprotect_object (SCM obj); +extern SCM scm_gc_protect_object (SCM obj); +extern SCM scm_gc_unprotect_object (SCM obj); +extern void scm_gc_register_root (SCM *p); +extern void scm_gc_unregister_root (SCM *p); +extern void scm_gc_register_roots (SCM *b, unsigned long n); +extern void scm_gc_unregister_roots (SCM *b, unsigned long n); extern int scm_init_storage (void); extern void *scm_get_stack_base (void); extern void scm_init_gc (void); @@ -391,6 +395,9 @@ extern void scm_init_gc (void); #if (SCM_DEBUG_DEPRECATED == 0) +extern SCM scm_protect_object (SCM obj); +extern SCM scm_unprotect_object (SCM obj); + #define SCM_SETAND_CAR(x, y) \ (SCM_SETCAR ((x), SCM_PACK (SCM_UNPACK (SCM_CAR (x)) & (y)))) #define SCM_SETOR_CAR(x, y)\ diff --git a/libguile/hooks.c b/libguile/hooks.c index 9d7cf5b00..166394818 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -199,7 +199,7 @@ scm_create_hook (const char *name, int n_args) { SCM hook = make_hook (SCM_MAKINUM (n_args), "scm_create_hook"); scm_c_define (name, hook); - scm_protect_object (hook); + scm_gc_protect_object (hook); /* cmm:FIXME:: qua? */ return hook; } diff --git a/libguile/root.h b/libguile/root.h index 764052ce6..9963aa813 100644 --- a/libguile/root.h +++ b/libguile/root.h @@ -68,11 +68,12 @@ #define scm_asyncs scm_sys_protects[9] #define scm_protects scm_sys_protects[10] #define scm_properties_whash scm_sys_protects[11] +#define scm_gc_registered_roots scm_sys_protects[12] #ifdef DEBUG_EXTENSIONS -#define scm_source_whash scm_sys_protects[12] -#define SCM_NUM_PROTECTS 13 +#define scm_source_whash scm_sys_protects[13] +#define SCM_NUM_PROTECTS 14 #else -#define SCM_NUM_PROTECTS 12 +#define SCM_NUM_PROTECTS 13 #endif extern SCM scm_sys_protects[]; From fc62c86a599039709b22783a0abc552a5f33719e Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Sat, 26 May 2001 22:11:31 +0000 Subject: [PATCH 1193/2047] *** empty log message *** --- NEWS | 12 ++++++++++++ RELEASE | 1 + 2 files changed, 13 insertions(+) diff --git a/NEWS b/NEWS index 724a3589e..6b8a9fd96 100644 --- a/NEWS +++ b/NEWS @@ -978,6 +978,18 @@ types and Scheme numbers. See above. +** New functions: scm_gc_protect_object, scm_gc_unprotect_object + +These are just nicer-named old scm_protect_object and +scm_unprotect_object. + +** Deprecated functions: scm_protect_object, scm_unprotect_object + +** New functions: scm_gc_[un]register_root, scm_gc_[un]register_roots + +These functions can be used to register pointers to locations that +hold SCM values. + Changes since Guile 1.3.4: diff --git a/RELEASE b/RELEASE index dd50962b8..941339fb1 100644 --- a/RELEASE +++ b/RELEASE @@ -107,6 +107,7 @@ After signal handling and threading have been fixed: scm_info_frame, scm_stack, scm_array, scm_array_dim. - remove deprecated functions: scm_mkbig, scm_big2num, scm_adjbig, scm_normbig, scm_copybig, scm_2ulong2big, scm_dbl2big, scm_big2dbl. +- remove deprecated functions: scm_protect_object, scm_unprotect_object. Modules sort.c and random.c should be factored out into separate modules (but still be distributed with guile-core) when we get a new From 729dbac32f9b3a8b2c6fe399f4e725549cecd1e7 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sun, 27 May 2001 22:00:03 +0000 Subject: [PATCH 1194/2047] * Changed the default definition of SCM. * Fixed some typing problems detected by the above change. * Fixed some problems that were detected by compiling guile with -W. --- libguile/ChangeLog | 68 ++++++++++++++++++++++++++++++++++++++++++++- libguile/__scm.h | 8 +++--- libguile/eval.c | 5 ++-- libguile/eval.h | 8 ++++-- libguile/gc.c | 4 +-- libguile/gh_data.c | 7 ++--- libguile/goops.c | 15 +++++----- libguile/goops.h | 12 ++++---- libguile/modules.c | 4 +-- libguile/modules.h | 12 ++++---- libguile/objects.h | 14 ++++------ libguile/sort.c | 4 +-- libguile/strports.c | 2 +- libguile/struct.h | 10 +++---- libguile/symbols.h | 20 ++++++------- libguile/tags.h | 8 ++---- libguile/unif.c | 27 ++++++++++-------- 17 files changed, 147 insertions(+), 81 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 07474e65d..9c375df04 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,68 @@ +2001-05-26 Dirk Herrmann + + * __scm.h (SCM_DEBUG_TYPING_STRICTNESS): Make 1 the default. + + * eval.c (promise_print): Read the promise's value as an object. + + (SCM_CEVAL): Don't perform side-effecting operations in macro + parameters. + + * eval.h (SCM_EVALIM2): Fix the typing strictness of the + conditional expression. + + * gc.c (scm_master_freelist, scm_master_freelist2): Added missing + initializer. + + * gh_data.c (gh_set_substr): Removed redundant unsigned >= 0 + text, removed redundant computation of effective_length and fixed + the overflow check. + + * goops.c (test_slot_existence): Use SCM_EQ_P to compare SCM + values. + + (wrap_init): Don't use SCM_C[AD]R for non pairs. + + (hell): Make it a scm_bits_t pointer rather than a SCM pointer. + + * goops.c (scm_sys_modify_class), strports.c (st_resize_port), + struct.h (SCM_SET_STRUCT_PRINTER): Store unpacked values. + + * goops.h (SCM_ACCESSORS_OF, SCM_SLOT): Return a SCM value. + + * goops.h (GOOPSH, SCM_GOOPS_H), modules.h (MODULESH, + SCM_MODULES_H), objects.h (OBJECTSH, SCM_OBJECTS_H), struct.h + (STRUCTH, SCM_STRUCT_H), symbols.h (SYMBOLSH, SCM_SYMBOLS_H), + __scm.h (__SCMH, SCM___SCM_H): Change H to SCM__H. + + * modules.[ch] (scm_module_tag): Make it a scm_bits_t value. + + * objects.h (SCM_SET_CLASS_INSTANCE_SIZE): Fixed typing. + + * ramap.c (ramap_rp): Removed bogus `;´. + + * sort.c (scm_restricted_vector_sort_x): Fixed signedness + problem. + + * symbols.h (SCM_PROP_SLOTS, SCM_SET_PROP_SLOTS, SCM_SYMBOL_FUNC, + SCM_SET_SYMBOL_FUNC, SCM_SYMBOL_PROPS, SCM_SET_SYMBOL_PROPS): + Read SCM objects rather than scm_bits_t values. + + * tags.h (SCM_VOIDP_TEST): Removed. + + (SCM_DEBUG_TYPING_STRICTNESS): Now takes values 0, 1, 2. The + value of 2 now corresponds to the former 1, the current 1 + corresponds to the former situation that SCM_VOIDP_TEST was + defined. + + (SCM): Now defined as typedef struct scm_unused_struct * SCM; + If this appears to be not ANSI compliant, we will change it to + typedef struct scm_unused_struct { } * SCM; + Thanks to Han-Wen Nienhuys for the suggestion. + + * unif.c (scm_array_set_x): Fix typing problem, and use + SCM_UVECTOR_BASE instead of SCM_VELTS or SCM_CELL_WORD_1 when + dealing with uniform vectors. + 2001-05-27 Michael Livshin * gc.c (scm_init_storage): init `scm_gc_registered_roots'. @@ -25,8 +90,9 @@ * modules.c (scm_env_module): Exported to Scheme. * eval.c (scm_debug_opts): New option `show-file-name'. + * debug.h (SCM_SHOW_FILE_NAME): New. - + * backtrace.c: Include "libguile/filesys.h". (sym_base, display_backtrace_get_file_line, display_backtrace_file, display_backtrace_file_and_line): New. diff --git a/libguile/__scm.h b/libguile/__scm.h index 5e7637f0d..2a06b9caa 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -1,7 +1,7 @@ /* classes: h_files */ -#ifndef __SCMH -#define __SCMH +#ifndef SCM___SCM_H +#define SCM___SCM_H /* Copyright (C) 1995,1996,1998,1999,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify @@ -192,7 +192,7 @@ * errors, and then do 'make clean; make'. */ #ifndef SCM_DEBUG_TYPING_STRICTNESS -#define SCM_DEBUG_TYPING_STRICTNESS 0 +#define SCM_DEBUG_TYPING_STRICTNESS 1 #endif /* If SCM_ENABLE_VCELLS is set to 1, a couple of functions that deal @@ -636,7 +636,7 @@ extern SCM scm_apply_generic (SCM gf, SCM args); -#endif /* __SCMH */ +#endif /* SCM___SCM_H */ /* Local Variables: diff --git a/libguile/eval.c b/libguile/eval.c index 0274da4fe..df458d50a 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2321,7 +2321,8 @@ dispatch: /* Compute a hash value */ long hashset = SCM_INUM (proc); long j = n; - mask = SCM_INUM (SCM_CAR (z = SCM_CDDR (z))); + z = SCM_CDDR (z); + mask = SCM_INUM (SCM_CAR (z)); proc = SCM_CADR (z); i = 0; t.arg1 = arg2; @@ -3786,7 +3787,7 @@ promise_print (SCM exp, SCM port, scm_print_state *pstate) int writingp = SCM_WRITINGP (pstate); scm_puts ("#', port); return !0; diff --git a/libguile/eval.h b/libguile/eval.h index 06ad86969..4bd167f48 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -95,9 +95,11 @@ extern SCM scm_eval_options_interface (SCM setting); * * For an explanation of symbols containing "EVAL", see beginning of eval.c. */ -#define SCM_EVALIM2(x) ((SCM_EQ_P ((x), SCM_EOL)) \ - ? scm_misc_error (NULL, scm_s_expression, SCM_EOL), 0 \ - : (x)) +#define SCM_EVALIM2(x) \ + ((SCM_EQ_P ((x), SCM_EOL) \ + ? scm_misc_error (NULL, scm_s_expression, SCM_EOL), 0 \ + : 0), \ + (x)) #ifdef MEMOIZE_LOCALS #define SCM_EVALIM(x, env) (SCM_ILOCP (x) \ ? *scm_ilookup ((x), env) \ diff --git a/libguile/gc.c b/libguile/gc.c index 750ef4969..0a0f92288 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -312,11 +312,11 @@ typedef struct scm_freelist_t { SCM scm_freelist = SCM_EOL; scm_freelist_t scm_master_freelist = { - SCM_EOL, 0, 0, SCM_EOL, 0, SCM_CLUSTER_SIZE_1, 0, 0, 0, 1, 0, 0 + SCM_EOL, 0, 0, SCM_EOL, 0, SCM_CLUSTER_SIZE_1, 0, 0, 0, 1, 0, 0, 0 }; SCM scm_freelist2 = SCM_EOL; scm_freelist_t scm_master_freelist2 = { - SCM_EOL, 0, 0, SCM_EOL, 0, SCM_CLUSTER_SIZE_2, 0, 0, 0, 2, 0, 0 + SCM_EOL, 0, 0, SCM_EOL, 0, SCM_CLUSTER_SIZE_2, 0, 0, 0, 2, 0, 0, 0 }; /* scm_mtrigger diff --git a/libguile/gh_data.c b/libguile/gh_data.c index dc31bae09..3843a0741 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -99,17 +99,14 @@ gh_set_substr (char *src, SCM dst, long start, size_t len) { char *dst_ptr; size_t dst_len; - size_t effective_length; SCM_ASSERT (SCM_STRINGP (dst), dst, SCM_ARG3, "gh_set_substr"); dst_ptr = SCM_STRING_CHARS (dst); dst_len = SCM_STRING_LENGTH (dst); - SCM_ASSERT (len >= 0 && len <= dst_len, - dst, SCM_ARG4, "gh_set_substr"); + SCM_ASSERT (start + len <= dst_len, dst, SCM_ARG4, "gh_set_substr"); - effective_length = (len < dst_len) ? len : dst_len; - memmove (dst_ptr + start, src, effective_length); + memmove (dst_ptr + start, src, len); scm_remember_upto_here_1 (dst); } diff --git a/libguile/goops.c b/libguile/goops.c index 1fe133828..a85f4975c 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1129,8 +1129,8 @@ test_slot_existence (SCM class, SCM obj, SCM slot_name) { register SCM l; - for (l = SCM_ACCESSORS_OF (obj); SCM_NNULLP (l); l = SCM_CDR (l)) - if (SCM_CAAR (l) == slot_name) + for (l = SCM_ACCESSORS_OF (obj); !SCM_NULLP (l); l = SCM_CDR (l)) + if (SCM_EQ_P (SCM_CAAR (l), slot_name)) return SCM_BOOL_T; return SCM_BOOL_F; @@ -1289,9 +1289,10 @@ wrap_init (SCM class, SCM *m, long n) m[i] = SCM_GOOPS_UNBOUND; SCM_NEWCELL2 (z); - SCM_SETCDR (z, (SCM) m); SCM_SET_STRUCT_GC_CHAIN (z, 0); - SCM_SETCAR (z, (scm_bits_t) SCM_STRUCT_DATA (class) | scm_tc3_cons_gloc); + SCM_SET_CELL_WORD_1 (z, m); + SCM_SET_CELL_WORD_0 (z, (scm_bits_t) SCM_STRUCT_DATA (class) + | scm_tc3_cons_gloc); return z; } @@ -1435,10 +1436,10 @@ SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0, SCM cdr = SCM_CDR (old); SCM_SETCAR (old, SCM_CAR (new)); SCM_SETCDR (old, SCM_CDR (new)); - SCM_STRUCT_DATA (old)[scm_vtable_index_vtable] = old; + SCM_STRUCT_DATA (old)[scm_vtable_index_vtable] = SCM_UNPACK (old); SCM_SETCAR (new, car); SCM_SETCDR (new, cdr); - SCM_STRUCT_DATA (new)[scm_vtable_index_vtable] = new; + SCM_STRUCT_DATA (new)[scm_vtable_index_vtable] = SCM_UNPACK (new); } SCM_REALLOW_INTS; return SCM_UNSPECIFIED; @@ -1462,7 +1463,7 @@ SCM_DEFINE (scm_sys_invalidate_class, "%invalidate-class", 1, 0, 0, * infinite recursions. */ -static SCM **hell; +static scm_bits_t **hell; static long n_hell = 1; /* one place for the evil one himself */ static long hell_size = 4; #ifdef USE_THREADS diff --git a/libguile/goops.h b/libguile/goops.h index 481ff0067..5aefcfe6d 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef GOOPSH -#define GOOPSH -/* Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. +#ifndef SCM_GOOPS_H +#define SCM_GOOPS_H +/* Copyright (C) 1998,1999,2000,2001 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 @@ -120,7 +120,7 @@ typedef struct scm_method_t { #define SCM_INST_TYPE(x) SCM_OBJ_CLASS_FLAGS (x) /* Also defined in libguuile/objects.c */ #define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x) -#define SCM_ACCESSORS_OF(x) (SCM_STRUCT_VTABLE_DATA (x)[scm_si_getters_n_setters]) +#define SCM_ACCESSORS_OF(x) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (x)[scm_si_getters_n_setters])) #define SCM_NUMBER_OF_SLOTS(x)\ (SCM_UNPACK (SCM_STRUCT_DATA (x)[scm_struct_i_n_words]) \ - scm_struct_n_extra_words) \ @@ -140,7 +140,7 @@ typedef struct scm_method_t { & (SCM_CLASSF_ACCESSOR_METHOD \ | SCM_CLASSF_SIMPLE_METHOD)) -#define SCM_SLOT(x, i) (SCM_INST(x)[i]) +#define SCM_SLOT(x, i) (SCM_PACK (SCM_INST (x) [i])) #define SCM_SUBCLASSP(c1, c2) (!SCM_FALSEP (scm_c_memq (c2, SCM_SLOT (c1, scm_si_cpl)))) #define SCM_IS_A_P(x, c) (SCM_NIMP (x) \ && SCM_INSTANCEP (x) \ @@ -284,4 +284,4 @@ SCM scm_sys_method_more_specific_p (SCM m1, SCM m2, SCM targs); SCM scm_init_goops_builtins (void); void scm_init_goops (void); -#endif /* GOOPSH */ +#endif /* SCM_GOOPS_H */ diff --git a/libguile/modules.c b/libguile/modules.c index 5bf40ac89..5e893dc9d 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1998,2000,2001 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 @@ -62,7 +62,7 @@ int scm_module_system_booted_p = 0; -SCM scm_module_tag; +scm_bits_t scm_module_tag; static SCM the_module; diff --git a/libguile/modules.h b/libguile/modules.h index 632668ebe..2dd058524 100644 --- a/libguile/modules.h +++ b/libguile/modules.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef MODULESH -#define MODULESH -/* Copyright (C) 1998, 2000 Free Software Foundation, Inc. +#ifndef SCM_MODULES_H +#define SCM_MODULES_H +/* Copyright (C) 1998,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -51,10 +51,10 @@ extern int scm_module_system_booted_p; -extern SCM scm_module_tag; +extern scm_bits_t scm_module_tag; #define SCM_MODULEP(OBJ) \ - (SCM_NIMP (OBJ) && SCM_CELL_TYPE (OBJ) == scm_module_tag) + (!SCM_IMP (OBJ) && SCM_CELL_TYPE (OBJ) == scm_module_tag) #define SCM_VALIDATE_MODULE(pos, scm) SCM_MAKE_VALIDATE (pos, scm, MODULEP) @@ -139,7 +139,7 @@ extern SCM scm_load_scheme_module (SCM name); #endif -#endif /* MODULESH */ +#endif /* SCM_MODULES_H */ /* Local Variables: diff --git a/libguile/objects.h b/libguile/objects.h index 3f9b5e9a8..649d3fb1e 100644 --- a/libguile/objects.h +++ b/libguile/objects.h @@ -1,9 +1,9 @@ /* classes: h_files */ -#ifndef OBJECTSH -#define OBJECTSH +#ifndef SCM_OBJECTS_H +#define SCM_OBJECTS_H -/* Copyright (C) 1996, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1996,1999,2000,2001 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 @@ -99,10 +99,8 @@ #define SCM_SET_CLASS_DESTRUCTOR(c, d) SCM_SET_VTABLE_DESTRUCTOR (c, d) #define SCM_SET_CLASS_INSTANCE_SIZE(c, s) \ -(SCM_STRUCT_DATA (c)[scm_struct_i_size] \ - = SCM_PACK ((SCM_UNPACK (SCM_STRUCT_DATA (c)[scm_struct_i_size])\ - & SCM_STRUCTF_MASK)\ - | s)) + (SCM_STRUCT_DATA (c)[scm_struct_i_size] \ + = (SCM_STRUCT_DATA (c) [scm_struct_i_size] & SCM_STRUCTF_MASK) | s) /* {Operator classes} * @@ -242,7 +240,7 @@ extern SCM scm_i_make_class_object (SCM metaclass, SCM layout_string, unsigned long flags); extern void scm_init_objects (void); -#endif /* OBJECTSH */ +#endif /* SCM_OBJECTS_H */ /* Local Variables: diff --git a/libguile/sort.c b/libguile/sort.c index 5f849328f..76867843a 100644 --- a/libguile/sort.c +++ b/libguile/sort.c @@ -434,8 +434,8 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0, vp = SCM_VELTS (vec); /* vector pointer */ vlen = SCM_VECTOR_LENGTH (vec); - SCM_VALIDATE_INUM_COPY (3,startpos,spos); - SCM_ASSERT_RANGE (3,startpos,(spos >= 0) && (spos <= vlen)); + SCM_VALIDATE_INUM_MIN_COPY (3, startpos, 0, spos); + SCM_ASSERT_RANGE (3,startpos, spos <= vlen); SCM_VALIDATE_INUM_RANGE (4,endpos,0,vlen+1); len = SCM_INUM (endpos) - spos; diff --git a/libguile/strports.c b/libguile/strports.c index 21bffde78..de9dfbc79 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -114,7 +114,7 @@ st_resize_port (scm_port_t *pt, off_t new_size) /* reset buffer. */ { - pt->stream = new_stream; + pt->stream = SCM_UNPACK (new_stream); pt->read_buf = pt->write_buf = SCM_STRING_UCHARS (new_stream); pt->read_pos = pt->write_pos = pt->write_buf + index; pt->write_end = pt->write_buf + pt->write_buf_size; diff --git a/libguile/struct.h b/libguile/struct.h index bd952f7eb..cf7a027fd 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef STRUCTH -#define STRUCTH -/* Copyright (C) 1995, 1997, 1999, 2000 Free Software Foundation, Inc. +#ifndef SCM_STRUCT_H +#define SCM_STRUCT_H +/* Copyright (C) 1995,1997,1999,2000,2001 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 @@ -88,7 +88,7 @@ typedef size_t (*scm_struct_free_t) (scm_bits_t * vtable, scm_bits_t * data); #define SCM_STRUCT_VTABLE(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_vtable])) #define SCM_STRUCT_PRINTER(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_printer])) #define SCM_SET_STRUCT_PRINTER(x, v)\ - (SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_printer] = (v)) + (SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_printer] = SCM_UNPACK (v)) #define SCM_SET_VTABLE_DESTRUCTOR(X, D) (SCM_STRUCT_DATA (X) [scm_struct_i_free] = (scm_bits_t) (D)) /* Efficiency is important in the following macro, since it's used in GC */ #define SCM_LAYOUT_TAILP(X) (((X) & 32) == 0) /* R, W or O */ @@ -127,7 +127,7 @@ extern void scm_print_struct (SCM exp, SCM port, scm_print_state *); extern void scm_struct_prehistory (void); extern void scm_init_struct (void); -#endif /* STRUCTH */ +#endif /* SCM_STRUCT_H */ /* Local Variables: diff --git a/libguile/symbols.h b/libguile/symbols.h index 3691ac46e..2c4973b9d 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef SYMBOLSH -#define SYMBOLSH -/* Copyright (C) 1995,1996,1997,1998, 2000, 2001 Free Software Foundation, Inc. +#ifndef SCM_SYMBOLS_H +#define SCM_SYMBOLS_H +/* Copyright (C) 1995,1996,1997,1998,2000,2001 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 @@ -62,12 +62,12 @@ #define SCM_SYMBOL_HASH(X) ((unsigned long) SCM_CELL_WORD_2 (X)) #define SCM_SET_SYMBOL_HASH(X, v) (SCM_SET_CELL_WORD_2 ((X), (v))) -#define SCM_PROP_SLOTS(X) (SCM_CELL_WORD_3 (X)) -#define SCM_SET_PROP_SLOTS(X, v) (SCM_SET_CELL_WORD_3 ((X), (v))) -#define SCM_SYMBOL_FUNC(X) (SCM_CAR (SCM_CELL_WORD_3 (X))) -#define SCM_SET_SYMBOL_FUNC(X, v) (SCM_SETCAR (SCM_CELL_WORD_3 (X), (v))) -#define SCM_SYMBOL_PROPS(X) (SCM_CDR (SCM_CELL_WORD_3 (X))) -#define SCM_SET_SYMBOL_PROPS(X, v) (SCM_SETCDR (SCM_CELL_WORD_3 (X), (v))) +#define SCM_PROP_SLOTS(X) (SCM_CELL_OBJECT_3 (X)) +#define SCM_SET_PROP_SLOTS(X, v) (SCM_SET_CELL_OBJECT_3 ((X), (v))) +#define SCM_SYMBOL_FUNC(X) (SCM_CAR (SCM_CELL_OBJECT_3 (X))) +#define SCM_SET_SYMBOL_FUNC(X, v) (SCM_SETCAR (SCM_CELL_OBJECT_3 (X), (v))) +#define SCM_SYMBOL_PROPS(X) (SCM_CDR (SCM_CELL_OBJECT_3 (X))) +#define SCM_SET_SYMBOL_PROPS(X, v) (SCM_SETCDR (SCM_CELL_OBJECT_3 (X), (v))) @@ -152,7 +152,7 @@ extern void scm_init_symbols_deprecated (void); #endif /* SCM_ENABLE_VCELLS */ -#endif /* SYMBOLSH */ +#endif /* SCM_SYMBOLS_H */ /* Local Variables: diff --git a/libguile/tags.h b/libguile/tags.h index e64ad4c35..3de11fec8 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -54,8 +54,6 @@ -/* #define SCM_VOIDP_TEST */ - /* In the beginning was the Word: */ typedef long scm_bits_t; @@ -63,16 +61,16 @@ typedef long scm_bits_t; /* But as external interface, we use SCM, which may, according to the desired * level of type checking, be defined in several ways: */ -#if (SCM_DEBUG_TYPING_STRICTNESS == 1) +#if (SCM_DEBUG_TYPING_STRICTNESS == 2) typedef union { struct { scm_bits_t n; } n; } SCM; static SCM scm_pack(scm_bits_t b) { SCM s; s.n.n = b; return s; } # define SCM_UNPACK(x) ((x).n.n) # define SCM_PACK(x) (scm_pack ((scm_bits_t) (x))) -#elif defined (SCM_VOIDP_TEST) +#elif (SCM_DEBUG_TYPING_STRICTNESS == 1) /* This is the default, which provides an intermediate level of compile time * type checking while still resulting in very efficient code. */ - typedef void * SCM; + typedef struct scm_unused_struct * SCM; # define SCM_UNPACK(x) ((scm_bits_t) (x)) # define SCM_PACK(x) ((SCM) (x)) #else diff --git a/libguile/unif.c b/libguile/unif.c index fbb9b96d7..5e0a801df 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1321,36 +1321,39 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, ((char *) SCM_UVECTOR_BASE (v))[pos] = SCM_INUM (obj); break; case scm_tc7_uvect: - ((unsigned long *) SCM_VELTS(v))[pos] = SCM_PACK (scm_num2ulong(obj, SCM_ARG2, FUNC_NAME)); + ((unsigned long *) SCM_UVECTOR_BASE (v))[pos] + = scm_num2ulong (obj, SCM_ARG2, FUNC_NAME); break; case scm_tc7_ivect: - ((long *) SCM_VELTS(v))[pos] = SCM_PACK (scm_num2long (obj, SCM_ARG2, FUNC_NAME)); + ((long *) SCM_UVECTOR_BASE (v))[pos] + = scm_num2long (obj, SCM_ARG2, FUNC_NAME); break; case scm_tc7_svect: SCM_ASRTGO (SCM_INUMP (obj), badobj); - ((short *) SCM_CELL_WORD_1 (v))[pos] = SCM_INUM (obj); + ((short *) SCM_UVECTOR_BASE (v))[pos] = SCM_INUM (obj); break; #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: - ((long long *) SCM_CELL_WORD_1 (v))[pos] = scm_num2long_long (obj, SCM_ARG2, FUNC_NAME); + ((long long *) SCM_UVECTOR_BASE (v))[pos] + = scm_num2long_long (obj, SCM_ARG2, FUNC_NAME); break; #endif - - case scm_tc7_fvect: - ((float *) SCM_CELL_WORD_1 (v))[pos] = (float) scm_num2dbl (obj, FUNC_NAME); + ((float *) SCM_UVECTOR_BASE (v))[pos] + = (float) scm_num2dbl (obj, FUNC_NAME); break; case scm_tc7_dvect: - ((double *) SCM_CELL_WORD_1 (v))[pos] = scm_num2dbl (obj, FUNC_NAME); + ((double *) SCM_UVECTOR_BASE (v))[pos] + = scm_num2dbl (obj, FUNC_NAME); break; case scm_tc7_cvect: SCM_ASRTGO (SCM_INEXACTP (obj), badobj); if (SCM_REALP (obj)) { - ((double *) SCM_CELL_WORD_1 (v))[2 * pos] = SCM_REAL_VALUE (obj); - ((double *) SCM_CELL_WORD_1 (v))[2 * pos + 1] = 0.0; + ((double *) SCM_UVECTOR_BASE (v))[2 * pos] = SCM_REAL_VALUE (obj); + ((double *) SCM_UVECTOR_BASE (v))[2 * pos + 1] = 0.0; } else { - ((double *) SCM_CELL_WORD_1 (v))[2 * pos] = SCM_COMPLEX_REAL (obj); - ((double *) SCM_CELL_WORD_1 (v))[2 * pos + 1] = SCM_COMPLEX_IMAG (obj); + ((double *) SCM_UVECTOR_BASE (v))[2 * pos] = SCM_COMPLEX_REAL (obj); + ((double *) SCM_UVECTOR_BASE (v))[2 * pos + 1] = SCM_COMPLEX_IMAG (obj); } break; case scm_tc7_vector: From 1db81cb09afe3afec94903a4f83a5e947829a58e Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Mon, 28 May 2001 12:23:41 +0000 Subject: [PATCH 1195/2047] * check-guile.in: fix to be runnable when srcdir!=builddir. --- ChangeLog | 4 ++++ check-guile.in | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index e4eecbc30..788191c34 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2001-05-28 Michael Livshin + + * check-guile.in: fix to be runnable when srcdir!=builddir. + 2001-05-26 Michael Livshin revert the controversial part of the 2001-05-23 changes diff --git a/check-guile.in b/check-guile.in index e876af5e7..a9961e93d 100644 --- a/check-guile.in +++ b/check-guile.in @@ -21,7 +21,7 @@ if [ x"$1" = x-i ] ; then else guile=libguile/guile GUILE_LOAD_PATH=$srcdir:$TEST_SUITE_DIR - LTDL_LIBRARY_PATH=$srcdir/srfi/.libs:${LTDL_LIBRARY_PATH} + LTDL_LIBRARY_PATH=`pwd`/srfi/.libs:${LTDL_LIBRARY_PATH} fi export GUILE_LOAD_PATH export LTDL_LIBRARY_PATH From dd85ce4758260f712d0efc806df6643aca8e3b74 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Mon, 28 May 2001 12:36:41 +0000 Subject: [PATCH 1196/2047] * strop.c (s_scm_string_capitalize_x): fix docstring quoting. * socket.c (s_scm_inet_pton): fix docstring quoting. (s_scm_inet_ntop): ditto. * num2integral.i.c (INTEGRAL2NUM): cast to fix a warning. * hashtab.c (scm_internal_hash_fold): fix argument position in SCM_ASSERT. * environments.c (s_scm_import_environment_set_imports_x): fix argument position in SCM_ASSERT. * debug.c (s_scm_make_gloc): fix SCM packing/unpacking. (s_scm_make_iloc): ditto. --- libguile/ChangeLog | 18 ++++++++++++++++++ libguile/debug.c | 10 +++++----- libguile/environments.c | 4 ++-- libguile/hashtab.c | 4 ++-- libguile/num2integral.i.c | 2 +- libguile/socket.c | 6 +++--- libguile/strop.c | 6 +++--- 7 files changed, 34 insertions(+), 16 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 9c375df04..f0fdd1572 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,21 @@ +2001-05-28 Michael Livshin + + * strop.c (s_scm_string_capitalize_x): fix docstring quoting. + + * socket.c (s_scm_inet_pton): fix docstring quoting. + (s_scm_inet_ntop): ditto. + + * num2integral.i.c (INTEGRAL2NUM): cast to fix a warning. + + * hashtab.c (scm_internal_hash_fold): fix argument position in + SCM_ASSERT. + + * environments.c (s_scm_import_environment_set_imports_x): fix + argument position in SCM_ASSERT. + + * debug.c (s_scm_make_gloc): fix SCM packing/unpacking. + (s_scm_make_iloc): ditto. + 2001-05-26 Dirk Herrmann * __scm.h (SCM_DEBUG_TYPING_STRICTNESS): Make 1 the default. diff --git a/libguile/debug.c b/libguile/debug.c index efece65f7..dc47c9dbc 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -265,7 +265,7 @@ SCM_DEFINE (scm_make_gloc, "make-gloc", 1, 1, 0, env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE); else SCM_VALIDATE_NULLORCONS (2,env); - return scm_make_memoized (SCM_UNPACK (var) + scm_tc3_cons_gloc, env); + return scm_make_memoized (SCM_PACK (SCM_UNPACK (var) + scm_tc3_cons_gloc), env); } #undef FUNC_NAME @@ -288,10 +288,10 @@ SCM_DEFINE (scm_make_iloc, "make-iloc", 3, 0, 0, { SCM_VALIDATE_INUM (1,frame); SCM_VALIDATE_INUM (2,binding); - return (SCM_ILOC00 - + SCM_IFRINC * SCM_INUM (frame) - + (SCM_NFALSEP (cdrp) ? SCM_ICDR : 0) - + SCM_IDINC * SCM_INUM (binding)); + return SCM_PACK (SCM_UNPACK (SCM_ILOC00) + + SCM_IFRINC * SCM_INUM (frame) + + (SCM_NFALSEP (cdrp) ? SCM_ICDR : 0) + + SCM_IDINC * SCM_INUM (binding)); } #undef FUNC_NAME diff --git a/libguile/environments.c b/libguile/environments.c index aad811d32..eecf4fe3f 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -1907,9 +1907,9 @@ SCM_DEFINE (scm_import_environment_set_imports_x, "import-environment-set-import for (l = imports; SCM_CONSP (l); l = SCM_CDR (l)) { SCM obj = SCM_CAR (l); - SCM_ASSERT (SCM_ENVIRONMENT_P (obj), imports, SCM_ARG1, FUNC_NAME); + SCM_ASSERT (SCM_ENVIRONMENT_P (obj), imports, SCM_ARG2, FUNC_NAME); } - SCM_ASSERT (SCM_NULLP (l), imports, SCM_ARG1, FUNC_NAME); + SCM_ASSERT (SCM_NULLP (l), imports, SCM_ARG2, FUNC_NAME); for (l = body->import_observers; !SCM_NULLP (l); l = SCM_CDR (l)) { diff --git a/libguile/hashtab.c b/libguile/hashtab.c index d9f629240..da802a5e1 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -551,10 +551,10 @@ scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table) while (!SCM_NULLP (ls)) { SCM_ASSERT (SCM_CONSP (ls), - table, SCM_ARG1, s_scm_hash_fold); + table, SCM_ARG3, s_scm_hash_fold); handle = SCM_CAR (ls); SCM_ASSERT (SCM_CONSP (handle), - table, SCM_ARG1, s_scm_hash_fold); + table, SCM_ARG3, s_scm_hash_fold); result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result); ls = SCM_CDR (ls); } diff --git a/libguile/num2integral.i.c b/libguile/num2integral.i.c index 3e5d65389..a68fe5d87 100644 --- a/libguile/num2integral.i.c +++ b/libguile/num2integral.i.c @@ -92,7 +92,7 @@ INTEGRAL2NUM (ITYPE n) SCM_POSFIXABLE (n) #endif ) - return SCM_MAKINUM (n); + return SCM_MAKINUM ((long) n); #ifdef SCM_BIGDIG return INTEGRAL2BIG (n); diff --git a/libguile/socket.c b/libguile/socket.c index 109918d83..685d93277 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -355,8 +355,8 @@ SCM_DEFINE (scm_inet_pton, "inet-pton", 2, 0, 0, "the result is an integer with normal host byte ordering.\n" "@var{family} can be @code{AF_INET} or @code{AF_INET6}. E.g.,\n\n" "@lisp\n" - "(inet-pton AF_INET "127.0.0.1") @result{} 2130706433\n" - "(inet-pton AF_INET6 "::1") @result{} 1\n" + "(inet-pton AF_INET \"127.0.0.1\") @result{} 2130706433\n" + "(inet-pton AF_INET6 \"::1\") @result{} 1\n" "@end lisp") #define FUNC_NAME s_scm_inet_pton { @@ -389,7 +389,7 @@ SCM_DEFINE (scm_inet_ntop, "inet-ntop", 2, 0, 0, "the input is an integer with normal host byte ordering.\n" "@var{family} can be @code{AF_INET} or @code{AF_INET6}. E.g.,\n\n" "@lisp\n" - "(inet-ntop AF_INET 2130706433) @result{} "127.0.0.1"\n" + "(inet-ntop AF_INET 2130706433) @result{} \"127.0.0.1\"\n" "(inet-ntop AF_INET6 (- (expt 2 128) 1)) @result{}\n" "ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff\n" "@end lisp") diff --git a/libguile/strop.c b/libguile/strop.c index ff2698fb3..d8336634f 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -483,9 +483,9 @@ SCM_DEFINE (scm_string_capitalize_x, "string-capitalize!", 1, 0, 0, "destructively and return @var{str}.\n" "\n" "@lisp\n" - "y @result{} "hello world"\n" - "(string-capitalize! y) @result{} "Hello World"\n" - "y @result{} "Hello World"\n" + "y @result{} \"hello world\"\n" + "(string-capitalize! y) @result{} \"Hello World\"\n" + "y @result{} \"Hello World\"\n" "@end lisp") #define FUNC_NAME s_scm_string_capitalize_x { From fde504077bf4f73e3f9983de6ae8599d3fbb8895 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Mon, 28 May 2001 14:18:35 +0000 Subject: [PATCH 1197/2047] * hooks.c (scm_create_hook): deprecated. (make_hook): deleted. (scm_make_hook): all the hook creation code is now here. * gc.c (scm_init_gc): don't call `scm_create_hook'. instead make a hook, make it permanent, and do a `scm_c_define' on it. --- libguile/ChangeLog | 7 +++++++ libguile/gc.c | 4 ++-- libguile/hooks.c | 42 ++++++++++++++++++------------------------ libguile/hooks.h | 5 ++++- 4 files changed, 31 insertions(+), 27 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f0fdd1572..4c719f2ec 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,12 @@ 2001-05-28 Michael Livshin + * hooks.c (scm_create_hook): deprecated. + (make_hook): deleted. + (scm_make_hook): all the hook creation code is now here. + + * gc.c (scm_init_gc): don't call `scm_create_hook'. instead make + a hook, make it permanent, and do a `scm_c_define' on it. + * strop.c (s_scm_string_capitalize_x): fix docstring quoting. * socket.c (s_scm_inet_pton): fix docstring quoting. diff --git a/libguile/gc.c b/libguile/gc.c index 0a0f92288..48f688b93 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -2840,8 +2840,8 @@ scm_init_gc () { SCM after_gc_thunk; - /* Dirk:FIXME:: scm_create_hook is strange. */ - scm_after_gc_hook = scm_create_hook ("after-gc-hook", 0); + scm_after_gc_hook = scm_permanent_object (scm_make_hook (SCM_INUM0)); + scm_c_define ("after-gc-hook", scm_after_gc_hook); after_gc_thunk = scm_c_make_subr ("%gc-thunk", scm_tc7_subr_0, gc_async_thunk); diff --git a/libguile/hooks.c b/libguile/hooks.c index 166394818..737e92353 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -150,26 +150,6 @@ scm_c_hook_run (scm_c_hook_t *hook, void *data) scm_bits_t scm_tc16_hook; -static SCM -make_hook (SCM n_args, const char *subr) -{ - int n; - - if (SCM_UNBNDP (n_args)) - { - n = 0; - } - else - { - SCM_ASSERT (SCM_INUMP (n_args), n_args, SCM_ARGn, subr); - n = SCM_INUM (n_args); - if (n < 0 || n > 16) - scm_out_of_range (subr, n_args); - } - SCM_RETURN_NEWSMOB (scm_tc16_hook + (n << 16), SCM_UNPACK (SCM_EOL)); -} - - static int hook_print (SCM hook, SCM port, scm_print_state *pstate) { @@ -193,16 +173,17 @@ hook_print (SCM hook, SCM port, scm_print_state *pstate) return 1; } +#if (SCM_DEBUG_DEPRECATED == 0) SCM scm_create_hook (const char *name, int n_args) { - SCM hook = make_hook (SCM_MAKINUM (n_args), "scm_create_hook"); + SCM hook = scm_make_hook (SCM_MAKINUM (n_args)); scm_c_define (name, hook); - scm_gc_protect_object (hook); /* cmm:FIXME:: qua? */ - return hook; + return scm_permanent_object (hook); } +#endif SCM_DEFINE (scm_make_hook, "make-hook", 0, 1, 0, (SCM n_args), @@ -210,7 +191,20 @@ SCM_DEFINE (scm_make_hook, "make-hook", 0, 1, 0, "@var{n_args}. @var{n_args} defaults to zero.") #define FUNC_NAME s_scm_make_hook { - return make_hook (n_args, FUNC_NAME); + int n; + + if (SCM_UNBNDP (n_args)) + { + n = 0; + } + else + { + SCM_VALIDATE_INUM_COPY (SCM_ARG1, n_args, n); + if (n < 0 || n > 16) + SCM_OUT_OF_RANGE (SCM_ARG1, n_args); + } + + SCM_RETURN_NEWSMOB (scm_tc16_hook + (n << 16), SCM_UNPACK (SCM_EOL)); } #undef FUNC_NAME diff --git a/libguile/hooks.h b/libguile/hooks.h index 216d63062..ff9d9d5d4 100644 --- a/libguile/hooks.h +++ b/libguile/hooks.h @@ -104,7 +104,6 @@ extern scm_bits_t scm_tc16_hook; #define SCM_SET_HOOK_PROCEDURES(hook, procs) SCM_SET_CELL_OBJECT_1 ((hook), (procs)) extern SCM scm_make_hook (SCM n_args); -extern SCM scm_create_hook (const char* name, int n_args); extern SCM scm_hook_p (SCM x); extern SCM scm_hook_empty_p (SCM hook); extern SCM scm_add_hook_x (SCM hook, SCM thunk, SCM appendp); @@ -115,6 +114,10 @@ extern void scm_c_run_hook (SCM hook, SCM args); extern SCM scm_hook_to_list (SCM hook); extern void scm_init_hooks (void); +#if (SCM_DEBUG_DEPRECATED == 0) +extern SCM scm_create_hook (const char* name, int n_args); +#endif + #endif /* SCM_HOOKS_H */ /* From 5b2ad23be2aa13db008061cdab7c56f0756280ce Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Mon, 28 May 2001 14:21:24 +0000 Subject: [PATCH 1198/2047] *** empty log message *** --- NEWS | 5 +++++ RELEASE | 3 ++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index 6b8a9fd96..ffff15251 100644 --- a/NEWS +++ b/NEWS @@ -990,6 +990,11 @@ scm_unprotect_object. These functions can be used to register pointers to locations that hold SCM values. +** Deprecated function: scm_create_hook. + +Its sins are: misleading name, non-modularity and lack of general +usefulness. + Changes since Guile 1.3.4: diff --git a/RELEASE b/RELEASE index 941339fb1..5043e9fd9 100644 --- a/RELEASE +++ b/RELEASE @@ -107,7 +107,8 @@ After signal handling and threading have been fixed: scm_info_frame, scm_stack, scm_array, scm_array_dim. - remove deprecated functions: scm_mkbig, scm_big2num, scm_adjbig, scm_normbig, scm_copybig, scm_2ulong2big, scm_dbl2big, scm_big2dbl. -- remove deprecated functions: scm_protect_object, scm_unprotect_object. +- remove deprecated functions: scm_protect_object, + scm_unprotect_object, scm_create_hook. Modules sort.c and random.c should be factored out into separate modules (but still be distributed with guile-core) when we get a new From 6b0d28a38004139dd15578b07c33bb096d205a67 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Mon, 28 May 2001 14:36:00 +0000 Subject: [PATCH 1199/2047] =?UTF-8?q?*=20srfi-19.scm:=20removed=20a=20stra?= =?UTF-8?q?y=20open=20parenthesis.=20(thanks=20to=20Matthias=20K=C3=B6ppe?= =?UTF-8?q?=20for=20the=20report).?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- srfi/ChangeLog | 5 +++++ srfi/srfi-19.scm | 2 -- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 7d897618b..e18ad7170 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,8 @@ +2001-05-28 Michael Livshin + + * srfi-19.scm: removed a stray open parenthesis. (thanks to + Matthias Köppe for the report). + 2001-05-23 Rob Browning * srfi-19.scm (:optional): renamed to optional to avoid reader diff --git a/srfi/srfi-19.scm b/srfi/srfi-19.scm index 8a398e3ad..da93c8ef1 100644 --- a/srfi/srfi-19.scm +++ b/srfi/srfi-19.scm @@ -603,8 +603,6 @@ t) - ( - ;; gives the julian day which starts at noon. (define (priv:encode-julian-day-number day month year) (let* ((a (quotient (- 14 month) 12)) From d81f6fe1fe9a7ccc871039e3c9c409297ea2b88f Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 28 May 2001 14:41:33 +0000 Subject: [PATCH 1200/2047] * Ooops. This belongs to my ChangeLog entry from 2001-05-26. Sorry. --- libguile/ramap.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/ramap.c b/libguile/ramap.c index a1e290c7a..74e281c65 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -1366,7 +1366,7 @@ ramap_rp (SCM ra0,SCM proc,SCM ras) */ SCM n1 = SCM_MAKINUM (((long *) SCM_UNPACK (SCM_CDR (ra1)))[i1]); SCM n2 = SCM_MAKINUM (((long *) SCM_UNPACK (SCM_CDR (ra2)))[i2]); - if (SCM_FALSEP (SCM_SUBRF (proc) (n1, n2))); + if (SCM_FALSEP (SCM_SUBRF (proc) (n1, n2))) SCM_BITVEC_CLR (ra0, i0); } break; From 24ecf16c0c37098ea7747510d205f802ef3f37a1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 28 May 2001 18:40:31 +0000 Subject: [PATCH 1201/2047] * tests/symbols.test ("gensym"): New tests for long gensym prefices and embedded NULs in prefices. --- test-suite/ChangeLog | 5 +++++ test-suite/tests/symbols.test | 9 ++++++++- 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index a1afa6d36..a31a0dfec 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2001-05-28 Martin Grabmueller + + * tests/symbols.test ("gensym"): New tests for long gensym + prefices and embedded NULs in prefices. + 2001-05-21 Marius Vollmer * test/goops.test, test/syncase.test: New, minimal tests. diff --git a/test-suite/tests/symbols.test b/test-suite/tests/symbols.test index 3524b492b..7831a9514 100644 --- a/test-suite/tests/symbols.test +++ b/test-suite/tests/symbols.test @@ -80,4 +80,11 @@ (pass-if-exception "does not accept a symbol prefix" exception:wrong-type-arg - (gensym 'foo))) + (gensym 'foo)) + + (pass-if "accepts long prefices" + (symbol? (gensym (make-string 4000 #\!)))) + + (pass-if "accepts embedded NULs" + (> (string-length (symbol->string (gensym "foo\0bar\0braz\0foo\0bar\0braz\0foo\0bar\0braz\0foo\0bar\0braz\0foo\0bar\0braz\0foo\0bar\0braz\0"))) 6))) + From 8d09eb04493a7a3e6ab57cd8d3c1ef7da917b41d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 28 May 2001 18:42:57 +0000 Subject: [PATCH 1202/2047] * symbols.c (scm_gensym): Fix buffer overrun (try `(gensym (make-string 2000 #\!))' in an older version). Change strncpy to memcpy to allow embedded NUL characters in symbol prefix. --- libguile/ChangeLog | 8 ++++++++ libguile/symbols.c | 4 ++-- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 4c719f2ec..7f0469983 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2001-05-28 Martin Grabmueller + + * symbols.c (scm_gensym): Fix buffer overrun (try `(gensym + (make-string 2000 #\!))' in an older version). + + Change strncpy to memcpy to allow embedded NUL characters in + symbol prefix. + 2001-05-28 Michael Livshin * hooks.c (scm_create_hook): deprecated. diff --git a/libguile/symbols.c b/libguile/symbols.c index 6a463f914..83cddc0da 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -247,8 +247,8 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, SCM_VALIDATE_STRING (1, prefix); len = SCM_STRING_LENGTH (prefix); if (len > MAX_PREFIX_LENGTH) - name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); - strncpy (name, SCM_STRING_CHARS (prefix), len); + name = SCM_MUST_MALLOC (len + SCM_INTBUFLEN); + memcpy (name, SCM_STRING_CHARS (prefix), len); } { int n_digits = scm_iint2str (gensym_counter++, 10, &name[len]); From a8ca715359bc9f6a6a26a538baabe03a8ca13494 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Mon, 28 May 2001 21:14:31 +0000 Subject: [PATCH 1203/2047] * Makefile.am: let guile-config depend on libguile/libpath.h, so that it will be rebuilt if configure --prefix changes. --- guile-config/ChangeLog | 5 +++++ guile-config/Makefile.am | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/guile-config/ChangeLog b/guile-config/ChangeLog index ac7fa0ef0..f163f4ffe 100644 --- a/guile-config/ChangeLog +++ b/guile-config/ChangeLog @@ -1,3 +1,8 @@ +2001-05-28 Gary Houston + + * Makefile.am: let guile-config depend on libguile/libpath.h, + so that it will be rebuilt if configure --prefix changes. + 2001-03-07 Mikael Djurfeldt * guile-config.in (build-link): Really reverted the change of diff --git a/guile-config/Makefile.am b/guile-config/Makefile.am index a0c0e29d2..7a39b5c12 100644 --- a/guile-config/Makefile.am +++ b/guile-config/Makefile.am @@ -32,7 +32,7 @@ aclocal_DATA = guile.m4 ## We use @-...-@ as the substitution brackets here, instead of the ## usual @...@, so autoconf doesn't go and substitute the values ## directly into the left-hand sides of the sed substitutions. *sigh* -guile-config: guile-config.in +guile-config: guile-config.in ${top_builddir}/libguile/libpath.h rm -f guile-config.tmp sed < ${srcdir}/guile-config.in > guile-config.tmp \ -e s:@-bindir-@:${bindir}: \ From 609c3d3095e2d81e7a0d26a1e0cb8baed7f45750 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 30 May 2001 20:27:46 +0000 Subject: [PATCH 1204/2047] 2001-05-30 Martin Grabmueller * numbers.c (scm_difference, scm_divide): Clarified comments for - and /. 2001-05-29 Martin Grabmueller * debug.h: Removed prototype for scm_eval_string. --- libguile/ChangeLog | 9 +++++++++ libguile/debug.h | 1 - libguile/numbers.c | 12 ++++++------ 3 files changed, 15 insertions(+), 7 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 7f0469983..75a256180 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2001-05-30 Martin Grabmueller + + * numbers.c (scm_difference, scm_divide): Clarified comments for - + and /. + +2001-05-29 Martin Grabmueller + + * debug.h: Removed prototype for scm_eval_string. + 2001-05-28 Martin Grabmueller * symbols.c (scm_gensym): Fix buffer overrun (try `(gensym diff --git a/libguile/debug.h b/libguile/debug.h index 742726fae..6a49a3aed 100644 --- a/libguile/debug.h +++ b/libguile/debug.h @@ -187,7 +187,6 @@ extern scm_bits_t scm_tc16_memoized; -extern SCM scm_eval_string (SCM str); extern int scm_ready_p (void); extern void debug_print (SCM obj); extern SCM scm_debug_object_p (SCM obj); diff --git a/libguile/numbers.c b/libguile/numbers.c index 8f08a74a3..993b722ca 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -3362,10 +3362,9 @@ scm_sum (SCM x, SCM y) SCM_GPROC1 (s_difference, "-", scm_tc7_asubr, scm_difference, g_difference); -/* "If called without arguments, 0 is returned. Otherwise the sum of\n" - * "all but the first argument are subtracted from the first\n" - * "argument." - */ +/* If called with one argument @var{z1}, -@var{z1} returned. Otherwise + * the sum of all but the first argument are subtracted from the first + * argument. */ #define FUNC_NAME s_difference SCM scm_difference (SCM x, SCM y) @@ -3643,8 +3642,9 @@ scm_num2dbl (SCM a, const char *why) SCM_GPROC1 (s_divide, "/", scm_tc7_asubr, scm_divide, g_divide); -/* "Divide the first argument by the product of the remaining arguments." - */ +/* Divide the first argument by the product of the remaining + arguments. If called with one argument @var{z1}, 1/@var{z1} is + returned. */ #define FUNC_NAME s_divide SCM scm_divide (SCM x, SCM y) From 7977a4873729f73d4e6c882f2dc171a311cdd4a9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 30 May 2001 20:28:51 +0000 Subject: [PATCH 1205/2047] * image-type.c: Adapted to new typing and naming convention. --- doc/example-smob/ChangeLog | 4 ++++ doc/example-smob/image-type.c | 12 ++++++------ 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/doc/example-smob/ChangeLog b/doc/example-smob/ChangeLog index 12afa8813..60d10c03d 100644 --- a/doc/example-smob/ChangeLog +++ b/doc/example-smob/ChangeLog @@ -1,3 +1,7 @@ +2001-05-30 Martin Grabmueller + + * image-type.c: Adapted to new typing and naming convention. + 2001-04-26 Neil Jerram * image-type.c (make_image): Don't need to use SCM_NIMP before diff --git a/doc/example-smob/image-type.c b/doc/example-smob/image-type.c index fe0a9b802..f9b783737 100644 --- a/doc/example-smob/image-type.c +++ b/doc/example-smob/image-type.c @@ -21,7 +21,7 @@ #include #include -static long image_tag; +static scm_bits_t image_tag; struct image { int width, height; @@ -89,11 +89,11 @@ mark_image (SCM image_smob) return image->update_func; } -static scm_sizet +static size_t free_image (SCM image_smob) { struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); - scm_sizet size = image->width * image->height + sizeof (struct image); + size_t size = image->width * image->height + sizeof (struct image); free (image->pixels); free (image); @@ -115,13 +115,13 @@ print_image (SCM image_smob, SCM port, scm_print_state *pstate) } void -init_image_type () +init_image_type (void) { image_tag = scm_make_smob_type ("image", sizeof (struct image)); scm_set_smob_mark (image_tag, mark_image); scm_set_smob_free (image_tag, free_image); scm_set_smob_print (image_tag, print_image); - scm_make_gsubr ("clear-image", 1, 0, 0, clear_image); - scm_make_gsubr ("make-image", 3, 0, 0, make_image); + scm_c_define_gsubr ("clear-image", 1, 0, 0, clear_image); + scm_c_define_gsubr ("make-image", 3, 0, 0, make_image); } From cee2ed4f7363849841ab53324a71d7b8c08a4548 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 30 May 2001 20:32:05 +0000 Subject: [PATCH 1206/2047] * General: A lot of typo, texinfo markup and layout corrections. * scheme-data.texi (Arithmetic): Clarified docs for - and /. (String Modification): Removed docs for C functions (scm_substring_move_right_x etc.) (Keyword Procedures): New section documenting the keyword procedures from boot-9.scm. (Vectors): Moved the section before the non-standard data types. * data-rep.texi (Defining New Types (Smobs)): Adapted description of smobs and proocedure creation to new terminology. (Describing a New Type): Removed mentioning of scm_make_smob_type_mfpe from smob function list and added deprecation notice for this function. (Creating Instances): Added description and macro docs for smobs with 2 or 3 data cells. (Garbage Collecting Smobs): Removed old docs for SCM_GCTYP16. (Garbage Collecting Simple Smobs): Added some clarification about usage and usefulness. (Non-immediate Datatypes): Changed R4RS reference to R5RS. (Vector Data): Document type-specific accessors. --- doc/ChangeLog | 25 +++ doc/data-rep.texi | 211 ++++++++++++----------- doc/deprecated.texi | 137 --------------- doc/indices.texi | 51 ------ doc/intro.texi | 3 +- doc/scheme-data.texi | 371 ++++++++++++++++++++-------------------- doc/scheme-io.texi | 6 +- doc/scheme-reading.texi | 27 --- doc/scripts.texi | 213 ----------------------- doc/srfi-modules.texi | 6 + 10 files changed, 329 insertions(+), 721 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 32522fff9..7c9b12855 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,28 @@ +2001-05-30 Martin Grabmueller + + * General: A lot of typo, texinfo markup and layout corrections. + + * scheme-data.texi (Arithmetic): Clarified docs for - and /. + (String Modification): Removed docs for C functions + (scm_substring_move_right_x etc.) + (Keyword Procedures): New section documenting the keyword + procedures from boot-9.scm. + (Vectors): Moved the section before the non-standard data types. + + * data-rep.texi (Defining New Types (Smobs)): Adapted description + of smobs and proocedure creation to new terminology. + (Describing a New Type): Removed mentioning of + scm_make_smob_type_mfpe from smob function list and added + deprecation notice for this function. + (Creating Instances): Added description and macro docs for smobs + with 2 or 3 data cells. + (Garbage Collecting Smobs): Removed old docs for SCM_GCTYP16. + (Garbage Collecting Simple Smobs): Added some clarification about + usage and usefulness. + (Non-immediate Datatypes): Changed R4RS reference to R5RS. + (Vector Data): Document type-specific accessors. + + 2001-05-23 Martin Grabmueller * guile.texi: Commented out menu entry and inclusion of Tcl/Tk diff --git a/doc/data-rep.texi b/doc/data-rep.texi index d4156477a..0a4ad15fa 100644 --- a/doc/data-rep.texi +++ b/doc/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.24 2001-05-16 19:30:57 ossau Exp $ +@c essay @subtitle $Id: data-rep.texi,v 1.25 2001-05-30 20:32:05 mgrabmue Exp $ @c essay @subtitle For use with Guile @value{VERSION} @c essay @author Jim Blandy @c essay @author Free Software Foundation @@ -730,7 +730,7 @@ symbol's value to see if it has a binding as a global variable. A non-immediate datatype is one which lives in the heap, either because it cannot fit entirely within a @code{SCM} word, or because it denotes a -specific storage location (in the nomenclature of the Revised^4 Report +specific storage location (in the nomenclature of the Revised^5 Report on Scheme). The @code{SCM_IMP} and @code{SCM_NIMP} macros will distinguish these @@ -873,19 +873,22 @@ Return non-zero iff @var{x} is a string. Return non-zero iff @var{x} is a symbol. @end deftypefn -@deftypefn Macro int SCM_LENGTH (SCM @var{x}) -Return the length of the object @var{x}. -The result is undefined if @var{x} is not a vector, string, or symbol. +@deftypefn Macro int SCM_VECTOR_LENGTH (SCM @var{x}) +@deftypefnx Macro int SCM_STRING_LENGTH (SCM @var{x}) +@deftypefnx Macro int SCM_SYMBOL_LENGTH (SCM @var{x}) +Return the length of the object @var{x}. The result is undefined if +@var{x} is not a vector, string, or symbol, respectively. @end deftypefn -@deftypefn Macro {SCM *} SCM_VELTS (SCM @var{x}) +@deftypefn Macro {SCM *} SCM_VECTOR_BASE (SCM @var{x}) Return a pointer to the array of elements of the vector @var{x}. The result is undefined if @var{x} is not a vector. @end deftypefn -@deftypefn Macro {char *} SCM_CHARS (SCM @var{x}) -Return a pointer to the characters of @var{x}. -The result is undefined if @var{x} is not a symbol or a string. +@deftypefn Macro {char *} SCM_STRING_CHARS (SCM @var{x}) +@deftypefnx Macro {char *} SCM_SYMBOL_CHARS (SCM @var{x}) +Return a pointer to the characters of @var{x}. The result is undefined +if @var{x} is not a symbol or string, respectively. @end deftypefn There are also a few magic values stuffed into memory before a symbol's @@ -1361,8 +1364,8 @@ says it comes from ``small object'', referring to the fact that only the use.} To define a new smob type, the programmer provides Guile with some essential information about the type --- how to print it, how to garbage collect it, and so on --- and Guile returns a fresh type tag for -use in the @sc{car} of new cells. The programmer can then use -@code{scm_make_gsubr} to make a set of C functions that create and +use in the first word of new cells. The programmer can then use +@code{scm_c_define_gsubr} to make a set of C functions that create and operate on these objects visible to Scheme code. (You can find a complete version of the example code used in this @@ -1399,13 +1402,12 @@ refers to. The default smob mark function is to not mark any data. Guile will apply this function to each instance of the new type it could not find any live pointers to. The function should release all resources held by the object and return the number of bytes released. -This is analagous to the Java finalization method-- it is invoked at -an unspecified time (when garbage collection occurs) after the object -is dead. -The default free function frees the smob data (if the size of the struct -passed to @code{scm_make_smob_type} or @code{scm_make_smob_type_mfpe} is -non-zero) using @code{scm_must_free} and returns the size of that -struct. @xref{Garbage Collecting Smobs}, for more details. +This is analagous to the Java finalization method-- it is invoked at an +unspecified time (when garbage collection occurs) after the object is +dead. The default free function frees the smob data (if the size of the +struct passed to @code{scm_make_smob_type} is non-zero) using +@code{scm_must_free} and returns the size of that struct. @xref{Garbage +Collecting Smobs}, for more details. @item print @c GJB:FIXME:: @var{exp} and @var{port} need to refer to a prototype of @@ -1414,9 +1416,9 @@ Guile will apply this function to each instance of the new type to print the value, as for @code{display} or @code{write}. The function should write a printed representation of @var{exp} on @var{port}, in accordance with the parameters in @var{pstate}. (For more information on print -states, see @ref{Port Data}.) The default print function prints @code{#} -where @code{NAME} is the first argument passed to @code{scm_make_smob_type} or -@code{scm_make_smob_type_mfpe}. +states, see @ref{Port Data}.) The default print function prints +@code{#} where @code{NAME} is the first argument passed to +@code{scm_make_smob_type}. @item equalp If Scheme code asks the @code{equal?} function to compare two instances @@ -1430,7 +1432,7 @@ never @code{equal?} unless they are @code{eq?}. To actually register the new smob type, call @code{scm_make_smob_type}: -@deftypefun long scm_make_smob_type (const char *name, scm_sizet size) +@deftypefun scm_bits_t scm_make_smob_type (const char *name, size_t size) This function implements the standard way of adding a new smob type, named @var{name}, with instance size @var{size}, to the system. The return value is a tag that is used in creating instances of the type. @@ -1449,35 +1451,39 @@ special function for a given type. Each function is intended to be used only zero or one time per type, and the call should be placed immediately following the call to @code{scm_make_smob_type}. -@deftypefun void scm_set_smob_mark (long tc, SCM (*mark) (SCM)) +@deftypefun void scm_set_smob_mark (scm_bits_t tc, SCM (*mark) (SCM)) This function sets the smob marking procedure for the smob type specified by the tag @var{tc}. @var{tc} is the tag returned by @code{scm_make_smob_type}. @end deftypefun -@deftypefun void scm_set_smob_free (long tc, scm_sizet (*free) (SCM)) +@deftypefun void scm_set_smob_free (scm_bits_t tc, size_t (*free) (SCM)) This function sets the smob freeing procedure for the smob type specified by the tag @var{tc}. @var{tc} is the tag returned by @code{scm_make_smob_type}. @end deftypefun -@deftypefun void scm_set_smob_print (long tc, int (*print) (SCM,SCM,scm_print_state*)) +@deftypefun void scm_set_smob_print (scm_bits_t tc, int (*print) (SCM, SCM, scm_print_state*)) This function sets the smob printing procedure for the smob type specified by the tag @var{tc}. @var{tc} is the tag returned by @code{scm_make_smob_type}. @end deftypefun -@deftypefun void scm_set_smob_equalp (long tc, SCM (*equalp) (SCM,SCM)) +@deftypefun void scm_set_smob_equalp (scm_bits_t tc, SCM (*equalp) (SCM, SCM)) This function sets the smob equality-testing predicate for the smob type specified by the tag @var{tc}. @var{tc} is the tag returned by @code{scm_make_smob_type}. @end deftypefun +In versions 1.4 and earlier, there was another way of creating smob +types, using @code{scm_make_smob_type_mfpe}. This function is now +deprecated and will be removed in a future version of Guile. You should +use the mechanism described above for new code, and change old code not +to use deprecated features. + Instead of using @code{scm_make_smob_type} and calling each of the individual @code{scm_set_smob_XXX} functions to register each special -function independently, you can use @code{scm_make_smob_type_mfpe} to +function independently, you could use @code{scm_make_smob_type_mfpe} to register all of the special functions at once as you create the smob -type@footnote{Warning: There is an ongoing discussion among the developers which -may result in deprecating @code{scm_make_smob_type_mfpe} in next release -of Guile.}: +type -@deftypefun long scm_make_smob_type_mfpe(const char *name, scm_sizet size, SCM (*mark) (SCM), scm_sizet (*free) (SCM), int (*print) (SCM, SCM, scm_print_state*), SCM (*equalp) (SCM, SCM)) +@deftypefun long scm_make_smob_type_mfpe(const char *name, size_t size, SCM (*mark) (SCM), size_t (*free) (SCM), int (*print) (SCM, SCM, scm_print_state*), SCM (*equalp) (SCM, SCM)) This function invokes @code{scm_make_smob_type} on its first two arguments to add a new smob type named @var{name}, with instance size @var{size} to the system. It also registers the @var{mark}, @var{free}, @var{print}, @var{equalp} smob @@ -1490,13 +1496,14 @@ nothing will be freed by the default free function. For example, here is how one might declare and register a new type representing eight-bit grayscale images: + @example #include -static long image_tag; +static scm_bits_t image_tag; void -init_image_type () +init_image_type (void) @{ image_tag = scm_make_smob_type ("image", sizeof (struct image)); scm_set_smob_mark (image_tag, mark_image); @@ -1509,34 +1516,44 @@ init_image_type () @node Creating Instances @subsection Creating Instances -Like other non-immediate types, smobs start with a cell whose @sc{car} -contains typing information, and whose @code{cdr} is free for any use. For smobs, -the @code{cdr} stores a pointer to the internal C structure holding the -smob-specific data. -To create an instance of a smob type following these standards, you should -use @code{SCM_NEWSMOB}: +Like other non-immediate types, smobs start with a cell whose first word +contains typing information, and whose remaining words are free for any +use. -@deftypefn Macro void SCM_NEWSMOB(SCM value,long tag,void *data) +After the header word containing the type code, smobs can have either +one, two or three additional words of data. These words store either a +pointer to the internal C structure holding the smob-specific data, or +the smob data itself. To create an instance of a smob type following +these standards, you should use @code{SCM_NEWSMOB}, @code{SCM_NEWSMOB2} +or @code{SCM_NEWSMOB3}:@footnote{The @code{SCM_NEWSMOB2} and +@code{SCM_NEWSMOB3} variants will allocate double cells and thus use +twice as much memory as smobs created by @code{SCM_NEWSMOB}.} + +@deftypefn Macro void SCM_NEWSMOB(SCM value, scm_bits_t tag, void *data) +@deftypefnx Macro void SCM_NEWSMOB2(SCM value, scm_bits_t tag, void *data1, void *data2) +@deftypefnx Macro void SCM_NEWSMOB3(SCM value, scm_bits_t tag, void *data1, void *data2, void *data3) Make @var{value} contain a smob instance of the type with tag @var{tag} -and smob data @var{data}. @var{value} must be previously declared -as C type @code{SCM}. +and smob data @var{data} (or @var{data1}, @var{data2}, and @var{data3}). +@var{value} must be previously declared as C type @code{SCM}. @end deftypefn Since it is often the case (e.g., in smob constructors) that you will create a smob instance and return it, there is also a slightly specialized macro for this situation: -@deftypefn Macro fn_returns SCM_RETURN_NEWSMOB(long tab, void *data) +@deftypefn Macro fn_returns SCM_RETURN_NEWSMOB(scm_bits_t tag, void *data) +@deftypefnx Macro fn_returns SCM_RETURN_NEWSMOB2(scm_bits_t tag, void *data1, void *data2) +@deftypefnx Macro fn_returns SCM_RETURN_NEWSMOB3(scm_bits_t tag, void *data1, void *data2, void *data3) This macro expands to a block of code that creates a smob instance of -the type with tag @var{tag} and smob data @var{data}, and returns -that @code{SCM} value. It should be the last piece of code in -a block. +the type with tag @var{tag} and smob data @var{data} (or @var{data1}, +@var{data2}, and @var{data3}), and returns that @code{SCM} value. It +should be the last piece of code in a block. @end deftypefn Guile provides the following functions for managing memory, which are often helpful when implementing smobs: -@deftypefun {char *} scm_must_malloc (long @var{len}, char *@var{what}) +@deftypefun {char *} scm_must_malloc (size_t @var{len}, char *@var{what}) Allocate @var{len} bytes of memory, using @code{malloc}, and return a pointer to them. @@ -1547,7 +1564,7 @@ reporting that we could not allocate @var{what}. This function also helps maintain statistics about the size of the heap. @end deftypefun -@deftypefun {char *} scm_must_realloc (char *@var{addr}, long @var{olen}, long @var{len}, char *@var{what}) +@deftypefun {char *} scm_must_realloc (char *@var{addr}, size_t @var{olen}, size_t @var{len}, char *@var{what}) Resize (and possibly relocate) the block of memory at @var{addr}, to have a size of @var{len} bytes, by calling @code{realloc}. Return a pointer to the new block. @@ -1625,7 +1642,7 @@ Functions that operate on smobs should aggressively check the types of their arguments, to avoid misinterpreting some other datatype as a smob, and perhaps causing a segmentation fault. Fortunately, this is pretty simple to do. The function need only verify that its argument is a -non-immediate, whose @sc{car} is the type tag returned by +non-immediate, whose first word is the type tag returned by @code{scm_make_smob_type}. For example, here is a simple function that operates on an image smob, @@ -1633,6 +1650,7 @@ and checks the type of its argument. We also present an expanded version of the @code{init_image_type} function, to make @code{clear_image} and the image constructor function @code{make_image} visible to Scheme code. + @example SCM clear_image (SCM image_smob) @@ -1656,24 +1674,21 @@ clear_image (SCM image_smob) void -init_image_type () +init_image_type (void) @{ image_tag = scm_make_smob_type ("image", sizeof (struct image)); scm_set_smob_mark (image_tag, mark_image); scm_set_smob_free (image_tag, free_image); scm_set_smob_print (image_tag, print_image); - scm_make_gsubr ("clear-image", 1, 0, 0, clear_image); - scm_make_gsubr ("make-image", 3, 0, 0, make_image); + scm_c_define_gsubr ("clear-image", 1, 0, 0, clear_image); + scm_c_define_gsubr ("make-image", 3, 0, 0, make_image); @} @end example -Note that checking types is a little more complicated during garbage -collection; see the description of @code{SCM_GCTYP16} in @ref{Garbage -Collecting Smobs}. - @c GJB:FIXME:: should talk about guile-snarf somewhere! + @node Garbage Collecting Smobs @subsection Garbage Collecting Smobs @@ -1695,12 +1710,12 @@ The two main portions of the collection are called the @dfn{mark phase}, during which the collector marks live objects, and the @dfn{sweep phase}, during which the collector frees all unmarked objects. -The mark bit of a smob lives in its @sc{car}, along with the smob's type -tag. When the collector encounters a smob, it sets the smob's mark bit, -and uses the smob's type tag to find the appropriate @code{mark} -function for that smob: the one listed in that smob's -@code{scm_smobfuns} structure. It then calls the @code{mark} function, -passing it the smob as its only argument. +The mark bit of a smob lives in a special memory region. When the +collector encounters a smob, it sets the smob's mark bit, and uses the +smob's type tag to find the appropriate @code{mark} function for that +smob: the one listed in that smob's @code{scm_smobfuns} structure. It +then calls the @code{mark} function, passing it the smob as its only +argument. The @code{mark} function is responsible for marking any other Scheme objects the smob refers to. If it does not do so, the objects' mark @@ -1719,6 +1734,7 @@ If @var{x}'s mark bit is already set, return immediately. Thus, here is how we might write the @code{mark} function for the image smob type discussed above: + @example @group SCM @@ -1768,18 +1784,18 @@ as its only argument. The @code{free} function must release any resources used by the smob. However, it need not free objects managed by the collector; the collector will take care of them. The return type of the @code{free} -function should be @code{scm_sizet}, an unsigned integral type; the +function should be @code{size_t}, an unsigned integral type; the @code{free} function should return the number of bytes released, to help the collector maintain statistics on the size of the heap. Here is how we might write the @code{free} function for the image smob type: @example -scm_sizet +size_t free_image (SCM image_smob) @{ struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); - scm_sizet size = image->width * image->height + sizeof (*image); + size_t size = image->width * image->height + sizeof (*image); free (image->pixels); free (image); @@ -1795,20 +1811,6 @@ itself. There is no way for smob code to be notified when collection is complete. -Note that, since a smob's mark bit lives in its @sc{car}, along with the -smob's type tag, the technique for checking the type of a smob described -in @ref{Typechecking} will not necessarily work during GC. If you need -to find out whether a given object is a particular smob type during GC, -use the following macro: - -@deftypefn Macro void SCM_GCTYP16 (SCM @var{x}) -Return the type bits of the smob @var{x}, with the mark bit clear. - -Use this macro instead of @code{SCM_CAR} to check the type of a smob -during GC. Usually, only code called by the smob's @code{mark} function -need worry about this. -@end deftypefn - It is usually a good idea to minimize the amount of processing done during garbage collection; keep @code{mark} and @code{free} functions very simple. Since collections occur at unpredictable times, it is easy @@ -1844,19 +1846,19 @@ make_image (SCM name, SCM s_width, SCM s_height) /* THESE TWO LINES HAVE CHANGED: */ image->name = scm_string_copy (name); - image->update_func = scm_make_gsubr (@dots{}); + image->update_func = scm_c_define_gsubr (@dots{}); SCM_NEWCELL (image_smob); - SCM_SETCDR (image_smob, image); - SCM_SETCAR (image_smob, image_tag); + SCM_SET_CELL_WORD_1 (image_smob, image); + SCM_SET_CELL_TYPE (image_smob, image_tag); return image_smob; @} @end example This code is incorrect. The calls to @code{scm_string_copy} and -@code{scm_make_gsubr} allocate fresh objects. Allocating any new object -may cause the garbage collector to run. If @code{scm_make_gsubr} +@code{scm_c_define_gsubr} allocate fresh objects. Allocating any new object +may cause the garbage collector to run. If @code{scm_c_define_gsubr} invokes a collection, the garbage collector has no way to discover that @code{image->name} points to the new string object; the @code{image} structure is not yet part of any Scheme object, so the garbage collector @@ -1865,16 +1867,17 @@ references to the new string object, it will free it, leaving @code{image} pointing to a dead object. A correct implementation might say, instead: + @example image->name = SCM_BOOL_F; image->update_func = SCM_BOOL_F; SCM_NEWCELL (image_smob); - SCM_SETCDR (image_smob, image); - SCM_SETCAR (image_smob, image_tag); + SCM_SET_CELL_WORD_1 (image_smob, image); + SCM_SET_CELL_TYPE (image_smob, image_tag); image->name = scm_string_copy (name); - image->update_func = scm_make_gsubr (@dots{}); + image->update_func = scm_c_define_gsubr (@dots{}); return image_smob; @end example @@ -1890,10 +1893,10 @@ preserved. @subsection Garbage Collecting Simple Smobs It is often useful to define very simple smob types --- smobs which have -no data to mark, other than the cell itself, or smobs whose @sc{cdr} is -simply an ordinary Scheme object, to be marked recursively. Guile -provides some functions to handle these common cases; you can use these -functions as your smob type's @code{mark} function, if your smob's +no data to mark, other than the cell itself, or smobs whose first data +word is simply an ordinary Scheme object, to be marked recursively. +Guile provides some functions to handle these common cases; you can use +this function as your smob type's @code{mark} function, if your smob's structure is simple enough. If the smob refers to no other Scheme objects, then no action is @@ -1901,16 +1904,22 @@ necessary; the garbage collector has already marked the smob cell itself. In that case, you can use zero as your mark function. @deftypefun SCM scm_markcdr (SCM @var{x}) -Mark the references in the smob @var{x}, assuming that @var{x}'s -@sc{cdr} contains an ordinary Scheme object, and @var{x} refers to no -other objects. This function simply returns @var{x}'s @sc{cdr}. +Mark the references in the smob @var{x}, assuming that @var{x}'s first +data word contains an ordinary Scheme object, and @var{x} refers to no +other objects. This function simply returns @var{x}'s first data word. + +This is only useful for simple smobs created by @code{SCM_NEWSMOB} or +@code{SCM_RETURN_NEWSMOB}, not for smobs allocated as double cells. @end deftypefun -@deftypefun scm_sizet scm_free0 (SCM @var{x}) +@deftypefun size_t scm_free0 (SCM @var{x}) Do nothing; return zero. This function is appropriate for smobs that use either zero or @code{scm_markcdr} as their marking functions, and refer to no heap storage, including memory managed by @code{malloc}, other than the smob's header cell. + +This function should not be needed anymore, because simply passing +@code{NULL} as the free function does the same. @end deftypefun @@ -1933,7 +1942,7 @@ Guile shell, extended with the datatypes described here.) #include #include -static long image_tag; +static scm_bits_t image_tag; struct image @{ int width, height; @@ -2001,11 +2010,11 @@ mark_image (SCM image_smob) return image->update_func; @} -static scm_sizet +static size_t free_image (SCM image_smob) @{ struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); - scm_sizet size = image->width * image->height + sizeof (struct image); + size_t size = image->width * image->height + sizeof (struct image); free (image->pixels); free (image); @@ -2027,15 +2036,15 @@ print_image (SCM image_smob, SCM port, scm_print_state *pstate) @} void -init_image_type () +init_image_type (void) @{ image_tag = scm_make_smob_type ("image", sizeof (struct image)); scm_set_smob_mark (image_tag, mark_image); scm_set_smob_free (image_tag, free_image); scm_set_smob_print (image_tag, print_image); - scm_make_gsubr ("clear-image", 1, 0, 0, clear_image); - scm_make_gsubr ("make-image", 3, 0, 0, make_image); + scm_c_define_gsubr ("clear-image", 1, 0, 0, clear_image); + scm_c_define_gsubr ("make-image", 3, 0, 0, make_image); @} @end example diff --git a/doc/deprecated.texi b/doc/deprecated.texi index f569e89fa..e69de29bb 100644 --- a/doc/deprecated.texi +++ b/doc/deprecated.texi @@ -1,137 +0,0 @@ -@node Deprecated -@chapter Deprecated - -@menu -* Shared And Read Only Strings:: -@end menu - - -@node Shared And Read Only Strings -@section Shared And Read Only Strings - -The procedures described in this section are deprecated because explicit -shared substrings are planned to disappear from Guile. - -Instead, all strings will be implemented using sharing internally, -combined with a copy-on-write strategy. Once internal string sharing -and copy-on-write have been implemented, it will be unnecessary to -preserve the concept of read only strings. - -@menu -* Shared Substrings:: Strings which share memory with each other. -* Read Only Strings:: Treating certain non-strings as strings. -@end menu - - -@node Shared Substrings -@subsection Shared Substrings - -Whenever you extract a substring using @code{substring}, the Scheme -interpreter allocates a new string and copies data from the old string. -This is expensive, but @code{substring} is so convenient for -manipulating text that programmers use it often. - -Guile Scheme provides the concept of the @dfn{shared substring} to -improve performance of many substring-related operations. A shared -substring is an object that mostly behaves just like an ordinary -substring, except that it actually shares storage space with its parent -string. - -@deffn primitive make-shared-substring str [start [end]] -Return a shared substring of @var{str}. The arguments are the -same as for the @code{substring} function: the shared substring -returned includes all of the text from @var{str} between -indexes @var{start} (inclusive) and @var{end} (exclusive). If -@var{end} is omitted, it defaults to the end of @var{str}. The -shared substring returned by @code{make-shared-substring} -occupies the same storage space as @var{str}. -@end deffn - -Example: - -@example -(define foo "the quick brown fox") -(define bar (make-shared-substring some-string 4 9)) - -foo => "t h e q u i c k b r o w n f o x" -bar =========> |---------| -@end example - -The shared substring @var{bar} is not given its own storage space. -Instead, the Guile interpreter notes internally that @var{bar} points to -a portion of the memory allocated to @var{foo}. However, @var{bar} -behaves like an ordinary string in most respects: it may be used with -string primitives like @code{string-length}, @code{string-ref}, -@code{string=?}. Guile makes the necessary translation between indices -of @var{bar} and indices of @var{foo} automatically. - -@example -(string-length? bar) @result{} 5 ; bar only extends from indices 4 to 9 -(string-ref bar 3) @result{} #\c ; same as (string-ref foo 7) -(make-shared-substring bar 2) - @result{} "ick" ; can even make a shared substring! -@end example - -Because creating a shared substring does not require allocating new -storage from the heap, it is a very fast operation. However, because it -shares memory with its parent string, a change to the contents of the -parent string will implicitly change the contents of its shared -substrings. - -@example -(string-set! foo 7 #\r) -bar @result{} "quirk" -@end example - -Guile considers shared substrings to be immutable. This is because -programmers might not always be aware that a given string is really a -shared substring, and might innocently try to mutate it without -realizing that the change would affect its parent string. (We are -currently considering a "copy-on-write" strategy that would permit -modifying shared substrings without affecting the parent string.) - -In general, shared substrings are useful in circumstances where it is -important to divide a string into smaller portions, but you do not -expect to change the contents of any of the strings involved. - - -@node Read Only Strings -@subsection Read Only Strings - -In previous versions of Guile, there was the idea that some string-based -primitives such as @code{string-append} could equally accept symbols as -arguments. For example, one could write - -@lisp -(string-append '/home/ 'vigilia) -@end lisp - -@noindent -and get @code{"/home/vigilia"} as the result. The term @dfn{read only -string} was adopted to describe the argument type expected by such -primitives. - -This idea has now been removed. The predicate @code{read-only-string?} -still exists, but deprecated, and is equivalent to - -@lisp -(lambda (x) (or (string? x) (symbol? x))) -@end lisp - -@noindent -But no Guile primitives now use @code{read-only-string?} to validate -their arguments. - -String-based primitives such as @code{string-append} -now require strings: - -@lisp -(string-append '/home/ 'vigilia) -@result{} -ERROR: Wrong type argument (expecting STRINGP): /home/ -@end lisp - -@deffn primitive read-only-string? obj -Return @code{#t} if @var{obj} is either a string or a symbol, -otherwise return @code{#f}. -@end deffn diff --git a/doc/indices.texi b/doc/indices.texi index 47b8d4cc2..e69de29bb 100644 --- a/doc/indices.texi +++ b/doc/indices.texi @@ -1,51 +0,0 @@ -@node Concept Index -@unnumbered Concept Index - -This index contains concepts, keywords and non-Schemey names for several -features, to make it easier to locate the desired sections. - -@printindex cp - - -@node Procedure Index -@unnumbered Procedure Index - -@c FIXME::martin: Review me! - -This is an alphabetical list of all the procedures and macros in Guile. - -When looking for a particular procedure, please look under its Scheme -name as well as under its C name. The C name can be constructed from -the Scheme names by a simple transformation described in the section -@xref{Transforming Scheme name to C name}. - -@printindex fn - - -@node Variable Index -@unnumbered Variable Index - -@c FIXME::martin: Review me! - -This is an alphabetical list of all the important variables and -constants in Guile. - -When looking for a particular variable or constant, please look under -its Scheme name as well as under its C name. The C name can be -constructed from the Scheme names by a simple transformation described -in the section @xref{Transforming Scheme name to C name}. - -@printindex vr - - -@c Spell out this node fully, because it is the last real node -@c in the top-level menu. Leaving off the pointers here causes -@c spurious makeinfo errors. -@node Type Index -@unnumbered Type Index - -This is an alphabetical list of all the important data types defined in -the Guile Programmers Manual. - -@printindex tp - diff --git a/doc/intro.texi b/doc/intro.texi index f12c3c980..55ab4f6bd 100644 --- a/doc/intro.texi +++ b/doc/intro.texi @@ -1,4 +1,4 @@ -@c $Id: intro.texi,v 1.10 2001-05-23 17:24:49 mgrabmue Exp $ +@c $Id: intro.texi,v 1.11 2001-05-30 20:32:05 mgrabmue Exp $ @page @node What is Guile? @@ -50,7 +50,6 @@ can program applications which use Guile in the language of their choice, rather than having the tastes of the application's author imposed on them. - @page @node Whirlwind Tour @chapter A Whirlwind Tour diff --git a/doc/scheme-data.texi b/doc/scheme-data.texi index 03d7043fc..5c2f77cf5 100755 --- a/doc/scheme-data.texi +++ b/doc/scheme-data.texi @@ -51,11 +51,11 @@ sections of this manual that cover them. * Keywords:: Self-quoting, customizable display keywords. * Pairs:: Scheme's basic building block. * Lists:: Special list functions supported by Guile. +* Vectors:: One-dimensional arrays of Scheme objects. * Records:: * Structures:: * Arrays:: Arrays of values. * Association Lists and Hash Tables:: Dictionary data types. -* Vectors:: One-dimensional arrays of Scheme objects. * Hooks:: User-customizable event lists. * Other Data Types:: Data types that are documented elsewhere. @end menu @@ -681,8 +681,9 @@ parameters. @c begin (texi-doc-string "guile" "-") @deffn primitive - z1 z2 @dots{} -If called without arguments, 0 is returned. Otherwise the sum of all but -the first argument are subtracted from the first argument. +If called with one argument @var{z1}, -@var{z1} is returned. Otherwise +the sum of all but the first argument are subtracted from the first +argument. @end deffn @c begin (texi-doc-string "guile" "*") @@ -693,7 +694,8 @@ returned. @c begin (texi-doc-string "guile" "/") @deffn primitive / z1 z2 @dots{} -Divide the first argument by the product of the remaining arguments. +Divide the first argument by the product of the remaining arguments. If +called with one argument @var{z1}, 1/@var{z1} is returned. @end deffn @c begin (texi-doc-string "guile" "abs") @@ -734,66 +736,66 @@ Round the number @var{x} towards infinity. @node Scientific @subsection Scientific Functions -@rnindex exp -@rnindex log -@rnindex sin -@rnindex cos -@rnindex tan -@rnindex asin -@rnindex acos -@rnindex atan -@rnindex sqrt -@rnindex expt The following procedures accept any kind of number as arguments, including complex numbers. +@rnindex sqrt @c begin (texi-doc-string "guile" "sqrt") @deffn procedure sqrt z Return the square root of @var{z}. @end deffn +@rnindex expt @c begin (texi-doc-string "guile" "expt") @deffn procedure expt z1 z2 Return @var{z1} raised to the power of @var{z2}. @end deffn +@rnindex sin @c begin (texi-doc-string "guile" "sin") @deffn procedure sin z Return the sine of @var{z}. @end deffn +@rnindex cos @c begin (texi-doc-string "guile" "cos") @deffn procedure cos z Return the cosine of @var{z}. @end deffn +@rnindex tan @c begin (texi-doc-string "guile" "tan") @deffn procedure tan z Return the tangent of @var{z}. @end deffn +@rnindex asin @c begin (texi-doc-string "guile" "asin") @deffn procedure asin z Return the arcsine of @var{z}. @end deffn +@rnindex acos @c begin (texi-doc-string "guile" "acos") @deffn procedure acos z Return the arccosine of @var{z}. @end deffn +@rnindex atan @c begin (texi-doc-string "guile" "atan") @deffn procedure atan z Return the arctangent of @var{z}. @end deffn +@rnindex exp @c begin (texi-doc-string "guile" "exp") @deffn procedure exp z Return e to the power of @var{z}, where e is the base of natural logarithms (2.71828@dots{}). @end deffn +@rnindex log @c begin (texi-doc-string "guile" "log") @deffn procedure log z Return the natural logarithm of @var{z}. @@ -1197,19 +1199,19 @@ Several characters have more than one name: @itemize @bullet @item -#\space, #\sp +@code{#\space}, @code{#\sp} @item -#\newline, #\nl +@code{#\newline}, @code{#\nl} @item -#\tab, #\ht +@code{#\tab}, @code{#\ht} @item -#\backspace, #\bs +@code{#\backspace}, @code{#\bs} @item -#\return, #\cr +@code{#\return}, @code{#\cr} @item -#\page, #\np +@code{#\page}, @code{#\np} @item -#\null, #\nul +@code{#\null}, @code{#\nul} @end itemize @rnindex char? @@ -1555,16 +1557,6 @@ text first, to avoid clobbering your data. Hence, when @var{str1} and @code{substring-move-right!} when moving text from left to right, and @code{substring-move-left!} otherwise. If @code{str1} and @samp{str2} are different strings, it does not matter which function you use. -@end deffn - -@deffn primitive substring-move-left! str1 start1 end1 str2 start2 -@end deffn -@deftypefn {C Function} SCM scm_substring_move_left_x (SCM @var{str1}, SCM @var{start1}, SCM @var{end1}, SCM @var{str2}, SCM @var{start2}) -[@strong{Note:} this is only valid if you've applied the strop patch]. - -Moves a substring of @var{str1}, from @var{start1} to @var{end1} -(@var{end1} is exclusive), into @var{str2}, starting at -@var{start2}. Allows overlapping strings. @example (define x (make-string 10 #\a)) @@ -1585,18 +1577,7 @@ y (substring-move-left! y 2 5 y 3) y @result{} "abccccg" -@end example -@end deftypefn -@deffn substring-move-right! str1 start1 end1 str2 start2 -@end deffn -@deftypefn {C Function} SCM scm_substring_move_right_x (SCM @var{str1}, SCM @var{start1}, SCM @var{end1}, SCM @var{str2}, SCM @var{start2}) -[@strong{Note:} this is only valid if you've applied the strop patch, if -it hasn't made it into the guile tree]. - -Does much the same thing as @code{substring-move-left!}, except it -starts moving at the end of the sequence, rather than the beginning. -@example (define y "abcdefg") (substring-move-right! y 2 5 y 0) y @@ -1607,7 +1588,7 @@ y y @result{} "abccdeg" @end example -@end deftypefn +@end deffn @node String Comparison @@ -1797,16 +1778,16 @@ The procedure @code{string-append} appends several strings together to form a longer result string. @rnindex string-append -@deffn primitive string-append . args +@deffn primitive string-append string1 @dots{} Return a newly allocated string whose characters form the -concatenation of the given strings, @var{args}. +concatenation of the given strings. @end deffn @node String Miscellanea @subsection String Miscellanea -This section contains several remaining string procedures. +This section contains all remaining string procedures. @deffn primitive string-ci->symbol str Return the symbol whose name is @var{str}. @var{str} is @@ -2598,7 +2579,8 @@ syntax extension to permit keywords to begin with @code{:} as well as * Why Use Keywords?:: Motivation for keyword usage. * Coding With Keywords:: How to use keywords. * Keyword Read Syntax:: Read syntax for keywords. -* Keyword Primitives:: Procedures for dealing with keywords. +* Keyword Procedures:: Procedures for dealing with keywords. +* Keyword Primitives:: The underlying primitive procedures. @end menu @node Why Use Keywords? @@ -2764,6 +2746,23 @@ ERROR: Unbound variable: :type ABORT: (unbound-variable) @end smalllisp +@node Keyword Procedures +@subsection Keyword Procedures + +@c FIXME::martin: Review me! + +The following procedures can be used for converting symbols to keywords +and back. + +@deffn procedure symbol->keyword sym +Return a keyword with the same characters as in @var{sym}. +@end deffn + +@deffn procedure keyword->symbol kw +Return a symbol with the same characters as in @var{kw}. +@end deffn + + @node Keyword Primitives @subsection Keyword Primitives @@ -2794,7 +2793,6 @@ Return the dash symbol for @var{keyword}. This is the inverse of @code{make-keyword-from-dash-symbol}. @end deffn - @node Pairs @section Pairs @@ -3295,6 +3293,144 @@ return value is not specified. @end deffn +@node Vectors +@section Vectors + +@c FIXME::martin: Review me! + +@c FIXME::martin: Should the subsections of this section be nodes +@c of their own, or are the resulting nodes too short, then? + +Vectors are sequences of Scheme objects. Unlike lists, the length of a +vector, once the vector is created, cannot be changed. The advantage of +vectors over lists is that the time required to access one element of a +vector is constant, whereas lists have an access time linear to the +index of the accessed element in the list. + +Note that the vectors documented in this section can contain any kind of +Scheme object, it is even possible to have different types of objects in +the same vector. + +@subsection Vector Read Syntax + +Vectors can literally be entered in source code, just like strings, +characters or some of the other data types. The read syntax for vectors +is as follows: A sharp sign (@code{#}), followed by an opening +parentheses, all elements of the vector in their respective read syntax, +and finally a closing parentheses. The following are examples of the +read syntax for vectors; where the first vector only contains numbers +and the second three different object types: a string, a symbol and a +number in hexidecimal notation. + +@lisp +#(1 2 3) +#("Hello" foo #xdeadbeef) +@end lisp + +@subsection Vector Predicates + +@rnindex vector? +@deffn primitive vector? obj +Return @code{#t} if @var{obj} is a vector, otherwise return +@code{#f}. +@end deffn + +@subsection Vector Constructors + +@rnindex make-vector +@deffn primitive make-vector k [fill] +Return a newly allocated vector of @var{k} elements. If a +second argument is given, then each element is initialized to +@var{fill}. Otherwise the initial contents of each element is +unspecified. +@end deffn + +@rnindex vector +@rnindex list->vector +@deffn primitive vector . l +@deffnx primitive list->vector l +Return a newly allocated vector whose elements contain the +given arguments. Analogous to @code{list}. + +@lisp +(vector 'a 'b 'c) @result{} #(a b c) +@end lisp +@end deffn + +@rnindex vector->list +@deffn primitive vector->list v +Return a newly allocated list of the objects contained in the +elements of @var{vector}. + +@lisp +(vector->list '#(dah dah didah)) @result{} (dah dah didah) +(list->vector '(dididit dah)) @result{} #(dididit dah) +@end lisp +@end deffn + +@subsection Vector Modification + +A vector created by any of the vector constructor procedures +(@pxref{Vectors}) documented above can be modified using the +following procedures. + +According to R5RS, using any of these procedures on literally entered +vectors is an error, because these vectors are considered to be +constant, although Guile currently does not detect this error. + +@rnindex vector-set! +@deffn primitive vector-set! vector k obj +@var{k} must be a valid index of @var{vector}. +@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}. +The value returned by @samp{vector-set!} is unspecified. +@lisp +(let ((vec (vector 0 '(2 2 2 2) "Anna"))) + (vector-set! vec 1 '("Sue" "Sue")) + vec) @result{} #(0 ("Sue" "Sue") "Anna") +(vector-set! '#(0 1 2) 1 "doe") @result{} @emph{error} ; constant vector +@end lisp +@end deffn + +@rnindex vector-fill! +@deffn primitive vector-fill! v fill +Store @var{fill} in every element of @var{vector}. The value +returned by @code{vector-fill!} is unspecified. +@end deffn + +@deffn primitive vector-move-left! vec1 start1 end1 vec2 start2 +Vector version of @code{substring-move-left!}. +@end deffn + +@deffn primitive vector-move-right! vec1 start1 end1 vec2 start2 +Vector version of @code{substring-move-right!}. +@end deffn + +@subsection Vector Selection + +These procedures return information about a given vector, such as the +size or what elements are contained in the vector. + +@rnindex vector-length +@deffn primitive vector-length vector +Returns the number of elements in @var{vector} as an exact integer. +@end deffn + +@rnindex vector-ref +@deffn primitive vector-ref vector k +@var{k} must be a valid index of @var{vector}. +@samp{Vector-ref} returns the contents of element @var{k} of +@var{vector}. +@lisp +(vector-ref '#(1 1 2 3 5 8 13 21) 5) @result{} 8 +(vector-ref '#(1 1 2 3 5 8 13 21) + (let ((i (round (* 2 (acos -1))))) + (if (inexact? i) + (inexact->exact i) + i))) @result{} 13 +@end lisp +@end deffn + + @node Records @section Records @@ -4818,145 +4954,6 @@ table into an a-list of key-value pairs. @end deffn -@node Vectors -@section Vectors - -@c FIXME::martin: Review me! - -@c FIXME::martin: This node should come before the non-standard data types. - -@c FIXME::martin: Should the subsections of this section be nodes -@c of their own, or are the resulting nodes too short, then? - -Vectors are sequences of Scheme objects. Unlike lists, the length of a -vector, once the vector is created, cannot be changed. The advantage of -vectors over lists is that the time required to access one element of a -vector is constant, whereas lists have an access time linear to the -index of the accessed element in the list. - -Note that the vectors documented in this section can contain any kind of -Scheme object, it is even possible to have different types of objects in -the same vector. - -@subsection Vector Read Syntax - -Vectors can literally be entered in source code, just like strings, -characters or some of the other data types. The read syntax for vectors -is as follows: A sharp sign (@code{#}), followed by an opening -parentheses, all elements of the vector in their respective read syntax, -and finally a closing parentheses. The following are examples of the -read syntax for vectors; where the first vector only contains numbers -and the second three different object types: a string, a symbol and a -number in hexidecimal notation. - -@lisp -#(1 2 3) -#("Hello" foo #xdeadbeef) -@end lisp - -@subsection Vector Predicates - -@rnindex vector? -@deffn primitive vector? obj -Return @code{#t} if @var{obj} is a vector, otherwise return -@code{#f}. -@end deffn - -@subsection Vector Constructors - -@rnindex make-vector -@deffn primitive make-vector k [fill] -Return a newly allocated vector of @var{k} elements. If a -second argument is given, then each element is initialized to -@var{fill}. Otherwise the initial contents of each element is -unspecified. -@end deffn - -@rnindex vector -@rnindex list->vector -@deffn primitive vector . l -@deffnx primitive list->vector l -Return a newly allocated vector whose elements contain the -given arguments. Analogous to @code{list}. - -@lisp -(vector 'a 'b 'c) @result{} #(a b c) -@end lisp -@end deffn - -@rnindex vector->list -@deffn primitive vector->list v -Return a newly allocated list of the objects contained in the -elements of @var{vector}. - -@lisp -(vector->list '#(dah dah didah)) @result{} (dah dah didah) -(list->vector '(dididit dah)) @result{} #(dididit dah) -@end lisp -@end deffn - -@subsection Vector Modification - -A vector created by any of the vector constructor procedures -(@pxref{Vectors}) documented above can be modified using the -following procedures. - -According to R5RS, using any of these procedures on literally entered -vectors is an error, because these vectors are considered to be -constant, although Guile currently does not detect this error. - -@rnindex vector-set! -@deffn primitive vector-set! vector k obj -@var{k} must be a valid index of @var{vector}. -@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}. -The value returned by @samp{vector-set!} is unspecified. -@lisp -(let ((vec (vector 0 '(2 2 2 2) "Anna"))) - (vector-set! vec 1 '("Sue" "Sue")) - vec) @result{} #(0 ("Sue" "Sue") "Anna") -(vector-set! '#(0 1 2) 1 "doe") @result{} @emph{error} ; constant vector -@end lisp -@end deffn - -@rnindex vector-fill! -@deffn primitive vector-fill! v fill -Store @var{fill} in every element of @var{vector}. The value -returned by @code{vector-fill!} is unspecified. -@end deffn - -@deffn primitive vector-move-left! vec1 start1 end1 vec2 start2 -Vector version of @code{substring-move-left!}. -@end deffn - -@deffn primitive vector-move-right! vec1 start1 end1 vec2 start2 -Vector version of @code{substring-move-right!}. -@end deffn - -@subsection Vector Selection - -These procedures return information about a given vector, such as the -size or what elements are contained in the vector. - -@rnindex vector-length -@deffn primitive vector-length vector -Returns the number of elements in @var{vector} as an exact integer. -@end deffn - -@rnindex vector-ref -@deffn primitive vector-ref vector k -@var{k} must be a valid index of @var{vector}. -@samp{Vector-ref} returns the contents of element @var{k} of -@var{vector}. -@lisp -(vector-ref '#(1 1 2 3 5 8 13 21) 5) @result{} 8 -(vector-ref '#(1 1 2 3 5 8 13 21) - (let ((i (round (* 2 (acos -1))))) - (if (inexact? i) - (inexact->exact i) - i))) @result{} 13 -@end lisp -@end deffn - @node Hooks @section Hooks diff --git a/doc/scheme-io.texi b/doc/scheme-io.texi index 942ffabf5..4152207bf 100644 --- a/doc/scheme-io.texi +++ b/doc/scheme-io.texi @@ -766,9 +766,9 @@ always returns the end-of-file object when read from. @deffn primitive %make-void-port mode Create and return a new void port. A void port acts like -/dev/null. The @var{mode} argument -specifies the input/output modes for this port: see the -documentation for @code{open-file} in @ref{File Ports}. +@code{/dev/null}. The @var{mode} argument specifies the input/output +modes for this port: see the documentation for @code{open-file} in +@ref{File Ports}. @end deffn diff --git a/doc/scheme-reading.texi b/doc/scheme-reading.texi index fab90ff72..e69de29bb 100644 --- a/doc/scheme-reading.texi +++ b/doc/scheme-reading.texi @@ -1,27 +0,0 @@ -@page -@node Further Reading -@chapter Further Reading - -@itemize @bullet -@item -Dorai Sitaram's online Scheme tutorial, @dfn{Teach Yourself Scheme in -Fixnum Days}, at -http://www.cs.rice.edu/~dorai/t-y-scheme/t-y-scheme.html. Includes a -nice explanation of continuations. - -@item -http://wombat.doc.ic.ac.uk/foldoc/. - -@item -The complete text of @dfn{Structure and Interpretation of Computer -Programs}, the classic introduction to computer science and Scheme by -Hal Abelson, Jerry Sussman and Julie Sussman, is now available online at -http://mitpress.mit.edu/sicp/sicp.html. This site also provides -teaching materials related to the book, and all the source code used in -the book, in a form suitable for loading and running. -@end itemize - - -@c Local Variables: -@c TeX-master: "guile.texi" -@c End: diff --git a/doc/scripts.texi b/doc/scripts.texi index 69b8d1661..e69de29bb 100644 --- a/doc/scripts.texi +++ b/doc/scripts.texi @@ -1,213 +0,0 @@ - -@node Guile Scripting -@chapter Guile Scripting - -Like AWK, Perl, or any shell, Guile can interpret script files. A Guile -script is simply a file of Scheme code with some extra information at -the beginning which tells the operating system how to invoke Guile, and -then tells Guile how to handle the Scheme code. - -@menu -* Invoking Guile:: How to start a Guile script. -* The Meta Switch:: Passing complex argument lists to Guile - from shell scripts. -@end menu - -@node Invoking Guile -@section Invoking Guile - -Here we describe Guile's command-line processing in detail. Guile -processes its arguments from left to right, recognizing the switches -described below. For examples, see @ref{Scripting Examples}. - -@table @code - -@item -s @var{script} @var{arg...} -Read and evaluate Scheme source code from the file @var{script}, as the -@code{load} function would. After loading @var{script}, exit. Any -command-line arguments @var{arg...} following @var{script} become the -script's arguments; the @code{command-line} function returns a list of -strings of the form @code{(@var{script} @var{arg...})}. - -@item -c @var{expr} @var{arg...} -Evaluate @var{expr} as Scheme code, and then exit. Any command-line -arguments @var{arg...} following @var{expr} become command-line arguments; the -@code{command-line} function returns a list of strings of the form -@code{(@var{guile} @var{arg...})}, where @var{guile} is the path of the -Guile executable. - -@item -- @var{arg...} -Run interactively, prompting the user for expressions and evaluating -them. Any command-line arguments @var{arg...} following the @code{--} -become command-line arguments for the interactive session; the -@code{command-line} function returns a list of strings of the form -@code{(@var{guile} @var{arg...})}, where @var{guile} is the path of the -Guile executable. - -@item -l @var{file} -Load Scheme source code from @var{file}, and continue processing the -command line. - -@item -e @var{function} -Make @var{function} the @dfn{entry point} of the script. After loading -the script file (with @code{-s}) or evaluating the expression (with -@code{-c}), apply @var{function} to a list containing the program name -and the command-line arguments --- the list provided by the -@code{command-line} function. - -A @code{-e} switch can appear anywhere in the argument list, but Guile -always invokes the @var{function} as the @emph{last} action it performs. -This is weird, but because of the way script invocation works under -POSIX, the @code{-s} option must always come last in the list. - -@xref{Scripting Examples}. - -@item -ds -Treat a final @code{-s} option as if it occurred at this point in the -command line; load the script here. - -This switch is necessary because, although the POSIX script invocation -mechanism effectively requires the @code{-s} option to appear last, the -programmer may well want to run the script before other actions -requested on the command line. For examples, see @ref{Scripting -Examples}. - -@item \ -Read more command-line arguments, starting from the second line of the -script file. @xref{The Meta Switch}. - -@item --emacs -Assume Guile is running as an inferior process of Emacs, and use a -special protocol to communicate with Emacs's Guile interaction mode. -This switch sets the global variable use-emacs-interface to @code{#t}. - -This switch is still experimental. - -@item --use-srfi=@var{list} -The option @code{--use-srfi} expects a comma-separated list of numbers, -each representing a SRFI number to be loaded into the interpreter -before starting evaluating a script file or the REPL. Additionally, -the feature identifier for the loaded SRFIs is recognized by -`cond-expand' when using this option. - -@example -guile --use-srfi=8,13 -@end example - -@item -h@r{, }--help -Display help on invoking Guile, and then exit. - -@item -v@r{, }--version -Display the current version of Guile, and then exit. - -@end table - - -@node The Meta Switch -@section The Meta Switch - -Guile's command-line switches allow the programmer to describe -reasonably complicated actions in scripts. Unfortunately, the POSIX -script invocation mechanism only allows one argument to appear on the -@samp{#!} line after the path to the Guile executable, and imposes -arbitrary limits on that argument's length. Suppose you wrote a script -starting like this: -@example -#!/usr/local/bin/guile -e main -s -!# -(define (main args) - (map (lambda (arg) (display arg) (display " ")) - (cdr args)) - (newline)) -@end example -The intended meaning is clear: load the file, and then call @code{main} -on the command-line arguments. However, the system will treat -everything after the Guile path as a single argument --- the string -@code{"-e main -s"} --- which is not what we want. - -As a workaround, the meta switch @code{\} allows the Guile programmer to -specify an arbitrary number of options without patching the kernel. If -the first argument to Guile is @code{\}, Guile will open the script file -whose name follows the @code{\}, parse arguments starting from the -file's second line (according to rules described below), and substitute -them for the @code{\} switch. - -Working in concert with the meta switch, Guile treats the characters -@samp{#!} as the beginning of a comment which extends through the next -line containing only the characters @samp{!#}. This sort of comment may -appear anywhere in a Guile program, but it is most useful at the top of -a file, meshing magically with the POSIX script invocation mechanism. - -Thus, consider a script named @file{/u/jimb/ekko} which starts like this: -@example -#!/usr/local/bin/guile \ --e main -s -!# -(define (main args) - (map (lambda (arg) (display arg) (display " ")) - (cdr args)) - (newline)) -@end example - -Suppose a user invokes this script as follows: -@example -$ /u/jimb/ekko a b c -@end example - -Here's what happens: -@itemize @bullet - -@item -the operating system recognizes the @samp{#!} token at the top of the -file, and rewrites the command line to: -@example -/usr/local/bin/guile \ /u/jimb/ekko a b c -@end example -This is the usual behavior, prescribed by POSIX. - -@item -When Guile sees the first two arguments, @code{\ /u/jimb/ekko}, it opens -@file{/u/jimb/ekko}, parses the three arguments @code{-e}, @code{main}, -and @code{-s} from it, and substitutes them for the @code{\} switch. -Thus, Guile's command line now reads: -@example -/usr/local/bin/guile -e main -s /u/jimb/ekko a b c -@end example - -@item -Guile then processes these switches: it loads @file{/u/jimb/ekko} as a -file of Scheme code (treating the first three lines as a comment), and -then performs the application @code{(main "/u/jimb/ekko" "a" "b" "c")}. - -@end itemize - - -When Guile sees the meta switch @code{\}, it parses command-line -argument from the script file according to the following rules: -@itemize @bullet - -@item -Each space character terminates an argument. This means that two -spaces in a row introduce an argument @code{""}. - -@item -The tab character is not permitted (unless you quote it with the -backslash character, as described below), to avoid confusion. - -@item -The newline character terminates the sequence of arguments, and will -also terminate a final non-empty argument. (However, a newline -following a space will not introduce a final empty-string argument; -it only terminates the argument list.) - -@item -The backslash character is the escape character. It escapes backslash, -space, tab, and newline. The ANSI C escape sequences like @code{\n} and -@code{\t} are also supported. These produce argument constituents; the -two-character combination @code{\n} doesn't act like a terminating -newline. The escape sequence @code{\@var{NNN}} for exactly three octal -digits reads as the character whose ASCII code is @var{NNN}. As above, -characters produced this way are argument constituents. Backslash -followed by other characters is not allowed. - -@end itemize diff --git a/doc/srfi-modules.texi b/doc/srfi-modules.texi index da2cefee0..d6ea9bfa5 100644 --- a/doc/srfi-modules.texi +++ b/doc/srfi-modules.texi @@ -72,6 +72,7 @@ support for a specified feature. The syntactic form @code{cond-expand}, which implements this means, has the following syntax. @example +@group --> (cond-expand +) | (cond-expand * (else )) @@ -84,6 +85,7 @@ which implements this means, has the following syntax. | (not ) --> +@end group @end example When evaluated, this form checks all clauses in order, until it finds @@ -218,6 +220,7 @@ the risk of variable capture. The syntax of a record type definition is: @example +@group -> (define-record-type ( ...) @@ -227,6 +230,7 @@ The syntax of a record type definition is: -> ( ) -> <... name> -> +@end group @end example Usage example: @@ -1375,6 +1379,7 @@ The syntax of the @code{case-lambda} form is defined in the following EBNF grammar. @example +@group --> (case-lambda ) @@ -1383,6 +1388,7 @@ EBNF grammar. --> (*) | (* . ) | +@end group @end example The value returned by a @code{case-lambda} form is a procedure which From fec1807cdbadd4692e45250a76211266bc6fbc44 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 30 May 2001 20:54:17 +0000 Subject: [PATCH 1207/2047] *** empty log message *** --- doc/scheme-data.texi | 1 - 1 file changed, 1 deletion(-) diff --git a/doc/scheme-data.texi b/doc/scheme-data.texi index 5c2f77cf5..df9517443 100755 --- a/doc/scheme-data.texi +++ b/doc/scheme-data.texi @@ -5092,7 +5092,6 @@ Convert the procedure list of @var{hook} to a list. @node Other Data Types @section Other Core Guile Data Types - @c Local Variables: @c TeX-master: "guile.texi" @c End: From 6662998f741ca886c8b2050085283ebcb7445f6f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 30 May 2001 23:47:49 +0000 Subject: [PATCH 1208/2047] * print.c (scm_simple_format): Support "~~" and "~%". Signal error for unsupported format controls and for superflous arguments. Thanks to David Skarda! * print.h, print.c (scm_print_symbol_name): Factored out of scm_iprin1. (scm_iprin1): Call it. * print.c (scm_print_symbol_name): Symbols whose name starts with `#' or `:' or ends with `:' are considered weird. --- libguile/print.c | 213 +++++++++++++++++++++++++++-------------------- libguile/print.h | 1 + 2 files changed, 124 insertions(+), 90 deletions(-) diff --git a/libguile/print.c b/libguile/print.c index 0ca427f29..2a0e4fa62 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -305,12 +305,96 @@ print_circref (SCM port,scm_print_state *pstate,SCM ref) scm_putc ('#', port); } +/* Print the name of a symbol. */ + +void +scm_print_symbol_name (const char *str, size_t len, SCM port) +{ + size_t pos; + size_t end; + int weird; + int maybe_weird; + size_t mw_pos = 0; + + pos = 0; + weird = 0; + maybe_weird = 0; + + /* XXX - Lots of weird symbol names are missed, such as "12" or + "'a". */ + + if (len == 0) + scm_lfwrite ("#{}#", 4, port); + else if (str[0] == '#' || str[0] == ':' || str[len-1] == ':') + { + scm_lfwrite ("#{", 2, port); + weird = 1; + } + + for (end = pos; end < len; ++end) + switch (str[end]) + { +#ifdef BRACKETS_AS_PARENS + case '[': + case ']': +#endif + case '(': + case ')': + case '"': + case ';': + case SCM_WHITE_SPACES: + case SCM_LINE_INCREMENTORS: + weird_handler: + if (maybe_weird) + { + end = mw_pos; + maybe_weird = 0; + } + if (!weird) + { + scm_lfwrite ("#{", 2, port); + weird = 1; + } + if (pos < end) + { + scm_lfwrite (str + pos, end - pos, port); + } + { + char buf[2]; + buf[0] = '\\'; + buf[1] = str[end]; + scm_lfwrite (buf, 2, port); + } + pos = end + 1; + break; + case '\\': + if (weird) + goto weird_handler; + if (!maybe_weird) + { + maybe_weird = 1; + mw_pos = pos; + } + break; + case '}': + case '#': + if (weird) + goto weird_handler; + break; + default: + break; + } + if (pos < end) + scm_lfwrite (str + pos, end - pos, port); + if (weird) + scm_lfwrite ("}#", 2, port); +} + /* Print generally. Handles both write and display according to PSTATE. */ SCM_GPROC(s_write, "write", 1, 1, 0, scm_write, g_write); SCM_GPROC(s_display, "display", 1, 1, 0, scm_display, g_display); - void scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) { @@ -457,84 +541,11 @@ taloop: scm_lfwrite (SCM_STRING_CHARS (exp), SCM_STRING_LENGTH (exp), port); break; case scm_tc7_symbol: - { - size_t pos; - size_t end; - size_t len; - char * str; - int weird; - int maybe_weird; - size_t mw_pos = 0; - - len = SCM_SYMBOL_LENGTH (exp); - str = SCM_SYMBOL_CHARS (exp); - pos = 0; - weird = 0; - maybe_weird = 0; - - if (len == 0) - scm_lfwrite ("#{}#", 4, port); - - for (end = pos; end < len; ++end) - switch (str[end]) - { -#ifdef BRACKETS_AS_PARENS - case '[': - case ']': -#endif - case '(': - case ')': - case '"': - case ';': - case SCM_WHITE_SPACES: - case SCM_LINE_INCREMENTORS: - weird_handler: - if (maybe_weird) - { - end = mw_pos; - maybe_weird = 0; - } - if (!weird) - { - scm_lfwrite ("#{", 2, port); - weird = 1; - } - if (pos < end) - { - scm_lfwrite (str + pos, end - pos, port); - } - { - char buf[2]; - buf[0] = '\\'; - buf[1] = str[end]; - scm_lfwrite (buf, 2, port); - } - pos = end + 1; - break; - case '\\': - if (weird) - goto weird_handler; - if (!maybe_weird) - { - maybe_weird = 1; - mw_pos = pos; - } - break; - case '}': - case '#': - if (weird) - goto weird_handler; - break; - default: - break; - } - if (pos < end) - scm_lfwrite (str + pos, end - pos, port); - scm_remember_upto_here_1 (exp); - if (weird) - scm_lfwrite ("}#", 2, port); - break; - } + scm_print_symbol_name (SCM_SYMBOL_CHARS (exp), + SCM_SYMBOL_LENGTH (exp), + port); + scm_remember_upto_here_1 (exp); + break; case scm_tc7_wvect: ENTER_NESTED_DATA (pstate, exp, circref); if (SCM_IS_WHVEC (exp)) @@ -942,25 +953,47 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, for (p = start; p != end; ++p) if (*p == '~') { - if (!SCM_CONSP (args)) - continue; - if (++p == end) - continue; - - if (*p == 'A' || *p == 'a') - writingp = 0; - else if (*p == 'S' || *p == 's') - writingp = 1; - else - continue; + break; + switch (*p) + { + case 'A': case 'a': + writingp = 0; + break; + case 'S': case 's': + writingp = 1; + break; + case '~': + scm_lfwrite (start, p - start, destination); + start = p + 1; + continue; + case '%': + scm_newline (destination); + start = p + 1; + continue; + default: + scm_misc_error (s_scm_simple_format, + "FORMAT: Unsupported format option ~~~A - use (ice-9 format) instead", + SCM_LIST1 (SCM_MAKE_CHAR (*p))); + + } + + + if (!SCM_CONSP (args)) + scm_misc_error (s_scm_simple_format, "FORMAT: Missing argument for ~~~A", + SCM_LIST1 (SCM_MAKE_CHAR (*p))); + scm_lfwrite (start, p - start - 1, destination); scm_prin1 (SCM_CAR (args), destination, writingp); args = SCM_CDR (args); start = p + 1; } + scm_lfwrite (start, p - start, destination); + if (args != SCM_EOL) + scm_misc_error (s_scm_simple_format, + "FORMAT: ~A superfluous arguments", SCM_LIST1 (scm_length (args))); if (fReturnString) answer = scm_strport_to_string (destination); diff --git a/libguile/print.h b/libguile/print.h index 25fa3d5db..a9c544292 100644 --- a/libguile/print.h +++ b/libguile/print.h @@ -107,6 +107,7 @@ void scm_free_print_state (SCM print_state); extern void scm_intprint (long n, int radix, SCM port); extern void scm_ipruk (char *hdr, SCM ptr, SCM port); extern void scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate); +extern void scm_print_symbol_name (const char *str, size_t len, SCM port); extern void scm_prin1 (SCM exp, SCM port, int writingp); extern void scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate); extern SCM scm_write (SCM obj, SCM port); From ca3140213bd4e5e51edc7ce29635ee6c93fb29ec Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 30 May 2001 23:48:13 +0000 Subject: [PATCH 1209/2047] (keyword_print): Use scm_print_symbol_name so that weird names are printed correctly. --- libguile/keywords.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/libguile/keywords.c b/libguile/keywords.c index f17eedacc..a3819c6e4 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -62,7 +62,9 @@ static int keyword_print (SCM exp, SCM port, scm_print_state *pstate) { scm_puts ("#:", port); - scm_puts(1 + SCM_SYMBOL_CHARS (SCM_CDR (exp)), port); + scm_print_symbol_name (1 + SCM_SYMBOL_CHARS (SCM_CDR (exp)), + SCM_SYMBOL_LENGTH (SCM_CDR (exp)), + port); return 1; } From 7eb5d7b2e4555aabb192537f468674ed097cb45c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 30 May 2001 23:48:36 +0000 Subject: [PATCH 1210/2047] *** empty log message *** --- libguile/ChangeLog | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 75a256180..10948b747 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,19 @@ +2001-05-31 Marius Vollmer + + * print.c (scm_simple_format): Support "~~" and "~%". Signal + error for unsupported format controls and for superflous + arguments. Thanks to David Skarda! + + * print.h, print.c (scm_print_symbol_name): Factored out of + scm_iprin1. + (scm_iprin1): Call it. + + * keywords.c (keyword_print): Use scm_print_symbol_name so that + weird names are printed correctly. + + * print.c (scm_print_symbol_name): Symbols whose name starts with + `#' or `:' or ends with `:' are considered weird. + 2001-05-30 Martin Grabmueller * numbers.c (scm_difference, scm_divide): Clarified comments for - From 305bf93c22fa348bf482f09d5e36cf32f9806122 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Thu, 31 May 2001 12:45:07 +0000 Subject: [PATCH 1211/2047] * Makefile.am (libguilereadline_la_SOURCES): removed readline.x from here (not needed). (CLEANFILES): added *.x (and removed from DISTCLEANFILES). (MKDEP): copied from libguile/Makefile.am. not that it matters now, but it will if we stop using BUILT_SOURCES for some reason. --- guile-readline/ChangeLog | 8 ++++++++ guile-readline/Makefile.am | 6 ++++-- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index b4d3a7893..8ae349f08 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,11 @@ +2001-05-31 Michael Livshin + + * Makefile.am (libguilereadline_la_SOURCES): removed readline.x + from here (not needed). + (CLEANFILES): added *.x (and removed from DISTCLEANFILES). + (MKDEP): copied from libguile/Makefile.am. not that it matters + now, but it will if we stop using BUILT_SOURCES for some reason. + 2001-05-24 Martin Grabmueller Make it compile with --disable-deprecated. diff --git a/guile-readline/Makefile.am b/guile-readline/Makefile.am index 0311a7213..0b3038f45 100644 --- a/guile-readline/Makefile.am +++ b/guile-readline/Makefile.am @@ -32,7 +32,7 @@ GUILE_SNARF = ../libguile/guile-snarf lib_LTLIBRARIES = libguilereadline.la -libguilereadline_la_SOURCES = readline.h readline.c +libguilereadline_la_SOURCES = readline.c BUILT_SOURCES = readline.x @@ -48,7 +48,9 @@ SUFFIXES = .x EXTRA_DIST = readline.scm -DISTCLEANFILES = *.x +MKDEP = gcc -M -MG $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) + +CLEANFILES = *.x dist-hook: (temp="/tmp/mangle-deps.$$$$"; \ From 13482e95a7aa9e95e7802978808a6fcb65c6dc3d Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Thu, 31 May 2001 12:45:32 +0000 Subject: [PATCH 1212/2047] * snarf-check-and-output-texi: new file. * Makefile.am (scripts_sources): add snarf-check-and-output-texi. --- scripts/ChangeLog | 6 ++ scripts/Makefile.am | 3 +- scripts/snarf-check-and-output-texi | 157 ++++++++++++++++++++++++++++ 3 files changed, 165 insertions(+), 1 deletion(-) create mode 100755 scripts/snarf-check-and-output-texi diff --git a/scripts/ChangeLog b/scripts/ChangeLog index 466a582fa..d647d06f9 100644 --- a/scripts/ChangeLog +++ b/scripts/ChangeLog @@ -1,3 +1,9 @@ +2001-05-31 Michael Livshin + + * snarf-check-and-output-texi: new file. + + * Makefile.am (scripts_sources): add snarf-check-and-output-texi. + 2001-05-14 Thien-Thi Nguyen * PROGRAM, display-commentary, doc-snarf, generate-autoload, diff --git a/scripts/Makefile.am b/scripts/Makefile.am index 3d5b126bf..373f03d69 100644 --- a/scripts/Makefile.am +++ b/scripts/Makefile.am @@ -29,7 +29,8 @@ scripts_sources = \ generate-autoload \ punify \ read-scheme-source \ - use2dot + use2dot \ + snarf-check-and-output-texi subpkgdatadir = $(pkgdatadir)/$(VERSION)/scripts subpkgdata_SCRIPTS = $(scripts_sources) diff --git a/scripts/snarf-check-and-output-texi b/scripts/snarf-check-and-output-texi new file mode 100755 index 000000000..4ba467272 --- /dev/null +++ b/scripts/snarf-check-and-output-texi @@ -0,0 +1,157 @@ +#!/bin/sh +# aside from this initial boilerplate, this is actually -*- scheme -*- code +main="(module-ref (resolve-module '(scripts snarf-check-and-output-texi)) 'main)" +exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" +!# +;;; snarf-check-and-output-texi --- called by the doc snarfer. + +;; Copyright (C) 2001 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA + +;;; Author: Michael Livshin + +;;; Code: + +(define-module (scripts snarf-check-and-output-texi) + :export (snarf-check-and-output-texi)) + +(define *file* #f) +(define *line* #f) +(define *function-name* #f) +(define *snarf-type* #f) +(define *args* #f) +(define *sig* #f) +(define *docstring* #f) + +(define (doc-block args) + (let loop ((args args)) + (if (not (null? args)) + (let ((arg (car args))) + (if (not (null? arg)) + (begin + + (case (car arg) + + ((fname) + (set! *function-name* (cdr arg))) + + ((type) + (set! *snarf-type* (cdr arg))) + + ((location) + (set! *file* (cadr arg)) + (set! *line* (cddr arg))) + + ((arglist) + (set! *args* (cdr arg))) + + ((argsig) + (set! *sig* (cdr arg))) + + ((docstring) + (set! *docstring* (cdr arg))) + + (else + (error (format #f "unknown doc attribute: ~A" (car arg))))))) + (loop (cdr args))))) + (output-doc-block)) + +(define (doc-check arg) + (if (not (null? arg)) + + (case (car arg) + + ((argpos) + (let* ((name (cadr arg)) + (pos (caddr arg)) + (line (cadddr arg)) + (idx (list-index *args* name))) + (cond + ((not idx)) + ((not (number? pos))) + ((= 0 pos)) + ((not (= (+ idx 1) pos)) + (display (format #f "~A:~A: wrong position for argument \"~A\": ~A (should be ~A)\n" + *file* line name pos (+ idx 1)) + (current-error-port)))))) + + (else + (error (format #f "unknown check: ~A" (car arg))))))) + +(define (output-doc-block) + (let* ((req (car *sig*)) + (opt (cadr *sig*)) + (var (caddr *sig*)) + (all (+ req opt var))) + (if (and (not (eqv? *snarf-type* 'register)) + (not (= (length *args*) all))) + (error (format #f "~A:~A: ~A's C implementation takes ~A args (should take ~A)" + *file* *line* name (length *args*) all))) + (let ((nice-sig + (if (eq? *snarf-type* 'register) + *function-name* + (with-output-to-string + (lambda () + (format #t "~A" *function-name*) + (let loop-req ((r 0)) + (if (< r req) + (begin + (format #t " ~A" (list-ref *args* r)) + (loop-req (+ 1 r))) + (begin + (if (> opt 0) + (format #t "~A[" (if (> req 0) " " ""))) + (let loop-opt ((o 0) (space #f)) + (if (< o opt) + (begin + (format #t "~A~A" (if space " " "") + (list-ref *args* (+ r o))) + (loop-opt (+ 1 o) #t)) + (begin + (if (> opt 0) + (format #t "]")) + (if (> var 0) + (format #t "~A. ~A" (if (< var all) " " "") + (car (last-pair *args*))))))))))))))) + (format #t "\n ~A\n" *function-name*) + (format #t "@c snarfed from ~A:~A\n" *file* *line*) + (format #t "@deffn primitive ~A\n" nice-sig) + (let loop ((strings *docstring*)) + (if (not (null? strings)) + (begin + (display (car strings)) + (loop (cdr strings))))) + (display "\n@end deffn\n")))) + +(define (snarf-check-and-output-texi) + (let loop ((form (read))) + (if (not (eof-object? form)) + (begin + (if (not (null? form)) + + (case (car form) + + ((doc-block) + (doc-block (cdr form))) + + ((doc-check) + (doc-check (cdr form))) + + (else (error (format #f "unknown doc command: ~A" (car form)))))) + (loop (read)))))) + +(define main snarf-check-and-output-texi) From 998c3141ac91d2bac1730b86fe51856c5805994a Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Thu, 31 May 2001 12:47:24 +0000 Subject: [PATCH 1213/2047] * Makefile.am (MKDEP): copied from libguile/Makefile.am, just in case. (CLEANFILES): added *.x (and removed from DISTCLEANFILES) --- srfi/ChangeLog | 6 ++++++ srfi/Makefile.am | 4 +++- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index e18ad7170..a9ef7e535 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,9 @@ +2001-05-31 Michael Livshin + + * Makefile.am (MKDEP): copied from libguile/Makefile.am, just in + case. + (CLEANFILES): added *.x (and removed from DISTCLEANFILES) + 2001-05-28 Michael Livshin * srfi-19.scm: removed a stray open parenthesis. (thanks to diff --git a/srfi/Makefile.am b/srfi/Makefile.am index 17108567e..c454b1913 100644 --- a/srfi/Makefile.am +++ b/srfi/Makefile.am @@ -53,9 +53,11 @@ EXTRA_DIST = $(srfi_DATA) GUILE_SNARF = ../libguile/guile-snarf +MKDEP = gcc -M -MG $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) + SUFFIXES = .x .c.x: $(GUILE_SNARF) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \ || { rm $@; false; } -DISTCLEANFILES = *.x +CLEANFILES = *.x From c99f96051839bbc87146e32e7462d61e1b4768d3 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Thu, 31 May 2001 13:15:54 +0000 Subject: [PATCH 1214/2047] * guile-snarf-docs.in, guile-snarf-docs-texi.in, filter-doc-snarfage.c: new files. * Makefile.am: add stuff to [build,] use and distribute guile-snarf-docs, guile-snarf-docs-texi, guile_filter_doc_snarfage. * guile-snarf.in: grok the new snarf output. * snarf.h: make the output both texttools- and `read'-friendly. * guile-doc-snarf.in (bindir): reimplement in terms of guile-snarf and guile-snarf-docs. (should also deprecate, I guess. maybe not). --- libguile/ChangeLog | 16 ++ libguile/Makefile.am | 33 +++-- libguile/filter-doc-snarfage.c | 234 ++++++++++++++++++++++++++++++ libguile/guile-doc-snarf.in | 23 +-- libguile/guile-snarf-docs-texi.in | 60 ++++++++ libguile/guile-snarf-docs.in | 32 ++++ libguile/guile-snarf.in | 4 +- libguile/snarf.h | 48 +++--- 8 files changed, 396 insertions(+), 54 deletions(-) create mode 100644 libguile/filter-doc-snarfage.c create mode 100755 libguile/guile-snarf-docs-texi.in create mode 100755 libguile/guile-snarf-docs.in diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 10948b747..f24f54e68 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,19 @@ +2001-05-31 Michael Livshin + + * guile-snarf-docs.in, guile-snarf-docs-texi.in, + filter-doc-snarfage.c: new files. + + * Makefile.am: add stuff to [build,] use and distribute + guile-snarf-docs, guile-snarf-docs-texi, guile_filter_doc_snarfage. + + * guile-snarf.in: grok the new snarf output. + + * snarf.h: make the output both texttools- and `read'-friendly. + + * guile-doc-snarf.in (bindir): reimplement in terms of guile-snarf + and guile-snarf-docs. (should also deprecate, I guess. maybe + not). + 2001-05-31 Marius Vollmer * print.c (scm_simple_format): Support "~~" and "~%". Signal diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 5a8cc58e1..baf34f5aa 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -32,12 +32,14 @@ ETAGS_ARGS = --regex='/SCM_\(GLOBAL_\)?\(G?PROC\|G?PROC1\|SYMBOL\|VCELL\|CONST_L --regex='/[ \t]*SCM_[G]?DEFINE1?[ \t]*(\([^,]*\),[^,]*/\1/' lib_LTLIBRARIES = libguile.la -bin_PROGRAMS = guile +bin_PROGRAMS = guile guile_filter_doc_snarfage guile_SOURCES = guile.c guile_LDADD = libguile.la ${THREAD_LIBS_LOCAL} guile_LDFLAGS = @DLPREOPEN@ +guile_filter_doc_snarfage_SOURCES = filter-doc-snarfage.c + libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ chars.c continuations.c debug.c deprecation.c dynl.c dynwind.c \ environments.c eq.c error.c eval.c evalext.c extensions.c \ @@ -87,7 +89,7 @@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \ EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@ BUILT_SOURCES = cpp_err_symbols.c cpp_sig_symbols.c libpath.h scmconfig.h \ - $(DOT_X_FILES) $(EXTRA_DOT_X_FILES) $(DOT_DOC_FILES) + $(DOT_X_FILES) $(EXTRA_DOT_X_FILES) EXTRA_libguile_la_SOURCES = _scm.h \ alloca.c inet_aton.c memmove.c putenv.c strerror.c \ @@ -95,6 +97,8 @@ EXTRA_libguile_la_SOURCES = _scm.h \ filesys.c posix.c net_db.c socket.c \ ramap.c unif.c debug-malloc.c +Makefile: $(DOT_X_FILES) + ## In next release, threads will be factored out of libguile. ## Until then, the machine specific headers is a temporary kludge. OMIT_DEPENDENCIES = libguile.h ltdl.h \ @@ -133,10 +137,13 @@ modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h boolean.h \ ## and not a header -- headers are included in the distribution. modinclude_DATA = scmconfig.h -bin_SCRIPTS = guile-snarf guile-doc-snarf guile-snarf.awk guile-func-name-check +bin_SCRIPTS = guile-snarf guile-doc-snarf guile-snarf-docs \ + guile-snarf-docs-texi guile-func-name-check EXTRA_DIST = ChangeLog-gh ChangeLog-scm ChangeLog-threads cpp_signal.c \ cpp_errno.c cpp_err_symbols.in cpp_sig_symbols.in cpp_cnvt.awk +# $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \ +# guile-procedures.txt guile.texi ## FIXME: Consider using timestamp file, to avoid unnecessary rebuilds. libpath.h: $(srcdir)/Makefile.in $(top_builddir)/config.status @@ -178,22 +185,24 @@ libpath.h: $(srcdir)/Makefile.in $(top_builddir)/config.status SUFFIXES = .x .doc .c.x: - ./guile-doc-snarf $< $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \ + ./guile-snarf $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \ || { rm $@; false; } -.x.doc: - ./guile-doc-snarf $(srcdir)/$*.c $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $(srcdir)/$*.c > /dev/null \ +.c.doc: + -(test -n "${AWK+set}" || AWK="@AWK@"; ${AWK} -f ./guile-func-name-check $<) + ./guile-snarf-docs $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \ || { rm $@; false; } -*.x: snarf.h guile-doc-snarf.in -*.doc: guile-snarf.awk.in +$(DOT_X_FILES) $(EXTRA_DOT_DOC_FILES): snarf.h guile-snarf.in + +$(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES): snarf.h guile-snarf-docs.in guile_filter_doc_snarfage error.x: cpp_err_symbols.c posix.x: cpp_sig_symbols.c load.x: libpath.h -guile.texi: $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) - echo "@paragraphindent 0" > $@ - cat *.doc >> $@ +guile.texi: $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) guile-snarf-docs-texi.in guile + ./guile-snarf-docs-texi $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) > $@ \ + || { rm $@; false; } guile-procedures.txt: guile.texi rm -f $@ @@ -250,4 +259,4 @@ MOSTLYCLEANFILES = \ cpp_err_symbols_here cpp_err_symbols_diff cpp_err_symbols_new \ cpp_sig_symbols_here cpp_sig_symbols_diff cpp_sig_symbols_new -CLEANFILES = libpath.h *.x *.doc +CLEANFILES = libpath.h *.x *.doc guile-procedures.txt guile.texi diff --git a/libguile/filter-doc-snarfage.c b/libguile/filter-doc-snarfage.c new file mode 100644 index 000000000..c403b0ebf --- /dev/null +++ b/libguile/filter-doc-snarfage.c @@ -0,0 +1,234 @@ +#include +#include +#include + +static void init_state_machine (void); + +static void process (void); + +static void check_end_conditions (void); + +int +main (int argc, char *argv[]) +{ + init_state_machine (); + process (); + check_end_conditions (); + + return EXIT_SUCCESS; +} + +typedef enum state_t + { + SKIP, + SKIP_COOKIE, + + MULTILINE, + + MULTILINE_COOKIE, + STRINGS, + + SINGLELINE, + + } state_t; + +state_t state = SKIP; + +static void die (const char *msg); +static void process_strings (void); +static void process_single_line (void); + +void +process () +{ + int want_cookie = 0; + int ch; + + while ((ch = getc (stdin)) != EOF) { + char c = (char)ch; + + switch (state) { + case SKIP: + if (c == '^') { + if (want_cookie) { + state = SKIP_COOKIE; + want_cookie = 0; + } else + want_cookie = 1; + } else + want_cookie = 0; + break; + case SKIP_COOKIE: + switch (c) { + case '[': + fputs ("(doc-check\n", stdout); + state = SINGLELINE; + break; + case '{': + fputs ("(doc-block (\n", stdout); + state = MULTILINE; + break; + default: + die ("bad snarf cookie"); + break; + } + break; + case MULTILINE: + if (c == '^') { + if (want_cookie) { + fputs ("\n)\n(\n", stdout); + state = MULTILINE_COOKIE; + want_cookie = 0; + } else + want_cookie = 1; + } else { + want_cookie = 0; + putc (c, stdout); + } + break; + case MULTILINE_COOKIE: + switch (c) { + case '(': + state = STRINGS; + break; + case ' ': + state = MULTILINE; + break; + case '}': + fputs ("))\n", stdout); + state = SKIP; + break; + default: + die ("bad snarf cookie in multiline context"); + break; + } + break; + case STRINGS: + process_strings (); + state = MULTILINE; + break; + case SINGLELINE: + process_single_line (); + fputs ("\n)\n", stdout); + state = SKIP; + break; + default: + abort (); + break; + } + } +} + +void +init_state_machine () +{} + +void +die (const char *msg) +{ + fprintf (stderr, "%s\n", msg); + exit (EXIT_FAILURE); +} + +void +check_end_conditions () +{ + if (state != SKIP) + die ("something is unterminated"); +} + +typedef enum str_state_t + { + STR_SKIP, + STR_INSIDE, + STR_HAD_ESCAPE, + STR_EXIT + } str_state_t; + +void +process_strings () +{ + /* read well-formed strings up to a ')', and break them up in the + process if they are too long */ + int count = 0; + int ch; + str_state_t state = STR_SKIP; + + fputs ("docstring\n", stdout); + +#define PUTC(c) putc (c, stdout); if (++count >= 512) { fputs ("\"\nstring \"", stdout); count = 0; } + + while (!(((ch = getc (stdin)) == EOF) + || (state == STR_EXIT))) { + char c = (char) ch; + + switch (state) { + case STR_SKIP: + switch (c) { + case '"': + fputs ("\nstring ", stdout); + count = 0; + PUTC (c); + state = STR_INSIDE; + break; + case ')': + state = STR_EXIT; + break; + default: + if (!isspace (c)) + die ("stray stuff where should be only strings"); + break; + } + break; + case STR_INSIDE: + switch (c) { + case '\\': + putc (c, stdout); + ++count; + state = STR_HAD_ESCAPE; + break; + case '"': + putc (c, stdout); + state = STR_SKIP; + break; + default: + PUTC (c); + break; + } + break; + case STR_HAD_ESCAPE: + PUTC (c); + state = STR_INSIDE; + break; + default: + abort (); + break; + } + } + + if (state != STR_EXIT) + die ("docstrings don't terminate"); +} + +void +process_single_line () +{ + /* read up to a ']' */ + int ch; + while (!(((ch = getc (stdin)) == EOF) + || ((char) ch == ']'))) { + char c = (char) ch; + + putc (c, stdout); + } + + if ((char) ch != ']') + die ("bad checking snarfage"); +} + + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/guile-doc-snarf.in b/libguile/guile-doc-snarf.in index 954075592..36e1a9453 100755 --- a/libguile/guile-doc-snarf.in +++ b/libguile/guile-doc-snarf.in @@ -18,33 +18,18 @@ # the Free Software Foundation, Inc., 59 Temple Place, Suite 330, # Boston, MA 02111-1307 USA -fullfilename=$1; shift +fullfilename=$1 # strip path to source directory filename=`basename $fullfilename` -# we need to be sure that the .x file exists -# since the .c/.cc file may include it -# (the old guile-snarf did not have this problem -# because the makefile redirects output to the .x file -# which creates the file before the inclusion occurs) -# --12/12/99 gjb no_ext=`echo $filename | sed 's/\.[^.]*$//g'` dot_doc=${no_ext}.doc -temp="/tmp/snarf.$$" -trap "rm -f $temp" 0 1 2 15 +bindir=`dirname $0` -## Let the user override the preprocessor & awk autoconf found. -test -n "${CPP+set}" || CPP="@CPP@" -test -n "${AWK+set}" || AWK="@AWK@" +${bindir}/guile-snarf-docs "$@" > $dot_doc -## Must run guile-func-name-check on the unpreprocessed source -${AWK} -f `dirname $0`/guile-func-name-check "$fullfilename" - -## We must use a temporary file here, instead of a pipe, because we -## need to know if CPP exits with a non-zero status. -${CPP} -DSCM_MAGIC_SNARFER "$@" > ${temp} || exit $? -cut -c1-1023 ${temp} | ${AWK} -f `dirname $0`/guile-snarf.awk ${dot_doc} +${bindir}/guile-snarf "$@" # guile-doc-snarf ends here diff --git a/libguile/guile-snarf-docs-texi.in b/libguile/guile-snarf-docs-texi.in new file mode 100755 index 000000000..2dbc4aecc --- /dev/null +++ b/libguile/guile-snarf-docs-texi.in @@ -0,0 +1,60 @@ +#!/bin/sh +# Massage the snarfed docs to texinfo. +# +# Copyright (C) 1996, 1997, 1998, 1999, 2000 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 +# the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +# the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +# Boston, MA 02111-1307 USA + +srcdir=@srcdir@ +bindir=`dirname $0` + +bindir=`(cd $bindir; pwd)` +srcdir=`(cd $srcdir; pwd)` + +temp0="/tmp/snarf.0.$$" +temp1="/tmp/snarf.1.$$" +trap "rm -f $temp0 $temp1" 0 1 2 15 + +# cat all the small files together: +cat "$@" > ${temp1} + +## massage the arglists + +# lose the SCM types and commas, and texi-quote @'s in names and args +< ${temp1} sed -e '/^arglist/s/[ ]*SCM[ ]*//g' \ + -e '/^arglist/s/,/ /g' \ + -e '/^arglist/s/([ ]*void[ ]*)/()/g' \ + -e '/^fname/s/@/@@/g' \ + -e '/^arglist/s/@/@@/g' \ + > ${temp0} + +# nothing to do with the docstrings +< ${temp0} sed -e 's/^string //' > ${temp1} + +# we're too lame to check argpos assertions other then for straight names, so... +< ${temp1} sed -e 's/^argpos.*[(\[].*//' > ${temp0} + +echo "@paragraphindent 0" + +# now run the script that will generate texinfo +main='(module-ref (resolve-module '\''(scripts snarf-check-and-output-texi)) '\''main)' +apply_main="(apply $main (cdr (command-line)))" + +if [ `basename ${bindir}` = libguile ]; then + GUILE_LOAD_PATH=${srcdir}/.. ${bindir}/guile -c "${apply_main}" < ${temp0} +else + ${bindir}/guile -c "${apply_main}" < ${temp0} +fi diff --git a/libguile/guile-snarf-docs.in b/libguile/guile-snarf-docs.in new file mode 100755 index 000000000..338b710d7 --- /dev/null +++ b/libguile/guile-snarf-docs.in @@ -0,0 +1,32 @@ +#!/bin/sh +# Extract the doc stuff for builtin things. +# +# Copyright (C) 1996, 1997, 1998, 1999, 2000 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 +# the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +# the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +# Boston, MA 02111-1307 USA + +bindir=`dirname $0` + +temp="/tmp/snarf.$$" +trap "rm -f $temp" 0 1 2 15 + +## Let the user override the preprocessor autoconf found. +test -n "${CPP+set}" || CPP="@CPP@" + +## We must use a temporary file here, instead of a pipe, because we +## need to know if CPP exits with a non-zero status. +${CPP} -DSCM_MAGIC_SNARF_DOCS "$@" > ${temp} || exit $? +< ${temp} ${bindir}/guile_filter_doc_snarfage diff --git a/libguile/guile-snarf.in b/libguile/guile-snarf.in index d41f34c70..41542dcfc 100644 --- a/libguile/guile-snarf.in +++ b/libguile/guile-snarf.in @@ -26,8 +26,8 @@ test -n "${CPP+set}" || CPP="@CPP@" ## We must use a temporary file here, instead of a pipe, because we ## need to know if CPP exits with a non-zero status. -${CPP} -DSCM_MAGIC_SNARFER "$@" > ${temp} || exit $? -< ${temp} grep "^ *SCM_SNARF_INIT_START" | sed -e "s/^ *SCM_SNARF_INIT_START//" -e 's/SCM_SNARF_DOC_START.*$//g' +${CPP} -DSCM_MAGIC_SNARF_INITS "$@" > ${temp} || exit $? +< ${temp} grep "^ *\^\^" | sed -e "s/^ *\^\^//" ## Apparently, AIX's preprocessor is unhappy if you try to #include an ## empty file. diff --git a/libguile/snarf.h b/libguile/snarf.h index ac7a59baa..045e63441 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -76,14 +76,28 @@ * line, if any. */ -#ifndef SCM_MAGIC_SNARFER +#ifdef SCM_MAGIC_SNARF_INITS +# define SCM_SNARF_HERE(X) +# define SCM_SNARF_INIT(X) ^^ X +# define SCM_SNARF_DOCS(TYPE, FNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING) +#else +# ifdef SCM_MAGIC_SNARF_DOCS +# define SCM_SNARF_HERE(X) +# define SCM_SNARF_INIT(X) +# define SCM_SNARF_DOCS(TYPE, FNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING) \ +^^{ \ +^^ fname . FNAME \ +^^ type . TYPE \ +^^ location __FILE__ . __LINE__ \ +^^ arglist . ARGLIST \ +^^ argsig REQ OPT VAR \ +^^(DOCSTRING) \ +^^} +# else # define SCM_SNARF_HERE(X) X # define SCM_SNARF_INIT(X) -# define SCM_SNARF_DOCS(X) -#else -# define SCM_SNARF_HERE(X) -# define SCM_SNARF_INIT(X) SCM_SNARF_INIT_START X -# define SCM_SNARF_DOCS(X) X +# define SCM_SNARF_DOCS(TYPE, FNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING) +# endif #endif #define SCM_DEFINE(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \ @@ -95,10 +109,7 @@ SCM_SNARF_INIT(\ scm_c_define_gsubr (s_ ## FNAME, REQ, OPT, VAR, \ (SCM_FUNC_CAST_ARBITRARY_ARGS) FNAME); \ )\ -SCM_SNARF_DOCS(\ -SCM_SNARF_DOC_STARTP PRIMNAME #ARGLIST | REQ | OPT | VAR | __FILE__:__LINE__ | \ - SCM_SNARF_DOCSTRING_START DOCSTRING SCM_SNARF_DOCSTRING_END \ -) +SCM_SNARF_DOCS(primitive, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING) #define SCM_DEFINE1(FNAME, PRIMNAME, TYPE, ARGLIST, DOCSTRING) \ SCM_SNARF_HERE(\ @@ -106,10 +117,7 @@ static const char s_ ## FNAME [] = PRIMNAME; \ SCM FNAME ARGLIST\ )\ SCM_SNARF_INIT(scm_c_define_subr (s_ ## FNAME, TYPE, FNAME); ) \ -SCM_SNARF_DOCS(\ -SCM_SNARF_DOC_START1 PRIMNAME #ARGLIST | 2 | 0 | 0 | __FILE__:__LINE__ | \ - SCM_SNARF_DOCSTRING_START DOCSTRING SCM_SNARF_DOCSTRING_END \ -) +SCM_SNARF_DOCS(1, PRIMNAME, ARGLIST, 2, 0, 0, DOCSTRING) #define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \ SCM_SNARF_HERE(static const char RANAME[]=STR) \ @@ -120,10 +128,8 @@ SCM_SNARF_INIT(scm_c_define_gsubr (RANAME, REQ, OPT, VAR, \ SCM_SNARF_HERE(static const char RANAME[]=STR) \ SCM_SNARF_INIT(scm_c_define_gsubr (RANAME, REQ, OPT, VAR, \ (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN);) \ -SCM_SNARF_DOCS(\ -SCM_SNARF_DOC_STARTR STR | REQ | OPT | VAR | __FILE__:__LINE__ | \ - SCM_SNARF_DOCSTRING_START CFN SCM_SNARF_DOCSTRING_END \ -) +SCM_SNARF_DOCS(register, STR, (), REQ, OPT, VAR, \ + "implemented by the C function \"" #CFN "\"") #define SCM_GPROC(RANAME, STR, REQ, OPT, VAR, CFN, GF) \ SCM_SNARF_HERE(\ @@ -211,10 +217,10 @@ SCM_SNARF_INIT(c_name = scm_permanent_object (scm_sysintern (scheme_name, init_v #endif /* (SCM_DEBUG_DEPRECATED == 0) */ -#ifdef SCM_MAGIC_SNARFER +#ifdef SCM_MAGIC_SNARF_DOCS #undef SCM_ASSERT -#define SCM_ASSERT(_cond, _arg, _pos, _subr) *&*&*&*SCM_ARG_BETTER_BE_IN_POSITION(_arg,_pos,__LINE__) -#endif /* SCM_MAGIC_SNARFER */ +#define SCM_ASSERT(_cond, _arg, _pos, _subr) ^^[ argpos _arg _pos __LINE__ ] +#endif /* SCM_MAGIC_SNARF_DOCS */ #endif /* LIBGUILE_SNARF_H */ From f501d0d4e0c96f533e9f77ebc1a44837d2726c67 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Thu, 31 May 2001 13:17:00 +0000 Subject: [PATCH 1215/2047] * configure.in: generate guile-snarf-docs & guile-snarf-docs-texi. don't generate guile-snarf.awk. * Makefile.am (EXTRA_DIST): add test-suite. --- ChangeLog | 7 +++++++ Makefile.am | 6 +++++- configure.in | 5 +++-- 3 files changed, 15 insertions(+), 3 deletions(-) diff --git a/ChangeLog b/ChangeLog index 788191c34..13de79a9f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2001-05-31 Michael Livshin + + * configure.in: generate guile-snarf-docs & guile-snarf-docs-texi. + don't generate guile-snarf.awk. + + * Makefile.am (EXTRA_DIST): add test-suite. + 2001-05-28 Michael Livshin * check-guile.in: fix to be runnable when srcdir!=builddir. diff --git a/Makefile.am b/Makefile.am index 69c6cfc4f..97c5fffa1 100644 --- a/Makefile.am +++ b/Makefile.am @@ -19,6 +19,7 @@ ## to the Free Software Foundation, Inc., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA + SUBDIRS = ice-9 oop qt libltdl libguile guile-config guile-readline \ scripts srfi doc @@ -26,7 +27,10 @@ bin_SCRIPTS = guile-tools include_HEADERS = libguile.h -EXTRA_DIST = qthreads.m4 HACKING GUILE-VERSION ANON-CVS SNAPSHOTS +# automake sometimes forgets to distribute acconfig.h, +# apparently depending on the phase of the moon. +EXTRA_DIST = qthreads.m4 HACKING GUILE-VERSION ANON-CVS SNAPSHOTS \ + test-suite $(ACLOCAL) acconfig.h TESTS = check-guile diff --git a/configure.in b/configure.in index 92d1c5444..db9db9a98 100644 --- a/configure.in +++ b/configure.in @@ -608,7 +608,8 @@ AC_OUTPUT([Makefile libguile/guile-snarf libguile/guile-doc-snarf libguile/guile-func-name-check - libguile/guile-snarf.awk + libguile/guile-snarf-docs + libguile/guile-snarf-docs-texi libguile/versiondat.h ice-9/Makefile oop/Makefile @@ -623,7 +624,7 @@ AC_OUTPUT([Makefile doc/Makefile check-guile guile-tools], - [chmod +x libguile/guile-snarf libguile/guile-doc-snarf libguile/guile-func-name-check check-guile guile-tools]) + [chmod +x libguile/guile-snarf libguile/guile-doc-snarf libguile/guile-func-name-check libguile/guile-snarf-docs libguile/guile-snarf-docs-texi check-guile guile-tools]) dnl Local Variables: dnl comment-start: "dnl " From 413a1367e205e594685f4686bc4d31d670d70511 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Thu, 31 May 2001 14:04:56 +0000 Subject: [PATCH 1216/2047] small fixes --- libguile/Makefile.am | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index baf34f5aa..5badd240a 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -97,13 +97,17 @@ EXTRA_libguile_la_SOURCES = _scm.h \ filesys.c posix.c net_db.c socket.c \ ramap.c unif.c debug-malloc.c -Makefile: $(DOT_X_FILES) - ## In next release, threads will be factored out of libguile. ## Until then, the machine specific headers is a temporary kludge. OMIT_DEPENDENCIES = libguile.h ltdl.h \ axp.h hppa.h i386.h ksr.h m88k.h mips.h sparc.h vax.h +## delete guile-snarf.awk from the installation bindir, in case it's +## lingering there due to an earlier guile version not having been +## wiped out. +install-exec-hook: + rm -f $(bindir)/guile-snarf.awk + ## This is kind of nasty... there are ".c" files that we don't want to ## compile, since they are #included. So instead we list them here. ## Perhaps we can deal with them normally once the merge seems to be From 2de7ddb7669c6a1f964fa9ad9a874523b26f4f34 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 31 May 2001 15:54:25 +0000 Subject: [PATCH 1217/2047] Added the new `examples' directory to the distribution. --- ChangeLog | 7 ++ Makefile.am | 2 +- configure.in | 6 ++ examples/ChangeLog | 13 +++ examples/Makefile.am | 24 +++++ examples/README | 12 +++ examples/box-module/Makefile.am | 31 ++++++ examples/box-module/README | 42 ++++++++ examples/box-module/box.c | 160 ++++++++++++++++++++++++++++++ examples/box/Makefile.am | 31 ++++++ examples/box/README | 34 +++++++ examples/box/box.c | 148 +++++++++++++++++++++++++++ examples/modules/Makefile.am | 22 ++++ examples/modules/README | 26 +++++ examples/modules/main | 52 ++++++++++ examples/modules/module-0.scm | 22 ++++ examples/modules/module-1.scm | 22 ++++ examples/modules/module-2.scm | 26 +++++ examples/safe/Makefile.am | 22 ++++ examples/safe/README | 36 +++++++ examples/safe/evil.scm | 25 +++++ examples/safe/safe | 85 ++++++++++++++++ examples/safe/untrusted.scm | 31 ++++++ examples/scripts/Makefile.am | 22 ++++ examples/scripts/README | 33 ++++++ examples/scripts/fact | 70 +++++++++++++ examples/scripts/hello | 58 +++++++++++ examples/scripts/simple-hello.scm | 14 +++ 28 files changed, 1075 insertions(+), 1 deletion(-) create mode 100644 examples/ChangeLog create mode 100644 examples/Makefile.am create mode 100644 examples/README create mode 100644 examples/box-module/Makefile.am create mode 100644 examples/box-module/README create mode 100644 examples/box-module/box.c create mode 100644 examples/box/Makefile.am create mode 100644 examples/box/README create mode 100644 examples/box/box.c create mode 100644 examples/modules/Makefile.am create mode 100644 examples/modules/README create mode 100644 examples/modules/main create mode 100644 examples/modules/module-0.scm create mode 100644 examples/modules/module-1.scm create mode 100644 examples/modules/module-2.scm create mode 100644 examples/safe/Makefile.am create mode 100644 examples/safe/README create mode 100644 examples/safe/evil.scm create mode 100755 examples/safe/safe create mode 100644 examples/safe/untrusted.scm create mode 100644 examples/scripts/Makefile.am create mode 100644 examples/scripts/README create mode 100755 examples/scripts/fact create mode 100755 examples/scripts/hello create mode 100644 examples/scripts/simple-hello.scm diff --git a/ChangeLog b/ChangeLog index 13de79a9f..fb84a2979 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2001-05-31 Martin Grabmueller + + * Makefile.am (EXTRA_DIST): New subdirectory `examples'. + + * configure.in: Added all Makefiles in the `examples' directory to + AC_OUTPUT. + 2001-05-31 Michael Livshin * configure.in: generate guile-snarf-docs & guile-snarf-docs-texi. diff --git a/Makefile.am b/Makefile.am index 97c5fffa1..b3df779e9 100644 --- a/Makefile.am +++ b/Makefile.am @@ -21,7 +21,7 @@ SUBDIRS = ice-9 oop qt libltdl libguile guile-config guile-readline \ - scripts srfi doc + scripts srfi doc examples bin_SCRIPTS = guile-tools diff --git a/configure.in b/configure.in index db9db9a98..cfe5ecb8a 100644 --- a/configure.in +++ b/configure.in @@ -622,6 +622,12 @@ AC_OUTPUT([Makefile qt/time/Makefile guile-config/Makefile doc/Makefile + examples/Makefile + examples/scripts/Makefile + examples/box/Makefile + examples/box-module/Makefile + examples/modules/Makefile + examples/safe/Makefile check-guile guile-tools], [chmod +x libguile/guile-snarf libguile/guile-doc-snarf libguile/guile-func-name-check libguile/guile-snarf-docs libguile/guile-snarf-docs-texi check-guile guile-tools]) diff --git a/examples/ChangeLog b/examples/ChangeLog new file mode 100644 index 000000000..64a1976d2 --- /dev/null +++ b/examples/ChangeLog @@ -0,0 +1,13 @@ +2001-05-30 Martin Grabmueller + + * box-module: New directory, similar to box, but defines the + primitives in a module (box-module) instead of defining them + globally. + + * safe: New directory, explaining some aspects of using safe + environments for evaluation. + +2001-05-29 Martin Grabmueller + + * New directory for Guile example code. + diff --git a/examples/Makefile.am b/examples/Makefile.am new file mode 100644 index 000000000..c0955a17b --- /dev/null +++ b/examples/Makefile.am @@ -0,0 +1,24 @@ +## Process this file with Automake to create Makefile.in +## +## Copyright (C) 2001 Free Software Foundation, Inc. +## +## This file is part of GUILE. +## +## GUILE 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, or +## (at your option) any later version. +## +## GUILE 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 GUILE; see the file COPYING. If not, write +## to the Free Software Foundation, Inc., 59 Temple Place, Suite +## 330, Boston, MA 02111-1307 USA + +SUBDIRS = scripts box box-module modules safe + +EXTRA_DIST = README diff --git a/examples/README b/examples/README new file mode 100644 index 000000000..ff9f3b2ca --- /dev/null +++ b/examples/README @@ -0,0 +1,12 @@ + -*- text -*- + +This directory includes examples illustrating various aspects of Guile +programming. + +See the README files in the subdirectories for details. + +scripts Examples for writing simple scripts in Guile Scheme. +box Example for extending Guile with a new data type. +box-module Similar to `box', but define new procedures in a named module. +modules Examples for writing and using Guile modules. +safe Examples for creating and using safe environments. diff --git a/examples/box-module/Makefile.am b/examples/box-module/Makefile.am new file mode 100644 index 000000000..3e1f92032 --- /dev/null +++ b/examples/box-module/Makefile.am @@ -0,0 +1,31 @@ +## Process this file with Automake to create Makefile.in +## +## Copyright (C) 2001 Free Software Foundation, Inc. +## +## This file is part of GUILE. +## +## GUILE 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, or +## (at your option) any later version. +## +## GUILE 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 GUILE; see the file COPYING. If not, write +## to the Free Software Foundation, Inc., 59 Temple Place, Suite +## 330, Boston, MA 02111-1307 USA + +EXTRA_DIST = README box.c + +CFLAGS=`guile-config compile` +LIBS=`guile-config link` + +box: box.o + $(CC) $< $(LIBS) -o box + +box.o: box.c + $(CC) $(CFLAGS) -c $< \ No newline at end of file diff --git a/examples/box-module/README b/examples/box-module/README new file mode 100644 index 000000000..7f5d8521d --- /dev/null +++ b/examples/box-module/README @@ -0,0 +1,42 @@ + -*- text -*- + +This directory includes an example program for extending Guile with a +new (and even useful) data type. + +The `box' program created by this example is nearly identical to the +one produced in directory ../box, with one (important) difference: The +interpreter in this directory will place all defined primitive +procedures in a module called (box-module). That means that this +module must be used before the primitives can be accessed. + +To build the example, simply type + + make box + +in this directory. + +The resulting `box' program is a Guile interpreter which has one +additional data type called `box'. + +A box is simply an object for storing one other object in. It can be +used for passing parameters by reference, for example. You simply +store an object into a box, pass it to another procedure which can +store a new object into it and thus return a value via the box. + +Box objects are created with `make-box', set with `box-set!' and +examined with `box-ref'. Note that these procedures are placed in a +module called (box-module) and can thus only be accessed after using +this module. See the following example session for usage details: + +$ ./box +guile> (use-modules (box-module)) +guile> (define b (make-box)) +guile> b +# +guile> (box-set! b '(list of values)) +guile> b +# +guile> (box-ref b) +(list of values) +guile> (quit) +$ diff --git a/examples/box-module/box.c b/examples/box-module/box.c new file mode 100644 index 000000000..2065466fc --- /dev/null +++ b/examples/box-module/box.c @@ -0,0 +1,160 @@ +/* examples/box-module/box.c + * + * Copyright (C) 1998,2001 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 + * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + */ + +/* Include all needed declarations. */ +#include + + +/* The type code for the newly created smob type will be stored into + this variable. It has the prefix `scm_tc16_' to make it usable + with the SCM_VALIDATE_SMOB macro below. */ +static scm_bits_t scm_tc16_box; + + +/* This function is responsible for marking all SCM objects included + in the smob. */ +static SCM +mark_box (SCM b) +{ + /* Since we have only one SCM object to protect, we simply return it + and the caller with mark it. */ + return SCM_CELL_OBJECT_1 (b); +} + + +/* Print a textual represenation of the smob to a given port. */ +static int +print_box (SCM b, SCM port, scm_print_state *pstate) +{ + SCM value = SCM_CELL_OBJECT_1 (b); + + scm_puts ("#", port); + + /* Non-zero means success. */ + return 1; +} + + +/* This defines the primitve `make-box', which returns a new smob of + type `box', initialized to `#f'. */ +static SCM +#define FUNC_NAME "make-box" +make_box (void) +{ + /* This macro creates the new objects, stores the value `#f' into it + and returns it to the caller. */ + SCM_RETURN_NEWSMOB (scm_tc16_box, SCM_BOOL_F); +} +#undef FUNC_NAME + + +/* This is the primitive `box-ref' which returns the object stored in + the box. */ +static SCM +box_ref (SCM b) +#define FUNC_NAME "box-ref" +{ + /* First, we have to ensure that the user really gave us a box + objects. The macro SCM_VALIDATE_SMOB will do all what is needed. + The parameters are interpreted as follows: + + 1: The position of the checked variable in the parameter list. + b: The passed parameter. + box: Concatenated with the fixed prefix scm_tc16_, names the type + code for the expected smob type. */ + SCM_VALIDATE_SMOB (1, b, box); + + /* Fetch the object from the box and return it. */ + return SCM_CELL_OBJECT_1 (b); +} +#undef FUNC_NAME + + +/* Primitive which stores an arbitrary value into a box. */ +static SCM +box_set_x (SCM b, SCM value) +#define FUNC_NAME "box-set!" +{ + SCM_VALIDATE_SMOB (1, b, box); + + /* Set the cell number 1 of the smob to the given value. */ + SCM_SET_CELL_OBJECT_1 (b, value); + + /* When this constant is returned, the REPL will not print the + returned value. All procedures in Guile which are documented as + returning `and unspecified value' actually return this value. */ + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +/* Create and initialize the new smob type, and register the + primitives withe the interpreter library. + + This function must be declared a bit different from the example in + the ../box directory, because it will be called by + `scm_c_define_module', called from below. */ +static void +init_box_type (void * unused) +{ + scm_tc16_box = scm_make_smob_type ("box", 0); + scm_set_smob_mark (scm_tc16_box, mark_box); + scm_set_smob_print (scm_tc16_box, print_box); + + scm_c_define_gsubr ("make-box", 0, 0, 0, make_box); + scm_c_define_gsubr ("box-set!", 2, 0, 0, box_set_x); + scm_c_define_gsubr ("box-ref", 1, 0, 0, box_ref); + + /* This is new too: Since the procedures are now in a module, we + have to explicitly export them before they can be used. */ + scm_c_export ("make-box", "box-set!", "box-ref", NULL); +} + + +/* This is the function which gets called by scm_boot_guile after the + Guile library is completely initialized. */ +static void +inner_main (void *closure, int argc, char **argv) +{ + /* Unlike the example in ../box, init_box_type is not called + directly, but by scm_c_define_module, which will create a module + named (box-module) and make this module current while called + init_box_type, thus placing the definitions into that module. */ + scm_c_define_module ("box-module", init_box_type, NULL); + + /* ... then we start a shell, in which the box data type can be + used (after using the module (box-module)). */ + scm_shell (argc, argv); +} + + +/* Main program. */ +int +main (int argc, char **argv) +{ + /* Initialize Guile, then call `inner_main' with the arguments 0, + argc and argv. */ + scm_boot_guile (argc, argv, inner_main, 0); + return 0; /* Never reached. */ +} + +/* End of file. */ diff --git a/examples/box/Makefile.am b/examples/box/Makefile.am new file mode 100644 index 000000000..3e1f92032 --- /dev/null +++ b/examples/box/Makefile.am @@ -0,0 +1,31 @@ +## Process this file with Automake to create Makefile.in +## +## Copyright (C) 2001 Free Software Foundation, Inc. +## +## This file is part of GUILE. +## +## GUILE 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, or +## (at your option) any later version. +## +## GUILE 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 GUILE; see the file COPYING. If not, write +## to the Free Software Foundation, Inc., 59 Temple Place, Suite +## 330, Boston, MA 02111-1307 USA + +EXTRA_DIST = README box.c + +CFLAGS=`guile-config compile` +LIBS=`guile-config link` + +box: box.o + $(CC) $< $(LIBS) -o box + +box.o: box.c + $(CC) $(CFLAGS) -c $< \ No newline at end of file diff --git a/examples/box/README b/examples/box/README new file mode 100644 index 000000000..78b7762ef --- /dev/null +++ b/examples/box/README @@ -0,0 +1,34 @@ + -*- text -*- + +This directory includes an example program for extending Guile with a +new (and even useful) data type. + +To build the example, simply type + + make box + +in this directory. + +The resulting `box' program is a Guile interpreter which has one +additional data type called `box'. + +A box is simply an object for storing one other object in. It can be +used for passing parameters by reference, for example. You simply +store an object into a box, pass it to another procedure which can +store a new object into it and thus return a value via the box. + +Box objects are created with `make-box', set with `box-set!' and +examined with `box-ref'. See the following example session for usage +details: + +$ ./box +guile> (define b (make-box)) +guile> b +# +guile> (box-set! b '(list of values)) +guile> b +# +guile> (box-ref b) +(list of values) +guile> (quit) +$ diff --git a/examples/box/box.c b/examples/box/box.c new file mode 100644 index 000000000..a928c0ef3 --- /dev/null +++ b/examples/box/box.c @@ -0,0 +1,148 @@ +/* examples/box/box.c + * + * Copyright (C) 1998,2001 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 + * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + */ + +/* Include all needed declarations. */ +#include + + +/* The type code for the newly created smob type will be stored into + this variable. It has the prefix `scm_tc16_' to make it usable + with the SCM_VALIDATE_SMOB macro below. */ +static scm_bits_t scm_tc16_box; + + +/* This function is responsible for marking all SCM objects included + in the smob. */ +static SCM +mark_box (SCM b) +{ + /* Since we have only one SCM object to protect, we simply return it + and the caller with mark it. */ + return SCM_CELL_OBJECT_1 (b); +} + + +/* Print a textual represenation of the smob to a given port. */ +static int +print_box (SCM b, SCM port, scm_print_state *pstate) +{ + SCM value = SCM_CELL_OBJECT_1 (b); + + scm_puts ("#", port); + + /* Non-zero means success. */ + return 1; +} + + +/* This defines the primitve `make-box', which returns a new smob of + type `box', initialized to `#f'. */ +static SCM +#define FUNC_NAME "make-box" +make_box (void) +{ + /* This macro creates the new objects, stores the value `#f' into it + and returns it to the caller. */ + SCM_RETURN_NEWSMOB (scm_tc16_box, SCM_BOOL_F); +} +#undef FUNC_NAME + + +/* This is the primitive `box-ref' which returns the object stored in + the box. */ +static SCM +box_ref (SCM b) +#define FUNC_NAME "box-ref" +{ + /* First, we have to ensure that the user really gave us a box + objects. The macro SCM_VALIDATE_SMOB will do all what is needed. + The parameters are interpreted as follows: + + 1: The position of the checked variable in the parameter list. + b: The passed parameter. + box: Concatenated with the fixed prefix scm_tc16_, names the type + code for the expected smob type. */ + SCM_VALIDATE_SMOB (1, b, box); + + /* Fetch the object from the box and return it. */ + return SCM_CELL_OBJECT_1 (b); +} +#undef FUNC_NAME + + +/* Primitive which stores an arbitrary value into a box. */ +static SCM +box_set_x (SCM b, SCM value) +#define FUNC_NAME "box-set!" +{ + SCM_VALIDATE_SMOB (1, b, box); + + /* Set the cell number 1 of the smob to the given value. */ + SCM_SET_CELL_OBJECT_1 (b, value); + + /* When this constant is returned, the REPL will not print the + returned value. All procedures in Guile which are documented as + returning `and unspecified value' actually return this value. */ + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +/* Create and initialize the new smob type, and register the + primitives withe the interpreter library. */ +static void +init_box_type (void) +{ + scm_tc16_box = scm_make_smob_type ("box", 0); + scm_set_smob_mark (scm_tc16_box, mark_box); + scm_set_smob_print (scm_tc16_box, print_box); + + scm_c_define_gsubr ("make-box", 0, 0, 0, make_box); + scm_c_define_gsubr ("box-set!", 2, 0, 0, box_set_x); + scm_c_define_gsubr ("box-ref", 1, 0, 0, box_ref); +} + + +/* This is the function which gets called by scm_boot_guile after the + Guile library is completely initialized. */ +static void +inner_main (void *closure, int argc, char **argv) +{ + /* First, we create our data type... */ + init_box_type (); + /* ... then we start a shell, in which the box data type can be + used. */ + scm_shell (argc, argv); +} + + +/* Main program. */ +int +main (int argc, char **argv) +{ + /* Initialize Guile, then call `inner_main' with the arguments 0, + argc and argv. */ + scm_boot_guile (argc, argv, inner_main, 0); + return 0; /* Never reached. */ +} + +/* End of file. */ diff --git a/examples/modules/Makefile.am b/examples/modules/Makefile.am new file mode 100644 index 000000000..35988c545 --- /dev/null +++ b/examples/modules/Makefile.am @@ -0,0 +1,22 @@ +## Process this file with Automake to create Makefile.in +## +## Copyright (C) 2001 Free Software Foundation, Inc. +## +## This file is part of GUILE. +## +## GUILE 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, or +## (at your option) any later version. +## +## GUILE 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 GUILE; see the file COPYING. If not, write +## to the Free Software Foundation, Inc., 59 Temple Place, Suite +## 330, Boston, MA 02111-1307 USA + +EXTRA_DIST = README module-0.scm module-1.scm module-2.scm main diff --git a/examples/modules/README b/examples/modules/README new file mode 100644 index 000000000..12df77f69 --- /dev/null +++ b/examples/modules/README @@ -0,0 +1,26 @@ + -*- text -*- + +This directory includes examples which show how to write and use Guile +modules in Scheme programs. + +The descriptions below assume that you have a working copy of Guile +installed and available with the standard installation prefix +`/usr/local'. + +main: + + The main program, which uses the modules described below to perform + some actions. Module usage and selective importing as well as + renaming is demonstrated here.n + + $ ./main + + or + + guile -s main + +module-0.scm, module-1.scm, module-2.scm: + + Two modules which export several procedure, some of which have the + same names (so that renaming/selection is required for proper + importing). diff --git a/examples/modules/main b/examples/modules/main new file mode 100644 index 000000000..603ea10f1 --- /dev/null +++ b/examples/modules/main @@ -0,0 +1,52 @@ +#! /usr/local/bin/guile -s +!# +;;; examples/modules/main -- Module system demo. + +;;; Commentary: + +;;; The main demo program for the modules subdirectory. +;;; +;;; This program shows how all the new fancy module import features +;;; are to be used. + +;;; Author: Martin Grabmueller +;;; Date: 2001-05-29 + +;;; Code: + +(define-module (main) + ;; The module 0 is imported completely. + ;; + :use-module (module-0) + + ;; Module 1 is imported completely, too, but the procedure names are + ;; prefixed with the module name. + ;; + :use-module ((module-1) :rename (symbol-prefix-proc 'module-1:)) + + ;; From module 2, only the procedure `braz' is imported, so that the + ;; procedures `foo' and `bar' also exported by that module don't + ;; clash with the definitions of module 0. + ;; + :use-module ((module-2) :select (braz)) + + ;; Import the bindings from module 2 again, now renaming them by + ;; explicitly mentioning the original and new names. + ;; + :use-module ((module-2) :select ((braz . m-2:braz) (foo . m-2:foo)))) + +;; +;; Now call the various imported procedures. +;; + +(foo) +(bar) +(module-1:foo) +(module-1:bar) +(braz) +(m-2:braz) +(m-2:foo) + +;; Local variables: +;; mode: scheme +;; End: diff --git a/examples/modules/module-0.scm b/examples/modules/module-0.scm new file mode 100644 index 000000000..47e8433c7 --- /dev/null +++ b/examples/modules/module-0.scm @@ -0,0 +1,22 @@ +;;; examples/modules/module-0.scm -- Module system demo. + +;;; Commentary: + +;;; Module 0 of the module demo program. + +;;; Author: Martin Grabmueller +;;; Date: 2001-05-29 + +;;; Code: + +(define-module (module-0)) + +(export foo bar) + +(define (foo) + (display "module-0 foo") + (newline)) + +(define (bar) + (display "module-0 bar") + (newline)) diff --git a/examples/modules/module-1.scm b/examples/modules/module-1.scm new file mode 100644 index 000000000..d62264021 --- /dev/null +++ b/examples/modules/module-1.scm @@ -0,0 +1,22 @@ +;;; examples/modules/module-1.scm -- Module system demo. + +;;; Commentary: + +;;; Module 1 of the module demo program. + +;;; Author: Martin Grabmueller +;;; Date: 2001-05-29 + +;;; Code: + +(define-module (module-1)) + +(export foo bar) + +(define (foo) + (display "module-1 foo") + (newline)) + +(define (bar) + (display "module-1 bar") + (newline)) diff --git a/examples/modules/module-2.scm b/examples/modules/module-2.scm new file mode 100644 index 000000000..a63d5e492 --- /dev/null +++ b/examples/modules/module-2.scm @@ -0,0 +1,26 @@ +;;; examples/modules/module-2.scm -- Module system demo. + +;;; Commentary: + +;;; Module 2 of the module demo program. + +;;; Author: Martin Grabmueller +;;; Date: 2001-05-29 + +;;; Code: + +(define-module (module-2)) + +(export foo bar braz) + +(define (foo) + (display "module-2 foo") + (newline)) + +(define (bar) + (display "module-2 bar") + (newline)) + +(define (braz) + (display "module-2 braz") + (newline)) diff --git a/examples/safe/Makefile.am b/examples/safe/Makefile.am new file mode 100644 index 000000000..cf41df73f --- /dev/null +++ b/examples/safe/Makefile.am @@ -0,0 +1,22 @@ +## Process this file with Automake to create Makefile.in +## +## Copyright (C) 2001 Free Software Foundation, Inc. +## +## This file is part of GUILE. +## +## GUILE 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, or +## (at your option) any later version. +## +## GUILE 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 GUILE; see the file COPYING. If not, write +## to the Free Software Foundation, Inc., 59 Temple Place, Suite +## 330, Boston, MA 02111-1307 USA + +EXTRA_DIST = README safe untrusted.scm evil.scm diff --git a/examples/safe/README b/examples/safe/README new file mode 100644 index 000000000..be16e1e74 --- /dev/null +++ b/examples/safe/README @@ -0,0 +1,36 @@ + -*- text -*- + +This directory includes examples which show how to create and use safe +environments for safe (sand-boxed) execution of Scheme programs. + +*Note* that the files in this directory are only suitable for + demonstration purposes, if you have to implement safe evaluation + mechanisms in important environments, you will have to do more than + shown here -- for example disabling input/output operations. + +The descriptions below assume that you have a working copy of Guile +installed and available with the standard installation prefix +`/usr/local'. + +safe: + + The main program, which executes the Scheme code in a file given on + the command line in a safe environment. The following command will + do that with the file `untrusted.scm' (see below.) + + $ ./safe untrusted.scm + + or + + guile -s safe untrusted.scm + +untrusted.scm: + + This file contains some Scheme code, which will be executed in a + safe environment by the `safe' script. + +evil.scm + + This file also contains Scheme code, but it tries to do evil things. + Evaluating this with the `safe' script will abort on those evil + actions. diff --git a/examples/safe/evil.scm b/examples/safe/evil.scm new file mode 100644 index 000000000..9eb64db8e --- /dev/null +++ b/examples/safe/evil.scm @@ -0,0 +1,25 @@ +;;; examples/safe/evil.scm -- Evil Scheme file to be run in a safe +;;; environment. + +;;; Commentary: + +;;; This is an example file to be evaluated by the `safe' program in +;;; this directory. This program, unlike the `untrusted.scm' (which +;;; is untrusted, but a really nice fellow though), tries to do evil +;;; things and will thus break in a safe environment. +;;; +;;; *Note* that the files in this directory are only suitable for +;;; demonstration purposes, if you have to implement safe evaluation +;;; mechanisms in important environments, you will have to do more +;;; than shown here -- for example disabling input/output operations. + +;;; Author: Martin Grabmueller +;;; Date: 2001-05-30 + +;;; Code: + +(define passwd (open-input-file "/etc/passwd")) + +(let lp ((ch (read-char passwd))) + (if (not (eof-object? ch)) + (lp (read-char passwd)))) diff --git a/examples/safe/safe b/examples/safe/safe new file mode 100755 index 000000000..7653dc2b8 --- /dev/null +++ b/examples/safe/safe @@ -0,0 +1,85 @@ +#! /usr/local/bin/guile -s +!# +;;; examples/safe/safe -- Example for safe (sand-boxed) evaluation. + +;;; Commentary: + +;;; This is a demo program for evaluating arbitrary (untrusted) Scheme +;;; code in a controlled, safe environment. Evaluation in safe +;;; environments restricts the evaluated code's access to some given +;;; primitives, which are considered `safe', that means which cannot +;;; do any harm to the world outside of Guile (creating/deleting files +;;; etc.) +;;; +;;; *Note* that the files in this directory are only suitable for +;;; demonstration purposes, if you have to implement safe evaluation +;;; mechanisms in important environments, you will have to do more +;;; than shown here -- for example disabling input/output operations. + +;;; Author: Martin Grabmueller +;;; Date: 2001-05-30 + +;;; Code: + +;; Safe module creation is implemented in this module: +;; +(use-modules (ice-9 safe)) + +;; This is the main program. It expects one parameter in the format +;; returned by (command-line) and expects that exactly one file name +;; is passed in this list (after the script name, which is passed as +;; the 0th parameter.) +;; +;; The given file is opened for reading, one expression after the +;; other is read and evaluated in a safe environment. All exceptions +;; caused by this evaluation are caught and printed out. +;; +(define (main cmd-line) + + ;; Internal definition of the procedure which prints usage + ;; information. + ;; + (define (display-help) + (display "Usage: safe FILENAME") + (newline) + (quit 1)) + + ;; Check that we received exactly one command line argument after + ;; the script name + ;; + (if (not (= (length cmd-line) 2)) + (display-help) + (let ((port (open-input-file (cadr cmd-line))) + + ;; Create the safe module. + (safe-module (make-safe-module))) + + ;; Read one expression a time. + (let lp ((expr (read port))) + ;; End of file? -> Return. + (if (eof-object? expr) + #t + (catch #t + (lambda () + ;; Evaluate the expression in the safe environment. + (eval expr safe-module) + ;; ... and read the next expression if no error occured. + (lp (read port))) + + ;; Handle exceptions. This procedure will be called when an + ;; error occurs while evaluating the expression. It just + ;; prints out a message telling so and returns from the + ;; evaluation loop, thus terminating the program. + ;; + (lambda args + (display "** Exception: ") + (write args) + (newline)))))))) + +;; Start the main program. +;; +(main (command-line)) + +;; Local variables: +;; mode: scheme +;; End: diff --git a/examples/safe/untrusted.scm b/examples/safe/untrusted.scm new file mode 100644 index 000000000..9cdf1b640 --- /dev/null +++ b/examples/safe/untrusted.scm @@ -0,0 +1,31 @@ +;;; examples/safe/untrusted.scm -- Scheme file to be run in a safe +;;; environment. + +;;; Commentary: + +;;; This is an example file to be evaluated by the `safe' program in +;;; this directory. +;;; +;;; *Note* that the files in this directory are only suitable for +;;; demonstration purposes, if you have to implement safe evaluation +;;; mechanisms in important environments, you will have to do more +;;; than shown here -- for example disabling input/output operations. + +;;; Author: Martin Grabmueller +;;; Date: 2001-05-30 + +;;; Code: + +;; fact -- the everlasting factorial function... +;; +(define (fact n) + (if (< n 2) + 1 + (* n (fact (- n 1))))) + +;; Display the factorial of 0..9 to the terminal. +;; +(do ((x 0 (+ x 1))) + ((= x 11)) + (display (fact x)) + (newline)) diff --git a/examples/scripts/Makefile.am b/examples/scripts/Makefile.am new file mode 100644 index 000000000..ff6173086 --- /dev/null +++ b/examples/scripts/Makefile.am @@ -0,0 +1,22 @@ +## Process this file with Automake to create Makefile.in +## +## Copyright (C) 2001 Free Software Foundation, Inc. +## +## This file is part of GUILE. +## +## GUILE 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, or +## (at your option) any later version. +## +## GUILE 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 GUILE; see the file COPYING. If not, write +## to the Free Software Foundation, Inc., 59 Temple Place, Suite +## 330, Boston, MA 02111-1307 USA + +EXTRA_DIST = README simple-hello.scm hello fact diff --git a/examples/scripts/README b/examples/scripts/README new file mode 100644 index 000000000..491007c27 --- /dev/null +++ b/examples/scripts/README @@ -0,0 +1,33 @@ + -*- text -*- + +This directory includes examples which show how to write scripts using +Guile. + +The descriptions below assume that you have a working copy of Guile +installed and available with the standard installation prefix +`/usr/local'. + +simple-hello.scm: + + The simplest "Hello World!" program for Guile. Run it like this: + + $ guile -s simple-hello.scm + +hello: + + An advanced version of the script above, with command line handling + for the important options --help and --version. Run it like this: + + ./hello + + or + + guile -s hello + +fact: + + Command-line factorial calculator. Run it like this: + + ./fact 5 + + to calculate the factorial of 5. diff --git a/examples/scripts/fact b/examples/scripts/fact new file mode 100755 index 000000000..90eecd7c2 --- /dev/null +++ b/examples/scripts/fact @@ -0,0 +1,70 @@ +#! /usr/local/bin/guile -s +!# +;;; Commentary: + +;;; This is a command-line factorial calculator. Run like this: +;;; +;;; ./fact 5 +;;; +;;; to calculate the factorial of 5 + +;;; Author: Martin Grabmueller +;;; Date: 2001-05-29 + +;;; Code: + +(use-modules (ice-9 getopt-long)) + +;; This is the grammar for the command line synopsis we expect. +;; +(define command-synopsis + '((version (single-char #\v) (value #f)) + (help (single-char #\h) (value #f)))) + +;; Display version information and exit. +;; +(define (display-version) + (display "fact 0.0.1\n")) + +;; Display the usage help message and exit. +;; +(define (display-help) + (display "Usage: fact [options...] number\n") + (display " --help, -h Show this usage information\n") + (display " --version, -v Show version information\n")) + +;; Interpret options, if --help or --version was given, print out the +;; requested information and exit. Otherwise, calculate the factorial +;; of the argument. +;; +(define (main options) + (let ((help-wanted (option-ref options 'help #f)) + (version-wanted (option-ref options 'version #f)) + (args (option-ref options '() '()))) + (cond + ((or version-wanted help-wanted) + (if version-wanted + (display-version)) + (if help-wanted + (display-help))) + ((not (= (length args) 1)) + (display-help)) + (else + (display (fact (string->number (car args)))) + (newline))))) + +;; Calculate the factorial of n. +;; +(define (fact n) + (if (< n 2) + 1 + (* n (fact (- n 1))))) + +;; Call the main program with parsed command line options. +;; +(main (getopt-long (command-line) command-synopsis)) + +;; Local variables: +;; mode: scheme +;; End: + diff --git a/examples/scripts/hello b/examples/scripts/hello new file mode 100755 index 000000000..4108db400 --- /dev/null +++ b/examples/scripts/hello @@ -0,0 +1,58 @@ +#! /usr/local/bin/guile -s +!# +;;; Commentary: + +;;; This is the famous Hello-World-program, written for Guile. It is a +;;; little bit enhanced in that it understands the command line options +;;; `--help' (-h) and `--version' (-v), which print a short usage +;;; decription or version information, respectively. + +;;; Author: Martin Grabmueller +;;; Date: 2001-05-29 + +;;; Code: + +(use-modules (ice-9 getopt-long)) + +;; This is the grammar for the command line synopsis we expect. +;; +(define command-synopsis + '((version (single-char #\v) (value #f)) + (help (single-char #\h) (value #f)))) + +;; Display version information and exit. +;; +(define (display-version) + (display "hello 0.0.1\n")) + +;; Display the usage help message and exit. +;; +(define (display-help) + (display "Usage: hello [options...]\n") + (display " --help, -h Show this usage information\n") + (display " --version, -v Show version information\n")) + +;; Interpret options, if --help or --version was given, print out the +;; requested information and exit. Otherwise, print the famous +;; message. +;; +(define (main options) + (let ((help-wanted (option-ref options 'help #f)) + (version-wanted (option-ref options 'version #f))) + (if (or version-wanted help-wanted) + (begin + (if version-wanted + (display-version)) + (if help-wanted + (display-help))) + (begin + (display "Hello, World!") (newline))))) + +;; Call the main program with parsed command line options. +;; +(main (getopt-long (command-line) command-synopsis)) + +;; Local variables: +;; mode: scheme +;; End: + diff --git a/examples/scripts/simple-hello.scm b/examples/scripts/simple-hello.scm new file mode 100644 index 000000000..713a1aee4 --- /dev/null +++ b/examples/scripts/simple-hello.scm @@ -0,0 +1,14 @@ +;;; Commentary: + +;;; This is the famous Hello-World-program, written for Guile. +;;; +;;; For an advanced version, see the script `hello' in the same +;;; directory. + +;;; Author: Martin Grabmueller +;;; Date: 2001-05-29 + +;;; Code: + +(display "Hello, World!") +(newline) From dd22a80ac666c403f1fef9de14abb8eff97a754d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 31 May 2001 18:22:54 +0000 Subject: [PATCH 1218/2047] * srfi-14.scm, srfi-13.scm: Use `load-extension' for loading the shared library. --- srfi/ChangeLog | 5 +++++ srfi/srfi-13.scm | 2 +- srfi/srfi-14.scm | 2 +- 3 files changed, 7 insertions(+), 2 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index a9ef7e535..3b77ca198 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,8 @@ +2001-05-31 Martin Grabmueller + + * srfi-14.scm, srfi-13.scm: Use `load-extension' for loading the + shared library. + 2001-05-31 Michael Livshin * Makefile.am (MKDEP): copied from libguile/Makefile.am, just in diff --git a/srfi/srfi-13.scm b/srfi/srfi-13.scm index 76fcc6d06..dc3821b7b 100644 --- a/srfi/srfi-13.scm +++ b/srfi/srfi-13.scm @@ -112,7 +112,7 @@ (cond-expand-provide (current-module) '(srfi-13)) -(dynamic-call "scm_init_srfi_13" (dynamic-link "libguile-srfi-srfi-13-14")) +(load-extension "libguile-srfi-srfi-13-14" "scm_init_srfi_13") (define string-hash (lambda (s . rest) diff --git a/srfi/srfi-14.scm b/srfi/srfi-14.scm index 1cea4e079..ae0e32a3b 100644 --- a/srfi/srfi-14.scm +++ b/srfi/srfi-14.scm @@ -92,7 +92,7 @@ (cond-expand-provide (current-module) '(srfi-14)) -(dynamic-call "scm_init_srfi_14" (dynamic-link "libguile-srfi-srfi-13-14")) +(load-extension "libguile-srfi-srfi-13-14" "scm_init_srfi_14") (define (->char-set x) (cond From cc6dd1c57a2f49108c4dd8df63dee12ec94022e6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 31 May 2001 18:24:11 +0000 Subject: [PATCH 1219/2047] * box-dynamic: New directory, implements the box type in a shared library (aka extension) Thanks to Thomas Wawrzinek for patching box.c into an extension! --- examples/ChangeLog | 7 ++ examples/Makefile.am | 2 +- examples/README | 3 +- examples/box-dynamic/Makefile.am | 31 ++++++++ examples/box-dynamic/README | 41 ++++++++++ examples/box-dynamic/box.c | 128 +++++++++++++++++++++++++++++++ 6 files changed, 210 insertions(+), 2 deletions(-) create mode 100644 examples/box-dynamic/Makefile.am create mode 100644 examples/box-dynamic/README create mode 100644 examples/box-dynamic/box.c diff --git a/examples/ChangeLog b/examples/ChangeLog index 64a1976d2..5549fa574 100644 --- a/examples/ChangeLog +++ b/examples/ChangeLog @@ -1,3 +1,10 @@ +2001-05-31 Martin Grabmueller + + * box-dynamic: New directory, implements the box type in a shared + library (aka extension) + + Thanks to Thomas Wawrzinek for patching box.c into an extension! + 2001-05-30 Martin Grabmueller * box-module: New directory, similar to box, but defines the diff --git a/examples/Makefile.am b/examples/Makefile.am index c0955a17b..1b5d3852a 100644 --- a/examples/Makefile.am +++ b/examples/Makefile.am @@ -19,6 +19,6 @@ ## to the Free Software Foundation, Inc., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA -SUBDIRS = scripts box box-module modules safe +SUBDIRS = scripts box box-module box-dynamic modules safe EXTRA_DIST = README diff --git a/examples/README b/examples/README index ff9f3b2ca..0c2c7063a 100644 --- a/examples/README +++ b/examples/README @@ -1,6 +1,6 @@ -*- text -*- -This directory includes examples illustrating various aspects of Guile +This directory contains examples illustrating various aspects of Guile programming. See the README files in the subdirectories for details. @@ -8,5 +8,6 @@ See the README files in the subdirectories for details. scripts Examples for writing simple scripts in Guile Scheme. box Example for extending Guile with a new data type. box-module Similar to `box', but define new procedures in a named module. +box-dynamic Implements the box type in a dynamically loadable library. modules Examples for writing and using Guile modules. safe Examples for creating and using safe environments. diff --git a/examples/box-dynamic/Makefile.am b/examples/box-dynamic/Makefile.am new file mode 100644 index 000000000..7bb9f46c2 --- /dev/null +++ b/examples/box-dynamic/Makefile.am @@ -0,0 +1,31 @@ +## Process this file with Automake to create Makefile.in +## +## Copyright (C) 2001 Free Software Foundation, Inc. +## +## This file is part of GUILE. +## +## GUILE 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, or +## (at your option) any later version. +## +## GUILE 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 GUILE; see the file COPYING. If not, write +## to the Free Software Foundation, Inc., 59 Temple Place, Suite +## 330, Boston, MA 02111-1307 USA + +EXTRA_DIST = README box.c + +CFLAGS=`guile-config compile` +LIBS=`guile-config link` + +libbox: box.lo + sh ../../libtool --mode=link $(CC) $< $(LIBS) -rpath $(prefix)/lib -o libbox.la + +box.lo: box.c + sh ../../libtool --mode=compile $(CC) $(CFLAGS) -c $< \ No newline at end of file diff --git a/examples/box-dynamic/README b/examples/box-dynamic/README new file mode 100644 index 000000000..561e4841a --- /dev/null +++ b/examples/box-dynamic/README @@ -0,0 +1,41 @@ + -*- text -*- + +This directory includes an example program for extending Guile with a +new (and even useful) data type, putting it into a shared library, so it +can be called from an unmodified guile interpreter. + +To build the example, simply type + + make libbox + +in this directory. + +A box is simply an object for storing one other object in. It can be +used for passing parameters by reference, for example. You simply +store an object into a box, pass it to another procedure which can +store a new object into it and thus return a value via the box. + +Box objects are created with `make-box', set with `box-set!' and +examined with `box-ref'. Note that these procedures are placed in a +module called (box-module) and can thus only be accessed after using +this module. See the following example session for usage details: + +Extend your LD_LIBRARY_PATH variable (or equivalent) to include . and +.libs + +If you like this example so much that you want to have it available +for normal usage, install the dynamic libraries in the .libs directory +to the directory $(prefix)/lib + +$ ./guile +guile> (load-extension "libbox" "scm_init_box") +guile> (define b (make-box)) +guile> b +# +guile> (box-set! b '(list of values)) +guile> b +# +guile> (box-ref b) +(list of values) +guile> (quit) +$ diff --git a/examples/box-dynamic/box.c b/examples/box-dynamic/box.c new file mode 100644 index 000000000..6c6151cee --- /dev/null +++ b/examples/box-dynamic/box.c @@ -0,0 +1,128 @@ +/* examples/box-dynamic/box.c + * + * Copyright (C) 1998,2001 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 + * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + */ + +/* Include all needed declarations. */ +#include + + +/* The type code for the newly created smob type will be stored into + this variable. It has the prefix `scm_tc16_' to make it usable + with the SCM_VALIDATE_SMOB macro below. */ +static scm_bits_t scm_tc16_box; + + +/* This function is responsible for marking all SCM objects included + in the smob. */ +static SCM +mark_box (SCM b) +{ + /* Since we have only one SCM object to protect, we simply return it + and the caller with mark it. */ + return SCM_CELL_OBJECT_1 (b); +} + + +/* Print a textual represenation of the smob to a given port. */ +static int +print_box (SCM b, SCM port, scm_print_state *pstate) +{ + SCM value = SCM_CELL_OBJECT_1 (b); + + scm_puts ("#", port); + + /* Non-zero means success. */ + return 1; +} + + +/* This defines the primitve `make-box', which returns a new smob of + type `box', initialized to `#f'. */ +static SCM +#define FUNC_NAME "make-box" +make_box (void) +{ + /* This macro creates the new objects, stores the value `#f' into it + and returns it to the caller. */ + SCM_RETURN_NEWSMOB (scm_tc16_box, SCM_BOOL_F); +} +#undef FUNC_NAME + + +/* This is the primitive `box-ref' which returns the object stored in + the box. */ +static SCM +box_ref (SCM b) +#define FUNC_NAME "box-ref" +{ + /* First, we have to ensure that the user really gave us a box + objects. The macro SCM_VALIDATE_SMOB will do all what is needed. + The parameters are interpreted as follows: + + 1: The position of the checked variable in the parameter list. + b: The passed parameter. + box: Concatenated with the fixed prefix scm_tc16_, names the type + code for the expected smob type. */ + SCM_VALIDATE_SMOB (1, b, box); + + /* Fetch the object from the box and return it. */ + return SCM_CELL_OBJECT_1 (b); +} +#undef FUNC_NAME + + +/* Primitive which stores an arbitrary value into a box. */ +static SCM +box_set_x (SCM b, SCM value) +#define FUNC_NAME "box-set!" +{ + SCM_VALIDATE_SMOB (1, b, box); + + /* Set the cell number 1 of the smob to the given value. */ + SCM_SET_CELL_OBJECT_1 (b, value); + + /* When this constant is returned, the REPL will not print the + returned value. All procedures in Guile which are documented as + returning `and unspecified value' actually return this value. */ + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +/* Create and initialize the new smob type, and register the + primitives with the interpreter library. + + To be called with (load-extension "libbox" "scm_init_box") + from a script. +*/ +void +scm_init_box () +{ + scm_tc16_box = scm_make_smob_type ("box", 0); + scm_set_smob_mark (scm_tc16_box, mark_box); + scm_set_smob_print (scm_tc16_box, print_box); + + scm_c_define_gsubr ("make-box", 0, 0, 0, make_box); + scm_c_define_gsubr ("box-set!", 2, 0, 0, box_set_x); + scm_c_define_gsubr ("box-ref", 1, 0, 0, box_ref); +} + +/* End of file. */ From ee2718a9ec45117cba26a8e4b20f1bb234d77941 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 1 Jun 2001 05:04:52 +0000 Subject: [PATCH 1220/2047] * configure.in: Generate examples/box-dynamic/Makefile. --- ChangeLog | 4 ++++ configure.in | 1 + 2 files changed, 5 insertions(+) diff --git a/ChangeLog b/ChangeLog index fb84a2979..3f2a40677 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2001-06-01 Martin Grabmueller + + * configure.in: Generate examples/box-dynamic/Makefile. + 2001-05-31 Martin Grabmueller * Makefile.am (EXTRA_DIST): New subdirectory `examples'. diff --git a/configure.in b/configure.in index cfe5ecb8a..bbcac87dd 100644 --- a/configure.in +++ b/configure.in @@ -626,6 +626,7 @@ AC_OUTPUT([Makefile examples/scripts/Makefile examples/box/Makefile examples/box-module/Makefile + examples/box-dynamic/Makefile examples/modules/Makefile examples/safe/Makefile check-guile From 615bfe7277455a3676486b5d8b82fa16ca74efb3 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 1 Jun 2001 14:01:27 +0000 Subject: [PATCH 1221/2047] (top-repl): Revert part of the 2001-05-19 change. When defining the guile-user module, do not use any modules. Add them to guile-user when `top-repl' is called. --- ice-9/boot-9.scm | 123 +++++++++++++++++++++++++---------------------- 1 file changed, 66 insertions(+), 57 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 4c4f0a9ca..f4089c827 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -2838,59 +2838,77 @@ (lambda (v) (fluid-set! using-readline? v))))) (define (top-repl) + (let ((guile-user-module (resolve-module '(guile-user)))) - ;; Load emacs interface support if emacs option is given. - (if (and (module-defined? the-root-module 'use-emacs-interface) - (module-ref the-root-module 'use-emacs-interface)) - (load-emacs-interface)) + ;; Load emacs interface support if emacs option is given. + (if (and (module-defined? the-root-module 'use-emacs-interface) + (module-ref the-root-module 'use-emacs-interface)) + (load-emacs-interface)) - (let ((old-handlers #f) - (signals (if (provided? 'posix) - `((,SIGINT . "User interrupt") - (,SIGFPE . "Arithmetic error") - (,SIGBUS . "Bad memory access (bus error)") - (,SIGSEGV . - "Bad memory access (Segmentation violation)")) - '()))) + ;; Use some convenient modules (in reverse order) + + (if (provided? 'regex) + (module-use! guile-user-module (resolve-module '(ice-9 regex)))) + (if (provided? 'threads) + (module-use! guile-user-module (resolve-module '(ice-9 threads)))) + ;; load debugger on demand + (module-use! guile-user-module + (make-autoload-interface guile-user-module + '(ice-9 debugger) '(debug))) + (module-use! guile-user-module (resolve-module '(ice-9 session))) + (module-use! guile-user-module (resolve-module '(ice-9 debug))) + ;; so that builtin bindings will be checked first + (module-use! guile-user-module (resolve-module '(guile))) - (dynamic-wind + (set-current-module guile-user-module) - ;; call at entry - (lambda () - (let ((make-handler (lambda (msg) - (lambda (sig) - ;; Make a backup copy of the stack - (fluid-set! before-signal-stack - (fluid-ref the-last-stack)) - (save-stack %deliver-signals) - (scm-error 'signal - #f - msg - #f - (list sig)))))) - (set! old-handlers - (map (lambda (sig-msg) - (sigaction (car sig-msg) - (make-handler (cdr sig-msg)))) - signals)))) + (let ((old-handlers #f) + (signals (if (provided? 'posix) + `((,SIGINT . "User interrupt") + (,SIGFPE . "Arithmetic error") + (,SIGBUS . "Bad memory access (bus error)") + (,SIGSEGV + . "Bad memory access (Segmentation violation)")) + '()))) - ;; the protected thunk. - (lambda () - (let ((status (scm-style-repl))) - (run-hook exit-hook) - status)) + (dynamic-wind - ;; call at exit. - (lambda () - (map (lambda (sig-msg old-handler) - (if (not (car old-handler)) - ;; restore original C handler. - (sigaction (car sig-msg) #f) - ;; restore Scheme handler, SIG_IGN or SIG_DFL. - (sigaction (car sig-msg) - (car old-handler) - (cdr old-handler)))) - signals old-handlers))))) + ;; call at entry + (lambda () + (let ((make-handler (lambda (msg) + (lambda (sig) + ;; Make a backup copy of the stack + (fluid-set! before-signal-stack + (fluid-ref the-last-stack)) + (save-stack %deliver-signals) + (scm-error 'signal + #f + msg + #f + (list sig)))))) + (set! old-handlers + (map (lambda (sig-msg) + (sigaction (car sig-msg) + (make-handler (cdr sig-msg)))) + signals)))) + + ;; the protected thunk. + (lambda () + (let ((status (scm-style-repl))) + (run-hook exit-hook) + status)) + + ;; call at exit. + (lambda () + (map (lambda (sig-msg old-handler) + (if (not (car old-handler)) + ;; restore original C handler. + (sigaction (car sig-msg) #f) + ;; restore Scheme handler, SIG_IGN or SIG_DFL. + (sigaction (car sig-msg) + (car old-handler) + (cdr old-handler)))) + signals old-handlers)))))) (defmacro false-if-exception (expr) `(catch #t (lambda () ,expr) @@ -2905,15 +2923,6 @@ ;; Place the user in the guile-user module. ;; -(define-module (guile-user) - :use-module (guile) ;so that bindings will be checked here first - :use-module (ice-9 session) - :use-module (ice-9 debug) - :autoload (ice-9 debugger) (debug)) ;load debugger on demand - -(if (provided? 'threads) - (use-modules (ice-9 threads))) -(if (provided? 'regex) - (use-modules (ice-9 regex))) +(define-module (guile-user)) ;;; boot-9.scm ends here From 05c64f524e5de54e1ce90f3c8003677ab1572213 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 1 Jun 2001 14:01:44 +0000 Subject: [PATCH 1222/2047] *** empty log message *** --- ice-9/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 4c22e75f1..038101434 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,9 @@ +2001-06-01 Marius Vollmer + + * boot-9.scm (top-repl): Revert part of the 2001-05-19 change. + When defining the guile-user module, do not use any modules. Add + them to guile-user when `top-repl' is called. + 2001-05-25 Marius Vollmer * boot-9.scm (cond-expand): Define using From 532cf805dbfb2723b5a09f8be66df81f8cc2e25a Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 1 Jun 2001 20:15:10 +0000 Subject: [PATCH 1223/2047] (resolve-interface): Expect keyword arguments instead of a `spec'. (compile-interface-spec, compile-define-module-args): New. (define-module): Use compile-define-module-args to construct argument for process-define-module. (use-modules, use-syntax): Use compile-interface-spec to construct arguments for process-use-modules. (process-define-module): Expect keywords in argument list. --- ice-9/boot-9.scm | 243 ++++++++++++++++++++++++++++++----------------- 1 file changed, 158 insertions(+), 85 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index f4089c827..644c82725 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1608,52 +1608,61 @@ (eq? (car (last-pair use-list)) the-scm-module)) (set-module-uses! module (reverse (cdr (reverse use-list))))))) -;; Return a module interface made from SPEC. -;; SPEC can be a list of symbols, in which case it names a module -;; whose public interface is found and returned. +;; Return a module that is a interface to the module designated by +;; NAME. ;; -;; SPEC can also be of the form: -;; (MODULE-NAME [:select SELECTION] [:rename RENAMER]) -;; in which case a partial interface is newly created and returned. -;; MODULE-NAME is a list of symbols, as above; SELECTION is a list of -;; binding-specs to be imported; and RENAMER is a procedure that takes a -;; symbol and returns its new name. A binding-spec is either a symbol or a -;; pair of symbols (ORIG . SEEN), where ORIG is the name in the used module -;; and SEEN is the name in the using module. Note that SEEN is also passed -;; through RENAMER. +;; `resolve-interface' takes two keyword arguments: ;; -;; The `:select' and `:rename' clauses are optional. If both are omitted, the -;; returned interface has no bindings. If the `:select' clause is omitted, -;; RENAMER operates on the used module's public interface. +;; #:select SELECTION ;; -;; Signal "no code for module" error if module name is not resolvable or its -;; public interface is not available. Signal "no binding" error if selected -;; binding does not exist in the used module. +;; SELECTION is a list of binding-specs to be imported; A binding-spec +;; is either a symbol or a pair of symbols (ORIG . SEEN), where ORIG +;; is the name in the used module and SEEN is the name in the using +;; module. Note that SEEN is also passed through RENAMER, below. The +;; default is to select all bindings. If you specify no selection but +;; a renamer, only the bindings that already exists in the used module +;; are made available in the interface. Bindings that are added later +;; are not picked up. ;; -(define (resolve-interface spec) - (let* ((simple? (not (pair? (car spec)))) - (name (if simple? spec (car spec))) +;; #:renamer RENAMER +;; +;; RENAMER is a procedure that takes a symbol and returns its new +;; name. The default is to not perform any renaming. +;; +;; Signal "no code for module" error if module name is not resolvable +;; or its public interface is not available. Signal "no binding" +;; error if selected binding does not exist in the used module. +;; +(define (resolve-interface name . args) + + (define (get-keyword-arg args kw def) + (cond ((memq kw args) + => (lambda (kw-arg) + (if (null? (cdr kw-arg)) + (error "keyword without value: " kw)) + (cadr kw-arg))) + (else + def))) + + (let* ((select (get-keyword-arg args #:select #f)) + (renamer (get-keyword-arg args #:renamer identity)) (module (resolve-module name)) (public-i (and module (module-public-interface module)))) (and (or (not module) (not public-i)) (error "no code for module" name)) - (if simple? + (if (and (not select) (eq? renamer identity)) public-i - (let ((selection (cond ((memq ':select spec) => cadr) - (else (module-map (lambda (sym var) sym) - public-i)))) - (rename (cond ((memq ':rename spec) - => (lambda (x) - ;; fixme:ttn -- move to macroexpansion time - (eval (cadr x) (current-module)))) - (else identity))) + (let ((selection (or select (module-map (lambda (sym var) sym) + public-i))) (custom-i (make-module 31))) (set-module-kind! custom-i 'interface) + ;; XXX - should use a lazy binder so that changes to the + ;; used module are picked up automatically. (for-each (lambda (bspec) (let* ((direct? (symbol? bspec)) (orig (if direct? bspec (car bspec))) (seen (if direct? bspec (cdr bspec)))) - (module-add! custom-i (rename seen) + (module-add! custom-i (renamer seen) (or (module-local-variable module orig) (error ;; fixme: format manually for now @@ -1683,52 +1692,47 @@ (module-use! module interface)) (reverse reversed-interfaces)) (module-export! module exports)) - (let ((keyword (if (keyword? (car kws)) - (keyword->symbol (car kws)) - (and (symbol? (car kws)) - (let ((s (symbol->string (car kws)))) - (and (eq? (string-ref s 0) #\:) - (string->symbol (substring s 1)))))))) - (case keyword - ((use-module use-syntax) - (or (pair? (cdr kws)) - (unrecognized kws)) - (let* ((spec (cadr kws)) - (interface (resolve-interface spec))) - (and (eq? keyword 'use-syntax) - (or (symbol? (car spec)) - (error "invalid module name for use-syntax" - spec)) - (set-module-transformer! - module - (module-ref interface (car (last-pair spec)) - #f))) - (loop (cddr kws) - (cons interface reversed-interfaces) - exports))) - ((autoload) - (or (and (pair? (cdr kws)) (pair? (cddr kws))) - (unrecognized kws)) - (loop (cdddr kws) - (cons (make-autoload-interface module - (cadr kws) - (caddr kws)) - reversed-interfaces) - exports)) - ((no-backtrace) - (set-system-module! module #t) - (loop (cdr kws) reversed-interfaces exports)) - ((pure) - (purify-module! module) - (loop (cdr kws) reversed-interfaces exports)) - ((export) - (or (pair? (cdr kws)) - (unrecognized kws)) + (case (car kws) + ((#:use-module #:use-syntax) + (or (pair? (cdr kws)) + (unrecognized kws)) + (let* ((interface-args (cadr kws)) + (interface (apply resolve-interface interface-args))) + (and (eq? (car kws) 'use-syntax) + (or (symbol? (car spec)) + (error "invalid module name for use-syntax" + spec)) + (set-module-transformer! + module + (module-ref interface (car + (last-pair (car interface-args))) + #f))) (loop (cddr kws) - reversed-interfaces - (append (cadr kws) exports))) - (else - (unrecognized kws)))))) + (cons interface reversed-interfaces) + exports))) + ((#:autoload) + (or (and (pair? (cdr kws)) (pair? (cddr kws))) + (unrecognized kws)) + (loop (cdddr kws) + (cons (make-autoload-interface module + (cadr kws) + (caddr kws)) + reversed-interfaces) + exports)) + ((#:no-backtrace) + (set-system-module! module #t) + (loop (cdr kws) reversed-interfaces exports)) + ((#:pure) + (purify-module! module) + (loop (cdr kws) reversed-interfaces exports)) + ((#:export) + (or (pair? (cdr kws)) + (unrecognized kws)) + (loop (cddr kws) + reversed-interfaces + (append (cadr kws) exports))) + (else + (unrecognized kws))))) module)) ;;; {Autoload} @@ -2595,29 +2599,97 @@ ;;; {Module System Macros} ;;; +;; Return a list of expressions that evaluate to the appropriate +;; arguments for resolve-interface according to SPEC. + +(define (compile-interface-spec spec) + (define (make-keyarg sym key quote?) + (cond ((or (memq sym spec) + (memq key spec)) + => (lambda (rest) + (if quote? + (list key (list 'quote (cadr rest))) + (list key (cadr rest))))) + (else + '()))) + (define (map-apply func list) + (map (lambda (args) (apply func args)) list)) + (define keys + ;; sym key quote? + '((:select #:select #t) + (:rename #:rename #f))) + (if (not (pair? (car spec))) + `(',spec) + `(',(car spec) + ,@(apply append (map-apply make-keyarg keys))))) + +(define (keyword-like-symbol->keyword sym) + (symbol->keyword (string->symbol (substring (symbol->string sym) 1)))) + +(define (compile-define-module-args args) + ;; Just quote everything except #:use-module and #:use-syntax. We + ;; need to know about all arguments regardless since we want to turn + ;; symbols that look like keywords into real keywords, and the + ;; keyword args in a define-module form are not regular + ;; (i.e. no-backtrace doesn't take a value). + (let loop ((compiled-args `((quote ,(car args)))) + (args (cdr args))) + (cond ((null? args) + (reverse! compiled-args)) + ;; symbol in keyword position + ((symbol? (car args)) + (loop compiled-args + (cons (keyword-like-symbol->keyword (car args)) (cdr args)))) + ((memq (car args) '(#:no-backtrace #:pure)) + (loop (cons (car args) compiled-args) + (cdr args))) + ((null? (cdr args)) + (error "keyword without value:" (car args))) + ((memq (car args) '(#:use-module #:use-syntax)) + (loop (cons* `(list ,@(compile-interface-spec (cadr args))) + (car args) + compiled-args) + (cddr args))) + ((eq? (car args) #:autoload) + (loop (cons* `(quote ,(caddr args)) + `(quote ,(cadr args)) + (car args) + compiled-args) + (cdddr args))) + (else + (loop (cons* `(quote ,(cadr args)) + (car args) + compiled-args) + (cddr args)))))) + (defmacro define-module args `(eval-case ((load-toplevel) - (let ((m (process-define-module ',args))) + (let ((m (process-define-module + (list ,@(compile-define-module-args args))))) (set-current-module m) m)) (else (error "define-module can only be used at the top level")))) -;; the guts of the use-modules macro. add the interfaces of the named -;; modules to the use-list of the current module, in order -(define (process-use-modules module-interface-specs) - (for-each (lambda (mif-spec) - (let ((mod-iface (resolve-interface mif-spec))) +;; The guts of the use-modules macro. Add the interfaces of the named +;; modules to the use-list of the current module, in order. + +(define (process-use-modules module-interface-args) + (for-each (lambda (mif-args) + (let ((mod-iface (apply resolve-interface mif-args))) (or mod-iface (error "no such module" mif-spec)) (module-use! (current-module) mod-iface))) - module-interface-specs)) + module-interface-args)) (defmacro use-modules modules `(eval-case ((load-toplevel) - (process-use-modules ',modules)) + (process-use-modules + (list ,@(map (lambda (m) + `(list ,@(compile-interface-spec m))) + modules)))) (else (error "use-modules can only be used at the top level")))) @@ -2625,7 +2697,8 @@ `(eval-case ((load-toplevel) ,@(if (pair? spec) - `((process-use-modules ',(list spec)) + `((process-use-modules (list + (list ,@(compile-interface-spec spec)))) (set-module-transformer! (current-module) ,(car (last-pair spec)))) `((set-module-transformer! (current-module) ,spec))) From 63b62b733d822e383ecd3f801959be982ff5e6b4 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 1 Jun 2001 20:15:49 +0000 Subject: [PATCH 1224/2047] *** empty log message *** --- ice-9/ChangeLog | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 038101434..a9e34b66f 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -3,6 +3,13 @@ * boot-9.scm (top-repl): Revert part of the 2001-05-19 change. When defining the guile-user module, do not use any modules. Add them to guile-user when `top-repl' is called. + (resolve-interface): Expect keyword arguments instead of a `spec'. + (compile-interface-spec, compile-define-module-args): New. + (define-module): Use compile-define-module-args to construct + argument for process-define-module. + (use-modules, use-syntax): Use compile-interface-spec to construct + arguments for process-use-modules. + (process-define-module): Expect keywords in argument list. 2001-05-25 Marius Vollmer From dcd0a9645f3f2515b0677e4c74d20c12cd86e6b8 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 1 Jun 2001 23:43:14 +0000 Subject: [PATCH 1225/2047] Updated for next release. --- THANKS | 89 ++++++++++++++++++++++++++++++++++------------------------ 1 file changed, 52 insertions(+), 37 deletions(-) diff --git a/THANKS b/THANKS index 92ca5ba8a..fac953512 100644 --- a/THANKS +++ b/THANKS @@ -1,45 +1,60 @@ The Guile maintainer committee consists of - Jim Blandy - Mikael Djurfeldt - Maciej Stachowiak - Marius Vollmer + Jim Blandy + Mikael Djurfeldt + Maciej Stachowiak + Marius Vollmer Contributors since the last release: - Jost Boekemeier - Greg Harvey - Will Fitzgerald - Rob Browning + Rob Browning + Will Fitzgerald + Martin Grabmueller + Dirk Herrmann + Gary Houston + Neil Jerram + Matthias Koeppe + Michael Livshin + Thien-Thi Nguyen + Keisuke Nishida + Niibe Yutaka For fixes or providing information which led to a fix: - Lars J. Aas - Ian Bicking - Rob Browning - George Caswell - Chris Cramer - I. N. Golubev - Martin Grabmueller - Andres Holst - Neil Jerram - Brad Knotwell - Matthias Köppe - Bruce Korb - Ralf Mattes - Shuji Narazaki - Nicolas Neuss - Thien-Thi Nguyen - Han-Wen Nienhuys - David Pirotte - Sergey Poznyakoff - Julian Satchell - Bill Schottstaedt - Miroslav Silovic - Dale P. Smith - Masao Uebayashi - Jacques A. Vidrine - Brett Viren - William Webber - Keith Wright - Niibe Yutaka + Lars J. Aas + Martin Baulig + Ian Bicking + Quetzalcoatl Bradley + George Caswell + Albert Chin + Chris Cramer + I. N. Golubev + Utz-Uwe Haus + Karl M. Hegbloom + Anders Holst + Steven G. Johnson + Richard Kim + Alexander Klimov + Brad Knotwell + Bruce Korb + Matthias Köppe + Ralf Mattes + Shuji Narazaki + Han-Wen Nienhuys + Bertrand Petit + David Pirotte + Sergey Poznyakoff + Ariel Rios + Julian Satchell + Bill Schottstaedt + Miroslav Silovic + David Skarda + Dale P. Smith + Masao Uebayashi + Bernard Urban + Jacques A. Vidrine. + Brett Viren + Thomas Wawrzinek + Florian Weimer + Keith Wright + From 5f0cf00bcf20e78b3aefb5e7469a3f124e217c32 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 1 Jun 2001 23:46:36 +0000 Subject: [PATCH 1226/2047] *** empty log message *** --- AUTHORS | 64 ++++++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 61 insertions(+), 3 deletions(-) diff --git a/AUTHORS b/AUTHORS index 363ef8f8d..fa89a4bf3 100644 --- a/AUTHORS +++ b/AUTHORS @@ -76,16 +76,18 @@ gh_eval.c gh_io.c gh_test_c.c In the subdirectory doc, wrote: appendices.texi gh.texi guile-tut.texi -Marius Vollmer: +Marius Vollmer: Many changes throughout. In the subdirectory libguile, wrote: - fluids.c - fluids.h + fluids.c fluids.h + deprecation.h deprecation.c In the subdirectory libguile, rewrote: dynl.c dynl-dl.c dynl-shl.c dynl.h dynl-dld.c In the subdirectory doc, changes to: data-rep.texi intro.texi posix.texi scheme-modules.texi +In the subdirectory ice-9, wrote + and-let-star-compat.scm R. Kent Dybvig: In the subdirectory ice-9, wrote: @@ -142,6 +144,10 @@ In the subdirectory doc, changes to: scheme-memory.texi scheme-modules.texi scheme-options.texi scheme-procedures.texi scheme-scheduling.texi scheme-utility.texi +In the subdirectory example, wrote + scripts modules safe + box box-module box-dynamic + Will Fitzgerald: wrote initial srfi/srfi-19.scm. @@ -198,3 +204,55 @@ In the subdirectory doc, changes to: intro.texi preface.texi scheme-modules.texi scheme-procedures.texi scheme-scheduling.texi + +Robert Merkel: +In the subdirectory doc, co-wrote: + guile.1 + +Marc Feeley: +In the subdirectory doc, wrote: + pretty-print.scm + +The file libguile/gc_os_dep.c is from the Boehm-Weiser conservative +collector. A lot of people have contributed to it, but probably not +all to the code in gc_os_dep.c: + + The SPARC specific code was contributed by Mark Weiser + (weiser@parc.xerox.com). The Encore Multimax modifications were + supplied by Kevin Kenny (kenny@m.cs.uiuc.edu). The adaptation to + the RT is largely due to Vernon Lee (scorpion@rice.edu), on + machines made available by IBM. Much of the HP specific code and + a number of good suggestions for improving the generic code are + due to Walter Underwood (wunder@hp-ses.sde.hp.com). Robert + Brazile (brazile@diamond.bbn.com) originally supplied the ULTRIX + code. Al Dosser (dosser@src.dec.com) and Regis Cridlig + (Regis.Cridlig@cl.cam.ac.uk) subsequently provided updates and + information on variation between ULTRIX systems. Parag Patel + (parag@netcom.com) supplied the A/UX code. Jesper + Peterson(jep@mtiame.mtia.oz.au), Michel Schinz, and Martin + Tauchmann (martintauchmann@bigfoot.com) supplied the Amiga port. + Thomas Funke (thf@zelator.in-berlin.de(?)) and Brian D.Carlstrom + (bdc@clark.lcs.mit.edu) supplied the NeXT ports. Douglas Steel + (doug@wg.icl.co.uk) provided ICL DRS6000 code. Bill Janssen + (janssen@parc.xerox.com) supplied the SunOS dynamic loader + specific code. Manuel Serrano (serrano@cornas.inria.fr) supplied + linux and Sony News specific code. Al Dosser provided Alpha/OSF/1 + code. He and Dave Detlefs(detlefs@src.dec.com) also provided + several generic bug fixes. Alistair G. Crooks(agc@uts.amdahl.com) + supplied the NetBSD and 386BSD ports. Jeffrey Hsu + (hsu@soda.berkeley.edu) provided the FreeBSD port. Brent Benson + (brent@jade.ssd.csd.harris.com) ported the collector to a Motorola + 88K processor running CX/UX (Harris NightHawk). Ari Huttunen + (Ari.Huttunen@hut.fi) generalized the OS/2 port to nonIBM + development environments (a nontrivial task). Patrick Beard + (beard@cs.ucdavis.edu) provided the initial MacOS port. David + Chase, then at Olivetti Research, suggested several improvements. + Scott Schwartz (schwartz@groucho.cse.psu.edu) supplied some of the + code to save and print call stacks for leak detection on a SPARC. + Jesse Hull and John Ellis supplied the C++ interface code. Zhong + Shao performed much of the experimentation that led to the current + typed allocation facility. (His dynamic type inference code + hasn't made it into the released version of the collector, yet.) + (Blame for misinstallation of these modifications goes to the + first author, however.) + From 28fe405ecd2d7cb4784befeb49e749219d168c18 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 2 Jun 2001 04:58:55 +0000 Subject: [PATCH 1227/2047] * .cvsignore: here and in all subdirectories listing Makefile and Makefile.in. --- examples/.cvsignore | 2 ++ examples/ChangeLog | 5 +++++ examples/box-dynamic/.cvsignore | 2 ++ examples/box-module/.cvsignore | 2 ++ examples/box/.cvsignore | 2 ++ examples/modules/.cvsignore | 2 ++ examples/safe/.cvsignore | 2 ++ examples/scripts/.cvsignore | 2 ++ 8 files changed, 19 insertions(+) create mode 100644 examples/.cvsignore create mode 100644 examples/box-dynamic/.cvsignore create mode 100644 examples/box-module/.cvsignore create mode 100644 examples/box/.cvsignore create mode 100644 examples/modules/.cvsignore create mode 100644 examples/safe/.cvsignore create mode 100644 examples/scripts/.cvsignore diff --git a/examples/.cvsignore b/examples/.cvsignore new file mode 100644 index 000000000..282522db0 --- /dev/null +++ b/examples/.cvsignore @@ -0,0 +1,2 @@ +Makefile +Makefile.in diff --git a/examples/ChangeLog b/examples/ChangeLog index 5549fa574..fac04cd1b 100644 --- a/examples/ChangeLog +++ b/examples/ChangeLog @@ -1,3 +1,8 @@ +2001-06-01 Rob Browning + + * .cvsignore: here and in all subdirectories listing Makefile and + Makefile.in. + 2001-05-31 Martin Grabmueller * box-dynamic: New directory, implements the box type in a shared diff --git a/examples/box-dynamic/.cvsignore b/examples/box-dynamic/.cvsignore new file mode 100644 index 000000000..282522db0 --- /dev/null +++ b/examples/box-dynamic/.cvsignore @@ -0,0 +1,2 @@ +Makefile +Makefile.in diff --git a/examples/box-module/.cvsignore b/examples/box-module/.cvsignore new file mode 100644 index 000000000..282522db0 --- /dev/null +++ b/examples/box-module/.cvsignore @@ -0,0 +1,2 @@ +Makefile +Makefile.in diff --git a/examples/box/.cvsignore b/examples/box/.cvsignore new file mode 100644 index 000000000..282522db0 --- /dev/null +++ b/examples/box/.cvsignore @@ -0,0 +1,2 @@ +Makefile +Makefile.in diff --git a/examples/modules/.cvsignore b/examples/modules/.cvsignore new file mode 100644 index 000000000..282522db0 --- /dev/null +++ b/examples/modules/.cvsignore @@ -0,0 +1,2 @@ +Makefile +Makefile.in diff --git a/examples/safe/.cvsignore b/examples/safe/.cvsignore new file mode 100644 index 000000000..282522db0 --- /dev/null +++ b/examples/safe/.cvsignore @@ -0,0 +1,2 @@ +Makefile +Makefile.in diff --git a/examples/scripts/.cvsignore b/examples/scripts/.cvsignore new file mode 100644 index 000000000..282522db0 --- /dev/null +++ b/examples/scripts/.cvsignore @@ -0,0 +1,2 @@ +Makefile +Makefile.in From 2ac41cc17be7328c100e9c51a4f8d7c91d228945 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Sat, 2 Jun 2001 11:20:01 +0000 Subject: [PATCH 1228/2047] *** empty log message *** --- AUTHORS | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/AUTHORS b/AUTHORS index fa89a4bf3..ea35caee0 100644 --- a/AUTHORS +++ b/AUTHORS @@ -100,12 +100,18 @@ In the subdirectory libguile, wrote: In the subdirectory ice-9, wrote: session.scm -Michael N. Livshin: +Michael Livshin: Some changes throughout. Implemented support for double-word heap cells and converted some smobs to use them. In the subdirectory libguile, wrote: - guardians.c - guardians.h + guardians.c guardians.h filter-doc-snarfage.c + guile-snarf-docs.in guile-snarf-docs-texi.in +In the subdirectory libguile, changed extensively: + gc.c gc.h +In the subdirectory ice-9, wrote: + streams.scm and-let*.scm +In the subdirectory scripts, wrote: + snarf-check-and-output-texi Tim Pierce: In the subdirectory libguile, wrote: From 26446f99071028b6aa9d87739f46311774f6ebbb Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 2 Jun 2001 11:57:50 +0000 Subject: [PATCH 1229/2047] Added notes about keeping AUTHORS and THANKS uptodate. --- HACKING | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/HACKING b/HACKING index ed25e6572..a0487e30a 100644 --- a/HACKING +++ b/HACKING @@ -282,9 +282,15 @@ If you receive contributions you want to use from someone, let me know and I'll take care of the administrivia. Put the contributions aside until we have the necessary papers. +Once you accept a contribution, be sure to keep the files AUTHORS and +THANKS uptodate. + - When you make substantial changes to a file, add the current year to the list of years in the copyright notice at the top of the file. +- When you get bug reports or patches from people, be sure to list +them in THANKS. + Helpful hints ======================================================== From 23cc59681bfcc239de26b9c1e526e5dede63a042 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 2 Jun 2001 12:39:09 +0000 Subject: [PATCH 1230/2047] New file, slightly modified from libiberties mkstemps.c. --- libguile/mkstemp.c | 123 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 123 insertions(+) create mode 100644 libguile/mkstemp.c diff --git a/libguile/mkstemp.c b/libguile/mkstemp.c new file mode 100644 index 000000000..a35f8d6d0 --- /dev/null +++ b/libguile/mkstemp.c @@ -0,0 +1,123 @@ +/* Copyright (C) 1991, 1992, 1996, 1998 Free Software Foundation, Inc. + This file is derived from mkstemps.c from the GNU Libiberty Library + which in turn is derived from the GNU C Library. + + The GNU C Library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + The GNU C 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with the GNU C Library; see the file COPYING.LIB. If not, + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. */ + +#include "scmconfig.h" + +#ifdef HAVE_STDLIB_H +#include +#endif +#ifdef HAVE_STRING_H +#include +#endif +#include +#include +#include +#ifdef HAVE_UNISTD_H +#include +#endif +#ifdef HAVE_SYS_TIME_H +#include +#endif + +/* We need to provide a type for gcc_uint64_t. */ +#ifdef __GNUC__ +typedef unsigned long long gcc_uint64_t; +#else +typedef unsigned long gcc_uint64_t; +#endif + +#ifndef TMP_MAX +#define TMP_MAX 16384 +#endif + +/* Generate a unique temporary file name from TEMPLATE. + + TEMPLATE has the form: + + /ccXXXXXX + + The last six characters of TEMPLATE must be "XXXXXX"; they are + replaced with a string that makes the filename unique. + + Returns a file descriptor open on the file for reading and writing. */ +int +mkstemp (template) + char *template; +{ + static const char letters[] + = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"; + static gcc_uint64_t value; +#ifdef HAVE_GETTIMEOFDAY + struct timeval tv; +#endif + char *XXXXXX; + size_t len; + int count; + + len = strlen (template); + + if ((int) len < 6 + || strncmp (&template[len - 6], "XXXXXX", 6)) + { + return -1; + } + + XXXXXX = &template[len - 6]; + +#ifdef HAVE_GETTIMEOFDAY + /* Get some more or less random data. */ + gettimeofday (&tv, NULL); + value += ((gcc_uint64_t) tv.tv_usec << 16) ^ tv.tv_sec ^ getpid (); +#else + value += getpid (); +#endif + + for (count = 0; count < TMP_MAX; ++count) + { + gcc_uint64_t v = value; + int fd; + + /* Fill in the random bits. */ + XXXXXX[0] = letters[v % 62]; + v /= 62; + XXXXXX[1] = letters[v % 62]; + v /= 62; + XXXXXX[2] = letters[v % 62]; + v /= 62; + XXXXXX[3] = letters[v % 62]; + v /= 62; + XXXXXX[4] = letters[v % 62]; + v /= 62; + XXXXXX[5] = letters[v % 62]; + + fd = open (template, O_RDWR|O_CREAT|O_EXCL, 0600); + if (fd >= 0) + /* The file does not exist. */ + return fd; + + /* This is a random value. It is only necessary that the next + TMP_MAX values generated by adding 7777 to VALUE are different + with (module 2^32). */ + value += 7777; + } + + /* We return the null string if we can't find a unique file name. */ + template[0] = '\0'; + return -1; +} From 5bbfbd1e49becfaa0b62c722d96d452038f45abc Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 2 Jun 2001 12:39:46 +0000 Subject: [PATCH 1231/2047] Check for mkstemp via AC_REPLACE_FUNCS. Thanks to I. N. Golubev! --- configure.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.in b/configure.in index bbcac87dd..c104b6bc6 100644 --- a/configure.in +++ b/configure.in @@ -403,7 +403,7 @@ if test "$enable_regex" = yes; then fi fi -AC_REPLACE_FUNCS(inet_aton putenv strerror memmove) +AC_REPLACE_FUNCS(inet_aton putenv strerror memmove mkstemp) # When testing for the presence of alloca, we need to add alloca.o # explicitly to LIBOBJS to make sure that it is translated to From 114f9bab42516e9b3249d9210070ae0a9dcd4efd Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 2 Jun 2001 12:40:00 +0000 Subject: [PATCH 1232/2047] *** empty log message *** --- ChangeLog | 5 +++++ libguile/ChangeLog | 5 +++++ 2 files changed, 10 insertions(+) diff --git a/ChangeLog b/ChangeLog index 3f2a40677..b9484f8d8 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2001-06-02 Marius Vollmer + + * configure.in: Check for mkstemp via AC_REPLACE_FUNCS. Thanks to + I. N. Golubev! + 2001-06-01 Martin Grabmueller * configure.in: Generate examples/box-dynamic/Makefile. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f24f54e68..1afe9ff0c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-06-02 Marius Vollmer + + * mkstemp.c: New file, slightly modified from libiberties + mkstemps.c. + 2001-05-31 Michael Livshin * guile-snarf-docs.in, guile-snarf-docs-texi.in, From 094a67bb4c9ef7ee774d717324abf833d7b65a88 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 2 Jun 2001 18:29:24 +0000 Subject: [PATCH 1233/2047] *** empty log message *** --- NEWS | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/NEWS b/NEWS index ffff15251..86cfc9ac4 100644 --- a/NEWS +++ b/NEWS @@ -187,6 +187,8 @@ manuals. See the README file in the `doc' directory for more details. +** There are a couple of examples in the examples/ directory now. + * Changes to the stand-alone interpreter ** New command line option `--use-srfi' @@ -208,6 +210,12 @@ guile> (receive (x z) (values 1 2) (+ 1 2)) guile> (string-pad "bla" 20) " bla" +** Guile now always starts up in the `(guile-user)' module. + +Previously, script executed via the `-s' option would run in the +`(guile)' module and the repl would run in the `(guile-user)' module. +Now every user action takes place in the `(guile-user)' module by +default. * Changes to Scheme functions and syntax From aef9dd6536ebcb3bcf321e7dae47f1574acdfbb2 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 2 Jun 2001 18:32:03 +0000 Subject: [PATCH 1234/2047] (apropos-fold, submodules, apropos): Be careful not to access unbound variables. --- ice-9/session.scm | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/ice-9/session.scm b/ice-9/session.scm index 87ad2c5f7..15290dff9 100644 --- a/ice-9/session.scm +++ b/ice-9/session.scm @@ -257,12 +257,14 @@ where OPTIONSET is one of debug, read, eval, print (display name) (display ": ") (display (car x)) - (cond ((procedure? (variable-ref (cdr x))) + (cond ((variable-bound? (cdr x)) + (let ((val (variable-ref (cdr x)))) + (cond ((or (procedure? val) value) + (display separator) + (display val))))) + (else (display separator) - (display (variable-ref (cdr x)))) - (value - (display separator) - (display (variable-ref (cdr x))))) + (display "(unbound)"))) (if (and shadow (not (eq? (module-ref module (car x)) @@ -313,7 +315,9 @@ Fourth arg FOLDER is one of data))) (module-filter (lambda (name var data) - (obarray-filter name (variable-ref var) data)))) + (if (variable-bound? var) + (obarray-filter name (variable-ref var) data) + data)))) (cond (module (hash-fold module-filter data (module-obarray module))) @@ -352,7 +356,7 @@ It is an image under the mapping EXTRACT." (define (submodules m) (hash-fold (lambda (name var data) - (let ((obj (variable-ref var))) + (let ((obj (and (variable-bound? var) (variable-ref var)))) (if (and (module? obj) (eq? (module-kind obj) 'directory)) (cons obj data) From 9540368e79ea7c20c2262e78478ea95fa34819c8 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 2 Jun 2001 18:33:25 +0000 Subject: [PATCH 1235/2047] (module-ensure-variable!): New. (module-export!): Use it to ensure that there is a variable to export. Previously, we would always create a new variable, copy the value over, and export the new variable. This confused syncase since it keys important properties on variables. --- ice-9/boot-9.scm | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 644c82725..72d3e6d57 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1256,6 +1256,19 @@ (module-modified m) answer)))) +;; module-ensure-variable! module symbol +;; +;; ensure that there is a variable in MODULE for SYMBOL. If there is +;; no binding for SYMBOL, create a new undefined variable. Return +;; that variable. +;; +(define (module-ensure-variable! module symbol) + (or (module-variable module symbol) + (let ((var (make-undefined-variable))) + (variable-set-name-hint! var symbol) + (module-add! module symbol var) + var))) + ;; module-add! module symbol var ;; ;; ensure a particular variable for V in the local namespace of M. @@ -2745,10 +2758,8 @@ (define (module-export! m names) (let ((public-i (module-public-interface m))) (for-each (lambda (name) - ;; Make sure there is a local variable: - (module-define! m name (module-ref m name #f)) - ;; Make sure that local is exported: - (module-add! public-i name (module-variable m name))) + (let ((var (module-ensure-variable! m name))) + (module-add! public-i name var))) names))) (defmacro export names From c0017a49a5e790d604060b44809c4b2c71a881cd Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 2 Jun 2001 18:34:22 +0000 Subject: [PATCH 1236/2047] (psyntax.pp): Make it dependent on psyntax.ss and fix command so that it works. --- ice-9/Makefile.am | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index 4e436295a..b38b88893 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -45,5 +45,5 @@ install-data-local: ## test.scm is not currently installed. EXTRA_DIST = $(ice9_sources) test.scm and-let-star-compat.scm -psyntax.pp: - cd $(srcdir) && guile -c '(load-from-path "ice-9/syncase") (psyncomp)' +psyntax.pp: psyntax.ss + cd $(srcdir) && guile -c '(load-from-path "ice-9/syncase") (define-module (ice-9 syncase)) (psyncomp)' From 96e83482fba579979c8ff896d69ad3e72b5dd63a Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 2 Jun 2001 18:34:48 +0000 Subject: [PATCH 1237/2047] (scm_eval_string): Use scm_primitive_eval_x instead of scm_eval_x to allow module changes between the forms in the string. Set/restore module using scm_c_call_with_current_module. --- libguile/strports.c | 34 ++++++++++++++++++++-------------- 1 file changed, 20 insertions(+), 14 deletions(-) diff --git a/libguile/strports.c b/libguile/strports.c index de9dfbc79..54a371fd2 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -447,6 +447,24 @@ scm_eval_0str (const char *expr) return scm_eval_string (scm_makfrom0str (expr)); } +static SCM +inner_eval_string (void *data) +{ + SCM port = (SCM)data; + SCM form; + SCM ans = SCM_UNSPECIFIED; + + /* Read expressions from that port; ignore the values. */ + while (!SCM_EOF_OBJECT_P (form = scm_read (port))) + ans = scm_primitive_eval_x (form); + + /* Don't close the port here; if we re-enter this function via a + continuation, then the next time we enter it, we'll get an error. + It's a string port anyway, so there's no advantage to closing it + early. */ + + return ans; +} SCM_DEFINE (scm_eval_string, "eval-string", 1, 0, 0, (SCM string), @@ -458,20 +476,8 @@ SCM_DEFINE (scm_eval_string, "eval-string", 1, 0, 0, { SCM port = scm_mkstrport (SCM_INUM0, string, SCM_OPN | SCM_RDNG, "scm_eval_0str"); - SCM form; - SCM ans = SCM_UNSPECIFIED; - SCM module = scm_interaction_environment (); - - /* Read expressions from that port; ignore the values. */ - while (!SCM_EOF_OBJECT_P (form = scm_read (port))) - ans = scm_eval_x (form, module); - - /* Don't close the port here; if we re-enter this function via a - continuation, then the next time we enter it, we'll get an error. - It's a string port anyway, so there's no advantage to closing it - early. */ - - return ans; + return scm_c_call_with_current_module (scm_interaction_environment (), + inner_eval_string, (void *)port); } #undef FUNC_NAME From b0c16cd922c82e58ea11d3882d5107e85a47730d Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 2 Jun 2001 18:35:28 +0000 Subject: [PATCH 1238/2047] *** empty log message *** --- ice-9/ChangeLog | 14 ++++++++++++++ libguile/ChangeLog | 4 ++++ 2 files changed, 18 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index a9e34b66f..d154a7982 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,17 @@ +2001-06-02 Marius Vollmer + + * Makefile.am (psyntax.pp): Make it dependent on psyntax.ss and + fix command so that it works. + + * session.scm (apropos-fold, submodules, apropos): Be careful not + to access unbound variables. + + * boot-9.scm (module-ensure-variable!): New. + (module-export!): Use it to ensure that there is a variable to + export. Previously, we would always create a new variable, copy + the value over, and export the new variable. This confused + syncase since it keys important properties on variables. + 2001-06-01 Marius Vollmer * boot-9.scm (top-repl): Revert part of the 2001-05-19 change. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 1afe9ff0c..f9c1ac347 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,9 @@ 2001-06-02 Marius Vollmer + * strports.c (scm_eval_string): Use scm_primitive_eval_x instead + of scm_eval_x to allow module changes between the forms in the + string. Set/restore module using scm_c_call_with_current_module. + * mkstemp.c: New file, slightly modified from libiberties mkstemps.c. From f47a5239d44117a15fe16f95708d58adcfd50a6a Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 2 Jun 2001 20:30:20 +0000 Subject: [PATCH 1239/2047] * fports.c: HAVE_ST_BLKSIZE changed to HAVE_STRUCT_STAT_ST_BLKSIZE. (scm_fport_buffer_add): HAVE_ST_BLKSIZE changed to HAVE_STRUCT_STAT_ST_BLKSIZE. --- libguile/fports.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/fports.c b/libguile/fports.c index c8586a38b..acf7b3f2f 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -61,7 +61,7 @@ #else size_t fwrite (); #endif -#ifdef HAVE_ST_BLKSIZE +#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE #include #endif @@ -88,7 +88,7 @@ scm_fport_buffer_add (SCM port, long read_size, int write_size) if (read_size == -1 || write_size == -1) { size_t default_size; -#ifdef HAVE_ST_BLKSIZE +#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE struct stat st; default_size = (fstat (fp->fdes, &st) == -1) ? default_buffer_size From 1fd85bc565192fbaca87574ddb761e4689da250e Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 2 Jun 2001 20:30:29 +0000 Subject: [PATCH 1240/2047] * filesys.c (scm_stat2scm): HAVE_ST_RDEV changed to HAVE_STRUCT_STAT_ST_RDEV. (scm_stat2scm): HAVE_ST_BLKSIZE changed to HAVE_STRUCT_STAT_ST_BLKSIZE. (scm_stat2scm): HAVE_ST_BLOCKS changed to HAVE_STRUCT_STAT_ST_BLOCKS. --- libguile/filesys.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index 8648d447a..0960300e6 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -384,7 +384,7 @@ scm_stat2scm (struct stat *stat_temp) ve[3] = scm_ulong2num ((unsigned long) stat_temp->st_nlink); ve[4] = scm_ulong2num ((unsigned long) stat_temp->st_uid); ve[5] = scm_ulong2num ((unsigned long) stat_temp->st_gid); -#ifdef HAVE_ST_RDEV +#ifdef HAVE_STRUCT_STAT_ST_RDEV ve[6] = scm_ulong2num ((unsigned long) stat_temp->st_rdev); #else ve[6] = SCM_BOOL_F; @@ -393,12 +393,12 @@ scm_stat2scm (struct stat *stat_temp) ve[8] = scm_ulong2num ((unsigned long) stat_temp->st_atime); ve[9] = scm_ulong2num ((unsigned long) stat_temp->st_mtime); ve[10] = scm_ulong2num ((unsigned long) stat_temp->st_ctime); -#ifdef HAVE_ST_BLKSIZE +#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE ve[11] = scm_ulong2num ((unsigned long) stat_temp->st_blksize); #else ve[11] = scm_ulong2num (4096L); #endif -#ifdef HAVE_ST_BLOCKS +#ifdef HAVE_STRUCT_STAT_ST_BLOCKS ve[12] = scm_ulong2num ((unsigned long) stat_temp->st_blocks); #else ve[12] = SCM_BOOL_F; From 3074c04a00b7587a8bb86954c5e345f3e43cb394 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 2 Jun 2001 20:31:38 +0000 Subject: [PATCH 1241/2047] * .cvsignore: add guile_filter_doc_snarfage guile-snarf-docs guile-snarf-docs-texi. --- libguile/.cvsignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/libguile/.cvsignore b/libguile/.cvsignore index 648719c01..aa0d852e0 100644 --- a/libguile/.cvsignore +++ b/libguile/.cvsignore @@ -25,6 +25,8 @@ guile-doc-snarf guile-func-name-check guile-procedures.txt guile-snarf +guile-snarf-docs +guile-snarf-docs-texi guile-snarf.awk guile.texi libpath.h From f02327ae0313bcb3dba85629302cf8945c5389de Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 2 Jun 2001 20:34:43 +0000 Subject: [PATCH 1242/2047] * .cvsignore: really add guile_filter_doc_snarfage. --- libguile/.cvsignore | 1 + 1 file changed, 1 insertion(+) diff --git a/libguile/.cvsignore b/libguile/.cvsignore index aa0d852e0..7bdc7f277 100644 --- a/libguile/.cvsignore +++ b/libguile/.cvsignore @@ -28,6 +28,7 @@ guile-snarf guile-snarf-docs guile-snarf-docs-texi guile-snarf.awk +guile_filter_doc_snarfage guile.texi libpath.h libtool From 237b3247ac28841259fd0bdb80de5f11d54e1fe8 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 2 Jun 2001 20:35:01 +0000 Subject: [PATCH 1243/2047] * configure.in: changes for autoconf 2.50. (AC_PREREQ): require at least autoconf 2.50. (AC_INIT): no longer takes an arg. (AC_CONFIG_SRCDIR): takes arg AC_INIT used to take. (AC_STRUCT_ST_RDEV): changed -> AC_CHECK_MEMBERS. (AC_STRUCT_ST_BLKSIZE): deprecated -> AC_CHECK_MEMBERS. (AC_STRUCT_ST_BLOCKS): use it rather than our version. (AC_CONFIG_FILES): now generated files go here, not in AC_OUTPUT. (AC_CONFIG_COMMANDS): now actions go here, not in AC_OUTPUT. (AC_OUTPUT): no longer takes args. --- configure.in | 86 +++++++++++++++++++++++++++------------------------- 1 file changed, 45 insertions(+), 41 deletions(-) diff --git a/configure.in b/configure.in index c104b6bc6..a85113b7a 100644 --- a/configure.in +++ b/configure.in @@ -20,7 +20,10 @@ dnl along with GUILE; see the file COPYING. If not, write to the dnl Free Software Foundation, Inc., 59 Temple Place - Suite 330, dnl Boston, MA 02111-1307, USA. -AC_INIT(Makefile.in) +AC_PREREQ(2.50) + +AC_INIT +AC_CONFIG_SRCDIR([Makefile.in]) . $srcdir/GUILE-VERSION AM_INIT_AUTOMAKE($PACKAGE, $VERSION, no-define) AM_MAINTAINER_MODE @@ -411,18 +414,10 @@ AC_REPLACE_FUNCS(inet_aton putenv strerror memmove mkstemp) AC_FUNC_ALLOCA if test "$ALLOCA" = "alloca.o"; then LIBOBJS="alloca.o $LIBOBJS"; fi -AC_STRUCT_ST_RDEV -AC_STRUCT_ST_BLKSIZE +AC_CHECK_MEMBERS([struct stat.st_rdev]) +AC_CHECK_MEMBERS([struct stat.st_blksize]) -# We could use AC_STRUCT_ST_BLOCKS here, but that adds fileblocks.o to -# LIBOBJS, which we don't need. This seems more direct. -AC_CACHE_CHECK([for st_blocks in struct stat], ac_cv_struct_st_blocks, -[AC_TRY_COMPILE([#include -#include ], [struct stat s; s.st_blocks;], -ac_cv_struct_st_blocks=yes, ac_cv_struct_st_blocks=no)]) -if test $ac_cv_struct_st_blocks = yes; then - AC_DEFINE(HAVE_ST_BLOCKS) -fi +AC_STRUCT_ST_BLOCKS AC_CACHE_CHECK([for S_ISLNK in sys/stat.h], ac_cv_macro_S_ISLNK, [AC_TRY_CPP([#include @@ -603,35 +598,44 @@ AC_SUBST(LIBLOBJS) AC_SUBST(EXTRA_DOT_DOC_FILES) AC_SUBST(EXTRA_DOT_X_FILES) -AC_OUTPUT([Makefile - libguile/Makefile - libguile/guile-snarf - libguile/guile-doc-snarf - libguile/guile-func-name-check - libguile/guile-snarf-docs - libguile/guile-snarf-docs-texi - libguile/versiondat.h - ice-9/Makefile - oop/Makefile - oop/goops/Makefile - scripts/Makefile - srfi/Makefile - qt/Makefile - qt/qt.h - qt/md/Makefile - qt/time/Makefile - guile-config/Makefile - doc/Makefile - examples/Makefile - examples/scripts/Makefile - examples/box/Makefile - examples/box-module/Makefile - examples/box-dynamic/Makefile - examples/modules/Makefile - examples/safe/Makefile - check-guile - guile-tools], - [chmod +x libguile/guile-snarf libguile/guile-doc-snarf libguile/guile-func-name-check libguile/guile-snarf-docs libguile/guile-snarf-docs-texi check-guile guile-tools]) +AC_CONFIG_FILES([ + Makefile + libguile/Makefile + libguile/guile-doc-snarf + libguile/guile-func-name-check + libguile/guile-snarf-docs + libguile/guile-snarf-docs-texi + libguile/versiondat.h + ice-9/Makefile + oop/Makefile + oop/goops/Makefile + scripts/Makefile + srfi/Makefile + qt/Makefile + qt/qt.h + qt/md/Makefile + qt/time/Makefile + guile-config/Makefile + doc/Makefile + examples/Makefile + examples/scripts/Makefile + examples/box/Makefile + examples/box-module/Makefile + examples/box-dynamic/Makefile + examples/modules/Makefile + examples/safe/Makefile + check-guile + guile-tools]) + +AC_CONFIG_COMMANDS(default, + [ chmod +x libguile/guile-doc-snarf \ + libguile/guile-func-name-check \ + libguile/guile-snarf-docs \ + libguile/guile-snarf-docs-texi \ + check-guile \ + guile-tools]) + +AC_OUTPUT dnl Local Variables: dnl comment-start: "dnl " From ee79b9ff89e6f2b33e00221172b5bb5853f3e983 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 2 Jun 2001 20:35:14 +0000 Subject: [PATCH 1244/2047] * acinclude.m4: AC_LANG not a variable now -- use __cplusplus unconditionally . --- acinclude.m4 | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/acinclude.m4 b/acinclude.m4 index 7765f64d4..f0402880a 100644 --- a/acinclude.m4 +++ b/acinclude.m4 @@ -76,11 +76,10 @@ dnl select. Similarly for bzero. which can conflict with char $1(); below. */ #include /* Override any gcc2 internal prototype to avoid an error. */ -]ifelse(AC_LANG, CPLUSPLUS, [#ifdef __cplusplus +#ifdef __cplusplus extern "C" #endif -])dnl -[/* We use char because int might match the return type of a gcc2 +/* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char $1(); ], [ From 9454d8d5e7992a71854d0663d320583c890ec01a Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 2 Jun 2001 20:35:27 +0000 Subject: [PATCH 1245/2047] *** empty log message *** --- ChangeLog | 16 ++++++++++++++++ libguile/ChangeLog | 17 +++++++++++++++++ 2 files changed, 33 insertions(+) diff --git a/ChangeLog b/ChangeLog index b9484f8d8..babef5126 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,19 @@ +2001-06-02 Rob Browning + + * configure.in: changes for autoconf 2.50. + (AC_PREREQ): require at least autoconf 2.50. + (AC_INIT): no longer takes an arg. + (AC_CONFIG_SRCDIR): takes arg AC_INIT used to take. + (AC_STRUCT_ST_RDEV): changed -> AC_CHECK_MEMBERS. + (AC_STRUCT_ST_BLKSIZE): deprecated -> AC_CHECK_MEMBERS. + (AC_STRUCT_ST_BLOCKS): use it rather than our version. + (AC_CONFIG_FILES): now generated files go here, not in AC_OUTPUT. + (AC_CONFIG_COMMANDS): now actions go here, not in AC_OUTPUT. + (AC_OUTPUT): no longer takes args. + + * acinclude.m4: AC_LANG not a variable now -- use __cplusplus + unconditionally . + 2001-06-02 Marius Vollmer * configure.in: Check for mkstemp via AC_REPLACE_FUNCS. Thanks to diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f9c1ac347..47704653f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,20 @@ +2001-06-02 Rob Browning + + * .cvsignore: add guile_filter_doc_snarfage guile-snarf-docs + guile-snarf-docs-texi. + + * fports.c: HAVE_ST_BLKSIZE changed to + HAVE_STRUCT_STAT_ST_BLKSIZE. + (scm_fport_buffer_add): HAVE_ST_BLKSIZE changed to + HAVE_STRUCT_STAT_ST_BLKSIZE. + + * filesys.c (scm_stat2scm): HAVE_ST_RDEV changed to + HAVE_STRUCT_STAT_ST_RDEV. + (scm_stat2scm): HAVE_ST_BLKSIZE changed to + HAVE_STRUCT_STAT_ST_BLKSIZE. + (scm_stat2scm): HAVE_ST_BLOCKS changed to + HAVE_STRUCT_STAT_ST_BLOCKS. + 2001-06-02 Marius Vollmer * strports.c (scm_eval_string): Use scm_primitive_eval_x instead From 691f5a4d2d8c0ab0bf40294e5c36e5b16169ae98 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Jun 2001 00:59:23 +0000 Subject: [PATCH 1246/2047] Added AC_PREREQ(2.50) and minimally changed for autoconf 2.50. This is mostly so that the `transparent autoconf wrapper' on Debian picks the right version of autoconf. --- guile-readline/configure.in | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/guile-readline/configure.in b/guile-readline/configure.in index 1b0984023..a085dbcf9 100644 --- a/guile-readline/configure.in +++ b/guile-readline/configure.in @@ -1,4 +1,7 @@ -AC_INIT(readline.c) +AC_PREREQ(2.50) + +AC_INIT +AC_CONFIG_SRCDIR([readline.c]) . $srcdir/../GUILE-VERSION PACKAGE=guile-readline AM_INIT_AUTOMAKE($PACKAGE, $VERSION, no-define) @@ -98,4 +101,5 @@ fi AC_CHECK_FUNCS(strdup) -AC_OUTPUT(Makefile) +AC_CONFIG_FILES(Makefile) +AC_OUTPUT From 99a34d6e6af3c1660fef0fa4b08d526ce9f66501 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Jun 2001 01:02:53 +0000 Subject: [PATCH 1247/2047] (try-load-module): Bracket calls to try-module-linked and try-module-dynamic-link with `begin-deprecated'. (split-c-module-name, convert-c-registered-modules, registered-modules, register-modules, warn-autoload-deprecation, init-dynamic-module, dynamic-maybe-call, dynamic-maybe-link, find-and-link-dynamic-module, try-using-libtool-name, try-using-sharlib-name, link-dynamic-module, try-module-linked, try-module-dynamic-link): Deprecated. Activate deprecation message. --- ice-9/boot-9.scm | 272 +++++++++++++++++++++++------------------------ 1 file changed, 135 insertions(+), 137 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 72d3e6d57..d65666d7f 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1610,9 +1610,9 @@ ;; (define-special-value '(app modules new-ws) (lambda () (make-scm-module))) (define (try-load-module name) - (or (try-module-linked name) + (or (begin-deprecated (try-module-linked name)) (try-module-autoload name) - (try-module-dynamic-link name))) + (begin-deprecated (try-module-dynamic-link name)))) (define (purify-module! module) "Removes bindings in MODULE which are inherited from the (guile) module." @@ -1803,152 +1803,150 @@ ;;; Dynamic linking of modules ;; This method of dynamically linking Guile Extensions is deprecated. -;; Use `dynamic-link' and `dynamic-call' explicitely from Scheme code -;; instead. +;; Use `load-extension' explicitely from Scheme code instead. -;; XXX - We can not offer the removal of this code thru the -;; deprecation mechanism since we have no complete replacement yet. +(begin-deprecated -(define (split-c-module-name str) - (let loop ((rev '()) - (start 0) - (pos 0) - (end (string-length str))) - (cond - ((= pos end) - (reverse (cons (string->symbol (substring str start pos)) rev))) - ((eq? (string-ref str pos) #\space) - (loop (cons (string->symbol (substring str start pos)) rev) - (+ pos 1) - (+ pos 1) - end)) - (else - (loop rev start (+ pos 1) end))))) + (define (split-c-module-name str) + (let loop ((rev '()) + (start 0) + (pos 0) + (end (string-length str))) + (cond + ((= pos end) + (reverse (cons (string->symbol (substring str start pos)) rev))) + ((eq? (string-ref str pos) #\space) + (loop (cons (string->symbol (substring str start pos)) rev) + (+ pos 1) + (+ pos 1) + end)) + (else + (loop rev start (+ pos 1) end))))) -(define (convert-c-registered-modules dynobj) - (let ((res (map (lambda (c) - (list (split-c-module-name (car c)) (cdr c) dynobj)) - (c-registered-modules)))) - (c-clear-registered-modules) - res)) + (define (convert-c-registered-modules dynobj) + (let ((res (map (lambda (c) + (list (split-c-module-name (car c)) (cdr c) dynobj)) + (c-registered-modules)))) + (c-clear-registered-modules) + res)) -(define registered-modules '()) + (define registered-modules '()) -(define (register-modules dynobj) - (set! registered-modules - (append! (convert-c-registered-modules dynobj) - registered-modules))) + (define (register-modules dynobj) + (set! registered-modules + (append! (convert-c-registered-modules dynobj) + registered-modules))) -(define (warn-autoload-deprecation modname) - ;; Do nothing here until we can deprecate the code for real. - (if #f - (issue-deprecation-warning - "Autoloading of compiled code modules is deprecated." - "Write a Scheme file instead that uses `dynamic-link' directly."))) + (define (warn-autoload-deprecation modname) + (issue-deprecation-warning + "Autoloading of compiled code modules is deprecated." + "Write a Scheme file instead that uses `load-extension'.") + (issue-deprecation-warning + (simple-format #f "(You just autoloaded module ~S.)" modname))) + + (define (init-dynamic-module modname) + ;; Register any linked modules which have been registered on the C level + (register-modules #f) + (or-map (lambda (modinfo) + (if (equal? (car modinfo) modname) + (begin + (warn-autoload-deprecation modname) + (set! registered-modules (delq! modinfo registered-modules)) + (let ((mod (resolve-module modname #f))) + (save-module-excursion + (lambda () + (set-current-module mod) + (set-module-public-interface! mod mod) + (dynamic-call (cadr modinfo) (caddr modinfo)) + )) + #t)) + #f)) + registered-modules)) -(define (init-dynamic-module modname) - ;; Register any linked modules which have been registered on the C level - (register-modules #f) - (or-map (lambda (modinfo) - (if (equal? (car modinfo) modname) - (begin - (warn-autoload-deprecation modname) - (set! registered-modules (delq! modinfo registered-modules)) - (let ((mod (resolve-module modname #f))) - (save-module-excursion - (lambda () - (set-current-module mod) - (set-module-public-interface! mod mod) - (dynamic-call (cadr modinfo) (caddr modinfo)) - )) - #t)) - #f)) - registered-modules)) + (define (dynamic-maybe-call name dynobj) + (catch #t ; could use false-if-exception here + (lambda () + (dynamic-call name dynobj)) + (lambda args + #f))) -(define (dynamic-maybe-call name dynobj) - (catch #t ; could use false-if-exception here - (lambda () - (dynamic-call name dynobj)) - (lambda args - #f))) + (define (dynamic-maybe-link filename) + (catch #t ; could use false-if-exception here + (lambda () + (dynamic-link filename)) + (lambda args + #f))) -(define (dynamic-maybe-link filename) - (catch #t ; could use false-if-exception here - (lambda () - (dynamic-link filename)) - (lambda args - #f))) - -(define (find-and-link-dynamic-module module-name) - (define (make-init-name mod-name) - (string-append "scm_init" - (list->string (map (lambda (c) - (if (or (char-alphabetic? c) - (char-numeric? c)) - c - #\_)) - (string->list mod-name))) - "_module")) - - ;; Put the subdirectory for this module in the car of SUBDIR-AND-LIBNAME, - ;; and the `libname' (the name of the module prepended by `lib') in the cdr - ;; field. For example, if MODULE-NAME is the list (inet tcp-ip udp), then - ;; SUBDIR-AND-LIBNAME will be the pair ("inet/tcp-ip" . "libudp"). - (let ((subdir-and-libname - (let loop ((dirs "") - (syms module-name)) - (if (null? (cdr syms)) - (cons dirs (string-append "lib" (symbol->string (car syms)))) - (loop (string-append dirs (symbol->string (car syms)) "/") - (cdr syms))))) - (init (make-init-name (apply string-append - (map (lambda (s) - (string-append "_" - (symbol->string s))) - module-name))))) - (let ((subdir (car subdir-and-libname)) - (libname (cdr subdir-and-libname))) - - ;; Now look in each dir in %LOAD-PATH for `subdir/libfoo.la'. If that - ;; file exists, fetch the dlname from that file and attempt to link - ;; against it. If `subdir/libfoo.la' does not exist, or does not seem - ;; to name any shared library, look for `subdir/libfoo.so' instead and - ;; link against that. - (let check-dirs ((dir-list %load-path)) - (if (null? dir-list) - #f - (let* ((dir (in-vicinity (car dir-list) subdir)) - (sharlib-full - (or (try-using-libtool-name dir libname) - (try-using-sharlib-name dir libname)))) - (if (and sharlib-full (file-exists? sharlib-full)) - (link-dynamic-module sharlib-full init) - (check-dirs (cdr dir-list))))))))) - -(define (try-using-libtool-name libdir libname) - (let ((libtool-filename (in-vicinity libdir - (string-append libname ".la")))) - (and (file-exists? libtool-filename) - libtool-filename))) - -(define (try-using-sharlib-name libdir libname) - (in-vicinity libdir (string-append libname ".so"))) - -(define (link-dynamic-module filename initname) - ;; Register any linked modules which has been registered on the C level - (register-modules #f) - (let ((dynobj (dynamic-link filename))) - (dynamic-call initname dynobj) - (register-modules dynobj))) - -(define (try-module-linked module-name) - (init-dynamic-module module-name)) - -(define (try-module-dynamic-link module-name) - (and (find-and-link-dynamic-module module-name) - (init-dynamic-module module-name))) + (define (find-and-link-dynamic-module module-name) + (define (make-init-name mod-name) + (string-append "scm_init" + (list->string (map (lambda (c) + (if (or (char-alphabetic? c) + (char-numeric? c)) + c + #\_)) + (string->list mod-name))) + "_module")) + ;; Put the subdirectory for this module in the car of SUBDIR-AND-LIBNAME, + ;; and the `libname' (the name of the module prepended by `lib') in the cdr + ;; field. For example, if MODULE-NAME is the list (inet tcp-ip udp), then + ;; SUBDIR-AND-LIBNAME will be the pair ("inet/tcp-ip" . "libudp"). + (let ((subdir-and-libname + (let loop ((dirs "") + (syms module-name)) + (if (null? (cdr syms)) + (cons dirs (string-append "lib" (symbol->string (car syms)))) + (loop (string-append dirs (symbol->string (car syms)) "/") + (cdr syms))))) + (init (make-init-name (apply string-append + (map (lambda (s) + (string-append "_" + (symbol->string s))) + module-name))))) + (let ((subdir (car subdir-and-libname)) + (libname (cdr subdir-and-libname))) + + ;; Now look in each dir in %LOAD-PATH for `subdir/libfoo.la'. If that + ;; file exists, fetch the dlname from that file and attempt to link + ;; against it. If `subdir/libfoo.la' does not exist, or does not seem + ;; to name any shared library, look for `subdir/libfoo.so' instead and + ;; link against that. + (let check-dirs ((dir-list %load-path)) + (if (null? dir-list) + #f + (let* ((dir (in-vicinity (car dir-list) subdir)) + (sharlib-full + (or (try-using-libtool-name dir libname) + (try-using-sharlib-name dir libname)))) + (if (and sharlib-full (file-exists? sharlib-full)) + (link-dynamic-module sharlib-full init) + (check-dirs (cdr dir-list))))))))) + + (define (try-using-libtool-name libdir libname) + (let ((libtool-filename (in-vicinity libdir + (string-append libname ".la")))) + (and (file-exists? libtool-filename) + libtool-filename))) + + (define (try-using-sharlib-name libdir libname) + (in-vicinity libdir (string-append libname ".so"))) + + (define (link-dynamic-module filename initname) + ;; Register any linked modules which have been registered on the C level + (register-modules #f) + (let ((dynobj (dynamic-link filename))) + (dynamic-call initname dynobj) + (register-modules dynobj))) + + (define (try-module-linked module-name) + (init-dynamic-module module-name)) + (define (try-module-dynamic-link module-name) + (and (find-and-link-dynamic-module module-name) + (init-dynamic-module module-name)))) +;; end of deprecated section + (define autoloads-done '((guile . guile))) From 46ca6c2e28965d5b24af40de75ead63130970203 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Jun 2001 01:03:31 +0000 Subject: [PATCH 1248/2047] (scm_register_module_xxx, scm_registered_modules, scm_clear_registered_modules): Deprecated. --- libguile/dynl.c | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/libguile/dynl.c b/libguile/dynl.c index c26dd2a15..ca00e4e73 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -129,6 +129,8 @@ scm_must_free_argv(char **argv) free (argv); } +#if SCM_DEBUG_DEPRECATED == 0 + /* Module registry */ @@ -150,6 +152,9 @@ scm_register_module_xxx (char *module_name, void *init_func) { struct moddata *md; + scm_c_issue_deprecation_warning + ("`scm_register_module_xxx' is deprecated. Use extensions instead."); + /* XXX - should we (and can we) DEFER_INTS here? */ for (md = registered_mods; md; md = md->link) @@ -186,6 +191,9 @@ SCM_DEFINE (scm_registered_modules, "c-registered-modules", 0, 0, 0, SCM res; struct moddata *md; + scm_c_issue_deprecation_warning + ("`registered-modules' is deprecated. Use extensions instead."); + res = SCM_EOL; for (md = registered_mods; md; md = md->link) res = scm_cons (scm_cons (scm_makfrom0str (md->module_name), @@ -206,6 +214,9 @@ SCM_DEFINE (scm_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0, { struct moddata *md1, *md2; + scm_c_issue_deprecation_warning + ("`c-clear-registered-modules' is deprecated. Use extensions instead."); + SCM_DEFER_INTS; for (md1 = registered_mods; md1; md1 = md2) @@ -220,6 +231,8 @@ SCM_DEFINE (scm_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0, } #undef FUNC_NAME +#endif /* !SCM_DEBUG_DEPRECATED */ + /* Dispatch to the system dependent files * * They define some static functions. These functions are called with From 1e4be672f5643f043f5d05f08cc07945ae577b23 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Jun 2001 01:04:51 +0000 Subject: [PATCH 1249/2047] (AC_CONFIG_FILES, AC_CONFIG_COMMANDS): Add guile-snarf. --- configure.in | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/configure.in b/configure.in index a85113b7a..678202bb3 100644 --- a/configure.in +++ b/configure.in @@ -601,6 +601,7 @@ AC_SUBST(EXTRA_DOT_X_FILES) AC_CONFIG_FILES([ Makefile libguile/Makefile + libguile/guile-snarf libguile/guile-doc-snarf libguile/guile-func-name-check libguile/guile-snarf-docs @@ -628,7 +629,8 @@ AC_CONFIG_FILES([ guile-tools]) AC_CONFIG_COMMANDS(default, - [ chmod +x libguile/guile-doc-snarf \ + [ chmod +x libguile/guile-snarf \ + libguile/guile-doc-snarf \ libguile/guile-func-name-check \ libguile/guile-snarf-docs \ libguile/guile-snarf-docs-texi \ From c794483cc03249ded91c49ab4e05a32bc99e2ed5 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Jun 2001 01:07:06 +0000 Subject: [PATCH 1250/2047] *** empty log message *** --- AUTHORS | 4 ++-- ChangeLog | 5 +++++ HACKING | 6 +++--- RELEASE | 4 +++- guile-readline/ChangeLog | 6 ++++++ ice-9/ChangeLog | 12 ++++++++++++ libguile/ChangeLog | 5 +++++ 7 files changed, 36 insertions(+), 6 deletions(-) diff --git a/AUTHORS b/AUTHORS index ea35caee0..8a6640405 100644 --- a/AUTHORS +++ b/AUTHORS @@ -78,8 +78,8 @@ In the subdirectory doc, wrote: Marius Vollmer: Many changes throughout. In the subdirectory libguile, wrote: - fluids.c fluids.h - deprecation.h deprecation.c + fluids.c fluids.h extensions.h + deprecation.h deprecation.c extensions.c In the subdirectory libguile, rewrote: dynl.c dynl-dl.c dynl-shl.c dynl.h dynl-dld.c diff --git a/ChangeLog b/ChangeLog index babef5126..5324f549e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2001-06-03 Marius Vollmer + + * configure.in (AC_CONFIG_FILES, AC_CONFIG_COMMANDS): Add + guile-snarf. + 2001-06-02 Rob Browning * configure.in: changes for autoconf 2.50. diff --git a/HACKING b/HACKING index a0487e30a..e5ae2aea4 100644 --- a/HACKING +++ b/HACKING @@ -37,12 +37,12 @@ you want to make changes to the system (which we encourage!) you will find it helpful to have the tools we use to develop Guile. They are the following: -Autoconf 2.13 --- a system for automatically generating `configure' +Autoconf 2.50 --- a system for automatically generating `configure' scripts from templates which list the non-portable features a program would like to use. Available in "ftp://ftp.gnu.org/pub/gnu/autoconf" -Automake 1.4 --- a system for automatically generating Makefiles that +Automake 1.4-p2 --- a system for automatically generating Makefiles that conform to the (rather Byzantine) GNU coding standards. The nice thing is that it takes care of hairy targets like 'make dist' and 'make distclean', and automatically generates @@ -53,7 +53,7 @@ Automake 1.4 --- a system for automatically generating Makefiles that `guile.m4' from the top directory of the Guile core disty to `/usr/local/share/aclocal. -libtool 1.3.5 --- a system for managing the zillion hairy options needed +libtool 1.4 --- a system for managing the zillion hairy options needed on various systems to produce shared libraries. Available in "ftp://ftp.gnu.org/pub/gnu/libtool" diff --git a/RELEASE b/RELEASE index 5043e9fd9..b193220d7 100644 --- a/RELEASE +++ b/RELEASE @@ -47,7 +47,9 @@ After signal handling and threading have been fixed: try-module-dynamic-link init-dynamic-module scm_register_module_xxx - etc. + scm_registered_modules + scm_clear_registered_modules + - remove deprecated variables: scm_top_level_lookup_closure_var scm_scm_system_transformer diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 8ae349f08..d010037cd 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,9 @@ +2001-06-03 Marius Vollmer + + * configure.in: Added AC_PREREQ(2.50) and minimally changed for + autoconf 2.50. This is mostly so that the `transparent autoconf + wrapper' on Debian picks the right version of autoconf. + 2001-05-31 Michael Livshin * Makefile.am (libguilereadline_la_SOURCES): removed readline.x diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index d154a7982..b79bc526b 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,15 @@ +2001-06-03 Marius Vollmer + + * boot-9.scm (try-load-module): Bracket calls to try-module-linked + and try-module-dynamic-link with `begin-deprecated'. + (split-c-module-name, convert-c-registered-modules, + registered-modules, register-modules, warn-autoload-deprecation, + init-dynamic-module, dynamic-maybe-call, dynamic-maybe-link, + find-and-link-dynamic-module, try-using-libtool-name, + try-using-sharlib-name, link-dynamic-module, try-module-linked, + try-module-dynamic-link): Deprecated. Activate deprecation + message. + 2001-06-02 Marius Vollmer * Makefile.am (psyntax.pp): Make it dependent on psyntax.ss and diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 47704653f..5864d8a07 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-06-03 Marius Vollmer + + * dynl.c (scm_register_module_xxx, scm_registered_modules, + scm_clear_registered_modules): Deprecated. + 2001-06-02 Rob Browning * .cvsignore: add guile_filter_doc_snarfage guile-snarf-docs From b3372ff632a4f3258c935129bf3c5880cb82801f Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Sun, 3 Jun 2001 14:59:19 +0000 Subject: [PATCH 1251/2047] *** empty log message *** --- .cvsignore | 1 + doc/sources/.cvsignore | 1 + 2 files changed, 2 insertions(+) diff --git a/.cvsignore b/.cvsignore index da5d0bd13..24aa42bcc 100644 --- a/.cvsignore +++ b/.cvsignore @@ -14,4 +14,5 @@ libtool ltconfig ltmain.sh check-guile +check-guile.log guile-tools diff --git a/doc/sources/.cvsignore b/doc/sources/.cvsignore index dc9df74a2..1b583920e 100644 --- a/doc/sources/.cvsignore +++ b/doc/sources/.cvsignore @@ -1,4 +1,5 @@ Makefile +Makefile.in stamp-vti *.log *.dvi From ac30b1e6b16ae081d95ab41930e54e583bd14102 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 3 Jun 2001 19:58:03 +0000 Subject: [PATCH 1252/2047] *** empty log message *** --- AUTHORS | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/AUTHORS b/AUTHORS index 8a6640405..37302d610 100644 --- a/AUTHORS +++ b/AUTHORS @@ -19,12 +19,15 @@ In the subdirectory libguile, wrote: gsubr.c ramap.c unif.c gsubr.h ramap.h unif.h -Gary Houston: changes to many files in libguile. +Gary Houston: +In the subdirectory libguile, wrote: + rw.c In the subdirectory ice-9, wrote: - expect.scm networking.scm popen.scm posix.scm + expect.scm networking.scm popen.scm posix.scm rw.scm In the subdirectory doc, changes to: data-rep.texi expect.texi guile-tut.texi posix.texi r5rs.texi scheme-io.texi +Many other changes throughout. Jim Blandy: Many changes throughout. In the subdirectory libguile, wrote: From a482f2cc7b2edaa2c5cd66efe81cbf4428919dbe Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Jun 2001 23:29:45 +0000 Subject: [PATCH 1253/2047] Added exception notice to all files. (module-export!): Revert 2001-06-02 change. It caused more problems than it solved by accidentally re-exporting importing bindings once in a while. --- ice-9/and-let-star.scm | 24 +++++++++++++++++ ice-9/boot-9.scm | 37 ++++++++++++++++++++++--- ice-9/buffered-input.scm | 24 +++++++++++++++++ ice-9/calling.scm | 24 +++++++++++++++++ ice-9/channel.scm | 24 +++++++++++++++++ ice-9/common-list.scm | 24 +++++++++++++++++ ice-9/debug.scm | 24 +++++++++++++++++ ice-9/debugger.scm | 24 +++++++++++++++++ ice-9/documentation.scm | 24 +++++++++++++++++ ice-9/emacs.scm | 24 +++++++++++++++++ ice-9/expect.scm | 24 +++++++++++++++++ ice-9/getopt-long.scm | 26 +++++++++++++++++- ice-9/hcons.scm | 24 +++++++++++++++++ ice-9/history.scm | 24 +++++++++++++++++ ice-9/lineio.scm | 24 +++++++++++++++++ ice-9/ls.scm | 24 +++++++++++++++++ ice-9/mapping.scm | 24 +++++++++++++++++ ice-9/match.scm | 24 +++++++++++++++++ ice-9/networking.scm | 24 +++++++++++++++++ ice-9/null.scm | 24 +++++++++++++++++ ice-9/optargs.scm | 24 +++++++++++++++++ ice-9/poe.scm | 24 +++++++++++++++++ ice-9/popen.scm | 24 +++++++++++++++++ ice-9/posix.scm | 24 +++++++++++++++++ ice-9/pretty-print.scm | 43 +++++++++++++++++++++++++++++ ice-9/psyntax.ss | 24 +++++++++++++++++ ice-9/q.scm | 24 +++++++++++++++++ ice-9/r4rs.scm | 24 +++++++++++++++++ ice-9/r5rs.scm | 24 +++++++++++++++++ ice-9/rdelim.scm | 24 +++++++++++++++++ ice-9/receive.scm | 24 +++++++++++++++++ ice-9/regex.scm | 24 +++++++++++++++++ ice-9/runq.scm | 24 +++++++++++++++++ ice-9/rw.scm | 24 +++++++++++++++++ ice-9/safe-r5rs.scm | 24 +++++++++++++++++ ice-9/safe.scm | 24 +++++++++++++++++ ice-9/session.scm | 24 +++++++++++++++++ ice-9/slib.scm | 58 ++++++++++++++++++++++++++++------------ ice-9/stack-catch.scm | 24 +++++++++++++++++ ice-9/streams.scm | 24 +++++++++++++++++ ice-9/string-fun.scm | 24 +++++++++++++++++ ice-9/syncase.scm | 24 +++++++++++++++++ ice-9/tags.scm | 24 ----------------- ice-9/threads.scm | 24 +++++++++++++++++ ice-9/time.scm | 24 +++++++++++++++++ 45 files changed, 1102 insertions(+), 46 deletions(-) diff --git a/ice-9/and-let-star.scm b/ice-9/and-let-star.scm index 4055d17fe..c2d7f6002 100644 --- a/ice-9/and-let-star.scm +++ b/ice-9/and-let-star.scm @@ -17,6 +17,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. (define-module (ice-9 and-let-star)) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index d65666d7f..000c4a4a0 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -17,6 +17,30 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA ;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. +;;;; ;;; Commentary: @@ -1262,6 +1286,9 @@ ;; no binding for SYMBOL, create a new undefined variable. Return ;; that variable. ;; +;; (This is not a really clean thing to do, we should evetually get +;; rid of the need for `module-ensure-variable!') +;; (define (module-ensure-variable! module symbol) (or (module-variable module symbol) (let ((var (make-undefined-variable))) @@ -2734,8 +2761,8 @@ (#t (let ((name (defined-name (car args)))) `(begin - (eval-case ((load-toplevel) (export ,name))) - (define-private ,@args)))))) + (define-private ,@args) + (eval-case ((load-toplevel) (export ,name)))))))) (defmacro defmacro-public args (define (syntax) @@ -2756,8 +2783,10 @@ (define (module-export! m names) (let ((public-i (module-public-interface m))) (for-each (lambda (name) - (let ((var (module-ensure-variable! m name))) - (module-add! public-i name var))) + ;; Make sure there is a local variable: + (module-define! m name (module-ref m name #f)) + ;; Make sure that local is exported: + (module-add! public-i name (module-variable m name))) names))) (defmacro export names diff --git a/ice-9/buffered-input.scm b/ice-9/buffered-input.scm index c289a58a3..1cfc2ea76 100644 --- a/ice-9/buffered-input.scm +++ b/ice-9/buffered-input.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. (define-module (ice-9 buffered-input) #:export (make-buffered-input-port diff --git a/ice-9/calling.scm b/ice-9/calling.scm index 5b06d7f19..3f2f57b65 100644 --- a/ice-9/calling.scm +++ b/ice-9/calling.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; (define-module (ice-9 calling)) diff --git a/ice-9/channel.scm b/ice-9/channel.scm index 96978aab2..e3527d441 100644 --- a/ice-9/channel.scm +++ b/ice-9/channel.scm @@ -16,6 +16,30 @@ ;; along with this program; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. +;; +;; As a special exception, the Free Software Foundation gives permission +;; for additional uses of the text contained in its release of GUILE. +;; +;; The exception is that, if you link the GUILE library with other files +;; to produce an executable, this does not by itself cause the +;; resulting executable to be covered by the GNU General Public License. +;; Your use of that executable is in no way restricted on account of +;; linking the GUILE library code into it. +;; +;; This exception does not however invalidate any other reasons why +;; the executable file might be covered by the GNU General Public License. +;; +;; This exception applies only to the code released by the +;; Free Software Foundation under the name GUILE. If you copy +;; code from other Free Software Foundation releases into a copy of +;; GUILE, as the General Public License permits, the exception does +;; not apply to the code that you add in this way. To avoid misleading +;; anyone as to the status of such modified files, you must delete +;; this exception notice from them. +;; +;; If you write modifications of your own for GUILE, it is your choice +;; whether to permit this exception to apply to your modifications. +;; If you do not wish that, delete this exception notice. ;;; Commentary: diff --git a/ice-9/common-list.scm b/ice-9/common-list.scm index c5c8c0609..1301b4219 100644 --- a/ice-9/common-list.scm +++ b/ice-9/common-list.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; (define-module (ice-9 common-list)) diff --git a/ice-9/debug.scm b/ice-9/debug.scm index 04043a13e..f01676ba4 100644 --- a/ice-9/debug.scm +++ b/ice-9/debug.scm @@ -15,6 +15,30 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA ;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. +;;;; ;;;; The author can be reached at djurfeldt@nada.kth.se ;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN ;;;; diff --git a/ice-9/debugger.scm b/ice-9/debugger.scm index d185f2dca..16b6d81b5 100644 --- a/ice-9/debugger.scm +++ b/ice-9/debugger.scm @@ -16,6 +16,30 @@ ;;; along with this software; see the file COPYING. If not, write to ;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;; Boston, MA 02111-1307 USA +;;; +;;; As a special exception, the Free Software Foundation gives permission +;;; for additional uses of the text contained in its release of GUILE. +;;; +;;; The exception is that, if you link the GUILE library with other files +;;; to produce an executable, this does not by itself cause the +;;; resulting executable to be covered by the GNU General Public License. +;;; Your use of that executable is in no way restricted on account of +;;; linking the GUILE library code into it. +;;; +;;; This exception does not however invalidate any other reasons why +;;; the executable file might be covered by the GNU General Public License. +;;; +;;; This exception applies only to the code released by the +;;; Free Software Foundation under the name GUILE. If you copy +;;; code from other Free Software Foundation releases into a copy of +;;; GUILE, as the General Public License permits, the exception does +;;; not apply to the code that you add in this way. To avoid misleading +;;; anyone as to the status of such modified files, you must delete +;;; this exception notice from them. +;;; +;;; If you write modifications of your own for GUILE, it is your choice +;;; whether to permit this exception to apply to your modifications. +;;; If you do not wish that, delete this exception notice. (define-module (ice-9 debugger) :use-module (ice-9 debug) diff --git a/ice-9/documentation.scm b/ice-9/documentation.scm index 27d160ff5..1a9e04c5c 100644 --- a/ice-9/documentation.scm +++ b/ice-9/documentation.scm @@ -15,6 +15,30 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA ;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. +;;;; ;;; Commentary: diff --git a/ice-9/emacs.scm b/ice-9/emacs.scm index 4fa6bcd2f..85e9bd551 100644 --- a/ice-9/emacs.scm +++ b/ice-9/emacs.scm @@ -15,6 +15,30 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA ;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. +;;;; ;;;; The author can be reached at djurfeldt@nada.kth.se ;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN ;;;; (I didn't write this!) diff --git a/ice-9/expect.scm b/ice-9/expect.scm index 2a0c1b954..1c46a9921 100644 --- a/ice-9/expect.scm +++ b/ice-9/expect.scm @@ -15,6 +15,30 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA ;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. +;;;; ;;; Commentary: diff --git a/ice-9/getopt-long.scm b/ice-9/getopt-long.scm index c3660f5ff..a5722dbf5 100644 --- a/ice-9/getopt-long.scm +++ b/ice-9/getopt-long.scm @@ -1,5 +1,5 @@ ;;; Author: Russ McManus -;;; $Id: getopt-long.scm,v 1.3 2001-05-06 09:40:32 ttn Exp $ +;;; $Id: getopt-long.scm,v 1.4 2001-06-03 23:29:45 mvo Exp $ ;;; ;;; Copyright (C) 1998, 2001 Free Software Foundation, Inc. ;;; @@ -16,6 +16,30 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +;;; +;;; As a special exception, the Free Software Foundation gives permission +;;; for additional uses of the text contained in its release of GUILE. +;;; +;;; The exception is that, if you link the GUILE library with other files +;;; to produce an executable, this does not by itself cause the +;;; resulting executable to be covered by the GNU General Public License. +;;; Your use of that executable is in no way restricted on account of +;;; linking the GUILE library code into it. +;;; +;;; This exception does not however invalidate any other reasons why +;;; the executable file might be covered by the GNU General Public License. +;;; +;;; This exception applies only to the code released by the +;;; Free Software Foundation under the name GUILE. If you copy +;;; code from other Free Software Foundation releases into a copy of +;;; GUILE, as the General Public License permits, the exception does +;;; not apply to the code that you add in this way. To avoid misleading +;;; anyone as to the status of such modified files, you must delete +;;; this exception notice from them. +;;; +;;; If you write modifications of your own for GUILE, it is your choice +;;; whether to permit this exception to apply to your modifications. +;;; If you do not wish that, delete this exception notice. ;;; Commentary: diff --git a/ice-9/hcons.scm b/ice-9/hcons.scm index 3b74f4164..1b20a5362 100644 --- a/ice-9/hcons.scm +++ b/ice-9/hcons.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; diff --git a/ice-9/history.scm b/ice-9/history.scm index e32bd5d15..66bb7a8cc 100644 --- a/ice-9/history.scm +++ b/ice-9/history.scm @@ -14,6 +14,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; ;;;; A simple value history support diff --git a/ice-9/lineio.scm b/ice-9/lineio.scm index 25711f8c3..fda97d530 100644 --- a/ice-9/lineio.scm +++ b/ice-9/lineio.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; diff --git a/ice-9/ls.scm b/ice-9/ls.scm index 11d2c94bf..60c765eb9 100644 --- a/ice-9/ls.scm +++ b/ice-9/ls.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; (define-module (ice-9 ls) diff --git a/ice-9/mapping.scm b/ice-9/mapping.scm index 3610b87f8..3630147ab 100644 --- a/ice-9/mapping.scm +++ b/ice-9/mapping.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; diff --git a/ice-9/match.scm b/ice-9/match.scm index ca10d7d37..75b4608d9 100644 --- a/ice-9/match.scm +++ b/ice-9/match.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; (define-module (ice-9 match) diff --git a/ice-9/networking.scm b/ice-9/networking.scm index 8ca074e70..c9089554e 100644 --- a/ice-9/networking.scm +++ b/ice-9/networking.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; (define (gethostbyaddr addr) (gethost addr)) diff --git a/ice-9/null.scm b/ice-9/null.scm index 594267bd2..6875a438e 100644 --- a/ice-9/null.scm +++ b/ice-9/null.scm @@ -14,6 +14,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; ;;;; The null environment - only syntactic bindings diff --git a/ice-9/optargs.scm b/ice-9/optargs.scm index db2d7d2a4..2ee0411ac 100644 --- a/ice-9/optargs.scm +++ b/ice-9/optargs.scm @@ -17,6 +17,30 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA ;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. +;;;; ;;;; Contributed by Maciej Stachowiak diff --git a/ice-9/poe.scm b/ice-9/poe.scm index ccb8759ec..91acd1195 100644 --- a/ice-9/poe.scm +++ b/ice-9/poe.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; diff --git a/ice-9/popen.scm b/ice-9/popen.scm index b8214abb7..62846ff6c 100644 --- a/ice-9/popen.scm +++ b/ice-9/popen.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; (define-module (ice-9 popen)) diff --git a/ice-9/posix.scm b/ice-9/posix.scm index 9d76a79d0..701e942cc 100644 --- a/ice-9/posix.scm +++ b/ice-9/posix.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; (define (stat:dev f) (vector-ref f 0)) diff --git a/ice-9/pretty-print.scm b/ice-9/pretty-print.scm index bf4aac2ac..187a7abdb 100644 --- a/ice-9/pretty-print.scm +++ b/ice-9/pretty-print.scm @@ -1,3 +1,46 @@ +;;;; -*-scheme-*- +;;;; +;;;; Copyright (C) 2001 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. +;;;; (define-module (ice-9 pretty-print)) (export pretty-print) diff --git a/ice-9/psyntax.ss b/ice-9/psyntax.ss index ab55a2f27..b14c14f4a 100644 --- a/ice-9/psyntax.ss +++ b/ice-9/psyntax.ss @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; diff --git a/ice-9/q.scm b/ice-9/q.scm index 453ef95d1..335ec4ecd 100644 --- a/ice-9/q.scm +++ b/ice-9/q.scm @@ -17,6 +17,30 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA ;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. +;;;; ;;; Commentary: diff --git a/ice-9/r4rs.scm b/ice-9/r4rs.scm index 6dff2a616..f81833288 100644 --- a/ice-9/r4rs.scm +++ b/ice-9/r4rs.scm @@ -17,6 +17,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; apply and call-with-current-continuation diff --git a/ice-9/r5rs.scm b/ice-9/r5rs.scm index 2236c59b3..47dfd59f9 100644 --- a/ice-9/r5rs.scm +++ b/ice-9/r5rs.scm @@ -14,6 +14,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; ;;;; R5RS bindings diff --git a/ice-9/rdelim.scm b/ice-9/rdelim.scm index 787b79f0d..edc8cf8ec 100644 --- a/ice-9/rdelim.scm +++ b/ice-9/rdelim.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; diff --git a/ice-9/receive.scm b/ice-9/receive.scm index 982c9595e..257c46f0b 100644 --- a/ice-9/receive.scm +++ b/ice-9/receive.scm @@ -16,6 +16,30 @@ ;;; along with this software; see the file COPYING. If not, write to ;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;; Boston, MA 02111-1307 USA +;;; +;;; As a special exception, the Free Software Foundation gives permission +;;; for additional uses of the text contained in its release of GUILE. +;;; +;;; The exception is that, if you link the GUILE library with other files +;;; to produce an executable, this does not by itself cause the +;;; resulting executable to be covered by the GNU General Public License. +;;; Your use of that executable is in no way restricted on account of +;;; linking the GUILE library code into it. +;;; +;;; This exception does not however invalidate any other reasons why +;;; the executable file might be covered by the GNU General Public License. +;;; +;;; This exception applies only to the code released by the +;;; Free Software Foundation under the name GUILE. If you copy +;;; code from other Free Software Foundation releases into a copy of +;;; GUILE, as the General Public License permits, the exception does +;;; not apply to the code that you add in this way. To avoid misleading +;;; anyone as to the status of such modified files, you must delete +;;; this exception notice from them. +;;; +;;; If you write modifications of your own for GUILE, it is your choice +;;; whether to permit this exception to apply to your modifications. +;;; If you do not wish that, delete this exception notice. (define-module (ice-9 receive) :export (receive) diff --git a/ice-9/regex.scm b/ice-9/regex.scm index 3bda38b84..023c0b7bc 100644 --- a/ice-9/regex.scm +++ b/ice-9/regex.scm @@ -14,6 +14,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; ;;;; POSIX regex support functions. diff --git a/ice-9/runq.scm b/ice-9/runq.scm index 136f92595..4929756d3 100644 --- a/ice-9/runq.scm +++ b/ice-9/runq.scm @@ -17,6 +17,30 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA ;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. +;;;; ;;; Commentary: diff --git a/ice-9/rw.scm b/ice-9/rw.scm index da4bd86d9..bcfeb9591 100644 --- a/ice-9/rw.scm +++ b/ice-9/rw.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; diff --git a/ice-9/safe-r5rs.scm b/ice-9/safe-r5rs.scm index ae7e4f82a..1ebec99b5 100644 --- a/ice-9/safe-r5rs.scm +++ b/ice-9/safe-r5rs.scm @@ -14,6 +14,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; ;;;; Safe subset of R5RS bindings diff --git a/ice-9/safe.scm b/ice-9/safe.scm index bd4fc377f..b8bd7ac6f 100644 --- a/ice-9/safe.scm +++ b/ice-9/safe.scm @@ -14,6 +14,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; ;;;; Safe subset of R5RS bindings diff --git a/ice-9/session.scm b/ice-9/session.scm index 15290dff9..5b2b6e720 100644 --- a/ice-9/session.scm +++ b/ice-9/session.scm @@ -15,6 +15,30 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA ;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. +;;;; (define-module (ice-9 session) diff --git a/ice-9/slib.scm b/ice-9/slib.scm index 72e7a6404..c7d3af57f 100644 --- a/ice-9/slib.scm +++ b/ice-9/slib.scm @@ -1,23 +1,47 @@ ;;;; slib.scm --- definitions needed to get SLIB to work with Guile ;;;; -;;;; Copyright (C) 1997, 1998, 2000 Free Software Foundation, Inc. +;;;; Copyright (C) 1997, 1998, 2000 Free Software Foundation, Inc. ;;;; -;;;; This file is part of GUILE. -;;;; -;;;; GUILE 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, or -;;;; (at your option) any later version. -;;;; -;;;; GUILE 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 GUILE; see the file COPYING. If not, write -;;;; to the Free Software Foundation, Inc., 59 Temple Place, Suite -;;;; 330, Boston, MA 02111-1307 USA +;;;; This file is part of GUILE. +;;;; +;;;; GUILE 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, or (at your +;;;; option) any later version. +;;;; +;;;; GUILE 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 GUILE; see the file COPYING. If not, write to the +;;;; Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; (define-module (ice-9 slib) :no-backtrace) diff --git a/ice-9/stack-catch.scm b/ice-9/stack-catch.scm index ff160f7b0..c5f37c199 100644 --- a/ice-9/stack-catch.scm +++ b/ice-9/stack-catch.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; (define-module (ice-9 stack-catch) diff --git a/ice-9/streams.scm b/ice-9/streams.scm index 008a05c91..9ef0706e6 100644 --- a/ice-9/streams.scm +++ b/ice-9/streams.scm @@ -17,6 +17,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;; the basic stream operations are inspired by ;; (i.e. ripped off) Scheme48's `stream' package, diff --git a/ice-9/string-fun.scm b/ice-9/string-fun.scm index 1973ef47b..f6ffaa1d9 100644 --- a/ice-9/string-fun.scm +++ b/ice-9/string-fun.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; (define-module (ice-9 string-fun)) diff --git a/ice-9/syncase.scm b/ice-9/syncase.scm index 0074285a6..f7aca4c43 100644 --- a/ice-9/syncase.scm +++ b/ice-9/syncase.scm @@ -14,6 +14,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; diff --git a/ice-9/tags.scm b/ice-9/tags.scm index edd0dc49a..e69de29bb 100644 --- a/ice-9/tags.scm +++ b/ice-9/tags.scm @@ -1,24 +0,0 @@ -;;; installed-scm-file - -;;;; Copyright (C) 1996 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 -;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA -;;;; - - - -(define-module (ice-9 tags)) - diff --git a/ice-9/threads.scm b/ice-9/threads.scm index 631f5d86e..6fc4511d0 100644 --- a/ice-9/threads.scm +++ b/ice-9/threads.scm @@ -15,6 +15,30 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA ;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. +;;;; ;;;; ---------------------------------------------------------------- ;;;; threads.scm -- User-level interface to Guile's thread system ;;;; 4 March 1996, Anthony Green diff --git a/ice-9/time.scm b/ice-9/time.scm index 658ffbe56..4b1859928 100644 --- a/ice-9/time.scm +++ b/ice-9/time.scm @@ -15,6 +15,30 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA ;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. +;;;; ;;; Commentary: From a0e0793ff782d05dad08a7f43f90013b6ddb9e0c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Jun 2001 23:31:14 +0000 Subject: [PATCH 1254/2047] Include "deprecation.h". --- libguile/dynl.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/dynl.c b/libguile/dynl.c index ca00e4e73..99de73cd4 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -73,7 +73,7 @@ maybe_drag_in_eprintf () #include "libguile/keywords.h" #include "libguile/ports.h" #include "libguile/strings.h" - +#include "libguile/deprecation.h" #include "libguile/validate.h" /* Create a new C argv array from a scheme list of strings. */ From c22adbeb3be76a64db645ed7620fb81351fa0818 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Jun 2001 23:32:27 +0000 Subject: [PATCH 1255/2047] Added exception notice to all files. --- libguile/gdb_interface.h | 24 ++++++++++++++++++++++++ libguile/mallocs.c | 26 +++++++++++++++++++++++++- libguile/putenv.c | 26 +++++++++++++++++++++++++- libguile/strerror.c | 26 +++++++++++++++++++++++++- libguile/strop.c | 26 +++++++++++++++++++++++++- oop/goops.scm | 24 ++++++++++++++++++++++++ oop/goops/active-slot.scm | 24 ++++++++++++++++++++++++ oop/goops/compile.scm | 24 ++++++++++++++++++++++++ oop/goops/composite-slot.scm | 24 ++++++++++++++++++++++++ oop/goops/describe.scm | 24 ++++++++++++++++++++++++ oop/goops/dispatch.scm | 24 ++++++++++++++++++++++++ oop/goops/internal.scm | 24 ++++++++++++++++++++++++ oop/goops/old-define-method.scm | 24 ++++++++++++++++++++++++ oop/goops/save.scm | 24 ++++++++++++++++++++++++ oop/goops/stklos.scm | 24 ++++++++++++++++++++++++ oop/goops/util.scm | 24 ++++++++++++++++++++++++ 16 files changed, 388 insertions(+), 4 deletions(-) diff --git a/libguile/gdb_interface.h b/libguile/gdb_interface.h index 9598c35bb..ec1bbe43d 100644 --- a/libguile/gdb_interface.h +++ b/libguile/gdb_interface.h @@ -17,6 +17,30 @@ You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +As a special exception, the Free Software Foundation gives permission +for additional uses of the text contained in its release of GUILE. + +The exception is that, if you link the GUILE library with other files +to produce an executable, this does not by itself cause the +resulting executable to be covered by the GNU General Public License. +Your use of that executable is in no way restricted on account of +linking the GUILE library code into it. + +This exception does not however invalidate any other reasons why +the executable file might be covered by the GNU General Public License. + +This exception applies only to the code released by the +Free Software Foundation under the name GUILE. If you copy +code from other Free Software Foundation releases into a copy of +GUILE, as the General Public License permits, the exception does +not apply to the code that you add in this way. To avoid misleading +anyone as to the status of such modified files, you must delete +this exception notice from them. + +If you write modifications of your own for GUILE, it is your choice +whether to permit this exception to apply to your modifications. +If you do not wish that, delete this exception notice. + The author can be reached at djurfeldt@nada.kth.se Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */ diff --git a/libguile/mallocs.c b/libguile/mallocs.c index 3ce7d2f90..0a6a1db61 100644 --- a/libguile/mallocs.c +++ b/libguile/mallocs.c @@ -14,7 +14,31 @@ * You should have received a copy of the GNU General Public License * along with this software; see the file COPYING. If not, write to * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA */ + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/putenv.c b/libguile/putenv.c index bc59233dd..bb7eb0bb1 100644 --- a/libguile/putenv.c +++ b/libguile/putenv.c @@ -13,7 +13,31 @@ You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 - USA */ + USA + + As a special exception, the Free Software Foundation gives permission + for additional uses of the text contained in its release of GUILE. + + The exception is that, if you link the GUILE library with other files + to produce an executable, this does not by itself cause the + resulting executable to be covered by the GNU General Public License. + Your use of that executable is in no way restricted on account of + linking the GUILE library code into it. + + This exception does not however invalidate any other reasons why + the executable file might be covered by the GNU General Public License. + + This exception applies only to the code released by the + Free Software Foundation under the name GUILE. If you copy + code from other Free Software Foundation releases into a copy of + GUILE, as the General Public License permits, the exception does + not apply to the code that you add in this way. To avoid misleading + anyone as to the status of such modified files, you must delete + this exception notice from them. + + If you write modifications of your own for GUILE, it is your choice + whether to permit this exception to apply to your modifications. + If you do not wish that, delete this exception notice. */ /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/strerror.c b/libguile/strerror.c index 8445f6ff1..44ffca628 100644 --- a/libguile/strerror.c +++ b/libguile/strerror.c @@ -16,7 +16,31 @@ GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Emacs; see the file COPYING. If not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ +Boston, MA 02111-1307, USA. + +As a special exception, the Free Software Foundation gives permission +for additional uses of the text contained in its release of GUILE. + +The exception is that, if you link the GUILE library with other files +to produce an executable, this does not by itself cause the +resulting executable to be covered by the GNU General Public License. +Your use of that executable is in no way restricted on account of +linking the GUILE library code into it. + +This exception does not however invalidate any other reasons why +the executable file might be covered by the GNU General Public License. + +This exception applies only to the code released by the +Free Software Foundation under the name GUILE. If you copy +code from other Free Software Foundation releases into a copy of +GUILE, as the General Public License permits, the exception does +not apply to the code that you add in this way. To avoid misleading +anyone as to the status of such modified files, you must delete +this exception notice from them. + +If you write modifications of your own for GUILE, it is your choice +whether to permit this exception to apply to your modifications. +If you do not wish that, delete this exception notice. */ /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/strop.c b/libguile/strop.c index d8336634f..a6c05d61c 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -15,7 +15,31 @@ GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this software; see the file COPYING. If not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA -02111-1307 USA */ +02111-1307 USA + +As a special exception, the Free Software Foundation gives permission +for additional uses of the text contained in its release of GUILE. + +The exception is that, if you link the GUILE library with other files +to produce an executable, this does not by itself cause the +resulting executable to be covered by the GNU General Public License. +Your use of that executable is in no way restricted on account of +linking the GUILE library code into it. + +This exception does not however invalidate any other reasons why +the executable file might be covered by the GNU General Public License. + +This exception applies only to the code released by the +Free Software Foundation under the name GUILE. If you copy +code from other Free Software Foundation releases into a copy of +GUILE, as the General Public License permits, the exception does +not apply to the code that you add in this way. To avoid misleading +anyone as to the status of such modified files, you must delete +this exception notice from them. + +If you write modifications of your own for GUILE, it is your choice +whether to permit this exception to apply to your modifications. +If you do not wish that, delete this exception notice. */ /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/oop/goops.scm b/oop/goops.scm index 85ecf028c..8445d20b1 100644 --- a/oop/goops.scm +++ b/oop/goops.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; diff --git a/oop/goops/active-slot.scm b/oop/goops/active-slot.scm index 46e6aa921..cdedd30aa 100644 --- a/oop/goops/active-slot.scm +++ b/oop/goops/active-slot.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; diff --git a/oop/goops/compile.scm b/oop/goops/compile.scm index 024c2a886..a538215ae 100644 --- a/oop/goops/compile.scm +++ b/oop/goops/compile.scm @@ -14,6 +14,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; diff --git a/oop/goops/composite-slot.scm b/oop/goops/composite-slot.scm index 32e8d9eaf..88147a571 100644 --- a/oop/goops/composite-slot.scm +++ b/oop/goops/composite-slot.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; diff --git a/oop/goops/describe.scm b/oop/goops/describe.scm index e268fb877..4dd218127 100644 --- a/oop/goops/describe.scm +++ b/oop/goops/describe.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; diff --git a/oop/goops/dispatch.scm b/oop/goops/dispatch.scm index ebd3623ea..d766b637a 100644 --- a/oop/goops/dispatch.scm +++ b/oop/goops/dispatch.scm @@ -14,6 +14,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; diff --git a/oop/goops/internal.scm b/oop/goops/internal.scm index 864fdacf2..aa315066b 100644 --- a/oop/goops/internal.scm +++ b/oop/goops/internal.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; diff --git a/oop/goops/old-define-method.scm b/oop/goops/old-define-method.scm index 915b5b25c..79165ae44 100644 --- a/oop/goops/old-define-method.scm +++ b/oop/goops/old-define-method.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; diff --git a/oop/goops/save.scm b/oop/goops/save.scm index 10d193055..7e937dca5 100644 --- a/oop/goops/save.scm +++ b/oop/goops/save.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; diff --git a/oop/goops/stklos.scm b/oop/goops/stklos.scm index be9594faa..4d84df444 100644 --- a/oop/goops/stklos.scm +++ b/oop/goops/stklos.scm @@ -14,6 +14,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; diff --git a/oop/goops/util.scm b/oop/goops/util.scm index b5ab894da..ebc557dff 100644 --- a/oop/goops/util.scm +++ b/oop/goops/util.scm @@ -14,6 +14,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;;; From f480396be50dbbfb5a930ec9254b1dc35f53f69f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Jun 2001 23:34:08 +0000 Subject: [PATCH 1256/2047] *** empty log message *** --- ice-9/ChangeLog | 10 ++++++++++ libguile/ChangeLog | 6 ++++++ srfi/ChangeLog | 4 ++++ srfi/srfi-10.scm | 24 ++++++++++++++++++++++++ srfi/srfi-11.scm | 24 ++++++++++++++++++++++++ srfi/srfi-13.scm | 24 ++++++++++++++++++++++++ srfi/srfi-14.scm | 24 ++++++++++++++++++++++++ srfi/srfi-16.scm | 24 ++++++++++++++++++++++++ srfi/srfi-17.scm | 24 ++++++++++++++++++++++++ srfi/srfi-19.scm | 24 ++++++++++++++++++++++++ srfi/srfi-2.scm | 24 ++++++++++++++++++++++++ srfi/srfi-6.scm | 24 ++++++++++++++++++++++++ srfi/srfi-8.scm | 24 ++++++++++++++++++++++++ srfi/srfi-9.scm | 24 ++++++++++++++++++++++++ 14 files changed, 284 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index b79bc526b..79aecc2f9 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,11 @@ +2001-06-04 Marius Vollmer + + Added exception notice to all files. + + * boot-9.scm (module-export!): Revert 2001-06-02 change. It + caused more problems than it solved by accidentally re-exporting + importing bindings once in a while. + 2001-06-03 Marius Vollmer * boot-9.scm (try-load-module): Bracket calls to try-module-linked @@ -9,6 +17,8 @@ try-using-sharlib-name, link-dynamic-module, try-module-linked, try-module-dynamic-link): Deprecated. Activate deprecation message. + (define-public): Define binding before exporting it. This is to + avoid accidentally re-exporting a imported binding. 2001-06-02 Marius Vollmer diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 5864d8a07..d1a3bca4d 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2001-06-04 Marius Vollmer + + Added exception notice to all files. + + * dynl.c: Include "deprecation.h". + 2001-06-03 Marius Vollmer * dynl.c (scm_register_module_xxx, scm_registered_modules, diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 3b77ca198..fd5096532 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,7 @@ +2001-06-04 Marius Vollmer + + Added exception notice to all files. + 2001-05-31 Martin Grabmueller * srfi-14.scm, srfi-13.scm: Use `load-extension' for loading the diff --git a/srfi/srfi-10.scm b/srfi/srfi-10.scm index 5aa8b04a8..f24ec0d94 100644 --- a/srfi/srfi-10.scm +++ b/srfi/srfi-10.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;; Commentary: diff --git a/srfi/srfi-11.scm b/srfi/srfi-11.scm index 032e5daf6..758ef282c 100644 --- a/srfi/srfi-11.scm +++ b/srfi/srfi-11.scm @@ -16,6 +16,30 @@ ;;; along with this software; see the file COPYING. If not, write to ;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;; Boston, MA 02111-1307 USA +;;; +;;; As a special exception, the Free Software Foundation gives permission +;;; for additional uses of the text contained in its release of GUILE. +;;; +;;; The exception is that, if you link the GUILE library with other files +;;; to produce an executable, this does not by itself cause the +;;; resulting executable to be covered by the GNU General Public License. +;;; Your use of that executable is in no way restricted on account of +;;; linking the GUILE library code into it. +;;; +;;; This exception does not however invalidate any other reasons why +;;; the executable file might be covered by the GNU General Public License. +;;; +;;; This exception applies only to the code released by the +;;; Free Software Foundation under the name GUILE. If you copy +;;; code from other Free Software Foundation releases into a copy of +;;; GUILE, as the General Public License permits, the exception does +;;; not apply to the code that you add in this way. To avoid misleading +;;; anyone as to the status of such modified files, you must delete +;;; this exception notice from them. +;;; +;;; If you write modifications of your own for GUILE, it is your choice +;;; whether to permit this exception to apply to your modifications. +;;; If you do not wish that, delete this exception notice. (define-module (srfi srfi-11) :use-module (ice-9 syncase)) diff --git a/srfi/srfi-13.scm b/srfi/srfi-13.scm index dc3821b7b..dba10c525 100644 --- a/srfi/srfi-13.scm +++ b/srfi/srfi-13.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. (define-module (srfi srfi-13)) diff --git a/srfi/srfi-14.scm b/srfi/srfi-14.scm index ae0e32a3b..c123c4dc6 100644 --- a/srfi/srfi-14.scm +++ b/srfi/srfi-14.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. (define-module (srfi srfi-14)) diff --git a/srfi/srfi-16.scm b/srfi/srfi-16.scm index 1746657cf..73fd22dc7 100644 --- a/srfi/srfi-16.scm +++ b/srfi/srfi-16.scm @@ -16,6 +16,30 @@ ;;; along with this software; see the file COPYING. If not, write to ;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;; Boston, MA 02111-1307 USA +;;; +;;; As a special exception, the Free Software Foundation gives permission +;;; for additional uses of the text contained in its release of GUILE. +;;; +;;; The exception is that, if you link the GUILE library with other files +;;; to produce an executable, this does not by itself cause the +;;; resulting executable to be covered by the GNU General Public License. +;;; Your use of that executable is in no way restricted on account of +;;; linking the GUILE library code into it. +;;; +;;; This exception does not however invalidate any other reasons why +;;; the executable file might be covered by the GNU General Public License. +;;; +;;; This exception applies only to the code released by the +;;; Free Software Foundation under the name GUILE. If you copy +;;; code from other Free Software Foundation releases into a copy of +;;; GUILE, as the General Public License permits, the exception does +;;; not apply to the code that you add in this way. To avoid misleading +;;; anyone as to the status of such modified files, you must delete +;;; this exception notice from them. +;;; +;;; If you write modifications of your own for GUILE, it is your choice +;;; whether to permit this exception to apply to your modifications. +;;; If you do not wish that, delete this exception notice. ;;; Commentary: diff --git a/srfi/srfi-17.scm b/srfi/srfi-17.scm index fda6fb9ae..27538a17d 100644 --- a/srfi/srfi-17.scm +++ b/srfi/srfi-17.scm @@ -17,6 +17,30 @@ ;;; along with this software; see the file COPYING. If not, write to ;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;; Boston, MA 02111-1307 USA +;;; +;;; As a special exception, the Free Software Foundation gives permission +;;; for additional uses of the text contained in its release of GUILE. +;;; +;;; The exception is that, if you link the GUILE library with other files +;;; to produce an executable, this does not by itself cause the +;;; resulting executable to be covered by the GNU General Public License. +;;; Your use of that executable is in no way restricted on account of +;;; linking the GUILE library code into it. +;;; +;;; This exception does not however invalidate any other reasons why +;;; the executable file might be covered by the GNU General Public License. +;;; +;;; This exception applies only to the code released by the +;;; Free Software Foundation under the name GUILE. If you copy +;;; code from other Free Software Foundation releases into a copy of +;;; GUILE, as the General Public License permits, the exception does +;;; not apply to the code that you add in this way. To avoid misleading +;;; anyone as to the status of such modified files, you must delete +;;; this exception notice from them. +;;; +;;; If you write modifications of your own for GUILE, it is your choice +;;; whether to permit this exception to apply to your modifications. +;;; If you do not wish that, delete this exception notice. ;;; Commentary: diff --git a/srfi/srfi-19.scm b/srfi/srfi-19.scm index da93c8ef1..4c577b225 100644 --- a/srfi/srfi-19.scm +++ b/srfi/srfi-19.scm @@ -17,6 +17,30 @@ ;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;; Boston, MA 02111-1307 USA ;;; +;;; As a special exception, the Free Software Foundation gives permission +;;; for additional uses of the text contained in its release of GUILE. +;;; +;;; The exception is that, if you link the GUILE library with other files +;;; to produce an executable, this does not by itself cause the +;;; resulting executable to be covered by the GNU General Public License. +;;; Your use of that executable is in no way restricted on account of +;;; linking the GUILE library code into it. +;;; +;;; This exception does not however invalidate any other reasons why +;;; the executable file might be covered by the GNU General Public License. +;;; +;;; This exception applies only to the code released by the +;;; Free Software Foundation under the name GUILE. If you copy +;;; code from other Free Software Foundation releases into a copy of +;;; GUILE, as the General Public License permits, the exception does +;;; not apply to the code that you add in this way. To avoid misleading +;;; anyone as to the status of such modified files, you must delete +;;; this exception notice from them. +;;; +;;; If you write modifications of your own for GUILE, it is your choice +;;; whether to permit this exception to apply to your modifications. +;;; If you do not wish that, delete this exception notice. +;;; ;;; Originally from SRFI reference implementation by Will Fitzgerald. ;;; Ported to Guile by Rob Browning diff --git a/srfi/srfi-2.scm b/srfi/srfi-2.scm index 4ffb49c6f..8c33f7a76 100644 --- a/srfi/srfi-2.scm +++ b/srfi/srfi-2.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. (define-module (srfi srfi-2) :use-module (ice-9 and-let-star)) diff --git a/srfi/srfi-6.scm b/srfi/srfi-6.scm index 41aeeb362..216e4875a 100644 --- a/srfi/srfi-6.scm +++ b/srfi/srfi-6.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. (define-module (srfi srfi-6)) diff --git a/srfi/srfi-8.scm b/srfi/srfi-8.scm index 5971d1696..6ed7fc185 100644 --- a/srfi/srfi-8.scm +++ b/srfi/srfi-8.scm @@ -16,6 +16,30 @@ ;;; along with this software; see the file COPYING. If not, write to ;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;; Boston, MA 02111-1307 USA +;;; +;;; As a special exception, the Free Software Foundation gives permission +;;; for additional uses of the text contained in its release of GUILE. +;;; +;;; The exception is that, if you link the GUILE library with other files +;;; to produce an executable, this does not by itself cause the +;;; resulting executable to be covered by the GNU General Public License. +;;; Your use of that executable is in no way restricted on account of +;;; linking the GUILE library code into it. +;;; +;;; This exception does not however invalidate any other reasons why +;;; the executable file might be covered by the GNU General Public License. +;;; +;;; This exception applies only to the code released by the +;;; Free Software Foundation under the name GUILE. If you copy +;;; code from other Free Software Foundation releases into a copy of +;;; GUILE, as the General Public License permits, the exception does +;;; not apply to the code that you add in this way. To avoid misleading +;;; anyone as to the status of such modified files, you must delete +;;; this exception notice from them. +;;; +;;; If you write modifications of your own for GUILE, it is your choice +;;; whether to permit this exception to apply to your modifications. +;;; If you do not wish that, delete this exception notice. (define-module (srfi srfi-8) :use-module (ice-9 receive)) diff --git a/srfi/srfi-9.scm b/srfi/srfi-9.scm index 0df0fee6d..7bf032721 100644 --- a/srfi/srfi-9.scm +++ b/srfi/srfi-9.scm @@ -16,6 +16,30 @@ ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. ;;; Commentary: From 99004a2863dda0c36a681889ea1b0b93d33fb1ec Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Mon, 4 Jun 2001 21:48:25 +0000 Subject: [PATCH 1257/2047] * rw.c (scm_write_string_partial): new procedure implementing write-string/partial in (ice-9 rw). * rw.h: declare scm_write_string_partial. --- libguile/rw.c | 124 ++++++++++++++++++++++++++++++++++++++++++++++---- libguile/rw.h | 6 ++- 2 files changed, 120 insertions(+), 10 deletions(-) diff --git a/libguile/rw.c b/libguile/rw.c index 28d4ea604..d41767ce8 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -79,9 +79,11 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0, (SCM str, SCM port_or_fdes, SCM start, SCM end), - "Read characters from an fport or file descriptor into a\n" - "string @var{str}. This procedure is scsh-compatible\n" - "and can efficiently read large strings. It will:\n\n" + "Read characters from a port or file descriptor into a\n" + "string @var{str}. A port must have an underlying file\n" + "descriptor --- a so-called fport. This procedure is\n" + "scsh-compatible and can efficiently read large strings.\n" + "It will:\n\n" "@itemize\n" "@item\n" "attempt to fill the entire string, unless the @var{start}\n" @@ -92,11 +94,16 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0, "use the current input port if @var{port_or_fdes} is not\n" "supplied.\n" "@item\n" - "read any characters that are currently available,\n" - "without waiting for the rest (short reads are possible).\n\n" + "return fewer than the requested number of characters in some\n" + "cases, e.g., on end of file, if interrupted by a signal, or if\n" + "not all the characters are immediately available.\n" "@item\n" - "wait for as long as it needs to for the first character to\n" - "become available, unless the port is in non-blocking mode\n" + "wait indefinitely for some input if no characters are\n" + "currently available,\n" + "unless the port is in non-blocking mode.\n" + "@item\n" + "read characters from the port's input buffers if available,\n" + "instead from the underlying file descriptor.\n" "@item\n" "return @code{#f} if end-of-file is encountered before reading\n" "any characters, otherwise return the number of characters\n" @@ -106,7 +113,7 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0, "are immediately available.\n" "@item\n" "return 0 if the request is for 0 bytes, with no\n" - "end-of-file check\n" + "end-of-file check.\n" "@end itemize") #define FUNC_NAME s_scm_read_string_x_partial { @@ -160,6 +167,107 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0, + (SCM str, SCM port_or_fdes, SCM start, SCM end), + "Write characters from a string @var{str} to a port or file\n" + "descriptor. A port must have an underlying file descriptor\n" + "--- a so-called fport. This procedure is\n" + "scsh-compatible and can efficiently write large strings.\n" + "It will:\n\n" + "@itemize\n" + "@item\n" + "attempt to write the entire string, unless the @var{start}\n" + "and/or @var{end} arguments are supplied. i.e., @var{start}\n" + "defaults to 0 and @var{end} defaults to\n" + "@code{(string-length str)}\n" + "@item\n" + "use the current output port if @var{port_of_fdes} is not\n" + "supplied.\n" + "@item\n" + "in the case of a buffered port, store the characters in the\n" + "port's output buffer, if all will fit. If they will not fit\n" + "then any existing buffered characters will be flushed\n" + "before attempting\n" + "to write the new characters directly to the underlying file\n" + "descriptor. If the port is in non-blocking mode and\n" + "buffered characters can not be flushed immediately, then an\n" + "@code{EAGAIN} system-error exception will be raised (Note:\n" + "scsh does not support the use of non-blocking buffered ports.)\n" + "@item\n" + "write fewer than the requested number of\n" + "characters in some cases, e.g., if interrupted by a signal or\n" + "if not all of the output can be accepted immediately.\n" + "@item\n" + "wait indefinitely for at least one character\n" + "from @var{str} to be accepted by the port, unless the port is\n" + "in non-blocking mode.\n" + "@item\n" + "return the number of characters accepted by the port.\n" + "@item\n" + "return 0 if the port is in non-blocking mode and can not accept\n" + "at least one character from @var{str} immediately\n" + "@item\n" + "return 0 immediately if the request size is 0 bytes.\n" + "@end itemize") +#define FUNC_NAME s_scm_write_string_partial +{ + char *src; + long write_len; + int fdes; + + { + long offset; + long last; + + SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, src, 3, start, offset, + 4, end, last); + src += offset; + write_len = last - offset; + } + + if (write_len == 0) + return SCM_INUM0; + + if (SCM_INUMP (port_or_fdes)) + fdes = SCM_INUM (port_or_fdes); + else + { + SCM port = SCM_UNBNDP (port_or_fdes) ? scm_cur_outp : port_or_fdes; + scm_port_t *pt; + off_t space; + + SCM_VALIDATE_OPFPORT (2, port); + SCM_VALIDATE_OUTPUT_PORT (2, port); + pt = SCM_PTAB_ENTRY (port); + /* filling the last character in the buffer would require a flush. */ + space = pt->write_end - pt->write_pos - 1; + if (space >= write_len) + { + memcpy (pt->write_pos, src, write_len); + pt->write_pos += write_len; + return scm_long2num (write_len); + } + if (pt->write_pos > pt->write_buf) + scm_flush (port); + fdes = SCM_FPORT_FDES (port); + } + { + long rv; + + SCM_SYSCALL (rv = write (fdes, src, write_len)); + if (rv == -1) + { + if (SCM_EBLOCK (errno)) + rv = 0; + else + SCM_SYSERROR; + } + + return scm_long2num (rv); + } +} +#undef FUNC_NAME + SCM scm_init_rw_builtins () { diff --git a/libguile/rw.h b/libguile/rw.h index c0bb4868e..678c7cfa5 100644 --- a/libguile/rw.h +++ b/libguile/rw.h @@ -13,8 +13,7 @@ * 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 + * * You should have received a copy of the GNU General Public License * along with this software; see the file COPYING. If not, write to * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, * Boston, MA 02111-1307 USA @@ -48,6 +47,9 @@ extern SCM scm_read_string_x_partial (SCM str, SCM port_or_fdes, SCM start, SCM end); +extern SCM scm_write_string_partial (SCM str, SCM port_or_fdes, SCM start, + SCM end); + SCM scm_init_rw_builtins (void); void scm_init_rw (void); From db387bb7b9c2e026060e5e34c676d280a7954993 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Mon, 4 Jun 2001 21:49:36 +0000 Subject: [PATCH 1258/2047] * rw.scm (ice-9): export write-string/partial. --- ice-9/rw.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ice-9/rw.scm b/ice-9/rw.scm index bcfeb9591..418eb08e3 100644 --- a/ice-9/rw.scm +++ b/ice-9/rw.scm @@ -47,6 +47,6 @@ ;;; (scsh rw). (define-module (ice-9 rw) - :export (read-string!/partial)) + :export (read-string!/partial write-string/partial)) (%init-rw-builtins) From 1fb9789efd4a777c57d6503559217063c3eb3b02 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Mon, 4 Jun 2001 21:51:01 +0000 Subject: [PATCH 1259/2047] * scheme-io.texi (Block Reading and Writing): added write-string/partial, updated read-string!/partial. --- doc/scheme-io.texi | 777 --------------------------------------------- 1 file changed, 777 deletions(-) diff --git a/doc/scheme-io.texi b/doc/scheme-io.texi index 4152207bf..e69de29bb 100644 --- a/doc/scheme-io.texi +++ b/doc/scheme-io.texi @@ -1,777 +0,0 @@ -@page -@node Input and Output -@chapter Input and Output - -@menu -* Ports:: The idea of the port abstraction. -* Reading:: Procedures for reading from a port. -* Writing:: Procedures for writing to a port. -* Closing:: Procedures to close a port. -* Random Access:: Moving around a random access port. -* Line/Delimited:: Read and write lines or delimited text. -* Block Reading and Writing:: Reading and writing blocks of text. -* Default Ports:: Defaults for input, output and errors. -* Port Types:: Types of port and how to make them. -@end menu - - -@node Ports -@section Ports - -[Concept of the port abstraction.] - -Sequential input/output in Scheme is represented by operations on a -@dfn{port}. Characters can be read from an input port and -written to an output port. This chapter explains the operations -that Guile provides for working with ports. - -The formal definition of a port is very generic: an input port is -simply ``an object which can deliver characters on command,'' and -an output port is ``an object which can accept characters.'' -Because this definition is so loose, it is easy to write functions -that simulate ports in software. @dfn{Soft ports} and @dfn{string -ports} are two interesting and powerful examples of this technique. - -@rnindex input-port? -@deffn primitive input-port? x -Return @code{#t} if @var{x} is an input port, otherwise return -@code{#f}. Any object satisfying this predicate also satisfies -@code{port?}. -@end deffn - -@rnindex output-port? -@deffn primitive output-port? x -Return @code{#t} if @var{x} is an output port, otherwise return -@code{#f}. Any object satisfying this predicate also satisfies -@code{port?}. -@end deffn - -@deffn primitive port? x -Return a boolean indicating whether @var{x} is a port. -Equivalent to @code{(or (input-port? @var{x}) (output-port? -@var{x}))}. -@end deffn - - -@node Reading -@section Reading - -[Generic procedures for reading from ports.] - -@rnindex eof-object? -@deffn primitive eof-object? x -Return @code{#t} if @var{x} is an end-of-file object; otherwise -return @code{#f}. -@end deffn - -@rnindex char-ready? -@deffn primitive char-ready? [port] -Return @code{#t} if a character is ready on input @var{port} -and return @code{#f} otherwise. If @code{char-ready?} returns -@code{#t} then the next @code{read-char} operation on -@var{port} is guaranteed not to hang. If @var{port} is a file -port at end of file then @code{char-ready?} returns @code{#t}. -@footnote{@code{char-ready?} exists to make it possible for a -program to accept characters from interactive ports without -getting stuck waiting for input. Any input editors associated -with such ports must make sure that characters whose existence -has been asserted by @code{char-ready?} cannot be rubbed out. -If @code{char-ready?} were to return @code{#f} at end of file, -a port at end of file would be indistinguishable from an -interactive port that has no ready characters.} -@end deffn - -@rnindex read-char? -@deffn primitive read-char [port] -Return the next character available from @var{port}, updating -@var{port} to point to the following character. If no more -characters are available, the end-of-file object is returned. -@end deffn - -@rnindex peek-char? -@deffn primitive peek-char [port] -Return the next character available from @var{port}, -@emph{without} updating @var{port} to point to the following -character. If no more characters are available, the -end-of-file object is returned.@footnote{The value returned by -a call to @code{peek-char} is the same as the value that would -have been returned by a call to @code{read-char} on the same -port. The only difference is that the very next call to -@code{read-char} or @code{peek-char} on that @var{port} will -return the value returned by the preceding call to -@code{peek-char}. In particular, a call to @code{peek-char} on -an interactive port will hang waiting for input whenever a call -to @code{read-char} would have hung.} -@end deffn - -@deffn primitive unread-char cobj port -Place @var{char} in @var{port} so that it will be read by the -next read operation. If called multiple times, the unread characters -will be read again in last-in first-out order. If @var{port} is -not supplied, the current input port is used. -@end deffn - -@deffn primitive unread-string str port -Place the string @var{str} in @var{port} so that its characters will be -read in subsequent read operations. If called multiple times, the -unread characters will be read again in last-in first-out order. If -@var{port} is not supplied, the current-input-port is used. -@end deffn - -@deffn primitive drain-input port -Drain @var{port}'s read buffers (including any pushed-back -characters) and return the content as a single string. -@end deffn - -@deffn primitive port-column port -@deffnx primitive 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 -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 -message, we recommend you add 1 to get 1-origin integers. This is -because lines and column numbers traditionally start with 1, and that is -what non-programmers will find most natural.) -@end deffn - -@deffn primitive set-port-column! port column -@deffnx primitive set-port-line! port line -Set the current column or line number of @var{port}, using the -current input port if none is specified. -@end deffn - -@node Writing -@section Writing - -[Generic procedures for writing to ports.] - -@deffn primitive get-print-state port -Return the print state of the port @var{port}. If @var{port} -has no associated print state, @code{#f} is returned. -@end deffn - -@rnindex newline -@deffn primitive newline [port] -Send a newline to @var{port}. -@end deffn - -@deffn primitive port-with-print-state port pstate -Create a new port which behaves like @var{port}, but with an -included print state @var{pstate}. -@end deffn - -@deffn primitive print-options-interface [setting] -Option interface for the print options. Instead of using -this procedure directly, use the procedures -@code{print-enable}, @code{print-disable}, @code{print-set!} -and @code{print-options}. -@end deffn - -@deffn primitive simple-format destination message . args -Write @var{message} to @var{destination}, defaulting to -the current output port. -@var{message} can contain @code{~A} (was @code{%s}) and -@code{~S} (was @code{%S}) escapes. When printed, -the escapes are replaced with corresponding members of -@var{ARGS}: -@code{~A} formats using @code{display} and @code{~S} formats -using @code{write}. -If @var{destination} is @code{#t}, then use the current output -port, if @var{destination} is @code{#f}, then return a string -containing the formatted text. Does not add a trailing newline. -@end deffn - -@rnindex write-char -@deffn primitive write-char chr [port] -Send character @var{chr} to @var{port}. -@end deffn - -@findex fflush -@deffn primitive force-output [port] -Flush the specified output port, or the current output port if @var{port} -is omitted. The current output buffer contents are passed to the -underlying port implementation (e.g., in the case of fports, the -data will be written to the file and the output buffer will be cleared.) -It has no effect on an unbuffered port. - -The return value is unspecified. -@end deffn - -@deffn primitive flush-all-ports -Equivalent to calling @code{force-output} on -all open output ports. The return value is unspecified. -@end deffn - - -@node Closing -@section Closing - -@deffn primitive close-port port -Close the specified port object. Return @code{#t} if it -successfully closes a port or @code{#f} if it was already -closed. An exception may be raised if an error occurs, for -example when flushing buffered output. See also @ref{Ports and -File Descriptors, close}, for a procedure which can close file -descriptors. -@end deffn - -@rnindex close-input-port -@deffn primitive close-input-port port -Close the specified input port object. The routine has no effect if -the file has already been closed. An exception may be raised if an -error occurs. The value returned is unspecified. - -See also @ref{Ports and File Descriptors, close}, for a procedure -which can close file descriptors. -@end deffn - -@rnindex close-output-port -@deffn primitive close-output-port port -Close the specified output port object. The routine has no effect if -the file has already been closed. An exception may be raised if an -error occurs. The value returned is unspecified. - -See also @ref{Ports and File Descriptors, close}, for a procedure -which can close file descriptors. -@end deffn - -@deffn primitive port-closed? port -Return @code{#t} if @var{port} is closed or @code{#f} if it is -open. -@end deffn - - -@node Random Access -@section Random Access - -@deffn primitive seek fd_port offset whence -Sets the current position of @var{fd/port} to the integer -@var{offset}, which is interpreted according to the value of -@var{whence}. - -One of the following variables should be supplied for -@var{whence}: -@defvar SEEK_SET -Seek from the beginning of the file. -@end defvar -@defvar SEEK_CUR -Seek from the current position. -@end defvar -@defvar SEEK_END -Seek from the end of the file. -@end defvar -If @var{fd/port} is a file descriptor, the underlying system -call is @code{lseek}. @var{port} may be a string port. - -The value returned is the new position in the file. This means -that the current position of a port can be obtained using: -@lisp -(seek port 0 SEEK_CUR) -@end lisp -@end deffn - -@deffn primitive ftell fd_port -Return an integer representing the current position of -@var{fd/port}, measured from the beginning. Equivalent to: - -@lisp -(seek port 0 SEEK_CUR) -@end lisp -@end deffn - -@findex truncate -@findex ftruncate -@deffn primitive truncate-file object [length] -Truncates the object referred to by @var{object} to at most -@var{length} bytes. @var{object} can be a string containing a -file name or an integer file descriptor or a port. -@var{length} may be omitted if @var{object} is not a file name, -in which case the truncation occurs at the current port. -position. The return value is unspecified. -@end deffn - -@node Line/Delimited -@section Line Oriented and Delimited Text - -The delimited-I/O module can be accessed with: - -@smalllisp -(use-modules (ice-9 rdelim)) -@end smalllisp - -It can be used to read or write lines of text, or read text delimited by -a specified set of characters. It's similar to the @code{(scsh rdelim)} -module from guile-scsh, but does not use multiple values or character -sets and has an extra procedure @code{write-line}. - -@c begin (scm-doc-string "rdelim.scm" "read-line") -@deffn procedure read-line [port] [handle-delim] -Return a line of text from @var{port} if specified, otherwise from the -value returned by @code{(current-input-port)}. Under Unix, a line of text -is terminated by the first end-of-line character or by end-of-file. - -If @var{handle-delim} is specified, it should be one of the following -symbols: -@table @code -@item trim -Discard the terminating delimiter. This is the default, but it will -be impossible to tell whether the read terminated with a delimiter or -end-of-file. -@item concat -Append the terminating delimiter (if any) to the returned string. -@item peek -Push the terminating delimiter (if any) back on to the port. -@item split -Return a pair containing the string read from the port and the -terminating delimiter or end-of-file object. -@end table -@end deffn - -@c begin (scm-doc-string "rdelim.scm" "read-line!") -@deffn procedure read-line! buf [port] -Read a line of text into the supplied string @var{buf} and return the -number of characters added to @var{buf}. If @var{buf} is filled, then -@code{#f} is returned. -Read from @var{port} if -specified, otherwise from the value returned by @code{(current-input-port)}. -@end deffn - -@c begin (scm-doc-string "rdelim.scm" "read-delimited") -@deffn procedure read-delimited delims [port] [handle-delim] -Read text until one of the characters in the string @var{delims} is found -or end-of-file is reached. Read from @var{port} if supplied, otherwise -from the value returned by @code{(current-input-port)}. -@var{handle-delim} takes the same values as described for @code{read-line}. -@end deffn - -@c begin (scm-doc-string "rdelim.scm" "read-delimited!") -@deffn procedure read-delimited! delims buf [port] [handle-delim] [start] [end] -Read text into the supplied string @var{buf} and return the number of -characters added to @var{buf} (subject to @var{handle-delim}, which takes -the same values specified for @code{read-line}. If @var{buf} is filled, -@code{#f} is returned for both the number of characters read and the -delimiter. Also terminates if one of the characters in the string -@var{delims} is found -or end-of-file is reached. Read from @var{port} if supplied, otherwise -from the value returned by @code{(current-input-port)}. -@end deffn - -@deffn primitive write-line obj [port] -Display @var{obj} and a newline character to @var{port}. If -@var{port} is not specified, @code{(current-output-port)} is -used. This function is equivalent to: -@lisp -(display obj [port]) -(newline [port]) -@end lisp -@end deffn - -Some of the abovementioned I/O functions rely on the following C -primitives. These will mainly be of interest to people hacking Guile -internals. - -@deffn primitive %read-delimited! delims str gobble [port [start [end]]] -Read characters from @var{port} into @var{str} until one of the -characters in the @var{delims} string is encountered. If -@var{gobble} is true, discard the delimiter character; -otherwise, leave it in the input stream for the next read. If -@var{port} is not specified, use the value of -@code{(current-input-port)}. If @var{start} or @var{end} are -specified, store data only into the substring of @var{str} -bounded by @var{start} and @var{end} (which default to the -beginning and end of the string, respectively). - - Return a pair consisting of the delimiter that terminated the -string and the number of characters read. If reading stopped -at the end of file, the delimiter returned is the -@var{eof-object}; if the string was filled without encountering -a delimiter, this value is @code{#f}. -@end deffn - -@deffn primitive %read-line [port] -Read a newline-terminated line from @var{port}, allocating storage as -necessary. The newline terminator (if any) is removed from the string, -and a pair consisting of the line and its delimiter is returned. The -delimiter may be either a newline or the @var{eof-object}; if -@code{%read-line} is called at the end of file, it returns the pair -@code{(# . #)}. -@end deffn - -@node Block Reading and Writing -@section Block reading and writing - -The Block-string-I/O module can be accessed with: - -@smalllisp -(use-modules (ice-9 rw)) -@end smalllisp - -It currently contains a single procedure which helps implement -the @code{(scsh rw)} module in guile-scsh. - -@deffn primitive read-string!/partial str [port_or_fdes] [start] [end] -Read characters from an fport or file descriptor into a -string @var{str}. This procedure is scsh-compatible -and can efficiently read large strings. It will: - -@itemize @bullet -@item -attempt to fill the entire string, unless the @var{start} -and/or @var{end} arguments are supplied. i.e., @var{start} -defaults to 0 and @var{end} defaults to -@code{(string-length str)} -@item -use the current input port if @var{port_or_fdes} is not -supplied. -@item -read any characters that are currently available, -without waiting for the rest (short reads are possible). - -@item -wait for as long as it needs to for the first character to -become available, unless the port is in non-blocking mode -@item -return @code{#f} if end-of-file is encountered before reading -any characters, otherwise return the number of characters -read. -@item -return 0 if the port is in non-blocking mode and no characters -are immediately available. -@item -return 0 if the request is for 0 bytes, with no -end-of-file check -@end itemize -@end deffn - - -@node Default Ports -@section Default Ports for Input, Output and Errors - -@rnindex current-input-port -@deffn primitive current-input-port -Return the current input port. This is the default port used -by many input procedures. Initially, @code{current-input-port} -returns the @dfn{standard input} in Unix and C terminology. -@end deffn - -@rnindex current-output-port -@deffn primitive current-output-port -Return the current output port. This is the default port used -by many output procedures. Initially, -@code{current-output-port} returns the @dfn{standard output} in -Unix and C terminology. -@end deffn - -@deffn primitive current-error-port -Return the port to which errors and warnings should be sent (the -@dfn{standard error} in Unix and C terminology). -@end deffn - -@deffn primitive set-current-input-port port -@deffnx primitive set-current-output-port port -@deffnx primitive set-current-error-port port -Change the ports returned by @code{current-input-port}, -@code{current-output-port} and @code{current-error-port}, respectively, -so that they use the supplied @var{port} for input or output. -@end deffn - -@deffn primitive set-current-output-port port -Set the current default output port to PORT. -@end deffn - -@deffn primitive set-current-error-port port -Set the current default error port to PORT. -@end deffn - - -@node Port Types -@section Types of Port - -[Types of port; how to make them.] - -@menu -* File Ports:: Ports on an operating system file. -* String Ports:: Ports on a Scheme string. -* Soft Ports:: Ports on arbitrary Scheme procedures. -* Void Ports:: Ports on nothing at all. -@end menu - - -@node File Ports -@subsection File Ports - -The following procedures are used to open file ports. -See also @ref{Ports and File Descriptors, open}, for an interface -to the Unix @code{open} system call. - -@deffn primitive open-file filename mode -Open the file whose name is @var{filename}, and return a port -representing that file. The attributes of the port are -determined by the @var{mode} string. The way in which this is -interpreted is similar to C stdio. The first character must be -one of the following: -@table @samp -@item r -Open an existing file for input. -@item w -Open a file for output, creating it if it doesn't already exist -or removing its contents if it does. -@item a -Open a file for output, creating it if it doesn't already -exist. All writes to the port will go to the end of the file. -The "append mode" can be turned off while the port is in use -@pxref{Ports and File Descriptors, fcntl} -@end table -The following additional characters can be appended: -@table @samp -@item + -Open the port for both input and output. E.g., @code{r+}: open -an existing file for both input and output. -@item 0 -Create an "unbuffered" port. In this case input and output -operations are passed directly to the underlying port -implementation without additional buffering. This is likely to -slow down I/O operations. The buffering mode can be changed -while a port is in use @pxref{Ports and File Descriptors, -setvbuf} -@item l -Add line-buffering to the port. The port output buffer will be -automatically flushed whenever a newline character is written. -@end table -In theory we could create read/write ports which were buffered -in one direction only. However this isn't included in the -current interfaces. If a file cannot be opened with the access -requested, @code{open-file} throws an exception. -@end deffn - -@rnindex open-input-file -@deffn procedure open-input-file filename -Open @var{filename} for input. Equivalent to -@smalllisp -(open-file @var{filename} "r") -@end smalllisp -@end deffn - -@rnindex open-output-file -@deffn procedure open-output-file filename -Open @var{filename} for output. Equivalent to -@smalllisp -(open-file @var{filename} "w") -@end smalllisp -@end deffn - -@rnindex call-with-input-file -@deffn procedure call-with-input-file file proc -@var{proc} should be a procedure of one argument, and @var{file} should -be a string naming a file. The file must already exist. These -procedures call @var{proc} with one argument: the port obtained by -opening the named file for input or output. If the file cannot be -opened, an error is signalled. If the procedure returns, then the port -is closed automatically and the value yielded by the procedure is -returned. If the procedure does not return, then the port will not be -closed automatically unless it is possible to prove that the port will -never again be used for a read or write operation. -@end deffn - -@rnindex call-with-output-file -@deffn procedure call-with-output-file file proc -@var{proc} should be a procedure of one argument, and @var{file} should -be a string naming a file. The behaviour is unspecified if the file -already exists. These procedures call @var{proc} with one argument: the -port obtained by opening the named file for input or output. If the -file cannot be opened, an error is signalled. If the procedure returns, -then the port is closed automatically and the value yielded by the -procedure is returned. If the procedure does not return, then the port -will not be closed automatically unless it is possible to prove that the -port will never again be used for a read or write operation. -@end deffn - -@rnindex with-input-from-file -@deffn procedure with-input-from-file file thunk -@var{thunk} must be a procedure of no arguments, and @var{file} must be -a string naming a file. The file must already exist. The file is opened -for input, an input port connected to it is made the default value -returned by @code{current-input-port}, and the @var{thunk} is called -with no arguments. When the @var{thunk} returns, the port is closed and -the previous default is restored. Returns the value yielded by -@var{thunk}. If an escape procedure is used to escape from the -continuation of these procedures, their behavior is implementation -dependent. -@end deffn - -@rnindex with-output-to-file -@deffn procedure with-output-to-file file thunk -@var{thunk} must be a procedure of no arguments, and @var{file} must be -a string naming a file. The effect is unspecified if the file already -exists. The file is opened for output, an output port connected to it -is made the default value returned by @code{current-output-port}, and -the @var{thunk} is called with no arguments. When the @var{thunk} -returns, the port is closed and the previous default is restored. -Returns the value yielded by @var{thunk}. If an escape procedure is -used to escape from the continuation of these procedures, their behavior -is implementation dependent. -@end deffn - -@deffn procedure with-error-to-file file thunk -@var{thunk} must be a procedure of no arguments, and @var{file} must be -a string naming a file. The effect is unspecified if the file already -exists. The file is opened for output, an output port connected to it -is made the default value returned by @code{current-error-port}, and the -@var{thunk} is called with no arguments. When the @var{thunk} returns, -the port is closed and the previous default is restored. Returns the -value yielded by @var{thunk}. If an escape procedure is used to escape -from the continuation of these procedures, their behavior is -implementation dependent. -@end deffn - -@deffn primitive port-mode port -Returns the port modes associated with the open port @var{port}. These -will not necessarily be identical to the modes used when the port was -opened, since modes such as "append" which are used only during -port creation are not retained. -@end deffn - -@deffn primitive port-filename port -Return the filename associated with @var{port}. This function returns -the strings "standard input", "standard output" and "standard error" -when called on the current input, output and error ports respectively. -@end deffn - -@deffn primitive set-port-filename! port filename -Change the filename associated with @var{port}, using the current input -port if none is specified. Note that this does not change the port's -source of data, but only the value that is returned by -@code{port-filename} and reported in diagnostic output. -@end deffn - -@deffn primitive file-port? obj -Determine whether @var{obj} is a port that is related to a file. -@end deffn - - -@node String Ports -@subsection String Ports - -The following allow string ports to be opened by analogy to R4R* -file port facilities: - -@deffn primitive call-with-output-string proc -Calls the one-argument procedure @var{proc} with a newly created output -port. When the function returns, the string composed of the characters -written into the port is returned. -@end deffn - -@deffn primitive call-with-input-string string proc -Calls the one-argument procedure @var{proc} with a newly -created input port from which @var{string}'s contents may be -read. The value yielded by the @var{proc} is returned. -@end deffn - -@deffn procedure with-output-to-string thunk -Calls the zero-argument procedure @var{thunk} with the current output -port set temporarily to a new string port. It returns a string -composed of the characters written to the current output. -@end deffn - -@deffn procedure with-input-from-string string thunk -Calls the zero-argument procedure @var{thunk} with the current input -port set temporarily to a string port opened on the specified -@var{string}. The value yielded by @var{thunk} is returned. -@end deffn - -@deffn primitive open-input-string str -Take a string and return an input port that delivers characters -from the string. The port can be closed by -@code{close-input-port}, though its storage will be reclaimed -by the garbage collector if it becomes inaccessible. -@end deffn - -@deffn primitive open-output-string -Return an output port that will accumulate characters for -retrieval by @code{get-output-string}. The port can be closed -by the procedure @code{close-output-port}, though its storage -will be reclaimed by the garbage collector if it becomes -inaccessible. -@end deffn - -@deffn primitive get-output-string port -Given an output port created by @code{open-output-string}, -return a string consisting of the characters that have been -output to the port so far. -@end deffn - -A string port can be used in many procedures which accept a port -but which are not dependent on implementation details of fports. -E.g., seeking and truncating will work on a string port, -but trying to extract the file descriptor number will fail. - - -@node Soft Ports -@subsection Soft Ports - -A @dfn{soft-port} is a port based on a vector of procedures capable of -accepting or delivering characters. It allows emulation of I/O ports. - -@deffn primitive make-soft-port pv modes -Return a port capable of receiving or delivering characters as -specified by the @var{modes} string (@pxref{File Ports, -open-file}). @var{pv} must be a vector of length 5. Its -components are as follows: - -@enumerate 0 -@item -procedure accepting one character for output -@item -procedure accepting a string for output -@item -thunk for flushing output -@item -thunk for getting one character -@item -thunk for closing port (not by garbage collection) -@end enumerate - -For an output-only port only elements 0, 1, 2, and 4 need be -procedures. For an input-only port only elements 3 and 4 need -be procedures. Thunks 2 and 4 can instead be @code{#f} if -there is no useful operation for them to perform. - -If thunk 3 returns @code{#f} or an @code{eof-object} -(@pxref{Input, eof-object?, ,r5rs, The Revised^5 Report on -Scheme}) it indicates that the port has reached end-of-file. -For example: - -@lisp -(define stdout (current-output-port)) -(define p (make-soft-port - (vector - (lambda (c) (write c stdout)) - (lambda (s) (display s stdout)) - (lambda () (display "." stdout)) - (lambda () (char-upcase (read-char))) - (lambda () (display "@@" stdout))) - "rw")) - -(write p p) @result{} # -@end lisp -@end deffn - - -@node Void Ports -@subsection Void Ports - -This kind of port causes any data to be discarded when written to, and -always returns the end-of-file object when read from. - -@deffn primitive %make-void-port mode -Create and return a new void port. A void port acts like -@code{/dev/null}. The @var{mode} argument specifies the input/output -modes for this port: see the documentation for @code{open-file} in -@ref{File Ports}. -@end deffn - - -@c Local Variables: -@c TeX-master: "guile.texi" -@c End: From 4bcdfe464138f064c70d1e15b357f76b99505f80 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Mon, 4 Jun 2001 21:52:21 +0000 Subject: [PATCH 1260/2047] *** empty log message *** --- NEWS | 14 +++++++++++--- doc/ChangeLog | 5 +++++ ice-9/ChangeLog | 4 ++++ libguile/ChangeLog | 6 ++++++ 4 files changed, 26 insertions(+), 3 deletions(-) diff --git a/NEWS b/NEWS index 86cfc9ac4..d7d863e9b 100644 --- a/NEWS +++ b/NEWS @@ -136,14 +136,22 @@ can be used for similar functionality. ** New module (ice-9 rw) This is a subset of the (scsh rw) module from guile-scsh. Currently -it defines a single procedure: +it defines two single procedures: *** New function: read-string!/partial str [port_or_fdes [start [end]]] - Read characters from an fport or file descriptor into a string - STR. This procedure is scsh-compatible and can efficiently read + Read characters from a port or file descriptor into a string STR. + A port must have an underlying file descriptor -- a so-called + fport. This procedure is scsh-compatible and can efficiently read large strings. +*** New function: write-string/partial str [port_or_fdes [start [end]]] + + Write characters from a string STR to a port or file descriptor. + A port must have an underlying file descriptor -- a so-called + fport. This procedure is mostly compatible and can efficiently + write large strings. + ** New module (ice-9 match) This module includes Andrew K. Wright's pattern matcher. See diff --git a/doc/ChangeLog b/doc/ChangeLog index 7c9b12855..366a64dac 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,8 @@ +2001-06-04 Gary Houston + + * scheme-io.texi (Block Reading and Writing): added + write-string/partial, updated read-string!/partial. + 2001-05-30 Martin Grabmueller * General: A lot of typo, texinfo markup and layout corrections. diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 79aecc2f9..2b508f2f9 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2001-06-04 Gary Houston + + * rw.scm: export write-string/partial. + 2001-06-04 Marius Vollmer Added exception notice to all files. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d1a3bca4d..6582f83be 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2001-06-04 Gary Houston + + * rw.c (scm_write_string_partial): new procedure implementing + write-string/partial in (ice-9 rw). + * rw.h: declare scm_write_string_partial. + 2001-06-04 Marius Vollmer Added exception notice to all files. From 0df9aac51b604e71d5fd8cad8a1b521a58a38dd6 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Mon, 4 Jun 2001 22:05:02 +0000 Subject: [PATCH 1261/2047] *** empty log message *** --- libguile/rw.h | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/rw.h b/libguile/rw.h index 678c7cfa5..c2089d423 100644 --- a/libguile/rw.h +++ b/libguile/rw.h @@ -13,7 +13,8 @@ * 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 + * + * You should have received a copy of the GNU General Public License * along with this software; see the file COPYING. If not, write to * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, * Boston, MA 02111-1307 USA From 9a7d04c37c04264348271773309a1415cfbcf2fd Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 4 Jun 2001 22:09:39 +0000 Subject: [PATCH 1262/2047] Added kluge at top that keeps `export' from re-exporting the `format' variable of the `(guile)' module. --- ice-9/format.scm | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ice-9/format.scm b/ice-9/format.scm index c54d57839..7d8c1ccb7 100644 --- a/ice-9/format.scm +++ b/ice-9/format.scm @@ -14,6 +14,11 @@ (define-module (ice-9 format) :autoload (ice-9 pretty-print) (pretty-print)) +(begin-deprecated + ;; So that `export' below will not accidentally re-export the + ;; `format' of the `(guile)' module. + (define format #f)) + (export format format:symbol-case-conv format:iobj-case-conv From 89d06712d9b277b000282c2e40573558013966c0 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 4 Jun 2001 22:14:16 +0000 Subject: [PATCH 1263/2047] (module-ensure-local-variable!): Renamed from `module-ensure-variable!'. Make sure that there really is a local variable, not just a visible one. (module-ensure-variable!): See above. (module-export!): Behave like always when deprecated features are enabled, but issue a warning when re-exporting a variable. When deprecated features are disabled, only export local variables, creating them uninitialized when they don't yet exist. (module-re-export!): New. Use this for re-exporting imported variables. (re-export): New, to go with `module-re-export!'. (named-module-use!, top-repl): Use resolve-interface instead of resolve-module to get at the used module. --- ice-9/boot-9.scm | 67 ++++++++++++++++++++++++++++++++++-------------- 1 file changed, 48 insertions(+), 19 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 000c4a4a0..02932d4f0 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1280,17 +1280,14 @@ (module-modified m) answer)))) -;; module-ensure-variable! module symbol +;; module-ensure-local-variable! module symbol ;; -;; ensure that there is a variable in MODULE for SYMBOL. If there is -;; no binding for SYMBOL, create a new undefined variable. Return -;; that variable. +;; Ensure that there is a local variable in MODULE for SYMBOL. If +;; there is no binding for SYMBOL, create a new uninitialized +;; variable. Return the local variable. ;; -;; (This is not a really clean thing to do, we should evetually get -;; rid of the need for `module-ensure-variable!') -;; -(define (module-ensure-variable! module symbol) - (or (module-variable module symbol) +(define (module-ensure-local-variable! module symbol) + (or (module-local-variable module symbol) (let ((var (make-undefined-variable))) (variable-set-name-hint! var symbol) (module-add! module symbol var) @@ -2780,13 +2777,38 @@ (eval-case ((load-toplevel) (export ,name))) (defmacro ,@args)))))) +;; Export a local variable +;; (define (module-export! m names) (let ((public-i (module-public-interface m))) (for-each (lambda (name) - ;; Make sure there is a local variable: - (module-define! m name (module-ref m name #f)) - ;; Make sure that local is exported: - (module-add! public-i name (module-variable m name))) + (begin-deprecated + (if (not (module-local-variable m name)) + (let ((v (module-variable m name))) + (cond + (v + (issue-deprecation-warning + "Using `export' to re-export imported bindings is deprecated. Use `re-export' instead.") + (issue-deprecation-warning + (simple-format #f "(You just re-exported `~a' from `~a'.)" + name (module-name m))) + (module-define! m name (variable-ref v))))))) + (let ((var (module-ensure-local-variable! m name))) + (module-add! public-i name var))) + names))) + +;; Re-export a imported variable +;; +(define (module-re-export! m names) + (let ((public-i (module-public-interface m))) + (for-each (lambda (name) + (let ((var (module-variable m name))) + (cond ((not var) + (error "Undefined variable:" name)) + ((eq? var (module-local-variable m name)) + (error "re-exporting local variable:" name)) + (else + (module-add! public-i name var))))) names))) (defmacro export names @@ -2796,6 +2818,13 @@ (else (error "export can only be used at the top level")))) +(defmacro re-export names + `(eval-case + ((load-toplevel) + (module-re-export! (current-module) ',names)) + (else + (error "re-export can only be used at the top level")))) + (define export-syntax export) @@ -2933,7 +2962,7 @@ ;;; {Load emacs interface support if emacs option is given.} (define (named-module-use! user usee) - (module-use! (resolve-module user) (resolve-module usee))) + (module-use! (resolve-module user) (resolve-interface usee))) (define (load-emacs-interface) (and (provided? 'debug-extensions) @@ -2959,17 +2988,17 @@ ;; Use some convenient modules (in reverse order) (if (provided? 'regex) - (module-use! guile-user-module (resolve-module '(ice-9 regex)))) + (module-use! guile-user-module (resolve-interface '(ice-9 regex)))) (if (provided? 'threads) - (module-use! guile-user-module (resolve-module '(ice-9 threads)))) + (module-use! guile-user-module (resolve-interface '(ice-9 threads)))) ;; load debugger on demand (module-use! guile-user-module (make-autoload-interface guile-user-module '(ice-9 debugger) '(debug))) - (module-use! guile-user-module (resolve-module '(ice-9 session))) - (module-use! guile-user-module (resolve-module '(ice-9 debug))) + (module-use! guile-user-module (resolve-interface '(ice-9 session))) + (module-use! guile-user-module (resolve-interface '(ice-9 debug))) ;; so that builtin bindings will be checked first - (module-use! guile-user-module (resolve-module '(guile))) + (module-use! guile-user-module (resolve-interface '(guile))) (set-current-module guile-user-module) From 0e9eeb6cc9dc1d0f8dccb93082604149a4e5777b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 4 Jun 2001 22:15:15 +0000 Subject: [PATCH 1264/2047] (scm_registered_modules, scm_clear_registered_modules): Do not emit deprecation warning. --- libguile/dynl.c | 6 ------ 1 file changed, 6 deletions(-) diff --git a/libguile/dynl.c b/libguile/dynl.c index 99de73cd4..b19ac070f 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -191,9 +191,6 @@ SCM_DEFINE (scm_registered_modules, "c-registered-modules", 0, 0, 0, SCM res; struct moddata *md; - scm_c_issue_deprecation_warning - ("`registered-modules' is deprecated. Use extensions instead."); - res = SCM_EOL; for (md = registered_mods; md; md = md->link) res = scm_cons (scm_cons (scm_makfrom0str (md->module_name), @@ -214,9 +211,6 @@ SCM_DEFINE (scm_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0, { struct moddata *md1, *md2; - scm_c_issue_deprecation_warning - ("`c-clear-registered-modules' is deprecated. Use extensions instead."); - SCM_DEFER_INTS; for (md1 = registered_mods; md1; md1 = md2) From bef38a17c4e75ef52dbb158c23844f09e7734b64 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 4 Jun 2001 22:16:27 +0000 Subject: [PATCH 1265/2047] (scm_c_register_extension): Allow NULL as library name. (load_extension): Ignore NULL library names when comparing. --- libguile/extensions.c | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/libguile/extensions.c b/libguile/extensions.c index 0a5346009..e5f19c806 100644 --- a/libguile/extensions.c +++ b/libguile/extensions.c @@ -59,13 +59,25 @@ typedef struct extension_t static extension_t *registered_extensions; +/* Register a LIB/INIT pair for use by `scm_load_extension'. LIB is + allowed to be NULL and then only INIT is used to identify the + registered entry. This is useful when you don't know the library + name (which isn't really relevant anyway in a completely linked + program) and you are sure that INIT is unique (which it must be for + static linking). Hmm, given this reasoning, what use is LIB + anyway? +*/ + void scm_c_register_extension (const char *lib, const char *init, void (*func) (void *), void *data) { extension_t *ext = scm_must_malloc (sizeof(extension_t), "scm_register_extension"); - ext->lib = scm_must_strdup (lib); + if (lib) + ext->lib = scm_must_strdup (lib); + else + ext->lib = NULL; ext->init = scm_must_strdup (init); ext->func = func; ext->data = data; @@ -82,7 +94,7 @@ load_extension (SCM lib, SCM init) extension_t *ext; for (ext = registered_extensions; ext; ext = ext->next) - if (!strcmp (ext->lib, SCM_STRING_CHARS (lib)) + if ((ext->lib == NULL || !strcmp (ext->lib, SCM_STRING_CHARS (lib))) && !strcmp (ext->init, SCM_STRING_CHARS (init))) { ext->func (ext->data); From f228362b1060c85b0d4187c12a97454bf0a4a3ff Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 4 Jun 2001 22:16:43 +0000 Subject: [PATCH 1266/2047] (scm_hasher): Use SCM_UNPACK in the case labels so that non-pointers are being compared. Thanks to Alexander Klimov! --- libguile/hash.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/libguile/hash.c b/libguile/hash.c index ae09a3862..9cb0d7411 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -98,17 +98,17 @@ scm_hasher(SCM obj, unsigned long n, size_t d) return (unsigned)(scm_downcase(SCM_CHAR(obj))) % n; switch (SCM_UNPACK (obj)) { #ifndef SICP - case SCM_EOL: + case SCM_UNPACK(SCM_EOL): d = 256; break; #endif - case SCM_BOOL_T: + case SCM_UNPACK(SCM_BOOL_T): d = 257; break; - case SCM_BOOL_F: + case SCM_UNPACK(SCM_BOOL_F): d = 258; break; - case SCM_EOF_VAL: + case SCM_UNPACK(SCM_EOF_VAL): d = 259; break; default: From 4a68d142ae7bce2f18517ae37a6d1f51849a6adb Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 4 Jun 2001 22:17:17 +0000 Subject: [PATCH 1267/2047] (keyword_print): Substract 1 from length of symbol name, accounting for the silly dash. --- libguile/keywords.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/keywords.c b/libguile/keywords.c index a3819c6e4..53f457c1a 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -62,8 +62,8 @@ static int keyword_print (SCM exp, SCM port, scm_print_state *pstate) { scm_puts ("#:", port); - scm_print_symbol_name (1 + SCM_SYMBOL_CHARS (SCM_CDR (exp)), - SCM_SYMBOL_LENGTH (SCM_CDR (exp)), + scm_print_symbol_name (SCM_SYMBOL_CHARS (SCM_CDR (exp)) + 1, + SCM_SYMBOL_LENGTH (SCM_CDR (exp)) - 1, port); return 1; } From 5a3ea5018402c102b8c03e71b38dcd6738c79057 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 4 Jun 2001 22:18:12 +0000 Subject: [PATCH 1268/2047] Use `re-export' instead of `export' when re-exporting `class-of'. --- oop/goops.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/oop/goops.scm b/oop/goops.scm index 8445d20b1..4f997da3f 100644 --- a/oop/goops.scm +++ b/oop/goops.scm @@ -96,7 +96,7 @@ (export instance? slot-ref-using-class slot-set-using-class! slot-bound-using-class? - slot-exists-using-class? slot-ref slot-set! slot-bound? class-of + slot-exists-using-class? slot-ref slot-set! slot-bound? class-name class-direct-supers class-direct-subclasses class-direct-methods class-direct-slots class-precedence-list class-slots class-environment @@ -106,6 +106,8 @@ method-procedure accessor-method-slot-definition slot-exists? make find-method get-keyword) +(re-export class-of) ;; from (guile) + (define min-fixnum (- (expt 2 29))) From feeedafb9cc5e12150814cd0432146ceb6e21c40 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 4 Jun 2001 22:18:59 +0000 Subject: [PATCH 1269/2047] *** empty log message *** --- ice-9/ChangeLog | 22 ++++++++++++++++++++++ libguile/ChangeLog | 15 +++++++++++++++ oop/ChangeLog | 5 +++++ 3 files changed, 42 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 2b508f2f9..d433095e2 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,25 @@ +2001-06-05 Marius Vollmer + + * boot-9.scm (module-ensure-local-variable!): Renamed from + `module-ensure-variable!'. Make sure that there really is a local + variable, not just a visible one. + (module-ensure-variable!): See above. + (module-export!): Behave like always when deprecated features are + enabled, but issue a warning when re-exporting a variable. When + deprecated features are disabled, only export local variables, + creating them uninitialized when they don't yet exist. + (module-re-export!): New. Use this for re-exporting imported + variables. + (re-export): New, to go with `module-re-export!'. + + * format.scm: Added kluge at top that keeps `export' from + re-exporting the `format' variable of the `(guile)' module. + +2001-06-04 Marius Vollmer + + * boot-9.scm (named-module-use!, top-repl): Use resolve-interface + instead of resolve-module to get at the used module. + 2001-06-04 Gary Houston * rw.scm: export write-string/partial. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6582f83be..892f631e9 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2001-06-05 Marius Vollmer + + * extensions.c (scm_c_register_extension): Allow NULL as library + name. + (load_extension): Ignore NULL library names when comparing. + + * hash.c (scm_hasher): Use SCM_UNPACK in the case labels so that + non-pointers are being compared. Thanks to Alexander Klimov! + 2001-06-04 Gary Houston * rw.c (scm_write_string_partial): new procedure implementing @@ -6,6 +15,12 @@ 2001-06-04 Marius Vollmer + * keywords.c (keyword_print): Substract 1 from length of symbol + name, accounting for the silly dash. + + * dynl.c (scm_registered_modules, scm_clear_registered_modules): + Do not emit deprecation warning. + Added exception notice to all files. * dynl.c: Include "deprecation.h". diff --git a/oop/ChangeLog b/oop/ChangeLog index f6eebba30..be51f2c64 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -1,3 +1,8 @@ +2001-06-05 Marius Vollmer + + * goops.scm: Use `re-export' instead of `export' when re-exporting + `class-of'. + 2001-05-19 Marius Vollmer * goops.scm: Call `%init-goops-builtins' instead of using the From 71c771efdfc2cc49f0bbc43fdc9947cbc09e81dc Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 5 Jun 2001 15:18:46 +0000 Subject: [PATCH 1270/2047] * Added Jost to THANKS and AUTHORS list. * Updated my personal authoring data. --- AUTHORS | 17 +++++++++++++++-- THANKS | 1 + 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/AUTHORS b/AUTHORS index 37302d610..1a1aa0c77 100644 --- a/AUTHORS +++ b/AUTHORS @@ -161,10 +161,23 @@ In the subdirectory example, wrote Will Fitzgerald: wrote initial srfi/srfi-19.scm. +Jost Boekemeier: +In the subdirectory libguile, wrote: + environments.c, environments.h + Dirk Herrmann: In the subdirectory doc, changes to: - data-rep.texi - scm.texi + data-rep.texi, scm.texi +In the subdirectory libguile, rewrote: + environments.c, environments.h +In the subdirectory libguile, changes to: + error.c, gc.c, gc.h, numbers.c, strings.c, symbols.c +In the subdirectory test-suite, rewrote: + lib.scm +In the subdirectory test-suite/tests, wrote: + bit-operations.test, common-list.test, environments.test, eval.test, + gc.test, list.test, numbers.test, symbols.test, syntax.test +Many other changes throughout. Greg Badros: In the subdirectory doc, changes to: diff --git a/THANKS b/THANKS index fac953512..f4eccdddb 100644 --- a/THANKS +++ b/THANKS @@ -7,6 +7,7 @@ The Guile maintainer committee consists of Contributors since the last release: + Jost Boekemeier Rob Browning Will Fitzgerald Martin Grabmueller From 8779d59588ffd0671729562a0195ae98b6017c50 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Tue, 5 Jun 2001 17:33:40 +0000 Subject: [PATCH 1271/2047] * box-dynamic-module: New directory, implements the box type in a shared library and places the definitions in a C-only module. Thanks to Thomas Wawrzinek for this, too! * box-dynamic/box.c, box/box.c, box-dynamic-module/box.c, box-module/box.c (mark_box): Fixed typo in comment. --- examples/ChangeLog | 10 ++ examples/Makefile.am | 3 +- examples/README | 18 ++- examples/box-dynamic-module/.cvsignore | 2 + examples/box-dynamic-module/Makefile.am | 31 +++++ examples/box-dynamic-module/README | 52 +++++++++ examples/box-dynamic-module/box.c | 147 ++++++++++++++++++++++++ examples/box-dynamic/box.c | 2 +- examples/box-module/box.c | 2 +- examples/box/box.c | 2 +- 10 files changed, 259 insertions(+), 10 deletions(-) create mode 100644 examples/box-dynamic-module/.cvsignore create mode 100644 examples/box-dynamic-module/Makefile.am create mode 100644 examples/box-dynamic-module/README create mode 100644 examples/box-dynamic-module/box.c diff --git a/examples/ChangeLog b/examples/ChangeLog index fac04cd1b..da7797723 100644 --- a/examples/ChangeLog +++ b/examples/ChangeLog @@ -1,3 +1,13 @@ +2001-06-05 Martin Grabmueller + + * box-dynamic-module: New directory, implements the box type in a + shared library and places the definitions in a C-only module. + + Thanks to Thomas Wawrzinek for this, too! + + * box-dynamic/box.c, box/box.c, box-dynamic-module/box.c, + box-module/box.c (mark_box): Fixed typo in comment. + 2001-06-01 Rob Browning * .cvsignore: here and in all subdirectories listing Makefile and diff --git a/examples/Makefile.am b/examples/Makefile.am index 1b5d3852a..504ba06ff 100644 --- a/examples/Makefile.am +++ b/examples/Makefile.am @@ -19,6 +19,7 @@ ## to the Free Software Foundation, Inc., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA -SUBDIRS = scripts box box-module box-dynamic modules safe +SUBDIRS = scripts box box-module box-dynamic box-dynamic-module\ + modules safe EXTRA_DIST = README diff --git a/examples/README b/examples/README index 0c2c7063a..2a362f2cd 100644 --- a/examples/README +++ b/examples/README @@ -5,9 +5,15 @@ programming. See the README files in the subdirectories for details. -scripts Examples for writing simple scripts in Guile Scheme. -box Example for extending Guile with a new data type. -box-module Similar to `box', but define new procedures in a named module. -box-dynamic Implements the box type in a dynamically loadable library. -modules Examples for writing and using Guile modules. -safe Examples for creating and using safe environments. +scripts Examples for writing simple scripts in Guile Scheme. +box Example for extending Guile with a new data type. +box-module Similar to `box', but defines new procedures in a + named module. +box-dynamic Implements the box type in a dynamically loadable + library. +box-dynamic-module Combination of `box-module' and `box-dynamic': + Implements the `box' type in a shared library and + defines the procedures in a Guile module. +modules Examples for writing and using Guile modules. +safe Examples for creating and using safe environments. + diff --git a/examples/box-dynamic-module/.cvsignore b/examples/box-dynamic-module/.cvsignore new file mode 100644 index 000000000..282522db0 --- /dev/null +++ b/examples/box-dynamic-module/.cvsignore @@ -0,0 +1,2 @@ +Makefile +Makefile.in diff --git a/examples/box-dynamic-module/Makefile.am b/examples/box-dynamic-module/Makefile.am new file mode 100644 index 000000000..16465c814 --- /dev/null +++ b/examples/box-dynamic-module/Makefile.am @@ -0,0 +1,31 @@ +## Process this file with Automake to create Makefile.in +## +## Copyright (C) 2001 Free Software Foundation, Inc. +## +## This file is part of GUILE. +## +## GUILE 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, or +## (at your option) any later version. +## +## GUILE 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 GUILE; see the file COPYING. If not, write +## to the Free Software Foundation, Inc., 59 Temple Place, Suite +## 330, Boston, MA 02111-1307 USA + +EXTRA_DIST = README box.c + +CFLAGS=`guile-config compile` +LIBS=`guile-config link` + +libbox-module: box.lo + sh ../../libtool --mode=link $(CC) $< $(LIBS) -rpath $(prefix)/lib -o libbox-module.la + +box.lo: box.c + sh ../../libtool --mode=compile $(CC) $(CFLAGS) -c $< \ No newline at end of file diff --git a/examples/box-dynamic-module/README b/examples/box-dynamic-module/README new file mode 100644 index 000000000..a3cb32496 --- /dev/null +++ b/examples/box-dynamic-module/README @@ -0,0 +1,52 @@ + -*- text -*- + +This directory includes an example program for extending Guile with a +new (and even useful) data type, putting it into a shared library, so it +can be called from an unmodified guile interpreter. Further, the shared +library defines a new guile module. + +To build the example, simply type + + make libbox-module + +in this directory. + +A box is simply an object for storing one other object in. It can be +used for passing parameters by reference, for example. You simply +store an object into a box, pass it to another procedure which can +store a new object into it and thus return a value via the box. + +Box objects are created with `make-box', set with `box-set!' and +examined with `box-ref'. Note that these procedures are placed in a +module called (box-module) and can thus only be accessed after using +this module. See the following example session for usage details: + +Extend your LD_LIBRARY_PATH variable (or equivalent) to include . and +.libs + +If you like this example so much that you want to have it available +for normal usage, install the dynamic libraries in the .libs directory +to the directory $(prefix)/lib + +Note that after loading the extension, an explicit call to use-modules +is needed to make the exported procedures available. + +$ guile +guile> (load-extension "libbox-module" "scm_init_box") +guile> make-box +: In expression make-box: +: Unbound variable: make-box +ABORT: (unbound-variable) + +Type "(backtrace)" to get more information or "(debug)" to enter the debugger. +guile> (use-modules (box-module)) +guile> (define b (make-box)) +guile> b +# +guile> (box-set! b '(list of values)) +guile> b +# +guile> (box-ref b) +(list of values) +guile> (quit) +$ diff --git a/examples/box-dynamic-module/box.c b/examples/box-dynamic-module/box.c new file mode 100644 index 000000000..166610248 --- /dev/null +++ b/examples/box-dynamic-module/box.c @@ -0,0 +1,147 @@ +/* examples/box-dynamic-module/box.c + * + * Copyright (C) 1998,2001 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 + * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + */ + +/* Include all needed declarations. */ +#include + + +/* The type code for the newly created smob type will be stored into + this variable. It has the prefix `scm_tc16_' to make it usable + with the SCM_VALIDATE_SMOB macro below. */ +static scm_bits_t scm_tc16_box; + + +/* This function is responsible for marking all SCM objects included + in the smob. */ +static SCM +mark_box (SCM b) +{ + /* Since we have only one SCM object to protect, we simply return it + and the caller will mark it. */ + return SCM_CELL_OBJECT_1 (b); +} + + +/* Print a textual represenation of the smob to a given port. */ +static int +print_box (SCM b, SCM port, scm_print_state *pstate) +{ + SCM value = SCM_CELL_OBJECT_1 (b); + + scm_puts ("#", port); + + /* Non-zero means success. */ + return 1; +} + + +/* This defines the primitve `make-box', which returns a new smob of + type `box', initialized to `#f'. */ +static SCM +#define FUNC_NAME "make-box" +make_box (void) +{ + /* This macro creates the new objects, stores the value `#f' into it + and returns it to the caller. */ + SCM_RETURN_NEWSMOB (scm_tc16_box, SCM_BOOL_F); +} +#undef FUNC_NAME + + +/* This is the primitive `box-ref' which returns the object stored in + the box. */ +static SCM +box_ref (SCM b) +#define FUNC_NAME "box-ref" +{ + /* First, we have to ensure that the user really gave us a box + objects. The macro SCM_VALIDATE_SMOB will do all what is needed. + The parameters are interpreted as follows: + + 1: The position of the checked variable in the parameter list. + b: The passed parameter. + box: Concatenated with the fixed prefix scm_tc16_, names the type + code for the expected smob type. */ + SCM_VALIDATE_SMOB (1, b, box); + + /* Fetch the object from the box and return it. */ + return SCM_CELL_OBJECT_1 (b); +} +#undef FUNC_NAME + + +/* Primitive which stores an arbitrary value into a box. */ +static SCM +box_set_x (SCM b, SCM value) +#define FUNC_NAME "box-set!" +{ + SCM_VALIDATE_SMOB (1, b, box); + + /* Set the cell number 1 of the smob to the given value. */ + SCM_SET_CELL_OBJECT_1 (b, value); + + /* When this constant is returned, the REPL will not print the + returned value. All procedures in Guile which are documented as + returning `and unspecified value' actually return this value. */ + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +/* Create and initialize the new smob type, and register the + primitives withe the interpreter library. + + This function must be declared a bit different from the example in + the ../box directory, because it will be called by + `scm_c_define_module', called from below. */ +static void +init_box_type (void * unused) +{ + scm_tc16_box = scm_make_smob_type ("box", 0); + scm_set_smob_mark (scm_tc16_box, mark_box); + scm_set_smob_print (scm_tc16_box, print_box); + + scm_c_define_gsubr ("make-box", 0, 0, 0, make_box); + scm_c_define_gsubr ("box-set!", 2, 0, 0, box_set_x); + scm_c_define_gsubr ("box-ref", 1, 0, 0, box_ref); + + /* This is new too: Since the procedures are now in a module, we + have to explicitly export them before they can be used. */ + scm_c_export ("make-box", "box-set!", "box-ref", NULL); +} + +/* This is the function which must be given to `load-extension' as the + second argument. It will initialize the shared, library, but will + place the definitions in a module called (box-module), so that an + additional (use-modules (box-module)) is needed to make them + accessible. */ +void +scm_init_box () +{ + /* Unlike the example in ../box, init_box_type is not called + directly, but by scm_c_define_module, which will create a module + named (box-module) and make this module current while called + init_box_type, thus placing the definitions into that module. */ + scm_c_define_module ("box-module", init_box_type, NULL); +} + +/* End of file. */ diff --git a/examples/box-dynamic/box.c b/examples/box-dynamic/box.c index 6c6151cee..8872a6163 100644 --- a/examples/box-dynamic/box.c +++ b/examples/box-dynamic/box.c @@ -34,7 +34,7 @@ static SCM mark_box (SCM b) { /* Since we have only one SCM object to protect, we simply return it - and the caller with mark it. */ + and the caller will mark it. */ return SCM_CELL_OBJECT_1 (b); } diff --git a/examples/box-module/box.c b/examples/box-module/box.c index 2065466fc..cf6542593 100644 --- a/examples/box-module/box.c +++ b/examples/box-module/box.c @@ -34,7 +34,7 @@ static SCM mark_box (SCM b) { /* Since we have only one SCM object to protect, we simply return it - and the caller with mark it. */ + and the caller will mark it. */ return SCM_CELL_OBJECT_1 (b); } diff --git a/examples/box/box.c b/examples/box/box.c index a928c0ef3..6c972b86b 100644 --- a/examples/box/box.c +++ b/examples/box/box.c @@ -34,7 +34,7 @@ static SCM mark_box (SCM b) { /* Since we have only one SCM object to protect, we simply return it - and the caller with mark it. */ + and the caller will mark it. */ return SCM_CELL_OBJECT_1 (b); } From e01970a51d505106f81806d2ad5ca7685808d8f7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Tue, 5 Jun 2001 17:35:42 +0000 Subject: [PATCH 1272/2047] * configure.in: Generate examples/box-dynamic-module/Makefile. --- ChangeLog | 4 ++++ configure.in | 1 + 2 files changed, 5 insertions(+) diff --git a/ChangeLog b/ChangeLog index 5324f549e..d7dcb09fc 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2001-06-05 Martin Grabmueller + + * configure.in: Generate examples/box-dynamic-module/Makefile. + 2001-06-03 Marius Vollmer * configure.in (AC_CONFIG_FILES, AC_CONFIG_COMMANDS): Add diff --git a/configure.in b/configure.in index 678202bb3..a28d07df2 100644 --- a/configure.in +++ b/configure.in @@ -623,6 +623,7 @@ AC_CONFIG_FILES([ examples/box/Makefile examples/box-module/Makefile examples/box-dynamic/Makefile + examples/box-dynamic-module/Makefile examples/modules/Makefile examples/safe/Makefile check-guile From 97b4221044e15d1af16c0ad926c7b01605d85b8a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Tue, 5 Jun 2001 17:43:16 +0000 Subject: [PATCH 1273/2047] Added authorship information. --- AUTHORS | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/AUTHORS b/AUTHORS index 1a1aa0c77..db912e6f3 100644 --- a/AUTHORS +++ b/AUTHORS @@ -131,6 +131,12 @@ Rob Browning: ported srfi/srfi-19.scm to Guile. Martin Grabmueller: +In the subdirectory libguile, changes to: + backtrace.c eval.c strorder.c script.c + strop.c strop.h struct.c macros.c + numbers.c posix.h posix.c symbols.c + gh_data.c strports.h strports.c validate.h + and changed many docstrings throughout. In the subdirectory srfi, wrote: srfi-9.scm srfi-10.scm @@ -156,7 +162,8 @@ In the subdirectory doc, changes to: In the subdirectory example, wrote scripts modules safe box box-module box-dynamic - +In the subdirectory test-suite/tests, wrote: + srfi-9.test srfi-10.test srfi-13.test Will Fitzgerald: wrote initial srfi/srfi-19.scm. From 17fa3fcf36f0869e1d165ddb3d05ed233be6cdff Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 5 Jun 2001 20:48:28 +0000 Subject: [PATCH 1274/2047] * Introduce macro SCM_VALIDATE_NON_EMPTY_COMBINATION. --- libguile/ChangeLog | 7 +++++++ libguile/eval.c | 12 ++++++++++-- 2 files changed, 17 insertions(+), 2 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 892f631e9..a4cc49e64 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2001-06-05 Dirk Herrmann + + * eval.c (SCM_VALIDATE_NON_EMPTY_COMBINATION): New macro. + + (SCM_CEVAL, SCM_APPLY): Replace calls to SCM_EVALIM2 with calls + to SCM_VALIDATE_NON_EMPTY_COMBINATION. + 2001-06-05 Marius Vollmer * extensions.c (scm_c_register_extension): Allow NULL as library diff --git a/libguile/eval.c b/libguile/eval.c index df458d50a..ee577c1e1 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -106,6 +106,14 @@ char *alloca (); +#define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \ + do { \ + if (SCM_EQ_P ((x), SCM_EOL)) \ + scm_misc_error (NULL, scm_s_expression, SCM_EOL); \ + } while (0) + + + /* The evaluator contains a plethora of EVAL symbols. * This is an attempt at explanation. * @@ -1979,7 +1987,7 @@ dispatch: goto nontoplevel_begin; } else - SCM_EVALIM2 (SCM_CAR (x)); + SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (x)); } else SCM_CEVAL (SCM_CAR (x), env); @@ -3515,7 +3523,7 @@ tail: goto again; } else - SCM_EVALIM2 (SCM_CAR (proc)); + SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc)); } else SCM_CEVAL (SCM_CAR (proc), args); From d36350e84173a38a5b6fc946c995d77fe8183c6b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 6 Jun 2001 20:14:51 +0000 Subject: [PATCH 1275/2047] * box-dynamic-module/box-module.scm: New file. --- examples/ChangeLog | 4 ++++ examples/box-dynamic-module/Makefile.am | 2 +- examples/box-dynamic-module/README | 16 ++++------------ examples/box-dynamic-module/box.c | 3 ++- 4 files changed, 11 insertions(+), 14 deletions(-) diff --git a/examples/ChangeLog b/examples/ChangeLog index da7797723..fda148a24 100644 --- a/examples/ChangeLog +++ b/examples/ChangeLog @@ -1,3 +1,7 @@ +2001-06-06 Martin Grabmueller + + * box-dynamic-module/box-module.scm: New file. + 2001-06-05 Martin Grabmueller * box-dynamic-module: New directory, implements the box type in a diff --git a/examples/box-dynamic-module/Makefile.am b/examples/box-dynamic-module/Makefile.am index 16465c814..ca157f2bc 100644 --- a/examples/box-dynamic-module/Makefile.am +++ b/examples/box-dynamic-module/Makefile.am @@ -19,7 +19,7 @@ ## to the Free Software Foundation, Inc., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA -EXTRA_DIST = README box.c +EXTRA_DIST = README box.c box-module.scm CFLAGS=`guile-config compile` LIBS=`guile-config link` diff --git a/examples/box-dynamic-module/README b/examples/box-dynamic-module/README index a3cb32496..6e4636fa3 100644 --- a/examples/box-dynamic-module/README +++ b/examples/box-dynamic-module/README @@ -22,23 +22,15 @@ module called (box-module) and can thus only be accessed after using this module. See the following example session for usage details: Extend your LD_LIBRARY_PATH variable (or equivalent) to include . and -.libs +.libs and make sure that your current working directory is the one +this file is contained in. If you like this example so much that you want to have it available for normal usage, install the dynamic libraries in the .libs directory -to the directory $(prefix)/lib - -Note that after loading the extension, an explicit call to use-modules -is needed to make the exported procedures available. +to the directory $(prefix)/lib and the scheme file `box-module.scm' in +a directory in your GUILE_LOAD_PATH. $ guile -guile> (load-extension "libbox-module" "scm_init_box") -guile> make-box -: In expression make-box: -: Unbound variable: make-box -ABORT: (unbound-variable) - -Type "(backtrace)" to get more information or "(debug)" to enter the debugger. guile> (use-modules (box-module)) guile> (define b (make-box)) guile> b diff --git a/examples/box-dynamic-module/box.c b/examples/box-dynamic-module/box.c index 166610248..fa9eaff41 100644 --- a/examples/box-dynamic-module/box.c +++ b/examples/box-dynamic-module/box.c @@ -133,7 +133,8 @@ init_box_type (void * unused) second argument. It will initialize the shared, library, but will place the definitions in a module called (box-module), so that an additional (use-modules (box-module)) is needed to make them - accessible. */ + accessible. In this example, the Scheme file box-module.scm is + responsible for doing the load-extension call. */ void scm_init_box () { From e9680547d3e7c8aaf4992b1006b1810008cc42d8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 7 Jun 2001 04:27:37 +0000 Subject: [PATCH 1276/2047] * README: Update. * srfi-1.scm: New file. --- srfi/ChangeLog | 6 + srfi/Makefile.am | 3 +- srfi/README | 7 +- srfi/srfi-1.scm | 976 +++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 990 insertions(+), 2 deletions(-) create mode 100644 srfi/srfi-1.scm diff --git a/srfi/ChangeLog b/srfi/ChangeLog index fd5096532..8d03b3060 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,9 @@ +2001-06-06 Martin Grabmueller + + * README: Update. + + * srfi-1.scm: New file. + 2001-06-04 Marius Vollmer Added exception notice to all files. diff --git a/srfi/Makefile.am b/srfi/Makefile.am index c454b1913..188688cd5 100644 --- a/srfi/Makefile.am +++ b/srfi/Makefile.am @@ -37,7 +37,8 @@ libguile_srfi_srfi_13_14_la_SOURCES = srfi-13.x srfi-13.c srfi-14.x srfi-14.c\ libguile_srfi_srfi_13_14_la_LDFLAGS = -version-info 0:0 -export-dynamic srfidir = $(datadir)/guile/$(VERSION)/srfi -srfi_DATA = srfi-2.scm \ +srfi_DATA = srfi-1.scm \ + srfi-2.scm \ srfi-6.scm \ srfi-8.scm \ srfi-9.scm \ diff --git a/srfi/README b/srfi/README index bfe1af158..a96a822e5 100644 --- a/srfi/README +++ b/srfi/README @@ -5,12 +5,17 @@ stand for, please refer to the SRFI homepage at http://srfi.schemers.org -The following SRFIs are supported (as of 2001-05-22 -- 'martin): +The following SRFIs are supported (as of 2001-06-06 -- 'martin): SRFI-0: cond-expand Supported by default, no module needs to get used. +SRFI-1: List Library + + A full toolbox of list processing procedures. (use-modules (srfi + srfi-1)) will make them available for use. + SRFI-2: and-let* (use-modules (srfi srfi-2)) to make and-let* available. diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm new file mode 100644 index 000000000..a5315511f --- /dev/null +++ b/srfi/srfi-1.scm @@ -0,0 +1,976 @@ +;;;; srfi-1.scm --- SRFI-1 procedures for Guile +;;;; +;;;; Copyright (C) 2001 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. + +;;; Author: Martin Grabmueller +;;; Date: 2001-06-06 + +;;; Commentary: + +;;; This is an implementation of SRFI-1 (List Library) +;;; +;;; All procedures defined in SRFI-1, which are not already defined in +;;; the Guile core library, are exported. The procedures in this +;;; implementation work, but they have not been tuned for speed or +;;; memory usage. +;;; + +;;; Code: + +(define-module (srfi srfi-1) + :use-module (ice-9 receive)) + +(export +;;; Constructors + ;; cons <= in the core + ;; list <= in the core + xcons + ;; cons* <= in the core + ;; make-list <= in the core + list-tabulate + ;; list-copy <= in the core + circular-list + iota + +;;; Predicates + proper-list? + circular-list? + dotted-list? + ;; pair? <= in the core + ;; null? <= in the core + null-list? + not-pair? + list= + +;;; Selectors + ;; car <= in the core + ;; cdr <= in the core + ;; caar <= in the core + ;; cadr <= in the core + ;; cdar <= in the core + ;; cddr <= in the core + ;; caaar <= in the core + ;; caadr <= in the core + ;; cadar <= in the core + ;; caddr <= in the core + ;; cdaar <= in the core + ;; cdadr <= in the core + ;; cddar <= in the core + ;; cdddr <= in the core + ;; caaaar <= in the core + ;; caaadr <= in the core + ;; caadar <= in the core + ;; caaddr <= in the core + ;; cadaar <= in the core + ;; cadadr <= in the core + ;; caddar <= in the core + ;; cadddr <= in the core + ;; cdaaar <= in the core + ;; cdaadr <= in the core + ;; cdadar <= in the core + ;; cdaddr <= in the core + ;; cddaar <= in the core + ;; cddadr <= in the core + ;; cdddar <= in the core + ;; cddddr <= in the core + ;; list-ref <= in the core + first + second + third + fourth + fifth + sixth + seventh + eighth + ninth + tenth + car+cdr + take + drop + take-right + drop-right + take! + drop-right! + split-at + split-at! + last + ;; last-pair <= in the core + +;;; Miscelleneous: length, append, concatenate, reverse, zip & count + ;; length <= in the core + length+ + ;; append <= in the core + ;; append! <= in the core + concatenate + concatenate! + ;; reverse <= in the core + ;; reverse! <= in the core + append-reverse + append-reverse! + zip + unzip1 + unzip2 + unzip3 + unzip4 + unzip5 + count + +;;; Fold, unfold & map + fold + fold-right + pair-fold + pair-fold-right + reduce + reduce-right + unfold + unfold-right + ;; map <= in the core + ;; for-each <= in the core + append-map + append-map! + map! + ;; map-in-order <= in the core + pair-for-each + filter-map + +;;; Filtering & partitioning + filter + partition + remove + filter! + partition! + remove! + +;;; Searching + find + find-tail + take-while + take-while! + drop-while + span + span! + break + break! + any + every + list-index + member ; Extended. + ;; memq <= in the core + ;; memv <= in the core + +;;; Deletion + delete ; Extended. + delete! + delete-duplicates + delete-duplicates! + +;;; Association lists + assoc ; Extended. + ;; assq <= in the core + ;; assv <= in the core + alist-cons + alist-copy + alist-delete + alist-delete! + +;;; Set operations on lists + lset<= + lset= + lset-adjoin + lset-union + lset-intersection + lset-difference + lset-xor + lset-diff+intersection + lset-union! + lset-intersection! + lset-difference! + lset-xor! + lset-diff+intersection! + +;;; Primitive side-effects + ;; set-car! <= in the core + ;; set-cdr! <= in the core + ) + +(cond-expand-provide (current-module) '(srfi-1)) + +;;; Constructors + +(define (xcons d a) + (cons a d)) + +(define (list-tabulate n init-proc) + (let lp ((n n) (acc '())) + (if (zero? n) + acc + (lp (- n 1) (cons (init-proc (- n 1)) acc))))) + +(define (circular-list elt1 . rest) + (let ((start (cons elt1 '()))) + (let lp ((r rest) (p start)) + (if (null? r) + (begin + (set-cdr! p start) + start) + (begin + (set-cdr! p (cons (car r) '())) + (lp (cdr r) (cdr p))))))) + +(define (iota count . rest) + (let ((start (if (pair? rest) (car rest) 0)) + (step (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) 1))) + (let lp ((n 0) (acc '())) + (if (= n count) + (reverse! acc) + (lp (+ n 1) (cons (+ start (* n step)) acc)))))) + +;;; Predicates + +(define (proper-list? x) + (list? x)) + +(define (circular-list? x) + (if (not-pair? x) + #f + (let lp ((hare (cdr x)) (tortoise x)) + (if (not-pair? hare) + #f + (let ((hare (cdr hare))) + (if (not-pair? hare) + #f + (if (eq? hare tortoise) + #t + (lp (cdr hare) (cdr tortoise))))))))) + +(define (dotted-list? x) + (cond + ((null? x) #f) + ((not-pair? x) #t) + (else + (let lp ((hare (cdr x)) (tortoise x)) + (cond + ((null? hare) #f) + ((not-pair? hare) #t) + (else + (let ((hare (cdr hare))) + (cond + ((null? hare) #f) + ((not-pair? hare) #t) + ((eq? hare tortoise) #f) + (else + (lp (cdr hare) (cdr tortoise))))))))))) + +(define (null-list? x) + (cond + ((proper-list? x) + (null? x)) + ((circular-list? x) + #f) + (else + (error "not a proper list in null-list?")))) + +(define (not-pair? x) + (not (pair? x))) + +(define (list= elt= . rest) + (define (lists-equal a b) + (let lp ((a a) (b b)) + (cond ((null? a) + (null? b)) + ((null? b) + #f) + (else + (and (elt= (car a) (car b)) + (lp (cdr a) (cdr b))))))) + (or (null? rest) + (let ((first (car rest))) + (let lp ((lists rest)) + (or (null? lists) + (and (lists-equal first (car lists)) + (lp (cdr lists)))))))) + +;;; Selectors + +(define first car) +(define second cadr) +(define third caddr) +(define fourth cadddr) +(define (fifth x) (car (cddddr x))) +(define (sixth x) (cadr (cddddr x))) +(define (seventh x) (caddr (cddddr x))) +(define (eighth x) (cadddr (cddddr x))) +(define (ninth x) (car (cddddr (cddddr x)))) +(define (tenth x) (cadr (cddddr (cddddr x)))) + +(define (car+cdr x) (values (car x) (cdr x))) + +(define (take x i) + (let lp ((n i) (l x) (acc '())) + (if (zero? n) + (reverse! acc) + (lp (- n 1) (cdr l) (cons (car l) acc))))) +(define (drop x i) + (let lp ((n i) (l x)) + (if (zero? n) + l + (lp (- n 1) (cdr l))))) +(define (take-right flist i) + (let lp ((n i) (l flist)) + (if (zero? n) + (let lp0 ((s flist) (l l)) + (if (null? l) + s + (lp0 (cdr s) (cdr l)))) + (lp (- n 1) (cdr l))))) + +(define (drop-right flist i) + (let lp ((n i) (l flist)) + (if (zero? n) + (let lp0 ((s flist) (l l) (acc '())) + (if (null? l) + (reverse! acc) + (lp0 (cdr s) (cdr l) (cons (car s) acc)))) + (lp (- n 1) (cdr l))))) + +(define (take! x i) + (if (zero? i) + '() + (let lp ((n (- i 1)) (l x)) + (if (zero? n) + (begin + (set-cdr! l '()) + x) + (lp (- n 1) (cdr l)))))) + +(define (drop-right! flist i) + (if (zero? i) + flist + (let lp ((n (+ i 1)) (l flist)) + (if (zero? n) + (let lp0 ((s flist) (l l)) + (if (null? l) + (begin + (set-cdr! s '()) + flist) + (lp0 (cdr s) (cdr l)))) + (if (null? l) + '() + (lp (- n 1) (cdr l))))))) + +(define (split-at x i) + (let lp ((l x) (n i) (acc '())) + (if (zero? n) + (values (reverse! acc) l) + (lp (cdr l) (- n 1) (cons (car l) acc))))) + +(define (split-at! x i) + (if (zero? i) + (values '() x) + (let lp ((l x) (n (- i 1))) + (if (zero? n) + (let ((tmp (cdr l))) + (set-cdr! l '()) + (values x tmp)) + (lp (cdr l) (- n 1)))))) + +(define (last pair) + (car (last-pair pair))) + +;;; Miscelleneous: length, append, concatenate, reverse, zip & count + +(define (length+ clist) + (if (null? clist) + 0 + (let lp ((hare (cdr clist)) (tortoise clist) (l 1)) + (if (null? hare) + l + (let ((hare (cdr hare))) + (if (null? hare) + (+ l 1) + (if (eq? hare tortoise) + #f + (lp (cdr hare) (cdr tortoise) (+ l 2))))))))) + +(define (concatenate l-o-l) + (let lp ((l l-o-l) (acc '())) + (if (null? l) + (reverse! acc) + (let lp0 ((ll (car l)) (acc acc)) + (if (null? ll) + (lp (cdr l) acc) + (lp0 (cdr ll) (cons (car ll) acc))))))) + +(define (concatenate! l-o-l) + (let lp0 ((l-o-l l-o-l)) + (cond + ((null? l-o-l) + '()) + ((null? (car l-o-l)) + (lp0 (cdr l-o-l))) + (else + (let ((result (car l-o-l)) (tail (last-pair (car l-o-l)))) + (let lp ((l (cdr l-o-l)) (ntail tail)) + (if (null? l) + result + (begin + (set-cdr! ntail (car l)) + (lp (cdr l) (last-pair ntail)))))))))) + + +(define (append-reverse rev-head tail) + (let lp ((l rev-head) (acc tail)) + (if (null? l) + acc + (lp (cdr l) (cons (car l) acc))))) + +(define (append-reverse! rev-head tail) + (append-reverse rev-head tail)) ; XXX:optimize + +(define (zip clist1 . rest) + (let lp ((l (cons clist1 rest)) (acc '())) + (if (any null? l) + (reverse! acc) + (lp (map cdr l) (cons (map car l) acc))))) + + +(define (unzip1 l) + (map first l)) +(define (unzip2 l) + (values (map first l) (map second l))) +(define (unzip3 l) + (values (map first l) (map second l) (map third l))) +(define (unzip4 l) + (values (map first l) (map second l) (map third l) (map fourth l))) +(define (unzip5 l) + (values (map first l) (map second l) (map third l) (map fourth l) + (map fifth l))) + +(define (count pred clist1 . rest) + (if (null? rest) + (count1 pred clist1) + (let lp ((lists (cons clist1 rest))) + (cond ((any1 null? lists) + 0) + (else + (if (apply pred (map car lists)) + (+ 1 (lp (map cdr lists))) + (lp (map cdr lists)))))))) + +(define (count1 pred clist) + (if (null? clist) + 0 + (if (pred (car clist)) + (+ 1 (count1 pred (cdr clist))) + (count1 pred (cdr clist))))) + +;;; Fold, unfold & map + +(define (fold kons knil list1 . rest) + (if (null? rest) + (let f ((knil knil) (list1 list1)) + (if (null? list1) + knil + (f (kons (car list1) knil) (cdr list1)))) + (let f ((knil knil) (lists (cons list1 rest))) + (if (any null? lists) + knil + (let ((cars (map car lists)) + (cdrs (map cdr lists))) + (f (apply kons cars (list knil)) cdrs)))))) + +(define (fold-right kons knil clist1 . rest) + (if (null? rest) + (let f ((list1 clist1)) + (if (null? list1) + knil + (kons (car list1) (f (cdr list1))))) + (let f ((lists (cons clist1 rest))) + (if (any null? lists) + knil + (apply kons (append! (map car lists) (list (f (map cdr lists))))))))) + +(define (pair-fold kons knil clist1 . rest) + (if (null? rest) + (let f ((knil knil) (list1 clist1)) + (if (null? list1) + knil + (let ((tail (cdr list1))) + (f (kons list1 knil) tail)))) + (let f ((knil knil) (lists (cons clist1 rest))) + (if (any null? lists) + knil + (let ((tails (map cdr lists))) + (f (apply kons lists (list knil)) tails)))))) + + +(define (pair-fold-right kons knil clist1 . rest) + (if (null? rest) + (let f ((list1 clist1)) + (if (null? list1) + knil + (kons list1 (f (cdr list1))))) + (let f ((lists (cons clist1 rest))) + (if (any null? lists) + knil + (apply kons (append! lists (list (f (map cdr lists))))))))) + +(define (unfold p f g seed . rest) + (let ((tail-gen (if (pair? rest) + (if (pair? (cdr rest)) + (scm-error 'wrong-number-of-args + "unfold" "too many arguments" '() '()) + (car rest)) + (lambda (x) '())))) + (let uf ((seed seed)) + (if (p seed) + (tail-gen seed) + (cons (f seed) + (uf (g seed))))))) + +(define (unfold-right p f g seed . rest) + (let ((tail (if (pair? rest) + (if (pair? (cdr rest)) + (scm-error 'wrong-number-of-args + "unfold-right" "too many arguments" '() + '()) + (car rest)) + '()))) + (let uf ((seed seed) (lis tail)) + (if (p seed) + lis + (uf (g seed) (cons (f seed) lis)))))) + +(define (reduce f ridentity lst) + (fold f ridentity lst)) + +(define (reduce-right f ridentity lst) + (fold-right f ridentity lst)) + +(define (append-map f clist1 . rest) + (if (null? rest) + (let lp ((l clist1)) + (if (null? l) + '() + (append (f (car l)) (lp (cdr l))))) + (let lp ((l (cons clist1 rest))) + (if (any1 null? l) + '() + (append (apply f (map car l)) (lp (map cdr l))))))) + +(define (append-map! f clist1 . rest) + (if (null? rest) + (let lp ((l clist1)) + (if (null? l) + '() + (append! (f (car l)) (lp (cdr l))))) + (let lp ((l (cons clist1 rest))) + (if (any1 null? l) + '() + (append! (apply f (map car l)) (lp (map cdr l))))))) + +(define (map! f list1 . rest) + (if (null? rest) + (let lp ((l list1)) + (if (null? l) + '() + (begin + (set-car! l (f (car l))) + (set-cdr! l (lp (cdr l))) + l))) + (let lp ((l (cons list1 rest)) (res list1)) + (if (any1 null? l) + '() + (begin + (set-car! res (apply f (map car l))) + (set-cdr! res (lp (map cdr l) (cdr res))) + res))))) + +(define (pair-for-each f clist1 . rest) + (if (null? rest) + (let lp ((l clist1)) + (if (null? l) + (if #f #f) + (begin + (f l) + (lp (cdr l))))) + (let lp ((l (cons clist1 rest))) + (if (any1 null? l) + (if #f #f) + (begin + (apply f l) + (lp (map cdr l))))))) + +(define (filter-map f clist1 . rest) + (if (null? rest) + (let lp ((l clist1)) + (if (null? l) + '() + (let ((res (f (car l)))) + (if res + (cons res (lp (cdr l))) + (lp (cdr l)))))) + (let lp ((l (cons clist1 rest))) + (if (any1 null? l) + '() + (let ((res (apply f (map car l)))) + (if res + (cons res (lp (map cdr l))) + (lp (map cdr l)))))))) + +;;; Filtering & partitioning + +(define (filter pred list) + (if (null? list) + '() + (if (pred (car list)) + (cons (car list) (filter pred (cdr list))) + (filter pred (cdr list))))) + +(define (partition pred list) + (if (null? list) + (values '() '()) + (if (pred (car list)) + (receive (in out) (partition pred (cdr list)) + (values (cons (car list) in) out)) + (receive (in out) (partition pred (cdr list)) + (values in (cons (car list) out)))))) + +(define (remove pred list) + (if (null? list) + '() + (if (pred (car list)) + (remove pred (cdr list)) + (cons (car list) (remove pred (cdr list)))))) + +(define (filter! pred list) + (filter pred list)) ; XXX:optimize + +(define (partition! pred list) + (partition pred list)) ; XXX:optimize + +(define (remove! pred list) + (remove pred list)) ; XXX:optimize + +;;; Searching + +(define (find pred clist) + (if (null? clist) + #f + (if (pred (car clist)) + (car clist) + (find pred (cdr clist))))) + +(define (find-tail pred clist) + (if (null? clist) + #f + (if (pred (car clist)) + clist + (find-tail pred (cdr clist))))) + +(define (take-while pred clist) + (if (null? clist) + '() + (if (pred (car clist)) + (cons (car clist) (take-while pred (cdr clist))) + '()))) + +(define (take-while! pred clist) + (take-while pred clist)) ; XXX:optimize + +(define (drop-while pred clist) + (if (null? clist) + '() + (if (pred (car clist)) + (drop-while pred (cdr clist)) + clist))) + +(define (span pred clist) + (if (null? clist) + (values '() '()) + (if (pred (car clist)) + (receive (first last) (span pred (cdr clist)) + (values (cons (car clist) first) last)) + (values '() clist)))) + +(define (span! pred list) + (span pred list)) ; XXX:optimize + +(define (break pred clist) + (if (null? clist) + (values '() '()) + (if (pred (car clist)) + (values '() clist) + (receive (first last) (break pred (cdr clist)) + (values (cons (car clist) first) last))))) + +(define (break! pred list) + (break pred list)) ; XXX:optimize + +(define (any pred ls . lists) + (if (null? lists) + (any1 pred ls) + (let lp ((lists (cons ls lists))) + (cond ((any1 null? lists) + #f) + ((any1 null? (map cdr lists)) + (apply pred (map car lists))) + (else + (or (apply pred (map car lists)) (lp (map cdr lists)))))))) + +(define (any1 pred ls) + (let lp ((ls ls)) + (cond ((null? ls) + #f) + ((null? (cdr ls)) + (pred (car ls))) + (else + (or (pred (car ls)) (lp (cdr ls))))))) + +(define (every pred ls . lists) + (if (null? lists) + (every1 pred ls) + (let lp ((lists (cons ls lists))) + (cond ((any1 null? lists) + #t) + ((any1 null? (map cdr lists)) + (apply pred (map car lists))) + (else + (and (apply pred (map car lists)) (lp (map cdr lists)))))))) + +(define (every1 pred ls) + (let lp ((ls ls)) + (cond ((null? ls) + #t) + ((null? (cdr ls)) + (pred (car ls))) + (else + (and (pred (car ls)) (lp (cdr ls))))))) + +(define (list-index pred clist1 . rest) + (if (null? rest) + (let lp ((l clist1) (i 0)) + (if (null? l) + #f + (if (pred (car l)) + i + (lp (cdr l) (+ i 1))))) + (let lp ((lists (cons clist1 rest)) (i 0)) + (cond ((any1 null? lists) + #f) + ((apply pred (map car lists)) i) + (else + (lp (map cdr lists) (+ i 1))))))) + +(define (member x list . rest) + (let ((l= (if (pair? rest) (car rest) equal?))) + (let lp ((l list)) + (if (null? l) + #f + (if (l= (car l) x) + l + (lp (cdr l))))))) + +;;; Deletion + +(define (delete x list . rest) + (let ((l= (if (pair? rest) (car rest) equal?))) + (let lp ((l list)) + (if (null? l) + '() + (if (l= (car l) x) + (lp (cdr l)) + (cons (car l) (lp (cdr l)))))))) + +(define (delete! x list . rest) + (let ((l= (if (pair? rest) (car rest) equal?))) + (delete x list l=))) ; XXX:optimize + +(define (delete-duplicates list . rest) + (let ((l= (if (pair? rest) (car rest) equal?))) + (let lp0 ((l1 list)) + (if (null? l1) + '() + (if (let lp1 ((l2 (cdr l1))) + (if (null? l2) + #f + (if (l= (car l1) (car l2)) + #t + (lp1 (cdr l2))))) + (lp0 (cdr l1)) + (cons (car l1) (cdr l1))))))) + +(define (delete-duplicates! list . rest) + (let ((l= (if (pair? rest) (car rest) equal?))) + (delete-duplicates list l=))) ; XXX:optimize + +;;; Association lists + +(define (assoc key alist . rest) + (let ((k= (if (pair? rest) (car rest) equal?))) + (let lp ((a alist)) + (if (null? a) + #f + (if (k= (caar a) key) + (car a) + (lp (cdr a))))))) + +(define (alist-cons key datum alist) + (acons key datum alist)) + +(define (alist-copy alist) + (let lp ((a alist)) + (if (null? a) + '() + (cons (cons (caar a) (cdar a)) (lp (cdr a)))))) + +(define (alist-delete key alist . rest) + (let ((k= (if (pair? rest) (car rest) equal?))) + (let lp ((a alist)) + (if (null? a) + '() + (if (k= (caar a) key) + (lp (cdr a)) + (cons (car a) (lp (cdr a)))))))) + +(define (alist-delete! key alist . rest) + (let ((k= (if (pair? rest) (car rest) equal?))) + (alist-delete key alist k=))) ; XXX:optimize + +;;; Set operations on lists + +(define (lset<= = . rest) + (if (null? rest) + #t + (let lp ((f (car rest)) (r (cdr rest))) + (or (null? r) + (and (every (lambda (el) (member el (car r) =)) f) + (lp (car r) (cdr r))))))) + +(define (lset= = list1 . rest) + (if (null? rest) + #t + (let lp ((f list1) (r rest)) + (or (null? r) + (and (every (lambda (el) (member el (car r) =)) f) + (every (lambda (el) (member el f =)) (car r)) + (lp (car r) (cdr r))))))) + +(define (lset-adjoin = list . rest) + (let lp ((l rest) (acc list)) + (if (null? l) + acc + (if (member (car l) acc) + (lp (cdr l) acc) + (lp (cdr l) (cons (car l) acc)))))) + +(define (lset-union = . rest) + (let lp0 ((l rest) (acc '())) + (if (null? l) + (reverse! acc) + (let lp1 ((ll (car l)) (acc acc)) + (if (null? ll) + (lp0 (cdr l) acc) + (if (member (car ll) acc =) + (lp1 (cdr ll) acc) + (lp1 (cdr ll) (cons (car ll) acc)))))))) + +(define (lset-intersection = list1 . rest) + (let lp ((l list1) (acc '())) + (if (null? l) + (reverse! acc) + (if (every (lambda (ll) (member (car l) ll =)) rest) + (lp (cdr l) (cons (car l) acc)) + (lp (cdr l) acc))))) + +(define (lset-difference = list1 . rest) + (if (null? rest) + list1 + (let lp ((l list1) (acc '())) + (if (null? l) + (reverse! acc) + (if (any (lambda (ll) (member (car l) ll =)) rest) + (lp (cdr l) acc) + (lp (cdr l) (cons (car l) acc))))))) + +;(define (fold kons knil list1 . rest) + +(define (lset-xor = . rest) + (fold (lambda (lst res) + (let lp ((l lst) (acc '())) + (if (null? l) + (let lp0 ((r res) (acc acc)) + (if (null? r) + (reverse! acc) + (if (member (car r) lst =) + (lp0 (cdr r) acc) + (lp0 (cdr r) (cons (car r) acc))))) + (if (member (car l) res =) + (lp (cdr l) acc) + (lp (cdr l) (cons (car l) acc)))))) + '() + rest)) + +(define (lset-diff+intersection = list1 . rest) + (let lp ((l list1) (accd '()) (acci '())) + (if (null? l) + (values (reverse! accd) (reverse! acci)) + (let ((appears (every (lambda (ll) (member (car l) ll =)) rest))) + (if appears + (lp (cdr l) accd (cons (car l) acci)) + (lp (cdr l) (cons (car l) accd) acci)))))) + + +(define (lset-union! = . rest) + (apply lset-union = rest)) ; XXX:optimize + +(define (lset-intersection! = list1 . rest) + (apply lset-intersection = list1 rest)) ; XXX:optimize + +(define (lset-difference! = list1 . rest) + (apply lset-difference = list1 rest)) ; XXX:optimize + +(define (lset-xor! = . rest) + (apply lset-xor = rest)) ; XXX:optimize + +(define (lset-diff+intersection! = list1 . rest) + (apply lset-diff+intersection = list1 rest)) ; XXX:optimize From 5b33ed3df93a6c71b10d45e44926020c2b8e1db6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 7 Jun 2001 12:18:01 +0000 Subject: [PATCH 1277/2047] Added scheme module file. --- examples/box-dynamic-module/box-module.scm | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) create mode 100644 examples/box-dynamic-module/box-module.scm diff --git a/examples/box-dynamic-module/box-module.scm b/examples/box-dynamic-module/box-module.scm new file mode 100644 index 000000000..cab41c7e5 --- /dev/null +++ b/examples/box-dynamic-module/box-module.scm @@ -0,0 +1,17 @@ +;;; examples/box-dynamic-module/box-module.scm -- Scheme part of the +;;; dynamic module (box-module) + +;;; Commentary: + +;;; This is the Scheme part of the dynamic library module (box-module). +;;; When you do a (use-modules (box-module)) in this directory, +;;; this file gets loaded and will load the compiled extension. + +;;; Code: + +;;; Author: Martin Grabmueller +;;; Date: 2001-06-06 + +(define-module (box-module)) + +(load-extension "libbox-module" "scm_init_box") From 563058efbe03208cacb43f664c702e3979922cb6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 7 Jun 2001 17:54:40 +0000 Subject: [PATCH 1278/2047] * srfi-1.scm (fold, fold-pair): Fixed a buggy call to apply. (delete-duplicates): Now the first occurrence of an element is retained, as required. (member, assoc): Fixed wrong order of equality predicate application. --- srfi/ChangeLog | 9 +++++++++ srfi/srfi-1.scm | 20 ++++++++++++++------ 2 files changed, 23 insertions(+), 6 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 8d03b3060..dd808e359 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,12 @@ +2001-06-07 Martin Grabmueller + + * srfi-1.scm (fold, fold-pair): Fixed a buggy call to apply. + (delete-duplicates): Now the first occurrence of an element is + retained, as required. + (member, assoc): Fixed wrong order of equality predicate + application. + + 2001-06-06 Martin Grabmueller * README: Update. diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm index a5315511f..1b2b1cab0 100644 --- a/srfi/srfi-1.scm +++ b/srfi/srfi-1.scm @@ -57,6 +57,7 @@ ;;; Code: (define-module (srfi srfi-1) + :use-module (ice-9 session) :use-module (ice-9 receive)) (export @@ -516,7 +517,7 @@ knil (let ((cars (map car lists)) (cdrs (map cdr lists))) - (f (apply kons cars (list knil)) cdrs)))))) + (f (apply kons (append! cars (list knil))) cdrs)))))) (define (fold-right kons knil clist1 . rest) (if (null? rest) @@ -540,7 +541,7 @@ (if (any null? lists) knil (let ((tails (map cdr lists))) - (f (apply kons lists (list knil)) tails)))))) + (f (apply kons (append! lists (list knil))) tails)))))) (define (pair-fold-right kons knil clist1 . rest) @@ -806,7 +807,7 @@ (let lp ((l list)) (if (null? l) #f - (if (l= (car l) x) + (if (l= x (car l)) l (lp (cdr l))))))) @@ -837,7 +838,14 @@ #t (lp1 (cdr l2))))) (lp0 (cdr l1)) - (cons (car l1) (cdr l1))))))) + (cons (car l1) (lp0 (cdr l1)))))))) + +(define (delete-duplicates list . rest) + (let ((l= (if (pair? rest) (car rest) equal?))) + (let lp ((list list)) + (if (null? list) + '() + (cons (car list) (lp (delete (car list) (cdr list) l=))))))) (define (delete-duplicates! list . rest) (let ((l= (if (pair? rest) (car rest) equal?))) @@ -850,7 +858,7 @@ (let lp ((a alist)) (if (null? a) #f - (if (k= (caar a) key) + (if (k= key (caar a)) (car a) (lp (cdr a))))))) @@ -861,7 +869,7 @@ (let lp ((a alist)) (if (null? a) '() - (cons (cons (caar a) (cdar a)) (lp (cdr a)))))) + (acons (caar a) (cdar a) (lp (cdr a)))))) (define (alist-delete key alist . rest) (let ((k= (if (pair? rest) (car rest) equal?))) From e81d98ec2d12d9101dc79928833b2c064d148afc Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 7 Jun 2001 21:12:19 +0000 Subject: [PATCH 1279/2047] * Introduce SCM_UNUSED and mark unused function parameters. * Introduce SCM_DEBUG_PAIR_ACCESSES. * Extend the possibilities of SCM_DEBUG_CELL_ACCESSES. --- guile-readline/ChangeLog | 5 +++ guile-readline/readline.c | 4 +- libguile/ChangeLog | 74 +++++++++++++++++++++++++++++++++++ libguile/__scm.h | 40 +++++++++++++++++++ libguile/backtrace.c | 4 +- libguile/continuations.c | 4 +- libguile/debug.c | 2 +- libguile/dynwind.c | 4 +- libguile/environments.c | 35 ++++++++++------- libguile/error.h | 17 ++------ libguile/eval.c | 46 +++++++++++----------- libguile/evalext.c | 4 +- libguile/filesys.c | 2 +- libguile/fluids.c | 2 +- libguile/fports.c | 4 +- libguile/gc.c | 82 +++++++++++++++++++++++++++++++++++---- libguile/gh_init.c | 6 +-- libguile/goops.c | 17 ++++---- libguile/guardians.c | 14 +++++-- libguile/guile.c | 4 +- libguile/init.c | 4 +- libguile/keywords.c | 2 +- libguile/mallocs.c | 2 +- libguile/numbers.c | 6 +-- libguile/pairs.c | 16 +++++++- libguile/pairs.h | 27 +++++++++---- libguile/ports.c | 12 +++--- libguile/ramap.c | 2 +- libguile/rdelim.c | 2 +- libguile/root.c | 4 +- libguile/smob.c | 17 ++++---- libguile/stime.c | 2 +- libguile/strings.c | 2 +- libguile/struct.c | 15 ++++--- libguile/symbols.c | 2 +- libguile/throw.c | 10 ++--- libguile/weaks.c | 12 ++++-- srfi/ChangeLog | 6 ++- srfi/srfi-14.c | 4 +- 39 files changed, 378 insertions(+), 139 deletions(-) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index d010037cd..b8f3410fe 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,8 @@ +2001-06-07 Dirk Herrmann + + * readline.c (current_input_getc): Mark unused parameters with + SCM_UNUSED. + 2001-06-03 Marius Vollmer * configure.in: Added AC_PREREQ(2.50) and minimally changed for diff --git a/guile-readline/readline.c b/guile-readline/readline.c index 6070e174f..b085f94d8 100644 --- a/guile-readline/readline.c +++ b/guile-readline/readline.c @@ -1,6 +1,6 @@ /* readline.c --- line editing support for Guile */ -/* Copyright (C) 1997,1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1997,1999,2000,2001 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 @@ -128,7 +128,7 @@ static SCM input_port; static SCM before_read; static int -current_input_getc (FILE *in) +current_input_getc (FILE *in SCM_UNUSED) { if (promptp && !SCM_FALSEP (before_read)) { diff --git a/libguile/ChangeLog b/libguile/ChangeLog index a4cc49e64..ef708e74e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,77 @@ +2001-06-07 Dirk Herrmann + + * __scm.h (SCM_NORETURN): Moved here from error.h. + + (SCM_UNUSED): New macro. + + (SCM_DEBUG_PAIR_ACCESSES): New macro. + + * backtrace.c (display_error_handler), continuations.c + (continuation_print), debug.c (debugobj_print), dynwind.c + (guards_print), environments.c (observer_print, + core_environments_finalize, leaf_environment_cell, + leaf_environment_print, eval_environment_print, + eval_environment_observer, import_environment_define, + import_environment_undefine, import_environment_print, + import_environment_observer, export_environment_define, + export_environment_undefine, export_environment_print, + export_environment_observer), eval.c (scm_m_quote, scm_m_begin, + scm_m_if, scm_m_set_x, scm_m_and, scm_m_or, scm_m_case, + scm_m_cond, scm_m_lambda, scm_m_letstar, scm_m_do, scm_m_delay, + scm_m_letrec1, scm_m_apply, scm_m_cont, scm_m_nil_cond, + scm_m_nil_ify, scm_m_t_ify, scm_m_0_cond, scm_m_0_ify, + scm_m_1_ify, scm_m_atfop, scm_m_at_call_with_values), evalext.c + (scm_m_generalized_set_x), fluids.c (fluid_print), fports.c + (fport_print), gc.c (gc_start_stats, scm_remember_upto_here_1, + scm_remember_upto_here_2, scm_remember_upto_here, mark_gc_async), + gh_init.c (gh_standard_handler), goops.c (get_slot_value, + set_slot_value, test_slot_existence, scm_change_object_class, + scm_m_atslot_ref, scm_m_atslot_set_x, make_struct_class, + default_setter), guardians.c (guardian_print, guardian_gc_init, + guardian_zombify, whine_about_self_centered_zombies), guile.c + (inner_main), init.c (stream_handler), keywords.c (keyword_print), + mallocs.c (malloc_print), numbers.c (scm_print_real, + scm_print_complex, scm_bigprint), ports.c (flush_port_default, + end_input_default, scm_port_print, fill_input_void_port, + write_void_port), root.c (root_print), smob.c (scm_mark0, + scm_free0, scm_smob_print, scm_smob_apply_1_error, + scm_smob_apply_2_error, scm_smob_apply_3_error, free_print), + stime.c (restorezone), strings.c (scm_makfromstr), struct.c + (scm_struct_free_0, scm_struct_free_standard, + scm_struct_free_entity, scm_struct_gc_init, scm_free_structs), + throw.c (jmpbuffer_print, lazy_catch_print, ss_handler, + scm_handle_by_throw, scm_ithrow), weaks.c + (scm_weak_vector_gc_init, scm_mark_weak_vector_spines, + scm_scan_weak_vectors), ramap.c (scm_array_fill_int), filesys.c + (scm_dir_print): Mark unused parameters with SCM_UNUSED. + + * error.h (SCM_NORETURN): Moved to __scm.h. + + * error.h (ERRORH, SCM_ERROR_H), pairs.h (PAIRSH, SCM_PAIRS_H): + Renamed H to SCM__H. + + * gc.c (debug_cells_gc_interval): New static variable. + + (scm_assert_cell_valid): If selected by the user, perform + additional garbage collections. + + (scm_set_debug_cell_accesses_x): Extended to let the user specify + if additional garbage collections are desired. + + (mark_gc_async): If additional garbage collections are selected + by the user, don't call the after-gc-hook. Instead require the + user to run the hook manually. + + * pairs.c (scm_error_pair_access): New function. Only compiled + if SCM_DEBUG_PAIR_ACCESSES is set to 1. + + * pairs.h (SCM_VALIDATE_PAIR): New macro. + + (SCM_CAR, SCM_CDR, SCM_SETCAR, SCM_SETCDR): If + SCM_DEBUG_PAIR_ACCESSES is set to 1, make sure that the argument + is a real pair object. (Glocs are also accepted, but that may + change.) If not, abort with an error message. + 2001-06-05 Dirk Herrmann * eval.c (SCM_VALIDATE_NON_EMPTY_COMBINATION): New macro. diff --git a/libguile/__scm.h b/libguile/__scm.h index 2a06b9caa..f5e7ed3a0 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -55,6 +55,38 @@ should go in __scm.h. */ +/* {Compiler hints} + * + * The following macros are used to provide additional information for the + * compiler, which may help to do better error checking and code + * optimization. A second benefit of these macros is, that they also provide + * additional information to the developers. + */ + +/* The macro SCM_NORETURN indicates that a function will never return. + * Examples: + * 1) int foo (char arg) SCM_NORETURN; + */ +#ifdef __GNUC__ +#define SCM_NORETURN __attribute__ ((noreturn)) +#else +#define SCM_NORETURN +#endif + +/* The macro SCM_UNUSED indicates that a function, function argument or + * variable may potentially be unused. + * Examples: + * 1) static int unused_function (char arg) SCM_UNUSED; + * 2) int foo (char unused_argument SCM_UNUSED); + * 3) int unused_variable SCM_UNUSED; + */ +#ifdef __GNUC__ +#define SCM_UNUSED __attribute__ ((unused)) +#else +#define SCM_UNUSED +#endif + + /* {Supported Options} * * These may be defined or undefined. @@ -177,6 +209,14 @@ #define SCM_DEBUG_INTERRUPTS SCM_DEBUG #endif +/* If SCM_DEBUG_PAIR_ACCESSES is set to 1, accesses to cons cells will be + * exhaustively checked. Note: If this option is enabled, guile will run + * slower than normally. + */ +#ifndef SCM_DEBUG_PAIR_ACCESSES +#define SCM_DEBUG_PAIR_ACCESSES SCM_DEBUG +#endif + /* If SCM_DEBUG_REST_ARGUMENT is set to 1, functions that take rest arguments * will check whether the rest arguments are actually passed as a proper list. * Otherwise, if SCM_DEBUG_REST_ARGUMENT is 0, functions that take rest diff --git a/libguile/backtrace.c b/libguile/backtrace.c index a602d9139..8ddc473df 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -1,5 +1,5 @@ /* Printing of backtraces and error messages - * Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation + * Copyright (C) 1996,1997,1998,1999,2000,2001 Free Software Foundation * * 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 @@ -216,7 +216,7 @@ struct display_error_handler_data { try to print all objects, we would enter an infinite loop. */ static SCM display_error_handler (struct display_error_handler_data *data, - SCM tag, SCM args) + SCM tag, SCM args SCM_UNUSED) { SCM print_state = scm_make_print_state (); scm_puts ("\nException during displaying of ", data->port); diff --git a/libguile/continuations.c b/libguile/continuations.c index 7b33d7248..49f2890d8 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,2000,2001 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 @@ -94,7 +94,7 @@ continuation_free (SCM obj) } static int -continuation_print (SCM obj, SCM port, scm_print_state *state) +continuation_print (SCM obj, SCM port, scm_print_state *state SCM_UNUSED) { scm_contregs_t *continuation = SCM_CONTREGS (obj); diff --git a/libguile/debug.c b/libguile/debug.c index dc47c9dbc..bd0b4ba7f 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -557,7 +557,7 @@ scm_m_start_stack (SCM exp, SCM env) scm_bits_t scm_tc16_debugobj; static int -debugobj_print (SCM obj, SCM port, scm_print_state *pstate) +debugobj_print (SCM obj, SCM port, scm_print_state *pstate SCM_UNUSED) { scm_puts ("#obarray; SCM binding = obarray_retrieve (obarray, sym); @@ -1002,7 +1002,7 @@ leaf_environment_free (SCM env) static int -leaf_environment_print (SCM type, SCM port, scm_print_state *pstate) +leaf_environment_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED) { SCM address = scm_ulong2num (SCM_UNPACK (type)); SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16)); @@ -1363,7 +1363,7 @@ eval_environment_free (SCM env) static int -eval_environment_print (SCM type, SCM port, scm_print_state *pstate) +eval_environment_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED) { SCM address = scm_ulong2num (SCM_UNPACK (type)); SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16)); @@ -1395,7 +1395,7 @@ void *scm_type_eval_environment = &eval_environment_funcs; static void -eval_environment_observer (SCM caller, SCM eval_env) +eval_environment_observer (SCM caller SCM_UNUSED, SCM eval_env) { SCM obarray = EVAL_ENVIRONMENT (eval_env)->obarray; @@ -1687,7 +1687,9 @@ import_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM ini static SCM -import_environment_define (SCM env, SCM sym, SCM val) +import_environment_define (SCM env SCM_UNUSED, + SCM sym SCM_UNUSED, + SCM val SCM_UNUSED) #define FUNC_NAME "import_environment_define" { return SCM_ENVIRONMENT_BINDING_IMMUTABLE; @@ -1696,7 +1698,8 @@ import_environment_define (SCM env, SCM sym, SCM val) static SCM -import_environment_undefine (SCM env, SCM sym) +import_environment_undefine (SCM env SCM_UNUSED, + SCM sym SCM_UNUSED) #define FUNC_NAME "import_environment_undefine" { return SCM_ENVIRONMENT_BINDING_IMMUTABLE; @@ -1779,7 +1782,8 @@ import_environment_free (SCM env) static int -import_environment_print (SCM type, SCM port, scm_print_state *pstate) +import_environment_print (SCM type, SCM port, + scm_print_state *pstate SCM_UNUSED) { SCM address = scm_ulong2num (SCM_UNPACK (type)); SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16)); @@ -1811,7 +1815,7 @@ void *scm_type_import_environment = &import_environment_funcs; static void -import_environment_observer (SCM caller, SCM import_env) +import_environment_observer (SCM caller SCM_UNUSED, SCM import_env) { core_environments_broadcast (import_env); } @@ -1997,7 +2001,9 @@ export_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM ini static SCM -export_environment_define (SCM env, SCM sym, SCM val) +export_environment_define (SCM env SCM_UNUSED, + SCM sym SCM_UNUSED, + SCM val SCM_UNUSED) #define FUNC_NAME "export_environment_define" { return SCM_ENVIRONMENT_BINDING_IMMUTABLE; @@ -2006,7 +2012,7 @@ export_environment_define (SCM env, SCM sym, SCM val) static SCM -export_environment_undefine (SCM env, SCM sym) +export_environment_undefine (SCM env SCM_UNUSED, SCM sym SCM_UNUSED) #define FUNC_NAME "export_environment_undefine" { return SCM_ENVIRONMENT_BINDING_IMMUTABLE; @@ -2082,7 +2088,8 @@ export_environment_free (SCM env) static int -export_environment_print (SCM type, SCM port, scm_print_state *pstate) +export_environment_print (SCM type, SCM port, + scm_print_state *pstate SCM_UNUSED) { SCM address = scm_ulong2num (SCM_UNPACK (type)); SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16)); @@ -2114,7 +2121,7 @@ void *scm_type_export_environment = &export_environment_funcs; static void -export_environment_observer (SCM caller, SCM export_env) +export_environment_observer (SCM caller SCM_UNUSED, SCM export_env) { core_environments_broadcast (export_env); } diff --git a/libguile/error.h b/libguile/error.h index cfdc604a1..37b8ee342 100644 --- a/libguile/error.h +++ b/libguile/error.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef ERRORH -#define ERRORH -/* Copyright (C) 1995,1996,1997,1998, 2000 Free Software Foundation, Inc. +#ifndef SCM_ERROR_H +#define SCM_ERROR_H +/* Copyright (C) 1995,1996,1997,1998,2000,2001 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 @@ -50,15 +50,6 @@ extern int scm_ints_disabled; -/* GCC can be told that a function doesn't return; this helps it do - better error checking (for uninitialized variable use, for - example), and some optimization. */ -#ifdef __GNUC__ -#define SCM_NORETURN __attribute__ ((noreturn)) -#else -#define SCM_NORETURN -#endif - extern void scm_error (SCM key, const char *subr, const char *message, SCM args, SCM rest) SCM_NORETURN; extern SCM scm_error_scm (SCM key, SCM subr, SCM message, @@ -91,7 +82,7 @@ extern SCM scm_wta (SCM arg, const char *pos, const char *s_subr); #endif /* SCM_DEBUG_DEPRECATED == 0 */ -#endif /* ERRORH */ +#endif /* SCM_ERROR_H */ /* Local Variables: diff --git a/libguile/eval.c b/libguile/eval.c index ee577c1e1..a45ae0851 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -518,7 +518,7 @@ SCM_SYNTAX(s_quote,"quote", scm_makmmacro, scm_m_quote); SCM_GLOBAL_SYMBOL(scm_sym_quote, s_quote); SCM -scm_m_quote (SCM xorig, SCM env) +scm_m_quote (SCM xorig, SCM env SCM_UNUSED) { SCM x = scm_copy_tree (SCM_CDR (xorig)); @@ -532,7 +532,7 @@ SCM_SYNTAX(s_begin, "begin", scm_makmmacro, scm_m_begin); SCM_GLOBAL_SYMBOL(scm_sym_begin, s_begin); SCM -scm_m_begin (SCM xorig, SCM env) +scm_m_begin (SCM xorig, SCM env SCM_UNUSED) { SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 1, scm_s_expression, s_begin); return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig)); @@ -542,7 +542,7 @@ SCM_SYNTAX(s_if, "if", scm_makmmacro, scm_m_if); SCM_GLOBAL_SYMBOL(scm_sym_if, s_if); SCM -scm_m_if (SCM xorig, SCM env) +scm_m_if (SCM xorig, SCM env SCM_UNUSED) { long len = scm_ilength (SCM_CDR (xorig)); SCM_ASSYNT (len >= 2 && len <= 3, scm_s_expression, "if"); @@ -556,7 +556,7 @@ const char scm_s_set_x[] = "set!"; SCM_GLOBAL_SYMBOL(scm_sym_set_x, scm_s_set_x); SCM -scm_m_set_x (SCM xorig, SCM env) +scm_m_set_x (SCM xorig, SCM env SCM_UNUSED) { SCM x = SCM_CDR (xorig); SCM_ASSYNT (2 == scm_ilength (x), scm_s_expression, scm_s_set_x); @@ -569,7 +569,7 @@ SCM_SYNTAX(s_and, "and", scm_makmmacro, scm_m_and); SCM_GLOBAL_SYMBOL(scm_sym_and, s_and); SCM -scm_m_and (SCM xorig, SCM env) +scm_m_and (SCM xorig, SCM env SCM_UNUSED) { long len = scm_ilength (SCM_CDR (xorig)); SCM_ASSYNT (len >= 0, scm_s_test, s_and); @@ -583,7 +583,7 @@ SCM_SYNTAX(s_or,"or", scm_makmmacro, scm_m_or); SCM_GLOBAL_SYMBOL(scm_sym_or,s_or); SCM -scm_m_or (SCM xorig, SCM env) +scm_m_or (SCM xorig, SCM env SCM_UNUSED) { long len = scm_ilength (SCM_CDR (xorig)); SCM_ASSYNT (len >= 0, scm_s_test, s_or); @@ -598,7 +598,7 @@ SCM_SYNTAX(s_case, "case", scm_makmmacro, scm_m_case); SCM_GLOBAL_SYMBOL(scm_sym_case, s_case); SCM -scm_m_case (SCM xorig, SCM env) +scm_m_case (SCM xorig, SCM env SCM_UNUSED) { SCM proc, cdrx = scm_list_copy (SCM_CDR (xorig)), x = cdrx; SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_clauses, s_case); @@ -620,7 +620,7 @@ SCM_GLOBAL_SYMBOL(scm_sym_cond, s_cond); SCM -scm_m_cond (SCM xorig, SCM env) +scm_m_cond (SCM xorig, SCM env SCM_UNUSED) { SCM arg1, cdrx = scm_list_copy (SCM_CDR (xorig)), x = cdrx; long len = scm_ilength (x); @@ -663,7 +663,7 @@ scm_c_improper_memq (SCM obj, SCM list) } SCM -scm_m_lambda (SCM xorig, SCM env) +scm_m_lambda (SCM xorig, SCM env SCM_UNUSED) { SCM proc, x = SCM_CDR (xorig); if (scm_ilength (x) < 2) @@ -710,7 +710,7 @@ SCM_GLOBAL_SYMBOL(scm_sym_letstar,s_letstar); SCM -scm_m_letstar (SCM xorig, SCM env) +scm_m_letstar (SCM xorig, SCM env SCM_UNUSED) { SCM x = SCM_CDR (xorig), arg1, proc, vars = SCM_EOL, *varloc = &vars; long len = scm_ilength (x); @@ -750,7 +750,7 @@ SCM_SYNTAX(s_do, "do", scm_makmmacro, scm_m_do); SCM_GLOBAL_SYMBOL(scm_sym_do, s_do); SCM -scm_m_do (SCM xorig, SCM env) +scm_m_do (SCM xorig, SCM env SCM_UNUSED) { SCM x = SCM_CDR (xorig), arg1, proc; SCM vars = SCM_EOL, inits = SCM_EOL, steps = SCM_EOL; @@ -852,7 +852,7 @@ SCM_SYNTAX (s_delay, "delay", scm_makmmacro, scm_m_delay); SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay); SCM -scm_m_delay (SCM xorig, SCM env) +scm_m_delay (SCM xorig, SCM env SCM_UNUSED) { SCM_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_delay); return scm_cons2 (SCM_IM_DELAY, SCM_EOL, SCM_CDR (xorig)); @@ -912,7 +912,7 @@ scm_m_define (SCM x, SCM env) /* end of acros */ static SCM -scm_m_letrec1 (SCM op, SCM imm, SCM xorig, SCM env) +scm_m_letrec1 (SCM op, SCM imm, SCM xorig, SCM env SCM_UNUSED) { SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */ char *what = SCM_SYMBOL_CHARS (SCM_CAR (xorig)); @@ -1022,7 +1022,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply); SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1); SCM -scm_m_apply (SCM xorig, SCM env) +scm_m_apply (SCM xorig, SCM env SCM_UNUSED) { SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, scm_s_expression, s_atapply); return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig)); @@ -1034,7 +1034,7 @@ SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc,s_atcall_cc); SCM -scm_m_cont (SCM xorig, SCM env) +scm_m_cont (SCM xorig, SCM env SCM_UNUSED) { SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, s_atcall_cc); @@ -1049,7 +1049,7 @@ SCM_GLOBAL_SYMBOL (scm_lisp_t, "t"); SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond); SCM -scm_m_nil_cond (SCM xorig, SCM env) +scm_m_nil_cond (SCM xorig, SCM env SCM_UNUSED) { long len = scm_ilength (SCM_CDR (xorig)); SCM_ASSYNT (len >= 1 && (len & 1) == 1, scm_s_expression, "nil-cond"); @@ -1059,7 +1059,7 @@ scm_m_nil_cond (SCM xorig, SCM env) SCM_SYNTAX (s_nil_ify, "nil-ify", scm_makmmacro, scm_m_nil_ify); SCM -scm_m_nil_ify (SCM xorig, SCM env) +scm_m_nil_ify (SCM xorig, SCM env SCM_UNUSED) { SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "nil-ify"); return scm_cons (SCM_IM_NIL_IFY, SCM_CDR (xorig)); @@ -1068,7 +1068,7 @@ scm_m_nil_ify (SCM xorig, SCM env) SCM_SYNTAX (s_t_ify, "t-ify", scm_makmmacro, scm_m_t_ify); SCM -scm_m_t_ify (SCM xorig, SCM env) +scm_m_t_ify (SCM xorig, SCM env SCM_UNUSED) { SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "t-ify"); return scm_cons (SCM_IM_T_IFY, SCM_CDR (xorig)); @@ -1077,7 +1077,7 @@ scm_m_t_ify (SCM xorig, SCM env) SCM_SYNTAX (s_0_cond, "0-cond", scm_makmmacro, scm_m_0_cond); SCM -scm_m_0_cond (SCM xorig, SCM env) +scm_m_0_cond (SCM xorig, SCM env SCM_UNUSED) { long len = scm_ilength (SCM_CDR (xorig)); SCM_ASSYNT (len >= 1 && (len & 1) == 1, scm_s_expression, "0-cond"); @@ -1087,7 +1087,7 @@ scm_m_0_cond (SCM xorig, SCM env) SCM_SYNTAX (s_0_ify, "0-ify", scm_makmmacro, scm_m_0_ify); SCM -scm_m_0_ify (SCM xorig, SCM env) +scm_m_0_ify (SCM xorig, SCM env SCM_UNUSED) { SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "0-ify"); return scm_cons (SCM_IM_0_IFY, SCM_CDR (xorig)); @@ -1096,7 +1096,7 @@ scm_m_0_ify (SCM xorig, SCM env) SCM_SYNTAX (s_1_ify, "1-ify", scm_makmmacro, scm_m_1_ify); SCM -scm_m_1_ify (SCM xorig, SCM env) +scm_m_1_ify (SCM xorig, SCM env SCM_UNUSED) { SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "1-ify"); return scm_cons (SCM_IM_1_IFY, SCM_CDR (xorig)); @@ -1105,7 +1105,7 @@ scm_m_1_ify (SCM xorig, SCM env) SCM_SYNTAX (s_atfop, "@fop", scm_makmmacro, scm_m_atfop); SCM -scm_m_atfop (SCM xorig, SCM env) +scm_m_atfop (SCM xorig, SCM env SCM_UNUSED) { SCM x = SCM_CDR (xorig), var; SCM_ASSYNT (scm_ilength (x) >= 1, scm_s_expression, "@fop"); @@ -1148,7 +1148,7 @@ SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_makmmacro, scm_m_at_ SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values); SCM -scm_m_at_call_with_values (SCM xorig, SCM env) +scm_m_at_call_with_values (SCM xorig, SCM env SCM_UNUSED) { SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, scm_s_expression, s_at_call_with_values); diff --git a/libguile/evalext.c b/libguile/evalext.c index a36ef687b..b19f94c21 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1998,1999,2000,2001 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 @@ -56,7 +56,7 @@ SCM_SYMBOL (scm_sym_setter, "setter"); SCM -scm_m_generalized_set_x (SCM xorig, SCM env) +scm_m_generalized_set_x (SCM xorig, SCM env SCM_UNUSED) { SCM x = SCM_CDR (xorig); SCM_ASSYNT (2 == scm_ilength (x), scm_s_expression, scm_s_set_x); diff --git a/libguile/filesys.c b/libguile/filesys.c index 0960300e6..56b4737d1 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -783,7 +783,7 @@ SCM_DEFINE (scm_closedir, "closedir", 1, 0, 0, static int -scm_dir_print (SCM exp, SCM port, scm_print_state *pstate) +scm_dir_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { scm_puts ("#<", port); if (!SCM_DIR_OPEN_P (exp)) diff --git a/libguile/fluids.c b/libguile/fluids.c index 718dc5f3f..b3a12d666 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -96,7 +96,7 @@ scm_copy_fluids (scm_root_state *root_state) } static int -fluid_print (SCM exp, SCM port, scm_print_state *pstate) +fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { scm_puts ("#string", 1, 1, 0, SCM_BIGDIG conditionals */ int -scm_print_real (SCM sexp, SCM port, scm_print_state *pstate) +scm_print_real (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED) { char num_buf[FLOBUFLEN]; scm_lfwrite (num_buf, iflo2str (sexp, num_buf), port); @@ -2213,7 +2213,7 @@ scm_print_real (SCM sexp, SCM port, scm_print_state *pstate) } int -scm_print_complex (SCM sexp, SCM port, scm_print_state *pstate) +scm_print_complex (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED) { char num_buf[FLOBUFLEN]; scm_lfwrite (num_buf, iflo2str (sexp, num_buf), port); @@ -2221,7 +2221,7 @@ scm_print_complex (SCM sexp, SCM port, scm_print_state *pstate) } int -scm_bigprint (SCM exp, SCM port, scm_print_state *pstate) +scm_bigprint (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { #ifdef SCM_BIGDIG exp = big2str (exp, (unsigned int) 10); diff --git a/libguile/pairs.c b/libguile/pairs.c index 812c39235..48db366b3 100644 --- a/libguile/pairs.c +++ b/libguile/pairs.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,2000,2001 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 @@ -54,6 +54,20 @@ /* {Pairs} */ +#if (SCM_DEBUG_PAIR_ACCESSES == 1) + +#include "libguile/ports.h" +#include "libguile/strings.h" + +void scm_error_pair_access (SCM non_pair) +{ + SCM message = scm_makfrom0str ("Non-pair accessed with SCM_C[AD]R: `~S´\n"); + scm_simple_format (scm_current_error_port (), message, SCM_LIST1 (non_pair)); + abort (); +} + +#endif + SCM_DEFINE (scm_cons, "cons", 2, 0, 0, (SCM x, SCM y), "Return a newly allocated pair whose car is @var{x} and whose\n" diff --git a/libguile/pairs.h b/libguile/pairs.h index 96b0e47d7..17aa76cd1 100644 --- a/libguile/pairs.h +++ b/libguile/pairs.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef PAIRSH -#define PAIRSH -/* Copyright (C) 1995,1996,2000 Free Software Foundation, Inc. +#ifndef SCM_PAIRS_H +#define SCM_PAIRS_H +/* Copyright (C) 1995,1996,2000,2001 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 @@ -52,14 +52,22 @@ +#if (SCM_DEBUG_PAIR_ACCESSES == 1) +# include "libguile/struct.h" +# define SCM_VALIDATE_PAIR(cell, expr) \ + ((!SCM_ECONSP (cell) ? scm_error_pair_access (cell), 0 : 0), (expr)) +#else +# define SCM_VALIDATE_PAIR(cell, expr) (expr) +#endif + #define SCM_NULLP(x) (SCM_EQ_P ((x), SCM_EOL)) #define SCM_NNULLP(x) (!SCM_NULLP (x)) -#define SCM_CAR(x) (SCM_CELL_OBJECT_0 (x)) -#define SCM_CDR(x) (SCM_CELL_OBJECT_1 (x)) +#define SCM_CAR(x) (SCM_VALIDATE_PAIR (x, SCM_CELL_OBJECT_0 (x))) +#define SCM_CDR(x) (SCM_VALIDATE_PAIR (x, SCM_CELL_OBJECT_1 (x))) -#define SCM_SETCAR(x, v) (SCM_SET_CELL_OBJECT_0 ((x), (v))) -#define SCM_SETCDR(x, v) (SCM_SET_CELL_OBJECT_1 ((x), (v))) +#define SCM_SETCAR(x, v) (SCM_VALIDATE_PAIR (x, SCM_SET_CELL_OBJECT_0 ((x), (v)))) +#define SCM_SETCDR(x, v) (SCM_VALIDATE_PAIR (x, SCM_SET_CELL_OBJECT_1 ((x), (v)))) #define SCM_CAAR(OBJ) SCM_CAR (SCM_CAR (OBJ)) #define SCM_CDAR(OBJ) SCM_CDR (SCM_CAR (OBJ)) @@ -94,6 +102,9 @@ +#if (SCM_DEBUG_PAIR_ACCESSES == 1) +extern void scm_error_pair_access (SCM) SCM_NORETURN; +#endif extern SCM scm_cons (SCM x, SCM y); extern SCM scm_cons2 (SCM w, SCM x, SCM y); extern SCM scm_pair_p (SCM x); @@ -101,7 +112,7 @@ extern SCM scm_set_car_x (SCM pair, SCM value); extern SCM scm_set_cdr_x (SCM pair, SCM value); extern void scm_init_pairs (void); -#endif /* PAIRSH */ +#endif /* SCM_PAIRS_H */ /* Local Variables: diff --git a/libguile/ports.c b/libguile/ports.c index 9bc8168bd..cf1ac56c7 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -108,12 +108,12 @@ scm_markstream (SCM ptr) */ static void -flush_port_default (SCM port) +flush_port_default (SCM port SCM_UNUSED) { } static void -end_input_default (SCM port, int offset) +end_input_default (SCM port SCM_UNUSED, int offset SCM_UNUSED) { } @@ -1487,7 +1487,7 @@ scm_print_port_mode (SCM exp, SCM port) } int -scm_port_print (SCM exp, SCM port, scm_print_state *pstate) +scm_port_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { char *type = SCM_PTOBNAME (SCM_PTOBNUM (exp)); if (!type) @@ -1514,13 +1514,15 @@ scm_ports_prehistory () scm_bits_t scm_tc16_void_port = 0; -static int fill_input_void_port (SCM port) +static int fill_input_void_port (SCM port SCM_UNUSED) { return EOF; } static void -write_void_port (SCM port, const void *data, size_t size) +write_void_port (SCM port SCM_UNUSED, + const void *data SCM_UNUSED, + size_t size SCM_UNUSED) { } diff --git a/libguile/ramap.c b/libguile/ramap.c index 74e281c65..4c169753b 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -475,7 +475,7 @@ SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0, /* to be used as cproc in scm_ramapc to fill an array dimension with "fill". */ int -scm_array_fill_int (SCM ra, SCM fill, SCM ignore) +scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED) #define FUNC_NAME s_scm_array_fill_x { unsigned long i; diff --git a/libguile/rdelim.c b/libguile/rdelim.c index c029b3f8c..b8fde12e2 100644 --- a/libguile/rdelim.c +++ b/libguile/rdelim.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 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 diff --git a/libguile/root.c b/libguile/root.c index f3d6edd86..e37d77b8f 100644 --- a/libguile/root.c +++ b/libguile/root.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000 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 @@ -92,7 +92,7 @@ root_mark (SCM root) static int -root_print (SCM exp, SCM port, scm_print_state *pstate) +root_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { scm_puts ("# rootcont), 16, port); diff --git a/libguile/smob.c b/libguile/smob.c index e2d9fcb7c..558adc979 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -84,7 +84,7 @@ scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT]; to make their links fail. */ SCM -scm_mark0 (SCM ptr) +scm_mark0 (SCM ptr SCM_UNUSED) { return SCM_BOOL_F; } @@ -101,7 +101,7 @@ scm_markcdr (SCM ptr) */ size_t -scm_free0 (SCM ptr) +scm_free0 (SCM ptr SCM_UNUSED) { return 0; } @@ -117,7 +117,7 @@ scm_smob_free (SCM obj) */ int -scm_smob_print (SCM exp, SCM port, scm_print_state *pstate) +scm_smob_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { long n = SCM_SMOBNUM (exp); scm_puts ("#<", port); @@ -216,7 +216,7 @@ scm_smob_apply_1_021 (SCM smob, SCM a1) } static SCM -scm_smob_apply_1_error (SCM smob, SCM a1) +scm_smob_apply_1_error (SCM smob, SCM a1 SCM_UNUSED) { scm_wrong_num_args (smob); } @@ -246,7 +246,7 @@ scm_smob_apply_2_021 (SCM smob, SCM a1, SCM a2) } static SCM -scm_smob_apply_2_error (SCM smob, SCM a1, SCM a2) +scm_smob_apply_2_error (SCM smob, SCM a1 SCM_UNUSED, SCM a2 SCM_UNUSED) { scm_wrong_num_args (smob); } @@ -278,7 +278,10 @@ scm_smob_apply_3_021 (SCM smob, SCM a1, SCM a2, SCM rst) } static SCM -scm_smob_apply_3_error (SCM smob, SCM a1, SCM a2, SCM rst) +scm_smob_apply_3_error (SCM smob, + SCM a1 SCM_UNUSED, + SCM a2 SCM_UNUSED, + SCM rst SCM_UNUSED) { scm_wrong_num_args (smob); } @@ -512,7 +515,7 @@ scm_set_smob_mfpe (long tc, */ static int -free_print (SCM exp, SCM port, scm_print_state *pstate) +free_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { char buf[100]; diff --git a/libguile/stime.c b/libguile/stime.c index ac99a1587..f99656da4 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -325,7 +325,7 @@ setzone (SCM zone, int pos, const char *subr) } static void -restorezone (SCM zone, char **oldenv, const char *subr) +restorezone (SCM zone, char **oldenv, const char *subr SCM_UNUSED) { if (!SCM_UNBNDP (zone)) { diff --git a/libguile/strings.c b/libguile/strings.c index b87864973..a60c03ac1 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -192,7 +192,7 @@ scm_take0str (char *s) } SCM -scm_makfromstr (const char *src, size_t len, int dummy) +scm_makfromstr (const char *src, size_t len, int dummy SCM_UNUSED) { SCM s = scm_allocate_string (len); char *dst = SCM_STRING_CHARS (s); diff --git a/libguile/struct.c b/libguile/struct.c index b13a8c1c8..dc9b7d981 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -332,7 +332,8 @@ scm_alloc_struct (int n_words, int n_extra, char *who) } size_t -scm_struct_free_0 (scm_bits_t * vtable, scm_bits_t * data) +scm_struct_free_0 (scm_bits_t * vtable SCM_UNUSED, + scm_bits_t * data SCM_UNUSED) { return 0; } @@ -345,7 +346,7 @@ scm_struct_free_light (scm_bits_t * vtable, scm_bits_t * data) } size_t -scm_struct_free_standard (scm_bits_t * vtable, scm_bits_t * data) +scm_struct_free_standard (scm_bits_t * vtable SCM_UNUSED, scm_bits_t * data) { size_t n = (data[scm_struct_i_n_words] + scm_struct_n_extra_words) * sizeof (scm_bits_t) + 7; @@ -354,7 +355,7 @@ scm_struct_free_standard (scm_bits_t * vtable, scm_bits_t * data) } size_t -scm_struct_free_entity (scm_bits_t * vtable, scm_bits_t * data) +scm_struct_free_entity (scm_bits_t * vtable SCM_UNUSED, scm_bits_t * data) { size_t n = (data[scm_struct_i_n_words] + scm_struct_entity_n_extra_words) * sizeof (scm_bits_t) + 7; @@ -363,14 +364,18 @@ scm_struct_free_entity (scm_bits_t * vtable, scm_bits_t * data) } static void * -scm_struct_gc_init (void *dummy1, void *dummy2, void *dummy3) +scm_struct_gc_init (void *dummy1 SCM_UNUSED, + void *dummy2 SCM_UNUSED, + void *dummy3 SCM_UNUSED) { scm_structs_to_free = SCM_EOL; return 0; } static void * -scm_free_structs (void *dummy1, void *dummy2, void *dummy3) +scm_free_structs (void *dummy1 SCM_UNUSED, + void *dummy2 SCM_UNUSED, + void *dummy3 SCM_UNUSED) { SCM newchain = scm_structs_to_free; do diff --git a/libguile/symbols.c b/libguile/symbols.c index 83cddc0da..448c9d85f 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998, 2000, 2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001 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 diff --git a/libguile/throw.c b/libguile/throw.c index 63af28650..765924bf6 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -84,7 +84,7 @@ static scm_bits_t tc16_jmpbuffer; #endif static int -jmpbuffer_print (SCM exp, SCM port, scm_print_state *pstate) +jmpbuffer_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { scm_puts ("# + + * srfi-14.c (charset_print): Mark unused parameters with + SCM_UNUSED. + 2001-06-07 Martin Grabmueller * srfi-1.scm (fold, fold-pair): Fixed a buggy call to apply. @@ -5,7 +10,6 @@ retained, as required. (member, assoc): Fixed wrong order of equality predicate application. - 2001-06-06 Martin Grabmueller diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index 2cb7dc9e3..de9713bd9 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -1,6 +1,6 @@ /* srfi-14.c --- SRFI-14 procedures for Guile * - * Copyright (C) 2001 Free Software Foundation, Inc. + * Copyright (C) 2001 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 @@ -60,7 +60,7 @@ int scm_tc16_charset = 0; /* Smob print hook for character sets. */ static int -charset_print (SCM charset, SCM port, scm_print_state *pstate) +charset_print (SCM charset, SCM port, scm_print_state *pstate SCM_UNUSED) { int i; int first = 1; From dcb410ec079dcb20e6589461803fa99e3a3d8dd7 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 7 Jun 2001 23:10:33 +0000 Subject: [PATCH 1280/2047] * Fix SCM <--> scm_t_bits related typing problems. Thanks to Matthias Koeppe for the bug report. --- libguile/ChangeLog | 31 +++++++++ libguile/goops.c | 152 ++++++++++++++++++++++----------------------- libguile/goops.h | 2 + libguile/ramap.c | 3 - libguile/vectors.h | 14 ++--- libguile/weaks.c | 8 +-- 6 files changed, 119 insertions(+), 91 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index ef708e74e..557b9b808 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,34 @@ +2001-06-08 Dirk Herrmann + + * goops.c (SCM_CLASS_REDEF): Removed. + + * vectors.h (VECTORSH, SCM_VECTORS_H): Renamed H to + SCM__H. + + Thanks to Matthias Koeppe for reporting the bugs that correspond + to the following set of patches. + + * goops.c (scm_sys_prep_layout_x, scm_basic_basic_make_class, + create_basic_classes, scm_sys_fast_slot_set_x, set_slot_value, + scm_sys_allocate_instance, clear_method_cache, + scm_sys_invalidate_method_cache_x, scm_make, + create_standard_classes, scm_make_port_classes, scm_make_class, + scm_add_slot): Use SCM_SET_SLOT to set slot values. + + (prep_hashsets): Use SCM_SET_HASHSET to set class hash values. + + * goops.h (SCM_SET_SLOT, SCM_SET_HASHSET): New macros. + + * ramap.c (BINARY_ELTS_CODE, BINARY_PAIR_ELTS_CODE, + UNARY_ELTS_CODE): Remove bogus break statement. + + * vectors.h (SCM_BITVEC_REF, SCM_BITVEC_SET, SCM_BITVEC_CLR): + Don't access bit vectors elements as SCM objects. + + * weaks.c (scm_make_weak_vector, scm_make_weak_key_hash_table, + scm_make_weak_value_hash_table, scm_make_doubly_weak_hash_table): + Don't assign to an unpacked value. + 2001-06-07 Dirk Herrmann * __scm.h (SCM_NORETURN): Moved here from error.h. diff --git a/libguile/goops.c b/libguile/goops.c index 4ea756a10..b38acf89b 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -111,7 +111,6 @@ h1. */ -#define SCM_CLASS_REDEF(c) SCM_SLOT (c, scm_si_redefined) /* The following definition is located in libguile/objects.h: #define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined]) */ @@ -168,7 +167,7 @@ static SCM scm_sys_goops_loaded (void); * Compute-cpl * * This version doesn't handle multiple-inheritance. It serves only for - * booting classes and will be overaloaded in Scheme + * booting classes and will be overloaded in Scheme * ******************************************************************************/ @@ -302,7 +301,7 @@ SCM_DEFINE (scm_sys_compute_slots, "%compute-slots", 1, 0, 0, * compute-getters-n-setters * * This version doesn't handle slot options. It serves only for booting - * classes and will be overaloaded in Scheme. + * classes and will be overloaded in Scheme. * ******************************************************************************/ @@ -528,7 +527,7 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0, s[i + 1] = a; slots = SCM_CDR (slots); } - SCM_SLOT (class, scm_si_layout) = scm_mem2symbol (s, n); + SCM_SET_SLOT (class, scm_si_layout, scm_mem2symbol (s, n)); if (s) scm_must_free (s); return SCM_UNSPECIFIED; @@ -589,11 +588,10 @@ SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0, void prep_hashsets (SCM class) { - int i; + unsigned int i; for (i = 0; i < 7; ++i) - SCM_SLOT (class, scm_si_hashsets + i) - = SCM_PACK (scm_c_uniform32 (goops_rstate)); + SCM_SET_HASHSET (class, i, scm_c_uniform32 (goops_rstate)); } /******************************************************************************/ @@ -610,30 +608,31 @@ scm_basic_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots) #if 0 cpl = compute_cpl (dsupers, SCM_LIST1(z)); #endif - SCM_SLOT (z, scm_si_direct_supers) = dsupers; + SCM_SET_SLOT (z, scm_si_direct_supers, dsupers); cpl = compute_cpl (z); slots = build_slots_list (maplist (dslots), cpl); nfields = SCM_MAKINUM (scm_ilength (slots)); g_n_s = compute_getters_n_setters (slots); - SCM_SLOT(z, scm_si_name) = name; - SCM_SLOT(z, scm_si_direct_slots) = dslots; - SCM_SLOT(z, scm_si_direct_subclasses) = SCM_EOL; - SCM_SLOT(z, scm_si_direct_methods) = SCM_EOL; - SCM_SLOT(z, scm_si_cpl) = cpl; - SCM_SLOT(z, scm_si_slots) = slots; - SCM_SLOT(z, scm_si_nfields) = nfields; - SCM_SLOT(z, scm_si_getters_n_setters) = g_n_s; - SCM_SLOT(z, scm_si_redefined) = SCM_BOOL_F; - SCM_SLOT(z, scm_si_environment) - = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE); + SCM_SET_SLOT (z, scm_si_name, name); + SCM_SET_SLOT (z, scm_si_direct_slots, dslots); + SCM_SET_SLOT (z, scm_si_direct_subclasses, SCM_EOL); + SCM_SET_SLOT (z, scm_si_direct_methods, SCM_EOL); + SCM_SET_SLOT (z, scm_si_cpl, cpl); + SCM_SET_SLOT (z, scm_si_slots, slots); + SCM_SET_SLOT (z, scm_si_nfields, nfields); + SCM_SET_SLOT (z, scm_si_getters_n_setters, g_n_s); + SCM_SET_SLOT (z, scm_si_redefined, SCM_BOOL_F); + SCM_SET_SLOT (z, scm_si_environment, + scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE)); /* Add this class in the direct-subclasses slot of dsupers */ { SCM tmp; - for (tmp = dsupers; SCM_NNULLP(tmp); tmp = SCM_CDR(tmp)) - SCM_SLOT(SCM_CAR(tmp), scm_si_direct_subclasses) - = scm_cons(z, SCM_SLOT(SCM_CAR(tmp), scm_si_direct_subclasses)); + for (tmp = dsupers; !SCM_NULLP (tmp); tmp = SCM_CDR (tmp)) + SCM_SET_SLOT (SCM_CAR (tmp), scm_si_direct_subclasses, + scm_cons (z, SCM_SLOT (SCM_CAR (tmp), + scm_si_direct_subclasses))); } /* Support for the underlying structs: */ @@ -733,19 +732,19 @@ create_basic_classes (void) SCM_SET_CLASS_FLAGS (scm_class_class, (SCM_CLASSF_GOOPS_OR_VALID | SCM_CLASSF_METACLASS)); - SCM_SLOT(scm_class_class, scm_si_name) = name; - SCM_SLOT(scm_class_class, scm_si_direct_supers) = SCM_EOL; /* will be changed */ - /* SCM_SLOT(scm_class_class, scm_si_direct_slots) = slots_of_class; */ - SCM_SLOT(scm_class_class, scm_si_direct_subclasses)= SCM_EOL; - SCM_SLOT(scm_class_class, scm_si_direct_methods) = SCM_EOL; - SCM_SLOT(scm_class_class, scm_si_cpl) = SCM_EOL; /* will be changed */ - /* SCM_SLOT(scm_class_class, scm_si_slots) = slots_of_class; */ - SCM_SLOT(scm_class_class, scm_si_nfields) = SCM_MAKINUM (SCM_N_CLASS_SLOTS); - /* SCM_SLOT(scm_class_class, scm_si_getters_n_setters) - = compute_getters_n_setters (slots_of_class); */ - SCM_SLOT(scm_class_class, scm_si_redefined) = SCM_BOOL_F; - SCM_SLOT(scm_class_class, scm_si_environment) - = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE); + SCM_SET_SLOT (scm_class_class, scm_si_name, name); + SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, SCM_EOL); /* will be changed */ + /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */ + SCM_SET_SLOT (scm_class_class, scm_si_direct_subclasses, SCM_EOL); + SCM_SET_SLOT (scm_class_class, scm_si_direct_methods, SCM_EOL); + SCM_SET_SLOT (scm_class_class, scm_si_cpl, SCM_EOL); /* will be changed */ + /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */ + SCM_SET_SLOT (scm_class_class, scm_si_nfields, SCM_MAKINUM (SCM_N_CLASS_SLOTS)); + /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters, + compute_getters_n_setters (slots_of_class)); */ + SCM_SET_SLOT (scm_class_class, scm_si_redefined, SCM_BOOL_F); + SCM_SET_SLOT (scm_class_class, scm_si_environment, + scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE)); prep_hashsets (scm_class_class); @@ -770,10 +769,10 @@ create_basic_classes (void) DEFVAR (name, scm_class_object); /* and were partially initialized. Correct them here */ - SCM_SLOT (scm_class_object, scm_si_direct_subclasses) = SCM_LIST1 (scm_class_class); + SCM_SET_SLOT (scm_class_object, scm_si_direct_subclasses, SCM_LIST1 (scm_class_class)); - SCM_SLOT (scm_class_class, scm_si_direct_supers) = SCM_LIST1 (scm_class_object); - SCM_SLOT (scm_class_class, scm_si_cpl) = SCM_LIST3 (scm_class_class, scm_class_object, scm_class_top); + SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, SCM_LIST1 (scm_class_object)); + SCM_SET_SLOT (scm_class_class, scm_si_cpl, SCM_LIST3 (scm_class_class, scm_class_object, scm_class_top)); } /******************************************************************************/ @@ -1021,7 +1020,7 @@ SCM_DEFINE (scm_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0, SCM_VALIDATE_INUM (2, index); i = SCM_INUM (index); SCM_ASSERT_RANGE (2, index, i >= 0 && i < SCM_NUMBER_OF_SLOTS (obj)); - SCM_SLOT (obj, i) = value; + SCM_SET_SLOT (obj, i, value); return SCM_UNSPECIFIED; } @@ -1092,7 +1091,7 @@ set_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef, SCM value) * - otherwise (cadr access) is the setter function to apply */ if (SCM_INUMP (access)) - SCM_SLOT (obj, SCM_INUM (access)) = value; + SCM_SET_SLOT (obj, SCM_INUM (access), value); else { /* We must evaluate (apply (cadr l) (list obj value)) @@ -1349,9 +1348,9 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0, /* allocate class object */ SCM z = scm_make_struct (class, SCM_INUM0, SCM_EOL); - SCM_SLOT (z, scm_si_print) = SCM_GOOPS_UNBOUND; + SCM_SET_SLOT (z, scm_si_print, SCM_GOOPS_UNBOUND); for (i = scm_si_goops_fields; i < n; i++) - SCM_SLOT (z, i) = SCM_GOOPS_UNBOUND; + SCM_SET_SLOT (z, i, SCM_GOOPS_UNBOUND); if (SCM_SUBCLASSP (class, scm_class_entity_class)) SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY); @@ -1564,7 +1563,7 @@ clear_method_cache (SCM gf) { SCM cache = scm_make_method_cache (gf); SCM_SET_ENTITY_PROCEDURE (gf, cache); - SCM_SLOT (gf, scm_si_used_by) = SCM_BOOL_F; + SCM_SET_SLOT (gf, scm_si_used_by, SCM_BOOL_F); } SCM_DEFINE (scm_sys_invalidate_method_cache_x, "%invalidate-method-cache!", 1, 0, 0, @@ -1582,7 +1581,7 @@ SCM_DEFINE (scm_sys_invalidate_method_cache_x, "%invalidate-method-cache!", 1, 0 scm_sys_invalidate_method_cache_x (SCM_CAR (used_by)); clear_method_cache (gf); for (; SCM_CONSP (methods); methods = SCM_CDR (methods)) - SCM_SLOT (SCM_CAR (methods), scm_si_code_table) = SCM_EOL; + SCM_SET_SLOT (SCM_CAR (methods), scm_si_code_table, SCM_EOL); } { SCM n = SCM_SLOT (gf, scm_si_n_specialized); @@ -1692,7 +1691,7 @@ more_specificp (SCM m1, SCM m2, SCM *targs) if (SCM_CAR(s1) != SCM_CAR(s2)) { register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2); - for (l = SCM_SLOT(targs[i], scm_si_cpl); ; l = SCM_CDR(l)) { + for (l = SCM_SLOT (targs[i], scm_si_cpl); ; l = SCM_CDR(l)) { if (cs1 == SCM_CAR(l)) return 1; if (cs2 == SCM_CAR(l)) @@ -2032,47 +2031,47 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1, || class == scm_class_simple_method || class == scm_class_accessor) { - SCM_SLOT (z, scm_si_generic_function) = + SCM_SET_SLOT (z, scm_si_generic_function, scm_i_get_keyword (k_gf, args, len - 1, SCM_BOOL_F, - FUNC_NAME); - SCM_SLOT (z, scm_si_specializers) = + FUNC_NAME)); + SCM_SET_SLOT (z, scm_si_specializers, scm_i_get_keyword (k_specializers, args, len - 1, SCM_EOL, - FUNC_NAME); - SCM_SLOT (z, scm_si_procedure) = + FUNC_NAME)); + SCM_SET_SLOT (z, scm_si_procedure, scm_i_get_keyword (k_procedure, args, len - 1, SCM_EOL, - FUNC_NAME); - SCM_SLOT (z, scm_si_code_table) = SCM_EOL; + FUNC_NAME)); + SCM_SET_SLOT (z, scm_si_code_table, SCM_EOL); } else { /* In all the others case, make a new class .... No instance here */ - SCM_SLOT (z, scm_si_name) = + SCM_SET_SLOT (z, scm_si_name, scm_i_get_keyword (k_name, args, len - 1, scm_str2symbol ("???"), - FUNC_NAME); - SCM_SLOT (z, scm_si_direct_supers) = + FUNC_NAME)); + SCM_SET_SLOT (z, scm_si_direct_supers, scm_i_get_keyword (k_dsupers, args, len - 1, SCM_EOL, - FUNC_NAME); - SCM_SLOT (z, scm_si_direct_slots) = + FUNC_NAME)); + SCM_SET_SLOT (z, scm_si_direct_slots, scm_i_get_keyword (k_slots, args, len - 1, SCM_EOL, - FUNC_NAME); + FUNC_NAME)); } } return z; @@ -2210,10 +2209,10 @@ create_standard_classes (void) /* Continue initialization of class */ slots = build_class_class_slots (); - SCM_SLOT (scm_class_class, scm_si_direct_slots) = slots; - SCM_SLOT (scm_class_class, scm_si_slots) = slots; - SCM_SLOT (scm_class_class, scm_si_getters_n_setters) - = compute_getters_n_setters (slots); + SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots); + SCM_SET_SLOT (scm_class_class, scm_si_slots, slots); + SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters, + compute_getters_n_setters (slots)); make_stdcls (&scm_class_foreign_class, "", scm_class_class, scm_class_class, @@ -2258,12 +2257,12 @@ create_standard_classes (void) SCM_EOL); #if 0 /* Patch cpl since compute_cpl doesn't support multiple inheritance. */ - SCM_SLOT (scm_class_generic_with_setter, scm_si_cpl) = + SCM_SET_SLOT (scm_class_generic_with_setter, scm_si_cpl, scm_append (SCM_LIST3 (SCM_LIST2 (scm_class_generic_with_setter, scm_class_generic), SCM_SLOT (scm_class_entity_with_setter, scm_si_cpl), - SCM_EOL)); + SCM_EOL))); #endif SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter, SCM_CLASSF_PURE_GENERIC); @@ -2395,8 +2394,8 @@ scm_make_port_classes (long ptobnum, char *type_name) SCM_LIST2 (class, scm_class_input_output_port)); /* Patch cpl (since this tree is too complex for the C level compute-cpl) */ - SCM_SLOT (c, scm_si_cpl) - = scm_cons2 (c, class, SCM_SLOT (scm_class_input_output_port, scm_si_cpl)); + SCM_SET_SLOT (c, scm_si_cpl, + scm_cons2 (c, class, SCM_SLOT (scm_class_input_output_port, scm_si_cpl))); } static void @@ -2478,7 +2477,7 @@ scm_make_class (SCM meta, char *s_name, SCM supers, size_t size, if (destructor != 0) { - SCM_SLOT (class, scm_si_destructor) = (SCM) destructor; + SCM_SET_SLOT (class, scm_si_destructor, (SCM) destructor); SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object); } else if (size > 0) @@ -2487,8 +2486,8 @@ scm_make_class (SCM meta, char *s_name, SCM supers, size_t size, SCM_SET_CLASS_INSTANCE_SIZE (class, size); } - SCM_SLOT (class, scm_si_layout) = scm_str2symbol (""); - SCM_SLOT (class, scm_si_constructor) = (SCM) constructor; + SCM_SET_SLOT (class, scm_si_layout, scm_str2symbol ("")); + SCM_SET_SLOT (class, scm_si_constructor, (SCM) constructor); return class; } @@ -2544,19 +2543,18 @@ scm_add_slot (SCM class, char *slot_name, SCM slot_class, k_procedure, setm))); DEFVAR (aname, gf); - SCM_SLOT (class, scm_si_slots) - = scm_append_x (SCM_LIST2 (SCM_SLOT (class, scm_si_slots), - SCM_LIST1 (slot))); - SCM_SLOT (class, scm_si_getters_n_setters) - = scm_append_x (SCM_LIST2 (SCM_SLOT (class, scm_si_getters_n_setters), - SCM_LIST1 (gns))); + SCM_SET_SLOT (class, scm_si_slots, + scm_append_x (SCM_LIST2 (SCM_SLOT (class, scm_si_slots), + SCM_LIST1 (slot)))); + SCM_SET_SLOT (class, scm_si_getters_n_setters, + scm_append_x (SCM_LIST2 (SCM_SLOT (class, scm_si_getters_n_setters), + SCM_LIST1 (gns)))); } } { long n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); - SCM_SLOT (class, scm_si_nfields) - = SCM_MAKINUM (n + 1); + SCM_SET_SLOT (class, scm_si_nfields, SCM_MAKINUM (n + 1)); } } diff --git a/libguile/goops.h b/libguile/goops.h index 5aefcfe6d..607df5a50 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -141,6 +141,8 @@ typedef struct scm_method_t { | SCM_CLASSF_SIMPLE_METHOD)) #define SCM_SLOT(x, i) (SCM_PACK (SCM_INST (x) [i])) +#define SCM_SET_SLOT(x, i, v) (SCM_INST (x) [i] = SCM_UNPACK (v)) +#define SCM_SET_HASHSET(c, i, h) (SCM_INST (c) [scm_si_hashsets + (i)] = (h)) #define SCM_SUBCLASSP(c1, c2) (!SCM_FALSEP (scm_c_memq (c2, SCM_SLOT (c1, scm_si_cpl)))) #define SCM_IS_A_P(x, c) (SCM_NIMP (x) \ && SCM_INSTANCEP (x) \ diff --git a/libguile/ramap.c b/libguile/ramap.c index 4c169753b..0db574edf 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -129,7 +129,6 @@ do { type *v0 = (type*)SCM_VELTS (ra0);\ IVDEP (ra0 != ra1, \ for (; n-- > 0; i0 += inc0, i1 += inc1) \ v0[i0] OPERATOR v1[i1];) \ - break; \ } while (0) /* This macro is used for all but binary division and @@ -143,14 +142,12 @@ do { type (*v0)[2] = (type (*)[2]) SCM_VELTS (ra0);\ v0[i0][0] OPERATOR v1[i1][0]; \ v0[i0][1] OPERATOR v1[i1][1]; \ }) \ - break; \ } while (0) #define UNARY_ELTS_CODE(OPERATOR, type) \ do { type *v0 = (type *) SCM_VELTS (ra0);\ for (; n-- > 0; i0 += inc0) \ v0[i0] OPERATOR v0[i0];\ - break;\ } while (0) diff --git a/libguile/vectors.h b/libguile/vectors.h index 77d6131bf..0f1456853 100644 --- a/libguile/vectors.h +++ b/libguile/vectors.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef VECTORSH -#define VECTORSH -/* Copyright (C) 1995, 1996, 1998, 2000 Free Software Foundation, Inc. +#ifndef SCM_VECTORS_H +#define SCM_VECTORS_H +/* Copyright (C) 1995,1996,1998,2000,2001 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 @@ -67,9 +67,9 @@ /* bit vectors */ -#define SCM_BITVEC_REF(a, i) ((SCM_UNPACK(SCM_VELTS(a)[(i)/SCM_LONG_BIT]) & (1L<<((i)%SCM_LONG_BIT))) ? 1 : 0) -#define SCM_BITVEC_SET(a, i) SCM_UNPACK(SCM_VELTS(a)[(i)/SCM_LONG_BIT]) |= (1L<<((i)%SCM_LONG_BIT)) -#define SCM_BITVEC_CLR(a, i) SCM_UNPACK(SCM_VELTS(a)[(i)/SCM_LONG_BIT]) &= ~(1L<<((i)%SCM_LONG_BIT)) +#define SCM_BITVEC_REF(a, i) ((SCM_VECTOR_BASE (a) [(i) / SCM_LONG_BIT] & (1L << ((i) % SCM_LONG_BIT))) ? 1 : 0) +#define SCM_BITVEC_SET(a, i) SCM_VECTOR_BASE (a) [(i) / SCM_LONG_BIT] |= (1L << ((i) % SCM_LONG_BIT)) +#define SCM_BITVEC_CLR(a, i) SCM_VECTOR_BASE (a) [(i) / SCM_LONG_BIT] &= ~(1L << ((i) % SCM_LONG_BIT)) @@ -99,7 +99,7 @@ extern SCM scm_vector_set_length_x (SCM vect, SCM len); #endif /* SCM_DEBUG_DEPRECATED == 0 */ -#endif /* VECTORSH */ +#endif /* SCM_VECTORS_H */ /* Local Variables: diff --git a/libguile/weaks.c b/libguile/weaks.c index 144f32cb9..6180f1bc5 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -70,7 +70,7 @@ SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0, SCM_SET_VECTOR_LENGTH (v, SCM_INUM (size), scm_tc7_wvect); SCM_SETVELTS(v, SCM_VELTS(v) + 2); SCM_VELTS(v)[-2] = SCM_EOL; - SCM_UNPACK (SCM_VELTS (v)[-1]) = 0; + SCM_VECTOR_BASE (v) [-1] = 0; SCM_ALLOW_INTS; return v; } @@ -142,7 +142,7 @@ SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 1, 0, 0, SCM_VALIDATE_INUM (1, size); v = scm_make_weak_vector (size, SCM_EOL); SCM_DEFER_INTS; - SCM_UNPACK (SCM_VELTS (v)[-1]) = 1; + SCM_VECTOR_BASE (v) [-1] = 1; SCM_ALLOW_INTS; return v; } @@ -159,7 +159,7 @@ SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 1, 0, SCM_VALIDATE_INUM (1, size); v = scm_make_weak_vector (size, SCM_EOL); SCM_DEFER_INTS; - SCM_UNPACK (SCM_VELTS (v)[-1]) = 2; + SCM_VECTOR_BASE (v) [-1] = 2; SCM_ALLOW_INTS; return v; } @@ -177,7 +177,7 @@ SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0 SCM_VALIDATE_INUM (1, size); v = scm_make_weak_vector (size, SCM_EOL); SCM_DEFER_INTS; - SCM_UNPACK (SCM_VELTS (v)[-1]) = 3; + SCM_VECTOR_BASE (v) [-1] = 3; SCM_ALLOW_INTS; return v; } From bab246f3345d6fa97ccd698ad66ada18abede481 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 8 Jun 2001 10:02:33 +0000 Subject: [PATCH 1281/2047] * Fixed some bugs, some reported by Matthias Koeppe. --- libguile/ChangeLog | 20 ++++++++++++++++++++ libguile/keywords.c | 7 +++++-- libguile/objects.c | 5 +++-- libguile/pairs.c | 11 +++++++++-- libguile/unif.c | 6 +++--- libguile/unif.h | 2 +- libguile/vectors.h | 6 +++--- 7 files changed, 44 insertions(+), 13 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 557b9b808..5eb22ccd8 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,23 @@ +2001-06-08 Dirk Herrmann + + * keywords.c (keyword_print): Don't use SCM_C[AD]R to access + keywords. Fix gc protection. + + * objects.c (scm_mcache_lookup_cmethod): Don't use side effecting + operations in macro calls. + + * pairs.c (scm_error_pair_access): Avoid recursion. + + Thanks to Matthias Koeppe for reporting the bugs that correspond + to the following set of patches. + + * unif.c (scm_bit_set_star_x, scm_bit_invert_x), vectors.h + (SCM_BITVEC_REF, SCM_BITVEC_SET, SCM_BITVEC_CLR): Obtain the + bitvector base address using SCM_BITVECTOR_BASE. + + * unif.h (SCM_BITVECTOR_BASE): Return the base address as an + unsigned long*. + 2001-06-08 Dirk Herrmann * goops.c (SCM_CLASS_REDEF): Removed. diff --git a/libguile/keywords.c b/libguile/keywords.c index cea7ac526..36e0ce26e 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -61,10 +61,13 @@ scm_bits_t scm_tc16_keyword; static int keyword_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { + SCM symbol = SCM_KEYWORDSYM (exp); + scm_puts ("#:", port); - scm_print_symbol_name (SCM_SYMBOL_CHARS (SCM_CDR (exp)) + 1, - SCM_SYMBOL_LENGTH (SCM_CDR (exp)) - 1, + scm_print_symbol_name (SCM_SYMBOL_CHARS (symbol) + 1, + SCM_SYMBOL_LENGTH (symbol) - 1, port); + scm_remember_upto_here_1 (symbol); return 1; } diff --git a/libguile/objects.c b/libguile/objects.c index 4cec90ba2..a8ece94a3 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1999,2000,2001 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 @@ -268,7 +268,8 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args) /* Compute a hash value */ long hashset = SCM_INUM (methods); long j = n; - mask = SCM_INUM (SCM_CAR (z = SCM_CDDR (z))); + z = SCM_CDDR (z); + mask = SCM_INUM (SCM_CAR (z)); methods = SCM_CADR (z); i = 0; ls = args; diff --git a/libguile/pairs.c b/libguile/pairs.c index 48db366b3..24d1aec07 100644 --- a/libguile/pairs.c +++ b/libguile/pairs.c @@ -61,9 +61,16 @@ void scm_error_pair_access (SCM non_pair) { + static unsigned int running = 0; SCM message = scm_makfrom0str ("Non-pair accessed with SCM_C[AD]R: `~S´\n"); - scm_simple_format (scm_current_error_port (), message, SCM_LIST1 (non_pair)); - abort (); + + if (!running) + { + running = 1; + scm_simple_format (scm_current_error_port (), + message, SCM_LIST1 (non_pair)); + abort (); + } } #endif diff --git a/libguile/unif.c b/libguile/unif.c index 5e0a801df..e1f1bd017 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1924,10 +1924,10 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME); if (SCM_FALSEP (obj)) for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) - SCM_UNPACK (SCM_VELTS (v)[k]) &= ~ SCM_UNPACK(SCM_VELTS (kv)[k]); + SCM_BITVECTOR_BASE (v) [k] &= ~SCM_BITVECTOR_BASE (kv) [k]; else if (SCM_EQ_P (obj, SCM_BOOL_T)) for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) - SCM_UNPACK (SCM_VELTS (v)[k]) |= SCM_UNPACK (SCM_VELTS (kv)[k]); + SCM_BITVECTOR_BASE (v) [k] |= SCM_BITVECTOR_BASE (kv) [k]; else goto badarg3; break; @@ -2016,7 +2016,7 @@ SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0, k = SCM_BITVECTOR_LENGTH (v); for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) - SCM_UNPACK (SCM_VELTS (v)[k]) = ~SCM_UNPACK (SCM_VELTS (v)[k]); + SCM_BITVECTOR_BASE (v) [k] = ~SCM_BITVECTOR_BASE (v) [k]; return SCM_UNSPECIFIED; } diff --git a/libguile/unif.h b/libguile/unif.h index 1a7b1b46f..867c04427 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -109,7 +109,7 @@ extern scm_bits_t scm_tc16_array; #define SCM_SET_UVECTOR_LENGTH(v, l, t) (SCM_SET_CELL_WORD_0 ((v), ((l) << 8) + (t))) #define SCM_BITVECTOR_P(x) (!SCM_IMP (x) && (SCM_TYP7 (x) == scm_tc7_bvect)) -#define SCM_BITVECTOR_BASE(x) ((void *) (SCM_CELL_WORD_1 (x))) +#define SCM_BITVECTOR_BASE(x) ((unsigned long *) (SCM_CELL_WORD_1 (x))) #define SCM_SET_BITVECTOR_BASE(v, b) (SCM_SET_CELL_WORD_1 ((v), (b))) #define SCM_BITVECTOR_MAX_LENGTH SCM_I_MAX_LENGTH #define SCM_BITVECTOR_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) diff --git a/libguile/vectors.h b/libguile/vectors.h index 0f1456853..7a788f00b 100644 --- a/libguile/vectors.h +++ b/libguile/vectors.h @@ -67,9 +67,9 @@ /* bit vectors */ -#define SCM_BITVEC_REF(a, i) ((SCM_VECTOR_BASE (a) [(i) / SCM_LONG_BIT] & (1L << ((i) % SCM_LONG_BIT))) ? 1 : 0) -#define SCM_BITVEC_SET(a, i) SCM_VECTOR_BASE (a) [(i) / SCM_LONG_BIT] |= (1L << ((i) % SCM_LONG_BIT)) -#define SCM_BITVEC_CLR(a, i) SCM_VECTOR_BASE (a) [(i) / SCM_LONG_BIT] &= ~(1L << ((i) % SCM_LONG_BIT)) +#define SCM_BITVEC_REF(a, i) ((SCM_BITVECTOR_BASE (a) [(i) / SCM_LONG_BIT] & (1L << ((i) % SCM_LONG_BIT))) ? 1 : 0) +#define SCM_BITVEC_SET(a, i) SCM_BITVECTOR_BASE (a) [(i) / SCM_LONG_BIT] |= (1L << ((i) % SCM_LONG_BIT)) +#define SCM_BITVEC_CLR(a, i) SCM_BITVECTOR_BASE (a) [(i) / SCM_LONG_BIT] &= ~(1L << ((i) % SCM_LONG_BIT)) From 47bcd6465f75719bbed6ae4520dda2e7480b77ed Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Fri, 8 Jun 2001 13:48:39 +0000 Subject: [PATCH 1282/2047] =?UTF-8?q?*=20filter-doc-snarfage.c,=20guile-sn?= =?UTF-8?q?arf.in:=20try=20to=20cope=20with=20spaces=20inside=20cookies.?= =?UTF-8?q?=20=20thanks=20to=20Matthias=20K=C3=B6ppe!?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- libguile/ChangeLog | 10 +++++++--- libguile/filter-doc-snarfage.c | 5 +++-- libguile/guile-snarf.in | 2 +- 3 files changed, 11 insertions(+), 6 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 5eb22ccd8..3f48f61f6 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-06-08 Michael Livshin + + * filter-doc-snarfage.c, guile-snarf.in: try to cope with spaces + inside cookies. thanks to Matthias Köppe! + 2001-06-08 Dirk Herrmann * keywords.c (keyword_print): Don't use SCM_C[AD]R to access @@ -200,9 +205,8 @@ * snarf.h: make the output both texttools- and `read'-friendly. - * guile-doc-snarf.in (bindir): reimplement in terms of guile-snarf - and guile-snarf-docs. (should also deprecate, I guess. maybe - not). + * guile-doc-snarf.in: reimplement in terms of guile-snarf and + guile-snarf-docs. (should also deprecate, I guess. maybe not). 2001-05-31 Marius Vollmer diff --git a/libguile/filter-doc-snarfage.c b/libguile/filter-doc-snarfage.c index c403b0ebf..f1d2fd14e 100644 --- a/libguile/filter-doc-snarfage.c +++ b/libguile/filter-doc-snarfage.c @@ -55,7 +55,7 @@ process () want_cookie = 0; } else want_cookie = 1; - } else + } else if (c != ' ') want_cookie = 0; break; case SKIP_COOKIE: @@ -82,7 +82,8 @@ process () } else want_cookie = 1; } else { - want_cookie = 0; + if (c != ' ') + want_cookie = 0; putc (c, stdout); } break; diff --git a/libguile/guile-snarf.in b/libguile/guile-snarf.in index 41542dcfc..ffb035146 100644 --- a/libguile/guile-snarf.in +++ b/libguile/guile-snarf.in @@ -27,7 +27,7 @@ test -n "${CPP+set}" || CPP="@CPP@" ## We must use a temporary file here, instead of a pipe, because we ## need to know if CPP exits with a non-zero status. ${CPP} -DSCM_MAGIC_SNARF_INITS "$@" > ${temp} || exit $? -< ${temp} grep "^ *\^\^" | sed -e "s/^ *\^\^//" +< ${temp} grep "^ *\^ *\^" | sed -e "s/^ *\^ *\^//" ## Apparently, AIX's preprocessor is unhappy if you try to #include an ## empty file. From a88ff5b650bc251848ca12d2daff2d642d6375c0 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Fri, 8 Jun 2001 14:49:05 +0000 Subject: [PATCH 1283/2047] * snarf.h, filter-doc-snarfage.c: more changes to cope with space-happy C preprocessors. --- libguile/ChangeLog | 3 +++ libguile/filter-doc-snarfage.c | 15 +++++++++++++-- libguile/snarf.h | 10 +++++----- 3 files changed, 21 insertions(+), 7 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 3f48f61f6..ad4a3e871 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,8 @@ 2001-06-08 Michael Livshin + * snarf.h, filter-doc-snarfage.c: more changes to cope with + space-happy C preprocessors. + * filter-doc-snarfage.c, guile-snarf.in: try to cope with spaces inside cookies. thanks to Matthias Köppe! diff --git a/libguile/filter-doc-snarfage.c b/libguile/filter-doc-snarfage.c index f1d2fd14e..54ebc3c6e 100644 --- a/libguile/filter-doc-snarfage.c +++ b/libguile/filter-doc-snarfage.c @@ -23,6 +23,7 @@ typedef enum state_t SKIP, SKIP_COOKIE, + MULTILINE_BEGINNING_OF_LINE, MULTILINE, MULTILINE_COOKIE, @@ -68,11 +69,19 @@ process () fputs ("(doc-block (\n", stdout); state = MULTILINE; break; + case ' ': + break; default: die ("bad snarf cookie"); break; } break; + case MULTILINE_BEGINNING_OF_LINE: + if (c != ' ') { + state = MULTILINE; + putc (c, stdout); + } + break; case MULTILINE: if (c == '^') { if (want_cookie) { @@ -92,13 +101,15 @@ process () case '(': state = STRINGS; break; - case ' ': - state = MULTILINE; + case '%': + state = MULTILINE_BEGINNING_OF_LINE; break; case '}': fputs ("))\n", stdout); state = SKIP; break; + case ' ': + break; default: die ("bad snarf cookie in multiline context"); break; diff --git a/libguile/snarf.h b/libguile/snarf.h index 045e63441..04c2a3022 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -86,11 +86,11 @@ # define SCM_SNARF_INIT(X) # define SCM_SNARF_DOCS(TYPE, FNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING) \ ^^{ \ -^^ fname . FNAME \ -^^ type . TYPE \ -^^ location __FILE__ . __LINE__ \ -^^ arglist . ARGLIST \ -^^ argsig REQ OPT VAR \ +^^%fname . FNAME \ +^^%type . TYPE \ +^^%location __FILE__ . __LINE__ \ +^^%arglist . ARGLIST \ +^^%argsig REQ OPT VAR \ ^^(DOCSTRING) \ ^^} # else From 12e5078cbbd242bb22fc9f723de3e7e769558635 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 8 Jun 2001 22:35:30 +0000 Subject: [PATCH 1284/2047] * Fix rogue text caused by line breaking a comment. --- doc/data-rep.texi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/data-rep.texi b/doc/data-rep.texi index 0a4ad15fa..351d7fb31 100644 --- a/doc/data-rep.texi +++ b/doc/data-rep.texi @@ -10,7 +10,7 @@ @c essay @dircategory The Algorithmic Language Scheme @c essay @direntry @c essay * data-rep: (data-rep). Data Representation in Guile --- how to use - Guile objects in your C code. +@c essay Guile objects in your C code. @c essay @end direntry @c essay @setchapternewpage off @@ -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.25 2001-05-30 20:32:05 mgrabmue Exp $ +@c essay @subtitle $Id: data-rep.texi,v 1.26 2001-06-08 22:35:30 ossau Exp $ @c essay @subtitle For use with Guile @value{VERSION} @c essay @author Jim Blandy @c essay @author Free Software Foundation From 0a892a2cbd9342af0afd4a7bfca6111c2ee0a0f9 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 9 Jun 2001 18:12:14 +0000 Subject: [PATCH 1285/2047] Added paragraph about new `export' behaviour and new `re-export' statement. --- NEWS | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/NEWS b/NEWS index d7d863e9b..9eb5928d7 100644 --- a/NEWS +++ b/NEWS @@ -339,6 +339,13 @@ work on the top level. The forms `define-public' and behave just like `define' and `defmacro', respectively, when they are used in a lexical environment. +Also, `export' will no longer silently re-export bindings imported +from a used module. It will emit a `deprecation' warning and will +cease to perform any re-export in the next version. If you actually +want to re-export bindings, use the new `re-export' in place of +`export'. The new `re-export' will not make copies of variables when +rexporting them, as `export' did wrongly. + ** The semantics of guardians have changed. The changes are for the most part compatible. An important criterion From 269ce4390e3b3bdc94c2dbd0965328545356164f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 9 Jun 2001 18:14:08 +0000 Subject: [PATCH 1286/2047] (generic-write): Use `object->string' to print unknown objects. --- ice-9/pretty-print.scm | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/ice-9/pretty-print.scm b/ice-9/pretty-print.scm index 187a7abdb..2eac93e94 100644 --- a/ice-9/pretty-print.scm +++ b/ice-9/pretty-print.scm @@ -124,10 +124,7 @@ ((#\newline) "newline") (else (make-string 1 obj))) (out "#\\" col)))) - ((input-port? obj) (out "#[input-port]" col)) - ((output-port? obj) (out "#[output-port]" col)) - ((eof-object? obj) (out "#[eof-object]" col)) - (else (out "#[unknown]" col)))) + (else (out (object->string obj) col)))) (define (pp obj col) From 1987c8ee57098ade2de19facb30f5b4aa55a0fde Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 9 Jun 2001 18:14:22 +0000 Subject: [PATCH 1287/2047] =?UTF-8?q?(lambda*):=20Make=20sure=20that=20BOD?= =?UTF-8?q?Y=20is=20always=20put=20into=20a=20real=20body=20context=20so?= =?UTF-8?q?=20that=20it=20can=20contain=20internal=20definitions.=20Thanks?= =?UTF-8?q?=20to=20Matthias=20K=C3=B6ppe!?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- ice-9/optargs.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ice-9/optargs.scm b/ice-9/optargs.scm index 2ee0411ac..fd4db654b 100644 --- a/ice-9/optargs.scm +++ b/ice-9/optargs.scm @@ -294,7 +294,8 @@ `((if (not (null? ,rest-gensym)) (error "Too many arguments."))) '()) - ,@BODY))) + (let () + ,@BODY)))) `(lambda (,@non-optional-args . ,(if rest-arg rest-arg '())) ,@BODY)))))) From 3cc34e16beaf2239d9eda892e0cf631b619712a2 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 9 Jun 2001 18:14:36 +0000 Subject: [PATCH 1288/2047] =?UTF-8?q?Use=20(ice-9=20and-let-star).=20(form?= =?UTF-8?q?at:out):=20Initialize=20format:output-col=20with=20current=20co?= =?UTF-8?q?lumn=20of=20`port',=20if=20it=20has=20one.=20=20Else=20leave=20?= =?UTF-8?q?it=20alone.=20=20Thanks=20to=20Matthias=20K=C3=B6ppe!?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- ice-9/format.scm | 3 +++ 1 file changed, 3 insertions(+) diff --git a/ice-9/format.scm b/ice-9/format.scm index 7d8c1ccb7..c3b8666a7 100644 --- a/ice-9/format.scm +++ b/ice-9/format.scm @@ -12,6 +12,7 @@ ; Version 3.0 (define-module (ice-9 format) + :use-module (ice-9 and-let-star) :autoload (ice-9 pretty-print) (pretty-print)) (begin-deprecated @@ -182,6 +183,8 @@ (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 From 53802ea86da3783584bc6f257c368675a7ff5bfc Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 9 Jun 2001 18:15:08 +0000 Subject: [PATCH 1289/2047] =?UTF-8?q?(scm=5Flfwrite):=20Maintain=20columnd?= =?UTF-8?q?=20and=20row=20count=20in=20port.=20Thanks=20to=20Matthias=20K?= =?UTF-8?q?=C3=B6ppe!?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- libguile/ports.c | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index cf1ac56c7..b8d6fd221 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -975,11 +975,8 @@ scm_puts (const char *s, SCM port) /* scm_lfwrite * - * Currently, this function has an identical implementation to - * scm_c_write. We could have turned it into a macro expanding into a - * call to scm_c_write. However, the implementation is small and - * might differ in the future. - */ + * This function differs from scm_c_write; it updates port line and + * column. */ void scm_lfwrite (const char *ptr, size_t size, SCM port) @@ -992,6 +989,18 @@ scm_lfwrite (const char *ptr, size_t size, SCM port) ptob->write (port, ptr, size); + for (; size; ptr++, size--) { + if (*ptr == '\n') { + SCM_INCLINE(port); + } + else if (*ptr == '\t') { + SCM_TABCOL(port); + } + else { + SCM_INCCOL(port); + } + } + if (pt->rw_random) pt->rw_active = SCM_PORT_WRITE; } From 6a9003d3a4592c05e521489aaf1394a74b23974d Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 9 Jun 2001 18:15:32 +0000 Subject: [PATCH 1290/2047] *** empty log message *** --- RELEASE | 6 +++++- ice-9/ChangeLog | 14 ++++++++++++++ libguile/ChangeLog | 5 +++++ 3 files changed, 24 insertions(+), 1 deletion(-) diff --git a/RELEASE b/RELEASE index b193220d7..6155e3901 100644 --- a/RELEASE +++ b/RELEASE @@ -22,6 +22,10 @@ After signal handling and threading have been fixed: === In release 1.8.0: +- remove re-exporting behaviour of `export'. + in boot-9.scm, remove begin-deprecated part of `module-export!' + in format.scm, remove kluge at top + - remove deprecated subr and gsubr functions in procs.h, procs.c: scm_make_subr, scm_make_subr_opt, scm_make_subr_with_generic, @@ -45,7 +49,7 @@ After signal handling and threading have been fixed: - remove support for autoloading compiled-code modules: try-module-linked try-module-dynamic-link - init-dynamic-module + init-dynamic-module, etc. scm_register_module_xxx scm_registered_modules scm_clear_registered_modules diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index d433095e2..ec4b7598a 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,17 @@ +2001-06-09 Marius Vollmer + + * pretty-print.scm (generic-write): Use `object->string' to print + unknown objects. + + * optargs.scm (lambda*): Make sure that BODY is always put into a + real body context so that it can contain internal definitions. + Thanks to Matthias Köppe! + + * format.scm: Use (ice-9 and-let-star). + (format:out): Initialize format:output-col with current column of + `port', if it has one. Else leave it alone. Thanks to Matthias + Köppe! + 2001-06-05 Marius Vollmer * boot-9.scm (module-ensure-local-variable!): Renamed from diff --git a/libguile/ChangeLog b/libguile/ChangeLog index ad4a3e871..cd20e6e89 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-06-09 Marius Vollmer + + * ports.c (scm_lfwrite): Maintain columnd and row count in port. + Thanks to Matthias Köppe! + 2001-06-08 Michael Livshin * snarf.h, filter-doc-snarfage.c: more changes to cope with From 811727c704d1e2ce1c0de187c310f28fd648846a Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 10 Jun 2001 20:42:31 +0000 Subject: [PATCH 1291/2047] * rdelim.c (scm_init_rdelim_builtins): don't try to activate the (ice-9 rdelim) module in (guile) and (guile-user). it didn't work reliably anymore. try it from boot-9.scm instead. --- libguile/rdelim.c | 12 ------------ 1 file changed, 12 deletions(-) diff --git a/libguile/rdelim.c b/libguile/rdelim.c index b8fde12e2..f7358ae9e 100644 --- a/libguile/rdelim.c +++ b/libguile/rdelim.c @@ -289,18 +289,6 @@ scm_init_rdelim_builtins (void) #include "libguile/rdelim.x" #endif -#if DEBUG_DEPRECATED == 0 - { - SCM old_module = scm_current_module (); - const char expr[] = "\ -(define-module (guile) :use-module (ice-9 rdelim))\ -(define-module (guile-user) :use-module (ice-9 rdelim))"; - - scm_eval_string (scm_makfromstr (expr, (sizeof expr) - 1, 0)); - scm_set_current_module (old_module); - } -#endif - return SCM_UNSPECIFIED; } From 6eb396fe093fbce2ec759728b62d6b4e2c946469 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 10 Jun 2001 20:44:45 +0000 Subject: [PATCH 1292/2047] * boot-9.scm: use the (ice-9 rdelim) module if include-deprecated-features is true. --- ice-9/boot-9.scm | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 02932d4f0..e1a6e7dd7 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -3063,6 +3063,11 @@ ;; Place the user in the guile-user module. ;; + (define-module (guile-user)) +(if include-deprecated-features + ;; automatic availability of this module is deprecated. + (use-modules (ice-9 rdelim))) + ;;; boot-9.scm ends here From 495c67e53bc96891322b3c18cdbab3597e1d3e17 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 10 Jun 2001 20:45:34 +0000 Subject: [PATCH 1293/2047] *** empty log message *** --- ice-9/ChangeLog | 5 +++++ libguile/ChangeLog | 6 ++++++ 2 files changed, 11 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index ec4b7598a..39d527366 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2001-06-10 Gary Houston + + * boot-9.scm: use the (ice-9 rdelim) module if + include-deprecated-features is true. + 2001-06-09 Marius Vollmer * pretty-print.scm (generic-write): Use `object->string' to print diff --git a/libguile/ChangeLog b/libguile/ChangeLog index cd20e6e89..38da7a1f6 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2001-06-10 Gary Houston + + * rdelim.c (scm_init_rdelim_builtins): don't try to activate the + (ice-9 rdelim) module in (guile) and (guile-user). it didn't + work reliably anymore. try it from boot-9.scm instead. + 2001-06-09 Marius Vollmer * ports.c (scm_lfwrite): Maintain columnd and row count in port. From 00d8d838bb05cd659a090541c7aefdbf826a89ad Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 11 Jun 2001 08:51:28 +0000 Subject: [PATCH 1294/2047] * Simplified the goops macro system a bit and fixed a bug. --- libguile/ChangeLog | 16 +++++++++++++ libguile/goops.h | 56 ++++++++++++++++++++++++++++------------------ libguile/struct.h | 2 ++ 3 files changed, 52 insertions(+), 22 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 38da7a1f6..f55c1c229 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,19 @@ +2001-06-11 Dirk Herrmann + + * struct.h (SCM_STRUCT_VTABLE_FLAGS): New macro. + + * goops.h (SCM_NUMBER_OF_SLOTS): Removed bogus `\´ at the end of + the macro definition. + + (SCM_CLASSP, SCM_INSTANCEP, SCM_PUREGENERICP, SCM_ACCESSORP, + SCM_SIMPLEMETHODP, SCM_FASTMETHODP): Use SCM_STRUCT_VTABLE_FLAGS + instead of SCM_INST_TYPE. + + (SCM_ACCESSORP, SCM_SIMPLEMETHODP, SCM_FASTMETHODP): Make sure + the object is a struct before accessing its struct flags. + + (SCM_INST_TYPE, SCM_SIMPLEMETHODP, SCM_FASTMETHODP): Deprecated. + 2001-06-10 Gary Houston * rdelim.c (scm_init_rdelim_builtins): don't try to activate the diff --git a/libguile/goops.h b/libguile/goops.h index 607df5a50..175d0db40 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -117,45 +117,44 @@ typedef struct scm_method_t { & SCM_CLASSF_MASK) #define SCM_INST(x) SCM_STRUCT_DATA (x) -#define SCM_INST_TYPE(x) SCM_OBJ_CLASS_FLAGS (x) -/* Also defined in libguuile/objects.c */ + +/* Also defined in libguile/objects.c */ #define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x) #define SCM_ACCESSORS_OF(x) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (x)[scm_si_getters_n_setters])) -#define SCM_NUMBER_OF_SLOTS(x)\ +#define SCM_NUMBER_OF_SLOTS(x) \ (SCM_UNPACK (SCM_STRUCT_DATA (x)[scm_struct_i_n_words]) \ - - scm_struct_n_extra_words) \ + - scm_struct_n_extra_words) + +#define SCM_CLASSP(x) \ + (SCM_STRUCTP (x) && SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_METACLASS) +#define SCM_VALIDATE_CLASS(pos, x) SCM_MAKE_VALIDATE (pos, x, CLASSP) #define SCM_INSTANCEP(x) \ - (SCM_STRUCTP (x) && (SCM_INST_TYPE (x) & SCM_CLASSF_GOOPS)) + (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_GOOPS)) #define SCM_VALIDATE_INSTANCE(pos, x) SCM_MAKE_VALIDATE (pos, x, INSTANCEP) #define SCM_PUREGENERICP(x) \ - (SCM_STRUCTP (x) && (SCM_INST_TYPE(x) & SCM_CLASSF_PURE_GENERIC)) + (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_PURE_GENERIC)) #define SCM_VALIDATE_PUREGENERIC(pos, x) SCM_MAKE_VALIDATE (pos, x, PUREGENERICP) -#define SCM_SIMPLEMETHODP(x) (SCM_INST_TYPE(x) & SCM_CLASSF_SIMPLE_METHOD) -#define SCM_ACCESSORP(x) (SCM_INST_TYPE(x) & SCM_CLASSF_ACCESSOR_METHOD) +#define SCM_ACCESSORP(x) \ + (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_ACCESSOR_METHOD)) #define SCM_VALIDATE_ACCESSOR(pos, x) SCM_MAKE_VALIDATE (pos, x, ACCESSORP) -#define SCM_FASTMETHODP(x) (SCM_INST_TYPE(x) \ - & (SCM_CLASSF_ACCESSOR_METHOD \ - | SCM_CLASSF_SIMPLE_METHOD)) #define SCM_SLOT(x, i) (SCM_PACK (SCM_INST (x) [i])) #define SCM_SET_SLOT(x, i, v) (SCM_INST (x) [i] = SCM_UNPACK (v)) #define SCM_SET_HASHSET(c, i, h) (SCM_INST (c) [scm_si_hashsets + (i)] = (h)) -#define SCM_SUBCLASSP(c1, c2) (!SCM_FALSEP (scm_c_memq (c2, SCM_SLOT (c1, scm_si_cpl)))) -#define SCM_IS_A_P(x, c) (SCM_NIMP (x) \ - && SCM_INSTANCEP (x) \ - && SCM_SUBCLASSP (SCM_CLASS_OF (x), c)) -#define SCM_CLASSP(x) (SCM_STRUCTP (x) \ - && SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_METACLASS) -#define SCM_VALIDATE_CLASS(pos, x) SCM_MAKE_VALIDATE (pos, x, CLASSP) -#define SCM_GENERICP(x) (SCM_INSTANCEP (x) \ - && SCM_SUBCLASSP (SCM_CLASS_OF (x), scm_class_generic)) +#define SCM_SUBCLASSP(c1, c2) (!SCM_FALSEP (scm_c_memq (c2, SCM_SLOT (c1, scm_si_cpl)))) +#define SCM_IS_A_P(x, c) \ + (SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), c)) + +#define SCM_GENERICP(x) \ + (SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), scm_class_generic)) #define SCM_VALIDATE_GENERIC(pos, x) SCM_MAKE_VALIDATE (pos, x, GENERICP) -#define SCM_METHODP(x) (SCM_INSTANCEP (x) \ - && SCM_SUBCLASSP(SCM_CLASS_OF(x), scm_class_method)) + +#define SCM_METHODP(x) \ + (SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), scm_class_method)) #define SCM_VALIDATE_METHOD(pos, x) SCM_MAKE_VALIDATE (pos, x, METHODP) #define SCM_MCACHE_N_SPECIALIZED(C) SCM_CADDR (C) @@ -286,4 +285,17 @@ SCM scm_sys_method_more_specific_p (SCM m1, SCM m2, SCM targs); SCM scm_init_goops_builtins (void); void scm_init_goops (void); +#if (SCM_DEBUG_DEPRECATED == 0) + +#define SCM_INST_TYPE(x) SCM_OBJ_CLASS_FLAGS (x) +#define SCM_SIMPLEMETHODP(x) \ + (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_SIMPLE_METHOD)) +#define SCM_FASTMETHODP(x) \ + (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) \ + & (SCM_CLASSF_ACCESSOR_METHOD \ + | SCM_CLASSF_SIMPLE_METHOD))) + + +#endif + #endif /* SCM_GOOPS_H */ diff --git a/libguile/struct.h b/libguile/struct.h index cf7a027fd..6c31ea90b 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -86,6 +86,8 @@ typedef size_t (*scm_struct_free_t) (scm_bits_t * vtable, scm_bits_t * data); #define SCM_SET_STRUCT_LAYOUT(X, v) (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_layout] = SCM_UNPACK (v)) #define SCM_STRUCT_VTABLE(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_vtable])) +#define SCM_STRUCT_VTABLE_FLAGS(X) \ + (SCM_STRUCT_VTABLE_DATA (X) [scm_struct_i_flags]) #define SCM_STRUCT_PRINTER(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_printer])) #define SCM_SET_STRUCT_PRINTER(x, v)\ (SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_printer] = SCM_UNPACK (v)) From de698bfa2679e5aab75dde54e29d01ba7b61fae7 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 11 Jun 2001 17:23:42 +0000 Subject: [PATCH 1295/2047] Use `begin-deprecated' instead of testing `include-deprecated-features' when conditionally using the (ice-9 rdelim) module. See below. --- ice-9/boot-9.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index e1a6e7dd7..cad2a8548 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -3066,8 +3066,8 @@ (define-module (guile-user)) -(if include-deprecated-features - ;; automatic availability of this module is deprecated. - (use-modules (ice-9 rdelim))) +(begin-deprecated + ;; automatic availability of this module is deprecated. + (use-modules (ice-9 rdelim))) ;;; boot-9.scm ends here From 7c95e366c9c46b466daf4f955d4f2875e62dddd0 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 11 Jun 2001 17:23:58 +0000 Subject: [PATCH 1296/2047] *** empty log message *** --- ice-9/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 39d527366..5091dccdf 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,9 @@ +2001-06-11 Marius Vollmer + + * boot-9.scm: Use `begin-deprecated' instead of testing + `include-deprecated-features' when conditionally using the (ice-9 + rdelim) module. See below. + 2001-06-10 Gary Houston * boot-9.scm: use the (ice-9 rdelim) module if From c771038bdae41661a5471caa82ceb52e8df0fd7c Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 13 Jun 2001 09:10:20 +0000 Subject: [PATCH 1297/2047] Clean up some docstrings; nfc. Add Commentary. Update copyright. --- ice-9/common-list.scm | 106 +++++++++++++++++++++++++++--------------- 1 file changed, 69 insertions(+), 37 deletions(-) diff --git a/ice-9/common-list.scm b/ice-9/common-list.scm index 1301b4219..4d0e147aa 100644 --- a/ice-9/common-list.scm +++ b/ice-9/common-list.scm @@ -1,17 +1,17 @@ ;;;; common-list.scm --- COMMON LISP list functions for Scheme ;;;; -;;;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. -;;;; +;;;; Copyright (C) 1995, 1996, 1997, 2001 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 ;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, @@ -40,7 +40,40 @@ ;;;; If you write modifications of your own for GUILE, it is your choice ;;;; whether to permit this exception to apply to your modifications. ;;;; If you do not wish that, delete this exception notice. -;;;; +;;;; + +;;; Commentary: + +;; These procedures are exported: +;; (adjoin e l) +;; (union l1 l2) +;; (intersection l1 l2) +;; (set-difference l1 l2) +;; (reduce-init p init l) +;; (reduce p l) +;; (some pred l . rest) +;; (every pred l . rest) +;; (notany pred . ls) +;; (notevery pred . ls) +;; (count-if pred l) +;; (find-if pred l) +;; (member-if pred l) +;; (remove-if pred l) +;; (remove-if-not pred l) +;; (delete-if! pred l) +;; (delete-if-not! pred l) +;; (butlast lst n) +;; (and? . args) +;; (or? . args) +;; (has-duplicates? lst) +;; (pick p l) +;; (pick-mappings p l) +;; (uniq l) +;; +;; See docstrings for each procedure for more info. See also module +;; `(srfi srfi-1)' for a complete list handling library. + +;;; Code: (define-module (ice-9 common-list)) @@ -63,21 +96,21 @@ ;promotional, or sales literature without prior written consent in ;each case. -(define-public (adjoin e l) - "Returns list L, possibly with element E added if it is not already in L." +(define-public (adjoin e l) + "Return list L, possibly with element E added if it is not already in L." (if (memq e l) l (cons e l))) (define-public (union l1 l2) - "Returns a new list that is the union of L1 and L2. -Elements that occur in both lists will occur only once -in the result list." + "Return a new list that is the union of L1 and L2. +Elements that occur in both lists occur only once in +the result list." (cond ((null? l1) l2) ((null? l2) l1) (else (union (cdr l1) (adjoin (car l1) l2))))) (define-public (intersection l1 l2) - "Returns a new list that is the intersection of L1 and L2. -Only elements that occur in both lists will occur in the result list." + "Return a new list that is the intersection of L1 and L2. +Only elements that occur in both lists occur in the result list." (if (null? l2) l2 (let loop ((l1 l1) (result '())) (cond ((null? l1) (reverse! result)) @@ -98,9 +131,9 @@ Only elements that occur in both lists will occur in the result list." (reduce-init p (p init (car l)) (cdr l)))) (define-public (reduce p l) - "Combines all the elements of sequence L using a binary operation P. -The combination is left-associative. For example, using +, one can -add up all the elements. `reduce' allows you to apply a function which + "Combine all the elements of sequence L using a binary operation P. +The combination is left-associative. For example, using +, one can +add up all the elements. `reduce' allows you to apply a function which accepts only two arguments to more than 2 objects. Functional programmers usually refer to this as foldl." (cond ((null? l) l) @@ -109,11 +142,11 @@ programmers usually refer to this as foldl." (define-public (some pred l . rest) "PRED is a boolean function of as many arguments as there are list -arguments to `some'. I.e., L plus any optional arguments. PRED is -applied to successive elements of the list arguments in order. As soon -as one of these applications returns a true value, `some' terminates -and returns that value. If no application returns a true value, -`some' returns #f. All the lists should have the same length." +arguments to `some', i.e., L plus any optional arguments. PRED is +applied to successive elements of the list arguments in order. As soon +as one of these applications returns a true value, return that value. +If no application returns a true value, return #f. +All the lists should have the same length." (cond ((null? rest) (let mapf ((l l)) (and (not (null? l)) @@ -136,52 +169,49 @@ PRED is #t and #f otherwise." (and (apply pred (car l) (map car rest)) (mapf (cdr l) (map cdr rest)))))))) -(define-public (notany pred . ls) +(define-public (notany pred . ls) "Return #t iff every application of PRED to L, etc., returns #f. Analogous to some but returns #t if no application of PRED returns a true value or #f as soon as any one does." (not (apply some pred ls))) -(define-public (notevery pred . ls) +(define-public (notevery pred . ls) "Return #t iff there is an application of PRED to L, etc., that returns #f. Analogous to some but returns #t as soon as an application of PRED returns #f, or #f otherwise." (not (apply every pred ls))) (define-public (count-if pred l) - "Returns the number of elements in L such that (PRED element) -returns true." + "Return the number of elements in L for which (PRED element) returns true." (let loop ((n 0) (l l)) (cond ((null? l) n) ((pred (car l)) (loop (+ n 1) (cdr l))) (else (loop n (cdr l)))))) (define-public (find-if pred l) - "Searches for the first element in L such that (PRED element) -returns true. If it finds any such element in L, element is -returned. Otherwise, #f is returned." + "Search for the first element in L for which (PRED element) returns true. +If found, return that element, otherwise return #f." (cond ((null? l) #f) ((pred (car l)) (car l)) (else (find-if pred (cdr l))))) (define-public (member-if pred l) - "Returns L if (T element) is true for any element in L. Returns #f -if PRED does not apply to any element in L." + "Return #f iff (PRED element) is not true for any element in L." (cond ((null? l) #f) ((pred (car l)) l) (else (member-if pred (cdr l))))) -(define-public (remove-if pred? l) - "Removes all elements from L where (PRED? element) is true. -Returns everything that's left." +(define-public (remove-if pred l) + "Remove all elements from L where (PRED element) is true. +Return everything that's left." (let loop ((l l) (result '())) (cond ((null? l) (reverse! result)) ((pred? (car l)) (loop (cdr l) result)) (else (loop (cdr l) (cons (car l) result)))))) -(define-public (remove-if-not pred? l) - "Removes all elements from L where (PRED? element) is #f. -Returns everything that's left." +(define-public (remove-if-not pred l) + "Remove all elements from L where (PRED element) is #f. +Return everything that's left." (let loop ((l l) (result '())) (cond ((null? l) (reverse! result)) ((not (pred? (car l))) (loop (cdr l) result)) @@ -194,7 +224,7 @@ Returns everything that's left." ((pred (car l)) (delete-if (cdr l))) (else (set-cdr! l (delete-if (cdr l))) - l)))) + l)))) (define-public (delete-if-not! pred l) "Destructive version of `remove-if-not'." @@ -246,7 +276,7 @@ for which P returns a non-#f value." (else (loop s (cdr l)))))) (define-public (pick-mappings p l) - "Apply P to each element of L, returning a list of the + "Apply P to each element of L, returning a list of the non-#f return values of P." (let loop ((s '()) (l l)) @@ -265,3 +295,5 @@ non-#f return values of P." acc (cons (car l) acc)) (cdr l))))) + +;;; common-list.scm ends here From 60850aed09607669943638337acecf0bc082f149 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 13 Jun 2001 09:14:07 +0000 Subject: [PATCH 1298/2047] *** empty log message *** --- ice-9/ChangeLog | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 5091dccdf..a52631ef4 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,10 @@ +2001-06-13 Thien-Thi Nguyen + + * common-list.scm: + Clean up some docstrings; nfc. + Add Commentary. + Update copyright. + 2001-06-11 Marius Vollmer * boot-9.scm: Use `begin-deprecated' instead of testing @@ -17,7 +24,7 @@ * optargs.scm (lambda*): Make sure that BODY is always put into a real body context so that it can contain internal definitions. Thanks to Matthias Köppe! - + * format.scm: Use (ice-9 and-let-star). (format:out): Initialize format:output-col with current column of `port', if it has one. Else leave it alone. Thanks to Matthias @@ -36,7 +43,7 @@ (module-re-export!): New. Use this for re-exporting imported variables. (re-export): New, to go with `module-re-export!'. - + * format.scm: Added kluge at top that keeps `export' from re-exporting the `format' variable of the `(guile)' module. @@ -52,7 +59,7 @@ 2001-06-04 Marius Vollmer Added exception notice to all files. - + * boot-9.scm (module-export!): Revert 2001-06-02 change. It caused more problems than it solved by accidentally re-exporting importing bindings once in a while. @@ -121,7 +128,7 @@ * boot-9.scm (use-srfis): Do not extend the srfi-0 feature list. (cond-expand-provide): New procedure. - + 2001-05-22 Marius Vollmer * boot-9.scm (define-module): Return the new module. @@ -142,7 +149,7 @@ * match.scm: Likewise. * expect.scm: Likewise. * psyntax.pp: Regenerated. - + * rdelim.scm: Call `%init-rdelim-builtins'. * rw.scm: Call `%init-rw-builtins'. From 9eee1d6c1560ace930502d2234f57c7ce3df91c7 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 13 Jun 2001 09:25:43 +0000 Subject: [PATCH 1299/2047] Initial revision --- ice-9/README | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 ice-9/README diff --git a/ice-9/README b/ice-9/README new file mode 100644 index 000000000..f659b9ee7 --- /dev/null +++ b/ice-9/README @@ -0,0 +1,12 @@ +This directory contains various bits of Guile Scheme code. +Most of these are packaged as modules, with foo.scm implementing +the module `(ice-9 foo)'. + +The non-module files are: + +boot-9.scm -- loaded on guile startup + implements module system + lots of other stuff +arrays.scm -- loaded by boot-9.scm +networking.scm -- loaded by boot-9.scm +posix.scm -- loaded by boot-9.scm +r4rs.scm -- loaded by boot-9.scm From b4b50361c999869e48a378db386baab3e0ccb3bf Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 13 Jun 2001 09:26:46 +0000 Subject: [PATCH 1300/2047] *** empty log message *** --- ice-9/ChangeLog | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index a52631ef4..0b5891e6c 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,5 +1,7 @@ 2001-06-13 Thien-Thi Nguyen + * README: New file. + * common-list.scm: Clean up some docstrings; nfc. Add Commentary. From 26d9bcd003b6ac86c4c4d1413dbdebad27e6c779 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 13 Jun 2001 16:02:07 +0000 Subject: [PATCH 1301/2047] No longer use module `(ice-9 slib)'. Use module `(ice-9 pretty-print)'. No longer require `pretty-print'. (slib:error): Delete. (match:error, match:syntax-err): Rewrite. Thanks to Dale P. Smith. --- ice-9/match.scm | 25 +++++++++++-------------- 1 file changed, 11 insertions(+), 14 deletions(-) diff --git a/ice-9/match.scm b/ice-9/match.scm index 75b4608d9..d2aeb501d 100644 --- a/ice-9/match.scm +++ b/ice-9/match.scm @@ -1,17 +1,17 @@ ;;; installed-scm-file ;;;; Copyright (C) 2001 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 ;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, @@ -40,10 +40,10 @@ ;;;; If you write modifications of your own for GUILE, it is your choice ;;;; whether to permit this exception to apply to your modifications. ;;;; If you do not wish that, delete this exception notice. -;;;; +;;;; -(define-module (ice-9 match) - :use-module (ice-9 slib) +(define-module (ice-9 match) + :use-module (ice-9 pretty-print) :export (match match-lambda match-lambda* match-define match-let match-let* match-letrec define-structure define-const-structure @@ -52,14 +52,12 @@ match:structure-control match:set-structure-control match:runtime-structures match:set-runtime-structures)) -(define slib:error error) - ;; The original code can be found at the Scheme Repository -;; +;; ;; http://www.cs.indiana.edu/scheme-repository/code.match.html -;; +;; ;; or Andrew K. Wright's web page: -;; +;; ;; http://www.star-lab.com/wright/code.html @@ -196,10 +194,9 @@ ;; End of user visible/modifiable stuff. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(require (quote pretty-print)) -(define match:error (lambda (val . args) (for-each pretty-print args) (slib:error "no matching clause for " val))) +(define match:error (lambda (val . args) (for-each pretty-print args) (error "no matching clause for " val))) (define match:andmap (lambda (f l) (if (null? l) (and) (and (f (car l)) (match:andmap f (cdr l)))))) -(define match:syntax-err (lambda (obj msg) (slib:error msg obj))) +(define match:syntax-err (lambda (obj msg) (error msg obj))) (define match:disjoint-structure-tags (quote ())) (define match:make-structure-tag (lambda (name) (if (or (eq? match:structure-control (quote disjoint)) match:runtime-structures) (let ((tag (gensym))) (set! match:disjoint-structure-tags (cons tag match:disjoint-structure-tags)) tag) (string->symbol (string-append "<" (symbol->string name) ">"))))) (define match:structure? (lambda (tag) (memq tag match:disjoint-structure-tags))) From 9571723240183139f2e3883233b4b4269fbc1e50 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 13 Jun 2001 16:03:27 +0000 Subject: [PATCH 1302/2047] *** empty log message *** --- ice-9/ChangeLog | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 0b5891e6c..546c44c82 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,7 +1,17 @@ 2001-06-13 Thien-Thi Nguyen + * match.scm: + No longer use module `(ice-9 slib)'. + Use module `(ice-9 pretty-print)'. + No longer require `pretty-print'. + + (slib:error): Delete. + (match:error, match:syntax-err): Rewrite. + + Thanks to Dale P. Smith. + * README: New file. - + * common-list.scm: Clean up some docstrings; nfc. Add Commentary. From ae83dafdfc0560f238516d4722fd6fcc90b6ab72 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 13 Jun 2001 16:05:55 +0000 Subject: [PATCH 1303/2047] Remove SLIB reference for ice-9/match.scm, since it now is no longer dependent. Thanks to Dale P. Smith. --- NEWS | 2 -- 1 file changed, 2 deletions(-) diff --git a/NEWS b/NEWS index 9eb5928d7..e7d1cf468 100644 --- a/NEWS +++ b/NEWS @@ -161,8 +161,6 @@ ice-9/match.scm for brief description or for complete documentation. -This module requires SLIB to be installed and available from Guile. - ** New module (ice-9 buffered-input) This module provides procedures to construct an input port from an From 98cb966490ecce3365c8653ad14c623f5179f3f6 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 13 Jun 2001 16:10:05 +0000 Subject: [PATCH 1304/2047] Update path to #include file scmconfig.h. Thanks to Golubev I. N. --- libguile/mkstemp.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/mkstemp.c b/libguile/mkstemp.c index a35f8d6d0..ce7c376c2 100644 --- a/libguile/mkstemp.c +++ b/libguile/mkstemp.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1991, 1992, 1996, 1998 Free Software Foundation, Inc. +/* Copyright (C) 1991, 1992, 1996, 1998, 2001 Free Software Foundation, Inc. This file is derived from mkstemps.c from the GNU Libiberty Library which in turn is derived from the GNU C Library. @@ -17,7 +17,7 @@ write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ -#include "scmconfig.h" +#include "libguile/scmconfig.h" #ifdef HAVE_STDLIB_H #include From 58bee6a81aa6241410e2007245784289d93e623c Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 13 Jun 2001 16:11:23 +0000 Subject: [PATCH 1305/2047] *** empty log message *** --- libguile/ChangeLog | 33 +++++++++++++++++++-------------- 1 file changed, 19 insertions(+), 14 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f55c1c229..1269d714e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-06-13 Thien-Thi Nguyen + + * mkstemp.c: Update path to #include file scmconfig.h. + Thanks to Golubev I. N. + 2001-06-11 Dirk Herrmann * struct.h (SCM_STRUCT_VTABLE_FLAGS): New macro. @@ -24,7 +29,7 @@ * ports.c (scm_lfwrite): Maintain columnd and row count in port. Thanks to Matthias Köppe! - + 2001-06-08 Michael Livshin * snarf.h, filter-doc-snarfage.c: more changes to cope with @@ -170,7 +175,7 @@ * extensions.c (scm_c_register_extension): Allow NULL as library name. (load_extension): Ignore NULL library names when comparing. - + * hash.c (scm_hasher): Use SCM_UNPACK in the case labels so that non-pointers are being compared. Thanks to Alexander Klimov! @@ -179,7 +184,7 @@ * rw.c (scm_write_string_partial): new procedure implementing write-string/partial in (ice-9 rw). * rw.h: declare scm_write_string_partial. - + 2001-06-04 Marius Vollmer * keywords.c (keyword_print): Substract 1 from length of symbol @@ -247,7 +252,7 @@ * print.h, print.c (scm_print_symbol_name): Factored out of scm_iprin1. (scm_iprin1): Call it. - + * keywords.c (keyword_print): Use scm_print_symbol_name so that weird names are printed correctly. @@ -266,7 +271,7 @@ 2001-05-28 Martin Grabmueller * symbols.c (scm_gensym): Fix buffer overrun (try `(gensym - (make-string 2000 #\!))' in an older version). + (make-string 2000 #\!))' in an older version). Change strncpy to memcpy to allow embedded NUL characters in symbol prefix. @@ -352,8 +357,8 @@ corresponds to the former situation that SCM_VOIDP_TEST was defined. - (SCM): Now defined as typedef struct scm_unused_struct * SCM; - If this appears to be not ANSI compliant, we will change it to + (SCM): Now defined as typedef struct scm_unused_struct * SCM; + If this appears to be not ANSI compliant, we will change it to typedef struct scm_unused_struct { } * SCM; Thanks to Han-Wen Nienhuys for the suggestion. @@ -627,7 +632,7 @@ `duplicate_string'. Do not use an indirect cell, store symbol directly in collision list of hash table. (duplicate_string): Removed. - + * init.c (scm_init_guile_1): Call scm_init_extensions. * Makefile.am: Add "extensions.c" and related files in all the @@ -662,7 +667,7 @@ * eval.c, gc.c, gh_funcs.c, goops.c, macros.c, pairs.c, ramap.c, rdelim.c, rw.c, scmsigs.c, snarf.h, values.c: Changed according to the comments above. - + 2001-05-19 Neil Jerram * throw.c (scm_lazy_catch): Slight docstring clarification. @@ -691,20 +696,20 @@ scm_c_use_module, scm_c_export): New. (the_root_module): New static variant of scm_the_root_module. Use it everywhere instead of scm_the_root_module. - + * fluids.h, fluids.c (scm_internal_with_fluids): Deprecated. (scm_c_with_fluids): Renamed from scm_internal_with_fluids. (scm_c_with_fluid): New. (scm_with_fluids): Use scm_c_with_fluids instead of scm_internal_with_fluids. - + * goops.h, goops.c (scm_init_goops_builtins): Renamed from `scm_init_goops'. Do not explicitly create/switch modules. Return SCM_UNSPECIFIED. (scm_init_goops): Only register `%init-goops-builtins' procedure. (scm_load_goops): Use scm_c_resolve_module instead of scm_resolve_module. - + * init.c (scm_init_guile_1): Call `scm_init_goops' instead of `scm_init_oop_goops_goopscore_module'. Call `scm_init_rdelim' and `scm_init_rw' prior to loading the startup files. @@ -714,7 +719,7 @@ Return SCM_UNSPECIFIED. (scm_init_rdelim): Only register `%init-rdelim-builtins' procedure. - + * rw.c (scm_init_rw_builtins): Renamed from scm_init_rw. Do not explicitly create/switch modules. Return SCM_UNSPECIFIED. (scm_init_rw): Only register `%init-rw-builtins' procedure. @@ -933,7 +938,7 @@ 2001-05-15 Dirk Herrmann * eval.c (scm_init_eval): Initialize scm_undefineds and - scm_listofnull. + scm_listofnull. * gc.c (scm_debug_newcell, scm_debug_newcell2): Fixed to behave like the SCM_NEWCELL macro counterparts. From dc35f051e457acc9b046969c815a5dc9caab7c2e Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 14 Jun 2001 17:34:01 +0000 Subject: [PATCH 1306/2047] (ptrdiff_t): Removed. --- acconfig.h | 2 -- 1 file changed, 2 deletions(-) diff --git a/acconfig.h b/acconfig.h index adfbc0bd1..a449409aa 100644 --- a/acconfig.h +++ b/acconfig.h @@ -167,5 +167,3 @@ /* Define if the compiler supports long longs. */ #undef HAVE_LONG_LONGS -/* defined to signed long if doesn't exist: */ -#undef ptrdiff_t From 480cd4aa39e76a348a266506e35d76a079b2675c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 14 Jun 2001 17:36:03 +0000 Subject: [PATCH 1307/2047] Check for header . Check for uintptr_t type. Use AC_CHECK_TYPES for this. Do not caus ptrdiff_t to be `#defined'. --- configure.in | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/configure.in b/configure.in index a28d07df2..32c5481e0 100644 --- a/configure.in +++ b/configure.in @@ -165,10 +165,12 @@ AC_C_BIGENDIAN AC_CHECK_SIZEOF(int) AC_CHECK_SIZEOF(long) -dnl by the pre C9X ANSI C standards, size_t & ptrdiff_t have to be -dnl representable by a standard integral type. since the largest -dnl integer type in the pre-C9X ANSI C standards is long... -AC_CHECK_TYPE(ptrdiff_t, long) +dnl Check for integral types that can represent the range of pointers. +dnl If these types don't exist on this platform, they are replaced by +dnl "unsigned long" and "long", respectively. + +AC_CHECK_HEADERS(stdint.h) +AC_CHECK_TYPES([uintptr_t, ptrdiff_t]) AC_CACHE_CHECK([for long longs], scm_cv_long_longs, AC_TRY_COMPILE(, From be8dd11837e097a854bc8debe86aeff38e00b186 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 14 Jun 2001 17:36:41 +0000 Subject: [PATCH 1308/2047] Updates for load-extension et al. --- doc/intro.texi | 68 +++++++++++++++++++++++++++++++------------------- 1 file changed, 43 insertions(+), 25 deletions(-) diff --git a/doc/intro.texi b/doc/intro.texi index 55ab4f6bd..8e859c825 100644 --- a/doc/intro.texi +++ b/doc/intro.texi @@ -1,4 +1,4 @@ -@c $Id: intro.texi,v 1.11 2001-05-30 20:32:05 mgrabmue Exp $ +@c $Id: intro.texi,v 1.12 2001-06-14 17:36:41 mvo Exp $ @page @node What is Guile? @@ -649,7 +649,7 @@ j0_wrapper (SCM x) void init_bessel () @{ - scm_make_gsubr ("j0", 1, 0, 0, j0_wrapper); + scm_c_define_gsubr ("j0", 1, 0, 0, j0_wrapper); @} @end smallexample @@ -663,26 +663,27 @@ gcc -shared -o libguile-bessel.so -fPIC bessel.c For creating shared libraries portably, we recommend the use of @code{GNU Libtool}. -A shared library can be loaded into a running Guile process with -@code{dynamic-link}. After it has been linked you can call its exported -functions via @code{dynamic-call}. For our example, we are going to -call the function @code{init_bessel} which will make @code{j0_wrapper} -available to Scheme programs with the name @code{j0}. Note that we do -not specify a filename extension such as @file{.so} when invoking -@code{dynamic-link}. The right extension for the host platform will be -provided automatically. +A shared library can be loaded into a running Guile process with the +function @code{load-extension}. In addition to the name of the +library to load, this function also expects the name of function from +that library that will be called to initialize it. For our example, +we are going to call the function @code{init_bessel} which will make +@code{j0_wrapper} available to Scheme programs with the name +@code{j0}. Note that we do not specify a filename extension such as +@file{.so} when invoking @code{load-extension}. The right extension for +the host platform will be provided automatically. @smalllisp -(define bessel-lib (dynamic-link "libguile-bessel")) -(dynamic-call "init_bessel" bessel-lib) +(load-extension "libguile-bessel" "init_bessel") (j0 2) @result{} 0.223890779141236 @end smalllisp -For this to work, @code{dynamic-link} must be able to find -@file{libguile-bessel}, of course. It will look in the places that are -usual for your operating system, and it will additionally look into the -directories listed in the @code{LTDL_LIBRRAY_PATH} environment variable. +For this to work, @code{load-extension} must be able to find +@file{libguile-bessel}, of course. It will look in the places that +are usual for your operating system, and it will additionally look +into the directories listed in the @code{LTDL_LIBRRAY_PATH} +environment variable. To see how these Guile extensions via shared libraries relate to the module system, see below @xref{Intro to Modules and Extensions}. @@ -722,7 +723,7 @@ are searched first, then the the default. The following command shows the complete list of directories searched: @smallexample -guile -c '(for-each write-line %load-path)' +guile -c '(write %load-path) (newline)' @end smallexample Suppose you want to use the procedures and variables exported by the @@ -808,13 +809,15 @@ using @code{use-modules} to load the module @code{(foo bar)}. @node Intro to Modules and Extensions @subsection Intro to Modules and Extensions -In addition to Scheme code you can also put new procedures and other -named features that are provided by an extension into a module. +In addition to Scheme code you can also put things that are defined in +C into a module. You do this by writing a small Scheme file that defines the module. -That Scheme file in turn invokes @code{dynamic-link} and -@code{dynamic-call} as explained above to make the extension -available. +That Scheme file in turn invokes @code{load-extension} to make the +features defined in C available. This works since all definitions +made by @code{scm_c_define_gsubr} etc. go into the @emph{current +module} and @code{define-module} causes the newly defined module to be +current while the code that follows it is executed. Suppose we want to put the Bessel function @code{j0} from the example extension into a module called @code{(math bessel)}. We would have to @@ -823,12 +826,27 @@ write a Scheme file with this contents @smallexample (define-module (math bessel)) -(dynamic-call "init_bessel" (dynamic-link "libguile-bessel")) +(export j0) + +(load-extension "libguile-bessel" "init_bessel") @end smallexample -The file should of course be saved in the right place for autoloading, -for example as @file{/usr/local/share/guile/math/bessel.scm}. +This file should of course be saved in the right place for +autoloading, for example as +@file{/usr/local/share/guile/math/bessel.scm}. +When @code{init_bessel} is called, the new @code{(math bessel)} module +is the current one. Thus, the call to @code{scm_c_define_gsubr} will +put the new definition for @code{j0} into it, just as we want it. + +The definitions made in the C code are not automatically exported from +a module. You need to explicitely list the ones you want to export in +@code{export} statements or with the @code{:export} option of +@code{define-module}. + +There is also a way to manipulate the module system from C but only +Scheme files can be autoloaded. Thus, we recommend that you define +your modules in Scheme. @page @node Reporting Bugs From 38956d845cebc3921703f47559364578ffd9e43c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 14 Jun 2001 17:37:38 +0000 Subject: [PATCH 1309/2047] (ptrdiff_t): Typedef to long when configure didn't find it. --- libguile/__scm.h | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/libguile/__scm.h b/libguile/__scm.h index f5e7ed3a0..fd67075af 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -279,6 +279,10 @@ typedef unsigned long long ulong_long; * - ... add more */ +#ifndef HAVE_PTRDIFF_T +typedef long ptrdiff_t; +#endif + #ifdef HAVE_LIMITS_H # include #endif From 4a19973db38a653cae407d38e3ec7ea047c56e03 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 14 Jun 2001 17:39:30 +0000 Subject: [PATCH 1310/2047] Include when we have it. (scm_bits_t): Changed to be a unsigned type. Use uintptr_t when available. Else use "unsigned long". (scm_signed_bits_t): New. --- libguile/tags.h | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/libguile/tags.h b/libguile/tags.h index 3de11fec8..4f43dea26 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -52,11 +52,21 @@ ** It is here that tag bits are assigned for various purposes. **/ +#ifdef HAVE_STDINT_H +#include +#endif + /* In the beginning was the Word: */ -typedef long scm_bits_t; +#ifdef HAVE_UINTPTR_T +typedef uintptr_t scm_bits_t; +typedef intptr_t scm_signed_bits_t; +#else +typedef unsigned long scm_bits_t; +typedef signed long scm_signed_bits_t; +#endif /* But as external interface, we use SCM, which may, according to the desired * level of type checking, be defined in several ways: From 4d87842bb310d2c9a95c22835ac5817134ffd405 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 14 Jun 2001 17:41:21 +0000 Subject: [PATCH 1311/2047] (SCM_SRS): Cast shiftee to scm_signed_bits_t. (SCM_INUM): Cast result to scm_signed_bits_t. --- libguile/numbers.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/numbers.h b/libguile/numbers.h index e6ec6e10c..93e2c4bf9 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -69,7 +69,7 @@ /* SCM_SRS is signed right shift */ #if (-1 == (((-1) << 2) + 2) >> 2) -# define SCM_SRS(x, y) ((x) >> (y)) +# define SCM_SRS(x, y) ((scm_signed_bits_t)(x) >> (y)) #else # define SCM_SRS(x, y) ((SCM_UNPACK (x) < 0) ? ~((~SCM_UNPACK (x)) >> (y)) : (SCM_UNPACK (x) >> (y))) #endif /* (-1 == (((-1) << 2) + 2) >> 2) */ @@ -78,7 +78,7 @@ #define SCM_INUMP(x) (2 & SCM_UNPACK (x)) #define SCM_NINUMP(x) (!SCM_INUMP (x)) #define SCM_MAKINUM(x) (SCM_PACK (((x) << 2) + 2L)) -#define SCM_INUM(x) (SCM_SRS (SCM_UNPACK (x), 2)) +#define SCM_INUM(x) ((scm_signed_bits_t)(SCM_SRS (SCM_UNPACK (x), 2))) /* SCM_FIXABLE is true if its long argument can be encoded in an SCM_INUM. */ From 2e7d963d973481b8c8dab1d0bf0057316b0dbd11 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 14 Jun 2001 17:41:51 +0000 Subject: [PATCH 1312/2047] * readline.h (scm_clear_history): New prototype. --- guile-readline/readline.h | 1 + 1 file changed, 1 insertion(+) diff --git a/guile-readline/readline.h b/guile-readline/readline.h index 85d115b4a..26036e6d5 100644 --- a/guile-readline/readline.h +++ b/guile-readline/readline.h @@ -33,6 +33,7 @@ extern SCM scm_readline_options (SCM setting); extern void scm_readline_init_ports (SCM inp, SCM outp); extern SCM scm_readline (SCM txt, SCM inp, SCM outp, SCM read_hook); extern SCM scm_add_history (SCM txt); +extern SCM scm_clear_history (void); extern SCM scm_read_history (SCM file); extern SCM scm_write_history (SCM file); extern SCM scm_filename_completion_function (SCM text, SCM continuep); From dcb17187c3d2a9a680bed9aed44883562f3baacf Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 14 Jun 2001 17:42:45 +0000 Subject: [PATCH 1313/2047] * configure.in: Check for rl_filename_completion_function. * readline.c (s_scm_filename_completion_function): Use rl_filename_completion_function instead of filename_completion_function, if we have it. (scm_init_readline): Use rl_compentry_func_t instead if Function when _RL_FUNCTION_TYPEDEF is defined. --- guile-readline/configure.in | 3 +++ guile-readline/readline.c | 8 ++++++++ 2 files changed, 11 insertions(+) diff --git a/guile-readline/configure.in b/guile-readline/configure.in index a085dbcf9..ef62338d8 100644 --- a/guile-readline/configure.in +++ b/guile-readline/configure.in @@ -22,6 +22,9 @@ fi AC_CHECK_FUNCS(siginterrupt rl_clear_signals rl_cleanup_after_signal) +dnl Check for modern readline naming +AC_CHECK_FUNCS(rl_filename_completion_function) + dnl Check for rl_pre_input_hook. This is more complicated because on dnl some systems (HP/UX), the linker wont let us treat dnl rl_pre_input_hook as a function when it really is a function diff --git a/guile-readline/readline.c b/guile-readline/readline.c index b085f94d8..f5f330bca 100644 --- a/guile-readline/readline.c +++ b/guile-readline/readline.c @@ -380,7 +380,11 @@ SCM_DEFINE (scm_filename_completion_function, "filename-completion-function", 2, SCM ans; SCM_VALIDATE_STRING (1,text); SCM_STRING_COERCE_0TERMINATION_X (text); +#ifdef HAVE_RL_FILENAME_COMPLETION_FUNCTION + s = rl_filename_completion_function (SCM_STRING_CHARS (text), SCM_NFALSEP (continuep)); +#else s = filename_completion_function (SCM_STRING_CHARS (text), SCM_NFALSEP (continuep)); +#endif ans = scm_makfrom0str (s); free (s); return ans; @@ -545,7 +549,11 @@ scm_init_readline () = scm_c_define ("*readline-completion-function*", SCM_BOOL_F); rl_getc_function = current_input_getc; rl_redisplay_function = redisplay; +#if defined (_RL_FUNCTION_TYPEDEF) + rl_completion_entry_function = (rl_compentry_func_t*) completion_function; +#else rl_completion_entry_function = (Function*) completion_function; +#endif rl_basic_word_break_characters = "\t\n\"'`;()"; rl_readline_name = "Guile"; #if defined (HAVE_RL_PRE_INPUT_HOOK) && defined (GUILE_SIGWINCH_SA_RESTART_CLEARED) From 4ff9f8254e51eec64fa89cd02e775107f100471c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 14 Jun 2001 17:43:39 +0000 Subject: [PATCH 1314/2047] *** empty log message *** --- ChangeLog | 8 ++++++++ guile-readline/ChangeLog | 13 +++++++++++++ libguile/ChangeLog | 13 +++++++++++++ 3 files changed, 34 insertions(+) diff --git a/ChangeLog b/ChangeLog index d7dcb09fc..8d02e791f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2001-06-14 Marius Vollmer + + * configure.in: Check for header . Check for uintptr_t + type. Use AC_CHECK_TYPES for this. Do not caus ptrdiff_t to be + `#defined'. + + * acconfig.h (ptrdiff_t): Removed. + 2001-06-05 Martin Grabmueller * configure.in: Generate examples/box-dynamic-module/Makefile. diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index b8f3410fe..e8d98f1f2 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,16 @@ +2001-06-14 Marius Vollmer + + Thanks to Matthias Köppe! + + * configure.in: Check for rl_filename_completion_function. + * readline.c (s_scm_filename_completion_function): Use + rl_filename_completion_function instead of + filename_completion_function, if we have it. + (scm_init_readline): Use rl_compentry_func_t instead if Function + when _RL_FUNCTION_TYPEDEF is defined. + + * readline.h (scm_clear_history): New prototype. + 2001-06-07 Dirk Herrmann * readline.c (current_input_getc): Mark unused parameters with diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 1269d714e..4aae0a351 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,16 @@ +2001-06-14 Marius Vollmer + + * __scm.h (ptrdiff_t): Typedef to long when configure didn't find + it. + + * tags.h: Include when we have it. + (scm_bits_t): Changed to be a unsigned type. Use uintptr_t when + available. Else use "unsigned long". + (scm_signed_bits_t): New. + + * numbers.h (SCM_SRS): Cast shiftee to scm_signed_bits_t. + (SCM_INUM): Cast result to scm_signed_bits_t. + 2001-06-13 Thien-Thi Nguyen * mkstemp.c: Update path to #include file scmconfig.h. From 45cf8cd6aad1f45a7d025c04df90549869c83087 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 14 Jun 2001 18:22:25 +0000 Subject: [PATCH 1315/2047] (remove-if, remove-if-not): Fix typo: use `pred', not `pred?', in the body. --- ice-9/common-list.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ice-9/common-list.scm b/ice-9/common-list.scm index 4d0e147aa..bc583fdf2 100644 --- a/ice-9/common-list.scm +++ b/ice-9/common-list.scm @@ -206,7 +206,7 @@ If found, return that element, otherwise return #f." Return everything that's left." (let loop ((l l) (result '())) (cond ((null? l) (reverse! result)) - ((pred? (car l)) (loop (cdr l) result)) + ((pred (car l)) (loop (cdr l) result)) (else (loop (cdr l) (cons (car l) result)))))) (define-public (remove-if-not pred l) @@ -214,7 +214,7 @@ Return everything that's left." Return everything that's left." (let loop ((l l) (result '())) (cond ((null? l) (reverse! result)) - ((not (pred? (car l))) (loop (cdr l) result)) + ((not (pred (car l))) (loop (cdr l) result)) (else (loop (cdr l) (cons (car l) result)))))) (define-public (delete-if! pred l) From 3d968b4e8b82c4c080ff57689a3a4e9742583fcf Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 14 Jun 2001 18:23:28 +0000 Subject: [PATCH 1316/2047] Prevent `export' from re-exporting core bindings. --- srfi/srfi-13.scm | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/srfi/srfi-13.scm b/srfi/srfi-13.scm index dba10c525..8fe674f1e 100644 --- a/srfi/srfi-13.scm +++ b/srfi/srfi-13.scm @@ -43,6 +43,19 @@ (define-module (srfi srfi-13)) +(begin-deprecated + ;; Prevent `export' from re-exporting core bindings. This behaviour + ;; of `export' is deprecated and will disappear in one f the next + ;; releases. + (define string->list #f) + (define string-copy #f) + (define string-fill! #f) + (define string-index #f) + (define string-upcase #f) + (define string-upcase! #f) + (define string-downcase #f) + (define string-downcase! #f)) + (export ;;; Predicates ;; string? string-null? <= in the core From 2635d5efb9553cbc6a2d0a80e554936da5dc6a42 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 14 Jun 2001 18:26:27 +0000 Subject: [PATCH 1317/2047] * unif.h (SCM_ARRAY_NDIM): Shift then cast so that the no sign extension takes place. * strings.h (SCM_STRING_LENGTH): Likewise. (SCM_STRING_MAX_LENGTH): Use unsigned numbers. --- libguile/strings.h | 4 ++-- libguile/unif.h | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/libguile/strings.h b/libguile/strings.h index 608467d52..fb44beaae 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -57,8 +57,8 @@ #define SCM_STRING_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) #endif #define SCM_SET_STRING_CHARS(s, c) (SCM_SET_CELL_WORD_1 ((s), (c))) -#define SCM_STRING_MAX_LENGTH ((1L << 24) - 1) -#define SCM_STRING_LENGTH(x) (((size_t) SCM_CELL_WORD_0 (x)) >> 8) +#define SCM_STRING_MAX_LENGTH ((1UL << 24) - 1UL) +#define SCM_STRING_LENGTH(x) ((size_t) (SCM_CELL_WORD_0 (x) >> 8)) #define SCM_SET_STRING_LENGTH(s, l) (SCM_SET_CELL_WORD_0 ((s), ((l) << 8) + scm_tc7_string)) #define SCM_STRING_COERCE_0TERMINATION_X(x) \ diff --git a/libguile/unif.h b/libguile/unif.h index 867c04427..131aa12b1 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -88,7 +88,7 @@ extern scm_bits_t scm_tc16_array; #endif #define SCM_ARRAYP(a) SCM_TYP16_PREDICATE (scm_tc16_array, a) -#define SCM_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x)) >> 17) +#define SCM_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x) >> 17)) #define SCM_ARRAY_CONTP(x) (SCM_CELL_WORD_0 (x) & SCM_ARRAY_FLAG_CONTIGUOUS) #define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \ (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | SCM_ARRAY_FLAG_CONTIGUOUS)) From 0f002b27a35fee320f4836a136de1ca7eae7342b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 14 Jun 2001 18:26:43 +0000 Subject: [PATCH 1318/2047] *** empty log message *** --- ice-9/ChangeLog | 5 +++++ libguile/ChangeLog | 5 +++++ srfi/ChangeLog | 4 ++++ 3 files changed, 14 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 546c44c82..8dddec587 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2001-06-14 Marius Vollmer + + * common-list.scm (remove-if, remove-if-not): Fix typo: use + `pred', not `pred?', in the body. + 2001-06-13 Thien-Thi Nguyen * match.scm: diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 4aae0a351..b6b0199de 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,10 @@ 2001-06-14 Marius Vollmer + * unif.h (SCM_ARRAY_NDIM): Shift then cast so that the no sign + extension takes place. + * strings.h (SCM_STRING_LENGTH): Likewise. + (SCM_STRING_MAX_LENGTH): Use unsigned numbers. + * __scm.h (ptrdiff_t): Typedef to long when configure didn't find it. diff --git a/srfi/ChangeLog b/srfi/ChangeLog index ea5726b38..09b08c67d 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,7 @@ +2001-06-14 Marius Vollmer + + * srfi-13.scm: Prevent `export' from re-exporting core bindings. + 2001-06-07 Dirk Herrmann * srfi-14.c (charset_print): Mark unused parameters with From 51fa276692198eb140365f60e516fbc8ff547f10 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 14 Jun 2001 18:26:58 +0000 Subject: [PATCH 1319/2047] Talk about kluge at top of srfi13.scm. --- RELEASE | 1 + 1 file changed, 1 insertion(+) diff --git a/RELEASE b/RELEASE index 6155e3901..d653a367b 100644 --- a/RELEASE +++ b/RELEASE @@ -25,6 +25,7 @@ After signal handling and threading have been fixed: - remove re-exporting behaviour of `export'. in boot-9.scm, remove begin-deprecated part of `module-export!' in format.scm, remove kluge at top + in srfi13.scm, likewise - remove deprecated subr and gsubr functions in procs.h, procs.c: scm_make_subr, scm_make_subr_opt, From 92c2555f6972b5fbc2236fe486e9432040b43812 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 14 Jun 2001 19:50:43 +0000 Subject: [PATCH 1320/2047] replace "scm_*_t" with "scm_t_*". --- libguile/arbiters.c | 2 +- libguile/async.c | 2 +- libguile/backtrace.c | 10 ++-- libguile/continuations.c | 30 +++++----- libguile/continuations.h | 12 ++-- libguile/coop-defs.h | 10 ++-- libguile/coop-threads.c | 24 ++++---- libguile/debug.c | 10 ++-- libguile/debug.h | 28 ++++----- libguile/dynl.c | 2 +- libguile/dynwind.c | 16 +++--- libguile/dynwind.h | 10 ++-- libguile/environments.c | 4 +- libguile/environments.h | 4 +- libguile/eval.c | 38 ++++++------ libguile/eval.h | 4 +- libguile/filesys.c | 6 +- libguile/filesys.h | 2 +- libguile/fluids.c | 2 +- libguile/fluids.h | 2 +- libguile/fports.c | 48 ++++++++-------- libguile/fports.h | 10 ++-- libguile/gc.c | 118 +++++++++++++++++++------------------- libguile/gc.h | 62 ++++++++++---------- libguile/gdbint.c | 2 +- libguile/gh.h | 8 +-- libguile/gh_eval.c | 16 +++--- libguile/gh_init.c | 4 +- libguile/goops.c | 8 +-- libguile/goops.h | 6 +- libguile/guardians.c | 2 +- libguile/hashtab.c | 20 +++---- libguile/hashtab.h | 6 +- libguile/hooks.c | 26 ++++----- libguile/hooks.h | 38 ++++++------ libguile/init.c | 2 +- libguile/ioext.c | 18 +++--- libguile/keywords.c | 2 +- libguile/keywords.h | 2 +- libguile/lang.c | 4 +- libguile/lang.h | 2 +- libguile/macros.c | 2 +- libguile/macros.h | 2 +- libguile/mallocs.c | 4 +- libguile/mallocs.h | 2 +- libguile/modules.c | 4 +- libguile/modules.h | 4 +- libguile/num2integral.i.c | 10 ++-- libguile/numbers.h | 16 +++--- libguile/options.c | 4 +- libguile/options.h | 10 ++-- libguile/ports.c | 110 +++++++++++++++++------------------ libguile/ports.h | 40 ++++++------- libguile/print.c | 4 +- libguile/print.h | 4 +- libguile/procs.c | 12 ++-- libguile/procs.h | 8 +-- libguile/ramap.c | 10 ++-- libguile/random.c | 40 ++++++------- libguile/random.h | 52 ++++++++--------- libguile/rdelim.c | 4 +- libguile/read.c | 2 +- libguile/read.h | 2 +- libguile/regex-posix.c | 2 +- libguile/regex-posix.h | 2 +- libguile/root.c | 8 +-- libguile/root.h | 8 +-- libguile/rw.c | 2 +- libguile/smob.c | 16 +++--- libguile/smob.h | 14 ++--- libguile/srcprop.c | 40 ++++++------- libguile/srcprop.h | 28 ++++----- libguile/stacks.c | 70 +++++++++++----------- libguile/stacks.h | 26 ++++----- libguile/strports.c | 24 ++++---- libguile/strports.h | 2 +- libguile/struct.c | 54 ++++++++--------- libguile/struct.h | 18 +++--- libguile/symbols.h | 2 +- libguile/tags.h | 20 +++---- libguile/threads.c | 6 +- libguile/threads.h | 10 ++-- libguile/throw.c | 18 +++--- libguile/throw.h | 16 +++--- libguile/unif.c | 38 ++++++------ libguile/unif.h | 22 +++---- libguile/variable.c | 2 +- libguile/variable.h | 2 +- libguile/vectors.c | 4 +- libguile/vectors.h | 2 +- libguile/vports.c | 12 ++-- 91 files changed, 718 insertions(+), 718 deletions(-) diff --git a/libguile/arbiters.c b/libguile/arbiters.c index faa0f4613..d655abfcd 100644 --- a/libguile/arbiters.c +++ b/libguile/arbiters.c @@ -59,7 +59,7 @@ * SCM_DEFER_INTS). */ -static scm_bits_t scm_tc16_arbiter; +static scm_t_bits scm_tc16_arbiter; #define SCM_ARB_LOCKED(arb) ((SCM_CELL_WORD_0 (arb)) & (1L << 16)) diff --git a/libguile/async.c b/libguile/async.c index ae3f5dcaf..d93ce7d1a 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -109,7 +109,7 @@ static unsigned int scm_desired_switch_rate = 0; int scm_asyncs_pending_p = 0; #endif -static scm_bits_t tc16_async; +static scm_t_bits tc16_async; diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 8ddc473df..0be2d0226 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -247,8 +247,8 @@ scm_i_display_error (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM r data.mode = "error"; data.port = port; scm_internal_catch (SCM_BOOL_T, - (scm_catch_body_t) display_error_body, &a, - (scm_catch_handler_t) display_error_handler, &data); + (scm_t_catch_body) display_error_body, &a, + (scm_t_catch_handler) display_error_handler, &data); } @@ -339,7 +339,7 @@ display_frame_expr (char *hdr,SCM exp,char *tlr,int indentation,SCM sport,SCM po { SCM string; int i = 0, n; - scm_ptob_descriptor_t *ptob = scm_ptobs + SCM_PTOBNUM (sport); + scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (sport); do { pstate->length = print_params[i].length; @@ -720,8 +720,8 @@ SCM_DEFINE (scm_display_backtrace, "display-backtrace", 2, 2, 0, data.mode = "backtrace"; data.port = port; scm_internal_catch (SCM_BOOL_T, - (scm_catch_body_t) display_backtrace_body, &a, - (scm_catch_handler_t) display_error_handler, &data); + (scm_t_catch_body) display_backtrace_body, &a, + (scm_t_catch_handler) display_error_handler, &data); return SCM_UNSPECIFIED; } #undef FUNC_NAME diff --git a/libguile/continuations.c b/libguile/continuations.c index 49f2890d8..3bf0f9074 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -66,12 +66,12 @@ /* {Continuations} */ -scm_bits_t scm_tc16_continuation; +scm_t_bits scm_tc16_continuation; static SCM continuation_mark (SCM obj) { - scm_contregs_t *continuation = SCM_CONTREGS (obj); + scm_t_contregs *continuation = SCM_CONTREGS (obj); scm_gc_mark (continuation->throw_value); scm_mark_locations (continuation->stack, continuation->num_stack_items); @@ -81,12 +81,12 @@ continuation_mark (SCM obj) static size_t continuation_free (SCM obj) { - scm_contregs_t *continuation = SCM_CONTREGS (obj); + scm_t_contregs *continuation = SCM_CONTREGS (obj); /* stack array size is 1 if num_stack_items is 0 (rootcont). */ size_t extra_items = (continuation->num_stack_items > 0) ? (continuation->num_stack_items - 1) : 0; - size_t bytes_free = sizeof (scm_contregs_t) + size_t bytes_free = sizeof (scm_t_contregs) + extra_items * sizeof (SCM_STACKITEM); scm_must_free (continuation); @@ -96,7 +96,7 @@ continuation_free (SCM obj) static int continuation_print (SCM obj, SCM port, scm_print_state *state SCM_UNUSED) { - scm_contregs_t *continuation = SCM_CONTREGS (obj); + scm_t_contregs *continuation = SCM_CONTREGS (obj); scm_puts ("#num_stack_items, 10, port); @@ -114,15 +114,15 @@ SCM scm_make_continuation (int *first) { volatile SCM cont; - scm_contregs_t *continuation; - scm_contregs_t *rootcont = SCM_CONTREGS (scm_rootcont); + scm_t_contregs *continuation; + scm_t_contregs *rootcont = SCM_CONTREGS (scm_rootcont); long stack_size; SCM_STACKITEM * src; SCM_ENTER_A_SECTION; SCM_FLUSH_REGISTER_WINDOWS; stack_size = scm_stack_size (rootcont->base); - continuation = scm_must_malloc (sizeof (scm_contregs_t) + continuation = scm_must_malloc (sizeof (scm_t_contregs) + (stack_size - 1) * sizeof (SCM_STACKITEM), FUNC_NAME); continuation->num_stack_items = stack_size; @@ -163,14 +163,14 @@ static void scm_dynthrow (SCM, SCM); * variable. */ -scm_bits_t scm_i_dummy; +scm_t_bits scm_i_dummy; static void grow_stack (SCM cont, SCM val) { - scm_bits_t growth[100]; + scm_t_bits growth[100]; - scm_i_dummy = (scm_bits_t) growth; + scm_i_dummy = (scm_t_bits) growth; scm_dynthrow (cont, val); } @@ -180,7 +180,7 @@ grow_stack (SCM cont, SCM val) * own frame are overwritten. Thus, memcpy can be used for best performance. */ static void -copy_stack_and_call (scm_contregs_t *continuation, SCM val, +copy_stack_and_call (scm_t_contregs *continuation, SCM val, SCM_STACKITEM * dst) { memcpy (dst, continuation->stack, @@ -202,7 +202,7 @@ copy_stack_and_call (scm_contregs_t *continuation, SCM val, static void scm_dynthrow (SCM cont, SCM val) { - scm_contregs_t *continuation = SCM_CONTREGS (cont); + scm_t_contregs *continuation = SCM_CONTREGS (cont); SCM_STACKITEM * dst = SCM_BASE (scm_rootcont); SCM_STACKITEM stack_top_element; @@ -224,8 +224,8 @@ static SCM continuation_apply (SCM cont, SCM args) #define FUNC_NAME "continuation_apply" { - scm_contregs_t *continuation = SCM_CONTREGS (cont); - scm_contregs_t *rootcont = SCM_CONTREGS (scm_rootcont); + scm_t_contregs *continuation = SCM_CONTREGS (cont); + scm_t_contregs *rootcont = SCM_CONTREGS (scm_rootcont); if (continuation->seq != rootcont->seq /* this base comparison isn't needed */ diff --git a/libguile/continuations.h b/libguile/continuations.h index 400eee326..85002ae44 100644 --- a/libguile/continuations.h +++ b/libguile/continuations.h @@ -50,12 +50,12 @@ /* a continuation SCM is a non-immediate pointing to a heap cell with: word 0: bits 0-15: unused. bits 16-31: smob type tag: scm_tc16_continuation. - word 1: malloc block containing an scm_contregs_t structure with a + word 1: malloc block containing an scm_t_contregs structure with a tail array of SCM_STACKITEM. the size of the array is stored in the num_stack_items field of the structure. */ -extern scm_bits_t scm_tc16_continuation; +extern scm_t_bits scm_tc16_continuation; typedef struct { @@ -69,18 +69,18 @@ typedef struct #ifdef DEBUG_EXTENSIONS /* the most recently created debug frame on the live stack, before it was saved. */ - struct scm_debug_frame_t *dframe; + struct scm_t_debug_frame *dframe; #endif SCM_STACKITEM stack[1]; /* copied stack of size num_stack_items. */ -} scm_contregs_t; +} scm_t_contregs; #if (SCM_DEBUG_DEPRECATED == 0) -# define scm_contregs scm_contregs_t +# define scm_contregs scm_t_contregs #endif #define SCM_CONTINUATIONP(x) SCM_TYP16_PREDICATE (scm_tc16_continuation, x) -#define SCM_CONTREGS(x) ((scm_contregs_t *) SCM_CELL_WORD_1 (x)) +#define SCM_CONTREGS(x) ((scm_t_contregs *) SCM_CELL_WORD_1 (x)) #define SCM_CONTINUATION_LENGTH(x) (SCM_CONTREGS (x)->num_stack_items) #define SCM_SET_CONTINUATION_LENGTH(x,n)\ diff --git a/libguile/coop-defs.h b/libguile/coop-defs.h index 6502b6480..86033ad37 100644 --- a/libguile/coop-defs.h +++ b/libguile/coop-defs.h @@ -143,7 +143,7 @@ typedef struct coop_m { typedef int coop_mattr; -typedef coop_m scm_mutex_t; +typedef coop_m scm_t_mutex; extern int coop_mutex_init (coop_m*); extern int coop_new_mutex_init (coop_m*, coop_mattr*); @@ -153,7 +153,7 @@ extern int coop_mutex_unlock (coop_m*); extern int coop_mutex_destroy (coop_m*); #define scm_mutex_init coop_mutex_init #define scm_mutex_lock coop_mutex_lock -#define scm_mutex_trylock coop_mutex_lock +#define scm_t_mutexrylock coop_mutex_lock #define scm_mutex_unlock coop_mutex_unlock #define scm_mutex_destroy coop_mutex_destroy @@ -166,7 +166,7 @@ typedef struct coop_c { typedef int coop_cattr; -typedef coop_c scm_cond_t; +typedef coop_c scm_t_cond; #ifndef HAVE_STRUCT_TIMESPEC /* POSIX.4 structure for a time value. This is like a `struct timeval' but @@ -188,14 +188,14 @@ extern int coop_condition_variable_signal (coop_c*); extern int coop_condition_variable_destroy (coop_c*); #define scm_cond_init coop_new_condition_variable_init #define scm_cond_wait coop_condition_variable_wait_mutex -#define scm_cond_timedwait coop_condition_variable_timed_wait_mutex +#define scm_t_condimedwait coop_condition_variable_timed_wait_mutex #define scm_cond_signal coop_condition_variable_signal #define scm_cond_broadcast coop_condition_variable_signal /* yes */ #define scm_cond_destroy coop_condition_variable_destroy typedef int coop_k; -typedef coop_k scm_key_t; +typedef coop_k scm_t_key; extern int coop_key_create (coop_k *keyp, void (*destruktor) (void *value)); extern int coop_setspecific (coop_k key, const void *value); diff --git a/libguile/coop-threads.c b/libguile/coop-threads.c index a003d5b41..0c9feb287 100644 --- a/libguile/coop-threads.c +++ b/libguile/coop-threads.c @@ -209,9 +209,9 @@ scheme_launch_thread (void *p) data.rootcont = SCM_BOOL_F; data.body = SCM_CADR (argl); data.handler = SCM_CADDR (argl); - scm_internal_cwdr ((scm_catch_body_t) scheme_body_bootstrip, + scm_internal_cwdr ((scm_t_catch_body) scheme_body_bootstrip, &data, - (scm_catch_handler_t) scheme_handler_bootstrip, + (scm_t_catch_handler) scheme_handler_bootstrip, &data, (SCM_STACKITEM *) &thread); SCM_SET_CELL_WORD_1 (thread, 0); @@ -269,7 +269,7 @@ scm_call_with_new_thread (SCM argl) argl variable may not exist in memory when the thread starts. */ t = coop_create (scheme_launch_thread, (void *) argl); t->data = SCM_ROOT_STATE (root); - SCM_SET_CELL_WORD_1 (thread, (scm_bits_t) t); + SCM_SET_CELL_WORD_1 (thread, (scm_t_bits) t); scm_thread_count++; /* Note that the following statement also could cause coop_yield.*/ SCM_ALLOW_INTS; @@ -293,9 +293,9 @@ typedef struct c_launch_data { SCM thread; SCM rootcont; } u; - scm_catch_body_t body; + scm_t_catch_body body; void *body_data; - scm_catch_handler_t handler; + scm_t_catch_handler handler; void *handler_data; } c_launch_data; @@ -323,9 +323,9 @@ c_launch_thread (void *p) /* We must use the address of `thread', otherwise the compiler will optimize it away. This is OK since the longest SCM_STACKITEM also is a long. */ - scm_internal_cwdr ((scm_catch_body_t) c_body_bootstrip, + scm_internal_cwdr ((scm_t_catch_body) c_body_bootstrip, data, - (scm_catch_handler_t) c_handler_bootstrip, + (scm_t_catch_handler) c_handler_bootstrip, data, (SCM_STACKITEM *) &thread); scm_thread_count--; @@ -333,8 +333,8 @@ c_launch_thread (void *p) } SCM -scm_spawn_thread (scm_catch_body_t body, void *body_data, - scm_catch_handler_t handler, void *handler_data) +scm_spawn_thread (scm_t_catch_body body, void *body_data, + scm_t_catch_handler handler, void *handler_data) { SCM thread; coop_t *t; @@ -362,7 +362,7 @@ scm_spawn_thread (scm_catch_body_t body, void *body_data, t = coop_create (c_launch_thread, (void *) data); t->data = SCM_ROOT_STATE (root); - SCM_SET_CELL_WORD_1 (thread, (scm_bits_t) t); + SCM_SET_CELL_WORD_1 (thread, (scm_t_bits) t); scm_thread_count++; /* Note that the following statement also could cause coop_yield.*/ SCM_ALLOW_INTS; @@ -423,7 +423,7 @@ scm_make_mutex (void) SCM m; coop_m *data = (coop_m *) scm_must_malloc (sizeof (coop_m), "mutex"); - SCM_NEWSMOB (m, scm_tc16_mutex, (scm_bits_t) data); + SCM_NEWSMOB (m, scm_tc16_mutex, (scm_t_bits) data); coop_mutex_init (data); return m; } @@ -454,7 +454,7 @@ scm_make_condition_variable (void) { SCM c; coop_c *data = (coop_c *) scm_must_malloc (sizeof (coop_c), "condvar"); - SCM_NEWSMOB (c, scm_tc16_condvar, (scm_bits_t) data); + SCM_NEWSMOB (c, scm_tc16_condvar, (scm_t_bits) data); coop_condition_variable_init (SCM_CONDVAR_DATA (c)); return c; } diff --git a/libguile/debug.c b/libguile/debug.c index bd0b4ba7f..29d259d60 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -147,7 +147,7 @@ SCM_SYMBOL (scm_sym_source, "source"); /* {Memoized Source} */ -scm_bits_t scm_tc16_memoized; +scm_t_bits scm_tc16_memoized; static int memoized_print (SCM obj, SCM port, scm_print_state *pstate) @@ -521,8 +521,8 @@ SCM scm_start_stack (SCM id, SCM exp, SCM env) { SCM answer; - scm_debug_frame_t vframe; - scm_debug_info_t vframe_vect_body; + scm_t_debug_frame vframe; + scm_t_debug_info vframe_vect_body; vframe.prev = scm_last_debug_frame; vframe.status = SCM_VOIDFRAME; vframe.vect = &vframe_vect_body; @@ -554,7 +554,7 @@ scm_m_start_stack (SCM exp, SCM env) * The debugging evaluator throws these on frame traps. */ -scm_bits_t scm_tc16_debugobj; +scm_t_bits scm_tc16_debugobj; static int debugobj_print (SCM obj, SCM port, scm_print_state *pstate SCM_UNUSED) @@ -576,7 +576,7 @@ SCM_DEFINE (scm_debug_object_p, "debug-object?", 1, 0, 0, SCM -scm_make_debugobj (scm_debug_frame_t *frame) +scm_make_debugobj (scm_t_debug_frame *frame) { register SCM z; SCM_NEWCELL (z); diff --git a/libguile/debug.h b/libguile/debug.h index 6a49a3aed..10a0cf69c 100644 --- a/libguile/debug.h +++ b/libguile/debug.h @@ -69,7 +69,7 @@ /* scm_debug_opts is defined in eval.c. */ -extern scm_option_t scm_debug_opts[]; +extern scm_t_option scm_debug_opts[]; #define SCM_CHEAPTRAPS_P scm_debug_opts[0].val #define SCM_BREAKPOINTS_P scm_debug_opts[1].val @@ -109,30 +109,30 @@ do {\ /* {Evaluator} */ -typedef union scm_debug_info_t +typedef union scm_t_debug_info { struct { SCM exp, env; } e; struct { SCM proc, args; } a; SCM id; -} scm_debug_info_t; +} scm_t_debug_info; extern long scm_debug_eframe_size; -typedef struct scm_debug_frame_t +typedef struct scm_t_debug_frame { - struct scm_debug_frame_t *prev; + struct scm_t_debug_frame *prev; long status; - scm_debug_info_t *vect; - scm_debug_info_t *info; -} scm_debug_frame_t; + scm_t_debug_info *vect; + scm_t_debug_info *info; +} scm_t_debug_frame; #if (SCM_DEBUG_DEPRECATED == 0) -# define scm_debug_info scm_debug_info_t -# define scm_debug_frame scm_debug_frame_t +# define scm_debug_info scm_t_debug_info +# define scm_debug_frame scm_t_debug_frame #endif #ifndef USE_THREADS -extern scm_debug_frame_t *scm_last_debug_frame; +extern scm_t_debug_frame *scm_last_debug_frame; #endif #define SCM_EVALFRAME (0L << 11) @@ -170,7 +170,7 @@ extern scm_debug_frame_t *scm_last_debug_frame; /* {Debug Objects} */ -extern scm_bits_t scm_tc16_debugobj; +extern scm_t_bits scm_tc16_debugobj; #define SCM_DEBUGOBJP(x) SCM_TYP16_PREDICATE (scm_tc16_debugobj, x) #define SCM_DEBUGOBJ_FRAME(x) SCM_CELL_WORD_1 (x) @@ -179,7 +179,7 @@ extern scm_bits_t scm_tc16_debugobj; /* {Memoized Source} */ -extern scm_bits_t scm_tc16_memoized; +extern scm_t_bits scm_tc16_memoized; #define SCM_MEMOIZEDP(x) SCM_TYP16_PREDICATE (scm_tc16_memoized, x) #define SCM_MEMOIZED_EXP(x) SCM_CAR (SCM_CELL_OBJECT_1 (x)) @@ -203,7 +203,7 @@ extern SCM scm_with_traps (SCM thunk); extern SCM scm_evaluator_traps (SCM setting); extern SCM scm_debug_options (SCM setting); extern SCM scm_unmemoize (SCM memoized); -extern SCM scm_make_debugobj (scm_debug_frame_t *debug); +extern SCM scm_make_debugobj (scm_t_debug_frame *debug); extern void scm_init_debug (void); #ifdef GUILE_DEBUG diff --git a/libguile/dynl.c b/libguile/dynl.c index b19ac070f..1bc797af9 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -330,7 +330,7 @@ sysdep_dynl_func (const char *symbol, #endif -scm_bits_t scm_tc16_dynamic_obj; +scm_t_bits scm_tc16_dynamic_obj; #define DYNL_FILENAME(x) (SCM_CELL_OBJECT_1 (x)) #define DYNL_HANDLE(x) ((void *) SCM_CELL_WORD_2 (x)) diff --git a/libguile/dynwind.c b/libguile/dynwind.c index 24d2e415f..f0777ab92 100644 --- a/libguile/dynwind.c +++ b/libguile/dynwind.c @@ -140,11 +140,11 @@ SCM_DEFINE (scm_dynamic_wind, "dynamic-wind", 3, 0, 0, */ #define SCM_GUARDSP(obj) SCM_TYP16_PREDICATE (tc16_guards, obj) -#define SCM_BEFORE_GUARD(obj) ((scm_guard_t) SCM_CELL_WORD (obj, 1)) -#define SCM_AFTER_GUARD(obj) ((scm_guard_t) SCM_CELL_WORD (obj, 2)) +#define SCM_BEFORE_GUARD(obj) ((scm_t_guard) SCM_CELL_WORD (obj, 1)) +#define SCM_AFTER_GUARD(obj) ((scm_t_guard) SCM_CELL_WORD (obj, 2)) #define SCM_GUARD_DATA(obj) ((void *) SCM_CELL_WORD (obj, 3)) -static scm_bits_t tc16_guards; +static scm_t_bits tc16_guards; static int guards_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) @@ -156,16 +156,16 @@ guards_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) } SCM -scm_internal_dynamic_wind (scm_guard_t before, - scm_inner_t inner, - scm_guard_t after, +scm_internal_dynamic_wind (scm_t_guard before, + scm_t_inner inner, + scm_t_guard after, void *inner_data, void *guard_data) { SCM guards, ans; before (guard_data); - SCM_NEWSMOB3 (guards, tc16_guards, (scm_bits_t) before, - (scm_bits_t) after, (scm_bits_t) guard_data); + SCM_NEWSMOB3 (guards, tc16_guards, (scm_t_bits) before, + (scm_t_bits) after, (scm_t_bits) guard_data); scm_dynwinds = scm_acons (guards, SCM_BOOL_F, scm_dynwinds); ans = inner (inner_data); scm_dynwinds = SCM_CDR (scm_dynwinds); diff --git a/libguile/dynwind.h b/libguile/dynwind.h index a8e888b23..9f457f636 100644 --- a/libguile/dynwind.h +++ b/libguile/dynwind.h @@ -47,13 +47,13 @@ -typedef void (*scm_guard_t) (void *); -typedef SCM (*scm_inner_t) (void *); +typedef void (*scm_t_guard) (void *); +typedef SCM (*scm_t_inner) (void *); extern SCM scm_dynamic_wind (SCM thunk1, SCM thunk2, SCM thunk3); -extern SCM scm_internal_dynamic_wind (scm_guard_t before, - scm_inner_t inner, - scm_guard_t after, +extern SCM scm_internal_dynamic_wind (scm_t_guard before, + scm_t_inner inner, + scm_t_guard after, void *inner_data, void *guard_data); extern void scm_dowinds (SCM to, long delta); diff --git a/libguile/environments.c b/libguile/environments.c index 211ce2816..ea6230ba9 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -56,8 +56,8 @@ -scm_bits_t scm_tc16_environment; -scm_bits_t scm_tc16_observer; +scm_t_bits scm_tc16_environment; +scm_t_bits scm_tc16_observer; #define DEFAULT_OBARRAY_SIZE 137 SCM scm_system_environment; diff --git a/libguile/environments.h b/libguile/environments.h index 7382bdb62..2103b383f 100644 --- a/libguile/environments.h +++ b/libguile/environments.h @@ -85,7 +85,7 @@ struct scm_environment_funcs { #define SCM_ENVIRONMENT_LOCATION_IMMUTABLE SCM_MAKINUM (1) #define SCM_ENVIRONMENT_LOCATION_NO_CELL SCM_BOOL_F -extern scm_bits_t scm_tc16_environment; +extern scm_t_bits scm_tc16_environment; #define SCM_ENVIRONMENT_P(x) \ (!SCM_IMP (x) && SCM_CELL_TYPE (x) == scm_tc16_environment) @@ -110,7 +110,7 @@ extern scm_bits_t scm_tc16_environment; #define SCM_ENVIRONMENT_UNOBSERVE(env, token) \ ((*(SCM_ENVIRONMENT_FUNCS (env)->unobserve)) (env, token)) -extern scm_bits_t scm_tc16_observer; +extern scm_t_bits scm_tc16_observer; #define SCM_OBSERVER_P(x) \ (!SCM_IMP (x) && (SCM_CELL_TYPE (x) == scm_tc16_observer)) diff --git a/libguile/eval.c b/libguile/eval.c index a45ae0851..fec45ac33 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1044,7 +1044,7 @@ scm_m_cont (SCM xorig, SCM env SCM_UNUSED) /* Multi-language support */ SCM_GLOBAL_SYMBOL (scm_lisp_nil, "nil"); -SCM_GLOBAL_SYMBOL (scm_lisp_t, "t"); +SCM_GLOBAL_SYMBOL (scm_t_lisp, "t"); SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond); @@ -1532,7 +1532,7 @@ scm_eval_args (SCM l, SCM env, SCM proc) } else if (SCM_TYP3 (l) == scm_tc3_cons_gloc) { - scm_bits_t vcell = + scm_t_bits vcell = SCM_STRUCT_VTABLE_DATA (l) [scm_vtable_index_vcell]; if (vcell == 0) res = SCM_CAR (l); /* struct planted in code */ @@ -1659,7 +1659,7 @@ SCM (*scm_ceval_ptr) (SCM x, SCM env); */ #ifndef USE_THREADS -scm_debug_frame_t *scm_last_debug_frame; +scm_t_debug_frame *scm_last_debug_frame; #endif /* scm_debug_eframe_size is the number of slots available for pseudo @@ -1672,11 +1672,11 @@ int scm_debug_mode, scm_check_entry_p, scm_check_apply_p, scm_check_exit_p; long scm_eval_stack; -scm_option_t scm_eval_opts[] = { +scm_t_option scm_eval_opts[] = { { SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." } }; -scm_option_t scm_debug_opts[] = { +scm_t_option scm_debug_opts[] = { { SCM_OPTION_BOOLEAN, "cheap", 1, "*Flyweight representation of the stack at traps." }, { SCM_OPTION_BOOLEAN, "breakpoints", 0, "*Check for breakpoints." }, @@ -1698,7 +1698,7 @@ scm_option_t scm_debug_opts[] = { { SCM_OPTION_SCM, "show-file-name", SCM_BOOL_T, "Show file names and line numbers in backtraces when not `#f'. A value of `base' displays only base names, while `#t' displays full names."} }; -scm_option_t scm_evaluator_trap_table[] = { +scm_t_option scm_evaluator_trap_table[] = { { SCM_OPTION_BOOLEAN, "traps", 0, "Enable evaluator traps." }, { SCM_OPTION_BOOLEAN, "enter-frame", 0, "Trap when eval enters new frame." }, { SCM_OPTION_BOOLEAN, "apply-frame", 0, "Trap when entering apply." }, @@ -1757,7 +1757,7 @@ scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc) } else if (SCM_TYP3 (l) == scm_tc3_cons_gloc) { - scm_bits_t vcell = + scm_t_bits vcell = SCM_STRUCT_VTABLE_DATA (l) [scm_vtable_index_vcell]; if (vcell == 0) res = SCM_CAR (l); /* struct planted in code */ @@ -1832,17 +1832,17 @@ SCM_CEVAL (SCM x, SCM env) } t; SCM proc, arg2, orig_sym; #ifdef DEVAL - scm_debug_frame_t debug; - scm_debug_info_t *debug_info_end; + scm_t_debug_frame debug; + scm_t_debug_info *debug_info_end; debug.prev = scm_last_debug_frame; debug.status = scm_debug_eframe_size; /* - * The debug.vect contains twice as much scm_debug_info_t frames as the + * The debug.vect contains twice as much scm_t_debug_info frames as the * user has specified with (debug-set! frames ). * * Even frames are eval frames, odd frames are apply frames. */ - debug.vect = (scm_debug_info_t *) alloca (scm_debug_eframe_size + debug.vect = (scm_t_debug_info *) alloca (scm_debug_eframe_size * sizeof (debug.vect[0])); debug.info = debug.vect; debug_info_end = debug.vect + scm_debug_eframe_size; @@ -2419,7 +2419,7 @@ dispatch: case (SCM_ISYMNUM (SCM_IM_T_IFY)): x = SCM_CDR (x); - RETURN (SCM_NFALSEP (EVALCAR (x, env)) ? scm_lisp_t : scm_lisp_nil) + RETURN (SCM_NFALSEP (EVALCAR (x, env)) ? scm_t_lisp : scm_lisp_nil) case (SCM_ISYMNUM (SCM_IM_0_COND)): proc = SCM_CDR (x); @@ -2554,7 +2554,7 @@ dispatch: case scm_tcs_cons_gloc: { - scm_bits_t vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell]; + scm_t_bits vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell]; if (vcell == 0) { /* This is a struct implanted in the code, not a gloc. */ RETURN (x); @@ -2766,7 +2766,7 @@ evapply: } else if (SCM_TYP3 (x) == scm_tc3_cons_gloc) { - scm_bits_t vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell]; + scm_t_bits vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell]; if (vcell == 0) t.arg1 = SCM_CAR (x); /* struct planted in code */ else @@ -2916,7 +2916,7 @@ evapply: } else if (SCM_TYP3 (x) == scm_tc3_cons_gloc) { - scm_bits_t vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell]; + scm_t_bits vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell]; if (vcell == 0) arg2 = SCM_CAR (x); /* struct planted in code */ else @@ -3323,8 +3323,8 @@ SCM_APPLY (SCM proc, SCM arg1, SCM args) { #ifdef DEBUG_EXTENSIONS #ifdef DEVAL - scm_debug_frame_t debug; - scm_debug_info_t debug_vect_body; + scm_t_debug_frame debug; + scm_t_debug_info debug_vect_body; debug.prev = scm_last_debug_frame; debug.status = SCM_APPLYFRAME; debug.vect = &debug_vect_body; @@ -3779,7 +3779,7 @@ scm_closure (SCM code, SCM env) } -scm_bits_t scm_tc16_promise; +scm_t_bits scm_tc16_promise; SCM scm_makprom (SCM code) @@ -4125,7 +4125,7 @@ scm_init_eval () #endif scm_c_define ("nil", scm_lisp_nil); - scm_c_define ("t", scm_lisp_t); + scm_c_define ("t", scm_t_lisp); scm_add_feature ("delay"); } diff --git a/libguile/eval.h b/libguile/eval.h index 4bd167f48..133d8b4c2 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -53,14 +53,14 @@ /* {Options} */ -extern scm_option_t scm_eval_opts[]; +extern scm_t_option scm_eval_opts[]; #define SCM_EVAL_STACK scm_eval_opts[0].val #define SCM_N_EVAL_OPTIONS 1 extern long scm_eval_stack; -extern scm_option_t scm_evaluator_trap_table[]; +extern scm_t_option scm_evaluator_trap_table[]; extern SCM scm_eval_options_interface (SCM setting); diff --git a/libguile/filesys.c b/libguile/filesys.c index 56b4737d1..913343234 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -686,7 +686,7 @@ SCM_DEFINE (scm_rmdir, "rmdir", 1, 0, 0, /* {Examining Directories} */ -scm_bits_t scm_tc16_dir; +scm_t_bits scm_tc16_dir; SCM_DEFINE (scm_directory_stream_p, "directory-stream?", 1, 0, 0, @@ -879,7 +879,7 @@ set_element (SELECT_TYPE *set, SCM *ports_ready, SCM element, int pos) if (pos == SCM_ARG1) { /* check whether port has buffered input. */ - scm_port_t *pt = SCM_PTAB_ENTRY (element); + scm_t_port *pt = SCM_PTAB_ENTRY (element); if (pt->read_pos < pt->read_end) use_buf = 1; @@ -887,7 +887,7 @@ set_element (SELECT_TYPE *set, SCM *ports_ready, SCM element, int pos) else if (pos == SCM_ARG2) { /* check whether port's output buffer has room. */ - scm_port_t *pt = SCM_PTAB_ENTRY (element); + scm_t_port *pt = SCM_PTAB_ENTRY (element); /* > 1 since writing the last byte in the buffer causes flush. */ if (pt->write_end - pt->write_pos > 1) diff --git a/libguile/filesys.h b/libguile/filesys.h index 549d71a05..0dbf8c2e2 100644 --- a/libguile/filesys.h +++ b/libguile/filesys.h @@ -51,7 +51,7 @@ -extern scm_bits_t scm_tc16_dir; +extern scm_t_bits scm_tc16_dir; #define SCM_DIR_FLAG_OPEN (1L << 16) diff --git a/libguile/fluids.c b/libguile/fluids.c index b3a12d666..07e944afc 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -57,7 +57,7 @@ #include "libguile/validate.h" static volatile long n_fluids; -scm_bits_t scm_tc16_fluid; +scm_t_bits scm_tc16_fluid; SCM scm_make_initial_fluids () diff --git a/libguile/fluids.h b/libguile/fluids.h index c80d1e696..aa11610d9 100644 --- a/libguile/fluids.h +++ b/libguile/fluids.h @@ -73,7 +73,7 @@ implement a more lightweight version of fluids on top of this basic mechanism. */ -extern scm_bits_t scm_tc16_fluid; +extern scm_t_bits scm_tc16_fluid; #define SCM_FLUIDP(x) (!SCM_IMP (x) && (SCM_CELL_TYPE (x) == scm_tc16_fluid)) #define SCM_FLUID_NUM(x) (SCM_CELL_WORD_1 (x)) diff --git a/libguile/fports.c b/libguile/fports.c index f5c63d0d0..42d8bd843 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -70,7 +70,7 @@ size_t fwrite (); #include "libguile/iselect.h" -scm_bits_t scm_tc16_fport; +scm_t_bits scm_tc16_fport; /* default buffer size, used if the O/S won't supply a value. */ @@ -82,8 +82,8 @@ static void scm_fport_buffer_add (SCM port, long read_size, int write_size) #define FUNC_NAME "scm_fport_buffer_add" { - scm_fport_t *fp = SCM_FSTREAM (port); - scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_t_fport *fp = SCM_FSTREAM (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); if (read_size == -1 || write_size == -1) { @@ -150,7 +150,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, { int cmode; long csize; - scm_port_t *pt; + scm_t_port *pt; port = SCM_COERCE_OUTPORT (port); @@ -205,13 +205,13 @@ scm_evict_ports (int fd) { long i; - for (i = 0; i < scm_port_table_size; i++) + for (i = 0; i < scm_t_portable_size; i++) { - SCM port = scm_port_table[i]->port; + SCM port = scm_t_portable[i]->port; if (SCM_FPORTP (port)) { - scm_fport_t *fp = SCM_FSTREAM (port); + scm_t_fport *fp = SCM_FSTREAM (port); if (fp->fdes == fd) { @@ -362,7 +362,7 @@ scm_fdes_to_port (int fdes, char *mode, SCM name) { long mode_bits = scm_mode_bits (mode); SCM port; - scm_port_t *pt; + scm_t_port *pt; int flags; /* test that fdes is valid. */ @@ -384,8 +384,8 @@ scm_fdes_to_port (int fdes, char *mode, SCM name) SCM_SET_CELL_TYPE (port, (scm_tc16_fport | mode_bits)); { - scm_fport_t *fp - = (scm_fport_t *) scm_must_malloc (sizeof (scm_fport_t), + scm_t_fport *fp + = (scm_t_fport *) scm_must_malloc (sizeof (scm_t_fport), FUNC_NAME); fp->fdes = fdes; @@ -506,8 +506,8 @@ static int fport_fill_input (SCM port) { long count; - scm_port_t *pt = SCM_PTAB_ENTRY (port); - scm_fport_t *fp = SCM_FSTREAM (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); + scm_t_fport *fp = SCM_FSTREAM (port); #ifdef GUILE_ISELECT fport_wait_for_input (port); @@ -528,8 +528,8 @@ fport_fill_input (SCM port) static off_t fport_seek (SCM port, off_t offset, int whence) { - scm_port_t *pt = SCM_PTAB_ENTRY (port); - scm_fport_t *fp = SCM_FSTREAM (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); + scm_t_fport *fp = SCM_FSTREAM (port); off_t rv; off_t result; @@ -580,7 +580,7 @@ fport_seek (SCM port, off_t offset, int whence) static void fport_truncate (SCM port, off_t length) { - scm_fport_t *fp = SCM_FSTREAM (port); + scm_t_fport *fp = SCM_FSTREAM (port); if (ftruncate (fp->fdes, length) == -1) scm_syserror ("ftruncate"); @@ -611,7 +611,7 @@ static void fport_write (SCM port, const void *data, size_t size) { /* this procedure tries to minimize the number of writes/flushes. */ - scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); if (pt->write_buf == &pt->shortbuf || (pt->write_pos == pt->write_buf && size >= pt->write_buf_size)) @@ -672,8 +672,8 @@ extern int terminating; static void fport_flush (SCM port) { - scm_port_t *pt = SCM_PTAB_ENTRY (port); - scm_fport_t *fp = SCM_FSTREAM (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); + scm_t_fport *fp = SCM_FSTREAM (port); unsigned char *ptr = pt->write_buf; long init_size = pt->write_pos - pt->write_buf; long remaining = init_size; @@ -730,8 +730,8 @@ fport_flush (SCM port) static void fport_end_input (SCM port, int offset) { - scm_fport_t *fp = SCM_FSTREAM (port); - scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_t_fport *fp = SCM_FSTREAM (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); offset += pt->read_end - pt->read_pos; @@ -749,8 +749,8 @@ fport_end_input (SCM port, int offset) static int fport_close (SCM port) { - scm_fport_t *fp = SCM_FSTREAM (port); - scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_t_fport *fp = SCM_FSTREAM (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); int rv; fport_flush (port); @@ -781,10 +781,10 @@ fport_free (SCM port) return 0; } -static scm_bits_t +static scm_t_bits scm_make_fptob () { - scm_bits_t tc = scm_make_port_type ("file", fport_fill_input, fport_write); + scm_t_bits tc = scm_make_port_type ("file", fport_fill_input, fport_write); scm_set_port_free (tc, fport_free); scm_set_port_print (tc, fport_print); diff --git a/libguile/fports.h b/libguile/fports.h index efdf81885..1feab7edc 100644 --- a/libguile/fports.h +++ b/libguile/fports.h @@ -54,17 +54,17 @@ /* struct allocated for each buffered FPORT. */ -typedef struct scm_fport_t { +typedef struct scm_t_fport { int fdes; /* file descriptor. */ -} scm_fport_t; +} scm_t_fport; #if (SCM_DEBUG_DEPRECATED == 0) -# define scm_fport scm_fport_t +# define scm_fport scm_t_fport #endif -extern scm_bits_t scm_tc16_fport; +extern scm_t_bits scm_tc16_fport; -#define SCM_FSTREAM(x) ((scm_fport_t *) SCM_STREAM (x)) +#define SCM_FSTREAM(x) ((scm_t_fport *) SCM_STREAM (x)) #define SCM_FPORT_FDES(x) (SCM_FSTREAM (x)->fdes) #define SCM_FPORTP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_fport)) diff --git a/libguile/gc.c b/libguile/gc.c index 29eee3392..dc14f5216 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -102,7 +102,7 @@ unsigned int scm_gc_running_p = 0; #if (SCM_DEBUG_CELL_ACCESSES == 1) -scm_bits_t scm_tc16_allocated; +scm_t_bits scm_tc16_allocated; /* Set this to != 0 if every cell that is accessed shall be checked: */ @@ -311,7 +311,7 @@ size_t scm_default_max_segment_size = 2097000L;/* a little less (adm) than 2 Mb /* scm_freelists */ -typedef struct scm_freelist_t { +typedef struct scm_t_freelist { /* collected cells */ SCM cells; /* number of cells left to collect before cluster is full */ @@ -344,14 +344,14 @@ typedef struct scm_freelist_t { * belonging to this list. */ unsigned long heap_size; -} scm_freelist_t; +} scm_t_freelist; SCM scm_freelist = SCM_EOL; -scm_freelist_t scm_master_freelist = { +scm_t_freelist scm_master_freelist = { SCM_EOL, 0, 0, SCM_EOL, 0, SCM_CLUSTER_SIZE_1, 0, 0, 0, 1, 0, 0, 0 }; SCM scm_freelist2 = SCM_EOL; -scm_freelist_t scm_master_freelist2 = { +scm_t_freelist scm_master_freelist2 = { SCM_EOL, 0, 0, SCM_EOL, 0, SCM_CLUSTER_SIZE_2, 0, 0, 0, 2, 0, 0, 0 }; @@ -412,25 +412,25 @@ SCM_SYMBOL (sym_times, "gc-times"); SCM_SYMBOL (sym_cells_marked, "cells-marked"); SCM_SYMBOL (sym_cells_swept, "cells-swept"); -typedef struct scm_heap_seg_data_t +typedef struct scm_t_heap_seg_data { /* lower and upper bounds of the segment */ SCM_CELLPTR bounds[2]; /* address of the head-of-freelist pointer for this segment's cells. All segments usually point to the same one, scm_freelist. */ - scm_freelist_t *freelist; + scm_t_freelist *freelist; /* number of cells per object in this segment */ int span; -} scm_heap_seg_data_t; +} scm_t_heap_seg_data; -static size_t init_heap_seg (SCM_CELLPTR, size_t, scm_freelist_t *); +static size_t init_heap_seg (SCM_CELLPTR, size_t, scm_t_freelist *); typedef enum { return_on_error, abort_on_error } policy_on_error; -static void alloc_some_heap (scm_freelist_t *, policy_on_error); +static void alloc_some_heap (scm_t_freelist *, policy_on_error); #define SCM_HEAP_SIZE \ @@ -439,30 +439,30 @@ static void alloc_some_heap (scm_freelist_t *, policy_on_error); #define BVEC_GROW_SIZE 256 #define BVEC_GROW_SIZE_IN_LIMBS (SCM_GC_CARD_BVEC_SIZE_IN_LIMBS * BVEC_GROW_SIZE) -#define BVEC_GROW_SIZE_IN_BYTES (BVEC_GROW_SIZE_IN_LIMBS * sizeof (scm_c_bvec_limb_t)) +#define BVEC_GROW_SIZE_IN_BYTES (BVEC_GROW_SIZE_IN_LIMBS * sizeof (scm_t_c_bvec_limb)) /* mark space allocation */ -typedef struct scm_mark_space_t +typedef struct scm_t_mark_space { - scm_c_bvec_limb_t *bvec_space; - struct scm_mark_space_t *next; -} scm_mark_space_t; + scm_t_c_bvec_limb *bvec_space; + struct scm_t_mark_space *next; +} scm_t_mark_space; -static scm_mark_space_t *current_mark_space; -static scm_mark_space_t **mark_space_ptr; +static scm_t_mark_space *current_mark_space; +static scm_t_mark_space **mark_space_ptr; static ptrdiff_t current_mark_space_offset; -static scm_mark_space_t *mark_space_head; +static scm_t_mark_space *mark_space_head; -static scm_c_bvec_limb_t * +static scm_t_c_bvec_limb * get_bvec () #define FUNC_NAME "get_bvec" { - scm_c_bvec_limb_t *res; + scm_t_c_bvec_limb *res; if (!current_mark_space) { - SCM_SYSCALL (current_mark_space = (scm_mark_space_t *) malloc (sizeof (scm_mark_space_t))); + SCM_SYSCALL (current_mark_space = (scm_t_mark_space *) malloc (sizeof (scm_t_mark_space))); if (!current_mark_space) SCM_MISC_ERROR ("could not grow heap", SCM_EOL); @@ -478,7 +478,7 @@ get_bvec () if (!(current_mark_space->bvec_space)) { SCM_SYSCALL (current_mark_space->bvec_space = - (scm_c_bvec_limb_t *) calloc (BVEC_GROW_SIZE_IN_BYTES, 1)); + (scm_t_c_bvec_limb *) calloc (BVEC_GROW_SIZE_IN_BYTES, 1)); if (!(current_mark_space->bvec_space)) SCM_MISC_ERROR ("could not grow heap", SCM_EOL); @@ -505,7 +505,7 @@ get_bvec () static void clear_mark_space () { - scm_mark_space_t *ms; + scm_t_mark_space *ms; for (ms = mark_space_head; ms; ms = ms->next) memset (ms->bvec_space, 0, BVEC_GROW_SIZE_IN_BYTES); @@ -534,7 +534,7 @@ which_seg (SCM cell) static void -map_free_list (scm_freelist_t *master, SCM freelist) +map_free_list (scm_t_freelist *master, SCM freelist) { long last_seg = -1, count = 0; SCM f; @@ -619,7 +619,7 @@ free_list_length (char *title, long i, SCM freelist) } static void -free_list_lengths (char *title, scm_freelist_t *master, SCM freelist) +free_list_lengths (char *title, scm_t_freelist *master, SCM freelist) { SCM clusters; long i = 0, len, n = 0; @@ -759,7 +759,7 @@ scm_debug_newcell2 (void) static unsigned long -master_cells_allocated (scm_freelist_t *master) +master_cells_allocated (scm_t_freelist *master) { /* the '- 1' below is to ignore the cluster spine cells. */ long objects = master->clusters_allocated * (master->cluster_size - 1); @@ -917,7 +917,7 @@ SCM_DEFINE (scm_gc, "gc", 0, 0, 0, */ static void -adjust_min_yield (scm_freelist_t *freelist) +adjust_min_yield (scm_t_freelist *freelist) { /* min yield is adjusted upwards so that next predicted total yield * (allocated cells actually freed by GC) becomes @@ -954,7 +954,7 @@ adjust_min_yield (scm_freelist_t *freelist) */ SCM -scm_gc_for_newcell (scm_freelist_t *master, SCM *freelist) +scm_gc_for_newcell (scm_t_freelist *master, SCM *freelist) { SCM cell; ++scm_ints_disabled; @@ -1018,7 +1018,7 @@ scm_gc_for_newcell (scm_freelist_t *master, SCM *freelist) */ void -scm_alloc_cluster (scm_freelist_t *master) +scm_alloc_cluster (scm_t_freelist *master) { SCM freelist, cell; cell = scm_gc_for_newcell (master, &freelist); @@ -1028,11 +1028,11 @@ scm_alloc_cluster (scm_freelist_t *master) #endif -scm_c_hook_t scm_before_gc_c_hook; -scm_c_hook_t scm_before_mark_c_hook; -scm_c_hook_t scm_before_sweep_c_hook; -scm_c_hook_t scm_after_sweep_c_hook; -scm_c_hook_t scm_after_gc_c_hook; +scm_t_c_hook scm_before_gc_c_hook; +scm_t_c_hook scm_before_mark_c_hook; +scm_t_c_hook scm_before_sweep_c_hook; +scm_t_c_hook scm_after_sweep_c_hook; +scm_t_c_hook scm_after_gc_c_hook; void @@ -1174,7 +1174,7 @@ MARK (SCM p) { register long i; register SCM ptr; - scm_bits_t cell_type; + scm_t_bits cell_type; #ifndef MARK_DEPENDENCIES # define RECURSE scm_gc_mark @@ -1267,8 +1267,8 @@ gc_mark_loop_first_time: * gloc, this location has the CDR of the variable smob, which * is guaranteed to be non-zero. */ - scm_bits_t word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_cons_gloc; - scm_bits_t * vtable_data = (scm_bits_t *) word0; /* access as struct */ + scm_t_bits word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_cons_gloc; + scm_t_bits * vtable_data = (scm_t_bits *) word0; /* access as struct */ if (vtable_data [scm_vtable_index_vcell] != 0) { /* ptr is a gloc */ @@ -1283,7 +1283,7 @@ gc_mark_loop_first_time: SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]); long len = SCM_SYMBOL_LENGTH (layout); char * fields_desc = SCM_SYMBOL_CHARS (layout); - scm_bits_t * struct_data = (scm_bits_t *) SCM_STRUCT_DATA (ptr); + scm_t_bits * struct_data = (scm_t_bits *) SCM_STRUCT_DATA (ptr); if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) { @@ -1600,7 +1600,7 @@ scm_cellp (SCM value) static void -gc_sweep_freelist_start (scm_freelist_t *freelist) +gc_sweep_freelist_start (scm_t_freelist *freelist) { freelist->cells = SCM_EOL; freelist->left_to_collect = freelist->cluster_size; @@ -1612,7 +1612,7 @@ gc_sweep_freelist_start (scm_freelist_t *freelist) } static void -gc_sweep_freelist_finish (scm_freelist_t *freelist) +gc_sweep_freelist_finish (scm_t_freelist *freelist) { long collected; *freelist->clustertail = freelist->cells; @@ -1651,7 +1651,7 @@ scm_gc_sweep () { register SCM_CELLPTR ptr; register SCM nfreelist; - register scm_freelist_t *freelist; + register scm_t_freelist *freelist; register unsigned long m; register int span; long i; @@ -1716,10 +1716,10 @@ scm_gc_sweep () * struct or a gloc. See the corresponding comment in * scm_gc_mark. */ - scm_bits_t word0 = (SCM_CELL_WORD_0 (scmptr) + scm_t_bits word0 = (SCM_CELL_WORD_0 (scmptr) - scm_tc3_cons_gloc); /* access as struct */ - scm_bits_t * vtable_data = (scm_bits_t *) word0; + scm_t_bits * vtable_data = (scm_t_bits *) word0; if (vtable_data[scm_vtable_index_vcell] == 0) { /* Structs need to be freed in a special order. @@ -1746,7 +1746,7 @@ scm_gc_sweep () unsigned long int length = SCM_VECTOR_LENGTH (scmptr); if (length > 0) { - m += length * sizeof (scm_bits_t); + m += length * sizeof (scm_t_bits); scm_must_free (SCM_VECTOR_BASE (scmptr)); } break; @@ -1829,7 +1829,7 @@ scm_gc_sweep () break; #endif /* def SCM_BIGDIG */ case scm_tc16_complex: - m += sizeof (scm_complex_t); + m += sizeof (scm_t_complex); scm_must_free (SCM_COMPLEX_MEM (scmptr)); break; default: @@ -2195,7 +2195,7 @@ size_t scm_max_segment_size; */ SCM_CELLPTR scm_heap_org; -scm_heap_seg_data_t * scm_heap_table = 0; +scm_t_heap_seg_data * scm_heap_table = 0; static size_t heap_segment_table_size = 0; size_t scm_n_heap_segs = 0; @@ -2218,7 +2218,7 @@ size_t scm_n_heap_segs = 0; } while (0) static size_t -init_heap_seg (SCM_CELLPTR seg_org, size_t size, scm_freelist_t *freelist) +init_heap_seg (SCM_CELLPTR seg_org, size_t size, scm_t_freelist *freelist) { register SCM_CELLPTR ptr; SCM_CELLPTR seg_end; @@ -2332,7 +2332,7 @@ init_heap_seg (SCM_CELLPTR seg_org, size_t size, scm_freelist_t *freelist) } static size_t -round_to_cluster_size (scm_freelist_t *freelist, size_t len) +round_to_cluster_size (scm_t_freelist *freelist, size_t len) { size_t cluster_size_in_bytes = CLUSTER_SIZE_IN_BYTES (freelist); @@ -2342,7 +2342,7 @@ round_to_cluster_size (scm_freelist_t *freelist, size_t len) } static void -alloc_some_heap (scm_freelist_t *freelist, policy_on_error error_policy) +alloc_some_heap (scm_t_freelist *freelist, policy_on_error error_policy) #define FUNC_NAME "alloc_some_heap" { SCM_CELLPTR ptr; @@ -2364,10 +2364,10 @@ alloc_some_heap (scm_freelist_t *freelist, policy_on_error error_policy) * init_heap_seg only if the allocation of the segment itself succeeds. */ size_t new_table_size = scm_n_heap_segs + 1; - size_t size = new_table_size * sizeof (scm_heap_seg_data_t); - scm_heap_seg_data_t *new_heap_table; + size_t size = new_table_size * sizeof (scm_t_heap_seg_data); + scm_t_heap_seg_data *new_heap_table; - SCM_SYSCALL (new_heap_table = ((scm_heap_seg_data_t *) + SCM_SYSCALL (new_heap_table = ((scm_t_heap_seg_data *) realloc ((char *)scm_heap_table, size))); if (!new_heap_table) { @@ -2707,7 +2707,7 @@ cleanup (int status, void *arg) static int -make_initial_segment (size_t init_heap_size, scm_freelist_t *freelist) +make_initial_segment (size_t init_heap_size, scm_t_freelist *freelist) { size_t rounded_size = round_to_cluster_size (freelist, init_heap_size); @@ -2734,7 +2734,7 @@ make_initial_segment (size_t init_heap_size, scm_freelist_t *freelist) static void -init_freelist (scm_freelist_t *freelist, +init_freelist (scm_t_freelist *freelist, int span, long cluster_size, int min_yield) @@ -2797,8 +2797,8 @@ scm_init_storage () j = SCM_HEAP_SEG_SIZE; scm_mtrigger = SCM_INIT_MALLOC_LIMIT; - scm_heap_table = ((scm_heap_seg_data_t *) - scm_must_malloc (sizeof (scm_heap_seg_data_t) * 2, "hplims")); + scm_heap_table = ((scm_t_heap_seg_data *) + scm_must_malloc (sizeof (scm_t_heap_seg_data) * 2, "hplims")); heap_segment_table_size = 2; mark_space_ptr = &mark_space_head; @@ -2819,9 +2819,9 @@ scm_init_storage () scm_c_hook_init (&scm_after_gc_c_hook, 0, SCM_C_HOOK_NORMAL); /* Initialise the list of ports. */ - scm_port_table = (scm_port_t **) - malloc (sizeof (scm_port_t *) * scm_port_table_room); - if (!scm_port_table) + scm_t_portable = (scm_t_port **) + malloc (sizeof (scm_t_port *) * scm_t_portable_room); + if (!scm_t_portable) return 1; #ifdef HAVE_ATEXIT diff --git a/libguile/gc.h b/libguile/gc.h index 9b4214325..07d2fe724 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -55,8 +55,8 @@ typedef struct scm_cell { - scm_bits_t word_0; - scm_bits_t word_1; + scm_t_bits word_0; + scm_t_bits word_1; } scm_cell; @@ -75,10 +75,10 @@ typedef scm_cell * SCM_CELLPTR; */ #ifdef _UNICOS # define SCM2PTR(x) ((SCM_CELLPTR) (SCM_UNPACK (x) >> 3)) -# define PTR2SCM(x) (SCM_PACK (((scm_bits_t) (x)) << 3)) +# define PTR2SCM(x) (SCM_PACK (((scm_t_bits) (x)) << 3)) #else # define SCM2PTR(x) ((SCM_CELLPTR) (SCM_UNPACK (x))) -# define PTR2SCM(x) (SCM_PACK ((scm_bits_t) (x))) +# define PTR2SCM(x) (SCM_PACK ((scm_t_bits) (x))) #endif /* def _UNICOS */ #define SCM_GC_CARD_N_HEADER_CELLS 1 @@ -93,13 +93,13 @@ typedef scm_cell * SCM_CELLPTR; #define SCM_GC_IN_CARD_HEADERP(x) \ SCM_PTR_LT ((scm_cell *) (x), SCM_GC_CELL_CARD (x) + SCM_GC_CARD_N_HEADER_CELLS) -#define SCM_GC_CARD_BVEC(card) ((scm_c_bvec_limb_t *) ((card)->word_0)) +#define SCM_GC_CARD_BVEC(card) ((scm_t_c_bvec_limb *) ((card)->word_0)) #define SCM_GC_SET_CARD_BVEC(card, bvec) \ - ((card)->word_0 = (scm_bits_t) (bvec)) + ((card)->word_0 = (scm_t_bits) (bvec)) #define SCM_GC_GET_CARD_FLAGS(card) ((long) ((card)->word_1)) #define SCM_GC_SET_CARD_FLAGS(card, flags) \ - ((card)->word_1 = (scm_bits_t) (flags)) + ((card)->word_1 = (scm_t_bits) (flags)) #define SCM_GC_CLR_CARD_FLAGS(card) (SCM_GC_SET_CARD_FLAGS (card, 0L)) #define SCM_GC_GET_CARD_FLAG(card, shift) (SCM_GC_GET_CARD_FLAGS (card) & (1L << (shift))) @@ -132,7 +132,7 @@ typedef scm_cell * SCM_CELLPTR; /* low level bit banging aids */ -typedef unsigned long scm_c_bvec_limb_t; +typedef unsigned long scm_t_c_bvec_limb; #if (SIZEOF_LONG == 8) # define SCM_C_BVEC_LIMB_BITS 64 @@ -153,7 +153,7 @@ typedef unsigned long scm_c_bvec_limb_t; #define SCM_C_BVEC_CLR(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] &= ~(1L << (pos & SCM_C_BVEC_POS_MASK))) #define SCM_C_BVEC_BITS2BYTES(bits) \ - (sizeof (scm_c_bvec_limb_t) * ((((bits) & SCM_C_BVEC_POS_MASK) ? 1L : 0L) + SCM_C_BVEC_OFFSET (bits))) + (sizeof (scm_t_c_bvec_limb) * ((((bits) & SCM_C_BVEC_POS_MASK) ? 1L : 0L) + SCM_C_BVEC_OFFSET (bits))) #define SCM_C_BVEC_SET_BYTES(bvec, bytes) (memset (bvec, 0xff, bytes)) #define SCM_C_BVEC_SET_ALL_BITS(bvec, bits) SCM_C_BVEC_SET_BYTES (bvec, SCM_C_BVEC_BITS2BYTES (bits)) @@ -177,28 +177,28 @@ typedef unsigned long scm_c_bvec_limb_t; #endif #define SCM_CELL_WORD(x, n) \ - SCM_VALIDATE_CELL ((x), ((const scm_bits_t *) SCM2PTR (x)) [n]) + SCM_VALIDATE_CELL ((x), ((const scm_t_bits *) SCM2PTR (x)) [n]) #define SCM_CELL_WORD_0(x) SCM_CELL_WORD (x, 0) #define SCM_CELL_WORD_1(x) SCM_CELL_WORD (x, 1) #define SCM_CELL_WORD_2(x) SCM_CELL_WORD (x, 2) #define SCM_CELL_WORD_3(x) SCM_CELL_WORD (x, 3) #define SCM_CELL_OBJECT(x, n) \ - SCM_VALIDATE_CELL ((x), SCM_PACK (((const scm_bits_t *) SCM2PTR (x)) [n])) + SCM_VALIDATE_CELL ((x), SCM_PACK (((const scm_t_bits *) SCM2PTR (x)) [n])) #define SCM_CELL_OBJECT_0(x) SCM_CELL_OBJECT (x, 0) #define SCM_CELL_OBJECT_1(x) SCM_CELL_OBJECT (x, 1) #define SCM_CELL_OBJECT_2(x) SCM_CELL_OBJECT (x, 2) #define SCM_CELL_OBJECT_3(x) SCM_CELL_OBJECT (x, 3) #define SCM_SET_CELL_WORD(x, n, v) \ - SCM_VALIDATE_CELL ((x), ((scm_bits_t *) SCM2PTR (x)) [n] = (scm_bits_t) (v)) + SCM_VALIDATE_CELL ((x), ((scm_t_bits *) SCM2PTR (x)) [n] = (scm_t_bits) (v)) #define SCM_SET_CELL_WORD_0(x, v) SCM_SET_CELL_WORD (x, 0, v) #define SCM_SET_CELL_WORD_1(x, v) SCM_SET_CELL_WORD (x, 1, v) #define SCM_SET_CELL_WORD_2(x, v) SCM_SET_CELL_WORD (x, 2, v) #define SCM_SET_CELL_WORD_3(x, v) SCM_SET_CELL_WORD (x, 3, v) #define SCM_SET_CELL_OBJECT(x, n, v) \ - SCM_VALIDATE_CELL ((x), ((scm_bits_t *) SCM2PTR (x)) [n] = SCM_UNPACK (v)) + SCM_VALIDATE_CELL ((x), ((scm_t_bits *) SCM2PTR (x)) [n] = SCM_UNPACK (v)) #define SCM_SET_CELL_OBJECT_0(x, v) SCM_SET_CELL_OBJECT (x, 0, v) #define SCM_SET_CELL_OBJECT_1(x, v) SCM_SET_CELL_OBJECT (x, 1, v) #define SCM_SET_CELL_OBJECT_2(x, v) SCM_SET_CELL_OBJECT (x, 2, v) @@ -215,10 +215,10 @@ typedef unsigned long scm_c_bvec_limb_t; * result in errors when in debug mode. */ #define SCM_GC_CELL_TYPE(x) \ - (((const scm_bits_t *) SCM2PTR (x)) [0]) + (((const scm_t_bits *) SCM2PTR (x)) [0]) -#define SCM_CELL_WORD_LOC(x, n) ((scm_bits_t *) & SCM_CELL_WORD (x, n)) +#define SCM_CELL_WORD_LOC(x, n) ((scm_t_bits *) & SCM_CELL_WORD (x, n)) #define SCM_CARLOC(x) ((SCM *) SCM_CELL_WORD_LOC ((x), 0)) #define SCM_CDRLOC(x) ((SCM *) SCM_CELL_WORD_LOC ((x), 1)) @@ -239,16 +239,16 @@ typedef unsigned long scm_c_bvec_limb_t; */ #define SCM_FREE_CELL_P(x) \ - (!SCM_IMP (x) && (* (const scm_bits_t *) SCM2PTR (x) == scm_tc_free_cell)) + (!SCM_IMP (x) && (* (const scm_t_bits *) SCM2PTR (x) == scm_tc_free_cell)) #define SCM_FREE_CELL_CDR(x) \ - (SCM_PACK (((const scm_bits_t *) SCM2PTR (x)) [1])) + (SCM_PACK (((const scm_t_bits *) SCM2PTR (x)) [1])) #define SCM_SET_FREE_CELL_CDR(x, v) \ - (((scm_bits_t *) SCM2PTR (x)) [1] = SCM_UNPACK (v)) + (((scm_t_bits *) SCM2PTR (x)) [1] = SCM_UNPACK (v)) #if (SCM_DEBUG_CELL_ACCESSES == 1) # define SCM_GC_SET_ALLOCATED(x) \ - (((scm_bits_t *) SCM2PTR (x)) [0] = scm_tc16_allocated) + (((scm_t_bits *) SCM2PTR (x)) [0] = scm_tc16_allocated) #else # define SCM_GC_SET_ALLOCATED(x) #endif @@ -296,11 +296,11 @@ typedef unsigned long scm_c_bvec_limb_t; #define SCM_NMARKEDP(x) (!SCM_MARKEDP (x)) #if (SCM_DEBUG_CELL_ACCESSES == 1) -extern scm_bits_t scm_tc16_allocated; +extern scm_t_bits scm_tc16_allocated; extern unsigned int scm_debug_cell_accesses_p; #endif -extern struct scm_heap_seg_data_t *scm_heap_table; +extern struct scm_t_heap_seg_data *scm_heap_table; extern size_t scm_n_heap_segs; extern int scm_block_gc; extern int scm_gc_heap_lock; @@ -316,9 +316,9 @@ extern size_t scm_default_max_segment_size; extern size_t scm_max_segment_size; extern SCM_CELLPTR scm_heap_org; extern SCM scm_freelist; -extern struct scm_freelist_t scm_master_freelist; +extern struct scm_t_freelist scm_master_freelist; extern SCM scm_freelist2; -extern struct scm_freelist_t scm_master_freelist2; +extern struct scm_t_freelist scm_master_freelist2; extern unsigned long scm_gc_cells_collected; extern unsigned long scm_gc_yield; extern unsigned long scm_gc_malloc_collected; @@ -329,11 +329,11 @@ extern unsigned long scm_mtrigger; extern SCM scm_after_gc_hook; -extern scm_c_hook_t scm_before_gc_c_hook; -extern scm_c_hook_t scm_before_mark_c_hook; -extern scm_c_hook_t scm_before_sweep_c_hook; -extern scm_c_hook_t scm_after_sweep_c_hook; -extern scm_c_hook_t scm_after_gc_c_hook; +extern scm_t_c_hook scm_before_gc_c_hook; +extern scm_t_c_hook scm_before_mark_c_hook; +extern scm_t_c_hook scm_before_sweep_c_hook; +extern scm_t_c_hook scm_after_sweep_c_hook; +extern scm_t_c_hook scm_after_gc_c_hook; #if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST) extern SCM scm_map_free_list (void); @@ -355,10 +355,10 @@ extern SCM scm_object_address (SCM obj); extern SCM scm_unhash_name (SCM name); extern SCM scm_gc_stats (void); extern SCM scm_gc (void); -extern void scm_gc_for_alloc (struct scm_freelist_t *freelist); -extern SCM scm_gc_for_newcell (struct scm_freelist_t *master, SCM *freelist); +extern void scm_gc_for_alloc (struct scm_t_freelist *freelist); +extern SCM scm_gc_for_newcell (struct scm_t_freelist *master, SCM *freelist); #if 0 -extern void scm_alloc_cluster (struct scm_freelist_t *master); +extern void scm_alloc_cluster (struct scm_t_freelist *master); #endif extern void scm_igc (const char *what); extern void scm_gc_mark (SCM p); diff --git a/libguile/gdbint.c b/libguile/gdbint.c index 4965de4f2..1f69ff2b2 100644 --- a/libguile/gdbint.c +++ b/libguile/gdbint.c @@ -277,7 +277,7 @@ gdb_print (SCM obj) scm_write (obj, gdb_output_port); scm_truncate_file (gdb_output_port, SCM_UNDEFINED); { - scm_port_t *pt = SCM_PTAB_ENTRY (gdb_output_port); + scm_t_port *pt = SCM_PTAB_ENTRY (gdb_output_port); scm_flush (gdb_output_port); *(pt->write_buf + pt->read_buf_size) = 0; diff --git a/libguile/gh.h b/libguile/gh.h index 6921d22e9..af1f952ed 100644 --- a/libguile/gh.h +++ b/libguile/gh.h @@ -61,19 +61,19 @@ extern "C" { void gh_enter(int argc, char *argv[], void (*c_main_prog)(int, char **)); #define gh_init () scm_init_guile () void gh_repl(int argc, char *argv[]); -SCM gh_catch(SCM tag, scm_catch_body_t body, void *body_data, - scm_catch_handler_t handler, void *handler_data); +SCM gh_catch(SCM tag, scm_t_catch_body body, void *body_data, + scm_t_catch_handler handler, void *handler_data); SCM gh_standard_handler(void *data, SCM tag, SCM throw_args); SCM gh_eval_str(const char *scheme_code); -SCM gh_eval_str_with_catch(const char *scheme_code, scm_catch_handler_t handler); +SCM gh_eval_str_with_catch(const char *scheme_code, scm_t_catch_handler handler); SCM gh_eval_str_with_standard_handler(const char *scheme_code); SCM gh_eval_str_with_stack_saving_handler(const char *scheme_code); SCM gh_eval_file(const char *fname); #define gh_load(fname) gh_eval_file(fname) -SCM gh_eval_file_with_catch(const char *scheme_code, scm_catch_handler_t handler); +SCM gh_eval_file_with_catch(const char *scheme_code, scm_t_catch_handler handler); SCM gh_eval_file_with_standard_handler(const char *scheme_code); #define gh_defer_ints() SCM_DEFER_INTS diff --git a/libguile/gh_eval.c b/libguile/gh_eval.c index 71c8f9350..e128e049a 100644 --- a/libguile/gh_eval.c +++ b/libguile/gh_eval.c @@ -70,11 +70,11 @@ eval_str_wrapper (void *data) } SCM -gh_eval_str_with_catch (const char *scheme_code, scm_catch_handler_t handler) +gh_eval_str_with_catch (const char *scheme_code, scm_t_catch_handler handler) { /* FIXME: not there yet */ - return gh_catch (SCM_BOOL_T, (scm_catch_body_t) eval_str_wrapper, (void *) scheme_code, - (scm_catch_handler_t) handler, (void *) scheme_code); + return gh_catch (SCM_BOOL_T, (scm_t_catch_body) eval_str_wrapper, (void *) scheme_code, + (scm_t_catch_handler) handler, (void *) scheme_code); } SCM @@ -87,9 +87,9 @@ SCM gh_eval_str_with_stack_saving_handler (const char *scheme_code) { return scm_internal_stack_catch (SCM_BOOL_T, - (scm_catch_body_t) eval_str_wrapper, + (scm_t_catch_body) eval_str_wrapper, (void *) scheme_code, - (scm_catch_handler_t) + (scm_t_catch_handler) gh_standard_handler, (void *) scheme_code); } @@ -104,11 +104,11 @@ eval_file_wrapper (void *data) } SCM -gh_eval_file_with_catch (const char *scheme_code, scm_catch_handler_t handler) +gh_eval_file_with_catch (const char *scheme_code, scm_t_catch_handler handler) { /* FIXME: not there yet */ - return gh_catch (SCM_BOOL_T, (scm_catch_body_t) eval_file_wrapper, - (void *) scheme_code, (scm_catch_handler_t) handler, + return gh_catch (SCM_BOOL_T, (scm_t_catch_body) eval_file_wrapper, + (void *) scheme_code, (scm_t_catch_handler) handler, (void *) scheme_code); } diff --git a/libguile/gh_init.c b/libguile/gh_init.c index 62b684d29..1454ef2fa 100644 --- a/libguile/gh_init.c +++ b/libguile/gh_init.c @@ -87,8 +87,8 @@ gh_repl (int argc, char *argv[]) error (or any thrown error if tag is SCM_BOOL_T); see ../libguile/throw.c for the comments explaining scm_internal_catch */ SCM -gh_catch (SCM tag, scm_catch_body_t body, void *body_data, - scm_catch_handler_t handler, void *handler_data) +gh_catch (SCM tag, scm_t_catch_body body, void *body_data, + scm_t_catch_handler handler, void *handler_data) { return scm_internal_catch (tag, body, body_data, handler, handler_data); } diff --git a/libguile/goops.c b/libguile/goops.c index b38acf89b..176cddec5 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -130,7 +130,7 @@ #define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND) static int goops_loaded_p = 0; -static scm_rstate_t *goops_rstate; +static scm_t_rstate *goops_rstate; static SCM scm_goops_lookup_closure; @@ -1290,7 +1290,7 @@ wrap_init (SCM class, SCM *m, long n) SCM_NEWCELL2 (z); SCM_SET_STRUCT_GC_CHAIN (z, 0); SCM_SET_CELL_WORD_1 (z, m); - SCM_SET_CELL_WORD_0 (z, (scm_bits_t) SCM_STRUCT_DATA (class) + SCM_SET_CELL_WORD_0 (z, (scm_t_bits) SCM_STRUCT_DATA (class) | scm_tc3_cons_gloc); return z; @@ -1462,11 +1462,11 @@ SCM_DEFINE (scm_sys_invalidate_class, "%invalidate-class", 1, 0, 0, * infinite recursions. */ -static scm_bits_t **hell; +static scm_t_bits **hell; static long n_hell = 1; /* one place for the evil one himself */ static long hell_size = 4; #ifdef USE_THREADS -static scm_mutex_t hell_mutex; +static scm_t_mutex hell_mutex; #endif static long diff --git a/libguile/goops.h b/libguile/goops.h index 175d0db40..574331144 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -88,13 +88,13 @@ #define scm_si_environment 26 /* The environment in which class is built */ #define SCM_N_CLASS_SLOTS 27 -typedef struct scm_method_t { +typedef struct scm_t_method { SCM generic_function; SCM specializers; SCM procedure; -} scm_method_t; +} scm_t_method; -#define SCM_METHOD(obj) ((scm_method_t *) SCM_STRUCT_DATA (obj)) +#define SCM_METHOD(obj) ((scm_t_method *) SCM_STRUCT_DATA (obj)) #define SCM_CLASSF_SIMPLE_METHOD (0x004 << 20) #define SCM_CLASSF_ACCESSOR_METHOD (0x008 << 20) diff --git a/libguile/guardians.c b/libguile/guardians.c index b62d8088d..d579948ae 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -102,7 +102,7 @@ do { \ } while (0) -static scm_bits_t tc16_guardian; +static scm_t_bits tc16_guardian; typedef struct guardian_t { diff --git a/libguile/hashtab.c b/libguile/hashtab.c index da802a5e1..442bfd644 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -366,17 +366,17 @@ SCM_DEFINE (scm_hash_remove_x, "hash-remove!", 2, 0, 0, -typedef struct scm_ihashx_closure_t +typedef struct scm_t_ihashx_closure { SCM hash; SCM assoc; SCM delete; -} scm_ihashx_closure_t; +} scm_t_ihashx_closure; static unsigned long -scm_ihashx (SCM obj, unsigned long n, scm_ihashx_closure_t *closure) +scm_ihashx (SCM obj, unsigned long n, scm_t_ihashx_closure *closure) { SCM answer; SCM_DEFER_INTS; @@ -390,7 +390,7 @@ scm_ihashx (SCM obj, unsigned long n, scm_ihashx_closure_t *closure) static SCM -scm_sloppy_assx (SCM obj, SCM alist, scm_ihashx_closure_t *closure) +scm_sloppy_assx (SCM obj, SCM alist, scm_t_ihashx_closure *closure) { SCM answer; SCM_DEFER_INTS; @@ -405,7 +405,7 @@ scm_sloppy_assx (SCM obj, SCM alist, scm_ihashx_closure_t *closure) static SCM -scm_delx_x (SCM obj, SCM alist, scm_ihashx_closure_t *closure) +scm_delx_x (SCM obj, SCM alist, scm_t_ihashx_closure *closure) { SCM answer; SCM_DEFER_INTS; @@ -428,7 +428,7 @@ SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0, "@code{assoc}, @code{assq} or @code{assv}.") #define FUNC_NAME s_scm_hashx_get_handle { - scm_ihashx_closure_t closure; + scm_t_ihashx_closure closure; closure.hash = hash; closure.assoc = assoc; return scm_hash_fn_get_handle (table, key, scm_ihashx, scm_sloppy_assx, @@ -447,7 +447,7 @@ SCM_DEFINE (scm_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0, "@code{assoc}, @code{assq} or @code{assv}.") #define FUNC_NAME s_scm_hashx_create_handle_x { - scm_ihashx_closure_t closure; + scm_t_ihashx_closure closure; closure.hash = hash; closure.assoc = assoc; return scm_hash_fn_create_handle_x (table, key, init, scm_ihashx, @@ -470,7 +470,7 @@ SCM_DEFINE (scm_hashx_ref, "hashx-ref", 4, 1, 0, "equivalent to @code{hashx-ref hashq assq table key}.") #define FUNC_NAME s_scm_hashx_ref { - scm_ihashx_closure_t closure; + scm_t_ihashx_closure closure; if (SCM_UNBNDP (dflt)) dflt = SCM_BOOL_F; closure.hash = hash; @@ -496,7 +496,7 @@ SCM_DEFINE (scm_hashx_set_x, "hashx-set!", 5, 0, 0, "equivalent to @code{hashx-set! hashq assq table key}.") #define FUNC_NAME s_scm_hashx_set_x { - scm_ihashx_closure_t closure; + scm_t_ihashx_closure closure; closure.hash = hash; closure.assoc = assoc; return scm_hash_fn_set_x (table, key, val, scm_ihashx, scm_sloppy_assx, @@ -509,7 +509,7 @@ SCM_DEFINE (scm_hashx_set_x, "hashx-set!", 5, 0, 0, SCM scm_hashx_remove_x (SCM hash, SCM assoc, SCM delete, SCM table, SCM obj) { - scm_ihashx_closure_t closure; + scm_t_ihashx_closure closure; closure.hash = hash; closure.assoc = assoc; closure.delete = delete; diff --git a/libguile/hashtab.h b/libguile/hashtab.h index 64a932c61..785626c84 100644 --- a/libguile/hashtab.h +++ b/libguile/hashtab.h @@ -48,9 +48,9 @@ #if 0 -typedef unsigned int scm_hash_fn_t (SCM obj, unsigned int d, void *closure); -typedef SCM scm_assoc_fn_t (SCM key, SCM alist, void *closure); -typedef SCM scm_delete_fn_t (SCM elt, SCM list); +typedef unsigned int scm_t_hash_fn (SCM obj, unsigned int d, void *closure); +typedef SCM scm_t_assoc_fn (SCM key, SCM alist, void *closure); +typedef SCM scm_t_delete_fn (SCM elt, SCM list); #endif extern SCM scm_c_make_hash_table (unsigned long k); diff --git a/libguile/hooks.c b/libguile/hooks.c index 737e92353..f0713f5eb 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -66,7 +66,7 @@ */ void -scm_c_hook_init (scm_c_hook_t *hook, void *hook_data, scm_c_hook_type_t type) +scm_c_hook_init (scm_t_c_hook *hook, void *hook_data, scm_t_c_hookype_t type) { hook->first = 0; hook->type = type; @@ -74,14 +74,14 @@ scm_c_hook_init (scm_c_hook_t *hook, void *hook_data, scm_c_hook_type_t type) } void -scm_c_hook_add (scm_c_hook_t *hook, - scm_c_hook_function_t func, +scm_c_hook_add (scm_t_c_hook *hook, + scm_t_c_hook_function func, void *func_data, int appendp) { - scm_c_hook_entry_t *entry = scm_must_malloc (sizeof (scm_c_hook_entry_t), + scm_t_c_hook_entry *entry = scm_must_malloc (sizeof (scm_t_c_hook_entry), "C level hook entry"); - scm_c_hook_entry_t **loc = &hook->first; + scm_t_c_hook_entry **loc = &hook->first; if (appendp) while (*loc) *loc = (*loc)->next; @@ -92,16 +92,16 @@ scm_c_hook_add (scm_c_hook_t *hook, } void -scm_c_hook_remove (scm_c_hook_t *hook, - scm_c_hook_function_t func, +scm_c_hook_remove (scm_t_c_hook *hook, + scm_t_c_hook_function func, void *func_data) { - scm_c_hook_entry_t **loc = &hook->first; + scm_t_c_hook_entry **loc = &hook->first; while (*loc) { if ((*loc)->func == func && (*loc)->data == func_data) { - scm_c_hook_entry_t *entry = *loc; + scm_t_c_hook_entry *entry = *loc; *loc = (*loc)->next; scm_must_free (entry); return; @@ -113,10 +113,10 @@ scm_c_hook_remove (scm_c_hook_t *hook, } void * -scm_c_hook_run (scm_c_hook_t *hook, void *data) +scm_c_hook_run (scm_t_c_hook *hook, void *data) { - scm_c_hook_entry_t *entry = hook->first; - scm_c_hook_type_t type = hook->type; + scm_t_c_hook_entry *entry = hook->first; + scm_t_c_hookype_t type = hook->type; void *res = 0; while (entry) { @@ -147,7 +147,7 @@ scm_c_hook_run (scm_c_hook_t *hook, void *data) * programs. */ -scm_bits_t scm_tc16_hook; +scm_t_bits scm_tc16_hook; static int diff --git a/libguile/hooks.h b/libguile/hooks.h index ff9d9d5d4..572330eef 100644 --- a/libguile/hooks.h +++ b/libguile/hooks.h @@ -58,45 +58,45 @@ * both may want to indicate success/failure and return a result. */ -typedef enum scm_c_hook_type_t { +typedef enum scm_t_c_hookype_t { SCM_C_HOOK_NORMAL, SCM_C_HOOK_OR, SCM_C_HOOK_AND -} scm_c_hook_type_t; +} scm_t_c_hookype_t; -typedef void *(*scm_c_hook_function_t) (void *hook_data, +typedef void *(*scm_t_c_hook_function) (void *hook_data, void *func_data, void *data); -typedef struct scm_c_hook_entry_t { - struct scm_c_hook_entry_t *next; - scm_c_hook_function_t func; +typedef struct scm_t_c_hook_entry { + struct scm_t_c_hook_entry *next; + scm_t_c_hook_function func; void *data; -} scm_c_hook_entry_t; +} scm_t_c_hook_entry; -typedef struct scm_c_hook_t { - scm_c_hook_entry_t *first; - scm_c_hook_type_t type; +typedef struct scm_t_c_hook { + scm_t_c_hook_entry *first; + scm_t_c_hookype_t type; void *data; -} scm_c_hook_t; +} scm_t_c_hook; -extern void scm_c_hook_init (scm_c_hook_t *hook, +extern void scm_c_hook_init (scm_t_c_hook *hook, void *hook_data, - scm_c_hook_type_t type); -extern void scm_c_hook_add (scm_c_hook_t *hook, - scm_c_hook_function_t func, + scm_t_c_hookype_t type); +extern void scm_c_hook_add (scm_t_c_hook *hook, + scm_t_c_hook_function func, void *func_data, int appendp); -extern void scm_c_hook_remove (scm_c_hook_t *hook, - scm_c_hook_function_t func, +extern void scm_c_hook_remove (scm_t_c_hook *hook, + scm_t_c_hook_function func, void *func_data); -extern void *scm_c_hook_run (scm_c_hook_t *hook, void *data); +extern void *scm_c_hook_run (scm_t_c_hook *hook, void *data); /* * Scheme level hooks */ -extern scm_bits_t scm_tc16_hook; +extern scm_t_bits scm_tc16_hook; #define SCM_HOOKP(x) SCM_TYP16_PREDICATE (scm_tc16_hook, x) #define SCM_HOOK_ARITY(hook) (SCM_CELL_WORD_0 (hook) >> 16) diff --git a/libguile/init.c b/libguile/init.c index 0c7e04578..97c8a67a1 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -189,7 +189,7 @@ start_stack (void *base) /* Create an object to hold the root continuation. */ { - scm_contregs_t *contregs = scm_must_malloc (sizeof (scm_contregs_t), + scm_t_contregs *contregs = scm_must_malloc (sizeof (scm_t_contregs), "continuation"); contregs->num_stack_items = 0; contregs->seq = 0; diff --git a/libguile/ioext.c b/libguile/ioext.c index ca51321d8..c8247d69e 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -90,7 +90,7 @@ SCM_DEFINE (scm_redirect_port, "redirect-port", 2, 0, 0, #define FUNC_NAME s_scm_redirect_port { int ans, oldfd, newfd; - scm_fport_t *fp; + scm_t_fport *fp; old = SCM_COERCE_OUTPORT (old); new = SCM_COERCE_OUTPORT (new); @@ -102,9 +102,9 @@ SCM_DEFINE (scm_redirect_port, "redirect-port", 2, 0, 0, newfd = fp->fdes; if (oldfd != newfd) { - scm_port_t *pt = SCM_PTAB_ENTRY (new); - scm_port_t *old_pt = SCM_PTAB_ENTRY (old); - scm_ptob_descriptor_t *ptob = &scm_ptobs[SCM_PTOBNUM (new)]; + scm_t_port *pt = SCM_PTAB_ENTRY (new); + scm_t_port *old_pt = SCM_PTAB_ENTRY (old); + scm_t_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (new)]; /* must flush to old fdes. */ if (pt->rw_active == SCM_PORT_WRITE) @@ -261,7 +261,7 @@ SCM_DEFINE (scm_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0, "required value or @code{#t} if it was moved.") #define FUNC_NAME s_scm_primitive_move_to_fdes { - scm_fport_t *stream; + scm_t_fport *stream; int old_fd; int new_fd; int rv; @@ -301,11 +301,11 @@ SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0, SCM_VALIDATE_INUM_COPY (1,fd,int_fd); - for (i = 0; i < scm_port_table_size; i++) + for (i = 0; i < scm_t_portable_size; i++) { - if (SCM_OPFPORTP (scm_port_table[i]->port) - && ((scm_fport_t *) scm_port_table[i]->stream)->fdes == int_fd) - result = scm_cons (scm_port_table[i]->port, result); + if (SCM_OPFPORTP (scm_t_portable[i]->port) + && ((scm_t_fport *) scm_t_portable[i]->stream)->fdes == int_fd) + result = scm_cons (scm_t_portable[i]->port, result); } return result; } diff --git a/libguile/keywords.c b/libguile/keywords.c index 36e0ce26e..0730979b2 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -56,7 +56,7 @@ #include "libguile/keywords.h" -scm_bits_t scm_tc16_keyword; +scm_t_bits scm_tc16_keyword; static int keyword_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) diff --git a/libguile/keywords.h b/libguile/keywords.h index 4bac54acc..ac35f294a 100644 --- a/libguile/keywords.h +++ b/libguile/keywords.h @@ -51,7 +51,7 @@ -extern scm_bits_t scm_tc16_keyword; +extern scm_t_bits scm_tc16_keyword; #define SCM_KEYWORDP(X) (!SCM_IMP (X) && (SCM_CELL_TYPE (X) == scm_tc16_keyword)) #define SCM_KEYWORDSYM(X) (SCM_CELL_OBJECT_1 (X)) diff --git a/libguile/lang.c b/libguile/lang.c index 82378e0ff..ee15c66ac 100644 --- a/libguile/lang.c +++ b/libguile/lang.c @@ -114,7 +114,7 @@ SCM_DEFINE (scm_null, "null", 1, 0, 0, "return LISP's nil otherwise.") #define FUNC_NAME s_scm_null { - return (SCM_NILP (x) || SCM_NULLP (x) || SCM_FALSEP (x)) ? scm_lisp_t : scm_lisp_nil; + return (SCM_NILP (x) || SCM_NULLP (x) || SCM_FALSEP (x)) ? scm_t_lisp : scm_lisp_nil; } #undef FUNC_NAME @@ -146,7 +146,7 @@ SCM_DEFINE1 (scm_nil_eq, "nil-eq", scm_tc7_rpsubr, return ((SCM_EQ_P (x, y) || (SCM_NILP (x) && (SCM_NULLP (y) || SCM_FALSEP (y))) || (SCM_NILP (y) && (SCM_NULLP (x) || SCM_FALSEP (x)))) - ? scm_lisp_t + ? scm_t_lisp : scm_lisp_nil); } #undef FUNC_NAME diff --git a/libguile/lang.h b/libguile/lang.h index f0514d0c6..dfae81970 100644 --- a/libguile/lang.h +++ b/libguile/lang.h @@ -49,7 +49,7 @@ extern SCM scm_lisp_nil; -extern SCM scm_lisp_t; +extern SCM scm_t_lisp; #define SCM_NILP(x) (SCM_EQ_P ((x), scm_lisp_nil)) #define SCM_NILNULLP(x) (SCM_NILP (x) || SCM_NULLP (x)) diff --git a/libguile/macros.c b/libguile/macros.c index 98b27d718..43ea53888 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -55,7 +55,7 @@ #include "libguile/validate.h" #include "libguile/macros.h" -scm_bits_t scm_tc16_macro; +scm_t_bits scm_tc16_macro; static int diff --git a/libguile/macros.h b/libguile/macros.h index ccc80dffd..2678d1c53 100644 --- a/libguile/macros.h +++ b/libguile/macros.h @@ -55,7 +55,7 @@ #define SCM_MACRO_TYPE(m) (SCM_CELL_WORD_0 (m) >> 16) #define SCM_MACRO_CODE(m) SCM_CELL_OBJECT_1 (m) -extern scm_bits_t scm_tc16_macro; +extern scm_t_bits scm_tc16_macro; extern SCM scm_makacro (SCM code); extern SCM scm_makmacro (SCM code); diff --git a/libguile/mallocs.c b/libguile/mallocs.c index 168f0632e..1801fbb7c 100644 --- a/libguile/mallocs.c +++ b/libguile/mallocs.c @@ -61,7 +61,7 @@ -scm_bits_t scm_tc16_malloc; +scm_t_bits scm_tc16_malloc; static size_t @@ -86,7 +86,7 @@ malloc_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) SCM scm_malloc_obj (size_t n) { - scm_bits_t mem = n ? (scm_bits_t) malloc (n) : 0; + scm_t_bits mem = n ? (scm_t_bits) malloc (n) : 0; if (n && !mem) return SCM_BOOL_F; SCM_RETURN_NEWSMOB (scm_tc16_malloc, mem); diff --git a/libguile/mallocs.h b/libguile/mallocs.h index f60622d8f..f62c245ab 100644 --- a/libguile/mallocs.h +++ b/libguile/mallocs.h @@ -46,7 +46,7 @@ #include "libguile/__scm.h" -extern scm_bits_t scm_tc16_malloc; +extern scm_t_bits scm_tc16_malloc; #define SCM_MALLOCP(X) (SCM_TYP16 (X) == scm_tc16_malloc) #define SCM_MALLOCDATA(obj) ((char *) SCM_CELL_WORD_1 (obj)) diff --git a/libguile/modules.c b/libguile/modules.c index 5e893dc9d..0e9fd0b4a 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -62,7 +62,7 @@ int scm_module_system_booted_p = 0; -scm_bits_t scm_module_tag; +scm_t_bits scm_module_tag; static SCM the_module; @@ -313,7 +313,7 @@ module_variable (SCM module, SCM sym) } } -scm_bits_t scm_tc16_eval_closure; +scm_t_bits scm_tc16_eval_closure; #define SCM_F_EVAL_CLOSURE_INTERFACE (1<<16) #define SCM_EVAL_CLOSURE_INTERFACE_P(e) \ diff --git a/libguile/modules.h b/libguile/modules.h index 2dd058524..55dd94744 100644 --- a/libguile/modules.h +++ b/libguile/modules.h @@ -51,7 +51,7 @@ extern int scm_module_system_booted_p; -extern scm_bits_t scm_module_tag; +extern scm_t_bits scm_module_tag; #define SCM_MODULEP(OBJ) \ (!SCM_IMP (OBJ) && SCM_CELL_TYPE (OBJ) == scm_module_tag) @@ -79,7 +79,7 @@ extern scm_bits_t scm_module_tag; #define SCM_MODULE_TRANSFORMER(module) \ SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_transformer]) -extern scm_bits_t scm_tc16_eval_closure; +extern scm_t_bits scm_tc16_eval_closure; #define SCM_EVAL_CLOSURE_P(x) SCM_TYP16_PREDICATE (scm_tc16_eval_closure, x) diff --git a/libguile/num2integral.i.c b/libguile/num2integral.i.c index a68fe5d87..5498c2828 100644 --- a/libguile/num2integral.i.c +++ b/libguile/num2integral.i.c @@ -6,22 +6,22 @@ NUM2INTEGRAL (SCM num, unsigned long int pos, const char *s_caller) if (SCM_INUMP (num)) { /* immediate */ - scm_bits_t n = SCM_INUM (num); + scm_t_bits n = SCM_INUM (num); #ifdef UNSIGNED if (n < 0) scm_out_of_range (s_caller, num); #endif - if (sizeof (ITYPE) >= sizeof (scm_bits_t)) + if (sizeof (ITYPE) >= sizeof (scm_t_bits)) /* can't fit anything too big for this type in an inum anyway */ return (ITYPE) n; else { /* an inum can be out of range, so check */ - if (n > (scm_bits_t)MAX_VALUE + if (n > (scm_t_bits)MAX_VALUE #ifndef UNSIGNED - || n < (scm_bits_t)MIN_VALUE + || n < (scm_t_bits)MIN_VALUE #endif ) scm_out_of_range (s_caller, num); @@ -84,7 +84,7 @@ NUM2INTEGRAL (SCM num, unsigned long int pos, const char *s_caller) SCM INTEGRAL2NUM (ITYPE n) { - if (sizeof (ITYPE) < sizeof (scm_bits_t) + if (sizeof (ITYPE) < sizeof (scm_t_bits) || #ifndef UNSIGNED SCM_FIXABLE (n) diff --git a/libguile/numbers.h b/libguile/numbers.h index 93e2c4bf9..6b33ff1e9 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -69,7 +69,7 @@ /* SCM_SRS is signed right shift */ #if (-1 == (((-1) << 2) + 2) >> 2) -# define SCM_SRS(x, y) ((scm_signed_bits_t)(x) >> (y)) +# define SCM_SRS(x, y) ((scm_t_signed_bits)(x) >> (y)) #else # define SCM_SRS(x, y) ((SCM_UNPACK (x) < 0) ? ~((~SCM_UNPACK (x)) >> (y)) : (SCM_UNPACK (x) >> (y))) #endif /* (-1 == (((-1) << 2) + 2) >> 2) */ @@ -78,7 +78,7 @@ #define SCM_INUMP(x) (2 & SCM_UNPACK (x)) #define SCM_NINUMP(x) (!SCM_INUMP (x)) #define SCM_MAKINUM(x) (SCM_PACK (((x) << 2) + 2L)) -#define SCM_INUM(x) ((scm_signed_bits_t)(SCM_SRS (SCM_UNPACK (x), 2))) +#define SCM_INUM(x) ((scm_t_signed_bits)(SCM_SRS (SCM_UNPACK (x), 2))) /* SCM_FIXABLE is true if its long argument can be encoded in an SCM_INUM. */ @@ -129,8 +129,8 @@ #define SCM_REALP(x) (SCM_NIMP (x) && SCM_TYP16 (x) == scm_tc16_real) #define SCM_COMPLEXP(x) (SCM_NIMP (x) && SCM_TYP16 (x) == scm_tc16_complex) -#define SCM_REAL_VALUE(x) (((scm_double_t *) SCM2PTR (x))->real) -#define SCM_COMPLEX_MEM(x) ((scm_complex_t *) SCM_CELL_WORD_1 (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)) #define SCM_COMPLEX_REAL(x) (SCM_COMPLEX_MEM (x)->real) #define SCM_COMPLEX_IMAG(x) (SCM_COMPLEX_MEM (x)->imag) @@ -186,18 +186,18 @@ -typedef struct scm_double_t +typedef struct scm_t_double { SCM type; SCM pad; double real; -} scm_double_t; +} scm_t_double; -typedef struct scm_complex_t +typedef struct scm_t_complex { double real; double imag; -} scm_complex_t; +} scm_t_complex; diff --git a/libguile/options.c b/libguile/options.c index f363ce866..ffdb0ff72 100644 --- a/libguile/options.c +++ b/libguile/options.c @@ -121,7 +121,7 @@ SCM_SYMBOL (scm_no_sym, "no"); static SCM protected_objects; SCM -scm_options (SCM arg, scm_option_t options[], int n, const char *s) +scm_options (SCM arg, scm_t_option options[], int n, const char *s) { int i, docp = (!SCM_UNBNDP (arg) && !SCM_NULLP (arg) && !SCM_CONSP (arg)); /* Let `arg' GC protect the arguments */ @@ -212,7 +212,7 @@ scm_options (SCM arg, scm_option_t options[], int n, const char *s) void -scm_init_opts (SCM (*func) (SCM), scm_option_t options[], int n) +scm_init_opts (SCM (*func) (SCM), scm_t_option options[], int n) { int i; diff --git a/libguile/options.h b/libguile/options.h index 5ff2c4fa3..899f5eed5 100644 --- a/libguile/options.h +++ b/libguile/options.h @@ -51,7 +51,7 @@ -typedef struct scm_option_t +typedef struct scm_t_option { int type; char *name; @@ -62,10 +62,10 @@ typedef struct scm_option_t unsigned long val; /* SCM val */ char *doc; -} scm_option_t; +} scm_t_option; #if (SCM_DEBUG_DEPRECATED == 0) -# define scm_option scm_option_t +# define scm_option scm_t_option #endif #define SCM_OPTION_BOOLEAN 0 @@ -73,8 +73,8 @@ typedef struct scm_option_t #define SCM_OPTION_SCM 2 -extern SCM scm_options (SCM new_mode, scm_option_t options[], int n, const char *s); -extern void scm_init_opts (SCM (*func) (SCM), scm_option_t options[], int n); +extern SCM scm_options (SCM new_mode, scm_t_option options[], int n, const char *s); +extern void scm_init_opts (SCM (*func) (SCM), scm_t_option options[], int n); extern void scm_init_options (void); #endif /* OPTIONSH */ diff --git a/libguile/ports.c b/libguile/ports.c index b8d6fd221..56c0b37fc 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -86,7 +86,7 @@ * Indexes into this table are used when generating type * tags for smobjects (if you know a tag you can get an index and conversely). */ -scm_ptob_descriptor_t *scm_ptobs; +scm_t_ptob_descriptor *scm_ptobs; long scm_numptob; /* GC marker for a port with stream of SCM type. */ @@ -117,7 +117,7 @@ end_input_default (SCM port SCM_UNUSED, int offset SCM_UNUSED) { } -scm_bits_t +scm_t_bits scm_make_port_type (char *name, int (*fill_input) (SCM port), void (*write) (SCM port, const void *data, size_t size)) @@ -128,10 +128,10 @@ scm_make_port_type (char *name, SCM_DEFER_INTS; SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_ptobs, (1 + scm_numptob) - * sizeof (scm_ptob_descriptor_t))); + * sizeof (scm_t_ptob_descriptor))); if (tmp) { - scm_ptobs = (scm_ptob_descriptor_t *) tmp; + scm_ptobs = (scm_t_ptob_descriptor *) tmp; scm_ptobs[scm_numptob].name = name; scm_ptobs[scm_numptob].mark = 0; @@ -246,7 +246,7 @@ SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0, "interactive port that has no ready characters.}") #define FUNC_NAME s_scm_char_ready_p { - scm_port_t *pt; + scm_t_port *pt; if (SCM_UNBNDP (port)) port = scm_cur_inp; @@ -264,7 +264,7 @@ SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0, return SCM_BOOL_T; else { - scm_ptob_descriptor_t *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; + scm_t_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; if (ptob->input_waiting) return SCM_BOOL(ptob->input_waiting (port)); @@ -278,7 +278,7 @@ SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0, into memory starting at dest. returns the number of chars moved. */ size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len) { - scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); size_t chars_read = 0; size_t from_buf = min (pt->read_end - pt->read_pos, read_len); @@ -313,7 +313,7 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, #define FUNC_NAME s_scm_drain_input { SCM result; - scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); long count; SCM_VALIDATE_OPINPORT (1,port); @@ -422,35 +422,35 @@ SCM_DEFINE (scm_set_current_error_port, "set-current-error-port", 1, 0, 0, /* The port table --- an array of pointers to ports. */ -scm_port_t **scm_port_table; +scm_t_port **scm_t_portable; -long scm_port_table_size = 0; /* Number of ports in scm_port_table. */ -long scm_port_table_room = 20; /* Size of the array. */ +long scm_t_portable_size = 0; /* Number of ports in scm_t_portable. */ +long scm_t_portable_room = 20; /* Size of the array. */ /* Add a port to the table. */ -scm_port_t * +scm_t_port * scm_add_to_port_table (SCM port) #define FUNC_NAME "scm_add_to_port_table" { - scm_port_t *entry; + scm_t_port *entry; - if (scm_port_table_size == scm_port_table_room) + if (scm_t_portable_size == scm_t_portable_room) { /* initial malloc is in gc.c. this doesn't use scm_must_malloc etc., since it can never be freed during gc. */ - void *newt = realloc ((char *) scm_port_table, - (size_t) (sizeof (scm_port_t *) - * scm_port_table_room * 2)); + void *newt = realloc ((char *) scm_t_portable, + (size_t) (sizeof (scm_t_port *) + * scm_t_portable_room * 2)); if (newt == NULL) scm_memory_error ("scm_add_to_port_table"); - scm_port_table = (scm_port_t **) newt; - scm_port_table_room *= 2; + scm_t_portable = (scm_t_port **) newt; + scm_t_portable_room *= 2; } - entry = (scm_port_t *) scm_must_malloc (sizeof (scm_port_t), FUNC_NAME); + entry = (scm_t_port *) scm_must_malloc (sizeof (scm_t_port), FUNC_NAME); entry->port = port; - entry->entry = scm_port_table_size; + entry->entry = scm_t_portable_size; entry->revealed = 0; entry->stream = 0; entry->file_name = SCM_BOOL_F; @@ -461,8 +461,8 @@ scm_add_to_port_table (SCM port) entry->rw_active = SCM_PORT_NEITHER; entry->rw_random = 0; - scm_port_table[scm_port_table_size] = entry; - scm_port_table_size++; + scm_t_portable[scm_t_portable_size] = entry; + scm_t_portable_size++; return entry; } @@ -474,23 +474,23 @@ void scm_remove_from_port_table (SCM port) #define FUNC_NAME "scm_remove_from_port_table" { - scm_port_t *p = SCM_PTAB_ENTRY (port); + scm_t_port *p = SCM_PTAB_ENTRY (port); long i = p->entry; - if (i >= scm_port_table_size) + if (i >= scm_t_portable_size) SCM_MISC_ERROR ("Port not in table: ~S", SCM_LIST1 (port)); if (p->putback_buf) scm_must_free (p->putback_buf); scm_must_free (p); /* Since we have just freed slot i we can shrink the table by moving the last entry to that slot... */ - if (i < scm_port_table_size - 1) + if (i < scm_t_portable_size - 1) { - scm_port_table[i] = scm_port_table[scm_port_table_size - 1]; - scm_port_table[i]->entry = i; + scm_t_portable[i] = scm_t_portable[scm_t_portable_size - 1]; + scm_t_portable[i]->entry = i; } SCM_SETPTAB_ENTRY (port, 0); - scm_port_table_size--; + scm_t_portable_size--; } #undef FUNC_NAME @@ -504,7 +504,7 @@ SCM_DEFINE (scm_pt_size, "pt-size", 0, 0, 0, "is only included in @code{--enable-guile-debug} builds.") #define FUNC_NAME s_scm_pt_size { - return SCM_MAKINUM (scm_port_table_size); + return SCM_MAKINUM (scm_t_portable_size); } #undef FUNC_NAME @@ -517,16 +517,16 @@ SCM_DEFINE (scm_pt_member, "pt-member", 1, 0, 0, { long i; SCM_VALIDATE_INUM_COPY (1,index,i); - if (i < 0 || i >= scm_port_table_size) + if (i < 0 || i >= scm_t_portable_size) return SCM_BOOL_F; else - return scm_port_table[i]->port; + return scm_t_portable[i]->port; } #undef FUNC_NAME #endif void -scm_port_non_buffer (scm_port_t *pt) +scm_port_non_buffer (scm_t_port *pt) { pt->read_pos = pt->read_buf = pt->read_end = &pt->shortbuf; pt->write_buf = pt->write_pos = &pt->shortbuf; @@ -725,8 +725,8 @@ SCM_DEFINE (scm_port_for_each, "port-for-each", 1, 0, 0, SCM_DEFER_INTS; scm_block_gc++; ports = SCM_EOL; - for (i = 0; i < scm_port_table_size; i++) - ports = scm_cons (scm_port_table[i]->port, ports); + for (i = 0; i < scm_t_portable_size; i++) + ports = scm_cons (scm_t_portable[i]->port, ports); scm_block_gc--; SCM_ALLOW_INTS; @@ -754,9 +754,9 @@ SCM_DEFINE (scm_close_all_ports_except, "close-all-ports-except", 0, 0, 1, { long i = 0; SCM_VALIDATE_REST_ARGUMENT (ports); - while (i < scm_port_table_size) + while (i < scm_t_portable_size) { - SCM thisport = scm_port_table[i]->port; + SCM thisport = scm_t_portable[i]->port; int found = 0; SCM ports_ptr = ports; @@ -874,10 +874,10 @@ SCM_DEFINE (scm_flush_all_ports, "flush-all-ports", 0, 0, 0, { size_t i; - for (i = 0; i < scm_port_table_size; i++) + for (i = 0; i < scm_t_portable_size; i++) { - if (SCM_OPOUTPORTP (scm_port_table[i]->port)) - scm_flush (scm_port_table[i]->port); + if (SCM_OPOUTPORTP (scm_t_portable[i]->port)) + scm_flush (scm_t_portable[i]->port); } return SCM_UNSPECIFIED; } @@ -907,7 +907,7 @@ SCM_DEFINE (scm_read_char, "read-char", 0, 1, 0, int scm_fill_input (SCM port) { - scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); if (pt->read_buf == pt->putback_buf) { @@ -926,7 +926,7 @@ int scm_getc (SCM port) { int c; - scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); if (pt->rw_active == SCM_PORT_WRITE) { @@ -981,8 +981,8 @@ scm_puts (const char *s, SCM port) void scm_lfwrite (const char *ptr, size_t size, SCM port) { - scm_port_t *pt = SCM_PTAB_ENTRY (port); - scm_ptob_descriptor_t *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; + scm_t_port *pt = SCM_PTAB_ENTRY (port); + scm_t_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; if (pt->rw_active == SCM_PORT_READ) scm_end_input (port); @@ -1016,7 +1016,7 @@ scm_lfwrite (const char *ptr, size_t size, SCM port) size_t scm_c_read (SCM port, void *buffer, size_t size) { - scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); size_t n_read = 0, n_available; if (pt->rw_active == SCM_PORT_WRITE) @@ -1069,8 +1069,8 @@ scm_c_read (SCM port, void *buffer, size_t size) void scm_c_write (SCM port, const void *ptr, size_t size) { - scm_port_t *pt = SCM_PTAB_ENTRY (port); - scm_ptob_descriptor_t *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; + scm_t_port *pt = SCM_PTAB_ENTRY (port); + scm_t_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; if (pt->rw_active == SCM_PORT_READ) scm_end_input (port); @@ -1092,7 +1092,7 @@ void scm_end_input (SCM port) { long offset; - scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); if (pt->read_buf == pt->putback_buf) { @@ -1115,7 +1115,7 @@ void scm_ungetc (int c, SCM port) #define FUNC_NAME "scm_ungetc" { - scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); if (pt->read_buf == pt->putback_buf) /* already using the put-back buffer. */ @@ -1311,7 +1311,7 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, SCM_OUT_OF_RANGE (3, whence); if (SCM_OPPORTP (fd_port)) { - scm_ptob_descriptor_t *ptob = scm_ptobs + SCM_PTOBNUM (fd_port); + scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (fd_port); if (!ptob->seek) SCM_MISC_ERROR ("port is not seekable", @@ -1364,8 +1364,8 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, } else if (SCM_OPOUTPORTP (object)) { - scm_port_t *pt = SCM_PTAB_ENTRY (object); - scm_ptob_descriptor_t *ptob = scm_ptobs + SCM_PTOBNUM (object); + scm_t_port *pt = SCM_PTAB_ENTRY (object); + scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (object); if (!ptob->truncate) SCM_MISC_ERROR ("port is not truncatable", SCM_EOL); @@ -1514,14 +1514,14 @@ void scm_ports_prehistory () { scm_numptob = 0; - scm_ptobs = (scm_ptob_descriptor_t *) malloc (sizeof (scm_ptob_descriptor_t)); + scm_ptobs = (scm_t_ptob_descriptor *) malloc (sizeof (scm_t_ptob_descriptor)); } /* Void ports. */ -scm_bits_t scm_tc16_void_port = 0; +scm_t_bits scm_tc16_void_port = 0; static int fill_input_void_port (SCM port SCM_UNUSED) { @@ -1540,7 +1540,7 @@ scm_void_port (char *mode_str) { int mode_bits; SCM answer; - scm_port_t * pt; + scm_t_port * pt; SCM_NEWCELL (answer); SCM_DEFER_INTS; diff --git a/libguile/ports.h b/libguile/ports.h index 1ebbd7ce7..e25419849 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -59,11 +59,11 @@ #define SCM_INITIAL_PUTBACK_BUF_SIZE 4 /* values for the rw_active flag. */ -typedef enum scm_port_rw_active_t { +typedef enum scm_t_port_rw_active { SCM_PORT_NEITHER = 0, SCM_PORT_READ = 1, SCM_PORT_WRITE = 2 -} scm_port_rw_active_t; +} scm_t_port_rw_active; /* C representation of a Scheme port. */ @@ -75,7 +75,7 @@ typedef struct * Revealed ports do not get GC'd. */ /* data for the underlying port implementation as a raw C value. */ - scm_bits_t stream; + scm_t_bits stream; SCM file_name; /* debugging support. */ long line_number; /* debugging support. */ @@ -120,7 +120,7 @@ typedef struct flushed before switching between reading and writing, seeking, etc. */ - scm_port_rw_active_t rw_active; /* for random access ports, + scm_t_port_rw_active rw_active; /* for random access ports, indicates which of the buffers is currently in use. can be SCM_PORT_WRITE, SCM_PORT_READ, @@ -130,10 +130,10 @@ typedef struct /* a buffer for un-read chars and strings. */ unsigned char *putback_buf; size_t putback_buf_size; /* allocated size of putback_buf. */ -} scm_port_t; +} scm_t_port; -extern scm_port_t **scm_port_table; -extern long scm_port_table_size; /* Number of ports in scm_port_table. */ +extern scm_t_port **scm_t_portable; +extern long scm_t_portable_size; /* Number of ports in scm_t_portable. */ #define SCM_READ_BUFFER_EMPTY_P(c_port) (c_port->read_pos >= c_port->read_end) @@ -167,10 +167,10 @@ extern long scm_port_table_size; /* Number of ports in scm_port_table. */ #define SCM_CLR_PORT_OPEN_FLAG(p) \ SCM_SET_CELL_WORD_0 ((p), SCM_CELL_WORD_0 (p) & ~SCM_OPN) -#define SCM_PTAB_ENTRY(x) ((scm_port_t *) SCM_CELL_WORD_1 (x)) -#define SCM_SETPTAB_ENTRY(x,ent) (SCM_SET_CELL_WORD_1 ((x), (scm_bits_t) (ent))) +#define SCM_PTAB_ENTRY(x) ((scm_t_port *) SCM_CELL_WORD_1 (x)) +#define SCM_SETPTAB_ENTRY(x,ent) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (ent))) #define SCM_STREAM(x) (SCM_PTAB_ENTRY(x)->stream) -#define SCM_SETSTREAM(x,s) (SCM_PTAB_ENTRY(x)->stream = (scm_bits_t) (s)) +#define SCM_SETSTREAM(x,s) (SCM_PTAB_ENTRY(x)->stream = (scm_t_bits) (s)) #define SCM_FILENAME(x) (SCM_PTAB_ENTRY(x)->file_name) #define SCM_SET_FILENAME(x, n) (SCM_PTAB_ENTRY(x)->file_name = (n)) #define SCM_LINUM(x) (SCM_PTAB_ENTRY(x)->line_number) @@ -185,7 +185,7 @@ extern long scm_port_table_size; /* Number of ports in scm_port_table. */ /* port-type description. */ -typedef struct scm_ptob_descriptor_t +typedef struct scm_t_ptob_descriptor { char *name; SCM (*mark) (SCM); @@ -204,12 +204,12 @@ typedef struct scm_ptob_descriptor_t off_t (*seek) (SCM port, off_t OFFSET, int WHENCE); void (*truncate) (SCM port, off_t length); -} scm_ptob_descriptor_t; +} scm_t_ptob_descriptor; #if (SCM_DEBUG_DEPRECATED == 0) -# define scm_port scm_port_t -# define scm_ptob_descriptor scm_ptob_descriptor_t -# define scm_port_rw_active scm_port_rw_active_t +# define scm_port scm_t_port +# define scm_ptob_descriptor scm_t_ptob_descriptor +# define scm_port_rw_active scm_t_port_rw_active #endif #define SCM_TC2PTOBNUM(x) (0x0ff & ((x) >> 8)) @@ -219,14 +219,14 @@ typedef struct scm_ptob_descriptor_t -extern scm_ptob_descriptor_t *scm_ptobs; +extern scm_t_ptob_descriptor *scm_ptobs; extern long scm_numptob; -extern long scm_port_table_room; +extern long scm_t_portable_room; extern SCM scm_markstream (SCM ptr); -extern scm_bits_t scm_make_port_type (char *name, +extern scm_t_bits scm_make_port_type (char *name, int (*fill_input) (SCM port), void (*write) (SCM port, const void *data, @@ -263,12 +263,12 @@ extern SCM scm_current_load_port (void); extern SCM scm_set_current_input_port (SCM port); extern SCM scm_set_current_output_port (SCM port); extern SCM scm_set_current_error_port (SCM port); -extern scm_port_t * scm_add_to_port_table (SCM port); +extern scm_t_port * scm_add_to_port_table (SCM port); extern void scm_remove_from_port_table (SCM port); extern void scm_grow_port_cbuf (SCM port, size_t requested); extern SCM scm_pt_size (void); extern SCM scm_pt_member (SCM member); -extern void scm_port_non_buffer (scm_port_t *pt); +extern void scm_port_non_buffer (scm_t_port *pt); extern int scm_revealed_count (SCM port); extern SCM scm_port_revealed (SCM port); extern SCM scm_set_port_revealed_x (SCM port, SCM rcount); diff --git a/libguile/print.c b/libguile/print.c index 2a0e4fa62..6583b3f42 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -127,7 +127,7 @@ char *scm_isymnames[] = "#" }; -scm_option_t scm_print_opts[] = { +scm_t_option scm_print_opts[] = { { SCM_OPTION_SCM, "closure-hook", SCM_UNPACK (SCM_BOOL_F), "Hook for printing closures (should handle macros as well)." }, { SCM_OPTION_BOOLEAN, "source", 0, @@ -1050,7 +1050,7 @@ SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0, * escaped to Scheme and thus has to be freed by the GC. */ -scm_bits_t scm_tc16_port_with_ps; +scm_t_bits scm_tc16_port_with_ps; /* Print exactly as the port itself would */ diff --git a/libguile/print.h b/libguile/print.h index a9c544292..5591d382b 100644 --- a/libguile/print.h +++ b/libguile/print.h @@ -51,7 +51,7 @@ #include "libguile/options.h" -extern scm_option_t scm_print_opts[]; +extern scm_t_option scm_print_opts[]; #define SCM_PRINT_CLOSURE (SCM_PACK (scm_print_opts[0].val)) #define SCM_PRINT_SOURCE_P ((int) scm_print_opts[1].val) @@ -99,7 +99,7 @@ typedef struct scm_print_state { extern SCM scm_print_state_vtable; -extern scm_bits_t scm_tc16_port_with_ps; +extern scm_t_bits scm_tc16_port_with_ps; extern SCM scm_print_options (SCM setting); SCM scm_make_print_state (void); diff --git a/libguile/procs.c b/libguile/procs.c index 74f751e6c..5f23d43ed 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -60,7 +60,7 @@ /* {Procedures} */ -scm_subr_entry_t *scm_subr_table; +scm_t_subr_entry *scm_subr_table; /* libguile contained approx. 700 primitive procedures on 24 Aug 1999. */ @@ -81,8 +81,8 @@ scm_c_make_subr (const char *name, long type, SCM (*fcn) ()) long new_size = scm_subr_table_room * 3 / 2; void *new_table = scm_must_realloc ((char *) scm_subr_table, - sizeof (scm_subr_entry_t) * scm_subr_table_room, - sizeof (scm_subr_entry_t) * new_size, + sizeof (scm_t_subr_entry) * scm_subr_table_room, + sizeof (scm_t_subr_entry) * new_size, "scm_subr_table"); scm_subr_table = new_table; scm_subr_table_room = new_size; @@ -160,7 +160,7 @@ scm_mark_subr_table () SCM scm_makcclo (SCM proc, size_t len) { - scm_bits_t *base = scm_must_malloc (len * sizeof (scm_bits_t), "compiled-closure"); + scm_t_bits *base = scm_must_malloc (len * sizeof (scm_t_bits), "compiled-closure"); unsigned long i; SCM s; @@ -390,8 +390,8 @@ void scm_init_subr_table () { scm_subr_table - = ((scm_subr_entry_t *) - scm_must_malloc (sizeof (scm_subr_entry_t) * scm_subr_table_room, + = ((scm_t_subr_entry *) + scm_must_malloc (sizeof (scm_t_subr_entry) * scm_subr_table_room, "scm_subr_table")); } diff --git a/libguile/procs.h b/libguile/procs.h index 0f07bb08f..9eba0d635 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -63,10 +63,10 @@ typedef struct * *generic == 0 until first method */ SCM properties; /* procedure properties */ -} scm_subr_entry_t; +} scm_t_subr_entry; #if (SCM_DEBUG_DEPRECATED == 0) -# define scm_subr_entry scm_subr_entry_t +# define scm_subr_entry scm_t_subr_entry #endif #define SCM_SUBRNUM(subr) (SCM_CELL_WORD_0 (subr) >> 8) @@ -82,7 +82,7 @@ typedef struct #define SCM_CCLO_LENGTH(x) (SCM_CELL_WORD_0 (x) >> 8) #define SCM_SET_CCLO_LENGTH(x, v) (SCM_SET_CELL_WORD_0 ((x), ((v) << 8) + scm_tc7_cclo)) -#define SCM_CCLO_BASE(x) ((scm_bits_t *) SCM_CELL_WORD_1 (x)) +#define SCM_CCLO_BASE(x) ((scm_t_bits *) SCM_CELL_WORD_1 (x)) #define SCM_SET_CCLO_BASE(x, v) (SCM_SET_CELL_WORD_1 ((x), (v))) #define SCM_CCLO_REF(x, i) (SCM_PACK (SCM_CCLO_BASE (x) [i])) @@ -157,7 +157,7 @@ typedef struct #define SCM_PROCEDURE(obj) SCM_CELL_OBJECT_1 (obj) #define SCM_SETTER(obj) SCM_CELL_OBJECT_2 (obj) -extern scm_subr_entry_t *scm_subr_table; +extern scm_t_subr_entry *scm_subr_table; extern long scm_subr_table_size; extern long scm_subr_table_room; diff --git a/libguile/ramap.c b/libguile/ramap.c index 0db574edf..7d49cdbd9 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -190,9 +190,9 @@ int scm_ra_matchp (SCM ra0, SCM ras) { SCM ra1; - scm_array_dim_t dims; - scm_array_dim_t *s0 = &dims; - scm_array_dim_t *s1; + scm_t_array_dim dims; + scm_t_array_dim *s0 = &dims; + scm_t_array_dim *s1; unsigned long bas0 = 0; int i, ndim = 1; int exact = 2 /* 4 */ ; /* Don't care about values >2 (yet?) */ @@ -1912,8 +1912,8 @@ static int raeql (SCM ra0,SCM as_equal,SCM ra1) { SCM v0 = ra0, v1 = ra1; - scm_array_dim_t dim0, dim1; - scm_array_dim_t *s0 = &dim0, *s1 = &dim1; + scm_t_array_dim dim0, dim1; + scm_t_array_dim *s0 = &dim0, *s1 = &dim1; unsigned long bas0 = 0, bas1 = 0; int k, unroll = 1, vlen = 1, ndim = 1; if (SCM_ARRAYP (ra0)) diff --git a/libguile/random.c b/libguile/random.c index b41db73b2..a55d68c31 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -73,7 +73,7 @@ * scm_init_random(). */ -scm_rng_t scm_the_rng; +scm_t_rng scm_the_rng; /* @@ -106,7 +106,7 @@ scm_rng_t scm_the_rng; #if SIZEOF_LONG > 4 || defined (HAVE_LONG_LONGS) unsigned long -scm_i_uniform32 (scm_i_rstate_t *state) +scm_i_uniform32 (scm_t_i_rstate *state) { LONG64 x = (LONG64) A * state->w + state->c; LONG32 w = x & 0xffffffffUL; @@ -132,7 +132,7 @@ scm_i_uniform32 (scm_i_rstate_t *state) #define H(x) ((x) >> 16) unsigned long -scm_i_uniform32 (scm_i_rstate_t *state) +scm_i_uniform32 (scm_t_i_rstate *state) { LONG32 x1 = L (A) * L (state->w); LONG32 x2 = L (A) * H (state->w); @@ -148,7 +148,7 @@ scm_i_uniform32 (scm_i_rstate_t *state) #endif void -scm_i_init_rstate (scm_i_rstate_t *state, char *seed, int n) +scm_i_init_rstate (scm_t_i_rstate *state, char *seed, int n) { LONG32 w = 0L; LONG32 c = 0L; @@ -167,10 +167,10 @@ scm_i_init_rstate (scm_i_rstate_t *state, char *seed, int n) state->c = c; } -scm_i_rstate_t * -scm_i_copy_rstate (scm_i_rstate_t *state) +scm_t_i_rstate * +scm_i_copy_rstate (scm_t_i_rstate *state) { - scm_rstate_t *new_state = malloc (scm_the_rng.rstate_size); + scm_t_rstate *new_state = malloc (scm_the_rng.rstate_size); if (new_state == 0) scm_memory_error ("rstate"); return memcpy (new_state, state, scm_the_rng.rstate_size); @@ -181,10 +181,10 @@ scm_i_copy_rstate (scm_i_rstate_t *state) * Random number library functions */ -scm_rstate_t * +scm_t_rstate * scm_c_make_rstate (char *seed, int n) { - scm_rstate_t *state = malloc (scm_the_rng.rstate_size); + scm_t_rstate *state = malloc (scm_the_rng.rstate_size); if (state == 0) scm_memory_error ("rstate"); state->reserved0 = 0; @@ -193,7 +193,7 @@ scm_c_make_rstate (char *seed, int n) } -scm_rstate_t * +scm_t_rstate * scm_c_default_rstate () #define FUNC_NAME "scm_c_default_rstate" { @@ -206,7 +206,7 @@ scm_c_default_rstate () inline double -scm_c_uniform01 (scm_rstate_t *state) +scm_c_uniform01 (scm_t_rstate *state) { double x = (double) scm_the_rng.random_bits (state) / (double) 0xffffffffUL; return ((x + (double) scm_the_rng.random_bits (state)) @@ -214,7 +214,7 @@ scm_c_uniform01 (scm_rstate_t *state) } double -scm_c_normal01 (scm_rstate_t *state) +scm_c_normal01 (scm_t_rstate *state) { if (state->reserved0) { @@ -237,7 +237,7 @@ scm_c_normal01 (scm_rstate_t *state) } double -scm_c_exp1 (scm_rstate_t *state) +scm_c_exp1 (scm_t_rstate *state) { return - log (scm_c_uniform01 (state)); } @@ -245,7 +245,7 @@ scm_c_exp1 (scm_rstate_t *state) unsigned char scm_masktab[256]; unsigned long -scm_c_random (scm_rstate_t *state, unsigned long m) +scm_c_random (scm_t_rstate *state, unsigned long m) { unsigned int r, mask; mask = (m < 0x100 @@ -260,7 +260,7 @@ scm_c_random (scm_rstate_t *state, unsigned long m) } SCM -scm_c_random_bignum (scm_rstate_t *state, SCM m) +scm_c_random_bignum (scm_t_rstate *state, SCM m) { SCM b; int i, nd; @@ -333,10 +333,10 @@ scm_c_random_bignum (scm_rstate_t *state, SCM m) * Scheme level representation of random states. */ -scm_bits_t scm_tc16_rstate; +scm_t_bits scm_tc16_rstate; static SCM -make_rstate (scm_rstate_t *state) +make_rstate (scm_t_rstate *state) { SCM_RETURN_NEWSMOB (scm_tc16_rstate, state); } @@ -568,12 +568,12 @@ scm_init_random () { int i, m; /* plug in default RNG */ - scm_rng_t rng = + scm_t_rng rng = { - sizeof (scm_i_rstate_t), + sizeof (scm_t_i_rstate), (unsigned long (*)()) scm_i_uniform32, (void (*)()) scm_i_init_rstate, - (scm_rstate_t *(*)()) scm_i_copy_rstate + (scm_t_rstate *(*)()) scm_i_copy_rstate }; scm_the_rng = rng; diff --git a/libguile/random.h b/libguile/random.h index f6d37cc81..50625e20d 100644 --- a/libguile/random.h +++ b/libguile/random.h @@ -62,61 +62,61 @@ * Look how the default generator is "plugged in" in scm_init_random(). */ -typedef struct scm_rstate_t { +typedef struct scm_t_rstate { int reserved0; double reserved1; /* Custom fields follow here */ -} scm_rstate_t; +} scm_t_rstate; -typedef struct scm_rng_t { +typedef struct scm_t_rng { size_t rstate_size; /* size of random state */ - unsigned long (*random_bits) (scm_rstate_t *state); /* gives 32 random bits */ - void (*init_rstate) (scm_rstate_t *state, char *seed, int n); - scm_rstate_t *(*copy_rstate) (scm_rstate_t *state); -} scm_rng_t; + unsigned long (*random_bits) (scm_t_rstate *state); /* gives 32 random bits */ + void (*init_rstate) (scm_t_rstate *state, char *seed, int n); + scm_t_rstate *(*copy_rstate) (scm_t_rstate *state); +} scm_t_rng; -extern scm_rng_t scm_the_rng; +extern scm_t_rng scm_the_rng; /* * Default RNG */ -typedef struct scm_i_rstate_t { - scm_rstate_t rstate; +typedef struct scm_t_i_rstate { + scm_t_rstate rstate; unsigned long w; unsigned long c; -} scm_i_rstate_t; +} scm_t_i_rstate; #if (SCM_DEBUG_DEPRECATED == 0) -# define scm_rstate scm_rstate_t -# define scm_rng scm_rng_t -# define scm_i_rstate scm_i_rstate_t +# define scm_rstate scm_t_rstate +# define scm_rng scm_t_rng +# define scm_i_rstate scm_t_i_rstate #endif -extern unsigned long scm_i_uniform32 (scm_i_rstate_t *); -extern void scm_i_init_rstate (scm_i_rstate_t *, char *seed, int n); -extern scm_i_rstate_t *scm_i_copy_rstate (scm_i_rstate_t *); +extern unsigned long scm_i_uniform32 (scm_t_i_rstate *); +extern void scm_i_init_rstate (scm_t_i_rstate *, char *seed, int n); +extern scm_t_i_rstate *scm_i_copy_rstate (scm_t_i_rstate *); /* * Random number library functions */ -extern scm_rstate_t *scm_c_make_rstate (char *, int); -extern scm_rstate_t *scm_c_default_rstate (void); +extern scm_t_rstate *scm_c_make_rstate (char *, int); +extern scm_t_rstate *scm_c_default_rstate (void); #define scm_c_uniform32(RSTATE) scm_the_rng.random_bits (RSTATE) -extern double scm_c_uniform01 (scm_rstate_t *); -extern double scm_c_normal01 (scm_rstate_t *); -extern double scm_c_exp1 (scm_rstate_t *); -extern unsigned long scm_c_random (scm_rstate_t *, unsigned long m); -extern SCM scm_c_random_bignum (scm_rstate_t *, SCM m); +extern double scm_c_uniform01 (scm_t_rstate *); +extern double scm_c_normal01 (scm_t_rstate *); +extern double scm_c_exp1 (scm_t_rstate *); +extern unsigned long scm_c_random (scm_t_rstate *, unsigned long m); +extern SCM scm_c_random_bignum (scm_t_rstate *, SCM m); /* * Scheme level interface */ -extern scm_bits_t scm_tc16_rstate; +extern scm_t_bits scm_tc16_rstate; #define SCM_RSTATEP(obj) SCM_TYP16_PREDICATE (scm_tc16_rstate, obj) -#define SCM_RSTATE(obj) ((scm_rstate_t *) SCM_CELL_WORD_1 (obj)) +#define SCM_RSTATE(obj) ((scm_t_rstate *) SCM_CELL_WORD_1 (obj)) extern unsigned char scm_masktab[256]; diff --git a/libguile/rdelim.c b/libguile/rdelim.c index f7358ae9e..6f5b9ed11 100644 --- a/libguile/rdelim.c +++ b/libguile/rdelim.c @@ -124,7 +124,7 @@ SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0, static unsigned char * scm_do_read_line (SCM port, size_t *len_p) { - scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); unsigned char *end; /* I thought reading lines was simple. Mercy me. */ @@ -223,7 +223,7 @@ SCM_DEFINE (scm_read_line, "%read-line", 0, 1, 0, "@code{(# . #)}.") #define FUNC_NAME s_scm_read_line { - scm_port_t *pt; + scm_t_port *pt; char *s; size_t slen; SCM line, term; diff --git a/libguile/read.c b/libguile/read.c index 57c90d6e0..5af8436c3 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -66,7 +66,7 @@ SCM_SYMBOL (scm_keyword_prefix, "prefix"); -scm_option_t scm_read_opts[] = { +scm_t_option scm_read_opts[] = { { SCM_OPTION_BOOLEAN, "copy", 0, "Copy source code expressions." }, { SCM_OPTION_BOOLEAN, "positions", 0, diff --git a/libguile/read.h b/libguile/read.h index 5c93e6d20..3362060e1 100644 --- a/libguile/read.h +++ b/libguile/read.h @@ -67,7 +67,7 @@ #define SCM_WHITE_SPACES SCM_SINGLE_SPACES: case '\t' -extern scm_option_t scm_read_opts[]; +extern scm_t_option scm_read_opts[]; #define SCM_COPY_SOURCE_P scm_read_opts[0].val #define SCM_RECORD_POSITIONS_P scm_read_opts[1].val diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index 867bed14d..71cb3b0f3 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -91,7 +91,7 @@ #define REG_BASIC 0 #endif -scm_bits_t scm_tc16_regex; +scm_t_bits scm_tc16_regex; static size_t regex_free (SCM obj) diff --git a/libguile/regex-posix.h b/libguile/regex-posix.h index 07ff7a147..718e651c4 100644 --- a/libguile/regex-posix.h +++ b/libguile/regex-posix.h @@ -50,7 +50,7 @@ #include "libguile/__scm.h" -extern scm_bits_t scm_tc16_regex; +extern scm_t_bits scm_tc16_regex; #define SCM_RGX(X) ((regex_t *) SCM_CELL_WORD_1 (X)) #define SCM_RGXP(X) (SCM_NIMP (X) && (SCM_CELL_TYPE (X) == scm_tc16_regex)) diff --git a/libguile/root.c b/libguile/root.c index e37d77b8f..793103f49 100644 --- a/libguile/root.c +++ b/libguile/root.c @@ -60,7 +60,7 @@ SCM scm_sys_protects[SCM_NUM_PROTECTS]; -scm_bits_t scm_tc16_root; +scm_t_bits scm_tc16_root; #ifndef USE_THREADS struct scm_root_state *scm_root; @@ -238,8 +238,8 @@ cwdr_handler (void *data, SCM tag, SCM args) * in a messed up state. */ SCM -scm_internal_cwdr (scm_catch_body_t body, void *body_data, - scm_catch_handler_t handler, void *handler_data, +scm_internal_cwdr (scm_t_catch_body body, void *body_data, + scm_t_catch_handler handler, void *handler_data, SCM_STACKITEM *stack_start) { int old_ints_disabled = scm_ints_disabled; @@ -253,7 +253,7 @@ scm_internal_cwdr (scm_catch_body_t body, void *body_data, SCM_REDEFER_INTS; { - scm_contregs_t *contregs = scm_must_malloc (sizeof (scm_contregs_t), + scm_t_contregs *contregs = scm_must_malloc (sizeof (scm_t_contregs), "inferior root continuation"); contregs->num_stack_items = 0; diff --git a/libguile/root.h b/libguile/root.h index 9963aa813..49f3604e1 100644 --- a/libguile/root.h +++ b/libguile/root.h @@ -80,7 +80,7 @@ extern SCM scm_sys_protects[]; -extern scm_bits_t scm_tc16_root; +extern scm_t_bits scm_tc16_root; #define SCM_ROOTP(obj) SCM_TYP16_PREDICATE (scm_tc16_root, obj) #define SCM_ROOT_STATE(root) ((scm_root_state *) SCM_CELL_WORD_1 (root)) @@ -97,7 +97,7 @@ typedef struct scm_root_state SCM continuation_stack_ptr; #ifdef DEBUG_EXTENSIONS /* It is very inefficient to have this variable in the root state. */ - scm_debug_frame_t *last_debug_frame; + scm_t_debug_frame *last_debug_frame; #endif SCM progargs; /* vestigial */ @@ -149,9 +149,9 @@ extern struct scm_root_state *scm_root; extern SCM scm_make_root (SCM parent); -extern SCM scm_internal_cwdr (scm_catch_body_t body, +extern SCM scm_internal_cwdr (scm_t_catch_body body, void *body_data, - scm_catch_handler_t handler, + scm_t_catch_handler handler, void *handler_data, SCM_STACKITEM *stack_start); extern SCM scm_call_with_dynamic_root (SCM thunk, SCM handler); diff --git a/libguile/rw.c b/libguile/rw.c index d41767ce8..ec76881ef 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -233,7 +233,7 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0, else { SCM port = SCM_UNBNDP (port_or_fdes) ? scm_cur_outp : port_or_fdes; - scm_port_t *pt; + scm_t_port *pt; off_t space; SCM_VALIDATE_OPFPORT (2, port); diff --git a/libguile/smob.c b/libguile/smob.c index 558adc979..8105df7db 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -288,7 +288,7 @@ scm_smob_apply_3_error (SCM smob, -scm_bits_t +scm_t_bits scm_make_smob_type (char *name, size_t size) #define FUNC_NAME "scm_make_smob_type" { @@ -320,31 +320,31 @@ scm_make_smob_type (char *name, size_t size) void -scm_set_smob_mark (scm_bits_t tc, SCM (*mark) (SCM)) +scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM)) { scm_smobs[SCM_TC2SMOBNUM (tc)].mark = mark; } void -scm_set_smob_free (scm_bits_t tc, size_t (*free) (SCM)) +scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM)) { scm_smobs[SCM_TC2SMOBNUM (tc)].free = free; } void -scm_set_smob_print (scm_bits_t tc, int (*print) (SCM, SCM, scm_print_state*)) +scm_set_smob_print (scm_t_bits tc, int (*print) (SCM, SCM, scm_print_state*)) { scm_smobs[SCM_TC2SMOBNUM (tc)].print = print; } void -scm_set_smob_equalp (scm_bits_t tc, SCM (*equalp) (SCM, SCM)) +scm_set_smob_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM)) { scm_smobs[SCM_TC2SMOBNUM (tc)].equalp = equalp; } void -scm_set_smob_apply (scm_bits_t tc, SCM (*apply) (), +scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (), unsigned int req, unsigned int opt, unsigned int rst) { SCM (*apply_0) (SCM); @@ -454,7 +454,7 @@ scm_set_smob_apply (scm_bits_t tc, SCM (*apply) (), } SCM -scm_make_smob (scm_bits_t tc) +scm_make_smob (scm_t_bits tc) { long n = SCM_TC2SMOBNUM (tc); size_t size = scm_smobs[n].size; @@ -530,7 +530,7 @@ void scm_smob_prehistory () { long i; - scm_bits_t tc; + scm_t_bits tc; scm_numsmob = 0; for (i = 0; i < MAX_SMOB_COUNT; ++i) diff --git a/libguile/smob.h b/libguile/smob.h index c0dd0976a..d7551f842 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -143,14 +143,14 @@ extern int scm_smob_print (SCM exp, SCM port, scm_print_state *pstate); * values using `scm_set_smob_xxx'. */ -extern scm_bits_t scm_make_smob_type (char *name, size_t size); +extern scm_t_bits scm_make_smob_type (char *name, size_t size); -extern void scm_set_smob_mark (scm_bits_t tc, SCM (*mark) (SCM)); -extern void scm_set_smob_free (scm_bits_t tc, size_t (*free) (SCM)); -extern void scm_set_smob_print (scm_bits_t tc, +extern void scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM)); +extern void scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM)); +extern void scm_set_smob_print (scm_t_bits tc, int (*print) (SCM, SCM, scm_print_state*)); -extern void scm_set_smob_equalp (scm_bits_t tc, SCM (*equalp) (SCM, SCM)); -extern void scm_set_smob_apply (scm_bits_t tc, +extern void scm_set_smob_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM)); +extern void scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (), unsigned int req, unsigned int opt, @@ -158,7 +158,7 @@ extern void scm_set_smob_apply (scm_bits_t tc, /* Function for creating smobs */ -extern SCM scm_make_smob (scm_bits_t tc); +extern SCM scm_make_smob (scm_t_bits tc); extern void scm_smob_prehistory (void); diff --git a/libguile/srcprop.c b/libguile/srcprop.c index e16573ec0..25c65e72a 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -83,9 +83,9 @@ SCM_GLOBAL_SYMBOL (scm_sym_line, "line"); SCM_GLOBAL_SYMBOL (scm_sym_column, "column"); SCM_GLOBAL_SYMBOL (scm_sym_breakpoint, "breakpoint"); -scm_bits_t scm_tc16_srcprops; -static scm_srcprops_chunk_t *srcprops_chunklist = 0; -static scm_srcprops_t *srcprops_freelist = 0; +scm_t_bits scm_tc16_srcprops; +static scm_t_srcprops_chunk *srcprops_chunklist = 0; +static scm_t_srcprops *srcprops_freelist = 0; static SCM @@ -100,8 +100,8 @@ srcprops_mark (SCM obj) static size_t srcprops_free (SCM obj) { - *((scm_srcprops_t **) SCM_CELL_WORD_1 (obj)) = srcprops_freelist; - srcprops_freelist = (scm_srcprops_t *) SCM_CELL_WORD_1 (obj); + *((scm_t_srcprops **) SCM_CELL_WORD_1 (obj)) = srcprops_freelist; + srcprops_freelist = (scm_t_srcprops *) SCM_CELL_WORD_1 (obj); return 0; /* srcprops_chunks are not freed until leaving guile */ } @@ -112,7 +112,7 @@ srcprops_print (SCM obj, SCM port, scm_print_state *pstate) int writingp = SCM_WRITINGP (pstate); scm_puts ("#', port); return 1; @@ -122,17 +122,17 @@ srcprops_print (SCM obj, SCM port, scm_print_state *pstate) SCM scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM plist) { - register scm_srcprops_t *ptr; + register scm_t_srcprops *ptr; SCM_DEFER_INTS; if ((ptr = srcprops_freelist) != NULL) - srcprops_freelist = *(scm_srcprops_t **)ptr; + srcprops_freelist = *(scm_t_srcprops **)ptr; else { size_t i; - scm_srcprops_chunk_t *mem; - size_t n = sizeof (scm_srcprops_chunk_t) - + sizeof (scm_srcprops_t) * (SRCPROPS_CHUNKSIZE - 1); - SCM_SYSCALL (mem = (scm_srcprops_chunk_t *) malloc (n)); + scm_t_srcprops_chunk *mem; + size_t n = sizeof (scm_t_srcprops_chunk) + + sizeof (scm_t_srcprops) * (SRCPROPS_CHUNKSIZE - 1); + SCM_SYSCALL (mem = (scm_t_srcprops_chunk *) malloc (n)); if (mem == NULL) scm_memory_error ("srcprops"); scm_mallocated += n; @@ -140,9 +140,9 @@ scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM plist) srcprops_chunklist = mem; ptr = &mem->srcprops[0]; for (i = 1; i < SRCPROPS_CHUNKSIZE - 1; ++i) - *(scm_srcprops_t **)&ptr[i] = &ptr[i + 1]; - *(scm_srcprops_t **)&ptr[SRCPROPS_CHUNKSIZE - 1] = 0; - srcprops_freelist = (scm_srcprops_t *) &ptr[1]; + *(scm_t_srcprops **)&ptr[i] = &ptr[i + 1]; + *(scm_t_srcprops **)&ptr[SRCPROPS_CHUNKSIZE - 1] = 0; + srcprops_freelist = (scm_t_srcprops *) &ptr[1]; } ptr->pos = SRCPROPMAKPOS (line, col); ptr->fname = filename; @@ -154,7 +154,7 @@ scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM plist) SCM -scm_srcprops_to_plist (SCM obj) +scm_t_srcpropso_plist (SCM obj) { SCM plist = SRCPROPPLIST (obj); if (!SCM_UNBNDP (SRCPROPCOPY (obj))) @@ -182,7 +182,7 @@ SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0, #endif p = scm_hashq_ref (scm_source_whash, obj, SCM_BOOL_F); if (SRCPROPSP (p)) - return scm_srcprops_to_plist (p); + return scm_t_srcpropso_plist (p); return SCM_EOL; } #undef FUNC_NAME @@ -344,13 +344,13 @@ scm_init_srcprop () void scm_finish_srcprop () { - register scm_srcprops_chunk_t *ptr = srcprops_chunklist, *next; + register scm_t_srcprops_chunk *ptr = srcprops_chunklist, *next; while (ptr) { next = ptr->next; free ((char *) ptr); - scm_mallocated -= sizeof (scm_srcprops_chunk_t) - + sizeof (scm_srcprops_t) * (SRCPROPS_CHUNKSIZE - 1); + scm_mallocated -= sizeof (scm_t_srcprops_chunk) + + sizeof (scm_t_srcprops) * (SRCPROPS_CHUNKSIZE - 1); ptr = next; } } diff --git a/libguile/srcprop.h b/libguile/srcprop.h index b53eb13b7..e1505c0e7 100644 --- a/libguile/srcprop.h +++ b/libguile/srcprop.h @@ -78,26 +78,26 @@ do { \ /* {Source properties} */ -extern scm_bits_t scm_tc16_srcprops; +extern scm_t_bits scm_tc16_srcprops; -typedef struct scm_srcprops_t +typedef struct scm_t_srcprops { unsigned long pos; SCM fname; SCM copy; SCM plist; -} scm_srcprops_t; +} scm_t_srcprops; #define SRCPROPS_CHUNKSIZE 2047 /* Number of srcprops per chunk */ -typedef struct scm_srcprops_chunk_t +typedef struct scm_t_srcprops_chunk { - struct scm_srcprops_chunk_t *next; - scm_srcprops_t srcprops[1]; -} scm_srcprops_chunk_t; + struct scm_t_srcprops_chunk *next; + scm_t_srcprops srcprops[1]; +} scm_t_srcprops_chunk; #if (SCM_DEBUG_DEPRECATED == 0) -# define scm_srcprops scm_srcprops_t -# define scm_srcprops_chunk scm_srcprops_chunk_t +# define scm_srcprops scm_t_srcprops +# define scm_srcprops_chunk scm_t_srcprops_chunk #endif #define SCM_SOURCE_PROPERTY_FLAG_BREAK (1L << 16) @@ -105,12 +105,12 @@ typedef struct scm_srcprops_chunk_t #define SRCPROPSP(p) (SCM_TYP16_PREDICATE (scm_tc16_srcprops, p)) #define SRCPROPBRK(p) \ (SCM_BOOL (SCM_CELL_WORD_0 (p) & SCM_SOURCE_PROPERTY_FLAG_BREAK)) -#define SRCPROPPOS(p) ((scm_srcprops_t *) SCM_CELL_WORD_1 (p))->pos +#define SRCPROPPOS(p) ((scm_t_srcprops *) SCM_CELL_WORD_1 (p))->pos #define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12) #define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL) -#define SRCPROPFNAME(p) ((scm_srcprops_t *) SCM_CELL_WORD_1 (p))->fname -#define SRCPROPCOPY(p) ((scm_srcprops_t *) SCM_CELL_WORD_1 (p))->copy -#define SRCPROPPLIST(p) ((scm_srcprops_t *) SCM_CELL_WORD_1 (p))->plist +#define SRCPROPFNAME(p) ((scm_t_srcprops *) SCM_CELL_WORD_1 (p))->fname +#define SRCPROPCOPY(p) ((scm_t_srcprops *) SCM_CELL_WORD_1 (p))->copy +#define SRCPROPPLIST(p) ((scm_t_srcprops *) SCM_CELL_WORD_1 (p))->plist #define SETSRCPROPBRK(p) \ (SCM_SET_CELL_WORD_0 ((p), SCM_CELL_WORD_0 (p) \ | SCM_SOURCE_PROPERTY_FLAG_BREAK)) @@ -137,7 +137,7 @@ extern SCM scm_sym_breakpoint; -extern SCM scm_srcprops_to_plist (SCM obj); +extern SCM scm_t_srcpropso_plist (SCM obj); extern SCM scm_make_srcprops (long line, int col, SCM fname, SCM copy, SCM plist); extern SCM scm_source_property (SCM obj, SCM key); extern SCM scm_set_source_property_x (SCM obj, SCM key, SCM datum); diff --git a/libguile/stacks.c b/libguile/stacks.c index d6a6e16af..42242f032 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -92,11 +92,11 @@ * Representation: * * The stack is represented as a struct with an id slot and a tail - * array of scm_info_frame_t structs. + * array of scm_t_info_frame structs. * * A frame is represented as a pair where the car contains a stack and * the cdr an inum. The inum is an index to the first SCM value of - * the scm_info_frame_t struct. + * the scm_t_info_frame struct. * * Stacks * Constructor @@ -129,7 +129,7 @@ */ /* Stacks often contain pointers to other items on the stack; for - example, each scm_debug_frame_t structure contains a pointer to the + example, each scm_t_debug_frame structure contains a pointer to the next frame out. When we capture a continuation, we copy the stack into the heap, and just leave all the pointers unchanged. This makes it simple to restore the continuation --- just copy the stack @@ -143,17 +143,17 @@ OFFSET) is a pointer to the copy in the continuation of the original referent, cast to an scm_debug_MUMBLE *. */ #define RELOC_INFO(ptr, offset) \ - ((scm_debug_info_t *) ((SCM_STACKITEM *) (ptr) + (offset))) + ((scm_t_debug_info *) ((SCM_STACKITEM *) (ptr) + (offset))) #define RELOC_FRAME(ptr, offset) \ - ((scm_debug_frame_t *) ((SCM_STACKITEM *) (ptr) + (offset))) + ((scm_t_debug_frame *) ((SCM_STACKITEM *) (ptr) + (offset))) /* Count number of debug info frames on a stack, beginning with * DFRAME. OFFSET is used for relocation of pointers when the stack * is read from a continuation. */ -static scm_bits_t -stack_depth (scm_debug_frame_t *dframe,long offset,SCM *id,int *maxp) +static scm_t_bits +stack_depth (scm_t_debug_frame *dframe,long offset,SCM *id,int *maxp) { long n; long max_depth = SCM_BACKTRACE_MAXDEPTH; @@ -163,10 +163,10 @@ stack_depth (scm_debug_frame_t *dframe,long offset,SCM *id,int *maxp) { if (SCM_EVALFRAMEP (*dframe)) { - scm_debug_info_t * info = RELOC_INFO (dframe->info, offset); + scm_t_debug_info * info = RELOC_INFO (dframe->info, offset); n += (info - dframe->vect) / 2 + 1; /* Data in the apply part of an eval info frame comes from previous - stack frame if the scm_debug_info_t vector is overflowed. */ + stack frame if the scm_t_debug_info vector is overflowed. */ if ((((info - dframe->vect) & 1) == 0) && SCM_OVERFLOWP (*dframe) && !SCM_UNBNDP (info[1].a.proc)) @@ -185,12 +185,12 @@ stack_depth (scm_debug_frame_t *dframe,long offset,SCM *id,int *maxp) /* Read debug info from DFRAME into IFRAME. */ static void -read_frame (scm_debug_frame_t *dframe,long offset,scm_info_frame_t *iframe) +read_frame (scm_t_debug_frame *dframe,long offset,scm_t_info_frame *iframe) { - scm_bits_t flags = SCM_UNPACK (SCM_INUM0); /* UGh. */ + scm_t_bits flags = SCM_UNPACK (SCM_INUM0); /* UGh. */ if (SCM_EVALFRAMEP (*dframe)) { - scm_debug_info_t * info = RELOC_INFO (dframe->info, offset); + scm_t_debug_info * info = RELOC_INFO (dframe->info, offset); if ((info - dframe->vect) & 1) { /* Debug.vect ends with apply info. */ @@ -246,16 +246,16 @@ do { \ } while (0) -/* Fill the scm_info_frame_t vector IFRAME with data from N stack frames +/* Fill the scm_t_info_frame vector IFRAME with data from N stack frames * starting with the first stack frame represented by debug frame * DFRAME. */ -static scm_bits_t -read_frames (scm_debug_frame_t *dframe,long offset,long n,scm_info_frame_t *iframes) +static scm_t_bits +read_frames (scm_t_debug_frame *dframe,long offset,long n,scm_t_info_frame *iframes) { - scm_info_frame_t *iframe = iframes; - scm_debug_info_t *info; + scm_t_info_frame *iframe = iframes; + scm_t_debug_info *info; static SCM applybody = SCM_UNDEFINED; /* The value of applybody has to be setup after r4rs.scm has executed. */ @@ -280,7 +280,7 @@ read_frames (scm_debug_frame_t *dframe,long offset,long n,scm_info_frame_t *ifra if ((info - dframe->vect) & 1) --info; /* Data in the apply part of an eval info frame comes from - previous stack frame if the scm_debug_info_t vector is overflowed. */ + previous stack frame if the scm_t_debug_info vector is overflowed. */ else if (SCM_OVERFLOWP (*dframe) && !SCM_UNBNDP (info[1].a.proc)) { @@ -347,7 +347,7 @@ read_frames (scm_debug_frame_t *dframe,long offset,long n,scm_info_frame_t *ifra static void narrow_stack (SCM stack,long inner,SCM inner_key,long outer,SCM outer_key) { - scm_stack_t *s = SCM_STACK (stack); + scm_t_stack *s = SCM_STACK (stack); long i; long n = s->length; @@ -400,7 +400,7 @@ narrow_stack (SCM stack,long inner,SCM inner_key,long outer,SCM outer_key) /* Stacks */ -SCM scm_stack_type; +SCM scm_t_stackype; SCM_DEFINE (scm_stack_p, "stack?", 1, 0, 0, (SCM obj), @@ -423,8 +423,8 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, { long n, size; int maxp; - scm_debug_frame_t *dframe = scm_last_debug_frame; - scm_info_frame_t *iframe; + scm_t_debug_frame *dframe = scm_last_debug_frame; + scm_t_info_frame *iframe; long offset = 0; SCM stack, id; SCM inner_cut, outer_cut; @@ -437,10 +437,10 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, { SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, FUNC_NAME); if (SCM_DEBUGOBJP (obj)) - dframe = (scm_debug_frame_t *) SCM_DEBUGOBJ_FRAME (obj); + dframe = (scm_t_debug_frame *) SCM_DEBUGOBJ_FRAME (obj); else if (SCM_CONTINUATIONP (obj)) { - offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (obj) + sizeof (scm_contregs_t)) + offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (obj) + sizeof (scm_t_contregs)) - SCM_BASE (obj)); #ifndef STACK_GROWS_UP offset += SCM_CONTINUATION_LENGTH (obj); @@ -463,7 +463,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, size = n * SCM_FRAME_N_SLOTS; /* Make the stack object. */ - stack = scm_make_struct (scm_stack_type, SCM_MAKINUM (size), SCM_EOL); + stack = scm_make_struct (scm_t_stackype, SCM_MAKINUM (size), SCM_EOL); SCM_STACK (stack) -> id = id; iframe = &SCM_STACK (stack) -> tail[0]; SCM_STACK (stack) -> frames = iframe; @@ -513,7 +513,7 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0, "Return the identifier given to @var{stack} by @code{start-stack}.") #define FUNC_NAME s_scm_stack_id { - scm_debug_frame_t *dframe; + scm_t_debug_frame *dframe; long offset = 0; if (SCM_EQ_P (stack, SCM_BOOL_T)) dframe = scm_last_debug_frame; @@ -521,10 +521,10 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0, { SCM_VALIDATE_NIM (1,stack); if (SCM_DEBUGOBJP (stack)) - dframe = (scm_debug_frame_t *) SCM_DEBUGOBJ_FRAME (stack); + dframe = (scm_t_debug_frame *) SCM_DEBUGOBJ_FRAME (stack); else if (SCM_CONTINUATIONP (stack)) { - offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (stack) + sizeof (scm_contregs_t)) + offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (stack) + sizeof (scm_t_contregs)) - SCM_BASE (stack)); #ifndef STACK_GROWS_UP offset += SCM_CONTINUATION_LENGTH (stack); @@ -587,16 +587,16 @@ SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0, "debug object or a continuation.") #define FUNC_NAME s_scm_last_stack_frame { - scm_debug_frame_t *dframe; + scm_t_debug_frame *dframe; long offset = 0; SCM stack; SCM_VALIDATE_NIM (1,obj); if (SCM_DEBUGOBJP (obj)) - dframe = (scm_debug_frame_t *) SCM_DEBUGOBJ_FRAME (obj); + dframe = (scm_t_debug_frame *) SCM_DEBUGOBJ_FRAME (obj); else if (SCM_CONTINUATIONP (obj)) { - offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (obj) + sizeof (scm_contregs_t)) + offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (obj) + sizeof (scm_t_contregs)) - SCM_BASE (obj)); #ifndef STACK_GROWS_UP offset += SCM_CONTINUATION_LENGTH (obj); @@ -612,12 +612,12 @@ SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0, if (!dframe || SCM_VOIDFRAMEP (*dframe)) return SCM_BOOL_F; - stack = scm_make_struct (scm_stack_type, SCM_MAKINUM (SCM_FRAME_N_SLOTS), + stack = scm_make_struct (scm_t_stackype, SCM_MAKINUM (SCM_FRAME_N_SLOTS), SCM_EOL); SCM_STACK (stack) -> length = 1; SCM_STACK (stack) -> frames = &SCM_STACK (stack) -> tail[0]; read_frame (dframe, offset, - (scm_info_frame_t *) &SCM_STACK (stack) -> frames[0]); + (scm_t_info_frame *) &SCM_STACK (stack) -> frames[0]); return scm_cons (stack, SCM_INUM0);; } @@ -747,11 +747,11 @@ scm_init_stacks () SCM stack_layout = scm_make_struct_layout (scm_makfrom0str (SCM_STACK_LAYOUT)); vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL); - scm_stack_type + scm_t_stackype = scm_permanent_object (scm_make_struct (vtable, SCM_INUM0, scm_cons (stack_layout, SCM_EOL))); - scm_set_struct_vtable_name_x (scm_stack_type, scm_str2symbol ("stack")); + scm_set_struct_vtable_name_x (scm_t_stackype, scm_str2symbol ("stack")); #ifndef SCM_MAGIC_SNARFER #include "libguile/stacks.x" #endif diff --git a/libguile/stacks.h b/libguile/stacks.h index b86d87aa3..b034bb368 100644 --- a/libguile/stacks.h +++ b/libguile/stacks.h @@ -55,33 +55,33 @@ /* {Frames and stacks} */ -typedef struct scm_info_frame_t { +typedef struct scm_t_info_frame { /* SCM flags; */ - scm_bits_t flags; + scm_t_bits flags; SCM source; SCM proc; SCM args; -} scm_info_frame_t; -#define SCM_FRAME_N_SLOTS (sizeof (scm_info_frame_t) / sizeof (SCM)) +} scm_t_info_frame; +#define SCM_FRAME_N_SLOTS (sizeof (scm_t_info_frame) / sizeof (SCM)) -#define SCM_STACK(obj) ((scm_stack_t *) SCM_STRUCT_DATA (obj)) +#define SCM_STACK(obj) ((scm_t_stack *) SCM_STRUCT_DATA (obj)) #define SCM_STACK_LAYOUT "pwuourpW" -typedef struct scm_stack_t { +typedef struct scm_t_stack { SCM id; /* Stack id */ - scm_info_frame_t *frames; /* Info frames */ + scm_t_info_frame *frames; /* Info frames */ unsigned long length; /* Stack length */ unsigned long tail_length; - scm_info_frame_t tail[1]; -} scm_stack_t; + scm_t_info_frame tail[1]; +} scm_t_stack; #if (SCM_DEBUG_DEPRECATED == 0) -# define scm_info_frame scm_info_frame_t -# define scm_stack scm_stack_t +# define scm_info_frame scm_t_info_frame +# define scm_stack scm_t_stack #endif -extern SCM scm_stack_type; +extern SCM scm_t_stackype; -#define SCM_STACKP(obj) (SCM_STRUCTP (obj) && SCM_EQ_P (SCM_STRUCT_VTABLE (obj), scm_stack_type)) +#define SCM_STACKP(obj) (SCM_STRUCTP (obj) && SCM_EQ_P (SCM_STRUCT_VTABLE (obj), scm_t_stackype)) #define SCM_STACK_LENGTH(stack) (SCM_STACK (stack) -> length) #define SCM_FRAMEP(obj) (SCM_CONSP (obj) \ diff --git a/libguile/strports.c b/libguile/strports.c index 54a371fd2..ef4a15838 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -80,13 +80,13 @@ when rw_active is SCM_PORT_NEITHER. */ -scm_bits_t scm_tc16_strport; +scm_t_bits scm_tc16_strport; static int stfill_buffer (SCM port) { - scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); if (pt->read_pos >= pt->read_end) return EOF; @@ -97,7 +97,7 @@ stfill_buffer (SCM port) /* change the size of a port's string to new_size. this doesn't change read_buf_size. */ static void -st_resize_port (scm_port_t *pt, off_t new_size) +st_resize_port (scm_t_port *pt, off_t new_size) { SCM old_stream = SCM_PACK (pt->stream); SCM new_stream = scm_allocate_string (new_size); @@ -130,7 +130,7 @@ st_resize_port (scm_port_t *pt, off_t new_size) static void st_flush (SCM port) { - scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); if (pt->write_pos == pt->write_end) { @@ -148,7 +148,7 @@ st_flush (SCM port) static void st_write (SCM port, const void *data, size_t size) { - scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); const char *input = (char *) data; while (size > 0) @@ -168,7 +168,7 @@ st_write (SCM port, const void *data, size_t size) static void st_end_input (SCM port, int offset) { - scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); if (pt->read_pos - pt->read_buf < offset) scm_misc_error ("st_end_input", "negative position", SCM_EOL); @@ -180,7 +180,7 @@ st_end_input (SCM port, int offset) static off_t st_seek (SCM port, off_t offset, int whence) { - scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); off_t target; if (pt->rw_active == SCM_PORT_READ && offset == 0 && whence == SEEK_CUR) @@ -252,7 +252,7 @@ st_seek (SCM port, off_t offset, int whence) static void st_truncate (SCM port, off_t length) { - scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); if (length > pt->write_buf_size) st_resize_port (pt, length); @@ -270,7 +270,7 @@ SCM scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) { SCM z; - scm_port_t *pt; + scm_t_port *pt; size_t str_len; SCM_ASSERT (SCM_INUMP(pos) && SCM_INUM(pos) >= 0, pos, SCM_ARG1, caller); @@ -304,7 +304,7 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) /* create a new string from a string port's buffer. */ SCM scm_strport_to_string (SCM port) { - scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); if (pt->rw_active == SCM_PORT_WRITE) st_flush (port); @@ -481,10 +481,10 @@ SCM_DEFINE (scm_eval_string, "eval-string", 1, 0, 0, } #undef FUNC_NAME -static scm_bits_t +static scm_t_bits scm_make_stptob () { - scm_bits_t tc = scm_make_port_type ("string", stfill_buffer, st_write); + scm_t_bits tc = scm_make_port_type ("string", stfill_buffer, st_write); scm_set_port_mark (tc, scm_markstream); scm_set_port_end_input (tc, st_end_input); diff --git a/libguile/strports.h b/libguile/strports.h index 9388c2dcd..b293fc466 100644 --- a/libguile/strports.h +++ b/libguile/strports.h @@ -60,7 +60,7 @@ -extern scm_bits_t scm_tc16_strport; +extern scm_t_bits scm_tc16_strport; diff --git a/libguile/struct.c b/libguile/struct.c index dc9b7d981..7f5227c36 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -155,7 +155,7 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, static void -scm_struct_init (SCM handle, SCM layout, scm_bits_t * mem, int tail_elts, SCM inits) +scm_struct_init (SCM handle, SCM layout, scm_t_bits * mem, int tail_elts, SCM inits) { unsigned char * fields_desc = (unsigned char *) SCM_SYMBOL_CHARS (layout) - 2; unsigned char prot = 0; @@ -256,7 +256,7 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0, #define FUNC_NAME s_scm_struct_vtable_p { SCM layout; - scm_bits_t * mem; + scm_t_bits * mem; if (!SCM_STRUCTP (x)) return SCM_BOOL_F; @@ -310,21 +310,21 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0, Ugh. */ -scm_bits_t * +scm_t_bits * scm_alloc_struct (int n_words, int n_extra, char *who) { - int size = sizeof (scm_bits_t) * (n_words + n_extra) + 7; + int size = sizeof (scm_t_bits) * (n_words + n_extra) + 7; void * block = scm_must_malloc (size, who); /* Adjust the pointer to hide the extra words. */ - scm_bits_t * p = (scm_bits_t *) block + n_extra; + scm_t_bits * p = (scm_t_bits *) block + n_extra; /* Adjust it even further so it's aligned on an eight-byte boundary. */ - p = (scm_bits_t *) (((scm_bits_t) p + 7) & ~7); + p = (scm_t_bits *) (((scm_t_bits) p + 7) & ~7); /* Initialize a few fields as described above. */ - p[scm_struct_i_free] = (scm_bits_t) scm_struct_free_standard; - p[scm_struct_i_ptr] = (scm_bits_t) block; + p[scm_struct_i_free] = (scm_t_bits) scm_struct_free_standard; + p[scm_struct_i_ptr] = (scm_t_bits) block; p[scm_struct_i_n_words] = n_words; p[scm_struct_i_flags] = 0; @@ -332,33 +332,33 @@ scm_alloc_struct (int n_words, int n_extra, char *who) } size_t -scm_struct_free_0 (scm_bits_t * vtable SCM_UNUSED, - scm_bits_t * data SCM_UNUSED) +scm_struct_free_0 (scm_t_bits * vtable SCM_UNUSED, + scm_t_bits * data SCM_UNUSED) { return 0; } size_t -scm_struct_free_light (scm_bits_t * vtable, scm_bits_t * data) +scm_struct_free_light (scm_t_bits * vtable, scm_t_bits * data) { scm_must_free (data); return vtable [scm_struct_i_size] & ~SCM_STRUCTF_MASK; } size_t -scm_struct_free_standard (scm_bits_t * vtable SCM_UNUSED, scm_bits_t * data) +scm_struct_free_standard (scm_t_bits * vtable SCM_UNUSED, scm_t_bits * data) { size_t n = (data[scm_struct_i_n_words] + scm_struct_n_extra_words) - * sizeof (scm_bits_t) + 7; + * sizeof (scm_t_bits) + 7; scm_must_free ((void *) data[scm_struct_i_ptr]); return n; } size_t -scm_struct_free_entity (scm_bits_t * vtable SCM_UNUSED, scm_bits_t * data) +scm_struct_free_entity (scm_t_bits * vtable SCM_UNUSED, scm_t_bits * data) { size_t n = (data[scm_struct_i_n_words] + scm_struct_entity_n_extra_words) - * sizeof (scm_bits_t) + 7; + * sizeof (scm_t_bits) + 7; scm_must_free ((void *) data[scm_struct_i_ptr]); return n; } @@ -404,12 +404,12 @@ scm_free_structs (void *dummy1 SCM_UNUSED, } else { - scm_bits_t word0 = SCM_CELL_WORD_0 (obj) - scm_tc3_cons_gloc; + scm_t_bits word0 = SCM_CELL_WORD_0 (obj) - scm_tc3_cons_gloc; /* access as struct */ - scm_bits_t * vtable_data = (scm_bits_t *) word0; - scm_bits_t * data = SCM_STRUCT_DATA (obj); - scm_struct_free_t free_struct_data - = ((scm_struct_free_t) vtable_data[scm_struct_i_free]); + scm_t_bits * vtable_data = (scm_t_bits *) word0; + scm_t_bits * data = SCM_STRUCT_DATA (obj); + scm_t_struct_free free_struct_data + = ((scm_t_struct_free) vtable_data[scm_struct_i_free]); SCM_SET_CELL_TYPE (obj, scm_tc_free_cell); free_struct_data (vtable_data, data); } @@ -445,7 +445,7 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, SCM layout; int basic_size; int tail_elts; - scm_bits_t * data; + scm_t_bits * data; SCM handle; SCM_VALIDATE_VTABLE (1,vtable); @@ -472,7 +472,7 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, SCM_SET_CELL_WORD_1 (handle, data); SCM_SET_STRUCT_GC_CHAIN (handle, 0); scm_struct_init (handle, layout, data, tail_elts, init); - SCM_SET_CELL_WORD_0 (handle, (scm_bits_t) SCM_STRUCT_DATA (vtable) + scm_tc3_cons_gloc); + SCM_SET_CELL_WORD_0 (handle, (scm_t_bits) SCM_STRUCT_DATA (vtable) + scm_tc3_cons_gloc); SCM_ALLOW_INTS; return handle; } @@ -532,7 +532,7 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, SCM layout; int basic_size; int tail_elts; - scm_bits_t * data; + scm_t_bits * data; SCM handle; SCM_VALIDATE_STRING (1, user_fields); @@ -552,7 +552,7 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, SCM_SET_STRUCT_GC_CHAIN (handle, 0); data [scm_vtable_index_layout] = SCM_UNPACK (layout); scm_struct_init (handle, layout, data, tail_elts, scm_cons (layout, init)); - SCM_SET_CELL_WORD_0 (handle, (scm_bits_t) data + scm_tc3_cons_gloc); + SCM_SET_CELL_WORD_0 (handle, (scm_t_bits) data + scm_tc3_cons_gloc); SCM_ALLOW_INTS; return handle; } @@ -571,10 +571,10 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0, #define FUNC_NAME s_scm_struct_ref { SCM answer = SCM_UNDEFINED; - scm_bits_t * data; + scm_t_bits * data; SCM layout; int p; - scm_bits_t n_fields; + scm_t_bits n_fields; char * fields_desc; char field_type = 0; @@ -648,7 +648,7 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0, "to.") #define FUNC_NAME s_scm_struct_set_x { - scm_bits_t * data; + scm_t_bits * data; SCM layout; int p; int n_fields; diff --git a/libguile/struct.h b/libguile/struct.h index 6c31ea90b..0e7c29f2e 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -70,7 +70,7 @@ #define scm_vtable_index_printer 3 /* A printer for this struct type. */ #define scm_vtable_offset_user 4 /* Where do user fields start? */ -typedef size_t (*scm_struct_free_t) (scm_bits_t * vtable, scm_bits_t * data); +typedef size_t (*scm_t_struct_free) (scm_t_bits * vtable, scm_t_bits * data); #define SCM_STRUCTF_MASK (0xFFF << 20) #define SCM_STRUCTF_ENTITY (1L << 30) /* Indicates presence of proc slots */ @@ -79,8 +79,8 @@ typedef size_t (*scm_struct_free_t) (scm_bits_t * vtable, scm_bits_t * data); /* Dirk:FIXME:: the SCM_STRUCTP predicate is also fulfilled for glocs */ #define SCM_STRUCTP(X) (SCM_NIMP(X) && (SCM_TYP3(X) == scm_tc3_cons_gloc)) -#define SCM_STRUCT_DATA(X) ((scm_bits_t *) SCM_CELL_WORD_1 (X)) -#define SCM_STRUCT_VTABLE_DATA(X) ((scm_bits_t *) (SCM_CELL_WORD_0 (X) - scm_tc3_cons_gloc)) +#define SCM_STRUCT_DATA(X) ((scm_t_bits *) SCM_CELL_WORD_1 (X)) +#define SCM_STRUCT_VTABLE_DATA(X) ((scm_t_bits *) (SCM_CELL_WORD_0 (X) - scm_tc3_cons_gloc)) #define SCM_STRUCT_LAYOUT(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_layout])) #define SCM_SET_STRUCT_LAYOUT(X, v) (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_layout] = SCM_UNPACK (v)) @@ -91,7 +91,7 @@ typedef size_t (*scm_struct_free_t) (scm_bits_t * vtable, scm_bits_t * data); #define SCM_STRUCT_PRINTER(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_printer])) #define SCM_SET_STRUCT_PRINTER(x, v)\ (SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_printer] = SCM_UNPACK (v)) -#define SCM_SET_VTABLE_DESTRUCTOR(X, D) (SCM_STRUCT_DATA (X) [scm_struct_i_free] = (scm_bits_t) (D)) +#define SCM_SET_VTABLE_DESTRUCTOR(X, D) (SCM_STRUCT_DATA (X) [scm_struct_i_free] = (scm_t_bits) (D)) /* Efficiency is important in the following macro, since it's used in GC */ #define SCM_LAYOUT_TAILP(X) (((X) & 32) == 0) /* R, W or O */ @@ -107,11 +107,11 @@ extern SCM scm_structs_to_free; -extern scm_bits_t * scm_alloc_struct (int n_words, int n_extra, char * who); -extern size_t scm_struct_free_0 (scm_bits_t * vtable, scm_bits_t * data); -extern size_t scm_struct_free_light (scm_bits_t * vtable, scm_bits_t * data); -extern size_t scm_struct_free_standard (scm_bits_t * vtable, scm_bits_t * data); -extern size_t scm_struct_free_entity (scm_bits_t * vtable, scm_bits_t * data); +extern scm_t_bits * scm_alloc_struct (int n_words, int n_extra, char * who); +extern size_t scm_struct_free_0 (scm_t_bits * vtable, scm_t_bits * data); +extern size_t scm_struct_free_light (scm_t_bits * vtable, scm_t_bits * data); +extern size_t scm_struct_free_standard (scm_t_bits * vtable, scm_t_bits * data); +extern size_t scm_struct_free_entity (scm_t_bits * vtable, scm_t_bits * data); extern SCM scm_make_struct_layout (SCM fields); extern SCM scm_struct_p (SCM x); extern SCM scm_struct_vtable_p (SCM x); diff --git a/libguile/symbols.h b/libguile/symbols.h index 2c4973b9d..81a616e31 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -98,7 +98,7 @@ extern void scm_init_symbols (void); #define SCM_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) #define SCM_UCHARS(x) ((unsigned char *) (SCM_CELL_WORD_1 (x))) -#define SCM_SETCHARS(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_bits_t) (v))) +#define SCM_SETCHARS(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (v))) #define SCM_SLOPPY_SUBSTRP(x) (SCM_SUBSTRP (x)) #define SCM_SUBSTR_STR(x) (SCM_CDDR (x)) #define SCM_SUBSTR_OFFSET(x) (SCM_CADR (x)) diff --git a/libguile/tags.h b/libguile/tags.h index 4f43dea26..b3cd66a0b 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -61,36 +61,36 @@ /* In the beginning was the Word: */ #ifdef HAVE_UINTPTR_T -typedef uintptr_t scm_bits_t; -typedef intptr_t scm_signed_bits_t; +typedef uintptr_t scm_t_bits; +typedef intptr_t scm_t_signed_bits; #else -typedef unsigned long scm_bits_t; -typedef signed long scm_signed_bits_t; +typedef unsigned long scm_t_bits; +typedef signed long scm_t_signed_bits; #endif /* But as external interface, we use 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_bits_t n; } n; } SCM; - static SCM scm_pack(scm_bits_t b) { SCM s; s.n.n = b; return s; } + typedef union { struct { scm_t_bits n; } n; } SCM; + static SCM scm_pack(scm_t_bits b) { SCM s; s.n.n = b; return s; } # define SCM_UNPACK(x) ((x).n.n) -# define SCM_PACK(x) (scm_pack ((scm_bits_t) (x))) +# define SCM_PACK(x) (scm_pack ((scm_t_bits) (x))) #elif (SCM_DEBUG_TYPING_STRICTNESS == 1) /* This is the default, which provides an intermediate level of compile time * type checking while still resulting in very efficient code. */ typedef struct scm_unused_struct * SCM; -# define SCM_UNPACK(x) ((scm_bits_t) (x)) +# define SCM_UNPACK(x) ((scm_t_bits) (x)) # define SCM_PACK(x) ((SCM) (x)) #else /* This should be used as a fall back solution for machines on which casting * to a pointer may lead to loss of bit information, e. g. in the three least * significant bits. */ - typedef scm_bits_t SCM; + typedef scm_t_bits SCM; # define SCM_UNPACK(x) (x) -# define SCM_PACK(x) ((scm_bits_t) (x)) +# define SCM_PACK(x) ((scm_t_bits) (x)) #endif diff --git a/libguile/threads.c b/libguile/threads.c index 2bf5180f6..f3334b49a 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -70,9 +70,9 @@ -scm_bits_t scm_tc16_thread; -scm_bits_t scm_tc16_mutex; -scm_bits_t scm_tc16_condvar; +scm_t_bits scm_tc16_thread; +scm_t_bits scm_tc16_mutex; +scm_t_bits scm_tc16_condvar; /* Scheme-visible thread functions. */ diff --git a/libguile/threads.h b/libguile/threads.h index 319a6e410..d6ac1c484 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -55,9 +55,9 @@ /* smob tags for the thread datatypes */ -extern scm_bits_t scm_tc16_thread; -extern scm_bits_t scm_tc16_mutex; -extern scm_bits_t scm_tc16_condvar; +extern scm_t_bits scm_tc16_thread; +extern scm_t_bits scm_tc16_mutex; +extern scm_t_bits scm_tc16_condvar; #define SCM_THREADP(x) SCM_TYP16_PREDICATE (scm_tc16_thread, x) #define SCM_THREAD_DATA(x) ((void *) SCM_CELL_WORD_1 (x)) @@ -79,8 +79,8 @@ SCM scm_threads_lock_mutex (SCM); SCM scm_threads_unlock_mutex (SCM); SCM scm_threads_monitor (void); -SCM scm_spawn_thread (scm_catch_body_t body, void *body_data, - scm_catch_handler_t handler, void *handler_data); +SCM scm_spawn_thread (scm_t_catch_body body, void *body_data, + scm_t_catch_handler handler, void *handler_data); /* These are versions of the ordinary sleep and usleep functions, that play nicely with the thread system. */ diff --git a/libguile/throw.c b/libguile/throw.c index 765924bf6..9d4f0aeca 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -66,7 +66,7 @@ /* the jump buffer data structure */ -static scm_bits_t tc16_jmpbuffer; +static scm_t_bits tc16_jmpbuffer; #define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ) @@ -79,7 +79,7 @@ static scm_bits_t tc16_jmpbuffer; #define JBJMPBUF(OBJ) ((jmp_buf *) SCM_CELL_WORD_1 (OBJ)) #define SETJBJMPBUF(x,v) (SCM_SET_CELL_WORD_1 ((x), (v))) #ifdef DEBUG_EXTENSIONS -#define SCM_JBDFRAME(x) ((scm_debug_frame_t *) SCM_CELL_WORD_2 (x)) +#define SCM_JBDFRAME(x) ((scm_t_debug_frame *) SCM_CELL_WORD_2 (x)) #define SCM_SETJBDFRAME(x,v) (SCM_SET_CELL_WORD_2 ((x), (v))) #endif @@ -170,7 +170,7 @@ struct jmp_buf_and_retval /* use only on the stack, in scm_catch */ will be found. */ SCM -scm_internal_catch (SCM tag, scm_catch_body_t body, void *body_data, scm_catch_handler_t handler, void *handler_data) +scm_internal_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data) { struct jmp_buf_and_retval jbr; SCM jmpbuf; @@ -218,7 +218,7 @@ scm_internal_catch (SCM tag, scm_catch_body_t body, void *body_data, scm_catch_h /* scm_internal_lazy_catch (the guts of lazy catching) */ /* The smob tag for lazy_catch smobs. */ -static scm_bits_t tc16_lazy_catch; +static scm_t_bits tc16_lazy_catch; /* This is the structure we put on the wind list for a lazy catch. It stores the handler function to call, and the data pointer to pass @@ -229,7 +229,7 @@ static scm_bits_t tc16_lazy_catch; (We don't need anything like this in the "eager" catch code, because the same C frame runs both the body and the handler.) */ struct lazy_catch { - scm_catch_handler_t handler; + scm_t_catch_handler handler; void *handler_data; }; @@ -267,7 +267,7 @@ make_lazy_catch (struct lazy_catch *c) - It does not unwind the stack (this is the major difference). - The handler is not allowed to return. */ SCM -scm_internal_lazy_catch (SCM tag, scm_catch_body_t body, void *body_data, scm_catch_handler_t handler, void *handler_data) +scm_internal_lazy_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data) { SCM lazy_catch, answer; struct lazy_catch c; @@ -307,7 +307,7 @@ ss_handler (void *data SCM_UNUSED, SCM tag, SCM throw_args) struct cwss_data { SCM tag; - scm_catch_body_t body; + scm_t_catch_body body; void *data; }; @@ -320,9 +320,9 @@ cwss_body (void *data) SCM scm_internal_stack_catch (SCM tag, - scm_catch_body_t body, + scm_t_catch_body body, void *body_data, - scm_catch_handler_t handler, + scm_t_catch_handler handler, void *handler_data) { struct cwss_data d; diff --git a/libguile/throw.h b/libguile/throw.h index b422dbd23..1211cd926 100644 --- a/libguile/throw.h +++ b/libguile/throw.h @@ -48,26 +48,26 @@ -typedef SCM (*scm_catch_body_t) (void *data); -typedef SCM (*scm_catch_handler_t) (void *data, +typedef SCM (*scm_t_catch_body) (void *data); +typedef SCM (*scm_t_catch_handler) (void *data, SCM tag, SCM throw_args); extern SCM scm_internal_catch (SCM tag, - scm_catch_body_t body, + scm_t_catch_body body, void *body_data, - scm_catch_handler_t handler, + scm_t_catch_handler handler, void *handler_data); extern SCM scm_internal_lazy_catch (SCM tag, - scm_catch_body_t body, + scm_t_catch_body body, void *body_data, - scm_catch_handler_t handler, + scm_t_catch_handler handler, void *handler_data); extern SCM scm_internal_stack_catch (SCM tag, - scm_catch_body_t body, + scm_t_catch_body body, void *body_data, - scm_catch_handler_t handler, + scm_t_catch_handler handler, void *handler_data); /* The first argument to scm_body_thunk should be a pointer to one of diff --git a/libguile/unif.c b/libguile/unif.c index e1f1bd017..17aad0774 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -89,7 +89,7 @@ * long long llvect */ -scm_bits_t scm_tc16_array; +scm_t_bits scm_tc16_array; /* return the size of an element in a uniform array or 0 if type not found. */ @@ -400,7 +400,7 @@ SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0, { SCM res = SCM_EOL; size_t k; - scm_array_dim_t *s; + scm_t_array_dim *s; if (SCM_IMP (ra)) return SCM_BOOL_F; switch (SCM_TYP7 (ra)) @@ -469,7 +469,7 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0, { SCM res = SCM_EOL; size_t k; - scm_array_dim_t *s; + scm_t_array_dim *s; SCM_ASSERT (SCM_ARRAYP (ra), ra, SCM_ARG1, FUNC_NAME); k = SCM_ARRAY_NDIM (ra); s = SCM_ARRAY_DIMS (ra); @@ -491,7 +491,7 @@ scm_aind (SCM ra, SCM args, const char *what) register long j; register unsigned long pos = SCM_ARRAY_BASE (ra); register unsigned long k = SCM_ARRAY_NDIM (ra); - scm_array_dim_t *s = SCM_ARRAY_DIMS (ra); + scm_t_array_dim *s = SCM_ARRAY_DIMS (ra); if (SCM_INUMP (args)) { if (k != 1) @@ -525,9 +525,9 @@ scm_make_ra (int ndim) SCM ra; SCM_NEWCELL (ra); SCM_DEFER_INTS; - SCM_NEWSMOB(ra, ((scm_bits_t) ndim << 17) + scm_tc16_array, - scm_must_malloc ((sizeof (scm_array_t) + - ndim * sizeof (scm_array_dim_t)), + SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + scm_tc16_array, + scm_must_malloc ((sizeof (scm_t_array) + + ndim * sizeof (scm_t_array_dim)), "array")); SCM_ARRAY_V (ra) = scm_nullvect; SCM_ALLOW_INTS; @@ -541,7 +541,7 @@ static char s_bad_spec[] = "Bad scm_array dimension"; SCM scm_shap2ra (SCM args, const char *what) { - scm_array_dim_t *s; + scm_t_array_dim *s; SCM ra, spec, sp; int ndim = scm_ilength (args); if (ndim < 0) @@ -589,7 +589,7 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, { size_t k; unsigned long rlen = 1; - scm_array_dim_t *s; + scm_t_array_dim *s; SCM ra; if (SCM_INUMP (dims)) @@ -681,7 +681,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, SCM imap; size_t k, i; long old_min, new_min, old_max, new_max; - scm_array_dim_t *s; + scm_t_array_dim *s; SCM_VALIDATE_REST_ARGUMENT (dims); SCM_VALIDATE_ARRAY (1,oldra); @@ -809,7 +809,7 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, #define FUNC_NAME s_scm_transpose_array { SCM res, vargs, *ve = &vargs; - scm_array_dim_t *s, *r; + scm_t_array_dim *s, *r; int ndim, i, k; SCM_VALIDATE_REST_ARGUMENT (args); @@ -918,7 +918,7 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, #define FUNC_NAME s_scm_enclose_array { SCM axv, res, ra_inr; - scm_array_dim_t vdim, *s = &vdim; + scm_t_array_dim vdim, *s = &vdim; int ndim, j, k, ninr, noutr; SCM_VALIDATE_REST_ARGUMENT (axes); @@ -1005,7 +1005,7 @@ SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1, long pos = 0; register size_t k; register long j; - scm_array_dim_t *s; + scm_t_array_dim *s; SCM_VALIDATE_REST_ARGUMENT (args); SCM_ASRTGO (SCM_NIMP (v), badarg1); @@ -1591,7 +1591,7 @@ loop: if (SCM_NIMP (port_or_fd)) { - scm_port_t *pt = SCM_PTAB_ENTRY (port_or_fd); + scm_t_port *pt = SCM_PTAB_ENTRY (port_or_fd); int remaining = (cend - offset) * sz; char *dest = base + (cstart + offset) * sz; @@ -2083,11 +2083,11 @@ ra2l (SCM ra,unsigned long base,unsigned long k) } -SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, +SCM_DEFINE (scm_t_arrayo_list, "array->list", 1, 0, 0, (SCM v), "Return a list consisting of all the elements, in order, of\n" "@var{array}.") -#define FUNC_NAME s_scm_array_to_list +#define FUNC_NAME s_scm_t_arrayo_list { SCM res = SCM_EOL; register long k; @@ -2475,7 +2475,7 @@ tail: scm_putc ('*', port); for (i = 0; i < (SCM_BITVECTOR_LENGTH (exp)) / SCM_LONG_BIT; i++) { - scm_bits_t w = SCM_UNPACK (SCM_VELTS (exp)[i]); + scm_t_bits w = SCM_UNPACK (SCM_VELTS (exp)[i]); for (j = SCM_LONG_BIT; j; j--) { scm_putc (w & 1 ? '1' : '0', port); @@ -2594,8 +2594,8 @@ static size_t array_free (SCM ptr) { scm_must_free (SCM_ARRAY_MEM (ptr)); - return sizeof (scm_array_t) + - SCM_ARRAY_NDIM (ptr) * sizeof (scm_array_dim_t); + return sizeof (scm_t_array) + + SCM_ARRAY_NDIM (ptr) * sizeof (scm_t_array_dim); } void diff --git a/libguile/unif.h b/libguile/unif.h index 131aa12b1..4f0d4e484 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -58,28 +58,28 @@ bit 15 is the SCM_ARRAY_FLAG_CONTIGUOUS flag bits 16-31 hold the smob type id: scm_tc16_array CDR: pointer to a malloced block containing an scm_array structure - followed by an scm_array_dim_t structure for each dimension. + followed by an scm_t_array_dim structure for each dimension. */ -typedef struct scm_array_t +typedef struct scm_t_array { SCM v; /* the contents of the array, e.g., a vector or uniform vector. */ unsigned long base; -} scm_array_t; +} scm_t_array; -typedef struct scm_array_dim_t +typedef struct scm_t_array_dim { long lbnd; long ubnd; long inc; -} scm_array_dim_t; +} scm_t_array_dim; #if (SCM_DEBUG_DEPRECATED == 0) -# define scm_array scm_array_t -# define scm_array_dim scm_array_dim_t +# define scm_array scm_t_array +# define scm_array_dim scm_t_array_dim #endif -extern scm_bits_t scm_tc16_array; +extern scm_t_bits scm_tc16_array; #define SCM_ARRAY_FLAG_CONTIGUOUS (1 << 16) @@ -95,10 +95,10 @@ extern scm_bits_t scm_tc16_array; #define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \ (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~SCM_ARRAY_FLAG_CONTIGUOUS)) -#define SCM_ARRAY_MEM(a) ((scm_array_t *) SCM_CELL_WORD_1 (a)) +#define SCM_ARRAY_MEM(a) ((scm_t_array *) SCM_CELL_WORD_1 (a)) #define SCM_ARRAY_V(a) (SCM_ARRAY_MEM (a)->v) #define SCM_ARRAY_BASE(a) (SCM_ARRAY_MEM (a)->base) -#define SCM_ARRAY_DIMS(a) ((scm_array_dim_t *)((char *) SCM_ARRAY_MEM (a) + sizeof (scm_array_t))) +#define SCM_ARRAY_DIMS(a) ((scm_t_array_dim *)((char *) SCM_ARRAY_MEM (a) + sizeof (scm_t_array))) #define SCM_I_MAX_LENGTH ((unsigned long) (-1L) >> 8) @@ -148,7 +148,7 @@ extern SCM scm_bit_set_star_x (SCM v, SCM kv, SCM obj); extern SCM scm_bit_count_star (SCM v, SCM kv, SCM obj); extern SCM scm_bit_invert_x (SCM v); extern SCM scm_istr2bve (char *str, long len); -extern SCM scm_array_to_list (SCM v); +extern SCM scm_t_arrayo_list (SCM v); extern SCM scm_list_to_uniform_array (SCM ndim, SCM prot, SCM lst); extern int scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate); extern SCM scm_array_prototype (SCM ra); diff --git a/libguile/variable.c b/libguile/variable.c index 4c0ad5a04..2a6da8c89 100644 --- a/libguile/variable.c +++ b/libguile/variable.c @@ -54,7 +54,7 @@ #include "libguile/validate.h" #include "libguile/variable.h" -scm_bits_t scm_tc16_variable; +scm_t_bits scm_tc16_variable; static int variable_print (SCM exp, SCM port, scm_print_state *pstate) diff --git a/libguile/variable.h b/libguile/variable.h index f899658a4..300e40220 100644 --- a/libguile/variable.h +++ b/libguile/variable.h @@ -54,7 +54,7 @@ /* Variables */ -extern scm_bits_t scm_tc16_variable; +extern scm_t_bits scm_tc16_variable; #define SCM_VARIABLEP(X) SCM_SMOB_PREDICATE (scm_tc16_variable, X) diff --git a/libguile/vectors.c b/libguile/vectors.c index 4407d57d8..89822ebdd 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -285,7 +285,7 @@ scm_c_make_vector (unsigned long int k, SCM fill) #define FUNC_NAME s_scm_make_vector { SCM v; - scm_bits_t *base; + scm_t_bits *base; if (k > 0) { @@ -293,7 +293,7 @@ scm_c_make_vector (unsigned long int k, SCM fill) SCM_ASSERT_RANGE (1, scm_ulong2num (k), k <= SCM_VECTOR_MAX_LENGTH); - base = scm_must_malloc (k * sizeof (scm_bits_t), FUNC_NAME); + base = scm_must_malloc (k * sizeof (scm_t_bits), FUNC_NAME); for (j = 0; j != k; ++j) base[j] = SCM_UNPACK (fill); } diff --git a/libguile/vectors.h b/libguile/vectors.h index 7a788f00b..6ffa3f9b2 100644 --- a/libguile/vectors.h +++ b/libguile/vectors.h @@ -52,7 +52,7 @@ #define SCM_VECTORP(x) (SCM_NIMP (x) && (SCM_TYP7S (x) == scm_tc7_vector)) -#define SCM_VECTOR_BASE(x) ((scm_bits_t *) SCM_CELL_WORD_1 (x)) +#define SCM_VECTOR_BASE(x) ((scm_t_bits *) SCM_CELL_WORD_1 (x)) #define SCM_SET_VECTOR_BASE(v, b) (SCM_SET_CELL_WORD_1 ((v), (b))) #define SCM_VECTOR_MAX_LENGTH ((1L << 24) - 1) #define SCM_VECTOR_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) diff --git a/libguile/vports.c b/libguile/vports.c index cd29ce31d..9d7fbe409 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -69,13 +69,13 @@ */ -static scm_bits_t scm_tc16_sfport; +static scm_t_bits scm_tc16_sfport; static void sf_flush (SCM port) { - scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); SCM stream = SCM_PACK (pt->stream); if (pt->write_pos > pt->write_buf) @@ -121,7 +121,7 @@ sf_fill_input (SCM port) return EOF; SCM_ASSERT (SCM_CHARP (ans), ans, SCM_ARG1, "sf_fill_input"); { - scm_port_t *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); *pt->read_buf = SCM_CHAR (ans); pt->read_pos = pt->read_buf; @@ -190,7 +190,7 @@ SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0, "@end lisp") #define FUNC_NAME s_scm_make_soft_port { - scm_port_t *pt; + scm_t_port *pt; SCM z; SCM_VALIDATE_VECTOR_LEN (1,pv,5); SCM_VALIDATE_STRING (2, modes); @@ -208,10 +208,10 @@ SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0, #undef FUNC_NAME -static scm_bits_t +static scm_t_bits scm_make_sfptob () { - scm_bits_t tc = scm_make_port_type ("soft", sf_fill_input, sf_write); + scm_t_bits tc = scm_make_port_type ("soft", sf_fill_input, sf_write); scm_set_port_mark (tc, scm_markstream); scm_set_port_flush (tc, sf_flush); From 593be5d2604e838b2a3c7d4f3a6ea46f9d2890f5 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 14 Jun 2001 19:51:54 +0000 Subject: [PATCH 1321/2047] Replace "scm_*_t" with "scm_t_*". --- guile-readline/readline.c | 10 +++++----- guile-readline/readline.h | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/guile-readline/readline.c b/guile-readline/readline.c index f5f330bca..7e0eb1460 100644 --- a/guile-readline/readline.c +++ b/guile-readline/readline.c @@ -42,7 +42,7 @@ #include "libguile/validate.h" #include "guile-readline/readline.h" -scm_option_t scm_readline_opts[] = { +scm_t_option scm_readline_opts[] = { { SCM_OPTION_BOOLEAN, "history-file", 1, "Use history file." }, { SCM_OPTION_INTEGER, "history-length", 200, @@ -147,7 +147,7 @@ redisplay () static int in_readline = 0; #ifdef USE_THREADS -static scm_mutex_t reentry_barrier_mutex; +static scm_t_mutex reentry_barrier_mutex; #endif static SCM internal_readline (SCM text); @@ -207,7 +207,7 @@ SCM_DEFINE (scm_readline, "%readline", 0, 4, 0, scm_readline_init_ports (inp, outp); ans = scm_internal_catch (SCM_BOOL_T, - (scm_catch_body_t) internal_readline, + (scm_t_catch_body) internal_readline, (void *) SCM_UNPACK (text), handle_error, 0); @@ -225,7 +225,7 @@ reentry_barrier () { int reentryp = 0; #ifdef USE_THREADS - /* We should rather use scm_mutex_try_lock when it becomes available */ + /* We should rather use scm_t_mutexry_lock when it becomes available */ scm_mutex_lock (&reentry_barrier_mutex); #endif if (in_readline) @@ -277,7 +277,7 @@ stream_from_fport (SCM port, char *mode, const char *subr) int fd; FILE *f; - fd = dup (((struct scm_fport_t *) SCM_STREAM (port))->fdes); + fd = dup (((struct scm_t_fport *) SCM_STREAM (port))->fdes); if (fd == -1) { --in_readline; diff --git a/guile-readline/readline.h b/guile-readline/readline.h index 26036e6d5..20d44df10 100644 --- a/guile-readline/readline.h +++ b/guile-readline/readline.h @@ -22,7 +22,7 @@ #include "libguile/__scm.h" -extern scm_option_t scm_readline_opts[]; +extern scm_t_option scm_readline_opts[]; #define SCM_HISTORY_FILE_P scm_readline_opts[0].val #define SCM_HISTORY_LENGTH scm_readline_opts[1].val From b629af45cba2b34fee0ad078581d231df1e1b86c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 14 Jun 2001 19:52:35 +0000 Subject: [PATCH 1322/2047] *** empty log message *** --- guile-readline/ChangeLog | 4 ++++ libguile/ChangeLog | 6 +++++- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index e8d98f1f2..648b86382 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,7 @@ +2001-06-14 Marius Vollmer + + * readline.c, readline.h: Replace "scm_*_t" with "scm_t_*". + 2001-06-14 Marius Vollmer Thanks to Matthias Köppe! diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b6b0199de..549401a40 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,6 +1,10 @@ 2001-06-14 Marius Vollmer - * unif.h (SCM_ARRAY_NDIM): Shift then cast so that the no sign + Throughout: replace "scm_*_t" with "scm_t_*". + +2001-06-14 Marius Vollmer + + * unif.h (SCM_ARRAY_NDIM): Shift then cast so that no sign extension takes place. * strings.h (SCM_STRING_LENGTH): Likewise. (SCM_STRING_MAX_LENGTH): Use unsigned numbers. From 1385d8aee3436a7166baeb7b5cc7ce27762561fd Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 14 Jun 2001 20:14:09 +0000 Subject: [PATCH 1323/2047] Replace "scm_*_t" with "scm_t_*", except "scm_lisp_t". --- libguile/eval.c | 6 +++--- libguile/lang.c | 4 ++-- libguile/lang.h | 2 +- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index fec45ac33..dad5aef6a 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1044,7 +1044,7 @@ scm_m_cont (SCM xorig, SCM env SCM_UNUSED) /* Multi-language support */ SCM_GLOBAL_SYMBOL (scm_lisp_nil, "nil"); -SCM_GLOBAL_SYMBOL (scm_t_lisp, "t"); +SCM_GLOBAL_SYMBOL (scm_lisp_t, "t"); SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond); @@ -2419,7 +2419,7 @@ dispatch: case (SCM_ISYMNUM (SCM_IM_T_IFY)): x = SCM_CDR (x); - RETURN (SCM_NFALSEP (EVALCAR (x, env)) ? scm_t_lisp : scm_lisp_nil) + RETURN (SCM_NFALSEP (EVALCAR (x, env)) ? scm_lisp_t : scm_lisp_nil) case (SCM_ISYMNUM (SCM_IM_0_COND)): proc = SCM_CDR (x); @@ -4125,7 +4125,7 @@ scm_init_eval () #endif scm_c_define ("nil", scm_lisp_nil); - scm_c_define ("t", scm_t_lisp); + scm_c_define ("t", scm_lisp_t); scm_add_feature ("delay"); } diff --git a/libguile/lang.c b/libguile/lang.c index ee15c66ac..82378e0ff 100644 --- a/libguile/lang.c +++ b/libguile/lang.c @@ -114,7 +114,7 @@ SCM_DEFINE (scm_null, "null", 1, 0, 0, "return LISP's nil otherwise.") #define FUNC_NAME s_scm_null { - return (SCM_NILP (x) || SCM_NULLP (x) || SCM_FALSEP (x)) ? scm_t_lisp : scm_lisp_nil; + return (SCM_NILP (x) || SCM_NULLP (x) || SCM_FALSEP (x)) ? scm_lisp_t : scm_lisp_nil; } #undef FUNC_NAME @@ -146,7 +146,7 @@ SCM_DEFINE1 (scm_nil_eq, "nil-eq", scm_tc7_rpsubr, return ((SCM_EQ_P (x, y) || (SCM_NILP (x) && (SCM_NULLP (y) || SCM_FALSEP (y))) || (SCM_NILP (y) && (SCM_NULLP (x) || SCM_FALSEP (x)))) - ? scm_t_lisp + ? scm_lisp_t : scm_lisp_nil); } #undef FUNC_NAME diff --git a/libguile/lang.h b/libguile/lang.h index dfae81970..f0514d0c6 100644 --- a/libguile/lang.h +++ b/libguile/lang.h @@ -49,7 +49,7 @@ extern SCM scm_lisp_nil; -extern SCM scm_t_lisp; +extern SCM scm_lisp_t; #define SCM_NILP(x) (SCM_EQ_P ((x), scm_lisp_nil)) #define SCM_NILNULLP(x) (SCM_NILP (x) || SCM_NULLP (x)) From c81c130ebe69f88a3a4ba4f25a4e78d7321d9ad6 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 14 Jun 2001 20:19:02 +0000 Subject: [PATCH 1324/2047] scm_t_bits is unsigned, types have been renamed. --- NEWS | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/NEWS b/NEWS index e7d1cf468..5513a267f 100644 --- a/NEWS +++ b/NEWS @@ -652,6 +652,15 @@ return. * Changes to the C interface +** Types have been renamed from scm_*_t to scm_t_*. + +This has been done for POSIX sake. It reserves identifiers ending +with "_t". What a concept. + +The old names are still available with status `deprecated'. + +** scm_t_bits (former scm_bits_t) is now a unsigned type. + ** Deprecated feature have been removed. *** Macros removed From 020e3c3868187244a7d7617eb6204520ea425e48 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 14 Jun 2001 20:19:33 +0000 Subject: [PATCH 1325/2047] Added deprecated section with the olde type names. --- libguile.h | 42 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) diff --git a/libguile.h b/libguile.h index d3e8a9adf..f006528fe 100644 --- a/libguile.h +++ b/libguile.h @@ -137,6 +137,48 @@ extern "C" { #include "libguile/threads.h" #endif +/* Deprecated type names. Don't use them for new code. */ + +#if SCM_DEBUG_DEPRECATED == 0 + +typedef scm_t_array_dim scm_array_dim_t; +typedef scm_t_array scm_array_t; +typedef scm_t_bits scm_bits_t; +typedef scm_t_c_bvec_limb scm_c_bvec_limb_t; +typedef scm_t_c_hook_entry scm_c_hook_entry_t; +typedef scm_t_c_hook_function scm_c_hook_function_t; +typedef scm_t_c_hook scm_c_hook_t; +typedef scm_t_catch_body scm_catch_body_t; +typedef scm_t_catch_handler scm_catch_handler_t; +typedef scm_t_complex scm_complex_t; +typedef scm_t_cond scm_cond_t; +typedef scm_t_contregs scm_contregs_t; +typedef scm_t_debug_frame scm_debug_frame_t; +typedef scm_t_debug_info scm_debug_info_t; +typedef scm_t_double scm_double_t; +typedef scm_t_fport scm_fport_t; +typedef scm_t_guard scm_guard_t; +typedef scm_t_i_rstate scm_i_rstate_t; +typedef scm_t_info_frame scm_info_frame_t; +typedef scm_t_inner scm_inner_t; +typedef scm_t_key scm_key_t; +typedef scm_t_method scm_method_t; +typedef scm_t_mutex scm_mutex_t; +typedef scm_t_option scm_option_t; +typedef scm_t_port_rw_active scm_port_rw_active_t; +typedef scm_t_port scm_port_t; +typedef scm_t_ptob_descriptor scm_ptob_descriptor_t; +typedef scm_t_rng scm_rng_t; +typedef scm_t_rstate scm_rstate_t; +typedef scm_t_signed_bits scm_signed_bits_t; +typedef scm_t_srcprops_chunk scm_srcprops_chunk_t; +typedef scm_t_srcprops scm_srcprops_t; +typedef scm_t_stack scm_stack_t; +typedef scm_t_struct_free scm_struct_free_t; +typedef scm_t_subr_entry scm_subr_entry_t; + +#endif /* !SCM_DEBUG_DEPRECATED */ + #ifdef __cplusplus } #endif From 4927dd283b1cefa4a0971081023e8d714ca97438 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 14 Jun 2001 20:20:35 +0000 Subject: [PATCH 1326/2047] *** empty log message *** --- ChangeLog | 2 ++ RELEASE | 2 ++ libguile/ChangeLog | 4 ++-- 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index 8d02e791f..eec6cba1c 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,7 @@ 2001-06-14 Marius Vollmer + * libguile.h: Added deprecated section with the olde type names. + * configure.in: Check for header . Check for uintptr_t type. Use AC_CHECK_TYPES for this. Do not caus ptrdiff_t to be `#defined'. diff --git a/RELEASE b/RELEASE index d653a367b..a26eec933 100644 --- a/RELEASE +++ b/RELEASE @@ -22,6 +22,8 @@ After signal handling and threading have been fixed: === In release 1.8.0: +- remove deprecated "scm_*_t" type names in libguile.h. + - remove re-exporting behaviour of `export'. in boot-9.scm, remove begin-deprecated part of `module-export!' in format.scm, remove kluge at top diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 549401a40..330e5b090 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,7 +1,7 @@ 2001-06-14 Marius Vollmer - Throughout: replace "scm_*_t" with "scm_t_*". - + Throughout: replace "scm_*_t" with "scm_t_*", except "scm_lisp_t". + 2001-06-14 Marius Vollmer * unif.h (SCM_ARRAY_NDIM): Shift then cast so that no sign From 673509f84f8b0fe3e5593e5473c844ce97c6075b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 14 Jun 2001 20:36:06 +0000 Subject: [PATCH 1327/2047] * scripts/README, scripts/hello.scm, safe/untrusted.scm, safe/evil.scm, safe/README, modules/README, modules/main, modules/module-0.scm, modules/module-1.scm, modules/module-2.scm: Minor cleanup. * README: Added intro stuff, restructured a bit. * box-dynamic/README, box-module/README, box/README: Cleanup and restructuring. * box-dynamic-module/box-mixed.scm: New file, demonstrating usage of extension library functionality, but without exporting procedures from the library. Thanks to Thomas Wawrzinek for the idea and example code! * box-dynamic-module/box-module.scm: Add comments, export make-box, box-ref, box-set!. * box-dynamic-module/README: Integrate new module (box-mixed), restructure and cleanup a bit. --- examples/ChangeLog | 24 +++++++++++ examples/README | 23 +++++++++-- examples/box-dynamic-module/Makefile.am | 2 +- examples/box-dynamic-module/README | 47 ++++++++++++++++++---- examples/box-dynamic-module/box-mixed.scm | 44 ++++++++++++++++++++ examples/box-dynamic-module/box-module.scm | 12 +++++- examples/box-dynamic-module/box.c | 35 ++++------------ examples/box-dynamic/README | 25 ++++++++++-- examples/box-module/README | 16 +++++++- examples/box/README | 16 +++++++- examples/modules/README | 12 ++++-- examples/modules/module-0.scm | 2 + examples/modules/module-1.scm | 2 + examples/modules/module-2.scm | 2 + examples/safe/README | 13 ++++-- examples/safe/evil.scm | 2 + examples/safe/untrusted.scm | 2 + examples/scripts/README | 13 ++++-- examples/scripts/fact | 1 - examples/scripts/hello | 1 - examples/scripts/simple-hello.scm | 2 + 21 files changed, 236 insertions(+), 60 deletions(-) create mode 100644 examples/box-dynamic-module/box-mixed.scm diff --git a/examples/ChangeLog b/examples/ChangeLog index fda148a24..5af8d9b05 100644 --- a/examples/ChangeLog +++ b/examples/ChangeLog @@ -1,3 +1,27 @@ +2001-06-14 Martin Grabmueller + + * scripts/README, scripts/hello.scm, safe/untrusted.scm, + safe/evil.scm, safe/README, modules/README, modules/main, + modules/module-0.scm, modules/module-1.scm, modules/module-2.scm: + Minor cleanup. + + * README: Added intro stuff, restructured a bit. + + * box-dynamic/README, box-module/README, box/README: Cleanup and + restructuring. + + * box-dynamic-module/box-mixed.scm: New file, demonstrating usage + of extension library functionality, but without exporting + procedures from the library. + + Thanks to Thomas Wawrzinek for the idea and example code! + + * box-dynamic-module/box-module.scm: Add comments, export + make-box, box-ref, box-set!. + + * box-dynamic-module/README: Integrate new module (box-mixed), + restructure and cleanup a bit. + 2001-06-06 Martin Grabmueller * box-dynamic-module/box-module.scm: New file. diff --git a/examples/README b/examples/README index 2a362f2cd..793d131c8 100644 --- a/examples/README +++ b/examples/README @@ -1,12 +1,28 @@ - -*- text -*- + -*- outline -*- + +* Overview This directory contains examples illustrating various aspects of Guile programming. +If you plan writing Scheme programs, have a look at the `scripts' +directory. To learn more about Guile modules, check out the `modules' +directory, and maybe the `box-module' and `box-dynamic-module' +directories, if you are into C programming or shared libraries, +respectively. The `safe' directory contains examples for evaluation +Scheme code in controlled environments (sandboxing). The directories +`box', `box-module', `box-dynamic' and `box-dynamic-module' are +interesting if you plan writing Guile extensions. + See the README files in the subdirectories for details. + +* Included Examples + scripts Examples for writing simple scripts in Guile Scheme. + box Example for extending Guile with a new data type. + box-module Similar to `box', but defines new procedures in a named module. box-dynamic Implements the box type in a dynamically loadable @@ -14,6 +30,7 @@ box-dynamic Implements the box type in a dynamically loadable box-dynamic-module Combination of `box-module' and `box-dynamic': Implements the `box' type in a shared library and defines the procedures in a Guile module. -modules Examples for writing and using Guile modules. -safe Examples for creating and using safe environments. +modules Examples for writing and using Guile modules. + +safe Examples for creating and using safe environments. diff --git a/examples/box-dynamic-module/Makefile.am b/examples/box-dynamic-module/Makefile.am index ca157f2bc..4d7df0210 100644 --- a/examples/box-dynamic-module/Makefile.am +++ b/examples/box-dynamic-module/Makefile.am @@ -19,7 +19,7 @@ ## to the Free Software Foundation, Inc., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA -EXTRA_DIST = README box.c box-module.scm +EXTRA_DIST = README box.c box-module.scm box-mixed.scm CFLAGS=`guile-config compile` LIBS=`guile-config link` diff --git a/examples/box-dynamic-module/README b/examples/box-dynamic-module/README index 6e4636fa3..5097ec7d9 100644 --- a/examples/box-dynamic-module/README +++ b/examples/box-dynamic-module/README @@ -1,35 +1,44 @@ - -*- text -*- + -*- outline -*- + +* Overview This directory includes an example program for extending Guile with a new (and even useful) data type, putting it into a shared library, so it can be called from an unmodified guile interpreter. Further, the shared library defines a new guile module. + +* Build Instructions + To build the example, simply type make libbox-module in this directory. + +* The Box Data Type + A box is simply an object for storing one other object in. It can be used for passing parameters by reference, for example. You simply store an object into a box, pass it to another procedure which can store a new object into it and thus return a value via the box. + +** Usage + Box objects are created with `make-box', set with `box-set!' and examined with `box-ref'. Note that these procedures are placed in a module called (box-module) and can thus only be accessed after using -this module. See the following example session for usage details: +this module. See the following example session for usage details. + + +** The Module (box-module) Extend your LD_LIBRARY_PATH variable (or equivalent) to include . and .libs and make sure that your current working directory is the one this file is contained in. -If you like this example so much that you want to have it available -for normal usage, install the dynamic libraries in the .libs directory -to the directory $(prefix)/lib and the scheme file `box-module.scm' in -a directory in your GUILE_LOAD_PATH. - $ guile guile> (use-modules (box-module)) guile> (define b (make-box)) @@ -42,3 +51,27 @@ guile> (box-ref b) (list of values) guile> (quit) $ + + +** The Module (box-mixed) + +The following example uses the module (box-mixed), also included in +this directory. It uses the shared library libbox-module like the +module (box-module) above, but does not export the procedures from +that module. It only implements some procedures for dealing with box +objects. + +$ guile +guile> (use-modules (box-mixed)) +guile> (define bl (make-box-list 1 2 3)) +guile> bl +(# # #) +guile> (box-map (lambda (el) (make-box-list (list el))) bl) +(#)> #)> #)>) +guile> (quit) +$ + +If you like this example so much that you want to have it available +for normal usage, install the dynamic libraries in the .libs directory +to the directory $(prefix)/lib and the scheme file `box-module.scm' in +a directory in your GUILE_LOAD_PATH. diff --git a/examples/box-dynamic-module/box-mixed.scm b/examples/box-dynamic-module/box-mixed.scm new file mode 100644 index 000000000..9e6135291 --- /dev/null +++ b/examples/box-dynamic-module/box-mixed.scm @@ -0,0 +1,44 @@ +;;; examples/box-dynamic-module/box-mixed.scm -- Scheme module using some +;;; functionality from the shared library libbox-module, but do not +;;; export procedures from the module. + +;;; Commentary: + +;;; This is the Scheme module box-mixed. It uses some functionality +;;; from the shared library libbox-module, but does not export it. + +;;; Code: + +;;; Author: Thomas Wawrzinek +;;; Date: 2001-06-08 +;;; Changed: 2001-06-14 by martin, some commenting, cleanup and integration. + +(define-module (box-mixed)) + +;; First, load the library. +;; +(load-extension "libbox-module" "scm_init_box") + +;; Create a list of boxes, each containing one element from ARGS. +;; +(define (make-box-list . args) + (map (lambda (el) + (let ((b (make-box))) + (box-set! b el) b)) + args)) + +;; Map the procedure FUNC over all elements of LST, which must be a +;; list of boxes. The result is a list of freshly allocated boxes, +;; each containing the result of an application of FUNC. +(define (box-map func lst) + (map (lambda (el) + (let ((b (make-box))) + (box-set! b (func (box-ref el))) + b)) + lst)) + +;; Export the procedures, so that they can be used by others. +;; +(export make-box-list box-map) + +;;; End of file. diff --git a/examples/box-dynamic-module/box-module.scm b/examples/box-dynamic-module/box-module.scm index cab41c7e5..ab589ba1b 100644 --- a/examples/box-dynamic-module/box-module.scm +++ b/examples/box-dynamic-module/box-module.scm @@ -1,5 +1,5 @@ -;;; examples/box-dynamic-module/box-module.scm -- Scheme part of the -;;; dynamic module (box-module) +;;; examples/box-dynamic-module/box-module.scm -- Scheme module exporting +;;; some functionality from the shared library libbox-module. ;;; Commentary: @@ -14,4 +14,12 @@ (define-module (box-module)) +;; First, load the library. +;; (load-extension "libbox-module" "scm_init_box") + +;; Then export the procedures which should be visible to module users. +;; +(export make-box box-ref box-set!) + +;;; End of file. diff --git a/examples/box-dynamic-module/box.c b/examples/box-dynamic-module/box.c index fa9eaff41..c159a8f82 100644 --- a/examples/box-dynamic-module/box.c +++ b/examples/box-dynamic-module/box.c @@ -107,14 +107,13 @@ box_set_x (SCM b, SCM value) #undef FUNC_NAME -/* Create and initialize the new smob type, and register the - primitives withe the interpreter library. - - This function must be declared a bit different from the example in - the ../box directory, because it will be called by - `scm_c_define_module', called from below. */ -static void -init_box_type (void * unused) +/* This is the function which must be given to `load-extension' as the + second argument. In this example, the Scheme file box-module.scm + (or box-mixed.scm) is responsible for doing the load-extension + call. The Scheme modules are also responsible for placing the + procedure definitions in the correct module. */ +void +scm_init_box () { scm_tc16_box = scm_make_smob_type ("box", 0); scm_set_smob_mark (scm_tc16_box, mark_box); @@ -123,26 +122,6 @@ init_box_type (void * unused) scm_c_define_gsubr ("make-box", 0, 0, 0, make_box); scm_c_define_gsubr ("box-set!", 2, 0, 0, box_set_x); scm_c_define_gsubr ("box-ref", 1, 0, 0, box_ref); - - /* This is new too: Since the procedures are now in a module, we - have to explicitly export them before they can be used. */ - scm_c_export ("make-box", "box-set!", "box-ref", NULL); -} - -/* This is the function which must be given to `load-extension' as the - second argument. It will initialize the shared, library, but will - place the definitions in a module called (box-module), so that an - additional (use-modules (box-module)) is needed to make them - accessible. In this example, the Scheme file box-module.scm is - responsible for doing the load-extension call. */ -void -scm_init_box () -{ - /* Unlike the example in ../box, init_box_type is not called - directly, but by scm_c_define_module, which will create a module - named (box-module) and make this module current while called - init_box_type, thus placing the definitions into that module. */ - scm_c_define_module ("box-module", init_box_type, NULL); } /* End of file. */ diff --git a/examples/box-dynamic/README b/examples/box-dynamic/README index 561e4841a..bb87b5db7 100644 --- a/examples/box-dynamic/README +++ b/examples/box-dynamic/README @@ -1,20 +1,31 @@ - -*- text -*- + -*- outline -*- + +* Overview This directory includes an example program for extending Guile with a new (and even useful) data type, putting it into a shared library, so it can be called from an unmodified guile interpreter. + +* Build Instructions + To build the example, simply type make libbox in this directory. + +* The Box Data Type + A box is simply an object for storing one other object in. It can be used for passing parameters by reference, for example. You simply store an object into a box, pass it to another procedure which can store a new object into it and thus return a value via the box. + +** Usage + Box objects are created with `make-box', set with `box-set!' and examined with `box-ref'. Note that these procedures are placed in a module called (box-module) and can thus only be accessed after using @@ -23,9 +34,8 @@ this module. See the following example session for usage details: Extend your LD_LIBRARY_PATH variable (or equivalent) to include . and .libs -If you like this example so much that you want to have it available -for normal usage, install the dynamic libraries in the .libs directory -to the directory $(prefix)/lib + +** Example Session $ ./guile guile> (load-extension "libbox" "scm_init_box") @@ -39,3 +49,10 @@ guile> (box-ref b) (list of values) guile> (quit) $ + + +* Module Installation + +If you like this example so much that you want to have it available +for normal usage, install the dynamic libraries in the .libs directory +to the directory $(prefix)/lib diff --git a/examples/box-module/README b/examples/box-module/README index 7f5d8521d..e1f1cd7af 100644 --- a/examples/box-module/README +++ b/examples/box-module/README @@ -1,4 +1,6 @@ - -*- text -*- + -*- outline -*- + +* Overview This directory includes an example program for extending Guile with a new (and even useful) data type. @@ -9,6 +11,9 @@ interpreter in this directory will place all defined primitive procedures in a module called (box-module). That means that this module must be used before the primitives can be accessed. + +* Build Instructions + To build the example, simply type make box @@ -18,16 +23,25 @@ in this directory. The resulting `box' program is a Guile interpreter which has one additional data type called `box'. + +* The Box Data Type + A box is simply an object for storing one other object in. It can be used for passing parameters by reference, for example. You simply store an object into a box, pass it to another procedure which can store a new object into it and thus return a value via the box. + +** Usage + Box objects are created with `make-box', set with `box-set!' and examined with `box-ref'. Note that these procedures are placed in a module called (box-module) and can thus only be accessed after using this module. See the following example session for usage details: + +** Example Session + $ ./box guile> (use-modules (box-module)) guile> (define b (make-box)) diff --git a/examples/box/README b/examples/box/README index 78b7762ef..fb0ef1305 100644 --- a/examples/box/README +++ b/examples/box/README @@ -1,8 +1,13 @@ - -*- text -*- + -*- outline -*- + +* Overview This directory includes an example program for extending Guile with a new (and even useful) data type. + +* Build Instructions + To build the example, simply type make box @@ -12,15 +17,24 @@ in this directory. The resulting `box' program is a Guile interpreter which has one additional data type called `box'. + +* The Box Data Type + A box is simply an object for storing one other object in. It can be used for passing parameters by reference, for example. You simply store an object into a box, pass it to another procedure which can store a new object into it and thus return a value via the box. + +** Usage + Box objects are created with `make-box', set with `box-set!' and examined with `box-ref'. See the following example session for usage details: + +** Example Session + $ ./box guile> (define b (make-box)) guile> b diff --git a/examples/modules/README b/examples/modules/README index 12df77f69..ddad881cc 100644 --- a/examples/modules/README +++ b/examples/modules/README @@ -1,4 +1,6 @@ - -*- text -*- + -*- outline -*- + +* Overview This directory includes examples which show how to write and use Guile modules in Scheme programs. @@ -7,7 +9,11 @@ The descriptions below assume that you have a working copy of Guile installed and available with the standard installation prefix `/usr/local'. -main: + +* Included Examples + + +** main The main program, which uses the modules described below to perform some actions. Module usage and selective importing as well as @@ -19,7 +25,7 @@ main: guile -s main -module-0.scm, module-1.scm, module-2.scm: +** module-0.scm, module-1.scm, module-2.scm Two modules which export several procedure, some of which have the same names (so that renaming/selection is required for proper diff --git a/examples/modules/module-0.scm b/examples/modules/module-0.scm index 47e8433c7..a5a001b64 100644 --- a/examples/modules/module-0.scm +++ b/examples/modules/module-0.scm @@ -20,3 +20,5 @@ (define (bar) (display "module-0 bar") (newline)) + +;;; End of file. diff --git a/examples/modules/module-1.scm b/examples/modules/module-1.scm index d62264021..6a7bb43e0 100644 --- a/examples/modules/module-1.scm +++ b/examples/modules/module-1.scm @@ -20,3 +20,5 @@ (define (bar) (display "module-1 bar") (newline)) + +;;; End of file. diff --git a/examples/modules/module-2.scm b/examples/modules/module-2.scm index a63d5e492..3147b2cab 100644 --- a/examples/modules/module-2.scm +++ b/examples/modules/module-2.scm @@ -24,3 +24,5 @@ (define (braz) (display "module-2 braz") (newline)) + +;;; End of file. diff --git a/examples/safe/README b/examples/safe/README index be16e1e74..47abcbf9f 100644 --- a/examples/safe/README +++ b/examples/safe/README @@ -1,4 +1,6 @@ - -*- text -*- + -*- outline -*- + +* Overview This directory includes examples which show how to create and use safe environments for safe (sand-boxed) execution of Scheme programs. @@ -12,7 +14,10 @@ The descriptions below assume that you have a working copy of Guile installed and available with the standard installation prefix `/usr/local'. -safe: +* Included Examples + + +** safe The main program, which executes the Scheme code in a file given on the command line in a safe environment. The following command will @@ -24,12 +29,12 @@ safe: guile -s safe untrusted.scm -untrusted.scm: +** untrusted.scm This file contains some Scheme code, which will be executed in a safe environment by the `safe' script. -evil.scm +** evil.scm This file also contains Scheme code, but it tries to do evil things. Evaluating this with the `safe' script will abort on those evil diff --git a/examples/safe/evil.scm b/examples/safe/evil.scm index 9eb64db8e..f9ee9082f 100644 --- a/examples/safe/evil.scm +++ b/examples/safe/evil.scm @@ -23,3 +23,5 @@ (let lp ((ch (read-char passwd))) (if (not (eof-object? ch)) (lp (read-char passwd)))) + +;;; End of file. diff --git a/examples/safe/untrusted.scm b/examples/safe/untrusted.scm index 9cdf1b640..f3ae5fe97 100644 --- a/examples/safe/untrusted.scm +++ b/examples/safe/untrusted.scm @@ -29,3 +29,5 @@ ((= x 11)) (display (fact x)) (newline)) + +;;; End of file. diff --git a/examples/scripts/README b/examples/scripts/README index 491007c27..f3e965b5a 100644 --- a/examples/scripts/README +++ b/examples/scripts/README @@ -1,4 +1,6 @@ - -*- text -*- + -*- outline -*- + +* Overview This directory includes examples which show how to write scripts using Guile. @@ -7,13 +9,16 @@ The descriptions below assume that you have a working copy of Guile installed and available with the standard installation prefix `/usr/local'. -simple-hello.scm: +* Included Examples + + +** simple-hello.scm The simplest "Hello World!" program for Guile. Run it like this: $ guile -s simple-hello.scm -hello: +** hello An advanced version of the script above, with command line handling for the important options --help and --version. Run it like this: @@ -24,7 +29,7 @@ hello: guile -s hello -fact: +** fact Command-line factorial calculator. Run it like this: diff --git a/examples/scripts/fact b/examples/scripts/fact index 90eecd7c2..05bcc9ffe 100755 --- a/examples/scripts/fact +++ b/examples/scripts/fact @@ -67,4 +67,3 @@ ;; Local variables: ;; mode: scheme ;; End: - diff --git a/examples/scripts/hello b/examples/scripts/hello index 4108db400..afeb64781 100755 --- a/examples/scripts/hello +++ b/examples/scripts/hello @@ -55,4 +55,3 @@ ;; Local variables: ;; mode: scheme ;; End: - diff --git a/examples/scripts/simple-hello.scm b/examples/scripts/simple-hello.scm index 713a1aee4..b46bc36ff 100644 --- a/examples/scripts/simple-hello.scm +++ b/examples/scripts/simple-hello.scm @@ -12,3 +12,5 @@ (display "Hello, World!") (newline) + +;;; End of file. From 2aebf10d7382640ccb59503a9d5b7b445c19faa1 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 14 Jun 2001 20:47:05 +0000 Subject: [PATCH 1328/2047] Stuff about our naming conventions. --- HACKING | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/HACKING b/HACKING index e5ae2aea4..b837a38cc 100644 --- a/HACKING +++ b/HACKING @@ -292,6 +292,35 @@ the list of years in the copyright notice at the top of the file. them in THANKS. +- Naming conventions. We use certain naming conventions to structure + the considerable number of global identifiers. All identifiers + should be either all lower case or all upper case. Syllables are + separated by underscaores `_'. All non-static identifiers should + start with scm_ or SCM_. Then might follow zero or more one letter + syllables giving the category of the identifier. The currently used + category identifiers are + + t - type name + + c,C - something with a interface suited for C use. This is used + to name functions that behave like Scheme primitives but + have a more C friendly calling convention. + + i,I - internal to libguile. It is global, but not considered part + of the libguile API. + + f - a SCM variable pointing to a Scheme function object. + + F - a bit mask for a flag. + + m - a macro transformer procedure + + n,N - a count of something + + s - a constant C string + + + Helpful hints ======================================================== - [From Mikael Djurfeldt] When working on the Guile internals, it is From 025f75b48fc3bbf84b2eaf067010ff5519099605 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 16 Jun 2001 20:11:39 +0000 Subject: [PATCH 1329/2047] =?UTF-8?q?New=20files.=20=20Thanks=20to=20Matth?= =?UTF-8?q?ias=20K=C3=B6ppe!?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- test-suite/tests/format.test | 39 ++++++++++ test-suite/tests/optargs.test | 29 ++++++++ test-suite/tests/srfi-19.test | 133 ++++++++++++++++++++++++++++++++++ 3 files changed, 201 insertions(+) create mode 100644 test-suite/tests/format.test create mode 100644 test-suite/tests/optargs.test create mode 100644 test-suite/tests/srfi-19.test diff --git a/test-suite/tests/format.test b/test-suite/tests/format.test new file mode 100644 index 000000000..dd740579b --- /dev/null +++ b/test-suite/tests/format.test @@ -0,0 +1,39 @@ +;;;; format.test --- test suite for Guile's CL-ish format -*- scheme -*- +;;;; Matthias Koeppe --- June 2001 +;;;; +;;;; Copyright (C) 2001 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +(use-modules (test-suite lib) + (ice-9 format)) + +;;; FORMAT Basic Output + +(with-test-prefix "format basic output" + (pass-if "format ~% produces a new line" + (string=? (format "~%") "\n")) + (pass-if "format ~& starts a fresh line" + (string=? (format "~&abc~&~&") "abc\n")) + (pass-if "format ~& is stateless but works properly across outputs via port-column" + (string=? + (with-output-to-string + (lambda () + (display "xyz") + (format #t "~&abc") + (format #f "~&") ; shall have no effect + (format #t "~&~&"))) + "xyz\nabc\n"))) diff --git a/test-suite/tests/optargs.test b/test-suite/tests/optargs.test new file mode 100644 index 000000000..4f356b020 --- /dev/null +++ b/test-suite/tests/optargs.test @@ -0,0 +1,29 @@ +;;;; optargs.test --- test suite for optional arg processing -*- scheme -*- +;;;; Matthias Koeppe --- June 2001 +;;;; +;;;; Copyright (C) 2001 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +(use-modules (test-suite lib) + (ice-9 optargs)) + +(with-test-prefix "optional argument processing" + (define* (test-1 #:optional (x 0)) + (define d 1) ; local define + #t) + (pass-if "local defines work with optional arguments" + (false-if-exception (test-1)))) diff --git a/test-suite/tests/srfi-19.test b/test-suite/tests/srfi-19.test new file mode 100644 index 000000000..4065b0556 --- /dev/null +++ b/test-suite/tests/srfi-19.test @@ -0,0 +1,133 @@ +;;;; srfi-19.test --- test suite for SRFI-19 -*- scheme -*- +;;;; Matthias Koeppe --- June 2001 +;;;; +;;;; Copyright (C) 2001 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +;; SRFI-19 overrides current-date, so we have to do the test in a +;; separate module, or later tests will fail. + +(define-module (test-suite test-srfi-19) + :use-module (test-suite lib) + :use-module (srfi srfi-19) + :use-module (ice-9 format)) + +(define (with-tz* tz thunk) + "Temporarily set the TZ environment variable to the passed string +value and call THUNK." + (let ((old-tz #f)) + (dynamic-wind + (lambda () + (set! old-tz (getenv "TZ")) + (putenv (format "TZ=~A" tz))) + thunk + (lambda () + (if old-tz + (putenv (format "TZ=~A" old-tz)) + (putenv "TZ")))))) + +(defmacro with-tz (tz . body) + `(with-tz* ,tz (lambda () ,@body))) + +(define (test-integral-time-structure date->time) + "Test whether the given DATE->TIME procedure creates a time +structure with integral seconds. (The seconds shall be maintained as +integers, or precision may go away silently. The SRFI-19 reference +implementation was not OK for Guile in this respect because of Guile's +incomplete numerical tower implementation.)" + (pass-if (format "~A makes integer seconds" + date->time) + (exact? (time-second + (date->time (make-date 0 0 0 12 1 6 2001 0)))))) + +(define (test-time->date time->date date->time) + (pass-if (format "~A works" + time->date) + (begin + (time->date (date->time (make-date 0 0 0 12 1 6 2001 0))) + #t))) + +(define (test-dst time->date date->time) + (pass-if (format "~A respects local DST if no TZ-OFFSET given" + time->date) + (let ((time (date->time (make-date 0 0 0 12 1 6 2001 0)))) + ;; on 2001-06-01, there should be two hours zone offset + ;; between CET (CEST) and GMT + (= (date-zone-offset + (with-tz "CET" + (time->date time))) + 7200)))) + +(define-macro (test-time-conversion a b) + (let* ((a->b-sym (symbol-append a '-> b)) + (b->a-sym (symbol-append b '-> a))) + `(pass-if (format "~A and ~A work and are inverses of each other" + ',a->b-sym ',b->a-sym) + (let ((time (make-time ,a 12345 67890123))) + (time=? time (,b->a-sym (,a->b-sym time))))))) + +(with-test-prefix "SRFI date/time library" + ;; check for typos and silly errors + (pass-if "date-zone-offset is defined" + (and (defined? 'date-zone-offset) + date-zone-offset + #t)) + (pass-if "add-duration is defined" + (and (defined? 'add-duration) + add-duration + #t)) + (pass-if "(current-time time-tai) works" + (begin (current-time time-tai) #t)) + (test-time-conversion time-utc time-tai) + (test-time-conversion time-utc time-monotonic) + (test-time-conversion time-tai time-monotonic) + (pass-if "string->date works" + (begin (string->date "2001-06-01@14:00" "~Y-~m-~d@~H:~M") + #t)) + ;; check for code paths where reals were passed to quotient, which + ;; doesn't work in Guile (and is unspecified in R5RS) + (test-time->date time-utc->date date->time-utc) + (test-time->date time-tai->date date->time-tai) + (test-time->date time-monotonic->date date->time-monotonic) + (pass-if "Fractional nanoseconds are handled" + (begin (make-time time-duration 1000000000.5 0) #t)) + ;; the seconds in a time shall be maintained as integers, or + ;; precision may silently go away + (test-integral-time-structure date->time-utc) + (test-integral-time-structure date->time-tai) + (test-integral-time-structure date->time-monotonic) + ;; check for DST and zone related problems + (pass-if "date->time-utc is the inverse of time-utc->date" + (let ((time (date->time-utc + (make-date 0 0 0 14 1 6 2001 7200)))) + (time=? time + (date->time-utc (time-utc->date time 7200))))) + (test-dst time-utc->date date->time-utc) + (test-dst time-tai->date date->time-tai) + (test-dst time-monotonic->date date->time-monotonic) + (test-dst julian-day->date date->julian-day) + (test-dst modified-julian-day->date date->modified-julian-day) + (pass-if "string->date respects local DST if no time zone is read" + (time=? (date->time-utc + (with-tz "CET" + (string->date "2001-06-01@14:00" "~Y-~m-~d@~H:~M"))) + (date->time-utc + (make-date 0 0 0 12 1 6 2001 0))))) + +;; Local Variables: +;; eval: (put 'with-tz 'scheme-indent-function 1) +;; End: From 9a8be5a707bc29f2861368e2022576b63225ed74 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 16 Jun 2001 20:13:50 +0000 Subject: [PATCH 1330/2047] * tests/ports.test: New test for output port line counts. --- test-suite/tests/ports.test | 31 ++++++++++++++++++++++++++++++- 1 file changed, 30 insertions(+), 1 deletion(-) diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index e941f91bd..6fa39cd8a 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -380,7 +380,36 @@ "He who receives an idea from me, receives instruction" 15))) - +;; Test port-line and port-column for output ports + +(define (test-output-line-counter text final-column) + (with-test-prefix "port-line and port-column for output ports" + (let ((port (open-output-string))) + (pass-if "at beginning of input" + (and (= (port-line port) 0) + (= (port-column port) 0))) + (write-char #\x port) + (pass-if "after writing one character" + (and (= (port-line port) 0) + (= (port-column port) 1))) + (write-char #\newline port) + (pass-if "after writing first newline char" + (and (= (port-line port) 1) + (= (port-column port) 0))) + (display text port) + (pass-if "line count is 5 at end" + (= (port-line port) 5)) + (pass-if "column is correct at end" + (= (port-column port) final-column))))) + +(test-output-line-counter + (string-append "He who receives an idea from me, receives instruction\n" + "himself without lessening mine; as he who lights his\n" + "taper at mine, receives light without darkening me.\n" + " --- Thomas Jefferson\n" + "no newline here") + 15) + ;;;; testing read-delimited and friends (with-test-prefix "read-delimited!" From 019ac1c98780291cb3732fc5cc501118f3567893 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 16 Jun 2001 20:14:24 +0000 Subject: [PATCH 1331/2047] (system-error-errno): New. --- ice-9/boot-9.scm | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index cad2a8548..bc6aff060 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -481,6 +481,11 @@ (and (> sl sufl) (string=? (substring str (- sl sufl) sl) suffix)))) +(define (system-error-errno args) + (if (eq? (car args) 'system-error) + (car (list-ref args 4)) + #f)) + ;;; {Error Handling} ;;; From daabbf15d70430e8c042be71d8757f8f813cfa7d Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 16 Jun 2001 20:16:12 +0000 Subject: [PATCH 1332/2047] (Conventions): Use `system-error-errno' instead of explicit code --- doc/posix.texi | 16 +++++----------- 1 file changed, 5 insertions(+), 11 deletions(-) diff --git a/doc/posix.texi b/doc/posix.texi index e16d0307a..300a7057b 100644 --- a/doc/posix.texi +++ b/doc/posix.texi @@ -68,15 +68,12 @@ the documentation. For ways to deal with exceptions, @ref{Exceptions}. -Errors which the C-library would report by returning a NULL -pointer or through some other means are reported by raising a -@code{system-error} exception. -The value of the Unix @code{errno} variable is available +Errors which the C-library would report by returning a NULL pointer or +through some other means are reported by raising a @code{system-error} +exception. The value of the Unix @code{errno} variable is available in the data passed by the exception. -Here's an ad-hoc@footnote{This may be changed in the future; be prepared -to rewrite this sort of code.} way to extract the @code{errno} value -from an exception: +It can be extracted with the function @code{system-error-errno}: @example (catch @@ -84,7 +81,7 @@ from an exception: (lambda () (mkdir "/this-ought-to-fail-if-I'm-not-root")) (lambda stuff - (let ((errno (car (list-ref stuff 4)))) + (let ((errno (system-error-errno 4))) (cond ((= errno EACCES) (display "You're not allowed to do that.")) @@ -95,9 +92,6 @@ from an exception: (newline)))) @end example -The important thing to note is that the @code{errno} value can be -extracted with @code{(car (list-ref stuff 4))}. - @node Ports and File Descriptors @section Ports and File Descriptors From 485ffecad5225b21727dc5965274b7f3fb1827ee Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 16 Jun 2001 20:17:19 +0000 Subject: [PATCH 1333/2047] (scm_cond_t, scm_key_t, scm_mutex_t): Only define these when using threads. --- libguile.h | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/libguile.h b/libguile.h index f006528fe..c5fc73387 100644 --- a/libguile.h +++ b/libguile.h @@ -151,7 +151,6 @@ typedef scm_t_c_hook scm_c_hook_t; typedef scm_t_catch_body scm_catch_body_t; typedef scm_t_catch_handler scm_catch_handler_t; typedef scm_t_complex scm_complex_t; -typedef scm_t_cond scm_cond_t; typedef scm_t_contregs scm_contregs_t; typedef scm_t_debug_frame scm_debug_frame_t; typedef scm_t_debug_info scm_debug_info_t; @@ -161,9 +160,7 @@ typedef scm_t_guard scm_guard_t; typedef scm_t_i_rstate scm_i_rstate_t; typedef scm_t_info_frame scm_info_frame_t; typedef scm_t_inner scm_inner_t; -typedef scm_t_key scm_key_t; typedef scm_t_method scm_method_t; -typedef scm_t_mutex scm_mutex_t; typedef scm_t_option scm_option_t; typedef scm_t_port_rw_active scm_port_rw_active_t; typedef scm_t_port scm_port_t; @@ -177,6 +174,14 @@ typedef scm_t_stack scm_stack_t; typedef scm_t_struct_free scm_struct_free_t; typedef scm_t_subr_entry scm_subr_entry_t; +#ifdef USE_THREADS + +typedef scm_t_cond scm_cond_t; +typedef scm_t_key scm_key_t; +typedef scm_t_mutex scm_mutex_t; + +#endif + #endif /* !SCM_DEBUG_DEPRECATED */ #ifdef __cplusplus From eb6c2de855c8c24ed1f28531c3c340da26bd16a8 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 16 Jun 2001 20:17:50 +0000 Subject: [PATCH 1334/2047] *** empty log message *** --- AUTHORS | 6 ++++++ ChangeLog | 5 +++++ doc/ChangeLog | 5 +++++ ice-9/ChangeLog | 4 ++++ test-suite/ChangeLog | 8 ++++++++ 5 files changed, 28 insertions(+) diff --git a/AUTHORS b/AUTHORS index db912e6f3..8c3e87a4f 100644 --- a/AUTHORS +++ b/AUTHORS @@ -242,6 +242,12 @@ Marc Feeley: In the subdirectory doc, wrote: pretty-print.scm +Matthias Koeppe: +In the subdirectory test-suite/tests, wrote + format.test, srfi-19.test, optargs.test +In the subdirectory test-suite/tests, changes to + ports.test + The file libguile/gc_os_dep.c is from the Boehm-Weiser conservative collector. A lot of people have contributed to it, but probably not all to the code in gc_os_dep.c: diff --git a/ChangeLog b/ChangeLog index eec6cba1c..e9404f91a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2001-06-16 Marius Vollmer + + * libguile.h (scm_cond_t, scm_key_t, scm_mutex_t): Only define + these when using threads. + 2001-06-14 Marius Vollmer * libguile.h: Added deprecated section with the olde type names. diff --git a/doc/ChangeLog b/doc/ChangeLog index 366a64dac..900deff30 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,8 @@ +2001-06-16 Marius Vollmer + + * posix.texi (Conventions): Use `system-error-errno' instead of + explicit code + 2001-06-04 Gary Houston * scheme-io.texi (Block Reading and Writing): added diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 8dddec587..6df92b26a 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2001-06-16 Marius Vollmer + + * boot-9.scm (system-error-errno): New. + 2001-06-14 Marius Vollmer * common-list.scm (remove-if, remove-if-not): Fix typo: use diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index a31a0dfec..afb2667f5 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,11 @@ +2001-06-16 Marius Vollmer + + Thanks to Matthias Köppe! + + * tests/ports.test: New test for output port line counts. + * tests/format.test, tests/optargs.test, tests/srfi-19.test: New + files. + 2001-05-28 Martin Grabmueller * tests/symbols.test ("gensym"): New tests for long gensym From f7b1cc84100e15096e728e4fa281dfbe719f2ad1 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 17 Jun 2001 20:32:26 +0000 Subject: [PATCH 1335/2047] Add entry for Keisuke Nishida. --- AUTHORS | 26 ++++++++++++++++++++++---- 1 file changed, 22 insertions(+), 4 deletions(-) diff --git a/AUTHORS b/AUTHORS index 8c3e87a4f..1b22ee443 100644 --- a/AUTHORS +++ b/AUTHORS @@ -19,7 +19,7 @@ In the subdirectory libguile, wrote: gsubr.c ramap.c unif.c gsubr.h ramap.h unif.h -Gary Houston: +Gary Houston: In the subdirectory libguile, wrote: rw.c In the subdirectory ice-9, wrote: @@ -178,7 +178,7 @@ In the subdirectory doc, changes to: In the subdirectory libguile, rewrote: environments.c, environments.h In the subdirectory libguile, changes to: - error.c, gc.c, gc.h, numbers.c, strings.c, symbols.c + error.c, gc.c, gc.h, numbers.c, strings.c, symbols.c In the subdirectory test-suite, rewrote: lib.scm In the subdirectory test-suite/tests, wrote: @@ -243,9 +243,9 @@ In the subdirectory doc, wrote: pretty-print.scm Matthias Koeppe: -In the subdirectory test-suite/tests, wrote +In the subdirectory test-suite/tests, wrote: format.test, srfi-19.test, optargs.test -In the subdirectory test-suite/tests, changes to +In the subdirectory test-suite/tests, changes to: ports.test The file libguile/gc_os_dep.c is from the Boehm-Weiser conservative @@ -291,3 +291,21 @@ all to the code in gc_os_dep.c: (Blame for misinstallation of these modifications goes to the first author, however.) +Keisuke Nishida: [added by ttn; kei, please review] +In the top-level directory, changes to: + libguile.h +In the subdirectory ice-9, wrote: + channel.scm history.scm time.scm + match.scm +In the subdirectory ice-9, changes to: + boot-9.scm receive.scm safe-r5rs.scm + common-list.scm +In the subdirectory emacs, wrote: + guile.el guile-scheme.el guile-emacs.scm +In the subdirectory libguile, changes to: + goops.c vectors.h vectors.c + eval.c hashtab.h hashtab.c + environments.c smob.h smob.c + keywords.c list.c strports.c + tag.c Makefile.am guile-snarf.awk.in +Many other changes throughout. From 837f9d198e6ad3a47521eb7d7748b86dd4e65d47 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 17 Jun 2001 20:45:33 +0000 Subject: [PATCH 1336/2047] fixed doc code bug --- doc/posix.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/posix.texi b/doc/posix.texi index 300a7057b..df7e757b5 100644 --- a/doc/posix.texi +++ b/doc/posix.texi @@ -81,7 +81,7 @@ It can be extracted with the function @code{system-error-errno}: (lambda () (mkdir "/this-ought-to-fail-if-I'm-not-root")) (lambda stuff - (let ((errno (system-error-errno 4))) + (let ((errno (system-error-errno stuff))) (cond ((= errno EACCES) (display "You're not allowed to do that.")) From 4549ba4ac60a39539a93e64b9ff383f1497adb46 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 18 Jun 2001 18:30:58 +0000 Subject: [PATCH 1337/2047] The SRFI-19 implementation was completely broken. Already the reference implementation did not handle DST and time zones properly and relied on non-R5RS-isms like passing reals to `quotient'. For Guile, some additional fixes were needed because of the incomplete numeric tower implementation. See also srfi-19.test. * srfi-19.scm (date-zone-offset): Fixed typo in export clause. (add-duration): Renamed from priv:add-duration. (priv:time-normalize!): Handle fractional nanoseconds; remove duplicate definition. (priv:current-time-tai): Fixed typo. (time=?, time<=?): Fixed typos. (time-tai->time-utc, time-utc->time-tai, time-utc->time-monotonic): Use make-time-unnormalized instead of make-time when uninitialized time fields are used. (set-date-nanosecond!, set-date-second!, set-date-minute!, set-date-hour!, set-date-day!, set-date-month!, set-date-year!, set-date-zone-offset!): Define. (priv:local-tz-offset): Take an extra argument in order to handle DST effects. (time-utc->date, time-tai->date, time-monotonic->date): Handle the changed signature of priv:local-tz-offset. Don't pass non-integer arguments to quotient (non-R5RS, not supported by Guile). (date->time-utc): Ensure that seconds in a date structure are always exact integers. Handle DST properly. (current-date, julian-day->date, modified-julian-day->date): Handle the changed signature of priv:local-tz-offset. (julian-day->time-utc): Reverted earlier inexact->exact hack; make-time now handles inexact arguments. (priv:locale-print-time-zone): At least print the numerical time zone. (priv:integer-reader): Fixed named let iteration. (priv:read-directives): Use set-date-month! instead of priv:set-date-month! etc. (string->date): Handle DST properly. --- srfi/srfi-19.scm | 210 +++++++++++++++++++++++++---------------------- 1 file changed, 113 insertions(+), 97 deletions(-) diff --git a/srfi/srfi-19.scm b/srfi/srfi-19.scm index 4c577b225..a059bc825 100644 --- a/srfi/srfi-19.scm +++ b/srfi/srfi-19.scm @@ -49,6 +49,13 @@ ;; substantial ones to be realized, esp. in the later "parsing" half ;; of the file, by rewriting the code with use of more Guile native ;; functions that do more work in a "chunk". +;; +;; FIXME: mkoeppe: Time zones are treated a little simplistic in +;; SRFI-19; they are only a numeric offset. Thus, printing time zones +;; (PRIV:LOCALE-PRINT-TIME-ZONE) can't be implemented sensibly. The +;; functions taking an optional TZ-OFFSET should be extended to take a +;; symbolic time-zone (like "CET"); this string should be stored in +;; the DATE structure. (define-module (srfi srfi-19) :use-module (srfi srfi-6) @@ -100,7 +107,7 @@ date-day date-month date-year - date-zone-offset? + date-zone-offset date-year-day date-week-day date-week-number @@ -304,13 +311,19 @@ (define (copy-time time) (make-time (time-type time) (time-nanosecond time) (time-second time))) +(define (priv:split-real r) + (if (integer? r) (values r 0) + (let ((l (truncate r))) + (values (inexact->exact l) (- r l))))) + (define (priv:time-normalize! t) (if (>= (abs (time-nanosecond t)) 1000000000) - (begin - (set-time-second! t (+ (time-second t) - (quotient (time-nanosecond t) 1000000000))) - (set-time-nanosecond! t (remainder (time-nanosecond t) - 1000000000)))) + (receive (int frac) + (priv:split-real (time-nanosecond t)) + (set-time-second! t (+ (time-second t) + (quotient int 1000000000))) + (set-time-nanosecond! t (+ (remainder int 1000000000) + frac)))) (if (and (positive? (time-second t)) (negative? (time-nanosecond t))) (begin @@ -360,7 +373,7 @@ (usec (cdr tod))) (make-time time-tai (* usec 1000) - (+ (car tod) (priv:leap-second-delta seconds))))) + (+ (car tod) (priv:leap-second-delta sec))))) ;;(define (priv:current-time-ms-time time-type proc) ;; (let ((current-ms (proc))) @@ -433,7 +446,7 @@ ;; Arrange tests for speed and presume that t1 and t2 are actually times. ;; also presume it will be rare to check two times of different types. (and (= (time-second t1) (time-second t2)) - (= (time-nanosecond t1) (time-nanosecond 2)) + (= (time-nanosecond t1) (time-nanosecond t2)) (eq? (time-type t1) (time-type t2)))) (define (time>? t1 t2) @@ -452,9 +465,9 @@ (>= (time-nanosecond t1) (time-nanosecond t2))))) (define (time<=? t1 t2) - (or (< (time-second time1) (time-second time2)) - (and (= (time-second time1) (time-second time2)) - (<= (time-nanosecond time1) (time-nanosecond time2))))) + (or (< (time-second t1) (time-second t2)) + (and (= (time-second t1) (time-second t2)) + (<= (time-nanosecond t1) (time-nanosecond t2))))) ;; -- Time arithmetic @@ -479,7 +492,7 @@ (set-time-nanosecond! t nsec-plus) (priv:time-normalize! t)))) -(define (priv:add-duration t duration) +(define (add-duration t duration) (let ((result (copy-time t))) (add-duration! result))) @@ -509,7 +522,7 @@ time-out) (define (time-tai->time-utc time-in) - (priv:time-tai->time-utc! time-in (make-time #f #f #f) 'time-tai->time-utc)) + (priv:time-tai->time-utc! time-in (make-time-unnormalized #f #f #f) 'time-tai->time-utc)) (define (time-tai->time-utc! time-in) @@ -526,7 +539,7 @@ time-out) (define (time-utc->time-tai time-in) - (priv:time-utc->time-tai! time-in (make-time #f #f #f) 'time-utc->time-tai)) + (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f) 'time-utc->time-tai)) (define (time-utc->time-tai! time-in) (priv:time-utc->time-tai! time-in time-in 'time-utc->time-tai!)) @@ -561,7 +574,7 @@ (define (time-utc->time-monotonic time-in) (if (not (eq? (time-type time-in) time-utc)) (priv:time-error caller 'incompatible-time-types time-in)) - (let ((ntime (priv:time-utc->time-tai! time-in (make-time #f #f #f) + (let ((ntime (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f) 'time-utc->time-monotonic))) (set-time-type! ntime time-monotonic) ntime)) @@ -598,34 +611,14 @@ year zone-offset) date? - (nanosecond date-nanosecond) - (second date-second) - (minute date-minute) - (hour date-hour) - (day date-day) - (month date-month) - (year date-year) - (zone-offset date-zone-offset)) - -(define (priv:time-normalize! t) - (if (>= (abs (time-nanosecond t)) 1000000000) - (begin - (set-time-second! t (+ (time-second t) - (quotient (time-nanosecond t) 1000000000))) - (set-time-nanosecond! t (remainder (time-nanosecond t) - 1000000000)))) - (if (and (positive? (time-second t)) - (negative? (time-nanosecond t))) - (begin - (set-time-second! t (- (time-second t) 1)) - (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t)))) - (if (and (negative? (time-second t)) - (positive? (time-nanosecond t))) - (begin - (set-time-second! t (+ (time-second t) 1)) - (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t)))))) - t) - + (nanosecond date-nanosecond set-date-nanosecond!) + (second date-second set-date-second!) + (minute date-minute set-date-minute!) + (hour date-hour set-date-hour!) + (day date-day set-date-day!) + (month date-month set-date-month!) + (year date-year set-date-year!) + (zone-offset date-zone-offset set-date-zone-offset!)) ;; gives the julian day which starts at noon. (define (priv:encode-julian-day-number day month year) @@ -640,11 +633,6 @@ (quotient y 400) -32045))) -(define (priv:split-real r) - (if (integer? r) (values r 0) - (let ((l (truncate r))) - (values l (- r l))))) - ;; gives the seconds/date/month/year (define (priv:decode-julian-day-number jdn) (let* ((days (inexact->exact (truncate jdn))) @@ -665,9 +653,9 @@ ;; differently from MzScheme's.... ;; This should be written to be OS specific. -(define (priv:local-tz-offset) +(define (priv:local-tz-offset utc-time) ;; SRFI uses seconds West, but guile (and libc) use seconds East. - (- (tm:gmtoff (localtime 0)))) + (- (tm:gmtoff (localtime (time-second utc-time))))) ;; special thing -- ignores nanos (define (priv:time->julian-day-number seconds tz-offset) @@ -681,7 +669,9 @@ (define (time-utc->date time . tz-offset) (if (not (eq? (time-type time) time-utc)) (priv:time-error 'time->date 'incompatible-time-types time)) - (let* ((offset (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset))) + (let* ((offset (if (null? tz-offset) + (priv:local-tz-offset time) + (car tz-offset))) (leap-second? (priv:leap-second? (+ offset (time-second time)))) (jdn (priv:time->julian-day-number (if leap-second? (- (time-second time) 1) @@ -690,7 +680,9 @@ (call-with-values (lambda () (priv:decode-julian-day-number jdn)) (lambda (secs date month year) - (let* ((int-secs (inexact->exact (floor secs))) + ;; secs is a real because jdn is a real in Guile; + ;; but it is conceptionally an integer. + (let* ((int-secs (inexact->exact (round secs))) (hours (quotient int-secs (* 60 60))) (rem (remainder int-secs (* 60 60))) (minutes (quotient rem 60)) @@ -707,7 +699,9 @@ (define (time-tai->date time . tz-offset) (if (not (eq? (time-type time) time-tai)) (priv:time-error 'time->date 'incompatible-time-types time)) - (let* ((offset (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset))) + (let* ((offset (if (null? tz-offset) + (priv:local-tz-offset (time-tai->time-utc time)) + (car tz-offset))) (seconds (- (time-second time) (priv:leap-second-delta (time-second time)))) (leap-second? (priv:leap-second? (+ offset seconds))) @@ -717,9 +711,12 @@ offset))) (call-with-values (lambda () (priv:decode-julian-day-number jdn)) (lambda (secs date month year) + ;; secs is a real because jdn is a real in Guile; + ;; but it is conceptionally an integer. ;; adjust for leap seconds if necessary ... - (let* ((hours (quotient secs (* 60 60))) - (rem (remainder secs (* 60 60))) + (let* ((int-secs (inexact->exact (round secs))) + (hours (quotient int-secs (* 60 60))) + (rem (remainder int-secs (* 60 60))) (minutes (quotient rem 60)) (seconds (remainder rem 60))) (make-date (time-nanosecond time) @@ -735,7 +732,9 @@ (define (time-monotonic->date time . tz-offset) (if (not (eq? (time-type time) time-monotonic)) (priv:time-error 'time->date 'incompatible-time-types time)) - (let* ((offset (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset))) + (let* ((offset (if (null? tz-offset) + (priv:local-tz-offset (time-monotonic->time-utc time)) + (car tz-offset))) (seconds (- (time-second time) (priv:leap-second-delta (time-second time)))) (leap-second? (priv:leap-second? (+ offset seconds))) @@ -745,9 +744,12 @@ offset))) (call-with-values (lambda () (priv:decode-julian-day-number jdn)) (lambda (secs date month year) + ;; secs is a real because jdn is a real in Guile; + ;; but it is conceptionally an integer. ;; adjust for leap seconds if necessary ... - (let* ((hours (quotient secs (* 60 60))) - (rem (remainder secs (* 60 60))) + (let* ((int-secs (inexact->exact (round secs))) + (hours (quotient int-secs (* 60 60))) + (rem (remainder int-secs (* 60 60))) (minutes (quotient rem 60)) (seconds (remainder rem 60))) (make-date (time-nanosecond time) @@ -760,17 +762,20 @@ offset)))))) (define (date->time-utc date) - (let ((jdays (- (priv:encode-julian-day-number (date-day date) + (let* ((jdays (- (priv:encode-julian-day-number (date-day date) (date-month date) (date-year date)) - priv:tai-epoch-in-jd))) + priv:tai-epoch-in-jd)) + ;; jdays is an integer plus 1/2, + (jdays-1/2 (inexact->exact (- jdays 1/2)))) (make-time time-utc (date-nanosecond date) - (+ (* (- jdays 1/2) 24 60 60) + (+ (* jdays-1/2 24 60 60) (* (date-hour date) 60 60) (* (date-minute date) 60) - (date-second date))))) + (date-second date) + (- (date-zone-offset date)))))) (define (date->time-tai date) (time-utc->time-tai! (date->time-utc date))) @@ -832,9 +837,12 @@ 7)) (define (current-date . tz-offset) - (time-utc->date - (current-time time-utc) - (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset)))) + (let ((time (current-time time-utc))) + (time-utc->date + time + (if (null? tz-offset) + (priv:local-tz-offset time) + (car tz-offset))))) ;; given a 'two digit' number, find the year within 50 years +/- (define (priv:natural-year n) @@ -907,10 +915,10 @@ (define (julian-day->time-utc jdn) (let ((secs (* priv:sid (- jdn priv:tai-epoch-in-jd)))) (receive (seconds parts) - (priv:split-real secs) - (make-time time-utc - (inexact->exact (truncate (* parts priv:nano))) - (inexact->exact seconds))))) + (priv:split-real secs) + (make-time time-utc + (* parts priv:nano) + seconds)))) (define (julian-day->time-tai jdn) (time-utc->time-tai! (julian-day->time-utc jdn))) @@ -919,12 +927,15 @@ (time-utc->time-monotonic! (julian-day->time-utc jdn))) (define (julian-day->date jdn . tz-offset) - (let ((offset (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset)))) - (time-utc->date (julian-day->time-utc jdn) offset))) + (let* ((time (julian-day->time-utc jdn)) + (offset (if (null? tz-offset) + (priv:local-tz-offset time) + (car tz-offset)))) + (time-utc->date time offset))) (define (modified-julian-day->date jdn . tz-offset) - (let ((offset (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset)))) - (julian-day->date (+ jdn 4800001/2) offset))) + (apply julian-day->date (+ jdn 4800001/2) + tz-offset)) (define (modified-julian-day->time-utc jdn) (julian-day->time-utc (+ jdn 4800001/2))) @@ -991,13 +1002,10 @@ (priv:vector-find string priv:locale-long-month-vector string=?)) - -;; do nothing. -;; Your implementation might want to do something... -;; -;; FIXME: is it even possible to do anything reasonable here? +;; FIXME: mkoeppe: Put a symbolic time zone in the date structs. +;; Print it here instead of the numerical offset if available. (define (priv:locale-print-time-zone date port) - (values)) + (priv:tz-printer (date-zone-offset date) port)) ;; FIXME: we should use strftime to determine this dynamically if possible. ;; Again, locale specific. @@ -1015,8 +1023,6 @@ (display (priv:padding hours #\0 2) port) (display (priv:padding minutes #\0 2) port)))) -;; STOPPED-HERE - ;; A table of output formatting directives. ;; the first time is the format char. ;; the second is a procedure that takes the date, a padding character @@ -1277,8 +1283,7 @@ (not (char-numeric? ch)) (and upto (>= nchars upto))) accum - (loop port - (+ (* accum 10) (priv:char->int (read-char port))) + (loop (+ (* accum 10) (priv:char->int (read-char port))) (+ nchars 1)))))) (define (priv:make-integer-reader upto) @@ -1417,41 +1422,41 @@ (list #\A char-alphabetic? locale-reader-long-weekday do-nothing) (list #\b char-alphabetic? locale-reader-abbr-month (lambda (val object) - (priv:set-date-month! object val))) + (set-date-month! object val))) (list #\B char-alphabetic? locale-reader-long-month (lambda (val object) - (priv:set-date-month! object val))) + (set-date-month! object val))) (list #\d char-numeric? ireader2 (lambda (val object) - (priv:set-date-day! + (set-date-day! object val))) (list #\e char-fail eireader2 (lambda (val object) - (priv:set-date-day! object val))) + (set-date-day! object val))) (list #\h char-alphabetic? locale-reader-abbr-month (lambda (val object) - (priv:set-date-month! object val))) + (set-date-month! object val))) (list #\H char-numeric? ireader2 (lambda (val object) - (priv:set-date-hour! object val))) + (set-date-hour! object val))) (list #\k char-fail eireader2 (lambda (val object) - (priv:set-date-hour! object val))) + (set-date-hour! object val))) (list #\m char-numeric? ireader2 (lambda (val object) - (priv:set-date-month! object val))) + (set-date-month! object val))) (list #\M char-numeric? ireader2 (lambda (val object) - (priv:set-date-minute! + (set-date-minute! object val))) (list #\S char-numeric? ireader2 (lambda (val object) - (priv:set-date-second! object val))) + (set-date-second! object val))) (list #\y char-fail eireader2 (lambda (val object) - (priv:set-date-year! object (priv:natural-year val)))) + (set-date-year! object (priv:natural-year val)))) (list #\Y char-numeric? ireader4 (lambda (val object) - (priv:set-date-year! object val))) + (set-date-year! object val))) (list #\z (lambda (c) (or (char=? c #\Z) (char=? c #\z) (char=? c #\+) (char=? c #\-))) priv:zone-reader (lambda (val object) - (priv:set-date-zone-offset! object val)))))) + (set-date-zone-offset! object val)))))) (define (priv:string->date date index format-string str-len port template-string) (define (skip-until port skipper) @@ -1513,13 +1518,24 @@ (date-month date) (date-year date) (date-zone-offset date))) - (let ((newdate (make-date 0 0 0 0 #f #f #f (priv:local-tz-offset)))) + (let ((newdate (make-date 0 0 0 0 #f #f #f #f))) (priv:string->date newdate 0 template-string (string-length template-string) (open-input-string input-string) template-string) + (if (not (date-zone-offset newdate)) + (begin + ;; this is necessary to get DST right -- as far as we can + ;; get it right (think of the double/missing hour in the + ;; night when we are switching between normal time and DST). + (set-date-zone-offset! newdate + (priv:local-tz-offset + (make-time time-utc 0 0))) + (set-date-zone-offset! newdate + (priv:local-tz-offset + (date->time-utc newdate))))) (if (priv:date-ok? newdate) newdate (priv:time-error From d0e06238b4b247cde92814e81680079ac66f2b49 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 18 Jun 2001 18:31:14 +0000 Subject: [PATCH 1338/2047] *** empty log message *** --- srfi/ChangeLog | 39 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 39 insertions(+) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 09b08c67d..1e6f68339 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,42 @@ +2001-06-18 Matthias Koeppe + + The SRFI-19 implementation was completely broken. Already the + reference implementation did not handle DST and time zones + properly and relied on non-R5RS-isms like passing reals to + `quotient'. For Guile, some additional fixes were needed because + of the incomplete numeric tower implementation. See also + srfi-19.test. + + * srfi-19.scm (date-zone-offset): Fixed typo in export clause. + (add-duration): Renamed from priv:add-duration. + (priv:time-normalize!): Handle fractional nanoseconds; remove + duplicate definition. + (priv:current-time-tai): Fixed typo. + (time=?, time<=?): Fixed typos. + (time-tai->time-utc, time-utc->time-tai, + time-utc->time-monotonic): Use make-time-unnormalized instead of + make-time when uninitialized time fields are used. + (set-date-nanosecond!, set-date-second!, set-date-minute!, + set-date-hour!, set-date-day!, set-date-month!, set-date-year!, + set-date-zone-offset!): Define. + (priv:local-tz-offset): Take an extra argument in order to handle + DST effects. + (time-utc->date, time-tai->date, time-monotonic->date): Handle the + changed signature of priv:local-tz-offset. Don't pass non-integer + arguments to quotient (non-R5RS, not supported by Guile). + (date->time-utc): Ensure that seconds in a date structure are + always exact integers. Handle DST properly. + (current-date, julian-day->date, modified-julian-day->date): + Handle the changed signature of priv:local-tz-offset. + (julian-day->time-utc): Reverted earlier inexact->exact hack; + make-time now handles inexact arguments. + (priv:locale-print-time-zone): At least print the numerical time + zone. + (priv:integer-reader): Fixed named let iteration. + (priv:read-directives): Use set-date-month! instead of + priv:set-date-month! etc. + (string->date): Handle DST properly. + 2001-06-14 Marius Vollmer * srfi-13.scm: Prevent `export' from re-exporting core bindings. From 39e30745c8e856b44767755d866ad90b42cf5980 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 18 Jun 2001 19:08:31 +0000 Subject: [PATCH 1339/2047] 2001-06-18 Martin Grabmueller * srfi-modules.texi (SRFI-1): Completed procedure documentation. * scheme-data.texi (List Constructors): Added make-list. Added type index entries for all data types. 2001-06-15 Martin Grabmueller * srfi-modules.texi (SRFI-1): New section documenting the SRFI-1 module. --- doc/ChangeLog | 17 ++ doc/scheme-data.texi | 38 ++- doc/scheme-modules.texi | 4 + doc/srfi-modules.texi | 644 ++++++++++++++++++++++++++++++++++++++++ 4 files changed, 701 insertions(+), 2 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 900deff30..553aab4f5 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,20 @@ +2001-06-18 Martin Grabmueller + + * srfi-modules.texi (SRFI-1): Completed procedure documentation. + + * scheme-data.texi (List Constructors): Added make-list. + Added type index entries for all data types. + +2001-06-15 Martin Grabmueller + + * srfi-modules.texi (SRFI-1): New section documenting the SRFI-1 + module. + +2001-06-14 Martin Grabmueller + + * scheme-modules.texi (Included Guile Modules): Added reference to + (srfi srfi-1) module. + 2001-06-16 Marius Vollmer * posix.texi (Conventions): Use `system-error-errno' instead of diff --git a/doc/scheme-data.texi b/doc/scheme-data.texi index df9517443..46bfb282b 100755 --- a/doc/scheme-data.texi +++ b/doc/scheme-data.texi @@ -63,6 +63,7 @@ sections of this manual that cover them. @node Booleans @section Booleans +@tpindex Booleans The two boolean values are @code{#t} for true and @code{#f} for false. @@ -137,6 +138,7 @@ Return @code{#t} iff @var{obj} is either @code{#t} or @code{#f}. @node Numbers @section Numerical data types +@tpindex Numbers Guile supports a rich ``tower'' of numerical types --- integer, rational, real and complex --- and provides an extensive set of @@ -227,9 +229,11 @@ For example: The next few subsections document each of Guile's numerical data types in detail. - @node Integers @subsection Integers + +@tpindex Integer numbers + @rnindex integer? Integers are whole numbers, that is numbers with no fractional part, @@ -288,6 +292,9 @@ Return @code{#t} if @var{x} is an integer number, @code{#f} else. @node Reals and Rationals @subsection Real and Rational Numbers +@tpindex Real numbers +@tpindex Rational numbers + @rnindex real? @rnindex rational? @@ -350,6 +357,8 @@ precision. @node Complex Numbers @subsection Complex Numbers +@tpindex Complex numbers + @rnindex complex? Complex numbers are the set of numbers that describe all possible points @@ -386,6 +395,9 @@ rational or integer number. @node Exactness @subsection Exact and Inexact Numbers +@tpindex Exact numbers +@tpindex Inexact numbers + @rnindex exact? @rnindex inexact? @rnindex exact->inexact @@ -1150,7 +1162,7 @@ Return a new random state using @var{seed}. @node Characters @section Characters - +@tpindex Characters Most of the characters in the ASCII character set may be referred to by name: for example, @code{#\tab}, @code{#\esc}, @code{#\stx}, and so on. @@ -1338,6 +1350,7 @@ Return the lowercase character version of @var{chr}. @node Strings @section Strings +@tpindex Strings Strings are fixed-length sequences of characters. They can be created by calling constructor procedures, but they can also literally get @@ -1798,6 +1811,7 @@ is currently reading symbols case-insensitively. @node Regular Expressions @section Regular Expressions +@tpindex Regular expressions @cindex regular expressions @cindex regex @@ -2285,6 +2299,7 @@ be used for interacting with the module system. @node Symbols @subsection Symbols +@tpindex Symbols @c FIXME::martin: Review me! @@ -2505,6 +2520,7 @@ otherwise. @node Variables @subsection Variables +@tpindex Variables @c FIXME::martin: Review me! @@ -2567,6 +2583,7 @@ return @code{#f} @node Keywords @section Keywords +@tpindex Keywords Keywords are self-evaluating objects with a convenient read syntax that makes them easy to type. @@ -2795,6 +2812,7 @@ This is the inverse of @code{make-keyword-from-dash-symbol}. @node Pairs @section Pairs +@tpindex Pairs @c FIXME::martin: Review me! @@ -2896,6 +2914,7 @@ by @code{set-cdr!} is unspecified. @node Lists @section Lists +@tpindex Lists @c FIXME::martin: Review me! @@ -3021,6 +3040,12 @@ Schemes and in Common LISP. Return a (newly-created) copy of @var{lst}. @end deffn +@deffn procedure make-list n [init] +Create a list containing of @var{n} elements, where each element is +initialized to @var{init}. @var{init} defaults to the empty list +@code{()} if not given. +@end deffn + Note that @code{list-copy} only makes a copy of the pairs which make up the spine of the lists. The list elements are not copied, which means that modifying the elements of the new list also modyfies the elements @@ -3295,6 +3320,7 @@ return value is not specified. @node Vectors @section Vectors +@tpindex Vectors @c FIXME::martin: Review me! @@ -3527,6 +3553,7 @@ created the type represented by @var{rtd}.@refill @node Structures @section Structures +@tpindex Structures [FIXME: this is pasted in from Tom Lord's original guile.texi and should be reviewed] @@ -3846,6 +3873,7 @@ Return the vtable tag of the structure @var{handle}. @node Arrays @section Arrays +@tpindex Arrays @menu * Conventional Arrays:: Arrays with arbitrary data. @@ -4106,6 +4134,7 @@ Another example: @node Uniform Arrays @subsection Uniform Arrays +@tpindex Uniform Arrays @noindent @dfn{Uniform arrays} have elements all of the @@ -4344,6 +4373,9 @@ of tools for using either association lists or hash tables. @node Association Lists @subsection Association Lists +@tpindex Association Lists +@tpindex Alist + @cindex Association List @cindex Alist @cindex Database @@ -4750,6 +4782,7 @@ capitals @node Hash Tables @subsection Hash Tables +@tpindex Hash Tables Like the association list functions, the hash table functions come in several varieties: @code{hashq}, @code{hashv}, and @code{hash}. @@ -4956,6 +4989,7 @@ table into an a-list of key-value pairs. @node Hooks @section Hooks +@tpindex Hooks @c FIXME::martin: Review me! diff --git a/doc/scheme-modules.texi b/doc/scheme-modules.texi index 293ab0517..fd130847b 100644 --- a/doc/scheme-modules.texi +++ b/doc/scheme-modules.texi @@ -399,6 +399,10 @@ Line- and character-delimited input (@pxref{Line/Delimited}). @item (ice-9 documentation) Online documentation (REFFIXME). +@item (srfi srfi-1) +A library providing a lot of useful list and pair processing +procedures (@pxref{SRFI-1}). + @item (srfi srfi-2) Support for @code{and-let*} (@pxref{SRFI-2}). diff --git a/doc/srfi-modules.texi b/doc/srfi-modules.texi index d6ea9bfa5..41c95ea97 100644 --- a/doc/srfi-modules.texi +++ b/doc/srfi-modules.texi @@ -15,6 +15,7 @@ get the relevant SRFI documents from the SRFI home page @menu * About SRFI Usage:: What to know about Guile's SRFI support. * SRFI-0:: cond-expand +* SRFI-1:: List library. * SRFI-2:: and-let*. * SRFI-6:: Basic String Ports. * SRFI-8:: receive. @@ -159,6 +160,649 @@ the following snippet will expand to @code{'hooray}. @end lisp +@node SRFI-1 +@section SRFI-1 - List library + +@c FIXME::martin: Review me! + +The list library defined in SRFI-1 contains a lot of useful list +processing procedures for construction, examining, destructuring and +manipulating lists and pairs. + +Since SRFI-1 also defines some procedures which are already contained +in R5RS and thus are supported by the Guile core library, some list +and pair procedures which appear in the SRFI-1 document may not appear +in this section. So when looking for a particular list/pair +processing procedure, you should also have a look at the sections +@ref{Lists} and @ref{Pairs}. + +@menu +* SRFI-1 Constructors:: Constructing new lists. +* SRFI-1 Predicates:: Testing list for specific properties. +* SRFI-1 Selectors:: Selecting elements from lists. +* SRFI-1 Length Append etc:: Length calculation and list appending. +* SRFI-1 Fold and Map:: Higher-order list processing. +* SRFI-1 Filtering and Partitioning:: Filter lists based on predicates. +* SRFI-1 Searching:: Search for elments. +* SRFI-1 Deleting:: Delete elements from lists. +* SRFI-1 Association Lists:: Handle association lists. +* SRFI-1 Set Operations:: Use lists for representing sets. +@end menu + +@node SRFI-1 Constructors +@subsection Constructors + +@c FIXME::martin: Review me! + +New lists can be constructed by calling one of the following +procedures. + +@deffn procedure xcons d a +Like @code{cons}, but with interchanged arguments. Useful mostly when +passed to higher-order procedures. +@end deffn + +@deffn procedure list-tabulate n init-proc +Return an @var{n}-element list, where each list element is produced by +applying the procedure @var{init-proc} to the corresponding list +index. The order in which @var{init-proc} is applied to the indices +is not specified. +@end deffn + +@deffn procedure circular-list elt1 elt2 @dots{} +Return a circular list containing the given arguments @var{elt1} +@var{elt2} @dots{}. +@end deffn + +@deffn procedure iota count [start step] +Return a list containing @var{count} elements, where each element is +calculated as follows: + +@var{start} + (@var{count} - 1) * @var{step} + +@var{start} defaults to 0 and @var{step} defaults to 1. +@end deffn + + +@node SRFI-1 Predicates +@subsection Predicates + +@c FIXME::martin: Review me! + +The procedures in this section test specific properties of lists. + +@deffn procedure proper-list? obj +Return @code{#t} if @var{obj} is a proper list, that is a finite list, +terminated with the empty list. Otherwise, return @code{#f}. +@end deffn + +@deffn procedure circular-list? obj +Return @code{#t} if @var{obj} is a circular list, otherwise return +@code{#f}. +@end deffn + +@deffn procedure dotted-list? obj +Return @code{#t} if @var{obj} is a dotted list, return @code{#f} +otherwise. A dotted list is a finite list which is not terminated by +the empty list, but some other value. +@end deffn + +@deffn procedure null-list? lst +Return @code{#t} if @var{lst} is the empty list @code{()}, @code{#f} +otherwise. If something else than a proper or circular list is passed +as @var{lst}, an error is signalled. This procedure is recommented +for checking for the end of a list in contexts where dotted lists are +not allowed. +@end deffn + +@deffn procedure not-pair? obj +Return @code{#t} is @var{obj} is not a pair, @code{#f} otherwise. +This is shorthand notation @code{(not (pair? @var{obj}))} and is +supposed to be used for end-of-list checking in contexts where dotted +lists are allowed. +@end deffn + +@deffn procedure list= elt= list1 @dots{} +Return @code{#t} if all argument lists are equal, @code{#f} otherwise. +List equality is determined by testing whether all lists have the same +length and the corresponding elements are equal in the sense of the +equality predicate @var{elt=}. If no or only one list is given, +@code{#t} is returned. +@end deffn + + +@node SRFI-1 Selectors +@subsection Selectors + +@c FIXME::martin: Review me! + +@deffn procedure first pair +@deffnx procedure second pair +@deffnx procedure third pair +@deffnx procedure fourth pair +@deffnx procedure fifth pair +@deffnx procedure sixth pair +@deffnx procedure seventh pair +@deffnx procedure eighth pair +@deffnx procedure ninth pair +@deffnx procedure tenth pair +These are synonyms for @code{car}, @code{cadr}, @code{caddr}, @dots{}. +@end deffn + +@deffn procedure car+cdr pair +Return two values, the @sc{car} and the @sc{cdr} of @var{pair}. +@end deffn + +@deffn procedure take lst i +@deffnx procedure take! lst i +Return a list containing the first @var{i} elements of @var{lst}. + +@code{take!} may modify the structure of the argument list @var{lst} +in order to produce the result. +@end deffn + +@deffn procedure drop lst i +Return a list containing all but the first @var{i} elements of +@var{lst}. +@end deffn + +@deffn procedure take-right lst i +Return the a list containing the @var{i} last elements of @var{lst}. +@end deffn + +@deffn procedure drop-right lst i +@deffnx procedure drop-right! lst i +Return the a list containing all but the @var{i} last elements of +@var{lst}. + +@code{drop-right!} may modify the structure of the argument list +@var{lst} in order to produce the result. +@end deffn + +@deffn procedure split-at lst i +@deffnx procedure split-at! lst i +Return two values, a list containing the first @var{i} elements of the +list @var{lst} and a list containing the remaining elements. + +@code{split-at!} may modify the structure of the argument list +@var{lst} in order to produce the result. +@end deffn + +@deffn procedure last lst +Return the last element of the non-empty, finite list @var{lst}. +@end deffn + + +@node SRFI-1 Length Append etc +@subsection Length, Append, Concatenate, etc. + +@c FIXME::martin: Review me! + +@deffn procedure length+ lst +Return the length of the argument list @var{lst}. When @var{lst} is a +circular list, @code{#f} is returned. +@end deffn + +@deffn procedure concatenate list-of-lists +@deffnx procedure concatenate! list-of-lists +Construct a list by appending all lists in @var{list-of-lists}. + +@code{concatenate!} may modify the structure of the given lists in +order to produce the result. +@end deffn + +@deffn procedure append-reverse rev-head tail +@deffnx procedure append-reverse! rev-head tail +Reverse @var{rev-head}, append @var{tail} and return the result. This +is equivalent to @code{(append (reverse @var{rev-head}) @var{tail})}, +but more efficient. + +@code{append-reverse!} may modify @var{rev-head} in order to produce +the result. +@end deffn + +@deffn procedure zip lst1 lst2 @dots{} +Return a list as long as the shortest of the argument lists, where +each element is a list. The first list contains the first elements of +the argument lists, the second list contains the second elements, and +so on. +@end deffn + +@deffn procedure unzip1 lst +@deffnx procedure unzip2 lst +@deffnx procedure unzip3 lst +@deffnx procedure unzip4 lst +@deffnx procedure unzip5 lst +@code{unzip1} takes a list of lists, and returns a list containing the +first elements of each list, @code{unzip2} returns two lists, the +first containing the first elements of each lists and the second +containing the second elements of each lists, and so on. +@end deffn + + +@node SRFI-1 Fold and Map +@subsection Fold, Unfold & Map + +@c FIXME::martin: Review me! + +@deffn procedure fold kons knil lst1 lst2 @dots{} +Fold the procedure @var{kons} across all elements of @var{lst1}, +@var{lst2}, @dots{}. Produce the result of + +@code{(@var{kons} @var{en1} @var{en2} @dots{} (@var{kons} @var{e21} +@var{e22} (@var{kons} @var{e11} @var{e12} @var{knil})))}, + +if @var{enm} are the elements of the lists @var{lst1}, @var{lst2}, +@dots{}. +@end deffn + +@deffn procedure fold-right kons knil lst1 lst2 @dots{} +Similar to @code{fold}, but applies @var{kons} in right-to-left order +to the list elements, that is: + +@code{(@var{kons} @var{e11} @var{e12}(@var{kons} @var{e21} +@var{e22} @dots{} (@var{kons} @var{en1} @var{en2} @var{knil})))}, +@end deffn + +@deffn procedure pair-fold kons knil lst1 lst2 @dots{} +Like @code{fold}, but apply @var{kons} to the pairs of the list +instead of the list elements. +@end deffn + +@deffn procedure pair-fold-right kons knil lst1 lst2 @dots{} +Like @code{fold-right}, but apply @var{kons} to the pairs of the list +instead of the list elements. +@end deffn + +@deffn procedure reduce f ridentity lst +@code{reduce} is a variant of @code{reduce}. If @var{lst} is +@code{()}, @var{ridentity} is returned. Otherwise, @code{(fold (car +@var{lst}) (cdr @var{lst}))} is returned. +@end deffn + +@deffn procedure reduce-right f ridentity lst +This is the @code{fold-right} variant of @var{reduce}. +@end deffn + +@deffn procedure unfold p f g seed [tail-gen] +@code{unfold} is defined as follows: + +@lisp +(unfold p f g seed) = + (if (p seed) (tail-gen seed) + (cons (f seed) + (unfold p f g (g seed)))) +@end lisp + +@table @var +@item p +Determines when to stop unfolding. + +@item f +Maps each seed value to the corresponding list element. + +@item g +Maps each seed value to next seed valu. + +@item seed +The state value for the unfold. + +@item tail-gen +Creates the tail of the list; defaults to @code{(lambda (x) '())}. +@end table + +@var{g} produces a series of seed values, which are mapped to list +elements by @var{f}. These elements are put into a list in +left-to-right order, and @var{p} tells when to stop unfolding. +@end deffn + +@deffn procedure unfold-right p f g seed [tail] +Construct a list with the following loop. + +@lisp +(let lp ((seed seed) (lis tail)) + (if (p seed) lis + (lp (g seed) + (cons (f seed) lis)))) +@end lisp + +@table @var +@item p +Determines when to stop unfolding. + +@item f +Maps each seed value to the corresponding list element. + +@item g +Maps each seed value to next seed valu. + +@item seed +The state value for the unfold. + +@item tail-gen +Creates the tail of the list; defaults to @code{(lambda (x) '())}. +@end table + +@end deffn + +@deffn procedure append-map f lst1 lst2 @dots{} +@deffnx procedure append-map! f lst1 lst2 @dots{} +Equivalent to + +@lisp +(apply append (map f clist1 clist2 ...)) +@end lisp + +and + +@lisp +(apply append! (map f clist1 clist2 ...)) +@end lisp + +Map @var{f} over the elements of the lists, just as in the @code{map} +function. However, the results of the applications are appended +together to make the final result. @code{append-map} uses +@code{append} to append the results together; @code{append-map!} uses +@code{append!}. + +The dynamic order in which the various applications of @var{f} are +made is not specified. +@end deffn + +@deffn procedure map! f lst1 lst2 @dots{} +Linear-update variant of @code{map} -- @code{map!} is allowed, but not +required, to alter the cons cells of @var{lst1} to construct the +result list. + +The dynamic order in which the various applications of @var{f} are +made is not specified. In the n-ary case, @var{lst2}, @var{lst3}, +@dots{} must have at least as many elements as @var{lst1}. +@end deffn + +@deffn procedure pair-for-each f lst1 lst2 @dots{} +Like @code{for-each}, but applies the procedure @var{f} to the pairs +from which the argument lists are constructed, instead of the list +elements. The return value is not specified. +@end deffn + +@deffn procedure filter-map f lst1 lst2 @dots{} +Like @code{map}, but only results from the applications of @var{f} +which are true are saved in the result list. +@end deffn + + +@node SRFI-1 Filtering and Partitioning +@subsection Filtering and Partitioning + +@c FIXME::martin: Review me! + +Filtering means to collect all elements from a list which satisfy a +specific condition. Partitioning a list means to make two groups of +list elements, one which contains the elements satisfying a condition, +and the other for the elements which don't. + +@deffn procedure filter pred lst +@deffnx procedure filter! pred lst +Return a list containing all elements from @var{lst} which satisfy the +predicate @var{pred}. The elements in the result list have the same +order as in @var{lst}. The order in which @var{pred} is applied to +the list elements is not specified. + +@code{filter!} is allowed, but not required to modify the structure of +@end deffn + +@deffn procedure partition pred lst +@deffnx procedure partition! pred lst +Return two lists, one containing all elements from @var{lst} which +satisfy the predicate @var{pred}, and one list containing the elements +which do not satisfy the predicated. The elements in the result lists +have the same order as in @var{lst}. The order in which @var{pred} is +applied to the list elements is not specified. + +@code{partition!} is allowed, but not required to modify the structure of +the input list. +@end deffn + +@deffn procedure remove pred lst +@deffnx procedure remove! pred lst +Return a list containing all elements from @var{lst} which do not +satisfy the predicate @var{pred}. The elements in the result list +have the same order as in @var{lst}. The order in which @var{pred} is +applied to the list elements is not specified. + +@code{remove!} is allowed, but not required to modify the structure of +the input list. +@end deffn + + +@node SRFI-1 Searching +@subsection Searching + +@c FIXME::martin: Review me! + +The procedures for searching elements in lists either accept a +predicate or a comparison object for determining which elements are to +be searched. + +@deffn procedure find pred lst +Return the first element of @var{lst} which satisfies the predicate +@var{pred} and @code{#f} if no such element is found. +@end deffn + +@deffn procedure find-tail pred lst +Return the first pair of @var{lst} whose @sc{car} satisfies the +predicate @var{pred} and @code{#f} if no such element is found. +@end deffn + +@deffn procedure take-while pred lst +@deffnx procedure take-while! pred lst +Return the longest initial prefix of @var{lst} whose elements all +satisfy the predicate @var{pred}. + +@code{take-while!} is allowed, but not required to modify the input +list while producing the result. +@end deffn + +@deffn procedure drop-while pred lst +Drop the longest initial prefix of @var{lst} whose elements all +satisfy the predicate @var{pred}. +@end deffn + +@deffn procedure span pred lst +@deffnx procedure span! pred lst +@deffnx procedure break pred lst +@deffnx procedure break! pred lst +@code{span} splits the list @var{lst} into the longest initial prefix +whose elements all satisfy the predicate @var{pred}, and the remaining +tail. @code{break} inverts the sense of the predicate. + +@code{span!} and @code{break!} are allowed, but not required to modify +the structure of the input list @var{lst} in order to produce the +result. +@end deffn + +@deffn procedure any pred lst1 lst2 @dots{} +Apply @var{pred} across the lists and return a true value if the +predicate returns true for any of the list elements(s); return +@code{#f} otherwise. The true value returned is always the result of +the first succesful application of @var{pred}. +@end deffn + +@deffn procedure every pred lst1 lst2 @dots{} +Apply @var{pred} across the lists and return a true value if the +predicate returns true for every of the list elements(s); return +@code{#f} otherwise. The true value returned is always the result of +the final succesful application of @var{pred}. +@end deffn + +@deffn procedure list-index pred lst1 lst2 @dots{} +Return the index of the leftmost element that satisfies @var{pred}. +@end deffn + +@deffn procedure member x lst [=] +Return the first sublist of @var{lst} whose @sc{car} is equal to +@var{x}. If @var{x} does no appear in @var{lst}, return @code{#f}. +Equality is determined by the equality predicate @var{=}, or +@code{equal?} if @var{=} is not given. +@end deffn + + +@node SRFI-1 Deleting +@subsection Deleting + +@c FIXME::martin: Review me! + +The procedures for deleting elements from a list either accept a +predicate or a comparison object for determining which elements are to +be removed. + +@deffn procedure delete x lst [=] +@deffnx procedure delete! x lst [=] +Return a list containing all elements from @var{lst}, but without the +elements equal to @var{x}. Equality is determined by the equality +predicate @var{=}, which defaults to @code{equal?} if not given. + +@code{delete!} is allowed, but not required to modify the structure of +the argument list in order to produce the result. +@end deffn + +@deffn procedure delete-duplicates lst [=] +@deffnx procedure delete-duplicates! lst [=] +Return a list containing all elements from @var{lst}, but without +duplicate elements. Equality of elements is determined by the +equality predicate @var{=}, which defaults to @code{equal?} if not +given. + +@code{delete-duplicates!} is allowed, but not required to modify the +structure of the argument list in order to produce the result. +@end deffn + + +@node SRFI-1 Association Lists +@subsection Association Lists + +@c FIXME::martin: Review me! + +Association lists are described in detail in section @ref{Association +Lists}. The present section only documents the additional procedures +for dealing with association lists defined by SRFI-1. + +@deffn procedure assoc key alist [=] +Return the pair from @var{alist} which matches @var{key}. Equality is +determined by @var{=}, which defaults to @code{equal?} if not given. +@var{alist} must be an association lists---a list of pairs. +@end deffn + +@deffn procedure alist-cons key datum alist +Equivalent to + +@lisp +(cons (cons @var{key} @var{datum}) @var{alist}) +@end lisp + +This procedure is used to coons a new pair onto an existing +association list. +@end deffn + +@deffn procedure alist-copy alist +Return a newly allocated copy of @var{alist}, that means that the +spine of the list as well as the pairs are copied. +@end deffn + +@deffn procedure alist-delete key alist [=] +@deffnx 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. + +@code{alist-delete!} is allowed, but not required to modify the +structure of the list @var{alist} in order to produce the result. +@end deffn + + +@node SRFI-1 Set Operations +@subsection Set Operations on Lists + +@c FIXME::martin: Review me! + +Lists can be used for representing sets of objects. The procedures +documented in this section can be used for such set representations. +Man combinding several sets or adding elements, they make sure that no +object is contained more than once in a given list. Please note that +lists are not a too efficient implementation method for sets, so if +you need high performance, you should think about implementing a +custom data structure for representing sets, such as trees, bitsets, +hash tables or something similar. + +All these procedures accept an equality predicate as the first +argument. This predicate is used for testing the objects in the list +sets for sameness. + +@deffn procedure lset<= = list1 @dots{} +Return @code{#t} if every @var{listi} is a subset of @var{listi+1}, +otherwise return @code{#f}. Returns @code{#t} if called with less +than two arguments. @var{=} is used for testing element equality. +@end deffn + +@deffn procedure lset= = list1 list2 @dots{} +Return @code{#t} if all argument lists are equal. @var{=} is used for +testing element equality. +@end deffn + +@deffn procedure lset-adjoin = list elt1 @dots{} +@deffnx procedure lset-adjoin! = list elt1 @dots{} +Add all @var{elts} to the list @var{list}, suppressing duplicates and +return the resulting list. @code{lset-adjoin!} is allowed, but not +required to modify its first argument. @var{=} is used for testing +element equality. +@end deffn + +@deffn procedure lset-union = list1 @dots{} +@deffnx procedure lset-union! = list1 @dots{} +Return the union of all argument list sets. The union is the set of +all elements which appear in any of the argument sets. +@code{lset-union!} is allowed, but not required to modify its first +argument. @var{=} is used for testing element equality. +@end deffn + +@deffn procedure lset-intersection = list1 list2 @dots{} +@deffnx procedure lset-intersection! = list1 list2 @dots{} +Return the intersection of all argument list sets. The intersection +is the set containing all elements which appear in all argument sets. +@code{lset-intersection!} is allowed, but not required to modify its +first argument. @var{=} is used for testing element equality. +@end deffn + +@deffn procedure lset-difference = list1 list2 @dots{} +@deffnx procedure lset-difference! = list1 list2 @dots{} +Return the difference of all argument list sets. The difference is +the the set containing all elements of the first list which do not +appear in the other lists. @code{lset-difference!} is allowed, but +not required to modify its first argument. @var{=} is used for testing +element equality. +@end deffn + +@deffn procedure lset-xor = list1 @dots{} +@deffnx procedure lset-xor! = list1 @dots{} +Return the set containing all elements which appear in the first +argument list set, but not in the second; or, more generally: which +appear in an odd number of sets. @code{lset-xor!} is allowed, but +not required to modify its first argument. @var{=} is used for testing +element equality. +@end deffn + +@deffn procedure lset-diff+intersection = list1 list2 @dots{} +@deffnx procedure lset-diff+intersection! = list1 list2 @dots{} +Return two values, the difference and the intersection of the argument +list sets. This works like a combination of @code{lset-difference} and +@code{lset-intersection}, but is more efficient. +@code{lset-diff+intersection!} is allowed, but not required to modify +its first argument. @var{=} is used for testing element equality. You +have to use some means to deal with the multiple values these +procedures return (@pxref{Multiple Values}). +@end deffn + + @node SRFI-2 @section SRFI-2 - and-let* From 22332e5dbea7ab23821f669f93da2609c61e778e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 18 Jun 2001 19:09:31 +0000 Subject: [PATCH 1340/2047] 2001-06-18 Martin Grabmueller * box-dynamic-module/README: Use a better example for box-map, as suggested by Thomas Wawrzinek. --- examples/ChangeLog | 5 +++++ examples/box-dynamic-module/README | 4 ++-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/examples/ChangeLog b/examples/ChangeLog index 5af8d9b05..678830aa8 100644 --- a/examples/ChangeLog +++ b/examples/ChangeLog @@ -1,3 +1,8 @@ +2001-06-18 Martin Grabmueller + + * box-dynamic-module/README: Use a better example for box-map, as + suggested by Thomas Wawrzinek. + 2001-06-14 Martin Grabmueller * scripts/README, scripts/hello.scm, safe/untrusted.scm, diff --git a/examples/box-dynamic-module/README b/examples/box-dynamic-module/README index 5097ec7d9..9f285c6ca 100644 --- a/examples/box-dynamic-module/README +++ b/examples/box-dynamic-module/README @@ -66,8 +66,8 @@ guile> (use-modules (box-mixed)) guile> (define bl (make-box-list 1 2 3)) guile> bl (# # #) -guile> (box-map (lambda (el) (make-box-list (list el))) bl) -(#)> #)> #)>) +guile> (box-map 1+ bl) +(# # #) guile> (quit) $ From e8bb04760c7031f94b70a580c208831100a8cdb3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 18 Jun 2001 19:11:21 +0000 Subject: [PATCH 1341/2047] Some updates. --- AUTHORS | 1 + NEWS | 3 +++ 2 files changed, 4 insertions(+) diff --git a/AUTHORS b/AUTHORS index 1b22ee443..f22547a33 100644 --- a/AUTHORS +++ b/AUTHORS @@ -138,6 +138,7 @@ In the subdirectory libguile, changes to: gh_data.c strports.h strports.c validate.h and changed many docstrings throughout. In the subdirectory srfi, wrote: + srfi-1.scm srfi-9.scm srfi-10.scm srfi-13.scm diff --git a/NEWS b/NEWS index 5513a267f..1ff870cde 100644 --- a/NEWS +++ b/NEWS @@ -40,6 +40,9 @@ See INSTALL and README for more information. SRFI-0 `cond-expand' is now supported in Guile, without requiring using a module. +(srfi srfi-1) is a library containing many useful pair- and list-processing + procedures. + (srfi srfi-2) exports and-let*. (srfi srfi-6) is a dummy module for now, since guile already provides From 6e9382f113b4e88038ce54df6d350144f5cdf2f9 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 19 Jun 2001 17:27:54 +0000 Subject: [PATCH 1342/2047] Added two "s". --- NEWS | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index 1ff870cde..56f595a40 100644 --- a/NEWS +++ b/NEWS @@ -221,7 +221,7 @@ guile> (string-pad "bla" 20) ** Guile now always starts up in the `(guile-user)' module. -Previously, script executed via the `-s' option would run in the +Previously, scripts executed via the `-s' option would run in the `(guile)' module and the repl would run in the `(guile-user)' module. Now every user action takes place in the `(guile-user)' module by default. @@ -664,7 +664,7 @@ The old names are still available with status `deprecated'. ** scm_t_bits (former scm_bits_t) is now a unsigned type. -** Deprecated feature have been removed. +** Deprecated features have been removed. *** Macros removed From 72c17ed0ee23257c99ab3a8a92ed1686f3c99e92 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Tue, 19 Jun 2001 22:56:29 +0000 Subject: [PATCH 1343/2047] * filter-doc-snarfage.c (process): added ungetc in MULTILINE_COOKIE case since otherwise it fails when there's no space between the '(' and the quote of the following string (gcc 3.0). --- libguile/ChangeLog | 7 + libguile/filter-doc-snarfage.c | 246 --------------------------------- 2 files changed, 7 insertions(+), 246 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 330e5b090..94f223656 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2001-06-19 Gary Houston + + * filter-doc-snarfage.c (process): added ungetc in + MULTILINE_COOKIE case since otherwise it fails when there's no + space between the '(' and the quote of the following string + (gcc 3.0). + 2001-06-14 Marius Vollmer Throughout: replace "scm_*_t" with "scm_t_*", except "scm_lisp_t". diff --git a/libguile/filter-doc-snarfage.c b/libguile/filter-doc-snarfage.c index 54ebc3c6e..e69de29bb 100644 --- a/libguile/filter-doc-snarfage.c +++ b/libguile/filter-doc-snarfage.c @@ -1,246 +0,0 @@ -#include -#include -#include - -static void init_state_machine (void); - -static void process (void); - -static void check_end_conditions (void); - -int -main (int argc, char *argv[]) -{ - init_state_machine (); - process (); - check_end_conditions (); - - return EXIT_SUCCESS; -} - -typedef enum state_t - { - SKIP, - SKIP_COOKIE, - - MULTILINE_BEGINNING_OF_LINE, - MULTILINE, - - MULTILINE_COOKIE, - STRINGS, - - SINGLELINE, - - } state_t; - -state_t state = SKIP; - -static void die (const char *msg); -static void process_strings (void); -static void process_single_line (void); - -void -process () -{ - int want_cookie = 0; - int ch; - - while ((ch = getc (stdin)) != EOF) { - char c = (char)ch; - - switch (state) { - case SKIP: - if (c == '^') { - if (want_cookie) { - state = SKIP_COOKIE; - want_cookie = 0; - } else - want_cookie = 1; - } else if (c != ' ') - want_cookie = 0; - break; - case SKIP_COOKIE: - switch (c) { - case '[': - fputs ("(doc-check\n", stdout); - state = SINGLELINE; - break; - case '{': - fputs ("(doc-block (\n", stdout); - state = MULTILINE; - break; - case ' ': - break; - default: - die ("bad snarf cookie"); - break; - } - break; - case MULTILINE_BEGINNING_OF_LINE: - if (c != ' ') { - state = MULTILINE; - putc (c, stdout); - } - break; - case MULTILINE: - if (c == '^') { - if (want_cookie) { - fputs ("\n)\n(\n", stdout); - state = MULTILINE_COOKIE; - want_cookie = 0; - } else - want_cookie = 1; - } else { - if (c != ' ') - want_cookie = 0; - putc (c, stdout); - } - break; - case MULTILINE_COOKIE: - switch (c) { - case '(': - state = STRINGS; - break; - case '%': - state = MULTILINE_BEGINNING_OF_LINE; - break; - case '}': - fputs ("))\n", stdout); - state = SKIP; - break; - case ' ': - break; - default: - die ("bad snarf cookie in multiline context"); - break; - } - break; - case STRINGS: - process_strings (); - state = MULTILINE; - break; - case SINGLELINE: - process_single_line (); - fputs ("\n)\n", stdout); - state = SKIP; - break; - default: - abort (); - break; - } - } -} - -void -init_state_machine () -{} - -void -die (const char *msg) -{ - fprintf (stderr, "%s\n", msg); - exit (EXIT_FAILURE); -} - -void -check_end_conditions () -{ - if (state != SKIP) - die ("something is unterminated"); -} - -typedef enum str_state_t - { - STR_SKIP, - STR_INSIDE, - STR_HAD_ESCAPE, - STR_EXIT - } str_state_t; - -void -process_strings () -{ - /* read well-formed strings up to a ')', and break them up in the - process if they are too long */ - int count = 0; - int ch; - str_state_t state = STR_SKIP; - - fputs ("docstring\n", stdout); - -#define PUTC(c) putc (c, stdout); if (++count >= 512) { fputs ("\"\nstring \"", stdout); count = 0; } - - while (!(((ch = getc (stdin)) == EOF) - || (state == STR_EXIT))) { - char c = (char) ch; - - switch (state) { - case STR_SKIP: - switch (c) { - case '"': - fputs ("\nstring ", stdout); - count = 0; - PUTC (c); - state = STR_INSIDE; - break; - case ')': - state = STR_EXIT; - break; - default: - if (!isspace (c)) - die ("stray stuff where should be only strings"); - break; - } - break; - case STR_INSIDE: - switch (c) { - case '\\': - putc (c, stdout); - ++count; - state = STR_HAD_ESCAPE; - break; - case '"': - putc (c, stdout); - state = STR_SKIP; - break; - default: - PUTC (c); - break; - } - break; - case STR_HAD_ESCAPE: - PUTC (c); - state = STR_INSIDE; - break; - default: - abort (); - break; - } - } - - if (state != STR_EXIT) - die ("docstrings don't terminate"); -} - -void -process_single_line () -{ - /* read up to a ']' */ - int ch; - while (!(((ch = getc (stdin)) == EOF) - || ((char) ch == ']'))) { - char c = (char) ch; - - putc (c, stdout); - } - - if ((char) ch != ']') - die ("bad checking snarfage"); -} - - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ From fbbdb1217429d014ba94744b90d7e9c392e89cac Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Wed, 20 Jun 2001 17:33:43 +0000 Subject: [PATCH 1344/2047] * deprecation.c, extensions.c, rw.c: include string.h. --- libguile/ChangeLog | 4 ++++ libguile/deprecation.c | 1 + libguile/extensions.c | 2 ++ libguile/rw.c | 1 + 4 files changed, 8 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 94f223656..311be7248 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2001-06-20 Gary Houston + + * deprecation.c, extensions.c, rw.c: include string.h. + 2001-06-19 Gary Houston * filter-doc-snarfage.c (process): added ungetc in diff --git a/libguile/deprecation.c b/libguile/deprecation.c index 1f6d1ffb0..6501d7fa3 100644 --- a/libguile/deprecation.c +++ b/libguile/deprecation.c @@ -42,6 +42,7 @@ #include +#include #include "libguile/_scm.h" diff --git a/libguile/extensions.c b/libguile/extensions.c index e5f19c806..b549f0fc7 100644 --- a/libguile/extensions.c +++ b/libguile/extensions.c @@ -41,6 +41,8 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ +#include + #include "libguile/_scm.h" #include "libguile/strings.h" #include "libguile/gc.h" diff --git a/libguile/rw.c b/libguile/rw.c index ec76881ef..4a19d8946 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -44,6 +44,7 @@ /* This is the C part of the (ice-9 rw) module. */ #include +#include #include "libguile/_scm.h" #include "libguile/fports.h" From 6b41a31399fc7106854cf355f54242aedcc3c59c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 20 Jun 2001 18:18:00 +0000 Subject: [PATCH 1345/2047] Removed tag.c and tag.h and all references. --- ChangeLog | 4 ++++ libguile.h | 1 - libguile/ChangeLog | 10 ++++++++++ libguile/Makefile.am | 8 ++++---- libguile/gdbint.c | 1 - libguile/init.c | 2 -- libguile/tag.c | 0 libguile/tag.h | 0 8 files changed, 18 insertions(+), 8 deletions(-) delete mode 100644 libguile/tag.c delete mode 100644 libguile/tag.h diff --git a/ChangeLog b/ChangeLog index e9404f91a..21806c622 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2001-06-20 Martin Grabmueller + + * libguile.h: Removed inclusion of libguile/tag.h. + 2001-06-16 Marius Vollmer * libguile.h (scm_cond_t, scm_key_t, scm_mutex_t): Only define diff --git a/libguile.h b/libguile.h index c5fc73387..cb7d3bfca 100644 --- a/libguile.h +++ b/libguile.h @@ -122,7 +122,6 @@ extern "C" { #include "libguile/strports.h" #include "libguile/struct.h" #include "libguile/symbols.h" -#include "libguile/tag.h" #include "libguile/tags.h" #include "libguile/throw.h" #include "libguile/unif.h" diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 311be7248..7e7a47703 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,13 @@ +2001-06-20 Martin Grabmueller + + * init.c (scm_init_guile_1): Removed initialization of tag.c. + + * gdbint.c, init.c: Removed inclusion of tag.h. + + * tag.h, tag.c: Removed files. + + * Makefile.am: Removed tag.{h,c,doc,x} in various places. + 2001-06-20 Gary Houston * deprecation.c, extensions.c, rw.c: include string.h. diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 5badd240a..e8d0ab4a5 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -51,7 +51,7 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ options.c pairs.c ports.c print.c procprop.c procs.c properties.c \ random.c rdelim.c read.c root.c rw.c scmsigs.c script.c simpos.c smob.c \ sort.c srcprop.c stackchk.c stacks.c stime.c strings.c strop.c \ - strorder.c strports.c struct.c symbols.c tag.c throw.c values.c \ + strorder.c strports.c struct.c symbols.c throw.c values.c \ variable.c vectors.c version.c vports.c weaks.c symbols-deprecated.c DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ @@ -65,7 +65,7 @@ DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ procprop.x procs.x properties.x random.x rdelim.x read.x root.x rw.x \ scmsigs.x script.x simpos.x smob.x sort.x srcprop.x \ stackchk.x stacks.x stime.x strings.x strop.x strorder.x strports.x \ - struct.x symbols.x tag.x throw.x values.x variable.x vectors.x \ + struct.x symbols.x throw.x values.x variable.x vectors.x \ version.x vports.x weaks.x symbols-deprecated.x EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@ @@ -82,7 +82,7 @@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \ procs.doc properties.doc random.doc rdelim.doc read.doc root.doc rw.doc \ scmsigs.doc script.doc simpos.doc smob.doc sort.doc \ srcprop.doc stackchk.doc stacks.doc stime.doc strings.doc strop.doc \ - strorder.doc strports.doc struct.doc symbols.doc tag.doc throw.doc \ + strorder.doc strports.doc struct.doc symbols.doc throw.doc \ values.doc variable.doc vectors.doc version.doc vports.doc weaks.doc \ symbols-deprecated.doc @@ -134,7 +134,7 @@ modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h boolean.h \ regex-posix.h print.h procprop.h procs.h properties.h random.h ramap.h \ rdelim.h read.h root.h rw.h scmsigs.h validate.h script.h simpos.h smob.h \ snarf.h socket.h sort.h srcprop.h stackchk.h stacks.h stime.h strings.h \ - strop.h strorder.h strports.h struct.h symbols.h tag.h tags.h threads.h \ + strop.h strorder.h strports.h struct.h symbols.h tags.h threads.h \ throw.h unif.h values.h variable.h vectors.h version.h vports.h weaks.h ## This file is generated at configure time. That is why it is DATA diff --git a/libguile/gdbint.c b/libguile/gdbint.c index 1f69ff2b2..afb649e0d 100644 --- a/libguile/gdbint.c +++ b/libguile/gdbint.c @@ -55,7 +55,6 @@ #include #endif -#include "libguile/tag.h" #include "libguile/strports.h" #include "libguile/read.h" #include "libguile/eval.h" diff --git a/libguile/init.c b/libguile/init.c index 97c8a67a1..9aefedcd5 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -132,7 +132,6 @@ #include "libguile/strports.h" #include "libguile/struct.h" #include "libguile/symbols.h" -#include "libguile/tag.h" #include "libguile/throw.h" #include "libguile/unif.h" #include "libguile/values.h" @@ -548,7 +547,6 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_init_struct (); /* Requires strings */ scm_init_stacks (); /* Requires strings, struct */ scm_init_symbols (); - scm_init_tag (); scm_init_values (); /* Requires struct */ scm_init_load (); /* Requires strings */ scm_init_objects (); /* Requires struct */ diff --git a/libguile/tag.c b/libguile/tag.c deleted file mode 100644 index e69de29bb..000000000 diff --git a/libguile/tag.h b/libguile/tag.h deleted file mode 100644 index e69de29bb..000000000 From a0143ebc24c24198e0dfce9b80f3648feb706226 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Wed, 20 Jun 2001 22:08:19 +0000 Subject: [PATCH 1346/2047] * Explain GH deprecation & plan for scm documentation. --- doc/ChangeLog | 8 +++++ doc/extend.texi | 33 +++++++++--------- doc/gh.texi | 90 ++++++++++++++++++++++++++++++++----------------- doc/guile.texi | 6 ++-- 4 files changed, 88 insertions(+), 49 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 553aab4f5..4482010b0 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,11 @@ +2001-06-20 Neil Jerram + + * guile.texi (Top): Move GH chapter to end of Part V. + + * extend.texi (Libguile Intro), gh.texi (GH deprecation): Explain + deprecation of GH and broad plan for documentation of scm + interface. + 2001-06-18 Martin Grabmueller * srfi-modules.texi (SRFI-1): Completed procedure documentation. diff --git a/doc/extend.texi b/doc/extend.texi index e9e7cdd0f..5cadde4e8 100644 --- a/doc/extend.texi +++ b/doc/extend.texi @@ -5,19 +5,22 @@ The chapters in this part of the manual explain how to use Guile as a powerful application extension language. -The following chapter, ``GH: A Portable C to Scheme Interface,'' shows -how to call Guile from your application's C code, and how to add new -Scheme level procedures to Guile whose behaviour is specified by -application specific code written in C. The Guile interface functions -documented in this chapter make up a high level, portable interface -which (we hope) will also someday work with other Scheme interpreters, -allowing you to write C code which will work with any of several Scheme -systems. +An important change for the 1.6.x series of Guile releases is that the +GH interface is now deprecated. For the reasoning behind this decision, +see @xref{GH deprecation}. The GH interface will continue to be +supported for the 1.6.x and 1.8.x release series, but will be dropped +thereafter, so developers are encouraged to switch progressively to the +scm interface. The last chapter in this part of the manual (@pxref{GH}) +documents both how to use GH and how to switch from GH to scm. -The portable interface is rich enough to support simple use of Guile as -an application extension language, but is limited by its own portability -where a deeper integration is desired between Guile and your -application's code. The subsequent chapters therefore present aspects -of libguile that allow you to use more of Guile's C level features, and -to extend your application in more complex ways than is possible with -the portable interface. +The documentation of the scm interface is currently a bit confused, but +the situation should improve rapidly once the 1.6.0 release is out. The +plan is to refocus the bulk of Part II, currently ``Guile Scheme'', as +the ``Guile API Reference'' so that it covers both Scheme and C +interfaces. (This makes sense because almost all of Guile's primitive +procedures on the Scheme level --- e.g. @code{memq} --- are also +available as C level primitives in the scm interface --- +e.g. @code{scm_memq}.) There will then remain a certain amount of +Scheme-specific (such as the ``Basic Ideas'' chapter) and C-specific +documentation (such as SMOB usage and interaction with the garbage +collector) to collect into corresponding chapters. diff --git a/doc/gh.texi b/doc/gh.texi index 668270cb8..999ea6331 100644 --- a/doc/gh.texi +++ b/doc/gh.texi @@ -5,40 +5,17 @@ @cindex gh @cindex gh - reference manual -The Guile interpreter is based on Aubrey Jaffer's @emph{SCM} interpreter -(@pxref{Overview, SCM: a portable Scheme interpreter, Overview, scm, -SCM: a portable Scheme interpreter}) with some modifications to make it -suitable as an embedded interpreter, and further modifications as Guile -evolves. -@cindex SCM interpreter -@cindex Jaffer, Aubrey - -Part of the modification has been to provide a restricted interface to -limit access to the SCM internals; this is called the @code{gh_} -interface, or @emph{libguile} interface. -@cindex gh_ interface -@cindex libguile interface - -If you are @emph{programming with Guile}, you should only use the C -subroutines described in this manual, which all begin with -@code{gh_}. - -If instead you are @emph{extending Guile}, you have the entire SCM -source to play with. This manual will not help you at all, but you can -consult Aubrey Jaffer's SCM manual (@pxref{Internals, SCM: a portable -Scheme interpreter, Internals, scm, SCM: a portable Scheme -interpreter}). -@cindex Guile - extending -@cindex extending Guile -@cindex SCM internals - -If you are @emph{adding a module to Guile}, I recommend that you stick -to the @code{gh_} interface: this interface is guaranteed to not -change drastically, while the SCM internals might change as Guile is -developed. +This chapter shows how to use the GH interface to call Guile from your +application's C code, and to add new Scheme level procedures to Guile +whose behaviour is specified by application specific code written in C. +Note, however, that the GH interface is now deprecated, and developers +are encouraged to switch to using the scm interface instead. Therefore, +for each GH feature, this chapter should also document how to achieve +the same result using the scm interface. @menu +* GH deprecation:: Why the GH interface is now deprecated. * gh preliminaries:: * Data types and constants defined by gh:: * Starting and controlling the interpreter:: @@ -54,6 +31,57 @@ developed. @end menu +@node GH deprecation +@section Why the GH Interface is Now Deprecated + +Historically, the GH interface was the product of a practical problem +and a neat idea. The practical problem was that the interface of the +@code{scm_} functions with which Guile itself was written (inherited +from Aubrey Jaffer's SCM) was so closely tied to the (rather arcane) +details of the internal data representation that it was extremely +difficult to write a Guile extension using these functions. The neat +idea was to define a high level language extension interface in such a +way that other extension language projects, not just Guile, would be +able to provide an implementation of that interface; then applications +using this interface could be compiled with whichever of the various +available implementations they chose. So the GH interface was created, +and advertised both as the recommended interface for application +developers wishing to use Guile, and as a portable high level interface +that could theoretically be implemented by other extension language +projects. + +Time passed, and various things changed. Crucially, an enormous number +of improvements were made to the @code{scm_} interface that Guile itself +uses in its implementation, with the result that it is now both easy and +comfortable to write a Guile extension with this interface. At the same +time, the contents of the GH interface were somewhat neglected by the +core Guile developers, such that some key operations --- such as smob +creation and management --- are simply not possible using GH alone. +Finally, the idea of multiple implementations of the GH interface did +not really crystallize (apart, I believe, from a short lived +implementation by the MzScheme project). + +Where portability is concerned, the @code{scm_} interface is now already +portable in the sense that other projects could provide an alternative +implementation of the @code{scm_} header file. For the majority of +@code{scm_} functions, all that is needed is a definition of the +@code{SCM} type, and then those functions are automatically portable by +virtue of the fact that their signatures refer only to this @code{SCM} +type. + +For all these reasons, the Guile developers have decided to deprecate +the GH interface --- which means that support for GH will be completely +removed after the next few releases --- and to focus only on the +@code{scm_} interface, with additions to ensure that it is as easy to +use in all respects as GH was. + +It remains an open question whether deeper kinds of interface +portability would be useful for extension language-based applications, +and it may still be an interesting project to attempt to define a +corresponding GH-like interface, but the Guile developers no longer plan +to try to do this as part of the core Guile project. + + @node gh preliminaries @section gh preliminaries diff --git a/doc/guile.texi b/doc/guile.texi index 29da7b221..d42cc8ca4 100644 --- a/doc/guile.texi +++ b/doc/guile.texi @@ -80,7 +80,7 @@ by the Free Software Foundation. @sp 10 @comment The title is printed in a large font. @title Guile Reference Manual -@subtitle $Id: guile.texi,v 1.10 2001-05-23 17:24:49 mgrabmue Exp $ +@subtitle $Id: guile.texi,v 1.11 2001-06-20 22:08:19 ossau Exp $ @subtitle For use with Guile @value{VERSION} @include AUTHORS @@ -187,11 +187,11 @@ Part IV: Guile Scripting Part V: Extending Applications Using Guile * Libguile Intro:: Using Guile as an extension language. -* GH:: GH: a portable C to Scheme interface. * Data Representation:: Data representation in Guile. * Scheme Primitives:: Writing Scheme primitives in C. * I/O Extensions:: Using and extending ports in C. * Handling Errors:: How to handle errors in C code. +* GH:: The deprecated GH interface. Appendices @@ -273,9 +273,9 @@ Indices @end iftex @include extend.texi -@include gh.texi @include data-rep.texi @include scm.texi +@include gh.texi @c Appendices @iftex From 9d45919310adc631a3ba232cff1c482fa4864396 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 21 Jun 2001 19:39:03 +0000 Subject: [PATCH 1347/2047] * Signal an error if unable to find channel.scm file. --- emacs/ChangeLog | 6 ++++++ emacs/guile.el | 13 +++++++------ 2 files changed, 13 insertions(+), 6 deletions(-) diff --git a/emacs/ChangeLog b/emacs/ChangeLog index 2b02bf87f..69b67b581 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,3 +1,9 @@ +2001-06-21 Neil Jerram + + * guile.el (guile-channel-file): Signal an error if unable to find + channel.scm. + Change "gulie" typos to "guile". + 2001-05-06 Keisuke Nishida * guile.el (guile:eval): Propagate user interrupt. diff --git a/emacs/guile.el b/emacs/guile.el index efd91fd69..15f866fbb 100644 --- a/emacs/guile.el +++ b/emacs/guile.el @@ -25,7 +25,7 @@ ;;; Low level interface ;;; -(defvar gulie-emacs-file +(defvar guile-emacs-file (catch 'return (mapc (lambda (dir) (let ((file (expand-file-name "guile-emacs.scm" dir))) @@ -33,21 +33,22 @@ load-path) (error "Cannot find guile-emacs.scm"))) -(defvar gulie-channel-file +(defvar guile-channel-file (catch 'return (mapc (lambda (dir) (let ((file (expand-file-name "channel.scm" dir))) (if (file-exists-p file) (throw 'return file)))) - load-path))) + load-path) + (error "Cannot find channel.scm"))) (defvar guile-libs - (nconc (if gulie-channel-file (list "-l" gulie-channel-file) '()) - (list "-l" gulie-emacs-file))) + (nconc (if guile-channel-file (list "-l" guile-channel-file) '()) + (list "-l" guile-emacs-file))) ;;;###autoload (defun guile:make-adapter (command channel) (let* ((buff (generate-new-buffer " *guile object channel*")) - (libs (if gulie-channel-file (list "-l" gulie-channel-file) nil)) + (libs (if guile-channel-file (list "-l" guile-channel-file) nil)) (proc (apply 'start-process "guile-oa" buff command "-q" guile-libs))) (process-kill-without-query proc) (accept-process-output proc) From 0c02b4080323cd7e8cf8d34121eeda3498028292 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 22 Jun 2001 14:23:46 +0000 Subject: [PATCH 1348/2047] * Start new node documenting transition from GH to scm interface. --- doc/ChangeLog | 6 ++ doc/gh.texi | 221 ++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 227 insertions(+) diff --git a/doc/ChangeLog b/doc/ChangeLog index 4482010b0..6efb994fd 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,9 @@ +2001-06-22 Neil Jerram + + * gh.texi (scm transition summary): New node for summary of how to + transition from GH to scm interface. + (GH): Link to new node. + 2001-06-20 Neil Jerram * guile.texi (Top): Move GH chapter to end of Part V. diff --git a/doc/gh.texi b/doc/gh.texi index 999ea6331..641565aa4 100644 --- a/doc/gh.texi +++ b/doc/gh.texi @@ -28,6 +28,7 @@ the same result using the scm interface. * Memory allocation and garbage collection:: * Calling Scheme procedures from C:: * Mixing gh and scm APIs:: +* scm transition summary:: @end menu @@ -831,3 +832,223 @@ here. @node Mixing gh and scm APIs @section Mixing gh and scm APIs + + +@node scm transition summary +@section Transitioning to the scm Interface + +The following table summarizes the available information on how to +transition from the GH to the scm interface. Where transitioning is not +completely straightforward, the table includes a reference to more +detailed documentation in the preceding sections. + +@table @asis +@item Header file +Use @code{#include } instead of @code{#include +}. + +@item Linking flags +No change: @code{-lguile} should be added to the link command line, +along with any additional libraries that your application needs. + +@item The @code{SCM} type +No change: the scm interface also uses this type to represent an +arbitrary Scheme value. + +@item @code{SCM_BOOL_F} and @code{SCM_BOOL_T} +No change. + +@item @code{SCM_UNSPECIFIED} +No change. + +@item @code{gh_enter} +Use @code{scm_boot_guile} instead, but note that @code{scm_boot_guile} +has a slightly different calling convention from @code{gh_enter}: +@code{scm_boot_guile}, and the main program function that you specify +for @code{scm_boot_guile} to call, both take an additional @var{closure} +parameter. @ref{Guile Initialization Functions} for more details. + +@item @code{gh_repl} +Use @code{scm_shell} instead. + +@item @code{gh_init} +Use @code{scm_init_guile} instead. + +@item @code{gh_eval_str} +Use @code{scm_eval_0str} instead. + +@item @code{gh_eval_file} or @code{gh_load} +Replace @code{gh_eval_file (@var{fname})} by +@example +scm_primitive_load (scm_makfrom0str (@var{fname})) +@end example + +@item @code{gh_new_procedure} +Use @code{scm_c_define_gsubr} instead, but note that the arguments are +in a different order: for @code{scm_c_define_gsubr} the C function +pointer is the last argument. @ref{A Sample Guile Extension} for an +example. + +@item @code{gh_defer_ints} and @code{gh_allow_ints} +Use @code{SCM_DEFER_INTS} and @code{SCM_ALLOW_INTS} instead. Note that +these macros are used without parentheses, as in @code{SCM_DEFER_INTS;}. + +@item @code{gh_bool2scm} +Use @code{SCM_BOOL} instead. + +@item @code{gh_ulong2scm} +Use @code{scm_ulong2num} instead. + +@item @code{gh_long2scm} +Use @code{scm_long2num} instead. + +@item @code{gh_double2scm} +Use @code{scm_make_real} instead. + +@item @code{gh_char2scm} +Use @code{SCM_MAKE_CHAR} instead. + +@item @code{gh_str2scm} +Use @code{scm_makfromstr} instead. Note that @code{scm_makfromstr} +currently has an additional, third parameter, but it's unused and will +hopefully disappear soon. If it's still there, set it to 0. + +@item @code{gh_str02scm} +Use @code{scm_makfrom0str} instead. + +@item @code{gh_set_substr} +No direct scm equivalent. [FIXME] + +@item @code{gh_symbol2scm} +Use @code{scm_str2symbol} instead. [FIXME: inconsistent naming, +should be @code{scm_str02symbol}.] + +@item @code{gh_ints2scm} and @code{gh_doubles2scm} +No direct scm equivalent. [FIXME] + +@item @code{gh_chars2byvect} and @code{gh_shorts2svect} +No direct scm equivalent. [FIXME] + +@item @code{gh_longs2ivect} and @code{gh_ulongs2uvect} +No direct scm equivalent. [FIXME] + +@item @code{gh_floats2fvect} and @code{gh_doubles2dvect} +No direct scm equivalent. [FIXME] + +@item @code{gh_scm2bool} +Use @code{SCM_NFALSEP} instead. + +@item @code{gh_scm2int} +Use @code{scm_num2int} instead. + +@item @code{gh_scm2ulong} +Use @code{scm_num2ulong} instead. + +@item @code{gh_scm2long} +Use @code{scm_num2long} instead. + +@item @code{gh_scm2double} +Use @code{scm_num2dbl} instead. + +@item @code{gh_scm2char} +Use the @code{SCM_CHAR} macro instead, but note that @code{SCM_CHAR} +does not check that its argument is actually a character. To check that +a @code{SCM} value is a character before using @code{SCM_CHAR} to +extract the character value, use the @code{SCM_VALIDATE_CHAR} macro. + +@item @code{gh_scm2newstr} +No direct scm equivalent. [FIXME] + +@item @code{gh_get_substr} +No direct scm equivalent. [FIXME] + +@item @code{gh_symbol2newstr} +No direct scm equivalent. [FIXME] + +@item @code{gh_scm2chars} +No direct scm equivalent. [FIXME] + +@item @code{gh_scm2shorts} and @code{gh_scm2longs} +No direct scm equivalent. [FIXME] + +@item @code{gh_scm2floats} and @code{gh_scm2doubles} +No direct scm equivalent. [FIXME] + +@item @code{gh_boolean_p} +Use the @code{SCM_BOOLP} macro instead, or replace @code{gh_boolean_p +(@var{obj})} by +@example +SCM_NFALSEP (scm_boolean_p (@var{obj})) +@end example + +@item @code{gh_symbol_p} +Use the @code{SCM_SYMBOLP} macro instead, or replace @code{gh_symbol_p +(@var{obj})} by +@example +SCM_NFALSEP (scm_symbol_p (@var{obj})) +@end example + +@item @code{gh_char_p} +Use the @code{SCM_CHARP} macro instead, or replace @code{gh_char_p +(@var{obj})} by +@example +SCM_NFALSEP (scm_char_p (@var{obj})) +@end example + +@item @code{gh_vector_p} +Use the @code{SCM_VECTORP} macro instead, or replace @code{gh_vector_p +(@var{obj})} by +@example +SCM_NFALSEP (scm_vector_p (@var{obj})) +@end example + +@item @code{gh_pair_p} +Use the @code{SCM_CONSP} macro instead, or replace @code{gh_pair_p +(@var{obj})} by +@example +SCM_NFALSEP (scm_pair_p (@var{obj})) +@end example + +@item @code{gh_number_p} +Use the @code{SCM_NUMBERP} macro instead, or replace @code{gh_number_p +(@var{obj})} by +@example +SCM_NFALSEP (scm_number_p (@var{obj})) +@end example + +@item @code{gh_string_p} +Use the @code{SCM_STRINGP} macro instead, or replace @code{gh_string_p +(@var{obj})} by +@example +SCM_NFALSEP (scm_string_p (@var{obj})) +@end example + +@item @code{gh_procedure_p} +Replace @code{gh_procedure_p (@var{obj})} by +@example +SCM_NFALSEP (scm_procedure_p (@var{obj})) +@end example + +@item @code{gh_list_p} +Replace @code{gh_list_p (@var{obj})} by +@example +SCM_NFALSEP (scm_list_p (@var{obj})) +@end example + +@item @code{gh_inexact_p} +Use the @code{SCM_INEXACTP} macro instead, or replace @code{gh_inexact_p +(@var{obj})} by +@example +SCM_NFALSEP (scm_inexact_p (@var{obj})) +@end example + +@item @code{gh_exact_p} +Replace @code{gh_exact_p (@var{obj})} by +@example +SCM_NFALSEP (scm_exact_p (@var{obj})) +@end example + +@item @code{gh_list} +Use @code{scm_listify} instead. + +@end table From 5843e5c98888a6b90d87a39894f42cd76e2be09c Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 23 Jun 2001 15:25:57 +0000 Subject: [PATCH 1349/2047] * Various minor improvements, for example signedness fixes. --- libguile/ChangeLog | 26 +++++++++++++++++++++++++ libguile/backtrace.c | 26 +++++++++++-------------- libguile/fluids.c | 5 ++--- libguile/numbers.c | 16 +++++++-------- libguile/objects.c | 46 ++++++++++++++++++++++++-------------------- libguile/pairs.h | 2 +- 6 files changed, 73 insertions(+), 48 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 7e7a47703..a1f2041e1 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,29 @@ +2001-06-23 Dirk Herrmann + + * backtrace.c (display_backtrace_body): Use SCM_VALIDATE_STACK + and SCM_VALIDATE_OPOUTPORT instead of SCM_ASSERT. Fix signedness + problem. + + * backtrace.c (display_expression, scm_set_print_params_x, + display_application, display_frame, scm_backtrace), numbers.c + (scm_istring2number), objects.c (scm_class_of, + scm_mcache_lookup_cmethod, scm_mcache_compute_cmethod): Prefer + explicit type check over SCM_N?IMP, !SCM_ over SCM_N. + + * fluids.c (scm_fluid_ref, scm_fluid_set_x): Fluid numbers are + always positive. + + * numbers.c (scm_i_mkbig): Remove unnecessary casts, remove + unnecessary SCM_DEFER_INTS, SCM_ALLOW_INTS. + + * objects.c (scm_class_of): Type fix. + + (scm_mcache_lookup_cmethod): Improved comment, simplified, + eliminated goto. + + * pairs.h (scm_error_pair_access): The function can return if + called recursively. + 2001-06-20 Martin Grabmueller * init.c (scm_init_guile_1): Removed initialization of tag.c. diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 0be2d0226..3ab3a29f4 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -154,7 +154,7 @@ display_expression (SCM frame,SCM pname,SCM source,SCM port) scm_iprin1 (scm_unmemoize (source), port, pstate); } } - else if (SCM_NIMP (source)) + else if (SCM_MEMOIZEDP (source)) { scm_puts ("In expression ", port); pstate->writingp = 1; @@ -300,7 +300,7 @@ SCM_DEFINE (scm_set_print_params_x, "set-print-params!", 1, 0, 0, print_params_t *new_params; SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, params, n); - for (ls = params; SCM_NNULLP (ls); ls = SCM_CDR (ls)) + for (ls = params; !SCM_NULLP (ls); ls = SCM_CDR (ls)) SCM_ASSERT (scm_ilength (SCM_CAR (params)) == 2 && SCM_INUMP (SCM_CAAR (ls)) && SCM_INUM (SCM_CAAR (ls)) >= 0 @@ -380,11 +380,11 @@ static void display_application (SCM frame,int indentation,SCM sport,SCM port,scm_print_state *pstate) { SCM proc = SCM_FRAME_PROC (frame); - SCM name = (SCM_NFALSEP (scm_procedure_p (proc)) + SCM name = (!SCM_FALSEP (scm_procedure_p (proc)) ? scm_procedure_name (proc) : SCM_BOOL_F); display_frame_expr ("[", - scm_cons (SCM_NFALSEP (name) ? name : proc, + scm_cons (!SCM_FALSEP (name) ? name : proc, SCM_FRAME_ARGS (frame)), SCM_FRAME_EVAL_ARGS_P (frame) ? " ..." : "]", indentation, @@ -532,7 +532,7 @@ display_frame (SCM frame,int nfield,int indentation,SCM sport,SCM port,scm_print } /* display file name and line number */ - if (SCM_NFALSEP (SCM_SHOW_FILE_NAME)) + if (!SCM_FALSEP (SCM_SHOW_FILE_NAME)) display_backtrace_file_and_line (frame, port, pstate); /* Check size of frame number. */ @@ -590,7 +590,7 @@ struct display_backtrace_args { }; static SCM -display_backtrace_body(struct display_backtrace_args *a) +display_backtrace_body (struct display_backtrace_args *a) #define FUNC_NAME "display_backtrace_body" { int n_frames, beg, end, n, i, j; @@ -602,14 +602,8 @@ display_backtrace_body(struct display_backtrace_args *a) a->port = SCM_COERCE_OUTPORT (a->port); /* Argument checking and extraction. */ - SCM_ASSERT (SCM_STACKP (a->stack), - a->stack, - SCM_ARG1, - s_display_backtrace); - SCM_ASSERT (SCM_OPOUTPORTP (a->port), - a->port, - SCM_ARG2, - s_display_backtrace); + SCM_VALIDATE_STACK (1, a->stack); + SCM_VALIDATE_OPOUTPORT (2, a->port); n_frames = SCM_INUM (scm_stack_length (a->stack)); n = SCM_INUMP (a->depth) ? SCM_INUM (a->depth) : SCM_BACKTRACE_DEPTH; if (SCM_BACKWARDS_P) @@ -658,6 +652,8 @@ display_backtrace_body(struct display_backtrace_args *a) indent_p = 0; else { + unsigned int j; + indent_p = 1; frame = scm_stack_ref (a->stack, SCM_MAKINUM (beg)); for (i = 0, j = 0; i < n; ++i) @@ -736,7 +732,7 @@ SCM_DEFINE (scm_backtrace, "backtrace", 0, 0, 0, { SCM the_last_stack = scm_fluid_ref (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var)); - if (SCM_NFALSEP (the_last_stack)) + if (!SCM_FALSEP (the_last_stack)) { scm_newline (scm_cur_outp); scm_puts ("Backtrace:\n", scm_cur_outp); diff --git a/libguile/fluids.c b/libguile/fluids.c index 07e944afc..9aba42bf5 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -149,10 +149,9 @@ SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0, "@code{#f}.") #define FUNC_NAME s_scm_fluid_ref { - long n; + unsigned long int n; SCM_VALIDATE_FLUID (1, fluid); - n = SCM_FLUID_NUM (fluid); if (SCM_VECTOR_LENGTH (scm_root->fluids) <= n) @@ -166,7 +165,7 @@ SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0, "Set the value associated with @var{fluid} in the current dynamic root.") #define FUNC_NAME s_scm_fluid_set_x { - long n; + unsigned long int n; SCM_VALIDATE_FLUID (1, fluid); n = SCM_FLUID_NUM (fluid); diff --git a/libguile/numbers.c b/libguile/numbers.c index 0beb8b2f0..59bb0007d 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1383,16 +1383,16 @@ SCM scm_i_mkbig (size_t nlen, int sign) { SCM v; - /* Cast to long int to avoid signed/unsigned comparison warnings. */ - if ((( ((long int) nlen) << SCM_BIGSIZEFIELD) >> SCM_BIGSIZEFIELD) - != (long int) nlen) + SCM_BIGDIG *base; + + if (((nlen << SCM_BIGSIZEFIELD) >> SCM_BIGSIZEFIELD) != nlen) scm_memory_error (s_bignum); - + + base = scm_must_malloc (nlen * sizeof (SCM_BIGDIG), s_bignum); + SCM_NEWCELL (v); - SCM_DEFER_INTS; - SCM_SET_BIGNUM_BASE (v, scm_must_malloc (nlen * sizeof (SCM_BIGDIG), s_bignum)); + SCM_SET_BIGNUM_BASE (v, base); SCM_SETNUMDIGS (v, nlen, sign); - SCM_ALLOW_INTS; return v; } @@ -2739,7 +2739,7 @@ scm_istring2number (char *str, long len, long radix) return scm_istr2int (&str[i], len - i, radix); case 0: res = scm_istr2int (&str[i], len - i, radix); - if (SCM_NFALSEP (res)) + if (!SCM_FALSEP (res)) return res; case 2: return scm_istr2flo (&str[i], len - i, radix); diff --git a/libguile/objects.c b/libguile/objects.c index a8ece94a3..66401e194 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -158,7 +158,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, case scm_tc7_smob: { - long type = SCM_TYP16 (x); + scm_t_bits type = SCM_TYP16 (x); if (type != scm_tc16_port_with_ps) return scm_smob_class[SCM_TC2SMOBNUM (type)]; x = SCM_PORT_WITH_PS_PORT (x); @@ -187,12 +187,12 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, { /* ordinary struct */ SCM handle = scm_struct_create_handle (SCM_STRUCT_VTABLE (x)); - if (SCM_NFALSEP (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle)))) + if (!SCM_FALSEP (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle)))) return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle)); else { SCM name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle)); - SCM class = scm_make_extended_class (SCM_NFALSEP (name) + SCM class = scm_make_extended_class (!SCM_FALSEP (name) ? SCM_SYMBOL_CHARS (name) : 0); SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class); @@ -217,10 +217,15 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, } #undef FUNC_NAME -/* (SCM_IM_DISPATCH ARGS N-SPECIALIZED +/* The cache argument for scm_mcache_lookup_cmethod has one of two possible + * formats: + * + * Format #1: + * (SCM_IM_DISPATCH ARGS N-SPECIALIZED * #((TYPE1 ... ENV FORMALS FORM ...) ...) * GF) * + * Format #2: * (SCM_IM_HASH_DISPATCH ARGS N-SPECIALIZED HASHSET MASK * #((TYPE1 ... ENV FORMALS FORM ...) ...) * GF) @@ -256,16 +261,9 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args) n = SCM_INUM (SCM_CAR (z)); /* maximum number of specializers */ methods = SCM_CADR (z); - if (SCM_NIMP (methods)) + if (SCM_INUMP (methods)) { - /* Prepare for linear search */ - mask = -1; - i = 0; - end = SCM_VECTOR_LENGTH (methods); - } - else - { - /* Compute a hash value */ + /* cache format #2: compute a hash value */ long hashset = SCM_INUM (methods); long j = n; z = SCM_CDDR (z); @@ -273,17 +271,24 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args) methods = SCM_CADR (z); i = 0; ls = args; - if (SCM_NIMP (ls)) + if (!SCM_NULLP (ls)) do { i += SCM_STRUCT_DATA (scm_class_of (SCM_CAR (ls))) [scm_si_hashsets + hashset]; ls = SCM_CDR (ls); } - while (j-- && SCM_NIMP (ls)); + while (j-- && !SCM_NULLP (ls)); i &= mask; end = i; } + else /* SCM_VECTORP (methods) */ + { + /* cache format #1: prepare for linear search */ + mask = -1; + i = 0; + end = SCM_VECTOR_LENGTH (methods); + } /* Search for match */ do @@ -291,7 +296,7 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args) long j = n; z = SCM_VELTS (methods)[i]; ls = args; /* list of arguments */ - if (SCM_NIMP (ls)) + if (!SCM_NULLP (ls)) do { /* More arguments than specifiers => CLASS != ENV */ @@ -300,11 +305,10 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args) ls = SCM_CDR (ls); z = SCM_CDR (z); } - while (j-- && SCM_NIMP (ls)); + while (j-- && !SCM_NULLP (ls)); /* Fewer arguments than specifiers => CAR != ENV */ - if (!(SCM_IMP (SCM_CAR (z)) || SCM_CONSP (SCM_CAR (z)))) - goto next_method; - return z; + if (SCM_NULLP (SCM_CAR (z)) || SCM_CONSP (SCM_CAR (z))) + return z; next_method: i = (i + 1) & mask; } while (i != end); @@ -315,7 +319,7 @@ SCM scm_mcache_compute_cmethod (SCM cache, SCM args) { SCM cmethod = scm_mcache_lookup_cmethod (cache, args); - if (SCM_IMP (cmethod)) + if (SCM_FALSEP (cmethod)) /* No match - memoize */ return scm_memoize_method (cache, args); return cmethod; diff --git a/libguile/pairs.h b/libguile/pairs.h index 17aa76cd1..2614cf37e 100644 --- a/libguile/pairs.h +++ b/libguile/pairs.h @@ -103,7 +103,7 @@ #if (SCM_DEBUG_PAIR_ACCESSES == 1) -extern void scm_error_pair_access (SCM) SCM_NORETURN; +extern void scm_error_pair_access (SCM); #endif extern SCM scm_cons (SCM x, SCM y); extern SCM scm_cons2 (SCM w, SCM x, SCM y); From 7862b07e4b7cd8f0f754a96955ab87f217328487 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 25 Jun 2001 00:55:36 +0000 Subject: [PATCH 1350/2047] (scm_srcprops_to_plist): Renamed from scm_t_srcpropso_plist. See the big type renaming. --- libguile/srcprop.c | 6 +++--- libguile/srcprop.h | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/libguile/srcprop.c b/libguile/srcprop.c index 25c65e72a..697698298 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -112,7 +112,7 @@ srcprops_print (SCM obj, SCM port, scm_print_state *pstate) int writingp = SCM_WRITINGP (pstate); scm_puts ("#', port); return 1; @@ -154,7 +154,7 @@ scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM plist) SCM -scm_t_srcpropso_plist (SCM obj) +scm_srcprops_to_plist (SCM obj) { SCM plist = SRCPROPPLIST (obj); if (!SCM_UNBNDP (SRCPROPCOPY (obj))) @@ -182,7 +182,7 @@ SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0, #endif p = scm_hashq_ref (scm_source_whash, obj, SCM_BOOL_F); if (SRCPROPSP (p)) - return scm_t_srcpropso_plist (p); + return scm_srcprops_to_plist (p); return SCM_EOL; } #undef FUNC_NAME diff --git a/libguile/srcprop.h b/libguile/srcprop.h index e1505c0e7..abfbc1709 100644 --- a/libguile/srcprop.h +++ b/libguile/srcprop.h @@ -137,7 +137,7 @@ extern SCM scm_sym_breakpoint; -extern SCM scm_t_srcpropso_plist (SCM obj); +extern SCM scm_srcprops_to_plist (SCM obj); extern SCM scm_make_srcprops (long line, int col, SCM fname, SCM copy, SCM plist); extern SCM scm_source_property (SCM obj, SCM key); extern SCM scm_set_source_property_x (SCM obj, SCM key, SCM datum); From 62af908b2743c6d2b3c84cfaa1aa2cd3af56ff98 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 25 Jun 2001 00:56:41 +0000 Subject: [PATCH 1351/2047] * srcprop.h, srcprop.c (scm_srcprops_to_plist): Renamed from scm_t_srcpropso_plist. See the big type renaming. * coop-defs.h (scm_mutex_trylock, scm_cond_timedwait): Likewise. --- libguile/coop-defs.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/coop-defs.h b/libguile/coop-defs.h index 86033ad37..ad2deb1d4 100644 --- a/libguile/coop-defs.h +++ b/libguile/coop-defs.h @@ -153,7 +153,7 @@ extern int coop_mutex_unlock (coop_m*); extern int coop_mutex_destroy (coop_m*); #define scm_mutex_init coop_mutex_init #define scm_mutex_lock coop_mutex_lock -#define scm_t_mutexrylock coop_mutex_lock +#define scm_mutex_trylock coop_mutex_lock #define scm_mutex_unlock coop_mutex_unlock #define scm_mutex_destroy coop_mutex_destroy @@ -188,7 +188,7 @@ extern int coop_condition_variable_signal (coop_c*); extern int coop_condition_variable_destroy (coop_c*); #define scm_cond_init coop_new_condition_variable_init #define scm_cond_wait coop_condition_variable_wait_mutex -#define scm_t_condimedwait coop_condition_variable_timed_wait_mutex +#define scm_cond_timedwait coop_condition_variable_timed_wait_mutex #define scm_cond_signal coop_condition_variable_signal #define scm_cond_broadcast coop_condition_variable_signal /* yes */ #define scm_cond_destroy coop_condition_variable_destroy From 6aed915c795b56caef9cc9116f85182640bd734c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 25 Jun 2001 00:57:59 +0000 Subject: [PATCH 1352/2047] (SIZE_MAX, PTRDIFF_MIN, PTRDIFF_MAX): Only define when they aren't defined already. --- libguile/numbers.c | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 59bb0007d..b1e139d01 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -4200,10 +4200,18 @@ scm_i_big2dbl (SCM b) # endif #endif +#ifndef SIZE_MAX #define SIZE_MAX ((size_t) (-1)) +#endif + +#ifndef PTRDIFF_MIN /* the below is not really guaranteed to work (I think), but probably does: */ -#define PTRDIFF_MIN ((ptrdiff_t) ((ptrdiff_t)1 << (sizeof (ptrdiff_t) * 8 - 1))) +#define PTRDIFF_MIN ((ptrdiff_t) ((ptrdiff_t)1 << (sizeof (ptrdiff_t)*8 - 1))) +#endif + +#ifndef PTRDIFF_MAX #define PTRDIFF_MAX (~ PTRDIFF_MIN) +#endif #define NUM2INTEGRAL scm_num2short #define INTEGRAL2NUM scm_short2num From 16be44e59dbe5fdb23ed2033dd80fab449937a09 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 25 Jun 2001 00:58:20 +0000 Subject: [PATCH 1353/2047] *** empty log message *** --- libguile/ChangeLog | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index a1f2041e1..e205b2966 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,13 @@ +2001-06-25 Marius Vollmer + + * srcprop.h, srcprop.c (scm_srcprops_to_plist): Renamed from + scm_t_srcpropso_plist. See the big type renaming. + * coop-defs.h (scm_mutex_trylock, scm_cond_timedwait): Likewise. + Thanks to Seth Alves! + + * numbers.c (SIZE_MAX, PTRDIFF_MIN, PTRDIFF_MAX): Only define when + they aren't defined already. + 2001-06-23 Dirk Herrmann * backtrace.c (display_backtrace_body): Use SCM_VALIDATE_STACK From e6b748a8321c78b7ef4a93f687bf04d3413affc8 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 25 Jun 2001 01:06:33 +0000 Subject: [PATCH 1354/2047] (re-export-syntax): New. --- 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 bc6aff060..5969244a3 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -2831,6 +2831,7 @@ (error "re-export can only be used at the top level")))) (define export-syntax export) +(define re-export-syntax re-export) (define load load-module) From ad4bc8c2bab6785bca380b42207934aaff3a2ec0 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 25 Jun 2001 01:07:04 +0000 Subject: [PATCH 1355/2047] Use `re-export-syntax' to correctly re-export `receive'. --- srfi/srfi-8.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/srfi/srfi-8.scm b/srfi/srfi-8.scm index 6ed7fc185..78732d445 100644 --- a/srfi/srfi-8.scm +++ b/srfi/srfi-8.scm @@ -44,6 +44,6 @@ (define-module (srfi srfi-8) :use-module (ice-9 receive)) -(export-syntax receive) +(re-export-syntax receive) (cond-expand-provide (current-module) '(srfi-8)) From f65811137e95496d70f5f12039cbf750f66977f0 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 25 Jun 2001 01:07:36 +0000 Subject: [PATCH 1356/2047] *** empty log message *** --- ice-9/ChangeLog | 4 ++++ srfi/ChangeLog | 5 +++++ 2 files changed, 9 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 6df92b26a..d1005d491 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2001-06-25 Marius Vollmer + + * boot-9.scm (re-export-syntax): New. + 2001-06-16 Marius Vollmer * boot-9.scm (system-error-errno): New. diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 1e6f68339..77d97f8bf 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,8 @@ +2001-06-25 Marius Vollmer + + * srfi-8.scm: Use `re-export-syntax' to correctly re-export + `receive'. + 2001-06-18 Matthias Koeppe The SRFI-19 implementation was completely broken. Already the From fc7a9e81a699994b365e76ac84345aa354c3fe62 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Mon, 25 Jun 2001 03:27:51 +0000 Subject: [PATCH 1357/2047] * streams.scm (stream-for-each-many): typo fix. --- ice-9/ChangeLog | 4 ++++ ice-9/streams.scm | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index d1005d491..ffdef9570 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2001-06-25 Michael Livshin + + * streams.scm (stream-for-each-many): typo fix. + 2001-06-25 Marius Vollmer * boot-9.scm (re-export-syntax): New. diff --git a/ice-9/streams.scm b/ice-9/streams.scm index 9ef0706e6..d300937e6 100644 --- a/ice-9/streams.scm +++ b/ice-9/streams.scm @@ -212,7 +212,7 @@ If STREAM has infinite length this procedure will not terminate." (f (stream-car stream)) (stream-for-each-one f (stream-cdr stream))))) -(define (stream-for-each-may f streams) +(define (stream-for-each-many f streams) (if (not (or-map stream-null? streams)) (begin (apply f (map stream-car streams)) From ac13d9d210fa8c88d28b7dedd6b44762e610ae83 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Mon, 25 Jun 2001 03:30:02 +0000 Subject: [PATCH 1358/2047] * snarf.h (SCM_SNARF_DOCS): change the "grammar" slightly. * guile-snarf-docs.in, guile-snarf-docs-texi.in: rewrite & simplify. * eval.c: all hash signs are in column 0. * Makefile.am (guile_filter_doc_snarfage): build using c-tokenize.c, not filter-doc-snarfage.c. rearrange snarfing dependencies a bit. * c-tokenize.lex: new file. --- libguile/ChangeLog | 15 +++ libguile/Makefile.am | 8 +- libguile/c-tokenize.lex | 180 ++++++++++++++++++++++++++++++ libguile/eval.c | 2 +- libguile/guile-snarf-docs-texi.in | 31 +---- libguile/guile-snarf-docs.in | 8 +- libguile/snarf.h | 17 ++- 7 files changed, 212 insertions(+), 49 deletions(-) create mode 100644 libguile/c-tokenize.lex diff --git a/libguile/ChangeLog b/libguile/ChangeLog index e205b2966..40e704526 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,18 @@ +2001-06-25 Michael Livshin + + * snarf.h (SCM_SNARF_DOCS): change the "grammar" slightly. + + * guile-snarf-docs.in, guile-snarf-docs-texi.in: rewrite & + simplify. + + * eval.c: all hash signs are in column 0. + + * Makefile.am (guile_filter_doc_snarfage): build using + c-tokenize.c, not filter-doc-snarfage.c. + rearrange snarfing dependencies a bit. + + * c-tokenize.lex: new file. + 2001-06-25 Marius Vollmer * srcprop.h, srcprop.c (scm_srcprops_to_plist): Renamed from diff --git a/libguile/Makefile.am b/libguile/Makefile.am index e8d0ab4a5..58d11cc4d 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -38,7 +38,7 @@ guile_SOURCES = guile.c guile_LDADD = libguile.la ${THREAD_LIBS_LOCAL} guile_LDFLAGS = @DLPREOPEN@ -guile_filter_doc_snarfage_SOURCES = filter-doc-snarfage.c +guile_filter_doc_snarfage_SOURCES = c-tokenize.c libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ chars.c continuations.c debug.c deprecation.c dynl.c dynwind.c \ @@ -185,8 +185,6 @@ libpath.h: $(srcdir)/Makefile.in $(top_builddir)/config.status @mv libpath.tmp libpath.h -# ./guile-snarf $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ - SUFFIXES = .x .doc .c.x: ./guile-snarf $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \ @@ -198,13 +196,13 @@ SUFFIXES = .x .doc $(DOT_X_FILES) $(EXTRA_DOT_DOC_FILES): snarf.h guile-snarf.in -$(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES): snarf.h guile-snarf-docs.in guile_filter_doc_snarfage +$(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES): snarf.h guile-snarf-docs.in error.x: cpp_err_symbols.c posix.x: cpp_sig_symbols.c load.x: libpath.h -guile.texi: $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) guile-snarf-docs-texi.in guile +guile.texi: $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) guile-snarf-docs-texi.in guile guile_filter_doc_snarfage ./guile-snarf-docs-texi $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) > $@ \ || { rm $@; false; } diff --git a/libguile/c-tokenize.lex b/libguile/c-tokenize.lex new file mode 100644 index 000000000..9c6c9387d --- /dev/null +++ b/libguile/c-tokenize.lex @@ -0,0 +1,180 @@ +%option noyywrap +%pointer + +EOL \n +SPACE [ \t\v\f] +WS [ \t\v\n\f] +DIGIT [0-9] +LETTER [a-zA-Z_] +OCTDIGIT [0-7] +HEXDIGIT [a-fA-F0-9] +EXPONENT [Ee][+-]?{DIGIT}+ +FLOQUAL (f|F|l|L) +INTQUAL (l|L|ll|LL|lL|Ll|u|U) + +%{ + +#include +#include +#include + +int filter_snarfage = 0; +int print = 1; + +enum t_state { + SKIP, + MULTILINE, + MULTILINE_COOKIE, + COOKIE, +}; + +enum t_state state = SKIP; +int cookie_was_last = 0; + +#define OUT_RAW(type,text) if (print) printf ("(%s . \"%s\")\n", #type, text) + +#define OUT_T(type) OUT_RAW (type, yytext) +#define OUT_S if (print) printf ("%s\n", yytext) +#define OUT(type) if (print) printf ("%s\n", #type) + +#define IS_COOKIE cookie_was_last = 1 +#define IS_NOT_COOKIE cookie_was_last = 0 + +%} + +%% + +\/\*(\n|[^*]|\*[^/])*\*\/ { OUT_T (comment); } + +({SPACE}*(\\\n)*{SPACE}*)+ ; + +({SPACE}*\n*{SPACE}*)+ { OUT(eol); } + +# { OUT(hash); IS_NOT_COOKIE; } + +{LETTER}({LETTER}|{DIGIT})* { OUT_T (id); IS_NOT_COOKIE; } + +0[xX]{HEXDIGIT}+{INTQUAL}? { OUT_RAW (int_hex, yytext + 2); IS_NOT_COOKIE; } +0{OCTDIGIT}+{INTQUAL}? { OUT_RAW (int_oct, yytext + 1); IS_NOT_COOKIE; } +{DIGIT}+{INTQUAL}? { OUT_T (int_dec); IS_NOT_COOKIE; } + +L?\'(\\.|[^\\\'])+\' { OUT_T (char); IS_NOT_COOKIE; } + +{DIGIT}+{EXPONENT}{FLOQUAL}? { OUT_T (flo_dec); IS_NOT_COOKIE; } +{DIGIT}*"."{DIGIT}+({EXPONENT})?{FLOQUAL}? { OUT_T (flo_dec); IS_NOT_COOKIE; } +{DIGIT}+"."{DIGIT}*({EXPONENT})?{FLOQUAL}? { OUT_T (flo_dec); IS_NOT_COOKIE; } + +L?\"(\\.|[^\\\"])*\" { OUT_S; IS_NOT_COOKIE; } + +"..." { OUT (ellipsis); IS_NOT_COOKIE; } + +">>=" { OUT (shift_right_assign); IS_NOT_COOKIE; } +"<<=" { OUT (shift_left_assign); IS_NOT_COOKIE; } +"+=" { OUT (add_assign); IS_NOT_COOKIE; } +"-=" { OUT (sub_assign); IS_NOT_COOKIE; } +"*=" { OUT (mul-assign); IS_NOT_COOKIE; } +"/=" { OUT (div_assign); IS_NOT_COOKIE; } +"%=" { OUT (mod_assign); IS_NOT_COOKIE; } +"&=" { OUT (logand_assign); IS_NOT_COOKIE; } +"^=" { OUT (logxor_assign); IS_NOT_COOKIE; } +"|=" { OUT (logior_assign); IS_NOT_COOKIE; } +">>" { OUT (right_shift); IS_NOT_COOKIE; } +"<<" { OUT (left_shift); IS_NOT_COOKIE; } +"++" { OUT (inc); IS_NOT_COOKIE; } +"--" { OUT (dec); IS_NOT_COOKIE; } +"->" { OUT (ptr); IS_NOT_COOKIE; } +"&&" { OUT (and); IS_NOT_COOKIE; } +"||" { OUT (or); IS_NOT_COOKIE; } +"<=" { OUT (le); IS_NOT_COOKIE; } +">=" { OUT (ge); IS_NOT_COOKIE; } +"==" { OUT (eq); IS_NOT_COOKIE; } +"!=" { OUT (ne); IS_NOT_COOKIE; } +";" { OUT (semicolon); IS_NOT_COOKIE; } + +("{"|"<%") { + OUT (brace_open); + if (filter_snarfage && cookie_was_last && state == COOKIE) + state = MULTILINE; + IS_NOT_COOKIE; } + +("}"|"%>") { + OUT (brace_close); + if (filter_snarfage && cookie_was_last && state == MULTILINE_COOKIE) { + state = SKIP; + print = 0; + } + IS_NOT_COOKIE; } + +"," { OUT (comma); IS_NOT_COOKIE; } +":" { OUT (colon); IS_NOT_COOKIE; } +"=" { OUT (assign); IS_NOT_COOKIE; } +"(" { OUT (paren_open); IS_NOT_COOKIE; } +")" { OUT (paren_close); IS_NOT_COOKIE; } +("["|"<:") { OUT (bracket_open); IS_NOT_COOKIE; } +("]"|":>") { OUT (bracket_close); IS_NOT_COOKIE; } +"." { OUT (dot); IS_NOT_COOKIE; } +"&" { OUT (amp); IS_NOT_COOKIE; } +"!" { OUT (bang); IS_NOT_COOKIE; } +"~" { OUT (tilde); IS_NOT_COOKIE; } +"-" { OUT (minus); IS_NOT_COOKIE; } +"+" { OUT (plus); IS_NOT_COOKIE; } +"*" { OUT (star); IS_NOT_COOKIE; } +"/" { OUT (slash); IS_NOT_COOKIE; } +"%" { OUT (percent); IS_NOT_COOKIE; } +"<" { OUT (lt); IS_NOT_COOKIE; } +">" { OUT (gt); IS_NOT_COOKIE; } + +\^{WS}*\^ { + if (filter_snarfage) + switch (state) { + case SKIP: + state = COOKIE; + print = 1; + OUT (snarf_cookie); + break; + case MULTILINE: + case MULTILINE_COOKIE: + state = MULTILINE_COOKIE; + OUT (snarf_cookie); + break; + case COOKIE: + state = SKIP; + OUT (snarf_cookie); + print = 0; + break; + default: + /* whoops */ + abort (); + break; + } + else + OUT (snarf_cookie); + + IS_COOKIE; } + +"^" { OUT (caret); IS_NOT_COOKIE; } +"|" { OUT (pipe); IS_NOT_COOKIE; } +"?" { OUT (question); IS_NOT_COOKIE; } + +. { fprintf (stderr, "*%s", yytext); fflush (stderr); IS_NOT_COOKIE; } + +%% + +int +main (int argc, char *argv[]) +{ + if (argc > 1 && !strcmp (argv[1], "--filter-snarfage")) { + filter_snarfage = 1; + print = 0; + } + + yylex (); + + return EXIT_SUCCESS; +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/eval.c b/libguile/eval.c index dad5aef6a..53177f6ae 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -68,7 +68,7 @@ # include # else # ifdef _AIX - #pragma alloca +# pragma alloca # else # ifndef alloca /* predefined by HP cc +Olibcalls */ char *alloca (); diff --git a/libguile/guile-snarf-docs-texi.in b/libguile/guile-snarf-docs-texi.in index 2dbc4aecc..587c6aff7 100755 --- a/libguile/guile-snarf-docs-texi.in +++ b/libguile/guile-snarf-docs-texi.in @@ -24,37 +24,14 @@ bindir=`dirname $0` bindir=`(cd $bindir; pwd)` srcdir=`(cd $srcdir; pwd)` -temp0="/tmp/snarf.0.$$" -temp1="/tmp/snarf.1.$$" -trap "rm -f $temp0 $temp1" 0 1 2 15 - -# cat all the small files together: -cat "$@" > ${temp1} - -## massage the arglists - -# lose the SCM types and commas, and texi-quote @'s in names and args -< ${temp1} sed -e '/^arglist/s/[ ]*SCM[ ]*//g' \ - -e '/^arglist/s/,/ /g' \ - -e '/^arglist/s/([ ]*void[ ]*)/()/g' \ - -e '/^fname/s/@/@@/g' \ - -e '/^arglist/s/@/@@/g' \ - > ${temp0} - -# nothing to do with the docstrings -< ${temp0} sed -e 's/^string //' > ${temp1} - -# we're too lame to check argpos assertions other then for straight names, so... -< ${temp1} sed -e 's/^argpos.*[(\[].*//' > ${temp0} - echo "@paragraphindent 0" -# now run the script that will generate texinfo +# run the script that will generate texinfo main='(module-ref (resolve-module '\''(scripts snarf-check-and-output-texi)) '\''main)' apply_main="(apply $main (cdr (command-line)))" if [ `basename ${bindir}` = libguile ]; then - GUILE_LOAD_PATH=${srcdir}/.. ${bindir}/guile -c "${apply_main}" < ${temp0} -else - ${bindir}/guile -c "${apply_main}" < ${temp0} + GUILE_LOAD_PATH=${srcdir}/..; export GUILE_LOAD_PATH fi + +cat "$@" | ${bindir}/guile_filter_doc_snarfage --filter-snarfage | ${bindir}/guile -c "${apply_main}" diff --git a/libguile/guile-snarf-docs.in b/libguile/guile-snarf-docs.in index 338b710d7..46c540d48 100755 --- a/libguile/guile-snarf-docs.in +++ b/libguile/guile-snarf-docs.in @@ -20,13 +20,7 @@ bindir=`dirname $0` -temp="/tmp/snarf.$$" -trap "rm -f $temp" 0 1 2 15 - ## Let the user override the preprocessor autoconf found. test -n "${CPP+set}" || CPP="@CPP@" -## We must use a temporary file here, instead of a pipe, because we -## need to know if CPP exits with a non-zero status. -${CPP} -DSCM_MAGIC_SNARF_DOCS "$@" > ${temp} || exit $? -< ${temp} ${bindir}/guile_filter_doc_snarfage +${CPP} -DSCM_MAGIC_SNARF_DOCS "$@" diff --git a/libguile/snarf.h b/libguile/snarf.h index 04c2a3022..d242e958d 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -85,14 +85,13 @@ # define SCM_SNARF_HERE(X) # define SCM_SNARF_INIT(X) # define SCM_SNARF_DOCS(TYPE, FNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING) \ -^^{ \ -^^%fname . FNAME \ -^^%type . TYPE \ -^^%location __FILE__ . __LINE__ \ -^^%arglist . ARGLIST \ -^^%argsig REQ OPT VAR \ -^^(DOCSTRING) \ -^^} +^^ { \ +fname FNAME ^^ \ +type TYPE ^^ \ +location __FILE__ __LINE__ ^^ \ +arglist ARGLIST ^^ \ +argsig REQ OPT VAR ^^ \ +DOCSTRING ^^ } # else # define SCM_SNARF_HERE(X) X # define SCM_SNARF_INIT(X) @@ -219,7 +218,7 @@ SCM_SNARF_INIT(c_name = scm_permanent_object (scm_sysintern (scheme_name, init_v #ifdef SCM_MAGIC_SNARF_DOCS #undef SCM_ASSERT -#define SCM_ASSERT(_cond, _arg, _pos, _subr) ^^[ argpos _arg _pos __LINE__ ] +#define SCM_ASSERT(_cond, _arg, _pos, _subr) ^^ argpos _arg _pos __LINE__ ^^ #endif /* SCM_MAGIC_SNARF_DOCS */ #endif /* LIBGUILE_SNARF_H */ From 58e17e276b22a7a040e3b6f2b44009c85ebd2b5b Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Mon, 25 Jun 2001 03:30:32 +0000 Subject: [PATCH 1359/2047] * snarf-check-and-output-texi: rewrite. --- scripts/ChangeLog | 4 + scripts/snarf-check-and-output-texi | 265 ++++++++++++++++++++-------- 2 files changed, 198 insertions(+), 71 deletions(-) diff --git a/scripts/ChangeLog b/scripts/ChangeLog index d647d06f9..d7a8910d4 100644 --- a/scripts/ChangeLog +++ b/scripts/ChangeLog @@ -1,3 +1,7 @@ +2001-06-25 Michael Livshin + + * snarf-check-and-output-texi: rewrite. + 2001-05-31 Michael Livshin * snarf-check-and-output-texi: new file. diff --git a/scripts/snarf-check-and-output-texi b/scripts/snarf-check-and-output-texi index 4ba467272..7b4df63fd 100755 --- a/scripts/snarf-check-and-output-texi +++ b/scripts/snarf-check-and-output-texi @@ -27,8 +27,99 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;;; Code: (define-module (scripts snarf-check-and-output-texi) + :use-module (ice-9 streams) + :use-module (ice-9 match) :export (snarf-check-and-output-texi)) +;;; why aren't these in some module? + +(define-macro (when cond . body) + `(if ,cond (begin ,@body))) + +(define-macro (unless cond . body) + `(if (not ,cond) (begin ,@body))) + +(define (snarf-check-and-output-texi) + (process-stream (current-input-port))) + +(define (process-stream port) + (let loop ((input (stream-map (match-lambda + (('id . s) + (cons 'id (string->symbol s))) + (('int_dec . s) + (cons 'int (string->number s))) + (('int_oct . s) + (cons 'int (string->number s 8))) + (('int_hex . s) + (cons 'int (string->number s 16))) + ((and x (? symbol?)) + (cons x x)) + ((and x (? string?)) + (cons 'string x)) + (x x)) + (make-stream (lambda (s) + (let loop ((s s)) + (cond + ((stream-null? s) #t) + ((eq? 'eol (stream-car s)) + (loop (stream-cdr s))) + (else (cons (stream-car s) (stream-cdr s)))))) + (port->stream port read))))) + + (unless (stream-null? input) + (let ((token (stream-car input))) + (if (eq? (car token) 'snarf_cookie) + (dispatch-top-cookie (stream-cdr input) + loop) + (loop (stream-cdr input))))))) + +(define (dispatch-top-cookie input cont) + + (when (stream-null? input) + (error 'syntax "premature end of file")) + + (let ((token (stream-car input))) + (cond + ((eq? (car token) 'brace_open) + (consume-multiline (stream-cdr input) + cont)) + (else + (consume-upto-cookie process-singleline + input + cont))))) + +(define (consume-upto-cookie process input cont) + (let loop ((acc '()) (input input)) + + (when (stream-null? input) + (error 'syntax "premature end of file in directive context")) + + (let ((token (stream-car input))) + (cond + ((eq? (car token) 'snarf_cookie) + (process (reverse! acc)) + (cont (stream-cdr input))) + + (else (loop (cons token acc) (stream-cdr input))))))) + +(define (consume-multiline input cont) + (begin-multiline) + + (let loop ((input input)) + + (when (stream-null? input) + (error 'syntax "premature end of file in multiline context")) + + (let ((token (stream-car input))) + (cond + ((eq? (car token) 'brace_close) + (end-multiline) + (cont (stream-cdr input))) + + (else (consume-upto-cookie process-multiline-directive + input + loop)))))) + (define *file* #f) (define *line* #f) (define *function-name* #f) @@ -37,62 +128,16 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" (define *sig* #f) (define *docstring* #f) -(define (doc-block args) - (let loop ((args args)) - (if (not (null? args)) - (let ((arg (car args))) - (if (not (null? arg)) - (begin - - (case (car arg) - - ((fname) - (set! *function-name* (cdr arg))) - - ((type) - (set! *snarf-type* (cdr arg))) - - ((location) - (set! *file* (cadr arg)) - (set! *line* (cddr arg))) - - ((arglist) - (set! *args* (cdr arg))) - - ((argsig) - (set! *sig* (cdr arg))) - - ((docstring) - (set! *docstring* (cdr arg))) - - (else - (error (format #f "unknown doc attribute: ~A" (car arg))))))) - (loop (cdr args))))) - (output-doc-block)) - -(define (doc-check arg) - (if (not (null? arg)) +(define (begin-multiline) + (set! *file* #f) + (set! *line* #f) + (set! *function-name* #f) + (set! *snarf-type* #f) + (set! *args* #f) + (set! *sig* #f) + (set! *docstring* #f)) - (case (car arg) - - ((argpos) - (let* ((name (cadr arg)) - (pos (caddr arg)) - (line (cadddr arg)) - (idx (list-index *args* name))) - (cond - ((not idx)) - ((not (number? pos))) - ((= 0 pos)) - ((not (= (+ idx 1) pos)) - (display (format #f "~A:~A: wrong position for argument \"~A\": ~A (should be ~A)\n" - *file* line name pos (+ idx 1)) - (current-error-port)))))) - - (else - (error (format #f "unknown check: ~A" (car arg))))))) - -(define (output-doc-block) +(define (end-multiline) (let* ((req (car *sig*)) (opt (cadr *sig*)) (var (caddr *sig*)) @@ -137,21 +182,99 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" (loop (cdr strings))))) (display "\n@end deffn\n")))) -(define (snarf-check-and-output-texi) - (let loop ((form (read))) - (if (not (eof-object? form)) - (begin - (if (not (null? form)) - - (case (car form) - - ((doc-block) - (doc-block (cdr form))) - - ((doc-check) - (doc-check (cdr form))) - - (else (error (format #f "unknown doc command: ~A" (car form)))))) - (loop (read)))))) +(define (texi-quote s) + (let rec ((i 0)) + (if (= i (string-length s)) + "" + (string-append (let ((ss (substring s i (+ i 1)))) + (if (string=? ss "@") + "@@" + ss)) + (rec (+ i 1)))))) + +(define (process-multiline-directive l) + + (define do-args + (match-lambda + + (('(paren_close . paren_close)) + '()) + + (('(comma . comma) rest ...) + (do-args rest)) + + (('(id . SCM) ('id . name) rest ...) + (cons name (do-args rest))) + + (x (error (format #f "invalid argument syntax: ~A" (map cdr x)))))) + + (define do-arglist + (match-lambda + + (('(paren_open . paren_open) '(id . void) '(paren_close . paren_close)) + '()) + + (('(paren_open . paren_open) rest ...) + (do-args rest)) + + (x (error (format #f "invalid arglist syntax: ~A" (map cdr x)))))) + + (define do-command + (match-lambda + + (('fname ('string . name)) + (set! *function-name* (texi-quote name))) + + (('type ('id . type)) + (set! *snarf-type* type)) + + (('type ('int . num)) + (set! *snarf-type* num)) + + (('location ('string . file) ('int . line)) + (set! *file* file) + (set! *line* line)) + + (('arglist rest ...) + (set! *args* (do-arglist rest))) + + (('argsig ('int . req) ('int . opt) ('int . var)) + (set! *sig* (list req opt var))) + + (x (error (format #f "unknown doc attribute: ~A" x))))) + + (define do-directive + (match-lambda + + ((('id . command) rest ...) + (do-command (cons command rest))) + + ((('string . string) ...) + (set! *docstring* string)) + + (x (error (format #f "unknown doc attribute syntax: ~A" x))))) + + (do-directive l)) + +(define (process-singleline l) + + (define do-argpos + (match-lambda + ((('id . name) ('int . pos) ('int . line)) + (let ((idx (list-index *args* name))) + (when idx + (unless (= (+ idx 1) pos) + (display (format #f "~A:~A: wrong position for argument ~A: ~A (should be ~A)\n" + *file* line name pos (+ idx 1))))))) + (x #f))) + + (define do-command + (match-lambda + (('(id . argpos) rest ...) + (do-argpos rest)) + (x (error (format #f "unknown check: ~A" x))))) + + (when *function-name* + (do-command l))) (define main snarf-check-and-output-texi) From 093e7da4bc2b467e91a2ddac96758161690180fd Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Mon, 25 Jun 2001 03:31:10 +0000 Subject: [PATCH 1360/2047] * HACKING: mention flex. * autogen.sh: generate libguile/c-tokenize.c. --- ChangeLog | 6 ++++++ HACKING | 4 +++- autogen.sh | 1 + 3 files changed, 10 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 21806c622..daabce176 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2001-06-25 Michael Livshin + + * HACKING: mention flex. + + * autogen.sh: generate libguile/c-tokenize.c. + 2001-06-20 Martin Grabmueller * libguile.h: Removed inclusion of libguile/tag.h. diff --git a/HACKING b/HACKING index b837a38cc..f3d60a899 100644 --- a/HACKING +++ b/HACKING @@ -57,9 +57,11 @@ libtool 1.4 --- a system for managing the zillion hairy options needed on various systems to produce shared libraries. Available in "ftp://ftp.gnu.org/pub/gnu/libtool" +flex 2.5.4 --- a tokenizer generator. earlier versions will most + probably work too. + You are lost in a little maze of automatically generated files, all different. -> Contributing Your Changes ============================================ diff --git a/autogen.sh b/autogen.sh index c3498d0cb..02bba0a34 100755 --- a/autogen.sh +++ b/autogen.sh @@ -11,5 +11,6 @@ libtoolize --copy --automake --ltdl autoheader autoconf automake --add-missing +flex -t libguile/c-tokenize.lex > libguile/c-tokenize.c ( echo "guile-readline..."; cd guile-readline; ./autogen.sh ) From ee0c0e034cd7f275de128a698d11f85d9f09b661 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Mon, 25 Jun 2001 03:37:06 +0000 Subject: [PATCH 1361/2047] * Makefile.am (MAINTAINERCLEANFILES): be sure to remove c-tokenize.c when doing maintainer-clean. --- libguile/ChangeLog | 3 +++ libguile/Makefile.am | 2 ++ 2 files changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 40e704526..d758893df 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,8 @@ 2001-06-25 Michael Livshin + * Makefile.am (MAINTAINERCLEANFILES): be sure to remove + c-tokenize.c when doing maintainer-clean. + * snarf.h (SCM_SNARF_DOCS): change the "grammar" slightly. * guile-snarf-docs.in, guile-snarf-docs-texi.in: rewrite & diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 58d11cc4d..b701dabd0 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -262,3 +262,5 @@ MOSTLYCLEANFILES = \ cpp_sig_symbols_here cpp_sig_symbols_diff cpp_sig_symbols_new CLEANFILES = libpath.h *.x *.doc guile-procedures.txt guile.texi + +MAINTAINERCLEANFILES = c-tokenize.c From 5f5dc9296639c2cea89c796ab11efa5cacb54a3c Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Mon, 25 Jun 2001 03:46:41 +0000 Subject: [PATCH 1362/2047] *** empty log message *** --- libguile/.cvsignore | 1 + 1 file changed, 1 insertion(+) diff --git a/libguile/.cvsignore b/libguile/.cvsignore index 7bdc7f277..ea2a54de6 100644 --- a/libguile/.cvsignore +++ b/libguile/.cvsignore @@ -36,3 +36,4 @@ scmconfig.h scmconfig.h.in stamp-h versiondat.h +c-tokenize.c From 13dcb66612f195f93e6529a25aa21376215a89c6 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 25 Jun 2001 11:06:33 +0000 Subject: [PATCH 1363/2047] * Fix signedness plus some minor improvements. --- libguile/ChangeLog | 28 +++++++++ libguile/debug.h | 14 +++-- libguile/stacks.c | 150 +++++++++++++++++++++++++-------------------- libguile/stacks.h | 17 ++--- 4 files changed, 127 insertions(+), 82 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d758893df..d5233dc80 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,31 @@ +2001-06-25 Dirk Herrmann + + * debug.h (SCM_DEBUGOBJ_FRAME): Deliver result as a + scm_t_debug_frame*. + + * debug.h (DEBUGH, SCM_DEBUG_H), stacks.h (STACKSH, SCM_STACKSH): + Rename H to SCM__H. + + * stacks.c (NEXT_FRAME, narrow_stack): Prefer explicit type check + over SCM_N?IMP, !SCM_ over SCM_N. + + (narrow_stack): Make i unsigned. Don't use side-effecting + operations in conditions. + + (narrow_stack, scm_make_stack, scm_stack_id, + scm_last_stack_frame): Get rid of redundant SCM_N?IMP checks. + + (scm_make_stack, scm_stack_id, scm_last_stack_frame): Clean up + type dispatch. No need to cast result of SCM_DEBUGOBJ_FRAME any + more. + + (scm_stack_ref, scm_frame_previous, scm_frame_next): Fix + signedness. + + (scm_last_stack_frame): Remove bogus `;´. + + * stacks.h (SCM_FRAMEP): Fix type check. + 2001-06-25 Michael Livshin * Makefile.am (MAINTAINERCLEANFILES): be sure to remove diff --git a/libguile/debug.h b/libguile/debug.h index 10a0cf69c..16d09510a 100644 --- a/libguile/debug.h +++ b/libguile/debug.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef DEBUGH -#define DEBUGH -/* Copyright (C) 1995,1996,1998, 1999, 2000 Free Software Foundation +#ifndef SCM_DEBUG_H +#define SCM_DEBUG_H +/* Copyright (C) 1995,1996,1998,1999,2000,2001 Free Software Foundation * * 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 @@ -172,8 +172,10 @@ extern scm_t_debug_frame *scm_last_debug_frame; extern scm_t_bits scm_tc16_debugobj; -#define SCM_DEBUGOBJP(x) SCM_TYP16_PREDICATE (scm_tc16_debugobj, x) -#define SCM_DEBUGOBJ_FRAME(x) SCM_CELL_WORD_1 (x) +#define SCM_DEBUGOBJP(x) \ + SCM_TYP16_PREDICATE (scm_tc16_debugobj, x) +#define SCM_DEBUGOBJ_FRAME(x) \ + ((scm_t_debug_frame *) SCM_CELL_WORD_1 (x)) #define SCM_SET_DEBUGOBJ_FRAME(x, f) SCM_SET_CELL_WORD_1 (x, f) /* {Memoized Source} @@ -217,7 +219,7 @@ extern SCM scm_proc_to_mem (SCM obj); extern SCM scm_debug_hang (SCM obj); #endif /*GUILE_DEBUG*/ -#endif /* DEBUGH */ +#endif /* SCM_DEBUG_H */ /* Local Variables: diff --git a/libguile/stacks.c b/libguile/stacks.c index 42242f032..3b6387b1f 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -1,5 +1,5 @@ /* Representation of stack frame debug information - * Copyright (C) 1996,1997, 2000 Free Software Foundation + * Copyright (C) 1996,1997,2000,2001 Free Software Foundation * * 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 @@ -230,7 +230,7 @@ get_applybody () #define NEXT_FRAME(iframe, n, quit) \ do { \ - if (SCM_NIMP (iframe->source) \ + if (SCM_MEMOIZEDP (iframe->source) \ && SCM_EQ_P (SCM_MEMOIZED_EXP (iframe->source), applybody)) \ { \ iframe->source = SCM_BOOL_F; \ @@ -280,7 +280,8 @@ read_frames (scm_t_debug_frame *dframe,long offset,long n,scm_t_info_frame *ifra if ((info - dframe->vect) & 1) --info; /* Data in the apply part of an eval info frame comes from - previous stack frame if the scm_t_debug_info vector is overflowed. */ + previous stack frame if the scm_t_debug_info vector is + overflowed. */ else if (SCM_OVERFLOWP (*dframe) && !SCM_UNBNDP (info[1].a.proc)) { @@ -348,28 +349,33 @@ static void narrow_stack (SCM stack,long inner,SCM inner_key,long outer,SCM outer_key) { scm_t_stack *s = SCM_STACK (stack); - long i; + unsigned long int i; long n = s->length; /* Cut inner part. */ if (SCM_EQ_P (inner_key, SCM_BOOL_T)) - /* Cut all frames up to user module code */ { + /* Cut all frames up to user module code */ for (i = 0; inner; ++i, --inner) { SCM m = s->frames[i].source; - if ( SCM_MEMOIZEDP (m) - && SCM_NIMP (SCM_MEMOIZED_ENV (m)) + if (SCM_MEMOIZEDP (m) + && !SCM_IMP (SCM_MEMOIZED_ENV (m)) && SCM_FALSEP (scm_system_module_env_p (SCM_MEMOIZED_ENV (m)))) { /* Back up in order to include any non-source frames */ - while (i > 0 - && !((m = s->frames[i - 1].source, SCM_MEMOIZEDP (m)) - || (SCM_NIMP (m = s->frames[i - 1].proc) - && SCM_NFALSEP (scm_procedure_p (m)) - && SCM_NFALSEP (scm_procedure_property - (m, scm_sym_system_procedure))))) + while (i > 0) { + m = s->frames[i - 1].source; + if (SCM_MEMOIZEDP (m)) + break; + + m = s->frames[i - 1].proc; + if (!SCM_FALSEP (scm_procedure_p (m)) + && !SCM_FALSEP (scm_procedure_property + (m, scm_sym_system_procedure))) + break; + --i; ++inner; } @@ -423,7 +429,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, { long n, size; int maxp; - scm_t_debug_frame *dframe = scm_last_debug_frame; + scm_t_debug_frame *dframe; scm_t_info_frame *iframe; long offset = 0; SCM stack, id; @@ -431,27 +437,27 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, /* Extract a pointer to the innermost frame of whatever object scm_make_stack was given. */ - /* just use dframe == scm_last_debug_frame - (from initialization of dframe, above) if obj is #t */ - if (!SCM_EQ_P (obj, SCM_BOOL_T)) + if (SCM_EQ_P (obj, SCM_BOOL_T)) { - SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, FUNC_NAME); - if (SCM_DEBUGOBJP (obj)) - dframe = (scm_t_debug_frame *) SCM_DEBUGOBJ_FRAME (obj); - else if (SCM_CONTINUATIONP (obj)) - { - offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (obj) + sizeof (scm_t_contregs)) - - SCM_BASE (obj)); + dframe = scm_last_debug_frame; + } + else if (SCM_DEBUGOBJP (obj)) + { + dframe = SCM_DEBUGOBJ_FRAME (obj); + } + else if (SCM_CONTINUATIONP (obj)) + { + offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (obj) + sizeof (scm_t_contregs)) + - SCM_BASE (obj)); #ifndef STACK_GROWS_UP - offset += SCM_CONTINUATION_LENGTH (obj); + offset += SCM_CONTINUATION_LENGTH (obj); #endif - dframe = RELOC_FRAME (SCM_DFRAME (obj), offset); - } - else - { - SCM_WRONG_TYPE_ARG (SCM_ARG1, obj); - /* not reached */ - } + dframe = RELOC_FRAME (SCM_DFRAME (obj), offset); + } + else + { + SCM_WRONG_TYPE_ARG (SCM_ARG1, obj); + /* not reached */ } /* Count number of frames. Also get stack id tag and check whether @@ -480,7 +486,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, args = SCM_CDR (args); if (SCM_NULLP (args)) { - outer_cut = SCM_INUM0; + outer_cut = SCM_INUM0; } else { @@ -516,26 +522,31 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0, scm_t_debug_frame *dframe; long offset = 0; if (SCM_EQ_P (stack, SCM_BOOL_T)) - dframe = scm_last_debug_frame; + { + dframe = scm_last_debug_frame; + } + else if (SCM_DEBUGOBJP (stack)) + { + dframe = SCM_DEBUGOBJ_FRAME (stack); + } + else if (SCM_CONTINUATIONP (stack)) + { + offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (stack) + sizeof (scm_t_contregs)) + - SCM_BASE (stack)); +#ifndef STACK_GROWS_UP + offset += SCM_CONTINUATION_LENGTH (stack); +#endif + dframe = RELOC_FRAME (SCM_DFRAME (stack), offset); + } + else if (SCM_STACKP (stack)) + { + return SCM_STACK (stack) -> id; + } else { - SCM_VALIDATE_NIM (1,stack); - if (SCM_DEBUGOBJP (stack)) - dframe = (scm_t_debug_frame *) SCM_DEBUGOBJ_FRAME (stack); - else if (SCM_CONTINUATIONP (stack)) - { - offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (stack) + sizeof (scm_t_contregs)) - - SCM_BASE (stack)); -#ifndef STACK_GROWS_UP - offset += SCM_CONTINUATION_LENGTH (stack); -#endif - dframe = RELOC_FRAME (SCM_DFRAME (stack), offset); - } - else if (SCM_STACKP (stack)) - return SCM_STACK (stack) -> id; - else - SCM_WRONG_TYPE_ARG (1, stack); + SCM_WRONG_TYPE_ARG (1, stack); } + while (dframe && !SCM_VOIDFRAMEP (*dframe)) dframe = RELOC_FRAME (dframe->prev, offset); if (dframe && SCM_VOIDFRAMEP (*dframe)) @@ -545,16 +556,18 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0, - (SCM stack, SCM i), - "Return the @var{i}'th frame from @var{stack}.") + (SCM stack, SCM index), + "Return the @var{index}'th frame from @var{stack}.") #define FUNC_NAME s_scm_stack_ref { - SCM_VALIDATE_STACK (1,stack); - SCM_VALIDATE_INUM (2,i); - SCM_ASSERT_RANGE (1,i, - SCM_INUM (i) >= 0 && - SCM_INUM (i) < SCM_STACK_LENGTH (stack)); - return scm_cons (stack, i); + unsigned long int c_index; + + SCM_VALIDATE_STACK (1, stack); + SCM_VALIDATE_INUM (2, index); + SCM_ASSERT_RANGE (1, index, SCM_INUM (index) >= 0); + c_index = SCM_INUM (index); + SCM_ASSERT_RANGE (1, index, c_index < SCM_STACK_LENGTH (stack)); + return scm_cons (stack, index); } #undef FUNC_NAME @@ -591,9 +604,10 @@ SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0, long offset = 0; SCM stack; - SCM_VALIDATE_NIM (1,obj); if (SCM_DEBUGOBJP (obj)) - dframe = (scm_t_debug_frame *) SCM_DEBUGOBJ_FRAME (obj); + { + dframe = SCM_DEBUGOBJ_FRAME (obj); + } else if (SCM_CONTINUATIONP (obj)) { offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (obj) + sizeof (scm_t_contregs)) @@ -619,7 +633,7 @@ SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0, read_frame (dframe, offset, (scm_t_info_frame *) &SCM_STACK (stack) -> frames[0]); - return scm_cons (stack, SCM_INUM0);; + return scm_cons (stack, SCM_INUM0); } #undef FUNC_NAME @@ -672,8 +686,8 @@ SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0, "@var{frame} is the first frame in its stack.") #define FUNC_NAME s_scm_frame_previous { - long n; - SCM_VALIDATE_FRAME (1,frame); + unsigned long int n; + SCM_VALIDATE_FRAME (1, frame); n = SCM_INUM (SCM_CDR (frame)) + 1; if (n >= SCM_STACK_LENGTH (SCM_CAR (frame))) return SCM_BOOL_F; @@ -688,13 +702,13 @@ SCM_DEFINE (scm_frame_next, "frame-next", 1, 0, 0, "@var{frame} is the last frame in its stack.") #define FUNC_NAME s_scm_frame_next { - long n; - SCM_VALIDATE_FRAME (1,frame); - n = SCM_INUM (SCM_CDR (frame)) - 1; - if (n < 0) + unsigned long int n; + SCM_VALIDATE_FRAME (1, frame); + n = SCM_INUM (SCM_CDR (frame)); + if (n == 0) return SCM_BOOL_F; else - return scm_cons (SCM_CAR (frame), SCM_MAKINUM (n)); + return scm_cons (SCM_CAR (frame), SCM_MAKINUM (n - 1)); } #undef FUNC_NAME diff --git a/libguile/stacks.h b/libguile/stacks.h index b034bb368..58b83ff80 100644 --- a/libguile/stacks.h +++ b/libguile/stacks.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef STACKSH -#define STACKSH -/* Copyright (C) 1995,1996, 2000 Free Software Foundation +#ifndef SCM_STACKS_H +#define SCM_STACKS_H +/* Copyright (C) 1995,1996,2000,2001 Free Software Foundation * * 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 @@ -84,10 +84,11 @@ extern SCM scm_t_stackype; #define SCM_STACKP(obj) (SCM_STRUCTP (obj) && SCM_EQ_P (SCM_STRUCT_VTABLE (obj), scm_t_stackype)) #define SCM_STACK_LENGTH(stack) (SCM_STACK (stack) -> length) -#define SCM_FRAMEP(obj) (SCM_CONSP (obj) \ - && SCM_STACKP (SCM_CAR (obj)) \ - && SCM_INUMP (SCM_CDR (obj))) \ - +#define SCM_FRAMEP(obj) \ + (SCM_CONSP (obj) && SCM_STACKP (SCM_CAR (obj)) \ + && SCM_INUMP (SCM_CDR (obj)) && SCM_INUM (SCM_CDR (obj)) >= 0 \ + && ((unsigned long int) SCM_INUM (SCM_CDR (obj)) \ + < SCM_STACK_LENGTH (SCM_CAR (obj)))) #define SCM_FRAME_REF(frame, slot) \ (SCM_STACK (SCM_CAR (frame)) -> frames[SCM_INUM (SCM_CDR (frame))].slot) \ @@ -142,7 +143,7 @@ SCM scm_frame_overflow_p (SCM frame); void scm_init_stacks (void); -#endif /* STACKSH */ +#endif /* SCM_STACKS_H */ /* Local Variables: From 9e74987fac93a59c95b5456e08279d26311edacc Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 25 Jun 2001 15:07:20 +0000 Subject: [PATCH 1364/2047] Added message about what to do next. Tell them to use `--enable-maintainer-mode'. --- autogen.sh | 3 +++ 1 file changed, 3 insertions(+) diff --git a/autogen.sh b/autogen.sh index 02bba0a34..b5e4b7e44 100755 --- a/autogen.sh +++ b/autogen.sh @@ -14,3 +14,6 @@ automake --add-missing flex -t libguile/c-tokenize.lex > libguile/c-tokenize.c ( echo "guile-readline..."; cd guile-readline; ./autogen.sh ) + +echo "Now run configure and make." +echo "You must pass the `--enable-maintainer-mode' option to configure." From 7fca1a1a7b1e61f514a857916096e9c26ea1531c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 25 Jun 2001 15:07:37 +0000 Subject: [PATCH 1365/2047] (version.texi, version-tutorial.texi): Removed kluges to build them unconditionally. --- doc/Makefile.am | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/doc/Makefile.am b/doc/Makefile.am index 739938988..4457f855c 100644 --- a/doc/Makefile.am +++ b/doc/Makefile.am @@ -71,14 +71,18 @@ dist-hook: cd example-smob; \ cp $(EXAMPLE_SMOB_FILES) $$dest) +## The following two kluges were added so that CVS checkouts would +## build when not configured with `--enable-maintainer-mode'. They +## were removed again since they relied on internal automake features. + # This rule overrides automake's rule for version.texi. It causes # version.texi to be created even in non-maintainer-mode. -$(srcdir)/version.texi: stamp-vti - @: +#$(srcdir)/version.texi: stamp-vti +# @: # And the same for version-tutorial.texi. -$(srcdir)/version-tutorial.texi: stamp-vti1 - @: +#$(srcdir)/version-tutorial.texi: stamp-vti1 +# @: # pending the papers from Robert Merkel # EXTRA_DIST = guile.1 From 4172703a7d14841fc726a05a15a61860450cff79 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 25 Jun 2001 15:08:22 +0000 Subject: [PATCH 1366/2047] *** empty log message *** --- ChangeLog | 5 +++++ doc/ChangeLog | 5 +++++ 2 files changed, 10 insertions(+) diff --git a/ChangeLog b/ChangeLog index daabce176..e30522b83 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2001-06-25 Marius Vollmer + + * autogen.sh: Added message about what to do next. Tell them to + use `--enable-maintainer-mode'. + 2001-06-25 Michael Livshin * HACKING: mention flex. diff --git a/doc/ChangeLog b/doc/ChangeLog index 6efb994fd..7af1a0ad6 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,8 @@ +2001-06-25 Marius Vollmer + + * Makefile.am (version.texi, version-tutorial.texi): Removed + kluges to build them unconditionally. + 2001-06-22 Neil Jerram * gh.texi (scm transition summary): New node for summary of how to From f2ae4555395c65ae0a144de1e117a3c0f17d12c4 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Mon, 25 Jun 2001 22:24:40 +0000 Subject: [PATCH 1367/2047] * Quoting fix in autogen.sh. --- ChangeLog | 4 ++++ autogen.sh | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index e30522b83..2a3747154 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2001-06-25 Neil Jerram + + * autogen.sh: Quoting fix for `--enable-maintainer-mode'. + 2001-06-25 Marius Vollmer * autogen.sh: Added message about what to do next. Tell them to diff --git a/autogen.sh b/autogen.sh index b5e4b7e44..9a9c9abfa 100755 --- a/autogen.sh +++ b/autogen.sh @@ -16,4 +16,4 @@ flex -t libguile/c-tokenize.lex > libguile/c-tokenize.c ( echo "guile-readline..."; cd guile-readline; ./autogen.sh ) echo "Now run configure and make." -echo "You must pass the `--enable-maintainer-mode' option to configure." +echo "You must pass the \`--enable-maintainer-mode' option to configure." From fbcd68abe9c55fdaa762246a84f3324f11f1b0f8 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Mon, 25 Jun 2001 22:27:11 +0000 Subject: [PATCH 1368/2047] * More GH to scm transition documentation. * Revise info about GH deprecation following Marius' suggestions. --- doc/ChangeLog | 13 ++++ doc/extend.texi | 26 -------- doc/gh.texi | 155 +++++++++++++++++++++++++++++++++++++++--------- 3 files changed, 139 insertions(+), 55 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 7af1a0ad6..8125f7351 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,10 @@ +2001-06-25 Neil Jerram + + * gh.texi (GH deprecation): Remove paragraph about portability. + + * extend.texi (Libguile Intro): Updated following Marius' + suggestions. + 2001-06-25 Marius Vollmer * Makefile.am (version.texi, version-tutorial.texi): Removed @@ -8,6 +15,12 @@ * gh.texi (scm transition summary): New node for summary of how to transition from GH to scm interface. (GH): Link to new node. + (Calling Scheme procedures from C): Remove doc for gh_set_car and + gh_set_cdr, which don't actually exist. + (Data types and constants defined by gh): Correct + SCM_UNSPECIFIED/SCM_UNDEFINED confusion. + (Calling Scheme procedures from C): Correct SCM_EOL/SCM_UNDEFINED + confusion. 2001-06-20 Neil Jerram diff --git a/doc/extend.texi b/doc/extend.texi index 5cadde4e8..e69de29bb 100644 --- a/doc/extend.texi +++ b/doc/extend.texi @@ -1,26 +0,0 @@ -@page -@node Libguile Intro -@chapter Using Guile as an Extension Language - -The chapters in this part of the manual explain how to use Guile as a -powerful application extension language. - -An important change for the 1.6.x series of Guile releases is that the -GH interface is now deprecated. For the reasoning behind this decision, -see @xref{GH deprecation}. The GH interface will continue to be -supported for the 1.6.x and 1.8.x release series, but will be dropped -thereafter, so developers are encouraged to switch progressively to the -scm interface. The last chapter in this part of the manual (@pxref{GH}) -documents both how to use GH and how to switch from GH to scm. - -The documentation of the scm interface is currently a bit confused, but -the situation should improve rapidly once the 1.6.0 release is out. The -plan is to refocus the bulk of Part II, currently ``Guile Scheme'', as -the ``Guile API Reference'' so that it covers both Scheme and C -interfaces. (This makes sense because almost all of Guile's primitive -procedures on the Scheme level --- e.g. @code{memq} --- are also -available as C level primitives in the scm interface --- -e.g. @code{scm_memq}.) There will then remain a certain amount of -Scheme-specific (such as the ``Basic Ideas'' chapter) and C-specific -documentation (such as SMOB usage and interaction with the garbage -collector) to collect into corresponding chapters. diff --git a/doc/gh.texi b/doc/gh.texi index 641565aa4..4d2896ae8 100644 --- a/doc/gh.texi +++ b/doc/gh.texi @@ -62,25 +62,17 @@ Finally, the idea of multiple implementations of the GH interface did not really crystallize (apart, I believe, from a short lived implementation by the MzScheme project). -Where portability is concerned, the @code{scm_} interface is now already -portable in the sense that other projects could provide an alternative -implementation of the @code{scm_} header file. For the majority of -@code{scm_} functions, all that is needed is a definition of the -@code{SCM} type, and then those functions are automatically portable by -virtue of the fact that their signatures refer only to this @code{SCM} -type. - For all these reasons, the Guile developers have decided to deprecate the GH interface --- which means that support for GH will be completely removed after the next few releases --- and to focus only on the @code{scm_} interface, with additions to ensure that it is as easy to use in all respects as GH was. -It remains an open question whether deeper kinds of interface -portability would be useful for extension language-based applications, -and it may still be an interesting project to attempt to define a -corresponding GH-like interface, but the Guile developers no longer plan -to try to do this as part of the core Guile project. +It remains an open question whether a deep kind of interface portability +would be useful for extension language-based applications, and it may +still be an interesting project to attempt to define a corresponding +GH-like interface, but the Guile developers no longer plan to try to do +this as part of the core Guile project. @node gh preliminaries @@ -127,9 +119,16 @@ tend to just type @code{if (boolean_function()) @{ ... @}} @end defvr @defvr Constant SCM_UNSPECIFIED -This is an SCM object which does not correspond to any legal Scheme -value. It can be used in C to terminate functions with variable numbers -of arguments, such as @code{gh_list()}. +This is a SCM value that is not the same as any legal Scheme value. It +is the value that a Scheme function returns when its specification says +that its return value is unspecified. +@end defvr + +@defvr Constant SCM_UNDEFINED +This is another SCM value that is not the same as any legal Scheme +value. It is the value used to mark variables that do not yet have a +value, and it is also used in C to terminate functions with variable +numbers of arguments, such as @code{gh_list()}. @end defvr @@ -600,7 +599,7 @@ I will list these routines here without much explanation, since what they do is the same as documented in @ref{Standard procedures, R5RS, , r5rs, R5RS}. But I will point out that when a procedure takes a variable number of arguments (such as @code{gh_list}), you should pass -the constant @var{SCM_EOL} from C to signify the end of the list. +the constant @var{SCM_UNDEFINED} from C to signify the end of the list. @deftypefun SCM gh_define (char *@var{name}, SCM @var{val}) Corresponds to the Scheme @code{(define name val)}: it binds a value to @@ -616,13 +615,6 @@ These correspond to the Scheme @code{(cons a b)} and @code{(list l0 l1 @code{scm_listify()}. @end deftypefun -@deftypefun SCM gh_set_car (SCM @var{obj}, SCM @var{val}) -@deftypefunx SCM gh_set_cdr (SCM @var{obj}, SCM @var{val}) -These correspond to the Scheme @code{(set-car! ...)} and @code{(set-cdr! -...)} procedures. -@end deftypefun - - @deftypefun SCM gh_car (SCM @var{obj}) @deftypefunx SCM gh_cdr (SCM @var{obj}) @dots{} @@ -858,7 +850,7 @@ arbitrary Scheme value. @item @code{SCM_BOOL_F} and @code{SCM_BOOL_T} No change. -@item @code{SCM_UNSPECIFIED} +@item @code{SCM_UNSPECIFIED} and @code{SCM_UNDEFINED} No change. @item @code{gh_enter} @@ -939,16 +931,32 @@ No direct scm equivalent. [FIXME] Use @code{SCM_NFALSEP} instead. @item @code{gh_scm2int} -Use @code{scm_num2int} instead. +Replace @code{gh_scm2int (@var{obj})} by +@example +scm_num2int (@var{obj}, SCM_ARG1, @var{str}) +@end example +where @var{str} is a C string that describes the context of the call. @item @code{gh_scm2ulong} -Use @code{scm_num2ulong} instead. +Replace @code{gh_scm2ulong (@var{obj})} by +@example +scm_num2ulong (@var{obj}, SCM_ARG1, @var{str}) +@end example +where @var{str} is a C string that describes the context of the call. @item @code{gh_scm2long} -Use @code{scm_num2long} instead. +Replace @code{gh_scm2long (@var{obj})} by +@example +scm_num2long (@var{obj}, SCM_ARG1, @var{str}) +@end example +where @var{str} is a C string that describes the context of the call. @item @code{gh_scm2double} -Use @code{scm_num2dbl} instead. +Replace @code{gh_scm2double (@var{obj})} by +@example +scm_num2dbl (@var{obj}, @var{str}) +@end example +where @var{str} is a C string that describes the context of the call. @item @code{gh_scm2char} Use the @code{SCM_CHAR} macro instead, but note that @code{SCM_CHAR} @@ -1048,7 +1056,96 @@ Replace @code{gh_exact_p (@var{obj})} by SCM_NFALSEP (scm_exact_p (@var{obj})) @end example +@item @code{gh_eq_p} +Use the @code{SCM_EQ_P} macro instead, or replace @code{gh_eq_p +(@var{x}, @var{y})} by +@example +SCM_NFALSEP (scm_eq_p (@var{x}, @var{y})) +@end example + +@item @code{gh_eqv_p} +Replace @code{gh_eqv_p (@var{x}, @var{y})} by +@example +SCM_NFALSEP (scm_eqv_p (@var{x}, @var{y})) +@end example + +@item @code{gh_equal_p} +Replace @code{gh_equal_p (@var{x}, @var{y})} by +@example +SCM_NFALSEP (scm_equal_p (@var{x}, @var{y})) +@end example + +@item @code{gh_string_equal_p} +Replace @code{gh_string_equal_p (@var{x}, @var{y})} by +@example +SCM_NFALSEP (scm_string_equal_p (@var{x}, @var{y})) +@end example + +@item @code{gh_null_p} +Use the @code{SCM_NULLP} macro instead, or replace @code{gh_null_p +(@var{obj})} by +@example +SCM_NFALSEP (scm_null_p (@var{obj})) +@end example + +@item @code{gh_cons} +Use @code{scm_cons} instead. + +@item @code{gh_car} and @code{gh_cdr} +Use the @code{SCM_CAR} and @code{SCM_CDR} macros instead. + +@item @code{gh_cxxr} and @code{gh_cxxxr} +(Where each x is either @samp{a} or @samp{d}.) Use the corresponding +@code{SCM_CXXR} or @code{SCM_CXXXR} macro instead. + +@item @code{gh_set_car_x} and @code{gh_set_cdr_x} +Use @code{scm_set_car_x} and @code{scm_set_cdr_x} instead. + @item @code{gh_list} Use @code{scm_listify} instead. +@item @code{gh_length} +Replace @code{gh_length (@var{lst})} by +@example +scm_num2ulong (scm_length (@var{lst}), SCM_ARG1, @var{str}) +@end example +where @var{str} is a C string that describes the context of the call. + +@item @code{gh_append} +Use @code{scm_append} instead. + +@item @code{gh_append2}, @code{gh_append3}, @code{gh_append4} +Replace @code{gh_append@var{N} (@var{l1}, @dots{}, @var{lN})} by +@example +scm_append (scm_listify (@var{l1}, @dots{}, @var{lN}, SCM_UNDEFINED)) +@end example + +@item @code{gh_reverse} +Use @code{scm_reverse} instead. + +@item @code{gh_list_tail} and @code{gh_list_ref} +Use @code{scm_list_tail} and @code{scm_list_ref} instead. + +@item @code{gh_memq}, @code{gh_memv} and @code{gh_member} +Use @code{scm_memq}, @code{scm_memv} and @code{scm_member} instead. + +@item @code{gh_assq}, @code{gh_assv} and @code{gh_assoc} +Use @code{scm_assq}, @code{scm_assv} and @code{scm_assoc} instead. + +@item @code{gh_make_vector} +Use @code{scm_make_vector} instead. + +@item @code{gh_vector} or @code{gh_list_to_vector} +Use @code{scm_vector} instead. + +@item @code{gh_vector_ref} and @code{gh_vector_set_x} +Use @code{scm_vector_ref} and @code{scm_vector_set_x} instead. + +@item @code{gh_vector_length} +Use the @code{SCM_VECTOR_LENGTH} macro instead. + +@item @code{gh_apply} +Use @code{scm_apply} instead, but note that @code{scm_apply} takes an +additional third argument that you should set to @code{SCM_EOL}. + @end table From 36284627919a6968174b5f17369349187a2b4b1b Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 26 Jun 2001 10:59:34 +0000 Subject: [PATCH 1369/2047] * Deprecated scm_makfromstr and added scm_mem2string as a replacement. * Eliminated some potential gc problems. * Eliminated some signedness problems. * Minor changes. --- NEWS | 4 ++++ RELEASE | 2 +- doc/ChangeLog | 5 +++++ doc/oldfmt.c | 7 +++---- libguile/ChangeLog | 50 +++++++++++++++++++++++++++++++++++++++++++++ libguile/filesys.c | 35 +++++++++++++++---------------- libguile/gh_data.c | 2 +- libguile/load.c | 7 +++---- libguile/net_db.c | 19 ++++++++--------- libguile/numbers.c | 4 ++-- libguile/objects.c | 2 +- libguile/ports.c | 19 +++++++---------- libguile/read.c | 23 +++++++++------------ libguile/simpos.c | 4 ++-- libguile/socket.c | 5 ++--- libguile/stime.c | 4 ++-- libguile/strings.c | 26 ++++++++++++++++++----- libguile/strings.h | 19 +++++++++-------- libguile/strop.c | 15 +++++++++----- libguile/strports.c | 6 +++++- libguile/symbols.c | 5 ++++- libguile/validate.h | 8 +++++--- libguile/vports.c | 4 ++-- srfi/ChangeLog | 10 +++++++++ srfi/srfi-13.c | 31 +++++++++++++--------------- 25 files changed, 200 insertions(+), 116 deletions(-) diff --git a/NEWS b/NEWS index 56f595a40..5e26e4734 100644 --- a/NEWS +++ b/NEWS @@ -681,6 +681,10 @@ The old names are still available with status `deprecated'. scm_tc_dblc - replaced by scm_tc16_complex. scm_list_star - replaced by scm_cons_star. +** Deprecated: scm_makfromstr + +Use scm_mem2string instead. + ** Deprecated: scm_make_shared_substring Explicit shared substrings will disappear from Guile. diff --git a/RELEASE b/RELEASE index a26eec933..15fd89751 100644 --- a/RELEASE +++ b/RELEASE @@ -68,7 +68,7 @@ After signal handling and threading have been fixed: load.c: scm_read_and_eval_x smob.c: scm_make_smob_type_mfpe, scm_set_smob_mfpe gc.c: scm_remember - string.c: scm_makstr + string.c: scm_makstr, scm_makfromstr - remove deprecated procedures: boot-9.scm: eval-in-module, id, -1+, return-it, string-character-length, flags diff --git a/doc/ChangeLog b/doc/ChangeLog index 8125f7351..5e0f0848a 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,8 @@ +2001-06-26 Dirk Herrmann + + * oldfmt.c (scm_oldfmt): Use scm_mem2string instead of + scm_makfromstr. + 2001-06-25 Neil Jerram * gh.texi (GH deprecation): Remove paragraph about portability. diff --git a/doc/oldfmt.c b/doc/oldfmt.c index bfd00fe1d..19fbffcc5 100644 --- a/doc/oldfmt.c +++ b/doc/oldfmt.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2000 Free Software Foundation, Inc. +/* Copyright (C) 2000,2001 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 @@ -211,9 +211,8 @@ scm_oldfmt (SCM s) int n; SCM_ASSERT (SCM_NIMP (s) && SCM_STRINGP (s), s, 1, s_oldfmt); n = SCM_LENGTH (s); - return scm_return_first (scm_makfromstr (scm_c_oldfmt (SCM_ROCHARS (s), n), - n, - 0), + return scm_return_first (scm_mem2string (scm_c_oldfmt (SCM_ROCHARS (s), n), + n), s); #endif } diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d5233dc80..ddffe6faf 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,53 @@ +2001-06-26 Dirk Herrmann + + * filesys.c (scm_close), ports.c (scm_close_port, + scm_port_closed_p), strop.c (scm_string_null_p): Use SCM_BOOL + instead of SCM_NEGATE_BOOL. + + * filesys.c (scm_stat): Clean up type dispatch. + + * filesys.c (scm_stat), ports.c (scm_input_port_p, + scm_output_port_p): Get rid of redundant IM type check. + + * filesys.c (scm_readdir, scm_getcwd, scm_readlink), gh_data.c + (gh_str2scm), load.c (scm_primitive_load, scm_internal_parse_path, + scm_search_path), net_db.c (scm_gethost, scm_getnet, scm_getproto, + scm_return_entry), numbers.c (scm_number_to_string), objects.c + (scm_make_subclass_object), ports.c (scm_port_mode), read.c + (scm_lreadr), simpos.c (scm_getenv), socket.c (scm_inet_ntoa, + scm_addr_vector), stime.c (scm_strftime), strings.c + (scm_makfromstrs, scm_makfrom0str, scm_substring), strings.h + (SCM_STRING_COERCE_0TERMINATION_X), strop.c (string_copy, + scm_string_split), strports.c (scm_strport_to_string), symbols.c + (scm_symbol_to_string), vports.c (sf_write): Use scm_mem2string + instead of scm_makfromstr. + + * net_db.c (scm_sethost, scm_setnet, scm_setproto, scm_setserv), + ports.c (scm_close_all_ports_except), read.c (scm_lreadr, + scm_read_hash_extend), stime.c (scm_strftime), strings.c + (scm_string_append, scm_string), strings.h (SCM_STRINGP, + SCM_STRING_COERCE_0TERMINATION_X, SCM_RWSTRINGP), strop.c + (string_capitalize_x): Prefer explicit type check over SCM_N?IMP, + !SCM_ over SCM_N. + + * strings.[ch] (scm_makfromstr): Deprecated. + + (scm_mem2string): New function, replaces scm_makfromstr. + + * strings.c (scm_substring), strop.c (string_copy, + scm_string_split), strports.c (scm_strport_to_string), symbols.c + (scm_symbol_to_string): Fix gc problem. + + * strings.h (STRINGSH, SCM_STRINGS_H): Rename H to + SCM__H. + + * validate.h (SCM_VALIDATE_SUBSTRING_SPEC_COPY): Eliminate + warning about comparing signed and unsigned values. This fix is + not optimal, since it won't work reliably if sizeof (c_start) > + sizeof (size_t) or sizeof (c_end) > sizeof (size_t). A better + solution is to define this macro as an inline function, thus + allowing to specifiy the types of c_start and c_end. + 2001-06-25 Dirk Herrmann * debug.h (SCM_DEBUGOBJ_FRAME): Deliver result as a diff --git a/libguile/filesys.c b/libguile/filesys.c index 913343234..1d4afd341 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -333,7 +333,7 @@ SCM_DEFINE (scm_close, "close", 1, 0, 0, not an error. */ if (rv < 0 && errno != EBADF) SCM_SYSERROR; - return SCM_NEGATE_BOOL(rv < 0); + return SCM_BOOL (rv >= 0); } #undef FUNC_NAME @@ -529,23 +529,22 @@ SCM_DEFINE (scm_stat, "stat", 1, 0, 0, struct stat stat_temp; if (SCM_INUMP (object)) - SCM_SYSCALL (rv = fstat (SCM_INUM (object), &stat_temp)); + { + SCM_SYSCALL (rv = fstat (SCM_INUM (object), &stat_temp)); + } + else if (SCM_STRINGP (object)) + { + SCM_STRING_COERCE_0TERMINATION_X (object); + SCM_SYSCALL (rv = stat (SCM_STRING_CHARS (object), &stat_temp)); + } else { - SCM_VALIDATE_NIM (1,object); - if (SCM_STRINGP (object)) - { - SCM_STRING_COERCE_0TERMINATION_X (object); - SCM_SYSCALL (rv = stat (SCM_STRING_CHARS (object), &stat_temp)); - } - else - { - object = SCM_COERCE_OUTPORT (object); - SCM_VALIDATE_OPFPORT(1,object); - fdes = SCM_FPORT_FDES (object); - SCM_SYSCALL (rv = fstat (fdes, &stat_temp)); - } + object = SCM_COERCE_OUTPORT (object); + SCM_VALIDATE_OPFPORT (1, object); + fdes = SCM_FPORT_FDES (object); + SCM_SYSCALL (rv = fstat (fdes, &stat_temp)); } + if (rv == -1) { int en = errno; @@ -735,7 +734,7 @@ SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0, if (errno != 0) SCM_SYSERROR; - return (rdent ? scm_makfromstr (rdent->d_name, NAMLEN (rdent), 0) + return (rdent ? scm_mem2string (rdent->d_name, NAMLEN (rdent)) : SCM_EOF_VAL); } #undef FUNC_NAME @@ -845,7 +844,7 @@ SCM_DEFINE (scm_getcwd, "getcwd", 0, 0, 0, } if (rv == 0) SCM_SYSERROR; - result = scm_makfromstr (wd, strlen (wd), 0); + result = scm_mem2string (wd, strlen (wd)); scm_must_free (wd); return result; } @@ -1272,7 +1271,7 @@ SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0, } if (rv == -1) SCM_SYSERROR; - result = scm_makfromstr (buf, rv, 0); + result = scm_mem2string (buf, rv); scm_must_free (buf); return result; } diff --git a/libguile/gh_data.c b/libguile/gh_data.c index 3843a0741..f55b87ed9 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -81,7 +81,7 @@ gh_char2scm (char c) SCM gh_str2scm (const char *s, size_t len) { - return scm_makfromstr (s, len, 0); + return scm_mem2string (s, len); } SCM gh_str02scm (const char *s) diff --git a/libguile/load.c b/libguile/load.c index 73eb2b9ab..3f6fff049 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -123,8 +123,7 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0, { /* scope */ SCM port, save_port; - port = scm_open_file (filename, - scm_makfromstr ("r", (size_t) sizeof (char), 0)); + port = scm_open_file (filename, scm_mem2string ("r", sizeof (char))); save_port = port; scm_internal_dynamic_wind (swap_port, load, @@ -205,7 +204,7 @@ scm_internal_parse_path (char *path, SCM tail) /* Scan back to the beginning of the current element. */ do scan--; while (scan >= path && *scan != ':'); - tail = scm_cons (scm_makfromstr (scan + 1, elt_end - (scan + 1), 0), + tail = scm_cons (scm_mem2string (scan + 1, elt_end - (scan + 1)), tail); elt_end = scan; } while (scan >= path); @@ -389,7 +388,7 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, if (stat (buf, &mode) == 0 && ! (mode.st_mode & S_IFDIR)) { - result = scm_makfromstr (buf, len + ext_len, 0); + result = scm_mem2string (buf, len + ext_len); goto end; } } diff --git a/libguile/net_db.c b/libguile/net_db.c index 4f5e64ed8..66e327a85 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -184,8 +184,7 @@ SCM_DEFINE (scm_gethost, "gethost", 0, 1, 0, if (!entry) scm_resolv_error (FUNC_NAME, host); - ve[0] = scm_makfromstr (entry->h_name, - (size_t) strlen (entry->h_name), 0); + ve[0] = scm_mem2string (entry->h_name, strlen (entry->h_name)); ve[1] = scm_makfromstrs (-1, entry->h_aliases); ve[2] = SCM_MAKINUM (entry->h_addrtype + 0L); ve[3] = SCM_MAKINUM (entry->h_length + 0L); @@ -257,7 +256,7 @@ SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0, } if (!entry) SCM_SYSERROR_MSG ("no such network ~A", SCM_LIST1 (net), errno); - ve[0] = scm_makfromstr (entry->n_name, (size_t) strlen (entry->n_name), 0); + ve[0] = scm_mem2string (entry->n_name, strlen (entry->n_name)); ve[1] = scm_makfromstrs (-1, entry->n_aliases); ve[2] = SCM_MAKINUM (entry->n_addrtype + 0L); ve[3] = scm_ulong2num (entry->n_net + 0L); @@ -307,7 +306,7 @@ SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0, } if (!entry) SCM_SYSERROR_MSG ("no such protocol ~A", SCM_LIST1 (protocol), errno); - ve[0] = scm_makfromstr (entry->p_name, (size_t) strlen (entry->p_name), 0); + ve[0] = scm_mem2string (entry->p_name, strlen (entry->p_name)); ve[1] = scm_makfromstrs (-1, entry->p_aliases); ve[2] = SCM_MAKINUM (entry->p_proto + 0L); return ans; @@ -323,10 +322,10 @@ scm_return_entry (struct servent *entry) ans = scm_c_make_vector (4, SCM_UNSPECIFIED); ve = SCM_VELTS (ans); - ve[0] = scm_makfromstr (entry->s_name, (size_t) strlen (entry->s_name), 0); + ve[0] = scm_mem2string (entry->s_name, strlen (entry->s_name)); ve[1] = scm_makfromstrs (-1, entry->s_aliases); ve[2] = SCM_MAKINUM (ntohs (entry->s_port) + 0L); - ve[3] = scm_makfromstr (entry->s_proto, (size_t) strlen (entry->s_proto), 0); + ve[3] = scm_mem2string (entry->s_proto, strlen (entry->s_proto)); return ans; } @@ -386,7 +385,7 @@ SCM_DEFINE (scm_sethost, "sethost", 0, 1, 0, if (SCM_UNBNDP (stayopen)) endhostent (); else - sethostent (SCM_NFALSEP (stayopen)); + sethostent (!SCM_FALSEP (stayopen)); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -402,7 +401,7 @@ SCM_DEFINE (scm_setnet, "setnet", 0, 1, 0, if (SCM_UNBNDP (stayopen)) endnetent (); else - setnetent (SCM_NFALSEP (stayopen)); + setnetent (!SCM_FALSEP (stayopen)); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -418,7 +417,7 @@ SCM_DEFINE (scm_setproto, "setproto", 0, 1, 0, if (SCM_UNBNDP (stayopen)) endprotoent (); else - setprotoent (SCM_NFALSEP (stayopen)); + setprotoent (!SCM_FALSEP (stayopen)); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -434,7 +433,7 @@ SCM_DEFINE (scm_setserv, "setserv", 0, 1, 0, if (SCM_UNBNDP (stayopen)) endservent (); else - setservent (SCM_NFALSEP (stayopen)); + setservent (!SCM_FALSEP (stayopen)); return SCM_UNSPECIFIED; } #undef FUNC_NAME diff --git a/libguile/numbers.c b/libguile/numbers.c index b1e139d01..2c7ebf447 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -2188,12 +2188,12 @@ SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0, if (SCM_INUMP (n)) { char num_buf [SCM_INTBUFLEN]; size_t length = scm_iint2str (SCM_INUM (n), base, num_buf); - return scm_makfromstr (num_buf, length, 0); + return scm_mem2string (num_buf, length); } else if (SCM_BIGP (n)) { return big2str (n, (unsigned int) base); } else if (SCM_INEXACTP (n)) { char num_buf [FLOBUFLEN]; - return scm_makfromstr (num_buf, iflo2str (n, num_buf), 0); + return scm_mem2string (num_buf, iflo2str (n, num_buf)); } else { SCM_WRONG_TYPE_ARG (1, n); } diff --git a/libguile/objects.c b/libguile/objects.c index 66401e194..07a46e752 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -491,7 +491,7 @@ SCM_DEFINE (scm_make_subclass_object, "make-subclass-object", 2, 0, 0, SCM_VALIDATE_STRING (2,layout); pl = SCM_PACK (SCM_STRUCT_DATA (class) [scm_vtable_index_layout]); /* Convert symbol->string */ - pl = scm_makfromstr (SCM_SYMBOL_CHARS (pl), SCM_SYMBOL_LENGTH (pl), 0); + pl = scm_mem2string (SCM_SYMBOL_CHARS (pl), SCM_SYMBOL_LENGTH (pl)); return scm_i_make_class_object (SCM_STRUCT_VTABLE (class), scm_string_append (SCM_LIST2 (pl, layout)), SCM_CLASS_FLAGS (class)); diff --git a/libguile/ports.c b/libguile/ports.c index 56c0b37fc..49902d7e2 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -627,7 +627,7 @@ SCM_DEFINE (scm_port_mode, "port-mode", 1, 0, 0, strcpy (modes, "w"); if (SCM_CELL_WORD_0 (port) & SCM_BUF0) strcat (modes, "0"); - return scm_makfromstr (modes, strlen (modes), 0); + return scm_mem2string (modes, strlen (modes)); } #undef FUNC_NAME @@ -664,7 +664,7 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0, rv = 0; scm_remove_from_port_table (port); SCM_CLR_PORT_OPEN_FLAG (port); - return SCM_NEGATE_BOOL (rv < 0); + return SCM_BOOL (rv >= 0); } #undef FUNC_NAME @@ -760,7 +760,7 @@ SCM_DEFINE (scm_close_all_ports_except, "close-all-ports-except", 0, 0, 1, int found = 0; SCM ports_ptr = ports; - while (SCM_NNULLP (ports_ptr)) + while (!SCM_NULLP (ports_ptr)) { SCM port = SCM_COERCE_OUTPORT (SCM_CAR (ports_ptr)); if (i == 0) @@ -791,9 +791,7 @@ SCM_DEFINE (scm_input_port_p, "input-port?", 1, 0, 0, "@code{port?}.") #define FUNC_NAME s_scm_input_port_p { - if (SCM_IMP (x)) - return SCM_BOOL_F; - return SCM_BOOL(SCM_INPUT_PORT_P (x)); + return SCM_BOOL (SCM_INPUT_PORT_P (x)); } #undef FUNC_NAME @@ -804,11 +802,8 @@ SCM_DEFINE (scm_output_port_p, "output-port?", 1, 0, 0, "@code{port?}.") #define FUNC_NAME s_scm_output_port_p { - if (SCM_IMP (x)) - return SCM_BOOL_F; - if (SCM_PORT_WITH_PS_P (x)) - x = SCM_PORT_WITH_PS_PORT (x); - return SCM_BOOL(SCM_OUTPUT_PORT_P (x)); + SCM_COERCE_OUTPORT (x); + return SCM_BOOL (SCM_OUTPUT_PORT_P (x)); } #undef FUNC_NAME @@ -830,7 +825,7 @@ SCM_DEFINE (scm_port_closed_p, "port-closed?", 1, 0, 0, #define FUNC_NAME s_scm_port_closed_p { SCM_VALIDATE_PORT (1,port); - return SCM_NEGATE_BOOL(SCM_OPPORTP (port)); + return SCM_BOOL (!SCM_OPPORTP (port)); } #undef FUNC_NAME diff --git a/libguile/read.c b/libguile/read.c index 5af8436c3..4dd745d67 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -380,7 +380,7 @@ tryagain_no_flush_ws: case '*': j = scm_read_token (c, tok_buf, port, 0); p = scm_istr2bve (SCM_STRING_CHARS (*tok_buf) + 1, (long) (j - 1)); - if (SCM_NFALSEP (p)) + if (!SCM_FALSEP (p)) return p; else goto unkshrp; @@ -398,7 +398,7 @@ tryagain_no_flush_ws: if (c >= '0' && c < '8') { p = scm_istr2int (SCM_STRING_CHARS (*tok_buf), (long) j, 8); - if (SCM_NFALSEP (p)) + if (!SCM_FALSEP (p)) return SCM_MAKE_CHAR (SCM_INUM (p)); } for (c = 0; c < scm_n_charnames; c++) @@ -418,7 +418,7 @@ tryagain_no_flush_ws: { SCM sharp = scm_get_hash_procedure (c); - if (SCM_NIMP (sharp)) + if (!SCM_FALSEP (sharp)) { int line = SCM_LINUM (port); int column = SCM_COL (port) - 2; @@ -484,11 +484,7 @@ tryagain_no_flush_ws: if (j == 0) return scm_nullstr; SCM_STRING_CHARS (*tok_buf)[j] = 0; - { - SCM str; - str = scm_makfromstr (SCM_STRING_CHARS (*tok_buf), j, 0); - return str; - } + return scm_mem2string (SCM_STRING_CHARS (*tok_buf), j); case'0':case '1':case '2':case '3':case '4': case '5':case '6':case '7':case '8':case '9': @@ -498,7 +494,7 @@ tryagain_no_flush_ws: num: j = scm_read_token (c, tok_buf, port, 0); p = scm_istring2number (SCM_STRING_CHARS (*tok_buf), (long) j, 10L); - if (SCM_NFALSEP (p)) + if (!SCM_FALSEP (p)) return p; if (c == '#') { @@ -749,9 +745,10 @@ SCM_DEFINE (scm_read_hash_extend, "read-hash-extend", 2, 0, 0, SCM this; SCM prev; - SCM_VALIDATE_CHAR (1,chr); - SCM_ASSERT (SCM_FALSEP (proc) || SCM_NIMP(proc), proc, SCM_ARG2, - FUNC_NAME); + SCM_VALIDATE_CHAR (1, chr); + SCM_ASSERT (SCM_FALSEP (proc) + || SCM_EQ_P (scm_procedure_p (proc), SCM_BOOL_T), + proc, SCM_ARG2, FUNC_NAME); /* Check if chr is already in the alist. */ this = *scm_read_hash_procedures; @@ -761,7 +758,7 @@ SCM_DEFINE (scm_read_hash_extend, "read-hash-extend", 2, 0, 0, if (SCM_NULLP (this)) { /* not found, so add it to the beginning. */ - if (SCM_NFALSEP (proc)) + if (!SCM_FALSEP (proc)) { *scm_read_hash_procedures = scm_cons (scm_cons (chr, proc), *scm_read_hash_procedures); diff --git a/libguile/simpos.c b/libguile/simpos.c index cfc1c9e41..882088b40 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998, 2000, 2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001 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 @@ -110,7 +110,7 @@ SCM_DEFINE (scm_getenv, "getenv", 1, 0, 0, SCM_VALIDATE_STRING (1, nam); SCM_STRING_COERCE_0TERMINATION_X (nam); val = getenv (SCM_STRING_CHARS (nam)); - return (val) ? scm_makfromstr(val, (size_t)strlen(val), 0) : SCM_BOOL_F; + return val ? scm_mem2string (val, strlen (val)) : SCM_BOOL_F; } #undef FUNC_NAME diff --git a/libguile/socket.c b/libguile/socket.c index 685d93277..1eacf9fe8 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -191,7 +191,7 @@ SCM_DEFINE (scm_inet_ntoa, "inet-ntoa", 1, 0, 0, SCM answer; addr.s_addr = htonl (SCM_NUM2ULONG (1, inetid)); s = inet_ntoa (addr); - answer = scm_makfromstr (s, strlen (s), 0); + answer = scm_mem2string (s, strlen (s)); return answer; } #undef FUNC_NAME @@ -960,8 +960,7 @@ scm_addr_vector (const struct sockaddr *address, const char *proc) result = scm_c_make_vector (2, SCM_UNSPECIFIED); ve = SCM_VELTS (result); ve[0] = scm_ulong2num ((unsigned long) fam); - ve[1] = scm_makfromstr (nad->sun_path, - (size_t) strlen (nad->sun_path), 0); + ve[1] = scm_mem2string (nad->sun_path, strlen (nad->sun_path)); } break; #endif diff --git a/libguile/stime.c b/libguile/stime.c index f99656da4..5db51a547 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -607,7 +607,7 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, SCM *velts = SCM_VELTS (stime); int have_zone = 0; - if (SCM_NFALSEP (velts[10]) && *SCM_STRING_CHARS (velts[10]) != 0) + if (!SCM_FALSEP (velts[10]) && *SCM_STRING_CHARS (velts[10]) != 0) { /* it's not required that the TZ setting be correct, just that it has the right name. so try something like TZ=EST0. @@ -647,7 +647,7 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, #endif } - result = scm_makfromstr (tbuf+1, len-1, 0); + result = scm_mem2string (tbuf + 1, len - 1); scm_must_free (tbuf); scm_must_free(myfmt); return result; diff --git a/libguile/strings.c b/libguile/strings.c index a60c03ac1..b37309b14 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -105,7 +105,7 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1, { unsigned char *data = SCM_STRING_UCHARS (result); - while (SCM_NNULLP (chrs)) + while (!SCM_NULLP (chrs)) { SCM elt = SCM_CAR (chrs); @@ -153,7 +153,7 @@ scm_makfromstrs (int argc, char **argv) if (0 > i) for (i = 0; argv[i]; i++); while (i--) - lst = scm_cons (scm_makfromstr (argv[i], (size_t) strlen (argv[i]), 0), lst); + lst = scm_cons (scm_mem2string (argv[i], strlen (argv[i])), lst); return lst; } @@ -191,8 +191,21 @@ scm_take0str (char *s) return scm_take_str (s, strlen (s)); } +#if (SCM_DEBUG_DEPRECATED == 0) + SCM scm_makfromstr (const char *src, size_t len, int dummy SCM_UNUSED) +{ + scm_c_issue_deprecation_warning ("`scm_makfromstr' is deprecated. " + "Use `scm_mem2string' instead."); + + return scm_mem2string (src, len); +} + +#endif + +SCM +scm_mem2string (const char *src, size_t len) { SCM s = scm_allocate_string (len); char *dst = SCM_STRING_CHARS (s); @@ -206,7 +219,7 @@ SCM scm_makfrom0str (const char *src) { if (!src) return SCM_BOOL_F; - return scm_makfromstr (src, (size_t) strlen (src), 0); + return scm_mem2string (src, strlen (src)); } @@ -332,6 +345,7 @@ SCM_DEFINE (scm_substring, "substring", 2, 1, 0, { long int from; long int to; + SCM substr; SCM_VALIDATE_STRING (1, str); SCM_VALIDATE_INUM (2, start); @@ -342,7 +356,9 @@ SCM_DEFINE (scm_substring, "substring", 2, 1, 0, to = SCM_INUM (end); SCM_ASSERT_RANGE (3, end, from <= to && to <= SCM_STRING_LENGTH (str)); - return scm_makfromstr (&SCM_STRING_CHARS (str)[from], (size_t) (to - from), 0); + substr = scm_mem2string (&SCM_STRING_CHARS (str)[from], to - from); + scm_remember_upto_here_1 (str); + return substr; } #undef FUNC_NAME @@ -366,7 +382,7 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, } res = scm_allocate_string (i); data = SCM_STRING_UCHARS (res); - for (l = args;SCM_NIMP (l);l = SCM_CDR (l)) { + for (l = args; !SCM_NULLP (l);l = SCM_CDR (l)) { s = SCM_CAR (l); for (i = 0;ilist", 1, 0, 0, static SCM string_copy (SCM str) { - return scm_makfromstr (SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str), 0); + const char* chars = SCM_STRING_CHARS (str); + size_t length = SCM_STRING_LENGTH (str); + SCM new_string = scm_mem2string (chars, length); + scm_remember_upto_here_1 (str); + return new_string; } @@ -487,7 +491,7 @@ string_capitalize_x (SCM str) len = SCM_STRING_LENGTH(str); sz = SCM_STRING_CHARS (str); for(i=0; i= 0) { - res = scm_cons (scm_makfromstr (p + idx, last_idx - idx, 0), res); + res = scm_cons (scm_mem2string (p + idx, last_idx - idx), res); idx--; } } + scm_remember_upto_here_1 (str); return res; } #undef FUNC_NAME diff --git a/libguile/strports.c b/libguile/strports.c index ef4a15838..2ce941b76 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -305,10 +305,14 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) SCM scm_strport_to_string (SCM port) { scm_t_port *pt = SCM_PTAB_ENTRY (port); + SCM str; if (pt->rw_active == SCM_PORT_WRITE) st_flush (port); - return scm_makfromstr ((char *) pt->read_buf, pt->read_buf_size, 0); + + str = scm_mem2string ((char *) pt->read_buf, pt->read_buf_size); + scm_remember_upto_here_1 (port); + return str; } SCM_DEFINE (scm_object_to_string, "object->string", 1, 1, 0, diff --git a/libguile/symbols.c b/libguile/symbols.c index 448c9d85f..7ce74a20b 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -185,8 +185,11 @@ SCM_DEFINE (scm_symbol_to_string, "symbol->string", 1, 0, 0, "@end lisp") #define FUNC_NAME s_scm_symbol_to_string { + SCM str; SCM_VALIDATE_SYMBOL (1, s); - return scm_makfromstr (SCM_SYMBOL_CHARS (s), SCM_SYMBOL_LENGTH (s), 0); + str = scm_mem2string (SCM_SYMBOL_CHARS (s), SCM_SYMBOL_LENGTH (s)); + scm_remember_upto_here_1 (s); + return str; } #undef FUNC_NAME diff --git a/libguile/validate.h b/libguile/validate.h index 5f152138c..51a9708cf 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -1,4 +1,4 @@ -/* $Id: validate.h,v 1.33 2001-05-26 20:51:22 cmm Exp $ */ +/* $Id: validate.h,v 1.34 2001-06-26 10:59:34 dirk Exp $ */ /* Copyright (C) 1999,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify @@ -180,9 +180,11 @@ SCM_VALIDATE_INUM_DEF_COPY (pos_start, start, 0, c_start);\ SCM_VALIDATE_INUM_DEF_COPY (pos_end, end, SCM_STRING_LENGTH (str), c_end);\ SCM_ASSERT_RANGE (pos_start, start,\ - 0 <= c_start && c_start <= SCM_STRING_LENGTH (str));\ + 0 <= c_start \ + && (size_t) c_start <= SCM_STRING_LENGTH (str));\ SCM_ASSERT_RANGE (pos_end, end,\ - c_start <= c_end && c_end <= SCM_STRING_LENGTH (str));\ + c_start <= c_end \ + && (size_t) c_end <= SCM_STRING_LENGTH (str));\ } while (0) #define SCM_VALIDATE_REAL(pos, z) SCM_MAKE_VALIDATE (pos, z, REALP) diff --git a/libguile/vports.c b/libguile/vports.c index 9d7fbe409..33ae23520 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,1999, 2000, 2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001 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 @@ -101,7 +101,7 @@ sf_write (SCM port, const void *data, size_t size) SCM p = SCM_PACK (SCM_STREAM (port)); scm_apply (SCM_VELTS (p)[1], - scm_cons (scm_makfromstr ((char *) data, size, 0), SCM_EOL), + scm_cons (scm_mem2string ((char *) data, size), SCM_EOL), SCM_EOL); } diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 77d97f8bf..05c1c1998 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,13 @@ +2001-06-26 Dirk Herrmann + + * srfi-13.c (scm_string_copyS, scm_string_take, scm_string_drop, + scm_string_take_right, scm_string_drop_right, scm_string_trim, + scm_string_trim_right, scm_string_trim_both, scm_string_tokenize): + Use scm_mem2string instead of scm_makfromstr. + + (scm_reverse_list_to_string, string_titlecase_x): Prefer + !SCM_ over SCM_N. + 2001-06-25 Marius Vollmer * srfi-8.scm: Use `re-export-syntax' to correctly re-export diff --git a/srfi/srfi-13.c b/srfi/srfi-13.c index 88584caaa..af34b03e2 100644 --- a/srfi/srfi-13.c +++ b/srfi/srfi-13.c @@ -1,6 +1,6 @@ /* srfi-13.c --- SRFI-13 procedures for Guile * - * Copyright (C) 2001 Free Software Foundation, Inc. + * Copyright (C) 2001 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 @@ -189,7 +189,7 @@ SCM_DEFINE (scm_reverse_list_to_string, "reverse-list->string", 1, 0, 0, { unsigned char *data = SCM_STRING_UCHARS (result) + i; - while (SCM_NNULLP (chrs)) + while (!SCM_NULLP (chrs)) { SCM elt = SCM_CAR (chrs); @@ -379,7 +379,7 @@ SCM_DEFINE (scm_string_copyS, "string-copy", 1, 2, 0, SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, 2, start, cstart, 3, end, cend); - return scm_makfromstr (cstr + cstart, cend - cstart, 0); + return scm_mem2string (cstr + cstart, cend - cstart); } #undef FUNC_NAME @@ -450,7 +450,7 @@ SCM_DEFINE (scm_string_take, "string-take", 2, 0, 0, SCM_VALIDATE_INUM_COPY (2, n, cn); SCM_ASSERT_RANGE (2, n, cn >= 0 && cn <= SCM_STRING_LENGTH (s)); - return scm_makfromstr (cstr, cn, 0); + return scm_mem2string (cstr, cn); } #undef FUNC_NAME @@ -467,7 +467,7 @@ SCM_DEFINE (scm_string_drop, "string-drop", 2, 0, 0, SCM_VALIDATE_INUM_COPY (2, n, cn); SCM_ASSERT_RANGE (2, n, cn >= 0 && cn <= SCM_STRING_LENGTH (s)); - return scm_makfromstr (cstr + cn, SCM_STRING_LENGTH (s) - cn, 0); + return scm_mem2string (cstr + cn, SCM_STRING_LENGTH (s) - cn); } #undef FUNC_NAME @@ -484,7 +484,7 @@ SCM_DEFINE (scm_string_take_right, "string-take-right", 2, 0, 0, SCM_VALIDATE_INUM_COPY (2, n, cn); SCM_ASSERT_RANGE (2, n, cn >= 0 && cn <= SCM_STRING_LENGTH (s)); - return scm_makfromstr (cstr + SCM_STRING_LENGTH (s) - cn, cn, 0); + return scm_mem2string (cstr + SCM_STRING_LENGTH (s) - cn, cn); } #undef FUNC_NAME @@ -501,7 +501,7 @@ SCM_DEFINE (scm_string_drop_right, "string-drop-right", 2, 0, 0, SCM_VALIDATE_INUM_COPY (2, n, cn); SCM_ASSERT_RANGE (2, n, cn >= 0 && cn <= SCM_STRING_LENGTH (s)); - return scm_makfromstr (cstr, SCM_STRING_LENGTH (s) - cn, 0); + return scm_mem2string (cstr, SCM_STRING_LENGTH (s) - cn); } #undef FUNC_NAME @@ -657,7 +657,7 @@ SCM_DEFINE (scm_string_trim, "string-trim", 1, 3, 0, cstart++; } } - return scm_makfromstr (cstr + cstart, cend - cstart, 0); + return scm_mem2string (cstr + cstart, cend - cstart); } #undef FUNC_NAME @@ -733,7 +733,7 @@ SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1, 3, 0, cend--; } } - return scm_makfromstr (cstr + cstart, cend - cstart, 0); + return scm_mem2string (cstr + cstart, cend - cstart); } #undef FUNC_NAME @@ -837,7 +837,7 @@ SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 0, cend--; } } - return scm_makfromstr (cstr + cstart, cend - cstart, 0); + return scm_mem2string (cstr + cstart, cend - cstart); } #undef FUNC_NAME @@ -2121,7 +2121,7 @@ string_titlecase_x (SCM str, int start, int end) sz = SCM_STRING_CHARS (str); for(i = start; i < end; i++) { - if(SCM_NFALSEP(scm_char_alphabetic_p(SCM_MAKE_CHAR(sz[i])))) + if (!SCM_FALSEP (scm_char_alphabetic_p (SCM_MAKE_CHAR (sz[i])))) { if (!in_word) { @@ -2826,8 +2826,7 @@ SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0, break; cend--; } - result = scm_cons (scm_makfromstr (cstr + cend, idx - cend, - 0), result); + result = scm_cons (scm_mem2string (cstr + cend, idx - cend), result); } } else if (SCM_CHARSETP (token_char)) @@ -2851,8 +2850,7 @@ SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0, break; cend--; } - result = scm_cons (scm_makfromstr (cstr + cend, idx - cend, - 0), result); + result = scm_cons (scm_mem2string (cstr + cend, idx - cend), result); } } else @@ -2880,8 +2878,7 @@ SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0, break; cend--; } - result = scm_cons (scm_makfromstr (cstr + cend, idx - cend, - 0), result); + result = scm_cons (scm_mem2string (cstr + cend, idx - cend), result); } } return result; From fdc2839563bd8c821221a4869f27255ae77f757b Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Tue, 26 Jun 2001 15:46:40 +0000 Subject: [PATCH 1370/2047] * eval.c (scm_call_0, scm_call_1, scm_call_2, scm_call_3, scm_apply_0, scm_apply_1, scm_apply_2, scm_apply_3): New functions. --- libguile/ChangeLog | 29 +++++++++++++++++++ libguile/async.c | 2 +- libguile/coop-threads.c | 6 ++-- libguile/debug.c | 2 +- libguile/dynwind.c | 10 +++---- libguile/environments.c | 2 +- libguile/eval.c | 64 ++++++++++++++++++++++++++++++++++++++--- libguile/eval.h | 8 ++++++ libguile/fluids.c | 2 +- libguile/goops.c | 16 ++++------- libguile/hashtab.c | 15 ++++------ libguile/hooks.c | 2 +- libguile/load.c | 2 +- libguile/modules.c | 43 +++++++++++---------------- libguile/ports.c | 2 +- libguile/print.c | 2 +- libguile/properties.c | 2 +- libguile/ramap.c | 19 ++++++------ libguile/read.c | 4 +-- libguile/scmsigs.c | 5 ++-- libguile/sort.c | 6 ++-- libguile/strports.c | 6 ++-- libguile/throw.c | 6 ++-- libguile/unif.c | 4 +-- libguile/vports.c | 13 ++++----- 25 files changed, 167 insertions(+), 105 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index ddffe6faf..cdf0344f2 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,32 @@ +2001-06-27 Keisuke Nishida + + * eval.c (scm_call_0, scm_call_1, scm_call_2, scm_call_3, + scm_apply_0, scm_apply_1, scm_apply_2, scm_apply_3): New functions. + * eval.h (scm_call_0, scm_call_1, scm_call_2, scm_call_3, + scm_apply_0, scm_apply_1, scm_apply_2, scm_apply_3): Declared. + * async.c (scm_run_asyncs), coop-threads.c (scheme_body_bootstrip, + scheme_handler_bootstrip), debug.c (with_traps_inner), dynwind.c + (scm_dynamic_wind, scm_dowinds), environments.c + (import_environment_conflict), eval.c (scm_macroexp, scm_force, + scm_primitive_eval_x, scm_primitive_eval), fluids.c (apply_thunk), + goops.c (GETVAR, purgatory, make_class_from_template, + scm_ensure_accessor), hashtab.c (scm_ihashx, scm_sloppy_assx, + scm_delx_x, fold_proc), hooks.c (scm_c_run_hook), load.c + (scm_primitive_load), modules.c (scm_resolve_module, + scm_c_define_module, scm_c_use_module, scm_c_export, + module_variable, scm_eval_closure_lookup, scm_sym2var, + scm_make_module, scm_ensure_user_module, scm_load_scheme_module), + ports.c (scm_port_for_each), print.c (scm_printer_apply), + properties.c (scm_primitive_property_ref), ramap.c (ramap, + ramap_cxr, rafe, scm_array_index_map_x, read.c (scm_lreadr), + scmsigs.c (sys_deliver_signals), sort.c (applyless), strports.c + (scm_object_to_string, scm_call_with_output_string, + scm_call_with_input_string), throw.c (scm_body_thunk, + scm_handle_by_proc, hbpca_body), unif.c (scm_make_shared_array, + scm_make_shared_array), vports.c (sf_flush, sf_write, + sf_fill_input, sf_close): Use one of the above functions. + * goops.c, hashtab.c, scmsigs.c, sort.c: #include "libguile/root.h". + 2001-06-26 Dirk Herrmann * filesys.c (scm_close), ports.c (scm_close_port, diff --git a/libguile/async.c b/libguile/async.c index d93ce7d1a..e5946393c 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -363,7 +363,7 @@ SCM_DEFINE (scm_run_asyncs, "run-asyncs", 1, 0, 0, if (ASYNC_GOT_IT (a)) { SET_ASYNC_GOT_IT (a, 0); - scm_apply (ASYNC_THUNK (a), SCM_EOL, SCM_EOL); + scm_call_0 (ASYNC_THUNK (a)); } scm_mask_ints = 0; list_of_a = SCM_CDR (list_of_a); diff --git a/libguile/coop-threads.c b/libguile/coop-threads.c index 0c9feb287..fda74aa6d 100644 --- a/libguile/coop-threads.c +++ b/libguile/coop-threads.c @@ -180,21 +180,19 @@ typedef struct scheme_launch_data { SCM handler; } scheme_launch_data; -extern SCM scm_apply (SCM, SCM, SCM); - static SCM scheme_body_bootstrip (scheme_launch_data* data) { /* First save the new root continuation */ data->rootcont = scm_root->rootcont; - return scm_apply (data->body, SCM_EOL, SCM_EOL); + return scm_call_0 (data->body); } static SCM scheme_handler_bootstrip (scheme_launch_data* data, SCM tag, SCM throw_args) { scm_root->rootcont = data->rootcont; - return scm_apply (data->handler, scm_cons (tag, throw_args), SCM_EOL); + return scm_apply_1 (data->handler, tag, throw_args); } static void diff --git a/libguile/debug.c b/libguile/debug.c index 29d259d60..c4c738009 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -120,7 +120,7 @@ static SCM with_traps_inner (void *data) { SCM thunk = SCM_PACK (data); - return scm_apply (thunk, SCM_EOL, SCM_EOL); + return scm_call_0 (thunk); } SCM_DEFINE (scm_with_traps, "with-traps", 1, 0, 0, diff --git a/libguile/dynwind.c b/libguile/dynwind.c index f0777ab92..9c6ab1069 100644 --- a/libguile/dynwind.c +++ b/libguile/dynwind.c @@ -125,11 +125,11 @@ SCM_DEFINE (scm_dynamic_wind, "dynamic-wind", 3, 0, 0, SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (out_guard)), out_guard, SCM_ARG3, FUNC_NAME); - scm_apply (in_guard, SCM_EOL, SCM_EOL); + scm_call_0 (in_guard); scm_dynwinds = scm_acons (in_guard, out_guard, scm_dynwinds); - ans = scm_apply (thunk, SCM_EOL, SCM_EOL); + ans = scm_call_0 (thunk); scm_dynwinds = SCM_CDR (scm_dynwinds); - scm_apply (out_guard, SCM_EOL, SCM_EOL); + scm_call_0 (out_guard); return ans; } #undef FUNC_NAME @@ -231,7 +231,7 @@ scm_dowinds (SCM to, long delta) else if (SCM_GUARDSP (wind_key)) SCM_BEFORE_GUARD (wind_key) (SCM_GUARD_DATA (wind_key)); else if (SCM_TYP3 (wind_key) == scm_tc3_closure) - scm_apply (wind_key, SCM_EOL, SCM_EOL); + scm_call_0 (wind_key); } } scm_dynwinds = to; @@ -263,7 +263,7 @@ scm_dowinds (SCM to, long delta) else if (SCM_GUARDSP (wind_key)) SCM_AFTER_GUARD (wind_key) (SCM_GUARD_DATA (wind_key)); else if (SCM_TYP3 (wind_key) == scm_tc3_closure) - scm_apply (from, SCM_EOL, SCM_EOL); + scm_call_0 (from); } } delta--; diff --git a/libguile/environments.c b/libguile/environments.c index ea6230ba9..58a4cff8b 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -1613,7 +1613,7 @@ import_environment_conflict (SCM env, SCM sym, SCM imports) SCM conflict_proc = IMPORT_ENVIRONMENT (env)->conflict_proc; SCM args = scm_cons2 (env, sym, scm_cons (imports, SCM_EOL)); - return scm_apply (conflict_proc, args, SCM_EOL); + return scm_apply_0 (conflict_proc, args); } diff --git a/libguile/eval.c b/libguile/eval.c index 53177f6ae..5d07e2434 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1246,7 +1246,7 @@ scm_macroexp (SCM x, SCM env) return x; SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */ - res = scm_apply (SCM_MACRO_CODE (proc), x, scm_cons (env, scm_listofnull)); + res = scm_call_2 (SCM_MACRO_CODE (proc), x, env); if (scm_ilength (res) <= 0) res = scm_cons2 (SCM_IM_BEGIN, res, SCM_EOL); @@ -3245,6 +3245,62 @@ ret: #ifndef DEVAL + +/* Simple procedure calls + */ + +SCM +scm_call_0 (SCM proc) +{ + return scm_apply (proc, SCM_EOL, SCM_EOL); +} + +SCM +scm_call_1 (SCM proc, SCM arg1) +{ + return scm_apply (proc, arg1, scm_listofnull); +} + +SCM +scm_call_2 (SCM proc, SCM arg1, SCM arg2) +{ + return scm_apply (proc, arg1, scm_cons (arg2, scm_listofnull)); +} + +SCM +scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3) +{ + return scm_apply (proc, arg1, scm_cons2 (arg2, arg3, scm_listofnull)); +} + +/* Simple procedure applies + */ + +SCM +scm_apply_0 (SCM proc, SCM args) +{ + return scm_apply (proc, args, SCM_EOL); +} + +SCM +scm_apply_1 (SCM proc, SCM arg1, SCM args) +{ + return scm_apply (proc, scm_cons (arg1, args), SCM_EOL); +} + +SCM +scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args) +{ + return scm_apply (proc, scm_cons2 (arg1, arg2, args), SCM_EOL); +} + +SCM +scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args) +{ + return scm_apply (proc, scm_cons (arg1, scm_cons2 (arg2, arg3, args)), + SCM_EOL); +} + /* This code processes the arguments to apply: (apply PROC ARG1 ... ARGS) @@ -3812,7 +3868,7 @@ SCM_DEFINE (scm_force, "force", 1, 0, 0, SCM_VALIDATE_SMOB (1, x, promise); if (!((1L << 16) & SCM_CELL_WORD_0 (x))) { - SCM ans = scm_apply (SCM_CELL_OBJECT_1 (x), SCM_EOL, SCM_EOL); + SCM ans = scm_call_0 (SCM_CELL_OBJECT_1 (x)); if (!((1L << 16) & SCM_CELL_WORD_0 (x))) { SCM_DEFER_INTS; @@ -3948,7 +4004,7 @@ scm_primitive_eval_x (SCM exp) SCM env; SCM transformer = scm_current_module_transformer (); if (SCM_NIMP (transformer)) - exp = scm_apply (transformer, exp, scm_listofnull); + exp = scm_call_1 (transformer, exp); env = scm_top_level_env (scm_current_module_lookup_closure ()); return scm_i_eval_x (exp, env); } @@ -3962,7 +4018,7 @@ SCM_DEFINE (scm_primitive_eval, "primitive-eval", 1, 0, 0, SCM env; SCM transformer = scm_current_module_transformer (); if (SCM_NIMP (transformer)) - exp = scm_apply (transformer, exp, scm_listofnull); + exp = scm_call_1 (transformer, exp); env = scm_top_level_env (scm_current_module_lookup_closure ()); return scm_i_eval (exp, env); } diff --git a/libguile/eval.h b/libguile/eval.h index 133d8b4c2..35de8a6b2 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -231,6 +231,14 @@ extern SCM scm_m_at_call_with_values (SCM xorig, SCM env); extern int scm_badargsp (SCM formals, SCM args); extern SCM scm_ceval (SCM x, SCM env); extern SCM scm_deval (SCM x, SCM env); +extern SCM scm_call_0 (SCM proc); +extern SCM scm_call_1 (SCM proc, SCM arg1); +extern SCM scm_call_2 (SCM proc, SCM arg1, SCM arg2); +extern SCM scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3); +extern SCM scm_apply_0 (SCM proc, SCM args); +extern SCM scm_apply_1 (SCM proc, SCM arg1, SCM args); +extern SCM scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args); +extern SCM scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args); extern SCM scm_nconc2last (SCM lst); extern SCM scm_apply (SCM proc, SCM arg1, SCM args); extern SCM scm_dapply (SCM proc, SCM arg1, SCM args); diff --git a/libguile/fluids.c b/libguile/fluids.c index 9aba42bf5..206808ab1 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -213,7 +213,7 @@ scm_swap_fluids_reverse (SCM fluids, SCM vals) static SCM apply_thunk (void *thunk) { - return scm_apply (SCM_PACK (thunk), SCM_EOL, SCM_EOL); + return scm_call_0 (SCM_PACK (thunk)); } SCM_DEFINE (scm_with_fluids, "with-fluids*", 3, 0, 0, diff --git a/libguile/goops.c b/libguile/goops.c index 176cddec5..3ae186e75 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -63,6 +63,7 @@ #include "libguile/ports.h" #include "libguile/procprop.h" #include "libguile/random.h" +#include "libguile/root.h" #include "libguile/smob.h" #include "libguile/strings.h" #include "libguile/strports.h" @@ -79,9 +80,8 @@ scm_module_goops); } /* Temporary hack until we get the new module system */ /*fixme* Should optimize by keeping track of the variable object itself */ -#define GETVAR(v) (SCM_VARIABLE_REF (scm_apply (scm_goops_lookup_closure, \ - SCM_LIST2 ((v), SCM_BOOL_F), \ - SCM_EOL))) +#define GETVAR(v) (SCM_VARIABLE_REF (scm_call_2 (scm_goops_lookup_closure, \ + (v), SCM_BOOL_F))) /* Fixme: Should use already interned symbols */ #define CALL_GF1(name,a) (scm_apply (GETVAR (scm_str2symbol (name)), \ @@ -1513,7 +1513,7 @@ go_to_heaven (void *o) static SCM purgatory (void *args) { - return scm_apply (GETVAR (scm_str2symbol ("change-class")), (SCM) args, SCM_EOL); + return scm_apply_0 (GETVAR (scm_str2symbol ("change-class")), (SCM) args); } void @@ -2339,9 +2339,7 @@ make_class_from_template (char *template, char *type_name, SCM supers) /* Only define name if doesn't already exist. */ if (!SCM_GOOPS_UNBOUNDP (name) - && SCM_FALSEP (scm_apply (scm_goops_lookup_closure, - SCM_LIST2 (name, SCM_BOOL_F), - SCM_EOL))) + && SCM_FALSEP (scm_call_2 (scm_goops_lookup_closure, name, SCM_BOOL_F))) DEFVAR (name, class); return class; } @@ -2588,9 +2586,7 @@ scm_wrap_component (SCM class, SCM container, void *data) SCM scm_ensure_accessor (SCM name) { - SCM gf = scm_apply (SCM_TOP_LEVEL_LOOKUP_CLOSURE, - SCM_LIST2 (name, SCM_BOOL_F), - SCM_EOL); + SCM gf = scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE, name, SCM_BOOL_F); if (!SCM_IS_A_P (gf, scm_class_generic_with_setter)) { gf = scm_make (SCM_LIST3 (scm_class_generic, k_name, name)); diff --git a/libguile/hashtab.c b/libguile/hashtab.c index 442bfd644..fa2840bb8 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -48,6 +48,7 @@ #include "libguile/alist.h" #include "libguile/hash.h" #include "libguile/eval.h" +#include "libguile/root.h" #include "libguile/vectors.h" #include "libguile/validate.h" @@ -380,9 +381,7 @@ scm_ihashx (SCM obj, unsigned long n, scm_t_ihashx_closure *closure) { SCM answer; SCM_DEFER_INTS; - answer = scm_apply (closure->hash, - SCM_LIST2 (obj, scm_ulong2num ((unsigned long)n)), - SCM_EOL); + answer = scm_call_2 (closure->hash, obj, scm_ulong2num ((unsigned long) n)); SCM_ALLOW_INTS; return SCM_INUM (answer); } @@ -394,9 +393,7 @@ scm_sloppy_assx (SCM obj, SCM alist, scm_t_ihashx_closure *closure) { SCM answer; SCM_DEFER_INTS; - answer = scm_apply (closure->assoc, - SCM_LIST2 (obj, alist), - SCM_EOL); + answer = scm_call_2 (closure->assoc, obj, alist); SCM_ALLOW_INTS; return answer; } @@ -409,9 +406,7 @@ scm_delx_x (SCM obj, SCM alist, scm_t_ihashx_closure *closure) { SCM answer; SCM_DEFER_INTS; - answer = scm_apply (closure->delete, - SCM_LIST2 (obj, alist), - SCM_EOL); + answer = scm_call_2 (closure->delete, obj, alist); SCM_ALLOW_INTS; return answer; } @@ -519,7 +514,7 @@ scm_hashx_remove_x (SCM hash, SCM assoc, SCM delete, SCM table, SCM obj) static SCM fold_proc (void *proc, SCM key, SCM data, SCM value) { - return scm_apply (SCM_PACK (proc), SCM_LIST3 (key, data, value), SCM_EOL); + return scm_call_3 (SCM_PACK (proc), key, data, value); } SCM_DEFINE (scm_hash_fold, "hash-fold", 3, 0, 0, diff --git a/libguile/hooks.c b/libguile/hooks.c index f0713f5eb..120ef1287 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -307,7 +307,7 @@ scm_c_run_hook (SCM hook, SCM args) SCM procs = SCM_HOOK_PROCEDURES (hook); while (SCM_NIMP (procs)) { - scm_apply (SCM_CAR (procs), args, SCM_EOL); + scm_apply_0 (SCM_CAR (procs), args); procs = SCM_CDR (procs); } } diff --git a/libguile/load.c b/libguile/load.c index 3f6fff049..8cb726a04 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -119,7 +119,7 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0, SCM_EOL); if (! SCM_FALSEP (hook)) - scm_apply (hook, SCM_LIST1 (filename), SCM_EOL); + scm_call_1 (hook, filename); { /* scope */ SCM port, save_port; diff --git a/libguile/modules.c b/libguile/modules.c index 0e9fd0b4a..dd912cf2d 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -162,17 +162,15 @@ scm_c_resolve_module (const char *name) SCM scm_resolve_module (SCM name) { - return scm_apply (SCM_VARIABLE_REF (resolve_module_var), - SCM_LIST1 (name), SCM_EOL); + return scm_call_1 (SCM_VARIABLE_REF (resolve_module_var), name); } SCM scm_c_define_module (const char *name, void (*init)(void *), void *data) { - SCM module = scm_apply (SCM_VARIABLE_REF (process_define_module_var), - SCM_LIST1 (SCM_LIST1 (convert_module_name (name))), - SCM_EOL); + SCM module = scm_call_1 (SCM_VARIABLE_REF (process_define_module_var), + SCM_LIST1 (convert_module_name (name))); if (init) scm_c_call_with_current_module (module, (SCM (*)(void*))init, data); return module; @@ -181,9 +179,8 @@ scm_c_define_module (const char *name, void scm_c_use_module (const char *name) { - scm_apply (SCM_VARIABLE_REF (process_use_modules_var), - SCM_LIST1 (SCM_LIST1 (convert_module_name (name))), - SCM_EOL); + scm_call_1 (SCM_VARIABLE_REF (process_use_modules_var), + SCM_LIST1 (convert_module_name (name))); } static SCM module_export_x_var; @@ -203,10 +200,8 @@ scm_c_export (const char *name, ...) *tail = scm_cons (scm_str2symbol (n), SCM_EOL); tail = SCM_CDRLOC (*tail); } - scm_apply (SCM_VARIABLE_REF (module_export_x_var), - SCM_LIST2 (scm_current_module (), - names), - SCM_EOL); + scm_call_2 (SCM_VARIABLE_REF (module_export_x_var), + scm_current_module (), names); } /* Environments */ @@ -292,9 +287,7 @@ module_variable (SCM module, SCM sym) if (SCM_NFALSEP (binder)) /* 2. Custom binder */ { - b = scm_apply (binder, - SCM_LIST3 (module, sym, SCM_BOOL_F), - SCM_EOL); + b = scm_call_3 (binder, module, sym, SCM_BOOL_F); if (SCM_NFALSEP (b)) return b; } @@ -329,9 +322,8 @@ scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep) { if (SCM_EVAL_CLOSURE_INTERFACE_P (eclo)) return SCM_BOOL_F; - return scm_apply (SCM_VARIABLE_REF (module_make_local_var_x_var), - SCM_LIST2 (module, sym), - SCM_EOL); + return scm_call_2 (SCM_VARIABLE_REF (module_make_local_var_x_var), + module, sym); } else return module_variable (module, sym); @@ -423,7 +415,7 @@ scm_sym2var (SCM sym, SCM proc, SCM definep) var = scm_eval_closure_lookup (proc, sym, definep); } else - var = scm_apply (proc, sym, scm_cons (definep, scm_listofnull)); + var = scm_call_2 (proc, sym, definep); } else { @@ -686,10 +678,9 @@ scm_make_module (SCM name) scm_c_issue_deprecation_warning ("`scm_make_module' is deprecated. " "Use `scm_c_define_module instead."); - return scm_apply (SCM_VARIABLE_REF (make_modules_in_var), - SCM_LIST2 (scm_the_root_module (), - scm_module_full_name (name)), - SCM_EOL); + return scm_call_2 (SCM_VARIABLE_REF (make_modules_in_var), + scm_the_root_module (), + scm_module_full_name (name)); } SCM @@ -698,8 +689,7 @@ scm_ensure_user_module (SCM module) scm_c_issue_deprecation_warning ("`scm_ensure_user_module' is deprecated. " "Use `scm_c_define_module instead."); - scm_apply (SCM_VARIABLE_REF (beautify_user_module_x_var), - SCM_LIST1 (module), SCM_EOL); + scm_call_1 (SCM_VARIABLE_REF (beautify_user_module_x_var), module); return SCM_UNSPECIFIED; } @@ -709,8 +699,7 @@ scm_load_scheme_module (SCM name) scm_c_issue_deprecation_warning ("`scm_load_scheme_module' is deprecated. " "Use `scm_c_resolve_module instead."); - return scm_apply (SCM_VARIABLE_REF (try_module_autoload_var), - SCM_LIST1 (name), SCM_EOL); + return scm_call_1 (SCM_VARIABLE_REF (try_module_autoload_var), name); } #endif diff --git a/libguile/ports.c b/libguile/ports.c index 49902d7e2..0dddda802 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -732,7 +732,7 @@ SCM_DEFINE (scm_port_for_each, "port-for-each", 1, 0, 0, while (ports != SCM_EOL) { - scm_apply (proc, scm_cons (SCM_CAR (ports), SCM_EOL), SCM_EOL); + scm_call_1 (proc, SCM_CAR (ports)); ports = SCM_CDR (ports); } diff --git a/libguile/print.c b/libguile/print.c index 6583b3f42..9159f996b 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1068,7 +1068,7 @@ scm_printer_apply (SCM proc, SCM exp, SCM port, scm_print_state *pstate) SCM pair = scm_cons (port, pstate->handle); SCM_NEWSMOB (pwps, scm_tc16_port_with_ps, SCM_UNPACK (pair)); pstate->revealed = 1; - return scm_apply (proc, exp, scm_cons (pwps, scm_listofnull)); + return scm_call_2 (proc, exp, pwps); } SCM_DEFINE (scm_port_with_print_state, "port-with-print-state", 2, 0, 0, diff --git a/libguile/properties.c b/libguile/properties.c index 6d9d8031b..b95c5d3da 100644 --- a/libguile/properties.c +++ b/libguile/properties.c @@ -100,7 +100,7 @@ SCM_DEFINE (scm_primitive_property_ref, "primitive-property-ref", 2, 0, 0, return SCM_BOOL_F; else { - SCM val = scm_apply (SCM_CAR (prop), SCM_LIST2 (prop, obj), SCM_EOL); + SCM val = scm_call_2 (SCM_CAR (prop), prop, obj); if (SCM_FALSEP (h)) h = scm_hashq_create_handle_x (scm_properties_whash, obj, SCM_EOL); SCM_SETCDR (h, scm_acons (prop, val, SCM_CDR (h))); diff --git a/libguile/ramap.c b/libguile/ramap.c index 7d49cdbd9..e21d7b8b3 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -1241,7 +1241,7 @@ ramap (SCM ra0,SCM proc,SCM ras) ra0 = SCM_ARRAY_V (ra0); if (SCM_NULLP (ras)) for (; i <= n; i++) - scm_array_set_x (ra0, scm_apply (proc, SCM_EOL, SCM_EOL), SCM_MAKINUM (i * inc + base)); + scm_array_set_x (ra0, scm_call_0 (proc), SCM_MAKINUM (i * inc + base)); else { SCM ra1 = SCM_CAR (ras); @@ -1263,7 +1263,7 @@ ramap (SCM ra0,SCM proc,SCM ras) for (k = SCM_INUM (scm_uniform_vector_length (ras)); k--;) args = scm_cons (scm_uniform_vector_ref (ve[k], SCM_MAKINUM (i)), args); args = scm_cons (scm_cvref (ra1, i1, SCM_UNDEFINED), args); - scm_array_set_x (ra0, scm_apply (proc, args, SCM_EOL), SCM_MAKINUM (i * inc + base)); + scm_array_set_x (ra0, scm_apply_0 (proc, args), SCM_MAKINUM (i * inc + base)); } } return 1; @@ -1285,7 +1285,7 @@ ramap_cxr (SCM ra0,SCM proc,SCM ras) default: gencase: for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, scm_apply (proc, RVREF (ra1, i1, e1), scm_listofnull), SCM_MAKINUM (i0)); + scm_array_set_x (ra0, scm_call_1 (proc, RVREF (ra1, i1, e1)), SCM_MAKINUM (i0)); break; case scm_tc7_fvect: { @@ -1635,7 +1635,7 @@ rafe (SCM ra0,SCM proc,SCM ras) ra0 = SCM_ARRAY_V (ra0); if (SCM_NULLP (ras)) for (; i <= n; i++, i0 += inc0) - scm_apply (proc, scm_cvref (ra0, i0, SCM_UNDEFINED), scm_listofnull); + scm_call_1 (proc, scm_cvref (ra0, i0, SCM_UNDEFINED)); else { SCM ra1 = SCM_CAR (ras); @@ -1657,7 +1657,7 @@ rafe (SCM ra0,SCM proc,SCM ras) for (k = SCM_INUM (scm_uniform_vector_length (ras)); k--;) args = scm_cons (scm_uniform_vector_ref (ve[k], SCM_MAKINUM (i)), args); args = scm_cons2 (scm_cvref (ra0, i0, SCM_UNDEFINED), scm_cvref (ra1, i1, SCM_UNDEFINED), args); - scm_apply (proc, args, SCM_EOL); + scm_apply_0 (proc, args); } } return 1; @@ -1710,7 +1710,7 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0, { SCM *ve = SCM_VELTS (ra); for (i = 0; i < SCM_VECTOR_LENGTH (ra); i++) - ve[i] = scm_apply (proc, SCM_MAKINUM (i), scm_listofnull); + ve[i] = scm_call_1 (proc, SCM_MAKINUM (i)); return SCM_UNSPECIFIED; } case scm_tc7_string: @@ -1728,7 +1728,7 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0, { unsigned long int length = SCM_INUM (scm_uniform_vector_length (ra)); for (i = 0; i < length; i++) - scm_array_set_x (ra, scm_apply (proc, SCM_MAKINUM (i), scm_listofnull), + scm_array_set_x (ra, scm_call_1 (proc, SCM_MAKINUM (i)), SCM_MAKINUM (i)); return SCM_UNSPECIFIED; } @@ -1740,8 +1740,7 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0, long *vinds = (long *) SCM_VELTS (inds); int j, k, kmax = SCM_ARRAY_NDIM (ra) - 1; if (kmax < 0) - return scm_array_set_x (ra, scm_apply(proc, SCM_EOL, SCM_EOL), - SCM_EOL); + return scm_array_set_x (ra, scm_call_0 (proc), SCM_EOL); for (k = 0; k <= kmax; k++) vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd; k = kmax; @@ -1756,7 +1755,7 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0, for (j = kmax + 1, args = SCM_EOL; j--;) args = scm_cons (SCM_MAKINUM (vinds[j]), args); scm_array_set_x (SCM_ARRAY_V (ra), - scm_apply (proc, args, SCM_EOL), + scm_apply_0 (proc, args), SCM_MAKINUM (i)); i += SCM_ARRAY_DIMS (ra)[k].inc; } diff --git a/libguile/read.c b/libguile/read.c index 4dd745d67..214118473 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -424,9 +424,7 @@ tryagain_no_flush_ws: int column = SCM_COL (port) - 2; SCM got; - got = scm_apply (sharp, - SCM_MAKE_CHAR (c), - scm_acons (port, SCM_EOL, SCM_EOL)); + got = scm_call_2 (sharp, SCM_MAKE_CHAR (c), port); if (SCM_EQ_P (got, SCM_UNSPECIFIED)) goto unkshrp; if (SCM_RECORD_POSITIONS_P) diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index c36c83d98..bdbf525e7 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -51,6 +51,7 @@ #include "libguile/async.h" #include "libguile/eval.h" +#include "libguile/root.h" #include "libguile/vectors.h" #include "libguile/validate.h" @@ -166,9 +167,7 @@ sys_deliver_signals (void) #ifndef HAVE_SIGACTION signal (i, take_signal); #endif - scm_apply (SCM_VELTS (*signal_handlers)[i], - SCM_LIST1 (SCM_MAKINUM (i)), - SCM_EOL); + scm_call_1 (SCM_VELTS (*signal_handlers)[i], SCM_MAKINUM (i)); } } return SCM_UNSPECIFIED; diff --git a/libguile/sort.c b/libguile/sort.c index 76867843a..f2edb5a17 100644 --- a/libguile/sort.c +++ b/libguile/sort.c @@ -86,6 +86,7 @@ char *alloca (); #include "libguile/ramap.h" #include "libguile/alist.h" #include "libguile/feature.h" +#include "libguile/root.h" #include "libguile/vectors.h" #include "libguile/validate.h" @@ -385,10 +386,7 @@ closureless (SCM code, const void *a, const void *b) static int applyless (SCM less, const void *a, const void *b) { - return SCM_NFALSEP (scm_apply (less, - scm_cons (*(SCM *) a, - scm_cons (*(SCM *) b, SCM_EOL)), - SCM_EOL)); + return SCM_NFALSEP (scm_call_2 (less, *(SCM *) a, *(SCM *) b)); } /* applyless */ static cmp_fun_t diff --git a/libguile/strports.c b/libguile/strports.c index 2ce941b76..f968c46ee 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -333,7 +333,7 @@ SCM_DEFINE (scm_object_to_string, "object->string", 1, 1, 0, if (SCM_UNBNDP (printer)) scm_write (obj, port); else - scm_apply (printer, SCM_LIST2 (obj, port), SCM_EOL); + scm_call_2 (printer, obj, port); return scm_strport_to_string (port); } @@ -362,7 +362,7 @@ SCM_DEFINE (scm_call_with_output_string, "call-with-output-string", 1, 0, 0, scm_make_string (SCM_INUM0, SCM_UNDEFINED), SCM_OPN | SCM_WRTNG, FUNC_NAME); - scm_apply (proc, p, scm_listofnull); + scm_call_1 (proc, p); return scm_strport_to_string (p); } @@ -376,7 +376,7 @@ SCM_DEFINE (scm_call_with_input_string, "call-with-input-string", 2, 0, 0, #define FUNC_NAME s_scm_call_with_input_string { SCM p = scm_mkstrport(SCM_INUM0, string, SCM_OPN | SCM_RDNG, FUNC_NAME); - return scm_apply (proc, p, scm_listofnull); + return scm_call_1 (proc, p); } #undef FUNC_NAME diff --git a/libguile/throw.c b/libguile/throw.c index 9d4f0aeca..62468437b 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -348,7 +348,7 @@ scm_body_thunk (void *body_data) { struct scm_body_thunk_data *c = (struct scm_body_thunk_data *) body_data; - return scm_apply (c->body_proc, SCM_EOL, SCM_EOL); + return scm_call_0 (c->body_proc); } @@ -367,7 +367,7 @@ scm_handle_by_proc (void *handler_data, SCM tag, SCM throw_args) { SCM *handler_proc_p = (SCM *) handler_data; - return scm_apply (*handler_proc_p, scm_cons (tag, throw_args), SCM_EOL); + return scm_apply_1 (*handler_proc_p, tag, throw_args); } /* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but @@ -383,7 +383,7 @@ static SCM hbpca_body (void *body_data) { struct hbpca_data *data = (struct hbpca_data *)body_data; - return scm_apply (data->proc, data->args, SCM_EOL); + return scm_apply_0 (data->proc, data->args); } SCM diff --git a/libguile/unif.c b/libguile/unif.c index 17aad0774..0e7319b7a 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -721,7 +721,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, return ra; } } - imap = scm_apply (mapfunc, scm_reverse (inds), SCM_EOL); + imap = scm_apply_0 (mapfunc, scm_reverse (inds)); if (SCM_ARRAYP (oldra)) i = (size_t) scm_aind (oldra, imap, FUNC_NAME); else @@ -743,7 +743,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, if (s[k].ubnd > s[k].lbnd) { SCM_SETCAR (indptr, SCM_MAKINUM (SCM_INUM (SCM_CAR (indptr)) + 1)); - imap = scm_apply (mapfunc, scm_reverse (inds), SCM_EOL); + imap = scm_apply_0 (mapfunc, scm_reverse (inds)); if (SCM_ARRAYP (oldra)) s[k].inc = scm_aind (oldra, imap, FUNC_NAME) - i; diff --git a/libguile/vports.c b/libguile/vports.c index 33ae23520..50c3b76fb 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -81,8 +81,7 @@ sf_flush (SCM port) if (pt->write_pos > pt->write_buf) { /* write the byte. */ - scm_apply (SCM_VELTS (stream)[0], SCM_MAKE_CHAR (*pt->write_buf), - scm_listofnull); + scm_call_1 (SCM_VELTS (stream)[0], SCM_MAKE_CHAR (*pt->write_buf)); pt->write_pos = pt->write_buf; /* flush the output. */ @@ -90,7 +89,7 @@ sf_flush (SCM port) SCM f = SCM_VELTS (stream)[2]; if (!SCM_FALSEP (f)) - scm_apply (f, SCM_EOL, SCM_EOL); + scm_call_0 (f); } } } @@ -100,9 +99,7 @@ sf_write (SCM port, const void *data, size_t size) { SCM p = SCM_PACK (SCM_STREAM (port)); - scm_apply (SCM_VELTS (p)[1], - scm_cons (scm_mem2string ((char *) data, size), SCM_EOL), - SCM_EOL); + scm_call_1 (SCM_VELTS (p)[1], scm_mem2string ((char *) data, size)); } /* calling the flush proc (element 2) is in case old code needs it, @@ -116,7 +113,7 @@ sf_fill_input (SCM port) SCM p = SCM_PACK (SCM_STREAM (port)); SCM ans; - ans = scm_apply (SCM_VELTS (p)[3], SCM_EOL, SCM_EOL); /* get char. */ + ans = scm_call_0 (SCM_VELTS (p)[3]); /* get char. */ if (SCM_FALSEP (ans) || SCM_EOF_OBJECT_P (ans)) return EOF; SCM_ASSERT (SCM_CHARP (ans), ans, SCM_ARG1, "sf_fill_input"); @@ -138,7 +135,7 @@ sf_close (SCM port) SCM f = SCM_VELTS (p)[4]; if (SCM_FALSEP (f)) return 0; - f = scm_apply (f, SCM_EOL, SCM_EOL); + f = scm_call_0 (f); errno = 0; return SCM_FALSEP (f) ? EOF : 0; } From dd0e04edd65cdcb71517f1f079676cb04d3bafc4 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Tue, 26 Jun 2001 15:59:41 +0000 Subject: [PATCH 1371/2047] News for scm_call_N and scm_apply_N. --- NEWS | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/NEWS b/NEWS index 5e26e4734..f55f70543 100644 --- a/NEWS +++ b/NEWS @@ -701,6 +701,23 @@ Guile. Instead, use scm_c_memq or scm_memq, scm_memv, scm_member. +** New functions: scm_call_0, scm_call_1, scm_call_2, scm_call_3 + +Call a procedure with the indicated number of arguments. + +Example: + + scm_call_1 (proc, arg1); + +** New functions: scm_apply_0, scm_apply_1, scm_apply_2, scm_apply_3 + +Call a procedure with the indicated number of arguments and a list +of arguments. + +Example: + + scm_apply_1 (proc, arg1, args); + ** New function: scm_c_read (SCM port, void *buffer, scm_sizet size) Used by an application to read arbitrary number of bytes from a port. From 82893676f43d32d217d264ad5bef50f0952b6460 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Tue, 26 Jun 2001 17:53:09 +0000 Subject: [PATCH 1372/2047] Make compilation under Windows easier. --- ANON-CVS | 1 - ChangeLog | 6 +++++ HACKING | 2 -- THANKS | 1 + configure.in | 4 +-- libguile/ChangeLog | 56 ++++++++++++++++++++++++++++++++++++++++ libguile/_scm.h | 4 +-- libguile/async.h | 6 ++--- libguile/backtrace.c | 3 +++ libguile/filesys.c | 50 +++++++++++++++++++++++++++++++++++ libguile/fports.c | 54 +++++++++++++++++++++++++++++++++++++- libguile/gdb_interface.h | 22 ++++++++++++++++ libguile/guile.c | 15 +++++++++++ libguile/inet_aton.c | 4 +++ libguile/iselect.h | 4 +++ libguile/net_db.c | 7 ++++- libguile/ports.c | 21 ++++++++++++++- libguile/posix.c | 47 ++++++++++++++++++++++++++++----- libguile/random.c | 8 ++++++ libguile/scmsigs.c | 12 +++++++++ libguile/socket.c | 6 ++++- libguile/stime.c | 4 +-- 22 files changed, 315 insertions(+), 22 deletions(-) diff --git a/ANON-CVS b/ANON-CVS index d782a03b9..baf07412a 100644 --- a/ANON-CVS +++ b/ANON-CVS @@ -46,7 +46,6 @@ To check out a CVS working directory: The modules available for checkout are: guile-core --- The scheme interpreter itself. - guile-doc --- Guile documentation-in-progress. guile-tcltk --- An interface between Guile and Tcl/Tk. guile-scsh --- An incomplete port of SCSH 0.4.4 to Guile. guile-rgx-ctax --- This has been discontinued; use Andrew Archibald's diff --git a/ChangeLog b/ChangeLog index 2a3747154..a3dfa2056 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2001-06-26 Martin Grabmueller + + * HACKING, ANON-CVS: Removed mentioning of guile-doc CVS module. + + * configure.in: Added some header and function checks. + 2001-06-25 Neil Jerram * autogen.sh: Quoting fix for `--enable-maintainer-mode'. diff --git a/HACKING b/HACKING index f3d60a899..ffbfa6dfe 100644 --- a/HACKING +++ b/HACKING @@ -103,8 +103,6 @@ For more information on SSH, see http://www.cs.hut.fi/ssh. The Guile sources live in several modules: - guile-core --- the interpreter, QuickThreads, and ice-9 - - guile-doc --- documentation in progress. When complete, this will - be incorporated into guile-core. - guile-tcltk --- the Guile/Tk interface - guile-tk --- the new Guile/Tk interface, based on STk's modified Tk - guile-rgx-ctax --- the Guile/Rx interface, and the ctax implementation diff --git a/THANKS b/THANKS index f4eccdddb..6941df180 100644 --- a/THANKS +++ b/THANKS @@ -33,6 +33,7 @@ For fixes or providing information which led to a fix: Utz-Uwe Haus Karl M. Hegbloom Anders Holst + Stefan Jahn Steven G. Johnson Richard Kim Alexander Klimov diff --git a/configure.in b/configure.in index 32c5481e0..f51e4c4ce 100644 --- a/configure.in +++ b/configure.in @@ -192,7 +192,7 @@ AC_HEADER_STDC AC_HEADER_DIRENT AC_HEADER_TIME AC_HEADER_SYS_WAIT -AC_CHECK_HEADERS(io.h libc.h limits.h malloc.h memory.h string.h regex.h rxposix.h rx/rxposix.h sys/ioctl.h sys/select.h sys/time.h sys/timeb.h sys/times.h sys/stdtypes.h sys/types.h sys/utime.h time.h unistd.h utime.h) +AC_CHECK_HEADERS(io.h libc.h limits.h malloc.h memory.h string.h regex.h rxposix.h rx/rxposix.h sys/ioctl.h sys/select.h sys/time.h sys/timeb.h sys/times.h sys/stdtypes.h sys/types.h sys/utime.h time.h unistd.h utime.h pwd.h winsock2.h grp.h sys/utsname.h) GUILE_HEADER_LIBC_WITH_UNISTD AC_TYPE_GETGROUPS @@ -232,7 +232,7 @@ AC_SUBST(INCLTDL) AC_SUBST(LIBLTDL) AC_SUBST(DLPREOPEN) -AC_CHECK_FUNCS(ctermid ftime fchown getcwd geteuid gettimeofday lstat mkdir mknod nice readlink rename rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt strftime strptime symlink sync tcgetpgrp tcsetpgrp times uname waitpid strdup system usleep atexit on_exit) +AC_CHECK_FUNCS(ctermid ftime fchown getcwd geteuid gettimeofday lstat mkdir mknod nice readlink rename rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt strftime strptime symlink sync tcgetpgrp tcsetpgrp times uname waitpid strdup system usleep atexit on_exit chown link fcntl ttyname getpwent getgrent kill getppid getpgrp fork) AC_CHECK_HEADERS(crypt.h sys/resource.h sys/file.h) AC_CHECK_FUNCS(chroot flock getlogin cuserid getpriority setpriority getpass sethostname gethostname) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index cdf0344f2..6ab44667e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,59 @@ +2001-06-26 Martin Grabmueller + + * ports.c (scm_output_port_p): Use result of SCM_COERCE_OUTPORT. + + The following set of changes makes compiling Guile under various + Windows compilers easier. Compilation under GNU systems should + not be affected at all. + + Thanks to Stefan Jahn for all necessary information, patches and + testing. + + * posix.c: Conditialize getpwent, getgrent, kill, getppid, getuid, + getpgrp, ttyname, primitive-fork and some header inclusion for + Windows. + + * random.c: Define M_PI, if not predefined and use __int64 for + LONG64 under Windows. + + * scmsigs.c: Emulate some functions (alarm, sleep, kill) under + Windows and conditionalize some signal names. + + * socket.c (scm_getsockopt): Added missing comma. + Include socket library header under Windows. + + * stime.c (CLKTCK): Add cast to int, to make it compile under + Windows. + + * ports.c (truncate): New function, compiled only under Windows. + + * net_db.c: Do not declare errno under Windows. + + * iselect.h, inet_aton.c: Include socket library headers under + Windows. + + * guile.c (inner_main): Under Windows, initialize socket library + and initialize gdb_interface data structures. + + * gdb_interface.h: Under Windows, gdb_interface cannot be + initialized statically. Initialize at runtime instead. + + * fports.c (write_all): ssize_t -> size_t. + (fport_print): Conditionalize call to ttyname(). + (getflags): New function, compiled only under Windows. + + * filesys.c: Conditionalize inclusion of . Conditionalize + primitives chown, link, fcntl. + (scm_basename, scm_dirname): Under Windows, handle \ as well as / + as path seperator. + + * backtrace.c: Include under Windows. + + * async.h (ASYNCH, SCM_ASYNC_H): Rename H to SCM__H. + + * _scm.h: Added preprocessor conditional for __MINGW32__ for errno + declaration. + 2001-06-27 Keisuke Nishida * eval.c (scm_call_0, scm_call_1, scm_call_2, scm_call_3, diff --git a/libguile/_scm.h b/libguile/_scm.h index ec9839d80..d155f9441 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -111,13 +111,13 @@ # define SCM_SYSCALL(line) line; #endif /* ndef SCM_SYSCALL */ -#ifndef MSDOS +#if !defined (MSDOS) && !defined (__MINGW32__) # ifdef ARM_ULIB extern volatile int errno; # else extern int errno; # endif /* def ARM_ULIB */ -#endif /* ndef MSDOS */ +#endif /* ndef MSDOS && ndef __MINGW32__*/ diff --git a/libguile/async.h b/libguile/async.h index b4fa403cb..ca5b7efce 100644 --- a/libguile/async.h +++ b/libguile/async.h @@ -1,7 +1,7 @@ /* classes: h_files */ -#ifndef ASYNCH -#define ASYNCH +#ifndef SCM_ASYNC_H +#define SCM_ASYNC_H /* Copyright (C) 1995, 96, 97, 98, 2000 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify @@ -70,7 +70,7 @@ extern SCM scm_unmask_signals (void); extern SCM scm_mask_signals (void); extern void scm_init_async (void); -#endif /* ASYNCH */ +#endif /* SCM_ASYNC_H */ /* Local Variables: diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 3ab3a29f4..1687ab88e 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -54,6 +54,9 @@ #ifdef HAVE_UNISTD_H #include #endif +#ifdef HAVE_IO_H +#include +#endif #include "libguile/stacks.h" #include "libguile/srcprop.h" diff --git a/libguile/filesys.c b/libguile/filesys.c index 1d4afd341..0593414c3 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -93,7 +93,9 @@ #include #include +#ifdef HAVE_PWD_H #include +#endif #if HAVE_DIRENT_H @@ -117,6 +119,26 @@ #if defined (S_IFSOCK) && ! defined (S_ISSOCK) #define S_ISSOCK(mode) (((mode) & S_IFMT) == S_IFSOCK) #endif + +/* The MinGW gcc does not define the S_ISSOCK macro. Any other native Windows + compiler like BorlandC or MSVC has none of these macros defined. */ +#ifdef __MINGW32__ +# define S_ISSOCK(mode) (0) +#endif +#if defined (__BORLANDC__) || defined (_MSC_VER) +# define S_ISBLK(mode) (0) +# define S_ISFIFO(mode) (((mode) & _S_IFMT) == _S_IFIFO) +# define S_ISCHR(mode) (((mode) & _S_IFMT) == _S_IFCHR) +# define S_ISDIR(mode) (((mode) & _S_IFMT) == _S_IFDIR) +# define S_ISREG(mode) (((mode) & _S_IFMT) == _S_IFREG) +#endif + +/* Some more definitions for the native Windows port. */ +#ifdef __MINGW32__ +# define mkdir(path, mode) mkdir (path) +# define fsync(fd) _commit (fd) +# define fchmod(fd, mode) (-1) +#endif /* __MINGW32__ */ @@ -125,6 +147,7 @@ /* {Permissions} */ +#ifdef HAVE_CHOWN SCM_DEFINE (scm_chown, "chown", 3, 0, 0, (SCM object, SCM owner, SCM group), "Change the ownership and group of the file referred to by @var{object} to\n" @@ -167,6 +190,7 @@ SCM_DEFINE (scm_chown, "chown", 3, 0, 0, return SCM_UNSPECIFIED; } #undef FUNC_NAME +#endif /* HAVE_CHOWN */ SCM_DEFINE (scm_chmod, "chmod", 2, 0, 0, @@ -561,6 +585,7 @@ SCM_DEFINE (scm_stat, "stat", 1, 0, 0, /* {Modifying Directories} */ +#ifdef HAVE_LINK SCM_DEFINE (scm_link, "link", 2, 0, 0, (SCM oldpath, SCM newpath), "Creates a new name @var{newpath} in the file system for the\n" @@ -582,6 +607,7 @@ SCM_DEFINE (scm_link, "link", 2, 0, 0, return SCM_UNSPECIFIED; } #undef FUNC_NAME +#endif /* HAVE_LINK */ @@ -1145,6 +1171,7 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0, +#ifdef HAVE_FCNTL SCM_DEFINE (scm_fcntl, "fcntl", 2, 1, 0, (SCM object, SCM cmd, SCM value), "Apply @var{command} to the specified file descriptor or the underlying\n" @@ -1199,6 +1226,7 @@ SCM_DEFINE (scm_fcntl, "fcntl", 2, 1, 0, return SCM_MAKINUM (rv); } #undef FUNC_NAME +#endif /* HAVE_FCNTL */ SCM_DEFINE (scm_fsync, "fsync", 1, 0, 0, (SCM object), @@ -1368,12 +1396,22 @@ SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0, len = SCM_STRING_LENGTH (filename); i = len - 1; +#ifdef __MINGW32__ + while (i >= 0 && (s[i] == '/' || s[i] == '\\')) --i; + while (i >= 0 && (s[i] != '/' || s[i] != '\\')) --i; + while (i >= 0 && (s[i] == '/' || s[i] == '\\')) --i; +#else while (i >= 0 && s[i] == '/') --i; while (i >= 0 && s[i] != '/') --i; while (i >= 0 && s[i] == '/') --i; +#endif /* ndef __MINGW32__ */ if (i < 0) { +#ifdef __MINGW32__ + if (len > 0 && (s[0] == '/' || s[0] == '\\')) +#else if (len > 0 && s[0] == '/') +#endif /* ndef __MINGW32__ */ return scm_substring (filename, SCM_INUM0, SCM_MAKINUM (1)); else return scm_dot_string; @@ -1407,15 +1445,27 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0, j = SCM_STRING_LENGTH (suffix) - 1; } i = len - 1; +#ifdef __MINGW32__ + while (i >= 0 && (f[i] == '/' || f[i] == '\\')) --i; +#else while (i >= 0 && f[i] == '/') --i; +#endif /* ndef __MINGW32__ */ end = i; while (i >= 0 && j >= 0 && f[i] == s[j]) --i, --j; if (j == -1) end = i; +#ifdef __MINGW32__ + while (i >= 0 && (f[i] != '/' || f[i] != '\\')) --i; +#else while (i >= 0 && f[i] != '/') --i; +#endif /* ndef __MINGW32__ */ if (i == end) { +#ifdef __MINGW32__ + if (len > 0 && (f[0] == '/' || f[i] == '\\')) +#else if (len > 0 && f[0] == '/') +#endif /* ndef __MINGW32__ */ return scm_substring (filename, SCM_INUM0, SCM_MAKINUM (1)); else return scm_dot_string; diff --git a/libguile/fports.c b/libguile/fports.c index 42d8bd843..bc90db6bf 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -68,6 +68,12 @@ size_t fwrite (); #include #include "libguile/iselect.h" +/* Some defines for Windows. */ +#ifdef __MINGW32__ +# include +# include +# define ftruncate(fd, size) chsize (fd, size) +#endif /* __MINGW32__ */ scm_t_bits scm_tc16_fport; @@ -349,6 +355,46 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0, #undef FUNC_NAME +#ifdef __MINGW32__ +/* + * Try getting the appropiate file flags for a given file descriptor + * under Windows. This incorporates some fancy operations because Windows + * differentiates between file, pipe and socket descriptors. + */ +#ifndef O_ACCMODE +# define O_ACCMODE 0x0003 +#endif + +static int getflags (int fdes) +{ + int flags = 0; + struct stat buf; + int error, optlen = sizeof (int); + + /* Is this a socket ? */ + if (getsockopt (fdes, SOL_SOCKET, SO_ERROR, (void *) &error, &optlen) >= 0) + flags = O_RDWR; + /* Maybe a regular file ? */ + else if (fstat (fdes, &buf) < 0) + flags = -1; + else + { + /* Or an anonymous pipe handle ? */ + if (buf.st_mode & 0x1000 /* _O_SHORT_LIVED */) + flags = O_RDWR; + /* stdin ? */ + else if (fdes == 0 && isatty (fdes)) + flags = O_RDONLY; + /* stdout / stderr ? */ + else if ((fdes == 1 || fdes == 2) && isatty (fdes)) + flags = O_WRONLY; + else + flags = buf.st_mode; + } + return flags; +} +#endif /* __MINGW32__ */ + /* Building Guile ports from a file descriptor. */ /* Build a Scheme port from an open file descriptor `fdes'. @@ -366,7 +412,11 @@ scm_fdes_to_port (int fdes, char *mode, SCM name) int flags; /* test that fdes is valid. */ +#ifdef __MINGW32__ + flags = getflags (fdes); +#else flags = fcntl (fdes, F_GETFL, 0); +#endif if (flags == -1) SCM_SYSERROR; flags &= O_ACCMODE; @@ -456,9 +506,11 @@ fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) scm_putc (' ', port); fdes = (SCM_FSTREAM (exp))->fdes; +#ifdef HAVE_TTYNAME if (isatty (fdes)) scm_puts (ttyname (fdes), port); else +#endif /* HAVE_TTYNAME */ scm_intprint (fdes, 10, port); } else @@ -595,7 +647,7 @@ static void write_all (SCM port, const void *data, size_t remaining) while (remaining > 0) { - ssize_t done; + size_t done; SCM_SYSCALL (done = write (fdes, data, remaining)); diff --git a/libguile/gdb_interface.h b/libguile/gdb_interface.h index ec1bbe43d..fc44bc815 100644 --- a/libguile/gdb_interface.h +++ b/libguile/gdb_interface.h @@ -58,6 +58,7 @@ Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */ interface in your main program. This is necessary if the interface is defined in a library, such as Guile. */ +#ifndef __MINGW32__ #define GDB_INTERFACE \ void *gdb_interface[] = { \ &gdb_options, \ @@ -71,6 +72,27 @@ void *gdb_interface[] = { \ (void *) gdb_print, \ (void *) gdb_binding \ } +#else /* __MINGW32__ */ +/* Because the following functions are imported from a DLL (some kind of + shared library) these are NO static initializers. That is why you need to + define them and assign the functions and data items at run time. */ +#define GDB_INTERFACE \ +void *gdb_interface[] = \ + { NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL }; +#define GDB_INTERFACE_INIT \ + do { \ + gdb_interface[0] = &gdb_options; \ + gdb_interface[1] = &gdb_language; \ + gdb_interface[2] = &gdb_result; \ + gdb_interface[3] = &gdb_output; \ + gdb_interface[4] = &gdb_output_length; \ + gdb_interface[5] = (void *) gdb_maybe_valid_type_p; \ + gdb_interface[6] = (void *) gdb_read; \ + gdb_interface[7] = (void *) gdb_eval; \ + gdb_interface[8] = (void *) gdb_print; \ + gdb_interface[9] = (void *) gdb_binding; \ + } while (0); +#endif /* __MINGW32__ */ /* GDB_OPTIONS is a set of flags informing gdb what features are present in the interface. Currently only one option is supported: */ diff --git a/libguile/guile.c b/libguile/guile.c index 21be17871..d25a70d07 100644 --- a/libguile/guile.c +++ b/libguile/guile.c @@ -55,6 +55,10 @@ #include #endif +#ifdef HAVE_WINSOCK2_H +#include +#endif + /* Debugger interface (don't change the order of the following lines) */ #define GDB_TYPE SCM #include @@ -63,8 +67,19 @@ GDB_INTERFACE; static void inner_main (void *closure SCM_UNUSED, int argc, char **argv) { +#ifdef __MINGW32__ + /* This is necessary to startup the Winsock API under Win32. */ + WSADATA WSAData; + WSAStartup (0x0202, &WSAData); + GDB_INTERFACE_INIT; +#endif /* __MINGW32__ */ + /* module initializations would go here */ scm_shell (argc, argv); + +#ifdef __MINGW32__ + WSACleanup (); +#endif /* __MINGW32__ */ } int diff --git a/libguile/inet_aton.c b/libguile/inet_aton.c index 54c76507b..ec00b5a0d 100644 --- a/libguile/inet_aton.c +++ b/libguile/inet_aton.c @@ -40,9 +40,13 @@ static char sccsid[] = "@(#)inet_addr.c 8.1 (Berkeley) 6/17/93"; #include +#ifdef __MINGW32__ +#include +#else #include #include #include +#endif #if 0 diff --git a/libguile/iselect.h b/libguile/iselect.h index eb87927c0..fdaedcc61 100644 --- a/libguile/iselect.h +++ b/libguile/iselect.h @@ -67,6 +67,10 @@ #include #endif +#ifdef HAVE_WINSOCK2_H +#include +#endif + #ifdef FD_SET #define SELECT_TYPE fd_set diff --git a/libguile/net_db.c b/libguile/net_db.c index 66e327a85..974ba888c 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -66,12 +66,17 @@ #endif #include + +#ifdef HAVE_WINSOCK2_H +#include +#else #include #include #include #include +#endif -#ifndef HAVE_H_ERRNO +#if !defined (HAVE_H_ERRNO) && !defined (__MINGW32__) /* h_errno not found in netdb.h, maybe this will help. */ extern int h_errno; #endif diff --git a/libguile/ports.c b/libguile/ports.c index 0dddda802..68951a416 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -77,6 +77,11 @@ #include #endif +#ifdef __MINGW32__ +#include +#define ftruncate(fd, size) chsize (fd, size) +#endif + /* The port kind table --- a dynamically resized array of port types. */ @@ -802,7 +807,7 @@ SCM_DEFINE (scm_output_port_p, "output-port?", 1, 0, 0, "@code{port?}.") #define FUNC_NAME s_scm_output_port_p { - SCM_COERCE_OUTPORT (x); + x = SCM_COERCE_OUTPORT (x); return SCM_BOOL (SCM_OUTPUT_PORT_P (x)); } #undef FUNC_NAME @@ -1325,6 +1330,20 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, } #undef FUNC_NAME +#ifdef __MINGW32__ +/* Define this function since it is not supported under Windows. */ +static int truncate (char *file, int length) +{ + int ret = -1, fdes; + if ((fdes = open (file, O_BINARY | O_WRONLY)) != -1) + { + ret = chsize (fdes, length); + close (fdes); + } + return ret; +} +#endif /* __MINGW32__ */ + SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, (SCM object, SCM length), "Truncates the object referred to by @var{object} to at most\n" diff --git a/libguile/posix.c b/libguile/posix.c index 83e8bac10..7379c3780 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -91,7 +91,20 @@ extern char *ttyname(); #include #include +#ifdef HAVE_PWD_H #include +#endif +#ifdef HAVE_IO_H +#include +#endif +#ifdef HAVE_WINSOCK2_H +#include +#endif + +#ifdef __MINGW32__ +/* Some defines for Windows here. */ +# define pipe(fd) _pipe (fd, 256, O_BINARY) +#endif /* __MINGW32__ */ #if HAVE_SYS_WAIT_H # include @@ -107,8 +120,12 @@ extern char *ttyname(); extern char ** environ; +#ifdef HAVE_GRP_H #include +#endif +#ifdef HAVE_SYS_UTSNAME_H #include +#endif #if HAVE_DIRENT_H # include @@ -247,7 +264,7 @@ SCM_DEFINE (scm_getgroups, "getgroups", 0, 0, 0, #undef FUNC_NAME #endif - +#ifdef HAVE_GETPWENT SCM_DEFINE (scm_getpwuid, "getpw", 0, 1, 0, (SCM user), "Look up an entry in the user database. @var{obj} can be an integer,\n" @@ -298,6 +315,7 @@ SCM_DEFINE (scm_getpwuid, "getpw", 0, 1, 0, return result; } #undef FUNC_NAME +#endif /* HAVE_GETPWENT */ #ifdef HAVE_SETPWENT @@ -318,7 +336,7 @@ SCM_DEFINE (scm_setpwent, "setpw", 0, 1, 0, #endif - +#ifdef HAVE_GETGRENT /* Combines getgrgid and getgrnam. */ SCM_DEFINE (scm_getgrgid, "getgr", 0, 1, 0, (SCM name), @@ -375,7 +393,7 @@ SCM_DEFINE (scm_setgrent, "setgr", 0, 1, 0, return SCM_UNSPECIFIED; } #undef FUNC_NAME - +#endif /* HAVE_GETGRENT */ SCM_DEFINE (scm_kill, "kill", 2, 0, 0, @@ -407,8 +425,13 @@ SCM_DEFINE (scm_kill, "kill", 2, 0, 0, SCM_VALIDATE_INUM (1,pid); SCM_VALIDATE_INUM (2,sig); /* Signal values are interned in scm_init_posix(). */ +#ifdef HAVE_KILL if (kill ((int) SCM_INUM (pid), (int) SCM_INUM (sig)) != 0) - SCM_SYSERROR; +#else + if ((int) SCM_INUM (pid) == getpid ()) + if (raise ((int) SCM_INUM (sig)) != 0) +#endif + SCM_SYSERROR; return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -472,6 +495,7 @@ SCM_DEFINE (scm_waitpid, "waitpid", 1, 1, 0, #undef FUNC_NAME #endif /* HAVE_WAITPID */ +#ifndef __MINGW32__ SCM_DEFINE (scm_status_exit_val, "status:exit-val", 1, 0, 0, (SCM status), "Return the exit status value, as would be set if a process\n" @@ -528,7 +552,9 @@ SCM_DEFINE (scm_status_stop_sig, "status:stop-sig", 1, 0, 0, return SCM_BOOL_F; } #undef FUNC_NAME +#endif /* __MINGW32__ */ +#ifdef HAVE_GETPPID SCM_DEFINE (scm_getppid, "getppid", 0, 0, 0, (), "Return an integer representing the process ID of the parent\n" @@ -538,9 +564,10 @@ SCM_DEFINE (scm_getppid, "getppid", 0, 0, 0, return SCM_MAKINUM (0L + getppid ()); } #undef FUNC_NAME +#endif /* HAVE_GETPPID */ - +#ifndef __MINGW32__ SCM_DEFINE (scm_getuid, "getuid", 0, 0, 0, (), "Return an integer representing the current real user ID.") @@ -549,6 +576,7 @@ SCM_DEFINE (scm_getuid, "getuid", 0, 0, 0, return SCM_MAKINUM (0L + getuid ()); } #undef FUNC_NAME +#endif /* __MINGW32__ */ @@ -580,7 +608,6 @@ SCM_DEFINE (scm_geteuid, "geteuid", 0, 0, 0, #undef FUNC_NAME - SCM_DEFINE (scm_getegid, "getegid", 0, 0, 0, (), "Return an integer representing the current effective group ID.\n" @@ -675,6 +702,8 @@ SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0, #undef FUNC_NAME #endif + +#ifdef HAVE_GETPGRP SCM_DEFINE (scm_getpgrp, "getpgrp", 0, 0, 0, (), "Return an integer representing the current process group ID.\n" @@ -686,6 +715,8 @@ SCM_DEFINE (scm_getpgrp, "getpgrp", 0, 0, 0, return SCM_MAKINUM (fn (0)); } #undef FUNC_NAME +#endif /* HAVE_GETPGRP */ + #ifdef HAVE_SETPGID SCM_DEFINE (scm_setpgid, "setpgid", 2, 0, 0, @@ -724,6 +755,7 @@ SCM_DEFINE (scm_setsid, "setsid", 0, 0, 0, #undef FUNC_NAME #endif /* HAVE_SETSID */ +#ifdef HAVE_TTYNAME SCM_DEFINE (scm_ttyname, "ttyname", 1, 0, 0, (SCM port), "Return a string with the name of the serial terminal device\n" @@ -745,6 +777,7 @@ SCM_DEFINE (scm_ttyname, "ttyname", 1, 0, 0, return (scm_makfrom0str (ans)); } #undef FUNC_NAME +#endif /* HAVE_TTYNAME */ #ifdef HAVE_CTERMID SCM_DEFINE (scm_ctermid, "ctermid", 0, 0, 0, @@ -947,6 +980,7 @@ SCM_DEFINE (scm_execle, "execle", 2, 0, 1, } #undef FUNC_NAME +#ifdef HAVE_FORK SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0, (), "Creates a new \"child\" process by duplicating the current \"parent\" process.\n" @@ -963,6 +997,7 @@ SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0, return SCM_MAKINUM (0L+pid); } #undef FUNC_NAME +#endif /* HAVE_FORK */ #ifdef HAVE_UNAME SCM_DEFINE (scm_uname, "uname", 0, 0, 0, diff --git a/libguile/random.c b/libguile/random.c index a55d68c31..f367332e5 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -91,6 +91,10 @@ scm_t_rng scm_the_rng; #define A 2131995753UL +#ifndef M_PI +#define M_PI 3.14159265359 +#endif + #if SIZEOF_LONG > 4 #if SIZEOF_INT > 4 #define LONG32 unsigned short @@ -100,8 +104,12 @@ scm_t_rng scm_the_rng; #define LONG64 unsigned long #else #define LONG32 unsigned long +#ifdef __MINGW32__ +#define LONG64 unsigned __int64 +#else #define LONG64 unsigned long long #endif +#endif #if SIZEOF_LONG > 4 || defined (HAVE_LONG_LONGS) diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index bdbf525e7..ea75a7216 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -74,6 +74,14 @@ int usleep (); #endif +#ifdef __MINGW32__ +#include +#define alarm(sec) (0) +/* This weird comma expression is because Sleep is void under Windows. */ +#define sleep(sec) (Sleep ((sec) * 1000), 0) +#define kill(pid, sig) raise (sig) +#endif + /* SIGRETTYPE is the type that signal handlers return. See */ @@ -298,12 +306,16 @@ SCM_DEFINE (scm_sigaction, "sigaction", 1, 2, 0, case SIGFPE: case SIGILL: case SIGSEGV: +#ifdef SIGBUS case SIGBUS: +#endif case SIGABRT: #if defined(SIGIOT) && (SIGIOT != SIGABRT) case SIGIOT: #endif +#ifdef SIGTRAP case SIGTRAP: +#endif #ifdef SIGEMT case SIGEMT: #endif diff --git a/libguile/socket.c b/libguile/socket.c index 1eacf9fe8..82d03fbc4 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -63,6 +63,9 @@ #include #endif #include +#ifdef HAVE_WINSOCK2_H +#include +#else #include #ifdef HAVE_UNIX_DOMAIN_SOCKETS #include @@ -70,6 +73,7 @@ #include #include #include +#endif #if defined (HAVE_UNIX_DOMAIN_SOCKETS) && !defined (SUN_LEN) #define SUN_LEN(ptr) ((size_t) (((struct sockaddr_un *) 0)->sun_path) \ @@ -523,7 +527,7 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0, return scm_cons (scm_long2num (ling->l_onoff), scm_long2num (ling->l_linger)); #else - return scm_cons (scm_long2num (*(int *) optval) + return scm_cons (scm_long2num (*(int *) optval), SCM_MAKINUM (0)); #endif } diff --git a/libguile/stime.c b/libguile/stime.c index 5db51a547..fae4beeb8 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -99,10 +99,10 @@ extern char *strptime (); /* This should be figured out by autoconf. */ #if ! defined(CLKTCK) && defined(CLK_TCK) -# define CLKTCK CLK_TCK +# define CLKTCK ((int) CLK_TCK) #endif #if ! defined(CLKTCK) && defined(CLOCKS_PER_SEC) -# define CLKTCK CLOCKS_PER_SEC +# define CLKTCK ((int) CLOCKS_PER_SEC) #endif #if ! defined(CLKTCK) # define CLKTCK 60 From 30e3be5a62d957efa70484fb5152a1039daaf46f Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Tue, 26 Jun 2001 21:18:51 +0000 Subject: [PATCH 1373/2047] * Makefile.am (c-tokenize.c): add rule to generate it. (EXTRA_DIST): add c-tokenize.lex, so it gets distributed. filter-doc-snarfage.c: remove. --- libguile/ChangeLog | 7 +++++++ libguile/Makefile.am | 6 +++++- libguile/filter-doc-snarfage.c | 0 3 files changed, 12 insertions(+), 1 deletion(-) delete mode 100644 libguile/filter-doc-snarfage.c diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6ab44667e..5be7c4100 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2001-06-27 Michael Livshin + + * Makefile.am (c-tokenize.c): add rule to generate it. + (EXTRA_DIST): add c-tokenize.lex, so it gets distributed. + + filter-doc-snarfage.c: remove. + 2001-06-26 Martin Grabmueller * ports.c (scm_output_port_p): Use result of SCM_COERCE_OUTPORT. diff --git a/libguile/Makefile.am b/libguile/Makefile.am index b701dabd0..c16bf2f2f 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -145,7 +145,8 @@ bin_SCRIPTS = guile-snarf guile-doc-snarf guile-snarf-docs \ guile-snarf-docs-texi guile-func-name-check EXTRA_DIST = ChangeLog-gh ChangeLog-scm ChangeLog-threads cpp_signal.c \ - cpp_errno.c cpp_err_symbols.in cpp_sig_symbols.in cpp_cnvt.awk + cpp_errno.c cpp_err_symbols.in cpp_sig_symbols.in cpp_cnvt.awk \ + c-tokenize.lex # $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \ # guile-procedures.txt guile.texi @@ -210,6 +211,9 @@ guile-procedures.txt: guile.texi rm -f $@ makeinfo --force -o $@ $< || test -f $@ +c-tokenize.c: c-tokenize.lex + flex -t $< > $@ || { rm $@; false; } + schemelibdir = $(pkgdatadir)/$(VERSION) schemelib_DATA = guile-procedures.txt diff --git a/libguile/filter-doc-snarfage.c b/libguile/filter-doc-snarfage.c deleted file mode 100644 index e69de29bb..000000000 From 17383b7c773eaca6e5ab488c9edd1fa313c33248 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Tue, 26 Jun 2001 21:20:04 +0000 Subject: [PATCH 1374/2047] * autogen.sh: don't run flex here. * HACKING: clarify that _newer_ versions of flex should be just fine. --- ChangeLog | 7 +++++++ HACKING | 4 ++-- autogen.sh | 1 - 3 files changed, 9 insertions(+), 3 deletions(-) diff --git a/ChangeLog b/ChangeLog index a3dfa2056..10e22b9b2 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2001-06-27 Michael Livshin + + * autogen.sh: don't run flex here. + + * HACKING: clarify that newer versions of flex should be just + fine. + 2001-06-26 Martin Grabmueller * HACKING, ANON-CVS: Removed mentioning of guile-doc CVS module. diff --git a/HACKING b/HACKING index ffbfa6dfe..0d2353dba 100644 --- a/HACKING +++ b/HACKING @@ -57,8 +57,8 @@ libtool 1.4 --- a system for managing the zillion hairy options needed on various systems to produce shared libraries. Available in "ftp://ftp.gnu.org/pub/gnu/libtool" -flex 2.5.4 --- a tokenizer generator. earlier versions will most - probably work too. +flex 2.5.4 (or newer) --- a scanner generator. earlier versions will + most probably work too. You are lost in a little maze of automatically generated files, all different. diff --git a/autogen.sh b/autogen.sh index 9a9c9abfa..1e92ab4b9 100755 --- a/autogen.sh +++ b/autogen.sh @@ -11,7 +11,6 @@ libtoolize --copy --automake --ltdl autoheader autoconf automake --add-missing -flex -t libguile/c-tokenize.lex > libguile/c-tokenize.c ( echo "guile-readline..."; cd guile-readline; ./autogen.sh ) From d95c0b76d6f139d59660bdc7b20fae5a15947bcd Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 26 Jun 2001 21:55:45 +0000 Subject: [PATCH 1375/2047] * Handle evaluator traps by calling trap handlers directly rather than by scm_ithrow and a lazy catch handler. --- doc/ChangeLog | 5 +++++ doc/gh.texi | 4 +--- ice-9/ChangeLog | 9 +++++++++ ice-9/boot-9.scm | 14 +------------- ice-9/debug.scm | 9 ++++++--- libguile/ChangeLog | 15 +++++++++++++++ libguile/debug.h | 10 ++++++---- libguile/eval.c | 43 ++++++++++++++++++++++++++++++++----------- libguile/eval.h | 6 +++++- 9 files changed, 80 insertions(+), 35 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 5e0f0848a..0544d0bb8 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,8 @@ +2001-06-26 Neil Jerram + + * gh.texi (scm transition summary): Refer to scm_mem2string + instead of scm_makfromstr. + 2001-06-26 Dirk Herrmann * oldfmt.c (scm_oldfmt): Use scm_mem2string instead of diff --git a/doc/gh.texi b/doc/gh.texi index 4d2896ae8..552e2a69d 100644 --- a/doc/gh.texi +++ b/doc/gh.texi @@ -901,9 +901,7 @@ Use @code{scm_make_real} instead. Use @code{SCM_MAKE_CHAR} instead. @item @code{gh_str2scm} -Use @code{scm_makfromstr} instead. Note that @code{scm_makfromstr} -currently has an additional, third parameter, but it's unused and will -hopefully disappear soon. If it's still there, set it to 0. +Use @code{scm_mem2string} instead. @item @code{gh_str02scm} Use @code{scm_makfrom0str} instead. diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index ffdef9570..855ed945d 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,12 @@ +2001-06-26 Neil Jerram + + * debug.scm (trace): Set evaluator trap options to handle tracing. + Don't reset trace-level to 0. + + * boot-9.scm (lazy-handler-dispatch): Remove enter-frame-handler, + apply-frame-handler and exit-frame-handler. (They're replaced by + evaluator trap options.) + 2001-06-25 Michael Livshin * streams.scm (stream-for-each-many): typo fix. diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 5969244a3..ac2e48681 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -2237,20 +2237,8 @@ (save-stack lazy-handler-dispatch) (apply throw key args)) -(define enter-frame-handler default-lazy-handler) -(define apply-frame-handler default-lazy-handler) -(define exit-frame-handler default-lazy-handler) - (define (lazy-handler-dispatch key . args) - (case key - ((apply-frame) - (apply apply-frame-handler key args)) - ((exit-frame) - (apply exit-frame-handler key args)) - ((enter-frame) - (apply enter-frame-handler key args)) - (else - (apply default-lazy-handler key args)))) + (apply default-lazy-handler key args)) (define abort-hook (make-hook)) diff --git a/ice-9/debug.scm b/ice-9/debug.scm index f01676ba4..d2fe61324 100644 --- a/ice-9/debug.scm +++ b/ice-9/debug.scm @@ -78,9 +78,12 @@ (set! traced-procedures (cons proc traced-procedures)))) args) - (set! apply-frame-handler trace-entry) - (set! exit-frame-handler trace-exit) - (set! trace-level 0) + (trap-set! apply-frame-handler trace-entry) + (trap-set! exit-frame-handler trace-exit) + ;; We used to reset `trace-level' here to 0, but this is wrong + ;; if `trace' itself is being traced, since `trace-exit' will + ;; then decrement `trace-level' to -1! It shouldn't actually + ;; be necessary to set `trace-level' here at all. (debug-enable 'trace) (nameify args)))) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 5be7c4100..7d0f808c2 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,18 @@ +2001-06-26 Neil Jerram + + * eval.h, eval.c (scm_call_4): New function. + + * eval.c (SCM_APPLY, SCM_CEVAL, ENTER_APPLY): Call trap handlers + directly rather than dispatching to them via scm_ithrow and a lazy + catch. + + * eval.c (scm_evaluator_trap_table), eval.h (SCM_ENTER_FRAME_HDLR, + SCM_APPLY_FRAME_HDLR, SCM_EXIT_FRAME_HDLR): Add three new options + for trap handler procedures. + + * debug.h (SCM_RESET_DEBUG_MODE): Add checks for trap handler + procedures not being #f. + 2001-06-27 Michael Livshin * Makefile.am (c-tokenize.c): add rule to generate it. diff --git a/libguile/debug.h b/libguile/debug.h index 16d09510a..0954e3329 100644 --- a/libguile/debug.h +++ b/libguile/debug.h @@ -98,14 +98,16 @@ extern int scm_check_entry_p, scm_check_apply_p, scm_check_exit_p; #define SCM_RESET_DEBUG_MODE \ do {\ - CHECK_ENTRY = SCM_ENTER_FRAME_P || SCM_BREAKPOINTS_P;\ - CHECK_APPLY = SCM_APPLY_FRAME_P || SCM_TRACE_P;\ - CHECK_EXIT = SCM_EXIT_FRAME_P || SCM_TRACE_P;\ + CHECK_ENTRY = (SCM_ENTER_FRAME_P || SCM_BREAKPOINTS_P)\ + && SCM_NFALSEP (SCM_ENTER_FRAME_HDLR);\ + CHECK_APPLY = (SCM_APPLY_FRAME_P || SCM_TRACE_P)\ + && SCM_NFALSEP (SCM_APPLY_FRAME_HDLR);\ + CHECK_EXIT = (SCM_EXIT_FRAME_P || SCM_TRACE_P)\ + && SCM_NFALSEP (SCM_EXIT_FRAME_HDLR);\ scm_debug_mode = SCM_DEVAL_P || CHECK_ENTRY || CHECK_APPLY || CHECK_EXIT;\ scm_ceval_ptr = scm_debug_mode ? scm_deval : scm_ceval;\ } while (0) - /* {Evaluator} */ diff --git a/libguile/eval.c b/libguile/eval.c index 5d07e2434..ffd195ca5 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1620,18 +1620,20 @@ do { \ {\ SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \ SCM_SET_TRACED_FRAME (debug); \ + SCM_TRAPS_P = 0;\ if (SCM_CHEAPTRAPS_P)\ {\ tmp = scm_make_debugobj (&debug);\ - scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\ + scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\ }\ else\ {\ int first;\ tmp = scm_make_continuation (&first);\ if (first)\ - scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\ + scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\ }\ + SCM_TRAPS_P = 1;\ }\ } while (0) #undef RETURN @@ -1695,14 +1697,17 @@ scm_t_option scm_debug_opts[] = { { SCM_OPTION_BOOLEAN, "backtrace", 0, "Show backtrace on error." }, { SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." }, { SCM_OPTION_INTEGER, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }, - { SCM_OPTION_SCM, "show-file-name", SCM_BOOL_T, "Show file names and line numbers in backtraces when not `#f'. A value of `base' displays only base names, while `#t' displays full names."} + { SCM_OPTION_SCM, "show-file-name", (unsigned long)SCM_BOOL_T, "Show file names and line numbers in backtraces when not `#f'. A value of `base' displays only base names, while `#t' displays full names."} }; scm_t_option scm_evaluator_trap_table[] = { { SCM_OPTION_BOOLEAN, "traps", 0, "Enable evaluator traps." }, { SCM_OPTION_BOOLEAN, "enter-frame", 0, "Trap when eval enters new frame." }, { SCM_OPTION_BOOLEAN, "apply-frame", 0, "Trap when entering apply." }, - { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." } + { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." }, + { SCM_OPTION_SCM, "enter-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for enter-frame traps." }, + { SCM_OPTION_SCM, "apply-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for apply-frame traps." }, + { SCM_OPTION_SCM, "exit-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for exit-frame traps." } }; SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0, @@ -1914,10 +1919,13 @@ start: goto dispatch; } } - scm_ithrow (scm_sym_enter_frame, - scm_cons2 (t.arg1, tail, - scm_cons (scm_unmemocopy (x, env), SCM_EOL)), - 0); + SCM_TRAPS_P = 0; + scm_call_4 (SCM_ENTER_FRAME_HDLR, + scm_sym_enter_frame, + t.arg1, + tail, + scm_unmemocopy (x, env)); + SCM_TRAPS_P = 1; } #endif #if defined (USE_THREADS) || defined (DEVAL) @@ -3231,7 +3239,9 @@ exit: goto ret; } } - scm_ithrow (scm_sym_exit_frame, scm_cons2 (t.arg1, proc, SCM_EOL), 0); + SCM_TRAPS_P = 0; + scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, t.arg1, proc); + SCM_TRAPS_P = 1; } ret: scm_last_debug_frame = debug.prev; @@ -3273,6 +3283,13 @@ scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3) return scm_apply (proc, arg1, scm_cons2 (arg2, arg3, scm_listofnull)); } +SCM +scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4) +{ + return scm_apply (proc, arg1, scm_cons2 (arg2, arg3, + scm_cons (arg4, scm_listofnull))); +} + /* Simple procedure applies */ @@ -3446,7 +3463,9 @@ SCM_APPLY (SCM proc, SCM arg1, SCM args) if (!first) goto entap; } - scm_ithrow (scm_sym_enter_frame, scm_cons (tmp, SCM_EOL), 0); + SCM_TRAPS_P = 0; + scm_call_2 (SCM_ENTER_FRAME_HDLR, scm_sym_enter_frame, tmp); + SCM_TRAPS_P = 1; } entap: ENTER_APPLY; @@ -3676,7 +3695,9 @@ exit: goto ret; } } - scm_ithrow (scm_sym_exit_frame, scm_cons2 (arg1, proc, SCM_EOL), 0); + SCM_TRAPS_P = 0; + scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc); + SCM_TRAPS_P = 1; } ret: scm_last_debug_frame = debug.prev; diff --git a/libguile/eval.h b/libguile/eval.h index 35de8a6b2..418844c0a 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -68,7 +68,10 @@ extern SCM scm_eval_options_interface (SCM setting); #define SCM_ENTER_FRAME_P scm_evaluator_trap_table[1].val #define SCM_APPLY_FRAME_P scm_evaluator_trap_table[2].val #define SCM_EXIT_FRAME_P scm_evaluator_trap_table[3].val -#define SCM_N_EVALUATOR_TRAPS 4 +#define SCM_ENTER_FRAME_HDLR (SCM)(scm_evaluator_trap_table[4].val) +#define SCM_APPLY_FRAME_HDLR (SCM)(scm_evaluator_trap_table[5].val) +#define SCM_EXIT_FRAME_HDLR (SCM)(scm_evaluator_trap_table[6].val) +#define SCM_N_EVALUATOR_TRAPS 7 @@ -235,6 +238,7 @@ extern SCM scm_call_0 (SCM proc); extern SCM scm_call_1 (SCM proc, SCM arg1); extern SCM scm_call_2 (SCM proc, SCM arg1, SCM arg2); extern SCM scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3); +extern SCM scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4); extern SCM scm_apply_0 (SCM proc, SCM args); extern SCM scm_apply_1 (SCM proc, SCM arg1, SCM args); extern SCM scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args); From e673b80495a6ea3671314def1a5240c0c68063c4 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 26 Jun 2001 23:50:10 +0000 Subject: [PATCH 1376/2047] Added comment about being careful with the autobuild cruft in libltdl. --- RELEASE | 2 ++ 1 file changed, 2 insertions(+) diff --git a/RELEASE b/RELEASE index 15fd89751..d6d76dc0e 100644 --- a/RELEASE +++ b/RELEASE @@ -195,6 +195,8 @@ Spiffing checklist: in your PATH match those given in HACKING. Note that the `make dist' process always invokes these tools, even when all the generated files are up to date. + Make specifically sure that the files in libltdl are generated using + the same tools as the rest. * Rebuild all generated files in the source tree: + Install the .m4 files where aclocal will find them. + Run aclocal. From abf94ef33fa88e797790f5de3db40f193d025c03 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 26 Jun 2001 23:51:54 +0000 Subject: [PATCH 1377/2047] (member-if): Put in docstring for member-if, it was a cut-n-paste error previously. --- ice-9/common-list.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ice-9/common-list.scm b/ice-9/common-list.scm index bc583fdf2..a8b775cef 100644 --- a/ice-9/common-list.scm +++ b/ice-9/common-list.scm @@ -196,7 +196,7 @@ If found, return that element, otherwise return #f." (else (find-if pred (cdr l))))) (define-public (member-if pred l) - "Return #f iff (PRED element) is not true for any element in L." + "Return the first sublist of L for whose car PRED is true." (cond ((null? l) #f) ((pred (car l)) l) (else (member-if pred (cdr l))))) From 4cda41f62931a79498652ae6750cb6da0ec9a949 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 26 Jun 2001 23:52:14 +0000 Subject: [PATCH 1378/2047] *** empty log message *** --- ice-9/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 855ed945d..917fa7b22 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2001-06-27 Marius Vollmer + + * common-list.scm (member-if): Put in docstring for member-if, it + was a cut-n-paste error previously. + 2001-06-26 Neil Jerram * debug.scm (trace): Set evaluator trap options to handle tracing. From c7552137523d25de4a590c3500e36497bd5d85da Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 27 Jun 2001 09:37:16 +0000 Subject: [PATCH 1379/2047] Move todo items to file TODO. --- RELEASE | 120 +------------------------------------------------------- 1 file changed, 2 insertions(+), 118 deletions(-) diff --git a/RELEASE b/RELEASE index d6d76dc0e..57c851d65 100644 --- a/RELEASE +++ b/RELEASE @@ -7,122 +7,6 @@ absinthe, etc. However, the first release containing the module system should be called Godot: "This is the one you've been waiting for." -=== Eventually: - -* Deprecate `read-only-string?'. - -After signal handling and threading have been fixed: -- remove the code corresponding to GUILE_OLD_ASYNC_CLICK and the corresponding - GUILE_OLD_ASYNC_CLICK macro. - -=== In release 1.6.0: - -- Make sure that the deprecation mechanism explained in INSTALL and - README is completed and works. - -=== In release 1.8.0: - -- remove deprecated "scm_*_t" type names in libguile.h. - -- remove re-exporting behaviour of `export'. - in boot-9.scm, remove begin-deprecated part of `module-export!' - in format.scm, remove kluge at top - in srfi13.scm, likewise - -- remove deprecated subr and gsubr functions - in procs.h, procs.c: scm_make_subr, scm_make_subr_opt, - scm_make_subr_with_generic, - in gsubr.h, gsubr.c: scm_make_gsubr, scm_make_gsubr_with_generic. - -- remove deprecated C interface to modules - in modules.h, modules.c: - root_module_lookup_closure, scm_sym_app, scm_sym_modules, - module_prefix, make_modules_in_var, beautify_user_module_x_var, - scm_the_root_module, scm_make_module, scm_ensure_user_module, - scm_load_scheme_module - -- remove vcell and obarray support. - Remove all code bracketed by `#if SCM_ENABLE_VCELLS'. - Remove SCM_ENABLE_VCELLS itself. - Also remove `variable-set-name-hint' completely. - -- remove compatability module (ice-9 and-let*). It - has been replaced by (ice-9 and-let-star) and/or (srfi srfi-2). - -- remove support for autoloading compiled-code modules: - try-module-linked - try-module-dynamic-link - init-dynamic-module, etc. - scm_register_module_xxx - scm_registered_modules - scm_clear_registered_modules - -- remove deprecated variables: - scm_top_level_lookup_closure_var - scm_scm_system_transformer - Remove all code that still sets them: - `use-syntax', scm_set_current_module, ... - -- remove deprecated functions: - eval.c: scm_eval2, scm_eval_3 - load.c: scm_read_and_eval_x - smob.c: scm_make_smob_type_mfpe, scm_set_smob_mfpe - gc.c: scm_remember - string.c: scm_makstr, scm_makfromstr -- remove deprecated procedures: - boot-9.scm: eval-in-module, id, -1+, return-it, string-character-length, - flags -- remove deprecated macros: SCM_OUTOFRANGE, SCM_NALLOC, SCM_HUP_SIGNAL, - SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, - SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD, - SCM_ORD_SIG, SCM_NUM_SIGS, SCM_SLOPPY_STRINGP, SCM_VALIDATE_STRINGORSUBSTR, - SCM_FREEP, SCM_NFREEP, SCM_CHARS, SCM_UCHARS, SCM_VALIDATE_ROSTRING, - SCM_VALIDATE_ROSTRING_COPY, SCM_VALIDATE_NULLORROSTRING_COPY, SCM_ROLENGTH, - SCM_LENGTH, SCM_HUGE_LENGTH, SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, - SCM_COERCE_SUBSTR, SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING, - SCM_ROCHARS, SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS, SCM_LENGTH_MAX, - SCM_GC8MARKP, SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR, - SCM_SUBR_DOC, SCM_OPDIRP, SCM_VALIDATE_OPDIR, SCM_WTA, RETURN_SCM_WTA, - SCM_WNA, SCM_FUNC_NAME, SCM_VALIDATE_NUMBER_COPY, - SCM_VALIDATE_NUMBER_DEF_COPY, SCM_SLOPPY_CONSP, SCM_SLOPPY_NCONSP, - SCM_SETAND_CDR, SCM_SETOR_CDR, SCM_SETAND_CAR, SCM_SETOR_CAR, - SCM_ARRAY_CONTIGUOUS -- remove scm_vector_set_length_x -- remove function scm_call_catching_errors - (replaced by catch functions from throw.[ch]) -- remove support for "#&" reader syntax in (ice-9 optargs). -- remove scm_make_shared_substring -- remove scm_read_only_string_p -- remove scm_strhash -- remove scm_tc7_ssymbol -- remove scm_tc7_msymbol -- remove scm_tcs_symbols -- remove scm_sloppy_memq, scm_sloppy_memv, scm_sloppy_member -- consider removing the automatic loading of (ice-9 rdelim) when guile - starts up. This would be a brave move, since a lot of code will - assume that read-line is available by default. However it would make - it easier to use alternative implementations of this module, e.g., a - strictly scsh-compatible version which uses multiple values. For - interactive use it would be easy to load the module in ~/.guile. -- remove scm_close_all_ports_except -- remove scm_strprint_obj -- remove SCM_CONST_LONG -- remove scm_wta -- remove deprecated typedefs: long_long, ulong_long, scm_sizet -- remove deprecated macros: scm_contregs, scm_port_rw_active, - scm_port, scm_ptob_descriptor, scm_debug_info, scm_debug_frame, - scm_fport, SCM_FIXNUM_BIT, scm_option, scm_subr_entry, scm_rstate, - scm_rng, scm_i_rstate, scm_srcprops, scm_srcprops_chunk, - scm_info_frame, scm_stack, scm_array, scm_array_dim. -- remove deprecated functions: scm_mkbig, scm_big2num, scm_adjbig, - scm_normbig, scm_copybig, scm_2ulong2big, scm_dbl2big, scm_big2dbl. -- remove deprecated functions: scm_protect_object, - scm_unprotect_object, scm_create_hook. - -Modules sort.c and random.c should be factored out into separate -modules (but still be distributed with guile-core) when we get a new -module system. - Platforms for test builds: SunOS (gcc and pcc) --- galapas.ai.mit.edu Solaris (gcc and SUN cc) --- saturn.ai.mit.edu @@ -146,7 +30,7 @@ Tom Tromey : Ian Grant : - alpha-dec-osf4.0e + alpha-dec-osf4.0e Julian Satchell : @@ -247,7 +131,7 @@ Once you've got a disty that seems pretty solid: Punting checklist: * Add "Guile N.M released." entry to the top-level ChangeLog, and commit it. -* Tag the entire source tree with a tag of the form "release_N_M" +* Tag the entire source tree with a tag of the form "release_N_M" or "release_N_M_L". * Do a 'make dist'. * Put the distribution up for FTP somewhere, and send mail to From 9a6b2d623a5e2ae38036fd8a9f617446919b0b7c Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 27 Jun 2001 09:46:44 +0000 Subject: [PATCH 1380/2047] Initial revision --- TODO | 135 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 135 insertions(+) create mode 100644 TODO diff --git a/TODO b/TODO new file mode 100644 index 000000000..5b8705a34 --- /dev/null +++ b/TODO @@ -0,0 +1,135 @@ +[ID: $Id: TODO,v 1.15 2001-06-27 09:46:44 ttn Exp $] + +These are grouped by release target. If you would like to suggest changes or +contribute patches, please first email guile-devel@gnu.org to coordinate. See +also file HACKING. + + +=== Eventually (not yet associated with a specific release): + +- deprecate `read-only-string?' +- [after signal handling and threading have been fixed] remove the code + corresponding to GUILE_OLD_ASYNC_CLICK and the corresponding + GUILE_OLD_ASYNC_CLICK macro. +- implement and integrate generational garbage collection +- add POSIX thread support +- factor thread support out of libguile +- protect common resources using mutecis from the new interface +- remove the dynamic roots +- revise the fluid implementation +- implement the GC thread synchronization (all threads: go to sleep!) +- implementing the libguileposix threads glue library +- GOOPS + - develop better representation for GOOPS objects + - rewrite method cache management in C + - rewrite core macros (define-class et al) in C + - define C API +- write orbit CORBA interface +- [after new module system] factor out modules sort.c and random.c should be + factored out into separate modules + +=== In release 1.6.0: + +- Make sure that the deprecation mechanism explained in INSTALL and + README is completed and works. + +=== In release 1.8.0: + +- remove deprecated "scm_*_t" type names in libguile.h. + +- remove re-exporting behaviour of `export'. + in boot-9.scm, remove begin-deprecated part of `module-export!' + in format.scm, remove kluge at top + in srfi13.scm, likewise + +- remove deprecated subr and gsubr functions + in procs.h, procs.c: scm_make_subr, scm_make_subr_opt, + scm_make_subr_with_generic, + in gsubr.h, gsubr.c: scm_make_gsubr, scm_make_gsubr_with_generic. + +- remove deprecated C interface to modules + in modules.h, modules.c: + root_module_lookup_closure, scm_sym_app, scm_sym_modules, + module_prefix, make_modules_in_var, beautify_user_module_x_var, + scm_the_root_module, scm_make_module, scm_ensure_user_module, + scm_load_scheme_module + +- remove vcell and obarray support. + Remove all code bracketed by `#if SCM_ENABLE_VCELLS'. + Remove SCM_ENABLE_VCELLS itself. + Also remove `variable-set-name-hint' completely. + +- remove compatability module (ice-9 and-let*). It + has been replaced by (ice-9 and-let-star) and/or (srfi srfi-2). + +- remove support for autoloading compiled-code modules: + try-module-linked + try-module-dynamic-link + init-dynamic-module, etc. + scm_register_module_xxx + scm_registered_modules + scm_clear_registered_modules + +- remove deprecated variables: + scm_top_level_lookup_closure_var + scm_scm_system_transformer + Remove all code that still sets them: + `use-syntax', scm_set_current_module, ... + +- remove deprecated functions: + eval.c: scm_eval2, scm_eval_3 + load.c: scm_read_and_eval_x + smob.c: scm_make_smob_type_mfpe, scm_set_smob_mfpe + gc.c: scm_remember + string.c: scm_makstr, scm_makfromstr +- remove deprecated procedures: + boot-9.scm: eval-in-module, id, -1+, return-it, string-character-length, + flags +- remove deprecated macros: SCM_OUTOFRANGE, SCM_NALLOC, SCM_HUP_SIGNAL, + SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, + SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD, + SCM_ORD_SIG, SCM_NUM_SIGS, SCM_SLOPPY_STRINGP, SCM_VALIDATE_STRINGORSUBSTR, + SCM_FREEP, SCM_NFREEP, SCM_CHARS, SCM_UCHARS, SCM_VALIDATE_ROSTRING, + SCM_VALIDATE_ROSTRING_COPY, SCM_VALIDATE_NULLORROSTRING_COPY, SCM_ROLENGTH, + SCM_LENGTH, SCM_HUGE_LENGTH, SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, + SCM_COERCE_SUBSTR, SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING, + SCM_ROCHARS, SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS, SCM_LENGTH_MAX, + SCM_GC8MARKP, SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR, + SCM_SUBR_DOC, SCM_OPDIRP, SCM_VALIDATE_OPDIR, SCM_WTA, RETURN_SCM_WTA, + SCM_WNA, SCM_FUNC_NAME, SCM_VALIDATE_NUMBER_COPY, + SCM_VALIDATE_NUMBER_DEF_COPY, SCM_SLOPPY_CONSP, SCM_SLOPPY_NCONSP, + SCM_SETAND_CDR, SCM_SETOR_CDR, SCM_SETAND_CAR, SCM_SETOR_CAR, + SCM_ARRAY_CONTIGUOUS +- remove scm_vector_set_length_x +- remove function scm_call_catching_errors + (replaced by catch functions from throw.[ch]) +- remove support for "#&" reader syntax in (ice-9 optargs). +- remove scm_make_shared_substring +- remove scm_read_only_string_p +- remove scm_strhash +- remove scm_tc7_ssymbol +- remove scm_tc7_msymbol +- remove scm_tcs_symbols +- remove scm_sloppy_memq, scm_sloppy_memv, scm_sloppy_member +- consider removing the automatic loading of (ice-9 rdelim) when guile + starts up. This would be a brave move, since a lot of code will + assume that read-line is available by default. However it would make + it easier to use alternative implementations of this module, e.g., a + strictly scsh-compatible version which uses multiple values. For + interactive use it would be easy to load the module in ~/.guile. +- remove scm_close_all_ports_except +- remove scm_strprint_obj +- remove SCM_CONST_LONG +- remove scm_wta +- remove deprecated typedefs: long_long, ulong_long, scm_sizet +- remove deprecated macros: scm_contregs, scm_port_rw_active, + scm_port, scm_ptob_descriptor, scm_debug_info, scm_debug_frame, + scm_fport, SCM_FIXNUM_BIT, scm_option, scm_subr_entry, scm_rstate, + scm_rng, scm_i_rstate, scm_srcprops, scm_srcprops_chunk, + scm_info_frame, scm_stack, scm_array, scm_array_dim. +- remove deprecated functions: scm_mkbig, scm_big2num, scm_adjbig, + scm_normbig, scm_copybig, scm_2ulong2big, scm_dbl2big, scm_big2dbl. +- remove deprecated functions: scm_protect_object, + scm_unprotect_object, scm_create_hook. + +[TODO ends here] From 8141076ab0dfad73350dbeb0c0f9851ba234b3b6 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 27 Jun 2001 09:47:20 +0000 Subject: [PATCH 1381/2047] bye bye --- devel/tasks.text | 0 1 file changed, 0 insertions(+), 0 deletions(-) delete mode 100644 devel/tasks.text diff --git a/devel/tasks.text b/devel/tasks.text deleted file mode 100644 index e69de29bb..000000000 From d00f977a117cd5d2682bb39e8d9abfac5d1debc6 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 27 Jun 2001 09:48:13 +0000 Subject: [PATCH 1382/2047] Remove tasks.text. --- devel/README | 4 ---- 1 file changed, 4 deletions(-) diff --git a/devel/README b/devel/README index 2ee832339..6fb2b4ca5 100644 --- a/devel/README +++ b/devel/README @@ -11,7 +11,3 @@ translation Language traslation vm Virtual machines vm/ior Mikael's ideas on a new type of Scheme interpreter - -Files: - -tasks.text Guile project task list From 32d6f999d0823fb7d83bbdf8f24e5fb43160fbad Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 27 Jun 2001 09:53:30 +0000 Subject: [PATCH 1383/2047] *** empty log message *** --- ChangeLog | 8 +++++++- NEWS | 2 ++ devel/ChangeLog | 10 ++++++++-- 3 files changed, 17 insertions(+), 3 deletions(-) diff --git a/ChangeLog b/ChangeLog index 10e22b9b2..c77d07d6a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2001-06-27 Thien-Thi Nguyen + + * RELEASE: Move todo items to file TODO. + + * TODO: Initial revision + 2001-06-27 Michael Livshin * autogen.sh: don't run flex here. @@ -66,7 +72,7 @@ (AC_CONFIG_FILES): now generated files go here, not in AC_OUTPUT. (AC_CONFIG_COMMANDS): now actions go here, not in AC_OUTPUT. (AC_OUTPUT): no longer takes args. - + * acinclude.m4: AC_LANG not a variable now -- use __cplusplus unconditionally . diff --git a/NEWS b/NEWS index f55f70543..458906a5a 100644 --- a/NEWS +++ b/NEWS @@ -8,6 +8,8 @@ Changes since Guile 1.4: * Changes to the distribution +** A top-level TODO file is included. + ** Guile now uses a versioning scheme similar to that of the Linux kernel. Guile now always uses three numbers to represent the version, diff --git a/devel/ChangeLog b/devel/ChangeLog index 4cefcf50a..c258badce 100644 --- a/devel/ChangeLog +++ b/devel/ChangeLog @@ -1,3 +1,9 @@ +2001-06-27 Thien-Thi Nguyen + + * README: Remove tasks.text. + + * tasks.text: Bye bye (contents folded into ../TODO). + 2001-05-08 Martin Grabmueller * modules/module-snippets.texi: Fixed a lot of typos and clarified @@ -11,13 +17,13 @@ 2001-03-16 Martin Grabmueller * modules: New directory. - + * modules/module-layout.text: New file. 2000-08-26 Mikael Djurfeldt * strings: New directory. - + * strings/sharedstr.text (sharedstr.text): New file. 2000-08-12 Mikael Djurfeldt From e58f1981c5e3317fbdf5822367cb67e8c06bd0a5 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 27 Jun 2001 10:05:27 +0000 Subject: [PATCH 1384/2047] (EXTRA_DIST): Add TODO. --- Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile.am b/Makefile.am index b3df779e9..561cd8885 100644 --- a/Makefile.am +++ b/Makefile.am @@ -29,7 +29,7 @@ include_HEADERS = libguile.h # automake sometimes forgets to distribute acconfig.h, # apparently depending on the phase of the moon. -EXTRA_DIST = qthreads.m4 HACKING GUILE-VERSION ANON-CVS SNAPSHOTS \ +EXTRA_DIST = qthreads.m4 HACKING GUILE-VERSION ANON-CVS SNAPSHOTS TODO \ test-suite $(ACLOCAL) acconfig.h TESTS = check-guile From a4734913a3f7257a7fe7e5293d14847ed0502faa Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 27 Jun 2001 10:06:12 +0000 Subject: [PATCH 1385/2047] *** empty log message *** --- ChangeLog | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ChangeLog b/ChangeLog index c77d07d6a..afeb9f50b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -4,6 +4,8 @@ * TODO: Initial revision + * Makefile.am (EXTRA_DIST): Add TODO. + 2001-06-27 Michael Livshin * autogen.sh: don't run flex here. From e5fdd2dd5ecf9e200634667b9f29f548d9371f73 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 27 Jun 2001 10:15:03 +0000 Subject: [PATCH 1386/2047] Fix reference bug; recommended tool versions are in HACKING. --- SNAPSHOTS | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/SNAPSHOTS b/SNAPSHOTS index d179a4f65..459b07c0c 100644 --- a/SNAPSHOTS +++ b/SNAPSHOTS @@ -30,7 +30,7 @@ The snapshot FTP site is mirrored at the following location: To build the snapshot, you will need to have autoconf, automake, and libtool installed on your system; the recommended versions are listed -in README. +in HACKING. After you have unpacked the tar file, run the command `./autogen.sh'. This builds the configure script, Makefile.in, and other derived files From e59f9c99eb4553554e0dbcdf52c29d118ebdf033 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 27 Jun 2001 10:17:18 +0000 Subject: [PATCH 1387/2047] Refer to TODO and SNAPSHOTS. No longer refer to devel/tasks.text. --- HACKING | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/HACKING b/HACKING index 0d2353dba..e5d00414c 100644 --- a/HACKING +++ b/HACKING @@ -20,9 +20,9 @@ What to Hack ========================================================= You can hack whatever you want, thank GNU. However, to see what others have indicated as their interest (and avoid -potential wasteful duplication of effort), see devel/tasks.text. Note -that this file is available only from CVS checkout and not distributed -w/ Guile releases. +potential wasteful duplication of effort), see file TODO. Note that +the version you find may be out of date; a CVS checkout is recommended +(see also file SNAPSHOTS). It's also a good idea to join the guile-devel@gnu.org mailing list. See http://www.gnu.org/software/guile/mail/mail.html for more info. @@ -319,7 +319,7 @@ them in THANKS. s - a constant C string - + Helpful hints ======================================================== From dbfadc85884aadbe0b905b66e2ff62200c2758a1 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 27 Jun 2001 10:18:36 +0000 Subject: [PATCH 1388/2047] *** empty log message *** --- ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/ChangeLog b/ChangeLog index afeb9f50b..1f4fe7505 100644 --- a/ChangeLog +++ b/ChangeLog @@ -6,6 +6,12 @@ * Makefile.am (EXTRA_DIST): Add TODO. + * HACKING: Refer to TODO and SNAPSHOTS. + No longer refer to devel/tasks.text. + + * SNAPSHOTS: Fix reference bug; recommended tool + versions are in HACKING. + 2001-06-27 Michael Livshin * autogen.sh: don't run flex here. From b858464a0a34381caf8661ec32a27bb94ce8c6cc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 27 Jun 2001 13:15:20 +0000 Subject: [PATCH 1389/2047] * read.c (scm_lreadr): When reading a hash token, check for a user-defined hash procedure first, so that overriding the builtin hash characters is possible (this was needed for implementing SRFI-4's read synax `f32(...)'). * num2integral.i.c: Use scm_t_signed_bits instead of scm_t_bits, because the latter is unsigned now and breaks comparisons like (n < (scm_t_signed_bits)MIN_VALUE). --- libguile/ChangeLog | 11 +++++++ libguile/num2integral.i.c | 10 +++--- libguile/read.c | 65 ++++++++++++++++++++++++++------------- 3 files changed, 59 insertions(+), 27 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 7d0f808c2..6458869ef 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2001-06-27 Martin Grabmueller + + * read.c (scm_lreadr): When reading a hash token, check for a + user-defined hash procedure first, so that overriding the builtin + hash characters is possible (this was needed for implementing + SRFI-4's read synax `f32(...)'). + + * num2integral.i.c: Use scm_t_signed_bits instead of scm_t_bits, + because the latter is unsigned now and breaks comparisons like + (n < (scm_t_signed_bits)MIN_VALUE). + 2001-06-26 Neil Jerram * eval.h, eval.c (scm_call_4): New function. diff --git a/libguile/num2integral.i.c b/libguile/num2integral.i.c index 5498c2828..f273eef89 100644 --- a/libguile/num2integral.i.c +++ b/libguile/num2integral.i.c @@ -6,22 +6,22 @@ NUM2INTEGRAL (SCM num, unsigned long int pos, const char *s_caller) if (SCM_INUMP (num)) { /* immediate */ - scm_t_bits n = SCM_INUM (num); + scm_t_signed_bits n = SCM_INUM (num); #ifdef UNSIGNED if (n < 0) scm_out_of_range (s_caller, num); #endif - if (sizeof (ITYPE) >= sizeof (scm_t_bits)) + if (sizeof (ITYPE) >= sizeof (scm_t_signed_bits)) /* can't fit anything too big for this type in an inum anyway */ return (ITYPE) n; else { /* an inum can be out of range, so check */ - if (n > (scm_t_bits)MAX_VALUE + if (n > (scm_t_signed_bits)MAX_VALUE #ifndef UNSIGNED - || n < (scm_t_bits)MIN_VALUE + || n < (scm_t_signed_bits)MIN_VALUE #endif ) scm_out_of_range (s_caller, num); @@ -84,7 +84,7 @@ NUM2INTEGRAL (SCM num, unsigned long int pos, const char *s_caller) SCM INTEGRAL2NUM (ITYPE n) { - if (sizeof (ITYPE) < sizeof (scm_t_bits) + if (sizeof (ITYPE) < sizeof (scm_t_signed_bits) || #ifndef UNSIGNED SCM_FIXABLE (n) diff --git a/libguile/read.c b/libguile/read.c index 214118473..a7e690a1e 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -289,9 +289,9 @@ scm_lreadr (SCM *tok_buf,SCM port,SCM *copy) size_t j; SCM p; -tryagain: + tryagain: c = scm_flush_ws (port, s_scm_read); -tryagain_no_flush_ws: + tryagain_no_flush_ws: switch (c) { case EOF: @@ -299,8 +299,8 @@ tryagain_no_flush_ws: case '(': return SCM_RECORD_POSITIONS_P - ? scm_lreadrecparen (tok_buf, port, s_list, copy) - : scm_lreadparen (tok_buf, port, s_list, copy); + ? scm_lreadrecparen (tok_buf, port, s_list, copy) + : scm_lreadparen (tok_buf, port, s_list, copy); case ')': SCM_MISC_ERROR ("unexpected \")\"", SCM_EOL); goto tryagain; @@ -339,6 +339,27 @@ tryagain_no_flush_ws: return p; case '#': c = scm_getc (port); + + { + /* Check for user-defined hash procedure first, to allow + overriding of builtin hash read syntaxes. */ + SCM sharp = scm_get_hash_procedure (c); + if (!SCM_FALSEP (sharp)) + { + int line = SCM_LINUM (port); + int column = SCM_COL (port) - 2; + SCM got; + + got = scm_call_2 (sharp, SCM_MAKE_CHAR (c), port); + if (SCM_EQ_P (got, SCM_UNSPECIFIED)) + goto unkshrp; + if (SCM_RECORD_POSITIONS_P) + return *copy = recsexpr (got, line, column, + SCM_FILENAME (port)); + else + return got; + } + } switch (c) { case '(': @@ -435,8 +456,8 @@ tryagain_no_flush_ws: } } unkshrp: - scm_misc_error (s_scm_read, "Unknown # object: ~S", - SCM_LIST1 (SCM_MAKE_CHAR (c))); + scm_misc_error (s_scm_read, "Unknown # object: ~S", + SCM_LIST1 (SCM_MAKE_CHAR (c))); } case '"': @@ -484,27 +505,27 @@ tryagain_no_flush_ws: SCM_STRING_CHARS (*tok_buf)[j] = 0; return scm_mem2string (SCM_STRING_CHARS (*tok_buf), j); - case'0':case '1':case '2':case '3':case '4': + case'0':case '1':case '2':case '3':case '4': case '5':case '6':case '7':case '8':case '9': case '.': case '-': case '+': num: - j = scm_read_token (c, tok_buf, port, 0); - p = scm_istring2number (SCM_STRING_CHARS (*tok_buf), (long) j, 10L); - if (!SCM_FALSEP (p)) - return p; - if (c == '#') - { - if ((j == 2) && (scm_getc (port) == '(')) - { - scm_ungetc ('(', port); - c = SCM_STRING_CHARS (*tok_buf)[1]; - goto callshrp; - } - SCM_MISC_ERROR ("unknown # object", SCM_EOL); - } - goto tok; + j = scm_read_token (c, tok_buf, port, 0); + p = scm_istring2number (SCM_STRING_CHARS (*tok_buf), (long) j, 10L); + if (!SCM_FALSEP (p)) + return p; + if (c == '#') + { + if ((j == 2) && (scm_getc (port) == '(')) + { + scm_ungetc ('(', port); + c = SCM_STRING_CHARS (*tok_buf)[1]; + goto callshrp; + } + SCM_MISC_ERROR ("unknown # object", SCM_EOL); + } + goto tok; case ':': if (SCM_EQ_P (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_prefix)) From 39cb0b041d27f88aa76f51df20f632674320ec62 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 27 Jun 2001 13:17:12 +0000 Subject: [PATCH 1390/2047] * tests/srfi-4.test: New file. --- test-suite/ChangeLog | 4 + test-suite/tests/srfi-4.test | 312 +++++++++++++++++++++++++++++++++++ 2 files changed, 316 insertions(+) create mode 100644 test-suite/tests/srfi-4.test diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index afb2667f5..ef4440c55 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2001-06-27 Martin Grabmueller + + * tests/srfi-4.test: New file. + 2001-06-16 Marius Vollmer Thanks to Matthias Köppe! diff --git a/test-suite/tests/srfi-4.test b/test-suite/tests/srfi-4.test new file mode 100644 index 000000000..ac6ce3792 --- /dev/null +++ b/test-suite/tests/srfi-4.test @@ -0,0 +1,312 @@ +;;;; srfi-4.test --- Test suite for Guile's SRFI-4 functions. -*- scheme -*- +;;;; Martin Grabmueller, 2001-06-26 +;;;; +;;;; Copyright (C) 2001 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +(use-modules (srfi srfi-4)) + +(with-test-prefix "u8 vectors" + + (pass-if "u8vector? success" + (u8vector? (u8vector))) + + (pass-if "u8vector? failure" + (not (u8vector? (s8vector)))) + + (pass-if "u8vector-length success 1" + (= (u8vector-length (u8vector)) 0)) + + (pass-if "u8vector-length success 2" + (= (u8vector-length (u8vector 3)) 1)) + + (pass-if "u8vector-length failure" + (not (= (u8vector-length (u8vector 3)) 3))) + + (pass-if "u8vector-ref" + (= (u8vector-ref (u8vector 1 2 3) 1) 2)) + + (pass-if "u8vector-set!/ref" + (= (let ((s (make-u8vector 10 0))) + (u8vector-set! s 4 33) + (u8vector-ref s 4)) 33)) + + (pass-if "u8vector->list/list->u8vector" + (equal? (u8vector->list (u8vector 1 2 3 4)) + (u8vector->list (list->u8vector '(1 2 3 4)))))) + +(with-test-prefix "s8 vectors" + + (pass-if "s8vector? success" + (s8vector? (s8vector))) + + (pass-if "s8vector? failure" + (not (s8vector? (u8vector)))) + + (pass-if "s8vector-length success 1" + (= (s8vector-length (s8vector)) 0)) + + (pass-if "s8vector-length success 2" + (= (s8vector-length (s8vector -3)) 1)) + + (pass-if "s8vector-length failure" + (not (= (s8vector-length (s8vector 3)) 3))) + + (pass-if "s8vector-ref" + (= (s8vector-ref (s8vector 1 2 3) 1) 2)) + + (pass-if "s8vector-set!/ref" + (= (let ((s (make-s8vector 10 0))) + (s8vector-set! s 4 33) + (s8vector-ref s 4)) 33)) + + (pass-if "s8vector->list/list->s8vector" + (equal? (s8vector->list (s8vector 1 2 3 4)) + (s8vector->list (list->s8vector '(1 2 3 4)))))) + + +(with-test-prefix "u16 vectors" + + (pass-if "u16vector? success" + (u16vector? (u16vector))) + + (pass-if "u16vector? failure" + (not (u16vector? (s16vector)))) + + (pass-if "u16vector-length success 1" + (= (u16vector-length (u16vector)) 0)) + + (pass-if "u16vector-length success 2" + (= (u16vector-length (u16vector 3)) 1)) + + (pass-if "u16vector-length failure" + (not (= (u16vector-length (u16vector 3)) 3))) + + (pass-if "u16vector-ref" + (= (u16vector-ref (u16vector 1 2 3) 1) 2)) + + (pass-if "u16vector-set!/ref" + (= (let ((s (make-u16vector 10 0))) + (u16vector-set! s 4 33) + (u16vector-ref s 4)) 33)) + + (pass-if "u16vector->list/list->u16vector" + (equal? (u16vector->list (u16vector 1 2 3 4)) + (u16vector->list (list->u16vector '(1 2 3 4)))))) + +(with-test-prefix "s16 vectors" + + (pass-if "s16vector? success" + (s16vector? (s16vector))) + + (pass-if "s16vector? failure" + (not (s16vector? (u16vector)))) + + (pass-if "s16vector-length success 1" + (= (s16vector-length (s16vector)) 0)) + + (pass-if "s16vector-length success 2" + (= (s16vector-length (s16vector -3)) 1)) + + (pass-if "s16vector-length failure" + (not (= (s16vector-length (s16vector 3)) 3))) + + (pass-if "s16vector-ref" + (= (s16vector-ref (s16vector 1 2 3) 1) 2)) + + (pass-if "s16vector-set!/ref" + (= (let ((s (make-s16vector 10 0))) + (s16vector-set! s 4 33) + (s16vector-ref s 4)) 33)) + + (pass-if "s16vector->list/list->s16vector" + (equal? (s16vector->list (s16vector 1 2 3 4)) + (s16vector->list (list->s16vector '(1 2 3 4)))))) + +(with-test-prefix "u32 vectors" + + (pass-if "u32vector? success" + (u32vector? (u32vector))) + + (pass-if "u32vector? failure" + (not (u32vector? (s32vector)))) + + (pass-if "u32vector-length success 1" + (= (u32vector-length (u32vector)) 0)) + + (pass-if "u32vector-length success 2" + (= (u32vector-length (u32vector 3)) 1)) + + (pass-if "u32vector-length failure" + (not (= (u32vector-length (u32vector 3)) 3))) + + (pass-if "u32vector-ref" + (= (u32vector-ref (u32vector 1 2 3) 1) 2)) + + (pass-if "u32vector-set!/ref" + (= (let ((s (make-u32vector 10 0))) + (u32vector-set! s 4 33) + (u32vector-ref s 4)) 33)) + + (pass-if "u32vector->list/list->u32vector" + (equal? (u32vector->list (u32vector 1 2 3 4)) + (u32vector->list (list->u32vector '(1 2 3 4)))))) + +(with-test-prefix "s32 vectors" + + (pass-if "s32vector? success" + (s32vector? (s32vector))) + + (pass-if "s32vector? failure" + (not (s32vector? (u32vector)))) + + (pass-if "s32vector-length success 1" + (= (s32vector-length (s32vector)) 0)) + + (pass-if "s32vector-length success 2" + (= (s32vector-length (s32vector -3)) 1)) + + (pass-if "s32vector-length failure" + (not (= (s32vector-length (s32vector 3)) 3))) + + (pass-if "s32vector-ref" + (= (s32vector-ref (s32vector 1 2 3) 1) 2)) + + (pass-if "s32vector-set!/ref" + (= (let ((s (make-s32vector 10 0))) + (s32vector-set! s 4 33) + (s32vector-ref s 4)) 33)) + + (pass-if "s32vector->list/list->s32vector" + (equal? (s32vector->list (s32vector 1 2 3 4)) + (s32vector->list (list->s32vector '(1 2 3 4)))))) + +(with-test-prefix "u64 vectors" + + (pass-if "u64vector? success" + (u64vector? (u64vector))) + + (pass-if "u64vector? failure" + (not (u64vector? (s64vector)))) + + (pass-if "u64vector-length success 1" + (= (u64vector-length (u64vector)) 0)) + + (pass-if "u64vector-length success 2" + (= (u64vector-length (u64vector 3)) 1)) + + (pass-if "u64vector-length failure" + (not (= (u64vector-length (u64vector 3)) 3))) + + (pass-if "u64vector-ref" + (= (u64vector-ref (u64vector 1 2 3) 1) 2)) + + (pass-if "u64vector-set!/ref" + (= (let ((s (make-u64vector 10 0))) + (u64vector-set! s 4 33) + (u64vector-ref s 4)) 33)) + + (pass-if "u64vector->list/list->u64vector" + (equal? (u64vector->list (u64vector 1 2 3 4)) + (u64vector->list (list->u64vector '(1 2 3 4)))))) + +(with-test-prefix "s64 vectors" + + (pass-if "s64vector? success" + (s64vector? (s64vector))) + + (pass-if "s64vector? failure" + (not (s64vector? (u64vector)))) + + (pass-if "s64vector-length success 1" + (= (s64vector-length (s64vector)) 0)) + + (pass-if "s64vector-length success 2" + (= (s64vector-length (s64vector -3)) 1)) + + (pass-if "s64vector-length failure" + (not (= (s64vector-length (s64vector 3)) 3))) + + (pass-if "s64vector-ref" + (= (s64vector-ref (s64vector 1 2 3) 1) 2)) + + (pass-if "s64vector-set!/ref" + (= (let ((s (make-s64vector 10 0))) + (s64vector-set! s 4 33) + (s64vector-ref s 4)) 33)) + + (pass-if "s64vector->list/list->s64vector" + (equal? (s64vector->list (s64vector 1 2 3 4)) + (s64vector->list (list->s64vector '(1 2 3 4)))))) + +(with-test-prefix "f32 vectors" + + (pass-if "f32vector? success" + (f32vector? (f32vector))) + + (pass-if "f32vector? failure" + (not (f32vector? (s8vector)))) + + (pass-if "f32vector-length success 1" + (= (f32vector-length (f32vector)) 0)) + + (pass-if "f32vector-length success 2" + (= (f32vector-length (f32vector -3)) 1)) + + (pass-if "f32vector-length failure" + (not (= (f32vector-length (f32vector 3)) 3))) + + (pass-if "f32vector-ref" + (= (f32vector-ref (f32vector 1 2 3) 1) 2)) + + (pass-if "f32vector-set!/ref" + (= (let ((s (make-f32vector 10 0))) + (f32vector-set! s 4 33) + (f32vector-ref s 4)) 33)) + + (pass-if "f32vector->list/list->f32vector" + (equal? (f32vector->list (f32vector 1 2 3 4)) + (f32vector->list (list->f32vector '(1 2 3 4)))))) + +(with-test-prefix "f64 vectors" + + (pass-if "f64vector? success" + (f64vector? (f64vector))) + + (pass-if "f64vector? failure" + (not (f64vector? (f32vector)))) + + (pass-if "f64vector-length success 1" + (= (f64vector-length (f64vector)) 0)) + + (pass-if "f64vector-length success 2" + (= (f64vector-length (f64vector -3)) 1)) + + (pass-if "f64vector-length failure" + (not (= (f64vector-length (f64vector 3)) 3))) + + (pass-if "f64vector-ref" + (= (f64vector-ref (f64vector 1 2 3) 1) 2)) + + (pass-if "f64vector-set!/ref" + (= (let ((s (make-f64vector 10 0))) + (f64vector-set! s 4 33) + (f64vector-ref s 4)) 33)) + + (pass-if "f64vector->list/list->f64vector" + (equal? (f64vector->list (f64vector 1 2 3 4)) + (f64vector->list (list->f64vector '(1 2 3 4)))))) From 71ca65d982b879f94ed87899335a19c1ff9b9728 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 27 Jun 2001 13:18:40 +0000 Subject: [PATCH 1391/2047] * Makefile.am: Added SRFI-4 files in various places. * srfi-4.c, srfi-4.h, srfi-4.scm: New files implementing SRFI-4. --- srfi/ChangeLog | 6 + srfi/Makefile.am | 8 +- srfi/srfi-4.c | 2150 ++++++++++++++++++++++++++++++++++++++++++++++ srfi/srfi-4.h | 141 +++ srfi/srfi-4.scm | 200 +++++ 5 files changed, 2503 insertions(+), 2 deletions(-) create mode 100644 srfi/srfi-4.c create mode 100644 srfi/srfi-4.h create mode 100644 srfi/srfi-4.scm diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 05c1c1998..0984f87bb 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,9 @@ +2001-06-27 Martin Grabmueller + + * Makefile.am: Added SRFI-4 files in various places. + + * srfi-4.c, srfi-4.h, srfi-4.scm: New files implementing SRFI-4. + 2001-06-26 Dirk Herrmann * srfi-13.c (scm_string_copyS, scm_string_take, scm_string_drop, diff --git a/srfi/Makefile.am b/srfi/Makefile.am index 188688cd5..8340ab1b2 100644 --- a/srfi/Makefile.am +++ b/srfi/Makefile.am @@ -29,16 +29,20 @@ DEFS = @DEFS@ INCLUDES = -I.. -I$(srcdir)/.. -lib_LTLIBRARIES = libguile-srfi-srfi-13-14.la +lib_LTLIBRARIES = libguile-srfi-srfi-13-14.la libguile-srfi-srfi-4.la -BUILT_SOURCES = srfi-13.x srfi-14.x +BUILT_SOURCES = srfi-13.x srfi-14.x srfi-4.x libguile_srfi_srfi_13_14_la_SOURCES = srfi-13.x srfi-13.c srfi-14.x srfi-14.c\ srfi-13.h srfi-14.h libguile_srfi_srfi_13_14_la_LDFLAGS = -version-info 0:0 -export-dynamic +libguile_srfi_srfi_4_la_SOURCES = srfi-4.x srfi-4.c srfi-4.h +libguile_srfi_srfi_4_la_LDFLAGS = -version-info 0:0 -export-dynamic + srfidir = $(datadir)/guile/$(VERSION)/srfi srfi_DATA = srfi-1.scm \ srfi-2.scm \ + srfi-4.scm \ srfi-6.scm \ srfi-8.scm \ srfi-9.scm \ diff --git a/srfi/srfi-4.c b/srfi/srfi-4.c new file mode 100644 index 000000000..da3025e1d --- /dev/null +++ b/srfi/srfi-4.c @@ -0,0 +1,2150 @@ +/* srfi-4.c --- Homogeneous numeric vector datatypes. + * + * Copyright (C) 2001 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives + * permission for additional uses of the text contained in its release + * of GUILE. + * + * The exception is that, if you link the GUILE library with other + * files to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public + * License. Your use of that executable is in no way restricted on + * account of linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public + * License. + * + * This exception applies only to the code released by the Free + * Software Foundation under the name GUILE. If you copy code from + * other Free Software Foundation releases into a copy of GUILE, as + * the General Public License permits, the exception does not apply to + * the code that you add in this way. To avoid misleading anyone as + * to the status of such modified files, you must delete this + * exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +#include + +#include "srfi-4.h" + + +/* For brevity and maintainability, we define our own types for the + various integer and floating point types. */ +typedef unsigned char int_u8; +typedef signed char int_s8; +typedef unsigned short int_u16; +typedef signed short int_s16; +typedef unsigned int int_u32; +typedef signed int int_s32; +#if HAVE_LONG_LONGS +#if SIZEOF_LONG == 8 +typedef unsigned long int_u64; +typedef signed long int_s64; +#else +typedef unsigned long long int_u64; +typedef signed long long int_s64; +#endif /* SIZEOF_LONG */ +#endif /* HAVE_LONG_LONGS */ +typedef float float_f32; +typedef double float_f64; + +/* Smob type code for homogeneous numeric vectors. */ +int scm_tc16_uvec = 0; + + +/* Accessor macros for the three components of a homogeneous numeric + vector: + - The type tag (one of the symbolic constants below). + - The vector's length (counted in elements). + - The address of the data area (holding the elements of the + vector). */ +#define SCM_UVEC_TYPE(u) (SCM_CELL_WORD_1(u)) +#define SCM_UVEC_LENGTH(u) (SCM_CELL_WORD_2(u)) +#define SCM_UVEC_BASE(u) (SCM_CELL_OBJECT_3(u)) + + +/* Symbolic constants encoding the various types of homogeneous + numeric vectors. */ +#define SCM_UVEC_U8 0 +#define SCM_UVEC_S8 1 +#define SCM_UVEC_U16 2 +#define SCM_UVEC_S16 3 +#define SCM_UVEC_U32 4 +#define SCM_UVEC_S32 5 +#define SCM_UVEC_U64 6 +#define SCM_UVEC_S64 7 +#define SCM_UVEC_F32 8 +#define SCM_UVEC_F64 9 + + +/* This array maps type tags to the size of the elements. */ +static int uvec_sizes[10] = {1, 1, 2, 2, 4, 4, 8, 8, 4, 8}; + + +/* ================================================================ */ +/* SMOB procedures. */ +/* ================================================================ */ + + +/* Smob print hook for homogeneous vectors. */ +static int +uvec_print (SCM uvec, SCM port, scm_print_state *pstate SCM_UNUSED) +{ + switch (SCM_UVEC_TYPE (uvec)) + { + case SCM_UVEC_U8: + { + int_u8 * p = (int_u8 *) SCM_UVEC_BASE (uvec); + int i = 0; + + scm_puts ("#u8(", port); + if (SCM_UVEC_LENGTH (uvec) > 0) + { + scm_intprint (*p, 10, port); + p++; + i++; + for (; i < SCM_UVEC_LENGTH (uvec); i++) + { + scm_puts (" ", port); + scm_intprint (*p, 10, port); + p++; + } + } + scm_puts (")", port); + break; + } + + case SCM_UVEC_S8: + { + int_s8 * p = (int_s8 *) SCM_UVEC_BASE (uvec); + int i = 0; + + scm_puts ("#s8(", port); + if (SCM_UVEC_LENGTH (uvec) > 0) + { + scm_intprint (*p, 10, port); + p++; + i++; + for (; i < SCM_UVEC_LENGTH (uvec); i++) + { + scm_puts (" ", port); + scm_intprint (*p, 10, port); + p++; + } + } + scm_puts (")", port); + break; + } + + case SCM_UVEC_U16: + { + int_u16 * p = (int_u16 *) SCM_UVEC_BASE (uvec); + int i = 0; + + scm_puts ("#u16(", port); + if (SCM_UVEC_LENGTH (uvec) > 0) + { + scm_intprint (*p, 10, port); + p++; + i++; + for (; i < SCM_UVEC_LENGTH (uvec); i++) + { + scm_puts (" ", port); + scm_intprint (*p, 10, port); + p++; + } + } + scm_puts (")", port); + break; + } + + case SCM_UVEC_S16: + { + int_s16 * p = (int_s16 *) SCM_UVEC_BASE (uvec); + int i = 0; + + scm_puts ("#s16(", port); + if (SCM_UVEC_LENGTH (uvec) > 0) + { + scm_intprint (*p, 10, port); + p++; + i++; + for (; i < SCM_UVEC_LENGTH (uvec); i++) + { + scm_puts (" ", port); + scm_intprint (*p, 10, port); + p++; + } + } + scm_puts (")", port); + break; + } + + case SCM_UVEC_U32: + { + int_u32 * p = (int_u32 *) SCM_UVEC_BASE (uvec); + int i = 0; + + scm_puts ("#u32(", port); + if (SCM_UVEC_LENGTH (uvec) > 0) + { + scm_intprint (*p, 10, port); + p++; + i++; + for (; i < SCM_UVEC_LENGTH (uvec); i++) + { + scm_puts (" ", port); + scm_intprint (*p, 10, port); + p++; + } + } + scm_puts (")", port); + break; + } + + case SCM_UVEC_S32: + { + int_s32 * p = (int_s32 *) SCM_UVEC_BASE (uvec); + int i = 0; + + scm_puts ("#s32(", port); + if (SCM_UVEC_LENGTH (uvec) > 0) + { + scm_intprint (*p, 10, port); + p++; + i++; + for (; i < SCM_UVEC_LENGTH (uvec); i++) + { + scm_puts (" ", port); + scm_intprint (*p, 10, port); + p++; + } + } + scm_puts (")", port); + break; + } + +#if HAVE_LONG_LONGS + case SCM_UVEC_U64: + { + int_u64 * p = (int_u64 *) SCM_UVEC_BASE (uvec); + int i = 0; + + scm_puts ("#u64(", port); + if (SCM_UVEC_LENGTH (uvec) > 0) + { + scm_intprint (*p, 10, port); + p++; + i++; + for (; i < SCM_UVEC_LENGTH (uvec); i++) + { + scm_puts (" ", port); + scm_intprint (*p, 10, port); + p++; + } + } + scm_puts (")", port); + break; + } + + case SCM_UVEC_S64: + { + int_s64 * p = (int_s64 *) SCM_UVEC_BASE (uvec); + int i = 0; + + scm_puts ("#s64(", port); + if (SCM_UVEC_LENGTH (uvec) > 0) + { + scm_intprint (*p, 10, port); + p++; + i++; + for (; i < SCM_UVEC_LENGTH (uvec); i++) + { + scm_puts (" ", port); + scm_intprint (*p, 10, port); + p++; + } + } + scm_puts (")", port); + break; + } +#endif + + case SCM_UVEC_F32: + { + float_f32 * p = (float_f32 *) SCM_UVEC_BASE (uvec); + int i = 0; + + scm_puts ("#f32(", port); + if (SCM_UVEC_LENGTH (uvec) > 0) + { + scm_iprin1 (scm_make_real (*p), port, pstate); + p++; + i++; + for (; i < SCM_UVEC_LENGTH (uvec); i++) + { + scm_puts (" ", port); + scm_iprin1 (scm_make_real (*p), port, pstate); + p++; + } + } + scm_puts (")", port); + break; + } + + case SCM_UVEC_F64: + { + float_f64 * p = (float_f64 *) SCM_UVEC_BASE (uvec); + int i = 0; + + scm_puts ("#f64(", port); + if (SCM_UVEC_LENGTH (uvec) > 0) + { + scm_iprin1 (scm_make_real (*p), port, pstate); + p++; + i++; + for (; i < SCM_UVEC_LENGTH (uvec); i++) + { + scm_puts (" ", port); + scm_iprin1 (scm_make_real (*p), port, pstate); + p++; + } + } + scm_puts (")", port); + break; + } + + default: + abort (); /* Sanity check. */ + } + return 1; +} + + +/* Smob free hook for homogeneous numeric vectors. */ +static size_t +uvec_free (SCM uvec) +{ + scm_must_free (SCM_UVEC_BASE (uvec)); + return SCM_UVEC_LENGTH (uvec) * uvec_sizes[SCM_UVEC_TYPE (uvec)]; +} + + +/* ================================================================ */ +/* Utility procedures. */ +/* ================================================================ */ + + +/* Create a new, uninitialized homogeneous numeric vector of type TYPE + with space for LEN elements. */ +static SCM +make_uvec (const char * func_name, int type, int len) +{ + void * p; + + p = scm_must_malloc (len * uvec_sizes[type], func_name); + SCM_RETURN_NEWSMOB3 (scm_tc16_uvec, type, len, p); +} + + +/* ================================================================ */ +/* U8 procedures. */ +/* ================================================================ */ + + +SCM_DEFINE (scm_u8vector_p, "u8vector?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a vector of type u8,\n" + "@code{#f} otherwise.") +#define FUNC_NAME s_scm_u8vector_p +{ + return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) && + SCM_UVEC_TYPE (obj) == SCM_UVEC_U8); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_make_u8vector, "make-u8vector", 1, 1, 0, + (SCM n, SCM fill), + "Create a newly allocated homogeneous numeric vector which can\n" + "hold @var{len} elements. If @var{fill} is given, it is used to\n" + "initialize the elements, otherwise the contents of the vector\n" + "is unspecified.") +#define FUNC_NAME s_scm_make_u8vector +{ + SCM uvec; + int_u8 * p; + int_u8 f; + int count; + + SCM_VALIDATE_INUM (1, n); + count = SCM_INUM (n); + uvec = make_uvec (FUNC_NAME, SCM_UVEC_U8, count); + if (SCM_UNBNDP (fill)) + f = 0; + else + { + unsigned int s = scm_num2uint (fill, 2, FUNC_NAME); + f = s; + if ((unsigned int) f != s) + scm_out_of_range_pos (FUNC_NAME, fill, SCM_MAKINUM (2)); + } + p = (int_u8 *) SCM_UVEC_BASE (uvec); + while (count-- > 0) + *p++ = f; + return uvec; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_u8vector, "u8vector", 0, 0, 1, + (SCM l), + "Create a newly allocated homogeneous numeric vector containing\n" + "all argument values.") +#define FUNC_NAME s_scm_u8vector +{ + SCM_VALIDATE_REST_ARGUMENT (l); + return scm_list_to_u8vector (l); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_u8vector_length, "u8vector-length", 1, 0, 0, + (SCM uvec), + "Return the number of elements in the homogeneous numeric vector\n" + "@var{uvec}.") +#define FUNC_NAME s_scm_u8vector_length +{ + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U8) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + return scm_int2num (SCM_UVEC_LENGTH (uvec)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_u8vector_ref, "u8vector-ref", 2, 0, 0, + (SCM uvec, SCM index), + "Return the element at @var{index} in the homogeneous numeric\n" + "vector @var{uvec}.") +#define FUNC_NAME s_scm_u8vector_ref +{ + int idx; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U8) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = scm_num2int (index, 2, FUNC_NAME); + if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec)) + scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2)); + + return scm_short2num (((int_u8 *) SCM_UVEC_BASE (uvec))[idx]); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_u8vector_set_x, "u8vector-set!", 3, 0, 0, + (SCM uvec, SCM index, SCM value), + "Set the element at @var{index} in the homogeneous numeric\n" + "vector @var{uvec} to @var{value}. The return value is not\n" + "specified.") +#define FUNC_NAME s_scm_u8vector_ref +{ + int idx; + int_u8 f; + unsigned int s; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U8) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = scm_num2int (index, 2, FUNC_NAME); + if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec)) + scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2)); + + s = scm_num2uint (value, 3, FUNC_NAME); + f = s; + if ((unsigned int) f != s) + scm_out_of_range_pos (FUNC_NAME, value, SCM_MAKINUM (3)); + + ((int_u8 *) SCM_UVEC_BASE (uvec))[idx] = f; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_u8vector_to_list, "u8vector->list", 1, 0, 0, + (SCM uvec), + "Convert the homogeneous numeric vector @var{uvec} to a list.") +#define FUNC_NAME s_scm_u8vector_to_list +{ + int idx; + int_u8 * p; + SCM res = SCM_EOL; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U8) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = SCM_UVEC_LENGTH (uvec); + p = (int_u8 *) SCM_UVEC_BASE (uvec) + idx; + while (idx-- > 0) + { + p--; + res = scm_cons (SCM_MAKINUM (*p), res); + } + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_list_to_u8vector, "list->u8vector", 1, 0, 0, + (SCM l), + "Convert the list @var{l}, which must only contain unsigned\n" + "8-bit values, to a numeric homogeneous vector.") +#define FUNC_NAME s_scm_list_to_u8vector +{ + SCM uvec; + SCM tmp; + int_u8 * p; + int n; + int arg_pos = 1; + + SCM_VALIDATE_LIST_COPYLEN (1, l, n); + + uvec = make_uvec (FUNC_NAME, SCM_UVEC_U8, n); + p = (int_u8 *) SCM_UVEC_BASE (uvec); + tmp = l; + while (SCM_CONSP (tmp)) + { + int_u8 f; + unsigned int s = scm_num2uint (SCM_CAR (tmp), 2, FUNC_NAME); + f = s; + if ((unsigned int) f != s) + scm_out_of_range (FUNC_NAME, SCM_CAR (tmp)); + *p++ = f; + tmp = SCM_CDR (tmp); + arg_pos++; + } + scm_remember_upto_here_1 (l); + return uvec; +} +#undef FUNC_NAME + + +/* ================================================================ */ +/* S8 procedures. */ +/* ================================================================ */ + + +SCM_DEFINE (scm_s8vector_p, "s8vector?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a vector of type s8,\n" + "@code{#f} otherwise.") +#define FUNC_NAME s_scm_s8vector_p +{ + return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) && + SCM_UVEC_TYPE (obj) == SCM_UVEC_S8); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_make_s8vector, "make-s8vector", 1, 1, 0, + (SCM n, SCM fill), + "Create a newly allocated homogeneous numeric vector which can\n" + "hold @var{len} elements. If @var{fill} is given, it is used to\n" + "initialize the elements, otherwise the contents of the vector\n" + "is unspecified.") +#define FUNC_NAME s_scm_make_s8vector +{ + SCM uvec; + int_s8 * p; + int_s8 f; + int count; + + SCM_VALIDATE_INUM (1, n); + count = SCM_INUM (n); + uvec = make_uvec (FUNC_NAME, SCM_UVEC_S8, count); + if (SCM_UNBNDP (fill)) + f = 0; + else + { + signed int s = scm_num2int (fill, 2, FUNC_NAME); + f = s; + if ((signed int) f != s) + scm_out_of_range_pos (FUNC_NAME, fill, SCM_MAKINUM (2)); + } + p = (int_s8 *) SCM_UVEC_BASE (uvec); + while (count-- > 0) + *p++ = f; + return uvec; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_s8vector, "s8vector", 0, 0, 1, + (SCM l), + "Create a newly allocated homogeneous numeric vector containing\n" + "all argument values.") +#define FUNC_NAME s_scm_s8vector +{ + SCM_VALIDATE_REST_ARGUMENT (l); + return scm_list_to_s8vector (l); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_s8vector_length, "s8vector-length", 1, 0, 0, + (SCM uvec), + "Return the number of elements in the homogeneous numeric vector\n" + "@var{uvec}.") +#define FUNC_NAME s_scm_s8vector_length +{ + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S8) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + return scm_int2num (SCM_UVEC_LENGTH (uvec)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_s8vector_ref, "s8vector-ref", 2, 0, 0, + (SCM uvec, SCM index), + "Return the element at @var{index} in the homogeneous numeric\n" + "vector @var{uvec}.") +#define FUNC_NAME s_scm_s8vector_ref +{ + int idx; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S8) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = scm_num2int (index, 2, FUNC_NAME); + if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec)) + scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2)); + + return scm_short2num (((int_s8 *) SCM_UVEC_BASE (uvec))[idx]); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_s8vector_set_x, "s8vector-set!", 3, 0, 0, + (SCM uvec, SCM index, SCM value), + "Set the element at @var{index} in the homogeneous numeric\n" + "vector @var{uvec} to @var{value}. The return value is not\n" + "specified.") +#define FUNC_NAME s_scm_s8vector_ref +{ + int idx; + int_s8 f; + signed int s; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S8) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = scm_num2int (index, 2, FUNC_NAME); + if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec)) + scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2)); + + s = scm_num2int (value, 3, FUNC_NAME); + f = s; + if ((signed int) f != s) + scm_out_of_range_pos (FUNC_NAME, value, SCM_MAKINUM (3)); + + ((int_s8 *) SCM_UVEC_BASE (uvec))[idx] = f; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_s8vector_to_list, "s8vector->list", 1, 0, 0, + (SCM uvec), + "Convert the homogeneous numeric vector @var{uvec} to a list.") +#define FUNC_NAME s_scm_s8vector_to_list +{ + int idx; + int_s8 * p; + SCM res = SCM_EOL; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S8) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = SCM_UVEC_LENGTH (uvec); + p = (int_s8 *) SCM_UVEC_BASE (uvec) + idx; + while (idx-- > 0) + { + p--; + res = scm_cons (SCM_MAKINUM (*p), res); + } + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_list_to_s8vector, "list->s8vector", 1, 0, 0, + (SCM l), + "Convert the list @var{l}, which must only contain signed\n" + "8-bit values, to a numeric homogeneous vector.") +#define FUNC_NAME s_scm_list_to_s8vector +{ + SCM uvec; + SCM tmp; + int_s8 * p; + int n; + int arg_pos = 1; + + SCM_VALIDATE_LIST_COPYLEN (1, l, n); + + uvec = make_uvec (FUNC_NAME, SCM_UVEC_S8, n); + p = (int_s8 *) SCM_UVEC_BASE (uvec); + tmp = l; + while (SCM_CONSP (tmp)) + { + int_s8 f; + signed int s; + + s = scm_num2int (SCM_CAR (tmp), 2, FUNC_NAME); + f = s; + if ((signed int) f != s) + scm_out_of_range (FUNC_NAME, SCM_CAR (tmp)); + *p++ = f; + tmp = SCM_CDR (tmp); + arg_pos++; + } + scm_remember_upto_here_1 (l); + return uvec; +} +#undef FUNC_NAME + + +/* ================================================================ */ +/* U16 procedures. */ +/* ================================================================ */ + + +SCM_DEFINE (scm_u16vector_p, "u16vector?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a vector of type u16,\n" + "@code{#f} otherwise.") +#define FUNC_NAME s_scm_u16vector_p +{ + return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) && + SCM_UVEC_TYPE (obj) == SCM_UVEC_U16); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_make_u16vector, "make-u16vector", 1, 1, 0, + (SCM n, SCM fill), + "Create a newly allocated homogeneous numeric vector which can\n" + "hold @var{len} elements. If @var{fill} is given, it is used to\n" + "initialize the elements, otherwise the contents of the vector\n" + "is unspecified.") +#define FUNC_NAME s_scm_make_u16vector +{ + SCM uvec; + int_u16 * p; + int_u16 f; + int count; + + SCM_VALIDATE_INUM (1, n); + count = SCM_INUM (n); + uvec = make_uvec (FUNC_NAME, SCM_UVEC_U16, count); + if (SCM_UNBNDP (fill)) + f = 0; + else + f = scm_num2ushort (fill, 2, FUNC_NAME); + p = (int_u16 *) SCM_UVEC_BASE (uvec); + while (count-- > 0) + *p++ = f; + return uvec; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_u16vector, "u16vector", 0, 0, 1, + (SCM l), + "Create a newly allocated homogeneous numeric vector containing\n" + "all argument values.") +#define FUNC_NAME s_scm_u16vector +{ + SCM_VALIDATE_REST_ARGUMENT (l); + return scm_list_to_u16vector (l); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_u16vector_length, "u16vector-length", 1, 0, 0, + (SCM uvec), + "Return the number of elements in the homogeneous numeric vector\n" + "@var{uvec}.") +#define FUNC_NAME s_scm_u16vector_length +{ + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U16) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + return scm_int2num (SCM_UVEC_LENGTH (uvec)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_u16vector_ref, "u16vector-ref", 2, 0, 0, + (SCM uvec, SCM index), + "Return the element at @var{index} in the homogeneous numeric\n" + "vector @var{uvec}.") +#define FUNC_NAME s_scm_u16vector_ref +{ + int idx; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U16) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = scm_num2int (index, 2, FUNC_NAME); + if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec)) + scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2)); + + return scm_ushort2num (((int_u16 *) SCM_UVEC_BASE (uvec))[idx]); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_u16vector_set_x, "u16vector-set!", 3, 0, 0, + (SCM uvec, SCM index, SCM value), + "Set the element at @var{index} in the homogeneous numeric\n" + "vector @var{uvec} to @var{value}. The return value is not\n" + "specified.") +#define FUNC_NAME s_scm_u16vector_ref +{ + int idx; + int_u16 f; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U16) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = scm_num2int (index, 2, FUNC_NAME); + if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec)) + scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2)); + + f = scm_num2ushort (value, 3, FUNC_NAME); + + ((int_u16 *) SCM_UVEC_BASE (uvec))[idx] = f; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_u16vector_to_list, "u16vector->list", 1, 0, 0, + (SCM uvec), + "Convert the homogeneous numeric vector @var{uvec} to a list.") +#define FUNC_NAME s_scm_u16vector_to_list +{ + int idx; + int_u16 * p; + SCM res = SCM_EOL; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U16) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = SCM_UVEC_LENGTH (uvec); + p = (int_u16 *) SCM_UVEC_BASE (uvec) + idx; + while (idx-- > 0) + { + p--; + res = scm_cons (SCM_MAKINUM (*p), res); + } + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_list_to_u16vector, "list->u16vector", 1, 0, 0, + (SCM l), + "Convert the list @var{l}, which must only contain unsigned\n" + "16-bit values, to a numeric homogeneous vector.") +#define FUNC_NAME s_scm_list_to_u16vector +{ + SCM uvec; + int_u16 * p; + int n; + int arg_pos = 1; + + SCM_VALIDATE_LIST_COPYLEN (1, l, n); + + uvec = make_uvec (FUNC_NAME, SCM_UVEC_U16, n); + p = (int_u16 *) SCM_UVEC_BASE (uvec); + while (SCM_CONSP (l)) + { + int_u16 f = scm_num2ushort (SCM_CAR (l), 2, FUNC_NAME); + *p++ = f; + l = SCM_CDR (l); + arg_pos++; + } + return uvec; +} +#undef FUNC_NAME + + +/* ================================================================ */ +/* S16 procedures. */ +/* ================================================================ */ + + +SCM_DEFINE (scm_s16vector_p, "s16vector?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a vector of type s16,\n" + "@code{#f} otherwise.") +#define FUNC_NAME s_scm_s16vector_p +{ + return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) && + SCM_UVEC_TYPE (obj) == SCM_UVEC_S16); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_make_s16vector, "make-s16vector", 1, 1, 0, + (SCM n, SCM fill), + "Create a newly allocated homogeneous numeric vector which can\n" + "hold @var{len} elements. If @var{fill} is given, it is used to\n" + "initialize the elements, otherwise the contents of the vector\n" + "is unspecified.") +#define FUNC_NAME s_scm_make_s16vector +{ + SCM uvec; + int_s16 * p; + int_s16 f; + int count; + + SCM_VALIDATE_INUM (1, n); + count = SCM_INUM (n); + uvec = make_uvec (FUNC_NAME, SCM_UVEC_S16, count); + if (SCM_UNBNDP (fill)) + f = 0; + else + f = scm_num2short (fill, 2, FUNC_NAME); + p = (int_s16 *) SCM_UVEC_BASE (uvec); + while (count-- > 0) + *p++ = f; + return uvec; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_s16vector, "s16vector", 0, 0, 1, + (SCM l), + "Create a newly allocated homogeneous numeric vector containing\n" + "all argument values.") +#define FUNC_NAME s_scm_s16vector +{ + SCM_VALIDATE_REST_ARGUMENT (l); + return scm_list_to_s16vector (l); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_s16vector_length, "s16vector-length", 1, 0, 0, + (SCM uvec), + "Return the number of elements in the homogeneous numeric vector\n" + "@var{uvec}.") +#define FUNC_NAME s_scm_s16vector_length +{ + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S16) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + return scm_int2num (SCM_UVEC_LENGTH (uvec)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_s16vector_ref, "s16vector-ref", 2, 0, 0, + (SCM uvec, SCM index), + "Return the element at @var{index} in the homogeneous numeric\n" + "vector @var{uvec}.") +#define FUNC_NAME s_scm_s16vector_ref +{ + int idx; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S16) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = scm_num2int (index, 2, FUNC_NAME); + if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec)) + scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2)); + + return scm_short2num (((int_s16 *) SCM_UVEC_BASE (uvec))[idx]); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_s16vector_set_x, "s16vector-set!", 3, 0, 0, + (SCM uvec, SCM index, SCM value), + "Set the element at @var{index} in the homogeneous numeric\n" + "vector @var{uvec} to @var{value}. The return value is not\n" + "specified.") +#define FUNC_NAME s_scm_s16vector_ref +{ + int idx; + int_s16 f; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S16) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = scm_num2int (index, 2, FUNC_NAME); + if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec)) + scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2)); + + f = scm_num2short (value, 3, FUNC_NAME); + + ((int_s16 *) SCM_UVEC_BASE (uvec))[idx] = f; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_s16vector_to_list, "s16vector->list", 1, 0, 0, + (SCM uvec), + "Convert the homogeneous numeric vector @var{uvec} to a list.") +#define FUNC_NAME s_scm_s16vector_to_list +{ + int idx; + int_s16 * p; + SCM res = SCM_EOL; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S16) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = SCM_UVEC_LENGTH (uvec); + p = (int_s16 *) SCM_UVEC_BASE (uvec) + idx; + while (idx-- > 0) + { + p--; + res = scm_cons (SCM_MAKINUM (*p), res); + } + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_list_to_s16vector, "list->s16vector", 1, 0, 0, + (SCM l), + "Convert the list @var{l}, which must only contain signed\n" + "16-bit values, to a numeric homogeneous vector.") +#define FUNC_NAME s_scm_list_to_s16vector +{ + SCM uvec; + SCM tmp; + int_s16 * p; + int n; + int arg_pos = 1; + + SCM_VALIDATE_LIST_COPYLEN (1, l, n); + + uvec = make_uvec (FUNC_NAME, SCM_UVEC_S16, n); + p = (int_s16 *) SCM_UVEC_BASE (uvec); + tmp = l; + while (SCM_CONSP (tmp)) + { + int_s16 f = scm_num2short (SCM_CAR (tmp), 2, FUNC_NAME); + *p++ = f; + tmp = SCM_CDR (tmp); + arg_pos++; + } + scm_remember_upto_here_1 (l); + return uvec; +} +#undef FUNC_NAME + + +/* ================================================================ */ +/* U32 procedures. */ +/* ================================================================ */ + + +SCM_DEFINE (scm_u32vector_p, "u32vector?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a vector of type u32,\n" + "@code{#f} otherwise.") +#define FUNC_NAME s_scm_u32vector_p +{ + return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) && + SCM_UVEC_TYPE (obj) == SCM_UVEC_U32); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_make_u32vector, "make-u32vector", 1, 1, 0, + (SCM n, SCM fill), + "Create a newly allocated homogeneous numeric vector which can\n" + "hold @var{len} elements. If @var{fill} is given, it is used to\n" + "initialize the elements, otherwise the contents of the vector\n" + "is unspecified.") +#define FUNC_NAME s_scm_make_u32vector +{ + SCM uvec; + int_u32 * p; + int_u32 f; + int count; + + SCM_VALIDATE_INUM (1, n); + count = SCM_INUM (n); + uvec = make_uvec (FUNC_NAME, SCM_UVEC_U32, count); + if (SCM_UNBNDP (fill)) + f = 0; + else + f = scm_num2uint (fill, 2, FUNC_NAME); + p = (int_u32 *) SCM_UVEC_BASE (uvec); + while (count-- > 0) + *p++ = f; + return uvec; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_u32vector, "u32vector", 0, 0, 1, + (SCM l), + "Create a newly allocated homogeneous numeric vector containing\n" + "all argument values.") +#define FUNC_NAME s_scm_u32vector +{ + SCM_VALIDATE_REST_ARGUMENT (l); + return scm_list_to_u32vector (l); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_u32vector_length, "u32vector-length", 1, 0, 0, + (SCM uvec), + "Return the number of elements in the homogeneous numeric vector\n" + "@var{uvec}.") +#define FUNC_NAME s_scm_u32vector_length +{ + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U32) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + return scm_int2num (SCM_UVEC_LENGTH (uvec)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_u32vector_ref, "u32vector-ref", 2, 0, 0, + (SCM uvec, SCM index), + "Return the element at @var{index} in the homogeneous numeric\n" + "vector @var{uvec}.") +#define FUNC_NAME s_scm_u32vector_ref +{ + int idx; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U32) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = scm_num2int (index, 2, FUNC_NAME); + if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec)) + scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2)); + + return scm_uint2num (((int_u32 *) SCM_UVEC_BASE (uvec))[idx]); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_u32vector_set_x, "u32vector-set!", 3, 0, 0, + (SCM uvec, SCM index, SCM value), + "Set the element at @var{index} in the homogeneous numeric\n" + "vector @var{uvec} to @var{value}. The return value is not\n" + "specified.") +#define FUNC_NAME s_scm_u32vector_ref +{ + int idx; + int_u32 f; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U32) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = scm_num2int (index, 2, FUNC_NAME); + if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec)) + scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2)); + + f = scm_num2uint (value, 3, FUNC_NAME); + + ((int_u32 *) SCM_UVEC_BASE (uvec))[idx] = f; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_u32vector_to_list, "u32vector->list", 1, 0, 0, + (SCM uvec), + "Convert the homogeneous numeric vector @var{uvec} to a list.") +#define FUNC_NAME s_scm_u32vector_to_list +{ + int idx; + int_u32 * p; + SCM res = SCM_EOL; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U32) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = SCM_UVEC_LENGTH (uvec); + p = (int_u32 *) SCM_UVEC_BASE (uvec) + idx; + while (idx-- > 0) + { + p--; + res = scm_cons (scm_uint2num (*p), res); + } + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_list_to_u32vector, "list->u32vector", 1, 0, 0, + (SCM l), + "Convert the list @var{l}, which must only contain unsigned\n" + "32-bit values, to a numeric homogeneous vector.") +#define FUNC_NAME s_scm_list_to_u32vector +{ + SCM uvec; + int_u32 * p; + int n; + int arg_pos = 1; + + SCM_VALIDATE_LIST_COPYLEN (1, l, n); + + uvec = make_uvec (FUNC_NAME, SCM_UVEC_U32, n); + p = (int_u32 *) SCM_UVEC_BASE (uvec); + while (SCM_CONSP (l)) + { + int_u32 f; + f = scm_num2uint (SCM_CAR (l), 2, FUNC_NAME); + *p++ = f; + l = SCM_CDR (l); + arg_pos++; + } + return uvec; +} +#undef FUNC_NAME + + +/* ================================================================ */ +/* S32 procedures. */ +/* ================================================================ */ + + +SCM_DEFINE (scm_s32vector_p, "s32vector?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a vector of type s32,\n" + "@code{#f} otherwise.") +#define FUNC_NAME s_scm_s32vector_p +{ + return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) && + SCM_UVEC_TYPE (obj) == SCM_UVEC_S32); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_make_s32vector, "make-s32vector", 1, 1, 0, + (SCM n, SCM fill), + "Create a newly allocated homogeneous numeric vector which can\n" + "hold @var{len} elements. If @var{fill} is given, it is used to\n" + "initialize the elements, otherwise the contents of the vector\n" + "is unspecified.") +#define FUNC_NAME s_scm_make_s32vector +{ + SCM uvec; + int_s32 * p; + int_s32 f; + int count; + + SCM_VALIDATE_INUM (1, n); + count = SCM_INUM (n); + uvec = make_uvec (FUNC_NAME, SCM_UVEC_S32, count); + if (SCM_UNBNDP (fill)) + f = 0; + else + f = scm_num2int (fill, 2, FUNC_NAME); + p = (int_s32 *) SCM_UVEC_BASE (uvec); + while (count-- > 0) + *p++ = f; + return uvec; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_s32vector, "s32vector", 0, 0, 1, + (SCM l), + "Create a newly allocated homogeneous numeric vector containing\n" + "all argument values.") +#define FUNC_NAME s_scm_s32vector +{ + SCM_VALIDATE_REST_ARGUMENT (l); + return scm_list_to_s32vector (l); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_s32vector_length, "s32vector-length", 1, 0, 0, + (SCM uvec), + "Return the number of elements in the homogeneous numeric vector\n" + "@var{uvec}.") +#define FUNC_NAME s_scm_s32vector_length +{ + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S32) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + return scm_int2num (SCM_UVEC_LENGTH (uvec)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_s32vector_ref, "s32vector-ref", 2, 0, 0, + (SCM uvec, SCM index), + "Return the element at @var{index} in the homogeneous numeric\n" + "vector @var{uvec}.") +#define FUNC_NAME s_scm_s32vector_ref +{ + int idx; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S32) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = scm_num2int (index, 2, FUNC_NAME); + if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec)) + scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2)); + + return scm_int2num (((int_s32 *) SCM_UVEC_BASE (uvec))[idx]); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_s32vector_set_x, "s32vector-set!", 3, 0, 0, + (SCM uvec, SCM index, SCM value), + "Set the element at @var{index} in the homogeneous numeric\n" + "vector @var{uvec} to @var{value}. The return value is not\n" + "specified.") +#define FUNC_NAME s_scm_s32vector_ref +{ + int idx; + int_s32 f; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S32) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = scm_num2int (index, 2, FUNC_NAME); + if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec)) + scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2)); + + f = scm_num2int (value, 3, FUNC_NAME); + + ((int_s32 *) SCM_UVEC_BASE (uvec))[idx] = f; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_s32vector_to_list, "s32vector->list", 1, 0, 0, + (SCM uvec), + "Convert the homogeneous numeric vector @var{uvec} to a list.") +#define FUNC_NAME s_scm_s32vector_to_list +{ + int idx; + int_s32 * p; + SCM res = SCM_EOL; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S32) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = SCM_UVEC_LENGTH (uvec); + p = (int_s32 *) SCM_UVEC_BASE (uvec) + idx; + while (idx-- > 0) + { + p--; + res = scm_cons (scm_int2num (*p), res); + } + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_list_to_s32vector, "list->s32vector", 1, 0, 0, + (SCM l), + "Convert the list @var{l}, which must only contain signed\n" + "32-bit values, to a numeric homogeneous vector.") +#define FUNC_NAME s_scm_list_to_s32vector +{ + SCM uvec; + int_s32 * p; + int n; + int arg_pos = 1; + + SCM_VALIDATE_LIST_COPYLEN (1, l, n); + + uvec = make_uvec (FUNC_NAME, SCM_UVEC_S32, n); + p = (int_s32 *) SCM_UVEC_BASE (uvec); + while (SCM_CONSP (l)) + { + int_s32 f; + f = scm_num2int (SCM_CAR (l), 2, FUNC_NAME); + *p++ = f; + l = SCM_CDR (l); + arg_pos++; + } + return uvec; +} +#undef FUNC_NAME + + +#if HAVE_LONG_LONGS + +/* ================================================================ */ +/* U64 procedures. */ +/* ================================================================ */ + + +SCM_DEFINE (scm_u64vector_p, "u64vector?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a vector of type u64,\n" + "@code{#f} otherwise.") +#define FUNC_NAME s_scm_u64vector_p +{ + return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) && + SCM_UVEC_TYPE (obj) == SCM_UVEC_U64); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_make_u64vector, "make-u64vector", 1, 1, 0, + (SCM n, SCM fill), + "Create a newly allocated homogeneous numeric vector which can\n" + "hold @var{len} elements. If @var{fill} is given, it is used to\n" + "initialize the elements, otherwise the contents of the vector\n" + "is unspecified.") +#define FUNC_NAME s_scm_make_u64vector +{ + SCM uvec; + int_u64 * p; + int_u64 f; + int count; + + SCM_VALIDATE_INUM (1, n); + count = SCM_INUM (n); + uvec = make_uvec (FUNC_NAME, SCM_UVEC_U64, count); + if (SCM_UNBNDP (fill)) + f = 0; + else + f = scm_num2ulong_long (fill, 2, FUNC_NAME); + p = (int_u64 *) SCM_UVEC_BASE (uvec); + while (count-- > 0) + *p++ = f; + return uvec; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_u64vector, "u64vector", 0, 0, 1, + (SCM l), + "Create a newly allocated homogeneous numeric vector containing\n" + "all argument values.") +#define FUNC_NAME s_scm_u64vector +{ + SCM_VALIDATE_REST_ARGUMENT (l); + return scm_list_to_u64vector (l); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_u64vector_length, "u64vector-length", 1, 0, 0, + (SCM uvec), + "Return the number of elements in the homogeneous numeric vector\n" + "@var{uvec}.") +#define FUNC_NAME s_scm_u64vector_length +{ + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U64) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + return scm_int2num (SCM_UVEC_LENGTH (uvec)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_u64vector_ref, "u64vector-ref", 2, 0, 0, + (SCM uvec, SCM index), + "Return the element at @var{index} in the homogeneous numeric\n" + "vector @var{uvec}.") +#define FUNC_NAME s_scm_u64vector_ref +{ + int idx; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U64) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = scm_num2int (index, 2, FUNC_NAME); + if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec)) + scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2)); + + return scm_ulong_long2num (((int_u64 *) SCM_UVEC_BASE (uvec))[idx]); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_u64vector_set_x, "u64vector-set!", 3, 0, 0, + (SCM uvec, SCM index, SCM value), + "Set the element at @var{index} in the homogeneous numeric\n" + "vector @var{uvec} to @var{value}. The return value is not\n" + "specified.") +#define FUNC_NAME s_scm_u64vector_ref +{ + int idx; + int_u64 f; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U64) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = scm_num2int (index, 2, FUNC_NAME); + if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec)) + scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2)); + + f = scm_num2ulong_long (value, 3, FUNC_NAME); + + ((int_u64 *) SCM_UVEC_BASE (uvec))[idx] = f; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_u64vector_to_list, "u64vector->list", 1, 0, 0, + (SCM uvec), + "Convert the homogeneous numeric vector @var{uvec} to a list.") +#define FUNC_NAME s_scm_u64vector_to_list +{ + int idx; + int_u64 * p; + SCM res = SCM_EOL; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U64) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = SCM_UVEC_LENGTH (uvec); + p = (int_u64 *) SCM_UVEC_BASE (uvec) + idx; + while (idx-- > 0) + { + p--; + res = scm_cons (scm_long_long2num (*p), res); + } + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_list_to_u64vector, "list->u64vector", 1, 0, 0, + (SCM l), + "Convert the list @var{l}, which must only contain unsigned\n" + "64-bit values, to a numeric homogeneous vector.") +#define FUNC_NAME s_scm_list_to_u64vector +{ + SCM uvec; + int_u64 * p; + int n; + int arg_pos = 1; + + SCM_VALIDATE_LIST_COPYLEN (1, l, n); + + uvec = make_uvec (FUNC_NAME, SCM_UVEC_U64, n); + p = (int_u64 *) SCM_UVEC_BASE (uvec); + while (SCM_CONSP (l)) + { + int_u64 f; + f = scm_num2ulong_long (SCM_CAR (l), 2, FUNC_NAME); + *p++ = f; + l = SCM_CDR (l); + arg_pos++; + } + return uvec; +} +#undef FUNC_NAME + + +/* ================================================================ */ +/* S64 procedures. */ +/* ================================================================ */ + + +SCM_DEFINE (scm_s64vector_p, "s64vector?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a vector of type s64,\n" + "@code{#f} otherwise.") +#define FUNC_NAME s_scm_s64vector_p +{ + return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) && + SCM_UVEC_TYPE (obj) == SCM_UVEC_S64); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_make_s64vector, "make-s64vector", 1, 1, 0, + (SCM n, SCM fill), + "Create a newly allocated homogeneous numeric vector which can\n" + "hold @var{len} elements. If @var{fill} is given, it is used to\n" + "initialize the elements, otherwise the contents of the vector\n" + "is unspecified.") +#define FUNC_NAME s_scm_make_s64vector +{ + SCM uvec; + int_s64 * p; + int_s64 f; + int count; + + SCM_VALIDATE_INUM (1, n); + count = SCM_INUM (n); + uvec = make_uvec (FUNC_NAME, SCM_UVEC_S64, count); + if (SCM_UNBNDP (fill)) + f = 0; + else + f = scm_num2long_long (fill, 2, FUNC_NAME); + p = (int_s64 *) SCM_UVEC_BASE (uvec); + while (count-- > 0) + *p++ = f; + return uvec; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_s64vector, "s64vector", 0, 0, 1, + (SCM l), + "Create a newly allocated homogeneous numeric vector containing\n" + "all argument values.") +#define FUNC_NAME s_scm_s64vector +{ + SCM_VALIDATE_REST_ARGUMENT (l); + return scm_list_to_s64vector (l); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_s64vector_length, "s64vector-length", 1, 0, 0, + (SCM uvec), + "Return the number of elements in the homogeneous numeric vector\n" + "@var{uvec}.") +#define FUNC_NAME s_scm_s64vector_length +{ + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S64) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + return scm_int2num (SCM_UVEC_LENGTH (uvec)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_s64vector_ref, "s64vector-ref", 2, 0, 0, + (SCM uvec, SCM index), + "Return the element at @var{index} in the homogeneous numeric\n" + "vector @var{uvec}.") +#define FUNC_NAME s_scm_s64vector_ref +{ + int idx; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S64) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = scm_num2int (index, 2, FUNC_NAME); + if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec)) + scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2)); + + return scm_long_long2num (((int_s64 *) SCM_UVEC_BASE (uvec))[idx]); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_s64vector_set_x, "s64vector-set!", 3, 0, 0, + (SCM uvec, SCM index, SCM value), + "Set the element at @var{index} in the homogeneous numeric\n" + "vector @var{uvec} to @var{value}. The return value is not\n" + "specified.") +#define FUNC_NAME s_scm_s64vector_ref +{ + int idx; + int_s64 f; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S64) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = scm_num2int (index, 2, FUNC_NAME); + if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec)) + scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2)); + + f = scm_num2long_long (value, 3, FUNC_NAME); + + ((int_s64 *) SCM_UVEC_BASE (uvec))[idx] = f; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_s64vector_to_list, "s64vector->list", 1, 0, 0, + (SCM uvec), + "Convert the homogeneous numeric vector @var{uvec} to a list.") +#define FUNC_NAME s_scm_s64vector_to_list +{ + int idx; + int_s64 * p; + SCM res = SCM_EOL; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S64) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = SCM_UVEC_LENGTH (uvec); + p = (int_s64 *) SCM_UVEC_BASE (uvec) + idx; + while (idx-- > 0) + { + p--; + res = scm_cons (scm_long_long2num (*p), res); + } + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_list_to_s64vector, "list->s64vector", 1, 0, 0, + (SCM l), + "Convert the list @var{l}, which must only contain signed\n" + "64-bit values, to a numeric homogeneous vector.") +#define FUNC_NAME s_scm_list_to_s64vector +{ + SCM uvec; + int_s64 * p; + int n; + int arg_pos = 1; + + SCM_VALIDATE_LIST_COPYLEN (1, l, n); + + uvec = make_uvec (FUNC_NAME, SCM_UVEC_S64, n); + p = (int_s64 *) SCM_UVEC_BASE (uvec); + while (SCM_CONSP (l)) + { + int_s64 f; + f = scm_num2long_long (SCM_CAR (l), 2, FUNC_NAME); + *p++ = f; + l = SCM_CDR (l); + arg_pos++; + } + return uvec; +} +#undef FUNC_NAME + +#endif /* HAVE_LONG_LONGS */ + + +/* ================================================================ */ +/* F32 procedures. */ +/* ================================================================ */ + + +SCM_DEFINE (scm_f32vector_p, "f32vector?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a vector of type f32,\n" + "@code{#f} otherwise.") +#define FUNC_NAME s_scm_f32vector_p +{ + return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) && + SCM_UVEC_TYPE (obj) == SCM_UVEC_F32); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_make_f32vector, "make-f32vector", 1, 1, 0, + (SCM n, SCM fill), + "Create a newly allocated homogeneous numeric vector which can\n" + "hold @var{len} elements. If @var{fill} is given, it is used to\n" + "initialize the elements, otherwise the contents of the vector\n" + "is unspecified.") +#define FUNC_NAME s_scm_make_f32vector +{ + SCM uvec; + float_f32 * p; + float_f32 f; + int count; + + SCM_VALIDATE_INUM (1, n); + count = SCM_INUM (n); + uvec = make_uvec (FUNC_NAME, SCM_UVEC_F32, count); + if (SCM_UNBNDP (fill)) + f = 0; + else + { + double d = scm_num2dbl (fill, FUNC_NAME); + f = d; +#if 0 + /* This test somehow fails for even the simplest inexact + numbers, like 3.1. Must find out how to check properly. */ + if (f != d) + scm_out_of_range_pos (FUNC_NAME, fill, SCM_MAKINUM (2)); +#endif /* 0 */ + } + p = (float_f32 *) SCM_UVEC_BASE (uvec); + while (count-- > 0) + *p++ = f; + return uvec; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_f32vector, "f32vector", 0, 0, 1, + (SCM l), + "Create a newly allocated homogeneous numeric vector containing\n" + "all argument values.") +#define FUNC_NAME s_scm_f32vector +{ + SCM_VALIDATE_REST_ARGUMENT (l); + return scm_list_to_f32vector (l); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_f32vector_length, "f32vector-length", 1, 0, 0, + (SCM uvec), + "Return the number of elements in the homogeneous numeric vector\n" + "@var{uvec}.") +#define FUNC_NAME s_scm_f32vector_length +{ + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F32) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + return scm_int2num (SCM_UVEC_LENGTH (uvec)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_f32vector_ref, "f32vector-ref", 2, 0, 0, + (SCM uvec, SCM index), + "Return the element at @var{index} in the homogeneous numeric\n" + "vector @var{uvec}.") +#define FUNC_NAME s_scm_f32vector_ref +{ + int idx; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F32) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = scm_num2int (index, 2, FUNC_NAME); + if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec)) + scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2)); + + return scm_make_real (((float_f32 *) SCM_UVEC_BASE (uvec))[idx]); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_f32vector_set_x, "f32vector-set!", 3, 0, 0, + (SCM uvec, SCM index, SCM value), + "Set the element at @var{index} in the homogeneous numeric\n" + "vector @var{uvec} to @var{value}. The return value is not\n" + "specified.") +#define FUNC_NAME s_scm_f32vector_ref +{ + int idx; + float_f32 f; + double d; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F32) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = scm_num2int (index, 2, FUNC_NAME); + if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec)) + scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2)); + + d = scm_num2dbl (value, FUNC_NAME); + f = d; +#if 0 + /* This test somehow fails for even the simplest inexact + numbers, like 3.1. Must find out how to check properly. */ + if (f != d) + scm_out_of_range_pos (FUNC_NAME, value, SCM_MAKINUM (3)); +#endif /* 0 */ + + ((float_f32 *) SCM_UVEC_BASE (uvec))[idx] = f; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_f32vector_to_list, "f32vector->list", 1, 0, 0, + (SCM uvec), + "Convert the homogeneous numeric vector @var{uvec} to a list.") +#define FUNC_NAME s_scm_f32vector_to_list +{ + int idx; + float_f32 * p; + SCM res = SCM_EOL; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F32) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = SCM_UVEC_LENGTH (uvec); + p = (float_f32 *) SCM_UVEC_BASE (uvec) + idx; + while (idx-- > 0) + { + p--; + res = scm_cons (scm_make_real (*p), res); + } + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_list_to_f32vector, "list->f32vector", 1, 0, 0, + (SCM l), + "Convert the list @var{l}, which must only contain unsigned\n" + "8-bit values, to a numeric homogeneous vector.") +#define FUNC_NAME s_scm_list_to_f32vector +{ + SCM uvec; + float_f32 * p; + int n; + int arg_pos = 1; + + SCM_VALIDATE_LIST_COPYLEN (1, l, n); + + uvec = make_uvec (FUNC_NAME, SCM_UVEC_F32, n); + p = (float_f32 *) SCM_UVEC_BASE (uvec); + while (SCM_CONSP (l)) + { + float_f32 f; + double d; + d = scm_num2dbl (SCM_CAR (l), FUNC_NAME); + f = d; +#if 0 + /* This test somehow fails for even the simplest inexact + numbers, like 3.1. Must find out how to check properly. */ + if (d != f) + scm_out_of_range_pos (FUNC_NAME, l, SCM_MAKINUM (1)); +#endif /* 0 */ + *p++ = f; + l = SCM_CDR (l); + arg_pos++; + } + return uvec; +} +#undef FUNC_NAME + + +/* ================================================================ */ +/* F64 procedures. */ +/* ================================================================ */ + + +SCM_DEFINE (scm_f64vector_p, "f64vector?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a vector of type f64,\n" + "@code{#f} otherwise.") +#define FUNC_NAME s_scm_f64vector_p +{ + return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) && + SCM_UVEC_TYPE (obj) == SCM_UVEC_F64); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_make_f64vector, "make-f64vector", 1, 1, 0, + (SCM n, SCM fill), + "Create a newly allocated homogeneous numeric vector which can\n" + "hold @var{len} elements. If @var{fill} is given, it is used to\n" + "initialize the elements, otherwise the contents of the vector\n" + "is unspecified.") +#define FUNC_NAME s_scm_make_f64vector +{ + SCM uvec; + float_f64 * p; + float_f64 f; + int count; + + SCM_VALIDATE_INUM (1, n); + count = SCM_INUM (n); + uvec = make_uvec (FUNC_NAME, SCM_UVEC_F64, count); + if (SCM_UNBNDP (fill)) + f = 0; + else + f = scm_num2dbl (fill, FUNC_NAME); + p = (float_f64 *) SCM_UVEC_BASE (uvec); + while (count-- > 0) + *p++ = f; + return uvec; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_f64vector, "f64vector", 0, 0, 1, + (SCM l), + "Create a newly allocated homogeneous numeric vector containing\n" + "all argument values.") +#define FUNC_NAME s_scm_f64vector +{ + SCM_VALIDATE_REST_ARGUMENT (l); + return scm_list_to_f64vector (l); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_f64vector_length, "f64vector-length", 1, 0, 0, + (SCM uvec), + "Return the number of elements in the homogeneous numeric vector\n" + "@var{uvec}.") +#define FUNC_NAME s_scm_f64vector_length +{ + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F64) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + return scm_int2num (SCM_UVEC_LENGTH (uvec)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_f64vector_ref, "f64vector-ref", 2, 0, 0, + (SCM uvec, SCM index), + "Return the element at @var{index} in the homogeneous numeric\n" + "vector @var{uvec}.") +#define FUNC_NAME s_scm_f64vector_ref +{ + int idx; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F64) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = scm_num2int (index, 2, FUNC_NAME); + if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec)) + scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2)); + + return scm_make_real (((float_f64 *) SCM_UVEC_BASE (uvec))[idx]); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_f64vector_set_x, "f64vector-set!", 3, 0, 0, + (SCM uvec, SCM index, SCM value), + "Set the element at @var{index} in the homogeneous numeric\n" + "vector @var{uvec} to @var{value}. The return value is not\n" + "specified.") +#define FUNC_NAME s_scm_f64vector_ref +{ + int idx; + float_f64 f; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F64) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = scm_num2int (index, 2, FUNC_NAME); + if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec)) + scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2)); + + f = scm_num2dbl (value, FUNC_NAME); + + ((float_f64 *) SCM_UVEC_BASE (uvec))[idx] = f; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_f64vector_to_list, "f64vector->list", 1, 0, 0, + (SCM uvec), + "Convert the homogeneous numeric vector @var{uvec} to a list.") +#define FUNC_NAME s_scm_f64vector_to_list +{ + int idx; + float_f64 * p; + SCM res = SCM_EOL; + + SCM_VALIDATE_SMOB (1, uvec, uvec); + if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F64) + scm_wrong_type_arg (FUNC_NAME, 1, uvec); + + idx = SCM_UVEC_LENGTH (uvec); + p = (float_f64 *) SCM_UVEC_BASE (uvec) + idx; + while (idx-- > 0) + { + p--; + res = scm_cons (scm_make_real (*p), res); + } + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_list_to_f64vector, "list->f64vector", 1, 0, 0, + (SCM l), + "Convert the list @var{l}, which must only contain signed\n" + "8-bit values, to a numeric homogeneous vector.") +#define FUNC_NAME s_scm_list_to_f64vector +{ + SCM uvec; + float_f64 * p; + int n; + int arg_pos = 1; + + SCM_VALIDATE_LIST_COPYLEN (1, l, n); + + uvec = make_uvec (FUNC_NAME, SCM_UVEC_F64, n); + p = (float_f64 *) SCM_UVEC_BASE (uvec); + while (SCM_CONSP (l)) + { + float_f64 f = scm_num2dbl (SCM_CAR (l), FUNC_NAME); + *p++ = f; + l = SCM_CDR (l); + arg_pos++; + } + return uvec; +} +#undef FUNC_NAME + + +void +scm_init_srfi_4 (void) +{ + scm_tc16_uvec = scm_make_smob_type ("uvec", 0); + scm_set_smob_free (scm_tc16_uvec, uvec_free); + scm_set_smob_print (scm_tc16_uvec, uvec_print); +#ifndef SCM_MAGIC_SNARFER +#include "srfi/srfi-4.x" +#endif +} diff --git a/srfi/srfi-4.h b/srfi/srfi-4.h new file mode 100644 index 000000000..2b8df5161 --- /dev/null +++ b/srfi/srfi-4.h @@ -0,0 +1,141 @@ +#ifndef SCM_SRFI_4_H +#define SCM_SRFI_4_H +/* srfi-4.c --- Homogeneous numeric vector datatypes. + * + * Copyright (C) 2001 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives + * permission for additional uses of the text contained in its release + * of GUILE. + * + * The exception is that, if you link the GUILE library with other + * files to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public + * License. Your use of that executable is in no way restricted on + * account of linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public + * License. + * + * This exception applies only to the code released by the Free + * Software Foundation under the name GUILE. If you copy code from + * other Free Software Foundation releases into a copy of GUILE, as + * the General Public License permits, the exception does not apply to + * the code that you add in this way. To avoid misleading anyone as + * to the status of such modified files, you must delete this + * exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + + +SCM scm_u8vector_p (SCM obj); +SCM scm_make_u8vector (SCM n, SCM fill); +SCM scm_u8vector (SCM l); +SCM scm_u8vector_length (SCM uvec); +SCM scm_u8vector_ref (SCM uvec, SCM index); +SCM scm_u8vector_set_x (SCM uvec, SCM index, SCM value); +SCM scm_u8vector_to_list (SCM uvec); +SCM scm_list_to_u8vector (SCM l); + +SCM scm_s8vector_p (SCM obj); +SCM scm_make_s8vector (SCM n, SCM fill); +SCM scm_s8vector (SCM l); +SCM scm_s8vector_length (SCM uvec); +SCM scm_s8vector_ref (SCM uvec, SCM index); +SCM scm_s8vector_set_x (SCM uvec, SCM index, SCM value); +SCM scm_s8vector_to_list (SCM uvec); +SCM scm_list_to_s8vector (SCM l); + +SCM scm_u16vector_p (SCM obj); +SCM scm_make_u16vector (SCM n, SCM fill); +SCM scm_u16vector (SCM l); +SCM scm_u16vector_length (SCM uvec); +SCM scm_u16vector_ref (SCM uvec, SCM index); +SCM scm_u16vector_set_x (SCM uvec, SCM index, SCM value); +SCM scm_u16vector_to_list (SCM uvec); +SCM scm_list_to_u16vector (SCM l); + +SCM scm_s16vector_p (SCM obj); +SCM scm_make_s16vector (SCM n, SCM fill); +SCM scm_s16vector (SCM l); +SCM scm_s16vector_length (SCM uvec); +SCM scm_s16vector_ref (SCM uvec, SCM index); +SCM scm_s16vector_set_x (SCM uvec, SCM index, SCM value); +SCM scm_s16vector_to_list (SCM uvec); +SCM scm_list_to_s16vector (SCM l); + +SCM scm_u32vector_p (SCM obj); +SCM scm_make_u32vector (SCM n, SCM fill); +SCM scm_u32vector (SCM l); +SCM scm_u32vector_length (SCM uvec); +SCM scm_u32vector_ref (SCM uvec, SCM index); +SCM scm_u32vector_set_x (SCM uvec, SCM index, SCM value); +SCM scm_u32vector_to_list (SCM uvec); +SCM scm_list_to_u32vector (SCM l); + +SCM scm_s32vector_p (SCM obj); +SCM scm_make_s32vector (SCM n, SCM fill); +SCM scm_s32vector (SCM l); +SCM scm_s32vector_length (SCM uvec); +SCM scm_s32vector_ref (SCM uvec, SCM index); +SCM scm_s32vector_set_x (SCM uvec, SCM index, SCM value); +SCM scm_s32vector_to_list (SCM uvec); +SCM scm_list_to_s32vector (SCM l); + +SCM scm_u64vector_p (SCM obj); +SCM scm_make_u64vector (SCM n, SCM fill); +SCM scm_u64vector (SCM l); +SCM scm_u64vector_length (SCM uvec); +SCM scm_u64vector_ref (SCM uvec, SCM index); +SCM scm_u64vector_set_x (SCM uvec, SCM index, SCM value); +SCM scm_u64vector_to_list (SCM uvec); +SCM scm_list_to_u64vector (SCM l); + +SCM scm_s64vector_p (SCM obj); +SCM scm_make_s64vector (SCM n, SCM fill); +SCM scm_s64vector (SCM l); +SCM scm_s64vector_length (SCM uvec); +SCM scm_s64vector_ref (SCM uvec, SCM index); +SCM scm_s64vector_set_x (SCM uvec, SCM index, SCM value); +SCM scm_s64vector_to_list (SCM uvec); +SCM scm_list_to_s64vector (SCM l); + +SCM scm_f32vector_p (SCM obj); +SCM scm_make_f32vector (SCM n, SCM fill); +SCM scm_f32vector (SCM l); +SCM scm_f32vector_length (SCM uvec); +SCM scm_f32vector_ref (SCM uvec, SCM index); +SCM scm_f32vector_set_x (SCM uvec, SCM index, SCM value); +SCM scm_f32vector_to_list (SCM uvec); +SCM scm_list_to_f32vector (SCM l); + +SCM scm_f64vector_p (SCM obj); +SCM scm_make_f64vector (SCM n, SCM fill); +SCM scm_f64vector (SCM l); +SCM scm_f64vector_length (SCM uvec); +SCM scm_f64vector_ref (SCM uvec, SCM index); +SCM scm_f64vector_set_x (SCM uvec, SCM index, SCM value); +SCM scm_f64vector_to_list (SCM uvec); +SCM scm_list_to_f64vector (SCM l); + +void scm_init_srfi_4 (void); + +#endif /* SCM_SRFI_4_H */ diff --git a/srfi/srfi-4.scm b/srfi/srfi-4.scm new file mode 100644 index 000000000..ea7137cd1 --- /dev/null +++ b/srfi/srfi-4.scm @@ -0,0 +1,200 @@ +;;;; srfi-4.scm --- Homogeneous numeric vector datatypes. +;;;; +;;;; Copyright (C) 2001 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 the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. + +;;; Commentary: + +;;; This module implements homogeneous numeric vectors as defined in SRFI-4. + +;;; Code: + +;;; Author: Martin Grabmueller + +(define-module (srfi srfi-4)) + +(export +;;; Unsigned 8-bit vectors. + u8vector? make-u8vector u8vector u8vector-length u8vector-ref + u8vector-set! u8vector->list list->u8vector + +;;; Signed 8-bit vectors. + s8vector? make-s8vector s8vector s8vector-length s8vector-ref + s8vector-set! s8vector->list list->s8vector + +;;; Unsigned 16-bit vectors. + u16vector? make-u16vector u16vector u16vector-length u16vector-ref + u16vector-set! u16vector->list list->u16vector + +;;; Signed 16-bit vectors. + s16vector? make-s16vector s16vector s16vector-length s16vector-ref + s16vector-set! s16vector->list list->s16vector + +;;; Unsigned 32-bit vectors. + u32vector? make-u32vector u32vector u32vector-length u32vector-ref + u32vector-set! u32vector->list list->u32vector + +;;; Signed 32-bit vectors. + s32vector? make-s32vector s32vector s32vector-length s32vector-ref + s32vector-set! s32vector->list list->s32vector + +;;; Unsigned 64-bit vectors. + u64vector? make-u64vector u64vector u64vector-length u64vector-ref + u64vector-set! u64vector->list list->u64vector + +;;; Signed 64-bit vectors. + s64vector? make-s64vector s64vector s64vector-length s64vector-ref + s64vector-set! s64vector->list list->s64vector + +;;; 32-bit floating point vectors. + f32vector? make-f32vector f32vector f32vector-length f32vector-ref + f32vector-set! f32vector->list list->f32vector + +;;; 64-bit floating point vectors. + f64vector? make-f64vector f64vector f64vector-length f64vector-ref + f64vector-set! f64vector->list list->f64vector + ) + + +;; Make 'srfi-4 available as a feature identifiere to `cond-expand'. +;; +(cond-expand-provide (current-module) '(srfi-4)) + + +;; Load the compiled primitives from the shared library. +;; +(load-extension "libguile-srfi-srfi-4" "scm_init_srfi_4") + + +;; Reader extension for #f32() and #f64() vectors. +;; +(define (hash-f char port) + (if (or (char=? (peek-char port) #\3) + (char=? (peek-char port) #\6)) + (let* ((obj (read port))) + (if (number? obj) + (cond ((= obj 32) + (let ((l (read port))) + (if (list? l) + (list->f32vector l) + (error "syntax error in #f32() vector literal")))) + ((= obj 64) + (let ((l (read port))) + (if (list? l) + (list->f64vector l) + (error "syntax error in #f64() vector literal")))) + (else + (error "syntax error in #f...() vector literal"))) + (error "syntax error in #f...() vector literal"))) + #f)) + + +;; Reader extension for #u8(), #u16(), #u32() and #u64() vectors. +;; +(define (hash-u char port) + (if (or (char=? (peek-char port) #\8) + (char=? (peek-char port) #\1) + (char=? (peek-char port) #\3) + (char=? (peek-char port) #\6)) + (let ((obj (read port))) + (cond ((= obj 8) + (let ((l (read port))) + (if (list? l) + (list->u8vector l) + (error "syntax error in #u8() vector literal")))) + ((= obj 16) + (let ((l (read port))) + (if (list? l) + (list->u16vector l) + (error "syntax error in #u16() vector literal")))) + ((= obj 32) + (let ((l (read port))) + (if (list? l) + (list->u32vector l) + (error "syntax error in #u32() vector literal")))) + ((= obj 64) + (let ((l (read port))) + (if (list? l) + (list->u64vector l) + (error "syntax error in #u64() vector literal")))) + (else + (error "syntax error in #u...() vector literal")))) + (error "syntax error in #u...() vector literal"))) + + +;; Reader extension for #s8(), #s16(), #s32() and #s64() vectors. +;; +(define (hash-s char port) + (if (or (char=? (peek-char port) #\8) + (char=? (peek-char port) #\1) + (char=? (peek-char port) #\3) + (char=? (peek-char port) #\6)) + (let ((obj (read port))) + (cond ((= obj 8) + (let ((l (read port))) + (if (list? l) + (list->s8vector l) + (error "syntax error in #s8() vector literal")))) + ((= obj 16) + (let ((l (read port))) + (if (list? l) + (list->s16vector l) + (error "syntax error in #s16() vector literal")))) + ((= obj 32) + (let ((l (read port))) + (if (list? l) + (list->s32vector l) + (error "syntax error in #s32() vector literal")))) + ((= obj 64) + (let ((l (read port))) + (if (list? l) + (list->s64vector l) + (error "syntax error in #s64() vector literal")))) + (else + (error "syntax error in #s...() vector literal")))) + (error "syntax error in #s...() vector literal"))) + + +;; Install the hash extensions. +;; +(read-hash-extend #\f hash-f) +(read-hash-extend #\u hash-u) +(read-hash-extend #\s hash-s) From c34f52745cd70656f89ac3ed96f033a586a51371 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 27 Jun 2001 13:19:43 +0000 Subject: [PATCH 1392/2047] * srfi-modules.texi (SRFI-4): Added documentation for the new module (srfi srfi-4). --- doc/ChangeLog | 5 ++ doc/srfi-modules.texi | 126 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 131 insertions(+) diff --git a/doc/ChangeLog b/doc/ChangeLog index 0544d0bb8..1e135bf9d 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,8 @@ +2001-06-27 Martin Grabmueller + + * srfi-modules.texi (SRFI-4): Added documentation for the new + module (srfi srfi-4). + 2001-06-26 Neil Jerram * gh.texi (scm transition summary): Refer to scm_mem2string diff --git a/doc/srfi-modules.texi b/doc/srfi-modules.texi index 41c95ea97..a0ee14602 100644 --- a/doc/srfi-modules.texi +++ b/doc/srfi-modules.texi @@ -17,6 +17,7 @@ get the relevant SRFI documents from the SRFI home page * SRFI-0:: cond-expand * SRFI-1:: List library. * SRFI-2:: and-let*. +* SRFI-4:: Homogeneous numeric vector datatypes. * SRFI-6:: Basic String Ports. * SRFI-8:: receive. * SRFI-9:: define-record-type. @@ -834,6 +835,131 @@ returns the value of @var{x}. @end lisp +@node SRFI-4 +@section SRFI-4 - Homogeneous numeric vector datatypes. + +@c FIXME::martin: Review me! + +SRFI-4 defines a set of datatypes for vectors whose elements are all +of the same numeric type. Vectors for signed and unsigned exact +integer or inexact real numbers in several precisions are available. + +Procedures similar to the vector procedures (@pxref{Vectors}) are +provided for handling these homogeneous vectors, but they are distinct +datatypes. + +The reason for providing this set of datatypes is that with the +limitation (all elements must have the same type), it is possible to +implement them much more memory-efficient than normal, heterogenous +vectors. + +If you want to use these datatypes and the corresponding procedures, +you have to use the module @code{(srfi srfi-4)}. + +Ten vector data types are provided: Unsigned and signed integer values +with 8, 16, 32 and 64 bits and floating point values with 32 and 64 +bits. In the following descriptions, the tags @code{u8}, @code{s8}, +@code{u16}, @code{s16}, @code{u32}, @code{s32}, @code{u64}, +@code{s64}, @code{f32}, @code{f64}, respectively, are used for +denoting the various types. + +@menu +* SRFI-4 - Read Syntax:: How to write homogeneous vector literals. +* SRFI-4 - Procedures:: Available homogeneous vector procedures. +@end menu + + +@node SRFI-4 - Read Syntax +@subsection SRFI-4 - Read Syntax + +Homogeneous numeric vectors have an external representation (read +syntax) similar to normal Scheme vectors, but with an additional tag +telling the vector's type. + +@lisp +#u16(1 2 3) +@end lisp + +denotes a homogeneous numeric vector of three elements, which are the +values 1, 2 and 3, represented as 16-bit unsigned integers. +Correspondingly, + +@lisp +#f64(3.1415 2.71) +@end lisp + +denotes a vector of two elements, which are the values 3.1415 and +2.71, represented as floating-point values of 64 bit precision. + +Please note that the read syntax for floating-point vectors conflicts +with Standard Scheme, because there @code{#f} is defined to be the +literal false value. That means, that with the loaded SRFI-4 module, +it is not possible to enter some list like + +@lisp +'(1 #f3) +@end lisp + +and hope that it will be parsed as a three-element list with the +elements 1, @code{#f} and 3. In normal use, this should be no +problem, because people tend to terminate tokens sensibly when writing +Scheme expressions. + +@node SRFI-4 - Procedures +@subsection SRFI-4 Procedures + +The procedures listed in this section are provided for all homogeneous +numeric vector datatypes. For brevity, they are not all documented, +but a summary of the procedures is given. In the following +descriptions, you can replace @code{TAG} by any of the datatype +indicators @code{u8}, @code{s8}, @code{u16}, @code{s16}, @code{u32}, +@code{s32}, @code{u64}, @code{s64}, @code{f32} and @code{f64}. + +For example, you can use the procedures @code{u8vector?}, +@code{make-s8vector}, @code{u16vector}, @code{u32vector-length}, +@code{s64vector-ref}, @code{f32vector-set!} or @code{f64vector->list}. + +@deffn primitive TAGvector? obj +Return @code{#t} if @var{obj} is a homogeneous numeric vector of type +@code{TAG}. +@end deffn + +@deffn primitive make-TAGvector n [value] +Create a newly allocated homogeneous numeric vector of type +@code{TAG}, which can hold @var{n} elements. If @var{value} is given, +the vector is initialized with the value, otherwise, the contents of +the returned vector is not specified. +@end deffn + +@deffn primitive TAGvector value1 @dots{} +Create a newly allocated homogeneous numeric vector of type +@code{TAG}. The returned vector is as long as the number of arguments +given, and is initialized with the argument values. +@end deffn + +@deffn primitive TAGvector-length TAGvec +Return the number of elements in @var{TAGvec}. +@end deffn + +@deffn primitive TAGvector-ref TAGvec i +Return the element at index @var{i} in @var{TAGvec}. +@end deffn + +@deffn primitive TAGvector-ref TAGvec i value +Set the element at index @var{i} in @var{TAGvec} to @var{value}. The +return value is not specified. +@end deffn + +@deffn primitive TAGvector->list TAGvec +Return a newly allocated list holding all elements of @var{TAGvec}. +@end deffn + +@deffn primitive list->TAGvector lst +Return a newly allocated homogeneous numeric vector of type @code{TAG}, +initialized with the elements of the list @var{lst}. +@end deffn + + @node SRFI-6 @section SRFI-6 - Basic String Ports From 71220e340073f414af814e015830ce52f82db9e0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 27 Jun 2001 13:21:31 +0000 Subject: [PATCH 1393/2047] Updated my record. --- AUTHORS | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/AUTHORS b/AUTHORS index f22547a33..36b64a29e 100644 --- a/AUTHORS +++ b/AUTHORS @@ -136,16 +136,14 @@ In the subdirectory libguile, changes to: strop.c strop.h struct.c macros.c numbers.c posix.h posix.c symbols.c gh_data.c strports.h strports.c validate.h - and changed many docstrings throughout. + read.c + and many docstrings changes throughout. In the subdirectory srfi, wrote: - srfi-1.scm - srfi-9.scm - srfi-10.scm - srfi-13.scm - srfi-14.scm - srfi-13.c - srfi-14.c - srfi-16.scm + srfi-1.scm srfi-9.scm srfi-10.scm + srfi-13.scm srfi-14.scm srfi-13.c + srfi-14.c srfi-13.h srfi-14.h + srfi-16.scm srfi-4.c srfi-4.h + srfi-4.scm In the subdirectory scripts, wrote: doc-snarf In the subdirectory doc, wrote: @@ -164,7 +162,8 @@ In the subdirectory example, wrote scripts modules safe box box-module box-dynamic In the subdirectory test-suite/tests, wrote: - srfi-9.test srfi-10.test srfi-13.test + srfi-4.test srfi-9.test srfi-10.test + srfi-13.test Will Fitzgerald: wrote initial srfi/srfi-19.scm. From 6db6327de92e4a01a0bf8ff8f62c1eb7e9de62d9 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 27 Jun 2001 17:15:36 +0000 Subject: [PATCH 1394/2047] Add completion and ownership protocol to header comments. --- TODO | 28 ++++++++++++++++++++++------ 1 file changed, 22 insertions(+), 6 deletions(-) diff --git a/TODO b/TODO index 5b8705a34..5c1e1573c 100644 --- a/TODO +++ b/TODO @@ -1,11 +1,27 @@ -[ID: $Id: TODO,v 1.15 2001-06-27 09:46:44 ttn Exp $] +[ID: $Id: TODO,v 1.16 2001-06-27 17:15:36 ttn Exp $] -These are grouped by release target. If you would like to suggest changes or -contribute patches, please first email guile-devel@gnu.org to coordinate. See -also file HACKING. +These TODO items are grouped by target release version. The first group is +the "Eventually" group, which is not associated w/ any particular version. +Move these items under a version upon completion (or better yet, ownership). +Upon completion, simply change the "-" to a "+", but do not delete the item. +At release time, the "+" entries will be deleted after review to make sure +that user-visible changes are reflected in NEWS (and that proper credit is +applied :-). -=== Eventually (not yet associated with a specific release): +Ownership is indicated by `[USERNAME]'. Maintainers (w/ write privs) can +indicate sponsorship by `[ACTUAL-OWNER:MAINTAINER]', where both elements are +usernames. + +If you would like to suggest changes or contribute patches, please first email +guile-devel@gnu.org to coordinate efforts. If you distribute this file, +please include the first line and check around on the Internet for updates. + +See also file HACKING. + +------------------------------------------------------------------------------ + +=== Eventually: - deprecate `read-only-string?' - [after signal handling and threading have been fixed] remove the code @@ -24,7 +40,7 @@ also file HACKING. - rewrite method cache management in C - rewrite core macros (define-class et al) in C - define C API -- write orbit CORBA interface +- write Orbit CORBA interface - [after new module system] factor out modules sort.c and random.c should be factored out into separate modules From f6b3694a309bcdc932638501f695a4a6a0f80f8f Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 27 Jun 2001 17:17:38 +0000 Subject: [PATCH 1395/2047] *** empty log message *** --- ChangeLog | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ChangeLog b/ChangeLog index 1f4fe7505..99b20a1c9 100644 --- a/ChangeLog +++ b/ChangeLog @@ -12,6 +12,8 @@ * SNAPSHOTS: Fix reference bug; recommended tool versions are in HACKING. + * TODO: Add completion and ownership protocol to header comments. + 2001-06-27 Michael Livshin * autogen.sh: don't run flex here. From e04ff9b2cda4052618cf688043e8beeb49f3c582 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 27 Jun 2001 17:24:58 +0000 Subject: [PATCH 1396/2047] Add TODO-processing to spiffing checklist. --- RELEASE | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/RELEASE b/RELEASE index 57c851d65..6996d7a2b 100644 --- a/RELEASE +++ b/RELEASE @@ -72,7 +72,8 @@ Spiffing checklist: documented. + Check for any [[incomplete]] sections of NEWS. + Fact-check INSTALL. - + Make sure AUTHORS and THANKS are up-to-date. + + Make sure AUTHORS and THANKS are up-to-date (see also TODO). + + Remove finished items from TODO (those marked w/ "+"). * Make sure the downloading addresses and filenames in README are current. (But don't bump the version number yet. We do that below.) * Check that the versions of aclocal, automake, autoconf, and autoheader From 3cd085d0ff0028cfea2ee372c4b1917e470e4723 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 27 Jun 2001 17:25:51 +0000 Subject: [PATCH 1397/2047] *** empty log message *** --- ChangeLog | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ChangeLog b/ChangeLog index 99b20a1c9..2cb6cb26f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -14,6 +14,8 @@ * TODO: Add completion and ownership protocol to header comments. + * RELEASE: Add TODO-processing to spiffing checklist. + 2001-06-27 Michael Livshin * autogen.sh: don't run flex here. From b235553417afe0bf144e4b2d3b9b5266a865b185 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 27 Jun 2001 17:28:45 +0000 Subject: [PATCH 1398/2047] Update deprecation procedure to refer to TODO. --- HACKING | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/HACKING b/HACKING index e5d00414c..e7d44bd2e 100644 --- a/HACKING +++ b/HACKING @@ -217,9 +217,9 @@ When deprecating a definition, always follow this procedure: 4. Add an entry that the definition has been deprecated in NEWS and explain what do do instead. -5. At the top of RELEASE, there is a list of releases with reminders - about what to do at each release. Add a reminder about the removal - of the deprecated defintion at the appropriate release. +5. In file TODO, there is a list of releases with reminders about what + to do at each release. Add a reminder about the removal of the + deprecated defintion at the appropriate release. - When you make a user-visible change (i.e. one that should be documented, and appear in NEWS, put an asterisk in column zero of the From 9c3955ffc6f19c5e945186c1c6f185119a4cfb22 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 27 Jun 2001 17:30:06 +0000 Subject: [PATCH 1399/2047] *** empty log message *** --- ChangeLog | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ChangeLog b/ChangeLog index 2cb6cb26f..b6725e9bf 100644 --- a/ChangeLog +++ b/ChangeLog @@ -16,6 +16,8 @@ * RELEASE: Add TODO-processing to spiffing checklist. + * HACKING: Update deprecation procedure to refer to TODO. + 2001-06-27 Michael Livshin * autogen.sh: don't run flex here. From 02d9f388177fc440ad7648544cfd1034ca0bbd13 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Wed, 27 Jun 2001 18:12:46 +0000 Subject: [PATCH 1400/2047] * Grammar fix. --- doc/ChangeLog | 5 +++++ doc/THANKS | 25 +++++++++++++------------ doc/posix.texi | 7 +++---- 3 files changed, 21 insertions(+), 16 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 1e135bf9d..dd6b70426 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,8 @@ +2001-06-27 Neil Jerram + + * posix.texi (Network Sockets and Communication): Grammar fix - + thanks to Christopher Cramer! + 2001-06-27 Martin Grabmueller * srfi-modules.texi (SRFI-4): Added documentation for the new diff --git a/doc/THANKS b/doc/THANKS index 7db6082eb..53cff29f4 100644 --- a/doc/THANKS +++ b/doc/THANKS @@ -2,17 +2,18 @@ Many thanks to the following people for contributing to the Guile manuals! Proofreading, bug reports and patches from: - Chris Bitmead - Marcus Daniels - Dirk Herrmann - Dale P. Smith - Steve Tell - Lee Thomas - Masao Uebayashi - Joel Weber - Keith Wright + Chris Bitmead +Christopher Cramer + Marcus Daniels + Dirk Herrmann + Dale P. Smith + Steve Tell + Lee Thomas + Masao Uebayashi + Joel Weber + Keith Wright New entries from: - Per Bothner - Martin Grabmueller -Thien Thi Nguyen + Per Bothner + Martin Grabmueller + Thien Thi Nguyen diff --git a/doc/posix.texi b/doc/posix.texi index df7e757b5..a823bc360 100644 --- a/doc/posix.texi +++ b/doc/posix.texi @@ -1870,10 +1870,9 @@ Otherwise it is equivalent to @code{setservent stayopen}. @subsection Network Sockets and Communication Socket ports can be created using @code{socket} and @code{socketpair}. -The ports are initially unbuffered, to -makes reading and writing to the same port more reliable. -A buffer can be added to the port using @code{setvbuf}, -@xref{Ports and File Descriptors}. +The ports are initially unbuffered, to make reading and writing to the +same port more reliable. A buffer can be added to the port using +@code{setvbuf}, @xref{Ports and File Descriptors}. The convention used for "host" vs "network" addresses is that addresses are always held in host order at the Scheme level. The procedures in From 1afff620541041a7b680a85fee6d641092091b7c Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Thu, 28 Jun 2001 01:11:59 +0000 Subject: [PATCH 1401/2047] * list.h (scm_list_1, scm_list_2, scm_list_3, scm_list_4, scm_list_5, scm_list_n): New functions. (SCM_LIST0, SCM_LIST1, SCM_LIST2, SCM_LIST3, SCM_LIST4, SCM_LIST5, SCM_LIST6, SCM_LIST7, SCM_LIST8, SCM_LIST9, scm_listify): Deprecated. (lots of files): Use the new functions. * goops.c (CALL_GF1, CALL_GF2, CALL_GF3, CALL_GF4): Use scm_call_N. * strings.c: #include "libguile/deprecation.h". --- libguile/ChangeLog | 12 ++ libguile/continuations.c | 2 +- libguile/deprecation.c | 2 +- libguile/dynl.c | 2 +- libguile/environments.c | 2 +- libguile/error.c | 26 +-- libguile/eval.c | 2 +- libguile/evalext.c | 4 +- libguile/filesys.c | 15 +- libguile/fluids.c | 2 +- libguile/gc.c | 24 +-- libguile/gh.h | 2 +- libguile/gh_list.c | 14 +- libguile/goops.c | 317 +++++++++++++++++----------------- libguile/gsubr.c | 2 +- libguile/guardians.c | 7 +- libguile/hooks.c | 4 +- libguile/list.c | 52 +++++- libguile/list.h | 45 +++-- libguile/load.c | 14 +- libguile/modules.c | 14 +- libguile/net_db.c | 6 +- libguile/objects.c | 16 +- libguile/options.c | 2 +- libguile/pairs.c | 2 +- libguile/ports.c | 2 +- libguile/print.c | 15 +- libguile/procprop.c | 6 +- libguile/read.c | 4 +- libguile/script.c | 7 +- libguile/smob.c | 6 +- libguile/socket.c | 2 +- libguile/strings.c | 2 + libguile/struct.c | 23 +-- libguile/symbols-deprecated.c | 2 +- libguile/unif.c | 3 +- libguile/variable.c | 2 +- libguile/vectors.c | 4 +- 38 files changed, 368 insertions(+), 300 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6458869ef..058620928 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,15 @@ +2001-06-28 Keisuke Nishida + + * list.h (scm_list_1, scm_list_2, scm_list_3, scm_list_4, scm_list_5, + scm_list_n): New functions. + (SCM_LIST0, SCM_LIST1, SCM_LIST2, SCM_LIST3, SCM_LIST4, SCM_LIST5, + SCM_LIST6, SCM_LIST7, SCM_LIST8, SCM_LIST9, scm_listify): Deprecated. + (lots of files): Use the new functions. + + * goops.c (CALL_GF1, CALL_GF2, CALL_GF3, CALL_GF4): Use scm_call_N. + + * strings.c: #include "libguile/deprecation.h". + 2001-06-27 Martin Grabmueller * read.c (scm_lreadr): When reading a hash token, check for a diff --git a/libguile/continuations.c b/libguile/continuations.c index 3bf0f9074..ae936fe78 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -232,7 +232,7 @@ continuation_apply (SCM cont, SCM args) || continuation->base != rootcont->base) { SCM_MISC_ERROR ("continuation from wrong top level: ~S", - SCM_LIST1 (cont)); + scm_list_1 (cont)); } scm_dowinds (continuation->dynenv, diff --git a/libguile/deprecation.c b/libguile/deprecation.c index 6501d7fa3..9271fb0c5 100644 --- a/libguile/deprecation.c +++ b/libguile/deprecation.c @@ -66,7 +66,7 @@ scm_c_issue_deprecation_warning (const char *msg) if (SCM_BOOLP (issued_msgs)) issued_msgs = SCM_BOOL_T; else - scm_issue_deprecation_warning (SCM_LIST1 (scm_makfrom0str (msg))); + scm_issue_deprecation_warning (scm_list_1 (scm_makfrom0str (msg))); } SCM_DEFINE(scm_issue_deprecation_warning, diff --git a/libguile/dynl.c b/libguile/dynl.c index 1bc797af9..006bbff6a 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -254,7 +254,7 @@ sysdep_dynl_link (const char *fname, const char *subr) SCM_ALLOW_INTS; fn = scm_makfrom0str (fname); msg = scm_makfrom0str (lt_dlerror ()); - scm_misc_error (subr, "file: ~S, message: ~S", SCM_LIST2 (fn, msg)); + scm_misc_error (subr, "file: ~S, message: ~S", scm_list_2 (fn, msg)); } return (void *) handle; } diff --git a/libguile/environments.c b/libguile/environments.c index 58a4cff8b..541427641 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -816,7 +816,7 @@ update_catch_handler (void *ptr, SCM tag, SCM args) SCM observer = data->observer; SCM message = scm_makfrom0str ("Observer `~A' signals `~A' error: ~S"); - return scm_cons (message, SCM_LIST3 (observer, tag, args)); + return scm_cons (message, scm_list_3 (observer, tag, args)); } diff --git a/libguile/error.c b/libguile/error.c index b37db72a5..0fd20718a 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -81,10 +81,10 @@ scm_error (SCM key, const char *subr, const char *message, SCM args, SCM rest) message ? message : ""); abort (); } - arg_list = SCM_LIST4 (subr ? scm_makfrom0str (subr) : SCM_BOOL_F, - message ? scm_makfrom0str (message) : SCM_BOOL_F, - args, - rest); + arg_list = scm_list_4 (subr ? scm_makfrom0str (subr) : SCM_BOOL_F, + message ? scm_makfrom0str (message) : SCM_BOOL_F, + args, + rest); scm_ithrow (key, arg_list, 1); /* No return, but just in case: */ @@ -202,7 +202,7 @@ scm_out_of_range (const char *subr, SCM bad_value) scm_error (scm_out_of_range_key, subr, "Argument out of range: ~S", - SCM_LIST1(bad_value), + scm_list_1 (bad_value), SCM_BOOL_F); } @@ -212,7 +212,7 @@ scm_out_of_range_pos (const char *subr, SCM bad_value, SCM pos) scm_error (scm_out_of_range_key, subr, "Argument ~S out of range: ~S", - SCM_LIST2(pos,bad_value), + scm_list_2 (pos,bad_value), SCM_BOOL_F); } @@ -224,7 +224,7 @@ scm_wrong_num_args (SCM proc) scm_error (scm_args_number_key, NULL, "Wrong number of arguments to ~A", - SCM_LIST1(proc), + scm_list_1 (proc), SCM_BOOL_F); } @@ -235,7 +235,7 @@ scm_error_num_args_subr (const char *subr) scm_error (scm_args_number_key, NULL, "Wrong number of arguments to ~A", - SCM_LIST1 (scm_makfrom0str (subr)), + scm_list_1 (scm_makfrom0str (subr)), SCM_BOOL_F); } @@ -248,8 +248,8 @@ scm_wrong_type_arg (const char *subr, int pos, SCM bad_value) subr, (pos == 0) ? "Wrong type argument: ~S" : "Wrong type argument in position ~A: ~S", - (pos == 0) ? SCM_LIST1(bad_value) - : SCM_LIST2(SCM_MAKINUM(pos), bad_value), + (pos == 0) ? scm_list_1 (bad_value) + : scm_list_2 (SCM_MAKINUM (pos), bad_value), SCM_BOOL_F); } @@ -260,13 +260,13 @@ scm_wrong_type_arg_msg (const char *subr, int pos, SCM bad_value, const char *sz if (pos == 0) { scm_error (scm_arg_type_key, subr, "Wrong type argument (expecting ~A): ~S", - SCM_LIST2(msg,bad_value), + scm_list_2 (msg, bad_value), SCM_BOOL_F); } else { scm_error (scm_arg_type_key, subr, "Wrong type argument in position ~A (expecting ~A): ~S", - SCM_LIST3(SCM_MAKINUM(pos),msg,bad_value), + scm_list_3 (SCM_MAKINUM (pos), msg, bad_value), SCM_BOOL_F); } } @@ -300,7 +300,7 @@ scm_wta (SCM arg, const char *pos, const char *s_subr) if ((~0x1fL) & (long) pos) { /* error string supplied. */ - scm_misc_error (s_subr, pos, SCM_LIST1 (arg)); + scm_misc_error (s_subr, pos, scm_list_1 (arg)); } else { diff --git a/libguile/eval.c b/libguile/eval.c index ffd195ca5..337c52a8c 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2523,7 +2523,7 @@ dispatch: proc = x; badfun: /* scm_everr (x, env,...) */ - scm_misc_error (NULL, "Wrong type to apply: ~S", SCM_LIST1 (proc)); + scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc)); case scm_tc7_vector: case scm_tc7_wvect: #ifdef HAVE_ARRAYS diff --git a/libguile/evalext.c b/libguile/evalext.c index b19f94c21..aa44cc502 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -63,8 +63,8 @@ scm_m_generalized_set_x (SCM xorig, SCM env SCM_UNUSED) if (SCM_SYMBOLP (SCM_CAR (x))) return scm_cons (SCM_IM_SET_X, x); else if (SCM_CONSP (SCM_CAR (x))) - return scm_cons (SCM_LIST2 (scm_sym_setter, SCM_CAAR (x)), - scm_append (SCM_LIST2 (SCM_CDAR (x), SCM_CDR (x)))); + return scm_cons (scm_list_2 (scm_sym_setter, SCM_CAAR (x)), + scm_append (scm_list_2 (SCM_CDAR (x), SCM_CDR (x)))); else scm_misc_error (scm_s_set_x, scm_s_variable, SCM_EOL); } diff --git a/libguile/filesys.c b/libguile/filesys.c index 0593414c3..4f7a5d09e 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -574,7 +574,8 @@ SCM_DEFINE (scm_stat, "stat", 1, 0, 0, int en = errno; SCM_SYSERROR_MSG ("~A: ~S", - SCM_LIST2 (scm_makfrom0str (strerror (errno)), object), + scm_list_2 (scm_makfrom0str (strerror (errno)), + object), en); } return scm_stat2scm (&stat_temp); @@ -753,7 +754,7 @@ SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0, SCM_VALIDATE_DIR (1, port); if (!SCM_DIR_OPEN_P (port)) - SCM_MISC_ERROR ("Directory ~S is not open.", SCM_LIST1 (port)); + SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port)); errno = 0; SCM_SYSCALL (rdent = readdir ((DIR *) SCM_CELL_WORD_1 (port))); @@ -774,7 +775,7 @@ SCM_DEFINE (scm_rewinddir, "rewinddir", 1, 0, 0, { SCM_VALIDATE_DIR (1, port); if (!SCM_DIR_OPEN_P (port)) - SCM_MISC_ERROR ("Directory ~S is not open.", SCM_LIST1 (port)); + SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port)); rewinddir ((DIR *) SCM_CELL_WORD_1 (port)); @@ -1162,9 +1163,9 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0, if (rv < 0) SCM_SYSERROR; } - return SCM_LIST3 (retrieve_select_type (&read_set, read_ports_ready, reads), - retrieve_select_type (&write_set, write_ports_ready, writes), - retrieve_select_type (&except_set, SCM_EOL, excepts)); + return scm_list_3 (retrieve_select_type (&read_set, read_ports_ready, reads), + retrieve_select_type (&write_set, write_ports_ready, writes), + retrieve_select_type (&except_set, SCM_EOL, excepts)); } #undef FUNC_NAME #endif /* HAVE_SELECT */ @@ -1325,7 +1326,7 @@ SCM_DEFINE (scm_lstat, "lstat", 1, 0, 0, int en = errno; SCM_SYSERROR_MSG ("~A: ~S", - SCM_LIST2 (scm_makfrom0str (strerror (errno)), str), + scm_list_2 (scm_makfrom0str (strerror (errno)), str), en); } return scm_stat2scm(&stat_temp); diff --git a/libguile/fluids.c b/libguile/fluids.c index 206808ab1..3f092ffff 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -253,7 +253,7 @@ SCM scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (), void *cdata) #define FUNC_NAME "scm_c_with_fluid" { - return scm_c_with_fluids (SCM_LIST1 (fluid), SCM_LIST1 (value), + return scm_c_with_fluids (scm_list_1 (fluid), SCM_LIST1 (value), cproc, cdata); } #undef FUNC_NAME diff --git a/libguile/gc.c b/libguile/gc.c index dc14f5216..ac7f8fe85 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -841,18 +841,18 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, local_scm_gc_cells_swept = scm_gc_cells_swept_acc; local_scm_gc_cells_marked = scm_gc_cells_marked_acc; - answer = scm_listify (scm_cons (sym_gc_time_taken, scm_ulong2num (local_scm_gc_time_taken)), - scm_cons (sym_cells_allocated, scm_ulong2num (local_scm_cells_allocated)), - scm_cons (sym_heap_size, scm_ulong2num (local_scm_heap_size)), - scm_cons (sym_mallocated, scm_ulong2num (local_scm_mallocated)), - scm_cons (sym_mtrigger, scm_ulong2num (local_scm_mtrigger)), - scm_cons (sym_times, scm_ulong2num (local_scm_gc_times)), - scm_cons (sym_gc_mark_time_taken, scm_ulong2num (local_scm_gc_mark_time_taken)), - scm_cons (sym_gc_sweep_time_taken, scm_ulong2num (local_scm_gc_sweep_time_taken)), - scm_cons (sym_cells_marked, scm_i_dbl2big (local_scm_gc_cells_marked)), - scm_cons (sym_cells_swept, scm_i_dbl2big (local_scm_gc_cells_swept)), - scm_cons (sym_heap_segments, heap_segs), - SCM_UNDEFINED); + answer = scm_list_n (scm_cons (sym_gc_time_taken, scm_ulong2num (local_scm_gc_time_taken)), + scm_cons (sym_cells_allocated, scm_ulong2num (local_scm_cells_allocated)), + scm_cons (sym_heap_size, scm_ulong2num (local_scm_heap_size)), + scm_cons (sym_mallocated, scm_ulong2num (local_scm_mallocated)), + scm_cons (sym_mtrigger, scm_ulong2num (local_scm_mtrigger)), + scm_cons (sym_times, scm_ulong2num (local_scm_gc_times)), + scm_cons (sym_gc_mark_time_taken, scm_ulong2num (local_scm_gc_mark_time_taken)), + scm_cons (sym_gc_sweep_time_taken, scm_ulong2num (local_scm_gc_sweep_time_taken)), + scm_cons (sym_cells_marked, scm_i_dbl2big (local_scm_gc_cells_marked)), + scm_cons (sym_cells_swept, scm_i_dbl2big (local_scm_gc_cells_swept)), + scm_cons (sym_heap_segments, heap_segs), + SCM_UNDEFINED); SCM_ALLOW_INTS; return answer; } diff --git a/libguile/gh.h b/libguile/gh.h index af1f952ed..dab80b07f 100644 --- a/libguile/gh.h +++ b/libguile/gh.h @@ -188,7 +188,7 @@ SCM gh_lookup (const char *sname); SCM gh_module_lookup (SCM module, const char *sname); SCM gh_cons(SCM x, SCM y); -#define gh_list scm_listify +#define gh_list scm_list_n unsigned long gh_length(SCM l); SCM gh_append(SCM args); SCM gh_append2(SCM l1, SCM l2); diff --git a/libguile/gh_list.c b/libguile/gh_list.c index 71af25ee8..6935ffc4a 100644 --- a/libguile/gh_list.c +++ b/libguile/gh_list.c @@ -59,27 +59,27 @@ gh_length (SCM l) them all together into a single list, which is returned. This is equivalent to the Scheme procedure (append list1 list2 ...) */ SCM -gh_append(SCM args) +gh_append (SCM args) { - return scm_append(args); + return scm_append (args); } SCM -gh_append2(SCM l1, SCM l2) +gh_append2 (SCM l1, SCM l2) { - return scm_append(scm_listify(l1, l2, SCM_UNDEFINED)); + return scm_append (scm_list_2 (l1, l2)); } SCM gh_append3(SCM l1, SCM l2, SCM l3) { - return scm_append(scm_listify(l1, l2, l3, SCM_UNDEFINED)); + return scm_append (scm_list_3 (l1, l2, l3)); } SCM -gh_append4(SCM l1, SCM l2, SCM l3, SCM l4) +gh_append4 (SCM l1, SCM l2, SCM l3, SCM l4) { - return scm_append(scm_listify(l1, l2, l3, l4, SCM_UNDEFINED)); + return scm_append (scm_list_4 (l1, l2, l3, l4)); } /* gh_reverse() is defined as a macro in gh.h */ diff --git a/libguile/goops.c b/libguile/goops.c index 3ae186e75..13a677218 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -76,22 +76,22 @@ #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers) #define DEFVAR(v,val) \ -{ scm_eval (SCM_LIST3 (scm_sym_define_public, (v), (val)), \ - scm_module_goops); } +{ scm_eval (scm_list_3 (scm_sym_define_public, (v), (val)), \ + scm_module_goops); } /* Temporary hack until we get the new module system */ /*fixme* Should optimize by keeping track of the variable object itself */ #define GETVAR(v) (SCM_VARIABLE_REF (scm_call_2 (scm_goops_lookup_closure, \ (v), SCM_BOOL_F))) /* Fixme: Should use already interned symbols */ -#define CALL_GF1(name,a) (scm_apply (GETVAR (scm_str2symbol (name)), \ - SCM_LIST1 (a), SCM_EOL)) -#define CALL_GF2(name,a,b) (scm_apply (GETVAR (scm_str2symbol (name)), \ - SCM_LIST2 (a, b), SCM_EOL)) -#define CALL_GF3(name,a,b,c) (scm_apply (GETVAR (scm_str2symbol (name)), \ - SCM_LIST3 (a, b, c), SCM_EOL)) -#define CALL_GF4(name,a,b,c,d) (scm_apply (GETVAR (scm_str2symbol (name)), \ - SCM_LIST4 (a, b, c, d), SCM_EOL)) +#define CALL_GF1(name,a) (scm_call_1 (GETVAR (scm_str2symbol (name)), \ + a)) +#define CALL_GF2(name,a,b) (scm_call_2 (GETVAR (scm_str2symbol (name)), \ + a, b)) +#define CALL_GF3(name,a,b,c) (scm_call_3 (GETVAR (scm_str2symbol (name)), \ + a, b, c)) +#define CALL_GF4(name,a,b,c,d) (scm_call_4 (GETVAR (scm_str2symbol (name)), \ + a, b, c, d)) /* Class redefinition protocol: @@ -245,7 +245,7 @@ remove_duplicate_slots (SCM l, SCM res, SCM slots_already_seen) tmp = SCM_CAAR (l); if (!SCM_SYMBOLP (tmp)) - scm_misc_error ("%compute-slots", "bad slot name ~S", SCM_LIST1 (tmp)); + scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp)); if (SCM_FALSEP (scm_c_memq (tmp, slots_already_seen))) { res = scm_cons (SCM_CAR (l), res); @@ -261,8 +261,9 @@ build_slots_list (SCM dslots, SCM cpl) register SCM res = dslots; for (cpl = SCM_CDR(cpl); SCM_NNULLP(cpl); cpl = SCM_CDR(cpl)) - res = scm_append (SCM_LIST2 (SCM_SLOT (SCM_CAR (cpl), scm_si_direct_slots), - res)); + res = scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl), + scm_si_direct_slots), + res)); /* res contains a list of slots. Remove slots which appears more than once */ return remove_duplicate_slots (scm_reverse (res), SCM_EOL, SCM_EOL); @@ -323,7 +324,7 @@ compute_getters_n_setters (SCM slots) { init = scm_get_keyword (k_init_value, options, 0); if (init) - init = scm_closure (SCM_LIST2 (SCM_EOL, init), SCM_EOL); + init = scm_closure (scm_list_2 (SCM_EOL, init), SCM_EOL); else init = scm_get_keyword (k_init_thunk, options, SCM_BOOL_F); } @@ -353,7 +354,7 @@ scm_i_get_keyword (SCM key, SCM l, long len, SCM default_value, const char *subr SCM obj = SCM_CAR (l); if (!SCM_KEYWORDP (obj)) - scm_misc_error (subr, "bad keyword: ~S", SCM_LIST1 (obj)); + scm_misc_error (subr, "bad keyword: ~S", scm_list_1 (obj)); else if (SCM_EQ_P (obj, key)) return SCM_CADR (l); else @@ -379,7 +380,7 @@ SCM_DEFINE (scm_get_keyword, "get-keyword", 3, 0, 0, SCM_ASSERT (SCM_KEYWORDP (key), key, SCM_ARG1, FUNC_NAME); len = scm_ilength (l); if (len < 0 || len % 2 == 1) - scm_misc_error (FUNC_NAME, "Bad keyword-value list: ~S", SCM_LIST1 (l)); + scm_misc_error (FUNC_NAME, "Bad keyword-value list: ~S", scm_list_1 (l)); return scm_i_get_keyword (key, l, len, default_value, FUNC_NAME); } @@ -422,7 +423,7 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0, long n = scm_ilength (SCM_CDR (slot_name)); if (n & 1) /* odd or -1 */ SCM_MISC_ERROR ("class contains bogus slot definition: ~S", - SCM_LIST1 (slot_name)); + scm_list_1 (slot_name)); tmp = scm_i_get_keyword (k_init_keyword, SCM_CDR (slot_name), n, @@ -434,7 +435,7 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0, /* an initarg was provided for this slot */ if (!SCM_KEYWORDP (tmp)) SCM_MISC_ERROR ("initarg must be a keyword. It was ~S", - SCM_LIST1 (tmp)); + scm_list_1 (tmp)); slot_value = scm_i_get_keyword (tmp, initargs, n_initargs, @@ -487,12 +488,12 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0, nfields = SCM_SLOT (class, scm_si_nfields); if (!SCM_INUMP (nfields) || SCM_INUM (nfields) < 0) SCM_MISC_ERROR ("bad value in nfields slot: ~S", - SCM_LIST1 (nfields)); + scm_list_1 (nfields)); n = 2 * SCM_INUM (nfields); if (n < sizeof (SCM_CLASS_CLASS_LAYOUT) - 1 && SCM_SUBCLASSP (class, scm_class_class)) SCM_MISC_ERROR ("class object doesn't have enough fields: ~S", - SCM_LIST1 (nfields)); + scm_list_1 (nfields)); s = n > 0 ? scm_must_malloc (n, FUNC_NAME) : 0; for (i = 0; i < n; i += 2) @@ -606,7 +607,7 @@ scm_basic_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots) /* Initialize its slots */ #if 0 - cpl = compute_cpl (dsupers, SCM_LIST1(z)); + cpl = compute_cpl (dsupers, scm_list_1 (z)); #endif SCM_SET_SLOT (z, scm_si_direct_supers, dsupers); cpl = compute_cpl (z); @@ -661,47 +662,47 @@ static SCM build_class_class_slots () { return maplist ( - scm_cons (SCM_LIST3 (scm_str2symbol ("layout"), - k_class, - scm_class_protected_read_only), - scm_cons (SCM_LIST3 (scm_str2symbol ("vcell"), - k_class, - scm_class_opaque), - scm_cons (SCM_LIST3 (scm_str2symbol ("vtable"), - k_class, - scm_class_self), + scm_cons (scm_list_3 (scm_str2symbol ("layout"), + k_class, + scm_class_protected_read_only), + scm_cons (scm_list_3 (scm_str2symbol ("vcell"), + k_class, + scm_class_opaque), + scm_cons (scm_list_3 (scm_str2symbol ("vtable"), + k_class, + scm_class_self), scm_cons (scm_str2symbol ("print"), - scm_cons (SCM_LIST3 (scm_str2symbol ("procedure"), - k_class, - scm_class_protected_opaque), - scm_cons (SCM_LIST3 (scm_str2symbol ("setter"), - k_class, - scm_class_protected_opaque), + scm_cons (scm_list_3 (scm_str2symbol ("procedure"), + k_class, + scm_class_protected_opaque), + scm_cons (scm_list_3 (scm_str2symbol ("setter"), + k_class, + scm_class_protected_opaque), scm_cons (scm_str2symbol ("redefined"), - scm_cons (SCM_LIST3 (scm_str2symbol ("h0"), - k_class, - scm_class_int), - scm_cons (SCM_LIST3 (scm_str2symbol ("h1"), - k_class, - scm_class_int), - scm_cons (SCM_LIST3 (scm_str2symbol ("h2"), - k_class, - scm_class_int), - scm_cons (SCM_LIST3 (scm_str2symbol ("h3"), - k_class, - scm_class_int), - scm_cons (SCM_LIST3 (scm_str2symbol ("h4"), - k_class, - scm_class_int), - scm_cons (SCM_LIST3 (scm_str2symbol ("h5"), - k_class, - scm_class_int), - scm_cons (SCM_LIST3 (scm_str2symbol ("h6"), - k_class, - scm_class_int), - scm_cons (SCM_LIST3 (scm_str2symbol ("h7"), - k_class, - scm_class_int), + scm_cons (scm_list_3 (scm_str2symbol ("h0"), + k_class, + scm_class_int), + scm_cons (scm_list_3 (scm_str2symbol ("h1"), + k_class, + scm_class_int), + scm_cons (scm_list_3 (scm_str2symbol ("h2"), + k_class, + scm_class_int), + scm_cons (scm_list_3 (scm_str2symbol ("h3"), + k_class, + scm_class_int), + scm_cons (scm_list_3 (scm_str2symbol ("h4"), + k_class, + scm_class_int), + scm_cons (scm_list_3 (scm_str2symbol ("h5"), + k_class, + scm_class_int), + scm_cons (scm_list_3 (scm_str2symbol ("h6"), + k_class, + scm_class_int), + scm_cons (scm_list_3 (scm_str2symbol ("h7"), + k_class, + scm_class_int), scm_cons (scm_str2symbol ("name"), scm_cons (scm_str2symbol ("direct-supers"), scm_cons (scm_str2symbol ("direct-slots"), @@ -763,16 +764,16 @@ create_basic_classes (void) name = scm_str2symbol (""); scm_class_object = scm_permanent_object (scm_basic_make_class (scm_class_class, name, - SCM_LIST1 (scm_class_top), + scm_list_1 (scm_class_top), SCM_EOL)); DEFVAR (name, scm_class_object); /* and were partially initialized. Correct them here */ - SCM_SET_SLOT (scm_class_object, scm_si_direct_subclasses, SCM_LIST1 (scm_class_class)); + SCM_SET_SLOT (scm_class_object, scm_si_direct_subclasses, scm_list_1 (scm_class_class)); - SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, SCM_LIST1 (scm_class_object)); - SCM_SET_SLOT (scm_class_class, scm_si_cpl, SCM_LIST3 (scm_class_class, scm_class_object, scm_class_top)); + SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, scm_list_1 (scm_class_object)); + SCM_SET_SLOT (scm_class_class, scm_si_cpl, scm_list_3 (scm_class_class, scm_class_object, scm_class_top)); } /******************************************************************************/ @@ -1065,7 +1066,7 @@ get_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef) if (!SCM_CLOSUREP (code)) return SCM_SUBRF (code) (obj); env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code), - SCM_LIST1 (obj), + scm_list_1 (obj), SCM_ENV (code)); /* Evaluate the closure body */ return scm_eval_body (SCM_CDR (SCM_CODE (code)), env); @@ -1104,7 +1105,7 @@ set_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef, SCM value) else { env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code), - SCM_LIST2 (obj, value), + scm_list_2 (obj, value), SCM_ENV (code)); /* Evaluate the closure body */ scm_eval_body (SCM_CDR (SCM_CODE (code)), env); @@ -1521,7 +1522,7 @@ scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED, SCM new_class) { if (!burnin (obj)) scm_internal_dynamic_wind (go_to_hell, purgatory, go_to_heaven, - (void *) SCM_LIST2 (obj, new_class), + (void *) scm_list_2 (obj, new_class), (void *) obj); } @@ -1552,10 +1553,12 @@ SCM_SYMBOL (scm_sym_args, "args"); SCM scm_make_method_cache (SCM gf) { - return SCM_LIST5 (SCM_IM_DISPATCH, scm_sym_args, SCM_MAKINUM (1), - scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE, - list_of_no_method), - gf); + return scm_list_5 (SCM_IM_DISPATCH, + scm_sym_args, + SCM_MAKINUM (1), + scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE, + list_of_no_method), + gf); } static void @@ -1616,9 +1619,9 @@ SCM_DEFINE (scm_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1 SCM_ASSERT (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr), subr, SCM_ARGn, FUNC_NAME); *SCM_SUBR_GENERIC (subr) - = scm_make (SCM_LIST3 (scm_class_generic, - k_name, - SCM_SNAME (subr))); + = scm_make (scm_list_3 (scm_class_generic, + k_name, + SCM_SNAME (subr))); subrs = SCM_CDR (subrs); } return SCM_UNSPECIFIED; @@ -1915,7 +1918,7 @@ scm_m_atdispatch (SCM xorig, SCM env) x = SCM_CDR (x); gf = SCM_XEVALCAR (x, env); SCM_VALIDATE_PUREGENERIC (SCM_ARG4, gf); - return SCM_LIST5 (SCM_IM_DISPATCH, args, n, v, gf); + return scm_list_5 (SCM_IM_DISPATCH, args, n, v, gf); } #undef FUNC_NAME @@ -2003,13 +2006,13 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1, { #ifdef USE_THREADS z = scm_make_struct (class, SCM_INUM0, - SCM_LIST4 (SCM_EOL, - SCM_INUM0, - SCM_BOOL_F, - scm_make_mutex ())); + scm_list_4 (SCM_EOL, + SCM_INUM0, + SCM_BOOL_F, + scm_make_mutex ())); #else z = scm_make_struct (class, SCM_INUM0, - SCM_LIST3 (SCM_EOL, SCM_INUM0, SCM_BOOL_F)); + scm_list_3 (SCM_EOL, SCM_INUM0, SCM_BOOL_F)); #endif scm_set_procedure_property_x (z, scm_sym_name, scm_get_keyword (k_name, @@ -2092,7 +2095,7 @@ SCM_DEFINE (scm_find_method, "find-method", 0, 0, 1, gf = SCM_CAR(l); l = SCM_CDR(l); SCM_VALIDATE_GENERIC (1, gf); if (SCM_NULLP (SCM_SLOT (gf, scm_si_methods))) - SCM_MISC_ERROR ("no methods for generic ~S", SCM_LIST1 (gf)); + SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf)); return scm_compute_applicable_methods (gf, l, len - 1, 1); } @@ -2139,7 +2142,7 @@ make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots) tmp, SCM_CONSP (super) ? super - : SCM_LIST1 (super), + : scm_list_1 (super), slots)); DEFVAR(tmp, *var); } @@ -2151,30 +2154,30 @@ static void create_standard_classes (void) { SCM slots; - SCM method_slots = SCM_LIST4 (scm_str2symbol ("generic-function"), - scm_str2symbol ("specializers"), - scm_str2symbol ("procedure"), - scm_str2symbol ("code-table")); - SCM amethod_slots = SCM_LIST1 (SCM_LIST3 (scm_str2symbol ("slot-definition"), - k_init_keyword, - k_slot_definition)); + SCM method_slots = scm_list_4 (scm_str2symbol ("generic-function"), + scm_str2symbol ("specializers"), + scm_str2symbol ("procedure"), + scm_str2symbol ("code-table")); + SCM amethod_slots = scm_list_1 (scm_list_3 (scm_str2symbol ("slot-definition"), + k_init_keyword, + k_slot_definition)); #ifdef USE_THREADS - SCM mutex_slot = SCM_LIST1 (scm_str2symbol ("make-mutex")); + SCM mutex_slot = scm_list_1 (scm_str2symbol ("make-mutex")); #else SCM mutex_slot = SCM_BOOL_F; #endif - SCM gf_slots = SCM_LIST4 (scm_str2symbol ("methods"), - SCM_LIST3 (scm_str2symbol ("n-specialized"), - k_init_value, - SCM_INUM0), - SCM_LIST3 (scm_str2symbol ("used-by"), - k_init_value, - SCM_BOOL_F), - SCM_LIST3 (scm_str2symbol ("cache-mutex"), - k_init_thunk, - scm_closure (SCM_LIST2 (SCM_EOL, - mutex_slot), - SCM_EOL))); + SCM gf_slots = scm_list_4 (scm_str2symbol ("methods"), + scm_list_3 (scm_str2symbol ("n-specialized"), + k_init_value, + SCM_INUM0), + scm_list_3 (scm_str2symbol ("used-by"), + k_init_value, + SCM_BOOL_F), + scm_list_3 (scm_str2symbol ("cache-mutex"), + k_init_thunk, + scm_closure (scm_list_2 (SCM_EOL, + mutex_slot), + SCM_EOL))); /* Foreign class slot classes */ make_stdcls (&scm_class_foreign_slot, "", @@ -2187,15 +2190,15 @@ create_standard_classes (void) scm_class_class, scm_class_foreign_slot, SCM_EOL); make_stdcls (&scm_class_self, "", scm_class_class, - SCM_LIST2 (scm_class_foreign_slot, scm_class_read_only), + scm_list_2 (scm_class_foreign_slot, scm_class_read_only), SCM_EOL); make_stdcls (&scm_class_protected_opaque, "", scm_class_class, - SCM_LIST2 (scm_class_protected, scm_class_opaque), + scm_list_2 (scm_class_protected, scm_class_opaque), SCM_EOL); make_stdcls (&scm_class_protected_read_only, "", scm_class_class, - SCM_LIST2 (scm_class_protected, scm_class_read_only), + scm_list_2 (scm_class_protected, scm_class_read_only), SCM_EOL); make_stdcls (&scm_class_scm, "", scm_class_class, scm_class_protected, SCM_EOL); @@ -2216,12 +2219,12 @@ create_standard_classes (void) make_stdcls (&scm_class_foreign_class, "", scm_class_class, scm_class_class, - SCM_LIST2 (SCM_LIST3 (scm_str2symbol ("constructor"), - k_class, - scm_class_opaque), - SCM_LIST3 (scm_str2symbol ("destructor"), - k_class, - scm_class_opaque))); + scm_list_2 (scm_list_3 (scm_str2symbol ("constructor"), + k_class, + scm_class_opaque), + scm_list_3 (scm_str2symbol ("destructor"), + k_class, + scm_class_opaque))); make_stdcls (&scm_class_foreign_object, "", scm_class_foreign_class, scm_class_object, SCM_EOL); SCM_SET_CLASS_FLAGS (scm_class_foreign_object, SCM_CLASSF_FOREIGN); @@ -2253,16 +2256,16 @@ create_standard_classes (void) SCM_SET_CLASS_FLAGS (scm_class_generic, SCM_CLASSF_PURE_GENERIC); make_stdcls (&scm_class_generic_with_setter, "", scm_class_entity_class, - SCM_LIST2 (scm_class_generic, scm_class_entity_with_setter), + scm_list_2 (scm_class_generic, scm_class_entity_with_setter), SCM_EOL); #if 0 /* Patch cpl since compute_cpl doesn't support multiple inheritance. */ SCM_SET_SLOT (scm_class_generic_with_setter, scm_si_cpl, - scm_append (SCM_LIST3 (SCM_LIST2 (scm_class_generic_with_setter, - scm_class_generic), - SCM_SLOT (scm_class_entity_with_setter, - scm_si_cpl), - SCM_EOL))); + scm_append (scm_list_3 (scm_list_2 (scm_class_generic_with_setter, + scm_class_generic), + SCM_SLOT (scm_class_entity_with_setter, + scm_si_cpl), + SCM_EOL))); #endif SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter, SCM_CLASSF_PURE_GENERIC); @@ -2309,7 +2312,7 @@ create_standard_classes (void) scm_class_class, scm_class_port, SCM_EOL); make_stdcls (&scm_class_input_output_port, "", scm_class_class, - SCM_LIST2 (scm_class_input_port, scm_class_output_port), + scm_list_2 (scm_class_input_port, scm_class_output_port), SCM_EOL); } @@ -2349,7 +2352,7 @@ scm_make_extended_class (char *type_name) { return make_class_from_template ("<%s>", type_name, - SCM_LIST1 (scm_class_top)); + scm_list_1 (scm_class_top)); } static void @@ -2376,21 +2379,20 @@ scm_make_port_classes (long ptobnum, char *type_name) { SCM c, class = make_class_from_template ("<%s-port>", type_name, - SCM_LIST1 (scm_class_port)); + scm_list_1 (scm_class_port)); scm_port_class[SCM_IN_PCLASS_INDEX + ptobnum] = make_class_from_template ("<%s-input-port>", type_name, - SCM_LIST2 (class, scm_class_input_port)); + scm_list_2 (class, scm_class_input_port)); scm_port_class[SCM_OUT_PCLASS_INDEX + ptobnum] = make_class_from_template ("<%s-output-port>", type_name, - SCM_LIST2 (class, scm_class_output_port)); + scm_list_2 (class, scm_class_output_port)); scm_port_class[SCM_INOUT_PCLASS_INDEX + ptobnum] = c = make_class_from_template ("<%s-input-output-port>", type_name, - SCM_LIST2 (class, - scm_class_input_output_port)); + scm_list_2 (class, scm_class_input_output_port)); /* Patch cpl (since this tree is too complex for the C level compute-cpl) */ SCM_SET_SLOT (c, scm_si_cpl, scm_cons2 (c, class, SCM_SLOT (scm_class_input_output_port, scm_si_cpl))); @@ -2447,7 +2449,7 @@ scm_make_foreign_object (SCM class, SCM initargs) void * (*constructor) (SCM) = (void * (*) (SCM)) SCM_SLOT (class, scm_si_constructor); if (constructor == 0) - SCM_MISC_ERROR ("Can't make instances of class ~S", SCM_LIST1 (class)); + SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class)); return scm_wrap_object (class, constructor (initargs)); } #undef FUNC_NAME @@ -2469,7 +2471,7 @@ scm_make_class (SCM meta, char *s_name, SCM supers, size_t size, SCM name, class; name = scm_str2symbol (s_name); if (SCM_IMP (supers)) - supers = SCM_LIST1 (scm_class_foreign_object); + supers = scm_list_1 (scm_class_foreign_object); class = scm_basic_basic_make_class (meta, name, supers, SCM_EOL); scm_sys_inherit_magic_x (class, supers); @@ -2513,40 +2515,42 @@ scm_add_slot (SCM class, char *slot_name, SCM slot_class, SCM get = scm_c_make_subr ("goops:get", scm_tc7_subr_1, getter); SCM set = scm_c_make_subr ("goops:set", scm_tc7_subr_2, setter ? setter : default_setter); - SCM getm = scm_closure (SCM_LIST2 (SCM_LIST1 (sym_o), - SCM_LIST2 (get, sym_o)), + SCM getm = scm_closure (scm_list_2 (scm_list_1 (sym_o), + scm_list_2 (get, sym_o)), SCM_EOL); - SCM setm = scm_closure (SCM_LIST2 (SCM_LIST2 (sym_o, sym_x), - SCM_LIST3 (set, sym_o, sym_x)), + SCM setm = scm_closure (scm_list_2 (scm_list_2 (sym_o, sym_x), + scm_list_3 (set, sym_o, sym_x)), SCM_EOL); { SCM name = scm_str2symbol (slot_name); SCM aname = scm_str2symbol (accessor_name); SCM gf = scm_ensure_accessor (aname); - SCM slot = SCM_LIST5 (name, - k_class, slot_class, - setter ? k_accessor : k_getter, - gf); - SCM gns = SCM_LIST4 (name, SCM_BOOL_F, get, set); + SCM slot = scm_list_5 (name, + k_class, + slot_class, + setter ? k_accessor : k_getter, + gf); + SCM gns = scm_list_4 (name, SCM_BOOL_F, get, set); - scm_add_method (gf, scm_make (SCM_LIST5 (scm_class_accessor, - k_specializers, - SCM_LIST1 (class), - k_procedure, getm))); + scm_add_method (gf, scm_make (scm_list_5 (scm_class_accessor, + k_specializers, + scm_list_1 (class), + k_procedure, + getm))); scm_add_method (scm_setter (gf), - scm_make (SCM_LIST5 (scm_class_accessor, - k_specializers, - SCM_LIST2 (class, - scm_class_top), - k_procedure, setm))); + scm_make (scm_list_5 (scm_class_accessor, + k_specializers, + scm_list_2 (class, scm_class_top), + k_procedure, + setm))); DEFVAR (aname, gf); SCM_SET_SLOT (class, scm_si_slots, - scm_append_x (SCM_LIST2 (SCM_SLOT (class, scm_si_slots), - SCM_LIST1 (slot)))); + scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots), + scm_list_1 (slot)))); SCM_SET_SLOT (class, scm_si_getters_n_setters, - scm_append_x (SCM_LIST2 (SCM_SLOT (class, scm_si_getters_n_setters), - SCM_LIST1 (gns)))); + scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters), + scm_list_1 (gns)))); } } { @@ -2589,10 +2593,9 @@ scm_ensure_accessor (SCM name) SCM gf = scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE, name, SCM_BOOL_F); if (!SCM_IS_A_P (gf, scm_class_generic_with_setter)) { - gf = scm_make (SCM_LIST3 (scm_class_generic, k_name, name)); - gf = scm_make (SCM_LIST5 (scm_class_generic_with_setter, - k_name, name, - k_setter, gf)); + gf = scm_make (scm_list_3 (scm_class_generic, k_name, name)); + gf = scm_make (scm_list_5 (scm_class_generic_with_setter, + k_name, name, k_setter, gf)); } return gf; } @@ -2602,7 +2605,7 @@ SCM_SYMBOL (sym_internal_add_method_x, "internal-add-method!"); void scm_add_method (SCM gf, SCM m) { - scm_eval (SCM_LIST3 (sym_internal_add_method_x, gf, m), scm_module_goops); + scm_eval (scm_list_3 (sym_internal_add_method_x, gf, m), scm_module_goops); } #ifdef GUILE_DEBUG @@ -2661,7 +2664,7 @@ scm_init_goops_builtins (void) #include "libguile/goops.x" #endif - list_of_no_method = scm_permanent_object (SCM_LIST1 (sym_no_method)); + list_of_no_method = scm_permanent_object (scm_list_1 (sym_no_method)); hell = scm_must_malloc (hell_size, "hell"); #ifdef USE_THREADS @@ -2677,9 +2680,9 @@ scm_init_goops_builtins (void) { SCM name = scm_str2symbol ("no-applicable-method"); scm_no_applicable_method - = scm_permanent_object (scm_make (SCM_LIST3 (scm_class_generic, - k_name, - name))); + = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic, + k_name, + name))); DEFVAR (name, scm_no_applicable_method); } diff --git a/libguile/gsubr.c b/libguile/gsubr.c index ebb09f3b1..e7513ba00 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -220,7 +220,7 @@ scm_gsubr_apply (SCM args) if (n > SCM_GSUBR_MAX) scm_misc_error (FUNC_NAME, "Function ~S has illegal arity ~S.", - SCM_LIST2 (self, SCM_MAKINUM (n))); + scm_list_2 (self, SCM_MAKINUM (n))); #endif args = SCM_CDR (args); for (i = 0; i < SCM_GSUBR_REQ (typ); i++) { diff --git a/libguile/guardians.c b/libguile/guardians.c index d579948ae..db9574635 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -230,7 +230,7 @@ guardian_apply (SCM guardian, SCM obj, SCM throw_p) { if (DESTROYED_P (GUARDIAN (guardian))) scm_misc_error ("guard", "attempted use of destroyed guardian: ~A", - SCM_LIST1 (guardian)); + scm_list_1 (guardian)); if (!SCM_UNBNDP (obj)) return scm_guard (guardian, obj, @@ -266,7 +266,7 @@ scm_guard (SCM guardian, SCM obj, int throw_p) if (throw_p) scm_misc_error ("guard", "object is already greedily guarded: ~A", - SCM_LIST1 (obj)); + scm_list_1 (obj)); else return SCM_BOOL_F; } @@ -401,7 +401,8 @@ SCM_DEFINE (scm_destroy_guardian_x, "destroy-guardian!", 1, 0, 0, if (DESTROYED_P (g)) { SCM_ALLOW_INTS; - SCM_MISC_ERROR ("guardian is already destroyed: ~A", SCM_LIST1 (guardian)); + SCM_MISC_ERROR ("guardian is already destroyed: ~A", + scm_list_1 (guardian)); } if (GREEDY_P (g)) diff --git a/libguile/hooks.c b/libguile/hooks.c index 120ef1287..e57aeb6d5 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -252,7 +252,7 @@ SCM_DEFINE (scm_add_hook_x, "add-hook!", 2, 1, 0, rest = scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook)); SCM_SET_HOOK_PROCEDURES (hook, (!SCM_UNBNDP (append_p) && !SCM_FALSEP (append_p) - ? scm_append_x (SCM_LIST2 (rest, SCM_LIST1 (proc))) + ? scm_append_x (scm_list_2 (rest, scm_list_1 (proc))) : scm_cons (proc, rest))); return SCM_UNSPECIFIED; } @@ -294,7 +294,7 @@ SCM_DEFINE (scm_run_hook, "run-hook", 1, 0, 1, SCM_VALIDATE_HOOK (1,hook); if (scm_ilength (args) != SCM_HOOK_ARITY (hook)) SCM_MISC_ERROR ("Hook ~S requires ~A arguments", - SCM_LIST2 (hook,SCM_MAKINUM (SCM_HOOK_ARITY (hook)))); + scm_list_2 (hook, SCM_MAKINUM (SCM_HOOK_ARITY (hook)))); scm_c_run_hook (hook, args); return SCM_UNSPECIFIED; } diff --git a/libguile/list.c b/libguile/list.c index 043444aa3..f39c99c91 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -60,8 +60,54 @@ /* creating lists */ +#define SCM_I_CONS(cell,x,y) \ +do { \ + SCM_NEWCELL (cell); \ + SCM_SET_CELL_OBJECT_0 (cell, x); \ + SCM_SET_CELL_OBJECT_1 (cell, y); \ +} while (0) + SCM -scm_listify (SCM elt, ...) +scm_list_1 (SCM e1) +{ + SCM c1; + SCM_I_CONS (c1, e1, SCM_EOL); + return c1; +} + +SCM +scm_list_2 (SCM e1, SCM e2) +{ + SCM c1, c2; + SCM_I_CONS (c2, e2, SCM_EOL); + SCM_I_CONS (c1, e1, c2); + return c1; +} + +SCM +scm_list_3 (SCM e1, SCM e2, SCM e3) +{ + SCM c1, c2, c3; + SCM_I_CONS (c3, e3, SCM_EOL); + SCM_I_CONS (c2, e2, c3); + SCM_I_CONS (c1, e1, c2); + return c1; +} + +SCM +scm_list_4 (SCM e1, SCM e2, SCM e3, SCM e4) +{ + return scm_cons2 (e1, e2, scm_list_2 (e3, e4)); +} + +SCM +scm_list_5 (SCM e1, SCM e2, SCM e3, SCM e4, SCM e5) +{ + return scm_cons2 (e1, e2, scm_list_3 (e3, e4, e5)); +} + +SCM +scm_list_n (SCM elt, ...) { va_list foo; SCM answer = SCM_EOL; @@ -286,7 +332,7 @@ SCM_DEFINE (scm_last_pair, "last-pair", 1, 0, 0, tortoise = SCM_CDR(tortoise); } while (! SCM_EQ_P (hare, tortoise)); - SCM_MISC_ERROR ("Circular structure in position 1: ~S", SCM_LIST1 (lst)); + SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst)); } #undef FUNC_NAME @@ -315,7 +361,7 @@ SCM_DEFINE (scm_reverse, "reverse", 1, 0, 0, tortoise = SCM_CDR (tortoise); } while (! SCM_EQ_P (hare, tortoise)); - SCM_MISC_ERROR ("Circular structure in position 1: ~S", SCM_LIST1 (lst)); + SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst)); } #undef FUNC_NAME diff --git a/libguile/list.h b/libguile/list.h index 4493816ee..ba8601974 100644 --- a/libguile/list.h +++ b/libguile/list.h @@ -48,26 +48,13 @@ -#define SCM_LIST0 SCM_EOL -#define SCM_LIST1(e0) scm_cons ((e0), SCM_EOL) -#define SCM_LIST2(e0, e1) scm_cons2 ((e0), (e1), SCM_EOL) -#define SCM_LIST3(e0, e1, e2) scm_cons ((e0), SCM_LIST2 ((e1), (e2))) -#define SCM_LIST4(e0, e1, e2, e3)\ - scm_cons2 ((e0), (e1), SCM_LIST2 ((e2), (e3))) -#define SCM_LIST5(e0, e1, e2, e3, e4)\ - scm_cons ((e0), SCM_LIST4 ((e1), (e2), (e3), (e4))) -#define SCM_LIST6(e0, e1, e2, e3, e4, e5)\ - scm_cons2 ((e0), (e1), SCM_LIST4 ((e2), (e3), (e4), (e5))) -#define SCM_LIST7(e0, e1, e2, e3, e4, e5, e6)\ - scm_cons ((e0), SCM_LIST6 ((e1), (e2), (e3), (e4), (e5), (e6))) -#define SCM_LIST8(e0, e1, e2, e3, e4, e5, e6, e7)\ - scm_cons2 ((e0), (e1), SCM_LIST6 ((e2), (e3), (e4), (e5), (e6), (e7))) -#define SCM_LIST9(e0, e1, e2, e3, e4, e5, e6, e7, e8)\ - scm_cons ((e0),\ - SCM_LIST8 ((e1), (e2), (e3), (e4), (e5), (e6), (e7), (e8))) - +extern SCM scm_list_1 (SCM e1); +extern SCM scm_list_2 (SCM e1, SCM e2); +extern SCM scm_list_3 (SCM e1, SCM e2, SCM e3); +extern SCM scm_list_4 (SCM e1, SCM e2, SCM e3, SCM e4); +extern SCM scm_list_5 (SCM e1, SCM e2, SCM e3, SCM e4, SCM e5); +extern SCM scm_list_n (SCM elt, ...); extern SCM scm_list_head (SCM lst, SCM k); -extern SCM scm_listify (SCM elt, ...); extern SCM scm_list (SCM objs); extern SCM scm_cons_star (SCM arg, SCM objs); extern SCM scm_null_p (SCM x); @@ -103,6 +90,26 @@ extern void scm_init_list (void); #if (SCM_DEBUG_DEPRECATED == 0) +#define SCM_LIST0 SCM_EOL +#define SCM_LIST1(e0) scm_cons ((e0), SCM_EOL) +#define SCM_LIST2(e0, e1) scm_cons2 ((e0), (e1), SCM_EOL) +#define SCM_LIST3(e0, e1, e2) scm_cons ((e0), SCM_LIST2 ((e1), (e2))) +#define SCM_LIST4(e0, e1, e2, e3)\ + scm_cons2 ((e0), (e1), SCM_LIST2 ((e2), (e3))) +#define SCM_LIST5(e0, e1, e2, e3, e4)\ + scm_cons ((e0), SCM_LIST4 ((e1), (e2), (e3), (e4))) +#define SCM_LIST6(e0, e1, e2, e3, e4, e5)\ + scm_cons2 ((e0), (e1), SCM_LIST4 ((e2), (e3), (e4), (e5))) +#define SCM_LIST7(e0, e1, e2, e3, e4, e5, e6)\ + scm_cons ((e0), SCM_LIST6 ((e1), (e2), (e3), (e4), (e5), (e6))) +#define SCM_LIST8(e0, e1, e2, e3, e4, e5, e6, e7)\ + scm_cons2 ((e0), (e1), SCM_LIST6 ((e2), (e3), (e4), (e5), (e6), (e7))) +#define SCM_LIST9(e0, e1, e2, e3, e4, e5, e6, e7, e8)\ + scm_cons ((e0),\ + SCM_LIST8 ((e1), (e2), (e3), (e4), (e5), (e6), (e7), (e8))) + +#define scm_listify scm_list_n + extern SCM scm_sloppy_memq (SCM x, SCM lst); extern SCM scm_sloppy_memv (SCM x, SCM lst); extern SCM scm_sloppy_member (SCM x, SCM lst); diff --git a/libguile/load.c b/libguile/load.c index 8cb726a04..8c9d16b30 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -243,9 +243,9 @@ scm_init_load_path () SCM path = SCM_EOL; #ifdef SCM_LIBRARY_DIR - path = SCM_LIST3 (scm_makfrom0str (SCM_SITE_DIR), - scm_makfrom0str (SCM_LIBRARY_DIR), - scm_makfrom0str (SCM_PKGDATA_DIR)); + path = scm_list_3 (scm_makfrom0str (SCM_SITE_DIR), + scm_makfrom0str (SCM_LIBRARY_DIR), + scm_makfrom0str (SCM_PKGDATA_DIR)); #endif /* SCM_LIBRARY_DIR */ path = scm_internal_parse_path (getenv ("GUILE_LOAD_PATH"), path); @@ -453,7 +453,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0, SCM_MISC_ERROR ((absolute ? "Unable to load file ~S" : "Unable to find file ~S in load path"), - SCM_LIST1 (filename)); + scm_list_1 (filename)); } return scm_primitive_load (full_filename); @@ -507,12 +507,12 @@ init_build_info () void scm_init_load () { - scm_listofnullstr = scm_permanent_object (SCM_LIST1 (scm_nullstr)); + scm_listofnullstr = scm_permanent_object (scm_list_1 (scm_nullstr)); scm_loc_load_path = SCM_VARIABLE_LOC (scm_c_define ("%load-path", SCM_EOL)); scm_loc_load_extensions = SCM_VARIABLE_LOC (scm_c_define ("%load-extensions", - SCM_LIST2 (scm_makfrom0str (".scm"), - scm_nullstr))); + scm_list_2 (scm_makfrom0str (".scm"), + scm_nullstr))); scm_loc_load_hook = SCM_VARIABLE_LOC (scm_c_define ("%load-hook", SCM_BOOL_F)); init_build_info (); diff --git a/libguile/modules.c b/libguile/modules.c index dd912cf2d..55d63d75f 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -170,7 +170,7 @@ scm_c_define_module (const char *name, void (*init)(void *), void *data) { SCM module = scm_call_1 (SCM_VARIABLE_REF (process_define_module_var), - SCM_LIST1 (convert_module_name (name))); + scm_list_1 (convert_module_name (name))); if (init) scm_c_call_with_current_module (module, (SCM (*)(void*))init, data); return module; @@ -180,7 +180,7 @@ void scm_c_use_module (const char *name) { scm_call_1 (SCM_VARIABLE_REF (process_use_modules_var), - SCM_LIST1 (convert_module_name (name))); + scm_list_1 (convert_module_name (name))); } static SCM module_export_x_var; @@ -440,7 +440,7 @@ scm_sym2var (SCM sym, SCM proc, SCM definep) } if (var != SCM_BOOL_F && !SCM_VARIABLEP (var)) - SCM_MISC_ERROR ("~S is not bound to a variable", SCM_LIST1 (sym)); + SCM_MISC_ERROR ("~S is not bound to a variable", scm_list_1 (sym)); return var; } @@ -461,7 +461,7 @@ scm_module_lookup (SCM module, SCM sym) var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F); if (SCM_FALSEP (var)) - SCM_MISC_ERROR ("unbound variable: ~S", SCM_LIST1 (sym)); + SCM_MISC_ERROR ("unbound variable: ~S", scm_list_1 (sym)); return var; } #undef FUNC_NAME @@ -478,7 +478,7 @@ scm_lookup (SCM sym) SCM var = scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F); if (SCM_FALSEP (var)) - scm_misc_error ("scm_lookup", "unbound variable: ~S", SCM_LIST1 (sym)); + scm_misc_error ("scm_lookup", "unbound variable: ~S", scm_list_1 (sym)); return var; } @@ -639,7 +639,7 @@ scm_post_boot_init_modules () #if SCM_DEBUG_DEPRECATED == 0 - module_prefix = PERM (SCM_LIST2 (scm_sym_app, scm_sym_modules)); + module_prefix = PERM (scm_list_2 (scm_sym_app, scm_sym_modules)); make_modules_in_var = PERM (scm_c_lookup ("make-modules-in")); root_module_lookup_closure = PERM (scm_module_lookup_closure (SCM_VARIABLE_REF (the_root_module_var))); @@ -669,7 +669,7 @@ scm_module_full_name (SCM name) if (SCM_EQ_P (SCM_CAR (name), scm_sym_app)) return name; else - return scm_append (SCM_LIST2 (module_prefix, name)); + return scm_append (scm_list_2 (module_prefix, name)); } SCM diff --git a/libguile/net_db.c b/libguile/net_db.c index 974ba888c..8bf5a312a 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -260,7 +260,7 @@ SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0, entry = getnetbyaddr (netnum, AF_INET); } if (!entry) - SCM_SYSERROR_MSG ("no such network ~A", SCM_LIST1 (net), errno); + SCM_SYSERROR_MSG ("no such network ~A", scm_list_1 (net), errno); ve[0] = scm_mem2string (entry->n_name, strlen (entry->n_name)); ve[1] = scm_makfromstrs (-1, entry->n_aliases); ve[2] = SCM_MAKINUM (entry->n_addrtype + 0L); @@ -310,7 +310,7 @@ SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0, entry = getprotobynumber (protonum); } if (!entry) - SCM_SYSERROR_MSG ("no such protocol ~A", SCM_LIST1 (protocol), errno); + SCM_SYSERROR_MSG ("no such protocol ~A", scm_list_1 (protocol), errno); ve[0] = scm_mem2string (entry->p_name, strlen (entry->p_name)); ve[1] = scm_makfromstrs (-1, entry->p_aliases); ve[2] = SCM_MAKINUM (entry->p_proto + 0L); @@ -374,7 +374,7 @@ SCM_DEFINE (scm_getserv, "getserv", 0, 2, 0, entry = getservbyport (htons (SCM_INUM (name)), SCM_STRING_CHARS (protocol)); } if (!entry) - SCM_SYSERROR_MSG("no such service ~A", SCM_LIST1 (name), errno); + SCM_SYSERROR_MSG("no such service ~A", scm_list_1 (name), errno); return scm_return_entry (entry); } #undef FUNC_NAME diff --git a/libguile/objects.c b/libguile/objects.c index 07a46e752..888da56dd 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -344,19 +344,19 @@ scm_call_generic_0 (SCM gf) SCM scm_call_generic_1 (SCM gf, SCM a1) { - return scm_apply_generic (gf, SCM_LIST1 (a1)); + return scm_apply_generic (gf, scm_list_1 (a1)); } SCM scm_call_generic_2 (SCM gf, SCM a1, SCM a2) { - return scm_apply_generic (gf, SCM_LIST2 (a1, a2)); + return scm_apply_generic (gf, scm_list_2 (a1, a2)); } SCM scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3) { - return scm_apply_generic (gf, SCM_LIST3 (a1, a2, a3)); + return scm_apply_generic (gf, scm_list_3 (a1, a2, a3)); } SCM_DEFINE (scm_entity_p, "entity?", 1, 0, 0, @@ -460,7 +460,7 @@ scm_i_make_class_object (SCM meta, SCM layout = scm_make_struct_layout (layout_string); c = scm_make_struct (meta, SCM_INUM0, - SCM_LIST4 (layout, SCM_BOOL_F, SCM_EOL, SCM_EOL)); + scm_list_4 (layout, SCM_BOOL_F, SCM_EOL, SCM_EOL)); SCM_SET_CLASS_FLAGS (c, flags); return c; } @@ -493,7 +493,7 @@ SCM_DEFINE (scm_make_subclass_object, "make-subclass-object", 2, 0, 0, /* Convert symbol->string */ pl = scm_mem2string (SCM_SYMBOL_CHARS (pl), SCM_SYMBOL_LENGTH (pl)); return scm_i_make_class_object (SCM_STRUCT_VTABLE (class), - scm_string_append (SCM_LIST2 (pl, layout)), + scm_string_append (scm_list_2 (pl, layout)), SCM_CLASS_FLAGS (class)); } #undef FUNC_NAME @@ -503,16 +503,16 @@ scm_init_objects () { SCM ms = scm_makfrom0str (SCM_METACLASS_STANDARD_LAYOUT); SCM mt = scm_make_vtable_vtable (ms, SCM_INUM0, - SCM_LIST3 (SCM_BOOL_F, SCM_EOL, SCM_EOL)); + scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL)); SCM os = scm_makfrom0str (SCM_METACLASS_OPERATOR_LAYOUT); SCM ot = scm_make_vtable_vtable (os, SCM_INUM0, - SCM_LIST3 (SCM_BOOL_F, SCM_EOL, SCM_EOL)); + scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL)); SCM es = scm_makfrom0str (SCM_ENTITY_LAYOUT); SCM el = scm_make_struct_layout (es); SCM et = scm_make_struct (mt, SCM_INUM0, - SCM_LIST4 (el, SCM_BOOL_F, SCM_EOL, SCM_EOL)); + scm_list_4 (el, SCM_BOOL_F, SCM_EOL, SCM_EOL)); scm_c_define ("", mt); scm_metaclass_standard = mt; diff --git a/libguile/options.c b/libguile/options.c index ffdb0ff72..84dbd369c 100644 --- a/libguile/options.c +++ b/libguile/options.c @@ -190,7 +190,7 @@ scm_options (SCM arg, scm_t_option options[], int n, const char *s) #ifndef SCM_RECKLESS scm_must_free ((char *) flags); scm_misc_error (s, "Unknown mode flag: ~S", - SCM_LIST1 (SCM_CAR (new_mode))); + scm_list_1 (SCM_CAR (new_mode))); #endif cont: new_mode = SCM_CDR (new_mode); diff --git a/libguile/pairs.c b/libguile/pairs.c index 24d1aec07..0a77e2baf 100644 --- a/libguile/pairs.c +++ b/libguile/pairs.c @@ -68,7 +68,7 @@ void scm_error_pair_access (SCM non_pair) { running = 1; scm_simple_format (scm_current_error_port (), - message, SCM_LIST1 (non_pair)); + message, scm_list_1 (non_pair)); abort (); } } diff --git a/libguile/ports.c b/libguile/ports.c index 68951a416..a62c4236e 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -483,7 +483,7 @@ scm_remove_from_port_table (SCM port) long i = p->entry; if (i >= scm_t_portable_size) - SCM_MISC_ERROR ("Port not in table: ~S", SCM_LIST1 (port)); + SCM_MISC_ERROR ("Port not in table: ~S", scm_list_1 (port)); if (p->putback_buf) scm_must_free (p->putback_buf); scm_must_free (p); diff --git a/libguile/print.c b/libguile/print.c index 9159f996b..37eddea02 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -973,16 +973,15 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, start = p + 1; continue; default: - scm_misc_error (s_scm_simple_format, - "FORMAT: Unsupported format option ~~~A - use (ice-9 format) instead", - SCM_LIST1 (SCM_MAKE_CHAR (*p))); + SCM_MISC_ERROR ("FORMAT: Unsupported format option ~~~A - use (ice-9 format) instead", + scm_list_1 (SCM_MAKE_CHAR (*p))); } if (!SCM_CONSP (args)) - scm_misc_error (s_scm_simple_format, "FORMAT: Missing argument for ~~~A", - SCM_LIST1 (SCM_MAKE_CHAR (*p))); + SCM_MISC_ERROR ("FORMAT: Missing argument for ~~~A", + scm_list_1 (SCM_MAKE_CHAR (*p))); scm_lfwrite (start, p - start - 1, destination); scm_prin1 (SCM_CAR (args), destination, writingp); @@ -992,8 +991,8 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, scm_lfwrite (start, p - start, destination); if (args != SCM_EOL) - scm_misc_error (s_scm_simple_format, - "FORMAT: ~A superfluous arguments", SCM_LIST1 (scm_length (args))); + SCM_MISC_ERROR ("FORMAT: ~A superfluous arguments", + scm_list_1 (scm_length (args))); if (fReturnString) answer = scm_strport_to_string (destination); @@ -1110,7 +1109,7 @@ scm_init_print () scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS); vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL); layout = scm_make_struct_layout (scm_makfrom0str (SCM_PRINT_STATE_LAYOUT)); - type = scm_make_struct (vtable, SCM_INUM0, SCM_LIST1 (layout)); + type = scm_make_struct (vtable, SCM_INUM0, scm_list_1 (layout)); scm_set_struct_vtable_name_x (type, scm_str2symbol ("print-state")); print_state_pool = scm_permanent_object (scm_cons (type, SCM_EOL)); diff --git a/libguile/procprop.c b/libguile/procprop.c index 7bfc96b3a..4186a8142 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -155,9 +155,7 @@ scm_i_procedure_arity (SCM proc) default: return SCM_BOOL_F; } - return SCM_LIST3 (SCM_MAKINUM (a), - SCM_MAKINUM (o), - SCM_BOOL(r)); + return scm_list_3 (SCM_MAKINUM (a), SCM_MAKINUM (o), SCM_BOOL(r)); } static SCM @@ -167,7 +165,7 @@ scm_stand_in_scm_proc(SCM proc) answer = scm_assoc (proc, scm_stand_in_procs); if (SCM_FALSEP (answer)) { - answer = scm_closure (SCM_LIST2 (SCM_EOL, SCM_BOOL_F), SCM_EOL); + answer = scm_closure (scm_list_2 (SCM_EOL, SCM_BOOL_F), SCM_EOL); scm_stand_in_procs = scm_acons (proc, answer, scm_stand_in_procs); } else diff --git a/libguile/read.c b/libguile/read.c index a7e690a1e..f93fa70c4 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -153,7 +153,7 @@ scm_flush_ws (SCM port, const char *eoferr) if (!SCM_FALSEP (SCM_FILENAME (port))) scm_misc_error (eoferr, "end of file in ~A", - SCM_LIST1 (SCM_FILENAME (port))); + scm_list_1 (SCM_FILENAME (port))); else scm_misc_error (eoferr, "end of file", SCM_EOL); } @@ -457,7 +457,7 @@ scm_lreadr (SCM *tok_buf,SCM port,SCM *copy) } unkshrp: scm_misc_error (s_scm_read, "Unknown # object: ~S", - SCM_LIST1 (SCM_MAKE_CHAR (c))); + scm_list_1 (SCM_MAKE_CHAR (c))); } case '"': diff --git a/libguile/script.c b/libguile/script.c index 7c7c3f162..0c4810446 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -565,11 +565,8 @@ scm_compile_shell_switches (int argc, char **argv) if (scm_ilength (srfis) <= 0) scm_shell_usage (1, "invalid SRFI specification"); srfis = scm_reverse_x (srfis, SCM_UNDEFINED); - tail = scm_cons (scm_listify - (sym_use_srfis, - scm_listify (scm_sym_quote, - srfis, SCM_UNDEFINED), - SCM_UNDEFINED), + tail = scm_cons (scm_list_2 (sym_use_srfis, + scm_list_2 (scm_sym_quote, srfis)), tail); } diff --git a/libguile/smob.c b/libguile/smob.c index 8105df7db..6d3c586e1 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -200,7 +200,7 @@ scm_smob_apply_1_030 (SCM smob, SCM a1) static SCM scm_smob_apply_1_001 (SCM smob, SCM a1) { - return SCM_SMOB_APPLY1 (smob, SCM_LIST1 (a1)); + return SCM_SMOB_APPLY1 (smob, scm_list_1 (a1)); } static SCM @@ -230,13 +230,13 @@ scm_smob_apply_2_030 (SCM smob, SCM a1, SCM a2) static SCM scm_smob_apply_2_001 (SCM smob, SCM a1, SCM a2) { - return SCM_SMOB_APPLY1 (smob, SCM_LIST2 (a1, a2)); + return SCM_SMOB_APPLY1 (smob, scm_list_2 (a1, a2)); } static SCM scm_smob_apply_2_011 (SCM smob, SCM a1, SCM a2) { - return SCM_SMOB_APPLY2 (smob, a1, SCM_LIST1 (a2)); + return SCM_SMOB_APPLY2 (smob, a1, scm_list_1 (a2)); } static SCM diff --git a/libguile/socket.c b/libguile/socket.c index 82d03fbc4..a0b852b77 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -970,7 +970,7 @@ scm_addr_vector (const struct sockaddr *address, const char *proc) #endif default: scm_misc_error (proc, "Unrecognised address family: ~A", - SCM_LIST1 (SCM_MAKINUM (fam))); + scm_list_1 (SCM_MAKINUM (fam))); } return result; } diff --git a/libguile/strings.c b/libguile/strings.c index b37309b14..f0d162d43 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -50,7 +50,9 @@ #include "libguile/chars.h" #include "libguile/root.h" #include "libguile/strings.h" +#include "libguile/deprecation.h" #include "libguile/validate.h" + /* {Strings} diff --git a/libguile/struct.c b/libguile/struct.c index 7f5227c36..e241a3f35 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -90,7 +90,7 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, len = SCM_STRING_LENGTH (fields); if (len % 2 == 1) SCM_MISC_ERROR ("odd length field specification: ~S", - SCM_LIST1 (fields)); + scm_list_1 (fields)); field_desc = SCM_STRING_CHARS (fields); @@ -108,7 +108,7 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, break; default: SCM_MISC_ERROR ("unrecognized field type: ~S", - SCM_LIST1 (SCM_MAKE_CHAR (field_desc[x]))); + scm_list_1 (SCM_MAKE_CHAR (field_desc[x]))); } switch (field_desc[x + 1]) @@ -131,14 +131,14 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, break; default: SCM_MISC_ERROR ("unrecognized ref specification: ~S", - SCM_LIST1 (SCM_MAKE_CHAR (field_desc[x + 1]))); + scm_list_1 (SCM_MAKE_CHAR (field_desc[x + 1]))); } #if 0 if (field_desc[x] == 'd') { if (field_desc[x + 2] != '-') SCM_MISC_ERROR ("missing dash field at position ~A", - SCM_LIST1 (SCM_MAKINUM (x / 2))); + scm_list_1 (SCM_MAKINUM (x / 2))); x += 2; goto recheck_ref; } @@ -539,7 +539,8 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, SCM_VALIDATE_INUM (2, tail_array_size); SCM_VALIDATE_REST_ARGUMENT (init); - fields = scm_string_append (SCM_LIST2 (required_vtable_fields, user_fields)); + fields = scm_string_append (scm_list_2 (required_vtable_fields, + user_fields)); layout = scm_make_struct_layout (fields); basic_size = SCM_SYMBOL_LENGTH (layout) / 2; tail_elts = SCM_INUM (tail_array_size); @@ -601,13 +602,13 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0, if ((ref == 'R') || (ref == 'W')) field_type = 'u'; else - SCM_MISC_ERROR ("ref denied for field ~A", SCM_LIST1 (pos)); + SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos)); } } else if (fields_desc[SCM_SYMBOL_LENGTH (layout) - 1] != 'O') field_type = fields_desc[SCM_SYMBOL_LENGTH (layout) - 2]; else - SCM_MISC_ERROR ("ref denied for field ~A", SCM_LIST1 (pos)); + SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos)); switch (field_type) { @@ -633,7 +634,7 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0, default: SCM_MISC_ERROR ("unrecognized field type: ~S", - SCM_LIST1 (SCM_MAKE_CHAR (field_type))); + scm_list_1 (SCM_MAKE_CHAR (field_type))); } return answer; @@ -673,12 +674,12 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0, field_type = fields_desc[p * 2]; set_x = fields_desc [p * 2 + 1]; if (set_x != 'w') - SCM_MISC_ERROR ("set! denied for field ~A", SCM_LIST1 (pos)); + SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos)); } else if (fields_desc[SCM_SYMBOL_LENGTH (layout) - 1] == 'W') field_type = fields_desc[SCM_SYMBOL_LENGTH (layout) - 2]; else - SCM_MISC_ERROR ("set! denied for field ~A", SCM_LIST1 (pos)); + SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos)); switch (field_type) { @@ -705,7 +706,7 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0, default: SCM_MISC_ERROR ("unrecognized field type: ~S", - SCM_LIST1 (SCM_MAKE_CHAR (field_type))); + scm_list_1 (SCM_MAKE_CHAR (field_type))); } return val; diff --git a/libguile/symbols-deprecated.c b/libguile/symbols-deprecated.c index 63dfdbd0d..6151a4494 100644 --- a/libguile/symbols-deprecated.c +++ b/libguile/symbols-deprecated.c @@ -112,7 +112,7 @@ scm_sym2ovcell (SCM sym, SCM obarray) answer = scm_sym2ovcell_soft (sym, obarray); if (!SCM_FALSEP (answer)) return answer; - SCM_MISC_ERROR ("uninterned symbol: ~S", SCM_LIST1 (sym)); + SCM_MISC_ERROR ("uninterned symbol: ~S", scm_list_1 (sym)); return SCM_UNSPECIFIED; /* not reached */ } #undef FUNC_NAME diff --git a/libguile/unif.c b/libguile/unif.c index 0e7319b7a..6feb7e6d6 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -2222,7 +2222,8 @@ SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, if (l2ra (lst, ra, SCM_ARRAY_BASE (ra), 0)) return ra; else - badlst:SCM_MISC_ERROR ("Bad scm_array contents list: ~S", SCM_LIST1 (lst)); + badlst:SCM_MISC_ERROR ("Bad scm_array contents list: ~S", + scm_list_1 (lst)); } #undef FUNC_NAME diff --git a/libguile/variable.c b/libguile/variable.c index 2a6da8c89..7e61680eb 100644 --- a/libguile/variable.c +++ b/libguile/variable.c @@ -130,7 +130,7 @@ SCM_DEFINE (scm_variable_ref, "variable-ref", 1, 0, 0, SCM_VALIDATE_VARIABLE (1, var); val = SCM_VARIABLE_REF (var); if (val == SCM_UNDEFINED) - SCM_MISC_ERROR ("variable is unbound: ~S", SCM_LIST1 (var)); + SCM_MISC_ERROR ("variable is unbound: ~S", scm_list_1 (var)); return val; } #undef FUNC_NAME diff --git a/libguile/vectors.c b/libguile/vectors.c index 89822ebdd..7f4cdaa88 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -244,10 +244,10 @@ scm_vector_set_x (SCM v, SCM k, SCM obj) #define FUNC_NAME s_vector_set_x { SCM_GASSERTn (SCM_VECTORP (v), - g_vector_set_x, SCM_LIST3 (v, k, obj), + g_vector_set_x, scm_list_3 (v, k, obj), SCM_ARG1, s_vector_set_x); SCM_GASSERTn (SCM_INUMP (k), - g_vector_set_x, SCM_LIST3 (v, k, obj), + g_vector_set_x, scm_list_3 (v, k, obj), SCM_ARG2, s_vector_set_x); SCM_ASSERT_RANGE (2, k, SCM_INUM (k) < SCM_VECTOR_LENGTH (v) && SCM_INUM (k) >= 0); SCM_VELTS(v)[(long) SCM_INUM(k)] = obj; From 20ec6e26380780bbd00d6c56c9788a0f6ae93ab3 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Thu, 28 Jun 2001 08:33:12 +0000 Subject: [PATCH 1402/2047] Fix typo. --- doc/scheme-binding.texi | 242 ---------------------------------------- 1 file changed, 242 deletions(-) diff --git a/doc/scheme-binding.texi b/doc/scheme-binding.texi index 8ea515e9f..e69de29bb 100644 --- a/doc/scheme-binding.texi +++ b/doc/scheme-binding.texi @@ -1,242 +0,0 @@ -@page -@node Binding Constructs -@chapter Definitions and Variable Bindings - -@c FIXME::martin: Review me! - -Scheme supports the definition of variables in different contexts. -Variables can be defined at the top level, so that they are visible in -the entire program, and variables can be defined locally to procedures -and expressions. This is important for modularity and data abstraction. - -@menu -* Top Level:: Top level variable definitions. -* Local Bindings:: Local variable bindings. -* Internal Definitions:: Internal definitions. -* Binding Reflection:: Querying variable bindings. -@end menu - - -@node Top Level -@section Top Level Variable Definitions - -@c FIXME::martin: Review me! - -@cindex variable definition - -On the top level of a program (e.g. when not inside of a procedure -definition or a @code{let}, @code{let*} or @code{letrec} expression), a -definition of the form - -@lisp -(define a 1) -@end lisp - -@noindent -defines a variable called @var{a} and sets it to the value 1. When the -variable already was bound with a @code{define} expression, the above -form is completely equivalent to - -@lisp -(set! a 1) -@end lisp - -@noindent -that means that @code{define} can be used interchangeably with -@code{set!} when at the top level of the REPL or a Scheme source file. -But note that a @code{set!} is not allowed if the variable was not bound -before. - -Attention: definitions inside local binding constructs (@pxref{Local -Bindings}) act differently (@pxref{Internal Definitions}). - - -@node Local Bindings -@section Local Variable Bindings - -@c FIXME::martin: Review me! - -@cindex local bindings -@cindex local variables - -As opposed to definitions at the top level, which are visible in the -whole program (or current module, when Guile modules are used), it is -also possible to define variables which are only visible in a -well-defined part of the program. Normally, this part of a program -will be a procedure or a subexpression of a procedure. - -With the constructs for local binding (@code{let}, @code{let*} and -@code{letrec}), the Scheme language has a block structure like most -other programming languages since the days of @sc{Algol 60}. Readers -familiar to languages like C or Java should already be used to this -concept, but the family of @code{let} expressions has a few properties -which are well worth knowing. - -The first local binding construct is @code{let}. The other constructs -@code{let*} and @code{letrec} are specialized versions for usage wher -using plain @code{let} is a bit inconvenient. - -@deffn syntax let bindings body -@var{bindings} has the form - -@lisp -((@var{variable1} @var{init1}) @dots{}) -@end lisp - -that is zero or more two-element lists of a variable and an arbitrary -expression each. All @var{variable} names must be distinct. - -A @code{let} expression is evaluated as follows. - -@itemize @bullet -@item -All @var{init} expressions are evaluated. - -@item -New storage is allocated for the @var{variables}. - -@item -The values of the @var{init} expressions are stored into the variables. - -@item -The expressions in @var{body} are evaluated in order, and the value of -the last expression is returned as the value of the @code{let} -expression. - -@item -The storage for the @var{variables} is freed. -@end itemize - -The @var{init} expressions are not allowed to refer to any of the -@var{variables}. -@end deffn - -@deffn syntax let* bindings body -Similar to @code{let}, but the variable bindings are performed -sequentially, that means that all @var{init} expression are allowed to -use the variables defined on their left in the binding list. - -A @code{let*} expression can always be expressed with nested @code{let} -expressions. - -@lisp -(let* ((a 1) (b a)) - b) -@equiv{} -(let ((a 1)) - (let ((b a)) - b)) -@end lisp -@end deffn - -@deffn syntax letrec bindings body -Similar to @code{let}, but it is possible to refer to the @var{variable} -from lambda expression created in any of the @var{inits}. That is, -procedures created in the @var{init} expression can recursively refer to -the defined variables. - -@lisp -(letrec ((even? - (lambda (n) - (if (zero? n) - #t - (odd? (- n 1))))) - (odd? - (lambda (n) - (if (zero? n) - #f - (even? (- n 1)))))) - (even? 88)) -@result{} -#t -@end lisp -@end deffn - -There is also an alternative form of the @code{let} form, which is used -for expressing iteration. Because of the use as a looping construct, -this form (the @dfn{named let}) is documented in the section about -iteration (@pxref{while do, Iteration}) - -@node Internal Definitions -@section Internal definitions - -@c FIXME::martin: Review me! - -A @code{define} form which appears inside the body of a @code{lambda}, -@code{let}, @code{let*}, @code{letrec} or equivalent expression is -called an @dfn{internal definition}. An internal definition differs -from a top level definition (@pxref{Top Level}), because the definition -is only visible inside the complete body of the enclosing form. Let us -examine the following example. - -@lisp -(let ((frumble "froz")) - (define banana (lambda () (apple 'peach))) - (define apple (lambda (x) x)) - (banana)) -@result{} -peach -@end lisp - -Here the enclosing form is a @code{let}, so the @code{define}s in the -@code{let}-body are internal definitions. Because the scope of the -internal definitions is the @strong{complete} body of the -@code{let}-expression, the @code{lambda}-expression which gets bound -to the variable @code{banana} may refer to the variable @code{apple}, -even thogh it's definition appears lexically @emph{after} the definition -of @code{banana}. This is because a sequence of internal definition -acts as if it were a @code{letrec} expression. - -@lisp -(let () - (define a 1) - (define b 2) - (+ a b)) -@end lisp - -@noindent -is equivalent to - -@lisp -(let () - (letrec ((a 1) (b 2)) - (+ a b))) -@end lisp - -Another noteworthy difference to top level definitions is that within -one group of internal definitions all variable names must be distinct. -That means where on the top level a second define for a given variable -acts like a @code{set!}, an exception is thrown for internal definitions -with duplicate bindings. - -@c FIXME::martin: The following is required by R5RS, but Guile does not -@c signal an error. Document it anyway, saying that Guile is sloppy? - -@c Internal definitions are only allowed at the beginning of the body of an -@c enclosing expression. They may not be mixed with other expressions. - -@c @lisp -@c (let () -@c (define a 1) -@c a -@c (define b 2) -@c b) -@c @end lisp - -@node Binding Reflection -@section Querying variable bindings - -Guile provides a procedure for checking wehther a symbol is bound in the -top level environment. If you want to test whether a symbol is locally -bound in expression, you can use the @code{bound?} macro from the module -@code{(ice-9 optargs)}, documented in @ref{Optional Arguments}. - -@c NJFIXME explain [env] -@deffn primitive defined? sym [env] -Return @code{#t} if @var{sym} is defined in the top-level environment. -@end deffn - - -@c Local Variables: -@c TeX-master: "guile.texi" -@c End: From df1ad0d146b78a4eeefaf0e0eb33de7cbf0354ff Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 28 Jun 2001 16:37:19 +0000 Subject: [PATCH 1403/2047] * fluids.c (scm_c_with_fluid): Use scm_list_1() instead of SCM_LIST1. --- libguile/ChangeLog | 5 +++++ libguile/fluids.c | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 058620928..410790cd5 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-06-28 Martin Grabmueller + + * fluids.c (scm_c_with_fluid): Use scm_list_1() instead of + SCM_LIST1. + 2001-06-28 Keisuke Nishida * list.h (scm_list_1, scm_list_2, scm_list_3, scm_list_4, scm_list_5, diff --git a/libguile/fluids.c b/libguile/fluids.c index 3f092ffff..ea6c16069 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -253,7 +253,7 @@ SCM scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (), void *cdata) #define FUNC_NAME "scm_c_with_fluid" { - return scm_c_with_fluids (scm_list_1 (fluid), SCM_LIST1 (value), + return scm_c_with_fluids (scm_list_1 (fluid), scm_list_1 (value), cproc, cdata); } #undef FUNC_NAME From 2c4df451863763567ee9813093e6f81b30244d53 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 28 Jun 2001 16:39:00 +0000 Subject: [PATCH 1404/2047] * srfi-4.c: Minor cleanups. * srfi-14.c (scm_char_set_fold, scm_char_set_unfold) (scm_char_set_unfold_x, scm_char_set_for_each) (scm_char_set_map, scm_char_set_filter) (scm_char_set_filter_x, scm_char_set_count) (scm_char_set_every, scm_char_set_any): Replace calls to scm_apply() with the corresponding scm_call_N() functions. * srfi-14.c (scm_char_set_ref, scm_char_set_cursor_next) (scm_char_set_unfold, scm_char_set_unfold_x) (scm_char_set_map, scm_char_set_diff_plus_intersection) (scm_char_set_diff_plus_intersection_x): Replace deprecated macros SCM_LISTN with calls to scm_list_N(). * srfi-13.c (scm_string_tabulate, scm_string_map) (scm_string_map_x, scm_string_unfold) (scm_string_unfold_right): Replace deprecated macros SCM_LISTN with calls to scm_list_N(). * srfi-13.c (scm_string_any, scm_string_every), (scm_string_tabulate, scm_string_trim), (scm_string_trim_right, scm_string_trim_both), (scm_string_compare, scm_string_compare_ci), (scm_string_indexS, scm_string_index_right), (scm_string_skip, scm_string_skip_right, scm_string_count), (scm_string_map, scm_string_map_x, scm_string_fold), (scm_string_fold_right, scm_string_unfold), (scm_string_unfold_right, scm_string_for_each), (scm_string_filter, scm_string_delete): Replace calls to scm_apply() with the corresponding scm_call_N() functions. --- srfi/ChangeLog | 34 ++++++++++++++ srfi/srfi-13.c | 119 +++++++++++++++++++++++-------------------------- srfi/srfi-14.c | 67 +++++++++++++++++----------- srfi/srfi-4.c | 5 +++ 4 files changed, 137 insertions(+), 88 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 0984f87bb..4f56cc6dd 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,37 @@ +2001-06-28 Martin Grabmueller + + * srfi-4.c: Minor cleanups. + + * srfi-14.c (scm_char_set_fold, scm_char_set_unfold) + (scm_char_set_unfold_x, scm_char_set_for_each) + (scm_char_set_map, scm_char_set_filter) + (scm_char_set_filter_x, scm_char_set_count) + (scm_char_set_every, scm_char_set_any): Replace calls to + scm_apply() with the corresponding scm_call_N() functions. + + * srfi-14.c (scm_char_set_ref, scm_char_set_cursor_next) + (scm_char_set_unfold, scm_char_set_unfold_x) + (scm_char_set_map, scm_char_set_diff_plus_intersection) + (scm_char_set_diff_plus_intersection_x): Replace deprecated macros + SCM_LISTN with calls to scm_list_N(). + + * srfi-13.c (scm_string_tabulate, scm_string_map) + (scm_string_map_x, scm_string_unfold) + (scm_string_unfold_right): Replace deprecated macros SCM_LISTN + with calls to scm_list_N(). + + * srfi-13.c (scm_string_any, scm_string_every), + (scm_string_tabulate, scm_string_trim), + (scm_string_trim_right, scm_string_trim_both), + (scm_string_compare, scm_string_compare_ci), + (scm_string_indexS, scm_string_index_right), + (scm_string_skip, scm_string_skip_right, scm_string_count), + (scm_string_map, scm_string_map_x, scm_string_fold), + (scm_string_fold_right, scm_string_unfold), + (scm_string_unfold_right, scm_string_for_each), + (scm_string_filter, scm_string_delete): Replace calls to + scm_apply() with the corresponding scm_call_N() functions. + 2001-06-27 Martin Grabmueller * Makefile.am: Added SRFI-4 files in various places. diff --git a/srfi/srfi-13.c b/srfi/srfi-13.c index af34b03e2..acd043b9c 100644 --- a/srfi/srfi-13.c +++ b/srfi/srfi-13.c @@ -72,7 +72,7 @@ SCM_DEFINE (scm_string_any, "string-any", 2, 2, 0, cstr += cstart; while (cstart < cend) { - res = scm_apply (pred, SCM_MAKE_CHAR (*cstr), scm_listofnull); + res = scm_call_1 (pred, SCM_MAKE_CHAR (*cstr)); if (!SCM_FALSEP (res)) return res; cstr++; @@ -104,7 +104,7 @@ SCM_DEFINE (scm_string_every, "string-every", 2, 2, 0, cstr += cstart; while (cstart < cend) { - res = scm_apply (pred, SCM_MAKE_CHAR (*cstr), scm_listofnull); + res = scm_call_1 (pred, SCM_MAKE_CHAR (*cstr)); if (SCM_FALSEP (res)) return res; cstr++; @@ -137,9 +137,9 @@ SCM_DEFINE (scm_string_tabulate, "string-tabulate", 2, 0, 0, i = 0; while (i < clen) { - ch = scm_apply (proc, SCM_MAKINUM (i), scm_listofnull); + ch = scm_call_1 (proc, SCM_MAKINUM (i)); if (!SCM_CHARP (ch)) - SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (proc)); + SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); *p++ = SCM_CHAR (ch); i++; } @@ -650,8 +650,7 @@ SCM_DEFINE (scm_string_trim, "string-trim", 1, 3, 0, { SCM res; - res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cstart]), - scm_listofnull); + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart])); if (SCM_FALSEP (res)) break; cstart++; @@ -726,8 +725,7 @@ SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1, 3, 0, { SCM res; - res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cend - 1]), - scm_listofnull); + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend - 1])); if (SCM_FALSEP (res)) break; cend--; @@ -820,8 +818,7 @@ SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 0, { SCM res; - res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cstart]), - scm_listofnull); + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart])); if (SCM_FALSEP (res)) break; cstart++; @@ -830,8 +827,7 @@ SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 0, { SCM res; - res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cend - 1]), - scm_listofnull); + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend - 1])); if (SCM_FALSEP (res)) break; cend--; @@ -890,18 +886,18 @@ SCM_DEFINE (scm_string_compare, "string-compare", 5, 4, 0, while (cstart1 < cend1 && cstart2 < cend2) { if (cstr1[cstart1] < cstr2[cstart2]) - return scm_apply (proc_lt, SCM_MAKINUM (cstart1), scm_listofnull); + return scm_call_1 (proc_lt, SCM_MAKINUM (cstart1)); else if (cstr1[cstart1] > cstr2[cstart2]) - return scm_apply (proc_gt, SCM_MAKINUM (cstart1), scm_listofnull); + return scm_call_1 (proc_gt, SCM_MAKINUM (cstart1)); cstart1++; cstart2++; } if (cstart1 < cend1) - return scm_apply (proc_gt, SCM_MAKINUM (cstart1), scm_listofnull); + return scm_call_1 (proc_gt, SCM_MAKINUM (cstart1)); else if (cstart2 < cend2) - return scm_apply (proc_lt, SCM_MAKINUM (cstart1), scm_listofnull); + return scm_call_1 (proc_lt, SCM_MAKINUM (cstart1)); else - return scm_apply (proc_eq, SCM_MAKINUM (cstart1), scm_listofnull); + return scm_call_1 (proc_eq, SCM_MAKINUM (cstart1)); } #undef FUNC_NAME @@ -933,18 +929,18 @@ SCM_DEFINE (scm_string_compare_ci, "string-compare-ci", 5, 4, 0, while (cstart1 < cend1 && cstart2 < cend2) { if (scm_downcase (cstr1[cstart1]) < scm_downcase (cstr2[cstart2])) - return scm_apply (proc_lt, SCM_MAKINUM (cstart1), scm_listofnull); + return scm_call_1 (proc_lt, SCM_MAKINUM (cstart1)); else if (scm_downcase (cstr1[cstart1]) > scm_downcase (cstr2[cstart2])) - return scm_apply (proc_gt, SCM_MAKINUM (cstart1), scm_listofnull); + return scm_call_1 (proc_gt, SCM_MAKINUM (cstart1)); cstart1++; cstart2++; } if (cstart1 < cend1) - return scm_apply (proc_gt, SCM_MAKINUM (cstart1), scm_listofnull); + return scm_call_1 (proc_gt, SCM_MAKINUM (cstart1)); else if (cstart2 < cend2) - return scm_apply (proc_lt, SCM_MAKINUM (cstart1), scm_listofnull); + return scm_call_1 (proc_lt, SCM_MAKINUM (cstart1)); else - return scm_apply (proc_eq, SCM_MAKINUM (cstart1), scm_listofnull); + return scm_call_1 (proc_eq, SCM_MAKINUM (cstart1)); } #undef FUNC_NAME @@ -1657,8 +1653,7 @@ SCM_DEFINE (scm_string_indexS, "string-index", 2, 2, 0, while (cstart < cend) { SCM res; - res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cstart]), - scm_listofnull); + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart])); if (!SCM_FALSEP (res)) return SCM_MAKINUM (cstart); cstart++; @@ -1718,8 +1713,7 @@ SCM_DEFINE (scm_string_index_right, "string-index-right", 2, 2, 0, { SCM res; cend--; - res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cend]), - scm_listofnull); + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend])); if (!SCM_FALSEP (res)) return SCM_MAKINUM (cend); } @@ -1778,8 +1772,7 @@ SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0, while (cstart < cend) { SCM res; - res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cstart]), - scm_listofnull); + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart])); if (SCM_FALSEP (res)) return SCM_MAKINUM (cstart); cstart++; @@ -1840,8 +1833,7 @@ SCM_DEFINE (scm_string_skip_right, "string-skip-right", 2, 2, 0, { SCM res; cend--; - res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cend]), - scm_listofnull); + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend])); if (SCM_FALSEP (res)) return SCM_MAKINUM (cend); } @@ -1900,8 +1892,7 @@ SCM_DEFINE (scm_string_count, "string-count", 2, 2, 0, while (cstart < cend) { SCM res; - res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cstart]), - scm_listofnull); + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart])); if (!SCM_FALSEP (res)) count++; cstart++; @@ -2427,10 +2418,9 @@ SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0, p = SCM_STRING_CHARS (result); while (cstart < cend) { - SCM ch = scm_apply (proc, SCM_MAKE_CHAR (cstr[cstart]), - scm_listofnull); + SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (cstr[cstart])); if (!SCM_CHARP (ch)) - SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (proc)); + SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); cstart++; *p++ = SCM_CHAR (ch); } @@ -2457,10 +2447,9 @@ SCM_DEFINE (scm_string_map_x, "string-map!", 2, 2, 0, p = SCM_STRING_CHARS (s) + cstart; while (cstart < cend) { - SCM ch = scm_apply (proc, SCM_MAKE_CHAR (cstr[cstart]), - scm_listofnull); + SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (cstr[cstart])); if (!SCM_CHARP (ch)) - SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (proc)); + SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); cstart++; *p++ = SCM_CHAR (ch); } @@ -2488,8 +2477,7 @@ SCM_DEFINE (scm_string_fold, "string-fold", 3, 2, 0, result = knil; while (cstart < cend) { - result = scm_apply (kons, SCM_LIST2 (SCM_MAKE_CHAR (cstr[cstart]), - result), SCM_EOL); + result = scm_call_2 (kons, SCM_MAKE_CHAR (cstr[cstart]), result); cstart++; } return result; @@ -2516,8 +2504,7 @@ SCM_DEFINE (scm_string_fold_right, "string-fold-right", 3, 2, 0, result = knil; while (cstart < cend) { - result = scm_apply (kons, SCM_LIST2 (SCM_MAKE_CHAR (cstr[cend - 1]), - result), SCM_EOL); + result = scm_call_2 (kons, SCM_MAKE_CHAR (cstr[cend - 1]), result); cend--; } return result; @@ -2562,24 +2549,24 @@ SCM_DEFINE (scm_string_unfold, "string-unfold", 4, 2, 0, if (!SCM_UNBNDP (make_final)) SCM_VALIDATE_PROC (6, make_final); - res = scm_apply (p, seed, scm_listofnull); + res = scm_call_1 (p, seed); while (SCM_FALSEP (res)) { SCM str; - SCM ch = scm_apply (f, seed, scm_listofnull); + SCM ch = scm_call_1 (f, seed); if (!SCM_CHARP (ch)) - SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (f)); + SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f)); str = scm_allocate_string (1); *SCM_STRING_CHARS (str) = SCM_CHAR (ch); - ans = scm_string_append (SCM_LIST2 (ans, str)); - seed = scm_apply (g, seed, scm_listofnull); - res = scm_apply (p, seed, scm_listofnull); + ans = scm_string_append (scm_list_2 (ans, str)); + seed = scm_call_1 (g, seed); + res = scm_call_1 (p, seed); } if (!SCM_UNBNDP (make_final)) { - res = scm_apply (make_final, seed, scm_listofnull); - return scm_string_append (SCM_LIST2 (ans, res)); + res = scm_call_1 (make_final, seed); + return scm_string_append (scm_list_2 (ans, res)); } else return ans; @@ -2624,24 +2611,24 @@ SCM_DEFINE (scm_string_unfold_right, "string-unfold-right", 4, 2, 0, if (!SCM_UNBNDP (make_final)) SCM_VALIDATE_PROC (6, make_final); - res = scm_apply (p, seed, scm_listofnull); + res = scm_call_1 (p, seed); while (SCM_FALSEP (res)) { SCM str; - SCM ch = scm_apply (f, seed, scm_listofnull); + SCM ch = scm_call_1 (f, seed); if (!SCM_CHARP (ch)) - SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (f)); + SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f)); str = scm_allocate_string (1); *SCM_STRING_CHARS (str) = SCM_CHAR (ch); - ans = scm_string_append (SCM_LIST2 (str, ans)); - seed = scm_apply (g, seed, scm_listofnull); - res = scm_apply (p, seed, scm_listofnull); + ans = scm_string_append (scm_list_2 (str, ans)); + seed = scm_call_1 (g, seed); + res = scm_call_1 (p, seed); } if (!SCM_UNBNDP (make_final)) { - res = scm_apply (make_final, seed, scm_listofnull); - return scm_string_append (SCM_LIST2 (res, ans)); + res = scm_call_1 (make_final, seed); + return scm_string_append (scm_list_2 (res, ans)); } else return ans; @@ -2664,7 +2651,7 @@ SCM_DEFINE (scm_string_for_each, "string-for-each", 2, 2, 0, SCM_VALIDATE_PROC (2, proc); while (cstart < cend) { - scm_apply (proc, SCM_MAKE_CHAR (cstr[cstart]), scm_listofnull); + scm_call_1 (proc, SCM_MAKE_CHAR (cstr[cstart])); cstart++; } return SCM_UNSPECIFIED; @@ -2940,8 +2927,7 @@ SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0, while (idx < cend) { SCM res; - res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[idx]), - scm_listofnull); + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[idx])); if (!SCM_FALSEP (res)) ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); idx++; @@ -3007,8 +2993,7 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0, while (idx < cend) { SCM res; - res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[idx]), - scm_listofnull); + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[idx])); if (SCM_FALSEP (res)) ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); idx++; @@ -3020,11 +3005,19 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0, #undef FUNC_NAME +/* Initialize the SRFI-13 module. This function will be called by the + loading Scheme module. */ void scm_init_srfi_13 (void) { + /* We initialize the SRFI-14 module here, because the string + primitives need the charset smob type created by that module. */ scm_c_init_srfi_14 (); + + /* Install the string primitives. */ #ifndef SCM_MAGIC_SNARFER #include "srfi/srfi-13.x" #endif } + +/* End of srfi-13.c. */ diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index de9713bd9..3ee4ea8a2 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -237,7 +237,7 @@ SCM_DEFINE (scm_char_set_ref, "char-set-ref", 2, 0, 0, SCM_VALIDATE_INUM_COPY (2, cursor, ccursor); if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor)) - SCM_MISC_ERROR ("invalid character set cursor: ~A", SCM_LIST1 (cursor)); + SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor)); return SCM_MAKE_CHAR (ccursor); } #undef FUNC_NAME @@ -256,7 +256,7 @@ SCM_DEFINE (scm_char_set_cursor_next, "char-set-cursor-next", 2, 0, 0, SCM_VALIDATE_INUM_COPY (2, cursor, ccursor); if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor)) - SCM_MISC_ERROR ("invalid character set cursor: ~A", SCM_LIST1 (cursor)); + SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor)); for (ccursor++; ccursor < SCM_CHARSET_SIZE; ccursor++) { if (SCM_CHARSET_GET (cs, ccursor)) @@ -295,13 +295,13 @@ SCM_DEFINE (scm_char_set_fold, "char-set-fold", 3, 0, 0, for (k = 0; k < SCM_CHARSET_SIZE; k++) if (SCM_CHARSET_GET (cs, k)) { - knil = scm_apply (kons, SCM_LIST2 (SCM_MAKE_CHAR (k), (knil)), - SCM_EOL); + knil = scm_call_2 (kons, SCM_MAKE_CHAR (k), knil); } return knil; } #undef FUNC_NAME + SCM_DEFINE (scm_char_set_unfold, "char-set-unfold", 4, 1, 0, (SCM p, SCM f, SCM g, SCM seed, SCM base_cs), "This is a fundamental constructor for character sets.\n" @@ -330,16 +330,16 @@ SCM_DEFINE (scm_char_set_unfold, "char-set-unfold", 4, 1, 0, else result = make_char_set (FUNC_NAME); - tmp = scm_apply (p, seed, scm_listofnull); + tmp = scm_call_1 (p, seed); while (SCM_FALSEP (tmp)) { - SCM ch = scm_apply (f, seed, scm_listofnull); + SCM ch = scm_call_1 (f, seed); if (!SCM_CHARP (ch)) - SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (f)); + SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f)); SCM_CHARSET_SET (result, SCM_CHAR (ch)); - seed = scm_apply (g, seed, scm_listofnull); - tmp = scm_apply (p, seed, scm_listofnull); + seed = scm_call_1 (g, seed); + tmp = scm_call_1 (p, seed); } return result; } @@ -368,16 +368,16 @@ SCM_DEFINE (scm_char_set_unfold_x, "char-set-unfold!", 5, 0, 0, SCM_VALIDATE_PROC (3, g); SCM_VALIDATE_SMOB (5, base_cs, charset); - tmp = scm_apply (p, seed, scm_listofnull); + tmp = scm_call_1 (p, seed); while (SCM_FALSEP (tmp)) { - SCM ch = scm_apply (f, seed, scm_listofnull); + SCM ch = scm_call_1 (f, seed); if (!SCM_CHARP (ch)) - SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (f)); + SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f)); SCM_CHARSET_SET (base_cs, SCM_CHAR (ch)); - seed = scm_apply (g, seed, scm_listofnull); - tmp = scm_apply (p, seed, scm_listofnull); + seed = scm_call_1 (g, seed); + tmp = scm_call_1 (p, seed); } return base_cs; } @@ -397,7 +397,7 @@ SCM_DEFINE (scm_char_set_for_each, "char-set-for-each", 2, 0, 0, for (k = 0; k < SCM_CHARSET_SIZE; k++) if (SCM_CHARSET_GET (cs, k)) - scm_apply (proc, SCM_MAKE_CHAR (k), scm_listofnull); + scm_call_1 (proc, SCM_MAKE_CHAR (k)); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -419,9 +419,9 @@ SCM_DEFINE (scm_char_set_map, "char-set-map", 2, 0, 0, for (k = 0; k < SCM_CHARSET_SIZE; k++) if (SCM_CHARSET_GET (cs, k)) { - SCM ch = scm_apply (proc, SCM_MAKE_CHAR (k), scm_listofnull); + SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (k)); if (!SCM_CHARP (ch)) - SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (proc)); + SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); SCM_CHARSET_SET (cs, SCM_CHAR (ch)); } return result; @@ -620,7 +620,7 @@ SCM_DEFINE (scm_char_set_filter, "char-set-filter", 2, 1, 0, { if (SCM_CHARSET_GET (cs, k)) { - SCM res = scm_apply (pred, SCM_MAKE_CHAR (k), scm_listofnull); + SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); if (!SCM_FALSEP (res)) p[k / sizeof (long)] |= 1 << (k % sizeof (long)); @@ -649,7 +649,7 @@ SCM_DEFINE (scm_char_set_filter_x, "char-set-filter!", 3, 0, 0, { if (SCM_CHARSET_GET (cs, k)) { - SCM res = scm_apply (pred, SCM_MAKE_CHAR (k), scm_listofnull); + SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); if (!SCM_FALSEP (res)) p[k / sizeof (long)] |= 1 << (k % sizeof (long)); @@ -787,7 +787,7 @@ SCM_DEFINE (scm_char_set_count, "char-set-count", 2, 0, 0, for (k = 0; k < SCM_CHARSET_SIZE; k++) if (SCM_CHARSET_GET (cs, k)) { - SCM res = scm_apply (pred, SCM_MAKE_CHAR (k), scm_listofnull); + SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); if (!SCM_FALSEP (res)) count++; } @@ -869,7 +869,7 @@ SCM_DEFINE (scm_char_set_every, "char-set-every", 2, 0, 0, for (k = 0; k < SCM_CHARSET_SIZE; k++) if (SCM_CHARSET_GET (cs, k)) { - res = scm_apply (pred, SCM_MAKE_CHAR (k), scm_listofnull); + res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); if (SCM_FALSEP (res)) return res; } @@ -892,7 +892,7 @@ SCM_DEFINE (scm_char_set_any, "char-set-any", 2, 0, 0, for (k = 0; k < SCM_CHARSET_SIZE; k++) if (SCM_CHARSET_GET (cs, k)) { - SCM res = scm_apply (pred, SCM_MAKE_CHAR (k), scm_listofnull); + SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); if (!SCM_FALSEP (res)) return res; } @@ -928,6 +928,7 @@ SCM_DEFINE (scm_char_set_adjoin, "char-set-adjoin", 1, 0, 1, } #undef FUNC_NAME + SCM_DEFINE (scm_char_set_delete, "char-set-delete", 1, 0, 1, (SCM cs, SCM rest), "Delete all character arguments from the first argument, which\n" @@ -955,6 +956,7 @@ SCM_DEFINE (scm_char_set_delete, "char-set-delete", 1, 0, 1, } #undef FUNC_NAME + SCM_DEFINE (scm_char_set_adjoin_x, "char-set-adjoin!", 1, 0, 1, (SCM cs, SCM rest), "Add all character arguments to the first argument, which must\n" @@ -981,6 +983,7 @@ SCM_DEFINE (scm_char_set_adjoin_x, "char-set-adjoin!", 1, 0, 1, } #undef FUNC_NAME + SCM_DEFINE (scm_char_set_delete_x, "char-set-delete!", 1, 0, 1, (SCM cs, SCM rest), "Delete all character arguments from the first argument, which\n" @@ -1179,7 +1182,7 @@ SCM_DEFINE (scm_char_set_diff_plus_intersection, "char-set-diff+intersection", 1 q[k] &= ((long *) SCM_SMOB_DATA (cs))[k]; } } - return scm_values (SCM_LIST2 (res1, res2)); + return scm_values (scm_list_2 (res1, res2)); } #undef FUNC_NAME @@ -1315,7 +1318,8 @@ SCM_DEFINE (scm_char_set_xor_x, "char-set-xor!", 1, 0, 1, SCM_DEFINE (scm_char_set_diff_plus_intersection_x, "char-set-diff+intersection!", 1, 0, 1, (SCM cs1, SCM rest), - "Return the difference and the intersection of all argument character sets.") + "Return the difference and the intersection of all argument\n" + "character sets.") #define FUNC_NAME s_scm_char_set_diff_plus_intersection_x { int c = 2; @@ -1342,14 +1346,19 @@ SCM_DEFINE (scm_char_set_diff_plus_intersection_x, "char-set-diff+intersection!" q[k] &= ((long *) SCM_SMOB_DATA (cs))[k]; } } - return scm_values (SCM_LIST2 (cs1, res2)); + return scm_values (scm_list_2 (cs1, res2)); } #undef FUNC_NAME +/* Create the charset smob type. */ void scm_c_init_srfi_14 (void) { + /* Charset smob creation is protected by this variable because this + function can be both called from the SRFI-13 and SRFI-14 + initialization functions. This is because the SRFI-13 procedures + access the charset smob type code. */ static int initialized = 0; if (!initialized) @@ -1362,11 +1371,19 @@ scm_c_init_srfi_14 (void) } } + +/* Initialize the SRFI-14 module. This function will be called by the + loading Scheme module. */ void scm_init_srfi_14 (void) { + /* Do the smob type initialization. */ scm_c_init_srfi_14 (); + + /* Install the charset primitives. */ #ifndef SCM_MAGIC_SNARFER #include "srfi/srfi-14.x" #endif } + +/* End of srfi-14.c. */ diff --git a/srfi/srfi-4.c b/srfi/srfi-4.c index da3025e1d..c90b36675 100644 --- a/srfi/srfi-4.c +++ b/srfi/srfi-4.c @@ -68,6 +68,7 @@ typedef signed long long int_s64; typedef float float_f32; typedef double float_f64; + /* Smob type code for homogeneous numeric vectors. */ int scm_tc16_uvec = 0; @@ -2138,6 +2139,8 @@ SCM_DEFINE (scm_list_to_f64vector, "list->f64vector", 1, 0, 0, #undef FUNC_NAME +/* Create the smob type for homogeneous numeric vectors and install + the primitives. */ void scm_init_srfi_4 (void) { @@ -2148,3 +2151,5 @@ scm_init_srfi_4 (void) #include "srfi/srfi-4.x" #endif } + +/* End of srfi-4.c. */ From b74a7ec8bf01e6038d4437a0ce4306b8e2b59773 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 28 Jun 2001 16:40:38 +0000 Subject: [PATCH 1405/2047] Mention SRFI-4. --- NEWS | 2 ++ 1 file changed, 2 insertions(+) diff --git a/NEWS b/NEWS index 458906a5a..da1ecf357 100644 --- a/NEWS +++ b/NEWS @@ -47,6 +47,8 @@ using a module. (srfi srfi-2) exports and-let*. +(srfi srfi-4) implements homogeneous numeric vector datatypes. + (srfi srfi-6) is a dummy module for now, since guile already provides all of the srfi-6 procedures by default: open-input-string, open-output-string, get-output-string. From 0a7fcdbc23353727fb68cec898a37f8e6961b237 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Thu, 28 Jun 2001 16:55:12 +0000 Subject: [PATCH 1406/2047] Also mention guile-tools. --- README | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/README b/README index 84684b58f..0dfa7ee7f 100644 --- a/README +++ b/README @@ -153,14 +153,16 @@ guile --- a stand-alone interpreter for Guile. With no arguments, this as an interpreter for script files; see the NEWS file for details. guile-config --- a Guile script which provides the information necessary to link your programs against the Guile library. -guile-snarf --- a script to parse declarations in your C code for +guile-snarf --- a script to parse declarations in your C code for Scheme-visible C functions, Scheme objects to be used by C code, etc. +guile-tools --- a wrapper to invoke the executable modules in + subdirectory `scripts' (also installed). Libraries, in ${prefix}/lib. Depending on the platform and options given to configure, you may get shared libraries in addition to or instead of these static libraries: - + libguile.a --- an object library containing the Guile interpreter, You can use Guile in your own programs by linking against this. libqthreads.a --- an object library containing the QuickThreads From 88deca50f3597ce57b1b9ff6415e615563c1ce04 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Thu, 28 Jun 2001 16:56:26 +0000 Subject: [PATCH 1407/2047] *** empty log message *** --- ChangeLog | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ChangeLog b/ChangeLog index b6725e9bf..5cb503fcd 100644 --- a/ChangeLog +++ b/ChangeLog @@ -18,6 +18,8 @@ * HACKING: Update deprecation procedure to refer to TODO. + * README: Also mention guile-tools. + 2001-06-27 Michael Livshin * autogen.sh: don't run flex here. From 04873705f6d4b410e672a87c95f88eb138bc9ca8 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Thu, 28 Jun 2001 17:30:12 +0000 Subject: [PATCH 1408/2047] Mention libguile-srfi-*, oop/*, scripts/* and srfi/*. --- README | 61 ++++++++++++++++++++++++++++++++-------------------------- 1 file changed, 34 insertions(+), 27 deletions(-) diff --git a/README b/README index 0dfa7ee7f..68313686f 100644 --- a/README +++ b/README @@ -1,6 +1,7 @@ -This is not a Guile release; it is a source tree retrieved via +!!! This is not a Guile release; it is a source tree retrieved via anonymous CVS or as a nightly snapshot at some random time after the -Guile 1.4 release. +Guile 1.4 release. If this were a Guile release, you would not see +this message. !!! [fixme: zonk on release] This is a 1.5 development version of Guile, Project GNU's extension language library. Guile is an interpreter for Scheme, packaged as a @@ -148,48 +149,54 @@ configure, /usr/local by default. Building and installing gives you: Executables, in ${prefix}/bin: -guile --- a stand-alone interpreter for Guile. With no arguments, this - is a simple interactive Scheme interpreter. It can also be used - as an interpreter for script files; see the NEWS file for details. -guile-config --- a Guile script which provides the information necessary - to link your programs against the Guile library. -guile-snarf --- a script to parse declarations in your C code for - Scheme-visible C functions, Scheme objects to be used by C code, - etc. -guile-tools --- a wrapper to invoke the executable modules in - subdirectory `scripts' (also installed). + guile --- a stand-alone interpreter for Guile. With no arguments, this + is a simple interactive Scheme interpreter. It can also be used + as an interpreter for script files; see the NEWS file for details. + guile-config --- a Guile script which provides the information necessary + to link your programs against the Guile library. + guile-snarf --- a script to parse declarations in your C code for + Scheme-visible C functions, Scheme objects to be used by C code, + etc. + guile-tools --- a wrapper to invoke the executable modules in + subdirectory `scripts' (also installed). Libraries, in ${prefix}/lib. Depending on the platform and options given to configure, you may get shared libraries in addition to or instead of these static libraries: -libguile.a --- an object library containing the Guile interpreter, - You can use Guile in your own programs by linking against this. -libqthreads.a --- an object library containing the QuickThreads - primitives. If you enabled thread support when you configured - Guile, you will need to link your code against this too. -libguilereadline.a --- an object library containing glue code for the - GNU readline library. See NEWS for instructions on how to enable - readline for your personal use. + libguile.a --- an object library containing the Guile interpreter, + You can use Guile in your own programs by linking against this. + libqthreads.a --- an object library containing the QuickThreads + primitives. If you enabled thread support when you configured + Guile, you will need to link your code against this too. + libguilereadline.a --- an object library containing glue code for the + GNU readline library. See NEWS for instructions on how to enable + readline for your personal use. + libguile-srfi-*.a --- various SRFI support libraries Header files, in ${prefix}/include: -libguile.h, guile/gh.h, libguile/*.h --- for libguile. -guile-readline/readline.h --- for guile-readline. + libguile.h, guile/gh.h, libguile/*.h --- for libguile. + guile-readline/readline.h --- for guile-readline. Support files, in ${prefix}/share/guile/: -ice-9/* --- run-time support for Guile: the module system, - read-eval-print loop, some R4RS code and other infrastructure. + ice-9/* --- run-time support for Guile: the module system, + read-eval-print loop, some R4RS code and other infrastructure. + oop/* --- the Guile Object-Oriented Programming System (GOOPS) + scripts/* --- executable modules, i.e., scheme programs that can be both + called as an executable from the shell, and loaded and used as a + module from scheme code. See scripts/README for more info. + srfi/* --- SRFI support modules. See srfi/README for more info. Automake macros, in ${prefix}/share/aclocal: -guile.m4 + guile.m4 Documentation in Info format, in ${prefix}/info: -data-rep.info --- an essay on how to write C code that works with - Guile Scheme values. + data-rep.info --- an essay on how to write C code that works with + Guile Scheme values. The Guile source tree is laid out as follows: From 8d12303615e7e4648e76d13065709dec7d5ed825 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Thu, 28 Jun 2001 17:31:44 +0000 Subject: [PATCH 1409/2047] *** empty log message *** --- ChangeLog | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index 5cb503fcd..6486b955a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2001-06-28 Thien-Thi Nguyen + + * README: Also mention guile-tools. + + * README: Mention libguile-srfi-*, oop/*, scripts/* and srfi/*. + 2001-06-27 Thien-Thi Nguyen * RELEASE: Move todo items to file TODO. @@ -18,8 +24,6 @@ * HACKING: Update deprecation procedure to refer to TODO. - * README: Also mention guile-tools. - 2001-06-27 Michael Livshin * autogen.sh: don't run flex here. From e235f2a6c77a20de97533ab67e2ad8154f03191f Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 29 Jun 2001 08:10:09 +0000 Subject: [PATCH 1410/2047] News for scm_list_N, replacing SCM_LISTN --- NEWS | 11 +++++++++++ TODO | 7 +++++-- 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index da1ecf357..86625f209 100644 --- a/NEWS +++ b/NEWS @@ -722,6 +722,17 @@ Example: scm_apply_1 (proc, arg1, args); +** New functions: scm_list_1, scm_list_2, scm_list_3, scm_list_4, scm_list_5 + +Create a list of the given number of elements. + +** Renamed function: scm_listify has been replaced by scm_list_n. + +** Deprecated macros: SCM_LIST0, SCM_LIST1, SCM_LIST2, SCM_LIST3, SCM_LIST4, +SCM_LIST5, SCM_LIST6, SCM_LIST7, SCM_LIST8, SCM_LIST9. + +Use functions scm_list_N instead. + ** New function: scm_c_read (SCM port, void *buffer, scm_sizet size) Used by an application to read arbitrary number of bytes from a port. diff --git a/TODO b/TODO index 5c1e1573c..8c657d604 100644 --- a/TODO +++ b/TODO @@ -1,4 +1,4 @@ -[ID: $Id: TODO,v 1.16 2001-06-27 17:15:36 ttn Exp $] +[ID: $Id: TODO,v 1.17 2001-06-29 08:10:00 kei Exp $] These TODO items are grouped by target release version. The first group is the "Eventually" group, which is not associated w/ any particular version. @@ -115,7 +115,10 @@ See also file HACKING. SCM_WNA, SCM_FUNC_NAME, SCM_VALIDATE_NUMBER_COPY, SCM_VALIDATE_NUMBER_DEF_COPY, SCM_SLOPPY_CONSP, SCM_SLOPPY_NCONSP, SCM_SETAND_CDR, SCM_SETOR_CDR, SCM_SETAND_CAR, SCM_SETOR_CAR, - SCM_ARRAY_CONTIGUOUS + SCM_ARRAY_CONTIGUOUS, + SCM_LIST0, SCM_LIST1, SCM_LIST2, SCM_LIST3, SCM_LIST4, SCM_LIST5, + SCM_LIST6, SCM_LIST7, SCM_LIST8, SCM_LIST9 +- remove scm_listify - remove scm_vector_set_length_x - remove function scm_call_catching_errors (replaced by catch functions from throw.[ch]) From 941614c6aae3dfb90833e98ca9d308fc52a61898 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 29 Jun 2001 15:36:47 +0000 Subject: [PATCH 1411/2047] Changes to support tracing other than inside the repl-stack that is set up by the REPL code in boot-9.scm. * debug.scm (trace-entry, trace-exit): Conditionalize tracing on whether the current stack id is in `traced-stack-ids'. (traced-stack-ids, trace-all-stacks?, trace-stack, untrace-stack): New. --- ice-9/ChangeLog | 10 ++++++++++ ice-9/debug.scm | 22 ++++++++++++++++++++-- 2 files changed, 30 insertions(+), 2 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 917fa7b22..c496f8e91 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,13 @@ +2001-06-29 Neil Jerram + + Changes to support tracing other than inside the repl-stack that + is set up by the REPL code in boot-9.scm. + + * debug.scm (trace-entry, trace-exit): Conditionalize tracing on + whether the current stack id is in `traced-stack-ids'. + (traced-stack-ids, trace-all-stacks?, trace-stack, untrace-stack): + New. + 2001-06-27 Marius Vollmer * common-list.scm (member-if): Put in docstring for member-if, it diff --git a/ice-9/debug.scm b/ice-9/debug.scm index d2fe61324..0c25e5c70 100644 --- a/ice-9/debug.scm +++ b/ice-9/debug.scm @@ -109,8 +109,25 @@ (define trace-level 0) (add-hook! abort-hook (lambda () (set! trace-level 0))) +(define traced-stack-ids (list 'repl-stack)) +(define trace-all-stacks? #f) + +(define-public (trace-stack id) + "Add ID to the set of stack ids for which tracing is active. +If `#t' is in this set, tracing is active regardless of stack context. +To remove ID again, use `untrace-stack'. If you add the same ID twice +using `trace-stack', you will need to remove it twice." + (set! traced-stack-ids (cons id traced-stack-ids)) + (set! trace-all-stacks? (memq #t traced-stack-ids))) + +(define-public (untrace-stack id) + "Remove ID from the set of stack ids for which tracing is active." + (set! traced-stack-ids (delq1! id traced-stack-ids)) + (set! trace-all-stacks? (memq #t traced-stack-ids))) + (define (trace-entry key cont tail) - (if (eq? (stack-id cont) 'repl-stack) + (if (or trace-all-stacks? + (memq (stack-id cont) traced-stack-ids)) (let ((cep (current-error-port)) (frame (last-stack-frame cont))) (if (not tail) @@ -125,7 +142,8 @@ ) (define (trace-exit key cont retval) - (if (eq? (stack-id cont) 'repl-stack) + (if (or trace-all-stacks? + (memq (stack-id cont) traced-stack-ids)) (let ((cep (current-error-port))) (set! trace-level (- trace-level 1)) (let indent ((n trace-level)) From c253742527aa6a6eda30bbfd32c70575084b14cb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 29 Jun 2001 21:43:17 +0000 Subject: [PATCH 1412/2047] * misc-modules.texi: New file. (Pretty Printing): New chapter. (Formatted Output): New chapter. * Makefile.am (guile_TEXINFOS): Added misc-modules.texi. * guile.texi (Top): Added inclusion of misc-modules.texi. * scheme-modules.texi (Included Guile Modules): Added (srfi srfi-4) and (ice-9 rw) modules. (Module System Quirks): Removed note that `module-export!' must be called via gh_eval_str, now that we have scm_c_export. * repl-modules.texi (Loading Readline Support, Readline Options): New nodes. --- doc/ChangeLog | 18 + doc/Makefile.am | 2 +- doc/guile.texi | 5 +- doc/misc-modules.texi | 0 doc/repl-modules.texi | 81 ---- doc/scheme-modules.texi | 820 ---------------------------------------- 6 files changed, 23 insertions(+), 903 deletions(-) create mode 100644 doc/misc-modules.texi diff --git a/doc/ChangeLog b/doc/ChangeLog index dd6b70426..2b8933f68 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,21 @@ +2001-06-29 Martin Grabmueller + + * misc-modules.texi: New file. + (Pretty Printing): New chapter. + (Formatted Output): New chapter. + + * Makefile.am (guile_TEXINFOS): Added misc-modules.texi. + + * guile.texi (Top): Added inclusion of misc-modules.texi. + + * scheme-modules.texi (Included Guile Modules): Added (srfi + srfi-4) and (ice-9 rw) modules. + (Module System Quirks): Removed note that `module-export!' must be + called via gh_eval_str, now that we have scm_c_export. + + * repl-modules.texi (Loading Readline Support, Readline Options): + New nodes. + 2001-06-27 Neil Jerram * posix.texi (Network Sockets and Communication): Grammar fix - diff --git a/doc/Makefile.am b/doc/Makefile.am index 4457f855c..c5b7156f3 100644 --- a/doc/Makefile.am +++ b/doc/Makefile.am @@ -35,7 +35,7 @@ guile_TEXINFOS = preface.texi intro.texi scheme-intro.texi \ scheme-reading.texi scheme-indices.texi slib.texi posix.texi \ expect.texi scsh.texi tcltk.texi scripts.texi gh.texi scm.texi \ appendices.texi indices.texi script-getopt.texi data-rep.texi \ - extend.texi repl-modules.texi srfi-modules.texi \ + extend.texi repl-modules.texi srfi-modules.texi misc-modules.texi \ AUTHORS guile_tut_TEXINFOS = guile-tut.texi AUTHORS diff --git a/doc/guile.texi b/doc/guile.texi index d42cc8ca4..b4cfad73a 100644 --- a/doc/guile.texi +++ b/doc/guile.texi @@ -80,7 +80,7 @@ by the Free Software Foundation. @sp 10 @comment The title is printed in a large font. @title Guile Reference Manual -@subtitle $Id: guile.texi,v 1.11 2001-06-20 22:08:19 ossau Exp $ +@subtitle $Id: guile.texi,v 1.12 2001-06-29 21:43:17 mgrabmue Exp $ @subtitle For use with Guile @value{VERSION} @include AUTHORS @@ -171,6 +171,8 @@ Part III: Guile Modules * SRFI Support:: Support for various SRFIs. * Readline Support:: Module for using the readline library. * Value History:: Maintaining a value history in the REPL. +* Pretty Printing:: Nicely formatting Scheme objects for output. +* Formatted Output:: The @code{format} procedure. * Expect:: Controlling interactive programs with Guile. * The Scheme shell (scsh):: The SCSH compatibility module has been made an @@ -253,6 +255,7 @@ Indices @include posix.texi @include srfi-modules.texi @include repl-modules.texi +@include misc-modules.texi @include expect.texi @include scsh.texi @c @include tcltk.texi diff --git a/doc/misc-modules.texi b/doc/misc-modules.texi new file mode 100644 index 000000000..e69de29bb diff --git a/doc/repl-modules.texi b/doc/repl-modules.texi index 2a0361126..e69de29bb 100644 --- a/doc/repl-modules.texi +++ b/doc/repl-modules.texi @@ -1,81 +0,0 @@ -@page -@node Readline Support -@chapter Readline Support - -@c FIXME::martin: Review me! - -@cindex readline -@cindex command line history -Guile comes with an interface module to the readline library. This -makes interactive use much more convenient, because of the command-line -editing features of readline. Using @code{(ice-9 readline)}, you can -navigate through the current input line with the cursor keys, retrieve -older command lines from the input history and even search through the -history entries. - -The module is not loaded by default and so has to be loaded and -activated explicitly. This is done with two simple lines of code: - -@lisp -(use-modules (ice-9 readline)) -(activate-readline) -@end lisp - -The first line will load the necessary code, and the second will -activate readline's features for the REPL. If you plan to use this -module often, you should save these to lines to your @file{.guile} -personal startup file. - -You will notice that the REPL's behaviour changes a bit when you have -loaded the readline module. For examle, when you press Enter before -typing in the closing parentheses of a list, you will see the -@dfn{continuation} prompt, three dots: @code{...} This gives you a nice -visual feedback when trying to match parentheses. To make this even -easier, @dfn{bouncing parentheses} are implemented. That means that -when you type in a closing parentheses, the cursor will jump to the -corresponding opening paren for a short time, making it trivial to make -them match. - -Once the readline module is activated, all lines entered interactively -will be stored in a history and can be recalled later using the -cursor-up and -down keys. Readline also understands the Emacs keys for -navigating through the command line and history. - -When you quit your Guile session by evaluating @code{(quit)} or pressing -Ctrl-D, the history will be saved to the file @file{.guile_history} and -read in when you start Guile for the next time. Thus you can start a -new Guile session and still have the (probably long-winded) definition -expressions available. - - -@page -@node Value History -@chapter Value History - -@c FIXME::martin: Review me! - -@cindex value history -Another module which makes command line usage more convenient is -@code{(ice-9 history)}. This module will change the REPL so that each -value which is evaluated and printed will be remembered under a name -constructed from the dollar character (@code{$}) and the number of the -evaluated expression. - -Consider an example session. - -@example -guile> (use-modules (ice-9 history)) -guile> 1 -$1 = 1 -guile> (+ $1 $1) -$2 = 2 -guile> (* $2 $2) -$3 = 4 -@end example - -After loading the value history module @code{(ice-9 history)}, one -(trivial) expression is evaluated. The result is stored into the -variable @code{$1}. This fact is indicated by the output @code{$1 = }, -which is also caused by @code{(ice-9 history)}. In the next line, this -variable is used two times, to produce the value @code{$2}, which in -turn is used in the calculation for @code{$3}. diff --git a/doc/scheme-modules.texi b/doc/scheme-modules.texi index fd130847b..e69de29bb 100644 --- a/doc/scheme-modules.texi +++ b/doc/scheme-modules.texi @@ -1,820 +0,0 @@ -@page -@node Modules -@chapter Modules -@cindex modules - -When programs become large, naming conflicts can occur when a function -or global variable defined in one file has the same name as a function -or global variable in another file. Even just a @emph{similarity} -between function names can cause hard-to-find bugs, since a programmer -might type the wrong function name. - -The approach used to tackle this problem is called @emph{information -encapsulation}, which consists of packaging functional units into a -given name space that is clearly separated from other name spaces. -@cindex encapsulation -@cindex information encapsulation -@cindex name space - -The language features that allow this are usually called @emph{the -module system} because programs are broken up into modules that are -compiled separately (or loaded separately in an interpreter). - -Older languages, like C, have limited support for name space -manipulation and protection. In C a variable or function is public by -default, and can be made local to a module with the @code{static} -keyword. But you cannot reference public variables and functions from -another module with different names. - -More advanced module systems have become a common feature in recently -designed languages: ML, Python, Perl, and Modula 3 all allow the -@emph{renaming} of objects from a foreign module, so they will not -clutter the global name space. -@cindex name space - private - -@menu -* Scheme and modules:: How modules are handled in standard Scheme. -* The Guile module system:: How Guile does it. -* Dynamic Libraries:: Loading libraries of compiled code at run time. -@end menu - - -@node Scheme and modules -@section Scheme and modules - -Scheme, as defined in R5RS, does @emph{not} have a module system at all. - -Aubrey Jaffer, mostly to support his portable Scheme library SLIB, -implemented a provide/require mechanism for many Scheme implementations. -Library files in SLIB @emph{provide} a feature, and when user programs -@emph{require} that feature, the library file is loaded in. - -For example, the file @file{random.scm} in the SLIB package contains the -line - -@smalllisp -(provide 'random) -@end smalllisp - -so to use its procedures, a user would type - -@smalllisp -(require 'random) -@end smalllisp - -and they would magically become available, @emph{but still have the same -names!} So this method is nice, but not as good as a full-featured -module system. - - -@node The Guile module system -@section The Guile module system - -In 1996 Tom Lord implemented a full-featured module system for Guile which -allows loading Scheme source files into a private name space. This system has -been in available since Guile version 1.4. -@c fixme: Actually, was it available before? 1.4 seems a bit late... - -For Guile version 1.5.0 and later, the system has been improved to have better -integration from C code, more fine-grained user control over interfaces, and -documentation. - -Although it is anticipated that the module system implementation will -change in the future, the Scheme programming interface described in this -manual should be considered stable. The C programming interface is -considered relatively stable, although at the time of this writing, -there is still some flux. -@c fixme: Review: Need better C code interface commentary. - -@menu -* General Information about Modules:: Guile module basics. -* Using Guile Modules:: How to use existing modules. -* Creating Guile Modules:: How to package your code into modules. -* More Module Procedures:: Low-level module code. -* Module System Quirks:: Strange things to be aware of. -* Included Guile Modules:: Which modules come with Guile? -@end menu - -@node General Information about Modules -@subsection General Information about Modules - -A Guile module is a collection of named procedures, variables and -macros, altogether called the @dfn{bindings}, since they bind, or -associate, a symbol (the name) to a Scheme object (procedure, variable, -or macro). Within a module, all bindings are visible. Certain bindings -can be declared @dfn{public}, in which case they are added to the -module's so-called @dfn{export list}; this set of public bindings is -called the module's @dfn{public interface} (@pxref{Creating Guile -Modules}). - -A client module @dfn{uses} a providing module's bindings by either -accessing the providing module's public interface, or by building a -custom interface (and then accessing that). In a custom interface, the -client module can @dfn{select} which bindings to access and can also -algorithmically @dfn{rename} bindings. In contrast, when using the -providing module's public interface, the entire export list is available -without renaming (@pxref{Using Guile Modules}). - -To use a module, it must be found and loaded. All Guile modules have a -unique @dfn{module name}, which is a list of one or more symbols. -Examples are @code{(ice-9 popen)} or @code{(srfi srfi-11)}. When Guile -searches for the code of a module, it constructs the name of the file to -load by concatenating the name elements with slashes between the -elements and appending a number of file name extensions from the list -@code{%load-extensions} (REFFIXME). The resulting file name is then -searched in all directories in the variable @code{%load-path}. For -example, the @code{(ice-9 popen)} module would result in the filename -@code{ice-9/popen.scm} and searched in the installation directory of -Guile and in all other directories in the load path. - -@c FIXME::martin: Not sure about this, maybe someone knows better? -Every module has a so-called syntax transformer associated with it. -This is a procedure which performs all syntax transformation for the -time the module is read in and evaluated. When working with modules, -you can manipulate the current syntax transformer using the -@code{use-syntax} syntactic form or the @code{#:use-syntax} module -definition option (@pxref{Creating Guile Modules}). - -Please note that there are some problems with the current module system -you should keep in mind (@pxref{Module System Quirks}). We hope to -address these eventually. - - -@node Using Guile Modules -@subsection Using Guile Modules - -To use a Guile module is to access either its public interface or a -custom interface (@pxref{General Information about Modules}). Both -types of access are handled by the syntactic form @code{use-modules}, -which accepts one or more interface specifications and, upon evaluation, -arranges for those interfaces to be available to the current module. -This process may include locating and loading code for a given module if -that code has not yet been loaded (REFFIXME %load-path). - -An @dfn{interface specification} has one of two forms. The first -variation is simply to name the module, in which case its public -interface is the one accessed. For example: - -@smalllisp -(use-modules (ice-9 popen)) -@end smalllisp - -Here, the interface specification is @code{(ice-9 popen)}, and the -result is that the current module now has access to @code{open-pipe}, -@code{close-pipe}, @code{open-input-pipe}, and so on (@pxref{Included -Guile Modules}). - -Note in the previous example that if the current module had already -defined @code{open-pipe}, that definition would be overwritten by the -definition in @code{(ice-9 popen)}. For this reason (and others), there -is a second variation of interface specification that not only names a -module to be accessed, but also selects bindings from it and renames -them to suit the current module's needs. For example: - -@smalllisp -(use-modules ((ice-9 popen) - :select ((open-pipe . pipe-open) close-pipe) - :rename (symbol-prefix-proc 'unixy:))) -@end smalllisp - -Here, the interface specification is more complex than before, and the -result is that a custom interface with only two bindings is created and -subsequently accessed by the current module. The mapping of old to new -names is as follows: - -@c Use `smallexample' since `table' is ugly. --ttn -@smallexample -(ice-9 popen) sees: current module sees: -open-pipe unixy:pipe-open -close-pipe unixy:close-pipe -@end smallexample - -This example also shows how to use the convenience procedure -@code{symbol-prefix-proc}. - -@c begin (scm-doc-string "boot-9.scm" "symbol-prefix-proc") -@deffn procedure symbol-prefix-proc prefix-sym -Return a procedure that prefixes its arg (a symbol) with -@var{prefix-sym}. -@c Insert gratuitous C++ slam here. --ttn -@end deffn - -@c begin (scm-doc-string "boot-9.scm" "use-modules") -@deffn syntax use-modules spec @dots{} -Resolve each interface specification @var{spec} into an interface and -arrange for these to be accessible by the current module. The return -value is unspecified. - -@var{spec} can be a list of symbols, in which case it names a module -whose public interface is found and used. - -@var{spec} can also be of the form: - -@smalllisp - (MODULE-NAME [:select SELECTION] [:rename RENAMER]) -@end smalllisp - -in which case a custom interface is newly created and used. -@var{module-name} is a list of symbols, as above; @var{selection} is a -list of selection-specs; and @var{renamer} is a procedure that takes a -symbol and returns its new name. A selection-spec is either a symbol or -a pair of symbols @code{(ORIG . SEEN)}, where @var{orig} is the name in -the used module and @var{seen} is the name in the using module. Note -that @var{seen} is also passed through @var{renamer}. - -The @code{:select} and @code{:rename} clauses are optional. If both are -omitted, the returned interface has no bindings. If the @code{:select} -clause is omitted, @var{renamer} operates on the used module's public -interface. - -Signal error if module name is not resolvable. -@end deffn - - -@c FIXME::martin: Is this correct, and is there more to say? -@c FIXME::martin: Define term and concept `system transformer' somewhere. - -@deffn syntax use-syntax module-name -Load the module @code{module-name} and use its system -transformer as the system transformer for the currently defined module, -as well as installing it as the current system transformer. -@end deffn - - -@node Creating Guile Modules -@subsection Creating Guile Modules - -When you want to create your own modules, you have to take the following -steps: - -@itemize @bullet -@item -Create a Scheme source file and add all variables and procedures you wish -to export, or which are required by the exported procedures. - -@item -Add a @code{define-module} form at the beginning. - -@item -Export all bindings which should be in the public interface, either -by using @code{define-public} or @code{export} (both documented below). -@end itemize - -@c begin (scm-doc-string "boot-9.scm" "define-module") -@deffn syntax define-module module-name [options @dots{}] -@var{module-name} is of the form @code{(hierarchy file)}. One -example of this is - -@smalllisp -(define-module (ice-9 popen)) -@end smalllisp - -@code{define-module} makes this module available to Guile programs under -the given @var{module-name}. - -The @var{options} are keyword/value pairs which specify more about the -defined module. The recognized options and their meaning is shown in -the following table. - -@c fixme: Should we use "#:" or ":"? - -@table @code -@item #:use-module @var{interface-specification} -Equivalent to a @code{(use-modules @var{interface-specification})} -(@pxref{Using Guile Modules}). - -@item #:use-syntax @var{module} -Use @var{module} when loading the currently defined module, and install -it as the syntax transformer. - -@item #:autoload @var{module} @var{symbol} -Load @var{module} whenever @var{symbol} is accessed. - -@item #:export @var{list} -Export all identifiers in @var{list}, which must be a list of symbols. -This is equivalent to @code{(export @var{list})} in the module body. - -@item #:no-backtrace -Tell Guile not to record information for procedure backtraces when -executing the procedures in this module. - -@item #:pure -Create a @dfn{pure} module, that is a module which does not contain any -of the standard procedure bindings except for the syntax forms. This is -useful if you want to create @dfn{safe} modules, that is modules which -do not know anything about dangerous procedures. -@end table - -@end deffn -@c end - -@deffn syntax export variable @dots{} -Add all @var{variable}s (which must be symbols) to the list of exported -bindings of the current module. -@end deffn - -@c begin (scm-doc-string "boot-9.scm" "define-public") -@deffn syntax define-public @dots{} -Equivalent to @code{(begin (define foo ...) (export foo))}. -@end deffn -@c end - - -@node More Module Procedures -@subsection More Module Procedures - -@c FIXME::martin: Review me! - -@c FIXME::martin: Should this procedure be documented and supported -@c at all? - -The procedures in this section are useful if you want to dig into the -innards of Guile's module system. If you don't know precisely what you -do, you should probably avoid using any of them. - -@deffn primitive standard-eval-closure module -Return an eval closure for the module @var{module}. -@end deffn - - -@node Module System Quirks -@subsection Module System Quirks - -Although the programming interfaces are relatively stable, the Guile -module system itself is still evolving. Here are some situations where -usage surpasses design. - -@itemize @bullet - -@item -When using a module which exports a macro definition, the other module -must export all bindings the macro expansion uses, too, because the -expanded code would otherwise not be able to see these definitions and -issue a ``variable unbound'' error, or worse, would use another binding -which might be present in the scope of the expansion. - -@item -From C, you need to construct a @code{module-export!} call using -@code{gh_eval_str}. This is cumbersome. - -@item -When two or more used modules export bindings with the same names, the -last accessed module wins, and the exported binding of that last module -will silently be used. This might lead to hard-to-find errors because -wrong procedures or variables are used. To avoid this kind of -@dfn{name-clash} situation, use a custom interface specification -(@pxref{Using Guile Modules}). (We include this entry for the possible -benefit of users of Guile versions previous to 1.5.0, when custom -interfaces were added to the module system.) - -@item -[Add other quirks here.] - -@end itemize - - -@node Included Guile Modules -@subsection Included Guile Modules - -@c FIXME::martin: Review me! - -Some modules are included in the Guile distribution; here are references -to the entries in this manual which describe them in more detail: - -@table @strong -@item boot-9 -boot-9 is Guile's initialization module, and it is always loaded when -Guile starts up. - -@item (ice-9 debug) -Mikael Djurfeldt's source-level debugging support for Guile -(@pxref{Debugger User Interface}). - -@item (ice-9 threads) -Guile's support for multi threaded execution (@pxref{Scheduling}). - -@item (ice-9 rdelim) -Line- and character-delimited input (@pxref{Line/Delimited}). - -@item (ice-9 documentation) -Online documentation (REFFIXME). - -@item (srfi srfi-1) -A library providing a lot of useful list and pair processing -procedures (@pxref{SRFI-1}). - -@item (srfi srfi-2) -Support for @code{and-let*} (@pxref{SRFI-2}). - -@item (srfi srfi-6) -Support for some additional string port procedures (@pxref{SRFI-6}). - -@item (srfi srfi-8) -Multiple-value handling with @code{receive} (@pxref{SRFI-8}). - -@item (srfi srfi-9) -Record definition with @code{define-record-type} (@pxref{SRFI-9}). - -@item (srfi srfi-10) -Read hash extension @code{#,()} (@pxref{SRFI-10}). - -@item (srfi srfi-11) -Multiple-value handling with @code{let-values} and @code{let-values*} -(@pxref{SRFI-11}). - -@item (srfi srfi-13) -String library (@pxref{SRFI-13}). - -@item (srfi srfi-14) -Character-set library (@pxref{SRFI-14}). - -@item (srfi srfi-17) -Getter-with-setter support (@pxref{SRFI-17}). - -@item (ice-9 slib) -This module contains hooks for using Aubrey Jaffer's portable Scheme -library SLIB from Guile (@pxref{SLIB}). - -@c FIXME::martin: This module is not in the distribution. Remove it -@c from here? -@item (ice-9 jacal) -This module contains hooks for using Aubrey Jaffer's symbolic math -packge Jacal from Guile (@pxref{JACAL}). -@end table - - -@node Dynamic Libraries -@section Dynamic Libraries - -Most modern Unices have something called @dfn{shared libraries}. This -ordinarily means that they have the capability to share the executable -image of a library between several running programs to save memory and -disk space. But generally, shared libraries give a lot of additional -flexibility compared to the traditional static libraries. In fact, -calling them `dynamic' libraries is as correct as calling them `shared'. - -Shared libraries really give you a lot of flexibility in addition to the -memory and disk space savings. When you link a program against a shared -library, that library is not closely incorporated into the final -executable. Instead, the executable of your program only contains -enough information to find the needed shared libraries when the program -is actually run. Only then, when the program is starting, is the final -step of the linking process performed. This means that you need not -recompile all programs when you install a new, only slightly modified -version of a shared library. The programs will pick up the changes -automatically the next time they are run. - -Now, when all the necessary machinery is there to perform part of the -linking at run-time, why not take the next step and allow the programmer -to explicitly take advantage of it from within his program? Of course, -many operating systems that support shared libraries do just that, and -chances are that Guile will allow you to access this feature from within -your Scheme programs. As you might have guessed already, this feature -is called @dfn{dynamic linking}@footnote{Some people also refer to the -final linking stage at program startup as `dynamic linking', so if you -want to make yourself perfectly clear, it is probably best to use the -more technical term @dfn{dlopening}, as suggested by Gordon Matzigkeit -in his libtool documentation.} - -As with many aspects of Guile, there is a low-level way to access the -dynamic linking apparatus, and a more high-level interface that -integrates dynamically linked libraries into the module system. - -@menu -* Low level dynamic linking:: -* Compiled Code Modules:: -* Dynamic Linking and Compiled Code Modules:: -@end menu - -@node Low level dynamic linking -@subsection Low level dynamic linking - -When using the low level procedures to do your dynamic linking, you have -complete control over which library is loaded when and what get's done -with it. - -@deffn primitive dynamic-link library -Find the shared library denoted by @var{library} (a string) and link it -into the running Guile application. When everything works out, return a -Scheme object suitable for representing the linked object file. -Otherwise an error is thrown. How object files are searched is system -dependent. - -Normally, @var{library} is just the name of some shared library file -that will be searched for in the places where shared libraries usually -reside, such as in @file{/usr/lib} and @file{/usr/local/lib}. -@end deffn - -@deffn primitive dynamic-object? val -Determine whether @var{val} represents a dynamically linked object file. -@end deffn - -@deffn primitive dynamic-unlink dynobj -Unlink the indicated object file from the application. The argument -@var{dynobj} should be one of the values returned by -@code{dynamic-link}. When @code{dynamic-unlink} has been called on -@var{dynobj}, it is no longer usable as an argument to the functions -below and you will get type mismatch errors when you try to. -@end deffn - -@deffn primitive dynamic-func function dynobj -Search the C function indicated by @var{function} (a string or symbol) -in @var{dynobj} and return some Scheme object that can later be used -with @code{dynamic-call} to actually call this function. Right now, -these Scheme objects are formed by casting the address of the function -to @code{long} and converting this number to its Scheme representation. - -Regardless whether your C compiler prepends an underscore @samp{_} to -the global names in a program, you should @strong{not} include this -underscore in @var{function}. Guile knows whether the underscore is -needed or not and will add it when necessary. -@end deffn - -@deffn primitive dynamic-call function dynobj -Call the C function indicated by @var{function} and @var{dynobj}. The -function is passed no arguments and its return value is ignored. When -@var{function} is something returned by @code{dynamic-func}, call that -function and ignore @var{dynobj}. When @var{function} is a string (or -symbol, etc.), look it up in @var{dynobj}; this is equivalent to - -@smallexample -(dynamic-call (dynamic-func @var{function} @var{dynobj} #f)) -@end smallexample - -Interrupts are deferred while the C function is executing (with -@code{SCM_DEFER_INTS}/@code{SCM_ALLOW_INTS}). -@end deffn - -@deffn primitive dynamic-args-call function dynobj args -Call the C function indicated by @var{function} and @var{dynobj}, just -like @code{dynamic-call}, but pass it some arguments and return its -return value. The C function is expected to take two arguments and -return an @code{int}, just like @code{main}: - -@smallexample -int c_func (int argc, char **argv); -@end smallexample - -The parameter @var{args} must be a list of strings and is converted into -an array of @code{char *}. The array is passed in @var{argv} and its -size in @var{argc}. The return value is converted to a Scheme number -and returned from the call to @code{dynamic-args-call}. -@end deffn - -When dynamic linking is disabled or not supported on your system, -the above functions throw errors, but they are still available. - -Here is a small example that works on GNU/Linux: - -@smallexample -(define libc-obj (dynamic-link "libc.so")) -libc-obj -@result{} # -(dynamic-args-call 'rand libc-obj '()) -@result{} 269167349 -(dynamic-unlink libc-obj) -libc-obj -@result{} # -@end smallexample - -As you can see, after calling @code{dynamic-unlink} on a dynamically -linked library, it is marked as @samp{(unlinked)} and you are no longer -able to use it with @code{dynamic-call}, etc. Whether the library is -really removed from you program is system-dependent and will generally -not happen when some other parts of your program still use it. In the -example above, @code{libc} is almost certainly not removed from your -program because it is badly needed by almost everything. - -The functions to call a function from a dynamically linked library, -@code{dynamic-call} and @code{dynamic-args-call}, are not very powerful. -They are mostly intended to be used for calling specially written -initialization functions that will then add new primitives to Guile. -For example, we do not expect that you will dynamically link -@file{libX11} with @code{dynamic-link} and then construct a beautiful -graphical user interface just by using @code{dynamic-call} and -@code{dynamic-args-call}. Instead, the usual way would be to write a -special Guile<->X11 glue library that has intimate knowledge about both -Guile and X11 and does whatever is necessary to make them inter-operate -smoothly. This glue library could then be dynamically linked into a -vanilla Guile interpreter and activated by calling its initialization -function. That function would add all the new types and primitives to -the Guile interpreter that it has to offer. - -From this setup the next logical step is to integrate these glue -libraries into the module system of Guile so that you can load new -primitives into a running system just as you can load new Scheme code. - -There is, however, another possibility to get a more thorough access to -the functions contained in a dynamically linked library. Anthony Green -has written @file{libffi}, a library that implements a @dfn{foreign -function interface} for a number of different platforms. With it, you -can extend the Spartan functionality of @code{dynamic-call} and -@code{dynamic-args-call} considerably. There is glue code available in -the Guile contrib archive to make @file{libffi} accessible from Guile. - -@node Compiled Code Modules -@subsection Putting Compiled Code into Modules - -The new primitives that you add to Guile with @code{gh_new_procedure} or -with any of the other mechanisms are normally placed into the same -module as all the other builtin procedures (like @code{display}). -However, it is also possible to put new primitives into their own -module. - -The mechanism for doing so is not very well thought out and is likely to -change when the module system of Guile itself is revised, but it is -simple and useful enough to document it as it stands. - -What @code{gh_new_procedure} and the functions used by the snarfer -really do is to add the new primitives to whatever module is the -@emph{current module} when they are called. This is analogous to the -way Scheme code is put into modules: the @code{define-module} expression -at the top of a Scheme source file creates a new module and makes it the -current module while the rest of the file is evaluated. The -@code{define} expressions in that file then add their new definitions to -this current module. - -Therefore, all we need to do is to make sure that the right module is -current when calling @code{gh_new_procedure} for our new primitives. -Unfortunately, there is not yet an easy way to access the module system -from C, so we are better off with a more indirect approach. Instead of -adding our primitives at initialization time we merely register with -Guile that we are ready to provide the contents of a certain module, -should it ever be needed. - -@deftypefun void scm_register_module_xxx (char *@var{name}, void (*@var{initfunc})(void)) -Register with Guile that @var{initfunc} will provide the contents of the -module @var{name}. - -The function @var{initfunc} should perform the usual initialization -actions for your new primitives, like calling @code{gh_new_procedure} or -including the file produced by the snarfer. When @var{initfunc} is -called, the current module is a newly created module with a name as -indicated by @var{name}. Each definition that is added to it will be -automatically exported. - -The string @var{name} indicates the hierachical name of the new module. -It should consist of the individual components of the module name -separated by single spaces. That is, the Scheme module name @code{(foo -bar)}, which is a list, should be written as @code{"foo bar"} for the -@var{name} parameter. - -You can call @code{scm_register_module_xxx} at any time, even before -Guile has been initialized. This might be useful when you want to put -the call to it in some initialization code that is magically called -before main, like constructors for global C++ objects. - -An example for @code{scm_register_module_xxx} appears in the next section. -@end deftypefun - -Now, instead of calling the initialization function at program startup, -you should simply call @code{scm_register_module_xxx} and pass it the -initialization function. When the named module is later requested by -Scheme code with @code{use-modules} for example, Guile will notice that -it knows how to create this module and will call the initialization -function at the right time in the right context. - -@node Dynamic Linking and Compiled Code Modules -@subsection Dynamic Linking and Compiled Code Modules - -The most interesting application of dynamically linked libraries is -probably to use them for providing @emph{compiled code modules} to -Scheme programs. As much fun as programming in Scheme is, every now and -then comes the need to write some low-level C stuff to make Scheme even -more fun. - -Not only can you put these new primitives into their own module (see the -previous section), you can even put them into a shared library that is -only then linked to your running Guile image when it is actually -needed. - -An example will hopefully make everything clear. Suppose we want to -make the Bessel functions of the C library available to Scheme in the -module @samp{(math bessel)}. First we need to write the appropriate -glue code to convert the arguments and return values of the functions -from Scheme to C and back. Additionally, we need a function that will -add them to the set of Guile primitives. Because this is just an -example, we will only implement this for the @code{j0} function, tho. - -@smallexample -#include -#include - -SCM -j0_wrapper (SCM x) -@{ - return gh_double2scm (j0 (gh_scm2double (x))); -@} - -void -init_math_bessel () -@{ - gh_new_procedure1_0 ("j0", j0_wrapper); -@} -@end smallexample - -We can already try to bring this into action by manually calling the low -level functions for performing dynamic linking. The C source file needs -to be compiled into a shared library. Here is how to do it on -GNU/Linux, please refer to the @code{libtool} documentation for how to -create dynamically linkable libraries portably. - -@smallexample -gcc -shared -o libbessel.so -fPIC bessel.c -@end smallexample - -Now fire up Guile: - -@smalllisp -(define bessel-lib (dynamic-link "./libbessel.so")) -(dynamic-call "init_math_bessel" bessel-lib) -(j0 2) -@result{} 0.223890779141236 -@end smalllisp - -The filename @file{./libbessel.so} should be pointing to the shared -library produced with the @code{gcc} command above, of course. The -second line of the Guile interaction will call the -@code{init_math_bessel} function which in turn will register the C -function @code{j0_wrapper} with the Guile interpreter under the name -@code{j0}. This function becomes immediately available and we can call -it from Scheme. - -Fun, isn't it? But we are only half way there. This is what -@code{apropos} has to say about @code{j0}: - -@smallexample -(apropos 'j0) -@print{} the-root-module: j0 # -@end smallexample - -As you can see, @code{j0} is contained in the root module, where all -the other Guile primitives like @code{display}, etc live. In general, -a primitive is put into whatever module is the @dfn{current module} at -the time @code{gh_new_procedure} is called. To put @code{j0} into its -own module named @samp{(math bessel)}, we need to make a call to -@code{scm_register_module_xxx}. Additionally, to have Guile perform -the dynamic linking automatically, we need to put @file{libbessel.so} -into a place where Guile can find it. The call to -@code{scm_register_module_xxx} should be contained in a specially -named @dfn{module init function}. Guile knows about this special name -and will call that function automatically after having linked in the -shared library. For our example, we add the following code to -@file{bessel.c}: - -@smallexample -void scm_init_math_bessel_module () -@{ - scm_register_module_xxx ("math bessel", init_math_bessel); -@} -@end smallexample - -The general pattern for the name of a module init function is: -@samp{scm_init_}, followed by the name of the module where the -individual hierarchical components are concatenated with underscores, -followed by @samp{_module}. It should call -@code{scm_register_module_xxx} with the correct module name and the -appropriate initialization function. When that initialization function -will be called, a newly created module with the right name will be the -@emph{current module} so that all definitions that the initialization -functions makes will end up in the correct module. - -After @file{libbessel.so} has been rebuild, we need to place the shared -library into the right place. When Guile tries to autoload the -@samp{(math bessel)} module, it looks not only for a file called -@file{math/bessel.scm} in its @code{%load-path}, but also for -@file{math/libbessel.so}. So all we need to do is to create a directory -called @file{math} somewhere in Guile's @code{%load-path} and place -@file{libbessel.so} there. Normally, the current directory @file{.} is -in the @code{%load-path}, so we just use that for this example. - -@smallexample -% mkdir maths -% cd maths -% ln -s ../libbessel.so . -% cd .. -% guile -guile> (use-modules (math bessel)) -guile> (j0 2) -0.223890779141236 -guile> (apropos 'j0) -@print{} bessel: j0 # -@end smallexample - -That's it! - -Note that we used a symlink to make @file{libbessel.so} appear in the -right spot. This is probably not a bad idea in general. The -directories that the @file{%load-path} normally contains are supposed to -contain only architecture independent files. They are not really the -right place for a shared library. You might want to install the -libraries somewhere below @samp{exec_prefix} and then symlink to them -from the architecture independent directory. This will at least work on -heterogenous systems where the architecture dependent stuff resides in -the same place on all machines (which seems like a good idea to me -anyway). - - -@c Local Variables: -@c TeX-master: "guile.texi" -@c End: From 296d257ebfb57159d4aeb27c4c39e9aee80c3b2e Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 29 Jun 2001 23:12:34 +0000 Subject: [PATCH 1413/2047] Updates to the transition guide. --- doc/gh.texi | 1149 --------------------------------------------------- 1 file changed, 1149 deletions(-) diff --git a/doc/gh.texi b/doc/gh.texi index 552e2a69d..e69de29bb 100644 --- a/doc/gh.texi +++ b/doc/gh.texi @@ -1,1149 +0,0 @@ -@page -@node GH -@chapter GH: A Portable C to Scheme Interface -@cindex libguile - gh -@cindex gh -@cindex gh - reference manual - -This chapter shows how to use the GH interface to call Guile from your -application's C code, and to add new Scheme level procedures to Guile -whose behaviour is specified by application specific code written in C. - -Note, however, that the GH interface is now deprecated, and developers -are encouraged to switch to using the scm interface instead. Therefore, -for each GH feature, this chapter should also document how to achieve -the same result using the scm interface. - -@menu -* GH deprecation:: Why the GH interface is now deprecated. -* gh preliminaries:: -* Data types and constants defined by gh:: -* Starting and controlling the interpreter:: -* Error messages:: -* Executing Scheme code:: -* Defining new Scheme procedures in C:: -* Converting data between C and Scheme:: -* Type predicates:: -* Equality predicates:: -* Memory allocation and garbage collection:: -* Calling Scheme procedures from C:: -* Mixing gh and scm APIs:: -* scm transition summary:: -@end menu - - -@node GH deprecation -@section Why the GH Interface is Now Deprecated - -Historically, the GH interface was the product of a practical problem -and a neat idea. The practical problem was that the interface of the -@code{scm_} functions with which Guile itself was written (inherited -from Aubrey Jaffer's SCM) was so closely tied to the (rather arcane) -details of the internal data representation that it was extremely -difficult to write a Guile extension using these functions. The neat -idea was to define a high level language extension interface in such a -way that other extension language projects, not just Guile, would be -able to provide an implementation of that interface; then applications -using this interface could be compiled with whichever of the various -available implementations they chose. So the GH interface was created, -and advertised both as the recommended interface for application -developers wishing to use Guile, and as a portable high level interface -that could theoretically be implemented by other extension language -projects. - -Time passed, and various things changed. Crucially, an enormous number -of improvements were made to the @code{scm_} interface that Guile itself -uses in its implementation, with the result that it is now both easy and -comfortable to write a Guile extension with this interface. At the same -time, the contents of the GH interface were somewhat neglected by the -core Guile developers, such that some key operations --- such as smob -creation and management --- are simply not possible using GH alone. -Finally, the idea of multiple implementations of the GH interface did -not really crystallize (apart, I believe, from a short lived -implementation by the MzScheme project). - -For all these reasons, the Guile developers have decided to deprecate -the GH interface --- which means that support for GH will be completely -removed after the next few releases --- and to focus only on the -@code{scm_} interface, with additions to ensure that it is as easy to -use in all respects as GH was. - -It remains an open question whether a deep kind of interface portability -would be useful for extension language-based applications, and it may -still be an interesting project to attempt to define a corresponding -GH-like interface, but the Guile developers no longer plan to try to do -this as part of the core Guile project. - - -@node gh preliminaries -@section gh preliminaries - -To use gh, you must have the following toward the beginning of your C -source: -@smallexample -#include -@end smallexample -@cindex gh - headers - -When you link, you will have to add at least @code{-lguile} to the list -of libraries. If you are using more of Guile than the basic Scheme -interpreter, you will have to add more libraries. -@cindex gh - linking - - -@node Data types and constants defined by gh -@section Data types and constants defined by gh -@cindex libguile - data types - -The following C constants and data types are defined in gh: - -@deftp {Data type} SCM -This is a C data type used to store all Scheme data, no matter what the -Scheme type. Values are converted between C data types and the SCM type -with utility functions described below (@pxref{Converting data between C -and Scheme}). [FIXME: put in references to Jim's essay and so forth.] -@end deftp -@cindex SCM data type - -@defvr Constant SCM_BOOL_T -@defvrx Constant SCM_BOOL_F -The @emph{Scheme} values returned by many boolean procedures in -libguile. - -This can cause confusion because they are different from 0 and 1. In -testing a boolean function in libguile programming, you must always make -sure that you check the spec: @code{gh_} and @code{scm_} functions will -usually return @code{SCM_BOOL_T} and @code{SCM_BOOL_F}, but other C -functions usually can be tested against 0 and 1, so programmers' fingers -tend to just type @code{if (boolean_function()) @{ ... @}} -@end defvr - -@defvr Constant SCM_UNSPECIFIED -This is a SCM value that is not the same as any legal Scheme value. It -is the value that a Scheme function returns when its specification says -that its return value is unspecified. -@end defvr - -@defvr Constant SCM_UNDEFINED -This is another SCM value that is not the same as any legal Scheme -value. It is the value used to mark variables that do not yet have a -value, and it is also used in C to terminate functions with variable -numbers of arguments, such as @code{gh_list()}. -@end defvr - - -@node Starting and controlling the interpreter -@section Starting and controlling the interpreter -@cindex libguile - start interpreter - -In almost every case, your first @code{gh_} call will be: - -@deftypefun void gh_enter (int @var{argc}, char *@var{argv}[], void (*@var{main_prog})()) -Starts up a Scheme interpreter with all the builtin Scheme primitives. -@code{gh_enter()} never exits, and the user's code should all be in the -@code{@var{main_prog}()} function. @code{argc} and @code{argv} will be -passed to @var{main_prog}. - -@deftypefun void main_prog (int @var{argc}, char *@var{argv}[]) -This is the user's main program. It will be invoked by -@code{gh_enter()} after Guile has been started up. -@end deftypefun - -Note that you can use @code{gh_repl} inside @code{gh_enter} (in other -words, inside the code for @code{main-prog}) if you want the program to -be controled by a Scheme read-eval-print loop. -@end deftypefun - -@cindex read eval print loop -- from the gh_ interface -@cindex REPL -- from the gh_ interface -A convenience routine which enters the Guile interpreter with the -standard Guile read-eval-print loop (@dfn{REPL}) is: - -@deftypefun void gh_repl (int @var{argc}, char *@var{argv}[]) -Enters the Scheme interpreter giving control to the Scheme REPL. -Arguments are processed as if the Guile program @file{guile} were being -invoked. - -Note that @code{gh_repl} should be used @emph{inside} @code{gh_enter}, -since any Guile interpreter calls are meaningless unless they happen in -the context of the interpreter. - -Also note that when you use @code{gh_repl}, your program will be -controlled by Guile's REPL (which is written in Scheme and has many -useful features). Use straight C code inside @code{gh_enter} if you -want to maintain execution control in your C program. -@end deftypefun - -You will typically use @code{gh_enter} and @code{gh_repl} when you -want a Guile interpreter enhanced by your own libraries, but otherwise -quite normal. For example, to build a Guile--derived program that -includes some random number routines @dfn{GSL} (GNU Scientific Library), -you would write a C program that looks like this: - -@smallexample -#include -#include - -/* random number suite */ -SCM gw_ran_seed(SCM s) -@{ - gsl_ran_seed(gh_scm2int(s)); - return SCM_UNSPECIFIED; -@} - -SCM gw_ran_random() -@{ - SCM x; - - x = gh_ulong2scm(gsl_ran_random()); - return x; -@} - -SCM gw_ran_uniform() -@{ - SCM x; - - x = gh_double2scm(gsl_ran_uniform()); - return x; -@} -SCM gw_ran_max() -@{ - return gh_double2scm(gsl_ran_max()); -@} - -void -init_gsl() -@{ - /* random number suite */ - gh_new_procedure("gsl-ran-seed", gw_ran_seed, 1, 0, 0); - gh_new_procedure("gsl-ran-random", gw_ran_random, 0, 0, 0); - gh_new_procedure("gsl-ran-uniform", gw_ran_uniform, 0, 0, 0); - gh_new_procedure("gsl-ran-max", gw_ran_max, 0, 0, 0); -@} - -void -main_prog (int argc, char *argv[]) -@{ - init_gsl(); - - gh_repl(argc, argv); -@} - -int -main (int argc, char *argv[]) -@{ - gh_enter (argc, argv, main_prog); -@} -@end smallexample - -Then, supposing the C program is in @file{guile-gsl.c}, you could -compile it with @kbd{gcc -o guile-gsl guile-gsl.c -lguile -lgsl}. - -The resulting program @file{guile-gsl} would have new primitive -procedures @code{gsl-ran-random}, @code{gsl-ran-gaussian} and so forth. - - -@node Error messages -@section Error messages -@cindex libguile - error messages -@cindex error messages in libguile - -[FIXME: need to fill this based on Jim's new mechanism] - - -@node Executing Scheme code -@section Executing Scheme code -@cindex libguile - executing Scheme -@cindex executing Scheme - -Once you have an interpreter running, you can ask it to evaluate Scheme -code. There are two calls that implement this: - -@deftypefun SCM gh_eval_str (char *@var{scheme_code}) -This asks the interpreter to evaluate a single string of Scheme code, -and returns the result of the last expression evaluated. - -Note that the line of code in @var{scheme_code} must be a well formed -Scheme expression. If you have many lines of code before you balance -parentheses, you must either concatenate them into one string, or use -@code{gh_eval_file()}. -@end deftypefun - -@deftypefun SCM gh_eval_file (char *@var{fname}) -@deftypefunx SCM gh_load (char *@var{fname}) -@code{gh_eval_file} is completely analogous to @code{gh_eval_str()}, -except that a whole file is evaluated instead of a string. -@code{gh_eval_file} returns @code{SCM_UNSPECIFIED}. - -@code{gh_load} is identical to @code{gh_eval_file} (it's a macro that -calls @code{gh_eval_file} on its argument). It is provided to start -making the @code{gh_} interface match the R5RS Scheme procedures -closely. -@end deftypefun - - -@node Defining new Scheme procedures in C -@section Defining new Scheme procedures in C -@cindex libguile - new procedures -@cindex new procedures -@cindex procedures, new -@cindex new primitives -@cindex primitives, new - -The real interface between C and Scheme comes when you can write new -Scheme procedures in C. This is done through the routine - - -@deftypefn {Libguile high} SCM gh_new_procedure (char *@var{proc_name}, SCM (*@var{fn})(), int @var{n_required_args}, int @var{n_optional_args}, int @var{restp}) -@code{gh_new_procedure} defines a new Scheme procedure. Its Scheme name -will be @var{proc_name}, it will be implemented by the C function -(*@var{fn})(), it will take at least @var{n_required_args} arguments, -and at most @var{n_optional_args} extra arguments. - -When the @var{restp} parameter is 1, the procedure takes a final -argument: a list of remaining parameters. - -@code{gh_new_procedure} returns an SCM value representing the procedure. - -The C function @var{fn} should have the form -@deftypefn {Libguile high} SCM fn (SCM @var{req1}, SCM @var{req2}, ..., SCM @var{opt1}, SCM @var{opt2}, ..., SCM @var{rest_args}) -The arguments are all passed as SCM values, so the user will have to use -the conversion functions to convert to standard C types. - -Examples of C functions used as new Scheme primitives can be found in -the sample programs @code{learn0} and @code{learn1}. -@end deftypefn - -@end deftypefn - -@strong{Rationale:} this is the correct way to define new Scheme -procedures in C. The ugly mess of arguments is required because of how -C handles procedures with variable numbers of arguments. - -@strong{Note:} what about documentation strings? - -@cartouche -There are several important considerations to be made when writing the C -routine @code{(*fn)()}. - -First of all the C routine has to return type @code{SCM}. - -Second, all arguments passed to the C funcion will be of type -@code{SCM}. - -Third: the C routine is now subject to Scheme flow control, which means -that it could be interrupted at any point, and then reentered. This -means that you have to be very careful with operations such as -allocating memory, modifying static data @dots{} - -Fourth: to get around the latter issue, you can use -@code{GH_DEFER_INTS} and @code{GH_ALLOW_INTS}. -@end cartouche - -@defmac GH_DEFER_INTS -@defmacx GH_ALLOW_INTS -These macros disable and reenable Scheme's flow control. They -@end defmac - - -@c [??? have to do this right; maybe using subsections, or maybe creating a -@c section called Flow control issues...] - -@c [??? Go into exhaustive detail with examples of the various possible -@c combinations of required and optional args...] - - -@node Converting data between C and Scheme -@section Converting data between C and Scheme -@cindex libguile - converting data -@cindex data conversion -@cindex converting data - -Guile provides mechanisms to convert data between C and Scheme. This -allows new builtin procedures to understand their arguments (which are -of type @code{SCM}) and return values of type @code{SCM}. - - -@menu -* C to Scheme:: -* Scheme to C:: -@end menu - -@node C to Scheme -@subsection C to Scheme - -@deftypefun SCM gh_bool2scm (int @var{x}) -Returns @code{#f} if @var{x} is zero, @code{#t} otherwise. -@end deftypefun - -@deftypefun SCM gh_ulong2scm (unsigned long @var{x}) -@deftypefunx SCM gh_long2scm (long @var{x}) -@deftypefunx SCM gh_double2scm (double @var{x}) -@deftypefunx SCM gh_char2scm (char @var{x}) -Returns a Scheme object with the value of the C quantity @var{x}. -@end deftypefun - -@deftypefun SCM gh_str2scm (char *@var{s}, int @var{len}) -Returns a new Scheme string with the (not necessarily null-terminated) C -array @var{s} data. -@end deftypefun - -@deftypefun SCM gh_str02scm (char *@var{s}) -Returns a new Scheme string with the null-terminated C string @var{s} -data. -@end deftypefun - -@deftypefun SCM gh_set_substr (char *@var{src}, SCM @var{dst}, int @var{start}, int @var{len}) -Copy @var{len} characters at @var{src} into the @emph{existing} Scheme -string @var{dst}, starting at @var{start}. @var{start} is an index into -@var{dst}; zero means the beginning of the string. - -If @var{start} + @var{len} is off the end of @var{dst}, signal an -out-of-range error. -@end deftypefun - -@deftypefun SCM gh_symbol2scm (char *@var{name}) -Given a null-terminated string @var{name}, return the symbol with that -name. -@end deftypefun - -@deftypefun SCM gh_ints2scm (int *@var{dptr}, int @var{n}) -@deftypefunx SCM gh_doubles2scm (double *@var{dptr}, int @var{n}) -Make a scheme vector containing the @var{n} ints or doubles at memory -location @var{dptr}. -@end deftypefun - -@deftypefun SCM gh_chars2byvect (char *@var{dptr}, int @var{n}) -@deftypefunx SCM gh_shorts2svect (short *@var{dptr}, int @var{n}) -@deftypefunx SCM gh_longs2ivect (long *@var{dptr}, int @var{n}) -@deftypefunx SCM gh_ulongs2uvect (ulong *@var{dptr}, int @var{n}) -@deftypefunx SCM gh_floats2fvect (float *@var{dptr}, int @var{n}) -@deftypefunx SCM gh_doubles2dvect (double *@var{dptr}, int @var{n}) -Make a scheme uniform vector containing the @var{n} chars, shorts, -longs, unsigned longs, floats or doubles at memory location @var{dptr}. -@end deftypefun - - - -@node Scheme to C -@subsection Scheme to C - -@deftypefun int gh_scm2bool (SCM @var{obj}) -@deftypefunx {unsigned long} gh_scm2ulong (SCM @var{obj}) -@deftypefunx long gh_scm2long (SCM @var{obj}) -@deftypefunx double gh_scm2double (SCM @var{obj}) -@deftypefunx int gh_scm2char (SCM @var{obj}) -These routines convert the Scheme object to the given C type. -@end deftypefun - -@deftypefun char *gh_scm2newstr (SCM @var{str}, int *@var{lenp}) -Given a Scheme string @var{str}, return a pointer to a new copy of its -contents, followed by a null byte. If @var{lenp} is non-null, set -@code{*@var{lenp}} to the string's length. - -This function uses malloc to obtain storage for the copy; the caller is -responsible for freeing it. - -Note that Scheme strings may contain arbitrary data, including null -characters. This means that null termination is not a reliable way to -determine the length of the returned value. However, the function -always copies the complete contents of @var{str}, and sets @var{*lenp} -to the true length of the string (when @var{lenp} is non-null). -@end deftypefun - - -@deftypefun void gh_get_substr (SCM str, char *return_str, int *lenp) -Copy @var{len} characters at @var{start} from the Scheme string -@var{src} to memory at @var{dst}. @var{start} is an index into -@var{src}; zero means the beginning of the string. @var{dst} has -already been allocated by the caller. - -If @var{start} + @var{len} is off the end of @var{src}, signal an -out-of-range error. -@end deftypefun - -@deftypefun char *gh_symbol2newstr (SCM @var{sym}, int *@var{lenp}) -Takes a Scheme symbol and returns a string of the form -@code{"'symbol-name"}. If @var{lenp} is non-null, the string's length -is returned in @code{*@var{lenp}}. - -This function uses malloc to obtain storage for the returned string; the -caller is responsible for freeing it. -@end deftypefun - -@deftypefun char *gh_scm2chars (SCM @var{vector}, chars *@var{result}) -@deftypefunx short *gh_scm2shorts (SCM @var{vector}, short *@var{result}) -@deftypefunx long *gh_scm2longs (SCM @var{vector}, long *@var{result}) -@deftypefunx float *gh_scm2floats (SCM @var{vector}, float *@var{result}) -@deftypefunx double *gh_scm2doubles (SCM @var{vector}, double *@var{result}) -Copy the numbers in @var{vector} to the array pointed to by @var{result} -and return it. If @var{result} is NULL, allocate a double array large -enough. - -@var{vector} can be an ordinary vector, a weak vector, or a signed or -unsigned uniform vector of the same type as the result array. For -chars, @var{vector} can be a string or substring. For floats and -doubles, @var{vector} can contain a mix of inexact and integer values. - -If @var{vector} is of unsigned type and contains values too large to fit -in the signed destination array, those values will be wrapped around, -that is, data will be copied as if the destination array was unsigned. -@end deftypefun - - -@node Type predicates -@section Type predicates - -These C functions mirror Scheme's type predicate procedures with one -important difference. The C routines return C boolean values (0 and 1) -instead of @code{SCM_BOOL_T} and @code{SCM_BOOL_F}. - -The Scheme notational convention of putting a @code{?} at the end of -predicate procedure names is mirrored in C by placing @code{_p} at the -end of the procedure. For example, @code{(pair? ...)} maps to -@code{gh_pair_p(...)}. - -@deftypefun int gh_boolean_p (SCM @var{val}) -Returns 1 if @var{val} is a boolean, 0 otherwise. -@end deftypefun - -@deftypefun int gh_symbol_p (SCM @var{val}) -Returns 1 if @var{val} is a symbol, 0 otherwise. -@end deftypefun - -@deftypefun int gh_char_p (SCM @var{val}) -Returns 1 if @var{val} is a char, 0 otherwise. -@end deftypefun - -@deftypefun int gh_vector_p (SCM @var{val}) -Returns 1 if @var{val} is a vector, 0 otherwise. -@end deftypefun - -@deftypefun int gh_pair_p (SCM @var{val}) -Returns 1 if @var{val} is a pair, 0 otherwise. -@end deftypefun - -@deftypefun int gh_procedure_p (SCM @var{val}) -Returns 1 if @var{val} is a procedure, 0 otherwise. -@end deftypefun - -@deftypefun int gh_list_p (SCM @var{val}) -Returns 1 if @var{val} is a list, 0 otherwise. -@end deftypefun - -@deftypefun int gh_inexact_p (SCM @var{val}) -Returns 1 if @var{val} is an inexact number, 0 otherwise. -@end deftypefun - -@deftypefun int gh_exact_p (SCM @var{val}) -Returns 1 if @var{val} is an exact number, 0 otherwise. -@end deftypefun - - -@node Equality predicates -@section Equality predicates - -These C functions mirror Scheme's equality predicate procedures with one -important difference. The C routines return C boolean values (0 and 1) -instead of @code{SCM_BOOL_T} and @code{SCM_BOOL_F}. - -The Scheme notational convention of putting a @code{?} at the end of -predicate procedure names is mirrored in C by placing @code{_p} at the -end of the procedure. For example, @code{(equal? ...)} maps to -@code{gh_equal_p(...)}. - -@deftypefun int gh_eq_p (SCM x, SCM y) -Returns 1 if @var{x} and @var{y} are equal in the sense of Scheme's -@code{eq?} predicate, 0 otherwise. -@end deftypefun - -@deftypefun int gh_eqv_p (SCM x, SCM y) -Returns 1 if @var{x} and @var{y} are equal in the sense of Scheme's -@code{eqv?} predicate, 0 otherwise. -@end deftypefun - -@deftypefun int gh_equal_p (SCM x, SCM y) -Returns 1 if @var{x} and @var{y} are equal in the sense of Scheme's -@code{equal?} predicate, 0 otherwise. -@end deftypefun - -@deftypefun int gh_string_equal_p (SCM @var{s1}, SCM @var{s2}) -Returns 1 if the strings @var{s1} and @var{s2} are equal, 0 otherwise. -@end deftypefun - -@deftypefun int gh_null_p (SCM @var{l}) -Returns 1 if @var{l} is an empty list or pair; 0 otherwise. -@end deftypefun - - -@node Memory allocation and garbage collection -@section Memory allocation and garbage collection - -@c [FIXME: flesh this out with some description of garbage collection in -@c scm/guile] - -@c @deftypefun SCM gh_mkarray (int size) -@c Allocate memory for a Scheme object in a garbage-collector-friendly -@c manner. -@c @end deftypefun - - -@node Calling Scheme procedures from C -@section Calling Scheme procedures from C - -Many of the Scheme primitives are available in the @code{gh_} -interface; they take and return objects of type SCM, and one could -basically use them to write C code that mimics Scheme code. - -I will list these routines here without much explanation, since what -they do is the same as documented in @ref{Standard procedures, R5RS, , -r5rs, R5RS}. But I will point out that when a procedure takes a -variable number of arguments (such as @code{gh_list}), you should pass -the constant @var{SCM_UNDEFINED} from C to signify the end of the list. - -@deftypefun SCM gh_define (char *@var{name}, SCM @var{val}) -Corresponds to the Scheme @code{(define name val)}: it binds a value to -the given name (which is a C string). Returns the new object. -@end deftypefun - -@heading Pairs and lists - -@deftypefun SCM gh_cons (SCM @var{a}, SCM @var{b}) -@deftypefunx SCM gh_list (SCM l0, SCM l1, ... , SCM_UNDEFINED) -These correspond to the Scheme @code{(cons a b)} and @code{(list l0 l1 -...)} procedures. Note that @code{gh_list()} is a C macro that invokes -@code{scm_listify()}. -@end deftypefun - -@deftypefun SCM gh_car (SCM @var{obj}) -@deftypefunx SCM gh_cdr (SCM @var{obj}) -@dots{} - -@deftypefunx SCM gh_c[ad][ad][ad][ad]r (SCM @var{obj}) -These correspond to the Scheme @code{(caadar ls)} procedures etc @dots{} -@end deftypefun - -@deftypefun SCM gh_set_car_x(SCM @var{pair}, SCM @var{value}) -Modifies the CAR of @var{pair} to be @var{value}. This is equivalent to -the Scheme procedure @code{(set-car! ...)}. -@end deftypefun - -@deftypefun SCM gh_set_cdr_x(SCM @var{pair}, SCM @var{value}) -Modifies the CDR of @var{pair} to be @var{value}. This is equivalent to -the Scheme procedure @code{(set-cdr! ...)}. -@end deftypefun - -@deftypefun {unsigned long} gh_length (SCM @var{ls}) -Returns the length of the list. -@end deftypefun - -@deftypefun SCM gh_append (SCM @var{args}) -@deftypefunx SCM gh_append2 (SCM @var{l1}, SCM @var{l2}) -@deftypefunx SCM gh_append3 (SCM @var{l1}, SCM @var{l2}, @var{l3}) -@deftypefunx SCM gh_append4 (SCM @var{l1}, SCM @var{l2}, @var{l3}, @var{l4}) -@code{gh_append()} takes @var{args}, which is a list of lists -@code{(list1 list2 ...)}, and returns a list containing all the elements -of the individual lists. - -A typical invocation of @code{gh_append()} to append 5 lists together -would be -@smallexample - gh_append(gh_list(l1, l2, l3, l4, l5, SCM_UNDEFINED)); -@end smallexample - -The functions @code{gh_append2()}, @code{gh_append2()}, -@code{gh_append3()} and @code{gh_append4()} are convenience routines to -make it easier for C programs to form the list of lists that goes as an -argument to @code{gh_append()}. -@end deftypefun - -@deftypefun SCM gh_reverse (SCM @var{ls}) -Returns a new list that has the same elements as @var{ls} but in the -reverse order. Note that this is implemented as a macro which calls -@code{scm_reverse()}. -@end deftypefun - -@deftypefun SCM gh_list_tail (SCM @var{ls}, SCM @var{k}) -Returns the sublist of @var{ls} with the last @var{k} elements. -@end deftypefun - -@deftypefun SCM gh_list_ref (SCM @var{ls}, SCM @var{k}) -Returns the @var{k}th element of the list @var{ls}. -@end deftypefun - -@deftypefun SCM gh_memq (SCM @var{x}, SCM @var{ls}) -@deftypefunx SCM gh_memv (SCM @var{x}, SCM @var{ls}) -@deftypefunx SCM gh_member (SCM @var{x}, SCM @var{ls}) -These functions return the first sublist of @var{ls} whose CAR is -@var{x}. They correspond to @code{(memq x ls)}, @code{(memv x ls)} and -@code{(member x ls)}, and hence use (respectively) @code{eq?}, -@code{eqv?} and @code{equal?} to do comparisons. - -If @var{x} does not appear in @var{ls}, the value @code{SCM_BOOL_F} (not -the empty list) is returned. - -Note that these functions are implemented as macros which call -@code{scm_memq()}, @code{scm_memv()} and @code{scm_member()} -respectively. -@end deftypefun - -@deftypefun SCM gh_assq (SCM @var{x}, SCM @var{alist}) -@deftypefunx SCM gh_assv (SCM @var{x}, SCM @var{alist}) -@deftypefunx SCM gh_assoc (SCM @var{x}, SCM @var{alist}) -These functions search an @dfn{association list} (list of pairs) -@var{alist} for the first pair whose CAR is @var{x}, and they return -that pair. - -If no pair in @var{alist} has @var{x} as its CAR, the value -@code{SCM_BOOL_F} (not the empty list) is returned. - -Note that these functions are implemented as macros which call -@code{scm_assq()}, @code{scm_assv()} and @code{scm_assoc()} -respectively. -@end deftypefun - - -@heading Symbols - -@c @deftypefun SCM gh_symbol (SCM str, SCM len) -@c @deftypefunx SCM gh_tmp_symbol (SCM str, SCM len) -@c Takes the given string @var{str} of length @var{len} and returns a -@c symbol corresponding to that string. -@c @end deftypefun - - -@heading Vectors - -@deftypefun SCM gh_make_vector (SCM @var{n}, SCM @var{fill}) -@deftypefunx SCM gh_vector (SCM @var{ls}) -@deftypefunx SCM gh_vector_ref (SCM @var{v}, SCM @var{i}) -@deftypefunx SCM gh_vector_set (SCM @var{v}, SCM @var{i}, SCM @var{val}) -@deftypefunx {unsigned long} gh_vector_length (SCM @var{v}) -@deftypefunx SCM gh_list_to_vector (SCM @var{ls}) -These correspond to the Scheme @code{(make-vector n fill)}, -@code{(vector a b c ...)} @code{(vector-ref v i)} @code{(vector-set v i -value)} @code{(vector-length v)} @code{(list->vector ls)} procedures. - -The correspondence is not perfect for @code{gh_vector}: this routine -taks a list @var{ls} instead of the individual list elements, thus -making it identical to @code{gh_list_to_vector}. - -There is also a difference in gh_vector_length: the value returned is a -C @code{unsigned long} instead of an SCM object. -@end deftypefun - - -@heading Procedures - -@c @deftypefun SCM gh_make_subr (SCM (*@var{fn})(), int @var{req}, int @var{opt}, int @var{restp}, char *@var{sym}) -@c Make the C function @var{fn} available to Scheme programs. The function -@c will be bound to the symbol @var{sym}. The arguments @var{req}, -@c @var{opt} and @var{restp} describe @var{fn}'s calling conventions. The -@c function must take @var{req} required arguments and may take @var{opt} -@c optional arguments. Any optional arguments which are not supplied by -@c the caller will be bound to @var{SCM_UNSPECIFIED}. If @var{restp} is -@c non-zero, it means that @var{fn} may be called with an arbitrary number -@c of arguments, and that any extra arguments supplied by the caller will -@c be passed to @var{fn} as a list. The @var{restp} argument is exactly -@c like Scheme's @code{(lambda (arg1 arg2 . arglist))} calling convention. -@c -@c For example, the procedure @code{read-line}, which takes optional -@c @var{port} and @var{handle-delim} arguments, would be declared like so: -@c -@c @example -@c SCM scm_read_line (SCM port, SCM handle_delim); -@c gh_make_subr (scm_read_line, 0, 2, 0, "read-line"); -@c @end example -@c -@c The @var{req} argument to @code{gh_make_subr} is 0 to indicate that -@c there are no required arguments, so @code{read-line} may be called -@c without any arguments at all. The @var{opt} argument is 2, to indicate -@c that both the @var{port} and @var{handle_delim} arguments to -@c @code{scm_read_line} are optional, and will be bound to -@c @code{SCM_UNSPECIFIED} if the calling program does not supply them. -@c Because the @var{restp} argument is 0, this function may not be called -@c with more than two arguments. -@c @end deftypefun - -@deftypefun SCM gh_apply (SCM proc, SCM args) -Call the Scheme procedure @var{proc}, with the elements of @var{args} as -arguments. @var{args} must be a proper list. -@end deftypefun - -@deftypefun SCM gh_call0 (SCM proc) -@deftypefunx SCM gh_call1 (SCM proc, SCM arg) -@deftypefunx SCM gh_call2 (SCM proc, SCM arg1, SCM arg2) -@deftypefunx SCM gh_call3 (SCM proc, SCM arg1, SCM arg2, SCM arg3) -Call the Scheme procedure @var{proc} with no arguments -(@code{gh_call0}), one argument (@code{gh_call1}), and so on. You can -get the same effect by wrapping the arguments up into a list, and -calling @code{gh_apply}; Guile provides these functions for convenience. -@end deftypefun - - -@deftypefun SCM gh_catch (SCM key, SCM thunk, SCM handler) -@deftypefunx SCM gh_throw (SCM key, SCM args) -Corresponds to the Scheme @code{catch} and @code{throw} procedures, -which in Guile are provided as primitives. -@end deftypefun - -@c [FIXME: must add the I/O section in gscm.h] - -@deftypefun SCM gh_is_eq (SCM a, SCM b) -@deftypefunx SCM gh_is_eqv (SCM a, SCM b) -@deftypefunx SCM gh_is_equal (SCM a, SCM b) -These correspond to the Scheme @code{eq?}, @code{eqv?} and @code{equal?} -predicates. -@end deftypefun - -@deftypefun int gh_obj_length (SCM @var{obj}) -Returns the raw object length. -@end deftypefun - -@heading Data lookup - -For now I just include Tim Pierce's comments from the @file{gh_data.c} -file; it should be organized into a documentation of the two functions -here. - -@smallexample -/* Data lookups between C and Scheme - - Look up a symbol with a given name, and return the object to which - it is bound. gh_lookup examines the Guile top level, and - gh_module_lookup checks the module namespace specified by the - `vec' argument. - - The return value is the Scheme object to which SNAME is bound, or - SCM_UNDEFINED if SNAME is not bound in the given context. [FIXME: - should this be SCM_UNSPECIFIED? Can a symbol ever legitimately be - bound to SCM_UNDEFINED or SCM_UNSPECIFIED? What is the difference? - -twp] */ -@end smallexample - - -@node Mixing gh and scm APIs -@section Mixing gh and scm APIs - - -@node scm transition summary -@section Transitioning to the scm Interface - -The following table summarizes the available information on how to -transition from the GH to the scm interface. Where transitioning is not -completely straightforward, the table includes a reference to more -detailed documentation in the preceding sections. - -@table @asis -@item Header file -Use @code{#include } instead of @code{#include -}. - -@item Linking flags -No change: @code{-lguile} should be added to the link command line, -along with any additional libraries that your application needs. - -@item The @code{SCM} type -No change: the scm interface also uses this type to represent an -arbitrary Scheme value. - -@item @code{SCM_BOOL_F} and @code{SCM_BOOL_T} -No change. - -@item @code{SCM_UNSPECIFIED} and @code{SCM_UNDEFINED} -No change. - -@item @code{gh_enter} -Use @code{scm_boot_guile} instead, but note that @code{scm_boot_guile} -has a slightly different calling convention from @code{gh_enter}: -@code{scm_boot_guile}, and the main program function that you specify -for @code{scm_boot_guile} to call, both take an additional @var{closure} -parameter. @ref{Guile Initialization Functions} for more details. - -@item @code{gh_repl} -Use @code{scm_shell} instead. - -@item @code{gh_init} -Use @code{scm_init_guile} instead. - -@item @code{gh_eval_str} -Use @code{scm_eval_0str} instead. - -@item @code{gh_eval_file} or @code{gh_load} -Replace @code{gh_eval_file (@var{fname})} by -@example -scm_primitive_load (scm_makfrom0str (@var{fname})) -@end example - -@item @code{gh_new_procedure} -Use @code{scm_c_define_gsubr} instead, but note that the arguments are -in a different order: for @code{scm_c_define_gsubr} the C function -pointer is the last argument. @ref{A Sample Guile Extension} for an -example. - -@item @code{gh_defer_ints} and @code{gh_allow_ints} -Use @code{SCM_DEFER_INTS} and @code{SCM_ALLOW_INTS} instead. Note that -these macros are used without parentheses, as in @code{SCM_DEFER_INTS;}. - -@item @code{gh_bool2scm} -Use @code{SCM_BOOL} instead. - -@item @code{gh_ulong2scm} -Use @code{scm_ulong2num} instead. - -@item @code{gh_long2scm} -Use @code{scm_long2num} instead. - -@item @code{gh_double2scm} -Use @code{scm_make_real} instead. - -@item @code{gh_char2scm} -Use @code{SCM_MAKE_CHAR} instead. - -@item @code{gh_str2scm} -Use @code{scm_mem2string} instead. - -@item @code{gh_str02scm} -Use @code{scm_makfrom0str} instead. - -@item @code{gh_set_substr} -No direct scm equivalent. [FIXME] - -@item @code{gh_symbol2scm} -Use @code{scm_str2symbol} instead. [FIXME: inconsistent naming, -should be @code{scm_str02symbol}.] - -@item @code{gh_ints2scm} and @code{gh_doubles2scm} -No direct scm equivalent. [FIXME] - -@item @code{gh_chars2byvect} and @code{gh_shorts2svect} -No direct scm equivalent. [FIXME] - -@item @code{gh_longs2ivect} and @code{gh_ulongs2uvect} -No direct scm equivalent. [FIXME] - -@item @code{gh_floats2fvect} and @code{gh_doubles2dvect} -No direct scm equivalent. [FIXME] - -@item @code{gh_scm2bool} -Use @code{SCM_NFALSEP} instead. - -@item @code{gh_scm2int} -Replace @code{gh_scm2int (@var{obj})} by -@example -scm_num2int (@var{obj}, SCM_ARG1, @var{str}) -@end example -where @var{str} is a C string that describes the context of the call. - -@item @code{gh_scm2ulong} -Replace @code{gh_scm2ulong (@var{obj})} by -@example -scm_num2ulong (@var{obj}, SCM_ARG1, @var{str}) -@end example -where @var{str} is a C string that describes the context of the call. - -@item @code{gh_scm2long} -Replace @code{gh_scm2long (@var{obj})} by -@example -scm_num2long (@var{obj}, SCM_ARG1, @var{str}) -@end example -where @var{str} is a C string that describes the context of the call. - -@item @code{gh_scm2double} -Replace @code{gh_scm2double (@var{obj})} by -@example -scm_num2dbl (@var{obj}, @var{str}) -@end example -where @var{str} is a C string that describes the context of the call. - -@item @code{gh_scm2char} -Use the @code{SCM_CHAR} macro instead, but note that @code{SCM_CHAR} -does not check that its argument is actually a character. To check that -a @code{SCM} value is a character before using @code{SCM_CHAR} to -extract the character value, use the @code{SCM_VALIDATE_CHAR} macro. - -@item @code{gh_scm2newstr} -No direct scm equivalent. [FIXME] - -@item @code{gh_get_substr} -No direct scm equivalent. [FIXME] - -@item @code{gh_symbol2newstr} -No direct scm equivalent. [FIXME] - -@item @code{gh_scm2chars} -No direct scm equivalent. [FIXME] - -@item @code{gh_scm2shorts} and @code{gh_scm2longs} -No direct scm equivalent. [FIXME] - -@item @code{gh_scm2floats} and @code{gh_scm2doubles} -No direct scm equivalent. [FIXME] - -@item @code{gh_boolean_p} -Use the @code{SCM_BOOLP} macro instead, or replace @code{gh_boolean_p -(@var{obj})} by -@example -SCM_NFALSEP (scm_boolean_p (@var{obj})) -@end example - -@item @code{gh_symbol_p} -Use the @code{SCM_SYMBOLP} macro instead, or replace @code{gh_symbol_p -(@var{obj})} by -@example -SCM_NFALSEP (scm_symbol_p (@var{obj})) -@end example - -@item @code{gh_char_p} -Use the @code{SCM_CHARP} macro instead, or replace @code{gh_char_p -(@var{obj})} by -@example -SCM_NFALSEP (scm_char_p (@var{obj})) -@end example - -@item @code{gh_vector_p} -Use the @code{SCM_VECTORP} macro instead, or replace @code{gh_vector_p -(@var{obj})} by -@example -SCM_NFALSEP (scm_vector_p (@var{obj})) -@end example - -@item @code{gh_pair_p} -Use the @code{SCM_CONSP} macro instead, or replace @code{gh_pair_p -(@var{obj})} by -@example -SCM_NFALSEP (scm_pair_p (@var{obj})) -@end example - -@item @code{gh_number_p} -Use the @code{SCM_NUMBERP} macro instead, or replace @code{gh_number_p -(@var{obj})} by -@example -SCM_NFALSEP (scm_number_p (@var{obj})) -@end example - -@item @code{gh_string_p} -Use the @code{SCM_STRINGP} macro instead, or replace @code{gh_string_p -(@var{obj})} by -@example -SCM_NFALSEP (scm_string_p (@var{obj})) -@end example - -@item @code{gh_procedure_p} -Replace @code{gh_procedure_p (@var{obj})} by -@example -SCM_NFALSEP (scm_procedure_p (@var{obj})) -@end example - -@item @code{gh_list_p} -Replace @code{gh_list_p (@var{obj})} by -@example -SCM_NFALSEP (scm_list_p (@var{obj})) -@end example - -@item @code{gh_inexact_p} -Use the @code{SCM_INEXACTP} macro instead, or replace @code{gh_inexact_p -(@var{obj})} by -@example -SCM_NFALSEP (scm_inexact_p (@var{obj})) -@end example - -@item @code{gh_exact_p} -Replace @code{gh_exact_p (@var{obj})} by -@example -SCM_NFALSEP (scm_exact_p (@var{obj})) -@end example - -@item @code{gh_eq_p} -Use the @code{SCM_EQ_P} macro instead, or replace @code{gh_eq_p -(@var{x}, @var{y})} by -@example -SCM_NFALSEP (scm_eq_p (@var{x}, @var{y})) -@end example - -@item @code{gh_eqv_p} -Replace @code{gh_eqv_p (@var{x}, @var{y})} by -@example -SCM_NFALSEP (scm_eqv_p (@var{x}, @var{y})) -@end example - -@item @code{gh_equal_p} -Replace @code{gh_equal_p (@var{x}, @var{y})} by -@example -SCM_NFALSEP (scm_equal_p (@var{x}, @var{y})) -@end example - -@item @code{gh_string_equal_p} -Replace @code{gh_string_equal_p (@var{x}, @var{y})} by -@example -SCM_NFALSEP (scm_string_equal_p (@var{x}, @var{y})) -@end example - -@item @code{gh_null_p} -Use the @code{SCM_NULLP} macro instead, or replace @code{gh_null_p -(@var{obj})} by -@example -SCM_NFALSEP (scm_null_p (@var{obj})) -@end example - -@item @code{gh_cons} -Use @code{scm_cons} instead. - -@item @code{gh_car} and @code{gh_cdr} -Use the @code{SCM_CAR} and @code{SCM_CDR} macros instead. - -@item @code{gh_cxxr} and @code{gh_cxxxr} -(Where each x is either @samp{a} or @samp{d}.) Use the corresponding -@code{SCM_CXXR} or @code{SCM_CXXXR} macro instead. - -@item @code{gh_set_car_x} and @code{gh_set_cdr_x} -Use @code{scm_set_car_x} and @code{scm_set_cdr_x} instead. - -@item @code{gh_list} -Use @code{scm_listify} instead. - -@item @code{gh_length} -Replace @code{gh_length (@var{lst})} by -@example -scm_num2ulong (scm_length (@var{lst}), SCM_ARG1, @var{str}) -@end example -where @var{str} is a C string that describes the context of the call. - -@item @code{gh_append} -Use @code{scm_append} instead. - -@item @code{gh_append2}, @code{gh_append3}, @code{gh_append4} -Replace @code{gh_append@var{N} (@var{l1}, @dots{}, @var{lN})} by -@example -scm_append (scm_listify (@var{l1}, @dots{}, @var{lN}, SCM_UNDEFINED)) -@end example - -@item @code{gh_reverse} -Use @code{scm_reverse} instead. - -@item @code{gh_list_tail} and @code{gh_list_ref} -Use @code{scm_list_tail} and @code{scm_list_ref} instead. - -@item @code{gh_memq}, @code{gh_memv} and @code{gh_member} -Use @code{scm_memq}, @code{scm_memv} and @code{scm_member} instead. - -@item @code{gh_assq}, @code{gh_assv} and @code{gh_assoc} -Use @code{scm_assq}, @code{scm_assv} and @code{scm_assoc} instead. - -@item @code{gh_make_vector} -Use @code{scm_make_vector} instead. - -@item @code{gh_vector} or @code{gh_list_to_vector} -Use @code{scm_vector} instead. - -@item @code{gh_vector_ref} and @code{gh_vector_set_x} -Use @code{scm_vector_ref} and @code{scm_vector_set_x} instead. - -@item @code{gh_vector_length} -Use the @code{SCM_VECTOR_LENGTH} macro instead. - -@item @code{gh_apply} -Use @code{scm_apply} instead, but note that @code{scm_apply} takes an -additional third argument that you should set to @code{SCM_EOL}. - -@end table From ca13a04a2653e6626415da5bcfdaad197122d41a Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 29 Jun 2001 23:13:14 +0000 Subject: [PATCH 1414/2047] (scm_c_read_string): Renamed from scm_read_0str. Also, added "const" qualifier to argument. (scm_c_eval_string): Renamed from scm_eval_0str. (scm_read_0str, scm_eval_0str): Deprecated. --- libguile/strports.c | 31 +++++++++++++++++++++++++++---- libguile/strports.h | 6 ++++-- 2 files changed, 31 insertions(+), 6 deletions(-) diff --git a/libguile/strports.c b/libguile/strports.c index f968c46ee..7509473ca 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -59,6 +59,7 @@ #include "libguile/strings.h" #include "libguile/modules.h" #include "libguile/validate.h" +#include "libguile/deprecation.h" #include "libguile/strports.h" @@ -428,12 +429,12 @@ SCM_DEFINE (scm_get_output_string, "get-output-string", 1, 0, 0, /* Given a null-terminated string EXPR containing a Scheme expression read it, and return it as an SCM value. */ SCM -scm_read_0str (char *expr) +scm_c_read_string (const char *expr) { SCM port = scm_mkstrport (SCM_INUM0, scm_makfrom0str (expr), SCM_OPN | SCM_RDNG, - "scm_eval_0str"); + "scm_c_read_string"); SCM form; /* Read expressions from that port; ignore the values. */ @@ -446,11 +447,33 @@ scm_read_0str (char *expr) /* Given a null-terminated string EXPR containing Scheme program text, evaluate it, and return the result of the last expression evaluated. */ SCM -scm_eval_0str (const char *expr) +scm_c_eval_string (const char *expr) { return scm_eval_string (scm_makfrom0str (expr)); } +#if SCM_DEBUG_DEPRECATED == 0 + +SCM +scm_read_0str (char *expr) +{ + scm_c_issue_deprecation_warning + ("scm_read_0str is deprecated. Use scm_c_read_string instead."); + + return scm_read_0str (expr); +} + +SCM +scm_eval_0str (const char *expr) +{ + scm_c_issue_deprecation_warning + ("scm_eval_0str is deprecated. Use scm_c_eval_string instead."); + + return scm_eval_0str (expr); +} + +#endif + static SCM inner_eval_string (void *data) { @@ -479,7 +502,7 @@ SCM_DEFINE (scm_eval_string, "eval-string", 1, 0, 0, #define FUNC_NAME s_scm_eval_string { SCM port = scm_mkstrport (SCM_INUM0, string, SCM_OPN | SCM_RDNG, - "scm_eval_0str"); + "eval-string"); return scm_c_call_with_current_module (scm_interaction_environment (), inner_eval_string, (void *)port); } diff --git a/libguile/strports.h b/libguile/strports.h index b293fc466..5de723b8b 100644 --- a/libguile/strports.h +++ b/libguile/strports.h @@ -72,14 +72,16 @@ extern SCM scm_call_with_input_string (SCM str, SCM proc); extern SCM scm_open_input_string (SCM str); extern SCM scm_open_output_string (void); extern SCM scm_get_output_string (SCM port); -extern SCM scm_read_0str (char *expr); -extern SCM scm_eval_0str (const char *expr); +extern SCM scm_c_read_string (const char *expr); +extern SCM scm_c_eval_string (const char *expr); extern SCM scm_eval_string (SCM string); extern void scm_init_strports (void); #if (SCM_DEBUG_DEPRECATED == 0) extern SCM scm_strprint_obj (SCM obj); +extern SCM scm_read_0str (char *expr); +extern SCM scm_eval_0str (const char *expr); #endif /* SCM_DEBUG_DEPRECATED == 0 */ From c519b27251cb0b041e510a3feb8d8d620bfd1ca4 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 29 Jun 2001 23:13:43 +0000 Subject: [PATCH 1415/2047] (scm_c_primitive_load, scm_c_primitive_load_path): New. --- libguile/load.c | 12 ++++++++++++ libguile/load.h | 2 ++ 2 files changed, 14 insertions(+) diff --git a/libguile/load.c b/libguile/load.c index 8c9d16b30..641f152ca 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -136,6 +136,12 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0, } #undef FUNC_NAME +SCM +scm_c_primitive_load (const char *filename) +{ + return scm_primitive_load (scm_makfrom0str (filename)); +} + /* Builtin path to scheme library files. */ #ifdef SCM_PKGDATA_DIR @@ -460,6 +466,12 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0, } #undef FUNC_NAME +SCM +scm_c_primitive_load_path (const char *filename) +{ + return scm_primitive_load_path (scm_makfrom0str (filename)); +} + #if SCM_DEBUG_DEPRECATED == 0 /* Eval now copies source properties, so this function is no longer required. diff --git a/libguile/load.h b/libguile/load.h index 6d5ceb9ec..fbba9be08 100644 --- a/libguile/load.h +++ b/libguile/load.h @@ -50,12 +50,14 @@ extern SCM scm_internal_parse_path (char *path, SCM tail); extern SCM scm_parse_path (SCM path, SCM tail); extern void scm_init_load_path (void); extern SCM scm_primitive_load (SCM filename); +extern SCM scm_c_primitive_load (const char *filename); extern SCM scm_sys_package_data_dir (void); extern SCM scm_sys_library_dir (void); extern SCM scm_sys_site_dir (void); extern SCM scm_search_path (SCM path, SCM filename, SCM exts); extern SCM scm_sys_search_load_path (SCM filename); extern SCM scm_primitive_load_path (SCM filename); +extern SCM scm_c_primitive_load_path (const char *filename); extern SCM scm_read_and_eval_x (SCM port); extern void scm_init_load (void); From 2dc6875df5e40ed1dc98fe23ba2297a22cfd5e7c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 29 Jun 2001 23:14:07 +0000 Subject: [PATCH 1416/2047] (gh_eval_str): Use scm_c_eval_string instead of scm_eval_0str. --- libguile/gh_eval.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/gh_eval.c b/libguile/gh_eval.c index e128e049a..48259eff3 100644 --- a/libguile/gh_eval.c +++ b/libguile/gh_eval.c @@ -50,7 +50,7 @@ typedef SCM (*gh_eval_t) (void *data, SCM jmpbuf); SCM gh_eval_str (const char *scheme_code) { - return scm_eval_0str (scheme_code); + return scm_c_eval_string (scheme_code); } /* evaluate the file by passing it to the lower level scm_primitive_load() */ From 02202352845398c6880a2f97ceaacc2a47801c07 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 29 Jun 2001 23:14:25 +0000 Subject: [PATCH 1417/2047] *** empty log message *** --- libguile/ChangeLog | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 410790cd5..ed5b2017b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,16 @@ +2001-06-30 Marius Vollmer + + * gh_eval.c (gh_eval_str): Use scm_c_eval_string instead of + scm_eval_0str. + + * load.c, load.h (scm_c_primitive_load, + scm_c_primitive_load_path): New. + + * strports.c, strports.h (scm_c_read_string): Renamed from + scm_read_0str. Also, added "const" qualifier to argument. + (scm_c_eval_string): Renamed from scm_eval_0str. + (scm_read_0str, scm_eval_0str): Deprecated. + 2001-06-28 Martin Grabmueller * fluids.c (scm_c_with_fluid): Use scm_list_1() instead of From 5dc13e983049b34615f3134ec34079726c393353 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Sat, 30 Jun 2001 06:39:17 +0000 Subject: [PATCH 1418/2047] * Makefile.am (ice9_sources): Removed tags.scm. * tags.scm: Removed file. --- ice-9/ChangeLog | 6 ++++++ ice-9/Makefile.am | 2 +- ice-9/tags.scm | 0 3 files changed, 7 insertions(+), 1 deletion(-) delete mode 100644 ice-9/tags.scm diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index c496f8e91..db26b0cf0 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,9 @@ +2001-06-30 Martin Grabmueller + + * Makefile.am (ice9_sources): Removed tags.scm. + + * tags.scm: Removed file. + 2001-06-29 Neil Jerram Changes to support tracing other than inside the repl-stack that diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index b38b88893..597fa7700 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -30,7 +30,7 @@ ice9_sources = \ posix.scm psyntax.pp psyntax.ss q.scm r4rs.scm r5rs.scm \ rdelim.scm receive.scm regex.scm runq.scm rw.scm \ safe-r5rs.scm safe.scm session.scm slib.scm stack-catch.scm \ - streams.scm string-fun.scm syncase.scm tags.scm threads.scm \ + streams.scm string-fun.scm syncase.scm threads.scm \ buffered-input.scm time.scm history.scm channel.scm \ pretty-print.scm diff --git a/ice-9/tags.scm b/ice-9/tags.scm deleted file mode 100644 index e69de29bb..000000000 From 375d34c0f5a7741de5e46c64a6afed880a8f023f Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 30 Jun 2001 06:56:43 +0000 Subject: [PATCH 1419/2047] bye bye --- libguile/stamp-h.in | 0 1 file changed, 0 insertions(+), 0 deletions(-) delete mode 100644 libguile/stamp-h.in diff --git a/libguile/stamp-h.in b/libguile/stamp-h.in deleted file mode 100644 index e69de29bb..000000000 From 78c51768a78de52cb93d77224933a67e2e9b5b56 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Sat, 30 Jun 2001 06:58:04 +0000 Subject: [PATCH 1420/2047] * scheme-data.texi (Hash Tables): Added docs for `make-hash-table'. --- doc/ChangeLog | 5 +++++ doc/scheme-data.texi | 13 +++++++++++-- 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 2b8933f68..a3ff0d3ce 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,8 @@ +2001-06-30 Martin Grabmueller + + * scheme-data.texi (Hash Tables): Added docs for + `make-hash-table'. + 2001-06-29 Martin Grabmueller * misc-modules.texi: New file. diff --git a/doc/scheme-data.texi b/doc/scheme-data.texi index 46bfb282b..0aaf527a3 100755 --- a/doc/scheme-data.texi +++ b/doc/scheme-data.texi @@ -4331,8 +4331,8 @@ useful for organizing and indexing large bodies of information. @menu * Dictionary Types:: About dictionary types; what they're good for. -* Association Lists:: -* Hash Tables:: +* Association Lists:: List-based dictionaries. +* Hash Tables:: Table-based dictionaries. @end menu @node Dictionary Types @@ -4794,6 +4794,15 @@ 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. +@deffn 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 + @deffn primitive 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, From 4dadf664c6966b48d44eb9fa2358c6d582322292 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 30 Jun 2001 06:58:08 +0000 Subject: [PATCH 1421/2047] *** empty log message *** --- libguile/ChangeLog | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index ed5b2017b..24416dac7 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2001-06-30 Thien-Thi Nguyen + + * stamp-h.in: bye bye + 2001-06-30 Marius Vollmer * gh_eval.c (gh_eval_str): Use scm_c_eval_string instead of @@ -23,7 +27,7 @@ (SCM_LIST0, SCM_LIST1, SCM_LIST2, SCM_LIST3, SCM_LIST4, SCM_LIST5, SCM_LIST6, SCM_LIST7, SCM_LIST8, SCM_LIST9, scm_listify): Deprecated. (lots of files): Use the new functions. - + * goops.c (CALL_GF1, CALL_GF2, CALL_GF3, CALL_GF4): Use scm_call_N. * strings.c: #include "libguile/deprecation.h". @@ -34,11 +38,11 @@ user-defined hash procedure first, so that overriding the builtin hash characters is possible (this was needed for implementing SRFI-4's read synax `f32(...)'). - + * num2integral.i.c: Use scm_t_signed_bits instead of scm_t_bits, because the latter is unsigned now and breaks comparisons like (n < (scm_t_signed_bits)MIN_VALUE). - + 2001-06-26 Neil Jerram * eval.h, eval.c (scm_call_4): New function. @@ -46,7 +50,7 @@ * eval.c (SCM_APPLY, SCM_CEVAL, ENTER_APPLY): Call trap handlers directly rather than dispatching to them via scm_ithrow and a lazy catch. - + * eval.c (scm_evaluator_trap_table), eval.h (SCM_ENTER_FRAME_HDLR, SCM_APPLY_FRAME_HDLR, SCM_EXIT_FRAME_HDLR): Add three new options for trap handler procedures. @@ -71,7 +75,7 @@ Thanks to Stefan Jahn for all necessary information, patches and testing. - + * posix.c: Conditialize getpwent, getgrent, kill, getppid, getuid, getpgrp, ttyname, primitive-fork and some header inclusion for Windows. @@ -82,7 +86,7 @@ * scmsigs.c: Emulate some functions (alarm, sleep, kill) under Windows and conditionalize some signal names. - * socket.c (scm_getsockopt): Added missing comma. + * socket.c (scm_getsockopt): Added missing comma. Include socket library header under Windows. * stime.c (CLKTCK): Add cast to int, to make it compile under @@ -248,7 +252,7 @@ scm_t_srcpropso_plist. See the big type renaming. * coop-defs.h (scm_mutex_trylock, scm_cond_timedwait): Likewise. Thanks to Seth Alves! - + * numbers.c (SIZE_MAX, PTRDIFF_MIN, PTRDIFF_MAX): Only define when they aren't defined already. @@ -309,7 +313,7 @@ extension takes place. * strings.h (SCM_STRING_LENGTH): Likewise. (SCM_STRING_MAX_LENGTH): Use unsigned numbers. - + * __scm.h (ptrdiff_t): Typedef to long when configure didn't find it. From e9566a8e4c8b5acb6314466103c3f07bc5a586e0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Sat, 30 Jun 2001 13:45:22 +0000 Subject: [PATCH 1422/2047] * preface.texi (Manual Conventions): Added description of @result{} and @print{}. * scheme-data.texi (Hash Table Examples): New subsubsection. --- doc/ChangeLog | 7 ++ doc/preface.texi | 158 ------------------------------------------- doc/scheme-data.texi | 94 ++++++++++++++++++++++++- 3 files changed, 100 insertions(+), 159 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index a3ff0d3ce..b77bed64b 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,10 @@ +2001-06-30 Martin Grabmueller + + * preface.texi (Manual Conventions): Added description of + @result{} and @print{}. + + * scheme-data.texi (Hash Table Examples): New subsubsection. + 2001-06-30 Martin Grabmueller * scheme-data.texi (Hash Tables): Added docs for diff --git a/doc/preface.texi b/doc/preface.texi index 3c0ab509b..e69de29bb 100644 --- a/doc/preface.texi +++ b/doc/preface.texi @@ -1,158 +0,0 @@ -@iftex -@page -@unnumbered Preface - -This reference manual documents Guile, GNU's Ubiquitous Intelligent -Language for Extensions. It describes how to use Guile in many useful -and interesting ways. - -This is edition 1.0 of the reference manual, and corresponds to Guile -version @value{VERSION}. -@end iftex - - -@iftex -@section The Guile License -@end iftex - -@ifnottex -@node Guile License -@chapter The Guile License -@end ifnottex - -The license of Guile consists of the GNU GPL plus a special statement -giving blanket permission to link with non-free software. This is the -license statement as found in any individual file that it applies to: - -@quotation -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, 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 this software; see the file COPYING. If not, write to the Free -Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA -02111-1307 USA - -As a special exception, the Free Software Foundation gives permission -for additional uses of the text contained in its release of GUILE. - -The exception is that, if you link the GUILE library with other files to -produce an executable, this does not by itself cause the resulting -executable to be covered by the GNU General Public License. Your use of -that executable is in no way restricted on account of linking the GUILE -library code into it. - -This exception does not however invalidate any other reasons why the -executable file might be covered by the GNU General Public License. - -This exception applies only to the code released by the Free Software -Foundation under the name GUILE. If you copy code from other Free -Software Foundation releases into a copy of GUILE, as the General Public -License permits, the exception does not apply to the code that you add -in this way. To avoid misleading anyone as to the status of such -modified files, you must delete this exception notice from them. - -If you write modifications of your own for GUILE, it is your choice -whether to permit this exception to apply to your modifications. If you -do not wish that, delete this exception notice. -@end quotation - - -@iftex -@section Layout of this Manual -@end iftex - -@ifnottex -@node Manual Layout -@chapter Layout of this Manual -@end ifnottex - -This manual is divided into five parts. - -@strong{Part I: Introduction to Guile} provides an overview of what -Guile is and how you can use it. A whirlwind tour shows how Guile can -be used interactively and as a script interpreter, how to link Guile -into your own applications, and how to write modules of interpreted and -compiled code for use with Guile. All of the ideas introduced here are -documented in full by the later parts of the manual. - -@strong{Part II: Guile Scheme} documents the core Scheme language and -features that Guile implements. Although the basis for this is the -Scheme language described in R5RS, this part of the manual does not -assume any prior familiarity with R5RS in particular, or with Scheme in -general. Basic Scheme concepts, standard aspects of the Scheme language -and Guile extensions on top of R5RS are all documented from scratch, and -organized by functionality rather than by the defining standards. - -@strong{Part III: Guile Modules} describes some important modules, -distributed as part of the Guile distribution, that extend the -functionality provided by the Guile Scheme core, most notably: - -@itemize @bullet -@item -the POSIX module, which provides Scheme level procedures for system and -network programming, conforming to the POSIX standard - -@item -the SLIB module, which makes Aubrey Jaffer's portable Scheme library -available for use in Guile. -@end itemize - -@strong{Part IV: Guile Scripting} documents the use of Guile as a script -interpreter, and illustrates this with a series of examples. - -@strong{Part V: Extending Applications Using Guile} explains the options -available for using Guile as a application extension language. At the -simpler end of the scale, an application might use Guile to define some -application-specific primitives in C and then load an application Scheme -file. In this case most of the application code is written on the -Scheme level, and uses the application-specific primitives as an -extension to standard Scheme. At the other end of the scale, an -application might be predominantly written in C --- with its main -control loop implemented in C --- but make occasional forays into Scheme -to, say, read configuration data or run user-defined customization code. -This part of the manual covers the complete range of application -extension options. - -Finally, the appendices explain how to obtain the latest version of -Guile, how to install it, where to find modules to work with Guile, and -how to use the Guile debugger. - - -@iftex -@section Manual Conventions -@end iftex - -@ifnottex -@node Manual Conventions -@chapter Conventions used in this Manual -@end ifnottex - -We use some conventions in this manual. - -@itemize @bullet - -@item -For some procedures, notably type predicates, we use @dfn{iff} to -mean `if and only if'. The construct is usually something like: -`Return @var{val} iff @var{condition}', where @var{val} is usually -`@code{#t}' or `non-@code{#f}'. This typically means that @var{val} -is returned if @var{condition} holds, and that @samp{#f} is returned -otherwise. -@cindex iff - -@c Add other conventions here. - -@end itemize - - -@c Local Variables: -@c TeX-master: "guile.texi" -@c End: diff --git a/doc/scheme-data.texi b/doc/scheme-data.texi index 0aaf527a3..120a2b638 100755 --- a/doc/scheme-data.texi +++ b/doc/scheme-data.texi @@ -4784,6 +4784,98 @@ capitals @subsection Hash Tables @tpindex Hash Tables +@c FIXME::martin: Review me! + +Hash tables are dictionaries which offer similar functionality as +association lists: They provide a mapping from keys to values. The +difference is that association lists need time linear in the size of +elements when searching for entries, whereas hash tables can normally +search in constant time. The drawback is that hash tables require a +little bit more memory, and that you can not use the normal list +procedures (@pxref{Lists}) for working with them. + +@menu +* Hash Table Examples:: Demonstration of hash table usage. +* Hash Table Reference:: Hash table procedure descriptions. +@end menu + + +@node Hash Table Examples +@subsubsection Hash Table Examples + +@c FIXME::martin: Review me! + +For demonstration purposes, this section gives a few usage examples of +some hash table procedures, together with some explanation what they do. + +First we start by creating a new hash table with 31 slots, and +populate it with two key/value pairs. + +@lisp +(define h (make-hash-table 31)) + +(hashq-create-handle! h 'foo "bar") +@result{} +(foo . "bar") + +(hashq-create-handle! h 'braz "zonk") +@result{} +(braz . "zonk") + +(hashq-create-handle! h 'frob #f) +@result{} +(frob . #f) +@end lisp + +You can get the value for a given key with the procedure +@code{hashq-ref}, but the problem with this procedure is that you +cannot reliably determine whether a key does exists in the table. The +reason is that the procedure returns @code{#f} if the key is not in +the table, but it will return the same value if the key is in the +table and just happens to have the value @code{#f}, as you can see in +the following examples. + +@lisp +(hashq-ref h 'foo) +@result{} +"bar" + +(hashq-ref h 'frob) +@result{} +#f + +(hashq-ref h 'not-there) +@result{} +#f +@end lisp + +Better is to use the procedure @code{hashq-get-handle}, which makes a +distinction between the two cases. Just like @code{assq}, this +procedure returns a key/value-pair on success, and @code{#f} if the +key is not found. + +@lisp +(hashq-get-handle h 'foo) +@result{} +(foo . "bar") + +(hashq-get-handle h 'not-there) +@result{} +#f +@end lisp + +There is no procedure for calculating the number of key/value-pairs in +a hash table, but @code{hash-fold} can be used for doing exactly that. + +@lisp +(hash-fold (lambda (key value seed) (+ 1 seed)) 0 h) +@result{} +3 +@end lisp + +@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 @@ -4991,7 +5083,7 @@ 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 +For example, @code{(hash-fold acons '() tab)} will convert a hash table into an a-list of key-value pairs. @end deffn From 0147054b67356fc72211965b915884cb4cc3caf4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Sat, 30 Jun 2001 13:47:32 +0000 Subject: [PATCH 1423/2047] Updated my record. --- AUTHORS | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/AUTHORS b/AUTHORS index 36b64a29e..966ed0f73 100644 --- a/AUTHORS +++ b/AUTHORS @@ -147,9 +147,8 @@ In the subdirectory srfi, wrote: In the subdirectory scripts, wrote: doc-snarf In the subdirectory doc, wrote: - script-getopt.texi - srfi-modules.texi - repl-modules.texi + script-getopt.texi srfi-modules.texi + repl-modules.texi misc-modules.texi In the subdirectory doc, changes to: guile.texi intro.texi posix.texi scheme-binding.texi scheme-control.texi From 197edeea976beda781ef9cd96a33cc24d3ac37ea Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 30 Jun 2001 19:26:21 +0000 Subject: [PATCH 1424/2047] * Don't install a bitvector read-hash extension for letter 'b'. --- ice-9/ChangeLog | 6 ++++++ ice-9/arrays.scm | 4 ++-- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index db26b0cf0..72be35b8e 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,9 @@ +2001-06-30 Dirk Herrmann + + * arrays.scm: Don't install a read-hash-extension for 'b': #b + is already defined by R5RS. Further, there is already a working + read syntax for bitvectors, starting with #*. + 2001-06-30 Martin Grabmueller * Makefile.am (ice9_sources): Removed tags.scm. diff --git a/ice-9/arrays.scm b/ice-9/arrays.scm index 7d249795e..b08de5e97 100644 --- a/ice-9/arrays.scm +++ b/ice-9/arrays.scm @@ -47,8 +47,8 @@ (for-each (lambda (char template) (read-hash-extend char (make-array-proc template))) - '(#\b #\a #\u #\e #\s #\i #\c #\y #\h #\l) - '(#t #\a 1 -1 1.0 1/3 0+i #\nul s l))) + '(#\a #\u #\e #\s #\i #\c #\y #\h #\l) + '(#\a 1 -1 1.0 1/3 0+i #\nul s l))) (let ((array-proc (lambda (c port) (read:array c port)))) From 5b2a7b5906e9257458af9164819376cdc74deb0a Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 30 Jun 2001 19:28:26 +0000 Subject: [PATCH 1425/2047] * Don't use SCM_LISTn any more. --- guile-readline/ChangeLog | 5 +++++ guile-readline/readline.c | 4 ++-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 648b86382..61375034f 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,8 @@ +2001-06-30 Dirk Herrmann + + * readline.c (completion_function): Use scm_list_n instead of + SCM_LISTn. + 2001-06-14 Marius Vollmer * readline.c, readline.h: Replace "scm_*_t" with "scm_t_*". diff --git a/guile-readline/readline.c b/guile-readline/readline.c index 7e0eb1460..0d2403384 100644 --- a/guile-readline/readline.c +++ b/guile-readline/readline.c @@ -410,7 +410,7 @@ completion_function (char *text, int continuep) { SCM t = scm_makfrom0str (text); SCM c = continuep ? SCM_BOOL_T : SCM_BOOL_F; - res = scm_apply (compfunc, SCM_LIST2 (t, c), SCM_EOL); + res = scm_apply (compfunc, scm_list_2 (t, c), SCM_EOL); if (SCM_FALSEP (res)) return NULL; @@ -418,7 +418,7 @@ completion_function (char *text, int continuep) if (!SCM_STRINGP (res)) scm_misc_error (s_scm_readline, "Completion function returned bogus value: %S", - SCM_LIST1 (res)); + scm_list_1 (res)); SCM_STRING_COERCE_0TERMINATION_X (res); return strdup (SCM_STRING_CHARS (res)); } From 592996c9ee5ead91117174873899d6d4069f2d9f Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 30 Jun 2001 19:50:10 +0000 Subject: [PATCH 1426/2047] * Fixed some signedness issues. * Added conservative marking for the contents of free or allocated cells. * Changed the representation of weak vectors to use double cells. * Minor stuff. --- libguile/ChangeLog | 63 +++++++++++ libguile/gc.c | 275 +++++++++++++++++++++++++-------------------- libguile/gc.h | 1 + libguile/list.c | 4 +- libguile/weaks.c | 111 +++++++++++------- libguile/weaks.h | 24 ++-- 6 files changed, 301 insertions(+), 177 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 24416dac7..4fb5e43b6 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,66 @@ +2001-06-30 Dirk Herrmann + + * list.c (SCM_I_CONS): Make sure the cell type is initialized + last. + + * gc.c (s_scm_map_free_list, scm_igc, scm_gc_sweep, + init_heap_seg): Fixed signedness. + + (init_heap_seg): Replaced strange for-loop with a while loop. + + * weaks.h (WEAKSH, SCM_WEAKS_H): Rename H to SCM__H. + + (SCM_WVECTP): Prefer !SCM_ over SCM_N. + + The following patch adds conservative marking for the elements of + free or allocated cells. + + * gc.c (allocated_mark, heap_segment): New static functions. + + (which_seg): Deleted, since the functionality is now provided by + function heap_segment. + + (map_free_list): Use heap_segment instead of which_seg. + + (MARK): If cell debugging is disabled, mark free cells + conservatively. + + (scm_mark_locations, scm_cellp): Extracted the search for the + heap segment of a SCM value into function heap_segment. + + (scm_init_storage): Allocated cells must be marked + conservatively. + + * gc.[ch] (scm_gc_mark_cell_conservatively): New function. + + The following patch changes the representation of weak vectors to + double cells instead of using an extension of the vector's + allocated memory. + + * gc.c (MARK): Use SCM_SET_WVECT_GC_CHAIN instead of assigning to + the result of SCM_WVECT_GC_CHAIN. + + (scm_gc_sweep): Weak vectors don't have extra fields any more. + + * weaks.c (allocate_weak_vector): New static function. It does + not patch any previously created vector object during the + construction of a weak vector, and thus doesn't need to switch + off interrupts during vector creation. + + (scm_make_weak_vector, scm_make_weak_key_hash_table, + scm_make_weak_value_hash_table, scm_make_doubly_weak_hash_table): + Use allocate_weak_vector to provide the new weak vector object. + + * weaks.h (SCM_WVECT_TYPE, SCM_SET_WVECT_TYPE, + SCM_SET_WVECT_GC_CHAIN): New macros. The weak vector subtype is + now stored in the double cell. + + (SCM_IS_WHVEC, SCM_IS_WHVEC_V, SCM_IS_WHVEC_B, SCM_IS_WHVEC_ANY): + Use SCM_WVECT_TYPE. + + (SCM_WVECT_GC_CHAIN): The weak objects are now chained together + using an entry of the double cell. + 2001-06-30 Thien-Thi Nguyen * stamp-h.in: bye bye diff --git a/libguile/gc.c b/libguile/gc.c index ac7f8fe85..0d5177912 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -114,6 +114,19 @@ unsigned int scm_debug_cell_accesses_p = 1; static unsigned int debug_cells_gc_interval = 0; +/* If an allocated cell is detected during garbage collection, this means that + * some code has just obtained the object but was preempted before the + * initialization of the object was completed. This meanst that some entries + * of the allocated cell may already contain SCM objects. Therefore, + * allocated cells are scanned conservatively. */ +static SCM +allocated_mark (SCM allocated) +{ + scm_gc_mark_cell_conservatively (allocated); + return SCM_BOOL_F; +} + + /* Assert that the given object is a valid reference to a valid cell. This * test involves to determine whether the object is a cell pointer, whether * this pointer actually points into a heap segment and whether the cell @@ -517,22 +530,6 @@ clear_mark_space () #if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST) -/* Return the number of the heap segment containing CELL. */ -static long -which_seg (SCM cell) -{ - long i; - - for (i = 0; i < scm_n_heap_segs; i++) - if (SCM_PTR_LE (scm_heap_table[i].bounds[0], SCM2PTR (cell)) - && SCM_PTR_GT (scm_heap_table[i].bounds[1], SCM2PTR (cell))) - return i; - fprintf (stderr, "which_seg: can't find segment containing cell %lux\n", - (unsigned long) SCM_UNPACK (cell)); - abort (); -} - - static void map_free_list (scm_t_freelist *master, SCM freelist) { @@ -541,9 +538,16 @@ map_free_list (scm_t_freelist *master, SCM freelist) for (f = freelist; !SCM_NULLP (f); f = SCM_FREE_CELL_CDR (f)) { - long this_seg = which_seg (f); + long int this_seg = heap_segment (f); - if (this_seg != last_seg) + if (this_seg == -1) + { + fprintf (stderr, + "map_free_list: can't find segment containing cell %lux\n", + (unsigned long int) SCM_UNPACK (cell)); + abort (); + } + else if (this_seg != last_seg) { if (last_seg != -1) fprintf (stderr, " %5ld %d-cells in segment %ld\n", @@ -565,12 +569,14 @@ SCM_DEFINE (scm_map_free_list, "map-free-list", 0, 0, 0, "@code{--enable-guile-debug} builds of Guile.") #define FUNC_NAME s_scm_map_free_list { - long i; + size_t i; + fprintf (stderr, "%ld segments total (%d:%ld", (long) scm_n_heap_segs, scm_heap_table[0].span, (long) (scm_heap_table[0].bounds[1] - scm_heap_table[0].bounds[0])); - for (i = 1; i < scm_n_heap_segs; i++) + + for (i = 1; i != scm_n_heap_segs; i++) fprintf (stderr, ", %d:%ld", scm_heap_table[i].span, (long) (scm_heap_table[i].bounds[1] - scm_heap_table[i].bounds[0])); @@ -1120,10 +1126,10 @@ scm_igc (const char *what) /* mark the registered roots */ { - long i; + size_t i; for (i = 0; i < SCM_VECTOR_LENGTH (scm_gc_registered_roots); ++i) { SCM l = SCM_VELTS (scm_gc_registered_roots)[i]; - for (; ! SCM_NULLP (l); l = SCM_CDR (l)) { + for (; !SCM_NULLP (l); l = SCM_CDR (l)) { SCM *p = (SCM *) (scm_num2long (SCM_CAAR (l), 0, NULL)); scm_gc_mark (*p); } @@ -1366,7 +1372,7 @@ gc_mark_loop_first_time: goto_gc_mark_loop; case scm_tc7_wvect: - SCM_WVECT_GC_CHAIN (ptr) = scm_weak_vectors; + SCM_SET_WVECT_GC_CHAIN (ptr, scm_weak_vectors); scm_weak_vectors = ptr; if (SCM_IS_WHVEC_ANY (ptr)) { @@ -1449,7 +1455,27 @@ gc_mark_loop_first_time: switch (SCM_TYP16 (ptr)) { /* should be faster than going through scm_smobs */ case scm_tc_free_cell: - /* printf("found free_cell %X ", ptr); fflush(stdout); */ + /* We have detected a free cell. This can happen if non-object data + * on the C stack points into guile's heap and is scanned during + * conservative marking. */ +#if (SCM_DEBUG_CELL_ACCESSES == 0) + /* If cell debugging is disabled, there is a second situation in + * which a free cell can be encountered, namely if with preemptive + * threading one thread has just obtained a fresh cell and was + * preempted before the cell initialization was completed. In this + * case, some entries of the cell may already contain objects. + * Thus, if cell debugging is disabled, free cells are scanned + * conservatively. */ + scm_gc_mark_cell_conservatively (ptr); +#else /* SCM_DEBUG_CELL_ACCESSES == 1 */ + /* With cell debugging enabled, a freshly obtained but not fully + * initialized cell is guaranteed to be of type scm_tc16_allocated. + * Thus, no conservative scanning for free cells is necessary, but + * instead cells of type scm_tc16_allocated have to be scanned + * conservatively. This is done in the mark function of the + * scm_tc16_allocated smob type. */ +#endif + break; case scm_tc16_big: case scm_tc16_real: case scm_tc16_complex: @@ -1493,9 +1519,97 @@ gc_mark_loop_first_time: #undef FNAME -/* Mark a Region Conservatively - */ +/* Determine whether the given value does actually represent a cell in some + * heap segment. If this is the case, the number of the heap segment is + * returned. Otherwise, -1 is returned. Binary search is used in order to + * determine the heap segment that contains the cell.*/ +/* FIXME: To be used within scm_gc_mark_cell_conservatively, + * scm_mark_locations and scm_cellp this function should be an inline + * function. */ +static long int +heap_segment (SCM obj) +{ + if (!SCM_CELLP (obj)) + return -1; + else + { + SCM_CELLPTR ptr = SCM2PTR (obj); + unsigned long int i = 0; + unsigned long int j = scm_n_heap_segs - 1; + if (SCM_PTR_LT (ptr, scm_heap_table[i].bounds[0])) + return -1; + else if (SCM_PTR_LE (scm_heap_table[j].bounds[1], ptr)) + return -1; + else + { + while (i < j) + { + if (SCM_PTR_LT (ptr, scm_heap_table[i].bounds[1])) + { + break; + } + else if (SCM_PTR_LE (scm_heap_table[j].bounds[0], ptr)) + { + i = j; + break; + } + else + { + unsigned long int k = (i + j) / 2; + + if (k == i) + return -1; + else if (SCM_PTR_LT (ptr, scm_heap_table[k].bounds[1])) + { + j = k; + ++i; + if (SCM_PTR_LT (ptr, scm_heap_table[i].bounds[0])) + return -1; + } + else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr)) + { + i = k; + --j; + if (SCM_PTR_LE (scm_heap_table[j].bounds[1], ptr)) + return -1; + } + } + } + + if (!DOUBLECELL_ALIGNED_P (obj) && scm_heap_table[i].span == 2) + return -1; + else if (SCM_GC_IN_CARD_HEADERP (ptr)) + return -1; + else + return i; + } + } +} + + +/* Mark the entries of a cell conservatively. The given cell is known to be + * on the heap. Still we have to determine its heap segment in order to + * figure out whether it is a single or a double cell. Then, each of the cell + * elements itself is checked and potentially marked. */ +void +scm_gc_mark_cell_conservatively (SCM cell) +{ + unsigned long int cell_segment = heap_segment (cell); + unsigned int span = scm_heap_table[cell_segment].span; + unsigned int i; + + for (i = 1; i != span * 2; ++i) + { + SCM obj = SCM_CELL_OBJECT (cell, i); + long int obj_segment = heap_segment (obj); + if (obj_segment >= 0) + scm_gc_mark (obj); + } +} + + +/* Mark a region conservatively */ void scm_mark_locations (SCM_STACKITEM x[], unsigned long n) { @@ -1504,98 +1618,21 @@ scm_mark_locations (SCM_STACKITEM x[], unsigned long n) for (m = 0; m < n; ++m) { SCM obj = * (SCM *) &x[m]; - if (SCM_CELLP (obj)) - { - SCM_CELLPTR ptr = SCM2PTR (obj); - long i = 0; - long j = scm_n_heap_segs - 1; - if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr) - && SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr)) - { - while (i <= j) - { - long seg_id; - seg_id = -1; - if ((i == j) - || SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr)) - seg_id = i; - else if (SCM_PTR_LE (scm_heap_table[j].bounds[0], ptr)) - seg_id = j; - else - { - long k; - k = (i + j) / 2; - if (k == i) - break; - if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr)) - { - j = k; - ++i; - if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr)) - continue; - else - break; - } - else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr)) - { - i = k; - --j; - if (SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr)) - continue; - else - break; - } - } - - if (SCM_GC_IN_CARD_HEADERP (ptr)) - break; - - if (scm_heap_table[seg_id].span == 1 - || DOUBLECELL_ALIGNED_P (obj)) - scm_gc_mark (obj); - - break; - } - } - } + long int segment = heap_segment (obj); + if (segment >= 0) + scm_gc_mark (obj); } } /* The function scm_cellp determines whether an SCM value can be regarded as a - * pointer to a cell on the heap. Binary search is used in order to determine - * the heap segment that contains the cell. + * pointer to a cell on the heap. */ int scm_cellp (SCM value) { - if (SCM_CELLP (value)) { - scm_cell * ptr = SCM2PTR (value); - unsigned long i = 0; - unsigned long j = scm_n_heap_segs - 1; - - if (SCM_GC_IN_CARD_HEADERP (ptr)) - return 0; - - while (i < j) { - long k = (i + j) / 2; - if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr)) { - j = k; - } else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr)) { - i = k + 1; - } - } - - if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr) - && SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr) - && (scm_heap_table[i].span == 1 || DOUBLECELL_ALIGNED_P (value)) - && !SCM_GC_IN_CARD_HEADERP (ptr) - ) - return 1; - else - return 0; - } else - return 0; + long int segment = heap_segment (value); + return (segment >= 0); } @@ -1654,7 +1691,7 @@ scm_gc_sweep () register scm_t_freelist *freelist; register unsigned long m; register int span; - long i; + size_t i; size_t seg_size; m = 0; @@ -1738,9 +1775,6 @@ scm_gc_sweep () case scm_tc7_pws: break; case scm_tc7_wvect: - m += (2 + SCM_VECTOR_LENGTH (scmptr)) * sizeof (SCM); - scm_must_free (SCM_VECTOR_BASE (scmptr) - 2); - break; case scm_tc7_vector: { unsigned long int length = SCM_VECTOR_LENGTH (scmptr); @@ -2222,7 +2256,7 @@ init_heap_seg (SCM_CELLPTR seg_org, size_t size, scm_t_freelist *freelist) { register SCM_CELLPTR ptr; SCM_CELLPTR seg_end; - long new_seg_index; + size_t new_seg_index; ptrdiff_t n_new_cells; int span = freelist->span; @@ -2238,13 +2272,11 @@ init_heap_seg (SCM_CELLPTR seg_org, size_t size, scm_t_freelist *freelist) seg_end = SCM_GC_CARD_DOWN ((char *)seg_org + size); /* Find the right place and insert the segment record. - * */ - for (new_seg_index = 0; - ( (new_seg_index < scm_n_heap_segs) - && SCM_PTR_LE (scm_heap_table[new_seg_index].bounds[0], seg_org)); - new_seg_index++) - ; + new_seg_index = 0; + while (new_seg_index < scm_n_heap_segs + && SCM_PTR_LE (scm_heap_table[new_seg_index].bounds[0], seg_org)) + new_seg_index++; { int i; @@ -2468,7 +2500,7 @@ alloc_some_heap (scm_t_freelist *freelist, policy_on_error error_policy) * parameters. Therefore, you can be sure that the compiler will keep those * scheme values alive (on the stack or in a register) up to the point where * scm_remember_upto_here* is called. In other words, place the call to - * scm_remember_upt_here* _behind_ the last code in your function, that + * scm_remember_upto_here* _behind_ the last code in your function, that * depends on the scheme object to exist. * * Example: We want to make sure, that the string object str does not get @@ -2778,6 +2810,7 @@ scm_init_storage () #if (SCM_DEBUG_CELL_ACCESSES == 1) scm_tc16_allocated = scm_make_smob_type ("allocated cell", 0); + scm_set_smob_mark (scm_tc16_allocated, allocated_mark); #endif /* SCM_DEBUG_CELL_ACCESSES == 1 */ j = SCM_NUM_PROTECTS; diff --git a/libguile/gc.h b/libguile/gc.h index 07d2fe724..0f0b5a8a3 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -363,6 +363,7 @@ extern void scm_alloc_cluster (struct scm_t_freelist *master); extern void scm_igc (const char *what); extern void scm_gc_mark (SCM p); extern void scm_gc_mark_dependencies (SCM p); +extern void scm_gc_mark_cell_conservatively (SCM cell); extern void scm_mark_locations (SCM_STACKITEM x[], unsigned long n); extern int scm_cellp (SCM value); extern void scm_gc_sweep (void); diff --git a/libguile/list.c b/libguile/list.c index f39c99c91..0da225596 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,2000,2001 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 @@ -63,8 +63,8 @@ #define SCM_I_CONS(cell,x,y) \ do { \ SCM_NEWCELL (cell); \ - SCM_SET_CELL_OBJECT_0 (cell, x); \ SCM_SET_CELL_OBJECT_1 (cell, y); \ + SCM_SET_CELL_OBJECT_0 (cell, x); \ } while (0) SCM diff --git a/libguile/weaks.c b/libguile/weaks.c index 6180f1bc5..4debbb499 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -43,18 +43,72 @@ gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include "libguile/_scm.h" #include "libguile/vectors.h" #include "libguile/validate.h" #include "libguile/weaks.h" - + /* {Weak Vectors} */ +/* Allocate memory for a weak vector on behalf of the caller. The allocated + * vector will be of the given weak vector subtype. It will contain size + * elements which are initialized with the 'fill' object, or, if 'fill' is + * undefined, with an unspecified object. + */ +static SCM +allocate_weak_vector (scm_t_bits type, SCM size, SCM fill, const char* caller) +#define FUNC_NAME caller +{ + if (SCM_INUMP (size)) + { + size_t c_size; + SCM v; + + SCM_ASSERT_RANGE (1, size, SCM_INUM (size) >= 0); + c_size = SCM_INUM (size); + + SCM_NEWCELL2 (v); + SCM_SET_WVECT_GC_CHAIN (v, SCM_EOL); + SCM_SET_WVECT_TYPE (v, type); + + if (c_size > 0) + { + scm_t_bits *base; + size_t j; + + if (SCM_UNBNDP (fill)) + fill = SCM_UNSPECIFIED; + + SCM_ASSERT_RANGE (1, size, c_size <= SCM_VECTOR_MAX_LENGTH); + base = scm_must_malloc (c_size * sizeof (scm_t_bits), FUNC_NAME); + for (j = 0; j != c_size; ++j) + base[j] = SCM_UNPACK (fill); + SCM_SET_VECTOR_BASE (v, base); + SCM_SET_VECTOR_LENGTH (v, c_size, scm_tc7_wvect); + scm_remember_upto_here_1 (fill); + } + else + { + SCM_SET_VECTOR_BASE (v, NULL); + SCM_SET_VECTOR_LENGTH (v, 0, scm_tc7_wvect); + } + + return v; + } + else if (SCM_BIGP (size)) + SCM_OUT_OF_RANGE (1, size); + else + SCM_WRONG_TYPE_ARG (1, size); +} +#undef FUNC_NAME + + SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0, (SCM size, SCM fill), "Return a weak vector with @var{size} elements. If the optional\n" @@ -63,16 +117,7 @@ SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0, "empty list.") #define FUNC_NAME s_scm_make_weak_vector { - /* Dirk:FIXME:: We should probably rather use a double cell for weak vectors. */ - SCM v; - v = scm_make_vector (scm_sum (size, SCM_MAKINUM (2)), fill); - SCM_DEFER_INTS; - SCM_SET_VECTOR_LENGTH (v, SCM_INUM (size), scm_tc7_wvect); - SCM_SETVELTS(v, SCM_VELTS(v) + 2); - SCM_VELTS(v)[-2] = SCM_EOL; - SCM_VECTOR_BASE (v) [-1] = 0; - SCM_ALLOW_INTS; - return v; + return allocate_weak_vector (0, size, fill, FUNC_NAME); } #undef FUNC_NAME @@ -116,16 +161,12 @@ SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0, "weak hashes are also weak vectors.") #define FUNC_NAME s_scm_weak_vector_p { - return SCM_BOOL(SCM_WVECTP (obj) && !SCM_IS_WHVEC (obj)); + return SCM_BOOL (SCM_WVECTP (obj) && !SCM_IS_WHVEC (obj)); } #undef FUNC_NAME - - - - SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 1, 0, 0, (SCM size), "@deffnx primitive make-weak-value-hash-table size\n" @@ -138,13 +179,7 @@ SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 1, 0, 0, "would modify regular hash tables. (@pxref{Hash Tables})") #define FUNC_NAME s_scm_make_weak_key_hash_table { - SCM v; - SCM_VALIDATE_INUM (1, size); - v = scm_make_weak_vector (size, SCM_EOL); - SCM_DEFER_INTS; - SCM_VECTOR_BASE (v) [-1] = 1; - SCM_ALLOW_INTS; - return v; + return allocate_weak_vector (1, size, SCM_EOL, FUNC_NAME); } #undef FUNC_NAME @@ -155,34 +190,22 @@ SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 1, 0, "(@pxref{Hash Tables})") #define FUNC_NAME s_scm_make_weak_value_hash_table { - SCM v; - SCM_VALIDATE_INUM (1, size); - v = scm_make_weak_vector (size, SCM_EOL); - SCM_DEFER_INTS; - SCM_VECTOR_BASE (v) [-1] = 2; - SCM_ALLOW_INTS; - return v; + return allocate_weak_vector (2, size, SCM_EOL, FUNC_NAME); } #undef FUNC_NAME - SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0, (SCM size), "Return a hash table with weak keys and values with @var{size}\n" "buckets. (@pxref{Hash Tables})") #define FUNC_NAME s_scm_make_doubly_weak_hash_table { - SCM v; - SCM_VALIDATE_INUM (1, size); - v = scm_make_weak_vector (size, SCM_EOL); - SCM_DEFER_INTS; - SCM_VECTOR_BASE (v) [-1] = 3; - SCM_ALLOW_INTS; - return v; + return allocate_weak_vector (3, size, SCM_EOL, FUNC_NAME); } #undef FUNC_NAME + SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0, (SCM obj), "@deffnx primitive weak-value-hash-table? obj\n" @@ -192,7 +215,7 @@ SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0, "nor a weak value hash table.") #define FUNC_NAME s_scm_weak_key_hash_table_p { - return SCM_BOOL(SCM_WVECTP (obj) && SCM_IS_WHVEC(obj)); + return SCM_BOOL (SCM_WVECTP (obj) && SCM_IS_WHVEC (obj)); } #undef FUNC_NAME @@ -202,7 +225,7 @@ SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0, "Return @code{#t} if @var{obj} is a weak value hash table.") #define FUNC_NAME s_scm_weak_value_hash_table_p { - return SCM_BOOL(SCM_WVECTP (obj) && SCM_IS_WHVEC_V(obj)); + return SCM_BOOL (SCM_WVECTP (obj) && SCM_IS_WHVEC_V (obj)); } #undef FUNC_NAME @@ -212,10 +235,11 @@ SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0, "Return @code{#t} if @var{obj} is a doubly weak hash table.") #define FUNC_NAME s_scm_doubly_weak_hash_table_p { - return SCM_BOOL(SCM_WVECTP (obj) && SCM_IS_WHVEC_B (obj)); + return SCM_BOOL (SCM_WVECTP (obj) && SCM_IS_WHVEC_B (obj)); } #undef FUNC_NAME + static void * scm_weak_vector_gc_init (void *dummy1 SCM_UNUSED, void *dummy2 SCM_UNUSED, @@ -226,6 +250,7 @@ scm_weak_vector_gc_init (void *dummy1 SCM_UNUSED, return 0; } + static void * scm_mark_weak_vector_spines (void *dummy1 SCM_UNUSED, void *dummy2 SCM_UNUSED, @@ -265,6 +290,7 @@ scm_mark_weak_vector_spines (void *dummy1 SCM_UNUSED, return 0; } + static void * scm_scan_weak_vectors (void *dummy1 SCM_UNUSED, void *dummy2 SCM_UNUSED, @@ -325,10 +351,8 @@ scm_scan_weak_vectors (void *dummy1 SCM_UNUSED, return 0; } - - void scm_weaks_prehistory () { @@ -337,6 +361,7 @@ scm_weaks_prehistory () scm_c_hook_add (&scm_after_sweep_c_hook, scm_scan_weak_vectors, 0, 0); } + void scm_init_weaks () { diff --git a/libguile/weaks.h b/libguile/weaks.h index 9f662d2c6..da86bfd1c 100644 --- a/libguile/weaks.h +++ b/libguile/weaks.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef WEAKSH -#define WEAKSH -/* Copyright (C) 1995,1996, 2000 Free Software Foundation, Inc. +#ifndef SCM_WEAKS_H +#define SCM_WEAKS_H +/* Copyright (C) 1995,1996,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -51,13 +51,15 @@ - -#define SCM_WVECTP(x) (SCM_NIMP(x) && (SCM_TYP7(x)==scm_tc7_wvect)) -#define SCM_IS_WHVEC(X) (SCM_UNPACK (SCM_VELTS(X)[-1]) == 1) -#define SCM_IS_WHVEC_V(X) (SCM_UNPACK (SCM_VELTS(X)[-1]) == 2) -#define SCM_IS_WHVEC_B(X) (SCM_UNPACK (SCM_VELTS(X)[-1]) == 3) -#define SCM_IS_WHVEC_ANY(X) (SCM_UNPACK (SCM_VELTS(X)[-1]) != 0) -#define SCM_WVECT_GC_CHAIN(X) (SCM_VELTS(X)[-2]) +#define SCM_WVECTP(x) (!SCM_IMP (x) && SCM_TYP7 (x) == scm_tc7_wvect) +#define SCM_WVECT_TYPE(x) (SCM_CELL_WORD_2 (x)) +#define SCM_SET_WVECT_TYPE(x, t) (SCM_SET_CELL_WORD_2 ((x), (t))) +#define SCM_IS_WHVEC(X) (SCM_WVECT_TYPE (X) == 1) +#define SCM_IS_WHVEC_V(X) (SCM_WVECT_TYPE (X) == 2) +#define SCM_IS_WHVEC_B(X) (SCM_WVECT_TYPE (X) == 3) +#define SCM_IS_WHVEC_ANY(X) (SCM_WVECT_TYPE (X) != 0) +#define SCM_WVECT_GC_CHAIN(X) (SCM_CELL_OBJECT_3 (X)) +#define SCM_SET_WVECT_GC_CHAIN(X, o) (SCM_SET_CELL_OBJECT_3 ((X), (o))) extern SCM scm_weak_vectors; @@ -75,7 +77,7 @@ extern SCM scm_doubly_weak_hash_table_p (SCM x); extern void scm_weaks_prehistory (void); extern void scm_init_weaks (void); -#endif /* WEAKSH */ +#endif /* SCM_WEAKS_H */ /* Local Variables: From 9a97e36281431311f22e40251411bf548b10c596 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 30 Jun 2001 19:56:57 +0000 Subject: [PATCH 1427/2047] * Fixed a bug in array-set! plus some minor cleanup. --- libguile/ChangeLog | 6 ++++++ libguile/unif.c | 6 ++---- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 4fb5e43b6..001d2495d 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2001-06-30 Dirk Herrmann + + * unif.c (scm_array_set_x): The variable args does not + necessarily have to be a list. Further, got rid of a redundant + SCM_NIMP test. + 2001-06-30 Dirk Herrmann * list.c (SCM_I_CONS): Make sure the cell type is initialized diff --git a/libguile/unif.c b/libguile/unif.c index 6feb7e6d6..ac229538b 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1267,7 +1267,6 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, { long pos = 0; - SCM_VALIDATE_REST_ARGUMENT (args); SCM_ASRTGO (SCM_NIMP (v), badarg1); if (SCM_ARRAYP (v)) { @@ -1277,10 +1276,9 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, else { unsigned long int length; - if (SCM_NIMP (args)) + if (SCM_CONSP (args)) { - SCM_ASSERT (SCM_CONSP(args) && SCM_INUMP (SCM_CAR (args)), args, - SCM_ARG3, FUNC_NAME); + SCM_ASSERT (SCM_INUMP (SCM_CAR (args)), args, SCM_ARG3, FUNC_NAME); SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna); pos = SCM_INUM (SCM_CAR (args)); } From 0e3817d7d8465cbeb5f94229a3bbff21556800ef Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 30 Jun 2001 19:59:51 +0000 Subject: [PATCH 1428/2047] * Added a missing module import. --- test-suite/ChangeLog | 4 ++++ test-suite/guile-test | 3 ++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index ef4440c55..3bd320890 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2001-06-30 Dirk Herrmann + + * guile-test: Use module (ice-9 rdelim). + 2001-06-27 Martin Grabmueller * tests/srfi-4.test: New file. diff --git a/test-suite/guile-test b/test-suite/guile-test index 362938a9d..4d9819641 100755 --- a/test-suite/guile-test +++ b/test-suite/guile-test @@ -81,7 +81,8 @@ (use-modules (test-suite lib) (ice-9 getopt-long) - (ice-9 and-let-star)) + (ice-9 and-let-star) + (ice-9 rdelim)) ;;; Variables that will receive their actual values later. From bdd2c6f4f4de5685eafa4f7ded30e6ff95afc772 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 30 Jun 2001 20:03:14 +0000 Subject: [PATCH 1429/2047] * Added some simple goops test for a beginning. --- test-suite/ChangeLog | 4 ++ test-suite/tests/goops.test | 73 ++++++++++++++++++++++++++++++++++++- 2 files changed, 76 insertions(+), 1 deletion(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 3bd320890..12be6b2e2 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2001-06-30 Dirk Herrmann + + * tests/goops.test: Started with some real tests. + 2001-06-30 Dirk Herrmann * guile-test: Use module (ice-9 rdelim). diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test index c5d5984d2..9705b19bc 100644 --- a/test-suite/tests/goops.test +++ b/test-suite/tests/goops.test @@ -1,6 +1,6 @@ ;;;; goops.test --- test suite for GOOPS -*- scheme -*- ;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 2001 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 @@ -27,3 +27,74 @@ (use-modules (oop goops)) ;;; more tests here... + +(with-test-prefix "basic classes" + + (with-test-prefix "" + + (pass-if "instance?" + (instance? )) + + (pass-if "class-of" + (eq? (class-of ) )) + + (pass-if "is a class?" + (is-a? )) + + (pass-if "class-name" + (eq? (class-name ) ')) + + (pass-if "direct superclasses" + (equal? (class-direct-supers ) '())) + + (pass-if "superclasses" + (equal? (class-precedence-list ) (list ))) + + (pass-if "direct slots" + (equal? (class-direct-slots ) '())) + + (pass-if "slots" + (equal? (class-slots ) '()))) + + (with-test-prefix "" + + (pass-if "instance?" + (instance? )) + + (pass-if "class-of" + (eq? (class-of ) )) + + (pass-if "is a class?" + (is-a? )) + + (pass-if "class-name" + (eq? (class-name ) ')) + + (pass-if "direct superclasses" + (equal? (class-direct-supers ) (list ))) + + (pass-if "superclasses" + (equal? (class-precedence-list ) (list ))) + + (pass-if "direct slots" + (equal? (class-direct-slots ) '())) + + (pass-if "slots" + (equal? (class-slots ) '()))) + + (with-test-prefix "" + + (pass-if "instance?" + (instance? )) + + (pass-if "class-of" + (eq? (class-of ) )) + + (pass-if "is a class?" + (is-a? )) + + (pass-if "class-name" + (eq? (class-name ) ')) + + (pass-if "direct superclass" + (equal? (class-direct-supers ) (list ))))) From 71c9d8eb3bc2e915c529df045af2cab02f332af3 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 1 Jul 2001 11:57:56 +0000 Subject: [PATCH 1430/2047] (scm_read_0str, scm_eval_0str): Call scm_c_read_string and scm_c_eval_string respectively, not themselves. Thanks to Dale P. Smith! --- libguile/strports.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/strports.c b/libguile/strports.c index 7509473ca..17dd64c67 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -460,7 +460,7 @@ scm_read_0str (char *expr) scm_c_issue_deprecation_warning ("scm_read_0str is deprecated. Use scm_c_read_string instead."); - return scm_read_0str (expr); + return scm_c_read_string (expr); } SCM @@ -469,7 +469,7 @@ scm_eval_0str (const char *expr) scm_c_issue_deprecation_warning ("scm_eval_0str is deprecated. Use scm_c_eval_string instead."); - return scm_eval_0str (expr); + return scm_c_eval_string (expr); } #endif From 0d0560d04abe9d44d8f2d1a30fcf4876794ffe82 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 1 Jul 2001 11:58:22 +0000 Subject: [PATCH 1431/2047] *** empty log message *** --- libguile/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 001d2495d..9a835374c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2001-07-01 Marius Vollmer + + * strports.c (scm_read_0str, scm_eval_0str): Call + scm_c_read_string and scm_c_eval_string respectively, not + themselves. Thanks to Dale P. Smith! + 2001-06-30 Dirk Herrmann * unif.c (scm_array_set_x): The variable args does not From cef248dd6161db86a8e1997dd75b7c0f04261ea4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 2 Jul 2001 17:50:28 +0000 Subject: [PATCH 1432/2047] * srfi-1.scm: Replaced calls to `map' in several procedures to calls to `map1'. (map, for-each): New procedures, extended from R5RS. --- srfi/ChangeLog | 6 +++ srfi/srfi-1.scm | 109 +++++++++++++++++++++++++++++++++--------------- 2 files changed, 82 insertions(+), 33 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 4f56cc6dd..ca097e012 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,9 @@ +2001-07-02 Martin Grabmueller + + * srfi-1.scm: Replaced calls to `map' in several procedures to + calls to `map1'. + (map, for-each): New procedures, extended from R5RS. + 2001-06-28 Martin Grabmueller * srfi-4.c: Minor cleanups. diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm index 1b2b1cab0..f0ef31055 100644 --- a/srfi/srfi-1.scm +++ b/srfi/srfi-1.scm @@ -164,8 +164,8 @@ reduce-right unfold unfold-right - ;; map <= in the core - ;; for-each <= in the core + map + for-each append-map append-map! map! @@ -471,20 +471,20 @@ (let lp ((l (cons clist1 rest)) (acc '())) (if (any null? l) (reverse! acc) - (lp (map cdr l) (cons (map car l) acc))))) + (lp (map1 cdr l) (cons (map1 car l) acc))))) (define (unzip1 l) - (map first l)) + (map1 first l)) (define (unzip2 l) - (values (map first l) (map second l))) + (values (map1 first l) (map1 second l))) (define (unzip3 l) - (values (map first l) (map second l) (map third l))) + (values (map1 first l) (map1 second l) (map1 third l))) (define (unzip4 l) - (values (map first l) (map second l) (map third l) (map fourth l))) + (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l))) (define (unzip5 l) - (values (map first l) (map second l) (map third l) (map fourth l) - (map fifth l))) + (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l) + (map1 fifth l))) (define (count pred clist1 . rest) (if (null? rest) @@ -493,9 +493,9 @@ (cond ((any1 null? lists) 0) (else - (if (apply pred (map car lists)) - (+ 1 (lp (map cdr lists))) - (lp (map cdr lists)))))))) + (if (apply pred (map1 car lists)) + (+ 1 (lp (map1 cdr lists))) + (lp (map1 cdr lists)))))))) (define (count1 pred clist) (if (null? clist) @@ -515,8 +515,8 @@ (let f ((knil knil) (lists (cons list1 rest))) (if (any null? lists) knil - (let ((cars (map car lists)) - (cdrs (map cdr lists))) + (let ((cars (map1 car lists)) + (cdrs (map1 cdr lists))) (f (apply kons (append! cars (list knil))) cdrs)))))) (define (fold-right kons knil clist1 . rest) @@ -528,7 +528,7 @@ (let f ((lists (cons clist1 rest))) (if (any null? lists) knil - (apply kons (append! (map car lists) (list (f (map cdr lists))))))))) + (apply kons (append! (map1 car lists) (list (f (map1 cdr lists))))))))) (define (pair-fold kons knil clist1 . rest) (if (null? rest) @@ -540,7 +540,7 @@ (let f ((knil knil) (lists (cons clist1 rest))) (if (any null? lists) knil - (let ((tails (map cdr lists))) + (let ((tails (map1 cdr lists))) (f (apply kons (append! lists (list knil))) tails)))))) @@ -553,7 +553,7 @@ (let f ((lists (cons clist1 rest))) (if (any null? lists) knil - (apply kons (append! lists (list (f (map cdr lists))))))))) + (apply kons (append! lists (list (f (map1 cdr lists))))))))) (define (unfold p f g seed . rest) (let ((tail-gen (if (pair? rest) @@ -587,6 +587,48 @@ (define (reduce-right f ridentity lst) (fold-right f ridentity lst)) + +;; Internal helper procedure. Map `f' over the single list `ls'. +;; +(define (map1 f ls) + (let lp ((l ls)) + (if (null? l) + '() + (cons (f (car l)) (lp (cdr l)))))) + +;; This `map' is extended from the standard `map'. It allows argument +;; lists of different length, so that the shortest list determines the +;; number of elements processed. +;; +(define (map f list1 . rest) + (if (null? rest) + (map1 f list1) + (let lp ((l (cons list1 rest))) + (if (any1 null? l) + '() + (cons (apply f (map1 car l)) (lp (map1 cdr l))))))) + + +;; This `for-each' is extended from the standard `for-each'. It +;; allows argument lists of different length, so that the shortest +;; list determines the number of elements processed. +;; +(define (for-each f list1 . rest) + (if (null? rest) + (let lp ((l list1)) + (if (null? l) + (if #f #f) ; Return unspecified value. + (begin + (f (car l)) + (lp (cdr l))))) + (let lp ((l (cons list1 rest))) + (if (any1 null? l) + (if #f #f) + (begin + (apply f (map1 car l)) + (lp (map1 cdr l))))))) + + (define (append-map f clist1 . rest) (if (null? rest) (let lp ((l clist1)) @@ -596,7 +638,8 @@ (let lp ((l (cons clist1 rest))) (if (any1 null? l) '() - (append (apply f (map car l)) (lp (map cdr l))))))) + (append (apply f (map1 car l)) (lp (map1 cdr l))))))) + (define (append-map! f clist1 . rest) (if (null? rest) @@ -607,7 +650,7 @@ (let lp ((l (cons clist1 rest))) (if (any1 null? l) '() - (append! (apply f (map car l)) (lp (map cdr l))))))) + (append! (apply f (map1 car l)) (lp (map1 cdr l))))))) (define (map! f list1 . rest) (if (null? rest) @@ -622,8 +665,8 @@ (if (any1 null? l) '() (begin - (set-car! res (apply f (map car l))) - (set-cdr! res (lp (map cdr l) (cdr res))) + (set-car! res (apply f (map1 car l))) + (set-cdr! res (lp (map1 cdr l) (cdr res))) res))))) (define (pair-for-each f clist1 . rest) @@ -639,7 +682,7 @@ (if #f #f) (begin (apply f l) - (lp (map cdr l))))))) + (lp (map1 cdr l))))))) (define (filter-map f clist1 . rest) (if (null? rest) @@ -653,10 +696,10 @@ (let lp ((l (cons clist1 rest))) (if (any1 null? l) '() - (let ((res (apply f (map car l)))) + (let ((res (apply f (map1 car l)))) (if res - (cons res (lp (map cdr l))) - (lp (map cdr l)))))))) + (cons res (lp (map1 cdr l))) + (lp (map1 cdr l)))))))) ;;; Filtering & partitioning @@ -753,10 +796,10 @@ (let lp ((lists (cons ls lists))) (cond ((any1 null? lists) #f) - ((any1 null? (map cdr lists)) - (apply pred (map car lists))) + ((any1 null? (map1 cdr lists)) + (apply pred (map1 car lists))) (else - (or (apply pred (map car lists)) (lp (map cdr lists)))))))) + (or (apply pred (map1 car lists)) (lp (map1 cdr lists)))))))) (define (any1 pred ls) (let lp ((ls ls)) @@ -773,10 +816,10 @@ (let lp ((lists (cons ls lists))) (cond ((any1 null? lists) #t) - ((any1 null? (map cdr lists)) - (apply pred (map car lists))) + ((any1 null? (map1 cdr lists)) + (apply pred (map1 car lists))) (else - (and (apply pred (map car lists)) (lp (map cdr lists)))))))) + (and (apply pred (map1 car lists)) (lp (map1 cdr lists)))))))) (define (every1 pred ls) (let lp ((ls ls)) @@ -798,9 +841,9 @@ (let lp ((lists (cons clist1 rest)) (i 0)) (cond ((any1 null? lists) #f) - ((apply pred (map car lists)) i) + ((apply pred (map1 car lists)) i) (else - (lp (map cdr lists) (+ i 1))))))) + (lp (map1 cdr lists) (+ i 1))))))) (define (member x list . rest) (let ((l= (if (pair? rest) (car rest) equal?))) From 166882e16b427309838da365e898f69292fea43b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 2 Jul 2001 17:52:43 +0000 Subject: [PATCH 1433/2047] * srfi-modules.texi (SRFI-1 Fold and Map): Documented extended versions of `map' and `for-each'. --- doc/ChangeLog | 5 + doc/srfi-modules.texi | 2222 ----------------------------------------- 2 files changed, 5 insertions(+), 2222 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index b77bed64b..bafa78884 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,8 @@ +2001-07-02 Martin Grabmueller + + * srfi-modules.texi (SRFI-1 Fold and Map): Documented extended + versions of `map' and `for-each'. + 2001-06-30 Martin Grabmueller * preface.texi (Manual Conventions): Added description of diff --git a/doc/srfi-modules.texi b/doc/srfi-modules.texi index a0ee14602..e69de29bb 100644 --- a/doc/srfi-modules.texi +++ b/doc/srfi-modules.texi @@ -1,2222 +0,0 @@ -@page -@node SRFI Support -@chapter SRFI Support Modules - -SRFI is an acronym for Scheme Request For Implementation. The SRFI -documents define a lot of syntactic and procedure extensions to standard -Scheme as defined in R5RS. - -Guile has support for a number of SRFIs. This chapter gives an overview -over the available SRFIs and some usage hints. For complete -documentation, design rationales and further examples, we advise you to -get the relevant SRFI documents from the SRFI home page -@url{http://srfi.schemers.org}. - -@menu -* About SRFI Usage:: What to know about Guile's SRFI support. -* SRFI-0:: cond-expand -* SRFI-1:: List library. -* SRFI-2:: and-let*. -* SRFI-4:: Homogeneous numeric vector datatypes. -* SRFI-6:: Basic String Ports. -* SRFI-8:: receive. -* SRFI-9:: define-record-type. -* SRFI-10:: Hash-Comma Reader Extension. -* SRFI-11:: let-values and let-values*. -* SRFI-13:: String library. -* SRFI-14:: Character-set library. -* SRFI-16:: case-lambda -* SRFI-17:: Generalized set! -@end menu - - -@node About SRFI Usage -@section About SRFI Usage - -@c FIXME::martin: Review me! - -SRFI support in Guile is currently implemented partly in the core -library, and partly as add-on modules. That means that some SRFIs are -automatically available when the interpreter is started, whereas the -other SRFIs require you to use the appropriate support module -explicitly. - -There are several reasons for this inconsistency. First, the feature -checking syntactic form @code{cond-expand} (@pxref{SRFI-0}) must be -available immediately, because it must be there when the user wants to -check for the Scheme implementation, that is, before she can know that -it is safe to use @code{use-modules} to load SRFI support modules. The -second reason is that some features defined in SRFIs had been -implemented in Guile before the developers started to add SRFI -implementations as modules (for example SRFI-6 (@pxref{SRFI-6})). In -the future, it is possible that SRFIs in the core library might be -factored out into separate modules, requiring explicit module loading -when they are needed. So you should be prepared to have to use -@code{use-modules} someday in the future to access SRFI-6 bindings. If -you want, you can do that already. We have included the module -@code{(srfi srfi-6)} in the distribution, which currently does nothing, -but ensures that you can write future-safe code. - -Generally, support for a specific SRFI is made available by using -modules named @code{(srfi srfi-@var{number})}, where @var{number} is the -number of the SRFI needed. Another possibility is to use the command -line option @code{--use-srfi}, which will load the necessary modules -automatically (@pxref{Invoking Guile}). - - -@node SRFI-0 -@section SRFI-0 - cond-expand - -@c FIXME::martin: Review me! - -SRFI-0 defines a means for checking whether a Scheme implementation has -support for a specified feature. The syntactic form @code{cond-expand}, -which implements this means, has the following syntax. - -@example -@group - - --> (cond-expand +) - | (cond-expand * (else )) - - --> ( *) - - --> - | (and *) - | (or *) - | (not ) - - --> -@end group -@end example - -When evaluated, this form checks all clauses in order, until it finds -one whose feature requirement is satisfied. Then the form expands into -the commands or definitions in the clause. A requirement is tested as -follows: - -@itemize @bullet -@item -If it is a symbol, it is satisfied if the feature identifier is -supported. - -@item -If it is an @code{and} form, all requirements must be satisfied. If no -requirements are given, it is satisfied, too. - -@item -If it is an @code{or} form, at least one of the requirements must be -satisfied. If no requirements are given, it is not satisfied. - -@item -If it is a @code{not} form, the feature requirement must @emph{not} be -satisfied. - -@item -If the feature requirement is the keyword @code{else} and it is the last -clause, it is satisfied if no prior clause matched. -@end itemize - -If no clause is satisfied, an error is signalled. - -Since @code{cond-expand} is needed to tell what a Scheme implementation -provides, it must be accessible without using any -implementation-dependant operations, such as @code{use-modules} in -Guile. Thus, it is not necessary to use any module to get access to -this form. - -Currently, the feature identifiers @code{guile}, @code{r5rs} and -@code{srfi-0} are supported. The other SRFIs are not in that list by -default, because the SRFI modules must be explicitly used before their -exported bindings can be used. - -So if a Scheme program wishes to use SRFI-8, it has two possibilities: -First, it can check whether the running Scheme implementation is Guile, -and if it is, it can use the appropriate module: - -@lisp -(cond-expand - (guile - (use-modules (srfi srfi-8))) - (srfi-8 - #t)) - ;; otherwise fail. -@end lisp - -The other possibility is to use the @code{--use-srfi} command line -option when invoking Guile (@pxref{Invoking Guile}). When you do that, -the specified SRFI support modules will be loaded and add their feature -identifier to the list of symbols checked by @code{cond-expand}. - -So, if you invoke Guile like this: - -@example -$ guile --use-srfi=8 -@end example - -the following snippet will expand to @code{'hooray}. - -@lisp -(cond-expand (srfi-8 'hooray)) -@end lisp - - -@node SRFI-1 -@section SRFI-1 - List library - -@c FIXME::martin: Review me! - -The list library defined in SRFI-1 contains a lot of useful list -processing procedures for construction, examining, destructuring and -manipulating lists and pairs. - -Since SRFI-1 also defines some procedures which are already contained -in R5RS and thus are supported by the Guile core library, some list -and pair procedures which appear in the SRFI-1 document may not appear -in this section. So when looking for a particular list/pair -processing procedure, you should also have a look at the sections -@ref{Lists} and @ref{Pairs}. - -@menu -* SRFI-1 Constructors:: Constructing new lists. -* SRFI-1 Predicates:: Testing list for specific properties. -* SRFI-1 Selectors:: Selecting elements from lists. -* SRFI-1 Length Append etc:: Length calculation and list appending. -* SRFI-1 Fold and Map:: Higher-order list processing. -* SRFI-1 Filtering and Partitioning:: Filter lists based on predicates. -* SRFI-1 Searching:: Search for elments. -* SRFI-1 Deleting:: Delete elements from lists. -* SRFI-1 Association Lists:: Handle association lists. -* SRFI-1 Set Operations:: Use lists for representing sets. -@end menu - -@node SRFI-1 Constructors -@subsection Constructors - -@c FIXME::martin: Review me! - -New lists can be constructed by calling one of the following -procedures. - -@deffn procedure xcons d a -Like @code{cons}, but with interchanged arguments. Useful mostly when -passed to higher-order procedures. -@end deffn - -@deffn procedure list-tabulate n init-proc -Return an @var{n}-element list, where each list element is produced by -applying the procedure @var{init-proc} to the corresponding list -index. The order in which @var{init-proc} is applied to the indices -is not specified. -@end deffn - -@deffn procedure circular-list elt1 elt2 @dots{} -Return a circular list containing the given arguments @var{elt1} -@var{elt2} @dots{}. -@end deffn - -@deffn procedure iota count [start step] -Return a list containing @var{count} elements, where each element is -calculated as follows: - -@var{start} + (@var{count} - 1) * @var{step} - -@var{start} defaults to 0 and @var{step} defaults to 1. -@end deffn - - -@node SRFI-1 Predicates -@subsection Predicates - -@c FIXME::martin: Review me! - -The procedures in this section test specific properties of lists. - -@deffn procedure proper-list? obj -Return @code{#t} if @var{obj} is a proper list, that is a finite list, -terminated with the empty list. Otherwise, return @code{#f}. -@end deffn - -@deffn procedure circular-list? obj -Return @code{#t} if @var{obj} is a circular list, otherwise return -@code{#f}. -@end deffn - -@deffn procedure dotted-list? obj -Return @code{#t} if @var{obj} is a dotted list, return @code{#f} -otherwise. A dotted list is a finite list which is not terminated by -the empty list, but some other value. -@end deffn - -@deffn procedure null-list? lst -Return @code{#t} if @var{lst} is the empty list @code{()}, @code{#f} -otherwise. If something else than a proper or circular list is passed -as @var{lst}, an error is signalled. This procedure is recommented -for checking for the end of a list in contexts where dotted lists are -not allowed. -@end deffn - -@deffn procedure not-pair? obj -Return @code{#t} is @var{obj} is not a pair, @code{#f} otherwise. -This is shorthand notation @code{(not (pair? @var{obj}))} and is -supposed to be used for end-of-list checking in contexts where dotted -lists are allowed. -@end deffn - -@deffn procedure list= elt= list1 @dots{} -Return @code{#t} if all argument lists are equal, @code{#f} otherwise. -List equality is determined by testing whether all lists have the same -length and the corresponding elements are equal in the sense of the -equality predicate @var{elt=}. If no or only one list is given, -@code{#t} is returned. -@end deffn - - -@node SRFI-1 Selectors -@subsection Selectors - -@c FIXME::martin: Review me! - -@deffn procedure first pair -@deffnx procedure second pair -@deffnx procedure third pair -@deffnx procedure fourth pair -@deffnx procedure fifth pair -@deffnx procedure sixth pair -@deffnx procedure seventh pair -@deffnx procedure eighth pair -@deffnx procedure ninth pair -@deffnx procedure tenth pair -These are synonyms for @code{car}, @code{cadr}, @code{caddr}, @dots{}. -@end deffn - -@deffn procedure car+cdr pair -Return two values, the @sc{car} and the @sc{cdr} of @var{pair}. -@end deffn - -@deffn procedure take lst i -@deffnx procedure take! lst i -Return a list containing the first @var{i} elements of @var{lst}. - -@code{take!} may modify the structure of the argument list @var{lst} -in order to produce the result. -@end deffn - -@deffn procedure drop lst i -Return a list containing all but the first @var{i} elements of -@var{lst}. -@end deffn - -@deffn procedure take-right lst i -Return the a list containing the @var{i} last elements of @var{lst}. -@end deffn - -@deffn procedure drop-right lst i -@deffnx procedure drop-right! lst i -Return the a list containing all but the @var{i} last elements of -@var{lst}. - -@code{drop-right!} may modify the structure of the argument list -@var{lst} in order to produce the result. -@end deffn - -@deffn procedure split-at lst i -@deffnx procedure split-at! lst i -Return two values, a list containing the first @var{i} elements of the -list @var{lst} and a list containing the remaining elements. - -@code{split-at!} may modify the structure of the argument list -@var{lst} in order to produce the result. -@end deffn - -@deffn procedure last lst -Return the last element of the non-empty, finite list @var{lst}. -@end deffn - - -@node SRFI-1 Length Append etc -@subsection Length, Append, Concatenate, etc. - -@c FIXME::martin: Review me! - -@deffn procedure length+ lst -Return the length of the argument list @var{lst}. When @var{lst} is a -circular list, @code{#f} is returned. -@end deffn - -@deffn procedure concatenate list-of-lists -@deffnx procedure concatenate! list-of-lists -Construct a list by appending all lists in @var{list-of-lists}. - -@code{concatenate!} may modify the structure of the given lists in -order to produce the result. -@end deffn - -@deffn procedure append-reverse rev-head tail -@deffnx procedure append-reverse! rev-head tail -Reverse @var{rev-head}, append @var{tail} and return the result. This -is equivalent to @code{(append (reverse @var{rev-head}) @var{tail})}, -but more efficient. - -@code{append-reverse!} may modify @var{rev-head} in order to produce -the result. -@end deffn - -@deffn procedure zip lst1 lst2 @dots{} -Return a list as long as the shortest of the argument lists, where -each element is a list. The first list contains the first elements of -the argument lists, the second list contains the second elements, and -so on. -@end deffn - -@deffn procedure unzip1 lst -@deffnx procedure unzip2 lst -@deffnx procedure unzip3 lst -@deffnx procedure unzip4 lst -@deffnx procedure unzip5 lst -@code{unzip1} takes a list of lists, and returns a list containing the -first elements of each list, @code{unzip2} returns two lists, the -first containing the first elements of each lists and the second -containing the second elements of each lists, and so on. -@end deffn - - -@node SRFI-1 Fold and Map -@subsection Fold, Unfold & Map - -@c FIXME::martin: Review me! - -@deffn procedure fold kons knil lst1 lst2 @dots{} -Fold the procedure @var{kons} across all elements of @var{lst1}, -@var{lst2}, @dots{}. Produce the result of - -@code{(@var{kons} @var{en1} @var{en2} @dots{} (@var{kons} @var{e21} -@var{e22} (@var{kons} @var{e11} @var{e12} @var{knil})))}, - -if @var{enm} are the elements of the lists @var{lst1}, @var{lst2}, -@dots{}. -@end deffn - -@deffn procedure fold-right kons knil lst1 lst2 @dots{} -Similar to @code{fold}, but applies @var{kons} in right-to-left order -to the list elements, that is: - -@code{(@var{kons} @var{e11} @var{e12}(@var{kons} @var{e21} -@var{e22} @dots{} (@var{kons} @var{en1} @var{en2} @var{knil})))}, -@end deffn - -@deffn procedure pair-fold kons knil lst1 lst2 @dots{} -Like @code{fold}, but apply @var{kons} to the pairs of the list -instead of the list elements. -@end deffn - -@deffn procedure pair-fold-right kons knil lst1 lst2 @dots{} -Like @code{fold-right}, but apply @var{kons} to the pairs of the list -instead of the list elements. -@end deffn - -@deffn procedure reduce f ridentity lst -@code{reduce} is a variant of @code{reduce}. If @var{lst} is -@code{()}, @var{ridentity} is returned. Otherwise, @code{(fold (car -@var{lst}) (cdr @var{lst}))} is returned. -@end deffn - -@deffn procedure reduce-right f ridentity lst -This is the @code{fold-right} variant of @var{reduce}. -@end deffn - -@deffn procedure unfold p f g seed [tail-gen] -@code{unfold} is defined as follows: - -@lisp -(unfold p f g seed) = - (if (p seed) (tail-gen seed) - (cons (f seed) - (unfold p f g (g seed)))) -@end lisp - -@table @var -@item p -Determines when to stop unfolding. - -@item f -Maps each seed value to the corresponding list element. - -@item g -Maps each seed value to next seed valu. - -@item seed -The state value for the unfold. - -@item tail-gen -Creates the tail of the list; defaults to @code{(lambda (x) '())}. -@end table - -@var{g} produces a series of seed values, which are mapped to list -elements by @var{f}. These elements are put into a list in -left-to-right order, and @var{p} tells when to stop unfolding. -@end deffn - -@deffn procedure unfold-right p f g seed [tail] -Construct a list with the following loop. - -@lisp -(let lp ((seed seed) (lis tail)) - (if (p seed) lis - (lp (g seed) - (cons (f seed) lis)))) -@end lisp - -@table @var -@item p -Determines when to stop unfolding. - -@item f -Maps each seed value to the corresponding list element. - -@item g -Maps each seed value to next seed valu. - -@item seed -The state value for the unfold. - -@item tail-gen -Creates the tail of the list; defaults to @code{(lambda (x) '())}. -@end table - -@end deffn - -@deffn procedure append-map f lst1 lst2 @dots{} -@deffnx procedure append-map! f lst1 lst2 @dots{} -Equivalent to - -@lisp -(apply append (map f clist1 clist2 ...)) -@end lisp - -and - -@lisp -(apply append! (map f clist1 clist2 ...)) -@end lisp - -Map @var{f} over the elements of the lists, just as in the @code{map} -function. However, the results of the applications are appended -together to make the final result. @code{append-map} uses -@code{append} to append the results together; @code{append-map!} uses -@code{append!}. - -The dynamic order in which the various applications of @var{f} are -made is not specified. -@end deffn - -@deffn procedure map! f lst1 lst2 @dots{} -Linear-update variant of @code{map} -- @code{map!} is allowed, but not -required, to alter the cons cells of @var{lst1} to construct the -result list. - -The dynamic order in which the various applications of @var{f} are -made is not specified. In the n-ary case, @var{lst2}, @var{lst3}, -@dots{} must have at least as many elements as @var{lst1}. -@end deffn - -@deffn procedure pair-for-each f lst1 lst2 @dots{} -Like @code{for-each}, but applies the procedure @var{f} to the pairs -from which the argument lists are constructed, instead of the list -elements. The return value is not specified. -@end deffn - -@deffn procedure filter-map f lst1 lst2 @dots{} -Like @code{map}, but only results from the applications of @var{f} -which are true are saved in the result list. -@end deffn - - -@node SRFI-1 Filtering and Partitioning -@subsection Filtering and Partitioning - -@c FIXME::martin: Review me! - -Filtering means to collect all elements from a list which satisfy a -specific condition. Partitioning a list means to make two groups of -list elements, one which contains the elements satisfying a condition, -and the other for the elements which don't. - -@deffn procedure filter pred lst -@deffnx procedure filter! pred lst -Return a list containing all elements from @var{lst} which satisfy the -predicate @var{pred}. The elements in the result list have the same -order as in @var{lst}. The order in which @var{pred} is applied to -the list elements is not specified. - -@code{filter!} is allowed, but not required to modify the structure of -@end deffn - -@deffn procedure partition pred lst -@deffnx procedure partition! pred lst -Return two lists, one containing all elements from @var{lst} which -satisfy the predicate @var{pred}, and one list containing the elements -which do not satisfy the predicated. The elements in the result lists -have the same order as in @var{lst}. The order in which @var{pred} is -applied to the list elements is not specified. - -@code{partition!} is allowed, but not required to modify the structure of -the input list. -@end deffn - -@deffn procedure remove pred lst -@deffnx procedure remove! pred lst -Return a list containing all elements from @var{lst} which do not -satisfy the predicate @var{pred}. The elements in the result list -have the same order as in @var{lst}. The order in which @var{pred} is -applied to the list elements is not specified. - -@code{remove!} is allowed, but not required to modify the structure of -the input list. -@end deffn - - -@node SRFI-1 Searching -@subsection Searching - -@c FIXME::martin: Review me! - -The procedures for searching elements in lists either accept a -predicate or a comparison object for determining which elements are to -be searched. - -@deffn procedure find pred lst -Return the first element of @var{lst} which satisfies the predicate -@var{pred} and @code{#f} if no such element is found. -@end deffn - -@deffn procedure find-tail pred lst -Return the first pair of @var{lst} whose @sc{car} satisfies the -predicate @var{pred} and @code{#f} if no such element is found. -@end deffn - -@deffn procedure take-while pred lst -@deffnx procedure take-while! pred lst -Return the longest initial prefix of @var{lst} whose elements all -satisfy the predicate @var{pred}. - -@code{take-while!} is allowed, but not required to modify the input -list while producing the result. -@end deffn - -@deffn procedure drop-while pred lst -Drop the longest initial prefix of @var{lst} whose elements all -satisfy the predicate @var{pred}. -@end deffn - -@deffn procedure span pred lst -@deffnx procedure span! pred lst -@deffnx procedure break pred lst -@deffnx procedure break! pred lst -@code{span} splits the list @var{lst} into the longest initial prefix -whose elements all satisfy the predicate @var{pred}, and the remaining -tail. @code{break} inverts the sense of the predicate. - -@code{span!} and @code{break!} are allowed, but not required to modify -the structure of the input list @var{lst} in order to produce the -result. -@end deffn - -@deffn procedure any pred lst1 lst2 @dots{} -Apply @var{pred} across the lists and return a true value if the -predicate returns true for any of the list elements(s); return -@code{#f} otherwise. The true value returned is always the result of -the first succesful application of @var{pred}. -@end deffn - -@deffn procedure every pred lst1 lst2 @dots{} -Apply @var{pred} across the lists and return a true value if the -predicate returns true for every of the list elements(s); return -@code{#f} otherwise. The true value returned is always the result of -the final succesful application of @var{pred}. -@end deffn - -@deffn procedure list-index pred lst1 lst2 @dots{} -Return the index of the leftmost element that satisfies @var{pred}. -@end deffn - -@deffn procedure member x lst [=] -Return the first sublist of @var{lst} whose @sc{car} is equal to -@var{x}. If @var{x} does no appear in @var{lst}, return @code{#f}. -Equality is determined by the equality predicate @var{=}, or -@code{equal?} if @var{=} is not given. -@end deffn - - -@node SRFI-1 Deleting -@subsection Deleting - -@c FIXME::martin: Review me! - -The procedures for deleting elements from a list either accept a -predicate or a comparison object for determining which elements are to -be removed. - -@deffn procedure delete x lst [=] -@deffnx procedure delete! x lst [=] -Return a list containing all elements from @var{lst}, but without the -elements equal to @var{x}. Equality is determined by the equality -predicate @var{=}, which defaults to @code{equal?} if not given. - -@code{delete!} is allowed, but not required to modify the structure of -the argument list in order to produce the result. -@end deffn - -@deffn procedure delete-duplicates lst [=] -@deffnx procedure delete-duplicates! lst [=] -Return a list containing all elements from @var{lst}, but without -duplicate elements. Equality of elements is determined by the -equality predicate @var{=}, which defaults to @code{equal?} if not -given. - -@code{delete-duplicates!} is allowed, but not required to modify the -structure of the argument list in order to produce the result. -@end deffn - - -@node SRFI-1 Association Lists -@subsection Association Lists - -@c FIXME::martin: Review me! - -Association lists are described in detail in section @ref{Association -Lists}. The present section only documents the additional procedures -for dealing with association lists defined by SRFI-1. - -@deffn procedure assoc key alist [=] -Return the pair from @var{alist} which matches @var{key}. Equality is -determined by @var{=}, which defaults to @code{equal?} if not given. -@var{alist} must be an association lists---a list of pairs. -@end deffn - -@deffn procedure alist-cons key datum alist -Equivalent to - -@lisp -(cons (cons @var{key} @var{datum}) @var{alist}) -@end lisp - -This procedure is used to coons a new pair onto an existing -association list. -@end deffn - -@deffn procedure alist-copy alist -Return a newly allocated copy of @var{alist}, that means that the -spine of the list as well as the pairs are copied. -@end deffn - -@deffn procedure alist-delete key alist [=] -@deffnx 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. - -@code{alist-delete!} is allowed, but not required to modify the -structure of the list @var{alist} in order to produce the result. -@end deffn - - -@node SRFI-1 Set Operations -@subsection Set Operations on Lists - -@c FIXME::martin: Review me! - -Lists can be used for representing sets of objects. The procedures -documented in this section can be used for such set representations. -Man combinding several sets or adding elements, they make sure that no -object is contained more than once in a given list. Please note that -lists are not a too efficient implementation method for sets, so if -you need high performance, you should think about implementing a -custom data structure for representing sets, such as trees, bitsets, -hash tables or something similar. - -All these procedures accept an equality predicate as the first -argument. This predicate is used for testing the objects in the list -sets for sameness. - -@deffn procedure lset<= = list1 @dots{} -Return @code{#t} if every @var{listi} is a subset of @var{listi+1}, -otherwise return @code{#f}. Returns @code{#t} if called with less -than two arguments. @var{=} is used for testing element equality. -@end deffn - -@deffn procedure lset= = list1 list2 @dots{} -Return @code{#t} if all argument lists are equal. @var{=} is used for -testing element equality. -@end deffn - -@deffn procedure lset-adjoin = list elt1 @dots{} -@deffnx procedure lset-adjoin! = list elt1 @dots{} -Add all @var{elts} to the list @var{list}, suppressing duplicates and -return the resulting list. @code{lset-adjoin!} is allowed, but not -required to modify its first argument. @var{=} is used for testing -element equality. -@end deffn - -@deffn procedure lset-union = list1 @dots{} -@deffnx procedure lset-union! = list1 @dots{} -Return the union of all argument list sets. The union is the set of -all elements which appear in any of the argument sets. -@code{lset-union!} is allowed, but not required to modify its first -argument. @var{=} is used for testing element equality. -@end deffn - -@deffn procedure lset-intersection = list1 list2 @dots{} -@deffnx procedure lset-intersection! = list1 list2 @dots{} -Return the intersection of all argument list sets. The intersection -is the set containing all elements which appear in all argument sets. -@code{lset-intersection!} is allowed, but not required to modify its -first argument. @var{=} is used for testing element equality. -@end deffn - -@deffn procedure lset-difference = list1 list2 @dots{} -@deffnx procedure lset-difference! = list1 list2 @dots{} -Return the difference of all argument list sets. The difference is -the the set containing all elements of the first list which do not -appear in the other lists. @code{lset-difference!} is allowed, but -not required to modify its first argument. @var{=} is used for testing -element equality. -@end deffn - -@deffn procedure lset-xor = list1 @dots{} -@deffnx procedure lset-xor! = list1 @dots{} -Return the set containing all elements which appear in the first -argument list set, but not in the second; or, more generally: which -appear in an odd number of sets. @code{lset-xor!} is allowed, but -not required to modify its first argument. @var{=} is used for testing -element equality. -@end deffn - -@deffn procedure lset-diff+intersection = list1 list2 @dots{} -@deffnx procedure lset-diff+intersection! = list1 list2 @dots{} -Return two values, the difference and the intersection of the argument -list sets. This works like a combination of @code{lset-difference} and -@code{lset-intersection}, but is more efficient. -@code{lset-diff+intersection!} is allowed, but not required to modify -its first argument. @var{=} is used for testing element equality. You -have to use some means to deal with the multiple values these -procedures return (@pxref{Multiple Values}). -@end deffn - - -@node SRFI-2 -@section SRFI-2 - and-let* - -@c FIXME::martin: Review me! - -The syntactic form @code{and-let*} combines the conditional evaluation -form @code{and} with the binding form @var{let*}. Each argument -expression will be evaluated sequentially, bound to a variable (if a -variable name is given), but only as long as no expression returns -the false value @code{#f}. - -Use @code{(use-modules (srfi srfi-2)} to access this syntax form. - -A short example will demonstrate how it works. In the first expression, -@var{x} will get bound to 1, but the next expression (@code{#f}) is -false, so evaluation of the form is stopped, and @code{#f} is returned. -In the next expression, @var{x} is bound to 1, @var{y} is bound to -@code{#t} and since no expression in the binding section was false, the -body of the @code{and-let*} expression is evaluated, which in this case -returns the value of @var{x}. - -@lisp -(and-let* ((x 1) (y #f)) 42) -@result{} -#f -(and-let* ((x 1) (y #t)) x) -@result{} -1 -@end lisp - - -@node SRFI-4 -@section SRFI-4 - Homogeneous numeric vector datatypes. - -@c FIXME::martin: Review me! - -SRFI-4 defines a set of datatypes for vectors whose elements are all -of the same numeric type. Vectors for signed and unsigned exact -integer or inexact real numbers in several precisions are available. - -Procedures similar to the vector procedures (@pxref{Vectors}) are -provided for handling these homogeneous vectors, but they are distinct -datatypes. - -The reason for providing this set of datatypes is that with the -limitation (all elements must have the same type), it is possible to -implement them much more memory-efficient than normal, heterogenous -vectors. - -If you want to use these datatypes and the corresponding procedures, -you have to use the module @code{(srfi srfi-4)}. - -Ten vector data types are provided: Unsigned and signed integer values -with 8, 16, 32 and 64 bits and floating point values with 32 and 64 -bits. In the following descriptions, the tags @code{u8}, @code{s8}, -@code{u16}, @code{s16}, @code{u32}, @code{s32}, @code{u64}, -@code{s64}, @code{f32}, @code{f64}, respectively, are used for -denoting the various types. - -@menu -* SRFI-4 - Read Syntax:: How to write homogeneous vector literals. -* SRFI-4 - Procedures:: Available homogeneous vector procedures. -@end menu - - -@node SRFI-4 - Read Syntax -@subsection SRFI-4 - Read Syntax - -Homogeneous numeric vectors have an external representation (read -syntax) similar to normal Scheme vectors, but with an additional tag -telling the vector's type. - -@lisp -#u16(1 2 3) -@end lisp - -denotes a homogeneous numeric vector of three elements, which are the -values 1, 2 and 3, represented as 16-bit unsigned integers. -Correspondingly, - -@lisp -#f64(3.1415 2.71) -@end lisp - -denotes a vector of two elements, which are the values 3.1415 and -2.71, represented as floating-point values of 64 bit precision. - -Please note that the read syntax for floating-point vectors conflicts -with Standard Scheme, because there @code{#f} is defined to be the -literal false value. That means, that with the loaded SRFI-4 module, -it is not possible to enter some list like - -@lisp -'(1 #f3) -@end lisp - -and hope that it will be parsed as a three-element list with the -elements 1, @code{#f} and 3. In normal use, this should be no -problem, because people tend to terminate tokens sensibly when writing -Scheme expressions. - -@node SRFI-4 - Procedures -@subsection SRFI-4 Procedures - -The procedures listed in this section are provided for all homogeneous -numeric vector datatypes. For brevity, they are not all documented, -but a summary of the procedures is given. In the following -descriptions, you can replace @code{TAG} by any of the datatype -indicators @code{u8}, @code{s8}, @code{u16}, @code{s16}, @code{u32}, -@code{s32}, @code{u64}, @code{s64}, @code{f32} and @code{f64}. - -For example, you can use the procedures @code{u8vector?}, -@code{make-s8vector}, @code{u16vector}, @code{u32vector-length}, -@code{s64vector-ref}, @code{f32vector-set!} or @code{f64vector->list}. - -@deffn primitive TAGvector? obj -Return @code{#t} if @var{obj} is a homogeneous numeric vector of type -@code{TAG}. -@end deffn - -@deffn primitive make-TAGvector n [value] -Create a newly allocated homogeneous numeric vector of type -@code{TAG}, which can hold @var{n} elements. If @var{value} is given, -the vector is initialized with the value, otherwise, the contents of -the returned vector is not specified. -@end deffn - -@deffn primitive TAGvector value1 @dots{} -Create a newly allocated homogeneous numeric vector of type -@code{TAG}. The returned vector is as long as the number of arguments -given, and is initialized with the argument values. -@end deffn - -@deffn primitive TAGvector-length TAGvec -Return the number of elements in @var{TAGvec}. -@end deffn - -@deffn primitive TAGvector-ref TAGvec i -Return the element at index @var{i} in @var{TAGvec}. -@end deffn - -@deffn primitive TAGvector-ref TAGvec i value -Set the element at index @var{i} in @var{TAGvec} to @var{value}. The -return value is not specified. -@end deffn - -@deffn primitive TAGvector->list TAGvec -Return a newly allocated list holding all elements of @var{TAGvec}. -@end deffn - -@deffn primitive list->TAGvector lst -Return a newly allocated homogeneous numeric vector of type @code{TAG}, -initialized with the elements of the list @var{lst}. -@end deffn - - -@node SRFI-6 -@section SRFI-6 - Basic String Ports - -SRFI-6 defines the procedures @code{open-input-string}, -@code{open-output-string} and @code{get-output-string}. These -procedures are included in the Guile core, so using this module does not -make any difference at the moment. But it is possible that support for -SRFI-6 will be factored out of the core library in the future, so using -this module does not hurt, after all. - -@node SRFI-8 -@section SRFI-8 - receive - -@code{receive} is a syntax for making the handling of multiple-value -procedures easier. It is documented in @xref{Multiple Values}. - - -@node SRFI-9 -@section SRFI-9 - define-record-type - -This is the SRFI way for defining record types. The Guile -implementation is a layer above Guile's normal record construction -procedures (@pxref{Records}). The nice thing about this kind of record -definition method is that no new names are implicitly created, all -constructor, accessor and predicates are explicitly given. This reduces -the risk of variable capture. - -The syntax of a record type definition is: - -@example -@group - - -> (define-record-type - ( ...) - - ...) - -> ( ) - -> ( ) - -> -<... name> -> -@end group -@end example - -Usage example: - -@example -guile> (use-modules (srfi srfi-9)) -guile> (define-record-type :foo (make-foo x) foo? - (x get-x) (y get-y set-y!)) -guile> (define f (make-foo 1)) -guile> f -#<:foo x: 1 y: #f> -guile> (get-x f) -1 -guile> (set-y! f 2) -2 -guile> (get-y f) -2 -guile> f -#<:foo x: 1 y: 2> -guile> (foo? f) -#t -guile> (foo? 1) -#f -@end example - - -@node SRFI-10 -@section SRFI-10 - Hash-Comma Reader Extension - -@cindex hash-comma -@cindex #,() -The module @code{(srfi srfi-10)} implements the syntax extension -@code{#,()}, also called hash-comma, which is defined in SRFI-10. - -The support for SRFI-10 consists of the procedure -@code{define-reader-ctor} for defining new reader constructors and the -read syntax form - -@example -#,(@var{ctor} @var{datum} ...) -@end example - -where @var{ctor} must be a symbol for which a read constructor was -defined previouly, using @code{define-reader-ctor}. - -Example: - -@lisp -(define-reader-ctor 'file open-input-file) -(define f '#,(file "/etc/passwd")) -(read-line f) -@result{} -"root:x:0:0:root:/root:/bin/bash" -@end lisp - -Please note the quote before the @code{#,(file ...)} expression. This -is necessary because ports are not self-evaluating in Guile. - -@deffn procedure define-reader-ctor symbol proc -Define @var{proc} as the reader constructor for hash-comma forms with a -tag @var{symbol}. @var{proc} will be applied to the datum(s) following -the tag in the hash-comma expression after the complete form has been -read in. The result of @var{proc} is returned by the Scheme reader. -@end deffn - - -@node SRFI-11 -@section SRFI-11 - let-values - -This module implements the binding forms for multiple values -@code{let-values} and @code{let-values*}. These forms are similar to -@code{let} and @code{let*} (@pxref{Local Bindings}), but they support -binding of the values returned by multiple-valued expressions. - -Write @code{(use-modules (srfi srfi-11))} to make the bindings -available. - -@lisp -(let-values (((x y) (values 1 2)) - ((z f) (values 3 4))) - (+ x y z f)) -@result{} -10 -@end lisp - -@code{let-values} performs all bindings simultaneously, which means that -no expression in the binding clauses may refer to variables bound in the -same clause list. @code{let-values*}, on the other hand, performs the -bindings sequentially, just like @code{let*} does for single-valued -expressions. - - -@node SRFI-13 -@section SRFI-13 - String Library - -In this section, we will describe all procedures defined in SRFI-13 -(string library) and implemented by the module @code{(srfi srfi-13)}. - -Note that only the procedures from SRFI-13 are documented here which are -not already contained in Guile. For procedures not documented here -please refer to the relevant chapters in the Guile Reference Manual, for -example the documentation of strings and string procedures -(@pxref{Strings}). - -All of the procedures defined in SRFI-13, which are not already included -in the Guile core library, are implemented in the module @code{(srfi -srfi-13)}. The procedures which are both in Guile and in SRFI-13, but -which are slightly extended, have been implemented in this module, and -the bindings overwrite those in the Guile core. - -The procedures which are defined in the section @emph{Low-level -procedures} of SRFI-13 for parsing optional string indices, substring -specification checking and Knuth-Morris-Pratt-Searching are not -implemented. - -The procedures @code{string-contains} and @code{string-contains-ci} are -not implemented very efficiently at the moment. This will be changed as -soon as possible. - -@menu -* Loading SRFI-13:: How to load SRFI-13 support. -* SRFI-13 Predicates:: String predicates. -* SRFI-13 Constructors:: String constructing procedures. -* SRFI-13 List/String Conversion:: Conversion from/to lists. -* SRFI-13 Selection:: Selection portions of strings. -* SRFI-13 Modification:: Modfify strings in-place. -* SRFI-13 Comparison:: Compare strings. -* SRFI-13 Prefixes/Suffixes:: Detect common pre-/suffixes. -* SRFI-13 Searching:: Searching for substrings. -* SRFI-13 Case Mapping:: Mapping to lower-/upper-case. -* SRFI-13 Reverse/Append:: Reverse and append strings. -* SRFI-13 Fold/Unfold/Map:: Construct/deconstruct strings. -* SRFI-13 Replicate/Rotate:: Replacate and rotate portions of strings. -* SRFI-13 Miscellaneous:: Left-over string procedures. -* SRFI-13 Filtering/Deleting:: Filter and delete characters from strings. -@end menu - - -@node Loading SRFI-13 -@subsection Loading SRFI-13 - -When Guile is properly installed, SRFI-13 support can be loaded into a -running Guile by using the @code{(srfi srfi-13)} module. - -@example -$ guile -guile> (use-modules (srfi srfi-13)) -guile> -@end example - -When this step causes any errors, Guile is not properly installed. - -One possible reason is that Guile cannot find either the Scheme module -file @file{srfi-13.scm}, or it cannot find the shared object file -@file{libguile-srfi-srfi-13-14.so}. Make sure that the former is in the -Guile load path and that the latter is either installed in some default -location like @file{/usr/local/lib} or that the directory it was -installed to is in your @code{LTDL_LIBRARY_PATH}. The same applies to -@file{srfi-14.scm}. - -Now you can test whether the SRFI-13 procedures are working by calling -the @code{string-concatenate} procedure. - -@example -guile> (string-concatenate '("Hello" " " "World!")) -"Hello World!" -@end example - -@node SRFI-13 Predicates -@subsection Predicates - -In addition to the primitives @code{string?} and @code{string-null?}, -which are already in the Guile core, the string predicates -@code{string-any} and @code{string-every} are defined by SRFI-13. - -@deffn primitive string-any pred s [start end] -Check if the predicate @var{pred} is true for any character in -the string @var{s}, proceeding from left (index @var{start}) to -right (index @var{end}). If @code{string-any} returns true, -the returned true value is the one produced by the first -successful application of @var{pred}. -@end deffn - -@deffn primitive string-every pred s [start end] -Check if the predicate @var{pred} is true for every character -in the string @var{s}, proceeding from left (index @var{start}) -to right (index @var{end}). If @code{string-every} returns -true, the returned true value is the one produced by the final -application of @var{pred} to the last character of @var{s}. -@end deffn - - -@c =================================================================== - -@node SRFI-13 Constructors -@subsection Constructors - -SRFI-13 defines several procedures for constructing new strings. In -addition to @code{make-string} and @code{string} (available in the Guile -core library), the procedure @code{string-tabulate} does exist. - -@deffn primitive string-tabulate proc len -@var{proc} is an integer->char procedure. Construct a string -of size @var{len} by applying @var{proc} to each index to -produce the corresponding string element. The order in which -@var{proc} is applied to the indices is not specified. -@end deffn - - -@c =================================================================== - -@node SRFI-13 List/String Conversion -@subsection List/String Conversion - -The procedure @code{string->list} is extended by SRFI-13, that is why it -is included in @code{(srfi srfi-13)}. The other procedures are new. -The Guile core already contains the procedure @code{list->string} for -converting a list of characters into a string (@pxref{List/String -Conversion}). - -@deffn primitive string->list str [start end] -Convert the string @var{str} into a list of characters. -@end deffn - -@deffn primitive reverse-list->string chrs -An efficient implementation of @code{(compose string->list -reverse)}: - -@smalllisp -(reverse-list->string '(#\a #\B #\c)) @result{} "cBa" -@end smalllisp -@end deffn - -@deffn primitive string-join ls [delimiter grammar] -Append the string in the string list @var{ls}, using the string -@var{delim} as a delimiter between the elements of @var{ls}. -@var{grammar} is a symbol which specifies how the delimiter is -placed between the strings, and defaults to the symbol -@code{infix}. - -@table @code -@item infix -Insert the separator between list elements. An empty string -will produce an empty list. - -@item string-infix -Like @code{infix}, but will raise an error if given the empty -list. - -@item suffix -Insert the separator after every list element. - -@item prefix -Insert the separator before each list element. -@end table -@end deffn - - -@c =================================================================== - -@node SRFI-13 Selection -@subsection Selection - -These procedures are called @dfn{selectors}, because they access -information about the string or select pieces of a given string. - -Additional selector procedures are documented in the Strings section -(@pxref{String Selection}), like @code{string-length} or -@code{string-ref}. - -@code{string-copy} is also available in core Guile, but this version -accepts additional start/end indices. - -@deffn primitive string-copy str [start end] -Return a freshly allocated copy of the string @var{str}. If -given, @var{start} and @var{end} delimit the portion of -@var{str} which is copied. -@end deffn - -@deffn primitive substring/shared str start [end] -Like @code{substring}, but the result may share memory with the -argument @var{str}. -@end deffn - -@deffn primitive string-copy! target tstart s [start end] -Copy the sequence of characters from index range [@var{start}, -@var{end}) in string @var{s} to string @var{target}, beginning -at index @var{tstart}. The characters are copied left-to-right -or right-to-left as needed - the copy is guaranteed to work, -even if @var{target} and @var{s} are the same string. It is an -error if the copy operation runs off the end of the target -string. -@end deffn - -@deffn primitive string-take s n -@deffnx primitive string-take-right s n -Return the @var{n} first/last characters of @var{s}. -@end deffn - -@deffn primitive string-drop s n -@deffnx primitive string-drop-right s n -Return all but the first/last @var{n} characters of @var{s}. -@end deffn - -@deffn primitive string-pad s len [chr start end] -@deffnx primitive string-pad-right s len [chr start end] -Take that characters from @var{start} to @var{end} from the -string @var{s} and return a new string, right(left)-padded by the -character @var{chr} to length @var{len}. If the resulting -string is longer than @var{len}, it is truncated on the right (left). -@end deffn - -@deffn primitive string-trim s [char_pred start end] -@deffnx primitive string-trim-right s [char_pred start end] -@deffnx primitive string-trim-both s [char_pred start end] -Trim @var{s} by skipping over all characters on the left/right/both -sides of the string that satisfy the parameter @var{char_pred}: - -@itemize @bullet -@item -if it is the character @var{ch}, characters equal to -@var{ch} are trimmed, - -@item -if it is a procedure @var{pred} characters that -satisfy @var{pred} are trimmed, - -@item -if it is a character set, characters in that set are trimmed. -@end itemize - -If called without a @var{char_pred} argument, all whitespace is -trimmed. -@end deffn - - -@c =================================================================== - -@node SRFI-13 Modification -@subsection Modification - -The procedure @code{string-fill!} is extended from R5RS because it -accepts optional start/end indices. This bindings shadows the procedure -of the same name in the Guile core. The second modification procedure -@code{string-set!} is documented in the Strings section (@pxref{String -Modification}). - -@deffn primitive string-fill! str chr [start end] -Stores @var{chr} in every element of the given @var{str} and -returns an unspecified value. -@end deffn - - -@c =================================================================== - -@node SRFI-13 Comparison -@subsection Comparison - -The procedures in this section are used for comparing strings in -different ways. The comparison predicates differ from those in R5RS in -that they do not only return @code{#t} or @code{#f}, but the mismatch -index in the case of a true return value. - -@code{string-hash} and @code{string-hash-ci} are for calculating hash -values for strings, useful for implementing fast lookup mechanisms. - -@deffn primitive string-compare s1 s2 proc_lt proc_eq proc_gt [start1 end1 start2 end2] -@deffnx primitive string-compare-ci s1 s2 proc_lt proc_eq proc_gt [start1 end1 start2 end2] -Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the -mismatch index, depending upon whether @var{s1} is less than, -equal to, or greater than @var{s2}. The mismatch index is the -largest index @var{i} such that for every 0 <= @var{j} < -@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] - that is, -@var{i} is the first position that does not match. The -character comparison is done case-insensitively. -@end deffn - -@deffn primitive string= s1 s2 [start1 end1 start2 end2] -@deffnx primitive string<> s1 s2 [start1 end1 start2 end2] -@deffnx primitive string< s1 s2 [start1 end1 start2 end2] -@deffnx primitive string> s1 s2 [start1 end1 start2 end2] -@deffnx primitive string<= s1 s2 [start1 end1 start2 end2] -@deffnx primitive string>= s1 s2 [start1 end1 start2 end2] -Compare @var{s1} and @var{s2} and return @code{#f} if the predicate -fails. Otherwise, the mismatch index is returned (or @var{end1} in the -case of @code{string=}. -@end deffn - -@deffn primitive string-ci= s1 s2 [start1 end1 start2 end2] -@deffnx primitive string-ci<> s1 s2 [start1 end1 start2 end2] -@deffnx primitive string-ci< s1 s2 [start1 end1 start2 end2] -@deffnx primitive string-ci> s1 s2 [start1 end1 start2 end2] -@deffnx primitive string-ci<= s1 s2 [start1 end1 start2 end2] -@deffnx primitive string-ci>= s1 s2 [start1 end1 start2 end2] -Compare @var{s1} and @var{s2} and return @code{#f} if the predicate -fails. Otherwise, the mismatch index is returned (or @var{end1} in the -case of @code{string=}. These are the case-insensitive variants. -@end deffn - -@deffn primitive string-hash s [bound start end] -@deffnx primitive string-hash-ci s [bound start end] -Return a hash value of the string @var{s} in the range 0 @dots{} -@var{bound} - 1. @code{string-hash-ci} is the case-insensitive variant. -@end deffn - - -@c =================================================================== - -@node SRFI-13 Prefixes/Suffixes -@subsection Prefixes/Suffixes - -Using these procedures you can determine whether a given string is a -prefix or suffix of another string or how long a common prefix/suffix -is. - -@deffn primitive string-prefix-length s1 s2 [start1 end1 start2 end2] -@deffnx primitive string-prefix-length-ci s1 s2 [start1 end1 start2 end2] -@deffnx primitive string-suffix-length s1 s2 [start1 end1 start2 end2] -@deffnx primitive string-suffix-length-ci s1 s2 [start1 end1 start2 end2] -Return the length of the longest common prefix/suffix of the two -strings. @code{string-prefix-length-ci} and -@code{string-suffix-length-ci} are the case-insensitive variants. -@end deffn - -@deffn primitive string-prefix? s1 s2 [start1 end1 start2 end2] -@deffnx primitive string-prefix-ci? s1 s2 [start1 end1 start2 end2] -@deffnx primitive string-suffix? s1 s2 [start1 end1 start2 end2] -@deffnx primitive string-suffix-ci? s1 s2 [start1 end1 start2 end2] -Is @var{s1} a prefix/suffix of @var{s2}. @code{string-prefix-ci?} and -@code{string-suffix-ci?} are the case-insensitive variants. -@end deffn - - -@c =================================================================== - -@node SRFI-13 Searching -@subsection Searching - -Use these procedures to find out whether a string contains a given -character or a given substring, or a character from a set of characters. - -@deffn primitive string-index s char_pred [start end] -@deffnx primitive string-index-right s char_pred [start end] -Search through the string @var{s} from left to right (right to left), -returning the index of the first (last) occurence of a character which - -@itemize @bullet -@item -equals @var{char_pred}, if it is character, - -@item -satisifies the predicate @var{char_pred}, if it is a -procedure, - -@item -is in the set @var{char_pred}, if it is a character set. -@end itemize -@end deffn - -@deffn primitive string-skip s char_pred [start end] -@deffnx primitive string-skip-right s char_pred [start end] -Search through the string @var{s} from left to right (right to left), -returning the index of the first (last) occurence of a character which - -@itemize @bullet -@item -does not equal @var{char_pred}, if it is character, - -@item -does not satisify the predicate @var{char_pred}, if it is -a procedure. - -@item -is not in the set if @var{char_pred} is a character set. -@end itemize -@end deffn - -@deffn primitive string-count s char_pred [start end] -Return the count of the number of characters in the string -@var{s} which - -@itemize @bullet -@item -equals @var{char_pred}, if it is character, - -@item -satisifies the predicate @var{char_pred}, if it is a procedure. - -@item -is in the set @var{char_pred}, if it is a character set. -@end itemize -@end deffn - -@deffn primitive string-contains s1 s2 [start1 end1 start2 end2] -@deffnx primitive string-contains-ci s1 s2 [start1 end1 start2 end2] -Does string @var{s1} contain string @var{s2}? Return the index -in @var{s1} where @var{s2} occurs as a substring, or false. -The optional start/end indices restrict the operation to the -indicated substrings. - -@code{string-contains-ci} is the case-insensitive variant. -@end deffn - - -@c =================================================================== - -@node SRFI-13 Case Mapping -@subsection Alphabetic Case Mapping - -These procedures convert the alphabetic case of strings. They are -similar to the procedures in the Guile core, but are extended to handle -optional start/end indices. - -@deffn primitive string-upcase s [start end] -@deffnx primitive string-upcase! s [start end] -Upcase every character in @var{s}. @code{string-upcase!} is the -side-effecting variant. -@end deffn - -@deffn primitive string-downcase s [start end] -@deffnx primitive string-downcase! s [start end] -Downcase every character in @var{s}. @code{string-downcase!} is the -side-effecting variant. -@end deffn - -@deffn primitive string-titlecase s [start end] -@deffnx primitive string-titlecase! s [start end] -Upcase every first character in every word in @var{s}, downcase the -other characters. @code{string-titlecase!} is the side-effecting -variant. -@end deffn - - -@c =================================================================== - -@node SRFI-13 Reverse/Append -@subsection Reverse/Append - -One appending procedure, @code{string-append} is the same in R5RS and in -SRFI-13, so it is not redefined. - -@deffn primitive string-reverse str [start end] -@deffnx primitive string-reverse! str [start end] -Reverse the string @var{str}. The optional arguments -@var{start} and @var{end} delimit the region of @var{str} to -operate on. - -@code{string-reverse!} modifies the argument string and returns an -unspecified value. -@end deffn - -@deffn primitive string-append/shared ls @dots{} -Like @code{string-append}, but the result may share memory -with the argument strings. -@end deffn - -@deffn primitive string-concatenate ls -Append the elements of @var{ls} (which must be strings) -together into a single string. Guaranteed to return a freshly -allocated string. -@end deffn - -@deffn primitive string-concatenate/shared ls -Like @code{string-concatenate}, but the result may share memory -with the strings in the list @var{ls}. -@end deffn - -@deffn primitive string-concatenate-reverse ls final_string end -Without optional arguments, this procedure is equivalent to - -@smalllisp -(string-concatenate (reverse ls)) -@end smalllisp - -If the optional argument @var{final_string} is specified, it is -consed onto the beginning to @var{ls} before performing the -list-reverse and string-concatenate operations. If @var{end} -is given, only the characters of @var{final_string} up to index -@var{end} are used. - -Guaranteed to return a freshly allocated string. -@end deffn - -@deffn primitive string-concatenate-reverse/shared ls final_string end -Like @code{string-concatenate-reverse}, but the result may -share memory with the the strings in the @var{ls} arguments. -@end deffn - - -@c =================================================================== - -@node SRFI-13 Fold/Unfold/Map -@subsection Fold/Unfold/Map - -@code{string-map}, @code{string-for-each} etc. are for iterating over -the characters a string is composed of. The fold and unfold procedures -are list iterators and constructors. - -@deffn primitive string-map proc s [start end] -@var{proc} is a char->char procedure, it is mapped over -@var{s}. The order in which the procedure is applied to the -string elements is not specified. -@end deffn - -@deffn primitive string-map! proc s [start end] -@var{proc} is a char->char procedure, it is mapped over -@var{s}. The order in which the procedure is applied to the -string elements is not specified. The string @var{s} is -modified in-place, the return value is not specified. -@end deffn - -@deffn primitive string-fold kons knil s [start end] -@deffnx primitive string-fold-right kons knil s [start end] -Fold @var{kons} over the characters of @var{s}, with @var{knil} as the -terminating element, from left to right (or right to left, for -@code{string-fold-right}). @var{kons} must expect two arguments: The -actual character and the last result of @var{kons}' application. -@end deffn - -@deffn primitive string-unfold p f g seed [base make_final] -@deffnx primitive string-unfold-right p f g seed [base make_final] -These are the fundamental string constructors. -@itemize @bullet -@item @var{g} is used to generate a series of @emph{seed} -values from the initial @var{seed}: @var{seed}, (@var{g} -@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), -@dots{} -@item @var{p} tells us when to stop - when it returns true -when applied to one of these seed values. -@item @var{f} maps each seed value to the corresponding -character in the result string. These chars are assembled into the -string in a left-to-right (right-to-left) order. -@item @var{base} is the optional initial/leftmost (rightmost) - portion of the constructed string; it default to the empty string. -@item @var{make_final} is applied to the terminal seed -value (on which @var{p} returns true) to produce the final/rightmost -(leftmost) portion of the constructed string. It defaults to -@code{(lambda (x) "")}. -@end itemize -@end deffn - -@deffn primitive string-for-each proc s [start end] -@var{proc} is mapped over @var{s} in left-to-right order. The -return value is not specified. -@end deffn - - -@c =================================================================== - -@node SRFI-13 Replicate/Rotate -@subsection Replicate/Rotate - -These procedures are special substring procedures, which can also be -used for replicating strings. They are a bit tricky to use, but -consider this code fragment, which replicates the input string -@code{"foo"} so often that the resulting string has a length of six. - -@lisp -(xsubstring "foo" 0 6) -@result{} -"foofoo" -@end lisp - -@deffn primitive xsubstring s from [to start end] -This is the @emph{extended substring} procedure that implements -replicated copying of a substring of some string. - -@var{s} is a string, @var{start} and @var{end} are optional -arguments that demarcate a substring of @var{s}, defaulting to -0 and the length of @var{s}. Replicate this substring up and -down index space, in both the positive and negative directions. -@code{xsubstring} returns the substring of this string -beginning at index @var{from}, and ending at @var{to}, which -defaults to @var{from} + (@var{end} - @var{start}). -@end deffn - -@deffn primitive string-xcopy! target tstart s sfrom [sto start end] -Exactly the same as @code{xsubstring}, but the extracted text -is written into the string @var{target} starting at index -@var{tstart}. The operation is not defined if @code{(eq? -@var{target} @var{s})} or these arguments share storage - you -cannot copy a string on top of itself. -@end deffn - - -@c =================================================================== - -@node SRFI-13 Miscellaneous -@subsection Miscellaneous - -@code{string-replace} is for replacing a portion of a string with -another string and @code{string-tokenize} splits a string into a list of -strings, breaking it up at a specified character. - -@deffn primitive string-replace s1 s2 [start1 end1 start2 end2] -Return the string @var{s1}, but with the characters -@var{start1} @dots{} @var{end1} replaced by the characters -@var{start2} @dots{} @var{end2} from @var{s2}. -@end deffn - -@deffn primitive string-tokenize s [token_char start end] -Split the string @var{s} into a list of substrings, where each -substring is a maximal non-empty contiguous sequence of -characters equal to the character @var{token_char}, or -whitespace, if @var{token_char} is not given. If -@var{token_char} is a character set, it is used for finding the -token borders. -@end deffn - - -@c =================================================================== - -@node SRFI-13 Filtering/Deleting -@subsection Filtering/Deleting - -@dfn{Filtering} means to remove all characters from a string which do -not match a given criteria, @dfn{deleting} means the opposite. - -@deffn primitive string-filter s char_pred [start end] -Filter the string @var{s}, retaining only those characters that -satisfy the @var{char_pred} argument. If the argument is a -procedure, it is applied to each character as a predicate, if -it is a character, it is tested for equality and if it is a -character set, it is tested for membership. -@end deffn - -@deffn primitive string-delete s char_pred [start end] -Filter the string @var{s}, retaining only those characters that -do not satisfy the @var{char_pred} argument. If the argument -is a procedure, it is applied to each character as a predicate, -if it is a character, it is tested for equality and if it is a -character set, it is tested for membership. -@end deffn - - -@node SRFI-14 -@section SRFI-14 - Character-set Library - -SRFI-14 defines the data type @dfn{character set}, and also defines a -lot of procedures for handling this character type, and a few standard -character sets like whitespace, alphabetic characters and others. - -All procedures from SRFI-14 (character-set library) are implemented in -the module @code{(srfi srfi-14)}, as well as the standard variables -@code{char-set:letter}, @code{char-set:digit} etc. - -@menu -* Loading SRFI-14:: How to make charsets available. -* SRFI-14 Character Set Data Type:: Underlying data type for charsets. -* SRFI-14 Predicates/Comparison:: Charset predicates. -* SRFI-14 Iterating Over Character Sets:: Enumerate charset elements. -* SRFI-14 Creating Character Sets:: Makeing new charsets. -* SRFI-14 Querying Character Sets:: Test charsets for membership etc. -* SRFI-14 Character-Set Algebra:: Calculating new charsets. -* SRFI-14 Standard Character Sets:: Variables containing predefined charsets. -@end menu - - -@node Loading SRFI-14 -@subsection Loading SRFI-14 - -When Guile is properly installed, SRFI-14 support can be loaded into a -running Guile by using the @code{(srfi srfi-14)} module. - -@example -$ guile -guile> (use-modules (srfi srfi-14)) -guile> (char-set-union (char-set #\f #\o #\o) (string->char-set "bar")) -# -guile> -@end example - - -@node SRFI-14 Character Set Data Type -@subsection Character Set Data Type - -The data type @dfn{charset} implements sets of characters -(@pxref{Characters}). Because the internal representation of character -sets is not visible to the user, a lot of procedures for handling them -are provided. - -Character sets can be created, extended, tested for the membership of a -characters and be compared to other character sets. - -The Guile implementation of character sets deals with 8-bit characters. -In the standard variables, only the ASCII part of the character range is -really used, so that for example @dfn{Umlaute} and other accented -characters are not considered to be letters. In the future, as Guile -may get support for international character sets, this will change, so -don't rely on these ``features''. - - -@c =================================================================== - -@node SRFI-14 Predicates/Comparison -@subsection Predicates/Comparison - -Use these procedures for testing whether an object is a character set, -or whether several character sets are equal or subsets of each other. -@code{char-set-hash} can be used for calculating a hash value, maybe for -usage in fast lookup procedures. - -@deffn primitive char-set? obj -Return @code{#t} if @var{obj} is a character set, @code{#f} -otherwise. -@end deffn - -@deffn primitive char-set= cs1 @dots{} -Return @code{#t} if all given character sets are equal. -@end deffn - -@deffn primitive char-set<= cs1 @dots{} -Return @code{#t} if every character set @var{cs}i is a subset -of character set @var{cs}i+1. -@end deffn - -@deffn primitive char-set-hash cs [bound] -Compute a hash value for the character set @var{cs}. If -@var{bound} is given and not @code{#f}, it restricts the -returned value to the range 0 @dots{} @var{bound - 1}. -@end deffn - - -@c =================================================================== - -@node SRFI-14 Iterating Over Character Sets -@subsection Iterating Over Character Sets - -Character set cursors are a means for iterating over the members of a -character sets. After creating a character set cursor with -@code{char-set-cursor}, a cursor can be dereferenced with -@code{char-set-ref}, advanced to the next member with -@code{char-set-cursor-next}. Whether a cursor has passed past the last -element of the set can be checked with @code{end-of-char-set?}. - -Additionally, mapping and (un-)folding procedures for character sets are -provided. - -@deffn primitive char-set-cursor cs -Return a cursor into the character set @var{cs}. -@end deffn - -@deffn primitive char-set-ref cs cursor -Return the character at the current cursor position -@var{cursor} in the character set @var{cs}. It is an error to -pass a cursor for which @code{end-of-char-set?} returns true. -@end deffn - -@deffn primitive char-set-cursor-next cs cursor -Advance the character set cursor @var{cursor} to the next -character in the character set @var{cs}. It is an error if the -cursor given satisfies @code{end-of-char-set?}. -@end deffn - -@deffn primitive end-of-char-set? cursor -Return @code{#t} if @var{cursor} has reached the end of a -character set, @code{#f} otherwise. -@end deffn - -@deffn primitive char-set-fold kons knil cs -Fold the procedure @var{kons} over the character set @var{cs}, -initializing it with @var{knil}. -@end deffn - -@deffn primitive char-set-unfold p f g seed [base_cs] -@deffnx primitive char-set-unfold! p f g seed base_cs -This is a fundamental constructor for character sets. -@itemize @bullet -@item @var{g} is used to generate a series of ``seed'' values -from the initial seed: @var{seed}, (@var{g} @var{seed}), -(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{} -@item @var{p} tells us when to stop -- when it returns true -when applied to one of the seed values. -@item @var{f} maps each seed value to a character. These -characters are added to the base character set @var{base_cs} to -form the result; @var{base_cs} defaults to the empty set. -@end itemize - -@code{char-set-unfold!} is the side-effecting variant. -@end deffn - -@deffn primitive char-set-for-each proc cs -Apply @var{proc} to every character in the character set -@var{cs}. The return value is not specified. -@end deffn - -@deffn primitive char-set-map proc cs -Map the procedure @var{proc} over every character in @var{cs}. -@var{proc} must be a character -> character procedure. -@end deffn - - -@c =================================================================== - -@node SRFI-14 Creating Character Sets -@subsection Creating Character Sets - -New character sets are produced with these procedures. - -@deffn primitive char-set-copy cs -Return a newly allocated character set containing all -characters in @var{cs}. -@end deffn - -@deffn primitive char-set char1 @dots{} -Return a character set containing all given characters. -@end deffn - -@deffn primitive list->char-set char_list [base_cs] -@deffnx primitive list->char-set! char_list base_cs -Convert the character list @var{list} to a character set. If -the character set @var{base_cs} is given, the character in this -set are also included in the result. - -@code{list->char-set!} is the side-effecting variant. -@end deffn - -@deffn primitive string->char-set s [base_cs] -@deffnx primitive string->char-set! s base_cs -Convert the string @var{str} to a character set. If the -character set @var{base_cs} is given, the characters in this -set are also included in the result. - -@code{string->char-set!} is the side-effecting variant. -@end deffn - -@deffn primitive char-set-filter pred cs [base_cs] -@deffnx primitive char-set-filter! pred cs base_cs -Return a character set containing every character from @var{cs} -so that it satisfies @var{pred}. If provided, the characters -from @var{base_cs} are added to the result. - -@code{char-set-filter!} is the side-effecting variant. -@end deffn - -@deffn primitive ucs-range->char-set lower upper [error? base_cs] -@deffnx primitive uce-range->char-set! lower upper error? base_cs -Return a character set containing all characters whose -character codes lie in the half-open range -[@var{lower},@var{upper}). - -If @var{error} is a true value, an error is signalled if the -specified range contains characters which are not contained in -the implemented character range. If @var{error} is @code{#f}, -these characters are silently left out of the resultung -character set. - -The characters in @var{base_cs} are added to the result, if -given. - -@code{ucs-range->char-set!} is the side-effecting variant. -@end deffn - -@deffn procedure ->char-set x -Coerce @var{x} into a character set. @var{x} may be a string, a -character or a character set. -@end deffn - - -@c =================================================================== - -@node SRFI-14 Querying Character Sets -@subsection Querying Character Sets - -Access the elements and other information of a character set with these -procedures. - -@deffn primitive char-set-size cs -Return the number of elements in character set @var{cs}. -@end deffn - -@deffn primitive char-set-count pred cs -Return the number of the elements int the character set -@var{cs} which satisfy the predicate @var{pred}. -@end deffn - -@deffn primitive char-set->list cs -Return a list containing the elements of the character set -@var{cs}. -@end deffn - -@deffn primitive char-set->string cs -Return a string containing the elements of the character set -@var{cs}. The order in which the characters are placed in the -string is not defined. -@end deffn - -@deffn primitive char-set-contains? cs char -Return @code{#t} iff the character @var{ch} is contained in the -character set @var{cs}. -@end deffn - -@deffn primitive char-set-every pred cs -Return a true value if every character in the character set -@var{cs} satisfies the predicate @var{pred}. -@end deffn - -@deffn primitive char-set-any pred cs -Return a true value if any character in the character set -@var{cs} satisfies the predicate @var{pred}. -@end deffn - - -@c =================================================================== - -@node SRFI-14 Character-Set Algebra -@subsection Character-Set Algebra - -Character sets can be manipulated with the common set algebra operation, -such as union, complement, intersection etc. All of these procedures -provide side-effecting variants, which modify their character set -argument(s). - -@deffn primitive char-set-adjoin cs char1 @dots{} -@deffnx primitive char-set-adjoin! cs char1 @dots{} -Add all character arguments to the first argument, which must -be a character set. -@end deffn - -@deffn primitive char-set-delete cs char1 @dots{} -@deffnx primitive char-set-delete! cs char1 @dots{} -Delete all character arguments from the first argument, which -must be a character set. -@end deffn - -@deffn primitive char-set-complement cs -@deffnx primitive char-set-complement! cs -Return the complement of the character set @var{cs}. -@end deffn - -@deffn primitive char-set-union cs1 @dots{} -@deffnx primitive char-set-union! cs1 @dots{} -Return the union of all argument character sets. -@end deffn - -@deffn primitive char-set-intersection cs1 @dots{} -@deffnx primitive char-set-intersection! cs1 @dots{} -Return the intersection of all argument character sets. -@end deffn - -@deffn primitive char-set-difference cs1 @dots{} -@deffnx primitive char-set-difference! cs1 @dots{} -Return the difference of all argument character sets. -@end deffn - -@deffn primitive char-set-xor cs1 @dots{} -@deffnx primitive char-set-xor! cs1 @dots{} -Return the exclusive-or of all argument character sets. -@end deffn - -@deffn primitive char-set-diff+intersection cs1 @dots{} -@deffnx primitive char-set-diff+intersection! cs1 @dots{} -Return the difference and the intersection of all argument -character sets. -@end deffn - - -@c =================================================================== - -@node SRFI-14 Standard Character Sets -@subsection Standard Character Sets - -In order to make the use of the character set data type and procedures -useful, several predefined character set variables exist. - -@defvar char-set:lower-case -All lower-case characters. -@end defvar - -@defvar char-set:upper-case -All upper-case characters. -@end defvar - -@defvar char-set:title-case -This is empty, because ASCII has no titlecase characters. -@end defvar - -@defvar char-set:letter -All letters, e.g. the union of @code{char-set:lower-case} and -@code{char-set:upper-case}. -@end defvar - -@defvar char-set:digit -All digits. -@end defvar - -@defvar char-set:letter+digit -The union of @code{char-set:letter} and @code{char-set:digit}. -@end defvar - -@defvar char-set:graphic -All characters which would put ink on the paper. -@end defvar - -@defvar char-set:printing -The union of @code{char-set:graphic} and @code{char-set:whitespace}. -@end defvar - -@defvar char-set:whitespace -All whitespace characters. -@end defvar - -@defvar char-set:blank -All horizontal whitespace characters, that is @code{#\space} and -@code{#\tab}. -@end defvar - -@defvar char-set:iso-control -The ISO control characters with the codes 0--31 and 127. -@end defvar - -@defvar char-set:punctuation -The characters @code{!"#%&'()*,-./:;?@@[\\]_@{@}} -@end defvar - -@defvar char-set:symbol -The characters @code{$+<=>^`|~}. -@end defvar - -@defvar char-set:hex-digit -The hexadecimal digits @code{0123456789abcdefABCDEF}. -@end defvar - -@defvar char-set:ascii -All ASCII characters. -@end defvar - -@defvar char-set:empty -The empty character set. -@end defvar - -@defvar char-set:full -This character set contains all possible characters. -@end defvar - -@node SRFI-16 -@section SRFI-16 - case-lambda - -@c FIXME::martin: Review me! - -The syntactic form @code{case-lambda} creates procedures, just like -@code{lambda}, but has syntactic extensions for writing procedures of -varying arity easier. - -The syntax of the @code{case-lambda} form is defined in the following -EBNF grammar. - -@example -@group - - --> (case-lambda ) - - --> ( *) - - --> (*) - | (* . ) - | -@end group -@end example - -The value returned by a @code{case-lambda} form is a procedure which -matches the number of actual arguments against the formals in the -various clauses, in order. @dfn{Formals} means a formal argument list -just like with @code{lambda} (@pxref{Lambda}). The first matching clause -is selected, the corresponding values from the actual parameter list are -bound to the variable names in the clauses and the body of the clause is -evaluated. If no clause matches, an error is signalled. - -The following (silly) definition creates a procedure @var{foo} which -acts differently, depending on the number of actual arguments. If one -argument is given, the constant @code{#t} is returned, two arguments are -added and if more arguments are passed, their product is calculated. - -@lisp -(define foo (case-lambda - ((x) #t) - ((x y) (+ x y)) - (z - (apply * z)))) -(foo 'bar) -@result{} -#t -(foo 2 4) -@result{} -6 -(foo 3 3 3) -@result{} -27 -(foo) -@result{} -1 -@end lisp - -The last expression evaluates to 1 because the last clause is matched, -@var{z} is bound to the empty list and the following multiplication, -applied to zero arguments, yields 1. - - -@node SRFI-17 -@section SRFI-17 - Generalized set! - -This is an implementation of SRFI-17: Generalized set! - -It exports the Guile procedure @code{make-procedure-with-setter} under -the SRFI name @code{getter-with-setter} and exports the standard -procedures @code{car}, @code{cdr}, @dots{}, @code{cdddr}, -@code{string-ref} and @code{vector-ref} as procedures with setters, as -required by the SRFI. - -SRFI-17 was heavily criticized during its discussion period but it was -finalized anyway. One issue was its concept of globally associating -setter @dfn{properties} with (procedure) values, which is non-Schemy. -For this reason, this implementation chooses not to provide a way to set -the setter of a procedure. In fact, @code{(set! (setter @var{proc}) -@var{setter})} signals an error. The only way to attach a setter to a -procedure is to create a new object (a @dfn{procedure with setter}) via -the @code{getter-with-setter} procedure. This procedure is also -specified in the SRFI. Using it avoids the described problems. - From 7beabedb0a7ad957f04117c7efd200790c1f7780 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Tue, 3 Jul 2001 15:27:56 +0000 Subject: [PATCH 1434/2047] * posix.c (getlogin): getlogin() implementation for Windows. * backtrace.c, ioext.c: Include . * unif.c, script.c, rw.c, error.c: Include , if it does exist. * cpp_sig_symbols.in: Added SIGBREAK. --- libguile/ChangeLog | 13 +++++++++++++ libguile/backtrace.c | 1 + libguile/cpp_sig_symbols.in | 1 + libguile/error.c | 5 +++++ libguile/ioext.c | 1 + libguile/posix.c | 19 ++++++++++++++++++- libguile/rw.c | 3 +++ libguile/script.c | 4 ++++ libguile/unif.c | 4 ++++ 9 files changed, 50 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 9a835374c..007aa4f74 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,16 @@ +2001-07-03 Martin Grabmueller + + Some more compatibility patches for Windows. + + * posix.c (getlogin): getlogin() implementation for Windows. + + * backtrace.c, ioext.c: Include . + + * unif.c, script.c, rw.c, error.c: Include , if it does + exist. + + * cpp_sig_symbols.in: Added SIGBREAK. + 2001-07-01 Marius Vollmer * strports.c (scm_read_0str, scm_eval_0str): Call diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 1687ab88e..c1d42dc6c 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -47,6 +47,7 @@ gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ +#include #include #include "libguile/_scm.h" diff --git a/libguile/cpp_sig_symbols.in b/libguile/cpp_sig_symbols.in index a533ea1b0..bcdae842c 100644 --- a/libguile/cpp_sig_symbols.in +++ b/libguile/cpp_sig_symbols.in @@ -1,5 +1,6 @@ SIGABRT SIGALRM +SIGBREAK SIGBUS SIGCHLD SIGCLD diff --git a/libguile/error.c b/libguile/error.c index 0fd20718a..74e0a5f75 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -61,6 +61,11 @@ #ifdef HAVE_UNISTD_H #include #endif + +/* For Windows... */ +#ifdef HAVE_IO_H +#include +#endif diff --git a/libguile/ioext.c b/libguile/ioext.c index c8247d69e..f7d4232b1 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -44,6 +44,7 @@ +#include #include #include "libguile/_scm.h" diff --git a/libguile/posix.c b/libguile/posix.c index 7379c3780..4eb679eb2 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -103,6 +103,7 @@ extern char *ttyname(); #ifdef __MINGW32__ /* Some defines for Windows here. */ +# include # define pipe(fd) _pipe (fd, 256, O_BINARY) #endif /* __MINGW32__ */ @@ -576,7 +577,6 @@ SCM_DEFINE (scm_getuid, "getuid", 0, 0, 0, return SCM_MAKINUM (0L + getuid ()); } #undef FUNC_NAME -#endif /* __MINGW32__ */ @@ -675,6 +675,8 @@ SCM_DEFINE (scm_seteuid, "seteuid", 1, 0, 0, return SCM_UNSPECIFIED; } #undef FUNC_NAME +#endif /* __MINGW32__ */ + #ifdef HAVE_SETEGID SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0, @@ -1383,6 +1385,21 @@ SCM_DEFINE (scm_chroot, "chroot", 1, 0, 0, #undef FUNC_NAME #endif /* HAVE_CHROOT */ + +#ifdef __MINGW32__ +/* Wrapper function to supplying `getlogin()' under Windows. */ +static char * getlogin (void) +{ + static char user[256]; + static unsigned long len = 256; + + if (!GetUserName (user, &len)) + return NULL; + return user; +} +#endif /* __MINGW32__ */ + + #if HAVE_GETLOGIN SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0, (void), diff --git a/libguile/rw.c b/libguile/rw.c index 4a19d8946..e8e83c806 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -59,6 +59,9 @@ #ifdef HAVE_UNISTD_H #include #endif +#ifdef HAVE_IO_H +#include +#endif diff --git a/libguile/script.c b/libguile/script.c index 0c4810446..e16e65d77 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -64,6 +64,10 @@ #include /* for X_OK define */ #endif +#ifdef HAVE_IO_H +#include +#endif + /* Concatentate str2 onto str1 at position n and return concatenated string if file exists; 0 otherwise. */ diff --git a/libguile/unif.c b/libguile/unif.c index ac229538b..4fd7882a7 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -74,6 +74,10 @@ #include #endif +#ifdef HAVE_IO_H +#include +#endif + /* The set of uniform scm_vector types is: * Vector of: Called: From 018adcae03b6a3e78f8283313b2dd782125bf73a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Tue, 3 Jul 2001 15:35:08 +0000 Subject: [PATCH 1435/2047] * srfi-1.scm (list-tabulate): Do not go into infinite loop for invalid arguments. --- srfi/ChangeLog | 5 +++++ srfi/srfi-1.scm | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index ca097e012..d67d3580c 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,8 @@ +2001-07-03 Martin Grabmueller + + * srfi-1.scm (list-tabulate): Do not go into infinite loop for + invalid arguments. + 2001-07-02 Martin Grabmueller * srfi-1.scm: Replaced calls to `map' in several procedures to diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm index f0ef31055..34f71739b 100644 --- a/srfi/srfi-1.scm +++ b/srfi/srfi-1.scm @@ -242,7 +242,7 @@ (define (list-tabulate n init-proc) (let lp ((n n) (acc '())) - (if (zero? n) + (if (<= n 0) acc (lp (- n 1) (cons (init-proc (- n 1)) acc))))) From e800aa04824ee04aea92fac6cdbb9bd8be7c1360 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Tue, 3 Jul 2001 16:19:23 +0000 Subject: [PATCH 1436/2047] * srfi-1.scm (list-tabulate): Do not go into infinite loop for invalid arguments. Same fix for several other procedures (do not use zero?, use <= 0). --- srfi/ChangeLog | 3 ++- srfi/srfi-1.scm | 22 +++++++++++----------- 2 files changed, 13 insertions(+), 12 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index d67d3580c..870478dd8 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,7 +1,8 @@ 2001-07-03 Martin Grabmueller * srfi-1.scm (list-tabulate): Do not go into infinite loop for - invalid arguments. + invalid arguments. Same fix for several other procedures (do not + use zero?, use <= 0). 2001-07-02 Martin Grabmueller diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm index 34f71739b..45d558523 100644 --- a/srfi/srfi-1.scm +++ b/srfi/srfi-1.scm @@ -347,17 +347,17 @@ (define (take x i) (let lp ((n i) (l x) (acc '())) - (if (zero? n) + (if (<= n 0) (reverse! acc) (lp (- n 1) (cdr l) (cons (car l) acc))))) (define (drop x i) (let lp ((n i) (l x)) - (if (zero? n) + (if (<= n 0) l (lp (- n 1) (cdr l))))) (define (take-right flist i) (let lp ((n i) (l flist)) - (if (zero? n) + (if (<= n 0) (let lp0 ((s flist) (l l)) (if (null? l) s @@ -366,7 +366,7 @@ (define (drop-right flist i) (let lp ((n i) (l flist)) - (if (zero? n) + (if (<= n 0) (let lp0 ((s flist) (l l) (acc '())) (if (null? l) (reverse! acc) @@ -374,20 +374,20 @@ (lp (- n 1) (cdr l))))) (define (take! x i) - (if (zero? i) + (if (<= i 0) '() (let lp ((n (- i 1)) (l x)) - (if (zero? n) + (if (<= n 0) (begin (set-cdr! l '()) x) (lp (- n 1) (cdr l)))))) (define (drop-right! flist i) - (if (zero? i) + (if (<= i 0) flist (let lp ((n (+ i 1)) (l flist)) - (if (zero? n) + (if (<= n 0) (let lp0 ((s flist) (l l)) (if (null? l) (begin @@ -400,15 +400,15 @@ (define (split-at x i) (let lp ((l x) (n i) (acc '())) - (if (zero? n) + (if (<= n 0) (values (reverse! acc) l) (lp (cdr l) (- n 1) (cons (car l) acc))))) (define (split-at! x i) - (if (zero? i) + (if (<= i 0) (values '() x) (let lp ((l x) (n (- i 1))) - (if (zero? n) + (if (<= n 0) (let ((tmp (cdr l))) (set-cdr! l '()) (values x tmp)) From e48f36b29f22134e183d89b7b9800906d52fc5da Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 3 Jul 2001 17:40:49 +0000 Subject: [PATCH 1437/2047] Added Greg Badros' many changes. --- AUTHORS | 1 + 1 file changed, 1 insertion(+) diff --git a/AUTHORS b/AUTHORS index 966ed0f73..c4bccb6a8 100644 --- a/AUTHORS +++ b/AUTHORS @@ -188,6 +188,7 @@ Many other changes throughout. Greg Badros: In the subdirectory doc, changes to: data-rep.texi +Many changes throughout. Neil Jerram: In the subdirectory ice-9, wrote: From 33ee4d574491817d7e43479cefc4068e9ee72241 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 3 Jul 2001 17:41:12 +0000 Subject: [PATCH 1438/2047] More naming conventions. --- HACKING | 29 ++++++++++++++++++++++------- 1 file changed, 22 insertions(+), 7 deletions(-) diff --git a/HACKING b/HACKING index e7d44bd2e..3baa25e9a 100644 --- a/HACKING +++ b/HACKING @@ -292,13 +292,14 @@ the list of years in the copyright notice at the top of the file. them in THANKS. -- Naming conventions. We use certain naming conventions to structure - the considerable number of global identifiers. All identifiers - should be either all lower case or all upper case. Syllables are - separated by underscaores `_'. All non-static identifiers should - start with scm_ or SCM_. Then might follow zero or more one letter - syllables giving the category of the identifier. The currently used - category identifiers are +Naming conventions ================================================= + +We use certain naming conventions to structure the considerable number +of global identifiers. All identifiers should be either all lower +case or all upper case. Syllables are separated by underscores `_'. +All non-static identifiers should start with scm_ or SCM_. Then might +follow zero or more syllables giving the category of the identifier. +The currently used category identifiers are t - type name @@ -319,6 +320,20 @@ them in THANKS. s - a constant C string + k - a SCM variable pointing to a keyword. + + sym - a SCM variable pointing to a symbol. + + var - a SCM variable pointing to a variable object. + +The follwing syllables also have a technical meaning: + + str - this denotes a zero terminated C string + + mem - a C string with an explicit count + + +See also the file `devel/names.text'. Helpful hints ======================================================== From 2bc6f750486b1cfa1158bebde04e8be9fd16e6c6 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 3 Jul 2001 17:42:11 +0000 Subject: [PATCH 1439/2047] Updated generic instructions. Added two paragraphs about external packages. --- INSTALL | 247 ++++++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 179 insertions(+), 68 deletions(-) diff --git a/INSTALL b/INSTALL index 271c1da5e..302065803 100644 --- a/INSTALL +++ b/INSTALL @@ -27,6 +27,25 @@ are included below. (For instructions how to install SLIB, the scheme procedure library, see below.) +Guile can use a number of external packages such as `readline' when +they are available. Guile expects to be able to find these packages +in the default compiler setup, it does not try to make any special +arrangements itself. For example, for the `readline' package, Guile +expects to be able to find the include file , +without passing any special `-I' options to the compiler. + +If you installed an external package, and you used the --prefix +installation option to install it somewhere else than /usr/local, you +must arrange for your compiler to find it by default. If that +compiler is gcc, one convenient way of making such arrangements is to +use the --with-local-prefix option during installation, naming the +same directory as you used in the --prefix option of the package. In +particular, it is not good enough to use the same --prefix option when +you install gcc and the package; you need to use the +--with-local-prefix option as well. See the gcc documentation for +more details. + + Special Instructions For Some Systems ===================================== We would like Guile to build on all systems using the simple @@ -227,88 +246,180 @@ Example: Generic Instructions for Building Auto-Configured Packages ================ -To compile this package: + The `configure' shell script attempts to guess correct values for +various system-dependent variables used during compilation. It uses +those values to create a `Makefile' in each directory of the package. +It may also create one or more `.h' files containing system-dependent +definitions. Finally, it creates a shell script `config.status' that +you can run in the future to recreate the current configuration, a file +`config.cache' that saves the results of its tests to speed up +reconfiguring, and a file `config.log' containing compiler output +(useful mainly for debugging `configure'). -1. Configure the package for your system. In the directory that this -file is in, type `./configure'. If you're using `csh' on an old -version of System V, you might need to type `sh configure' instead to -prevent `csh' from trying to execute `configure' itself. + If you need to do unusual things to compile the package, please try +to figure out how `configure' could check whether to do them, and mail +diffs or instructions to the address given in the `README' so they can +be considered for the next release. If at some point `config.cache' +contains results you don't want to keep, you may remove or edit it. -The `configure' shell script attempts to guess correct values for -various system-dependent variables used during compilation, and -creates the Makefile(s) (one in each subdirectory of the source -directory). In some packages it creates a C header file containing -system-dependent definitions. It also creates a file `config.status' -that you can run in the future to recreate the current configuration. -Running `configure' takes a minute or two. + The file `configure.in' is used to create `configure' by a program +called `autoconf'. You only need `configure.in' if you want to change +it or regenerate `configure' using a newer version of `autoconf'. -To compile the package in a different directory from the one -containing the source code, you must use GNU make. `cd' to the -directory where you want the object files and executables to go and -run `configure' with the option `--srcdir=DIR', where DIR is the -directory that contains the source code. Using this option is -actually unnecessary if the source code is in the parent directory of -the one in which you are compiling; `configure' automatically checks -for the source code in `..' if it does not find it in the current -directory. +The simplest way to compile this package is: -By default, `make install' will install the package's files in -/usr/local/bin, /usr/local/lib, /usr/local/man, etc. You can specify -an installation prefix other than /usr/local by giving `configure' the -option `--prefix=PATH'. Alternately, you can do so by changing the -`prefix' variable in the Makefile that `configure' creates (the -Makefile in the top-level directory, if the package contains -subdirectories). + 1. `cd' to the directory containing the package's source code and type + `./configure' to configure the package for your system. If you're + using `csh' on an old version of System V, you might need to type + `sh ./configure' instead to prevent `csh' from trying to execute + `configure' itself. -You can specify separate installation prefixes for machine-specific -files and machine-independent files. If you give `configure' the -option `--exec_prefix=PATH', the package will use PATH as the prefix -for installing programs and libraries. Normally, all files are -installed using the same prefix. + Running `configure' takes awhile. While running, it prints some + messages telling which features it is checking for. -`configure' ignores any other arguments that you give it. + 2. Type `make' to compile the package. -If your system requires unusual options for compilation or linking -that `configure' doesn't know about, you can give `configure' initial -values for some variables by setting them in the environment. In -Bourne-compatible shells, you can do that on the command line like + 3. Optionally, type `make check' to run any self-tests that come with + the package. + + 4. Type `make install' to install the programs and any data files and + documentation. + + 5. You can remove the program binaries and object files from the + source code directory by typing `make clean'. To also remove the + files that `configure' created (so you can compile the package for + a different kind of computer), type `make distclean'. There is + also a `make maintainer-clean' target, but that is intended mainly + for the package's developers. If you use it, you may have to get + all sorts of other programs in order to regenerate files that came + with the distribution. + +Compilers and Options +===================== + + Some systems require unusual options for compilation or linking that +the `configure' script does not know about. You can give `configure' +initial values for variables by setting them in the environment. Using +a Bourne-compatible shell, you can do that on the command line like this: - CC='gcc -traditional' DEFS=-D_POSIX_SOURCE ./configure + CC=c89 CFLAGS=-O2 LIBS=-lposix ./configure -The `make' variables that you might want to override with environment -variables when running `configure' are: +Or on systems that have the `env' program, you can do it like this: + env CPPFLAGS=-I/usr/local/include LDFLAGS=-s ./configure -(For these variables, any value given in the environment overrides the -value that `configure' would choose:) -CC C compiler program. - Default is `cc', or `gcc' if `gcc' is in your PATH. -INSTALL Program to use to install files. - Default is `install' if you have it, `cp' otherwise. -INCLUDEDIR Directory for `configure' to search for include files. - Default is /usr/include. +Compiling For Multiple Architectures +==================================== -(For these variables, any value given in the environment is added to -the value that `configure' chooses:) -DEFS Configuration options, in the form '-Dfoo -Dbar ...' -LIBS Libraries to link with, in the form '-lfoo -lbar ...' + You can compile the package for more than one kind of computer at the +same time, by placing the object files for each architecture in their +own directory. To do this, you must use a version of `make' that +supports the `VPATH' variable, such as GNU `make'. `cd' to the +directory where you want the object files and executables to go and run +the `configure' script. `configure' automatically checks for the +source code in the directory that `configure' is in and in `..'. -If you need to do unusual things to compile the package, we encourage -you to teach `configure' how to do them and mail the diffs to the -address given in the README so we can include them in the next -release. + If you have to use a `make' that does not supports the `VPATH' +variable, you have to compile the package for one architecture at a time +in the source code directory. After you have installed the package for +one architecture, use `make distclean' before reconfiguring for another +architecture. -2. Type `make' to compile the package. +Installation Names +================== -3. Type `make install' to install programs, data files, and -documentation. + By default, `make install' will install the package's files in +`/usr/local/bin', `/usr/local/man', etc. You can specify an +installation prefix other than `/usr/local' by giving `configure' the +option `--prefix=PATH'. -4. You can remove the program binaries and object files from the -source directory by typing `make clean'. To also remove the -Makefile(s), the header file containing system-dependent definitions -(if the package uses one), and `config.status' (all the files that -`configure' created), type `make distclean'. + You can specify separate installation prefixes for +architecture-specific files and architecture-independent files. If you +give `configure' the option `--exec-prefix=PATH', the package will use +PATH as the prefix for installing programs and libraries. +Documentation and other data files will still use the regular prefix. -The file `configure.in' is used as a template to create `configure' by -a program called `autoconf'. You will only need it if you want to -regenerate `configure' using a newer version of `autoconf'. + In addition, if you use an unusual directory layout you can give +options like `--bindir=PATH' to specify different values for particular +kinds of files. Run `configure --help' for a list of the directories +you can set and what kinds of files go in them. + If the package supports it, you can cause programs to be installed +with an extra prefix or suffix on their names by giving `configure' the +option `--program-prefix=PREFIX' or `--program-suffix=SUFFIX'. + +Optional Features +================= + + Some packages pay attention to `--enable-FEATURE' options to +`configure', where FEATURE indicates an optional part of the package. +They may also pay attention to `--with-PACKAGE' options, where PACKAGE +is something like `gnu-as' or `x' (for the X Window System). The +`README' should mention any `--enable-' and `--with-' options that the +package recognizes. + + For packages that use the X Window System, `configure' can usually +find the X include and library files automatically, but if it doesn't, +you can use the `configure' options `--x-includes=DIR' and +`--x-libraries=DIR' to specify their locations. + +Specifying the System Type +========================== + + There may be some features `configure' can not figure out +automatically, but needs to determine by the type of host the package +will run on. Usually `configure' can figure that out, but if it prints +a message saying it can not guess the host type, give it the +`--host=TYPE' option. TYPE can either be a short name for the system +type, such as `sun4', or a canonical name with three fields: + CPU-COMPANY-SYSTEM + +See the file `config.sub' for the possible values of each field. If +`config.sub' isn't included in this package, then this package doesn't +need to know the host type. + + If you are building compiler tools for cross-compiling, you can also +use the `--target=TYPE' option to select the type of system they will +produce code for and the `--build=TYPE' option to select the type of +system on which you are compiling the package. + +Sharing Defaults +================ + + If you want to set default values for `configure' scripts to share, +you can create a site shell script called `config.site' that gives +default values for variables like `CC', `cache_file', and `prefix'. +`configure' looks for `PREFIX/share/config.site' if it exists, then +`PREFIX/etc/config.site' if it exists. Or, you can set the +`CONFIG_SITE' environment variable to the location of the site script. +A warning: not all `configure' scripts look for a site script. + +Operation Controls +================== + + `configure' recognizes the following options to control how it +operates. + +`--cache-file=FILE' + Use and save the results of the tests in FILE instead of + `./config.cache'. Set FILE to `/dev/null' to disable caching, for + debugging `configure'. + +`--help' + Print a summary of the options to `configure', and exit. + +`--quiet' +`--silent' +`-q' + Do not print messages saying which checks are being made. To + suppress all normal output, redirect it to `/dev/null' (any error + messages will still be shown). + +`--srcdir=DIR' + Look for the package's source code in directory DIR. Usually + `configure' can determine that directory automatically. + +`--version' + Print the version of Autoconf used to generate the `configure' + script, and exit. + +`configure' also accepts some other, not widely useful, options. From fc183bc85b611670c5895d73805d67aaa66133f3 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Tue, 3 Jul 2001 18:54:43 +0000 Subject: [PATCH 1440/2047] * srfi-1.scm (iota, map, for-each, list-index, member, delete, delete!, assoc): don't export until the new bindings have been created. otherwise "export" thinks they are being re-exported and a deprecation warning is produced. --- srfi/srfi-1.scm | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm index 45d558523..0687d93e7 100644 --- a/srfi/srfi-1.scm +++ b/srfi/srfi-1.scm @@ -70,7 +70,7 @@ list-tabulate ;; list-copy <= in the core circular-list - iota + ;; iota ; exported below ;;; Predicates proper-list? @@ -164,8 +164,8 @@ reduce-right unfold unfold-right - map - for-each + ;; map ; exported below + ;; for-each ; exported below append-map append-map! map! @@ -193,19 +193,19 @@ break! any every - list-index - member ; Extended. + ;; list-index ; exported below. + ;; member ; exported below ; Extended. ;; memq <= in the core ;; memv <= in the core ;;; Deletion - delete ; Extended. - delete! +;; delete ; exported below ; Extended. +;; delete! ; exported below delete-duplicates delete-duplicates! ;;; Association lists - assoc ; Extended. + ;; assoc ; exported below ; Extended. ;; assq <= in the core ;; assv <= in the core alist-cons @@ -1025,3 +1025,7 @@ (define (lset-diff+intersection! = list1 . rest) (apply lset-diff+intersection = list1 rest)) ; XXX:optimize + +;; extended versions of builtin procedures. exporting is delayed until the +;; new bindings have been created. +(export iota map for-each list-index member delete delete! assoc) From 26c22ea816ee20058ee60e526e9b2d5e4f415d02 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Tue, 3 Jul 2001 18:55:28 +0000 Subject: [PATCH 1441/2047] *** empty log message *** --- srfi/ChangeLog | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 870478dd8..c55522342 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,10 @@ +2001-07-03 Gary Houston + + * srfi-1.scm (iota, map, for-each, list-index, member, delete, + delete!, assoc): don't export until the new bindings have been + created. otherwise "export" thinks they are being re-exported and + a deprecation warning is produced. + 2001-07-03 Martin Grabmueller * srfi-1.scm (list-tabulate): Do not go into infinite loop for From 6d52dbf2efa11332118d201323df2b92261a3444 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Tue, 3 Jul 2001 20:18:39 +0000 Subject: [PATCH 1442/2047] (map-in-order): defined and exported, to support lists of unequal length. --- srfi/ChangeLog | 2 ++ srfi/srfi-1.scm | 6 ++++-- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index c55522342..3996b49e2 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -4,6 +4,8 @@ delete!, assoc): don't export until the new bindings have been created. otherwise "export" thinks they are being re-exported and a deprecation warning is produced. + (map-in-order): defined and exported, to support lists of unequal + length. 2001-07-03 Martin Grabmueller diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm index 0687d93e7..cc53adc79 100644 --- a/srfi/srfi-1.scm +++ b/srfi/srfi-1.scm @@ -169,7 +169,7 @@ append-map append-map! map! - ;; map-in-order <= in the core + ;; map-in-order ; exported below pair-for-each filter-map @@ -608,6 +608,8 @@ '() (cons (apply f (map1 car l)) (lp (map1 cdr l))))))) +;; extended to lists of unequal length. +(define map-in-order map) ;; This `for-each' is extended from the standard `for-each'. It ;; allows argument lists of different length, so that the shortest @@ -1028,4 +1030,4 @@ ;; extended versions of builtin procedures. exporting is delayed until the ;; new bindings have been created. -(export iota map for-each list-index member delete delete! assoc) +(export iota map map-in-order for-each list-index member delete delete! assoc) From 04e3da4f2242f6733cecff384af39d0f5f26bc7e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 4 Jul 2001 06:11:19 +0000 Subject: [PATCH 1443/2047] * scheme-data.texi (Hook Reference): Removed documentation for `make-hook-with-name', which does note exist. Added note about unspecified return values to all procedure documentation --- doc/ChangeLog | 6 + doc/scheme-data.texi | 5232 ------------------------------------------ 2 files changed, 6 insertions(+), 5232 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index bafa78884..ef0012f8d 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,9 @@ +2001-07-04 Martin Grabmueller + + * scheme-data.texi (Hook Reference): Removed documentation for + `make-hook-with-name', which does note exist. Added note about + unspecified return values to all procedure documentation + 2001-07-02 Martin Grabmueller * srfi-modules.texi (SRFI-1 Fold and Map): Documented extended diff --git a/doc/scheme-data.texi b/doc/scheme-data.texi index 120a2b638..e69de29bb 100755 --- a/doc/scheme-data.texi +++ b/doc/scheme-data.texi @@ -1,5232 +0,0 @@ -@page -@node Data Types -@chapter Data Types for Generic Use - -This chapter describes all the data types that Guile provides for -``generic use''. - -One of the great strengths of Scheme is that there is no straightforward -distinction between ``data'' and ``functionality''. For example, -Guile's support for dynamic linking could be described - -@itemize @bullet -@item -either in a ``data-centric'' way, as the behaviour and properties of the -``dynamically linked object'' data type, and the operations that may be -applied to instances of this type - -@item -or in a ``functionality-centric'' way, as the set of procedures that -constitute Guile's support for dynamic linking, in the context of the -module system. -@end itemize - -The contents of this chapter are, therefore, a matter of judgement. By -``generic use'', we mean to select those data types whose typical use as -@emph{data} in a wide variety of programming contexts is more important -than their use in the implementation of a particular piece of -@emph{functionality}. - -@ifinfo -The following menu -@end ifinfo -@iftex -The table of contents for this chapter -@end iftex -@ifhtml -The following table of contents -@end ifhtml -shows the data types that are documented in this chapter. The final -section of this chapter lists all the core Guile data types that are not -documented here, and provides links to the ``functionality-centric'' -sections of this manual that cover them. - -@menu -* Booleans:: True/false values. -* Numbers:: Numerical data types. -* Characters:: New character names. -* Strings:: Special things about strings. -* Regular Expressions:: Pattern matching and substitution. -* Symbols and Variables:: Manipulating the Scheme symbol table. -* Keywords:: Self-quoting, customizable display keywords. -* Pairs:: Scheme's basic building block. -* Lists:: Special list functions supported by Guile. -* Vectors:: One-dimensional arrays of Scheme objects. -* Records:: -* Structures:: -* Arrays:: Arrays of values. -* Association Lists and Hash Tables:: Dictionary data types. -* Hooks:: User-customizable event lists. -* Other Data Types:: Data types that are documented elsewhere. -@end menu - - -@node Booleans -@section Booleans -@tpindex Booleans - -The two boolean values are @code{#t} for true and @code{#f} for false. - -Boolean values are returned by predicate procedures, such as the general -equality predicates @code{eq?}, @code{eqv?} and @code{equal?} -(@pxref{Equality}) and numerical and string comparison operators like -@code{string=?} (@pxref{String Comparison}) and @code{<=} -(@pxref{Comparison}). - -@lisp -(<= 3 8) -@result{} -#t - -(<= 3 -3) -@result{} -#f - -(equal? "house" "houses") -@result{} -#f - -(eq? #f #f) -@result{} -#t -@end lisp - -In test condition contexts like @code{if} and @code{cond} (@pxref{if -cond case}), where a group of subexpressions will be evaluated only if a -@var{condition} expression evaluates to ``true'', ``true'' means any -value at all except @code{#f}. - -@lisp -(if #t "yes" "no") -@result{} -"yes" - -(if 0 "yes" "no") -@result{} -"yes" - -(if #f "yes" "no") -@result{} -"no" -@end lisp - -A result of this asymmetry is that typical Scheme source code more often -uses @code{#f} explicitly than @code{#t}: @code{#f} is necessary to -represent an @code{if} or @code{cond} false value, whereas @code{#t} is -not necessary to represent an @code{if} or @code{cond} true value. - -It is important to note that @code{#f} is @strong{not} equivalent to any -other Scheme value. In particular, @code{#f} is not the same as the -number 0 (like in C and C++), and not the same as the ``empty list'' -(like in some Lisp dialects). - -The @code{not} procedure returns the boolean inverse of its argument: - -@rnindex not -@deffn primitive not x -Return @code{#t} iff @var{x} is @code{#f}, else return @code{#f}. -@end deffn - -The @code{boolean?} procedure is a predicate that returns @code{#t} if -its argument is one of the boolean values, otherwise @code{#f}. - -@rnindex boolean? -@deffn primitive boolean? obj -Return @code{#t} iff @var{obj} is either @code{#t} or @code{#f}. -@end deffn - - -@node Numbers -@section Numerical data types -@tpindex Numbers - -Guile supports a rich ``tower'' of numerical types --- integer, -rational, real and complex --- and provides an extensive set of -mathematical and scientific functions for operating on numerical -data. This section of the manual documents those types and functions. - -You may also find it illuminating to read R5RS's presentation of numbers -in Scheme, which is particularly clear and accessible: see -@xref{Numbers,,,r5rs}. - -@menu -* Numerical Tower:: Scheme's numerical "tower". -* Integers:: Whole numbers. -* Reals and Rationals:: Real and rational numbers. -* Complex Numbers:: Complex numbers. -* Exactness:: Exactness and inexactness. -* Number Syntax:: Read syntax for numerical data. -* Integer Operations:: Operations on integer values. -* Comparison:: Comparison predicates. -* Conversion:: Converting numbers to and from strings. -* Complex:: Complex number operations. -* Arithmetic:: Arithmetic functions. -* Scientific:: Scientific functions. -* Primitive Numerics:: Primitive numeric functions. -* Bitwise Operations:: Logical AND, OR, NOT, and so on. -* Random:: Random number generation. -@end menu - - -@node Numerical Tower -@subsection Scheme's Numerical ``Tower'' -@rnindex number? - -Scheme's numerical ``tower'' consists of the following categories of -numbers: - -@itemize @bullet -@item -integers (whole numbers) - -@item -rationals (the set of numbers that can be expressed as P/Q where P and Q -are integers) - -@item -real numbers (the set of numbers that describes all possible positions -along a one dimensional line) - -@item -complex numbers (the set of numbers that describes all possible -positions in a two dimensional space) -@end itemize - -It is called a tower because each category ``sits on'' the one that -follows it, in the sense that every integer is also a rational, every -rational is also real, and every real number is also a complex number -(but with zero imaginary part). - -Of these, Guile implements integers, reals and complex numbers as -distinct types. Rationals are implemented as regards the read syntax -for rational numbers that is specified by R5RS, but are immediately -converted by Guile to the corresponding real number. - -The @code{number?} predicate may be applied to any Scheme value to -discover whether the value is any of the supported numerical types. - -@deffn primitive number? obj -Return @code{#t} if @var{obj} is any kind of number, @code{#f} else. -@end deffn - -For example: - -@lisp -(number? 3) -@result{} -#t - -(number? "hello there!") -@result{} -#f - -(define pi 3.141592654) -(number? pi) -@result{} -#t -@end lisp - -The next few subsections document each of Guile's numerical data types -in detail. - -@node Integers -@subsection Integers - -@tpindex Integer numbers - -@rnindex integer? - -Integers are whole numbers, that is numbers with no fractional part, -such as 2, 83 and -3789. - -Integers in Guile can be arbitrarily big, as shown by the following -example. - -@lisp -(define (factorial n) - (let loop ((n n) (product 1)) - (if (= n 0) - product - (loop (- n 1) (* product n))))) - -(factorial 3) -@result{} -6 - -(factorial 20) -@result{} -2432902008176640000 - -(- (factorial 45)) -@result{} --119622220865480194561963161495657715064383733760000000000 -@end lisp - -Readers whose background is in programming languages where integers are -limited by the need to fit into just 4 or 8 bytes of memory may find -this surprising, or suspect that Guile's representation of integers is -inefficient. In fact, Guile achieves a near optimal balance of -convenience and efficiency by using the host computer's native -representation of integers where possible, and a more general -representation where the required number does not fit in the native -form. Conversion between these two representations is automatic and -completely invisible to the Scheme level programmer. - -@c REFFIXME Maybe point here to discussion of handling immediates/bignums -@c on the C level, where the conversion is not so automatic - NJ - -@deffn primitive integer? x -Return @code{#t} if @var{x} is an integer number, @code{#f} else. - -@lisp -(integer? 487) -@result{} -#t - -(integer? -3.4) -@result{} -#f -@end lisp -@end deffn - - -@node Reals and Rationals -@subsection Real and Rational Numbers -@tpindex Real numbers -@tpindex Rational numbers - -@rnindex real? -@rnindex rational? - -Mathematically, the real numbers are the set of numbers that describe -all possible points along a continuous, infinite, one-dimensional line. -The rational numbers are the set of all numbers that can be written as -fractions P/Q, where P and Q are integers. All rational numbers are -also real, but there are real numbers that are not rational, for example -the square root of 2, and pi. - -Guile represents both real and rational numbers approximately using a -floating point encoding with limited precision. Even though the actual -encoding is in binary, it may be helpful to think of it as a decimal -number with a limited number of significant figures and a decimal point -somewhere, since this corresponds to the standard notation for non-whole -numbers. For example: - -@lisp -0.34 --0.00000142857931198 --5648394822220000000000.0 -4.0 -@end lisp - -The limited precision of Guile's encoding means that any ``real'' number -in Guile can be written in a rational form, by multiplying and then dividing -by sufficient powers of 10 (or in fact, 2). For example, -@code{-0.00000142857931198} is the same as @code{142857931198} divided by -@code{100000000000000000}. In Guile's current incarnation, therefore, -the @code{rational?} and @code{real?} predicates are equivalent. - -Another aspect of this equivalence is that Guile currently does not -preserve the exactness that is possible with rational arithmetic. -If such exactness is needed, it is of course possible to implement -exact rational arithmetic at the Scheme level using Guile's arbitrary -size integers. - -A planned future revision of Guile's numerical tower will make it -possible to implement exact representations and arithmetic for both -rational numbers and real irrational numbers such as square roots, -and in such a way that the new kinds of number integrate seamlessly -with those that are already implemented. - -@deffn primitive real? obj -Return @code{#t} if @var{obj} is a real number, @code{#f} else. -Note that the sets of integer and rational values form subsets -of the set of real numbers, so the predicate will also be fulfilled -if @var{obj} is an integer number or a rational number. -@end deffn - -@deffn primitive rational? x -Return @code{#t} if @var{x} is a rational number, @code{#f} -else. Note that the set of integer values forms a subset of -the set of rational numbers, i. e. the predicate will also be -fulfilled if @var{x} is an integer number. Real numbers -will also satisfy this predicate, because of their limited -precision. -@end deffn - - -@node Complex Numbers -@subsection Complex Numbers -@tpindex Complex numbers - -@rnindex complex? - -Complex numbers are the set of numbers that describe all possible points -in a two-dimensional space. The two coordinates of a particular point -in this space are known as the @dfn{real} and @dfn{imaginary} parts of -the complex number that describes that point. - -In Guile, complex numbers are written in rectangular form as the sum of -their real and imaginary parts, using the symbol @code{i} to indicate -the imaginary part. - -@lisp -3+4i -@result{} -3.0+4.0i - -(* 3-8i 2.3+0.3i) -@result{} -9.3-17.5i -@end lisp - -Guile represents a complex number as a pair of numbers both of which are -real, so the real and imaginary parts of a complex number have the same -properties of inexactness and limited precision as single real numbers. - -@deffn primitive complex? x -Return @code{#t} if @var{x} is a complex number, @code{#f} -else. Note that the sets of real, rational and integer -values form subsets of the set of complex numbers, i. e. the -predicate will also be fulfilled if @var{x} is a real, -rational or integer number. -@end deffn - - -@node Exactness -@subsection Exact and Inexact Numbers -@tpindex Exact numbers -@tpindex Inexact numbers - -@rnindex exact? -@rnindex inexact? -@rnindex exact->inexact -@rnindex inexact->exact - -R5RS requires that a calculation involving inexact numbers always -produces an inexact result. To meet this requirement, Guile -distinguishes between an exact integer value such as @code{5} and the -corresponding inexact real value which, to the limited precision -available, has no fractional part, and is printed as @code{5.0}. Guile -will only convert the latter value to the former when forced to do so by -an invocation of the @code{inexact->exact} procedure. - -@deffn primitive exact? x -Return @code{#t} if @var{x} is an exact number, @code{#f} -otherwise. -@end deffn - -@deffn primitive inexact? x -Return @code{#t} if @var{x} is an inexact number, @code{#f} -else. -@end deffn - -@deffn primitive inexact->exact z -Return an exact number that is numerically closest to @var{z}. -@end deffn - -@c begin (texi-doc-string "guile" "exact->inexact") -@deffn primitive exact->inexact z -Convert the number @var{z} to its inexact representation. -@end deffn - - -@node Number Syntax -@subsection Read Syntax for Numerical Data - -The read syntax for integers is a string of digits, optionally -preceded by a minus or plus character, a code indicating the -base in which the integer is encoded, and a code indicating whether -the number is exact or inexact. The supported base codes are: - -@itemize @bullet -@item -@code{#b}, @code{#B} --- the integer is written in binary (base 2) - -@item -@code{#o}, @code{#O} --- the integer is written in octal (base 8) - -@item -@code{#d}, @code{#D} --- the integer is written in decimal (base 10) - -@item -@code{#x}, @code{#X} --- the integer is written in hexadecimal (base 16). -@end itemize - -If the base code is omitted, the integer is assumed to be decimal. The -following examples show how these base codes are used. - -@lisp --13 -@result{} --13 - -#d-13 -@result{} --13 - -#x-13 -@result{} --19 - -#b+1101 -@result{} -13 - -#o377 -@result{} -255 -@end lisp - -The codes for indicating exactness (which can, incidentally, be applied -to all numerical values) are: - -@itemize @bullet -@item -@code{#e}, @code{#E} --- the number is exact - -@item -@code{#i}, @code{#I} --- the number is inexact. -@end itemize - -If the exactness indicator is omitted, the integer is assumed to be exact, -since Guile's internal representation for integers is always exact. -Real numbers have limited precision similar to the precision of the -@code{double} type in C. A consequence of the limited precision is that -all real numbers in Guile are also rational, since any number R with a -limited number of decimal places, say N, can be made into an integer by -multiplying by 10^N. - - -@node Integer Operations -@subsection Operations on Integer Values -@rnindex odd? -@rnindex even? -@rnindex quotient -@rnindex remainder -@rnindex modulo -@rnindex gcd -@rnindex lcm - -@deffn primitive odd? n -Return @code{#t} if @var{n} is an odd number, @code{#f} -otherwise. -@end deffn - -@deffn primitive even? n -Return @code{#t} if @var{n} is an even number, @code{#f} -otherwise. -@end deffn - -@c begin (texi-doc-string "guile" "quotient") -@deffn primitive quotient -Return the quotient of the numbers @var{x} and @var{y}. -@end deffn - -@c begin (texi-doc-string "guile" "remainder") -@deffn primitive remainder -Return the remainder of the numbers @var{x} and @var{y}. -@lisp -(remainder 13 4) @result{} 1 -(remainder -13 4) @result{} -1 -@end lisp -@end deffn - -@c begin (texi-doc-string "guile" "modulo") -@deffn primitive modulo -Return the modulo of the numbers @var{x} and @var{y}. -@lisp -(modulo 13 4) @result{} 1 -(modulo -13 4) @result{} 3 -@end lisp -@end deffn - -@c begin (texi-doc-string "guile" "gcd") -@deffn primitive gcd -Return the greatest common divisor of all arguments. -If called without arguments, 0 is returned. -@end deffn - -@c begin (texi-doc-string "guile" "lcm") -@deffn primitive lcm -Return the least common multiple of the arguments. -If called without arguments, 1 is returned. -@end deffn - - -@node Comparison -@subsection Comparison Predicates -@rnindex zero? -@rnindex positive? -@rnindex negative? - -@c begin (texi-doc-string "guile" "=") -@deffn primitive = -Return @code{#t} if all parameters are numerically equal. -@end deffn - -@c begin (texi-doc-string "guile" "<") -@deffn primitive < -Return @code{#t} if the list of parameters is monotonically -increasing. -@end deffn - -@c begin (texi-doc-string "guile" ">") -@deffn primitive > -Return @code{#t} if the list of parameters is monotonically -decreasing. -@end deffn - -@c begin (texi-doc-string "guile" "<=") -@deffn primitive <= -Return @code{#t} if the list of parameters is monotonically -non-decreasing. -@end deffn - -@c begin (texi-doc-string "guile" ">=") -@deffn primitive >= -Return @code{#t} if the list of parameters is monotonically -non-increasing. -@end deffn - -@c begin (texi-doc-string "guile" "zero?") -@deffn primitive zero? -Return @code{#t} if @var{z} is an exact or inexact number equal to -zero. -@end deffn - -@c begin (texi-doc-string "guile" "positive?") -@deffn primitive positive? -Return @code{#t} if @var{x} is an exact or inexact number greater than -zero. -@end deffn - -@c begin (texi-doc-string "guile" "negative?") -@deffn primitive negative? -Return @code{#t} if @var{x} is an exact or inexact number less than -zero. -@end deffn - - -@node Conversion -@subsection Converting Numbers To and From Strings -@rnindex number->string -@rnindex string->number - -@deffn primitive number->string n [radix] -Return a string holding the external representation of the -number @var{n} in the given @var{radix}. If @var{n} is -inexact, a radix of 10 will be used. -@end deffn - -@deffn primitive string->number string [radix] -Return a number of the maximally precise representation -expressed by the given @var{string}. @var{radix} must be an -exact integer, either 2, 8, 10, or 16. If supplied, @var{radix} -is a default radix that may be overridden by an explicit radix -prefix in @var{string} (e.g. "#o177"). If @var{radix} is not -supplied, then the default radix is 10. If string is not a -syntactically valid notation for a number, then -@code{string->number} returns @code{#f}. -@end deffn - - -@node Complex -@subsection Complex Number Operations -@rnindex make-rectangular -@rnindex make-polar -@rnindex real-part -@rnindex imag-part -@rnindex magnitude -@rnindex angle - -@deffn primitive make-rectangular real imaginary -Return a complex number constructed of the given @var{real} and -@var{imaginary} parts. -@end deffn - -@deffn primitive make-polar x y -Return the complex number @var{x} * e^(i * @var{y}). -@end deffn - -@c begin (texi-doc-string "guile" "real-part") -@deffn primitive real-part -Return the real part of the number @var{z}. -@end deffn - -@c begin (texi-doc-string "guile" "imag-part") -@deffn primitive imag-part -Return the imaginary part of the number @var{z}. -@end deffn - -@c begin (texi-doc-string "guile" "magnitude") -@deffn primitive magnitude -Return the magnitude of the number @var{z}. This is the same as -@code{abs} for real arguments, but also allows complex numbers. -@end deffn - -@c begin (texi-doc-string "guile" "angle") -@deffn primitive angle -Return the angle of the complex number @var{z}. -@end deffn - - -@node Arithmetic -@subsection Arithmetic Functions -@rnindex max -@rnindex min -@rnindex + -@rnindex * -@rnindex - -@rnindex / -@rnindex abs -@rnindex floor -@rnindex ceiling -@rnindex truncate -@rnindex round - -@c begin (texi-doc-string "guile" "+") -@deffn primitive + z1 @dots{} -Return the sum of all parameter values. Return 0 if called without any -parameters. -@end deffn - -@c begin (texi-doc-string "guile" "-") -@deffn primitive - z1 z2 @dots{} -If called with one argument @var{z1}, -@var{z1} is returned. Otherwise -the sum of all but the first argument are subtracted from the first -argument. -@end deffn - -@c begin (texi-doc-string "guile" "*") -@deffn primitive * z1 @dots{} -Return the product of all arguments. If called without arguments, 1 is -returned. -@end deffn - -@c begin (texi-doc-string "guile" "/") -@deffn primitive / z1 z2 @dots{} -Divide the first argument by the product of the remaining arguments. If -called with one argument @var{z1}, 1/@var{z1} is returned. -@end deffn - -@c begin (texi-doc-string "guile" "abs") -@deffn primitive abs x -Return the absolute value of @var{x}. -@end deffn - -@c begin (texi-doc-string "guile" "max") -@deffn primitive max x1 x2 @dots{} -Return the maximum of all parameter values. -@end deffn - -@c begin (texi-doc-string "guile" "min") -@deffn primitive min x1 x2 @dots{} -Return the minium of all parameter values. -@end deffn - -@c begin (texi-doc-string "guile" "truncate") -@deffn primitive truncate -Round the inexact number @var{x} towards zero. -@end deffn - -@c begin (texi-doc-string "guile" "round") -@deffn primitive round x -Round the inexact number @var{x} towards zero. -@end deffn - -@c begin (texi-doc-string "guile" "floor") -@deffn primitive floor x -Round the number @var{x} towards minus infinity. -@end deffn - -@c begin (texi-doc-string "guile" "ceiling") -@deffn primitive ceiling x -Round the number @var{x} towards infinity. -@end deffn - - -@node Scientific -@subsection Scientific Functions - -The following procedures accept any kind of number as arguments, -including complex numbers. - -@rnindex sqrt -@c begin (texi-doc-string "guile" "sqrt") -@deffn procedure sqrt z -Return the square root of @var{z}. -@end deffn - -@rnindex expt -@c begin (texi-doc-string "guile" "expt") -@deffn procedure expt z1 z2 -Return @var{z1} raised to the power of @var{z2}. -@end deffn - -@rnindex sin -@c begin (texi-doc-string "guile" "sin") -@deffn procedure sin z -Return the sine of @var{z}. -@end deffn - -@rnindex cos -@c begin (texi-doc-string "guile" "cos") -@deffn procedure cos z -Return the cosine of @var{z}. -@end deffn - -@rnindex tan -@c begin (texi-doc-string "guile" "tan") -@deffn procedure tan z -Return the tangent of @var{z}. -@end deffn - -@rnindex asin -@c begin (texi-doc-string "guile" "asin") -@deffn procedure asin z -Return the arcsine of @var{z}. -@end deffn - -@rnindex acos -@c begin (texi-doc-string "guile" "acos") -@deffn procedure acos z -Return the arccosine of @var{z}. -@end deffn - -@rnindex atan -@c begin (texi-doc-string "guile" "atan") -@deffn procedure atan z -Return the arctangent of @var{z}. -@end deffn - -@rnindex exp -@c begin (texi-doc-string "guile" "exp") -@deffn procedure exp z -Return e to the power of @var{z}, where e is the base of natural -logarithms (2.71828@dots{}). -@end deffn - -@rnindex log -@c begin (texi-doc-string "guile" "log") -@deffn procedure log z -Return the natural logarithm of @var{z}. -@end deffn - -@c begin (texi-doc-string "guile" "log10") -@deffn procedure log10 z -Return the base 10 logarithm of @var{z}. -@end deffn - -@c begin (texi-doc-string "guile" "sinh") -@deffn procedure sinh z -Return the hyperbolic sine of @var{z}. -@end deffn - -@c begin (texi-doc-string "guile" "cosh") -@deffn procedure cosh z -Return the hyperbolic cosine of @var{z}. -@end deffn - -@c begin (texi-doc-string "guile" "tanh") -@deffn procedure tanh z -Return the hyperbolic tangent of @var{z}. -@end deffn - -@c begin (texi-doc-string "guile" "asinh") -@deffn procedure asinh z -Return the hyperbolic arcsine of @var{z}. -@end deffn - -@c begin (texi-doc-string "guile" "acosh") -@deffn procedure acosh z -Return the hyperbolic arccosine of @var{z}. -@end deffn - -@c begin (texi-doc-string "guile" "atanh") -@deffn procedure atanh z -Return the hyperbolic arctangent of @var{z}. -@end deffn - - -@node Primitive Numerics -@subsection Primitive Numeric Functions - -Many of Guile's numeric procedures which accept any kind of numbers as -arguments, including complex numbers, are implemented as Scheme -procedures that use the following real number-based primitives. These -primitives signal an error if they are called with complex arguments. - -@c begin (texi-doc-string "guile" "$abs") -@deffn primitive $abs x -Return the absolute value of @var{x}. -@end deffn - -@c begin (texi-doc-string "guile" "$sqrt") -@deffn primitive $sqrt x -Return the square root of @var{x}. -@end deffn - -@deffn primitive $expt x y -Return @var{x} raised to the power of @var{y}. This -procedure does not accept complex arguments. -@end deffn - -@c begin (texi-doc-string "guile" "$sin") -@deffn primitive $sin x -Return the sine of @var{x}. -@end deffn - -@c begin (texi-doc-string "guile" "$cos") -@deffn primitive $cos x -Return the cosine of @var{x}. -@end deffn - -@c begin (texi-doc-string "guile" "$tan") -@deffn primitive $tan x -Return the tangent of @var{x}. -@end deffn - -@c begin (texi-doc-string "guile" "$asin") -@deffn primitive $asin x -Return the arcsine of @var{x}. -@end deffn - -@c begin (texi-doc-string "guile" "$acos") -@deffn primitive $acos x -Return the arccosine of @var{x}. -@end deffn - -@c begin (texi-doc-string "guile" "$atan") -@deffn primitive $atan x -Return the arctangent of @var{x} in the range -PI/2 to PI/2. -@end deffn - -@deffn primitive $atan2 x y -Return the arc tangent of the two arguments @var{x} and -@var{y}. This is similar to calculating the arc tangent of -@var{x} / @var{y}, except that the signs of both arguments -are used to determine the quadrant of the result. This -procedure does not accept complex arguments. -@end deffn - -@c begin (texi-doc-string "guile" "$exp") -@deffn primitive $exp x -Return e to the power of @var{x}, where e is the base of natural -logarithms (2.71828@dots{}). -@end deffn - -@c begin (texi-doc-string "guile" "$log") -@deffn primitive $log x -Return the natural logarithm of @var{x}. -@end deffn - -@c begin (texi-doc-string "guile" "$sinh") -@deffn primitive $sinh x -Return the hyperbolic sine of @var{x}. -@end deffn - -@c begin (texi-doc-string "guile" "$cosh") -@deffn primitive $cosh x -Return the hyperbolic cosine of @var{x}. -@end deffn - -@c begin (texi-doc-string "guile" "$tanh") -@deffn primitive $tanh x -Return the hyperbolic tangent of @var{x}. -@end deffn - -@c begin (texi-doc-string "guile" "$asinh") -@deffn primitive $asinh x -Return the hyperbolic arcsine of @var{x}. -@end deffn - -@c begin (texi-doc-string "guile" "$acosh") -@deffn primitive $acosh x -Return the hyperbolic arccosine of @var{x}. -@end deffn - -@c begin (texi-doc-string "guile" "$atanh") -@deffn primitive $atanh x -Return the hyperbolic arctangent of @var{x}. -@end deffn - - -@node Bitwise Operations -@subsection Bitwise Operations - -@deffn primitive logand n1 n2 -Return the integer which is the bit-wise AND of the two integer -arguments. - -@lisp -(number->string (logand #b1100 #b1010) 2) - @result{} "1000" -@end lisp -@end deffn - -@deffn primitive logior n1 n2 -Return the integer which is the bit-wise OR of the two integer -arguments. - -@lisp -(number->string (logior #b1100 #b1010) 2) - @result{} "1110" -@end lisp -@end deffn - -@deffn primitive logxor n1 n2 -Return the integer which is the bit-wise XOR of the two integer -arguments. - -@lisp -(number->string (logxor #b1100 #b1010) 2) - @result{} "110" -@end lisp -@end deffn - -@deffn primitive lognot n -Return the integer which is the 2s-complement of the integer -argument. - -@lisp -(number->string (lognot #b10000000) 2) - @result{} "-10000001" -(number->string (lognot #b0) 2) - @result{} "-1" -@end lisp -@end deffn - -@deffn primitive logtest j k -@lisp -(logtest j k) @equiv{} (not (zero? (logand j k))) - -(logtest #b0100 #b1011) @result{} #f -(logtest #b0100 #b0111) @result{} #t -@end lisp -@end deffn - -@deffn primitive logbit? index j -@lisp -(logbit? index j) @equiv{} (logtest (integer-expt 2 index) j) - -(logbit? 0 #b1101) @result{} #t -(logbit? 1 #b1101) @result{} #f -(logbit? 2 #b1101) @result{} #t -(logbit? 3 #b1101) @result{} #t -(logbit? 4 #b1101) @result{} #f -@end lisp -@end deffn - -@deffn primitive ash n cnt -The function ash performs an arithmetic shift left by @var{cnt} -bits (or shift right, if @var{cnt} is negative). 'Arithmetic' -means, that the function does not guarantee to keep the bit -structure of @var{n}, but rather guarantees that the result -will always be rounded towards minus infinity. Therefore, the -results of ash and a corresponding bitwise shift will differ if -@var{n} is negative. - -Formally, the function returns an integer equivalent to -@code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}. - -@lisp -(number->string (ash #b1 3) 2) @result{} "1000" -(number->string (ash #b1010 -1) 2) @result{} "101" -@end lisp -@end deffn - -@deffn primitive logcount n -Return the number of bits in integer @var{n}. If integer is -positive, the 1-bits in its binary representation are counted. -If negative, the 0-bits in its two's-complement binary -representation are counted. If 0, 0 is returned. - -@lisp -(logcount #b10101010) - @result{} 4 -(logcount 0) - @result{} 0 -(logcount -2) - @result{} 1 -@end lisp -@end deffn - -@deffn primitive integer-length n -Return the number of bits neccessary to represent @var{n}. - -@lisp -(integer-length #b10101010) - @result{} 8 -(integer-length 0) - @result{} 0 -(integer-length #b1111) - @result{} 4 -@end lisp -@end deffn - -@deffn primitive integer-expt n k -Return @var{n} raised to the non-negative integer exponent -@var{k}. - -@lisp -(integer-expt 2 5) - @result{} 32 -(integer-expt -3 3) - @result{} -27 -@end lisp -@end deffn - -@deffn primitive bit-extract n start end -Return the integer composed of the @var{start} (inclusive) -through @var{end} (exclusive) bits of @var{n}. The -@var{start}th bit becomes the 0-th bit in the result. - -@lisp -(number->string (bit-extract #b1101101010 0 4) 2) - @result{} "1010" -(number->string (bit-extract #b1101101010 4 9) 2) - @result{} "10110" -@end lisp -@end deffn - - -@node Random -@subsection Random Number Generation - -@deffn primitive copy-random-state [state] -Return a copy of the random state @var{state}. -@end deffn - -@deffn primitive random n [state] -Return a number in [0,N). - -Accepts a positive integer or real n and returns a -number of the same type between zero (inclusive) and -N (exclusive). The values returned have a uniform -distribution. - -The optional argument @var{state} must be of the type produced -by @code{seed->random-state}. It defaults to the value of the -variable @var{*random-state*}. This object is used to maintain -the state of the pseudo-random-number generator and is altered -as a side effect of the random operation. -@end deffn - -@deffn primitive random:exp [state] -Return an inexact real in an exponential distribution with mean -1. For an exponential distribution with mean u use (* u -(random:exp)). -@end deffn - -@deffn primitive random:hollow-sphere! v [state] -Fills vect with inexact real random numbers -the sum of whose squares is equal to 1.0. -Thinking of vect as coordinates in space of -dimension n = (vector-length vect), the coordinates -are uniformly distributed over the surface of the -unit n-shere. -@end deffn - -@deffn primitive random:normal [state] -Return an inexact real in a normal distribution. The -distribution used has mean 0 and standard deviation 1. For a -normal distribution with mean m and standard deviation d use -@code{(+ m (* d (random:normal)))}. -@end deffn - -@deffn primitive random:normal-vector! v [state] -Fills vect with inexact real random numbers that are -independent and standard normally distributed -(i.e., with mean 0 and variance 1). -@end deffn - -@deffn primitive random:solid-sphere! v [state] -Fills vect with inexact real random numbers -the sum of whose squares is less than 1.0. -Thinking of vect as coordinates in space of -dimension n = (vector-length vect), the coordinates -are uniformly distributed within the unit n-shere. -The sum of the squares of the numbers is returned. -@end deffn - -@deffn primitive random:uniform [state] -Return a uniformly distributed inexact real random number in -[0,1). -@end deffn - -@deffn primitive seed->random-state seed -Return a new random state using @var{seed}. -@end deffn - - -@node Characters -@section Characters -@tpindex Characters - -Most of the characters in the ASCII character set may be referred to by -name: for example, @code{#\tab}, @code{#\esc}, @code{#\stx}, and so on. -The following table describes the ASCII names for each character. - -@multitable @columnfractions .25 .25 .25 .25 -@item 0 = @code{#\nul} - @tab 1 = @code{#\soh} - @tab 2 = @code{#\stx} - @tab 3 = @code{#\etx} -@item 4 = @code{#\eot} - @tab 5 = @code{#\enq} - @tab 6 = @code{#\ack} - @tab 7 = @code{#\bel} -@item 8 = @code{#\bs} - @tab 9 = @code{#\ht} - @tab 10 = @code{#\nl} - @tab 11 = @code{#\vt} -@item 12 = @code{#\np} - @tab 13 = @code{#\cr} - @tab 14 = @code{#\so} - @tab 15 = @code{#\si} -@item 16 = @code{#\dle} - @tab 17 = @code{#\dc1} - @tab 18 = @code{#\dc2} - @tab 19 = @code{#\dc3} -@item 20 = @code{#\dc4} - @tab 21 = @code{#\nak} - @tab 22 = @code{#\syn} - @tab 23 = @code{#\etb} -@item 24 = @code{#\can} - @tab 25 = @code{#\em} - @tab 26 = @code{#\sub} - @tab 27 = @code{#\esc} -@item 28 = @code{#\fs} - @tab 29 = @code{#\gs} - @tab 30 = @code{#\rs} - @tab 31 = @code{#\us} -@item 32 = @code{#\sp} -@end multitable - -The @code{delete} character (octal 177) may be referred to with the name -@code{#\del}. - -Several characters have more than one name: - -@itemize @bullet -@item -@code{#\space}, @code{#\sp} -@item -@code{#\newline}, @code{#\nl} -@item -@code{#\tab}, @code{#\ht} -@item -@code{#\backspace}, @code{#\bs} -@item -@code{#\return}, @code{#\cr} -@item -@code{#\page}, @code{#\np} -@item -@code{#\null}, @code{#\nul} -@end itemize - -@rnindex char? -@deffn primitive char? x -Return @code{#t} iff @var{x} is a character, else @code{#f}. -@end deffn - -@rnindex char=? -@deffn primitive char=? x y -Return @code{#t} iff @var{x} is the same character as @var{y}, else @code{#f}. -@end deffn - -@rnindex char? -@deffn primitive char>? x y -Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII -sequence, else @code{#f}. -@end deffn - -@rnindex char>=? -@deffn primitive char>=? x y -Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the -ASCII sequence, else @code{#f}. -@end deffn - -@rnindex char-ci=? -@deffn primitive char-ci=? x y -Return @code{#t} iff @var{x} is the same character as @var{y} ignoring -case, else @code{#f}. -@end deffn - -@rnindex char-ci? -@deffn primitive char-ci>? x y -Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII -sequence ignoring case, else @code{#f}. -@end deffn - -@rnindex char-ci>=? -@deffn primitive char-ci>=? x y -Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the -ASCII sequence ignoring case, else @code{#f}. -@end deffn - -@rnindex char-alphabetic? -@deffn primitive char-alphabetic? chr -Return @code{#t} iff @var{chr} is alphabetic, else @code{#f}. -Alphabetic means the same thing as the isalpha C library function. -@end deffn - -@rnindex char-numeric? -@deffn primitive char-numeric? chr -Return @code{#t} iff @var{chr} is numeric, else @code{#f}. -Numeric means the same thing as the isdigit C library function. -@end deffn - -@rnindex char-whitespace? -@deffn primitive char-whitespace? chr -Return @code{#t} iff @var{chr} is whitespace, else @code{#f}. -Whitespace means the same thing as the isspace C library function. -@end deffn - -@rnindex char-upper-case? -@deffn primitive char-upper-case? chr -Return @code{#t} iff @var{chr} is uppercase, else @code{#f}. -Uppercase means the same thing as the isupper C library function. -@end deffn - -@rnindex char-lower-case? -@deffn primitive char-lower-case? chr -Return @code{#t} iff @var{chr} is lowercase, else @code{#f}. -Lowercase means the same thing as the islower C library function. -@end deffn - -@deffn primitive char-is-both? chr -Return @code{#t} iff @var{chr} is either uppercase or lowercase, else @code{#f}. -Uppercase and lowercase are as defined by the isupper and islower -C library functions. -@end deffn - -@rnindex char->integer -@deffn primitive char->integer chr -Return the number corresponding to ordinal position of @var{chr} in the -ASCII sequence. -@end deffn - -@rnindex integer->char -@deffn primitive integer->char n -Return the character at position @var{n} in the ASCII sequence. -@end deffn - -@rnindex char-upcase -@deffn primitive char-upcase chr -Return the uppercase character version of @var{chr}. -@end deffn - -@rnindex char-downcase -@deffn primitive char-downcase chr -Return the lowercase character version of @var{chr}. -@end deffn - - -@node Strings -@section Strings -@tpindex Strings - -Strings are fixed-length sequences of characters. They can be created -by calling constructor procedures, but they can also literally get -entered at the REPL or in Scheme source files. - -Guile provides a rich set of string processing procedures, because text -handling is very important when Guile is used as a scripting language. - -Strings always carry the information about how many characters they are -composed of with them, so there is no special end-of-string character, -like in C. That means that Scheme strings can contain any character, -even the NUL character @code{'\0'}. But note: Since most operating -system calls dealing with strings (such as for file operations) expect -strings to be zero-terminated, they might do unexpected things when -called with string containing unusal characters. - -@menu -* String Syntax:: Read syntax for strings. -* String Predicates:: Testing strings for certain properties. -* String Constructors:: Creating new string objects. -* List/String Conversion:: Converting from/to lists of characters. -* String Selection:: Select portions from strings. -* String Modification:: Modify parts or whole strings. -* String Comparison:: Lexicographic ordering predicates. -* String Searching:: Searching in strings. -* Alphabetic Case Mapping:: Convert the alphabetic case of strings. -* Appending Strings:: Appending strings to form a new string. -* String Miscellanea:: Miscellaneous string procedures. -@end menu - -@node String Syntax -@subsection String Read Syntax - -The read syntax for strings is an arbitrarily long sequence of -characters enclosed in double quotes (@code{"}). @footnote{Actually, the -current implementation restricts strings to a length of 2^24 -characters.} If you want to insert a double quote character into a -string literal, it must be prefixed with a backslash @code{\} character -(called an @emph{escape character}). - -The following are examples of string literals: - -@lisp -"foo" -"bar plonk" -"Hello World" -"\"Hi\", he said." -@end lisp - -@c FIXME::martin: What about escape sequences like \r, \n etc.? - -@node String Predicates -@subsection String Predicates - -The following procedures can be used to check whether a given string -fulfills some specified property. - -@rnindex string? -@deffn primitive string? obj -Return @code{#t} iff @var{obj} is a string, else returns -@code{#f}. -@end deffn - -@deffn primitive string-null? str -Return @code{#t} if @var{str}'s length is nonzero, and -@code{#f} otherwise. -@lisp -(string-null? "") @result{} #t -y @result{} "foo" -(string-null? y) @result{} #f -@end lisp -@end deffn - -@node String Constructors -@subsection String Constructors - -The string constructor procedures create new string objects, possibly -initializing them with some specified character data. - -@c FIXME::martin: list->string belongs into `List/String Conversion' - -@rnindex string -@rnindex list->string -@deffn primitive string . chrs -@deffnx primitive list->string chrs -Return a newly allocated string composed of the arguments, -@var{chrs}. -@end deffn - -@rnindex make-string -@deffn primitive make-string k [chr] -Return a newly allocated string of -length @var{k}. If @var{chr} is given, then all elements of -the string are initialized to @var{chr}, otherwise the contents -of the @var{string} are unspecified. -@end deffn - -@node List/String Conversion -@subsection List/String conversion - -When processing strings, it is often convenient to first convert them -into a list representation by using the procedure @code{string->list}, -work with the resulting list, and then convert it back into a string. -These procedures are useful for similar tasks. - -@rnindex string->list -@deffn primitive string->list str -Return a newly allocated list of the characters that make up -the given string @var{str}. @code{string->list} and -@code{list->string} are inverses as far as @samp{equal?} is -concerned. -@end deffn - -@deffn primitive string-split str chr -Split the string @var{str} into the a list of the substrings delimited -by appearances of the character @var{chr}. Note that an empty substring -between separator characters will result in an empty string in the -result list. -@lisp -(string-split "root:x:0:0:root:/root:/bin/bash" #\:) -@result{} -("root" "x" "0" "0" "root" "/root" "/bin/bash") - -(string-split "::" #\:) -@result{} -("" "" "") - -(string-split "" #\:) -@result{} -("") -@end lisp -@end deffn - - -@node String Selection -@subsection String Selection - -Portions of strings can be extracted by these procedures. -@code{string-ref} delivers individual characters whereas -@code{substring} can be used to extract substrings from longer strings. - -@rnindex string-length -@deffn primitive string-length string -Return the number of characters in @var{string}. -@end deffn - -@rnindex string-ref -@deffn primitive string-ref str k -Return character @var{k} of @var{str} using zero-origin -indexing. @var{k} must be a valid index of @var{str}. -@end deffn - -@rnindex string-copy -@deffn primitive string-copy str -Return a newly allocated copy of the given @var{string}. -@end deffn - -@rnindex substring -@deffn primitive substring str start [end] -Return a newly allocated string formed from the characters -of @var{str} beginning with index @var{start} (inclusive) and -ending with index @var{end} (exclusive). -@var{str} must be a string, @var{start} and @var{end} must be -exact integers satisfying: - -0 <= @var{start} <= @var{end} <= (string-length @var{str}). -@end deffn - -@node String Modification -@subsection String Modification - -These procedures are for modifying strings in-place. That means, that -not a new string is the result of a string operation, but that the -actual memory representation of a string is modified. - -@rnindex string-set! -@deffn primitive string-set! str k chr -Store @var{chr} in element @var{k} of @var{str} and return -an unspecified value. @var{k} must be a valid index of -@var{str}. -@end deffn - -@rnindex string-fill! -@deffn primitive string-fill! str chr -Store @var{char} in every element of the given @var{string} and -return an unspecified value. -@end deffn - -@deffn primitive substring-fill! str start end fill -Change every character in @var{str} between @var{start} and -@var{end} to @var{fill}. - -@lisp -(define y "abcdefg") -(substring-fill! y 1 3 #\r) -y -@result{} "arrdefg" -@end lisp -@end deffn - -@deffn primitive substring-move! str1 start1 end1 str2 start2 -@deffnx primitive substring-move-left! str1 start1 end1 str2 start2 -@deffnx primitive substring-move-right! str1 start1 end1 str2 start2 -Copy the substring of @var{str1} bounded by @var{start1} and @var{end1} -into @var{str2} beginning at position @var{end2}. -@code{substring-move-right!} begins copying from the rightmost character -and moves left, and @code{substring-move-left!} copies from the leftmost -character moving right. - -It is useful to have two functions that copy in different directions so -that substrings can be copied back and forth within a single string. If -you wish to copy text from the left-hand side of a string to the -right-hand side of the same string, and the source and destination -overlap, you must be careful to copy the rightmost characters of the -text first, to avoid clobbering your data. Hence, when @var{str1} and -@var{str2} are the same string, you should use -@code{substring-move-right!} when moving text from left to right, and -@code{substring-move-left!} otherwise. If @code{str1} and @samp{str2} -are different strings, it does not matter which function you use. - -@example -(define x (make-string 10 #\a)) -(define y "bcd") -(substring-move-left! x 2 5 y 0) -y -@result{} "aaa" - -x -@result{} "aaaaaaaaaa" - -(define y "bcdefg") -(substring-move-left! x 2 5 y 0) -y -@result{} "aaaefg" - -(define y "abcdefg") -(substring-move-left! y 2 5 y 3) -y -@result{} "abccccg" - -(define y "abcdefg") -(substring-move-right! y 2 5 y 0) -y -@result{} "ededefg" - -(define y "abcdefg") -(substring-move-right! y 2 5 y 3) -y -@result{} "abccdeg" -@end example -@end deffn - - -@node String Comparison -@subsection String Comparison - -The procedures in this section are similar to the character ordering -predicates (@pxref{Characters}), but are defined on character sequences. -They all return @code{#t} on success and @code{#f} on failure. The -predicates ending in @code{-ci} ignore the character case when comparing -strings. - - -@rnindex string=? -@deffn primitive string=? s1 s2 -Lexicographic equality predicate; return @code{#t} if the two -strings are the same length and contain the same characters in -the same positions, otherwise return @code{#f}. - -The procedure @code{string-ci=?} treats upper and lower case -letters as though they were the same character, but -@code{string=?} treats upper and lower case as distinct -characters. -@end deffn - -@rnindex string? -@deffn primitive string>? s1 s2 -Lexicographic ordering predicate; return @code{#t} if @var{s1} -is lexicographically greater than @var{s2}. -@end deffn - -@rnindex string>=? -@deffn primitive string>=? s1 s2 -Lexicographic ordering predicate; return @code{#t} if @var{s1} -is lexicographically greater than or equal to @var{s2}. -@end deffn - -@rnindex string-ci=? -@deffn primitive string-ci=? s1 s2 -Case-insensitive string equality predicate; return @code{#t} if -the two strings are the same length and their component -characters match (ignoring case) at each position; otherwise -return @code{#f}. -@end deffn - -@rnindex string-ci< -@deffn primitive string-ci? -@deffn primitive string-ci>? s1 s2 -Case insensitive lexicographic ordering predicate; return -@code{#t} if @var{s1} is lexicographically greater than -@var{s2} regardless of case. -@end deffn - -@rnindex string-ci>=? -@deffn primitive string-ci>=? s1 s2 -Case insensitive lexicographic ordering predicate; return -@code{#t} if @var{s1} is lexicographically greater than or -equal to @var{s2} regardless of case. -@end deffn - - -@node String Searching -@subsection String Searching - -When searching the index of a character in a string, these procedures -can be used. - -@deffn primitive string-index str chr [frm [to]] -Return the index of the first occurrence of @var{chr} in -@var{str}. The optional integer arguments @var{frm} and -@var{to} limit the search to a portion of the string. This -procedure essentially implements the @code{index} or -@code{strchr} functions from the C library. - -@lisp -(string-index "weiner" #\e) -@result{} 1 - -(string-index "weiner" #\e 2) -@result{} 4 - -(string-index "weiner" #\e 2 4) -@result{} #f -@end lisp -@end deffn - -@deffn primitive string-rindex str chr [frm [to]] -Like @code{string-index}, but search from the right of the -string rather than from the left. This procedure essentially -implements the @code{rindex} or @code{strrchr} functions from -the C library. - -@lisp -(string-rindex "weiner" #\e) -@result{} 4 - -(string-rindex "weiner" #\e 2 4) -@result{} #f - -(string-rindex "weiner" #\e 2 5) -@result{} 4 -@end lisp -@end deffn - -@node Alphabetic Case Mapping -@subsection Alphabetic Case Mapping - -These are procedures for mapping strings to their upper- or lower-case -equivalents, respectively, or for capitalizing strings. - -@deffn primitive string-upcase str -Return a freshly allocated string containing the characters of -@var{str} in upper case. -@end deffn - -@deffn primitive string-upcase! str -Destructively upcase every character in @var{str} and return -@var{str}. -@lisp -y @result{} "arrdefg" -(string-upcase! y) @result{} "ARRDEFG" -y @result{} "ARRDEFG" -@end lisp -@end deffn - -@deffn primitive string-downcase str -Return a freshly allocation string containing the characters in -@var{str} in lower case. -@end deffn - -@deffn primitive string-downcase! str -Destructively downcase every character in @var{str} and return -@var{str}. -@lisp -y @result{} "ARRDEFG" -(string-downcase! y) @result{} "arrdefg" -y @result{} "arrdefg" -@end lisp -@end deffn - -@deffn primitive string-capitalize str -Return a freshly allocated string with the characters in -@var{str}, where the first character of every word is -capitalized. -@end deffn - -@deffn primitive string-capitalize! str -Upcase the first character of every word in @var{str} -destructively and return @var{str}. - -@lisp -y @result{} "hello world" -(string-capitalize! y) @result{} "Hello World" -y @result{} "Hello World" -@end lisp -@end deffn - - -@node Appending Strings -@subsection Appending Strings - -The procedure @code{string-append} appends several strings together to -form a longer result string. - -@rnindex string-append -@deffn primitive string-append string1 @dots{} -Return a newly allocated string whose characters form the -concatenation of the given strings. -@end deffn - - -@node String Miscellanea -@subsection String Miscellanea - -This section contains all remaining string procedures. - -@deffn primitive string-ci->symbol str -Return the symbol whose name is @var{str}. @var{str} is -converted to lowercase before the conversion is done, if Guile -is currently reading symbols case-insensitively. -@end deffn - - -@node Regular Expressions -@section Regular Expressions -@tpindex Regular expressions - -@cindex regular expressions -@cindex regex -@cindex emacs regexp - -A @dfn{regular expression} (or @dfn{regexp}) is a pattern that -describes a whole class of strings. A full description of regular -expressions and their syntax is beyond the scope of this manual; -an introduction can be found in the Emacs manual (@pxref{Regexps, -, Syntax of Regular Expressions, emacs, The GNU Emacs Manual}, or -in many general Unix reference books. - -If your system does not include a POSIX regular expression library, and -you have not linked Guile with a third-party regexp library such as Rx, -these functions will not be available. You can tell whether your Guile -installation includes regular expression support by checking whether the -@code{*features*} list includes the @code{regex} symbol. - -@menu -* Regexp Functions:: Functions that create and match regexps. -* Match Structures:: Finding what was matched by a regexp. -* Backslash Escapes:: Removing the special meaning of regexp metacharacters. -* Rx Interface:: Tom Lord's Rx library does things differently. -@end menu - -[FIXME: it may be useful to include an Examples section. Parts of this -interface are bewildering on first glance.] - -@node Regexp Functions -@subsection Regexp Functions - -By default, Guile supports POSIX extended regular expressions. -That means that the characters @samp{(}, @samp{)}, @samp{+} and -@samp{?} are special, and must be escaped if you wish to match the -literal characters. - -This regular expression interface was modeled after that -implemented by SCSH, the Scheme Shell. It is intended to be -upwardly compatible with SCSH regular expressions. - -@c begin (scm-doc-string "regex.scm" "string-match") -@deffn procedure string-match pattern str [start] -Compile the string @var{pattern} into a regular expression and compare -it with @var{str}. The optional numeric argument @var{start} specifies -the position of @var{str} at which to begin matching. - -@code{string-match} returns a @dfn{match structure} which -describes what, if anything, was matched by the regular -expression. @xref{Match Structures}. If @var{str} does not match -@var{pattern} at all, @code{string-match} returns @code{#f}. -@end deffn - -Each time @code{string-match} is called, it must compile its -@var{pattern} argument into a regular expression structure. This -operation is expensive, which makes @code{string-match} inefficient if -the same regular expression is used several times (for example, in a -loop). For better performance, you can compile a regular expression in -advance and then match strings against the compiled regexp. - -@deffn primitive make-regexp pat . flags -Compile the regular expression described by @var{pat}, and -return the compiled regexp structure. If @var{pat} does not -describe a legal regular expression, @code{make-regexp} throws -a @code{regular-expression-syntax} error. - -The @var{flags} arguments change the behavior of the compiled -regular expression. The following flags may be supplied: - -@table @code -@item regexp/icase -Consider uppercase and lowercase letters to be the same when -matching. -@item regexp/newline -If a newline appears in the target string, then permit the -@samp{^} and @samp{$} operators to match immediately after or -immediately before the newline, respectively. Also, the -@samp{.} and @samp{[^...]} operators will never match a newline -character. The intent of this flag is to treat the target -string as a buffer containing many lines of text, and the -regular expression as a pattern that may match a single one of -those lines. -@item regexp/basic -Compile a basic (``obsolete'') regexp instead of the extended -(``modern'') regexps that are the default. Basic regexps do -not consider @samp{|}, @samp{+} or @samp{?} to be special -characters, and require the @samp{@{...@}} and @samp{(...)} -metacharacters to be backslash-escaped (@pxref{Backslash -Escapes}). There are several other differences between basic -and extended regular expressions, but these are the most -significant. -@item regexp/extended -Compile an extended regular expression rather than a basic -regexp. This is the default behavior; this flag will not -usually be needed. If a call to @code{make-regexp} includes -both @code{regexp/basic} and @code{regexp/extended} flags, the -one which comes last will override the earlier one. -@end table -@end deffn - -@deffn primitive regexp-exec rx str [start [flags]] -Match the compiled regular expression @var{rx} against -@code{str}. If the optional integer @var{start} argument is -provided, begin matching from that position in the string. -Return a match structure describing the results of the match, -or @code{#f} if no match could be found. -@end deffn - -@deffn primitive regexp? obj -Return @code{#t} if @var{obj} is a compiled regular expression, -or @code{#f} otherwise. -@end deffn - -Regular expressions are commonly used to find patterns in one string and -replace them with the contents of another string. - -@c begin (scm-doc-string "regex.scm" "regexp-substitute") -@deffn procedure regexp-substitute port match [item@dots{}] -Write to the output port @var{port} selected contents of the match -structure @var{match}. Each @var{item} specifies what should be -written, and may be one of the following arguments: - -@itemize @bullet -@item -A string. String arguments are written out verbatim. - -@item -An integer. The submatch with that number is written. - -@item -The symbol @samp{pre}. The portion of the matched string preceding -the regexp match is written. - -@item -The symbol @samp{post}. The portion of the matched string following -the regexp match is written. -@end itemize - -@var{port} may be @code{#f}, in which case nothing is written; instead, -@code{regexp-substitute} constructs a string from the specified -@var{item}s and returns that. -@end deffn - -@c begin (scm-doc-string "regex.scm" "regexp-substitute") -@deffn procedure regexp-substitute/global port regexp target [item@dots{}] -Similar to @code{regexp-substitute}, but can be used to perform global -substitutions on @var{str}. Instead of taking a match structure as an -argument, @code{regexp-substitute/global} takes two string arguments: a -@var{regexp} string describing a regular expression, and a @var{target} -string which should be matched against this regular expression. - -Each @var{item} behaves as in @var{regexp-substitute}, with the -following exceptions: - -@itemize @bullet -@item -A function may be supplied. When this function is called, it will be -passed one argument: a match structure for a given regular expression -match. It should return a string to be written out to @var{port}. - -@item -The @samp{post} symbol causes @code{regexp-substitute/global} to recurse -on the unmatched portion of @var{str}. This @emph{must} be supplied in -order to perform global search-and-replace on @var{str}; if it is not -present among the @var{item}s, then @code{regexp-substitute/global} will -return after processing a single match. -@end itemize -@end deffn - -@node Match Structures -@subsection Match Structures - -@cindex match structures - -A @dfn{match structure} is the object returned by @code{string-match} and -@code{regexp-exec}. It describes which portion of a string, if any, -matched the given regular expression. Match structures include: a -reference to the string that was checked for matches; the starting and -ending positions of the regexp match; and, if the regexp included any -parenthesized subexpressions, the starting and ending positions of each -submatch. - -In each of the regexp match functions described below, the @code{match} -argument must be a match structure returned by a previous call to -@code{string-match} or @code{regexp-exec}. Most of these functions -return some information about the original target string that was -matched against a regular expression; we will call that string -@var{target} for easy reference. - -@c begin (scm-doc-string "regex.scm" "regexp-match?") -@deffn procedure regexp-match? obj -Return @code{#t} if @var{obj} is a match structure returned by a -previous call to @code{regexp-exec}, or @code{#f} otherwise. -@end deffn - -@c begin (scm-doc-string "regex.scm" "match:substring") -@deffn procedure match:substring match [n] -Return the portion of @var{target} matched by subexpression number -@var{n}. Submatch 0 (the default) represents the entire regexp match. -If the regular expression as a whole matched, but the subexpression -number @var{n} did not match, return @code{#f}. -@end deffn - -@c begin (scm-doc-string "regex.scm" "match:start") -@deffn procedure match:start match [n] -Return the starting position of submatch number @var{n}. -@end deffn - -@c begin (scm-doc-string "regex.scm" "match:end") -@deffn procedure match:end match [n] -Return the ending position of submatch number @var{n}. -@end deffn - -@c begin (scm-doc-string "regex.scm" "match:prefix") -@deffn procedure match:prefix match -Return the unmatched portion of @var{target} preceding the regexp match. -@end deffn - -@c begin (scm-doc-string "regex.scm" "match:suffix") -@deffn procedure match:suffix match -Return the unmatched portion of @var{target} following the regexp match. -@end deffn - -@c begin (scm-doc-string "regex.scm" "match:count") -@deffn procedure match:count match -Return the number of parenthesized subexpressions from @var{match}. -Note that the entire regular expression match itself counts as a -subexpression, and failed submatches are included in the count. -@end deffn - -@c begin (scm-doc-string "regex.scm" "match:string") -@deffn procedure match:string match -Return the original @var{target} string. -@end deffn - -@node Backslash Escapes -@subsection Backslash Escapes - -Sometimes you will want a regexp to match characters like @samp{*} or -@samp{$} exactly. For example, to check whether a particular string -represents a menu entry from an Info node, it would be useful to match -it against a regexp like @samp{^* [^:]*::}. However, this won't work; -because the asterisk is a metacharacter, it won't match the @samp{*} at -the beginning of the string. In this case, we want to make the first -asterisk un-magic. - -You can do this by preceding the metacharacter with a backslash -character @samp{\}. (This is also called @dfn{quoting} the -metacharacter, and is known as a @dfn{backslash escape}.) When Guile -sees a backslash in a regular expression, it considers the following -glyph to be an ordinary character, no matter what special meaning it -would ordinarily have. Therefore, we can make the above example work by -changing the regexp to @samp{^\* [^:]*::}. The @samp{\*} sequence tells -the regular expression engine to match only a single asterisk in the -target string. - -Since the backslash is itself a metacharacter, you may force a regexp to -match a backslash in the target string by preceding the backslash with -itself. For example, to find variable references in a @TeX{} program, -you might want to find occurrences of the string @samp{\let\} followed -by any number of alphabetic characters. The regular expression -@samp{\\let\\[A-Za-z]*} would do this: the double backslashes in the -regexp each match a single backslash in the target string. - -@c begin (scm-doc-string "regex.scm" "regexp-quote") -@deffn procedure regexp-quote str -Quote each special character found in @var{str} with a backslash, and -return the resulting string. -@end deffn - -@strong{Very important:} Using backslash escapes in Guile source code -(as in Emacs Lisp or C) can be tricky, because the backslash character -has special meaning for the Guile reader. For example, if Guile -encounters the character sequence @samp{\n} in the middle of a string -while processing Scheme code, it replaces those characters with a -newline character. Similarly, the character sequence @samp{\t} is -replaced by a horizontal tab. Several of these @dfn{escape sequences} -are processed by the Guile reader before your code is executed. -Unrecognized escape sequences are ignored: if the characters @samp{\*} -appear in a string, they will be translated to the single character -@samp{*}. - -This translation is obviously undesirable for regular expressions, since -we want to be able to include backslashes in a string in order to -escape regexp metacharacters. Therefore, to make sure that a backslash -is preserved in a string in your Guile program, you must use @emph{two} -consecutive backslashes: - -@lisp -(define Info-menu-entry-pattern (make-regexp "^\\* [^:]*")) -@end lisp - -The string in this example is preprocessed by the Guile reader before -any code is executed. The resulting argument to @code{make-regexp} is -the string @samp{^\* [^:]*}, which is what we really want. - -This also means that in order to write a regular expression that matches -a single backslash character, the regular expression string in the -source code must include @emph{four} backslashes. Each consecutive pair -of backslashes gets translated by the Guile reader to a single -backslash, and the resulting double-backslash is interpreted by the -regexp engine as matching a single backslash character. Hence: - -@lisp -(define tex-variable-pattern (make-regexp "\\\\let\\\\=[A-Za-z]*")) -@end lisp - -The reason for the unwieldiness of this syntax is historical. Both -regular expression pattern matchers and Unix string processing systems -have traditionally used backslashes with the special meanings -described above. The POSIX regular expression specification and ANSI C -standard both require these semantics. Attempting to abandon either -convention would cause other kinds of compatibility problems, possibly -more severe ones. Therefore, without extending the Scheme reader to -support strings with different quoting conventions (an ungainly and -confusing extension when implemented in other languages), we must adhere -to this cumbersome escape syntax. - -@node Rx Interface -@subsection Rx Interface - -@c FIXME::martin: Shouldn't this be removed or moved to the -@c ``Guile Modules'' chapter? The functions are not available in -@c plain Guile... - -[FIXME: this is taken from Gary and Mark's quick summaries and should be -reviewed and expanded. Rx is pretty stable, so could already be done!] - -@cindex rx -@cindex finite automaton - -Guile includes an interface to Tom Lord's Rx library (currently only to -POSIX regular expressions). Use of the library requires a two step -process: compile a regular expression into an efficient structure, then -use the structure in any number of string comparisons. - -For example, given the -regular expression @samp{abc.} (which matches any string containing -@samp{abc} followed by any single character): - -@smalllisp -guile> @kbd{(define r (regcomp "abc."))} -guile> @kbd{r} -# -guile> @kbd{(regexec r "abc")} -#f -guile> @kbd{(regexec r "abcd")} -#((0 . 4)) -guile> -@end smalllisp - -The definitions of @code{regcomp} and @code{regexec} are as follows: - -@c NJFIXME not in libguile! -@deffn primitive regcomp pattern [flags] -Compile the regular expression pattern using POSIX rules. Flags is -optional and should be specified using symbolic names: -@defvar REG_EXTENDED -use extended POSIX syntax -@end defvar -@defvar REG_ICASE -use case-insensitive matching -@end defvar -@defvar REG_NEWLINE -allow anchors to match after newline characters in the -string and prevents @code{.} or @code{[^...]} from matching newlines. -@end defvar - -The @code{logior} procedure can be used to combine multiple flags. -The default is to use -POSIX basic syntax, which makes @code{+} and @code{?} literals and @code{\+} -and @code{\?} -operators. Backslashes in @var{pattern} must be escaped if specified in a -literal string e.g., @code{"\\(a\\)\\?"}. -@end deffn - -@c NJFIXME not in libguile! -@deffn primitive regexec regex string [match-pick] [flags] - -Match @var{string} against the compiled POSIX regular expression -@var{regex}. -@var{match-pick} and @var{flags} are optional. Possible flags (which can be -combined using the logior procedure) are: - -@defvar REG_NOTBOL -The beginning of line operator won't match the beginning of -@var{string} (presumably because it's not the beginning of a line) -@end defvar - -@defvar REG_NOTEOL -Similar to REG_NOTBOL, but prevents the end of line operator -from matching the end of @var{string}. -@end defvar - -If no match is possible, regexec returns #f. Otherwise @var{match-pick} -determines the return value: - -@code{#t} or unspecified: a newly-allocated vector is returned, -containing pairs with the indices of the matched part of @var{string} and any -substrings. - -@code{""}: a list is returned: the first element contains a nested list -with the matched part of @var{string} surrounded by the the unmatched parts. -Remaining elements are matched substrings (if any). All returned -substrings share memory with @var{string}. - -@code{#f}: regexec returns #t if a match is made, otherwise #f. - -vector: the supplied vector is returned, with the first element replaced -by a pair containing the indices of the matched portion of @var{string} and -further elements replaced by pairs containing the indices of matched -substrings (if any). - -list: a list will be returned, with each member of the list -specified by a code in the corresponding position of the supplied list: - -a number: the numbered matching substring (0 for the entire match). - -@code{#\<}: the beginning of @var{string} to the beginning of the part matched -by regex. - -@code{#\>}: the end of the matched part of @var{string} to the end of -@var{string}. - -@code{#\c}: the "final tag", which seems to be associated with the "cut -operator", which doesn't seem to be available through the posix -interface. - -e.g., @code{(list #\< 0 1 #\>)}. The returned substrings share memory with -@var{string}. -@end deffn - -Here are some other procedures that might be used when using regular -expressions: - -@c NJFIXME not in libguile! -@deffn primitive compiled-regexp? obj -Test whether obj is a compiled regular expression. -@end deffn - -@c NJFIXME not in libguile! -@deffn primitive regexp->dfa regex [flags] -@end deffn - -@c NJFIXME not in libguile! -@deffn primitive dfa-fork dfa -@end deffn - -@c NJFIXME not in libguile! -@deffn primitive reset-dfa! dfa -@end deffn - -@c NJFIXME not in libguile! -@deffn primitive dfa-final-tag dfa -@end deffn - -@c NJFIXME not in libguile! -@deffn primitive dfa-continuable? dfa -@end deffn - -@c NJFIXME not in libguile! -@deffn primitive advance-dfa! dfa string -@end deffn - - -@node Symbols and Variables -@section Symbols and Variables - -@c FIXME::martin: Review me! - -Symbols are a data type with a special property. On the one hand, -symbols are used for denoting variables in a Scheme program, on the -other they can be used as literal data as well. - -The association between symbols and values is maintained in special data -structures, the symbol tables. - -In addition, Guile offers variables as first-class objects. They can -be used for interacting with the module system. - -@menu -* Symbols:: All about symbols as a data type. -* Symbol Tables:: Tables for mapping symbols to values. -* Variables:: First-class variables. -@end menu - -@node Symbols -@subsection Symbols -@tpindex Symbols - -@c FIXME::martin: Review me! - -Symbols are especially useful because two symbols which are spelled the -same way are equivalent in the sense of @code{eq?}. That means that -they are actually the same Scheme object. The advantage is that symbols -can be compared extremely efficiently, although they carry more -information for the human reader than, say, numbers. - -It is very common in Scheme programs to use symbols as keys in -association lists (@pxref{Association Lists}) or hash tables -(@pxref{Hash Tables}), because this usage improves the readability a -lot, and does not cause any performance loss. - -The read syntax for symbols is a sequence of letters, digits, and -@emph{extended alphabetic characters} that begins with a character that -cannot begin a number is an identifier. In addition, @code{+}, -@code{-}, and @code{...} are identifiers. - -Extended alphabetic characters may be used within identifiers as if -they were letters. The following are extended alphabetic characters: - -@example -! $ % & * + - . / : < = > ? @@ ^ _ ~ -@end example - -In addition to the read syntax defined above (which is taken from R5RS -(@pxref{Formal syntax,,,r5rs,The Revised^5 Report on Scheme})), Guile -provides a method for writing symbols with unusual characters, such as -space characters. If you (for whatever reason) need to write a symbol -containing characters not mentioned above, you write symbols as follows: - -@itemize @bullet -@item -Begin the symbol with the two character @code{#@{}, - -@item -write the characters of the symbol and - -@item -finish the symbol with the characters @code{@}#}. -@end itemize - -Here are a few examples of this form of read syntax; the first -containing a space character, the second containing a line break and the -last one looks like a number. - -@lisp -#@{foo bar@}# -#@{what -ever@}# -#@{4242@}# -@end lisp - -Usage of this form of read syntax is discouraged, because it is not -portable at all, and is not very readable. - -@rnindex symbol? -@deffn primitive symbol? obj -Return @code{#t} if @var{obj} is a symbol, otherwise return -@code{#f}. -@end deffn - -@rnindex string->symbol -@deffn primitive string->symbol string -Return the symbol whose name is @var{string}. This procedure -can create symbols with names containing special characters or -letters in the non-standard case, but it is usually a bad idea -to create such symbols because in some implementations of -Scheme they cannot be read as themselves. See -@code{symbol->string}. - -The following examples assume that the implementation's -standard case is lower case: - -@lisp -(eq? 'mISSISSIppi 'mississippi) @result{} #t -(string->symbol "mISSISSIppi") @result{} @r{the symbol with name "mISSISSIppi"} -(eq? 'bitBlt (string->symbol "bitBlt")) @result{} #f -(eq? 'JollyWog - (string->symbol (symbol->string 'JollyWog))) @result{} #t -(string=? "K. Harper, M.D." - (symbol->string - (string->symbol "K. Harper, M.D."))) @result{}#t -@end lisp -@end deffn - -@rnindex symbol->string -@deffn primitive symbol->string s -Return the name of @var{symbol} as a string. If the symbol was -part of an object returned as the value of a literal expression -(section @pxref{Literal expressions,,,r5rs, The Revised^5 -Report on Scheme}) or by a call to the @code{read} procedure, -and its name contains alphabetic characters, then the string -returned will contain characters in the implementation's -preferred standard case--some implementations will prefer -upper case, others lower case. If the symbol was returned by -@code{string->symbol}, the case of characters in the string -returned will be the same as the case in the string that was -passed to @code{string->symbol}. It is an error to apply -mutation procedures like @code{string-set!} to strings returned -by this procedure. - -The following examples assume that the implementation's -standard case is lower case: - -@lisp -(symbol->string 'flying-fish) @result{} "flying-fish" -(symbol->string 'Martin) @result{} "martin" -(symbol->string - (string->symbol "Malvina")) @result{} "Malvina" -@end lisp -@end deffn - -@node Symbol Tables -@subsection Symbol Tables - -@c FIXME::martin: Review me! - -@c FIXME::martin: Are all these procedures still relevant? - -Guile symbol tables are hash tables. Each hash table, also called an -@dfn{obarray} (for `object array'), is a vector of association lists. -Each entry in the alists is a pair (@var{SYMBOL} . @var{VALUE}). To -@dfn{intern} a symbol in a symbol table means to return its -(@var{SYMBOL} . @var{VALUE}) pair, adding a new entry to the symbol -table (with an undefined value) if none is yet present. - -@c FIXME::martin: According to NEWS, removed. Remove here too, or -@c leave for compatibility? -@c @c docstring begin (texi-doc-string "guile" "builtin-bindings") -@c @deffn primitive builtin-bindings -@c Create and return a copy of the global symbol table, removing all -@c unbound symbols. -@c @end deffn - -@deffn primitive 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 @code{g}. The counter -is increased by 1 at each call. There is no provision for -resetting the counter. -@end deffn - -@deffn primitive gentemp [prefix [obarray]] -Create a new symbol with a name unique in an obarray. -The name is constructed from an optional string @var{prefix} -and a counter value. The default prefix is @code{t}. The -@var{obarray} is specified as a second optional argument. -Default is the system obarray where all normal symbols are -interned. The counter is increased by 1 at each -call. There is no provision for resetting the counter. -@end deffn - -@deffn primitive intern-symbol obarray string -Add a new symbol to @var{obarray} with name @var{string}, bound to an -unspecified initial value. The symbol table is not modified if a symbol -with this name is already present. -@end deffn - -@deffn primitive string->obarray-symbol obarray string [soft?] -Intern a new symbol in @var{obarray}, a symbol table, with name -@var{string}. -@end deffn - -@deffn primitive symbol-binding obarray string -Look up in @var{obarray} the symbol whose name is @var{string}, and -return the value to which it is bound. If @var{obarray} is @code{#f}, -use the global symbol table. If @var{string} is not interned in -@var{obarray}, an error is signalled. -@end deffn - -@deffn primitive symbol-bound? obarray string -Return @code{#t} if @var{obarray} contains a symbol with name -@var{string} bound to a defined value. This differs from -@var{symbol-interned?} in that the mere mention of a symbol -usually causes it to be interned; @code{symbol-bound?} -determines whether a symbol has been given any meaningful -value. -@end deffn - -@deffn primitive symbol-fref symbol -Return the contents of @var{symbol}'s @dfn{function slot}. -@end deffn - -@deffn primitive symbol-fset! symbol value -Change the binding of @var{symbol}'s function slot. -@end deffn - -@deffn primitive symbol-hash symbol -Return a hash value for @var{symbol}. -@end deffn - -@deffn primitive symbol-interned? obarray string -Return @code{#t} if @var{obarray} contains a symbol with name -@var{string}, and @code{#f} otherwise. -@end deffn - -@deffn primitive symbol-pref symbol -Return the @dfn{property list} currently associated with @var{symbol}. -@end deffn - -@deffn primitive symbol-pset! symbol value -Change the binding of @var{symbol}'s property slot. -@end deffn - -@deffn primitive symbol-set! obarray string value -Find the symbol in @var{obarray} whose name is @var{string}, and rebind -it to @var{value}. An error is signalled if @var{string} is not present -in @var{obarray}. -@end deffn - -@deffn primitive unintern-symbol obarray string -Remove the symbol with name @var{string} from @var{obarray}. This -function returns @code{#t} if the symbol was present and @code{#f} -otherwise. -@end deffn - -@node Variables -@subsection Variables -@tpindex Variables - -@c FIXME::martin: Review me! - -Variables are objects with two fields. They contain a value and they -can contain a symbol, which is the name of the variable. A variable is -said to be bound if it does not contain the object denoting unbound -variables in the value slot. - -Variables do not have a read syntax, they have to be created by calling -one of the constructor procedures @code{make-variable} or -@code{make-undefined-variable} or retrieved by @code{builtin-variable}. - -First-class variables are especially useful for interacting with the -current module system (@pxref{The Guile module system}). - -@deffn primitive builtin-variable name -Return the built-in variable with the name @var{name}. -@var{name} must be a symbol (not a string). -Then use @code{variable-ref} to access its value. -@end deffn - -@deffn primitive make-undefined-variable [name-hint] -Return a variable object initialized to an undefined value. -If given, uses @var{name-hint} as its internal (debugging) -name, otherwise just treat it as an anonymous variable. -Remember, of course, that multiple bindings to the same -variable may exist, so @var{name-hint} is just that---a hint. -@end deffn - -@deffn primitive make-variable init [name-hint] -Return a variable object initialized to value @var{init}. -If given, uses @var{name-hint} as its internal (debugging) -name, otherwise just treat it as an anonymous variable. -Remember, of course, that multiple bindings to the same -variable may exist, so @var{name-hint} is just that---a hint. -@end deffn - -@deffn primitive variable-bound? var -Return @code{#t} iff @var{var} is bound to a value. -Throws an error if @var{var} is not a variable object. -@end deffn - -@deffn primitive variable-ref var -Dereference @var{var} and return its value. -@var{var} must be a variable object; see @code{make-variable} -and @code{make-undefined-variable}. -@end deffn - -@deffn primitive variable-set! var val -Set the value of the variable @var{var} to @var{val}. -@var{var} must be a variable object, @var{val} can be any -value. Return an unspecified value. -@end deffn - -@deffn primitive variable? obj -Return @code{#t} iff @var{obj} is a variable object, else -return @code{#f} -@end deffn - - -@node Keywords -@section Keywords -@tpindex Keywords - -Keywords are self-evaluating objects with a convenient read syntax that -makes them easy to type. - -Guile's keyword support conforms to R5RS, and adds a (switchable) read -syntax extension to permit keywords to begin with @code{:} as well as -@code{#:}. - -@menu -* Why Use Keywords?:: Motivation for keyword usage. -* Coding With Keywords:: How to use keywords. -* Keyword Read Syntax:: Read syntax for keywords. -* Keyword Procedures:: Procedures for dealing with keywords. -* Keyword Primitives:: The underlying primitive procedures. -@end menu - -@node Why Use Keywords? -@subsection Why Use Keywords? - -Keywords are useful in contexts where a program or procedure wants to be -able to accept a large number of optional arguments without making its -interface unmanageable. - -To illustrate this, consider a hypothetical @code{make-window} -procedure, which creates a new window on the screen for drawing into -using some graphical toolkit. There are many parameters that the caller -might like to specify, but which could also be sensibly defaulted, for -example: - -@itemize @bullet -@item -colour depth -- Default: the colour depth for the screen - -@item -background colour -- Default: white - -@item -width -- Default: 600 - -@item -height -- Default: 400 -@end itemize - -If @code{make-window} did not use keywords, the caller would have to -pass in a value for each possible argument, remembering the correct -argument order and using a special value to indicate the default value -for that argument: - -@lisp -(make-window 'default ;; Colour depth - 'default ;; Background colour - 800 ;; Width - 100 ;; Height - @dots{}) ;; More make-window arguments -@end lisp - -With keywords, on the other hand, defaulted arguments are omitted, and -non-default arguments are clearly tagged by the appropriate keyword. As -a result, the invocation becomes much clearer: - -@lisp -(make-window #:width 800 #:height 100) -@end lisp - -On the other hand, for a simpler procedure with few arguments, the use -of keywords would be a hindrance rather than a help. The primitive -procedure @code{cons}, for example, would not be improved if it had to -be invoked as - -@lisp -(cons #:car x #:cdr y) -@end lisp - -So the decision whether to use keywords or not is purely pragmatic: use -them if they will clarify the procedure invocation at point of call. - -@node Coding With Keywords -@subsection Coding With Keywords - -If a procedure wants to support keywords, it should take a rest argument -and then use whatever means is convenient to extract keywords and their -corresponding arguments from the contents of that rest argument. - -The following example illustrates the principle: the code for -@code{make-window} uses a helper procedure called -@code{get-keyword-value} to extract individual keyword arguments from -the rest argument. - -@lisp -(define (get-keyword-value args keyword default) - (let ((kv (memq keyword args))) - (if (and kv (>= (length kv) 2)) - (cadr kv) - default))) - -(define (make-window . args) - (let ((depth (get-keyword-value args #:depth screen-depth)) - (bg (get-keyword-value args #:bg "white")) - (width (get-keyword-value args #:width 800)) - (height (get-keyword-value args #:height 100)) - @dots{}) - @dots{})) -@end lisp - -But you don't need to write @code{get-keyword-value}. The @code{(ice-9 -optargs)} module provides a set of powerful macros that you can use to -implement keyword-supporting procedures like this: - -@lisp -(use-modules (ice-9 optargs)) - -(define (make-window . args) - (let-keywords args #f ((depth screen-depth) - (bg "white") - (width 800) - (height 100)) - ...)) -@end lisp - -@noindent -Or, even more economically, like this: - -@lisp -(use-modules (ice-9 optargs)) - -(define* (make-window #:key (depth screen-depth) - (bg "white") - (width 800) - (height 100)) - ...) -@end lisp - -For further details on @code{let-keywords}, @code{define*} and other -facilities provided by the @code{(ice-9 optargs)} module, @ref{Optional -Arguments}. - - -@node Keyword Read Syntax -@subsection Keyword Read Syntax - -Guile, by default, only recognizes the keyword syntax specified by R5RS. -A token of the form @code{#:NAME}, where @code{NAME} has the same syntax -as a Scheme symbol, is the external representation of the keyword named -@code{NAME}. Keyword objects print using this syntax as well, so values -containing keyword objects can be read back into Guile. When used in an -expression, keywords are self-quoting objects. - -If the @code{keyword} read option is set to @code{'prefix}, Guile also -recognizes the alternative read syntax @code{:NAME}. Otherwise, tokens -of the form @code{:NAME} are read as symbols, as required by R5RS. - -To enable and disable the alternative non-R5RS keyword syntax, you use -the @code{read-options} procedure documented in @ref{General option -interface} and @ref{Reader options}. - -@smalllisp -(read-set! keywords 'prefix) - -#:type -@result{} -#:type - -:type -@result{} -#:type - -(read-set! keywords #f) - -#:type -@result{} -#:type - -:type -@result{} -ERROR: In expression :type: -ERROR: Unbound variable: :type -ABORT: (unbound-variable) -@end smalllisp - -@node Keyword Procedures -@subsection Keyword Procedures - -@c FIXME::martin: Review me! - -The following procedures can be used for converting symbols to keywords -and back. - -@deffn procedure symbol->keyword sym -Return a keyword with the same characters as in @var{sym}. -@end deffn - -@deffn procedure keyword->symbol kw -Return a symbol with the same characters as in @var{kw}. -@end deffn - - -@node Keyword Primitives -@subsection Keyword Primitives - -Internally, a keyword is implemented as something like a tagged symbol, -where the tag identifies the keyword as being self-evaluating, and the -symbol, known as the keyword's @dfn{dash symbol} has the same name as -the keyword name but prefixed by a single dash. For example, the -keyword @code{#:name} has the corresponding dash symbol @code{-name}. - -Most keyword objects are constructed automatically by the reader when it -reads a token beginning with @code{#:}. However, if you need to -construct a keyword object programmatically, you can do so by calling -@code{make-keyword-from-dash-symbol} with the corresponding dash symbol -(as the reader does). The dash symbol for a keyword object can be -retrieved using the @code{keyword-dash-symbol} procedure. - -@deffn primitive make-keyword-from-dash-symbol symbol -Make a keyword object from a @var{symbol} that starts with a dash. -@end deffn - -@deffn primitive keyword? obj -Return @code{#t} if the argument @var{obj} is a keyword, else -@code{#f}. -@end deffn - -@deffn primitive keyword-dash-symbol keyword -Return the dash symbol for @var{keyword}. -This is the inverse of @code{make-keyword-from-dash-symbol}. -@end deffn - -@node Pairs -@section Pairs -@tpindex Pairs - -@c FIXME::martin: Review me! - -Pairs are used to combine two Scheme objects into one compound object. -Hence the name: A pair stores a pair of objects. - -The data type @emph{pair} is extremely important in Scheme, just like in -any other Lisp dialect. The reason is that pairs are not only used to -make two values available as one object, but that pairs are used for -constructing lists of values. Because lists are so important in Scheme, -they are described in a section of their own (@pxref{Lists}). - -Pairs can literally get entered in source code or at the REPL, in the -so-called @dfn{dotted list} syntax. This syntax consists of an opening -parentheses, the first element of the pair, a dot, the second element -and a closing parentheses. The following example shows how a pair -consisting of the two numbers 1 and 2, and a pair containing the symbols -@code{foo} and @code{bar} can be entered. It is very important to write -the whitespace before and after the dot, because otherwise the Scheme -parser whould not be able to figure out where to split the tokens. - -@lisp -(1 . 2) -(foo . bar) -@end lisp - -But beware, if you want to try out these examples, you have to -@dfn{quote} the expressions. More information about quotation is -available in the section (REFFIXME). The correct way to try these -examples is as follows. - -@lisp -'(1 . 2) -@result{} -(1 . 2) -'(foo . bar) -@result{} -(foo . bar) -@end lisp - -A new pair is made by calling the procedure @code{cons} with two -arguments. Then the argument values are stored into a newly allocated -pair, and the pair is returned. The name @code{cons} stands for -@emph{construct}. Use the procedure @code{pair?} to test whether a -given Scheme object is a pair or not. - -@rnindex cons -@deffn primitive cons x y -Return a newly allocated pair whose car is @var{x} and whose -cdr is @var{y}. The pair is guaranteed to be different (in the -sense of @code{eq?}) from every previously existing object. -@end deffn - -@rnindex pair? -@deffn primitive pair? x -Return @code{#t} if @var{x} is a pair; otherwise return -@code{#f}. -@end deffn - -The two parts of a pair are traditionally called @emph{car} and -@emph{cdr}. They can be retrieved with procedures of the same name -(@code{car} and @code{cdr}), and can be modified with the procedures -@code{set-car!} and @code{set-cdr!}. Since a very common operation in -Scheme programs is to access the car of a pair, or the car of the cdr of -a pair, etc., the procedures called @code{caar}, @code{cadr} and so on -are also predefined. - -@rnindex car -@rnindex cdr -@deffn primitive car pair -@deffnx primitive cdr pair -Return the car or the cdr of @var{pair}, respectively. -@end deffn - -@deffn primitive caar pair -@deffnx primitive cadr pair @dots{} -@deffnx primitive cdddar pair -@deffnx primitive cddddr pair -These procedures are compositions of @code{car} and @code{cdr}, where -for example @code{caddr} could be defined by - -@lisp -(define caddr (lambda (x) (car (cdr (cdr x))))) -@end lisp -@end deffn - -@rnindex set-car! -@deffn primitive set-car! pair value -Stores @var{value} in the car field of @var{pair}. The value returned -by @code{set-car!} is unspecified. -@end deffn - -@rnindex set-cdr! -@deffn primitive set-cdr! pair value -Stores @var{value} in the cdr field of @var{pair}. The value returned -by @code{set-cdr!} is unspecified. -@end deffn - - -@node Lists -@section Lists -@tpindex Lists - -@c FIXME::martin: Review me! - -A very important data type in Scheme---as well as in all other Lisp -dialects---is the data type @dfn{list}.@footnote{Strictly speaking, -Scheme does not have a real datatype @emph{list}. Lists are made up of -chained @emph{pairs}, and only exist by definition---a list is a chain -of pairs which looks like a list.} - -This is the short definition of what a list is: - -@itemize @bullet -@item -Either the empty list @code{()}, - -@item -or a pair which has a list in its cdr. -@end itemize - -@c FIXME::martin: Describe the pair chaining in more detail. - -@c FIXME::martin: What is a proper, what an improper list? -@c What is a circular list? - -@c FIXME::martin: Maybe steal some graphics from the Elisp reference -@c manual? - -@menu -* List Syntax:: Writing literal lists. -* List Predicates:: Testing lists. -* List Constructors:: Creating new lists. -* List Selection:: Selecting from lists, getting their length. -* Append/Reverse:: Appending and reversing lists. -* List Modifification:: Modifying list structure. -* List Searching:: Searching for list elements -* List Mapping:: Applying procedures to lists. -@end menu - -@node List Syntax -@subsection List Read Syntax - -@c FIXME::martin: Review me! - -The syntax for lists is an opening parentheses, then all the elements of -the list (separated by whitespace) and finally a closing -parentheses.@footnote{Note that there is no separation character between -the list elements, like a comma or a semicolon.}. - -@lisp -(1 2 3) ; @r{a list of the numbers 1, 2 and 3} -("foo" bar 3.1415) ; @r{a string, a symbol and a real number} -() ; @r{the empty list} -@end lisp - -The last example needs a bit more explanation. A list with no elements, -called the @dfn{empty list}, is special in some ways. It is used for -terminating lists by storing it into the cdr of the last pair that makes -up a list. An example will clear that up: - -@lisp -(car '(1)) -@result{} -1 -(cdr '(1)) -@result{} -() -@end lisp - -This example also shows that lists have to be quoted (REFFIXME) when -written, because they would otherwise be mistakingly taken as procedure -applications (@pxref{Simple Invocation}). - - -@node List Predicates -@subsection List Predicates - -@c FIXME::martin: Review me! - -Often it is useful to test whether a given Scheme object is a list or -not. List-processing procedures could use this information to test -whether their input is valid, or they could do different things -depending on the datatype of their arguments. - -@rnindex list? -@deffn primitive list? x -Return @code{#t} iff @var{x} is a proper list, else @code{#f}. -@end deffn - -The predicate @code{null?} is often used in list-processing code to -tell whether a given list has run out of elements. That is, a loop -somehow deals with the elements of a list until the list satisfies -@code{null?}. Then, teh algorithm terminates. - -@rnindex null? -@deffn primitive null? x -Return @code{#t} iff @var{x} is the empty list, else @code{#f}. -@end deffn - -@node List Constructors -@subsection List Constructors - -This section describes the procedures for constructing new lists. -@code{list} simply returns a list where the elements are the arguments, -@code{cons*} is similar, but the last argument is stored in the cdr of -the last pair of the list. - -@rnindex list -@deffn primitive list arg1 @dots{} -Return a list containing @var{objs}, the arguments to -@code{list}. -@end deffn - -@deffn primitive cons* arg1 arg2 @dots{} -Like @code{list}, but the last arg provides the tail of the -constructed list, returning @code{(cons @var{arg1} (cons -@var{arg2} (cons @dots{} @var{argn})))}. Requires at least one -argument. If given one argument, that argument is returned as -result. This function is called @code{list*} in some other -Schemes and in Common LISP. -@end deffn - -@deffn primitive list-copy lst -Return a (newly-created) copy of @var{lst}. -@end deffn - -@deffn procedure make-list n [init] -Create a list containing of @var{n} elements, where each element is -initialized to @var{init}. @var{init} defaults to the empty list -@code{()} if not given. -@end deffn - -Note that @code{list-copy} only makes a copy of the pairs which make up -the spine of the lists. The list elements are not copied, which means -that modifying the elements of the new list also modyfies the elements -of the old list. On the other hand, applying procedures like -@code{set-cdr!} or @code{delv!} to the new list will not alter the old -list. If you also need to copy the list elements (making a deep copy), -use the procedure @code{copy-tree} (@pxref{Copying}). - -@node List Selection -@subsection List Selection - -@c FIXME::martin: Review me! - -These procedures are used to get some information about a list, or to -retrieve one or more elements of a list. - -@rnindex length -@deffn primitive length lst -Return the number of elements in list @var{lst}. -@end deffn - -@deffn primitive last-pair lst -Return a pointer to the last pair in @var{lst}, signalling an error if -@var{lst} is circular. -@end deffn - -@rnindex list-ref -@deffn primitive list-ref list k -Return the @var{k}th element from @var{list}. -@end deffn - -@rnindex list-tail -@deffn primitive list-tail lst k -@deffnx primitive list-cdr-ref lst k -Return the "tail" of @var{lst} beginning with its @var{k}th element. -The first element of the list is considered to be element 0. - -@code{list-tail} and @code{list-cdr-ref} are identical. It may help to -think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list, -or returning the results of cdring @var{k} times down @var{lst}. -@end deffn - -@deffn primitive list-head lst k -Copy the first @var{k} elements from @var{lst} into a new list, and -return it. -@end deffn - -@node Append/Reverse -@subsection Append and Reverse - -@c FIXME::martin: Review me! - -@code{append} and @code{append!} are used to concatenate two or more -lists in order to form a new list. @code{reverse} and @code{reverse!} -return lists with the same elements as their arguments, but in reverse -order. The procedure variants with an @code{!} directly modify the -pairs which form the list, whereas the other procedures create new -pairs. This is why you should be careful when using the side-effecting -variants. - -@rnindex append -@deffn primitive append . args -Return a list consisting of the elements the lists passed as -arguments. -@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. -@lisp -(append '(a b) '(c . d)) @result{} (a b c . d) -(append '() 'a) @result{} a -@end lisp -@end deffn - -@deffn primitive append! . 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. -@end deffn - -@rnindex reverse -@deffn primitive reverse lst -Return a new list that contains the elements of @var{lst} but -in reverse order. -@end deffn - -@c NJFIXME explain new_tail -@deffn primitive reverse! 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. - -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!} -@end deffn - -@node List Modifification -@subsection List Modification - -@c FIXME::martin: Review me! - -The following procedures modify existing list. @code{list-set!} and -@code{list-cdr-set!} change which elements a list contains, the various -deletion procedures @code{delq}, @code{delv} etc. - -@deffn primitive list-set! list k val -Set the @var{k}th element of @var{list} to @var{val}. -@end deffn - -@deffn primitive list-cdr-set! list k val -Set the @var{k}th cdr of @var{list} to @var{val}. -@end deffn - -@deffn primitive delq item lst -Return a newly-created copy of @var{lst} with elements -@code{eq?} to @var{item} removed. This procedure mirrors -@code{memq}: @code{delq} compares elements of @var{lst} against -@var{item} with @code{eq?}. -@end deffn - -@deffn primitive delv item lst -Return a newly-created copy of @var{lst} with elements -@code{eqv?} to @var{item} removed. This procedure mirrors -@code{memv}: @code{delv} compares elements of @var{lst} against -@var{item} with @code{eqv?}. -@end deffn - -@deffn primitive delete item lst -Return a newly-created copy of @var{lst} with elements -@code{equal?} to @var{item} removed. This procedure mirrors -@code{member}: @code{delete} compares elements of @var{lst} -against @var{item} with @code{equal?}. -@end deffn - -@deffn primitive delq! item lst -@deffnx primitive delv! item lst -@deffnx primitive delete! item lst -These procedures are destructive versions of @code{delq}, @code{delv} -and @code{delete}: they modify the pointers in the existing @var{lst} -rather than creating a new list. Caveat evaluator: Like other -destructive list functions, these functions cannot modify the binding of -@var{lst}, and so cannot be used to delete the first element of -@var{lst} destructively. -@end deffn - -@deffn primitive delq1! item lst -Like @code{delq!}, but only deletes the first occurrence of -@var{item} from @var{lst}. Tests for equality using -@code{eq?}. See also @code{delv1!} and @code{delete1!}. -@end deffn - -@deffn primitive delv1! item lst -Like @code{delv!}, but only deletes the first occurrence of -@var{item} from @var{lst}. Tests for equality using -@code{eqv?}. See also @code{delq1!} and @code{delete1!}. -@end deffn - -@deffn primitive delete1! item lst -Like @code{delete!}, but only deletes the first occurrence of -@var{item} from @var{lst}. Tests for equality using -@code{equal?}. See also @code{delq1!} and @code{delv1!}. -@end deffn - -@node List Searching -@subsection List Searching - -@c FIXME::martin: Review me! - -The following procedures search lists for particular elements. They use -different comparison predicates for comparing list elements with the -object to be seached. When they fail, they return @code{#f}, otherwise -they return the sublist whose car is equal to the search object, where -equality depends on the equality predicate used. - -@rnindex memq -@deffn primitive memq x lst -Return the first sublist of @var{lst} whose car is @code{eq?} -to @var{x} where the sublists of @var{lst} are the non-empty -lists returned by @code{(list-tail @var{lst} @var{k})} for -@var{k} less than the length of @var{lst}. If @var{x} does not -occur in @var{lst}, then @code{#f} (not the empty list) is -returned. -@end deffn - -@rnindex memv -@deffn primitive memv x lst -Return the first sublist of @var{lst} whose car is @code{eqv?} -to @var{x} where the sublists of @var{lst} are the non-empty -lists returned by @code{(list-tail @var{lst} @var{k})} for -@var{k} less than the length of @var{lst}. If @var{x} does not -occur in @var{lst}, then @code{#f} (not the empty list) is -returned. -@end deffn - -@rnindex member -@deffn primitive member x lst -Return the first sublist of @var{lst} whose car is -@code{equal?} to @var{x} where the sublists of @var{lst} are -the non-empty lists returned by @code{(list-tail @var{lst} -@var{k})} for @var{k} less than the length of @var{lst}. If -@var{x} does not occur in @var{lst}, then @code{#f} (not the -empty list) is returned. -@end deffn - -[FIXME: is there any reason to have the `sloppy' functions available at -high level at all? Maybe these docs should be relegated to a "Guile -Internals" node or something. -twp] - -@deffn primitive sloppy-memq x lst -This procedure behaves like @code{memq}, but does no type or error checking. -Its use is recommended only in writing Guile internals, -not for high-level Scheme programs. -@end deffn - -@deffn primitive sloppy-memv x lst -This procedure behaves like @code{memv}, but does no type or error checking. -Its use is recommended only in writing Guile internals, -not for high-level Scheme programs. -@end deffn - -@deffn primitive sloppy-member x lst -This procedure behaves like @code{member}, but does no type or error checking. -Its use is recommended only in writing Guile internals, -not for high-level Scheme programs. -@end deffn - -@node List Mapping -@subsection List Mapping - -@c FIXME::martin: Review me! - -List processing is very convenient in Scheme because the process of -iterating over the elements of a list can be highly abstracted. The -procedures in this section are the most basic iterating procedures for -lists. They take a procedure and one or more lists as arguments, and -apply the procedure to each element of the list. They differ in what -the result of the invocation is. - -@rnindex map -@c begin (texi-doc-string "guile" "map") -@deffn primitive map proc arg1 arg2 @dots{} -@deffnx primitive map-in-order proc arg1 arg2 @dots{} -Apply @var{proc} to each element of the list @var{arg1} (if only two -arguments are given), or to the corresponding elements of the argument -lists (if more than two arguments are given). The result(s) of the -procedure applications are saved and returned in a list. For -@code{map}, the order of procedure applications is not specified, -@code{map-in-order} applies the procedure from left to right to the list -elements. -@end deffn - -@rnindex for-each -@c begin (texi-doc-string "guile" "for-each") -@deffn primitive for-each proc arg1 arg2 @dots{} -Like @code{map}, but the procedure is always applied from left to right, -and the result(s) of the procedure applications are thrown away. The -return value is not specified. -@end deffn - - -@node Vectors -@section Vectors -@tpindex Vectors - -@c FIXME::martin: Review me! - -@c FIXME::martin: Should the subsections of this section be nodes -@c of their own, or are the resulting nodes too short, then? - -Vectors are sequences of Scheme objects. Unlike lists, the length of a -vector, once the vector is created, cannot be changed. The advantage of -vectors over lists is that the time required to access one element of a -vector is constant, whereas lists have an access time linear to the -index of the accessed element in the list. - -Note that the vectors documented in this section can contain any kind of -Scheme object, it is even possible to have different types of objects in -the same vector. - -@subsection Vector Read Syntax - -Vectors can literally be entered in source code, just like strings, -characters or some of the other data types. The read syntax for vectors -is as follows: A sharp sign (@code{#}), followed by an opening -parentheses, all elements of the vector in their respective read syntax, -and finally a closing parentheses. The following are examples of the -read syntax for vectors; where the first vector only contains numbers -and the second three different object types: a string, a symbol and a -number in hexidecimal notation. - -@lisp -#(1 2 3) -#("Hello" foo #xdeadbeef) -@end lisp - -@subsection Vector Predicates - -@rnindex vector? -@deffn primitive vector? obj -Return @code{#t} if @var{obj} is a vector, otherwise return -@code{#f}. -@end deffn - -@subsection Vector Constructors - -@rnindex make-vector -@deffn primitive make-vector k [fill] -Return a newly allocated vector of @var{k} elements. If a -second argument is given, then each element is initialized to -@var{fill}. Otherwise the initial contents of each element is -unspecified. -@end deffn - -@rnindex vector -@rnindex list->vector -@deffn primitive vector . l -@deffnx primitive list->vector l -Return a newly allocated vector whose elements contain the -given arguments. Analogous to @code{list}. - -@lisp -(vector 'a 'b 'c) @result{} #(a b c) -@end lisp -@end deffn - -@rnindex vector->list -@deffn primitive vector->list v -Return a newly allocated list of the objects contained in the -elements of @var{vector}. - -@lisp -(vector->list '#(dah dah didah)) @result{} (dah dah didah) -(list->vector '(dididit dah)) @result{} #(dididit dah) -@end lisp -@end deffn - -@subsection Vector Modification - -A vector created by any of the vector constructor procedures -(@pxref{Vectors}) documented above can be modified using the -following procedures. - -According to R5RS, using any of these procedures on literally entered -vectors is an error, because these vectors are considered to be -constant, although Guile currently does not detect this error. - -@rnindex vector-set! -@deffn primitive vector-set! vector k obj -@var{k} must be a valid index of @var{vector}. -@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}. -The value returned by @samp{vector-set!} is unspecified. -@lisp -(let ((vec (vector 0 '(2 2 2 2) "Anna"))) - (vector-set! vec 1 '("Sue" "Sue")) - vec) @result{} #(0 ("Sue" "Sue") "Anna") -(vector-set! '#(0 1 2) 1 "doe") @result{} @emph{error} ; constant vector -@end lisp -@end deffn - -@rnindex vector-fill! -@deffn primitive vector-fill! v fill -Store @var{fill} in every element of @var{vector}. The value -returned by @code{vector-fill!} is unspecified. -@end deffn - -@deffn primitive vector-move-left! vec1 start1 end1 vec2 start2 -Vector version of @code{substring-move-left!}. -@end deffn - -@deffn primitive vector-move-right! vec1 start1 end1 vec2 start2 -Vector version of @code{substring-move-right!}. -@end deffn - -@subsection Vector Selection - -These procedures return information about a given vector, such as the -size or what elements are contained in the vector. - -@rnindex vector-length -@deffn primitive vector-length vector -Returns the number of elements in @var{vector} as an exact integer. -@end deffn - -@rnindex vector-ref -@deffn primitive vector-ref vector k -@var{k} must be a valid index of @var{vector}. -@samp{Vector-ref} returns the contents of element @var{k} of -@var{vector}. -@lisp -(vector-ref '#(1 1 2 3 5 8 13 21) 5) @result{} 8 -(vector-ref '#(1 1 2 3 5 8 13 21) - (let ((i (round (* 2 (acos -1))))) - (if (inexact? i) - (inexact->exact i) - i))) @result{} 13 -@end lisp -@end deffn - - -@node Records -@section Records - -[FIXME: this is pasted in from Tom Lord's original guile.texi and should -be reviewed] - -A @dfn{record type} is a first class object representing a user-defined -data type. A @dfn{record} is an instance of a record type. - -@deffn procedure record? obj -Returns @code{#t} if @var{obj} is a record of any type and @code{#f} -otherwise. - -Note that @code{record?} may be true of any Scheme value; there is no -promise that records are disjoint with other Scheme types. -@end deffn - -@deffn procedure make-record-type type-name field-names -Returns a @dfn{record-type descriptor}, a value representing a new data -type disjoint from all others. The @var{type-name} argument must be a -string, but is only used for debugging purposes (such as the printed -representation of a record of the new type). The @var{field-names} -argument is a list of symbols naming the @dfn{fields} of a record of the -new type. It is an error if the list contains any duplicates. It is -unspecified how record-type descriptors are represented.@refill -@end deffn - -@deffn procedure record-constructor rtd [field-names] -Returns a procedure for constructing new members of the type represented -by @var{rtd}. The returned procedure accepts exactly as many arguments -as there are symbols in the given list, @var{field-names}; these are -used, in order, as the initial values of those fields in a new record, -which is returned by the constructor procedure. The values of any -fields not named in that list are unspecified. The @var{field-names} -argument defaults to the list of field names in the call to -@code{make-record-type} that created the type represented by @var{rtd}; -if the @var{field-names} argument is provided, it is an error if it -contains any duplicates or any symbols not in the default list.@refill -@end deffn - -@deffn procedure record-predicate rtd -Returns a procedure for testing membership in the type represented by -@var{rtd}. The returned procedure accepts exactly one argument and -returns a true value if the argument is a member of the indicated record -type; it returns a false value otherwise.@refill -@end deffn - -@deffn procedure record-accessor rtd field-name -Returns a procedure for reading the value of a particular field of a -member of the type represented by @var{rtd}. The returned procedure -accepts exactly one argument which must be a record of the appropriate -type; it returns the current value of the field named by the symbol -@var{field-name} in that record. The symbol @var{field-name} must be a -member of the list of field-names in the call to @code{make-record-type} -that created the type represented by @var{rtd}.@refill -@end deffn - -@deffn procedure record-modifier rtd field-name -Returns a procedure for writing the value of a particular field of a -member of the type represented by @var{rtd}. The returned procedure -accepts exactly two arguments: first, a record of the appropriate type, -and second, an arbitrary Scheme value; it modifies the field named by -the symbol @var{field-name} in that record to contain the given value. -The returned value of the modifier procedure is unspecified. The symbol -@var{field-name} must be a member of the list of field-names in the call -to @code{make-record-type} that created the type represented by -@var{rtd}.@refill -@end deffn - -@deffn procedure record-type-descriptor record -Returns a record-type descriptor representing the type of the given -record. That is, for example, if the returned descriptor were passed to -@code{record-predicate}, the resulting predicate would return a true -value when passed the given record. Note that it is not necessarily the -case that the returned descriptor is the one that was passed to -@code{record-constructor} in the call that created the constructor -procedure that created the given record.@refill -@end deffn - -@deffn procedure record-type-name rtd -Returns the type-name associated with the type represented by rtd. The -returned value is @code{eqv?} to the @var{type-name} argument given in -the call to @code{make-record-type} that created the type represented by -@var{rtd}.@refill -@end deffn - -@deffn procedure record-type-fields rtd -Returns a list of the symbols naming the fields in members of the type -represented by @var{rtd}. The returned value is @code{equal?} to the -field-names argument given in the call to @code{make-record-type} that -created the type represented by @var{rtd}.@refill -@end deffn - - -@node Structures -@section Structures -@tpindex Structures - -[FIXME: this is pasted in from Tom Lord's original guile.texi and should -be reviewed] - -A @dfn{structure type} is a first class user-defined data type. A -@dfn{structure} is an instance of a structure type. A structure type is -itself a structure. - -Structures are less abstract and more general than traditional records. -In fact, in Guile Scheme, records are implemented using structures. - -@menu -* Structure Concepts:: The structure of Structures -* Structure Layout:: Defining the layout of structure types -* Structure Basics:: make-, -ref and -set! procedures for structs -* Vtables:: Accessing type-specific data -@end menu - -@node Structure Concepts -@subsection Structure Concepts - -A structure object consists of a handle, structure data, and a vtable. -The handle is a Scheme value which points to both the vtable and the -structure's data. Structure data is a dynamically allocated region of -memory, private to the structure, divided up into typed fields. A -vtable is another structure used to hold type-specific data. Multiple -structures can share a common vtable. - -Three concepts are key to understanding structures. - -@itemize @bullet{} -@item @dfn{layout specifications} - -Layout specifications determine how memory allocated to structures is -divided up into fields. Programmers must write a layout specification -whenever a new type of structure is defined. - -@item @dfn{structural accessors} - -Structure access is by field number. There is only one set of -accessors common to all structure objects. - -@item @dfn{vtables} - -Vtables, themselves structures, are first class representations of -disjoint sub-types of structures in general. In most cases, when a -new structure is created, programmers must specifiy a vtable for the -new structure. Each vtable has a field describing the layout of its -instances. Vtables can have additional, user-defined fields as well. -@end itemize - - - -@node Structure Layout -@subsection Structure Layout - -When a structure is created, a region of memory is allocated to hold its -state. The @dfn{layout} of the structure's type determines how that -memory is divided into fields. - -Each field has a specified type. There are only three types allowed, each -corresponding to a one letter code. The allowed types are: - -@itemize @bullet{} -@item 'u' -- unprotected - -The field holds binary data that is not GC protected. - -@item 'p' -- protected - -The field holds a Scheme value and is GC protected. - -@item 's' -- self - -The field holds a Scheme value and is GC protected. When a structure is -created with this type of field, the field is initialized to refer to -the structure's own handle. This kind of field is mainly useful when -mixing Scheme and C code in which the C code may need to compute a -structure's handle given only the address of its malloced data. -@end itemize - - -Each field also has an associated access protection. There are only -three kinds of protection, each corresponding to a one letter code. -The allowed protections are: - -@itemize @bullet{} -@item 'w' -- writable - -The field can be read and written. - -@item 'r' -- readable - -The field can be read, but not written. - -@item 'o' -- opaque - -The field can be neither read nor written. This kind -of protection is for fields useful only to built-in routines. -@end itemize - -A layout specification is described by stringing together pairs -of letters: one to specify a field type and one to specify a field -protection. For example, a traditional cons pair type object could -be described as: - -@example -; cons pairs have two writable fields of Scheme data -"pwpw" -@end example - -A pair object in which the first field is held constant could be: - -@example -"prpw" -@end example - -Binary fields, (fields of type "u"), hold one @emph{word} each. The -size of a word is a machine dependent value defined to be equal to the -value of the C expression: @code{sizeof (long)}. - -The last field of a structure layout may specify a tail array. -A tail array is indicated by capitalizing the field's protection -code ('W', 'R' or 'O'). A tail-array field is replaced by -a read-only binary data field containing an array size. The array -size is determined at the time the structure is created. It is followed -by a corresponding number of fields of the type specified for the -tail array. For example, a conventional Scheme vector can be -described as: - -@example -; A vector is an arbitrary number of writable fields holding Scheme -; values: -"pW" -@end example - -In the above example, field 0 contains the size of the vector and -fields beginning at 1 contain the vector elements. - -A kind of tagged vector (a constant tag followed by conventioal -vector elements) might be: - -@example -"prpW" -@end example - - -Structure layouts are represented by specially interned symbols whose -name is a string of type and protection codes. To create a new -structure layout, use this procedure: - -@deffn primitive make-struct-layout fields -Return a new structure layout object. - -@var{fields} must be a string made up of pairs of characters -strung together. The first character of each pair describes a field -type, the second a field protection. Allowed types are 'p' for -GC-protected Scheme data, 'u' for unprotected binary data, and 's' for -a field that points to the structure itself. Allowed protections -are 'w' for mutable fields, 'r' for read-only fields, and 'o' for opaque -fields. The last field protection specification may be capitalized to -indicate that the field is a tail-array. -@end deffn - - - -@node Structure Basics -@subsection Structure Basics - -This section describes the basic procedures for creating and accessing -structures. - -@deffn primitive make-struct vtable tail_array_size . init -Create a new structure. - -@var{type} must be a vtable structure (@pxref{Vtables}). - -@var{tail-elts} must be a non-negative integer. If the layout -specification indicated by @var{type} includes a tail-array, -this is the number of elements allocated to that array. - -The @var{init1}, @dots{} are optional arguments describing how -successive fields of the structure should be initialized. Only fields -with protection 'r' or 'w' can be initialized, except for fields of -type 's', which are automatically initialized to point to the new -structure itself; fields with protection 'o' can not be initialized by -Scheme programs. - -If fewer optional arguments than initializable fields are supplied, -fields of type 'p' get default value #f while fields of type 'u' are -initialized to 0. - -Structs are currently the basic representation for record-like data -structures in Guile. The plan is to eventually replace them with a -new representation which will at the same time be easier to use and -more powerful. - -For more information, see the documentation for @code{make-vtable-vtable}. -@end deffn - -@deffn primitive struct? x -Return @code{#t} iff @var{obj} is a structure object, else -@code{#f}. -@end deffn - - -@deffn primitive struct-ref handle pos -@deffnx primitive struct-set! struct n value -Access (or modify) the @var{n}th field of @var{struct}. - -If the field is of type 'p', then it can be set to an arbitrary value. - -If the field is of type 'u', then it can only be set to a non-negative -integer value small enough to fit in one machine word. -@end deffn - - - -@node Vtables -@subsection Vtables - -Vtables are structures that are used to represent structure types. Each -vtable contains a layout specification in field -@code{vtable-index-layout} -- instances of the type are laid out -according to that specification. Vtables contain additional fields -which are used only internally to libguile. The variable -@code{vtable-offset-user} is bound to a field number. Vtable fields -at that position or greater are user definable. - -@deffn primitive struct-vtable handle -Return the vtable structure that describes the type of @var{struct}. -@end deffn - -@deffn primitive struct-vtable? x -Return @code{#t} iff obj is a vtable structure. -@end deffn - -If you have a vtable structure, @code{V}, you can create an instance of -the type it describes by using @code{(make-struct V ...)}. But where -does @code{V} itself come from? One possibility is that @code{V} is an -instance of a user-defined vtable type, @code{V'}, so that @code{V} is -created by using @code{(make-struct V' ...)}. Another possibility is -that @code{V} is an instance of the type it itself describes. Vtable -structures of the second sort are created by this procedure: - -@deffn primitive make-vtable-vtable user_fields tail_array_size . init -Return a new, self-describing vtable structure. - -@var{user-fields} is a string describing user defined fields of the -vtable beginning at index @code{vtable-offset-user} -(see @code{make-struct-layout}). - -@var{tail-size} specifies the size of the tail-array (if any) of -this vtable. - -@var{init1}, @dots{} are the optional initializers for the fields of -the vtable. - -Vtables have one initializable system field---the struct printer. -This field comes before the user fields in the initializers passed -to @code{make-vtable-vtable} and @code{make-struct}, and thus works as -a third optional argument to @code{make-vtable-vtable} and a fourth to -@code{make-struct} when creating vtables: - -If the value is a procedure, it will be called instead of the standard -printer whenever a struct described by this vtable is printed. -The procedure will be called with arguments STRUCT and PORT. - -The structure of a struct is described by a vtable, so the vtable is -in essence the type of the struct. The vtable is itself a struct with -a vtable. This could go on forever if it weren't for the -vtable-vtables which are self-describing vtables, and thus terminate -the chain. - -There are several potential ways of using structs, but the standard -one is to use three kinds of structs, together building up a type -sub-system: one vtable-vtable working as the root and one or several -"types", each with a set of "instances". (The vtable-vtable should be -compared to the class which is the class of itself.) - -@lisp -(define ball-root (make-vtable-vtable "pr" 0)) - -(define (make-ball-type ball-color) - (make-struct ball-root 0 - (make-struct-layout "pw") - (lambda (ball port) - (format port "#" - (color ball) - (owner ball))) - ball-color)) -(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user)) -(define (owner ball) (struct-ref ball 0)) - -(define red (make-ball-type 'red)) -(define green (make-ball-type 'green)) - -(define (make-ball type owner) (make-struct type 0 owner)) - -(define ball (make-ball green 'Nisse)) -ball @result{} # -@end lisp -@end deffn - -@deffn primitive struct-vtable-name vtable -Return the name of the vtable @var{vtable}. -@end deffn - -@deffn primitive set-struct-vtable-name! vtable name -Set the name of the vtable @var{vtable} to @var{name}. -@end deffn - -@deffn primitive struct-vtable-tag handle -Return the vtable tag of the structure @var{handle}. -@end deffn - - -@node Arrays -@section Arrays -@tpindex Arrays - -@menu -* Conventional Arrays:: Arrays with arbitrary data. -* Array Mapping:: Applying a procedure to the contents of an array. -* Uniform Arrays:: Arrays with data of a single type. -* Bit Vectors:: Vectors of bits. -@end menu - -@node Conventional Arrays -@subsection Conventional Arrays - -@dfn{Conventional arrays} are a collection of cells organised into an -arbitrary number of dimensions. Each cell can hold any kind of Scheme -value and can be accessed in constant time by supplying an index for -each dimension. This contrasts with uniform arrays, which use memory -more efficiently but can hold data of only a single type, and lists -where inserting and deleting cells is more efficient, but more time -is usually required to access a particular cell. - -A conventional array is displayed as @code{#} followed by the @dfn{rank} -(number of dimensions) followed by the cells, organised into dimensions -using parentheses. The nesting depth of the parentheses is equal to -the rank. - -When an array is created, the number of dimensions and range of each -dimension must be specified, e.g., to create a 2x3 array with a -zero-based index: - -@example -(make-array 'ho 2 3) @result{} -#2((ho ho ho) (ho ho ho)) -@end example - -The range of each dimension can also be given explicitly, e.g., another -way to create the same array: - -@example -(make-array 'ho '(0 1) '(0 2)) @result{} -#2((ho ho ho) (ho ho ho)) -@end example - -A conventional array with one dimension based at zero is identical to -a vector: - -@example -(make-array 'ho 3) @result{} -#(ho ho ho) -@end example - -The following procedures can be used with conventional arrays (or vectors). - -@deffn primitive array? v [prot] -Return @code{#t} if the @var{obj} is an array, and @code{#f} if -not. The @var{prototype} argument is used with uniform arrays -and is described elsewhere. -@end deffn - -@deffn procedure make-array initial-value bound1 bound2 @dots{} -Creates and returns an array that has as many dimensions as there are -@var{bound}s and fills it with @var{initial-value}. -@end deffn - -@c array-ref's type is `compiled-closure'. There's some weird stuff -@c going on in array.c, too. Let's call it a primitive. -twp - -@deffn primitive uniform-vector-ref v args -@deffnx primitive array-ref v . args -Return the element at the @code{(index1, index2)} element in -@var{array}. -@end deffn - -@deffn primitive array-in-bounds? v . args -Return @code{#t} if its arguments would be acceptable to -@code{array-ref}. -@end deffn - -@deffn primitive array-set! v obj . args -@deffnx primitive uniform-array-set1! v obj args -Sets the element at the @code{(index1, index2)} element in @var{array} to -@var{new-value}. The value returned by array-set! is unspecified. -@end deffn - -@deffn primitive make-shared-array oldra mapfunc . dims -@code{make-shared-array} can be used to create shared subarrays of other -arrays. The @var{mapper} is a function that translates coordinates in -the new array into coordinates in the old array. A @var{mapper} must be -linear, and its range must stay within the bounds of the old array, but -it can be otherwise arbitrary. A simple example: -@lisp -(define fred (make-array #f 8 8)) -(define freds-diagonal - (make-shared-array fred (lambda (i) (list i i)) 8)) -(array-set! freds-diagonal 'foo 3) -(array-ref fred 3 3) @result{} foo -(define freds-center - (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2)) -(array-ref freds-center 0 0) @result{} foo -@end lisp -@end deffn - -@deffn primitive shared-array-increments ra -For each dimension, return the distance between elements in the root vector. -@end deffn - -@deffn primitive shared-array-offset ra -Return the root vector index of the first element in the array. -@end deffn - -@deffn primitive shared-array-root ra -Return the root vector of a shared array. -@end deffn - -@deffn primitive transpose-array ra . args -Return an array sharing contents with @var{array}, but with -dimensions arranged in a different order. There must be one -@var{dim} argument for each dimension of @var{array}. -@var{dim0}, @var{dim1}, @dots{} should be integers between 0 -and the rank of the array to be returned. Each integer in that -range must appear at least once in the argument list. - -The values of @var{dim0}, @var{dim1}, @dots{} correspond to -dimensions in the array to be returned, their positions in the -argument list to dimensions of @var{array}. Several @var{dim}s -may have the same value, in which case the returned array will -have smaller rank than @var{array}. - -@lisp -(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d)) -(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d) -(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{} - #2((a 4) (b 5) (c 6)) -@end lisp -@end deffn - -@deffn primitive enclose-array ra . axes -@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than -the rank of @var{array}. @var{enclose-array} returns an array -resembling an array of shared arrays. The dimensions of each shared -array are the same as the @var{dim}th dimensions of the original array, -the dimensions of the outer array are the same as those of the original -array that did not match a @var{dim}. - -An enclosed array is not a general Scheme array. Its elements may not -be set using @code{array-set!}. Two references to the same element of -an enclosed array will be @code{equal?} but will not in general be -@code{eq?}. The value returned by @var{array-prototype} when given an -enclosed array is unspecified. - -examples: -@lisp -(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{} - # - -(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{} - # -@end lisp -@end deffn - -@deffn procedure array-shape array -Returns a list of inclusive bounds of integers. -@example -(array-shape (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) (0 4)) -@end example -@end deffn - -@deffn primitive array-dimensions ra -@code{Array-dimensions} is similar to @code{array-shape} but replaces -elements with a @code{0} minimum with one greater than the maximum. So: -@lisp -(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5) -@end lisp -@end deffn - -@deffn primitive array-rank ra -Return the number of dimensions of @var{obj}. If @var{obj} is -not an array, @code{0} is returned. -@end deffn - -@deffn primitive array->list v -Return a list consisting of all the elements, in order, of -@var{array}. -@end deffn - -@deffn primitive array-copy! src dst -@deffnx primitive array-copy-in-order! src dst -Copies every element from vector or array @var{source} to the -corresponding element of @var{destination}. @var{destination} must have -the same rank as @var{source}, and be at least as large in each -dimension. The order is unspecified. -@end deffn - -@deffn primitive array-fill! ra fill -Stores @var{fill} in every element of @var{array}. The value returned -is unspecified. -@end deffn - -@c begin (texi-doc-string "guile" "array-equal?") -@deffn primitive array-equal? ra0 ra1 -Returns @code{#t} iff all arguments are arrays with the same shape, the -same type, and have corresponding elements which are either -@code{equal?} or @code{array-equal?}. This function differs from -@code{equal?} in that a one dimensional shared array may be -@var{array-equal?} but not @var{equal?} to a vector or uniform vector. -@end deffn - -@deffn primitive array-contents ra [strict] -@deffnx primitive array-contents array strict -If @var{array} may be @dfn{unrolled} into a one dimensional shared array -without changing their order (last subscript changing fastest), then -@code{array-contents} returns that shared array, otherwise it returns -@code{#f}. All arrays made by @var{make-array} and -@var{make-uniform-array} may be unrolled, some arrays made by -@var{make-shared-array} may not be. - -If the optional argument @var{strict} is provided, a shared array will -be returned only if its elements are stored internally contiguous in -memory. -@end deffn - -@node Array Mapping -@subsection Array Mapping - -@deffn primitive array-map! ra0 proc . lra -@deffnx primitive array-map-in-order! ra0 proc . lra -@var{array1}, @dots{} must have the same number of dimensions as -@var{array0} and have a range for each index which includes the range -for the corresponding index in @var{array0}. @var{proc} is applied to -each tuple of elements of @var{array1} @dots{} and the result is stored -as the corresponding element in @var{array0}. The value returned is -unspecified. The order of application is unspecified. -@end deffn - -@deffn primitive array-for-each proc ra0 . lra -@var{proc} is applied to each tuple of elements of @var{array0} @dots{} -in row-major order. The value returned is unspecified. -@end deffn - -@deffn primitive array-index-map! ra proc -applies @var{proc} to the indices of each element of @var{array} in -turn, storing the result in the corresponding element. The value -returned and the order of application are unspecified. - -One can implement @var{array-indexes} as -@lisp -(define (array-indexes array) - (let ((ra (apply make-array #f (array-shape array)))) - (array-index-map! ra (lambda x x)) - ra)) -@end lisp -Another example: -@lisp -(define (apl:index-generator n) - (let ((v (make-uniform-vector n 1))) - (array-index-map! v (lambda (i) i)) - v)) -@end lisp -@end deffn - -@node Uniform Arrays -@subsection Uniform Arrays -@tpindex Uniform Arrays - -@noindent -@dfn{Uniform arrays} have elements all of the -same type and occupy less storage than conventional -arrays. Uniform arrays with a single zero-based dimension -are also known as @dfn{uniform vectors}. The procedures in -this section can also be used on conventional arrays, vectors, -bit-vectors and strings. - -@noindent -When creating a uniform array, the type of data to be stored -is indicated with a @var{prototype} argument. The following table -lists the types available and example prototypes: - -@example -prototype type printing character - -#t boolean (bit-vector) b -#\a char (string) a -#\nul byte (integer) y -'s short (integer) h -1 unsigned long (integer) u --1 signed long (integer) e -'l signed long long (integer) l -1.0 float (single precision) s -1/3 double (double precision float) i -0+i complex (double precision) c -() conventional vector -@end example - -@noindent -Unshared uniform arrays of characters with a single zero-based dimension -are identical to strings: - -@example -(make-uniform-array #\a 3) @result{} -"aaa" -@end example - -@noindent -Unshared uniform arrays of booleans with a single zero-based dimension -are identical to @ref{Bit Vectors, bit-vectors}. - -@example -(make-uniform-array #t 3) @result{} -#*111 -@end example - -@noindent -Other uniform vectors are written in a form similar to that of vectors, -except that a single character from the above table is put between -@code{#} and @code{(}. For example, a uniform vector of signed -long integers is displayed in the form @code{'#e(3 5 9)}. - -@deffn primitive array? v [prot] -Returns @code{#t} if the @var{obj} is an array, and @code{#f} if not. - -The @var{prototype} argument is used with uniform arrays and is described -elsewhere. -@end deffn - -@deffn procedure make-uniform-array prototype bound1 bound2 @dots{} -Creates and returns a uniform array of type corresponding to -@var{prototype} that has as many dimensions as there are @var{bound}s -and fills it with @var{prototype}. -@end deffn - -@deffn primitive array-prototype ra -Return an object that would produce an array of the same type -as @var{array}, if used as the @var{prototype} for -@code{make-uniform-array}. -@end deffn - -@deffn primitive list->uniform-array ndim prot lst -@deffnx procedure list->uniform-vector prot lst -Return a uniform array of the type indicated by prototype -@var{prot} with elements the same as those of @var{lst}. -Elements must be of the appropriate type, no coercions are -done. -@end deffn - -@deffn primitive uniform-vector-fill! uve fill -Stores @var{fill} in every element of @var{uve}. The value returned is -unspecified. -@end deffn - -@deffn primitive uniform-vector-length v -Return the number of elements in @var{uve}. -@end deffn - -@deffn primitive dimensions->uniform-array dims prot [fill] -@deffnx primitive make-uniform-vector length prototype [fill] -Create and return a uniform array or vector of type -corresponding to @var{prototype} with dimensions @var{dims} or -length @var{length}. If @var{fill} is supplied, it's used to -fill the array, otherwise @var{prototype} is used. -@end deffn - -@c Another compiled-closure. -twp - -@deffn primitive uniform-array-read! ra [port_or_fd [start [end]]] -@deffnx primitive uniform-vector-read! uve [port-or-fdes] [start] [end] -Attempts to read all elements of @var{ura}, in lexicographic order, as -binary objects from @var{port-or-fdes}. -If an end of file is encountered during -uniform-array-read! the objects up to that point only are put into @var{ura} -(starting at the beginning) and the remainder of the array is -unchanged. - -The optional arguments @var{start} and @var{end} allow -a specified region of a vector (or linearized array) to be read, -leaving the remainder of the vector unchanged. - -@code{uniform-array-read!} returns the number of objects read. -@var{port-or-fdes} may be omitted, in which case it defaults to the value -returned by @code{(current-input-port)}. -@end deffn - -@deffn primitive uniform-array-write v [port_or_fd [start [end]]] -@deffnx primitive uniform-vector-write uve [port-or-fdes] [start] [end] -Writes all elements of @var{ura} as binary objects to -@var{port-or-fdes}. - -The optional arguments @var{start} -and @var{end} allow -a specified region of a vector (or linearized array) to be written. - -The number of objects actually written is returned. -@var{port-or-fdes} may be -omitted, in which case it defaults to the value returned by -@code{(current-output-port)}. -@end deffn - -@node Bit Vectors -@subsection Bit Vectors - -@noindent -Bit vectors are a specific type of uniform array: an array of booleans -with a single zero-based index. - -@noindent -They are displayed as a sequence of @code{0}s and -@code{1}s prefixed by @code{#*}, e.g., - -@example -(make-uniform-vector 8 #t #f) @result{} -#*00000000 - -#b(#t #f #t) @result{} -#*101 -@end example - -@deffn primitive bit-count b bitvector -Return the number of occurrences of the boolean @var{b} in -@var{bitvector}. -@end deffn - -@deffn primitive bit-position item v k -Return the minimum index of an occurrence of @var{bool} in -@var{bv} which is at least @var{k}. If no @var{bool} occurs -within the specified range @code{#f} is returned. -@end deffn - -@deffn primitive bit-invert! v -Modifies @var{bv} by replacing each element with its negation. -@end deffn - -@deffn primitive bit-set*! v kv obj -If uve is a bit-vector @var{bv} and uve must be of the same -length. If @var{bool} is @code{#t}, uve is OR'ed into -@var{bv}; If @var{bool} is @code{#f}, the inversion of uve is -AND'ed into @var{bv}. - -If uve is a unsigned long integer vector all the elements of uve -must be between 0 and the @code{length} of @var{bv}. The bits -of @var{bv} corresponding to the indexes in uve are set to -@var{bool}. The return value is unspecified. -@end deffn - -@deffn primitive bit-count* v kv obj -Return -@lisp -(bit-count (bit-set*! (if bool bv (bit-invert! bv)) uve #t) #t). -@end lisp -@var{bv} is not modified. -@end deffn - - -@node Association Lists and Hash Tables -@section Association Lists and Hash Tables - -This chapter discusses dictionary objects: data structures that are -useful for organizing and indexing large bodies of information. - -@menu -* Dictionary Types:: About dictionary types; what they're good for. -* Association Lists:: List-based dictionaries. -* Hash Tables:: Table-based dictionaries. -@end menu - -@node Dictionary Types -@subsection Dictionary Types - -A @dfn{dictionary} object is a data structure used to index -information in a user-defined way. In standard Scheme, the main -aggregate data types are lists and vectors. Lists are not really -indexed at all, and vectors are indexed only by number -(e.g. @code{(vector-ref foo 5)}). Often you will find it useful -to index your data on some other type; for example, in a library -catalog you might want to look up a book by the name of its -author. Dictionaries are used to help you organize information in -such a way. - -An @dfn{association list} (or @dfn{alist} for short) is a list of -key-value pairs. Each pair represents a single quantity or -object; the @code{car} of the pair is a key which is used to -identify the object, and the @code{cdr} is the object's value. - -A @dfn{hash table} also permits you to index objects with -arbitrary keys, but in a way that makes looking up any one object -extremely fast. A well-designed hash system makes hash table -lookups almost as fast as conventional array or vector references. - -Alists are popular among Lisp programmers because they use only -the language's primitive operations (lists, @dfn{car}, @dfn{cdr} -and the equality primitives). No changes to the language core are -necessary. Therefore, with Scheme's built-in list manipulation -facilities, it is very convenient to handle data stored in an -association list. Also, alists are highly portable and can be -easily implemented on even the most minimal Lisp systems. - -However, alists are inefficient, especially for storing large -quantities of data. Because we want Guile to be useful for large -software systems as well as small ones, Guile provides a rich set -of tools for using either association lists or hash tables. - -@node Association Lists -@subsection Association Lists -@tpindex Association Lists -@tpindex Alist - -@cindex Association List -@cindex Alist -@cindex Database - -An association list is a conventional data structure that is often used -to implement simple key-value databases. It consists of a list of -entries in which each entry is a pair. The @dfn{key} of each entry is -the @code{car} of the pair and the @dfn{value} of each entry is the -@code{cdr}. - -@example -ASSOCIATION LIST ::= '( (KEY1 . VALUE1) - (KEY2 . VALUE2) - (KEY3 . VALUE3) - @dots{} - ) -@end example - -@noindent -Association lists are also known, for short, as @dfn{alists}. - -The structure of an association list is just one example of the infinite -number of possible structures that can be built using pairs and lists. -As such, the keys and values in an association list can be manipulated -using the general list structure procedures @code{cons}, @code{car}, -@code{cdr}, @code{set-car!}, @code{set-cdr!} and so on. However, -because association lists are so useful, Guile also provides specific -procedures for manipulating them. - -@menu -* Alist Key Equality:: -* Adding or Setting Alist Entries:: -* Retrieving Alist Entries:: -* Removing Alist Entries:: -* Sloppy Alist Functions:: -* Alist Example:: -@end menu - -@node Alist Key Equality -@subsubsection Alist Key Equality - -All of Guile's dedicated association list procedures, apart from -@code{acons}, come in three flavours, depending on the level of equality -that is required to decide whether an existing key in the association -list is the same as the key that the procedure call uses to identify the -required entry. - -@itemize @bullet -@item -Procedures with @dfn{assq} in their name use @code{eq?} to determine key -equality. - -@item -Procedures with @dfn{assv} in their name use @code{eqv?} to determine -key equality. - -@item -Procedures with @dfn{assoc} in their name use @code{equal?} to -determine key equality. -@end itemize - -@code{acons} is an exception because it is used to build association -lists which do not require their entries' keys to be unique. - -@node Adding or Setting Alist Entries -@subsubsection Adding or Setting Alist Entries - -@code{acons} adds a new entry to an association list and returns the -combined association list. The combined alist is formed by consing the -new entry onto the head of the alist specified in the @code{acons} -procedure call. So the specified alist is not modified, but its -contents become shared with the tail of the combined alist that -@code{acons} returns. - -In the most common usage of @code{acons}, a variable holding the -original association list is updated with the combined alist: - -@example -(set! address-list (acons name address address-list)) -@end example - -In such cases, it doesn't matter that the old and new values of -@code{address-list} share some of their contents, since the old value is -usually no longer independently accessible. - -Note that @code{acons} adds the specified new entry regardless of -whether the alist may already contain entries with keys that are, in -some sense, the same as that of the new entry. Thus @code{acons} is -ideal for building alists where there is no concept of key uniqueness. - -@example -(set! task-list (acons 3 "pay gas bill" '())) -task-list -@result{} -((3 . "pay gas bill")) - -(set! task-list (acons 3 "tidy bedroom" task-list)) -task-list -@result{} -((3 . "tidy bedroom") (3 . "pay gas bill")) -@end example - -@code{assq-set!}, @code{assv-set!} and @code{assoc-set!} are used to add -or replace an entry in an association list where there @emph{is} a -concept of key uniqueness. If the specified association list already -contains an entry whose key is the same as that specified in the -procedure call, the existing entry is replaced by the new one. -Otherwise, the new entry is consed onto the head of the old association -list to create the combined alist. In all cases, these procedures -return the combined alist. - -@code{assq-set!} and friends @emph{may} destructively modify the -structure of the old association list in such a way that an existing -variable is correctly updated without having to @code{set!} it to the -value returned: - -@example -address-list -@result{} -(("mary" . "34 Elm Road") ("james" . "16 Bow Street")) - -(assoc-set! address-list "james" "1a London Road") -@result{} -(("mary" . "34 Elm Road") ("james" . "1a London Road")) - -address-list -@result{} -(("mary" . "34 Elm Road") ("james" . "1a London Road")) -@end example - -Or they may not: - -@example -(assoc-set! address-list "bob" "11 Newington Avenue") -@result{} -(("bob" . "11 Newington Avenue") ("mary" . "34 Elm Road") - ("james" . "1a London Road")) - -address-list -@result{} -(("mary" . "34 Elm Road") ("james" . "1a London Road")) -@end example - -The only safe way to update an association list variable when adding or -replacing an entry like this is to @code{set!} the variable to the -returned value: - -@example -(set! address-list - (assoc-set! address-list "bob" "11 Newington Avenue")) -address-list -@result{} -(("bob" . "11 Newington Avenue") ("mary" . "34 Elm Road") - ("james" . "1a London Road")) -@end example - -Because of this slight inconvenience, you may find it more convenient to -use hash tables to store dictionary data. If your application will not -be modifying the contents of an alist very often, this may not make much -difference to you. - -If you need to keep the old value of an association list in a form -independent from the list that results from modification by -@code{acons}, @code{assq-set!}, @code{assv-set!} or @code{assoc-set!}, -use @code{list-copy} to copy the old association list before modifying -it. - -@deffn primitive acons key value alist -Adds a new key-value pair to @var{alist}. A new pair is -created whose car is @var{key} and whose cdr is @var{value}, and the -pair is consed onto @var{alist}, and the new list is returned. This -function is @emph{not} destructive; @var{alist} is not modified. -@end deffn - -@deffn primitive assq-set! alist key val -@deffnx primitive assv-set! alist key value -@deffnx primitive assoc-set! alist key value -Reassociate @var{key} in @var{alist} with @var{value}: find any existing -@var{alist} entry for @var{key} and associate it with the new -@var{value}. If @var{alist} does not contain an entry for @var{key}, -add a new one. Return the (possibly new) alist. - -These functions do not attempt to verify the structure of @var{alist}, -and so may cause unusual results if passed an object that is not an -association list. -@end deffn - -@node Retrieving Alist Entries -@subsubsection Retrieving Alist Entries -@rnindex assq -@rnindex assv -@rnindex assoc - -@code{assq}, @code{assv} and @code{assoc} take an alist and a key as -arguments and return the entry for that key if an entry exists, or -@code{#f} if there is no entry for that key. Note that, in the cases -where an entry exists, these procedures return the complete entry, that -is @code{(KEY . VALUE)}, not just the value. - -@deffn primitive assq key alist -@deffnx primitive assv key alist -@deffnx primitive assoc key alist -Fetches the entry in @var{alist} that is associated with @var{key}. To -decide whether the argument @var{key} matches a particular entry in -@var{alist}, @code{assq} compares keys with @code{eq?}, @code{assv} -uses @code{eqv?} and @code{assoc} uses @code{equal?}. If @var{key} -cannot be found in @var{alist} (according to whichever equality -predicate is in use), then @code{#f} is returned. These functions -return the entire alist entry found (i.e. both the key and the value). -@end deffn - -@code{assq-ref}, @code{assv-ref} and @code{assoc-ref}, on the other -hand, take an alist and a key and return @emph{just the value} for that -key, if an entry exists. If there is no entry for the specified key, -these procedures return @code{#f}. - -This creates an ambiguity: if the return value is @code{#f}, it means -either that there is no entry with the specified key, or that there -@emph{is} an entry for the specified key, with value @code{#f}. -Consequently, @code{assq-ref} and friends should only be used where it -is known that an entry exists, or where the ambiguity doesn't matter -for some other reason. - -@deffn primitive assq-ref alist key -@deffnx primitive assv-ref alist key -@deffnx primitive assoc-ref alist key -Like @code{assq}, @code{assv} and @code{assoc}, except that only the -value associated with @var{key} in @var{alist} is returned. These -functions are equivalent to - -@lisp -(let ((ent (@var{associator} @var{key} @var{alist}))) - (and ent (cdr ent))) -@end lisp - -where @var{associator} is one of @code{assq}, @code{assv} or @code{assoc}. -@end deffn - -@node Removing Alist Entries -@subsubsection Removing Alist Entries - -To remove the element from an association list whose key matches a -specified key, use @code{assq-remove!}, @code{assv-remove!} or -@code{assoc-remove!} (depending, as usual, on the level of equality -required between the key that you specify and the keys in the -association list). - -As with @code{assq-set!} and friends, the specified alist may or may not -be modified destructively, and the only safe way to update a variable -containing the alist is to @code{set!} it to the value that -@code{assq-remove!} and friends return. - -@example -address-list -@result{} -(("bob" . "11 Newington Avenue") ("mary" . "34 Elm Road") - ("james" . "1a London Road")) - -(set! address-list (assoc-remove! address-list "mary")) -address-list -@result{} -(("bob" . "11 Newington Avenue") ("james" . "1a London Road")) -@end example - -Note that, when @code{assq/v/oc-remove!} is used to modify an -association list that has been constructed only using the corresponding -@code{assq/v/oc-set!}, there can be at most one matching entry in the -alist, so the question of multiple entries being removed in one go does -not arise. If @code{assq/v/oc-remove!} is applied to an association -list that has been constructed using @code{acons}, or an -@code{assq/v/oc-set!} with a different level of equality, or any mixture -of these, it removes only the first matching entry from the alist, even -if the alist might contain further matching entries. For example: - -@example -(define address-list '()) -(set! address-list (assq-set! address-list "mary" "11 Elm Street")) -(set! address-list (assq-set! address-list "mary" "57 Pine Drive")) -address-list -@result{} -(("mary" . "57 Pine Drive") ("mary" . "11 Elm Street")) - -(set! address-list (assoc-remove! address-list "mary")) -address-list -@result{} -(("mary" . "11 Elm Street")) -@end example - -In this example, the two instances of the string "mary" are not the same -when compared using @code{eq?}, so the two @code{assq-set!} calls add -two distinct entries to @code{address-list}. When compared using -@code{equal?}, both "mary"s in @code{address-list} are the same as the -"mary" in the @code{assoc-remove!} call, but @code{assoc-remove!} stops -after removing the first matching entry that it finds, and so one of the -"mary" entries is left in place. - -@deffn primitive assq-remove! alist key -@deffnx primitive assv-remove! alist key -@deffnx primitive assoc-remove! alist key -Delete the first entry in @var{alist} associated with @var{key}, and return -the resulting alist. -@end deffn - -@node Sloppy Alist Functions -@subsubsection Sloppy Alist Functions - -@code{sloppy-assq}, @code{sloppy-assv} and @code{sloppy-assoc} behave -like the corresponding non-@code{sloppy-} procedures, except that they -return @code{#f} when the specified association list is not well-formed, -where the non-@code{sloppy-} versions would signal an error. - -Specifically, there are two conditions for which the non-@code{sloppy-} -procedures signal an error, which the @code{sloppy-} procedures handle -instead by returning @code{#f}. Firstly, if the specified alist as a -whole is not a proper list: - -@example -(assoc "mary" '((1 . 2) ("key" . "door") . "open sesame")) -@result{} -ERROR: In procedure assoc in expression (assoc "mary" (quote #)): -ERROR: Wrong type argument in position 2 (expecting NULLP): "open sesame" -ABORT: (wrong-type-arg) - -(sloppy-assoc "mary" '((1 . 2) ("key" . "door") . "open sesame")) -@result{} -#f -@end example - -@noindent -Secondly, if one of the entries in the specified alist is not a pair: - -@example -(assoc 2 '((1 . 1) 2 (3 . 9))) -@result{} -ERROR: In procedure assoc in expression (assoc 2 (quote #)): -ERROR: Wrong type argument in position 2 (expecting CONSP): 2 -ABORT: (wrong-type-arg) - -(sloppy-assoc 2 '((1 . 1) 2 (3 . 9))) -@result{} -#f -@end example - -Unless you are explicitly working with badly formed association lists, -it is much safer to use the non-@code{sloppy-} procedures, because they -help to highlight coding and data errors that the @code{sloppy-} -versions would silently cover up. - -@deffn primitive sloppy-assq key alist -Behaves like @code{assq} but does not do any error checking. -Recommended only for use in Guile internals. -@end deffn - -@deffn primitive sloppy-assv key alist -Behaves like @code{assv} but does not do any error checking. -Recommended only for use in Guile internals. -@end deffn - -@deffn primitive sloppy-assoc key alist -Behaves like @code{assoc} but does not do any error checking. -Recommended only for use in Guile internals. -@end deffn - -@node Alist Example -@subsubsection Alist Example - -Here is a longer example of how alists may be used in practice. - -@lisp -(define capitals '(("New York" . "Albany") - ("Oregon" . "Salem") - ("Florida" . "Miami"))) - -;; What's the capital of Oregon? -(assoc "Oregon" capitals) @result{} ("Oregon" . "Salem") -(assoc-ref capitals "Oregon") @result{} "Salem" - -;; We left out South Dakota. -(set! capitals - (assoc-set! capitals "South Dakota" "Bismarck")) -capitals -@result{} (("South Dakota" . "Bismarck") - ("New York" . "Albany") - ("Oregon" . "Salem") - ("Florida" . "Miami")) - -;; And we got Florida wrong. -(set! capitals - (assoc-set! capitals "Florida" "Tallahassee")) -capitals -@result{} (("South Dakota" . "Bismarck") - ("New York" . "Albany") - ("Oregon" . "Salem") - ("Florida" . "Tallahassee")) - -;; After Oregon secedes, we can remove it. -(set! capitals - (assoc-remove! capitals "Oregon")) -capitals -@result{} (("South Dakota" . "Bismarck") - ("New York" . "Albany") - ("Florida" . "Tallahassee")) -@end lisp - -@node Hash Tables -@subsection Hash Tables -@tpindex Hash Tables - -@c FIXME::martin: Review me! - -Hash tables are dictionaries which offer similar functionality as -association lists: They provide a mapping from keys to values. The -difference is that association lists need time linear in the size of -elements when searching for entries, whereas hash tables can normally -search in constant time. The drawback is that hash tables require a -little bit more memory, and that you can not use the normal list -procedures (@pxref{Lists}) for working with them. - -@menu -* Hash Table Examples:: Demonstration of hash table usage. -* Hash Table Reference:: Hash table procedure descriptions. -@end menu - - -@node Hash Table Examples -@subsubsection Hash Table Examples - -@c FIXME::martin: Review me! - -For demonstration purposes, this section gives a few usage examples of -some hash table procedures, together with some explanation what they do. - -First we start by creating a new hash table with 31 slots, and -populate it with two key/value pairs. - -@lisp -(define h (make-hash-table 31)) - -(hashq-create-handle! h 'foo "bar") -@result{} -(foo . "bar") - -(hashq-create-handle! h 'braz "zonk") -@result{} -(braz . "zonk") - -(hashq-create-handle! h 'frob #f) -@result{} -(frob . #f) -@end lisp - -You can get the value for a given key with the procedure -@code{hashq-ref}, but the problem with this procedure is that you -cannot reliably determine whether a key does exists in the table. The -reason is that the procedure returns @code{#f} if the key is not in -the table, but it will return the same value if the key is in the -table and just happens to have the value @code{#f}, as you can see in -the following examples. - -@lisp -(hashq-ref h 'foo) -@result{} -"bar" - -(hashq-ref h 'frob) -@result{} -#f - -(hashq-ref h 'not-there) -@result{} -#f -@end lisp - -Better is to use the procedure @code{hashq-get-handle}, which makes a -distinction between the two cases. Just like @code{assq}, this -procedure returns a key/value-pair on success, and @code{#f} if the -key is not found. - -@lisp -(hashq-get-handle h 'foo) -@result{} -(foo . "bar") - -(hashq-get-handle h 'not-there) -@result{} -#f -@end lisp - -There is no procedure for calculating the number of key/value-pairs in -a hash table, but @code{hash-fold} can be used for doing exactly that. - -@lisp -(hash-fold (lambda (key value seed) (+ 1 seed)) 0 h) -@result{} -3 -@end lisp - -@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?}. - -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. - -@deffn 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 - -@deffn primitive 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 - -@deffn primitive 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. -@end deffn - -@deffn primitive 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 primitive hashq-set! 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 primitive hashv-set! table key val -Find the entry in @var{table} associated with @var{key}, and -store @var{value} there. Uses @code{eqv?} for equality testing. -@end deffn - -@deffn primitive hash-set! 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 primitive hashq-remove! table key -Remove @var{key} (and any value associated with it) from -@var{table}. Uses @code{eq?} for equality tests. -@end deffn - -@deffn primitive hashv-remove! table key -Remove @var{key} (and any value associated with it) from -@var{table}. Uses @code{eqv?} for equality tests. -@end deffn - -@deffn primitive hash-remove! 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 primitive hashq key size -Determine a hash value for @var{key} that is suitable for -lookups in a hashtable 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 primitive hashv key size -Determine a hash value for @var{key} that is suitable for -lookups in a hashtable 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. -@end deffn - -@deffn primitive hash key size -Determine a hash value for @var{key} that is suitable for -lookups in a hashtable 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 - -@deffn primitive 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}. - -By way of illustration, @code{hashq-ref table key} is -equivalent to @code{hashx-ref hashq assq table key}. -@end deffn - -@deffn primitive hashx-set! 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 primitive 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 primitive 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. -@end deffn - -@deffn primitive 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 primitive 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 primitive hashq-create-handle! 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 primitive hashv-create-handle! 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 primitive hash-create-handle! 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 primitive hashx-create-handle! 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}. -@end deffn - -@deffn primitive 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. -@end deffn - - -@node Hooks -@section Hooks -@tpindex Hooks - -@c FIXME::martin: Review me! - -A hook is basically a list of procedures to be called at well defined -points in time. Hooks are used internally for several debugging -facilities, but they can be used in user code, too. - -Hooks are created with @code{make-hook}, then procedures can be added to -a hook with @code{add-hook!} or removed with @code{remove-hook!} or -@code{reset-hook!}. The procedures stored in a hook can be invoked with -@code{run-hook}. - -@menu -* Hook Examples:: Hook usage by example. -* Hook Reference:: Reference of all hook procedures. -@end menu - -@node Hook Examples -@subsection Hook Examples - -Hook usage is shown by some examples in this section. First, we will -define a hook of arity 2 --- that is, the procedures stored in the hook -will have to accept two arguments. - -@lisp -(define hook (make-hook 2)) -hook -@result{} # -@end lisp - -Now we are ready to add some procedures to the newly created hook with -@code{add-hook!}. In the following example, two procedures are added, -which print different messages and do different things with their -arguments. When the procedures have been added, we can invoke them -using @code{run-hook}. - -@lisp -(add-hook! hook (lambda (x y) - (display "Foo: ") - (display (+ x y)) - (newline))) -(add-hook! hook (lambda (x y) - (display "Bar: ") - (display (* x y)) - (newline))) -(run-hook hook 3 4) -@print{} Bar: 12 -@print{} Foo: 7 -@end lisp - -Note that the procedures are called in reverse order than they were -added. This can be changed by providing the optional third argument -on the second call to @code{add-hook!}. - -@lisp -(add-hook! hook (lambda (x y) - (display "Foo: ") - (display (+ x y)) - (newline))) -(add-hook! hook (lambda (x y) - (display "Bar: ") - (display (* x y)) - (newline)) - #t) ; @r{<- Change here!} -(run-hook hook 3 4) -@print{} Foo: 7 -@print{} Bar: 12 -@end lisp - -@node Hook Reference -@subsection Hook Reference - -When a hook is created with @code{make-hook}, you can supply the arity -of the procedures which can be added to the hook. The arity defaults to -zero. All procedures of a hook must have the same arity, and when the -procedures are invoked using @code{run-hook}, the number of arguments -must match the arity of the procedures. - -The order in which procedures are added to a hook matters. If the third -parameter to @var{add-hook!} is omitted or is equal to @code{#f}, the -procedure is added in front of the procedures which might already be on -that hook, otherwise the procedure is added at the end. The procedures -are always called from first to last when they are invoked via -@code{run-hook}. - -When calling @code{hook->list}, the procedures in the resulting list are -in the same order as they would have been called by @code{run-hook}. - -@deffn primitive make-hook-with-name name [n_args] -Create a named hook with the name @var{name} for storing -procedures of arity @var{n_args}. @var{n_args} defaults to -zero. -@end deffn - -@deffn primitive make-hook [n_args] -Create a hook for storing procedure of arity -@var{n_args}. @var{n_args} defaults to zero. -@end deffn - -@deffn primitive hook? x -Return @code{#t} if @var{x} is a hook, @code{#f} otherwise. -@end deffn - -@deffn primitive hook-empty? hook -Return @code{#t} if @var{hook} is an empty hook, @code{#f} -otherwise. -@end deffn - -@deffn primitive add-hook! hook proc [append_p] -Add the procedure @var{proc} to the hook @var{hook}. The -procedure is added to the end if @var{append_p} is true, -otherwise it is added to the front. -@end deffn - -@deffn primitive remove-hook! hook proc -Remove the procedure @var{proc} from the hook @var{hook}. -@end deffn - -@deffn primitive reset-hook! hook -Remove all procedures from the hook @var{hook}. -@end deffn - -@deffn primitive run-hook hook . args -Apply all procedures from the hook @var{hook} to the arguments -@var{args}. The order of the procedure application is first to -last. -@end deffn - -@deffn primitive hook->list hook -Convert the procedure list of @var{hook} to a list. -@end deffn - - -@node Other Data Types -@section Other Core Guile Data Types - -@c Local Variables: -@c TeX-master: "guile.texi" -@c End: From f91e4547f4f314f89f327d86056c8f76edd3cea2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Wed, 4 Jul 2001 06:13:10 +0000 Subject: [PATCH 1444/2047] * hooks.c (scm_make_hook, scm_add_hook_x), (scm_remove_hook_x, scm_reset_hook_x, scm_run_hook): Added return value info to the docstrings. --- libguile/ChangeLog | 8 +++++++- libguile/hooks.c | 16 ++++++++++------ 2 files changed, 17 insertions(+), 7 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 007aa4f74..e98b7c43a 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2001-07-04 Martin Grabmueller + + * hooks.c (scm_make_hook, scm_add_hook_x), + (scm_remove_hook_x, scm_reset_hook_x, scm_run_hook): Added return + value info to the docstrings. + 2001-07-03 Martin Grabmueller Some more compatibility patches for Windows. @@ -29,7 +35,7 @@ last. * gc.c (s_scm_map_free_list, scm_igc, scm_gc_sweep, - init_heap_seg): Fixed signedness. + init_heap_seg): Fixed signedness. (init_heap_seg): Replaced strange for-loop with a while loop. diff --git a/libguile/hooks.c b/libguile/hooks.c index e57aeb6d5..f7945b02c 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -187,8 +187,9 @@ scm_create_hook (const char *name, int n_args) SCM_DEFINE (scm_make_hook, "make-hook", 0, 1, 0, (SCM n_args), - "Create a hook for storing procedure of arity\n" - "@var{n_args}. @var{n_args} defaults to zero.") + "Create a hook for storing procedure of arity @var{n_args}.\n" + "@var{n_args} defaults to zero. The returned value is a hook\n" + "object to be used with the other hook procedures.") #define FUNC_NAME s_scm_make_hook { int n; @@ -235,7 +236,8 @@ SCM_DEFINE (scm_add_hook_x, "add-hook!", 2, 1, 0, (SCM hook, SCM proc, SCM append_p), "Add the procedure @var{proc} to the hook @var{hook}. The\n" "procedure is added to the end if @var{append_p} is true,\n" - "otherwise it is added to the front.") + "otherwise it is added to the front. The return value of this\n" + "procedure is not specified.") #define FUNC_NAME s_scm_add_hook_x { SCM arity, rest; @@ -261,7 +263,8 @@ SCM_DEFINE (scm_add_hook_x, "add-hook!", 2, 1, 0, SCM_DEFINE (scm_remove_hook_x, "remove-hook!", 2, 0, 0, (SCM hook, SCM proc), - "Remove the procedure @var{proc} from the hook @var{hook}.") + "Remove the procedure @var{proc} from the hook @var{hook}. The\n" + "return value of this procedure is not specified.") #define FUNC_NAME s_scm_remove_hook_x { SCM_VALIDATE_HOOK (1, hook); @@ -274,7 +277,8 @@ SCM_DEFINE (scm_remove_hook_x, "remove-hook!", 2, 0, 0, SCM_DEFINE (scm_reset_hook_x, "reset-hook!", 1, 0, 0, (SCM hook), - "Remove all procedures from the hook @var{hook}.") + "Remove all procedures from the hook @var{hook}. The return\n" + "value of this procedure is not specified.") #define FUNC_NAME s_scm_reset_hook_x { SCM_VALIDATE_HOOK (1,hook); @@ -288,7 +292,7 @@ SCM_DEFINE (scm_run_hook, "run-hook", 1, 0, 1, (SCM hook, SCM args), "Apply all procedures from the hook @var{hook} to the arguments\n" "@var{args}. The order of the procedure application is first to\n" - "last.") + "last. The return value of this procedure is not specified.") #define FUNC_NAME s_scm_run_hook { SCM_VALIDATE_HOOK (1,hook); From b4d2a48e9ddbb44cad5ccc53dd561e9bc9073d52 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Fri, 6 Jul 2001 14:00:13 +0000 Subject: [PATCH 1445/2047] * srfi-19.scm (priv:locale-reader): don't need open-output-string. --- srfi/srfi-19.scm | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/srfi/srfi-19.scm b/srfi/srfi-19.scm index a059bc825..d95ba9a5c 100644 --- a/srfi/srfi-19.scm +++ b/srfi/srfi-19.scm @@ -1362,18 +1362,18 @@ ;; looking at a char, read the char string, run thru indexer, return index (define (priv:locale-reader port indexer) - (let ((string-port (open-output-string))) - (define (read-char-string) - (let ((ch (peek-char port))) - (if (char-alphabetic? ch) - (begin (write-char (read-char port) string-port) - (read-char-string)) - (get-output-string string-port)))) - (let* ((str (read-char-string)) - (index (indexer str))) - (if index index (priv:time-error 'string->date - 'bad-date-template-string - (list "Invalid string for " indexer)))))) + + (define (read-char-string result) + (let ((ch (peek-char port))) + (if (char-alphabetic? ch) + (read-char-string (cons (read-char port) result)) + (list->string (reverse! result))))) + + (let* ((str (read-char-string '())) + (index (indexer str))) + (if index index (priv:time-error 'string->date + 'bad-date-template-string + (list "Invalid string for " indexer))))) (define (priv:make-locale-reader indexer) (lambda (port) From 0d6209aa9e5539a266ce1d87bb2b1b9b9a0ddd01 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Fri, 6 Jul 2001 14:00:21 +0000 Subject: [PATCH 1446/2047] *** empty log message *** --- srfi/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 3996b49e2..e3df581d6 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,7 @@ +2001-07-06 Rob Browning + + * srfi-19.scm (priv:locale-reader): don't need open-output-string. + 2001-07-03 Gary Houston * srfi-1.scm (iota, map, for-each, list-index, member, delete, From 600c9584853d28f734c5769e2f039fd1e32836c8 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Fri, 6 Jul 2001 17:38:40 +0000 Subject: [PATCH 1447/2047] * boot-9.scm: added fix suggested by Matthias for #. read extension -- now only works if read-eval? is not #f. --- ice-9/boot-9.scm | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index ac2e48681..8d00cd988 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -779,8 +779,15 @@ (read-hash-extend #\' (lambda (c port) (read port))) -(read-hash-extend #\. (lambda (c port) - (eval (read port) (interaction-environment)))) + +(define read-eval? (make-fluid)) +(fluid-set! read-eval? #f) +(read-hash-extend #\. + (lambda (c port) + (if (fluid-ref read-eval?) + (eval (read port) (interaction-environment)) + (error + "#. read expansion found and read-eval? is not #f.")))) ;;; {Command Line Options} From 8630fdfc37910b6d3762493c1c03ca5ede644282 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Fri, 6 Jul 2001 17:39:12 +0000 Subject: [PATCH 1448/2047] *** empty log message *** --- NEWS | 11 +++++++++++ ice-9/ChangeLog | 5 +++++ 2 files changed, 16 insertions(+) diff --git a/NEWS b/NEWS index 86625f209..4b10cbb28 100644 --- a/NEWS +++ b/NEWS @@ -37,6 +37,17 @@ The new configure option `--enable-deprecated=LEVEL' and the environment variable GUILE_WARN_DEPRECATED control this mechanism. See INSTALL and README for more information. +** The #. reader extension is now disabled by default. + +For safety reasons, #. evaluation is disabled by default. To +re-enable it, set the fluid read-eval? to #t. For example: + + (fluid-set read-eval? #t) + +but make sure you realize the potential security risks involved. With +read-eval? enabled, reading a data file from an untrusted source can +be dangerous. + ** New SRFI modules have been added: SRFI-0 `cond-expand' is now supported in Guile, without requiring diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 72be35b8e..20b0a25e6 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2001-07-06 Rob Browning + + * boot-9.scm: added fix suggested by Matthias for #. read + extension -- now only works if read-eval? is not #f. + 2001-06-30 Dirk Herrmann * arrays.scm: Don't install a read-hash-extension for 'b': #b From 1b5132c4ab08a1af60cd867f0ffa0b360c3f44b3 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 6 Jul 2001 20:04:48 +0000 Subject: [PATCH 1449/2047] Mention AUTHORS maintenance in two places: for contributors and for maintainers (who may also be contributors :-). --- HACKING | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/HACKING b/HACKING index 3baa25e9a..036bf66a9 100644 --- a/HACKING +++ b/HACKING @@ -77,6 +77,8 @@ or diff -u). Don't include a patch for ChangeLog; such patches don't apply cleanly, since we've probably changed the top of ChangeLog too. Instead, provide the unaltered text at the top of your patch. +- For proper credit, also make sure you update the AUTHORS file. + Please don't include patches for generated files like configure, aclocal.m4, or any Makefile.in. Such patches are often large, and we're just going to regenerate those files anyway. @@ -283,7 +285,7 @@ and I'll take care of the administrivia. Put the contributions aside until we have the necessary papers. Once you accept a contribution, be sure to keep the files AUTHORS and -THANKS uptodate. +THANKS uptodate. Feel free to remove authorship info from source files. - When you make substantial changes to a file, add the current year to the list of years in the copyright notice at the top of the file. From 373f4948c5117514a71fbe87ab1e15a138956e49 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Fri, 6 Jul 2001 21:05:20 +0000 Subject: [PATCH 1450/2047] *** empty log message *** --- NEWS | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index 4b10cbb28..6247523a7 100644 --- a/NEWS +++ b/NEWS @@ -154,7 +154,7 @@ can be used for similar functionality. ** New module (ice-9 rw) This is a subset of the (scsh rw) module from guile-scsh. Currently -it defines two single procedures: +it defines two procedures: *** New function: read-string!/partial str [port_or_fdes [start [end]]] @@ -1039,7 +1039,7 @@ Made more compliant with the naming policy by adding a _t at the end. ** Deprecated functions: scm_mkbig, scm_big2num, scm_adjbig, scm_normbig, scm_copybig, scm_2ulong2big, scm_dbl2big, scm_big2dbl -With the exception of the misterious scm_2ulong2big, they are still +With the exception of the mysterious scm_2ulong2big, they are still available under new names (scm_i_mkbig etc). These functions are not intended to be used in user code. You should avoid dealing with bignums directly, and should deal with numbers in general (which can From 99f59e93b517f163b00e3cbe47bc65cd0c209a0b Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Fri, 6 Jul 2001 21:10:47 +0000 Subject: [PATCH 1451/2047] * srfi-1.scm (iota, map, for-each, list-index, member, delete, delete!, assoc): roll back the previous change. instead place dummy definitions in a deprecated block at the beginning as in srfi-13.scm. --- srfi/ChangeLog | 7 +++++++ srfi/srfi-1.scm | 36 +++++++++++++++++++++++------------- srfi/srfi-13.scm | 2 +- 3 files changed, 31 insertions(+), 14 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index e3df581d6..f4a5dc01f 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,10 @@ +2001-07-06 Gary Houston + + * srfi-1.scm (iota, map, for-each, list-index, member, delete, + delete!, assoc): roll back the previous change. instead place + dummy definitions in a deprecated block at the beginning as in + srfi-13.scm. + 2001-07-06 Rob Browning * srfi-19.scm (priv:locale-reader): don't need open-output-string. diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm index cc53adc79..4c361a57e 100644 --- a/srfi/srfi-1.scm +++ b/srfi/srfi-1.scm @@ -60,6 +60,20 @@ :use-module (ice-9 session) :use-module (ice-9 receive)) +(begin-deprecated + ;; Prevent `export' from re-exporting core bindings. This behaviour + ;; of `export' is deprecated and will disappear in one of the next + ;; releases. + (define iota #f) + (define map #f) + (define map-in-order #f) + (define for-each #f) + (define list-index #f) + (define member #f) + (define delete #f) + (define delete! #f) + (define assoc #f)) + (export ;;; Constructors ;; cons <= in the core @@ -70,7 +84,7 @@ list-tabulate ;; list-copy <= in the core circular-list - ;; iota ; exported below + iota ; Extended. ;;; Predicates proper-list? @@ -164,12 +178,12 @@ reduce-right unfold unfold-right - ;; map ; exported below - ;; for-each ; exported below + map ; Extended. + for-each ; Extended. append-map append-map! map! - ;; map-in-order ; exported below + map-in-order ; Extended. pair-for-each filter-map @@ -193,19 +207,19 @@ break! any every - ;; list-index ; exported below. - ;; member ; exported below ; Extended. + list-index ; Extended. + member ; Extended. ;; memq <= in the core ;; memv <= in the core ;;; Deletion -;; delete ; exported below ; Extended. -;; delete! ; exported below + delete ; Extended. + delete! ; Extended. delete-duplicates delete-duplicates! ;;; Association lists - ;; assoc ; exported below ; Extended. + assoc ; Extended. ;; assq <= in the core ;; assv <= in the core alist-cons @@ -1027,7 +1041,3 @@ (define (lset-diff+intersection! = list1 . rest) (apply lset-diff+intersection = list1 rest)) ; XXX:optimize - -;; extended versions of builtin procedures. exporting is delayed until the -;; new bindings have been created. -(export iota map map-in-order for-each list-index member delete delete! assoc) diff --git a/srfi/srfi-13.scm b/srfi/srfi-13.scm index 8fe674f1e..ba1ff6fc1 100644 --- a/srfi/srfi-13.scm +++ b/srfi/srfi-13.scm @@ -45,7 +45,7 @@ (begin-deprecated ;; Prevent `export' from re-exporting core bindings. This behaviour - ;; of `export' is deprecated and will disappear in one f the next + ;; of `export' is deprecated and will disappear in one of the next ;; releases. (define string->list #f) (define string-copy #f) From 7e238e4afb05c516cf4f0b7d931ecb55beab47bd Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 7 Jul 2001 06:24:37 +0000 Subject: [PATCH 1452/2047] In "Contributing Your Changes", distiguish between AUTHORS and THANKS usage. --- HACKING | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/HACKING b/HACKING index 036bf66a9..ddec624c8 100644 --- a/HACKING +++ b/HACKING @@ -77,7 +77,9 @@ or diff -u). Don't include a patch for ChangeLog; such patches don't apply cleanly, since we've probably changed the top of ChangeLog too. Instead, provide the unaltered text at the top of your patch. -- For proper credit, also make sure you update the AUTHORS file. +- For proper credit, also make sure you update the AUTHORS file +(for new files for which you've assigned copyright to the FSF), or +the THANKS file (for everything else). Please don't include patches for generated files like configure, aclocal.m4, or any Makefile.in. Such patches are often large, and From 746dcb4e30dd94b37c1648a98bc82ff4c6838eb6 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 7 Jul 2001 06:31:26 +0000 Subject: [PATCH 1453/2047] (Eventually): Add items from devel/TODO. --- TODO | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/TODO b/TODO index 8c657d604..60d8fad5b 100644 --- a/TODO +++ b/TODO @@ -1,4 +1,4 @@ -[ID: $Id: TODO,v 1.17 2001-06-29 08:10:00 kei Exp $] +[ID: $Id: TODO,v 1.18 2001-07-07 06:31:26 ttn Exp $] These TODO items are grouped by target release version. The first group is the "Eventually" group, which is not associated w/ any particular version. @@ -43,6 +43,24 @@ See also file HACKING. - write Orbit CORBA interface - [after new module system] factor out modules sort.c and random.c should be factored out into separate modules +- include malloc debugging code in an optional file in libguile +- fix looking up procedure names in environment in backtraces +- implement srcprops using double cells +- use "real" procprops +- add facilities for easily debugging Scheme programs from Emacs +- write good interface to Tk +- write translators for additional languages + - Perl + - Python + - TCL + - Emacs Lisp + - Rexx +- make GDB work with Guile +- use the SCM trick of tagging environments with immediates (see m_letrec1) + to convert source correctly in unmemocopy +- eliminate argument checking for closures +- Implement a thread-safe alternative to SCM's environment caches + === In release 1.6.0: From b5b6075c25c7a7f0059628b7160ce663763fd495 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 7 Jul 2001 06:31:44 +0000 Subject: [PATCH 1454/2047] bye bye --- devel/TODO | 0 1 file changed, 0 insertions(+), 0 deletions(-) delete mode 100644 devel/TODO diff --git a/devel/TODO b/devel/TODO deleted file mode 100644 index e69de29bb..000000000 From 6b46d8ba914d7858a02f646f5a1a60f35909a4ae Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 7 Jul 2001 15:36:39 +0000 Subject: [PATCH 1455/2047] Sneak in the translators... --- devel/policy/goals.text | 92 ----------------------------------------- 1 file changed, 92 deletions(-) diff --git a/devel/policy/goals.text b/devel/policy/goals.text index 32ce46b68..e69de29bb 100644 --- a/devel/policy/goals.text +++ b/devel/policy/goals.text @@ -1,92 +0,0 @@ -This file states the goals of Guile. - -* Goals of Guile - -Guile is many things to many people. It has multiple ways to approach -it: as a C library that provides an extension language, as a -programming language in its own right, as a interface to the operating -system, as an interactive shell, or as a platform that integrates many -independent subsystems. - -These different roles have a lot in common, but there are also some -opposing forces that need to be balanced. - -Not everything of what is outlined below has been realized yet. The -things that are missing will receive high priority from the -maintainers of Guile. One thing that is not mentioned below because -it goes without saying is documentation. It is of course a goal of -Guile to have high quality documentation. - -More information about the current status of Guile and planned changed -can be found in the file "plans.text". - -** Guile as an extension language library - -Guile's primary aim is to provide a good extension language which is -easy to add to an application written in C for the GNU system. This -means that it must export the features of a higher level language in a -way that makes it easy not to break them from C code. - -For example, one important feature of Guile is automatic garbage -collection. The C interface to the garbage collector makes it easy to -use its services for the data structures of the application itself. - -** Guile as a programming language - -It is an aim to support easy programming using Guile. This includes -providing the powerful features of the programming language Scheme, -like garbage collection, dynamic types, hygienic macros and higher -order functions. - -This also includes things that go beyond standard Scheme, like a -module system to manage multiple name spaces, a system for object -oriented programming, support for comfortable multi-threading, and -internationalization features like Unicode support. - -To make it useful, Guile offers good performance. - -** Guile as an interface to the operating system - -Guile supports most of the POSIX system calls. Most of Scsh is -available to Guile users and Guile programs. Beyond POSIX, Guile also -makes available important system libraries like the graphical toolkit -Gtk+. - -** Guile as an interactive shell - -Guile provides a command line interface with readline support. The -interactive features of the programming language allow you to -incrementally alter a running system. A integrated debugger allows -you to analyze such a running system in great detail. - -Guile provides online documentation for most of its features. - -Guile can also be controlled from Emacs. This allows you to update -the definition of a function or some other object in a Guile process -with the touch of a few keys. You have access to the documentation in -a context sensitive way. It also integrates the debugger nicely into -your editing environment. - -** Guile as an integration platform - -With all the features describes above, Guile allows the implementation -of well behaved modules. When most of an application is implemented -as modules with generality and re-usability in mind, Guile will be the -platform where the integration and reusing will take place. - -Thus, Guile makes it easy to factor your application into well -separated modules and then finish it off by combining them with a thin -layer of Scheme code. - -Guile has support for writing modules in C or other compiled -languages. - -** Guile as a basis for other languages - -Scheme is a very powerful language, which makes it possible -to implement other languages by translating them into Scheme. - -By writing translators that convert various popular scripting -languages into Scheme, we can enable users to choose their favorite -languages for extending any program that provides extensibility using -Guile. From 0ba803846f62d6416dfa72a7d80556f84ffa86de Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sun, 8 Jul 2001 19:14:33 +0000 Subject: [PATCH 1456/2047] * AUTHORS: add "many files throughout" for myself. --- AUTHORS | 1 + 1 file changed, 1 insertion(+) diff --git a/AUTHORS b/AUTHORS index c4bccb6a8..b4ec70fa5 100644 --- a/AUTHORS +++ b/AUTHORS @@ -129,6 +129,7 @@ Rob Browning: wrote initial srfi/srfi-8.scm. wrote initial srfi/srfi-11.scm. ported srfi/srfi-19.scm to Guile. + and many other changes throughout. Martin Grabmueller: In the subdirectory libguile, changes to: From d6c0a9e00d905795ae60821f21e73e88060f430e Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sun, 8 Jul 2001 19:17:05 +0000 Subject: [PATCH 1457/2047] * .cvsignore: add stamp-h.in. --- libguile/.cvsignore | 1 + 1 file changed, 1 insertion(+) diff --git a/libguile/.cvsignore b/libguile/.cvsignore index ea2a54de6..e4cb95f62 100644 --- a/libguile/.cvsignore +++ b/libguile/.cvsignore @@ -35,5 +35,6 @@ libtool scmconfig.h scmconfig.h.in stamp-h +stamp-h.in versiondat.h c-tokenize.c From fd6c6321d950064be9b6f8eaf03c15c8e61fdc45 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sun, 8 Jul 2001 19:17:17 +0000 Subject: [PATCH 1458/2047] *** empty log message *** --- ChangeLog | 4 ++++ libguile/ChangeLog | 4 ++++ 2 files changed, 8 insertions(+) diff --git a/ChangeLog b/ChangeLog index 6486b955a..572301ef0 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2001-07-08 Rob Browning + + * AUTHORS: add "many files throughout" for myself. + 2001-06-28 Thien-Thi Nguyen * README: Also mention guile-tools. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index e98b7c43a..285e7a42b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2001-07-08 Rob Browning + + * .cvsignore: add stamp-h.in. + 2001-07-04 Martin Grabmueller * hooks.c (scm_make_hook, scm_add_hook_x), From 013788b6b11d05933c0348114fff1d8a1a8baff5 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 8 Jul 2001 21:00:42 +0000 Subject: [PATCH 1459/2047] Removed --- libltdl/.cvsignore | 0 1 file changed, 0 insertions(+), 0 deletions(-) delete mode 100644 libltdl/.cvsignore diff --git a/libltdl/.cvsignore b/libltdl/.cvsignore deleted file mode 100644 index e69de29bb..000000000 From 601275cdda30b9a71d866558e249acfd32b17ba3 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 8 Jul 2001 21:04:03 +0000 Subject: [PATCH 1460/2047] mention scm_read_0str and scm_eval_0str, corrections to file names. --- TODO | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/TODO b/TODO index 60d8fad5b..273d5140b 100644 --- a/TODO +++ b/TODO @@ -1,4 +1,4 @@ -[ID: $Id: TODO,v 1.18 2001-07-07 06:31:26 ttn Exp $] +[ID: $Id: TODO,v 1.19 2001-07-08 21:04:03 mvo Exp $] These TODO items are grouped by target release version. The first group is the "Eventually" group, which is not associated w/ any particular version. @@ -69,12 +69,15 @@ See also file HACKING. === In release 1.8.0: +- remove deprecated functions scm_read_0str, scm_eval_0str. + - remove deprecated "scm_*_t" type names in libguile.h. - remove re-exporting behaviour of `export'. in boot-9.scm, remove begin-deprecated part of `module-export!' in format.scm, remove kluge at top - in srfi13.scm, likewise + in srfi-13.scm, likewise + in srfi-1.scm, likewise - remove deprecated subr and gsubr functions in procs.h, procs.c: scm_make_subr, scm_make_subr_opt, From 2c105c26152940da465ea085a64477e0f1d72da3 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sun, 8 Jul 2001 23:15:56 +0000 Subject: [PATCH 1461/2047] * RELEASE: add a note that the RELEASE instructions are out of date now that we're using branches. --- RELEASE | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/RELEASE b/RELEASE index 6996d7a2b..cbd264cf8 100644 --- a/RELEASE +++ b/RELEASE @@ -56,7 +56,8 @@ The "Spiffing" phase you might go through several times as you discover problems. The "Punting" phase you do only once. -Spiffing checklist: +Spiffing checklist (NOTE: these instructions are out of date now that +we're using cvs branches for stable vs unstable). * Do a `cvs update -A', to get rid of any sticky tags in your working directory. From a96b27eadf9b38e8744a8cf3f9d345448ee28bac Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sun, 8 Jul 2001 23:16:04 +0000 Subject: [PATCH 1462/2047] * TODO: updated to include relevant itemized post-1.6-RELEASE tasks that are distributable so we can check them off as they are done, and delete 1.6.0 tasks. --- TODO | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/TODO b/TODO index 273d5140b..db2903ad4 100644 --- a/TODO +++ b/TODO @@ -1,4 +1,4 @@ -[ID: $Id: TODO,v 1.19 2001-07-08 21:04:03 mvo Exp $] +-*-text-*- These TODO items are grouped by target release version. The first group is the "Eventually" group, which is not associated w/ any particular version. @@ -61,13 +61,17 @@ See also file HACKING. - eliminate argument checking for closures - Implement a thread-safe alternative to SCM's environment caches +=== Before releasing 1.8.0: -=== In release 1.6.0: +- Make sure we have appropriate interface numbers for shared + libraries, and that we document and use the libtool + conventions. [rlb]. -- Make sure that the deprecation mechanism explained in INSTALL and - README is completed and works. +- Update the version numbers in GUILE-VERSION and README. [rlb] -=== In release 1.8.0: +- Start a new section of the NEWS file. + +- Start a new THANKS file. - remove deprecated functions scm_read_0str, scm_eval_0str. From 04860df734637ca294b02737977516d05161347c Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sun, 8 Jul 2001 23:16:16 +0000 Subject: [PATCH 1463/2047] *** empty log message *** --- ChangeLog | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/ChangeLog b/ChangeLog index 572301ef0..f907a4dab 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,12 @@ 2001-07-08 Rob Browning + * TODO: updated to include relevant itemized post-1.6-RELEASE + tasks that are distributable so we can check them off as they are + done, and delete 1.6.0 tasks. + + * RELEASE: add a note that the RELEASE instructions are out of + date now that we're using branches. + * AUTHORS: add "many files throughout" for myself. 2001-06-28 Thien-Thi Nguyen From a06e3a75b298d2335d134cfec97ee893b29aea33 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 9 Jul 2001 07:36:48 +0000 Subject: [PATCH 1464/2047] Remove "face-lift" comment. --- guile-readline/readline.c | 2 -- libguile/alist.c | 2 -- libguile/alloca.c | 2 -- libguile/arbiters.c | 2 -- libguile/async.c | 2 -- libguile/async.h | 2 -- libguile/backtrace.c | 2 -- libguile/boolean.c | 2 -- libguile/chars.c | 2 -- libguile/continuations.c | 2 -- libguile/coop-defs.h | 2 -- libguile/coop-threads.c | 2 -- libguile/debug-malloc.h | 2 -- libguile/debug.c | 2 -- libguile/debug.h | 2 -- libguile/dynl.c | 2 -- libguile/dynwind.c | 2 -- libguile/eq.c | 2 -- libguile/error.c | 2 -- libguile/eval.c | 2 -- libguile/evalext.c | 2 -- libguile/feature.c | 2 -- libguile/feature.h | 2 -- libguile/filesys.c | 2 -- libguile/filesys.h | 2 -- libguile/fluids.c | 2 -- libguile/fluids.h | 2 -- libguile/fports.c | 2 -- libguile/fports.h | 2 -- libguile/gc.c | 2 -- libguile/gc.h | 2 -- libguile/gdbint.c | 2 -- libguile/gsubr.c | 2 -- libguile/guardians.c | 2 -- libguile/hash.c | 2 -- libguile/hashtab.c | 2 -- libguile/hooks.c | 2 -- libguile/hooks.h | 2 -- libguile/inet_aton.c | 2 -- libguile/init.c | 2 -- libguile/ioext.c | 2 -- libguile/keywords.c | 2 -- libguile/keywords.h | 2 -- libguile/lang.c | 2 -- libguile/list.c | 2 -- libguile/load.c | 2 -- libguile/macros.c | 2 -- libguile/mallocs.c | 2 -- libguile/memmove.c | 2 -- libguile/modules.c | 2 -- libguile/net_db.c | 2 -- libguile/numbers.c | 2 -- libguile/numbers.h | 2 -- libguile/objects.c | 2 -- libguile/objprop.c | 2 -- libguile/options.c | 2 -- libguile/pairs.c | 2 -- libguile/pairs.h | 2 -- libguile/ports.c | 2 -- libguile/ports.h | 2 -- libguile/posix.c | 2 -- libguile/print.c | 2 -- libguile/print.h | 2 -- libguile/procprop.c | 2 -- libguile/procs.c | 2 -- libguile/procs.h | 2 -- libguile/properties.c | 2 -- libguile/putenv.c | 2 -- libguile/ramap.c | 2 -- libguile/random.c | 2 -- libguile/random.h | 2 -- libguile/read.c | 2 -- libguile/regex-posix.c | 2 -- libguile/regex-posix.h | 2 -- libguile/root.c | 2 -- libguile/root.h | 2 -- libguile/scmsigs.c | 2 -- libguile/script.c | 2 -- libguile/simpos.c | 2 -- libguile/smob.c | 2 -- libguile/snarf.h | 2 -- libguile/socket.c | 2 -- libguile/sort.c | 2 -- libguile/srcprop.c | 2 -- libguile/srcprop.h | 2 -- libguile/stackchk.c | 2 -- libguile/stacks.c | 2 -- libguile/stacks.h | 2 -- libguile/stime.c | 2 -- libguile/strerror.c | 2 -- libguile/strings.c | 2 -- libguile/strings.h | 2 -- libguile/strop.c | 2 -- libguile/strorder.c | 2 -- libguile/strports.c | 2 -- libguile/struct.c | 2 -- libguile/struct.h | 2 -- libguile/symbols-deprecated.c | 2 -- libguile/symbols.c | 2 -- libguile/symbols.h | 2 -- libguile/tags.h | 2 -- libguile/threads.c | 2 -- libguile/threads.h | 2 -- libguile/throw.c | 2 -- libguile/unif.c | 2 -- libguile/unif.h | 2 -- libguile/variable.c | 2 -- libguile/variable.h | 2 -- libguile/vectors.c | 2 -- libguile/vectors.h | 2 -- libguile/version.c | 2 -- libguile/vports.c | 2 -- libguile/weaks.c | 2 -- libguile/weaks.h | 2 -- 114 files changed, 228 deletions(-) diff --git a/guile-readline/readline.c b/guile-readline/readline.c index 0d2403384..c9245caff 100644 --- a/guile-readline/readline.c +++ b/guile-readline/readline.c @@ -19,8 +19,6 @@ * */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/alist.c b/libguile/alist.c index 5e75c8e95..0b2e81557 100644 --- a/libguile/alist.c +++ b/libguile/alist.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/_scm.h" diff --git a/libguile/alloca.c b/libguile/alloca.c index 8173cb6bc..e814ed43f 100644 --- a/libguile/alloca.c +++ b/libguile/alloca.c @@ -21,8 +21,6 @@ allocating any. It is a good idea to use alloca(0) in your main control loop, etc. to force garbage collection. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #ifdef HAVE_CONFIG_H #include "libguile/scmconfig.h" diff --git a/libguile/arbiters.c b/libguile/arbiters.c index d655abfcd..7bd92caa8 100644 --- a/libguile/arbiters.c +++ b/libguile/arbiters.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/async.c b/libguile/async.c index e5946393c..b5c1f9e92 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/async.h b/libguile/async.h index ca5b7efce..4a5afd59f 100644 --- a/libguile/async.h +++ b/libguile/async.h @@ -43,8 +43,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" diff --git a/libguile/backtrace.c b/libguile/backtrace.c index c1d42dc6c..f391a32e8 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -43,8 +43,6 @@ * The author can be reached at djurfeldt@nada.kth.se * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include diff --git a/libguile/boolean.c b/libguile/boolean.c index 7bda2139f..cea294c62 100644 --- a/libguile/boolean.c +++ b/libguile/boolean.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/chars.c b/libguile/chars.c index c47705645..a8967b99f 100644 --- a/libguile/chars.c +++ b/libguile/chars.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/continuations.c b/libguile/continuations.c index ae936fe78..d3fbd6b93 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/coop-defs.h b/libguile/coop-defs.h index ad2deb1d4..6a54c5ca0 100644 --- a/libguile/coop-defs.h +++ b/libguile/coop-defs.h @@ -44,8 +44,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ # ifdef TIME_WITH_SYS_TIME diff --git a/libguile/coop-threads.c b/libguile/coop-threads.c index fda74aa6d..d126f67f6 100644 --- a/libguile/coop-threads.c +++ b/libguile/coop-threads.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/debug-malloc.h b/libguile/debug-malloc.h index 49ee82269..b31b3191e 100644 --- a/libguile/debug-malloc.h +++ b/libguile/debug-malloc.h @@ -43,8 +43,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" diff --git a/libguile/debug.c b/libguile/debug.c index c4c738009..49cce42c7 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -43,8 +43,6 @@ * The author can be reached at djurfeldt@nada.kth.se * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/_scm.h" diff --git a/libguile/debug.h b/libguile/debug.h index 0954e3329..06a3133cb 100644 --- a/libguile/debug.h +++ b/libguile/debug.h @@ -46,8 +46,6 @@ * The author can be reached at djurfeldt@nada.kth.se * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" diff --git a/libguile/dynl.c b/libguile/dynl.c index 006bbff6a..1e9d2718a 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -41,8 +41,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ /* "dynl.c" dynamically link&load object files. diff --git a/libguile/dynwind.c b/libguile/dynwind.c index 9c6ab1069..6a32797cc 100644 --- a/libguile/dynwind.c +++ b/libguile/dynwind.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/eq.c b/libguile/eq.c index 73658cfad..515d786b1 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/_scm.h" diff --git a/libguile/error.c b/libguile/error.c index 74e0a5f75..052d07e06 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/eval.c b/libguile/eval.c index 337c52a8c..ef80bfbf7 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/evalext.c b/libguile/evalext.c index aa44cc502..e7c95aec1 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/feature.c b/libguile/feature.c index 43073e91d..108cfdd61 100644 --- a/libguile/feature.c +++ b/libguile/feature.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/feature.h b/libguile/feature.h index 81baa9011..c22325917 100644 --- a/libguile/feature.h +++ b/libguile/feature.h @@ -43,8 +43,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" diff --git a/libguile/filesys.c b/libguile/filesys.c index 4f7a5d09e..f86f790f9 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include diff --git a/libguile/filesys.h b/libguile/filesys.h index 0dbf8c2e2..e0820044b 100644 --- a/libguile/filesys.h +++ b/libguile/filesys.h @@ -43,8 +43,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" diff --git a/libguile/fluids.c b/libguile/fluids.c index ea6c16069..4ce9b8860 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/_scm.h" diff --git a/libguile/fluids.h b/libguile/fluids.h index aa11610d9..60c7a879f 100644 --- a/libguile/fluids.h +++ b/libguile/fluids.h @@ -44,8 +44,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" #include "libguile/root.h" diff --git a/libguile/fports.c b/libguile/fports.c index bc90db6bf..8ccfeab70 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/fports.h b/libguile/fports.h index 1feab7edc..a63699fe3 100644 --- a/libguile/fports.h +++ b/libguile/fports.h @@ -43,8 +43,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" diff --git a/libguile/gc.c b/libguile/gc.c index 0d5177912..65316bbb2 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ /* #define DEBUGINFO */ diff --git a/libguile/gc.h b/libguile/gc.h index 0f0b5a8a3..07a11481b 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -43,8 +43,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" diff --git a/libguile/gdbint.c b/libguile/gdbint.c index afb649e0d..54e594e51 100644 --- a/libguile/gdbint.c +++ b/libguile/gdbint.c @@ -43,8 +43,6 @@ * The author can be reached at djurfeldt@nada.kth.se * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/_scm.h" diff --git a/libguile/gsubr.c b/libguile/gsubr.c index e7513ba00..9b3e1fbff 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/guardians.c b/libguile/guardians.c index db9574635..c54395a20 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/hash.c b/libguile/hash.c index 9cb0d7411..70c12546f 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/hashtab.c b/libguile/hashtab.c index fa2840bb8..ca06b2030 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/hooks.c b/libguile/hooks.c index f7945b02c..2d32db31a 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/hooks.h b/libguile/hooks.h index 572330eef..c475bb07e 100644 --- a/libguile/hooks.h +++ b/libguile/hooks.h @@ -43,8 +43,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" diff --git a/libguile/inet_aton.c b/libguile/inet_aton.c index ec00b5a0d..f8e92541f 100644 --- a/libguile/inet_aton.c +++ b/libguile/inet_aton.c @@ -31,8 +31,6 @@ * SUCH DAMAGE. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #if defined(LIBC_SCCS) && !defined(lint) static char sccsid[] = "@(#)inet_addr.c 8.1 (Berkeley) 6/17/93"; diff --git a/libguile/init.c b/libguile/init.c index 9aefedcd5..2c7901f50 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ /* Include the headers for just about everything. diff --git a/libguile/ioext.c b/libguile/ioext.c index f7d4232b1..759e78c38 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/keywords.c b/libguile/keywords.c index 0730979b2..e2eb11437 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/keywords.h b/libguile/keywords.h index ac35f294a..9112abb45 100644 --- a/libguile/keywords.h +++ b/libguile/keywords.h @@ -43,8 +43,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" diff --git a/libguile/lang.c b/libguile/lang.c index 82378e0ff..8ec52f74e 100644 --- a/libguile/lang.c +++ b/libguile/lang.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/list.c b/libguile/list.c index 0da225596..b1465fa78 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/_scm.h" diff --git a/libguile/load.c b/libguile/load.c index 641f152ca..f8c9b76ec 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/macros.c b/libguile/macros.c index 43ea53888..8f011c055 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/mallocs.c b/libguile/mallocs.c index 1801fbb7c..accdcce36 100644 --- a/libguile/mallocs.c +++ b/libguile/mallocs.c @@ -40,8 +40,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/memmove.c b/libguile/memmove.c index adc7bd725..a62083f0f 100644 --- a/libguile/memmove.c +++ b/libguile/memmove.c @@ -1,8 +1,6 @@ /* Wrapper to implement ANSI C's memmove using BSD's bcopy. */ /* This function is in the public domain. --Per Bothner. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include diff --git a/libguile/modules.c b/libguile/modules.c index 55d63d75f..062e3f9ee 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/net_db.c b/libguile/net_db.c index 8bf5a312a..bcb920708 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -40,8 +40,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ /* Written in 1994 by Aubrey Jaffer. diff --git a/libguile/numbers.c b/libguile/numbers.c index 2c7ebf447..9b5c6a61f 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/numbers.h b/libguile/numbers.h index 6b33ff1e9..7a6d6d7f1 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -43,8 +43,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" diff --git a/libguile/objects.c b/libguile/objects.c index 888da56dd..e920ac78d 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/objprop.c b/libguile/objprop.c index 41a766c1a..0e3eee7bc 100644 --- a/libguile/objprop.c +++ b/libguile/objprop.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/options.c b/libguile/options.c index 84dbd369c..327f0aa5d 100644 --- a/libguile/options.c +++ b/libguile/options.c @@ -42,8 +42,6 @@ * The author can be reached at djurfeldt@nada.kth.se * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/pairs.c b/libguile/pairs.c index 0a77e2baf..88ce017c4 100644 --- a/libguile/pairs.c +++ b/libguile/pairs.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/pairs.h b/libguile/pairs.h index 2614cf37e..6b808f886 100644 --- a/libguile/pairs.h +++ b/libguile/pairs.h @@ -43,8 +43,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/ports.c b/libguile/ports.c index a62c4236e..ddcc4b9a6 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ /* Headers. */ diff --git a/libguile/ports.h b/libguile/ports.h index e25419849..866b74d23 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -43,8 +43,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" diff --git a/libguile/posix.c b/libguile/posix.c index 4eb679eb2..2fe0d4af2 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/print.c b/libguile/print.c index 37eddea02..82c619586 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/print.h b/libguile/print.h index 5591d382b..5d8e3e06d 100644 --- a/libguile/print.h +++ b/libguile/print.h @@ -43,8 +43,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" diff --git a/libguile/procprop.c b/libguile/procprop.c index 4186a8142..d3d63a3dd 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/procs.c b/libguile/procs.c index 5f23d43ed..576ca91e6 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/procs.h b/libguile/procs.h index 9eba0d635..9e0f34eba 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -43,8 +43,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" diff --git a/libguile/properties.c b/libguile/properties.c index b95c5d3da..2b829fcad 100644 --- a/libguile/properties.c +++ b/libguile/properties.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/putenv.c b/libguile/putenv.c index bb7eb0bb1..ccfaaa2d8 100644 --- a/libguile/putenv.c +++ b/libguile/putenv.c @@ -39,8 +39,6 @@ whether to permit this exception to apply to your modifications. If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #ifdef HAVE_CONFIG_H #include "libguile/scmconfig.h" diff --git a/libguile/ramap.c b/libguile/ramap.c index e21d7b8b3..4e0e712c8 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ /* HWN:FIXME:: diff --git a/libguile/random.c b/libguile/random.c index f367332e5..4883ff16f 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -38,8 +38,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ /* Author: Mikael Djurfeldt */ diff --git a/libguile/random.h b/libguile/random.h index 50625e20d..020a745bc 100644 --- a/libguile/random.h +++ b/libguile/random.h @@ -43,8 +43,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" diff --git a/libguile/read.c b/libguile/read.c index f93fa70c4..131999f46 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index 71cb3b0f3..1a232d59f 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -40,8 +40,6 @@ * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/regex-posix.h b/libguile/regex-posix.h index 718e651c4..23416738f 100644 --- a/libguile/regex-posix.h +++ b/libguile/regex-posix.h @@ -45,8 +45,6 @@ * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" diff --git a/libguile/root.c b/libguile/root.c index 793103f49..150d66dc0 100644 --- a/libguile/root.c +++ b/libguile/root.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/root.h b/libguile/root.h index 49f3604e1..e5a680e84 100644 --- a/libguile/root.h +++ b/libguile/root.h @@ -44,8 +44,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index ea75a7216..62a0cd99f 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/script.c b/libguile/script.c index e16e65d77..ebd38c1e8 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -41,8 +41,6 @@ /* "script.c" argv tricks for `#!' scripts. Authors: Aubrey Jaffer and Jim Blandy */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include #include diff --git a/libguile/simpos.c b/libguile/simpos.c index 882088b40..7f55c07ee 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/smob.c b/libguile/smob.c index 6d3c586e1..16fef9fcb 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/snarf.h b/libguile/snarf.h index d242e958d..36eea885e 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -46,8 +46,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/socket.c b/libguile/socket.c index a0b852b77..9c22c215a 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/sort.c b/libguile/sort.c index f2edb5a17..70de17505 100644 --- a/libguile/sort.c +++ b/libguile/sort.c @@ -38,8 +38,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ /* Written in December 1998 by Roland Orre diff --git a/libguile/srcprop.c b/libguile/srcprop.c index 697698298..9f2c89b31 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -42,8 +42,6 @@ * The author can be reached at djurfeldt@nada.kth.se * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/srcprop.h b/libguile/srcprop.h index abfbc1709..5da2e1282 100644 --- a/libguile/srcprop.h +++ b/libguile/srcprop.h @@ -46,8 +46,6 @@ * The author can be reached at djurfeldt@nada.kth.se * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" diff --git a/libguile/stackchk.c b/libguile/stackchk.c index e8971e322..abf6a5a55 100644 --- a/libguile/stackchk.c +++ b/libguile/stackchk.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/stacks.c b/libguile/stacks.c index 3b6387b1f..c49924a38 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -43,8 +43,6 @@ * The author can be reached at djurfeldt@nada.kth.se * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/stacks.h b/libguile/stacks.h index 58b83ff80..bea51ce7a 100644 --- a/libguile/stacks.h +++ b/libguile/stacks.h @@ -46,8 +46,6 @@ * The author can be reached at djurfeldt@nada.kth.se * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" diff --git a/libguile/stime.c b/libguile/stime.c index fae4beeb8..d90e9798d 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/strerror.c b/libguile/strerror.c index 44ffca628..ba43e8e6b 100644 --- a/libguile/strerror.c +++ b/libguile/strerror.c @@ -42,8 +42,6 @@ If you write modifications of your own for GUILE, it is your choice whether to permit this exception to apply to your modifications. If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ char * strerror (int errnum) diff --git a/libguile/strings.c b/libguile/strings.c index f0d162d43..acb53be8d 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/strings.h b/libguile/strings.h index d6495e615..9307a1742 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -43,8 +43,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" diff --git a/libguile/strop.c b/libguile/strop.c index 9e637bfa6..a173cacea 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -41,8 +41,6 @@ If you write modifications of your own for GUILE, it is your choice whether to permit this exception to apply to your modifications. If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/strorder.c b/libguile/strorder.c index c50a2469b..8c7737abf 100644 --- a/libguile/strorder.c +++ b/libguile/strorder.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/_scm.h" diff --git a/libguile/strports.c b/libguile/strports.c index 17dd64c67..66fc7b52c 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/struct.c b/libguile/struct.c index e241a3f35..e4014a9d5 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/struct.h b/libguile/struct.h index 0e7c29f2e..659052501 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -43,8 +43,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" diff --git a/libguile/symbols-deprecated.c b/libguile/symbols-deprecated.c index 6151a4494..6157966f0 100644 --- a/libguile/symbols-deprecated.c +++ b/libguile/symbols-deprecated.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/symbols.c b/libguile/symbols.c index 7ce74a20b..3093a6484 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/symbols.h b/libguile/symbols.h index 81a616e31..f1417b4b5 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -43,8 +43,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" diff --git a/libguile/tags.h b/libguile/tags.h index b3cd66a0b..7d45c66c5 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -43,8 +43,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/threads.c b/libguile/threads.c index f3334b49a..c8a09941d 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/threads.h b/libguile/threads.h index d6ac1c484..408ce1734 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -44,8 +44,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" diff --git a/libguile/throw.c b/libguile/throw.c index 62468437b..04c5263e1 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/unif.c b/libguile/unif.c index 4fd7882a7..5b2af435c 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ /* This file has code for arrays in lots of variants (double, integer, diff --git a/libguile/unif.h b/libguile/unif.h index 4f0d4e484..9b5b61d6c 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -43,8 +43,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" diff --git a/libguile/variable.c b/libguile/variable.c index 7e61680eb..4037e51be 100644 --- a/libguile/variable.c +++ b/libguile/variable.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/variable.h b/libguile/variable.h index 300e40220..014fc821f 100644 --- a/libguile/variable.h +++ b/libguile/variable.h @@ -43,8 +43,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" #include "libguile/smob.h" diff --git a/libguile/vectors.c b/libguile/vectors.c index 7f4cdaa88..8280b113e 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/vectors.h b/libguile/vectors.h index 6ffa3f9b2..83ef491b4 100644 --- a/libguile/vectors.h +++ b/libguile/vectors.h @@ -43,8 +43,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" diff --git a/libguile/version.c b/libguile/version.c index 8b7808a57..a3ac0d920 100644 --- a/libguile/version.c +++ b/libguile/version.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/vports.c b/libguile/vports.c index 50c3b76fb..68ed74c15 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/weaks.c b/libguile/weaks.c index 4debbb499..d8eb065cd 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -39,8 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ diff --git a/libguile/weaks.h b/libguile/weaks.h index da86bfd1c..4e561eec2 100644 --- a/libguile/weaks.h +++ b/libguile/weaks.h @@ -43,8 +43,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" From dbb640bd08cdbe6bc3e7e1c3b7e5f325e2c30dfa Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 9 Jul 2001 07:43:48 +0000 Subject: [PATCH 1465/2047] *** empty log message *** --- guile-readline/ChangeLog | 18 +++++++++++------- libguile/ChangeLog | 24 +++++++++++++++++++++++- 2 files changed, 34 insertions(+), 8 deletions(-) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 61375034f..1c56ddff2 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,7 @@ +2001-07-09 Thien-Thi Nguyen + + * readline.c: Remove "face-lift" comment. + 2001-06-30 Dirk Herrmann * readline.c (completion_function): Use scm_list_n instead of @@ -19,7 +23,7 @@ when _RL_FUNCTION_TYPEDEF is defined. * readline.h (scm_clear_history): New prototype. - + 2001-06-07 Dirk Herrmann * readline.c (current_input_getc): Mark unused parameters with @@ -143,7 +147,7 @@ in addition to ncurses and termcap. Check for `readline' in libreadline, not for `main'. Thanks to Albert Chin! - + 2000-07-17 Marius Vollmer * configure.in (rl_pre_input_hook): Don't check for this with @@ -195,7 +199,7 @@ 2000-06-01 Michael Livshin * autogen.sh: call ../guile-aclocal.sh instead of aclocal - + 2000-05-01 Gary Houston * readline.c: include libguile.h, not libguile/libguile.h. @@ -209,7 +213,7 @@ and we don't want that. (INCLUDES): Removed all -I options except for the root source directory and the root build directory. - + 2000-04-04 Dirk Herrmann * readline.c (scm_readline): Must unpack SCM values to access @@ -249,7 +253,7 @@ Tue Jan 11 17:51:40 2000 Greg J. Badros * readline.c (scm_init_readline): Drop extra argument to scm_mutex_init as that argument should not exist. I do not know how this escaped detection for so long. - + 2000-01-09 Mikael Djurfeldt * readline.c (match_paren): Changed return type to int (this is @@ -319,7 +323,7 @@ Sun Dec 12 19:56:52 1999 Greg J. Badros so this works. See below. (activate-readline): New function which contains the readline activation code formerly found in top-repl. - + * readline.c (scm_readline): Export it to Scheme as "%readline". * configure.in: Get version from ../GUILE-VERSION and use it for @@ -343,7 +347,7 @@ Sun Dec 12 19:56:52 1999 Greg J. Badros (Thanks to Anders Holst.) * Makefile.am: Install guile-readline/readline.h. - + 1999-08-20 James Blandy * Makefile.in, aclocal.m4, configure: Regenerated. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 285e7a42b..129503036 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,25 @@ +2001-07-09 Thien-Thi Nguyen + + * alist.c, alloca.c, arbiters.c, async.c, async.h, backtrace.c, + boolean.c, chars.c, continuations.c, coop-defs.h, coop-threads.c, + debug-malloc.h, debug.c, debug.h, dynl.c, dynwind.c, eq.c, + error.c, eval.c, evalext.c, feature.c, feature.h, filesys.c, + filesys.h, fluids.c, fluids.h, fports.c, fports.h, gc.c, gc.h, + gdbint.c, gsubr.c, guardians.c, hash.c, hashtab.c, hooks.c, + hooks.h, inet_aton.c, init.c, ioext.c, keywords.c, keywords.h, + lang.c, list.c, load.c, macros.c, mallocs.c, memmove.c, modules.c, + net_db.c, numbers.c, numbers.h, objects.c, objprop.c, options.c, + pairs.c, pairs.h, ports.c, ports.h, posix.c, print.c, print.h, + procprop.c, procs.c, procs.h, properties.c, putenv.c, ramap.c, + random.c, random.h, read.c, regex-posix.c, regex-posix.h, root.c, + root.h, scmsigs.c, script.c, simpos.c, smob.c, snarf.h, socket.c, + sort.c, srcprop.c, srcprop.h, stackchk.c, stacks.c, stacks.h, + stime.c, strerror.c, strings.c, strings.h, strop.c, strorder.c, + strports.c, struct.c, struct.h, symbols-deprecated.c, symbols.c, + symbols.h, tags.h, threads.c, threads.h, throw.c, unif.c, unif.h, + variable.c, variable.h, vectors.c, vectors.h, version.c, vports.c, + weaks.c, weaks.h: Remove "face-lift" comment. + 2001-07-08 Rob Browning * .cvsignore: add stamp-h.in. @@ -11,7 +33,7 @@ 2001-07-03 Martin Grabmueller Some more compatibility patches for Windows. - + * posix.c (getlogin): getlogin() implementation for Windows. * backtrace.c, ioext.c: Include . From 71335c0d9da4faf8e08371de5bc8394acbeeac83 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Mon, 9 Jul 2001 14:28:03 +0000 Subject: [PATCH 1466/2047] * boot-9.scm: Fixed the sense of the error message when read-eval? is #f. Thanks to Matthias for catching this. --- ice-9/boot-9.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 8d00cd988..d0bd11c58 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -787,7 +787,7 @@ (if (fluid-ref read-eval?) (eval (read port) (interaction-environment)) (error - "#. read expansion found and read-eval? is not #f.")))) + "#. read expansion found and read-eval? is #f.")))) ;;; {Command Line Options} From 4aea9e7b4db77e46f426c49a0e5f5d20a127d10d Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Mon, 9 Jul 2001 14:28:30 +0000 Subject: [PATCH 1467/2047] *** empty log message *** --- ice-9/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 20b0a25e6..ed434d630 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2001-07-09 Rob Browning + + * boot-9.scm: Fixed the sense of the error message when read-eval? + is #f. Thanks to Matthias for catching this. + 2001-07-06 Rob Browning * boot-9.scm: added fix suggested by Matthias for #. read From 4b1ef000a51f0c6f900a7ac85a216045cfd280af Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 9 Jul 2001 15:02:11 +0000 Subject: [PATCH 1468/2047] Updated snapshot location. --- SNAPSHOTS | 37 ------------------------------------- 1 file changed, 37 deletions(-) diff --git a/SNAPSHOTS b/SNAPSHOTS index 459b07c0c..e69de29bb 100644 --- a/SNAPSHOTS +++ b/SNAPSHOTS @@ -1,37 +0,0 @@ -FTP Snapshots ======================================================== - -Each night, we make the current Guile sources available via anonymous -FTP. Please keep in mind that these sources are strictly -experimental; they will usually not be well-tested, and may not even -compile on some systems. They may contain interfaces which will -change. They will usually not be of sufficient quality for use by -people not comfortable hacking the innards of Guile. Caveat! - -However, we're providing them anyway for several reasons. We'd like -to encourage people to get involved in developing Guile. People -willing to use the bleeding edge of development can get earlier access -to new, experimental features. Patches submitted relative to recent -snapshots will be easier for us to evaluate and install, since the -patch's original sources will be closer to what we're working with. -And it allows us to start testing features earlier. - -Nightly snapshots of the Guile development sources are available via -anonymous FTP from ftp.red-bean.com, as -/pub/guile/snapshots/guile-core-snap.tar.gz. - -Via the web, that's: - ftp://ftp.red-bean.com/pub/guile/snapshots/guile-core-snap.tar.gz -For getit, that's: - ftp.red-bean.com:/pub/guile/snapshots/guile-core-snap.tar.gz - -The snapshot FTP site is mirrored at the following location: - Japan: ftp://ftp.jaist.ac.jp/pub/lang/scheme/guile - - -To build the snapshot, you will need to have autoconf, automake, and -libtool installed on your system; the recommended versions are listed -in HACKING. - -After you have unpacked the tar file, run the command `./autogen.sh'. -This builds the configure script, Makefile.in, and other derived files -used by the build system. From ee85583a3755cd445a58ed0c250c36e8e0cbafb2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 9 Jul 2001 19:12:27 +0000 Subject: [PATCH 1469/2047] 2001-07-09 Martin Grabmueller * README: Cleanup. --- srfi/ChangeLog | 4 ++++ srfi/README | 7 ++----- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index f4a5dc01f..ba518e45c 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,7 @@ +2001-07-09 Martin Grabmueller + + * README: Cleanup. + 2001-07-06 Gary Houston * srfi-1.scm (iota, map, for-each, list-index, member, delete, diff --git a/srfi/README b/srfi/README index a96a822e5..c9d47ee54 100644 --- a/srfi/README +++ b/srfi/README @@ -5,8 +5,6 @@ stand for, please refer to the SRFI homepage at http://srfi.schemers.org -The following SRFIs are supported (as of 2001-06-06 -- 'martin): - SRFI-0: cond-expand Supported by default, no module needs to get used. @@ -73,7 +71,6 @@ SRFI-19: Time Data Types and Procedures A lot of data types and procedures for dealing with times and dates. (use-modules (srfi srfi-19)) loads the procedures. -SRFI-23: Error reporting mechanism (draft) +SRFI-23: Error reporting mechanism - This SRFI is still in draft status, but Guile fully supports it - already. No need to load any module. + Guile fully supports this SRFI. No need to load any module. From 9bf806445c03bd0476fa8050d95954104805cb16 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 9 Jul 2001 19:13:21 +0000 Subject: [PATCH 1470/2047] * box-dynamic/README: Corrected sample session. * box-module/box.c, box-dynamic-module/box.c, box-dynamic/box.c * box/box.c: scm_bits_t -> scm_t_bits. --- examples/ChangeLog | 7 +++++++ examples/box-dynamic-module/box.c | 2 +- examples/box-dynamic/README | 2 +- examples/box-dynamic/box.c | 2 +- examples/box-module/box.c | 2 +- examples/box/box.c | 2 +- 6 files changed, 12 insertions(+), 5 deletions(-) diff --git a/examples/ChangeLog b/examples/ChangeLog index 678830aa8..e907b87b5 100644 --- a/examples/ChangeLog +++ b/examples/ChangeLog @@ -1,3 +1,10 @@ +2001-07-09 Martin Grabmueller + + * box-dynamic/README: Corrected sample session. + + * box-module/box.c, box-dynamic-module/box.c, box-dynamic/box.c + * box/box.c: scm_bits_t -> scm_t_bits. + 2001-06-18 Martin Grabmueller * box-dynamic-module/README: Use a better example for box-map, as diff --git a/examples/box-dynamic-module/box.c b/examples/box-dynamic-module/box.c index c159a8f82..180190e9e 100644 --- a/examples/box-dynamic-module/box.c +++ b/examples/box-dynamic-module/box.c @@ -25,7 +25,7 @@ /* The type code for the newly created smob type will be stored into this variable. It has the prefix `scm_tc16_' to make it usable with the SCM_VALIDATE_SMOB macro below. */ -static scm_bits_t scm_tc16_box; +static scm_t_bits scm_tc16_box; /* This function is responsible for marking all SCM objects included diff --git a/examples/box-dynamic/README b/examples/box-dynamic/README index bb87b5db7..7acc9f432 100644 --- a/examples/box-dynamic/README +++ b/examples/box-dynamic/README @@ -37,7 +37,7 @@ Extend your LD_LIBRARY_PATH variable (or equivalent) to include . and ** Example Session -$ ./guile +$ guile guile> (load-extension "libbox" "scm_init_box") guile> (define b (make-box)) guile> b diff --git a/examples/box-dynamic/box.c b/examples/box-dynamic/box.c index 8872a6163..9379b86a5 100644 --- a/examples/box-dynamic/box.c +++ b/examples/box-dynamic/box.c @@ -25,7 +25,7 @@ /* The type code for the newly created smob type will be stored into this variable. It has the prefix `scm_tc16_' to make it usable with the SCM_VALIDATE_SMOB macro below. */ -static scm_bits_t scm_tc16_box; +static scm_t_bits scm_tc16_box; /* This function is responsible for marking all SCM objects included diff --git a/examples/box-module/box.c b/examples/box-module/box.c index cf6542593..90f6881dd 100644 --- a/examples/box-module/box.c +++ b/examples/box-module/box.c @@ -25,7 +25,7 @@ /* The type code for the newly created smob type will be stored into this variable. It has the prefix `scm_tc16_' to make it usable with the SCM_VALIDATE_SMOB macro below. */ -static scm_bits_t scm_tc16_box; +static scm_t_bits scm_tc16_box; /* This function is responsible for marking all SCM objects included diff --git a/examples/box/box.c b/examples/box/box.c index 6c972b86b..e526fa880 100644 --- a/examples/box/box.c +++ b/examples/box/box.c @@ -25,7 +25,7 @@ /* The type code for the newly created smob type will be stored into this variable. It has the prefix `scm_tc16_' to make it usable with the SCM_VALIDATE_SMOB macro below. */ -static scm_bits_t scm_tc16_box; +static scm_t_bits scm_tc16_box; /* This function is responsible for marking all SCM objects included From aa3eb769a8455eacce6cf49f5404d0a79205d275 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 9 Jul 2001 19:37:05 +0000 Subject: [PATCH 1471/2047] Remove authorship comment. --- scripts/PROGRAM | 2 -- scripts/display-commentary | 2 -- scripts/doc-snarf | 2 -- scripts/generate-autoload | 2 -- scripts/punify | 2 -- scripts/read-scheme-source | 2 -- scripts/snarf-check-and-output-texi | 46 ++++++++++++++--------------- scripts/use2dot | 2 -- 8 files changed, 22 insertions(+), 38 deletions(-) diff --git a/scripts/PROGRAM b/scripts/PROGRAM index 3511ccdfc..74a4f3cff 100755 --- a/scripts/PROGRAM +++ b/scripts/PROGRAM @@ -22,8 +22,6 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA -;;; Author: J.R.Hacker - ;;; Commentary: ;; Usage: PROGRAM [ARGS] diff --git a/scripts/display-commentary b/scripts/display-commentary index 1eeb842d8..4d1b17f0a 100755 --- a/scripts/display-commentary +++ b/scripts/display-commentary @@ -22,8 +22,6 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA -;;; Author: Thien-Thi Nguyen - ;;; Commentary: ;; Usage: display-commentary FILE1 FILE2 ... diff --git a/scripts/doc-snarf b/scripts/doc-snarf index 941682e78..6279c9c68 100755 --- a/scripts/doc-snarf +++ b/scripts/doc-snarf @@ -22,8 +22,6 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA -;;; Author: Martin Grabmueller - ;;; Commentary: ;; Usage: doc-snarf FILE diff --git a/scripts/generate-autoload b/scripts/generate-autoload index eef2b88c5..d1e5ba3b9 100755 --- a/scripts/generate-autoload +++ b/scripts/generate-autoload @@ -22,8 +22,6 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA -;;; Author: Thien-Thi Nguyen - ;;; Commentary: ;; Usage: generate-autoload [OPTIONS] FILE1 FILE2 ... diff --git a/scripts/punify b/scripts/punify index 1cc318fb6..8101550f2 100755 --- a/scripts/punify +++ b/scripts/punify @@ -22,8 +22,6 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA -;;; Author: Thien-Thi Nguyen - ;;; Commentary: ;; Usage: punify FILE1 FILE2 ... diff --git a/scripts/read-scheme-source b/scripts/read-scheme-source index 48e96058a..6a82938e4 100755 --- a/scripts/read-scheme-source +++ b/scripts/read-scheme-source @@ -22,8 +22,6 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA -;;; Author: Thien-Thi Nguyen - ;;; Commentary: ;; Usage: read-scheme-source FILE1 FILE2 ... diff --git a/scripts/snarf-check-and-output-texi b/scripts/snarf-check-and-output-texi index 7b4df63fd..6a1888917 100755 --- a/scripts/snarf-check-and-output-texi +++ b/scripts/snarf-check-and-output-texi @@ -22,8 +22,6 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA -;;; Author: Michael Livshin - ;;; Code: (define-module (scripts snarf-check-and-output-texi) @@ -65,7 +63,7 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" (loop (stream-cdr s))) (else (cons (stream-car s) (stream-cdr s)))))) (port->stream port read))))) - + (unless (stream-null? input) (let ((token (stream-car input))) (if (eq? (car token) 'snarf_cookie) @@ -74,10 +72,10 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" (loop (stream-cdr input))))))) (define (dispatch-top-cookie input cont) - + (when (stream-null? input) (error 'syntax "premature end of file")) - + (let ((token (stream-car input))) (cond ((eq? (car token) 'brace_open) @@ -90,10 +88,10 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" (define (consume-upto-cookie process input cont) (let loop ((acc '()) (input input)) - + (when (stream-null? input) (error 'syntax "premature end of file in directive context")) - + (let ((token (stream-car input))) (cond ((eq? (car token) 'snarf_cookie) @@ -109,13 +107,13 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" (when (stream-null? input) (error 'syntax "premature end of file in multiline context")) - + (let ((token (stream-car input))) (cond ((eq? (car token) 'brace_close) (end-multiline) (cont (stream-cdr input))) - + (else (consume-upto-cookie process-multiline-directive input loop)))))) @@ -136,7 +134,7 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" (set! *args* #f) (set! *sig* #f) (set! *docstring* #f)) - + (define (end-multiline) (let* ((req (car *sig*)) (opt (cadr *sig*)) @@ -196,13 +194,13 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" (define do-args (match-lambda - + (('(paren_close . paren_close)) '()) - + (('(comma . comma) rest ...) (do-args rest)) - + (('(id . SCM) ('id . name) rest ...) (cons name (do-args rest))) @@ -210,21 +208,21 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" (define do-arglist (match-lambda - + (('(paren_open . paren_open) '(id . void) '(paren_close . paren_close)) '()) - + (('(paren_open . paren_open) rest ...) (do-args rest)) - + (x (error (format #f "invalid arglist syntax: ~A" (map cdr x)))))) (define do-command (match-lambda - + (('fname ('string . name)) (set! *function-name* (texi-quote name))) - + (('type ('id . type)) (set! *snarf-type* type)) @@ -245,19 +243,19 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" (define do-directive (match-lambda - + ((('id . command) rest ...) (do-command (cons command rest))) - + ((('string . string) ...) (set! *docstring* string)) - + (x (error (format #f "unknown doc attribute syntax: ~A" x))))) (do-directive l)) (define (process-singleline l) - + (define do-argpos (match-lambda ((('id . name) ('int . pos) ('int . line)) @@ -267,13 +265,13 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" (display (format #f "~A:~A: wrong position for argument ~A: ~A (should be ~A)\n" *file* line name pos (+ idx 1))))))) (x #f))) - + (define do-command (match-lambda (('(id . argpos) rest ...) (do-argpos rest)) (x (error (format #f "unknown check: ~A" x))))) - + (when *function-name* (do-command l))) diff --git a/scripts/use2dot b/scripts/use2dot index 2f1b58d04..b52276a38 100755 --- a/scripts/use2dot +++ b/scripts/use2dot @@ -22,8 +22,6 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA -;;; Author: Thien-Thi Nguyen based on PERL script by Keisuke Nishida - ;;; Commentary: ;; Usage: use2dot [OPTIONS] [FILE ...] From cffdf820c65675daf0638e1f8fb638326eb974b8 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 9 Jul 2001 19:40:08 +0000 Subject: [PATCH 1472/2047] *** empty log message *** --- scripts/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/scripts/ChangeLog b/scripts/ChangeLog index d7a8910d4..f385cfdcf 100644 --- a/scripts/ChangeLog +++ b/scripts/ChangeLog @@ -1,3 +1,9 @@ +2001-07-09 Thien-Thi Nguyen + + * PROGRAM, generate-autoload, use2dot, punify, display-commentary, + doc-snarf, read-scheme-source, snarf-check-and-output-texi: + Remove authorship info. + 2001-06-25 Michael Livshin * snarf-check-and-output-texi: rewrite. From 4973b813cc30f5126d30ad6df2da8cd46678541b Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 10 Jul 2001 15:09:59 +0000 Subject: [PATCH 1473/2047] Point to HACKING for tool versions. --- INSTALL | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/INSTALL b/INSTALL index 302065803..7e8d40d2b 100644 --- a/INSTALL +++ b/INSTALL @@ -83,7 +83,7 @@ switches specific to Guile you may find useful in some circumstances. If you have automake, autoconf, and libtool installed on your system, this switch causes configure to generate Makefiles which know how to automatically regenerate configure scripts, makefiles, - and headers, when they are out of date. The README file says which + and headers, when they are out of date. The HACKING file says which versions of those tools you will need. From d76852e37c2089449ea209b3d88025144d9d0b23 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 10 Jul 2001 15:11:27 +0000 Subject: [PATCH 1474/2047] *** empty log message *** --- ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ChangeLog b/ChangeLog index f907a4dab..1b7ae7702 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2001-07-10 Thien-Thi Nguyen + + * INSTALL: Point to HACKING for tool versions. + 2001-07-08 Rob Browning * TODO: updated to include relevant itemized post-1.6-RELEASE From 3b0eb5fd6ba0ee6bebd182cab596ee8c60086f48 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 10 Jul 2001 20:49:48 +0000 Subject: [PATCH 1475/2047] (display-version, display-help): Fix comment; nfc. --- examples/scripts/hello | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/examples/scripts/hello b/examples/scripts/hello index afeb64781..01f9a6c3b 100755 --- a/examples/scripts/hello +++ b/examples/scripts/hello @@ -20,12 +20,12 @@ '((version (single-char #\v) (value #f)) (help (single-char #\h) (value #f)))) -;; Display version information and exit. +;; Display version information. ;; (define (display-version) (display "hello 0.0.1\n")) -;; Display the usage help message and exit. +;; Display the usage help message. ;; (define (display-help) (display "Usage: hello [options...]\n") From 4ffdd2663a90d3f9fefcc445395a348d1f629951 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 10 Jul 2001 20:50:54 +0000 Subject: [PATCH 1476/2047] *** empty log message *** --- examples/ChangeLog | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/examples/ChangeLog b/examples/ChangeLog index e907b87b5..99e51f89c 100644 --- a/examples/ChangeLog +++ b/examples/ChangeLog @@ -1,3 +1,7 @@ +2001-07-10 Thien-Thi Nguyen + + * scripts/hello (display-version, display-help): Fix comment; nfc. + 2001-07-09 Martin Grabmueller * box-dynamic/README: Corrected sample session. @@ -27,7 +31,7 @@ procedures from the library. Thanks to Thomas Wawrzinek for the idea and example code! - + * box-dynamic-module/box-module.scm: Add comments, export make-box, box-ref, box-set!. @@ -44,7 +48,7 @@ shared library and places the definitions in a C-only module. Thanks to Thomas Wawrzinek for this, too! - + * box-dynamic/box.c, box/box.c, box-dynamic-module/box.c, box-module/box.c (mark_box): Fixed typo in comment. @@ -59,7 +63,7 @@ library (aka extension) Thanks to Thomas Wawrzinek for patching box.c into an extension! - + 2001-05-30 Martin Grabmueller * box-module: New directory, similar to box, but defines the From 4b8ec619621a08653ae1742e62e36dc41ab1ef58 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Wed, 11 Jul 2001 17:37:53 +0000 Subject: [PATCH 1477/2047] * strports.c (st_write): use memcpy, not strncpy. thanks to Dale P. Smith. --- libguile/ChangeLog | 5 +++++ libguile/strports.c | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 129503036..0ec078395 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-07-11 Gary Houston + + * strports.c (st_write): use memcpy, not strncpy. thanks to + Dale P. Smith. + 2001-07-09 Thien-Thi Nguyen * alist.c, alloca.c, arbiters.c, async.c, async.h, backtrace.c, diff --git a/libguile/strports.c b/libguile/strports.c index 66fc7b52c..969d2b79b 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -155,7 +155,7 @@ st_write (SCM port, const void *data, size_t size) int space = pt->write_end - pt->write_pos; int write_len = (size > space) ? space : size; - strncpy ((char *) pt->write_pos, input, write_len); + memcpy ((char *) pt->write_pos, input, write_len); pt->write_pos += write_len; size -= write_len; input += write_len; From a7c0d85cb6e65e187e3b58dde65903244096ace1 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Wed, 11 Jul 2001 18:13:53 +0000 Subject: [PATCH 1478/2047] * scheme-evaluation.texi: Added `load-from-path'. Updated `load': it doesn't use the load paths. --- doc/ChangeLog | 5 +++++ doc/scheme-evaluation.texi | 15 ++++++++++----- 2 files changed, 15 insertions(+), 5 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index ef0012f8d..618f754bd 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,8 @@ +2001-07-11 Gary Houston + + * scheme-evaluation.texi: Added `load-from-path'. Corrected `load': + it doesn't use the load paths. + 2001-07-04 Martin Grabmueller * scheme-data.texi (Hook Reference): Removed documentation for diff --git a/doc/scheme-evaluation.texi b/doc/scheme-evaluation.texi index d3b3f6eea..5a0f861ff 100644 --- a/doc/scheme-evaluation.texi +++ b/doc/scheme-evaluation.texi @@ -245,11 +245,16 @@ signalled. @rnindex load @deffn procedure load filename -Load @var{file} and evaluate its contents in the top-level environment. -The load paths are searched. If the variable @code{%load-hook} is -defined, it should be bound to a procedure that will be called before -any code is loaded. See documentation for @code{%load-hook} later in -this section. +Load @var{filename} and evaluate its contents in the top-level +environment. The load paths are not searched. If the variable +@code{%load-hook} is defined, it should be bound to a procedure that +will be called before any code is loaded. See documentation for +@code{%load-hook} later in this section. +@end deffn + +@deffn procedure load-from-path filename +Similar to @code{load}, but searches for @var{filename} in the load +paths. @end deffn @deffn primitive primitive-load filename From dd84cd4d1fd4f216b9c473c37eeeef790867c925 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Wed, 11 Jul 2001 20:47:07 +0000 Subject: [PATCH 1479/2047] * srfi-14.c (s_scm_char_set_eq): bug fix: (char-set=) should return #t instead of giving wrong-number-of-arguments . take a single "rest" argument. use memcmp instead of a loop to compare the values. srfi-14.h: update the declaration. --- srfi/ChangeLog | 8 ++++++++ srfi/srfi-14.c | 35 +++++++++++++++-------------------- srfi/srfi-14.h | 2 +- 3 files changed, 24 insertions(+), 21 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index ba518e45c..f9e8287d5 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,11 @@ +2001-07-11 Gary Houston + + * srfi-14.c (s_scm_char_set_eq): bug fix: (char-set=) should + return #t instead of giving wrong-number-of-arguments . take a + single "rest" argument. use memcmp instead of a loop to compare + the values. + srfi-14.h: update the declaration. + 2001-07-09 Martin Grabmueller * README: Cleanup. diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index 3ee4ea8a2..a0fc6615a 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -111,33 +111,28 @@ SCM_DEFINE (scm_char_set_p, "char-set?", 1, 0, 0, #undef FUNC_NAME -SCM_DEFINE (scm_char_set_eq, "char-set=", 1, 0, 1, - (SCM cs1, SCM csr), +SCM_DEFINE (scm_char_set_eq, "char-set=", 0, 0, 1, + (SCM char_sets), "Return @code{#t} if all given character sets are equal.") #define FUNC_NAME s_scm_char_set_eq { - int argnum = 2; + int argnum = 1; + long *cs1_data = NULL; - SCM_VALIDATE_SMOB (1, cs1, charset); - SCM_VALIDATE_REST_ARGUMENT (csr); + SCM_VALIDATE_REST_ARGUMENT (char_sets); - while (!SCM_NULLP (csr)) + while (!SCM_NULLP (char_sets)) { - long * p1, * p2; - SCM cs2 = SCM_CAR (csr); - int k; + SCM csn = SCM_CAR (char_sets); + long *csn_data; - SCM_VALIDATE_SMOB (argnum++, cs2, charset); - p1 = (long *) SCM_SMOB_DATA (cs1); - p2 = (long *) SCM_SMOB_DATA (cs2); - for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) - { - if (p1[k] != p2[k]) - return SCM_BOOL_F; - } - - csr = SCM_CDR (csr); - cs1 = cs2; + SCM_VALIDATE_SMOB (argnum++, csn, charset); + csn_data = (long *) SCM_SMOB_DATA (csn); + if (cs1_data == NULL) + cs1_data = csn_data; + else if (memcmp (cs1_data, csn_data, SCM_CHARSET_SIZE) != 0) + return SCM_BOOL_F; + char_sets = SCM_CDR (char_sets); } return SCM_BOOL_T; } diff --git a/srfi/srfi-14.h b/srfi/srfi-14.h index 48bb88337..2ddc9c83c 100644 --- a/srfi/srfi-14.h +++ b/srfi/srfi-14.h @@ -60,7 +60,7 @@ void scm_c_init_srfi_14 (void); void scm_init_srfi_14 (void); SCM scm_char_set_p (SCM obj); -SCM scm_char_set_eq (SCM cs1, SCM csr); +SCM scm_char_set_eq (SCM char_sets); SCM scm_char_set_leq (SCM cs1, SCM csr); SCM scm_char_set_hash (SCM cs, SCM bound); SCM scm_char_set_cursor (SCM cs); From be390de2baddbe5361bfc99da3f402b1e8d19225 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Wed, 11 Jul 2001 22:00:52 +0000 Subject: [PATCH 1480/2047] (s_scm_char_set_leq): similarly, (char-set<=) should return #t. take a single "rest" argument. --- srfi/ChangeLog | 4 +++- srfi/srfi-14.c | 50 ++++++++++++++++++++++++++------------------------ srfi/srfi-14.h | 2 +- 3 files changed, 30 insertions(+), 26 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index f9e8287d5..dc6ee8cf0 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -4,7 +4,9 @@ return #t instead of giving wrong-number-of-arguments . take a single "rest" argument. use memcmp instead of a loop to compare the values. - srfi-14.h: update the declaration. + (s_scm_char_set_leq): similarly, (char-set<=) should return #t. + take a single "rest" argument. + srfi-14.h: update the declarations. 2001-07-09 Martin Grabmueller diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index a0fc6615a..b18cb1251 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -123,14 +123,14 @@ SCM_DEFINE (scm_char_set_eq, "char-set=", 0, 0, 1, while (!SCM_NULLP (char_sets)) { - SCM csn = SCM_CAR (char_sets); - long *csn_data; + SCM csi = SCM_CAR (char_sets); + long *csi_data; - SCM_VALIDATE_SMOB (argnum++, csn, charset); - csn_data = (long *) SCM_SMOB_DATA (csn); + SCM_VALIDATE_SMOB (argnum++, csi, charset); + csi_data = (long *) SCM_SMOB_DATA (csi); if (cs1_data == NULL) - cs1_data = csn_data; - else if (memcmp (cs1_data, csn_data, SCM_CHARSET_SIZE) != 0) + cs1_data = csi_data; + else if (memcmp (cs1_data, csi_data, SCM_CHARSET_SIZE) != 0) return SCM_BOOL_F; char_sets = SCM_CDR (char_sets); } @@ -139,34 +139,36 @@ SCM_DEFINE (scm_char_set_eq, "char-set=", 0, 0, 1, #undef FUNC_NAME -SCM_DEFINE (scm_char_set_leq, "char-set<=", 1, 0, 1, - (SCM cs1, SCM csr), +SCM_DEFINE (scm_char_set_leq, "char-set<=", 0, 0, 1, + (SCM char_sets), "Return @code{#t} if every character set @var{cs}i is a subset\n" "of character set @var{cs}i+1.") #define FUNC_NAME s_scm_char_set_leq { - int argnum = 2; + int argnum = 1; + long *prev_data = NULL; - SCM_VALIDATE_SMOB (1, cs1, charset); - SCM_VALIDATE_REST_ARGUMENT (csr); + SCM_VALIDATE_REST_ARGUMENT (char_sets); - while (!SCM_NULLP (csr)) + while (!SCM_NULLP (char_sets)) { - long * p1, * p2; - SCM cs2 = SCM_CAR (csr); - int k; + SCM csi = SCM_CAR (char_sets); + long *csi_data; - SCM_VALIDATE_SMOB (argnum++, cs2, charset); - p1 = (long *) SCM_SMOB_DATA (cs1); - p2 = (long *) SCM_SMOB_DATA (cs2); - for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + SCM_VALIDATE_SMOB (argnum++, csi, charset); + csi_data = (long *) SCM_SMOB_DATA (csi); + if (prev_data) { - if ((p1[k] & p2[k]) != p1[k]) - return SCM_BOOL_F; + int k; + + for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + { + if ((prev_data[k] & csi_data[k]) != prev_data[k]) + return SCM_BOOL_F; + } } - - csr = SCM_CDR (csr); - cs1 = cs2; + prev_data = csi_data; + char_sets = SCM_CDR (char_sets); } return SCM_BOOL_T; } diff --git a/srfi/srfi-14.h b/srfi/srfi-14.h index 2ddc9c83c..40b355236 100644 --- a/srfi/srfi-14.h +++ b/srfi/srfi-14.h @@ -61,7 +61,7 @@ void scm_init_srfi_14 (void); SCM scm_char_set_p (SCM obj); SCM scm_char_set_eq (SCM char_sets); -SCM scm_char_set_leq (SCM cs1, SCM csr); +SCM scm_char_set_leq (SCM char_sets); SCM scm_char_set_hash (SCM cs, SCM bound); SCM scm_char_set_cursor (SCM cs); SCM scm_char_set_ref (SCM cs, SCM cursor); From 4d6aae71833bd104fe6b3515f68f44c727d6ba2e Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Wed, 11 Jul 2001 22:14:11 +0000 Subject: [PATCH 1481/2047] * strings.c (s_scm_string): fix arg position in assert. --- libguile/ChangeLog | 4 ++++ libguile/strings.c | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 0ec078395..a78276fbb 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2001-07-12 Michael Livshin + + * strings.c (s_scm_string): fix arg position in assert. + 2001-07-11 Gary Houston * strports.c (st_write): use memcpy, not strncpy. thanks to diff --git a/libguile/strings.c b/libguile/strings.c index acb53be8d..7c9d548e9 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -98,7 +98,7 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1, { long i = scm_ilength (chrs); - SCM_ASSERT (i >= 0, chrs, SCM_ARGn, FUNC_NAME); + SCM_ASSERT (i >= 0, chrs, SCM_ARG1, FUNC_NAME); result = scm_allocate_string (i); } From 4d772ae2157d4c9f554f53b71c0514a7d666ec8f Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Wed, 11 Jul 2001 22:14:49 +0000 Subject: [PATCH 1482/2047] * snarf-check-and-output-texi (do-argpos): complain to the stderr, not stdout. thanks to Dale P. Smith! (nice-sig): cosmetic fix. --- scripts/ChangeLog | 6 ++++++ scripts/snarf-check-and-output-texi | 5 +++-- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/scripts/ChangeLog b/scripts/ChangeLog index f385cfdcf..a4f4f8195 100644 --- a/scripts/ChangeLog +++ b/scripts/ChangeLog @@ -1,3 +1,9 @@ +2001-07-12 Michael Livshin + + * snarf-check-and-output-texi (do-argpos): complain to the stderr, + not stdout. thanks to Dale P. Smith! + (nice-sig): cosmetic fix. + 2001-07-09 Thien-Thi Nguyen * PROGRAM, generate-autoload, use2dot, punify, display-commentary, diff --git a/scripts/snarf-check-and-output-texi b/scripts/snarf-check-and-output-texi index 6a1888917..b61e77d34 100755 --- a/scripts/snarf-check-and-output-texi +++ b/scripts/snarf-check-and-output-texi @@ -168,7 +168,7 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" (if (> opt 0) (format #t "]")) (if (> var 0) - (format #t "~A. ~A" (if (< var all) " " "") + (format #t " . ~A" (car (last-pair *args*))))))))))))))) (format #t "\n ~A\n" *function-name*) (format #t "@c snarfed from ~A:~A\n" *file* *line*) @@ -263,7 +263,8 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" (when idx (unless (= (+ idx 1) pos) (display (format #f "~A:~A: wrong position for argument ~A: ~A (should be ~A)\n" - *file* line name pos (+ idx 1))))))) + *file* line name pos (+ idx 1)) + (current-error-port)))))) (x #f))) (define do-command From 065509a51b6862a8f11f8ad37e68b2960ba9d41c Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Thu, 12 Jul 2001 18:34:39 +0000 Subject: [PATCH 1483/2047] autogen.sh: Call libtoolize with --force. --- ChangeLog | 4 ++++ autogen.sh | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 1b7ae7702..88b76cccf 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2001-07-13 Keisuke Nishida + + * autogen.sh: Call libtoolize with --force. + 2001-07-10 Thien-Thi Nguyen * INSTALL: Point to HACKING for tool versions. diff --git a/autogen.sh b/autogen.sh index 1e92ab4b9..10bf34a30 100755 --- a/autogen.sh +++ b/autogen.sh @@ -7,7 +7,7 @@ ./guile-aclocal.sh -libtoolize --copy --automake --ltdl +libtoolize --copy --force --automake --ltdl autoheader autoconf automake --add-missing From 6672871b9e9e7a908b22d72d6805b4a2cafe126e Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 12 Jul 2001 23:26:52 +0000 Subject: [PATCH 1484/2047] (compile-interface-spec): Bug fix: the keyword argument is "renamer" not "rename". --- ice-9/boot-9.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index d0bd11c58..d1ac9a7f1 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -2652,7 +2652,7 @@ (define keys ;; sym key quote? '((:select #:select #t) - (:rename #:rename #f))) + (:renamer #:renamer #f))) (if (not (pair? (car spec))) `(',spec) `(',(car spec) From 521194715d667d4d7e75788d1273f69f37f4f3ab Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 12 Jul 2001 23:27:07 +0000 Subject: [PATCH 1485/2047] Use `re-export' instead of `export' for re-exported core bindings. Do not export `unquote' and `unquote-splicing' since there aren't definitions for them. --- ice-9/null.scm | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) diff --git a/ice-9/null.scm b/ice-9/null.scm index 6875a438e..594f3d79f 100644 --- a/ice-9/null.scm +++ b/ice-9/null.scm @@ -45,18 +45,17 @@ (define-module (ice-9 null) :use-module (ice-9 syncase)) -(export define quote lambda if set! +(re-export define quote lambda if set! - cond case and or - - let let* letrec - - begin do - - delay - - quasiquote unquote unquote-splicing - - define-syntax - let-syntax letrec-syntax - ) + cond case and or + + let let* letrec + + begin do + + delay + + quasiquote + + define-syntax + let-syntax letrec-syntax) From e9965e8fb7ddf507661b9969f750b3230e619fa0 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 12 Jul 2001 23:27:23 +0000 Subject: [PATCH 1486/2047] Use `re-export' instead of `export' for re-exported core bindings. Do not re-export `numerator', `denominator' and `rationalize' since Guile does not have them. Continue to use `export' for `null-environment'. --- ice-9/safe-r5rs.scm | 209 ++++++++++++++++++++++---------------------- 1 file changed, 105 insertions(+), 104 deletions(-) diff --git a/ice-9/safe-r5rs.scm b/ice-9/safe-r5rs.scm index 1ebec99b5..0221bd1b9 100644 --- a/ice-9/safe-r5rs.scm +++ b/ice-9/safe-r5rs.scm @@ -48,113 +48,114 @@ (module-use! %module-public-interface null-interface) -(export eqv? eq? equal? - number? complex? real? rational? integer? - exact? inexact? - = < > <= >= - zero? positive? negative? odd? even? - max min - + * - / - abs - quotient remainder modulo - gcd lcm - numerator denominator - floor ceiling truncate round - rationalize - exp log sin cos tan asin acos atan - sqrt - expt - make-rectangular make-polar real-part imag-part magnitude angle - exact->inexact inexact->exact +(re-export eqv? eq? equal? + number? complex? real? rational? integer? + exact? inexact? + = < > <= >= + zero? positive? negative? odd? even? + max min + + * - / + abs + quotient remainder modulo + gcd lcm + ;;numerator denominator XXX + ;;rationalize XXX + floor ceiling truncate round + exp log sin cos tan asin acos atan + sqrt + expt + make-rectangular make-polar real-part imag-part magnitude angle + exact->inexact inexact->exact + + number->string string->number + + boolean? + not + + pair? + cons car cdr + set-car! set-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 + null? + list? + list + length + append + reverse + list-tail list-ref + memq memv member + assq assv assoc + + symbol? + symbol->string string->symbol + + char? + char=? char? char<=? char>=? + char-ci=? char-ci? char-ci<=? char-ci>=? + char-alphabetic? char-numeric? char-whitespace? + char-upper-case? char-lower-case? + char->integer integer->char + char-upcase + char-downcase + + string? + make-string + string + string-length + string-ref string-set! + string=? string-ci=? + string? string<=? string>=? + string-ci? string-ci<=? string-ci>=? + substring + string-length + string-append + string->list list->string + string-copy string-fill! + + vector? + make-vector + vector + vector-length + vector-ref vector-set! + vector->list list->vector + vector-fill! + + procedure? + apply + map + for-each + force + + call-with-current-continuation + + values + call-with-values + dynamic-wind + + eval - number->string string->number + input-port? output-port? + current-input-port current-output-port + + read + read-char + peek-char + eof-object? + char-ready? + + write + display + newline + write-char - boolean? - not + ;;transcript-on + ;;transcript-off + ) - pair? - cons car cdr - set-car! set-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 - null? - list? - list - length - append - reverse - list-tail list-ref - memq memv member - assq assv assoc - - symbol? - symbol->string string->symbol - - char? - char=? char? char<=? char>=? - char-ci=? char-ci? char-ci<=? char-ci>=? - char-alphabetic? char-numeric? char-whitespace? - char-upper-case? char-lower-case? - char->integer integer->char - char-upcase - char-downcase - - string? - make-string - string - string-length - string-ref string-set! - string=? string-ci=? - string? string<=? string>=? - string-ci? string-ci<=? string-ci>=? - substring - string-length - string-append - string->list list->string - string-copy string-fill! - - vector? - make-vector - vector - vector-length - vector-ref vector-set! - vector->list list->vector - vector-fill! - - procedure? - apply - map - for-each - force - - call-with-current-continuation - - values - call-with-values - dynamic-wind - - eval - null-environment - - input-port? output-port? - current-input-port current-output-port - - read - read-char - peek-char - eof-object? - char-ready? - - write - display - newline - write-char - - ;;transcript-on - ;;transcript-off - ) +(export null-environment) (define (null-environment n) (if (not (= n 5)) From cc259e57b18ab971fad1be55b51512a805886f2c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 12 Jul 2001 23:28:03 +0000 Subject: [PATCH 1487/2047] (and-let*): Use `re-export-syntax' instead of `export-syntax'. --- srfi/srfi-2.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/srfi/srfi-2.scm b/srfi/srfi-2.scm index 8c33f7a76..fa6d0c960 100644 --- a/srfi/srfi-2.scm +++ b/srfi/srfi-2.scm @@ -44,6 +44,6 @@ (define-module (srfi srfi-2) :use-module (ice-9 and-let-star)) -(export-syntax and-let*) +(re-export-syntax and-let*) (cond-expand-provide (current-module) '(srfi-2)) From 93e08431193e8fcf2f06d3b37e85fa334c9715dd Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 12 Jul 2001 23:28:44 +0000 Subject: [PATCH 1488/2047] New file. --- test-suite/tests/import.test | 76 ++++++++++++++++++++++++++++++++++++ 1 file changed, 76 insertions(+) create mode 100644 test-suite/tests/import.test diff --git a/test-suite/tests/import.test b/test-suite/tests/import.test new file mode 100644 index 000000000..330c91a0b --- /dev/null +++ b/test-suite/tests/import.test @@ -0,0 +1,76 @@ +;;;; import.test --- test selective and renaming imports -*- scheme -*- +;;;; Copyright (C) 2000 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. + +(define-module (exporter) + :export (foo bar)) + +(define foo 1) +(define bar 2) + +(define-module (importer) + :use-module (test-suite lib)) + +(use-modules ((exporter) + :select (foo (bar . baz)))) + +(pass-if-exception "selective non-import" (cons 'unbound-variable + "^Unbound variable") + (= bar 2)) + +(pass-if "selective import" + (= foo 1)) + +(pass-if "renaming import" + (= baz 2)) + +(use-modules ((exporter) :renamer (symbol-prefix-proc 'external:))) + +(pass-if "symbol-prefic-proc import" + (and (= external:foo 1) + (= external:bar 2))) + +(use-modules ((exporter) :renamer (lambda (sym) + (symbol-append sym ':external)))) + +(pass-if "renamer import" + (and (= foo:external 1) + (= bar:external 2))) From 22647fef9fb2806fd29474702edbb1187e82fa87 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 12 Jul 2001 23:28:53 +0000 Subject: [PATCH 1489/2047] *** empty log message *** --- ice-9/ChangeLog | 14 ++++++++++++++ srfi/ChangeLog | 5 +++++ test-suite/ChangeLog | 4 ++++ 3 files changed, 23 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index ed434d630..ea0fc5b95 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,17 @@ +2001-07-13 Marius Vollmer + + * safe-r5rs.scm: Use `re-export' instead of `export' for + re-exported core bindings. Do not re-export `numerator', + `denominator' and `rationalize' since Guile does not have them. + Continue to use `export' for `null-environment'. + + * null.scm: Use `re-export' instead of `export' for re-exported + core bindings. Do not export `unquote' and `unquote-splicing' + since there aren't definitions for them. + + * boot-9.scm (compile-interface-spec): Bug fix: the keyword + argument is "renamer" not "rename". + 2001-07-09 Rob Browning * boot-9.scm: Fixed the sense of the error message when read-eval? diff --git a/srfi/ChangeLog b/srfi/ChangeLog index dc6ee8cf0..16861e10b 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,8 @@ +2001-07-13 Marius Vollmer + + * srfi-2.scm (and-let*): Use `re-export-syntax' instead of + `export-syntax'. + 2001-07-11 Gary Houston * srfi-14.c (s_scm_char_set_eq): bug fix: (char-set=) should diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 12be6b2e2..e1baec7d3 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2001-07-13 Marius Vollmer + + * tests/import.test: New file. + 2001-06-30 Dirk Herrmann * tests/goops.test: Started with some real tests. From 61897afe9a5950c5369c954c685d52d7d8aad7ce Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 14 Jul 2001 09:40:10 +0000 Subject: [PATCH 1490/2047] Re-add authorship info. --- scripts/PROGRAM | 2 ++ scripts/display-commentary | 2 ++ scripts/doc-snarf | 2 ++ scripts/generate-autoload | 2 ++ scripts/punify | 2 ++ scripts/read-scheme-source | 2 ++ scripts/snarf-check-and-output-texi | 2 ++ scripts/use2dot | 2 ++ 8 files changed, 16 insertions(+) diff --git a/scripts/PROGRAM b/scripts/PROGRAM index 74a4f3cff..3511ccdfc 100755 --- a/scripts/PROGRAM +++ b/scripts/PROGRAM @@ -22,6 +22,8 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA +;;; Author: J.R.Hacker + ;;; Commentary: ;; Usage: PROGRAM [ARGS] diff --git a/scripts/display-commentary b/scripts/display-commentary index 4d1b17f0a..1eeb842d8 100755 --- a/scripts/display-commentary +++ b/scripts/display-commentary @@ -22,6 +22,8 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA +;;; Author: Thien-Thi Nguyen + ;;; Commentary: ;; Usage: display-commentary FILE1 FILE2 ... diff --git a/scripts/doc-snarf b/scripts/doc-snarf index 6279c9c68..941682e78 100755 --- a/scripts/doc-snarf +++ b/scripts/doc-snarf @@ -22,6 +22,8 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA +;;; Author: Martin Grabmueller + ;;; Commentary: ;; Usage: doc-snarf FILE diff --git a/scripts/generate-autoload b/scripts/generate-autoload index d1e5ba3b9..eef2b88c5 100755 --- a/scripts/generate-autoload +++ b/scripts/generate-autoload @@ -22,6 +22,8 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA +;;; Author: Thien-Thi Nguyen + ;;; Commentary: ;; Usage: generate-autoload [OPTIONS] FILE1 FILE2 ... diff --git a/scripts/punify b/scripts/punify index 8101550f2..1cc318fb6 100755 --- a/scripts/punify +++ b/scripts/punify @@ -22,6 +22,8 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA +;;; Author: Thien-Thi Nguyen + ;;; Commentary: ;; Usage: punify FILE1 FILE2 ... diff --git a/scripts/read-scheme-source b/scripts/read-scheme-source index 6a82938e4..48e96058a 100755 --- a/scripts/read-scheme-source +++ b/scripts/read-scheme-source @@ -22,6 +22,8 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA +;;; Author: Thien-Thi Nguyen + ;;; Commentary: ;; Usage: read-scheme-source FILE1 FILE2 ... diff --git a/scripts/snarf-check-and-output-texi b/scripts/snarf-check-and-output-texi index b61e77d34..e3c84f540 100755 --- a/scripts/snarf-check-and-output-texi +++ b/scripts/snarf-check-and-output-texi @@ -22,6 +22,8 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA +;;; Author: Michael Livshin + ;;; Code: (define-module (scripts snarf-check-and-output-texi) diff --git a/scripts/use2dot b/scripts/use2dot index b52276a38..d2cb64695 100755 --- a/scripts/use2dot +++ b/scripts/use2dot @@ -22,6 +22,8 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA +;;; Author: Thien-Thi Nguyen + ;;; Commentary: ;; Usage: use2dot [OPTIONS] [FILE ...] From 08576c585e0b47c4bba12b6eec582934c00e743f Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 14 Jul 2001 09:40:59 +0000 Subject: [PATCH 1491/2047] *** empty log message *** --- scripts/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/scripts/ChangeLog b/scripts/ChangeLog index a4f4f8195..257fdad91 100644 --- a/scripts/ChangeLog +++ b/scripts/ChangeLog @@ -1,3 +1,9 @@ +2001-07-14 Thien-Thi Nguyen + + * PROGRAM, display-commentary, doc-snarf, generate-autoload, + punify, read-scheme-source, snarf-check-and-output-texi, use2dot: + Re-add authorship info. + 2001-07-12 Michael Livshin * snarf-check-and-output-texi (do-argpos): complain to the stderr, From 4be5d9762537a44720e31e135f084080f51df18b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Sat, 14 Jul 2001 11:11:48 +0000 Subject: [PATCH 1492/2047] * examples/modules/main: Use :renamer for specifying renaming procedure. --- examples/ChangeLog | 4 ++++ examples/modules/main | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/examples/ChangeLog b/examples/ChangeLog index 99e51f89c..d7a556d59 100644 --- a/examples/ChangeLog +++ b/examples/ChangeLog @@ -1,3 +1,7 @@ +2001-07-14 Martin Grabmueller + + * modules/main: Use :renamer for specifying renaming procedure. + 2001-07-10 Thien-Thi Nguyen * scripts/hello (display-version, display-help): Fix comment; nfc. diff --git a/examples/modules/main b/examples/modules/main index 603ea10f1..e4cc71dc7 100644 --- a/examples/modules/main +++ b/examples/modules/main @@ -22,7 +22,7 @@ ;; Module 1 is imported completely, too, but the procedure names are ;; prefixed with the module name. ;; - :use-module ((module-1) :rename (symbol-prefix-proc 'module-1:)) + :use-module ((module-1) :renamer (symbol-prefix-proc 'module-1:)) ;; From module 2, only the procedure `braz' is imported, so that the ;; procedures `foo' and `bar' also exported by that module don't From 396f36cdbfe40800a6aeacbdf3ceca7ddbd1a962 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 15 Jul 2001 15:16:31 +0000 Subject: [PATCH 1493/2047] * srfi-14.c (scm_char_set_hash): recognise 0 instead of #f in the opt arg to give default bound, as in final spec. don't allow negative bounds. --- srfi/ChangeLog | 6 ++++++ srfi/srfi-14.c | 14 ++++++++++---- 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 16861e10b..9a75116cc 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,9 @@ +2001-07-15 Gary Houston + + * srfi-14.c (scm_char_set_hash): recognise 0 instead of #f in the + opt arg to give default bound, as in final spec. don't allow + negative bounds. + 2001-07-13 Marius Vollmer * srfi-2.scm (and-let*): Use `re-export-syntax' instead of diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index b18cb1251..e3fbbcc1e 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -178,20 +178,26 @@ SCM_DEFINE (scm_char_set_leq, "char-set<=", 0, 0, 1, SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0, (SCM cs, SCM bound), "Compute a hash value for the character set @var{cs}. If\n" - "@var{bound} is given and not @code{#f}, it restricts the\n" + "@var{bound} is given and non-zero, it restricts the\n" "returned value to the range 0 @dots{} @var{bound - 1}.") #define FUNC_NAME s_scm_char_set_hash { + const int default_bnd = 871; int bnd; long * p; unsigned val = 0; int k; SCM_VALIDATE_SMOB (1, cs, charset); - if (SCM_UNBNDP (bound) || SCM_FALSEP (bound)) - bnd = 871; + + if (SCM_UNBNDP (bound)) + bnd = default_bnd; else - SCM_VALIDATE_INUM_COPY (2, bound, bnd); + { + SCM_VALIDATE_INUM_MIN_COPY (2, bound, 0, bnd); + if (bnd == 0) + bnd = default_bnd; + } p = (long *) SCM_SMOB_DATA (cs); for (k = 0; k < SCM_CHARSET_SIZE - 1; k++) From b87f5a839490236ce76deb873e81cdec9a477269 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 15 Jul 2001 18:54:28 +0000 Subject: [PATCH 1494/2047] (scm_char_set_hash): bug fix: was overrunning the buffer and calculating based on garbage. (scm_char_set_eq, scm_char_set_leq): fix argument number in error reporting: wasn't incremented due to macro coding. (scm_char_set): report argument number in error reporting: was hard coded to 1. remove a couple of local variables. --- srfi/ChangeLog | 6 ++++++ srfi/srfi-14.c | 21 +++++++++++---------- 2 files changed, 17 insertions(+), 10 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 9a75116cc..8b467df17 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -3,6 +3,12 @@ * srfi-14.c (scm_char_set_hash): recognise 0 instead of #f in the opt arg to give default bound, as in final spec. don't allow negative bounds. + (scm_char_set_hash): bug fix: was overrunning the buffer and + calculating based on garbage. + (scm_char_set_eq, scm_char_set_leq): fix argument number in error + reporting: wasn't incremented due to macro coding. + (scm_char_set): report argument number in error reporting: was + hard coded to 1. remove a couple of local variables. 2001-07-13 Marius Vollmer diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index e3fbbcc1e..685ee89bc 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -126,7 +126,8 @@ SCM_DEFINE (scm_char_set_eq, "char-set=", 0, 0, 1, SCM csi = SCM_CAR (char_sets); long *csi_data; - SCM_VALIDATE_SMOB (argnum++, csi, charset); + SCM_VALIDATE_SMOB (argnum, csi, charset); + argnum++; csi_data = (long *) SCM_SMOB_DATA (csi); if (cs1_data == NULL) cs1_data = csi_data; @@ -155,7 +156,8 @@ SCM_DEFINE (scm_char_set_leq, "char-set<=", 0, 0, 1, SCM csi = SCM_CAR (char_sets); long *csi_data; - SCM_VALIDATE_SMOB (argnum++, csi, charset); + SCM_VALIDATE_SMOB (argnum, csi, charset); + argnum++; csi_data = (long *) SCM_SMOB_DATA (csi); if (prev_data) { @@ -200,7 +202,7 @@ SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0, } p = (long *) SCM_SMOB_DATA (cs); - for (k = 0; k < SCM_CHARSET_SIZE - 1; k++) + for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) { val = p[k] ^ val; } @@ -458,21 +460,20 @@ SCM_DEFINE (scm_char_set, "char-set", 0, 0, 1, "Return a character set containing all given characters.") #define FUNC_NAME s_scm_char_set { - SCM cs, ls; + SCM cs; long * p; + int argnum = 1; SCM_VALIDATE_REST_ARGUMENT (rest); - ls = rest; cs = make_char_set (FUNC_NAME); p = (long *) SCM_SMOB_DATA (cs); - while (!SCM_NULLP (ls)) + while (!SCM_NULLP (rest)) { - SCM chr = SCM_CAR (ls); int c; - SCM_VALIDATE_CHAR_COPY (1, chr, c); - ls = SCM_CDR (ls); - + SCM_VALIDATE_CHAR_COPY (argnum, SCM_CAR (rest), c); + argnum++; + rest = SCM_CDR (rest); p[c / sizeof (long)] |= 1 << (c % sizeof (long)); } return cs; From 5a1a7950e69b75974d64e2382913f045087a4900 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 15 Jul 2001 21:50:23 +0000 Subject: [PATCH 1495/2047] Remove onerous authorship-info deletion clause. --- HACKING | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/HACKING b/HACKING index ddec624c8..12ed66312 100644 --- a/HACKING +++ b/HACKING @@ -287,7 +287,7 @@ and I'll take care of the administrivia. Put the contributions aside until we have the necessary papers. Once you accept a contribution, be sure to keep the files AUTHORS and -THANKS uptodate. Feel free to remove authorship info from source files. +THANKS uptodate. - When you make substantial changes to a file, add the current year to the list of years in the copyright notice at the top of the file. From 8f2ecec52e812ee6dd90c184d4502d10a920e939 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 15 Jul 2001 21:52:25 +0000 Subject: [PATCH 1496/2047] *** empty log message *** --- ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ChangeLog b/ChangeLog index 88b76cccf..3af3aa9cd 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2001-07-15 Thien-Thi Nguyen + + * HACKING: Remove onerous authorship-info deletion clause. + 2001-07-13 Keisuke Nishida * autogen.sh: Call libtoolize with --force. From 63bcad1964527df2d658035766467b2f782fb043 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 16 Jul 2001 10:22:38 +0000 Subject: [PATCH 1497/2047] * Minor changes. --- libguile/ChangeLog | 10 + libguile/fports.c | 2 +- libguile/num2integral.i.c | 4 +- libguile/symbols-deprecated.c | 635 ---------------------------------- libguile/vectors.c | 2 - 5 files changed, 13 insertions(+), 640 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index a78276fbb..b1663b21f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,13 @@ +2001-07-16 Dirk Herrmann + + * fports.c (fport_print): Don't use SCM_C[AD]R for non pairs. + + * num2integral.i.c (INTEGRAL2NUM, INTEGRAL2BIG): Fix signedness. + + * symbols-deprecated.c (scm_gentemp): Simplify vector test. + + * vectors.c (scm_vector_p): Eliminate redundant IMP test. + 2001-07-12 Michael Livshin * strings.c (s_scm_string): fix arg position in assert. diff --git a/libguile/fports.c b/libguile/fports.c index 8ccfeab70..9466214b2 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -515,7 +515,7 @@ fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port); scm_putc (' ', port); - scm_intprint (SCM_UNPACK (SCM_CDR (exp)), 16, port); + scm_intprint ((scm_t_bits) SCM_PTAB_ENTRY (exp), 16, port); } scm_putc ('>', port); return 1; diff --git a/libguile/num2integral.i.c b/libguile/num2integral.i.c index f273eef89..e0982bac3 100644 --- a/libguile/num2integral.i.c +++ b/libguile/num2integral.i.c @@ -92,7 +92,7 @@ INTEGRAL2NUM (ITYPE n) SCM_POSFIXABLE (n) #endif ) - return SCM_MAKINUM ((long) n); + return SCM_MAKINUM ((scm_t_signed_bits) n); #ifdef SCM_BIGDIG return INTEGRAL2BIG (n); @@ -108,7 +108,7 @@ INTEGRAL2BIG (ITYPE n) { SCM res; int neg_p; - int n_digits; + unsigned int n_digits; size_t i; SCM_BIGDIG *digits; diff --git a/libguile/symbols-deprecated.c b/libguile/symbols-deprecated.c index 6157966f0..e69de29bb 100644 --- a/libguile/symbols-deprecated.c +++ b/libguile/symbols-deprecated.c @@ -1,635 +0,0 @@ -/* Copyright (C) 1995,1996,1997,1998, 2000, 2001 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 - * the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ - - - - -#include "libguile/_scm.h" -#include "libguile/chars.h" -#include "libguile/eval.h" -#include "libguile/hash.h" -#include "libguile/smob.h" -#include "libguile/variable.h" -#include "libguile/alist.h" -#include "libguile/fluids.h" -#include "libguile/strings.h" -#include "libguile/vectors.h" -#include "libguile/hashtab.h" -#include "libguile/weaks.h" -#include "libguile/modules.h" -#include "libguile/deprecation.h" - -#include "libguile/validate.h" -#include "libguile/symbols.h" - -#ifdef HAVE_STRING_H -#include -#endif - - - -#if SCM_ENABLE_VCELLS - -/* scm_sym2ovcell - * looks up the symbol in an arbitrary obarray. - */ - -SCM -scm_sym2ovcell_soft (SCM sym, SCM obarray) -{ - SCM lsym, z; - size_t hash = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (obarray); - - scm_c_issue_deprecation_warning ("`scm_sym2ovcell_soft' is deprecated. " - "Use hashtables instead."); - - SCM_REDEFER_INTS; - for (lsym = SCM_VELTS (obarray)[hash]; - SCM_NIMP (lsym); - lsym = SCM_CDR (lsym)) - { - z = SCM_CAR (lsym); - if (SCM_EQ_P (SCM_CAR (z), sym)) - { - SCM_REALLOW_INTS; - return z; - } - } - SCM_REALLOW_INTS; - return SCM_BOOL_F; -} - - -SCM -scm_sym2ovcell (SCM sym, SCM obarray) -#define FUNC_NAME "scm_sym2ovcell" -{ - SCM answer; - - scm_c_issue_deprecation_warning ("`scm_sym2ovcell' is deprecated. " - "Use hashtables instead."); - - answer = scm_sym2ovcell_soft (sym, obarray); - if (!SCM_FALSEP (answer)) - return answer; - SCM_MISC_ERROR ("uninterned symbol: ~S", scm_list_1 (sym)); - return SCM_UNSPECIFIED; /* not reached */ -} -#undef FUNC_NAME - - -/* Intern a symbol whose name is the LEN characters at NAME in OBARRAY. - - OBARRAY should be a vector of lists, indexed by the name's hash - value, modulo OBARRAY's length. Each list has the form - ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the - value associated with that symbol (in the current module? in the - system module?) - - To "intern" a symbol means: if OBARRAY already contains a symbol by - that name, return its (SYMBOL . VALUE) pair; otherwise, create a - new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the - appropriate list of the OBARRAY, and return the pair. - - If softness is non-zero, don't create a symbol if it isn't already - in OBARRAY; instead, just return #f. - - If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and - return (SYMBOL . SCM_UNDEFINED). */ - - -SCM -scm_intern_obarray_soft (const char *name,size_t len,SCM obarray,unsigned int softness) -{ - SCM symbol = scm_mem2symbol (name, len); - size_t raw_hash = SCM_SYMBOL_HASH (symbol); - size_t hash; - SCM lsym; - - scm_c_issue_deprecation_warning ("`scm_intern_obarray_soft' is deprecated. " - "Use hashtables instead."); - - if (SCM_FALSEP (obarray)) - { - if (softness) - return SCM_BOOL_F; - else - return scm_cons (symbol, SCM_UNDEFINED); - } - - hash = raw_hash % SCM_VECTOR_LENGTH (obarray); - - for (lsym = SCM_VELTS (obarray)[hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) - { - SCM a = SCM_CAR (lsym); - SCM z = SCM_CAR (a); - if (SCM_EQ_P (z, symbol)) - return a; - } - - if (softness) - { - return SCM_BOOL_F; - } - else - { - SCM cell = scm_cons (symbol, SCM_UNDEFINED); - SCM slot = SCM_VELTS (obarray) [hash]; - - SCM_VELTS (obarray) [hash] = scm_cons (cell, slot); - - return cell; - } -} - - -SCM -scm_intern_obarray (const char *name,size_t len,SCM obarray) -{ - scm_c_issue_deprecation_warning ("`scm_intern_obarray' is deprecated. " - "Use hashtables instead."); - - return scm_intern_obarray_soft (name, len, obarray, 0); -} - - -SCM -scm_intern (const char *name,size_t len) -{ - scm_c_issue_deprecation_warning ("`scm_intern' is deprecated. " - "Use scm_c_define or scm_c_lookup instead."); - - { - SCM symbol = scm_mem2symbol (name, len); - SCM var = scm_sym2var (symbol, SCM_BOOL_F, SCM_BOOL_T); - SCM vcell = SCM_VARVCELL (var); - SCM_SETCAR (vcell, symbol); - return vcell; - } -} - - -SCM -scm_intern0 (const char * name) -{ - scm_c_issue_deprecation_warning ("`scm_intern0' is deprecated. " - "Use scm_define or scm_lookup instead."); - - return scm_intern (name, strlen (name)); -} - -/* Intern the symbol named NAME in scm_symhash, and give it the value - VAL. NAME is null-terminated. Use the current top_level lookup - closure to give NAME its value. - */ -SCM -scm_sysintern (const char *name, SCM val) -{ - SCM var; - - scm_c_issue_deprecation_warning ("`scm_sysintern' is deprecated. " - "Use `scm_define' instead."); - - var = scm_c_define (name, val); - return SCM_VARVCELL (var); -} - -SCM -scm_sysintern0 (const char *name) -{ - SCM var; - SCM symbol; - - scm_c_issue_deprecation_warning ("`scm_sysintern0' is deprecated. " - "Use `scm_define' instead."); - - symbol = scm_str2symbol (name); - var = scm_sym2var (symbol, scm_current_module_lookup_closure (), SCM_BOOL_T); - if (var == SCM_BOOL_F) - scm_misc_error ("sysintern0", "can't define variable", symbol); - return SCM_VARVCELL (var); -} - -/* Lookup the value of the symbol named by the nul-terminated string - NAME in the current module. */ -SCM -scm_symbol_value0 (const char *name) -{ - scm_c_issue_deprecation_warning ("`scm_symbol_value0' is deprecated. " - "Use `scm_lookup' instead."); - - return scm_variable_ref (scm_c_lookup (name)); -} - -SCM -scm_sym2vcell (SCM sym, SCM thunk, SCM definep) -{ - SCM var; - - scm_c_issue_deprecation_warning("`scm_sym2vcell' is deprecated. " - "Use `scm_define' or `scm_lookup' instead."); - - var = scm_sym2var (sym, thunk, definep); - if (var == SCM_BOOL_F) - return SCM_BOOL_F; - return SCM_VARVCELL (var); -} - -SCM_DEFINE (scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, - (SCM o, SCM s, SCM softp), - "Intern a new symbol in @var{obarray}, a symbol table, with name\n" - "@var{string}.\n\n" - "If @var{obarray} is @code{#f}, use the default system symbol table. If\n" - "@var{obarray} is @code{#t}, the symbol should not be interned in any\n" - "symbol table; merely return the pair (@var{symbol}\n" - ". @var{#}).\n\n" - "The @var{soft?} argument determines whether new symbol table entries\n" - "should be created when the specified symbol is not already present in\n" - "@var{obarray}. If @var{soft?} is specified and is a true value, then\n" - "new entries should not be added for symbols not already present in the\n" - "table; instead, simply return @code{#f}.") -#define FUNC_NAME s_scm_string_to_obarray_symbol -{ - SCM vcell; - SCM answer; - int softness; - - SCM_VALIDATE_STRING (2, s); - SCM_ASSERT (SCM_BOOLP (o) || SCM_VECTORP (o), o, SCM_ARG1, FUNC_NAME); - - scm_c_issue_deprecation_warning ("`string->obarray-symbol' is deprecated. " - "Use hashtables instead."); - - softness = (!SCM_UNBNDP (softp) && !SCM_FALSEP(softp)); - /* iron out some screwy calling conventions */ - if (SCM_FALSEP (o)) - { - /* nothing interesting to do here. */ - return scm_string_to_symbol (s); - } - else if (SCM_EQ_P (o, SCM_BOOL_T)) - o = SCM_BOOL_F; - - vcell = scm_intern_obarray_soft (SCM_STRING_CHARS(s), - SCM_STRING_LENGTH (s), - o, - softness); - if (SCM_FALSEP (vcell)) - return vcell; - answer = SCM_CAR (vcell); - return answer; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0, - (SCM o, SCM s), - "Add a new symbol to @var{obarray} with name @var{string}, bound to an\n" - "unspecified initial value. The symbol table is not modified if a symbol\n" - "with this name is already present.") -#define FUNC_NAME s_scm_intern_symbol -{ - size_t hval; - SCM_VALIDATE_SYMBOL (2,s); - if (SCM_FALSEP (o)) - return SCM_UNSPECIFIED; - - scm_c_issue_deprecation_warning ("`intern-symbol' is deprecated. " - "Use hashtables instead."); - - SCM_VALIDATE_VECTOR (1,o); - hval = SCM_SYMBOL_HASH (s) % SCM_VECTOR_LENGTH (o); - /* If the symbol is already interned, simply return. */ - SCM_REDEFER_INTS; - { - SCM lsym; - SCM sym; - for (lsym = SCM_VELTS (o)[hval]; - SCM_NIMP (lsym); - lsym = SCM_CDR (lsym)) - { - sym = SCM_CAR (lsym); - if (SCM_EQ_P (SCM_CAR (sym), s)) - { - SCM_REALLOW_INTS; - return SCM_UNSPECIFIED; - } - } - SCM_VELTS (o)[hval] = - scm_acons (s, SCM_UNDEFINED, SCM_VELTS (o)[hval]); - } - SCM_REALLOW_INTS; - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0, - (SCM o, SCM s), - "Remove the symbol with name @var{string} from @var{obarray}. This\n" - "function returns @code{#t} if the symbol was present and @code{#f}\n" - "otherwise.") -#define FUNC_NAME s_scm_unintern_symbol -{ - size_t hval; - - scm_c_issue_deprecation_warning ("`unintern-symbol' is deprecated. " - "Use hashtables instead."); - - SCM_VALIDATE_SYMBOL (2,s); - if (SCM_FALSEP (o)) - return SCM_BOOL_F; - SCM_VALIDATE_VECTOR (1,o); - hval = SCM_SYMBOL_HASH (s) % SCM_VECTOR_LENGTH (o); - SCM_DEFER_INTS; - { - SCM lsym_follow; - SCM lsym; - SCM sym; - for (lsym = SCM_VELTS (o)[hval], lsym_follow = SCM_BOOL_F; - SCM_NIMP (lsym); - lsym_follow = lsym, lsym = SCM_CDR (lsym)) - { - sym = SCM_CAR (lsym); - if (SCM_EQ_P (SCM_CAR (sym), s)) - { - /* Found the symbol to unintern. */ - if (SCM_FALSEP (lsym_follow)) - SCM_VELTS(o)[hval] = lsym; - else - SCM_SETCDR (lsym_follow, SCM_CDR(lsym)); - SCM_ALLOW_INTS; - return SCM_BOOL_T; - } - } - } - SCM_ALLOW_INTS; - return SCM_BOOL_F; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_symbol_binding, "symbol-binding", 2, 0, 0, - (SCM o, SCM s), - "Look up in @var{obarray} the symbol whose name is @var{string}, and\n" - "return the value to which it is bound. If @var{obarray} is @code{#f},\n" - "use the global symbol table. If @var{string} is not interned in\n" - "@var{obarray}, an error is signalled.") -#define FUNC_NAME s_scm_symbol_binding -{ - SCM vcell; - - scm_c_issue_deprecation_warning ("`symbol-binding' is deprecated. " - "Use hashtables instead."); - - SCM_VALIDATE_SYMBOL (2,s); - if (SCM_FALSEP (o)) - return scm_variable_ref (scm_lookup (s)); - SCM_VALIDATE_VECTOR (1,o); - vcell = scm_sym2ovcell (s, o); - return SCM_CDR(vcell); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 2, 0, 0, - (SCM o, SCM s), - "Return @code{#t} if @var{obarray} contains a symbol with name\n" - "@var{string}, and @code{#f} otherwise.") -#define FUNC_NAME s_scm_symbol_interned_p -{ - SCM vcell; - - scm_c_issue_deprecation_warning ("`symbol-interned?' is deprecated. " - "Use hashtables instead."); - - SCM_VALIDATE_SYMBOL (2,s); - if (SCM_FALSEP (o)) - { - SCM var = scm_sym2var (s, SCM_BOOL_F, SCM_BOOL_F); - if (var != SCM_BOOL_F) - return SCM_BOOL_T; - return SCM_BOOL_F; - } - SCM_VALIDATE_VECTOR (1,o); - vcell = scm_sym2ovcell_soft (s, o); - return (SCM_NIMP(vcell) - ? SCM_BOOL_T - : SCM_BOOL_F); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_symbol_bound_p, "symbol-bound?", 2, 0, 0, - (SCM o, SCM s), - "Return @code{#t} if @var{obarray} contains a symbol with name\n" - "@var{string} bound to a defined value. This differs from\n" - "@var{symbol-interned?} in that the mere mention of a symbol\n" - "usually causes it to be interned; @code{symbol-bound?}\n" - "determines whether a symbol has been given any meaningful\n" - "value.") -#define FUNC_NAME s_scm_symbol_bound_p -{ - SCM vcell; - - scm_c_issue_deprecation_warning ("`symbol-bound?' is deprecated. " - "Use hashtables instead."); - - SCM_VALIDATE_SYMBOL (2,s); - if (SCM_FALSEP (o)) - { - SCM var = scm_sym2var (s, SCM_BOOL_F, SCM_BOOL_F); - if (SCM_DEFVARIABLEP (var)) - return SCM_BOOL_T; - return SCM_BOOL_F; - } - SCM_VALIDATE_VECTOR (1,o); - vcell = scm_sym2ovcell_soft (s, o); - return SCM_BOOL (SCM_NIMP (vcell) && !SCM_UNBNDP (SCM_CDR (vcell))); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_symbol_set_x, "symbol-set!", 3, 0, 0, - (SCM o, SCM s, SCM v), - "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n" - "it to @var{value}. An error is signalled if @var{string} is not present\n" - "in @var{obarray}.") -#define FUNC_NAME s_scm_symbol_set_x -{ - SCM vcell; - - scm_c_issue_deprecation_warning ("`symbol-set!' is deprecated. " - "Use the module system instead."); - - SCM_VALIDATE_SYMBOL (2,s); - if (SCM_FALSEP (o)) - { - scm_define (s, v); - return SCM_UNSPECIFIED; - } - SCM_VALIDATE_VECTOR (1,o); - vcell = scm_sym2ovcell (s, o); - SCM_SETCDR (vcell, v); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -#if 0 - -static void -copy_and_prune_obarray (SCM from, SCM to) -{ - int i; - int length = SCM_VECTOR_LENGTH (from); - for (i = 0; i < length; ++i) - { - SCM head = SCM_VELTS (from)[i]; /* GC protection */ - SCM ls = head; - SCM res = SCM_EOL; - SCM *lloc = &res; - while (SCM_NIMP (ls)) - { - if (!SCM_UNBNDP (SCM_CDAR (ls))) - { - *lloc = scm_cons (SCM_CAR (ls), SCM_EOL); - lloc = SCM_CDRLOC (*lloc); - } - ls = SCM_CDR (ls); - } - SCM_VELTS (to)[i] = res; - } -} - - -SCM_DEFINE (scm_builtin_bindings, "builtin-bindings", 0, 0, 0, - (), - "Create and return a copy of the global symbol table, removing all\n" - "unbound symbols.") -#define FUNC_NAME s_scm_builtin_bindings -{ - int length = SCM_VECTOR_LENGTH (scm_symhash); - SCM obarray = scm_c_make_hash_table (length); - - scm_issue_deprecation_warning ("`builtin-bindings' is deprecated. " - "Use the module system instead."); - - copy_and_prune_obarray (scm_symhash, obarray); - return obarray; -} -#undef FUNC_NAME - -#endif - -#define MAX_PREFIX_LENGTH 30 - -static int gentemp_counter; - -SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0, - (SCM prefix, SCM obarray), - "Create a new symbol with a name unique in an obarray.\n" - "The name is constructed from an optional string @var{prefix}\n" - "and a counter value. The default prefix is @code{t}. The\n" - "@var{obarray} is specified as a second optional argument.\n" - "Default is the system obarray where all normal symbols are\n" - "interned. The counter is increased by 1 at each\n" - "call. There is no provision for resetting the counter.") -#define FUNC_NAME s_scm_gentemp -{ - char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; - char *name = buf; - int len, n_digits; - - scm_c_issue_deprecation_warning ("`gentemp' is deprecated. " - "Use `gensym' instead."); - - if (SCM_UNBNDP (prefix)) - { - name[0] = 't'; - len = 1; - } - else - { - SCM_VALIDATE_STRING (1, prefix); - len = SCM_STRING_LENGTH (prefix); - if (len > MAX_PREFIX_LENGTH) - name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); - strncpy (name, SCM_STRING_CHARS (prefix), len); - } - - if (SCM_UNBNDP (obarray)) - return scm_gensym (prefix); - else - SCM_ASSERT ((SCM_VECTORP (obarray) || SCM_WVECTP (obarray)), - obarray, - SCM_ARG2, - FUNC_NAME); - do - n_digits = scm_iint2str (gentemp_counter++, 10, &name[len]); - while (!SCM_FALSEP (scm_intern_obarray_soft (name, - len + n_digits, - obarray, - 1))); - { - SCM vcell = scm_intern_obarray_soft (name, - len + n_digits, - obarray, - 0); - if (name != buf) - scm_must_free (name); - return SCM_CAR (vcell); - } -} -#undef FUNC_NAME - -void -scm_init_symbols_deprecated () -{ - gentemp_counter = 0; -#ifndef SCM_MAGIC_SNARFER -#include "libguile/symbols-deprecated.x" -#endif -} - -#endif /* SCM_ENABLE_VCELLS */ - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ diff --git a/libguile/vectors.c b/libguile/vectors.c index 8280b113e..1cc666a99 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -140,8 +140,6 @@ SCM_DEFINE (scm_vector_p, "vector?", 1, 0, 0, "@code{#f}.") #define FUNC_NAME s_scm_vector_p { - if (SCM_IMP (obj)) - return SCM_BOOL_F; return SCM_BOOL (SCM_VECTORP (obj)); } #undef FUNC_NAME From cebf3d62d915cb73ca5cc6b99e3fa006c4d0a15a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 16 Jul 2001 15:47:02 +0000 Subject: [PATCH 1498/2047] * srfi-14.c: Allocate correct memory size for charsets (32 bytes), use this value for initializing and comparing charsets. (scm_char_set_hash): Use ``better'' hash algorithm which produces more values. --- srfi/ChangeLog | 7 +++++++ srfi/srfi-14.c | 12 +++++++----- 2 files changed, 14 insertions(+), 5 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 8b467df17..8c2f2c936 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,10 @@ +2001-07-16 Martin Grabmueller + + * srfi-14.c: Allocate correct memory size for charsets (32 bytes), + use this value for initializing and comparing charsets. + (scm_char_set_hash): Use ``better'' hash algorithm which produces + more values. + 2001-07-15 Gary Houston * srfi-14.c (scm_char_set_hash): recognise 0 instead of #f in the diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index 685ee89bc..878349158 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -94,8 +94,8 @@ make_char_set (const char * func_name) { long * p; - p = scm_must_malloc (SCM_CHARSET_SIZE, func_name); - memset (p, 0, SCM_CHARSET_SIZE); + p = scm_must_malloc (SCM_CHARSET_SIZE / sizeof (char), func_name); + memset (p, 0, SCM_CHARSET_SIZE / sizeof (char)); SCM_RETURN_NEWSMOB (scm_tc16_charset, p); } @@ -131,7 +131,8 @@ SCM_DEFINE (scm_char_set_eq, "char-set=", 0, 0, 1, csi_data = (long *) SCM_SMOB_DATA (csi); if (cs1_data == NULL) cs1_data = csi_data; - else if (memcmp (cs1_data, csi_data, SCM_CHARSET_SIZE) != 0) + else if (memcmp (cs1_data, csi_data, + SCM_CHARSET_SIZE / sizeof (char)) != 0) return SCM_BOOL_F; char_sets = SCM_CDR (char_sets); } @@ -204,7 +205,8 @@ SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0, p = (long *) SCM_SMOB_DATA (cs); for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) { - val = p[k] ^ val; + if (p[k] != 0) + val = p[k] + (val << 1); } return SCM_MAKINUM (val % bnd); } @@ -1368,7 +1370,7 @@ scm_c_init_srfi_14 (void) if (!initialized) { scm_tc16_charset = scm_make_smob_type ("character-set", - SCM_CHARSET_SIZE * sizeof (long)); + SCM_CHARSET_SIZE / sizeof (char)); scm_set_smob_free (scm_tc16_charset, charset_free); scm_set_smob_print (scm_tc16_charset, charset_print); initialized = 1; From 072ad0fe6b41339ffde847232c04bc3fa497de78 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 16 Jul 2001 18:49:10 +0000 Subject: [PATCH 1499/2047] * tests/srfi-14.test: New file. --- test-suite/ChangeLog | 4 + test-suite/tests/srfi-14.test | 188 ++++++++++++++++++++++++++++++++++ 2 files changed, 192 insertions(+) create mode 100644 test-suite/tests/srfi-14.test diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index e1baec7d3..b54a5df3a 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2001-07-16 Martin Grabmueller + + * tests/srfi-14.test: New file. + 2001-07-13 Marius Vollmer * tests/import.test: New file. diff --git a/test-suite/tests/srfi-14.test b/test-suite/tests/srfi-14.test new file mode 100644 index 000000000..bd927c0bb --- /dev/null +++ b/test-suite/tests/srfi-14.test @@ -0,0 +1,188 @@ +;;;; srfi-14.test --- Test suite for Guile's SRFI-14 functions. -*- scheme -*- +;;;; Martin Grabmueller, 2001-07-16 +;;;; +;;;; Copyright (C) 2001 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +(use-modules (srfi srfi-14)) + +(define exception:invalid-char-set-cursor + (cons 'misc-error "^invalid character set cursor")) + +(define exception:non-char-return + (cons 'misc-error "returned non-char")) + +(with-test-prefix "char-set?" + + (pass-if "success on empty set" + (char-set? (char-set))) + + (pass-if "success on non-empty set" + (char-set? char-set:printing)) + + (pass-if "failure on empty set" + (not (char-set? #t)))) + + +(with-test-prefix "char-set=" + (pass-if "success, no arg" + (char-set=)) + + (pass-if "success, one arg" + (char-set= char-set:lower-case)) + + (pass-if "success, two args" + (char-set= char-set:upper-case char-set:upper-case)) + + (pass-if "failure, first empty" + (not (char-set= (char-set) (char-set #\a)))) + + (pass-if "failure, second empty" + (not (char-set= (char-set #\a) (char-set)))) + + (pass-if "success, more args" + (char-set= char-set:blank char-set:blank char-set:blank))) + +(with-test-prefix "char-set<=" + (pass-if "success, no arg" + (char-set<=)) + + (pass-if "success, one arg" + (char-set<= char-set:lower-case)) + + (pass-if "success, two args" + (char-set<= char-set:upper-case char-set:upper-case)) + + (pass-if "success, first empty" + (char-set<= (char-set) (char-set #\a))) + + (pass-if "failure, second empty" + (not (char-set<= (char-set #\a) (char-set)))) + + (pass-if "success, more args, equal" + (char-set<= char-set:blank char-set:blank char-set:blank)) + + (pass-if "success, more args, not equal" + (char-set<= char-set:blank + (char-set-adjoin char-set:blank #\F) + (char-set-adjoin char-set:blank #\F #\o)))) + +(with-test-prefix "char-set-hash" + (pass-if "empty set, bound" + (let ((h (char-set-hash char-set:empty 31))) + (and h (number? h) (exact? h) (>= h 0) (< h 31)))) + + (pass-if "empty set, no bound" + (let ((h (char-set-hash char-set:empty))) + (and h (number? h) (exact? h) (>= h 0)))) + + (pass-if "full set, bound" + (let ((h (char-set-hash char-set:full 31))) + (and h (number? h) (exact? h) (>= h 0) (< h 31)))) + + (pass-if "full set, no bound" + (let ((h (char-set-hash char-set:full))) + (and h (number? h) (exact? h) (>= h 0)))) + + (pass-if "other set, bound" + (let ((h (char-set-hash (char-set #\f #\o #\b #\a #\r) 31))) + (and h (number? h) (exact? h) (>= h 0) (< h 31)))) + + (pass-if "other set, no bound" + (let ((h (char-set-hash (char-set #\f #\o #\b #\a #\r)))) + (and h (number? h) (exact? h) (>= h 0))))) + + +(with-test-prefix "char-set cursor" + + (pass-if-exception "invalid character cursor" + exception:invalid-char-set-cursor + (let* ((cs (char-set #\B #\r #\a #\z)) + (cc (char-set-cursor cs))) + (char-set-ref cs 1000))) + + (pass-if "success" + (let* ((cs (char-set #\B #\r #\a #\z)) + (cc (char-set-cursor cs))) + (char? (char-set-ref cs cc)))) + + (pass-if "end of set fails" + (let* ((cs (char-set #\a)) + (cc (char-set-cursor cs))) + (not (end-of-char-set? cc)))) + + (pass-if "end of set succeeds, empty set" + (let* ((cs (char-set)) + (cc (char-set-cursor cs))) + (end-of-char-set? cc))) + + (pass-if "end of set succeeds, non-empty set" + (let* ((cs (char-set #\a)) + (cc (char-set-cursor cs)) + (cc (char-set-cursor-next cs cc))) + (end-of-char-set? cc)))) + +(with-test-prefix "char-set-fold" + + (pass-if "count members" + (= (char-set-fold (lambda (c n) (+ n 1)) 0 (char-set #\a #\b)) 2)) + + (pass-if "copy set" + (= (char-set-size (char-set-fold (lambda (c cs) (char-set-adjoin cs c)) + (char-set) (char-set #\a #\b))) 2))) + +(with-test-prefix "char-set-unfold" + + (pass-if "create char set" + (char-set= char-set:full + (char-set-unfold (lambda (s) (= s 256)) integer->char + (lambda (s) (+ s 1)) 0))) + (pass-if "create char set (base set)" + (char-set= char-set:full + (char-set-unfold (lambda (s) (= s 256)) integer->char + (lambda (s) (+ s 1)) 0 char-set:empty)))) + +(with-test-prefix "char-set-unfold!" + + (pass-if "create char set" + (char-set= char-set:full + (char-set-unfold! (lambda (s) (= s 256)) integer->char + (lambda (s) (+ s 1)) 0 + (char-set-copy char-set:empty)))) + + (pass-if "create char set" + (char-set= char-set:full + (char-set-unfold! (lambda (s) (= s 32)) integer->char + (lambda (s) (+ s 1)) 0 + (char-set-copy char-set:full))))) + + +(with-test-prefix "char-set-for-each" + + (pass-if "copy char set" + (= (char-set-size (let ((cs (char-set))) + (char-set-for-each + (lambda (c) (char-set-adjoin! cs c)) + (char-set #\a #\b)) + cs)) + 2))) + +(with-test-prefix "char-set-map" + + (pass-if "upper case char set" + (char-set= (char-set-map char-upcase char-set:lower-case) + char-set:upper-case))) From 139777e5c7fb9621456adadc98610feb5549a5de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 16 Jul 2001 18:51:11 +0000 Subject: [PATCH 1500/2047] (scm_char_set_map): Bug-fix: char-set-map was modifying the argument instead of the return value. --- srfi/ChangeLog | 5 +++++ srfi/srfi-14.c | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 8c2f2c936..081f4eaa8 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,8 @@ +2001-07-16 Martin Grabmueller + + (scm_char_set_map): Bug-fix: char-set-map was modifying the + argument instead of the return value. + 2001-07-16 Martin Grabmueller * srfi-14.c: Allocate correct memory size for charsets (32 bytes), diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index 878349158..14a717a80 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -429,7 +429,7 @@ SCM_DEFINE (scm_char_set_map, "char-set-map", 2, 0, 0, SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (k)); if (!SCM_CHARP (ch)) SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); - SCM_CHARSET_SET (cs, SCM_CHAR (ch)); + SCM_CHARSET_SET (result, SCM_CHAR (ch)); } return result; } From 8b19021c25ec8ead2e1237788160e4d486c017f4 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Mon, 16 Jul 2001 22:30:25 +0000 Subject: [PATCH 1501/2047] * srfi-14.scm: export string->char-set!, not string-char-set!. * srfi-14.c (scm_char_set_ref, scm_char_set_cursor_next, scm_end_of_char_set_p): reject negative cursor values. (scm_list_to_char_set, scm_list_to_char_set_x): when reporting type error in list component, omit the position (was always 1). --- srfi/ChangeLog | 11 ++++++++++- srfi/srfi-14.c | 10 +++++----- srfi/srfi-14.scm | 2 +- 3 files changed, 16 insertions(+), 7 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 081f4eaa8..ceadab802 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,12 @@ +2001-07-16 Gary Houston + + * srfi-14.scm: export string->char-set!, not string-char-set!. + + * srfi-14.c (scm_char_set_ref, scm_char_set_cursor_next, + scm_end_of_char_set_p): reject negative cursor values. + (scm_list_to_char_set, scm_list_to_char_set_x): when reporting + type error in list component, omit the position (was always 1). + 2001-07-16 Martin Grabmueller (scm_char_set_map): Bug-fix: char-set-map was modifying the @@ -11,7 +20,7 @@ more values. 2001-07-15 Gary Houston - + * srfi-14.c (scm_char_set_hash): recognise 0 instead of #f in the opt arg to give default bound, as in final spec. don't allow negative bounds. diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index 14a717a80..427ee9e23 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -241,7 +241,7 @@ SCM_DEFINE (scm_char_set_ref, "char-set-ref", 2, 0, 0, int ccursor; SCM_VALIDATE_SMOB (1, cs, charset); - SCM_VALIDATE_INUM_COPY (2, cursor, ccursor); + SCM_VALIDATE_INUM_MIN_COPY (2, cursor, 0, ccursor); if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor)) SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor)); @@ -260,7 +260,7 @@ SCM_DEFINE (scm_char_set_cursor_next, "char-set-cursor-next", 2, 0, 0, int ccursor; SCM_VALIDATE_SMOB (1, cs, charset); - SCM_VALIDATE_INUM_COPY (2, cursor, ccursor); + SCM_VALIDATE_INUM_MIN_COPY (2, cursor, 0, ccursor); if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor)) SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor)); @@ -282,7 +282,7 @@ SCM_DEFINE (scm_end_of_char_set_p, "end-of-char-set?", 1, 0, 0, { int ccursor; - SCM_VALIDATE_INUM_COPY (1, cursor, ccursor); + SCM_VALIDATE_INUM_MIN_COPY (1, cursor, 0, ccursor); return SCM_BOOL (ccursor >= SCM_CHARSET_SIZE); } #undef FUNC_NAME @@ -507,7 +507,7 @@ SCM_DEFINE (scm_list_to_char_set, "list->char-set", 1, 1, 0, SCM chr = SCM_CAR (list); int c; - SCM_VALIDATE_CHAR_COPY (1, chr, c); + SCM_VALIDATE_CHAR_COPY (0, chr, c); list = SCM_CDR (list); p[c / sizeof (long)] |= 1 << (c % sizeof (long)); @@ -534,7 +534,7 @@ SCM_DEFINE (scm_list_to_char_set_x, "list->char-set!", 2, 0, 0, SCM chr = SCM_CAR (list); int c; - SCM_VALIDATE_CHAR_COPY (1, chr, c); + SCM_VALIDATE_CHAR_COPY (0, chr, c); list = SCM_CDR (list); p[c / sizeof (long)] |= 1 << (c % sizeof (long)); diff --git a/srfi/srfi-14.scm b/srfi/srfi-14.scm index c123c4dc6..08aa7b71e 100644 --- a/srfi/srfi-14.scm +++ b/srfi/srfi-14.scm @@ -64,7 +64,7 @@ char-set-copy char-set list->char-set list->char-set! - string->char-set string-char-set! + string->char-set string->char-set! char-set-filter char-set-filter! ucs-range->char-set ucs-range->char-set! ->char-set From 8d4ab69245bb9dea59f2bda672c7d995789e7f81 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Tue, 17 Jul 2001 05:26:15 +0000 Subject: [PATCH 1502/2047] * goops/save.scm: Use `re-export' instead of `export' when re-exporting `make-unbound'. --- oop/ChangeLog | 5 +++++ oop/goops/save.scm | 4 +++- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/oop/ChangeLog b/oop/ChangeLog index be51f2c64..0947befbe 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -1,3 +1,8 @@ +2001-07-17 Martin Grabmueller + + * goops/save.scm: Use `re-export' instead of `export' when + re-exporting `make-unbound'. + 2001-06-05 Marius Vollmer * goops.scm: Use `re-export' instead of `export' when re-exporting diff --git a/oop/goops/save.scm b/oop/goops/save.scm index 7e937dca5..1597c8e90 100644 --- a/oop/goops/save.scm +++ b/oop/goops/save.scm @@ -48,7 +48,9 @@ :use-module (oop goops util) ) -(export save-objects load-objects restore make-unbound +(re-export make-unbound) + +(export save-objects load-objects restore enumerate! enumerate-component! write-readably write-component write-component-procedure literal? readable make-readable) From 2671725a6539221f4bb34029bcdc3714ff901dc7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Tue, 17 Jul 2001 05:35:51 +0000 Subject: [PATCH 1503/2047] * srfi-14.c: Fix for bug caused by brain-malfunctioning on my side. Bit sets were handled wrong because I couldn't tell bit counts from byte counts. Also, the bit array should be 256 / 8 bytes long. Thank you, Gary! Removed unnecessary protoype for scm_char_set_copy. --- srfi/ChangeLog | 9 +++++++++ srfi/srfi-14.c | 45 ++++++++++++++++++++++----------------------- srfi/srfi-14.h | 9 ++++++++- 3 files changed, 39 insertions(+), 24 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index ceadab802..d8546e8cb 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,12 @@ +2001-07-17 Martin Grabmueller + + * srfi-14.c: Fix for bug caused by brain-malfunctioning on my + side. Bit sets were handled wrong because I couldn't tell bit + counts from byte counts. Also, the bit array should be 256 / 8 + bytes long. Thank you, Gary! + + Removed unnecessary protoype for scm_char_set_copy. + 2001-07-16 Gary Houston * srfi-14.scm: export string->char-set!, not string-char-set!. diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index 427ee9e23..0de7a6ba3 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -50,9 +50,9 @@ #include "srfi-14.h" -#define SCM_CHARSET_SET(cs, idx) (((long *) SCM_SMOB_DATA (cs))[(idx) / sizeof (long)] |= (1 << ((idx) % sizeof (long)))) -SCM scm_char_set_copy (SCM cs); +#define SCM_CHARSET_SET(cs, idx) (((long *) SCM_SMOB_DATA (cs))[(idx) / SCM_BITS_PER_LONG] |= (1 << ((idx) % SCM_BITS_PER_LONG))) + /* Smob type code for character sets. */ int scm_tc16_charset = 0; @@ -94,8 +94,8 @@ make_char_set (const char * func_name) { long * p; - p = scm_must_malloc (SCM_CHARSET_SIZE / sizeof (char), func_name); - memset (p, 0, SCM_CHARSET_SIZE / sizeof (char)); + p = scm_must_malloc (SCM_CHARSET_SIZE / 8, func_name); + memset (p, 0, SCM_CHARSET_SIZE / 8); SCM_RETURN_NEWSMOB (scm_tc16_charset, p); } @@ -131,8 +131,7 @@ SCM_DEFINE (scm_char_set_eq, "char-set=", 0, 0, 1, csi_data = (long *) SCM_SMOB_DATA (csi); if (cs1_data == NULL) cs1_data = csi_data; - else if (memcmp (cs1_data, csi_data, - SCM_CHARSET_SIZE / sizeof (char)) != 0) + else if (memcmp (cs1_data, csi_data, SCM_CHARSET_SIZE / 8) != 0) return SCM_BOOL_F; char_sets = SCM_CDR (char_sets); } @@ -476,7 +475,7 @@ SCM_DEFINE (scm_char_set, "char-set", 0, 0, 1, SCM_VALIDATE_CHAR_COPY (argnum, SCM_CAR (rest), c); argnum++; rest = SCM_CDR (rest); - p[c / sizeof (long)] |= 1 << (c % sizeof (long)); + p[c / SCM_BITS_PER_LONG] |= 1 << (c % SCM_BITS_PER_LONG); } return cs; } @@ -510,7 +509,7 @@ SCM_DEFINE (scm_list_to_char_set, "list->char-set", 1, 1, 0, SCM_VALIDATE_CHAR_COPY (0, chr, c); list = SCM_CDR (list); - p[c / sizeof (long)] |= 1 << (c % sizeof (long)); + p[c / SCM_BITS_PER_LONG] |= 1 << (c % SCM_BITS_PER_LONG); } return cs; } @@ -537,7 +536,7 @@ SCM_DEFINE (scm_list_to_char_set_x, "list->char-set!", 2, 0, 0, SCM_VALIDATE_CHAR_COPY (0, chr, c); list = SCM_CDR (list); - p[c / sizeof (long)] |= 1 << (c % sizeof (long)); + p[c / SCM_BITS_PER_LONG] |= 1 << (c % SCM_BITS_PER_LONG); } return base_cs; } @@ -569,7 +568,7 @@ SCM_DEFINE (scm_string_to_char_set, "string->char-set", 1, 1, 0, while (k < SCM_STRING_LENGTH (str)) { int c = s[k++]; - p[c / sizeof (long)] |= 1 << (c % sizeof (long)); + p[c / SCM_BITS_PER_LONG] |= 1 << (c % SCM_BITS_PER_LONG); } return cs; } @@ -594,7 +593,7 @@ SCM_DEFINE (scm_string_to_char_set_x, "string->char-set!", 2, 0, 0, while (k < SCM_STRING_LENGTH (str)) { int c = s[k++]; - p[c / sizeof (long)] |= 1 << (c % sizeof (long)); + p[c / SCM_BITS_PER_LONG] |= 1 << (c % SCM_BITS_PER_LONG); } return base_cs; } @@ -629,7 +628,7 @@ SCM_DEFINE (scm_char_set_filter, "char-set-filter", 2, 1, 0, SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); if (!SCM_FALSEP (res)) - p[k / sizeof (long)] |= 1 << (k % sizeof (long)); + p[k / SCM_BITS_PER_LONG] |= 1 << (k % SCM_BITS_PER_LONG); } } return ret; @@ -658,7 +657,7 @@ SCM_DEFINE (scm_char_set_filter_x, "char-set-filter!", 3, 0, 0, SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); if (!SCM_FALSEP (res)) - p[k / sizeof (long)] |= 1 << (k % sizeof (long)); + p[k / SCM_BITS_PER_LONG] |= 1 << (k % SCM_BITS_PER_LONG); } } return base_cs; @@ -712,7 +711,7 @@ SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0, p = (long *) SCM_SMOB_DATA (cs); while (clower < cupper) { - p[clower / sizeof (long)] |= 1 << (clower % sizeof (long)); + p[clower / SCM_BITS_PER_LONG] |= 1 << (clower % SCM_BITS_PER_LONG); clower++; } return cs; @@ -755,7 +754,7 @@ SCM_DEFINE (scm_ucs_range_to_char_set_x, "ucs-range->char-set!", 4, 0, 0, p = (long *) SCM_SMOB_DATA (base_cs); while (clower < cupper) { - p[clower / sizeof (long)] |= 1 << (clower % sizeof (long)); + p[clower / SCM_BITS_PER_LONG] |= 1 << (clower % SCM_BITS_PER_LONG); clower++; } return base_cs; @@ -928,7 +927,7 @@ SCM_DEFINE (scm_char_set_adjoin, "char-set-adjoin", 1, 0, 1, SCM_VALIDATE_CHAR_COPY (1, chr, c); rest = SCM_CDR (rest); - p[c / sizeof (long)] |= 1 << (c % sizeof (long)); + p[c / SCM_BITS_PER_LONG] |= 1 << (c % SCM_BITS_PER_LONG); } return cs; } @@ -956,7 +955,7 @@ SCM_DEFINE (scm_char_set_delete, "char-set-delete", 1, 0, 1, SCM_VALIDATE_CHAR_COPY (1, chr, c); rest = SCM_CDR (rest); - p[c / sizeof (long)] &= ~(1 << (c % sizeof (long))); + p[c / SCM_BITS_PER_LONG] &= ~(1 << (c % SCM_BITS_PER_LONG)); } return cs; } @@ -983,7 +982,7 @@ SCM_DEFINE (scm_char_set_adjoin_x, "char-set-adjoin!", 1, 0, 1, SCM_VALIDATE_CHAR_COPY (1, chr, c); rest = SCM_CDR (rest); - p[c / sizeof (long)] |= 1 << (c % sizeof (long)); + p[c / SCM_BITS_PER_LONG] |= 1 << (c % SCM_BITS_PER_LONG); } return cs; } @@ -1010,7 +1009,7 @@ SCM_DEFINE (scm_char_set_delete_x, "char-set-delete!", 1, 0, 1, SCM_VALIDATE_CHAR_COPY (1, chr, c); rest = SCM_CDR (rest); - p[c / sizeof (long)] &= ~(1 << (c % sizeof (long))); + p[c / SCM_BITS_PER_LONG] &= ~(1 << (c % SCM_BITS_PER_LONG)); } return cs; } @@ -1129,7 +1128,7 @@ SCM_DEFINE (scm_char_set_difference, "char-set-difference", 1, 0, 1, SCM_DEFINE (scm_char_set_xor, "char-set-xor", 1, 0, 1, (SCM cs1, SCM rest), - "Return the exclusive--or of all argument character sets.") + "Return the exclusive-or of all argument character sets.") #define FUNC_NAME s_scm_char_set_xor { int c = 2; @@ -1296,7 +1295,7 @@ SCM_DEFINE (scm_char_set_difference_x, "char-set-difference!", 1, 0, 1, SCM_DEFINE (scm_char_set_xor_x, "char-set-xor!", 1, 0, 1, (SCM cs1, SCM rest), - "Return the exclusive--or of all argument character sets.") + "Return the exclusive-or of all argument character sets.") #define FUNC_NAME s_scm_char_set_xor_x { int c = 2; @@ -1369,8 +1368,8 @@ scm_c_init_srfi_14 (void) if (!initialized) { - scm_tc16_charset = scm_make_smob_type ("character-set", - SCM_CHARSET_SIZE / sizeof (char)); + scm_tc16_charset = scm_make_smob_type ("character-set", + SCM_CHARSET_SIZE / 8); scm_set_smob_free (scm_tc16_charset, charset_free); scm_set_smob_print (scm_tc16_charset, charset_print); initialized = 1; diff --git a/srfi/srfi-14.h b/srfi/srfi-14.h index 40b355236..2621ba22f 100644 --- a/srfi/srfi-14.h +++ b/srfi/srfi-14.h @@ -48,8 +48,15 @@ #define SCM_CHARSET_SIZE 256 +/* We expect 8-bit bytes here. Shoule be no problem in the year + 2001. */ +#ifndef SCM_BITS_PER_LONG +# define SCM_BITS_PER_LONG (sizeof (long) * 8) +#endif + #define SCM_CHARSET_GET(cs, idx) (((long *) SCM_SMOB_DATA (cs))\ - [(idx) / sizeof (long)] & (1 << ((idx) % sizeof (long)))) + [(idx) / SCM_BITS_PER_LONG] &\ + (1 << ((idx) % SCM_BITS_PER_LONG))) #define SCM_CHARSETP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_charset)) From 90ee03daff448f66aea68771dfe1d5df90c052e8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Tue, 17 Jul 2001 18:59:17 +0000 Subject: [PATCH 1504/2047] * r5rs.scm: Use `re-export' instead of `export' for re-exported primitives. Thanks Neil! --- ice-9/ChangeLog | 5 +++++ ice-9/r5rs.scm | 18 ++++++++++-------- 2 files changed, 15 insertions(+), 8 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index ea0fc5b95..90535775c 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2001-07-17 Martin Grabmueller + + * r5rs.scm: Use `re-export' instead of `export' for re-exported + primitives. Thanks Neil! + 2001-07-13 Marius Vollmer * safe-r5rs.scm: Use `re-export' instead of `export' for diff --git a/ice-9/r5rs.scm b/ice-9/r5rs.scm index 47dfd59f9..faf75ae9e 100644 --- a/ice-9/r5rs.scm +++ b/ice-9/r5rs.scm @@ -47,18 +47,20 @@ (module-use! %module-public-interface (resolve-interface '(ice-9 safe-r5rs))) (export scheme-report-environment - interaction-environment - - call-with-input-file call-with-output-file - with-input-from-file with-output-to-file - open-input-file open-output-file - close-input-port close-output-port - - load ;;transcript-on ;;transcript-off ) +(re-export interaction-environment + + call-with-input-file call-with-output-file + with-input-from-file with-output-to-file + open-input-file open-output-file + close-input-port close-output-port + + load + ) + (define scheme-report-interface %module-public-interface) (define (scheme-report-environment n) From 4c4185ee9519ef44d0547fcd43deffb7f9bbd0ad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Tue, 17 Jul 2001 19:41:49 +0000 Subject: [PATCH 1505/2047] * srfi-14.c: Okay. Now I got it. Really. This time it's fixed. Guaranteed. (Maybe) * srfi-19.scm: Define `current-time' before exporting it. --- srfi/ChangeLog | 7 +++++++ srfi/srfi-14.c | 49 +++++++++++++++++++++++++++++------------------- srfi/srfi-19.scm | 13 ++++++++++--- 3 files changed, 47 insertions(+), 22 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index d8546e8cb..5b50721c6 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,10 @@ +2001-07-17 Martin Grabmueller + + * srfi-14.c: Okay. Now I got it. Really. This time it's fixed. + Guaranteed. (Maybe) + + * srfi-19.scm: Define `current-time' before exporting it. + 2001-07-17 Martin Grabmueller * srfi-14.c: Fix for bug caused by brain-malfunctioning on my diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index 0de7a6ba3..7973e61d0 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -54,6 +54,10 @@ #define SCM_CHARSET_SET(cs, idx) (((long *) SCM_SMOB_DATA (cs))[(idx) / SCM_BITS_PER_LONG] |= (1 << ((idx) % SCM_BITS_PER_LONG))) +#define BYTES_PER_CHARSET (SCM_CHARSET_SIZE / 8) +#define LONGS_PER_CHARSET (SCM_CHARSET_SIZE / SCM_BITS_PER_LONG) + + /* Smob type code for character sets. */ int scm_tc16_charset = 0; @@ -94,8 +98,8 @@ make_char_set (const char * func_name) { long * p; - p = scm_must_malloc (SCM_CHARSET_SIZE / 8, func_name); - memset (p, 0, SCM_CHARSET_SIZE / 8); + p = scm_must_malloc (BYTES_PER_CHARSET, func_name); + memset (p, 0, BYTES_PER_CHARSET); SCM_RETURN_NEWSMOB (scm_tc16_charset, p); } @@ -131,7 +135,7 @@ SCM_DEFINE (scm_char_set_eq, "char-set=", 0, 0, 1, csi_data = (long *) SCM_SMOB_DATA (csi); if (cs1_data == NULL) cs1_data = csi_data; - else if (memcmp (cs1_data, csi_data, SCM_CHARSET_SIZE / 8) != 0) + else if (memcmp (cs1_data, csi_data, BYTES_PER_CHARSET) != 0) return SCM_BOOL_F; char_sets = SCM_CDR (char_sets); } @@ -163,7 +167,7 @@ SCM_DEFINE (scm_char_set_leq, "char-set<=", 0, 0, 1, { int k; - for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + for (k = 0; k < LONGS_PER_CHARSET; k++) { if ((prev_data[k] & csi_data[k]) != prev_data[k]) return SCM_BOOL_F; @@ -202,7 +206,7 @@ SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0, } p = (long *) SCM_SMOB_DATA (cs); - for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + for (k = 0; k < LONGS_PER_CHARSET; k++) { if (p[k] != 0) val = p[k] + (val << 1); @@ -449,7 +453,7 @@ SCM_DEFINE (scm_char_set_copy, "char-set-copy", 1, 0, 0, ret = make_char_set (FUNC_NAME); p1 = (long *) SCM_SMOB_DATA (cs); p2 = (long *) SCM_SMOB_DATA (ret); - for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + for (k = 0; k < LONGS_PER_CHARSET; k++) p2[k] = p1[k]; return ret; } @@ -1030,7 +1034,7 @@ SCM_DEFINE (scm_char_set_complement, "char-set-complement", 1, 0, 0, res = make_char_set (FUNC_NAME); p = (long *) SCM_SMOB_DATA (res); q = (long *) SCM_SMOB_DATA (cs); - for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + for (k = 0; k < LONGS_PER_CHARSET; k++) p[k] = ~q[k]; return res; } @@ -1058,7 +1062,7 @@ SCM_DEFINE (scm_char_set_union, "char-set-union", 0, 0, 1, c++; rest = SCM_CDR (rest); - for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + for (k = 0; k < LONGS_PER_CHARSET; k++) p[k] |= ((long *) SCM_SMOB_DATA (cs))[k]; } return res; @@ -1088,7 +1092,7 @@ SCM_DEFINE (scm_char_set_intersection, "char-set-intersection", 1, 0, 1, c++; rest = SCM_CDR (rest); - for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + for (k = 0; k < LONGS_PER_CHARSET; k++) p[k] &= ((long *) SCM_SMOB_DATA (cs))[k]; } return res; @@ -1118,7 +1122,7 @@ SCM_DEFINE (scm_char_set_difference, "char-set-difference", 1, 0, 1, c++; rest = SCM_CDR (rest); - for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + for (k = 0; k < LONGS_PER_CHARSET; k++) p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k]; } return res; @@ -1148,7 +1152,7 @@ SCM_DEFINE (scm_char_set_xor, "char-set-xor", 1, 0, 1, c++; rest = SCM_CDR (rest); - for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + for (k = 0; k < LONGS_PER_CHARSET; k++) p[k] ^= ((long *) SCM_SMOB_DATA (cs))[k]; } return res; @@ -1181,7 +1185,7 @@ SCM_DEFINE (scm_char_set_diff_plus_intersection, "char-set-diff+intersection", 1 c++; rest = SCM_CDR (rest); - for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + for (k = 0; k < LONGS_PER_CHARSET; k++) { p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k]; q[k] &= ((long *) SCM_SMOB_DATA (cs))[k]; @@ -1202,7 +1206,7 @@ SCM_DEFINE (scm_char_set_complement_x, "char-set-complement!", 1, 0, 0, SCM_VALIDATE_SMOB (1, cs, charset); p = (long *) SCM_SMOB_DATA (cs); - for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + for (k = 0; k < LONGS_PER_CHARSET; k++) p[k] = ~p[k]; return cs; } @@ -1229,7 +1233,7 @@ SCM_DEFINE (scm_char_set_union_x, "char-set-union!", 1, 0, 1, c++; rest = SCM_CDR (rest); - for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + for (k = 0; k < LONGS_PER_CHARSET; k++) p[k] |= ((long *) SCM_SMOB_DATA (cs))[k]; } return cs1; @@ -1257,7 +1261,7 @@ SCM_DEFINE (scm_char_set_intersection_x, "char-set-intersection!", 1, 0, 1, c++; rest = SCM_CDR (rest); - for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + for (k = 0; k < LONGS_PER_CHARSET; k++) p[k] &= ((long *) SCM_SMOB_DATA (cs))[k]; } return cs1; @@ -1285,7 +1289,7 @@ SCM_DEFINE (scm_char_set_difference_x, "char-set-difference!", 1, 0, 1, c++; rest = SCM_CDR (rest); - for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + for (k = 0; k < LONGS_PER_CHARSET; k++) p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k]; } return cs1; @@ -1313,7 +1317,7 @@ SCM_DEFINE (scm_char_set_xor_x, "char-set-xor!", 1, 0, 1, c++; rest = SCM_CDR (rest); - for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + for (k = 0; k < LONGS_PER_CHARSET; k++) p[k] ^= ((long *) SCM_SMOB_DATA (cs))[k]; } return cs1; @@ -1345,7 +1349,7 @@ SCM_DEFINE (scm_char_set_diff_plus_intersection_x, "char-set-diff+intersection!" c++; rest = SCM_CDR (rest); - for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) + for (k = 0; k < LONGS_PER_CHARSET; k++) { p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k]; q[k] &= ((long *) SCM_SMOB_DATA (cs))[k]; @@ -1369,7 +1373,7 @@ scm_c_init_srfi_14 (void) if (!initialized) { scm_tc16_charset = scm_make_smob_type ("character-set", - SCM_CHARSET_SIZE / 8); + BYTES_PER_CHARSET); scm_set_smob_free (scm_tc16_charset, charset_free); scm_set_smob_print (scm_tc16_charset, charset_print); initialized = 1; @@ -1382,6 +1386,13 @@ scm_c_init_srfi_14 (void) void scm_init_srfi_14 (void) { +#if 0 + fprintf(stderr, "bytes-per-charset: %d\n", BYTES_PER_CHARSET); + fprintf(stderr, "bits-per-long: %d\n", SCM_BITS_PER_LONG); + fprintf(stderr, "longs-per-charset: %d\n", LONGS_PER_CHARSET); + fflush (stderr); +#endif /* 0 */ + /* Do the smob type initialization. */ scm_c_init_srfi_14 (); diff --git a/srfi/srfi-19.scm b/srfi/srfi-19.scm index d95ba9a5c..6a1a5a268 100644 --- a/srfi/srfi-19.scm +++ b/srfi/srfi-19.scm @@ -60,8 +60,15 @@ (define-module (srfi srfi-19) :use-module (srfi srfi-6) :use-module (srfi srfi-8) - :use-module (srfi srfi-9) - :export (;; Constants + :use-module (srfi srfi-9)) + +(begin-deprecated + ;; Prevent `export' from re-exporting core bindings. This behaviour + ;; of `export' is deprecated and will disappear in one of the next + ;; releases. + (define current-time #f)) + +(export ;; Constants time-duration time-monotonic time-process @@ -147,7 +154,7 @@ time-utc->time-tai! ;; Date to string/string to date converters. date->string - string->date)) + string->date) (cond-expand-provide (current-module) '(srfi-19)) From 6b80d352020fe34468cdeecf153fcecc51cc3980 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 18 Jul 2001 10:14:29 +0000 Subject: [PATCH 1506/2047] * A couple of minor cleanups. --- libguile/ChangeLog | 52 ++++++++ libguile/goops.c | 315 ++++++++++++++++++++++++--------------------- 2 files changed, 223 insertions(+), 144 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b1663b21f..f0d3576a6 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,55 @@ +2001-07-17 Dirk Herrmann + + * goops.c (sym_layout, sym_vcell, sym_vtable, sym_print, + sym_procedure, sym_setter, sym_redefined, sym_h0, sym_h1, sym_h2, + sym_h3, sym_h4, sym_h5, sym_h6, sym_h7, sym_name, + sym_direct_supers, sym_direct_slots, sym_direct_subclasses, + sym_direct_methods, sym_cpl, sym_default_slot_definition_class, + sym_slots, sym_getters_n_setters, sym_keyword_access, sym_nfields, + sym_environment, scm_sym_change_class): New static variables to + hold predefined symbols. + + (build_class_class_slots): Build the list using scm_list_n + instead of cons. Also, slots are already created as lists, thus + making a call to maplist unnecessary. + + (scm_class_name, scm_class_direct_supers, scm_class_direct_slots, + scm_class_direct_subclasses, scm_class_direct_methods, + scm_class_precedence_list, scm_class_slots, scm_class_environment, + scm_method_procedure, create_standard_classes, purgatory): Use + predefined symbols. + + (build_slots_list, compute_getters_n_setters, + scm_sys_initialize_object, scm_sys_inherit_magic_x, + get_slot_value_using_name, set_slot_value_using_name, + scm_sys_invalidate_method_cache_x, scm_generic_capability_p, + scm_compute_applicable_methods, scm_sys_method_more_specific_p, + make_struct_class): Prefer !SCM_ over SCM_N. + + (scm_sys_prep_layout_x): Minimize variable scopes. + + (scm_sys_prep_layout_x, scm_sys_fast_slot_ref, + scm_sys_fast_slot_set_x): Fix signedness. + + (go_to_hell, go_to_heaven, purgatory, scm_change_object_class, + lock_cache_mutex, unlock_cache_mutex, call_memoize_method, + scm_memoize_method, scm_wrap_object): Use packing and unpacking + when converting to and from SCM values. + + (scm_enable_primitive_generic_x): Add rest argument checking. + + (map, filter_cpl, maplist, scm_sys_initialize_object, + scm_sys_prep_layout_x, slot_definition_using_name, + scm_enable_primitive_generic_x, scm_compute_applicable_methods, + call_memoize_method, scm_make, scm_make_class): Prefer explicit + predicates over SCM_N?IMP tests. + + (scm_sys_prep_layout_x): Fix typo in error message. Fix type + checking. + + (burnin, go_to_hell): Use SCM_STRUCT_DATA instead of the SCM_INST + alias. + 2001-07-16 Dirk Herrmann * fports.c (fport_print): Don't use SCM_C[AD]R for non pairs. diff --git a/libguile/goops.c b/libguile/goops.c index 13a677218..8e147bea9 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -185,27 +185,28 @@ compute_cpl (SCM supers, SCM res) static SCM map (SCM (*proc) (SCM), SCM ls) { - if (SCM_IMP (ls)) + if (SCM_NULLP (ls)) return ls; - { - SCM res = scm_cons (proc (SCM_CAR (ls)), SCM_EOL); - SCM h = res; - ls = SCM_CDR (ls); - while (SCM_NIMP (ls)) - { - SCM_SETCDR (h, scm_cons (proc (SCM_CAR (ls)), SCM_EOL)); - h = SCM_CDR (h); - ls = SCM_CDR (ls); - } - return res; - } + else + { + SCM res = scm_cons (proc (SCM_CAR (ls)), SCM_EOL); + SCM h = res; + ls = SCM_CDR (ls); + while (!SCM_NULLP (ls)) + { + SCM_SETCDR (h, scm_cons (proc (SCM_CAR (ls)), SCM_EOL)); + h = SCM_CDR (h); + ls = SCM_CDR (ls); + } + return res; + } } static SCM filter_cpl (SCM ls) { SCM res = SCM_EOL; - while (SCM_NIMP (ls)) + while (!SCM_NULLP (ls)) { SCM el = SCM_CAR (ls); if (SCM_FALSEP (scm_c_memq (el, res))) @@ -260,7 +261,7 @@ build_slots_list (SCM dslots, SCM cpl) { register SCM res = dslots; - for (cpl = SCM_CDR(cpl); SCM_NNULLP(cpl); cpl = SCM_CDR(cpl)) + for (cpl = SCM_CDR (cpl); !SCM_NULLP (cpl); cpl = SCM_CDR (cpl)) res = scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl), scm_si_direct_slots), res)); @@ -273,7 +274,7 @@ static SCM maplist (SCM ls) { SCM orig = ls; - while (SCM_NIMP (ls)) + while (!SCM_NULLP (ls)) { if (!SCM_CONSP (SCM_CAR (ls))) SCM_SETCAR (ls, scm_cons (SCM_CAR (ls), SCM_EOL)); @@ -316,11 +317,11 @@ compute_getters_n_setters (SCM slots) SCM *cdrloc = &res; long i = 0; - for ( ; SCM_NNULLP(slots); slots = SCM_CDR(slots)) + for ( ; !SCM_NULLP (slots); slots = SCM_CDR (slots)) { SCM init = SCM_BOOL_F; SCM options = SCM_CDAR (slots); - if (SCM_NNULLP (options)) + if (!SCM_NULLP (options)) { init = scm_get_keyword (k_init_value, options, 0); if (init) @@ -411,13 +412,13 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0, /* See for each slot how it must be initialized */ for (; - SCM_NNULLP (slots); + !SCM_NULLP (slots); get_n_set = SCM_CDR (get_n_set), slots = SCM_CDR (slots)) { SCM slot_name = SCM_CAR (slots); SCM slot_value = 0; - if (SCM_NIMP (SCM_CDR (slot_name))) + if (!SCM_NULLP (SCM_CDR (slot_name))) { /* This slot admits (perhaps) to be initialized at creation time */ long n = scm_ilength (SCM_CDR (slot_name)); @@ -479,9 +480,9 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0, "") #define FUNC_NAME s_scm_sys_prep_layout_x { - long i, n, len; - char *s, p, a; - SCM nfields, slots, type; + SCM slots, nfields; + unsigned long int n, i; + char *s; SCM_VALIDATE_INSTANCE (1, class); slots = SCM_SLOT (class, scm_si_slots); @@ -495,35 +496,49 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0, SCM_MISC_ERROR ("class object doesn't have enough fields: ~S", scm_list_1 (nfields)); - s = n > 0 ? scm_must_malloc (n, FUNC_NAME) : 0; + s = n > 0 ? scm_must_malloc (n, FUNC_NAME) : 0; for (i = 0; i < n; i += 2) { + long len; + SCM type; + char p, a; + if (!SCM_CONSP (slots)) - SCM_MISC_ERROR ("to few slot definitions", SCM_EOL); + SCM_MISC_ERROR ("too few slot definitions", SCM_EOL); len = scm_ilength (SCM_CDAR (slots)); type = scm_i_get_keyword (k_class, SCM_CDAR (slots), len, SCM_BOOL_F, FUNC_NAME); - if (SCM_NIMP (type) && SCM_SUBCLASSP (type, scm_class_foreign_slot)) - { - if (SCM_SUBCLASSP (type, scm_class_self)) - p = 's'; - else if (SCM_SUBCLASSP (type, scm_class_protected)) - p = 'p'; - else - p = 'u'; - - if (SCM_SUBCLASSP (type, scm_class_opaque)) - a = 'o'; - else if (SCM_SUBCLASSP (type, scm_class_read_only)) - a = 'r'; - else - a = 'w'; - } - else + if (SCM_FALSEP (type)) { p = 'p'; a = 'w'; } + else + { + if (!SCM_CLASSP (type)) + SCM_MISC_ERROR ("bad slot class", SCM_EOL); + else if (SCM_SUBCLASSP (type, scm_class_foreign_slot)) + { + if (SCM_SUBCLASSP (type, scm_class_self)) + p = 's'; + else if (SCM_SUBCLASSP (type, scm_class_protected)) + p = 'p'; + else + p = 'u'; + + if (SCM_SUBCLASSP (type, scm_class_opaque)) + a = 'o'; + else if (SCM_SUBCLASSP (type, scm_class_read_only)) + a = 'r'; + else + a = 'w'; + } + else + { + p = 'p'; + a = 'w'; + } + } s[i] = p; s[i + 1] = a; slots = SCM_CDR (slots); @@ -545,7 +560,7 @@ SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0, SCM ls = dsupers; long flags = 0; SCM_VALIDATE_INSTANCE (1, class); - while (SCM_NNULLP (ls)) + while (!SCM_NULLP (ls)) { SCM_ASSERT (SCM_CONSP (ls) && SCM_INSTANCEP (SCM_CAR (ls)), @@ -658,64 +673,67 @@ scm_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots) /******************************************************************************/ +SCM_SYMBOL (sym_layout, "layout"); +SCM_SYMBOL (sym_vcell, "vcell"); +SCM_SYMBOL (sym_vtable, "vtable"); +SCM_SYMBOL (sym_print, "print"); +SCM_SYMBOL (sym_procedure, "procedure"); +SCM_SYMBOL (sym_setter, "setter"); +SCM_SYMBOL (sym_redefined, "redefined"); +SCM_SYMBOL (sym_h0, "h0"); +SCM_SYMBOL (sym_h1, "h1"); +SCM_SYMBOL (sym_h2, "h2"); +SCM_SYMBOL (sym_h3, "h3"); +SCM_SYMBOL (sym_h4, "h4"); +SCM_SYMBOL (sym_h5, "h5"); +SCM_SYMBOL (sym_h6, "h6"); +SCM_SYMBOL (sym_h7, "h7"); +SCM_SYMBOL (sym_name, "name"); +SCM_SYMBOL (sym_direct_supers, "direct-supers"); +SCM_SYMBOL (sym_direct_slots, "direct-slots"); +SCM_SYMBOL (sym_direct_subclasses, "direct-subclasses"); +SCM_SYMBOL (sym_direct_methods, "direct-methods"); +SCM_SYMBOL (sym_cpl, "cpl"); +SCM_SYMBOL (sym_default_slot_definition_class, "default-slot-definition-class"); +SCM_SYMBOL (sym_slots, "slots"); +SCM_SYMBOL (sym_getters_n_setters, "getters-n-setters"); +SCM_SYMBOL (sym_keyword_access, "keyword-access"); +SCM_SYMBOL (sym_nfields, "nfields"); +SCM_SYMBOL (sym_environment, "environment"); + + static SCM build_class_class_slots () { - return maplist ( - scm_cons (scm_list_3 (scm_str2symbol ("layout"), - k_class, - scm_class_protected_read_only), - scm_cons (scm_list_3 (scm_str2symbol ("vcell"), - k_class, - scm_class_opaque), - scm_cons (scm_list_3 (scm_str2symbol ("vtable"), - k_class, - scm_class_self), - scm_cons (scm_str2symbol ("print"), - scm_cons (scm_list_3 (scm_str2symbol ("procedure"), - k_class, - scm_class_protected_opaque), - scm_cons (scm_list_3 (scm_str2symbol ("setter"), - k_class, - scm_class_protected_opaque), - scm_cons (scm_str2symbol ("redefined"), - scm_cons (scm_list_3 (scm_str2symbol ("h0"), - k_class, - scm_class_int), - scm_cons (scm_list_3 (scm_str2symbol ("h1"), - k_class, - scm_class_int), - scm_cons (scm_list_3 (scm_str2symbol ("h2"), - k_class, - scm_class_int), - scm_cons (scm_list_3 (scm_str2symbol ("h3"), - k_class, - scm_class_int), - scm_cons (scm_list_3 (scm_str2symbol ("h4"), - k_class, - scm_class_int), - scm_cons (scm_list_3 (scm_str2symbol ("h5"), - k_class, - scm_class_int), - scm_cons (scm_list_3 (scm_str2symbol ("h6"), - k_class, - scm_class_int), - scm_cons (scm_list_3 (scm_str2symbol ("h7"), - k_class, - scm_class_int), - scm_cons (scm_str2symbol ("name"), - scm_cons (scm_str2symbol ("direct-supers"), - scm_cons (scm_str2symbol ("direct-slots"), - scm_cons (scm_str2symbol ("direct-subclasses"), - scm_cons (scm_str2symbol ("direct-methods"), - scm_cons (scm_str2symbol ("cpl"), - scm_cons (scm_str2symbol ("default-slot-definition-class"), - scm_cons (scm_str2symbol ("slots"), - scm_cons (scm_str2symbol ("getters-n-setters"), /* name-access */ - scm_cons (scm_str2symbol ("keyword-access"), - scm_cons (scm_str2symbol ("nfields"), - scm_cons (scm_str2symbol ("environment"), - SCM_EOL)))))))))))))))))))))))))))); + return scm_list_n ( + scm_list_3 (sym_layout, k_class, scm_class_protected_read_only), + scm_list_3 (sym_vcell, k_class, scm_class_opaque), + scm_list_3 (sym_vtable, k_class, scm_class_self), + scm_list_1 (sym_print), + scm_list_3 (sym_procedure, k_class, scm_class_protected_opaque), + scm_list_3 (sym_setter, k_class, scm_class_protected_opaque), + scm_list_1 (sym_redefined), + scm_list_3 (sym_h0, k_class, scm_class_int), + scm_list_3 (sym_h1, k_class, scm_class_int), + scm_list_3 (sym_h2, k_class, scm_class_int), + scm_list_3 (sym_h3, k_class, scm_class_int), + scm_list_3 (sym_h4, k_class, scm_class_int), + scm_list_3 (sym_h5, k_class, scm_class_int), + scm_list_3 (sym_h6, k_class, scm_class_int), + scm_list_3 (sym_h7, k_class, scm_class_int), + scm_list_1 (sym_name), + scm_list_1 (sym_direct_supers), + scm_list_1 (sym_direct_slots), + scm_list_1 (sym_direct_subclasses), + scm_list_1 (sym_direct_methods), + scm_list_1 (sym_cpl), + scm_list_1 (sym_default_slot_definition_class), + scm_list_1 (sym_slots), + scm_list_1 (sym_getters_n_setters), + scm_list_1 (sym_keyword_access), + scm_list_1 (sym_nfields), + scm_list_1 (sym_environment), + SCM_UNDEFINED); } static void @@ -799,7 +817,7 @@ SCM_DEFINE (scm_class_name, "class-name", 1, 0, 0, #define FUNC_NAME s_scm_class_name { SCM_VALIDATE_CLASS (1, obj); - return scm_slot_ref (obj, scm_str2symbol ("name")); + return scm_slot_ref (obj, sym_name); } #undef FUNC_NAME @@ -809,7 +827,7 @@ SCM_DEFINE (scm_class_direct_supers, "class-direct-supers", 1, 0, 0, #define FUNC_NAME s_scm_class_direct_supers { SCM_VALIDATE_CLASS (1, obj); - return scm_slot_ref (obj, scm_str2symbol ("direct-supers")); + return scm_slot_ref (obj, sym_direct_supers); } #undef FUNC_NAME @@ -819,7 +837,7 @@ SCM_DEFINE (scm_class_direct_slots, "class-direct-slots", 1, 0, 0, #define FUNC_NAME s_scm_class_direct_slots { SCM_VALIDATE_CLASS (1, obj); - return scm_slot_ref (obj, scm_str2symbol ("direct-slots")); + return scm_slot_ref (obj, sym_direct_slots); } #undef FUNC_NAME @@ -829,7 +847,7 @@ SCM_DEFINE (scm_class_direct_subclasses, "class-direct-subclasses", 1, 0, 0, #define FUNC_NAME s_scm_class_direct_subclasses { SCM_VALIDATE_CLASS (1, obj); - return scm_slot_ref(obj, scm_str2symbol ("direct-subclasses")); + return scm_slot_ref(obj, sym_direct_subclasses); } #undef FUNC_NAME @@ -839,7 +857,7 @@ SCM_DEFINE (scm_class_direct_methods, "class-direct-methods", 1, 0, 0, #define FUNC_NAME s_scm_class_direct_methods { SCM_VALIDATE_CLASS (1, obj); - return scm_slot_ref (obj, scm_str2symbol ("direct-methods")); + return scm_slot_ref (obj, sym_direct_methods); } #undef FUNC_NAME @@ -849,7 +867,7 @@ SCM_DEFINE (scm_class_precedence_list, "class-precedence-list", 1, 0, 0, #define FUNC_NAME s_scm_class_precedence_list { SCM_VALIDATE_CLASS (1, obj); - return scm_slot_ref (obj, scm_str2symbol ("cpl")); + return scm_slot_ref (obj, sym_cpl); } #undef FUNC_NAME @@ -859,7 +877,7 @@ SCM_DEFINE (scm_class_slots, "class-slots", 1, 0, 0, #define FUNC_NAME s_scm_class_slots { SCM_VALIDATE_CLASS (1, obj); - return scm_slot_ref (obj, scm_str2symbol ("slots")); + return scm_slot_ref (obj, sym_slots); } #undef FUNC_NAME @@ -869,7 +887,7 @@ SCM_DEFINE (scm_class_environment, "class-environment", 1, 0, 0, #define FUNC_NAME s_scm_class_environment { SCM_VALIDATE_CLASS (1, obj); - return scm_slot_ref(obj, scm_str2symbol ("environment")); + return scm_slot_ref(obj, sym_environment); } #undef FUNC_NAME @@ -921,7 +939,7 @@ SCM_DEFINE (scm_method_procedure, "method-procedure", 1, 0, 0, #define FUNC_NAME s_scm_method_procedure { SCM_VALIDATE_METHOD (1, obj); - return scm_slot_ref (obj, scm_str2symbol ("procedure")); + return scm_slot_ref (obj, sym_procedure); } #undef FUNC_NAME @@ -998,13 +1016,14 @@ SCM_DEFINE (scm_sys_fast_slot_ref, "%fast-slot-ref", 2, 0, 0, "Return the slot value with index @var{index} from @var{obj}.") #define FUNC_NAME s_scm_sys_fast_slot_ref { - register long i; + unsigned long int i; SCM_VALIDATE_INSTANCE (1, obj); SCM_VALIDATE_INUM (2, index); + SCM_ASSERT_RANGE (2, index, SCM_INUM (index) >= 0); i = SCM_INUM (index); - - SCM_ASSERT_RANGE (2, index, i >= 0 && i < SCM_NUMBER_OF_SLOTS (obj)); + SCM_ASSERT_RANGE (2, index, i < SCM_NUMBER_OF_SLOTS (obj)); + return scm_at_assert_bound_ref (obj, index); } #undef FUNC_NAME @@ -1015,12 +1034,14 @@ SCM_DEFINE (scm_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0, "@var{value}.") #define FUNC_NAME s_scm_sys_fast_slot_set_x { - register long i; + unsigned long int i; SCM_VALIDATE_INSTANCE (1, obj); SCM_VALIDATE_INUM (2, index); + SCM_ASSERT_RANGE (2, index, SCM_INUM (index) >= 0); i = SCM_INUM (index); - SCM_ASSERT_RANGE (2, index, i >= 0 && i < SCM_NUMBER_OF_SLOTS (obj)); + SCM_ASSERT_RANGE (2, index, i < SCM_NUMBER_OF_SLOTS (obj)); + SCM_SET_SLOT (obj, i, value); return SCM_UNSPECIFIED; @@ -1040,7 +1061,7 @@ static SCM slot_definition_using_name (SCM class, SCM slot_name) { register SCM slots = SCM_SLOT (class, scm_si_getters_n_setters); - for (; SCM_NIMP (slots); slots = SCM_CDR (slots)) + for (; !SCM_NULLP (slots); slots = SCM_CDR (slots)) if (SCM_CAAR (slots) == slot_name) return SCM_CAR (slots); return SCM_BOOL_F; @@ -1077,7 +1098,7 @@ static SCM get_slot_value_using_name (SCM class, SCM obj, SCM slot_name) { SCM slotdef = slot_definition_using_name (class, slot_name); - if (SCM_NFALSEP (slotdef)) + if (!SCM_FALSEP (slotdef)) return get_slot_value (class, obj, slotdef); else return CALL_GF3 ("slot-missing", class, obj, slot_name); @@ -1118,7 +1139,7 @@ static SCM set_slot_value_using_name (SCM class, SCM obj, SCM slot_name, SCM value) { SCM slotdef = slot_definition_using_name (class, slot_name); - if (SCM_NFALSEP (slotdef)) + if (!SCM_FALSEP (slotdef)) return set_slot_value (class, obj, slotdef, value); else return CALL_GF4 ("slot-missing", class, obj, slot_name, value); @@ -1475,7 +1496,7 @@ burnin (SCM o) { long i; for (i = 1; i < n_hell; ++i) - if (SCM_INST (o) == hell[i]) + if (SCM_STRUCT_DATA (o) == hell[i]) return i; return 0; } @@ -1483,7 +1504,7 @@ burnin (SCM o) static void go_to_hell (void *o) { - SCM obj = (SCM) o; + SCM obj = SCM_PACK ((scm_t_bits) o); #ifdef USE_THREADS scm_mutex_lock (&hell_mutex); #endif @@ -1493,7 +1514,7 @@ go_to_hell (void *o) hell = scm_must_realloc (hell, hell_size, new_size, "hell"); hell_size = new_size; } - hell[n_hell++] = SCM_INST (obj); + hell[n_hell++] = SCM_STRUCT_DATA (obj); #ifdef USE_THREADS scm_mutex_unlock (&hell_mutex); #endif @@ -1505,16 +1526,20 @@ go_to_heaven (void *o) #ifdef USE_THREADS scm_mutex_lock (&hell_mutex); #endif - hell[burnin ((SCM) o)] = hell[--n_hell]; + hell[burnin (SCM_PACK ((scm_t_bits) o))] = hell[--n_hell]; #ifdef USE_THREADS scm_mutex_unlock (&hell_mutex); #endif } + +SCM_SYMBOL (scm_sym_change_class, "change-class"); + static SCM purgatory (void *args) { - return scm_apply_0 (GETVAR (scm_str2symbol ("change-class")), (SCM) args); + return scm_apply_0 (GETVAR (scm_sym_change_class), + SCM_PACK ((scm_t_bits) args)); } void @@ -1522,8 +1547,8 @@ scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED, SCM new_class) { if (!burnin (obj)) scm_internal_dynamic_wind (go_to_hell, purgatory, go_to_heaven, - (void *) scm_list_2 (obj, new_class), - (void *) obj); + (void *) SCM_UNPACK (scm_list_2 (obj, new_class)), + (void *) SCM_UNPACK (obj)); } /****************************************************************************** @@ -1577,7 +1602,7 @@ SCM_DEFINE (scm_sys_invalidate_method_cache_x, "%invalidate-method-cache!", 1, 0 SCM used_by; SCM_ASSERT (SCM_PUREGENERICP (gf), gf, SCM_ARG1, FUNC_NAME); used_by = SCM_SLOT (gf, scm_si_used_by); - if (SCM_NFALSEP (used_by)) + if (!SCM_FALSEP (used_by)) { SCM methods = SCM_SLOT (gf, scm_si_methods); for (; SCM_CONSP (used_by); used_by = SCM_CDR (used_by)) @@ -1600,7 +1625,7 @@ SCM_DEFINE (scm_generic_capability_p, "generic-capability?", 1, 0, 0, "") #define FUNC_NAME s_scm_generic_capability_p { - SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (proc)), + SCM_ASSERT (!SCM_FALSEP (scm_procedure_p (proc)), proc, SCM_ARG1, FUNC_NAME); return (scm_subr_p (proc) && SCM_SUBR_GENERIC (proc) ? SCM_BOOL_T @@ -1613,7 +1638,8 @@ SCM_DEFINE (scm_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1 "") #define FUNC_NAME s_scm_enable_primitive_generic_x { - while (SCM_NIMP (subrs)) + SCM_VALIDATE_REST_ARGUMENT (subrs); + while (!SCM_NULLP (subrs)) { SCM subr = SCM_CAR (subrs); SCM_ASSERT (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr), @@ -1805,16 +1831,16 @@ scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p) else types = p = buffer; - for ( ; SCM_NNULLP (args); args = SCM_CDR (args)) + for ( ; !SCM_NULLP (args); args = SCM_CDR (args)) *p++ = scm_class_of (SCM_CAR (args)); /* Build a list of all applicable methods */ - for (l = SCM_SLOT (gf, scm_si_methods); SCM_NNULLP (l); l = SCM_CDR (l)) + for (l = SCM_SLOT (gf, scm_si_methods); !SCM_NULLP (l); l = SCM_CDR (l)) { fl = SPEC_OF (SCM_CAR (l)); /* Only accept accessors which match exactly in first arg. */ if (SCM_ACCESSORP (SCM_CAR (l)) - && (SCM_IMP (fl) || types[0] != SCM_CAR (fl))) + && (SCM_NULLP (fl) || types[0] != SCM_CAR (fl))) continue; for (i = 0; ; i++, fl = SCM_CDR (fl)) { @@ -1927,14 +1953,14 @@ scm_m_atdispatch (SCM xorig, SCM env) static void lock_cache_mutex (void *m) { - SCM mutex = (SCM) m; + SCM mutex = SCM_PACK ((scm_t_bits) m); scm_lock_mutex (mutex); } static void unlock_cache_mutex (void *m) { - SCM mutex = (SCM) m; + SCM mutex = SCM_PACK ((scm_t_bits) m); scm_unlock_mutex (mutex); } #endif @@ -1942,14 +1968,14 @@ unlock_cache_mutex (void *m) static SCM call_memoize_method (void *a) { - SCM args = (SCM) a; + SCM args = SCM_PACK ((scm_t_bits) a); SCM gf = SCM_CAR (args); SCM x = SCM_CADR (args); /* First check if another thread has inserted a method between * the cache miss and locking the mutex. */ SCM cmethod = scm_mcache_lookup_cmethod (x, SCM_CDDR (args)); - if (SCM_NIMP (cmethod)) + if (!SCM_FALSEP (cmethod)) return cmethod; /*fixme* Use scm_apply */ return CALL_GF3 ("memoize-method!", gf, SCM_CDDR (args), x); @@ -1960,13 +1986,14 @@ scm_memoize_method (SCM x, SCM args) { SCM gf = SCM_CAR (scm_last_pair (x)); #ifdef USE_THREADS - return scm_internal_dynamic_wind (lock_cache_mutex, - call_memoize_method, - unlock_cache_mutex, - (void *) scm_cons2 (gf, x, args), - (void *) SCM_SLOT (gf, scm_si_cache_mutex)); + return scm_internal_dynamic_wind ( + lock_cache_mutex, + call_memoize_method, + unlock_cache_mutex, + (void *) SCM_UNPACK (scm_cons2 (gf, x, args)), + (void *) SCM_UNPACK (SCM_SLOT (gf, scm_si_cache_mutex))); #else - return call_memoize_method ((void *) scm_cons2 (gf, x, args)); + return call_memoize_method ((void *) SCM_UNPACK (scm_cons2 (gf, x, args))); #endif } @@ -2022,7 +2049,7 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1, if (class == scm_class_generic_with_setter) { SCM setter = scm_get_keyword (k_setter, args, SCM_BOOL_F); - if (SCM_NIMP (setter)) + if (!SCM_FALSEP (setter)) scm_sys_set_object_setter_x (z, setter); } } @@ -2116,7 +2143,7 @@ SCM_DEFINE (scm_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0, /* Verify that all the arguments of targs are classes and place them in a vector*/ v = scm_c_make_vector (len, SCM_EOL); - for (i=0, l=targs; SCM_NNULLP(l); i++, l=SCM_CDR(l)) { + for (i = 0, l = targs; !SCM_NULLP (l); i++, l = SCM_CDR (l)) { SCM_ASSERT (SCM_CLASSP (SCM_CAR (l)), targs, SCM_ARG3, FUNC_NAME); SCM_VELTS(v)[i] = SCM_CAR(l); } @@ -2156,7 +2183,7 @@ create_standard_classes (void) SCM slots; SCM method_slots = scm_list_4 (scm_str2symbol ("generic-function"), scm_str2symbol ("specializers"), - scm_str2symbol ("procedure"), + sym_procedure, scm_str2symbol ("code-table")); SCM amethod_slots = scm_list_1 (scm_list_3 (scm_str2symbol ("slot-definition"), k_init_keyword, @@ -2415,7 +2442,7 @@ static SCM make_struct_class (void *closure SCM_UNUSED, SCM key SCM_UNUSED, SCM data, SCM prev SCM_UNUSED) { - if (SCM_NFALSEP (SCM_STRUCT_TABLE_NAME (data))) + if (!SCM_FALSEP (SCM_STRUCT_TABLE_NAME (data))) SCM_SET_STRUCT_TABLE_CLASS (data, scm_make_extended_class (SCM_SYMBOL_CHARS (SCM_STRUCT_TABLE_NAME (data)))); @@ -2470,7 +2497,7 @@ scm_make_class (SCM meta, char *s_name, SCM supers, size_t size, { SCM name, class; name = scm_str2symbol (s_name); - if (SCM_IMP (supers)) + if (SCM_NULLP (supers)) supers = scm_list_1 (scm_class_foreign_object); class = scm_basic_basic_make_class (meta, name, supers, SCM_EOL); scm_sys_inherit_magic_x (class, supers); @@ -2565,7 +2592,7 @@ scm_wrap_object (SCM class, void *data) { SCM z; SCM_NEWCELL2 (z); - SCM_SETCDR (z, (SCM) data); + SCM_SETCDR (z, SCM_PACK ((scm_t_bits) data)); SCM_SET_STRUCT_GC_CHAIN (z, 0); SCM_SETCAR (z, SCM_UNPACK (SCM_CDR (class)) | scm_tc3_cons_gloc); return z; From 7bcbb3f235cf9739676ddb92866a9c6767465cc2 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 19 Jul 2001 17:43:14 +0000 Subject: [PATCH 1507/2047] * scmsigs.h (scm_init_scmsigs): new prototype. (scm_init_scmsigs): new prototype. --- libguile/scmsigs.h | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/libguile/scmsigs.h b/libguile/scmsigs.h index 347ed8b03..06fc129d5 100644 --- a/libguile/scmsigs.h +++ b/libguile/scmsigs.h @@ -50,6 +50,10 @@ extern SCM scm_sigaction (SCM signum, SCM handler, SCM flags); extern SCM scm_restore_signals (void); extern SCM scm_alarm (SCM i); +extern SCM scm_setitimer (SCM which_timer, + SCM interval_seconds, SCM interval_microseconds, + SCM value_seconds, SCM value_microseconds); +extern SCM scm_getitimer (SCM which_timer); extern SCM scm_pause (void); extern SCM scm_sleep (SCM i); extern SCM scm_usleep (SCM i); From 53f8a0d20e30590a54eab6ed6aed7e3d1526c558 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 19 Jul 2001 17:43:22 +0000 Subject: [PATCH 1508/2047] * scmsigs.c (s_scm_setitimer): new function. (s_scm_setitimer): new function. --- libguile/scmsigs.c | 90 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 90 insertions(+) diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index 62a0cd99f..ef3e80c68 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -415,6 +415,89 @@ SCM_DEFINE (scm_alarm, "alarm", 1, 0, 0, } #undef FUNC_NAME +#ifdef HAVE_SETITIMER +SCM_DEFINE (scm_setitimer, "setitimer", 5, 0, 0, + (SCM which_timer, + SCM interval_seconds, SCM interval_microseconds, + SCM value_seconds, SCM value_microseconds), + "Set the timer specified by @var{which_timer} according to the given\n" + "@var{interval_seconds}, @var{interval_microseconds},\n" + "@var{value_seconds}, and @var{value_microseconds} values.\n" + "\n" + "Return information about the timer's previous setting." + "\n" + "Errors are handled as described in the guile info pages under ``POSIX\n" + "Interface Conventions''.\n" + "\n" + "The timers available are: @code{ITIMER_REAL}, @code{ITIMER_VIRTUAL}, \n" + "and @code{ITIMER_PROF}.\n" + "\n" + "The return value will be a list of two cons pairs representing the\n" + "current state of the given timer. The first pair is the seconds and\n" + "microseconds of the timer @code{it_interval}, and the second pair is\n" + "the seconds and microseconds of the timer @code{it_value}.\n") +#define FUNC_NAME s_scm_setitimer +{ + int rv; + int c_which_timer; + struct itimerval new_timer; + struct itimerval old_timer; + + c_which_timer = SCM_NUM2INT(1, which_timer); + new_timer.it_interval.tv_sec = SCM_NUM2LONG(2, interval_seconds); + new_timer.it_interval.tv_usec = SCM_NUM2LONG(3, interval_microseconds); + new_timer.it_value.tv_sec = SCM_NUM2LONG(4, value_seconds); + new_timer.it_value.tv_usec = SCM_NUM2LONG(5, value_microseconds); + + SCM_SYSCALL(rv = setitimer(c_which_timer, &new_timer, &old_timer)); + + if(rv != 0) + SCM_SYSERROR; + + return scm_list_2(scm_cons(scm_long2num(old_timer.it_interval.tv_sec), + scm_long2num(old_timer.it_interval.tv_usec)), + scm_cons(scm_long2num(old_timer.it_value.tv_sec), + scm_long2num(old_timer.it_value.tv_usec))); +} +#undef FUNC_NAME +#endif /* HAVE_SETITIMER */ + +#ifdef HAVE_GETITIMER +SCM_DEFINE (scm_getitimer, "getitimer", 1, 0, 0, + (SCM which_timer), + "Return information about the timer specified by @var{which_timer}" + "\n" + "Errors are handled as described in the guile info pages under ``POSIX\n" + "Interface Conventions''.\n" + "\n" + "The timers available are: @code{ITIMER_REAL}, @code{ITIMER_VIRTUAL}, \n" + "and @code{ITIMER_PROF}.\n" + "\n" + "The return value will be a list of two cons pairs representing the\n" + "current state of the given timer. The first pair is the seconds and\n" + "microseconds of the timer @code{it_interval}, and the second pair is\n" + "the seconds and microseconds of the timer @code{it_value}.\n") +#define FUNC_NAME s_scm_getitimer +{ + int rv; + int c_which_timer; + struct itimerval old_timer; + + c_which_timer = SCM_NUM2INT(1, which_timer); + + SCM_SYSCALL(rv = getitimer(c_which_timer, &old_timer)); + + if(rv != 0) + SCM_SYSERROR; + + return scm_list_2(scm_cons(scm_long2num(old_timer.it_interval.tv_sec), + scm_long2num(old_timer.it_interval.tv_usec)), + scm_cons(scm_long2num(old_timer.it_value.tv_sec), + scm_long2num(old_timer.it_value.tv_usec))); +} +#undef FUNC_NAME +#endif /* HAVE_GETITIMER */ + #ifdef HAVE_PAUSE SCM_DEFINE (scm_pause, "pause", 0, 0, 0, (), @@ -552,6 +635,13 @@ scm_init_scmsigs () scm_c_define ("SA_RESTART", scm_long2num (SA_RESTART)); #endif +#if defined(HAVE_SETITIMER) || defined(HAVE_GETITIMER) + /* Stuff needed by setitimer and getitimer. */ + scm_c_define ("ITIMER_REAL", SCM_MAKINUM (ITIMER_REAL)); + scm_c_define ("ITIMER_VIRTUAL", SCM_MAKINUM (ITIMER_VIRTUAL)); + scm_c_define ("ITIMER_PROF", SCM_MAKINUM (ITIMER_PROF)); +#endif /* defined(HAVE_SETITIMER) || defined(HAVE_GETITIMER) */ + #ifndef SCM_MAGIC_SNARFER #include "libguile/scmsigs.x" #endif From f28108ee142c8c05c4273342a051e3018de22343 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 19 Jul 2001 17:43:34 +0000 Subject: [PATCH 1509/2047] * gc_os_dep.c (GC_noop1): ifdef out (unused) to quiet warning. --- libguile/gc_os_dep.c | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/libguile/gc_os_dep.c b/libguile/gc_os_dep.c index d05105a63..ab392729d 100644 --- a/libguile/gc_os_dep.c +++ b/libguile/gc_os_dep.c @@ -62,8 +62,11 @@ typedef int GC_bool; # define VOLATILE #endif +#if 0 /* currently unused (as of 2001-07-12) */ + /* Single argument version, robust against whole program analysis. */ -static void GC_noop1(x) +static void +GC_noop1(x) word x; { static VOLATILE word sink; @@ -71,6 +74,8 @@ word x; sink = x; } +#endif + /* Machine dependent parameters. Some tuning parameters can be found */ /* near the top of gc_private.h. */ From e80bea704d370ad1e58f53229599bac153f16a74 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 19 Jul 2001 17:45:01 +0000 Subject: [PATCH 1510/2047] * c-tokenize.lex: add option %nounput to quiet warning. Add prototype for yylex to quiet warning. --- libguile/c-tokenize.lex | 3 +++ 1 file changed, 3 insertions(+) diff --git a/libguile/c-tokenize.lex b/libguile/c-tokenize.lex index 9c6c9387d..b48354c32 100644 --- a/libguile/c-tokenize.lex +++ b/libguile/c-tokenize.lex @@ -1,4 +1,5 @@ %option noyywrap +%option nounput %pointer EOL \n @@ -18,6 +19,8 @@ INTQUAL (l|L|ll|LL|lL|Ll|u|U) #include #include +int yylex(void); + int filter_snarfage = 0; int print = 1; From 0aaac665d52d5c98a96c94cffba3d3829c94d33d Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 19 Jul 2001 17:46:22 +0000 Subject: [PATCH 1511/2047] * box-module/.cvsignore: add .deps. --- examples/box-module/.cvsignore | 1 + 1 file changed, 1 insertion(+) diff --git a/examples/box-module/.cvsignore b/examples/box-module/.cvsignore index 282522db0..051d1bd50 100644 --- a/examples/box-module/.cvsignore +++ b/examples/box-module/.cvsignore @@ -1,2 +1,3 @@ Makefile Makefile.in +.deps From 363902dbb2a3202ae3464793e3de956c2709652b Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 19 Jul 2001 17:46:30 +0000 Subject: [PATCH 1512/2047] * box/.cvsignore: add .deps. --- examples/box/.cvsignore | 1 + 1 file changed, 1 insertion(+) diff --git a/examples/box/.cvsignore b/examples/box/.cvsignore index 282522db0..051d1bd50 100644 --- a/examples/box/.cvsignore +++ b/examples/box/.cvsignore @@ -1,2 +1,3 @@ Makefile Makefile.in +.deps From 8afd1a2a62c27f5d1b3bab76bcf799769952427d Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 19 Jul 2001 17:46:42 +0000 Subject: [PATCH 1513/2047] * configure.in: add checks for setitimer and getitimer. Add --enable-error-on-warning. --- configure.in | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/configure.in b/configure.in index f51e4c4ce..78a0bf7c6 100644 --- a/configure.in +++ b/configure.in @@ -43,6 +43,14 @@ AC_CONFIG_SUBDIRS(guile-readline) # #-------------------------------------------------------------------- +AC_ARG_ENABLE(error-on-warning, + [ --enable-error-on-warning treat compile warnings as errors], + [case "${enableval}" in + yes | y) CFLAGS="${CFLAGS} -Werror"; enable_compile_warnings=no ;; + no | n) ;; + *) AC_MSG_ERROR(bad value ${enableval} for --enable-error-on-warning) ;; + esac]) + AC_ARG_ENABLE(debug-freelist, [ --enable-debug-freelist include garbage collector freelist debugging code], if test "$enable_debug_freelist" = y || test "$enable_debug_freelist" = yes; then @@ -232,7 +240,7 @@ AC_SUBST(INCLTDL) AC_SUBST(LIBLTDL) AC_SUBST(DLPREOPEN) -AC_CHECK_FUNCS(ctermid ftime fchown getcwd geteuid gettimeofday lstat mkdir mknod nice readlink rename rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt strftime strptime symlink sync tcgetpgrp tcsetpgrp times uname waitpid strdup system usleep atexit on_exit chown link fcntl ttyname getpwent getgrent kill getppid getpgrp fork) +AC_CHECK_FUNCS(ctermid ftime fchown getcwd geteuid gettimeofday lstat mkdir mknod nice readlink rename rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt strftime strptime symlink sync tcgetpgrp tcsetpgrp times uname waitpid strdup system usleep atexit on_exit chown link fcntl ttyname getpwent getgrent kill getppid getpgrp fork setitimer getitimer) AC_CHECK_HEADERS(crypt.h sys/resource.h sys/file.h) AC_CHECK_FUNCS(chroot flock getlogin cuserid getpriority setpriority getpass sethostname gethostname) From e658215a980c61f20bf858143361123570768c1d Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 19 Jul 2001 17:47:08 +0000 Subject: [PATCH 1514/2047] *** empty log message *** --- ChangeLog | 5 +++++ NEWS | 5 +++++ libguile/ChangeLog | 15 +++++++++++++++ 3 files changed, 25 insertions(+) diff --git a/ChangeLog b/ChangeLog index 3af3aa9cd..0c98e8c21 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2001-07-19 Rob Browning + + * configure.in: add checks for setitimer and getitimer. + Add --enable-error-on-warning. + 2001-07-15 Thien-Thi Nguyen * HACKING: Remove onerous authorship-info deletion clause. diff --git a/NEWS b/NEWS index 6247523a7..01d04af58 100644 --- a/NEWS +++ b/NEWS @@ -37,6 +37,11 @@ The new configure option `--enable-deprecated=LEVEL' and the environment variable GUILE_WARN_DEPRECATED control this mechanism. See INSTALL and README for more information. +** New functions: setitimer and getitimer. + +These implement a fairly direct interface to the libc functions of the +same name. + ** The #. reader extension is now disabled by default. For safety reasons, #. evaluation is disabled by default. To diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f0d3576a6..56abc6eda 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,18 @@ +2001-07-19 Rob Browning + + * gc_os_dep.c (GC_noop1): ifdef out (unused) to quiet warning. + + * c-tokenize.lex: add option %nounput to quiet warning. + Add prototype for yylex to quiet warning. + + * scmconfig.h.in: add flags for setitimer and getitimer. + + * scmsigs.h (scm_init_scmsigs): new prototype. + (scm_init_scmsigs): new prototype. + + * scmsigs.c (s_scm_setitimer): new function. + (s_scm_setitimer): new function. + 2001-07-17 Dirk Herrmann * goops.c (sym_layout, sym_vcell, sym_vtable, sym_print, From 41d6c85b29279aa0a0091083826eb627f2ce6252 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 19 Jul 2001 17:58:27 +0000 Subject: [PATCH 1515/2047] * posix.texi (Signals): add docs for setitimer and getitimer. --- doc/posix.texi | 2304 ------------------------------------------------ 1 file changed, 2304 deletions(-) diff --git a/doc/posix.texi b/doc/posix.texi index a823bc360..e69de29bb 100644 --- a/doc/posix.texi +++ b/doc/posix.texi @@ -1,2304 +0,0 @@ -@node POSIX -@chapter POSIX System Calls and Networking - -@menu -* Conventions:: Conventions employed by the POSIX interface. -* Ports and File Descriptors:: Scheme ``ports'' and Unix file descriptors - have different representations. -* File System:: stat, chown, chmod, etc. -* User Information:: Retrieving a user's GECOS (/etc/passwd) entry. -* Time:: gettimeofday, localtime, strftime, etc. -* Runtime Environment:: Accessing and modifying Guile's environment. -* Processes:: getuid, getpid, etc. -* Signals:: sigaction, kill, pause, alarm, etc. -* Terminals and Ptys:: ttyname, tcsetpgrp, etc. -* Pipes:: Communicating data between processes. -* Networking:: gethostbyaddr, getnetent, socket, bind, listen. -* System Identification:: Obtaining information about the system. -* Locales:: setlocale, etc. -* Encryption:: -@end menu - -@node Conventions -@section POSIX Interface Conventions - -These interfaces provide access to operating system facilities. -They provide a simple wrapping around the underlying C interfaces -to make usage from Scheme more convenient. They are also used -to implement the Guile port of @ref{The Scheme shell (scsh)}. - -Generally there is a single procedure for each corresponding Unix -facility. There are some exceptions, such as procedures implemented for -speed and convenience in Scheme with no primitive Unix equivalent, -e.g., @code{copy-file}. - -The interfaces are intended as far as possible to be portable across -different versions of Unix. In some cases procedures which can't be -implemented on particular systems may become no-ops, or perform limited -actions. In other cases they may throw errors. - -General naming conventions are as follows: - -@itemize @bullet -@item -The Scheme name is often identical to the name of the underlying Unix -facility. -@item -Underscores in Unix procedure names are converted to hyphens. -@item -Procedures which destructively modify Scheme data have exclaimation -marks appended, e.g., @code{recv!}. -@item -Predicates (returning only @code{#t} or @code{#f}) have question marks -appended, e.g., @code{access?}. -@item -Some names are changed to avoid conflict with dissimilar interfaces -defined by scsh, e.g., @code{primitive-fork}. -@item -Unix preprocessor names such as @code{EPERM} or @code{R_OK} are converted -to Scheme variables of the same name (underscores are not replaced -with hyphens). -@end itemize - -Unexpected conditions are generally handled by raising exceptions. -There are a few procedures which return a special value if they don't -succeed, e.g., @code{getenv} returns @code{#f} if it the requested -string is not found in the environment. These cases are noted in -the documentation. - -For ways to deal with exceptions, @ref{Exceptions}. - -Errors which the C-library would report by returning a NULL pointer or -through some other means are reported by raising a @code{system-error} -exception. The value of the Unix @code{errno} variable is available -in the data passed by the exception. - -It can be extracted with the function @code{system-error-errno}: - -@example -(catch - 'system-error - (lambda () - (mkdir "/this-ought-to-fail-if-I'm-not-root")) - (lambda stuff - (let ((errno (system-error-errno stuff))) - (cond - ((= errno EACCES) - (display "You're not allowed to do that.")) - ((= errno EEXIST) - (display "Already exists.")) - (#t - (display (strerror errno)))) - (newline)))) -@end example - -@node Ports and File Descriptors -@section Ports and File Descriptors - -Conventions generally follow those of scsh, @ref{The Scheme shell (scsh)}. - -File ports are implemented using low-level operating system I/O -facilities, with optional buffering to improve efficiency -@pxref{File Ports} - -Note that some procedures (e.g., @code{recv!}) will accept ports as -arguments, but will actually operate directly on the file descriptor -underlying the port. Any port buffering is ignored, including the -buffer which implements @code{peek-char} and @code{unread-char}. - -The @code{force-output} and @code{drain-input} procedures can be used -to clear the buffers. - -Each open file port has an associated operating system file descriptor. -File descriptors are generally not useful in Scheme programs; however -they may be needed when interfacing with foreign code and the Unix -environment. - -A file descriptor can be extracted from a port and a new port can be -created from a file descriptor. However a file descriptor is just an -integer and the garbage collector doesn't recognise it as a reference -to the port. If all other references to the port were dropped, then -it's likely that the garbage collector would free the port, with the -side-effect of closing the file descriptor prematurely. - -To assist the programmer in avoiding this problem, each port has an -associated "revealed count" which can be used to keep track of how many -times the underlying file descriptor has been stored in other places. -If a port's revealed count is greater than zero, the file descriptor -will not be closed when the port is gabage collected. A programmer -can therefore ensure that the revealed count will be greater than -zero if the file descriptor is needed elsewhere. - -For the simple case where a file descriptor is "imported" once to become -a port, it does not matter if the file descriptor is closed when the -port is garbage collected. There is no need to maintain a revealed -count. Likewise when "exporting" a file descriptor to the external -environment, setting the revealed count is not required provided the -port is kept open (i.e., is pointed to by a live Scheme binding) while -the file descriptor is in use. - -To correspond with traditional Unix behaviour, the three file -descriptors (0, 1 and 2) are automatically imported when a program -starts up and assigned to the initial values of the current input, -output and error ports. The revealed count for each is initially set to -one, so that dropping references to one of these ports will not result -in its garbage collection: it could be retrieved with fdopen or -fdes->ports. - -@deffn primitive port-revealed port -Return the revealed count for @var{port}. -@end deffn - -@deffn primitive set-port-revealed! port rcount -Sets the revealed count for a port to a given value. -The return value is unspecified. -@end deffn - -@deffn primitive fileno port -Return the integer file descriptor underlying @var{port}. Does -not change its revealed count. -@end deffn - -@deffn procedure port->fdes port -Returns the integer file descriptor underlying @var{port}. As a -side effect the revealed count of @var{port} is incremented. -@end deffn - -@deffn primitive fdopen fdes modes -Return a new port based on the file descriptor @var{fdes}. -Modes are given by the string @var{modes}. The revealed count -of the port is initialized to zero. The modes string is the -same as that accepted by @ref{File Ports, open-file}. -@end deffn - -@deffn primitive fdes->ports fd -Return a list of existing ports which have @var{fdes} as an -underlying file descriptor, without changing their revealed -counts. -@end deffn - -@deffn procedure fdes->inport fdes -Returns an existing input port which has @var{fdes} as its underlying file -descriptor, if one exists, and increments its revealed count. -Otherwise, returns a new input port with a revealed count of 1. -@end deffn - -@deffn procedure fdes->outport fdes -Returns an existing output port which has @var{fdes} as its underlying file -descriptor, if one exists, and increments its revealed count. -Otherwise, returns a new output port with a revealed count of 1. -@end deffn - -@deffn primitive primitive-move->fdes port fd -Moves the underlying file descriptor for @var{port} to the integer -value @var{fdes} without changing the revealed count of @var{port}. -Any other ports already using this descriptor will be automatically -shifted to new descriptors and their revealed counts reset to zero. -The return value is @code{#f} if the file descriptor already had the -required value or @code{#t} if it was moved. -@end deffn - -@deffn procedure move->fdes port fdes -Moves the underlying file descriptor for @var{port} to the integer -value @var{fdes} and sets its revealed count to one. Any other ports -already using this descriptor will be automatically -shifted to new descriptors and their revealed counts reset to zero. -The return value is unspecified. -@end deffn - -@deffn procedure release-port-handle port -Decrements the revealed count for a port. -@end deffn - -@deffn primitive fsync object -Copies any unwritten data for the specified output file descriptor to disk. -If @var{port/fd} is a port, its buffer is flushed before the underlying -file descriptor is fsync'd. -The return value is unspecified. -@end deffn - -@deffn primitive open path flags [mode] -Open the file named by @var{path} for reading and/or writing. -@var{flags} is an integer specifying how the file should be opened. -@var{mode} is an integer specifying the permission bits of the file, if -it needs to be created, before the umask is applied. The default is 666 -(Unix itself has no default). - -@var{flags} can be constructed by combining variables using @code{logior}. -Basic flags are: - -@defvar O_RDONLY -Open the file read-only. -@end defvar -@defvar O_WRONLY -Open the file write-only. -@end defvar -@defvar O_RDWR -Open the file read/write. -@end defvar -@defvar O_APPEND -Append to the file instead of truncating. -@end defvar -@defvar O_CREAT -Create the file if it does not already exist. -@end defvar - -See the Unix documentation of the @code{open} system call -for additional flags. -@end deffn - -@deffn primitive open-fdes path flags [mode] -Similar to @code{open} but return a file descriptor instead of -a port. -@end deffn - -@deffn primitive close fd_or_port -Similar to close-port (@pxref{Closing, close-port}), but also works on -file descriptors. A side effect of closing a file descriptor is that -any ports using that file descriptor are moved to a different file -descriptor and have their revealed counts set to zero. -@end deffn - -@deffn primitive close-fdes fd -A simple wrapper for the @code{close} system call. -Close file descriptor @var{fd}, which must be an integer. -Unlike close (@pxref{Ports and File Descriptors, close}), -the file descriptor will be closed even if a port is using it. -The return value is unspecified. -@end deffn - -@deffn primitive unread-char char [port] -Place @var{char} in @var{port} so that it will be read by the -next read operation. If called multiple times, the unread characters -will be read again in last-in first-out order. If @var{port} is -not supplied, the current input port is used. -@end deffn - -@deffn primitive unread-string str port -Place the string @var{str} in @var{port} so that its characters will be -read in subsequent read operations. If called multiple times, the -unread characters will be read again in last-in first-out order. If -@var{port} is not supplied, the current-input-port is used. -@end deffn - -@deffn primitive pipe -Return a newly created pipe: a pair of ports which are linked -together on the local machine. The @emph{car} is the input -port and the @emph{cdr} is the output port. Data written (and -flushed) to the output port can be read from the input port. -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}. - -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. -@end deffn - -The next group of procedures perform a @code{dup2} -system call, if @var{newfd} (an -integer) is supplied, otherwise a @code{dup}. The file descriptor to be -duplicated can be supplied as an integer or contained in a port. The -type of value returned varies depending on which procedure is used. - -All procedures also have the side effect when performing @code{dup2} that any -ports using @var{newfd} are moved to a different file descriptor and have -their revealed counts set to zero. - -@deffn primitive dup->fdes fd_or_port [fd] -Return a new integer file descriptor referring to the open file -designated by @var{fd_or_port}, which must be either an open -file port or a file descriptor. -@end deffn - -@deffn procedure dup->inport port/fd [newfd] -Returns a new input port using the new file descriptor. -@end deffn - -@deffn procedure dup->outport port/fd [newfd] -Returns a new output port using the new file descriptor. -@end deffn - -@deffn procedure dup port/fd [newfd] -Returns a new port if @var{port/fd} is a port, with the same mode as the -supplied port, otherwise returns an integer file descriptor. -@end deffn - -@deffn procedure dup->port port/fd mode [newfd] -Returns a new port using the new file descriptor. @var{mode} supplies a -mode string for the port (@pxref{File Ports, open-file}). -@end deffn - -@deffn procedure duplicate-port port modes -Returns a new port which is opened on a duplicate of the file -descriptor underlying @var{port}, with mode string @var{modes} -as for @ref{File Ports, open-file}. The two ports -will share a file position and file status flags. - -Unexpected behaviour can result if both ports are subsequently used -and the original and/or duplicate ports are buffered. -The mode string can include @code{0} to obtain an unbuffered duplicate -port. - -This procedure is equivalent to @code{(dup->port @var{port} @var{modes})}. -@end deffn - -@deffn primitive redirect-port old new -This procedure takes two ports and duplicates the underlying file -descriptor from @var{old-port} into @var{new-port}. The -current file descriptor in @var{new-port} will be closed. -After the redirection the two ports will share a file position -and file status flags. - -The return value is unspecified. - -Unexpected behaviour can result if both ports are subsequently used -and the original and/or duplicate ports are buffered. - -This procedure does not have any side effects on other ports or -revealed counts. -@end deffn - -@deffn primitive dup2 oldfd newfd -A simple wrapper for the @code{dup2} system call. -Copies the file descriptor @var{oldfd} to descriptor -number @var{newfd}, replacing the previous meaning -of @var{newfd}. Both @var{oldfd} and @var{newfd} must -be integers. -Unlike for dup->fdes or primitive-move->fdes, no attempt -is made to move away ports which are using @var{newfd}. -The return value is unspecified. -@end deffn - -@deffn primitive port-mode port -Return the port modes associated with the open port @var{port}. -These will not necessarily be identical to the modes used when -the port was opened, since modes such as "append" which are -used only during port creation are not retained. -@end deffn - -@deffn primitive close-all-ports-except . ports -[DEPRECATED] Close all open file ports used by the interpreter -except for those supplied as arguments. This procedure -was intended to be used before an exec call to close file descriptors -which are not needed in the new process. However it has the -undesirable side-effect of flushing buffes, so it's deprecated. -Use port-for-each instead. -@end deffn - -@deffn primitive port-for-each proc -Apply @var{proc} to each port in the Guile port table -in turn. The return value is unspecified. More specifically, -@var{proc} is applied exactly once to every port that exists -in the system at the time @var{port-for-each} is invoked. -Changes to the port table while @var{port-for-each} is running -have no effect as far as @var{port-for-each} is concerned. -@end deffn - -@deffn primitive setvbuf port mode [size] -Set the buffering mode for @var{port}. @var{mode} can be: -@table @code -@item _IONBF -non-buffered -@item _IOLBF -line buffered -@item _IOFBF -block buffered, using a newly allocated buffer of @var{size} bytes. -If @var{size} is omitted, a default size will be used. -@end table -@end deffn - -@deffn primitive fcntl object cmd [value] -Apply @var{command} to the specified file descriptor or the underlying -file descriptor of the specified port. @var{value} is an optional -integer argument. - -Values for @var{command} are: - -@table @code -@item F_DUPFD -Duplicate a file descriptor -@item F_GETFD -Get flags associated with the file descriptor. -@item F_SETFD -Set flags associated with the file descriptor to @var{value}. -@item F_GETFL -Get flags associated with the open file. -@item F_SETFL -Set flags associated with the open file to @var{value} -@item F_GETOWN -Get the process ID of a socket's owner, for @code{SIGIO} signals. -@item F_SETOWN -Set the process that owns a socket to @var{value}, for @code{SIGIO} signals. -@item FD_CLOEXEC -The value used to indicate the "close on exec" flag with @code{F_GETFL} or -@code{F_SETFL}. -@end table -@end deffn - -@deffn primitive flock file operation -Apply or remove an advisory lock on an open file. -@var{operation} specifies the action to be done: -@table @code -@item LOCK_SH -Shared lock. More than one process may hold a shared lock -for a given file at a given time. -@item LOCK_EX -Exclusive lock. Only one process may hold an exclusive lock -for a given file at a given time. -@item LOCK_UN -Unlock the file. -@item LOCK_NB -Don't block when locking. May be specified by bitwise OR'ing -it to one of the other operations. -@end table -The return value is not specified. @var{file} may be an open -file descriptor or an open file descriptior port. -@end deffn - -@deffn primitive select reads writes excepts [secs [usecs]] -This procedure has a variety of uses: waiting for the ability -to provide input, accept output, or the existance of -exceptional conditions on a collection of ports or file -descriptors, or waiting for a timeout to occur. -It also returns if interrupted by a signal. - -@var{reads}, @var{writes} and @var{excepts} can be lists or -vectors, with each member a port or a file descriptor. -The value returned is a list of three corresponding -lists or vectors containing only the members which meet the -specified requirement. The ability of port buffers to -provide input or accept output is taken into account. -Ordering of the input lists or vectors is not preserved. - -The optional arguments @var{secs} and @var{usecs} specify the -timeout. Either @var{secs} can be specified alone, as -either an integer or a real number, or both @var{secs} and -@var{usecs} can be specified as integers, in which case -@var{usecs} is an additional timeout expressed in -microseconds. If @var{secs} is omitted or is @code{#f} then -select will wait for as long as it takes for one of the other -conditions to be satisfied. - -The scsh version of @code{select} differs as follows: -Only vectors are accepted for the first three arguments. -The @var{usecs} argument is not supported. -Multiple values are returned instead of a list. -Duplicates in the input vectors appear only once in output. -An additional @code{select!} interface is provided. -@end deffn - -@node File System -@section File System - -These procedures allow querying and setting file system attributes -(such as owner, -permissions, sizes and types of files); deleting, copying, renaming and -linking files; creating and removing directories and querying their -contents; syncing the file system and creating special files. - -@deffn primitive access? path how -Return @code{#t} if @var{path} corresponds to an existing file -and the current process has the type of access specified by -@var{how}, otherwise @code{#f}. @var{how} should be specified -using the values of the variables listed below. Multiple -values can be combined using a bitwise or, in which case -@code{#t} will only be returned if all accesses are granted. - -Permissions are checked using the real id of the current -process, not the effective id, although it's the effective id -which determines whether the access would actually be granted. - -@defvar R_OK -test for read permission. -@end defvar -@defvar W_OK -test for write permission. -@end defvar -@defvar X_OK -test for execute permission. -@end defvar -@defvar F_OK -test for existence of the file. -@end defvar -@end deffn - -@findex fstat -@deffn primitive stat object -Return an object containing various information about the file -determined by @var{obj}. @var{obj} can be a string containing -a file name or a port or integer file descriptor which is open -on a file (in which case @code{fstat} is used as the underlying -system call). - -The object returned by @code{stat} can be passed as a single -parameter to the following procedures, all of which return -integers: - -@table @code -@item stat:dev -The device containing the file. -@item stat:ino -The file serial number, which distinguishes this file from all -other files on the same device. -@item stat:mode -The mode of the file. This includes file type information and -the file permission bits. See @code{stat:type} and -@code{stat:perms} below. -@item stat:nlink -The number of hard links to the file. -@item stat:uid -The user ID of the file's owner. -@item stat:gid -The group ID of the file. -@item stat:rdev -Device ID; this entry is defined only for character or block -special files. -@item stat:size -The size of a regular file in bytes. -@item stat:atime -The last access time for the file. -@item stat:mtime -The last modification time for the file. -@item stat:ctime -The last modification time for the attributes of the file. -@item stat:blksize -The optimal block size for reading or writing the file, in -bytes. -@item stat:blocks -The amount of disk space that the file occupies measured in -units of 512 byte blocks. -@end table - -In addition, the following procedures return the information -from stat:mode in a more convenient form: - -@table @code -@item stat:type -A symbol representing the type of file. Possible values are -regular, directory, symlink, block-special, char-special, fifo, -socket and unknown -@item stat:perms -An integer representing the access permission bits. -@end table -@end deffn - -@deffn primitive lstat str -Similar to @code{stat}, but does not follow symbolic links, i.e., -it will return information about a symbolic link itself, not the -file it points to. @var{path} must be a string. -@end deffn - -@deffn primitive readlink path -Return the value of the symbolic link named by @var{path} (a -string), i.e., the file that the link points to. -@end deffn - -@findex fchown -@findex lchown -@deffn primitive chown object owner group -Change the ownership and group of the file referred to by @var{object} to -the integer values @var{owner} and @var{group}. @var{object} can be -a string containing a file name or, if the platform -supports fchown, a port or integer file descriptor -which is open on the file. The return value -is unspecified. - -If @var{object} is a symbolic link, either the -ownership of the link or the ownership of the referenced file will be -changed depending on the operating system (lchown is -unsupported at present). If @var{owner} or @var{group} is specified -as @code{-1}, then that ID is not changed. -@end deffn - -@findex fchmod -@deffn primitive chmod object mode -Changes the permissions of the file referred to by @var{obj}. -@var{obj} can be a string containing a file name or a port or integer file -descriptor which is open on a file (in which case @code{fchmod} is used -as the underlying system call). -@var{mode} specifies -the new permissions as a decimal number, e.g., @code{(chmod "foo" #o755)}. -The return value is unspecified. -@end deffn - -@deffn primitive utime pathname [actime [modtime]] -@code{utime} sets the access and modification times for the -file named by @var{path}. If @var{actime} or @var{modtime} is -not supplied, then the current time is used. @var{actime} and -@var{modtime} must be integer time values as returned by the -@code{current-time} procedure. -@lisp -(utime "foo" (- (current-time) 3600)) -@end lisp -will set the access time to one hour in the past and the -modification time to the current time. -@end deffn - -@findex unlink -@deffn primitive delete-file str -Deletes (or "unlinks") the file specified by @var{path}. -@end deffn - -@deffn primitive copy-file oldfile newfile -Copy the file specified by @var{path-from} to @var{path-to}. -The return value is unspecified. -@end deffn - -@findex rename -@deffn primitive rename-file oldname newname -Renames the file specified by @var{oldname} to @var{newname}. -The return value is unspecified. -@end deffn - -@deffn primitive link oldpath newpath -Creates a new name @var{newpath} in the file system for the -file named by @var{oldpath}. If @var{oldpath} is a symbolic -link, the link may or may not be followed depending on the -system. -@end deffn - -@deffn primitive symlink oldpath newpath -Create a symbolic link named @var{path-to} with the value (i.e., pointing to) -@var{path-from}. The return value is unspecified. -@end deffn - -@deffn primitive mkdir path [mode] -Create a new directory named by @var{path}. If @var{mode} is omitted -then the permissions of the directory file are set using the current -umask. Otherwise they are set to the decimal value specified with -@var{mode}. The return value is unspecified. -@end deffn - -@deffn primitive rmdir path -Remove the existing directory named by @var{path}. The directory must -be empty for this to succeed. The return value is unspecified. -@end deffn - -@deffn primitive opendir dirname -Open the directory specified by @var{path} and return a directory -stream. -@end deffn - -@deffn primitive directory-stream? obj -Return a boolean indicating whether @var{object} is a directory -stream as returned by @code{opendir}. -@end deffn - -@deffn primitive readdir port -Return (as a string) the next directory entry from the directory stream -@var{stream}. If there is no remaining entry to be read then the -end of file object is returned. -@end deffn - -@deffn primitive rewinddir port -Reset the directory port @var{stream} so that the next call to -@code{readdir} will return the first directory entry. -@end deffn - -@deffn primitive closedir port -Close the directory stream @var{stream}. -The return value is unspecified. -@end deffn - -@deffn primitive sync -Flush the operating system disk buffers. -The return value is unspecified. -@end deffn - -@deffn primitive mknod path type perms dev -Creates a new special file, such as a file corresponding to a device. -@var{path} specifies the name of the file. @var{type} should -be one of the following symbols: -regular, directory, symlink, block-special, char-special, -fifo, or socket. @var{perms} (an integer) specifies the file permissions. -@var{dev} (an integer) specifies which device the special file refers -to. Its exact interpretation depends on the kind of special file -being created. - -E.g., -@lisp -(mknod "/dev/fd0" 'block-special #o660 (+ (* 2 256) 2)) -@end lisp - -The return value is unspecified. -@end deffn - -@deffn primitive tmpnam -Return a name in the file system that does not match any -existing file. However there is no guarantee that another -process will not create the file after @code{tmpnam} is called. -Care should be taken if opening the file, e.g., use the -@code{O_EXCL} open flag or use @code{mkstemp!} instead. -@end deffn - -@deffn primitive mkstemp! tmpl -Create a new unique file in the file system and returns a new -buffered port open for reading and writing to the file. -@var{tmpl} is a string specifying where the file should be -created: it must end with @code{XXXXXX} and will be changed in -place to return the name of the temporary file. -@end deffn - -@deffn primitive dirname filename -Return the directory name component of the file name -@var{filename}. If @var{filename} does not contain a directory -component, @code{.} is returned. -@end deffn - -@deffn primitive basename filename [suffix] -Return the base name of the file name @var{filename}. The -base name is the file name without any directory components. -If @var{suffix} is privided, and is equal to the end of -@var{basename}, it is removed also. -@end deffn - - -@node User Information -@section User Information - -The facilities in this section provide an interface to the user and -group database. -They should be used with care since they are not reentrant. - -The following functions accept an object representing user information -and return a selected component: - -@table @code -@item passwd:name -The name of the userid. -@item passwd:passwd -The encrypted passwd. -@item passwd:uid -The user id number. -@item passwd:gid -The group id number. -@item passwd:gecos -The full name. -@item passwd:dir -The home directory. -@item passwd:shell -The login shell. -@end table - -@deffn procedure getpwuid uid -Look up an integer userid in the user database. -@end deffn - -@deffn procedure getpwnam name -Look up a user name string in the user database. -@end deffn - -@deffn procedure setpwent -Initializes a stream used by @code{getpwent} to read from the user database. -The next use of @code{getpwent} will return the first entry. The -return value is unspecified. -@end deffn - -@deffn procedure getpwent -Return the next entry in the user database, using the stream set by -@code{setpwent}. -@end deffn - -@deffn procedure endpwent -Closes the stream used by @code{getpwent}. The return value is unspecified. -@end deffn - -@deffn primitive setpw [arg] -If called with a true argument, initialize or reset the password data -stream. Otherwise, close the stream. The @code{setpwent} and -@code{endpwent} procedures are implemented on top of this. -@end deffn - -@deffn primitive getpw [user] -Look up an entry in the user database. @var{obj} can be an integer, -a string, or omitted, giving the behaviour of getpwuid, getpwnam -or getpwent respectively. -@end deffn - -The following functions accept an object representing group information -and return a selected component: - -@table @code -@item group:name -The group name. -@item group:passwd -The encrypted group password. -@item group:gid -The group id number. -@item group:mem -A list of userids which have this group as a supplimentary group. -@end table - -@deffn procedure getgrgid gid -Look up an integer groupid in the group database. -@end deffn - -@deffn procedure getgrnam name -Look up a group name in the group database. -@end deffn - -@deffn procedure setgrent -Initializes a stream used by @code{getgrent} to read from the group database. -The next use of @code{getgrent} will return the first entry. -The return value is unspecified. -@end deffn - -@deffn procedure getgrent -Return the next entry in the group database, using the stream set by -@code{setgrent}. -@end deffn - -@deffn procedure endgrent -Closes the stream used by @code{getgrent}. -The return value is unspecified. -@end deffn - -@deffn primitive setgr [arg] -If called with a true argument, initialize or reset the group data -stream. Otherwise, close the stream. The @code{setgrent} and -@code{endgrent} procedures are implemented on top of this. -@end deffn - -@deffn primitive getgr [name] -Look up an entry in the group database. @var{obj} can be an integer, -a string, or omitted, giving the behaviour of getgrgid, getgrnam -or getgrent respectively. -@end deffn - -In addition to the accessor procedures for the user database, the -following shortcut procedures are also available. - -@deffn primitive cuserid -Return a string containing a user name associated with the -effective user id of the process. Return @code{#f} if this -information cannot be obtained. -@end deffn - -@deffn primitive getlogin -Return a string containing the name of the user logged in on -the controlling terminal of the process, or @code{#f} if this -information cannot be obtained. -@end deffn - - -@node Time -@section Time - -@deffn primitive current-time -Return the number of seconds since 1970-01-01 00:00:00 UTC, -excluding leap seconds. -@end deffn - -@deffn primitive gettimeofday -Return a pair containing the number of seconds and microseconds -since 1970-01-01 00:00:00 UTC, excluding leap seconds. Note: -whether true microsecond resolution is available depends on the -operating system. -@end deffn - -The following procedures either accept an object representing a broken down -time and return a selected component, or accept an object representing -a broken down time and a value and set the component to the value. -The numbers in parentheses give the usual range. - -@table @code -@item tm:sec, set-tm:sec -Seconds (0-59). -@item tm:min, set-tm:min -Minutes (0-59). -@item tm:hour, set-tm:hour -Hours (0-23). -@item tm:mday, set-tm:mday -Day of the month (1-31). -@item tm:mon, set-tm:mon -Month (0-11). -@item tm:year, set-tm:year -Year (70-), the year minus 1900. -@item tm:wday, set-tm:wday -Day of the week (0-6) with Sunday represented as 0. -@item tm:yday, set-tm:yday -Day of the year (0-364, 365 in leap years). -@item tm:isdst, set-tm:isdst -Daylight saving indicator (0 for "no", greater than 0 for "yes", less than -0 for "unknown"). -@item tm:gmtoff, set-tm:gmtoff -Time zone offset in seconds west of UTC (-46800 to 43200). -@item tm:zone, set-tm:zone -Time zone label (a string), not necessarily unique. -@end table - -@deffn primitive localtime time [zone] -Return an object representing the broken down components of -@var{time}, an integer like the one returned by -@code{current-time}. The time zone for the calculation is -optionally specified by @var{zone} (a string), otherwise the -@code{TZ} environment variable or the system default is used. -@end deffn - -@deffn primitive gmtime time -Return an object representing the broken down components of -@var{time}, an integer like the one returned by -@code{current-time}. The values are calculated for UTC. -@end deffn - -@deffn primitive mktime sbd_time [zone] -@var{bd-time} is an object representing broken down time and @code{zone} -is an optional time zone specifier (otherwise the TZ environment variable -or the system default is used). - -Returns a pair: the car is a corresponding -integer time value like that returned -by @code{current-time}; the cdr is a broken down time object, similar to -as @var{bd-time} but with normalized values. -@end deffn - -@deffn primitive tzset -Initialize the timezone from the TZ environment variable -or the system default. It's not usually necessary to call this procedure -since it's done automatically by other procedures that depend on the -timezone. -@end deffn - -@deffn primitive strftime format stime -Formats a time specification @var{time} using @var{template}. @var{time} -is an object with time components in the form returned by @code{localtime} -or @code{gmtime}. @var{template} is a string which can include formatting -specifications introduced by a @code{%} character. The formatting of -month and day names is dependent on the current locale. The value returned -is the formatted string. -@xref{Formatting Date and Time, , , libc, The GNU C Library Reference Manual}.) -@end deffn - -@deffn primitive strptime format string -Performs the reverse action to @code{strftime}, parsing -@var{string} according to the specification supplied in -@var{template}. The interpretation of month and day names is -dependent on the current locale. The value returned is a pair. -The car has an object with time components -in the form returned by @code{localtime} or @code{gmtime}, -but the time zone components -are not usefully set. -The cdr reports the number of characters from @var{string} -which were used for the conversion. -@end deffn - -@defvar internal-time-units-per-second -The value of this variable is the number of time units per second -reported by the following procedures. -@end defvar - -@deffn primitive times -Return an object with information about real and processor -time. The following procedures accept such an object as an -argument and return a selected component: - -@table @code -@item tms:clock -The current real time, expressed as time units relative to an -arbitrary base. -@item tms:utime -The CPU time units used by the calling process. -@item tms:stime -The CPU time units used by the system on behalf of the calling -process. -@item tms:cutime -The CPU time units used by terminated child processes of the -calling process, whose status has been collected (e.g., using -@code{waitpid}). -@item tms:cstime -Similarly, the CPU times units used by the system on behalf of -terminated child processes. -@end table -@end deffn - -@deffn primitive get-internal-real-time -Return the number of time units since the interpreter was -started. -@end deffn - -@deffn primitive get-internal-run-time -Return the number of time units of processor time used by the -interpreter. Both @emph{system} and @emph{user} time are -included but subprocesses are not. -@end deffn - -@node Runtime Environment -@section Runtime Environment - -@deffn primitive program-arguments -@deffnx procedure command-line -Return the list of command line arguments passed to Guile, as a list of -strings. The list includes the invoked program name, which is usually -@code{"guile"}, but excludes switches and parameters for command line -options like @code{-e} and @code{-l}. -@end deffn - -@deffn primitive getenv nam -Looks up the string @var{name} in the current environment. The return -value is @code{#f} unless a string of the form @code{NAME=VALUE} is -found, in which case the string @code{VALUE} is returned. -@end deffn - -@c begin (scm-doc-string "boot-9.scm" "setenv") -@deffn procedure setenv name value -Modifies the environment of the current process, which is -also the default environment inherited by child processes. - -If @var{value} is @code{#f}, then @var{name} is removed from the -environment. Otherwise, the string @var{name}=@var{value} is added -to the environment, replacing any existing string with name matching -@var{name}. - -The return value is unspecified. -@end deffn - -@deffn primitive environ [env] -If @var{env} is omitted, return the current environment (in the -Unix sense) as a list of strings. Otherwise set the current -environment, which is also the default environment for child -processes, to the supplied list of strings. Each member of -@var{env} should be of the form @code{NAME=VALUE} and values of -@code{NAME} should not be duplicated. If @var{env} is supplied -then the return value is unspecified. -@end deffn - -@deffn primitive putenv str -Modifies the environment of the current process, which is -also the default environment inherited by child processes. - -If @var{string} is of the form @code{NAME=VALUE} then it will be written -directly into the environment, replacing any existing environment string -with -name matching @code{NAME}. If @var{string} does not contain an equal -sign, then any existing string with name matching @var{string} will -be removed. - -The return value is unspecified. -@end deffn - - -@node Processes -@section Processes - -@findex cd -@deffn primitive chdir str -Change the current working directory to @var{path}. -The return value is unspecified. -@end deffn - -@findex pwd -@deffn primitive getcwd -Return the name of the current working directory. -@end deffn - -@deffn primitive umask [mode] -If @var{mode} is omitted, retuns a decimal number representing the current -file creation mask. Otherwise the file creation mask is set to -@var{mode} and the previous value is returned. - -E.g., @code{(umask #o022)} sets the mask to octal 22, decimal 18. -@end deffn - -@deffn primitive chroot path -Change the root directory to that specified in @var{path}. -This directory will be used for path names beginning with -@file{/}. The root directory is inherited by all children -of the current process. Only the superuser may change the -root directory. -@end deffn - -@deffn primitive getpid -Return an integer representing the current process ID. -@end deffn - -@deffn primitive getgroups -Return a vector of integers representing the current -supplimentary group IDs. -@end deffn - -@deffn primitive getppid -Return an integer representing the process ID of the parent -process. -@end deffn - -@deffn primitive getuid -Return an integer representing the current real user ID. -@end deffn - -@deffn primitive getgid -Return an integer representing the current real group ID. -@end deffn - -@deffn primitive geteuid -Return an integer representing the current effective user ID. -If the system does not support effective IDs, then the real ID -is returned. @code{(feature? 'EIDs)} reports whether the -system supports effective IDs. -@end deffn - -@deffn primitive getegid -Return an integer representing the current effective group ID. -If the system does not support effective IDs, then the real ID -is returned. @code{(feature? 'EIDs)} reports whether the -system supports effective IDs. -@end deffn - -@deffn primitive setuid id -Sets both the real and effective user IDs to the integer @var{id}, provided -the process has appropriate privileges. -The return value is unspecified. -@end deffn - -@deffn primitive setgid id -Sets both the real and effective group IDs to the integer @var{id}, provided -the process has appropriate privileges. -The return value is unspecified. -@end deffn - -@deffn primitive seteuid id -Sets the effective user ID to the integer @var{id}, provided the process -has appropriate privileges. If effective IDs are not supported, the -real ID is set instead -- @code{(feature? 'EIDs)} reports whether the -system supports effective IDs. -The return value is unspecified. -@end deffn - -@deffn primitive setegid id -Sets the effective group ID to the integer @var{id}, provided the process -has appropriate privileges. If effective IDs are not supported, the -real ID is set instead -- @code{(feature? 'EIDs)} reports whether the -system supports effective IDs. -The return value is unspecified. -@end deffn - -@deffn primitive getpgrp -Return an integer representing the current process group ID. -This is the POSIX definition, not BSD. -@end deffn - -@deffn primitive setpgid pid pgid -Move the process @var{pid} into the process group @var{pgid}. @var{pid} or -@var{pgid} must be integers: they can be zero to indicate the ID of the -current process. -Fails on systems that do not support job control. -The return value is unspecified. -@end deffn - -@deffn primitive setsid -Creates a new session. The current process becomes the session leader -and is put in a new process group. The process will be detached -from its controlling terminal if it has one. -The return value is an integer representing the new process group ID. -@end deffn - -@deffn primitive waitpid pid [options] -This procedure collects status information from a child process which -has terminated or (optionally) stopped. Normally it will -suspend the calling process until this can be done. If more than one -child process is eligible then one will be chosen by the operating system. - -The value of @var{pid} determines the behaviour: - -@table @r -@item @var{pid} greater than 0 -Request status information from the specified child process. -@item @var{pid} equal to -1 or WAIT_ANY -Request status information for any child process. -@item @var{pid} equal to 0 or WAIT_MYPGRP -Request status information for any child process in the current process -group. -@item @var{pid} less than -1 -Request status information for any child process whose process group ID -is -@var{PID}. -@end table - -The @var{options} argument, if supplied, should be the bitwise OR of the -values of zero or more of the following variables: - -@defvar WNOHANG -Return immediately even if there are no child processes to be collected. -@end defvar - -@defvar WUNTRACED -Report status information for stopped processes as well as terminated -processes. -@end defvar - -The return value is a pair containing: - -@enumerate -@item -The process ID of the child process, or 0 if @code{WNOHANG} was -specified and no process was collected. -@item -The integer status value. -@end enumerate -@end deffn - -The following three -functions can be used to decode the process status code returned -by @code{waitpid}. - -@deffn primitive status:exit-val status -Return the exit status value, as would be set if a process -ended normally through a call to @code{exit} or @code{_exit}, -if any, otherwise @code{#f}. -@end deffn - -@deffn primitive status:term-sig status -Return the signal number which terminated the process, if any, -otherwise @code{#f}. -@end deffn - -@deffn primitive status:stop-sig status -Return the signal number which stopped the process, if any, -otherwise @code{#f}. -@end deffn - -@deffn primitive system [cmd] -Execute @var{cmd} using the operating system's "command -processor". Under Unix this is usually the default shell -@code{sh}. The value returned is @var{cmd}'s exit status as -returned by @code{waitpid}, which can be interpreted using the -functions above. - -If @code{system} is called without arguments, return a boolean -indicating whether the command processor is available. -@end deffn - -@deffn primitive primitive-exit [status] -Terminate the current process without unwinding the Scheme stack. -This is would typically be useful after a fork. The exit status -is @var{status} if supplied, otherwise zero. -@end deffn - -@deffn primitive execl filename . args -Executes the file named by @var{path} as a new process image. -The remaining arguments are supplied to the process; from a C program -they are accessable as the @code{argv} argument to @code{main}. -Conventionally the first @var{arg} is the same as @var{path}. -All arguments must be strings. - -If @var{arg} is missing, @var{path} is executed with a null -argument list, which may have system-dependent side-effects. - -This procedure is currently implemented using the @code{execv} system -call, but we call it @code{execl} because of its Scheme calling interface. -@end deffn - -@deffn primitive execlp filename . args -Similar to @code{execl}, however if -@var{filename} does not contain a slash -then the file to execute will be located by searching the -directories listed in the @code{PATH} environment variable. - -This procedure is currently implemented using the @code{execvp} system -call, but we call it @code{execlp} because of its Scheme calling interface. -@end deffn - -@deffn primitive execle filename env . args -Similar to @code{execl}, but the environment of the new process is -specified by @var{env}, which must be a list of strings as returned by the -@code{environ} procedure. - -This procedure is currently implemented using the @code{execve} system -call, but we call it @code{execle} because of its Scheme calling interface. -@end deffn - -@deffn primitive primitive-fork -Creates a new "child" process by duplicating the current "parent" process. -In the child the return value is 0. In the parent the return value is -the integer process ID of the child. - -This procedure has been renamed from @code{fork} to avoid a naming conflict -with the scsh fork. -@end deffn - -@deffn primitive nice incr -Increment the priority of the current process by @var{incr}. A higher -priority value means that the process runs less often. -The return value is unspecified. -@end deffn - -@deffn primitive setpriority which who prio -Set the scheduling priority of the process, process group -or user, as indicated by @var{which} and @var{who}. @var{which} -is one of the variables @code{PRIO_PROCESS}, @code{PRIO_PGRP} -or @code{PRIO_USER}, and @var{who} is interpreted relative to -@var{which} (a process identifier for @code{PRIO_PROCESS}, -process group identifier for @code{PRIO_PGRP}, and a user -identifier for @code{PRIO_USER}. A zero value of @var{who} -denotes the current process, process group, or user. -@var{prio} is a value in the range -20 and 20, the default -priority is 0; lower priorities cause more favorable -scheduling. Sets the priority of all of the specified -processes. Only the super-user may lower priorities. -The return value is not specified. -@end deffn - -@deffn primitive getpriority which who -Return the scheduling priority of the process, process group -or user, as indicated by @var{which} and @var{who}. @var{which} -is one of the variables @code{PRIO_PROCESS}, @code{PRIO_PGRP} -or @code{PRIO_USER}, and @var{who} is interpreted relative to -@var{which} (a process identifier for @code{PRIO_PROCESS}, -process group identifier for @code{PRIO_PGRP}, and a user -identifier for @code{PRIO_USER}. A zero value of @var{who} -denotes the current process, process group, or user. Return -the highest priority (lowest numerical value) of any of the -specified processes. -@end deffn - - -@node Signals -@section Signals - -Procedures to raise, handle and wait for signals. - -@deffn primitive kill pid sig -Sends a signal to the specified process or group of processes. - -@var{pid} specifies the processes to which the signal is sent: - -@table @r -@item @var{pid} greater than 0 -The process whose identifier is @var{pid}. -@item @var{pid} equal to 0 -All processes in the current process group. -@item @var{pid} less than -1 -The process group whose identifier is -@var{pid} -@item @var{pid} equal to -1 -If the process is privileged, all processes except for some special -system processes. Otherwise, all processes with the current effective -user ID. -@end table - -@var{sig} should be specified using a variable corresponding to -the Unix symbolic name, e.g., - -@defvar SIGHUP -Hang-up signal. -@end defvar - -@defvar SIGINT -Interrupt signal. -@end defvar -@end deffn - -@deffn primitive raise sig -Sends a specified signal @var{sig} to the current process, where -@var{sig} is as described for the kill procedure. -@end deffn - -@deffn primitive sigaction signum [handler [flags]] -Install or report the signal handler for a specified signal. - -@var{signum} is the signal number, which can be specified using the value -of variables such as @code{SIGINT}. - -If @var{action} is omitted, @code{sigaction} returns a pair: the -CAR is the current -signal hander, which will be either an integer with the value @code{SIG_DFL} -(default action) or @code{SIG_IGN} (ignore), or the Scheme procedure which -handles the signal, or @code{#f} if a non-Scheme procedure handles the -signal. The CDR contains the current @code{sigaction} flags for the handler. - -If @var{action} is provided, it is installed as the new handler for -@var{signum}. @var{action} can be a Scheme procedure taking one -argument, or the value of @code{SIG_DFL} (default action) or -@code{SIG_IGN} (ignore), or @code{#f} to restore whatever signal handler -was installed before @code{sigaction} was first used. Flags can -optionally be specified for the new handler (@code{SA_RESTART} will -always be added if it's available and the system is using restartable -system calls.) The return value is a pair with information about the -old handler as described above. - -This interface does not provide access to the "signal blocking" -facility. Maybe this is not needed, since the thread support may -provide solutions to the problem of consistent access to data -structures. -@end deffn - -@deffn primitive restore-signals -Return all signal handlers to the values they had before any call to -@code{sigaction} was made. The return value is unspecified. -@end deffn - -@deffn primitive alarm i -Set a timer to raise a @code{SIGALRM} signal after the specified -number of seconds (an integer). It's advisable to install a signal -handler for -@code{SIGALRM} beforehand, since the default action is to terminate -the process. - -The return value indicates the time remaining for the previous alarm, -if any. The new value replaces the previous alarm. If there was -no previous alarm, the return value is zero. -@end deffn - -@deffn primitive pause -Pause the current process (thread?) until a signal arrives whose -action is to either terminate the current process or invoke a -handler procedure. The return value is unspecified. -@end deffn - -@deffn primitive sleep i -Wait for the given number of seconds (an integer) or until a signal -arrives. The return value is zero if the time elapses or the number -of seconds remaining otherwise. -@end deffn - -@deffn primitive usleep i -Sleep for I microseconds. @code{usleep} is not available on -all platforms. -@end deffn - -@node Terminals and Ptys -@section Terminals and Ptys - -@deffn primitive isatty? port -Return @code{#t} if @var{port} is using a serial non--file -device, otherwise @code{#f}. -@end deffn - -@deffn primitive ttyname port -Return a string with the name of the serial terminal device -underlying @var{port}. -@end deffn - -@deffn primitive ctermid -Return a string containing the file name of the controlling -terminal for the current process. -@end deffn - -@deffn primitive tcgetpgrp port -Return the process group ID of the foreground process group -associated with the terminal open on the file descriptor -underlying @var{port}. - -If there is no foreground process group, the return value is a -number greater than 1 that does not match the process group ID -of any existing process group. This can happen if all of the -processes in the job that was formerly the foreground job have -terminated, and no other job has yet been moved into the -foreground. -@end deffn - -@deffn primitive tcsetpgrp port pgid -Set the foreground process group ID for the terminal used by the file -descriptor underlying @var{port} to the integer @var{pgid}. -The calling process -must be a member of the same session as @var{pgid} and must have the same -controlling terminal. The return value is unspecified. -@end deffn - -@node Pipes -@section Pipes - -The following procedures provide an interface to the @code{popen} and -@code{pclose} system routines. The code is in a separate "popen" -module: - -@smalllisp -(use-modules (ice-9 popen)) -@end smalllisp - -@findex popen -@deffn procedure open-pipe command modes -Executes the shell command @var{command} (a string) in a subprocess. -A pipe to the process is created and returned. @var{modes} specifies -whether an input or output pipe to the process is created: it should -be the value of @code{OPEN_READ} or @code{OPEN_WRITE}. -@end deffn - -@deffn procedure open-input-pipe command -Equivalent to @code{open-pipe} with mode @code{OPEN_READ}. -@end deffn - -@deffn procedure open-output-pipe command -Equivalent to @code{open-pipe} with mode @code{OPEN_WRITE}. -@end deffn - -@findex pclose -@deffn procedure close-pipe port -Closes the pipe created by @code{open-pipe}, then waits for the process -to terminate and returns its status value, @xref{Processes, waitpid}, for -information on how to interpret this value. - -@code{close-port} (@pxref{Closing, close-port}) can also be used to -close a pipe, but doesn't return the status. -@end deffn - -@node Networking -@section Networking - -@menu -* Network Address Conversion:: -* Network Databases:: -* Network Sockets and Communication:: -@end menu - -@node Network Address Conversion -@subsection Network Address Conversion - -This section describes procedures which convert internet addresses -between numeric and string formats. - -@subsubsection IPv4 Address Conversion - -@deffn primitive inet-aton address -Convert an IPv4 Internet address from printable string -(dotted decimal notation) to an integer. E.g., - -@lisp -(inet-aton "127.0.0.1") @result{} 2130706433 -@end lisp -@end deffn - -@deffn primitive inet-ntoa inetid -Convert an IPv4 Internet address to a printable -(dotted decimal notation) string. E.g., - -@lisp -(inet-ntoa 2130706433) @result{} "127.0.0.1" -@end lisp -@end deffn - -@deffn primitive inet-netof address -Return the network number part of the given IPv4 -Internet address. E.g., - -@lisp -(inet-netof 2130706433) @result{} 127 -@end lisp -@end deffn - -@deffn primitive inet-lnaof address -Return the local-address-with-network part of the given -IPv4 Internet address, using the obsolete class A/B/C system. -E.g., - -@lisp -(inet-lnaof 2130706433) @result{} 1 -@end lisp -@end deffn - -@deffn primitive inet-makeaddr net lna -Make an IPv4 Internet address by combining the network number -@var{net} with the local-address-within-network number -@var{lna}. E.g., - -@lisp -(inet-makeaddr 127 1) @result{} 2130706433 -@end lisp -@end deffn - -@subsubsection IPv6 Address Conversion - -@deffn primitive inet-ntop family address -Convert a network address into a printable string. -Note that unlike the C version of this function, -the input is an integer with normal host byte ordering. -@var{family} can be @code{AF_INET} or @code{AF_INET6}. E.g., - -@lisp -(inet-ntop AF_INET 2130706433) @result{} "127.0.0.1" -(inet-ntop AF_INET6 (- (expt 2 128) 1)) @result{} -ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff -@end lisp -@end deffn - -@deffn primitive inet-pton family address -Convert a string containing a printable network address to -an integer address. Note that unlike the C version of this -function, -the result is an integer with normal host byte ordering. -@var{family} can be @code{AF_INET} or @code{AF_INET6}. E.g., - -@lisp -(inet-pton AF_INET "127.0.0.1") @result{} 2130706433 -(inet-pton AF_INET6 "::1") @result{} 1 -@end lisp -@end deffn - - -@node Network Databases -@subsection Network Databases - -This section describes procedures which query various network databases. -Care should be taken when using the database routines since they are not -reentrant. - -@subsubsection The Host Database - -A @dfn{host object} is a structure that represents what is known about a -network host, and is the usual way of representing a system's network -identity inside software. - -The following functions accept a host object and return a selected -component: - -@deffn procedure hostent:name host -The "official" hostname for @var{host}. -@end deffn -@deffn procedure hostent:aliases host -A list of aliases for @var{host}. -@end deffn -@deffn procedure hostent:addrtype host -The host address type. For hosts with Internet addresses, this will -return @code{AF_INET}. -@end deffn -@deffn procedure hostent:length host -The length of each address for @var{host}, in bytes. -@end deffn -@deffn procedure hostent:addr-list host -The list of network addresses associated with @var{host}. -@end deffn - -The following procedures are used to search the host database: - -@deffn primitive gethost [host] -@deffnx procedure gethostbyname hostname -@deffnx procedure gethostbyaddr address -Look up a host by name or address, returning a host object. The -@code{gethost} procedure will accept either a string name or an integer -address; if given no arguments, it behaves like @code{gethostent} (see -below). If a name or address is supplied but the address can not be -found, an error will be thrown to one of the keys: -@code{host-not-found}, @code{try-again}, @code{no-recovery} or -@code{no-data}, corresponding to the equivalent @code{h_error} values. -Unusual conditions may result in errors thrown to the -@code{system-error} or @code{misc_error} keys. -@end deffn - -The following procedures may be used to step through the host -database from beginning to end. - -@deffn procedure sethostent [stayopen] -Initialize an internal stream from which host objects may be read. This -procedure must be called before any calls to @code{gethostent}, and may -also be called afterward to reset the host entry stream. If -@var{stayopen} is supplied and is not @code{#f}, the database is not -closed by subsequent @code{gethostbyname} or @code{gethostbyaddr} calls, -possibly giving an efficiency gain. -@end deffn - -@deffn procedure gethostent -Return the next host object from the host database, or @code{#f} if -there are no more hosts to be found (or an error has been encountered). -This procedure may not be used before @code{sethostent} has been called. -@end deffn - -@deffn procedure endhostent -Close the stream used by @code{gethostent}. The return value is unspecified. -@end deffn - -@deffn primitive sethost [stayopen] -If @var{stayopen} is omitted, this is equivalent to @code{endhostent}. -Otherwise it is equivalent to @code{sethostent stayopen}. -@end deffn -@subsubsection The Network Database - -The following functions accept an object representing a network -and return a selected component: - -@deffn procedure netent:name net -The "official" network name. -@end deffn -@deffn procedure netent:aliases net -A list of aliases for the network. -@end deffn -@deffn procedure netent:addrtype net -The type of the network number. Currently, this returns only -@code{AF_INET}. -@end deffn -@deffn procedure netent:net net -The network number. -@end deffn - -The following procedures are used to search the network database: - -@deffn primitive getnet [net] -@deffnx procedure getnetbyname net-name -@deffnx procedure getnetbyaddr net-number -Look up a network by name or net number in the network database. The -@var{net-name} argument must be a string, and the @var{net-number} -argument must be an integer. @code{getnet} will accept either type of -argument, behaving like @code{getnetent} (see below) if no arguments are -given. -@end deffn - -The following procedures may be used to step through the network -database from beginning to end. - -@deffn procedure setnetent [stayopen] -Initialize an internal stream from which network objects may be read. This -procedure must be called before any calls to @code{getnetent}, and may -also be called afterward to reset the net entry stream. If -@var{stayopen} is supplied and is not @code{#f}, the database is not -closed by subsequent @code{getnetbyname} or @code{getnetbyaddr} calls, -possibly giving an efficiency gain. -@end deffn - -@deffn procedure getnetent -Return the next entry from the network database. -@end deffn - -@deffn procedure endnetent -Close the stream used by @code{getnetent}. The return value is unspecified. -@end deffn - -@deffn primitive setnet [stayopen] -If @var{stayopen} is omitted, this is equivalent to @code{endnetent}. -Otherwise it is equivalent to @code{setnetent stayopen}. -@end deffn - -@subsubsection The Protocol Database - -The following functions accept an object representing a protocol -and return a selected component: - -@deffn procedure protoent:name protocol -The "official" protocol name. -@end deffn -@deffn procedure protoent:aliases protocol -A list of aliases for the protocol. -@end deffn -@deffn procedure protoent:proto protocol -The protocol number. -@end deffn - -The following procedures are used to search the protocol database: - -@deffn primitive getproto [protocol] -@deffnx procedure getprotobyname name -@deffnx procedure getprotobynumber number -Look up a network protocol by name or by number. @code{getprotobyname} -takes a string argument, and @code{getprotobynumber} takes an integer -argument. @code{getproto} will accept either type, behaving like -@code{getprotoent} (see below) if no arguments are supplied. -@end deffn - -The following procedures may be used to step through the protocol -database from beginning to end. - -@deffn procedure setprotoent [stayopen] -Initialize an internal stream from which protocol objects may be read. This -procedure must be called before any calls to @code{getprotoent}, and may -also be called afterward to reset the protocol entry stream. If -@var{stayopen} is supplied and is not @code{#f}, the database is not -closed by subsequent @code{getprotobyname} or @code{getprotobynumber} calls, -possibly giving an efficiency gain. -@end deffn - -@deffn procedure getprotoent -Return the next entry from the protocol database. -@end deffn - -@deffn procedure endprotoent -Close the stream used by @code{getprotoent}. The return value is unspecified. -@end deffn - -@deffn primitive setproto [stayopen] -If @var{stayopen} is omitted, this is equivalent to @code{endprotoent}. -Otherwise it is equivalent to @code{setprotoent stayopen}. -@end deffn - -@subsubsection The Service Database - -The following functions accept an object representing a service -and return a selected component: - -@deffn procedure servent:name serv -The "official" name of the network service. -@end deffn -@deffn procedure servent:aliases serv -A list of aliases for the network service. -@end deffn -@deffn procedure servent:port serv -The Internet port used by the service. -@end deffn -@deffn procedure servent:proto serv -The protocol used by the service. A service may be listed many times -in the database under different protocol names. -@end deffn - -The following procedures are used to search the service database: - -@deffn primitive getserv [name [protocol]] -@deffnx procedure getservbyname name protocol -@deffnx procedure getservbyport port protocol -Look up a network service by name or by service number, and return a -network service object. The @var{protocol} argument specifies the name -of the desired protocol; if the protocol found in the network service -database does not match this name, a system error is signalled. - -The @code{getserv} procedure will take either a service name or number -as its first argument; if given no arguments, it behaves like -@code{getservent} (see below). -@end deffn - -The following procedures may be used to step through the service -database from beginning to end. - -@deffn procedure setservent [stayopen] -Initialize an internal stream from which service objects may be read. This -procedure must be called before any calls to @code{getservent}, and may -also be called afterward to reset the service entry stream. If -@var{stayopen} is supplied and is not @code{#f}, the database is not -closed by subsequent @code{getservbyname} or @code{getservbyport} calls, -possibly giving an efficiency gain. -@end deffn - -@deffn procedure getservent -Return the next entry from the services database. -@end deffn - -@deffn procedure endservent -Close the stream used by @code{getservent}. The return value is unspecified. -@end deffn - -@deffn primitive setserv [stayopen] -If @var{stayopen} is omitted, this is equivalent to @code{endservent}. -Otherwise it is equivalent to @code{setservent stayopen}. -@end deffn - -@node Network Sockets and Communication -@subsection Network Sockets and Communication - -Socket ports can be created using @code{socket} and @code{socketpair}. -The ports are initially unbuffered, to make reading and writing to the -same port more reliable. A buffer can be added to the port using -@code{setvbuf}, @xref{Ports and File Descriptors}. - -The convention used for "host" vs "network" addresses is that addresses -are always held in host order at the Scheme level. The procedures in -this section automatically convert between host and network order when -required. The arguments and return values are thus in host order. - -@deffn primitive socket family style proto -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{AF_UNIX}, @code{AF_INET} and @code{AF_INET6}. -Typical values for @var{style} are @code{SOCK_STREAM}, -@code{SOCK_DGRAM} and @code{SOCK_RAW}. - -@var{proto} can be obtained from a protocol name using -@code{getprotobyname}. A value of zero specifies the default -protocol, which is usually right. - -A single socket port cannot by used for communication until it -has been connected to another socket. -@end deffn - -@deffn primitive 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}. -@end deffn - -@deffn primitive getsockopt sock level optname -Return the value of a particular socket option for the socket -port @var{sock}. @var{level} is an integer code for type of -option being requested, e.g., @code{SOL_SOCKET} for -socket-level options. @var{optname} is an integer code for the -option required and should be specified using one of the -symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc. - -The returned value is typically an integer but @code{SO_LINGER} -returns a pair of integers. -@end deffn - -@deffn primitive setsockopt sock level optname value -Set the value of a particular socket option for the socket -port @var{sock}. @var{level} is an integer code for type of option -being set, e.g., @code{SOL_SOCKET} for socket-level options. -@var{optname} is an -integer code for the option to set and should be specified using one of -the symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc. -@var{value} is the value to which the option should be set. For -most options this must be an integer, but for @code{SO_LINGER} it must -be a pair. - -The return value is unspecified. -@end deffn - -@deffn primitive shutdown sock how -Sockets can be closed simply by using @code{close-port}. The -@code{shutdown} procedure allows reception or tranmission on a -connection to be shut down individually, according to the parameter -@var{how}: - -@table @asis -@item 0 -Stop receiving data for this socket. If further data arrives, reject it. -@item 1 -Stop trying to transmit data from this socket. Discard any -data waiting to be sent. Stop looking for acknowledgement of -data already sent; don't retransmit it if it is lost. -@item 2 -Stop both reception and transmission. -@end table - -The return value is unspecified. -@end deffn - -@deffn primitive connect sock fam address . args -Initiate a connection from a socket using a specified address -family to the address -specified by @var{address} and possibly @var{args}. -The format required for @var{address} -and @var{args} depends on the family of the socket. - -For a socket of family @code{AF_UNIX}, -only @var{address} is specified and must be a string with the -filename where the socket is to be created. - -For a socket of family @code{AF_INET}, -@var{address} must be an integer IPv4 host address and -@var{args} must be a single integer port number. - -For a socket of family @code{AF_INET6}, -@var{address} must be an integer IPv6 host address and -@var{args} may be up to three integers: -port [flowinfo] [scope_id], -where flowinfo and scope_id default to zero. - -The return value is unspecified. -@end deffn - -@deffn primitive bind sock fam address . args -Assign an address to the socket port @var{sock}. -Generally this only needs to be done for server sockets, -so they know where to look for incoming connections. A socket -without an address will be assigned one automatically when it -starts communicating. - -The format of @var{address} and @var{args} depends -on the family of the socket. - -For a socket of family @code{AF_UNIX}, only @var{address} -is specified and must be a string with the filename where -the socket is to be created. - -For a socket of family @code{AF_INET}, @var{address} -must be an integer IPv4 address and @var{args} -must be a single integer port number. - -The values of the following variables can also be used for -@var{address}: - -@defvar INADDR_ANY -Allow connections from any address. -@end defvar - -@defvar INADDR_LOOPBACK -The address of the local host using the loopback device. -@end defvar - -@defvar INADDR_BROADCAST -The broadcast address on the local network. -@end defvar - -@defvar INADDR_NONE -No address. -@end defvar - -For a socket of family @code{AF_INET6}, @var{address} -must be an integer IPv6 address and @var{args} -may be up to three integers: -port [flowinfo] [scope_id], -where flowinfo and scope_id default to zero. - -The return value is unspecified. -@end deffn - -@deffn primitive listen sock backlog -Enable @var{sock} to accept connection -requests. @var{backlog} is an integer specifying -the maximum length of the queue for pending connections. -If the queue fills, new clients will fail to connect until -the server calls @code{accept} to accept a connection from -the queue. - -The return value is unspecified. -@end deffn - -@deffn primitive accept sock -Accept a connection on a bound, listening socket. -If there -are no pending connections in the queue, wait until -one is available unless the non-blocking option has been -set on the socket. - -The return value is a -pair in which the @emph{car} is a new socket port for the -connection and -the @emph{cdr} is an object with address information about the -client which initiated the connection. - -@var{sock} does not become part of the -connection and will continue to accept new requests. -@end deffn - -The following functions take a socket address object, as returned -by @code{accept} and other procedures, and return a selected component. - -@table @code -@item sockaddr:fam -The socket family, typically equal to the value of @code{AF_UNIX} or -@code{AF_INET}. -@item sockaddr:path -If the socket family is @code{AF_UNIX}, returns the path of the -filename the socket is based on. -@item sockaddr:addr -If the socket family is @code{AF_INET}, returns the Internet host -address. -@item sockaddr:port -If the socket family is @code{AF_INET}, returns the Internet port -number. -@end table - -@deffn primitive getsockname sock -Return the address of @var{sock}, in the same form as the -object returned by @code{accept}. On many systems the address -of a socket in the @code{AF_FILE} namespace cannot be read. -@end deffn - -@deffn primitive getpeername sock -Return the address that @var{sock} -is connected to, in the same form as the object returned by -@code{accept}. On many systems the address of a socket in the -@code{AF_FILE} namespace cannot be read. -@end deffn - -@deffn primitive recv! sock buf [flags] -Receive data from a socket port. -@var{sock} must already -be bound to the address from which data is to be received. -@var{buf} is a string into which -the data will be written. The size of @var{buf} limits -the amount of -data which can be received: in the case of packet -protocols, if a packet larger than this limit is encountered -then some data -will be irrevocably lost. - -The optional @var{flags} argument is a value or -bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc. - -The value returned is the number of bytes read from the -socket. - -Note that the data is read directly from the socket file -descriptor: -any unread buffered port data is ignored. -@end deffn - -@deffn primitive send sock message [flags] -Transmit the string @var{message} on a socket port @var{sock}. -@var{sock} must already be bound to a destination address. The -value returned is the number of bytes transmitted -- -it's possible for -this to be less than the length of @var{message} -if the socket is -set to be non-blocking. The optional @var{flags} argument -is a value or -bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc. - -Note that the data is written directly to the socket -file descriptor: -any unflushed buffered port data is ignored. -@end deffn - -@deffn primitive recvfrom! sock str [flags [start [end]]] -Return data from the socket port @var{sock} and also -information about where the data was received from. -@var{sock} must already be bound to the address from which -data is to be received. @code{str}, is a string into which the -data will be written. The size of @var{str} limits the amount -of data which can be received: in the case of packet protocols, -if a packet larger than this limit is encountered then some -data will be irrevocably lost. - -The optional @var{flags} argument is a value or bitwise OR of -@code{MSG_OOB}, @code{MSG_PEEK}, @code{MSG_DONTROUTE} etc. - -The value returned is a pair: the @emph{car} is the number of -bytes read from the socket and the @emph{cdr} an address object -in the same form as returned by @code{accept}. The address -will given as @code{#f} if not available, as is usually the -case for stream sockets. - -The @var{start} and @var{end} arguments specify a substring of -@var{str} to which the data should be written. - -Note that the data is read directly from the socket file -descriptor: any unread buffered port data is ignored. -@end deffn - -@deffn primitive sendto sock message fam address . args_and_flags -Transmit the string @var{message} on the socket port -@var{sock}. The -destination address is specified using the @var{fam}, -@var{address} and -@var{args_and_flags} arguments, in a similar way to the -@code{connect} procedure. @var{args_and_flags} contains -the usual connection arguments optionally followed by -a flags argument, which is a value or -bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc. - -The value returned is the number of bytes transmitted -- -it's possible for -this to be less than the length of @var{message} if the -socket is -set to be non-blocking. -Note that the data is written directly to the socket -file descriptor: -any unflushed buffered port data is ignored. -@end deffn - -The following functions can be used to convert short and long integers -between "host" and "network" order. Although the procedures above do -this automatically for addresses, the conversion will still need to -be done when sending or receiving encoded integer data from the network. - -@deffn primitive htons value -Convert a 16 bit quantity from host to network byte ordering. -@var{value} is packed into 2 bytes, which are then converted -and returned as a new integer. -@end deffn - -@deffn primitive ntohs value -Convert a 16 bit quantity from network to host byte ordering. -@var{value} is packed into 2 bytes, which are then converted -and returned as a new integer. -@end deffn - -@deffn primitive htonl value -Convert a 32 bit quantity from host to network byte ordering. -@var{value} is packed into 4 bytes, which are then converted -and returned as a new integer. -@end deffn - -@deffn primitive ntohl value -Convert a 32 bit quantity from network to host byte ordering. -@var{value} is packed into 4 bytes, which are then converted -and returned as a new integer. -@end deffn - -These procedures are inconvenient to use at present, but consider: - -@example -(define write-network-long - (lambda (value port) - (let ((v (make-uniform-vector 1 1 0))) - (uniform-vector-set! v 0 (htonl value)) - (uniform-vector-write v port)))) - -(define read-network-long - (lambda (port) - (let ((v (make-uniform-vector 1 1 0))) - (uniform-vector-read! v port) - (ntohl (uniform-vector-ref v 0))))) -@end example - -@node System Identification -@section System Identification - -This section lists the various procedures Guile provides for accessing -information about the system it runs on. - -@deffn primitive uname -Return an object with some information about the computer -system the program is running on. -@end deffn - -The following procedures accept an object as returned by @code{uname} -and return a selected component. - -@table @code -@item utsname:sysname -The name of the operating system. -@item utsname:nodename -The network name of the computer. -@item utsname:release -The current release level of the operating system implementation. -@item utsname:version -The current version level within the release of the operating system. -@item utsname:machine -A description of the hardware. -@end table - -@deffn primitive gethostname -Return the host name of the current processor. -@end deffn - -@deffn primitive sethostname name -Set the host name of the current processor to @var{name}. May -only be used by the superuser. The return value is not -specified. -@end deffn - -@c FIXME::martin: Not in libguile! -@deffn primitive software-type -Return a symbol describing the current platform's operating system. -This may be one of AIX, VMS, UNIX, COHERENT, WINDOWS, MS-DOS, OS/2, -THINKC, AMIGA, ATARIST, MACH, or ACORN. - -Note that most varieties of Unix are considered to be simply "UNIX". -That is because when a program depends on features that are not present -on every operating system, it is usually better to test for the presence -or absence of that specific feature. The return value of -@code{software-type} should only be used for this purpose when there is -no other easy or unambiguous way of detecting such features. -@end deffn - -@node Locales -@section Locales - -@deffn primitive setlocale category [locale] -If @var{locale} is omitted, return the current value of the -specified locale category as a system-dependent string. -@var{category} should be specified using the values -@code{LC_COLLATE}, @code{LC_ALL} etc. - -Otherwise the specified locale category is set to the string -@var{locale} and the new value is returned as a -system-dependent string. If @var{locale} is an empty string, -the locale will be set using envirionment variables. -@end deffn - -@node Encryption -@section Encryption - -Please note that the procedures in this section are not suited for -strong encryption, they are only interfaces to the well-known and -common system library functions of the same name. They are just as good -(or bad) as the underlying functions, so you should refer to your system -documentation before using them. - -@deffn primitive crypt key salt -Encrypt @var{key} using @var{salt} as the salt value to the -crypt(3) library call -@end deffn - -@code{getpass} is no encryption procedure at all, but it is often used -in compination with @code{crypt}, that is why it appears in this -section. - -@deffn primitive getpass prompt -Display @var{prompt} to the standard error output and read -a password from @file{/dev/tty}. If this file is not -accessible, it reads from standard input. The password may be -up to 127 characters in length. Additional characters and the -terminating newline character are discarded. While reading -the password, echoing and the generation of signals by special -characters is disabled. -@end deffn From 61921779a92a26d70f5c6d4e49f85a239353a345 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 19 Jul 2001 17:58:37 +0000 Subject: [PATCH 1516/2047] *** empty log message *** --- doc/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/doc/ChangeLog b/doc/ChangeLog index 618f754bd..4f5660483 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,7 @@ +2001-07-19 Rob Browning + + * posix.texi (Signals): add docs for setitimer and getitimer. + 2001-07-11 Gary Houston * scheme-evaluation.texi: Added `load-from-path'. Corrected `load': From 12ce651a811ce981123d97b3a9452eec38ebb0f4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 19 Jul 2001 20:22:12 +0000 Subject: [PATCH 1517/2047] * guile-config.in, Makefile.am: Updated copyright notice. --- guile-config/ChangeLog | 4 ++++ guile-config/Makefile.am | 2 +- guile-config/guile-config.in | 2 +- 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/guile-config/ChangeLog b/guile-config/ChangeLog index f163f4ffe..a9920b31e 100644 --- a/guile-config/ChangeLog +++ b/guile-config/ChangeLog @@ -1,3 +1,7 @@ +2001-07-18 Martin Grabmueller + + * guile-config.in, Makefile.am: Updated copyright notice. + 2001-05-28 Gary Houston * Makefile.am: let guile-config depend on libguile/libpath.h, diff --git a/guile-config/Makefile.am b/guile-config/Makefile.am index 7a39b5c12..19c7a6fbf 100644 --- a/guile-config/Makefile.am +++ b/guile-config/Makefile.am @@ -1,7 +1,7 @@ ## Process this file with Automake to create Makefile.in ## Jim Blandy --- September 1997 ## -## Copyright (C) 1998, 1999 Free Software Foundation, Inc. +## Copyright (C) 1998, 1999, 2001 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## diff --git a/guile-config/guile-config.in b/guile-config/guile-config.in index 0e917889c..54ed9772e 100644 --- a/guile-config/guile-config.in +++ b/guile-config/guile-config.in @@ -4,7 +4,7 @@ ;;;; guile-config --- utility for linking programs with Guile ;;;; Jim Blandy --- September 1997 ;;;; -;;;; Copyright (C) 1998 Free Software Foundation, Inc. +;;;; Copyright (C) 1998, 2001 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 9cc64c3ea359c6798b26c365c22f8ac610ca1b05 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 19 Jul 2001 20:23:03 +0000 Subject: [PATCH 1518/2047] * Makefile.am, readline.scm: Updated copyright notice. --- guile-readline/ChangeLog | 4 ++++ guile-readline/Makefile.am | 2 +- guile-readline/readline.scm | 2 +- 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 1c56ddff2..e431af5bf 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,7 @@ +2001-07-18 Martin Grabmueller + + * Makefile.am, readline.scm: Updated copyright notice. + 2001-07-09 Thien-Thi Nguyen * readline.c: Remove "face-lift" comment. diff --git a/guile-readline/Makefile.am b/guile-readline/Makefile.am index 0b3038f45..1094501e9 100644 --- a/guile-readline/Makefile.am +++ b/guile-readline/Makefile.am @@ -1,6 +1,6 @@ ## Process this file with Automake to create Makefile.in ## -## Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. +## Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## diff --git a/guile-readline/readline.scm b/guile-readline/readline.scm index f2960fac6..24f9de58f 100644 --- a/guile-readline/readline.scm +++ b/guile-readline/readline.scm @@ -1,6 +1,6 @@ ;;;; readline.scm --- support functions for command-line editing ;;;; -;;;; Copyright (C) 1997, 1999, 2000 Free Software Foundation, Inc. +;;;; Copyright (C) 1997, 1999, 2000, 2001 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 e39bbe80b6b305bf61c154c0376052a94fd0dbee Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 19 Jul 2001 20:24:49 +0000 Subject: [PATCH 1519/2047] * and-let-star.scm, debug.scm, debugger.scm, history.scm, lineio.scm, null.scm, optargs.scm, r4rs.scm, r5rs.scm, receive.scm, safe-r5rs.scm, streams.scm: Updated copyright notice. --- ice-9/ChangeLog | 6 ++++++ ice-9/and-let-star.scm | 2 +- ice-9/debug.scm | 2 +- ice-9/debugger.scm | 2 +- ice-9/history.scm | 2 +- ice-9/lineio.scm | 2 +- ice-9/null.scm | 2 +- ice-9/optargs.scm | 2 +- ice-9/r4rs.scm | 2 +- ice-9/r5rs.scm | 2 +- ice-9/receive.scm | 2 +- ice-9/safe-r5rs.scm | 2 +- ice-9/streams.scm | 2 +- 13 files changed, 18 insertions(+), 12 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 90535775c..b3b7233a9 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,9 @@ +2001-07-18 Martin Grabmueller + + * and-let-star.scm, debug.scm, debugger.scm, history.scm, + lineio.scm, null.scm, optargs.scm, r4rs.scm, r5rs.scm, + receive.scm, safe-r5rs.scm, streams.scm: Updated copyright notice. + 2001-07-17 Martin Grabmueller * r5rs.scm: Use `re-export' instead of `export' for re-exported diff --git a/ice-9/and-let-star.scm b/ice-9/and-let-star.scm index c2d7f6002..61765f910 100644 --- a/ice-9/and-let-star.scm +++ b/ice-9/and-let-star.scm @@ -1,7 +1,7 @@ ;;;; and-let-star.scm --- and-let* syntactic form (draft SRFI-2) for Guile ;;;; written by Michael Livshin ;;;; -;;;; Copyright (C) 1999 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001 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 diff --git a/ice-9/debug.scm b/ice-9/debug.scm index 0c25e5c70..bec2068b8 100644 --- a/ice-9/debug.scm +++ b/ice-9/debug.scm @@ -1,4 +1,4 @@ -;;;; Copyright (C) 1996, 1997, 1998, 1999 Free Software Foundation +;;;; Copyright (C) 1996, 1997, 1998, 1999, 2001 Free Software Foundation ;;;; ;;;; 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 diff --git a/ice-9/debugger.scm b/ice-9/debugger.scm index 16b6d81b5..3bf29ab75 100644 --- a/ice-9/debugger.scm +++ b/ice-9/debugger.scm @@ -1,6 +1,6 @@ ;;;; Guile Debugger -;;; Copyright (C) 1999 Free Software Foundation, Inc. +;;; Copyright (C) 1999, 2001 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 diff --git a/ice-9/history.scm b/ice-9/history.scm index 66bb7a8cc..6ff1b25a5 100644 --- a/ice-9/history.scm +++ b/ice-9/history.scm @@ -1,4 +1,4 @@ -;;;; Copyright (C) 2000 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001 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 diff --git a/ice-9/lineio.scm b/ice-9/lineio.scm index fda97d530..b45cf0d52 100644 --- a/ice-9/lineio.scm +++ b/ice-9/lineio.scm @@ -1,6 +1,6 @@ ;;; installed-scm-file -;;;; Copyright (C) 1996, 1998 Free Software Foundation, Inc. +;;;; Copyright (C) 1996, 1998, 2001 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 diff --git a/ice-9/null.scm b/ice-9/null.scm index 594f3d79f..30f785a4f 100644 --- a/ice-9/null.scm +++ b/ice-9/null.scm @@ -1,4 +1,4 @@ -;;;; Copyright (C) 2000 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001 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 diff --git a/ice-9/optargs.scm b/ice-9/optargs.scm index fd4db654b..a64ca9cd8 100644 --- a/ice-9/optargs.scm +++ b/ice-9/optargs.scm @@ -1,6 +1,6 @@ ;;;; optargs.scm -- support for optional arguments ;;;; -;;;; Copyright (C) 1997, 1998, 1999 Free Software Foundation, Inc. +;;;; Copyright (C) 1997, 1998, 1999, 2001 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 diff --git a/ice-9/r4rs.scm b/ice-9/r4rs.scm index f81833288..66a3952b8 100644 --- a/ice-9/r4rs.scm +++ b/ice-9/r4rs.scm @@ -1,7 +1,7 @@ ;;;; r4rs.scm --- definitions needed for libguile to be R4RS compliant ;;;; Jim Blandy --- October 1996 -;;;; Copyright (C) 1996, 1997, 1998, 2000 Free Software Foundation, Inc. +;;;; Copyright (C) 1996, 1997, 1998, 2000, 2001 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 diff --git a/ice-9/r5rs.scm b/ice-9/r5rs.scm index faf75ae9e..73b9d0fe0 100644 --- a/ice-9/r5rs.scm +++ b/ice-9/r5rs.scm @@ -1,4 +1,4 @@ -;;;; Copyright (C) 2000 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001 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 diff --git a/ice-9/receive.scm b/ice-9/receive.scm index 257c46f0b..56e5ecc45 100644 --- a/ice-9/receive.scm +++ b/ice-9/receive.scm @@ -1,6 +1,6 @@ ;;;; SRFI-8 -;;; Copyright (C) 2000 Free Software Foundation, Inc. +;;; Copyright (C) 2000, 2001 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 diff --git a/ice-9/safe-r5rs.scm b/ice-9/safe-r5rs.scm index 0221bd1b9..b17dd57b0 100644 --- a/ice-9/safe-r5rs.scm +++ b/ice-9/safe-r5rs.scm @@ -1,4 +1,4 @@ -;;;; Copyright (C) 2000 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001 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 diff --git a/ice-9/streams.scm b/ice-9/streams.scm index d300937e6..9091b896c 100644 --- a/ice-9/streams.scm +++ b/ice-9/streams.scm @@ -1,7 +1,7 @@ ;;;; streams.scm --- general lazy streams ;;;; -*- Scheme -*- -;;;; Copyright (C) 1999 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001 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 f3a5178732b5c32dcd1b723ab2184d223bd44b7f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 19 Jul 2001 20:27:40 +0000 Subject: [PATCH 1520/2047] * goops/util.scm: Updated copyright notice. --- oop/ChangeLog | 4 ++++ oop/goops/util.scm | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/oop/ChangeLog b/oop/ChangeLog index 0947befbe..2e82f3a1c 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -1,3 +1,7 @@ +2001-07-18 Martin Grabmueller + + * goops/util.scm: Updated copyright notice. + 2001-07-17 Martin Grabmueller * goops/save.scm: Use `re-export' instead of `export' when diff --git a/oop/goops/util.scm b/oop/goops/util.scm index ebc557dff..d3d904c60 100644 --- a/oop/goops/util.scm +++ b/oop/goops/util.scm @@ -1,4 +1,4 @@ -;;;; Copyright (C) 1999, 2000 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2000, 2001 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 46a7b46f0cfe6c477c3a23f271e31665736f6da4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 19 Jul 2001 20:28:33 +0000 Subject: [PATCH 1521/2047] * srfi-11.scm, srfi-8.scm: Update copyright notice. --- srfi/ChangeLog | 4 ++++ srfi/srfi-11.scm | 2 +- srfi/srfi-8.scm | 2 +- 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 5b50721c6..2646f5e25 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,7 @@ +2001-07-18 Martin Grabmueller + + * srfi-11.scm, srfi-8.scm: Update copyright notice. + 2001-07-17 Martin Grabmueller * srfi-14.c: Okay. Now I got it. Really. This time it's fixed. diff --git a/srfi/srfi-11.scm b/srfi/srfi-11.scm index 758ef282c..de0753636 100644 --- a/srfi/srfi-11.scm +++ b/srfi/srfi-11.scm @@ -1,6 +1,6 @@ ;;;; srfi-11.scm --- SRFI-11 procedures for Guile -;;; Copyright (C) 2000 Free Software Foundation, Inc. +;;; Copyright (C) 2000, 2001 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 diff --git a/srfi/srfi-8.scm b/srfi/srfi-8.scm index 78732d445..52961ed3a 100644 --- a/srfi/srfi-8.scm +++ b/srfi/srfi-8.scm @@ -1,6 +1,6 @@ ;;;; srfi-8.scm --- SRFI-8 procedures for Guile -;;; Copyright (C) 2000 Free Software Foundation, Inc. +;;; Copyright (C) 2000, 2001 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 From 96e30d2ab2bc04fa1f9207f151cef5886e08483d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 19 Jul 2001 20:30:37 +0000 Subject: [PATCH 1522/2047] * tests/alist.test, tests/bit-operations.test, tests/common-list.test, tests/environments.test, tests/eval.test, tests/gc.test, tests/hooks.test, tests/import.test, tests/interp.test, tests/list.test, tests/load.test, tests/numbers.test, tests/ports.test, tests/r4rs.test, tests/version.test, tests/weaks.test, lib.scm, guile-test: Updated copyright notice. --- test-suite/ChangeLog | 10 ++++++++++ test-suite/guile-test | 2 +- test-suite/lib.scm | 2 +- test-suite/tests/alist.test | 2 +- test-suite/tests/bit-operations.test | 2 +- test-suite/tests/common-list.test | 2 +- test-suite/tests/environments.test | 2 +- test-suite/tests/eval.test | 2 +- test-suite/tests/gc.test | 2 +- test-suite/tests/guardians.test | 2 +- test-suite/tests/hooks.test | 2 +- test-suite/tests/import.test | 2 +- test-suite/tests/interp.test | 2 +- test-suite/tests/list.test | 2 +- test-suite/tests/load.test | 2 +- test-suite/tests/numbers.test | 2 +- test-suite/tests/ports.test | 2 +- test-suite/tests/r4rs.test | 2 +- test-suite/tests/version.test | 2 +- test-suite/tests/weaks.test | 2 +- 20 files changed, 29 insertions(+), 19 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index b54a5df3a..0aa2ad502 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,13 @@ +2001-07-18 Martin Grabmueller + + * tests/alist.test, tests/bit-operations.test, + tests/common-list.test, tests/environments.test, tests/eval.test, + tests/gc.test, tests/hooks.test, tests/import.test, + tests/interp.test, tests/list.test, tests/load.test, + tests/numbers.test, tests/ports.test, tests/r4rs.test, + tests/version.test, tests/weaks.test, lib.scm, guile-test: Updated + copyright notice. + 2001-07-16 Martin Grabmueller * tests/srfi-14.test: New file. diff --git a/test-suite/guile-test b/test-suite/guile-test index 4d9819641..a040c0da2 100755 --- a/test-suite/guile-test +++ b/test-suite/guile-test @@ -5,7 +5,7 @@ ;;;; guile-test --- run the Guile test suite ;;;; Jim Blandy --- May 1999 ;;;; -;;;; Copyright (C) 1999 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001 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 diff --git a/test-suite/lib.scm b/test-suite/lib.scm index 2ef8aee45..1084e641d 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -1,5 +1,5 @@ ;;;; test-suite/lib.scm --- generic support for testing -;;;; Copyright (C) 1999, 2000 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2000, 2001 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 diff --git a/test-suite/tests/alist.test b/test-suite/tests/alist.test index 39d676ada..c25459c53 100644 --- a/test-suite/tests/alist.test +++ b/test-suite/tests/alist.test @@ -1,5 +1,5 @@ ;;;; alist.test --- tests guile's alists -*- scheme -*- -;;;; Copyright (C) 1999 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001 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 diff --git a/test-suite/tests/bit-operations.test b/test-suite/tests/bit-operations.test index 46c9fe1b8..f319648d3 100644 --- a/test-suite/tests/bit-operations.test +++ b/test-suite/tests/bit-operations.test @@ -1,5 +1,5 @@ ;;;; bit-operations.test --- bitwise operations on numbers -*- scheme -*- -;;;; Copyright (C) 2000 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001 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 diff --git a/test-suite/tests/common-list.test b/test-suite/tests/common-list.test index 6e404f7a8..8d675da9d 100644 --- a/test-suite/tests/common-list.test +++ b/test-suite/tests/common-list.test @@ -1,5 +1,5 @@ ;;;; common-list.test --- tests guile's common list functions -*- scheme -*- -;;;; Copyright (C) 2000 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001 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 diff --git a/test-suite/tests/environments.test b/test-suite/tests/environments.test index 895850d16..507dff7fe 100644 --- a/test-suite/tests/environments.test +++ b/test-suite/tests/environments.test @@ -1,5 +1,5 @@ ;;;; environments.test -*- scheme -*- -;;;; Copyright (C) 2000 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001 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 diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index 96e3afc8d..8e94885c3 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -1,5 +1,5 @@ ;;;; eval.test --- tests guile's evaluator -*- scheme -*- -;;;; Copyright (C) 2000 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001 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 diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test index 7afeb4226..2617eff69 100644 --- a/test-suite/tests/gc.test +++ b/test-suite/tests/gc.test @@ -1,5 +1,5 @@ ;;;; gc.test --- test guile's garbage collection -*- scheme -*- -;;;; Copyright (C) 2000 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001 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 diff --git a/test-suite/tests/guardians.test b/test-suite/tests/guardians.test index 8d5a6eb2b..8fc42c2f6 100644 --- a/test-suite/tests/guardians.test +++ b/test-suite/tests/guardians.test @@ -1,7 +1,7 @@ ;;;; guardians.test --- test suite for Guile Guardians -*- scheme -*- ;;;; Jim Blandy --- July 1999 ;;;; -;;;; Copyright (C) 1999 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001 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 diff --git a/test-suite/tests/hooks.test b/test-suite/tests/hooks.test index 1f309e5f2..45398d9ff 100644 --- a/test-suite/tests/hooks.test +++ b/test-suite/tests/hooks.test @@ -1,5 +1,5 @@ ;;;; hooks.test --- tests guile's hooks implementation -*- scheme -*- -;;;; Copyright (C) 1999 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001 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 diff --git a/test-suite/tests/import.test b/test-suite/tests/import.test index 330c91a0b..f22522f8d 100644 --- a/test-suite/tests/import.test +++ b/test-suite/tests/import.test @@ -1,5 +1,5 @@ ;;;; import.test --- test selective and renaming imports -*- scheme -*- -;;;; Copyright (C) 2000 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001 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 diff --git a/test-suite/tests/interp.test b/test-suite/tests/interp.test index ac346b256..5d872759b 100644 --- a/test-suite/tests/interp.test +++ b/test-suite/tests/interp.test @@ -1,6 +1,6 @@ ;;;; interp.test --- tests for bugs in the Guile interpreter -*- scheme -*- ;;;; -;;;; Copyright (C) 1999 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001 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 diff --git a/test-suite/tests/list.test b/test-suite/tests/list.test index 746eeb8ad..04929a2cc 100644 --- a/test-suite/tests/list.test +++ b/test-suite/tests/list.test @@ -1,5 +1,5 @@ ;;;; list.test --- tests guile's lists -*- scheme -*- -;;;; Copyright (C) 2000 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001 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 diff --git a/test-suite/tests/load.test b/test-suite/tests/load.test index 473d09de2..294bd252a 100644 --- a/test-suite/tests/load.test +++ b/test-suite/tests/load.test @@ -1,7 +1,7 @@ ;;;; load.test --- test LOAD and path searching functions -*- scheme -*- ;;;; Jim Blandy --- September 1999 ;;;; -;;;; Copyright (C) 1999 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001 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 diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 139715f81..f20a37d93 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -1,5 +1,5 @@ ;;;; numbers.test --- tests guile's numbers -*- scheme -*- -;;;; Copyright (C) 2000 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001 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 diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index 6fa39cd8a..956aac191 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -1,7 +1,7 @@ ;;;; ports.test --- test suite for Guile I/O ports -*- scheme -*- ;;;; Jim Blandy --- May 1999 ;;;; -;;;; Copyright (C) 1999 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001 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 diff --git a/test-suite/tests/r4rs.test b/test-suite/tests/r4rs.test index 246bbfcfe..c9fbb1525 100644 --- a/test-suite/tests/r4rs.test +++ b/test-suite/tests/r4rs.test @@ -1,5 +1,5 @@ ;;;; r4rs.test --- tests for R4RS compliance -*- scheme -*- -;;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999 Free Software Foundation, Inc. +;;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999, 2001 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 diff --git a/test-suite/tests/version.test b/test-suite/tests/version.test index 3bf6bb6fe..79587923d 100644 --- a/test-suite/tests/version.test +++ b/test-suite/tests/version.test @@ -1,7 +1,7 @@ ;;;; versions.test --- test suite for Guile's version functions -*- scheme -*- ;;;; Greg J. Badros ;;;; -;;;; Copyright (C) 2000 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001 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 diff --git a/test-suite/tests/weaks.test b/test-suite/tests/weaks.test index b5be62da5..e66c89282 100644 --- a/test-suite/tests/weaks.test +++ b/test-suite/tests/weaks.test @@ -1,5 +1,5 @@ ;;;; weaks.test --- tests guile's weaks -*- scheme -*- -;;;; Copyright (C) 1999 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001 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 c0b2936ee9fdc24132d72562d01fd65223742081 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 19 Jul 2001 20:57:59 +0000 Subject: [PATCH 1523/2047] * INSTALL, Makefile.am, configure.in: Updated copyright notice. --- ChangeLog | 4 ++++ INSTALL | 2 +- Makefile.am | 2 +- configure.in | 2 +- 4 files changed, 7 insertions(+), 3 deletions(-) diff --git a/ChangeLog b/ChangeLog index 0c98e8c21..635f21c57 100644 --- a/ChangeLog +++ b/ChangeLog @@ -3,6 +3,10 @@ * configure.in: add checks for setitimer and getitimer. Add --enable-error-on-warning. +2001-07-18 Martin Grabmueller + + * INSTALL, Makefile.am, configure.in: Updated copyright notice. + 2001-07-15 Thien-Thi Nguyen * HACKING: Remove onerous authorship-info deletion clause. diff --git a/INSTALL b/INSTALL index 7e8d40d2b..fedf6dfb1 100644 --- a/INSTALL +++ b/INSTALL @@ -1,5 +1,5 @@ Guile Installation Guide -Copyright (c) 1996, 1997, 1998, 1999, 2000 Free software Foundation, Inc. +Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 Free Software Foundation, Inc. Permission is granted to anyone to make or distribute verbatim copies of this document as received, in any medium, provided that the diff --git a/Makefile.am b/Makefile.am index 561cd8885..c352d4bd1 100644 --- a/Makefile.am +++ b/Makefile.am @@ -1,6 +1,6 @@ ## Process this file with automake to produce Makefile.in. ## -## Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. +## Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## diff --git a/configure.in b/configure.in index 78a0bf7c6..90bec143d 100644 --- a/configure.in +++ b/configure.in @@ -1,7 +1,7 @@ dnl configuration script for Guile dnl Process this file with autoconf to produce configure. dnl -dnl Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. +dnl Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. dnl dnl This file is part of GUILE dnl From 58ade1022ca491dbb86565aa4e514089ec6fcabd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 19 Jul 2001 21:08:49 +0000 Subject: [PATCH 1524/2047] * alist.c, arbiters.c, async.h, backtrace.h, boolean.c, chars.c, chars.h, continuations.h, debug-malloc.h, dynl.c, feature.c, feature.h, filesys.h, fluids.h, fports.h, gc_os_dep.c, gdb_interface.h, gh_eval.c, gh_funcs.c, gh_io.c, gh_list.c, gh_predicates.c, gsubr.c, gsubr.h, guardians.h, guile-func-name-check.in, guile-snarf-docs-texi.in, guile-snarf-docs.in, guile-snarf.awk.in, guile-snarf.in, hashtab.h, iselect.h, keywords.h, lang.c, list.h, load.h, objprop.c, objprop.h, options.c, options.h, random.h, regex-posix.h, root.c, root.h, script.c, snarf.h, stackchk.c, strerror.c, strop.h, strports.h, threads.h, values.c, values.h, version.c, version.h: Updated copyright notice. --- libguile/ChangeLog | 15 +++++++++++++++ libguile/alist.c | 2 +- libguile/arbiters.c | 2 +- libguile/async.h | 2 +- libguile/backtrace.h | 2 +- libguile/boolean.c | 2 +- libguile/chars.c | 2 +- libguile/chars.h | 2 +- libguile/continuations.h | 2 +- libguile/debug-malloc.h | 2 +- libguile/dynl.c | 2 +- libguile/feature.c | 2 +- libguile/feature.h | 2 +- libguile/filesys.h | 2 +- libguile/fluids.h | 2 +- libguile/fports.h | 2 +- libguile/gc_os_dep.c | 2 +- libguile/gdb_interface.h | 2 +- libguile/gh_eval.c | 2 +- libguile/gh_funcs.c | 2 +- libguile/gh_io.c | 2 +- libguile/gh_list.c | 2 +- libguile/gh_predicates.c | 2 +- libguile/gsubr.c | 2 +- libguile/gsubr.h | 2 +- libguile/guardians.h | 2 +- libguile/guile-func-name-check.in | 2 +- libguile/guile-snarf-docs-texi.in | 2 +- libguile/guile-snarf-docs.in | 2 +- libguile/guile-snarf.awk.in | 2 +- libguile/guile-snarf.in | 2 +- libguile/hashtab.h | 2 +- libguile/iselect.h | 2 +- libguile/keywords.h | 2 +- libguile/lang.c | 2 +- libguile/list.h | 2 +- libguile/load.h | 2 +- libguile/objprop.c | 2 +- libguile/objprop.h | 2 +- libguile/options.c | 2 +- libguile/options.h | 2 +- libguile/random.h | 2 +- libguile/regex-posix.h | 2 +- libguile/root.c | 2 +- libguile/root.h | 2 +- libguile/script.c | 2 +- libguile/snarf.h | 2 +- libguile/stackchk.c | 2 +- libguile/strerror.c | 2 +- libguile/strop.h | 2 +- libguile/strports.h | 2 +- libguile/threads.h | 2 +- libguile/values.c | 2 +- libguile/values.h | 2 +- libguile/version.c | 2 +- libguile/version.h | 2 +- 56 files changed, 70 insertions(+), 55 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 56abc6eda..d94097fec 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -13,6 +13,21 @@ * scmsigs.c (s_scm_setitimer): new function. (s_scm_setitimer): new function. +2001-07-18 Martin Grabmueller + + * alist.c, arbiters.c, async.h, backtrace.h, boolean.c, chars.c, + chars.h, continuations.h, debug-malloc.h, dynl.c, feature.c, + feature.h, filesys.h, fluids.h, fports.h, gc_os_dep.c, + gdb_interface.h, gh_eval.c, gh_funcs.c, gh_io.c, gh_list.c, + gh_predicates.c, gsubr.c, gsubr.h, guardians.h, + guile-func-name-check.in, guile-snarf-docs-texi.in, + guile-snarf-docs.in, guile-snarf.awk.in, guile-snarf.in, + hashtab.h, iselect.h, keywords.h, lang.c, list.h, load.h, + objprop.c, objprop.h, options.c, options.h, random.h, + regex-posix.h, root.c, root.h, script.c, snarf.h, stackchk.c, + strerror.c, strop.h, strports.h, threads.h, values.c, values.h, + version.c, version.h: Updated copyright notice. + 2001-07-17 Dirk Herrmann * goops.c (sym_layout, sym_vcell, sym_vtable, sym_print, diff --git a/libguile/alist.c b/libguile/alist.c index 0b2e81557..e2fa86068 100644 --- a/libguile/alist.c +++ b/libguile/alist.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 96, 97, 98, 99, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001 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 diff --git a/libguile/arbiters.c b/libguile/arbiters.c index 7bd92caa8..a6d17ca80 100644 --- a/libguile/arbiters.c +++ b/libguile/arbiters.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996, 1997, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996, 1997, 2000, 2001 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 diff --git a/libguile/async.h b/libguile/async.h index 4a5afd59f..15a1841cb 100644 --- a/libguile/async.h +++ b/libguile/async.h @@ -2,7 +2,7 @@ #ifndef SCM_ASYNC_H #define SCM_ASYNC_H -/* Copyright (C) 1995, 96, 97, 98, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995, 96, 97, 98, 2000, 2001 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 diff --git a/libguile/backtrace.h b/libguile/backtrace.h index 0bc8c0803..db0cd8dc5 100644 --- a/libguile/backtrace.h +++ b/libguile/backtrace.h @@ -2,7 +2,7 @@ #ifndef BACKTRACEH #define BACKTRACEH -/* Copyright (C) 1996, 1998, 1999, 2000 Free Software Foundation +/* Copyright (C) 1996, 1998, 1999, 2000, 2001 Free Software Foundation * * 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 diff --git a/libguile/boolean.c b/libguile/boolean.c index cea294c62..da56aab54 100644 --- a/libguile/boolean.c +++ b/libguile/boolean.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 2000, 2001 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 diff --git a/libguile/chars.c b/libguile/chars.c index a8967b99f..229da4b35 100644 --- a/libguile/chars.c +++ b/libguile/chars.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998, 2000, 2001 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 diff --git a/libguile/chars.h b/libguile/chars.h index 7339f0255..65cc079d2 100644 --- a/libguile/chars.h +++ b/libguile/chars.h @@ -2,7 +2,7 @@ #ifndef SCM_CHARSH #define SCM_CHARSH -/* Copyright (C) 1995,1996, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996, 2000, 2001 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 diff --git a/libguile/continuations.h b/libguile/continuations.h index 85002ae44..2c67d78a5 100644 --- a/libguile/continuations.h +++ b/libguile/continuations.h @@ -2,7 +2,7 @@ #ifndef CONTINUATIONSH #define CONTINUATIONSH -/* Copyright (C) 1995,1996, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996, 2000, 2001 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 diff --git a/libguile/debug-malloc.h b/libguile/debug-malloc.h index b31b3191e..29e465bc0 100644 --- a/libguile/debug-malloc.h +++ b/libguile/debug-malloc.h @@ -2,7 +2,7 @@ #ifndef DEBUGMALLOCH #define DEBUGMALLOCH -/* Copyright (C) 2000 Free Software Foundation, Inc. +/* Copyright (C) 2000, 2001 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 diff --git a/libguile/dynl.c b/libguile/dynl.c index 1e9d2718a..70d36341f 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -1,6 +1,6 @@ /* dynl.c - dynamic linking * - * Copyright (C) 1990, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000 Free Software Foundation, Inc. + * Copyright (C) 1990, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 2001 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 diff --git a/libguile/feature.c b/libguile/feature.c index 108cfdd61..30f5325c3 100644 --- a/libguile/feature.c +++ b/libguile/feature.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001 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 diff --git a/libguile/feature.h b/libguile/feature.h index c22325917..dcde6803f 100644 --- a/libguile/feature.h +++ b/libguile/feature.h @@ -2,7 +2,7 @@ #ifndef FEATUREH #define FEATUREH -/* Copyright (C) 1995, 1996, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1999, 2000, 2001 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 diff --git a/libguile/filesys.h b/libguile/filesys.h index e0820044b..ee845b743 100644 --- a/libguile/filesys.h +++ b/libguile/filesys.h @@ -2,7 +2,7 @@ #ifndef FILESYSH #define FILESYSH -/* Copyright (C) 1995,1997,1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1997,1998, 1999, 2000, 2001 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 diff --git a/libguile/fluids.h b/libguile/fluids.h index 60c7a879f..acc6bebb4 100644 --- a/libguile/fluids.h +++ b/libguile/fluids.h @@ -3,7 +3,7 @@ #ifndef FLUIDSH #define FLUIDSH -/* Copyright (C) 1996, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1996, 2000, 2001 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 diff --git a/libguile/fports.h b/libguile/fports.h index a63699fe3..c8de4f2cb 100644 --- a/libguile/fports.h +++ b/libguile/fports.h @@ -2,7 +2,7 @@ #ifndef FPORTSH #define FPORTSH -/* Copyright (C) 1995,1996,1997,1998,1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999, 2000, 2001 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 diff --git a/libguile/gc_os_dep.c b/libguile/gc_os_dep.c index ab392729d..2d5a19491 100644 --- a/libguile/gc_os_dep.c +++ b/libguile/gc_os_dep.c @@ -3,7 +3,7 @@ * Copyright (c) 1991-1995 by Xerox Corporation. All rights reserved. * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. * Copyright (c) 1999 by Hewlett-Packard Company. All rights reserved. - * Copyright (c) 2000 Free Software Foundation + * Copyright (c) 2000, 2001 Free Software Foundation * * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. diff --git a/libguile/gdb_interface.h b/libguile/gdb_interface.h index fc44bc815..ad3e3af5f 100644 --- a/libguile/gdb_interface.h +++ b/libguile/gdb_interface.h @@ -1,5 +1,5 @@ /* Simple interpreter interface for GDB, the GNU debugger. - Copyright (C) 1996, 2000 Free Software Foundation + Copyright (C) 1996, 2000, 2001 Free Software Foundation This file is part of GDB. diff --git a/libguile/gh_eval.c b/libguile/gh_eval.c index 48259eff3..e1e37d527 100644 --- a/libguile/gh_eval.c +++ b/libguile/gh_eval.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998, 2000, 2001 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 diff --git a/libguile/gh_funcs.c b/libguile/gh_funcs.c index de3b97a92..74136096a 100644 --- a/libguile/gh_funcs.c +++ b/libguile/gh_funcs.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998, 2000, 2001 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 diff --git a/libguile/gh_io.c b/libguile/gh_io.c index 41ca3a724..f77cefec5 100644 --- a/libguile/gh_io.c +++ b/libguile/gh_io.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997, 2000, 2001 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 diff --git a/libguile/gh_list.c b/libguile/gh_list.c index 6935ffc4a..1330fc6ef 100644 --- a/libguile/gh_list.c +++ b/libguile/gh_list.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997, 2000, 2001 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 diff --git a/libguile/gh_predicates.c b/libguile/gh_predicates.c index 1bd234b50..8f3e081b5 100644 --- a/libguile/gh_predicates.c +++ b/libguile/gh_predicates.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997, 2000, 2001 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 diff --git a/libguile/gsubr.c b/libguile/gsubr.c index 9b3e1fbff..6fe3492a8 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998, 1999, 2000, 2001 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 diff --git a/libguile/gsubr.h b/libguile/gsubr.h index 131854c4f..fe7dcd8f5 100644 --- a/libguile/gsubr.h +++ b/libguile/gsubr.h @@ -2,7 +2,7 @@ #ifndef GSUBRH #define GSUBRH -/* Copyright (C) 1995,1996,1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998, 2000, 2001 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 diff --git a/libguile/guardians.h b/libguile/guardians.h index eb79c1305..4a0489d03 100644 --- a/libguile/guardians.h +++ b/libguile/guardians.h @@ -2,7 +2,7 @@ #ifndef SCM_GUARDIANH #define SCM_GUARDIANH -/* Copyright (C) 1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1998, 2000, 2001 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 diff --git a/libguile/guile-func-name-check.in b/libguile/guile-func-name-check.in index da1435192..adf5594e8 100644 --- a/libguile/guile-func-name-check.in +++ b/libguile/guile-func-name-check.in @@ -1,6 +1,6 @@ #!/usr/bin/awk -f # -# Copyright (C) 2000 Free Software Foundation, Inc. +# Copyright (C) 2000, 2001 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 diff --git a/libguile/guile-snarf-docs-texi.in b/libguile/guile-snarf-docs-texi.in index 587c6aff7..0aa9f9cff 100755 --- a/libguile/guile-snarf-docs-texi.in +++ b/libguile/guile-snarf-docs-texi.in @@ -1,7 +1,7 @@ #!/bin/sh # Massage the snarfed docs to texinfo. # -# Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc. +# Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 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 diff --git a/libguile/guile-snarf-docs.in b/libguile/guile-snarf-docs.in index 46c540d48..5129d7d6f 100755 --- a/libguile/guile-snarf-docs.in +++ b/libguile/guile-snarf-docs.in @@ -1,7 +1,7 @@ #!/bin/sh # Extract the doc stuff for builtin things. # -# Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc. +# Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 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 diff --git a/libguile/guile-snarf.awk.in b/libguile/guile-snarf.awk.in index 8d2e73bb3..107e4fc7d 100644 --- a/libguile/guile-snarf.awk.in +++ b/libguile/guile-snarf.awk.in @@ -1,4 +1,4 @@ -# Copyright (C) 1999, 2000 Free Software Foundation, Inc. +# Copyright (C) 1999, 2000, 2001 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 diff --git a/libguile/guile-snarf.in b/libguile/guile-snarf.in index ffb035146..3d708dbf3 100644 --- a/libguile/guile-snarf.in +++ b/libguile/guile-snarf.in @@ -1,7 +1,7 @@ #!/bin/sh # Extract the initialization actions for builtin things. # -# Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc. +# Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 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 diff --git a/libguile/hashtab.h b/libguile/hashtab.h index 785626c84..c7594a344 100644 --- a/libguile/hashtab.h +++ b/libguile/hashtab.h @@ -2,7 +2,7 @@ #ifndef HASHTABH #define HASHTABH -/* Copyright (C) 1995, 1996, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1999, 2000, 2001 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 diff --git a/libguile/iselect.h b/libguile/iselect.h index fdaedcc61..4a7971864 100644 --- a/libguile/iselect.h +++ b/libguile/iselect.h @@ -3,7 +3,7 @@ #ifndef ISELECTH #define ISELECTH -/* Copyright (C) 1997, 1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1997, 1998, 2000, 2001 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 diff --git a/libguile/keywords.h b/libguile/keywords.h index 9112abb45..13ce8cb95 100644 --- a/libguile/keywords.h +++ b/libguile/keywords.h @@ -2,7 +2,7 @@ #ifndef KEYWORDSH #define KEYWORDSH -/* Copyright (C) 1995,1996,1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1999, 2000, 2001 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 diff --git a/libguile/lang.c b/libguile/lang.c index 8ec52f74e..b5791fbbf 100644 --- a/libguile/lang.c +++ b/libguile/lang.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1999, 2000, 2001 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 diff --git a/libguile/list.h b/libguile/list.h index ba8601974..d4f2c6efb 100644 --- a/libguile/list.h +++ b/libguile/list.h @@ -2,7 +2,7 @@ #ifndef LISTH #define LISTH -/* Copyright (C) 1995,1996,1997, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997, 2000, 2001 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 diff --git a/libguile/load.h b/libguile/load.h index fbba9be08..b3c2c2e52 100644 --- a/libguile/load.h +++ b/libguile/load.h @@ -2,7 +2,7 @@ #ifndef LOADH #define LOADH -/* Copyright (C) 1995,1996,1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998, 2000, 2001 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 diff --git a/libguile/objprop.c b/libguile/objprop.c index 0e3eee7bc..4d5dd79cb 100644 --- a/libguile/objprop.c +++ b/libguile/objprop.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996, 2000, 2001 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 diff --git a/libguile/objprop.h b/libguile/objprop.h index 376991017..bc590fbe0 100644 --- a/libguile/objprop.h +++ b/libguile/objprop.h @@ -2,7 +2,7 @@ #ifndef OBJPROPH #define OBJPROPH -/* Copyright (C) 1995, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995, 2000, 2001 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 diff --git a/libguile/options.c b/libguile/options.c index 327f0aa5d..74cb820f9 100644 --- a/libguile/options.c +++ b/libguile/options.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1998, 2000 Free Software Foundation +/* Copyright (C) 1995, 1996, 1998, 2000, 2001 Free Software Foundation * * 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 diff --git a/libguile/options.h b/libguile/options.h index 899f5eed5..f8b56ef68 100644 --- a/libguile/options.h +++ b/libguile/options.h @@ -2,7 +2,7 @@ #ifndef OPTIONSH #define OPTIONSH -/* Copyright (C) 1995,1996, 2000 Free Software Foundation +/* Copyright (C) 1995,1996, 2000, 2001 Free Software Foundation * * 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 diff --git a/libguile/random.h b/libguile/random.h index 020a745bc..0901c597b 100644 --- a/libguile/random.h +++ b/libguile/random.h @@ -2,7 +2,7 @@ #ifndef RANDOMH #define RANDOMH -/* Copyright (C) 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1999, 2000, 2001 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 diff --git a/libguile/regex-posix.h b/libguile/regex-posix.h index 23416738f..798c55240 100644 --- a/libguile/regex-posix.h +++ b/libguile/regex-posix.h @@ -3,7 +3,7 @@ #ifndef REGEXPOSIXH #define REGEXPOSIXH -/* Copyright (C) 1997,1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1997,1998, 2000, 2001 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 diff --git a/libguile/root.c b/libguile/root.c index 150d66dc0..6ff24ca49 100644 --- a/libguile/root.c +++ b/libguile/root.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000, 2001 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 diff --git a/libguile/root.h b/libguile/root.h index e5a680e84..2bc3b4f20 100644 --- a/libguile/root.h +++ b/libguile/root.h @@ -3,7 +3,7 @@ #ifndef ROOTH #define ROOTH -/* Copyright (C) 1996,1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1996,1998, 2000, 2001 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 diff --git a/libguile/script.c b/libguile/script.c index ebd38c1e8..2f740659c 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -584,7 +584,7 @@ scm_compile_shell_switches (int argc, char **argv) { /* Print version number. */ printf ("Guile %s\n" - "Copyright (c) 1995, 1996, 1997, 2000 Free Software Foundation\n" + "Copyright (c) 1995, 1996, 1997, 2000, 2001 Free Software Foundation\n" "Guile may be distributed under the terms of the GNU General Public Licence;\n" "certain other uses are permitted as well. For details, see the file\n" "`COPYING', which is included in the Guile distribution.\n" diff --git a/libguile/snarf.h b/libguile/snarf.h index 36eea885e..8c03c3874 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -5,7 +5,7 @@ #ifndef LIBGUILE_SNARF_H #define LIBGUILE_SNARF_H -/* Copyright (C) 1995, 96, 97, 98, 99, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001 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 diff --git a/libguile/stackchk.c b/libguile/stackchk.c index abf6a5a55..da3ebe7f9 100644 --- a/libguile/stackchk.c +++ b/libguile/stackchk.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997, 2000, 2001 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 diff --git a/libguile/strerror.c b/libguile/strerror.c index ba43e8e6b..8c42cd2a4 100644 --- a/libguile/strerror.c +++ b/libguile/strerror.c @@ -1,5 +1,5 @@ /* Turning errno values into English error messages. - Copyright (C) 1985, 86, 87, 88, 93, 94, 95, 2000 Free Software Foundation, Inc. + Copyright (C) 1985, 86, 87, 88, 93, 94, 95, 2000, 2001 Free Software Foundation, Inc. This file is part of GNU Emacs. diff --git a/libguile/strop.h b/libguile/strop.h index 45a3ecb84..14b079849 100644 --- a/libguile/strop.h +++ b/libguile/strop.h @@ -2,7 +2,7 @@ #ifndef STROPH #define STROPH -/* Copyright (C) 1995,1996,1997, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997, 2000, 2001 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 diff --git a/libguile/strports.h b/libguile/strports.h index 5de723b8b..590aa2959 100644 --- a/libguile/strports.h +++ b/libguile/strports.h @@ -2,7 +2,7 @@ #ifndef STRPORTSH #define STRPORTSH -/* Copyright (C) 1995,1996, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996, 2000, 2001 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 diff --git a/libguile/threads.h b/libguile/threads.h index 408ce1734..1cc228594 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -3,7 +3,7 @@ #ifndef THREADSH #define THREADSH -/* Copyright (C) 1996, 1997, 1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1996, 1997, 1998, 2000, 2001 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 diff --git a/libguile/values.c b/libguile/values.c index 5aad29a89..a11b0041d 100644 --- a/libguile/values.c +++ b/libguile/values.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2000 Free Software Foundation, Inc. +/* Copyright (C) 2000, 2001 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 diff --git a/libguile/values.h b/libguile/values.h index 20777153d..1ddac9a71 100644 --- a/libguile/values.h +++ b/libguile/values.h @@ -2,7 +2,7 @@ #ifndef SCM_VALUES_H #define SCM_VALUES_H -/* Copyright (C) 2000 Free Software Foundation, Inc. +/* Copyright (C) 2000, 2001 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 diff --git a/libguile/version.c b/libguile/version.c index a3ac0d920..c74f66c56 100644 --- a/libguile/version.c +++ b/libguile/version.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996, 1999, 2000, 2001 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 diff --git a/libguile/version.h b/libguile/version.h index 15b01406f..b95254632 100644 --- a/libguile/version.h +++ b/libguile/version.h @@ -2,7 +2,7 @@ #ifndef VERSIONH #define VERSIONH -/* Copyright (C) 1995, 1996, 1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001 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 bd8398e6ef8a5deb178f39c2632e4d1a0f9fc5ea Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 21 Jul 2001 06:42:46 +0000 Subject: [PATCH 1525/2047] Remove "how to contribute" header paragraph. --- TODO | 4 ---- 1 file changed, 4 deletions(-) diff --git a/TODO b/TODO index db2903ad4..f5836ede6 100644 --- a/TODO +++ b/TODO @@ -13,10 +13,6 @@ Ownership is indicated by `[USERNAME]'. Maintainers (w/ write privs) can indicate sponsorship by `[ACTUAL-OWNER:MAINTAINER]', where both elements are usernames. -If you would like to suggest changes or contribute patches, please first email -guile-devel@gnu.org to coordinate efforts. If you distribute this file, -please include the first line and check around on the Internet for updates. - See also file HACKING. ------------------------------------------------------------------------------ From 1bed8c28a26868a64d35a6dd8d814412e3edb0ac Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sat, 21 Jul 2001 21:11:16 +0000 Subject: [PATCH 1526/2047] * scmsigs.c: include sys/time.h for itimer stuff. --- libguile/ChangeLog | 4 ++++ libguile/scmsigs.c | 4 ++++ 2 files changed, 8 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d94097fec..213f021cd 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2001-07-21 Gary Houston + + * scmsigs.c: include sys/time.h for itimer stuff. + 2001-07-19 Rob Browning * gc_os_dep.c (GC_noop1): ifdef out (unused) to quiet warning. diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index ef3e80c68..93f806a33 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -59,6 +59,10 @@ #include #endif +#ifdef HAVE_SYS_TIME_H +#include +#endif + /* The thread system has its own sleep and usleep functions. */ #ifndef USE_THREADS From 32bc3c4596f06d71cd9f09ccecbc6075a8f82883 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 22 Jul 2001 11:08:18 +0000 Subject: [PATCH 1527/2047] (autoload-info): Also handle `defmacro-public' forms. --- scripts/generate-autoload | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/scripts/generate-autoload b/scripts/generate-autoload index eef2b88c5..83fa1f3f2 100755 --- a/scripts/generate-autoload +++ b/scripts/generate-autoload @@ -38,9 +38,10 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; ;; For each file, a symbol triggers an autoload if it is found in one ;; of these situations: -;; - in the `:export' clause of a `define-module' form; -;; - in a top-level `export' or `export-syntax' form; -;; - in a `define-public' form. +;; - in the `:export' clause of a `define-module' form +;; - in a top-level `export' or `export-syntax' form +;; - in a `define-public' form +;; - in a `defmacro-public' form ;; ;; The module name is inferred from the `define-module' form. If either the ;; module name or the exports list cannot be determined, no autoload entry is @@ -100,6 +101,13 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" (loop (read p) module-name (cons (cadr form) exports))) + ((and (list? form) + (< 3 (length form)) + (eq? 'defmacro-public (car form)) + (symbol? (cadr form))) + (loop (read p) + module-name + (cons (cadr form) exports))) (else (loop (read p) module-name exports))))))) (define (generate-autoload . args) From 9977b4fb1f0e255226fe047defed6e5710d95e05 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 22 Jul 2001 11:09:23 +0000 Subject: [PATCH 1528/2047] *** empty log message *** --- scripts/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/scripts/ChangeLog b/scripts/ChangeLog index 257fdad91..b25efc2f2 100644 --- a/scripts/ChangeLog +++ b/scripts/ChangeLog @@ -1,3 +1,8 @@ +2001-07-22 Thien-Thi Nguyen + + * generate-autoload (autoload-info): + Also handle `defmacro-public' forms. + 2001-07-14 Thien-Thi Nguyen * PROGRAM, display-commentary, doc-snarf, generate-autoload, From 6a1677a396302f218b8ce82973d3f50f7d1b9487 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 22 Jul 2001 12:49:02 +0000 Subject: [PATCH 1529/2047] * regex-posix.c (s_scm_regexp_exec): use scm_long2num not SCM_MAKINUM to convert regoff_t value to SCM. --- libguile/ChangeLog | 5 +++++ libguile/regex-posix.c | 4 ++-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 213f021cd..13e56a81a 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-07-22 Gary Houston + + * regex-posix.c (s_scm_regexp_exec): use scm_long2num not + SCM_MAKINUM to convert regoff_t value to SCM. + 2001-07-21 Gary Houston * scmsigs.c: include sys/time.h for itimer stuff. diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index 1a232d59f..d5d8fba63 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -278,8 +278,8 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, SCM_VELTS(mvec)[i+1] = scm_cons (SCM_MAKINUM (-1), SCM_MAKINUM (-1)); else SCM_VELTS(mvec)[i+1] - = scm_cons(SCM_MAKINUM(matches[i].rm_so + offset), - SCM_MAKINUM(matches[i].rm_eo + offset)); + = scm_cons (scm_long2num (matches[i].rm_so + offset), + scm_long2num (matches[i].rm_eo + offset)); } scm_must_free ((char *) matches); SCM_ALLOW_INTS; From f4d1173bb3e2e0b0de40968120b7fecca67a879f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 22 Jul 2001 18:28:21 +0000 Subject: [PATCH 1530/2047] Check for "inttypes.h". --- configure.in | 1 + 1 file changed, 1 insertion(+) diff --git a/configure.in b/configure.in index 90bec143d..69656d4a6 100644 --- a/configure.in +++ b/configure.in @@ -178,6 +178,7 @@ dnl If these types don't exist on this platform, they are replaced by dnl "unsigned long" and "long", respectively. AC_CHECK_HEADERS(stdint.h) +AC_CHECK_HEADERS(inttypes.h) AC_CHECK_TYPES([uintptr_t, ptrdiff_t]) AC_CACHE_CHECK([for long longs], scm_cv_long_longs, From cda36c23561b70fb88cd1670227bd51933b38207 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 22 Jul 2001 18:30:08 +0000 Subject: [PATCH 1531/2047] * tags.h: Include inttypes.h when we have it. * tags.h (SCM_UNBOUND): Make it the 34th isym/iflag, the 33th slot is taken by the new SCM_IM_CALL_WITH_VALUES. * print.c (scm_isymnames): Update table accordingly. --- libguile/tags.h | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/libguile/tags.h b/libguile/tags.h index 7d45c66c5..9b877b7ec 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -54,6 +54,10 @@ #include #endif +#ifdef HAVE_INTTYPES_H +#include +#endif + /* In the beginning was the Word: @@ -487,7 +491,7 @@ extern char *scm_isymnames[]; /* defined in print.c */ * 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 (33) +#define SCM_UNBOUND SCM_MAKIFLAG (34) #define SCM_UNBNDP(x) (SCM_EQ_P ((x), SCM_UNDEFINED)) From 24d1fde84c208f30204d726d26847b379ef4c5ab Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 22 Jul 2001 18:30:36 +0000 Subject: [PATCH 1532/2047] * tags.h (SCM_UNBOUND): Make it the 34th isym/iflag, the 33th slot is taken by the new SCM_IM_CALL_WITH_VALUES. * print.c (scm_isymnames): Update table accordingly. --- libguile/print.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/print.c b/libguile/print.c index 82c619586..25d854fad 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -121,7 +121,8 @@ char *scm_isymnames[] = "#@bind", "#@delay", - + "#@call-with-values", + "#" }; From f3805ebb7cd244512e9f1d05c46d45df653da633 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 22 Jul 2001 18:31:11 +0000 Subject: [PATCH 1533/2047] *** empty log message *** --- ChangeLog | 4 ++++ libguile/ChangeLog | 10 ++++++++++ 2 files changed, 14 insertions(+) diff --git a/ChangeLog b/ChangeLog index 635f21c57..2aadabd3c 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2001-07-22 Marius Vollmer + + * configure.in: Check for "inttypes.h". + 2001-07-19 Rob Browning * configure.in: add checks for setitimer and getitimer. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 13e56a81a..0d72dc1b3 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,13 @@ +2001-07-22 Marius Vollmer + + * tags.h: Include inttypes.h when we have it. + +2001-07-13 Marius Vollmer + + * tags.h (SCM_UNBOUND): Make it the 34th isym/iflag, the 33th slot + is taken by the new SCM_IM_CALL_WITH_VALUES. + * print.c (scm_isymnames): Update table accordingly. + 2001-07-22 Gary Houston * regex-posix.c (s_scm_regexp_exec): use scm_long2num not From d1bc66027ef9081ab86bb7a1e5061700df022e87 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 22 Jul 2001 20:17:28 +0000 Subject: [PATCH 1534/2047] * srfi-14.c (scm_char_set_intersection, scm_char_set_xor): remove the compulsory cs1 arguments: all args are optional in final spec. * srfi-14.h: declarations updated. --- srfi/ChangeLog | 6 ++++ srfi/srfi-14.c | 76 +++++++++++++++++++++++++++++++------------------- srfi/srfi-14.h | 4 +-- 3 files changed, 56 insertions(+), 30 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 2646f5e25..e4a7440a8 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,9 @@ +2001-07-22 Gary Houston + + * srfi-14.c (scm_char_set_intersection, scm_char_set_xor): remove + the compulsory cs1 arguments: all args are optional in final spec. + * srfi-14.h: declarations updated. + 2001-07-18 Martin Grabmueller * srfi-11.scm, srfi-8.scm: Update copyright notice. diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index 7973e61d0..798f75bb5 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -1070,31 +1070,41 @@ SCM_DEFINE (scm_char_set_union, "char-set-union", 0, 0, 1, #undef FUNC_NAME -SCM_DEFINE (scm_char_set_intersection, "char-set-intersection", 1, 0, 1, - (SCM cs1, SCM rest), +SCM_DEFINE (scm_char_set_intersection, "char-set-intersection", 0, 0, 1, + (SCM rest), "Return the intersection of all argument character sets.") #define FUNC_NAME s_scm_char_set_intersection { - int c = 2; SCM res; - long * p; - SCM_VALIDATE_SMOB (1, cs1, charset); SCM_VALIDATE_REST_ARGUMENT (rest); - res = scm_char_set_copy (cs1); - p = (long *) SCM_SMOB_DATA (res); - while (!SCM_NULLP (rest)) + if (SCM_NULLP (rest)) + res = make_char_set (FUNC_NAME); + else { - int k; - SCM cs = SCM_CAR (rest); - SCM_VALIDATE_SMOB (c, cs, charset); - c++; + long *p; + int argnum = 2; + + res = scm_char_set_copy (SCM_CAR (rest)); + p = (long *) SCM_SMOB_DATA (res); rest = SCM_CDR (rest); - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] &= ((long *) SCM_SMOB_DATA (cs))[k]; + while (SCM_CONSP (rest)) + { + int k; + SCM cs = SCM_CAR (rest); + long *cs_data; + + SCM_VALIDATE_SMOB (argnum, cs, charset); + argnum++; + cs_data = (long *) SCM_SMOB_DATA (cs); + rest = SCM_CDR (rest); + for (k = 0; k < LONGS_PER_CHARSET; k++) + p[k] &= cs_data[k]; + } } + return res; } #undef FUNC_NAME @@ -1130,30 +1140,40 @@ SCM_DEFINE (scm_char_set_difference, "char-set-difference", 1, 0, 1, #undef FUNC_NAME -SCM_DEFINE (scm_char_set_xor, "char-set-xor", 1, 0, 1, - (SCM cs1, SCM rest), +SCM_DEFINE (scm_char_set_xor, "char-set-xor", 0, 0, 1, + (SCM rest), "Return the exclusive-or of all argument character sets.") #define FUNC_NAME s_scm_char_set_xor { - int c = 2; SCM res; - long * p; - SCM_VALIDATE_SMOB (1, cs1, charset); SCM_VALIDATE_REST_ARGUMENT (rest); - res = scm_char_set_copy (cs1); - p = (long *) SCM_SMOB_DATA (res); - while (!SCM_NULLP (rest)) + if (SCM_NULLP (rest)) + res = make_char_set (FUNC_NAME); + else { - int k; - SCM cs = SCM_CAR (rest); - SCM_VALIDATE_SMOB (c, cs, charset); - c++; + long * p; + int argnum = 2; + + res = scm_char_set_copy (SCM_CAR (rest)); + p = (long *) SCM_SMOB_DATA (res); rest = SCM_CDR (rest); - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] ^= ((long *) SCM_SMOB_DATA (cs))[k]; + while (SCM_CONSP (rest)) + { + int k; + SCM cs = SCM_CAR (rest); + long *cs_data; + + SCM_VALIDATE_SMOB (argnum, cs, charset); + argnum++; + cs_data = (long *) SCM_SMOB_DATA (cs); + rest = SCM_CDR (rest); + + for (k = 0; k < LONGS_PER_CHARSET; k++) + p[k] ^= cs_data[k]; + } } return res; } diff --git a/srfi/srfi-14.h b/srfi/srfi-14.h index 2621ba22f..02e74f765 100644 --- a/srfi/srfi-14.h +++ b/srfi/srfi-14.h @@ -102,9 +102,9 @@ SCM scm_char_set_adjoin_x (SCM cs, SCM rest); SCM scm_char_set_delete_x (SCM cs, SCM rest); SCM scm_char_set_complement (SCM cs); SCM scm_char_set_union (SCM rest); -SCM scm_char_set_intersection (SCM cs1, SCM rest); +SCM scm_char_set_intersection (SCM rest); SCM scm_char_set_difference (SCM cs1, SCM rest); -SCM scm_char_set_xor (SCM cs1, SCM rest); +SCM scm_char_set_xor (SCM rest); SCM scm_char_set_diff_plus_intersection (SCM cs1, SCM rest); SCM scm_char_set_complement_x (SCM cs); SCM scm_char_set_union_x (SCM cs1, SCM rest); From 42b54c05a9ba541cfe15eb071ad96b42de19d908 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 22 Jul 2001 22:01:50 +0000 Subject: [PATCH 1535/2047] (scm_char_set_xor): bug fix: characters should only be included if they occur in exactly one argument, but were included if they occured an odd number of times >= 3, e.g, in (char-set-xor a a a) where a is (char-set #\a). fix it with a "mask" array. --- srfi/ChangeLog | 5 +++++ srfi/srfi-14.c | 14 +++++++++++--- 2 files changed, 16 insertions(+), 3 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index e4a7440a8..3a3937b29 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -2,6 +2,11 @@ * srfi-14.c (scm_char_set_intersection, scm_char_set_xor): remove the compulsory cs1 arguments: all args are optional in final spec. + (scm_char_set_xor): bug fix: characters should only be included if + they occur in exactly one argument, but were included if they + occured an odd number of times >= 3, e.g, in (char-set-xor a a a) + where a is (char-set #\a). fix it with a "mask" array. + * srfi-14.h: declarations updated. 2001-07-18 Martin Grabmueller diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index 798f75bb5..8d628252a 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -1155,16 +1155,18 @@ SCM_DEFINE (scm_char_set_xor, "char-set-xor", 0, 0, 1, { long * p; int argnum = 2; + long mask[LONGS_PER_CHARSET]; + int k; + memset (mask, 0, sizeof mask); res = scm_char_set_copy (SCM_CAR (rest)); p = (long *) SCM_SMOB_DATA (res); rest = SCM_CDR (rest); while (SCM_CONSP (rest)) { - int k; SCM cs = SCM_CAR (rest); - long *cs_data; + long *cs_data; SCM_VALIDATE_SMOB (argnum, cs, charset); argnum++; @@ -1172,8 +1174,14 @@ SCM_DEFINE (scm_char_set_xor, "char-set-xor", 0, 0, 1, rest = SCM_CDR (rest); for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] ^= cs_data[k]; + { + mask[k] |= p[k] & cs_data[k]; + p[k] ^= cs_data[k]; + } } + /* avoid including characters that occur an odd number of times >= 3. */ + for (k = 0; k < LONGS_PER_CHARSET; k++) + p[k] &= ~mask[k]; } return res; } From d95744e9865c423588a884ef8effa0c4a204226a Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 22 Jul 2001 23:21:03 +0000 Subject: [PATCH 1536/2047] Reverse the n-ary logxor change. The behaviour is weird in a set context, but consistent with logxor and scsh. Maybe it should get the benefit of the doubt. --- srfi/ChangeLog | 4 ---- srfi/srfi-14.c | 14 +++----------- 2 files changed, 3 insertions(+), 15 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 3a3937b29..b287451b2 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -2,10 +2,6 @@ * srfi-14.c (scm_char_set_intersection, scm_char_set_xor): remove the compulsory cs1 arguments: all args are optional in final spec. - (scm_char_set_xor): bug fix: characters should only be included if - they occur in exactly one argument, but were included if they - occured an odd number of times >= 3, e.g, in (char-set-xor a a a) - where a is (char-set #\a). fix it with a "mask" array. * srfi-14.h: declarations updated. diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index 8d628252a..8a7a7321a 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -1153,12 +1153,9 @@ SCM_DEFINE (scm_char_set_xor, "char-set-xor", 0, 0, 1, res = make_char_set (FUNC_NAME); else { - long * p; int argnum = 2; - long mask[LONGS_PER_CHARSET]; - int k; + long * p; - memset (mask, 0, sizeof mask); res = scm_char_set_copy (SCM_CAR (rest)); p = (long *) SCM_SMOB_DATA (res); rest = SCM_CDR (rest); @@ -1167,6 +1164,7 @@ SCM_DEFINE (scm_char_set_xor, "char-set-xor", 0, 0, 1, { SCM cs = SCM_CAR (rest); long *cs_data; + int k; SCM_VALIDATE_SMOB (argnum, cs, charset); argnum++; @@ -1174,14 +1172,8 @@ SCM_DEFINE (scm_char_set_xor, "char-set-xor", 0, 0, 1, rest = SCM_CDR (rest); for (k = 0; k < LONGS_PER_CHARSET; k++) - { - mask[k] |= p[k] & cs_data[k]; - p[k] ^= cs_data[k]; - } + p[k] ^= cs_data[k]; } - /* avoid including characters that occur an odd number of times >= 3. */ - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] &= ~mask[k]; } return res; } From 9d198c1b17ffb0ce66ab3c1fd48807efdc198d22 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 23 Jul 2001 22:09:42 +0000 Subject: [PATCH 1537/2047] * syncase.scm (psyncomp): Removed, it is now in compile-psyntax.scm. * Makefile.am (psyntax.pp): Enable rule for psyntax.pp only in maintainer mode. Use compile-psyntax.scm for actual compilation. Make sure the uninstalled guile is used. (EXTRA_DIST): Distribute compile-psyntax.scm * compile-psyntax.scm: New file. --- ice-9/Makefile.am | 7 +++++-- ice-9/compile-psyntax.scm | 25 +++++++++++++++++++++++++ ice-9/syncase.scm | 16 ---------------- 3 files changed, 30 insertions(+), 18 deletions(-) create mode 100644 ice-9/compile-psyntax.scm diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index 597fa7700..e9af0558a 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -43,7 +43,10 @@ install-data-local: $(subpkgdatadir)/'and-let*.scm' ## test.scm is not currently installed. -EXTRA_DIST = $(ice9_sources) test.scm and-let-star-compat.scm +EXTRA_DIST = $(ice9_sources) test.scm and-let-star-compat.scm \ + compile-psyntax.scm +if MAINTAINER_MODE psyntax.pp: psyntax.ss - cd $(srcdir) && guile -c '(load-from-path "ice-9/syncase") (define-module (ice-9 syncase)) (psyncomp)' + GUILE_LOAD_PATH=$(srcdir)/..:.. ../libguile/guile -s compile-psyntax.scm $(srcdir)/psyntax.ss $(srcdir)/psyntax.pp +endif diff --git a/ice-9/compile-psyntax.scm b/ice-9/compile-psyntax.scm new file mode 100644 index 000000000..b96e8111b --- /dev/null +++ b/ice-9/compile-psyntax.scm @@ -0,0 +1,25 @@ +(use-modules (ice-9 syncase)) + +;; XXX - We need to be inside (ice-9 syncase) since psyntax.ss calls +;; `eval' int he `interaction-environment' aka the current module and +;; it expects to have `andmap' there. The reason for this escapes me +;; at the moment. +;; +(define-module (ice-9 syncase)) + +(define source (list-ref (command-line) 1)) +(define target (list-ref (command-line) 2)) + +(let ((in (open-input-file source)) + (out (open-output-file (string-append target ".tmp")))) + (let loop ((x (read in))) + (if (eof-object? x) + (begin + (close-port out) + (close-port in)) + (begin + (write (sc-expand3 x 'c '(compile load eval)) out) + (newline out) + (loop (read in)))))) + +(system (format #f "mv -f ~s.tmp ~s" target target)) diff --git a/ice-9/syncase.scm b/ice-9/syncase.scm index f7aca4c43..948e11b86 100644 --- a/ice-9/syncase.scm +++ b/ice-9/syncase.scm @@ -139,22 +139,6 @@ (define generated-symbols (make-weak-key-hash-table 1019)) -;;; Utilities - -(define (psyncomp) - (system "mv -f psyntax.pp psyntax.pp~") - (let ((in (open-input-file "psyntax.ss")) - (out (open-output-file "psyntax.pp"))) - (let loop ((x (read in))) - (if (eof-object? x) - (begin - (close-port out) - (close-port in)) - (begin - (write (sc-expand3 x 'c '(compile load eval)) out) - (newline out) - (loop (read in))))))) - ;;; Load the preprocessed code (let ((old-debug #f) From 6ebb9835740d934b3ab22d66a05e85e56beb8260 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 23 Jul 2001 22:10:29 +0000 Subject: [PATCH 1538/2047] (SUBDIRS): Build libguile before ice-9. --- Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile.am b/Makefile.am index c352d4bd1..a4824d826 100644 --- a/Makefile.am +++ b/Makefile.am @@ -20,7 +20,7 @@ ## 330, Boston, MA 02111-1307 USA -SUBDIRS = ice-9 oop qt libltdl libguile guile-config guile-readline \ +SUBDIRS = oop qt libltdl libguile ice-9 guile-config guile-readline \ scripts srfi doc examples bin_SCRIPTS = guile-tools From 11057044d87b5700ad4e2273bce0577dc3364e51 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 23 Jul 2001 22:10:42 +0000 Subject: [PATCH 1539/2047] *** empty log message *** --- ChangeLog | 4 ++++ ice-9/ChangeLog | 13 +++++++++++++ 2 files changed, 17 insertions(+) diff --git a/ChangeLog b/ChangeLog index 2aadabd3c..1bd7fc4e2 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2001-07-23 Marius Vollmer + + * Makefile.am (SUBDIRS): Build libguile before ice-9. + 2001-07-22 Marius Vollmer * configure.in: Check for "inttypes.h". diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index b3b7233a9..449f5327f 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,16 @@ +2001-07-24 Marius Vollmer + + * syncase.scm (psyncomp): Removed, it is now in + compile-psyntax.scm. + +2001-07-23 Marius Vollmer + + * Makefile.am (psyntax.pp): Enable rule for psyntax.pp only in + maintainer mode. Use compile-psyntax.scm for actual compilation. + Make sure the uninstalled guile is used. + (EXTRA_DIST): Distribute compile-psyntax.scm + * compile-psyntax.scm: New file. + 2001-07-18 Martin Grabmueller * and-let-star.scm, debug.scm, debugger.scm, history.scm, From e5aca4b5c428232510ea207b895e894e0295401b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Jul 2001 15:22:53 +0000 Subject: [PATCH 1540/2047] * tags.h (scm_tc7_variable): New. * gc.c (scm_gc_mark): Handle scm_tc7_variable objects. * print.c (scm_iprin1): Likewise. --- libguile/gc.c | 3 +++ libguile/print.c | 3 +++ libguile/tags.h | 2 +- 3 files changed, 7 insertions(+), 1 deletion(-) diff --git a/libguile/gc.c b/libguile/gc.c index 65316bbb2..43d532dff 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1431,6 +1431,9 @@ gc_mark_loop_first_time: case scm_tc7_symbol: ptr = SCM_PROP_SLOTS (ptr); goto_gc_mark_loop; + case scm_tc7_variable: + ptr = SCM_CELL_OBJECT_1 (ptr); + goto_gc_mark_loop; case scm_tcs_subrs: break; case scm_tc7_port: diff --git a/libguile/print.c b/libguile/print.c index 25d854fad..3873da422 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -545,6 +545,9 @@ taloop: port); scm_remember_upto_here_1 (exp); break; + case scm_tc7_variable: + scm_i_variable_print (exp, port, pstate); + break; case scm_tc7_wvect: ENTER_NESTED_DATA (pstate, exp, circref); if (SCM_IS_WHVEC (exp)) diff --git a/libguile/tags.h b/libguile/tags.h index 9b877b7ec..b40fbc754 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -333,7 +333,7 @@ typedef signed long scm_t_signed_bits; #define scm_tc7_symbol 5 -/* free 7 */ +#define scm_tc7_variable 7 /* couple */ #define scm_tc7_vector 13 From dbf5dfb3c1e937b12261a32c47ee3f14ee7e3325 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Jul 2001 15:28:07 +0000 Subject: [PATCH 1541/2047] * variable.h (scm_tc16_variable): Removed. (SCM_VARIABLEP): Test for new tc7 code. (scm_i_variable_print): New. * variable.c (scm_tc16_variable): Removed. (variable_print): Renamed to scm_i_variable_print and made non-static. (variable_equal_p): Removed. (make_variable): Construct a tc7 object instead of a smob. (scm_init_variable): Do not register smob. --- libguile/variable.c | 35 +++++++++++++++++++---------------- libguile/variable.h | 6 +++--- 2 files changed, 22 insertions(+), 19 deletions(-) diff --git a/libguile/variable.c b/libguile/variable.c index 4037e51be..9f542eda0 100644 --- a/libguile/variable.c +++ b/libguile/variable.c @@ -52,24 +52,17 @@ #include "libguile/validate.h" #include "libguile/variable.h" -scm_t_bits scm_tc16_variable; -static int -variable_print (SCM exp, SCM port, scm_print_state *pstate) +void +scm_i_variable_print (SCM exp, SCM port, scm_print_state *pstate) { scm_puts ("#', port); - return 1; } -static SCM -variable_equalp (SCM var1, SCM var2) -{ - return scm_equal_p (SCM_VARIABLE_REF (var1), SCM_VARIABLE_REF (var2)); -} #if SCM_ENABLE_VCELLS @@ -80,9 +73,24 @@ static SCM make_variable (SCM init) { #if !SCM_ENABLE_VCELLS - SCM_RETURN_NEWSMOB (scm_tc16_variable, SCM_UNPACK (init)); + { + SCM z; + SCM_NEWCELL (z); + SCM_SET_CELL_WORD_1 (z, SCM_UNPACK (init)); + SCM_SET_CELL_TYPE (z, scm_tc7_variable); + scm_remember_upto_here_1 (init); + return z; + } #else - SCM_RETURN_NEWSMOB (scm_tc16_variable, scm_cons (sym_huh, init)); + { + SCM z; + SCM cell = scm_cons (sym_huh, init); + SCM_NEWCELL (z); + SCM_SET_CELL_WORD_1 (z, SCM_UNPACK (cell)); + SCM_SET_CELL_TYPE (z, scm_tc7_variable); + scm_remember_upto_here_1 (cell); + return z; + } #endif } @@ -192,11 +200,6 @@ SCM_DEFINE (scm_builtin_variable, "builtin-variable", 1, 0, 0, void scm_init_variable () { - scm_tc16_variable = scm_make_smob_type ("variable", 0); - scm_set_smob_mark (scm_tc16_variable, scm_markcdr); - scm_set_smob_print (scm_tc16_variable, variable_print); - scm_set_smob_equalp (scm_tc16_variable, variable_equalp); - #ifndef SCM_MAGIC_SNARFER #include "libguile/variable.x" #endif diff --git a/libguile/variable.h b/libguile/variable.h index 014fc821f..577f1f820 100644 --- a/libguile/variable.h +++ b/libguile/variable.h @@ -52,9 +52,7 @@ /* Variables */ -extern scm_t_bits scm_tc16_variable; - -#define SCM_VARIABLEP(X) SCM_SMOB_PREDICATE (scm_tc16_variable, X) +#define SCM_VARIABLEP(X) (SCM_NIMP(X) && SCM_TYP7(X) == scm_tc7_variable) #if !SCM_ENABLE_VCELLS #define SCM_VARIABLE_REF(V) SCM_CELL_OBJECT_1(V) @@ -83,6 +81,8 @@ extern SCM scm_variable_set_name_hint (SCM var, SCM hint); extern SCM scm_builtin_variable (SCM name); #endif +extern void scm_i_variable_print (SCM var, SCM port, scm_print_state *pstate); + extern void scm_init_variable (void); #endif /* SCM_VARIABLE_H */ From ee0c7345a98b45f7454a323271fe429ab1162d04 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Jul 2001 15:32:20 +0000 Subject: [PATCH 1542/2047] *** empty log message *** --- NEWS | 8 ++++++++ libguile/ChangeLog | 16 ++++++++++++++++ 2 files changed, 24 insertions(+) diff --git a/NEWS b/NEWS index 01d04af58..cd1fb1d6a 100644 --- a/NEWS +++ b/NEWS @@ -4,6 +4,14 @@ See the end for copying conditions. Please send Guile bug reports to bug-guile@gnu.org. +Changes since the stable branch: + +** Variables have no longer a special behavior for `equal?'. + +Previously, comparing two variables with `equal?' would recursivly +compare their values. This is no longer done. Variables are now only +`equal?' if they are `eq?'. + Changes since Guile 1.4: * Changes to the distribution diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 0d72dc1b3..6212314b0 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,19 @@ +2001-07-25 Marius Vollmer + + * tags.h (scm_tc7_variable): New. + * gc.c (scm_gc_mark): Handle scm_tc7_variable objects. + * print.c (scm_iprin1): Likewise. + + * variable.h (scm_tc16_variable): Removed. + (SCM_VARIABLEP): Test for new tc7 code. + (scm_i_variable_print): New. + * variable.c (scm_tc16_variable): Removed. + (variable_print): Renamed to scm_i_variable_print and made + non-static. + (variable_equal_p): Removed. + (make_variable): Construct a tc7 object instead of a smob. + (scm_init_variable): Do not register smob. + 2001-07-22 Marius Vollmer * tags.h: Include inttypes.h when we have it. From 2b1d120cd73bd32a9976c60daffa8d1a75d4f3bb Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Jul 2001 15:32:30 +0000 Subject: [PATCH 1543/2047] * variable.c (scm_i_variable_print): Use "value" instead of "binding" since a binding is the mapping between symbols and variables, not between variables and their values. --- libguile/variable.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/variable.c b/libguile/variable.c index 9f542eda0..7ced1e9dd 100644 --- a/libguile/variable.c +++ b/libguile/variable.c @@ -58,7 +58,7 @@ scm_i_variable_print (SCM exp, SCM port, scm_print_state *pstate) { scm_puts ("#', port); } From 6d9ad98a173fe43900cbf3bbf521959b1d1dc7c1 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Jul 2001 15:33:03 +0000 Subject: [PATCH 1544/2047] *** empty log message *** --- libguile/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6212314b0..609e5c02c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,9 @@ 2001-07-25 Marius Vollmer + * variable.c (scm_i_variable_print): Use "value" instead of + "binding" since a binding is the mapping between symbols and + variables, not between variables and their values. + * tags.h (scm_tc7_variable): New. * gc.c (scm_gc_mark): Handle scm_tc7_variable objects. * print.c (scm_iprin1): Likewise. From d22a0ea164401885c0567c1621b83af10739da12 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Jul 2001 21:03:28 +0000 Subject: [PATCH 1545/2047] Allow variables in memoized code (in addition to glocs). (scm_lookupcar): Handle variables in lost races. Replace symbol with variable directly, do not make a gloc. (scm_unmemocar): Rewrite variables using a reverse lookup, just like glocs. (scm_ceval, scm_deval): Deal with variables in SCM_IM_SET and in the main switch. --- libguile/eval.c | 22 +++++++++++++++++++--- 1 file changed, 19 insertions(+), 3 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index ef80bfbf7..a4904d071 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -372,6 +372,8 @@ scm_lookupcar (SCM vloc, SCM genv, int check) var = SCM_CAR (vloc); if (SCM_ITAG3 (var) == scm_tc3_cons_gloc) return SCM_GLOC_VAL_LOC (var); + if (SCM_VARIABLEP (var)) + return SCM_VARIABLE_LOC (var); #ifdef MEMOIZE_LOCALS if (SCM_ITAG7 (var) == SCM_ITAG7 (SCM_ILOC00)) return scm_ilookup (var, genv); @@ -385,7 +387,7 @@ scm_lookupcar (SCM vloc, SCM genv, int check) } #endif /* USE_THREADS */ - SCM_SET_CELL_WORD_0 (vloc, SCM_UNPACK (real_var) + scm_tc3_cons_gloc); + SCM_SETCAR (vloc, real_var); return SCM_VARIABLE_LOC (real_var); } } @@ -421,6 +423,14 @@ scm_unmemocar (SCM form, SCM env) sym = sym_three_question_marks; SCM_SETCAR (form, sym); } + else if (SCM_VARIABLEP (c)) + { + SCM sym = + scm_module_reverse_lookup (scm_env_module (env), c); + if (SCM_EQ_P (sym, SCM_BOOL_F)) + sym = sym_three_question_marks; + SCM_SETCAR (form, sym); + } #ifdef MEMOIZE_LOCALS #ifdef DEBUG_EXTENSIONS else if (SCM_ILOCP (c)) @@ -2193,7 +2203,10 @@ dispatch: switch (SCM_ITAG3 (proc)) { case scm_tc3_cons: - t.lloc = scm_lookupcar (x, env, 1); + if (SCM_VARIABLEP (proc)) + t.lloc = SCM_VARIABLE_LOC (proc); + else + t.lloc = scm_lookupcar (x, env, 1); break; case scm_tc3_cons_gloc: t.lloc = SCM_GLOC_VAL_LOC (proc); @@ -2546,6 +2559,9 @@ dispatch: case scm_tcs_subrs: RETURN (x); + case scm_tc7_variable: + return SCM_VARIABLE_REF(x); + #ifdef MEMOIZE_LOCALS case SCM_BIT8(SCM_ILOC00): proc = *scm_ilookup (SCM_CAR (x), env); @@ -2558,7 +2574,7 @@ dispatch: break; #endif /* ifdef MEMOIZE_LOCALS */ - + case scm_tcs_cons_gloc: { scm_t_bits vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell]; if (vcell == 0) { From f5fe6c2f7e084e2cc756573fe782d5f9ee826175 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Jul 2001 21:03:59 +0000 Subject: [PATCH 1546/2047] *** empty log message *** --- libguile/ChangeLog | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 609e5c02c..e0e8d88b7 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,13 @@ +2001-07-25 Marius Vollmer + + * eval.c: Allow variables in memoized code (in addition to glocs). + (scm_lookupcar): Handle variables in lost races. Replace symbol + with variable directly, do not make a gloc. + (scm_unmemocar): Rewrite variables using a reverse lookup, just + like glocs. + (scm_ceval, scm_deval): Deal with variables in SCM_IM_SET and in + the main switch. + 2001-07-25 Marius Vollmer * variable.c (scm_i_variable_print): Use "value" instead of From a130e9829bce7819b9f235fe2e56d303a6839eeb Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Jul 2001 22:01:27 +0000 Subject: [PATCH 1547/2047] (scm_ceval, scm_deval): Use "RETURN" macro when returning value of a variable, not the plain "return" statement. --- libguile/eval.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/eval.c b/libguile/eval.c index a4904d071..1978b2632 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2560,7 +2560,7 @@ dispatch: RETURN (x); case scm_tc7_variable: - return SCM_VARIABLE_REF(x); + RETURN (SCM_VARIABLE_REF(x)); #ifdef MEMOIZE_LOCALS case SCM_BIT8(SCM_ILOC00): From dd29a16921104f94170b34b03d9099b7b879e790 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Jul 2001 22:01:50 +0000 Subject: [PATCH 1548/2047] *** empty log message *** --- libguile/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index e0e8d88b7..91bd46a71 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-07-26 Marius Vollmer + + * eval.c (scm_ceval, scm_deval): Use "RETURN" macro when returning + value of a variable, not the plain "return" statement. + 2001-07-25 Marius Vollmer * eval.c: Allow variables in memoized code (in addition to glocs). From 3c3db1289a7f2578c1505c5385d3052649d8f42f Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Wed, 25 Jul 2001 22:37:05 +0000 Subject: [PATCH 1549/2047] * numbers.c (scm_logand, scm_logior, scm_logxor): adjusted the docstrings to reflect the n-ary implementation. --- libguile/ChangeLog | 5 +++++ libguile/numbers.c | 38 ++++++++++++++++++-------------------- 2 files changed, 23 insertions(+), 20 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 91bd46a71..369d1c4e7 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-07-25 Gary Houston + + * numbers.c (scm_logand, scm_logior, scm_logxor): adjusted the + docstrings to reflect the n-ary implementation. + 2001-07-26 Marius Vollmer * eval.c (scm_ceval, scm_deval): Use "RETURN" macro when returning diff --git a/libguile/numbers.c b/libguile/numbers.c index 9b5c6a61f..0fc136cce 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -738,16 +738,14 @@ SCM scm_big_test(SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy) #endif - SCM_DEFINE1 (scm_logand, "logand", scm_tc7_asubr, (SCM n1, SCM n2), - "Return the integer which is the bit-wise AND of the two integer\n" - "arguments.\n" - "\n" - "@lisp\n" - "(number->string (logand #b1100 #b1010) 2)\n" - " @result{} \"1000\"\n" - "@end lisp") + "Return the bitwise AND of the integer arguments.\n\n" + "@lisp\n" + "(logand) @result{} -1\n" + "(logand 7) @result{} 7\n" + "(logand #b111 #b011 #\b001) @result{} 1\n" + "@end lisp") #define FUNC_NAME s_scm_logand { long int nn1; @@ -828,12 +826,11 @@ SCM_DEFINE1 (scm_logand, "logand", scm_tc7_asubr, SCM_DEFINE1 (scm_logior, "logior", scm_tc7_asubr, (SCM n1, SCM n2), - "Return the integer which is the bit-wise OR of the two integer\n" - "arguments.\n" - "\n" - "@lisp\n" - "(number->string (logior #b1100 #b1010) 2)\n" - " @result{} \"1110\"\n" + "Return the bitwise OR of the integer arguments.\n\n" + "@lisp\n" + "(logior) @result{} 0\n" + "(logior 7) @result{} 7\n" + "(logior #b000 #b001 #b011) @result{} 3\n" "@end lisp") #define FUNC_NAME s_scm_logior { @@ -914,12 +911,13 @@ SCM_DEFINE1 (scm_logior, "logior", scm_tc7_asubr, SCM_DEFINE1 (scm_logxor, "logxor", scm_tc7_asubr, (SCM n1, SCM n2), - "Return the integer which is the bit-wise XOR of the two integer\n" - "arguments.\n" - "\n" - "@lisp\n" - "(number->string (logxor #b1100 #b1010) 2)\n" - " @result{} \"110\"\n" + "Return the bitwise XOR of the integer arguments. A bit is\n" + "set in the result if it is set in an odd number of arguments.\n" + "@lisp\n" + "(logxor) @result{} 0\n" + "(logxor 7) @result{} 7\n" + "(logxor #b000 #b001 #b011) @result{} 2\n" + "(logxor #b000 #b001 #b011 #b011) @result{} 1\n" "@end lisp") #define FUNC_NAME s_scm_logxor { From 67b7dd9ea9aad459d77785766da3a8e3607ce2ab Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 26 Jul 2001 05:31:57 +0000 Subject: [PATCH 1550/2047] Minor typo fix in NEWS. Examples are now built and tested on `make installcheck'. --- NEWS | 2 +- examples/ChangeLog | 61 +++++++++++++++++++++++++ examples/box-dynamic-module/Makefile.am | 15 ++++-- examples/box-dynamic/Makefile.am | 15 ++++-- examples/box-module/Makefile.am | 13 ++++-- examples/box/Makefile.am | 13 ++++-- examples/modules/Makefile.am | 5 +- examples/safe/Makefile.am | 5 +- examples/scripts/Makefile.am | 11 +++-- 9 files changed, 115 insertions(+), 25 deletions(-) diff --git a/NEWS b/NEWS index cd1fb1d6a..ea966c86d 100644 --- a/NEWS +++ b/NEWS @@ -55,7 +55,7 @@ same name. For safety reasons, #. evaluation is disabled by default. To re-enable it, set the fluid read-eval? to #t. For example: - (fluid-set read-eval? #t) + (fluid-set! read-eval? #t) but make sure you realize the potential security risks involved. With read-eval? enabled, reading a data file from an untrusted source can diff --git a/examples/ChangeLog b/examples/ChangeLog index d7a556d59..f70742449 100644 --- a/examples/ChangeLog +++ b/examples/ChangeLog @@ -1,3 +1,64 @@ +2001-07-24 Martin Grabmueller + + All examples are now built and tested on `make installcheck' + rather than `make check'. + +2001-07-19 Martin Grabmueller + + * box-dynamic-module/Makefile.am, box-dynamic/Makefile.am, + box-module/Makefile.am, box/Makefile.am: Use $(top_srcdir) to get + at GUILE_LOAD_PATH, and $(top_builddir) for the guile and + guile-config programs and for the link paths. Add check.test to + EXTRA_DIST. + + * box-dynamic-module/Makefile.am, box-dynamic/Makefile.am, + box-module/Makefile.am, box/Makefile.am: Add -L../../qt to LIBS. + +2001-07-19 Rob Browning + + * box-module/.cvsignore: add .deps + + * box/.cvsignore: add .deps. + +2001-07-17 Martin Grabmueller + + * box-module/Makefile.am (TESTS): New variable. + Create `box' on `make all'. + + * box-module/check.test, box-dynamic-module/check.test, + * box-dynamic/check.test: New files. + + * box-dynamic/Makefile.am (libbox): Create box library on `make + all'. + (TESTS): New variable. + + * box/Makefile.am (TESTS): New variable. + Create `box' program on `make all', use freshly built Guile for + building. + + * box/check.test: New file. + + * modules/check.test, safe/check.test, scripts/check.test: Set + GUILE_LOAD_PATH to make the tests run without installed Guile. + +2001-07-16 Thien-Thi Nguyen + + * scripts/check.test: Add check for guile interpreter. + Fix bug: Use `$guile' everywhere. Thanks to Martin Grabmueller. + +2001-07-16 Martin Grabmueller + + * modules/check.test, safe/check.test: New files. + + * modules/Makefile.am (TESTS), safe/Makefile.am (TESTS): New + variables. + +2001-07-14 Thien-Thi Nguyen + + * scripts/check.test: New file. + + * Makefile.am (TESTS): New var. + 2001-07-14 Martin Grabmueller * modules/main: Use :renamer for specifying renaming procedure. diff --git a/examples/box-dynamic-module/Makefile.am b/examples/box-dynamic-module/Makefile.am index 4d7df0210..665a7de54 100644 --- a/examples/box-dynamic-module/Makefile.am +++ b/examples/box-dynamic-module/Makefile.am @@ -19,13 +19,18 @@ ## to the Free Software Foundation, Inc., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA -EXTRA_DIST = README box.c box-module.scm box-mixed.scm +EXTRA_DIST = README box.c box-module.scm box-mixed.scm check.test -CFLAGS=`guile-config compile` -LIBS=`guile-config link` +CFLAGS=`$(bindir)/guile-config compile` +LIBS=`$(bindir)/guile-config link` libbox-module: box.lo - sh ../../libtool --mode=link $(CC) $< $(LIBS) -rpath $(prefix)/lib -o libbox-module.la + sh ../../libtool --mode=link $(CC) $< $(LIBS) -rpath $(libdir) -o libbox-module.la box.lo: box.c - sh ../../libtool --mode=compile $(CC) $(CFLAGS) -c $< \ No newline at end of file + sh ../../libtool --mode=compile $(CC) $(CFLAGS) -c $< + +installcheck: libbox-module + LTDL_LIBRARY_PATH=.libs GUILE_LOAD_PATH=$(top_srcdir):$(srcdir) $(srcdir)/check.test + +CLEANFILES=libbox-module.la box.lo box.o diff --git a/examples/box-dynamic/Makefile.am b/examples/box-dynamic/Makefile.am index 7bb9f46c2..574eadb85 100644 --- a/examples/box-dynamic/Makefile.am +++ b/examples/box-dynamic/Makefile.am @@ -19,13 +19,18 @@ ## to the Free Software Foundation, Inc., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA -EXTRA_DIST = README box.c +EXTRA_DIST = README box.c check.test -CFLAGS=`guile-config compile` -LIBS=`guile-config link` +CFLAGS=`$(bindir)/guile-config compile` +LIBS=`$(bindir)/guile-config link` libbox: box.lo - sh ../../libtool --mode=link $(CC) $< $(LIBS) -rpath $(prefix)/lib -o libbox.la + sh ../../libtool --mode=link $(CC) $< $(LIBS) -rpath $(libdir) -o libbox.la box.lo: box.c - sh ../../libtool --mode=compile $(CC) $(CFLAGS) -c $< \ No newline at end of file + sh ../../libtool --mode=compile $(CC) $(CFLAGS) -c $< + +installcheck: libbox + LTDL_LIBRARY_PATH=.libs GUILE_LOAD_PATH=$(top_srcdir):$(srcdir) $(srcdir)/check.test + +CLEANFILES=libbox.la box.lo box.o diff --git a/examples/box-module/Makefile.am b/examples/box-module/Makefile.am index 3e1f92032..3fe82e7cd 100644 --- a/examples/box-module/Makefile.am +++ b/examples/box-module/Makefile.am @@ -19,13 +19,18 @@ ## to the Free Software Foundation, Inc., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA -EXTRA_DIST = README box.c +EXTRA_DIST = README box.c check.test -CFLAGS=`guile-config compile` -LIBS=`guile-config link` +CFLAGS=`$(bindir)/guile-config compile` +LIBS=`$(bindir)/guile-config link` box: box.o $(CC) $< $(LIBS) -o box box.o: box.c - $(CC) $(CFLAGS) -c $< \ No newline at end of file + $(CC) $(CFLAGS) -c $< + +installcheck: box + LD_LIBRARY_PATH=$(libdir) GUILE_LOAD_PATH=$(top_srcdir) $(srcdir)/check.test + +CLEANFILES=box box.o diff --git a/examples/box/Makefile.am b/examples/box/Makefile.am index 3e1f92032..3fe82e7cd 100644 --- a/examples/box/Makefile.am +++ b/examples/box/Makefile.am @@ -19,13 +19,18 @@ ## to the Free Software Foundation, Inc., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA -EXTRA_DIST = README box.c +EXTRA_DIST = README box.c check.test -CFLAGS=`guile-config compile` -LIBS=`guile-config link` +CFLAGS=`$(bindir)/guile-config compile` +LIBS=`$(bindir)/guile-config link` box: box.o $(CC) $< $(LIBS) -o box box.o: box.c - $(CC) $(CFLAGS) -c $< \ No newline at end of file + $(CC) $(CFLAGS) -c $< + +installcheck: box + LD_LIBRARY_PATH=$(libdir) GUILE_LOAD_PATH=$(top_srcdir) $(srcdir)/check.test + +CLEANFILES=box box.o diff --git a/examples/modules/Makefile.am b/examples/modules/Makefile.am index 35988c545..a6a9e0e03 100644 --- a/examples/modules/Makefile.am +++ b/examples/modules/Makefile.am @@ -19,4 +19,7 @@ ## to the Free Software Foundation, Inc., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA -EXTRA_DIST = README module-0.scm module-1.scm module-2.scm main +EXTRA_DIST = README module-0.scm module-1.scm module-2.scm main check.test + +installcheck: + srcdir=$(srcdir) GUILE_LOAD_PATH=$(top_srcdir):$(srcdir) $(srcdir)/check.test diff --git a/examples/safe/Makefile.am b/examples/safe/Makefile.am index cf41df73f..16c2f1687 100644 --- a/examples/safe/Makefile.am +++ b/examples/safe/Makefile.am @@ -19,4 +19,7 @@ ## to the Free Software Foundation, Inc., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA -EXTRA_DIST = README safe untrusted.scm evil.scm +EXTRA_DIST = README safe untrusted.scm evil.scm check.test + +installcheck: + srcdir=$(srcdir) GUILE_LOAD_PATH=$(top_srcdir) $(srcdir)/check.test diff --git a/examples/scripts/Makefile.am b/examples/scripts/Makefile.am index ff6173086..3a82dad77 100644 --- a/examples/scripts/Makefile.am +++ b/examples/scripts/Makefile.am @@ -3,20 +3,23 @@ ## Copyright (C) 2001 Free Software Foundation, Inc. ## ## This file is part of GUILE. -## +## ## GUILE 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, or ## (at your option) any later version. -## +## ## GUILE 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 GUILE; see the file COPYING. If not, write ## to the Free Software Foundation, Inc., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA -EXTRA_DIST = README simple-hello.scm hello fact +EXTRA_DIST = README simple-hello.scm hello fact check.test + +installcheck: + srcdir=$(srcdir) GUILE_LOAD_PATH=$(top_srcdir) $(srcdir)/check.test From d315ea8ccc5aff59189f3133b517a92a97e5a9c3 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 26 Jul 2001 16:58:30 +0000 Subject: [PATCH 1551/2047] (GC_noop1): Moved into the same #if/#endif context where it is needed. --- libguile/gc_os_dep.c | 24 ++++++++++-------------- 1 file changed, 10 insertions(+), 14 deletions(-) diff --git a/libguile/gc_os_dep.c b/libguile/gc_os_dep.c index 2d5a19491..cc5af6837 100644 --- a/libguile/gc_os_dep.c +++ b/libguile/gc_os_dep.c @@ -62,20 +62,6 @@ typedef int GC_bool; # define VOLATILE #endif -#if 0 /* currently unused (as of 2001-07-12) */ - -/* Single argument version, robust against whole program analysis. */ -static void -GC_noop1(x) -word x; -{ - static VOLATILE word sink; - - sink = x; -} - -#endif - /* Machine dependent parameters. Some tuning parameters can be found */ /* near the top of gc_private.h. */ @@ -1773,6 +1759,16 @@ void *scm_get_stack_base() } return(result); } + + /* Single argument version, robust against whole program analysis. */ + static void + GC_noop1(x) + word x; + { + static VOLATILE word sink; + sink = x; + } + # endif #ifdef LINUX_STACKBOTTOM From 5b54c4daa124b0d9f9b984f0bf1733ac5ebba4d3 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 26 Jul 2001 16:58:55 +0000 Subject: [PATCH 1552/2047] *** empty log message *** --- libguile/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 369d1c4e7..38f7d3b1e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-07-26 Marius Vollmer + + * gc_os_dep.c (GC_noop1): Moved into the same #if/#endif context + where it is needed. + 2001-07-25 Gary Houston * numbers.c (scm_logand, scm_logior, scm_logxor): adjusted the From 904a077df1a670d386ca114ddb7a8e371684f655 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 26 Jul 2001 21:40:18 +0000 Subject: [PATCH 1553/2047] * tags.h: Update tag system docs. (scm_tc3_cons_gloc): Renamed to scm_tc3_struct. Changed all uses. (scm_tcs_cons_gloc): Renamed to scm_tcs_struct. Changed all uses. (SCM_ECONSP, SCM_NECONSP): Removed. Changed all uses to SCM_CONSP or SCM_NCONSP, respectively. * struct.c, struct.h, srcprop.c, procs.c, procprop.c, print.c, objects.c. modules.c, goops.c, eval.c, debug.c: Changed all uses of scm_tc3_cond_gloc and scm_tcs_cons_gloc. See above. * print.c (scm_iprin1): Remove printing of glocs. Do not try to tell glocs from structs. * gc.c (scm_gc_mark, scm_gc_sweep): Remove handling of glocs. * eval.c (scm_m_atbind): Make a list of variables, not glocs. (scm_ceval, scm_deval): For SCM_IM_BIND, fiddle with variables instead of with glocs. (EVALCAR): Do not test for glocs. (scm_lookupcar, scm_lookupcar1): Do not handle glocs in race condition. (scm_unmemocar): Do not handle glocs. (scm_m_atfop): Memoize as a variable, not as a gloc. (scm_eval_args, scm_deval_args): Do not handle glocs. (scm_ceval, scm_deval): Likewise. * eval.h (SCM_XEVALCAR): Do not test for glocs. (SCM_GLOC_VAR, SCM_GLOC_VAL, SCM_GLOC_SET_VAL, SCM_GLOC_VAL_LOC): Removed. * debug.h, debug.c (scm_make_gloc, scm_gloc_p): Removed. * dynwind.c (scm_swap_bindings): Likewise. (scm_dowinds): Updated to recognize lists of variables instead of lists of glocs. * __scm.h (SCM_CAUTIOS, SCM_RECKLESS): Update comments. --- libguile/__scm.h | 11 +-- libguile/debug.c | 41 +---------- libguile/debug.h | 2 - libguile/dynwind.c | 32 ++++---- libguile/eval.c | 176 ++++++++++---------------------------------- libguile/eval.h | 14 +--- libguile/gc.c | 110 ++++++++++----------------- libguile/goops.c | 4 +- libguile/modules.c | 2 +- libguile/objects.c | 5 +- libguile/print.c | 64 +++++++--------- libguile/procprop.c | 2 +- libguile/procs.c | 2 +- libguile/srcprop.c | 2 +- libguile/struct.c | 9 ++- libguile/struct.h | 7 +- libguile/tags.h | 109 ++++++++++++++------------- 17 files changed, 201 insertions(+), 391 deletions(-) diff --git a/libguile/__scm.h b/libguile/__scm.h index fd67075af..2e1e3b611 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -100,11 +100,12 @@ /* If the compile FLAG `SCM_CAUTIOUS' is #defined then the number of * arguments is always checked for application of closures. If the * compile FLAG `SCM_RECKLESS' is #defined then they are not checked. - * Otherwise, number of argument checks for closures are made only when - * the function position (whose value is the closure) of a combination is - * not an ILOC or GLOC. When the function position of a combination is a - * symbol it will be checked only the first time it is evaluated because - * it will then be replaced with an ILOC or GLOC. + * Otherwise, number of argument checks for closures are made only + * when the function position (whose value is the closure) of a + * combination is not an ILOC or a variable (true?). When the + * function position of a combination is a symbol it will be checked + * only the first time it is evaluated because it will then be + * replaced with an ILOC or variable. */ #undef SCM_RECKLESS #define SCM_CAUTIOUS diff --git a/libguile/debug.c b/libguile/debug.c index 49cce42c7..d4a97e260 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -196,17 +196,6 @@ scm_make_memoized (SCM exp, SCM env) * specified, the top-level environment of the current module will * be assumed. All environments must match. * - * - procedure: make-gloc VARIABLE [ENV] - * - * Return a gloc, encapsulated in a memoized object. - * - * (Glocs can't exist in normal list structures, since they will - * be mistaken for structs.) - * - * - procedure: gloc? OBJECT - * - * Return #t if OBJECT is a memoized gloc. - * * - procedure: make-iloc FRAME BINDING CDRP * * Return an iloc referring to frame no. FRAME, binding @@ -252,32 +241,6 @@ scm_make_memoized (SCM exp, SCM env) #include "libguile/variable.h" #include "libguile/procs.h" -SCM_DEFINE (scm_make_gloc, "make-gloc", 1, 1, 0, - (SCM var, SCM env), - "Create a gloc for variable @var{var} in the environment\n" - "@var{env}.") -#define FUNC_NAME s_scm_make_gloc -{ - SCM_VALIDATE_VARIABLE (1,var); - if (SCM_UNBNDP (env)) - env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE); - else - SCM_VALIDATE_NULLORCONS (2,env); - return scm_make_memoized (SCM_PACK (SCM_UNPACK (var) + scm_tc3_cons_gloc), env); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_gloc_p, "gloc?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a gloc.") -#define FUNC_NAME s_scm_gloc_p -{ - return - SCM_BOOL (SCM_MEMOIZEDP (obj) - && ((SCM_UNPACK(SCM_MEMOIZED_EXP(obj))&7) == scm_tc3_cons_gloc)); -} -#undef FUNC_NAME - SCM_DEFINE (scm_make_iloc, "make-iloc", 3, 0, 0, (SCM frame, SCM binding, SCM cdrp), "Return a new iloc with frame offset @var{frame}, binding\n" @@ -538,8 +501,8 @@ scm_m_start_stack (SCM exp, SCM env) #define FUNC_NAME s_start_stack { exp = SCM_CDR (exp); - if (!SCM_ECONSP (exp) - || !SCM_ECONSP (SCM_CDR (exp)) + if (!SCM_CONSP (exp) + || !SCM_CONSP (SCM_CDR (exp)) || !SCM_NULLP (SCM_CDDR (exp))) SCM_WRONG_NUM_ARGS (); return scm_start_stack (scm_eval_car (exp, env), SCM_CADR (exp), env); diff --git a/libguile/debug.h b/libguile/debug.h index 06a3133cb..c5b54a62c 100644 --- a/libguile/debug.h +++ b/libguile/debug.h @@ -209,8 +209,6 @@ extern SCM scm_make_debugobj (scm_t_debug_frame *debug); extern void scm_init_debug (void); #ifdef GUILE_DEBUG -extern SCM scm_make_gloc (SCM var, SCM env); -extern SCM scm_gloc_p (SCM obj); extern SCM scm_make_iloc (SCM frame, SCM binding, SCM cdrp); extern SCM scm_iloc_p (SCM obj); extern SCM scm_memcons (SCM car, SCM cdr, SCM env); diff --git a/libguile/dynwind.c b/libguile/dynwind.c index 6a32797cc..889c0d4fb 100644 --- a/libguile/dynwind.c +++ b/libguile/dynwind.c @@ -185,15 +185,15 @@ SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0, #endif static void -scm_swap_bindings (SCM glocs, SCM vals) +scm_swap_bindings (SCM vars, SCM vals) { SCM tmp; while (SCM_NIMP (vals)) { - tmp = SCM_GLOC_VAL (SCM_CAR (glocs)); - SCM_GLOC_SET_VAL (SCM_CAR (glocs), SCM_CAR (vals)); + tmp = SCM_VARIABLE_REF (SCM_CAR (vars)); + SCM_VARIABLE_SET (SCM_CAR (vars), SCM_CAR (vals)); SCM_SETCAR (vals, tmp); - glocs = SCM_CDR (glocs); + vars = SCM_CDR (vars); vals = SCM_CDR (vals); } } @@ -219,13 +219,16 @@ scm_dowinds (SCM to, long delta) #endif { wind_key = SCM_CAR (wind_elt); - /* key = #t | symbol | thunk | list of glocs | list of fluids */ + /* key = #t | symbol | thunk | list of variables | list of fluids */ if (SCM_NIMP (wind_key)) { - if (SCM_TYP3 (wind_key) == scm_tc3_cons_gloc) - scm_swap_bindings (wind_key, SCM_CDR (wind_elt)); - else if (SCM_TYP3 (wind_key) == scm_tc3_cons) - scm_swap_fluids (wind_key, SCM_CDR (wind_elt)); + if (SCM_CONSP (wind_key)) + { + if (SCM_VARIABLEP (SCM_CAR (wind_key))) + scm_swap_bindings (wind_key, SCM_CDR (wind_elt)); + else if (SCM_FLUIDP (SCM_CAR (wind_key))) + scm_swap_fluids (wind_key, SCM_CDR (wind_elt)); + } else if (SCM_GUARDSP (wind_key)) SCM_BEFORE_GUARD (wind_key) (SCM_GUARD_DATA (wind_key)); else if (SCM_TYP3 (wind_key) == scm_tc3_closure) @@ -254,10 +257,13 @@ scm_dowinds (SCM to, long delta) wind_key = SCM_CAR (wind_elt); if (SCM_NIMP (wind_key)) { - if (SCM_TYP3 (wind_key) == scm_tc3_cons_gloc) - scm_swap_bindings (wind_key, from); - else if (SCM_TYP3 (wind_key) == scm_tc3_cons) - scm_swap_fluids_reverse (wind_key, from); + if (SCM_CONSP (wind_key)) + { + if (SCM_VARIABLEP (SCM_CAR (wind_key))) + scm_swap_bindings (wind_key, SCM_CDR (wind_elt)); + else if (SCM_FLUIDP (SCM_CAR (wind_key))) + scm_swap_fluids_reverse (wind_key, SCM_CDR (wind_elt)); + } else if (SCM_GUARDSP (wind_key)) SCM_AFTER_GUARD (wind_key) (SCM_GUARD_DATA (wind_key)); else if (SCM_TYP3 (wind_key) == scm_tc3_closure) diff --git a/libguile/eval.c b/libguile/eval.c index 1978b2632..ff681d86d 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -156,10 +156,8 @@ char *alloca (); : SCM_CEVAL (SCM_CAR (x), env)) #define EVALCAR(x, env) (!SCM_CELLP (SCM_CAR (x)) \ - ? (SCM_IMP (SCM_CAR (x)) \ - ? SCM_EVALIM (SCM_CAR (x), env) \ - : SCM_GLOC_VAL (SCM_CAR (x))) \ - : EVALCELLCAR (x, env)) + ? SCM_EVALIM (SCM_CAR (x), env) \ + : EVALCELLCAR (x, env)) #define EXTEND_ENV SCM_EXTEND_ENV @@ -197,7 +195,7 @@ scm_ilookup (SCM iloc, SCM env) tree-code instructions. There shouldn't normally be a problem with memoizing local and - global variable references (into ilocs and glocs), because all + global variable references (into ilocs and variables), because all threads will mutate the code in *exactly* the same way and (if I read the C code correctly) it is not possible to observe a half-way mutated cons cell. The lookup procedure can handle this @@ -205,11 +203,11 @@ scm_ilookup (SCM iloc, SCM env) It is different with macro expansion, because macro expansion happens outside of the lookup procedure and can't be - undone. Therefore it can't cope with it. It has to indicate - failure when it detects a lost race and hope that the caller can - handle it. Luckily, it turns out that this is the case. + undone. Therefore the lookup procedure can't cope with it. It has + to indicate failure when it detects a lost race and hope that the + caller can handle it. Luckily, it turns out that this is the case. - An example to illustrate this: Suppose that the follwing form will + An example to illustrate this: Suppose that the following form will be memoized concurrently by two threads (let ((x 12)) x) @@ -226,13 +224,13 @@ scm_ilookup (SCM iloc, SCM env) But let's see what will happen when the race occurs while looking up the symbol "let" at the start of the form. It could happen that the second thread interrupts the lookup of the first thread and not - only substitutes a gloc for it but goes right ahead and replaces it - with the compiled form (#@let* (x 12) x). Now, when the first - thread completes its lookup, it would replace the #@let* with a - gloc pointing to the "let" binding, effectively reverting the form - to (let (x 12) x). This is wrong. It has to detect that it has - lost the race and the evaluator has to reconsider the changed form - completely. + only substitutes a variable for it but goes right ahead and + replaces it with the compiled form (#@let* (x 12) x). Now, when + the first thread completes its lookup, it would replace the #@let* + with a variable containing the "let" binding, effectively reverting + the form to (let (x 12) x). This is wrong. It has to detect that + it has lost the race and the evaluator has to reconsider the + changed form completely. This race condition could be resolved with some kind of traffic light (like mutexes) around scm_lookupcar, but I think that it is @@ -370,15 +368,13 @@ scm_lookupcar (SCM vloc, SCM genv, int check) completely. */ race: var = SCM_CAR (vloc); - if (SCM_ITAG3 (var) == scm_tc3_cons_gloc) - return SCM_GLOC_VAL_LOC (var); if (SCM_VARIABLEP (var)) return SCM_VARIABLE_LOC (var); #ifdef MEMOIZE_LOCALS if (SCM_ITAG7 (var) == SCM_ITAG7 (SCM_ILOC00)) return scm_ilookup (var, genv); #endif - /* We can't cope with anything else than glocs and ilocs. When + /* We can't cope with anything else than variables and ilocs. When a special form has been memoized (i.e. `let' into `#@let') we return NULL and expect the calling function to do the right thing. For the evaluator, this means going back and redoing @@ -415,15 +411,7 @@ scm_unmemocar (SCM form, SCM env) if (SCM_IMP (form)) return form; c = SCM_CAR (form); - if (SCM_ITAG3 (c) == scm_tc3_cons_gloc) - { - SCM sym = - scm_module_reverse_lookup (scm_env_module (env), SCM_GLOC_VAR (c)); - if (SCM_EQ_P (sym, SCM_BOOL_F)) - sym = sym_three_question_marks; - SCM_SETCAR (form, sym); - } - else if (SCM_VARIABLEP (c)) + if (SCM_VARIABLEP (c)) { SCM sym = scm_module_reverse_lookup (scm_env_module (env), c); @@ -839,7 +827,7 @@ iqq (SCM form, SCM env, long depth) --depth; label: form = SCM_CDR (form); - SCM_ASSERT (SCM_ECONSP (form) && SCM_NULLP (SCM_CDR (form)), + SCM_ASSERT (SCM_CONSP (form) && SCM_NULLP (SCM_CDR (form)), form, SCM_ARG1, s_quasiquote); if (0 == depth) return evalcar (form, env); @@ -1120,7 +1108,7 @@ scm_m_atfop (SCM xorig, SCM env SCM_UNUSED) var = scm_symbol_fref (SCM_CAR (x)); SCM_ASSYNT (SCM_VARIABLEP (var), "Symbol's function definition is void", NULL); - SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (var) + scm_tc3_cons_gloc); + SCM_SETCAR (x, var); return x; } @@ -1146,7 +1134,7 @@ scm_m_atbind (SCM xorig, SCM env) x = SCM_CAR (x); while (SCM_NIMP (x)) { - SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (scm_sym2var (SCM_CAR (x), env, SCM_BOOL_T)) + scm_tc3_cons_gloc); + SCM_SETCAR (x, scm_sym2var (SCM_CAR (x), env, SCM_BOOL_T)); x = SCM_CDR (x); } return scm_cons (SCM_IM_BIND, SCM_CDR (xorig)); @@ -1291,7 +1279,7 @@ unmemocopy (SCM x, SCM env) #ifdef DEBUG_EXTENSIONS SCM p; #endif - if (SCM_NCELLP (x) || SCM_NECONSP (x)) + if (SCM_NCELLP (x) || SCM_NCONSP (x)) return x; #ifdef DEBUG_EXTENSIONS p = scm_whash_lookup (scm_source_whash, x); @@ -1459,7 +1447,7 @@ unmemocopy (SCM x, SCM env) env); } loop: - while (SCM_CELLP (x = SCM_CDR (x)) && SCM_ECONSP (x)) + while (SCM_CELLP (x = SCM_CDR (x)) && SCM_CONSP (x)) { if (SCM_ISYMP (SCM_CAR (x))) /* skip body markers */ @@ -1528,40 +1516,17 @@ SCM scm_eval_args (SCM l, SCM env, SCM proc) { SCM results = SCM_EOL, *lloc = &results, res; - while (!SCM_IMP (l)) + while (SCM_CONSP (l)) { -#ifdef SCM_CAUTIOUS - if (SCM_CONSP (l)) - { - if (SCM_IMP (SCM_CAR (l))) - res = SCM_EVALIM (SCM_CAR (l), env); - else - res = EVALCELLCAR (l, env); - } - else if (SCM_TYP3 (l) == scm_tc3_cons_gloc) - { - scm_t_bits vcell = - SCM_STRUCT_VTABLE_DATA (l) [scm_vtable_index_vcell]; - if (vcell == 0) - res = SCM_CAR (l); /* struct planted in code */ - else - res = SCM_GLOC_VAL (SCM_CAR (l)); - } - else - goto wrongnumargs; -#else res = EVALCAR (l, env); -#endif + *lloc = scm_cons (res, SCM_EOL); lloc = SCM_CDRLOC (*lloc); l = SCM_CDR (l); } #ifdef SCM_CAUTIOUS if (!SCM_NULLP (l)) - { - wrongnumargs: - scm_wrong_num_args (proc); - } + scm_wrong_num_args (proc); #endif return results; } @@ -1758,40 +1723,17 @@ SCM scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc) { SCM *results = lloc, res; - while (!SCM_IMP (l)) + while (SCM_CONSP (l)) { -#ifdef SCM_CAUTIOUS - if (SCM_CONSP (l)) - { - if (SCM_IMP (SCM_CAR (l))) - res = SCM_EVALIM (SCM_CAR (l), env); - else - res = EVALCELLCAR (l, env); - } - else if (SCM_TYP3 (l) == scm_tc3_cons_gloc) - { - scm_t_bits vcell = - SCM_STRUCT_VTABLE_DATA (l) [scm_vtable_index_vcell]; - if (vcell == 0) - res = SCM_CAR (l); /* struct planted in code */ - else - res = SCM_GLOC_VAL (SCM_CAR (l)); - } - else - goto wrongnumargs; -#else res = EVALCAR (l, env); -#endif + *lloc = scm_cons (res, SCM_EOL); lloc = SCM_CDRLOC (*lloc); l = SCM_CDR (l); } #ifdef SCM_CAUTIOUS if (!SCM_NULLP (l)) - { - wrongnumargs: - scm_wrong_num_args (proc); - } + scm_wrong_num_args (proc); #endif return *results; } @@ -2014,7 +1956,7 @@ dispatch: if (!SCM_CELLP (SCM_CAR (x))) { x = SCM_CAR (x); - RETURN (SCM_IMP (x) ? SCM_EVALIM (x, env) : SCM_GLOC_VAL (x)) + RETURN (SCM_EVALIM (x, env)) } if (SCM_SYMBOLP (SCM_CAR (x))) @@ -2208,9 +2150,6 @@ dispatch: else t.lloc = scm_lookupcar (x, env, 1); break; - case scm_tc3_cons_gloc: - t.lloc = SCM_GLOC_VAL_LOC (proc); - break; #ifdef MEMOIZE_LOCALS case scm_tc3_imm24: t.lloc = scm_ilookup (proc, env); @@ -2309,8 +2248,8 @@ dispatch: arg2 = *scm_ilookup (proc, env); else if (SCM_NCONSP (proc)) { - if (SCM_NCELLP (proc)) - arg2 = SCM_GLOC_VAL (proc); + if (SCM_VARIABLEP (proc)) + arg2 = SCM_VARIABLE_REF (proc); else arg2 = *scm_lookupcar (SCM_CDR (x), env, 1); } @@ -2477,9 +2416,8 @@ dispatch: arg2 = SCM_CDAR (env); while (SCM_NIMP (arg2)) { - proc = SCM_GLOC_VAL (SCM_CAR (t.arg1)); - SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t.arg1)) - 1L), - SCM_CAR (arg2)); + proc = SCM_VARIABLE_REF (SCM_CAR (t.arg1)); + SCM_VARIABLE_SET (SCM_CAR (t.arg1), SCM_CAR (arg2)); SCM_SETCAR (arg2, proc); t.arg1 = SCM_CDR (t.arg1); arg2 = SCM_CDR (arg2); @@ -2499,8 +2437,7 @@ dispatch: arg2 = SCM_CDAR (env); while (SCM_NIMP (arg2)) { - SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t.arg1)) - 1L), - SCM_CAR (arg2)); + SCM_VARIABLE_SET (SCM_CAR (t.arg1), SCM_CAR (arg2)); t.arg1 = SCM_CDR (t.arg1); arg2 = SCM_CDR (arg2); } @@ -2557,6 +2494,7 @@ dispatch: case scm_tc7_cclo: case scm_tc7_pws: case scm_tcs_subrs: + case scm_tcs_struct: RETURN (x); case scm_tc7_variable: @@ -2573,25 +2511,7 @@ dispatch: #endif break; #endif /* ifdef MEMOIZE_LOCALS */ - - case scm_tcs_cons_gloc: { - scm_t_bits vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell]; - if (vcell == 0) { - /* This is a struct implanted in the code, not a gloc. */ - RETURN (x); - } else { - proc = SCM_GLOC_VAL (SCM_CAR (x)); - SCM_ASRTGO (SCM_NIMP (proc), badfun); -#ifndef SCM_RECKLESS -#ifdef SCM_CAUTIOUS - goto checkargs; -#endif -#endif - } - break; - } - case scm_tcs_cons_nimcar: orig_sym = SCM_CAR (x); if (SCM_SYMBOLP (orig_sym)) @@ -2733,7 +2653,7 @@ evapply: x = SCM_CODE (proc); env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), SCM_EOL, SCM_ENV (proc)); goto nontoplevel_cdrxbegin; - case scm_tcs_cons_gloc: /* really structs, not glocs */ + case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { x = SCM_ENTITY_PROCEDURE (proc); @@ -2786,14 +2706,6 @@ evapply: else t.arg1 = EVALCELLCAR (x, env); } - else if (SCM_TYP3 (x) == scm_tc3_cons_gloc) - { - scm_t_bits vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell]; - if (vcell == 0) - t.arg1 = SCM_CAR (x); /* struct planted in code */ - else - t.arg1 = SCM_GLOC_VAL (SCM_CAR (x)); - } else goto wrongnumargs; #else @@ -2888,7 +2800,7 @@ evapply: env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc)); #endif goto nontoplevel_cdrxbegin; - case scm_tcs_cons_gloc: /* really structs, not glocs */ + case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { x = SCM_ENTITY_PROCEDURE (proc); @@ -2936,14 +2848,6 @@ evapply: else arg2 = EVALCELLCAR (x, env); } - else if (SCM_TYP3 (x) == scm_tc3_cons_gloc) - { - scm_t_bits vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell]; - if (vcell == 0) - arg2 = SCM_CAR (x); /* struct planted in code */ - else - arg2 = SCM_GLOC_VAL (SCM_CAR (x)); - } else goto wrongnumargs; #else @@ -2992,7 +2896,7 @@ evapply: proc))), SCM_EOL)); #endif - case scm_tcs_cons_gloc: /* really structs, not glocs */ + case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { x = SCM_ENTITY_PROCEDURE (proc); @@ -3058,7 +2962,7 @@ evapply: } } #ifdef SCM_CAUTIOUS - if (SCM_IMP (x) || SCM_NECONSP (x)) + if (SCM_IMP (x) || SCM_NCONSP (x)) goto wrongnumargs; #endif #ifdef DEVAL @@ -3206,7 +3110,7 @@ evapply: x = SCM_CODE (proc); goto nontoplevel_cdrxbegin; #endif /* DEVAL */ - case scm_tcs_cons_gloc: /* really structs, not glocs */ + case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { #ifdef DEVAL @@ -3649,7 +3553,7 @@ tail: debug.vect[0].a.proc = proc; #endif goto tail; - case scm_tcs_cons_gloc: /* really structs, not glocs */ + case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { #ifdef DEVAL diff --git a/libguile/eval.h b/libguile/eval.h index 418844c0a..18e245483 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -115,9 +115,7 @@ extern SCM scm_eval_options_interface (SCM setting); ? SCM_EVALIM2(x) \ : (*scm_ceval_ptr) ((x), (env))) #define SCM_XEVALCAR(x, env) (SCM_NCELLP (SCM_CAR (x)) \ - ? (SCM_IMP (SCM_CAR (x)) \ - ? SCM_EVALIM (SCM_CAR (x), env) \ - : SCM_GLOC_VAL (SCM_CAR (x))) \ + ? SCM_EVALIM (SCM_CAR (x), env) \ : (SCM_SYMBOLP (SCM_CAR (x)) \ ? *scm_lookupcar (x, env, 1) \ : (*scm_ceval_ptr) (SCM_CAR (x), env))) @@ -182,16 +180,6 @@ extern SCM scm_sym_args; extern SCM scm_f_apply; -/* A resolved global variable reference in the CAR position - * of a list is stored (in code only) as a pointer to a variable with a - * tag of 1. This is called a "gloc". - */ - -#define SCM_GLOC_VAR(x) (SCM_PACK(SCM_UNPACK(x)-scm_tc3_cons_gloc)) -#define SCM_GLOC_VAL(x) (SCM_VARIABLE_REF (SCM_GLOC_VAR (x))) -#define SCM_GLOC_SET_VAL(x, y) (SCM_VARIABLE_SET (SCM_GLOC_VAR (x), y)) -#define SCM_GLOC_VAL_LOC(x) (SCM_VARIABLE_LOC (SCM_GLOC_VAR (x))) - extern SCM * scm_ilookup (SCM iloc, SCM env); diff --git a/libguile/gc.c b/libguile/gc.c index 43d532dff..83b9263e6 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1257,63 +1257,40 @@ gc_mark_loop_first_time: RECURSE (SCM_SETTER (ptr)); ptr = SCM_PROCEDURE (ptr); goto_gc_mark_loop; - case scm_tcs_cons_gloc: + case scm_tcs_struct: { - /* Dirk:FIXME:: The following code is super ugly: ptr may be a - * struct or a gloc. If it is a gloc, the cell word #0 of ptr - * is the address of a scm_tc16_variable smob. If it is a - * struct, the cell word #0 of ptr is a pointer to a struct - * vtable data region. (The fact that these are accessed in - * the same way restricts the possibilites to change the data - * layout of structs or heap cells.) To discriminate between - * the two, it is guaranteed that the scm_vtable_index_vcell - * element of the prospective vtable is always zero. For a - * gloc, this location has the CDR of the variable smob, which - * is guaranteed to be non-zero. - */ - scm_t_bits word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_cons_gloc; - scm_t_bits * vtable_data = (scm_t_bits *) word0; /* access as struct */ - if (vtable_data [scm_vtable_index_vcell] != 0) + /* XXX - use less explicit code. */ + scm_t_bits word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_struct; + scm_t_bits * vtable_data = (scm_t_bits *) word0; + SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]); + long len = SCM_SYMBOL_LENGTH (layout); + char * fields_desc = SCM_SYMBOL_CHARS (layout); + scm_t_bits * struct_data = (scm_t_bits *) SCM_STRUCT_DATA (ptr); + + if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) { - /* ptr is a gloc */ - SCM gloc_car = SCM_PACK (word0); - RECURSE (gloc_car); - ptr = SCM_CDR (ptr); - goto gc_mark_loop; - } - else - { - /* ptr is a struct */ - SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]); - long len = SCM_SYMBOL_LENGTH (layout); - char * fields_desc = SCM_SYMBOL_CHARS (layout); - scm_t_bits * struct_data = (scm_t_bits *) SCM_STRUCT_DATA (ptr); - - if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) - { - RECURSE (SCM_PACK (struct_data[scm_struct_i_procedure])); - RECURSE (SCM_PACK (struct_data[scm_struct_i_setter])); - } - if (len) - { - long x; - - for (x = 0; x < len - 2; x += 2, ++struct_data) - if (fields_desc[x] == 'p') - RECURSE (SCM_PACK (*struct_data)); - if (fields_desc[x] == 'p') - { - if (SCM_LAYOUT_TAILP (fields_desc[x + 1])) - for (x = *struct_data++; x; --x, ++struct_data) - RECURSE (SCM_PACK (*struct_data)); - else - RECURSE (SCM_PACK (*struct_data)); - } - } - /* mark vtable */ - ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]); - goto_gc_mark_loop; + RECURSE (SCM_PACK (struct_data[scm_struct_i_procedure])); + RECURSE (SCM_PACK (struct_data[scm_struct_i_setter])); } + if (len) + { + long x; + + for (x = 0; x < len - 2; x += 2, ++struct_data) + if (fields_desc[x] == 'p') + RECURSE (SCM_PACK (*struct_data)); + if (fields_desc[x] == 'p') + { + if (SCM_LAYOUT_TAILP (fields_desc[x + 1])) + for (x = *struct_data++; x; --x, ++struct_data) + RECURSE (SCM_PACK (*struct_data)); + else + RECURSE (SCM_PACK (*struct_data)); + } + } + /* mark vtable */ + ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]); + goto_gc_mark_loop; } break; case scm_tcs_closures: @@ -1748,28 +1725,15 @@ scm_gc_sweep () switch SCM_TYP7 (scmptr) { - case scm_tcs_cons_gloc: + case scm_tcs_struct: { - /* Dirk:FIXME:: Again, super ugly code: scmptr may be a - * struct or a gloc. See the corresponding comment in - * scm_gc_mark. + /* Structs need to be freed in a special order. + * This is handled by GC C hooks in struct.c. */ - scm_t_bits word0 = (SCM_CELL_WORD_0 (scmptr) - - scm_tc3_cons_gloc); - /* access as struct */ - scm_t_bits * vtable_data = (scm_t_bits *) word0; - if (vtable_data[scm_vtable_index_vcell] == 0) - { - /* Structs need to be freed in a special order. - * This is handled by GC C hooks in struct.c. - */ - SCM_SET_STRUCT_GC_CHAIN (scmptr, scm_structs_to_free); - scm_structs_to_free = scmptr; - continue; - } - /* fall through so that scmptr gets collected */ + SCM_SET_STRUCT_GC_CHAIN (scmptr, scm_structs_to_free); + scm_structs_to_free = scmptr; } - break; + continue; case scm_tcs_cons_imcar: case scm_tcs_cons_nimcar: case scm_tcs_closures: diff --git a/libguile/goops.c b/libguile/goops.c index 8e147bea9..94e7d6847 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1313,7 +1313,7 @@ wrap_init (SCM class, SCM *m, long n) SCM_SET_STRUCT_GC_CHAIN (z, 0); SCM_SET_CELL_WORD_1 (z, m); SCM_SET_CELL_WORD_0 (z, (scm_t_bits) SCM_STRUCT_DATA (class) - | scm_tc3_cons_gloc); + | scm_tc3_struct); return z; } @@ -2594,7 +2594,7 @@ scm_wrap_object (SCM class, void *data) SCM_NEWCELL2 (z); SCM_SETCDR (z, SCM_PACK ((scm_t_bits) data)); SCM_SET_STRUCT_GC_CHAIN (z, 0); - SCM_SETCAR (z, SCM_UNPACK (SCM_CDR (class)) | scm_tc3_cons_gloc); + SCM_SETCAR (z, SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct); return z; } diff --git a/libguile/modules.c b/libguile/modules.c index 062e3f9ee..ed8fdfdda 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -627,7 +627,7 @@ scm_post_boot_init_modules () #define PERM(x) scm_permanent_object(x) SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type")); - scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_cons_gloc); + scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_struct); resolve_module_var = PERM (scm_c_lookup ("resolve-module")); process_define_module_var = PERM (scm_c_lookup ("process-define-module")); diff --git a/libguile/objects.c b/libguile/objects.c index e920ac78d..424cd466e 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -168,8 +168,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, ? SCM_INOUT_PCLASS_INDEX | SCM_PTOBNUM (x) : SCM_OUT_PCLASS_INDEX | SCM_PTOBNUM (x)) : SCM_IN_PCLASS_INDEX | SCM_PTOBNUM (x))]; - case scm_tcs_cons_gloc: - /* must be a struct */ + case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID) return SCM_CLASS_OF (x); else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS) @@ -204,7 +203,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, return scm_class_unknown; } - case scm_tc3_cons_gloc: + case scm_tc3_struct: case scm_tc3_tc7_1: case scm_tc3_tc7_2: case scm_tc3_closure: diff --git a/libguile/print.c b/libguile/print.c index 3873da422..6204a8738 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -397,7 +397,6 @@ SCM_GPROC(s_display, "display", 1, 1, 0, scm_display, g_display); void scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) { -taloop: switch (SCM_ITAG3 (exp)) { case scm_tc3_closure: @@ -451,39 +450,30 @@ taloop: scm_ipruk ("immediate", exp, port); } break; - case scm_tc3_cons_gloc: - /* gloc */ - scm_puts ("#@", port); - exp = scm_module_reverse_lookup (scm_current_module (), - SCM_GLOC_VAR (exp)); - goto taloop; case scm_tc3_cons: switch (SCM_TYP7 (exp)) { - case scm_tcs_cons_gloc: - - if (SCM_STRUCT_VTABLE_DATA (exp) [scm_vtable_index_vcell] == 0) - { - ENTER_NESTED_DATA (pstate, exp, circref); - if (SCM_OBJ_CLASS_FLAGS (exp) & SCM_CLASSF_GOOPS) - { - SCM pwps, print = pstate->writingp ? g_write : g_display; - if (!print) - goto print_struct; - SCM_NEWSMOB (pwps, - scm_tc16_port_with_ps, - SCM_UNPACK (scm_cons (port, pstate->handle))); - scm_call_generic_2 (print, exp, pwps); - } - else - { - print_struct: - scm_print_struct (exp, port, pstate); - } - EXIT_NESTED_DATA (pstate); - break; - } - + case scm_tcs_struct: + { + ENTER_NESTED_DATA (pstate, exp, circref); + if (SCM_OBJ_CLASS_FLAGS (exp) & SCM_CLASSF_GOOPS) + { + SCM pwps, print = pstate->writingp ? g_write : g_display; + if (!print) + goto print_struct; + SCM_NEWSMOB (pwps, + scm_tc16_port_with_ps, + SCM_UNPACK (scm_cons (port, pstate->handle))); + scm_call_generic_2 (print, exp, pwps); + } + else + { + print_struct: + scm_print_struct (exp, port, pstate); + } + EXIT_NESTED_DATA (pstate); + } + break; case scm_tcs_cons_imcar: case scm_tcs_cons_nimcar: ENTER_NESTED_DATA (pstate, exp, circref); @@ -754,9 +744,7 @@ scm_ipruk (char *hdr, SCM ptr, SCM port) } -/* Print a list. The list may be either a list of ordinary data, or it may be - a list that represents code. Lists that represent code may contain gloc - cells. +/* Print a list. */ void scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate) @@ -772,12 +760,12 @@ scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate) O(depth * N) instead of O(N^2). */ hare = SCM_CDR (exp); tortoise = exp; - while (SCM_ECONSP (hare)) + while (SCM_CONSP (hare)) { if (SCM_EQ_P (hare, tortoise)) goto fancy_printing; hare = SCM_CDR (hare); - if (SCM_IMP (hare) || SCM_NECONSP (hare)) + if (SCM_IMP (hare) || SCM_NCONSP (hare)) break; hare = SCM_CDR (hare); tortoise = SCM_CDR (tortoise); @@ -785,7 +773,7 @@ scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate) /* No cdr cycles intrinsic to this list */ scm_iprin1 (SCM_CAR (exp), port, pstate); - for (exp = SCM_CDR (exp); SCM_ECONSP (exp); exp = SCM_CDR (exp)) + for (exp = SCM_CDR (exp); SCM_CONSP (exp); exp = SCM_CDR (exp)) { register long i; @@ -814,7 +802,7 @@ fancy_printing: scm_iprin1 (SCM_CAR (exp), port, pstate); exp = SCM_CDR (exp); --n; - for (; SCM_ECONSP (exp); exp = SCM_CDR (exp)) + for (; SCM_CONSP (exp); exp = SCM_CDR (exp)) { register unsigned long i; diff --git a/libguile/procprop.c b/libguile/procprop.c index d3d63a3dd..e6136527d 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -137,7 +137,7 @@ scm_i_procedure_arity (SCM proc) if (!SCM_NULLP (proc)) r = 1; break; - case scm_tcs_cons_gloc: + case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { r = 1; diff --git a/libguile/procs.c b/libguile/procs.c index 576ca91e6..78b703bca 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -198,7 +198,7 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0, if (SCM_NIMP (obj)) switch (SCM_TYP7 (obj)) { - case scm_tcs_cons_gloc: + case scm_tcs_struct: if (!SCM_I_OPERATORP (obj)) break; case scm_tcs_closures: diff --git a/libguile/srcprop.c b/libguile/srcprop.c index 9f2c89b31..651066135 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -218,7 +218,7 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0, if (SCM_MEMOIZEDP (obj)) obj = SCM_MEMOIZED_EXP (obj); #ifndef SCM_RECKLESS - else if (SCM_NECONSP (obj)) + else if (SCM_NCONSP (obj)) SCM_WRONG_TYPE_ARG (1, obj); #endif p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL); diff --git a/libguile/struct.c b/libguile/struct.c index e4014a9d5..dfc183e42 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -402,8 +402,8 @@ scm_free_structs (void *dummy1 SCM_UNUSED, } else { - scm_t_bits word0 = SCM_CELL_WORD_0 (obj) - scm_tc3_cons_gloc; - /* access as struct */ + /* XXX - use less explicit code. */ + scm_t_bits word0 = SCM_CELL_WORD_0 (obj) - scm_tc3_struct; scm_t_bits * vtable_data = (scm_t_bits *) word0; scm_t_bits * data = SCM_STRUCT_DATA (obj); scm_t_struct_free free_struct_data @@ -470,7 +470,8 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, SCM_SET_CELL_WORD_1 (handle, data); SCM_SET_STRUCT_GC_CHAIN (handle, 0); scm_struct_init (handle, layout, data, tail_elts, init); - SCM_SET_CELL_WORD_0 (handle, (scm_t_bits) SCM_STRUCT_DATA (vtable) + scm_tc3_cons_gloc); + SCM_SET_CELL_WORD_0 (handle, + (scm_t_bits) SCM_STRUCT_DATA (vtable) + scm_tc3_struct); SCM_ALLOW_INTS; return handle; } @@ -551,7 +552,7 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, SCM_SET_STRUCT_GC_CHAIN (handle, 0); data [scm_vtable_index_layout] = SCM_UNPACK (layout); scm_struct_init (handle, layout, data, tail_elts, scm_cons (layout, init)); - SCM_SET_CELL_WORD_0 (handle, (scm_t_bits) data + scm_tc3_cons_gloc); + SCM_SET_CELL_WORD_0 (handle, (scm_t_bits) data + scm_tc3_struct); SCM_ALLOW_INTS; return handle; } diff --git a/libguile/struct.h b/libguile/struct.h index 659052501..ed330818d 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -63,7 +63,7 @@ #define scm_struct_i_size -1 /* Instance size */ #define scm_struct_i_flags -1 /* Upper 12 bits used as flags */ #define scm_vtable_index_layout 0 /* A symbol describing the physical arrangement of this type. */ -#define scm_vtable_index_vcell 1 /* An opaque word, managed by the garbage collector. */ +#define scm_vtable_index_vcell 1 /* XXX - remove this, it is unused. */ #define scm_vtable_index_vtable 2 /* A pointer to the handle for this vtable. */ #define scm_vtable_index_printer 3 /* A printer for this struct type. */ #define scm_vtable_offset_user 4 /* Where do user fields start? */ @@ -75,10 +75,9 @@ typedef size_t (*scm_t_struct_free) (scm_t_bits * vtable, scm_t_bits * data); #define SCM_STRUCTF_LIGHT (1L << 31) /* Light representation (no hidden words) */ -/* Dirk:FIXME:: the SCM_STRUCTP predicate is also fulfilled for glocs */ -#define SCM_STRUCTP(X) (SCM_NIMP(X) && (SCM_TYP3(X) == scm_tc3_cons_gloc)) +#define SCM_STRUCTP(X) (SCM_NIMP(X) && (SCM_TYP3(X) == scm_tc3_struct)) #define SCM_STRUCT_DATA(X) ((scm_t_bits *) SCM_CELL_WORD_1 (X)) -#define SCM_STRUCT_VTABLE_DATA(X) ((scm_t_bits *) (SCM_CELL_WORD_0 (X) - scm_tc3_cons_gloc)) +#define SCM_STRUCT_VTABLE_DATA(X) ((scm_t_bits *) (SCM_CELL_WORD_0 (X) - scm_tc3_struct)) #define SCM_STRUCT_LAYOUT(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_layout])) #define SCM_SET_STRUCT_LAYOUT(X, v) (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_layout] = SCM_UNPACK (v)) diff --git a/libguile/tags.h b/libguile/tags.h index b40fbc754..5dec122fb 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -117,20 +117,24 @@ typedef signed long scm_t_signed_bits; * only (i.e., programmers must keep track of any SCM variables they * create that don't contain ordinary scheme values). * - * All immediates and non-immediates must have a 0 in bit 0. Only - * non-object values can have a 1 in bit 0. In some cases, bit 0 of a - * word in the heap is used for the GC tag so during garbage - * collection, that bit might be 1 even in an immediate or - * non-immediate value. In other cases, bit 0 of a word in the heap - * is used to tag a pointer to a GLOC (VM global variable address) or - * the header of a struct. But whenever an SCM variable holds a - * normal Scheme value, bit 0 is 0. + * 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). * - * Immediates and non-immediates are distinguished by bits two and four. - * Immediate values must have a 1 in at least one of those bits. 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). */ + * 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)) @@ -142,17 +146,17 @@ typedef signed long scm_t_signed_bits; * * * 0 Most objects except... - * 1 ...glocs and structs (this tag valid only in a SCM_CAR or - * in the header of a struct's data). + * 1 ... structs (this tag is valid only in the header + * of a struct's data, as with all odd tags). * * 00 heap addresses and many immediates (not integers) - * 01 glocs/structs, some tc7_ codes + * 01 structs, some tc7_ codes * 10 immediate integers * 11 various tc7_ codes including, tc16_ codes. * * * 000 heap address - * 001 glocs/structs + * 001 structs * 010 integer * 011 closure * 100 immediates @@ -191,33 +195,35 @@ typedef signed long scm_t_signed_bits; * 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-bit aligned address tagged with 011. There are 16 identical 7-bit - * instructions, all ending 011, which are invoked by evaluating closures. + * 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. + * 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). + * 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.) + * 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: * * HEAP CELL: G=gc_mark; 1 during mark, 0 other times. * * cons ..........SCM car..............0 ...........SCM cdr.............G - * gloc ..........SCM vcell..........001 ...........SCM cdr.............G * struct ..........void * type........001 ...........void * data.........G * closure ..........SCM code...........011 ...........SCM env.............G * tc7 ......24.bits of data...Gxxxx1S1 ..........void *data............ @@ -284,17 +290,6 @@ typedef signed long scm_t_signed_bits; #define SCM_CONSP(x) (!SCM_IMP (x) && ((1 & SCM_CELL_TYPE (x)) == 0)) #define SCM_NCONSP(x) (!SCM_CONSP (x)) - -/* SCM_ECONSP should be used instead of SCM_CONSP at places where GLOCS - * can be expected to occur. - */ -#define SCM_ECONSP(x) \ - (!SCM_IMP (x) \ - && (SCM_CONSP (x) \ - || (SCM_TYP3 (x) == 1 \ - && (SCM_STRUCT_VTABLE_DATA (x)[scm_vtable_index_vcell] != 0)))) -#define SCM_NECONSP(x) (!SCM_ECONSP (x)) - #define SCM_CELLP(x) (((sizeof (scm_cell) - 1) & SCM_UNPACK (x)) == 0) @@ -303,11 +298,11 @@ typedef signed long scm_t_signed_bits; /* See numbers.h for macros relating to immediate integers. */ -#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_cons_gloc 1 -#define scm_tc3_int_1 2 +#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 2 #define scm_tc3_closure 3 #define scm_tc3_imm24 4 #define scm_tc3_tc7_1 5 @@ -497,8 +492,10 @@ extern char *scm_isymnames[]; /* defined in print.c */ -/* Dispatching aids: */ +/* Dispatching aids: + When switching on SCM_TYP7 of a SCM value, use these fake case + labels to catch types that use fewer than 7 bits for tagging. */ /* For cons pairs with immediate values in the CAR */ @@ -523,20 +520,22 @@ extern char *scm_isymnames[]; /* defined in print.c */ case 64:case 72:case 80:case 88:\ case 96:case 104:case 112:case 120 -/* A CONS_GLOC occurs in code. It's CAR is a pointer to the - * CDR of a variable. The low order bits of the CAR are 001. - * The CDR of the gloc is the code continuation. +/* For structs */ -#define scm_tcs_cons_gloc 1:case 9:case 17:case 25:\ +#define scm_tcs_struct 1:case 9:case 17:case 25:\ case 33:case 41:case 49:case 57:\ case 65:case 73:case 81:case 89:\ case 97:case 105:case 113:case 121 +/* For closures + */ #define scm_tcs_closures 3:case 11:case 19:case 27:\ case 35:case 43:case 51:case 59:\ case 67:case 75:case 83:case 91:\ case 99:case 107:case 115:case 123 +/* For subrs + */ #define scm_tcs_subrs scm_tc7_asubr:case scm_tc7_subr_0:case scm_tc7_subr_1:case scm_tc7_cxr:\ case scm_tc7_subr_3:case scm_tc7_subr_2:case scm_tc7_rpsubr:case scm_tc7_subr_1o:\ case scm_tc7_subr_2o:case scm_tc7_lsubr_2:case scm_tc7_lsubr From a0f5718e1556066cc536a7871529dc077b70a594 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 26 Jul 2001 21:40:52 +0000 Subject: [PATCH 1554/2047] *** empty log message *** --- libguile/ChangeLog | 43 ++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 42 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 38f7d3b1e..c0267c7c4 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,8 +1,49 @@ 2001-07-26 Marius Vollmer + "Glocs" have been removed. + + * tags.h: Update tag system docs. + (scm_tc3_cons_gloc): Renamed to scm_tc3_struct. Changed all uses. + (scm_tcs_cons_gloc): Renamed to scm_tcs_struct. Changed all uses. + (SCM_ECONSP, SCM_NECONSP): Removed. Changed all uses to SCM_CONSP + or SCM_NCONSP, respectively. + + * struct.c, struct.h, srcprop.c, procs.c, procprop.c, print.c, + objects.c. modules.c, goops.c, eval.c, debug.c: Changed all uses + of scm_tc3_cond_gloc and scm_tcs_cons_gloc. See above. + + * print.c (scm_iprin1): Remove printing of glocs. Do not try to + tell glocs from structs. + + * gc.c (scm_gc_mark, scm_gc_sweep): Remove handling of glocs. + + * eval.c (scm_m_atbind): Make a list of variables, not glocs. + (scm_ceval, scm_deval): For SCM_IM_BIND, fiddle with variables + instead of with glocs. + (EVALCAR): Do not test for glocs. + (scm_lookupcar, scm_lookupcar1): Do not handle glocs in race + condition. + (scm_unmemocar): Do not handle glocs. + (scm_m_atfop): Memoize as a variable, not as a gloc. + (scm_eval_args, scm_deval_args): Do not handle glocs. + (scm_ceval, scm_deval): Likewise. + + * eval.h (SCM_XEVALCAR): Do not test for glocs. + (SCM_GLOC_VAR, SCM_GLOC_VAL, SCM_GLOC_SET_VAL, SCM_GLOC_VAL_LOC): + Removed. + + * debug.h, debug.c (scm_make_gloc, scm_gloc_p): Removed. + + * dynwind.c (scm_swap_bindings): Likewise. + (scm_dowinds): Updated to recognize lists of variables instead of + lists of glocs. + + * __scm.h (SCM_CAUTIOS, SCM_RECKLESS): Update comments. + + * gc_os_dep.c (GC_noop1): Moved into the same #if/#endif context where it is needed. - + 2001-07-25 Gary Houston * numbers.c (scm_logand, scm_logior, scm_logxor): adjusted the From 024001c213e229f9a6ba0066184f59349559003a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 27 Jul 2001 16:11:13 +0000 Subject: [PATCH 1555/2047] Check in forgotten test scripts. --- examples/box-dynamic-module/check.test | 48 +++++++++++++++++++++++ examples/box-dynamic/check.test | 38 ++++++++++++++++++ examples/box-module/check.test | 38 ++++++++++++++++++ examples/box/check.test | 38 ++++++++++++++++++ examples/modules/check.test | 27 +++++++++++++ examples/safe/check.test | 40 +++++++++++++++++++ examples/scripts/check.test | 53 ++++++++++++++++++++++++++ 7 files changed, 282 insertions(+) create mode 100755 examples/box-dynamic-module/check.test create mode 100755 examples/box-dynamic/check.test create mode 100755 examples/box-module/check.test create mode 100755 examples/box/check.test create mode 100755 examples/modules/check.test create mode 100755 examples/safe/check.test create mode 100755 examples/scripts/check.test diff --git a/examples/box-dynamic-module/check.test b/examples/box-dynamic-module/check.test new file mode 100755 index 000000000..935176d20 --- /dev/null +++ b/examples/box-dynamic-module/check.test @@ -0,0 +1,48 @@ +#!/bin/sh + +# must be run from this directory +guile=${GUILE-../../libguile/guile} + +set -e + +# +# ./box test #1 +# +$guile -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline)))' > TMP +cat < +EOF +rm -f TMP + +# +# ./box test #2 +# +$guile -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline)))' > TMP +cat < +# +EOF +rm -f TMP + +# +# ./box test #3 +# +$guile -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline) (display (box-ref b)) (newline)))' > TMP +cat < +# +1 +EOF +rm -f TMP + +# +# ./box test #4 +# +$guile -c '(begin (use-modules (box-mixed)) (let ((b (make-box-list 1 2 3))) (display b) (newline) (display (box-map 1+ b)) (newline)))' > TMP +cat < # #) +(# # #) +EOF +rm -f TMP + +# check.test ends here diff --git a/examples/box-dynamic/check.test b/examples/box-dynamic/check.test new file mode 100755 index 000000000..c0923365c --- /dev/null +++ b/examples/box-dynamic/check.test @@ -0,0 +1,38 @@ +#!/bin/sh + +# must be run from this directory +guile=${GUILE-../../libguile/guile} + +set -e + +# +# ./box test #1 +# +$guile -c '(begin (load-extension "libbox" "scm_init_box") (let ((b (make-box))) (display b) (newline)))' > TMP +cat < +EOF +rm -f TMP + +# +# ./box test #2 +# +$guile -c '(begin (load-extension "libbox" "scm_init_box") (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline)))' > TMP +cat < +# +EOF +rm -f TMP + +# +# ./box test #3 +# +$guile -c '(begin (load-extension "libbox" "scm_init_box") (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline) (display (box-ref b)) (newline)))' > TMP +cat < +# +1 +EOF +rm -f TMP + +# check.test ends here diff --git a/examples/box-module/check.test b/examples/box-module/check.test new file mode 100755 index 000000000..28a79d45b --- /dev/null +++ b/examples/box-module/check.test @@ -0,0 +1,38 @@ +#!/bin/sh + +# must be run from this directory +guile=${GUILE-../../libguile/guile} + +set -e + +# +# ./box test #1 +# +./box -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline)))' > TMP +cat < +EOF +rm -f TMP + +# +# ./box test #2 +# +./box -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline)))' > TMP +cat < +# +EOF +rm -f TMP + +# +# ./box test #3 +# +./box -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline) (display (box-ref b)) (newline)))' > TMP +cat < +# +1 +EOF +rm -f TMP + +# check.test ends here diff --git a/examples/box/check.test b/examples/box/check.test new file mode 100755 index 000000000..1909ffb7e --- /dev/null +++ b/examples/box/check.test @@ -0,0 +1,38 @@ +#!/bin/sh + +# must be run from this directory +guile=${GUILE-../../libguile/guile} + +set -e + +# +# ./box test #1 +# +./box -c '(let ((b (make-box))) (display b) (newline))' > TMP +cat < +EOF +rm -f TMP + +# +# ./box test #2 +# +./box -c '(let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline))' > TMP +cat < +# +EOF +rm -f TMP + +# +# ./box test #3 +# +./box -c '(let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline) (display (box-ref b)) (newline))' > TMP +cat < +# +1 +EOF +rm -f TMP + +# check.test ends here diff --git a/examples/modules/check.test b/examples/modules/check.test new file mode 100755 index 000000000..f7a789b69 --- /dev/null +++ b/examples/modules/check.test @@ -0,0 +1,27 @@ +#!/bin/sh + +# must be run from this directory +guile=${GUILE-../../libguile/guile} + +if test "X$srcdir" = X; then + srcdir=. +fi + +set -e + +# +# ./main test +# +$guile -s $srcdir/main > TMP +cat < TMP +cat < TMP +cat < TMP +cat < TMP +echo "Hello, World!" | diff -u - TMP +rm -f TMP + +$guile -s $srcdir/hello --version > TMP +echo "hello 0.0.1" | diff -u - TMP +rm -f TMP + +$guile -s $srcdir/hello --help > TMP +cat < Date: Sun, 29 Jul 2001 20:39:38 +0000 Subject: [PATCH 1556/2047] (scm_vtable_index_vcell): Removed. Renumbered subsequent indices. --- libguile/struct.h | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/libguile/struct.h b/libguile/struct.h index ed330818d..ec5ae8cff 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -62,11 +62,13 @@ #define scm_struct_i_n_words -2 /* How many words allocated to this struct? */ #define scm_struct_i_size -1 /* Instance size */ #define scm_struct_i_flags -1 /* Upper 12 bits used as flags */ + +/* These indices must correspond to required_vtable_fields in + struct.c. */ #define scm_vtable_index_layout 0 /* A symbol describing the physical arrangement of this type. */ -#define scm_vtable_index_vcell 1 /* XXX - remove this, it is unused. */ -#define scm_vtable_index_vtable 2 /* A pointer to the handle for this vtable. */ -#define scm_vtable_index_printer 3 /* A printer for this struct type. */ -#define scm_vtable_offset_user 4 /* Where do user fields start? */ +#define scm_vtable_index_vtable 1 /* A pointer to the handle for this vtable. */ +#define scm_vtable_index_printer 2 /* A printer for this struct type. */ +#define scm_vtable_offset_user 3 /* Where do user fields start? */ typedef size_t (*scm_t_struct_free) (scm_t_bits * vtable, scm_t_bits * data); From 6902384eb94ed03d85de6a5892357dde6e7dee57 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 29 Jul 2001 20:42:06 +0000 Subject: [PATCH 1557/2047] (scm_struct_vtable_p): Do not check vcell slot for zero. Use scm_vtable_index_layout instead of "0" when accessing said slot. (scm_init_struct): Remove vcell slot layout code from required_vtable_fields. --- libguile/struct.c | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/libguile/struct.c b/libguile/struct.c index dfc183e42..37cc7422d 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -270,10 +270,7 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0, mem = SCM_STRUCT_DATA (x); - if (mem[1] != 0) - return SCM_BOOL_F; - - return SCM_BOOL (SCM_SYMBOLP (SCM_PACK (mem[0]))); + return SCM_BOOL (SCM_SYMBOLP (SCM_PACK (mem[scm_vtable_index_layout]))); } #undef FUNC_NAME @@ -823,7 +820,7 @@ scm_init_struct () { scm_struct_table = scm_permanent_object (scm_make_weak_key_hash_table (SCM_MAKINUM (31))); - required_vtable_fields = scm_makfrom0str ("pruosrpw"); + required_vtable_fields = scm_makfrom0str ("prsrpw"); scm_permanent_object (required_vtable_fields); scm_c_define ("vtable-index-layout", SCM_MAKINUM (scm_vtable_index_layout)); scm_c_define ("vtable-index-vtable", SCM_MAKINUM (scm_vtable_index_vtable)); From e93854046bdec349b6c09704ccca3b805ee30a81 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 29 Jul 2001 20:43:05 +0000 Subject: [PATCH 1558/2047] (scm_si_redefined, scm_si_hashsets): Renumbered. --- libguile/objects.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/objects.h b/libguile/objects.h index 649d3fb1e..a7afb4aa2 100644 --- a/libguile/objects.h +++ b/libguile/objects.h @@ -173,8 +173,8 @@ struct scm_metaclass_operator { #define SCM_CLASSF_PURE_GENERIC (0x010 << 20) #define SCM_CLASSF_GOOPS_VALID (0x080 << 20) #define SCM_CLASSF_GOOPS (0x100 << 20) -#define scm_si_redefined 6 -#define scm_si_hashsets 7 +#define scm_si_redefined 5 +#define scm_si_hashsets 6 #define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x) #define SCM_OBJ_CLASS_REDEF(x) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (x) [scm_si_redefined])) From 7895b092c476aa9020d931c5deb69c3e6c4a1898 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 29 Jul 2001 20:46:23 +0000 Subject: [PATCH 1559/2047] Renumbered slot indices. (SCM_CLASS_CLASS_LAYOUT): Removed vcell slot layout code. (scm_si_vcell): Removed. --- libguile/goops.h | 45 ++++++++++++++++++++++----------------------- 1 file changed, 22 insertions(+), 23 deletions(-) diff --git a/libguile/goops.h b/libguile/goops.h index 574331144..d0b85c684 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -59,34 +59,33 @@ * scm_class_class */ -#define SCM_CLASS_CLASS_LAYOUT "pruosrpwpopopwururururururururpwpwpwpwpwpwpwpwpwpwpwpw" +#define SCM_CLASS_CLASS_LAYOUT "prsrpwpopopwururururururururpwpwpwpwpwpwpwpwpwpwpwpw" #define scm_si_layout 0 /* the struct layout */ -#define scm_si_vcell 1 -#define scm_si_vtable 2 -#define scm_si_print 3 /* the struct print closure */ -#define scm_si_proc 4 -#define scm_si_setter 5 +#define scm_si_vtable 1 +#define scm_si_print 2 /* the struct print closure */ +#define scm_si_proc 3 +#define scm_si_setter 4 -#define scm_si_goops_fields 6 +#define scm_si_goops_fields 5 -/* Defined in libguile/objects.c: -#define scm_si_redefined 6 The class to which class was redefined. -#define scm_si_hashsets 7 +/* Defined in libguile/objects.h: +#define scm_si_redefined 5 The class to which class was redefined. +#define scm_si_hashsets 6 */ -#define scm_si_name 15 /* a symbol */ -#define scm_si_direct_supers 16 /* (class ...) */ -#define scm_si_direct_slots 17 /* ((name . options) ...) */ -#define scm_si_direct_subclasses 18 /* (class ...) */ -#define scm_si_direct_methods 19 /* (methods ...) */ -#define scm_si_cpl 20 /* (class ...) */ -#define scm_si_slotdef_class 21 -#define scm_si_slots 22 /* ((name . options) ...) */ -#define scm_si_name_access 23 -#define scm_si_keyword_access 24 -#define scm_si_nfields 25 /* an integer */ -#define scm_si_environment 26 /* The environment in which class is built */ -#define SCM_N_CLASS_SLOTS 27 +#define scm_si_name 14 /* a symbol */ +#define scm_si_direct_supers 15 /* (class ...) */ +#define scm_si_direct_slots 16 /* ((name . options) ...) */ +#define scm_si_direct_subclasses 17 /* (class ...) */ +#define scm_si_direct_methods 18 /* (methods ...) */ +#define scm_si_cpl 19 /* (class ...) */ +#define scm_si_slotdef_class 20 +#define scm_si_slots 21 /* ((name . options) ...) */ +#define scm_si_name_access 22 +#define scm_si_keyword_access 23 +#define scm_si_nfields 24 /* an integer */ +#define scm_si_environment 25 /* The environment in which class is built */ +#define SCM_N_CLASS_SLOTS 26 typedef struct scm_t_method { SCM generic_function; From c0227bcdb05bea15e0668eb24ec6343ec6eee131 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 29 Jul 2001 20:46:37 +0000 Subject: [PATCH 1560/2047] (build_class_class_slots): Removed vcell slot definition. --- libguile/goops.c | 1 - 1 file changed, 1 deletion(-) diff --git a/libguile/goops.c b/libguile/goops.c index 94e7d6847..b813dad05 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -707,7 +707,6 @@ build_class_class_slots () { return scm_list_n ( scm_list_3 (sym_layout, k_class, scm_class_protected_read_only), - scm_list_3 (sym_vcell, k_class, scm_class_opaque), scm_list_3 (sym_vtable, k_class, scm_class_self), scm_list_1 (sym_print), scm_list_3 (sym_procedure, k_class, scm_class_protected_opaque), From 8b958d72d10255c9f4fb77fe1ac6879afa3ecf5c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 29 Jul 2001 20:48:41 +0000 Subject: [PATCH 1561/2047] (hashset-index): Renumbered, since the vcell slot of structs has been removed. --- oop/goops/dispatch.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/oop/goops/dispatch.scm b/oop/goops/dispatch.scm index d766b637a..cd1c7e698 100644 --- a/oop/goops/dispatch.scm +++ b/oop/goops/dispatch.scm @@ -61,7 +61,7 @@ ;;; (define hashsets 8) -(define hashset-index 7) +(define hashset-index 6) (define hash-threshold 3) (define initial-hash-size 4) ;must be a power of 2 and >= hash-threshold From 54866b6c2012368b0de9675b17a12bd08a7f31d4 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 29 Jul 2001 20:48:52 +0000 Subject: [PATCH 1562/2047] *** empty log message *** --- libguile/ChangeLog | 22 ++++++++++++++++++++++ oop/ChangeLog | 5 +++++ 2 files changed, 27 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index c0267c7c4..901e1b458 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,25 @@ +2001-07-29 Marius Vollmer + + Removed vcell slot from structs. + + * struct.h (scm_vtable_index_vcell): Removed. Renumbered + subsequent indices. + + * struct.c (scm_struct_vtable_p): Do not check vcell slot for + zero. Use scm_vtable_index_layout instead of "0" when accessing + said slot. + (scm_init_struct): Remove vcell slot layout code from + required_vtable_fields. + + * objects.h (scm_si_redefined, scm_si_hashsets): Renumbered. + + * goops.c (build_class_class_slots): Removed vcell slot + definition. + + * goops.h: Renumbered slot indices. (SCM_CLASS_CLASS_LAYOUT): + Removed vcell slot layout code. + (scm_si_vcell): Removed. + 2001-07-26 Marius Vollmer "Glocs" have been removed. diff --git a/oop/ChangeLog b/oop/ChangeLog index 2e82f3a1c..ab927758c 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -1,3 +1,8 @@ +2001-07-29 Marius Vollmer + + * goops/dispatch.scm (hashset-index): Renumbered, since the vcell + slot of structs has been removed. + 2001-07-18 Martin Grabmueller * goops/util.scm: Updated copyright notice. From 6cf695375fe598182b1925a41f6dd9b1e279a11e Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 30 Jul 2001 18:25:14 +0000 Subject: [PATCH 1563/2047] * Use SCM_CONSP, not SCM_ECONSP. --- libguile/ChangeLog | 4 ++++ libguile/pairs.h | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 901e1b458..6cf02a0dd 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2001-07-30 Dirk Herrmann + + * pairs.h (SCM_VALIDATE_PAIR): Use SCM_CONSP, not SCM_ECONSP. + 2001-07-29 Marius Vollmer Removed vcell slot from structs. diff --git a/libguile/pairs.h b/libguile/pairs.h index 6b808f886..ff6bddc5b 100644 --- a/libguile/pairs.h +++ b/libguile/pairs.h @@ -53,7 +53,7 @@ #if (SCM_DEBUG_PAIR_ACCESSES == 1) # include "libguile/struct.h" # define SCM_VALIDATE_PAIR(cell, expr) \ - ((!SCM_ECONSP (cell) ? scm_error_pair_access (cell), 0 : 0), (expr)) + ((!SCM_CONSP (cell) ? scm_error_pair_access (cell), 0 : 0), (expr)) #else # define SCM_VALIDATE_PAIR(cell, expr) (expr) #endif From 01f11e027e9978fe04e8cecb5ebffcd2eea8eccf Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 30 Jul 2001 18:55:50 +0000 Subject: [PATCH 1564/2047] * Minor changes. --- libguile/ChangeLog | 12 ++++++++ libguile/eval.c | 71 ++++++++++++++++++++++------------------------ 2 files changed, 46 insertions(+), 37 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6cf02a0dd..3b1c32fbe 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,15 @@ +2001-07-30 Dirk Herrmann + + * eval.c (scm_lookupcar, scm_m_body, scm_m_lambda, unmemocopy, + scm_unmemocopy, scm_badargsp, scm_eval_body, CHECK_EQVISH, + SCM_CEVAL, scm_nconc2last, SCM_APPLY, scm_copy_tree): Prefer + !SCM_ over SCM_N. + + (scm_eval_body): Remove side effecting code from macro call. + + (SCM_CEVAL, SCM_APPLY): Remove goto statement and redundant + SCM_NIMP test. + 2001-07-30 Dirk Herrmann * pairs.h (SCM_VALIDATE_PAIR): Use SCM_CONSP, not SCM_ECONSP. diff --git a/libguile/eval.c b/libguile/eval.c index ff681d86d..f598f370d 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -278,7 +278,7 @@ scm_lookupcar (SCM vloc, SCM genv, int check) al = SCM_CARLOC (env); for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl)) { - if (SCM_NCONSP (fl)) + if (!SCM_CONSP (fl)) { if (SCM_EQ_P (fl, var)) { @@ -336,7 +336,7 @@ scm_lookupcar (SCM vloc, SCM genv, int check) goto errout; #ifndef SCM_RECKLESS - if (SCM_NNULLP (env) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var))) + if (!SCM_NULLP (env) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var))) { errout: /* scm_everr (vloc, genv,...) */ @@ -501,7 +501,7 @@ scm_m_body (SCM op, SCM xorig, const char *what) /* Retain possible doc string. */ if (!SCM_CONSP (SCM_CAR (xorig))) { - if (SCM_NNULLP (SCM_CDR(xorig))) + if (!SCM_NULLP (SCM_CDR(xorig))) return scm_cons (SCM_CAR (xorig), scm_m_body (op, SCM_CDR(xorig), what)); return xorig; @@ -673,11 +673,11 @@ scm_m_lambda (SCM xorig, SCM env SCM_UNUSED) goto badforms; if (SCM_SYMBOLP (proc)) goto memlambda; - if (SCM_NCONSP (proc)) + if (!SCM_CONSP (proc)) goto badforms; while (SCM_NIMP (proc)) { - if (SCM_NCONSP (proc)) + if (!SCM_CONSP (proc)) { if (!SCM_SYMBOLP (proc)) goto badforms; @@ -690,7 +690,7 @@ scm_m_lambda (SCM xorig, SCM env SCM_UNUSED) scm_misc_error (s_lambda, scm_s_duplicate_formals, SCM_EOL); proc = SCM_CDR (proc); } - if (SCM_NNULLP (proc)) + if (!SCM_NULLP (proc)) { badforms: scm_misc_error (s_lambda, scm_s_formals, SCM_EOL); @@ -1279,7 +1279,7 @@ unmemocopy (SCM x, SCM env) #ifdef DEBUG_EXTENSIONS SCM p; #endif - if (SCM_NCELLP (x) || SCM_NCONSP (x)) + if (!SCM_CELLP (x) || !SCM_CONSP (x)) return x; #ifdef DEBUG_EXTENSIONS p = scm_whash_lookup (scm_source_whash, x); @@ -1414,7 +1414,7 @@ unmemocopy (SCM x, SCM env) x = SCM_CDR (x); ls = scm_cons (scm_sym_define, z = scm_cons (n = SCM_CAR (x), SCM_UNSPECIFIED)); - if (SCM_NNULLP (env)) + if (!SCM_NULLP (env)) SCM_SETCAR (SCM_CAR (env), scm_cons (n, SCM_CAR (SCM_CAR (env)))); break; } @@ -1459,7 +1459,7 @@ loop: } SCM_SETCDR (z, x); #ifdef DEBUG_EXTENSIONS - if (SCM_NFALSEP (p)) + if (!SCM_FALSEP (p)) scm_whash_insert (scm_source_whash, ls, p); #endif return ls; @@ -1469,7 +1469,7 @@ loop: SCM scm_unmemocopy (SCM x, SCM env) { - if (SCM_NNULLP (env)) + if (!SCM_NULLP (env)) /* Make a copy of the lowest frame to protect it from modifications by SCM_IM_DEFINE */ return unmemocopy (x, scm_cons (SCM_CAR (env), SCM_CDR (env))); @@ -1484,14 +1484,14 @@ scm_badargsp (SCM formals, SCM args) { while (SCM_NIMP (formals)) { - if (SCM_NCONSP (formals)) + if (!SCM_CONSP (formals)) return 0; if (SCM_IMP(args)) return 1; formals = SCM_CDR (formals); args = SCM_CDR (args); } - return SCM_NNULLP (args) ? 1 : 0; + return !SCM_NULLP (args) ? 1 : 0; } #endif @@ -1536,8 +1536,8 @@ scm_eval_body (SCM code, SCM env) { SCM next; again: - next = code; - while (SCM_NNULLP (next = SCM_CDR (next))) + next = SCM_CDR (code); + while (!SCM_NULLP (next)) { if (SCM_IMP (SCM_CAR (code))) { @@ -1550,6 +1550,7 @@ scm_eval_body (SCM code, SCM env) else SCM_XEVAL (SCM_CAR (code), env); code = next; + next = SCM_CDR (code); } return SCM_XEVALCAR (code, env); } @@ -1755,7 +1756,7 @@ scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc) } while (0) #ifndef DEVAL -#define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B))))) +#define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (!SCM_FALSEP (scm_eqv_p ((A), (B))))) #endif /* DEVAL */ #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */ @@ -1893,7 +1894,7 @@ dispatch: case SCM_BIT8(SCM_IM_AND): x = SCM_CDR (x); t.arg1 = x; - while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) + while (!SCM_NULLP (t.arg1 = SCM_CDR (t.arg1))) if (SCM_FALSEP (EVALCAR (x, env))) { RETURN (SCM_BOOL_F); @@ -2001,7 +2002,7 @@ dispatch: { proc = SCM_CAR (x); t.arg1 = EVALCAR (proc, env); - if (SCM_NFALSEP (t.arg1)) + if (!SCM_FALSEP (t.arg1)) { x = SCM_CDR (proc); if (SCM_NULLP (x)) @@ -2059,7 +2060,7 @@ dispatch: case SCM_BIT8(SCM_IM_IF): x = SCM_CDR (x); - if (SCM_NFALSEP (EVALCAR (x, env))) + if (!SCM_FALSEP (EVALCAR (x, env))) x = SCM_CDR (x); else if (SCM_IMP (x = SCM_CDR (SCM_CDR (x)))) { @@ -2246,7 +2247,7 @@ dispatch: PREP_APPLY (SCM_UNDEFINED, SCM_EOL); if (SCM_IMP (proc)) arg2 = *scm_ilookup (proc, env); - else if (SCM_NCONSP (proc)) + else if (!SCM_CONSP (proc)) { if (SCM_VARIABLEP (proc)) arg2 = SCM_VARIABLE_REF (proc); @@ -2377,7 +2378,7 @@ dispatch: case (SCM_ISYMNUM (SCM_IM_T_IFY)): x = SCM_CDR (x); - RETURN (SCM_NFALSEP (EVALCAR (x, env)) ? scm_lisp_t : scm_lisp_nil) + RETURN (!SCM_FALSEP (EVALCAR (x, env)) ? scm_lisp_t : scm_lisp_nil) case (SCM_ISYMNUM (SCM_IM_0_COND)): proc = SCM_CDR (x); @@ -2405,7 +2406,7 @@ dispatch: case (SCM_ISYMNUM (SCM_IM_1_IFY)): x = SCM_CDR (x); - RETURN (SCM_NFALSEP (EVALCAR (x, env)) + RETURN (!SCM_FALSEP (EVALCAR (x, env)) ? SCM_MAKINUM (1) : SCM_INUM0) @@ -2426,7 +2427,7 @@ dispatch: scm_dynwinds = scm_acons (t.arg1, SCM_CDAR (env), scm_dynwinds); arg2 = x = SCM_CDR (x); - while (SCM_NNULLP (arg2 = SCM_CDR (arg2))) + while (!SCM_NULLP (arg2 = SCM_CDR (arg2))) { SIDEVAL (SCM_CAR (x), env); x = arg2; @@ -2733,18 +2734,16 @@ evapply: { RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (t.arg1)))); } - SCM_ASRTGO (SCM_NIMP (t.arg1), floerr); - if (SCM_REALP (t.arg1)) + else if (SCM_REALP (t.arg1)) { RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (t.arg1)))); } #ifdef SCM_BIGDIG - if (SCM_BIGP (t.arg1)) + else if (SCM_BIGP (t.arg1)) { RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (t.arg1)))); } #endif - floerr: SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), t.arg1, SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); } @@ -2962,7 +2961,7 @@ evapply: } } #ifdef SCM_CAUTIOUS - if (SCM_IMP (x) || SCM_NCONSP (x)) + if (SCM_IMP (x) || !SCM_CONSP (x)) goto wrongnumargs; #endif #ifdef DEVAL @@ -3269,7 +3268,7 @@ SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0, SCM *lloc; SCM_VALIDATE_NONEMPTYLIST (1,lst); lloc = &lst; - while (SCM_NNULLP (SCM_CDR (*lloc))) + while (!SCM_NULLP (SCM_CDR (*lloc))) lloc = SCM_CDRLOC (*lloc); SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME); *lloc = SCM_CAR (*lloc); @@ -3395,7 +3394,7 @@ tail: args = SCM_NULLP (args) ? SCM_UNDEFINED : SCM_CAR (args); RETURN (SCM_SUBRF (proc) (arg1, args)) case scm_tc7_subr_2: - SCM_ASRTGO (SCM_NNULLP (args) && SCM_NULLP (SCM_CDR (args)), + SCM_ASRTGO (!SCM_NULLP (args) && SCM_NULLP (SCM_CDR (args)), wrongnumargs); args = SCM_CAR (args); RETURN (SCM_SUBRF (proc) (arg1, args)) @@ -3415,16 +3414,14 @@ tail: { RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)))); } - SCM_ASRTGO (SCM_NIMP (arg1), floerr); - if (SCM_REALP (arg1)) + else if (SCM_REALP (arg1)) { RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); } #ifdef SCM_BIGDIG - if (SCM_BIGP (arg1)) + else if (SCM_BIGP (arg1)) RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))) #endif - floerr: SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); } @@ -3440,8 +3437,8 @@ tail: RETURN (arg1) } case scm_tc7_subr_3: - SCM_ASRTGO (SCM_NNULLP (args) - && SCM_NNULLP (SCM_CDR (args)) + SCM_ASRTGO (!SCM_NULLP (args) + && !SCM_NULLP (SCM_CDR (args)) && SCM_NULLP (SCM_CDDR (args)), wrongnumargs); RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CAR (SCM_CDR (args)))) @@ -3506,7 +3503,7 @@ tail: proc = SCM_CDR (SCM_CODE (proc)); again: arg1 = proc; - while (SCM_NNULLP (arg1 = SCM_CDR (arg1))) + while (!SCM_NULLP (arg1 = SCM_CDR (arg1))) { if (SCM_IMP (SCM_CAR (proc))) { @@ -3872,7 +3869,7 @@ SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0, SCM_VELTS (ans)[i] = scm_copy_tree (SCM_VELTS (obj)[i]); return ans; } - if (SCM_NCONSP (obj)) + if (!SCM_CONSP (obj)) return obj; ans = tl = scm_cons_source (obj, scm_copy_tree (SCM_CAR (obj)), From 3c9a524f01b3054b03c25638f8e29c533e8057f0 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 30 Jul 2001 19:35:15 +0000 Subject: [PATCH 1565/2047] * Rewrote string->number stuff. --- libguile/ChangeLog | 33 ++ libguile/numbers.c | 1098 +++++++++++++++++++++++--------------------- libguile/numbers.h | 20 +- libguile/read.c | 47 +- 4 files changed, 649 insertions(+), 549 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 3b1c32fbe..b21e6a6c6 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,36 @@ +2001-07-30 Dirk Herrmann + + * numbers.c (DIGITS, scm_small_istr2int, scm_istr2int, + scm_istr2flo, scm_istring2number): Removed. + + (iflo2str, scm_real_p, scm_integer_p): Use SCM_ instead of + SCM_SLOPPY_. + + (t_exactness, t_radix, DIGIT2UINT, XDIGIT2UINT, mem2uinteger, + mem2decimal_from_point, mem2ureal, mem2complex, scm_i_mem2number): + Added. + + (scm_string_to_number): Use new number parser. + + (scm_exact_to_inexact): Replace dummy by a GPROC, which also + handles complex numbers. + + * numbers.h (NUMBERSH, SCM_NUMBERS_H): Rename H to + SCM__H. + + (SCM_INEXACTP, SCM_REALP, SCM_COMPLEXP): Prefer !SCM_ over + SCM_N. + + (scm_istr2int, scm_istr2flo, scm_istring2number): Removed. + + (scm_i_mem2number): Added. + + (scm_exact_to_inexact): Changed signature. + + * read.c (scm_lreadr): Perform the shortcut test for '+ and '- + here instead of within scm_i_mem2number. Call scm_i_mem2number + instead of scm_istr2int and scm_istring2number. + 2001-07-30 Dirk Herrmann * eval.c (scm_lookupcar, scm_m_body, scm_m_lambda, unmemocopy, diff --git a/libguile/numbers.c b/libguile/numbers.c index 0fc136cce..1a6ff53c1 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -43,6 +43,7 @@ #include +#include #include "libguile/_scm.h" #include "libguile/feature.h" #include "libguile/ports.h" @@ -60,10 +61,6 @@ static SCM scm_divbigbig (SCM_BIGDIG *x, size_t nx, SCM_BIGDIG *y, size_t ny, in static SCM scm_divbigint (SCM x, long z, int sgn, int mode); -#define DIGITS '0':case '1':case '2':case '3':case '4':\ - case '5':case '6':case '7':case '8':case '9' - - #define SCM_SWAP(x,y) do { SCM __t = x; x = y; y = __t; } while (0) @@ -2063,7 +2060,7 @@ static size_t iflo2str (SCM flt, char *str) { size_t i; - if (SCM_SLOPPY_REALP (flt)) + if (SCM_REALP (flt)) i = idbl2str (SCM_REAL_VALUE (flt), str); else { @@ -2229,518 +2226,573 @@ scm_bigprint (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) } /*** END nums->strs ***/ + /*** STRINGS -> NUMBERS ***/ +/* The following functions implement the conversion from strings to numbers. + * The implementation somehow follows the grammar for numbers as it is given + * in R5RS. Thus, the functions resemble syntactic units (, + * , ...) that are used to build up numbers in the grammar. Some + * points should be noted about the implementation: + * * Each function keeps a local index variable 'idx' that points at the + * current position within the parsed string. The global index is only + * updated if the function could parse the corresponding syntactic unit + * successfully. + * * Similarly, the functions keep track of indicators of inexactness ('#', + * '.' or exponents) using local variables ('hash_seen', 'x'). Again, the + * global exactness information is only updated after each part has been + * successfully parsed. + * * Sequences of digits are parsed into temporary variables holding fixnums. + * Only if these fixnums would overflow, the result variables are updated + * using the standard functions scm_add, scm_product, scm_divide etc. Then, + * the temporary variables holding the fixnums are cleared, and the process + * starts over again. If for example fixnums were able to store five decimal + * digits, a number 1234567890 would be parsed in two parts 12345 and 67890, + * and the result was computed as 12345 * 100000 + 67890. In other words, + * only every five digits two bignum operations were performed. + */ + +enum t_exactness {NO_EXACTNESS, INEXACT, EXACT}; + +/* R5RS, section 7.1.1, lexical structure of numbers: . */ + +/* In non ASCII-style encodings the following macro might not work. */ +#define XDIGIT2UINT(d) (isdigit (d) ? (d) - '0' : tolower (d) - 'a' + 10) + static SCM -scm_small_istr2int (char *str, long len, long radix) +mem2uinteger (const char* mem, size_t len, unsigned int *p_idx, + unsigned int radix, enum t_exactness *p_exactness) { - register long n = 0, ln; - register int c; - register int i = 0; - int lead_neg = 0; - if (0 >= len) - return SCM_BOOL_F; /* zero scm_length */ - switch (*str) - { /* leading sign */ - case '-': - lead_neg = 1; - case '+': - if (++i == len) - return SCM_BOOL_F; /* bad if lone `+' or `-' */ - } + unsigned int idx = *p_idx; + unsigned int hash_seen = 0; + scm_t_bits shift = 1; + scm_t_bits add = 0; + unsigned int digit_value; + SCM result; + char c; - do - { - switch (c = str[i++]) - { - case DIGITS: - c = c - '0'; - goto accumulate; - case 'A': - case 'B': - case 'C': - case 'D': - case 'E': - case 'F': - c = c - 'A' + 10; - goto accumulate; - case 'a': - case 'b': - case 'c': - case 'd': - case 'e': - case 'f': - c = c - 'a' + 10; - accumulate: - if (c >= radix) - return SCM_BOOL_F; /* bad digit for radix */ - ln = n; - n = n * radix - c; - /* Negation is a workaround for HP700 cc bug */ - if (n > ln || (-n > -SCM_MOST_NEGATIVE_FIXNUM)) - goto ovfl; - break; - default: - return SCM_BOOL_F; /* not a digit */ - } - } - while (i < len); - if (!lead_neg) - if ((n = -n) > SCM_MOST_POSITIVE_FIXNUM) - goto ovfl; - return SCM_MAKINUM (n); - ovfl: /* overflow scheme integer */ - return SCM_BOOL_F; -} - - - -SCM -scm_istr2int (char *str, long len, long radix) -{ - size_t j; - register size_t k, blen = 1; - size_t i = 0; - int c; - SCM res; - register SCM_BIGDIG *ds; - register unsigned long t2; - - if (0 >= len) - return SCM_BOOL_F; /* zero scm_length */ - - /* Short numbers we parse directly into an int, to avoid the overhead - of creating a bignum. */ - if (len < 6) - return scm_small_istr2int (str, len, radix); - - if (16 == radix) - j = 1 + (4 * len * sizeof (char)) / (SCM_BITSPERDIG); - else if (10 <= radix) - j = 1 + (84 * len * sizeof (char)) / (SCM_BITSPERDIG * 25); - else - j = 1 + (len * sizeof (char)) / (SCM_BITSPERDIG); - switch (str[0]) - { /* leading sign */ - case '-': - case '+': - if (++i == (unsigned) len) - return SCM_BOOL_F; /* bad if lone `+' or `-' */ - } - res = scm_i_mkbig (j, '-' == str[0]); - ds = SCM_BDIGITS (res); - for (k = j; k--;) - ds[k] = 0; - do - { - switch (c = str[i++]) - { - case DIGITS: - c = c - '0'; - goto accumulate; - case 'A': - case 'B': - case 'C': - case 'D': - case 'E': - case 'F': - c = c - 'A' + 10; - goto accumulate; - case 'a': - case 'b': - case 'c': - case 'd': - case 'e': - case 'f': - c = c - 'a' + 10; - accumulate: - if (c >= radix) - return SCM_BOOL_F; /* bad digit for radix */ - k = 0; - t2 = c; - moretodo: - while (k < blen) - { -/* printf ("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]); */ - t2 += ds[k] * radix; - ds[k++] = SCM_BIGLO (t2); - t2 = SCM_BIGDN (t2); - } - if (blen > j) - scm_num_overflow ("bignum"); - if (t2) - { - blen++; - goto moretodo; - } - break; - default: - return SCM_BOOL_F; /* not a digit */ - } - } - while (i < (unsigned) len); - if (blen * SCM_BITSPERDIG / SCM_CHAR_BIT <= sizeof (SCM)) - if (SCM_INUMP (res = scm_i_big2inum (res, blen))) - return res; - if (j == blen) - return res; - return scm_i_adjbig (res, blen); -} - -SCM -scm_istr2flo (char *str, long len, long radix) -{ - register int c, i = 0; - double lead_sgn; - double res = 0.0, tmp = 0.0; - int flg = 0; - int point = 0; - SCM second; - - if (i >= len) - return SCM_BOOL_F; /* zero scm_length */ - - switch (*str) - { /* leading sign */ - case '-': - lead_sgn = -1.0; - i++; - break; - case '+': - lead_sgn = 1.0; - i++; - break; - default: - lead_sgn = 0.0; - } - if (i == len) - return SCM_BOOL_F; /* bad if lone `+' or `-' */ - - if (str[i] == 'i' || str[i] == 'I') - { /* handle `+i' and `-i' */ - if (lead_sgn == 0.0) - return SCM_BOOL_F; /* must have leading sign */ - if (++i < len) - return SCM_BOOL_F; /* `i' not last character */ - return scm_make_complex (0.0, lead_sgn); - } - do - { /* check initial digits */ - switch (c = str[i]) - { - case DIGITS: - c = c - '0'; - goto accum1; - case 'D': - case 'E': - case 'F': - if (radix == 10) - goto out1; /* must be exponent */ - case 'A': - case 'B': - case 'C': - c = c - 'A' + 10; - goto accum1; - case 'd': - case 'e': - case 'f': - if (radix == 10) - goto out1; - case 'a': - case 'b': - case 'c': - c = c - 'a' + 10; - accum1: - if (c >= radix) - return SCM_BOOL_F; /* bad digit for radix */ - res = res * radix + c; - flg = 1; /* res is valid */ - break; - default: - goto out1; - } - } - while (++i < len); - out1: - - /* if true, then we did see a digit above, and res is valid */ - if (i == len) - goto done; - - /* By here, must have seen a digit, - or must have next char be a `.' with radix==10 */ - if (!flg) - if (!(str[i] == '.' && radix == 10)) - return SCM_BOOL_F; - - while (str[i] == '#') - { /* optional sharps */ - res *= radix; - if (++i == len) - goto done; - } - - if (str[i] == '/') - { - while (++i < len) - { - switch (c = str[i]) - { - case DIGITS: - c = c - '0'; - goto accum2; - case 'A': - case 'B': - case 'C': - case 'D': - case 'E': - case 'F': - c = c - 'A' + 10; - goto accum2; - case 'a': - case 'b': - case 'c': - case 'd': - case 'e': - case 'f': - c = c - 'a' + 10; - accum2: - if (c >= radix) - return SCM_BOOL_F; - tmp = tmp * radix + c; - break; - default: - goto out2; - } - } - out2: - if (tmp == 0.0) - return SCM_BOOL_F; /* `slash zero' not allowed */ - if (i < len) - while (str[i] == '#') - { /* optional sharps */ - tmp *= radix; - if (++i == len) - break; - } - res /= tmp; - goto done; - } - - if (str[i] == '.') - { /* decimal point notation */ - if (radix != 10) - return SCM_BOOL_F; /* must be radix 10 */ - while (++i < len) - { - switch (c = str[i]) - { - case DIGITS: - point--; - res = res * 10.0 + c - '0'; - flg = 1; - break; - default: - goto out3; - } - } - out3: - if (!flg) - return SCM_BOOL_F; /* no digits before or after decimal point */ - if (i == len) - goto adjust; - while (str[i] == '#') - { /* ignore remaining sharps */ - if (++i == len) - goto adjust; - } - } - - switch (str[i]) - { /* exponent */ - case 'd': - case 'D': - case 'e': - case 'E': - case 'f': - case 'F': - case 'l': - case 'L': - case 's': - case 'S': - { - int expsgn = 1, expon = 0; - if (radix != 10) - return SCM_BOOL_F; /* only in radix 10 */ - if (++i == len) - return SCM_BOOL_F; /* bad exponent */ - switch (str[i]) - { - case '-': - expsgn = (-1); - case '+': - if (++i == len) - return SCM_BOOL_F; /* bad exponent */ - } - if (str[i] < '0' || str[i] > '9') - return SCM_BOOL_F; /* bad exponent */ - do - { - switch (c = str[i]) - { - case DIGITS: - expon = expon * 10 + c - '0'; - if (expon > SCM_MAXEXP) - scm_out_of_range ("string->number", SCM_MAKINUM (expon)); - break; - default: - goto out4; - } - } - while (++i < len); - out4: - point += expsgn * expon; - } - } - - adjust: - if (point >= 0) - while (point--) - res *= 10.0; - else -#ifdef _UNICOS - while (point++) - res *= 0.1; -#else - while (point++) - res /= 10.0; -#endif - - done: - /* at this point, we have a legitimate floating point result */ - if (lead_sgn == -1.0) - res = -res; - if (i == len) - return scm_make_real (res); - - if (str[i] == 'i' || str[i] == 'I') - { /* pure imaginary number */ - if (lead_sgn == 0.0) - return SCM_BOOL_F; /* must have leading sign */ - if (++i < len) - return SCM_BOOL_F; /* `i' not last character */ - return scm_make_complex (0.0, res); - } - - switch (str[i++]) - { - case '-': - lead_sgn = -1.0; - break; - case '+': - lead_sgn = 1.0; - break; - case '@': - { /* polar input for complex number */ - /* get a `real' for scm_angle */ - second = scm_istr2flo (&str[i], (long) (len - i), radix); - if (!SCM_SLOPPY_INEXACTP (second)) - return SCM_BOOL_F; /* not `real' */ - if (SCM_SLOPPY_COMPLEXP (second)) - return SCM_BOOL_F; /* not `real' */ - tmp = SCM_REAL_VALUE (second); - return scm_make_complex (res * cos (tmp), res * sin (tmp)); - } - default: - return SCM_BOOL_F; - } - - /* at this point, last char must be `i' */ - if (str[len - 1] != 'i' && str[len - 1] != 'I') + if (idx == len) return SCM_BOOL_F; - /* handles `x+i' and `x-i' */ - if (i == (len - 1)) - return scm_make_complex (res, lead_sgn); - /* get a `ureal' for complex part */ - second = scm_istr2flo (&str[i], (long) ((len - i) - 1), radix); - if (!SCM_INEXACTP (second)) - return SCM_BOOL_F; /* not `ureal' */ - if (SCM_SLOPPY_COMPLEXP (second)) - return SCM_BOOL_F; /* not `ureal' */ - tmp = SCM_REAL_VALUE (second); - if (tmp < 0.0) - return SCM_BOOL_F; /* not `ureal' */ - return scm_make_complex (res, (lead_sgn * tmp)); + + c = mem[idx]; + if (!isxdigit (c)) + return SCM_BOOL_F; + digit_value = XDIGIT2UINT (c); + if (digit_value >= radix) + return SCM_BOOL_F; + + idx++; + result = SCM_MAKINUM (digit_value); + while (idx != len) + { + char c = mem[idx]; + if (isxdigit (c)) + { + if (hash_seen) + return SCM_BOOL_F; + digit_value = XDIGIT2UINT (c); + if (digit_value >= radix) + return SCM_BOOL_F; + } + else if (c == '#') + { + hash_seen = 1; + digit_value = 0; + } + else + break; + + idx++; + if (SCM_MOST_POSITIVE_FIXNUM / radix < shift) + { + result = scm_product (result, SCM_MAKINUM (shift)); + if (add > 0) + result = scm_sum (result, SCM_MAKINUM (add)); + + shift = radix; + add = digit_value; + } + else + { + shift = shift * radix; + add = add * radix + digit_value; + } + }; + + if (shift > 1) + result = scm_product (result, SCM_MAKINUM (shift)); + if (add > 0) + result = scm_sum (result, SCM_MAKINUM (add)); + + *p_idx = idx; + if (hash_seen) + *p_exactness = INEXACT; + + return result; } +/* R5RS, section 7.1.1, lexical structure of numbers: . Only + * covers the parts of the rules that start at a potential point. The value + * of the digits up to the point have been parsed by the caller and are given + * in variable prepoint. The content of *p_exactness indicates, whether a + * hash has already been seen in the digits before the point. + */ + +/* In non ASCII-style encodings the following macro might not work. */ +#define DIGIT2UINT(d) ((d) - '0') + +static SCM +mem2decimal_from_point (SCM prepoint, const char* mem, size_t len, + unsigned int *p_idx, enum t_exactness *p_exactness) +{ + unsigned int idx = *p_idx; + enum t_exactness x = *p_exactness; + SCM big_shift = SCM_MAKINUM (1); + SCM big_add = SCM_MAKINUM (0); + SCM result; + + if (idx == len) + return prepoint; + + if (mem[idx] == '.') + { + scm_t_bits shift = 1; + scm_t_bits add = 0; + unsigned int digit_value; + + idx++; + while (idx != len) + { + char c = mem[idx]; + if (isdigit (c)) + { + if (x == INEXACT) + return SCM_BOOL_F; + else + digit_value = DIGIT2UINT (c); + } + else if (c == '#') + { + x = INEXACT; + digit_value = 0; + } + else + break; + + idx++; + if (SCM_MOST_POSITIVE_FIXNUM / 10 < shift) + { + big_shift = scm_product (big_shift, SCM_MAKINUM (shift)); + big_add = scm_product (big_add, SCM_MAKINUM (shift)); + if (add > 0) + big_add = scm_sum (big_add, SCM_MAKINUM (add)); + + shift = 10; + add = digit_value; + } + else + { + shift = shift * 10; + add = add * 10 + digit_value; + } + }; + + if (add > 0) + { + big_shift = scm_product (big_shift, SCM_MAKINUM (shift)); + big_add = scm_product (big_add, SCM_MAKINUM (shift)); + big_add = scm_sum (big_add, SCM_MAKINUM (add)); + } + + /* We've seen a decimal point, thus the value is implicitly inexact. */ + x = INEXACT; + } + + big_add = scm_divide (big_add, big_shift); + result = scm_sum (prepoint, big_add); + + if (idx != len) + { + int sign = 1; + unsigned int start; + char c; + int exponent; + SCM e; + + /* R5RS, section 7.1.1, lexical structure of numbers: */ + + switch (mem[idx]) + { + case 'd': case 'D': + case 'e': case 'E': + case 'f': case 'F': + case 'l': case 'L': + case 's': case 'S': + idx++; + start = idx; + c = mem[idx]; + if (c == '-') + { + idx++; + sign = -1; + c = mem[idx]; + } + else if (c == '+') + { + idx++; + sign = 1; + c = mem[idx]; + } + else + sign = 1; + + if (!isdigit (c)) + return SCM_BOOL_F; + + idx++; + exponent = DIGIT2UINT (c); + while (idx != len) + { + char c = mem[idx]; + if (isdigit (c)) + { + idx++; + if (exponent <= SCM_MAXEXP) + exponent = exponent * 10 + DIGIT2UINT (c); + } + else + break; + } + + if (exponent > SCM_MAXEXP) + { + size_t exp_len = idx - start; + SCM exp_string = scm_mem2string (&mem[start], exp_len); + SCM exp_num = scm_string_to_number (exp_string, SCM_UNDEFINED); + scm_out_of_range ("string->number", exp_num); + } + + e = scm_integer_expt (SCM_MAKINUM (10), SCM_MAKINUM (exponent)); + if (sign == 1) + result = scm_product (result, e); + else + result = scm_divide (result, e); + + /* We've seen an exponent, thus the value is implicitly inexact. */ + x = INEXACT; + + break; + + default: + break; + } + } + + *p_idx = idx; + if (x == INEXACT) + *p_exactness = x; + + return result; +} + + +/* R5RS, section 7.1.1, lexical structure of numbers: */ + +static SCM +mem2ureal (const char* mem, size_t len, unsigned int *p_idx, + unsigned int radix, enum t_exactness *p_exactness) +{ + unsigned int idx = *p_idx; + + if (idx == len) + return SCM_BOOL_F; + + if (mem[idx] == '.') + { + if (radix != 10) + return SCM_BOOL_F; + else if (idx + 1 == len) + return SCM_BOOL_F; + else if (!isdigit (mem[idx + 1])) + return SCM_BOOL_F; + else + return mem2decimal_from_point (SCM_MAKINUM (0), mem, len, + p_idx, p_exactness); + } + else + { + enum t_exactness x = EXACT; + SCM uinteger; + SCM result; + + uinteger = mem2uinteger (mem, len, &idx, radix, &x); + if (SCM_FALSEP (uinteger)) + return SCM_BOOL_F; + + if (idx == len) + result = uinteger; + else if (mem[idx] == '/') + { + SCM divisor; + + idx++; + + divisor = mem2uinteger (mem, len, &idx, radix, &x); + if (SCM_FALSEP (divisor)) + return SCM_BOOL_F; + + result = scm_divide (uinteger, divisor); + } + else if (radix == 10) + { + result = mem2decimal_from_point (uinteger, mem, len, &idx, &x); + if (SCM_FALSEP (result)) + return SCM_BOOL_F; + } + else + result = uinteger; + + *p_idx = idx; + if (x == INEXACT) + *p_exactness = x; + + return result; + } +} + + +/* R5RS, section 7.1.1, lexical structure of numbers: */ + +static SCM +mem2complex (const char* mem, size_t len, unsigned int idx, + unsigned int radix, enum t_exactness *p_exactness) +{ + char c; + int sign = 0; + SCM ureal; + + if (idx == len) + return SCM_BOOL_F; + + c = mem[idx]; + if (c == '+') + { + idx++; + sign = 1; + } + else if (c == '-') + { + idx++; + sign = -1; + } + + if (idx == len) + return SCM_BOOL_F; + + ureal = mem2ureal (mem, len, &idx, radix, p_exactness); + if (SCM_FALSEP (ureal)) + { + /* input must be either +i or -i */ + + if (sign == 0) + return SCM_BOOL_F; + + if (mem[idx] == 'i' || mem[idx] == 'I') + { + idx++; + if (idx != len) + return SCM_BOOL_F; + + return scm_make_rectangular (SCM_MAKINUM (0), SCM_MAKINUM (sign)); + } + else + return SCM_BOOL_F; + } + else + { + if (sign == -1) + ureal = scm_difference (ureal, SCM_UNDEFINED); + + if (idx == len) + return ureal; + + c = mem[idx]; + switch (c) + { + case 'i': case 'I': + /* either +i or -i */ + + idx++; + if (sign == 0) + return SCM_BOOL_F; + if (idx != len) + return SCM_BOOL_F; + return scm_make_rectangular (SCM_MAKINUM (0), ureal); + + case '@': + /* polar input: @. */ + + idx++; + if (idx == len) + return SCM_BOOL_F; + else + { + int sign; + SCM angle; + SCM result; + + c = mem[idx]; + if (c == '+') + { + idx++; + sign = 1; + } + else if (c == '-') + { + idx++; + sign = -1; + } + else + sign = 1; + + angle = mem2ureal (mem, len, &idx, radix, p_exactness); + if (SCM_FALSEP (angle)) + return SCM_BOOL_F; + if (idx != len) + return SCM_BOOL_F; + + if (sign == -1) + angle = scm_difference (angle, SCM_UNDEFINED); + + result = scm_make_polar (ureal, angle); + return result; + } + case '+': + case '-': + /* expecting input matching [+-]?i */ + + idx++; + if (idx == len) + return SCM_BOOL_F; + else + { + int sign = (c == '+') ? 1 : -1; + SCM imag = mem2ureal (mem, len, &idx, radix, p_exactness); + SCM result; + + if (SCM_FALSEP (imag)) + imag = SCM_MAKINUM (sign); + + if (idx == len) + return SCM_BOOL_F; + if (mem[idx] != 'i' && mem[idx] != 'I') + return SCM_BOOL_F; + + idx++; + if (idx != len) + return SCM_BOOL_F; + + if (sign == -1) + imag = scm_difference (imag, SCM_UNDEFINED); + result = scm_make_rectangular (ureal, imag); + return result; + } + default: + return SCM_BOOL_F; + } + } +} + + +/* R5RS, section 7.1.1, lexical structure of numbers: */ + +enum t_radix {NO_RADIX=0, DUAL=2, OCT=8, DEC=10, HEX=16}; SCM -scm_istring2number (char *str, long len, long radix) +scm_i_mem2number (const char* mem, size_t len, unsigned int default_radix) { - int i = 0; - char ex = 0; - char ex_p = 0, rx_p = 0; /* Only allow 1 exactness and 1 radix prefix */ - SCM res; - if (len == 1) - if (*str == '+' || *str == '-') /* Catches lone `+' and `-' for speed */ - return SCM_BOOL_F; + unsigned int idx = 0; + unsigned int radix = NO_RADIX; + enum t_exactness forced_x = NO_EXACTNESS; + enum t_exactness implicit_x = EXACT; + SCM result; - while ((len - i) >= 2 && str[i] == '#' && ++i) - switch (str[i++]) - { - case 'b': - case 'B': - if (rx_p++) - return SCM_BOOL_F; - radix = 2; - break; - case 'o': - case 'O': - if (rx_p++) - return SCM_BOOL_F; - radix = 8; - break; - case 'd': - case 'D': - if (rx_p++) - return SCM_BOOL_F; - radix = 10; - break; - case 'x': - case 'X': - if (rx_p++) - return SCM_BOOL_F; - radix = 16; - break; - case 'i': - case 'I': - if (ex_p++) - return SCM_BOOL_F; - ex = 2; - break; - case 'e': - case 'E': - if (ex_p++) - return SCM_BOOL_F; - ex = 1; - break; - default: - return SCM_BOOL_F; - } - - switch (ex) + /* R5RS, section 7.1.1, lexical structure of numbers: */ + while (idx + 2 < len && mem[idx] == '#') { - case 1: - return scm_istr2int (&str[i], len - i, radix); - case 0: - res = scm_istr2int (&str[i], len - i, radix); - if (!SCM_FALSEP (res)) - return res; - case 2: - return scm_istr2flo (&str[i], len - i, radix); + switch (mem[idx + 1]) + { + case 'b': case 'B': + if (radix != NO_RADIX) + return SCM_BOOL_F; + radix = DUAL; + break; + case 'd': case 'D': + if (radix != NO_RADIX) + return SCM_BOOL_F; + radix = DEC; + break; + case 'i': case 'I': + if (forced_x != NO_EXACTNESS) + return SCM_BOOL_F; + forced_x = INEXACT; + break; + case 'e': case 'E': + if (forced_x != NO_EXACTNESS) + return SCM_BOOL_F; + forced_x = EXACT; + break; + case 'o': case 'O': + if (radix != NO_RADIX) + return SCM_BOOL_F; + radix = OCT; + break; + case 'x': case 'X': + if (radix != NO_RADIX) + return SCM_BOOL_F; + radix = HEX; + break; + default: + return SCM_BOOL_F; + } + idx += 2; + } + + /* R5RS, section 7.1.1, lexical structure of numbers: */ + if (radix == NO_RADIX) + result = mem2complex (mem, len, idx, default_radix, &implicit_x); + else + result = mem2complex (mem, len, idx, (unsigned int) radix, &implicit_x); + + if (SCM_FALSEP (result)) + return SCM_BOOL_F; + + switch (forced_x) + { + case EXACT: + if (SCM_INEXACTP (result)) + /* FIXME: This may change the value. */ + return scm_inexact_to_exact (result); + else + return result; + case INEXACT: + if (SCM_INEXACTP (result)) + return result; + else + return scm_exact_to_inexact (result); + case NO_EXACTNESS: + default: + if (implicit_x == INEXACT) + { + if (SCM_INEXACTP (result)) + return result; + else + return scm_exact_to_inexact (result); + } + else + return result; } - return SCM_BOOL_F; } @@ -2760,12 +2812,14 @@ SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0, int base; SCM_VALIDATE_STRING (1, string); SCM_VALIDATE_INUM_MIN_DEF_COPY (2,radix,2,10,base); - answer = scm_istring2number (SCM_STRING_CHARS (string), - SCM_STRING_LENGTH (string), - base); + answer = scm_i_mem2number (SCM_STRING_CHARS (string), + SCM_STRING_LENGTH (string), + base); return scm_return_first (answer, string); } #undef FUNC_NAME + + /*** END strs->nums ***/ @@ -2860,7 +2914,7 @@ SCM_DEFINE (scm_real_p, "rational?", 1, 0, 0, return SCM_BOOL_T; } else if (SCM_IMP (x)) { return SCM_BOOL_F; - } else if (SCM_SLOPPY_REALP (x)) { + } else if (SCM_REALP (x)) { return SCM_BOOL_T; } else if (SCM_BIGP (x)) { return SCM_BOOL_T; @@ -2884,9 +2938,9 @@ SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0, return SCM_BOOL_F; if (SCM_BIGP (x)) return SCM_BOOL_T; - if (!SCM_SLOPPY_INEXACTP (x)) + if (!SCM_INEXACTP (x)) return SCM_BOOL_F; - if (SCM_SLOPPY_COMPLEXP (x)) + if (SCM_COMPLEXP (x)) return SCM_BOOL_F; r = SCM_REAL_VALUE (x); if (r == floor (r)) @@ -3860,17 +3914,6 @@ scm_round (double x) } - -SCM_GPROC1 (s_exact_to_inexact, "exact->inexact", scm_tc7_cxr, (SCM (*)()) scm_exact_to_inexact, g_exact_to_inexact); -/* Convert the number @var{x} to its inexact representation.\n" - */ -double -scm_exact_to_inexact (double z) -{ - return z; -} - - SCM_GPROC1 (s_i_floor, "floor", scm_tc7_cxr, (SCM (*)()) floor, g_i_floor); /* "Round the number @var{x} towards minus infinity." */ @@ -4113,6 +4156,23 @@ scm_angle (SCM z) } +SCM_GPROC (s_exact_to_inexact, "exact->inexact", 1, 0, 0, scm_exact_to_inexact, g_exact_to_inexact); +/* Convert the number @var{x} to its inexact representation.\n" + */ +SCM +scm_exact_to_inexact (SCM z) +{ + if (SCM_INUMP (z)) + return scm_make_real ((double) SCM_INUM (z)); + else if (SCM_BIGP (z)) + return scm_make_real (scm_i_big2dbl (z)); + else if (SCM_INEXACTP (z)) + return z; + else + SCM_WTA_DISPATCH_1 (g_exact_to_inexact, z, 1, s_exact_to_inexact); +} + + SCM_DEFINE (scm_inexact_to_exact, "inexact->exact", 1, 0, 0, (SCM z), "Return an exact number that is numerically closest to @var{z}.") diff --git a/libguile/numbers.h b/libguile/numbers.h index 7a6d6d7f1..05c2b4b21 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -1,7 +1,7 @@ /* classes: h_files */ -#ifndef NUMBERSH -#define NUMBERSH +#ifndef SCM_NUMBERS_H +#define SCM_NUMBERS_H /* Copyright (C) 1995,1996,1998,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify @@ -56,7 +56,7 @@ * * SCM_INUMP applies only to values known to be Scheme objects. * In particular, SCM_INUMP (SCM_CAR (x)) is valid only if x is known - * to be a SCM_CONSP. If x is only known to be a SCM_NIMP, + * to be a SCM_CONSP. If x is only known to be a non-immediate, * SCM_INUMP (SCM_CAR (x)) can give wrong answers. */ @@ -123,9 +123,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_NIMP (x) && SCM_TYP16S (x) == scm_tc16_real) -#define SCM_REALP(x) (SCM_NIMP (x) && SCM_TYP16 (x) == scm_tc16_real) -#define SCM_COMPLEXP(x) (SCM_NIMP (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_REAL_VALUE(x) (((scm_t_double *) SCM2PTR (x))->real) #define SCM_COMPLEX_MEM(x) ((scm_t_complex *) SCM_CELL_WORD_1 (x)) @@ -264,9 +264,7 @@ extern SCM scm_number_to_string (SCM x, SCM radix); extern int scm_print_real (SCM sexp, SCM port, scm_print_state *pstate); extern int scm_print_complex (SCM sexp, SCM port, scm_print_state *pstate); extern int scm_bigprint (SCM exp, SCM port, scm_print_state *pstate); -extern SCM scm_istr2int (char *str, long len, long radix); -extern SCM scm_istr2flo (char *str, long len, long radix); -extern SCM scm_istring2number (char *str, long len, long radix); +extern SCM scm_i_mem2number (const char *mem, size_t len, unsigned int radix); extern SCM scm_string_to_number (SCM str, SCM radix); extern SCM scm_make_real (double x); extern SCM scm_make_complex (double x, double y); @@ -297,7 +295,6 @@ extern double scm_acosh (double x); extern double scm_atanh (double x); extern double scm_truncate (double x); extern double scm_round (double x); -extern double scm_exact_to_inexact (double z); extern SCM scm_sys_expt (SCM z1, SCM z2); extern SCM scm_sys_atan2 (SCM z1, SCM z2); extern SCM scm_make_rectangular (SCM z1, SCM z2); @@ -306,6 +303,7 @@ extern SCM scm_real_part (SCM z); extern SCM scm_imag_part (SCM z); extern SCM scm_magnitude (SCM z); extern SCM scm_angle (SCM z); +extern SCM scm_exact_to_inexact (SCM z); extern SCM scm_inexact_to_exact (SCM z); extern SCM scm_trunc (SCM x); extern SCM scm_i_dbl2big (double d); @@ -355,7 +353,7 @@ extern unsigned long long scm_num2ulong_long (SCM num, unsigned long int pos, extern void scm_init_numbers (void); -#endif /* NUMBERSH */ +#endif /* SCM_NUMBERS_H */ /* Local Variables: diff --git a/libguile/read.c b/libguile/read.c index 131999f46..0387c293d 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -416,8 +416,13 @@ scm_lreadr (SCM *tok_buf,SCM port,SCM *copy) return SCM_MAKE_CHAR (c); if (c >= '0' && c < '8') { - p = scm_istr2int (SCM_STRING_CHARS (*tok_buf), (long) j, 8); - if (!SCM_FALSEP (p)) + /* Dirk:FIXME:: This type of character syntax is not R5RS + * compliant. Further, it should be verified that the constant + * does only consist of octal digits. Finally, it should be + * checked whether the resulting fixnum is in the range of + * characters. */ + p = scm_i_mem2number (SCM_STRING_CHARS (*tok_buf), j, 8); + if (SCM_INUMP (p)) return SCM_MAKE_CHAR (SCM_INUM (p)); } for (c = 0; c < scm_n_charnames; c++) @@ -503,27 +508,31 @@ scm_lreadr (SCM *tok_buf,SCM port,SCM *copy) SCM_STRING_CHARS (*tok_buf)[j] = 0; return scm_mem2string (SCM_STRING_CHARS (*tok_buf), j); - case'0':case '1':case '2':case '3':case '4': - case '5':case '6':case '7':case '8':case '9': + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': case '.': case '-': case '+': num: - j = scm_read_token (c, tok_buf, port, 0); - p = scm_istring2number (SCM_STRING_CHARS (*tok_buf), (long) j, 10L); - if (!SCM_FALSEP (p)) - return p; - if (c == '#') - { - if ((j == 2) && (scm_getc (port) == '(')) - { - scm_ungetc ('(', port); - c = SCM_STRING_CHARS (*tok_buf)[1]; - goto callshrp; - } - SCM_MISC_ERROR ("unknown # object", SCM_EOL); - } - goto tok; + j = scm_read_token (c, tok_buf, port, 0); + if (j == 1 && (c == '+' || c == '-')) + /* Shortcut: Detected symbol '+ or '- */ + goto tok; + + p = scm_i_mem2number (SCM_STRING_CHARS (*tok_buf), j, 10); + if (!SCM_FALSEP (p)) + return p; + if (c == '#') + { + if ((j == 2) && (scm_getc (port) == '(')) + { + scm_ungetc ('(', port); + c = SCM_STRING_CHARS (*tok_buf)[1]; + goto callshrp; + } + SCM_MISC_ERROR ("unknown # object", SCM_EOL); + } + goto tok; case ':': if (SCM_EQ_P (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_prefix)) From 88c4ba2aefd9175068e479d87d6e69e83c9c08d5 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Tue, 31 Jul 2001 14:08:04 +0000 Subject: [PATCH 1566/2047] * boot-9.scm (process-define-module): Bug fixed. --- ice-9/ChangeLog | 4 ++++ ice-9/boot-9.scm | 10 +++++----- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 449f5327f..e37b870bf 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2001-07-31 Keisuke Nishida + + * boot-9.scm (process-define-module): Bug fixed. + 2001-07-24 Marius Vollmer * syncase.scm (psyncomp): Removed, it is now in diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index d1ac9a7f1..67e20c523 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1747,14 +1747,14 @@ (unrecognized kws)) (let* ((interface-args (cadr kws)) (interface (apply resolve-interface interface-args))) - (and (eq? (car kws) 'use-syntax) - (or (symbol? (car spec)) + (and (eq? (car kws) #:use-syntax) + (or (symbol? (caar interface-args)) (error "invalid module name for use-syntax" - spec)) + (car interface-args))) (set-module-transformer! module - (module-ref interface (car - (last-pair (car interface-args))) + (module-ref interface + (car (last-pair (car interface-args))) #f))) (loop (cddr kws) (cons interface reversed-interfaces) From 9be745030e215de6a0ee5e14e0d1e5c0398c704f Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Tue, 31 Jul 2001 21:42:24 +0000 Subject: [PATCH 1567/2047] * srfi-14.c (scm_char_set_diff_plus_intersection): wasn't correctly accounting for the (char-set-union cs2...) in the spec. i.e., (char-set-diff+intersection a) -> copy-of-a, empty-set and the following are equivalent: (char-set-diff+intersection a (char-set #\a) (char-set #\b)) (char-set-diff+intersection a (char-set #\a #\b)) (scm_char_set_xor_x): disabled the side-effecting code, since it gives inconsistent results to scm_char_set_xor for the case (char-set-xor! a a a). (scm_char_set_diff_plus_intersection_x): added cs2 argument, since two arguments are compulsory in final spec. also similar changes as for scm_char_set_diff_plus_intersection. * srfi-14.h (scm_char_set_diff_plus_intersection_x): added cs2. --- srfi/ChangeLog | 18 +++++++++++++++ srfi/srfi-14.c | 59 +++++++++++++++++++++++++++++++++++++------------- srfi/srfi-14.h | 2 +- 3 files changed, 63 insertions(+), 16 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index b287451b2..109ff9940 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,21 @@ +2001-07-31 Gary Houston + + * srfi-14.c (scm_char_set_diff_plus_intersection): wasn't correctly + accounting for the (char-set-union cs2...) in the spec. i.e., + (char-set-diff+intersection a) -> copy-of-a, empty-set + and the following are equivalent: + (char-set-diff+intersection a (char-set #\a) (char-set #\b)) + (char-set-diff+intersection a (char-set #\a #\b)) + + (scm_char_set_xor_x): disabled the side-effecting code, since it + gives inconsistent results to scm_char_set_xor for the case + (char-set-xor! a a a). + + (scm_char_set_diff_plus_intersection_x): added cs2 argument, since + two arguments are compulsory in final spec. also similar changes + as for scm_char_set_diff_plus_intersection. + * srfi-14.h (scm_char_set_diff_plus_intersection_x): added cs2. + 2001-07-22 Gary Houston * srfi-14.c (scm_char_set_intersection, scm_char_set_xor): remove diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index 8a7a7321a..52d9419e3 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -1194,22 +1194,25 @@ SCM_DEFINE (scm_char_set_diff_plus_intersection, "char-set-diff+intersection", 1 SCM_VALIDATE_REST_ARGUMENT (rest); res1 = scm_char_set_copy (cs1); - res2 = scm_char_set_copy (cs1); + res2 = make_char_set (FUNC_NAME); p = (long *) SCM_SMOB_DATA (res1); q = (long *) SCM_SMOB_DATA (res2); while (!SCM_NULLP (rest)) { int k; SCM cs = SCM_CAR (rest); + long *r; + SCM_VALIDATE_SMOB (c, cs, charset); c++; - rest = SCM_CDR (rest); + r = (long *) SCM_SMOB_DATA (cs); for (k = 0; k < LONGS_PER_CHARSET; k++) { - p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k]; - q[k] &= ((long *) SCM_SMOB_DATA (cs))[k]; + q[k] |= p[k] & r[k]; + p[k] &= ~r[k]; } + rest = SCM_CDR (rest); } return scm_values (scm_list_2 (res1, res2)); } @@ -1322,6 +1325,15 @@ SCM_DEFINE (scm_char_set_xor_x, "char-set-xor!", 1, 0, 1, "Return the exclusive-or of all argument character sets.") #define FUNC_NAME s_scm_char_set_xor_x { + /* a side-effecting variant should presumably give consistent results: + (define a (char-set #\a)) + (char-set-xor a a a) -> char set #\a + (char-set-xor! a a a) -> char set #\a + */ + return scm_char_set_xor (scm_cons (cs1, rest)); + +#if 0 + /* this would give (char-set-xor! a a a) -> empty char set. */ int c = 2; long * p; @@ -1341,41 +1353,58 @@ SCM_DEFINE (scm_char_set_xor_x, "char-set-xor!", 1, 0, 1, p[k] ^= ((long *) SCM_SMOB_DATA (cs))[k]; } return cs1; +#endif } #undef FUNC_NAME -SCM_DEFINE (scm_char_set_diff_plus_intersection_x, "char-set-diff+intersection!", 1, 0, 1, - (SCM cs1, SCM rest), +SCM_DEFINE (scm_char_set_diff_plus_intersection_x, "char-set-diff+intersection!", 2, 0, 1, + (SCM cs1, SCM cs2, SCM rest), "Return the difference and the intersection of all argument\n" "character sets.") #define FUNC_NAME s_scm_char_set_diff_plus_intersection_x { - int c = 2; - SCM res2; + int c = 3; long * p, * q; + int k; SCM_VALIDATE_SMOB (1, cs1, charset); + SCM_VALIDATE_SMOB (2, cs2, charset); SCM_VALIDATE_REST_ARGUMENT (rest); - res2 = scm_char_set_copy (cs1); p = (long *) SCM_SMOB_DATA (cs1); - q = (long *) SCM_SMOB_DATA (res2); + q = (long *) SCM_SMOB_DATA (cs2); + if (p == q) + { + /* (char-set-diff+intersection! a a ...): can't share storage, + but we know the answer without checking for further + arguments. */ + return scm_values (scm_list_2 (make_char_set (FUNC_NAME), cs1)); + } + for (k = 0; k < LONGS_PER_CHARSET; k++) + { + long t = p[k]; + + p[k] &= ~q[k]; + q[k] = t & q[k]; + } while (!SCM_NULLP (rest)) { - int k; SCM cs = SCM_CAR (rest); + long *r; + SCM_VALIDATE_SMOB (c, cs, charset); c++; - rest = SCM_CDR (rest); + r = (long *) SCM_SMOB_DATA (cs); for (k = 0; k < LONGS_PER_CHARSET; k++) { - p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k]; - q[k] &= ((long *) SCM_SMOB_DATA (cs))[k]; + q[k] |= p[k] & r[k]; + p[k] &= ~r[k]; } + rest = SCM_CDR (rest); } - return scm_values (scm_list_2 (cs1, res2)); + return scm_values (scm_list_2 (cs1, cs2)); } #undef FUNC_NAME diff --git a/srfi/srfi-14.h b/srfi/srfi-14.h index 02e74f765..3989aadcc 100644 --- a/srfi/srfi-14.h +++ b/srfi/srfi-14.h @@ -111,6 +111,6 @@ SCM scm_char_set_union_x (SCM cs1, SCM rest); SCM scm_char_set_intersection_x (SCM cs1, SCM rest); SCM scm_char_set_difference_x (SCM cs1, SCM rest); SCM scm_char_set_xor_x (SCM cs1, SCM rest); -SCM scm_char_set_diff_plus_intersection_x (SCM cs1, SCM rest); +SCM scm_char_set_diff_plus_intersection_x (SCM cs1, SCM cs2, SCM rest); #endif /* SCM_SRFI_14_H */ From 8c914f6b696392a0e451e060cab9c66ca00f25d7 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 1 Aug 2001 05:09:30 +0000 Subject: [PATCH 1568/2047] In boilerplate, use -l$0. Thanks to Daniel Skarda. --- scripts/PROGRAM | 2 +- scripts/README | 2 +- scripts/display-commentary | 2 +- scripts/doc-snarf | 2 +- scripts/generate-autoload | 2 +- scripts/punify | 2 +- scripts/read-scheme-source | 2 +- scripts/snarf-check-and-output-texi | 2 +- scripts/use2dot | 2 +- 9 files changed, 9 insertions(+), 9 deletions(-) diff --git a/scripts/PROGRAM b/scripts/PROGRAM index 3511ccdfc..69a655949 100755 --- a/scripts/PROGRAM +++ b/scripts/PROGRAM @@ -1,7 +1,7 @@ #!/bin/sh # aside from this initial boilerplate, this is actually -*- scheme -*- code main='(module-ref (resolve-module '\''(scripts PROGRAM)) '\'main')' -exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" +exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" !# ;;; PROGRAM --- Does something diff --git a/scripts/README b/scripts/README index c1a3ef998..56dd286fb 100644 --- a/scripts/README +++ b/scripts/README @@ -65,7 +65,7 @@ Programs must follow the "executable module" convention, documented here: #!/bin/sh main='(module-ref (resolve-module '\''(scripts PROGRAM)) '\'main')' - exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" + exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" !# Following these conventions allows the program file to be used as module diff --git a/scripts/display-commentary b/scripts/display-commentary index 1eeb842d8..21ce2c03a 100755 --- a/scripts/display-commentary +++ b/scripts/display-commentary @@ -1,7 +1,7 @@ #!/bin/sh # aside from this initial boilerplate, this is actually -*- scheme -*- code main='(module-ref (resolve-module '\''(scripts display-commentary)) '\'main')' -exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" +exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" !# ;;; display-commentary --- As advertized diff --git a/scripts/doc-snarf b/scripts/doc-snarf index 941682e78..5b72fc5f8 100755 --- a/scripts/doc-snarf +++ b/scripts/doc-snarf @@ -1,7 +1,7 @@ #!/bin/sh # aside from this initial boilerplate, this is actually -*- scheme -*- code main='(module-ref (resolve-module '\''(scripts doc-snarf)) '\'main')' -exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" +exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" !# ;;; doc-snarf --- Extract documentation from source files diff --git a/scripts/generate-autoload b/scripts/generate-autoload index 83fa1f3f2..942822ead 100755 --- a/scripts/generate-autoload +++ b/scripts/generate-autoload @@ -1,7 +1,7 @@ #!/bin/sh # aside from this initial boilerplate, this is actually -*- scheme -*- code main='(module-ref (resolve-module '\''(scripts generate-autoload)) '\'main')' -exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" +exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" !# ;;; generate-autoload --- Display define-module form with autoload info diff --git a/scripts/punify b/scripts/punify index 1cc318fb6..699f3e2ff 100755 --- a/scripts/punify +++ b/scripts/punify @@ -1,7 +1,7 @@ #!/bin/sh # aside from this initial boilerplate, this is actually -*- scheme -*- code main='(module-ref (resolve-module '\''(scripts punify)) '\'main')' -exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" +exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" !# ;;; punify --- Display Scheme code w/o unnecessary comments / whitespace diff --git a/scripts/read-scheme-source b/scripts/read-scheme-source index 48e96058a..1a9c0e59b 100755 --- a/scripts/read-scheme-source +++ b/scripts/read-scheme-source @@ -1,7 +1,7 @@ #!/bin/sh # aside from this initial boilerplate, this is actually -*- scheme -*- code main='(module-ref (resolve-module '\''(scripts read-scheme-source)) '\'main')' -exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" +exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" !# ;;; read-scheme-source --- Read a file, recognizing scheme forms and comments diff --git a/scripts/snarf-check-and-output-texi b/scripts/snarf-check-and-output-texi index e3c84f540..bc1287b38 100755 --- a/scripts/snarf-check-and-output-texi +++ b/scripts/snarf-check-and-output-texi @@ -1,7 +1,7 @@ #!/bin/sh # aside from this initial boilerplate, this is actually -*- scheme -*- code main="(module-ref (resolve-module '(scripts snarf-check-and-output-texi)) 'main)" -exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" +exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" !# ;;; snarf-check-and-output-texi --- called by the doc snarfer. diff --git a/scripts/use2dot b/scripts/use2dot index d2cb64695..6f2901107 100755 --- a/scripts/use2dot +++ b/scripts/use2dot @@ -1,7 +1,7 @@ #!/bin/sh # aside from this initial boilerplate, this is actually -*- scheme -*- code main='(module-ref (resolve-module '\''(scripts use2dot)) '\'main')' -exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" +exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" !# ;;; use2dot --- Display module dependencies as a DOT specification From 9ebd6e62811219fdbcb04efff439ff67116ce920 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 1 Aug 2001 05:10:12 +0000 Subject: [PATCH 1569/2047] *** empty log message *** --- scripts/ChangeLog | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/scripts/ChangeLog b/scripts/ChangeLog index b25efc2f2..0a8dab25a 100644 --- a/scripts/ChangeLog +++ b/scripts/ChangeLog @@ -1,3 +1,11 @@ +2001-08-01 Thien-Thi Nguyen + + * PROGRAM, README, display-commentary, doc-snarf, + generate-autoload, punify, read-scheme-source, + snarf-check-and-output-texi, use2dot: + In boilerplate, use -l$0. + Thanks to Daniel Skarda. + 2001-07-22 Thien-Thi Nguyen * generate-autoload (autoload-info): From bba2d1908ab2104ad6de36a105466ce2936f274f Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 1 Aug 2001 09:57:01 +0000 Subject: [PATCH 1570/2047] (run-test-exception): Add special handling for `error'-generated exceptions, which pass key `misc-error' and leave messages unformatted. --- test-suite/lib.scm | 79 ++++++++++++++++++++++++++-------------------- 1 file changed, 45 insertions(+), 34 deletions(-) diff --git a/test-suite/lib.scm b/test-suite/lib.scm index 1084e641d..a5a44fa8a 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -1,16 +1,16 @@ ;;;; test-suite/lib.scm --- generic support for testing ;;;; Copyright (C) 1999, 2000, 2001 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 ;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, @@ -37,7 +37,7 @@ ;; Reporting results in various ways. register-reporter unregister-reporter reporter-registered? make-count-reporter print-counts - make-log-reporter + make-log-reporter full-reporter user-reporter format-test-name) @@ -75,12 +75,12 @@ ;;;; ;;;; Convenience macros for tests expected to pass or fail ;;;; -;;;; * (pass-if name body) is a short form for +;;;; * (pass-if name body) is a short form for ;;;; (run-test name #t (lambda () body)) -;;;; * (expect-fail name body) is a short form for +;;;; * (expect-fail name body) is a short form for ;;;; (run-test name #f (lambda () body)) ;;;; -;;;; For example: +;;;; For example: ;;;; ;;;; (pass-if "integer addition" (= 2 (+ 1 1))) ;;;; @@ -118,23 +118,23 @@ ;;;; - Test names can be compared with EQUAL?. ;;;; - Test names can be reliably stored and retrieved with the standard WRITE ;;;; and READ procedures; doing so preserves their identity. -;;;; +;;;; ;;;; For example: -;;;; +;;;; ;;;; (pass-if "simple addition" (= 4 (+ 2 2))) -;;;; +;;;; ;;;; In that case, the test name is the list ("simple addition"). ;;;; ;;;; The WITH-TEST-PREFIX syntax and WITH-TEST-PREFIX* procedure establish ;;;; a prefix for the names of all tests whose results are reported ;;;; within their dynamic scope. For example: -;;;; +;;;; ;;;; (begin ;;;; (with-test-prefix "basic arithmetic" ;;;; (pass-if "addition" (= (+ 2 2) 4)) ;;;; (pass-if "subtraction" (= (- 4 2) 2))) ;;;; (pass-if "multiplication" (= (* 2 2) 4))) -;;;; +;;;; ;;;; In that example, the three test names are: ;;;; ("basic arithmetic" "addition"), ;;;; ("basic arithmetic" "subtraction"), and @@ -142,7 +142,7 @@ ;;;; ;;;; WITH-TEST-PREFIX can be nested. Each WITH-TEST-PREFIX postpends ;;;; a new element to the current prefix: -;;;; +;;;; ;;;; (with-test-prefix "arithmetic" ;;;; (with-test-prefix "addition" ;;;; (pass-if "integer" (= (+ 2 2) 4)) @@ -150,7 +150,7 @@ ;;;; (with-test-prefix "subtraction" ;;;; (pass-if "integer" (= (- 2 2) 0)) ;;;; (pass-if "complex" (= (- 2+3i 1+2i) 1+1i)))) -;;;; +;;;; ;;;; The four test names here are: ;;;; ("arithmetic" "addition" "integer") ;;;; ("arithmetic" "addition" "complex") @@ -160,7 +160,7 @@ ;;;; To print a name for a human reader, we DISPLAY its elements, ;;;; separated by ": ". So, the last set of test names would be ;;;; reported as: -;;;; +;;;; ;;;; arithmetic: addition: integer ;;;; arithmetic: addition: complex ;;;; arithmetic: subtraction: integer @@ -173,16 +173,16 @@ ;;;; REPORTERS -;;;; +;;;; ;;;; A reporter is a function which we apply to each test outcome. ;;;; Reporters can log results, print interesting results to the ;;;; standard output, collect statistics, etc. -;;;; +;;;; ;;;; A reporter function takes two mandatory arguments, RESULT and TEST, and ;;;; possibly additional arguments depending on RESULT; its return value ;;;; is ignored. RESULT has one of the following forms: ;;;; -;;;; pass - The test named TEST passed. +;;;; pass - The test named TEST passed. ;;;; Additional arguments are ignored. ;;;; upass - The test named TEST passed unexpectedly. ;;;; Additional arguments are ignored. @@ -195,7 +195,7 @@ ;;;; tested because something else went wrong. ;;;; Additional arguments are ignored. ;;;; untested - The test named TEST was not actually performed, for -;;;; example because the test case is not complete yet. +;;;; example because the test case is not complete yet. ;;;; Additional arguments are ignored. ;;;; unsupported - The test named TEST requires some feature that is not ;;;; available in the configured testing environment. @@ -259,16 +259,16 @@ (throw 'unresolved))) (lambda (key . args) (case key - ((pass) + ((pass) (report (if expect-pass 'pass 'upass) test-name)) - ((fail) + ((fail) (report (if expect-pass 'fail 'xfail) test-name)) - ((unresolved untested unsupported) + ((unresolved untested unsupported) (report key test-name)) - ((quit) + ((quit) (report 'unresolved test-name) (quit)) - (else + (else (report 'error test-name (cons key args)))))) (set! test-running #f)))) (set! run-test local-run-test)) @@ -287,10 +287,21 @@ (lambda () (stack-catch (car exception) (lambda () (thunk) #f) - (lambda (key proc message . rest) - (if (not (string-match (cdr exception) message)) - (apply throw key proc message rest) - #t)))))) + (lambda (key proc message . rest) + (cond + ;; handle explicit key + ((string-match (cdr exception) message) + #t) + ;; handle `(error ...)' which uses `misc-error' for key and doesn't + ;; yet format the message and args (we have to do it here). + ((and (eq? 'misc-error (car exception)) + (list? rest) + (string-match (cdr exception) + (apply simple-format #f message (car rest)))) + #t) + ;; unhandled; throw again + (else + (apply throw key proc message rest)))))))) ;;; A short form for tests that expect a certain exception to be thrown. (defmacro pass-if-exception (name exception body . rest) @@ -344,7 +355,7 @@ ;;;; REPORTERS -;;;; +;;;; ;;; The global list of reporters. (define reporters '()) @@ -385,7 +396,7 @@ ;;;; User reporters write interesting test results to the standard output. ;;; The complete list of possible test results. -(define result-tags +(define result-tags '((pass "PASS" "passes: ") (fail "FAIL" "failures: ") (upass "UPASS" "unexpected passes: ") @@ -396,7 +407,7 @@ (error "ERROR" "errors: "))) ;;; The list of important test results. -(define important-result-tags +(define important-result-tags '(fail upass unresolved error)) ;;; Display a single test result in formatted form to the given port @@ -426,9 +437,9 @@ (list (lambda (result name . args) (let ((pair (assq result counts))) - (if pair + (if pair (set-cdr! pair (+ 1 (cdr pair))) - (error "count-reporter: unexpected test result: " + (error "count-reporter: unexpected test result: " (cons result (cons name args)))))) (lambda () (append counts '()))))) @@ -436,7 +447,7 @@ ;;; Print a count reporter's results nicely. Pass this function the value ;;; returned by a count reporter's RESULTS procedure. (define (print-counts results . port?) - (let ((port (if (pair? port?) + (let ((port (if (pair? port?) (car port?) (current-output-port)))) (newline port) From 9b974335964eb26d0920b368ba717dd98c9af1b9 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 1 Aug 2001 10:01:51 +0000 Subject: [PATCH 1571/2047] *** empty log message *** --- AUTHORS | 4 ++++ test-suite/ChangeLog | 6 ++++++ 2 files changed, 10 insertions(+) diff --git a/AUTHORS b/AUTHORS index b4ec70fa5..c1dd0b3ed 100644 --- a/AUTHORS +++ b/AUTHORS @@ -234,6 +234,10 @@ In the subdirectory doc, changes to: intro.texi preface.texi scheme-modules.texi scheme-procedures.texi scheme-scheduling.texi +In the subdirectory test-suite, changes to: + guile-test lib.scm +In the subdirectory test-suite/tests, changes to: + exceptions.test eval.test Robert Merkel: In the subdirectory doc, co-wrote: diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 0aa2ad502..90bab7d41 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,9 @@ +2001-08-01 Thien-Thi Nguyen + + * lib.scm (run-test-exception): Add special handling for + `error'-generated exceptions, which pass key `misc-error' and + leave messages unformatted. + 2001-07-18 Martin Grabmueller * tests/alist.test, tests/bit-operations.test, From 29aa75ea12ceca938d699d3383d7e2e48fd4a1d4 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 1 Aug 2001 16:50:34 +0000 Subject: [PATCH 1572/2047] Wrote more informative change log. --- ice-9/ChangeLog | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index e37b870bf..93d053506 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,6 +1,7 @@ 2001-07-31 Keisuke Nishida - * boot-9.scm (process-define-module): Bug fixed. + * boot-9.scm (process-define-module): Fixed a bug that did not + handle :use-syntax correctly. 2001-07-24 Marius Vollmer From ccbd262bd13991093e10044785c61a50e4e22a30 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 1 Aug 2001 21:27:59 +0000 Subject: [PATCH 1573/2047] (scm_char_alphabetic_p, scm_char_numeric_p, scm_char_whitespace_p, scm_char_upper_case_p, scm_char_lower_case_p, scm_char_is_both_p): Do not require characters to fulfill isascii in addition to the primary predicate. --- libguile/chars.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/libguile/chars.c b/libguile/chars.c index 229da4b35..469514715 100644 --- a/libguile/chars.c +++ b/libguile/chars.c @@ -186,7 +186,7 @@ SCM_DEFINE (scm_char_alphabetic_p, "char-alphabetic?", 1, 0, 0, #define FUNC_NAME s_scm_char_alphabetic_p { SCM_VALIDATE_CHAR (1,chr); - return SCM_BOOL(isascii(SCM_CHAR(chr)) && isalpha(SCM_CHAR(chr))); + return SCM_BOOL(isalpha(SCM_CHAR(chr))); } #undef FUNC_NAME @@ -197,7 +197,7 @@ SCM_DEFINE (scm_char_numeric_p, "char-numeric?", 1, 0, 0, #define FUNC_NAME s_scm_char_numeric_p { SCM_VALIDATE_CHAR (1,chr); - return SCM_BOOL(isascii(SCM_CHAR(chr)) && isdigit(SCM_CHAR(chr))); + return SCM_BOOL(isdigit(SCM_CHAR(chr))); } #undef FUNC_NAME @@ -208,7 +208,7 @@ SCM_DEFINE (scm_char_whitespace_p, "char-whitespace?", 1, 0, 0, #define FUNC_NAME s_scm_char_whitespace_p { SCM_VALIDATE_CHAR (1,chr); - return SCM_BOOL(isascii(SCM_CHAR(chr)) && isspace(SCM_CHAR(chr))); + return SCM_BOOL(isspace(SCM_CHAR(chr))); } #undef FUNC_NAME @@ -221,7 +221,7 @@ SCM_DEFINE (scm_char_upper_case_p, "char-upper-case?", 1, 0, 0, #define FUNC_NAME s_scm_char_upper_case_p { SCM_VALIDATE_CHAR (1,chr); - return SCM_BOOL(isascii(SCM_CHAR(chr)) && isupper(SCM_CHAR(chr))); + return SCM_BOOL(isupper(SCM_CHAR(chr))); } #undef FUNC_NAME @@ -233,7 +233,7 @@ SCM_DEFINE (scm_char_lower_case_p, "char-lower-case?", 1, 0, 0, #define FUNC_NAME s_scm_char_lower_case_p { SCM_VALIDATE_CHAR (1,chr); - return SCM_BOOL(isascii(SCM_CHAR(chr)) && islower(SCM_CHAR(chr))); + return SCM_BOOL(islower(SCM_CHAR(chr))); } #undef FUNC_NAME @@ -247,7 +247,7 @@ SCM_DEFINE (scm_char_is_both_p, "char-is-both?", 1, 0, 0, #define FUNC_NAME s_scm_char_is_both_p { SCM_VALIDATE_CHAR (1,chr); - return SCM_BOOL(isascii(SCM_CHAR(chr)) && (isupper(SCM_CHAR(chr)) || islower(SCM_CHAR(chr)))); + return SCM_BOOL((isupper(SCM_CHAR(chr)) || islower(SCM_CHAR(chr)))); } #undef FUNC_NAME From 915bd26388c4f2196daf8f756b0615f44597d8f3 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 1 Aug 2001 21:28:29 +0000 Subject: [PATCH 1574/2047] Added `--disable-linuxthreads' option and do not define GUILE_PTHREAD_COMPAT nor link with -lpthread when it is given. Thanks to Cris Cramer! --- configure.in | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/configure.in b/configure.in index 69656d4a6..532f0ccfc 100644 --- a/configure.in +++ b/configure.in @@ -558,8 +558,12 @@ if test "${THREAD_PACKAGE}" != "" ; then AC_DEFINE(GUILE_ISELECT, 1) fi - ## Workaround for linuxthreads (currently disabled) - if test $host_os = linux-gnu; then + AC_ARG_ENABLE(linuxthreads, + [ --disable-linuxthreads disable linuxthreads workaround],, + enable_linuxthreads=yes) + + ## Workaround for linuxthreads (optionally disabled) + if test $host_os = linux-gnu -a "$enable_linuxthreads" = yes; then AC_DEFINE(GUILE_PTHREAD_COMPAT, 1) AC_CHECK_LIB(pthread, main) fi From c1151355d21fd050541198e31eafb098f119b7a6 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 1 Aug 2001 21:28:45 +0000 Subject: [PATCH 1575/2047] *** empty log message *** --- ChangeLog | 6 + INSTALL | 425 --------------------------------------------- libguile/ChangeLog | 8 + 3 files changed, 14 insertions(+), 425 deletions(-) diff --git a/ChangeLog b/ChangeLog index 1bd7fc4e2..e537d6951 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2001-08-01 Marius Vollmer + + * configure.in: Added `--disable-linuxthreads' option and do not + define GUILE_PTHREAD_COMPAT nor link with -lpthread when it is + given. Thanks to Cris Cramer! + 2001-07-23 Marius Vollmer * Makefile.am (SUBDIRS): Build libguile before ice-9. diff --git a/INSTALL b/INSTALL index fedf6dfb1..e69de29bb 100644 --- a/INSTALL +++ b/INSTALL @@ -1,425 +0,0 @@ -Guile Installation Guide -Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 Free Software Foundation, Inc. - - Permission is granted to anyone to make or distribute verbatim copies - of this document as received, in any medium, provided that the - copyright notice and permission notice are preserved, - and that the distributor grants the recipient permission - for further redistribution as permitted by this notice. - - Permission is granted to distribute modified versions - of this document, or of portions of it, - under the above conditions, provided also that they - carry prominent notices stating who last changed them, - and that any new or changed statements about the activities - of the Free Software Foundation are approved by the Foundation. - - -Brief Installation Instructions =========================================== - -To build Guile on unix, there are two basic steps: - - 1. Type "./configure", to configure the package for your system. - 2. Type "make", to build the package. - -Generic instructions for configuring and compiling GNU distributions -are included below. (For instructions how to install SLIB, the scheme -procedure library, see below.) - - -Guile can use a number of external packages such as `readline' when -they are available. Guile expects to be able to find these packages -in the default compiler setup, it does not try to make any special -arrangements itself. For example, for the `readline' package, Guile -expects to be able to find the include file , -without passing any special `-I' options to the compiler. - -If you installed an external package, and you used the --prefix -installation option to install it somewhere else than /usr/local, you -must arrange for your compiler to find it by default. If that -compiler is gcc, one convenient way of making such arrangements is to -use the --with-local-prefix option during installation, naming the -same directory as you used in the --prefix option of the package. In -particular, it is not good enough to use the same --prefix option when -you install gcc and the package; you need to use the ---with-local-prefix option as well. See the gcc documentation for -more details. - - -Special Instructions For Some Systems ===================================== - -We would like Guile to build on all systems using the simple -instructions above, but it seems that a few systems still need special -treatment. If you can send us fixes for these problems, we'd be -grateful. - -SunOS 4.1: Guile's shared library support seems to be confused, but - hey; shared libraries are confusing. You may need to configure - Guile with a command like: - ./configure --disable-shared - For more information on `--disable-shared', see below, "Flags - Accepted by Configure". - -HP/UX: GCC 2.7.2 (and maybe other versions) have trouble creating - shared libraries if they depend on any non-shared libraries. GCC - seems to have other problems as well. To work around this, we - suggest you configure Guile to use the system's C compiler: - CC=cc ./configure - -NetBSD: Perry Metzger says, "Guile will build under NetBSD only using - gmake -- the native make will not work. (gmake is in our package - system, so this will not be a problem when we packagize 1.3.)" - - -Flags Accepted by Configure =============================================== - -If you run the configure script with no arguments, it should examine -your system and set things up appropriately. However, there are a few -switches specific to Guile you may find useful in some circumstances. - - ---enable-maintainer-mode - - If you have automake, autoconf, and libtool installed on your - system, this switch causes configure to generate Makefiles which - know how to automatically regenerate configure scripts, makefiles, - and headers, when they are out of date. The HACKING file says which - versions of those tools you will need. - - ---with-threads --- Build with thread support - - Build a Guile executable and library that supports cooperative - threading. If you use this switch, Guile will also build and - install the QuickThreads non-preemptive threading library, - libqthreads, which you will need to link into your programs after - libguile. When you use `guile-config', you will pick up all - neccessary linker flags automatically. - - Cooperative threads are not yet thoroughly tested; once they are, - they will be enabled by default. The interaction with blocking I/O - is pretty ad hoc at the moment. In our experience, bugs in the - thread support do not affect you if you don't actually use threads. - - ---with-modules --- Specify statically linked `modules' - - Guile can dynamically load `plugin modules' during runtime, using - facilities provided by libtool. Not all platforms support this, - however. On these platforms, you can statically link the plugin - modules into libguile when Guile itself is build. XXX - how does - one specify the modules? - - ---enable-deprecated=LEVEL --- Control the inclusion of deprecated features. - - You can select between different behaviours via the LEVEL argument: - a value of "no" will omit all deprecated features and you will get - "undefined reference", "variable unbound" or similar errors when you - try to use them. All other values will include all deprecated - features. The LEVEL argument is used to determine the default value - for the environment variable GUILE_WARN_DEPRECATED. See the README - for more information. - - The default is to get a vague warning at program exit if deprecated - features were used: - - --enable-deprecated=yes - --enable-deprecated=summary - - To get a detailed warning at first use of a deprecated feature: - - --enable-deprecated=detailed - - To get no warnings: - - --enable-deprecated=shutup - - To omit deprecated features completely and irrevokably: - - --enable-deprecated=no - - ---disable-shared --- Do not build shared libraries. ---disable-static --- Do not build static libraries. - - Normally, both static and shared libraries will be built if your - system supports them. - - ---enable-debug-freelist --- Enable freelist debugging. - - This enables a debugging version of SCM_NEWCELL(), and also - registers an extra primitive, the setter - `gc-set-debug-check-freelist!'. - - Configure with the --enable-debug-freelist option to enable the - gc-set-debug-check-freelist! primitive, and then use: - - (gc-set-debug-check-freelist! #t) # turn on checking of the freelist - (gc-set-debug-check-freelist! #f) # turn off checking - - Checking of the freelist forces a traversal of the freelist and a - garbage collection before each allocation of a cell. This can slow - down the interpreter dramatically, so the setter should be used to - turn on this extra processing only when necessary. - - ---enable-debug-malloc --- Enable malloc debugging. - - Include code for debugging of calls to scm_must_malloc/realloc/free. - - Checks that - - 1. objects freed by scm_must_free has been mallocated by scm_must_malloc - 2. objects reallocated by scm_must_realloc has been allocated by - scm_must_malloc - 3. reallocated objects are reallocated with the same what string - - But, most importantly, it records the number of allocated objects of - each kind. This is useful when searching for memory leaks. - - A Guile compiled with this option provides the primitive - `malloc-stats' which returns an alist with pairs of kind and the - number of objects of that kind. - - ---enable-guile-debug --- Include internal debugging functions ---disable-arrays --- omit array and uniform array support ---disable-posix --- omit posix interfaces ---disable-networking --- omit networking interfaces ---disable-regex --- omit regular expression interfaces - - -Using Guile Without Installing It ========================================= - -If you want to run Guile without installing it, set the environment -variable `GUILE_LOAD_PATH' to a colon-separated list of directories, -including the directory containing this INSTALL file. If you used a -separate build directory, you'll need to include the build directory -in the path as well. - -For example, suppose the Guile distribution unpacked into a directory -called `/home/jimb/guile-snap' (so the full name of this INSTALL file -would be `/home/jimb/guile-snap/INSTALL'). Then you might say, if -you're using Bash or any other Bourne shell variant, - - export GUILE_LOAD_PATH=/home/jimb/guile-snap - -or if you're using CSH or one of its variants: - - setenv GUILE_LOAD_PATH /home/jimb/guile-snap - - -Installing SLIB =========================================================== - -In order to use SLIB from Guile you basically only need to put the -`slib' directory _in_ one of the directories on Guile's load path. - -The standard installation is: - - 1. Obtain slib from http://www-swiss.ai.mit.edu/~jaffer/SLIB.html - - 2. Put it in Guile's data directory, that is the directory printed when - you type - - guile-config info pkgdatadir - - at the shell prompt. This is normally `/usr/local/share/guile', so the - directory will normally have full path `/usr/local/share/guile/slib'. - - 3. Start guile as a user with write access to the data directory and type - - (use-modules (ice-9 slib)) - - at the Guile prompt. This will generate the slibcat catalog next to - the slib directory. - -SLIB's `require' is provided by the Guile module (ice-9 slib). - -Example: - - (use-modules (ice-9 slib)) - (require 'primes) - (prime? 7) - - -Generic Instructions for Building Auto-Configured Packages ================ - - The `configure' shell script attempts to guess correct values for -various system-dependent variables used during compilation. It uses -those values to create a `Makefile' in each directory of the package. -It may also create one or more `.h' files containing system-dependent -definitions. Finally, it creates a shell script `config.status' that -you can run in the future to recreate the current configuration, a file -`config.cache' that saves the results of its tests to speed up -reconfiguring, and a file `config.log' containing compiler output -(useful mainly for debugging `configure'). - - If you need to do unusual things to compile the package, please try -to figure out how `configure' could check whether to do them, and mail -diffs or instructions to the address given in the `README' so they can -be considered for the next release. If at some point `config.cache' -contains results you don't want to keep, you may remove or edit it. - - The file `configure.in' is used to create `configure' by a program -called `autoconf'. You only need `configure.in' if you want to change -it or regenerate `configure' using a newer version of `autoconf'. - -The simplest way to compile this package is: - - 1. `cd' to the directory containing the package's source code and type - `./configure' to configure the package for your system. If you're - using `csh' on an old version of System V, you might need to type - `sh ./configure' instead to prevent `csh' from trying to execute - `configure' itself. - - Running `configure' takes awhile. While running, it prints some - messages telling which features it is checking for. - - 2. Type `make' to compile the package. - - 3. Optionally, type `make check' to run any self-tests that come with - the package. - - 4. Type `make install' to install the programs and any data files and - documentation. - - 5. You can remove the program binaries and object files from the - source code directory by typing `make clean'. To also remove the - files that `configure' created (so you can compile the package for - a different kind of computer), type `make distclean'. There is - also a `make maintainer-clean' target, but that is intended mainly - for the package's developers. If you use it, you may have to get - all sorts of other programs in order to regenerate files that came - with the distribution. - -Compilers and Options -===================== - - Some systems require unusual options for compilation or linking that -the `configure' script does not know about. You can give `configure' -initial values for variables by setting them in the environment. Using -a Bourne-compatible shell, you can do that on the command line like -this: - CC=c89 CFLAGS=-O2 LIBS=-lposix ./configure - -Or on systems that have the `env' program, you can do it like this: - env CPPFLAGS=-I/usr/local/include LDFLAGS=-s ./configure - -Compiling For Multiple Architectures -==================================== - - You can compile the package for more than one kind of computer at the -same time, by placing the object files for each architecture in their -own directory. To do this, you must use a version of `make' that -supports the `VPATH' variable, such as GNU `make'. `cd' to the -directory where you want the object files and executables to go and run -the `configure' script. `configure' automatically checks for the -source code in the directory that `configure' is in and in `..'. - - If you have to use a `make' that does not supports the `VPATH' -variable, you have to compile the package for one architecture at a time -in the source code directory. After you have installed the package for -one architecture, use `make distclean' before reconfiguring for another -architecture. - -Installation Names -================== - - By default, `make install' will install the package's files in -`/usr/local/bin', `/usr/local/man', etc. You can specify an -installation prefix other than `/usr/local' by giving `configure' the -option `--prefix=PATH'. - - You can specify separate installation prefixes for -architecture-specific files and architecture-independent files. If you -give `configure' the option `--exec-prefix=PATH', the package will use -PATH as the prefix for installing programs and libraries. -Documentation and other data files will still use the regular prefix. - - In addition, if you use an unusual directory layout you can give -options like `--bindir=PATH' to specify different values for particular -kinds of files. Run `configure --help' for a list of the directories -you can set and what kinds of files go in them. - - If the package supports it, you can cause programs to be installed -with an extra prefix or suffix on their names by giving `configure' the -option `--program-prefix=PREFIX' or `--program-suffix=SUFFIX'. - -Optional Features -================= - - Some packages pay attention to `--enable-FEATURE' options to -`configure', where FEATURE indicates an optional part of the package. -They may also pay attention to `--with-PACKAGE' options, where PACKAGE -is something like `gnu-as' or `x' (for the X Window System). The -`README' should mention any `--enable-' and `--with-' options that the -package recognizes. - - For packages that use the X Window System, `configure' can usually -find the X include and library files automatically, but if it doesn't, -you can use the `configure' options `--x-includes=DIR' and -`--x-libraries=DIR' to specify their locations. - -Specifying the System Type -========================== - - There may be some features `configure' can not figure out -automatically, but needs to determine by the type of host the package -will run on. Usually `configure' can figure that out, but if it prints -a message saying it can not guess the host type, give it the -`--host=TYPE' option. TYPE can either be a short name for the system -type, such as `sun4', or a canonical name with three fields: - CPU-COMPANY-SYSTEM - -See the file `config.sub' for the possible values of each field. If -`config.sub' isn't included in this package, then this package doesn't -need to know the host type. - - If you are building compiler tools for cross-compiling, you can also -use the `--target=TYPE' option to select the type of system they will -produce code for and the `--build=TYPE' option to select the type of -system on which you are compiling the package. - -Sharing Defaults -================ - - If you want to set default values for `configure' scripts to share, -you can create a site shell script called `config.site' that gives -default values for variables like `CC', `cache_file', and `prefix'. -`configure' looks for `PREFIX/share/config.site' if it exists, then -`PREFIX/etc/config.site' if it exists. Or, you can set the -`CONFIG_SITE' environment variable to the location of the site script. -A warning: not all `configure' scripts look for a site script. - -Operation Controls -================== - - `configure' recognizes the following options to control how it -operates. - -`--cache-file=FILE' - Use and save the results of the tests in FILE instead of - `./config.cache'. Set FILE to `/dev/null' to disable caching, for - debugging `configure'. - -`--help' - Print a summary of the options to `configure', and exit. - -`--quiet' -`--silent' -`-q' - Do not print messages saying which checks are being made. To - suppress all normal output, redirect it to `/dev/null' (any error - messages will still be shown). - -`--srcdir=DIR' - Look for the package's source code in directory DIR. Usually - `configure' can determine that directory automatically. - -`--version' - Print the version of Autoconf used to generate the `configure' - script, and exit. - -`configure' also accepts some other, not widely useful, options. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b21e6a6c6..8570e57db 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2001-08-01 Marius Vollmer + + * chars.c (scm_char_alphabetic_p, scm_char_numeric_p, + scm_char_whitespace_p, scm_char_upper_case_p, + scm_char_lower_case_p, scm_char_is_both_p): Do not require + characters to fulfill isascii in addition to the primary + predicate. + 2001-07-30 Dirk Herrmann * numbers.c (DIGITS, scm_small_istr2int, scm_istr2int, From 3cc2e575a65ab38e312c42ff7e5f66257d5cf670 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Thu, 2 Aug 2001 10:13:03 +0000 Subject: [PATCH 1576/2047] Initial revision --- test-suite/tests/getopt-long.test | 95 +++++++++++++++++++++++++++++++ 1 file changed, 95 insertions(+) create mode 100644 test-suite/tests/getopt-long.test diff --git a/test-suite/tests/getopt-long.test b/test-suite/tests/getopt-long.test new file mode 100644 index 000000000..1d1658a09 --- /dev/null +++ b/test-suite/tests/getopt-long.test @@ -0,0 +1,95 @@ +;;;; getopt-long.test --- optional long arg processing -*- scheme -*- +;;;; Thien-Thi Nguyen --- August 2001 +;;;; +;;;; Copyright (C) 2001 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 +;;;; the Free Software Foundation; either version 2, 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 this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +(use-modules (test-suite lib) + (ice-9 getopt-long) + (ice-9 regex)) + +(define exception:option-predicate-failed + (cons 'misc-error "^option predicate failed")) + +(with-test-prefix "specifying predicate" + + (define (test1 . args) + (getopt-long args `((test (value #t) + (predicate ,(lambda (x) + (string-match "^[0-9]+$" x))))))) + + (pass-if "valid arg" + (equal? (test1 "foo" "bar" "--test=123") + '((() "bar") (test . "123")))) + + (pass-if-exception "invalid arg" + exception:option-predicate-failed + (test1 "foo" "bar" "--test=foo")) + + (pass-if-exception "option has no arg" + exception:option-predicate-failed + (test1 "foo" "bar")) + + ) + +(with-test-prefix "not specifying predicate" + + (define (test2 . args) + (getopt-long args `((test (value #t))))) + + (pass-if "option has arg" + (equal? (test2 "foo" "bar" "--test=foo") + '((() "bar") (test . "foo")))) + + (pass-if "option has no arg" + (equal? (test2 "foo" "bar") + '((() "bar")))) + + ) + +(with-test-prefix "value optional" + + (define (test3 . args) + (getopt-long args '((foo (value optional) (single-char #\f)) + (bar)))) + + (pass-if "long option `foo' w/ arg, long option `bar'" + (equal? (test3 "prg" "--foo" "fooval" "--bar") + '((()) (bar . #t) (foo . "fooval")))) + + (pass-if "short option `foo' w/ arg, long option `bar'" + (equal? (test3 "prg" "-f" "fooval" "--bar") + '((()) (bar . #t) (foo . "fooval")))) + + (pass-if "short option `foo', long option `bar', no args" + (equal? (test3 "prg" "-f" "--bar") + '((()) (bar . #t) (foo . #t)))) + + (pass-if "long option `foo', long option `bar', no args" + (equal? (test3 "prg" "--foo" "--bar") + '((()) (bar . #t) (foo . #t)))) + + (pass-if "long option `bar', short option `foo', no args" + (equal? (test3 "prg" "--bar" "-f") + '((()) (foo . #t) (bar . #t)))) + + (pass-if "long option `bar', long option `foo', no args" + (equal? (test3 "prg" "--bar" "--foo") + '((()) (foo . #t) (bar . #t)))) + ) + +;;; getopt-long.test ends here From ed9ef46202519bca3937935f8fb8f80613bab3c9 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Thu, 2 Aug 2001 10:14:17 +0000 Subject: [PATCH 1577/2047] *** empty log message *** --- test-suite/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 90bab7d41..4c59ef578 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2001-08-02 Thien-Thi Nguyen + + * tests/getopt-long.test: New file. + 2001-08-01 Thien-Thi Nguyen * lib.scm (run-test-exception): Add special handling for From 4f70d598bf3e98f9b886421a146cfd68fd2759ba Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Thu, 2 Aug 2001 10:26:52 +0000 Subject: [PATCH 1578/2047] Refill to fit in 80 columns. (process-long-option): Fix bug: Keep track of `optional' value-required info and use this to determine whether or not the next element is to be taken as the option arg. --- ice-9/getopt-long.scm | 366 ++++++++++++++++++++++++------------------ 1 file changed, 212 insertions(+), 154 deletions(-) diff --git a/ice-9/getopt-long.scm b/ice-9/getopt-long.scm index a5722dbf5..ab30658f6 100644 --- a/ice-9/getopt-long.scm +++ b/ice-9/getopt-long.scm @@ -1,5 +1,5 @@ ;;; Author: Russ McManus -;;; $Id: getopt-long.scm,v 1.4 2001-06-03 23:29:45 mvo Exp $ +;;; $Id: getopt-long.scm,v 1.5 2001-08-02 10:26:52 ttn Exp $ ;;; ;;; Copyright (C) 1998, 2001 Free Software Foundation, Inc. ;;; @@ -190,147 +190,147 @@ (begin (define option-spec->name (lambda - (obj) + (obj) (if (option-spec? obj) (vector-ref obj 1) (slib:error - (quote option-spec->name) - ": bad record" - obj)))) + (quote option-spec->name) + ": bad record" + obj)))) (define option-spec->value (lambda - (obj) + (obj) (if (option-spec? obj) (vector-ref obj 2) (slib:error - (quote option-spec->value) - ": bad record" - obj)))) + (quote option-spec->value) + ": bad record" + obj)))) (define option-spec->value-required? (lambda - (obj) + (obj) (if (option-spec? obj) (vector-ref obj 3) (slib:error - (quote option-spec->value-required?) - ": bad record" - obj)))) + (quote option-spec->value-required?) + ": bad record" + obj)))) (define option-spec->single-char (lambda - (obj) + (obj) (if (option-spec? obj) (vector-ref obj 4) (slib:error - (quote option-spec->single-char) - ": bad record" - obj)))) + (quote option-spec->single-char) + ": bad record" + obj)))) (define option-spec->predicate-ls (lambda - (obj) + (obj) (if (option-spec? obj) (vector-ref obj 5) (slib:error - (quote option-spec->predicate-ls) - ": bad record" - obj)))) + (quote option-spec->predicate-ls) + ": bad record" + obj)))) (define option-spec->parse-ls (lambda - (obj) + (obj) (if (option-spec? obj) (vector-ref obj 6) (slib:error - (quote option-spec->parse-ls) - ": bad record" - obj)))) + (quote option-spec->parse-ls) + ": bad record" + obj)))) (define set-option-spec-name! (lambda - (obj val) + (obj val) (if (option-spec? obj) (vector-set! obj 1 val) (slib:error - (quote set-option-spec-name!) - ": bad record" - obj)))) + (quote set-option-spec-name!) + ": bad record" + obj)))) (define set-option-spec-value! (lambda - (obj val) + (obj val) (if (option-spec? obj) (vector-set! obj 2 val) (slib:error - (quote set-option-spec-value!) - ": bad record" - obj)))) + (quote set-option-spec-value!) + ": bad record" + obj)))) (define set-option-spec-value-required?! (lambda - (obj val) + (obj val) (if (option-spec? obj) (vector-set! obj 3 val) (slib:error - (quote set-option-spec-value-required?!) - ": bad record" - obj)))) + (quote set-option-spec-value-required?!) + ": bad record" + obj)))) (define set-option-spec-single-char! (lambda - (obj val) + (obj val) (if (option-spec? obj) (vector-set! obj 4 val) (slib:error - (quote set-option-spec-single-char!) - ": bad record" - obj)))) + (quote set-option-spec-single-char!) + ": bad record" + obj)))) (define set-option-spec-predicate-ls! (lambda - (obj val) + (obj val) (if (option-spec? obj) (vector-set! obj 5 val) (slib:error - (quote set-option-spec-predicate-ls!) - ": bad record" - obj)))) + (quote set-option-spec-predicate-ls!) + ": bad record" + obj)))) (define set-option-spec-parse-ls! (lambda - (obj val) + (obj val) (if (option-spec? obj) (vector-set! obj 6 val) (slib:error - (quote set-option-spec-parse-ls!) - ": bad record" - obj)))) + (quote set-option-spec-parse-ls!) + ": bad record" + obj)))) (define option-spec? (lambda - (obj) + (obj) (and (vector? obj) (= (vector-length obj) 7) (eq? (vector-ref obj 0) (quote option-spec))))) (define make-option-spec (lambda - (option-spec->name - option-spec->value - option-spec->value-required? - option-spec->single-char - option-spec->predicate-ls - option-spec->parse-ls) + (option-spec->name + option-spec->value + option-spec->value-required? + option-spec->single-char + option-spec->predicate-ls + option-spec->parse-ls) (vector - (quote option-spec) - option-spec->name - option-spec->value - option-spec->value-required? - option-spec->single-char - option-spec->predicate-ls - option-spec->parse-ls)))) + (quote option-spec) + option-spec->name + option-spec->value + option-spec->value-required? + option-spec->single-char + option-spec->predicate-ls + option-spec->parse-ls)))) ;;; @@ -394,80 +394,102 @@ (let ((key (car ls)) (val (cadr ls))) (cond ((and (eq? key 'required?) val) - ;; required values are implemented as a predicate - (parse-iter (make-option-spec (option-spec->name spec) - (option-spec->value spec) - (option-spec->value-required? spec) - (option-spec->single-char spec) - (cons (make-option-required-predicate) - (option-spec->predicate-ls spec)) - (cdr parse-ls)))) - ;; if the value is not required, then don't add a predicate, + ;; required values implemented as a predicate + (parse-iter + (make-option-spec + (option-spec->name spec) + (option-spec->value spec) + (option-spec->value-required? spec) + (option-spec->single-char spec) + (cons (make-option-required-predicate) + (option-spec->predicate-ls spec)) + (cdr parse-ls)))) + ;; if value not required, don't add predicate, ((eq? key 'required?) - (parse-iter (make-option-spec (option-spec->name spec) - (option-spec->value spec) - (option-spec->value-required? spec) - (option-spec->single-char spec) - (option-spec->predicate-ls spec) - (cdr parse-ls)))) + (parse-iter + (make-option-spec + (option-spec->name spec) + (option-spec->value spec) + (option-spec->value-required? spec) + (option-spec->single-char spec) + (option-spec->predicate-ls spec) + (cdr parse-ls)))) ;; handle value specification ((eq? key 'value) (cond ((eq? val #t) - ;; when value is required, add a predicate to that effect - ;; and record the fact in value-required? field. - (parse-iter (make-option-spec (option-spec->name spec) - (option-spec->value spec) - #t - (option-spec->single-char spec) - (cons (make-required-value-fn) - (option-spec->predicate-ls spec)) - (cdr parse-ls)))) + ;; when value is required, add a + ;; predicate to that effect and record + ;; the fact in value-required? field. + (parse-iter + (make-option-spec + (option-spec->name spec) + (option-spec->value spec) + #t + (option-spec->single-char spec) + (cons (make-required-value-fn) + (option-spec->predicate-ls spec)) + (cdr parse-ls)))) ((eq? val #f) - ;; when the value is not allowed, add a predicate to that effect. - ;; one can detect that a value is not supplied by checking the option - ;; value against #f. - (parse-iter (make-option-spec (option-spec->name spec) - (option-spec->value spec) - #f - (option-spec->single-char spec) - (cons (make-not-allowed-value-fn) - (option-spec->predicate-ls spec)) - (cdr parse-ls)))) + ;; when the value is not allowed, add a + ;; predicate to that effect. one can + ;; detect that a value is not supplied + ;; by checking the option value against + ;; #f. + (parse-iter + (make-option-spec + (option-spec->name spec) + (option-spec->value spec) + #f + (option-spec->single-char spec) + (cons (make-not-allowed-value-fn) + (option-spec->predicate-ls spec)) + (cdr parse-ls)))) ((eq? val 'optional) - ;; for optional values, don't add a predicate. do, however - ;; put the value 'optional in the value-required? field. this - ;; setting checks whether optional values are 'greedy'. set - ;; to #f to make optional value clauses 'non-greedy'. - - (parse-iter (make-option-spec (option-spec->name spec) - (option-spec->value spec) - 'optional - (option-spec->single-char spec) - (option-spec->predicate-ls spec) - (cdr parse-ls)))) + ;; for optional values, don't add a + ;; predicate. do, however put the value + ;; 'optional in the value-required? + ;; field. this setting checks whether + ;; optional values are 'greedy'. set to + ;; #f to make optional value clauses + ;; 'non-greedy'. + (parse-iter + (make-option-spec + (option-spec->name spec) + (option-spec->value spec) + 'optional + (option-spec->single-char spec) + (option-spec->predicate-ls spec) + (cdr parse-ls)))) (#t ;; error case - (error "Bad value specification for option:" (cons key val))))) - ;; specify which single char is defined for this option. + (error "Bad value specification for option:" + (cons key val))))) + ;; specify single char defined for this option. ((eq? key 'single-char) (if (not (single-char-value? val)) - (error "Not a single-char-value:" val " for option:" key) - (parse-iter (make-option-spec (option-spec->name spec) - (option-spec->value spec) - (option-spec->value-required? spec) - val - (option-spec->predicate-ls spec) - (cdr parse-ls))))) + (error "Not a single-char-value:" + val " for option:" key) + (parse-iter + (make-option-spec + (option-spec->name spec) + (option-spec->value spec) + (option-spec->value-required? spec) + val + (option-spec->predicate-ls spec) + (cdr parse-ls))))) ((eq? key 'predicate) (if (procedure? val) - (parse-iter (make-option-spec (option-spec->name spec) - (option-spec->value spec) - (option-spec->value-required? spec) - (option-spec->single-char spec) - (cons (make-user-predicate val) - (option-spec->predicate-ls spec)) - (cdr parse-ls))) - (error "Bad predicate specified for option:" (cons key val)))))))))))) + (parse-iter + (make-option-spec + (option-spec->name spec) + (option-spec->value spec) + (option-spec->value-required? spec) + (option-spec->single-char spec) + (cons (make-user-predicate val) + (option-spec->predicate-ls spec)) + (cdr parse-ls))) + (error "Bad predicate specified for option:" + (cons key val)))))))))))) (if (or (not (pair? desc)) (string? (car desc))) (error "Bad option specification:" desc)) @@ -514,26 +536,30 @@ is the list to not process." ((is-short-opt? (car opt-ls)) (let* ((orig-str (car opt-ls)) (match-pair (vector-ref response 2)) - (match-str (substring orig-str (car match-pair) (cdr match-pair)))) + (match-str (substring orig-str (car match-pair) + (cdr match-pair)))) (if (= (string-length match-str) 1) (iter (cdr opt-ls) (cons (string-append "-" match-str) ret-ls)) - (iter (cons (string-append "-" (substring match-str 1)) (cdr opt-ls)) - (cons (string-append "-" (substring match-str 0 1)) ret-ls))))) + (iter (cons (string-append "-" (substring match-str 1)) + (cdr opt-ls)) + (cons (string-append "-" (substring match-str 0 1)) + ret-ls))))) (#t (iter (cdr opt-ls) (cons (car opt-ls) ret-ls))))) (iter opt-ls '()))) (define (process-short-option specifications argument-ls alist) "Process a single short option that appears at the front of the ARGUMENT-LS, -according to SPECIFICATIONS. Returns #f is there is no such argument. Otherwise -returns a pair whose car is the list of remaining arguments, and whose cdr is a -new association list, constructed by adding a pair to the supplied ALIST. -The pair on the front of the returned association list describes the option -found at the head of ARGUMENT-LS. The way this routine currently works, an -option that never takes a value that is followed by a non option will cause -an error, which is probably a bug. To fix the bug the option specification -needs to record whether the option ever can take a value." +according to SPECIFICATIONS. Returns #f is there is no such argument. +Otherwise returns a pair whose car is the list of remaining arguments, and +whose cdr is a new association list, constructed by adding a pair to the +supplied ALIST. The pair on the front of the returned association list +describes the option found at the head of ARGUMENT-LS. The way this routine +currently works, an option that never takes a value that is followed by a non +option will cause an error, which is probably a bug. To fix the bug the +option specification needs to record whether the option ever can take a +value." (define (short-option->char option) (string-ref option 1)) (define (is-short-option? option) @@ -543,29 +569,36 @@ needs to record whether the option ever can take a value." (regexp-exec long-opt-no-value-rx option))) (define (find-matching-spec option) (let ((key (short-option->char option))) - (find-if (lambda (spec) (eq? key (option-spec->single-char spec))) specifications))) + (find-if (lambda (spec) + (eq? key (option-spec->single-char spec))) specifications))) (let ((option (car argument-ls))) (if (is-short-option? option) (let ((spec (find-matching-spec option))) (if spec - (let* ((next-value (if (null? (cdr argument-ls)) #f (cadr argument-ls))) + (let* ((next-value (if (null? (cdr argument-ls)) + #f + (cadr argument-ls))) (option-value (if (and next-value (not (is-short-option? next-value)) (not (is-long-option? next-value)) (option-spec->value-required? spec)) next-value #t)) - (new-alist (cons (cons (option-spec->name spec) option-value) alist))) + (new-alist (cons (cons (option-spec->name spec) + option-value) + alist))) (cons (if (eq? option-value #t) - (cdr argument-ls) ; there was one value specified, skip just one - (cddr argument-ls)) ; there must have been a value specified, skip two + (cdr argument-ls) ; one value, skip just one + (cddr argument-ls)) ; must be a value, skip two new-alist)) (error "No such option:" option))) #f))) (define (process-long-option specifications argument-ls alist) (define (find-matching-spec key) - (find-if (lambda (spec) (eq? key (option-spec->name spec))) specifications)) + (find-if (lambda (spec) + (eq? key (option-spec->name spec))) + specifications)) (define (split-long-option option) ;; returns a pair whose car is a symbol naming the option, cdr is ;; the option value. as a special case, if the option value is @@ -577,27 +610,50 @@ needs to record whether the option ever can take a value." ;; Maybe we need to grab a value from argument-ls. To find ;; out we need to refer to the option-spec. (let* ((key-pair (vector-ref resp 2)) - (key (string->symbol (substring option (car key-pair) (cdr key-pair)))) + (key (string->symbol + (substring option (car key-pair) (cdr key-pair)))) (spec (find-matching-spec key))) - (cons key (if (option-spec->value-required? spec) #f #t))) + (let* ((req (option-spec->value-required? spec)) + (retval (cons key (if req #f #t)))) + ;; this is a fucking kludge, i hate it. it's necessary because + ;; the protocol (return #f to indicate next element is an option + ;; arg) is insufficient. needs redesign. why am i checking in + ;; such ugliness? read moby dick! -ttn + (and (eq? 'optional req) + (set-object-property! retval 'optional #t)) + retval)) (let ((resp (regexp-exec long-opt-with-value-rx option))) ;; Aha, we've found a long option with an equal sign. The ;; option value is simply the value to the right of the ;; equal sign. (if resp (let* ((key-pair (vector-ref resp 2)) - (key (string->symbol (substring option (car key-pair) (cdr key-pair)))) + (key (string->symbol + (substring option + (car key-pair) (cdr key-pair)))) (value-pair (vector-ref resp 3)) - (value (substring option (car value-pair) (cdr value-pair)))) + (value (substring option + (car value-pair) (cdr value-pair)))) (cons key value)) - #f))))) + #f))))) (let* ((option (car argument-ls)) (pair (split-long-option option))) (cond ((and pair (eq? (cdr pair) #f)) - (if (null? (cdr argument-ls)) - (error "Not enough options.") - (cons (cddr argument-ls) - (cons (cons (car pair) (cadr argument-ls)) alist)))) + (cond ((and (null? (cdr argument-ls)) + (not (object-property pair 'optional))) + (error "Not enough options.")) + ((null? (cdr argument-ls)) + (cons '() (cons (cons (car pair) #t) alist))) + ((let* ((next (cadr argument-ls)) + (m (or (regexp-exec short-opt-rx next) + (regexp-exec long-opt-with-value-rx next) + (regexp-exec long-opt-no-value-rx next)))) + (and m (object-property pair 'optional))) + (cons (cdr argument-ls) + (cons (cons (car pair) #t) alist))) + (else + (cons (cddr argument-ls) + (cons (cons (car pair) (cadr argument-ls)) alist))))) (pair (cons (cdr argument-ls) (cons pair alist))) (else #f)))) @@ -611,7 +667,8 @@ needs to record whether the option ever can take a value." (let ((argument-ls (car pair)) (alist (cdr pair))) (iter argument-ls alist rest-ls)) - (let ((pair (process-long-option specifications argument-ls alist))) + (let ((pair (process-long-option + specifications argument-ls alist))) (if pair (let ((argument-ls (car pair)) (alist (cdr pair))) @@ -659,11 +716,12 @@ to add a 'single-char' clause to the option description." (let* ((opt-pair (process-options specifications split-ls)) (alist (car opt-pair)) (rest-ls (append (cdr opt-pair) non-split-ls))) - ;; loop through the returned alist, and set the values into the specifications + ;; loop through returned alist, set values into specifications (for-each (lambda (pair) (let* ((key (car pair)) (val (cdr pair)) - (spec (find-if (lambda (spec) (eq? key (option-spec->name spec))) + (spec (find-if (lambda (spec) + (eq? key (option-spec->name spec))) specifications))) (if spec (set-option-spec-value! spec val)))) alist) From 8940c16b17df0dd2cdbec8b7a40d751dbb87d76b Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Thu, 2 Aug 2001 10:29:32 +0000 Subject: [PATCH 1579/2047] *** empty log message *** --- ice-9/ChangeLog | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 93d053506..844f1a825 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,11 @@ +2001-08-02 Thien-Thi Nguyen + + * getopt-long.scm: Refill to fit in 80 columns. + + (process-long-option): Fix bug: Keep track of `optional' + value-required info and use this to determine whether or not the + next element is to be taken as the option arg. + 2001-07-31 Keisuke Nishida * boot-9.scm (process-define-module): Fixed a bug that did not @@ -67,7 +75,7 @@ Changes to support tracing other than inside the repl-stack that is set up by the REPL code in boot-9.scm. - + * debug.scm (trace-entry, trace-exit): Conditionalize tracing on whether the current stack id is in `traced-stack-ids'. (traced-stack-ids, trace-all-stacks?, trace-stack, untrace-stack): @@ -82,7 +90,7 @@ * debug.scm (trace): Set evaluator trap options to handle tracing. Don't reset trace-level to 0. - + * boot-9.scm (lazy-handler-dispatch): Remove enter-frame-handler, apply-frame-handler and exit-frame-handler. (They're replaced by evaluator trap options.) From 8c84b81ecade2e364e725506b0ef91ff5dc4c8c1 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Thu, 2 Aug 2001 10:48:12 +0000 Subject: [PATCH 1580/2047] *** empty log message *** --- AUTHORS | 6 ++++-- NEWS | 10 +++++++++- 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/AUTHORS b/AUTHORS index c1dd0b3ed..2eeba2c1b 100644 --- a/AUTHORS +++ b/AUTHORS @@ -220,7 +220,7 @@ In the top-level directory, wrote: In the subdirectory ice-9, changes to: boot-9.scm documentation.scm emacs.scm ls.scm session.scm string-fun.scm - threads.scm + threads.scm getopt-long.scm In the subdirectory scripts, wrote: Makefile.am PROGRAM display-commentary generate-autoload @@ -236,8 +236,10 @@ In the subdirectory doc, changes to: scheme-scheduling.texi In the subdirectory test-suite, changes to: guile-test lib.scm +In the subdirectory test-suite/tests, wrote: + exceptions.test getopt-long.test In the subdirectory test-suite/tests, changes to: - exceptions.test eval.test + eval.test Robert Merkel: In the subdirectory doc, co-wrote: diff --git a/NEWS b/NEWS index ea966c86d..eadbbf48d 100644 --- a/NEWS +++ b/NEWS @@ -6,7 +6,7 @@ Please send Guile bug reports to bug-guile@gnu.org. Changes since the stable branch: -** Variables have no longer a special behavior for `equal?'. +** Variables have no longer a special behavior for `equal?'. Previously, comparing two variables with `equal?' would recursivly compare their values. This is no longer done. Variables are now only @@ -681,6 +681,14 @@ Use module system operations for all variables. That is, a call to `throw', `error', etc is now guaranteed to not return. +** Bugfix for (ice-9 getopt-long) + +Parsing for options that are specified to have `optional' args now checks if +the next element is an option instead of unconditionally taking it as the +option arg. + +Also, this module is now tested using test-suite/tests/getopt-long.test. + * Changes to the C interface ** Types have been renamed from scm_*_t to scm_t_*. From ee0346032640284cba26f596dd90d09bf1562a13 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 2 Aug 2001 19:45:07 +0000 Subject: [PATCH 1581/2047] * Added `call-with-readline-completion-function'. --- guile-readline/ChangeLog | 4 ++++ guile-readline/readline.scm | 10 ++++++++++ 2 files changed, 14 insertions(+) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index e431af5bf..aba59dcb3 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,7 @@ +2001-08-02 Neil Jerram + + * readline.scm (call-with-readline-completion-function): New. + 2001-07-18 Martin Grabmueller * Makefile.am, readline.scm: Updated copyright notice. diff --git a/guile-readline/readline.scm b/guile-readline/readline.scm index 24f9de58f..99e63bce0 100644 --- a/guile-readline/readline.scm +++ b/guile-readline/readline.scm @@ -187,6 +187,16 @@ (set! *readline-completion-function* apropos-completion-function) )) +(define-public (call-with-readline-completion-function completer thunk) + "With @var{completer} as readline completion function, call @var{thunk}." + (let ((old-completer *readline-completion-function*)) + (dynamic-wind + (lambda () + (set! *readline-completion-function* completer)) + thunk + (lambda () + (set! *readline-completion-function* old-completer))))) + (define-public (activate-readline) (if (and (isatty? (current-input-port)) (not (and (module-defined? the-root-module 'use-emacs-interface) From d3b924ba3bd0bf4958c1893e8f4ff66216b5f2fe Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 2 Aug 2001 19:52:09 +0000 Subject: [PATCH 1582/2047] * Fix obscure debugger bug - trying to rerun last command when last command fluid is not yet set. --- ice-9/ChangeLog | 5 +++++ ice-9/debugger.scm | 3 ++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 844f1a825..62ba0a291 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2001-08-02 Neil Jerram + + * debugger.scm (run-last-command): Return current state if + last-command fluid is not yet set. + 2001-08-02 Thien-Thi Nguyen * getopt-long.scm: Refill to fit in 80 columns. diff --git a/ice-9/debugger.scm b/ice-9/debugger.scm index 3bf29ab75..f98509c2c 100644 --- a/ice-9/debugger.scm +++ b/ice-9/debugger.scm @@ -114,7 +114,8 @@ (define (run-last-command state) (let ((procedure (fluid-ref last-command))) (if procedure - (procedure state)))) + (procedure state) + state))) (define (catch-user-errors port thunk) (catch 'debugger-user-error From baffb19f273aaa2fe71f6dcd6f8ca9e1c23eab91 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 2 Aug 2001 20:26:21 +0000 Subject: [PATCH 1583/2047] * Explain cutting args for `make-stack'. --- libguile/ChangeLog | 5 +++++ libguile/stacks.c | 23 ++++++++++++++++++++--- 2 files changed, 25 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 8570e57db..b0a1460e4 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-08-02 Neil Jerram + + * stacks.c (scm_make_stack): Improve docstring by explaining use + of cutting args. + 2001-08-01 Marius Vollmer * chars.c (scm_char_alphabetic_p, scm_char_numeric_p, diff --git a/libguile/stacks.c b/libguile/stacks.c index c49924a38..c00b47bf5 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -420,9 +420,26 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, "Create a new stack. If @var{obj} is @code{#t}, the current\n" "evaluation stack is used for creating the stack frames,\n" "otherwise the frames are taken from @var{obj} (which must be\n" - "either a debug object or a continuation).\n" - "@var{args} must be a list of integers and specifies how the\n" - "resulting stack will be narrowed.") + "either a debug object or a continuation).\n\n" + "@var{args} should be a list containing any combination of\n" + "integer, procedure and @code{#t} values.\n\n" + "These values specify various ways of cutting away uninteresting\n" + "stack frames from the top and bottom of the stack that\n" + "@code{make-stack} returns. They come in pairs like this:\n" + "@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}\n" + "@var{outer_cut_2} @dots{})}.\n\n" + "Each @var{inner_cut_N} can be @code{#t}, an integer, or a\n" + "procedure. @code{#t} means to cut away all frames up to but\n" + "excluding the first user module frame. An integer means to cut\n" + "away exactly that number of frames. A procedure means to cut\n" + "away all frames up to but excluding the application frame whose\n" + "procedure matches the specified one.\n\n" + "Each @var{outer_cut_N} can be an integer or a procedure. An\n" + "integer means to cut away that number of frames. A procedure\n" + "means to cut away frames down to but excluding the application\n" + "frame whose procedure matches the specified one.\n\n" + "If the @var{outer_cut_N} of the last pair is missing, it is\n" + "taken as 0.") #define FUNC_NAME s_scm_make_stack { long n, size; From 3524efbcd9f45174a4fec6a1802697531f63cc97 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 2 Aug 2001 20:27:42 +0000 Subject: [PATCH 1584/2047] * Improve `make-stack' doc by explaining cutting args. --- doc/ChangeLog | 5 ++ doc/scheme-debug.texi | 165 ------------------------------------------ 2 files changed, 5 insertions(+), 165 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 4f5660483..3d6210db9 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,8 @@ +2001-08-02 Neil Jerram + + * scheme-debug.texi (Debugging): Improve `make-stack' doc by + explaining cutting args. + 2001-07-19 Rob Browning * posix.texi (Signals): add docs for setitimer and getitimer. diff --git a/doc/scheme-debug.texi b/doc/scheme-debug.texi index cbb35cb17..e69de29bb 100644 --- a/doc/scheme-debug.texi +++ b/doc/scheme-debug.texi @@ -1,165 +0,0 @@ -@page -@node Debugging -@chapter Internal Debugging Interface - ---- The name of this chapter needs to clearly distinguish it - from the appendix describing the debugger UI. The intro - should have a pointer to the UI appendix. - -@deffn primitive display-error stack port subr message args rest -Display an error message to the output port @var{port}. -@var{stack} is the saved stack for the error, @var{subr} is -the name of the procedure in which the error occured and -@var{message} is the actual error message, which may contain -formatting instructions. These will format the arguments in -the list @var{args} accordingly. @var{rest} is currently -ignored. -@end deffn - -@deffn primitive display-application frame [port [indent]] -Display a procedure application @var{frame} to the output port -@var{port}. @var{indent} specifies the indentation of the -output. -@end deffn - -@deffn primitive display-backtrace stack port [first [depth]] -Display a backtrace to the output port @var{port}. @var{stack} -is the stack to take the backtrace from, @var{first} specifies -where in the stack to start and @var{depth} how much frames -to display. Both @var{first} and @var{depth} can be @code{#f}, -which means that default values will be used. -@end deffn - -@deffn primitive backtrace -Display a backtrace of the stack saved by the last error -to the current output port. -@end deffn - -@deffn primitive malloc-stats -Return an alist ((@var{what} . @var{n}) ...) describing number -of malloced objects. -@var{what} is the second argument to @code{scm_must_malloc}, -@var{n} is the number of objects of that type currently -allocated. -@end deffn - -@deffn primitive debug-options-interface [setting] -Option interface for the debug options. Instead of using -this procedure directly, use the procedures @code{debug-enable}, -@code{debug-disable}, @code{debug-set!} and @var{debug-options}. -@end deffn - -@deffn primitive with-traps thunk -Call @var{thunk} with traps enabled. -@end deffn - -@deffn primitive memoized? obj -Return @code{#t} if @var{obj} is memoized. -@end deffn - -@deffn primitive unmemoize m -Unmemoize the memoized expression @var{m}, -@end deffn - -@deffn primitive memoized-environment m -Return the environment of the memoized expression @var{m}. -@end deffn - -@deffn primitive procedure-name proc -Return the name of the procedure @var{proc} -@end deffn - -@deffn primitive procedure-source proc -Return the source of the procedure @var{proc}. -@end deffn - -@deffn primitive procedure-environment proc -Return the environment of the procedure @var{proc}. -@end deffn - -@deffn primitive debug-object? obj -Return @code{#t} if @var{obj} is a debug object. -@end deffn - -@deffn primitive frame-arguments frame -Return the arguments of @var{frame}. -@end deffn - -@deffn primitive frame-evaluating-args? frame -Return @code{#t} if @var{frame} contains evaluated arguments. -@end deffn - -@deffn primitive frame-next frame -Return the next frame of @var{frame}, or @code{#f} if -@var{frame} is the last frame in its stack. -@end deffn - -@deffn primitive frame-number frame -Return the frame number of @var{frame}. -@end deffn - -@deffn primitive frame-overflow? frame -Return @code{#t} if @var{frame} is an overflow frame. -@end deffn - -@deffn primitive frame-previous frame -Return the previous frame of @var{frame}, or @code{#f} if -@var{frame} is the first frame in its stack. -@end deffn - -@deffn primitive frame-procedure frame -Return the procedure for @var{frame}, or @code{#f} if no -procedure is associated with @var{frame}. -@end deffn - -@deffn primitive frame-procedure? frame -Return @code{#t} if a procedure is associated with @var{frame}. -@end deffn - -@deffn primitive frame-real? frame -Return @code{#t} if @var{frame} is a real frame. -@end deffn - -@deffn primitive frame-source frame -Return the source of @var{frame}. -@end deffn - -@deffn primitive frame? obj -Return @code{#t} if @var{obj} is a stack frame. -@end deffn - -@deffn primitive last-stack-frame obj -Return a stack which consists of a single frame, which is the -last stack frame for @var{obj}. @var{obj} must be either a -debug object or a continuation. -@end deffn - -@deffn primitive make-stack obj . args -Create a new stack. If @var{obj} is @code{#t}, the current -evaluation stack is used for creating the stack frames, -otherwise the frames are taken from @var{obj} (which must be -either a debug object or a continuation). -@var{args} must be a list of integers and specifies how the -resulting stack will be narrowed. -@end deffn - -@deffn primitive stack-id stack -Return the identifier given to @var{stack} by @code{start-stack}. -@end deffn - -@deffn primitive stack-length stack -Return the length of @var{stack}. -@end deffn - -@deffn primitive stack-ref stack i -Return the @var{i}'th frame from @var{stack}. -@end deffn - -@deffn primitive stack? obj -Return @code{#t} if @var{obj} is a calling stack. -@end deffn - - -@c Local Variables: -@c TeX-master: "guile.texi" -@c End: From 848458d99068f7542b5f63d52eb2338595a5fb1e Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sat, 4 Aug 2001 18:37:08 +0000 Subject: [PATCH 1585/2047] * srfi-1.scm (filter): replaced with a tail-recursive version. (remove): implement using filter, to make it tail-recursive. --- srfi/ChangeLog | 5 +++++ srfi/srfi-1.scm | 20 ++++++++++---------- 2 files changed, 15 insertions(+), 10 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 109ff9940..d4b650181 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,8 @@ +2001-08-04 Gary Houston + + * srfi-1.scm (filter): replaced with a tail-recursive version. + (remove): implement using filter, to make it tail-recursive. + 2001-07-31 Gary Houston * srfi-14.c (scm_char_set_diff_plus_intersection): wasn't correctly diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm index 4c361a57e..cd2ca757d 100644 --- a/srfi/srfi-1.scm +++ b/srfi/srfi-1.scm @@ -720,11 +720,15 @@ ;;; Filtering & partitioning (define (filter pred list) - (if (null? list) - '() - (if (pred (car list)) - (cons (car list) (filter pred (cdr list))) - (filter pred (cdr list))))) + (letrec ((filiter (lambda (pred rest result) + (if (null? rest) + (reverse! result) + (filiter pred (cdr rest) + (cond ((pred (car rest)) + (cons (car rest) result)) + (else + result))))))) + (filiter pred list '()))) (define (partition pred list) (if (null? list) @@ -736,11 +740,7 @@ (values in (cons (car list) out)))))) (define (remove pred list) - (if (null? list) - '() - (if (pred (car list)) - (remove pred (cdr list)) - (cons (car list) (remove pred (cdr list)))))) + (filter (lambda (x) (not (pred x))) list)) (define (filter! pred list) (filter pred list)) ; XXX:optimize From 5753f02f67d31e87bceba2b1f559c20e6e21b015 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 5 Aug 2001 10:12:37 +0000 Subject: [PATCH 1586/2047] * srfi-1.scm (check-arg-type, non-negative-integer?): a couple of new internal definitions. (list-tabulate, iota): check for bad arguments that otherwise give weird output. (filter): check for proper list, to avoid infinite recursion on a circular list. --- srfi/ChangeLog | 9 +++++++++ srfi/srfi-1.scm | 13 +++++++++++++ 2 files changed, 22 insertions(+) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index d4b650181..d2e94bbe5 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,12 @@ +2001-08-05 Gary Houston + + * srfi-1.scm (check-arg-type, non-negative-integer?): a couple of new + internal definitions. + (list-tabulate, iota): check for bad arguments that otherwise + give weird output. + (filter): check for proper list, to avoid infinite recursion on + a circular list. + 2001-08-04 Gary Houston * srfi-1.scm (filter): replaced with a tail-recursive version. diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm index cd2ca757d..f58c1ebfe 100644 --- a/srfi/srfi-1.scm +++ b/srfi/srfi-1.scm @@ -254,7 +254,18 @@ (define (xcons d a) (cons a d)) +;; internal helper, similar to (scsh utilities) check-arg. +(define (check-arg-type pred arg caller) + (if (pred arg) + arg + (scm-error 'wrong-type-arg caller + "Wrong type argument: ~S" (list arg) '()))) + +;; the srfi spec doesn't seem to forbid inexact integers. +(define (non-negative-integer? x) (and (integer? x) (>= x 0))) + (define (list-tabulate n init-proc) + (check-arg-type non-negative-integer? n "list-tabulate") (let lp ((n n) (acc '())) (if (<= n 0) acc @@ -272,6 +283,7 @@ (lp (cdr r) (cdr p))))))) (define (iota count . rest) + (check-arg-type non-negative-integer? count "iota") (let ((start (if (pair? rest) (car rest) 0)) (step (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) 1))) (let lp ((n 0) (acc '())) @@ -720,6 +732,7 @@ ;;; Filtering & partitioning (define (filter pred list) + (check-arg-type list? list "caller") ; reject circular lists. (letrec ((filiter (lambda (pred rest result) (if (null? rest) (reverse! result) From fd7ec88302a3307b5d83ca16ff30fdbbc6409bfa Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Mon, 6 Aug 2001 23:19:05 +0000 Subject: [PATCH 1587/2047] * snarf-check-and-output-texi: print optional args in a prettier manner. --- scripts/ChangeLog | 5 +++++ scripts/snarf-check-and-output-texi | 35 ++++++++++++++--------------- 2 files changed, 22 insertions(+), 18 deletions(-) diff --git a/scripts/ChangeLog b/scripts/ChangeLog index 0a8dab25a..b4eced90c 100644 --- a/scripts/ChangeLog +++ b/scripts/ChangeLog @@ -1,3 +1,8 @@ +2001-08-07 Michael Livshin + + * snarf-check-and-output-texi: print optional args in a prettier + manner. + 2001-08-01 Thien-Thi Nguyen * PROGRAM, README, display-commentary, doc-snarf, diff --git a/scripts/snarf-check-and-output-texi b/scripts/snarf-check-and-output-texi index bc1287b38..a300ca78e 100755 --- a/scripts/snarf-check-and-output-texi +++ b/scripts/snarf-check-and-output-texi @@ -152,26 +152,25 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" (with-output-to-string (lambda () (format #t "~A" *function-name*) - (let loop-req ((r 0)) + (let loop-req ((args *args*) (r 0)) (if (< r req) (begin - (format #t " ~A" (list-ref *args* r)) - (loop-req (+ 1 r))) - (begin - (if (> opt 0) - (format #t "~A[" (if (> req 0) " " ""))) - (let loop-opt ((o 0) (space #f)) - (if (< o opt) - (begin - (format #t "~A~A" (if space " " "") - (list-ref *args* (+ r o))) - (loop-opt (+ 1 o) #t)) - (begin - (if (> opt 0) - (format #t "]")) - (if (> var 0) - (format #t " . ~A" - (car (last-pair *args*))))))))))))))) + (format #t " ~A" (car args)) + (loop-req (cdr args) (+ 1 r))) + (let loop-opt ((o 0) (args args) (tail '())) + (if (< o opt) + (begin + (format #t " [~A" (car args)) + (loop-opt (+ 1 o) (cdr args) (cons #\] tail))) + (begin + (if (> var 0) + (format #t " . ~A" + (car args))) + (let loop-tail ((tail tail)) + (if (not (null? tail)) + (begin + (format #t "~A" (car tail)) + (loop-tail (cdr tail))))))))))))))) (format #t "\n ~A\n" *function-name*) (format #t "@c snarfed from ~A:~A\n" *file* *line*) (format #t "@deffn primitive ~A\n" nice-sig) From 8b1d12c79a19778c0c1bbc15ea074f62a9e6843e Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Mon, 6 Aug 2001 23:19:50 +0000 Subject: [PATCH 1588/2047] * guile-snarf-docs-texi.in: don't call the tokenizer here, we now do it from the Makefile. * Makefile.am: rearrange the snarfing slightly, so that .doc files are of a reasonable size. --- libguile/ChangeLog | 8 ++++++++ libguile/Makefile.am | 10 +++++----- libguile/guile-snarf-docs-texi.in | 2 +- 3 files changed, 14 insertions(+), 6 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b0a1460e4..be1fbc87a 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2001-08-07 Michael Livshin + + * guile-snarf-docs-texi.in: don't call the tokenizer here, we now + do it from the Makefile. + + * Makefile.am: rearrange the snarfing slightly, so that .doc files + are of a reasonable size. + 2001-08-02 Neil Jerram * stacks.c (scm_make_stack): Improve docstring by explaining use diff --git a/libguile/Makefile.am b/libguile/Makefile.am index c16bf2f2f..c8c7b8960 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -192,19 +192,19 @@ SUFFIXES = .x .doc || { rm $@; false; } .c.doc: -(test -n "${AWK+set}" || AWK="@AWK@"; ${AWK} -f ./guile-func-name-check $<) - ./guile-snarf-docs $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \ - || { rm $@; false; } + (./guile-snarf-docs $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< | \ + ./guile_filter_doc_snarfage --filter-snarfage) > $@ || { rm $@; false; } $(DOT_X_FILES) $(EXTRA_DOT_DOC_FILES): snarf.h guile-snarf.in -$(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES): snarf.h guile-snarf-docs.in +$(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES): snarf.h guile-snarf-docs.in guile_filter_doc_snarfage error.x: cpp_err_symbols.c posix.x: cpp_sig_symbols.c load.x: libpath.h -guile.texi: $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) guile-snarf-docs-texi.in guile guile_filter_doc_snarfage - ./guile-snarf-docs-texi $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) > $@ \ +guile.texi: $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) guile-snarf-docs-texi.in guile + cat $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) | ./guile-snarf-docs-texi > $@ \ || { rm $@; false; } guile-procedures.txt: guile.texi diff --git a/libguile/guile-snarf-docs-texi.in b/libguile/guile-snarf-docs-texi.in index 0aa9f9cff..6481534b2 100755 --- a/libguile/guile-snarf-docs-texi.in +++ b/libguile/guile-snarf-docs-texi.in @@ -34,4 +34,4 @@ if [ `basename ${bindir}` = libguile ]; then GUILE_LOAD_PATH=${srcdir}/..; export GUILE_LOAD_PATH fi -cat "$@" | ${bindir}/guile_filter_doc_snarfage --filter-snarfage | ${bindir}/guile -c "${apply_main}" +${bindir}/guile -c "${apply_main}" From 720e1c3045f4bb78bfb5564beb2200805135e3d9 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 7 Aug 2001 14:39:02 +0000 Subject: [PATCH 1589/2047] *** empty log message *** --- NEWS | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/NEWS b/NEWS index eadbbf48d..bba3769b5 100644 --- a/NEWS +++ b/NEWS @@ -256,6 +256,14 @@ default. * Changes to Scheme functions and syntax +** Character classifiers work for non-ASCII characters. + +The predicates `char-alphabetic?', `char-numeric?', +`char-whitespace?', `char-lower?', `char-upper?' and `char-is-both?' +no longer check whether their arguments are ASCII characters. +Previously, a character would only be considered alphabetic when it +was also ASCII, for example. + ** Previously deprecated Scheme functions have been removed: tag - no replacement. From 41973b48bb529e2c512b971ef167805def9be3cd Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 7 Aug 2001 18:14:56 +0000 Subject: [PATCH 1590/2047] (EXTRA_DIST): Distribute ChangeLog-1996-1999 and ChangeLog-2000. Thanks to Daniel Skarda! --- libguile/Makefile.am | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index c8c7b8960..a97db45db 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -144,8 +144,9 @@ modinclude_DATA = scmconfig.h bin_SCRIPTS = guile-snarf guile-doc-snarf guile-snarf-docs \ guile-snarf-docs-texi guile-func-name-check -EXTRA_DIST = ChangeLog-gh ChangeLog-scm ChangeLog-threads cpp_signal.c \ - cpp_errno.c cpp_err_symbols.in cpp_sig_symbols.in cpp_cnvt.awk \ +EXTRA_DIST = ChangeLog-gh ChangeLog-scm ChangeLog-threads \ + ChangeLog-1996-1999 ChangeLog-2000 cpp_signal.c \ + cpp_errno.c cpp_err_symbols.in cpp_sig_symbols.in cpp_cnvt.awk \ c-tokenize.lex # $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \ # guile-procedures.txt guile.texi From bc79995a9a18b35c656d41b3ecb5c10f778f6cdc Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 7 Aug 2001 18:17:14 +0000 Subject: [PATCH 1591/2047] Added "test-suite/Makefile". --- configure.in | 1 + 1 file changed, 1 insertion(+) diff --git a/configure.in b/configure.in index 532f0ccfc..6bb4ef87c 100644 --- a/configure.in +++ b/configure.in @@ -641,6 +641,7 @@ AC_CONFIG_FILES([ examples/box-dynamic-module/Makefile examples/modules/Makefile examples/safe/Makefile + test-suite/Makefile check-guile guile-tools]) From c4361fe59466e860bc9b1bd621e55623f29574cb Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 7 Aug 2001 18:17:27 +0000 Subject: [PATCH 1592/2047] (EXTRA_DIST, SUBDIRS): Move test-suite from EXTRA_DIST to SUBDIRS. --- Makefile.am | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Makefile.am b/Makefile.am index a4824d826..e37a678a4 100644 --- a/Makefile.am +++ b/Makefile.am @@ -21,7 +21,7 @@ SUBDIRS = oop qt libltdl libguile ice-9 guile-config guile-readline \ - scripts srfi doc examples + scripts srfi doc examples test-suite bin_SCRIPTS = guile-tools @@ -30,7 +30,7 @@ include_HEADERS = libguile.h # automake sometimes forgets to distribute acconfig.h, # apparently depending on the phase of the moon. EXTRA_DIST = qthreads.m4 HACKING GUILE-VERSION ANON-CVS SNAPSHOTS TODO \ - test-suite $(ACLOCAL) acconfig.h + $(ACLOCAL) acconfig.h TESTS = check-guile From 067dd9c61c23cff69c10c65e0565645f66b2da40 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 7 Aug 2001 18:18:40 +0000 Subject: [PATCH 1593/2047] New file, to control distribution of the test-suite. --- test-suite/Makefile.am | 1 + 1 file changed, 1 insertion(+) create mode 100644 test-suite/Makefile.am diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am new file mode 100644 index 000000000..c2aaa7f57 --- /dev/null +++ b/test-suite/Makefile.am @@ -0,0 +1 @@ +EXTRA_DIST = guile-test lib.scm tests/*.test tests/asmobs tests/c-api From b754e3d1ecdb7db4db7e2b46b7c4ab8239c5adb7 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 7 Aug 2001 18:18:55 +0000 Subject: [PATCH 1594/2047] *** empty log message *** --- ChangeLog | 7 +++++++ libguile/ChangeLog | 5 +++++ test-suite/ChangeLog | 5 +++++ 3 files changed, 17 insertions(+) diff --git a/ChangeLog b/ChangeLog index e537d6951..2f5f0ce81 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2001-08-07 Marius Vollmer + + * Makefile.am (EXTRA_DIST, SUBDIRS): Move test-suite from + EXTRA_DIST to SUBDIRS. + + * configure.in: Added "test-suite/Makefile". + 2001-08-01 Marius Vollmer * configure.in: Added `--disable-linuxthreads' option and do not diff --git a/libguile/ChangeLog b/libguile/ChangeLog index be1fbc87a..f46645a44 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-08-07 Marius Vollmer + + * Makefile.am (EXTRA_DIST): Distribute ChangeLog-1996-1999 and + ChangeLog-2000. Thanks to Daniel Skarda! + 2001-08-07 Michael Livshin * guile-snarf-docs-texi.in: don't call the tokenizer here, we now diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 4c59ef578..ab281f5d4 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2001-08-07 Marius Vollmer + + * Makefile.am: New file, to control distribution of the + test-suite. + 2001-08-02 Thien-Thi Nguyen * tests/getopt-long.test: New file. From 46a39e343af3c27f222e529e14ce455c452f687c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 8 Aug 2001 16:34:57 +0000 Subject: [PATCH 1595/2047] *** empty log message *** --- .cvsignore | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/.cvsignore b/.cvsignore index 24aa42bcc..994f72bbc 100644 --- a/.cvsignore +++ b/.cvsignore @@ -1,18 +1,19 @@ Makefile Makefile.in aclocal.m4 +check-guile +check-guile.log config.build-subdirs config.cache config.guess -config.sub config.h.in config.log config.status +config.sub configure guile-*.tar.gz +guile-tools +libltdl libtool ltconfig ltmain.sh -check-guile -check-guile.log -guile-tools From 83060bc4e71c0bc1c289373406d31aa07aa5556b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 8 Aug 2001 16:41:28 +0000 Subject: [PATCH 1596/2047] (TESTS): List tests explicitely instead of using a wildcard. Wildcards don't seem to work for VPATH "make dist"s. --- test-suite/Makefile.am | 43 +++++++++++++++++++++++++++++++++++++++++- 1 file changed, 42 insertions(+), 1 deletion(-) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index c2aaa7f57..5206f26ae 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -1 +1,42 @@ -EXTRA_DIST = guile-test lib.scm tests/*.test tests/asmobs tests/c-api +TESTS = tests/alist.test \ + tests/asmobs \ + tests/bit-operations.test \ + tests/c-api \ + tests/c-api.test \ + tests/chars.test \ + tests/common-list.test \ + tests/environments.test \ + tests/eval.test \ + tests/exceptions.test \ + tests/format.test \ + tests/gc.test \ + tests/getopt-long.test \ + tests/goops.test \ + tests/guardians.test \ + tests/hooks.test \ + tests/import.test \ + tests/interp.test \ + tests/list.test \ + tests/load.test \ + tests/multilingual.nottest \ + tests/numbers.test \ + tests/optargs.test \ + tests/ports.test \ + tests/r4rs.test \ + tests/reader.test \ + tests/regexp.test \ + tests/srfi-10.test \ + tests/srfi-13.test \ + tests/srfi-14.test \ + tests/srfi-19.test \ + tests/srfi-4.test \ + tests/srfi-9.test \ + tests/strings.test \ + tests/symbols.test \ + tests/syncase.test \ + tests/syntax.test \ + tests/time.test \ + tests/version.test \ + tests/weaks.test + +EXTRA_DIST = guile-test lib.scm $(TESTS) From 5f09993304d52daf43efe5e542579d8c1bce7431 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 8 Aug 2001 16:41:38 +0000 Subject: [PATCH 1597/2047] *** empty log message *** --- test-suite/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index ab281f5d4..f01c7488f 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2001-08-08 Marius Vollmer + + * Makefile.am (TESTS): List tests explicitely instead of using a + wildcard. Wildcards don't seem to work for VPATH "make dist"s. + 2001-08-07 Marius Vollmer * Makefile.am: New file, to control distribution of the From 682542634b2fec0823302dc072084851621a11ec Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 9 Aug 2001 17:33:31 +0000 Subject: [PATCH 1598/2047] (TESTS): Do not call the variable "TESTS", call it "SCM_TESTS". This has special meaning to automake. How many tries left to get this right, mvo? --- test-suite/Makefile.am | 82 +++++++++++++++++++++--------------------- 1 file changed, 41 insertions(+), 41 deletions(-) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 5206f26ae..5db5ba0d2 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -1,42 +1,42 @@ -TESTS = tests/alist.test \ - tests/asmobs \ - tests/bit-operations.test \ - tests/c-api \ - tests/c-api.test \ - tests/chars.test \ - tests/common-list.test \ - tests/environments.test \ - tests/eval.test \ - tests/exceptions.test \ - tests/format.test \ - tests/gc.test \ - tests/getopt-long.test \ - tests/goops.test \ - tests/guardians.test \ - tests/hooks.test \ - tests/import.test \ - tests/interp.test \ - tests/list.test \ - tests/load.test \ - tests/multilingual.nottest \ - tests/numbers.test \ - tests/optargs.test \ - tests/ports.test \ - tests/r4rs.test \ - tests/reader.test \ - tests/regexp.test \ - tests/srfi-10.test \ - tests/srfi-13.test \ - tests/srfi-14.test \ - tests/srfi-19.test \ - tests/srfi-4.test \ - tests/srfi-9.test \ - tests/strings.test \ - tests/symbols.test \ - tests/syncase.test \ - tests/syntax.test \ - tests/time.test \ - tests/version.test \ - tests/weaks.test +SCM_TESTS = tests/alist.test \ + tests/asmobs \ + tests/bit-operations.test \ + tests/c-api \ + tests/c-api.test \ + tests/chars.test \ + tests/common-list.test \ + tests/environments.test \ + tests/eval.test \ + tests/exceptions.test \ + tests/format.test \ + tests/gc.test \ + tests/getopt-long.test \ + tests/goops.test \ + tests/guardians.test \ + tests/hooks.test \ + tests/import.test \ + tests/interp.test \ + tests/list.test \ + tests/load.test \ + tests/multilingual.nottest \ + tests/numbers.test \ + tests/optargs.test \ + tests/ports.test \ + tests/r4rs.test \ + tests/reader.test \ + tests/regexp.test \ + tests/srfi-10.test \ + tests/srfi-13.test \ + tests/srfi-14.test \ + tests/srfi-19.test \ + tests/srfi-4.test \ + tests/srfi-9.test \ + tests/strings.test \ + tests/symbols.test \ + tests/syncase.test \ + tests/syntax.test \ + tests/time.test \ + tests/version.test \ + tests/weaks.test -EXTRA_DIST = guile-test lib.scm $(TESTS) +EXTRA_DIST = guile-test lib.scm $(SCM_TESTS) From 284774f38dbc22a249fcd388bc0743c1c2402677 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 9 Aug 2001 17:33:45 +0000 Subject: [PATCH 1599/2047] *** empty log message *** --- test-suite/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index f01c7488f..6f5571055 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,9 @@ +2001-08-09 Marius Vollmer + + * Makefile.am (TESTS): Do not call the variable "TESTS", call it + "SCM_TESTS". This has special meaning to automake. How many + tries left to get this right, mvo? + 2001-08-08 Marius Vollmer * Makefile.am (TESTS): List tests explicitely instead of using a From 2f4a254ac93145592018c3e7015a6678d6092981 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 11 Aug 2001 16:59:42 +0000 Subject: [PATCH 1600/2047] * Added some syntax tests for numbers. --- test-suite/ChangeLog | 5 +++++ test-suite/tests/numbers.test | 19 +++++++++++++++++++ 2 files changed, 24 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 6f5571055..0d06fcbfb 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2001-08-11 Dirk Herrmann + + * tests/numbers.test: Added Some syntax tests for + string->number. + 2001-08-09 Marius Vollmer * Makefile.am (TESTS): Do not call the variable "TESTS", call it diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index f20a37d93..68f2b7477 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -850,6 +850,25 @@ ;;; string->number ;;; +(with-test-prefix "string->number" + + (pass-if "string->number" + (documented? string->number)) + + (pass-if "non number strings" + (for-each (lambda (x) (if (string->number x) (throw 'fail))) + '("" "q" "1q" "6+7iq" "8+9q" "10+11" "13+" "18@19 " "20@q" "23@" + "+25iq" "26i" "-q" "-iq" "i" "5#.0" "8/" "10#11" ".#" "." + "#o.2" "3.4q" "15.16e17q" "18.19e+q" ".a" ".17#18" "10q" "#b2" + "#b3" "#b4" "#b5" "#b6" "#b7" "#b8" "#b9" "#ba" "#bb" "#bc" + "#bd" "#be" "#bf" "#q" "#b#b1" "#o#o1" "#d#d1" "#x#x1" "#e#e1" + "#i#i1" "12@12+0i")) + #t) + + (pass-if-exception "exponent too big" + exception:out-of-range + (string->number "12.13e141414"))) + ;;; ;;; number? ;;; From 252422b02991833c1aa1e8b88f9c1a9e2059d6be Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 12 Aug 2001 18:31:10 +0000 Subject: [PATCH 1601/2047] (exception:no-such-option, exception:option-does-not-support-arg, exception:option-must-be-specified, exception:option-must-have-arg, exception:not-enough-args): New vars. ("option-ref", "required", "specified no value, given anyway", "specified arg required"): New top-level sections. --- test-suite/tests/getopt-long.test | 145 ++++++++++++++++++++++++++++-- 1 file changed, 138 insertions(+), 7 deletions(-) diff --git a/test-suite/tests/getopt-long.test b/test-suite/tests/getopt-long.test index 1d1658a09..b867835fa 100644 --- a/test-suite/tests/getopt-long.test +++ b/test-suite/tests/getopt-long.test @@ -18,19 +18,39 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +;;;; +;;;; NB: Please don't report the TTN_TEST_NEW env var refs as a bug. +;;;; They will go away on checkin of rewritten getopt-long.scm. +;;;; + (use-modules (test-suite lib) (ice-9 getopt-long) (ice-9 regex)) -(define exception:option-predicate-failed - (cons 'misc-error "^option predicate failed")) +(defmacro deferr (name-frag re) + (let ((name (symbol-append 'exception: name-frag))) + `(define ,name (cons 'misc-error ,re)))) + +(deferr no-such-option "^no such option") +(deferr option-predicate-failed "^option predicate failed") +(deferr option-does-not-support-arg "^option does not support argument") +(deferr option-must-be-specified "^option must be specified") +(deferr option-must-have-arg "^option must be specified with argument") + +(or (getenv "TTN_TEST_NEW") + (deferr not-enough-args "^not enough arg")) + +(with-test-prefix "exported procs" + (pass-if "`option-ref' defined" (defined? 'option-ref)) + (pass-if "`getopt-long' defined" (defined? 'getopt-long))) (with-test-prefix "specifying predicate" (define (test1 . args) - (getopt-long args `((test (value #t) - (predicate ,(lambda (x) - (string-match "^[0-9]+$" x))))))) + (getopt-long args + `((test (value #t) + (predicate ,(lambda (x) + (string-match "^[0-9]+$" x))))))) (pass-if "valid arg" (equal? (test1 "foo" "bar" "--test=123") @@ -41,8 +61,10 @@ (test1 "foo" "bar" "--test=foo")) (pass-if-exception "option has no arg" - exception:option-predicate-failed - (test1 "foo" "bar")) + (if (getenv "TTN_TEST_NEW") + exception:option-must-have-arg + exception:not-enough-args) + (test1 "foo" "bar" "--test")) ) @@ -90,6 +112,115 @@ (pass-if "long option `bar', long option `foo', no args" (equal? (test3 "prg" "--bar" "--foo") '((()) (foo . #t) (bar . #t)))) + + ) + +(with-test-prefix "option-ref" + + (define (test4 option-arg . args) + (equal? option-arg (option-ref (getopt-long + (cons "prog" args) + '((foo + (value optional) + (single-char #\f)) + (bar))) + 'foo #f))) + + (pass-if "option-ref `--foo 4'" + (test4 "4" "--foo" "4")) + + (pass-if "option-ref `-f 4'" + (test4 "4" "-f" "4")) + + (and (getenv "TTN_TEST_NEW") + (pass-if "option-ref `-f4'" + (test4 "4" "-f4"))) + + (pass-if "option-ref `--foo=4'" + (test4 "4" "--foo=4")) + + ) + +(with-test-prefix "required" + + (define (test5 args specs) + (getopt-long (cons "foo" args) specs)) + + (pass-if "not mentioned, not given" + (equal? (test5 '() '()) + '((())))) + + (and (getenv "TTN_TEST_NEW") + (pass-if-exception "not mentioned, given" + exception:no-such-option + (test5 '("--req") '((something))))) + + (pass-if "not specified required, not given" + (equal? (test5 '() '((req (required? #f)))) + '((())))) + + (pass-if "not specified required, given anyway" + (equal? (test5 '("--req") '((req (required? #f)))) + '((()) (req . #t)))) + + (pass-if "not specified required, but w/ value, given anyway w/ \"=\" val" + (equal? (test5 '("--req=7") '((req (required? #f) (value #t)))) + '((()) (req . "7")))) + + (pass-if "not specified required, but w/ value, given anyway w/ non-\"=\" val" + (equal? (test5 '("--req" "7") '((req (required? #f) (value #t)))) + '((()) (req . "7")))) + + (pass-if-exception "specified required, not given" + exception:option-must-be-specified + (test5 '() '((req (required? #t))))) + + ) + +(with-test-prefix "specified no-value, given anyway" + + (define (test6 args specs) + (getopt-long (cons "foo" args) specs)) + + (and (getenv "TTN_TEST_NEW") + (pass-if-exception "using \"=\" syntax" + exception:option-does-not-support-arg + (test6 '("--maybe=yes") '((maybe))))) + + ) + +(with-test-prefix "specified arg required" + + (define (test7 args) + (getopt-long (cons "foo" args) '((hmm (value #t) (single-char #\H)) + (ignore)))) + + (pass-if "short opt, arg given" + (equal? (test7 '("-H" "99")) + '((()) (hmm . "99")))) + + (pass-if "long non-\"=\" opt, arg given" + (equal? (test7 '("--hmm" "100")) + '((()) (hmm . "100")))) + + (pass-if "long \"=\" opt, arg given" + (equal? (test7 '("--hmm=101")) + '((()) (hmm . "101")))) + + (pass-if-exception "short opt, arg not given" + exception:option-must-have-arg + (test7 '("-H"))) + + (and (getenv "TTN_TEST_NEW") + (pass-if-exception "long non-\"=\" opt, arg not given (next arg an option)" + exception:option-must-have-arg + (test7 '("--hmm" "--ignore")))) + + (and (getenv "TTN_TEST_NEW") + (pass-if-exception "long \"=\" opt, arg not given" + exception:option-must-have-arg + (test7 '("--hmm")))) + ) ;;; getopt-long.test ends here From c3597bc4e08fc012d9af9808e6b08564bc06f8db Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 12 Aug 2001 18:34:11 +0000 Subject: [PATCH 1602/2047] *** empty log message *** --- test-suite/ChangeLog | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 0d06fcbfb..e0d6c6716 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,14 @@ +2001-08-12 Thien-Thi Nguyen + + * tests/getopt-long.test (exception:no-such-option, + exception:option-does-not-support-arg, + exception:option-must-be-specified, + exception:option-must-have-arg, exception:not-enough-args): + New vars. + + ("option-ref", "required", "specified no value, given anyway", + "specified arg required"): New top-level sections. + 2001-08-11 Dirk Herrmann * tests/numbers.test: Added Some syntax tests for From 3925d0c31f82e36eabf2e37b93220e891b02b011 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 12 Aug 2001 18:56:39 +0000 Subject: [PATCH 1603/2047] Rewrite. Touch up docstrings. Augment commentary. --- ice-9/getopt-long.scm | 742 ++++++++++++------------------------------ 1 file changed, 212 insertions(+), 530 deletions(-) diff --git a/ice-9/getopt-long.scm b/ice-9/getopt-long.scm index ab30658f6..40fd4c4df 100644 --- a/ice-9/getopt-long.scm +++ b/ice-9/getopt-long.scm @@ -1,6 +1,3 @@ -;;; Author: Russ McManus -;;; $Id: getopt-long.scm,v 1.5 2001-08-02 10:26:52 ttn Exp $ -;;; ;;; Copyright (C) 1998, 2001 Free Software Foundation, Inc. ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -41,19 +38,21 @@ ;;; whether to permit this exception to apply to your modifications. ;;; If you do not wish that, delete this exception notice. +;;; Author: Russ McManus (rewritten by Thien-Thi Nguyen) + ;;; Commentary: ;;; This module implements some complex command line option parsing, in -;;; the spirit of the GNU C library function 'getopt_long'. Both long +;;; the spirit of the GNU C library function `getopt_long'. Both long ;;; and short options are supported. ;;; ;;; The theory is that people should be able to constrain the set of ;;; options they want to process using a grammar, rather than some arbitrary ;;; structure. The grammar makes the option descriptions easy to read. ;;; - -;;; getopt-long is a function for parsing command-line arguments in a -;;; manner consistent with other GNU programs. +;;; `getopt-long' is a procedure for parsing command-line arguments in a +;;; manner consistent with other GNU programs. `option-ref' is a procedure +;;; that facilitates processing of the `getopt-long' return value. ;;; (getopt-long ARGS GRAMMAR) ;;; Parse the arguments ARGS according to the argument list grammar GRAMMAR. @@ -109,8 +108,8 @@ ;;; ;;; If an option's value is optional, then `getopt-long' decides ;;; whether it has a value by looking at what follows it in ARGS. If -;;; the next element is a string, and it does not appear to be an -;;; option itself, then that string is the option's value. +;;; the next element is does not appear to be an option itself, then +;;; that element is the option's value. ;;; ;;; The value of a long option can appear as the next element in ARGS, ;;; or it can follow the option name, separated by an `=' character. @@ -138,6 +137,8 @@ ;;; as a list, associated with the empty list. ;;; ;;; `getopt-long' throws an exception if: +;;; - it finds an unrecognized property in GRAMMAR +;;; - the value of the `single-char' property is not a character ;;; - it finds an unrecognized option in ARGS ;;; - a required option is omitted ;;; - an option that requires an argument doesn't get one @@ -168,515 +169,200 @@ ;;; (lockfile-dir . "/tmp") ;;; (verbose . #t)) +;;; (option-ref OPTIONS KEY DEFAULT) +;;; Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not +;;; found. The value is either a string or `#t'. +;;; +;;; For example, using the `getopt-long' return value from above: +;;; +;;; (option-ref (getopt-long ...) 'x-includes 42) => "/usr/include" +;;; (option-ref (getopt-long ...) 'not-a-key! 31) => 31 + ;;; Code: (define-module (ice-9 getopt-long) - :use-module (ice-9 common-list)) + :use-module ((ice-9 common-list) :select (some remove-if-not)) + :export (getopt-long option-ref)) - -;;; The code on this page was expanded by hand using the following code: -;;; (pretty-print -;;; (macroexpand -;;; '(define-record option-spec -;;; (name -;;; value -;;; value-required? -;;; single-char -;;; predicate-ls -;;; parse-ls)))) -;;; -;;; This avoids the need to load slib for records. -(define slib:error error) -(begin (define - option-spec->name - (lambda - (obj) - (if (option-spec? obj) - (vector-ref obj 1) - (slib:error - (quote option-spec->name) - ": bad record" - obj)))) - (define - option-spec->value - (lambda - (obj) - (if (option-spec? obj) - (vector-ref obj 2) - (slib:error - (quote option-spec->value) - ": bad record" - obj)))) - (define - option-spec->value-required? - (lambda - (obj) - (if (option-spec? obj) - (vector-ref obj 3) - (slib:error - (quote option-spec->value-required?) - ": bad record" - obj)))) - (define - option-spec->single-char - (lambda - (obj) - (if (option-spec? obj) - (vector-ref obj 4) - (slib:error - (quote option-spec->single-char) - ": bad record" - obj)))) - (define - option-spec->predicate-ls - (lambda - (obj) - (if (option-spec? obj) - (vector-ref obj 5) - (slib:error - (quote option-spec->predicate-ls) - ": bad record" - obj)))) - (define - option-spec->parse-ls - (lambda - (obj) - (if (option-spec? obj) - (vector-ref obj 6) - (slib:error - (quote option-spec->parse-ls) - ": bad record" - obj)))) - (define - set-option-spec-name! - (lambda - (obj val) - (if (option-spec? obj) - (vector-set! obj 1 val) - (slib:error - (quote set-option-spec-name!) - ": bad record" - obj)))) - (define - set-option-spec-value! - (lambda - (obj val) - (if (option-spec? obj) - (vector-set! obj 2 val) - (slib:error - (quote set-option-spec-value!) - ": bad record" - obj)))) - (define - set-option-spec-value-required?! - (lambda - (obj val) - (if (option-spec? obj) - (vector-set! obj 3 val) - (slib:error - (quote set-option-spec-value-required?!) - ": bad record" - obj)))) - (define - set-option-spec-single-char! - (lambda - (obj val) - (if (option-spec? obj) - (vector-set! obj 4 val) - (slib:error - (quote set-option-spec-single-char!) - ": bad record" - obj)))) - (define - set-option-spec-predicate-ls! - (lambda - (obj val) - (if (option-spec? obj) - (vector-set! obj 5 val) - (slib:error - (quote set-option-spec-predicate-ls!) - ": bad record" - obj)))) - (define - set-option-spec-parse-ls! - (lambda - (obj val) - (if (option-spec? obj) - (vector-set! obj 6 val) - (slib:error - (quote set-option-spec-parse-ls!) - ": bad record" - obj)))) - (define - option-spec? - (lambda - (obj) - (and (vector? obj) - (= (vector-length obj) 7) - (eq? (vector-ref obj 0) (quote option-spec))))) - (define - make-option-spec - (lambda - (option-spec->name - option-spec->value - option-spec->value-required? - option-spec->single-char - option-spec->predicate-ls - option-spec->parse-ls) - (vector - (quote option-spec) - option-spec->name - option-spec->value - option-spec->value-required? - option-spec->single-char - option-spec->predicate-ls - option-spec->parse-ls)))) +(define option-spec-fields '(name + value + required? + single-char + predicate + value-policy)) - -;;; -;;; parse functions go on this page. -;;; -(define make-user-predicate - (lambda (pred) - (lambda (spec) - (let ((val (option-spec->value spec))) - (if (and val - (pred val)) #t - (error "option predicate failed:" (option-spec->name spec))))))) +(define option-spec (make-record-type 'option-spec option-spec-fields)) +(define make-option-spec (record-constructor option-spec option-spec-fields)) -(define make-not-allowed-value-fn - (lambda () - (lambda (spec) - (let ((val (option-spec->value spec))) - (if (not (or (eq? val #t) - (eq? val #f))) - (let ((name (option-spec->name spec))) - (error "option does not support argument:" name))))))) +(define (define-one-option-spec-field-accessor field) + `(define ,(symbol-append 'option-spec-> field) ;;; name slib-compat + (record-accessor option-spec ',field))) -(define make-option-required-predicate - (lambda () - (lambda (spec) - (let ((val (option-spec->value spec))) - (if (not val) - (let ((name (option-spec->name spec))) - (error "option must be specified:" name))))))) +(define (define-one-option-spec-field-modifier field) + `(define ,(symbol-append 'set-option-spec- field '!) ;;; name slib-compat + (record-modifier option-spec ',field))) -(define make-option-value-predicate - (lambda (predicate) - (lambda (spec) - (let ((val (option-spec->value spec))) - (if (not (predicate val)) - (let ((name (option-spec->name spec))) - (error "Bad option value:" name val))))))) +(defmacro define-all-option-spec-accessors/modifiers () + `(begin + ,@(map define-one-option-spec-field-accessor option-spec-fields) + ,@(map define-one-option-spec-field-modifier option-spec-fields))) -(define make-required-value-fn - (lambda () - (lambda (spec) - (let ((val (option-spec->value spec))) - (if (eq? val #t) - (let ((name (option-spec->name spec))) - (error "option must be specified with argument:" name))))))) +(define-all-option-spec-accessors/modifiers) -(define single-char-value? - (lambda (val) - (char? val))) +(define make-option-spec + (let ((ctor (record-constructor option-spec '(name)))) + (lambda (name) + (ctor name)))) (define (parse-option-spec desc) - (letrec ((parse-iter - (lambda (spec) - (let ((parse-ls (option-spec->parse-ls spec))) - (if (null? parse-ls) - spec - (let ((ls (car parse-ls))) - (if (or (not (list? ls)) - (not (= (length ls) 2))) - (error "Bad option specification:" ls)) - (let ((key (car ls)) - (val (cadr ls))) - (cond ((and (eq? key 'required?) val) - ;; required values implemented as a predicate - (parse-iter - (make-option-spec - (option-spec->name spec) - (option-spec->value spec) - (option-spec->value-required? spec) - (option-spec->single-char spec) - (cons (make-option-required-predicate) - (option-spec->predicate-ls spec)) - (cdr parse-ls)))) - ;; if value not required, don't add predicate, - ((eq? key 'required?) - (parse-iter - (make-option-spec - (option-spec->name spec) - (option-spec->value spec) - (option-spec->value-required? spec) - (option-spec->single-char spec) - (option-spec->predicate-ls spec) - (cdr parse-ls)))) - ;; handle value specification - ((eq? key 'value) - (cond ((eq? val #t) - ;; when value is required, add a - ;; predicate to that effect and record - ;; the fact in value-required? field. - (parse-iter - (make-option-spec - (option-spec->name spec) - (option-spec->value spec) - #t - (option-spec->single-char spec) - (cons (make-required-value-fn) - (option-spec->predicate-ls spec)) - (cdr parse-ls)))) - ((eq? val #f) - ;; when the value is not allowed, add a - ;; predicate to that effect. one can - ;; detect that a value is not supplied - ;; by checking the option value against - ;; #f. - (parse-iter - (make-option-spec - (option-spec->name spec) - (option-spec->value spec) - #f - (option-spec->single-char spec) - (cons (make-not-allowed-value-fn) - (option-spec->predicate-ls spec)) - (cdr parse-ls)))) - ((eq? val 'optional) - ;; for optional values, don't add a - ;; predicate. do, however put the value - ;; 'optional in the value-required? - ;; field. this setting checks whether - ;; optional values are 'greedy'. set to - ;; #f to make optional value clauses - ;; 'non-greedy'. - (parse-iter - (make-option-spec - (option-spec->name spec) - (option-spec->value spec) - 'optional - (option-spec->single-char spec) - (option-spec->predicate-ls spec) - (cdr parse-ls)))) - (#t - ;; error case - (error "Bad value specification for option:" - (cons key val))))) - ;; specify single char defined for this option. - ((eq? key 'single-char) - (if (not (single-char-value? val)) - (error "Not a single-char-value:" - val " for option:" key) - (parse-iter - (make-option-spec - (option-spec->name spec) - (option-spec->value spec) - (option-spec->value-required? spec) - val - (option-spec->predicate-ls spec) - (cdr parse-ls))))) - ((eq? key 'predicate) - (if (procedure? val) - (parse-iter - (make-option-spec - (option-spec->name spec) - (option-spec->value spec) - (option-spec->value-required? spec) - (option-spec->single-char spec) - (cons (make-user-predicate val) - (option-spec->predicate-ls spec)) - (cdr parse-ls))) - (error "Bad predicate specified for option:" - (cons key val)))))))))))) - (if (or (not (pair? desc)) - (string? (car desc))) - (error "Bad option specification:" desc)) - (parse-iter (make-option-spec (car desc) - #f - #f - #f - '() - (cdr desc))))) + (let ((spec (make-option-spec (symbol->string (car desc))))) + (for-each (lambda (desc-elem) + (let ((given (lambda () (cadr desc-elem)))) + (case (car desc-elem) + ((required?) + (set-option-spec-required?! spec (given))) + ((value) + (set-option-spec-value-policy! spec (given))) + ((single-char) + (or (char? (given)) + (error "`single-char' value must be a char!")) + (set-option-spec-single-char! spec (given))) + ((predicate) + (set-option-spec-predicate! + spec ((lambda (pred) + (lambda (name val) + (or (not val) + (pred val) + (error "option predicate failed:" name)))) + (given)))) + (else + (error "invalid getopt-long option property:" + (car desc-elem)))))) + (cdr desc)) + spec)) - -;;; -;;; -;;; (define (split-arg-list argument-list) - "Given an ARGUMENT-LIST, decide which part to process for options. -Everything before an arg of \"--\" is fair game, everything after it -should not be processed. The \"--\" is discarded. A cons pair is -returned whose car is the list to process for options, and whose cdr -is the list to not process." - (let loop ((process-ls '()) - (not-process-ls argument-list)) - (cond ((null? not-process-ls) - (cons (reverse process-ls) '())) - ((string=? "--" (car not-process-ls)) - (cons (reverse process-ls) (cdr not-process-ls))) - (#t - (loop (cons (car not-process-ls) process-ls) - (cdr not-process-ls)))))) + ;; Scan ARGUMENT-LIST for "--" and return (BEFORE-LS . AFTER-LS). + ;; Discard the "--". If no "--" is found, AFTER-LS is empty. + (let loop ((yes '()) (no argument-list)) + (cond ((null? no) (cons (reverse yes) no)) + ((string=? "--" (car no)) (cons (reverse yes) (cdr no))) + (else (loop (cons (car no) yes) (cdr no)))))) -(define short-opt-rx (make-regexp "^-([a-zA-Z]+)")) -(define long-opt-no-value-rx (make-regexp "^--([^=]+)$")) +(define short-opt-rx (make-regexp "^-([a-zA-Z]+)(.*)")) +(define long-opt-no-value-rx (make-regexp "^--([^=]+)$")) (define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)")) -(define (single-char-expander specifications opt-ls) - "Expand single letter options that are mushed together." - (let ((response #f)) - (define (is-short-opt? str) - (set! response (regexp-exec short-opt-rx str)) - response) - (define (iter opt-ls ret-ls) - (cond ((null? opt-ls) - (reverse ret-ls)) - ((is-short-opt? (car opt-ls)) - (let* ((orig-str (car opt-ls)) - (match-pair (vector-ref response 2)) - (match-str (substring orig-str (car match-pair) - (cdr match-pair)))) - (if (= (string-length match-str) 1) - (iter (cdr opt-ls) - (cons (string-append "-" match-str) ret-ls)) - (iter (cons (string-append "-" (substring match-str 1)) - (cdr opt-ls)) - (cons (string-append "-" (substring match-str 0 1)) - ret-ls))))) - (#t (iter (cdr opt-ls) - (cons (car opt-ls) ret-ls))))) - (iter opt-ls '()))) +(define (match-substring match which) + ;; condensed from (ice-9 regex) `match:{substring,start,end}' + (let ((sel (vector-ref match (1+ which)))) + (substring (vector-ref match 0) (car sel) (cdr sel)))) -(define (process-short-option specifications argument-ls alist) - "Process a single short option that appears at the front of the ARGUMENT-LS, -according to SPECIFICATIONS. Returns #f is there is no such argument. -Otherwise returns a pair whose car is the list of remaining arguments, and -whose cdr is a new association list, constructed by adding a pair to the -supplied ALIST. The pair on the front of the returned association list -describes the option found at the head of ARGUMENT-LS. The way this routine -currently works, an option that never takes a value that is followed by a non -option will cause an error, which is probably a bug. To fix the bug the -option specification needs to record whether the option ever can take a -value." - (define (short-option->char option) - (string-ref option 1)) - (define (is-short-option? option) - (regexp-exec short-opt-rx option)) - (define (is-long-option? option) - (or (regexp-exec long-opt-with-value-rx option) - (regexp-exec long-opt-no-value-rx option))) - (define (find-matching-spec option) - (let ((key (short-option->char option))) - (find-if (lambda (spec) - (eq? key (option-spec->single-char spec))) specifications))) - (let ((option (car argument-ls))) - (if (is-short-option? option) - (let ((spec (find-matching-spec option))) - (if spec - (let* ((next-value (if (null? (cdr argument-ls)) - #f - (cadr argument-ls))) - (option-value (if (and next-value - (not (is-short-option? next-value)) - (not (is-long-option? next-value)) - (option-spec->value-required? spec)) - next-value - #t)) - (new-alist (cons (cons (option-spec->name spec) - option-value) - alist))) - (cons (if (eq? option-value #t) - (cdr argument-ls) ; one value, skip just one - (cddr argument-ls)) ; must be a value, skip two - new-alist)) - (error "No such option:" option))) - #f))) +(define (expand-clumped-singles opt-ls) + ;; example: ("--xyz" "-abc5d") => ("--xyz" "-a" "-b" "-c" "5d") + (let loop ((opt-ls opt-ls) (ret-ls '())) + (cond ((null? opt-ls) + (reverse ret-ls)) ;;; retval + ((regexp-exec short-opt-rx (car opt-ls)) + => (lambda (match) + (let ((singles (reverse + (map (lambda (c) + (string-append "-" (make-string 1 c))) + (string->list + (match-substring match 1))))) + (extra (match-substring match 2))) + (loop (cdr opt-ls) + (append (if (string=? "" extra) + singles + (cons extra singles)) + ret-ls))))) + (else (loop (cdr opt-ls) + (cons (car opt-ls) ret-ls)))))) -(define (process-long-option specifications argument-ls alist) - (define (find-matching-spec key) - (find-if (lambda (spec) - (eq? key (option-spec->name spec))) - specifications)) - (define (split-long-option option) - ;; returns a pair whose car is a symbol naming the option, cdr is - ;; the option value. as a special case, if the option value is - ;; #f, then the caller should use the next item in argument-ls as - ;; the option value. - (let ((resp (regexp-exec long-opt-no-value-rx option))) - (if resp - ;; Aha, we've found a long option without an equal sign. - ;; Maybe we need to grab a value from argument-ls. To find - ;; out we need to refer to the option-spec. - (let* ((key-pair (vector-ref resp 2)) - (key (string->symbol - (substring option (car key-pair) (cdr key-pair)))) - (spec (find-matching-spec key))) - (let* ((req (option-spec->value-required? spec)) - (retval (cons key (if req #f #t)))) - ;; this is a fucking kludge, i hate it. it's necessary because - ;; the protocol (return #f to indicate next element is an option - ;; arg) is insufficient. needs redesign. why am i checking in - ;; such ugliness? read moby dick! -ttn - (and (eq? 'optional req) - (set-object-property! retval 'optional #t)) - retval)) - (let ((resp (regexp-exec long-opt-with-value-rx option))) - ;; Aha, we've found a long option with an equal sign. The - ;; option value is simply the value to the right of the - ;; equal sign. - (if resp - (let* ((key-pair (vector-ref resp 2)) - (key (string->symbol - (substring option - (car key-pair) (cdr key-pair)))) - (value-pair (vector-ref resp 3)) - (value (substring option - (car value-pair) (cdr value-pair)))) - (cons key value)) - #f))))) - (let* ((option (car argument-ls)) - (pair (split-long-option option))) - (cond ((and pair (eq? (cdr pair) #f)) - (cond ((and (null? (cdr argument-ls)) - (not (object-property pair 'optional))) - (error "Not enough options.")) - ((null? (cdr argument-ls)) - (cons '() (cons (cons (car pair) #t) alist))) - ((let* ((next (cadr argument-ls)) - (m (or (regexp-exec short-opt-rx next) - (regexp-exec long-opt-with-value-rx next) - (regexp-exec long-opt-no-value-rx next)))) - (and m (object-property pair 'optional))) - (cons (cdr argument-ls) - (cons (cons (car pair) #t) alist))) - (else - (cons (cddr argument-ls) - (cons (cons (car pair) (cadr argument-ls)) alist))))) - (pair - (cons (cdr argument-ls) (cons pair alist))) - (else #f)))) +(define (looks-like-an-option string) + (some (lambda (rx) + (regexp-exec rx string)) + `(,short-opt-rx + ,long-opt-with-value-rx + ,long-opt-no-value-rx))) -(define (process-options specifications argument-ls) - (define (iter argument-ls alist rest-ls) - (if (null? argument-ls) - (cons alist (reverse rest-ls)) - (let ((pair (process-short-option specifications argument-ls alist))) - (if pair - (let ((argument-ls (car pair)) - (alist (cdr pair))) - (iter argument-ls alist rest-ls)) - (let ((pair (process-long-option - specifications argument-ls alist))) - (if pair - (let ((argument-ls (car pair)) - (alist (cdr pair))) - (iter argument-ls alist rest-ls)) - (iter (cdr argument-ls) - alist - (cons (car argument-ls) rest-ls)))))))) - (iter argument-ls '() '())) +(define (process-options specs argument-ls) + ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC). + ;; FOUND is an unordered list of option specs for found options, while ETC + ;; is an order-maintained list of elements in ARGUMENT-LS that are neither + ;; options nor their values. + (let ((idx (map (lambda (spec) + (cons (option-spec->name spec) spec)) + specs)) + (sc-idx (map (lambda (spec) + (cons (make-string 1 (option-spec->single-char spec)) + spec)) + (remove-if-not option-spec->single-char specs)))) + (let loop ((argument-ls argument-ls) (found '()) (etc '())) + (let ((eat! (lambda (spec ls) + (let ((val!loop (lambda (val n-ls n-found n-etc) + (set-option-spec-value! spec val) + (loop n-ls n-found n-etc))) + (ERR:no-arg (lambda () + (error (string-append + "option must be specified" + " with argument:") + (option-spec->name spec))))) + (cond + ((eq? 'optional (option-spec->value-policy spec)) + (if (or (null? (cdr ls)) + (looks-like-an-option (cadr ls))) + (val!loop #t + (cdr ls) + (cons spec found) + etc) + (val!loop (cadr ls) + (cddr ls) + (cons spec found) + etc))) + ((eq? #t (option-spec->value-policy spec)) + (if (or (null? (cdr ls)) + (looks-like-an-option (cadr ls))) + (ERR:no-arg) + (val!loop (cadr ls) + (cddr ls) + (cons spec found) + etc))) + (else + (val!loop #t + (cdr ls) + (cons spec found) + etc))))))) + (if (null? argument-ls) + (cons found (reverse etc)) ;;; retval + (cond ((regexp-exec short-opt-rx (car argument-ls)) + => (lambda (match) + (let* ((c (match-substring match 1)) + (spec (or (assoc-ref sc-idx c) + (error "no such option:" c)))) + (eat! spec argument-ls)))) + ((regexp-exec long-opt-no-value-rx (car argument-ls)) + => (lambda (match) + (let* ((opt (match-substring match 1)) + (spec (or (assoc-ref idx opt) + (error "no such option:" opt)))) + (eat! spec argument-ls)))) + ((regexp-exec long-opt-with-value-rx (car argument-ls)) + => (lambda (match) + (let* ((opt (match-substring match 1)) + (spec (or (assoc-ref idx opt) + (error "no such option:" opt)))) + (if (option-spec->value-policy spec) + (eat! spec (append + (list 'ignored + (match-substring match 2)) + (cdr argument-ls))) + (error "option does not support argument:" + opt))))) + (else + (loop (cdr argument-ls) + found + (cons (car argument-ls) etc))))))))) (define (getopt-long program-arguments option-desc-list) "Process options, handling both long and short options, similar to @@ -708,41 +394,37 @@ or option values. By default, options are not required, and option values are not required. By default, single character equivalents are not supported; if you want to allow the user to use single character options, you need -to add a 'single-char' clause to the option description." +to add a `single-char' clause to the option description." (let* ((specifications (map parse-option-spec option-desc-list)) (pair (split-arg-list (cdr program-arguments))) - (split-ls (single-char-expander specifications (car pair))) - (non-split-ls (cdr pair))) - (let* ((opt-pair (process-options specifications split-ls)) - (alist (car opt-pair)) - (rest-ls (append (cdr opt-pair) non-split-ls))) - ;; loop through returned alist, set values into specifications - (for-each (lambda (pair) - (let* ((key (car pair)) - (val (cdr pair)) - (spec (find-if (lambda (spec) - (eq? key (option-spec->name spec))) - specifications))) - (if spec (set-option-spec-value! spec val)))) - alist) - ;; now fire all the predicates - (for-each (lambda (spec) - (let ((predicate-ls (option-spec->predicate-ls spec))) - (for-each (lambda (predicate) - (predicate spec)) - predicate-ls))) - specifications) - (cons (cons '() rest-ls) alist)))) + (split-ls (expand-clumped-singles (car pair))) + (non-split-ls (cdr pair)) + (found/etc (process-options specifications split-ls)) + (found (car found/etc)) + (rest-ls (append (cdr found/etc) non-split-ls))) + (for-each (lambda (spec) + (let ((name (option-spec->name spec)) + (val (option-spec->value spec))) + (and (option-spec->required? spec) + (or (memq spec found) + (error "option must be specified:" name))) + (and (memq spec found) + (eq? #t (option-spec->value-policy spec)) + (or val + (error "option must be specified with argument:" + name))) + (let ((pred (option-spec->predicate spec))) + (and pred (pred name val))))) + specifications) + (cons (cons '() rest-ls) + (map (lambda (spec) + (cons (string->symbol (option-spec->name spec)) + (option-spec->value spec))) + found)))) (define (option-ref options key default) - "Look for an option value in OPTIONS using KEY. If no such value is -found, return DEFAULT." - (let ((pair (assq key options))) - (if pair - (cdr pair) - default))) - -(export option-ref) -(export getopt-long) + "Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found. +The value is either a string or `#t'." + (or (assq-ref options key) default)) ;;; getopt-long.scm ends here From 4030287ec095d3c21804f0ebfc92fceff3399148 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 12 Aug 2001 18:59:16 +0000 Subject: [PATCH 1604/2047] *** empty log message *** --- ice-9/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 62ba0a291..3bbf33074 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,9 @@ +2001-08-12 Thien-Thi Nguyen + + * getopt-long.scm: Rewrite. + Touch up docstrings. + Augment commentary. + 2001-08-02 Neil Jerram * debugger.scm (run-last-command): Return current state if From c0c07ee9420de34151cd950d00f8fbf432de0aa5 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 12 Aug 2001 19:03:34 +0000 Subject: [PATCH 1605/2047] Remove dependency on `TTN_TEST_NEW' env var. --- test-suite/tests/getopt-long.test | 47 +++++++++++-------------------- 1 file changed, 16 insertions(+), 31 deletions(-) diff --git a/test-suite/tests/getopt-long.test b/test-suite/tests/getopt-long.test index b867835fa..f40fa5fb1 100644 --- a/test-suite/tests/getopt-long.test +++ b/test-suite/tests/getopt-long.test @@ -1,4 +1,4 @@ -;;;; getopt-long.test --- optional long arg processing -*- scheme -*- +;;;; getopt-long.test --- long options processing -*- scheme -*- ;;;; Thien-Thi Nguyen --- August 2001 ;;;; ;;;; Copyright (C) 2001 Free Software Foundation, Inc. @@ -18,11 +18,6 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA -;;;; -;;;; NB: Please don't report the TTN_TEST_NEW env var refs as a bug. -;;;; They will go away on checkin of rewritten getopt-long.scm. -;;;; - (use-modules (test-suite lib) (ice-9 getopt-long) (ice-9 regex)) @@ -37,9 +32,6 @@ (deferr option-must-be-specified "^option must be specified") (deferr option-must-have-arg "^option must be specified with argument") -(or (getenv "TTN_TEST_NEW") - (deferr not-enough-args "^not enough arg")) - (with-test-prefix "exported procs" (pass-if "`option-ref' defined" (defined? 'option-ref)) (pass-if "`getopt-long' defined" (defined? 'getopt-long))) @@ -61,9 +53,7 @@ (test1 "foo" "bar" "--test=foo")) (pass-if-exception "option has no arg" - (if (getenv "TTN_TEST_NEW") - exception:option-must-have-arg - exception:not-enough-args) + exception:option-must-have-arg (test1 "foo" "bar" "--test")) ) @@ -132,9 +122,8 @@ (pass-if "option-ref `-f 4'" (test4 "4" "-f" "4")) - (and (getenv "TTN_TEST_NEW") - (pass-if "option-ref `-f4'" - (test4 "4" "-f4"))) + (pass-if "option-ref `-f4'" + (test4 "4" "-f4")) (pass-if "option-ref `--foo=4'" (test4 "4" "--foo=4")) @@ -150,10 +139,9 @@ (equal? (test5 '() '()) '((())))) - (and (getenv "TTN_TEST_NEW") - (pass-if-exception "not mentioned, given" - exception:no-such-option - (test5 '("--req") '((something))))) + (pass-if-exception "not mentioned, given" + exception:no-such-option + (test5 '("--req") '((something)))) (pass-if "not specified required, not given" (equal? (test5 '() '((req (required? #f)))) @@ -182,10 +170,9 @@ (define (test6 args specs) (getopt-long (cons "foo" args) specs)) - (and (getenv "TTN_TEST_NEW") - (pass-if-exception "using \"=\" syntax" - exception:option-does-not-support-arg - (test6 '("--maybe=yes") '((maybe))))) + (pass-if-exception "using \"=\" syntax" + exception:option-does-not-support-arg + (test6 '("--maybe=yes") '((maybe)))) ) @@ -211,15 +198,13 @@ exception:option-must-have-arg (test7 '("-H"))) - (and (getenv "TTN_TEST_NEW") - (pass-if-exception "long non-\"=\" opt, arg not given (next arg an option)" - exception:option-must-have-arg - (test7 '("--hmm" "--ignore")))) + (pass-if-exception "long non-\"=\" opt, arg not given (next arg an option)" + exception:option-must-have-arg + (test7 '("--hmm" "--ignore"))) - (and (getenv "TTN_TEST_NEW") - (pass-if-exception "long \"=\" opt, arg not given" - exception:option-must-have-arg - (test7 '("--hmm")))) + (pass-if-exception "long \"=\" opt, arg not given" + exception:option-must-have-arg + (test7 '("--hmm"))) ) From a583bf1ec681e8a869c8c8f2f1cb6025eb18a1e6 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 12 Aug 2001 19:19:41 +0000 Subject: [PATCH 1606/2047] Expand ice-9/getopt-long.scm bugfix news. --- NEWS | 32 ++++++++++++++++++++++++++++---- 1 file changed, 28 insertions(+), 4 deletions(-) diff --git a/NEWS b/NEWS index bba3769b5..5390f8c41 100644 --- a/NEWS +++ b/NEWS @@ -689,13 +689,37 @@ Use module system operations for all variables. That is, a call to `throw', `error', etc is now guaranteed to not return. -** Bugfix for (ice-9 getopt-long) +** Bugfixes for (ice-9 getopt-long) -Parsing for options that are specified to have `optional' args now checks if -the next element is an option instead of unconditionally taking it as the +This module is now tested using test-suite/tests/getopt-long.test. +The following bugs have been fixed: + +*** Parsing for options that are specified to have `optional' args now checks +if the next element is an option instead of unconditionally taking it as the option arg. -Also, this module is now tested using test-suite/tests/getopt-long.test. +*** An error is now thrown for `--opt=val' when the option description +does not specify `(value #t)' or `(value optional)'. This condition used to +be accepted w/o error, contrary to the documentation. + +*** The error message for unrecognized options is now more informative. +It used to be "not a record", an artifact of the implementation. + +*** The error message for `--opt' terminating the arg list (no value), when +`(value #t)' is specified, is now more informative. It used to be "not enough +args". + +*** "Clumped" single-char args now preserve trailing string, use it as arg. +The expansion used to be like so: + + ("-abc5d" "--xyz") => ("-a" "-b" "-c" "--xyz") + +Note that the "5d" is dropped. Now it is like so: + + ("-abc5d" "--xyz") => ("-a" "-b" "-c" "5d" "--xyz") + +This enables single-char options to have adjoining arguments as long as their +constituent characters are not potential single-char options. * Changes to the C interface From 85e6a2f842715daec99f2b7f4251211373b6c99b Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 16 Aug 2001 03:41:49 +0000 Subject: [PATCH 1607/2047] * GUILE-VERSION (GUILE_MINOR_VERSION): bump for new unstable. (GUILE_MICRO_VERSION): reset for new unstable. (LIBGUILE_INTERFACE_CURRENT): use libtool versioning scheme. (LIBGUILE_INTERFACE_REVISION): use libtool versioning scheme. (LIBGUILE_INTERFACE_AGE): use libtool versioning scheme. (LIBGUILE_INTERFACE): use libtool versioning scheme. (LIBGUILEQTHREADS_INTERFACE_CURRENT): use libtool versioning scheme. (LIBGUILEQTHREADS_INTERFACE_REVISION): use libtool versioning scheme. (LIBGUILEQTHREADS_INTERFACE_AGE): use libtool versioning scheme. (LIBGUILEQTHREADS_INTERFACE): use libtool versioning scheme. --- GUILE-VERSION | 23 ++++++++++++++--------- 1 file changed, 14 insertions(+), 9 deletions(-) diff --git a/GUILE-VERSION b/GUILE-VERSION index 55f99d9f6..5aa7e6c66 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -1,5 +1,7 @@ +# -*-shell-script-*- + GUILE_MAJOR_VERSION=1 -GUILE_MINOR_VERSION=5 +GUILE_MINOR_VERSION=7 GUILE_MICRO_VERSION=0 GUILE_VERSION=${GUILE_MAJOR_VERSION} @@ -10,14 +12,17 @@ GUILE_VERSION=${GUILE_VERSION}.${GUILE_MICRO_VERSION} VERSION=${GUILE_VERSION} PACKAGE=guile +# See libtool info pages for more information on how and when to +# change these. + # libguile.so versioning info -LIBGUILE_MAJOR_VERSION=10 -LIBGUILE_MINOR_VERSION=0 -LIBGUILE_REVISION_VERSION=0 -LIBGUILE_VERSION=${LIBGUILE_MAJOR_VERSION}.${LIBGUILE_MINOR_VERSION}.${LIBGUILE_REVISION_VERSION} +LIBGUILE_INTERFACE_CURRENT=10 +LIBGUILE_INTERFACE_REVISION=0 +LIBGUILE_INTERFACE_AGE=0 +LIBGUILE_INTERFACE="${LIBGUILE_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_INTERFACE_AGE}" # libguileqthreads.so versioning info -LIBGUILEQTHREADS_MAJOR_VERSION=10 -LIBGUILEQTHREADS_MINOR_VERSION=0 -LIBGUILEQTHREADS_REVISION_VERSION=0 -LIBGUILEQTHREADS_VERSION=${LIBGUILEQTHREADS_MAJOR_VERSION}.${LIBGUILEQTHREADS_MINOR_VERSION}.${LIBGUILEQTHREADS_REVISION_VERSION} +LIBGUILEQTHREADS_INTERFACE_CURRENT=1 +LIBGUILEQTHREADS_INTERFACE_REVISION=0 +LIBGUILEQTHREADS_INTERFACE_AGE=0 +LIBGUILEQTHREADS_INTERFACE="${LIBGUILEQTHREADS_INTERFACE_CURRENT}:${LIBGUILEQTHREADS_INTERFACE_REVISION}:${LIBGUILEQTHREADS_INTERFACE_AGE}" From 9e202853dd61d3eb239464d4d5c5c7132db99382 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 16 Aug 2001 03:43:50 +0000 Subject: [PATCH 1608/2047] * configure.in (LIBGUILE_INTERFACE_CURRENT): use libtool versioning scheme. (LIBGUILE_INTERFACE_REVISION): use libtool versioning scheme. (LIBGUILE_INTERFACE_AGE): use libtool versioning scheme. (LIBGUILE_INTERFACE): use libtool versioning scheme. (LIBGUILEQTHREADS_INTERFACE_CURRENT): use libtool versioning scheme. (LIBGUILEQTHREADS_INTERFACE_REVISION): use libtool versioning scheme. (LIBGUILEQTHREADS_INTERFACE_AGE): use libtool versioning scheme. (LIBGUILEQTHREADS_INTERFACE): use libtool versioning scheme. --- configure.in | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/configure.in b/configure.in index 6bb4ef87c..5f7140345 100644 --- a/configure.in +++ b/configure.in @@ -568,10 +568,10 @@ if test "${THREAD_PACKAGE}" != "" ; then AC_CHECK_LIB(pthread, main) fi fi -AC_SUBST(LIBGUILEQTHREADS_MAJOR_VERSION) -AC_SUBST(LIBGUILEQTHREADS_MINOR_VERSION) -AC_SUBST(LIBGUILEQTHREADS_REVISION_VERSION) -AC_SUBST(LIBGUILEQTHREADS_VERSION) +AC_SUBST(LIBGUILEQTHREADS_INTERFACE_CURRENT) +AC_SUBST(LIBGUILEQTHREADS_INTERFACE_REVISION) +AC_SUBST(LIBGUILEQTHREADS_INTERFACE_AGE) +AC_SUBST(LIBGUILEQTHREADS_INTERFACE) ## If we're using GCC, ask for aggressive warnings. case "$GCC" in @@ -599,10 +599,11 @@ AC_SUBST(GUILE_MAJOR_VERSION) AC_SUBST(GUILE_MINOR_VERSION) AC_SUBST(GUILE_MICRO_VERSION) AC_SUBST(GUILE_VERSION) -AC_SUBST(LIBGUILE_MAJOR_VERSION) -AC_SUBST(LIBGUILE_MINOR_VERSION) -AC_SUBST(LIBGUILE_REVISION_VERSION) -AC_SUBST(LIBGUILE_VERSION) + +AC_SUBST(LIBGUILE_INTERFACE_CURRENT) +AC_SUBST(LIBGUILE_INTERFACE_REVISION) +AC_SUBST(LIBGUILE_INTERFACE_AGE) +AC_SUBST(LIBGUILE_INTERFACE) dnl Tell guile-config what flags guile users should link against. GUILE_LIBS="$LDFLAGS $THREAD_LIBS_INSTALLED $LIBS" From 9e86801e2fb35981081c14a1fdea08c063904446 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 16 Aug 2001 03:44:19 +0000 Subject: [PATCH 1609/2047] * Makefile.am (libguile_la_LDFLAGS): use libtool interface version variables. (libpath.h): change libguileversion to libguileinterface. --- libguile/Makefile.am | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index a97db45db..8eaa24fc5 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -116,7 +116,7 @@ noinst_HEADERS = coop-threads.c coop-threads.h coop.c num2integral.i.c libguile_la_DEPENDENCIES = @LIBLOBJS@ libguile_la_LIBADD = @LIBLOBJS@ $(LIBLTDL) -libguile_la_LDFLAGS = -version-info @LIBGUILE_MAJOR_VERSION@:@LIBGUILE_MINOR_VERSION@:@LIBGUILE_REVISION_VERSION@ -export-dynamic +libguile_la_LDFLAGS = -version-info @LIBGUILE_INTERFACE_CURRENT@:@LIBGUILE_INTERFACE_REVISION@:@LIBGUILE_INTERFACE_AGE@ -export-dynamic # These are headers visible as pkginclude_HEADERS = gh.h @@ -181,7 +181,7 @@ libpath.h: $(srcdir)/Makefile.in $(top_builddir)/config.status @echo ' { "pkgincludedir", "$(includedir)/@PACKAGE@" }, \' \ >> libpath.tmp @echo ' { "guileversion", "@GUILE_VERSION@" }, \' >> libpath.tmp - @echo ' { "libguileversion", "@LIBGUILE_VERSION@" }, \' >> libpath.tmp + @echo ' { "libguileinterface", "@LIBGUILE_INTERFACE@" }, \' >> libpath.tmp @echo ' { "LIBS", "@GUILE_LIBS@" }, \' >> libpath.tmp @echo '}' >> libpath.tmp @mv libpath.tmp libpath.h From ab4cd34b26e3605127b3e52b12ce5770eba39268 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 16 Aug 2001 03:44:29 +0000 Subject: [PATCH 1610/2047] *** empty log message *** --- ChangeLog | 23 +++++++ HACKING | 146 ++++++++++++++++++++++++++++++++++++++++++++- README | 4 +- RELEASE | 114 ++++++++++++++++++++++++++--------- libguile/ChangeLog | 6 ++ qt/ChangeLog | 5 ++ 6 files changed, 267 insertions(+), 31 deletions(-) diff --git a/ChangeLog b/ChangeLog index 2f5f0ce81..36c92fbe7 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,26 @@ +2001-08-15 Rob Browning + + * configure.in + (LIBGUILE_INTERFACE_CURRENT): use libtool versioning scheme. + (LIBGUILE_INTERFACE_REVISION): use libtool versioning scheme. + (LIBGUILE_INTERFACE_AGE): use libtool versioning scheme. + (LIBGUILE_INTERFACE): use libtool versioning scheme. + (LIBGUILEQTHREADS_INTERFACE_CURRENT): use libtool versioning scheme. + (LIBGUILEQTHREADS_INTERFACE_REVISION): use libtool versioning scheme. + (LIBGUILEQTHREADS_INTERFACE_AGE): use libtool versioning scheme. + (LIBGUILEQTHREADS_INTERFACE): use libtool versioning scheme. + + * GUILE-VERSION (GUILE_MINOR_VERSION): bump for new unstable. + (GUILE_MICRO_VERSION): reset for new unstable. + (LIBGUILE_INTERFACE_CURRENT): use libtool versioning scheme. + (LIBGUILE_INTERFACE_REVISION): use libtool versioning scheme. + (LIBGUILE_INTERFACE_AGE): use libtool versioning scheme. + (LIBGUILE_INTERFACE): use libtool versioning scheme. + (LIBGUILEQTHREADS_INTERFACE_CURRENT): use libtool versioning scheme. + (LIBGUILEQTHREADS_INTERFACE_REVISION): use libtool versioning scheme. + (LIBGUILEQTHREADS_INTERFACE_AGE): use libtool versioning scheme. + (LIBGUILEQTHREADS_INTERFACE): use libtool versioning scheme. + 2001-08-07 Marius Vollmer * Makefile.am (EXTRA_DIST, SUBDIRS): Move test-suite from diff --git a/HACKING b/HACKING index 12ed66312..431c1ea55 100644 --- a/HACKING +++ b/HACKING @@ -1,3 +1,4 @@ +-*-text-*- Guile Hacking Guide Copyright (c) 1996, 1997, 1998, 1999, 2000, 2001 Free software Foundation, Inc. @@ -42,7 +43,7 @@ Autoconf 2.50 --- a system for automatically generating `configure' program would like to use. Available in "ftp://ftp.gnu.org/pub/gnu/autoconf" -Automake 1.4-p2 --- a system for automatically generating Makefiles that +Automake 1.4-p4 --- a system for automatically generating Makefiles that conform to the (rather Byzantine) GNU coding standards. The nice thing is that it takes care of hairy targets like 'make dist' and 'make distclean', and automatically generates @@ -112,9 +113,147 @@ The Guile sources live in several modules: - guile-rgx-ctax --- the Guile/Rx interface, and the ctax implementation - guile-scsh --- the port of SCSH to guile, talk to Gary Houston - guile-www --- A Guile module for making HTTP requests. + - guile-statprof --- an experimental statistical profiler. There is a mailing list for CVS commit messages; see README for details. +- The guile-core tree is now versioned similarly to the Linux kernel. +Guile now always uses three numbers to represent the version, +i.e. "1.6.5". The first number, 1, is the major version number, the +second number, 6, is the minor version number, and the third number, +5, is the micro version number. Changes in major version number +indicate major changes in Guile. + +Minor version numbers that are even denote stable releases, and odd +minor version numbers denote development versions (which may be +unstable). The micro version number indicates a minor sub-revision of +a given MAJOR.MINOR release. + +- A default CVS checkout will get the current unstable development +tree. However, for each stable release, a CVS branch is created so +that release (and ongoing maintenance) of the stable version can +proceed independent of the development of the next unstable version. +To check out a particular stable branch, you just need to specify "-r +branch_release-X-Y" to your CVS checkout command (or to any update). +For example, if you wanted to check out the 1.6 stable branch, you +would specify "-r branch_release-1-6". + +So, for example, during a normal development cycle, work will proceed +on an unstable version, say 1.5.X, until it is decided that it's time +for a stable release. At that point, a branch named +branch_release-1-6 will be created, and the version numbers on the +HEAD of the CVS tree (the trunk, i.e. what you get by default), will +be changed to reflect the new unstable version 1.7.X. Then unstable +development will proceed on the unstable version, while the stable +1.5.X branch is fixed up for the eventual 1.6.0 release. + +Anytime you want to yank an existing checked out tree to the stable +branch, you can run a command like this: + + cvs -z3 update -r branch_release-1-6 -Pd + +This will yank the working directory over on to the stable release +branch. Note that this directory will track that branch from then on +unless you do something to yank it back to the main (unstable) trunk. + +To go back to the unstable branch, you can use + + cvs -z3 update -A -Pd + +Note that in either case, you should probably make sure you've +commited or removed all local changes before running the commands or +you're likely to have some unexpected results. + +Finally note that one approach, should you need to work on both +branches, is to keep two trees checked out, one stable, the other +unstable and you can work in whichever is appropriate. + +To save some initial bandwidth, you can check out either the stable +tree or the unstable tree, and then do something like this: + + cp -a core-unstable core-1.5 + cd core-1.5 + cvs -z3 update -r branch_release-1-6 -Pd + +- The stable and unstable CVS trees are distinct, and no changes will +automatically propagate between them. If you make changes that need +to show up both places, you'll need to apply the changes both places. +You *might* be able to do this with a cvs command, but often you'll +probably need to apply the changes by hand or risk migrating +superfluous modifications between the two versions. This is +particularly important when moving a change from the unstable branch +to the stable branch. + +- In general, please don't be adventurous with the stable branch. We +mostly want bugfixes, documentation improvements, build improvements, +etc., though exceptions will doubtless exist. + +- There are a few CVS tagging conventions which follow the Scheme +convention that dashes are used to separate words within a single +symbol, and so dashes bind more tightly than underscores. This means +that foo-bar_baz-bax indicates that foo-bar is somehow separate from +baz-bax. The conventions are as follows: + + Branch root tags: + ----------------- + anytime just before you create a branch it's a good + idea to create a normal tag so that you can refer to the branch point + on the main trunk as well as on the branch. So please use a tag of + the form + + branch-root-release-1-X + + or more generally, for other non-release branches: + + branch-root_FOO + + Branch tags: + ------------ + for the branch tag itself please use + + branch_release-1-6 + + or more generally, for other non-release branches: + + branch_FOO + + Merge tags: + ----------- + Whenever you're merging a branch back into the trunk (or into another + branch repeatedly) you need to tag the branch each time you merge. If + you don't do that, you won't be able to merge repeatedly without + possibly tedious conflicts. For those tags, we suggest: + + branch-merge_SOME-FOO_to_SOME-BAR_1 + branch-merge_SOME-FOO_to_SOME-BAR_2 + .. + + As an example, SOME-BAR might be trunk, or even perhaps another branch + like branch-mvo-super-fixes :> + + More mundanely, you might have + + branch-merge_release-1-6_to_trunk_1 + + (Merging the stable branch to the trunk like this + will probably be much more common, when it happens, than the + reverse for the reasons mentioned above. + + Release tags: + ------------- + When releasing a new version of guile, please use: + + release_X-Y-Z + + i.e. + + release_1-6-0 + +- If you hack on a stable branch, please apply any relevant patches or +fixes to the current unstable version (the main CVS trunk) as well. +Similarly, please back-port any important fixes to the unstable CVS +tree to the current stable branch. + - We check Makefile.am and configure.in files into CVS, but the "autogen.sh" script must be run from the top-level to generate the actual "configure" script that then must be run to create the various @@ -167,6 +306,9 @@ GCC switches, which are the default in the current configure script: -O2 -Wall -Wpointer-arith -Wmissing-prototypes +To make sure of this, you can use the --enable-error-on-warning option +to configure. This option will make GCC fail if it hits a warning. + Note that the warnings generated vary from one version of GCC to the next, and from one architecture to the next (apparently). To provide a concrete common standard, Guile should compile without warnings from @@ -234,7 +376,7 @@ Sat Aug 3 01:27:14 1996 Gary Houston * * fports.c (scm_open_file): don't return #f, throw error. When you've written a NEWS entry and updated the documentation, go -ahead and remove the asterisk. I will use the asterisks to find and +ahead and remove the asterisk. The asterisks are used to find and document changes that haven't been dealt with before a release. - Please write log entries for functions written in C under the diff --git a/README b/README index 68313686f..47f0db224 100644 --- a/README +++ b/README @@ -3,7 +3,7 @@ anonymous CVS or as a nightly snapshot at some random time after the Guile 1.4 release. If this were a Guile release, you would not see this message. !!! [fixme: zonk on release] -This is a 1.5 development version of Guile, Project GNU's extension +This is a 1.7 development version of Guile, Project GNU's extension language library. Guile is an interpreter for Scheme, packaged as a library that you can link into your applications to give them their own scripting language. Guile will eventually support other languages @@ -14,7 +14,7 @@ Guile versions with an odd middle number, i.e. 1.5.* are unstable development versions. Even middle numbers indicate stable versions. This has been the case since the 1.3.* series. -The next stable release will be version 1.6.0. +The next stable release will be version 1.8.0. Please send bug reports to bug-guile@gnu.org. diff --git a/RELEASE b/RELEASE index cbd264cf8..76ab6f9c3 100644 --- a/RELEASE +++ b/RELEASE @@ -1,3 +1,4 @@ +-*-text-*- This is a checklist for making Guile releases. It's specific to the FSF's development environment; please don't put it in the distribution. @@ -43,7 +44,9 @@ Perry Metzger Release Checklists =================================================== -There are basically two phases to doing a release: +There are basically three phases to doing a release: + +* "BRANCHING": Creating a stable development branch in CVS. * "SPIFFING": Updating NEWS, README, INSTALL. Running tests. Getting people to try builds on various machines. Getting everything @@ -53,18 +56,37 @@ There are basically two phases to doing a release: the FSF to put the disty on ftp.gnu.org. Posting announcements. The "Spiffing" phase you might go through several times as you -discover problems. The "Punting" phase you do only once. +discover problems. The "Branching" and "Punting" phases you do only +once. +Branching checklist: -Spiffing checklist (NOTE: these instructions are out of date now that -we're using cvs branches for stable vs unstable). +* Announce when you're about to make the branch so that you have a + greater chance of people holding off on edits during the short + period while you're branching. + +* Make sure you're on the main trunk (see HACKING), and then create + the branch-root tag. i.e. -r branch-root_release-1-6. (Add the + exact command here next time I do it.) + +* Now create the branch with the branch tag. i.e. -r + branch_release-1-6. (Add exact command here next time I do it.) + +* Change the version numbers in GUILE-VERSION and README on the main + branch to reflect the new unstable version i.e. 1.7.0, if you're + currently creating the 1.6.X branch. + +Spiffing checklist: + +* Make sure you're working on the stable branch (see HACKING for + details). Note that after following the branch checklist above, you + won't necessarily be. -* Do a `cvs update -A', to get rid of any sticky tags in your working - directory. * Check for files that have changed a lot, but do not have up-to-date copyright notices. This can be as simple as doing: grep 'Copyright' * | grep -v 1999 and looking for files you know you've worked on a lot. + * Make sure NEWS, INSTALL, AUTHORS and THANKS and the docs are up to date: + Scan the ChangeLogs for user-visible changes, marked with an asterisk at the left margin. @@ -75,24 +97,30 @@ we're using cvs branches for stable vs unstable). + Fact-check INSTALL. + Make sure AUTHORS and THANKS are up-to-date (see also TODO). + Remove finished items from TODO (those marked w/ "+"). + * Make sure the downloading addresses and filenames in README are current. (But don't bump the version number yet. We do that below.) + * Check that the versions of aclocal, automake, autoconf, and autoheader in your PATH match those given in HACKING. Note that the `make dist' process always invokes these tools, even when all the generated files are up to date. Make specifically sure that the files in libltdl are generated using the same tools as the rest. + * Rebuild all generated files in the source tree: - + Install the .m4 files where aclocal will find them. - + Run aclocal. - + Run autoconf. - + Run autoheader. - + Run automake. + + run ./autogen.sh + * Verify that Guile builds and runs in your working directory. -* Run the test suite, in guile-core/test-suite. + +* Run a "make check". + * Commit all changes to the CVS repository. + * Build a test distribution. + + update GUILE-VERSION each time you make a test distribution. For + example, just before the 1.6.0 release, we went through some + number of 1.5.X test releases. + BEFORE doing 'make dist', configure the source tree for build in the same tree with configuration options --enable-maintainer-mode --enable-debug-malloc --with-threads. @@ -105,6 +133,7 @@ we're using cvs branches for stable vs unstable). (We currently use a kludge which edits the dependencies generated by automake so that Guile can be built in a directory separate from the source tree also with non-GNU make programs.) + * Give the test disty to various people to try. Here's what you should do: + Unset GUILE_LOAD_PATH. + Remove automake and autoconf from your path, or turn off their @@ -117,39 +146,70 @@ we're using cvs branches for stable vs unstable). Once you've got a disty that seems pretty solid: -* Choose new interface numbers for shared libraries. -* Update the version numbers in GUILE-VERSION and README. (There are - many places in README that need updating!) The Guile version - number should have one of the following forms: - N.M - a major release - N.M.L, where L is even - a minor release - N.M.L, where L is odd - sources from CVS or nightly snapshot +* Make sure the shared library libtool versioning numbers are correct, + but first make sure you understand "Libtool's versioning system" in + the libtool info pages. Guile is going to be versioning it's shared + libraries independently, so follow the libtool rules for choosing + version numbers, but make sure to keep in mind that not everyone is + as good about this as they should be. If a library even changes the + layout of a data structure that's part of it's API in a backward + incompatible way, even if that data structure is handled as an + opaque object in the API, that library is probably no longer + compatible with previous versions. + + A canonical ugly problem is this. Imagine you have libfoo and + libbar that both are linked against libbaz. Now imagine that you + create a libwhatever that uses both libfoo and libbar. What you + don't want to have happen is libfoo and libbar to be linked against + different versions of libbaz that produce incompatible instances of + the "same" data structure, and then have libwhatever get one version + of this data structure from libbaz via libfoo, and pass it back to a + different version of libbaz via libbar, a version of libbaz that + can't handle the newer/older struct from the other libbaz. + +* In general, there will be a number of libraries in guile that will + have to be versioned, and it would be best if the people who know + the most about the individual libs decide what the apropriate + CURRENT, REVISION, and AGE numbers for each one are. In general, + though, you have to be conservative. If no one is sure that the + libs are still compatible, then you *must* make the appropriate + changes under the assumption that they're not. Getting this wrong + is very BAD(TM). + +* Make the final update to the version numbers in GUILE-VERSION and + README. (There are many places in README that need updating!). See + HACKING for more information on how the version numbers are to be + chosen. + * Reformat the names in THANKS. -* Do a `cvs update -A' of the whole tree, to look for any stray + +* Do a `cvs -z3 update -Pd' of the whole tree, to look for any stray uncommitted or accidental changes. + * Commit your changes. + * Make one last test distribution. Punting checklist: * Add "Guile N.M released." entry to the top-level ChangeLog, and commit it. -* Tag the entire source tree with a tag of the form "release_N_M" - or "release_N_M_L". + +* Tag the entire source tree with a tag of the form "release_X-Y-Z", + i.e for release 1.6.0, use release_1-6-0 + * Do a 'make dist'. + * Put the distribution up for FTP somewhere, and send mail to ftp-upload@gnu.org, asking them to put it on prep. + * Send an announcement message to gnu-announce@gnu.org. Put a brief summary of the changes in this release first, then "Obtaining Guile", "Thanks", "About This Distribution," and "Nightly Snapshots." If I remember correctly, the moderator will delay it until the distribution appears on ftp.gnu.org. The announcement text should be mostly taken from Guile's README file. + * Notify freshmeat.net, although they're probably watching anyway. (They got the 1.3 release just fine.) I have no idea if www.bowerbird.com.au will be something anyone refers to, but Guile does have an entry there. -* Tweak the version numbers in GUILE-VERSION, and README to indicate - that the sources are a snapshot again. Snapshots should have - version numbers of the form "N.M.L", where L is odd. -* Start a new section of the NEWS file. -* Start a new THANKS file. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f46645a44..d7420768d 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2001-08-15 Rob Browning + + * Makefile.am (libguile_la_LDFLAGS): use libtool interface version + variables. + (libpath.h): change libguileversion to libguileinterface. + 2001-08-07 Marius Vollmer * Makefile.am (EXTRA_DIST): Distribute ChangeLog-1996-1999 and diff --git a/qt/ChangeLog b/qt/ChangeLog index 93ef31ee8..2550d9d59 100644 --- a/qt/ChangeLog +++ b/qt/ChangeLog @@ -1,3 +1,8 @@ +2001-08-15 Rob Browning + + * Makefile.am (libqthreads_la_LDFLAGS): use libtool interface version + variables. + 2000-06-12 Mikael Djurfeldt * Makefile.am (OMIT_DEPENDENCIES): Defined to contain the list of From 65e43ca6d385f646f1d3b5b9ba9116c541ddff6e Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Thu, 16 Aug 2001 03:44:36 +0000 Subject: [PATCH 1611/2047] * Makefile.am (libqthreads_la_LDFLAGS): use libtool interface version variables. --- qt/Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qt/Makefile.am b/qt/Makefile.am index 2ba31b93e..ab0aa3cb6 100644 --- a/qt/Makefile.am +++ b/qt/Makefile.am @@ -34,7 +34,7 @@ INCLUDES = -I.. -I$(srcdir)/.. libqthreads_la_SOURCES = qt.c copyright.h libqthreads_la_LIBADD = qtmds.lo qtmdc.lo libqthreads_la_DEPENDENCIES = qtmds.lo qtmdc.lo -libqthreads_la_LDFLAGS = -rpath $(libdir) +libqthreads_la_LDFLAGS = -rpath $(libdir) -version-info @LIBGUILEQTHREADS_INTERFACE_CURRENT@:@LIBGUILEQTHREADS_INTERFACE_REVISION@:@LIBGUILEQTHREADS_INTERFACE_AGE@ -export-dynamic OMIT_DEPENDENCIES = axp.h hppa.h i386.h ksr.h m88k.h mips.h sparc.h vax.h From eae3393547e5df6ab3dd0cceadce455ef9569ec2 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 17 Aug 2001 23:45:29 +0000 Subject: [PATCH 1612/2047] Fix omission bug: Add `heap_segment' forward decl (proto) in the case when either `GUILE_DEBUG' or `GUILE_DEBUG_FREELIST' preprocessor symbols are defined. (map_free_list): Fix typo: Ref `f' correctly. Thanks to Chris Cramer. --- libguile/gc.c | 36 +++++++++++++++++++----------------- 1 file changed, 19 insertions(+), 17 deletions(-) diff --git a/libguile/gc.c b/libguile/gc.c index 83b9263e6..b7a0defbf 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -102,7 +102,7 @@ unsigned int scm_gc_running_p = 0; scm_t_bits scm_tc16_allocated; -/* Set this to != 0 if every cell that is accessed shall be checked: +/* Set this to != 0 if every cell that is accessed shall be checked: */ unsigned int scm_debug_cell_accesses_p = 1; @@ -172,7 +172,7 @@ scm_assert_cell_valid (SCM cell) if (debug_cells_gc_interval) { static unsigned int counter = 0; - + if (counter != 0) { --counter; @@ -528,6 +528,8 @@ clear_mark_space () #if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST) +static long int heap_segment (SCM obj); /* forw decl: non-debugging func */ + static void map_free_list (scm_t_freelist *master, SCM freelist) { @@ -540,9 +542,9 @@ map_free_list (scm_t_freelist *master, SCM freelist) if (this_seg == -1) { - fprintf (stderr, + fprintf (stderr, "map_free_list: can't find segment containing cell %lux\n", - (unsigned long int) SCM_UNPACK (cell)); + (unsigned long int) SCM_UNPACK (f)); abort (); } else if (this_seg != last_seg) @@ -656,7 +658,7 @@ SCM_DEFINE (scm_free_list_length, "free-list-length", 0, 0, 0, } #undef FUNC_NAME -#endif +#endif /* defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST) */ #ifdef GUILE_DEBUG_FREELIST @@ -1185,7 +1187,7 @@ MARK (SCM p) #else /* go through the usual marking, but not for self-cycles. */ # define RECURSE(x) do { if ((x) != p) scm_gc_mark (x); } while (0) -#endif +#endif ptr = p; #ifdef MARK_DEPENDENCIES @@ -1208,7 +1210,7 @@ gc_mark_loop: return; gc_mark_nimp: - + #ifdef MARK_DEPENDENCIES if (SCM_EQ_P (ptr, p)) return; @@ -1230,10 +1232,10 @@ gc_mark_loop_first_time: #endif #ifndef MARK_DEPENDENCIES - + if (SCM_GCMARKP (ptr)) return; - + SCM_SETGCMARK (ptr); #endif @@ -1275,7 +1277,7 @@ gc_mark_loop_first_time: if (len) { long x; - + for (x = 0; x < len - 2; x += 2, ++struct_data) if (fields_desc[x] == 'p') RECURSE (SCM_PACK (*struct_data)); @@ -1451,7 +1453,7 @@ gc_mark_loop_first_time: * Thus, no conservative scanning for free cells is necessary, but * instead cells of type scm_tc16_allocated have to be scanned * conservatively. This is done in the mark function of the - * scm_tc16_allocated smob type. */ + * scm_tc16_allocated smob type. */ #endif break; case scm_tc16_big: @@ -1908,7 +1910,7 @@ scm_gc_sweep () scm_cells_allocated = (SCM_HEAP_SIZE - scm_gc_cells_collected); scm_gc_yield -= scm_cells_allocated; - + if (scm_mallocated < m) /* The byte count of allocated objects has underflowed. This is probably because you forgot to report the sizes of objects you @@ -1974,7 +1976,7 @@ scm_must_malloc (size_t size, const char *what) scm_igc (what); nm = scm_mallocated + size; - + if (nm < size) /* The byte count of allocated objects has overflowed. This is probably because you forgot to report the correct size of freed @@ -2130,7 +2132,7 @@ scm_done_malloc (long size) memory in some of your smob free methods. */ abort (); } - + scm_mallocated += size; if (scm_mallocated > scm_mtrigger) @@ -2239,7 +2241,7 @@ init_heap_seg (SCM_CELLPTR seg_org, size_t size, scm_t_freelist *freelist) /* Find the right place and insert the segment record. */ new_seg_index = 0; - while (new_seg_index < scm_n_heap_segs + while (new_seg_index < scm_n_heap_segs && SCM_PTR_LE (scm_heap_table[new_seg_index].bounds[0], seg_org)) new_seg_index++; @@ -2627,7 +2629,7 @@ scm_gc_register_root (SCM *p) { SCM handle; SCM key = scm_long2num ((long) p); - + /* This critical section barrier will be replaced by a mutex. */ SCM_REDEFER_INTS; @@ -2877,7 +2879,7 @@ mark_gc_async (void * hook_data SCM_UNUSED, * the execution of the next gc. Then, guile would keep executing the * after-gc-hook over and over again, and would never come to do other * things. - * + * * To overcome this problem, if cell access debugging with additional * garbage collections is enabled, the after-gc-hook is never run by the * garbage collecter. When running guile with cell access debugging and the From 43b83b541d7e1b05dfc1356e6e4afe75649b0f97 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 17 Aug 2001 23:50:02 +0000 Subject: [PATCH 1613/2047] *** empty log message *** --- libguile/ChangeLog | 26 ++++++++++++++++++-------- 1 file changed, 18 insertions(+), 8 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d7420768d..20191a9bd 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,13 @@ +2001-08-17 Thien-Thi Nguyen + + * gc.c: Fix omission bug: Add `heap_segment' forward decl + (proto) in the case when either `GUILE_DEBUG' or + `GUILE_DEBUG_FREELIST' preprocessor symbols are defined. + + (map_free_list): Fix typo: Ref `f' correctly. + + Thanks to Chris Cramer. + 2001-08-15 Rob Browning * Makefile.am (libguile_la_LDFLAGS): use libtool interface version @@ -82,7 +92,7 @@ 2001-07-29 Marius Vollmer Removed vcell slot from structs. - + * struct.h (scm_vtable_index_vcell): Removed. Renumbered subsequent indices. @@ -104,7 +114,7 @@ 2001-07-26 Marius Vollmer "Glocs" have been removed. - + * tags.h: Update tag system docs. (scm_tc3_cons_gloc): Renamed to scm_tc3_struct. Changed all uses. (scm_tcs_cons_gloc): Renamed to scm_tcs_struct. Changed all uses. @@ -117,7 +127,7 @@ * print.c (scm_iprin1): Remove printing of glocs. Do not try to tell glocs from structs. - + * gc.c (scm_gc_mark, scm_gc_sweep): Remove handling of glocs. * eval.c (scm_m_atbind): Make a list of variables, not glocs. @@ -130,7 +140,7 @@ (scm_m_atfop): Memoize as a variable, not as a gloc. (scm_eval_args, scm_deval_args): Do not handle glocs. (scm_ceval, scm_deval): Likewise. - + * eval.h (SCM_XEVALCAR): Do not test for glocs. (SCM_GLOC_VAR, SCM_GLOC_VAL, SCM_GLOC_SET_VAL, SCM_GLOC_VAL_LOC): Removed. @@ -143,10 +153,10 @@ * __scm.h (SCM_CAUTIOS, SCM_RECKLESS): Update comments. - + * gc_os_dep.c (GC_noop1): Moved into the same #if/#endif context where it is needed. - + 2001-07-25 Gary Houston * numbers.c (scm_logand, scm_logior, scm_logxor): adjusted the @@ -186,7 +196,7 @@ (variable_equal_p): Removed. (make_variable): Construct a tc7 object instead of a smob. (scm_init_variable): Do not register smob. - + 2001-07-22 Marius Vollmer * tags.h: Include inttypes.h when we have it. @@ -196,7 +206,7 @@ * tags.h (SCM_UNBOUND): Make it the 34th isym/iflag, the 33th slot is taken by the new SCM_IM_CALL_WITH_VALUES. * print.c (scm_isymnames): Update table accordingly. - + 2001-07-22 Gary Houston * regex-posix.c (s_scm_regexp_exec): use scm_long2num not From a786db16b20bbd6cedaf4249f7584f6d0861a5b5 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 18 Aug 2001 03:06:09 +0000 Subject: [PATCH 1614/2047] * .cvsignore: rename stamp-vti1 to stamp-vti.1. Of course this only matters once you fix the bug in automake. --- doc/.cvsignore | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/.cvsignore b/doc/.cvsignore index a73aeda2b..8eaa8267a 100644 --- a/doc/.cvsignore +++ b/doc/.cvsignore @@ -1,7 +1,7 @@ Makefile Makefile.in stamp-vti -stamp-vti1 +stamp-vti.1 *.log *.dvi *.aux From 8098fca9318e5fd1fbb0aa9ebf18c1d395ad8a0c Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 18 Aug 2001 03:06:18 +0000 Subject: [PATCH 1615/2047] *** empty log message *** --- RELEASE | 13 +++++++++++-- doc/ChangeLog | 8 ++++++++ 2 files changed, 19 insertions(+), 2 deletions(-) diff --git a/RELEASE b/RELEASE index 76ab6f9c3..8289964da 100644 --- a/RELEASE +++ b/RELEASE @@ -118,17 +118,26 @@ Spiffing checklist: * Commit all changes to the CVS repository. * Build a test distribution. + + update GUILE-VERSION each time you make a test distribution. For example, just before the 1.6.0 release, we went through some number of 1.5.X test releases. + + BEFORE doing 'make dist', configure the source tree for build - in the same tree with configuration options - --enable-maintainer-mode --enable-debug-malloc --with-threads. + in the same tree with these configuration options: + --enable-maintainer-mode + --enable-debug-malloc + --with-threads + --enable-error-on-warning + + Make sure that readline was enabled correctly. + + Build the tree. (If the above steps are not done, the dependencies won't be properly included in the generated Makefile.in files.) + + Then do 'make dist'. + + Check that the dependencies in guile-readline/Makefile look OK. (We currently use a kludge which edits the dependencies generated by automake so that Guile can be built in a directory separate diff --git a/doc/ChangeLog b/doc/ChangeLog index 3d6210db9..14763185a 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,11 @@ +2001-08-17 Rob Browning + + * Makefile.am (guile_tut_TEXINFOS): remove guile-tut.texi. It's + already in info_TEXINFOS. + + * .cvsignore: rename stamp-vti1 to stamp-vti.1. Of course this + only matters once you fix the bug in automake. + 2001-08-02 Neil Jerram * scheme-debug.texi (Debugging): Improve `make-stack' doc by From 59cd9b0f6755bd000747950af8fd25212f514446 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 18 Aug 2001 03:06:26 +0000 Subject: [PATCH 1616/2047] * Makefile.am (guile_tut_TEXINFOS): remove guile-tut.texi. It's already in info_TEXINFOS. --- doc/Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/Makefile.am b/doc/Makefile.am index c5b7156f3..edd481f66 100644 --- a/doc/Makefile.am +++ b/doc/Makefile.am @@ -38,7 +38,7 @@ guile_TEXINFOS = preface.texi intro.texi scheme-intro.texi \ extend.texi repl-modules.texi srfi-modules.texi misc-modules.texi \ AUTHORS -guile_tut_TEXINFOS = guile-tut.texi AUTHORS +guile_tut_TEXINFOS = AUTHORS goops_TEXINFOS = goops-tutorial.texi hierarchy.eps hierarchy.txt AUTHORS From cf504ee0cf7b5d3ebd28db334c1ccedab077b57a Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 18 Aug 2001 16:32:04 +0000 Subject: [PATCH 1617/2047] * Fix spelling mistake in comment. --- libguile/ChangeLog | 4 ++++ libguile/__scm.h | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 20191a9bd..e19afc953 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2001-08-18 Neil Jerram + + * __scm.h (SCM_ENABLE_VCELLS): Fix spelling mistake in comment. + 2001-08-17 Thien-Thi Nguyen * gc.c: Fix omission bug: Add `heap_segment' forward decl diff --git a/libguile/__scm.h b/libguile/__scm.h index 2e1e3b611..bda6326f2 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -237,7 +237,7 @@ #endif /* If SCM_ENABLE_VCELLS is set to 1, a couple of functions that deal - * with vcells are defined for compatability reasons. Supporting + * with vcells are defined for compatibility reasons. Supporting * vcells reduces performance however. * * We use a dedicated macro instead of just SCM_DEBUG_DEPRECATED so From 88176879bff0b24f67bb995495c461a104b39281 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 22 Aug 2001 09:57:35 +0000 Subject: [PATCH 1618/2047] * scheme-options.texi (Evaluator trap options): Splitted section "Evaluator options". * scheme-evaluation.texi (Evaluator Behaviour): Typo "reader options" --> "evaluator options". --- doc/ChangeLog | 8 + doc/scheme-evaluation.texi | 419 ------------------------------------- doc/scheme-options.texi | 342 ------------------------------ 3 files changed, 8 insertions(+), 761 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 14763185a..2f3cd2d11 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,11 @@ +2001-08-22 Mikael Djurfeldt + + * scheme-options.texi (Evaluator trap options): Splitted + section "Evaluator options". + + * scheme-evaluation.texi (Evaluator Behaviour): Typo "reader + options" --> "evaluator options". + 2001-08-17 Rob Browning * Makefile.am (guile_tut_TEXINFOS): remove guile-tut.texi. It's diff --git a/doc/scheme-evaluation.texi b/doc/scheme-evaluation.texi index 5a0f861ff..e69de29bb 100644 --- a/doc/scheme-evaluation.texi +++ b/doc/scheme-evaluation.texi @@ -1,419 +0,0 @@ -@page -@node Read/Load/Eval -@chapter Reading and Evaluating Scheme Code - -This chapter describes Guile functions that are concerned with reading, -loading and evaluating Scheme code at run time. - -@menu -* Scheme Syntax:: Standard and extended Scheme syntax. -* Scheme Read:: Reading Scheme code. -* Fly Evaluation:: Procedures for on the fly evaluation. -* Loading:: Loading Scheme code from file. -* Delayed Evaluation:: Postponing evaluation until it is needed. -* Local Evaluation:: Evaluation in a local environment. -* Evaluator Behaviour:: Modifying Guile's evaluator. -@end menu - - -@node Scheme Syntax -@section Scheme Syntax: Standard and Guile Extensions - -@menu -* Expression Syntax:: -* Comments:: -* Block Comments:: -* Case Sensitivity:: -* Keyword Syntax:: -* Reader Extensions:: -@end menu - - -@node Expression Syntax -@subsection Expression Syntax - - -@node Comments -@subsection Comments - -@c FIXME::martin: Review me! - -Comments in Scheme source files are written by starting them with a -semicolon character (@code{;}). The comment then reaches up to the end -of the line. Comments can begin at any column, and the may be inserted -on the same line as Scheme code. - -@lisp -; Comment -;; Comment too -(define x 1) ; Comment after expression -(let ((y 1)) - ;; Display something. - (display y) -;;; Comment at left margin. - (display (+ y 1))) -@end lisp - -It is common to use a single semicolon for comments following -expressions on a line, to use two semicolons for comments which are -indented like code, and three semicolons for comments which start at -column 0, even if they are inside an indented code block. This -convention is used when indenting code in Emacs' Scheme mode. - - -@node Block Comments -@subsection Block Comments - -@c FIXME::martin: Review me! - -@cindex multiline comments -In addition to the standard line comments defined by R5RS, Guile has -another comment type for multiline comments, called @dfn{block -comments}. This type of comment begins with the character sequence -@code{#!} and ends with the characters @code{!#}, which must appear on a -line of their own. These comments are compatible with the block -comments in the Scheme Shell @file{scsh} (@pxref{The Scheme shell -(scsh)}). The characters @code{#!} were chosen because they are the -magic characters used in shell scripts for indicating that the name of -the program for executing the script follows on the same line. - -Thus a Guile script often starts like this. - -@lisp -#! /usr/local/bin/guile -s -!# -@end lisp - -More details on Guile scripting can be found in the scripting section -(@pxref{Guile Scripting}). - - -@node Case Sensitivity -@subsection Case Sensitivity - -@c FIXME::martin: Review me! - -Scheme as defined in R5RS is not case sensitive when reading symbols. -Guile, on the contrary is case sensitive by default, so the identifiers - -@lisp -guile-whuzzy -Guile-Whuzzy -@end lisp - -are the same in R5RS Scheme, but are different in Guile. - -It is possible to turn off case sensitivity in Guile by setting the -reader option @code{case-insensitive}. More on reader options can be -found at (@pxref{Reader options}). - -@lisp -(read-enable 'case-insensitive) -@end lisp - -Note that this is seldom a problem, because Scheme programmers tend not -to use uppercase letters in their identifiers anyway. - - -@node Keyword Syntax -@subsection Keyword Syntax - - -@node Reader Extensions -@subsection Reader Extensions - -@deffn primitive read-hash-extend chr proc -Install the procedure @var{proc} for reading expressions -starting with the character sequence @code{#} and @var{chr}. -@var{proc} will be called with two arguments: the character -@var{chr} and the port to read further data from. The object -returned will be the return value of @code{read}. -@end deffn - - -@node Scheme Read -@section Reading Scheme Code - -@rnindex read -@deffn primitive read [port] -Read an s-expression from the input port @var{port}, or from -the current input port if @var{port} is not specified. -Any whitespace before the next token is discarded. -@end deffn - -The behaviour of Guile's Scheme reader can be modified by manipulating -its read options. For more information about options, @xref{General -option interface}. If you want to know which reader options are -available, @xref{Reader options}. - -@c FIXME::martin: This is taken from libguile/options.c. Is there -@c actually a difference between 'help and 'full? - -@deffn procedure read-options [setting] -Display the current settings of the read options. If @var{setting} is -omitted, only a short form of the current read options is printed. -Otherwise, @var{setting} should be one of the following symbols: -@table @code -@item help -Display the complete option settings. -@item full -Like @code{help}, but also print programmer options. -@end table -@end deffn - -@deffn procedure read-enable option-name -@deffnx procedure read-disable option-name -@deffnx procedure read-set! option-name value -Modify the read options. @code{read-enable} should be used with boolean -options and switches them on, @code{read-disable} switches them off. -@code{read-set!} can be used to set an option to a specific value. -@end deffn - -@deffn primitive read-options-interface [setting] -Option interface for the read options. Instead of using -this procedure directly, use the procedures @code{read-enable}, -@code{read-disable}, @code{read-set!} and @code{read-options}. -@end deffn - - -@node Fly Evaluation -@section Procedures for On the Fly Evaluation - -@rnindex eval -@c ARGFIXME environment/environment specifier -@deffn primitive eval exp environment -Evaluate @var{exp}, a list representing a Scheme expression, in the -environment given by @var{environment specifier}. -@end deffn - -@rnindex interaction-environment -@deffn primitive interaction-environment -Return a specifier for the environment that contains -implementation--defined bindings, typically a superset of those -listed in the report. The intent is that this procedure will -return the environment in which the implementation would -evaluate expressions dynamically typed by the user. -@end deffn - -@deffn primitive eval-string string -Evaluate @var{string} as the text representation of a Scheme -form or forms, and return whatever value they produce. -Evaluation takes place in the environment returned by the -procedure @code{interaction-environment}. -@end deffn - -@deffn primitive apply:nconc2last lst -Given a list (@var{arg1} @dots{} @var{args}), this function -conses the @var{arg1} @dots{} arguments onto the front of -@var{args}, and returns the resulting list. Note that -@var{args} is a list; thus, the argument to this function is -a list whose last element is a list. -Note: Rather than do new consing, @code{apply:nconc2last} -destroys its argument, so use with care. -@end deffn - -@rnindex apply -@deffn primitive apply proc arg1 @dots{} args -@var{proc} must be a procedure and @var{args} must be a list. Call -@var{proc} with the elements of the list @code{(append (list @var{arg1} -@dots{}) @var{args})} as the actual arguments. -@end deffn - -@deffn primitive primitive-eval exp -Evaluate @var{exp} in the top-level environment specified by -the current module. -@end deffn - -@deffn primitive eval2 obj env_thunk -Evaluate @var{exp}, a Scheme expression, in the environment -designated by @var{lookup}, a symbol-lookup function. -Do not use this version of eval, it does not play well -with the module system. Use @code{eval} or -@code{primitive-eval} instead. -@end deffn - -@deffn primitive read-and-eval! [port] -Read a form from @var{port} (standard input by default), and evaluate it -(memoizing it in the process) in the top-level environment. If no data -is left to be read from @var{port}, an @code{end-of-file} error is -signalled. -@end deffn - - -@node Loading -@section Loading Scheme Code from File - -@rnindex load -@deffn procedure load filename -Load @var{filename} and evaluate its contents in the top-level -environment. The load paths are not searched. If the variable -@code{%load-hook} is defined, it should be bound to a procedure that -will be called before any code is loaded. See documentation for -@code{%load-hook} later in this section. -@end deffn - -@deffn procedure load-from-path filename -Similar to @code{load}, but searches for @var{filename} in the load -paths. -@end deffn - -@deffn primitive primitive-load filename -Load the file named @var{filename} and evaluate its contents in -the top-level environment. The load paths are not searched; -@var{filename} must either be a full pathname or be a pathname -relative to the current directory. If the variable -@code{%load-hook} is defined, it should be bound to a procedure -that will be called before any code is loaded. See the -documentation for @code{%load-hook} later in this section. -@end deffn - -@deffn primitive primitive-load-path filename -Search @var{%load-path} for the file named @var{filename} and -load it into the top-level environment. If @var{filename} is a -relative pathname and is not found in the list of search paths, -an error is signalled. -@end deffn - -@deffn primitive %search-load-path filename -Search @var{%load-path} for the file named @var{filename}, -which must be readable by the current user. If @var{filename} -is found in the list of paths to search or is an absolute -pathname, return its full pathname. Otherwise, return -@code{#f}. Filenames may have any of the optional extensions -in the @code{%load-extensions} list; @code{%search-load-path} -will try each extension automatically. -@end deffn - -@defvar %load-hook -A procedure to be run whenever @code{primitive-load} is called. If this -procedure is defined, it will be called with the filename argument that -was passed to @code{primitive-load}. - -@example -(define %load-hook (lambda (file) - (display "Loading ") - (display file) - (write-line "...."))) @result{} undefined -(load-from-path "foo.scm") -@print{} Loading /usr/local/share/guile/site/foo.scm.... -@end example - -@end defvar - -@deffn primitive current-load-port -Return the current-load-port. -The load port is used internally by @code{primitive-load}. -@end deffn - -@defvar %load-extensions -A list of default file extensions for files containing Scheme code. -@code{%search-load-path} tries each of these extensions when looking for -a file to load. By default, @code{%load-extensions} is bound to the -list @code{("" ".scm")}. -@end defvar - - -@node Delayed Evaluation -@section Delayed Evaluation - -[delay] - -@deffn primitive promise? obj -Return true if @var{obj} is a promise, i.e. a delayed computation -(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}). -@end deffn - -@rnindex force -@deffn primitive force x -If the promise @var{x} has not been computed yet, compute and -return @var{x}, otherwise just return the previously computed -value. -@end deffn - - -@node Local Evaluation -@section Local Evaluation - -[the-environment] - -@deffn primitive local-eval exp [env] -Evaluate @var{exp} in its environment. If @var{env} is supplied, -it is the environment in which to evaluate @var{exp}. Otherwise, -@var{exp} must be a memoized code object (in which case, its environment -is implicit). -@end deffn - - -@node Evaluator Behaviour -@section Evaluator Behaviour - -@c FIXME::martin: Maybe this node name is bad, but the old name clashed with -@c `Evaluator options' under `Options and Config'. - -The behaviour of Guile's evaluator can be modified by manipulating the -evaluator options. For more information about options, @xref{General -option interface}. If you want to know which reader options are -available, @xref{Evaluator options}. - -@c FIXME::martin: This is taken from libguile/options.c. Is there -@c actually a difference between 'help and 'full? - -@deffn procedure eval-options [setting] -Display the current settings of the evaluator options. If @var{setting} -is omitted, only a short form of the current evaluator options is -printed. Otherwise, @var{setting} should be one of the following -symbols: -@table @code -@item help -Display the complete option settings. -@item full -Like @code{help}, but also print programmer options. -@end table -@end deffn - -@deffn procedure eval-enable option-name -@deffnx procedure eval-disable option-name -@deffnx procedure eval-set! option-name value -Modify the evaluator options. @code{eval-enable} should be used with boolean -options and switches them on, @code{eval-disable} switches them off. -@code{eval-set!} can be used to set an option to a specific value. -@end deffn - -@deffn primitive eval-options-interface [setting] -Option interface for the evaluation options. Instead of using -this procedure directly, use the procedures @code{eval-enable}, -@code{eval-disable}, @code{eval-set!} and @code{eval-options}. -@end deffn - -@c FIXME::martin: Why aren't these procedure named like the other options -@c procedures? - -@deffn procedure traps [setting] -Display the current settings of the evaluator traps options. If -@var{setting} is omitted, only a short form of the current evaluator -traps options is printed. Otherwise, @var{setting} should be one of the -following symbols: -@table @code -@item help -Display the complete option settings. -@item full -Like @code{help}, but also print programmer options. -@end table -@end deffn - -@deffn procedure trap-enable option-name -@deffnx procedure trap-disable option-name -@deffnx procedure trap-set! option-name value -Modify the evaluator options. @code{trap-enable} should be used with boolean -options and switches them on, @code{trap-disable} switches them off. -@code{trap-set!} can be used to set an option to a specific value. -@end deffn - -@deffn primitive evaluator-traps-interface [setting] -Option interface for the evaluator trap options. -@end deffn - - -@c Local Variables: -@c TeX-master: "guile.texi" -@c End: diff --git a/doc/scheme-options.texi b/doc/scheme-options.texi index 4e711764a..e69de29bb 100644 --- a/doc/scheme-options.texi +++ b/doc/scheme-options.texi @@ -1,342 +0,0 @@ -@page -@node Options and Config -@chapter Runtime Options and Configuration - -Guile's behaviour can be modified by setting options. For example, is -the language that Guile accepts case sensitive, or should the debugger -automatically show a backtrace on error? - -Guile has two levels of interface for managing options: a low-level -control interface, and a user-level interface which allows the enabling -or disabling of options. - -Moreover, the options are classified in groups according to whether they -configure @emph{reading}, @emph{printing}, @emph{debugging} or -@emph{evaluating}. - -@menu -* General option interface:: -* Reader options:: -* Printing options:: -* Debugger options:: -* Evaluator options:: -* Examples of option use:: -* Install Config:: Installation and configuration data. -@end menu - -@node General option interface -@section General option interface - -We will use the expression @code{} to represent @code{read}, -@code{print}, @code{debug} or @code{evaluator}. - -@subheading Low level - -@c NJFIXME -@deffn primitive -options-interface -@deffnx primitive read-options-interface [SOME-INT] -@deffnx primitive print-options-interface [SOME-INT] -@deffnx primitive evaluator-traps-interface [SOME-INT] -@deffnx primitive read-options-interface [SOME-INT] -[FIXME: I have just taken the comments for C routine scm_options that -implements all of these. It needs to be presented better.] - -If scm_options is called without arguments, the current option setting -is returned. If the argument is an option setting, options are altered -and the old setting is returned. If the argument isn't a list, a list -of sublists is returned, where each sublist contains option name, value -and documentation string. -@end deffn - - -@subheading User level - -@c @deftp {Data type} scm_option -@c @code{scm_option} is used to represent run time options. It can be a -@c @emph{boolean} type, in which case the option will be set by the strings -@c @code{"yes"} and @code{"no"}. It can be a -@c @end deftp - -@c NJFIXME -@deffn procedure -options [arg] -@deffnx procedure read-options [arg] -@deffnx procedure print-options [arg] -@deffnx procedure debug-options [arg] -@deffnx procedure traps [arg] -These functions list the options in their group. The optional argument -@var{arg} is a symbol which modifies the form in which the options are -presented. - -With no arguments, @code{-options} returns the values of the -options in that particular group. If @var{arg} is @code{'help}, a -description of each option is given. If @var{arg} is @code{'full}, -programmers' options are also shown. - -@var{arg} can also be a list representing the state of all options. In -this case, the list contains single symbols (for enabled boolean -options) and symbols followed by values. -@end deffn -[FIXME: I don't think 'full is ever any different from 'help. What's -up?] - -@c NJFIXME -@deffn procedure -enable option-symbol -@deffnx procedure read-enable option-symbol -@deffnx procedure print-enable option-symbol -@deffnx procedure debug-enable option-symbol -@deffnx procedure trap-enable option-symbol -These functions set the specified @var{option-symbol} in their options -group. They only work if the option is boolean, and throw an error -otherwise. -@end deffn - -@c NJFIXME -@deffn procedure -disable option-symbol -@deffnx procedure read-disable option-symbol -@deffnx procedure print-disable option-symbol -@deffnx procedure debug-disable option-symbol -@deffnx procedure trap-disable option-symbol -These functions turn off the specified @var{option-symbol} in their -options group. They only work if the option is boolean, and throw an -error otherwise. -@end deffn - -@c NJFIXME -@deffn syntax -set! option-symbol value -@deffnx syntax read-set! option-symbol value -@deffnx syntax print-set! option-symbol value -@deffnx syntax debug-set! option-symbol value -@deffnx syntax trap-set! option-symbol value -These functions set a non-boolean @var{option-symbol} to the specified -@var{value}. -@end deffn - - -@node Reader options -@section Reader options -@cindex options - read -@cindex read options - -Here is the list of reader options generated by typing -@code{(read-options 'full)} in Guile. You can also see the default -values. - -@smalllisp -keywords #f Style of keyword recognition: #f or 'prefix -case-insensitive no Convert symbols to lower case. -positions yes Record positions of source code expressions. -copy no Copy source code expressions. -@end smalllisp - -Notice that while Standard Scheme is case insensitive, to ease -translation of other Lisp dialects, notably Emacs Lisp, into Guile, -Guile is case-sensitive by default. - -To make Guile case insensitive, you can type - -@smalllisp -(read-enable 'case-insensitive) -@end smalllisp - -@node Printing options -@section Printing options - -Here is the list of print options generated by typing -@code{(print-options 'full)} in Guile. You can also see the default -values. - -@smallexample -source no Print closures with source. -closure-hook #f Hook for printing closures. -@end smallexample - - -@node Evaluator options -@section Evaluator options - -These are the evaluator options with their default values, as they are -printed by typing @code{(eval-options 'full)} in Guile. - -@smallexample -stack 22000 Size of thread stacks (in machine words). -@end smallexample - -Here is the list of evaluator trap options generated by typing -@code{(traps 'full)} in Guile. You can also see the default values. - -@smallexample -exit-frame no Trap when exiting eval or apply. -apply-frame no Trap when entering apply. -enter-frame no Trap when eval enters new frame. -@end smallexample - - -@node Debugger options -@section Debugger options - -Here is the list of print options generated by typing -@code{(debug-options 'full)} in Guile. You can also see the default -values. - -@smallexample -stack 20000 Stack size limit (0 = no check). -debug yes Use the debugging evaluator. -backtrace no Show backtrace on error. -depth 20 Maximal length of printed backtrace. -maxdepth 1000 Maximal number of stored backtrace frames. -frames 3 Maximum number of tail-recursive frames in backtrace. -indent 10 Maximal indentation in backtrace. -backwards no Display backtrace in anti-chronological order. -procnames yes Record procedure names at definition. -trace no *Trace mode. -breakpoints no *Check for breakpoints. -cheap yes *Flyweight representation of the stack at traps. -@end smallexample - - -@node Examples of option use -@section Examples of option use - -Here is an example of a session in which some read and debug option -handling procedures are used. In this example, the user - -@enumerate -@item -Notices that the symbols @code{abc} and @code{aBc} are not the same -@item -Examines the @code{read-options}, and sees that @code{case-insensitive} -is set to ``no''. -@item -Enables @code{case-insensitive} -@item -Verifies that now @code{aBc} and @code{abc} are the same -@item -Disables @code{case-insensitive} and enables debugging @code{backtrace} -@item -Reproduces the error of displaying @code{aBc} with backtracing enabled -[FIXME: this last example is lame because there is no depth in the -backtrace. Need to give a better example, possibly putting debugging -option examples in a separate session.] -@end enumerate - - -@smalllisp -guile> (define abc "hello") -guile> abc -"hello" -guile> aBc -ERROR: In expression aBc: -ERROR: Unbound variable: aBc -ABORT: (misc-error) - -Type "(backtrace)" to get more information. -guile> (read-options 'help) -keywords #f Style of keyword recognition: #f or 'prefix -case-insensitive no Convert symbols to lower case. -positions yes Record positions of source code expressions. -copy no Copy source code expressions. -guile> (debug-options 'help) -stack 20000 Stack size limit (0 = no check). -debug yes Use the debugging evaluator. -backtrace no Show backtrace on error. -depth 20 Maximal length of printed backtrace. -maxdepth 1000 Maximal number of stored backtrace frames. -frames 3 Maximum number of tail-recursive frames in backtrace. -indent 10 Maximal indentation in backtrace. -backwards no Display backtrace in anti-chronological order. -procnames yes Record procedure names at definition. -trace no *Trace mode. -breakpoints no *Check for breakpoints. -cheap yes *Flyweight representation of the stack at traps. -guile> (read-enable 'case-insensitive) -(keywords #f case-insensitive positions) -guile> aBc -"hello" -guile> (read-disable 'case-insensitive) -(keywords #f positions) -guile> (debug-enable 'backtrace) -(stack 20000 debug backtrace depth 20 maxdepth 1000 frames 3 indent 10 procnames cheap) -guile> aBc - -Backtrace: -0* aBc - -ERROR: In expression aBc: -ERROR: Unbound variable: aBc -ABORT: (misc-error) -guile> -@end smalllisp - - -@node Install Config -@section Installation and Configuration Data - -It is often useful to have site-specific information about the current -Guile installation. This chapter describes how to find out about -Guile's configuration at run time. - -@deffn primitive version -@deffnx primitive major-version -@deffnx primitive minor-version -@deffnx primitive micro-version -Return a string describing Guile's version number, or its major or minor -version numbers, respectively. - -@lisp -(version) @result{} "1.6.5" -(major-version) @result{} "1" -(minor-version) @result{} "6" -(micro-version) @result{} "5" -@end lisp -@end deffn - -@c NJFIXME not in libguile! -@deffn primitive libguile-config-stamp -Return a string describing the date on which @code{libguile} was -configured. This is used to determine whether the Guile core -interpreter and the ice-9 runtime have grown out of date with one -another. -@end deffn - -@deffn primitive %package-data-dir -Return the name of the directory where Scheme packages, modules and -libraries are kept. On most Unix systems, this will be -@samp{/usr/local/share/guile}. -@end deffn - -@deffn primitive %library-dir -Return the directory where the Guile Scheme library files are installed. -E.g., may return "/usr/share/guile/1.3.5". -@end deffn - -@deffn primitive %site-dir -Return the directory where the Guile site files are installed. -E.g., may return "/usr/share/guile/site". -@end deffn - -@deffn primitive parse-path path [tail] -Parse @var{path}, which is expected to be a colon-separated -string, into a list and return the resulting list with -@var{tail} appended. If @var{path} is @code{#f}, @var{tail} -is returned. -@end deffn - -@deffn primitive search-path path filename [extensions] -Search @var{path} for a directory containing a file named -@var{filename}. The file must be readable, and not a directory. -If we find one, return its full filename; otherwise, return -@code{#f}. If @var{filename} is absolute, return it unchanged. -If given, @var{extensions} is a list of strings; for each -directory in @var{path}, we search for @var{filename} -concatenated with each @var{extension}. -@end deffn - -@defvar %load-path -Return the list of directories which should be searched for Scheme -modules and libraries. -@end defvar - - -@c Local Variables: -@c TeX-master: "guile.texi" -@c End: From 80fdeb4e5a869726da90c88ddce377f599515ee8 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 22 Aug 2001 12:00:06 +0000 Subject: [PATCH 1619/2047] * tests/srfi-13.test (string-map): Swapped order of string and proc args to conform with the srfi. (Thanks to Alex Shinn.) * srfi-13.c (string-map): Swapped order of string and proc args to conform with the srfi. (Thanks to Alex Shinn.) --- srfi/ChangeLog | 5 +++++ srfi/srfi-13.c | 12 ++++++------ test-suite/ChangeLog | 5 +++++ test-suite/tests/srfi-13.test | 13 ++++++++++++- 4 files changed, 28 insertions(+), 7 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index d2e94bbe5..e2286b8b7 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,8 @@ +2001-08-22 Mikael Djurfeldt + + * srfi-13.c (string-map): Swapped order of string and proc args to + conform with the srfi. (Thanks to Alex Shinn.) + 2001-08-05 Gary Houston * srfi-1.scm (check-arg-type, non-negative-integer?): a couple of new diff --git a/srfi/srfi-13.c b/srfi/srfi-13.c index acd043b9c..a54dfbc1a 100644 --- a/srfi/srfi-13.c +++ b/srfi/srfi-13.c @@ -2400,7 +2400,7 @@ SCM_DEFINE (scm_string_concatenate_reverse_shared, "string-concatenate-reverse/s SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0, - (SCM s, SCM proc, SCM start, SCM end), + (SCM proc, SCM s, SCM start, SCM end), "@var{proc} is a char->char procedure, it is mapped over\n" "@var{s}. The order in which the procedure is applied to the\n" "string elements is not specified.") @@ -2410,10 +2410,10 @@ SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0, int cstart, cend; SCM result; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + SCM_VALIDATE_PROC (1, proc); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, 3, start, cstart, 4, end, cend); - SCM_VALIDATE_PROC (2, proc); result = scm_allocate_string (cend - cstart); p = SCM_STRING_CHARS (result); while (cstart < cend) @@ -2430,7 +2430,7 @@ SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0, SCM_DEFINE (scm_string_map_x, "string-map!", 2, 2, 0, - (SCM s, SCM proc, SCM start, SCM end), + (SCM proc, SCM s, SCM start, SCM end), "@var{proc} is a char->char procedure, it is mapped over\n" "@var{s}. The order in which the procedure is applied to the\n" "string elements is not specified. The string @var{s} is\n" @@ -2440,10 +2440,10 @@ SCM_DEFINE (scm_string_map_x, "string-map!", 2, 2, 0, char * cstr, *p; int cstart, cend; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + SCM_VALIDATE_PROC (1, proc); + SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, 3, start, cstart, 4, end, cend); - SCM_VALIDATE_PROC (2, proc); p = SCM_STRING_CHARS (s) + cstart; while (cstart < cend) { diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index e0d6c6716..d12e6fdc1 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2001-08-22 Mikael Djurfeldt + + * tests/srfi-13.test (string-map): Swapped order of string and + proc args to conform with the srfi. (Thanks to Alex Shinn.) + 2001-08-12 Thien-Thi Nguyen * tests/getopt-long.test (exception:no-such-option, diff --git a/test-suite/tests/srfi-13.test b/test-suite/tests/srfi-13.test index b55472b75..37ecfa5af 100644 --- a/test-suite/tests/srfi-13.test +++ b/test-suite/tests/srfi-13.test @@ -18,7 +18,7 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA -(use-modules (srfi srfi-13) (srfi srfi-14)) +(use-modules (srfi srfi-13) (srfi srfi-14) (test-suite lib)) ;;; This kludge is needed, because SRFI-13 redefines some bindings in ;;; the core. @@ -1010,3 +1010,14 @@ (pass-if "pred, start and end index" (string=? "" (string-delete ".foo.bar." char-alphabetic? 2 4)))) + +(with-test-prefix "string-map" + + (pass-if "constant" + (string=? "xxx" (string-map (lambda (c) #\x) "foo"))) + + (pass-if "identity" + (string=? "foo" (string-map identity "foo"))) + + (pass-if "upcase" + (string=? "FOO" (string-map char-upcase "foo")))) From a0e07ba4ec86e4df014fee0666f18ece5a4d2471 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 24 Aug 2001 09:40:29 +0000 Subject: [PATCH 1620/2047] * Organize documentation into per-manual directories (halfway point commit). --- doc/ChangeLog-guile-doc-ref | 0 doc/ChangeLog-guile-doc-tutorial | 0 doc/api.txt | 0 doc/deprecated.texi | 0 doc/expect.texi | 0 doc/extend.texi | 0 doc/format.texi | 0 doc/gh.texi | 0 doc/goops-tutorial.texi | 0 doc/goops.texi | 0 doc/goops/.cvsignore | 23 + doc/goops/goops-tutorial.texi | 810 ++ doc/goops/goops.texi | 2788 +++++++ doc/goops/hierarchy.eps | 127 + doc/goops/hierarchy.txt | 14 + doc/goops/mop.text | 66 + doc/guile-tut.texi | 0 doc/hierarchy.eps | 0 doc/hierarchy.txt | 0 doc/indices.texi | 0 doc/misc-modules.texi | 0 doc/mop.text | 0 doc/new-docstrings.texi | 0 doc/posix.texi | 0 doc/preface.texi | 0 doc/r5rs.texi | 0 doc/r5rs/.cvsignore | 23 + doc/r5rs/r5rs.texi | 8538 +++++++++++++++++++++ doc/ref/.cvsignore | 23 + doc/ref/ChangeLog-guile-doc-ref | 890 +++ doc/ref/api.txt | 185 + doc/{ => ref}/appendices.texi | 0 doc/{ => ref}/data-rep.texi | 2 +- doc/ref/deprecated.texi | 138 + doc/ref/expect.texi | 142 + doc/ref/extend.texi | 44 + doc/ref/gh.texi | 1164 +++ doc/{ => ref}/guile.texi | 2 +- doc/ref/indices.texi | 54 + doc/{ => ref}/intro.texi | 2 +- doc/ref/misc-modules.texi | 291 + doc/ref/new-docstrings.texi | 532 ++ doc/ref/posix.texi | 2328 ++++++ doc/ref/preface.texi | 182 + doc/ref/repl-modules.texi | 131 + doc/ref/scheme-binding.texi | 242 + doc/ref/scheme-control.texi | 823 ++ doc/ref/scheme-data.texi | 5230 +++++++++++++ doc/ref/scheme-debug.texi | 187 + doc/ref/scheme-evaluation.texi | 419 + doc/ref/scheme-ideas.texi | 1458 ++++ doc/ref/scheme-indices.texi | 17 + doc/ref/scheme-intro.texi | 55 + doc/ref/scheme-io.texi | 826 ++ doc/ref/scheme-memory.texi | 222 + doc/ref/scheme-modules.texi | 826 ++ doc/ref/scheme-options.texi | 398 + doc/ref/scheme-procedures.texi | 778 ++ doc/ref/scheme-reading.texi | 27 + doc/ref/scheme-scheduling.texi | 435 ++ doc/ref/scheme-translation.texi | 44 + doc/ref/scheme-utility.texi | 295 + doc/ref/scm.texi | 458 ++ doc/ref/script-getopt.texi | 435 ++ doc/ref/scripts.texi | 213 + doc/ref/scsh.texi | 25 + doc/ref/slib.texi | 105 + doc/ref/srfi-modules.texi | 2241 ++++++ doc/ref/tcltk.texi | 3 + doc/repl-modules.texi | 0 doc/scheme-binding.texi | 0 doc/scheme-control.texi | 0 doc/scheme-data.texi | 0 doc/scheme-debug.texi | 0 doc/scheme-evaluation.texi | 0 doc/scheme-ideas.texi | 0 doc/scheme-indices.texi | 0 doc/scheme-intro.texi | 0 doc/scheme-io.texi | 0 doc/scheme-memory.texi | 0 doc/scheme-modules.texi | 0 doc/scheme-options.texi | 0 doc/scheme-procedures.texi | 0 doc/scheme-reading.texi | 0 doc/scheme-scheduling.texi | 0 doc/scheme-translation.texi | 0 doc/scheme-utility.texi | 0 doc/scm.texi | 0 doc/script-getopt.texi | 0 doc/scripts.texi | 0 doc/scsh.texi | 0 doc/slib.texi | 0 doc/{ => sources}/env.texi | 2 +- doc/sources/format.texi | 434 ++ doc/srfi-modules.texi | 0 doc/tcltk.texi | 0 doc/tutorial/.cvsignore | 23 + doc/tutorial/ChangeLog-guile-doc-tutorial | 16 + doc/tutorial/guile-tut.texi | 1334 ++++ 99 files changed, 36066 insertions(+), 4 deletions(-) delete mode 100644 doc/ChangeLog-guile-doc-ref delete mode 100644 doc/ChangeLog-guile-doc-tutorial delete mode 100644 doc/api.txt delete mode 100644 doc/deprecated.texi delete mode 100644 doc/expect.texi delete mode 100644 doc/extend.texi delete mode 100644 doc/format.texi delete mode 100644 doc/gh.texi delete mode 100644 doc/goops-tutorial.texi delete mode 100644 doc/goops.texi create mode 100644 doc/goops/.cvsignore create mode 100644 doc/goops/goops-tutorial.texi create mode 100644 doc/goops/goops.texi create mode 100644 doc/goops/hierarchy.eps create mode 100644 doc/goops/hierarchy.txt create mode 100644 doc/goops/mop.text delete mode 100644 doc/guile-tut.texi delete mode 100644 doc/hierarchy.eps delete mode 100644 doc/hierarchy.txt delete mode 100644 doc/indices.texi delete mode 100644 doc/misc-modules.texi delete mode 100644 doc/mop.text delete mode 100644 doc/new-docstrings.texi delete mode 100644 doc/posix.texi delete mode 100644 doc/preface.texi delete mode 100644 doc/r5rs.texi create mode 100644 doc/r5rs/.cvsignore create mode 100644 doc/r5rs/r5rs.texi create mode 100644 doc/ref/.cvsignore create mode 100644 doc/ref/ChangeLog-guile-doc-ref create mode 100644 doc/ref/api.txt rename doc/{ => ref}/appendices.texi (100%) rename doc/{ => ref}/data-rep.texi (99%) create mode 100644 doc/ref/deprecated.texi create mode 100644 doc/ref/expect.texi create mode 100644 doc/ref/extend.texi create mode 100644 doc/ref/gh.texi rename doc/{ => ref}/guile.texi (99%) create mode 100644 doc/ref/indices.texi rename doc/{ => ref}/intro.texi (99%) create mode 100644 doc/ref/misc-modules.texi create mode 100644 doc/ref/new-docstrings.texi create mode 100644 doc/ref/posix.texi create mode 100644 doc/ref/preface.texi create mode 100644 doc/ref/repl-modules.texi create mode 100644 doc/ref/scheme-binding.texi create mode 100644 doc/ref/scheme-control.texi create mode 100755 doc/ref/scheme-data.texi create mode 100644 doc/ref/scheme-debug.texi create mode 100644 doc/ref/scheme-evaluation.texi create mode 100644 doc/ref/scheme-ideas.texi create mode 100644 doc/ref/scheme-indices.texi create mode 100644 doc/ref/scheme-intro.texi create mode 100644 doc/ref/scheme-io.texi create mode 100644 doc/ref/scheme-memory.texi create mode 100644 doc/ref/scheme-modules.texi create mode 100644 doc/ref/scheme-options.texi create mode 100644 doc/ref/scheme-procedures.texi create mode 100644 doc/ref/scheme-reading.texi create mode 100644 doc/ref/scheme-scheduling.texi create mode 100644 doc/ref/scheme-translation.texi create mode 100644 doc/ref/scheme-utility.texi create mode 100644 doc/ref/scm.texi create mode 100644 doc/ref/script-getopt.texi create mode 100644 doc/ref/scripts.texi create mode 100644 doc/ref/scsh.texi create mode 100644 doc/ref/slib.texi create mode 100644 doc/ref/srfi-modules.texi create mode 100644 doc/ref/tcltk.texi delete mode 100644 doc/repl-modules.texi delete mode 100644 doc/scheme-binding.texi delete mode 100644 doc/scheme-control.texi delete mode 100755 doc/scheme-data.texi delete mode 100644 doc/scheme-debug.texi delete mode 100644 doc/scheme-evaluation.texi delete mode 100644 doc/scheme-ideas.texi delete mode 100644 doc/scheme-indices.texi delete mode 100644 doc/scheme-intro.texi delete mode 100644 doc/scheme-io.texi delete mode 100644 doc/scheme-memory.texi delete mode 100644 doc/scheme-modules.texi delete mode 100644 doc/scheme-options.texi delete mode 100644 doc/scheme-procedures.texi delete mode 100644 doc/scheme-reading.texi delete mode 100644 doc/scheme-scheduling.texi delete mode 100644 doc/scheme-translation.texi delete mode 100644 doc/scheme-utility.texi delete mode 100644 doc/scm.texi delete mode 100644 doc/script-getopt.texi delete mode 100644 doc/scripts.texi delete mode 100644 doc/scsh.texi delete mode 100644 doc/slib.texi rename doc/{ => sources}/env.texi (99%) create mode 100644 doc/sources/format.texi delete mode 100644 doc/srfi-modules.texi delete mode 100644 doc/tcltk.texi create mode 100644 doc/tutorial/.cvsignore create mode 100644 doc/tutorial/ChangeLog-guile-doc-tutorial create mode 100644 doc/tutorial/guile-tut.texi diff --git a/doc/ChangeLog-guile-doc-ref b/doc/ChangeLog-guile-doc-ref deleted file mode 100644 index e69de29bb..000000000 diff --git a/doc/ChangeLog-guile-doc-tutorial b/doc/ChangeLog-guile-doc-tutorial deleted file mode 100644 index e69de29bb..000000000 diff --git a/doc/api.txt b/doc/api.txt deleted file mode 100644 index e69de29bb..000000000 diff --git a/doc/deprecated.texi b/doc/deprecated.texi deleted file mode 100644 index e69de29bb..000000000 diff --git a/doc/expect.texi b/doc/expect.texi deleted file mode 100644 index e69de29bb..000000000 diff --git a/doc/extend.texi b/doc/extend.texi deleted file mode 100644 index e69de29bb..000000000 diff --git a/doc/format.texi b/doc/format.texi deleted file mode 100644 index e69de29bb..000000000 diff --git a/doc/gh.texi b/doc/gh.texi deleted file mode 100644 index e69de29bb..000000000 diff --git a/doc/goops-tutorial.texi b/doc/goops-tutorial.texi deleted file mode 100644 index e69de29bb..000000000 diff --git a/doc/goops.texi b/doc/goops.texi deleted file mode 100644 index e69de29bb..000000000 diff --git a/doc/goops/.cvsignore b/doc/goops/.cvsignore new file mode 100644 index 000000000..8eaa8267a --- /dev/null +++ b/doc/goops/.cvsignore @@ -0,0 +1,23 @@ +Makefile +Makefile.in +stamp-vti +stamp-vti.1 +*.log +*.dvi +*.aux +*.toc +*.cp +*.fn +*.vr +*.tp +*.ky +*.pg +*.cps +*.fns +*.tps +*.vrs +*.ps +*.info* +*.html +version.texi +version-tutorial.texi diff --git a/doc/goops/goops-tutorial.texi b/doc/goops/goops-tutorial.texi new file mode 100644 index 000000000..7ab6ebcf0 --- /dev/null +++ b/doc/goops/goops-tutorial.texi @@ -0,0 +1,810 @@ +@c Original attribution: + +@c +@c STk Reference manual (Appendix: An Introduction to STklos) +@c +@c Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI +@c Permission to use, copy, modify, distribute,and license this +@c software and its documentation for any purpose is hereby granted, +@c provided that existing copyright notices are retained in all +@c copies and that this notice is included verbatim in any +@c distributions. No written agreement, license, or royalty fee is +@c required for any of the authorized uses. +@c This software is provided ``AS IS'' without express or implied +@c warranty. +@c + +@c Adapted for use in Guile with the authors permission + +@c @macro goops @c was {\stklos} +@c GOOPS +@c @end macro + +@c @macro guile @c was {\stk} +@c Guile +@c @end macro + +This is chapter was originally written by Erick Gallesio as an appendix +for the STk reference manual, and subsequently adapted to @goops{}. + +@menu +* Copyright:: +* Intro:: +* Class definition and instantiation:: +* Inheritance:: +* Generic functions:: +@end menu + +@node Copyright, Intro, Tutorial, Tutorial +@section Copyright + +Original attribution: + +STk Reference manual (Appendix: An Introduction to STklos) + +Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI +Permission to use, copy, modify, distribute,and license this +software and its documentation for any purpose is hereby granted, +provided that existing copyright notices are retained in all +copies and that this notice is included verbatim in any +distributions. No written agreement, license, or royalty fee is +required for any of the authorized uses. +This software is provided ``AS IS'' without express or implied +warranty. + +Adapted for use in Guile with the authors permission + +@node Intro, Class definition and instantiation, Copyright, Tutorial +@section Introduction + +@goops{} is the object oriented extension to @guile{}. Its +implementation is derived from @w{STk-3.99.3} by Erick Gallesio and +version 1.3 of the Gregor Kiczales @cite{Tiny-Clos}. It is very close +to CLOS, the Common Lisp Object System (@cite{CLtL2}) but is adapted for +the Scheme language. + +Briefly stated, the @goops{} extension gives the user a full object +oriented system with multiple inheritance and generic functions with +multi-method dispatch. Furthermore, the implementation relies on a true +meta object protocol, in the spirit of the one defined for CLOS +(@cite{Gregor Kiczales: A Metaobject Protocol}). + +The purpose of this tutorial is to introduce briefly the @goops{} +package and in no case will it replace the @goops{} reference manual +(which needs to be urgently written now@ @dots{}). + +Note that the operations described in this tutorial resides in modules +that may need to be imported before being available. The main module is +imported by evaluating: + +@lisp +(use-modules (oop goops)) +@end lisp +@findex (oop goops) +@cindex main module +@cindex loading +@cindex preparing + +@node Class definition and instantiation, Inheritance, Intro, Tutorial +@section Class definition and instantiation + +@menu +* Class definition:: +@end menu + +@node Class definition, , Class definition and instantiation, Class definition and instantiation +@subsection Class definition + +A new class is defined with the @code{define-class}@footnote{Don't +forget to import the @code{(oop goops)} module} macro. The syntax of +@code{define-class} is close to CLOS @code{defclass}: + +@findex define-class +@cindex class +@lisp +(define-class @var{class} (@var{superclass} @dots{}) + @var{slot-description} @dots{} + @var{class-option} @dots{}) +@end lisp + +Class options will not be discussed in this tutorial. The list of +@var{superclass}es specifies which classes to inherit properties from +@var{class} (see @ref{Inheritance} for more details). A +@var{slot-description} gives the name of a slot and, eventually, some +``properties'' of this slot (such as its initial value, the function +which permit to access its value, @dots{}). Slot descriptions will be +discussed in @ref{Slot description}. +@cindex slot + +As an example, let us define a type for representation of complex +numbers in terms of real numbers. This can be done with the following +class definition: + +@lisp +(define-class () + r i) +@end lisp + +This binds the variable @code{}@footnote{@code{} is in +fact a builtin class in GOOPS. Because of this, GOOPS will create a new +class. The old class will still serve as the type for Guile's native +complex numbers.} to a new class whose instances contain two +slots. These slots are called @code{r} an @code{i} and we suppose here +that they contain respectively the real part and the imaginary part of a +complex number. Note that this class inherits from @code{} which +is a pre-defined class. (@code{} is the direct super class of +the pre-defined class @code{} which, in turn, is the super +class of @code{} which is the super of +@code{}.)@footnote{With the new definition of @code{}, +a @code{} is not a @code{} since @code{} inherits +from @code{ } rather than @code{}. In practice, +inheritance could be modified @emph{a posteriori}, if needed. However, +this necessitates some knowledge of the meta object protocol and it will +not be shown in this document}. + +@node Inheritance, Generic functions, Class definition and instantiation, Tutorial +@section Inheritance +@c \label{inheritance} + +@menu +* Class hierarchy and inheritance of slots:: +* Instance creation and slot access:: +* Slot description:: +* Class precedence list:: +@end menu + +@node Class hierarchy and inheritance of slots, Instance creation and slot access, Inheritance, Inheritance +@subsection Class hierarchy and inheritance of slots +Inheritance is specified upon class definition. As said in the +introduction, @goops{} supports multiple inheritance. Here are some +class definitions: + +@lisp +(define-class A () a) +(define-class B () b) +(define-class C () c) +(define-class D (A B) d a) +(define-class E (A C) e c) +(define-class F (D E) f) +@end lisp + +@code{A}, @code{B}, @code{C} have a null list of super classes. In this +case, the system will replace it by the list which only contains +@code{}, the root of all the classes defined by +@code{define-class}. @code{D}, @code{E}, @code{F} use multiple +inheritance: each class inherits from two previously defined classes. +Those class definitions define a hierarchy which is shown in Figure@ 1. +In this figure, the class @code{} is also shown; this class is the +super class of all Scheme objects. In particular, @code{} is the +super class of all standard Scheme types. + +@example +@group +@image{hierarchy} +@center @emph{Fig 1: A class hierarchy} +@iftex +@emph{(@code{} which is the direct subclass of @code{} +and the direct superclass of @code{} has been omitted in this +figure.)} +@end iftex +@end group +@end example + +The set of slots of a given class is calculated by taking the union of the +slots of all its super class. For instance, each instance of the class +D, defined before will have three slots (@code{a}, @code{b} and +@code{d}). The slots of a class can be obtained by the @code{class-slots} +primitive. For instance, + +@lisp +(class-slots A) @result{} ((a)) +(class-slots E) @result{} ((a) (e) (c)) +(class-slots F) @result{} ((e) (c) (b) (d) (a) (f)) +@c used to be ((d) (a) (b) (c) (f)) +@end lisp + +@emph{Note: } The order of slots is not significant. + +@node Instance creation and slot access, Slot description, Class hierarchy and inheritance of slots, Inheritance +@subsection Instance creation and slot access + +Creation of an instance of a previously defined +class can be done with the @code{make} procedure. This +procedure takes one mandatory parameter which is the class of the +instance which must be created and a list of optional +arguments. Optional arguments are generally used to initialize some +slots of the newly created instance. For instance, the following form + +@findex make +@cindex instance +@lisp +(define c (make )) +@end lisp + +will create a new @code{} object and will bind it to the @code{c} +Scheme variable. + +Accessing the slots of the new complex number can be done with the +@code{slot-ref} and the @code{slot-set!} primitives. @code{Slot-set!} +primitive permits to set the value of an object slot and @code{slot-ref} +permits to get its value. + +@findex slot-set! +@findex slot-ref +@lisp +@group +(slot-set! c 'r 10) +(slot-set! c 'i 3) +(slot-ref c 'r) @result{} 10 +(slot-ref c 'i) @result{} 3 +@end group +@end lisp + +Using the @code{describe} function is a simple way to see all the +slots of an object at one time: this function prints all the slots of an +object on the standard output. + +First load the module @code{(oop goops describe)}: + +@example +@code{(use-modules (oop goops describe))} +@end example + +The expression + +@smalllisp +(describe c) +@end smalllisp + +will now print the following information on the standard output: + +@lisp +#< 401d8638> is an instance of class +Slots are: + r = 10 + i = 3 +@end lisp + +@node Slot description, Class precedence list, Instance creation and slot access, Inheritance +@subsection Slot description +@c \label{slot-description} + +When specifying a slot, a set of options can be given to the +system. Each option is specified with a keyword. The list of authorized +keywords is given below: + +@cindex keyword +@itemize @bullet +@item +@code{#:init-value} permits to supply a default value for the slot. This +default value is obtained by evaluating the form given after the +@code{#:init-form} in the global environment, at class definition time. +@cindex default slot value +@findex #:init-value +@cindex top level environment + +@item +@code{#:init-thunk} permits to supply a thunk that will provide a +default value for the slot. The value is obtained by evaluating the +thunk a instance creation time. +@c CHECKME: in the global environment? +@findex default slot value +@findex #:init-thunk +@cindex top level environment + +@item +@code{#:init-keyword} permits to specify the keyword for initializing a +slot. The init-keyword may be provided during instance creation (i.e. in +the @code{make} optional parameter list). Specifying such a keyword +during instance initialization will supersede the default slot +initialization possibly given with @code{#:init-form}. +@findex #:init-keyword + +@item +@code{#:getter} permits to supply the name for the +slot getter. The name binding is done in the +environment of the @code{define-class} macro. +@findex #:getter +@cindex top level environment +@cindex getter + +@item +@code{#:setter} permits to supply the name for the +slot setter. The name binding is done in the +environment of the @code{define-class} macro. +@findex #:setter +@cindex top level environment +@cindex setter + +@item +@code{#:accessor} permits to supply the name for the +slot accessor. The name binding is done in the global +environment. An accessor permits to get and +set the value of a slot. Setting the value of a slot is done with the extended +version of @code{set!}. +@findex set! +@findex #:accessor +@cindex top level environment +@cindex accessor + +@item +@code{#:allocation} permits to specify how storage for +the slot is allocated. Three kinds of allocation are provided. +They are described below: + +@itemize @minus +@item +@code{#:instance} indicates that each instance gets its own storage for +the slot. This is the default. +@item +@code{#:class} indicates that there is one storage location used by all +the direct and indirect instances of the class. This permits to define a +kind of global variable which can be accessed only by (in)direct +instances of the class which defines this slot. +@item +@code{#:each-subclass} indicates that there is one storage location used +by all the direct instances of the class. In other words, if two classes +are not siblings in the class hierarchy, they will not see the same +value. +@item +@code{#:virtual} indicates that no storage will be allocated for this +slot. It is up to the user to define a getter and a setter function for +this slot. Those functions must be defined with the @code{#:slot-ref} +and @code{#:slot-set!} options. See the example below. +@findex #:slot-set! +@findex #:slot-ref +@findex #:virtual +@findex #:class +@findex #:each-subclass +@findex #:instance +@findex #:allocation +@end itemize +@end itemize + +To illustrate slot description, we shall redefine the @code{} class +seen before. A definition could be: + +@lisp +(define-class () + (r #:init-value 0 #:getter get-r #:setter set-r! #:init-keyword #:r) + (i #:init-value 0 #:getter get-i #:setter set-i! #:init-keyword #:i)) +@end lisp + +With this definition, the @code{r} and @code{i} slot are set to 0 by +default. Value of a slot can also be specified by calling @code{make} +with the @code{#:r} and @code{#:i} keywords. Furthermore, the generic +functions @code{get-r} and @code{set-r!} (resp. @code{get-i} and +@code{set-i!}) are automatically defined by the system to read and write +the @code{r} (resp. @code{i}) slot. + +@lisp +(define c1 (make #:r 1 #:i 2)) +(get-r c1) @result{} 1 +(set-r! c1 12) +(get-r c1) @result{} 12 +(define c2 (make #:r 2)) +(get-r c2) @result{} 2 +(get-i c2) @result{} 0 +@end lisp + +Accessors provide an uniform access for reading and writing an object +slot. Writing a slot is done with an extended form of @code{set!} +which is close to the Common Lisp @code{setf} macro. So, another +definition of the previous @code{} class, using the +@code{#:accessor} option, could be: + +@findex set! +@lisp +(define-class () + (r #:init-value 0 #:accessor real-part #:init-keyword #:r) + (i #:init-value 0 #:accessor imag-part #:init-keyword #:i)) +@end lisp + +Using this class definition, reading the real part of the @code{c} +complex can be done with: +@lisp +(real-part c) +@end lisp +and setting it to the value contained in the @code{new-value} variable +can be done using the extended form of @code{set!}. +@lisp +(set! (real-part c) new-value) +@end lisp + +Suppose now that we have to manipulate complex numbers with rectangular +coordinates as well as with polar coordinates. One solution could be to +have a definition of complex numbers which uses one particular +representation and some conversion functions to pass from one +representation to the other. A better solution uses virtual slots. A +complete definition of the @code{} class using virtual slots is +given in Figure@ 2. + +@example +@group +@lisp +(define-class () + ;; True slots use rectangular coordinates + (r #:init-value 0 #:accessor real-part #:init-keyword #:r) + (i #:init-value 0 #:accessor imag-part #:init-keyword #:i) + ;; Virtual slots access do the conversion + (m #:accessor magnitude #:init-keyword #:magn + #:allocation #:virtual + #:slot-ref (lambda (o) + (let ((r (slot-ref o 'r)) (i (slot-ref o 'i))) + (sqrt (+ (* r r) (* i i))))) + #:slot-set! (lambda (o m) + (let ((a (slot-ref o 'a))) + (slot-set! o 'r (* m (cos a))) + (slot-set! o 'i (* m (sin a)))))) + (a #:accessor angle #:init-keyword #:angle + #:allocation #:virtual + #:slot-ref (lambda (o) + (atan (slot-ref o 'i) (slot-ref o 'r))) + #:slot-set! (lambda(o a) + (let ((m (slot-ref o 'm))) + (slot-set! o 'r (* m (cos a))) + (slot-set! o 'i (* m (sin a))))))) + +@end lisp +@center @emph{Fig 2: A @code{} number class definition using virtual slots} +@end group +@end example + +@sp 3 +This class definition implements two real slots (@code{r} and +@code{i}). Values of the @code{m} and @code{a} virtual slots are +calculated from real slot values. Reading a virtual slot leads to the +application of the function defined in the @code{#:slot-ref} +option. Writing such a slot leads to the application of the function +defined in the @code{#:slot-set!} option. For instance, the following +expression + +@findex #:slot-set! +@findex #:slot-ref +@lisp +(slot-set! c 'a 3) +@end lisp + +permits to set the angle of the @code{c} complex number. This expression +conducts, in fact, to the evaluation of the following expression + +@lisp +((lambda o m) + (let ((m (slot-ref o 'm))) + (slot-set! o 'r (* m (cos a))) + (slot-set! o 'i (* m (sin a)))) + c 3) +@end lisp + +A more complete example is given below: + +@example +@group +@lisp +(define c (make #:r 12 #:i 20)) +(real-part c) @result{} 12 +(angle c) @result{} 1.03037682652431 +(slot-set! c 'i 10) +(set! (real-part c) 1) +(describe c) @result{} + #< 401e9b58> is an instance of class + Slots are: + r = 1 + i = 10 + m = 10.0498756211209 + a = 1.47112767430373 +@end lisp +@end group +@end example + +Since initialization keywords have been defined for the four slots, we +can now define the @code{make-rectangular} and @code{make-polar} standard +Scheme primitives. + +@lisp +(define make-rectangular + (lambda (x y) (make #:r x #:i y))) + +(define make-polar + (lambda (x y) (make #:magn x #:angle y))) +@end lisp + +@node Class precedence list, , Slot description, Inheritance +@subsection Class precedence list + +A class may have more than one superclass. @footnote{This section is an +adaptation of Jeff Dalton's (J.Dalton@@ed.ac.uk) @cite{Brief +introduction to CLOS}} With single inheritance (one superclass), it is +easy to order the super classes from most to least specific. This is the +rule: + +@display +@cartouche +Rule 1: Each class is more specific than its superclasses.@c was \bf +@end cartouche +@end display + +With multiple inheritance, ordering is harder. Suppose we have + +@lisp +(define-class X () + (x #:init-value 1)) + +(define-class Y () + (x #:init-value 2)) + +(define-class Z (X Y) + (@dots{})) +@end lisp + +In this case, the @code{Z} class is more specific than the @code{X} or +@code{Y} class for instances of @code{Z}. However, the @code{#:init-value} +specified in @code{X} and @code{Y} leads to a problem: which one +overrides the other? The rule in @goops{}, as in CLOS, is that the +superclasses listed earlier are more specific than those listed later. +So: + +@display +@cartouche +Rule 2: For a given class, superclasses listed earlier are more + specific than those listed later. +@end cartouche +@end display + +These rules are used to compute a linear order for a class and all its +superclasses, from most specific to least specific. This order is +called the ``class precedence list'' of the class. Given these two +rules, we can claim that the initial form for the @code{x} slot of +previous example is 1 since the class @code{X} is placed before @code{Y} +in class precedence list of @code{Z}. + +These two rules are not always enough to determine a unique order, +however, but they give an idea of how things work. Taking the @code{F} +class shown in Figure@ 1, the class precedence list is + +@example +(f d e a c b ) +@end example + +However, it is usually considered a bad idea for programmers to rely on +exactly what the order is. If the order for some superclasses is important, +it can be expressed directly in the class definition. + +The precedence list of a class can be obtained by the function +@code{class-precedence-list}. This function returns a ordered +list whose first element is the most specific class. For instance, + +@lisp +(class-precedence-list B) @result{} (#< B 401b97c8> + #< 401e4a10> + #< 4026a9d8>) +@end lisp + +However, this result is not too much readable; using the function +@code{class-name} yields a clearer result: + +@lisp +(map class-name (class-precedence-list B)) @result{} (B ) +@end lisp + +@node Generic functions, , Inheritance, Tutorial +@section Generic functions + +@menu +* Generic functions and methods:: +* Next-method:: +* Example:: +@end menu + +@node Generic functions and methods, Next-method, Generic functions, Generic functions +@subsection Generic functions and methods + +@c \label{gf-n-methods} +Neither @goops{} nor CLOS use the message mechanism for methods as most +Object Oriented language do. Instead, they use the notion of +@dfn{generic functions}. A generic function can be seen as a methods +``tanker''. When the evaluator requested the application of a generic +function, all the methods of this generic function will be grabbed and +the most specific among them will be applied. We say that a method +@var{M} is @emph{more specific} than a method @var{M'} if the class of +its parameters are more specific than the @var{M'} ones. To be more +precise, when a generic function must be ``called'' the system will: + +@cindex generic function +@enumerate +@item +search among all the generic function those which are applicable +@item +sort the list of applicable methods in the ``most specific'' order +@item +call the most specific method of this list (i.e. the first method of +the sorted methods list). +@end enumerate + +The definition of a generic function is done with the +@code{define-generic} macro. Definition of a new method is done with the +@code{define-method} macro. Note that @code{define-method} automatically +defines the generic function if it has not been defined +before. Consequently, most of the time, the @code{define-generic} needs +not be used. +@findex define-generic +@findex define-method +Consider the following definitions: + +@lisp +(define-generic G) +(define-method (G (a ) b) 'integer) +(define-method (G (a ) b) 'real) +(define-method (G a b) 'top) +@end lisp + +The @code{define-generic} call defines @var{G} as a generic +function. Note that the signature of the generic function is not given +upon definition, contrarily to CLOS. This will permit methods with +different signatures for a given generic function, as we shall see +later. The three next lines define methods for the @var{G} generic +function. Each method uses a sequence of @dfn{parameter specializers} +that specify when the given method is applicable. A specializer permits +to indicate the class a parameter must belong to (directly or +indirectly) to be applicable. If no specializer is given, the system +defaults it to @code{}. Thus, the first method definition is +equivalent to + +@cindex parameter specializers +@lisp +(define-method (G (a ) (b )) 'integer) +@end lisp + +Now, let us look at some possible calls to generic function @var{G}: + +@lisp +(G 2 3) @result{} integer +(G 2 #t) @result{} integer +(G 1.2 'a) @result{} real +@c (G #3 'a) @result{} real @c was {\sharpsign} +(G #t #f) @result{} top +(G 1 2 3) @result{} error (since no method exists for 3 parameters) +@end lisp + +The preceding methods use only one specializer per parameter list. Of +course, each parameter can use a specializer. In this case, the +parameter list is scanned from left to right to determine the +applicability of a method. Suppose we declare now + +@lisp +(define-method (G (a ) (b )) 'integer-number) +(define-method (G (a ) (b )) 'integer-real) +(define-method (G (a ) (b )) 'integer-integer) +(define-method (G a (b )) 'top-number) +@end lisp + +In this case, + +@lisp +(G 1 2) @result{} integer-integer +(G 1 1.0) @result{} integer-real +(G 1 #t) @result{} integer +(G 'a 1) @result{} top-number +@end lisp + +@node Next-method, Example, Generic functions and methods, Generic functions +@subsection Next-method + +When a generic function is called, the list of applicable methods is +built. As mentioned before, the most specific method of this list is +applied (see@ @ref{Generic functions and methods}). This method may call +the next method in the list of applicable methods. This is done by using +the special form @code{next-method}. Consider the following definitions + +@lisp +(define-method (Test (a )) (cons 'integer (next-method))) +(define-method (Test (a )) (cons 'number (next-method))) +(define-method (Test a) (list 'top)) +@end lisp + +With those definitions, + +@lisp +(Test 1) @result{} (integer number top) +(Test 1.0) @result{} (number top) +(Test #t) @result{} (top) +@end lisp + +@node Example, , Next-method, Generic functions +@subsection Example + +In this section we shall continue to define operations on the @code{} +class defined in Figure@ 2. Suppose that we want to use it to implement +complex numbers completely. For instance a definition for the addition of +two complexes could be + +@lisp +(define-method (new-+ (a ) (b )) + (make-rectangular (+ (real-part a) (real-part b)) + (+ (imag-part a) (imag-part b)))) +@end lisp + +To be sure that the @code{+} used in the method @code{new-+} is the standard +addition we can do: + +@lisp +(define-generic new-+) + +(let ((+ +)) + (define-method (new-+ (a ) (b )) + (make-rectangular (+ (real-part a) (real-part b)) + (+ (imag-part a) (imag-part b))))) +@end lisp + +The @code{define-generic} ensures here that @code{new-+} will be defined +in the global environment. Once this is done, we can add methods to the +generic function @code{new-+} which make a closure on the @code{+} +symbol. A complete writing of the @code{new-+} methods is shown in +Figure@ 3. + +@example +@group +@lisp +(define-generic new-+) + +(let ((+ +)) + + (define-method (new-+ (a ) (b )) (+ a b)) + + (define-method (new-+ (a ) (b )) + (make-rectangular (+ a (real-part b)) (imag-part b))) + + (define-method (new-+ (a ) (b )) + (make-rectangular (+ (real-part a) b) (imag-part a))) + + (define-method (new-+ (a ) (b )) + (make-rectangular (+ (real-part a) (real-part b)) + (+ (imag-part a) (imag-part b)))) + + (define-method (new-+ (a )) a) + + (define-method (new-+) 0) + + (define-method (new-+ . args) + (new-+ (car args) + (apply new-+ (cdr args))))) + +(set! + new-+) +@end lisp + +@center @emph{Fig 3: Extending @code{+} for dealing with complex numbers} +@end group +@end example + +@sp 3 +We use here the fact that generic function are not obliged to have the +same number of parameters, contrarily to CLOS. The four first methods +implement the dyadic addition. The fifth method says that the addition +of a single element is this element itself. The sixth method says that +using the addition with no parameter always return 0. The last method +takes an arbitrary number of parameters@footnote{The parameter list for +a @code{define-method} follows the conventions used for Scheme +procedures. In particular it can use the dot notation or a symbol to +denote an arbitrary number of parameters}. This method acts as a kind +of @code{reduce}: it calls the dyadic addition on the @emph{car} of the +list and on the result of applying it on its rest. To finish, the +@code{set!} permits to redefine the @code{+} symbol to our extended +addition. + +@sp 3 +To terminate our implementation (integration?) of complex numbers, we can +redefine standard Scheme predicates in the following manner: + +@lisp +(define-method (complex? c ) #t) +(define-method (complex? c) #f) + +(define-method (number? n ) #t) +(define-method (number? n) #f) +@dots{} +@dots{} +@end lisp + +Standard primitives in which complex numbers are involved could also be +redefined in the same manner. + diff --git a/doc/goops/goops.texi b/doc/goops/goops.texi new file mode 100644 index 000000000..ac08a2625 --- /dev/null +++ b/doc/goops/goops.texi @@ -0,0 +1,2788 @@ +\input texinfo +@c -*-texinfo-*- +@c %**start of header +@setfilename goops.info +@settitle Goops Manual +@set goops +@setchapternewpage odd +@paragraphindent 0 +@c %**end of header + +@set VERSION 0.3 + +@dircategory The Algorithmic Language Scheme +@direntry +* GOOPS: (goops). The GOOPS reference manual. +@end direntry + +@macro goops +GOOPS +@end macro + +@macro guile +Guile +@end macro + +@ifinfo +This file documents GOOPS, an object oriented extension for Guile. + +Copyright (C) 1999, 2000, 2001 Free Software Foundation + +Permission is granted to make and distribute verbatim copies of +this manual provided the copyright notice and this permission notice +are preserved on all copies. + +@end ifinfo + +@c This title page illustrates only one of the +@c two methods of forming a title page. + +@titlepage +@title Goops Manual +@subtitle For use with GOOPS @value{VERSION} +@include AUTHORS + +@c The following two commands +@c start the copyright page. +@page +@vskip 0pt plus 1filll +Copyright @copyright{} 1999 Free Software Foundation + +Permission is granted to make and distribute verbatim copies of +this manual provided the copyright notice and this permission notice +are preserved on all copies. + +@end titlepage + +@node Top, Introduction, (dir), (dir) + +@menu +[When the manual is completed, this will be a flat index in the style of + the Emacs manual. More nodes will turn up under parts I-III.] + +Part I: Preliminaries + +* Introduction:: +* Getting Started:: + +Part II: Reference Manual + +* Reference Manual:: + +Part III: GOOPS Meta Object Protocol + +* MOP Specification:: + +The GOOPS tutorial + +* Tutorial:: + +* Index:: +* Concept Index:: +* Function and Variable Index:: +@end menu + +@iftex +@chapter Preliminaries +@end iftex + +@node Introduction, Getting Started, Top, Top +@section Introduction + +@goops{} is the object oriented extension to @guile{}. Its +implementation is derived from @w{STk-3.99.3} by Erick Gallesio and +version 1.3 of Gregor Kiczales @cite{Tiny-Clos}. It is very close in +spirit to CLOS, the Common Lisp Object System (@cite{CLtL2}) but is +adapted for the Scheme language. While GOOPS is not compatible with any +of these systems, GOOPS contains a compatibility module which allows for +execution of STKlos programs. + +Briefly stated, the @goops{} extension gives the user a full object +oriented system with multiple inheritance and generic functions with +multi-method dispatch. Furthermore, the implementation relies on a true +meta object protocol, in the spirit of the one defined for CLOS +(@cite{Gregor Kiczales: A Metaobject Protocol}). + +@node Getting Started, Reference Manual, Introduction, Top +@section Getting Started + +@menu +* Running GOOPS:: + +Examples of some basic GOOPS functionality. + +* Methods:: +* User-defined types:: +* Asking for the type of an object:: + +See further in the GOOPS tutorial available in this distribution in +info (goops.info) and texinfo format. +@end menu + +@node Running GOOPS, Methods, Getting Started, Getting Started +@subsection Running GOOPS + +@enumerate +@item +Type + +@smalllisp +guile-oops +@end smalllisp + +You should now be at the Guile prompt ("guile> "). + +@item +Type + +@smalllisp +(use-modules (oop goops)) +@end smalllisp + +to load GOOPS. (If your system supports dynamic loading, you +should be able to do this not only from `guile-oops' but from an +arbitrary Guile interpreter.) +@end enumerate + +We're now ready to try some basic GOOPS functionality. + +@node Methods, User-defined types, Running GOOPS, Getting Started +@subsection Methods + +@smalllisp +@group +(define-method (+ (x ) (y )) + (string-append x y)) + +(+ 1 2) --> 3 +(+ "abc" "de") --> "abcde" +@end group +@end smalllisp + +@node User-defined types, Asking for the type of an object, Methods, Getting Started +@subsection User-defined types + +@smalllisp +(define-class <2D-vector> () + (x #:init-value 0 #:accessor x-component #:init-keyword #:x) + (y #:init-value 0 #:accessor y-component #:init-keyword #:y)) + +@group +(use-modules (ice-9 format)) + +(define-method (write (obj <2D-vector>) port) + (display (format #f "<~S, ~S>" (x-component obj) (y-component obj)) + port)) + +(define v (make <2D-vector> #:x 3 #:y 4)) + +v --> <3, 4> +@end group + +@group +(define-method (+ (x <2D-vector>) (y <2D-vector>)) + (make <2D-vector> + #:x (+ (x-component x) (x-component y)) + #:y (+ (y-component x) (y-component y)))) + +(+ v v) --> <6, 8> +@end group +@end smalllisp + +@node Asking for the type of an object, , User-defined types, Getting Started +@subsection Types + +@example +(class-of v) --> #< <2D-vector> 40241ac0> +<2D-vector> --> #< <2D-vector> 40241ac0> +(class-of 1) --> #< 401b2a98> + --> #< 401b2a98> + +(is-a? v <2D-vector>) --> #t +@end example + +@node Reference Manual, MOP Specification, Getting Started, Top +@chapter Reference Manual + +This chapter is the GOOPS reference manual. It aims to describe all the +syntax, procedures, options and associated concepts that a typical +application author would need to understand in order to use GOOPS +effectively in their application. It also describes what is meant by +the GOOPS ``metaobject protocol'' (aka ``MOP''), and indicates how +authors can use the metaobject protocol to customize the behaviour of +GOOPS itself. + +For a detailed specification of the GOOPS metaobject protocol, see +@ref{MOP Specification}. + +@menu +* Introductory Remarks:: +* Defining New Classes:: +* Creating Instances:: +* Accessing Slots:: +* Creating Generic Functions:: +* Adding Methods to Generic Functions:: +* Invoking Generic Functions:: +* Redefining a Class:: +* Changing the Class of an Instance:: +* Introspection:: +* Miscellaneous Functions:: +@end menu + +@node Introductory Remarks +@section Introductory Remarks + +GOOPS is an object-oriented programming system based on a ``metaobject +protocol'' derived from the ones used in CLOS (the Common Lisp Object +System), tiny-clos (a small Scheme implementation of a subset of CLOS +functionality) and STKlos. + +GOOPS can be used by application authors at a basic level without any +need to understand what the metaobject protocol (aka ``MOP'') is and how +it works. On the other hand, the MOP underlies even the customizations +that application authors are likely to make use of very quickly --- such +as defining an @code{initialize} method to customize the initialization +of instances of an application-defined class --- and an understanding of +the MOP makes it much easier to explain such customizations in a precise +way. And in the long run, understanding the MOP is the key both to +understanding GOOPS at a deeper level and to taking full advantage of +GOOPS' power, by customizing the behaviour of GOOPS itself. + +Each of the following sections of the reference manual is arranged +such that the most basic usage is introduced first, and then subsequent +subsections discuss the related internal functions and metaobject +protocols, finishing with a description of how to customize that area of +functionality. + +These introductory remarks continue with a few words about metaobjects +and the MOP. Readers who do not want to be bothered yet with the MOP +and customization could safely skip this subsection on a first reading, +and should correspondingly skip subsequent subsections that are +concerned with internals and customization. + +In general, this reference manual assumes familiarity with standard +object oriented concepts and terminology. However, some of the terms +used in GOOPS is less well known, so the Terminology subsection +provides definitions for these terms. + +@menu +* Metaobjects and the Metaobject Protocol:: +* Terminology:: +@end menu + +@node Metaobjects and the Metaobject Protocol +@subsection Metaobjects and the Metaobject Protocol + +The conceptual building blocks of GOOPS are classes, slot definitions, +instances, generic functions and methods. A class is a grouping of +inheritance relations and slot definitions. An instance is an object +with slots that are allocated following the rules implied by its class's +superclasses and slot definitions. A generic function is a collection +of methods and rules for determining which of those methods to apply +when the generic function is invoked. A method is a procedure and a set +of specializers that specify the type of arguments to which the +procedure is applicable. + +Of these entities, GOOPS represents classes, generic functions and +methods as ``metaobjects''. In other words, the values in a GOOPS +program that describe classes, generic functions and methods, are +themselves instances (or ``objects'') of special GOOPS classes that +encapsulate the behaviour, respectively, of classes, generic functions, +and methods. + +(The other two entities are slot definitions and instances. Slot +definitions are not strictly instances, but every slot definition is +associated with a GOOPS class that specifies the behaviour of the slot +as regards accessibility and protection from garbage collection. +Instances are of course objects in the usual sense, and there is no +benefit from thinking of them as metaobjects.) + +The ``metaobject protocol'' (aka ``MOP'') is the specification of the +generic functions which determine the behaviour of these metaobjects and +the circumstances in which these generic functions are invoked. + +For a concrete example of what this means, consider how GOOPS calculates +the set of slots for a class that is being defined using +@code{define-class}. The desired set of slots is the union of the new +class's direct slots and the slots of all its superclasses. But +@code{define-class} itself does not perform this calculation. Instead, +there is a method of the @code{initialize} generic function that is +specialized for instances of type @code{}, and it is this method +that performs the slot calculation. + +@code{initialize} is a generic function which GOOPS calls whenever a new +instance is created, immediately after allocating memory for a new +instance, in order to initialize the new instance's slots. The sequence +of steps is as follows. + +@itemize @bullet +@item +@code{define-class} uses @code{make} to make a new instance of the +@code{}, passing as initialization arguments the superclasses, +slot definitions and class options that were specified in the +@code{define-class} form. + +@item +@code{make} allocates memory for the new instance, and then invokes the +@code{initialize} generic function to initialize the new instance's +slots. + +@item +The @code{initialize} generic function applies the method that is +specialized for instances of type @code{}, and this method +performs the slot calculation. +@end itemize + +In other words, rather than being hardcoded in @code{define-class}, the +behaviour of class definition is encapsulated by generic function +methods that are specialized for the class @code{}. + +It is possible to create a new class that inherits from @code{}, +which is called a ``metaclass'', and to write a new @code{initialize} +method that is specialized for instances of the new metaclass. Then, if +the @code{define-class} form includes a @code{#:metaclass} class option +whose value is the new metaclass, the class that is defined by the +@code{define-class} form will be an instance of the new metaclass rather +than of the default @code{}, and will be defined in accordance +with the new @code{initialize} method. Thus the default slot +calculation, as well as any other aspect of the new class's relationship +with its superclasses, can be modified or overridden. + +In a similar way, the behaviour of generic functions can be modified or +overridden by creating a new class that inherits from the standard +generic function class @code{}, writing appropriate methods +that are specialized to the new class, and creating new generic +functions that are instances of the new class. + +The same is true for method metaobjects. And the same basic mechanism +allows the application class author to write an @code{initialize} method +that is specialized to their application class, to initialize instances +of that class. + +Such is the power of the MOP. Note that @code{initialize} is just one +of a large number of generic functions that can be customized to modify +the behaviour of application objects and classes and of GOOPS itself. +Each subsequent section of the reference manual covers a particular area +of GOOPS functionality, and describes the generic functions that are +relevant for customization of that area. + +We conclude this subsection by emphasizing a point that may seem +obvious, but contrasts with the corresponding situation in some other +MOP implementations, such as CLOS. The point is simply that an +identifier which represents a GOOPS class or generic function is a +variable with a first-class value, the value being an instance of class +@code{} or @code{}. (In CLOS, on the other hand, a +class identifier is a symbol that indexes the corresponding class +metaobject in a separate namespace for classes.) This is, of course, +simply an extension of the tendency in Scheme to avoid the unnecessary +use of, on the one hand, syntactic forms that require unevaluated +arguments and, on the other, separate identifier namespaces (e.g. for +class names), but it is worth noting that GOOPS conforms fully to this +Schemely principle. + +@node Terminology +@subsection Terminology + +It is assumed that the reader is already familiar with standard object +orientation concepts such as classes, objects/instances, +inheritance/subclassing, generic functions and methods, encapsulation +and polymorphism. + +This section explains some of the less well known concepts and +terminology that GOOPS uses, which are assumed by the following sections +of the reference manual. + +@menu +* Metaclass:: +* Class Precedence List:: +* Accessor:: +@end menu + +@node Metaclass +@subsubsection Metaclass + +A @dfn{metaclass} is the class of an object which represents a GOOPS +class. Put more succinctly, a metaclass is a class's class. + +Most GOOPS classes have the metaclass @code{} and, by default, +any new class that is created using @code{define-class} has the +metaclass @code{}. + +But what does this really mean? To find out, let's look in more detail +at what happens when a new class is created using @code{define-class}: + +@example +(define-class () . slots) +@end example + +GOOPS actually expands the @code{define-class} form to something like +this + +@example +(define (class () . slots)) +@end example + +and thence to + +@example +(define + (make #:supers (list ) #:slots slots)) +@end example + +In other words, the value of @code{} is in fact an instance of +the class @code{} with slot values specifying the superclasses +and slot definitions for the class @code{}. (@code{#:supers} +and @code{#:slots} are initialization keywords for the @code{dsupers} +and @code{dslots} slots of the @code{} class.) + +In order to take advantage of the full power of the GOOPS metaobject +protocol (@pxref{MOP Specification}), it is sometimes desirable to +create a new class with a metaclass other than the default +@code{}. This is done by writing: + +@example +(define-class () + slot @dots{} + #:metaclass ) +@end example + +GOOPS expands this to something like: + +@example +(define + (make #:supers (list ) #:slots slots)) +@end example + +In this case, the value of @code{} is an instance of the more +specialized class @code{}. Note that +@code{} itself must previously have been defined as a +subclass of @code{}. For a full discussion of when and how it is +useful to define new metaclasses, see @ref{MOP Specification}. + +Now let's make an instance of @code{}: + +@example +(define my-object (make ...)) +@end example + +All of the following statements are correct expressions of the +relationships between @code{my-object}, @code{}, +@code{} and @code{}. + +@itemize @bullet +@item +@code{my-object} is an instance of the class @code{}. + +@item +@code{} is an instance of the class @code{}. + +@item +@code{} is an instance of the class @code{}. + +@item +The class of @code{my-object} is @code{}. + +@item +The metaclass of @code{my-object} is @code{}. + +@item +The class of @code{} is @code{}. + +@item +The metaclass of @code{} is @code{}. + +@item +The class of @code{} is @code{}. + +@item +The metaclass of @code{} is @code{}. + +@item +@code{} is not a metaclass, since it is does not inherit from +@code{}. + +@item +@code{} is a metaclass, since it inherits from +@code{}. +@end itemize + +@node Class Precedence List +@subsubsection Class Precedence List + +The @dfn{class precedence list} of a class is the list of all direct and +indirect superclasses of that class, including the class itself. + +In the absence of multiple inheritance, the class precedence list is +ordered straightforwardly, beginning with the class itself and ending +with @code{}. + +For example, given this inheritance hierarchy: + +@example +(define-class () @dots{}) +(define-class () @dots{}) +(define-class () @dots{}) +@end example + +the class precedence list of would be + +@example +( ) +@end example + +With multiple inheritance, the algorithm is a little more complicated. +A full description is provided by the GOOPS Tutorial: see @ref{Class +precedence list}. + +``Class precedence list'' is often abbreviated, in documentation and +Scheme variable names, to @dfn{cpl}. + +@node Accessor +@subsubsection Accessor + +An @dfn{accessor} is a generic function with both reference and setter +methods. + +@example +(define-accessor perimeter) +@end example + +Reference methods for an accessor are defined in the same way as generic +function methods. + +@example +(define-method (perimeter (s )) + (* 4 (side-length s))) +@end example + +Setter methods for an accessor are defined by specifying ``(setter +)'' as the first parameter of the @code{define-method} +call. + +@example +(define-method ((setter perimeter) (s ) (n )) + (set! (side-length s) (/ n 4))) +@end example + +Once an appropriate setter method has been defined in this way, it can +be invoked using the generalized @code{set!} syntax, as in: + +@example +(set! (perimeter s1) 18.3) +@end example + +@node Defining New Classes +@section Defining New Classes + +[ *fixme* Somewhere in this manual there needs to be an introductory +discussion about GOOPS classes, generic functions and methods, covering + +@itemize @bullet +@item +how classes encapsulate related items of data in @dfn{slots} + +@item +why it is that, unlike in C++ and Java, a class does not encapsulate the +methods that act upon the class (at least not in the C++/Java sense) + +@item +how generic functions provide a more general solution that provides for +dispatch on all argument types, and avoids idiosyncracies like C++'s +friend classes + +@item +how encapsulation in the sense of data- and code-hiding, or of +distinguishing interface from implementation, is treated in Guile as an +orthogonal concept to object orientation, and is the responsibility of +the module system. +@end itemize + +Some of this is covered in the Tutorial chapter, in @ref{Generic +functions and methods} - perhaps the best solution would be to expand +the discussion there. ] + +@menu +* Basic Class Definition:: +* Class Options:: +* Slot Options:: +* Class Definition Internals:: +* Customizing Class Definition:: +* STKlos Compatibility:: +@end menu + +@node Basic Class Definition +@subsection Basic Class Definition + +New classes are defined using the @code{define-class} syntax, with +arguments that specify the classes that the new class should inherit +from, the direct slots of the new class, and any required class options. + +@deffn syntax define-class name (super @dots{}) slot-definition @dots{} . options +Define a class called @var{name} that inherits from @var{super}s, with +direct slots defined by @var{slot-definition}s and class options +@var{options}. The newly created class is bound to the variable name +@var{name} in the current environment. + +Each @var{slot-definition} is either a symbol that names the slot or a +list, + +@example +(@var{slot-name-symbol} . @var{slot-options}) +@end example + +where @var{slot-name-symbol} is a symbol and @var{slot-options} is a +list with an even number of elements. The even-numbered elements of +@var{slot-options} (counting from zero) are slot option keywords; the +odd-numbered elements are the corresponding values for those keywords. + +@var{options} is a similarly structured list containing class option +keywords and corresponding values. +@end deffn + +The standard GOOPS class and slot options are described in the following +subsections: see @ref{Class Options} and @ref{Slot Options}. + +Example 1. Define a class that combines two pre-existing classes by +inheritance but adds no new slots. + +@example +(define-class ( )) +@end example + +Example 2. Define a @code{regular-polygon} class with slots for side +length and number of sides that have default values and can be accessed +via the generic functions @code{side-length} and @code{num-sides}. + +@example +(define-class () + (sl #:init-value 1 #:accessor side-length) + (ns #:init-value 5 #:accessor num-sides)) +@end example + +Example 3. Define a class whose behavior (and that of its instances) is +customized via an application-defined metaclass. + +@example +(define-class () + (s #:init-value #f #:accessor state) + ... + #:metaclass ) +@end example + +@node Class Options +@subsection Class Options + +@deffn {class option} #:metaclass metaclass +The @code{#:metaclass} class option specifies the metaclass of the class +being defined. @var{metaclass} must be a class that inherits from +@code{}. For an introduction to the use of metaclasses, see +@ref{Metaobjects and the Metaobject Protocol} and @ref{Metaclass}. + +If the @code{#:metaclass} option is absent, GOOPS reuses or constructs a +metaclass for the new class by calling @code{ensure-metaclass} +(@pxref{Class Definition Internals,, ensure-metaclass}). +@end deffn + +@deffn {class option} #:name name +The @code{#:name} class option specifies the new class's name. This +name is used to identify the class whenever related objects - the class +itself, its instances and its subclasses - are printed. + +If the @code{#:name} option is absent, GOOPS uses the first argument to +@code{define-class} as the class name. +@end deffn + +@deffn {class option} #:environment environment +*fixme* Not sure about this one, but I think that the +@code{#:environment} option specifies the environment in which the +class's getters and setters are computed and evaluated. + +If the @code{#:environment} option is not specified, the class's +environment defaults to the top-level environment in which the +@code{define-class} form appears. +@end deffn + +@node Slot Options +@subsection Slot Options + +@deffn {slot option} #:allocation allocation +The @code{#:allocation} option tells GOOPS how to allocate storage for +the slot. Possible values for @var{allocation} are + +@itemize @bullet +@item @code{#:instance} + +Indicates that GOOPS should create separate storage for this slot in +each new instance of the containing class (and its subclasses). + +@item @code{#:class} + +Indicates that GOOPS should create storage for this slot that is shared +by all instances of the containing class (and its subclasses). In other +words, a slot in class @var{C} with allocation @code{#:class} is shared +by all @var{instance}s for which @code{(is-a? @var{instance} @var{c})}. + +@item @code{#:each-subclass} + +Indicates that GOOPS should create storage for this slot that is shared +by all @emph{direct} instances of the containing class, and that +whenever a subclass of the containing class is defined, GOOPS should +create a new storage for the slot that is shared by all @emph{direct} +instances of the subclass. In other words, a slot with allocation +@code{#:each-subclass} is shared by all instances with the same +@code{class-of}. + +@item @code{#:virtual} + +Indicates that GOOPS should not allocate storage for this slot. The +slot definition must also include the @code{#:slot-ref} and +@code{#:slot-set!} options to specify how to reference and set the value +for this slot. +@end itemize + +The default value is @code{#:instance}. + +Slot allocation options are processed when defining a new class by the +generic function @code{compute-get-n-set}, which is specialized by the +class's metaclass. Hence new types of slot allocation can be +implemented by defining a new metaclass and a method for +@code{compute-get-n-set} that is specialized for the new metaclass. For +an example of how to do this, see @ref{Customizing Class Definition}. +@end deffn + +@deffn {slot option} #:slot-ref getter +@deffnx {slot option} #:slot-set! setter +The @code{#:slot-ref} and @code{#:slot-set!} options must be specified +if the slot allocation is @code{#:virtual}, and are ignored otherwise. + +@var{getter} should be a closure taking a single @var{instance} parameter +that returns the current slot value. @var{setter} should be a closure +taking two parameters - @var{instance} and @var{new-val} - that sets the +slot value to @var{new-val}. +@end deffn + +@deffn {slot option} #:getter getter +@deffnx {slot option} #:setter setter +@deffnx {slot option} #:accessor accessor +These options, if present, tell GOOPS to create generic function and +method definitions that can be used to get and set the slot value more +conveniently than by using @code{slot-ref} and @code{slot-set!}. + +@var{getter} specifies a generic function to which GOOPS will add a +method for getting the slot value. @var{setter} specifies a generic +function to which GOOPS will add a method for setting the slot value. +@var{accessor} specifies an accessor to which GOOPS will add methods for +both getting and setting the slot value. + +So if a class includes a slot definition like this: + +@example +(c #:getter get-count #:setter set-count #:accessor count) +@end example + +GOOPS defines generic function methods such that the slot value can be +referenced using either the getter or the accessor - + +@example +(let ((current-count (get-count obj))) @dots{}) +(let ((current-count (count obj))) @dots{}) +@end example + +- and set using either the setter or the accessor - + +@example +(set-count obj (+ 1 current-count)) +(set! (count obj) (+ 1 current-count)) +@end example + +Note that + +@itemize @bullet +@item +with an accessor, the slot value is set using the generalized +@code{set!} syntax + +@item +in practice, it is unusual for a slot to use all three of these options: +read-only, write-only and read-write slots would typically use only +@code{#:getter}, @code{#:setter} and @code{#:accessor} options +respectively. +@end itemize + +If the specified names are already bound in the top-level environment to +values that cannot be upgraded to generic functions, those values are +overwritten during evaluation of the @code{define-class} that contains +the slot definition. For details, see @ref{Generic Function Internals,, +ensure-generic}. +@end deffn + +@deffn {slot option} #:init-value init-value +@deffnx {slot option} #:init-form init-form +@deffnx {slot option} #:init-thunk init-thunk +@deffnx {slot option} #:init-keyword init-keyword +These options provide various ways to specify how to initialize the +slot's value at instance creation time. @var{init-value} is a fixed +value. @var{init-thunk} is a procedure of no arguments that is called +when a new instance is created and should return the desired initial +slot value. @var{init-form} is an unevaluated expression that gets +evaluated when a new instance is created and should return the desired +initial slot value. @var{init-keyword} is a keyword that can be used to +pass an initial slot value to @code{make} when creating a new instance. + +If more than one of these options is specified for the same slot, the +order of precedence, highest first is + +@itemize @bullet +@item +@code{#:init-keyword}, if @var{init-keyword} is present in the options +passed to @code{make} + +@item +@code{#:init-thunk}, @code{#:init-form} or @code{#:init-value}. +@end itemize + +If the slot definition contains more than one initialization option of +the same precedence, the later ones are ignored. If a slot is not +initialized at all, its value is unbound. + +In general, slots that are shared between more than one instance are +only initialized at new instance creation time if the slot value is +unbound at that time. However, if the new instance creation specifies +a valid init keyword and value for a shared slot, the slot is +re-initialized regardless of its previous value. + +Note, however, that the power of GOOPS' metaobject protocol means that +everything written here may be customized or overridden for particular +classes! The slot initializations described here are performed by the least +specialized method of the generic function @code{initialize}, whose +signature is + +@example +(define-method (initialize (object ) initargs) ...) +@end example + +The initialization of instances of any given class can be customized by +defining a @code{initialize} method that is specialized for that class, +and the author of the specialized method may decide to call +@code{next-method} - which will result in a call to the next less +specialized @code{initialize} method - at any point within the +specialized code, or maybe not at all. In general, therefore, the +initialization mechanisms described here may be modified or overridden by +more specialized code, or may not be supported at all for particular +classes. +@end deffn + +@node Class Definition Internals +@subsection Class Definition Internals + +Implementation notes: @code{define-class} expands to an expression which + +@itemize @bullet +@item +checks that it is being evaluated only at top level + +@item +defines any accessors that are implied by the @var{slot-definition}s + +@item +uses @code{class} to create the new class (@pxref{Class Definition +Internals,, class}) + +@item +checks for a previous class definition for @var{name} and, if found, +handles the redefinition by invoking @code{class-redefinition} +(@pxref{Redefining a Class}). +@end itemize + +@deffn syntax class name (super @dots{}) slot-definition @dots{} . options +Return a newly created class that inherits from @var{super}s, with +direct slots defined by @var{slot-definition}s and class options +@var{options}. For the format of @var{slot-definition}s and +@var{options}, see @ref{Basic Class Definition,, define-class}. +@end deffn + +Implementation notes: @code{class} expands to an expression which + +@itemize @bullet +@item +processes the class and slot definition options to check that they are +well-formed, to convert the @code{#:init-form} option to an +@code{#:init-thunk} option, to supply a default environment parameter +(the current top-level environment) and to evaluate all the bits that +need to be evaluated + +@item +calls @code{make-class} to create the class with the processed and +evaluated parameters. +@end itemize + +@deffn procedure make-class supers slots . options +Return a newly created class that inherits from @var{supers}, with +direct slots defined by @var{slots} and class options @var{options}. +For the format of @var{slots} and @var{options}, see @ref{Basic Class +Definition,, define-class}, except note that for @code{make-class}, +@var{slots} and @var{options} are separate list parameters: @var{slots} +here is a list of slot definitions. +@end deffn + +Implementation notes: @code{make-class} + +@itemize @bullet +@item +adds @code{} to the @var{supers} list if @var{supers} is empty +or if none of the classes in @var{supers} have @code{} in their +class precedence list + +@item +defaults the @code{#:environment}, @code{#:name} and @code{#:metaclass} +options, if they are not specified by @var{options}, to the current +top-level environment, the unbound value, and @code{(ensure-metaclass +@var{supers})} respectively (@pxref{Class Definition Internals,, +ensure-metaclass}) + +@item +checks for duplicate classes in @var{supers} and duplicate slot names in +@var{slots}, and signals an error if there are any duplicates + +@item +calls @code{make}, passing the metaclass as the first parameter and all +other parameters as option keywords with values. +@end itemize + +@deffn procedure ensure-metaclass supers env +Return a metaclass suitable for a class that inherits from the list of +classes in @var{supers}. The returned metaclass is the union by +inheritance of the metaclasses of the classes in @var{supers}. + +In the simplest case, where all the @var{supers} are straightforward +classes with metaclass @code{}, the returned metaclass is just +@code{}. + +For a more complex example, suppose that @var{supers} contained one +class with metaclass @code{} and one with metaclass +@code{}. Then the returned metaclass would be a +class that inherits from both @code{} and +@code{}. + +If @var{supers} is the empty list, @code{ensure-metaclass} returns the +default GOOPS metaclass @code{}. + +GOOPS keeps a list of the metaclasses created by +@code{ensure-metaclass}, so that each required type of metaclass only +has to be created once. + +The @code{env} parameter is ignored. +@end deffn + +@deffn procedure ensure-metaclass-with-supers meta-supers +@code{ensure-metaclass-with-supers} is an internal procedure used by +@code{ensure-metaclass} (@pxref{Class Definition Internals,, +ensure-metaclass}). It returns a metaclass that is the union by +inheritance of the metaclasses in @var{meta-supers}. +@end deffn + +The internals of @code{make}, which is ultimately used to create the new +class object, are described in @ref{Customizing Instance Creation}, +which covers the creation and initialization of instances in general. + +@node Customizing Class Definition +@subsection Customizing Class Definition + +During the initialization of a new class, GOOPS calls a number of generic +functions with the newly allocated class instance as the first +argument. Specifically, GOOPS calls the generic function + +@itemize @bullet +@item +(initialize @var{class} @dots{}) +@end itemize + +where @var{class} is the newly allocated class instance, and the default +@code{initialize} method for arguments of type @code{} calls the +generic functions + +@itemize @bullet +@item +(compute-cpl @var{class}) + +@item +(compute-slots @var{class}) + +@item +(compute-get-n-set @var{class} @var{slot-def}), for each of the slot +definitions returned by @code{compute-slots} + +@item +(compute-getter-method @var{class} @var{slot-def}), for each of the +slot definitions returned by @code{compute-slots} that includes a +@code{#:getter} or @code{#:accessor} slot option + +@item +(compute-setter-method @var{class} @var{slot-def}), for each of the +slot definitions returned by @code{compute-slots} that includes a +@code{#:setter} or @code{#:accessor} slot option. +@end itemize + +If the metaclass of the new class is something more specialized than the +default @code{}, then the type of @var{class} in the calls above +is more specialized than @code{}, and hence it becomes possible +to define generic function methods, specialized for the new class's +metaclass, that can modify or override the default behaviour of +@code{initialize}, @code{compute-cpl} or @code{compute-get-n-set}. + +@code{compute-cpl} computes the class precedence list (``CPL'') for the +new class (@pxref{Class precedence list}), and returns it as a list of +class objects. The CPL is important because it defines a superclass +ordering that is used, when a generic function is invoked upon an +instance of the class, to decide which of the available generic function +methods is the most specific. Hence @code{compute-cpl} could be +customized in order to modify the CPL ordering algorithm for all classes +with a special metaclass. + +The default CPL algorithm is encapsulated by the @code{compute-std-cpl} +procedure, which is in turn called by the default @code{compute-cpl} +method. + +@deffn procedure compute-std-cpl class +Compute and return the class precedence list for @var{class} according +to the algorithm described in @ref{Class precedence list}. +@end deffn + +@code{compute-slots} computes and returns a list of all slot definitions +for the new class. By default, this list includes the direct slot +definitions from the @code{define-class} form, plus the slot definitions +that are inherited from the new class's superclasses. The default +@code{compute-slots} method uses the CPL computed by @code{compute-cpl} +to calculate this union of slot definitions, with the rule that slots +inherited from superclasses are shadowed by direct slots with the same +name. One possible reason for customizing @code{compute-slots} would be +to implement an alternative resolution strategy for slot name conflicts. + +@code{compute-get-n-set} computes the low-level closures that will be +used to get and set the value of a particular slot, and returns them in +a list with two elements. + +The closures returned depend on how storage for that slot is allocated. +The standard @code{compute-get-n-set} method, specialized for classes of +type @code{}, handles the standard GOOPS values for the +@code{#:allocation} slot option (@pxref{Slot Options,, allocation}). By +defining a new @code{compute-get-n-set} method for a more specialized +metaclass, it is possible to support new types of slot allocation. + +Suppose you wanted to create a large number of instances of some class +with a slot that should be shared between some but not all instances of +that class - say every 10 instances should share the same slot storage. +The following example shows how to implement and use a new type of slot +allocation to do this. + +@example +(define-class ()) + +(let ((batch-allocation-count 0) + (batch-get-n-set #f)) + (define-method (compute-get-n-set (class ) s) + (case (slot-definition-allocation s) + ((#:batched) + ;; If we've already used the same slot storage for 10 instances, + ;; reset variables. + (if (= batch-allocation-count 10) + (begin + (set! batch-allocation-count 0) + (set! batch-get-n-set #f))) + ;; If we don't have a current pair of get and set closures, + ;; create one. make-closure-variable returns a pair of closures + ;; around a single Scheme variable - see goops.scm for details. + (or batch-get-n-set + (set! batch-get-n-set (make-closure-variable))) + ;; Increment the batch allocation count. + (set! batch-allocation-count (+ batch-allocation-count 1)) + batch-get-n-set) + + ;; Call next-method to handle standard allocation types. + (else (next-method))))) + +(define-class () + ... + (c #:allocation #:batched) + ... + #:metaclass ) +@end example + +The usage of @code{compute-getter-method} and @code{compute-setter-method} +is described in @ref{MOP Specification}. + +@code{compute-cpl} and @code{compute-get-n-set} are called by the +standard @code{initialize} method for classes whose metaclass is +@code{}. But @code{initialize} itself can also be modified, by +defining an @code{initialize} method specialized to the new class's +metaclass. Such a method could complete override the standard +behaviour, by not calling @code{(next-method)} at all, but more +typically it would perform additional class initialization steps before +and/or after calling @code{(next-method)} for the standard behaviour. + +@node STKlos Compatibility +@subsection STKlos Compatibility + +If the STKlos compatibility module is loaded, @code{define-class} is +overwritten by a STKlos-specific definition; the standard GOOPS +definition of @code{define-class} remains available in +@code{standard-define-class}. + +@deffn syntax standard-define-class name (super @dots{}) slot-definition @dots{} . options +@code{standard-define-class} is equivalent to the standard GOOPS +@code{define-class}. +@end deffn + +@node Creating Instances +@section Creating Instances + +@menu +* Basic Instance Creation:: +* Customizing Instance Creation:: +@end menu + +@node Basic Instance Creation +@subsection Basic Instance Creation + +To create a new instance of any GOOPS class, use the generic function +@code{make} or @code{make-instance}, passing the required class and any +appropriate instance initialization arguments as keyword and value +pairs. Note that @code{make} and @code{make-instances} are aliases for +each other - their behaviour is identical. + +@deffn generic make +@deffnx method make (class ) . initargs +Create and return a new instance of class @var{class}, initialized using +@var{initargs}. + +In theory, @var{initargs} can have any structure that is understood by +whatever methods get applied when the @code{initialize} generic function +is applied to the newly allocated instance. + +In practice, specialized @code{initialize} methods would normally call +@code{(next-method)}, and so eventually the standard GOOPS +@code{initialize} methods are applied. These methods expect +@var{initargs} to be a list with an even number of elements, where +even-numbered elements (counting from zero) are keywords and +odd-numbered elements are the corresponding values. + +GOOPS processes initialization argument keywords automatically for slots +whose definition includes the @code{#:init-keyword} option (@pxref{Slot +Options,, init-keyword}). Other keyword value pairs can only be +processed by an @code{initialize} method that is specialized for the new +instance's class. Any unprocessed keyword value pairs are ignored. +@end deffn + +@deffn generic make-instance +@deffnx method make-instance (class ) . initargs +@code{make-instance} is an alias for @code{make}. +@end deffn + +@node Customizing Instance Creation +@subsection Customizing Instance Creation + +@code{make} itself is a generic function. Hence the @code{make} +invocation itself can be customized in the case where the new instance's +metaclass is more specialized than the default @code{}, by +defining a @code{make} method that is specialized to that metaclass. + +Normally, however, the method for classes with metaclass @code{} +will be applied. This method calls two generic functions: + +@itemize @bullet +@item +(allocate-instance @var{class} . @var{initargs}) + +@item +(initialize @var{instance} . @var{initargs}) +@end itemize + +@code{allocate-instance} allocates storage for and returns the new +instance, uninitialized. You might customize @code{allocate-instance}, +for example, if you wanted to provide a GOOPS wrapper around some other +object programming system. + +To do this, you would create a specialized metaclass, which would act as +the metaclass for all classes and instances from the other system. Then +define an @code{allocate-instance} method, specialized to that +metaclass, which calls a Guile primitive C function, which in turn +allocates the new instance using the interface of the other object +system. + +In this case, for a complete system, you would also need to customize a +number of other generic functions like @code{make} and +@code{initialize}, so that GOOPS knows how to make classes from the +other system, access instance slots, and so on. + +@code{initialize} initializes the instance that is returned by +@code{allocate-instance}. The standard GOOPS methods perform +initializations appropriate to the instance class. + +@itemize @bullet +@item +At the least specialized level, the method for instances of type +@code{} performs internal GOOPS instance initialization, and +initializes the instance's slots according to the slot definitions and +any slot initialization keywords that appear in @var{initargs}. + +@item +The method for instances of type @code{} calls +@code{(next-method)}, then performs the class initializations described +in @ref{Customizing Class Definition}. + +@item +and so on for generic functions, method, operator classes @dots{} +@end itemize + +Similarly, you can customize the initialization of instances of any +application-defined class by defining an @code{initialize} method +specialized to that class. + +Imagine a class whose instances' slots need to be initialized at +instance creation time by querying a database. Although it might be +possible to achieve this a combination of @code{#:init-thunk} keywords +and closures in the slot definitions, it is neater to write an +@code{initialize} method for the class that queries the database once +and initializes all the dependent slot values according to the results. + +@node Accessing Slots +@section Accessing Slots + +The definition of a slot contains at the very least a slot name, and may +also contain various slot options, including getter, setter and/or +accessor functions for the slot. + +It is always possible to access slots by name, using the various +``slot-ref'' and ``slot-set!'' procedures described in the following +subsections. For example, + +@example +(define-class () ;; Define a class with slots + (count #:init-value 0) ;; named "count" and "cache". + (cache #:init-value '()) + @dots{}) + +(define inst (make )) ;; Make an instance of this class. + +(slot-set! inst 'count 5) ;; Set the value of the "count" + ;; slot to 5. + +(slot-set! inst 'cache ;; Modify the value of the + (cons (cons "^it" "It") ;; "cache" slot. + (slot-ref inst 'cache))) +@end example + +If a slot definition includes a getter, setter or accessor function, +these can be used instead of @code{slot-ref} and @code{slot-set!} to +access the slot. + +@example +(define-class () ;; Define a new class whose slots + (count #:setter set-count) ;; use a getter, a setter and + (cache #:accessor cache) ;; an accessor. + (csize #:getter cache-size) + @dots{}) + +(define inst (make )) ;; Make an instance of this class. + +(set-count inst 5) ;; Set the value of the "count" + ;; slot to 5. + +(set! (cache inst) ;; Modify the value of the + (cons (cons "^it" "It") ;; "cache" slot. + (cache inst))) + +(let ((size (cache-size inst))) ;; Get the value of the "csize" + @dots{}) ;; slot. +@end example + +Whichever of these methods is used to access slots, GOOPS always calls +the low-level @dfn{getter} and @dfn{setter} closures for the slot to get +and set its value. These closures make sure that the slot behaves +according to the @code{#:allocation} type that was specified in the slot +definition (@pxref{Slot Options,, allocation}). (For more about these +closures, see @ref{Customizing Class Definition,, compute-get-n-set}.) + +@menu +* Instance Slots:: +* Class Slots:: +* Handling Slot Access Errors:: +@end menu + +@node Instance Slots +@subsection Instance Slots + +Any slot, regardless of its allocation, can be queried, referenced and +set using the following four primitive procedures. + +@deffn {primitive procedure} slot-exists? obj slot-name +Return @code{#t} if @var{obj} has a slot with name @var{slot-name}, +otherwise @code{#f}. +@end deffn + +@deffn {primitive procedure} slot-bound? obj slot-name +Return @code{#t} if the slot named @var{slot-name} in @var{obj} has a +value, otherwise @code{#f}. + +@code{slot-bound?} calls the generic function @code{slot-missing} if +@var{obj} does not have a slot called @var{slot-name} (@pxref{Handling +Slot Access Errors, slot-missing}). +@end deffn + +@deffn {primitive procedure} slot-ref obj slot-name +Return the value of the slot named @var{slot-name} in @var{obj}. + +@code{slot-ref} calls the generic function @code{slot-missing} if +@var{obj} does not have a slot called @var{slot-name} (@pxref{Handling +Slot Access Errors, slot-missing}). + +@code{slot-ref} calls the generic function @code{slot-unbound} if the +named slot in @var{obj} does not have a value (@pxref{Handling Slot +Access Errors, slot-unbound}). +@end deffn + +@deffn {primitive procedure} slot-set! obj slot-name value +Set the value of the slot named @var{slot-name} in @var{obj} to @var{value}. + +@code{slot-set!} calls the generic function @code{slot-missing} if +@var{obj} does not have a slot called @var{slot-name} (@pxref{Handling +Slot Access Errors, slot-missing}). +@end deffn + +GOOPS stores information about slots in class metaobjects. Internally, +all of these procedures work by looking up the slot definition for the +slot named @var{slot-name} in the class metaobject for @code{(class-of +@var{obj})}, and then using the slot definition's ``getter'' and +``setter'' closures to get and set the slot value. + +The next four procedures differ from the previous ones in that they take +the class metaobject as an explicit argument, rather than assuming +@code{(class-of @var{obj})}. Therefore they allow you to apply the +``getter'' and ``setter'' closures of a slot definition in one class to +an instance of a different class. + +[ *fixme* I have no idea why this is useful! Perhaps when a slot in +@code{(class-of @var{obj})} shadows a slot with the same name in one of +its superclasses? There should be an enlightening example here. ] + +@deffn {primitive procedure} slot-exists-using-class? class obj slot-name +Return @code{#t} if the class metaobject @var{class} has a slot +definition for a slot with name @var{slot-name}, otherwise @code{#f}. +@end deffn + +@deffn {primitive procedure} slot-bound-using-class? class obj slot-name +Return @code{#t} if applying @code{slot-ref-using-class} to the same +arguments would call the generic function @code{slot-unbound}, otherwise +@code{#f}. + +@code{slot-bound-using-class?} calls the generic function +@code{slot-missing} if @var{class} does not have a slot definition for a +slot called @var{slot-name} (@pxref{Handling Slot Access Errors, +slot-missing}). +@end deffn + +@deffn {primitive procedure} slot-ref-using-class class obj slot-name +Apply the ``getter'' closure for the slot named @var{slot-name} in +@var{class} to @var{obj}, and return its result. + +@code{slot-ref-using-class} calls the generic function +@code{slot-missing} if @var{class} does not have a slot definition for a +slot called @var{slot-name} (@pxref{Handling Slot Access Errors, +slot-missing}). + +@code{slot-ref-using-class} calls the generic function +@code{slot-unbound} if the application of the ``getter'' closure to +@var{obj} returns an unbound value (@pxref{Handling Slot Access Errors, +slot-unbound}). +@end deffn + +@deffn {primitive procedure} slot-set-using-class! class obj slot-name value +Apply the ``setter'' closure for the slot named @var{slot-name} in +@var{class} to @var{obj} and @var{value}. + +@code{slot-set-using-class!} calls the generic function +@code{slot-missing} if @var{class} does not have a slot definition for a +slot called @var{slot-name} (@pxref{Handling Slot Access Errors, +slot-missing}). +@end deffn + +@node Class Slots +@subsection Class Slots + +Slots whose allocation is per-class rather than per-instance can be +referenced and set without needing to specify any particular instance. + +@deffn procedure class-slot-ref class slot-name +Return the value of the slot named @var{slot-name} in class @var{class}. +The named slot must have @code{#:class} or @code{#:each-subclass} +allocation (@pxref{Slot Options,, allocation}). + +If there is no such slot with @code{#:class} or @code{#:each-subclass} +allocation, @code{class-slot-ref} calls the @code{slot-missing} generic +function with arguments @var{class} and @var{slot-name}. Otherwise, if +the slot value is unbound, @code{class-slot-ref} calls the +@code{slot-missing} generic function, with the same arguments. +@end deffn + +@deffn procedure class-slot-set! class slot-name value +Set the value of the slot named @var{slot-name} in class @var{class} to +@var{value}. The named slot must have @code{#:class} or +@code{#:each-subclass} allocation (@pxref{Slot Options,, allocation}). + +If there is no such slot with @code{#:class} or @code{#:each-subclass} +allocation, @code{class-slot-ref} calls the @code{slot-missing} generic +function with arguments @var{class} and @var{slot-name}. +@end deffn + +@node Handling Slot Access Errors +@subsection Handling Slot Access Errors + +GOOPS calls one of the following generic functions when a ``slot-ref'' +or ``slot-set!'' call specifies a non-existent slot name, or tries to +reference a slot whose value is unbound. + +@deffn generic slot-missing +@deffnx method slot-missing (class ) slot-name +@deffnx method slot-missing (class ) (object ) slot-name +@deffnx method slot-missing (class ) (object ) slot-name value +When an application attempts to reference or set a class or instance +slot by name, and the slot name is invalid for the specified @var{class} +or @var{object}, GOOPS calls the @code{slot-missing} generic function. + +The default methods all call @code{goops-error} with an appropriate +message. +@end deffn + +@deffn generic slot-unbound +@deffnx method slot-unbound (object ) +@deffnx method slot-unbound (class ) slot-name +@deffnx method slot-unbound (class ) (object ) slot-name +When an application attempts to reference a class or instance slot, and +the slot's value is unbound, GOOPS calls the @code{slot-unbound} generic +function. + +The default methods all call @code{goops-error} with an appropriate +message. +@end deffn + +@node Creating Generic Functions +@section Creating Generic Functions + +A generic function is a collection of methods, with rules for +determining which of the methods should be applied for any given +invocation of the generic function. + +GOOPS represents generic functions as metaobjects of the class +@code{} (or one of its subclasses). + +@menu +* Basic Generic Function Creation:: +* Generic Function Internals:: +* Extending Guiles Primitives:: +@end menu + +@node Basic Generic Function Creation +@subsection Basic Generic Function Creation + +The following forms may be used to bind a variable to a generic +function. Depending on that variable's pre-existing value, the generic +function may be created empty - with no methods - or it may contain +methods that are inferred from the pre-existing value. + +It is not, in general, necessary to use @code{define-generic} or +@code{define-accessor} before defining methods for the generic function +using @code{define-method}, since @code{define-method} will +automatically interpolate a @code{define-generic} call, or upgrade an +existing generic to an accessor, if that is implied by the +@code{define-method} call. Note in particular that, +if the specified variable already has a @emph{generic function} value, +@code{define-generic} and @code{define-accessor} will @emph{discard} it! +Obviously it is application-dependent whether this is desirable or not. + +If, for example, you wanted to extend @code{+} for a class representing +a new numerical type, you probably want to inherit any existing methods +for @code{+} and so should not use @code{define-generic}. If, on the +other hand, you do not want to risk inheriting methods whose behaviour +might surprise you, you can use @code{define-generic} or +@code{define-accessor} to wipe the slate clean. + +@deffn syntax define-generic symbol +Create a generic function with name @var{symbol} and bind it to the +variable @var{symbol}. + +If the variable @var{symbol} was previously bound to a Scheme procedure +(or procedure-with-setter), the old procedure (and setter) is +incorporated into the new generic function as its default procedure (and +setter). Any other previous value that was bound to @var{symbol}, +including an existing generic function, is overwritten by the new +generic function. +@end deffn + +@deffn syntax define-accessor symbol +Create an accessor with name @var{symbol} and bind it to the variable +@var{symbol}. + +If the variable @var{symbol} was previously bound to a Scheme procedure +(or procedure-with-setter), the old procedure (and setter) is +incorporated into the new accessor as its default procedure (and +setter). Any other previous value that was bound to @var{symbol}, +including an existing generic function or accessor, is overwritten by +the new definition. +@end deffn + +@node Generic Function Internals +@subsection Generic Function Internals + +@code{define-generic} calls @code{ensure-generic} to upgrade a +pre-existing procedure value, or @code{make} with metaclass +@code{} to create a new generic function. + +@code{define-accessor} calls @code{ensure-accessor} to upgrade a +pre-existing procedure value, or @code{make-accessor} to create a new +accessor. + +@deffn procedure ensure-generic old-definition [name] +Return a generic function with name @var{name}, if possible by using or +upgrading @var{old-definition}. If unspecified, @var{name} defaults to +@code{#f}. + +If @var{old-definition} is already a generic function, it is returned +unchanged. + +If @var{old-definition} is a Scheme procedure or procedure-with-setter, +@code{ensure-generic} returns a new generic function that uses +@var{old-definition} for its default procedure and setter. + +Otherwise @code{ensure-generic} returns a new generic function with no +defaults and no methods. +@end deffn + +@deffn procedure make-generic [name] +Return a new generic function with name @code{(car @var{name})}. If +unspecified, @var{name} defaults to @code{#f}. +@end deffn + +@code{ensure-generic} calls @code{make} with metaclasses +@code{} and @code{}, depending on the +previous value of the variable that it is trying to upgrade. + +@code{make-generic} is a simple wrapper for @code{make} with metaclass +@code{}. + +@deffn procedure ensure-accessor proc [name] +Return an accessor with name @var{name}, if possible by using or +upgrading @var{proc}. If unspecified, @var{name} defaults to @code{#f}. + +If @var{proc} is already an accessor, it is returned unchanged. + +If @var{proc} is a Scheme procedure, procedure-with-setter or generic +function, @code{ensure-accessor} returns an accessor that reuses the +reusable elements of @var{proc}. + +Otherwise @code{ensure-accessor} returns a new accessor with no defaults +and no methods. +@end deffn + +@deffn procedure make-accessor [name] +Return a new accessor with name @code{(car @var{name})}. If +unspecified, @var{name} defaults to @code{#f}. +@end deffn + +@code{ensure-accessor} calls @code{make} with +metaclass @code{}, as well as calls to +@code{ensure-generic}, @code{make-accessor} and (tail recursively) +@code{ensure-accessor}. + +@code{make-accessor} calls @code{make} twice, first +with metaclass @code{} to create a generic function for the +setter, then with metaclass @code{} to create the +accessor, passing the setter generic function as the value of the +@code{#:setter} keyword. + +@node Extending Guiles Primitives +@subsection Extending Guile's Primitives + +When GOOPS is loaded, many of Guile's primitive procedures can be +extended by giving them a generic function definition that operates +in conjunction with their normal C-coded implementation. For +primitives that are extended in this way, the result from the user- +or application-level point of view is that the extended primitive +behaves exactly like a generic function with the C-coded implementation +as its default method. + +The @code{generic-capability?} predicate should be used to determine +whether a particular primitive is extensible in this way. + +@deffn {primitive procedure} generic-capability? primitive +Return @code{#t} if @var{primitive} can be extended by giving it a +generic function definition, otherwise @code{#f}. +@end deffn + +Even when a primitive procedure is extensible like this, its generic +function definition is not created until it is needed by a call to +@code{define-method}, or until the application explicitly requests it +by calling @code{enable-primitive-generic!}. + +@deffn {primitive procedure} enable-primitive-generic! primitive +Force the creation of a generic function definition for +@var{primitive}. +@end deffn + +Once the generic function definition for a primitive has been created, +it can be retrieved using @code{primitive-generic-generic}. + +@deffn {primitive procedure} primitive-generic-generic primitive +Return the generic function definition of @var{primitive}. + +@code{primitive-generic-generic} raises an error if @var{primitive} +is not a primitive with generic capability, or if its generic capability +has not yet been enabled, whether implicitly (by @code{define-method}) +or explicitly (by @code{enable-primitive-generic!}). +@end deffn + +Note that the distinction between, on the one hand, primitives with +additional generic function definitions and, on the other hand, generic +functions with a default method, may disappear when GOOPS is fully +integrated into the core of Guile. Consequently, the +procedures described in this section may disappear as well. + +@node Adding Methods to Generic Functions +@section Adding Methods to Generic Functions + +@menu +* Basic Method Definition:: +* Method Definition Internals:: +@end menu + +@node Basic Method Definition +@subsection Basic Method Definition + +To add a method to a generic function, use the @code{define-method} form. + +@deffn syntax define-method (generic parameter @dots{}) . body +Define a method for the generic function or accessor @var{generic} with +parameters @var{parameter}s and body @var{body}. + +@var{generic} is a generic function. If @var{generic} is a variable +which is not yet bound to a generic function object, the expansion of +@code{define-method} will include a call to @code{define-generic}. If +@var{generic} is @code{(setter @var{generic-with-setter})}, where +@var{generic-with-setter} is a variable which is not yet bound to a +generic-with-setter object, the expansion will include a call to +@code{define-accessor}. + +Each @var{parameter} must be either a symbol or a two-element list +@code{(@var{symbol} @var{class})}. The symbols refer to variables in +the @var{body} that will be bound to the parameters supplied by the +caller when calling this method. The @var{class}es, if present, +specify the possible combinations of parameters to which this method +can be applied. + +@var{body} is the body of the method definition. +@end deffn + +@code{define-method} expressions look a little like normal Scheme +procedure definitions of the form + +@example +(define (name formals @dots{}) . body) +@end example + +The most important difference is that each formal parameter, apart from the +possible ``rest'' argument, can be qualified by a class name: +@code{@var{formal}} becomes @code{(@var{formal} @var{class})}. The +meaning of this qualification is that the method being defined +will only be applicable in a particular generic function invocation if +the corresponding argument is an instance of @code{@var{class}} (or one of +its subclasses). If more than one of the formal parameters is qualified +in this way, then the method will only be applicable if each of the +corresponding arguments is an instance of its respective qualifying class. + +Note that unqualified formal parameters act as though they are qualified +by the class @code{}, which GOOPS uses to mean the superclass of +all valid Scheme types, including both primitive types and GOOPS classes. + +For example, if a generic function method is defined with +@var{parameter}s @code{((s1 ) (n ))}, that method is +only applicable to invocations of its generic function that have two +parameters where the first parameter is an instance of the +@code{} class and the second parameter is a number. + +If a generic function is invoked with a combination of parameters for which +there is no applicable method, GOOPS raises an error. For more about +invocation error handling, and generic function invocation in general, +see @ref{Invoking Generic Functions}. + +@node Method Definition Internals +@subsection Method Definition Internals + +@code{define-method} + +@itemize @bullet +@item +checks the form of the first parameter, and applies the following steps +to the accessor's setter if it has the @code{(setter @dots{})} form + +@item +interpolates a call to @code{define-generic} or @code{define-accessor} +if a generic function is not already defined with the supplied name + +@item +calls @code{method} with the @var{parameter}s and @var{body}, to make a +new method instance + +@item +calls @code{add-method!} to add this method to the relevant generic +function. +@end itemize + +@deffn syntax method (parameter @dots{}) . body +Make a method whose specializers are defined by the classes in +@var{parameter}s and whose procedure definition is constructed from the +@var{parameter} symbols and @var{body} forms. + +The @var{parameter} and @var{body} parameters should be as for +@code{define-method} (@pxref{Basic Method Definition,, define-method}). +@end deffn + +@code{method} + +@itemize @bullet +@item +extracts formals and specializing classes from the @var{parameter}s, +defaulting the class for unspecialized parameters to @code{} + +@item +creates a closure using the formals and the @var{body} forms + +@item +calls @code{make} with metaclass @code{} and the specializers +and closure using the @code{#:specializers} and @code{#:procedure} +keywords. +@end itemize + +@deffn procedure make-method specializers procedure +Make a method using @var{specializers} and @var{procedure}. + +@var{specializers} should be a list of classes that specifies the +parameter combinations to which this method will be applicable. + +@var{procedure} should be the closure that will applied to the generic +function parameters when this method is invoked. +@end deffn + +@code{make-method} is a simple wrapper around @code{make} with metaclass +@code{}. + +@deffn generic add-method! target method +Generic function for adding method @var{method} to @var{target}. +@end deffn + +@deffn method add-method! (generic ) (method ) +Add method @var{method} to the generic function @var{generic}. +@end deffn + +@deffn method add-method! (proc ) (method ) +If @var{proc} is a procedure with generic capability (@pxref{Extending +Guiles Primitives,, generic-capability?}), upgrade it to a +primitive generic and add @var{method} to its generic function +definition. +@end deffn + +@deffn method add-method! (pg ) (method ) +Add method @var{method} to the generic function definition of @var{pg}. + +Implementation: @code{(add-method! (primitive-generic-generic pg) method)}. +@end deffn + +@deffn method add-method! (whatever ) (method ) +Raise an error indicating that @var{whatever} is not a valid generic +function. +@end deffn + +@node Invoking Generic Functions +@section Invoking Generic Functions + +When a variable with a generic function definition appears as the first +element of a list that is being evaluated, the Guile evaluator tries +to apply the generic function to the arguments obtained by evaluating +the remaining elements of the list. [ *fixme* How do I put this in a +more Schemely and less Lispy way? ] + +Usually a generic function contains several method definitions, with +varying degrees of formal parameter specialization (@pxref{Basic +Method Definition,, define-method}). So it is necessary to sort these +methods by specificity with respect to the supplied arguments, and then +apply the most specific method definition. Less specific methods +may be applied subsequently if a method that is being applied calls +@code{next-method}. + +@menu +* Determining Which Methods to Apply:: +* Handling Invocation Errors:: +@end menu + +@node Determining Which Methods to Apply +@subsection Determining Which Methods to Apply + +[ *fixme* Sorry - this is the area of GOOPS that I understand least of +all, so I'm afraid I have to pass on this section. Would some other +kind person consider filling it in? ] + +@deffn generic apply-generic +@deffnx method apply-generic (gf ) args +@end deffn + +@deffn generic compute-applicable-methods +@deffnx method compute-applicable-methods (gf ) args +@end deffn + +@deffn generic sort-applicable-methods +@deffnx method sort-applicable-methods (gf ) methods args +@end deffn + +@deffn generic method-more-specific? +@deffnx method method-more-specific? (m1 ) (m2 ) args +@end deffn + +@deffn generic apply-method +@deffnx method apply-method (gf ) methods build-next args +@end deffn + +@deffn generic apply-methods +@deffnx method apply-methods (gf ) (l ) args +@end deffn + +@node Handling Invocation Errors +@subsection Handling Invocation Errors + +@deffn generic no-method +@deffnx method no-method (gf ) args +When an application invokes a generic function, and no methods at all +have been defined for that generic function, GOOPS calls the +@code{no-method} generic function. The default method calls +@code{goops-error} with an appropriate message. +@end deffn + +@deffn generic no-applicable-method +@deffnx method no-applicable-method (gf ) args +When an application applies a generic function to a set of arguments, +and no methods have been defined for those argument types, GOOPS calls +the @code{no-applicable-method} generic function. The default method +calls @code{goops-error} with an appropriate message. +@end deffn + +@deffn generic no-next-method +@deffnx method no-next-method (gf ) args +When a generic function method calls @code{(next-method)} to invoke the +next less specialized method for that generic function, and no less +specialized methods have been defined for the current generic function +arguments, GOOPS calls the @code{no-next-method} generic function. The +default method calls @code{goops-error} with an appropriate message. +@end deffn + +@node Redefining a Class +@section Redefining a Class + +Suppose that a class @code{} is defined using @code{define-class} +(@pxref{Basic Class Definition,, define-class}), with slots that have +accessor functions, and that an application has created several instances +of @code{} using @code{make} (@pxref{Basic Instance Creation,, +make}). What then happens if @code{} is redefined by calling +@code{define-class} again? + +@menu +* Default Class Redefinition Behaviour:: +* Customizing Class Redefinition:: +@end menu + +@node Default Class Redefinition Behaviour +@subsection Default Class Redefinition Behaviour + +GOOPS' default answer to this question is as follows. + +@itemize @bullet +@item +All existing direct instances of @code{} are converted to be +instances of the new class. This is achieved by preserving the values +of slots that exist in both the old and new definitions, and initializing the +values of new slots in the usual way (@pxref{Basic Instance Creation,, +make}). + +@item +All existing subclasses of @code{} are redefined, as though +the @code{define-class} expressions that defined them were re-evaluated +following the redefinition of @code{}, and the class +redefinition process described here is applied recursively to the +redefined subclasses. + +@item +Once all of its instances and subclasses have been updated, the class +metaobject previously bound to the variable @code{} is no +longer needed and so can be allowed to be garbage collected. +@end itemize + +To keep things tidy, GOOPS also needs to do a little housekeeping on +methods that are associated with the redefined class. + +@itemize @bullet +@item +Slot accessor methods for slots in the old definition should be removed +from their generic functions. They will be replaced by accessor methods +for the slots of the new class definition. + +@item +Any generic function method that uses the old @code{} metaobject +as one of its formal parameter specializers must be updated to refer to +the new @code{} metaobject. (Whenever a new generic function +method is defined, @code{define-method} adds the method to a list stored +in the class metaobject for each class used as a formal parameter +specializer, so it is easy to identify all the methods that must be +updated when a class is redefined.) +@end itemize + +If this class redefinition strategy strikes you as rather counter-intuitive, +bear in mind that it is derived from similar behaviour in other object +systems such as CLOS, and that experience in those systems has shown it to be +very useful in practice. + +Also bear in mind that, like most of GOOPS' default behaviour, it can +be customized@dots{} + +@node Customizing Class Redefinition +@subsection Customizing Class Redefinition + +When @code{define-class} notices that a class is being redefined, +it constructs the new class metaobject as usual, and then invokes the +@code{class-redefinition} generic function with the old and new classes +as arguments. Therefore, if the old or new classes have metaclasses +other than the default @code{}, class redefinition behaviour can +be customized by defining a @code{class-redefinition} method that is +specialized for the relevant metaclasses. + +@deffn generic class-redefinition +Handle the class redefinition from @var{old-class} to @var{new-class}, +and return the new class metaobject that should be bound to the +variable specified by @code{define-class}'s first argument. +@end deffn + +@deffn method class-redefinition (old-class ) (new-class ) +Implements GOOPS' default class redefinition behaviour, as described in +@ref{Default Class Redefinition Behaviour}. Returns the metaobject +for the new class definition. +@end deffn + +An alternative class redefinition strategy could be to leave all +existing instances as instances of the old class, but accepting that the +old class is now ``nameless'', since its name has been taken over by the +new definition. In this strategy, any existing subclasses could also +be left as they are, on the understanding that they inherit from a nameless +superclass. + +This strategy is easily implemented in GOOPS, by defining a new metaclass, +that will be used as the metaclass for all classes to which the strategy +should apply, and then defining a @code{class-redefinition} method that +is specialized for this metaclass: + +@example +(define-class ()) + +(define-method (class-redefinition (old ) (new )) + new) +@end example + +When customization can be as easy as this, aren't you glad that GOOPS +implements the far more difficult strategy as its default! + +Finally, note that, if @code{class-redefinition} itself is not customized, +the default @code{class-redefinition} method invokes three further +generic functions that could be individually customized: + +@itemize @bullet +@item +(remove-class-accessors! @var{old-class}) + +@item +(update-direct-method! @var{method} @var{old-class} @var{new-class}) + +@item +(update-direct-subclass! @var{subclass} @var{old-class} @var{new-class}) +@end itemize + +and the default methods for these generic functions invoke further +generic functions, and so on@dots{} The detailed protocol for all of these +is described in @ref{MOP Specification}. + +@node Changing the Class of an Instance +@section Changing the Class of an Instance + +You can change the class of an existing instance by invoking the +generic function @code{change-class} with two arguments: the instance +and the new class. + +@deffn generic change-class +@end deffn + +The default method for @code{change-class} decides how to implement the +change of class by looking at the slot definitions for the instance's +existing class and for the new class. If the new class has slots with +the same name as slots in the existing class, the values for those slots +are preserved. Slots that are present only in the existing class are +discarded. Slots that are present only in the new class are initialized +using the corresponding slot definition's init function (@pxref{Classes,, +slot-init-function}). + +@deffn {method} change-class (obj ) (new ) +Modify instance @var{obj} to make it an instance of class @var{new}. + +The value of each of @var{obj}'s slots is preserved only if a similarly named +slot exists in @var{new}; any other slot values are discarded. + +The slots in @var{new} that do not correspond to any of @var{obj}'s +pre-existing slots are initialized according to @var{new}'s slot definitions' +init functions. +@end deffn + +Customized change of class behaviour can be implemented by defining +@code{change-class} methods that are specialized either by the class +of the instances to be modified or by the metaclass of the new class. + +When a class is redefined (@pxref{Redefining a Class}), and the default +class redefinition behaviour is not overridden, GOOPS (eventually) +invokes the @code{change-class} generic function for each existing +instance of the redefined class. + +@node Introspection +@section Introspection + +@dfn{Introspection}, also known as @dfn{reflection}, is the name given +to the ability to obtain information dynamically about GOOPS metaobjects. +It is perhaps best illustrated by considering an object oriented language +that does not provide any introspection, namely C++. + +Nothing in C++ allows a running program to obtain answers to the following +types of question: + +@itemize @bullet +@item +What are the data members of this object or class? + +@item +What classes does this class inherit from? + +@item +Is this method call virtual or non-virtual? + +@item +If I invoke @code{Employee::adjustHoliday()}, what class contains the +@code{adjustHoliday()} method that will be applied? +@end itemize + +In C++, answers to such questions can only be determined by looking at +the source code, if you have access to it. GOOPS, on the other hand, +includes procedures that allow answers to these questions --- or their +GOOPS equivalents --- to be obtained dynamically, at run time. + +@menu +* Classes:: +* Slots:: +* Instances:: +* Generic Functions:: +* Generic Function Methods:: +@end menu + +@node Classes +@subsection Classes + +@deffn {primitive procedure} class-name class +Return the name of class @var{class}. +This is the value of the @var{class} metaobject's @code{name} slot. +@end deffn + +@deffn {primitive procedure} class-direct-supers class +Return a list containing the direct superclasses of @var{class}. +This is the value of the @var{class} metaobject's +@code{direct-supers} slot. +@end deffn + +@deffn {primitive procedure} class-direct-slots class +Return a list containing the slot definitions of the direct slots of +@var{class}. +This is the value of the @var{class} metaobject's @code{direct-slots} +slot. +@end deffn + +@deffn {primitive procedure} class-direct-subclasses class +Return a list containing the direct subclasses of @var{class}. +This is the value of the @var{class} metaobject's +@code{direct-subclasses} slot. +@end deffn + +@deffn {primitive procedure} class-direct-methods class +Return a list of all the generic function methods that use @var{class} +as a formal parameter specializer. +This is the value of the @var{class} metaobject's @code{direct-methods} +slot. +@end deffn + +@deffn {primitive procedure} class-precedence-list class +Return the class precedence list for class @var{class} (@pxref{Class +precedence list}). +This is the value of the @var{class} metaobject's @code{cpl} slot. +@end deffn + +@deffn {primitive procedure} class-slots class +Return a list containing the slot definitions for all @var{class}'s slots, +including any slots that are inherited from superclasses. +This is the value of the @var{class} metaobject's @code{slots} slot. +@end deffn + +@deffn {primitive procedure} class-environment class +Return the value of @var{class}'s @code{environment} slot. +[ *fixme* I don't know what this value is used for. ] +@end deffn + +@deffn procedure class-subclasses class +Return a list of all subclasses of @var{class}. +@end deffn + +@deffn procedure class-methods class +Return a list of all methods that use @var{class} or a subclass of +@var{class} as one of its formal parameter specializers. +@end deffn + +@node Slots +@subsection Slots + +@deffn procedure class-slot-definition class slot-name +Return the slot definition for the slot named @var{slot-name} in class +@var{class}. @var{slot-name} should be a symbol. +@end deffn + +@deffn procedure slot-definition-name slot-def +Extract and return the slot name from @var{slot-def}. +@end deffn + +@deffn procedure slot-definition-options slot-def +Extract and return the slot options from @var{slot-def}. +@end deffn + +@deffn procedure slot-definition-allocation slot-def +Extract and return the slot allocation option from @var{slot-def}. This +is the value of the @code{#:allocation} keyword (@pxref{Slot Options,, +allocation}), or @code{#:instance} if the @code{#:allocation} keyword is +absent. +@end deffn + +@deffn procedure slot-definition-getter slot-def +Extract and return the slot getter option from @var{slot-def}. This is +the value of the @code{#:getter} keyword (@pxref{Slot Options,, +getter}), or @code{#f} if the @code{#:getter} keyword is absent. +@end deffn + +@deffn procedure slot-definition-setter slot-def +Extract and return the slot setter option from @var{slot-def}. This is +the value of the @code{#:setter} keyword (@pxref{Slot Options,, +setter}), or @code{#f} if the @code{#:setter} keyword is absent. +@end deffn + +@deffn procedure slot-definition-accessor slot-def +Extract and return the slot accessor option from @var{slot-def}. This +is the value of the @code{#:accessor} keyword (@pxref{Slot Options,, +accessor}), or @code{#f} if the @code{#:accessor} keyword is absent. +@end deffn + +@deffn procedure slot-definition-init-value slot-def +Extract and return the slot init-value option from @var{slot-def}. This +is the value of the @code{#:init-value} keyword (@pxref{Slot Options,, +init-value}), or the unbound value if the @code{#:init-value} keyword is +absent. +@end deffn + +@deffn procedure slot-definition-init-form slot-def +Extract and return the slot init-form option from @var{slot-def}. This +is the value of the @code{#:init-form} keyword (@pxref{Slot Options,, +init-form}), or the unbound value if the @code{#:init-form} keyword is +absent. +@end deffn + +@deffn procedure slot-definition-init-thunk slot-def +Extract and return the slot init-thunk option from @var{slot-def}. This +is the value of the @code{#:init-thunk} keyword (@pxref{Slot Options,, +init-thunk}), or @code{#f} if the @code{#:init-thunk} keyword is absent. +@end deffn + +@deffn procedure slot-definition-init-keyword slot-def +Extract and return the slot init-keyword option from @var{slot-def}. +This is the value of the @code{#:init-keyword} keyword (@pxref{Slot +Options,, init-keyword}), or @code{#f} if the @code{#:init-keyword} +keyword is absent. +@end deffn + +@deffn procedure slot-init-function class slot-name +Return the initialization function for the slot named @var{slot-name} in +class @var{class}. @var{slot-name} should be a symbol. + +The returned initialization function incorporates the effects of the +standard @code{#:init-thunk}, @code{#:init-form} and @code{#:init-value} +slot options. These initializations can be overridden by the +@code{#:init-keyword} slot option or by a specialized @code{initialize} +method, so, in general, the function returned by +@code{slot-init-function} may be irrelevant. For a fuller discussion, +see @ref{Slot Options,, init-value}. +@end deffn + +@node Instances +@subsection Instances + +@deffn {primitive procedure} class-of value +Return the GOOPS class of any Scheme @var{value}. +@end deffn + +@deffn {primitive procedure} instance? object +Return @code{#t} if @var{object} is any GOOPS instance, otherwise +@code{#f}. +@end deffn + +@deffn procedure is-a? object class +Return @code{#t} if @var{object} is an instance of @var{class} or one of +its subclasses. +@end deffn + +Implementation notes: @code{is-a?} uses @code{class-of} and +@code{class-precedence-list} to obtain the class precedence list for +@var{object}. + +@node Generic Functions +@subsection Generic Functions + +@deffn {primitive procedure} generic-function-name gf +Return the name of generic function @var{gf}. +@end deffn + +@deffn {primitive procedure} generic-function-methods gf +Return a list of the methods of generic function @var{gf}. +This is the value of the @var{gf} metaobject's @code{methods} slot. +@end deffn + +@node Generic Function Methods +@subsection Generic Function Methods + +@deffn {primitive procedure} method-generic-function method +Return the generic function that @var{method} belongs to. +This is the value of the @var{method} metaobject's +@code{generic-function} slot. +@end deffn + +@deffn {primitive procedure} method-specializers method +Return a list of @var{method}'s formal parameter specializers . +This is the value of the @var{method} metaobject's +@code{specializers} slot. +@end deffn + +@deffn {primitive procedure} method-procedure method +Return the procedure that implements @var{method}. +This is the value of the @var{method} metaobject's +@code{procedure} slot. +@end deffn + +@deffn generic method-source +@deffnx method method-source (m ) +Return an expression that prints to show the definition of method +@var{m}. + +@example +(define-generic cube) + +(define-method (cube (n )) + (* n n n)) + +(map method-source (generic-function-methods cube)) +@result{} +((method ((n )) (* n n n))) +@end example +@end deffn + +@node Miscellaneous Functions +@section Miscellaneous Functions + +@menu +* Administrative Functions:: +* Error Handling:: +* Object Comparisons:: +* Cloning Objects:: +* Write and Display:: +@end menu + +@node Administrative Functions +@subsection Administration Functions + +This section describes administrative, non-technical GOOPS functions. + +@deffn primitive goops-version +Return the current GOOPS version as a string, for example ``0.2''. +@end deffn + +@node Error Handling +@subsection Error Handling + +The procedure @code{goops-error} is called to raise an appropriate error +by the default methods of the following generic functions: + +@itemize @bullet +@item +@code{slot-missing} (@pxref{Handling Slot Access Errors,, slot-missing}) + +@item +@code{slot-unbound} (@pxref{Handling Slot Access Errors,, slot-unbound}) + +@item +@code{no-method} (@pxref{Handling Invocation Errors,, no-method}) + +@item +@code{no-applicable-method} (@pxref{Handling Invocation Errors,, +no-applicable-method}) + +@item +@code{no-next-method} (@pxref{Handling Invocation Errors,, +no-next-method}) +@end itemize + +If you customize these functions for particular classes or metaclasses, +you may still want to use @code{goops-error} to signal any error +conditions that you detect. + +@deffn procedure goops-error format-string . args +Raise an error with key @code{goops-error} and error message constructed +from @var{format-string} and @var{args}. Error message formatting is +as done by @code{scm-error}. +@end deffn + +@node Object Comparisons +@subsection Object Comparisons + +@deffn generic object-eqv? +@deffnx method object-eqv? ((x ) (y )) +@deffnx generic object-equal? +@deffnx method object-equal? ((x ) (y )) +Generic functions and default (unspecialized) methods for comparing two +GOOPS objects. + +The default methods always return @code{#f}. Application class authors +may wish to define specialized methods for @code{object-eqv?} and +@code{object-equal?} that compare instances of the same class for +equality in whatever sense is useful to the application. +@end deffn + +@node Cloning Objects +@subsection Cloning Objects + +@deffn generic shallow-clone +@deffnx method shallow-clone (self ) +Return a ``shallow'' clone of @var{self}. The default method makes a +shallow clone by allocating a new instance and copying slot values from +self to the new instance. Each slot value is copied either as an +immediate value or by reference. +@end deffn + +@deffn generic deep-clone +@deffnx method deep-clone (self ) +Return a ``deep'' clone of @var{self}. The default method makes a deep +clone by allocating a new instance and copying or cloning slot values +from self to the new instance. If a slot value is an instance +(satisfies @code{instance?}), it is cloned by calling @code{deep-clone} +on that value. Other slot values are copied either as immediate values +or by reference. +@end deffn + +@node Write and Display +@subsection Write and Display + +@deffn {primitive generic} write object port +@deffnx {primitive generic} display object port +When GOOPS is loaded, @code{write} and @code{display} become generic +functions with special methods for printing + +@itemize @bullet +@item +objects - instances of the class @code{} + +@item +foreign objects - instances of the class @code{} + +@item +classes - instances of the class @code{} + +@item +generic functions - instances of the class @code{} + +@item +methods - instances of the class @code{}. +@end itemize + +@code{write} and @code{display} print non-GOOPS values in the same way +as the Guile primitive @code{write} and @code{display} functions. +@end deffn + +@node MOP Specification, Tutorial, Reference Manual, Top +@chapter MOP Specification + +For an introduction to metaobjects and the metaobject protocol, +see @ref{Metaobjects and the Metaobject Protocol}. + +The aim of the MOP specification in this chapter is to specify all the +customizable generic function invocations that can be made by the standard +GOOPS syntax, procedures and methods, and to explain the protocol for +customizing such invocations. + +A generic function invocation is customizable if the types of the arguments +to which it is applied are not all determined by the lexical context in +which the invocation appears. For example, + +@itemize @bullet +@item +the @code{(initialize @var{instance} @var{initargs})} invocation in the +default @code{make-instance} method is customizable, because the type of the +@code{@var{instance}} argument is determined by the class that was passed to +@code{make-instance}. + +@item +the @code{(make #:name ',name)} invocation in @code{define-generic} +is not customizable, because all of its arguments have lexically determined +types. +@end itemize + +When using this rule to decide whether a given generic function invocation +is customizable, we ignore arguments that are expected to be handled in +method definitions as a single ``rest'' list argument. + +For each customizable generic function invocation, the @dfn{invocation +protocol} is explained by specifying + +@itemize @bullet +@item +what, conceptually, the applied method is intended to do + +@item +what assumptions, if any, the caller makes about the applied method's side +effects + +@item +what the caller expects to get as the applied method's return value. +@end itemize + +@menu +* Class Definition:: +* Instance Creation:: +* Class Redefinition:: +* Method Definition:: +* Generic Function Invocation:: +@end menu + +@node Class Definition +@section Class Definition + +@code{define-class} (syntax) + +@itemize @bullet +@item +@code{class} (syntax) + +@itemize @bullet +@item +@code{make-class} (procedure) + +@itemize @bullet +@item +@code{make @var{metaclass} @dots{}} (generic) + +@var{metaclass} is the metaclass of the class being defined, either +taken from the @code{#:metaclass} class option or computed by +@code{ensure-metaclass}. The applied method must create and return the +fully initialized class metaobject for the new class definition. +@end itemize + +@end itemize + +@item +@code{class-redefinition @var{old-class} @var{new-class}} (generic) + +@code{define-class} calls @code{class-redefinition} if the variable +specified by its first argument already held a GOOPS class definition. +@var{old-class} and @var{new-class} are the old and new class metaobjects. +The applied method should perform whatever is necessary to handle the +redefinition, and should return the class metaobject that is to be bound +to @code{define-class}'s variable. The default class redefinition +protocol is described in @ref{Class Redefinition}. +@end itemize + +The @code{(make @var{metaclass} @dots{})} invocation above will create +an class metaobject with metaclass @var{metaclass}. By default, this +metaobject will be initialized by the @code{initialize} method that is +specialized for instances of type @code{}. + +@code{initialize @var{initargs}} (method) + +@itemize @bullet +@item +@code{compute-cpl @var{class}} (generic) + +The applied method should compute and return the class precedence list +for @var{class} as a list of class metaobjects. When @code{compute-cpl} +is called, the following @var{class} metaobject slots have all been +initialized: @code{name}, @code{direct-supers}, @code{direct-slots}, +@code{direct-subclasses} (empty), @code{direct-methods}. The value +returned by @code{compute-cpl} will be stored in the @code{cpl} slot. + +@item +@code{compute-slots @var{class}} (generic) + +The applied method should compute and return the slots (union of direct +and inherited) for @var{class} as a list of slot definitions. When +@code{compute-slots} is called, all the @var{class} metaobject slots +mentioned for @code{compute-cpl} have been initialized, plus the +following: @code{cpl}, @code{redefined} (@code{#f}), @code{environment}. +The value returned by @code{compute-slots} will be stored in the +@code{slots} slot. + +@item +@code{compute-get-n-set @var{class} @var{slot-def}} (generic) + +@code{initialize} calls @code{compute-get-n-set} for each slot computed +by @code{compute-slots}. The applied method should compute and return a +pair of closures that, respectively, get and set the value of the specified +slot. The get closure should have arity 1 and expect a single argument +that is the instance whose slot value is to be retrieved. The set closure +should have arity 2 and expect two arguments, where the first argument is +the instance whose slot value is to be set and the second argument is the +new value for that slot. The closures should be returned in a two element +list: @code{(list @var{get} @var{set})}. + +The closures returned by @code{compute-get-n-set} are stored as part of +the value of the @var{class} metaobject's @code{getters-n-setters} slot. +Specifically, the value of this slot is a list with the same number of +elements as there are slots in the class, and each element looks either like + +@example +@code{(@var{slot-name-symbol} @var{init-function} . @var{index})} +@end example + +or like + +@example +@code{(@var{slot-name-symbol} @var{init-function} @var{get} @var{set})} +@end example + +Where the get and set closures are replaced by @var{index}, the slot is +an instance slot and @var{index} is the slot's index in the underlying +structure: GOOPS knows how to get and set the value of such slots and so +does not need specially constructed get and set closures. Otherwise, +@var{get} and @var{set} are the closures returned by @code{compute-get-n-set}. + +The structure of the @code{getters-n-setters} slot value is important when +understanding the next customizable generic functions that @code{initialize} +calls@dots{} + +@item +@code{compute-getter-method @var{class} @var{gns}} (generic) + +@code{initialize} calls @code{compute-getter-method} for each of the class's +slots (as determined by @code{compute-slots}) that includes a +@code{#:getter} or @code{#:accessor} slot option. @var{gns} is the +element of the @var{class} metaobject's @code{getters-n-setters} slot that +specifies how the slot in question is referenced and set, as described +above under @code{compute-get-n-set}. The applied method should create +and return a method that is specialized for instances of type @var{class} +and uses the get closure to retrieve the slot's value. [ *fixme Need +to insert something here about checking that the value is not unbound. ] +@code{initialize} uses @code{add-method!} to add the returned method to +the generic function named by the slot definition's @code{#:getter} or +@code{#:accessor} option. + +@item +@code{compute-setter-method @var{class} @var{gns}} (generic) + +@code{compute-setter-method} is invoked with the same arguments as +@code{compute-getter-method}, for each of the class's slots that includes +a @code{#:setter} or @code{#:accessor} slot option. The applied method +should create and return a method that is specialized for instances of +type @var{class} and uses the set closure to set the slot's value. +@code{initialize} then uses @code{add-method!} to add the returned method +to the generic function named by the slot definition's @code{#:setter} +or @code{#:accessor} option. +@end itemize + +@node Instance Creation +@section Instance Creation + +@code{make . @var{initargs}} (method) + +@itemize @bullet +@item +@code{allocate-instance @var{class} @var{initargs}} (generic) + +The applied @code{allocate-instance} method should allocate storage for +a new instance of class @var{class} and return the uninitialized instance. + +@item +@code{initialize @var{instance} @var{initargs}} (generic) + +@var{instance} is the uninitialized instance returned by +@code{allocate-instance}. The applied method should initialize the new +instance in whatever sense is appropriate for its class. The method's +return value is ignored. +@end itemize + +@node Class Redefinition +@section Class Redefinition + +The default @code{class-redefinition} method, specialized for classes +with the default metaclass @code{}, has the following internal +protocol. + +[ *fixme* I'm not sure that I understand this sufficiently to explain +it. Also, the internals of the default class redefinition method are +extremely implementation-specific, and I'm not sure that there is that +much point trying to describe the internal protocol such that it could +be customized without going to look at the source code. ] + +@code{class-redefinition @var{(old )} @var{(new )}} +(method) + +@itemize @bullet +@item +@code{remove-class-accessors! @var{old}} (generic) + +@item +@code{update-direct-method! @var{method} @var{old} @var{new}} (generic) + +@item +@code{update-direct-subclass! @var{subclass} @var{old} @var{new}} (generic) +@end itemize + +The default @code{update-direct-subclass!} method invokes +@code{class-redefinition} recursively to handle the redefinition of the +subclass. + +When a class is redefined, any existing instance of the redefined class +will be modified for the new class definition before the next time that +any of the instance's slot is referenced or set. GOOPS modifies each +instance by calling the generic function @code{change-class}. [ *fixme* +Actually it sometimes calls @code{change-class} and sometimes +@code{change-object-class}, and I don't understand why. ] + +The default @code{change-class} method copies slot values from the old +to the modified instance, and initializes new slots, as described in +@ref{Changing the Class of an Instance}. After doing so, it makes a +generic function invocation that can be used to customize the instance +update algorithm. + +@code{change-class @var{(old-instance )} @var{(new )}} (method) + +@itemize @bullet +@item +@code{update-instance-for-different-class @var{old-instance} @var{new-instance}} (generic) + +@code{change-class} invokes @code{update-instance-for-different-class} +as the last thing that it does before returning. The applied method can +make any further adjustments to @var{new-instance} that are required to +complete or modify the change of class. The return value from the +applied method is ignored. + +The default @code{update-instance-for-different-class} method does +nothing. +@end itemize + +@node Method Definition +@section Method Definition + +@code{define-method} (syntax) + +@itemize @bullet +@item +@code{add-method! @var{target} @var{method}} (generic) + +@code{define-method} invokes the @code{add-method!} generic function to +handle adding the new method to a variety of possible targets. GOOPS +includes methods to handle @var{target} as + +@itemize @bullet +@item +a generic function (the most common case) + +@item +a procedure + +@item +a primitive generic (@pxref{Extending Guiles Primitives}) +@end itemize + +By defining further methods for @code{add-method!}, you can +theoretically handle adding methods to further types of target. +@end itemize + +@node Generic Function Invocation +@section Generic Function Invocation + +[ *fixme* Description required here. ] + +@code{apply-generic} + +@itemize @bullet +@item +@code{no-method} + +@item +@code{compute-applicable-methods} + +@item +@code{sort-applicable-methods} + +@item +@code{apply-methods} + +@item +@code{no-applicable-method} +@end itemize + +@code{sort-applicable-methods} + +@itemize @bullet +@item +@code{method-more-specific?} +@end itemize + +@code{apply-methods} + +@itemize @bullet +@item +@code{apply-method} +@end itemize + +@code{next-method} + +@itemize @bullet +@item +@code{no-next-method} +@end itemize + +@node Tutorial, Index, MOP Specification, Top +@chapter Tutorial +@include goops-tutorial.texi + +@node Index, Concept Index, Tutorial, Top +@chapter Index +@page +@node Concept Index, Function and Variable Index, Index, Top +@unnumberedsec Concept Index + +@printindex cp + +@node Function and Variable Index, , Concept Index, Top +@unnumberedsec Function and Variable Index + +@printindex fn + +@summarycontents +@contents +@bye diff --git a/doc/goops/hierarchy.eps b/doc/goops/hierarchy.eps new file mode 100644 index 000000000..7b1a98605 --- /dev/null +++ b/doc/goops/hierarchy.eps @@ -0,0 +1,127 @@ +%!PS-Adobe-2.0 EPSF +%%Title: /tmp/xfig-fig016295 +%%Creator: fig2dev +%%CreationDate: Fri Jun 10 23:18:16 1994 +%%For: eg@kaolin (Erick Gallesio) +%%BoundingBox: 0 0 361 217 +%%Pages: 0 +%%EndComments +/$F2psDict 200 dict def +$F2psDict begin +$F2psDict /mtrx matrix put +/l {lineto} bind def +/m {moveto} bind def +/s {stroke} bind def +/n {newpath} bind def +/gs {gsave} bind def +/gr {grestore} bind def +/clp {closepath} bind def +/graycol {dup dup currentrgbcolor 4 -2 roll mul 4 -2 roll mul +4 -2 roll mul setrgbcolor} bind def +/col-1 {} def +/col0 {0 0 0 setrgbcolor} bind def +/col1 {0 0 1 setrgbcolor} bind def +/col2 {0 1 0 setrgbcolor} bind def +/col3 {0 1 1 setrgbcolor} bind def +/col4 {1 0 0 setrgbcolor} bind def +/col5 {1 0 1 setrgbcolor} bind def +/col6 {1 1 0 setrgbcolor} bind def +/col7 {1 1 1 setrgbcolor} bind def + end +/$F2psBegin {$F2psDict begin /$F2psEnteredState save def} def +/$F2psEnd {$F2psEnteredState restore end} def +%%EndProlog + +$F2psBegin +0 setlinecap 0 setlinejoin +-216.0 288.0 translate 0.900 -0.900 scale +0.500 setlinewidth +n 309 159 m 309 159 l gs col-1 s gr +n 246.401 216.889 m 244.000 209.000 l 249.831 214.831 l gs 2 setlinejoin col-1 s gr +% Polyline +n 244 209 m 274 259 l gs col-1 s gr +n 298.169 214.831 m 304.000 209.000 l 301.599 216.889 l gs 2 setlinejoin col-1 s gr +% Polyline +n 304 209 m 274 259 l gs col-1 s gr +n 255.721 213.778 m 249.000 209.000 l 257.179 210.053 l gs 2 setlinejoin col-1 s gr +% Polyline +n 249 209 m 364 254 l gs col-1 s gr +n 370.312 216.376 m 374.000 209.000 l 374.217 217.243 l gs 2 setlinejoin col-1 s gr +% Polyline +n 374 209 m 364 254 l gs col-1 s gr +n 283.772 280.725 m 279.000 274.000 l 286.376 277.688 l gs 2 setlinejoin col-1 s gr +% Polyline +n 279 274 m 314 304 l gs col-1 s gr +n 351.457 272.333 m 359.000 269.000 l 353.913 275.490 l gs 2 setlinejoin col-1 s gr +% Polyline +n 359 269 m 314 304 l gs col-1 s gr +n 300.950 165.789 m 309.000 164.000 l 302.739 169.367 l gs 2 setlinejoin col-1 s gr +% Polyline +n 309 164 m 249 194 l gs col-1 s gr +n 307.000 172.000 m 309.000 164.000 l 311.000 172.000 l gs 2 setlinejoin col-1 s gr +% Polyline +n 309 164 m 309 199 l gs col-1 s gr +n 315.261 169.367 m 309.000 164.000 l 317.050 165.789 l gs 2 setlinejoin col-1 s gr +% Polyline +n 309 164 m 379 199 l gs col-1 s gr +n 406.949 101.701 m 404.000 94.000 l 410.226 99.407 l gs 2 setlinejoin col-1 s gr +% Polyline +n 404 94 m 439 144 l gs col-1 s gr +n 410.363 99.245 m 404.000 94.000 l 412.083 95.634 l gs 2 setlinejoin col-1 s gr +% Polyline +n 404 94 m 509 144 l gs col-1 s gr +n 411.173 98.068 m 404.000 94.000 l 412.243 94.214 l gs 2 setlinejoin col-1 s gr +% Polyline +n 404 94 m 584 144 l gs col-1 s gr +n 396.075 96.277 m 404.000 94.000 l 398.079 99.739 l gs 2 setlinejoin col-1 s gr +% Polyline +n 404 94 m 309 149 l gs col-1 s gr +% Polyline +n 584 229 m 584 204 l gs col-1 s gr +n 582.000 212.000 m 584.000 204.000 l 586.000 212.000 l gs 2 setlinejoin col-1 s gr +% Polyline +n 584 189 m 584 159 l gs col-1 s gr +n 582.000 167.000 m 584.000 159.000 l 586.000 167.000 l gs 2 setlinejoin col-1 s gr +/Times-Bold findfont 12.00 scalefont setfont +239 209 m +gs 1 -1 scale (A) col-1 show gr +/Times-Bold findfont 12.00 scalefont setfont +274 274 m +gs 1 -1 scale (D) col-1 show gr +/Times-Bold findfont 12.00 scalefont setfont +359 269 m +gs 1 -1 scale (E) col-1 show gr +/Times-Bold findfont 12.00 scalefont setfont +304 209 m +gs 1 -1 scale (B) col-1 show gr +/Times-Bold findfont 12.00 scalefont setfont +374 209 m +gs 1 -1 scale (C) col-1 show gr +/Times-Bold findfont 12.00 scalefont setfont +314 319 m +gs 1 -1 scale (F) col-1 show gr +/Times-Bold findfont 12.00 scalefont setfont +289 159 m +gs 1 -1 scale () col-1 show gr +/Times-Bold findfont 12.00 scalefont setfont +389 89 m +gs 1 -1 scale () col-1 show gr +/Times-Bold findfont 12.00 scalefont setfont +424 154 m +gs 1 -1 scale () col-1 show gr +/Times-Bold findfont 12.00 scalefont setfont +474 154 m +gs 1 -1 scale () col-1 show gr +/Times-Bold findfont 12.00 scalefont setfont +559 154 m +gs 1 -1 scale () col-1 show gr +/Times-Bold findfont 12.00 scalefont setfont +629 154 m +gs 1 -1 scale (...) col-1 show gr +/Times-Bold findfont 12.00 scalefont setfont +569 199 m +gs 1 -1 scale () col-1 show gr +/Times-Bold findfont 12.00 scalefont setfont +559 239 m +gs 1 -1 scale () col-1 show gr +$F2psEnd diff --git a/doc/goops/hierarchy.txt b/doc/goops/hierarchy.txt new file mode 100644 index 000000000..c7992df7b --- /dev/null +++ b/doc/goops/hierarchy.txt @@ -0,0 +1,14 @@ + + / \\\_____________________ + / \\___________ \ + / \ \ \ + + / | \ | + / | \ | + A B C + |\__/__ | | + \ / \ / | + D E + \ / | + F | + diff --git a/doc/goops/mop.text b/doc/goops/mop.text new file mode 100644 index 000000000..0180f2c1e --- /dev/null +++ b/doc/goops/mop.text @@ -0,0 +1,66 @@ +*** NOTE: This information needs updating! *** + +P - procedure +L - local procedure +S - syntax +G - generic +M - method + +define-class (S) + make-class (S) + ensure-metaclass (P) + ensure-metaclass-with-supers (P) + make (G) + ensure-class (P) + make (G) + class-redefinition (G) + remove-class-accessors (G) + update-direct-method (G) + update-direct-subclass (G) + +define-generic (S) + make-generic-function (S) + ensure-generic-function (P) + make (G) + +define-method (S) + ensure-method (P) + ensure-generic-function (P) + make (G) + make (G) + add-method (P) + +method (S) + ensure-method (P) + +initialize (class) (M) + compute-cpl (P) + compute-slots (G) + compute-getters-n-setters (P) + compute-slot-init-function (L) + compute-get-n-set (G) + compute-slot-accessors (P) + ensure-method (P) + %inherit-magic! (P) + %prep-layout! (P) + +initialize (generic) (M) + make (G) + +change-class (G) + change-object-class (P) + update-instance-for-different-class (G) + +make = make-instance (G) + allocate-instance (G) + %allocate-instance (P) + initialize (G) + %initialize-object (P) + +apply-generic (G) + compute-applicable-methods (G) + find-method (P) + sort-applicable-methods (G) + sort (P) + apply-methods (G) + apply-method (G) diff --git a/doc/guile-tut.texi b/doc/guile-tut.texi deleted file mode 100644 index e69de29bb..000000000 diff --git a/doc/hierarchy.eps b/doc/hierarchy.eps deleted file mode 100644 index e69de29bb..000000000 diff --git a/doc/hierarchy.txt b/doc/hierarchy.txt deleted file mode 100644 index e69de29bb..000000000 diff --git a/doc/indices.texi b/doc/indices.texi deleted file mode 100644 index e69de29bb..000000000 diff --git a/doc/misc-modules.texi b/doc/misc-modules.texi deleted file mode 100644 index e69de29bb..000000000 diff --git a/doc/mop.text b/doc/mop.text deleted file mode 100644 index e69de29bb..000000000 diff --git a/doc/new-docstrings.texi b/doc/new-docstrings.texi deleted file mode 100644 index e69de29bb..000000000 diff --git a/doc/posix.texi b/doc/posix.texi deleted file mode 100644 index e69de29bb..000000000 diff --git a/doc/preface.texi b/doc/preface.texi deleted file mode 100644 index e69de29bb..000000000 diff --git a/doc/r5rs.texi b/doc/r5rs.texi deleted file mode 100644 index e69de29bb..000000000 diff --git a/doc/r5rs/.cvsignore b/doc/r5rs/.cvsignore new file mode 100644 index 000000000..8eaa8267a --- /dev/null +++ b/doc/r5rs/.cvsignore @@ -0,0 +1,23 @@ +Makefile +Makefile.in +stamp-vti +stamp-vti.1 +*.log +*.dvi +*.aux +*.toc +*.cp +*.fn +*.vr +*.tp +*.ky +*.pg +*.cps +*.fns +*.tps +*.vrs +*.ps +*.info* +*.html +version.texi +version-tutorial.texi diff --git a/doc/r5rs/r5rs.texi b/doc/r5rs/r5rs.texi new file mode 100644 index 000000000..a33771190 --- /dev/null +++ b/doc/r5rs/r5rs.texi @@ -0,0 +1,8538 @@ +\input texinfo @c -*-texinfo-*- +@c %**start of header +@setfilename r5rs.info +@settitle Revised(5) Scheme + +@c This copy of r5rs.texi differs from Aubrey Jaffer's master copy +@c by a set of changes to allow the building of r5rs.dvi from r5rs.texi. +@c Aubrey Jaffer's view - which I agree with - is that, given that +@c people have the option of building r5rs.dvi from the original +@c LaTeX distribution for R5RS, it is not worth fixing his master +@c copy of r5rs.texi and the tool which autogenerates it. On the +@c other hand, it is a marginal convenience for people to be able to +@c build hardcopy from r5rs.texi, even if the results are less good +@c than with the original LaTeX. Hence the following fixes. +@c (lines 714, 725, 728, 1614, 2258): Remove invalid parentheses from +@c @deffn statements. +@c (line 2316): Change @deffnx to @deffn, and insert `@end deffn' to +@c terminate preceding @deffn. +@c (line 7320): Insert `@c ' at beginning of lines that are intended +@c to be @ignore'd. +@c +@c NJ 2001/1/26 + +@c \documentclass[twoside]{algol60} + +@c \pagestyle{headings} +@c \showboxdepth=0 + + + +@c \def\headertitle{Revised$^{5}$ Scheme} +@c \def\integerversion{5} + +@c Sizes and dimensions + +@c \topmargin -.375in % Nominal distance from top of page to top of + +@c box containing running head. +@c \headsep 15pt % Space between running head and text. + +@c \textheight 663pt % Height of text (including footnotes and figures, + +@c excluding running head and foot). + +@c \textwidth 523pt % Width of text line. +@c \columnsep 15pt % Space between columns +@c \columnseprule 0pt % Width of rule between columns. + +@c \parskip 5pt plus 2pt minus 2pt % Extra vertical space between paragraphs. +@c \parindent 0pt % Width of paragraph indentation. +@c \topsep 0pt plus 2pt % Extra vertical space, in addition to + +@c \parskip, added above and below list and + +@c paragraphing environments. + +@c \oddsidemargin -.5in % Left margin on odd-numbered pages. +@c \evensidemargin -.5in % Left margin on even-numbered pages. + +@c % End of sizes and dimensions + +@paragraphindent 0 +@c %**end of header +@c syncodeindex fn cp + +@ifinfo +@dircategory The Algorithmic Language Scheme +@direntry +* R5RS: (r5rs). The Revised(5) Report on Scheme. +@end direntry +@end ifinfo + + +@c \parindent 0pt %!! 15pt % Width of paragraph indentation. + + @b{20 February 1998} +@c \hfil \today{} + +@c @include{first} +@titlepage + +@c HTML first page +@title Scheme +@subtitle Revised(5) Report on the Algorithmic Language Scheme +@c First page + +@c \thispagestyle{empty} + +@c \todo{"another" report?} + + +@author R@sc{ICHARD} K@sc{ELSEY}, W@sc{ILLIAM} C@sc{LINGER, AND} J@sc{ONATHAN} R@sc{EES} (@i{Editors}) +@author H. A@sc{BELSON} +@author R. K. D@sc{YBVIG} +@author C. T. H@sc{AYNES} +@author G. J. R@sc{OZAS} +@author N. I. A@sc{DAMS IV} +@author D. P. F@sc{RIEDMAN} +@author E. K@sc{OHLBECKER} +@author G. L. S@sc{TEELE} J@sc{R}. +@author D. H. B@sc{ARTLEY} +@author R. H@sc{ALSTEAD} +@author D. O@sc{XLEY} +@author G. J. S@sc{USSMAN} +@author G. B@sc{ROOKS} +@author C. H@sc{ANSON} +@author K. M. P@sc{ITMAN} +@author M. W@sc{AND} +@author + + +@c {\it Dedicated to the Memory of ALGOL 60} +@i{Dedicated to the Memory of Robert Hieb} +@c [For the macros in R5RS -RK] + + + + +@unnumbered Summary + + +The report gives a defining description of the programming language +Scheme. Scheme is a statically scoped and properly tail-recursive +dialect of the Lisp programming language invented by Guy Lewis +Steele Jr.@: and Gerald Jay Sussman. It was designed to have an +exceptionally clear and simple semantics and few different ways to +form expressions. A wide variety of programming paradigms, including +imperative, functional, and message passing styles, find convenient +expression in Scheme. + +The introduction offers a brief history of the language and of +the report. + +The first three chapters present the fundamental ideas of the +language and describe the notational conventions used for describing the +language and for writing programs in the language. + +Chapters @ref{Expressions} and @ref{Program structure} describe +the syntax and semantics of expressions, programs, and definitions. + +Chapter @ref{Standard procedures} describes Scheme's built-in +procedures, which include all of the language's data manipulation and +input/output primitives. + +Chapter @ref{Formal syntax and semantics} provides a formal syntax for Scheme +written in extended BNF, along with a formal denotational semantics. +An example of the use of the language follows the formal syntax and +semantics. + +The report concludes with a list of references and an +alphabetic index. + +@ignore todo +expand the summary so that it fills up the column. +@end ignore + + +@c \vfill +@c \begin{center} +@c {\large \bf +@c *** DRAFT*** \\ +@c %August 31, 1989 +@c \today +@c }\end{center} + + + + + +@c \addvspace{3.5pt} % don't shrink this gap +@c \renewcommand{\tocshrink}{-3.5pt} % value determined experimentally + + + + + + +@page + +@end titlepage + +@c INFO first page +@ifinfo + +@c First page + +@c \thispagestyle{empty} + +@c \todo{"another" report?} + + +@node top, Introduction, (dir), (dir) +@top Revised(5) Report on the Algorithmic Language Scheme + +@sp 1 + + +@center @c begin-tabular +@quotation +@multitable @columnfractions 0.25 0.25 0.25 0.25 +@item +@center R@sc{ICHARD} K@sc{ELSEY}, W@sc{ILLIAM} C@sc{LINGER, AND} J@sc{ONATHAN} R@sc{EES} (@i{Editors}) +@item H. A@sc{BELSON} @tab R. K. D@sc{YBVIG} @tab C. T. H@sc{AYNES} @tab G. J. R@sc{OZAS} +@item N. I. A@sc{DAMS IV} @tab D. P. F@sc{RIEDMAN} @tab E. K@sc{OHLBECKER} @tab G. L. S@sc{TEELE} J@sc{R}. +@item D. H. B@sc{ARTLEY} @tab R. H@sc{ALSTEAD} @tab D. O@sc{XLEY} @tab G. J. S@sc{USSMAN} +@item G. B@sc{ROOKS} @tab C. H@sc{ANSON} @tab K. M. P@sc{ITMAN} @tab M. W@sc{AND} +@item +@end multitable +@end quotation + + +@sp 2 + +@c {\it Dedicated to the Memory of ALGOL 60} +@i{Dedicated to the Memory of Robert Hieb} +@c [For the macros in R5RS -RK] + +@sp 3 + + + + +@majorheading Summary + + +The report gives a defining description of the programming language +Scheme. Scheme is a statically scoped and properly tail-recursive +dialect of the Lisp programming language invented by Guy Lewis +Steele Jr.@: and Gerald Jay Sussman. It was designed to have an +exceptionally clear and simple semantics and few different ways to +form expressions. A wide variety of programming paradigms, including +imperative, functional, and message passing styles, find convenient +expression in Scheme. + +The introduction offers a brief history of the language and of +the report. + +The first three chapters present the fundamental ideas of the +language and describe the notational conventions used for describing the +language and for writing programs in the language. + +Chapters @ref{Expressions} and @ref{Program structure} describe +the syntax and semantics of expressions, programs, and definitions. + +Chapter @ref{Standard procedures} describes Scheme's built-in +procedures, which include all of the language's data manipulation and +input/output primitives. + +Chapter @ref{Formal syntax and semantics} provides a formal syntax for Scheme +written in extended BNF, along with a formal denotational semantics. +An example of the use of the language follows the formal syntax and +semantics. + +The report concludes with a list of references and an +alphabetic index. + +@ignore todo +expand the summary so that it fills up the column. +@end ignore + + +@c \vfill +@c \begin{center} +@c {\large \bf +@c *** DRAFT*** \\ +@c %August 31, 1989 +@c \today +@c }\end{center} + + + + + +@c \addvspace{3.5pt} % don't shrink this gap +@c \renewcommand{\tocshrink}{-3.5pt} % value determined experimentally + +@unnumbered Contents + +@menu +* Introduction:: +* Overview of Scheme:: +* Lexical conventions:: +* Basic concepts:: +* Expressions:: +* Program structure:: +* Standard procedures:: +* Formal syntax and semantics:: +* Notes:: +* Additional material:: +* Example:: +* Bibliography:: +* Index:: +@end menu + + + + + +@page + +@end ifinfo + + +@c @include{intro} +@node Introduction, Overview of Scheme, top, top +@unnumbered Introduction + +@menu +* Background:: +* Acknowledgements:: +@end menu + + + + +Programming languages should be designed not by piling feature on top of +feature, but by removing the weaknesses and restrictions that make additional +features appear necessary. Scheme demonstrates that a very small number +of rules for forming expressions, with no restrictions on how they are +composed, suffice to form a practical and efficient programming language +that is flexible enough to support most of the major programming +paradigms in use today. + +@c Scheme has influenced the evolution of Lisp. +Scheme +was one of the first programming languages to incorporate first class +procedures as in the lambda calculus, thereby proving the usefulness of +static scope rules and block structure in a dynamically typed language. +Scheme was the first major dialect of Lisp to distinguish procedures +from lambda expressions and symbols, to use a single lexical +environment for all variables, and to evaluate the operator position +of a procedure call in the same way as an operand position. By relying +entirely on procedure calls to express iteration, Scheme emphasized the +fact that tail-recursive procedure calls are essentially goto's that +pass arguments. Scheme was the first widely used programming language to +embrace first class escape procedures, from which all previously known +sequential control structures can be synthesized. A subsequent +version of Scheme introduced the concept of exact and inexact numbers, +an extension of Common Lisp's generic arithmetic. +More recently, Scheme became the first programming language to support +hygienic macros, which permit the syntax of a block-structured language +to be extended in a consistent and reliable manner. +@c A few +@c of these innovations have recently been incorporated into Common Lisp, while +@c others remain to be adopted. + +@ignore todo +Ramsdell: +I would like to make a few comments on presentation. The most +important comment is about section organization. Newspaper writers +spend most of their time writing the first three paragraphs of any +article. This part of the article is often the only part read by +readers, and is important in enticing readers to continue. In the +same way, The first page is most likely to be the only page read by +many SIGPLAN readers. If I had my choice of what I would ask them to +read, it would be the material in section 1.1, the Semantics section +that notes that scheme is lexically scoped, tail recursive, weakly +typed, ... etc. I would expand on the discussion on continuations, +as they represent one important difference between Scheme and other +languages. The introduction, with its history of scheme, its history +of scheme reports and meetings, and acknowledgements giving names of +people that the reader will not likely know, is not that one page I +would like all to read. I suggest moving the history to the back of +the report, and use the first couple of pages to convince the reader +that the language documented in this report is worth studying. + +@end ignore + + +@node Background, Acknowledgements, Introduction, Introduction +@unnumberedsec Background + + +The first description of Scheme was written in +1975 [Scheme75]. A revised report [Scheme78] +@ignore todo +italicize or not? +@end ignore + appeared in 1978, which described the evolution +of the language as its MIT implementation was upgraded to support an +innovative compiler [Rabbit]. Three distinct projects began in +1981 and 1982 to use variants of Scheme for courses at MIT, Yale, and +Indiana University [Rees82], [MITScheme], [Scheme311]. An introductory +computer science textbook using Scheme was published in +1984 [SICP]. + +@c \vest As might be expected of a language used primarily for education and +@c research, Scheme has always evolved rapidly. This was no problem when +@c Scheme was used only within MIT, but +As Scheme became more widespread, +local dialects began to diverge until students and researchers +occasionally found it difficult to understand code written at other +sites. +Fifteen representatives of the major implementations of Scheme therefore +met in October 1984 to work toward a better and more widely accepted +standard for Scheme. +@c Participating in this workshop were Hal Abelson, Norman Adams, David +@c Bartley, Gary Brooks, William Clinger, Daniel Friedman, Robert Halstead, +@c Chris Hanson, Christopher Haynes, Eugene Kohlbecker, Don Oxley, Jonathan Rees, +@c Guillermo Rozas, Gerald Jay Sussman, and Mitchell Wand. Kent Pitman +@c made valuable contributions to the agenda for the workshop but was +@c unable to attend the sessions. + +@c Subsequent electronic mail discussions and committee work completed the +@c definition of the language. +@c Gerry Sussman drafted the section on numbers, Chris Hanson drafted the +@c sections on characters and strings, and Gary Brooks and William Clinger +@c drafted the sections on input and output. +@c William Clinger recorded the decisions of the workshop and +@c compiled the pieces into a coherent document. +@c The ``Revised revised report on Scheme''~\cite{RRRS} +Their report [RRRS] +was published at MIT and Indiana University in the summer of 1985. +Further revision took place in the spring of 1986 [R3RS], +@c , again accomplished +@c almost entirely by electronic mail, resulted in the present report. +and in the spring of 1988 [R4RS]. +The present report reflects further revisions agreed upon in a meeting +at Xerox PARC in June 1992. + +@c \vest The number 3 in the title is part of the title, not a reference to +@c a footnote. The word ``revised'' is raised to the third power because +@c the report is a revision of a report that was already twice revised. + +@ignore todo +Write an editors' note? +@end ignore + + + +@sp 3 + +We intend this report to belong to the entire Scheme community, and so +we grant permission to copy it in whole or in part without fee. In +particular, we encourage implementors of Scheme to use this report as +a starting point for manuals and other documentation, modifying it as +necessary. + + + + +@node Acknowledgements, , Background, Introduction +@unnumberedsec Acknowledgements + + +We would like to thank the following people for their help: Alan Bawden, Michael +Blair, George Carrette, Andy Cromarty, Pavel Curtis, Jeff Dalton, Olivier Danvy, +Ken Dickey, Bruce Duba, Marc Feeley, +Andy Freeman, Richard Gabriel, Yekta G"ursel, Ken Haase, Robert +Hieb, Paul Hudak, Morry Katz, Chris Lindblad, Mark Meyer, Jim Miller, Jim Philbin, +John Ramsdell, Mike Shaff, Jonathan Shapiro, Julie Sussman, +Perry Wagle, Daniel Weise, Henry Wu, and Ozan Yigit. +We thank Carol Fessenden, Daniel +Friedman, and Christopher Haynes for permission to use text from the Scheme 311 +version 4 reference manual. We thank Texas Instruments, Inc. for permission to +use text from the @emph{TI Scheme Language Reference Manual}[TImanual85]. +We gladly acknowledge the influence of manuals for MIT Scheme[MITScheme], +T[Rees84], Scheme 84[Scheme84],Common Lisp[CLtL], +and Algol 60[Naur63]. + +We also thank Betty Dexter for the extreme effort she put into +setting this report in @TeX{}, and Donald Knuth for designing the program +that caused her troubles. + +The Artificial Intelligence Laboratory of the +Massachusetts Institute of Technology, the Computer Science +Department of Indiana University, the Computer and Information +Sciences Department of the University of Oregon, and the NEC Research +Institute supported the preparation of this report. Support for the MIT +work was provided in part by +the Advanced Research Projects Agency of the Department of Defense under Office +of Naval Research contract N00014-80-C-0505. Support for the Indiana +University work was provided by NSF grants NCS 83-04567 and NCS +83-03325. + + + + +@sp 2 + +@c \clearchapterstar{Description of the language} %\unskip\vskip -2ex +@c @include{struct} + +@c 1. Structure of the language + +@node Overview of Scheme, Lexical conventions, Introduction, top +@chapter Overview of Scheme + +@menu +* Semantics:: +* Syntax:: +* Notation and terminology:: +@end menu + + +@node Semantics, Syntax, Overview of Scheme, Overview of Scheme +@section Semantics + + + +This section gives an overview of Scheme's semantics. A +detailed informal semantics is the subject of +chapters @ref{Basic concepts} through @ref{Standard procedures}. For reference +purposes, section @ref{Formal semantics} provides a formal +semantics of Scheme. + +Following Algol, Scheme is a statically scoped programming +language. Each use of a variable is associated with a lexically +apparent binding of that variable. + +Scheme has latent as opposed to manifest types. Types +are associated with values (also called objects) rather than +@cindex @w{object} +with variables. (Some authors refer to languages with latent types as +weakly typed or dynamically typed languages.) Other languages with +latent types are APL, Snobol, and other dialects of Lisp. Languages +with manifest types (sometimes referred to as strongly typed or +statically typed languages) include Algol 60, Pascal, and C. + +All objects created in the course of a Scheme computation, including +procedures and continuations, have unlimited extent. +No Scheme object is ever destroyed. The reason that +implementations of Scheme do not (usually!) run out of storage is that +they are permitted to reclaim the storage occupied by an object if +they can prove that the object cannot possibly matter to any future +computation. Other languages in which most objects have unlimited +extent include APL and other Lisp dialects. + +Implementations of Scheme are required to be properly tail-recursive. +This allows the execution of an iterative computation in constant space, +even if the iterative computation is described by a syntactically +recursive procedure. Thus with a properly tail-recursive implementation, +iteration can be expressed using the ordinary procedure-call +mechanics, so that special iteration constructs are useful only as +syntactic sugar. See section @ref{Proper tail recursion}. + +Scheme procedures are objects in their own right. Procedures can be +created dynamically, stored in data structures, returned as results of +procedures, and so on. Other languages with these properties include +Common Lisp and ML. +@ignore todo +Rozas: Scheme had them first. +@end ignore + + +One distinguishing feature of Scheme is that continuations, which +in most other languages only operate behind the scenes, also have +``first-class'' status. Continuations are useful for implementing a +wide variety of advanced control constructs, including non-local exits, +backtracking, and coroutines. See section @ref{Control features}. + +Arguments to Scheme procedures are always passed by value, which +means that the actual argument expressions are evaluated before the +procedure gains control, whether the procedure needs the result of the +evaluation or not. ML, C, and APL are three other languages that always +pass arguments by value. +This is distinct from the lazy-evaluation semantics of Haskell, +or the call-by-name semantics of Algol 60, where an argument +expression is not evaluated unless its value is needed by the +procedure. + +@ignore todo +Lisp's call by value should be explained more +accurately. What's funny is that all values are references. +@end ignore + + +Scheme's model of arithmetic is designed to remain as independent as +possible of the particular ways in which numbers are represented within a +computer. In Scheme, every integer is a rational number, every rational is a +real, and every real is a complex number. Thus the distinction between integer +and real arithmetic, so important to many programming languages, does not +appear in Scheme. In its place is a distinction between exact arithmetic, +which corresponds to the mathematical ideal, and inexact arithmetic on +approximations. As in Common Lisp, exact arithmetic is not limited to +integers. + +@node Syntax, Notation and terminology, Semantics, Overview of Scheme +@section Syntax + + +Scheme, like most dialects of Lisp, employs a fully parenthesized prefix +notation for programs and (other) data; the grammar of Scheme generates a +sublanguage of the language used for data. An important +consequence of this simple, uniform representation is the susceptibility of +Scheme programs and data to uniform treatment by other Scheme programs. +For example, the @samp{eval} procedure evaluates a Scheme program expressed +as data. + +The @samp{read} procedure performs syntactic as well as lexical decomposition of +the data it reads. The @samp{read} procedure parses its input as data +(section @pxref{External representation}), not as program. + +The formal syntax of Scheme is described in section @ref{Formal syntax}. + + +@node Notation and terminology, , Syntax, Overview of Scheme +@section Notation and terminology + +@menu +* Primitive; library; and optional features:: +* Error situations and unspecified behavior:: +* Entry format:: +* Evaluation examples:: +* Naming conventions:: +@end menu + + + +@node Primitive; library; and optional features, Error situations and unspecified behavior, Notation and terminology, Notation and terminology +@subsection Primitive; library; and optional features + + + +It is required that every implementation of Scheme support all +features that are not marked as being @dfn{optional}. Implementations are +@cindex @w{optional} +free to omit optional features of Scheme or to add extensions, +provided the extensions are not in conflict with the language reported +here. In particular, implementations must support portable code by +providing a syntactic mode that preempts no lexical conventions of this +report. + +To aid in understanding and implementing Scheme, some features are marked +as @dfn{library}. These can be easily implemented in terms of the other, +@cindex @w{library} +primitive, features. They are redundant in the strict sense of +the word, but they capture common patterns of usage, and are therefore +provided as convenient abbreviations. + +@node Error situations and unspecified behavior, Entry format, Primitive; library; and optional features, Notation and terminology +@subsection Error situations and unspecified behavior + + + +@cindex @w{error} +When speaking of an error situation, this report uses the phrase ``an +error is signalled'' to indicate that implementations must detect and +report the error. If such wording does not appear in the discussion of +an error, then implementations are not required to detect or report the +error, though they are encouraged to do so. An error situation that +implementations are not required to detect is usually referred to simply +as ``an error.'' + +For example, it is an error for a procedure to be passed an argument that +the procedure is not explicitly specified to handle, even though such +domain errors are seldom mentioned in this report. Implementations may +extend a procedure's domain of definition to include such arguments. + +This report uses the phrase ``may report a violation of an +implementation restriction'' to indicate circumstances under which an +implementation is permitted to report that it is unable to continue +execution of a correct program because of some restriction imposed by the +implementation. Implementation restrictions are of course discouraged, +but implementations are encouraged to report violations of implementation +restrictions. +@cindex @w{implementation restriction} + +For example, an implementation may report a violation of an +implementation restriction if it does not have enough storage to run a +program. + +If the value of an expression is said to be ``unspecified,'' then +the expression must evaluate to some object without signalling an error, +but the value depends on the implementation; this report explicitly does +not say what value should be returned. +@cindex @w{unspecified} + +@ignore todo +Talk about unspecified behavior vs. unspecified values. +@end ignore + + +@ignore todo +Look at KMP's situations paper. +@end ignore + + + +@node Entry format, Evaluation examples, Error situations and unspecified behavior, Notation and terminology +@subsection Entry format + + +Chapters @ref{Expressions} and @ref{Standard procedures} are organized +into entries. Each entry describes one language feature or a group of +related features, where a feature is either a syntactic construct or a +built-in procedure. An entry begins with one or more header lines of the form + + +@noindent +@deffn {@var{category}} @var{template} + +@end deffn + +for required, primitive features, or + + +@noindent +@deffn {@var{qualifier} @var{category}} @var{template} + +@end deffn + +where @var{qualifier} is either ``library'' or ``optional'' as defined + in section @ref{Primitive; library; and optional features}. + +If @var{category} is ``syntax'', the entry describes an expression +type, and the template gives the syntax of the expression type. +Components of expressions are designated by syntactic variables, which +are written using angle brackets, for example, @r{}, +@r{}. Syntactic variables should be understood to denote segments of +program text; for example, @r{} stands for any string of +characters which is a syntactically valid expression. The notation + +@format + @r{} @dots{} +@end format + +indicates zero or more occurrences of a @r{}, and + +@format + @r{} @r{} @dots{} +@end format + +indicates one or more occurrences of a @r{}. + +If @var{category} is ``procedure'', then the entry describes a procedure, and +the header line gives a template for a call to the procedure. Argument +names in the template are @var{italicized}. Thus the header line + + +@noindent +@deffn {procedure} vector-ref @var{vector} @var{k} + +@end deffn + +indicates that the built-in procedure @t{vector-ref} takes +two arguments, a vector @var{vector} and an exact non-negative integer +@var{k} (see below). The header lines + + +@noindent + +@deffn {procedure} make-vector @var{k} + + +@deffnx {procedure} make-vector @var{k} @var{fill} + +@end deffn + +indicate that the @t{make-vector} procedure must be defined to take +either one or two arguments. + + +It is an error for an operation to be presented with an argument that it +is not specified to handle. For succinctness, we follow the convention +that if an argument name is also the name of a type listed in +section @ref{Disjointness of types}, then that argument must be of the named type. +For example, the header line for @t{vector-ref} given above dictates that the +first argument to @t{vector-ref} must be a vector. The following naming +conventions also imply type restrictions: +@c \newcommand{\foo}[1]{\vr{#1}, \vri{#1}, $\ldots$ \vrj{#1}, $\ldots$} + + +@center @c begin-tabular +@quotation +@table @asis +@item @var{obj} +any object +@item @var{list}, @var{list1}, @dots{} @var{listj}, @dots{} +list (see section @pxref{Pairs and lists}) +@item @var{z}, @var{z1}, @dots{} @var{zj}, @dots{} +complex number +@item @var{x}, @var{x1}, @dots{} @var{xj}, @dots{} +real number +@item @var{y}, @var{y1}, @dots{} @var{yj}, @dots{} +real number +@item @var{q}, @var{q1}, @dots{} @var{qj}, @dots{} +rational number +@item @var{n}, @var{n1}, @dots{} @var{nj}, @dots{} +integer +@item @var{k}, @var{k1}, @dots{} @var{kj}, @dots{} +exact non-negative integer +@item +@end table +@end quotation + + + + +@ignore todo +Provide an example entry?? +@end ignore + + + +@node Evaluation examples, Naming conventions, Entry format, Notation and terminology +@subsection Evaluation examples + + +The symbol ``@result{}'' used in program examples should be read +``evaluates to.'' For example, + + +@example + +(* 5 8) ==> 40 + +@end example + + +means that the expression @t{(* 5 8)} evaluates to the object @t{40}. +Or, more precisely: the expression given by the sequence of characters +``@t{(* 5 8)}'' evaluates, in the initial environment, to an object +that may be represented externally by the sequence of characters ``@t{40}''. See section @ref{External representations} for a discussion of external +representations of objects. + +@node Naming conventions, , Evaluation examples, Notation and terminology +@subsection Naming conventions + + +By convention, the names of procedures that always return a boolean +value usually end +in ``@code{?}''. Such procedures are called predicates. +@vindex @w{?} + +By convention, the names of procedures that store values into previously +allocated locations (see section @pxref{Storage model}) usually end in +``@code{!}''. +@vindex @w{!} +Such procedures are called mutation procedures. +By convention, the value returned by a mutation procedure is unspecified. + +By convention, ``@code{->}'' appears within the names of procedures that +@vindex @w{->} +take an object of one type and return an analogous object of another type. +For example, @samp{list->vector} takes a list and returns a vector whose +elements are the same as those of the list. + + + +@ignore todo +Terms that need defining: thunk, command (what else?). +@end ignore + + +@c @include{lex} + +@c Lexical structure + +@c %\vfill\eject +@node Lexical conventions, Basic concepts, Overview of Scheme, top +@chapter Lexical conventions + +@menu +* Identifiers:: +* Whitespace and comments:: +* Other notations:: +@end menu + + +This section gives an informal account of some of the lexical +conventions used in writing Scheme programs. For a formal syntax of +Scheme, see section @ref{Formal syntax}. + +Upper and lower case forms of a letter are never distinguished +except within character and string constants. For example, @samp{Foo} is +the same identifier as @samp{FOO}, and @t{#x1AB} is the same number as +@t{#X1ab}. + +@node Identifiers, Whitespace and comments, Lexical conventions, Lexical conventions +@section Identifiers + + + +Most identifiers allowed by other programming +@cindex @w{identifier} +languages are also acceptable to Scheme. The precise rules for forming +identifiers vary among implementations of Scheme, but in all +implementations a sequence of letters, digits, and ``extended alphabetic +characters'' that begins with a character that cannot begin a number is +an identifier. In addition, @code{+}, @code{-}, and @code{...} are identifiers. +@vindex @w{...} +@vindex @w{-} +@vindex @w{+} +Here are some examples of identifiers: + + +@example + +lambda q +list->vector soup ++ V17a +<=? a34kTMNs +the-word-recursion-has-many-meanings + +@end example + + +Extended alphabetic characters may be used within identifiers as if +they were letters. The following are extended alphabetic characters: + + +@example + +! $ % & * + - . / : < = > ? @@ ^ _ ~ +@end example + + +See section @ref{Lexical structure} for a formal syntax of identifiers. + +Identifiers have two uses within Scheme programs: + + +@itemize @bullet + +@item +Any identifier may be used as a variable +or as a syntactic keyword +(see sections @pxref{Variables; syntactic keywords; and regions} and @pxref{Macros}). + +@item +When an identifier appears as a literal or within a literal +(see section @pxref{Literal expressions}), it is being used to denote a @emph{symbol} +(see section @pxref{Symbols}). + + +@end itemize + +@cindex @w{syntactic keyword} +@cindex @w{variable} + +@c \label{keywordsection} +@c The following identifiers are syntactic keywords, and should not be used +@c as variables: + +@c \begin{scheme} +@c => do or +@c and else quasiquote +@c begin if quote +@c case lambda set! +@c cond let unquote +@c define let* unquote-splicing +@c delay letrec% +@c \end{scheme} + +@c Some implementations allow all identifiers, including syntactic +@c keywords, to be used as variables. This is a compatible extension to +@c the language, but ambiguities in the language result when the +@c restriction is relaxed, and the ways in which these ambiguities are +@c resolved vary between implementations. + + +@node Whitespace and comments, Other notations, Identifiers, Lexical conventions +@section Whitespace and comments + + +@dfn{Whitespace} characters are spaces and newlines. +@cindex @w{Whitespace} +(Implementations typically provide additional whitespace characters such +as tab or page break.) Whitespace is used for improved readability and +as necessary to separate tokens from each other, a token being an +indivisible lexical unit such as an identifier or number, but is +otherwise insignificant. Whitespace may occur between any two tokens, +but not within a token. Whitespace may also occur inside a string, +where it is significant. + +A semicolon (@t{;}) indicates the start of a +comment. The comment continues to the +@cindex @w{;} +@cindex @w{comment} +end of the line on which the semicolon appears. Comments are invisible +to Scheme, but the end of the line is visible as whitespace. This +prevents a comment from appearing in the middle of an identifier or +number. + + +@example + +;;; The FACT procedure computes the factorial +;;; of a non-negative integer. +(define fact + (lambda (n) + (if (= n 0) + 1 ;Base case: return 1 + (* n (fact (- n 1)))))) + +@end example + + + +@node Other notations, , Whitespace and comments, Lexical conventions +@section Other notations + + +@ignore todo +Rewrite? +@end ignore + + +For a description of the notations used for numbers, see +section @ref{Numbers}. + + +@table @t + + +@item @t{.@: + -} +These are used in numbers, and may also occur anywhere in an identifier +except as the first character. A delimited plus or minus sign by itself +is also an identifier. +A delimited period (not occurring within a number or identifier) is used +in the notation for pairs (section @pxref{Pairs and lists}), and to indicate a +rest-parameter in a formal parameter list (section @pxref{Procedures}). +A delimited sequence of three successive periods is also an identifier. + +@item @t{( )} +Parentheses are used for grouping and to notate lists +(section @pxref{Pairs and lists}). + +@item @t{'} +The single quote character is used to indicate literal data (section @pxref{Literal expressions}). + +@item @t{`} +The backquote character is used to indicate almost-constant +data (section @pxref{Quasiquotation}). + +@item @t{, ,@@} +The character comma and the sequence comma at-sign are used in conjunction +with backquote (section @pxref{Quasiquotation}). + +@item @t{"} +The double quote character is used to delimit strings (section @pxref{Strings}). + +@item \ +Backslash is used in the syntax for character constants +(section @pxref{Characters}) and as an escape character within string +constants (section @pxref{Strings}). + +@c A box used because \verb is not allowed in command arguments. + +@item @w{@t{[ ] @{ @} |}} +Left and right square brackets and curly braces and vertical bar +are reserved for possible future extensions to the language. + +@item # + Sharp sign is used for a variety of purposes depending on +the character that immediately follows it: + +@item @t{#t} @t{#f} +These are the boolean constants (section @pxref{Booleans}). + +@item #\ +This introduces a character constant (section @pxref{Characters}). + +@item #@t{(} +This introduces a vector constant (section @pxref{Vectors}). Vector constants +are terminated by @t{)} . + +@item @t{#e #i #b #o #d #x} +These are used in the notation for numbers (section @pxref{Syntax of numerical constants}). + +@end table + + +@c @include{basic} + +@c \vfill\eject +@node Basic concepts, Expressions, Lexical conventions, top +@chapter Basic concepts + +@menu +* Variables; syntactic keywords; and regions:: +* Disjointness of types:: +* External representations:: +* Storage model:: +* Proper tail recursion:: +@end menu + + + +@node Variables; syntactic keywords; and regions, Disjointness of types, Basic concepts, Basic concepts +@section Variables; syntactic keywords; and regions + + + + +An identifier may name a type of syntax, or it may name +@cindex @w{identifier} +a location where a value can be stored. An identifier that names a type +of syntax is called a @emph{syntactic keyword} +@cindex @w{syntactic keyword} +and is said to be @emph{bound} to that syntax. An identifier that names a +location is called a @emph{variable} and is said to be +@cindex @w{variable} +@emph{bound} to that location. The set of all visible +bindings in effect at some point in a program is +@cindex @w{binding} +known as the @emph{environment} in effect at that point. The value +stored in the location to which a variable is bound is called the +variable's value. By abuse of terminology, the variable is sometimes +said to name the value or to be bound to the value. This is not quite +accurate, but confusion rarely results from this practice. + +@ignore todo +Define ``assigned'' and ``unassigned'' perhaps? +@end ignore + + +@ignore todo +In programs without side effects, one can safely pretend that the +variables are bound directly to the arguments. Or: +In programs without @code{set!}, one can safely pretend that the +@vindex @w{set!} +variable is bound directly to the value. +@end ignore + + +Certain expression types are used to create new kinds of syntax +and bind syntactic keywords to those new syntaxes, while other +expression types create new locations and bind variables to those +locations. These expression types are called @emph{binding constructs}. + +@cindex @w{binding construct} +Those that bind syntactic keywords are listed in section @ref{Macros}. +The most fundamental of the variable binding constructs is the +@samp{lambda} expression, because all other variable binding constructs +can be explained in terms of @samp{lambda} expressions. The other +variable binding constructs are @samp{let}, @samp{let*}, @samp{letrec}, +and @samp{do} expressions (see sections @pxref{Procedures}, @pxref{Binding constructs}, and +@pxref{Iteration}). + +@c Note: internal definitions not mentioned here. + +Like Algol and Pascal, and unlike most other dialects of Lisp +except for Common Lisp, Scheme is a statically scoped language with +block structure. To each place where an identifier is bound in a program +there corresponds a @dfn{region} of the program text within which +@cindex @w{region} +the binding is visible. The region is determined by the particular +binding construct that establishes the binding; if the binding is +established by a @samp{lambda} expression, for example, then its region +is the entire @samp{lambda} expression. Every mention of an identifier +refers to the binding of the identifier that established the +innermost of the regions containing the use. If there is no binding of +the identifier whose region contains the use, then the use refers to the +binding for the variable in the top level environment, if any +(chapters @pxref{Expressions} and @pxref{Standard procedures}); if there is no +binding for the identifier, +it is said to be @dfn{unbound}. +@cindex @w{top level environment} +@cindex @w{bound} +@cindex @w{unbound} + +@ignore todo +Mention that some implementations have multiple top level environments? +@end ignore + + +@ignore todo +Pitman sez: needs elaboration in case of @t{(let ...)} +@end ignore + + +@ignore todo +Pitman asks: say something about vars created after scheme starts? +@t{(define x 3) (define (f) x) (define (g) y) (define y 4)} +Clinger replies: The language was explicitly +designed to permit a view in which no variables are created after +Scheme starts. In files, you can scan out the definitions beforehand. +I think we're agreed on the principle that interactive use should +approximate that behavior as closely as possible, though we don't yet +agree on which programming environment provides the best approximation. +@end ignore + + +@node Disjointness of types, External representations, Variables; syntactic keywords; and regions, Basic concepts +@section Disjointness of types + + + +No object satisfies more than one of the following predicates: + + +@example + +boolean? pair? +symbol? number? +char? string? +vector? port? +procedure? + +@end example + + +These predicates define the types @emph{boolean}, @emph{pair}, @emph{symbol}, @emph{number}, @emph{char} (or @emph{character}), @emph{string}, @emph{vector}, @emph{port}, and @emph{procedure}. The empty list is a special +object of its own type; it satisfies none of the above predicates. + +@vindex symbol? +@vindex pair? +@vindex boolean? +@cindex @w{type} + +@vindex vector? +@vindex string? +@vindex char? +@vindex number? + +@cindex @w{empty list} +@vindex procedure? +@vindex port? + +Although there is a separate boolean type, +any Scheme value can be used as a boolean value for the purpose of a +conditional test. As explained in section @ref{Booleans}, all +values count as true in such a test except for @t{#f}. +@c and possibly the empty list. +@c The only value that is guaranteed to count as +@c false is \schfalse{}. It is explicitly unspecified whether the empty list +@c counts as true or as false. +This report uses the word ``true'' to refer to any +Scheme value except @t{#f}, and the word ``false'' to refer to +@t{#f}. +@cindex @w{false} +@cindex @w{true} + +@node External representations, Storage model, Disjointness of types, Basic concepts +@section External representations + + + +An important concept in Scheme (and Lisp) is that of the @emph{external +representation} of an object as a sequence of characters. For example, +an external representation of the integer 28 is the sequence of +characters ``@t{28}'', and an external representation of a list consisting +of the integers 8 and 13 is the sequence of characters ``@t{(8 13)}''. + +The external representation of an object is not necessarily unique. The +integer 28 also has representations ``@t{#e28.000}'' and ``@t{#x1c}'', and the +list in the previous paragraph also has the representations ``@t{( 08 13 +)}'' and ``@t{(8 .@: (13 .@: ()))}'' (see section @pxref{Pairs and lists}). + +Many objects have standard external representations, but some, such as +procedures, do not have standard representations (although particular +implementations may define representations for them). + +An external representation may be written in a program to obtain the +corresponding object (see @samp{quote}, section @pxref{Literal expressions}). + +External representations can also be used for input and output. The +procedure @samp{read} (section @pxref{Input}) parses external +representations, and the procedure @samp{write} (section @pxref{Output}) +generates them. Together, they provide an elegant and powerful +input/output facility. + +Note that the sequence of characters ``@t{(+ 2 6)}'' is @emph{not} an +external representation of the integer 8, even though it @emph{is} an +expression evaluating to the integer 8; rather, it is an external +representation of a three-element list, the elements of which are the symbol +@t{+} and the integers 2 and 6. Scheme's syntax has the property that +any sequence of characters that is an expression is also the external +representation of some object. This can lead to confusion, since it may +not be obvious out of context whether a given sequence of characters is +intended to denote data or program, but it is also a source of power, +since it facilitates writing programs such as interpreters and +compilers that treat programs as data (or vice versa). + +The syntax of external representations of various kinds of objects +accompanies the description of the primitives for manipulating the +objects in the appropriate sections of chapter @ref{Standard procedures}. + +@node Storage model, Proper tail recursion, External representations, Basic concepts +@section Storage model + + + +Variables and objects such as pairs, vectors, and strings implicitly +denote locations or sequences of locations. A string, for +@cindex @w{location} +example, denotes as many locations as there are characters in the string. +(These locations need not correspond to a full machine word.) A new value may be +stored into one of these locations using the @t{string-set!} procedure, but +the string continues to denote the same locations as before. + +An object fetched from a location, by a variable reference or by +a procedure such as @samp{car}, @samp{vector-ref}, or @samp{string-ref}, is +equivalent in the sense of @code{eqv?} +@c and \ide{eq?} ?? +(section @pxref{Equivalence predicates}) +@vindex @w{eqv?} +to the object last stored in the location before the fetch. + +Every location is marked to show whether it is in use. +No variable or object ever refers to a location that is not in use. +Whenever this report speaks of storage being allocated for a variable +or object, what is meant is that an appropriate number of locations are +chosen from the set of locations that are not in use, and the chosen +locations are marked to indicate that they are now in use before the variable +or object is made to denote them. + +In many systems it is desirable for constants (i.e. the values of +@cindex @w{constant} +literal expressions) to reside in read-only-memory. To express this, it is +convenient to imagine that every object that denotes locations is associated +with a flag telling whether that object is mutable or +@cindex @w{mutable} +immutable. In such systems literal constants and the strings +@cindex @w{immutable} +returned by @code{symbol->string} are immutable objects, while all objects +@vindex @w{symbol->string} +created by the other procedures listed in this report are mutable. It is an +error to attempt to store a new value into a location that is denoted by an +immutable object. + +@node Proper tail recursion, , Storage model, Basic concepts +@section Proper tail recursion + + + +Implementations of Scheme are required to be +@emph{properly tail-recursive}. +@cindex @w{proper tail recursion} +Procedure calls that occur in certain syntactic +contexts defined below are `tail calls'. A Scheme implementation is +properly tail-recursive if it supports an unbounded number of active +tail calls. A call is @emph{active} if the called procedure may still +return. Note that this includes calls that may be returned from either +by the current continuation or by continuations captured earlier by +@samp{call-with-current-continuation} that are later invoked. +In the absence of captured continuations, calls could +return at most once and the active calls would be those that had not +yet returned. +A formal definition of proper tail recursion can be found +in [propertailrecursion]. + + +@quotation +@emph{Rationale:} + +Intuitively, no space is needed for an active tail call because the +continuation that is used in the tail call has the same semantics as the +continuation passed to the procedure containing the call. Although an improper +implementation might use a new continuation in the call, a return +to this new continuation would be followed immediately by a return +to the continuation passed to the procedure. A properly tail-recursive +implementation returns to that continuation directly. + +Proper tail recursion was one of the central ideas in Steele and +Sussman's original version of Scheme. Their first Scheme interpreter +implemented both functions and actors. Control flow was expressed using +actors, which differed from functions in that they passed their results +on to another actor instead of returning to a caller. In the terminology +of this section, each actor finished with a tail call to another actor. + +Steele and Sussman later observed that in their interpreter the code +for dealing with actors was identical to that for functions and thus +there was no need to include both in the language. + +@end quotation + + +A @emph{tail call} is a procedure call that occurs +@cindex @w{tail call} +in a @emph{tail context}. Tail contexts are defined inductively. Note +that a tail context is always determined with respect to a particular lambda +expression. + + + +@itemize @bullet + +@item +The last expression within the body of a lambda expression, +shown as @r{} below, occurs in a tail context. + +@format +@t{(lambda + * * ) +} + +@end format + + + +@item +If one of the following expressions is in a tail context, +then the subexpressions shown as are in a tail context. +These were derived from rules in the grammar given in +chapter @ref{Formal syntax and semantics} by replacing some occurrences of +with . Only those rules that contain tail contexts +are shown here. + + +@format +@t{(if ) +(if ) + +(cond +) +(cond * (else )) + +(case + +) +(case + * + (else )) + +(and * ) +(or * ) + +(let (*) ) +(let (*) ) +(let* (*) ) +(letrec (*) ) + +(let-syntax (*) ) +(letrec-syntax (*) ) + +(begin ) + +(do (*) + ( ) + *) + +@r{where} + + --> ( ) + --> ((*) ) + + --> * + --> * +} + +@end format + + + +@item +If a @samp{cond} expression is in a tail context, and has a clause of +the form @samp{(@r{} => @r{})} +then the (implied) call to +the procedure that results from the evaluation of @r{} is in a +tail context. @r{} itself is not in a tail context. + + +@end itemize + + +Certain built-in procedures are also required to perform tail calls. +The first argument passed to @code{apply} and to +@vindex @w{apply} +@code{call-with-current-continuation}, and the second argument passed to +@vindex @w{call-with-current-continuation} +@code{call-with-values}, must be called via a tail call. +@vindex @w{call-with-values} +Similarly, @code{eval} must evaluate its argument as if it +@vindex @w{eval} +were in tail position within the @code{eval} procedure. +@vindex @w{eval} + +In the following example the only tail call is the call to @samp{f}. +None of the calls to @samp{g} or @samp{h} are tail calls. The reference to +@samp{x} is in a tail context, but it is not a call and thus is not a +tail call. + +@example + +(lambda () + (if (g) + (let ((x (h))) + x) + (and (g) (f)))) + +@end example + + + +@quotation +@emph{Note:} +Implementations are allowed, but not required, to +recognize that some non-tail calls, such as the call to @samp{h} +above, can be evaluated as though they were tail calls. +In the example above, the @samp{let} expression could be compiled +as a tail call to @samp{h}. (The possibility of @samp{h} returning +an unexpected number of values can be ignored, because in that +case the effect of the @samp{let} is explicitly unspecified and +implementation-dependent.) +@end quotation + + + +@c @include{expr} + +@c \vfill\eject +@node Expressions, Program structure, Basic concepts, top +@chapter Expressions + +@menu +* Primitive expression types:: +* Derived expression types:: +* Macros:: +@end menu + + + +@c \newcommand{\syntax}{{\em Syntax: }} +@c \newcommand{\semantics}{{\em Semantics: }} + +@c [Deleted for R5RS because of multiple-value returns. -RK] +@c A Scheme expression is a construct that returns a value, such as a +@c variable reference, literal, procedure call, or conditional. + +Expression types are categorized as @emph{primitive} or @emph{derived}. +Primitive expression types include variables and procedure calls. +Derived expression types are not semantically primitive, but can instead +be defined as macros. +With the exception of @samp{quasiquote}, whose macro definition is complex, +the derived expressions are classified as library features. +Suitable definitions are given in section @ref{Derived expression type}. + +@node Primitive expression types, Derived expression types, Expressions, Expressions +@section Primitive expression types + +@menu +* Variable references:: +* Literal expressions:: +* Procedure calls:: +* Procedures:: +* Conditionals:: +* Assignments:: +@end menu + + + +@node Variable references, Literal expressions, Primitive expression types, Primitive expression types +@subsection Variable references + + + +@deffn {syntax} @r{} + + +An expression consisting of a variable +@cindex @w{variable} +(section @pxref{Variables; syntactic keywords; and regions}) is a variable reference. The value of +the variable reference is the value stored in the location to which the +variable is bound. It is an error to reference an +unbound variable. +@cindex @w{unbound} + + +@format +@t{(define x 28) +x ==> 28 +} +@end format + +@end deffn + +@node Literal expressions, Procedure calls, Variable references, Primitive expression types +@subsection Literal expressions + + + + +@deffn {syntax} quote @r{} + +@deffnx {syntax} @t{'}@r{} + + +@deffnx {syntax} @r{} + + +@samp{(quote @r{})} evaluates to @r{}. +@cindex @w{'} +@r{} +may be any external representation of a Scheme object (see +section @pxref{External representations}). This notation is used to include literal +constants in Scheme code. + + +@format +@t{ +(quote a) ==> a +(quote #(a b c)) ==> #(a b c) +(quote (+ 1 2)) ==> (+ 1 2) +} +@end format + + +@samp{(quote @r{})} may be abbreviated as +@t{'}@r{}. The two notations are equivalent in all +respects. + + +@format +@t{'a ==> a +'#(a b c) ==> #(a b c) +'() ==> () +'(+ 1 2) ==> (+ 1 2) +'(quote a) ==> (quote a) +''a ==> (quote a) +} +@end format + + +Numerical constants, string constants, character constants, and boolean +constants evaluate ``to themselves''; they need not be quoted. + + +@format +@t{'"abc" ==> "abc" +"abc" ==> "abc" +'145932 ==> 145932 +145932 ==> 145932 +'#t ==> #t +#t ==> #t +} +@end format + + +As noted in section @ref{Storage model}, it is an error to alter a constant +(i.e. the value of a literal expression) using a mutation procedure like +@samp{set-car!} or @samp{string-set!}. + +@end deffn + + +@node Procedure calls, Procedures, Literal expressions, Primitive expression types +@subsection Procedure calls + + + +@deffn {syntax} @r{} @r{} @dots{}, + + +A procedure call is written by simply enclosing in parentheses +expressions for the procedure to be called and the arguments to be +passed to it. The operator and operand expressions are evaluated (in an +unspecified order) and the resulting procedure is passed the resulting +arguments. +@cindex @w{procedure call} +@cindex @w{call} + +@format +@t{ +(+ 3 4) ==> 7 +((if #f + *) 3 4) ==> 12 +} +@end format + + +A number of procedures are available as the values of variables in the +initial environment; for example, the addition and multiplication +procedures in the above examples are the values of the variables @samp{+} +and @samp{*}. New procedures are created by evaluating lambda expressions +(see section @pxref{Procedures}). +@ignore todo +At Friedman's request, flushed mention of other ways. +@end ignore + +@c or definitions (see section~\ref{define}). + +Procedure calls may return any number of values (see @code{values} in +@vindex @w{values} +section @pxref{Control features}). With the exception of @samp{values} +the procedures available in the initial environment return one +value or, for procedures such as @samp{apply}, pass on the values returned +by a call to one of their arguments. + +Procedure calls are also called @emph{combinations}. + +@cindex @w{combination} + + +@quotation +@emph{Note:} In contrast to other dialects of Lisp, the order of +evaluation is unspecified, and the operator expression and the operand +expressions are always evaluated with the same evaluation rules. +@end quotation + + + +@quotation +@emph{Note:} +Although the order of evaluation is otherwise unspecified, the effect of +any concurrent evaluation of the operator and operand expressions is +constrained to be consistent with some sequential order of evaluation. +The order of evaluation may be chosen differently for each procedure call. +@end quotation + + + +@quotation +@emph{Note:} In many dialects of Lisp, the empty combination, @t{()}, is a legitimate expression. In Scheme, combinations must have at +least one subexpression, so @t{()} is not a syntactically valid +expression. +@ignore todo +Dybvig: ``it should be obvious from the syntax.'' +@end ignore + +@end quotation + + +@ignore todo +Freeman: +I think an explanation as to why evaluation order is not specified +should be included. It should not include any reference to parallel +evaluation. Does any existing compiler generate better code because +the evaluation order is unspecified? Clinger: yes: T3, MacScheme v2, +probably MIT Scheme and Chez Scheme. But that's not the main reason +for leaving the order unspecified. +@end ignore + + +@end deffn + + +@node Procedures, Conditionals, Procedure calls, Primitive expression types +@subsection Procedures + + + + +@deffn {syntax} lambda @r{} @r{} + +@emph{Syntax:} +@r{} should be a formal arguments list as described below, +and @r{} should be a sequence of one or more expressions. + +@emph{Semantics:} +A lambda expression evaluates to a procedure. The environment in +effect when the lambda expression was evaluated is remembered as part of the +procedure. When the procedure is later called with some actual +arguments, the environment in which the lambda expression was evaluated will +be extended by binding the variables in the formal argument list to +fresh locations, the corresponding actual argument values will be stored +in those locations, and the expressions in the body of the lambda expression +will be evaluated sequentially in the extended environment. +The result(s) of the last expression in the body will be returned as +the result(s) of the procedure call. + + +@format +@t{(lambda (x) (+ x x)) ==> @emph{}a procedure +((lambda (x) (+ x x)) 4) ==> 8 + +(define reverse-subtract + (lambda (x y) (- y x))) +(reverse-subtract 7 10) ==> 3 + +(define add4 + (let ((x 4)) + (lambda (y) (+ x y)))) +(add4 6) ==> 10 +} +@end format + + +@r{} should have one of the following forms: + + + +@itemize @bullet + +@item +@t{(@r{} @dots{},)}: +The procedure takes a fixed number of arguments; when the procedure is +called, the arguments will be stored in the bindings of the +corresponding variables. + +@item +@r{}: +The procedure takes any number of arguments; when the procedure is +called, the sequence of actual arguments is converted into a newly +allocated list, and the list is stored in the binding of the +@r{}. + +@item +@t{(@r{} @dots{}, @r{} @b{.} +@r{})}: +If a space-delimited period precedes the last variable, then +the procedure takes n or more arguments, where n is the +number of formal arguments before the period (there must +be at least one). +The value stored in the binding of the last variable will be a +newly allocated +list of the actual arguments left over after all the other actual +arguments have been matched up against the other formal arguments. + +@end itemize + + +It is an error for a @r{} to appear more than once in +@r{}. + + +@format +@t{((lambda x x) 3 4 5 6) ==> (3 4 5 6) +((lambda (x y . z) z) + 3 4 5 6) ==> (5 6) +} +@end format + + +Each procedure created as the result of evaluating a lambda expression is +(conceptually) tagged +with a storage location, in order to make @code{eqv?} and +@vindex @w{eqv?} +@code{eq?} work on procedures (see section @pxref{Equivalence predicates}). +@vindex @w{eq?} + +@end deffn + + +@node Conditionals, Assignments, Procedures, Primitive expression types +@subsection Conditionals + + + +@deffn {syntax} if @r{} @r{} @r{} +@deffnx {syntax} if @r{} @r{} +@c \/ if hyper = italic + +@emph{Syntax:} +@r{}, @r{}, and @r{} may be arbitrary +expressions. + +@emph{Semantics:} +An @samp{if} expression is evaluated as follows: first, +@r{} is evaluated. If it yields a true value (see +@cindex @w{true} +section @pxref{Booleans}), then @r{} is evaluated and +its value(s) is(are) returned. Otherwise @r{} is evaluated and its +value(s) is(are) returned. If @r{} yields a false value and no +@r{} is specified, then the result of the expression is +unspecified. + + +@format +@t{(if (> 3 2) 'yes 'no) ==> yes +(if (> 2 3) 'yes 'no) ==> no +(if (> 3 2) + (- 3 2) + (+ 3 2)) ==> 1 +} +@end format + + +@end deffn + + +@node Assignments, , Conditionals, Primitive expression types +@subsection Assignments + + + + +@deffn {syntax} set! @r{} @r{} + +@r{} is evaluated, and the resulting value is stored in +the location to which @r{} is bound. @r{} must +be bound either in some region enclosing the @samp{set!} expression +@cindex @w{region} +or at top level. The result of the @samp{set!} expression is +unspecified. + + +@format +@t{(define x 2) +(+ x 1) ==> 3 +(set! x 4) ==> @emph{unspecified} +(+ x 1) ==> 5 +} +@end format + + +@end deffn + + +@node Derived expression types, Macros, Primitive expression types, Expressions +@section Derived expression types + +@menu +* Conditional:: +* Binding constructs:: +* Sequencing:: +* Iteration:: +* Delayed evaluation:: +* Quasiquotation:: +@end menu + + + +The constructs in this section are hygienic, as discussed in +section @ref{Macros}. +For reference purposes, section @ref{Derived expression type} gives macro definitions +that will convert most of the constructs described in this section +into the primitive constructs described in the previous section. + +@ignore todo +Mention that no definition of backquote is provided? +@end ignore + + +@node Conditional, Binding constructs, Derived expression types, Derived expression types +@subsection Conditionals + + + +@deffn {library syntax} cond @dots{}, + +@emph{Syntax:} +Each @r{} should be of the form + +@format +@t{(@r{} @r{} @dots{},) +} +@end format + +where @r{} is any expression. Alternatively, a @r{} may be +of the form + +@format +@t{(@r{} => @r{}) +} +@end format + +The last @r{} may be +an ``else clause,'' which has the form + +@format +@t{(else @r{} @r{} @dots{},)@r{.} +} +@end format + + +@cindex @w{else} + +@cindex @w{=>} + +@emph{Semantics:} +A @samp{cond} expression is evaluated by evaluating the @r{} +expressions of successive @r{}s in order until one of them +evaluates to a true value (see +@cindex @w{true} +section @pxref{Booleans}). When a @r{} evaluates to a true +value, then the remaining @r{}s in its @r{} are +evaluated in order, and the result(s) of the last @r{} in the +@r{} is(are) returned as the result(s) of the entire @samp{cond} +expression. If the selected @r{} contains only the +@r{} and no @r{}s, then the value of the +@r{} is returned as the result. If the selected @r{} uses the +@code{=>} alternate form, then the @r{} is evaluated. +@vindex @w{=>} +Its value must be a procedure that accepts one argument; this procedure is then +called on the value of the @r{} and the value(s) returned by this +procedure is(are) returned by the @samp{cond} expression. +If all @r{}s evaluate +to false values, and there is no else clause, then the result of +the conditional expression is unspecified; if there is an else +clause, then its @r{}s are evaluated, and the value(s) of +the last one is(are) returned. + + +@format +@t{(cond ((> 3 2) 'greater) + ((< 3 2) 'less)) ==> greater + +(cond ((> 3 3) 'greater) + ((< 3 3) 'less) + (else 'equal)) ==> equal + +(cond ((assv 'b '((a 1) (b 2))) => cadr) + (else #f)) ==> 2 +} +@end format + + + +@end deffn + + + +@deffn {library syntax} case @r{} @dots{}, + +@emph{Syntax:} +@r{} may be any expression. Each @r{} should have +the form + +@format +@t{((@r{} @dots{},) @r{} @r{} @dots{},)@r{,} +} +@end format + +where each @r{} is an external representation of some object. +All the @r{}s must be distinct. +The last @r{} may be an ``else clause,'' which has the form + +@format +@t{(else @r{} @r{} @dots{},)@r{.} +} +@end format + + +@vindex else + +@emph{Semantics:} +A @samp{case} expression is evaluated as follows. @r{} is +evaluated and its result is compared against each @r{}. If the +result of evaluating @r{} is equivalent (in the sense of +@samp{eqv?}; see section @pxref{Equivalence predicates}) to a @r{}, then the +expressions in the corresponding @r{} are evaluated from left +to right and the result(s) of the last expression in the @r{} is(are) +returned as the result(s) of the @samp{case} expression. If the result of +evaluating @r{} is different from every @r{}, then if +there is an else clause its expressions are evaluated and the +result(s) of the last is(are) the result(s) of the @samp{case} expression; +otherwise the result of the @samp{case} expression is unspecified. + + +@format +@t{(case (* 2 3) + ((2 3 5 7) 'prime) + ((1 4 6 8 9) 'composite)) ==> composite +(case (car '(c d)) + ((a) 'a) + ((b) 'b)) ==> @emph{unspecified} +(case (car '(c d)) + ((a e i o u) 'vowel) + ((w y) 'semivowel) + (else 'consonant)) ==> consonant +} +@end format + + +@end deffn + + + +@deffn {library syntax} and @dots{}, + +The @r{} expressions are evaluated from left to right, and the +value of the first expression that evaluates to a false value (see +section @pxref{Booleans}) is returned. Any remaining expressions +are not evaluated. If all the expressions evaluate to true values, the +value of the last expression is returned. If there are no expressions +then @t{#t} is returned. + + +@format +@t{(and (= 2 2) (> 2 1)) ==> #t +(and (= 2 2) (< 2 1)) ==> #f +(and 1 2 'c '(f g)) ==> (f g) +(and) ==> #t +} +@end format + + +@end deffn + + + +@deffn {library syntax} or @dots{}, + +The @r{} expressions are evaluated from left to right, and the value of the +first expression that evaluates to a true value (see +section @pxref{Booleans}) is returned. Any remaining expressions +are not evaluated. If all expressions evaluate to false values, the +value of the last expression is returned. If there are no +expressions then @t{#f} is returned. + + +@format +@t{(or (= 2 2) (> 2 1)) ==> #t +(or (= 2 2) (< 2 1)) ==> #t +(or #f #f #f) ==> #f +(or (memq 'b '(a b c)) + (/ 3 0)) ==> (b c) +} +@end format + + +@end deffn + + +@node Binding constructs, Sequencing, Conditional, Derived expression types +@subsection Binding constructs + + +The three binding constructs @samp{let}, @samp{let*}, and @samp{letrec} +give Scheme a block structure, like Algol 60. The syntax of the three +constructs is identical, but they differ in the regions they establish +@cindex @w{region} +for their variable bindings. In a @samp{let} expression, the initial +values are computed before any of the variables become bound; in a +@samp{let*} expression, the bindings and evaluations are performed +sequentially; while in a @samp{letrec} expression, all the bindings are in +effect while their initial values are being computed, thus allowing +mutually recursive definitions. + + +@deffn {library syntax} let @r{} @r{} + +@emph{Syntax:} +@r{} should have the form + +@format +@t{((@r{} @r{}) @dots{},)@r{,} +} +@end format + +where each @r{} is an expression, and @r{} should be a +sequence of one or more expressions. It is +an error for a @r{} to appear more than once in the list of variables +being bound. + +@emph{Semantics:} +The @r{}s are evaluated in the current environment (in some +unspecified order), the @r{}s are bound to fresh locations +holding the results, the @r{} is evaluated in the extended +environment, and the value(s) of the last expression of @r{} +is(are) returned. Each binding of a @r{} has @r{} as its +region. +@cindex @w{region} + + +@format +@t{(let ((x 2) (y 3)) + (* x y)) ==> 6 + +(let ((x 2) (y 3)) + (let ((x 7) + (z (+ x y))) + (* z x))) ==> 35 +} +@end format + + +See also named @samp{let}, section @ref{Iteration}. + +@end deffn + + + +@deffn {library syntax} let* @r{} @r{} + + +@emph{Syntax:} +@r{} should have the form + +@format +@t{((@r{} @r{}) @dots{},)@r{,} +} +@end format + +and @r{} should be a sequence of +one or more expressions. + +@emph{Semantics:} +@samp{Let*} is similar to @samp{let}, but the bindings are performed +sequentially from left to right, and the region of a binding indicated +@cindex @w{region} +by @samp{(@r{} @r{})} is that part of the @samp{let*} +expression to the right of the binding. Thus the second binding is done +in an environment in which the first binding is visible, and so on. + + +@format +@t{(let ((x 2) (y 3)) + (let* ((x 7) + (z (+ x y))) + (* z x))) ==> 70 +} +@end format + + +@end deffn + + + +@deffn {library syntax} letrec @r{} @r{} + +@emph{Syntax:} +@r{} should have the form + +@format +@t{((@r{} @r{}) @dots{},)@r{,} +} +@end format + +and @r{} should be a sequence of +one or more expressions. It is an error for a @r{} to appear more +than once in the list of variables being bound. + +@emph{Semantics:} +The @r{}s are bound to fresh locations holding undefined +values, the @r{}s are evaluated in the resulting environment (in +some unspecified order), each @r{} is assigned to the result +of the corresponding @r{}, the @r{} is evaluated in the +resulting environment, and the value(s) of the last expression in +@r{} is(are) returned. Each binding of a @r{} has the +entire @samp{letrec} expression as its region, making it possible to +@cindex @w{region} +define mutually recursive procedures. + + +@format +@t{(letrec ((even? + (lambda (n) + (if (zero? n) + #t + (odd? (- n 1))))) + (odd? + (lambda (n) + (if (zero? n) + #f + (even? (- n 1)))))) + (even? 88)) + ==> #t +} +@end format + + +One restriction on @samp{letrec} is very important: it must be possible +to evaluate each @r{} without assigning or referring to the value of any +@r{}. If this restriction is violated, then it is an error. The +restriction is necessary because Scheme passes arguments by value rather than by +name. In the most common uses of @samp{letrec}, all the @r{}s are +lambda expressions and the restriction is satisfied automatically. + +@c \todo{use or uses? --- Jinx.} + +@end deffn + + +@node Sequencing, Iteration, Binding constructs, Derived expression types +@subsection Sequencing + + + +@deffn {library syntax} begin @dots{}, + +The @r{}s are evaluated sequentially from left to right, +and the value(s) of the last @r{} is(are) returned. This +expression type is used to sequence side effects such as input and +output. + + +@format +@t{(define x 0) + +(begin (set! x 5) + (+ x 1)) ==> 6 + +(begin (display "4 plus 1 equals ") + (display (+ 4 1))) ==> @emph{unspecified} + @emph{and prints} 4 plus 1 equals 5 +} +@end format + + +@end deffn + + +@node Iteration, Delayed evaluation, Sequencing, Derived expression types +@subsection Iteration + +@c \unsection + + +@noindent + +@deffn {library syntax} do ((@r{} @r{} @r{}) @dots{}) (@r{} @r{} @dots{}) @r{} @dots{} +@cindex @w{do} + +@samp{Do} is an iteration construct. It specifies a set of variables to +be bound, how they are to be initialized at the start, and how they are +to be updated on each iteration. When a termination condition is met, +the loop exits after evaluating the @r{}s. + +@samp{Do} expressions are evaluated as follows: +The @r{} expressions are evaluated (in some unspecified order), +the @r{}s are bound to fresh locations, the results of the +@r{} expressions are stored in the bindings of the +@r{}s, and then the iteration phase begins. + +Each iteration begins by evaluating @r{}; if the result is +false (see section @pxref{Booleans}), then the @r{} +expressions are evaluated in order for effect, the @r{} +expressions are evaluated in some unspecified order, the +@r{}s are bound to fresh locations, the results of the +@r{}s are stored in the bindings of the +@r{}s, and the next iteration begins. + +If @r{} evaluates to a true value, then the +@r{}s are evaluated from left to right and the value(s) of +the last @r{} is(are) returned. If no @r{}s +are present, then the value of the @samp{do} expression is unspecified. + +The region of the binding of a @r{} +@cindex @w{region} +consists of the entire @samp{do} expression except for the @r{}s. +It is an error for a @r{} to appear more than once in the +list of @samp{do} variables. + +A @r{} may be omitted, in which case the effect is the +same as if @samp{(@r{} @r{} @r{})} had +been written instead of @samp{(@r{} @r{})}. + + +@format +@t{(do ((vec (make-vector 5)) + (i 0 (+ i 1))) + ((= i 5) vec) + (vector-set! vec i i)) ==> #(0 1 2 3 4) + +(let ((x '(1 3 5 7 9))) + (do ((x x (cdr x)) + (sum 0 (+ sum (car x)))) + ((null? x) sum))) ==> 25 +} +@end format + + +@c \end{entry} +@end deffn + + +@deffn {library syntax} let @r{} @r{} @r{} + + +``Named @samp{let}'' is a variant on the syntax of @code{let} which provides +@vindex @w{let} +a more general looping construct than @samp{do} and may also be used to express +recursions. +It has the same syntax and semantics as ordinary @samp{let} +except that @r{} is bound within @r{} to a procedure +whose formal arguments are the bound variables and whose body is +@r{}. Thus the execution of @r{} may be repeated by +invoking the procedure named by @r{}. + +@c | <-- right margin + +@format +@t{(let loop ((numbers '(3 -2 1 6 -5)) + (nonneg '()) + (neg '())) + (cond ((null? numbers) (list nonneg neg)) + ((>= (car numbers) 0) + (loop (cdr numbers) + (cons (car numbers) nonneg) + neg)) + ((< (car numbers) 0) + (loop (cdr numbers) + nonneg + (cons (car numbers) neg))))) + ==> ((6 1 3) (-5 -2)) +} +@end format + + +@end deffn + + +@node Delayed evaluation, Quasiquotation, Iteration, Derived expression types +@subsection Delayed evaluation + + + +@deffn {library syntax} delay @r{} + +@ignore todo +Fix. +@end ignore + + +The @samp{delay} construct is used together with the procedure @code{force} to +@vindex @w{force} +implement @dfn{lazy evaluation} or @dfn{call by need}. +@cindex @w{call by need} +@cindex @w{lazy evaluation} +@t{(delay @r{})} returns an object called a +@dfn{promise} which at some point in the future may be asked (by +@cindex @w{promise} +the @samp{force} procedure) +@ignore todo +Bartley's white lie; OK? +@end ignore + to evaluate +@r{}, and deliver the resulting value. +The effect of @r{} returning multiple values +is unspecified. + +See the description of @samp{force} (section @pxref{Control features}) for a +more complete description of @samp{delay}. + +@end deffn + + +@node Quasiquotation, , Delayed evaluation, Derived expression types +@subsection Quasiquotation + + + + +@deffn {syntax} quasiquote @r{} + +@deffnx {syntax} @t{`}@r{} + + +``Backquote'' or ``quasiquote'' expressions are useful +@cindex @w{backquote} +for constructing a list or vector structure when most but not all of the +desired structure is known in advance. If no +commas appear within the @r{}, the result of +@cindex @w{comma} +evaluating +@t{`}@r{} is equivalent to the result of evaluating +@t{'}@r{}. If a comma appears within the +@cindex @w{,} +@r{}, however, the expression following the comma is +evaluated (``unquoted'') and its result is inserted into the structure +instead of the comma and the expression. If a comma appears followed +immediately by an at-sign (@@), then the following +@cindex @w{,@@} +expression must evaluate to a list; the opening and closing parentheses +of the list are then ``stripped away'' and the elements of the list are +inserted in place of the comma at-sign expression sequence. A comma +at-sign should only appear within a list or vector @r{}. + +@c struck: "(in the sense of {\cf equal?})" after "equivalent" + + +@format +@t{`(list ,(+ 1 2) 4) ==> (list 3 4) +(let ((name 'a)) `(list ,name ',name)) + ==> (list a (quote a)) +`(a ,(+ 1 2) ,@@(map abs '(4 -5 6)) b) + ==> (a 3 4 5 6 b) +`((@samp{foo} ,(- 10 3)) ,@@(cdr '(c)) . ,(car '(cons))) + ==> ((foo 7) . cons) +`#(10 5 ,(sqrt 4) ,@@(map sqrt '(16 9)) 8) + ==> #(10 5 2 4 3 8) +} +@end format + + +Quasiquote forms may be nested. Substitutions are made only for +unquoted components appearing at the same nesting level +as the outermost backquote. The nesting level increases by one inside +each successive quasiquotation, and decreases by one inside each +unquotation. + + +@format +@t{`(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f) + ==> (a `(b ,(+ 1 2) ,(foo 4 d) e) f) +(let ((name1 'x) + (name2 'y)) + `(a `(b ,,name1 ,',name2 d) e)) + ==> (a `(b ,x ,'y d) e) +} +@end format + + +The two notations + @t{`}@r{} and @t{(quasiquote @r{})} + are identical in all respects. + @samp{,@r{}} is identical to @samp{(unquote @r{})}, + and + @samp{,@@@r{}} is identical to @samp{(unquote-splicing @r{})}. +The external syntax generated by @code{write} for two-element lists whose +@vindex @w{write} +car is one of these symbols may vary between implementations. + +@cindex @w{`} + + +@format +@t{(quasiquote (list (unquote (+ 1 2)) 4)) + ==> (list 3 4) +'(quasiquote (list (unquote (+ 1 2)) 4)) + ==> `(list ,(+ 1 2) 4) + @emph{}i.e., (quasiquote (list (unquote (+ 1 2)) 4)) +} +@end format + + +Unpredictable behavior can result if any of the symbols +@code{quasiquote}, @code{unquote}, or @code{unquote-splicing} appear in +@vindex @w{unquote-splicing} +@vindex @w{unquote} +@vindex @w{quasiquote} +positions within a @r{} otherwise than as described above. + +@end deffn + +@node Macros, , Derived expression types, Expressions +@section Macros + +@menu +* Binding constructs for syntactic keywords:: +* Pattern language:: +@end menu + + + +Scheme programs can define and use new derived expression types, + called @emph{macros}. +@cindex @w{macro} +Program-defined expression types have the syntax + +@example + +(@r{} @r{} ...) + +@end example + +where @r{} is an identifier that uniquely determines the +expression type. This identifier is called the @emph{syntactic +keyword}, or simply @emph{keyword}, of the macro. The +@cindex @w{macro keyword} +@cindex @w{keyword} +@cindex @w{syntactic keyword} +number of the @r{}s, and their syntax, depends on the +expression type. + +Each instance of a macro is called a @emph{use} +@cindex @w{macro use} +of the macro. +The set of rules that specifies +how a use of a macro is transcribed into a more primitive expression +is called the @emph{transformer} +@cindex @w{macro transformer} +of the macro. + +The macro definition facility consists of two parts: + + + +@itemize @bullet + +@item +A set of expressions used to establish that certain identifiers +are macro keywords, associate them with macro transformers, and control +the scope within which a macro is defined, and + +@item +a pattern language for specifying macro transformers. + +@end itemize + + +The syntactic keyword of a macro may shadow variable bindings, and local +variable bindings may shadow keyword bindings. All macros +@cindex @w{keyword} +defined using the pattern language are ``hygienic'' and ``referentially +transparent'' and thus preserve Scheme's lexical scoping [Kohlbecker86], [ +hygienic], [Bawden88], [macrosthatwork], [syntacticabstraction]: + +@cindex @w{hygienic} + +@cindex @w{referentially transparent} + + + + +@itemize @bullet + + +@item +If a macro transformer inserts a binding for an identifier +(variable or keyword), the identifier will in effect be renamed +throughout its scope to avoid conflicts with other identifiers. +Note that a @code{define} at top level may or may not introduce a binding; +see section @ref{Definitions}. + +@item +If a macro transformer inserts a free reference to an +identifier, the reference refers to the binding that was visible +where the transformer was specified, regardless of any local +bindings that may surround the use of the macro. + + +@end itemize + +@vindex @w{define} + +@c The low-level facility permits non-hygienic macros to be written, +@c and may be used to implement the high-level pattern language. + +@c The fourth section describes some features that would make the +@c low-level macro facility easier to use directly. + +@node Binding constructs for syntactic keywords, Pattern language, Macros, Macros +@subsection Binding constructs for syntactic keywords + + + +@samp{Let-syntax} and @samp{letrec-syntax} are +analogous to @samp{let} and @samp{letrec}, but they bind +syntactic keywords to macro transformers instead of binding variables +to locations that contain values. Syntactic keywords may also be +bound at top level; see section @ref{Syntax definitions}. + + +@deffn {syntax} let-syntax @r{} @r{} + +@emph{Syntax:} +@r{} should have the form + +@format +@t{((@r{} @r{}) @dots{},) +} +@end format + +Each @r{} is an identifier, +each @r{} is an instance of @samp{syntax-rules}, and +@r{} should be a sequence of one or more expressions. It is an error +for a @r{} to appear more than once in the list of keywords +being bound. + +@emph{Semantics:} +The @r{} is expanded in the syntactic environment +obtained by extending the syntactic environment of the +@samp{let-syntax} expression with macros whose keywords are +the @r{}s, bound to the specified transformers. +Each binding of a @r{} has @r{} as its region. + + +@format +@t{(let-syntax ((when (syntax-rules () + ((when test stmt1 stmt2 ...) + (if test + (begin stmt1 + stmt2 ...)))))) + (let ((if #t)) + (when if (set! if 'now)) + if)) ==> now + +(let ((x 'outer)) + (let-syntax ((m (syntax-rules () ((m) x)))) + (let ((x 'inner)) + (m)))) ==> outer +} +@end format + + +@end deffn + + +@deffn {syntax} letrec-syntax @r{} @r{} + +@emph{Syntax:} +Same as for @samp{let-syntax}. + +@emph{Semantics:} + The @r{} is expanded in the syntactic environment obtained by +extending the syntactic environment of the @samp{letrec-syntax} +expression with macros whose keywords are the +@r{}s, bound to the specified transformers. +Each binding of a @r{} has the @r{} +as well as the @r{} within its region, +so the transformers can +transcribe expressions into uses of the macros +introduced by the @samp{letrec-syntax} expression. + + +@format +@t{(letrec-syntax + ((my-or (syntax-rules () + ((my-or) #f) + ((my-or e) e) + ((my-or e1 e2 ...) + (let ((temp e1)) + (if temp + temp + (my-or e2 ...))))))) + (let ((x #f) + (y 7) + (temp 8) + (let odd?) + (if even?)) + (my-or x + (let temp) + (if y) + y))) ==> 7 +} +@end format + + +@end deffn + +@node Pattern language, , Binding constructs for syntactic keywords, Macros +@subsection Pattern language + + + +A @r{} has the following form: + + +@deffn {} syntax-rules @r{} @r{} @dots{}, + +@emph{Syntax:} +@r{} is a list of identifiers and each @r{} +should be of the form + +@format +@t{(@r{} @r{